From eb0612aaf49fa43059b1ccbd0baef1629ec6c65a Mon Sep 17 00:00:00 2001 From: Camm Maguire Date: Tue, 28 Oct 2014 13:56:15 +0000 Subject: [PATCH 1/1] Import gcl_2.6.12.orig.tar.gz [dgit import orig gcl_2.6.12.orig.tar.gz] --- AC_FD_CC | 10 + AC_FD_MSG | 1 + COPYING.LIB-2.0 | 481 + ChangeLog | 532 + ChangeLog.old | 218 + README.macosx | 9 + README.openbsd | 40 + README.wine | 17 + RELEASE-2.5.1 | 138 + RELEASE-2.6.2.html | 1599 + add-defs | 139 + add-defs.bat | 63 + add-defs1 | 89 + ansi-tests/.cvsignore | 5 + ansi-tests/README | 14 + ansi-tests/adjustable-array-p.lsp | 68 + ansi-tests/and.lsp | 57 + ansi-tests/ansi-aux.lsp | 1457 + ansi-tests/apply.lsp | 61 + ansi-tests/aref.lsp | 144 + ansi-tests/array-as-class.lsp | 66 + ansi-tests/array-aux.lsp | 205 + ansi-tests/array-dimension.lsp | 63 + ansi-tests/array-dimensions.lsp | 69 + ansi-tests/array-displacement.lsp | 135 + ansi-tests/array-in-bounds-p.lsp | 152 + ansi-tests/array-misc.lsp | 30 + ansi-tests/array-rank.lsp | 52 + ansi-tests/array-row-major-index.lsp | 39 + ansi-tests/array-t.lsp | 275 + ansi-tests/array-total-size.lsp | 63 + ansi-tests/array.lsp | 330 + ansi-tests/arrayp.lsp | 57 + ansi-tests/assert.lsp | 90 + ansi-tests/atom-errors.lsp | 39 + ansi-tests/bit-and.lsp | 243 + ansi-tests/bit-andc1.lsp | 243 + ansi-tests/bit-andc2.lsp | 244 + ansi-tests/bit-eqv.lsp | 245 + ansi-tests/bit-ior.lsp | 244 + ansi-tests/bit-nand.lsp | 244 + ansi-tests/bit-nor.lsp | 244 + ansi-tests/bit-not.lsp | 139 + ansi-tests/bit-orc1.lsp | 244 + ansi-tests/bit-orc2.lsp | 245 + ansi-tests/bit-vector-p.lsp | 79 + ansi-tests/bit-vector.lsp | 121 + ansi-tests/bit-xor.lsp | 244 + ansi-tests/bit.lsp | 136 + ansi-tests/block.lsp | 73 + ansi-tests/boundp.lsp | 56 + ansi-tests/call-arguments-limit.lsp | 29 + ansi-tests/case.lsp | 171 + ansi-tests/catch.lsp | 75 + ansi-tests/ccase.lsp | 189 + ansi-tests/cell-error-name.lsp | 51 + ansi-tests/cerror.lsp | 56 + ansi-tests/char-aux.lsp | 286 + ansi-tests/char-compare.lsp | 723 + ansi-tests/char-schar.lsp | 164 + ansi-tests/character.lsp | 651 + ansi-tests/check-type.lsp | 51 + ansi-tests/cl-symbol-names.lsp | 2155 + ansi-tests/cl-symbols-aux.lsp | 43 + ansi-tests/cl-symbols.lsp | 1587 + ansi-tests/cl-test-package.lsp | 15 + ansi-tests/cltest.system | 123 + ansi-tests/coerce.lsp | 178 + ansi-tests/compile-and-load.lsp | 26 + ansi-tests/compile.lsp | 91 + ansi-tests/compiled-function-p.lsp | 39 + ansi-tests/compiler-macros.lsp | 8 + ansi-tests/complement.lsp | 57 + ansi-tests/concatenate.lsp | 227 + ansi-tests/cond.lsp | 75 + ansi-tests/condition.lsp | 63 + ansi-tests/cons-test-01.lsp | 456 + ansi-tests/cons-test-02.lsp | 1117 + ansi-tests/cons-test-03.lsp | 325 + ansi-tests/cons-test-04.lsp | 412 + ansi-tests/cons-test-05.lsp | 192 + ansi-tests/cons-test-06.lsp | 54 + ansi-tests/cons-test-07.lsp | 211 + ansi-tests/cons-test-08.lsp | 455 + ansi-tests/cons-test-09.lsp | 186 + ansi-tests/cons-test-10.lsp | 96 + ansi-tests/cons-test-11.lsp | 261 + ansi-tests/cons-test-12.lsp | 103 + ansi-tests/cons-test-13.lsp | 292 + ansi-tests/cons-test-14.lsp | 275 + ansi-tests/cons-test-15.lsp | 652 + ansi-tests/cons-test-16.lsp | 678 + ansi-tests/cons-test-17.lsp | 559 + ansi-tests/cons-test-18.lsp | 338 + ansi-tests/cons-test-19.lsp | 738 + ansi-tests/cons-test-20.lsp | 404 + ansi-tests/cons-test-21.lsp | 402 + ansi-tests/cons-test-22.lsp | 613 + ansi-tests/cons-test-23.lsp | 693 + ansi-tests/cons-test-24.lsp | 250 + ansi-tests/cons-test-25.lsp | 56 + ansi-tests/constantly.lsp | 37 + ansi-tests/constantp.lsp | 84 + ansi-tests/copy-seq.lsp | 187 + ansi-tests/count-if-not.lsp | 540 + ansi-tests/count-if.lsp | 541 + ansi-tests/count.lsp | 609 + ansi-tests/ctypecase.lsp | 88 + ansi-tests/data-and-control-flow.lsp | 34 + ansi-tests/defconstant.lsp | 45 + ansi-tests/define-modify-macro.lsp | 83 + ansi-tests/defparameter.lsp | 66 + ansi-tests/defun.lsp | 19 + ansi-tests/defvar.lsp | 64 + ansi-tests/destructuring-bind.lsp | 110 + ansi-tests/ecase.lsp | 149 + ansi-tests/elt.lsp | 368 + ansi-tests/eql.lsp | 87 + ansi-tests/equal.lsp | 81 + ansi-tests/equalp.lsp | 47 + ansi-tests/error.lsp | 66 + ansi-tests/etypecase.lsp | 61 + ansi-tests/eval-and-compile.lsp | 22 + ansi-tests/eval.lsp | 52 + ansi-tests/every.lsp | 150 + ansi-tests/fboundp.lsp | 69 + ansi-tests/fdefinition.lsp | 83 + ansi-tests/features.lsp | 22 + ansi-tests/fill-pointer.lsp | 82 + ansi-tests/fill-strings.lsp | 26 + ansi-tests/fill.lsp | 522 + ansi-tests/find-if-not.lsp | 611 + ansi-tests/find-if.lsp | 634 + ansi-tests/find.lsp | 870 + ansi-tests/flet.lsp | 431 + ansi-tests/fmakunbound.lsp | 67 + ansi-tests/funcall.lsp | 105 + ansi-tests/function-lambda-expression.lsp | 42 + ansi-tests/function.lsp | 95 + ansi-tests/functionp.lsp | 96 + ansi-tests/gclload.lsp | 4 + ansi-tests/gclload1.lsp | 33 + ansi-tests/gclload2.lsp | 55 + ansi-tests/get-setf-expansion.lsp | 16 + ansi-tests/handler-bind.lsp | 144 + ansi-tests/handler-case.lsp | 9 + ansi-tests/hash-table.lsp | 71 + ansi-tests/identity.lsp | 34 + ansi-tests/if.lsp | 35 + ansi-tests/invoke-debugger.lsp | 23 + ansi-tests/iteration.lsp | 494 + ansi-tests/labels.lsp | 214 + ansi-tests/lambda-list-keywords.lsp | 39 + ansi-tests/lambda-parameters-limit.lsp | 17 + ansi-tests/lambda.lsp | 60 + ansi-tests/length.lsp | Bin 0 -> 2452 bytes ansi-tests/let.lsp | 210 + ansi-tests/load-arrays.lsp | 46 + ansi-tests/load-conditions.lsp | 10 + ansi-tests/load-cons.lsp | 27 + ansi-tests/load-data-and-control-flow.lsp | 69 + ansi-tests/load-eval-and-compile.lsp | 7 + ansi-tests/load-iteration.lsp | 20 + ansi-tests/load-sequences.lsp | 41 + ansi-tests/load-strings.lsp | 18 + ansi-tests/load-structures.lsp | 6 + ansi-tests/load-symbols.lsp | 5 + ansi-tests/load-types-and-class.lsp | 15 + ansi-tests/load.lsp | 15 + ansi-tests/loop.lsp | 53 + ansi-tests/loop1.lsp | 227 + ansi-tests/loop10.lsp | 450 + ansi-tests/loop11.lsp | 165 + ansi-tests/loop12.lsp | 234 + ansi-tests/loop13.lsp | 433 + ansi-tests/loop14.lsp | 333 + ansi-tests/loop15.lsp | 249 + ansi-tests/loop16.lsp | 243 + ansi-tests/loop17.lsp | 133 + ansi-tests/loop2.lsp | 139 + ansi-tests/loop3.lsp | 136 + ansi-tests/loop4.lsp | 57 + ansi-tests/loop5.lsp | 172 + ansi-tests/loop6.lsp | 294 + ansi-tests/loop7.lsp | 206 + ansi-tests/loop8.lsp | 141 + ansi-tests/loop9.lsp | 222 + ansi-tests/macrolet.lsp | 160 + ansi-tests/make-array.lsp | 670 + ansi-tests/make-hash-table.lsp | 16 + ansi-tests/make-sequence.lsp | 273 + ansi-tests/make-string.lsp | 163 + ansi-tests/make-tar | 2 + ansi-tests/makefile | 10 + ansi-tests/map-into.lsp | 407 + ansi-tests/map.lsp | 257 + ansi-tests/merge.lsp | 572 + ansi-tests/mismatch.lsp | 715 + ansi-tests/multiple-value-bind.lsp | 62 + ansi-tests/multiple-value-call.lsp | 42 + ansi-tests/multiple-value-list.lsp | 37 + ansi-tests/multiple-value-prog1.lsp | 71 + ansi-tests/multiple-value-setq.lsp | 109 + ansi-tests/nil.lsp | 44 + ansi-tests/not-and-null.lsp | 59 + ansi-tests/notany.lsp | 142 + ansi-tests/notevery.lsp | 142 + ansi-tests/nreverse.lsp | 126 + ansi-tests/nstring-capitalize.lsp | 108 + ansi-tests/nstring-downcase.lsp | 118 + ansi-tests/nstring-upcase.lsp | 115 + ansi-tests/nsubstitute-if-not.lsp | 761 + ansi-tests/nsubstitute-if.lsp | 753 + ansi-tests/nsubstitute.lsp | 957 + ansi-tests/nth-value.lsp | 36 + ansi-tests/or.lsp | 48 + ansi-tests/packages-00.lsp | 39 + ansi-tests/packages-01.lsp | 92 + ansi-tests/packages-02.lsp | 91 + ansi-tests/packages-03.lsp | 220 + ansi-tests/packages-04.lsp | 57 + ansi-tests/packages-05.lsp | 110 + ansi-tests/packages-06.lsp | 176 + ansi-tests/packages-07.lsp | 231 + ansi-tests/packages-08.lsp | 148 + ansi-tests/packages-09.lsp | 324 + ansi-tests/packages-10.lsp | 121 + ansi-tests/packages-11.lsp | 143 + ansi-tests/packages-12.lsp | 247 + ansi-tests/packages-13.lsp | 52 + ansi-tests/packages-14.lsp | 201 + ansi-tests/packages-15.lsp | 210 + ansi-tests/packages-16.lsp | 614 + ansi-tests/packages-17.lsp | 145 + ansi-tests/packages-18.lsp | 106 + ansi-tests/packages-19.lsp | 61 + ansi-tests/packages.lsp | 26 + ansi-tests/places.lsp | 467 + ansi-tests/position-if-not.lsp | 575 + ansi-tests/position-if.lsp | 574 + ansi-tests/position.lsp | 773 + ansi-tests/prog.lsp | 147 + ansi-tests/prog1.lsp | 27 + ansi-tests/prog2.lsp | 36 + ansi-tests/progn.lsp | 38 + ansi-tests/progv.lsp | 75 + ansi-tests/random-aux.lsp | 90 + ansi-tests/random-int-form.lsp | 2115 + ansi-tests/random-intern.lsp | 72 + ansi-tests/reader-test.lsp | 155 + ansi-tests/reduce.lsp | 470 + ansi-tests/remove-aux.lsp | 273 + ansi-tests/remove-duplicates-aux.lsp | 88 + ansi-tests/remove-duplicates.lsp | 253 + ansi-tests/remove.lsp | 806 + ansi-tests/replace.lsp | 685 + ansi-tests/reverse.lsp | 131 + ansi-tests/row-major-aref.lsp | 112 + ansi-tests/rt-acl.system | 12 + ansi-tests/rt-doc.txt | 194 + ansi-tests/rt-package.lsp | 25 + ansi-tests/rt-test.lsp | 229 + ansi-tests/rt.lsp | 270 + ansi-tests/rt.system | 22 + ansi-tests/sbit.lsp | 95 + ansi-tests/search-aux.lsp | 92 + ansi-tests/search-bitvector.lsp | 176 + ansi-tests/search-list.lsp | 251 + ansi-tests/search-string.lsp | 163 + ansi-tests/search-vector.lsp | 176 + ansi-tests/simple-array-t.lsp | 275 + ansi-tests/simple-array.lsp | 329 + ansi-tests/simple-bit-vector-p.lsp | 62 + ansi-tests/simple-bit-vector.lsp | 72 + ansi-tests/simple-vector-p.lsp | 71 + ansi-tests/some.lsp | 151 + ansi-tests/sort.lsp | 143 + ansi-tests/stable-sort.lsp | 154 + ansi-tests/string-aux.lsp | 165 + ansi-tests/string-capitalize.lsp | 132 + ansi-tests/string-comparisons.lsp | 514 + ansi-tests/string-downcase.lsp | 128 + ansi-tests/string-left-trim.lsp | 165 + ansi-tests/string-right-trim.lsp | 165 + ansi-tests/string-trim.lsp | 165 + ansi-tests/string-upcase.lsp | 129 + ansi-tests/string.lsp | 202 + ansi-tests/structure-00.lsp | 552 + ansi-tests/structures-01.lsp | 103 + ansi-tests/structures-02.lsp | 420 + ansi-tests/structures-03.lsp | 417 + ansi-tests/subseq-aux.lsp | 239 + ansi-tests/subseq.lsp | 235 + ansi-tests/substitute-if-not.lsp | 837 + ansi-tests/substitute-if.lsp | 856 + ansi-tests/substitute.lsp | 1086 + ansi-tests/subtypep-array.lsp | 98 + ansi-tests/subtypep-cons.lsp | 202 + ansi-tests/subtypep-eql.lsp | 54 + ansi-tests/subtypep-float.lsp | 175 + ansi-tests/subtypep-integer.lsp | 434 + ansi-tests/subtypep-member.lsp | 229 + ansi-tests/subtypep-rational.lsp | 173 + ansi-tests/subtypep-real.lsp | 194 + ansi-tests/subtypep.lsp | 200 + ansi-tests/svref.lsp | 59 + ansi-tests/t.lsp | 24 + ansi-tests/tagbody.lsp | 161 + ansi-tests/typecase.lsp | 72 + ansi-tests/types-and-class-2.lsp | 197 + ansi-tests/types-and-class.lsp | 422 + ansi-tests/universe.lsp | 397 + ansi-tests/unless.lsp | 49 + ansi-tests/unwind-protect.lsp | 90 + ansi-tests/upgraded-array-element-type.lsp | 108 + ansi-tests/values-list.lsp | 40 + ansi-tests/values.lsp | 62 + ansi-tests/vector-pop.lsp | 44 + ansi-tests/vector-push-extend.lsp | 362 + ansi-tests/vector-push.lsp | 319 + ansi-tests/vector.lsp | 331 + ansi-tests/vectorp.lsp | 82 + ansi-tests/warn.lsp | 161 + ansi-tests/when.lsp | 39 + bfdtest.c | 418 + bin/append.c | 35 + bin/dpp.c | 680 + bin/file-sub.c | 71 + bin/info | 3 + bin/info1 | 13 + bin/makefile | 19 + bin/tkinfo | 19 + clcs/gcl_clcs_condition_definitions.lisp | 145 + clcs/gcl_clcs_conditions.lisp | 85 + clcs/gcl_clcs_handler.lisp | 39 + clcs/gcl_clcs_precom.lisp | 6 + clcs/gcl_cmpinit.lsp | 7 + clcs/loading.lisp | 26 + clcs/makefile | 37 + clcs/myload.lisp | 4 + clcs/package.lisp | 22 + clcs/readme | 16 + clcs/sys-proclaim.lisp | 45 + clcs/unused/condition_precom.lisp | 61 + clcs/unused/doload.lisp | 21 + clcs/unused/reload.lisp | 12 + clcs/unused/sysdef.lisp | 129 + clcs/unused/test.lisp | 168 + clcs/unused/test2.lisp | 41 + clcs/unused/test3.lisp | 103 + clcs/unused/test4.lisp | 12 + clcs/unused/test5.lisp | 342 + clcs/unused/tester.lisp | 11 + cmpnew/gcl_cmpbind.lsp | 131 + cmpnew/gcl_cmpblock.lsp | 169 + cmpnew/gcl_cmpcall.lsp | 578 + cmpnew/gcl_cmpcatch.lsp | 124 + cmpnew/gcl_cmpenv.lsp | 681 + cmpnew/gcl_cmpeval.lsp | 679 + cmpnew/gcl_cmpflet.lsp | 405 + cmpnew/gcl_cmpfun.lsp | 984 + cmpnew/gcl_cmpif.lsp | 438 + cmpnew/gcl_cmpinit.lsp | 7 + cmpnew/gcl_cmpinline.lsp | 715 + cmpnew/gcl_cmplabel.lsp | 252 + cmpnew/gcl_cmplam.lsp | 974 + cmpnew/gcl_cmplet.lsp | 361 + cmpnew/gcl_cmploc.lsp | 297 + cmpnew/gcl_cmpmain.lsp | 839 + cmpnew/gcl_cmpmap.lsp | 262 + cmpnew/gcl_cmpmulti.lsp | 287 + cmpnew/gcl_cmpopt.lsp | 1284 + cmpnew/gcl_cmpspecial.lsp | 153 + cmpnew/gcl_cmptag.lsp | 418 + cmpnew/gcl_cmptest.lsp | 267 + cmpnew/gcl_cmptop.lsp | 1822 + cmpnew/gcl_cmptype.lsp | 227 + cmpnew/gcl_cmputil.lsp | 247 + cmpnew/gcl_cmpvar.lsp | 476 + cmpnew/gcl_cmpvs.lsp | 100 + cmpnew/gcl_cmpwt.lsp | 216 + cmpnew/gcl_collectfn.lsp | 401 + cmpnew/gcl_fasdmacros.lsp | 81 + cmpnew/gcl_init.lsp | 4 + cmpnew/gcl_lfun_list.lsp | 462 + cmpnew/gcl_make-fn.lsp | 4 + cmpnew/gcl_make_ufun.lsp | 86 + cmpnew/gcl_nocmpinc.lsp | 23 + cmpnew/makefile | 66 + cmpnew/so_locations | 4 + cmpnew/sys-proclaim.lisp | 168 + comp/bo1.lsp | 149 + comp/c-pass1.lsp | 70 + comp/cmpinit.lsp | 16 + comp/comptype.lsp | 227 + comp/data.lsp | 107 + comp/defmacro.lsp | 257 + comp/defs.lsp | 126 + comp/exit.lsp | 44 + comp/fasdmacros.lsp | 92 + comp/inline.lsp | 599 + comp/integer.doc | 35 + comp/lambda.lsp | 38 + comp/lisp-decls.doc | 531 + comp/macros.lsp | 79 + comp/makefile | 37 + comp/mangle.lsp | 116 + comp/opts-base.lsp | 52 + comp/opts.lsp | 492 + comp/proclaim.lsp | 1 + comp/smash-oldcmp.lsp | 7 + comp/stmt.lsp | 407 + comp/sysdef.lsp | 23 + comp/top.lsp | 92 + comp/top1.lsp | 137 + comp/top2.lsp | 1086 + comp/try.lsp | 26 + comp/try1.lsp | 8 + comp/utils.lsp | 166 + comp/var.lsp | 1147 + comp/wr.lsp | 476 + config.guess | 1420 + config.sub | 1794 + configure | 10716 +++++ configure-new.ac | 1040 + configure.in | 2827 ++ debian/README.Debian | 28 + debian/changelog | 3231 ++ debian/compat | 1 + debian/control | 39 + debian/control. | 39 + debian/control.cvs | 39 + debian/copyright | 65 + debian/gcl.lintian-overrides | 2 + debian/gcl.sh | 28 + debian/gcl.templates | 38 + debian/in.gcl-doc.README.Debian | 9 + debian/in.gcl-doc.doc-base.si | 12 + debian/in.gcl-doc.doc-base.tk | 12 + debian/in.gcl-doc.doc-base.xgcl | 15 + debian/in.gcl-doc.docs | 3 + debian/in.gcl-doc.info | 4 + debian/in.gcl-doc.install | 1 + debian/in.gcl.config | 19 + debian/in.gcl.docs | 2 + debian/in.gcl.emacsen-compat | 1 + debian/in.gcl.emacsen-install | 46 + debian/in.gcl.emacsen-remove | 15 + debian/in.gcl.emacsen-startup | 19 + debian/in.gcl.install | 3 + debian/in.gcl.manpages | 1 + debian/in.gcl.postinst | 40 + debian/in.gcl.postrm | 18 + debian/old.in.gcl-doc.doc-base.main | 12 + debian/po/POTFILES.in | 1 + debian/po/cs.po | 139 + debian/po/da.po | 97 + debian/po/de.po | 139 + debian/po/es.po | 209 + debian/po/fi.po | 95 + debian/po/fr.po | 141 + debian/po/gl.po | 138 + debian/po/it.po | 102 + debian/po/ja.po | 96 + debian/po/nl.po | 101 + debian/po/pt.po | 99 + debian/po/ru.po | 100 + debian/po/sv.po | 106 + debian/po/templates.pot | 82 + debian/po/vi.po | 98 + debian/rules | 268 + debian/source/format | 1 + debian/source/include-binaries | 3 + debian/texi.awk | 27 + debian/upstream/signing-key.asc | 88 + debian/watch | 2 + doc/bignum | 60 + doc/c-gc | 39 + doc/c-gc.doc | 32 + doc/compile-file-handling-of-top-level-forms | 222 + doc/contributors | 41 + doc/debug | 28 + doc/enhancements | 146 + doc/fast-link | 158 + doc/format | 44 + doc/funcall-comp | 35 + doc/funcall.lsp | 81 + doc/makefile | 9 + doc/multiple-values | 94 + doc/profile | 45 + dos/dostimes.c | 19 + dos/dum_dos.c | 9 + dos/makefile | 27 + dos/read.s | 41 + dos/readme | 7 + dos/sigman.s | 49 + dos/signal.c | 109 + dos/signal.h | 137 + elisp/add-default.el | 4 + elisp/ansi-doc.el | 92 + elisp/dbl.el | 685 + elisp/doc-to-texi.el | 126 + elisp/gcl.el | 375 + elisp/makefile | 18 + elisp/man1-to-texi.el | 414 + elisp/readme | 7 + elisp/smart-complete.el | 154 + elisp/sshell.el | 379 + eval.html | 106 + eval.tcl | 79 + faq | 85 + gcl-tk/comm.c | 283 + gcl-tk/convert.el | 246 + gcl-tk/decode.tcl | 321 + gcl-tk/demos-4.1/items.lisp | 305 + gcl-tk/demos-4.2/widget | 376 + gcl-tk/demos-4.2/widget.lisp | 385 + gcl-tk/demos/gc-monitor.lisp | 158 + gcl-tk/demos/mkArrow.tcl | 203 + gcl-tk/demos/mkBasic.lisp | 69 + gcl-tk/demos/mkBasic.tcl | 61 + gcl-tk/demos/mkBitmaps.tcl | 46 + gcl-tk/demos/mkButton.tcl | 33 + gcl-tk/demos/mkCanvText.lisp | 110 + gcl-tk/demos/mkCanvText.tcl | 110 + gcl-tk/demos/mkCheck.tcl | 33 + gcl-tk/demos/mkDialog.tcl | 63 + gcl-tk/demos/mkEntry.lisp | 30 + gcl-tk/demos/mkEntry.tcl | 29 + gcl-tk/demos/mkEntry2.lisp | 39 + gcl-tk/demos/mkEntry2.tcl | 39 + gcl-tk/demos/mkFloor.tcl | 1276 + gcl-tk/demos/mkForm.lisp | 54 + gcl-tk/demos/mkForm.tcl | 52 + gcl-tk/demos/mkHScale.lisp | 38 + gcl-tk/demos/mkHScale.tcl | 35 + gcl-tk/demos/mkIcon.tcl | 48 + gcl-tk/demos/mkItems.lisp | 358 + gcl-tk/demos/mkItems.tcl | 271 + gcl-tk/demos/mkLabel.lisp | 35 + gcl-tk/demos/mkLabel.tcl | 34 + gcl-tk/demos/mkListbox.lisp | 42 + gcl-tk/demos/mkListbox.tcl | 41 + gcl-tk/demos/mkListbox2.tcl | 95 + gcl-tk/demos/mkListbox3.tcl | 34 + gcl-tk/demos/mkPlot.lisp | 81 + gcl-tk/demos/mkPlot.tcl | 75 + gcl-tk/demos/mkPuzzle.tcl | 59 + gcl-tk/demos/mkRadio.lisp | 61 + gcl-tk/demos/mkRadio.tcl | 58 + gcl-tk/demos/mkRuler.lisp | 140 + gcl-tk/demos/mkRuler.tcl | 125 + gcl-tk/demos/mkScroll.tcl | 84 + gcl-tk/demos/mkSearch.lisp | 135 + gcl-tk/demos/mkSearch.tcl | 140 + gcl-tk/demos/mkStyles.lisp | 135 + gcl-tk/demos/mkStyles.tcl | 128 + gcl-tk/demos/mkTear.tcl | 19 + gcl-tk/demos/mkTextBind.lisp | 108 + gcl-tk/demos/mkTextBind.tcl | 100 + gcl-tk/demos/mkVScale.lisp | 40 + gcl-tk/demos/mkVScale.tcl | 35 + gcl-tk/demos/mkdialog.lisp | 64 + gcl-tk/demos/nqthm-stack.lisp | 61 + gcl-tk/demos/showVars.lisp | 28 + gcl-tk/demos/showVars.tcl | 26 + gcl-tk/demos/tclIndex | 83 + gcl-tk/demos/widget.lisp | 220 + gcl-tk/dir.sed | 3 + gcl-tk/gcl-1.tcl | 39 + gcl-tk/gcl.tcl | 55 + gcl-tk/gcl_cmpinit.lsp | 1 + gcl-tk/gcl_guisl.h | 9 + gcl-tk/gcltksrv.bat | 8 + gcl-tk/gcltksrv.in | 31 + gcl-tk/gcltksrv.in.interp | 15 + gcl-tk/gcltksrv.prev | 22 + gcl-tk/guis.c | 509 + gcl-tk/guis.h | 99 + gcl-tk/helpers.lisp | 21 + gcl-tk/index.lsp | 55 + gcl-tk/intrs.h | 0 gcl-tk/makefile | 76 + gcl-tk/makefile.prev | 129 + gcl-tk/ngcltksrv | 12 + gcl-tk/our_io.c | 109 + gcl-tk/sheader.h | 112 + gcl-tk/socketsl.lisp | 31 + gcl-tk/socks.h | 31 + gcl-tk/sysdep-sunos.h | 9 + gcl-tk/tinfo.lsp | 588 + gcl-tk/tk-package.lsp | 33 + gcl-tk/tkAppInit.c | 112 + gcl-tk/tkMain.c | 712 + gcl-tk/tkXAppInit.c | 131 + gcl-tk/tkXshell.c | 445 + gcl-tk/tkl.lisp | 1555 + gcl-tk/tktst.c | 231 + gcl.ico | Bin 0 -> 23502 bytes gcl.jpg | Bin 0 -> 24640 bytes gcl.png | Bin 0 -> 12437 bytes gcl1.jpg | Bin 0 -> 17006 bytes gcl2.jpg | Bin 0 -> 5737 bytes gmp.patch | 19 + gmp4/.gdbinit | 43 + gmp4/.pc/.quilt_patches | 1 + gmp4/.pc/.quilt_series | 1 + gmp4/.pc/.version | 1 + .../mpn/powerpc64/mode64/gcd_1.asm | 122 + gmp4/.pc/applied-patches | 2 + .../mpn/generic/div_qr_1n_pi1.c | 277 + gmp4/AUTHORS | 100 + gmp4/COPYING | 674 + gmp4/COPYING.LESSERv3 | 165 + gmp4/COPYINGv2 | 339 + gmp4/COPYINGv3 | 674 + gmp4/ChangeLog | 32941 ++++++++++++++++ gmp4/INSTALL | 370 + gmp4/INSTALL.autoconf | 228 + gmp4/Makefile.am | 445 + gmp4/Makefile.in | 1476 + gmp4/NEWS | 891 + gmp4/README | 116 + gmp4/acinclude.m4 | 3984 ++ gmp4/aclocal.m4 | 9492 +++++ gmp4/assert.c | 59 + gmp4/autom4te.cache/output.0 | 29966 ++++++++++++++ gmp4/autom4te.cache/output.1 | 29962 ++++++++++++++ gmp4/autom4te.cache/requests | 392 + gmp4/autom4te.cache/traces.0 | 9202 +++++ gmp4/autom4te.cache/traces.1 | 3663 ++ gmp4/bootstrap.c | 146 + gmp4/compat.c | 60 + gmp4/compile | 347 + gmp4/config.guess | 1558 + gmp4/config.in | 640 + gmp4/config.in~ | 640 + gmp4/config.sub | 1791 + gmp4/configfsf.guess | 1568 + gmp4/configfsf.sub | 1793 + gmp4/configure | 29962 ++++++++++++++ gmp4/configure.ac | 3816 ++ gmp4/cxx/Makefile.am | 40 + gmp4/cxx/Makefile.in | 630 + gmp4/cxx/dummy.cc | 33 + gmp4/cxx/isfuns.cc | 116 + gmp4/cxx/ismpf.cc | 145 + gmp4/cxx/ismpq.cc | 67 + gmp4/cxx/ismpz.cc | 63 + gmp4/cxx/ismpznw.cc | 73 + gmp4/cxx/limits.cc | 62 + gmp4/cxx/osdoprnti.cc | 68 + gmp4/cxx/osfuns.cc | 124 + gmp4/cxx/osmpf.cc | 71 + gmp4/cxx/osmpq.cc | 48 + gmp4/cxx/osmpz.cc | 48 + gmp4/debian/NEWS.Debian | 13 + gmp4/debian/Notes | 25 + gmp4/debian/README.Debian | 10 + gmp4/debian/README.source | 57 + gmp4/debian/changelog | 1148 + gmp4/debian/compat | 2 + gmp4/debian/control | 83 + gmp4/debian/copyright | 60 + gmp4/debian/libgmp10-doc.README.Debian | 21 + gmp4/debian/libgmp10-doc.examples | 1 + gmp4/debian/libgmp10.symbols | 912 + gmp4/debian/libgmpxx4ldbl.lintian-overrides | 1 + gmp4/debian/patches/4a6d258b467f.patch | 22 + gmp4/debian/patches/arm-asm-nothumb.patch | 21 + gmp4/debian/patches/series | 2 + gmp4/debian/rules | 177 + gmp4/debian/source/format | 1 + gmp4/debian/watch | 4 + gmp4/demos/Makefile.am | 50 + gmp4/demos/Makefile.in | 773 + gmp4/demos/calc/Makefile.am | 47 + gmp4/demos/calc/Makefile.in | 665 + gmp4/demos/calc/README | 65 + gmp4/demos/calc/calc-common.h | 35 + gmp4/demos/calc/calc-config-h.in | 21 + gmp4/demos/calc/calc.c | 2254 ++ gmp4/demos/calc/calc.h | 145 + gmp4/demos/calc/calc.y | 318 + gmp4/demos/calc/calclex.c | 1917 + gmp4/demos/calc/calclex.l | 113 + gmp4/demos/calc/calcread.c | 146 + gmp4/demos/expr/Makefile.am | 54 + gmp4/demos/expr/Makefile.in | 653 + gmp4/demos/expr/README | 501 + gmp4/demos/expr/expr-impl.h | 125 + gmp4/demos/expr/expr.c | 834 + gmp4/demos/expr/expr.h | 142 + gmp4/demos/expr/exprf.c | 123 + gmp4/demos/expr/exprfa.c | 191 + gmp4/demos/expr/exprq.c | 155 + gmp4/demos/expr/exprqa.c | 100 + gmp4/demos/expr/exprv.c | 57 + gmp4/demos/expr/exprz.c | 206 + gmp4/demos/expr/exprza.c | 108 + gmp4/demos/expr/run-expr.c | 242 + gmp4/demos/expr/t-expr.c | 510 + gmp4/demos/factorize.c | 446 + gmp4/demos/isprime.c | 68 + gmp4/demos/perl/GMP.pm | 671 + gmp4/demos/perl/GMP.xs | 3212 ++ gmp4/demos/perl/GMP/Mpf.pm | 106 + gmp4/demos/perl/GMP/Mpq.pm | 89 + gmp4/demos/perl/GMP/Mpz.pm | 101 + gmp4/demos/perl/GMP/Rand.pm | 44 + gmp4/demos/perl/INSTALL | 88 + gmp4/demos/perl/Makefile.PL | 82 + gmp4/demos/perl/sample.pl | 54 + gmp4/demos/perl/test.pl | 2179 + gmp4/demos/perl/test2.pl | 75 + gmp4/demos/perl/typemap | 108 + gmp4/demos/pexpr-config-h.in | 45 + gmp4/demos/pexpr.c | 1378 + gmp4/demos/primes.c | 387 + gmp4/demos/primes.h | 552 + gmp4/demos/qcn.c | 172 + gmp4/doc/Makefile.am | 0 gmp4/doc/Makefile.in | 467 + gmp4/errno.c | 70 + gmp4/extract-dbl.c | 311 + gmp4/gen-bases.c | 251 + gmp4/gen-fac.c | 285 + gmp4/gen-fib.c | 156 + gmp4/gen-jacobitab.c | 128 + gmp4/gen-psqr.c | 586 + gmp4/gen-trialdivtab.c | 300 + gmp4/gmp-h.in | 2301 ++ gmp4/gmp-impl.h | 5203 +++ gmp4/gmpxx.h | 3336 ++ gmp4/install-sh | 527 + gmp4/invalid.c | 83 + gmp4/longlong.h | 2183 + gmp4/ltmain.sh | 9661 +++++ gmp4/memory.c | 146 + gmp4/mini-gmp/README | 77 + gmp4/mini-gmp/mini-gmp.c | 4386 ++ gmp4/mini-gmp/mini-gmp.h | 294 + gmp4/mini-gmp/tests/Makefile | 60 + gmp4/mini-gmp/tests/hex-random.c | 434 + gmp4/mini-gmp/tests/hex-random.h | 50 + gmp4/mini-gmp/tests/mini-random.c | 142 + gmp4/mini-gmp/tests/mini-random.h | 33 + gmp4/mini-gmp/tests/run-tests | 123 + gmp4/mini-gmp/tests/t-add.c | 57 + gmp4/mini-gmp/tests/t-aorsmul.c | 77 + gmp4/mini-gmp/tests/t-bitops.c | 103 + gmp4/mini-gmp/tests/t-cmp_d.c | 283 + gmp4/mini-gmp/tests/t-comb.c | 164 + gmp4/mini-gmp/tests/t-cong.c | 212 + gmp4/mini-gmp/tests/t-div.c | 254 + gmp4/mini-gmp/tests/t-div_2exp.c | 82 + gmp4/mini-gmp/tests/t-double.c | 138 + gmp4/mini-gmp/tests/t-gcd.c | 176 + gmp4/mini-gmp/tests/t-import.c | 99 + gmp4/mini-gmp/tests/t-invert.c | 98 + gmp4/mini-gmp/tests/t-lcm.c | 73 + gmp4/mini-gmp/tests/t-limbs.c | 106 + gmp4/mini-gmp/tests/t-logops.c | 112 + gmp4/mini-gmp/tests/t-mul.c | 113 + gmp4/mini-gmp/tests/t-powm.c | 61 + gmp4/mini-gmp/tests/t-pprime_p.c | 182 + gmp4/mini-gmp/tests/t-reuse.c | 663 + gmp4/mini-gmp/tests/t-root.c | 95 + gmp4/mini-gmp/tests/t-scan.c | 90 + gmp4/mini-gmp/tests/t-signed.c | 142 + gmp4/mini-gmp/tests/t-sqrt.c | 181 + gmp4/mini-gmp/tests/t-str.c | 307 + gmp4/mini-gmp/tests/t-sub.c | 71 + gmp4/mini-gmp/tests/testutils.c | 173 + gmp4/mini-gmp/tests/testutils.h | 37 + gmp4/missing | 215 + gmp4/mp_bpl.c | 35 + gmp4/mp_clz_tab.c | 49 + gmp4/mp_dv_tab.c | 78 + gmp4/mp_get_fns.c | 48 + gmp4/mp_minv_tab.c | 59 + gmp4/mp_set_fns.c | 50 + gmp4/mpf/Makefile.am | 47 + gmp4/mpf/Makefile.in | 649 + gmp4/mpf/abs.c | 59 + gmp4/mpf/add.c | 184 + gmp4/mpf/add_ui.c | 153 + gmp4/mpf/ceilfloor.c | 126 + gmp4/mpf/clear.c | 39 + gmp4/mpf/clears.c | 49 + gmp4/mpf/cmp.c | 117 + gmp4/mpf/cmp_d.c | 60 + gmp4/mpf/cmp_si.c | 118 + gmp4/mpf/cmp_ui.c | 100 + gmp4/mpf/div.c | 138 + gmp4/mpf/div_2exp.c | 139 + gmp4/mpf/div_ui.c | 111 + gmp4/mpf/dump.c | 53 + gmp4/mpf/eq.c | 150 + gmp4/mpf/fits_s.h | 75 + gmp4/mpf/fits_sint.c | 36 + gmp4/mpf/fits_slong.c | 36 + gmp4/mpf/fits_sshort.c | 36 + gmp4/mpf/fits_u.h | 74 + gmp4/mpf/fits_uint.c | 35 + gmp4/mpf/fits_ulong.c | 35 + gmp4/mpf/fits_ushort.c | 35 + gmp4/mpf/get_d.c | 47 + gmp4/mpf/get_d_2exp.c | 61 + gmp4/mpf/get_dfl_prec.c | 39 + gmp4/mpf/get_prc.c | 38 + gmp4/mpf/get_si.c | 87 + gmp4/mpf/get_str.c | 330 + gmp4/mpf/get_ui.c | 102 + gmp4/mpf/init.c | 42 + gmp4/mpf/init2.c | 44 + gmp4/mpf/inits.c | 49 + gmp4/mpf/inp_str.c | 93 + gmp4/mpf/int_p.c | 59 + gmp4/mpf/iset.c | 62 + gmp4/mpf/iset_d.c | 42 + gmp4/mpf/iset_si.c | 58 + gmp4/mpf/iset_str.c | 44 + gmp4/mpf/iset_ui.c | 53 + gmp4/mpf/mul.c | 96 + gmp4/mpf/mul_2exp.c | 133 + gmp4/mpf/mul_ui.c | 182 + gmp4/mpf/neg.c | 62 + gmp4/mpf/out_str.c | 117 + gmp4/mpf/pow_ui.c | 54 + gmp4/mpf/random2.c | 67 + gmp4/mpf/reldiff.c | 65 + gmp4/mpf/set.c | 56 + gmp4/mpf/set_d.c | 60 + gmp4/mpf/set_dfl_prec.c | 40 + gmp4/mpf/set_prc.c | 69 + gmp4/mpf/set_prc_raw.c | 40 + gmp4/mpf/set_q.c | 155 + gmp4/mpf/set_si.c | 53 + gmp4/mpf/set_str.c | 402 + gmp4/mpf/set_ui.c | 49 + gmp4/mpf/set_z.c | 57 + gmp4/mpf/size.c | 39 + gmp4/mpf/sqrt.c | 113 + gmp4/mpf/sqrt_ui.c | 109 + gmp4/mpf/sub.c | 419 + gmp4/mpf/sub_ui.c | 51 + gmp4/mpf/swap.c | 57 + gmp4/mpf/trunc.c | 75 + gmp4/mpf/ui_div.c | 128 + gmp4/mpf/ui_sub.c | 336 + gmp4/mpf/urandomb.c | 69 + gmp4/mpn/Makeasm.am | 118 + gmp4/mpn/Makefile.am | 59 + gmp4/mpn/Makefile.in | 760 + gmp4/mpn/README | 44 + gmp4/mpn/alpha/README | 208 + gmp4/mpn/alpha/add_n.asm | 164 + gmp4/mpn/alpha/addmul_1.asm | 99 + gmp4/mpn/alpha/alpha-defs.m4 | 107 + gmp4/mpn/alpha/aorslsh1_n.asm | 164 + gmp4/mpn/alpha/aorslsh2_n.asm | 167 + gmp4/mpn/alpha/bdiv_dbm1c.asm | 282 + gmp4/mpn/alpha/cntlz.asm | 55 + gmp4/mpn/alpha/com.asm | 176 + gmp4/mpn/alpha/copyd.asm | 88 + gmp4/mpn/alpha/copyi.asm | 86 + gmp4/mpn/alpha/default.m4 | 127 + gmp4/mpn/alpha/dive_1.c | 115 + gmp4/mpn/alpha/divrem_2.asm | 177 + gmp4/mpn/alpha/ev5/diveby3.asm | 332 + gmp4/mpn/alpha/ev5/gmp-mparam.h | 187 + gmp4/mpn/alpha/ev6/add_n.asm | 283 + gmp4/mpn/alpha/ev6/aorslsh1_n.asm | 172 + gmp4/mpn/alpha/ev6/aorsmul_1.asm | 398 + gmp4/mpn/alpha/ev6/gmp-mparam.h | 209 + gmp4/mpn/alpha/ev6/mod_1_4.asm | 337 + gmp4/mpn/alpha/ev6/mul_1.asm | 496 + gmp4/mpn/alpha/ev6/nails/README | 65 + gmp4/mpn/alpha/ev6/nails/addmul_1.asm | 396 + gmp4/mpn/alpha/ev6/nails/addmul_2.asm | 146 + gmp4/mpn/alpha/ev6/nails/addmul_3.asm | 169 + gmp4/mpn/alpha/ev6/nails/addmul_4.asm | 210 + gmp4/mpn/alpha/ev6/nails/aors_n.asm | 233 + gmp4/mpn/alpha/ev6/nails/gmp-mparam.h | 72 + gmp4/mpn/alpha/ev6/nails/mul_1.asm | 364 + gmp4/mpn/alpha/ev6/nails/submul_1.asm | 396 + gmp4/mpn/alpha/ev6/slot.pl | 318 + gmp4/mpn/alpha/ev6/sub_n.asm | 283 + gmp4/mpn/alpha/ev67/gcd_1.asm | 145 + gmp4/mpn/alpha/ev67/hamdist.asm | 111 + gmp4/mpn/alpha/ev67/popcount.asm | 101 + gmp4/mpn/alpha/gmp-mparam.h | 86 + gmp4/mpn/alpha/invert_limb.asm | 95 + gmp4/mpn/alpha/lshift.asm | 182 + gmp4/mpn/alpha/mod_34lsub1.asm | 164 + gmp4/mpn/alpha/mode1o.asm | 209 + gmp4/mpn/alpha/mul_1.asm | 102 + gmp4/mpn/alpha/rshift.asm | 180 + gmp4/mpn/alpha/sec_tabselect.asm | 137 + gmp4/mpn/alpha/sqr_diag_addlsh1.asm | 93 + gmp4/mpn/alpha/sub_n.asm | 164 + gmp4/mpn/alpha/submul_1.asm | 99 + gmp4/mpn/alpha/umul.asm | 44 + gmp4/mpn/alpha/unicos.m4 | 131 + gmp4/mpn/arm/README | 35 + gmp4/mpn/arm/aors_n.asm | 112 + gmp4/mpn/arm/aorslsh1_n.asm | 167 + gmp4/mpn/arm/aorsmul_1.asm | 135 + gmp4/mpn/arm/arm-defs.m4 | 91 + gmp4/mpn/arm/bdiv_dbm1c.asm | 113 + gmp4/mpn/arm/cnd_aors_n.asm | 134 + gmp4/mpn/arm/com.asm | 75 + gmp4/mpn/arm/copyd.asm | 84 + gmp4/mpn/arm/copyi.asm | 79 + gmp4/mpn/arm/dive_1.asm | 151 + gmp4/mpn/arm/gmp-mparam.h | 127 + gmp4/mpn/arm/invert_limb.asm | 93 + gmp4/mpn/arm/logops_n.asm | 139 + gmp4/mpn/arm/lshift.asm | 88 + gmp4/mpn/arm/lshiftc.asm | 95 + gmp4/mpn/arm/mod_34lsub1.asm | 121 + gmp4/mpn/arm/mode1o.asm | 92 + gmp4/mpn/arm/mul_1.asm | 94 + gmp4/mpn/arm/neon/README | 2 + gmp4/mpn/arm/neon/hamdist.asm | 194 + gmp4/mpn/arm/neon/lorrshift.asm | 279 + gmp4/mpn/arm/neon/lshiftc.asm | 257 + gmp4/mpn/arm/neon/popcount.asm | 166 + gmp4/mpn/arm/neon/sec_tabselect.asm | 140 + gmp4/mpn/arm/rsh1aors_n.asm | 124 + gmp4/mpn/arm/rshift.asm | 86 + gmp4/mpn/arm/sec_tabselect.asm | 131 + gmp4/mpn/arm/udiv.asm | 104 + gmp4/mpn/arm/v5/gcd_1.asm | 120 + gmp4/mpn/arm/v5/mod_1_1.asm | 129 + gmp4/mpn/arm/v5/mod_1_2.asm | 156 + gmp4/mpn/arm/v6/addmul_1.asm | 111 + gmp4/mpn/arm/v6/addmul_2.asm | 138 + gmp4/mpn/arm/v6/addmul_3.asm | 187 + gmp4/mpn/arm/v6/dive_1.asm | 149 + gmp4/mpn/arm/v6/gmp-mparam.h | 157 + gmp4/mpn/arm/v6/mode1o.asm | 95 + gmp4/mpn/arm/v6/mul_1.asm | 114 + gmp4/mpn/arm/v6/mul_2.asm | 131 + gmp4/mpn/arm/v6/popham.asm | 138 + gmp4/mpn/arm/v6/sqr_basecase.asm | 518 + gmp4/mpn/arm/v6/submul_1.asm | 125 + gmp4/mpn/arm/v6t2/divrem_1.asm | 212 + gmp4/mpn/arm/v6t2/gcd_1.asm | 115 + gmp4/mpn/arm/v7a/cora15/addmul_1.asm | 145 + gmp4/mpn/arm/v7a/cora15/aors_n.asm | 162 + gmp4/mpn/arm/v7a/cora15/cnd_aors_n.asm | 158 + gmp4/mpn/arm/v7a/cora15/com.asm | 180 + gmp4/mpn/arm/v7a/cora15/gmp-mparam.h | 197 + gmp4/mpn/arm/v7a/cora15/logops_n.asm | 253 + gmp4/mpn/arm/v7a/cora15/mul_1.asm | 104 + .../mpn/arm/v7a/cora15/neon/aorsorrlsh1_n.asm | 43 + .../mpn/arm/v7a/cora15/neon/aorsorrlsh2_n.asm | 43 + .../mpn/arm/v7a/cora15/neon/aorsorrlshC_n.asm | 144 + gmp4/mpn/arm/v7a/cora15/neon/com.asm | 97 + gmp4/mpn/arm/v7a/cora15/neon/copyd.asm | 110 + gmp4/mpn/arm/v7a/cora15/neon/copyi.asm | 90 + gmp4/mpn/arm/v7a/cora15/neon/rsh1aors_n.asm | 177 + gmp4/mpn/arm/v7a/cora15/submul_1.asm | 159 + gmp4/mpn/arm/v7a/cora9/gmp-mparam.h | 209 + gmp4/mpn/arm64/aors_n.asm | 98 + gmp4/mpn/arm64/aorsmul_1.asm | 122 + gmp4/mpn/arm64/cnd_aors_n.asm | 99 + gmp4/mpn/arm64/copyd.asm | 93 + gmp4/mpn/arm64/copyi.asm | 77 + gmp4/mpn/arm64/gcd_1.asm | 125 + gmp4/mpn/arm64/invert_limb.asm | 83 + gmp4/mpn/arm64/logops_n.asm | 106 + gmp4/mpn/arm64/mul_1.asm | 98 + gmp4/mpn/asm-defs.m4 | 1761 + gmp4/mpn/cpp-ccas | 118 + gmp4/mpn/cray/README | 121 + gmp4/mpn/cray/add_n.c | 91 + gmp4/mpn/cray/cfp/addmul_1.c | 49 + gmp4/mpn/cray/cfp/mul_1.c | 48 + gmp4/mpn/cray/cfp/mulwwc90.s | 254 + gmp4/mpn/cray/cfp/mulwwj90.s | 253 + gmp4/mpn/cray/cfp/submul_1.c | 49 + gmp4/mpn/cray/gmp-mparam.h | 79 + gmp4/mpn/cray/hamdist.c | 43 + gmp4/mpn/cray/ieee/addmul_1.c | 112 + gmp4/mpn/cray/ieee/gmp-mparam.h | 73 + gmp4/mpn/cray/ieee/invert_limb.c | 128 + gmp4/mpn/cray/ieee/mul_1.c | 104 + gmp4/mpn/cray/ieee/mul_basecase.c | 108 + gmp4/mpn/cray/ieee/sqr_basecase.c | 106 + gmp4/mpn/cray/ieee/submul_1.c | 112 + gmp4/mpn/cray/lshift.c | 59 + gmp4/mpn/cray/mulww.f | 63 + gmp4/mpn/cray/popcount.c | 43 + gmp4/mpn/cray/rshift.c | 59 + gmp4/mpn/cray/sub_n.c | 91 + gmp4/mpn/generic/add.c | 34 + gmp4/mpn/generic/add_1.c | 34 + gmp4/mpn/generic/add_err1_n.c | 101 + gmp4/mpn/generic/add_err2_n.c | 117 + gmp4/mpn/generic/add_err3_n.c | 132 + gmp4/mpn/generic/add_n.c | 90 + gmp4/mpn/generic/add_n_sub_n.c | 173 + gmp4/mpn/generic/addmul_1.c | 139 + gmp4/mpn/generic/bdiv_dbm1c.c | 59 + gmp4/mpn/generic/bdiv_q.c | 77 + gmp4/mpn/generic/bdiv_q_1.c | 126 + gmp4/mpn/generic/bdiv_qr.c | 85 + gmp4/mpn/generic/binvert.c | 102 + gmp4/mpn/generic/broot.c | 196 + gmp4/mpn/generic/brootinv.c | 140 + gmp4/mpn/generic/bsqrt.c | 48 + gmp4/mpn/generic/bsqrtinv.c | 105 + gmp4/mpn/generic/cmp.c | 34 + gmp4/mpn/generic/cnd_add_n.c | 70 + gmp4/mpn/generic/cnd_sub_n.c | 70 + gmp4/mpn/generic/com.c | 45 + gmp4/mpn/generic/comb_tables.c | 48 + gmp4/mpn/generic/copyd.c | 41 + gmp4/mpn/generic/copyi.c | 43 + gmp4/mpn/generic/dcpi1_bdiv_q.c | 160 + gmp4/mpn/generic/dcpi1_bdiv_qr.c | 177 + gmp4/mpn/generic/dcpi1_div_q.c | 87 + gmp4/mpn/generic/dcpi1_div_qr.c | 249 + gmp4/mpn/generic/dcpi1_divappr_q.c | 257 + gmp4/mpn/generic/div_q.c | 323 + gmp4/mpn/generic/div_qr_1.c | 126 + gmp4/mpn/generic/div_qr_1n_pi1.c | 277 + gmp4/mpn/generic/div_qr_1n_pi2.c | 195 + gmp4/mpn/generic/div_qr_1u_pi2.c | 228 + gmp4/mpn/generic/div_qr_2.c | 332 + gmp4/mpn/generic/div_qr_2n_pi1.c | 85 + gmp4/mpn/generic/div_qr_2u_pi1.c | 77 + gmp4/mpn/generic/dive_1.c | 148 + gmp4/mpn/generic/diveby3.c | 174 + gmp4/mpn/generic/divexact.c | 294 + gmp4/mpn/generic/divis.c | 201 + gmp4/mpn/generic/divrem.c | 108 + gmp4/mpn/generic/divrem_1.c | 255 + gmp4/mpn/generic/divrem_2.c | 119 + gmp4/mpn/generic/dump.c | 100 + gmp4/mpn/generic/fib2_ui.c | 189 + gmp4/mpn/generic/gcd.c | 310 + gmp4/mpn/generic/gcd_1.c | 199 + gmp4/mpn/generic/gcd_subdiv_step.c | 205 + gmp4/mpn/generic/gcdext.c | 558 + gmp4/mpn/generic/gcdext_1.c | 328 + gmp4/mpn/generic/gcdext_lehmer.c | 337 + gmp4/mpn/generic/get_d.c | 412 + gmp4/mpn/generic/get_str.c | 553 + gmp4/mpn/generic/gmp-mparam.h | 33 + gmp4/mpn/generic/hgcd.c | 183 + gmp4/mpn/generic/hgcd2.c | 447 + gmp4/mpn/generic/hgcd2_jacobi.c | 366 + gmp4/mpn/generic/hgcd_appr.c | 268 + gmp4/mpn/generic/hgcd_jacobi.c | 244 + gmp4/mpn/generic/hgcd_matrix.c | 266 + gmp4/mpn/generic/hgcd_reduce.c | 247 + gmp4/mpn/generic/hgcd_step.c | 128 + gmp4/mpn/generic/invert.c | 91 + gmp4/mpn/generic/invertappr.c | 314 + gmp4/mpn/generic/jacbase.c | 243 + gmp4/mpn/generic/jacobi.c | 295 + gmp4/mpn/generic/jacobi_2.c | 352 + gmp4/mpn/generic/logops_n.c | 78 + gmp4/mpn/generic/lshift.c | 73 + gmp4/mpn/generic/lshiftc.c | 74 + gmp4/mpn/generic/matrix22_mul.c | 322 + .../generic/matrix22_mul1_inverse_vector.c | 65 + gmp4/mpn/generic/mod_1.c | 281 + gmp4/mpn/generic/mod_1_1.c | 332 + gmp4/mpn/generic/mod_1_2.c | 149 + gmp4/mpn/generic/mod_1_3.c | 157 + gmp4/mpn/generic/mod_1_4.c | 171 + gmp4/mpn/generic/mod_34lsub1.c | 131 + gmp4/mpn/generic/mode1o.c | 236 + gmp4/mpn/generic/mu_bdiv_q.c | 271 + gmp4/mpn/generic/mu_bdiv_qr.c | 289 + gmp4/mpn/generic/mu_div_q.c | 185 + gmp4/mpn/generic/mu_div_qr.c | 416 + gmp4/mpn/generic/mu_divappr_q.c | 363 + gmp4/mpn/generic/mul.c | 428 + gmp4/mpn/generic/mul_1.c | 97 + gmp4/mpn/generic/mul_basecase.c | 166 + gmp4/mpn/generic/mul_fft.c | 1014 + gmp4/mpn/generic/mul_n.c | 97 + gmp4/mpn/generic/mullo_basecase.c | 52 + gmp4/mpn/generic/mullo_n.c | 256 + gmp4/mpn/generic/mulmid.c | 256 + gmp4/mpn/generic/mulmid_basecase.c | 83 + gmp4/mpn/generic/mulmid_n.c | 62 + gmp4/mpn/generic/mulmod_bnm1.c | 355 + gmp4/mpn/generic/neg.c | 34 + gmp4/mpn/generic/nussbaumer_mul.c | 71 + gmp4/mpn/generic/perfpow.c | 417 + gmp4/mpn/generic/perfsqr.c | 240 + gmp4/mpn/generic/popham.c | 126 + gmp4/mpn/generic/pow_1.c | 134 + gmp4/mpn/generic/powlo.c | 174 + gmp4/mpn/generic/powm.c | 590 + gmp4/mpn/generic/pre_divrem_1.c | 146 + gmp4/mpn/generic/pre_mod_1.c | 62 + gmp4/mpn/generic/random.c | 51 + gmp4/mpn/generic/random2.c | 106 + gmp4/mpn/generic/redc_1.c | 57 + gmp4/mpn/generic/redc_2.c | 110 + gmp4/mpn/generic/redc_n.c | 81 + gmp4/mpn/generic/remove.c | 172 + gmp4/mpn/generic/rootrem.c | 415 + gmp4/mpn/generic/rshift.c | 70 + gmp4/mpn/generic/sbpi1_bdiv_q.c | 100 + gmp4/mpn/generic/sbpi1_bdiv_qr.c | 119 + gmp4/mpn/generic/sbpi1_div_q.c | 303 + gmp4/mpn/generic/sbpi1_div_qr.c | 110 + gmp4/mpn/generic/sbpi1_divappr_q.c | 199 + gmp4/mpn/generic/scan0.c | 60 + gmp4/mpn/generic/scan1.c | 60 + gmp4/mpn/generic/sec_aors_1.c | 60 + gmp4/mpn/generic/sec_div.c | 133 + gmp4/mpn/generic/sec_invert.c | 195 + gmp4/mpn/generic/sec_mul.c | 49 + gmp4/mpn/generic/sec_pi1_div.c | 173 + gmp4/mpn/generic/sec_powm.c | 438 + gmp4/mpn/generic/sec_sqr.c | 48 + gmp4/mpn/generic/sec_tabselect.c | 55 + gmp4/mpn/generic/set_str.c | 374 + gmp4/mpn/generic/sizeinbase.c | 50 + gmp4/mpn/generic/sqr.c | 99 + gmp4/mpn/generic/sqr_basecase.c | 325 + gmp4/mpn/generic/sqrmod_bnm1.c | 313 + gmp4/mpn/generic/sqrtrem.c | 357 + gmp4/mpn/generic/sub.c | 34 + gmp4/mpn/generic/sub_1.c | 34 + gmp4/mpn/generic/sub_err1_n.c | 101 + gmp4/mpn/generic/sub_err2_n.c | 117 + gmp4/mpn/generic/sub_err3_n.c | 132 + gmp4/mpn/generic/sub_n.c | 90 + gmp4/mpn/generic/submul_1.c | 139 + gmp4/mpn/generic/tdiv_qr.c | 389 + gmp4/mpn/generic/toom22_mul.c | 210 + gmp4/mpn/generic/toom2_sqr.c | 146 + gmp4/mpn/generic/toom32_mul.c | 323 + gmp4/mpn/generic/toom33_mul.c | 316 + gmp4/mpn/generic/toom3_sqr.c | 226 + gmp4/mpn/generic/toom42_mul.c | 234 + gmp4/mpn/generic/toom42_mulmid.c | 238 + gmp4/mpn/generic/toom43_mul.c | 234 + gmp4/mpn/generic/toom44_mul.c | 236 + gmp4/mpn/generic/toom4_sqr.c | 164 + gmp4/mpn/generic/toom52_mul.c | 257 + gmp4/mpn/generic/toom53_mul.c | 331 + gmp4/mpn/generic/toom54_mul.c | 143 + gmp4/mpn/generic/toom62_mul.c | 311 + gmp4/mpn/generic/toom63_mul.c | 232 + gmp4/mpn/generic/toom6_sqr.c | 182 + gmp4/mpn/generic/toom6h_mul.c | 263 + gmp4/mpn/generic/toom8_sqr.c | 226 + gmp4/mpn/generic/toom8h_mul.c | 306 + gmp4/mpn/generic/toom_couple_handling.c | 81 + gmp4/mpn/generic/toom_eval_dgr3_pm1.c | 73 + gmp4/mpn/generic/toom_eval_dgr3_pm2.c | 98 + gmp4/mpn/generic/toom_eval_pm1.c | 90 + gmp4/mpn/generic/toom_eval_pm2.c | 131 + gmp4/mpn/generic/toom_eval_pm2exp.c | 128 + gmp4/mpn/generic/toom_eval_pm2rexp.c | 102 + gmp4/mpn/generic/toom_interpolate_12pts.c | 361 + gmp4/mpn/generic/toom_interpolate_16pts.c | 527 + gmp4/mpn/generic/toom_interpolate_5pts.c | 199 + gmp4/mpn/generic/toom_interpolate_6pts.c | 240 + gmp4/mpn/generic/toom_interpolate_7pts.c | 266 + gmp4/mpn/generic/toom_interpolate_8pts.c | 212 + gmp4/mpn/generic/trialdiv.c | 132 + gmp4/mpn/generic/udiv_w_sdiv.c | 142 + gmp4/mpn/generic/zero.c | 42 + gmp4/mpn/ia64/README | 281 + gmp4/mpn/ia64/add_n_sub_n.asm | 309 + gmp4/mpn/ia64/addmul_1.asm | 602 + gmp4/mpn/ia64/addmul_2.asm | 708 + gmp4/mpn/ia64/aors_n.asm | 856 + gmp4/mpn/ia64/aorsorrlsh1_n.asm | 48 + gmp4/mpn/ia64/aorsorrlsh2_n.asm | 48 + gmp4/mpn/ia64/aorsorrlshC_n.asm | 397 + gmp4/mpn/ia64/bdiv_dbm1c.asm | 516 + gmp4/mpn/ia64/cnd_aors_n.asm | 259 + gmp4/mpn/ia64/copyd.asm | 186 + gmp4/mpn/ia64/copyi.asm | 182 + gmp4/mpn/ia64/dive_1.asm | 236 + gmp4/mpn/ia64/divrem_1.asm | 477 + gmp4/mpn/ia64/divrem_2.asm | 280 + gmp4/mpn/ia64/gcd_1.asm | 234 + gmp4/mpn/ia64/gmp-mparam.h | 204 + gmp4/mpn/ia64/hamdist.asm | 365 + gmp4/mpn/ia64/ia64-defs.m4 | 147 + gmp4/mpn/ia64/invert_limb.asm | 105 + gmp4/mpn/ia64/logops_n.asm | 292 + gmp4/mpn/ia64/lorrshift.asm | 358 + gmp4/mpn/ia64/lshiftc.asm | 463 + gmp4/mpn/ia64/mod_34lsub1.asm | 236 + gmp4/mpn/ia64/mode1o.asm | 342 + gmp4/mpn/ia64/mul_1.asm | 584 + gmp4/mpn/ia64/mul_2.asm | 620 + gmp4/mpn/ia64/popcount.asm | 200 + gmp4/mpn/ia64/rsh1aors_n.asm | 447 + gmp4/mpn/ia64/sec_tabselect.asm | 150 + gmp4/mpn/ia64/sqr_diag_addlsh1.asm | 144 + gmp4/mpn/ia64/submul_1.asm | 647 + gmp4/mpn/lisp/gmpasm-mode.el | 385 + gmp4/mpn/m4-ccas | 107 + gmp4/mpn/m68k/README | 138 + gmp4/mpn/m68k/aors_n.asm | 99 + gmp4/mpn/m68k/gmp-mparam.h | 76 + gmp4/mpn/m68k/lshift.asm | 175 + gmp4/mpn/m68k/m68k-defs.m4 | 230 + gmp4/mpn/m68k/mc68020/aorsmul_1.asm | 101 + gmp4/mpn/m68k/mc68020/mul_1.asm | 96 + gmp4/mpn/m68k/mc68020/udiv.asm | 45 + gmp4/mpn/m68k/mc68020/umul.asm | 44 + gmp4/mpn/m68k/rshift.asm | 175 + gmp4/mpn/m68k/t-m68k-defs.pl | 91 + gmp4/mpn/m88k/README | 61 + gmp4/mpn/m88k/add_n.s | 113 + gmp4/mpn/m88k/mc88110/add_n.S | 209 + gmp4/mpn/m88k/mc88110/addmul_1.s | 70 + gmp4/mpn/m88k/mc88110/mul_1.s | 68 + gmp4/mpn/m88k/mc88110/sub_n.S | 285 + gmp4/mpn/m88k/mul_1.s | 136 + gmp4/mpn/m88k/sub_n.s | 115 + gmp4/mpn/minithres/gmp-mparam.h | 109 + gmp4/mpn/mips32/add_n.asm | 124 + gmp4/mpn/mips32/addmul_1.asm | 101 + gmp4/mpn/mips32/gmp-mparam.h | 72 + gmp4/mpn/mips32/lshift.asm | 99 + gmp4/mpn/mips32/mips-defs.m4 | 80 + gmp4/mpn/mips32/mips.m4 | 80 + gmp4/mpn/mips32/mul_1.asm | 89 + gmp4/mpn/mips32/rshift.asm | 96 + gmp4/mpn/mips32/sub_n.asm | 123 + gmp4/mpn/mips32/submul_1.asm | 101 + gmp4/mpn/mips32/umul.asm | 45 + gmp4/mpn/mips64/README | 60 + gmp4/mpn/mips64/add_n.asm | 134 + gmp4/mpn/mips64/addmul_1.asm | 101 + gmp4/mpn/mips64/gmp-mparam.h | 72 + gmp4/mpn/mips64/lshift.asm | 99 + gmp4/mpn/mips64/mul_1.asm | 92 + gmp4/mpn/mips64/rshift.asm | 96 + gmp4/mpn/mips64/sqr_diagonal.asm | 77 + gmp4/mpn/mips64/sub_n.asm | 134 + gmp4/mpn/mips64/submul_1.asm | 101 + gmp4/mpn/mips64/umul.asm | 45 + gmp4/mpn/pa32/README | 162 + gmp4/mpn/pa32/add_n.asm | 63 + gmp4/mpn/pa32/gmp-mparam.h | 61 + gmp4/mpn/pa32/hppa1_1/addmul_1.asm | 106 + gmp4/mpn/pa32/hppa1_1/gmp-mparam.h | 72 + gmp4/mpn/pa32/hppa1_1/mul_1.asm | 102 + gmp4/mpn/pa32/hppa1_1/pa7100/add_n.asm | 83 + gmp4/mpn/pa32/hppa1_1/pa7100/addmul_1.asm | 201 + gmp4/mpn/pa32/hppa1_1/pa7100/lshift.asm | 95 + gmp4/mpn/pa32/hppa1_1/pa7100/rshift.asm | 92 + gmp4/mpn/pa32/hppa1_1/pa7100/sub_n.asm | 84 + gmp4/mpn/pa32/hppa1_1/pa7100/submul_1.asm | 207 + gmp4/mpn/pa32/hppa1_1/sqr_diagonal.asm | 60 + gmp4/mpn/pa32/hppa1_1/submul_1.asm | 115 + gmp4/mpn/pa32/hppa1_1/udiv.asm | 102 + gmp4/mpn/pa32/hppa1_1/umul.asm | 47 + gmp4/mpn/pa32/hppa2_0/add_n.asm | 107 + gmp4/mpn/pa32/hppa2_0/gmp-mparam.h | 167 + gmp4/mpn/pa32/hppa2_0/sqr_diagonal.asm | 112 + gmp4/mpn/pa32/hppa2_0/sub_n.asm | 107 + gmp4/mpn/pa32/lshift.asm | 75 + gmp4/mpn/pa32/pa-defs.m4 | 64 + gmp4/mpn/pa32/rshift.asm | 72 + gmp4/mpn/pa32/sub_n.asm | 64 + gmp4/mpn/pa32/udiv.asm | 291 + gmp4/mpn/pa64/README | 78 + gmp4/mpn/pa64/addmul_1.asm | 693 + gmp4/mpn/pa64/aors_n.asm | 130 + gmp4/mpn/pa64/aorslsh1_n.asm | 228 + gmp4/mpn/pa64/gmp-mparam.h | 247 + gmp4/mpn/pa64/lshift.asm | 114 + gmp4/mpn/pa64/mul_1.asm | 646 + gmp4/mpn/pa64/rshift.asm | 111 + gmp4/mpn/pa64/sqr_diagonal.asm | 191 + gmp4/mpn/pa64/submul_1.asm | 700 + gmp4/mpn/pa64/udiv.asm | 125 + gmp4/mpn/pa64/umul.asm | 98 + gmp4/mpn/power/add_n.asm | 83 + gmp4/mpn/power/addmul_1.asm | 126 + gmp4/mpn/power/gmp-mparam.h | 69 + gmp4/mpn/power/lshift.asm | 61 + gmp4/mpn/power/mul_1.asm | 113 + gmp4/mpn/power/rshift.asm | 59 + gmp4/mpn/power/sdiv.asm | 39 + gmp4/mpn/power/sub_n.asm | 85 + gmp4/mpn/power/submul_1.asm | 131 + gmp4/mpn/power/umul.asm | 43 + gmp4/mpn/powerpc32/750/com.asm | 79 + gmp4/mpn/powerpc32/750/gmp-mparam.h | 192 + gmp4/mpn/powerpc32/750/lshift.asm | 155 + gmp4/mpn/powerpc32/750/rshift.asm | 153 + gmp4/mpn/powerpc32/README | 180 + gmp4/mpn/powerpc32/addlsh1_n.asm | 100 + gmp4/mpn/powerpc32/addmul_1.asm | 155 + gmp4/mpn/powerpc32/aix.m4 | 82 + gmp4/mpn/powerpc32/aors_n.asm | 157 + gmp4/mpn/powerpc32/bdiv_dbm1c.asm | 131 + gmp4/mpn/powerpc32/darwin.m4 | 91 + gmp4/mpn/powerpc32/diveby3.asm | 93 + gmp4/mpn/powerpc32/divrem_2.asm | 182 + gmp4/mpn/powerpc32/eabi.m4 | 86 + gmp4/mpn/powerpc32/elf.m4 | 97 + gmp4/mpn/powerpc32/gmp-mparam.h | 217 + gmp4/mpn/powerpc32/invert_limb.asm | 142 + gmp4/mpn/powerpc32/lshift.asm | 166 + gmp4/mpn/powerpc32/lshiftc.asm | 168 + gmp4/mpn/powerpc32/mod_34lsub1.asm | 145 + gmp4/mpn/powerpc32/mode1o.asm | 127 + gmp4/mpn/powerpc32/mul_1.asm | 101 + gmp4/mpn/powerpc32/p3-p7/aors_n.asm | 186 + gmp4/mpn/powerpc32/p3/gmp-mparam.h | 155 + gmp4/mpn/powerpc32/p4/gmp-mparam.h | 204 + gmp4/mpn/powerpc32/p5/gmp-mparam.h | 156 + gmp4/mpn/powerpc32/p6/gmp-mparam.h | 165 + gmp4/mpn/powerpc32/p7/gmp-mparam.h | 159 + gmp4/mpn/powerpc32/powerpc-defs.m4 | 104 + gmp4/mpn/powerpc32/rshift.asm | 164 + gmp4/mpn/powerpc32/sec_tabselect.asm | 141 + gmp4/mpn/powerpc32/sqr_diag_addlsh1.asm | 80 + gmp4/mpn/powerpc32/sublsh1_n.asm | 101 + gmp4/mpn/powerpc32/submul_1.asm | 147 + gmp4/mpn/powerpc32/umul.asm | 50 + gmp4/mpn/powerpc32/vmx/copyd.asm | 203 + gmp4/mpn/powerpc32/vmx/copyi.asm | 198 + gmp4/mpn/powerpc32/vmx/logops_n.asm | 310 + gmp4/mpn/powerpc32/vmx/mod_34lsub1.asm | 386 + gmp4/mpn/powerpc32/vmx/popcount.asm | 34 + gmp4/mpn/powerpc64/README | 166 + gmp4/mpn/powerpc64/aix.m4 | 97 + gmp4/mpn/powerpc64/com.asm | 136 + gmp4/mpn/powerpc64/copyd.asm | 84 + gmp4/mpn/powerpc64/copyi.asm | 78 + gmp4/mpn/powerpc64/darwin.m4 | 119 + gmp4/mpn/powerpc64/elf.m4 | 123 + gmp4/mpn/powerpc64/logops_n.asm | 151 + gmp4/mpn/powerpc64/lshift.asm | 207 + gmp4/mpn/powerpc64/lshiftc.asm | 210 + gmp4/mpn/powerpc64/mode32/add_n.asm | 86 + gmp4/mpn/powerpc64/mode32/addmul_1.asm | 79 + gmp4/mpn/powerpc64/mode32/mul_1.asm | 73 + gmp4/mpn/powerpc64/mode32/p4/gmp-mparam.h | 173 + gmp4/mpn/powerpc64/mode32/sqr_diagonal.asm | 117 + gmp4/mpn/powerpc64/mode32/sub_n.asm | 88 + gmp4/mpn/powerpc64/mode32/submul_1.asm | 82 + gmp4/mpn/powerpc64/mode64/aors_n.asm | 189 + gmp4/mpn/powerpc64/mode64/aorsmul_1.asm | 225 + gmp4/mpn/powerpc64/mode64/aorsorrlsh1_n.asm | 43 + gmp4/mpn/powerpc64/mode64/aorsorrlsh2_n.asm | 43 + gmp4/mpn/powerpc64/mode64/aorsorrlshC_n.asm | 187 + gmp4/mpn/powerpc64/mode64/bdiv_dbm1c.asm | 132 + gmp4/mpn/powerpc64/mode64/cnd_aors_n.asm | 196 + gmp4/mpn/powerpc64/mode64/dive_1.asm | 132 + gmp4/mpn/powerpc64/mode64/divrem_1.asm | 274 + gmp4/mpn/powerpc64/mode64/divrem_2.asm | 187 + gmp4/mpn/powerpc64/mode64/gcd_1.asm | 125 + gmp4/mpn/powerpc64/mode64/gmp-mparam.h | 82 + gmp4/mpn/powerpc64/mode64/invert_limb.asm | 88 + gmp4/mpn/powerpc64/mode64/mod_1_1.asm | 164 + gmp4/mpn/powerpc64/mode64/mod_1_4.asm | 270 + gmp4/mpn/powerpc64/mode64/mod_34lsub1.asm | 132 + gmp4/mpn/powerpc64/mode64/mode1o.asm | 117 + gmp4/mpn/powerpc64/mode64/mul_1.asm | 168 + gmp4/mpn/powerpc64/mode64/mul_basecase.asm | 708 + gmp4/mpn/powerpc64/mode64/p3/gmp-mparam.h | 179 + gmp4/mpn/powerpc64/mode64/p4/gmp-mparam.h | 208 + gmp4/mpn/powerpc64/mode64/p5/gmp-mparam.h | 219 + gmp4/mpn/powerpc64/mode64/p6/aorsmul_1.asm | 183 + gmp4/mpn/powerpc64/mode64/p6/gmp-mparam.h | 160 + gmp4/mpn/powerpc64/mode64/p6/mul_basecase.asm | 589 + gmp4/mpn/powerpc64/mode64/p7/aormul_2.asm | 135 + gmp4/mpn/powerpc64/mode64/p7/aors_n.asm | 128 + .../mpn/powerpc64/mode64/p7/aorsorrlsh1_n.asm | 43 + .../mpn/powerpc64/mode64/p7/aorsorrlsh2_n.asm | 43 + .../mpn/powerpc64/mode64/p7/aorsorrlshC_n.asm | 129 + gmp4/mpn/powerpc64/mode64/p7/gcd_1.asm | 110 + gmp4/mpn/powerpc64/mode64/p7/gmp-mparam.h | 243 + gmp4/mpn/powerpc64/mode64/rsh1aors_n.asm | 172 + gmp4/mpn/powerpc64/mode64/sqr_basecase.asm | 863 + gmp4/mpn/powerpc64/p6/lshift.asm | 132 + gmp4/mpn/powerpc64/p6/lshiftc.asm | 136 + gmp4/mpn/powerpc64/p6/rshift.asm | 131 + gmp4/mpn/powerpc64/p7/copyd.asm | 128 + gmp4/mpn/powerpc64/p7/copyi.asm | 129 + gmp4/mpn/powerpc64/p7/hamdist.asm | 110 + gmp4/mpn/powerpc64/p7/popcount.asm | 90 + gmp4/mpn/powerpc64/rshift.asm | 207 + gmp4/mpn/powerpc64/sec_tabselect.asm | 147 + gmp4/mpn/powerpc64/umul.asm | 53 + gmp4/mpn/powerpc64/vmx/popcount.asm | 230 + gmp4/mpn/s390_32/README | 37 + gmp4/mpn/s390_32/addmul_1.asm | 93 + gmp4/mpn/s390_32/copyd.asm | 145 + gmp4/mpn/s390_32/copyi.asm | 69 + gmp4/mpn/s390_32/esame/addmul_1.asm | 72 + gmp4/mpn/s390_32/esame/aors_n.asm | 137 + gmp4/mpn/s390_32/esame/aorslsh1_n.asm | 173 + gmp4/mpn/s390_32/esame/bdiv_dbm1c.asm | 65 + gmp4/mpn/s390_32/esame/gmp-mparam.h | 207 + gmp4/mpn/s390_32/esame/mul_1.asm | 66 + gmp4/mpn/s390_32/esame/mul_basecase.asm | 130 + gmp4/mpn/s390_32/esame/sqr_basecase.asm | 203 + gmp4/mpn/s390_32/esame/submul_1.asm | 70 + gmp4/mpn/s390_32/gmp-mparam.h | 138 + gmp4/mpn/s390_32/logops_n.asm | 295 + gmp4/mpn/s390_32/lshift.asm | 144 + gmp4/mpn/s390_32/lshiftc.asm | 156 + gmp4/mpn/s390_32/mul_1.asm | 85 + gmp4/mpn/s390_32/rshift.asm | 138 + gmp4/mpn/s390_32/submul_1.asm | 93 + gmp4/mpn/s390_64/README | 88 + gmp4/mpn/s390_64/addmul_1.asm | 72 + gmp4/mpn/s390_64/aorrlsh1_n.asm | 168 + gmp4/mpn/s390_64/aors_n.asm | 136 + gmp4/mpn/s390_64/bdiv_dbm1c.asm | 65 + gmp4/mpn/s390_64/copyd.asm | 144 + gmp4/mpn/s390_64/copyi.asm | 68 + gmp4/mpn/s390_64/gmp-mparam.h | 175 + gmp4/mpn/s390_64/invert_limb.asm | 94 + gmp4/mpn/s390_64/logops_n.asm | 291 + gmp4/mpn/s390_64/lshift.asm | 196 + gmp4/mpn/s390_64/lshiftc.asm | 207 + gmp4/mpn/s390_64/mod_34lsub1.asm | 109 + gmp4/mpn/s390_64/mul_1.asm | 66 + gmp4/mpn/s390_64/mul_basecase.asm | 130 + gmp4/mpn/s390_64/rshift.asm | 195 + gmp4/mpn/s390_64/sqr_basecase.asm | 203 + gmp4/mpn/s390_64/sublsh1_n.asm | 169 + gmp4/mpn/s390_64/submul_1.asm | 70 + gmp4/mpn/s390_64/z10/gmp-mparam.h | 231 + gmp4/mpn/sh/add_n.asm | 59 + gmp4/mpn/sh/sh2/addmul_1.asm | 65 + gmp4/mpn/sh/sh2/mul_1.asm | 62 + gmp4/mpn/sh/sh2/submul_1.asm | 65 + gmp4/mpn/sh/sub_n.asm | 59 + gmp4/mpn/sparc32/README | 71 + gmp4/mpn/sparc32/add_n.asm | 245 + gmp4/mpn/sparc32/addmul_1.asm | 155 + gmp4/mpn/sparc32/gmp-mparam.h | 67 + gmp4/mpn/sparc32/lshift.asm | 105 + gmp4/mpn/sparc32/mul_1.asm | 146 + gmp4/mpn/sparc32/rshift.asm | 102 + gmp4/mpn/sparc32/sparc-defs.m4 | 79 + gmp4/mpn/sparc32/sub_n.asm | 335 + gmp4/mpn/sparc32/submul_1.asm | 155 + gmp4/mpn/sparc32/udiv.asm | 167 + gmp4/mpn/sparc32/udiv_nfp.asm | 202 + gmp4/mpn/sparc32/ultrasparct1/add_n.asm | 70 + gmp4/mpn/sparc32/ultrasparct1/addmul_1.asm | 90 + gmp4/mpn/sparc32/ultrasparct1/gmp-mparam.h | 153 + gmp4/mpn/sparc32/ultrasparct1/mul_1.asm | 83 + .../mpn/sparc32/ultrasparct1/sqr_diagonal.asm | 55 + gmp4/mpn/sparc32/ultrasparct1/sub_n.asm | 70 + gmp4/mpn/sparc32/ultrasparct1/submul_1.asm | 91 + gmp4/mpn/sparc32/umul.asm | 77 + gmp4/mpn/sparc32/v8/addmul_1.asm | 131 + gmp4/mpn/sparc32/v8/gmp-mparam.h | 73 + gmp4/mpn/sparc32/v8/mul_1.asm | 112 + gmp4/mpn/sparc32/v8/submul_1.asm | 67 + gmp4/mpn/sparc32/v8/supersparc/gmp-mparam.h | 73 + gmp4/mpn/sparc32/v8/supersparc/udiv.asm | 131 + gmp4/mpn/sparc32/v8/udiv.asm | 131 + gmp4/mpn/sparc32/v8/umul.asm | 40 + gmp4/mpn/sparc32/v9/README | 4 + gmp4/mpn/sparc32/v9/add_n.asm | 129 + gmp4/mpn/sparc32/v9/addmul_1.asm | 306 + gmp4/mpn/sparc32/v9/gmp-mparam.h | 204 + gmp4/mpn/sparc32/v9/mul_1.asm | 287 + gmp4/mpn/sparc32/v9/sqr_diagonal.asm | 462 + gmp4/mpn/sparc32/v9/sub_n.asm | 129 + gmp4/mpn/sparc32/v9/submul_1.asm | 316 + gmp4/mpn/sparc32/v9/udiv.asm | 52 + gmp4/mpn/sparc64/README | 125 + gmp4/mpn/sparc64/copyd.asm | 89 + gmp4/mpn/sparc64/copyi.asm | 86 + gmp4/mpn/sparc64/dive_1.c | 158 + gmp4/mpn/sparc64/divrem_1.c | 243 + gmp4/mpn/sparc64/gcd_1.asm | 135 + gmp4/mpn/sparc64/gmp-mparam.h | 139 + gmp4/mpn/sparc64/lshift.asm | 140 + gmp4/mpn/sparc64/lshiftc.asm | 147 + gmp4/mpn/sparc64/mod_1.c | 239 + gmp4/mpn/sparc64/mod_1_4.c | 236 + gmp4/mpn/sparc64/mode1o.c | 197 + gmp4/mpn/sparc64/rshift.asm | 142 + gmp4/mpn/sparc64/sec_tabselect.asm | 162 + gmp4/mpn/sparc64/sparc64.h | 219 + gmp4/mpn/sparc64/ultrasparc1234/add_n.asm | 241 + gmp4/mpn/sparc64/ultrasparc1234/addmul_1.asm | 606 + gmp4/mpn/sparc64/ultrasparc1234/addmul_2.asm | 551 + gmp4/mpn/sparc64/ultrasparc1234/lshiftc.asm | 165 + gmp4/mpn/sparc64/ultrasparc1234/mul_1.asm | 580 + .../sparc64/ultrasparc1234/sqr_diagonal.asm | 342 + gmp4/mpn/sparc64/ultrasparc1234/sub_n.asm | 241 + gmp4/mpn/sparc64/ultrasparc1234/submul_1.asm | 68 + gmp4/mpn/sparc64/ultrasparc34/gmp-mparam.h | 219 + gmp4/mpn/sparc64/ultrasparct1/add_n.asm | 68 + gmp4/mpn/sparc64/ultrasparct1/addlsh1_n.asm | 41 + gmp4/mpn/sparc64/ultrasparct1/addlsh2_n.asm | 41 + gmp4/mpn/sparc64/ultrasparct1/addlshC_n.asm | 69 + gmp4/mpn/sparc64/ultrasparct1/addmul_1.asm | 86 + gmp4/mpn/sparc64/ultrasparct1/gmp-mparam.h | 154 + gmp4/mpn/sparc64/ultrasparct1/mul_1.asm | 82 + gmp4/mpn/sparc64/ultrasparct1/rsblsh1_n.asm | 41 + gmp4/mpn/sparc64/ultrasparct1/rsblsh2_n.asm | 41 + gmp4/mpn/sparc64/ultrasparct1/rsblshC_n.asm | 69 + gmp4/mpn/sparc64/ultrasparct1/sub_n.asm | 68 + gmp4/mpn/sparc64/ultrasparct1/sublsh1_n.asm | 41 + gmp4/mpn/sparc64/ultrasparct1/sublsh2_n.asm | 41 + gmp4/mpn/sparc64/ultrasparct1/sublshC_n.asm | 69 + gmp4/mpn/sparc64/ultrasparct1/submul_1.asm | 86 + gmp4/mpn/sparc64/ultrasparct3/add_n.asm | 126 + gmp4/mpn/sparc64/ultrasparct3/addmul_1.asm | 182 + gmp4/mpn/sparc64/ultrasparct3/aormul_2.asm | 228 + gmp4/mpn/sparc64/ultrasparct3/aormul_4.asm | 219 + gmp4/mpn/sparc64/ultrasparct3/aorslsh_n.asm | 147 + gmp4/mpn/sparc64/ultrasparct3/bdiv_dbm1c.asm | 147 + gmp4/mpn/sparc64/ultrasparct3/cnd_aors_n.asm | 143 + gmp4/mpn/sparc64/ultrasparct3/dive_1.asm | 129 + gmp4/mpn/sparc64/ultrasparct3/hamdist.asm | 78 + gmp4/mpn/sparc64/ultrasparct3/invert_limb.asm | 92 + gmp4/mpn/sparc64/ultrasparct3/missing.asm | 77 + gmp4/mpn/sparc64/ultrasparct3/missing.m4 | 88 + gmp4/mpn/sparc64/ultrasparct3/mod_1_4.asm | 233 + gmp4/mpn/sparc64/ultrasparct3/mod_34lsub1.asm | 117 + gmp4/mpn/sparc64/ultrasparct3/mode1o.asm | 82 + gmp4/mpn/sparc64/ultrasparct3/mul_1.asm | 174 + gmp4/mpn/sparc64/ultrasparct3/popcount.asm | 70 + .../sparc64/ultrasparct3/sqr_diag_addlsh1.asm | 93 + gmp4/mpn/sparc64/ultrasparct3/sub_n.asm | 144 + gmp4/mpn/sparc64/ultrasparct3/submul_1.asm | 170 + gmp4/mpn/thumb/add_n.asm | 63 + gmp4/mpn/thumb/sub_n.asm | 63 + gmp4/mpn/vax/add_n.asm | 64 + gmp4/mpn/vax/addmul_1.asm | 124 + gmp4/mpn/vax/elf.m4 | 54 + gmp4/mpn/vax/gmp-mparam.h | 60 + gmp4/mpn/vax/lshift.asm | 59 + gmp4/mpn/vax/mul_1.asm | 118 + gmp4/mpn/vax/rshift.asm | 57 + gmp4/mpn/vax/sub_n.asm | 64 + gmp4/mpn/vax/submul_1.asm | 124 + gmp4/mpn/x86/README | 525 + gmp4/mpn/x86/aors_n.asm | 202 + gmp4/mpn/x86/aorsmul_1.asm | 156 + gmp4/mpn/x86/atom/aorrlsh1_n.asm | 53 + gmp4/mpn/x86/atom/aorrlsh2_n.asm | 53 + gmp4/mpn/x86/atom/aorrlshC_n.asm | 156 + gmp4/mpn/x86/atom/aors_n.asm | 159 + gmp4/mpn/x86/atom/aorslshC_n.asm | 247 + gmp4/mpn/x86/atom/bdiv_q_1.asm | 35 + gmp4/mpn/x86/atom/cnd_add_n.asm | 113 + gmp4/mpn/x86/atom/cnd_sub_n.asm | 124 + gmp4/mpn/x86/atom/dive_1.asm | 34 + gmp4/mpn/x86/atom/gmp-mparam.h | 201 + gmp4/mpn/x86/atom/logops_n.asm | 151 + gmp4/mpn/x86/atom/lshift.asm | 218 + gmp4/mpn/x86/atom/lshiftc.asm | 159 + gmp4/mpn/x86/atom/mmx/copyd.asm | 34 + gmp4/mpn/x86/atom/mmx/copyi.asm | 34 + gmp4/mpn/x86/atom/mmx/hamdist.asm | 34 + gmp4/mpn/x86/atom/mod_34lsub1.asm | 34 + gmp4/mpn/x86/atom/mode1o.asm | 34 + gmp4/mpn/x86/atom/rshift.asm | 152 + gmp4/mpn/x86/atom/sse2/aorsmul_1.asm | 174 + gmp4/mpn/x86/atom/sse2/bdiv_dbm1c.asm | 34 + gmp4/mpn/x86/atom/sse2/divrem_1.asm | 34 + gmp4/mpn/x86/atom/sse2/mod_1_1.asm | 34 + gmp4/mpn/x86/atom/sse2/mod_1_4.asm | 34 + gmp4/mpn/x86/atom/sse2/mul_1.asm | 124 + gmp4/mpn/x86/atom/sse2/mul_basecase.asm | 501 + gmp4/mpn/x86/atom/sse2/popcount.asm | 35 + gmp4/mpn/x86/atom/sse2/sqr_basecase.asm | 634 + gmp4/mpn/x86/atom/sublsh1_n.asm | 34 + gmp4/mpn/x86/atom/sublsh2_n.asm | 57 + gmp4/mpn/x86/bd1/gmp-mparam.h | 208 + gmp4/mpn/x86/bd2/gmp-mparam.h | 209 + gmp4/mpn/x86/bdiv_dbm1c.asm | 129 + gmp4/mpn/x86/bdiv_q_1.asm | 208 + gmp4/mpn/x86/bobcat/gmp-mparam.h | 197 + gmp4/mpn/x86/cnd_aors_n.asm | 124 + gmp4/mpn/x86/copyd.asm | 91 + gmp4/mpn/x86/copyi.asm | 99 + gmp4/mpn/x86/core2/gmp-mparam.h | 200 + gmp4/mpn/x86/coreihwl/gmp-mparam.h | 210 + gmp4/mpn/x86/coreinhm/gmp-mparam.h | 224 + gmp4/mpn/x86/coreisbr/gmp-mparam.h | 203 + gmp4/mpn/x86/darwin.m4 | 82 + gmp4/mpn/x86/dive_1.asm | 189 + gmp4/mpn/x86/divrem_1.asm | 233 + gmp4/mpn/x86/divrem_2.asm | 199 + gmp4/mpn/x86/fat/com.c | 32 + gmp4/mpn/x86/fat/fat.c | 473 + gmp4/mpn/x86/fat/fat_entry.asm | 220 + gmp4/mpn/x86/fat/gcd_1.c | 32 + gmp4/mpn/x86/fat/gmp-mparam.h | 71 + gmp4/mpn/x86/fat/lshiftc.c | 32 + gmp4/mpn/x86/fat/mod_1.c | 32 + gmp4/mpn/x86/fat/mod_1_1.c | 36 + gmp4/mpn/x86/fat/mod_1_2.c | 36 + gmp4/mpn/x86/fat/mod_1_4.c | 36 + gmp4/mpn/x86/fat/mode1o.c | 32 + gmp4/mpn/x86/fat/mullo_basecase.c | 32 + gmp4/mpn/x86/fat/redc_1.c | 32 + gmp4/mpn/x86/fat/redc_2.c | 32 + gmp4/mpn/x86/geode/gmp-mparam.h | 141 + gmp4/mpn/x86/gmp-mparam.h | 38 + gmp4/mpn/x86/i486/gmp-mparam.h | 69 + gmp4/mpn/x86/k10/gmp-mparam.h | 211 + gmp4/mpn/x86/k6/README | 251 + gmp4/mpn/x86/k6/aors_n.asm | 337 + gmp4/mpn/x86/k6/aorsmul_1.asm | 391 + gmp4/mpn/x86/k6/cross.pl | 182 + gmp4/mpn/x86/k6/divrem_1.asm | 203 + gmp4/mpn/x86/k6/gcd_1.asm | 362 + gmp4/mpn/x86/k6/gmp-mparam.h | 166 + gmp4/mpn/x86/k6/k62mmx/copyd.asm | 118 + gmp4/mpn/x86/k6/k62mmx/lshift.asm | 294 + gmp4/mpn/x86/k6/k62mmx/rshift.asm | 293 + gmp4/mpn/x86/k6/mmx/com.asm | 103 + gmp4/mpn/x86/k6/mmx/dive_1.asm | 281 + gmp4/mpn/x86/k6/mmx/logops_n.asm | 226 + gmp4/mpn/x86/k6/mmx/lshift.asm | 130 + gmp4/mpn/x86/k6/mmx/popham.asm | 236 + gmp4/mpn/x86/k6/mmx/rshift.asm | 130 + gmp4/mpn/x86/k6/mod_34lsub1.asm | 190 + gmp4/mpn/x86/k6/mode1o.asm | 175 + gmp4/mpn/x86/k6/mul_1.asm | 292 + gmp4/mpn/x86/k6/mul_basecase.asm | 612 + gmp4/mpn/x86/k6/pre_mod_1.asm | 146 + gmp4/mpn/x86/k6/sqr_basecase.asm | 680 + gmp4/mpn/x86/k7/README | 174 + gmp4/mpn/x86/k7/addlsh1_n.asm | 196 + gmp4/mpn/x86/k7/aors_n.asm | 258 + gmp4/mpn/x86/k7/aorsmul_1.asm | 167 + gmp4/mpn/x86/k7/bdiv_q_1.asm | 244 + gmp4/mpn/x86/k7/dive_1.asm | 207 + gmp4/mpn/x86/k7/gcd_1.asm | 186 + gmp4/mpn/x86/k7/gmp-mparam.h | 241 + gmp4/mpn/x86/k7/invert_limb.asm | 193 + gmp4/mpn/x86/k7/mmx/com.asm | 125 + gmp4/mpn/x86/k7/mmx/copyd.asm | 144 + gmp4/mpn/x86/k7/mmx/copyi.asm | 157 + gmp4/mpn/x86/k7/mmx/divrem_1.asm | 832 + gmp4/mpn/x86/k7/mmx/lshift.asm | 481 + gmp4/mpn/x86/k7/mmx/popham.asm | 213 + gmp4/mpn/x86/k7/mmx/rshift.asm | 480 + gmp4/mpn/x86/k7/mod_1_1.asm | 221 + gmp4/mpn/x86/k7/mod_1_4.asm | 260 + gmp4/mpn/x86/k7/mod_34lsub1.asm | 188 + gmp4/mpn/x86/k7/mode1o.asm | 180 + gmp4/mpn/x86/k7/mul_1.asm | 237 + gmp4/mpn/x86/k7/mul_basecase.asm | 602 + gmp4/mpn/x86/k7/sqr_basecase.asm | 635 + gmp4/mpn/x86/k7/sublsh1_n.asm | 173 + gmp4/mpn/x86/k8/gmp-mparam.h | 198 + gmp4/mpn/x86/lshift.asm | 106 + gmp4/mpn/x86/mmx/sec_tabselect.asm | 163 + gmp4/mpn/x86/mod_34lsub1.asm | 183 + gmp4/mpn/x86/mul_1.asm | 140 + gmp4/mpn/x86/mul_basecase.asm | 223 + gmp4/mpn/x86/nano/gmp-mparam.h | 162 + gmp4/mpn/x86/p6/README | 125 + gmp4/mpn/x86/p6/aors_n.asm | 156 + gmp4/mpn/x86/p6/aorsmul_1.asm | 320 + gmp4/mpn/x86/p6/bdiv_q_1.asm | 286 + gmp4/mpn/x86/p6/copyd.asm | 178 + gmp4/mpn/x86/p6/dive_1.asm | 266 + gmp4/mpn/x86/p6/gcd_1.asm | 156 + gmp4/mpn/x86/p6/gmp-mparam.h | 194 + gmp4/mpn/x86/p6/lshsub_n.asm | 169 + gmp4/mpn/x86/p6/mmx/divrem_1.asm | 767 + gmp4/mpn/x86/p6/mmx/gmp-mparam.h | 198 + gmp4/mpn/x86/p6/mmx/lshift.asm | 38 + gmp4/mpn/x86/p6/mmx/popham.asm | 39 + gmp4/mpn/x86/p6/mmx/rshift.asm | 38 + gmp4/mpn/x86/p6/mod_34lsub1.asm | 190 + gmp4/mpn/x86/p6/mode1o.asm | 169 + gmp4/mpn/x86/p6/mul_basecase.asm | 607 + gmp4/mpn/x86/p6/p3mmx/popham.asm | 42 + gmp4/mpn/x86/p6/sqr_basecase.asm | 649 + gmp4/mpn/x86/p6/sse2/addmul_1.asm | 37 + gmp4/mpn/x86/p6/sse2/gmp-mparam.h | 197 + gmp4/mpn/x86/p6/sse2/mod_1_1.asm | 34 + gmp4/mpn/x86/p6/sse2/mod_1_4.asm | 34 + gmp4/mpn/x86/p6/sse2/mul_1.asm | 38 + gmp4/mpn/x86/p6/sse2/mul_basecase.asm | 35 + gmp4/mpn/x86/p6/sse2/popcount.asm | 35 + gmp4/mpn/x86/p6/sse2/sqr_basecase.asm | 35 + gmp4/mpn/x86/p6/sse2/submul_1.asm | 35 + gmp4/mpn/x86/pentium/README | 181 + gmp4/mpn/x86/pentium/aors_n.asm | 203 + gmp4/mpn/x86/pentium/aorsmul_1.asm | 144 + gmp4/mpn/x86/pentium/bdiv_q_1.asm | 260 + gmp4/mpn/x86/pentium/com.asm | 181 + gmp4/mpn/x86/pentium/copyd.asm | 146 + gmp4/mpn/x86/pentium/copyi.asm | 164 + gmp4/mpn/x86/pentium/dive_1.asm | 272 + gmp4/mpn/x86/pentium/gmp-mparam.h | 76 + gmp4/mpn/x86/pentium/hamdist.asm | 143 + gmp4/mpn/x86/pentium/logops_n.asm | 176 + gmp4/mpn/x86/pentium/lshift.asm | 243 + gmp4/mpn/x86/pentium/mmx/gmp-mparam.h | 163 + gmp4/mpn/x86/pentium/mmx/hamdist.asm | 40 + gmp4/mpn/x86/pentium/mmx/lshift.asm | 463 + gmp4/mpn/x86/pentium/mmx/mul_1.asm | 371 + gmp4/mpn/x86/pentium/mmx/rshift.asm | 468 + gmp4/mpn/x86/pentium/mod_34lsub1.asm | 192 + gmp4/mpn/x86/pentium/mode1o.asm | 266 + gmp4/mpn/x86/pentium/mul_1.asm | 177 + gmp4/mpn/x86/pentium/mul_2.asm | 150 + gmp4/mpn/x86/pentium/mul_basecase.asm | 143 + gmp4/mpn/x86/pentium/popcount.asm | 134 + gmp4/mpn/x86/pentium/rshift.asm | 243 + gmp4/mpn/x86/pentium/sqr_basecase.asm | 528 + gmp4/mpn/x86/pentium4/README | 124 + gmp4/mpn/x86/pentium4/copyd.asm | 71 + gmp4/mpn/x86/pentium4/copyi.asm | 93 + gmp4/mpn/x86/pentium4/mmx/lshift.asm | 39 + gmp4/mpn/x86/pentium4/mmx/popham.asm | 203 + gmp4/mpn/x86/pentium4/mmx/rshift.asm | 39 + gmp4/mpn/x86/pentium4/sse2/add_n.asm | 101 + gmp4/mpn/x86/pentium4/sse2/addlsh1_n.asm | 108 + gmp4/mpn/x86/pentium4/sse2/addmul_1.asm | 189 + gmp4/mpn/x86/pentium4/sse2/bdiv_dbm1c.asm | 141 + gmp4/mpn/x86/pentium4/sse2/bdiv_q_1.asm | 233 + gmp4/mpn/x86/pentium4/sse2/cnd_add_n.asm | 95 + gmp4/mpn/x86/pentium4/sse2/cnd_sub_n.asm | 114 + gmp4/mpn/x86/pentium4/sse2/dive_1.asm | 215 + gmp4/mpn/x86/pentium4/sse2/divrem_1.asm | 645 + gmp4/mpn/x86/pentium4/sse2/gmp-mparam.h | 206 + gmp4/mpn/x86/pentium4/sse2/mod_1_1.asm | 166 + gmp4/mpn/x86/pentium4/sse2/mod_1_4.asm | 269 + gmp4/mpn/x86/pentium4/sse2/mod_34lsub1.asm | 175 + gmp4/mpn/x86/pentium4/sse2/mode1o.asm | 174 + gmp4/mpn/x86/pentium4/sse2/mul_1.asm | 164 + gmp4/mpn/x86/pentium4/sse2/mul_basecase.asm | 662 + gmp4/mpn/x86/pentium4/sse2/popcount.asm | 280 + gmp4/mpn/x86/pentium4/sse2/rsh1add_n.asm | 126 + gmp4/mpn/x86/pentium4/sse2/sqr_basecase.asm | 705 + gmp4/mpn/x86/pentium4/sse2/sub_n.asm | 119 + gmp4/mpn/x86/pentium4/sse2/submul_1.asm | 182 + gmp4/mpn/x86/rshift.asm | 108 + gmp4/mpn/x86/sec_tabselect.asm | 115 + gmp4/mpn/x86/sqr_basecase.asm | 359 + gmp4/mpn/x86/t-zdisp.sh | 71 + gmp4/mpn/x86/t-zdisp2.pl | 147 + gmp4/mpn/x86/udiv.asm | 52 + gmp4/mpn/x86/umul.asm | 51 + gmp4/mpn/x86/x86-defs.m4 | 999 + gmp4/mpn/x86_64/README | 74 + gmp4/mpn/x86_64/addaddmul_1msb0.asm | 170 + gmp4/mpn/x86_64/addmul_2.asm | 184 + gmp4/mpn/x86_64/aorrlsh1_n.asm | 170 + gmp4/mpn/x86_64/aorrlsh2_n.asm | 53 + gmp4/mpn/x86_64/aorrlshC_n.asm | 160 + gmp4/mpn/x86_64/aorrlsh_n.asm | 176 + gmp4/mpn/x86_64/aors_err1_n.asm | 225 + gmp4/mpn/x86_64/aors_err2_n.asm | 172 + gmp4/mpn/x86_64/aors_err3_n.asm | 156 + gmp4/mpn/x86_64/aors_n.asm | 169 + gmp4/mpn/x86_64/aorsmul_1.asm | 180 + gmp4/mpn/x86_64/atom/addmul_2.asm | 186 + gmp4/mpn/x86_64/atom/aorrlsh1_n.asm | 238 + gmp4/mpn/x86_64/atom/aorrlsh2_n.asm | 191 + gmp4/mpn/x86_64/atom/aors_n.asm | 37 + gmp4/mpn/x86_64/atom/aorsmul_1.asm | 190 + gmp4/mpn/x86_64/atom/com.asm | 37 + gmp4/mpn/x86_64/atom/copyd.asm | 37 + gmp4/mpn/x86_64/atom/copyi.asm | 37 + gmp4/mpn/x86_64/atom/dive_1.asm | 37 + gmp4/mpn/x86_64/atom/gmp-mparam.h | 220 + gmp4/mpn/x86_64/atom/lshift.asm | 123 + gmp4/mpn/x86_64/atom/lshiftc.asm | 127 + gmp4/mpn/x86_64/atom/mul_1.asm | 143 + gmp4/mpn/x86_64/atom/mul_2.asm | 186 + gmp4/mpn/x86_64/atom/popcount.asm | 35 + gmp4/mpn/x86_64/atom/redc_1.asm | 574 + gmp4/mpn/x86_64/atom/rsh1aors_n.asm | 287 + gmp4/mpn/x86_64/atom/rshift.asm | 121 + gmp4/mpn/x86_64/atom/sublsh1_n.asm | 242 + gmp4/mpn/x86_64/bd1/README | 11 + gmp4/mpn/x86_64/bd1/aorrlsh1_n.asm | 37 + gmp4/mpn/x86_64/bd1/aorsmul_1.asm | 181 + gmp4/mpn/x86_64/bd1/com.asm | 37 + gmp4/mpn/x86_64/bd1/copyd.asm | 37 + gmp4/mpn/x86_64/bd1/copyi.asm | 37 + gmp4/mpn/x86_64/bd1/gcd_1.asm | 37 + gmp4/mpn/x86_64/bd1/gmp-mparam.h | 236 + gmp4/mpn/x86_64/bd1/hamdist.asm | 38 + gmp4/mpn/x86_64/bd1/mul_1.asm | 184 + gmp4/mpn/x86_64/bd1/mul_2.asm | 192 + gmp4/mpn/x86_64/bd1/mul_basecase.asm | 416 + gmp4/mpn/x86_64/bd1/popcount.asm | 38 + gmp4/mpn/x86_64/bd1/sec_tabselect.asm | 37 + gmp4/mpn/x86_64/bd1/sublsh1_n.asm | 37 + gmp4/mpn/x86_64/bd2/gmp-mparam.h | 237 + gmp4/mpn/x86_64/bdiv_dbm1c.asm | 106 + gmp4/mpn/x86_64/bdiv_q_1.asm | 167 + gmp4/mpn/x86_64/bobcat/aors_n.asm | 150 + gmp4/mpn/x86_64/bobcat/aorsmul_1.asm | 183 + gmp4/mpn/x86_64/bobcat/copyd.asm | 91 + gmp4/mpn/x86_64/bobcat/copyi.asm | 94 + gmp4/mpn/x86_64/bobcat/gmp-mparam.h | 208 + gmp4/mpn/x86_64/bobcat/mul_1.asm | 187 + gmp4/mpn/x86_64/bobcat/mul_basecase.asm | 486 + gmp4/mpn/x86_64/bobcat/redc_1.asm | 502 + gmp4/mpn/x86_64/bobcat/sqr_basecase.asm | 565 + gmp4/mpn/x86_64/cnd_aors_n.asm | 183 + gmp4/mpn/x86_64/com.asm | 95 + gmp4/mpn/x86_64/copyd.asm | 93 + gmp4/mpn/x86_64/copyi.asm | 92 + gmp4/mpn/x86_64/core2/aorrlsh1_n.asm | 53 + gmp4/mpn/x86_64/core2/aorrlsh2_n.asm | 53 + gmp4/mpn/x86_64/core2/aorrlsh_n.asm | 38 + gmp4/mpn/x86_64/core2/aors_err1_n.asm | 225 + gmp4/mpn/x86_64/core2/aors_n.asm | 141 + gmp4/mpn/x86_64/core2/aorsmul_1.asm | 178 + gmp4/mpn/x86_64/core2/copyd.asm | 37 + gmp4/mpn/x86_64/core2/copyi.asm | 37 + gmp4/mpn/x86_64/core2/divrem_1.asm | 237 + gmp4/mpn/x86_64/core2/gcd_1.asm | 144 + gmp4/mpn/x86_64/core2/gmp-mparam.h | 217 + gmp4/mpn/x86_64/core2/lshift.asm | 149 + gmp4/mpn/x86_64/core2/lshiftc.asm | 159 + gmp4/mpn/x86_64/core2/mul_basecase.asm | 975 + gmp4/mpn/x86_64/core2/mullo_basecase.asm | 427 + gmp4/mpn/x86_64/core2/popcount.asm | 35 + gmp4/mpn/x86_64/core2/redc_1.asm | 425 + gmp4/mpn/x86_64/core2/rsh1aors_n.asm | 169 + gmp4/mpn/x86_64/core2/rshift.asm | 147 + gmp4/mpn/x86_64/core2/sec_tabselect.asm | 37 + gmp4/mpn/x86_64/core2/sqr_basecase.asm | 984 + gmp4/mpn/x86_64/core2/sublsh1_n.asm | 47 + gmp4/mpn/x86_64/core2/sublsh2_n.asm | 47 + gmp4/mpn/x86_64/core2/sublshC_n.asm | 158 + gmp4/mpn/x86_64/coreihwl/addmul_2.asm | 238 + gmp4/mpn/x86_64/coreihwl/aorsmul_1.asm | 198 + gmp4/mpn/x86_64/coreihwl/gmp-mparam.h | 237 + gmp4/mpn/x86_64/coreihwl/mul_1.asm | 155 + gmp4/mpn/x86_64/coreihwl/mul_2.asm | 173 + gmp4/mpn/x86_64/coreihwl/mul_basecase.asm | 441 + gmp4/mpn/x86_64/coreihwl/mullo_basecase.asm | 426 + gmp4/mpn/x86_64/coreihwl/redc_1.asm | 433 + gmp4/mpn/x86_64/coreihwl/sqr_basecase.asm | 506 + gmp4/mpn/x86_64/coreinhm/aorrlsh_n.asm | 200 + gmp4/mpn/x86_64/coreinhm/aorsmul_1.asm | 187 + gmp4/mpn/x86_64/coreinhm/gmp-mparam.h | 231 + gmp4/mpn/x86_64/coreinhm/hamdist.asm | 38 + gmp4/mpn/x86_64/coreinhm/popcount.asm | 38 + gmp4/mpn/x86_64/coreinhm/redc_1.asm | 544 + gmp4/mpn/x86_64/coreinhm/sec_tabselect.asm | 37 + gmp4/mpn/x86_64/coreisbr/addmul_2.asm | 224 + gmp4/mpn/x86_64/coreisbr/aorrlsh1_n.asm | 54 + gmp4/mpn/x86_64/coreisbr/aorrlsh2_n.asm | 56 + gmp4/mpn/x86_64/coreisbr/aorrlshC_n.asm | 173 + gmp4/mpn/x86_64/coreisbr/aorrlsh_n.asm | 215 + gmp4/mpn/x86_64/coreisbr/aors_n.asm | 198 + gmp4/mpn/x86_64/coreisbr/aorsmul_1.asm | 209 + gmp4/mpn/x86_64/coreisbr/divrem_1.asm | 37 + gmp4/mpn/x86_64/coreisbr/gmp-mparam.h | 224 + gmp4/mpn/x86_64/coreisbr/lshift.asm | 37 + gmp4/mpn/x86_64/coreisbr/lshiftc.asm | 37 + gmp4/mpn/x86_64/coreisbr/mul_1.asm | 161 + gmp4/mpn/x86_64/coreisbr/mul_2.asm | 163 + gmp4/mpn/x86_64/coreisbr/mul_basecase.asm | 407 + gmp4/mpn/x86_64/coreisbr/mullo_basecase.asm | 384 + gmp4/mpn/x86_64/coreisbr/popcount.asm | 118 + gmp4/mpn/x86_64/coreisbr/redc_1.asm | 541 + gmp4/mpn/x86_64/coreisbr/rsh1aors_n.asm | 193 + gmp4/mpn/x86_64/coreisbr/rshift.asm | 37 + gmp4/mpn/x86_64/coreisbr/sec_tabselect.asm | 37 + gmp4/mpn/x86_64/coreisbr/sqr_basecase.asm | 484 + gmp4/mpn/x86_64/darwin.m4 | 81 + gmp4/mpn/x86_64/div_qr_1n_pi1.asm | 247 + gmp4/mpn/x86_64/div_qr_2n_pi1.asm | 158 + gmp4/mpn/x86_64/div_qr_2u_pi1.asm | 200 + gmp4/mpn/x86_64/dive_1.asm | 158 + gmp4/mpn/x86_64/divrem_1.asm | 306 + gmp4/mpn/x86_64/divrem_2.asm | 189 + gmp4/mpn/x86_64/dos64.m4 | 100 + gmp4/mpn/x86_64/fastavx/copyd.asm | 171 + gmp4/mpn/x86_64/fastavx/copyi.asm | 168 + gmp4/mpn/x86_64/fastsse/README | 21 + gmp4/mpn/x86_64/fastsse/com-palignr.asm | 302 + gmp4/mpn/x86_64/fastsse/com.asm | 161 + gmp4/mpn/x86_64/fastsse/copyd-palignr.asm | 251 + gmp4/mpn/x86_64/fastsse/copyd.asm | 145 + gmp4/mpn/x86_64/fastsse/copyi-palignr.asm | 295 + gmp4/mpn/x86_64/fastsse/copyi.asm | 166 + gmp4/mpn/x86_64/fastsse/lshift-movdqu2.asm | 182 + gmp4/mpn/x86_64/fastsse/lshift.asm | 169 + gmp4/mpn/x86_64/fastsse/lshiftc-movdqu2.asm | 193 + gmp4/mpn/x86_64/fastsse/lshiftc.asm | 179 + gmp4/mpn/x86_64/fastsse/rshift-movdqu2.asm | 201 + gmp4/mpn/x86_64/fastsse/sec_tabselect.asm | 192 + gmp4/mpn/x86_64/fat/fat.c | 368 + gmp4/mpn/x86_64/fat/fat_entry.asm | 204 + gmp4/mpn/x86_64/fat/gmp-mparam.h | 72 + gmp4/mpn/x86_64/fat/mod_1.c | 32 + gmp4/mpn/x86_64/fat/mul_basecase.c | 32 + gmp4/mpn/x86_64/fat/mullo_basecase.c | 32 + gmp4/mpn/x86_64/fat/redc_1.c | 32 + gmp4/mpn/x86_64/fat/redc_2.c | 32 + gmp4/mpn/x86_64/fat/sqr_basecase.c | 32 + gmp4/mpn/x86_64/gcd_1.asm | 163 + gmp4/mpn/x86_64/gmp-mparam.h | 218 + gmp4/mpn/x86_64/invert_limb.asm | 115 + gmp4/mpn/x86_64/invert_limb_table.asm | 50 + gmp4/mpn/x86_64/k10/gcd_1.asm | 37 + gmp4/mpn/x86_64/k10/gmp-mparam.h | 222 + gmp4/mpn/x86_64/k10/hamdist.asm | 103 + gmp4/mpn/x86_64/k10/lshift.asm | 37 + gmp4/mpn/x86_64/k10/lshiftc.asm | 37 + gmp4/mpn/x86_64/k10/popcount.asm | 138 + gmp4/mpn/x86_64/k10/rshift.asm | 37 + gmp4/mpn/x86_64/k10/sec_tabselect.asm | 37 + gmp4/mpn/x86_64/k8/aorrlsh_n.asm | 217 + gmp4/mpn/x86_64/k8/div_qr_1n_pi1.asm | 249 + gmp4/mpn/x86_64/k8/gmp-mparam.h | 236 + gmp4/mpn/x86_64/k8/mul_basecase.asm | 469 + gmp4/mpn/x86_64/k8/mullo_basecase.asm | 436 + gmp4/mpn/x86_64/k8/mulmid_basecase.asm | 559 + gmp4/mpn/x86_64/k8/redc_1.asm | 590 + gmp4/mpn/x86_64/k8/sqr_basecase.asm | 807 + gmp4/mpn/x86_64/logops_n.asm | 244 + gmp4/mpn/x86_64/lshift.asm | 247 + gmp4/mpn/x86_64/lshiftc.asm | 182 + gmp4/mpn/x86_64/lshsub_n.asm | 172 + gmp4/mpn/x86_64/missing-call.m4 | 53 + gmp4/mpn/x86_64/missing-inline.m4 | 100 + gmp4/mpn/x86_64/missing.asm | 130 + gmp4/mpn/x86_64/mod_1_1.asm | 235 + gmp4/mpn/x86_64/mod_1_2.asm | 238 + gmp4/mpn/x86_64/mod_1_4.asm | 269 + gmp4/mpn/x86_64/mod_34lsub1.asm | 205 + gmp4/mpn/x86_64/mode1o.asm | 171 + gmp4/mpn/x86_64/mul_1.asm | 183 + gmp4/mpn/x86_64/mul_2.asm | 192 + gmp4/mpn/x86_64/mulx/adx/addmul_1.asm | 149 + gmp4/mpn/x86_64/mulx/aorsmul_1.asm | 161 + gmp4/mpn/x86_64/mulx/mul_1.asm | 154 + gmp4/mpn/x86_64/nano/copyd.asm | 37 + gmp4/mpn/x86_64/nano/copyi.asm | 37 + gmp4/mpn/x86_64/nano/dive_1.asm | 166 + gmp4/mpn/x86_64/nano/gcd_1.asm | 37 + gmp4/mpn/x86_64/nano/gmp-mparam.h | 243 + gmp4/mpn/x86_64/nano/popcount.asm | 35 + gmp4/mpn/x86_64/pentium4/aors_n.asm | 196 + gmp4/mpn/x86_64/pentium4/aorslsh1_n.asm | 50 + gmp4/mpn/x86_64/pentium4/aorslsh2_n.asm | 50 + gmp4/mpn/x86_64/pentium4/aorslshC_n.asm | 203 + gmp4/mpn/x86_64/pentium4/gmp-mparam.h | 231 + gmp4/mpn/x86_64/pentium4/lshift.asm | 166 + gmp4/mpn/x86_64/pentium4/lshiftc.asm | 179 + gmp4/mpn/x86_64/pentium4/mod_34lsub1.asm | 167 + gmp4/mpn/x86_64/pentium4/popcount.asm | 35 + gmp4/mpn/x86_64/pentium4/rsh1aors_n.asm | 334 + gmp4/mpn/x86_64/pentium4/rshift.asm | 169 + gmp4/mpn/x86_64/pentium4/sec_tabselect.asm | 37 + gmp4/mpn/x86_64/popham.asm | 177 + gmp4/mpn/x86_64/rsh1aors_n.asm | 189 + gmp4/mpn/x86_64/rshift.asm | 176 + gmp4/mpn/x86_64/sec_tabselect.asm | 176 + gmp4/mpn/x86_64/sqr_diag_addlsh1.asm | 116 + gmp4/mpn/x86_64/sublsh1_n.asm | 160 + gmp4/mpn/x86_64/x86_64-defs.m4 | 354 + gmp4/mpq/Makefile.am | 41 + gmp4/mpq/Makefile.in | 637 + gmp4/mpq/abs.c | 56 + gmp4/mpq/aors.c | 113 + gmp4/mpq/canonicalize.c | 63 + gmp4/mpq/clear.c | 41 + gmp4/mpq/clears.c | 52 + gmp4/mpq/cmp.c | 126 + gmp4/mpq/cmp_si.c | 67 + gmp4/mpq/cmp_ui.c | 100 + gmp4/mpq/div.c | 115 + gmp4/mpq/equal.c | 69 + gmp4/mpq/get_d.c | 175 + gmp4/mpq/get_den.c | 43 + gmp4/mpq/get_num.c | 45 + gmp4/mpq/get_str.c | 76 + gmp4/mpq/init.c | 49 + gmp4/mpq/inits.c | 49 + gmp4/mpq/inp_str.c | 76 + gmp4/mpq/inv.c | 71 + gmp4/mpq/md_2exp.c | 111 + gmp4/mpq/mul.c | 103 + gmp4/mpq/neg.c | 58 + gmp4/mpq/out_str.c | 54 + gmp4/mpq/set.c | 51 + gmp4/mpq/set_d.c | 166 + gmp4/mpq/set_den.c | 45 + gmp4/mpq/set_f.c | 107 + gmp4/mpq/set_num.c | 45 + gmp4/mpq/set_si.c | 65 + gmp4/mpq/set_str.c | 69 + gmp4/mpq/set_ui.c | 61 + gmp4/mpq/set_z.c | 49 + gmp4/mpq/swap.c | 71 + gmp4/mpz/2fac_ui.c | 100 + gmp4/mpz/Makefile.am | 67 + gmp4/mpz/Makefile.in | 688 + gmp4/mpz/abs.c | 55 + gmp4/mpz/add.c | 33 + gmp4/mpz/add_ui.c | 33 + gmp4/mpz/and.c | 244 + gmp4/mpz/aors.h | 124 + gmp4/mpz/aors_ui.h | 121 + gmp4/mpz/aorsmul.c | 164 + gmp4/mpz/aorsmul_i.c | 255 + gmp4/mpz/array_init.c | 50 + gmp4/mpz/bin_ui.c | 143 + gmp4/mpz/bin_uiui.c | 696 + gmp4/mpz/cdiv_q.c | 53 + gmp4/mpz/cdiv_q_ui.c | 103 + gmp4/mpz/cdiv_qr.c | 65 + gmp4/mpz/cdiv_qr_ui.c | 119 + gmp4/mpz/cdiv_r.c | 61 + gmp4/mpz/cdiv_r_ui.c | 110 + gmp4/mpz/cdiv_ui.c | 103 + gmp4/mpz/cfdiv_q_2exp.c | 113 + gmp4/mpz/cfdiv_r_2exp.c | 164 + gmp4/mpz/clear.c | 40 + gmp4/mpz/clears.c | 49 + gmp4/mpz/clrbit.c | 116 + gmp4/mpz/cmp.c | 54 + gmp4/mpz/cmp_d.c | 145 + gmp4/mpz/cmp_si.c | 70 + gmp4/mpz/cmp_ui.c | 78 + gmp4/mpz/cmpabs.c | 54 + gmp4/mpz/cmpabs_d.c | 130 + gmp4/mpz/cmpabs_ui.c | 77 + gmp4/mpz/com.c | 88 + gmp4/mpz/combit.c | 103 + gmp4/mpz/cong.c | 183 + gmp4/mpz/cong_2exp.c | 150 + gmp4/mpz/cong_ui.c | 116 + gmp4/mpz/dive_ui.c | 69 + gmp4/mpz/divegcd.c | 157 + gmp4/mpz/divexact.c | 91 + gmp4/mpz/divis.c | 44 + gmp4/mpz/divis_2exp.c | 61 + gmp4/mpz/divis_ui.c | 81 + gmp4/mpz/dump.c | 49 + gmp4/mpz/export.c | 190 + gmp4/mpz/fac_ui.c | 108 + gmp4/mpz/fdiv_q.c | 53 + gmp4/mpz/fdiv_q_ui.c | 101 + gmp4/mpz/fdiv_qr.c | 65 + gmp4/mpz/fdiv_qr_ui.c | 118 + gmp4/mpz/fdiv_r.c | 60 + gmp4/mpz/fdiv_r_ui.c | 108 + gmp4/mpz/fdiv_ui.c | 101 + gmp4/mpz/fib2_ui.c | 50 + gmp4/mpz/fib_ui.c | 152 + gmp4/mpz/fits_s.h | 61 + gmp4/mpz/fits_sint.c | 36 + gmp4/mpz/fits_slong.c | 36 + gmp4/mpz/fits_sshort.c | 36 + gmp4/mpz/fits_uint.c | 34 + gmp4/mpz/fits_ulong.c | 34 + gmp4/mpz/fits_ushort.c | 34 + gmp4/mpz/gcd.c | 167 + gmp4/mpz/gcd_ui.c | 85 + gmp4/mpz/gcdext.c | 124 + gmp4/mpz/get_d.c | 44 + gmp4/mpz/get_d_2exp.c | 54 + gmp4/mpz/get_si.c | 53 + gmp4/mpz/get_str.c | 119 + gmp4/mpz/get_ui.c | 34 + gmp4/mpz/getlimbn.c | 34 + gmp4/mpz/hamdist.c | 175 + gmp4/mpz/import.c | 180 + gmp4/mpz/init.c | 45 + gmp4/mpz/init2.c | 61 + gmp4/mpz/inits.c | 49 + gmp4/mpz/inp_raw.c | 173 + gmp4/mpz/inp_str.c | 174 + gmp4/mpz/invert.c | 73 + gmp4/mpz/ior.c | 230 + gmp4/mpz/iset.c | 59 + gmp4/mpz/iset_d.c | 42 + gmp4/mpz/iset_si.c | 59 + gmp4/mpz/iset_str.c | 52 + gmp4/mpz/iset_ui.c | 59 + gmp4/mpz/jacobi.c | 211 + gmp4/mpz/kronsz.c | 138 + gmp4/mpz/kronuz.c | 130 + gmp4/mpz/kronzs.c | 93 + gmp4/mpz/kronzu.c | 89 + gmp4/mpz/lcm.c | 88 + gmp4/mpz/lcm_ui.c | 79 + gmp4/mpz/limbs_finish.c | 40 + gmp4/mpz/limbs_modify.c | 39 + gmp4/mpz/limbs_read.c | 38 + gmp4/mpz/limbs_write.c | 39 + gmp4/mpz/lucnum2_ui.c | 90 + gmp4/mpz/lucnum_ui.c | 209 + gmp4/mpz/mfac_uiui.c | 140 + gmp4/mpz/millerrabin.c | 124 + gmp4/mpz/mod.c | 68 + gmp4/mpz/mul.c | 157 + gmp4/mpz/mul_2exp.c | 73 + gmp4/mpz/mul_i.h | 107 + gmp4/mpz/mul_si.c | 34 + gmp4/mpz/mul_ui.c | 34 + gmp4/mpz/n_pow_ui.c | 533 + gmp4/mpz/neg.c | 57 + gmp4/mpz/nextprime.c | 129 + gmp4/mpz/oddfac_1.c | 427 + gmp4/mpz/out_raw.c | 173 + gmp4/mpz/out_str.c | 112 + gmp4/mpz/perfpow.c | 39 + gmp4/mpz/perfsqr.c | 35 + gmp4/mpz/popcount.c | 35 + gmp4/mpz/pow_ui.c | 53 + gmp4/mpz/powm.c | 283 + gmp4/mpz/powm_sec.c | 104 + gmp4/mpz/powm_ui.c | 292 + gmp4/mpz/pprime_p.c | 164 + gmp4/mpz/primorial_ui.c | 164 + gmp4/mpz/prodlimbs.c | 109 + gmp4/mpz/random.c | 40 + gmp4/mpz/random2.c | 51 + gmp4/mpz/realloc.c | 71 + gmp4/mpz/realloc2.c | 60 + gmp4/mpz/remove.c | 147 + gmp4/mpz/roinit_n.c | 44 + gmp4/mpz/root.c | 93 + gmp4/mpz/rootrem.c | 101 + gmp4/mpz/rrandomb.c | 103 + gmp4/mpz/scan0.c | 130 + gmp4/mpz/scan1.c | 124 + gmp4/mpz/set.c | 50 + gmp4/mpz/set_d.c | 117 + gmp4/mpz/set_f.c | 72 + gmp4/mpz/set_q.c | 35 + gmp4/mpz/set_si.c | 55 + gmp4/mpz/set_str.c | 145 + gmp4/mpz/set_ui.c | 53 + gmp4/mpz/setbit.c | 105 + gmp4/mpz/size.c | 35 + gmp4/mpz/sizeinbase.c | 43 + gmp4/mpz/sqrt.c | 77 + gmp4/mpz/sqrtrem.c | 85 + gmp4/mpz/sub.c | 33 + gmp4/mpz/sub_ui.c | 33 + gmp4/mpz/swap.c | 55 + gmp4/mpz/tdiv_q.c | 93 + gmp4/mpz/tdiv_q_2exp.c | 68 + gmp4/mpz/tdiv_q_ui.c | 84 + gmp4/mpz/tdiv_qr.c | 107 + gmp4/mpz/tdiv_qr_ui.c | 103 + gmp4/mpz/tdiv_r.c | 98 + gmp4/mpz/tdiv_r_2exp.c | 78 + gmp4/mpz/tdiv_r_ui.c | 99 + gmp4/mpz/tdiv_ui.c | 85 + gmp4/mpz/tstbit.c | 81 + gmp4/mpz/ui_pow_ui.c | 59 + gmp4/mpz/ui_sub.c | 96 + gmp4/mpz/urandomb.c | 48 + gmp4/mpz/urandomm.c | 105 + gmp4/mpz/xor.c | 194 + gmp4/nextprime.c | 167 + gmp4/primesieve.c | 295 + gmp4/printf/Makefile.am | 41 + gmp4/printf/Makefile.in | 636 + gmp4/printf/asprintf.c | 48 + gmp4/printf/asprntffuns.c | 72 + gmp4/printf/doprnt.c | 627 + gmp4/printf/doprntf.c | 390 + gmp4/printf/doprnti.c | 137 + gmp4/printf/fprintf.c | 49 + gmp4/printf/obprintf.c | 59 + gmp4/printf/obprntffuns.c | 72 + gmp4/printf/obvprintf.c | 52 + gmp4/printf/printf.c | 49 + gmp4/printf/printffuns.c | 80 + gmp4/printf/repl-vsnprintf.c | 396 + gmp4/printf/snprintf.c | 54 + gmp4/printf/snprntffuns.c | 160 + gmp4/printf/sprintf.c | 55 + gmp4/printf/sprintffuns.c | 95 + gmp4/printf/vasprintf.c | 117 + gmp4/printf/vfprintf.c | 42 + gmp4/printf/vprintf.c | 42 + gmp4/printf/vsnprintf.c | 48 + gmp4/printf/vsprintf.c | 51 + gmp4/rand/Makefile.am | 38 + gmp4/rand/Makefile.in | 630 + gmp4/rand/rand.c | 52 + gmp4/rand/randbui.c | 57 + gmp4/rand/randclr.c | 38 + gmp4/rand/randdef.c | 38 + gmp4/rand/randiset.c | 39 + gmp4/rand/randlc2s.c | 93 + gmp4/rand/randlc2x.c | 333 + gmp4/rand/randmt.c | 416 + gmp4/rand/randmt.h | 51 + gmp4/rand/randmts.c | 165 + gmp4/rand/randmui.c | 86 + gmp4/rand/rands.c | 42 + gmp4/rand/randsd.c | 39 + gmp4/rand/randsdui.c | 44 + gmp4/scanf/Makefile.am | 38 + gmp4/scanf/Makefile.in | 629 + gmp4/scanf/doscan.c | 768 + gmp4/scanf/fscanf.c | 48 + gmp4/scanf/fscanffuns.c | 62 + gmp4/scanf/scanf.c | 48 + gmp4/scanf/sscanf.c | 53 + gmp4/scanf/sscanffuns.c | 124 + gmp4/scanf/vfscanf.c | 42 + gmp4/scanf/vscanf.c | 43 + gmp4/scanf/vsscanf.c | 61 + gmp4/tal-debug.c | 151 + gmp4/tal-notreent.c | 130 + gmp4/tal-reent.c | 82 + gmp4/test-driver | 139 + gmp4/tests/Makefile.am | 39 + gmp4/tests/Makefile.in | 1370 + gmp4/tests/amd64call.asm | 167 + gmp4/tests/amd64check.c | 106 + gmp4/tests/arm32call.asm | 83 + gmp4/tests/arm32check.c | 96 + gmp4/tests/cxx/Makefile.am | 81 + gmp4/tests/cxx/Makefile.in | 1395 + gmp4/tests/cxx/clocale.c | 60 + gmp4/tests/cxx/t-assign.cc | 604 + gmp4/tests/cxx/t-binary.cc | 466 + gmp4/tests/cxx/t-cast.cc | 57 + gmp4/tests/cxx/t-constr.cc | 756 + gmp4/tests/cxx/t-cxx11.cc | 220 + ...ceptions-work-at-all-with-this-compiler.cc | 38 + gmp4/tests/cxx/t-headers.cc | 26 + gmp4/tests/cxx/t-iostream.cc | 107 + gmp4/tests/cxx/t-istream.cc | 599 + gmp4/tests/cxx/t-locale.cc | 195 + gmp4/tests/cxx/t-misc.cc | 398 + gmp4/tests/cxx/t-mix.cc | 83 + gmp4/tests/cxx/t-ops.cc | 723 + gmp4/tests/cxx/t-ops2.cc | 256 + gmp4/tests/cxx/t-ops3.cc | 133 + gmp4/tests/cxx/t-ostream.cc | 450 + gmp4/tests/cxx/t-prec.cc | 217 + gmp4/tests/cxx/t-rand.cc | 149 + gmp4/tests/cxx/t-ternary.cc | 735 + gmp4/tests/cxx/t-unary.cc | 133 + gmp4/tests/devel/Makefile.am | 34 + gmp4/tests/devel/Makefile.in | 685 + gmp4/tests/devel/README | 37 + gmp4/tests/devel/anymul_1.c | 256 + gmp4/tests/devel/aors_n.c | 263 + gmp4/tests/devel/copy.c | 226 + gmp4/tests/devel/divmod_1.c | 200 + gmp4/tests/devel/divrem.c | 119 + gmp4/tests/devel/logops_n.c | 230 + gmp4/tests/devel/shift.c | 245 + gmp4/tests/devel/try.c | 3608 ++ gmp4/tests/devel/tst-addsub.c | 98 + gmp4/tests/memory.c | 247 + gmp4/tests/misc.c | 565 + gmp4/tests/misc/Makefile.am | 33 + gmp4/tests/misc/Makefile.in | 1028 + gmp4/tests/misc/t-locale.c | 201 + gmp4/tests/misc/t-printf.c | 948 + gmp4/tests/misc/t-scanf.c | 1616 + gmp4/tests/mpf/Makefile.am | 31 + gmp4/tests/mpf/Makefile.in | 1422 + gmp4/tests/mpf/reuse.c | 219 + gmp4/tests/mpf/t-add.c | 108 + gmp4/tests/mpf/t-cmp_d.c | 104 + gmp4/tests/mpf/t-cmp_si.c | 107 + gmp4/tests/mpf/t-conv.c | 143 + gmp4/tests/mpf/t-div.c | 186 + gmp4/tests/mpf/t-dm2exp.c | 119 + gmp4/tests/mpf/t-eq.c | 218 + gmp4/tests/mpf/t-fits.c | 333 + gmp4/tests/mpf/t-get_d.c | 106 + gmp4/tests/mpf/t-get_d_2exp.c | 121 + gmp4/tests/mpf/t-get_si.c | 223 + gmp4/tests/mpf/t-get_ui.c | 128 + gmp4/tests/mpf/t-gsprec.c | 62 + gmp4/tests/mpf/t-inp_str.c | 192 + gmp4/tests/mpf/t-int_p.c | 84 + gmp4/tests/mpf/t-mul_ui.c | 165 + gmp4/tests/mpf/t-muldiv.c | 159 + gmp4/tests/mpf/t-set.c | 113 + gmp4/tests/mpf/t-set_q.c | 127 + gmp4/tests/mpf/t-set_si.c | 91 + gmp4/tests/mpf/t-set_ui.c | 90 + gmp4/tests/mpf/t-sqrt.c | 194 + gmp4/tests/mpf/t-sqrt_ui.c | 113 + gmp4/tests/mpf/t-sub.c | 206 + gmp4/tests/mpf/t-trunc.c | 271 + gmp4/tests/mpf/t-ui_div.c | 152 + gmp4/tests/mpn/Makefile.am | 38 + gmp4/tests/mpn/Makefile.in | 1728 + gmp4/tests/mpn/logic.c | 134 + gmp4/tests/mpn/t-aors_1.c | 311 + gmp4/tests/mpn/t-asmtype.c | 64 + gmp4/tests/mpn/t-bdiv.c | 368 + gmp4/tests/mpn/t-broot.c | 105 + gmp4/tests/mpn/t-brootinv.c | 106 + gmp4/tests/mpn/t-div.c | 505 + gmp4/tests/mpn/t-divrem_1.c | 124 + gmp4/tests/mpn/t-fat.c | 311 + gmp4/tests/mpn/t-get_d.c | 498 + gmp4/tests/mpn/t-hgcd.c | 407 + gmp4/tests/mpn/t-hgcd_appr.c | 564 + gmp4/tests/mpn/t-instrument.c | 416 + gmp4/tests/mpn/t-invert.c | 161 + gmp4/tests/mpn/t-iord_u.c | 221 + gmp4/tests/mpn/t-matrix22.c | 207 + gmp4/tests/mpn/t-minvert.c | 179 + gmp4/tests/mpn/t-mod_1.c | 129 + gmp4/tests/mpn/t-mp_bases.c | 105 + gmp4/tests/mpn/t-mul.c | 101 + gmp4/tests/mpn/t-mullo.c | 142 + gmp4/tests/mpn/t-mulmid.c | 93 + gmp4/tests/mpn/t-mulmod_bnm1.c | 218 + gmp4/tests/mpn/t-perfsqr.c | 117 + gmp4/tests/mpn/t-scan.c | 145 + gmp4/tests/mpn/t-sizeinbase.c | 108 + gmp4/tests/mpn/t-sqrmod_bnm1.c | 191 + gmp4/tests/mpn/t-toom2-sqr.c | 6 + gmp4/tests/mpn/t-toom22.c | 10 + gmp4/tests/mpn/t-toom3-sqr.c | 6 + gmp4/tests/mpn/t-toom32.c | 8 + gmp4/tests/mpn/t-toom33.c | 11 + gmp4/tests/mpn/t-toom4-sqr.c | 6 + gmp4/tests/mpn/t-toom42.c | 8 + gmp4/tests/mpn/t-toom43.c | 8 + gmp4/tests/mpn/t-toom44.c | 11 + gmp4/tests/mpn/t-toom52.c | 8 + gmp4/tests/mpn/t-toom53.c | 8 + gmp4/tests/mpn/t-toom54.c | 8 + gmp4/tests/mpn/t-toom6-sqr.c | 8 + gmp4/tests/mpn/t-toom62.c | 8 + gmp4/tests/mpn/t-toom63.c | 8 + gmp4/tests/mpn/t-toom6h.c | 13 + gmp4/tests/mpn/t-toom8-sqr.c | 8 + gmp4/tests/mpn/t-toom8h.c | 18 + gmp4/tests/mpn/toom-shared.h | 158 + gmp4/tests/mpn/toom-sqr-shared.h | 129 + gmp4/tests/mpq/Makefile.am | 34 + gmp4/tests/mpq/Makefile.in | 1212 + gmp4/tests/mpq/io.c | 137 + gmp4/tests/mpq/reuse.c | 230 + gmp4/tests/mpq/t-aors.c | 183 + gmp4/tests/mpq/t-cmp.c | 102 + gmp4/tests/mpq/t-cmp_si.c | 118 + gmp4/tests/mpq/t-cmp_ui.c | 117 + gmp4/tests/mpq/t-equal.c | 147 + gmp4/tests/mpq/t-get_d.c | 295 + gmp4/tests/mpq/t-get_str.c | 143 + gmp4/tests/mpq/t-inp_str.c | 172 + gmp4/tests/mpq/t-inv.c | 61 + gmp4/tests/mpq/t-md_2exp.c | 245 + gmp4/tests/mpq/t-set_f.c | 170 + gmp4/tests/mpq/t-set_str.c | 103 + gmp4/tests/mpz/Makefile.am | 42 + gmp4/tests/mpz/Makefile.in | 2030 + gmp4/tests/mpz/bit.c | 406 + gmp4/tests/mpz/convert.c | 170 + gmp4/tests/mpz/dive.c | 101 + gmp4/tests/mpz/dive_ui.c | 87 + gmp4/tests/mpz/io.c | 139 + gmp4/tests/mpz/logic.c | 195 + gmp4/tests/mpz/reuse.c | 722 + gmp4/tests/mpz/t-addsub.c | 122 + gmp4/tests/mpz/t-aorsmul.c | 422 + gmp4/tests/mpz/t-bin.c | 266 + gmp4/tests/mpz/t-cdiv_ui.c | 159 + gmp4/tests/mpz/t-cmp.c | 182 + gmp4/tests/mpz/t-cmp_d.c | 293 + gmp4/tests/mpz/t-cmp_si.c | 102 + gmp4/tests/mpz/t-cong.c | 227 + gmp4/tests/mpz/t-cong_2exp.c | 209 + gmp4/tests/mpz/t-div_2exp.c | 224 + gmp4/tests/mpz/t-divis.c | 168 + gmp4/tests/mpz/t-divis_2exp.c | 133 + gmp4/tests/mpz/t-export.c | 206 + gmp4/tests/mpz/t-fac_ui.c | 106 + gmp4/tests/mpz/t-fdiv.c | 147 + gmp4/tests/mpz/t-fdiv_ui.c | 159 + gmp4/tests/mpz/t-fib_ui.c | 156 + gmp4/tests/mpz/t-fits.c | 202 + gmp4/tests/mpz/t-gcd.c | 454 + gmp4/tests/mpz/t-gcd_ui.c | 63 + gmp4/tests/mpz/t-get_d.c | 74 + gmp4/tests/mpz/t-get_d_2exp.c | 223 + gmp4/tests/mpz/t-get_si.c | 122 + gmp4/tests/mpz/t-hamdist.c | 124 + gmp4/tests/mpz/t-import.c | 176 + gmp4/tests/mpz/t-inp_str.c | 199 + gmp4/tests/mpz/t-invert.c | 121 + gmp4/tests/mpz/t-io_raw.c | 287 + gmp4/tests/mpz/t-jac.c | 1012 + gmp4/tests/mpz/t-lcm.c | 185 + gmp4/tests/mpz/t-limbs.c | 233 + gmp4/tests/mpz/t-lucnum_ui.c | 97 + gmp4/tests/mpz/t-mfac_uiui.c | 136 + gmp4/tests/mpz/t-mul.c | 219 + gmp4/tests/mpz/t-mul_i.c | 135 + gmp4/tests/mpz/t-nextprime.c | 222 + gmp4/tests/mpz/t-oddeven.c | 88 + gmp4/tests/mpz/t-perfpow.c | 243 + gmp4/tests/mpz/t-perfsqr.c | 155 + gmp4/tests/mpz/t-popcount.c | 168 + gmp4/tests/mpz/t-pow.c | 218 + gmp4/tests/mpz/t-powm.c | 184 + gmp4/tests/mpz/t-powm_ui.c | 128 + gmp4/tests/mpz/t-pprime_p.c | 190 + gmp4/tests/mpz/t-primorial_ui.c | 97 + gmp4/tests/mpz/t-remove.c | 147 + gmp4/tests/mpz/t-root.c | 174 + gmp4/tests/mpz/t-scan.c | 132 + gmp4/tests/mpz/t-set_d.c | 140 + gmp4/tests/mpz/t-set_f.c | 126 + gmp4/tests/mpz/t-set_si.c | 97 + gmp4/tests/mpz/t-set_str.c | 109 + gmp4/tests/mpz/t-sizeinbase.c | 90 + gmp4/tests/mpz/t-sqrtrem.c | 116 + gmp4/tests/mpz/t-tdiv.c | 146 + gmp4/tests/mpz/t-tdiv_ui.c | 159 + gmp4/tests/rand/Makefile.am | 89 + gmp4/tests/rand/Makefile.in | 1202 + gmp4/tests/rand/findlc.c | 252 + gmp4/tests/rand/gen.c | 481 + gmp4/tests/rand/gmpstat.h | 75 + gmp4/tests/rand/spect.c | 137 + gmp4/tests/rand/stat.c | 407 + gmp4/tests/rand/statlib.c | 837 + gmp4/tests/rand/t-iset.c | 68 + gmp4/tests/rand/t-lc2exp.c | 217 + gmp4/tests/rand/t-mt.c | 83 + gmp4/tests/rand/t-rand.c | 290 + gmp4/tests/rand/t-urbui.c | 65 + gmp4/tests/rand/t-urmui.c | 75 + gmp4/tests/rand/t-urndmm.c | 159 + gmp4/tests/rand/zdiv_round.c | 44 + gmp4/tests/refmpf.c | 428 + gmp4/tests/refmpn.c | 2578 ++ gmp4/tests/refmpq.c | 41 + gmp4/tests/refmpz.c | 298 + gmp4/tests/spinner.c | 129 + gmp4/tests/t-bswap.c | 71 + gmp4/tests/t-constants.c | 352 + gmp4/tests/t-count_zeros.c | 87 + gmp4/tests/t-gmpmax.c | 69 + gmp4/tests/t-hightomask.c | 43 + gmp4/tests/t-modlinv.c | 84 + gmp4/tests/t-parity.c | 67 + gmp4/tests/t-popc.c | 80 + gmp4/tests/t-sub.c | 115 + gmp4/tests/tests.h | 442 + gmp4/tests/trace.c | 318 + gmp4/tests/x86call.asm | 153 + gmp4/tests/x86check.c | 112 + gmp4/tune/Makefile.am | 181 + gmp4/tune/Makefile.in | 936 + gmp4/tune/README | 501 + gmp4/tune/alpha.asm | 59 + gmp4/tune/common.c | 2659 ++ gmp4/tune/div_qr_1_tune.c | 47 + gmp4/tune/div_qr_1n_pi1_1.c | 39 + gmp4/tune/div_qr_1n_pi1_2.c | 39 + gmp4/tune/divrem1div.c | 42 + gmp4/tune/divrem1inv.c | 42 + gmp4/tune/divrem2div.c | 41 + gmp4/tune/divrem2inv.c | 41 + gmp4/tune/freq.c | 894 + gmp4/tune/gcdext_double.c | 39 + gmp4/tune/gcdext_single.c | 39 + gmp4/tune/gcdextod.c | 40 + gmp4/tune/gcdextos.c | 40 + gmp4/tune/hgcd_appr_lehmer.c | 40 + gmp4/tune/hgcd_lehmer.c | 40 + gmp4/tune/hgcd_reduce_1.c | 41 + gmp4/tune/hgcd_reduce_2.c | 40 + gmp4/tune/hppa.asm | 42 + gmp4/tune/hppa2.asm | 44 + gmp4/tune/hppa2w.asm | 44 + gmp4/tune/ia64.asm | 47 + gmp4/tune/jacbase1.c | 38 + gmp4/tune/jacbase2.c | 38 + gmp4/tune/jacbase3.c | 38 + gmp4/tune/jacbase4.c | 38 + gmp4/tune/many.pl | 1334 + gmp4/tune/mod_1_1-1.c | 41 + gmp4/tune/mod_1_1-2.c | 41 + gmp4/tune/mod_1_div.c | 46 + gmp4/tune/mod_1_inv.c | 46 + gmp4/tune/modlinv.c | 178 + gmp4/tune/noop.c | 68 + gmp4/tune/pentium.asm | 60 + gmp4/tune/powerpc.asm | 53 + gmp4/tune/powerpc64.asm | 49 + gmp4/tune/powm_mod.c | 39 + gmp4/tune/powm_redc.c | 41 + gmp4/tune/pre_divrem_1.c | 41 + gmp4/tune/set_strb.c | 48 + gmp4/tune/set_strp.c | 43 + gmp4/tune/set_strs.c | 44 + gmp4/tune/sparcv9.asm | 45 + gmp4/tune/speed-ext.c | 233 + gmp4/tune/speed.c | 1384 + gmp4/tune/speed.h | 3646 ++ gmp4/tune/time.c | 1597 + gmp4/tune/tune-gcd-p.c | 225 + gmp4/tune/tuneup.c | 2912 ++ gmp4/tune/x86_64.asm | 55 + gmp4/version.c | 34 + gmp4/ylwrap | 247 + go/makefile | 183 + h/386-bsd.defs | 37 + h/386-bsd.h | 112 + h/386-gnu.h | 61 + h/386-kfreebsd.defs | 63 + h/386-kfreebsd.h | 48 + h/386-linux.h | 47 + h/386-macosx.defs | 35 + h/386-macosx.h | 199 + h/386.h | 89 + h/FreeBSD.defs | 45 + h/FreeBSD.h | 99 + h/NeXT.defs | 0 h/NeXT.h | 0 h/NeXT30-m68k.defs | 32 + h/NeXT30-m68k.h | 58 + h/NeXT32-i386.defs | 34 + h/NeXT32-i386.h | 59 + h/NeXT32-m68k.defs | 34 + h/NeXT32-m68k.h | 58 + h/NetBSD.defs | 49 + h/NetBSD.h | 104 + h/OpenBSD.defs | 36 + h/OpenBSD.h | 72 + h/aarch64-linux.h | 16 + h/alpha-linux.h | 20 + h/alpha-osf1.defs | 49 + h/alpha-osf1.h | 141 + h/amd64-kfreebsd.h | 25 + h/amd64-linux.h | 23 + h/apply_n.h | 101 + h/arith.h | 266 + h/arm-linux.h | 16 + h/arth.h | 8265 ++++ h/att.h | 95 + h/att3b2.h | 25 + h/att_ext.h | 650 + h/bds.h | 63 + h/bits.h | 43 + h/bsd.h | 103 + h/cmpincl1.h | 2 + h/cmplrs/stsupport.h | 164 + h/cmponly.h | 52 + h/coff/i386.h | 232 + h/coff_encap.h | 40 + h/compat.h | 17 + h/compbas.h | 2 + h/compbas2.h | 0 h/compdefs.h | 116 + h/compprotos.h | 182 + h/convex.h | 25 + h/cyglacks.h | 82 + h/dec3100.defs | 56 + h/dec3100.h | 77 + h/defun.h | 35 + h/dos-go32.defs | 68 + h/dos-go32.h | 100 + h/e15.h | 77 + h/elf32_arm_reloc.h | 63 + h/elf32_hppa_reloc.h | 35 + h/elf32_hppa_reloc_special.h | 41 + h/elf32_i386_reloc.h | 8 + h/elf32_m68k_reloc.h | 6 + h/elf32_mips_reloc.h | 43 + h/elf32_mips_reloc_special.h | 115 + h/elf32_ppc_reloc.h | 22 + h/elf32_s390_reloc.h | 11 + h/elf32_sh4_reloc.h | 3 + h/elf32_sparc_reloc.h | 19 + h/elf64_aarch64_reloc.h | 57 + h/elf64_aarch64_reloc_special.h | 53 + h/elf64_alpha_reloc.h | 47 + h/elf64_alpha_reloc_special.h | 92 + h/elf64_i386_reloc.h | 12 + h/elf64_mips_reloc.h | 47 + h/elf64_mips_reloc_special.h | 120 + h/elf64_ppc_reloc.h | 22 + h/elf64_ppc_reloc_special.h | 88 + h/elf64_ppcle_reloc.h | 27 + h/elf64_ppcle_reloc_special.h | 77 + h/elf64_s390_reloc.h | 12 + h/elf64_sparc_reloc.h | 30 + h/elf64_sparc_reloc_special.h | 85 + h/enum.h | 15 + h/erreurs.h | 164 + h/error.h | 203 + h/eval.h | 124 + h/ext_sym.h | 143 + h/fixnum.h | 43 + h/frame.h | 135 + h/funlink.h | 120 + h/gclincl.h.in | 402 + h/gencom.h | 523 + h/genpari.h | 54 + h/genport.h | 118 + h/getpagesize.h | 6 + h/globals.h | 35 + h/gmp_wrappers.h | 197 + h/gnuwin95.defs | 61 + h/gnuwin95.h | 157 + h/hp300-bsd.defs | 36 + h/hp300-bsd.h | 70 + h/hp300.defs | 59 + h/hp300.h | 148 + h/hp800.defs | 88 + h/hp800.h | 172 + h/hppa-linux.h | 25 + h/ia64-linux.h | 14 + h/immnum.h | 359 + h/include.h | 141 + h/irix5.defs | 62 + h/irix5.h | 120 + h/irix6.defs | 0 h/irix6.h | 11 + h/ld_bind_now.h | 27 + h/lex.h | 64 + h/linux.defs | 63 + h/linux.h | 195 + h/lu.h | 430 + h/m68k-linux.h | 80 + h/mac2.defs | 39 + h/mac2.h | 187 + h/mach32_i386_reloc.h | 15 + h/mach32_ppc_reloc.h | 29 + h/mach64_i386_reloc.h | 26 + h/make-decl.h | 3 + h/make-init.h | 82 + h/mc68k.h | 91 + h/mdefs.h | 55 + h/mgmp.h | 54 + h/minglacks.h | 82 + h/mingw.defs | 61 + h/mingw.h | 245 + h/mips-linux.h | 25 + h/mips.h | 37 + h/mipsel-linux.h | 9 + h/mp.h | 181 + h/mp386.defs | 30 + h/mp386.h | 30 + h/ncr.defs | 33 + h/ncr.h | 54 + h/news.h | 22 + h/notcomp.h | 370 + h/num_include.h | 42 + h/object.h | 521 + h/options.h | 22 + h/page.h | 137 + h/pageinfo.h | 10 + h/pbits.h | 13 + h/powerpc-linux.h | 31 + h/powerpc-macosx.defs | 35 + h/powerpc-macosx.h | 176 + h/prelink.h | 33 + h/protoize.h | 1925 + h/ptable.h | 56 + h/rgbc.h | 9 + h/rios-aix3.defs | 50 + h/rios-aix3.h | 238 + h/rios.defs | 50 + h/rios.h | 248 + h/rt_aix.defs | 43 + h/rt_aix.h | 150 + h/s3000.h | 56 + h/s390-linux.h | 20 + h/secondary_sun_magic | Bin 0 -> 8 bytes h/sfun_argd.h | 27 + h/sgi.defs | 28 + h/sgi.h | 33 + h/sgi4d.defs | 57 + h/sgi4d.h | 59 + h/sh4-linux.h | 58 + h/solaris-i386.defs | 65 + h/solaris-i386.h | 37 + h/solaris.defs | 65 + h/solaris.h | 44 + h/sparc-linux.h | 31 + h/sparc.h | 124 + h/stacks.h | 27 + h/sun.h | 30 + h/sun2r3.defs | 25 + h/sun2r3.h | 16 + h/sun3-os4.defs | 61 + h/sun3-os4.h | 38 + h/sun3.defs | 36 + h/sun3.h | 24 + h/sun386i.defs | 42 + h/sun386i.h | 133 + h/sun4.defs | 46 + h/sun4.h | 120 + h/symbol.h | 28 + h/symmetry.defs | 38 + h/symmetry.h | 55 + h/tsgc.h | 6 + h/twelve_null | Bin 0 -> 12 bytes h/type.h | 135 + h/u370_aix.defs | 63 + h/u370_aix.h | 188 + h/unrandomize.h | 65 + h/usig.h | 17 + h/vax.defs | 37 + h/vax.h | 29 + h/vs.h | 63 + h/wincoff.h | 24 + h/writable.h | 47 + info/bind.texi | 393 + info/c-interface.texi | 27 + info/character.texi | 377 + info/compile.texi | 313 + info/compiler-defs.texi | 158 + info/control.texi | 3424 ++ info/debug.texi | 149 + info/doc.texi | 100 + info/form.texi | 1140 + info/gcl-si-index.texi | 5 + info/gcl-si.info | 8231 ++++ info/gcl-si.pdf | Bin 0 -> 257802 bytes info/gcl-si.texi | 142 + info/gcl-si/Available-Symbols.html | 82 + info/gcl-si/Bignums.html | 131 + info/gcl-si/C-Interface.html | 70 + info/gcl-si/Characters.html | 488 + info/gcl-si/Command-Line.html | 212 + info/gcl-si/Compilation.html | 400 + info/gcl-si/Compiler-Definitions.html | 236 + info/gcl-si/Debugging.html | 74 + info/gcl-si/Doc.html | 170 + info/gcl-si/Environment.html | 74 + info/gcl-si/Function-and-Variable-Index.html | 1240 + info/gcl-si/GCL-Specific.html | 385 + info/gcl-si/Inititialization.html | 72 + info/gcl-si/Iteration-and-Tests.html | 229 + info/gcl-si/Lists.html | 1075 + info/gcl-si/Low-Level-Debug-Functions.html | 84 + info/gcl-si/Low-Level-X-Interface.html | 79 + info/gcl-si/Miscellaneous.html | 74 + info/gcl-si/Numbers.html | 1560 + info/gcl-si/Operating-System-Definitions.html | 419 + info/gcl-si/Operating-System.html | 72 + info/gcl-si/Regular-Expressions.html | 211 + .../Sequences-and-Arrays-and-Hash-Tables.html | 1162 + .../Source-Level-Debugging-in-Emacs.html | 170 + info/gcl-si/Special-Forms-and-Functions.html | 1279 + info/gcl-si/Streams-and-Reading.html | 1174 + info/gcl-si/Structures.html | 108 + info/gcl-si/Symbols.html | 580 + info/gcl-si/System-Definitions.html | 1159 + info/gcl-si/Type.html | 197 + info/gcl-si/User-Interface.html | 485 + info/gcl-si/index.html | 160 + info/gcl-tk.info | 72 + info/gcl-tk.info-1 | 6649 ++++ info/gcl-tk.info-2 | 1234 + info/gcl-tk.pdf | Bin 0 -> 387116 bytes info/gcl-tk.texi | 116 + info/gcl-tk/Argument-Lists.html | 160 + info/gcl-tk/Common-Features-of-Widgets.html | 163 + info/gcl-tk/Control.html | 117 + info/gcl-tk/General.html | 83 + info/gcl-tk/Getting-Started.html | 96 + info/gcl-tk/Introduction.html | 91 + info/gcl-tk/Linked-Variables.html | 161 + .../Lisp-Functions-Invoked-from-Graphics.html | 212 + info/gcl-tk/Return-Values.html | 181 + info/gcl-tk/Widgets.html | 97 + info/gcl-tk/after.html | 97 + info/gcl-tk/bind.html | 490 + info/gcl-tk/button.html | 263 + info/gcl-tk/canvas.html | 1570 + info/gcl-tk/checkbutton.html | 347 + info/gcl-tk/destroy.html | 83 + info/gcl-tk/entry.html | 351 + info/gcl-tk/exit.html | 86 + info/gcl-tk/focus.html | 182 + info/gcl-tk/frame.html | 192 + info/gcl-tk/grab.html | 182 + info/gcl-tk/index.html | 191 + info/gcl-tk/label.html | 179 + info/gcl-tk/listbox.html | 289 + info/gcl-tk/lower.html | 87 + info/gcl-tk/menu.html | 554 + info/gcl-tk/menubutton.html | 281 + info/gcl-tk/message.html | 237 + info/gcl-tk/option.html | 152 + info/gcl-tk/options.html | 666 + info/gcl-tk/pack.html | 338 + info/gcl-tk/pack_002dold.html | 279 + info/gcl-tk/place.html | 286 + info/gcl-tk/radiobutton.html | 333 + info/gcl-tk/raise.html | 87 + info/gcl-tk/scale.html | 328 + info/gcl-tk/scrollbar.html | 258 + info/gcl-tk/selection.html | 177 + info/gcl-tk/send.html | 112 + info/gcl-tk/text.html | 910 + info/gcl-tk/tk.html | 117 + info/gcl-tk/tk_002ddialog.html | 123 + .../tk_002dlistbox_002dsingle_002dselect.html | 86 + info/gcl-tk/tk_002dmenu_002dbar.html | 200 + info/gcl-tk/tkconnect.html | 121 + info/gcl-tk/tkerror.html | 112 + info/gcl-tk/tkvars.html | 126 + info/gcl-tk/tkwait.html | 99 + info/gcl-tk/toplevel.html | 175 + info/gcl-tk/update.html | 100 + info/gcl-tk/winfo.html | 302 + info/gcl-tk/wm.html | 964 + info/gcl.texi.diff | 11612 ++++++ info/general.texi | 687 + info/internal.texi | 361 + info/io.texi | 1008 + info/iteration.texi | 149 + info/list.texi | 899 + info/makefile | 123 + info/misc.texi | 47 + info/number.texi | 1332 + info/sequence.texi | 985 + info/si-defs.texi | 1157 + info/structure.texi | 43 + info/symbol.texi | 461 + info/system.texi | 458 + info/type.texi | 119 + info/user-interface.texi | 383 + info/widgets.texi | 5033 +++ install.sh | 250 + japitest.lsp | 369 + lsp/dbind.lisp | 15 + lsp/dummy.lisp | 1 + lsp/fasd.lisp | 151 + lsp/fast-mv.lisp | 41 + lsp/gcl_arraylib.lsp | 320 + lsp/gcl_assert.lsp | 81 + lsp/gcl_auto.lsp | 217 + lsp/gcl_auto_new.lsp | 220 + lsp/gcl_autocmp.lsp | 51 + lsp/gcl_autoload.lsp | 418 + lsp/gcl_cmpinit.lsp | 11 + lsp/gcl_debug.lsp | 823 + lsp/gcl_defmacro.lsp | 271 + lsp/gcl_defpackage.lsp | 339 + lsp/gcl_defstruct.lsp | 888 + lsp/gcl_describe.lsp | 454 + lsp/gcl_desetq.lsp | 25 + lsp/gcl_destructuring_bind.lsp | 405 + lsp/gcl_doc-file.lsp | 24 + lsp/gcl_evalmacros.lsp | 389 + lsp/gcl_export.lsp | 333 + lsp/gcl_fdecl.lsp | 93 + lsp/gcl_fpe.lsp | 147 + lsp/gcl_fpe_test.lsp | 212 + lsp/gcl_gprof.lsp | 133 + lsp/gcl_info.lsp | 548 + lsp/gcl_iolib.lsp | 325 + lsp/gcl_japi.lsp | 308 + lsp/gcl_listlib.lsp | 188 + lsp/gcl_littleXlsp.lsp | Bin 0 -> 6572 bytes lsp/gcl_loadcmp.lsp | 47 + lsp/gcl_loop.lsp | 2182 + lsp/gcl_make-declare.lsp | 80 + lsp/gcl_make_defpackage.lsp | 52 + lsp/gcl_mislib.lsp | 173 + lsp/gcl_module.lsp | 123 + lsp/gcl_numlib.lsp | 290 + lsp/gcl_packages.lsp | 1 + lsp/gcl_packlib.lsp | 225 + lsp/gcl_predlib.lsp | 792 + lsp/gcl_profile.lsp | 110 + lsp/gcl_readline.lsp | 12 + lsp/gcl_restart.lsp | 196 + lsp/gcl_seq.lsp | 138 + lsp/gcl_seqlib.lsp | 778 + lsp/gcl_serror.lsp | 281 + lsp/gcl_setf.lsp | 543 + lsp/gcl_sharp.lsp | 64 + lsp/gcl_sloop.lsp | 1230 + lsp/gcl_stack-problem.lsp | 29 + lsp/gcl_stdlisp.lsp | 61 + lsp/gcl_top.lsp | 653 + lsp/gcl_trace.lsp | 453 + lsp/gprof.hc | 122 + lsp/gprof1.lisp | 53 + lsp/gprof_aix.hc | 255 + lsp/make.lisp | 409 + lsp/makefile | 59 + lsp/sys-proclaim.lisp | 294 + lsp/ucall.lisp | 143 + lsp/ustreams.lisp | 81 + ltmain.sh | 5476 +++ machines | 36 + majvers | 1 + makdefs | 42 + makedefc.in | 75 + makefile | 294 + man/man1/gcl.1 | 248 + merge.c | 450 + minvers | 1 + misc/check.c | 45 + misc/check_obj.c | 14 + misc/cstruct.lsp | 157 + misc/foreign.lsp | 121 + misc/mprotect.ch | 197 + misc/rusage.lsp | 44 + misc/test-seek.c | 37 + misc/test-sgc.lsp | 58 + misc/warn-slow.lsp | 50 + mp/fplus.c | 104 + mp/gcclab | 29 + mp/gcclab.awk | 13 + mp/gnulib1.c | 51 + mp/lo-ibmrt.s | 67 + mp/lo-rios.s | 106 + mp/lo-rios1.s | 26 + mp/lo-sgi4d.s | 58 + mp/lo-u370_aix.s | 77 + mp/make.defs | 37 + mp/makefile | 76 + mp/mp2.c | 619 + mp/mp_addmul.c | 40 + mp/mp_bfffo.c | 64 + mp/mp_dblrsl3.c | 45 + mp/mp_dblrul3.c | 39 + mp/mp_divul3.c | 65 + mp/mp_divul3_word.c | 80 + mp/mp_mulul3.c | 69 + mp/mp_shiftl.c | 34 + mp/mp_sl3todivul3.c | 110 + mp/mpi-386_no_under.s | 2337 ++ mp/mpi-386d.S | 2323 ++ mp/mpi-bsd68k.s | 2164 + mp/mpi-sol-sparc.s | 2848 ++ mp/mpi-sparc.s | 2808 ++ mp/mpi.c | 649 + mp/readme | 85 + mp/sparcdivul3.s | 283 + o/ChangeLog | 1385 + o/NeXTunixfasl.c | 469 + o/NeXTunixsave.c | 499 + o/Vmalloc.c | 101 + o/alloc.c | 1762 + o/array.c | 1520 + o/array.c.prev | 1064 + o/array.c1 | 1085 + o/assignment.c | 604 + o/backq.c | 383 + o/bcmp.c | 11 + o/bcopy.c | 10 + o/bds.c | 37 + o/before_init.c | 53 + o/big.c | 163 + o/bind.c | 1127 + o/bind.texi | 1 + o/bitop.c | 47 + o/block.c | 123 + o/bsearch.c | 30 + o/bzero.c | 7 + o/catch.c | 165 + o/cfun.c | 365 + o/character.d | 668 + o/clxsocket.c | 166 + o/cmac.c | 241 + o/cmpaux.c | 578 + o/conditional.c | 205 + o/earith.c | 6 + o/egrep-def | 5 + o/error.c | 537 + o/eval.c | 1406 + o/external_funs.h | 423 + o/fasdump.c | 1598 + o/fasldlsym.c | 121 + o/fasldlsym.c.link | 73 + o/faslhp800.c | 163 + o/faslnt.c | 6 + o/faslsgi4.c | 463 + o/fat_string.c | 392 + o/file.d | 2743 ++ o/firstfile.c | 34 + o/fix-structref.el | 17 + o/format.c | 2298 ++ o/frame.c | 84 + o/funlink.c | 621 + o/funs | 24 + o/gbc.c | 1654 + o/gcl_readline.d | 392 + o/gdb_commands | 45 + o/gmp.c | 34 + o/gmp_big.c | 587 + o/gmp_num_log.c | 117 + o/gmp_wrappers.c | 4 + o/gnumalloc.c | 815 + o/grab_defs.c | 98 + o/grab_defs.u | 1 + o/hash.d | 574 + o/help.el | 425 + o/init_pari.c | 96 + o/internal-calls.lisp | 3227 ++ o/iteration.c | 458 + o/lastfile.c | 50 + o/let.c | 322 + o/lex.c | 129 + o/list.d | 1535 + o/littleXwin.c | 239 + o/macros.c | 348 + o/main.c | 1208 + o/makefile | 103 + o/makefun.c | 231 + o/malloc.c | 788 + o/mapfun.c | 326 + o/mingfile.c | 64 + o/mingwin.c | 957 + o/multival.c | 139 + o/mych | 60 + o/ndiv.c | 118 + o/nfunlink.c | 334 + o/nmul.c | 37 + o/nsocket.c | 699 + o/ntheap.h | 117 + o/num_arith.c | 1040 + o/num_co.c | 1115 + o/num_comp.c | 322 + o/num_log.c | 529 + o/num_pred.c | 253 + o/num_rand.c | 250 + o/num_sfun.c | 765 + o/number.c | 321 + o/package.d | 1217 + o/pari_big.c | 565 + o/pari_num_log.c | 245 + o/pathname.d | 771 + o/peculiar.c | 37 + o/plt.c | 202 + o/plttest.c | 86 + o/pre_init.c | 61 + o/predicate.c | 837 + o/prelink.c | 17 + o/print.d | 2203 ++ o/prog.c | 304 + o/read.d | 2550 ++ o/readme | 16 + o/reference.c | 200 + o/regexp.c | 1581 + o/regexp.h | 29 + o/regexpr.c | 191 + o/rel_aix.c | 110 + o/rel_coff.c | 86 + o/rel_hp300.c | 218 + o/rel_mac2.c | 84 + o/rel_ps2aix.c | 91 + o/rel_rios.c | 284 + o/rel_stand.c | 88 + o/rel_sun3.c | 44 + o/rel_sun4.c | 166 + o/rel_u370aix.c | 94 + o/run_process.c | 630 + o/save.c | 46 + o/save_sgi4.c | 472 + o/saveaix3.c | 283 + o/savedec31.c | 249 + o/saveu370.c | 188 + o/sbrk.c | 28 + o/sequence.d | 557 + o/sfasl.c | 700 + o/sfaslbfd.c | 395 + o/sfaslcoff.c | 447 + o/sfaslelf.c | 598 + o/sfasli.c | 158 + o/sfaslmacho.c | 580 + o/sfaslmacosx.c | 264 + o/sgbc.c | 1596 + o/sgi4d_emul.s | 68 + o/sockets.c | 571 + o/strcspn.c | 16 + o/string.d | 633 + o/structure.c | 468 + o/symbol.d | 711 + o/test_memprotect.c | 71 + o/toplevel.c | 241 + o/try.c | 496 + o/typespec.c | 350 + o/u370_emul.s | 82 + o/unexaix.c | 936 + o/unexec-19.29.c | 1197 + o/unexec.c | 1198 + o/unexelf.c | 1253 + o/unexelfsgi.c | 861 + o/unexhp9k800.c | 310 + o/unexlin.c | 969 + o/unexmacosx.c | 1203 + o/unexmips.c | 342 + o/unexnt.c | 1153 + o/unexsgi.c | 896 + o/unixfasl.c | 416 + o/unixfsys.c | 915 + o/unixsave.c | 164 + o/unixsys.c | 289 + o/unixtime.c | 302 + o/user_init.c | 3 + o/user_match.c | 3 + o/usig.c | 315 + o/usig2.c | 427 + o/usig2_aux.c | 81 + o/utils.c | 229 + o/xdrfuns.c | 186 + pcl/README | 11 + pcl/defsys.lisp | 959 + pcl/extensions/extensions.lisp | 496 + pcl/extensions/inline.lisp | 263 + pcl/extensions/user-instances.lisp | 684 + pcl/gcl_pcl_boot.lisp | 2195 + pcl/gcl_pcl_braid.lisp | 760 + pcl/gcl_pcl_cache.lisp | 1689 + pcl/gcl_pcl_combin.lisp | 407 + pcl/gcl_pcl_compat.lisp | 31 + pcl/gcl_pcl_cpl.lisp | 314 + pcl/gcl_pcl_ctypes.lisp | 45 + pcl/gcl_pcl_defclass.lisp | 467 + pcl/gcl_pcl_defcombin.lisp | 430 + pcl/gcl_pcl_defs.lisp | 973 + pcl/gcl_pcl_dfun.lisp | 1617 + pcl/gcl_pcl_dlisp.lisp | 425 + pcl/gcl_pcl_dlisp2.lisp | 178 + pcl/gcl_pcl_env.lisp | 406 + pcl/gcl_pcl_fast_init.lisp | 1048 + pcl/gcl_pcl_fin.lisp | 1868 + pcl/gcl_pcl_fixup.lisp | 40 + pcl/gcl_pcl_fngen.lisp | 214 + pcl/gcl_pcl_fsc.lisp | 100 + pcl/gcl_pcl_generic_functions.lisp | 779 + pcl/gcl_pcl_init.lisp | 261 + pcl/gcl_pcl_iterate.lisp | 1267 + pcl/gcl_pcl_low.lisp | 459 + pcl/gcl_pcl_macros.lisp | 789 + pcl/gcl_pcl_methods.lisp | 1646 + pcl/gcl_pcl_pkg.lisp | 408 + pcl/gcl_pcl_precom1.lisp | 51 + pcl/gcl_pcl_precom2.lisp | 31 + pcl/gcl_pcl_slots.lisp | 385 + pcl/gcl_pcl_slots_boot.lisp | 406 + pcl/gcl_pcl_std_class.lisp | 1321 + pcl/gcl_pcl_vector.lisp | 1109 + pcl/gcl_pcl_walk.lisp | 2198 ++ pcl/impl/cmu/README | 17 + pcl/impl/cmu/cmu-low.lisp | 217 + pcl/impl/cmu/pclcom.lisp | 66 + pcl/impl/cmu/pclload.lisp | 12 + pcl/impl/coral/coral-low.lisp | 63 + pcl/impl/franz/cpatch.lisp | 32 + pcl/impl/franz/excl-low.lisp | 136 + pcl/impl/franz/quadlap.lisp | 619 + pcl/impl/gcl/README | 14 + pcl/impl/gcl/gcl-low.lisp | 316 + pcl/impl/gcl/gcl-patches.lisp | 225 + pcl/impl/gcl/gcl_pcl_impl_low.lisp | 310 + pcl/impl/gcl/makefile.gcl | 38 + pcl/impl/gcl/sys-package.lisp | 149 + pcl/impl/gcl/sys-proclaim.lisp | 1448 + pcl/impl/gold-hill/gold-low.lisp | 51 + pcl/impl/gold-hill/gold-patches.lisp | 168 + pcl/impl/hp/hp-low.lisp | 37 + pcl/impl/ibcl/ibcl-low.lisp | 327 + pcl/impl/ibcl/ibcl-patches.lisp | 129 + pcl/impl/kcl/kcl-low.lisp | 438 + pcl/impl/kcl/kcl-mods.text | 224 + pcl/impl/kcl/kcl-notes.text | 39 + pcl/impl/kcl/kcl-patches.lisp | 362 + pcl/impl/kcl/makefile.akcl | 32 + pcl/impl/kcl/misc-kcl-patches.text | 340 + pcl/impl/kcl/new-kcl-wrapper.text | 2157 + pcl/impl/kcl/sys-package.lisp | 149 + pcl/impl/kcl/sys-proclaim.lisp | 818 + pcl/impl/kcl/sysdef.lisp | 121 + pcl/impl/lucid/lucid-low.lisp | 384 + pcl/impl/pyramid/pyr-low.lisp | 50 + pcl/impl/pyramid/pyr-patches.lisp | 9 + pcl/impl/symbolics/cloe-low.lisp | 32 + pcl/impl/symbolics/genera-low.lisp | 423 + pcl/impl/symbolics/rel-7-2-patches.lisp | 387 + pcl/impl/symbolics/rel-8-patches.lisp | 255 + pcl/impl/ti/ti-low.lisp | 83 + pcl/impl/ti/ti-patches.lisp | 105 + pcl/impl/vaxlisp/vaxl-low.lisp | 80 + pcl/impl/xerox/pcl-env-internal.lisp | 261 + pcl/impl/xerox/pcl-env.lisp | 1629 + pcl/impl/xerox/pcl-env.text | 105 + pcl/impl/xerox/xerox-low.lisp | 173 + pcl/impl/xerox/xerox-patches.lisp | 248 + pcl/makefile | 74 + pcl/notes/12-7-88-notes.text | 45 + pcl/notes/3-17-88-notes.text | 167 + pcl/notes/3-19-87-notes.text | 138 + pcl/notes/4-21-87-notes.text | 53 + pcl/notes/4-29-87-notes.text | 80 + pcl/notes/5-22-87-notes.text | 126 + pcl/notes/5-22-89-notes.text | 152 + pcl/notes/8-28-88-notes.text | 537 + pcl/notes/get-pcl.text | 180 + pcl/notes/lap.text | 655 + pcl/notes/may-day-notes.text | 98 + pcl/notes/notes.text | 366 + pcl/notes/readme.text | 11 + pcl/old/construct.lisp | 1064 + pcl/old/dlap.lisp | 639 + pcl/old/lap.lisp | 500 + pcl/old/plap.lisp | 369 + pcl/pcl_methods.patch | 11 + pcl/sys-package.lisp | 2636 ++ pcl/sys-proclaim.lisp | 1458 + pcl/test/bench-precompile.lisp | 3 + pcl/test/bench.lisp | 575 + pcl/test/bench.out | 21 + pcl/test/list-functions.lisp | 141 + pcl/test/make-test.lisp | 47 + pcl/test/makediff | Bin 0 -> 953 bytes pcl/test/time.lisp | 156 + pcl/unused/precom4.lisp | 32 + readme | 359 + readme-bin.mingw | 32 + readme.gmp | 20 + readme.mingw | 119 + readme.xgcl | 77 + unixport/aix-crt0.el | 7 + unixport/aix_exports | 1892 + unixport/ansi_cl.lisp | 159 + unixport/boots | 55 + unixport/bsd_rsym.c | 154 + unixport/cmpboots | 18 + unixport/gcldos.lsp | 84 + unixport/gcrt0.el | Bin 0 -> 203 bytes unixport/init_ansi_gcl.lsp.in | 266 + unixport/init_gcl.lsp.in | 95 + unixport/init_pcl_gcl.lsp.in | 107 + unixport/init_pre_gcl.lsp.in | 96 + unixport/lspboots | 19 + unixport/make_kcn | 5 + unixport/makefile | 200 + unixport/makefile.dos | 188 + unixport/msys.c | 85 + unixport/ncrt0.el | Bin 0 -> 214 bytes unixport/rsym.c | 349 + unixport/rsym_elf.c | 311 + unixport/rsym_macosx.c | 99 + unixport/rsym_nt.c | 68 + unixport/so_locations | 4 + unixport/sys-init.lsp | 5 + unixport/sys.c | 66 + unixport/sys_ansi_gcl.c | 188 + unixport/sys_boot.c | 67 + unixport/sys_gcl.c | 110 + unixport/sys_kcn.c | 26 + unixport/sys_pcl_gcl.c | 183 + unixport/sys_pre_gcl.c | 92 + unixport/tryserv.tcl | 29 + utils/replace | 4 + utils/repls1.sed | 31 + utils/repls2.sed | 8 + utils/repls3.sed | 25 + utils/repls4.sed | 90 + utils/repls5.sed | 93 + utils/revstruct.sed | 184 + windows/gcl.iss.in | 47 + windows/install.lsp.in | 165 + windows/instdos.sh | 6 + windows/sysdir.bat.in | 5 + xbin/386-linux-fix | 10 + xbin/add-dir | 16 + xbin/append | 5 + xbin/append.bat | 3 + xbin/comp_rel | 16 + xbin/compare-src | 19 + xbin/compare.c | 31 + xbin/dfiles | 2 + xbin/distrib-help | 9 + xbin/distribute | 67 + xbin/dos-files | 21 + xbin/dosmake.bat | 73 + xbin/exists | 4 + xbin/fix-copyright | 78 + xbin/get-externals | 11 + xbin/get-internal-calls | 12 + xbin/get-machine | 2 + xbin/ibm | 7 + xbin/if-exist.bat | 5 + xbin/if-exists | 15 + xbin/if-have-gcc | 3 + xbin/inc-version | 6 + xbin/is-V-newest | 37 + xbin/make-fn | 18 + xbin/maketest | 43 + xbin/maketest1 | 48 + xbin/move-if-changed | 17 + xbin/new-files | 19 + xbin/notify | 26 + xbin/setup-tmptest | 13 + xbin/spp.c | 102 + xbin/strip-ifdef | 10 + xbin/test | 16 + xbin/test-distrib | 27 + xbin/test1 | 19 + xbin/update | 4 + xgcl-2/Events.c | 3920 ++ xgcl-2/README | 119 + xgcl-2/XStruct-2.c | 1465 + xgcl-2/XStruct-4.c | 2484 ++ xgcl-2/Xakcl.paper | 801 + xgcl-2/Xutil-2.c | 56 + xgcl-2/dec.copyright | 23 + xgcl-2/dwdoc.pdf | Bin 0 -> 104815 bytes xgcl-2/dwdoc.tex | 958 + xgcl-2/dwdoc/dwdoc1.html | 948 + xgcl-2/dwdoc/dwdoc2.html | 117 + xgcl-2/dwdoc/dwdoc3.html | 44 + xgcl-2/dwdoc/dwdoccontents.html | 1 + xgcl-2/dwdoc/dwdocindex.html | 1 + xgcl-2/gcl_X.lsp | 689 + xgcl-2/gcl_X10.lsp | 30 + xgcl-2/gcl_XAtom.lsp | 118 + xgcl-2/gcl_XStruct_l_3.lsp | 491 + xgcl-2/gcl_Xakcl.example.lsp | 326 + xgcl-2/gcl_Xinit.lsp | 147 + xgcl-2/gcl_Xlib.lsp | 3456 ++ xgcl-2/gcl_Xstruct.lsp | 311 + xgcl-2/gcl_Xutil.lsp | 797 + xgcl-2/gcl_defentry_events.lsp | 817 + xgcl-2/gcl_dispatch-events.lsp | 50 + xgcl-2/gcl_draw-gates.lsp | 101 + xgcl-2/gcl_draw.lsp | 1089 + xgcl-2/gcl_drawtrans.lsp | 1890 + xgcl-2/gcl_dwexports.lsp | 153 + xgcl-2/gcl_dwimports.lsp | 77 + xgcl-2/gcl_dwimportsb.lsp | 76 + xgcl-2/gcl_dwindow.lsp | 3020 ++ xgcl-2/gcl_dwsyms.lsp | 148 + xgcl-2/gcl_dwtest.lsp | 192 + xgcl-2/gcl_dwtestcases.lsp | 32 + xgcl-2/gcl_dwtrans.lsp | 2894 ++ xgcl-2/gcl_editors.lsp | 483 + xgcl-2/gcl_editorstrans.lsp | 589 + xgcl-2/gcl_general.lsp | 86 + xgcl-2/gcl_ice-cream.lsp | 37 + xgcl-2/gcl_imports.lsp | 728 + xgcl-2/gcl_index.lsp | 88 + xgcl-2/gcl_init_xgcl.lsp | 118 + xgcl-2/gcl_keysymdef.lsp | 1151 + xgcl-2/gcl_lispserver.lsp | 130 + xgcl-2/gcl_lispservertrans.lsp | 110 + xgcl-2/gcl_menu-set.lsp | 521 + xgcl-2/gcl_menu-settrans.lsp | 531 + xgcl-2/gcl_pcalc.lsp | 133 + xgcl-2/gcl_sysinit.lsp | 69 + xgcl-2/gcl_tohtml.lsp | 502 + xgcl-2/general-c.c | 65 + xgcl-2/gnu.license | 249 + xgcl-2/makefile | 35 + xgcl-2/sysdef.lisp | 75 + xgcl-2/version | 1 + 3381 files changed, 994371 insertions(+) create mode 100644 AC_FD_CC create mode 100644 AC_FD_MSG create mode 100755 COPYING.LIB-2.0 create mode 100755 ChangeLog create mode 100755 ChangeLog.old create mode 100644 README.macosx create mode 100644 README.openbsd create mode 100644 README.wine create mode 100644 RELEASE-2.5.1 create mode 100644 RELEASE-2.6.2.html create mode 100755 add-defs create mode 100755 add-defs.bat create mode 100755 add-defs1 create mode 100644 ansi-tests/.cvsignore create mode 100644 ansi-tests/README create mode 100644 ansi-tests/adjustable-array-p.lsp create mode 100644 ansi-tests/and.lsp create mode 100644 ansi-tests/ansi-aux.lsp create mode 100644 ansi-tests/apply.lsp create mode 100644 ansi-tests/aref.lsp create mode 100644 ansi-tests/array-as-class.lsp create mode 100644 ansi-tests/array-aux.lsp create mode 100644 ansi-tests/array-dimension.lsp create mode 100644 ansi-tests/array-dimensions.lsp create mode 100644 ansi-tests/array-displacement.lsp create mode 100644 ansi-tests/array-in-bounds-p.lsp create mode 100644 ansi-tests/array-misc.lsp create mode 100644 ansi-tests/array-rank.lsp create mode 100644 ansi-tests/array-row-major-index.lsp create mode 100644 ansi-tests/array-t.lsp create mode 100644 ansi-tests/array-total-size.lsp create mode 100644 ansi-tests/array.lsp create mode 100644 ansi-tests/arrayp.lsp create mode 100644 ansi-tests/assert.lsp create mode 100644 ansi-tests/atom-errors.lsp create mode 100644 ansi-tests/bit-and.lsp create mode 100644 ansi-tests/bit-andc1.lsp create mode 100644 ansi-tests/bit-andc2.lsp create mode 100644 ansi-tests/bit-eqv.lsp create mode 100644 ansi-tests/bit-ior.lsp create mode 100644 ansi-tests/bit-nand.lsp create mode 100644 ansi-tests/bit-nor.lsp create mode 100644 ansi-tests/bit-not.lsp create mode 100644 ansi-tests/bit-orc1.lsp create mode 100644 ansi-tests/bit-orc2.lsp create mode 100644 ansi-tests/bit-vector-p.lsp create mode 100644 ansi-tests/bit-vector.lsp create mode 100644 ansi-tests/bit-xor.lsp create mode 100644 ansi-tests/bit.lsp create mode 100644 ansi-tests/block.lsp create mode 100644 ansi-tests/boundp.lsp create mode 100644 ansi-tests/call-arguments-limit.lsp create mode 100644 ansi-tests/case.lsp create mode 100644 ansi-tests/catch.lsp create mode 100644 ansi-tests/ccase.lsp create mode 100644 ansi-tests/cell-error-name.lsp create mode 100644 ansi-tests/cerror.lsp create mode 100644 ansi-tests/char-aux.lsp create mode 100644 ansi-tests/char-compare.lsp create mode 100644 ansi-tests/char-schar.lsp create mode 100644 ansi-tests/character.lsp create mode 100644 ansi-tests/check-type.lsp create mode 100644 ansi-tests/cl-symbol-names.lsp create mode 100644 ansi-tests/cl-symbols-aux.lsp create mode 100644 ansi-tests/cl-symbols.lsp create mode 100644 ansi-tests/cl-test-package.lsp create mode 100644 ansi-tests/cltest.system create mode 100644 ansi-tests/coerce.lsp create mode 100644 ansi-tests/compile-and-load.lsp create mode 100644 ansi-tests/compile.lsp create mode 100644 ansi-tests/compiled-function-p.lsp create mode 100644 ansi-tests/compiler-macros.lsp create mode 100644 ansi-tests/complement.lsp create mode 100644 ansi-tests/concatenate.lsp create mode 100644 ansi-tests/cond.lsp create mode 100644 ansi-tests/condition.lsp create mode 100644 ansi-tests/cons-test-01.lsp create mode 100644 ansi-tests/cons-test-02.lsp create mode 100644 ansi-tests/cons-test-03.lsp create mode 100644 ansi-tests/cons-test-04.lsp create mode 100644 ansi-tests/cons-test-05.lsp create mode 100644 ansi-tests/cons-test-06.lsp create mode 100644 ansi-tests/cons-test-07.lsp create mode 100644 ansi-tests/cons-test-08.lsp create mode 100644 ansi-tests/cons-test-09.lsp create mode 100644 ansi-tests/cons-test-10.lsp create mode 100644 ansi-tests/cons-test-11.lsp create mode 100644 ansi-tests/cons-test-12.lsp create mode 100644 ansi-tests/cons-test-13.lsp create mode 100644 ansi-tests/cons-test-14.lsp create mode 100644 ansi-tests/cons-test-15.lsp create mode 100644 ansi-tests/cons-test-16.lsp create mode 100644 ansi-tests/cons-test-17.lsp create mode 100644 ansi-tests/cons-test-18.lsp create mode 100644 ansi-tests/cons-test-19.lsp create mode 100644 ansi-tests/cons-test-20.lsp create mode 100644 ansi-tests/cons-test-21.lsp create mode 100644 ansi-tests/cons-test-22.lsp create mode 100644 ansi-tests/cons-test-23.lsp create mode 100644 ansi-tests/cons-test-24.lsp create mode 100644 ansi-tests/cons-test-25.lsp create mode 100644 ansi-tests/constantly.lsp create mode 100644 ansi-tests/constantp.lsp create mode 100644 ansi-tests/copy-seq.lsp create mode 100644 ansi-tests/count-if-not.lsp create mode 100644 ansi-tests/count-if.lsp create mode 100644 ansi-tests/count.lsp create mode 100644 ansi-tests/ctypecase.lsp create mode 100644 ansi-tests/data-and-control-flow.lsp create mode 100644 ansi-tests/defconstant.lsp create mode 100644 ansi-tests/define-modify-macro.lsp create mode 100644 ansi-tests/defparameter.lsp create mode 100644 ansi-tests/defun.lsp create mode 100644 ansi-tests/defvar.lsp create mode 100644 ansi-tests/destructuring-bind.lsp create mode 100644 ansi-tests/ecase.lsp create mode 100644 ansi-tests/elt.lsp create mode 100644 ansi-tests/eql.lsp create mode 100644 ansi-tests/equal.lsp create mode 100644 ansi-tests/equalp.lsp create mode 100644 ansi-tests/error.lsp create mode 100644 ansi-tests/etypecase.lsp create mode 100644 ansi-tests/eval-and-compile.lsp create mode 100644 ansi-tests/eval.lsp create mode 100644 ansi-tests/every.lsp create mode 100644 ansi-tests/fboundp.lsp create mode 100644 ansi-tests/fdefinition.lsp create mode 100644 ansi-tests/features.lsp create mode 100644 ansi-tests/fill-pointer.lsp create mode 100644 ansi-tests/fill-strings.lsp create mode 100644 ansi-tests/fill.lsp create mode 100644 ansi-tests/find-if-not.lsp create mode 100644 ansi-tests/find-if.lsp create mode 100644 ansi-tests/find.lsp create mode 100644 ansi-tests/flet.lsp create mode 100644 ansi-tests/fmakunbound.lsp create mode 100644 ansi-tests/funcall.lsp create mode 100644 ansi-tests/function-lambda-expression.lsp create mode 100644 ansi-tests/function.lsp create mode 100644 ansi-tests/functionp.lsp create mode 100644 ansi-tests/gclload.lsp create mode 100644 ansi-tests/gclload1.lsp create mode 100644 ansi-tests/gclload2.lsp create mode 100644 ansi-tests/get-setf-expansion.lsp create mode 100644 ansi-tests/handler-bind.lsp create mode 100644 ansi-tests/handler-case.lsp create mode 100644 ansi-tests/hash-table.lsp create mode 100644 ansi-tests/identity.lsp create mode 100644 ansi-tests/if.lsp create mode 100644 ansi-tests/invoke-debugger.lsp create mode 100644 ansi-tests/iteration.lsp create mode 100644 ansi-tests/labels.lsp create mode 100644 ansi-tests/lambda-list-keywords.lsp create mode 100644 ansi-tests/lambda-parameters-limit.lsp create mode 100644 ansi-tests/lambda.lsp create mode 100644 ansi-tests/length.lsp create mode 100644 ansi-tests/let.lsp create mode 100644 ansi-tests/load-arrays.lsp create mode 100644 ansi-tests/load-conditions.lsp create mode 100644 ansi-tests/load-cons.lsp create mode 100644 ansi-tests/load-data-and-control-flow.lsp create mode 100644 ansi-tests/load-eval-and-compile.lsp create mode 100644 ansi-tests/load-iteration.lsp create mode 100644 ansi-tests/load-sequences.lsp create mode 100644 ansi-tests/load-strings.lsp create mode 100644 ansi-tests/load-structures.lsp create mode 100644 ansi-tests/load-symbols.lsp create mode 100644 ansi-tests/load-types-and-class.lsp create mode 100644 ansi-tests/load.lsp create mode 100644 ansi-tests/loop.lsp create mode 100644 ansi-tests/loop1.lsp create mode 100644 ansi-tests/loop10.lsp create mode 100644 ansi-tests/loop11.lsp create mode 100644 ansi-tests/loop12.lsp create mode 100644 ansi-tests/loop13.lsp create mode 100644 ansi-tests/loop14.lsp create mode 100644 ansi-tests/loop15.lsp create mode 100644 ansi-tests/loop16.lsp create mode 100644 ansi-tests/loop17.lsp create mode 100644 ansi-tests/loop2.lsp create mode 100644 ansi-tests/loop3.lsp create mode 100644 ansi-tests/loop4.lsp create mode 100644 ansi-tests/loop5.lsp create mode 100644 ansi-tests/loop6.lsp create mode 100644 ansi-tests/loop7.lsp create mode 100644 ansi-tests/loop8.lsp create mode 100644 ansi-tests/loop9.lsp create mode 100644 ansi-tests/macrolet.lsp create mode 100644 ansi-tests/make-array.lsp create mode 100644 ansi-tests/make-hash-table.lsp create mode 100644 ansi-tests/make-sequence.lsp create mode 100644 ansi-tests/make-string.lsp create mode 100755 ansi-tests/make-tar create mode 100644 ansi-tests/makefile create mode 100644 ansi-tests/map-into.lsp create mode 100644 ansi-tests/map.lsp create mode 100644 ansi-tests/merge.lsp create mode 100644 ansi-tests/mismatch.lsp create mode 100644 ansi-tests/multiple-value-bind.lsp create mode 100644 ansi-tests/multiple-value-call.lsp create mode 100644 ansi-tests/multiple-value-list.lsp create mode 100644 ansi-tests/multiple-value-prog1.lsp create mode 100644 ansi-tests/multiple-value-setq.lsp create mode 100644 ansi-tests/nil.lsp create mode 100644 ansi-tests/not-and-null.lsp create mode 100644 ansi-tests/notany.lsp create mode 100644 ansi-tests/notevery.lsp create mode 100644 ansi-tests/nreverse.lsp create mode 100644 ansi-tests/nstring-capitalize.lsp create mode 100644 ansi-tests/nstring-downcase.lsp create mode 100644 ansi-tests/nstring-upcase.lsp create mode 100644 ansi-tests/nsubstitute-if-not.lsp create mode 100644 ansi-tests/nsubstitute-if.lsp create mode 100644 ansi-tests/nsubstitute.lsp create mode 100644 ansi-tests/nth-value.lsp create mode 100644 ansi-tests/or.lsp create mode 100644 ansi-tests/packages-00.lsp create mode 100644 ansi-tests/packages-01.lsp create mode 100644 ansi-tests/packages-02.lsp create mode 100644 ansi-tests/packages-03.lsp create mode 100644 ansi-tests/packages-04.lsp create mode 100644 ansi-tests/packages-05.lsp create mode 100644 ansi-tests/packages-06.lsp create mode 100644 ansi-tests/packages-07.lsp create mode 100644 ansi-tests/packages-08.lsp create mode 100644 ansi-tests/packages-09.lsp create mode 100644 ansi-tests/packages-10.lsp create mode 100644 ansi-tests/packages-11.lsp create mode 100644 ansi-tests/packages-12.lsp create mode 100644 ansi-tests/packages-13.lsp create mode 100644 ansi-tests/packages-14.lsp create mode 100644 ansi-tests/packages-15.lsp create mode 100644 ansi-tests/packages-16.lsp create mode 100644 ansi-tests/packages-17.lsp create mode 100644 ansi-tests/packages-18.lsp create mode 100644 ansi-tests/packages-19.lsp create mode 100644 ansi-tests/packages.lsp create mode 100644 ansi-tests/places.lsp create mode 100644 ansi-tests/position-if-not.lsp create mode 100644 ansi-tests/position-if.lsp create mode 100644 ansi-tests/position.lsp create mode 100644 ansi-tests/prog.lsp create mode 100644 ansi-tests/prog1.lsp create mode 100644 ansi-tests/prog2.lsp create mode 100644 ansi-tests/progn.lsp create mode 100644 ansi-tests/progv.lsp create mode 100644 ansi-tests/random-aux.lsp create mode 100644 ansi-tests/random-int-form.lsp create mode 100644 ansi-tests/random-intern.lsp create mode 100644 ansi-tests/reader-test.lsp create mode 100644 ansi-tests/reduce.lsp create mode 100644 ansi-tests/remove-aux.lsp create mode 100644 ansi-tests/remove-duplicates-aux.lsp create mode 100644 ansi-tests/remove-duplicates.lsp create mode 100644 ansi-tests/remove.lsp create mode 100644 ansi-tests/replace.lsp create mode 100644 ansi-tests/reverse.lsp create mode 100644 ansi-tests/row-major-aref.lsp create mode 100644 ansi-tests/rt-acl.system create mode 100644 ansi-tests/rt-doc.txt create mode 100644 ansi-tests/rt-package.lsp create mode 100644 ansi-tests/rt-test.lsp create mode 100644 ansi-tests/rt.lsp create mode 100644 ansi-tests/rt.system create mode 100644 ansi-tests/sbit.lsp create mode 100644 ansi-tests/search-aux.lsp create mode 100644 ansi-tests/search-bitvector.lsp create mode 100644 ansi-tests/search-list.lsp create mode 100644 ansi-tests/search-string.lsp create mode 100644 ansi-tests/search-vector.lsp create mode 100644 ansi-tests/simple-array-t.lsp create mode 100644 ansi-tests/simple-array.lsp create mode 100644 ansi-tests/simple-bit-vector-p.lsp create mode 100644 ansi-tests/simple-bit-vector.lsp create mode 100644 ansi-tests/simple-vector-p.lsp create mode 100644 ansi-tests/some.lsp create mode 100644 ansi-tests/sort.lsp create mode 100644 ansi-tests/stable-sort.lsp create mode 100644 ansi-tests/string-aux.lsp create mode 100644 ansi-tests/string-capitalize.lsp create mode 100644 ansi-tests/string-comparisons.lsp create mode 100644 ansi-tests/string-downcase.lsp create mode 100644 ansi-tests/string-left-trim.lsp create mode 100644 ansi-tests/string-right-trim.lsp create mode 100644 ansi-tests/string-trim.lsp create mode 100644 ansi-tests/string-upcase.lsp create mode 100644 ansi-tests/string.lsp create mode 100644 ansi-tests/structure-00.lsp create mode 100644 ansi-tests/structures-01.lsp create mode 100644 ansi-tests/structures-02.lsp create mode 100644 ansi-tests/structures-03.lsp create mode 100644 ansi-tests/subseq-aux.lsp create mode 100644 ansi-tests/subseq.lsp create mode 100644 ansi-tests/substitute-if-not.lsp create mode 100644 ansi-tests/substitute-if.lsp create mode 100644 ansi-tests/substitute.lsp create mode 100644 ansi-tests/subtypep-array.lsp create mode 100644 ansi-tests/subtypep-cons.lsp create mode 100644 ansi-tests/subtypep-eql.lsp create mode 100644 ansi-tests/subtypep-float.lsp create mode 100644 ansi-tests/subtypep-integer.lsp create mode 100644 ansi-tests/subtypep-member.lsp create mode 100644 ansi-tests/subtypep-rational.lsp create mode 100644 ansi-tests/subtypep-real.lsp create mode 100644 ansi-tests/subtypep.lsp create mode 100644 ansi-tests/svref.lsp create mode 100644 ansi-tests/t.lsp create mode 100644 ansi-tests/tagbody.lsp create mode 100644 ansi-tests/typecase.lsp create mode 100644 ansi-tests/types-and-class-2.lsp create mode 100644 ansi-tests/types-and-class.lsp create mode 100644 ansi-tests/universe.lsp create mode 100644 ansi-tests/unless.lsp create mode 100644 ansi-tests/unwind-protect.lsp create mode 100644 ansi-tests/upgraded-array-element-type.lsp create mode 100644 ansi-tests/values-list.lsp create mode 100644 ansi-tests/values.lsp create mode 100644 ansi-tests/vector-pop.lsp create mode 100644 ansi-tests/vector-push-extend.lsp create mode 100644 ansi-tests/vector-push.lsp create mode 100644 ansi-tests/vector.lsp create mode 100644 ansi-tests/vectorp.lsp create mode 100644 ansi-tests/warn.lsp create mode 100644 ansi-tests/when.lsp create mode 100644 bfdtest.c create mode 100755 bin/append.c create mode 100755 bin/dpp.c create mode 100644 bin/file-sub.c create mode 100755 bin/info create mode 100755 bin/info1 create mode 100644 bin/makefile create mode 100755 bin/tkinfo create mode 100755 clcs/gcl_clcs_condition_definitions.lisp create mode 100755 clcs/gcl_clcs_conditions.lisp create mode 100755 clcs/gcl_clcs_handler.lisp create mode 100755 clcs/gcl_clcs_precom.lisp create mode 100644 clcs/gcl_cmpinit.lsp create mode 100755 clcs/loading.lisp create mode 100644 clcs/makefile create mode 100644 clcs/myload.lisp create mode 100755 clcs/package.lisp create mode 100755 clcs/readme create mode 100644 clcs/sys-proclaim.lisp create mode 100755 clcs/unused/condition_precom.lisp create mode 100755 clcs/unused/doload.lisp create mode 100755 clcs/unused/reload.lisp create mode 100755 clcs/unused/sysdef.lisp create mode 100755 clcs/unused/test.lisp create mode 100755 clcs/unused/test2.lisp create mode 100755 clcs/unused/test3.lisp create mode 100755 clcs/unused/test4.lisp create mode 100755 clcs/unused/test5.lisp create mode 100755 clcs/unused/tester.lisp create mode 100755 cmpnew/gcl_cmpbind.lsp create mode 100755 cmpnew/gcl_cmpblock.lsp create mode 100755 cmpnew/gcl_cmpcall.lsp create mode 100755 cmpnew/gcl_cmpcatch.lsp create mode 100755 cmpnew/gcl_cmpenv.lsp create mode 100755 cmpnew/gcl_cmpeval.lsp create mode 100755 cmpnew/gcl_cmpflet.lsp create mode 100755 cmpnew/gcl_cmpfun.lsp create mode 100755 cmpnew/gcl_cmpif.lsp create mode 100755 cmpnew/gcl_cmpinit.lsp create mode 100755 cmpnew/gcl_cmpinline.lsp create mode 100755 cmpnew/gcl_cmplabel.lsp create mode 100755 cmpnew/gcl_cmplam.lsp create mode 100755 cmpnew/gcl_cmplet.lsp create mode 100755 cmpnew/gcl_cmploc.lsp create mode 100755 cmpnew/gcl_cmpmain.lsp create mode 100755 cmpnew/gcl_cmpmap.lsp create mode 100755 cmpnew/gcl_cmpmulti.lsp create mode 100755 cmpnew/gcl_cmpopt.lsp create mode 100755 cmpnew/gcl_cmpspecial.lsp create mode 100755 cmpnew/gcl_cmptag.lsp create mode 100755 cmpnew/gcl_cmptest.lsp create mode 100755 cmpnew/gcl_cmptop.lsp create mode 100755 cmpnew/gcl_cmptype.lsp create mode 100755 cmpnew/gcl_cmputil.lsp create mode 100755 cmpnew/gcl_cmpvar.lsp create mode 100755 cmpnew/gcl_cmpvs.lsp create mode 100755 cmpnew/gcl_cmpwt.lsp create mode 100755 cmpnew/gcl_collectfn.lsp create mode 100755 cmpnew/gcl_fasdmacros.lsp create mode 100755 cmpnew/gcl_init.lsp create mode 100755 cmpnew/gcl_lfun_list.lsp create mode 100755 cmpnew/gcl_make-fn.lsp create mode 100755 cmpnew/gcl_make_ufun.lsp create mode 100755 cmpnew/gcl_nocmpinc.lsp create mode 100644 cmpnew/makefile create mode 100755 cmpnew/so_locations create mode 100755 cmpnew/sys-proclaim.lisp create mode 100755 comp/bo1.lsp create mode 100755 comp/c-pass1.lsp create mode 100755 comp/cmpinit.lsp create mode 100755 comp/comptype.lsp create mode 100755 comp/data.lsp create mode 100755 comp/defmacro.lsp create mode 100755 comp/defs.lsp create mode 100755 comp/exit.lsp create mode 100755 comp/fasdmacros.lsp create mode 100755 comp/inline.lsp create mode 100755 comp/integer.doc create mode 100755 comp/lambda.lsp create mode 100755 comp/lisp-decls.doc create mode 100755 comp/macros.lsp create mode 100644 comp/makefile create mode 100755 comp/mangle.lsp create mode 100755 comp/opts-base.lsp create mode 100755 comp/opts.lsp create mode 100755 comp/proclaim.lsp create mode 100755 comp/smash-oldcmp.lsp create mode 100755 comp/stmt.lsp create mode 100755 comp/sysdef.lsp create mode 100755 comp/top.lsp create mode 100755 comp/top1.lsp create mode 100755 comp/top2.lsp create mode 100755 comp/try.lsp create mode 100755 comp/try1.lsp create mode 100755 comp/utils.lsp create mode 100755 comp/var.lsp create mode 100755 comp/wr.lsp create mode 100755 config.guess create mode 100755 config.sub create mode 100755 configure create mode 100644 configure-new.ac create mode 100644 configure.in create mode 100644 debian/README.Debian create mode 100644 debian/changelog create mode 100644 debian/compat create mode 100644 debian/control create mode 100644 debian/control. create mode 100644 debian/control.cvs create mode 100644 debian/copyright create mode 100644 debian/gcl.lintian-overrides create mode 100755 debian/gcl.sh create mode 100644 debian/gcl.templates create mode 100644 debian/in.gcl-doc.README.Debian create mode 100644 debian/in.gcl-doc.doc-base.si create mode 100644 debian/in.gcl-doc.doc-base.tk create mode 100644 debian/in.gcl-doc.doc-base.xgcl create mode 100644 debian/in.gcl-doc.docs create mode 100644 debian/in.gcl-doc.info create mode 100644 debian/in.gcl-doc.install create mode 100644 debian/in.gcl.config create mode 100644 debian/in.gcl.docs create mode 100644 debian/in.gcl.emacsen-compat create mode 100644 debian/in.gcl.emacsen-install create mode 100644 debian/in.gcl.emacsen-remove create mode 100644 debian/in.gcl.emacsen-startup create mode 100644 debian/in.gcl.install create mode 100644 debian/in.gcl.manpages create mode 100644 debian/in.gcl.postinst create mode 100644 debian/in.gcl.postrm create mode 100644 debian/old.in.gcl-doc.doc-base.main create mode 100644 debian/po/POTFILES.in create mode 100644 debian/po/cs.po create mode 100644 debian/po/da.po create mode 100644 debian/po/de.po create mode 100644 debian/po/es.po create mode 100644 debian/po/fi.po create mode 100644 debian/po/fr.po create mode 100644 debian/po/gl.po create mode 100644 debian/po/it.po create mode 100644 debian/po/ja.po create mode 100644 debian/po/nl.po create mode 100644 debian/po/pt.po create mode 100644 debian/po/ru.po create mode 100644 debian/po/sv.po create mode 100644 debian/po/templates.pot create mode 100644 debian/po/vi.po create mode 100755 debian/rules create mode 100644 debian/source/format create mode 100644 debian/source/include-binaries create mode 100755 debian/texi.awk create mode 100644 debian/upstream/signing-key.asc create mode 100644 debian/watch create mode 100644 doc/bignum create mode 100644 doc/c-gc create mode 100644 doc/c-gc.doc create mode 100644 doc/compile-file-handling-of-top-level-forms create mode 100644 doc/contributors create mode 100644 doc/debug create mode 100644 doc/enhancements create mode 100644 doc/fast-link create mode 100644 doc/format create mode 100644 doc/funcall-comp create mode 100644 doc/funcall.lsp create mode 100644 doc/makefile create mode 100644 doc/multiple-values create mode 100644 doc/profile create mode 100755 dos/dostimes.c create mode 100755 dos/dum_dos.c create mode 100644 dos/makefile create mode 100755 dos/read.s create mode 100755 dos/readme create mode 100755 dos/sigman.s create mode 100755 dos/signal.c create mode 100755 dos/signal.h create mode 100644 elisp/add-default.el create mode 100755 elisp/ansi-doc.el create mode 100755 elisp/dbl.el create mode 100755 elisp/doc-to-texi.el create mode 100755 elisp/gcl.el create mode 100644 elisp/makefile create mode 100755 elisp/man1-to-texi.el create mode 100755 elisp/readme create mode 100644 elisp/smart-complete.el create mode 100755 elisp/sshell.el create mode 100755 eval.html create mode 100755 eval.tcl create mode 100755 faq create mode 100755 gcl-tk/comm.c create mode 100755 gcl-tk/convert.el create mode 100644 gcl-tk/decode.tcl create mode 100755 gcl-tk/demos-4.1/items.lisp create mode 100755 gcl-tk/demos-4.2/widget create mode 100755 gcl-tk/demos-4.2/widget.lisp create mode 100755 gcl-tk/demos/gc-monitor.lisp create mode 100755 gcl-tk/demos/mkArrow.tcl create mode 100755 gcl-tk/demos/mkBasic.lisp create mode 100755 gcl-tk/demos/mkBasic.tcl create mode 100755 gcl-tk/demos/mkBitmaps.tcl create mode 100755 gcl-tk/demos/mkButton.tcl create mode 100755 gcl-tk/demos/mkCanvText.lisp create mode 100755 gcl-tk/demos/mkCanvText.tcl create mode 100755 gcl-tk/demos/mkCheck.tcl create mode 100755 gcl-tk/demos/mkDialog.tcl create mode 100755 gcl-tk/demos/mkEntry.lisp create mode 100755 gcl-tk/demos/mkEntry.tcl create mode 100755 gcl-tk/demos/mkEntry2.lisp create mode 100755 gcl-tk/demos/mkEntry2.tcl create mode 100755 gcl-tk/demos/mkFloor.tcl create mode 100755 gcl-tk/demos/mkForm.lisp create mode 100755 gcl-tk/demos/mkForm.tcl create mode 100755 gcl-tk/demos/mkHScale.lisp create mode 100755 gcl-tk/demos/mkHScale.tcl create mode 100755 gcl-tk/demos/mkIcon.tcl create mode 100755 gcl-tk/demos/mkItems.lisp create mode 100755 gcl-tk/demos/mkItems.tcl create mode 100755 gcl-tk/demos/mkLabel.lisp create mode 100755 gcl-tk/demos/mkLabel.tcl create mode 100755 gcl-tk/demos/mkListbox.lisp create mode 100755 gcl-tk/demos/mkListbox.tcl create mode 100755 gcl-tk/demos/mkListbox2.tcl create mode 100755 gcl-tk/demos/mkListbox3.tcl create mode 100755 gcl-tk/demos/mkPlot.lisp create mode 100755 gcl-tk/demos/mkPlot.tcl create mode 100755 gcl-tk/demos/mkPuzzle.tcl create mode 100755 gcl-tk/demos/mkRadio.lisp create mode 100755 gcl-tk/demos/mkRadio.tcl create mode 100755 gcl-tk/demos/mkRuler.lisp create mode 100755 gcl-tk/demos/mkRuler.tcl create mode 100755 gcl-tk/demos/mkScroll.tcl create mode 100755 gcl-tk/demos/mkSearch.lisp create mode 100755 gcl-tk/demos/mkSearch.tcl create mode 100755 gcl-tk/demos/mkStyles.lisp create mode 100755 gcl-tk/demos/mkStyles.tcl create mode 100755 gcl-tk/demos/mkTear.tcl create mode 100755 gcl-tk/demos/mkTextBind.lisp create mode 100755 gcl-tk/demos/mkTextBind.tcl create mode 100755 gcl-tk/demos/mkVScale.lisp create mode 100755 gcl-tk/demos/mkVScale.tcl create mode 100755 gcl-tk/demos/mkdialog.lisp create mode 100755 gcl-tk/demos/nqthm-stack.lisp create mode 100755 gcl-tk/demos/showVars.lisp create mode 100755 gcl-tk/demos/showVars.tcl create mode 100755 gcl-tk/demos/tclIndex create mode 100755 gcl-tk/demos/widget.lisp create mode 100755 gcl-tk/dir.sed create mode 100755 gcl-tk/gcl-1.tcl create mode 100755 gcl-tk/gcl.tcl create mode 100755 gcl-tk/gcl_cmpinit.lsp create mode 100755 gcl-tk/gcl_guisl.h create mode 100755 gcl-tk/gcltksrv.bat create mode 100755 gcl-tk/gcltksrv.in create mode 100755 gcl-tk/gcltksrv.in.interp create mode 100755 gcl-tk/gcltksrv.prev create mode 100755 gcl-tk/guis.c create mode 100755 gcl-tk/guis.h create mode 100755 gcl-tk/helpers.lisp create mode 100755 gcl-tk/index.lsp create mode 100755 gcl-tk/intrs.h create mode 100644 gcl-tk/makefile create mode 100644 gcl-tk/makefile.prev create mode 100755 gcl-tk/ngcltksrv create mode 100755 gcl-tk/our_io.c create mode 100755 gcl-tk/sheader.h create mode 100755 gcl-tk/socketsl.lisp create mode 100755 gcl-tk/socks.h create mode 100755 gcl-tk/sysdep-sunos.h create mode 100755 gcl-tk/tinfo.lsp create mode 100755 gcl-tk/tk-package.lsp create mode 100755 gcl-tk/tkAppInit.c create mode 100755 gcl-tk/tkMain.c create mode 100755 gcl-tk/tkXAppInit.c create mode 100755 gcl-tk/tkXshell.c create mode 100755 gcl-tk/tkl.lisp create mode 100755 gcl-tk/tktst.c create mode 100644 gcl.ico create mode 100755 gcl.jpg create mode 100644 gcl.png create mode 100755 gcl1.jpg create mode 100644 gcl2.jpg create mode 100644 gmp.patch create mode 100644 gmp4/.gdbinit create mode 100644 gmp4/.pc/.quilt_patches create mode 100644 gmp4/.pc/.quilt_series create mode 100644 gmp4/.pc/.version create mode 100644 gmp4/.pc/4a6d258b467f.patch/mpn/powerpc64/mode64/gcd_1.asm create mode 100644 gmp4/.pc/applied-patches create mode 100644 gmp4/.pc/arm-asm-nothumb.patch/mpn/generic/div_qr_1n_pi1.c create mode 100644 gmp4/AUTHORS create mode 100644 gmp4/COPYING create mode 100644 gmp4/COPYING.LESSERv3 create mode 100644 gmp4/COPYINGv2 create mode 100644 gmp4/COPYINGv3 create mode 100644 gmp4/ChangeLog create mode 100644 gmp4/INSTALL create mode 100644 gmp4/INSTALL.autoconf create mode 100644 gmp4/Makefile.am create mode 100644 gmp4/Makefile.in create mode 100644 gmp4/NEWS create mode 100644 gmp4/README create mode 100644 gmp4/acinclude.m4 create mode 100644 gmp4/aclocal.m4 create mode 100644 gmp4/assert.c create mode 100644 gmp4/autom4te.cache/output.0 create mode 100644 gmp4/autom4te.cache/output.1 create mode 100644 gmp4/autom4te.cache/requests create mode 100644 gmp4/autom4te.cache/traces.0 create mode 100644 gmp4/autom4te.cache/traces.1 create mode 100644 gmp4/bootstrap.c create mode 100644 gmp4/compat.c create mode 100755 gmp4/compile create mode 100755 gmp4/config.guess create mode 100644 gmp4/config.in create mode 100644 gmp4/config.in~ create mode 100755 gmp4/config.sub create mode 100755 gmp4/configfsf.guess create mode 100644 gmp4/configfsf.sub create mode 100755 gmp4/configure create mode 100644 gmp4/configure.ac create mode 100644 gmp4/cxx/Makefile.am create mode 100644 gmp4/cxx/Makefile.in create mode 100644 gmp4/cxx/dummy.cc create mode 100644 gmp4/cxx/isfuns.cc create mode 100644 gmp4/cxx/ismpf.cc create mode 100644 gmp4/cxx/ismpq.cc create mode 100644 gmp4/cxx/ismpz.cc create mode 100644 gmp4/cxx/ismpznw.cc create mode 100644 gmp4/cxx/limits.cc create mode 100644 gmp4/cxx/osdoprnti.cc create mode 100644 gmp4/cxx/osfuns.cc create mode 100644 gmp4/cxx/osmpf.cc create mode 100644 gmp4/cxx/osmpq.cc create mode 100644 gmp4/cxx/osmpz.cc create mode 100644 gmp4/debian/NEWS.Debian create mode 100644 gmp4/debian/Notes create mode 100644 gmp4/debian/README.Debian create mode 100644 gmp4/debian/README.source create mode 100644 gmp4/debian/changelog create mode 100644 gmp4/debian/compat create mode 100644 gmp4/debian/control create mode 100644 gmp4/debian/copyright create mode 100644 gmp4/debian/libgmp10-doc.README.Debian create mode 100644 gmp4/debian/libgmp10-doc.examples create mode 100644 gmp4/debian/libgmp10.symbols create mode 100644 gmp4/debian/libgmpxx4ldbl.lintian-overrides create mode 100644 gmp4/debian/patches/4a6d258b467f.patch create mode 100644 gmp4/debian/patches/arm-asm-nothumb.patch create mode 100644 gmp4/debian/patches/series create mode 100755 gmp4/debian/rules create mode 100644 gmp4/debian/source/format create mode 100644 gmp4/debian/watch create mode 100644 gmp4/demos/Makefile.am create mode 100644 gmp4/demos/Makefile.in create mode 100644 gmp4/demos/calc/Makefile.am create mode 100644 gmp4/demos/calc/Makefile.in create mode 100644 gmp4/demos/calc/README create mode 100644 gmp4/demos/calc/calc-common.h create mode 100644 gmp4/demos/calc/calc-config-h.in create mode 100644 gmp4/demos/calc/calc.c create mode 100644 gmp4/demos/calc/calc.h create mode 100644 gmp4/demos/calc/calc.y create mode 100644 gmp4/demos/calc/calclex.c create mode 100644 gmp4/demos/calc/calclex.l create mode 100644 gmp4/demos/calc/calcread.c create mode 100644 gmp4/demos/expr/Makefile.am create mode 100644 gmp4/demos/expr/Makefile.in create mode 100644 gmp4/demos/expr/README create mode 100644 gmp4/demos/expr/expr-impl.h create mode 100644 gmp4/demos/expr/expr.c create mode 100644 gmp4/demos/expr/expr.h create mode 100644 gmp4/demos/expr/exprf.c create mode 100644 gmp4/demos/expr/exprfa.c create mode 100644 gmp4/demos/expr/exprq.c create mode 100644 gmp4/demos/expr/exprqa.c create mode 100644 gmp4/demos/expr/exprv.c create mode 100644 gmp4/demos/expr/exprz.c create mode 100644 gmp4/demos/expr/exprza.c create mode 100644 gmp4/demos/expr/run-expr.c create mode 100644 gmp4/demos/expr/t-expr.c create mode 100644 gmp4/demos/factorize.c create mode 100644 gmp4/demos/isprime.c create mode 100644 gmp4/demos/perl/GMP.pm create mode 100644 gmp4/demos/perl/GMP.xs create mode 100644 gmp4/demos/perl/GMP/Mpf.pm create mode 100644 gmp4/demos/perl/GMP/Mpq.pm create mode 100644 gmp4/demos/perl/GMP/Mpz.pm create mode 100644 gmp4/demos/perl/GMP/Rand.pm create mode 100644 gmp4/demos/perl/INSTALL create mode 100644 gmp4/demos/perl/Makefile.PL create mode 100644 gmp4/demos/perl/sample.pl create mode 100644 gmp4/demos/perl/test.pl create mode 100644 gmp4/demos/perl/test2.pl create mode 100644 gmp4/demos/perl/typemap create mode 100644 gmp4/demos/pexpr-config-h.in create mode 100644 gmp4/demos/pexpr.c create mode 100644 gmp4/demos/primes.c create mode 100644 gmp4/demos/primes.h create mode 100644 gmp4/demos/qcn.c create mode 100644 gmp4/doc/Makefile.am create mode 100644 gmp4/doc/Makefile.in create mode 100644 gmp4/errno.c create mode 100644 gmp4/extract-dbl.c create mode 100644 gmp4/gen-bases.c create mode 100644 gmp4/gen-fac.c create mode 100644 gmp4/gen-fib.c create mode 100644 gmp4/gen-jacobitab.c create mode 100644 gmp4/gen-psqr.c create mode 100644 gmp4/gen-trialdivtab.c create mode 100644 gmp4/gmp-h.in create mode 100644 gmp4/gmp-impl.h create mode 100644 gmp4/gmpxx.h create mode 100755 gmp4/install-sh create mode 100644 gmp4/invalid.c create mode 100644 gmp4/longlong.h create mode 100644 gmp4/ltmain.sh create mode 100644 gmp4/memory.c create mode 100644 gmp4/mini-gmp/README create mode 100644 gmp4/mini-gmp/mini-gmp.c create mode 100644 gmp4/mini-gmp/mini-gmp.h create mode 100644 gmp4/mini-gmp/tests/Makefile create mode 100644 gmp4/mini-gmp/tests/hex-random.c create mode 100644 gmp4/mini-gmp/tests/hex-random.h create mode 100644 gmp4/mini-gmp/tests/mini-random.c create mode 100644 gmp4/mini-gmp/tests/mini-random.h create mode 100755 gmp4/mini-gmp/tests/run-tests create mode 100644 gmp4/mini-gmp/tests/t-add.c create mode 100644 gmp4/mini-gmp/tests/t-aorsmul.c create mode 100644 gmp4/mini-gmp/tests/t-bitops.c create mode 100644 gmp4/mini-gmp/tests/t-cmp_d.c create mode 100644 gmp4/mini-gmp/tests/t-comb.c create mode 100644 gmp4/mini-gmp/tests/t-cong.c create mode 100644 gmp4/mini-gmp/tests/t-div.c create mode 100644 gmp4/mini-gmp/tests/t-div_2exp.c create mode 100644 gmp4/mini-gmp/tests/t-double.c create mode 100644 gmp4/mini-gmp/tests/t-gcd.c create mode 100644 gmp4/mini-gmp/tests/t-import.c create mode 100644 gmp4/mini-gmp/tests/t-invert.c create mode 100644 gmp4/mini-gmp/tests/t-lcm.c create mode 100644 gmp4/mini-gmp/tests/t-limbs.c create mode 100644 gmp4/mini-gmp/tests/t-logops.c create mode 100644 gmp4/mini-gmp/tests/t-mul.c create mode 100644 gmp4/mini-gmp/tests/t-powm.c create mode 100644 gmp4/mini-gmp/tests/t-pprime_p.c create mode 100644 gmp4/mini-gmp/tests/t-reuse.c create mode 100644 gmp4/mini-gmp/tests/t-root.c create mode 100644 gmp4/mini-gmp/tests/t-scan.c create mode 100644 gmp4/mini-gmp/tests/t-signed.c create mode 100644 gmp4/mini-gmp/tests/t-sqrt.c create mode 100644 gmp4/mini-gmp/tests/t-str.c create mode 100644 gmp4/mini-gmp/tests/t-sub.c create mode 100644 gmp4/mini-gmp/tests/testutils.c create mode 100644 gmp4/mini-gmp/tests/testutils.h create mode 100755 gmp4/missing create mode 100644 gmp4/mp_bpl.c create mode 100644 gmp4/mp_clz_tab.c create mode 100644 gmp4/mp_dv_tab.c create mode 100644 gmp4/mp_get_fns.c create mode 100644 gmp4/mp_minv_tab.c create mode 100644 gmp4/mp_set_fns.c create mode 100644 gmp4/mpf/Makefile.am create mode 100644 gmp4/mpf/Makefile.in create mode 100644 gmp4/mpf/abs.c create mode 100644 gmp4/mpf/add.c create mode 100644 gmp4/mpf/add_ui.c create mode 100644 gmp4/mpf/ceilfloor.c create mode 100644 gmp4/mpf/clear.c create mode 100644 gmp4/mpf/clears.c create mode 100644 gmp4/mpf/cmp.c create mode 100644 gmp4/mpf/cmp_d.c create mode 100644 gmp4/mpf/cmp_si.c create mode 100644 gmp4/mpf/cmp_ui.c create mode 100644 gmp4/mpf/div.c create mode 100644 gmp4/mpf/div_2exp.c create mode 100644 gmp4/mpf/div_ui.c create mode 100644 gmp4/mpf/dump.c create mode 100644 gmp4/mpf/eq.c create mode 100644 gmp4/mpf/fits_s.h create mode 100644 gmp4/mpf/fits_sint.c create mode 100644 gmp4/mpf/fits_slong.c create mode 100644 gmp4/mpf/fits_sshort.c create mode 100644 gmp4/mpf/fits_u.h create mode 100644 gmp4/mpf/fits_uint.c create mode 100644 gmp4/mpf/fits_ulong.c create mode 100644 gmp4/mpf/fits_ushort.c create mode 100644 gmp4/mpf/get_d.c create mode 100644 gmp4/mpf/get_d_2exp.c create mode 100644 gmp4/mpf/get_dfl_prec.c create mode 100644 gmp4/mpf/get_prc.c create mode 100644 gmp4/mpf/get_si.c create mode 100644 gmp4/mpf/get_str.c create mode 100644 gmp4/mpf/get_ui.c create mode 100644 gmp4/mpf/init.c create mode 100644 gmp4/mpf/init2.c create mode 100644 gmp4/mpf/inits.c create mode 100644 gmp4/mpf/inp_str.c create mode 100644 gmp4/mpf/int_p.c create mode 100644 gmp4/mpf/iset.c create mode 100644 gmp4/mpf/iset_d.c create mode 100644 gmp4/mpf/iset_si.c create mode 100644 gmp4/mpf/iset_str.c create mode 100644 gmp4/mpf/iset_ui.c create mode 100644 gmp4/mpf/mul.c create mode 100644 gmp4/mpf/mul_2exp.c create mode 100644 gmp4/mpf/mul_ui.c create mode 100644 gmp4/mpf/neg.c create mode 100644 gmp4/mpf/out_str.c create mode 100644 gmp4/mpf/pow_ui.c create mode 100644 gmp4/mpf/random2.c create mode 100644 gmp4/mpf/reldiff.c create mode 100644 gmp4/mpf/set.c create mode 100644 gmp4/mpf/set_d.c create mode 100644 gmp4/mpf/set_dfl_prec.c create mode 100644 gmp4/mpf/set_prc.c create mode 100644 gmp4/mpf/set_prc_raw.c create mode 100644 gmp4/mpf/set_q.c create mode 100644 gmp4/mpf/set_si.c create mode 100644 gmp4/mpf/set_str.c create mode 100644 gmp4/mpf/set_ui.c create mode 100644 gmp4/mpf/set_z.c create mode 100644 gmp4/mpf/size.c create mode 100644 gmp4/mpf/sqrt.c create mode 100644 gmp4/mpf/sqrt_ui.c create mode 100644 gmp4/mpf/sub.c create mode 100644 gmp4/mpf/sub_ui.c create mode 100644 gmp4/mpf/swap.c create mode 100644 gmp4/mpf/trunc.c create mode 100644 gmp4/mpf/ui_div.c create mode 100644 gmp4/mpf/ui_sub.c create mode 100644 gmp4/mpf/urandomb.c create mode 100644 gmp4/mpn/Makeasm.am create mode 100644 gmp4/mpn/Makefile.am create mode 100644 gmp4/mpn/Makefile.in create mode 100644 gmp4/mpn/README create mode 100644 gmp4/mpn/alpha/README create mode 100644 gmp4/mpn/alpha/add_n.asm create mode 100644 gmp4/mpn/alpha/addmul_1.asm create mode 100644 gmp4/mpn/alpha/alpha-defs.m4 create mode 100644 gmp4/mpn/alpha/aorslsh1_n.asm create mode 100644 gmp4/mpn/alpha/aorslsh2_n.asm create mode 100644 gmp4/mpn/alpha/bdiv_dbm1c.asm create mode 100644 gmp4/mpn/alpha/cntlz.asm create mode 100644 gmp4/mpn/alpha/com.asm create mode 100644 gmp4/mpn/alpha/copyd.asm create mode 100644 gmp4/mpn/alpha/copyi.asm create mode 100644 gmp4/mpn/alpha/default.m4 create mode 100644 gmp4/mpn/alpha/dive_1.c create mode 100644 gmp4/mpn/alpha/divrem_2.asm create mode 100644 gmp4/mpn/alpha/ev5/diveby3.asm create mode 100644 gmp4/mpn/alpha/ev5/gmp-mparam.h create mode 100644 gmp4/mpn/alpha/ev6/add_n.asm create mode 100644 gmp4/mpn/alpha/ev6/aorslsh1_n.asm create mode 100644 gmp4/mpn/alpha/ev6/aorsmul_1.asm create mode 100644 gmp4/mpn/alpha/ev6/gmp-mparam.h create mode 100644 gmp4/mpn/alpha/ev6/mod_1_4.asm create mode 100644 gmp4/mpn/alpha/ev6/mul_1.asm create mode 100644 gmp4/mpn/alpha/ev6/nails/README create mode 100644 gmp4/mpn/alpha/ev6/nails/addmul_1.asm create mode 100644 gmp4/mpn/alpha/ev6/nails/addmul_2.asm create mode 100644 gmp4/mpn/alpha/ev6/nails/addmul_3.asm create mode 100644 gmp4/mpn/alpha/ev6/nails/addmul_4.asm create mode 100644 gmp4/mpn/alpha/ev6/nails/aors_n.asm create mode 100644 gmp4/mpn/alpha/ev6/nails/gmp-mparam.h create mode 100644 gmp4/mpn/alpha/ev6/nails/mul_1.asm create mode 100644 gmp4/mpn/alpha/ev6/nails/submul_1.asm create mode 100755 gmp4/mpn/alpha/ev6/slot.pl create mode 100644 gmp4/mpn/alpha/ev6/sub_n.asm create mode 100644 gmp4/mpn/alpha/ev67/gcd_1.asm create mode 100644 gmp4/mpn/alpha/ev67/hamdist.asm create mode 100644 gmp4/mpn/alpha/ev67/popcount.asm create mode 100644 gmp4/mpn/alpha/gmp-mparam.h create mode 100644 gmp4/mpn/alpha/invert_limb.asm create mode 100644 gmp4/mpn/alpha/lshift.asm create mode 100644 gmp4/mpn/alpha/mod_34lsub1.asm create mode 100644 gmp4/mpn/alpha/mode1o.asm create mode 100644 gmp4/mpn/alpha/mul_1.asm create mode 100644 gmp4/mpn/alpha/rshift.asm create mode 100644 gmp4/mpn/alpha/sec_tabselect.asm create mode 100644 gmp4/mpn/alpha/sqr_diag_addlsh1.asm create mode 100644 gmp4/mpn/alpha/sub_n.asm create mode 100644 gmp4/mpn/alpha/submul_1.asm create mode 100644 gmp4/mpn/alpha/umul.asm create mode 100644 gmp4/mpn/alpha/unicos.m4 create mode 100644 gmp4/mpn/arm/README create mode 100644 gmp4/mpn/arm/aors_n.asm create mode 100644 gmp4/mpn/arm/aorslsh1_n.asm create mode 100644 gmp4/mpn/arm/aorsmul_1.asm create mode 100644 gmp4/mpn/arm/arm-defs.m4 create mode 100644 gmp4/mpn/arm/bdiv_dbm1c.asm create mode 100644 gmp4/mpn/arm/cnd_aors_n.asm create mode 100644 gmp4/mpn/arm/com.asm create mode 100644 gmp4/mpn/arm/copyd.asm create mode 100644 gmp4/mpn/arm/copyi.asm create mode 100644 gmp4/mpn/arm/dive_1.asm create mode 100644 gmp4/mpn/arm/gmp-mparam.h create mode 100644 gmp4/mpn/arm/invert_limb.asm create mode 100644 gmp4/mpn/arm/logops_n.asm create mode 100644 gmp4/mpn/arm/lshift.asm create mode 100644 gmp4/mpn/arm/lshiftc.asm create mode 100644 gmp4/mpn/arm/mod_34lsub1.asm create mode 100644 gmp4/mpn/arm/mode1o.asm create mode 100644 gmp4/mpn/arm/mul_1.asm create mode 100644 gmp4/mpn/arm/neon/README create mode 100644 gmp4/mpn/arm/neon/hamdist.asm create mode 100644 gmp4/mpn/arm/neon/lorrshift.asm create mode 100644 gmp4/mpn/arm/neon/lshiftc.asm create mode 100644 gmp4/mpn/arm/neon/popcount.asm create mode 100644 gmp4/mpn/arm/neon/sec_tabselect.asm create mode 100644 gmp4/mpn/arm/rsh1aors_n.asm create mode 100644 gmp4/mpn/arm/rshift.asm create mode 100644 gmp4/mpn/arm/sec_tabselect.asm create mode 100644 gmp4/mpn/arm/udiv.asm create mode 100644 gmp4/mpn/arm/v5/gcd_1.asm create mode 100644 gmp4/mpn/arm/v5/mod_1_1.asm create mode 100644 gmp4/mpn/arm/v5/mod_1_2.asm create mode 100644 gmp4/mpn/arm/v6/addmul_1.asm create mode 100644 gmp4/mpn/arm/v6/addmul_2.asm create mode 100644 gmp4/mpn/arm/v6/addmul_3.asm create mode 100644 gmp4/mpn/arm/v6/dive_1.asm create mode 100644 gmp4/mpn/arm/v6/gmp-mparam.h create mode 100644 gmp4/mpn/arm/v6/mode1o.asm create mode 100644 gmp4/mpn/arm/v6/mul_1.asm create mode 100644 gmp4/mpn/arm/v6/mul_2.asm create mode 100644 gmp4/mpn/arm/v6/popham.asm create mode 100644 gmp4/mpn/arm/v6/sqr_basecase.asm create mode 100644 gmp4/mpn/arm/v6/submul_1.asm create mode 100644 gmp4/mpn/arm/v6t2/divrem_1.asm create mode 100644 gmp4/mpn/arm/v6t2/gcd_1.asm create mode 100644 gmp4/mpn/arm/v7a/cora15/addmul_1.asm create mode 100644 gmp4/mpn/arm/v7a/cora15/aors_n.asm create mode 100644 gmp4/mpn/arm/v7a/cora15/cnd_aors_n.asm create mode 100644 gmp4/mpn/arm/v7a/cora15/com.asm create mode 100644 gmp4/mpn/arm/v7a/cora15/gmp-mparam.h create mode 100644 gmp4/mpn/arm/v7a/cora15/logops_n.asm create mode 100644 gmp4/mpn/arm/v7a/cora15/mul_1.asm create mode 100644 gmp4/mpn/arm/v7a/cora15/neon/aorsorrlsh1_n.asm create mode 100644 gmp4/mpn/arm/v7a/cora15/neon/aorsorrlsh2_n.asm create mode 100644 gmp4/mpn/arm/v7a/cora15/neon/aorsorrlshC_n.asm create mode 100644 gmp4/mpn/arm/v7a/cora15/neon/com.asm create mode 100644 gmp4/mpn/arm/v7a/cora15/neon/copyd.asm create mode 100644 gmp4/mpn/arm/v7a/cora15/neon/copyi.asm create mode 100644 gmp4/mpn/arm/v7a/cora15/neon/rsh1aors_n.asm create mode 100644 gmp4/mpn/arm/v7a/cora15/submul_1.asm create mode 100644 gmp4/mpn/arm/v7a/cora9/gmp-mparam.h create mode 100644 gmp4/mpn/arm64/aors_n.asm create mode 100644 gmp4/mpn/arm64/aorsmul_1.asm create mode 100644 gmp4/mpn/arm64/cnd_aors_n.asm create mode 100644 gmp4/mpn/arm64/copyd.asm create mode 100644 gmp4/mpn/arm64/copyi.asm create mode 100644 gmp4/mpn/arm64/gcd_1.asm create mode 100644 gmp4/mpn/arm64/invert_limb.asm create mode 100644 gmp4/mpn/arm64/logops_n.asm create mode 100644 gmp4/mpn/arm64/mul_1.asm create mode 100644 gmp4/mpn/asm-defs.m4 create mode 100755 gmp4/mpn/cpp-ccas create mode 100644 gmp4/mpn/cray/README create mode 100644 gmp4/mpn/cray/add_n.c create mode 100644 gmp4/mpn/cray/cfp/addmul_1.c create mode 100644 gmp4/mpn/cray/cfp/mul_1.c create mode 100644 gmp4/mpn/cray/cfp/mulwwc90.s create mode 100644 gmp4/mpn/cray/cfp/mulwwj90.s create mode 100644 gmp4/mpn/cray/cfp/submul_1.c create mode 100644 gmp4/mpn/cray/gmp-mparam.h create mode 100644 gmp4/mpn/cray/hamdist.c create mode 100644 gmp4/mpn/cray/ieee/addmul_1.c create mode 100644 gmp4/mpn/cray/ieee/gmp-mparam.h create mode 100644 gmp4/mpn/cray/ieee/invert_limb.c create mode 100644 gmp4/mpn/cray/ieee/mul_1.c create mode 100644 gmp4/mpn/cray/ieee/mul_basecase.c create mode 100644 gmp4/mpn/cray/ieee/sqr_basecase.c create mode 100644 gmp4/mpn/cray/ieee/submul_1.c create mode 100644 gmp4/mpn/cray/lshift.c create mode 100644 gmp4/mpn/cray/mulww.f create mode 100644 gmp4/mpn/cray/popcount.c create mode 100644 gmp4/mpn/cray/rshift.c create mode 100644 gmp4/mpn/cray/sub_n.c create mode 100644 gmp4/mpn/generic/add.c create mode 100644 gmp4/mpn/generic/add_1.c create mode 100644 gmp4/mpn/generic/add_err1_n.c create mode 100644 gmp4/mpn/generic/add_err2_n.c create mode 100644 gmp4/mpn/generic/add_err3_n.c create mode 100644 gmp4/mpn/generic/add_n.c create mode 100644 gmp4/mpn/generic/add_n_sub_n.c create mode 100644 gmp4/mpn/generic/addmul_1.c create mode 100644 gmp4/mpn/generic/bdiv_dbm1c.c create mode 100644 gmp4/mpn/generic/bdiv_q.c create mode 100644 gmp4/mpn/generic/bdiv_q_1.c create mode 100644 gmp4/mpn/generic/bdiv_qr.c create mode 100644 gmp4/mpn/generic/binvert.c create mode 100644 gmp4/mpn/generic/broot.c create mode 100644 gmp4/mpn/generic/brootinv.c create mode 100644 gmp4/mpn/generic/bsqrt.c create mode 100644 gmp4/mpn/generic/bsqrtinv.c create mode 100644 gmp4/mpn/generic/cmp.c create mode 100644 gmp4/mpn/generic/cnd_add_n.c create mode 100644 gmp4/mpn/generic/cnd_sub_n.c create mode 100644 gmp4/mpn/generic/com.c create mode 100644 gmp4/mpn/generic/comb_tables.c create mode 100644 gmp4/mpn/generic/copyd.c create mode 100644 gmp4/mpn/generic/copyi.c create mode 100644 gmp4/mpn/generic/dcpi1_bdiv_q.c create mode 100644 gmp4/mpn/generic/dcpi1_bdiv_qr.c create mode 100644 gmp4/mpn/generic/dcpi1_div_q.c create mode 100644 gmp4/mpn/generic/dcpi1_div_qr.c create mode 100644 gmp4/mpn/generic/dcpi1_divappr_q.c create mode 100644 gmp4/mpn/generic/div_q.c create mode 100644 gmp4/mpn/generic/div_qr_1.c create mode 100644 gmp4/mpn/generic/div_qr_1n_pi1.c create mode 100644 gmp4/mpn/generic/div_qr_1n_pi2.c create mode 100644 gmp4/mpn/generic/div_qr_1u_pi2.c create mode 100644 gmp4/mpn/generic/div_qr_2.c create mode 100644 gmp4/mpn/generic/div_qr_2n_pi1.c create mode 100644 gmp4/mpn/generic/div_qr_2u_pi1.c create mode 100644 gmp4/mpn/generic/dive_1.c create mode 100644 gmp4/mpn/generic/diveby3.c create mode 100644 gmp4/mpn/generic/divexact.c create mode 100644 gmp4/mpn/generic/divis.c create mode 100644 gmp4/mpn/generic/divrem.c create mode 100644 gmp4/mpn/generic/divrem_1.c create mode 100644 gmp4/mpn/generic/divrem_2.c create mode 100644 gmp4/mpn/generic/dump.c create mode 100644 gmp4/mpn/generic/fib2_ui.c create mode 100644 gmp4/mpn/generic/gcd.c create mode 100644 gmp4/mpn/generic/gcd_1.c create mode 100644 gmp4/mpn/generic/gcd_subdiv_step.c create mode 100644 gmp4/mpn/generic/gcdext.c create mode 100644 gmp4/mpn/generic/gcdext_1.c create mode 100644 gmp4/mpn/generic/gcdext_lehmer.c create mode 100644 gmp4/mpn/generic/get_d.c create mode 100644 gmp4/mpn/generic/get_str.c create mode 100644 gmp4/mpn/generic/gmp-mparam.h create mode 100644 gmp4/mpn/generic/hgcd.c create mode 100644 gmp4/mpn/generic/hgcd2.c create mode 100644 gmp4/mpn/generic/hgcd2_jacobi.c create mode 100644 gmp4/mpn/generic/hgcd_appr.c create mode 100644 gmp4/mpn/generic/hgcd_jacobi.c create mode 100644 gmp4/mpn/generic/hgcd_matrix.c create mode 100644 gmp4/mpn/generic/hgcd_reduce.c create mode 100644 gmp4/mpn/generic/hgcd_step.c create mode 100644 gmp4/mpn/generic/invert.c create mode 100644 gmp4/mpn/generic/invertappr.c create mode 100644 gmp4/mpn/generic/jacbase.c create mode 100644 gmp4/mpn/generic/jacobi.c create mode 100644 gmp4/mpn/generic/jacobi_2.c create mode 100644 gmp4/mpn/generic/logops_n.c create mode 100644 gmp4/mpn/generic/lshift.c create mode 100644 gmp4/mpn/generic/lshiftc.c create mode 100644 gmp4/mpn/generic/matrix22_mul.c create mode 100644 gmp4/mpn/generic/matrix22_mul1_inverse_vector.c create mode 100644 gmp4/mpn/generic/mod_1.c create mode 100644 gmp4/mpn/generic/mod_1_1.c create mode 100644 gmp4/mpn/generic/mod_1_2.c create mode 100644 gmp4/mpn/generic/mod_1_3.c create mode 100644 gmp4/mpn/generic/mod_1_4.c create mode 100644 gmp4/mpn/generic/mod_34lsub1.c create mode 100644 gmp4/mpn/generic/mode1o.c create mode 100644 gmp4/mpn/generic/mu_bdiv_q.c create mode 100644 gmp4/mpn/generic/mu_bdiv_qr.c create mode 100644 gmp4/mpn/generic/mu_div_q.c create mode 100644 gmp4/mpn/generic/mu_div_qr.c create mode 100644 gmp4/mpn/generic/mu_divappr_q.c create mode 100644 gmp4/mpn/generic/mul.c create mode 100644 gmp4/mpn/generic/mul_1.c create mode 100644 gmp4/mpn/generic/mul_basecase.c create mode 100644 gmp4/mpn/generic/mul_fft.c create mode 100644 gmp4/mpn/generic/mul_n.c create mode 100644 gmp4/mpn/generic/mullo_basecase.c create mode 100644 gmp4/mpn/generic/mullo_n.c create mode 100644 gmp4/mpn/generic/mulmid.c create mode 100644 gmp4/mpn/generic/mulmid_basecase.c create mode 100644 gmp4/mpn/generic/mulmid_n.c create mode 100644 gmp4/mpn/generic/mulmod_bnm1.c create mode 100644 gmp4/mpn/generic/neg.c create mode 100644 gmp4/mpn/generic/nussbaumer_mul.c create mode 100644 gmp4/mpn/generic/perfpow.c create mode 100644 gmp4/mpn/generic/perfsqr.c create mode 100644 gmp4/mpn/generic/popham.c create mode 100644 gmp4/mpn/generic/pow_1.c create mode 100644 gmp4/mpn/generic/powlo.c create mode 100644 gmp4/mpn/generic/powm.c create mode 100644 gmp4/mpn/generic/pre_divrem_1.c create mode 100644 gmp4/mpn/generic/pre_mod_1.c create mode 100644 gmp4/mpn/generic/random.c create mode 100644 gmp4/mpn/generic/random2.c create mode 100644 gmp4/mpn/generic/redc_1.c create mode 100644 gmp4/mpn/generic/redc_2.c create mode 100644 gmp4/mpn/generic/redc_n.c create mode 100644 gmp4/mpn/generic/remove.c create mode 100644 gmp4/mpn/generic/rootrem.c create mode 100644 gmp4/mpn/generic/rshift.c create mode 100644 gmp4/mpn/generic/sbpi1_bdiv_q.c create mode 100644 gmp4/mpn/generic/sbpi1_bdiv_qr.c create mode 100644 gmp4/mpn/generic/sbpi1_div_q.c create mode 100644 gmp4/mpn/generic/sbpi1_div_qr.c create mode 100644 gmp4/mpn/generic/sbpi1_divappr_q.c create mode 100644 gmp4/mpn/generic/scan0.c create mode 100644 gmp4/mpn/generic/scan1.c create mode 100644 gmp4/mpn/generic/sec_aors_1.c create mode 100644 gmp4/mpn/generic/sec_div.c create mode 100644 gmp4/mpn/generic/sec_invert.c create mode 100644 gmp4/mpn/generic/sec_mul.c create mode 100644 gmp4/mpn/generic/sec_pi1_div.c create mode 100644 gmp4/mpn/generic/sec_powm.c create mode 100644 gmp4/mpn/generic/sec_sqr.c create mode 100644 gmp4/mpn/generic/sec_tabselect.c create mode 100644 gmp4/mpn/generic/set_str.c create mode 100644 gmp4/mpn/generic/sizeinbase.c create mode 100644 gmp4/mpn/generic/sqr.c create mode 100644 gmp4/mpn/generic/sqr_basecase.c create mode 100644 gmp4/mpn/generic/sqrmod_bnm1.c create mode 100644 gmp4/mpn/generic/sqrtrem.c create mode 100644 gmp4/mpn/generic/sub.c create mode 100644 gmp4/mpn/generic/sub_1.c create mode 100644 gmp4/mpn/generic/sub_err1_n.c create mode 100644 gmp4/mpn/generic/sub_err2_n.c create mode 100644 gmp4/mpn/generic/sub_err3_n.c create mode 100644 gmp4/mpn/generic/sub_n.c create mode 100644 gmp4/mpn/generic/submul_1.c create mode 100644 gmp4/mpn/generic/tdiv_qr.c create mode 100644 gmp4/mpn/generic/toom22_mul.c create mode 100644 gmp4/mpn/generic/toom2_sqr.c create mode 100644 gmp4/mpn/generic/toom32_mul.c create mode 100644 gmp4/mpn/generic/toom33_mul.c create mode 100644 gmp4/mpn/generic/toom3_sqr.c create mode 100644 gmp4/mpn/generic/toom42_mul.c create mode 100644 gmp4/mpn/generic/toom42_mulmid.c create mode 100644 gmp4/mpn/generic/toom43_mul.c create mode 100644 gmp4/mpn/generic/toom44_mul.c create mode 100644 gmp4/mpn/generic/toom4_sqr.c create mode 100644 gmp4/mpn/generic/toom52_mul.c create mode 100644 gmp4/mpn/generic/toom53_mul.c create mode 100644 gmp4/mpn/generic/toom54_mul.c create mode 100644 gmp4/mpn/generic/toom62_mul.c create mode 100644 gmp4/mpn/generic/toom63_mul.c create mode 100644 gmp4/mpn/generic/toom6_sqr.c create mode 100644 gmp4/mpn/generic/toom6h_mul.c create mode 100644 gmp4/mpn/generic/toom8_sqr.c create mode 100644 gmp4/mpn/generic/toom8h_mul.c create mode 100644 gmp4/mpn/generic/toom_couple_handling.c create mode 100644 gmp4/mpn/generic/toom_eval_dgr3_pm1.c create mode 100644 gmp4/mpn/generic/toom_eval_dgr3_pm2.c create mode 100644 gmp4/mpn/generic/toom_eval_pm1.c create mode 100644 gmp4/mpn/generic/toom_eval_pm2.c create mode 100644 gmp4/mpn/generic/toom_eval_pm2exp.c create mode 100644 gmp4/mpn/generic/toom_eval_pm2rexp.c create mode 100644 gmp4/mpn/generic/toom_interpolate_12pts.c create mode 100644 gmp4/mpn/generic/toom_interpolate_16pts.c create mode 100644 gmp4/mpn/generic/toom_interpolate_5pts.c create mode 100644 gmp4/mpn/generic/toom_interpolate_6pts.c create mode 100644 gmp4/mpn/generic/toom_interpolate_7pts.c create mode 100644 gmp4/mpn/generic/toom_interpolate_8pts.c create mode 100644 gmp4/mpn/generic/trialdiv.c create mode 100644 gmp4/mpn/generic/udiv_w_sdiv.c create mode 100644 gmp4/mpn/generic/zero.c create mode 100644 gmp4/mpn/ia64/README create mode 100644 gmp4/mpn/ia64/add_n_sub_n.asm create mode 100644 gmp4/mpn/ia64/addmul_1.asm create mode 100644 gmp4/mpn/ia64/addmul_2.asm create mode 100644 gmp4/mpn/ia64/aors_n.asm create mode 100644 gmp4/mpn/ia64/aorsorrlsh1_n.asm create mode 100644 gmp4/mpn/ia64/aorsorrlsh2_n.asm create mode 100644 gmp4/mpn/ia64/aorsorrlshC_n.asm create mode 100644 gmp4/mpn/ia64/bdiv_dbm1c.asm create mode 100644 gmp4/mpn/ia64/cnd_aors_n.asm create mode 100644 gmp4/mpn/ia64/copyd.asm create mode 100644 gmp4/mpn/ia64/copyi.asm create mode 100644 gmp4/mpn/ia64/dive_1.asm create mode 100644 gmp4/mpn/ia64/divrem_1.asm create mode 100644 gmp4/mpn/ia64/divrem_2.asm create mode 100644 gmp4/mpn/ia64/gcd_1.asm create mode 100644 gmp4/mpn/ia64/gmp-mparam.h create mode 100644 gmp4/mpn/ia64/hamdist.asm create mode 100644 gmp4/mpn/ia64/ia64-defs.m4 create mode 100644 gmp4/mpn/ia64/invert_limb.asm create mode 100644 gmp4/mpn/ia64/logops_n.asm create mode 100644 gmp4/mpn/ia64/lorrshift.asm create mode 100644 gmp4/mpn/ia64/lshiftc.asm create mode 100644 gmp4/mpn/ia64/mod_34lsub1.asm create mode 100644 gmp4/mpn/ia64/mode1o.asm create mode 100644 gmp4/mpn/ia64/mul_1.asm create mode 100644 gmp4/mpn/ia64/mul_2.asm create mode 100644 gmp4/mpn/ia64/popcount.asm create mode 100644 gmp4/mpn/ia64/rsh1aors_n.asm create mode 100644 gmp4/mpn/ia64/sec_tabselect.asm create mode 100644 gmp4/mpn/ia64/sqr_diag_addlsh1.asm create mode 100644 gmp4/mpn/ia64/submul_1.asm create mode 100644 gmp4/mpn/lisp/gmpasm-mode.el create mode 100755 gmp4/mpn/m4-ccas create mode 100644 gmp4/mpn/m68k/README create mode 100644 gmp4/mpn/m68k/aors_n.asm create mode 100644 gmp4/mpn/m68k/gmp-mparam.h create mode 100644 gmp4/mpn/m68k/lshift.asm create mode 100644 gmp4/mpn/m68k/m68k-defs.m4 create mode 100644 gmp4/mpn/m68k/mc68020/aorsmul_1.asm create mode 100644 gmp4/mpn/m68k/mc68020/mul_1.asm create mode 100644 gmp4/mpn/m68k/mc68020/udiv.asm create mode 100644 gmp4/mpn/m68k/mc68020/umul.asm create mode 100644 gmp4/mpn/m68k/rshift.asm create mode 100644 gmp4/mpn/m68k/t-m68k-defs.pl create mode 100644 gmp4/mpn/m88k/README create mode 100644 gmp4/mpn/m88k/add_n.s create mode 100644 gmp4/mpn/m88k/mc88110/add_n.S create mode 100644 gmp4/mpn/m88k/mc88110/addmul_1.s create mode 100644 gmp4/mpn/m88k/mc88110/mul_1.s create mode 100644 gmp4/mpn/m88k/mc88110/sub_n.S create mode 100644 gmp4/mpn/m88k/mul_1.s create mode 100644 gmp4/mpn/m88k/sub_n.s create mode 100644 gmp4/mpn/minithres/gmp-mparam.h create mode 100644 gmp4/mpn/mips32/add_n.asm create mode 100644 gmp4/mpn/mips32/addmul_1.asm create mode 100644 gmp4/mpn/mips32/gmp-mparam.h create mode 100644 gmp4/mpn/mips32/lshift.asm create mode 100644 gmp4/mpn/mips32/mips-defs.m4 create mode 100644 gmp4/mpn/mips32/mips.m4 create mode 100644 gmp4/mpn/mips32/mul_1.asm create mode 100644 gmp4/mpn/mips32/rshift.asm create mode 100644 gmp4/mpn/mips32/sub_n.asm create mode 100644 gmp4/mpn/mips32/submul_1.asm create mode 100644 gmp4/mpn/mips32/umul.asm create mode 100644 gmp4/mpn/mips64/README create mode 100644 gmp4/mpn/mips64/add_n.asm create mode 100644 gmp4/mpn/mips64/addmul_1.asm create mode 100644 gmp4/mpn/mips64/gmp-mparam.h create mode 100644 gmp4/mpn/mips64/lshift.asm create mode 100644 gmp4/mpn/mips64/mul_1.asm create mode 100644 gmp4/mpn/mips64/rshift.asm create mode 100644 gmp4/mpn/mips64/sqr_diagonal.asm create mode 100644 gmp4/mpn/mips64/sub_n.asm create mode 100644 gmp4/mpn/mips64/submul_1.asm create mode 100644 gmp4/mpn/mips64/umul.asm create mode 100644 gmp4/mpn/pa32/README create mode 100644 gmp4/mpn/pa32/add_n.asm create mode 100644 gmp4/mpn/pa32/gmp-mparam.h create mode 100644 gmp4/mpn/pa32/hppa1_1/addmul_1.asm create mode 100644 gmp4/mpn/pa32/hppa1_1/gmp-mparam.h create mode 100644 gmp4/mpn/pa32/hppa1_1/mul_1.asm create mode 100644 gmp4/mpn/pa32/hppa1_1/pa7100/add_n.asm create mode 100644 gmp4/mpn/pa32/hppa1_1/pa7100/addmul_1.asm create mode 100644 gmp4/mpn/pa32/hppa1_1/pa7100/lshift.asm create mode 100644 gmp4/mpn/pa32/hppa1_1/pa7100/rshift.asm create mode 100644 gmp4/mpn/pa32/hppa1_1/pa7100/sub_n.asm create mode 100644 gmp4/mpn/pa32/hppa1_1/pa7100/submul_1.asm create mode 100644 gmp4/mpn/pa32/hppa1_1/sqr_diagonal.asm create mode 100644 gmp4/mpn/pa32/hppa1_1/submul_1.asm create mode 100644 gmp4/mpn/pa32/hppa1_1/udiv.asm create mode 100644 gmp4/mpn/pa32/hppa1_1/umul.asm create mode 100644 gmp4/mpn/pa32/hppa2_0/add_n.asm create mode 100644 gmp4/mpn/pa32/hppa2_0/gmp-mparam.h create mode 100644 gmp4/mpn/pa32/hppa2_0/sqr_diagonal.asm create mode 100644 gmp4/mpn/pa32/hppa2_0/sub_n.asm create mode 100644 gmp4/mpn/pa32/lshift.asm create mode 100644 gmp4/mpn/pa32/pa-defs.m4 create mode 100644 gmp4/mpn/pa32/rshift.asm create mode 100644 gmp4/mpn/pa32/sub_n.asm create mode 100644 gmp4/mpn/pa32/udiv.asm create mode 100644 gmp4/mpn/pa64/README create mode 100644 gmp4/mpn/pa64/addmul_1.asm create mode 100644 gmp4/mpn/pa64/aors_n.asm create mode 100644 gmp4/mpn/pa64/aorslsh1_n.asm create mode 100644 gmp4/mpn/pa64/gmp-mparam.h create mode 100644 gmp4/mpn/pa64/lshift.asm create mode 100644 gmp4/mpn/pa64/mul_1.asm create mode 100644 gmp4/mpn/pa64/rshift.asm create mode 100644 gmp4/mpn/pa64/sqr_diagonal.asm create mode 100644 gmp4/mpn/pa64/submul_1.asm create mode 100644 gmp4/mpn/pa64/udiv.asm create mode 100644 gmp4/mpn/pa64/umul.asm create mode 100644 gmp4/mpn/power/add_n.asm create mode 100644 gmp4/mpn/power/addmul_1.asm create mode 100644 gmp4/mpn/power/gmp-mparam.h create mode 100644 gmp4/mpn/power/lshift.asm create mode 100644 gmp4/mpn/power/mul_1.asm create mode 100644 gmp4/mpn/power/rshift.asm create mode 100644 gmp4/mpn/power/sdiv.asm create mode 100644 gmp4/mpn/power/sub_n.asm create mode 100644 gmp4/mpn/power/submul_1.asm create mode 100644 gmp4/mpn/power/umul.asm create mode 100644 gmp4/mpn/powerpc32/750/com.asm create mode 100644 gmp4/mpn/powerpc32/750/gmp-mparam.h create mode 100644 gmp4/mpn/powerpc32/750/lshift.asm create mode 100644 gmp4/mpn/powerpc32/750/rshift.asm create mode 100644 gmp4/mpn/powerpc32/README create mode 100644 gmp4/mpn/powerpc32/addlsh1_n.asm create mode 100644 gmp4/mpn/powerpc32/addmul_1.asm create mode 100644 gmp4/mpn/powerpc32/aix.m4 create mode 100644 gmp4/mpn/powerpc32/aors_n.asm create mode 100644 gmp4/mpn/powerpc32/bdiv_dbm1c.asm create mode 100644 gmp4/mpn/powerpc32/darwin.m4 create mode 100644 gmp4/mpn/powerpc32/diveby3.asm create mode 100644 gmp4/mpn/powerpc32/divrem_2.asm create mode 100644 gmp4/mpn/powerpc32/eabi.m4 create mode 100644 gmp4/mpn/powerpc32/elf.m4 create mode 100644 gmp4/mpn/powerpc32/gmp-mparam.h create mode 100644 gmp4/mpn/powerpc32/invert_limb.asm create mode 100644 gmp4/mpn/powerpc32/lshift.asm create mode 100644 gmp4/mpn/powerpc32/lshiftc.asm create mode 100644 gmp4/mpn/powerpc32/mod_34lsub1.asm create mode 100644 gmp4/mpn/powerpc32/mode1o.asm create mode 100644 gmp4/mpn/powerpc32/mul_1.asm create mode 100644 gmp4/mpn/powerpc32/p3-p7/aors_n.asm create mode 100644 gmp4/mpn/powerpc32/p3/gmp-mparam.h create mode 100644 gmp4/mpn/powerpc32/p4/gmp-mparam.h create mode 100644 gmp4/mpn/powerpc32/p5/gmp-mparam.h create mode 100644 gmp4/mpn/powerpc32/p6/gmp-mparam.h create mode 100644 gmp4/mpn/powerpc32/p7/gmp-mparam.h create mode 100644 gmp4/mpn/powerpc32/powerpc-defs.m4 create mode 100644 gmp4/mpn/powerpc32/rshift.asm create mode 100644 gmp4/mpn/powerpc32/sec_tabselect.asm create mode 100644 gmp4/mpn/powerpc32/sqr_diag_addlsh1.asm create mode 100644 gmp4/mpn/powerpc32/sublsh1_n.asm create mode 100644 gmp4/mpn/powerpc32/submul_1.asm create mode 100644 gmp4/mpn/powerpc32/umul.asm create mode 100644 gmp4/mpn/powerpc32/vmx/copyd.asm create mode 100644 gmp4/mpn/powerpc32/vmx/copyi.asm create mode 100644 gmp4/mpn/powerpc32/vmx/logops_n.asm create mode 100644 gmp4/mpn/powerpc32/vmx/mod_34lsub1.asm create mode 100644 gmp4/mpn/powerpc32/vmx/popcount.asm create mode 100644 gmp4/mpn/powerpc64/README create mode 100644 gmp4/mpn/powerpc64/aix.m4 create mode 100644 gmp4/mpn/powerpc64/com.asm create mode 100644 gmp4/mpn/powerpc64/copyd.asm create mode 100644 gmp4/mpn/powerpc64/copyi.asm create mode 100644 gmp4/mpn/powerpc64/darwin.m4 create mode 100644 gmp4/mpn/powerpc64/elf.m4 create mode 100644 gmp4/mpn/powerpc64/logops_n.asm create mode 100644 gmp4/mpn/powerpc64/lshift.asm create mode 100644 gmp4/mpn/powerpc64/lshiftc.asm create mode 100644 gmp4/mpn/powerpc64/mode32/add_n.asm create mode 100644 gmp4/mpn/powerpc64/mode32/addmul_1.asm create mode 100644 gmp4/mpn/powerpc64/mode32/mul_1.asm create mode 100644 gmp4/mpn/powerpc64/mode32/p4/gmp-mparam.h create mode 100644 gmp4/mpn/powerpc64/mode32/sqr_diagonal.asm create mode 100644 gmp4/mpn/powerpc64/mode32/sub_n.asm create mode 100644 gmp4/mpn/powerpc64/mode32/submul_1.asm create mode 100644 gmp4/mpn/powerpc64/mode64/aors_n.asm create mode 100644 gmp4/mpn/powerpc64/mode64/aorsmul_1.asm create mode 100644 gmp4/mpn/powerpc64/mode64/aorsorrlsh1_n.asm create mode 100644 gmp4/mpn/powerpc64/mode64/aorsorrlsh2_n.asm create mode 100644 gmp4/mpn/powerpc64/mode64/aorsorrlshC_n.asm create mode 100644 gmp4/mpn/powerpc64/mode64/bdiv_dbm1c.asm create mode 100644 gmp4/mpn/powerpc64/mode64/cnd_aors_n.asm create mode 100644 gmp4/mpn/powerpc64/mode64/dive_1.asm create mode 100644 gmp4/mpn/powerpc64/mode64/divrem_1.asm create mode 100644 gmp4/mpn/powerpc64/mode64/divrem_2.asm create mode 100644 gmp4/mpn/powerpc64/mode64/gcd_1.asm create mode 100644 gmp4/mpn/powerpc64/mode64/gmp-mparam.h create mode 100644 gmp4/mpn/powerpc64/mode64/invert_limb.asm create mode 100644 gmp4/mpn/powerpc64/mode64/mod_1_1.asm create mode 100644 gmp4/mpn/powerpc64/mode64/mod_1_4.asm create mode 100644 gmp4/mpn/powerpc64/mode64/mod_34lsub1.asm create mode 100644 gmp4/mpn/powerpc64/mode64/mode1o.asm create mode 100644 gmp4/mpn/powerpc64/mode64/mul_1.asm create mode 100644 gmp4/mpn/powerpc64/mode64/mul_basecase.asm create mode 100644 gmp4/mpn/powerpc64/mode64/p3/gmp-mparam.h create mode 100644 gmp4/mpn/powerpc64/mode64/p4/gmp-mparam.h create mode 100644 gmp4/mpn/powerpc64/mode64/p5/gmp-mparam.h create mode 100644 gmp4/mpn/powerpc64/mode64/p6/aorsmul_1.asm create mode 100644 gmp4/mpn/powerpc64/mode64/p6/gmp-mparam.h create mode 100644 gmp4/mpn/powerpc64/mode64/p6/mul_basecase.asm create mode 100644 gmp4/mpn/powerpc64/mode64/p7/aormul_2.asm create mode 100644 gmp4/mpn/powerpc64/mode64/p7/aors_n.asm create mode 100644 gmp4/mpn/powerpc64/mode64/p7/aorsorrlsh1_n.asm create mode 100644 gmp4/mpn/powerpc64/mode64/p7/aorsorrlsh2_n.asm create mode 100644 gmp4/mpn/powerpc64/mode64/p7/aorsorrlshC_n.asm create mode 100644 gmp4/mpn/powerpc64/mode64/p7/gcd_1.asm create mode 100644 gmp4/mpn/powerpc64/mode64/p7/gmp-mparam.h create mode 100644 gmp4/mpn/powerpc64/mode64/rsh1aors_n.asm create mode 100644 gmp4/mpn/powerpc64/mode64/sqr_basecase.asm create mode 100644 gmp4/mpn/powerpc64/p6/lshift.asm create mode 100644 gmp4/mpn/powerpc64/p6/lshiftc.asm create mode 100644 gmp4/mpn/powerpc64/p6/rshift.asm create mode 100644 gmp4/mpn/powerpc64/p7/copyd.asm create mode 100644 gmp4/mpn/powerpc64/p7/copyi.asm create mode 100644 gmp4/mpn/powerpc64/p7/hamdist.asm create mode 100644 gmp4/mpn/powerpc64/p7/popcount.asm create mode 100644 gmp4/mpn/powerpc64/rshift.asm create mode 100644 gmp4/mpn/powerpc64/sec_tabselect.asm create mode 100644 gmp4/mpn/powerpc64/umul.asm create mode 100644 gmp4/mpn/powerpc64/vmx/popcount.asm create mode 100644 gmp4/mpn/s390_32/README create mode 100644 gmp4/mpn/s390_32/addmul_1.asm create mode 100644 gmp4/mpn/s390_32/copyd.asm create mode 100644 gmp4/mpn/s390_32/copyi.asm create mode 100644 gmp4/mpn/s390_32/esame/addmul_1.asm create mode 100644 gmp4/mpn/s390_32/esame/aors_n.asm create mode 100644 gmp4/mpn/s390_32/esame/aorslsh1_n.asm create mode 100644 gmp4/mpn/s390_32/esame/bdiv_dbm1c.asm create mode 100644 gmp4/mpn/s390_32/esame/gmp-mparam.h create mode 100644 gmp4/mpn/s390_32/esame/mul_1.asm create mode 100644 gmp4/mpn/s390_32/esame/mul_basecase.asm create mode 100644 gmp4/mpn/s390_32/esame/sqr_basecase.asm create mode 100644 gmp4/mpn/s390_32/esame/submul_1.asm create mode 100644 gmp4/mpn/s390_32/gmp-mparam.h create mode 100644 gmp4/mpn/s390_32/logops_n.asm create mode 100644 gmp4/mpn/s390_32/lshift.asm create mode 100644 gmp4/mpn/s390_32/lshiftc.asm create mode 100644 gmp4/mpn/s390_32/mul_1.asm create mode 100644 gmp4/mpn/s390_32/rshift.asm create mode 100644 gmp4/mpn/s390_32/submul_1.asm create mode 100644 gmp4/mpn/s390_64/README create mode 100644 gmp4/mpn/s390_64/addmul_1.asm create mode 100644 gmp4/mpn/s390_64/aorrlsh1_n.asm create mode 100644 gmp4/mpn/s390_64/aors_n.asm create mode 100644 gmp4/mpn/s390_64/bdiv_dbm1c.asm create mode 100644 gmp4/mpn/s390_64/copyd.asm create mode 100644 gmp4/mpn/s390_64/copyi.asm create mode 100644 gmp4/mpn/s390_64/gmp-mparam.h create mode 100644 gmp4/mpn/s390_64/invert_limb.asm create mode 100644 gmp4/mpn/s390_64/logops_n.asm create mode 100644 gmp4/mpn/s390_64/lshift.asm create mode 100644 gmp4/mpn/s390_64/lshiftc.asm create mode 100644 gmp4/mpn/s390_64/mod_34lsub1.asm create mode 100644 gmp4/mpn/s390_64/mul_1.asm create mode 100644 gmp4/mpn/s390_64/mul_basecase.asm create mode 100644 gmp4/mpn/s390_64/rshift.asm create mode 100644 gmp4/mpn/s390_64/sqr_basecase.asm create mode 100644 gmp4/mpn/s390_64/sublsh1_n.asm create mode 100644 gmp4/mpn/s390_64/submul_1.asm create mode 100644 gmp4/mpn/s390_64/z10/gmp-mparam.h create mode 100644 gmp4/mpn/sh/add_n.asm create mode 100644 gmp4/mpn/sh/sh2/addmul_1.asm create mode 100644 gmp4/mpn/sh/sh2/mul_1.asm create mode 100644 gmp4/mpn/sh/sh2/submul_1.asm create mode 100644 gmp4/mpn/sh/sub_n.asm create mode 100644 gmp4/mpn/sparc32/README create mode 100644 gmp4/mpn/sparc32/add_n.asm create mode 100644 gmp4/mpn/sparc32/addmul_1.asm create mode 100644 gmp4/mpn/sparc32/gmp-mparam.h create mode 100644 gmp4/mpn/sparc32/lshift.asm create mode 100644 gmp4/mpn/sparc32/mul_1.asm create mode 100644 gmp4/mpn/sparc32/rshift.asm create mode 100644 gmp4/mpn/sparc32/sparc-defs.m4 create mode 100644 gmp4/mpn/sparc32/sub_n.asm create mode 100644 gmp4/mpn/sparc32/submul_1.asm create mode 100644 gmp4/mpn/sparc32/udiv.asm create mode 100644 gmp4/mpn/sparc32/udiv_nfp.asm create mode 100644 gmp4/mpn/sparc32/ultrasparct1/add_n.asm create mode 100644 gmp4/mpn/sparc32/ultrasparct1/addmul_1.asm create mode 100644 gmp4/mpn/sparc32/ultrasparct1/gmp-mparam.h create mode 100644 gmp4/mpn/sparc32/ultrasparct1/mul_1.asm create mode 100644 gmp4/mpn/sparc32/ultrasparct1/sqr_diagonal.asm create mode 100644 gmp4/mpn/sparc32/ultrasparct1/sub_n.asm create mode 100644 gmp4/mpn/sparc32/ultrasparct1/submul_1.asm create mode 100644 gmp4/mpn/sparc32/umul.asm create mode 100644 gmp4/mpn/sparc32/v8/addmul_1.asm create mode 100644 gmp4/mpn/sparc32/v8/gmp-mparam.h create mode 100644 gmp4/mpn/sparc32/v8/mul_1.asm create mode 100644 gmp4/mpn/sparc32/v8/submul_1.asm create mode 100644 gmp4/mpn/sparc32/v8/supersparc/gmp-mparam.h create mode 100644 gmp4/mpn/sparc32/v8/supersparc/udiv.asm create mode 100644 gmp4/mpn/sparc32/v8/udiv.asm create mode 100644 gmp4/mpn/sparc32/v8/umul.asm create mode 100644 gmp4/mpn/sparc32/v9/README create mode 100644 gmp4/mpn/sparc32/v9/add_n.asm create mode 100644 gmp4/mpn/sparc32/v9/addmul_1.asm create mode 100644 gmp4/mpn/sparc32/v9/gmp-mparam.h create mode 100644 gmp4/mpn/sparc32/v9/mul_1.asm create mode 100644 gmp4/mpn/sparc32/v9/sqr_diagonal.asm create mode 100644 gmp4/mpn/sparc32/v9/sub_n.asm create mode 100644 gmp4/mpn/sparc32/v9/submul_1.asm create mode 100644 gmp4/mpn/sparc32/v9/udiv.asm create mode 100644 gmp4/mpn/sparc64/README create mode 100644 gmp4/mpn/sparc64/copyd.asm create mode 100644 gmp4/mpn/sparc64/copyi.asm create mode 100644 gmp4/mpn/sparc64/dive_1.c create mode 100644 gmp4/mpn/sparc64/divrem_1.c create mode 100644 gmp4/mpn/sparc64/gcd_1.asm create mode 100644 gmp4/mpn/sparc64/gmp-mparam.h create mode 100644 gmp4/mpn/sparc64/lshift.asm create mode 100644 gmp4/mpn/sparc64/lshiftc.asm create mode 100644 gmp4/mpn/sparc64/mod_1.c create mode 100644 gmp4/mpn/sparc64/mod_1_4.c create mode 100644 gmp4/mpn/sparc64/mode1o.c create mode 100644 gmp4/mpn/sparc64/rshift.asm create mode 100644 gmp4/mpn/sparc64/sec_tabselect.asm create mode 100644 gmp4/mpn/sparc64/sparc64.h create mode 100644 gmp4/mpn/sparc64/ultrasparc1234/add_n.asm create mode 100644 gmp4/mpn/sparc64/ultrasparc1234/addmul_1.asm create mode 100644 gmp4/mpn/sparc64/ultrasparc1234/addmul_2.asm create mode 100644 gmp4/mpn/sparc64/ultrasparc1234/lshiftc.asm create mode 100644 gmp4/mpn/sparc64/ultrasparc1234/mul_1.asm create mode 100644 gmp4/mpn/sparc64/ultrasparc1234/sqr_diagonal.asm create mode 100644 gmp4/mpn/sparc64/ultrasparc1234/sub_n.asm create mode 100644 gmp4/mpn/sparc64/ultrasparc1234/submul_1.asm create mode 100644 gmp4/mpn/sparc64/ultrasparc34/gmp-mparam.h create mode 100644 gmp4/mpn/sparc64/ultrasparct1/add_n.asm create mode 100644 gmp4/mpn/sparc64/ultrasparct1/addlsh1_n.asm create mode 100644 gmp4/mpn/sparc64/ultrasparct1/addlsh2_n.asm create mode 100644 gmp4/mpn/sparc64/ultrasparct1/addlshC_n.asm create mode 100644 gmp4/mpn/sparc64/ultrasparct1/addmul_1.asm create mode 100644 gmp4/mpn/sparc64/ultrasparct1/gmp-mparam.h create mode 100644 gmp4/mpn/sparc64/ultrasparct1/mul_1.asm create mode 100644 gmp4/mpn/sparc64/ultrasparct1/rsblsh1_n.asm create mode 100644 gmp4/mpn/sparc64/ultrasparct1/rsblsh2_n.asm create mode 100644 gmp4/mpn/sparc64/ultrasparct1/rsblshC_n.asm create mode 100644 gmp4/mpn/sparc64/ultrasparct1/sub_n.asm create mode 100644 gmp4/mpn/sparc64/ultrasparct1/sublsh1_n.asm create mode 100644 gmp4/mpn/sparc64/ultrasparct1/sublsh2_n.asm create mode 100644 gmp4/mpn/sparc64/ultrasparct1/sublshC_n.asm create mode 100644 gmp4/mpn/sparc64/ultrasparct1/submul_1.asm create mode 100644 gmp4/mpn/sparc64/ultrasparct3/add_n.asm create mode 100644 gmp4/mpn/sparc64/ultrasparct3/addmul_1.asm create mode 100644 gmp4/mpn/sparc64/ultrasparct3/aormul_2.asm create mode 100644 gmp4/mpn/sparc64/ultrasparct3/aormul_4.asm create mode 100644 gmp4/mpn/sparc64/ultrasparct3/aorslsh_n.asm create mode 100644 gmp4/mpn/sparc64/ultrasparct3/bdiv_dbm1c.asm create mode 100644 gmp4/mpn/sparc64/ultrasparct3/cnd_aors_n.asm create mode 100644 gmp4/mpn/sparc64/ultrasparct3/dive_1.asm create mode 100644 gmp4/mpn/sparc64/ultrasparct3/hamdist.asm create mode 100644 gmp4/mpn/sparc64/ultrasparct3/invert_limb.asm create mode 100644 gmp4/mpn/sparc64/ultrasparct3/missing.asm create mode 100644 gmp4/mpn/sparc64/ultrasparct3/missing.m4 create mode 100644 gmp4/mpn/sparc64/ultrasparct3/mod_1_4.asm create mode 100644 gmp4/mpn/sparc64/ultrasparct3/mod_34lsub1.asm create mode 100644 gmp4/mpn/sparc64/ultrasparct3/mode1o.asm create mode 100644 gmp4/mpn/sparc64/ultrasparct3/mul_1.asm create mode 100644 gmp4/mpn/sparc64/ultrasparct3/popcount.asm create mode 100644 gmp4/mpn/sparc64/ultrasparct3/sqr_diag_addlsh1.asm create mode 100644 gmp4/mpn/sparc64/ultrasparct3/sub_n.asm create mode 100644 gmp4/mpn/sparc64/ultrasparct3/submul_1.asm create mode 100644 gmp4/mpn/thumb/add_n.asm create mode 100644 gmp4/mpn/thumb/sub_n.asm create mode 100644 gmp4/mpn/vax/add_n.asm create mode 100644 gmp4/mpn/vax/addmul_1.asm create mode 100644 gmp4/mpn/vax/elf.m4 create mode 100644 gmp4/mpn/vax/gmp-mparam.h create mode 100644 gmp4/mpn/vax/lshift.asm create mode 100644 gmp4/mpn/vax/mul_1.asm create mode 100644 gmp4/mpn/vax/rshift.asm create mode 100644 gmp4/mpn/vax/sub_n.asm create mode 100644 gmp4/mpn/vax/submul_1.asm create mode 100644 gmp4/mpn/x86/README create mode 100644 gmp4/mpn/x86/aors_n.asm create mode 100644 gmp4/mpn/x86/aorsmul_1.asm create mode 100644 gmp4/mpn/x86/atom/aorrlsh1_n.asm create mode 100644 gmp4/mpn/x86/atom/aorrlsh2_n.asm create mode 100644 gmp4/mpn/x86/atom/aorrlshC_n.asm create mode 100644 gmp4/mpn/x86/atom/aors_n.asm create mode 100644 gmp4/mpn/x86/atom/aorslshC_n.asm create mode 100644 gmp4/mpn/x86/atom/bdiv_q_1.asm create mode 100644 gmp4/mpn/x86/atom/cnd_add_n.asm create mode 100644 gmp4/mpn/x86/atom/cnd_sub_n.asm create mode 100644 gmp4/mpn/x86/atom/dive_1.asm create mode 100644 gmp4/mpn/x86/atom/gmp-mparam.h create mode 100644 gmp4/mpn/x86/atom/logops_n.asm create mode 100644 gmp4/mpn/x86/atom/lshift.asm create mode 100644 gmp4/mpn/x86/atom/lshiftc.asm create mode 100644 gmp4/mpn/x86/atom/mmx/copyd.asm create mode 100644 gmp4/mpn/x86/atom/mmx/copyi.asm create mode 100644 gmp4/mpn/x86/atom/mmx/hamdist.asm create mode 100644 gmp4/mpn/x86/atom/mod_34lsub1.asm create mode 100644 gmp4/mpn/x86/atom/mode1o.asm create mode 100644 gmp4/mpn/x86/atom/rshift.asm create mode 100644 gmp4/mpn/x86/atom/sse2/aorsmul_1.asm create mode 100644 gmp4/mpn/x86/atom/sse2/bdiv_dbm1c.asm create mode 100644 gmp4/mpn/x86/atom/sse2/divrem_1.asm create mode 100644 gmp4/mpn/x86/atom/sse2/mod_1_1.asm create mode 100644 gmp4/mpn/x86/atom/sse2/mod_1_4.asm create mode 100644 gmp4/mpn/x86/atom/sse2/mul_1.asm create mode 100644 gmp4/mpn/x86/atom/sse2/mul_basecase.asm create mode 100644 gmp4/mpn/x86/atom/sse2/popcount.asm create mode 100644 gmp4/mpn/x86/atom/sse2/sqr_basecase.asm create mode 100644 gmp4/mpn/x86/atom/sublsh1_n.asm create mode 100644 gmp4/mpn/x86/atom/sublsh2_n.asm create mode 100644 gmp4/mpn/x86/bd1/gmp-mparam.h create mode 100644 gmp4/mpn/x86/bd2/gmp-mparam.h create mode 100644 gmp4/mpn/x86/bdiv_dbm1c.asm create mode 100644 gmp4/mpn/x86/bdiv_q_1.asm create mode 100644 gmp4/mpn/x86/bobcat/gmp-mparam.h create mode 100644 gmp4/mpn/x86/cnd_aors_n.asm create mode 100644 gmp4/mpn/x86/copyd.asm create mode 100644 gmp4/mpn/x86/copyi.asm create mode 100644 gmp4/mpn/x86/core2/gmp-mparam.h create mode 100644 gmp4/mpn/x86/coreihwl/gmp-mparam.h create mode 100644 gmp4/mpn/x86/coreinhm/gmp-mparam.h create mode 100644 gmp4/mpn/x86/coreisbr/gmp-mparam.h create mode 100644 gmp4/mpn/x86/darwin.m4 create mode 100644 gmp4/mpn/x86/dive_1.asm create mode 100644 gmp4/mpn/x86/divrem_1.asm create mode 100644 gmp4/mpn/x86/divrem_2.asm create mode 100644 gmp4/mpn/x86/fat/com.c create mode 100644 gmp4/mpn/x86/fat/fat.c create mode 100644 gmp4/mpn/x86/fat/fat_entry.asm create mode 100644 gmp4/mpn/x86/fat/gcd_1.c create mode 100644 gmp4/mpn/x86/fat/gmp-mparam.h create mode 100644 gmp4/mpn/x86/fat/lshiftc.c create mode 100644 gmp4/mpn/x86/fat/mod_1.c create mode 100644 gmp4/mpn/x86/fat/mod_1_1.c create mode 100644 gmp4/mpn/x86/fat/mod_1_2.c create mode 100644 gmp4/mpn/x86/fat/mod_1_4.c create mode 100644 gmp4/mpn/x86/fat/mode1o.c create mode 100644 gmp4/mpn/x86/fat/mullo_basecase.c create mode 100644 gmp4/mpn/x86/fat/redc_1.c create mode 100644 gmp4/mpn/x86/fat/redc_2.c create mode 100644 gmp4/mpn/x86/geode/gmp-mparam.h create mode 100644 gmp4/mpn/x86/gmp-mparam.h create mode 100644 gmp4/mpn/x86/i486/gmp-mparam.h create mode 100644 gmp4/mpn/x86/k10/gmp-mparam.h create mode 100644 gmp4/mpn/x86/k6/README create mode 100644 gmp4/mpn/x86/k6/aors_n.asm create mode 100644 gmp4/mpn/x86/k6/aorsmul_1.asm create mode 100755 gmp4/mpn/x86/k6/cross.pl create mode 100644 gmp4/mpn/x86/k6/divrem_1.asm create mode 100644 gmp4/mpn/x86/k6/gcd_1.asm create mode 100644 gmp4/mpn/x86/k6/gmp-mparam.h create mode 100644 gmp4/mpn/x86/k6/k62mmx/copyd.asm create mode 100644 gmp4/mpn/x86/k6/k62mmx/lshift.asm create mode 100644 gmp4/mpn/x86/k6/k62mmx/rshift.asm create mode 100644 gmp4/mpn/x86/k6/mmx/com.asm create mode 100644 gmp4/mpn/x86/k6/mmx/dive_1.asm create mode 100644 gmp4/mpn/x86/k6/mmx/logops_n.asm create mode 100644 gmp4/mpn/x86/k6/mmx/lshift.asm create mode 100644 gmp4/mpn/x86/k6/mmx/popham.asm create mode 100644 gmp4/mpn/x86/k6/mmx/rshift.asm create mode 100644 gmp4/mpn/x86/k6/mod_34lsub1.asm create mode 100644 gmp4/mpn/x86/k6/mode1o.asm create mode 100644 gmp4/mpn/x86/k6/mul_1.asm create mode 100644 gmp4/mpn/x86/k6/mul_basecase.asm create mode 100644 gmp4/mpn/x86/k6/pre_mod_1.asm create mode 100644 gmp4/mpn/x86/k6/sqr_basecase.asm create mode 100644 gmp4/mpn/x86/k7/README create mode 100644 gmp4/mpn/x86/k7/addlsh1_n.asm create mode 100644 gmp4/mpn/x86/k7/aors_n.asm create mode 100644 gmp4/mpn/x86/k7/aorsmul_1.asm create mode 100644 gmp4/mpn/x86/k7/bdiv_q_1.asm create mode 100644 gmp4/mpn/x86/k7/dive_1.asm create mode 100644 gmp4/mpn/x86/k7/gcd_1.asm create mode 100644 gmp4/mpn/x86/k7/gmp-mparam.h create mode 100644 gmp4/mpn/x86/k7/invert_limb.asm create mode 100644 gmp4/mpn/x86/k7/mmx/com.asm create mode 100644 gmp4/mpn/x86/k7/mmx/copyd.asm create mode 100644 gmp4/mpn/x86/k7/mmx/copyi.asm create mode 100644 gmp4/mpn/x86/k7/mmx/divrem_1.asm create mode 100644 gmp4/mpn/x86/k7/mmx/lshift.asm create mode 100644 gmp4/mpn/x86/k7/mmx/popham.asm create mode 100644 gmp4/mpn/x86/k7/mmx/rshift.asm create mode 100644 gmp4/mpn/x86/k7/mod_1_1.asm create mode 100644 gmp4/mpn/x86/k7/mod_1_4.asm create mode 100644 gmp4/mpn/x86/k7/mod_34lsub1.asm create mode 100644 gmp4/mpn/x86/k7/mode1o.asm create mode 100644 gmp4/mpn/x86/k7/mul_1.asm create mode 100644 gmp4/mpn/x86/k7/mul_basecase.asm create mode 100644 gmp4/mpn/x86/k7/sqr_basecase.asm create mode 100644 gmp4/mpn/x86/k7/sublsh1_n.asm create mode 100644 gmp4/mpn/x86/k8/gmp-mparam.h create mode 100644 gmp4/mpn/x86/lshift.asm create mode 100644 gmp4/mpn/x86/mmx/sec_tabselect.asm create mode 100644 gmp4/mpn/x86/mod_34lsub1.asm create mode 100644 gmp4/mpn/x86/mul_1.asm create mode 100644 gmp4/mpn/x86/mul_basecase.asm create mode 100644 gmp4/mpn/x86/nano/gmp-mparam.h create mode 100644 gmp4/mpn/x86/p6/README create mode 100644 gmp4/mpn/x86/p6/aors_n.asm create mode 100644 gmp4/mpn/x86/p6/aorsmul_1.asm create mode 100644 gmp4/mpn/x86/p6/bdiv_q_1.asm create mode 100644 gmp4/mpn/x86/p6/copyd.asm create mode 100644 gmp4/mpn/x86/p6/dive_1.asm create mode 100644 gmp4/mpn/x86/p6/gcd_1.asm create mode 100644 gmp4/mpn/x86/p6/gmp-mparam.h create mode 100644 gmp4/mpn/x86/p6/lshsub_n.asm create mode 100644 gmp4/mpn/x86/p6/mmx/divrem_1.asm create mode 100644 gmp4/mpn/x86/p6/mmx/gmp-mparam.h create mode 100644 gmp4/mpn/x86/p6/mmx/lshift.asm create mode 100644 gmp4/mpn/x86/p6/mmx/popham.asm create mode 100644 gmp4/mpn/x86/p6/mmx/rshift.asm create mode 100644 gmp4/mpn/x86/p6/mod_34lsub1.asm create mode 100644 gmp4/mpn/x86/p6/mode1o.asm create mode 100644 gmp4/mpn/x86/p6/mul_basecase.asm create mode 100644 gmp4/mpn/x86/p6/p3mmx/popham.asm create mode 100644 gmp4/mpn/x86/p6/sqr_basecase.asm create mode 100644 gmp4/mpn/x86/p6/sse2/addmul_1.asm create mode 100644 gmp4/mpn/x86/p6/sse2/gmp-mparam.h create mode 100644 gmp4/mpn/x86/p6/sse2/mod_1_1.asm create mode 100644 gmp4/mpn/x86/p6/sse2/mod_1_4.asm create mode 100644 gmp4/mpn/x86/p6/sse2/mul_1.asm create mode 100644 gmp4/mpn/x86/p6/sse2/mul_basecase.asm create mode 100644 gmp4/mpn/x86/p6/sse2/popcount.asm create mode 100644 gmp4/mpn/x86/p6/sse2/sqr_basecase.asm create mode 100644 gmp4/mpn/x86/p6/sse2/submul_1.asm create mode 100644 gmp4/mpn/x86/pentium/README create mode 100644 gmp4/mpn/x86/pentium/aors_n.asm create mode 100644 gmp4/mpn/x86/pentium/aorsmul_1.asm create mode 100644 gmp4/mpn/x86/pentium/bdiv_q_1.asm create mode 100644 gmp4/mpn/x86/pentium/com.asm create mode 100644 gmp4/mpn/x86/pentium/copyd.asm create mode 100644 gmp4/mpn/x86/pentium/copyi.asm create mode 100644 gmp4/mpn/x86/pentium/dive_1.asm create mode 100644 gmp4/mpn/x86/pentium/gmp-mparam.h create mode 100644 gmp4/mpn/x86/pentium/hamdist.asm create mode 100644 gmp4/mpn/x86/pentium/logops_n.asm create mode 100644 gmp4/mpn/x86/pentium/lshift.asm create mode 100644 gmp4/mpn/x86/pentium/mmx/gmp-mparam.h create mode 100644 gmp4/mpn/x86/pentium/mmx/hamdist.asm create mode 100644 gmp4/mpn/x86/pentium/mmx/lshift.asm create mode 100644 gmp4/mpn/x86/pentium/mmx/mul_1.asm create mode 100644 gmp4/mpn/x86/pentium/mmx/rshift.asm create mode 100644 gmp4/mpn/x86/pentium/mod_34lsub1.asm create mode 100644 gmp4/mpn/x86/pentium/mode1o.asm create mode 100644 gmp4/mpn/x86/pentium/mul_1.asm create mode 100644 gmp4/mpn/x86/pentium/mul_2.asm create mode 100644 gmp4/mpn/x86/pentium/mul_basecase.asm create mode 100644 gmp4/mpn/x86/pentium/popcount.asm create mode 100644 gmp4/mpn/x86/pentium/rshift.asm create mode 100644 gmp4/mpn/x86/pentium/sqr_basecase.asm create mode 100644 gmp4/mpn/x86/pentium4/README create mode 100644 gmp4/mpn/x86/pentium4/copyd.asm create mode 100644 gmp4/mpn/x86/pentium4/copyi.asm create mode 100644 gmp4/mpn/x86/pentium4/mmx/lshift.asm create mode 100644 gmp4/mpn/x86/pentium4/mmx/popham.asm create mode 100644 gmp4/mpn/x86/pentium4/mmx/rshift.asm create mode 100644 gmp4/mpn/x86/pentium4/sse2/add_n.asm create mode 100644 gmp4/mpn/x86/pentium4/sse2/addlsh1_n.asm create mode 100644 gmp4/mpn/x86/pentium4/sse2/addmul_1.asm create mode 100644 gmp4/mpn/x86/pentium4/sse2/bdiv_dbm1c.asm create mode 100644 gmp4/mpn/x86/pentium4/sse2/bdiv_q_1.asm create mode 100644 gmp4/mpn/x86/pentium4/sse2/cnd_add_n.asm create mode 100644 gmp4/mpn/x86/pentium4/sse2/cnd_sub_n.asm create mode 100644 gmp4/mpn/x86/pentium4/sse2/dive_1.asm create mode 100644 gmp4/mpn/x86/pentium4/sse2/divrem_1.asm create mode 100644 gmp4/mpn/x86/pentium4/sse2/gmp-mparam.h create mode 100644 gmp4/mpn/x86/pentium4/sse2/mod_1_1.asm create mode 100644 gmp4/mpn/x86/pentium4/sse2/mod_1_4.asm create mode 100644 gmp4/mpn/x86/pentium4/sse2/mod_34lsub1.asm create mode 100644 gmp4/mpn/x86/pentium4/sse2/mode1o.asm create mode 100644 gmp4/mpn/x86/pentium4/sse2/mul_1.asm create mode 100644 gmp4/mpn/x86/pentium4/sse2/mul_basecase.asm create mode 100644 gmp4/mpn/x86/pentium4/sse2/popcount.asm create mode 100644 gmp4/mpn/x86/pentium4/sse2/rsh1add_n.asm create mode 100644 gmp4/mpn/x86/pentium4/sse2/sqr_basecase.asm create mode 100644 gmp4/mpn/x86/pentium4/sse2/sub_n.asm create mode 100644 gmp4/mpn/x86/pentium4/sse2/submul_1.asm create mode 100644 gmp4/mpn/x86/rshift.asm create mode 100644 gmp4/mpn/x86/sec_tabselect.asm create mode 100644 gmp4/mpn/x86/sqr_basecase.asm create mode 100755 gmp4/mpn/x86/t-zdisp.sh create mode 100755 gmp4/mpn/x86/t-zdisp2.pl create mode 100644 gmp4/mpn/x86/udiv.asm create mode 100644 gmp4/mpn/x86/umul.asm create mode 100644 gmp4/mpn/x86/x86-defs.m4 create mode 100644 gmp4/mpn/x86_64/README create mode 100644 gmp4/mpn/x86_64/addaddmul_1msb0.asm create mode 100644 gmp4/mpn/x86_64/addmul_2.asm create mode 100644 gmp4/mpn/x86_64/aorrlsh1_n.asm create mode 100644 gmp4/mpn/x86_64/aorrlsh2_n.asm create mode 100644 gmp4/mpn/x86_64/aorrlshC_n.asm create mode 100644 gmp4/mpn/x86_64/aorrlsh_n.asm create mode 100644 gmp4/mpn/x86_64/aors_err1_n.asm create mode 100644 gmp4/mpn/x86_64/aors_err2_n.asm create mode 100644 gmp4/mpn/x86_64/aors_err3_n.asm create mode 100644 gmp4/mpn/x86_64/aors_n.asm create mode 100644 gmp4/mpn/x86_64/aorsmul_1.asm create mode 100644 gmp4/mpn/x86_64/atom/addmul_2.asm create mode 100644 gmp4/mpn/x86_64/atom/aorrlsh1_n.asm create mode 100644 gmp4/mpn/x86_64/atom/aorrlsh2_n.asm create mode 100644 gmp4/mpn/x86_64/atom/aors_n.asm create mode 100644 gmp4/mpn/x86_64/atom/aorsmul_1.asm create mode 100644 gmp4/mpn/x86_64/atom/com.asm create mode 100644 gmp4/mpn/x86_64/atom/copyd.asm create mode 100644 gmp4/mpn/x86_64/atom/copyi.asm create mode 100644 gmp4/mpn/x86_64/atom/dive_1.asm create mode 100644 gmp4/mpn/x86_64/atom/gmp-mparam.h create mode 100644 gmp4/mpn/x86_64/atom/lshift.asm create mode 100644 gmp4/mpn/x86_64/atom/lshiftc.asm create mode 100644 gmp4/mpn/x86_64/atom/mul_1.asm create mode 100644 gmp4/mpn/x86_64/atom/mul_2.asm create mode 100644 gmp4/mpn/x86_64/atom/popcount.asm create mode 100644 gmp4/mpn/x86_64/atom/redc_1.asm create mode 100644 gmp4/mpn/x86_64/atom/rsh1aors_n.asm create mode 100644 gmp4/mpn/x86_64/atom/rshift.asm create mode 100644 gmp4/mpn/x86_64/atom/sublsh1_n.asm create mode 100644 gmp4/mpn/x86_64/bd1/README create mode 100644 gmp4/mpn/x86_64/bd1/aorrlsh1_n.asm create mode 100644 gmp4/mpn/x86_64/bd1/aorsmul_1.asm create mode 100644 gmp4/mpn/x86_64/bd1/com.asm create mode 100644 gmp4/mpn/x86_64/bd1/copyd.asm create mode 100644 gmp4/mpn/x86_64/bd1/copyi.asm create mode 100644 gmp4/mpn/x86_64/bd1/gcd_1.asm create mode 100644 gmp4/mpn/x86_64/bd1/gmp-mparam.h create mode 100644 gmp4/mpn/x86_64/bd1/hamdist.asm create mode 100644 gmp4/mpn/x86_64/bd1/mul_1.asm create mode 100644 gmp4/mpn/x86_64/bd1/mul_2.asm create mode 100644 gmp4/mpn/x86_64/bd1/mul_basecase.asm create mode 100644 gmp4/mpn/x86_64/bd1/popcount.asm create mode 100644 gmp4/mpn/x86_64/bd1/sec_tabselect.asm create mode 100644 gmp4/mpn/x86_64/bd1/sublsh1_n.asm create mode 100644 gmp4/mpn/x86_64/bd2/gmp-mparam.h create mode 100644 gmp4/mpn/x86_64/bdiv_dbm1c.asm create mode 100644 gmp4/mpn/x86_64/bdiv_q_1.asm create mode 100644 gmp4/mpn/x86_64/bobcat/aors_n.asm create mode 100644 gmp4/mpn/x86_64/bobcat/aorsmul_1.asm create mode 100644 gmp4/mpn/x86_64/bobcat/copyd.asm create mode 100644 gmp4/mpn/x86_64/bobcat/copyi.asm create mode 100644 gmp4/mpn/x86_64/bobcat/gmp-mparam.h create mode 100644 gmp4/mpn/x86_64/bobcat/mul_1.asm create mode 100644 gmp4/mpn/x86_64/bobcat/mul_basecase.asm create mode 100644 gmp4/mpn/x86_64/bobcat/redc_1.asm create mode 100644 gmp4/mpn/x86_64/bobcat/sqr_basecase.asm create mode 100644 gmp4/mpn/x86_64/cnd_aors_n.asm create mode 100644 gmp4/mpn/x86_64/com.asm create mode 100644 gmp4/mpn/x86_64/copyd.asm create mode 100644 gmp4/mpn/x86_64/copyi.asm create mode 100644 gmp4/mpn/x86_64/core2/aorrlsh1_n.asm create mode 100644 gmp4/mpn/x86_64/core2/aorrlsh2_n.asm create mode 100644 gmp4/mpn/x86_64/core2/aorrlsh_n.asm create mode 100644 gmp4/mpn/x86_64/core2/aors_err1_n.asm create mode 100644 gmp4/mpn/x86_64/core2/aors_n.asm create mode 100644 gmp4/mpn/x86_64/core2/aorsmul_1.asm create mode 100644 gmp4/mpn/x86_64/core2/copyd.asm create mode 100644 gmp4/mpn/x86_64/core2/copyi.asm create mode 100644 gmp4/mpn/x86_64/core2/divrem_1.asm create mode 100644 gmp4/mpn/x86_64/core2/gcd_1.asm create mode 100644 gmp4/mpn/x86_64/core2/gmp-mparam.h create mode 100644 gmp4/mpn/x86_64/core2/lshift.asm create mode 100644 gmp4/mpn/x86_64/core2/lshiftc.asm create mode 100644 gmp4/mpn/x86_64/core2/mul_basecase.asm create mode 100644 gmp4/mpn/x86_64/core2/mullo_basecase.asm create mode 100644 gmp4/mpn/x86_64/core2/popcount.asm create mode 100644 gmp4/mpn/x86_64/core2/redc_1.asm create mode 100644 gmp4/mpn/x86_64/core2/rsh1aors_n.asm create mode 100644 gmp4/mpn/x86_64/core2/rshift.asm create mode 100644 gmp4/mpn/x86_64/core2/sec_tabselect.asm create mode 100644 gmp4/mpn/x86_64/core2/sqr_basecase.asm create mode 100644 gmp4/mpn/x86_64/core2/sublsh1_n.asm create mode 100644 gmp4/mpn/x86_64/core2/sublsh2_n.asm create mode 100644 gmp4/mpn/x86_64/core2/sublshC_n.asm create mode 100644 gmp4/mpn/x86_64/coreihwl/addmul_2.asm create mode 100644 gmp4/mpn/x86_64/coreihwl/aorsmul_1.asm create mode 100644 gmp4/mpn/x86_64/coreihwl/gmp-mparam.h create mode 100644 gmp4/mpn/x86_64/coreihwl/mul_1.asm create mode 100644 gmp4/mpn/x86_64/coreihwl/mul_2.asm create mode 100644 gmp4/mpn/x86_64/coreihwl/mul_basecase.asm create mode 100644 gmp4/mpn/x86_64/coreihwl/mullo_basecase.asm create mode 100644 gmp4/mpn/x86_64/coreihwl/redc_1.asm create mode 100644 gmp4/mpn/x86_64/coreihwl/sqr_basecase.asm create mode 100644 gmp4/mpn/x86_64/coreinhm/aorrlsh_n.asm create mode 100644 gmp4/mpn/x86_64/coreinhm/aorsmul_1.asm create mode 100644 gmp4/mpn/x86_64/coreinhm/gmp-mparam.h create mode 100644 gmp4/mpn/x86_64/coreinhm/hamdist.asm create mode 100644 gmp4/mpn/x86_64/coreinhm/popcount.asm create mode 100644 gmp4/mpn/x86_64/coreinhm/redc_1.asm create mode 100644 gmp4/mpn/x86_64/coreinhm/sec_tabselect.asm create mode 100644 gmp4/mpn/x86_64/coreisbr/addmul_2.asm create mode 100644 gmp4/mpn/x86_64/coreisbr/aorrlsh1_n.asm create mode 100644 gmp4/mpn/x86_64/coreisbr/aorrlsh2_n.asm create mode 100644 gmp4/mpn/x86_64/coreisbr/aorrlshC_n.asm create mode 100644 gmp4/mpn/x86_64/coreisbr/aorrlsh_n.asm create mode 100644 gmp4/mpn/x86_64/coreisbr/aors_n.asm create mode 100644 gmp4/mpn/x86_64/coreisbr/aorsmul_1.asm create mode 100644 gmp4/mpn/x86_64/coreisbr/divrem_1.asm create mode 100644 gmp4/mpn/x86_64/coreisbr/gmp-mparam.h create mode 100644 gmp4/mpn/x86_64/coreisbr/lshift.asm create mode 100644 gmp4/mpn/x86_64/coreisbr/lshiftc.asm create mode 100644 gmp4/mpn/x86_64/coreisbr/mul_1.asm create mode 100644 gmp4/mpn/x86_64/coreisbr/mul_2.asm create mode 100644 gmp4/mpn/x86_64/coreisbr/mul_basecase.asm create mode 100644 gmp4/mpn/x86_64/coreisbr/mullo_basecase.asm create mode 100644 gmp4/mpn/x86_64/coreisbr/popcount.asm create mode 100644 gmp4/mpn/x86_64/coreisbr/redc_1.asm create mode 100644 gmp4/mpn/x86_64/coreisbr/rsh1aors_n.asm create mode 100644 gmp4/mpn/x86_64/coreisbr/rshift.asm create mode 100644 gmp4/mpn/x86_64/coreisbr/sec_tabselect.asm create mode 100644 gmp4/mpn/x86_64/coreisbr/sqr_basecase.asm create mode 100644 gmp4/mpn/x86_64/darwin.m4 create mode 100644 gmp4/mpn/x86_64/div_qr_1n_pi1.asm create mode 100644 gmp4/mpn/x86_64/div_qr_2n_pi1.asm create mode 100644 gmp4/mpn/x86_64/div_qr_2u_pi1.asm create mode 100644 gmp4/mpn/x86_64/dive_1.asm create mode 100644 gmp4/mpn/x86_64/divrem_1.asm create mode 100644 gmp4/mpn/x86_64/divrem_2.asm create mode 100644 gmp4/mpn/x86_64/dos64.m4 create mode 100644 gmp4/mpn/x86_64/fastavx/copyd.asm create mode 100644 gmp4/mpn/x86_64/fastavx/copyi.asm create mode 100644 gmp4/mpn/x86_64/fastsse/README create mode 100644 gmp4/mpn/x86_64/fastsse/com-palignr.asm create mode 100644 gmp4/mpn/x86_64/fastsse/com.asm create mode 100644 gmp4/mpn/x86_64/fastsse/copyd-palignr.asm create mode 100644 gmp4/mpn/x86_64/fastsse/copyd.asm create mode 100644 gmp4/mpn/x86_64/fastsse/copyi-palignr.asm create mode 100644 gmp4/mpn/x86_64/fastsse/copyi.asm create mode 100644 gmp4/mpn/x86_64/fastsse/lshift-movdqu2.asm create mode 100644 gmp4/mpn/x86_64/fastsse/lshift.asm create mode 100644 gmp4/mpn/x86_64/fastsse/lshiftc-movdqu2.asm create mode 100644 gmp4/mpn/x86_64/fastsse/lshiftc.asm create mode 100644 gmp4/mpn/x86_64/fastsse/rshift-movdqu2.asm create mode 100644 gmp4/mpn/x86_64/fastsse/sec_tabselect.asm create mode 100644 gmp4/mpn/x86_64/fat/fat.c create mode 100644 gmp4/mpn/x86_64/fat/fat_entry.asm create mode 100644 gmp4/mpn/x86_64/fat/gmp-mparam.h create mode 100644 gmp4/mpn/x86_64/fat/mod_1.c create mode 100644 gmp4/mpn/x86_64/fat/mul_basecase.c create mode 100644 gmp4/mpn/x86_64/fat/mullo_basecase.c create mode 100644 gmp4/mpn/x86_64/fat/redc_1.c create mode 100644 gmp4/mpn/x86_64/fat/redc_2.c create mode 100644 gmp4/mpn/x86_64/fat/sqr_basecase.c create mode 100644 gmp4/mpn/x86_64/gcd_1.asm create mode 100644 gmp4/mpn/x86_64/gmp-mparam.h create mode 100644 gmp4/mpn/x86_64/invert_limb.asm create mode 100644 gmp4/mpn/x86_64/invert_limb_table.asm create mode 100644 gmp4/mpn/x86_64/k10/gcd_1.asm create mode 100644 gmp4/mpn/x86_64/k10/gmp-mparam.h create mode 100644 gmp4/mpn/x86_64/k10/hamdist.asm create mode 100644 gmp4/mpn/x86_64/k10/lshift.asm create mode 100644 gmp4/mpn/x86_64/k10/lshiftc.asm create mode 100644 gmp4/mpn/x86_64/k10/popcount.asm create mode 100644 gmp4/mpn/x86_64/k10/rshift.asm create mode 100644 gmp4/mpn/x86_64/k10/sec_tabselect.asm create mode 100644 gmp4/mpn/x86_64/k8/aorrlsh_n.asm create mode 100644 gmp4/mpn/x86_64/k8/div_qr_1n_pi1.asm create mode 100644 gmp4/mpn/x86_64/k8/gmp-mparam.h create mode 100644 gmp4/mpn/x86_64/k8/mul_basecase.asm create mode 100644 gmp4/mpn/x86_64/k8/mullo_basecase.asm create mode 100644 gmp4/mpn/x86_64/k8/mulmid_basecase.asm create mode 100644 gmp4/mpn/x86_64/k8/redc_1.asm create mode 100644 gmp4/mpn/x86_64/k8/sqr_basecase.asm create mode 100644 gmp4/mpn/x86_64/logops_n.asm create mode 100644 gmp4/mpn/x86_64/lshift.asm create mode 100644 gmp4/mpn/x86_64/lshiftc.asm create mode 100644 gmp4/mpn/x86_64/lshsub_n.asm create mode 100644 gmp4/mpn/x86_64/missing-call.m4 create mode 100644 gmp4/mpn/x86_64/missing-inline.m4 create mode 100644 gmp4/mpn/x86_64/missing.asm create mode 100644 gmp4/mpn/x86_64/mod_1_1.asm create mode 100644 gmp4/mpn/x86_64/mod_1_2.asm create mode 100644 gmp4/mpn/x86_64/mod_1_4.asm create mode 100644 gmp4/mpn/x86_64/mod_34lsub1.asm create mode 100644 gmp4/mpn/x86_64/mode1o.asm create mode 100644 gmp4/mpn/x86_64/mul_1.asm create mode 100644 gmp4/mpn/x86_64/mul_2.asm create mode 100644 gmp4/mpn/x86_64/mulx/adx/addmul_1.asm create mode 100644 gmp4/mpn/x86_64/mulx/aorsmul_1.asm create mode 100644 gmp4/mpn/x86_64/mulx/mul_1.asm create mode 100644 gmp4/mpn/x86_64/nano/copyd.asm create mode 100644 gmp4/mpn/x86_64/nano/copyi.asm create mode 100644 gmp4/mpn/x86_64/nano/dive_1.asm create mode 100644 gmp4/mpn/x86_64/nano/gcd_1.asm create mode 100644 gmp4/mpn/x86_64/nano/gmp-mparam.h create mode 100644 gmp4/mpn/x86_64/nano/popcount.asm create mode 100644 gmp4/mpn/x86_64/pentium4/aors_n.asm create mode 100644 gmp4/mpn/x86_64/pentium4/aorslsh1_n.asm create mode 100644 gmp4/mpn/x86_64/pentium4/aorslsh2_n.asm create mode 100644 gmp4/mpn/x86_64/pentium4/aorslshC_n.asm create mode 100644 gmp4/mpn/x86_64/pentium4/gmp-mparam.h create mode 100644 gmp4/mpn/x86_64/pentium4/lshift.asm create mode 100644 gmp4/mpn/x86_64/pentium4/lshiftc.asm create mode 100644 gmp4/mpn/x86_64/pentium4/mod_34lsub1.asm create mode 100644 gmp4/mpn/x86_64/pentium4/popcount.asm create mode 100644 gmp4/mpn/x86_64/pentium4/rsh1aors_n.asm create mode 100644 gmp4/mpn/x86_64/pentium4/rshift.asm create mode 100644 gmp4/mpn/x86_64/pentium4/sec_tabselect.asm create mode 100644 gmp4/mpn/x86_64/popham.asm create mode 100644 gmp4/mpn/x86_64/rsh1aors_n.asm create mode 100644 gmp4/mpn/x86_64/rshift.asm create mode 100644 gmp4/mpn/x86_64/sec_tabselect.asm create mode 100644 gmp4/mpn/x86_64/sqr_diag_addlsh1.asm create mode 100644 gmp4/mpn/x86_64/sublsh1_n.asm create mode 100644 gmp4/mpn/x86_64/x86_64-defs.m4 create mode 100644 gmp4/mpq/Makefile.am create mode 100644 gmp4/mpq/Makefile.in create mode 100644 gmp4/mpq/abs.c create mode 100644 gmp4/mpq/aors.c create mode 100644 gmp4/mpq/canonicalize.c create mode 100644 gmp4/mpq/clear.c create mode 100644 gmp4/mpq/clears.c create mode 100644 gmp4/mpq/cmp.c create mode 100644 gmp4/mpq/cmp_si.c create mode 100644 gmp4/mpq/cmp_ui.c create mode 100644 gmp4/mpq/div.c create mode 100644 gmp4/mpq/equal.c create mode 100644 gmp4/mpq/get_d.c create mode 100644 gmp4/mpq/get_den.c create mode 100644 gmp4/mpq/get_num.c create mode 100644 gmp4/mpq/get_str.c create mode 100644 gmp4/mpq/init.c create mode 100644 gmp4/mpq/inits.c create mode 100644 gmp4/mpq/inp_str.c create mode 100644 gmp4/mpq/inv.c create mode 100644 gmp4/mpq/md_2exp.c create mode 100644 gmp4/mpq/mul.c create mode 100644 gmp4/mpq/neg.c create mode 100644 gmp4/mpq/out_str.c create mode 100644 gmp4/mpq/set.c create mode 100644 gmp4/mpq/set_d.c create mode 100644 gmp4/mpq/set_den.c create mode 100644 gmp4/mpq/set_f.c create mode 100644 gmp4/mpq/set_num.c create mode 100644 gmp4/mpq/set_si.c create mode 100644 gmp4/mpq/set_str.c create mode 100644 gmp4/mpq/set_ui.c create mode 100644 gmp4/mpq/set_z.c create mode 100644 gmp4/mpq/swap.c create mode 100644 gmp4/mpz/2fac_ui.c create mode 100644 gmp4/mpz/Makefile.am create mode 100644 gmp4/mpz/Makefile.in create mode 100644 gmp4/mpz/abs.c create mode 100644 gmp4/mpz/add.c create mode 100644 gmp4/mpz/add_ui.c create mode 100644 gmp4/mpz/and.c create mode 100644 gmp4/mpz/aors.h create mode 100644 gmp4/mpz/aors_ui.h create mode 100644 gmp4/mpz/aorsmul.c create mode 100644 gmp4/mpz/aorsmul_i.c create mode 100644 gmp4/mpz/array_init.c create mode 100644 gmp4/mpz/bin_ui.c create mode 100644 gmp4/mpz/bin_uiui.c create mode 100644 gmp4/mpz/cdiv_q.c create mode 100644 gmp4/mpz/cdiv_q_ui.c create mode 100644 gmp4/mpz/cdiv_qr.c create mode 100644 gmp4/mpz/cdiv_qr_ui.c create mode 100644 gmp4/mpz/cdiv_r.c create mode 100644 gmp4/mpz/cdiv_r_ui.c create mode 100644 gmp4/mpz/cdiv_ui.c create mode 100644 gmp4/mpz/cfdiv_q_2exp.c create mode 100644 gmp4/mpz/cfdiv_r_2exp.c create mode 100644 gmp4/mpz/clear.c create mode 100644 gmp4/mpz/clears.c create mode 100644 gmp4/mpz/clrbit.c create mode 100644 gmp4/mpz/cmp.c create mode 100644 gmp4/mpz/cmp_d.c create mode 100644 gmp4/mpz/cmp_si.c create mode 100644 gmp4/mpz/cmp_ui.c create mode 100644 gmp4/mpz/cmpabs.c create mode 100644 gmp4/mpz/cmpabs_d.c create mode 100644 gmp4/mpz/cmpabs_ui.c create mode 100644 gmp4/mpz/com.c create mode 100644 gmp4/mpz/combit.c create mode 100644 gmp4/mpz/cong.c create mode 100644 gmp4/mpz/cong_2exp.c create mode 100644 gmp4/mpz/cong_ui.c create mode 100644 gmp4/mpz/dive_ui.c create mode 100644 gmp4/mpz/divegcd.c create mode 100644 gmp4/mpz/divexact.c create mode 100644 gmp4/mpz/divis.c create mode 100644 gmp4/mpz/divis_2exp.c create mode 100644 gmp4/mpz/divis_ui.c create mode 100644 gmp4/mpz/dump.c create mode 100644 gmp4/mpz/export.c create mode 100644 gmp4/mpz/fac_ui.c create mode 100644 gmp4/mpz/fdiv_q.c create mode 100644 gmp4/mpz/fdiv_q_ui.c create mode 100644 gmp4/mpz/fdiv_qr.c create mode 100644 gmp4/mpz/fdiv_qr_ui.c create mode 100644 gmp4/mpz/fdiv_r.c create mode 100644 gmp4/mpz/fdiv_r_ui.c create mode 100644 gmp4/mpz/fdiv_ui.c create mode 100644 gmp4/mpz/fib2_ui.c create mode 100644 gmp4/mpz/fib_ui.c create mode 100644 gmp4/mpz/fits_s.h create mode 100644 gmp4/mpz/fits_sint.c create mode 100644 gmp4/mpz/fits_slong.c create mode 100644 gmp4/mpz/fits_sshort.c create mode 100644 gmp4/mpz/fits_uint.c create mode 100644 gmp4/mpz/fits_ulong.c create mode 100644 gmp4/mpz/fits_ushort.c create mode 100644 gmp4/mpz/gcd.c create mode 100644 gmp4/mpz/gcd_ui.c create mode 100644 gmp4/mpz/gcdext.c create mode 100644 gmp4/mpz/get_d.c create mode 100644 gmp4/mpz/get_d_2exp.c create mode 100644 gmp4/mpz/get_si.c create mode 100644 gmp4/mpz/get_str.c create mode 100644 gmp4/mpz/get_ui.c create mode 100644 gmp4/mpz/getlimbn.c create mode 100644 gmp4/mpz/hamdist.c create mode 100644 gmp4/mpz/import.c create mode 100644 gmp4/mpz/init.c create mode 100644 gmp4/mpz/init2.c create mode 100644 gmp4/mpz/inits.c create mode 100644 gmp4/mpz/inp_raw.c create mode 100644 gmp4/mpz/inp_str.c create mode 100644 gmp4/mpz/invert.c create mode 100644 gmp4/mpz/ior.c create mode 100644 gmp4/mpz/iset.c create mode 100644 gmp4/mpz/iset_d.c create mode 100644 gmp4/mpz/iset_si.c create mode 100644 gmp4/mpz/iset_str.c create mode 100644 gmp4/mpz/iset_ui.c create mode 100644 gmp4/mpz/jacobi.c create mode 100644 gmp4/mpz/kronsz.c create mode 100644 gmp4/mpz/kronuz.c create mode 100644 gmp4/mpz/kronzs.c create mode 100644 gmp4/mpz/kronzu.c create mode 100644 gmp4/mpz/lcm.c create mode 100644 gmp4/mpz/lcm_ui.c create mode 100644 gmp4/mpz/limbs_finish.c create mode 100644 gmp4/mpz/limbs_modify.c create mode 100644 gmp4/mpz/limbs_read.c create mode 100644 gmp4/mpz/limbs_write.c create mode 100644 gmp4/mpz/lucnum2_ui.c create mode 100644 gmp4/mpz/lucnum_ui.c create mode 100644 gmp4/mpz/mfac_uiui.c create mode 100644 gmp4/mpz/millerrabin.c create mode 100644 gmp4/mpz/mod.c create mode 100644 gmp4/mpz/mul.c create mode 100644 gmp4/mpz/mul_2exp.c create mode 100644 gmp4/mpz/mul_i.h create mode 100644 gmp4/mpz/mul_si.c create mode 100644 gmp4/mpz/mul_ui.c create mode 100644 gmp4/mpz/n_pow_ui.c create mode 100644 gmp4/mpz/neg.c create mode 100644 gmp4/mpz/nextprime.c create mode 100644 gmp4/mpz/oddfac_1.c create mode 100644 gmp4/mpz/out_raw.c create mode 100644 gmp4/mpz/out_str.c create mode 100644 gmp4/mpz/perfpow.c create mode 100644 gmp4/mpz/perfsqr.c create mode 100644 gmp4/mpz/popcount.c create mode 100644 gmp4/mpz/pow_ui.c create mode 100644 gmp4/mpz/powm.c create mode 100644 gmp4/mpz/powm_sec.c create mode 100644 gmp4/mpz/powm_ui.c create mode 100644 gmp4/mpz/pprime_p.c create mode 100644 gmp4/mpz/primorial_ui.c create mode 100644 gmp4/mpz/prodlimbs.c create mode 100644 gmp4/mpz/random.c create mode 100644 gmp4/mpz/random2.c create mode 100644 gmp4/mpz/realloc.c create mode 100644 gmp4/mpz/realloc2.c create mode 100644 gmp4/mpz/remove.c create mode 100644 gmp4/mpz/roinit_n.c create mode 100644 gmp4/mpz/root.c create mode 100644 gmp4/mpz/rootrem.c create mode 100644 gmp4/mpz/rrandomb.c create mode 100644 gmp4/mpz/scan0.c create mode 100644 gmp4/mpz/scan1.c create mode 100644 gmp4/mpz/set.c create mode 100644 gmp4/mpz/set_d.c create mode 100644 gmp4/mpz/set_f.c create mode 100644 gmp4/mpz/set_q.c create mode 100644 gmp4/mpz/set_si.c create mode 100644 gmp4/mpz/set_str.c create mode 100644 gmp4/mpz/set_ui.c create mode 100644 gmp4/mpz/setbit.c create mode 100644 gmp4/mpz/size.c create mode 100644 gmp4/mpz/sizeinbase.c create mode 100644 gmp4/mpz/sqrt.c create mode 100644 gmp4/mpz/sqrtrem.c create mode 100644 gmp4/mpz/sub.c create mode 100644 gmp4/mpz/sub_ui.c create mode 100644 gmp4/mpz/swap.c create mode 100644 gmp4/mpz/tdiv_q.c create mode 100644 gmp4/mpz/tdiv_q_2exp.c create mode 100644 gmp4/mpz/tdiv_q_ui.c create mode 100644 gmp4/mpz/tdiv_qr.c create mode 100644 gmp4/mpz/tdiv_qr_ui.c create mode 100644 gmp4/mpz/tdiv_r.c create mode 100644 gmp4/mpz/tdiv_r_2exp.c create mode 100644 gmp4/mpz/tdiv_r_ui.c create mode 100644 gmp4/mpz/tdiv_ui.c create mode 100644 gmp4/mpz/tstbit.c create mode 100644 gmp4/mpz/ui_pow_ui.c create mode 100644 gmp4/mpz/ui_sub.c create mode 100644 gmp4/mpz/urandomb.c create mode 100644 gmp4/mpz/urandomm.c create mode 100644 gmp4/mpz/xor.c create mode 100644 gmp4/nextprime.c create mode 100644 gmp4/primesieve.c create mode 100644 gmp4/printf/Makefile.am create mode 100644 gmp4/printf/Makefile.in create mode 100644 gmp4/printf/asprintf.c create mode 100644 gmp4/printf/asprntffuns.c create mode 100644 gmp4/printf/doprnt.c create mode 100644 gmp4/printf/doprntf.c create mode 100644 gmp4/printf/doprnti.c create mode 100644 gmp4/printf/fprintf.c create mode 100644 gmp4/printf/obprintf.c create mode 100644 gmp4/printf/obprntffuns.c create mode 100644 gmp4/printf/obvprintf.c create mode 100644 gmp4/printf/printf.c create mode 100644 gmp4/printf/printffuns.c create mode 100644 gmp4/printf/repl-vsnprintf.c create mode 100644 gmp4/printf/snprintf.c create mode 100644 gmp4/printf/snprntffuns.c create mode 100644 gmp4/printf/sprintf.c create mode 100644 gmp4/printf/sprintffuns.c create mode 100644 gmp4/printf/vasprintf.c create mode 100644 gmp4/printf/vfprintf.c create mode 100644 gmp4/printf/vprintf.c create mode 100644 gmp4/printf/vsnprintf.c create mode 100644 gmp4/printf/vsprintf.c create mode 100644 gmp4/rand/Makefile.am create mode 100644 gmp4/rand/Makefile.in create mode 100644 gmp4/rand/rand.c create mode 100644 gmp4/rand/randbui.c create mode 100644 gmp4/rand/randclr.c create mode 100644 gmp4/rand/randdef.c create mode 100644 gmp4/rand/randiset.c create mode 100644 gmp4/rand/randlc2s.c create mode 100644 gmp4/rand/randlc2x.c create mode 100644 gmp4/rand/randmt.c create mode 100644 gmp4/rand/randmt.h create mode 100644 gmp4/rand/randmts.c create mode 100644 gmp4/rand/randmui.c create mode 100644 gmp4/rand/rands.c create mode 100644 gmp4/rand/randsd.c create mode 100644 gmp4/rand/randsdui.c create mode 100644 gmp4/scanf/Makefile.am create mode 100644 gmp4/scanf/Makefile.in create mode 100644 gmp4/scanf/doscan.c create mode 100644 gmp4/scanf/fscanf.c create mode 100644 gmp4/scanf/fscanffuns.c create mode 100644 gmp4/scanf/scanf.c create mode 100644 gmp4/scanf/sscanf.c create mode 100644 gmp4/scanf/sscanffuns.c create mode 100644 gmp4/scanf/vfscanf.c create mode 100644 gmp4/scanf/vscanf.c create mode 100644 gmp4/scanf/vsscanf.c create mode 100644 gmp4/tal-debug.c create mode 100644 gmp4/tal-notreent.c create mode 100644 gmp4/tal-reent.c create mode 100755 gmp4/test-driver create mode 100644 gmp4/tests/Makefile.am create mode 100644 gmp4/tests/Makefile.in create mode 100644 gmp4/tests/amd64call.asm create mode 100644 gmp4/tests/amd64check.c create mode 100644 gmp4/tests/arm32call.asm create mode 100644 gmp4/tests/arm32check.c create mode 100644 gmp4/tests/cxx/Makefile.am create mode 100644 gmp4/tests/cxx/Makefile.in create mode 100644 gmp4/tests/cxx/clocale.c create mode 100644 gmp4/tests/cxx/t-assign.cc create mode 100644 gmp4/tests/cxx/t-binary.cc create mode 100644 gmp4/tests/cxx/t-cast.cc create mode 100644 gmp4/tests/cxx/t-constr.cc create mode 100644 gmp4/tests/cxx/t-cxx11.cc create mode 100644 gmp4/tests/cxx/t-do-exceptions-work-at-all-with-this-compiler.cc create mode 100644 gmp4/tests/cxx/t-headers.cc create mode 100644 gmp4/tests/cxx/t-iostream.cc create mode 100644 gmp4/tests/cxx/t-istream.cc create mode 100644 gmp4/tests/cxx/t-locale.cc create mode 100644 gmp4/tests/cxx/t-misc.cc create mode 100644 gmp4/tests/cxx/t-mix.cc create mode 100644 gmp4/tests/cxx/t-ops.cc create mode 100644 gmp4/tests/cxx/t-ops2.cc create mode 100644 gmp4/tests/cxx/t-ops3.cc create mode 100644 gmp4/tests/cxx/t-ostream.cc create mode 100644 gmp4/tests/cxx/t-prec.cc create mode 100644 gmp4/tests/cxx/t-rand.cc create mode 100644 gmp4/tests/cxx/t-ternary.cc create mode 100644 gmp4/tests/cxx/t-unary.cc create mode 100644 gmp4/tests/devel/Makefile.am create mode 100644 gmp4/tests/devel/Makefile.in create mode 100644 gmp4/tests/devel/README create mode 100644 gmp4/tests/devel/anymul_1.c create mode 100644 gmp4/tests/devel/aors_n.c create mode 100644 gmp4/tests/devel/copy.c create mode 100644 gmp4/tests/devel/divmod_1.c create mode 100644 gmp4/tests/devel/divrem.c create mode 100644 gmp4/tests/devel/logops_n.c create mode 100644 gmp4/tests/devel/shift.c create mode 100644 gmp4/tests/devel/try.c create mode 100644 gmp4/tests/devel/tst-addsub.c create mode 100644 gmp4/tests/memory.c create mode 100644 gmp4/tests/misc.c create mode 100644 gmp4/tests/misc/Makefile.am create mode 100644 gmp4/tests/misc/Makefile.in create mode 100644 gmp4/tests/misc/t-locale.c create mode 100644 gmp4/tests/misc/t-printf.c create mode 100644 gmp4/tests/misc/t-scanf.c create mode 100644 gmp4/tests/mpf/Makefile.am create mode 100644 gmp4/tests/mpf/Makefile.in create mode 100644 gmp4/tests/mpf/reuse.c create mode 100644 gmp4/tests/mpf/t-add.c create mode 100644 gmp4/tests/mpf/t-cmp_d.c create mode 100644 gmp4/tests/mpf/t-cmp_si.c create mode 100644 gmp4/tests/mpf/t-conv.c create mode 100644 gmp4/tests/mpf/t-div.c create mode 100644 gmp4/tests/mpf/t-dm2exp.c create mode 100644 gmp4/tests/mpf/t-eq.c create mode 100644 gmp4/tests/mpf/t-fits.c create mode 100644 gmp4/tests/mpf/t-get_d.c create mode 100644 gmp4/tests/mpf/t-get_d_2exp.c create mode 100644 gmp4/tests/mpf/t-get_si.c create mode 100644 gmp4/tests/mpf/t-get_ui.c create mode 100644 gmp4/tests/mpf/t-gsprec.c create mode 100644 gmp4/tests/mpf/t-inp_str.c create mode 100644 gmp4/tests/mpf/t-int_p.c create mode 100644 gmp4/tests/mpf/t-mul_ui.c create mode 100644 gmp4/tests/mpf/t-muldiv.c create mode 100644 gmp4/tests/mpf/t-set.c create mode 100644 gmp4/tests/mpf/t-set_q.c create mode 100644 gmp4/tests/mpf/t-set_si.c create mode 100644 gmp4/tests/mpf/t-set_ui.c create mode 100644 gmp4/tests/mpf/t-sqrt.c create mode 100644 gmp4/tests/mpf/t-sqrt_ui.c create mode 100644 gmp4/tests/mpf/t-sub.c create mode 100644 gmp4/tests/mpf/t-trunc.c create mode 100644 gmp4/tests/mpf/t-ui_div.c create mode 100644 gmp4/tests/mpn/Makefile.am create mode 100644 gmp4/tests/mpn/Makefile.in create mode 100644 gmp4/tests/mpn/logic.c create mode 100644 gmp4/tests/mpn/t-aors_1.c create mode 100644 gmp4/tests/mpn/t-asmtype.c create mode 100644 gmp4/tests/mpn/t-bdiv.c create mode 100644 gmp4/tests/mpn/t-broot.c create mode 100644 gmp4/tests/mpn/t-brootinv.c create mode 100644 gmp4/tests/mpn/t-div.c create mode 100644 gmp4/tests/mpn/t-divrem_1.c create mode 100644 gmp4/tests/mpn/t-fat.c create mode 100644 gmp4/tests/mpn/t-get_d.c create mode 100644 gmp4/tests/mpn/t-hgcd.c create mode 100644 gmp4/tests/mpn/t-hgcd_appr.c create mode 100644 gmp4/tests/mpn/t-instrument.c create mode 100644 gmp4/tests/mpn/t-invert.c create mode 100644 gmp4/tests/mpn/t-iord_u.c create mode 100644 gmp4/tests/mpn/t-matrix22.c create mode 100644 gmp4/tests/mpn/t-minvert.c create mode 100644 gmp4/tests/mpn/t-mod_1.c create mode 100644 gmp4/tests/mpn/t-mp_bases.c create mode 100644 gmp4/tests/mpn/t-mul.c create mode 100644 gmp4/tests/mpn/t-mullo.c create mode 100644 gmp4/tests/mpn/t-mulmid.c create mode 100644 gmp4/tests/mpn/t-mulmod_bnm1.c create mode 100644 gmp4/tests/mpn/t-perfsqr.c create mode 100644 gmp4/tests/mpn/t-scan.c create mode 100644 gmp4/tests/mpn/t-sizeinbase.c create mode 100644 gmp4/tests/mpn/t-sqrmod_bnm1.c create mode 100644 gmp4/tests/mpn/t-toom2-sqr.c create mode 100644 gmp4/tests/mpn/t-toom22.c create mode 100644 gmp4/tests/mpn/t-toom3-sqr.c create mode 100644 gmp4/tests/mpn/t-toom32.c create mode 100644 gmp4/tests/mpn/t-toom33.c create mode 100644 gmp4/tests/mpn/t-toom4-sqr.c create mode 100644 gmp4/tests/mpn/t-toom42.c create mode 100644 gmp4/tests/mpn/t-toom43.c create mode 100644 gmp4/tests/mpn/t-toom44.c create mode 100644 gmp4/tests/mpn/t-toom52.c create mode 100644 gmp4/tests/mpn/t-toom53.c create mode 100644 gmp4/tests/mpn/t-toom54.c create mode 100644 gmp4/tests/mpn/t-toom6-sqr.c create mode 100644 gmp4/tests/mpn/t-toom62.c create mode 100644 gmp4/tests/mpn/t-toom63.c create mode 100644 gmp4/tests/mpn/t-toom6h.c create mode 100644 gmp4/tests/mpn/t-toom8-sqr.c create mode 100644 gmp4/tests/mpn/t-toom8h.c create mode 100644 gmp4/tests/mpn/toom-shared.h create mode 100644 gmp4/tests/mpn/toom-sqr-shared.h create mode 100644 gmp4/tests/mpq/Makefile.am create mode 100644 gmp4/tests/mpq/Makefile.in create mode 100644 gmp4/tests/mpq/io.c create mode 100644 gmp4/tests/mpq/reuse.c create mode 100644 gmp4/tests/mpq/t-aors.c create mode 100644 gmp4/tests/mpq/t-cmp.c create mode 100644 gmp4/tests/mpq/t-cmp_si.c create mode 100644 gmp4/tests/mpq/t-cmp_ui.c create mode 100644 gmp4/tests/mpq/t-equal.c create mode 100644 gmp4/tests/mpq/t-get_d.c create mode 100644 gmp4/tests/mpq/t-get_str.c create mode 100644 gmp4/tests/mpq/t-inp_str.c create mode 100644 gmp4/tests/mpq/t-inv.c create mode 100644 gmp4/tests/mpq/t-md_2exp.c create mode 100644 gmp4/tests/mpq/t-set_f.c create mode 100644 gmp4/tests/mpq/t-set_str.c create mode 100644 gmp4/tests/mpz/Makefile.am create mode 100644 gmp4/tests/mpz/Makefile.in create mode 100644 gmp4/tests/mpz/bit.c create mode 100644 gmp4/tests/mpz/convert.c create mode 100644 gmp4/tests/mpz/dive.c create mode 100644 gmp4/tests/mpz/dive_ui.c create mode 100644 gmp4/tests/mpz/io.c create mode 100644 gmp4/tests/mpz/logic.c create mode 100644 gmp4/tests/mpz/reuse.c create mode 100644 gmp4/tests/mpz/t-addsub.c create mode 100644 gmp4/tests/mpz/t-aorsmul.c create mode 100644 gmp4/tests/mpz/t-bin.c create mode 100644 gmp4/tests/mpz/t-cdiv_ui.c create mode 100644 gmp4/tests/mpz/t-cmp.c create mode 100644 gmp4/tests/mpz/t-cmp_d.c create mode 100644 gmp4/tests/mpz/t-cmp_si.c create mode 100644 gmp4/tests/mpz/t-cong.c create mode 100644 gmp4/tests/mpz/t-cong_2exp.c create mode 100644 gmp4/tests/mpz/t-div_2exp.c create mode 100644 gmp4/tests/mpz/t-divis.c create mode 100644 gmp4/tests/mpz/t-divis_2exp.c create mode 100644 gmp4/tests/mpz/t-export.c create mode 100644 gmp4/tests/mpz/t-fac_ui.c create mode 100644 gmp4/tests/mpz/t-fdiv.c create mode 100644 gmp4/tests/mpz/t-fdiv_ui.c create mode 100644 gmp4/tests/mpz/t-fib_ui.c create mode 100644 gmp4/tests/mpz/t-fits.c create mode 100644 gmp4/tests/mpz/t-gcd.c create mode 100644 gmp4/tests/mpz/t-gcd_ui.c create mode 100644 gmp4/tests/mpz/t-get_d.c create mode 100644 gmp4/tests/mpz/t-get_d_2exp.c create mode 100644 gmp4/tests/mpz/t-get_si.c create mode 100644 gmp4/tests/mpz/t-hamdist.c create mode 100644 gmp4/tests/mpz/t-import.c create mode 100644 gmp4/tests/mpz/t-inp_str.c create mode 100644 gmp4/tests/mpz/t-invert.c create mode 100644 gmp4/tests/mpz/t-io_raw.c create mode 100644 gmp4/tests/mpz/t-jac.c create mode 100644 gmp4/tests/mpz/t-lcm.c create mode 100644 gmp4/tests/mpz/t-limbs.c create mode 100644 gmp4/tests/mpz/t-lucnum_ui.c create mode 100644 gmp4/tests/mpz/t-mfac_uiui.c create mode 100644 gmp4/tests/mpz/t-mul.c create mode 100644 gmp4/tests/mpz/t-mul_i.c create mode 100644 gmp4/tests/mpz/t-nextprime.c create mode 100644 gmp4/tests/mpz/t-oddeven.c create mode 100644 gmp4/tests/mpz/t-perfpow.c create mode 100644 gmp4/tests/mpz/t-perfsqr.c create mode 100644 gmp4/tests/mpz/t-popcount.c create mode 100644 gmp4/tests/mpz/t-pow.c create mode 100644 gmp4/tests/mpz/t-powm.c create mode 100644 gmp4/tests/mpz/t-powm_ui.c create mode 100644 gmp4/tests/mpz/t-pprime_p.c create mode 100644 gmp4/tests/mpz/t-primorial_ui.c create mode 100644 gmp4/tests/mpz/t-remove.c create mode 100644 gmp4/tests/mpz/t-root.c create mode 100644 gmp4/tests/mpz/t-scan.c create mode 100644 gmp4/tests/mpz/t-set_d.c create mode 100644 gmp4/tests/mpz/t-set_f.c create mode 100644 gmp4/tests/mpz/t-set_si.c create mode 100644 gmp4/tests/mpz/t-set_str.c create mode 100644 gmp4/tests/mpz/t-sizeinbase.c create mode 100644 gmp4/tests/mpz/t-sqrtrem.c create mode 100644 gmp4/tests/mpz/t-tdiv.c create mode 100644 gmp4/tests/mpz/t-tdiv_ui.c create mode 100644 gmp4/tests/rand/Makefile.am create mode 100644 gmp4/tests/rand/Makefile.in create mode 100644 gmp4/tests/rand/findlc.c create mode 100644 gmp4/tests/rand/gen.c create mode 100644 gmp4/tests/rand/gmpstat.h create mode 100644 gmp4/tests/rand/spect.c create mode 100644 gmp4/tests/rand/stat.c create mode 100644 gmp4/tests/rand/statlib.c create mode 100644 gmp4/tests/rand/t-iset.c create mode 100644 gmp4/tests/rand/t-lc2exp.c create mode 100644 gmp4/tests/rand/t-mt.c create mode 100644 gmp4/tests/rand/t-rand.c create mode 100644 gmp4/tests/rand/t-urbui.c create mode 100644 gmp4/tests/rand/t-urmui.c create mode 100644 gmp4/tests/rand/t-urndmm.c create mode 100644 gmp4/tests/rand/zdiv_round.c create mode 100644 gmp4/tests/refmpf.c create mode 100644 gmp4/tests/refmpn.c create mode 100644 gmp4/tests/refmpq.c create mode 100644 gmp4/tests/refmpz.c create mode 100644 gmp4/tests/spinner.c create mode 100644 gmp4/tests/t-bswap.c create mode 100644 gmp4/tests/t-constants.c create mode 100644 gmp4/tests/t-count_zeros.c create mode 100644 gmp4/tests/t-gmpmax.c create mode 100644 gmp4/tests/t-hightomask.c create mode 100644 gmp4/tests/t-modlinv.c create mode 100644 gmp4/tests/t-parity.c create mode 100644 gmp4/tests/t-popc.c create mode 100644 gmp4/tests/t-sub.c create mode 100644 gmp4/tests/tests.h create mode 100644 gmp4/tests/trace.c create mode 100644 gmp4/tests/x86call.asm create mode 100644 gmp4/tests/x86check.c create mode 100644 gmp4/tune/Makefile.am create mode 100644 gmp4/tune/Makefile.in create mode 100644 gmp4/tune/README create mode 100644 gmp4/tune/alpha.asm create mode 100644 gmp4/tune/common.c create mode 100644 gmp4/tune/div_qr_1_tune.c create mode 100644 gmp4/tune/div_qr_1n_pi1_1.c create mode 100644 gmp4/tune/div_qr_1n_pi1_2.c create mode 100644 gmp4/tune/divrem1div.c create mode 100644 gmp4/tune/divrem1inv.c create mode 100644 gmp4/tune/divrem2div.c create mode 100644 gmp4/tune/divrem2inv.c create mode 100644 gmp4/tune/freq.c create mode 100644 gmp4/tune/gcdext_double.c create mode 100644 gmp4/tune/gcdext_single.c create mode 100644 gmp4/tune/gcdextod.c create mode 100644 gmp4/tune/gcdextos.c create mode 100644 gmp4/tune/hgcd_appr_lehmer.c create mode 100644 gmp4/tune/hgcd_lehmer.c create mode 100644 gmp4/tune/hgcd_reduce_1.c create mode 100644 gmp4/tune/hgcd_reduce_2.c create mode 100644 gmp4/tune/hppa.asm create mode 100644 gmp4/tune/hppa2.asm create mode 100644 gmp4/tune/hppa2w.asm create mode 100644 gmp4/tune/ia64.asm create mode 100644 gmp4/tune/jacbase1.c create mode 100644 gmp4/tune/jacbase2.c create mode 100644 gmp4/tune/jacbase3.c create mode 100644 gmp4/tune/jacbase4.c create mode 100644 gmp4/tune/many.pl create mode 100644 gmp4/tune/mod_1_1-1.c create mode 100644 gmp4/tune/mod_1_1-2.c create mode 100644 gmp4/tune/mod_1_div.c create mode 100644 gmp4/tune/mod_1_inv.c create mode 100644 gmp4/tune/modlinv.c create mode 100644 gmp4/tune/noop.c create mode 100644 gmp4/tune/pentium.asm create mode 100644 gmp4/tune/powerpc.asm create mode 100644 gmp4/tune/powerpc64.asm create mode 100644 gmp4/tune/powm_mod.c create mode 100644 gmp4/tune/powm_redc.c create mode 100644 gmp4/tune/pre_divrem_1.c create mode 100644 gmp4/tune/set_strb.c create mode 100644 gmp4/tune/set_strp.c create mode 100644 gmp4/tune/set_strs.c create mode 100644 gmp4/tune/sparcv9.asm create mode 100644 gmp4/tune/speed-ext.c create mode 100644 gmp4/tune/speed.c create mode 100644 gmp4/tune/speed.h create mode 100644 gmp4/tune/time.c create mode 100644 gmp4/tune/tune-gcd-p.c create mode 100644 gmp4/tune/tuneup.c create mode 100644 gmp4/tune/x86_64.asm create mode 100644 gmp4/version.c create mode 100755 gmp4/ylwrap create mode 100644 go/makefile create mode 100755 h/386-bsd.defs create mode 100755 h/386-bsd.h create mode 100755 h/386-gnu.h create mode 100644 h/386-kfreebsd.defs create mode 100644 h/386-kfreebsd.h create mode 100755 h/386-linux.h create mode 100644 h/386-macosx.defs create mode 100644 h/386-macosx.h create mode 100755 h/386.h create mode 100755 h/FreeBSD.defs create mode 100755 h/FreeBSD.h create mode 100755 h/NeXT.defs create mode 100755 h/NeXT.h create mode 100755 h/NeXT30-m68k.defs create mode 100755 h/NeXT30-m68k.h create mode 100755 h/NeXT32-i386.defs create mode 100755 h/NeXT32-i386.h create mode 100755 h/NeXT32-m68k.defs create mode 100755 h/NeXT32-m68k.h create mode 100755 h/NetBSD.defs create mode 100755 h/NetBSD.h create mode 100755 h/OpenBSD.defs create mode 100755 h/OpenBSD.h create mode 100644 h/aarch64-linux.h create mode 100755 h/alpha-linux.h create mode 100755 h/alpha-osf1.defs create mode 100755 h/alpha-osf1.h create mode 100644 h/amd64-kfreebsd.h create mode 100644 h/amd64-linux.h create mode 100644 h/apply_n.h create mode 100755 h/arith.h create mode 100755 h/arm-linux.h create mode 100644 h/arth.h create mode 100755 h/att.h create mode 100755 h/att3b2.h create mode 100755 h/att_ext.h create mode 100755 h/bds.h create mode 100644 h/bits.h create mode 100755 h/bsd.h create mode 100755 h/cmpincl1.h create mode 100755 h/cmplrs/stsupport.h create mode 100755 h/cmponly.h create mode 100755 h/coff/i386.h create mode 100755 h/coff_encap.h create mode 100755 h/compat.h create mode 100755 h/compbas.h create mode 100755 h/compbas2.h create mode 100644 h/compdefs.h create mode 100644 h/compprotos.h create mode 100755 h/convex.h create mode 100755 h/cyglacks.h create mode 100755 h/dec3100.defs create mode 100755 h/dec3100.h create mode 100755 h/defun.h create mode 100755 h/dos-go32.defs create mode 100755 h/dos-go32.h create mode 100755 h/e15.h create mode 100644 h/elf32_arm_reloc.h create mode 100644 h/elf32_hppa_reloc.h create mode 100644 h/elf32_hppa_reloc_special.h create mode 100644 h/elf32_i386_reloc.h create mode 100644 h/elf32_m68k_reloc.h create mode 100644 h/elf32_mips_reloc.h create mode 100644 h/elf32_mips_reloc_special.h create mode 100644 h/elf32_ppc_reloc.h create mode 100644 h/elf32_s390_reloc.h create mode 100644 h/elf32_sh4_reloc.h create mode 100644 h/elf32_sparc_reloc.h create mode 100644 h/elf64_aarch64_reloc.h create mode 100644 h/elf64_aarch64_reloc_special.h create mode 100644 h/elf64_alpha_reloc.h create mode 100644 h/elf64_alpha_reloc_special.h create mode 100644 h/elf64_i386_reloc.h create mode 100644 h/elf64_mips_reloc.h create mode 100644 h/elf64_mips_reloc_special.h create mode 100644 h/elf64_ppc_reloc.h create mode 100644 h/elf64_ppc_reloc_special.h create mode 100644 h/elf64_ppcle_reloc.h create mode 100644 h/elf64_ppcle_reloc_special.h create mode 100644 h/elf64_s390_reloc.h create mode 100644 h/elf64_sparc_reloc.h create mode 100644 h/elf64_sparc_reloc_special.h create mode 100755 h/enum.h create mode 100755 h/erreurs.h create mode 100644 h/error.h create mode 100755 h/eval.h create mode 100755 h/ext_sym.h create mode 100644 h/fixnum.h create mode 100755 h/frame.h create mode 100755 h/funlink.h create mode 100644 h/gclincl.h.in create mode 100755 h/gencom.h create mode 100755 h/genpari.h create mode 100755 h/genport.h create mode 100755 h/getpagesize.h create mode 100644 h/globals.h create mode 100644 h/gmp_wrappers.h create mode 100755 h/gnuwin95.defs create mode 100755 h/gnuwin95.h create mode 100755 h/hp300-bsd.defs create mode 100755 h/hp300-bsd.h create mode 100755 h/hp300.defs create mode 100755 h/hp300.h create mode 100755 h/hp800.defs create mode 100755 h/hp800.h create mode 100755 h/hppa-linux.h create mode 100755 h/ia64-linux.h create mode 100644 h/immnum.h create mode 100755 h/include.h create mode 100755 h/irix5.defs create mode 100755 h/irix5.h create mode 100755 h/irix6.defs create mode 100755 h/irix6.h create mode 100644 h/ld_bind_now.h create mode 100755 h/lex.h create mode 100644 h/linux.defs create mode 100644 h/linux.h create mode 100644 h/lu.h create mode 100755 h/m68k-linux.h create mode 100755 h/mac2.defs create mode 100755 h/mac2.h create mode 100644 h/mach32_i386_reloc.h create mode 100644 h/mach32_ppc_reloc.h create mode 100644 h/mach64_i386_reloc.h create mode 100755 h/make-decl.h create mode 100755 h/make-init.h create mode 100755 h/mc68k.h create mode 100755 h/mdefs.h create mode 100644 h/mgmp.h create mode 100644 h/minglacks.h create mode 100755 h/mingw.defs create mode 100755 h/mingw.h create mode 100755 h/mips-linux.h create mode 100755 h/mips.h create mode 100755 h/mipsel-linux.h create mode 100755 h/mp.h create mode 100755 h/mp386.defs create mode 100755 h/mp386.h create mode 100755 h/ncr.defs create mode 100755 h/ncr.h create mode 100755 h/news.h create mode 100755 h/notcomp.h create mode 100755 h/num_include.h create mode 100755 h/object.h create mode 100755 h/options.h create mode 100755 h/page.h create mode 100644 h/pageinfo.h create mode 100644 h/pbits.h create mode 100644 h/powerpc-linux.h create mode 100644 h/powerpc-macosx.defs create mode 100644 h/powerpc-macosx.h create mode 100644 h/prelink.h create mode 100644 h/protoize.h create mode 100755 h/ptable.h create mode 100755 h/rgbc.h create mode 100755 h/rios-aix3.defs create mode 100755 h/rios-aix3.h create mode 100755 h/rios.defs create mode 100755 h/rios.h create mode 100755 h/rt_aix.defs create mode 100755 h/rt_aix.h create mode 100755 h/s3000.h create mode 100755 h/s390-linux.h create mode 100755 h/secondary_sun_magic create mode 100755 h/sfun_argd.h create mode 100755 h/sgi.defs create mode 100755 h/sgi.h create mode 100755 h/sgi4d.defs create mode 100755 h/sgi4d.h create mode 100755 h/sh4-linux.h create mode 100755 h/solaris-i386.defs create mode 100755 h/solaris-i386.h create mode 100755 h/solaris.defs create mode 100755 h/solaris.h create mode 100755 h/sparc-linux.h create mode 100755 h/sparc.h create mode 100755 h/stacks.h create mode 100755 h/sun.h create mode 100755 h/sun2r3.defs create mode 100755 h/sun2r3.h create mode 100755 h/sun3-os4.defs create mode 100755 h/sun3-os4.h create mode 100755 h/sun3.defs create mode 100755 h/sun3.h create mode 100755 h/sun386i.defs create mode 100755 h/sun386i.h create mode 100755 h/sun4.defs create mode 100755 h/sun4.h create mode 100755 h/symbol.h create mode 100755 h/symmetry.defs create mode 100755 h/symmetry.h create mode 100644 h/tsgc.h create mode 100755 h/twelve_null create mode 100644 h/type.h create mode 100755 h/u370_aix.defs create mode 100755 h/u370_aix.h create mode 100644 h/unrandomize.h create mode 100755 h/usig.h create mode 100755 h/vax.defs create mode 100755 h/vax.h create mode 100755 h/vs.h create mode 100755 h/wincoff.h create mode 100644 h/writable.h create mode 100755 info/bind.texi create mode 100755 info/c-interface.texi create mode 100755 info/character.texi create mode 100755 info/compile.texi create mode 100755 info/compiler-defs.texi create mode 100755 info/control.texi create mode 100755 info/debug.texi create mode 100755 info/doc.texi create mode 100755 info/form.texi create mode 100755 info/gcl-si-index.texi create mode 100644 info/gcl-si.info create mode 100644 info/gcl-si.pdf create mode 100755 info/gcl-si.texi create mode 100644 info/gcl-si/Available-Symbols.html create mode 100644 info/gcl-si/Bignums.html create mode 100644 info/gcl-si/C-Interface.html create mode 100644 info/gcl-si/Characters.html create mode 100644 info/gcl-si/Command-Line.html create mode 100644 info/gcl-si/Compilation.html create mode 100644 info/gcl-si/Compiler-Definitions.html create mode 100644 info/gcl-si/Debugging.html create mode 100644 info/gcl-si/Doc.html create mode 100644 info/gcl-si/Environment.html create mode 100644 info/gcl-si/Function-and-Variable-Index.html create mode 100644 info/gcl-si/GCL-Specific.html create mode 100644 info/gcl-si/Inititialization.html create mode 100644 info/gcl-si/Iteration-and-Tests.html create mode 100644 info/gcl-si/Lists.html create mode 100644 info/gcl-si/Low-Level-Debug-Functions.html create mode 100644 info/gcl-si/Low-Level-X-Interface.html create mode 100644 info/gcl-si/Miscellaneous.html create mode 100644 info/gcl-si/Numbers.html create mode 100644 info/gcl-si/Operating-System-Definitions.html create mode 100644 info/gcl-si/Operating-System.html create mode 100644 info/gcl-si/Regular-Expressions.html create mode 100644 info/gcl-si/Sequences-and-Arrays-and-Hash-Tables.html create mode 100644 info/gcl-si/Source-Level-Debugging-in-Emacs.html create mode 100644 info/gcl-si/Special-Forms-and-Functions.html create mode 100644 info/gcl-si/Streams-and-Reading.html create mode 100644 info/gcl-si/Structures.html create mode 100644 info/gcl-si/Symbols.html create mode 100644 info/gcl-si/System-Definitions.html create mode 100644 info/gcl-si/Type.html create mode 100644 info/gcl-si/User-Interface.html create mode 100644 info/gcl-si/index.html create mode 100644 info/gcl-tk.info create mode 100644 info/gcl-tk.info-1 create mode 100644 info/gcl-tk.info-2 create mode 100644 info/gcl-tk.pdf create mode 100755 info/gcl-tk.texi create mode 100644 info/gcl-tk/Argument-Lists.html create mode 100644 info/gcl-tk/Common-Features-of-Widgets.html create mode 100644 info/gcl-tk/Control.html create mode 100644 info/gcl-tk/General.html create mode 100644 info/gcl-tk/Getting-Started.html create mode 100644 info/gcl-tk/Introduction.html create mode 100644 info/gcl-tk/Linked-Variables.html create mode 100644 info/gcl-tk/Lisp-Functions-Invoked-from-Graphics.html create mode 100644 info/gcl-tk/Return-Values.html create mode 100644 info/gcl-tk/Widgets.html create mode 100644 info/gcl-tk/after.html create mode 100644 info/gcl-tk/bind.html create mode 100644 info/gcl-tk/button.html create mode 100644 info/gcl-tk/canvas.html create mode 100644 info/gcl-tk/checkbutton.html create mode 100644 info/gcl-tk/destroy.html create mode 100644 info/gcl-tk/entry.html create mode 100644 info/gcl-tk/exit.html create mode 100644 info/gcl-tk/focus.html create mode 100644 info/gcl-tk/frame.html create mode 100644 info/gcl-tk/grab.html create mode 100644 info/gcl-tk/index.html create mode 100644 info/gcl-tk/label.html create mode 100644 info/gcl-tk/listbox.html create mode 100644 info/gcl-tk/lower.html create mode 100644 info/gcl-tk/menu.html create mode 100644 info/gcl-tk/menubutton.html create mode 100644 info/gcl-tk/message.html create mode 100644 info/gcl-tk/option.html create mode 100644 info/gcl-tk/options.html create mode 100644 info/gcl-tk/pack.html create mode 100644 info/gcl-tk/pack_002dold.html create mode 100644 info/gcl-tk/place.html create mode 100644 info/gcl-tk/radiobutton.html create mode 100644 info/gcl-tk/raise.html create mode 100644 info/gcl-tk/scale.html create mode 100644 info/gcl-tk/scrollbar.html create mode 100644 info/gcl-tk/selection.html create mode 100644 info/gcl-tk/send.html create mode 100644 info/gcl-tk/text.html create mode 100644 info/gcl-tk/tk.html create mode 100644 info/gcl-tk/tk_002ddialog.html create mode 100644 info/gcl-tk/tk_002dlistbox_002dsingle_002dselect.html create mode 100644 info/gcl-tk/tk_002dmenu_002dbar.html create mode 100644 info/gcl-tk/tkconnect.html create mode 100644 info/gcl-tk/tkerror.html create mode 100644 info/gcl-tk/tkvars.html create mode 100644 info/gcl-tk/tkwait.html create mode 100644 info/gcl-tk/toplevel.html create mode 100644 info/gcl-tk/update.html create mode 100644 info/gcl-tk/winfo.html create mode 100644 info/gcl-tk/wm.html create mode 100644 info/gcl.texi.diff create mode 100755 info/general.texi create mode 100755 info/internal.texi create mode 100755 info/io.texi create mode 100755 info/iteration.texi create mode 100755 info/list.texi create mode 100644 info/makefile create mode 100755 info/misc.texi create mode 100755 info/number.texi create mode 100755 info/sequence.texi create mode 100755 info/si-defs.texi create mode 100755 info/structure.texi create mode 100755 info/symbol.texi create mode 100755 info/system.texi create mode 100755 info/type.texi create mode 100755 info/user-interface.texi create mode 100755 info/widgets.texi create mode 100644 install.sh create mode 100644 japitest.lsp create mode 100755 lsp/dbind.lisp create mode 100755 lsp/dummy.lisp create mode 100755 lsp/fasd.lisp create mode 100755 lsp/fast-mv.lisp create mode 100755 lsp/gcl_arraylib.lsp create mode 100755 lsp/gcl_assert.lsp create mode 100755 lsp/gcl_auto.lsp create mode 100755 lsp/gcl_auto_new.lsp create mode 100755 lsp/gcl_autocmp.lsp create mode 100755 lsp/gcl_autoload.lsp create mode 100755 lsp/gcl_cmpinit.lsp create mode 100755 lsp/gcl_debug.lsp create mode 100755 lsp/gcl_defmacro.lsp create mode 100644 lsp/gcl_defpackage.lsp create mode 100755 lsp/gcl_defstruct.lsp create mode 100755 lsp/gcl_describe.lsp create mode 100755 lsp/gcl_desetq.lsp create mode 100644 lsp/gcl_destructuring_bind.lsp create mode 100755 lsp/gcl_doc-file.lsp create mode 100755 lsp/gcl_evalmacros.lsp create mode 100755 lsp/gcl_export.lsp create mode 100755 lsp/gcl_fdecl.lsp create mode 100644 lsp/gcl_fpe.lsp create mode 100644 lsp/gcl_fpe_test.lsp create mode 100755 lsp/gcl_gprof.lsp create mode 100755 lsp/gcl_info.lsp create mode 100755 lsp/gcl_iolib.lsp create mode 100644 lsp/gcl_japi.lsp create mode 100755 lsp/gcl_listlib.lsp create mode 100755 lsp/gcl_littleXlsp.lsp create mode 100755 lsp/gcl_loadcmp.lsp create mode 100644 lsp/gcl_loop.lsp create mode 100755 lsp/gcl_make-declare.lsp create mode 100644 lsp/gcl_make_defpackage.lsp create mode 100755 lsp/gcl_mislib.lsp create mode 100755 lsp/gcl_module.lsp create mode 100755 lsp/gcl_numlib.lsp create mode 100755 lsp/gcl_packages.lsp create mode 100755 lsp/gcl_packlib.lsp create mode 100755 lsp/gcl_predlib.lsp create mode 100755 lsp/gcl_profile.lsp create mode 100644 lsp/gcl_readline.lsp create mode 100644 lsp/gcl_restart.lsp create mode 100755 lsp/gcl_seq.lsp create mode 100755 lsp/gcl_seqlib.lsp create mode 100755 lsp/gcl_serror.lsp create mode 100755 lsp/gcl_setf.lsp create mode 100644 lsp/gcl_sharp.lsp create mode 100755 lsp/gcl_sloop.lsp create mode 100755 lsp/gcl_stack-problem.lsp create mode 100755 lsp/gcl_stdlisp.lsp create mode 100755 lsp/gcl_top.lsp create mode 100755 lsp/gcl_trace.lsp create mode 100755 lsp/gprof.hc create mode 100755 lsp/gprof1.lisp create mode 100755 lsp/gprof_aix.hc create mode 100755 lsp/make.lisp create mode 100644 lsp/makefile create mode 100755 lsp/sys-proclaim.lisp create mode 100755 lsp/ucall.lisp create mode 100755 lsp/ustreams.lisp create mode 100644 ltmain.sh create mode 100755 machines create mode 100755 majvers create mode 100755 makdefs create mode 100644 makedefc.in create mode 100644 makefile create mode 100755 man/man1/gcl.1 create mode 100755 merge.c create mode 100755 minvers create mode 100755 misc/check.c create mode 100755 misc/check_obj.c create mode 100755 misc/cstruct.lsp create mode 100755 misc/foreign.lsp create mode 100755 misc/mprotect.ch create mode 100755 misc/rusage.lsp create mode 100755 misc/test-seek.c create mode 100755 misc/test-sgc.lsp create mode 100755 misc/warn-slow.lsp create mode 100755 mp/fplus.c create mode 100755 mp/gcclab create mode 100755 mp/gcclab.awk create mode 100755 mp/gnulib1.c create mode 100755 mp/lo-ibmrt.s create mode 100755 mp/lo-rios.s create mode 100644 mp/lo-rios1.s create mode 100755 mp/lo-sgi4d.s create mode 100755 mp/lo-u370_aix.s create mode 100755 mp/make.defs create mode 100644 mp/makefile create mode 100755 mp/mp2.c create mode 100755 mp/mp_addmul.c create mode 100755 mp/mp_bfffo.c create mode 100755 mp/mp_dblrsl3.c create mode 100755 mp/mp_dblrul3.c create mode 100755 mp/mp_divul3.c create mode 100755 mp/mp_divul3_word.c create mode 100755 mp/mp_mulul3.c create mode 100755 mp/mp_shiftl.c create mode 100755 mp/mp_sl3todivul3.c create mode 100644 mp/mpi-386_no_under.s create mode 100755 mp/mpi-386d.S create mode 100755 mp/mpi-bsd68k.s create mode 100755 mp/mpi-sol-sparc.s create mode 100755 mp/mpi-sparc.s create mode 100755 mp/mpi.c create mode 100755 mp/readme create mode 100755 mp/sparcdivul3.s create mode 100755 o/ChangeLog create mode 100755 o/NeXTunixfasl.c create mode 100755 o/NeXTunixsave.c create mode 100755 o/Vmalloc.c create mode 100644 o/alloc.c create mode 100755 o/array.c create mode 100755 o/array.c.prev create mode 100755 o/array.c1 create mode 100755 o/assignment.c create mode 100755 o/backq.c create mode 100755 o/bcmp.c create mode 100755 o/bcopy.c create mode 100755 o/bds.c create mode 100755 o/before_init.c create mode 100755 o/big.c create mode 100755 o/bind.c create mode 100755 o/bind.texi create mode 100755 o/bitop.c create mode 100755 o/block.c create mode 100755 o/bsearch.c create mode 100755 o/bzero.c create mode 100755 o/catch.c create mode 100755 o/cfun.c create mode 100755 o/character.d create mode 100755 o/clxsocket.c create mode 100755 o/cmac.c create mode 100755 o/cmpaux.c create mode 100755 o/conditional.c create mode 100755 o/earith.c create mode 100755 o/egrep-def create mode 100755 o/error.c create mode 100755 o/eval.c create mode 100755 o/external_funs.h create mode 100755 o/fasdump.c create mode 100755 o/fasldlsym.c create mode 100755 o/fasldlsym.c.link create mode 100755 o/faslhp800.c create mode 100755 o/faslnt.c create mode 100755 o/faslsgi4.c create mode 100755 o/fat_string.c create mode 100755 o/file.d create mode 100755 o/firstfile.c create mode 100755 o/fix-structref.el create mode 100755 o/format.c create mode 100755 o/frame.c create mode 100755 o/funlink.c create mode 100755 o/funs create mode 100755 o/gbc.c create mode 100644 o/gcl_readline.d create mode 100755 o/gdb_commands create mode 100644 o/gmp.c create mode 100755 o/gmp_big.c create mode 100644 o/gmp_num_log.c create mode 100644 o/gmp_wrappers.c create mode 100755 o/gnumalloc.c create mode 100755 o/grab_defs.c create mode 100755 o/grab_defs.u create mode 100755 o/hash.d create mode 100755 o/help.el create mode 100755 o/init_pari.c create mode 100755 o/internal-calls.lisp create mode 100755 o/iteration.c create mode 100755 o/lastfile.c create mode 100755 o/let.c create mode 100755 o/lex.c create mode 100755 o/list.d create mode 100755 o/littleXwin.c create mode 100755 o/macros.c create mode 100755 o/main.c create mode 100644 o/makefile create mode 100755 o/makefun.c create mode 100755 o/malloc.c create mode 100755 o/mapfun.c create mode 100644 o/mingfile.c create mode 100755 o/mingwin.c create mode 100755 o/multival.c create mode 100755 o/mych create mode 100755 o/ndiv.c create mode 100755 o/nfunlink.c create mode 100755 o/nmul.c create mode 100644 o/nsocket.c create mode 100755 o/ntheap.h create mode 100755 o/num_arith.c create mode 100755 o/num_co.c create mode 100755 o/num_comp.c create mode 100755 o/num_log.c create mode 100755 o/num_pred.c create mode 100755 o/num_rand.c create mode 100755 o/num_sfun.c create mode 100755 o/number.c create mode 100755 o/package.d create mode 100755 o/pari_big.c create mode 100644 o/pari_num_log.c create mode 100755 o/pathname.d create mode 100755 o/peculiar.c create mode 100644 o/plt.c create mode 100644 o/plttest.c create mode 100755 o/pre_init.c create mode 100755 o/predicate.c create mode 100644 o/prelink.c create mode 100755 o/print.d create mode 100755 o/prog.c create mode 100755 o/read.d create mode 100755 o/readme create mode 100755 o/reference.c create mode 100755 o/regexp.c create mode 100755 o/regexp.h create mode 100755 o/regexpr.c create mode 100755 o/rel_aix.c create mode 100755 o/rel_coff.c create mode 100755 o/rel_hp300.c create mode 100755 o/rel_mac2.c create mode 100755 o/rel_ps2aix.c create mode 100755 o/rel_rios.c create mode 100755 o/rel_stand.c create mode 100755 o/rel_sun3.c create mode 100755 o/rel_sun4.c create mode 100755 o/rel_u370aix.c create mode 100755 o/run_process.c create mode 100755 o/save.c create mode 100755 o/save_sgi4.c create mode 100755 o/saveaix3.c create mode 100755 o/savedec31.c create mode 100755 o/saveu370.c create mode 100755 o/sbrk.c create mode 100755 o/sequence.d create mode 100755 o/sfasl.c create mode 100644 o/sfaslbfd.c create mode 100644 o/sfaslcoff.c create mode 100755 o/sfaslelf.c create mode 100755 o/sfasli.c create mode 100644 o/sfaslmacho.c create mode 100644 o/sfaslmacosx.c create mode 100755 o/sgbc.c create mode 100755 o/sgi4d_emul.s create mode 100755 o/sockets.c create mode 100755 o/strcspn.c create mode 100755 o/string.d create mode 100755 o/structure.c create mode 100755 o/symbol.d create mode 100755 o/test_memprotect.c create mode 100755 o/toplevel.c create mode 100755 o/try.c create mode 100755 o/typespec.c create mode 100755 o/u370_emul.s create mode 100644 o/unexaix.c create mode 100755 o/unexec-19.29.c create mode 100755 o/unexec.c create mode 100755 o/unexelf.c create mode 100755 o/unexelfsgi.c create mode 100755 o/unexhp9k800.c create mode 100755 o/unexlin.c create mode 100644 o/unexmacosx.c create mode 100755 o/unexmips.c create mode 100755 o/unexnt.c create mode 100755 o/unexsgi.c create mode 100755 o/unixfasl.c create mode 100755 o/unixfsys.c create mode 100755 o/unixsave.c create mode 100755 o/unixsys.c create mode 100755 o/unixtime.c create mode 100755 o/user_init.c create mode 100644 o/user_match.c create mode 100755 o/usig.c create mode 100755 o/usig2.c create mode 100755 o/usig2_aux.c create mode 100755 o/utils.c create mode 100755 o/xdrfuns.c create mode 100644 pcl/README create mode 100644 pcl/defsys.lisp create mode 100644 pcl/extensions/extensions.lisp create mode 100644 pcl/extensions/inline.lisp create mode 100644 pcl/extensions/user-instances.lisp create mode 100644 pcl/gcl_pcl_boot.lisp create mode 100644 pcl/gcl_pcl_braid.lisp create mode 100644 pcl/gcl_pcl_cache.lisp create mode 100644 pcl/gcl_pcl_combin.lisp create mode 100644 pcl/gcl_pcl_compat.lisp create mode 100644 pcl/gcl_pcl_cpl.lisp create mode 100644 pcl/gcl_pcl_ctypes.lisp create mode 100644 pcl/gcl_pcl_defclass.lisp create mode 100644 pcl/gcl_pcl_defcombin.lisp create mode 100644 pcl/gcl_pcl_defs.lisp create mode 100644 pcl/gcl_pcl_dfun.lisp create mode 100644 pcl/gcl_pcl_dlisp.lisp create mode 100644 pcl/gcl_pcl_dlisp2.lisp create mode 100644 pcl/gcl_pcl_env.lisp create mode 100644 pcl/gcl_pcl_fast_init.lisp create mode 100644 pcl/gcl_pcl_fin.lisp create mode 100644 pcl/gcl_pcl_fixup.lisp create mode 100644 pcl/gcl_pcl_fngen.lisp create mode 100644 pcl/gcl_pcl_fsc.lisp create mode 100644 pcl/gcl_pcl_generic_functions.lisp create mode 100644 pcl/gcl_pcl_init.lisp create mode 100644 pcl/gcl_pcl_iterate.lisp create mode 100644 pcl/gcl_pcl_low.lisp create mode 100644 pcl/gcl_pcl_macros.lisp create mode 100644 pcl/gcl_pcl_methods.lisp create mode 100644 pcl/gcl_pcl_pkg.lisp create mode 100644 pcl/gcl_pcl_precom1.lisp create mode 100644 pcl/gcl_pcl_precom2.lisp create mode 100644 pcl/gcl_pcl_slots.lisp create mode 100644 pcl/gcl_pcl_slots_boot.lisp create mode 100644 pcl/gcl_pcl_std_class.lisp create mode 100644 pcl/gcl_pcl_vector.lisp create mode 100644 pcl/gcl_pcl_walk.lisp create mode 100644 pcl/impl/cmu/README create mode 100644 pcl/impl/cmu/cmu-low.lisp create mode 100644 pcl/impl/cmu/pclcom.lisp create mode 100644 pcl/impl/cmu/pclload.lisp create mode 100644 pcl/impl/coral/coral-low.lisp create mode 100644 pcl/impl/franz/cpatch.lisp create mode 100644 pcl/impl/franz/excl-low.lisp create mode 100644 pcl/impl/franz/quadlap.lisp create mode 100644 pcl/impl/gcl/README create mode 100644 pcl/impl/gcl/gcl-low.lisp create mode 100644 pcl/impl/gcl/gcl-patches.lisp create mode 100644 pcl/impl/gcl/gcl_pcl_impl_low.lisp create mode 100644 pcl/impl/gcl/makefile.gcl create mode 100644 pcl/impl/gcl/sys-package.lisp create mode 100644 pcl/impl/gcl/sys-proclaim.lisp create mode 100644 pcl/impl/gold-hill/gold-low.lisp create mode 100644 pcl/impl/gold-hill/gold-patches.lisp create mode 100644 pcl/impl/hp/hp-low.lisp create mode 100644 pcl/impl/ibcl/ibcl-low.lisp create mode 100644 pcl/impl/ibcl/ibcl-patches.lisp create mode 100644 pcl/impl/kcl/kcl-low.lisp create mode 100644 pcl/impl/kcl/kcl-mods.text create mode 100644 pcl/impl/kcl/kcl-notes.text create mode 100644 pcl/impl/kcl/kcl-patches.lisp create mode 100644 pcl/impl/kcl/makefile.akcl create mode 100644 pcl/impl/kcl/misc-kcl-patches.text create mode 100644 pcl/impl/kcl/new-kcl-wrapper.text create mode 100644 pcl/impl/kcl/sys-package.lisp create mode 100644 pcl/impl/kcl/sys-proclaim.lisp create mode 100644 pcl/impl/kcl/sysdef.lisp create mode 100644 pcl/impl/lucid/lucid-low.lisp create mode 100644 pcl/impl/pyramid/pyr-low.lisp create mode 100644 pcl/impl/pyramid/pyr-patches.lisp create mode 100644 pcl/impl/symbolics/cloe-low.lisp create mode 100644 pcl/impl/symbolics/genera-low.lisp create mode 100644 pcl/impl/symbolics/rel-7-2-patches.lisp create mode 100644 pcl/impl/symbolics/rel-8-patches.lisp create mode 100644 pcl/impl/ti/ti-low.lisp create mode 100644 pcl/impl/ti/ti-patches.lisp create mode 100644 pcl/impl/vaxlisp/vaxl-low.lisp create mode 100644 pcl/impl/xerox/pcl-env-internal.lisp create mode 100644 pcl/impl/xerox/pcl-env.lisp create mode 100644 pcl/impl/xerox/pcl-env.text create mode 100644 pcl/impl/xerox/xerox-low.lisp create mode 100644 pcl/impl/xerox/xerox-patches.lisp create mode 100644 pcl/makefile create mode 100644 pcl/notes/12-7-88-notes.text create mode 100644 pcl/notes/3-17-88-notes.text create mode 100644 pcl/notes/3-19-87-notes.text create mode 100644 pcl/notes/4-21-87-notes.text create mode 100644 pcl/notes/4-29-87-notes.text create mode 100644 pcl/notes/5-22-87-notes.text create mode 100644 pcl/notes/5-22-89-notes.text create mode 100644 pcl/notes/8-28-88-notes.text create mode 100644 pcl/notes/get-pcl.text create mode 100644 pcl/notes/lap.text create mode 100644 pcl/notes/may-day-notes.text create mode 100644 pcl/notes/notes.text create mode 100644 pcl/notes/readme.text create mode 100644 pcl/old/construct.lisp create mode 100644 pcl/old/dlap.lisp create mode 100644 pcl/old/lap.lisp create mode 100644 pcl/old/plap.lisp create mode 100644 pcl/pcl_methods.patch create mode 100644 pcl/sys-package.lisp create mode 100644 pcl/sys-proclaim.lisp create mode 100644 pcl/test/bench-precompile.lisp create mode 100644 pcl/test/bench.lisp create mode 100644 pcl/test/bench.out create mode 100644 pcl/test/list-functions.lisp create mode 100644 pcl/test/make-test.lisp create mode 100644 pcl/test/makediff create mode 100644 pcl/test/time.lisp create mode 100644 pcl/unused/precom4.lisp create mode 100644 readme create mode 100644 readme-bin.mingw create mode 100644 readme.gmp create mode 100755 readme.mingw create mode 100644 readme.xgcl create mode 100755 unixport/aix-crt0.el create mode 100755 unixport/aix_exports create mode 100644 unixport/ansi_cl.lisp create mode 100755 unixport/boots create mode 100755 unixport/bsd_rsym.c create mode 100755 unixport/cmpboots create mode 100755 unixport/gcldos.lsp create mode 100755 unixport/gcrt0.el create mode 100644 unixport/init_ansi_gcl.lsp.in create mode 100644 unixport/init_gcl.lsp.in create mode 100644 unixport/init_pcl_gcl.lsp.in create mode 100644 unixport/init_pre_gcl.lsp.in create mode 100755 unixport/lspboots create mode 100644 unixport/make_kcn create mode 100644 unixport/makefile create mode 100755 unixport/makefile.dos create mode 100644 unixport/msys.c create mode 100755 unixport/ncrt0.el create mode 100755 unixport/rsym.c create mode 100755 unixport/rsym_elf.c create mode 100644 unixport/rsym_macosx.c create mode 100755 unixport/rsym_nt.c create mode 100755 unixport/so_locations create mode 100755 unixport/sys-init.lsp create mode 100644 unixport/sys.c create mode 100644 unixport/sys_ansi_gcl.c create mode 100755 unixport/sys_boot.c create mode 100755 unixport/sys_gcl.c create mode 100755 unixport/sys_kcn.c create mode 100644 unixport/sys_pcl_gcl.c create mode 100755 unixport/sys_pre_gcl.c create mode 100755 unixport/tryserv.tcl create mode 100755 utils/replace create mode 100755 utils/repls1.sed create mode 100755 utils/repls2.sed create mode 100755 utils/repls3.sed create mode 100755 utils/repls4.sed create mode 100755 utils/repls5.sed create mode 100755 utils/revstruct.sed create mode 100644 windows/gcl.iss.in create mode 100644 windows/install.lsp.in create mode 100755 windows/instdos.sh create mode 100644 windows/sysdir.bat.in create mode 100755 xbin/386-linux-fix create mode 100755 xbin/add-dir create mode 100755 xbin/append create mode 100755 xbin/append.bat create mode 100755 xbin/comp_rel create mode 100755 xbin/compare-src create mode 100755 xbin/compare.c create mode 100755 xbin/dfiles create mode 100755 xbin/distrib-help create mode 100755 xbin/distribute create mode 100755 xbin/dos-files create mode 100755 xbin/dosmake.bat create mode 100755 xbin/exists create mode 100755 xbin/fix-copyright create mode 100755 xbin/get-externals create mode 100755 xbin/get-internal-calls create mode 100755 xbin/get-machine create mode 100755 xbin/ibm create mode 100755 xbin/if-exist.bat create mode 100755 xbin/if-exists create mode 100755 xbin/if-have-gcc create mode 100755 xbin/inc-version create mode 100755 xbin/is-V-newest create mode 100755 xbin/make-fn create mode 100755 xbin/maketest create mode 100755 xbin/maketest1 create mode 100755 xbin/move-if-changed create mode 100755 xbin/new-files create mode 100755 xbin/notify create mode 100755 xbin/setup-tmptest create mode 100755 xbin/spp.c create mode 100755 xbin/strip-ifdef create mode 100755 xbin/test create mode 100755 xbin/test-distrib create mode 100755 xbin/test1 create mode 100755 xbin/update create mode 100644 xgcl-2/Events.c create mode 100644 xgcl-2/README create mode 100644 xgcl-2/XStruct-2.c create mode 100644 xgcl-2/XStruct-4.c create mode 100644 xgcl-2/Xakcl.paper create mode 100644 xgcl-2/Xutil-2.c create mode 100644 xgcl-2/dec.copyright create mode 100644 xgcl-2/dwdoc.pdf create mode 100644 xgcl-2/dwdoc.tex create mode 100644 xgcl-2/dwdoc/dwdoc1.html create mode 100644 xgcl-2/dwdoc/dwdoc2.html create mode 100644 xgcl-2/dwdoc/dwdoc3.html create mode 100644 xgcl-2/dwdoc/dwdoccontents.html create mode 100644 xgcl-2/dwdoc/dwdocindex.html create mode 100644 xgcl-2/gcl_X.lsp create mode 100644 xgcl-2/gcl_X10.lsp create mode 100644 xgcl-2/gcl_XAtom.lsp create mode 100644 xgcl-2/gcl_XStruct_l_3.lsp create mode 100644 xgcl-2/gcl_Xakcl.example.lsp create mode 100644 xgcl-2/gcl_Xinit.lsp create mode 100644 xgcl-2/gcl_Xlib.lsp create mode 100644 xgcl-2/gcl_Xstruct.lsp create mode 100644 xgcl-2/gcl_Xutil.lsp create mode 100644 xgcl-2/gcl_defentry_events.lsp create mode 100644 xgcl-2/gcl_dispatch-events.lsp create mode 100644 xgcl-2/gcl_draw-gates.lsp create mode 100644 xgcl-2/gcl_draw.lsp create mode 100644 xgcl-2/gcl_drawtrans.lsp create mode 100644 xgcl-2/gcl_dwexports.lsp create mode 100644 xgcl-2/gcl_dwimports.lsp create mode 100644 xgcl-2/gcl_dwimportsb.lsp create mode 100644 xgcl-2/gcl_dwindow.lsp create mode 100644 xgcl-2/gcl_dwsyms.lsp create mode 100644 xgcl-2/gcl_dwtest.lsp create mode 100644 xgcl-2/gcl_dwtestcases.lsp create mode 100644 xgcl-2/gcl_dwtrans.lsp create mode 100644 xgcl-2/gcl_editors.lsp create mode 100644 xgcl-2/gcl_editorstrans.lsp create mode 100644 xgcl-2/gcl_general.lsp create mode 100644 xgcl-2/gcl_ice-cream.lsp create mode 100644 xgcl-2/gcl_imports.lsp create mode 100644 xgcl-2/gcl_index.lsp create mode 100644 xgcl-2/gcl_init_xgcl.lsp create mode 100644 xgcl-2/gcl_keysymdef.lsp create mode 100644 xgcl-2/gcl_lispserver.lsp create mode 100644 xgcl-2/gcl_lispservertrans.lsp create mode 100644 xgcl-2/gcl_menu-set.lsp create mode 100644 xgcl-2/gcl_menu-settrans.lsp create mode 100644 xgcl-2/gcl_pcalc.lsp create mode 100644 xgcl-2/gcl_sysinit.lsp create mode 100644 xgcl-2/gcl_tohtml.lsp create mode 100644 xgcl-2/general-c.c create mode 100644 xgcl-2/gnu.license create mode 100644 xgcl-2/makefile create mode 100644 xgcl-2/sysdef.lisp create mode 100644 xgcl-2/version diff --git a/AC_FD_CC b/AC_FD_CC new file mode 100644 index 0000000..80cb3b6 --- /dev/null +++ b/AC_FD_CC @@ -0,0 +1,10 @@ +#line 40 "configure" +#include "confdefs.h" +#include +main() +{ + char *b = (void *) malloc(1000); + FILE *fp = fopen("conftest1","w"); + fprintf(fp,"0x%x",((unsigned int) b) & ~0xffffff); + fclose(fp); +} diff --git a/AC_FD_MSG b/AC_FD_MSG new file mode 100644 index 0000000..5888ea1 --- /dev/null +++ b/AC_FD_MSG @@ -0,0 +1 @@ +got 0 diff --git a/COPYING.LIB-2.0 b/COPYING.LIB-2.0 new file mode 100755 index 0000000..eb685a5 --- /dev/null +++ b/COPYING.LIB-2.0 @@ -0,0 +1,481 @@ + GNU LIBRARY GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1991 Free Software Foundation, Inc. + 675 Mass Ave, Cambridge, MA 02139, USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the library GPL. It is + numbered 2 because it goes with version 2 of the ordinary GPL.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Library General Public License, applies to some +specially designated Free Software Foundation software, and to any +other libraries whose authors decide to use it. You can use it for +your libraries, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if +you distribute copies of the library, or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link a program with the library, you must provide +complete object files to the recipients so that they can relink them +with the library, after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + Our method of protecting your rights has two steps: (1) copyright +the library, and (2) offer you this license which gives you legal +permission to copy, distribute and/or modify the library. + + Also, for each distributor's protection, we want to make certain +that everyone understands that there is no warranty for this free +library. If the library is modified by someone else and passed on, we +want its recipients to know that what they have is not the original +version, so that any problems introduced by others will not reflect on +the original authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that companies distributing free +software will individually obtain patent licenses, thus in effect +transforming the program into proprietary software. To prevent this, +we have made it clear that any patent must be licensed for everyone's +free use or not licensed at all. + + Most GNU software, including some libraries, is covered by the ordinary +GNU General Public License, which was designed for utility programs. This +license, the GNU Library General Public License, applies to certain +designated libraries. This license is quite different from the ordinary +one; be sure to read it in full, and don't assume that anything in it is +the same as in the ordinary license. + + The reason we have a separate public license for some libraries is that +they blur the distinction we usually make between modifying or adding to a +program and simply using it. Linking a program with a library, without +changing the library, is in some sense simply using the library, and is +analogous to running a utility program or application program. However, in +a textual and legal sense, the linked executable is a combined work, a +derivative of the original library, and the ordinary General Public License +treats it as such. + + Because of this blurred distinction, using the ordinary General +Public License for libraries did not effectively promote software +sharing, because most developers did not use the libraries. We +concluded that weaker conditions might promote sharing better. + + However, unrestricted linking of non-free programs would deprive the +users of those programs of all benefit from the free status of the +libraries themselves. This Library General Public License is intended to +permit developers of non-free programs to use free libraries, while +preserving your freedom as a user of such programs to change the free +libraries that are incorporated in them. (We have not seen how to achieve +this as regards changes in header files, but we have achieved it as regards +changes in the actual functions of the Library.) The hope is that this +will lead to faster development of free libraries. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, while the latter only +works together with the library. + + Note that it is possible for a library to be covered by the ordinary +General Public License rather than by this special one. + + GNU LIBRARY GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library which +contains a notice placed by the copyright holder or other authorized +party saying it may be distributed under the terms of this Library +General Public License (also called "this License"). Each licensee is +addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control compilation +and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also compile or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + c) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + d) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the source code distributed need not include anything that is normally +distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under any +particular circumstance, the balance of the section is intended to apply, +and the section as a whole is intended to apply in other circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License may add +an explicit geographical distribution limitation excluding those countries, +so that distribution is permitted only in or among countries not thus +excluded. In such case, this License incorporates the limitation as if +written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Library General Public License from time to time. +Such new versions will be similar in spirit to the present version, +but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY +KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU +FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS + + Appendix: How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms of the +ordinary General Public License). + + To apply these terms, attach the following notices to the library. It is +safest to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free + Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the library, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James Random Hacker. + + , 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! diff --git a/ChangeLog b/ChangeLog new file mode 100755 index 0000000..69c2b72 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,532 @@ +2006-10-26 Gabriel Dos Reis + + * configure.in: Don't be overly eager about setting INFO_DIR. + Fix quotations, as new Autoconf are pickier. + + * configure: Regenerate. + +2002-01-25 Camm Maguire + + * /cvsroot/gcl/gcl/ChangeLog, /cvsroot/gcl/gcl/ChangeLog.orig: + *** empty log message *** + +2002-01-24 Camm Maguire + + * /cvsroot/gcl/gcl/o/alloc.c, /cvsroot/gcl/gcl/o/sfaslelf.c: + Get bfd initialization to bypass malloc + + * /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/sys_gcl.c, /cvsroot/gcl/gcl/lsp/defpackage.c, /cvsroot/gcl/gcl/lsp/defpackage.data, /cvsroot/gcl/gcl/lsp/defpackage.h, /cvsroot/gcl/gcl/lsp/defpackage.lsp, /cvsroot/gcl/gcl/lsp/make_defpackage.c, /cvsroot/gcl/gcl/lsp/make_defpackage.data, /cvsroot/gcl/gcl/lsp/make_defpackage.h, /cvsroot/gcl/gcl/lsp/make_defpackage.lsp, /cvsroot/gcl/gcl/lsp/makefile: + Defpackage support + +2002-01-23 Camm Maguire + + * /cvsroot/gcl/gcl/o/mingfile.c, /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/h/minglacks.h, /cvsroot/gcl/gcl/h/mingw.h: + Mingw support fixes + +2002-01-20 Camm Maguire + + * /cvsroot/gcl/gcl/gcl.png: gif -> png for logo + +2002-01-18 Camm Maguire + + * /cvsroot/gcl/gcl/lsp/destructuring_bind.c, /cvsroot/gcl/gcl/lsp/destructuring_bind.data, /cvsroot/gcl/gcl/lsp/destructuring_bind.h, /cvsroot/gcl/gcl/lsp/destructuring_bind.lsp, /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/sys_gcl.c: + Add support for destructuring-bind + +2002-01-15 Camm Maguire + + * /cvsroot/gcl/gcl/h/gnuwin95.h, /cvsroot/gcl/gcl/o/unexnt.c: + Changes to get a preliminary NT build + +2002-01-13 Camm Maguire + + * /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in: + Emacs site list dir fix + +2002-01-11 Camm Maguire + + * /cvsroot/gcl/gcl/cmpnew/lfun_list.lsp, /cvsroot/gcl/gcl/h/new_decl.h, /cvsroot/gcl/gcl/lsp/stdlisp.lsp, /cvsroot/gcl/gcl/o/main.c, /cvsroot/gcl/gcl/o/new_init.c: + Added (quit) and (exit) as synonyms to (bye) + + * /cvsroot/gcl/gcl/gmp/assert.c, /cvsroot/gcl/gcl/gmp/extract-dbl.c, /cvsroot/gcl/gcl/gmp/gmp-impl.h, /cvsroot/gcl/gcl/gmp/mpn/generic/gcdext.c, /cvsroot/gcl/gcl/gmp/mpn/generic/tdiv_qr.c, /cvsroot/gcl/gcl/gmp/mpn/tests/addmul_1.c, /cvsroot/gcl/gcl/gmp/mpn/tests/add_n.c, /cvsroot/gcl/gcl/gmp/mpn/tests/copy.c, /cvsroot/gcl/gcl/gmp/mpn/tests/divmod_1.c, /cvsroot/gcl/gcl/gmp/mpn/tests/divrem.c, /cvsroot/gcl/gcl/gmp/mpn/tests/lshift.c, /cvsroot/gcl/gcl/gmp/mpn/tests/Makefile.in, /cvsroot/gcl/gcl/gmp/mpn/tests/mul_1.c, /cvsroot/gcl/gcl/gmp/mpn/tests/rshift.c, /cvsroot/gcl/gcl/gmp/mpn/tests/submul_1.c, /cvsroot/gcl/gcl/gmp/mpn/tests/sub_n.c, /cvsroot/gcl/gcl/gmp/mpz/bin_uiui.c, /cvsroot/gcl/gcl/gmp/mpz/fac_ui.c, /cvsroot/gcl/gcl/gmp/mpz/pprime_p.c, /cvsroot/gcl/gcl/gmp/mpz/root.c, /cvsroot/gcl/gcl/gmp/mpz/set_d.c, /cvsroot/gcl/gcl/gmp/mpz/tests/bit.c, /cvsroot/gcl/gcl/gmp/mpz/tests/convert.c, /cvsroot/gcl/gcl/gmp/mpz/tests/dive.c, /cvsroot/gcl/gcl/gmp/mpz/tests/io.c, /cvsroot/gcl/gcl/gmp/mpz/tests/logic.c, /cvsroot/gcl/gcl/gmp/mpz/tests/Makefile.in, /cvsroot/gcl/gcl/gmp/mpz/tests/reuse.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-2exp.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-bin.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-fdiv.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-fdiv_ui.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-gcd.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-jac.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-misc.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-mul.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-powm.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-powm_ui.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-pow_ui.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-root.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-sqrtrem.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-tdiv.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-tdiv_ui.c, /cvsroot/gcl/gcl/gmp/randlc.c, /cvsroot/gcl/gcl/gmp/randraw.c, /cvsroot/gcl/gcl/gmp/urandom.h: + Changes submitted by Robert Byer for VMS (thanks\!) + +2002-01-10 Camm Maguire + + * /cvsroot/gcl/gcl/o/eval.c, /cvsroot/gcl/gcl/o/funlink.c, /cvsroot/gcl/gcl/h/object.h: + Fix function definitions to be more portable, enables build on m68k + +2002-01-09 Camm Maguire + + * /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in: + Need 'return 0' at end of tests for DBEGIN and CSTACK_ADDRESS for sparc + + * /cvsroot/gcl/gcl/info/makefile: + Removed info files from tree, created now at build time from texi files + +2002-01-08 Camm Maguire + + * /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in: + Better arm config support + + * /cvsroot/gcl/gcl/h/arm-linux.defs, /cvsroot/gcl/gcl/h/arm-linux.h, /cvsroot/gcl/gcl/h/m68k-linux.defs, /cvsroot/gcl/gcl/h/m68k-linux.h: + New arm and m68k machine files + + * /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in: + Added configuration support for linux architectures + +2002-01-07 Camm Maguire + + * /cvsroot/gcl/gcl/h/gclincl.h.in, /cvsroot/gcl/gcl/h/notcomp.h, /cvsroot/gcl/gcl/o/sfasl.c, /cvsroot/gcl/gcl/o/sfaslelf.c, /cvsroot/gcl/gcl/o/sfasli.c, /cvsroot/gcl/gcl/acconfig.h: + BFD library support for relocations + + * /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in: + Changes to better detect tcl/tk locations + + * /cvsroot/gcl/gcl/h/386-linux.defs: + Optimization flags by default in 386-linux.defs + + * /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/bin/gcl, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/h/386-linux.defs, /cvsroot/gcl/gcl/h/386-linux.h, /cvsroot/gcl/gcl/info/gcl-si.info, /cvsroot/gcl/gcl/info/gcl-tk.info, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/o/alloc.c, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/makefile: + Removed some build-generated files + +2002-01-06 Camm Maguire + + * /cvsroot/gcl/gcl/o/main.c, /cvsroot/gcl/gcl/o/unexelf.c, /cvsroot/gcl/gcl/unixport/rsym_elf.c: + Refinement to max stack size handling, better fix to unexelf section numbering bug, revert sigsetjmp change in rsym_elf.c + + * /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in: + configure changes to detect newer as well as older tcl/tk libraries + + * /cvsroot/gcl/gcl/o/unexelf.c: + Protect against sh_info=0, causing occasional segfaults, in unexelf.c + +2002-01-04 Camm Maguire + + * /cvsroot/gcl/gcl/unixport/rsym_elf.c: + _setjmp -> __sigsetjmp for glibc systems in rsym_elf.c + + * /cvsroot/gcl/gcl/o/main.c: + Protect against unlimited stack resource environments + + * /cvsroot/gcl/gcl/unixport/rsym_elf.c: + _setjmp -> __sigsetjmp for glibc systems in rsym_elf.c + +2001-12-29 Camm Maguire + + * /cvsroot/gcl/gcl/ChangeLog: *** empty log message *** + + * /cvsroot/gcl/gcl/unixport/makefile: + Added DESTDIR to makefiles to support installing under arbitrary subdir; good 'clean' targets; correct building in absense of tcl/tk + + * /cvsroot/gcl/gcl/gcl-tk/makefile: + Add gcl-tk/demos/index.lsp to clean target + + * /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/makefile: + Added DESTDIR to makefiles to support installing under arbitrary subdir; good 'clean' targets; correct building in absense of tcl/tk + + * /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/elisp/makefile: + changes to configure.in and elisp/makefile to handle emacs not being present + + * /cvsroot/gcl/gcl/gmp/ltconfig: + fix to gmp/ltconfig to avoid exec'ing empty string + + * /cvsroot/gcl/gcl/gmp/configure, /cvsroot/gcl/gcl/gmp/configure.in: + gmp/configure.in update for darwin + + * /cvsroot/gcl/gcl/gmp/ltconfig: + fix to gmp/ltconfig to avoid exec'ing empty string + + * /cvsroot/gcl/gcl/gmp/configure, /cvsroot/gcl/gcl/gmp/configure.in: + gmp/configure.in update for darwin + +2001-12-21 Camm Maguire + + * /cvsroot/gcl/gcl/debian/changelog, /cvsroot/gcl/gcl/debian/control, /cvsroot/gcl/gcl/debian/emacsen-startup, /cvsroot/gcl/gcl/debian/gcl-doc.dirs, /cvsroot/gcl/gcl/debian/gcl-doc.doc-base.si, /cvsroot/gcl/gcl/debian/gcl-doc.doc-base.tk, /cvsroot/gcl/gcl/debian/rules, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/debian/copyright, /cvsroot/gcl/gcl/debian/emacsen-install, /cvsroot/gcl/gcl/debian/emacsen-remove, /cvsroot/gcl/gcl/debian/gcl.dirs, /cvsroot/gcl/gcl/debian/gcl-doc.doc-base, /cvsroot/gcl/gcl/debian/gcl-doc.docs, /cvsroot/gcl/gcl/debian/gcl-doc.files, /cvsroot/gcl/gcl/debian/gcl.files, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/info/texinfo.tex, /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/man/man1/gcl.1, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/makefile: + Many changes to get Debian package to build cleanly + +2001-12-20 Camm Maguire + + * /cvsroot/gcl/gcl/ChangeLog: remove more build-generated files + + * /cvsroot/gcl/gcl/h/gnuwin95.h: Apply fopen patch + + * /cvsroot/gcl/gcl/debian/all-files, /cvsroot/gcl/gcl/debian/changelog, /cvsroot/gcl/gcl/debian/clean, /cvsroot/gcl/gcl/debian/control, /cvsroot/gcl/gcl/debian/control.withtk, /cvsroot/gcl/gcl/debian/copyright, /cvsroot/gcl/gcl/debian/dirs, /cvsroot/gcl/gcl/debian/docs, /cvsroot/gcl/gcl/debian/gcl-doc.info, /cvsroot/gcl/gcl/debian/gcl.substvars, /cvsroot/gcl/gcl/debian/manpages, /cvsroot/gcl/gcl/debian/postinst, /cvsroot/gcl/gcl/debian/rules, /cvsroot/gcl/gcl/debian/texi.awk: + Initial upload of debian package building subdir + + * /cvsroot/gcl/gcl/tests/alltest.tst, /cvsroot/gcl/gcl/tests/array.tst, /cvsroot/gcl/gcl/tests/backquot.tst, /cvsroot/gcl/gcl/tests/characters.tst, /cvsroot/gcl/gcl/tests/eval20.tst, /cvsroot/gcl/gcl/tests/format.tst, /cvsroot/gcl/gcl/tests/GNU-GPL, /cvsroot/gcl/gcl/tests/hashlong.tst, /cvsroot/gcl/gcl/tests/hash.tst, /cvsroot/gcl/gcl/tests/iofkts.tst, /cvsroot/gcl/gcl/tests/lambda.tst, /cvsroot/gcl/gcl/tests/lists151.tst, /cvsroot/gcl/gcl/tests/lists152.tst, /cvsroot/gcl/gcl/tests/lists153.tst, /cvsroot/gcl/gcl/tests/lists154.tst, /cvsroot/gcl/gcl/tests/lists155.tst, /cvsroot/gcl/gcl/tests/lists156.tst, /cvsroot/gcl/gcl/tests/macro8.tst, /cvsroot/gcl/gcl/tests/Makefile, /cvsroot/gcl/gcl/tests/map.tst, /cvsroot/gcl/gcl/tests/number.tst, /cvsroot/gcl/gcl/tests/pack11.tst, /cvsroot/gcl/gcl/tests/path.tst, /cvsroot/gcl/gcl/tests/README, /cvsroot/gcl/gcl/tests/readtable.tst, /cvsroot/gcl/gcl/tests/setf.tst, /cvsroot/gcl/gcl/tests/steele7.tst, /cvsroot/gcl/gcl/tests/streamslong.tst, /cvsroot/gcl/gcl/tests/streams.tst, /cvsroot/gcl/gcl/tests/strings.tst, /cvsroot/gcl/gcl/tests/symbol10.tst, /cvsroot/gcl/gcl/tests/symbols.tst, /cvsroot/gcl/gcl/tests/tests.lsp, /cvsroot/gcl/gcl/tests/tprint.tst, /cvsroot/gcl/gcl/tests/tread.tst, /cvsroot/gcl/gcl/tests/type.tst: + Initial upload of cltl1 tests used by clisp -- needs #+ and #- for gcl + + * /cvsroot/gcl/gcl/makefile: Make distclean on gmp non-fatal + + * /cvsroot/gcl/gcl/info/compile.texi, /cvsroot/gcl/gcl/info/io.texi, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/info/number.texi, /cvsroot/gcl/gcl/info/sequence.texi, /cvsroot/gcl/gcl/info/si-defs.texi: + Clean target for docs, build all docs, fix texinfo errors + + * /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/makefile: + Got clean targets working so as not to leave any non-CVS files in tree after build (and clean) + + * /cvsroot/gcl/gcl/makefile: + Fixed makefile to build without tcl/tk if not found in configure + + * /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/gcl-tk/demos/index.lsp, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/h/386-linux.defs, /cvsroot/gcl/gcl/h/cmpinclude.h, /cvsroot/gcl/gcl/h/gclincl.h, /cvsroot/gcl/gcl/h/gclincl.h.in, /cvsroot/gcl/gcl/info/gcl-tk.info, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/lsp/readline.c, /cvsroot/gcl/gcl/lsp/readline.data, /cvsroot/gcl/gcl/lsp/readline.h, /cvsroot/gcl/gcl/lsp/readline.lsp, /cvsroot/gcl/gcl/lsp/serror.c, /cvsroot/gcl/gcl/lsp/serror.data, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/o/cmpinclude.h, /cvsroot/gcl/gcl/o/main.c, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/o/readline.d, /cvsroot/gcl/gcl/unixport/init_gcl.lsp, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/acconfig.h, /cvsroot/gcl/gcl/bin/gcl, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/makedefc.in, /cvsroot/gcl/gcl/makefile, /cvsroot/gcl/gcl/minvers: + Integrated dynamic readline support, activated at runtime with (si::init-readline) + +2001-12-19 Camm Maguire + + * /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/o/file.d, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/unixport/init_gcl.lsp, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/h/gclincl.h, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/makefile: + Merge bugfixes from current + +2001-12-18 Camm Maguire + + * /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in: + FCNTL check opens bad file 'jim', now opens configure.in read-only + + * /cvsroot/gcl/gcl/o/big.c, /cvsroot/gcl/gcl/o/cmpaux.c, /cvsroot/gcl/gcl/o/fasldlsym.c, /cvsroot/gcl/gcl/o/fat_string.c, /cvsroot/gcl/gcl/o/main.c, /cvsroot/gcl/gcl/o/print.d, /cvsroot/gcl/gcl/o/symbol.d, /cvsroot/gcl/gcl/o/try.c, /cvsroot/gcl/gcl/o/unixfsys.c, /cvsroot/gcl/gcl/unixport/rsym_nt.c, /cvsroot/gcl/gcl/unixport/tryserv.tcl, /cvsroot/gcl/gcl/bin/append.c, /cvsroot/gcl/gcl/bin/dpp.c, /cvsroot/gcl/gcl/bin/file-sub.c, /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/elisp/smart-complete.el, /cvsroot/gcl/gcl/gcl-tk/decode.tcl, /cvsroot/gcl/gcl/gcl-tk/gcltksrv.in.interp, /cvsroot/gcl/gcl/gcl-tk/ngcltksrv, /cvsroot/gcl/gcl/gcl-tk/tinfo.c, /cvsroot/gcl/gcl/h/coff/i386.h, /cvsroot/gcl/gcl/h/cyglacks.h, /cvsroot/gcl/gcl/h/gnuwin95.defs, /cvsroot/gcl/gcl/h/gnuwin95.h, /cvsroot/gcl/gcl/h/num_include.h, /cvsroot/gcl/gcl/info/control.texi, /cvsroot/gcl/gcl/info/gcl-si.texi, /cvsroot/gcl/gcl/makdefs, /cvsroot/gcl/gcl/readme.mingw: + Merge current bugfixes into 2.5.0 + + * /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in: + s/cygwin32/ cygwin\*/ in configure + + * /cvsroot/gcl/gcl/h/gnuwin95.defs: Tidy up h/gnuwin95.defs + + * /cvsroot/gcl/gcl/h/cyglacks.h: Remove cruft from h/cyglacks.h + + * /cvsroot/gcl/gcl/h/gnuwin95.h: Tidy up h/gnuwin95.defs + + * /cvsroot/gcl/gcl/h/coff/i386.h: Remove cruft from h/coff/i386.h + + * /cvsroot/gcl/gcl/o/print.d: Prototype definition for coerce_stream + + * /cvsroot/gcl/gcl/o/fat_string.c: + Compiler warning cleanup, strings end with char 0, not NULL + + * /cvsroot/gcl/gcl/info/control.texi, /cvsroot/gcl/gcl/info/gcl-si.texi: + Minor changes to .texi files to compile cleanly on standard texinfo installations + + * /cvsroot/gcl/gcl/h/num_include.h: + Clear up a compiler warning with MOST_NEGATIVE_FIX + + * /cvsroot/gcl/gcl/gcl-tk/gcltksrv.in.interp, /cvsroot/gcl/gcl/gcl-tk/ngcltksrv: + Remove version dependence on wish in shell scripts -- if need a dependency, will put in configure later + + * /cvsroot/gcl/gcl/elisp/smart-complete.el: + Rename split-string to split-string-gcl to avoid name conflicts with other elisp packages + + * /cvsroot/gcl/gcl/bin/dpp.c, /cvsroot/gcl/gcl/bin/file-sub.c, /cvsroot/gcl/gcl/o/cmpaux.c, /cvsroot/gcl/gcl/o/fasldlsym.c, /cvsroot/gcl/gcl/o/main.c, /cvsroot/gcl/gcl/o/symbol.d, /cvsroot/gcl/gcl/o/unixfsys.c: + Added missing headers for str... and exit standard functions + + * /cvsroot/gcl/gcl/bin/append.c, /cvsroot/gcl/gcl/gcl-tk/decode.tcl, /cvsroot/gcl/gcl/gcl-tk/tinfo.c, /cvsroot/gcl/gcl/h/cyglacks.h, /cvsroot/gcl/gcl/o/big.c, /cvsroot/gcl/gcl/o/try.c, /cvsroot/gcl/gcl/unixport/rsym_nt.c, /cvsroot/gcl/gcl/unixport/tryserv.tcl, /cvsroot/gcl/gcl/makdefs, /cvsroot/gcl/gcl/readme.mingw: + Removed CR from all compilable files; removed one useless file + +2001-12-17 Camm Maguire + + * /cvsroot/gcl/gcl/config.guess, /cvsroot/gcl/gcl/config.sub: + New versions of config.sub and config.guess + +2001-12-16 Camm Maguire + + * /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in: + Allow setting compiler in CC env variable + + * /cvsroot/gcl/gcl/h/compbas2.h, /cvsroot/gcl/gcl/o/alloc.c, /cvsroot/gcl/gcl/o/file.d: + Commented labels at end of #endifs + + * /cvsroot/gcl/gcl/h/ptable.h: removed carriage returns + +2001-12-15 Camm Maguire + + * /cvsroot/gcl/gcl/gmp/mpn/hppa/hppa1_1/pa7100/addmul_1.S, /cvsroot/gcl/gcl/gmp/mpn/hppa/hppa1_1/pa7100/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/hppa/hppa1_1/pa7100/lshift.s, /cvsroot/gcl/gcl/gmp/mpn/hppa/hppa1_1/pa7100/rshift.s, /cvsroot/gcl/gcl/gmp/mpn/hppa/hppa1_1/pa7100/submul_1.S, /cvsroot/gcl/gcl/gmp/mpn/hppa/hppa1_1/pa7100/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/sparc32/v8/supersparc/udiv.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/k62mmx/copyd.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/k62mmx/copyi.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/k62mmx/lshift.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/k62mmx/rshift.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/mmx/com_n.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/mmx/logops_n.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/mmx/lshift.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/mmx/popham.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/mmx/rshift.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/mmx/copyd.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/mmx/copyi.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/mmx/divrem_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/mmx/lshift.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/mmx/mod_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/mmx/popham.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/mmx/rshift.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/p6/mmx/divrem_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/p6/mmx/mod_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/p6/mmx/popham.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/p6/p3mmx/popham.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/mmx/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/mmx/lshift.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/mmx/popham.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/mmx/rshift.asm, /cvsroot/gcl/gcl/gmp/mpbsd/tests/Makefile.in, /cvsroot/gcl/gcl/gmp/mpfr/tests/Makefile.in, /cvsroot/gcl/gcl/gmp/mpf/tests/Makefile.in, /cvsroot/gcl/gcl/gmp/mpn/alpha/ev5/add_n.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/ev5/lshift.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/ev5/rshift.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/ev5/sub_n.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/ev6/addmul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/ev6/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/hppa/hppa1_1/addmul_1.s, /cvsroot/gcl/gcl/gmp/mpn/hppa/hppa1_1/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/hppa/hppa1_1/submul_1.s, /cvsroot/gcl/gcl/gmp/mpn/hppa/hppa1_1/udiv_qrnnd.S, /cvsroot/gcl/gcl/gmp/mpn/hppa/hppa1_1/umul.s, /cvsroot/gcl/gcl/gmp/mpn/hppa/hppa2_0/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/hppa/hppa2_0/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/m68k/mc68020/addmul_1.S, /cvsroot/gcl/gcl/gmp/mpn/m68k/mc68020/mul_1.S, /cvsroot/gcl/gcl/gmp/mpn/m68k/mc68020/submul_1.S, /cvsroot/gcl/gcl/gmp/mpn/m68k/mc68020/udiv.S, /cvsroot/gcl/gcl/gmp/mpn/m68k/mc68020/umul.S, /cvsroot/gcl/gcl/gmp/mpn/m88k/mc88110/addmul_1.s, /cvsroot/gcl/gcl/gmp/mpn/m88k/mc88110/add_n.S, /cvsroot/gcl/gcl/gmp/mpn/m88k/mc88110/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/m88k/mc88110/sub_n.S, /cvsroot/gcl/gcl/gmp/mpn/sh/sh2/addmul_1.s, /cvsroot/gcl/gcl/gmp/mpn/sh/sh2/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/sh/sh2/submul_1.s, /cvsroot/gcl/gcl/gmp/mpn/sparc32/v8/addmul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/v8/mul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/v8/submul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/v8/umul.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/v9/addmul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/v9/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/sparc32/v9/mul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/v9/README, /cvsroot/gcl/gcl/gmp/mpn/sparc32/v9/submul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/aorsmul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/aors_n.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/cross.pl, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/diveby3.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/mul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/mul_basecase.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/README, /cvsroot/gcl/gcl/gmp/mpn/x86/k6/sqr_basecase.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/aorsmul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/aors_n.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/diveby3.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/mul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/mul_basecase.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/README, /cvsroot/gcl/gcl/gmp/mpn/x86/k7/sqr_basecase.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/p6/aorsmul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/p6/diveby3.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/p6/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/x86/p6/README, /cvsroot/gcl/gcl/gmp/mpn/x86/p6/sqr_basecase.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/aorsmul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/aors_n.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/diveby3.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/lshift.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/mul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/mul_basecase.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/README, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/rshift.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/pentium/sqr_basecase.asm, /cvsroot/gcl/gcl/gmp/mpq/tests/Makefile.in, /cvsroot/gcl/gcl/gmp/tests/rand/Makefile.in, /cvsroot/gcl/gcl/gmp/mpn/tests/submul_1.c, /cvsroot/gcl/gcl/gmp/mpn/tests/sub_n.c, /cvsroot/gcl/gcl/gmp/mpn/tests/trace.c, /cvsroot/gcl/gcl/gmp/mpn/tests/try.c, /cvsroot/gcl/gcl/gmp/mpn/tests/try.h, /cvsroot/gcl/gcl/gmp/mpn/tests/tst-addsub.c, /cvsroot/gcl/gcl/gmp/mpn/tests/x86call.asm, /cvsroot/gcl/gcl/gmp/mpn/tests/x86check.c, /cvsroot/gcl/gcl/gmp/mpn/thumb/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/thumb/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/vax/addmul_1.s, /cvsroot/gcl/gcl/gmp/mpn/vax/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/vax/lshift.s, /cvsroot/gcl/gcl/gmp/mpn/vax/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/vax/rshift.s, /cvsroot/gcl/gcl/gmp/mpn/vax/submul_1.s, /cvsroot/gcl/gcl/gmp/mpn/vax/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/x86/addsub_n.S, /cvsroot/gcl/gcl/gmp/mpn/x86/aorsmul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/aors_n.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/copyd.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/copyi.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/diveby3.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/divrem_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/lshift.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/mod_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/mul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/mul_basecase.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/README, /cvsroot/gcl/gcl/gmp/mpn/x86/README.family, /cvsroot/gcl/gcl/gmp/mpn/x86/rshift.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/udiv.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/umul.asm, /cvsroot/gcl/gcl/gmp/mpn/x86/x86-defs.m4, /cvsroot/gcl/gcl/gmp/mpn/z8000/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/z8000/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/z8000/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/z8000/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/z8000x/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/z8000x/sub_n.s, /cvsroot/gcl/gcl/gmp/mpq/Makefile.in, /cvsroot/gcl/gcl/gmp/mpz/tests/bit.c, /cvsroot/gcl/gcl/gmp/mpz/tests/convert.c, /cvsroot/gcl/gcl/gmp/mpz/tests/dive.c, /cvsroot/gcl/gcl/gmp/mpz/tests/io.c, /cvsroot/gcl/gcl/gmp/mpz/tests/logic.c, /cvsroot/gcl/gcl/gmp/mpz/tests/Makefile.am, /cvsroot/gcl/gcl/gmp/mpz/tests/Makefile.in, /cvsroot/gcl/gcl/gmp/mpz/tests/reuse.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-2exp.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-bin.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-fdiv.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-fdiv_ui.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-gcd.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-jac.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-misc.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-mul.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-powm.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-powm_ui.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-pow_ui.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-root.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-sqrtrem.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-tdiv.c, /cvsroot/gcl/gcl/gmp/mpz/tests/t-tdiv_ui.c, /cvsroot/gcl/gcl/gmp/tests/Makefile.in, /cvsroot/gcl/gcl/gmp/tune/Makefile.in, /cvsroot/gcl/gcl/gmp/demos/Makefile.in, /cvsroot/gcl/gcl/gmp/macos/Makefile.in, /cvsroot/gcl/gcl/gmp/mpbsd/Makefile.in, /cvsroot/gcl/gcl/gmp/mpf/Makefile.in, /cvsroot/gcl/gcl/gmp/mpfr/Makefile.in, /cvsroot/gcl/gcl/gmp/mpn/a29k/addmul_1.s, /cvsroot/gcl/gcl/gmp/mpn/a29k/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/a29k/lshift.s, /cvsroot/gcl/gcl/gmp/mpn/a29k/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/a29k/rshift.s, /cvsroot/gcl/gcl/gmp/mpn/a29k/submul_1.s, /cvsroot/gcl/gcl/gmp/mpn/a29k/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/a29k/udiv.s, /cvsroot/gcl/gcl/gmp/mpn/a29k/umul.s, /cvsroot/gcl/gcl/gmp/mpn/alpha/addmul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/add_n.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/cntlz.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/default.m4, /cvsroot/gcl/gcl/gmp/mpn/alpha/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/alpha/invert_limb.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/lshift.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/mul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/README, /cvsroot/gcl/gcl/gmp/mpn/alpha/rshift.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/submul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/sub_n.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/udiv_qrnnd.S, /cvsroot/gcl/gcl/gmp/mpn/alpha/umul.asm, /cvsroot/gcl/gcl/gmp/mpn/alpha/unicos.m4, /cvsroot/gcl/gcl/gmp/mpn/arm/addmul_1.S, /cvsroot/gcl/gcl/gmp/mpn/arm/add_n.S, /cvsroot/gcl/gcl/gmp/mpn/arm/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/arm/mul_1.S, /cvsroot/gcl/gcl/gmp/mpn/arm/sub_n.S, /cvsroot/gcl/gcl/gmp/mpn/clipper/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/clipper/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/clipper/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/cray/addmul_1.c, /cvsroot/gcl/gcl/gmp/mpn/cray/add_n.c, /cvsroot/gcl/gcl/gmp/mpn/cray/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/cray/mul_1.c, /cvsroot/gcl/gcl/gmp/mpn/cray/mulww.f, /cvsroot/gcl/gcl/gmp/mpn/cray/mulww.s, /cvsroot/gcl/gcl/gmp/mpn/cray/README, /cvsroot/gcl/gcl/gmp/mpn/cray/submul_1.c, /cvsroot/gcl/gcl/gmp/mpn/cray/sub_n.c, /cvsroot/gcl/gcl/gmp/mpn/hppa/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/hppa/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/hppa/lshift.s, /cvsroot/gcl/gcl/gmp/mpn/hppa/README, /cvsroot/gcl/gcl/gmp/mpn/hppa/rshift.s, /cvsroot/gcl/gcl/gmp/mpn/hppa/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/hppa/udiv_qrnnd.s, /cvsroot/gcl/gcl/gmp/mpn/i960/addmul_1.s, /cvsroot/gcl/gcl/gmp/mpn/i960/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/i960/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/i960/README, /cvsroot/gcl/gcl/gmp/mpn/i960/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/lisp/gmpasm-mode.el, /cvsroot/gcl/gcl/gmp/mpn/m68k/add_n.S, /cvsroot/gcl/gcl/gmp/mpn/m68k/lshift.S, /cvsroot/gcl/gcl/gmp/mpn/m68k/rshift.S, /cvsroot/gcl/gcl/gmp/mpn/m68k/sub_n.S, /cvsroot/gcl/gcl/gmp/mpn/m68k/syntax.h, /cvsroot/gcl/gcl/gmp/mpn/m88k/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/m88k/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/m88k/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/mips2/addmul_1.s, /cvsroot/gcl/gcl/gmp/mpn/mips2/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/mips2/lshift.s, /cvsroot/gcl/gcl/gmp/mpn/mips2/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/mips2/rshift.s, /cvsroot/gcl/gcl/gmp/mpn/mips2/submul_1.s, /cvsroot/gcl/gcl/gmp/mpn/mips2/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/mips2/umul.s, /cvsroot/gcl/gcl/gmp/mpn/mips3/addmul_1.s, /cvsroot/gcl/gcl/gmp/mpn/mips3/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/mips3/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/mips3/lshift.s, /cvsroot/gcl/gcl/gmp/mpn/mips3/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/mips3/README, /cvsroot/gcl/gcl/gmp/mpn/mips3/rshift.s, /cvsroot/gcl/gcl/gmp/mpn/mips3/submul_1.s, /cvsroot/gcl/gcl/gmp/mpn/mips3/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/ns32k/addmul_1.s, /cvsroot/gcl/gcl/gmp/mpn/ns32k/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/ns32k/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/ns32k/submul_1.s, /cvsroot/gcl/gcl/gmp/mpn/ns32k/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/pa64/addmul_1.S, /cvsroot/gcl/gcl/gmp/mpn/pa64/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/pa64/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/pa64/lshift.s, /cvsroot/gcl/gcl/gmp/mpn/pa64/mul_1.S, /cvsroot/gcl/gcl/gmp/mpn/pa64/README, /cvsroot/gcl/gcl/gmp/mpn/pa64/rshift.s, /cvsroot/gcl/gcl/gmp/mpn/pa64/submul_1.S, /cvsroot/gcl/gcl/gmp/mpn/pa64/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/pa64/udiv_qrnnd.c, /cvsroot/gcl/gcl/gmp/mpn/pa64/umul_ppmm.S, /cvsroot/gcl/gcl/gmp/mpn/pa64w/addmul_1.S, /cvsroot/gcl/gcl/gmp/mpn/pa64w/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/pa64w/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/pa64w/lshift.s, /cvsroot/gcl/gcl/gmp/mpn/pa64w/mul_1.S, /cvsroot/gcl/gcl/gmp/mpn/pa64w/README, /cvsroot/gcl/gcl/gmp/mpn/pa64w/rshift.s, /cvsroot/gcl/gcl/gmp/mpn/pa64w/submul_1.S, /cvsroot/gcl/gcl/gmp/mpn/pa64w/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/pa64w/udiv_qrnnd.c, /cvsroot/gcl/gcl/gmp/mpn/pa64w/umul_ppmm.S, /cvsroot/gcl/gcl/gmp/mpn/power/addmul_1.s, /cvsroot/gcl/gcl/gmp/mpn/power/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/power/lshift.s, /cvsroot/gcl/gcl/gmp/mpn/power/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/powerpc32/addmul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc32/add_n.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc32/aix.m4, /cvsroot/gcl/gcl/gmp/mpn/powerpc32/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/powerpc32/lshift.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc32/mul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc32/regmap.m4, /cvsroot/gcl/gcl/gmp/mpn/powerpc32/rshift.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc32/submul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc32/sub_n.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc32/umul.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc64/addmul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc64/add_n.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc64/addsub_n.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc64/aix.m4, /cvsroot/gcl/gcl/gmp/mpn/powerpc64/copyd.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc64/copyi.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc64/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/powerpc64/lshift.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc64/mul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc64/README, /cvsroot/gcl/gcl/gmp/mpn/powerpc64/rshift.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc64/submul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/powerpc64/sub_n.asm, /cvsroot/gcl/gcl/gmp/mpn/power/rshift.s, /cvsroot/gcl/gcl/gmp/mpn/power/sdiv.s, /cvsroot/gcl/gcl/gmp/mpn/power/submul_1.s, /cvsroot/gcl/gcl/gmp/mpn/power/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/power/umul.s, /cvsroot/gcl/gcl/gmp/mpn/pyr/addmul_1.s, /cvsroot/gcl/gcl/gmp/mpn/pyr/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/pyr/mul_1.s, /cvsroot/gcl/gcl/gmp/mpn/pyr/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/sh/add_n.s, /cvsroot/gcl/gcl/gmp/mpn/sh/sub_n.s, /cvsroot/gcl/gcl/gmp/mpn/sparc32/addmul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/add_n.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/lshift.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/mul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/README, /cvsroot/gcl/gcl/gmp/mpn/sparc32/rshift.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/submul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/sub_n.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/udiv_fp.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/udiv_nfp.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc32/umul.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc64/addmul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc64/addmul1h.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc64/add_n.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc64/copyi.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc64/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/sparc64/lshift.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc64/mul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc64/mul_1h.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc64/README, /cvsroot/gcl/gcl/gmp/mpn/sparc64/rshift.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc64/submul_1.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc64/submul1h.asm, /cvsroot/gcl/gcl/gmp/mpn/sparc64/sub_n.asm, /cvsroot/gcl/gcl/gmp/mpn/tests/addmul_1.c, /cvsroot/gcl/gcl/gmp/mpn/tests/add_n.c, /cvsroot/gcl/gcl/gmp/mpn/tests/copy.c, /cvsroot/gcl/gcl/gmp/mpn/tests/divmod_1.c, /cvsroot/gcl/gcl/gmp/mpn/tests/divrem.c, /cvsroot/gcl/gcl/gmp/mpn/tests/lshift.c, /cvsroot/gcl/gcl/gmp/mpn/tests/Makefile.am, /cvsroot/gcl/gcl/gmp/mpn/tests/Makefile.in, /cvsroot/gcl/gcl/gmp/mpn/tests/mul_1.c, /cvsroot/gcl/gcl/gmp/mpn/tests/README, /cvsroot/gcl/gcl/gmp/mpn/tests/ref.c, /cvsroot/gcl/gcl/gmp/mpn/tests/ref.h, /cvsroot/gcl/gcl/gmp/mpn/tests/rshift.c, /cvsroot/gcl/gcl/gmp/mpn/tests/spinner.c, /cvsroot/gcl/gcl/gmp/ansi2knr.c, /cvsroot/gcl/gcl/gmp/configure.in, /cvsroot/gcl/gcl/gmp/mpn/asm-defs.m4, /cvsroot/gcl/gcl/gmp/mpn/generic/addmul_1.c, /cvsroot/gcl/gcl/gmp/mpn/generic/add_n.c, /cvsroot/gcl/gcl/gmp/mpn/generic/addsub_n.c, /cvsroot/gcl/gcl/gmp/mpn/generic/bdivmod.c, /cvsroot/gcl/gcl/gmp/mpn/generic/bz_divrem_n.c, /cvsroot/gcl/gcl/gmp/mpn/generic/cmp.c, /cvsroot/gcl/gcl/gmp/mpn/generic/diveby3.c, /cvsroot/gcl/gcl/gmp/mpn/generic/divrem_1.c, /cvsroot/gcl/gcl/gmp/mpn/generic/divrem_2.c, /cvsroot/gcl/gcl/gmp/mpn/generic/divrem.c, /cvsroot/gcl/gcl/gmp/mpn/generic/dump.c, /cvsroot/gcl/gcl/gmp/mpn/generic/gcd_1.c, /cvsroot/gcl/gcl/gmp/mpn/generic/gcd.c, /cvsroot/gcl/gcl/gmp/mpn/generic/gcdext.c, /cvsroot/gcl/gcl/gmp/mpn/generic/get_str.c, /cvsroot/gcl/gcl/gmp/mpn/generic/gmp-mparam.h, /cvsroot/gcl/gcl/gmp/mpn/generic/hamdist.c, /cvsroot/gcl/gcl/gmp/mpn/generic/inlines.c, /cvsroot/gcl/gcl/gmp/mpn/generic/jacbase.c, /cvsroot/gcl/gcl/gmp/mpn/generic/lshift.c, /cvsroot/gcl/gcl/gmp/mpn/generic/mod_1.c, /cvsroot/gcl/gcl/gmp/mpn/generic/mod_1_rs.c, /cvsroot/gcl/gcl/gmp/mpn/generic/mul_1.c, /cvsroot/gcl/gcl/gmp/mpn/generic/mul_basecase.c, /cvsroot/gcl/gcl/gmp/mpn/generic/mul.c, /cvsroot/gcl/gcl/gmp/mpn/generic/mul_fft.c, /cvsroot/gcl/gcl/gmp/mpn/generic/perfsqr.c, /cvsroot/gcl/gcl/gmp/mpn/generic/popcount.c, /cvsroot/gcl/gcl/gmp/mpn/generic/pre_mod_1.c, /cvsroot/gcl/gcl/gmp/mpn/generic/random2.c, /cvsroot/gcl/gcl/gmp/mpn/generic/random.c, /cvsroot/gcl/gcl/gmp/mpn/generic/rshift.c, /cvsroot/gcl/gcl/gmp/mpn/generic/sb_divrem_mn.c, /cvsroot/gcl/gcl/gmp/mpn/generic/scan0.c, /cvsroot/gcl/gcl/gmp/mpn/generic/scan1.c, /cvsroot/gcl/gcl/gmp/mpn/generic/set_str.c, /cvsroot/gcl/gcl/gmp/mpn/generic/sqr_basecase.c, /cvsroot/gcl/gcl/gmp/mpn/generic/sqrtrem.c, /cvsroot/gcl/gcl/gmp/mpn/generic/submul_1.c, /cvsroot/gcl/gcl/gmp/mpn/generic/sub_n.c, /cvsroot/gcl/gcl/gmp/mpn/generic/tdiv_qr.c, /cvsroot/gcl/gcl/gmp/mpn/generic/udiv_w_sdiv.c, /cvsroot/gcl/gcl/gmp/mpn/Makefile.am, /cvsroot/gcl/gcl/gmp/mpn/Makefile.in, /cvsroot/gcl/gcl/gmp/mpn/mp_bases.c, /cvsroot/gcl/gcl/gmp/mpn/README, /cvsroot/gcl/gcl/gmp/mpz/abs.c, /cvsroot/gcl/gcl/gmp/mpz/add.c, /cvsroot/gcl/gcl/gmp/mpz/addmul_ui.c, /cvsroot/gcl/gcl/gmp/mpz/add_ui.c, /cvsroot/gcl/gcl/gmp/mpz/and.c, /cvsroot/gcl/gcl/gmp/mpz/array_init.c, /cvsroot/gcl/gcl/gmp/mpz/bin_ui.c, /cvsroot/gcl/gcl/gmp/mpz/bin_uiui.c, /cvsroot/gcl/gcl/gmp/mpz/cdiv_q.c, /cvsroot/gcl/gcl/gmp/mpz/cdiv_qr.c, /cvsroot/gcl/gcl/gmp/mpz/cdiv_qr_ui.c, /cvsroot/gcl/gcl/gmp/mpz/cdiv_q_ui.c, /cvsroot/gcl/gcl/gmp/mpz/cdiv_r.c, /cvsroot/gcl/gcl/gmp/mpz/cdiv_r_ui.c, /cvsroot/gcl/gcl/gmp/mpz/cdiv_ui.c, /cvsroot/gcl/gcl/gmp/mpz/clear.c, /cvsroot/gcl/gcl/gmp/mpz/clrbit.c, /cvsroot/gcl/gcl/gmp/mpz/cmpabs.c, /cvsroot/gcl/gcl/gmp/mpz/cmpabs_ui.c, /cvsroot/gcl/gcl/gmp/mpz/cmp.c, /cvsroot/gcl/gcl/gmp/mpz/cmp_si.c, /cvsroot/gcl/gcl/gmp/mpz/cmp_ui.c, /cvsroot/gcl/gcl/gmp/mpz/com.c, /cvsroot/gcl/gcl/gmp/mpz/divexact.c, /cvsroot/gcl/gcl/gmp/mpz/dump.c, /cvsroot/gcl/gcl/gmp/mpz/fac_ui.c, /cvsroot/gcl/gcl/gmp/mpz/fdiv_q_2exp.c, /cvsroot/gcl/gcl/gmp/mpz/fdiv_q.c, /cvsroot/gcl/gcl/gmp/mpz/fdiv_qr.c, /cvsroot/gcl/gcl/gmp/mpz/fdiv_qr_ui.c, /cvsroot/gcl/gcl/gmp/mpz/fdiv_q_ui.c, /cvsroot/gcl/gcl/gmp/mpz/fdiv_r.c, /cvsroot/gcl/gcl/gmp/mpz/fdiv_r_ui.c, /cvsroot/gcl/gcl/gmp/mpz/fdiv_ui.c, /cvsroot/gcl/gcl/gmp/mpz/fib_ui.c, /cvsroot/gcl/gcl/gmp/mpz/fits_sint_p.c, /cvsroot/gcl/gcl/gmp/mpz/fits_slong_p.c, /cvsroot/gcl/gcl/gmp/mpz/fits_sshort_p.c, /cvsroot/gcl/gcl/gmp/mpz/fits_uint_p.c, /cvsroot/gcl/gcl/gmp/mpz/fits_ulong_p.c, /cvsroot/gcl/gcl/gmp/mpz/fits_ushort_p.c, /cvsroot/gcl/gcl/gmp/mpz/gcdext.c, /cvsroot/gcl/gcl/gmp/mpz/gcd_ui.c, /cvsroot/gcl/gcl/gmp/mpz/get_d.c, /cvsroot/gcl/gcl/gmp/mpz/getlimbn.c, /cvsroot/gcl/gcl/gmp/mpz/get_si.c, /cvsroot/gcl/gcl/gmp/mpz/get_str.c, /cvsroot/gcl/gcl/gmp/mpz/get_ui.c, /cvsroot/gcl/gcl/gmp/mpz/hamdist.c, /cvsroot/gcl/gcl/gmp/mpz/init.c, /cvsroot/gcl/gcl/gmp/mpz/inp_raw.c, /cvsroot/gcl/gcl/gmp/mpz/inp_str.c, /cvsroot/gcl/gcl/gmp/mpz/invert.c, /cvsroot/gcl/gcl/gmp/mpz/ior.c, /cvsroot/gcl/gcl/gmp/mpz/iset.c, /cvsroot/gcl/gcl/gmp/mpz/iset_d.c, /cvsroot/gcl/gcl/gmp/mpz/iset_si.c, /cvsroot/gcl/gcl/gmp/mpz/iset_str.c, /cvsroot/gcl/gcl/gmp/mpz/iset_ui.c, /cvsroot/gcl/gcl/gmp/mpz/jacobi.c, /cvsroot/gcl/gcl/gmp/mpz/kronsz.c, /cvsroot/gcl/gcl/gmp/mpz/kronuz.c, /cvsroot/gcl/gcl/gmp/mpz/kronzs.c, /cvsroot/gcl/gcl/gmp/mpz/kronzu.c, /cvsroot/gcl/gcl/gmp/mpz/lcm.c, /cvsroot/gcl/gcl/gmp/mpz/legendre.c, /cvsroot/gcl/gcl/gmp/mpz/Makefile.am, /cvsroot/gcl/gcl/gmp/mpz/Makefile.in, /cvsroot/gcl/gcl/gmp/mpz/mod.c, /cvsroot/gcl/gcl/gmp/mpz/mul_2exp.c, /cvsroot/gcl/gcl/gmp/mpz/mul_siui.c, /cvsroot/gcl/gcl/gmp/mpz/neg.c, /cvsroot/gcl/gcl/gmp/mpz/nextprime.c, /cvsroot/gcl/gcl/gmp/mpz/out_raw.c, /cvsroot/gcl/gcl/gmp/mpz/out_str.c, /cvsroot/gcl/gcl/gmp/mpz/perfpow.c, /cvsroot/gcl/gcl/gmp/mpz/perfsqr.c, /cvsroot/gcl/gcl/gmp/mpz/popcount.c, /cvsroot/gcl/gcl/gmp/mpz/powm.c, /cvsroot/gcl/gcl/gmp/mpz/powm_ui.c, /cvsroot/gcl/gcl/gmp/mpz/pow_ui.c, /cvsroot/gcl/gcl/gmp/mpz/pprime_p.c, /cvsroot/gcl/gcl/gmp/mpz/random2.c, /cvsroot/gcl/gcl/gmp/mpz/random.c, /cvsroot/gcl/gcl/gmp/mpz/README, /cvsroot/gcl/gcl/gmp/mpz/realloc.c, /cvsroot/gcl/gcl/gmp/mpz/remove.c, /cvsroot/gcl/gcl/gmp/mpz/root.c, /cvsroot/gcl/gcl/gmp/mpz/rrandomb.c, /cvsroot/gcl/gcl/gmp/mpz/scan0.c, /cvsroot/gcl/gcl/gmp/mpz/scan1.c, /cvsroot/gcl/gcl/gmp/mpz/setbit.c, /cvsroot/gcl/gcl/gmp/mpz/set.c, /cvsroot/gcl/gcl/gmp/mpz/set_d.c, /cvsroot/gcl/gcl/gmp/mpz/set_f.c, /cvsroot/gcl/gcl/gmp/mpz/set_q.c, /cvsroot/gcl/gcl/gmp/mpz/set_si.c, /cvsroot/gcl/gcl/gmp/mpz/set_str.c, /cvsroot/gcl/gcl/gmp/mpz/set_ui.c, /cvsroot/gcl/gcl/gmp/mpz/size.c, /cvsroot/gcl/gcl/gmp/mpz/sizeinbase.c, /cvsroot/gcl/gcl/gmp/mpz/sqrt.c, /cvsroot/gcl/gcl/gmp/mpz/sqrtrem.c, /cvsroot/gcl/gcl/gmp/mpz/sub.c, /cvsroot/gcl/gcl/gmp/mpz/sub_ui.c, /cvsroot/gcl/gcl/gmp/mpz/swap.c, /cvsroot/gcl/gcl/gmp/mpz/tdiv_q_2exp.c, /cvsroot/gcl/gcl/gmp/mpz/tdiv_q.c, /cvsroot/gcl/gcl/gmp/mpz/tdiv_qr.c, /cvsroot/gcl/gcl/gmp/mpz/tdiv_qr_ui.c, /cvsroot/gcl/gcl/gmp/mpz/tdiv_q_ui.c, /cvsroot/gcl/gcl/gmp/mpz/tdiv_r_2exp.c, /cvsroot/gcl/gcl/gmp/mpz/tdiv_r.c, /cvsroot/gcl/gcl/gmp/mpz/tdiv_r_ui.c, /cvsroot/gcl/gcl/gmp/mpz/tdiv_ui.c, /cvsroot/gcl/gcl/gmp/mpz/tstbit.c, /cvsroot/gcl/gcl/gmp/mpz/ui_pow_ui.c, /cvsroot/gcl/gcl/gmp/mpz/urandomb.c, /cvsroot/gcl/gcl/gmp/mpz/urandomm.c, /cvsroot/gcl/gcl/gmp/mpz/xor.c: + Complete file additions for gmp configure and build + + * /cvsroot/gcl/gcl/gmp/ansi2knr.c, /cvsroot/gcl/gcl/gmp/assert.c, /cvsroot/gcl/gcl/gmp/compat.c, /cvsroot/gcl/gcl/gmp/config.guess, /cvsroot/gcl/gcl/gmp/config.in, /cvsroot/gcl/gcl/gmp/config.sub, /cvsroot/gcl/gcl/gmp/configure, /cvsroot/gcl/gcl/gmp/configure.in, /cvsroot/gcl/gcl/gmp/COPYING, /cvsroot/gcl/gcl/gmp/errno.c, /cvsroot/gcl/gcl/gmp/extract-dbl.c, /cvsroot/gcl/gcl/gmp/gmp.h, /cvsroot/gcl/gcl/gmp/gmp-impl.h, /cvsroot/gcl/gcl/gmp/insert-dbl.c, /cvsroot/gcl/gcl/gmp/install-sh, /cvsroot/gcl/gcl/gmp/longlong.h, /cvsroot/gcl/gcl/gmp/ltconfig, /cvsroot/gcl/gcl/gmp/ltmain.sh, /cvsroot/gcl/gcl/gmp/Makefile.in, /cvsroot/gcl/gcl/gmp/memory.c, /cvsroot/gcl/gcl/gmp/missing, /cvsroot/gcl/gcl/gmp/mp_bpl.c, /cvsroot/gcl/gcl/gmp/mp_clz_tab.c, /cvsroot/gcl/gcl/gmp/mp.h, /cvsroot/gcl/gcl/gmp/mp_minv_tab.c, /cvsroot/gcl/gcl/gmp/mp_set_fns.c, /cvsroot/gcl/gcl/gmp/rand.c, /cvsroot/gcl/gcl/gmp/randclr.c, /cvsroot/gcl/gcl/gmp/randlc2x.c, /cvsroot/gcl/gcl/gmp/randlc.c, /cvsroot/gcl/gcl/gmp/randraw.c, /cvsroot/gcl/gcl/gmp/randsd.c, /cvsroot/gcl/gcl/gmp/randsdui.c, /cvsroot/gcl/gcl/gmp/README, /cvsroot/gcl/gcl/gmp/stack-alloc.c, /cvsroot/gcl/gcl/gmp/stack-alloc.h, /cvsroot/gcl/gcl/gmp/urandom.h, /cvsroot/gcl/gcl/gmp/version.c: + gmp configure and build restoration + + * /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in: + Run emacs with --no-site-file to avoid errors; default ix86 gmp target is i486 + + * /cvsroot/gcl/gcl/h/gmp.h: + Link needed to get gmp bignums working with new gmp_big.c file + + * /cvsroot/gcl/gcl/h/386-linux.h: + Patch submitted via email months ago by Dr. Schelter to enable reliable dynamic linking on i386 Linux + +2001-07-03 wfs + + * /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/h/gclincl.h: + fix to configure + +2001-06-06 wfs + + * /cvsroot/gcl/gcl/lsp/info.data, /cvsroot/gcl/gcl/lsp/info.lsp: + fix info to handle defunx + +2001-05-18 wfs + + * /cvsroot/gcl/gcl/h/gclincl.h, /cvsroot/gcl/gcl/o/gmp_big.c, /cvsroot/gcl/gcl/o/gmp.c, /cvsroot/gcl/gcl/o/gmp_num_log.c, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/o/pari_big.c, /cvsroot/gcl/gcl/o/pari_num_log.c, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/elisp/gcl.el, /cvsroot/gcl/gcl/h/mp.h: + changes for bignum code, now relocatable bignums ok, worked around bug in gmp code which does not detect 0 as fitting in an int + +2001-05-16 wfs + + * /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/h/cmpinclude.h, /cvsroot/gcl/gcl/h/gclincl.h, /cvsroot/gcl/gcl/h/mp.h, /cvsroot/gcl/gcl/h/new_decl.h, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/o/cmpinclude.h, /cvsroot/gcl/gcl/o/fat_string.c, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/o/new_init.c, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/bin/gcl, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/makefile: + changes for gmp + +2001-05-15 wfs + + * /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/gcl-tk/demos/index.lsp, /cvsroot/gcl/gcl/gcl-tk/gcltksrv, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/h/cmpinclude.h, /cvsroot/gcl/gcl/h/gclincl.h, /cvsroot/gcl/gcl/h/gclincl.h.in, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/o/cmpinclude.h, /cvsroot/gcl/gcl/o/main.c, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/o/num_log.c, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/bin/gcl, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/cmpnew/cmpmain.lsp, /cvsroot/gcl/gcl/cmpnew/cmpopt.lsp, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/makefile: + fix to ash, and for buggy redhat/cygnus compiler + +2001-05-11 wfs + + * /cvsroot/gcl/gcl/readme.gmp, /cvsroot/gcl/gcl/readme.mingw, /cvsroot/gcl/gcl/unixport/init_gcl.lsp: + fix the error code on compile from command line + +2001-05-06 wfs + + * /cvsroot/gcl/gcl/gmp/mpn/generic/mul_n.c, /cvsroot/gcl/gcl/gmp/mpz/fdiv_r_2exp.c, /cvsroot/gcl/gcl/gmp/mpz/gcd.c, /cvsroot/gcl/gcl/gmp/mpz/mul.c: + changes to gmp from 3.1.1 for gcl + + * /cvsroot/gcl/gcl/add-defs1, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/cmpnew/cmpopt.lsp, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/elisp/dbl.el, /cvsroot/gcl/gcl/elisp/gcl.el, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/elisp/smart-complete.el, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/gmp/mpn/generic/mul_n.c, /cvsroot/gcl/gcl/gmp/mpz/fdiv_r_2exp.c, /cvsroot/gcl/gcl/gmp/mpz/gcd.c, /cvsroot/gcl/gcl/gmp/mpz/mul.c, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/h/386-linux.h, /cvsroot/gcl/gcl/h/att_ext.h, /cvsroot/gcl/gcl/h/cmpinclude.h, /cvsroot/gcl/gcl/h/cmponly.h, /cvsroot/gcl/gcl/h/compbas2.h, /cvsroot/gcl/gcl/h/gclincl.h, /cvsroot/gcl/gcl/h/gclincl.h.in, /cvsroot/gcl/gcl/h/include.h, /cvsroot/gcl/gcl/h/mdefs.h, /cvsroot/gcl/gcl/h/mp.h, /cvsroot/gcl/gcl/h/new_decl.h, /cvsroot/gcl/gcl/h/object.h, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/makefile, /cvsroot/gcl/gcl/minvers, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/o/big.c, /cvsroot/gcl/gcl/o/cmac.c, /cvsroot/gcl/gcl/o/cmpaux.c, /cvsroot/gcl/gcl/o/cmpinclude.h, /cvsroot/gcl/gcl/o/fasdump.c, /cvsroot/gcl/gcl/o/gbc.c, /cvsroot/gcl/gcl/o/hash.d, /cvsroot/gcl/gcl/o/init_pari.c, /cvsroot/gcl/gcl/o/main.c, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/o/new_init.c, /cvsroot/gcl/gcl/o/num_arith.c, /cvsroot/gcl/gcl/o/number.c, /cvsroot/gcl/gcl/o/num_log.c, /cvsroot/gcl/gcl/o/num_pred.c, /cvsroot/gcl/gcl/o/print.d, /cvsroot/gcl/gcl/o/read.d, /cvsroot/gcl/gcl/o/sgbc.c, /cvsroot/gcl/gcl/o/unixfsys.c, /cvsroot/gcl/gcl/o/usig2_aux.c, /cvsroot/gcl/gcl/unixport/init_gcl.lsp, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/xbin/new-files: + many changes adding gmp bignums + +2001-04-17 wfs + + * /cvsroot/gcl/gcl/h/cmpinclude.h, /cvsroot/gcl/gcl/h/new_decl.h, /cvsroot/gcl/gcl/lsp/debug.c, /cvsroot/gcl/gcl/lsp/debug.data, /cvsroot/gcl/gcl/lsp/debug.h, /cvsroot/gcl/gcl/lsp/debug.lsp, /cvsroot/gcl/gcl/lsp/top.c, /cvsroot/gcl/gcl/lsp/top.data, /cvsroot/gcl/gcl/lsp/top.h, /cvsroot/gcl/gcl/lsp/top.lsp, /cvsroot/gcl/gcl/o/cmpinclude.h, /cvsroot/gcl/gcl/o/new_init.c: + minor change to break-call + + * /cvsroot/gcl/gcl/o/sfaslelf.c, /cvsroot/gcl/gcl/unixport/rsym_nt.c, /cvsroot/gcl/gcl/add-defs1, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/ChangeLog, /cvsroot/gcl/gcl/cmpnew/cmpmain.lsp, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/h/mingw.defs, /cvsroot/gcl/gcl/h/mingw.h, /cvsroot/gcl/gcl/lsp/autoload.lsp, /cvsroot/gcl/gcl/lsp/debug.lsp: + removed the o/*.ini files since these are generated automatically. + fixed things in h/mingw.{h,defs}, made o/sfaslelf.c so it can + load things compiled under -O4 (since init_ is searched for), + repaired rsym_nt.c for mingw port + +2001-04-13 wfs + + * /cvsroot/gcl/gcl/ChangeLog, /cvsroot/gcl/gcl/h/386-linux.h, /cvsroot/gcl/gcl/h/notcomp.h: + changes for clisp, and to sysdef + +2001-03-22 wfs + + * /cvsroot/gcl/gcl/lsp/evalmacros.c, /cvsroot/gcl/gcl/lsp/evalmacros.data, /cvsroot/gcl/gcl/lsp/evalmacros.h, /cvsroot/gcl/gcl/lsp/evalmacros.lsp, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/o/unexelf.c: + Fix the unexelf to make the data section executable + +2001-02-24 wfs + + * /cvsroot/gcl/gcl/bin/append, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/ChangeLog, /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/gcl-tk/guis.c, /cvsroot/gcl/gcl/gcl-tk/tinfo.c, /cvsroot/gcl/gcl/h/386-linux.h, /cvsroot/gcl/gcl/h/cmpinclude.h, /cvsroot/gcl/gcl/h/gclincl.h, /cvsroot/gcl/gcl/h/gclincl.h.in, /cvsroot/gcl/gcl/h/notcomp.h, /cvsroot/gcl/gcl/h/OpenBSD.defs, /cvsroot/gcl/gcl/h/OpenBSD.h, /cvsroot/gcl/gcl/o/cmpinclude.h, /cvsroot/gcl/gcl/o/main.c, /cvsroot/gcl/gcl/o/unexec.c, /cvsroot/gcl/gcl/xbin/new-files: + fix for debian, for stdout corruption after save + +2000-12-09 wfs + + * /cvsroot/gcl/gcl/add-defs1, /cvsroot/gcl/gcl/add-defs, /cvsroot/gcl/gcl/bin/append, /cvsroot/gcl/gcl/bin/file-sub.c, /cvsroot/gcl/gcl/bin/gcl, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/bin/winkill.c, /cvsroot/gcl/gcl/ChangeLog, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/cmpnew/cmpmain.lsp, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/elisp/dbl.el, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/gcl-tk/gcltksrv, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/gcl-tk/tinfo.c, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/h/cmpinclude.h, /cvsroot/gcl/gcl/h/coff/i386.h, /cvsroot/gcl/gcl/h/gclincl.h, /cvsroot/gcl/gcl/h/gnuwin95.h, /cvsroot/gcl/gcl/h/mingw.defs, /cvsroot/gcl/gcl/h/mingw.h, /cvsroot/gcl/gcl/h/new_decl.h, /cvsroot/gcl/gcl/h/object.h, /cvsroot/gcl/gcl/h/wincoff.h, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/lsp/info.c, /cvsroot/gcl/gcl/lsp/info.lsp, /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/lsp/top.c, /cvsroot/gcl/gcl/lsp/top.data, /cvsroot/gcl/gcl/lsp/top.h, /cvsroot/gcl/gcl/lsp/top.lsp, /cvsroot/gcl/gcl/makedefc.in, /cvsroot/gcl/gcl/makefile, /cvsroot/gcl/gcl/minvers, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/o/cmpinclude.h, /cvsroot/gcl/gcl/o/file.d, /cvsroot/gcl/gcl/o/main.c, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/o/mingwin.c, /cvsroot/gcl/gcl/o/new_init.c, /cvsroot/gcl/gcl/o/nsocket.c, /cvsroot/gcl/gcl/o/pathname.d, /cvsroot/gcl/gcl/o/read.d, /cvsroot/gcl/gcl/o/save.c, /cvsroot/gcl/gcl/o/sockets.c, /cvsroot/gcl/gcl/o/tclwinkill.c, /cvsroot/gcl/gcl/o/unexnt.c, /cvsroot/gcl/gcl/o/unixfsys.c, /cvsroot/gcl/gcl/o/unixfsys.ini, /cvsroot/gcl/gcl/o/unixtime.c, /cvsroot/gcl/gcl/o/usig2.c, /cvsroot/gcl/gcl/o/usig.c, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/unixport/rsym_nt.c, /cvsroot/gcl/gcl/xbin/386-linux-fix: + many changes for xmaxima and for windows + +2000-10-28 wfs + + * /cvsroot/gcl/gcl/xbin/386-linux-fix: changes for redhat 7.0 + +2000-10-27 wfs + + * /cvsroot/gcl/gcl/h/386-linux.h, /cvsroot/gcl/gcl/h/bsd.h, /cvsroot/gcl/gcl/h/sparc-linux.h, /cvsroot/gcl/gcl/o/file.d, /cvsroot/gcl/gcl/configure.in: + changes for close_stream, and to configure for redhat 7.0 + + * /cvsroot/gcl/gcl/gcl-tk/demos/index.lsp, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/h/object.h, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/bin/append, /cvsroot/gcl/gcl/bin/gcl, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/elisp/sshell.el, /cvsroot/gcl/gcl/gcl-tk/gcltksrv, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/gcl-tk/tinfo.c, /cvsroot/gcl/gcl/makefile: + abort() is void so fixed BV_OFFSET macro + +2000-06-27 wfs + + * /cvsroot/gcl/gcl/info/io.texi, /cvsroot/gcl/gcl/o/file.d: + allow open of a file '| command' to open a pipe + +2000-06-26 wfs + + * /cvsroot/gcl/gcl/lsp/export.lsp, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/o/read.d: + change parse_number to do bignums much faster + +2000-06-15 wfs + + * /cvsroot/gcl/gcl/configure.in: fixes to configure + +2000-06-13 wfs + + * /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/makefile, /cvsroot/gcl/gcl/unixport/init_maxima.lsp: + fix info compilation in makefile + +2000-06-04 wfs + + * /cvsroot/gcl/gcl/o/pathname.d: + fix so make-pathname when given an :type nil makes the type nil independent of the default + + * /cvsroot/gcl/gcl/lsp/sloop.c, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/o/cmpinclude.h, /cvsroot/gcl/gcl/o/macros.ini, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/o/new_init.c, /cvsroot/gcl/gcl/o/number.ini, /cvsroot/gcl/gcl/o/package.ini, /cvsroot/gcl/gcl/o/predicate.ini, /cvsroot/gcl/gcl/o/print.d, /cvsroot/gcl/gcl/o/read.d, /cvsroot/gcl/gcl/o/structure.ini, /cvsroot/gcl/gcl/o/toplevel.ini, /cvsroot/gcl/gcl/o/typespec.ini, /cvsroot/gcl/gcl/o/unixsys.ini, /cvsroot/gcl/gcl/o/usig.ini, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/bin/gcl, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/ChangeLog, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/cmpnew/cmplam.c, /cvsroot/gcl/gcl/cmpnew/cmptype.c, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/gcl-tk/gcltksrv, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/gcl-tk/tinfo.c, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/h/cmpinclude.h, /cvsroot/gcl/gcl/h/new_decl.h, /cvsroot/gcl/gcl/info/gcl-tk.info, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/makefile: + change the # syntax for pathnames to be #p + +2000-05-25 wfs + + * /cvsroot/gcl/gcl/minvers: fix version to 3.6 + + * /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/configure: + update configure from configure.in + +2000-05-16 wfs + + * /cvsroot/gcl/gcl/h/386-linux.defs: + remove the -static declaration for the link + +2000-05-15 wfs + + * /cvsroot/gcl/gcl/readme, /cvsroot/gcl/gcl/makefile: + fix some cosmetic and documentation items + +2000-05-15 mzou + + * /cvsroot/gcl/gcl/ChangeLog: *** empty log message *** + +2000-05-13 wfs + + * /cvsroot/gcl/gcl/xbin/distribute, /cvsroot/gcl/gcl/xbin/new-files: + fix xbin/distribute + + * /cvsroot/gcl/gcl/o/sfaslelf.c, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/unixport/rsym_elf.c, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/h/cmpinclude.h, /cvsroot/gcl/gcl/h/new_decl.h, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/mp/mpi-sol-sparc.s, /cvsroot/gcl/gcl/o/cmac.c, /cvsroot/gcl/gcl/o/cmpinclude.h, /cvsroot/gcl/gcl/o/earith.c, /cvsroot/gcl/gcl/o/earith.ini, /cvsroot/gcl/gcl/o/makefile, /cvsroot/gcl/gcl/o/new_init.c, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/ChangeLog, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/makedefs.in, /cvsroot/gcl/gcl/makefile, /cvsroot/gcl/gcl/readme: + bring cvs tree up to date with my development tree + + * /cvsroot/gcl/gcl/cmpnew/cmpmain.lsp, /cvsroot/gcl/gcl/makefile, /cvsroot/gcl/gcl/readme: + some cosmetic and readme changes + +1999-12-06 wfs + + * /cvsroot/gcl/gcl/ChangeLog: *** empty log message *** + + * /cvsroot/gcl/gcl/utils/replace, /cvsroot/gcl/gcl/utils/repls1.sed, /cvsroot/gcl/gcl/utils/repls2.sed, /cvsroot/gcl/gcl/utils/repls3.sed, /cvsroot/gcl/gcl/utils/repls4.sed, /cvsroot/gcl/gcl/utils/repls5.sed, /cvsroot/gcl/gcl/utils/revstruct.sed, /cvsroot/gcl/gcl/xbin/add-dir, /cvsroot/gcl/gcl/xbin/append, /cvsroot/gcl/gcl/xbin/append.bat, /cvsroot/gcl/gcl/xbin/compare.c, /cvsroot/gcl/gcl/xbin/compare-src, /cvsroot/gcl/gcl/xbin/comp_rel, /cvsroot/gcl/gcl/xbin/dfiles, /cvsroot/gcl/gcl/xbin/distrib-help, /cvsroot/gcl/gcl/xbin/distribute, /cvsroot/gcl/gcl/xbin/dos-files, /cvsroot/gcl/gcl/xbin/dosmake.bat, /cvsroot/gcl/gcl/xbin/exists, /cvsroot/gcl/gcl/xbin/file-sub, /cvsroot/gcl/gcl/xbin/fix-copyright, /cvsroot/gcl/gcl/xbin/get-externals, /cvsroot/gcl/gcl/xbin/get-internal-calls, /cvsroot/gcl/gcl/xbin/get-machine, /cvsroot/gcl/gcl/xbin/ibm, /cvsroot/gcl/gcl/xbin/if-exist.bat, /cvsroot/gcl/gcl/xbin/if-exists, /cvsroot/gcl/gcl/xbin/if-have-gcc, /cvsroot/gcl/gcl/xbin/inc-version, /cvsroot/gcl/gcl/xbin/is-V-newest, /cvsroot/gcl/gcl/xbin/make-fn, /cvsroot/gcl/gcl/xbin/maketest1, /cvsroot/gcl/gcl/xbin/maketest, /cvsroot/gcl/gcl/xbin/move-if-changed, /cvsroot/gcl/gcl/xbin/new-files, /cvsroot/gcl/gcl/xbin/notify, /cvsroot/gcl/gcl/xbin/setup-tmptest, /cvsroot/gcl/gcl/xbin/spp.c, /cvsroot/gcl/gcl/xbin/strip-ifdef, /cvsroot/gcl/gcl/xbin/test1, /cvsroot/gcl/gcl/xbin/test, /cvsroot/gcl/gcl/xbin/test-distrib, /cvsroot/gcl/gcl/xbin/update: + initial checkin + + * /cvsroot/gcl/gcl/utils/replace, /cvsroot/gcl/gcl/utils/repls1.sed, /cvsroot/gcl/gcl/utils/repls2.sed, /cvsroot/gcl/gcl/utils/repls3.sed, /cvsroot/gcl/gcl/utils/repls4.sed, /cvsroot/gcl/gcl/utils/repls5.sed, /cvsroot/gcl/gcl/utils/revstruct.sed, /cvsroot/gcl/gcl/xbin/add-dir, /cvsroot/gcl/gcl/xbin/append, /cvsroot/gcl/gcl/xbin/append.bat, /cvsroot/gcl/gcl/xbin/compare.c, /cvsroot/gcl/gcl/xbin/compare-src, /cvsroot/gcl/gcl/xbin/comp_rel, /cvsroot/gcl/gcl/xbin/dfiles, /cvsroot/gcl/gcl/xbin/distrib-help, /cvsroot/gcl/gcl/xbin/distribute, /cvsroot/gcl/gcl/xbin/dos-files, /cvsroot/gcl/gcl/xbin/dosmake.bat, /cvsroot/gcl/gcl/xbin/exists, /cvsroot/gcl/gcl/xbin/file-sub, /cvsroot/gcl/gcl/xbin/fix-copyright, /cvsroot/gcl/gcl/xbin/get-externals, /cvsroot/gcl/gcl/xbin/get-internal-calls, /cvsroot/gcl/gcl/xbin/get-machine, /cvsroot/gcl/gcl/xbin/ibm, /cvsroot/gcl/gcl/xbin/if-exist.bat, /cvsroot/gcl/gcl/xbin/if-exists, /cvsroot/gcl/gcl/xbin/if-have-gcc, /cvsroot/gcl/gcl/xbin/inc-version, /cvsroot/gcl/gcl/xbin/is-V-newest, /cvsroot/gcl/gcl/xbin/make-fn, /cvsroot/gcl/gcl/xbin/maketest1, /cvsroot/gcl/gcl/xbin/maketest, /cvsroot/gcl/gcl/xbin/move-if-changed, /cvsroot/gcl/gcl/xbin/new-files, /cvsroot/gcl/gcl/xbin/notify, /cvsroot/gcl/gcl/xbin/setup-tmptest, /cvsroot/gcl/gcl/xbin/spp.c, /cvsroot/gcl/gcl/xbin/strip-ifdef, /cvsroot/gcl/gcl/xbin/test1, /cvsroot/gcl/gcl/xbin/test, /cvsroot/gcl/gcl/xbin/test-distrib, /cvsroot/gcl/gcl/xbin/update: + New file. + + * /cvsroot/gcl/gcl/o/nsocket.ini, /cvsroot/gcl/gcl/o/unexaix.c, /cvsroot/gcl/gcl/unixport/aix-crt0.el, /cvsroot/gcl/gcl/unixport/aix_exports, /cvsroot/gcl/gcl/unixport/boots, /cvsroot/gcl/gcl/unixport/bsd_rsym.c, /cvsroot/gcl/gcl/unixport/cmpboots, /cvsroot/gcl/gcl/unixport/gcldos.lsp, /cvsroot/gcl/gcl/unixport/gcrt0.el, /cvsroot/gcl/gcl/unixport/init_gcl.lsp, /cvsroot/gcl/gcl/unixport/init_kcn.lsp, /cvsroot/gcl/gcl/unixport/init_maxima.lsp, /cvsroot/gcl/gcl/unixport/init_xgcl.lsp, /cvsroot/gcl/gcl/unixport/lspboots, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/makefile.dos, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/unixport/ncrt0.el, /cvsroot/gcl/gcl/unixport/rsym.c, /cvsroot/gcl/gcl/unixport/rsym_elf.c, /cvsroot/gcl/gcl/unixport/rsym_nt.c, /cvsroot/gcl/gcl/unixport/so_locations, /cvsroot/gcl/gcl/unixport/sys_boot.c, /cvsroot/gcl/gcl/unixport/sys_gcl.c, /cvsroot/gcl/gcl/unixport/sys-init.lsp, /cvsroot/gcl/gcl/unixport/sys_kcn.c, /cvsroot/gcl/gcl/unixport/tryserv.tcl: + initial checkin + + * /cvsroot/gcl/gcl/o/nsocket.ini, /cvsroot/gcl/gcl/o/unexaix.c, /cvsroot/gcl/gcl/unixport/aix-crt0.el, /cvsroot/gcl/gcl/unixport/aix_exports, /cvsroot/gcl/gcl/unixport/boots, /cvsroot/gcl/gcl/unixport/bsd_rsym.c, /cvsroot/gcl/gcl/unixport/cmpboots, /cvsroot/gcl/gcl/unixport/gcldos.lsp, /cvsroot/gcl/gcl/unixport/gcrt0.el, /cvsroot/gcl/gcl/unixport/init_gcl.lsp, /cvsroot/gcl/gcl/unixport/init_kcn.lsp, /cvsroot/gcl/gcl/unixport/init_maxima.lsp, /cvsroot/gcl/gcl/unixport/init_xgcl.lsp, /cvsroot/gcl/gcl/unixport/lspboots, /cvsroot/gcl/gcl/unixport/makefile, /cvsroot/gcl/gcl/unixport/makefile.dos, /cvsroot/gcl/gcl/unixport/make_kcn, /cvsroot/gcl/gcl/unixport/ncrt0.el, /cvsroot/gcl/gcl/unixport/rsym.c, /cvsroot/gcl/gcl/unixport/rsym_elf.c, /cvsroot/gcl/gcl/unixport/rsym_nt.c, /cvsroot/gcl/gcl/unixport/so_locations, /cvsroot/gcl/gcl/unixport/sys_boot.c, /cvsroot/gcl/gcl/unixport/sys_gcl.c, /cvsroot/gcl/gcl/unixport/sys-init.lsp, /cvsroot/gcl/gcl/unixport/sys_kcn.c, /cvsroot/gcl/gcl/unixport/tryserv.tcl: + New file. + + * /cvsroot/gcl/gcl/o/clxsocket.ini, /cvsroot/gcl/gcl/o/fasdump.c, /cvsroot/gcl/gcl/o/faslnt.c, /cvsroot/gcl/gcl/o/fat_string.ini, /cvsroot/gcl/gcl/o/file.d, /cvsroot/gcl/gcl/o/firstfile.c, /cvsroot/gcl/gcl/o/init_pari.ini, /cvsroot/gcl/gcl/o/lastfile.c, /cvsroot/gcl/gcl/o/main.c, /cvsroot/gcl/gcl/o/makefun.ini, /cvsroot/gcl/gcl/o/nsocket.c, /cvsroot/gcl/gcl/o/ntheap.h, /cvsroot/gcl/gcl/o/num_co.c, /cvsroot/gcl/gcl/o/rel_coff.c, /cvsroot/gcl/gcl/o/rel_stand.c, /cvsroot/gcl/gcl/o/run_process.ini, /cvsroot/gcl/gcl/o/sfasl.c, /cvsroot/gcl/gcl/o/sfasl.ini, /cvsroot/gcl/gcl/o/sockets.ini, /cvsroot/gcl/gcl/o/try.c, /cvsroot/gcl/gcl/o/unexelfsgi.c, /cvsroot/gcl/gcl/o/unexhp9k800.c, /cvsroot/gcl/gcl/o/unexlin.c, /cvsroot/gcl/gcl/o/unexmips.c, /cvsroot/gcl/gcl/o/unexsgi.c, /cvsroot/gcl/gcl/o/unixfasl.c, /cvsroot/gcl/gcl/o/unixfsys.c, /cvsroot/gcl/gcl/o/unixsave.c, /cvsroot/gcl/gcl/o/unixsys.c, /cvsroot/gcl/gcl/o/unixtime.c, /cvsroot/gcl/gcl/o/user_init.c, /cvsroot/gcl/gcl/o/usig2_aux.c, /cvsroot/gcl/gcl/o/usig2.c, /cvsroot/gcl/gcl/o/usig.c, /cvsroot/gcl/gcl/o/utils.c, /cvsroot/gcl/gcl/o/utils.ini, /cvsroot/gcl/gcl/o/Vmalloc.c, /cvsroot/gcl/gcl/o/xdrfuns.c: + initial checkin + + * /cvsroot/gcl/gcl/o/clxsocket.ini, /cvsroot/gcl/gcl/o/fasdump.c, /cvsroot/gcl/gcl/o/faslnt.c, /cvsroot/gcl/gcl/o/fat_string.ini, /cvsroot/gcl/gcl/o/file.d, /cvsroot/gcl/gcl/o/firstfile.c, /cvsroot/gcl/gcl/o/init_pari.ini, /cvsroot/gcl/gcl/o/lastfile.c, /cvsroot/gcl/gcl/o/main.c, /cvsroot/gcl/gcl/o/makefun.ini, /cvsroot/gcl/gcl/o/nsocket.c, /cvsroot/gcl/gcl/o/ntheap.h, /cvsroot/gcl/gcl/o/num_co.c, /cvsroot/gcl/gcl/o/rel_coff.c, /cvsroot/gcl/gcl/o/rel_stand.c, /cvsroot/gcl/gcl/o/run_process.ini, /cvsroot/gcl/gcl/o/sfasl.c, /cvsroot/gcl/gcl/o/sfasl.ini, /cvsroot/gcl/gcl/o/sockets.ini, /cvsroot/gcl/gcl/o/try.c, /cvsroot/gcl/gcl/o/unexelfsgi.c, /cvsroot/gcl/gcl/o/unexhp9k800.c, /cvsroot/gcl/gcl/o/unexlin.c, /cvsroot/gcl/gcl/o/unexmips.c, /cvsroot/gcl/gcl/o/unexsgi.c, /cvsroot/gcl/gcl/o/unixfasl.c, /cvsroot/gcl/gcl/o/unixfsys.c, /cvsroot/gcl/gcl/o/unixsave.c, /cvsroot/gcl/gcl/o/unixsys.c, /cvsroot/gcl/gcl/o/unixtime.c, /cvsroot/gcl/gcl/o/user_init.c, /cvsroot/gcl/gcl/o/usig2_aux.c, /cvsroot/gcl/gcl/o/usig2.c, /cvsroot/gcl/gcl/o/usig.c, /cvsroot/gcl/gcl/o/utils.c, /cvsroot/gcl/gcl/o/utils.ini, /cvsroot/gcl/gcl/o/Vmalloc.c, /cvsroot/gcl/gcl/o/xdrfuns.c: + New file. + + * /cvsroot/gcl/gcl/o/error.ini, /cvsroot/gcl/gcl/o/funlink.ini, /cvsroot/gcl/gcl/o/nfunlink.ini, /cvsroot/gcl/gcl/o/pathname.ini, /cvsroot/gcl/gcl/o/regexp.c, /cvsroot/gcl/gcl/o/regexp.h, /cvsroot/gcl/gcl/o/regexpr.c, /cvsroot/gcl/gcl/o/rel_aix.c, /cvsroot/gcl/gcl/o/rel_hp300.c, /cvsroot/gcl/gcl/o/rel_mac2.c, /cvsroot/gcl/gcl/o/rel_ps2aix.c, /cvsroot/gcl/gcl/o/rel_rios.c, /cvsroot/gcl/gcl/o/rel_sun3.c, /cvsroot/gcl/gcl/o/rel_sun4.c, /cvsroot/gcl/gcl/o/rel_u370aix.c, /cvsroot/gcl/gcl/o/run_process.c, /cvsroot/gcl/gcl/o/saveaix3.c, /cvsroot/gcl/gcl/o/save.c, /cvsroot/gcl/gcl/o/savedec31.c, /cvsroot/gcl/gcl/o/save_sgi4.c, /cvsroot/gcl/gcl/o/saveu370.c, /cvsroot/gcl/gcl/o/sbrk.c, /cvsroot/gcl/gcl/o/sequence.d, /cvsroot/gcl/gcl/o/sfaslelf.c, /cvsroot/gcl/gcl/o/sfasli.c, /cvsroot/gcl/gcl/o/sgbc.c, /cvsroot/gcl/gcl/o/sgi4d_emul.s, /cvsroot/gcl/gcl/o/sockets.c, /cvsroot/gcl/gcl/o/strcspn.c, /cvsroot/gcl/gcl/o/string.d, /cvsroot/gcl/gcl/o/structure.c, /cvsroot/gcl/gcl/o/symbol.d, /cvsroot/gcl/gcl/o/test_memprotect.c, /cvsroot/gcl/gcl/o/toplevel.c, /cvsroot/gcl/gcl/o/typespec.c, /cvsroot/gcl/gcl/o/u370_emul.s, /cvsroot/gcl/gcl/o/unexec-19.29.c, /cvsroot/gcl/gcl/o/unexec.c, /cvsroot/gcl/gcl/o/unexelf.c, /cvsroot/gcl/gcl/o/unixfasl.ini, /cvsroot/gcl/gcl/o/unixfsys.ini, /cvsroot/gcl/gcl/o/unixsave.ini, /cvsroot/gcl/gcl/o/unixsys.ini, /cvsroot/gcl/gcl/o/unixtime.ini, /cvsroot/gcl/gcl/o/usig2.ini, /cvsroot/gcl/gcl/o/usig.ini: + initial checkin + + * /cvsroot/gcl/gcl/o/error.ini, /cvsroot/gcl/gcl/o/funlink.ini, /cvsroot/gcl/gcl/o/nfunlink.ini, /cvsroot/gcl/gcl/o/pathname.ini, /cvsroot/gcl/gcl/o/regexp.c, /cvsroot/gcl/gcl/o/regexp.h, /cvsroot/gcl/gcl/o/regexpr.c, /cvsroot/gcl/gcl/o/rel_aix.c, /cvsroot/gcl/gcl/o/rel_hp300.c, /cvsroot/gcl/gcl/o/rel_mac2.c, /cvsroot/gcl/gcl/o/rel_ps2aix.c, /cvsroot/gcl/gcl/o/rel_rios.c, /cvsroot/gcl/gcl/o/rel_sun3.c, /cvsroot/gcl/gcl/o/rel_sun4.c, /cvsroot/gcl/gcl/o/rel_u370aix.c, /cvsroot/gcl/gcl/o/run_process.c, /cvsroot/gcl/gcl/o/saveaix3.c, /cvsroot/gcl/gcl/o/save.c, /cvsroot/gcl/gcl/o/savedec31.c, /cvsroot/gcl/gcl/o/save_sgi4.c, /cvsroot/gcl/gcl/o/saveu370.c, /cvsroot/gcl/gcl/o/sbrk.c, /cvsroot/gcl/gcl/o/sequence.d, /cvsroot/gcl/gcl/o/sfaslelf.c, /cvsroot/gcl/gcl/o/sfasli.c, /cvsroot/gcl/gcl/o/sgbc.c, /cvsroot/gcl/gcl/o/sgi4d_emul.s, /cvsroot/gcl/gcl/o/sockets.c, /cvsroot/gcl/gcl/o/strcspn.c, /cvsroot/gcl/gcl/o/string.d, /cvsroot/gcl/gcl/o/structure.c, /cvsroot/gcl/gcl/o/symbol.d, /cvsroot/gcl/gcl/o/test_memprotect.c, /cvsroot/gcl/gcl/o/toplevel.c, /cvsroot/gcl/gcl/o/typespec.c, /cvsroot/gcl/gcl/o/u370_emul.s, /cvsroot/gcl/gcl/o/unexec-19.29.c, /cvsroot/gcl/gcl/o/unexec.c, /cvsroot/gcl/gcl/o/unexelf.c, /cvsroot/gcl/gcl/o/unixfasl.ini, /cvsroot/gcl/gcl/o/unixfsys.ini, /cvsroot/gcl/gcl/o/unixsave.ini, /cvsroot/gcl/gcl/o/unixsys.ini, /cvsroot/gcl/gcl/o/unixtime.ini, /cvsroot/gcl/gcl/o/usig2.ini, /cvsroot/gcl/gcl/o/usig.ini: + New file. + + * /cvsroot/gcl/gcl/o/array.ini, /cvsroot/gcl/gcl/o/backq.ini, /cvsroot/gcl/gcl/o/character.ini, /cvsroot/gcl/gcl/o/earith.ini, /cvsroot/gcl/gcl/o/file.ini, /cvsroot/gcl/gcl/o/format.ini, /cvsroot/gcl/gcl/o/hash.ini, /cvsroot/gcl/gcl/o/list.ini, /cvsroot/gcl/gcl/o/mapfun.c, /cvsroot/gcl/gcl/o/multival.c, /cvsroot/gcl/gcl/o/ndiv.c, /cvsroot/gcl/gcl/o/new_init.c, /cvsroot/gcl/gcl/o/NeXTunixfasl.c, /cvsroot/gcl/gcl/o/NeXTunixsave.c, /cvsroot/gcl/gcl/o/nfunlink.c, /cvsroot/gcl/gcl/o/nmul.c, /cvsroot/gcl/gcl/o/num_arith.c, /cvsroot/gcl/gcl/o/number.c, /cvsroot/gcl/gcl/o/num_co.ini, /cvsroot/gcl/gcl/o/num_comp.c, /cvsroot/gcl/gcl/o/num_log.c, /cvsroot/gcl/gcl/o/num_log.ini, /cvsroot/gcl/gcl/o/num_pred.c, /cvsroot/gcl/gcl/o/num_rand.c, /cvsroot/gcl/gcl/o/num_rand.ini, /cvsroot/gcl/gcl/o/num_sfun.c, /cvsroot/gcl/gcl/o/package.d, /cvsroot/gcl/gcl/o/pathname.d, /cvsroot/gcl/gcl/o/peculiar.c, /cvsroot/gcl/gcl/o/predicate.c, /cvsroot/gcl/gcl/o/pre_init.c, /cvsroot/gcl/gcl/o/print.d, /cvsroot/gcl/gcl/o/print.ini, /cvsroot/gcl/gcl/o/prog.c, /cvsroot/gcl/gcl/o/read.d, /cvsroot/gcl/gcl/o/read.ini, /cvsroot/gcl/gcl/o/readme, /cvsroot/gcl/gcl/o/reference.c, /cvsroot/gcl/gcl/o/regexpr.ini, /cvsroot/gcl/gcl/o/sequence.ini, /cvsroot/gcl/gcl/o/string.ini, /cvsroot/gcl/gcl/o/structure.ini, /cvsroot/gcl/gcl/o/toplevel.ini: + initial checkin + + * /cvsroot/gcl/gcl/o/array.ini, /cvsroot/gcl/gcl/o/backq.ini, /cvsroot/gcl/gcl/o/character.ini, /cvsroot/gcl/gcl/o/earith.ini, /cvsroot/gcl/gcl/o/file.ini, /cvsroot/gcl/gcl/o/format.ini, /cvsroot/gcl/gcl/o/hash.ini, /cvsroot/gcl/gcl/o/list.ini, /cvsroot/gcl/gcl/o/mapfun.c, /cvsroot/gcl/gcl/o/multival.c, /cvsroot/gcl/gcl/o/ndiv.c, /cvsroot/gcl/gcl/o/new_init.c, /cvsroot/gcl/gcl/o/NeXTunixfasl.c, /cvsroot/gcl/gcl/o/NeXTunixsave.c, /cvsroot/gcl/gcl/o/nfunlink.c, /cvsroot/gcl/gcl/o/nmul.c, /cvsroot/gcl/gcl/o/num_arith.c, /cvsroot/gcl/gcl/o/number.c, /cvsroot/gcl/gcl/o/num_co.ini, /cvsroot/gcl/gcl/o/num_comp.c, /cvsroot/gcl/gcl/o/num_log.c, /cvsroot/gcl/gcl/o/num_log.ini, /cvsroot/gcl/gcl/o/num_pred.c, /cvsroot/gcl/gcl/o/num_rand.c, /cvsroot/gcl/gcl/o/num_rand.ini, /cvsroot/gcl/gcl/o/num_sfun.c, /cvsroot/gcl/gcl/o/package.d, /cvsroot/gcl/gcl/o/pathname.d, /cvsroot/gcl/gcl/o/peculiar.c, /cvsroot/gcl/gcl/o/predicate.c, /cvsroot/gcl/gcl/o/pre_init.c, /cvsroot/gcl/gcl/o/print.d, /cvsroot/gcl/gcl/o/print.ini, /cvsroot/gcl/gcl/o/prog.c, /cvsroot/gcl/gcl/o/read.d, /cvsroot/gcl/gcl/o/read.ini, /cvsroot/gcl/gcl/o/readme, /cvsroot/gcl/gcl/o/reference.c, /cvsroot/gcl/gcl/o/regexpr.ini, /cvsroot/gcl/gcl/o/sequence.ini, /cvsroot/gcl/gcl/o/string.ini, /cvsroot/gcl/gcl/o/structure.ini, /cvsroot/gcl/gcl/o/toplevel.ini: + New file. + + * /cvsroot/gcl/gcl/o/big.ini, /cvsroot/gcl/gcl/o/catch.ini, /cvsroot/gcl/gcl/o/cfun.ini, /cvsroot/gcl/gcl/o/cmpaux.ini, /cvsroot/gcl/gcl/o/conditional.ini, /cvsroot/gcl/gcl/o/faslsgi4.c, /cvsroot/gcl/gcl/o/fat_string.c, /cvsroot/gcl/gcl/o/fix-structref.el, /cvsroot/gcl/gcl/o/format.c, /cvsroot/gcl/gcl/o/frame.c, /cvsroot/gcl/gcl/o/funlink.c, /cvsroot/gcl/gcl/o/funs, /cvsroot/gcl/gcl/o/gbc.c, /cvsroot/gcl/gcl/o/gdb_commands, /cvsroot/gcl/gcl/o/gnumalloc.c, /cvsroot/gcl/gcl/o/grab_defs.c, /cvsroot/gcl/gcl/o/grab_defs.u, /cvsroot/gcl/gcl/o/hash.d, /cvsroot/gcl/gcl/o/help.el, /cvsroot/gcl/gcl/o/init_pari.c, /cvsroot/gcl/gcl/o/internal-calls.lisp, /cvsroot/gcl/gcl/o/iteration.c, /cvsroot/gcl/gcl/o/let.c, /cvsroot/gcl/gcl/o/lex.c, /cvsroot/gcl/gcl/o/list.d, /cvsroot/gcl/gcl/o/littleXwin.c, /cvsroot/gcl/gcl/o/macros.c, /cvsroot/gcl/gcl/o/makefun.c, /cvsroot/gcl/gcl/o/multival.ini, /cvsroot/gcl/gcl/o/mych, /cvsroot/gcl/gcl/o/num_arith.ini, /cvsroot/gcl/gcl/o/number.ini, /cvsroot/gcl/gcl/o/num_comp.ini, /cvsroot/gcl/gcl/o/num_pred.ini, /cvsroot/gcl/gcl/o/num_sfun.ini, /cvsroot/gcl/gcl/o/package.ini, /cvsroot/gcl/gcl/o/prog.ini, /cvsroot/gcl/gcl/o/symbol.ini, /cvsroot/gcl/gcl/o/unexnt.c: + initial checkin + + * /cvsroot/gcl/gcl/o/big.ini, /cvsroot/gcl/gcl/o/catch.ini, /cvsroot/gcl/gcl/o/cfun.ini, /cvsroot/gcl/gcl/o/cmpaux.ini, /cvsroot/gcl/gcl/o/conditional.ini, /cvsroot/gcl/gcl/o/faslsgi4.c, /cvsroot/gcl/gcl/o/fat_string.c, /cvsroot/gcl/gcl/o/fix-structref.el, /cvsroot/gcl/gcl/o/format.c, /cvsroot/gcl/gcl/o/frame.c, /cvsroot/gcl/gcl/o/funlink.c, /cvsroot/gcl/gcl/o/funs, /cvsroot/gcl/gcl/o/gbc.c, /cvsroot/gcl/gcl/o/gdb_commands, /cvsroot/gcl/gcl/o/gnumalloc.c, /cvsroot/gcl/gcl/o/grab_defs.c, /cvsroot/gcl/gcl/o/grab_defs.u, /cvsroot/gcl/gcl/o/hash.d, /cvsroot/gcl/gcl/o/help.el, /cvsroot/gcl/gcl/o/init_pari.c, /cvsroot/gcl/gcl/o/internal-calls.lisp, /cvsroot/gcl/gcl/o/iteration.c, /cvsroot/gcl/gcl/o/let.c, /cvsroot/gcl/gcl/o/lex.c, /cvsroot/gcl/gcl/o/list.d, /cvsroot/gcl/gcl/o/littleXwin.c, /cvsroot/gcl/gcl/o/macros.c, /cvsroot/gcl/gcl/o/makefun.c, /cvsroot/gcl/gcl/o/multival.ini, /cvsroot/gcl/gcl/o/mych, /cvsroot/gcl/gcl/o/num_arith.ini, /cvsroot/gcl/gcl/o/number.ini, /cvsroot/gcl/gcl/o/num_comp.ini, /cvsroot/gcl/gcl/o/num_pred.ini, /cvsroot/gcl/gcl/o/num_sfun.ini, /cvsroot/gcl/gcl/o/package.ini, /cvsroot/gcl/gcl/o/prog.ini, /cvsroot/gcl/gcl/o/symbol.ini, /cvsroot/gcl/gcl/o/unexnt.c: + New file. + + * /cvsroot/gcl/gcl/o/alloc.c, /cvsroot/gcl/gcl/o/assignment.c, /cvsroot/gcl/gcl/o/assignment.ini, /cvsroot/gcl/gcl/o/backq.c, /cvsroot/gcl/gcl/o/bcmp.c, /cvsroot/gcl/gcl/o/bcopy.c, /cvsroot/gcl/gcl/o/bds.c, /cvsroot/gcl/gcl/o/bds.ini, /cvsroot/gcl/gcl/o/before_init.c, /cvsroot/gcl/gcl/o/big.c, /cvsroot/gcl/gcl/o/bind.c, /cvsroot/gcl/gcl/o/bind.ini, /cvsroot/gcl/gcl/o/bind.texi, /cvsroot/gcl/gcl/o/bitop.c, /cvsroot/gcl/gcl/o/bitop.ini, /cvsroot/gcl/gcl/o/block.c, /cvsroot/gcl/gcl/o/block.ini, /cvsroot/gcl/gcl/o/bsearch.c, /cvsroot/gcl/gcl/o/bzero.c, /cvsroot/gcl/gcl/o/catch.c, /cvsroot/gcl/gcl/o/cfun.c, /cvsroot/gcl/gcl/o/ChangeLog, /cvsroot/gcl/gcl/o/character.d, /cvsroot/gcl/gcl/o/clxsocket.c, /cvsroot/gcl/gcl/o/cmac.c, /cvsroot/gcl/gcl/o/cmpaux.c, /cvsroot/gcl/gcl/o/conditional.c, /cvsroot/gcl/gcl/o/earith.c, /cvsroot/gcl/gcl/o/egrep-def, /cvsroot/gcl/gcl/o/error.c, /cvsroot/gcl/gcl/o/eval.c, /cvsroot/gcl/gcl/o/eval.ini, /cvsroot/gcl/gcl/o/external_funs.h, /cvsroot/gcl/gcl/o/fasldlsym.c, /cvsroot/gcl/gcl/o/fasldlsym.c.link, /cvsroot/gcl/gcl/o/faslhp800.c, /cvsroot/gcl/gcl/o/frame.ini, /cvsroot/gcl/gcl/o/gbc.ini, /cvsroot/gcl/gcl/o/iteration.ini, /cvsroot/gcl/gcl/o/let.ini, /cvsroot/gcl/gcl/o/lex.ini, /cvsroot/gcl/gcl/o/macros.ini, /cvsroot/gcl/gcl/o/malloc.c, /cvsroot/gcl/gcl/o/mapfun.ini, /cvsroot/gcl/gcl/o/predicate.ini, /cvsroot/gcl/gcl/o/reference.ini, /cvsroot/gcl/gcl/o/st, /cvsroot/gcl/gcl/o/typespec.ini: + initial checkin + + * /cvsroot/gcl/gcl/o/alloc.c, /cvsroot/gcl/gcl/o/assignment.c, /cvsroot/gcl/gcl/o/assignment.ini, /cvsroot/gcl/gcl/o/backq.c, /cvsroot/gcl/gcl/o/bcmp.c, /cvsroot/gcl/gcl/o/bcopy.c, /cvsroot/gcl/gcl/o/bds.c, /cvsroot/gcl/gcl/o/bds.ini, /cvsroot/gcl/gcl/o/before_init.c, /cvsroot/gcl/gcl/o/big.c, /cvsroot/gcl/gcl/o/bind.c, /cvsroot/gcl/gcl/o/bind.ini, /cvsroot/gcl/gcl/o/bind.texi, /cvsroot/gcl/gcl/o/bitop.c, /cvsroot/gcl/gcl/o/bitop.ini, /cvsroot/gcl/gcl/o/block.c, /cvsroot/gcl/gcl/o/block.ini, /cvsroot/gcl/gcl/o/bsearch.c, /cvsroot/gcl/gcl/o/bzero.c, /cvsroot/gcl/gcl/o/catch.c, /cvsroot/gcl/gcl/o/cfun.c, /cvsroot/gcl/gcl/o/ChangeLog, /cvsroot/gcl/gcl/o/character.d, /cvsroot/gcl/gcl/o/clxsocket.c, /cvsroot/gcl/gcl/o/cmac.c, /cvsroot/gcl/gcl/o/cmpaux.c, /cvsroot/gcl/gcl/o/conditional.c, /cvsroot/gcl/gcl/o/earith.c, /cvsroot/gcl/gcl/o/egrep-def, /cvsroot/gcl/gcl/o/error.c, /cvsroot/gcl/gcl/o/eval.c, /cvsroot/gcl/gcl/o/eval.ini, /cvsroot/gcl/gcl/o/external_funs.h, /cvsroot/gcl/gcl/o/fasldlsym.c, /cvsroot/gcl/gcl/o/fasldlsym.c.link, /cvsroot/gcl/gcl/o/faslhp800.c, /cvsroot/gcl/gcl/o/frame.ini, /cvsroot/gcl/gcl/o/gbc.ini, /cvsroot/gcl/gcl/o/iteration.ini, /cvsroot/gcl/gcl/o/let.ini, /cvsroot/gcl/gcl/o/lex.ini, /cvsroot/gcl/gcl/o/macros.ini, /cvsroot/gcl/gcl/o/malloc.c, /cvsroot/gcl/gcl/o/mapfun.ini, /cvsroot/gcl/gcl/o/predicate.ini, /cvsroot/gcl/gcl/o/reference.ini, /cvsroot/gcl/gcl/o/st, /cvsroot/gcl/gcl/o/typespec.ini: + New file. + + * /cvsroot/gcl/gcl/misc/warn-slow.lsp, /cvsroot/gcl/gcl/mp/fplus.c, /cvsroot/gcl/gcl/mp/gcclab, /cvsroot/gcl/gcl/mp/gcclab.awk, /cvsroot/gcl/gcl/mp/gnulib1.c, /cvsroot/gcl/gcl/mp/lo-ibmrt.s, /cvsroot/gcl/gcl/mp/lo-rios1.s, /cvsroot/gcl/gcl/mp/lo-rios.s, /cvsroot/gcl/gcl/mp/lo-sgi4d.s, /cvsroot/gcl/gcl/mp/lo-u370_aix.s, /cvsroot/gcl/gcl/mp/make.defs, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/mp/mp2.c, /cvsroot/gcl/gcl/mp/mp_addmul.c, /cvsroot/gcl/gcl/mp/mp_bfffo.c, /cvsroot/gcl/gcl/mp/mp_dblrsl3.c, /cvsroot/gcl/gcl/mp/mp_dblrul3.c, /cvsroot/gcl/gcl/mp/mp_divul3.c, /cvsroot/gcl/gcl/mp/mp_divul3_word.c, /cvsroot/gcl/gcl/mp/mpi-386d.S, /cvsroot/gcl/gcl/mp/mpi-386_no_under.s, /cvsroot/gcl/gcl/mp/mpi-bsd68k.s, /cvsroot/gcl/gcl/mp/mpi.c, /cvsroot/gcl/gcl/mp/mpi-sol-sparc.s, /cvsroot/gcl/gcl/mp/mpi-sparc.s, /cvsroot/gcl/gcl/mp/mp_mulul3.c, /cvsroot/gcl/gcl/mp/mp_shiftl.c, /cvsroot/gcl/gcl/mp/mp_sl3todivul3.c, /cvsroot/gcl/gcl/mp/readme, /cvsroot/gcl/gcl/mp/sparcdivul3.s, /cvsroot/gcl/gcl/o/alloc.ini, /cvsroot/gcl/gcl/o/array.c1, /cvsroot/gcl/gcl/o/array.c, /cvsroot/gcl/gcl/o/array.c.prev, /cvsroot/gcl/gcl/o/cmpinclude.h, /cvsroot/gcl/gcl/o/main.ini, /cvsroot/gcl/gcl/o/makefile: + initial checkin + + * /cvsroot/gcl/gcl/misc/warn-slow.lsp, /cvsroot/gcl/gcl/mp/fplus.c, /cvsroot/gcl/gcl/mp/gcclab, /cvsroot/gcl/gcl/mp/gcclab.awk, /cvsroot/gcl/gcl/mp/gnulib1.c, /cvsroot/gcl/gcl/mp/lo-ibmrt.s, /cvsroot/gcl/gcl/mp/lo-rios1.s, /cvsroot/gcl/gcl/mp/lo-rios.s, /cvsroot/gcl/gcl/mp/lo-sgi4d.s, /cvsroot/gcl/gcl/mp/lo-u370_aix.s, /cvsroot/gcl/gcl/mp/make.defs, /cvsroot/gcl/gcl/mp/makefile, /cvsroot/gcl/gcl/mp/mp2.c, /cvsroot/gcl/gcl/mp/mp_addmul.c, /cvsroot/gcl/gcl/mp/mp_bfffo.c, /cvsroot/gcl/gcl/mp/mp_dblrsl3.c, /cvsroot/gcl/gcl/mp/mp_dblrul3.c, /cvsroot/gcl/gcl/mp/mp_divul3.c, /cvsroot/gcl/gcl/mp/mp_divul3_word.c, /cvsroot/gcl/gcl/mp/mpi-386d.S, /cvsroot/gcl/gcl/mp/mpi-386_no_under.s, /cvsroot/gcl/gcl/mp/mpi-bsd68k.s, /cvsroot/gcl/gcl/mp/mpi.c, /cvsroot/gcl/gcl/mp/mpi-sol-sparc.s, /cvsroot/gcl/gcl/mp/mpi-sparc.s, /cvsroot/gcl/gcl/mp/mp_mulul3.c, /cvsroot/gcl/gcl/mp/mp_shiftl.c, /cvsroot/gcl/gcl/mp/mp_sl3todivul3.c, /cvsroot/gcl/gcl/mp/readme, /cvsroot/gcl/gcl/mp/sparcdivul3.s, /cvsroot/gcl/gcl/o/alloc.ini, /cvsroot/gcl/gcl/o/array.c1, /cvsroot/gcl/gcl/o/array.c, /cvsroot/gcl/gcl/o/array.c.prev, /cvsroot/gcl/gcl/o/cmpinclude.h, /cvsroot/gcl/gcl/o/main.ini, /cvsroot/gcl/gcl/o/makefile: + New file. + + * /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/lsp/serror.data, /cvsroot/gcl/gcl/lsp/serror.h, /cvsroot/gcl/gcl/lsp/sloop.data, /cvsroot/gcl/gcl/lsp/sloop.h, /cvsroot/gcl/gcl/lsp/sloop.lsp, /cvsroot/gcl/gcl/lsp/stack-problem.lsp, /cvsroot/gcl/gcl/lsp/stdlisp.lsp, /cvsroot/gcl/gcl/lsp/sys-proclaim.lisp, /cvsroot/gcl/gcl/lsp/top.c, /cvsroot/gcl/gcl/lsp/top.data, /cvsroot/gcl/gcl/lsp/top.h, /cvsroot/gcl/gcl/lsp/top.lsp, /cvsroot/gcl/gcl/lsp/trace.c, /cvsroot/gcl/gcl/lsp/trace.data, /cvsroot/gcl/gcl/lsp/trace.h, /cvsroot/gcl/gcl/lsp/trace.lsp, /cvsroot/gcl/gcl/lsp/ucall.lisp, /cvsroot/gcl/gcl/lsp/ustreams.lisp, /cvsroot/gcl/gcl/man/man1/gcl.1, /cvsroot/gcl/gcl/misc/check.c, /cvsroot/gcl/gcl/misc/check_obj.c, /cvsroot/gcl/gcl/misc/cstruct.lsp, /cvsroot/gcl/gcl/misc/foreign.lsp, /cvsroot/gcl/gcl/misc/mprotect.ch, /cvsroot/gcl/gcl/misc/rusage.lsp, /cvsroot/gcl/gcl/misc/test-seek.c, /cvsroot/gcl/gcl/misc/test-sgc.lsp: + initial checkin + + * /cvsroot/gcl/gcl/lsp/makefile, /cvsroot/gcl/gcl/lsp/serror.data, /cvsroot/gcl/gcl/lsp/serror.h, /cvsroot/gcl/gcl/lsp/sloop.data, /cvsroot/gcl/gcl/lsp/sloop.h, /cvsroot/gcl/gcl/lsp/sloop.lsp, /cvsroot/gcl/gcl/lsp/stack-problem.lsp, /cvsroot/gcl/gcl/lsp/stdlisp.lsp, /cvsroot/gcl/gcl/lsp/sys-proclaim.lisp, /cvsroot/gcl/gcl/lsp/top.c, /cvsroot/gcl/gcl/lsp/top.data, /cvsroot/gcl/gcl/lsp/top.h, /cvsroot/gcl/gcl/lsp/top.lsp, /cvsroot/gcl/gcl/lsp/trace.c, /cvsroot/gcl/gcl/lsp/trace.data, /cvsroot/gcl/gcl/lsp/trace.h, /cvsroot/gcl/gcl/lsp/trace.lsp, /cvsroot/gcl/gcl/lsp/ucall.lisp, /cvsroot/gcl/gcl/lsp/ustreams.lisp, /cvsroot/gcl/gcl/man/man1/gcl.1, /cvsroot/gcl/gcl/misc/check.c, /cvsroot/gcl/gcl/misc/check_obj.c, /cvsroot/gcl/gcl/misc/cstruct.lsp, /cvsroot/gcl/gcl/misc/foreign.lsp, /cvsroot/gcl/gcl/misc/mprotect.ch, /cvsroot/gcl/gcl/misc/rusage.lsp, /cvsroot/gcl/gcl/misc/test-seek.c, /cvsroot/gcl/gcl/misc/test-sgc.lsp: + New file. + + * /cvsroot/gcl/gcl/lsp/littleXlsp.lsp, /cvsroot/gcl/gcl/lsp/loadcmp.lsp, /cvsroot/gcl/gcl/lsp/make-declare.lsp, /cvsroot/gcl/gcl/lsp/make.lisp, /cvsroot/gcl/gcl/lsp/mislib.c, /cvsroot/gcl/gcl/lsp/mislib.data, /cvsroot/gcl/gcl/lsp/mislib.h, /cvsroot/gcl/gcl/lsp/mislib.lsp, /cvsroot/gcl/gcl/lsp/module.c, /cvsroot/gcl/gcl/lsp/module.data, /cvsroot/gcl/gcl/lsp/module.h, /cvsroot/gcl/gcl/lsp/module.lsp, /cvsroot/gcl/gcl/lsp/numlib.c, /cvsroot/gcl/gcl/lsp/numlib.data, /cvsroot/gcl/gcl/lsp/numlib.h, /cvsroot/gcl/gcl/lsp/numlib.lsp, /cvsroot/gcl/gcl/lsp/packages.lsp, /cvsroot/gcl/gcl/lsp/packlib.c, /cvsroot/gcl/gcl/lsp/packlib.data, /cvsroot/gcl/gcl/lsp/packlib.h, /cvsroot/gcl/gcl/lsp/packlib.lsp, /cvsroot/gcl/gcl/lsp/predlib.c, /cvsroot/gcl/gcl/lsp/predlib.data, /cvsroot/gcl/gcl/lsp/predlib.h, /cvsroot/gcl/gcl/lsp/predlib.lsp, /cvsroot/gcl/gcl/lsp/profile.lsp, /cvsroot/gcl/gcl/lsp/seq.c, /cvsroot/gcl/gcl/lsp/seq.data, /cvsroot/gcl/gcl/lsp/seq.h, /cvsroot/gcl/gcl/lsp/seqlib.c, /cvsroot/gcl/gcl/lsp/seqlib.data, /cvsroot/gcl/gcl/lsp/seqlib.h, /cvsroot/gcl/gcl/lsp/seqlib.lsp, /cvsroot/gcl/gcl/lsp/seq.lsp, /cvsroot/gcl/gcl/lsp/serror.lsp, /cvsroot/gcl/gcl/lsp/setf.c, /cvsroot/gcl/gcl/lsp/setf.data, /cvsroot/gcl/gcl/lsp/setf.h, /cvsroot/gcl/gcl/lsp/setf.lsp, /cvsroot/gcl/gcl/lsp/sloop.c: + initial checkin + + * /cvsroot/gcl/gcl/lsp/littleXlsp.lsp, /cvsroot/gcl/gcl/lsp/loadcmp.lsp, /cvsroot/gcl/gcl/lsp/make-declare.lsp, /cvsroot/gcl/gcl/lsp/make.lisp, /cvsroot/gcl/gcl/lsp/mislib.c, /cvsroot/gcl/gcl/lsp/mislib.data, /cvsroot/gcl/gcl/lsp/mislib.h, /cvsroot/gcl/gcl/lsp/mislib.lsp, /cvsroot/gcl/gcl/lsp/module.c, /cvsroot/gcl/gcl/lsp/module.data, /cvsroot/gcl/gcl/lsp/module.h, /cvsroot/gcl/gcl/lsp/module.lsp, /cvsroot/gcl/gcl/lsp/numlib.c, /cvsroot/gcl/gcl/lsp/numlib.data, /cvsroot/gcl/gcl/lsp/numlib.h, /cvsroot/gcl/gcl/lsp/numlib.lsp, /cvsroot/gcl/gcl/lsp/packages.lsp, /cvsroot/gcl/gcl/lsp/packlib.c, /cvsroot/gcl/gcl/lsp/packlib.data, /cvsroot/gcl/gcl/lsp/packlib.h, /cvsroot/gcl/gcl/lsp/packlib.lsp, /cvsroot/gcl/gcl/lsp/predlib.c, /cvsroot/gcl/gcl/lsp/predlib.data, /cvsroot/gcl/gcl/lsp/predlib.h, /cvsroot/gcl/gcl/lsp/predlib.lsp, /cvsroot/gcl/gcl/lsp/profile.lsp, /cvsroot/gcl/gcl/lsp/seq.c, /cvsroot/gcl/gcl/lsp/seq.data, /cvsroot/gcl/gcl/lsp/seq.h, /cvsroot/gcl/gcl/lsp/seqlib.c, /cvsroot/gcl/gcl/lsp/seqlib.data, /cvsroot/gcl/gcl/lsp/seqlib.h, /cvsroot/gcl/gcl/lsp/seqlib.lsp, /cvsroot/gcl/gcl/lsp/seq.lsp, /cvsroot/gcl/gcl/lsp/serror.lsp, /cvsroot/gcl/gcl/lsp/setf.c, /cvsroot/gcl/gcl/lsp/setf.data, /cvsroot/gcl/gcl/lsp/setf.h, /cvsroot/gcl/gcl/lsp/setf.lsp, /cvsroot/gcl/gcl/lsp/sloop.c: + New file. + + * /cvsroot/gcl/gcl/lsp/debug.h, /cvsroot/gcl/gcl/lsp/debug.lsp, /cvsroot/gcl/gcl/lsp/defmacro.c, /cvsroot/gcl/gcl/lsp/defmacro.data, /cvsroot/gcl/gcl/lsp/defmacro.h, /cvsroot/gcl/gcl/lsp/defmacro.lsp, /cvsroot/gcl/gcl/lsp/defstruct.c, /cvsroot/gcl/gcl/lsp/defstruct.data, /cvsroot/gcl/gcl/lsp/defstruct.h, /cvsroot/gcl/gcl/lsp/defstruct.lsp, /cvsroot/gcl/gcl/lsp/describe.c, /cvsroot/gcl/gcl/lsp/describe.data, /cvsroot/gcl/gcl/lsp/describe.h, /cvsroot/gcl/gcl/lsp/describe.lsp, /cvsroot/gcl/gcl/lsp/desetq.lsp, /cvsroot/gcl/gcl/lsp/doc-file.lsp, /cvsroot/gcl/gcl/lsp/dummy.lisp, /cvsroot/gcl/gcl/lsp/evalmacros.c, /cvsroot/gcl/gcl/lsp/evalmacros.data, /cvsroot/gcl/gcl/lsp/evalmacros.h, /cvsroot/gcl/gcl/lsp/evalmacros.lsp, /cvsroot/gcl/gcl/lsp/export.lsp, /cvsroot/gcl/gcl/lsp/fasd.lisp, /cvsroot/gcl/gcl/lsp/fast-mv.lisp, /cvsroot/gcl/gcl/lsp/fdecl.lsp, /cvsroot/gcl/gcl/lsp/gprof1.lisp, /cvsroot/gcl/gcl/lsp/gprof_aix.hc, /cvsroot/gcl/gcl/lsp/gprof.hc, /cvsroot/gcl/gcl/lsp/gprof.lsp, /cvsroot/gcl/gcl/lsp/info.c, /cvsroot/gcl/gcl/lsp/info.data, /cvsroot/gcl/gcl/lsp/info.h, /cvsroot/gcl/gcl/lsp/info.lsp, /cvsroot/gcl/gcl/lsp/iolib.c, /cvsroot/gcl/gcl/lsp/iolib.data, /cvsroot/gcl/gcl/lsp/iolib.h, /cvsroot/gcl/gcl/lsp/iolib.lsp, /cvsroot/gcl/gcl/lsp/jim, /cvsroot/gcl/gcl/lsp/listlib.c, /cvsroot/gcl/gcl/lsp/listlib.data, /cvsroot/gcl/gcl/lsp/listlib.h, /cvsroot/gcl/gcl/lsp/listlib.lsp, /cvsroot/gcl/gcl/lsp/serror.c: + initial checkin + + * /cvsroot/gcl/gcl/lsp/debug.h, /cvsroot/gcl/gcl/lsp/debug.lsp, /cvsroot/gcl/gcl/lsp/defmacro.c, /cvsroot/gcl/gcl/lsp/defmacro.data, /cvsroot/gcl/gcl/lsp/defmacro.h, /cvsroot/gcl/gcl/lsp/defmacro.lsp, /cvsroot/gcl/gcl/lsp/defstruct.c, /cvsroot/gcl/gcl/lsp/defstruct.data, /cvsroot/gcl/gcl/lsp/defstruct.h, /cvsroot/gcl/gcl/lsp/defstruct.lsp, /cvsroot/gcl/gcl/lsp/describe.c, /cvsroot/gcl/gcl/lsp/describe.data, /cvsroot/gcl/gcl/lsp/describe.h, /cvsroot/gcl/gcl/lsp/describe.lsp, /cvsroot/gcl/gcl/lsp/desetq.lsp, /cvsroot/gcl/gcl/lsp/doc-file.lsp, /cvsroot/gcl/gcl/lsp/dummy.lisp, /cvsroot/gcl/gcl/lsp/evalmacros.c, /cvsroot/gcl/gcl/lsp/evalmacros.data, /cvsroot/gcl/gcl/lsp/evalmacros.h, /cvsroot/gcl/gcl/lsp/evalmacros.lsp, /cvsroot/gcl/gcl/lsp/export.lsp, /cvsroot/gcl/gcl/lsp/fasd.lisp, /cvsroot/gcl/gcl/lsp/fast-mv.lisp, /cvsroot/gcl/gcl/lsp/fdecl.lsp, /cvsroot/gcl/gcl/lsp/gprof1.lisp, /cvsroot/gcl/gcl/lsp/gprof_aix.hc, /cvsroot/gcl/gcl/lsp/gprof.hc, /cvsroot/gcl/gcl/lsp/gprof.lsp, /cvsroot/gcl/gcl/lsp/info.c, /cvsroot/gcl/gcl/lsp/info.data, /cvsroot/gcl/gcl/lsp/info.h, /cvsroot/gcl/gcl/lsp/info.lsp, /cvsroot/gcl/gcl/lsp/iolib.c, /cvsroot/gcl/gcl/lsp/iolib.data, /cvsroot/gcl/gcl/lsp/iolib.h, /cvsroot/gcl/gcl/lsp/iolib.lsp, /cvsroot/gcl/gcl/lsp/jim, /cvsroot/gcl/gcl/lsp/listlib.c, /cvsroot/gcl/gcl/lsp/listlib.data, /cvsroot/gcl/gcl/lsp/listlib.h, /cvsroot/gcl/gcl/lsp/listlib.lsp, /cvsroot/gcl/gcl/lsp/serror.c: + New file. + + * /cvsroot/gcl/gcl/info/gcl-si.info-1.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-1.gz, /cvsroot/gcl/gcl/info/sequence.texi, /cvsroot/gcl/gcl/info/si-defs.texi, /cvsroot/gcl/gcl/info/structure.texi, /cvsroot/gcl/gcl/info/symbol.texi, /cvsroot/gcl/gcl/info/system.texi, /cvsroot/gcl/gcl/info/texinfo.tex, /cvsroot/gcl/gcl/info/type.texi, /cvsroot/gcl/gcl/info/user-interface.texi, /cvsroot/gcl/gcl/info/widgets.texi, /cvsroot/gcl/gcl/lsp/arraylib.c, /cvsroot/gcl/gcl/lsp/arraylib.data, /cvsroot/gcl/gcl/lsp/arraylib.h, /cvsroot/gcl/gcl/lsp/arraylib.lsp, /cvsroot/gcl/gcl/lsp/assert.c, /cvsroot/gcl/gcl/lsp/assert.data, /cvsroot/gcl/gcl/lsp/assert.h, /cvsroot/gcl/gcl/lsp/assert.lsp, /cvsroot/gcl/gcl/lsp/autocmp.lsp, /cvsroot/gcl/gcl/lsp/autoload.lsp, /cvsroot/gcl/gcl/lsp/auto.lsp, /cvsroot/gcl/gcl/lsp/cmpinit.lsp, /cvsroot/gcl/gcl/lsp/dbind.lisp, /cvsroot/gcl/gcl/lsp/debug.c, /cvsroot/gcl/gcl/lsp/debug.data: + initial checkin + + * /cvsroot/gcl/gcl/info/gcl-si.info-1.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-1.gz, /cvsroot/gcl/gcl/info/sequence.texi, /cvsroot/gcl/gcl/info/si-defs.texi, /cvsroot/gcl/gcl/info/structure.texi, /cvsroot/gcl/gcl/info/symbol.texi, /cvsroot/gcl/gcl/info/system.texi, /cvsroot/gcl/gcl/info/texinfo.tex, /cvsroot/gcl/gcl/info/type.texi, /cvsroot/gcl/gcl/info/user-interface.texi, /cvsroot/gcl/gcl/info/widgets.texi, /cvsroot/gcl/gcl/lsp/arraylib.c, /cvsroot/gcl/gcl/lsp/arraylib.data, /cvsroot/gcl/gcl/lsp/arraylib.h, /cvsroot/gcl/gcl/lsp/arraylib.lsp, /cvsroot/gcl/gcl/lsp/assert.c, /cvsroot/gcl/gcl/lsp/assert.data, /cvsroot/gcl/gcl/lsp/assert.h, /cvsroot/gcl/gcl/lsp/assert.lsp, /cvsroot/gcl/gcl/lsp/autocmp.lsp, /cvsroot/gcl/gcl/lsp/autoload.lsp, /cvsroot/gcl/gcl/lsp/auto.lsp, /cvsroot/gcl/gcl/lsp/cmpinit.lsp, /cvsroot/gcl/gcl/lsp/dbind.lisp, /cvsroot/gcl/gcl/lsp/debug.c, /cvsroot/gcl/gcl/lsp/debug.data: + New file. + + * /cvsroot/gcl/gcl/info/character.texi, /cvsroot/gcl/gcl/info/compiler-defs.texi, /cvsroot/gcl/gcl/info/compile.texi, /cvsroot/gcl/gcl/info/control.texi, /cvsroot/gcl/gcl/info/debug.texi, /cvsroot/gcl/gcl/info/doc.texi, /cvsroot/gcl/gcl/info/form.texi, /cvsroot/gcl/gcl/info/gcl-si.cp, /cvsroot/gcl/gcl/info/gcl-si-index.texi, /cvsroot/gcl/gcl/info/gcl-si.info, /cvsroot/gcl/gcl/info/gcl-si.info-2.gz, /cvsroot/gcl/gcl/info/gcl-si.info-3.gz, /cvsroot/gcl/gcl/info/gcl-si.info-4.gz, /cvsroot/gcl/gcl/info/gcl-si.info-5.gz, /cvsroot/gcl/gcl/info/gcl-si.info-6.gz, /cvsroot/gcl/gcl/info/gcl-si.ky, /cvsroot/gcl/gcl/info/gcl-si.pg, /cvsroot/gcl/gcl/info/gcl-si.texi, /cvsroot/gcl/gcl/info/gcl-si.toc, /cvsroot/gcl/gcl/info/gcl-si.tp, /cvsroot/gcl/gcl/info/gcl-si.vr, /cvsroot/gcl/gcl/info/gcl-tk.cp, /cvsroot/gcl/gcl/info/gcl-tk.info, /cvsroot/gcl/gcl/info/gcl-tk.info-2.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-3.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-4.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-5.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-6.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-7.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-8.gz, /cvsroot/gcl/gcl/info/gcl-tk.ky, /cvsroot/gcl/gcl/info/gcl-tk.pg, /cvsroot/gcl/gcl/info/gcl-tk.texi, /cvsroot/gcl/gcl/info/gcl-tk.toc, /cvsroot/gcl/gcl/info/gcl-tk.tp, /cvsroot/gcl/gcl/info/gcl-tk.vr, /cvsroot/gcl/gcl/info/general.texi, /cvsroot/gcl/gcl/info/internal.texi, /cvsroot/gcl/gcl/info/io.texi, /cvsroot/gcl/gcl/info/iteration.texi, /cvsroot/gcl/gcl/info/list.texi, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/info/misc.texi, /cvsroot/gcl/gcl/info/number.texi: + initial checkin + + * /cvsroot/gcl/gcl/info/character.texi, /cvsroot/gcl/gcl/info/compiler-defs.texi, /cvsroot/gcl/gcl/info/compile.texi, /cvsroot/gcl/gcl/info/control.texi, /cvsroot/gcl/gcl/info/debug.texi, /cvsroot/gcl/gcl/info/doc.texi, /cvsroot/gcl/gcl/info/form.texi, /cvsroot/gcl/gcl/info/gcl-si.cp, /cvsroot/gcl/gcl/info/gcl-si-index.texi, /cvsroot/gcl/gcl/info/gcl-si.info, /cvsroot/gcl/gcl/info/gcl-si.info-2.gz, /cvsroot/gcl/gcl/info/gcl-si.info-3.gz, /cvsroot/gcl/gcl/info/gcl-si.info-4.gz, /cvsroot/gcl/gcl/info/gcl-si.info-5.gz, /cvsroot/gcl/gcl/info/gcl-si.info-6.gz, /cvsroot/gcl/gcl/info/gcl-si.ky, /cvsroot/gcl/gcl/info/gcl-si.pg, /cvsroot/gcl/gcl/info/gcl-si.texi, /cvsroot/gcl/gcl/info/gcl-si.toc, /cvsroot/gcl/gcl/info/gcl-si.tp, /cvsroot/gcl/gcl/info/gcl-si.vr, /cvsroot/gcl/gcl/info/gcl-tk.cp, /cvsroot/gcl/gcl/info/gcl-tk.info, /cvsroot/gcl/gcl/info/gcl-tk.info-2.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-3.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-4.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-5.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-6.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-7.gz, /cvsroot/gcl/gcl/info/gcl-tk.info-8.gz, /cvsroot/gcl/gcl/info/gcl-tk.ky, /cvsroot/gcl/gcl/info/gcl-tk.pg, /cvsroot/gcl/gcl/info/gcl-tk.texi, /cvsroot/gcl/gcl/info/gcl-tk.toc, /cvsroot/gcl/gcl/info/gcl-tk.tp, /cvsroot/gcl/gcl/info/gcl-tk.vr, /cvsroot/gcl/gcl/info/general.texi, /cvsroot/gcl/gcl/info/internal.texi, /cvsroot/gcl/gcl/info/io.texi, /cvsroot/gcl/gcl/info/iteration.texi, /cvsroot/gcl/gcl/info/list.texi, /cvsroot/gcl/gcl/info/makefile, /cvsroot/gcl/gcl/info/misc.texi, /cvsroot/gcl/gcl/info/number.texi: + New file. + + * /cvsroot/gcl/gcl/h/att.h, /cvsroot/gcl/gcl/h/cmplrs/stsupport.h, /cvsroot/gcl/gcl/h/coff/i386.h, /cvsroot/gcl/gcl/h/cyglacks.h, /cvsroot/gcl/gcl/h/ext_sym.h, /cvsroot/gcl/gcl/h/gclincl.h.in, /cvsroot/gcl/gcl/h/gnuwin95.defs, /cvsroot/gcl/gcl/h/gnuwin95.h, /cvsroot/gcl/gcl/h/options.h, /cvsroot/gcl/gcl/h/ptable.h, /cvsroot/gcl/gcl/h/rgbc.h, /cvsroot/gcl/gcl/h/rios-aix3.defs, /cvsroot/gcl/gcl/h/rios-aix3.h, /cvsroot/gcl/gcl/h/rios.defs, /cvsroot/gcl/gcl/h/rios.h, /cvsroot/gcl/gcl/h/rt_aix.defs, /cvsroot/gcl/gcl/h/rt_aix.h, /cvsroot/gcl/gcl/h/s3000.h, /cvsroot/gcl/gcl/h/secondary_sun_magic, /cvsroot/gcl/gcl/h/sfun_argd.h, /cvsroot/gcl/gcl/h/sgi4d.defs, /cvsroot/gcl/gcl/h/sgi4d.h, /cvsroot/gcl/gcl/h/sgi.defs, /cvsroot/gcl/gcl/h/sgi.h, /cvsroot/gcl/gcl/h/solaris.defs, /cvsroot/gcl/gcl/h/solaris.h, /cvsroot/gcl/gcl/h/solaris-i386.defs, /cvsroot/gcl/gcl/h/solaris-i386.h, /cvsroot/gcl/gcl/h/sparc.h, /cvsroot/gcl/gcl/h/sparc-linux.defs, /cvsroot/gcl/gcl/h/sparc-linux.h, /cvsroot/gcl/gcl/h/stacks.h, /cvsroot/gcl/gcl/h/sun2r3.defs, /cvsroot/gcl/gcl/h/sun2r3.h, /cvsroot/gcl/gcl/h/sun386i.defs, /cvsroot/gcl/gcl/h/sun386i.h, /cvsroot/gcl/gcl/h/sun3.defs, /cvsroot/gcl/gcl/h/sun3.h, /cvsroot/gcl/gcl/h/sun3-os4.defs, /cvsroot/gcl/gcl/h/sun3-os4.h, /cvsroot/gcl/gcl/h/sun4.defs, /cvsroot/gcl/gcl/h/sun4.h, /cvsroot/gcl/gcl/h/sun.h, /cvsroot/gcl/gcl/h/symbol.h, /cvsroot/gcl/gcl/h/symmetry.defs, /cvsroot/gcl/gcl/h/symmetry.h, /cvsroot/gcl/gcl/h/twelve_null, /cvsroot/gcl/gcl/h/u370_aix.defs, /cvsroot/gcl/gcl/h/u370_aix.h, /cvsroot/gcl/gcl/h/usig.h, /cvsroot/gcl/gcl/h/vax.defs, /cvsroot/gcl/gcl/h/vax.h, /cvsroot/gcl/gcl/h/vs.h, /cvsroot/gcl/gcl/h/wincoff.h, /cvsroot/gcl/gcl/info/bind.texi, /cvsroot/gcl/gcl/info/c-interface.texi: + initial checkin + + * /cvsroot/gcl/gcl/h/att.h, /cvsroot/gcl/gcl/h/cmplrs/stsupport.h, /cvsroot/gcl/gcl/h/coff/i386.h, /cvsroot/gcl/gcl/h/cyglacks.h, /cvsroot/gcl/gcl/h/ext_sym.h, /cvsroot/gcl/gcl/h/gclincl.h.in, /cvsroot/gcl/gcl/h/gnuwin95.defs, /cvsroot/gcl/gcl/h/gnuwin95.h, /cvsroot/gcl/gcl/h/options.h, /cvsroot/gcl/gcl/h/ptable.h, /cvsroot/gcl/gcl/h/rgbc.h, /cvsroot/gcl/gcl/h/rios-aix3.defs, /cvsroot/gcl/gcl/h/rios-aix3.h, /cvsroot/gcl/gcl/h/rios.defs, /cvsroot/gcl/gcl/h/rios.h, /cvsroot/gcl/gcl/h/rt_aix.defs, /cvsroot/gcl/gcl/h/rt_aix.h, /cvsroot/gcl/gcl/h/s3000.h, /cvsroot/gcl/gcl/h/secondary_sun_magic, /cvsroot/gcl/gcl/h/sfun_argd.h, /cvsroot/gcl/gcl/h/sgi4d.defs, /cvsroot/gcl/gcl/h/sgi4d.h, /cvsroot/gcl/gcl/h/sgi.defs, /cvsroot/gcl/gcl/h/sgi.h, /cvsroot/gcl/gcl/h/solaris.defs, /cvsroot/gcl/gcl/h/solaris.h, /cvsroot/gcl/gcl/h/solaris-i386.defs, /cvsroot/gcl/gcl/h/solaris-i386.h, /cvsroot/gcl/gcl/h/sparc.h, /cvsroot/gcl/gcl/h/sparc-linux.defs, /cvsroot/gcl/gcl/h/sparc-linux.h, /cvsroot/gcl/gcl/h/stacks.h, /cvsroot/gcl/gcl/h/sun2r3.defs, /cvsroot/gcl/gcl/h/sun2r3.h, /cvsroot/gcl/gcl/h/sun386i.defs, /cvsroot/gcl/gcl/h/sun386i.h, /cvsroot/gcl/gcl/h/sun3.defs, /cvsroot/gcl/gcl/h/sun3.h, /cvsroot/gcl/gcl/h/sun3-os4.defs, /cvsroot/gcl/gcl/h/sun3-os4.h, /cvsroot/gcl/gcl/h/sun4.defs, /cvsroot/gcl/gcl/h/sun4.h, /cvsroot/gcl/gcl/h/sun.h, /cvsroot/gcl/gcl/h/symbol.h, /cvsroot/gcl/gcl/h/symmetry.defs, /cvsroot/gcl/gcl/h/symmetry.h, /cvsroot/gcl/gcl/h/twelve_null, /cvsroot/gcl/gcl/h/u370_aix.defs, /cvsroot/gcl/gcl/h/u370_aix.h, /cvsroot/gcl/gcl/h/usig.h, /cvsroot/gcl/gcl/h/vax.defs, /cvsroot/gcl/gcl/h/vax.h, /cvsroot/gcl/gcl/h/vs.h, /cvsroot/gcl/gcl/h/wincoff.h, /cvsroot/gcl/gcl/info/bind.texi, /cvsroot/gcl/gcl/info/c-interface.texi: + New file. + + * /cvsroot/gcl/gcl/h/cmponly.h, /cvsroot/gcl/gcl/h/coff_encap.h, /cvsroot/gcl/gcl/h/compat.h, /cvsroot/gcl/gcl/h/compbas2.h, /cvsroot/gcl/gcl/h/compbas.h, /cvsroot/gcl/gcl/h/convex.h, /cvsroot/gcl/gcl/h/dec3100.defs, /cvsroot/gcl/gcl/h/dec3100.h, /cvsroot/gcl/gcl/h/defun.h, /cvsroot/gcl/gcl/h/dos-go32.defs, /cvsroot/gcl/gcl/h/dos-go32.h, /cvsroot/gcl/gcl/h/e15.h, /cvsroot/gcl/gcl/h/enum.h, /cvsroot/gcl/gcl/h/erreurs.h, /cvsroot/gcl/gcl/h/eval.h, /cvsroot/gcl/gcl/h/frame.h, /cvsroot/gcl/gcl/h/FreeBSD.defs, /cvsroot/gcl/gcl/h/FreeBSD.h, /cvsroot/gcl/gcl/h/funlink.h, /cvsroot/gcl/gcl/h/gencom.h, /cvsroot/gcl/gcl/h/genpari.h, /cvsroot/gcl/gcl/h/genport.h, /cvsroot/gcl/gcl/h/getpagesize.h, /cvsroot/gcl/gcl/h/hp300-bsd.defs, /cvsroot/gcl/gcl/h/hp300-bsd.h, /cvsroot/gcl/gcl/h/hp300.defs, /cvsroot/gcl/gcl/h/hp300.h, /cvsroot/gcl/gcl/h/hp800.defs, /cvsroot/gcl/gcl/h/hp800.h, /cvsroot/gcl/gcl/h/include.h, /cvsroot/gcl/gcl/h/irix5.defs, /cvsroot/gcl/gcl/h/irix5.h, /cvsroot/gcl/gcl/h/irix6.defs, /cvsroot/gcl/gcl/h/irix6.h, /cvsroot/gcl/gcl/h/lex.h, /cvsroot/gcl/gcl/h/mac2.defs, /cvsroot/gcl/gcl/h/mac2.h, /cvsroot/gcl/gcl/h/make-decl.h, /cvsroot/gcl/gcl/h/make-init.h, /cvsroot/gcl/gcl/h/mc68k.h, /cvsroot/gcl/gcl/h/mdefs.h, /cvsroot/gcl/gcl/h/mips.h, /cvsroot/gcl/gcl/h/mp386.defs, /cvsroot/gcl/gcl/h/mp386.h, /cvsroot/gcl/gcl/h/mp.h, /cvsroot/gcl/gcl/h/ncr.defs, /cvsroot/gcl/gcl/h/ncr.h, /cvsroot/gcl/gcl/h/NetBSD.defs, /cvsroot/gcl/gcl/h/NetBSD.h, /cvsroot/gcl/gcl/h/new_decl.h, /cvsroot/gcl/gcl/h/news.h, /cvsroot/gcl/gcl/h/NeXT30-m68k.defs, /cvsroot/gcl/gcl/h/NeXT30-m68k.h, /cvsroot/gcl/gcl/h/NeXT32-i386.defs, /cvsroot/gcl/gcl/h/NeXT32-i386.h, /cvsroot/gcl/gcl/h/NeXT32-m68k.defs, /cvsroot/gcl/gcl/h/NeXT32-m68k.h, /cvsroot/gcl/gcl/h/NeXT.defs, /cvsroot/gcl/gcl/h/NeXT.h, /cvsroot/gcl/gcl/h/notcomp.h, /cvsroot/gcl/gcl/h/num_include.h, /cvsroot/gcl/gcl/h/object.h, /cvsroot/gcl/gcl/h/page.h: + initial checkin + + * /cvsroot/gcl/gcl/h/cmponly.h, /cvsroot/gcl/gcl/h/coff_encap.h, /cvsroot/gcl/gcl/h/compat.h, /cvsroot/gcl/gcl/h/compbas2.h, /cvsroot/gcl/gcl/h/compbas.h, /cvsroot/gcl/gcl/h/convex.h, /cvsroot/gcl/gcl/h/dec3100.defs, /cvsroot/gcl/gcl/h/dec3100.h, /cvsroot/gcl/gcl/h/defun.h, /cvsroot/gcl/gcl/h/dos-go32.defs, /cvsroot/gcl/gcl/h/dos-go32.h, /cvsroot/gcl/gcl/h/e15.h, /cvsroot/gcl/gcl/h/enum.h, /cvsroot/gcl/gcl/h/erreurs.h, /cvsroot/gcl/gcl/h/eval.h, /cvsroot/gcl/gcl/h/frame.h, /cvsroot/gcl/gcl/h/FreeBSD.defs, /cvsroot/gcl/gcl/h/FreeBSD.h, /cvsroot/gcl/gcl/h/funlink.h, /cvsroot/gcl/gcl/h/gencom.h, /cvsroot/gcl/gcl/h/genpari.h, /cvsroot/gcl/gcl/h/genport.h, /cvsroot/gcl/gcl/h/getpagesize.h, /cvsroot/gcl/gcl/h/hp300-bsd.defs, /cvsroot/gcl/gcl/h/hp300-bsd.h, /cvsroot/gcl/gcl/h/hp300.defs, /cvsroot/gcl/gcl/h/hp300.h, /cvsroot/gcl/gcl/h/hp800.defs, /cvsroot/gcl/gcl/h/hp800.h, /cvsroot/gcl/gcl/h/include.h, /cvsroot/gcl/gcl/h/irix5.defs, /cvsroot/gcl/gcl/h/irix5.h, /cvsroot/gcl/gcl/h/irix6.defs, /cvsroot/gcl/gcl/h/irix6.h, /cvsroot/gcl/gcl/h/lex.h, /cvsroot/gcl/gcl/h/mac2.defs, /cvsroot/gcl/gcl/h/mac2.h, /cvsroot/gcl/gcl/h/make-decl.h, /cvsroot/gcl/gcl/h/make-init.h, /cvsroot/gcl/gcl/h/mc68k.h, /cvsroot/gcl/gcl/h/mdefs.h, /cvsroot/gcl/gcl/h/mips.h, /cvsroot/gcl/gcl/h/mp386.defs, /cvsroot/gcl/gcl/h/mp386.h, /cvsroot/gcl/gcl/h/mp.h, /cvsroot/gcl/gcl/h/ncr.defs, /cvsroot/gcl/gcl/h/ncr.h, /cvsroot/gcl/gcl/h/NetBSD.defs, /cvsroot/gcl/gcl/h/NetBSD.h, /cvsroot/gcl/gcl/h/new_decl.h, /cvsroot/gcl/gcl/h/news.h, /cvsroot/gcl/gcl/h/NeXT30-m68k.defs, /cvsroot/gcl/gcl/h/NeXT30-m68k.h, /cvsroot/gcl/gcl/h/NeXT32-i386.defs, /cvsroot/gcl/gcl/h/NeXT32-i386.h, /cvsroot/gcl/gcl/h/NeXT32-m68k.defs, /cvsroot/gcl/gcl/h/NeXT32-m68k.h, /cvsroot/gcl/gcl/h/NeXT.defs, /cvsroot/gcl/gcl/h/NeXT.h, /cvsroot/gcl/gcl/h/notcomp.h, /cvsroot/gcl/gcl/h/num_include.h, /cvsroot/gcl/gcl/h/object.h, /cvsroot/gcl/gcl/h/page.h: + New file. + + * /cvsroot/gcl/gcl/gcl-tk/demos-4.1/items.lisp, /cvsroot/gcl/gcl/gcl-tk/demos-4.2/widget, /cvsroot/gcl/gcl/gcl-tk/demos-4.2/widget.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkForm.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkForm.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkHScale.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkHScale.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkIcon.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkItems.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkItems.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkLabel.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkLabel.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkListbox2.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkListbox3.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkListbox.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkListbox.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkPlot.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkPlot.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkPuzzle.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkRadio.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkRadio.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkRuler.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkRuler.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkScroll.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkSearch.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkSearch.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkStyles.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkStyles.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkTear.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkTextBind.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkTextBind.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkVScale.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkVScale.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/nqthm-stack.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/showVars.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/showVars.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/tclIndex, /cvsroot/gcl/gcl/gcl-tk/demos/widget.lisp, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/h/386-bsd.defs, /cvsroot/gcl/gcl/h/386-bsd.h, /cvsroot/gcl/gcl/h/386.h, /cvsroot/gcl/gcl/h/386-linux.defs, /cvsroot/gcl/gcl/h/386-linux.h, /cvsroot/gcl/gcl/h/alpha-osf1.defs, /cvsroot/gcl/gcl/h/alpha-osf1.h, /cvsroot/gcl/gcl/h/arith.h, /cvsroot/gcl/gcl/h/att3b2.h, /cvsroot/gcl/gcl/h/att_ext.h, /cvsroot/gcl/gcl/h/bds.h, /cvsroot/gcl/gcl/h/bsd.h, /cvsroot/gcl/gcl/h/cmpincl1.h, /cvsroot/gcl/gcl/h/cmpinclude.h, /cvsroot/gcl/gcl/h/gclincl.h: + initial checkin + + * /cvsroot/gcl/gcl/gcl-tk/demos-4.1/items.lisp, /cvsroot/gcl/gcl/gcl-tk/demos-4.2/widget, /cvsroot/gcl/gcl/gcl-tk/demos-4.2/widget.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkForm.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkForm.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkHScale.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkHScale.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkIcon.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkItems.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkItems.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkLabel.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkLabel.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkListbox2.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkListbox3.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkListbox.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkListbox.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkPlot.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkPlot.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkPuzzle.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkRadio.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkRadio.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkRuler.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkRuler.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkScroll.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkSearch.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkSearch.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkStyles.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkStyles.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkTear.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkTextBind.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkTextBind.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkVScale.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkVScale.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/nqthm-stack.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/showVars.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/showVars.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/tclIndex, /cvsroot/gcl/gcl/gcl-tk/demos/widget.lisp, /cvsroot/gcl/gcl/go/makefile, /cvsroot/gcl/gcl/h/386-bsd.defs, /cvsroot/gcl/gcl/h/386-bsd.h, /cvsroot/gcl/gcl/h/386.h, /cvsroot/gcl/gcl/h/386-linux.defs, /cvsroot/gcl/gcl/h/386-linux.h, /cvsroot/gcl/gcl/h/alpha-osf1.defs, /cvsroot/gcl/gcl/h/alpha-osf1.h, /cvsroot/gcl/gcl/h/arith.h, /cvsroot/gcl/gcl/h/att3b2.h, /cvsroot/gcl/gcl/h/att_ext.h, /cvsroot/gcl/gcl/h/bds.h, /cvsroot/gcl/gcl/h/bsd.h, /cvsroot/gcl/gcl/h/cmpincl1.h, /cvsroot/gcl/gcl/h/cmpinclude.h, /cvsroot/gcl/gcl/h/gclincl.h: + New file. + + * /cvsroot/gcl/gcl/gcl-tk/decode.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/gc-monitor.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/index.lsp, /cvsroot/gcl/gcl/gcl-tk/demos/mkArrow.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkBasic.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkBasic.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkBitmaps.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkButton.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkCanvText.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkCanvText.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkCheck.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkdialog.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkDialog.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkEntry2.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkEntry2.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkEntry.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkEntry.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkFloor.tcl, /cvsroot/gcl/gcl/gcl-tk/gcl_guisl.h, /cvsroot/gcl/gcl/gcl-tk/gcltksrv, /cvsroot/gcl/gcl/gcl-tk/gcltksrv.in.interp, /cvsroot/gcl/gcl/gcl-tk/gcltksrv.prev, /cvsroot/gcl/gcl/gcl-tk/guis.c, /cvsroot/gcl/gcl/gcl-tk/guis.h, /cvsroot/gcl/gcl/gcl-tk/helpers.lisp, /cvsroot/gcl/gcl/gcl-tk/index.lsp, /cvsroot/gcl/gcl/gcl-tk/intrs.h, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/gcl-tk/makefile.prev, /cvsroot/gcl/gcl/gcl-tk/ngcltksrv, /cvsroot/gcl/gcl/gcl-tk/our_io.c, /cvsroot/gcl/gcl/gcl-tk/sheader.h, /cvsroot/gcl/gcl/gcl-tk/socketsl.lisp, /cvsroot/gcl/gcl/gcl-tk/socks.h, /cvsroot/gcl/gcl/gcl-tk/sysdep-sunos.h, /cvsroot/gcl/gcl/gcl-tk/tinfo.c, /cvsroot/gcl/gcl/gcl-tk/tinfo.lsp, /cvsroot/gcl/gcl/gcl-tk/tkAppInit.c, /cvsroot/gcl/gcl/gcl-tk/tkl.lisp, /cvsroot/gcl/gcl/gcl-tk/tkMain.c, /cvsroot/gcl/gcl/gcl-tk/tk-package.lsp, /cvsroot/gcl/gcl/gcl-tk/tktst.c, /cvsroot/gcl/gcl/gcl-tk/tkXAppInit.c, /cvsroot/gcl/gcl/gcl-tk/tkXshell.c: + initial checkin + + * /cvsroot/gcl/gcl/gcl-tk/decode.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/gc-monitor.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/index.lsp, /cvsroot/gcl/gcl/gcl-tk/demos/mkArrow.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkBasic.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkBasic.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkBitmaps.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkButton.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkCanvText.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkCanvText.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkCheck.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkdialog.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkDialog.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkEntry2.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkEntry2.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkEntry.lisp, /cvsroot/gcl/gcl/gcl-tk/demos/mkEntry.tcl, /cvsroot/gcl/gcl/gcl-tk/demos/mkFloor.tcl, /cvsroot/gcl/gcl/gcl-tk/gcl_guisl.h, /cvsroot/gcl/gcl/gcl-tk/gcltksrv, /cvsroot/gcl/gcl/gcl-tk/gcltksrv.in.interp, /cvsroot/gcl/gcl/gcl-tk/gcltksrv.prev, /cvsroot/gcl/gcl/gcl-tk/guis.c, /cvsroot/gcl/gcl/gcl-tk/guis.h, /cvsroot/gcl/gcl/gcl-tk/helpers.lisp, /cvsroot/gcl/gcl/gcl-tk/index.lsp, /cvsroot/gcl/gcl/gcl-tk/intrs.h, /cvsroot/gcl/gcl/gcl-tk/makefile, /cvsroot/gcl/gcl/gcl-tk/makefile.prev, /cvsroot/gcl/gcl/gcl-tk/ngcltksrv, /cvsroot/gcl/gcl/gcl-tk/our_io.c, /cvsroot/gcl/gcl/gcl-tk/sheader.h, /cvsroot/gcl/gcl/gcl-tk/socketsl.lisp, /cvsroot/gcl/gcl/gcl-tk/socks.h, /cvsroot/gcl/gcl/gcl-tk/sysdep-sunos.h, /cvsroot/gcl/gcl/gcl-tk/tinfo.c, /cvsroot/gcl/gcl/gcl-tk/tinfo.lsp, /cvsroot/gcl/gcl/gcl-tk/tkAppInit.c, /cvsroot/gcl/gcl/gcl-tk/tkl.lisp, /cvsroot/gcl/gcl/gcl-tk/tkMain.c, /cvsroot/gcl/gcl/gcl-tk/tk-package.lsp, /cvsroot/gcl/gcl/gcl-tk/tktst.c, /cvsroot/gcl/gcl/gcl-tk/tkXAppInit.c, /cvsroot/gcl/gcl/gcl-tk/tkXshell.c: + New file. + + * /cvsroot/gcl/gcl/comp/top1.lsp, /cvsroot/gcl/gcl/comp/top2.lsp, /cvsroot/gcl/gcl/comp/try1.lsp, /cvsroot/gcl/gcl/comp/try.lsp, /cvsroot/gcl/gcl/comp/utils.lsp, /cvsroot/gcl/gcl/comp/var.lsp, /cvsroot/gcl/gcl/comp/wr.lsp, /cvsroot/gcl/gcl/doc/bignum, /cvsroot/gcl/gcl/doc/c-gc, /cvsroot/gcl/gcl/doc/c-gc.doc, /cvsroot/gcl/gcl/doc/compile-file-handling-of-top-level-forms, /cvsroot/gcl/gcl/doc/contributors, /cvsroot/gcl/gcl/doc/debug, /cvsroot/gcl/gcl/doc/enhancements, /cvsroot/gcl/gcl/doc/fast-link, /cvsroot/gcl/gcl/doc/format, /cvsroot/gcl/gcl/doc/funcall-comp, /cvsroot/gcl/gcl/doc/funcall.lsp, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/doc/multiple-values, /cvsroot/gcl/gcl/doc/profile, /cvsroot/gcl/gcl/dos/dostimes.c, /cvsroot/gcl/gcl/dos/dum_dos.c, /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/dos/readme, /cvsroot/gcl/gcl/dos/read.s, /cvsroot/gcl/gcl/dos/sigman.s, /cvsroot/gcl/gcl/dos/signal.c, /cvsroot/gcl/gcl/dos/signal.h, /cvsroot/gcl/gcl/elisp/add-default.el, /cvsroot/gcl/gcl/elisp/ansi-doc.el, /cvsroot/gcl/gcl/elisp/dbl.el, /cvsroot/gcl/gcl/elisp/doc-to-texi.el, /cvsroot/gcl/gcl/elisp/gcl.el, /cvsroot/gcl/gcl/elisp/lisp-complete.el, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/elisp/man1-to-texi.el, /cvsroot/gcl/gcl/elisp/readme, /cvsroot/gcl/gcl/elisp/smart-complete.el, /cvsroot/gcl/gcl/elisp/sshell.el, /cvsroot/gcl/gcl/gcl-tk/cmpinit.lsp, /cvsroot/gcl/gcl/gcl-tk/comm.c, /cvsroot/gcl/gcl/gcl-tk/convert.el, /cvsroot/gcl/gcl/gcl-tk/dir.sed, /cvsroot/gcl/gcl/gcl-tk/gcl-1.tcl, /cvsroot/gcl/gcl/gcl-tk/gcl.tcl, /cvsroot/gcl/gcl/gcl-tk/gcltksrv.in: + initial checkin + + * /cvsroot/gcl/gcl/comp/top1.lsp, /cvsroot/gcl/gcl/comp/top2.lsp, /cvsroot/gcl/gcl/comp/try1.lsp, /cvsroot/gcl/gcl/comp/try.lsp, /cvsroot/gcl/gcl/comp/utils.lsp, /cvsroot/gcl/gcl/comp/var.lsp, /cvsroot/gcl/gcl/comp/wr.lsp, /cvsroot/gcl/gcl/doc/bignum, /cvsroot/gcl/gcl/doc/c-gc, /cvsroot/gcl/gcl/doc/c-gc.doc, /cvsroot/gcl/gcl/doc/compile-file-handling-of-top-level-forms, /cvsroot/gcl/gcl/doc/contributors, /cvsroot/gcl/gcl/doc/debug, /cvsroot/gcl/gcl/doc/enhancements, /cvsroot/gcl/gcl/doc/fast-link, /cvsroot/gcl/gcl/doc/format, /cvsroot/gcl/gcl/doc/funcall-comp, /cvsroot/gcl/gcl/doc/funcall.lsp, /cvsroot/gcl/gcl/doc/makefile, /cvsroot/gcl/gcl/doc/multiple-values, /cvsroot/gcl/gcl/doc/profile, /cvsroot/gcl/gcl/dos/dostimes.c, /cvsroot/gcl/gcl/dos/dum_dos.c, /cvsroot/gcl/gcl/dos/makefile, /cvsroot/gcl/gcl/dos/readme, /cvsroot/gcl/gcl/dos/read.s, /cvsroot/gcl/gcl/dos/sigman.s, /cvsroot/gcl/gcl/dos/signal.c, /cvsroot/gcl/gcl/dos/signal.h, /cvsroot/gcl/gcl/elisp/add-default.el, /cvsroot/gcl/gcl/elisp/ansi-doc.el, /cvsroot/gcl/gcl/elisp/dbl.el, /cvsroot/gcl/gcl/elisp/doc-to-texi.el, /cvsroot/gcl/gcl/elisp/gcl.el, /cvsroot/gcl/gcl/elisp/lisp-complete.el, /cvsroot/gcl/gcl/elisp/makefile, /cvsroot/gcl/gcl/elisp/man1-to-texi.el, /cvsroot/gcl/gcl/elisp/readme, /cvsroot/gcl/gcl/elisp/smart-complete.el, /cvsroot/gcl/gcl/elisp/sshell.el, /cvsroot/gcl/gcl/gcl-tk/cmpinit.lsp, /cvsroot/gcl/gcl/gcl-tk/comm.c, /cvsroot/gcl/gcl/gcl-tk/convert.el, /cvsroot/gcl/gcl/gcl-tk/dir.sed, /cvsroot/gcl/gcl/gcl-tk/gcl-1.tcl, /cvsroot/gcl/gcl/gcl-tk/gcl.tcl, /cvsroot/gcl/gcl/gcl-tk/gcltksrv.in: + New file. + + * /cvsroot/gcl/gcl/cmpnew/cmpmain.lsp, /cvsroot/gcl/gcl/cmpnew/cmptype.h, /cvsroot/gcl/gcl/cmpnew/cmptype.lsp, /cvsroot/gcl/gcl/cmpnew/cmputil.c, /cvsroot/gcl/gcl/cmpnew/cmputil.data, /cvsroot/gcl/gcl/cmpnew/cmputil.h, /cvsroot/gcl/gcl/cmpnew/cmputil.lsp, /cvsroot/gcl/gcl/cmpnew/cmpvar.c, /cvsroot/gcl/gcl/cmpnew/cmpvar.data, /cvsroot/gcl/gcl/cmpnew/cmpvar.h, /cvsroot/gcl/gcl/cmpnew/cmpvar.lsp, /cvsroot/gcl/gcl/cmpnew/cmpvs.c, /cvsroot/gcl/gcl/cmpnew/cmpvs.data, /cvsroot/gcl/gcl/cmpnew/cmpvs.h, /cvsroot/gcl/gcl/cmpnew/cmpvs.lsp, /cvsroot/gcl/gcl/cmpnew/cmpwt.c, /cvsroot/gcl/gcl/cmpnew/cmpwt.data, /cvsroot/gcl/gcl/cmpnew/cmpwt.h, /cvsroot/gcl/gcl/cmpnew/cmpwt.lsp, /cvsroot/gcl/gcl/cmpnew/collectfn.lsp, /cvsroot/gcl/gcl/cmpnew/fasdmacros.lsp, /cvsroot/gcl/gcl/cmpnew/init.lsp, /cvsroot/gcl/gcl/cmpnew/lfun_list.lsp, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/cmpnew/make-fn.lsp, /cvsroot/gcl/gcl/cmpnew/make_ufun.lsp, /cvsroot/gcl/gcl/cmpnew/nocmpinc.lsp, /cvsroot/gcl/gcl/cmpnew/so_locations, /cvsroot/gcl/gcl/cmpnew/sys-proclaim.lisp, /cvsroot/gcl/gcl/comp/bo1.lsp, /cvsroot/gcl/gcl/comp/cmpinit.lsp, /cvsroot/gcl/gcl/comp/comptype.lsp, /cvsroot/gcl/gcl/comp/c-pass1.lsp, /cvsroot/gcl/gcl/comp/data.lsp, /cvsroot/gcl/gcl/comp/defmacro.lsp, /cvsroot/gcl/gcl/comp/defs.lsp, /cvsroot/gcl/gcl/comp/exit.lsp, /cvsroot/gcl/gcl/comp/fasdmacros.lsp, /cvsroot/gcl/gcl/comp/inline.lsp, /cvsroot/gcl/gcl/comp/integer.doc, /cvsroot/gcl/gcl/comp/lambda.lsp, /cvsroot/gcl/gcl/comp/lisp-decls.doc, /cvsroot/gcl/gcl/comp/macros.lsp, /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/comp/mangle.lsp, /cvsroot/gcl/gcl/comp/opts-base.lsp, /cvsroot/gcl/gcl/comp/opts.lsp, /cvsroot/gcl/gcl/comp/proclaim.lsp, /cvsroot/gcl/gcl/comp/smash-oldcmp.lsp, /cvsroot/gcl/gcl/comp/stmt.lsp, /cvsroot/gcl/gcl/comp/sysdef.lsp, /cvsroot/gcl/gcl/comp/top.lsp: + initial checkin + + * /cvsroot/gcl/gcl/cmpnew/cmpmain.lsp, /cvsroot/gcl/gcl/cmpnew/cmptype.h, /cvsroot/gcl/gcl/cmpnew/cmptype.lsp, /cvsroot/gcl/gcl/cmpnew/cmputil.c, /cvsroot/gcl/gcl/cmpnew/cmputil.data, /cvsroot/gcl/gcl/cmpnew/cmputil.h, /cvsroot/gcl/gcl/cmpnew/cmputil.lsp, /cvsroot/gcl/gcl/cmpnew/cmpvar.c, /cvsroot/gcl/gcl/cmpnew/cmpvar.data, /cvsroot/gcl/gcl/cmpnew/cmpvar.h, /cvsroot/gcl/gcl/cmpnew/cmpvar.lsp, /cvsroot/gcl/gcl/cmpnew/cmpvs.c, /cvsroot/gcl/gcl/cmpnew/cmpvs.data, /cvsroot/gcl/gcl/cmpnew/cmpvs.h, /cvsroot/gcl/gcl/cmpnew/cmpvs.lsp, /cvsroot/gcl/gcl/cmpnew/cmpwt.c, /cvsroot/gcl/gcl/cmpnew/cmpwt.data, /cvsroot/gcl/gcl/cmpnew/cmpwt.h, /cvsroot/gcl/gcl/cmpnew/cmpwt.lsp, /cvsroot/gcl/gcl/cmpnew/collectfn.lsp, /cvsroot/gcl/gcl/cmpnew/fasdmacros.lsp, /cvsroot/gcl/gcl/cmpnew/init.lsp, /cvsroot/gcl/gcl/cmpnew/lfun_list.lsp, /cvsroot/gcl/gcl/cmpnew/makefile, /cvsroot/gcl/gcl/cmpnew/make-fn.lsp, /cvsroot/gcl/gcl/cmpnew/make_ufun.lsp, /cvsroot/gcl/gcl/cmpnew/nocmpinc.lsp, /cvsroot/gcl/gcl/cmpnew/so_locations, /cvsroot/gcl/gcl/cmpnew/sys-proclaim.lisp, /cvsroot/gcl/gcl/comp/bo1.lsp, /cvsroot/gcl/gcl/comp/cmpinit.lsp, /cvsroot/gcl/gcl/comp/comptype.lsp, /cvsroot/gcl/gcl/comp/c-pass1.lsp, /cvsroot/gcl/gcl/comp/data.lsp, /cvsroot/gcl/gcl/comp/defmacro.lsp, /cvsroot/gcl/gcl/comp/defs.lsp, /cvsroot/gcl/gcl/comp/exit.lsp, /cvsroot/gcl/gcl/comp/fasdmacros.lsp, /cvsroot/gcl/gcl/comp/inline.lsp, /cvsroot/gcl/gcl/comp/integer.doc, /cvsroot/gcl/gcl/comp/lambda.lsp, /cvsroot/gcl/gcl/comp/lisp-decls.doc, /cvsroot/gcl/gcl/comp/macros.lsp, /cvsroot/gcl/gcl/comp/makefile, /cvsroot/gcl/gcl/comp/mangle.lsp, /cvsroot/gcl/gcl/comp/opts-base.lsp, /cvsroot/gcl/gcl/comp/opts.lsp, /cvsroot/gcl/gcl/comp/proclaim.lsp, /cvsroot/gcl/gcl/comp/smash-oldcmp.lsp, /cvsroot/gcl/gcl/comp/stmt.lsp, /cvsroot/gcl/gcl/comp/sysdef.lsp, /cvsroot/gcl/gcl/comp/top.lsp: + New file. + + * /cvsroot/gcl/gcl/cmpnew/cmplam.data, /cvsroot/gcl/gcl/cmpnew/cmplam.h, /cvsroot/gcl/gcl/cmpnew/cmplam.lsp, /cvsroot/gcl/gcl/cmpnew/cmplet.c, /cvsroot/gcl/gcl/cmpnew/cmplet.data, /cvsroot/gcl/gcl/cmpnew/cmplet.h, /cvsroot/gcl/gcl/cmpnew/cmplet.lsp, /cvsroot/gcl/gcl/cmpnew/cmploc.c, /cvsroot/gcl/gcl/cmpnew/cmploc.data, /cvsroot/gcl/gcl/cmpnew/cmploc.h, /cvsroot/gcl/gcl/cmpnew/cmploc.lsp, /cvsroot/gcl/gcl/cmpnew/cmpmap.c, /cvsroot/gcl/gcl/cmpnew/cmpmap.data, /cvsroot/gcl/gcl/cmpnew/cmpmap.h, /cvsroot/gcl/gcl/cmpnew/cmpmap.lsp, /cvsroot/gcl/gcl/cmpnew/cmpmulti.c, /cvsroot/gcl/gcl/cmpnew/cmpmulti.data, /cvsroot/gcl/gcl/cmpnew/cmpmulti.h, /cvsroot/gcl/gcl/cmpnew/cmpmulti.lsp, /cvsroot/gcl/gcl/cmpnew/cmpopt.lsp, /cvsroot/gcl/gcl/cmpnew/cmpspecial.c, /cvsroot/gcl/gcl/cmpnew/cmpspecial.data, /cvsroot/gcl/gcl/cmpnew/cmpspecial.h, /cvsroot/gcl/gcl/cmpnew/cmpspecial.lsp, /cvsroot/gcl/gcl/cmpnew/cmptag.c, /cvsroot/gcl/gcl/cmpnew/cmptag.data, /cvsroot/gcl/gcl/cmpnew/cmptag.h, /cvsroot/gcl/gcl/cmpnew/cmptag.lsp, /cvsroot/gcl/gcl/cmpnew/cmptest.lsp, /cvsroot/gcl/gcl/cmpnew/cmptop.c, /cvsroot/gcl/gcl/cmpnew/cmptop.data, /cvsroot/gcl/gcl/cmpnew/cmptop.h, /cvsroot/gcl/gcl/cmpnew/cmptop.lsp, /cvsroot/gcl/gcl/cmpnew/cmptype.c, /cvsroot/gcl/gcl/cmpnew/cmptype.data: + initial checkin + + * /cvsroot/gcl/gcl/cmpnew/cmplam.data, /cvsroot/gcl/gcl/cmpnew/cmplam.h, /cvsroot/gcl/gcl/cmpnew/cmplam.lsp, /cvsroot/gcl/gcl/cmpnew/cmplet.c, /cvsroot/gcl/gcl/cmpnew/cmplet.data, /cvsroot/gcl/gcl/cmpnew/cmplet.h, /cvsroot/gcl/gcl/cmpnew/cmplet.lsp, /cvsroot/gcl/gcl/cmpnew/cmploc.c, /cvsroot/gcl/gcl/cmpnew/cmploc.data, /cvsroot/gcl/gcl/cmpnew/cmploc.h, /cvsroot/gcl/gcl/cmpnew/cmploc.lsp, /cvsroot/gcl/gcl/cmpnew/cmpmap.c, /cvsroot/gcl/gcl/cmpnew/cmpmap.data, /cvsroot/gcl/gcl/cmpnew/cmpmap.h, /cvsroot/gcl/gcl/cmpnew/cmpmap.lsp, /cvsroot/gcl/gcl/cmpnew/cmpmulti.c, /cvsroot/gcl/gcl/cmpnew/cmpmulti.data, /cvsroot/gcl/gcl/cmpnew/cmpmulti.h, /cvsroot/gcl/gcl/cmpnew/cmpmulti.lsp, /cvsroot/gcl/gcl/cmpnew/cmpopt.lsp, /cvsroot/gcl/gcl/cmpnew/cmpspecial.c, /cvsroot/gcl/gcl/cmpnew/cmpspecial.data, /cvsroot/gcl/gcl/cmpnew/cmpspecial.h, /cvsroot/gcl/gcl/cmpnew/cmpspecial.lsp, /cvsroot/gcl/gcl/cmpnew/cmptag.c, /cvsroot/gcl/gcl/cmpnew/cmptag.data, /cvsroot/gcl/gcl/cmpnew/cmptag.h, /cvsroot/gcl/gcl/cmpnew/cmptag.lsp, /cvsroot/gcl/gcl/cmpnew/cmptest.lsp, /cvsroot/gcl/gcl/cmpnew/cmptop.c, /cvsroot/gcl/gcl/cmpnew/cmptop.data, /cvsroot/gcl/gcl/cmpnew/cmptop.h, /cvsroot/gcl/gcl/cmpnew/cmptop.lsp, /cvsroot/gcl/gcl/cmpnew/cmptype.c, /cvsroot/gcl/gcl/cmpnew/cmptype.data: + New file. + + * /cvsroot/gcl/gcl/cmpnew/cmpenv.c, /cvsroot/gcl/gcl/cmpnew/cmpenv.data, /cvsroot/gcl/gcl/cmpnew/cmpenv.h, /cvsroot/gcl/gcl/cmpnew/cmpenv.lsp, /cvsroot/gcl/gcl/cmpnew/cmpeval.c, /cvsroot/gcl/gcl/cmpnew/cmpeval.data, /cvsroot/gcl/gcl/cmpnew/cmpeval.h, /cvsroot/gcl/gcl/cmpnew/cmpeval.lsp, /cvsroot/gcl/gcl/cmpnew/cmpflet.c, /cvsroot/gcl/gcl/cmpnew/cmpflet.data, /cvsroot/gcl/gcl/cmpnew/cmpflet.h, /cvsroot/gcl/gcl/cmpnew/cmpflet.lsp, /cvsroot/gcl/gcl/cmpnew/cmpfun.c, /cvsroot/gcl/gcl/cmpnew/cmpfun.data, /cvsroot/gcl/gcl/cmpnew/cmpfun.h, /cvsroot/gcl/gcl/cmpnew/cmpfun.lsp, /cvsroot/gcl/gcl/cmpnew/cmpif.c, /cvsroot/gcl/gcl/cmpnew/cmpif.data, /cvsroot/gcl/gcl/cmpnew/cmpif.h, /cvsroot/gcl/gcl/cmpnew/cmpif.lsp, /cvsroot/gcl/gcl/cmpnew/cmpinit.lsp, /cvsroot/gcl/gcl/cmpnew/cmpinline.c, /cvsroot/gcl/gcl/cmpnew/cmpinline.data, /cvsroot/gcl/gcl/cmpnew/cmpinline.h, /cvsroot/gcl/gcl/cmpnew/cmpinline.lsp, /cvsroot/gcl/gcl/cmpnew/cmplabel.c, /cvsroot/gcl/gcl/cmpnew/cmplabel.data, /cvsroot/gcl/gcl/cmpnew/cmplabel.h, /cvsroot/gcl/gcl/cmpnew/cmplabel.lsp, /cvsroot/gcl/gcl/cmpnew/cmplam.c: + initial checkin + + * /cvsroot/gcl/gcl/cmpnew/cmpenv.c, /cvsroot/gcl/gcl/cmpnew/cmpenv.data, /cvsroot/gcl/gcl/cmpnew/cmpenv.h, /cvsroot/gcl/gcl/cmpnew/cmpenv.lsp, /cvsroot/gcl/gcl/cmpnew/cmpeval.c, /cvsroot/gcl/gcl/cmpnew/cmpeval.data, /cvsroot/gcl/gcl/cmpnew/cmpeval.h, /cvsroot/gcl/gcl/cmpnew/cmpeval.lsp, /cvsroot/gcl/gcl/cmpnew/cmpflet.c, /cvsroot/gcl/gcl/cmpnew/cmpflet.data, /cvsroot/gcl/gcl/cmpnew/cmpflet.h, /cvsroot/gcl/gcl/cmpnew/cmpflet.lsp, /cvsroot/gcl/gcl/cmpnew/cmpfun.c, /cvsroot/gcl/gcl/cmpnew/cmpfun.data, /cvsroot/gcl/gcl/cmpnew/cmpfun.h, /cvsroot/gcl/gcl/cmpnew/cmpfun.lsp, /cvsroot/gcl/gcl/cmpnew/cmpif.c, /cvsroot/gcl/gcl/cmpnew/cmpif.data, /cvsroot/gcl/gcl/cmpnew/cmpif.h, /cvsroot/gcl/gcl/cmpnew/cmpif.lsp, /cvsroot/gcl/gcl/cmpnew/cmpinit.lsp, /cvsroot/gcl/gcl/cmpnew/cmpinline.c, /cvsroot/gcl/gcl/cmpnew/cmpinline.data, /cvsroot/gcl/gcl/cmpnew/cmpinline.h, /cvsroot/gcl/gcl/cmpnew/cmpinline.lsp, /cvsroot/gcl/gcl/cmpnew/cmplabel.c, /cvsroot/gcl/gcl/cmpnew/cmplabel.data, /cvsroot/gcl/gcl/cmpnew/cmplabel.h, /cvsroot/gcl/gcl/cmpnew/cmplabel.lsp, /cvsroot/gcl/gcl/cmpnew/cmplam.c: + New file. + + * /cvsroot/gcl/gcl/bin/append, /cvsroot/gcl/gcl/bin/append.c, /cvsroot/gcl/gcl/bin/dpp.c, /cvsroot/gcl/gcl/bin/gcl, /cvsroot/gcl/gcl/bin/info1, /cvsroot/gcl/gcl/bin/info, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/bin/tkinfo, /cvsroot/gcl/gcl/clcs/condition-definitions.lisp, /cvsroot/gcl/gcl/clcs/condition-precom.lisp, /cvsroot/gcl/gcl/clcs/conditions.lisp, /cvsroot/gcl/gcl/clcs/debugger.lisp, /cvsroot/gcl/gcl/clcs/doload.lisp, /cvsroot/gcl/gcl/clcs/handler.lisp, /cvsroot/gcl/gcl/clcs/install.lisp, /cvsroot/gcl/gcl/clcs/kcl-cond.lisp, /cvsroot/gcl/gcl/clcs/loading.lisp, /cvsroot/gcl/gcl/clcs/macros.lisp, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/clcs/package.lisp, /cvsroot/gcl/gcl/clcs/precom.lisp, /cvsroot/gcl/gcl/clcs/readme, /cvsroot/gcl/gcl/clcs/reload.lisp, /cvsroot/gcl/gcl/clcs/restart.lisp, /cvsroot/gcl/gcl/clcs/sysdef.lisp, /cvsroot/gcl/gcl/clcs/test2.lisp, /cvsroot/gcl/gcl/clcs/test3.lisp, /cvsroot/gcl/gcl/clcs/test4.lisp, /cvsroot/gcl/gcl/clcs/test5.lisp, /cvsroot/gcl/gcl/clcs/tester.lisp, /cvsroot/gcl/gcl/clcs/test.lisp, /cvsroot/gcl/gcl/clcs/top-patches.lisp, /cvsroot/gcl/gcl/cmpnew/cmpbind.c, /cvsroot/gcl/gcl/cmpnew/cmpbind.data, /cvsroot/gcl/gcl/cmpnew/cmpbind.h, /cvsroot/gcl/gcl/cmpnew/cmpbind.lsp, /cvsroot/gcl/gcl/cmpnew/cmpblock.c, /cvsroot/gcl/gcl/cmpnew/cmpblock.data, /cvsroot/gcl/gcl/cmpnew/cmpblock.h, /cvsroot/gcl/gcl/cmpnew/cmpblock.lsp, /cvsroot/gcl/gcl/cmpnew/cmpcall.c, /cvsroot/gcl/gcl/cmpnew/cmpcall.data, /cvsroot/gcl/gcl/cmpnew/cmpcall.h, /cvsroot/gcl/gcl/cmpnew/cmpcall.lsp, /cvsroot/gcl/gcl/cmpnew/cmpcatch.c, /cvsroot/gcl/gcl/cmpnew/cmpcatch.data, /cvsroot/gcl/gcl/cmpnew/cmpcatch.h, /cvsroot/gcl/gcl/cmpnew/cmpcatch.lsp, /cvsroot/gcl/gcl/gcl1.jpg, /cvsroot/gcl/gcl/gcl2.jpg, /cvsroot/gcl/gcl/gcl.gif, /cvsroot/gcl/gcl/gcl.jpg: + initial checkin + + * /cvsroot/gcl/gcl/bin/append, /cvsroot/gcl/gcl/bin/append.c, /cvsroot/gcl/gcl/bin/dpp.c, /cvsroot/gcl/gcl/bin/gcl, /cvsroot/gcl/gcl/bin/info1, /cvsroot/gcl/gcl/bin/info, /cvsroot/gcl/gcl/bin/makefile, /cvsroot/gcl/gcl/bin/tkinfo, /cvsroot/gcl/gcl/clcs/condition-definitions.lisp, /cvsroot/gcl/gcl/clcs/condition-precom.lisp, /cvsroot/gcl/gcl/clcs/conditions.lisp, /cvsroot/gcl/gcl/clcs/debugger.lisp, /cvsroot/gcl/gcl/clcs/doload.lisp, /cvsroot/gcl/gcl/clcs/handler.lisp, /cvsroot/gcl/gcl/clcs/install.lisp, /cvsroot/gcl/gcl/clcs/kcl-cond.lisp, /cvsroot/gcl/gcl/clcs/loading.lisp, /cvsroot/gcl/gcl/clcs/macros.lisp, /cvsroot/gcl/gcl/clcs/makefile, /cvsroot/gcl/gcl/clcs/package.lisp, /cvsroot/gcl/gcl/clcs/precom.lisp, /cvsroot/gcl/gcl/clcs/readme, /cvsroot/gcl/gcl/clcs/reload.lisp, /cvsroot/gcl/gcl/clcs/restart.lisp, /cvsroot/gcl/gcl/clcs/sysdef.lisp, /cvsroot/gcl/gcl/clcs/test2.lisp, /cvsroot/gcl/gcl/clcs/test3.lisp, /cvsroot/gcl/gcl/clcs/test4.lisp, /cvsroot/gcl/gcl/clcs/test5.lisp, /cvsroot/gcl/gcl/clcs/tester.lisp, /cvsroot/gcl/gcl/clcs/test.lisp, /cvsroot/gcl/gcl/clcs/top-patches.lisp, /cvsroot/gcl/gcl/cmpnew/cmpbind.c, /cvsroot/gcl/gcl/cmpnew/cmpbind.data, /cvsroot/gcl/gcl/cmpnew/cmpbind.h, /cvsroot/gcl/gcl/cmpnew/cmpbind.lsp, /cvsroot/gcl/gcl/cmpnew/cmpblock.c, /cvsroot/gcl/gcl/cmpnew/cmpblock.data, /cvsroot/gcl/gcl/cmpnew/cmpblock.h, /cvsroot/gcl/gcl/cmpnew/cmpblock.lsp, /cvsroot/gcl/gcl/cmpnew/cmpcall.c, /cvsroot/gcl/gcl/cmpnew/cmpcall.data, /cvsroot/gcl/gcl/cmpnew/cmpcall.h, /cvsroot/gcl/gcl/cmpnew/cmpcall.lsp, /cvsroot/gcl/gcl/cmpnew/cmpcatch.c, /cvsroot/gcl/gcl/cmpnew/cmpcatch.data, /cvsroot/gcl/gcl/cmpnew/cmpcatch.h, /cvsroot/gcl/gcl/cmpnew/cmpcatch.lsp, /cvsroot/gcl/gcl/gcl1.jpg, /cvsroot/gcl/gcl/gcl2.jpg, /cvsroot/gcl/gcl/gcl.gif, /cvsroot/gcl/gcl/gcl.jpg: + New file. + + * /cvsroot/gcl/gcl/AC_FD_CC, /cvsroot/gcl/gcl/AC_FD_MSG, /cvsroot/gcl/gcl/add-defs1, /cvsroot/gcl/gcl/add-defs, /cvsroot/gcl/gcl/add-defs.bat, /cvsroot/gcl/gcl/ChangeLog, /cvsroot/gcl/gcl/config.guess, /cvsroot/gcl/gcl/config.sub, /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/COPYING.LIB-2.0, /cvsroot/gcl/gcl/eval.html, /cvsroot/gcl/gcl/eval.tcl, /cvsroot/gcl/gcl/faq, /cvsroot/gcl/gcl/install.sh, /cvsroot/gcl/gcl/machine, /cvsroot/gcl/gcl/machines, /cvsroot/gcl/gcl/majvers, /cvsroot/gcl/gcl/makdefs, /cvsroot/gcl/gcl/makedefs.in, /cvsroot/gcl/gcl/makedf, /cvsroot/gcl/gcl/makedf.in, /cvsroot/gcl/gcl/makefile, /cvsroot/gcl/gcl/merge.c, /cvsroot/gcl/gcl/minvers, /cvsroot/gcl/gcl/readme: + initial checkin + + * /cvsroot/gcl/gcl/AC_FD_CC, /cvsroot/gcl/gcl/AC_FD_MSG, /cvsroot/gcl/gcl/add-defs1, /cvsroot/gcl/gcl/add-defs, /cvsroot/gcl/gcl/add-defs.bat, /cvsroot/gcl/gcl/ChangeLog, /cvsroot/gcl/gcl/config.guess, /cvsroot/gcl/gcl/config.sub, /cvsroot/gcl/gcl/configure, /cvsroot/gcl/gcl/configure.in, /cvsroot/gcl/gcl/COPYING.LIB-2.0, /cvsroot/gcl/gcl/eval.html, /cvsroot/gcl/gcl/eval.tcl, /cvsroot/gcl/gcl/faq, /cvsroot/gcl/gcl/install.sh, /cvsroot/gcl/gcl/machine, /cvsroot/gcl/gcl/machines, /cvsroot/gcl/gcl/majvers, /cvsroot/gcl/gcl/makdefs, /cvsroot/gcl/gcl/makedefs.in, /cvsroot/gcl/gcl/makedf, /cvsroot/gcl/gcl/makedf.in, /cvsroot/gcl/gcl/makefile, /cvsroot/gcl/gcl/merge.c, /cvsroot/gcl/gcl/minvers, /cvsroot/gcl/gcl/readme: + New file. + diff --git a/ChangeLog.old b/ChangeLog.old new file mode 100755 index 0000000..6ff4e87 --- /dev/null +++ b/ChangeLog.old @@ -0,0 +1,218 @@ +2001-12-29 Camm Maguire + + * gmp/configure.in update for darwin + * #ifdef'ed R_386_NUM in sfaslelf.c for old libc + * changes to configure.in and elisp/makefile to handle emacs not + being present + * fix to gmp/ltconfig to avoid exec'ing '""' + * Added DESTDIR to makefiles to support installing under arbitrary + subdir + * good 'clean' targets + * correct building in absense of tcl/tk + + +2001-12-18 David Billinghurst + + * h/gnuwin95.h: Cruft removal and update + (SA_RESTART): Surround by #if 0/#endif + (fopen_binary): Remove + (fopen): Remove redefinition to fopen_binary + + +2001-04-15 Bill Schelter + + * Added changes to allow the loading .o files compiled + on -O4 under linux, and also added this to be the default + optimize level if speed = 3. speed = 2 gives -O still + +2001-04-13 Bill Schelter + + * fix the NULL_OR_ON_C_STACK macro for x86 linux in notcomp.h + and in 386-linux.h + +2001-01-30 Bill Schelter + + * many changes added for MS windows version.. + * add check on CSTACK_ADDRESS to configure for NULL_OR_ON_C_STACK + +2000-10-27 Bill Schelter + + * o/file.d bug in close_stream + * add xbin/386-linux-fix to knock the -O4 flag off of gcc if + it is version 2.96 because of a C compiler bug + * fixes to configure.in to better find the tcl tk stuff. + +2000-06-01 Bill Schelter + + * o/print.d: change printing of pathnames to use the more + standard #p"foo.bar" instead of #"foo.bar" + * o/read.d: allow pathnames #p"foo.bar" instead of just #"foo.bar" + as many implementations do. + + + +2000-05-13 Bill Schelter + + * fix readme file + * update gcl-2.3/mp/mpi-sol-sparc.s for the 'sparc' version. + * number of changes to 'configure.in' to handle finding + paths correctly. + +2000-05-02 Bill Schelter + + * rsym_elf.c (out;): strip off the @@GLIB* from symbols, + in the base image, since this is not added to .o files + With advent of GLIB2.0 this addition to the symbol was made. + This will allow dynamic linking of the raw_gcl with the C library. + * remove the -static default from the 386-linux.defs file, + so that links will by default be dynamic for libc .. + + +Fri Mar 28 16:23:18 1997 Bill Schelter + + * fix o/unexelf.c for section following bss overlapping it. + * fix some of the install sections in makefile + * add man page. + + +Wed Mar 12 14:11:01 1997 Bill Schelter + + * makefile (go): change to remove typo o${..} in makefile + in the install script + * change DIR= to GCL_TK_DIR= in gcl-tk/gcltksrv* and in + makefile, gcl-tk/makefile. Plain DIR= was causing the + replacement (in sed in makefiles) of other other variables + ending in DIR= .. + + + +Sun Dec 8 18:31:38 1996 Bill Schelter + + * release 2.2.1 contains various fixes to unexec and to + makefiles, for building on current systems. + +Mon Dec 2 20:36:28 1996 Bill Schelter + + * o/gbc.c: make the marking of MVloc go in the right direction. + important for problems that use mv_ref methods.. + +Thu Nov 9 18:09:01 1995 Bill Schelter + + * fixes for format and structure printing. + * fixes to calls to FEerror + * arrange so that static arrays stay static on growing via + adjust-array or via output with string stream stuff + +Mon Oct 30 20:42:17 1995 Bill Schelter + + * o/print.d (BEGIN): fix (defstruct (foo (:print-function + print-foo)) junk) + (defun print-foo (foo stream depth) + (format stream "#" (foo-junk foo))) + bug. [with the printStructBufp value being nulled] + * add-defs sets TCL_LIBRARY, and gcltksrv sets it.. + * fixes to support solaris-i386 [in rsym_elf.c, sfaslelf.c + * ./add-defs fix order of tests of paths... + + +Fri Oct 20 01:15:47 1995 Bill Schelter + + * fix initialization of *link-array* to be a string.. + [remove from cmptop.lsp] + * misc fixes in gbc.c and sgbc.c + * fix to profiling. + +Wed Oct 18 00:16:59 1995 Bill Schelter + + * (format nil "~5,,X" 10) made to work. Note the ansi draft + neither condones nor prohibits this. Normally the , is a place + holder and there is a argument after the last , and then comes the + directive. Here the commas dont hold a place. + + * fix bv.bv_offset problem... the move to 64 bit machines caused + it to be impossible to have some structure fields overlap the way + they once did. added BV_OFFSET(x) and SET_BV_OFFSET(x,val) + macros. + * fix add-defs to make clxsocket.o not be compiled in case of + no X11 include files found. + +Tue Oct 17 13:21:38 1995 Bill Schelter + + * fix the (write 3) bug... in print.d + +Wed Oct 11 23:00:34 1995 Bill Schelter + + * merge in billm's elf support for linux, and repair the + changes effects on regular a.out linux + * switch to unexec from 19.29 for versions using either the + regular or elf unexec from emacs + + +Sun Oct 1 19:52:45 1995 Bill Schelter + + * Many changes to gcl 2.1 to support 64 bit machines (eg Dec + alpha). Layout of structures etc changed. + * a gcl-2.2 beta was released in the summer. + since then there have been several bugs fixed. One in cmpfun.lsp + affecting write, and another in init_gcl.lsp to make sure the + link array is a string array (changed from fixnum which are no + longer sufficient to hold pointers). + * changes to fix for PA risc hpux in the hp800.h + * changes to unexec-19.27.c to allow MUCH faster saving in NFS + environment. + * testing with maxima 5.1 + * reworking makefiles + * (write 2) bug fixed. (in compiler) + * (aref #*11111 0) fixed (was different bv_elttype field) + + +Sun Apr 30 18:28:07 1995 Bill Schelter + + * various fixes to array.c for bitarrays and non 1 dimensional arrays + * fix to Ieval + * verify that pcl and clx work with these changes. + +Sun Apr 9 21:24:38 1995 Bill Schelter + + * (ln): + +Sat Apr 1 14:01:35 1995 Bill Schelter + + * There have been an infinite number of changes for gcl-2.0 + + * GCL now contains a tcl/tk windowing interface. + It is based on TCL 7.3 and TK 3.6 available from + ftp.cs.berkeley.edu and many mirrors. + + See the gcl-tk/demos/widget.lisp file for the demos. + + + * support for gzipped files + (setq si::*allow-gzipped-file* t) + to allow it. (load "foo.o") will look for "foo.o.gz" if + it does not find foo.o. Writing gzipped files is not + supported. + + * Command line args: + See the documentaion in the info directory under command line. + `-eval' `-load' etc. + + `-f' allows shell scripts to be made such as + ================== + #!/usr/local/bin/gcl.exe -f + (print "hello world") + ================== + + * All documentation converted to texinfo, info format and + extended. Ansi common lisp documentation converted to texinfo + + * interrupts completely changed, to be more robust and to + allow communication with tk. + + * regexp matching introduced see 'string-match' + + + + + + diff --git a/README.macosx b/README.macosx new file mode 100644 index 0000000..b605f58 --- /dev/null +++ b/README.macosx @@ -0,0 +1,9 @@ +On some recent mac boxes (e.g. 10.6) running 64bit capable processors, +the default configure scripts detect the cpu as 32bit only. To get a +64bit build, do: + +./configure --build=x86_64-apple-darwin10.4.0 .... + +where the key item is the x86_64, and some darwin string in the last +place. + diff --git a/README.openbsd b/README.openbsd new file mode 100644 index 0000000..91b7a28 --- /dev/null +++ b/README.openbsd @@ -0,0 +1,40 @@ +Building and using GCL 2.6.2 on OpenBSD + +PLATFORMS +--------- +GCL has only been tested on OpenBSD/i386 3.4. Newer versions should +work as well. Other hardware platforms are unchartered land. + +TOOLS +----- +You need GNU make to compile GCL. If you have installed the ports +tree, you can get it by running the following as root: + +cd /usr/ports/devel/gmake +make install + +It is then installed as `gmake'. + +The sed that ships with OpenBSD 3.4 has a bug (PR 3677) which is +triggered by the GCL makefiles. You can use either the sed of 3.5 or +GNU sed. Make sure the correct sed comes first in your PATH. + +BUILDING +-------- +There's nothing special to do for OpenBSD; GCL should build out of +the box. The OpenBSD version shares makefiles with FreeBSD, so don't +be surprised when you see "FreeBSD" in the output. + +NOTES +----- +The default limits on data segment size are 64MB (soft) and 256MB +(hard). GCL will automatically raise the soft limit to the hard +limit, but you may find that it runs out of memory anyway. If so, +you can change the limits in /etc/login.conf. + +For the record, the W^X feature of OpenBSD is disabled, since it +interfers with the way GCL dumps its executable. + + +Magnus Henoch, 12 June 2004 + diff --git a/README.wine b/README.wine new file mode 100644 index 0000000..ec6ec52 --- /dev/null +++ b/README.wine @@ -0,0 +1,17 @@ +On Debian, for example, gcl can be run and tested under wine as follows: + +(as root) + +aptitude install mingw32 mingw32-runtime mingw32-binutils wine + +If necessary, as root + +update-binfmts --enable wine + +Then as a normal user, + +export PATH=/usr/i586-mingw32msvc/bin:$PATH +export CC=/usr/bin/i586-mingw32msvc-gcc + +./configure --host=mingw32 && make + diff --git a/RELEASE-2.5.1 b/RELEASE-2.5.1 new file mode 100644 index 0000000..1bfd022 --- /dev/null +++ b/RELEASE-2.5.1 @@ -0,0 +1,138 @@ +RELEASE NOTES FOR 2.5.1: +======================== +The GNU Common Lisp (GCL) development team is pleased to release +Version 2.5.1, the first major release since the untimely death of the +former maintainer Dr William Schelter over a year ago. This release +is dedicated to his memory. The project is now hosted on +http://savannah.gnu.org/projects/gcl/ and is maintained and developed +by a team of thirteen programmers. Our home page lives at +http://www.gnu.org/software/gcl/. + +This release stabilizes the CLtL1 compliant build of GCL on most major +Unices including 11 Debian Linux 64 and 32 bit architectures and modern +versions of Microsoft Windows (TM). A rapidly progressing, partially ANSI +compliant version is also available on the Linux platforms. + +GCL plays a substantial role in development of the Maxima computer +algebra system (http://maxima.sourceforge.net/), ACL2, a computational +logic system (http://www.cs.utexas.edu/users/moore/acl2/), and the +forthcoming public release of the Axiom computer algebra system.. The +compiler is a descendant of the famous KCL and AKCL Common Lisp +compilers and is licensed under version two of the GNU Library General +Public License. + +As with any Lisp system GCL is a lot of fun to work with. We welcome all +comments and feedback. Developers are particularly welcome too. You will +find that the project offers a wide variety of challenges on various +platforms to anyone with an interest in compilers, low level C programming +or Common Lisp. + +----- + +Features: + + * Compiles itself, maxima, and acl2, passing all tests, on 11 + Debian GNU/Linux platforms (i386, sparc, powerpc, s390, ia64, alpha, + mips, mipsel, hppa, arm, and m68k), Sparc Solaris, and recent Windows + systems. + + * Compilation to native object code. Lisp disassembly shows intermediate + C source and native assembler. + + * Native code relocation on all supported platforms except alpha, mips, + mipsel, ia64, and hppa. + + * Can save its running memory image to a file on all systems where native object + code relocation is supported, thus producing standalone executables. + + * Compiles Lisp function calls to C function calls with inlined + arguments, when function proclamation/declamations are made. + + * Quite fast, particularly if one pre-allocates memory to be commensurate + with that typically available on modern computer systems. (see below) + + * A foreign function interface as flexible in principle as the C interface. + + * Socket support via streams + + * Support for numbers of arbitrary precision via the GNU + Multiprecision Library. If you build GCL on your own system, + multiprecision numerical support will make use of ISA extension + instructions available on your system for maximum large number + performance. + + * An exact garbage collector with no (known) leaks. + + * An ANSI mode on Unix systems which passes approximately 97% of + the ANSI compliance tests currently developed for the project. + On Debian GNU/Linux systems, this mode can be selected by setting the + GCL_ANSI environment variable to any non-empty string. See + /usr/share/doc/gcl/test_results on Debian GNU/Linux systems. + + * An MPI extension for cluster computing support. See the website for details. + + * A long history of leveraging GCC compiler technology for use in + production lisp applications. + +----- + +GCL is one of the oldest Lisp systems still in use, and as such has +served as the basis for large lisp applications when computers were +much more limited than they are today, particularly in terms of +available memory. Considerable effort was therefore made in the past +to keep the memory image as small as possible. As of the present +time, the GCL team has not tuned the default memory allocation scheme +to be more in line with modern systems. One can therefore often get +significant performance increases by preallocating memory, as in for +example + +(progn +(si::allocate 'cons 10000 t) +(si::allocate 'fixnum 200 t) +(si::allocate 'symbol 100 t) +(si::allocate-relocatable-pages 2000 t) +(si::allocate 'cfun 1000 t)) + +Optimal values will no doubt vary by application and machine. One +user/developer reports effects of the following magnitude when +using preallocation: + +######## + +Take a look on some funny numbers below. This is time and RAM +required to compute ratsimp((x+y+z)^300)$ on Linux AthlonXP 2400+. +For GCL run time is in the form T - G = N, where T is the total +time as shown by showtime:true; G is total GC tome and N +is run time without GC. + +Lisp Time RAM RAM RAM + [sec] before max after + T - G = N [Mb] [Mb] [Mb] +===================================================== + +CLISP 4.6 5.5 29 16 + +CMUCL 1.6 6.5 31 31 + +GCL class 5.9 - 5.2 = 0.7 8 24 24 +GCL ansi 9.5 - 8.9 = 0.6 9.5 29 29 + +GCL class 1.0 - 0.4 = 0.6 24 31 31 +GCL ansi 1.1 - 0.6 = 0.5 25 32 32 + +GCL class 0.7 - 0.1 = 0.6 48 55 55 +GCL ansi 0.5 - 0.0 = 0.5 49 56 56 + +==================================================== + +######## + + +TO DO: + + 1) Full ANSI compliance + 2) Native optimized blas support + 3) Integrate MPI support + 4) GCL as a suported GCC front end. + 5) Performance/memory optimization + diff --git a/RELEASE-2.6.2.html b/RELEASE-2.6.2.html new file mode 100644 index 0000000..b4534e3 --- /dev/null +++ b/RELEASE-2.6.2.html @@ -0,0 +1,1599 @@ + + + + GCL 2.6.2 tests + + + + + +
+
+ +
GCL 2.6.2 RELEASE NOTES
+
+
+ The GCL team is happy to announce the release of version +2.6.2, the latest achievement in the 'stable' series.  While strictly +speaking a bug-fix only release, 2.6.2 incorporates several major improvements +over the last stable release, 2.5.3.  Some highlights:
+
+ +
    +
  • The development of a 'lisp compiler torture tester' by GCL developer + Paul Dietz which repeatedly compiles randomly generated forms of specifiable + length to test the compiler for correctness.
    • +
  • The application of several significant corrections to the GCL +lisp compiler to remove every known instance of miscompilation uncovered +by this tester.  To our knowledge, GCL is alone with CLISP in passing +this torture test for runs of effectively indefinite length.
    • +
  • Major performance improvements were applied to the lisp compiler + to enable it to complete random tests of great length in a reasonable amount + of time. 
    • +
  • Corrections to the GCL core files to enable very large image sizes + in 64 bits, in which more than a billion cons cells can be allocated.  Current + 64bit options include amd64, ia64, and alpha running most flavors of GNU/Linux.
    • +
  • Corrections to the heap scaling behavior of the garbage collector, + resulting in significant performance gains in many instances.
    • +
  • Support for the latest gcc and binutils versions on all platforms + but mingw
    • +
  • The elimination of many instances of unnecessary internal garbage + generation bringing the associated performance gains
    • +
  • Native support for execstack protected linux kernels, such as +on Fedora core systems
    • +
  • Native support for FreeBSD, OpenBSD, and MacOSX
    • +
  • Static function pointer support to stabilize dynamic library usage + on Itanium systems
    • +
  • Transparent readline initialization when compiled in
    • +
  • Support for profiling via gprof
    • +
  • Automatic disabling of SGC (stratified garbage collection) if +the image is executed on a kernel not supporting fault address recovery
    • +
  • Remove a memory leak associated with heavy bignum usage via the + introduction of SGC contiguous pages
    • +
  • Several significant internal bug fixes, epecially in the mingw +port.
    • +
  • Alter the build process to perform a full self compile with full + function proclamation at build time.
    • +
  • GCL now compiles Axiom from scratch and carries it to all supported + platforms with the current exception of mingw
    • +
  • GCL's ANSI build now in use for its first end-user application +-- maxima (current cvs)
    • +
  • New 64bit platform support -- amd64, with full native object relocation
    +
    • + +
+ The full changelog can be found in the source tree in the file 'debian/changelog'.
+
+  
+ The GCL team has subjected this release to a wide variety of tests and + benchmarks.  While all such results are necessarily incomplete, one + can nevertheless usefully summarize the approximate state of affairs as +follows:
+ +
    +
  • GCL is about as portable as CLISP
    • +
  • The GCL lisp compiler is about as robust/correct as that of CLISP, + at least as measured by the random tester, which at present only covers +a mostly integer subset of lisp.
    • +
  • GCL is about as fast as CMUCL
    • +
  • GCL plays a major role in carrying the primary large open source + lisp end user applications to a wide variety of systems
    • +
  • GCL is still the least ANSI compliant of the freely available +lisp systems,  though a modest level of compliance has been achieved +in this release.  Much greater compliance has been achieved in the +2.7.x (cvs unstable) series yet to be officially released.
    • + +
+
+ The specific test results are arranged in the following table.  Some + terms need defining:
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
BFD
+ 		the method of relocating compiled lisp object modules +into the running executable using the BFD library
+
custreloc
+ 		the method of relocating compiled lisp object modules +into the running executable using the native GCL code.  This method +as well as the BFD method preserve the module loading across image saving +and re-execution
+
dlopen
+ 		the method of dynamically linking in compiled lisp +object modules into the existing session only via the system dynamic linker +loader, ld.so.
+
SGC
+ 		Stratified Garbage Collection -- an optional accelerated +generational garbage collection algorithm employing read-only memory
+
CLtL1
+ 		Common Lisp, the Language vol I, referring to the +book of the same name by Steele defining a widely used lisp language standard +prior to the ANSI standardization process in 1994.
+
ANSI
+ 		the work in progress image build attempting to eventually +extend traditional GCL into full ANSI complaince
+
Ansi tests
+ 		the results of the work in progress ansi compliance +test suite written by GCL developer Paul Dietz presented as the number of +failures divided by the total number of tests run
+
Random tests
+ 		the results of the random 'compiler torture tester' + presented as the number of tests/the size of the random forms/the number + of variables passed to the random function
+
+
+
+In the table below, green denotes a pass, yellow denotes an as yet unimplemented + option, and red indicates failure.  Blank cells indicate tests that + have not been run.
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
System
+ 		CPU
+ 		Self Build
+ 		BFD
+ 		dlopen
+ 		custreloc
+ 		Preferred
+ Linking
+ 		SGC
+ 		CLtL1
+ 		ANSI
+ 		ANSI tests
+ 		Random tests
+ 		Maxima 5.9.0/CLtL1
+ (4)
+ 		Maxima CVS/ANSI
+ (4)
+ 		ACL2 2.8/CLtL1
+ (5)
+ 		Axiom CVS/CLtL1
+ (6)
+ 		nqthm
+ CLtL1
+ 		pc-nqthm
+ CLtL1
+
Debian GNU/Linux (sid)
+ 		i386
+
+
+
+
+ 		bfd
+ or
+ custreloc
+
+
+
+ 		303/
+ 10697
+ 		50000/10000/8
+ 500000/1000/8
+
+
+
+
+
+ 		(setq si::*multiply-stacks* + 16)
+
Debian GNU/Linux (sid)
+ 		sparc
+
+
+
+
+ 		bfd
+ or
+ custreloc
+
+
+
+ 		303/
+ 10697
+
+
+
+
+
+
+
+
Debian GNU/Linux (sid)
+ 		powerpc
+
+
+
+
+ 		bfd
+
+
+
+ 		303/
+ 10697
+
+
+
+
+
+
+
+
Debian GNU/Linux (sid)
+ 		amd64
+
+
+
+
+ 		bfd
+
+
+
+ 		303/
+ 10697
+
+
+
+
+
+
+
+
Debian GNU/Linux (sid)
+ 		arm
+
+
+
+
+ 		bfd
+
+
+
+ 		303/
+ 10697
+
+
+
+
+
+
+
+
Debian GNU/Linux (sid)
+ 		m68k
+
+
+
+
+ 		bfd
+
+
+
+ 		303/
+ 10697
+
+
+
+
+
+
+
+
Debian GNU/Linux (sid)
+ 		s390
+
+
+
+
+ 		bfd
+
+
+
+ 		303/
+ 10697
+
+
+
+
+
+
+
+
Debian GNU/Linux (sid)
+ 		ia64
+
+
+
+
+ 		dlopen
+
+
+
+ 		303/
+ 10697
+
+
+
+
+ 		(1)
+
+
+
Debian GNU/Linux (sid)
+ 		hppa
+ 		-O0
+
+
+
+ 		dlopen
+
+
+
+ 		303/
+ 10697
+
+
+
+
+ 		(1)
+
+
+
Debian GNU/Linux (sid)
+ 		mips
+
+
+
+
+ 		dlopen
+
+
+
+ 		303/
+ 10697
+
+
+
+
+ 		(1)
+
+
+
Debian GNU/Linux (sid)
+ 		mipsel
+
+
+
+
+ 		dlopen
+
+
+
+ 		303/
+ 10697
+
+
+
+
+ 		(1)
+
+
+
Debian GNU/Linux (sid)
+ 		alpha
+
+
+
+
+ 		dlopen
+
+
+
+ 		303/
+ 10697
+
+
+
+
+ 		(1)
+
+
+
Fedora FC1
+ 		i386
+
+
+
+
+ 		bfd or
+ custreloc
+
+
+
+ 		303/
+ 10697
+ 		12000/1000/8
+
+
+
+
+
+
+
Solaris
+ 		sparc
+
+
+
+
+ 		bfd or
+ custreloc
+
+
+
+ 		303/
+ 10697
+ 		4000/1000/8
+ (4)
+
+
+
+
+
+
+
Windows MINGW(a)
+ 		i386
+
+
+
+
+ 		custreloc
+
+
+
+
+ 		303/
+ 10697
+ 		57000/1000/8
+
+
+
+ 		(2)
+
+
+
MacOSX
+ 		powerpc
+
+
+
+
+ 		bfd
+ 		(3)
+
+
+ 		303/
+ 10697
+
+
+
+
+
+
+
+
OpenBSD
+ 		i386
+
+
+
+
+ 		bfd
+
+
+
+ 		303/
+ 10697
+
+
+
+
+
+
+
+
FreeBSD
+ 		i386
+
+
+
+
+ 		custreloc
+
+
+
+ 		303/
+ 10697
+
+
+
+
+
+
+
+

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ Notes:
+
+ (1) dlopen builds use file descriptors for each object load.  The + step in the Axiom build process which regenerates its databases consumes + more than the conventional maximum of 1024 file descriptors available +by default on most UNIX systems.
+ (2) An AXIOMsys executable can be produced, and is basically functional, + but experiences sporadic errors of a type as yet unknown.
+ (3) This is known to work on at least some versions of the OS, but + others report a hang (infinite loop) when enabling SGC.  It is possible + that this is due to a mprotect bug in older versions of the Darwin system + shared libraries.  'compatibility version of user 6.0.0' appears to +work.
+ (4) On this machine, the underlying gcc was old (3.0) and segfaulted + outside of GCL when attempting to compile its produced C code after a few + thousand        iterations.
+
+ (a) The preferred build environment for Mingw/Windows is gcc 3.3.1, +binutils 2.14.90, and the latest msys release.
+
+
+
+ The following table presents the results of the popular gabriel benchmarks + of three freely available lisp systems, GCL, CLISP and CMUCL.  Times + are presented as multiples of the time GCL took in completing the tests. +  Green  indicates tests on which GCL is the fastest, while red +indicates tests on which GCLwas not the fastest.   The benchmark code +can be found in ftp://ftp.ma.utexas.edu/gcl/gabriel.tgz.  The number +of test iterations has been increased by a factor of 400 to overcome granularity +issues on modern machines.  The '(print (time ...))' statements around +each test iteration were removed, again due to granularity and relative i/o +load.  Likewise the special init.lsp file conventionally used to preallocate +GCL memory in such cases was removed as it is now mostly obsolete.  Finally +the tests were modified slightly to place the optimization declamations at +the top of each file being compiled as suggested by a CMUCL expert.
+
+As with any benchmark, results can vary somewhat with the details of the +executing machine.  With lisp in particular, the ratios of the cache +sizes, cpu speed, and memory bandwidths can impact such tests significantly. + We present the results for two popular configurations below.  While +the precise details of the differences are as yet known, it is speculated +that the first result is more dominated by in-cache cpu performance, while +the latter is more dominated by memory access efficiency.
+
+ + + + + + + + + + + + + + + +
Dual Intel Xeon 2.4Ghz, 512 Mb, Linux 2.4.20
+ 		Athlon XP 3000+ (2.1Ghz), 512 Mb, Linux 2.4.26
+
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Benchmark
+ 		GCL
+ 2.6.2
+ 		CMUCL 18e-9
+ 		CLISP
+ 2.33-2
+

+ BOYER
+ 1.000
+ 2.200
+ 9.869

+ BROWSE
+ 1.000
+ 2.240
+ NA

+ CTAK
+ 1.000
+ 0.230
+ 1.890

+ DDERIV
+ 1.000
+ 2.148
+ 2.909

+ DERIV
+ 1.000
+ 2.083
+ 3.640

+ DESTRU-MOD
+ 1.000
+ 2.043
+ 9.880

+ DESTRU
+ 1.000
+ 1.168
+ 5.743

+ DIV2
+ 1.000
+ 2.222
+ 3.911

+ FFT-MOD
+ 1.000
+ 1.585
+ 206.057

+ FFT
+ 1.000
+ 1.544
+ 176.088

+ FPRINT
+ 1.000
+ 2.136
+ 3.742

+ FREAD
+ 1.000
+ 1.746
+ 2.111

+ FRPOLY
+ 1.000
+ 1.524
+ 5.112

+ PUZZLE-MOD
+ 1.000
+ 10.824
+ 41.618

+ PUZZLE
+ 1.000
+ 11.324
+ 37.671

+ STAK
+ 1.000
+ 1.536
+ 9.836

+ TAK-MOD
+ 1.000
+ 1.465
+ 15.053

+ TAK
+ 1.000
+ 1.486
+ 14.629

+ TAKL
+ 1.000
+ 1.419
+ 14.965

+ TAKR
+ 1.000
+ 1.933
+ 12.327

+ TPRINT
+ 1.000
+ 0.937
+ 1.263

+ TRAVERSE
+ 1.000
+ 0.875
+ 8.378

+ TRIANG-MOD
+ 1.000
+ 7.067
+ 26.814

+ TRIANG
+ 1.000
+ 1.281
+ 18.565
GEOMETRIC
+ AVERAGE
+ 1.00
+ 1.86
+ 10.33
MEDIAN
+ 		1.00
+ 		1.67
+ 		9.87
+
+
+ 		+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Benchmark
+ 		GCL
+ 2.6.2
+ 		CMUCL 18e
+ 		CLISP
+ 2.33
+

+ BOYER
+ 1.000
+ 0.892
+ 6.316

+ BROWSE
+ 1.000
+ 0.965
+ NA

+ CTAK
+ 1.000
+ 0.435
+ 3.489

+ DDERIV
+ 1.000
+ 0.822
+ 1.579

+ DERIV
+ 1.000
+ 0.651
+ 1.639

+ DESTRU-MOD
+ 1.000
+ 0.812
+ 4.779

+ DESTRU
+ 1.000
+ 0.550
+ 3.239

+ DIV2
+ 1.000
+ 0.599
+ 1.525

+ FFT-MOD
+ 1.000
+ 2.655
+ 337.207

+ FFT
+ 1.000
+ 1.923
+ 251.026

+ FPRINT
+ 1.000
+ 2.322
+ 3.508

+ FREAD
+ 1.000
+ 1.890
+ 1.900

+ FRPOLY
+ 1.000
+ 1.013
+ 3.606

+ PUZZLE-MOD
+ 1.000
+ 5.976
+ 20.350

+ PUZZLE
+ 1.000
+ 5.472
+ 19.387

+ STAK
+ 1.000
+ 1.655
+ 8.064

+ TAK-MOD
+ 1.000
+ 1.382
+ 14.775

+ TAK
+ 1.000
+ 1.399
+ 14.514

+ TAKL
+ 1.000
+ 1.281
+ 12.877

+ TAKR
+ 1.000
+ 1.735
+ 15.500

+ TPRINT
+ 1.000
+ 2.008
+ 1.674

+ TRAVERSE
+ 1.000
+ 0.770
+ 8.013

+ TRIANG-MOD
+ 1.000
+ 6.639
+ 25.182

+ TRIANG
+ 1.000
+ 1.186
+ 16.948
GEOMETRIC
+ AVERAGE
+ 1.00
+ 1.40
+ 8.46
MEDIAN
+ 		1.00
+ 		1.33
+ 		8.01
+
+
+
+
+ Many improvements are planned for the 2.7.x development series time + permitting, the most important of which is to complete the task of building + an ANSI compliant GCL image. 
+
+
+
+
+
+
+
+ + diff --git a/add-defs b/add-defs new file mode 100755 index 0000000..7536a4e --- /dev/null +++ b/add-defs @@ -0,0 +1,139 @@ +#!/bin/sh + +if [ $# -le 0 ] ; then + echo usage: ./add-defs machine-type; + echo or ' ' ./add-defs machine-type directory + echo where directory might be '/usr/local' or '/public' or '/lusr' -- a place to find various local includes or libs + echo see echo h/*.defs +exit 1 ; fi + +if [ -f h/$1.defs ] ; then echo using $1.defs ; + else echo h/$1.defs does not exist + echo Build one or use one of `ls h/*.defs` + exit 1 +fi + +echo $1 > machine + + + rm -f makedefs + echo > makedefs + echo "# begin makedefs" >> makedefs + echo "# constructed by ${USER} using: $0 $1 $2 $3 $4 $5" >> makdefs + + if [ -d ${PWD}/unixport ] ; + then echo "GCLDIR=${PWD}" >> makedefs ; + else echo "GCLDIR=`pwd`" >> makedefs ; + fi + echo "SHELL=/bin/sh" >> makedefs + echo "MACHINE=$1" >> makedefs + +# a place where you keep local things. Changing this may help to +# find things, otherwise edit the "LIST-OF-DIRECTORIES" for the +# given item. + +if [ "$2x" != "x" ] ; then +PUBLIC=$2 ; +else +PUBLIC=/public +fi +export PUBLIC + + + +TK_XINCLUDES=-Iunknown +# `add-dir' searches for ITEM in LIST-OF-DIRECTORIES and then sets the +# directory in VARIABLE-SETTING-TEMPLATE +#Usage: ./xbin/add-dir ITEM LIST-OF-DIRECTORIES VARIABLE-SETTING-TEMPLATE + +./xbin/add-dir tkConfig.sh "${PUBLIC}/lib /usr/lib /usr/local/lib" 'TK_CONFIG_PREFIX="$v"' +./xbin/add-dir tclConfig.sh "${PUBLIC}/lib /usr/lib /usr/local/lib" 'TCL_CONFIG_PREFIX="$v"' +./xbin/add-dir dir "/usr/local/lib/info ${PUBLIC}/lib/info /usr/lib/info" 'INFO_DIR="$v"' + +SOURCE=. +${SOURCE} makedefs + + + +if [ -f ${TK_CONFIG_PREFIX}/tkConfig.sh -a \ + -f ${TCL_CONFIG_PREFIX}/tclConfig.sh ] ; then + ${SOURCE} ${TK_CONFIG_PREFIX}/tkConfig.sh ; + ${SOURCE} ${TK_CONFIG_PREFIX}/tclConfig.sh ; + ./xbin/add-dir tk.h "${PUBLIC}/include /usr/include /usr/local/include" 'TK_INCLUDE="-I$v"' + + echo "TK_VERSION=${TK_VERSION}" >> makedefs + echo "TCL_VERSION=${TCL_VERSION}" >> makedefs + echo "TK_LIB_SPEC=${TK_LIB_SPEC}" >> makedefs + echo "TK_LIBRARY=${TK_CONFIG_PREFIX}/tk${TK_VERSION}" >> makedefs + echo "TCL_LIBRARY=${TCL_CONFIG_PREFIX}/tcl${TCL_VERSION}" >> makedefs + echo "TK_BUILD_LIB_SPEC=${TK_BUILD_LIB_SPEC}" >> makedefs + echo "TK_XLIBSW=${TK_XLIBSW}" >> makedefs + TK_XLIB_DIR=`echo ${TK_XLIBSW} | sed "s:-L\\([^ ]*\\) .*:\\1:g"` + echo "TK_XLIB_DIR=${TK_XLIB_DIR}" >> makedefs + echo "TK_XINCLUDES=${TK_XINCLUDES}" >> makedefs + echo "TCL_LIB_SPEC=${TCL_LIB_SPEC}" >> makedefs + echo "TCL_DL_LIBS=${TCL_DL_LIBS}" >> makedefs + echo "TCL_LIBS=${TCL_LIBS}" >> makedefs + echo "HAVE_X11=-DHAVE_X11" >> makedefs +else + echo "TK_CONFIG_PREFIX=unknown" >> makedefs + ./xbin/add-dir X11/Xos.h "${PUBLIC}/include /usr/include /usr/local/X11R6/include /usr/local/X11/include " 'TK_XINCLUDES="-I$v"' + . makedefs + if [ "$TK_XINCLUDES" = "-Iunknown" ] ; then + echo "cant find X11 includes so not defining HAVE_X11" + else + echo HAVE_X11=-DHAVE_X11 >> makedefs + fi + echo unable to find tkConfig.sh and tclConfig.sh so not configuring tcl/tk +fi + + +####machine specific .defs files may over ride the above#### + + +####### insert the h/machine.defs file ############ + cat h/$1.defs >> makedefs + if [ -f ${HOME}/local_gcl.defs ] ; then + cat ${HOME}/local_gcl.defs >> makedefs + fi + + + echo "# end makedefs" >> makedefs + + echo inserting h/$1.defs in .. + for v in makefile unixport/make_kcn */makefile ; + do + echo " $v," + ./bin/file-sub makedefs $v "# begin makedefs" "# end makedefs" tmpx + mv tmpx $v + done + + +echo "" + +# Copy the config.h over. + +cat h/$1.h > tmpx +if [ -f ${HOME}/local_gcl.h ] ; then + cat ${HOME}/local_gcl.h >> tmpx +fi + +if fgrep =unknown makedefs > /dev/null ; +then echo " if the 'unknown' directories exist you may provide +a second argument to ./add-defs of a local directory where things might be, +or edit ./add-defs so that it can find them. Otherwise just continue +and the portions with unknown will not be compiled." +fi + + +if cmp tmpx h/config.h > /dev/null 2>&1 ;then true; +else +rm -f h/config.h +cp tmpx h/config.h +fi +rm -f tmpx + +# machine specific stuff that cant be handled normally... +if [ -f ./xbin/$1-fix ] ; then ./xbin/$1-fix ; fi + + diff --git a/add-defs.bat b/add-defs.bat new file mode 100755 index 0000000..92f6910 --- /dev/null +++ b/add-defs.bat @@ -0,0 +1,63 @@ +@echo off + +if .%1==. goto err_param +if NOT EXIST h\%1.def goto err_not_found + +IF EXIST unixport\saved_kc.exe goto found_saved_kcl_exe +echo WARNING : unixport/saved_kcl.exe file not found +echo _ you will not be able to recompile the .lsp files +echo _ nor start akcl +:found_saved_kcl_exe + +echo %1 > machine + +if .%2==. goto only_1_param +if exist %2\c\print.d goto only_1_param +echo %2 is not the main kcl directory + +:only_1_param + +make -f Smakefile merge + +copy tmpxx_.tem tmpxx +del makedefs + +echo AKCLDIR=/akcl >makedefs +echo SHELL=/bin/sh >>makedefs +echo MACHINE=%1 >>makedefs +type h\%1.def >>makedefs +if exist %2\c\print.d echo MAINDIR = %2 >> makedefs +type makedefs >>tmpxx +echo # end makedefs >>tmpxx +echo @s] >> tmpxx + +echo inserting h\%1.def in .. +for %%v in (Smakefile mp\makefile o\makefile lsp\makefile cmpnew\makefile dos\makefile) do go32 merge %%v tmpxx %%v.new +for %%v in (Smakefile mp\makefile o\makefile lsp\makefile cmpnew\makefile dos\makefile) do if exist %%v.new mv %%v %%v.bak +for %%v in (Smakefile mp\makefile o\makefile lsp\makefile cmpnew\makefile dos\makefile) do if exist %%v.new mv %%v.new %%v + +go32 merge unixport\makefile.dos tmpxx unixport\makefile.new +if exist unixport\makefile.new mv unixport\makefile.dos unixport\makefile.bak +if exist unixport\makefile.new mv unixport\makefile.new unixport\makefile.dos + +rem rm -f Vmakefile +rem rm -f tmpxx + +rem Copy the config.h over. +copy h\%1.h h\config.h + +rem fix the cmpinclude.h + +goto end + +:err_param +echo usage: Provide a machine name as arg +goto end + +:err_not_found +echo h\%1.def does not exist +echo Build one or use one of `ls h\*.def` +goto end + +:end + diff --git a/add-defs1 b/add-defs1 new file mode 100755 index 0000000..4c8c341 --- /dev/null +++ b/add-defs1 @@ -0,0 +1,89 @@ +#!/bin/sh + +#CC=cc +if test "$1" = "mingw" -o "$1" = "gnuwin95" ; then + EXE=.exe ; # CC=gcc + rm -f o/*.ini +fi + +#(cd bin ; make file-sub EXE=${EXE} CC=${CC}) + +if [ $# -le 0 ] ; then + echo usage: ./add-defs machine-type; + echo or ' ' ./add-defs machine-type directory + echo where directory might be '/usr/local' or '/public' or '/lusr' -- a place to find various local includes or libs + echo see echo h/*.defs +exit 1 ; fi + +if [ -f h/$1.defs ] ; then echo using $1.defs ; + else echo h/$1.defs does not exist + echo Build one or use one of `ls h/*.defs` + exit 1 +fi + +echo $1 > machine + + +# rm -f makedefs +# echo > makedefs +# echo "# begin makedefs" >> makedefs +# echo "# constructed by ${USER} using: $0 $1 $2 $3 $4 $5" >> makdefs + + rm -f makedefs + cp makedefc makedefs + if [ -d ${PWD}/unixport ] ; + then echo "GCLDIR=${PWD}" >> makedefs ; + else echo "GCLDIR=`pwd`" >> makedefs ; + fi + echo "SHELL=/bin/sh" >> makedefs + echo "MACHINE=$1" >> makedefs + + +####machine specific .defs files may over ride the above#### + + +####### insert the h/machine.defs file ############ + cat h/$1.defs >> makedefs + if [ -f makedefsafter ] ; then cat makedefsafter >> makedefs ; fi + if [ -f ${HOME}/local_gcl.defs ] ; then + cat ${HOME}/local_gcl.defs >> makedefs + fi + + echo "" >> makedefs + echo "# end makedefs" >> makedefs + + +# echo inserting h/$1.defs in .. +# for v in makefile unixport/make_kcn */makefile ; +# do +# echo " $v," +# ./bin/file-sub makedefs $v "# begin makedefs" "# end makedefs" tmpx +# mv tmpx $v +# done +# +#echo "" + +# Copy the config.h over. + +cat h/$1.h > tmpx +if [ -f ${HOME}/local_gcl.h ] ; then + cat ${HOME}/local_gcl.h >> tmpx +fi + +if fgrep =unknown makedefs > /dev/null ; +then echo " if the 'unknown' directories exist you may provide +a second argument to ./add-defs of a local directory where things might be, +or edit ./add-defs so that it can find them. Otherwise just continue +and the portions with unknown will not be compiled." +fi + + +if cmp tmpx h/config.h > /dev/null 2>&1 ;then true; +else +rm -f h/config.h +cp tmpx h/config.h +fi +rm -f tmpx + +# machine specific stuff that cant be handled normally... +if [ -f ./xbin/$1-fix ] ; then ./xbin/$1-fix ; fi diff --git a/ansi-tests/.cvsignore b/ansi-tests/.cvsignore new file mode 100644 index 0000000..2b0646a --- /dev/null +++ b/ansi-tests/.cvsignore @@ -0,0 +1,5 @@ +*.fn +*.x86f +*.fasl +*.ufsl +binary diff --git a/ansi-tests/README b/ansi-tests/README new file mode 100644 index 0000000..1d56d80 --- /dev/null +++ b/ansi-tests/README @@ -0,0 +1,14 @@ +This directory contains a partial Common Lisp standards compliance +test suite. + +To run the tests, load gclload.lsp. This will load and +run the tests. To just load the tests, load gclload1.lsp +and gclload2.lsp. + +Individual tests may be run by (rt:do-test '). + +Please tell me when you find incorrect test cases. + + Paul Dietz + dietz@dls.net + diff --git a/ansi-tests/adjustable-array-p.lsp b/ansi-tests/adjustable-array-p.lsp new file mode 100644 index 0000000..6a39218 --- /dev/null +++ b/ansi-tests/adjustable-array-p.lsp @@ -0,0 +1,68 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Mon Jan 20 21:25:22 2003 +;;;; Contains: Tests for ADJUSTABLE-ARRAY-P + +(in-package :cl-test) + +(deftest adjustable-array-p.1 + (notnot (adjustable-array-p (make-array '(5) :adjustable t))) + t) + +(deftest adjustable-array-p.2 + (notnot (adjustable-array-p (make-array nil :adjustable t))) + t) + +(deftest adjustable-array-p.3 + (notnot (adjustable-array-p (make-array '(2 3) :adjustable t))) + t) + +(deftest adjustable-array-p.4 + (notnot (adjustable-array-p (make-array '(2 2 2) :adjustable t))) + t) + +(deftest adjustable-array-p.5 + (notnot (adjustable-array-p (make-array '(2 2 2 2) :adjustable t))) + t) + +(deftest adjustable-array-p.order.1 + (let ((i 0) x) + (values + (notnot (adjustable-array-p (progn (setf x (incf i)) + (make-array '(5) :adjustable t)))) + i x)) + t 1 1) + +;;; Error tests + +(deftest adjustable-array-p.error.1 + (classify-error (adjustable-array-p)) + program-error) + +(deftest adjustable-array-p.error.2 + (classify-error (adjustable-array-p "aaa" nil)) + program-error) + +(deftest adjustable-array-p.error.3 + (classify-error (adjustable-array-p 10)) + type-error) + +(deftest adjustable-array-p.error.4 + (let (why) + (loop for e in *mini-universe* + unless (or (typep e 'array) + (eq 'type-error + (setq why (classify-error** + `(adjustable-array-p ',e))))) + collect (list e why))) + nil) + +(deftest adjustable-array-p.error.5 + (classify-error (locally (adjustable-array-p 10))) + type-error) + +(deftest adjustable-array-p.error.6 + (classify-error (let ((x 10)) + (locally (declare (optimize (safety 3))) + (adjustable-array-p x)))) + type-error) diff --git a/ansi-tests/and.lsp b/ansi-tests/and.lsp new file mode 100644 index 0000000..1a1ffda --- /dev/null +++ b/ansi-tests/and.lsp @@ -0,0 +1,57 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Oct 18 07:23:48 2002 +;;;; Contains: Tests for AND + +(in-package :cl-test) + +(deftest and.1 + (and) + t) + +(deftest and.2 + (and nil) + nil) + +(deftest and.3 + (and 'a) + a) + +(deftest and.4 + (and (values 'a 'b 'c)) + a b c) + +(deftest and.5 (and (values))) + +(deftest and.6 + (and (values t nil) 'a) + a) + +(deftest and.7 + (and nil (values 'a 'b 'c)) + nil) + +(deftest and.8 + (and (values 1 nil) (values nil 2)) + nil 2) + +(deftest and.9 + (and (values nil t) t) + nil) + +(deftest and.order.1 + (let ((x 0)) + (values (and nil (incf x)) + x)) + nil 0) + +(deftest and.order.2 + (let ((i 0) a b c d) + (values + (and (setf a (incf i)) + (setf b (incf i)) + (setf c (incf i)) + (setf d (incf i))) + i a b c d)) + 4 4 1 2 3 4) + diff --git a/ansi-tests/ansi-aux.lsp b/ansi-tests/ansi-aux.lsp new file mode 100644 index 0000000..305954a --- /dev/null +++ b/ansi-tests/ansi-aux.lsp @@ -0,0 +1,1457 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 17:10:18 1998 +;;;; Contains: Aux. functions for CL-TEST + +(in-package :cl-test) + +(declaim (optimize (safety 3))) + +;;; A function for coercing truth values to BOOLEAN + +(defun notnot (x) (not (not x))) + +(defmacro notnot-mv (form) + `(notnot-mv-fn (multiple-value-list ,form))) + +(defun notnot-mv-fn (results) + (if (null results) + (values) + (apply #'values + (not (not (first results))) + (rest results)))) + +(defmacro not-mv (form) + `(not-mv-fn (multiple-value-list ,form))) + +(defun not-mv-fn (results) + (if (null results) + (values) + (apply #'values + (not (first results)) + (rest results)))) + + +;;; Macro to check that a function is returning a specified number of values +;;; (defaults to 1) +(defmacro check-values (form &optional (num 1)) + (let ((v (gensym)) + (n (gensym))) + `(let ((,v (multiple-value-list ,form)) + (,n ,num)) + (check-values-length ,v ,n ',form) + (car ,v)))) + +(defun check-values-length (results expected-number form) + (declare (type fixnum expected-number)) + (let ((n expected-number)) + (declare (type fixnum n)) + (dolist (e results) + (declare (ignore e)) + (decf n)) + (unless (= n 0) + (error "Expected ~A results from ~A, got ~A results instead.~%~ +Results: ~A~%" expected-number form n results)))) + +;;; Do multiple-value-bind, but check # of arguments +(defmacro multiple-value-bind* ((&rest vars) form &body body) + (let ((len (length vars)) + (v (gensym))) + `(let ((,v (multiple-value-list ,form))) + (check-values-length ,v ,len ',form) + (destructuring-bind ,vars ,v ,@body)))) + +;;; Comparison functions that are like various builtins, +;;; but are guaranteed to return T for true. + +(defun eqt (x y) + "Like EQ, but guaranteed to return T for true." + (apply #'values (mapcar #'notnot (multiple-value-list (eq x y))))) + +(defun eqlt (x y) + "Like EQL, but guaranteed to return T for true." + (apply #'values (mapcar #'notnot (multiple-value-list (eql x y))))) + +(defun equalt (x y) + "Like EQUAL, but guaranteed to return T for true." + (apply #'values (mapcar #'notnot (multiple-value-list (equal x y))))) + +(defun equalpt (x y) + "Like EQUALP, but guaranteed to return T for true." + (apply #'values (mapcar #'notnot (multiple-value-list (equalp x y))))) + +(defun =t (x &rest args) + "Like =, but guaranteed to return T for true." + (apply #'values (mapcar #'notnot (multiple-value-list (apply #'= x args))))) + +(defun make-int-list (n) + (loop for i from 0 below n collect i)) + +(defun make-int-array (n &optional (fn #'make-array)) + (let ((a (funcall fn n))) + (loop for i from 0 below n do (setf (aref a i) i)) + a)) + +;;; Return true if A1 and A2 are arrays with the same rank +;;; and dimensions whose elements are EQUAL + +(defun equal-array (a1 a2) + (and (typep a1 'array) + (typep a2 'array) + (= (array-rank a1) (array-rank a2)) + (if (= (array-rank a1) 0) + (equal (aref a1) (aref a2)) + (let ((ad (array-dimensions a1))) + (and (equal ad (array-dimensions a2)) + (if (= (array-rank a1) 1) + (let ((as (first ad))) + (loop + for i from 0 below as + always (equal (aref a1 i) (aref a2 i)))) + (let ((as (array-total-size a1))) + (and (= as (array-total-size a2)) + (loop + for i from 0 below as + always (equal (row-major-aref a1 i) + (row-major-aref a2 i))))))))))) + +;;; *universe* is defined elsewhere -- it is a list of various +;;; lisp objects used when stimulating things in various tests. +(declaim (special *universe*)) + +;;; The function EMPIRICAL-SUBTYPEP checks two types +;;; for subtypeness, first using SUBTYPEP*, then (if that +;;; fails) empirically against all the elements of *universe*, +;;; checking if all that are in the first are also in the second. +;;; Return T if this is the case, NIL otherwise. This will +;;; always return T if type1 is truly a subtype of type2, +;;; but may return T even if this is not the case. + +(defun empirical-subtypep (type1 type2) + (multiple-value-bind (sub good) + (subtypep* type1 type2) + (if good + sub + (loop for e in *universe* + always (or (not (typep e type1)) (typep e type2)))))) + +;;; Check that the subtype relationships implied +;;; by disjointness are not contradicted. Return NIL +;;; if ok, or a list of error messages if not. + +;;; Assumes the types are nonempty. + +(defun check-disjointness (type1 type2) + (append + (check-subtypep type1 type2 nil) + (check-subtypep type2 type1 nil) + (check-subtypep type1 `(not ,type2) t) + (check-subtypep type2 `(not ,type1) t) + (check-subtypep `(and ,type1 ,type2) nil t) + (check-subtypep `(and ,type2 ,type1) nil t) + (check-subtypep `(and ,type1 (not ,type2)) type1 t) + (check-subtypep `(and (not ,type2) ,type1) type1 t) + (check-subtypep `(and ,type2 (not ,type1)) type2 t) + (check-subtypep `(and (not ,type1) ,type2) type2 t) +;;; (check-subtypep type1 `(or ,type1 (not ,type2)) t) +;;; (check-subtypep type1 `(or (not ,type2) ,type1) t) +;;; (check-subtypep type2 `(or ,type2 (not ,type1)) t) +;;; (check-subtypep type2 `(or (not ,type1) ,type2) t) + (check-subtypep t `(or (not ,type1) (not ,type2)) t) + (check-subtypep t `(or (not ,type2) (not ,type1)) t) + )) + +(defun check-equivalence (type1 type2) + (append + (check-subtypep type1 type2 t) + (check-subtypep type2 type1 t) + (check-subtypep `(not ,type1) `(not ,type2) t) + (check-subtypep `(not ,type2) `(not ,type1) t) + (check-subtypep `(and ,type1 (not ,type2)) nil t) + (check-subtypep `(and ,type2 (not ,type1)) nil t) + (check-subtypep `(and (not ,type2) ,type1) nil t) + (check-subtypep `(and (not ,type1) ,type2) nil t) + (check-subtypep t `(or ,type1 (not ,type2)) t) + (check-subtypep t `(or ,type2 (not ,type1)) t) + (check-subtypep t `(or (not ,type2) ,type1) t) + (check-subtypep t `(or (not ,type1) ,type2) t))) + +(defun check-all-subtypep (type1 type2) + (append + (check-subtypep type1 type2 t) + (check-subtypep `(not ,type2) `(not ,type1) t) + (check-subtypep `(and ,type1 (not ,type2)) nil t) + (check-subtypep t `(or (not ,type1) ,type2) t))) + +(defun check-all-not-subtypep (type1 type2) + (append + (check-subtypep type1 type2 nil) + (check-subtypep `(not ,type2) `(not ,type1) nil))) + +(defun check-subtypep (type1 type2 is-sub &optional should-be-valid) + (multiple-value-bind + (sub valid) + (subtypep type1 type2) + (unless (constantp type1) (setq type1 (list 'quote type1))) + (unless (constantp type2) (setq type2 (list 'quote type2))) + (if (or (and valid sub (not is-sub)) + (and valid (not sub) is-sub) + (and (not valid) should-be-valid)) + `(((SUBTYPEP ,type1 ,type2) cl-user::==> ,sub ,valid)) + nil))) + +(defun check-type-predicate (P TYPE) + "Check that a predicate P is the same as #'(lambda (x) (typep x TYPE)) + by applying both to all elements of *UNIVERSE*. Print message + when a mismatch is found, and return number of mistakes." + (loop + for x in *universe* count + (block failed + (let ((p1 (handler-case + (funcall P x) + (error () (format t "(FUNCALL ~S ~S) failed~%" + P x) + (return-from failed t)))) + (p2 (handler-case + (typep x TYPE) + (error () (format t "(TYPEP ~S '~S) failed~%" + x TYPE) + (return-from failed t))))) + (when (or (and p1 (not p2)) + (and (not p1) p2)) + (format t "(FUNCALL ~S ~S) = ~S, (TYPEP ~S '~S) = ~S~%" + P x p1 x TYPE p2) + t))))) + +(declaim (special *catch-error-type*)) + +(defun catch-continue-debugger-hook (condition dbh) + "Function that when used as *debugger-hook*, causes + continuable errors to be continued without user intervention." + (declare (ignore dbh)) + (let ((r (find-restart 'continue condition))) + (cond + ((and *catch-error-type* + (not (typep condition *catch-error-type*))) + (format t "Condition ~S is not a ~A~%" condition *catch-error-type*) + (cond (r (format t "Its continue restart is ~S~%" r)) + (t (format t "It has no continue restart~%"))) + (throw 'continue-failed nil)) + (r (invoke-restart r)) + (t (throw 'continue-failed nil))))) + +#| +(defun safe (fn &rest args) + "Apply fn to args, trapping errors. Convert type-errors to the + symbol type-error." + (declare (optimize (safety 3))) + (handler-case + (apply fn args) + (type-error () 'type-error) + (error (c) c))) +|# + +;;; Use the next macro in place of SAFE + +(defmacro catch-type-error (form) +"Evaluate form in safe mode, returning its value if there is no error. +If an error does occur, return type-error on TYPE-ERRORs, or the error +condition itself on other errors." +`(locally (declare (optimize (safety 3))) + (handler-case ,form + (type-error () 'type-error) + (error (c) c)))) + +(defmacro classify-error* (form) +"Evaluate form in safe mode, returning its value if there is no error. +If an error does occur, return a symbol classify the error, or allow +the condition to go uncaught if it cannot be classified." +`(locally (declare (optimize (safety 3))) + (handler-case ,form + (undefined-function () 'undefined-function) + (program-error () 'program-error) + (package-error () 'package-error) + (type-error () 'type-error) + (control-error () 'control-error) + (stream-error () 'stream-error) + (reader-error () 'reader-error) + (file-error () 'file-error) + (control-error () 'control-error) + (cell-error () 'cell-error) + (error () 'error) + ))) + +(defun classify-error** (form) + (handler-bind ((warning #'(lambda (c) (declare (ignore c)) + (muffle-warning)))) + (proclaim '(optimize (safety 3))) + (classify-error* + (if regression-test::*compile-tests* + (funcall (compile nil `(lambda () + (declare (optimize (safety 3))) + ,form))) + (eval form)) + ))) + +(defmacro classify-error (form) + `(classify-error** ',form)) + +;;; +;;; A scaffold is a structure that is used to remember the object +;;; identities of the cons cells in a (noncircular) data structure. +;;; This lets us check if the data structure has been changed by +;;; an operation. +;;; + +(defstruct scaffold + node + car + cdr) + +(defun make-scaffold-copy (x) + "Make a tree that will be used to check if a tree has been changed." + (if + (consp x) + (make-scaffold :node x + :car (make-scaffold-copy (car x)) + :cdr (make-scaffold-copy (cdr x))) + (make-scaffold :node x + :car nil + :cdr nil))) + +(defun check-scaffold-copy (x xcopy) + "Return t if xcopy were produced from x by make-scaffold-copy, + and none of the cons cells in the tree rooted at x have been + changed." + + (and (eq x (scaffold-node xcopy)) + (or + (not (consp x)) + (and + (check-scaffold-copy (car x) (scaffold-car xcopy)) + (check-scaffold-copy (cdr x) (scaffold-cdr xcopy)))))) + +(defun create-c*r-test (n) + (cond + ((<= n 0) 'none) + (t + (cons (create-c*r-test (1- n)) + (create-c*r-test (1- n)))))) + +(defun nth-1-body (x) + (loop + for e in x + and i from 0 + count (not (eqt e (nth i x))))) + +;;; +;;; The function SUBTYPEP should return two generalized booleans. +;;; This auxiliary function returns booleans instead +;;; (which makes it easier to write tests). +;;; +(defun subtypep* (type1 type2) + (apply #'values + (mapcar #'notnot + (multiple-value-list (subtypep type1 type2))))) + +(defun subtypep*-or-fail (type1 type2) + (let ((results (multiple-value-list (subtypep type1 type2)))) + (and (= (length results) 2) + (or (not (second results)) + (notnot (first results)))))) + +(defun subtypep*-not-or-fail (type1 type2) + (let ((results (multiple-value-list (subtypep type1 type2)))) + (and (= (length results) 2) + (or (not (second results)) + (not (first results)))))) + +;;; (eval-when (load eval compile) +;;; (unless (fboundp 'complement) +;;; (defun complement (fn) +;;; #'(lambda (&rest args) (not (apply fn args)))))) + +(defun compose (&rest fns) + (let ((rfns (reverse fns))) + #'(lambda (x) (loop for f in rfns do (setf x (funcall f x))) x))) + +(defun evendigitp (c) + (notnot (find c "02468"))) + +(defun odddigitp (c) + (notnot (find c "13579"))) + +(defun nextdigit (c) + (cadr (member c '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)))) + +(defun is-eq-p (x) #'(lambda (y) (eqt x y))) +(defun is-not-eq-p (x) #'(lambda (y) (not (eqt x y)))) + +(defun is-eql-p (x) #'(lambda (y) (eqlt x y))) +(defun is-not-eql-p (x) #'(lambda (y) (not (eqlt x y)))) + +(defun onep (x) (eql x 1)) + +(defun char-invertcase (c) + (if (upper-case-p c) (char-downcase c) + (char-upcase c))) + +(defun string-invertcase (s) + (map 'string #'char-invertcase s)) + +(defun symbol< (x &rest args) + (apply #'string< (symbol-name x) (mapcar #'symbol-name args))) + +(defun random-from-seq (seq) + "Generate a random member of a sequence." + (let ((len (length seq))) + (assert (> len 0)) + (elt seq (random len)))) + +(defmacro random-case (&body cases) + (let ((len (length cases))) + (assert (> len 0)) + `(case (random ,len) + ,@(loop for i from 0 for e in cases collect `(,i ,e)) + (t (error "Can't happen?! (in random-case~%"))))) + +(defun coin (&optional (n 2)) + "Flip an n-sided coin." + (eql (random n) 0)) + +;;; Randomly permute a sequence +(defun random-permute (seq) + (setq seq (copy-seq seq)) + (let ((len (length seq))) + (loop for i from len downto 2 + do (let ((r (random i))) + (rotatef (elt seq r) (elt seq (1- i)))))) + seq) + +(defun make-list-expr (args) + "Build an expression for computing (LIST . args), but that evades + CALL-ARGUMENTS-LIMIT." + (if (cddddr args) + (list 'list* + (first args) (second args) (third args) (fourth args) + (make-list-expr (cddddr args))) + (cons 'list args))) + +(defparameter +standard-chars+ + "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789~!@#$%^&*()_+|\\=-`{}[]:\";'<>?,./ + ") + +(defparameter + +base-chars+ #.(concatenate 'string + "abcdefghijklmnopqrstuvwxyz" + "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + "0123456789" + "<,>.?/\"':;[{]}~`!@#$%^&*()_-+= \\|")) + +(defparameter +num-base-chars+ (length +base-chars+)) + + +(defparameter +alpha-chars+ (subseq +standard-chars+ 0 52)) +(defparameter +lower-case-chars+ (subseq +alpha-chars+ 0 26)) +(defparameter +upper-case-chars+ (subseq +alpha-chars+ 26 52)) +(defparameter +alphanumeric-chars+ (subseq +standard-chars+ 0 62)) +(defparameter +digit-chars+ "0123456789") +(defparameter +extended-digit-chars+ "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ") +(defparameter +code-chars+ + (coerce (loop for i from 0 below 256 + for c = (code-char i) + when c collect c) + 'string)) +(defparameter +rev-code-chars+ (reverse +code-chars+)) + +;;; Used in checking for continuable errors + +(defun has-non-abort-restart (c) + (throw 'handled + (if (position 'abort (compute-restarts c) + :key #'restart-name :test-not #'eq) + 'success + 'fail))) + +(defmacro handle-non-abort-restart (&body body) + `(catch 'handled + (handler-bind ((error #'has-non-abort-restart)) + ,@body))) + +;;; used in elt.lsp +(defun elt-v-6-body () + (let ((x (make-int-list 1000))) + (let ((a (make-array '(1000) :initial-contents x))) + (loop + for i from 0 to 999 do + (unless (eql i (elt a i)) (return nil)) + finally (return t))))) + +(defun make-adj-array (n &key initial-contents) + (if initial-contents + (make-array n :adjustable t :initial-contents initial-contents) + (make-array n :adjustable t))) + +;;; used in elt.lsp +(defun elt-adj-array-6-body () + (let ((x (make-int-list 1000))) + (let ((a (make-adj-array '(1000) :initial-contents x))) + (loop + for i from 0 to 999 do + (unless (eql i (elt a i)) (return nil)) + finally (return t))))) + +(defparameter *displaced* (make-int-array 100000)) + +(defun make-displaced-array (n displacement) + (make-array n :displaced-to *displaced* + + :displaced-index-offset displacement)) + +;;; used in fill.lsp +(defun array-unsigned-byte-fill-test-fn (byte-size &rest fill-args) + (let* ((a (make-array '(5) :element-type (list 'unsigned-byte byte-size) + :initial-contents '(1 2 3 4 5))) + (b (apply #'fill a fill-args))) + (values (eqt a b) + (map 'list #'identity a)))) + +;;; used in fill-strings.lsp +(defun array-string-fill-test-fn (a &rest fill-args) + (setq a (copy-seq a)) + (let ((b (apply #'fill a fill-args))) + (values (eqt a b) b))) + +;;; From types-and-class.lsp + +(defparameter +float-types+ + '(long-float double-float short-float single-float)) + +(defparameter *subtype-table* +(let ((table + '( + (null symbol) + (symbol t) + (boolean symbol) + (standard-object t) + (function t) + (compiled-function function) + (generic-function function) + (standard-generic-function generic-function) + (class standard-object) + (built-in-class class) + (structure-class class) + (standard-class class) + (method standard-object) + (standard-method method) + (structure-object t) + (method-combination t) + (condition t) + (serious-condition condition) + (error serious-condition) + (type-error error) + (simple-type-error type-error) + (simple-condition condition) + (simple-type-error simple-condition) + (parse-error error) + (hash-table t) + (cell-error error) + (unbound-slot cell-error) + (warning condition) + (style-warning warning) + (storage-condition serious-condition) + (simple-warning warning) + (simple-warning simple-condition) + (keyword symbol) + (unbound-variable cell-error) + (control-error error) + (program-error error) + (undefined-function cell-error) + (package t) + (package-error error) + (random-state t) + (number t) + (real number) + (complex number) + (float real) + (short-float float) + (single-float float) + (double-float float) + (long-float float) + (rational real) + (integer rational) + (ratio rational) + (signed-byte integer) + (integer signed-byte) + (unsigned-byte signed-byte) + (bit unsigned-byte) + (fixnum integer) + (bignum integer) + (bit fixnum) + (arithmetic-error error) + (division-by-zero arithmetic-error) + (floating-point-invalid-operation arithmetic-error) + (floating-point-inexact arithmetic-error) + (floating-point-overflow arithmetic-error) + (floating-point-underflow arithmetic-error) + (character t) + (base-char character) + (standard-char base-char) + (extended-char character) + (sequence t) + (list sequence) + (null list) + (null boolean) + (cons list) + (array t) + (simple-array array) + (vector sequence) + (vector array) + (string vector) + (bit-vector vector) + (simple-vector vector) + (simple-vector simple-array) + (simple-bit-vector bit-vector) + (simple-bit-vector simple-array) + (base-string string) + (simple-string string) + (simple-string simple-array) + (simple-base-string base-string) + (simple-base-string simple-string) + (pathname t) + (logical-pathname pathname) + (file-error error) + (stream t) + (broadcast-stream stream) + (concatenated-stream stream) + (echo-stream stream) + (file-stream stream) + (string-stream stream) + (synonym-stream stream) + (two-way-stream stream) + (stream-error error) + (end-of-file stream-error) + (print-not-readable error) + (readtable t) + (reader-error parse-error) + (reader-error stream-error) + ))) + (when (subtypep* 'character 'base-char) + (setq table + (append + '((character base-char) + (string base-string) + (simple-string simple-base-string)) + table))) + + table)) + +(defparameter *disjoint-types-list* + '(cons symbol array + number character hash-table function readtable package + pathname stream random-state condition restart)) + +(defparameter *disjoint-types-list2* + `((cons (cons t t) (cons t (cons t t)) (eql (nil))) + (symbol keyword boolean null (eql a) (eql nil) (eql t) (eql *)) + (array vector simple-array simple-vector string simple-string + base-string simple-base-string (eql #())) + (character base-char standard-char (eql #\a) + ,@(if (subtypep 'character 'base-char) nil + (list 'extended-char))) + (function compiled-function generic-function standard-generic-function + (eql ,#'car)) + (package (eql ,(find-package "COMMON-LISP"))) + (pathname logical-pathname (eql #p"")) + (stream broadcast-stream concatenated-stream echo-stream + file-stream string-stream synonym-stream two-way-stream) + (number real complex float integer rational ratio fixnum + bit (integer 0 100) (float 0.0 100.0) (integer 0 *) + (rational 0 *) (mod 10) + (eql 0) + ,@(and (not (subtypep 'bignum nil)) + (list 'bignum))) + (random-state) + ,*condition-types* + (restart) + (readtable))) + +(defparameter *types-list3* + (reduce #'append *disjoint-types-list2* :from-end t)) + +(defun trim-list (list n) + (let ((len (length list))) + (if (<= len n) list + (append (subseq list 0 n) + (format nil "And ~A more omitted." (- len n)))))) + +(defun is-t-or-nil (e) + (or (eqt e t) (eqt e nil))) + +(defun is-builtin-class (type) + (when (symbolp type) (setq type (find-class type nil))) + (typep type 'built-in-class)) + +(defun classes-are-disjoint (c1 c2) + "If either c1 or c2 is a builtin class or the name of a builtin + class, then check for disjointness. Return a non-NIL list + of failed subtypep relationships, if any." + (and (or (is-builtin-class c1) + (is-builtin-class c2)) + (check-disjointness c1 c2))) + +(declaim (special *subtype-table*)) + +(defun types.6-body () + (loop + for p in *subtype-table* + for tp = (car p) + append + (and (not (member tp '(sequence cons list t))) + (let ((message (check-subtypep tp 'atom t t))) + (if message (list message)))))) + +(defparameter *type-list* nil) +(defparameter *supertype-table* nil) +(declaim (special *subtype-table*)) + +(defun types.9-body () + (let ((tp-list (append '(keyword atom list) + (loop for p in *subtype-table* collect (car p)))) + (result-list)) + (setf tp-list (remove-duplicates tp-list)) + ;; TP-LIST is now a list of unique CL type names + ;; Store it in *TYPE-LIST* so we can inspect it later if this test + ;; fails. The variable is also used in test TYPES.9A + (setf *type-list* tp-list) + ;; Compute all pairwise SUBTYPEP relationships among + ;; the elements of *TYPE-LIST*. + (let ((subs (make-hash-table :test #'eq)) + (sups (make-hash-table :test #'eq))) + (loop + for x in tp-list do + (loop + for y in tp-list do + (multiple-value-bind (result good) + (subtypep* x y) + (declare (ignore good)) + (when result + (pushnew x (gethash y subs)) + (pushnew y (gethash x sups)))))) + ;; Store the supertype relations for later inspection + ;; and use in test TYPES.9A + (setf *supertype-table* sups) + ;; Check that the relation we just computed is transitive. + ;; Return a list of triples on which transitivity fails. + (loop + for x in tp-list do + (let ((sub-list (gethash x subs)) + (sup-list (gethash x sups))) + (loop + for t1 in sub-list do + (loop + for t2 in sup-list do + (multiple-value-bind (result good) + (subtypep* t1 t2) + (when (and good (not result)) + (pushnew (list t1 x t2) result-list + :test #'equal))))))) + + result-list))) + +;;; TYPES.9-BODY returns a list of triples (T1 T2 T3) +;;; where (AND (SUBTYPEP T1 T2) (SUBTYPEP T2 T3) (NOT (SUBTYPEP T1 T3))) +;;; (and where SUBTYPEP succeeds in each case, returning true as its +;;; second return value.) + +(defun types.9a-body () + (cond + ((not (and *type-list* *supertype-table*)) + (format nil "Run test type.9 first~%") + nil) + (t + (loop + for tp in *type-list* + sum + (let ((sups (gethash tp *supertype-table*))) + (loop + for x in *universe* + sum + (handler-case + (cond + ((not (typep x tp)) 0) + (t + (loop + for tp2 in sups + count + (handler-case + (and (not (typep x tp2)) + (progn + (format t "Found element of ~S not in ~S: ~S~%" + tp tp2 x) + t)) + (condition (c) (format t "Error ~S occured: ~S~%" + c tp2) + t))))) + (condition (c) (format t "Error ~S occured: ~S~%" c tp) + 1)))))))) + +(defun even-size-p (a) + (some #'evenp (array-dimensions a))) + +(defun check-cons-copy (x y) + "Check that the tree x is a copy of the tree y, + returning t if it is, nil if not." + (cond + ((consp x) + (and (consp y) + (not (eqt x y)) + (check-cons-copy (car x) (car y)) + (check-cons-copy (cdr x) (cdr y)))) + ((eqt x y) t) + (t nil))) + +(defun check-sublis (a al &key (key 'no-key) test test-not) + "Apply sublis al a with various keys. Check that + the arguments are not themselves changed. Return nil + if the arguments do get changed." + (setf a (copy-tree a)) + (setf al (copy-tree al)) + (let ((acopy (make-scaffold-copy a)) + (alcopy (make-scaffold-copy al))) + (let ((as + (apply #'sublis al a + `(,@(when test `(:test ,test)) + ,@(when test-not `(:test-not ,test-not)) + ,@(unless (eqt key 'no-key) `(:key ,key)))))) + (and + (check-scaffold-copy a acopy) + (check-scaffold-copy al alcopy) + as)))) + +(defun check-nsublis (a al &key (key 'no-key) test test-not) + "Apply nsublis al a, copying these arguments first." + (setf a (copy-tree a)) + (setf al (copy-tree al)) + (let ((as + (apply #'sublis (copy-tree al) (copy-tree a) + `(,@(when test `(:test ,test)) + ,@(when test-not `(:test-not ,test-not)) + ,@(unless (eqt key 'no-key) `(:key ,key)))))) + as)) + +(defun check-subst (new old tree &key (key 'no-key) test test-not) + "Call subst new old tree, with keyword arguments if present. + Check that the arguments are not changed." + (setf new (copy-tree new)) + (setf old (copy-tree old)) + (setf tree (copy-tree tree)) + (let ((newcopy (make-scaffold-copy new)) + (oldcopy (make-scaffold-copy old)) + (treecopy (make-scaffold-copy tree))) + (let ((result + (apply #'subst new old tree + `(,@(unless (eqt key 'no-key) `(:key ,key)) + ,@(when test `(:test ,test)) + ,@(when test-not `(:test-not ,test-not)))))) + (and (check-scaffold-copy new newcopy) + (check-scaffold-copy old oldcopy) + (check-scaffold-copy tree treecopy) + result)))) + + +(defun check-subst-if (new pred tree &key (key 'no-key)) + "Call subst-if new pred tree, with various keyword arguments + if present. Check that the arguments are not changed." + (setf new (copy-tree new)) + (setf tree (copy-tree tree)) + (let ((newcopy (make-scaffold-copy new)) + (predcopy (make-scaffold-copy pred)) + (treecopy (make-scaffold-copy tree))) + (let ((result + (apply #'subst-if new pred tree + (unless (eqt key 'no-key) `(:key ,key))))) + (and (check-scaffold-copy new newcopy) + (check-scaffold-copy pred predcopy) + (check-scaffold-copy tree treecopy) + result)))) + +(defun check-subst-if-not (new pred tree &key (key 'no-key)) + "Call subst-if-not new pred tree, with various keyword arguments + if present. Check that the arguments are not changed." + (setf new (copy-tree new)) + (setf tree (copy-tree tree)) + (let ((newcopy (make-scaffold-copy new)) + (predcopy (make-scaffold-copy pred)) + (treecopy (make-scaffold-copy tree))) + (let ((result + (apply #'subst-if-not new pred tree + (unless (eqt key 'no-key) `(:key ,key))))) + (and (check-scaffold-copy new newcopy) + (check-scaffold-copy pred predcopy) + (check-scaffold-copy tree treecopy) + result)))) + +(defun check-nsubst (new old tree &key (key 'no-key) test test-not) + "Call nsubst new old tree, with keyword arguments if present." + (setf new (copy-tree new)) + (setf old (copy-tree old)) + (setf tree (copy-tree tree)) + (apply #'nsubst new old tree + `(,@(unless (eqt key 'no-key) `(:key ,key)) + ,@(when test `(:test ,test)) + ,@(when test-not `(:test-not ,test-not))))) + +(defun check-nsubst-if (new pred tree &key (key 'no-key)) + "Call nsubst-if new pred tree, with keyword arguments if present." + (setf new (copy-tree new)) + (setf tree (copy-tree tree)) + (apply #'nsubst-if new pred tree + (unless (eqt key 'no-key) `(:key ,key)))) + +(defun check-nsubst-if-not (new pred tree &key (key 'no-key)) + "Call nsubst-if-not new pred tree, with keyword arguments if present." + (setf new (copy-tree new)) + (setf tree (copy-tree tree)) + (apply #'nsubst-if-not new pred tree + (unless (eqt key 'no-key) `(:key ,key)))) + +(defun check-copy-list-copy (x y) + "Check that y is a copy of the list x." + (if + (consp x) + (and (consp y) + (not (eqt x y)) + (eqt (car x) (car y)) + (check-copy-list-copy (cdr x) (cdr y))) + (and (eqt x y) t))) + +(defun check-copy-list (x) + "Apply copy-list, checking that it properly copies, + and checking that it does not change its argument." + (let ((xcopy (make-scaffold-copy x))) + (let ((y (copy-list x))) + (and + (check-scaffold-copy x xcopy) + (check-copy-list-copy x y) + y)))) + +(defun append-6-body () + (let* ((cal (min 2048 call-arguments-limit)) + (step (max 1 (floor (/ cal) 64)))) + (loop + for n from 0 + below cal + by step + count + (not + (equal + (apply #'append (loop for i from 1 to n + collect '(a))) + (make-list n :initial-element 'a)))))) + +(defun is-intersection (x y z) + "Check that z is the intersection of x and y." + (and + (listp x) + (listp y) + (listp z) + (loop for e in x + always (or (not (member e y)) + (member e z))) + (loop for e in y + always (or (not (member e x)) + (member e z))) + (loop for e in z + always (and (member e x) (member e y))) + t)) + +(defun shuffle (x) + (cond + ((null x) nil) + ((null (cdr x)) x) + (t + (multiple-value-bind + (y z) + (split-list x) + (append (shuffle y) (shuffle z)))))) + +(defun split-list (x) + (cond + ((null x) (values nil nil)) + ((null (cdr x)) (values x nil)) + (t + (multiple-value-bind + (y z) + (split-list (cddr x)) + (values (cons (car x) y) (cons (cadr x) z)))))) + +(defun intersection-12-body (size niters &optional (maxelem (* 2 size))) + (let ((state (make-random-state))) + (loop + for i from 1 to niters do + (let ((x (shuffle (loop for j from 1 to size + collect (random maxelem state)))) + (y (shuffle (loop for j from 1 to size + collect (random maxelem state))))) + (let ((z (intersection x y))) + (let ((is-good (is-intersection x y z))) + (unless is-good (return (values x y z))))))) + nil)) + +(defun nintersection-with-check (x y &key test) + (let ((ycopy (make-scaffold-copy y))) + (let ((result (if test + (nintersection x y :test test) + (nintersection x y)))) + (if (check-scaffold-copy y ycopy) + result + 'failed)))) + +(defun nintersection-12-body (size niters &optional (maxelem (* 2 size))) + (let ((state (make-random-state t))) + (loop + for i from 1 to niters do + (let ((x (shuffle (loop for j from 1 to size + collect (random maxelem state)))) + (y (shuffle (loop for j from 1 to size + collect (random maxelem state))))) + (let ((z (nintersection-with-check (copy-list x) y))) + (when (eqt z 'failed) (return (values x y z))) + (let ((is-good (is-intersection x y z))) + (unless is-good (return (values x y z))))))) + nil)) + + +(defun union-with-check (x y &key test test-not) + (let ((xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y))) + (let ((result (cond + (test (union x y :test test)) + (test-not (union x y :test-not test-not)) + (t (union x y))))) + (if (and (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy)) + result + 'failed)))) + +(defun union-with-check-and-key (x y key &key test test-not) + (let ((xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y))) + (let ((result (cond + (test (union x y :key key :test test)) + (test-not (union x y :key key :test-not test-not)) + (t (union x y :key key))))) + (if (and (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy)) + result + 'failed)))) + +(defun check-union (x y z) + (and (listp x) + (listp y) + (listp z) + (loop for e in z always (or (member e x) (member e y))) + (loop for e in x always (member e z)) + (loop for e in y always (member e z)) + t)) + +(defun do-random-unions (size niters &optional (maxelem (* 2 size))) + (let ((state (make-random-state))) + (loop + for i from 1 to niters do + (let ((x (shuffle (loop for j from 1 to size collect + (random maxelem state)))) + (y (shuffle (loop for j from 1 to size collect + (random maxelem state))))) + (let ((z (union x y))) + (let ((is-good (check-union x y z))) + (unless is-good (return (values x y z))))))) + nil)) + +(defun nunion-with-copy (x y &key test test-not) + (setf x (copy-list x)) + (setf y (copy-list y)) + (cond + (test (nunion x y :test test)) + (test-not (nunion x y :test-not test-not)) + (t (nunion x y)))) + +(defun nunion-with-copy-and-key (x y key &key test test-not) + (setf x (copy-list x)) + (setf y (copy-list y)) + (cond + (test (nunion x y :key key :test test)) + (test-not (nunion x y :key key :test-not test-not)) + (t (nunion x y :key key)))) + +(defun do-random-nunions (size niters &optional (maxelem (* 2 size))) + (let ((state (make-random-state))) + (loop + for i from 1 to niters do + (let ((x (shuffle (loop for j from 1 to size collect + (random maxelem state)))) + (y (shuffle (loop for j from 1 to size collect + (random maxelem state))))) + (let ((z (nunion-with-copy x y))) + (let ((is-good (check-union x y z))) + (unless is-good (return (values x y z))))))) + nil)) + +(defun set-difference-with-check (x y &key (key 'no-key) + test test-not) + (setf x (copy-list x)) + (setf y (copy-list y)) + (let ((xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y))) + (let ((result (apply #'set-difference + x y + `(,@(unless (eqt key 'no-key) `(:key ,key)) + ,@(when test `(:test ,test)) + ,@(when test-not `(:test-not ,test-not)))))) + (cond + ((and (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy)) + result) + (t + 'failed))))) + +(defun check-set-difference (x y z &key (key #'identity) + (test #'eql)) + (and + ;; (not (eqt 'failed z)) + (listp x) + (listp y) + (listp z) + (loop for e in z always (member e x :key key :test test)) + (loop for e in x always (or (member e y :key key :test test) + (member e z :key key :test test))) + (loop for e in y never (member e z :key key :test test)) + t)) + +(defun do-random-set-differences (size niters &optional (maxelem (* 2 size))) + (let ((state (make-random-state))) + (loop + for i from 1 to niters do + (let ((x (shuffle (loop for j from 1 to size collect + (random maxelem state)))) + (y (shuffle (loop for j from 1 to size collect + (random maxelem state))))) + (let ((z (set-difference-with-check x y))) + (let ((is-good (check-set-difference x y z))) + (unless is-good (return (values x y z))))))) + nil)) +(defun nset-difference-with-check (x y &key (key 'no-key) + test test-not) + (setf x (copy-list x)) + (setf y (copy-list y)) + (apply #'nset-difference + x y + `(,@(unless (eqt key 'no-key) `(:key ,key)) + ,@(when test `(:test ,test)) + ,@(when test-not `(:test-not ,test-not))))) + +(defun check-nset-difference (x y z &key (key #'identity) + (test #'eql)) + (and + (listp x) + (listp y) + (listp z) + (loop for e in z always (member e x :key key :test test)) + (loop for e in x always (or (member e y :key key :test test) + (member e z :key key :test test))) + (loop for e in y never (member e z :key key :test test)) + t)) + +(defun do-random-nset-differences (size niters &optional (maxelem (* 2 size))) + (let ((state (make-random-state))) + (loop + for i from 1 to niters do + (let ((x (shuffle (loop for j from 1 to size collect + (random maxelem state)))) + (y (shuffle (loop for j from 1 to size collect + (random maxelem state))))) + (let ((z (nset-difference-with-check x y))) + (let ((is-good (check-nset-difference x y z))) + (unless is-good (return (values x y z))))))) + nil)) + +(defun set-exclusive-or-with-check (x y &key (key 'no-key) + test test-not) + (setf x (copy-list x)) + (setf y (copy-list y)) + (let ((xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y))) + (let ((result (apply #'set-exclusive-or + x y + `(,@(unless (eqt key 'no-key) `(:key ,key)) + ,@(when test `(:test ,test)) + ,@(when test-not `(:test-not ,test-not)))))) + (cond + ((and (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy)) + result) + (t + 'failed))))) + +(defun check-set-exclusive-or (x y z &key (key #'identity) + (test #'eql)) + (and + ;; (not (eqt 'failed z)) + (listp x) + (listp y) + (listp z) + (loop for e in z always (or (member e x :key key :test test) + (member e y :key key :test test))) + (loop for e in x always (if (member e y :key key :test test) + (not (member e z :key key :test test)) + (member e z :key key :test test))) + (loop for e in y always (if (member e x :key key :test test) + (not (member e z :key key :test test)) + (member e z :key key :test test))) + t)) + +(defun do-random-set-exclusive-ors (size niters &optional (maxelem (* 2 size))) + (let ((state (make-random-state))) + (loop + for i from 1 to niters do + (let ((x (shuffle (loop for j from 1 to size collect + (random maxelem state)))) + (y (shuffle (loop for j from 1 to size collect + (random maxelem state))))) + (let ((z (set-exclusive-or-with-check x y))) + (let ((is-good (check-set-exclusive-or x y z))) + (unless is-good (return (values x y z))))))) + nil)) + +(defun nset-exclusive-or-with-check (x y &key (key 'no-key) + test test-not) + (setf x (copy-list x)) + (setf y (copy-list y)) + (apply #'nset-exclusive-or + x y + `(,@(unless (eqt key 'no-key) `(:key ,key)) + ,@(when test `(:test ,test)) + ,@(when test-not `(:test-not ,test-not))))) + +(defun do-random-nset-exclusive-ors (size niters &optional (maxelem (* 2 size))) + (let ((state (make-random-state))) + (loop + for i from 1 to niters do + (let ((x (shuffle (loop for j from 1 to size collect + (random maxelem state)))) + (y (shuffle (loop for j from 1 to size collect + (random maxelem state))))) + (let ((z (nset-exclusive-or-with-check x y))) + (let ((is-good (check-set-exclusive-or x y z))) + (unless is-good (return (values x y z))))))) + nil)) + +(defun subsetp-with-check (x y &key (key 'no-key) test test-not) + (let ((xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y))) + (let ((result + (apply #'subsetp x y + `(,@(unless (eqt key 'no-key) + `(:key ,key)) + ,@(when test `(:test ,test)) + ,@(when test-not `(:test-not ,test-not)))))) + (cond + ((and (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy)) + (not (not result))) + (t 'failed))))) + +(defun safe-elt (x n) + (classify-error* (elt x n))) + +(defmacro defstruct* (&body args) + `(eval-when (load eval compile) + (ignore-errors + (defstruct ,@args)))) + + +(defun sort-package-list (x) + (sort (copy-list x) + #'string< + :key #'package-name)) + +(defun sort-symbols (sl) + (sort (copy-list sl) + #'(lambda (x y) + (or + (string< (symbol-name x) + (symbol-name y)) + (and (string= (symbol-name x) + (symbol-name y)) + (string< (package-name (symbol-package x)) + (package-name (symbol-package y)))))))) + +(defun num-symbols-in-package (p) + (let ((num 0)) + (declare (fixnum num)) + (do-symbols (s p num) + (incf num)))) + +(defun num-external-symbols-in-package (p) + (let ((num 0)) + (declare (fixnum num)) + (do-external-symbols (s p num) + (incf num)))) + +(defun safely-delete-package (package-designator) + (let ((package (find-package package-designator))) + (when package + (let ((used-by (package-used-by-list package))) + (dolist (using-package used-by) + (unuse-package package using-package))) + (delete-package package)))) + +(defconstant +fail-count-limit+ 20) + +(defmacro test-with-package-iterator (package-list-expr &rest symbol-types) + "Build an expression that tests the with-package-iterator form." + (let ((name (gensym)) + (cht-var (gensym)) + (pkg-list-var (gensym))) + `(let ((,cht-var (make-hash-table)) + (,pkg-list-var ,package-list-expr) + (fail-count 0)) + (with-package-iterator (,name ,pkg-list-var + ,@(copy-list symbol-types)) + ;; For each symbol, check that name is returning appropriate + ;; things + (loop + (block fail + (multiple-value-bind (more sym access pkg) + (,name) + (unless more (return nil)) + (setf (gethash sym ,cht-var) t) ;; note presence of symbol + ;; Check that its access status is in the list, + ;; that pkg is a package, + ;; that the symbol is in the package, + ;; and that (in the package) it has the correct access type + (unless (member access (quote ,(copy-list symbol-types))) + (unless (> fail-count +fail-count-limit+) + (format t "Bad access type: ~S ==> ~A~%" sym access)) + (when (= fail-count +fail-count-limit+) + (format t "Further messages suppressed~%")) + (incf fail-count) + (return-from fail nil)) + + (unless (packagep pkg) + (unless (> fail-count +fail-count-limit+) + (format t "Not a package: ~S ==> ~S~%" sym pkg)) + (when (= fail-count +fail-count-limit+) + (format t "Further messages suppressed~%")) + (incf fail-count) + (return-from fail nil)) + (multiple-value-bind (sym2 access2) + (find-symbol (symbol-name sym) pkg) + (unless (or (eqt sym sym2) + (member sym2 (package-shadowing-symbols pkg))) + (unless (> fail-count +fail-count-limit+) + (format t "Not same symbol: ~S ~S~%" sym sym2)) + (when (= fail-count +fail-count-limit+) + (format t "Further messages suppressed~%")) + (incf fail-count) + (return-from fail nil)) + (unless (eqt access access2) + (unless (> fail-count +fail-count-limit+) + (format t "Not same access type: ~S ~S ~S~%" + sym access access2)) + (when (= fail-count +fail-count-limit+) + (format t "Further messages suppressed~%")) + (incf fail-count) + (return-from fail nil))))))) + ;; now, check that each symbol in each package has + ;; been properly found + (loop + for p in ,pkg-list-var do + (block fail + (do-symbols (sym p) + (multiple-value-bind (sym2 access) + (find-symbol (symbol-name sym) p) + (unless (eqt sym sym2) + (unless (> fail-count +fail-count-limit+) + (format t "Not same symbol (2): ~S ~S~%" + sym sym2)) + (when (= fail-count +fail-count-limit+) + (format t "Further messages suppressed~%")) + (incf fail-count) + (return-from fail nil)) + (unless (or (not (member access + (quote ,(copy-list symbol-types)))) + (gethash sym ,cht-var)) + (format t "Symbol not found: ~S~%" sym) + (incf fail-count) + (return-from fail nil)))))) + (or (zerop fail-count) fail-count)))) + +(defun with-package-iterator-internal (packages) + (test-with-package-iterator packages :internal)) + +(defun with-package-iterator-external (packages) + (test-with-package-iterator packages :external)) + +(defun with-package-iterator-inherited (packages) + (test-with-package-iterator packages :inherited)) + +(defun with-package-iterator-all (packages) + (test-with-package-iterator packages :internal :external :inherited)) + +(defun frob-simple-condition (c expected-fmt &rest expected-args) + "Try out the format control and format arguments of a simple-condition C, + but make no assumptions about what they print as, only that they + do print." + (declare (ignore expected-fmt expected-args)) + (and (typep c 'simple-condition) + (let ((fc (simple-condition-format-control c)) + (args (simple-condition-format-arguments c))) + (and + (stringp (apply #'format nil fc args)) + t)))) + +(defun frob-simple-error (c expected-fmt &rest expected-args) + (and (typep c 'simple-error) + (apply #'frob-simple-condition c expected-fmt expected-args))) + +(defun frob-simple-warning (c expected-fmt &rest expected-args) + (and (typep c 'simple-warning) + (apply #'frob-simple-condition c expected-fmt expected-args))) + +(defparameter *array-element-types* + '(t (integer 0 0) + bit (unsigned-byte 8) (unsigned-byte 16) + (unsigned-byte 32) float short-float + single-float double-float long-float + nil character base-char symbol boolean null)) + +(defun random-partition (n p) + "Partition n into p numbers, each >= 1. Return list of numbers." + (assert (<= 1 p)) + #| + (cond + ((= p 1) (list n)) + ((< n p) (make-list p :initial-element 1)) + (t + (let ((n1 (1+ (random (floor n p))))) + (cons n1 (random-partition (- n n1) (1- p))))))) + |# + (cond + ((= p 1) (list n)) + ((= n 0) (make-list p :initial-element 0)) + (t (let* ((r (random p)) + (n1 (random (1+ n)))) + (cond + ((= r 0) + (cons n1 (random-partition (- n n1) (1- p)))) + ((= r (1- p)) + (append (random-partition (- n n1) (1- p)) (list n1))) + (t + (let* ((n2 (random (1+ (- n n1)))) + (n3 (- n n1 n2))) + (append (random-partition n2 r) + (list n1) + (random-partition n3 (- p 1 r)))))))))) + diff --git a/ansi-tests/apply.lsp b/ansi-tests/apply.lsp new file mode 100644 index 0000000..56ab007 --- /dev/null +++ b/ansi-tests/apply.lsp @@ -0,0 +1,61 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Mon Jan 13 15:13:07 2003 +;;;; Contains: Tests of APPLY + +(in-package :cl-test) + +;;; Error cases + +(deftest apply.error.1 + (classify-error (apply)) + program-error) + +(deftest apply.error.2 + (classify-error (apply #'cons)) + program-error) + +(deftest apply.error.3 + (classify-error (apply #'cons nil)) + program-error) + +(deftest apply.error.4 + (classify-error (apply #'cons (list 1 2 3))) + program-error) + +;;; Non-error cases + +(deftest apply.1 + (apply #'cons 'a 'b nil) + (a . b)) + +(deftest apply.2 + (apply #'cons 'a '(b)) + (a . b)) + +(deftest apply.3 + (apply #'cons '(a b)) + (a . b)) + +(deftest apply.4 + (let ((zeros (make-list (min 10000 (1- call-arguments-limit)) + :initial-element 1))) + (apply #'+ zeros)) + #.(min 10000 (1- call-arguments-limit))) + +(deftest apply.5 + (apply 'cons '(a b)) + (a . b)) + +(deftest apply.order.1 + (let ((i 0) x y z) + (values + (apply (progn (setf x (incf i)) + #'list) + (progn (setf y (incf i)) + 'b) + (progn (setf z (incf i)) + (list 'a))) + i x y z)) + (b a) 3 1 2 3) + diff --git a/ansi-tests/aref.lsp b/ansi-tests/aref.lsp new file mode 100644 index 0000000..1b8c093 --- /dev/null +++ b/ansi-tests/aref.lsp @@ -0,0 +1,144 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Feb 11 17:33:24 2003 +;;;; Contains: Tests for AREF + +(in-package :cl-test) + +;;; AREF is also tested in many other places + +(deftest aref.1 + (aref #0aT) + T) + +(deftest aref.2 + (aref #(1 2 3 4) 2) + 3) + +(deftest aref.3 + (aref #2a((a b c d)(e f g h)) 1 2) + g) + +(deftest aref.4 + (loop for i from 0 below 6 collect (aref "abcdef" i)) + (#\a #\b #\c #\d #\e #\f)) + +(deftest aref.5 + (let ((a (make-array '(2 3) :element-type 'base-char + :initial-contents '("abc" "def")))) + (loop for i below 2 + collect (loop for j below 3 + collect (aref a i j)))) + ((#\a #\b #\c) + (#\d #\e #\f))) + +(deftest aref.6 + (loop for i below 10 collect (aref #*1101100010 i)) + (1 1 0 1 1 0 0 0 1 0)) + +(deftest aref.7 + (let ((a (make-array '(2 5) :element-type 'bit + :initial-contents '((1 1 0 0 1) + (0 1 0 1 0))))) + (loop for i below 2 + collect (loop for j below 5 + collect (aref a i j)))) + ((1 1 0 0 1) + (0 1 0 1 0))) + +;;; Order of argument evaluation + +(deftest aref.order.1 + (let ((i 0) x y (a #(a b c d))) + (values + (aref (progn (setf x (incf i)) a) + (progn (setf y (incf i)) 2)) + i x y)) + c 2 1 2) + +(deftest aref.order.2 + (let ((i 0) x y z (a #2a((a b c)(d e f)))) + (values + (aref (progn (setf x (incf i)) a) + (progn (setf y (incf i)) 1) + (progn (setf z (incf i)) 2)) + i x y z)) + f 3 1 2 3) + + +;;; Setf of aref + +(deftest setf-aref.1 + (let ((a (copy-seq #(1 2 3 4)))) + (values + (setf (aref a 2) 'z) + a)) + z + #(1 2 z 4)) + +(deftest setf-aref.2 + (let ((a (make-array nil :initial-element 1))) + (values + (setf (aref a) 'z) + a)) + z #0az) + +(deftest setf-aref.3 + (let ((a (make-array '(2 3) :initial-element 'a))) + (values + (setf (aref a 0 1) 'z) + a)) + z + #2a((a z a)(a a a))) + +(deftest setf-aref.4 + (let ((a (copy-seq "abcd"))) + (values + (setf (aref a 0) #\z) + a)) + #\z + "zbcd") + +(deftest setf-aref.5 + (let ((a (copy-seq #*0011))) + (values + (setf (aref a 0) 1) + a)) + 1 + #*1011) + +(deftest setf-aref.6 + (let ((a (make-array '(2 3) :initial-element #\a :element-type 'base-char))) + (values + (setf (aref a 0 1) #\z) + a)) + #\z + #2a((#\a #\z #\a)(#\a #\a #\a))) + +(deftest setf-aref.7 + (let ((a (make-array '(2 3) :initial-element 1 :element-type 'bit))) + (values + (setf (aref a 0 1) 0) + a)) + 0 + #2a((1 0 1)(1 1 1))) + +(deftest setf-aref.order.1 + (let ((i 0) x y z (a (copy-seq #(a b c d)))) + (values + (setf (aref (progn (setf x (incf i)) a) + (progn (setf y (incf i)) 2)) + (progn (setf z (incf i)) 'z)) + a + i x y z)) + z #(a b z d) 3 1 2 3) + +;;; To add: aref on displaced arrays, arrays with fill pointers, etc. + +(deftest aref.error.1 + (classify-error (aref)) + program-error) + +(deftest aref.error.2 + (classify-error (funcall #'aref)) + program-error) diff --git a/ansi-tests/array-as-class.lsp b/ansi-tests/array-as-class.lsp new file mode 100644 index 0000000..879e090 --- /dev/null +++ b/ansi-tests/array-as-class.lsp @@ -0,0 +1,66 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Jan 26 07:45:25 2003 +;;;; Contains: Tests for ARRAY as a class + +(in-package :cl-test) + +(deftest array-as-class.1 + (notnot-mv (typep #() (find-class 'array))) + t) + +(deftest array-as-class.2 + (notnot-mv (typep #(a b c) (find-class 'array))) + t) + +(deftest array-as-class.3 + (notnot-mv (typep #0aNIL (find-class 'array))) + t) + +(deftest array-as-class.4 + (notnot-mv (typep #2a((a b)(c d)) (find-class 'array))) + t) + +(deftest array-as-class.5 + (notnot-mv (typep "abcde" (find-class 'array))) + t) + +(deftest array-as-class.6 + (notnot-mv (typep #*0011101 (find-class 'array))) + t) + +(deftest array-as-class.7 + (subtypep* 'array (find-class 'array)) + t t) + +(deftest array-as-class.8 + (subtypep* (find-class 'array) 'array) + t t) + +(deftest array-as-class.9 + (typep nil (find-class 'array)) + nil) + +(deftest array-as-class.10 + (typep 'x (find-class 'array)) + nil) + +(deftest array-as-class.11 + (typep '(a b c) (find-class 'array)) + nil) + +(deftest array-as-class.12 + (typep 10.0 (find-class 'array)) + nil) + +(deftest array-as-class.13 + (typep #'(lambda (x) (cons x nil)) (find-class 'array)) + nil) + +(deftest array-as-class.14 + (typep 1 (find-class 'array)) + nil) + +(deftest array-as-class.15 + (typep (1+ most-positive-fixnum) (find-class 'array)) + nil) diff --git a/ansi-tests/array-aux.lsp b/ansi-tests/array-aux.lsp new file mode 100644 index 0000000..09f8ccf --- /dev/null +++ b/ansi-tests/array-aux.lsp @@ -0,0 +1,205 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Jan 21 05:11:31 2003 +;;;; Contains: Auxiliary functions for array tests + +(in-package :cl-test) + +(defun make-array-check-upgrading (type) + (subtypep* type (array-element-type (make-array 0 :element-type type)))) + +(defun subtypep-or-unknown (subtype supertype) + (multiple-value-bind* (is-subtype is-known) + (subtypep subtype supertype) + (or (not is-known) (notnot is-subtype)))) + +(defun make-array-with-checks (dimensions + &rest options + &key + (element-type t element-type-p) + (initial-contents nil initial-contents-p) + (initial-element nil initial-element-p) + (adjustable nil) + (fill-pointer nil) + (displaced-to nil) + (displaced-index-offset 0 dio-p) + &aux + (dimensions-list (if (listp dimensions) + dimensions + (list dimensions)))) + "Call MAKE-ARRAY and do sanity tests on the output." + (declare (ignore element-type-p initial-contents initial-contents-p + initial-element initial-element-p dio-p)) + (let ((a (check-values (apply #'make-array dimensions options))) + (rank (length dimensions-list))) + (cond + + ((not (typep a 'array)) + :fail-not-array) + ((not (typep a (find-class 'array))) + :fail-not-array-class) + ((not (typep a '(array *))) + :fail-not-array2) + ((not (typep a `(array * ,dimensions-list))) + :fail-not-array3) + ((not (typep a `(array * *))) + :fail-not-array4) + ((not (typep a `(array ,element-type))) + :fail-not-array5) + ((not (typep a `(array ,element-type *))) + :fail-not-array6) + + #-gcl + ((not (typep a `(array ,element-type ,rank))) + :fail-not-array7) + + ((not (typep a `(array ,element-type ,dimensions-list))) + :fail-not-array8) + + ((not (typep a `(array ,element-type ,(mapcar (constantly '*) + dimensions-list)))) + :fail-not-array9) + + ((loop for i from 0 below (min 10 rank) + thereis + (let ((x (append (subseq dimensions-list 0 i) + (list '*) + (subseq dimensions-list (1+ i))))) + (or (not (typep a `(array * ,x))) + (not (typep a `(array ,element-type ,x)))))) + :fail-not-array10) + + ((not (check-values (arrayp a))) :fail-not-arrayp) + + ((and ;; (eq t element-type) + (not adjustable) + (not fill-pointer) + (not displaced-to) + (cond + ((not (typep a 'simple-array)) + :fail-not-simple-array) + ((not (typep a '(simple-array *))) + :fail-not-simple-array2) + ((not (typep a `(simple-array * ,dimensions-list))) + :fail-not-simple-array3) + ((not (typep a `(simple-array * *))) + :fail-not-simple-array4) + ((not (typep a `(simple-array ,element-type))) + :fail-not-simple-array5) + ((not (typep a `(simple-array ,element-type *))) + :fail-not-simple-array6) + #-gcl + ((not (typep a `(simple-array ,element-type + ,rank))) + :fail-not-array7) + ((not (typep a `(simple-array ,element-type ,dimensions-list))) + :fail-not-simple-array8) + ((not (typep a `(simple-array ,element-type + ,(mapcar (constantly '*) + dimensions-list)))) + :fail-not-simple-array9) + ))) + + ;; If the array is a vector, check that... + ((and (eql rank 1) + (cond + ;; ...It's in type vector + ((not (typep a 'vector)) + :fail-not-vector) + ;; ...If the element type is a subtype of BIT, then it's a + ;; bit vector... + ((and (subtypep 'bit element-type) + (subtypep element-type 'bit) + (or (not (bit-vector-p a)) + (not (typep a 'bit-vector)))) + :fail-not-bit-vector) + ;; ...If not adjustable, fill pointered, or displaced, + ;; then it's a simple vector or simple bit vector + ;; (if the element-type is appropriate) + ((and (not adjustable) + (not fill-pointer) + (not displaced-to) + (cond + ((and (eq t element-type) + (or (not (simple-vector-p a)) + (not (typep a 'simple-vector)))) + :fail-not-simple-vector) + ((and (subtypep 'bit element-type) + (subtypep element-type 'bit) + (or (not (simple-bit-vector-p a)) + (not (typep a 'simple-bit-vector)))) + :fail-not-simple-bit-vector) ))) ))) + + ;; The dimensions of the array must be initialized properly + ((not (equal (array-dimensions a) dimensions-list)) + :fail-array-dimensions) + + ;; The rank of the array must equal the number of dimensions + ((not (equal (array-rank a) rank)) + :fail-array-rank) + + ;; Arrays other than vectors cannot have fill pointers + ((and (not (equal (array-rank a) 1)) + (array-has-fill-pointer-p a)) + :fail-non-vector-fill-pointer) + + ;; The actual element type must be a supertype of the element-type + ;; argument + ((not (subtypep-or-unknown element-type (array-element-type a))) + :failed-array-element-type) + + ;; If :adjustable is given, the array must be adjustable. + ((and adjustable + (not (check-values (adjustable-array-p a))) + :fail-adjustable)) + + ;; If :fill-pointer is given, the array must have a fill pointer + ((and fill-pointer + (not (check-values (array-has-fill-pointer-p a))) + :fail-has-fill-pointer)) + + ;; If the fill pointer is given as an integer, it must be the value + ;; of the fill pointer of the new array + ((and (check-values (integerp fill-pointer)) + (not (eql fill-pointer (check-values (fill-pointer a)))) + :fail-fill-pointer-1)) + + ;; If the fill-pointer argument is t, the fill pointer must be + ;; set to the vector size. + ((and (eq fill-pointer t) + (not (eql (first dimensions-list) (fill-pointer a))) + :fail-fill-pointer-2)) + + ;; If displaced-to another array, check that this is proper + ((and + displaced-to + (multiple-value-bind* (actual-dt actual-dio) + (array-displacement a) + (cond + ((not (eq actual-dt displaced-to)) + :fail-displacement-1) + ((not (eql actual-dio displaced-index-offset)) + :fail-displaced-index-offset))))) + + ;; Test of array-total-size + ((not (eql (check-values (array-total-size a)) + (reduce #'* dimensions-list :initial-value 1))) + :fail-array-total-size) + + ;; Test array-row-major-index on all zeros + ((and (> (array-total-size a) 0) + (not (eql (check-values + (apply #'array-row-major-index + a (make-list (array-rank a) :initial-element 0))) + 0))) + :fail-array-row-major-index-0) + + ;; For the last entry + ((and (> (array-total-size a) 0) + (not (eql (apply #'array-row-major-index + a (mapcar #'1- dimensions-list)) + (1- (reduce #'* dimensions-list :initial-value 1))))) + :fail-array-row-major-index-last) + + ;; No problems -- return the array + (t a)))) diff --git a/ansi-tests/array-dimension.lsp b/ansi-tests/array-dimension.lsp new file mode 100644 index 0000000..f6f4ee0 --- /dev/null +++ b/ansi-tests/array-dimension.lsp @@ -0,0 +1,63 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Jan 21 06:55:14 2003 +;;;; Contains: Tests of ARRAY-DIMENSION + +(in-package :cl-test) + +;;; array-dimension is also tested by the tests in make-array.lsp + +(deftest array-dimension.1 + (array-dimension #(0 1 2 3) 0) + 4) + +(deftest array-dimension.2 + (array-dimension "abcdef" 0) + 6) + +(deftest array-dimension.3 + (array-dimension #2a((1 2 3 4)(5 6 7 8)) 0) + 2) + +(deftest array-dimension.4 + (array-dimension #2a((1 2 3 4)(5 6 7 8)) 1) + 4) + +(deftest array-dimension.5 + (let ((a (make-array '(10) :fill-pointer 5))) + (array-dimension a 0)) + 10) + +(deftest array-dimension.6 + (let ((a (make-array '(10) :adjustable t))) + (values + (array-dimension a 0) + (progn + (adjust-array a '(20)) + (array-dimension a 0)))) + 10 20) + +(deftest array-dimension.order.1 + (let ((i 0) a b) + (values + (array-dimension (progn (setf a (incf i)) #(a b c d)) + (progn (setf b (incf i)) 0)) + i a b)) + 4 2 1 2) + +;;; Error tests + +(deftest array-dimension.error.1 + (classify-error (array-dimension)) + program-error) + +(deftest array-dimension.error.2 + (classify-error (array-dimension #(a b c))) + program-error) + +(deftest array-dimension.error.3 + (classify-error (array-dimension #(a b c) 0 nil)) + program-error) + + + diff --git a/ansi-tests/array-dimensions.lsp b/ansi-tests/array-dimensions.lsp new file mode 100644 index 0000000..5cdeb55 --- /dev/null +++ b/ansi-tests/array-dimensions.lsp @@ -0,0 +1,69 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Jan 21 06:59:37 2003 +;;;; Contains: Tests of ARRAY-DIMENSIONS + +(in-package :cl-test) + +;;; The tests in make-array.lsp also test this function + +(deftest array-dimensions.1 + (array-dimensions #0aX) + nil) + +(deftest array-dimensions.2 + (array-dimensions #(a b c d)) + (4)) + +(deftest array-dimensions.3 + (array-dimensions #*0011011011) + (10)) + +(deftest array-dimensions.4 + (array-dimensions "abcdef") + (6)) + +(deftest array-dimensions.5 + (array-dimensions #2a((1 2 3)(4 5 6)(7 8 9)(10 11 12))) + (4 3)) + +(deftest array-dimensions.6 + (let ((a (make-array '(2 3 4) :adjustable t))) + (values (array-dimension a 0) + (array-dimension a 1) + (array-dimension a 2))) + 2 3 4) + +(deftest array-dimensions.7 + (let ((a (make-array '(10) :fill-pointer 5))) + (array-dimension a 0)) + 10) + +;;; Error tests + +(deftest array-dimensions.error.1 + (classify-error (array-dimensions)) + program-error) + +(deftest array-dimensions.error.2 + (classify-error (array-dimensions #(a b c) nil)) + program-error) + +(deftest array-dimensions.error.3 + (let (why) + (loop for e in *mini-universe* + unless (or (typep e 'array) + (eq 'type-error + (setq why (classify-error** + `(array-dimensions ',e))))) + collect (list e why))) + nil) + +(deftest array-dimensions.error.4 + (classify-error (array-dimensions nil)) + type-error) + +(deftest array-dimensions.error.5 + (classify-error (locally (array-dimensions nil))) + type-error) + diff --git a/ansi-tests/array-displacement.lsp b/ansi-tests/array-displacement.lsp new file mode 100644 index 0000000..f1c34f2 --- /dev/null +++ b/ansi-tests/array-displacement.lsp @@ -0,0 +1,135 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Jan 21 06:20:51 2003 +;;;; Contains: Tests for ARRAY-DISPLACEMENT + +(in-package :cl-test) + +;;; The tests in make-array.lsp also test array-displacement + +;;; The standard is contradictory about whether arrays created with +;;; :displaced-to NIL should return NIL as their primary value or +;;; not. I will assume (as per Kent Pitman's comment on comp.lang.lisp) +;;; that an implementation is free to implement all arrays as actually +;;; displaced. Therefore, I've omitted all the tests of not-expressly +;;; displaced arrays. + +;;; Behavior on expressly displaced arrays + +(deftest array-displacement.7 + (let* ((a (make-array '(10))) + (b (make-array '(10) :displaced-to a))) + (multiple-value-bind* (dt disp) + (array-displacement b) + (and (eqt a dt) + (eqlt disp 0)))) + t) + +(deftest array-displacement.8 + (let* ((a (make-array '(10))) + (b (make-array '(5) :displaced-to a :displaced-index-offset 2))) + (multiple-value-bind* (dt disp) + (array-displacement b) + (and (eqt a dt) + (eqlt disp 2)))) + t) + +(deftest array-displacement.9 + (let* ((a (make-array '(10) :element-type 'base-char)) + (b (make-array '(5) :displaced-to a :displaced-index-offset 2 + :element-type 'base-char))) + (multiple-value-bind* (dt disp) + (array-displacement b) + (and (eqt a dt) + (eqlt disp 2)))) + t) + +(deftest array-displacement.10 + (let* ((a (make-array '(10) :element-type 'base-char)) + (b (make-array '(5) :displaced-to a + :element-type 'base-char))) + (multiple-value-bind* (dt disp) + (array-displacement b) + (and (eqt a dt) + (eqlt disp 0)))) + t) + +(deftest array-displacement.11 + (let* ((a (make-array '(10) :element-type 'bit)) + (b (make-array '(5) :displaced-to a :displaced-index-offset 2 + :element-type 'bit))) + (multiple-value-bind* (dt disp) + (array-displacement b) + (and (eqt a dt) + (eqlt disp 2)))) + t) + +(deftest array-displacement.12 + (let* ((a (make-array '(10) :element-type 'bit)) + (b (make-array '(5) :displaced-to a + :element-type 'bit))) + (multiple-value-bind* (dt disp) + (array-displacement b) + (and (eqt a dt) + (eqlt disp 0)))) + t) + +(deftest array-displacement.13 + (let* ((a (make-array '(10) :element-type '(integer 0 255))) + (b (make-array '(5) :displaced-to a :displaced-index-offset 2 + :element-type '(integer 0 255)))) + (multiple-value-bind* (dt disp) + (array-displacement b) + (and (eqt a dt) + (eqlt disp 2)))) + t) + +(deftest array-displacement.14 + (let* ((a (make-array '(10) :element-type '(integer 0 255))) + (b (make-array '(5) :displaced-to a + :element-type '(integer 0 255)))) + (multiple-value-bind* (dt disp) + (array-displacement b) + (and (eqt a dt) + (eqlt disp 0)))) + t) + +(deftest array-displacement.order.1 + (let* ((a (make-array '(10))) + (b (make-array '(10) :displaced-to a)) + (i 0)) + (multiple-value-bind* (dt disp) + (array-displacement (progn (incf i) b)) + (and (eql i 1) + (eqt a dt) + (eqlt disp 0)))) + t) + +;;; Error tests + +(deftest array-displacement.error.1 + (classify-error (array-displacement)) + program-error) + +(deftest array-displacement.error.2 + (classify-error (array-displacement #(a b c) nil)) + program-error) + +(deftest array-displacement.error.3 + (let (why) + (loop for e in *mini-universe* + unless (or (typep e 'array) + (eq 'type-error + (setq why (classify-error** + `(array-displacement ',e))))) + collect (list e why))) + nil) + +(deftest array-displacement.error.4 + (classify-error (array-displacement nil)) + type-error) + +(deftest array-displacement.error.5 + (classify-error (let ((x nil)) (array-displacement x))) + type-error) + diff --git a/ansi-tests/array-in-bounds-p.lsp b/ansi-tests/array-in-bounds-p.lsp new file mode 100644 index 0000000..26e9afc --- /dev/null +++ b/ansi-tests/array-in-bounds-p.lsp @@ -0,0 +1,152 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Jan 21 19:57:29 2003 +;;;; Contains: Tests for ARRAY-IN-BOUNDS-P + +(in-package :cl-test) + +(deftest array-in-bounds-p.1 + (array-in-bounds-p #() 0) + nil) + +(deftest array-in-bounds-p.2 + (array-in-bounds-p #() -1) + nil) + +(deftest array-in-bounds-p.3 + (let ((a #(a b c d))) + (loop for i from 0 to 4 collect (notnot (array-in-bounds-p a i)))) + (t t t t nil)) + +(deftest array-in-bounds-p.4 + (notnot (array-in-bounds-p #0aNIL)) + t) + +(deftest array-in-bounds-p.5 + (array-in-bounds-p "" 0) + nil) + +(deftest array-in-bounds-p.6 + (array-in-bounds-p "" -1) + nil) + +(deftest array-in-bounds-p.7 + (let ((a "abcd")) + (loop for i from 0 to 4 collect (notnot (array-in-bounds-p a i)))) + (t t t t nil)) + +(deftest array-in-bounds-p.8 + (array-in-bounds-p #* 0) + nil) + +(deftest array-in-bounds-p.9 + (array-in-bounds-p #* -1) + nil) + +(deftest array-in-bounds-p.10 + (let ((a #*0110)) + (loop for i from 0 to 4 collect (notnot (array-in-bounds-p a i)))) + (t t t t nil)) + +;; Fill pointer tests + +(deftest array-in-bounds-p.11 + (let ((a (make-array '(10) :fill-pointer 5))) + (loop for i from -1 to 10 collect (notnot (array-in-bounds-p a i)))) + (nil t t t t t t t t t t nil)) + +(deftest array-in-bounds-p.12 + (let ((a (make-array '(10) :fill-pointer 5 :element-type 'bit :initial-element 0))) + (loop for i from -1 to 10 collect (notnot (array-in-bounds-p a i)))) + (nil t t t t t t t t t t nil)) + +(deftest array-in-bounds-p.13 + (let ((a (make-array '(10) :fill-pointer 5 :element-type 'base-char :initial-element #\x))) + (loop for i from -1 to 10 collect (notnot (array-in-bounds-p a i)))) + (nil t t t t t t t t t t nil)) + +(deftest array-in-bounds-p.14 + (let ((a (make-array '(10) :fill-pointer 5 :element-type 'character :initial-element #\x))) + (loop for i from -1 to 10 collect (notnot (array-in-bounds-p a i)))) + (nil t t t t t t t t t t nil)) + +;;; Displaced arrays + +(deftest array-in-bounds-p.15 + (let* ((a1 (make-array '(20))) + (a2 (make-array '(10) :displaced-to a1))) + (loop for i from -1 to 10 collect (notnot (array-in-bounds-p a2 i)))) + (nil t t t t t t t t t t nil)) + +(deftest array-in-bounds-p.16 + (let* ((a1 (make-array '(20) :element-type 'bit :initial-element 0)) + (a2 (make-array '(10) :displaced-to a1 :element-type 'bit))) + (loop for i from -1 to 10 collect (notnot (array-in-bounds-p a2 i)))) + (nil t t t t t t t t t t nil)) + +(deftest array-in-bounds-p.17 + (let* ((a1 (make-array '(20) :element-type 'character :initial-element #\x)) + (a2 (make-array '(10) :displaced-to a1 :element-type 'character))) + (loop for i from -1 to 10 collect (notnot (array-in-bounds-p a2 i)))) + (nil t t t t t t t t t t nil)) + +;;; Multidimensional arrays + +(deftest array-in-bounds-p.18 + (let ((a (make-array '(3 4)))) + (loop for i from -1 to 3 collect + (loop for j from -1 to 4 collect + (notnot (array-in-bounds-p a i j))))) + ((nil nil nil nil nil nil) + (nil t t t t nil) + (nil t t t t nil) + (nil t t t t nil) + (nil nil nil nil nil nil))) + +(deftest array-in-bounds-p.19 + (let ((a (make-array '(1 3 4) :adjustable t))) + (loop for i from -1 to 3 collect + (loop for j from -1 to 4 collect + (notnot (array-in-bounds-p a 0 i j))))) + ((nil nil nil nil nil nil) + (nil t t t t nil) + (nil t t t t nil) + (nil t t t t nil) + (nil nil nil nil nil nil))) + +;;; Very large indices + +(deftest array-in-bounds-p.20 + (array-in-bounds-p #(a b c) (1+ most-positive-fixnum)) + nil) + +(deftest array-in-bounds-p.21 + (array-in-bounds-p #(a b c) (1- most-negative-fixnum)) + nil) + +(deftest array-in-bounds-p.22 + (array-in-bounds-p #(a b c) 1000000000000000000) + nil) + +(deftest array-in-bounds-p.23 + (array-in-bounds-p #(a b c) -1000000000000000000) + nil) + +;;; Order of evaluation tests + +(deftest array-in-bounds-p.order.1 + (let ((x 0) y z) + (values + (array-in-bounds-p (progn (setf y (incf x)) + #()) + (progn (setf z (incf x)) + 10)) + x y z)) + nil 2 1 2) + +;;; Error tests + +(deftest array-in-bounds-p.error.1 + (classify-error (array-in-bounds-p)) + program-error) + diff --git a/ansi-tests/array-misc.lsp b/ansi-tests/array-misc.lsp new file mode 100644 index 0000000..361b0a4 --- /dev/null +++ b/ansi-tests/array-misc.lsp @@ -0,0 +1,30 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Jan 22 21:17:25 2003 +;;;; Contains: Misc. tests of array features + +(in-package :cl-test) + +(deftest array-dimension-limit.1 + (and (<= 1024 array-dimension-limit) t) + t) + +(deftest array-dimension-limit.2 + (and (typep array-dimension-limit 'fixnum) t) + t) + +(deftest array-total-size-limit.1 + (and (<= 1024 array-total-size-limit) t) + t) + +(deftest array-total-size-limit.2 + (and (typep array-total-size-limit 'fixnum) t) + t) + +(deftest array-rank-limit.1 + (and (<= 8 array-rank-limit) t) + t) + +(deftest array-rank-limit.2 + (and (typep array-rank-limit 'fixnum) t) + t) diff --git a/ansi-tests/array-rank.lsp b/ansi-tests/array-rank.lsp new file mode 100644 index 0000000..b57d67f --- /dev/null +++ b/ansi-tests/array-rank.lsp @@ -0,0 +1,52 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Jan 21 20:32:57 2003 +;;;; Contains: Tests for ARRAY-RANK + +(in-package :cl-test) + +;;; Most tests for ARRAY-RANK are in make-array.lsp + +(deftest array-rank.1 + (array-rank #0aNIL) + 0) + +(deftest array-rank.2 + (loop for e in *universe* + when (and (typep e 'vector) + (not (eql (array-rank e) 1))) + collect e) + nil) + +(deftest array-rank.order.1 + (let ((i 0) a) + (values + (array-rank (progn (setf a (incf i)) "abcd")) + i a)) + 1 1 1) + +;;; Error tests + +(deftest array-rank.error.1 + (classify-error (array-rank)) + program-error) + +(deftest array-rank.error.2 + (classify-error (array-rank #(a b c) nil)) + program-error) + +(deftest array-rank.error.3 + (loop for e in *mini-universe* + when (and (not (typep e 'array)) + (not (eq (classify-error** `(array-rank ',e)) + 'type-error))) + collect e) + nil) + +(deftest array-rank.error.4 + (classify-error (array-rank nil)) + type-error) + +(deftest array-rank.error.5 + (classify-error (locally (array-rank nil) t)) + type-error) diff --git a/ansi-tests/array-row-major-index.lsp b/ansi-tests/array-row-major-index.lsp new file mode 100644 index 0000000..75f3352 --- /dev/null +++ b/ansi-tests/array-row-major-index.lsp @@ -0,0 +1,39 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Jan 21 21:37:03 2003 +;;;; Contains: Tests of ARRAY-ROW-MAJOR-INDEX + +(in-package :cl-test) + +;;; More array-row-major-index tests are in make-array.lsp + +(deftest array-row-major-index.1 + (array-row-major-index #0aNIL) + 0) + +(deftest array-row-major-index.2 + (loop for i from 0 to 4 + collect (array-row-major-index #(a b c d e) i)) + (0 1 2 3 4)) + +(deftest array-row-major-index.3 + (let ((a (make-array '(5) :fill-pointer 1))) + (loop for i from 0 to 4 + collect (array-row-major-index a i))) + (0 1 2 3 4)) + +(deftest array-row-major-index.order.1 + (let ((x 0) y z + (a #(a b c d e f))) + (values + (array-row-major-index + (progn (setf y (incf x)) a) + (progn (setf z (incf x)) 0)) + x y z)) + 0 2 1 2) + +;;; Error tests + +(deftest array-row-major-index.error.1 + (classify-error (array-row-major-index)) + program-error) diff --git a/ansi-tests/array-t.lsp b/ansi-tests/array-t.lsp new file mode 100644 index 0000000..c6aa154 --- /dev/null +++ b/ansi-tests/array-t.lsp @@ -0,0 +1,275 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Jan 25 11:55:48 2003 +;;;; Contains: Tests of (array t ...) type specifiers + +(in-package :cl-test) + +;;; Tests of (array t) + +(deftest array-t.2.1 + (notnot-mv (typep #() '(array t))) + t) + +(deftest array-t.2.2 + (notnot-mv (typep #0aX '(array t))) + t) + +(deftest array-t.2.3 + (notnot-mv (typep #2a(()) '(array t))) + t) + +(deftest array-t.2.4 + (notnot-mv (typep #(1 2 3) '(array t))) + t) + +(deftest array-t.2.5 + (typep "abcd" '(array t)) + nil) + +(deftest array-t.2.6 + (typep #*010101 '(array t)) + nil) + +;;; Tests of (array t ()) + +(deftest array-t.3.1 + (notnot-mv (typep #() '(array t nil))) + nil) + +(deftest array-t.3.2 + (notnot-mv (typep #0aX '(array t nil))) + t) + +(deftest array-t.3.3 + (typep #2a(()) '(array t nil)) + nil) + +(deftest array-t.3.4 + (typep #(1 2 3) '(array t nil)) + nil) + +(deftest array-t.3.5 + (typep "abcd" '(array t nil)) + nil) + +(deftest array-t.3.6 + (typep #*010101 '(array t nil)) + nil) + +;;; Tests of (array t 1) +;;; The '1' indicates rank, so this is equivalent to 'vector' + +(deftest array-t.4.1 + (notnot-mv (typep #() '(array t 1))) + t) + +(deftest array-t.4.2 + (typep #0aX '(array t 1)) + nil) + +(deftest array-t.4.3 + (typep #2a(()) '(array t 1)) + nil) + +(deftest array-t.4.4 + (notnot-mv (typep #(1 2 3) '(array t 1))) + t) + +(deftest array-t.4.5 + (typep "abcd" '(array t 1)) + nil) + +(deftest array-t.4.6 + (typep #*010101 '(array t 1)) + nil) + +;;; Tests of (array t 0) + +(deftest array-t.5.1 + (typep #() '(array t 0)) + nil) + +(deftest array-t.5.2 + (notnot-mv (typep #0aX '(array t 0))) + t) + +(deftest array-t.5.3 + (typep #2a(()) '(array t 0)) + nil) + +(deftest array-t.5.4 + (typep #(1 2 3) '(array t 0)) + nil) + +(deftest array-t.5.5 + (typep "abcd" '(array t 0)) + nil) + +(deftest array-t.5.6 + (typep #*010101 '(array t 0)) + nil) + +;;; Tests of (array t *) + +(deftest array-t.6.1 + (notnot-mv (typep #() '(array t *))) + t) + +(deftest array-t.6.2 + (notnot-mv (typep #0aX '(array t *))) + t) + +(deftest array-t.6.3 + (notnot-mv (typep #2a(()) '(array t *))) + t) + +(deftest array-t.6.4 + (notnot-mv (typep #(1 2 3) '(array t *))) + t) + +(deftest array-t.6.5 + (typep "abcd" '(array t *)) + nil) + +(deftest array-t.6.6 + (typep #*010101 '(array t *)) + nil) + +;;; Tests of (array t 2) + +(deftest array-t.7.1 + (typep #() '(array t 2)) + nil) + +(deftest array-t.7.2 + (typep #0aX '(array t 2)) + nil) + +(deftest array-t.7.3 + (notnot-mv (typep #2a(()) '(array t 2))) + t) + +(deftest array-t.7.4 + (typep #(1 2 3) '(array t 2)) + nil) + +(deftest array-t.7.5 + (typep "abcd" '(array t 2)) + nil) + +(deftest array-t.7.6 + (typep #*010101 '(array t 2)) + nil) + +;;; Testing '(array t (--)) + +(deftest array-t.8.1 + (typep #() '(array t (1))) + nil) + +(deftest array-t.8.2 + (notnot-mv (typep #() '(array t (0)))) + t) + +(deftest array-t.8.3 + (notnot-mv (typep #() '(array t (*)))) + t) + +(deftest array-t.8.4 + (typep #(a b c) '(array t (2))) + nil) + +(deftest array-t.8.5 + (notnot-mv (typep #(a b c) '(array t (3)))) + t) + +(deftest array-t.8.6 + (notnot-mv (typep #(a b c) '(array t (*)))) + t) + +(deftest array-t.8.7 + (typep #(a b c) '(array t (4))) + nil) + +(deftest array-t.8.8 + (typep #2a((a b c)) '(array t (*))) + nil) + +(deftest array-t.8.9 + (typep #2a((a b c)) '(array t (3))) + nil) + +(deftest array-t.8.10 + (typep #2a((a b c)) '(array t (1))) + nil) + +(deftest array-t.8.11 + (typep "abc" '(array t (2))) + nil) + +(deftest array-t.8.12 + (typep "abc" '(array t (3))) + nil) + +(deftest array-t.8.13 + (typep "abc" '(array t (*))) + nil) + +(deftest array-t.8.14 + (typep "abc" '(array t (4))) + nil) + +;;; Two dimensional array type tests + +(deftest array-t.9.1 + (typep #() '(array t (* *))) + nil) + +(deftest array-t.9.2 + (typep "abc" '(array t (* *))) + nil) + +(deftest array-t.9.3 + (typep #(a b c) '(array t (3 *))) + nil) + +(deftest array-t.9.4 + (typep #(a b c) '(array t (* 3))) + nil) + +(deftest array-t.9.5 + (typep "abc" '(array t (3 *))) + nil) + +(deftest array-t.9.6 + (typep "abc" '(array t (* 3))) + nil) + +(deftest array-t.9.7 + (notnot-mv (typep #2a((a b)(c d)(e f)) '(array t (* *)))) + t) + +(deftest array-t.9.8 + (notnot-mv (typep #2a((a b)(c d)(e f)) '(array t (3 *)))) + t) + +(deftest array-t.9.9 + (typep #2a((a b)(c d)(e f)) '(array t (2 *))) + nil) + +(deftest array-t.9.10 + (notnot-mv (typep #2a((a b)(c d)(e f)) '(array t (* 2)))) + t) + +(deftest array-t.9.11 + (typep #2a((a b)(c d)(e f)) '(array t (* 3))) + nil) + +(deftest array-t.9.12 + (notnot-mv (typep #2a((a b)(c d)(e f)) '(array t (3 2)))) + t) + +(deftest array-t.9.13 + (typep #2a((a b)(c d)(e f)) '(array t (2 3))) + nil) diff --git a/ansi-tests/array-total-size.lsp b/ansi-tests/array-total-size.lsp new file mode 100644 index 0000000..7f05c2d --- /dev/null +++ b/ansi-tests/array-total-size.lsp @@ -0,0 +1,63 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Jan 21 22:01:09 2003 +;;;; Contains: Tests of ARRAY-TOTAL-SIZE + +(in-package :cl-test) + +;;; More tests of ARRAY-TOTAL-SIZE are in make-array.lsp + +(deftest array-total-size.1 + (array-total-size #0aNIL) + 1) + +(deftest array-total-size.2 + (array-total-size "abcdef") + 6) + +(deftest array-total-size.3 + (array-total-size #(a b c)) + 3) + +(deftest array-total-size.4 + (array-total-size #*0011010) + 7) + +(deftest array-total-size.5 + (array-total-size #2a((1 2 3)(4 5 6)(7 8 9)(a b c))) + 12) + +(deftest array-total-size.order.1 + (let ((i 0) a) + (values + (array-total-size (progn (setf a (incf i)) #(a b c d))) + i a)) + 4 1 1) + +;;; Error tests + +(deftest array-total-size.error.1 + (classify-error (array-total-size)) + program-error) + +(deftest array-total-size.error.2 + (classify-error (array-total-size #(a b c) nil)) + program-error) + +(deftest array-total-size.error.3 + (let (why) + (loop for e in *mini-universe* + when (and (not (typep e 'array)) + (not (eql (setq why + (classify-error** `(array-total-size ',e))) + 'type-error))) + collect (list e why))) + nil) + +(deftest array-total-size.error.4 + (classify-error (array-total-size 0)) + type-error) + +(deftest array-total-size.error.5 + (classify-error (locally (array-total-size 0) t)) + type-error) diff --git a/ansi-tests/array.lsp b/ansi-tests/array.lsp new file mode 100644 index 0000000..11bfae7 --- /dev/null +++ b/ansi-tests/array.lsp @@ -0,0 +1,330 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Jan 25 08:46:58 2003 +;;;; Contains: Tests of the ARRAY type specifier + +(in-package :cl-test) + +;;; Tests of array by itself + +(deftest array.1.1 + (notnot-mv (typep #() 'array)) + t) + +(deftest array.1.2 + (notnot-mv (typep #0aX 'array)) + t) + +(deftest array.1.3 + (notnot-mv (typep #2a(()) 'array)) + t) + +(deftest array.1.4 + (notnot-mv (typep #(1 2 3) 'array)) + t) + +(deftest array.1.5 + (notnot-mv (typep "abcd" 'array)) + t) + +(deftest array.1.6 + (notnot-mv (typep #*010101 'array)) + t) + +(deftest array.1.7 + (typep nil 'array) + nil) + +(deftest array.1.8 + (typep 'x 'array) + nil) + +(deftest array.1.9 + (typep '(a b c) 'array) + nil) + +(deftest array.1.10 + (typep 10.0 'array) + nil) + +(deftest array.1.11 + (typep #'(lambda (x) (cons x nil)) 'array) + nil) + +(deftest array.1.12 + (typep 1 'array) + nil) + +(deftest array.1.13 + (typep (1+ most-positive-fixnum) 'array) + nil) + + +;;; Tests of (array *) + +(deftest array.2.1 + (notnot-mv (typep #() '(array *))) + t) + +(deftest array.2.2 + (notnot-mv (typep #0aX '(array *))) + t) + +(deftest array.2.3 + (notnot-mv (typep #2a(()) '(array *))) + t) + +(deftest array.2.4 + (notnot-mv (typep #(1 2 3) '(array *))) + t) + +(deftest array.2.5 + (notnot-mv (typep "abcd" '(array *))) + t) + +(deftest array.2.6 + (notnot-mv (typep #*010101 '(array *))) + t) + +;;; Tests of (array * ()) + +(deftest array.3.1 + (notnot-mv (typep #() '(array * nil))) + nil) + +(deftest array.3.2 + (notnot-mv (typep #0aX '(array * nil))) + t) + +(deftest array.3.3 + (typep #2a(()) '(array * nil)) + nil) + +(deftest array.3.4 + (typep #(1 2 3) '(array * nil)) + nil) + +(deftest array.3.5 + (typep "abcd" '(array * nil)) + nil) + +(deftest array.3.6 + (typep #*010101 '(array * nil)) + nil) + +;;; Tests of (array * 1) +;;; The '1' indicates rank, so this is equivalent to 'vector' + +(deftest array.4.1 + (notnot-mv (typep #() '(array * 1))) + t) + +(deftest array.4.2 + (typep #0aX '(array * 1)) + nil) + +(deftest array.4.3 + (typep #2a(()) '(array * 1)) + nil) + +(deftest array.4.4 + (notnot-mv (typep #(1 2 3) '(array * 1))) + t) + +(deftest array.4.5 + (notnot-mv (typep "abcd" '(array * 1))) + t) + +(deftest array.4.6 + (notnot-mv (typep #*010101 '(array * 1))) + t) + +;;; Tests of (array * 0) + +(deftest array.5.1 + (typep #() '(array * 0)) + nil) + +(deftest array.5.2 + (notnot-mv (typep #0aX '(array * 0))) + t) + +(deftest array.5.3 + (typep #2a(()) '(array * 0)) + nil) + +(deftest array.5.4 + (typep #(1 2 3) '(array * 0)) + nil) + +(deftest array.5.5 + (typep "abcd" '(array * 0)) + nil) + +(deftest array.5.6 + (typep #*010101 '(array * 0)) + nil) + +;;; Tests of (array * *) + +(deftest array.6.1 + (notnot-mv (typep #() '(array * *))) + t) + +(deftest array.6.2 + (notnot-mv (typep #0aX '(array * *))) + t) + +(deftest array.6.3 + (notnot-mv (typep #2a(()) '(array * *))) + t) + +(deftest array.6.4 + (notnot-mv (typep #(1 2 3) '(array * *))) + t) + +(deftest array.6.5 + (notnot-mv (typep "abcd" '(array * *))) + t) + +(deftest array.6.6 + (notnot-mv (typep #*010101 '(array * *))) + t) + +;;; Tests of (array * 2) + +(deftest array.7.1 + (typep #() '(array * 2)) + nil) + +(deftest array.7.2 + (typep #0aX '(array * 2)) + nil) + +(deftest array.7.3 + (notnot-mv (typep #2a(()) '(array * 2))) + t) + +(deftest array.7.4 + (typep #(1 2 3) '(array * 2)) + nil) + +(deftest array.7.5 + (typep "abcd" '(array * 2)) + nil) + +(deftest array.7.6 + (typep #*010101 '(array * 2)) + nil) + +;;; Testing '(array * (--)) + +(deftest array.8.1 + (typep #() '(array * (1))) + nil) + +(deftest array.8.2 + (notnot-mv (typep #() '(array * (0)))) + t) + +(deftest array.8.3 + (notnot-mv (typep #() '(array * (*)))) + t) + +(deftest array.8.4 + (typep #(a b c) '(array * (2))) + nil) + +(deftest array.8.5 + (notnot-mv (typep #(a b c) '(array * (3)))) + t) + +(deftest array.8.6 + (notnot-mv (typep #(a b c) '(array * (*)))) + t) + +(deftest array.8.7 + (typep #(a b c) '(array * (4))) + nil) + +(deftest array.8.8 + (typep #2a((a b c)) '(array * (*))) + nil) + +(deftest array.8.9 + (typep #2a((a b c)) '(array * (3))) + nil) + +(deftest array.8.10 + (typep #2a((a b c)) '(array * (1))) + nil) + +(deftest array.8.11 + (typep "abc" '(array * (2))) + nil) + +(deftest array.8.12 + (notnot-mv (typep "abc" '(array * (3)))) + t) + +(deftest array.8.13 + (notnot-mv (typep "abc" '(array * (*)))) + t) + +(deftest array.8.14 + (typep "abc" '(array * (4))) + nil) + +;;; Two dimensional array type tests + +(deftest array.9.1 + (typep #() '(array * (* *))) + nil) + +(deftest array.9.2 + (typep "abc" '(array * (* *))) + nil) + +(deftest array.9.3 + (typep #(a b c) '(array * (3 *))) + nil) + +(deftest array.9.4 + (typep #(a b c) '(array * (* 3))) + nil) + +(deftest array.9.5 + (typep "abc" '(array * (3 *))) + nil) + +(deftest array.9.6 + (typep "abc" '(array * (* 3))) + nil) + +(deftest array.9.7 + (notnot-mv (typep #2a((a b)(c d)(e f)) '(array * (* *)))) + t) + +(deftest array.9.8 + (notnot-mv (typep #2a((a b)(c d)(e f)) '(array * (3 *)))) + t) + +(deftest array.9.9 + (typep #2a((a b)(c d)(e f)) '(array * (2 *))) + nil) + +(deftest array.9.10 + (notnot-mv (typep #2a((a b)(c d)(e f)) '(array * (* 2)))) + t) + +(deftest array.9.11 + (typep #2a((a b)(c d)(e f)) '(array * (* 3))) + nil) + +(deftest array.9.12 + (notnot-mv (typep #2a((a b)(c d)(e f)) '(array * (3 2)))) + t) + +(deftest array.9.13 + (typep #2a((a b)(c d)(e f)) '(array * (2 3))) + nil) diff --git a/ansi-tests/arrayp.lsp b/ansi-tests/arrayp.lsp new file mode 100644 index 0000000..4f46dd0 --- /dev/null +++ b/ansi-tests/arrayp.lsp @@ -0,0 +1,57 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Jan 21 22:08:21 2003 +;;;; Contains: Tests of ARRAYP + +(in-package :cl-test) + +;;; Also tested by make-array.lsp + +(deftest arrayp.1 + (notnot-mv (arrayp #(a b c))) + t) + +(deftest arrayp.2 + (notnot-mv (arrayp "abcd")) + t) + +(deftest arrayp.3 + (notnot-mv (arrayp #*001110101)) + t) + +(deftest arrayp.4 + (notnot-mv (arrayp #0aNIL)) + t) + +(deftest arrayp.5 + (notnot-mv (arrayp #2a((1 2 3)(4 5 6)))) + t) + +(deftest arrayp.6 + (loop for e in *universe* + for a = (arrayp e) + for b = (typep e 'array) + when (or (and a (not b)) + (and b (not a))) + collect e) + nil) + +(deftest arrayp.order.1 + (let ((i 0) a) + (values + (arrayp (progn (setf a (incf i)) nil)) + i a)) + nil 1 1) + +;;; Error tests + +(deftest arrayp.error.1 + (classify-error (arrayp)) + program-error) + +(deftest arrayp.error.2 + (classify-error (arrayp #(a b c) nil)) + program-error) + + + diff --git a/ansi-tests/assert.lsp b/ansi-tests/assert.lsp new file mode 100644 index 0000000..4d90b0a --- /dev/null +++ b/ansi-tests/assert.lsp @@ -0,0 +1,90 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Jan 28 06:48:19 2003 +;;;; Contains: Tests of ASSERT + +(in-package :cl-test) + +(deftest assert.1 + (assert t) + nil) + +(deftest assert.2 + (assert t ()) + nil) + +;;; I am assuming that when no places are given to ASSERT, +;;; it doesn't invoke any interactive handler. + +(deftest assert.3 + (let ((x nil)) + (handler-bind + ((error #'(lambda (c) + (setq x 17) + (let ((r (find-restart 'continue c))) + (when r (invoke-restart r)))))) + (assert x) + x)) + 17) + +(deftest assert.3a + (let ((x nil)) + (handler-bind + ((error #'(lambda (c) + (setq x 17) + (continue c)))) + (assert x) + x)) + 17) + + +;;; I don't yet know how to test the interactive version of ASSERT +;;; that is normally invoked when places are given. + +;;; Tests of the syntax (at least) + +(deftest assert.4 + (let (x) + (assert t (x))) + nil) + +(deftest assert.5 + (let ((x (cons 'a 'b))) + (assert t ((car x) (cdr x)))) + nil) + +(deftest assert.6 + (let ((x (vector 'a 'b 'c))) + (assert t ((aref x 0) (aref x 1) (aref x 2)) + "Vector x has value: ~A." x)) + nil) + +(deftest assert.7 + (let ((x nil)) + (handler-bind + ((simple-error #'(lambda (c) + (setq x 17) + (continue c)))) + (assert x () 'simple-error) + x)) + 17) + +(deftest assert.8 + (let ((x 0)) + (handler-bind + ((type-error #'(lambda (c) + (incf x) + (continue c)))) + (assert (> x 5) () 'type-error) + x)) + 6) + +(deftest assert.9 + (let ((x 0)) + (handler-bind + ((type-error #'(lambda (c) (declare (ignore c)) + (incf x) + (continue)))) + (assert (> x 5) () 'type-error) + x)) + 6) diff --git a/ansi-tests/atom-errors.lsp b/ansi-tests/atom-errors.lsp new file mode 100644 index 0000000..874fae2 --- /dev/null +++ b/ansi-tests/atom-errors.lsp @@ -0,0 +1,39 @@ +(setf x + (loop + for tp in '(CONDITION +SERIOUS-CONDITION +ERROR +TYPE-ERROR +SIMPLE-TYPE-ERROR +SIMPLE-CONDITION +PARSE-ERROR +CELL-ERROR +UNBOUND-SLOT +WARNING +STYLE-WARNING +STORAGE-CONDITION +SIMPLE-WARNING +UNBOUND-VARIABLE +CONTROL-ERROR +PROGRAM-ERROR +UNDEFINED-FUNCTION +PACKAGE-ERROR +ARITHMETIC-ERROR +DIVISION-BY-ZERO +FLOATING-POINT-INVALID-OPERATION +FLOATING-POINT-INEXACT +FLOATING-POINT-OVERFLOW +FLOATING-POINT-UNDERFLOW +FILE-ERROR +BROADCAST-STREAM +CONCATENATED-STREAM +ECHO-STREAM +FILE-STREAM +STRING-STREAM +SYNONYM-STREAM +TWO-WAY-STREAM +STREAM-ERROR +END-OF-FILE +PRINT-NOT-READABLE + READER-ERROR) + collect (list tp (multiple-value-list (subtypep* tp 'atom))))) diff --git a/ansi-tests/bit-and.lsp b/ansi-tests/bit-and.lsp new file mode 100644 index 0000000..0b62bb3 --- /dev/null +++ b/ansi-tests/bit-and.lsp @@ -0,0 +1,243 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Jan 26 18:18:47 2003 +;;;; Contains: Tests of BIT-AND + +(in-package :cl-test) + +(deftest bit-and.1 + (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (values (bit-and s1 s2) s1 s2)) + #0a0 + #0a0 + #0a0) + +(deftest bit-and.2 + (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (values (bit-and s1 s2) s1 s2)) + #0a0 + #0a1 + #0a0) + +(deftest bit-and.3 + (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (values (bit-and s1 s2) s1 s2)) + #0a0 + #0a0 + #0a1) + +(deftest bit-and.4 + (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (values (bit-and s1 s2) s1 s2)) + #0a1 + #0a1 + #0a1) + +(deftest bit-and.5 + (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) + (s2 (make-array nil :initial-element 0 :element-type 'bit)) + (s3 (make-array nil :initial-element 1 :element-type 'bit)) + (result (bit-and s1 s2 s3))) + (values s1 s2 s3 result (eqt s3 result))) + #0a0 + #0a0 + #0a0 + #0a0 + t) + +(deftest bit-and.6 + (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) + (s2 (make-array nil :initial-element 1 :element-type 'bit)) + (s3 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-and s1 s2 s3))) + (values s1 s2 s3 result (eqt s3 result))) + #0a1 + #0a1 + #0a1 + #0a1 + t) + +(deftest bit-and.7 + (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) + (s2 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-and s1 s2 t))) + (values s1 s2 result (eqt s1 result))) + #0a0 + #0a0 + #0a0 + t) + + +;;; Tests on bit vectors + +(deftest bit-and.8 + (let ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101))) + (values (check-values (bit-and a1 a2)) a1 a2)) + #*0001 #*0011 #*0101) + +(deftest bit-and.9 + (let* ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101)) + (result (check-values (bit-and a1 a2 t)))) + (values result a1 a2 (eqt result a1))) + #*0001 #*0001 #*0101 t) + +(deftest bit-and.10 + (let* ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101)) + (a3 (copy-seq #*1110)) + (result (check-values (bit-and a1 a2 a3)))) + (values result a1 a2 a3 (eqt result a3))) + #*0001 #*0011 #*0101 #*0001 t) + +(deftest bit-and.11 + (let ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101))) + (values (check-values (bit-and a1 a2 nil)) a1 a2)) + #*0001 #*0011 #*0101) + +;;; Tests on bit arrays + +(deftest bit-and.12 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-and a1 a2))) + (values a1 a2 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((0 0)(0 1))) + +(deftest bit-and.13 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-and a1 a2 t))) + (values a1 a2 result)) + #2a((0 0)(0 1)) + #2a((0 0)(1 1)) + #2a((0 0)(0 1))) + +(deftest bit-and.14 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-and a1 a2 nil))) + (values a1 a2 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((0 0)(0 1))) + +(deftest bit-and.15 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (a3 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(0 0)))) + (result (bit-and a1 a2 a3))) + (values a1 a2 a3 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((0 0)(0 1)) + #2a((0 0)(0 1))) + +;;; Adjustable arrays + +(deftest bit-and.16 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)) + :adjustable t)) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)) + :adjustable t)) + (result (bit-and a1 a2))) + (values a1 a2 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((0 0)(0 1))) + +;;; Displaced arrays + +(deftest bit-and.17 + (let* ((a0 (make-array '(8) :element-type 'bit + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-and a1 a2))) + (values a0 a1 a2 result)) + #*01010011 + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((0 0)(0 1))) + +(deftest bit-and.18 + (let* ((a0 (make-array '(8) :element-type 'bit + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-and a1 a2 t))) + (values a0 a1 a2 result)) + #*00010011 + #2a((0 0)(0 1)) + #2a((0 0)(1 1)) + #2a((0 0)(0 1))) + +(deftest bit-and.19 + (let* ((a0 (make-array '(12) :element-type 'bit + :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (a3 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 8)) + (result (bit-and a1 a2 a3))) + (values a0 a1 a2 result)) + #*010100110001 + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((0 0)(0 1))) + +(deftest bit-and.order.1 + (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) + (s2 (make-array 1 :initial-element 0 :element-type 'bit)) + (x 0) y z) + (values + (bit-and (progn (setf y (incf x)) s1) + (progn (setf z (incf x)) s2)) + x y z)) + #*0 2 1 2) + +;;; Error tests + +(deftest bit-and.error.1 + (classify-error (bit-and)) + program-error) + +(deftest bit-and.error.2 + (classify-error (bit-and #*000)) + program-error) + +(deftest bit-and.error.3 + (classify-error (bit-and #*000 #*0100 nil nil)) + program-error) diff --git a/ansi-tests/bit-andc1.lsp b/ansi-tests/bit-andc1.lsp new file mode 100644 index 0000000..5597ad1 --- /dev/null +++ b/ansi-tests/bit-andc1.lsp @@ -0,0 +1,243 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Jan 26 18:56:39 2003 +;;;; Contains: Tests of BIT-ANDC1 + +(in-package :cl-test) + +(deftest bit-andc1.1 + (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (values (bit-andc1 s1 s2) s1 s2)) + #0a0 + #0a0 + #0a0) + +(deftest bit-andc1.2 + (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (values (bit-andc1 s1 s2) s1 s2)) + #0a0 + #0a1 + #0a0) + +(deftest bit-andc1.3 + (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (values (bit-andc1 s1 s2) s1 s2)) + #0a1 + #0a0 + #0a1) + +(deftest bit-andc1.4 + (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (values (bit-andc1 s1 s2) s1 s2)) + #0a0 + #0a1 + #0a1) + +(deftest bit-andc1.5 + (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) + (s2 (make-array nil :initial-element 0 :element-type 'bit)) + (s3 (make-array nil :initial-element 1 :element-type 'bit)) + (result (bit-andc1 s1 s2 s3))) + (values s1 s2 s3 result (eqt s3 result))) + #0a0 + #0a0 + #0a0 + #0a0 + t) + +(deftest bit-andc1.6 + (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) + (s2 (make-array nil :initial-element 1 :element-type 'bit)) + (s3 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-andc1 s1 s2 s3))) + (values s1 s2 s3 result (eqt s3 result))) + #0a0 + #0a1 + #0a1 + #0a1 + t) + +(deftest bit-andc1.7 + (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) + (s2 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-andc1 s1 s2 t))) + (values s1 s2 result (eqt s1 result))) + #0a0 + #0a0 + #0a0 + t) + + +;;; Tests on bit vectors + +(deftest bit-andc1.8 + (let ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101))) + (values (check-values (bit-andc1 a1 a2)) a1 a2)) + #*0100 #*0011 #*0101) + +(deftest bit-andc1.9 + (let* ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101)) + (result (check-values (bit-andc1 a1 a2 t)))) + (values result a1 a2 (eqt result a1))) + #*0100 #*0100 #*0101 t) + +(deftest bit-andc1.10 + (let* ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101)) + (a3 (copy-seq #*0000)) + (result (check-values (bit-andc1 a1 a2 a3)))) + (values result a1 a2 a3 (eqt result a3))) + #*0100 #*0011 #*0101 #*0100 t) + +(deftest bit-andc1.11 + (let ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101))) + (values (check-values (bit-andc1 a1 a2 nil)) a1 a2)) + #*0100 #*0011 #*0101) + +;;; Tests on bit arrays + +(deftest bit-andc1.12 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-andc1 a1 a2))) + (values a1 a2 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((0 0)(1 0))) + +(deftest bit-andc1.13 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-andc1 a1 a2 t))) + (values a1 a2 result)) + #2a((0 0)(1 0)) + #2a((0 0)(1 1)) + #2a((0 0)(1 0))) + +(deftest bit-andc1.14 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-andc1 a1 a2 nil))) + (values a1 a2 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((0 0)(1 0))) + +(deftest bit-andc1.15 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (a3 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(0 0)))) + (result (bit-andc1 a1 a2 a3))) + (values a1 a2 a3 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((0 0)(1 0)) + #2a((0 0)(1 0))) + +;;; Adjustable arrays + +(deftest bit-andc1.16 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)) + :adjustable t)) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)) + :adjustable t)) + (result (bit-andc1 a1 a2))) + (values a1 a2 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((0 0)(1 0))) + +;;; Displaced arrays + +(deftest bit-andc1.17 + (let* ((a0 (make-array '(8) :element-type 'bit + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-andc1 a1 a2))) + (values a0 a1 a2 result)) + #*01010011 + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((0 0)(1 0))) + +(deftest bit-andc1.18 + (let* ((a0 (make-array '(8) :element-type 'bit + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-andc1 a1 a2 t))) + (values a0 a1 a2 result)) + #*00100011 + #2a((0 0)(1 0)) + #2a((0 0)(1 1)) + #2a((0 0)(1 0))) + +(deftest bit-andc1.19 + (let* ((a0 (make-array '(12) :element-type 'bit + :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (a3 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 8)) + (result (bit-andc1 a1 a2 a3))) + (values a0 a1 a2 result)) + #*010100110010 + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((0 0)(1 0))) + +(deftest bit-andc1.order.1 + (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) + (s2 (make-array 1 :initial-element 0 :element-type 'bit)) + (x 0) y z) + (values + (bit-andc1 (progn (setf y (incf x)) s1) + (progn (setf z (incf x)) s2)) + x y z)) + #*0 2 1 2) + +;;; Error tests + +(deftest bit-andc1.error.1 + (classify-error (bit-andc1)) + program-error) + +(deftest bit-andc1.error.2 + (classify-error (bit-andc1 #*000)) + program-error) + +(deftest bit-andc1.error.3 + (classify-error (bit-andc1 #*000 #*0100 nil nil)) + program-error) diff --git a/ansi-tests/bit-andc2.lsp b/ansi-tests/bit-andc2.lsp new file mode 100644 index 0000000..b61cbf7 --- /dev/null +++ b/ansi-tests/bit-andc2.lsp @@ -0,0 +1,244 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Jan 26 19:01:38 2003 +;;;; Contains: Tests of BIT-ANDC2 + +(in-package :cl-test) + +(deftest bit-andc2.1 + (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (values (bit-andc2 s1 s2) s1 s2)) + #0a0 + #0a0 + #0a0) + +(deftest bit-andc2.2 + (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (values (bit-andc2 s1 s2) s1 s2)) + #0a1 + #0a1 + #0a0) + +(deftest bit-andc2.3 + (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (values (bit-andc2 s1 s2) s1 s2)) + #0a0 + #0a0 + #0a1) + +(deftest bit-andc2.4 + (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (values (bit-andc2 s1 s2) s1 s2)) + #0a0 + #0a1 + #0a1) + +(deftest bit-andc2.5 + (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) + (s2 (make-array nil :initial-element 0 :element-type 'bit)) + (s3 (make-array nil :initial-element 1 :element-type 'bit)) + (result (bit-andc2 s1 s2 s3))) + (values s1 s2 s3 result (eqt s3 result))) + #0a0 + #0a0 + #0a0 + #0a0 + t) + +(deftest bit-andc2.6 + (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) + (s2 (make-array nil :initial-element 0 :element-type 'bit)) + (s3 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-andc2 s1 s2 s3))) + (values s1 s2 s3 result (eqt s3 result))) + #0a1 + #0a0 + #0a1 + #0a1 + t) + +(deftest bit-andc2.7 + (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) + (s2 (make-array nil :initial-element 1 :element-type 'bit)) + (result (bit-andc2 s1 s2 t))) + (values s1 s2 result (eqt s1 result))) + #0a0 + #0a1 + #0a0 + t) + + +;;; Tests on bit vectors + +(deftest bit-andc2.8 + (let ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101))) + (values (check-values (bit-andc2 a1 a2)) a1 a2)) + #*0010 #*0011 #*0101) + +(deftest bit-andc2.9 + (let* ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101)) + (result (check-values (bit-andc2 a1 a2 t)))) + (values result a1 a2 (eqt result a1))) + #*0010 #*0010 #*0101 t) + +(deftest bit-andc2.10 + (let* ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101)) + (a3 (copy-seq #*1110)) + (result (check-values (bit-andc2 a1 a2 a3)))) + (values result a1 a2 a3 (eqt result a3))) + #*0010 #*0011 #*0101 #*0010 t) + +(deftest bit-andc2.11 + (let ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101))) + (values (check-values (bit-andc2 a1 a2 nil)) a1 a2)) + #*0010 #*0011 #*0101) + +;;; Tests on bit arrays + +(deftest bit-andc2.12 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-andc2 a1 a2))) + (values a1 a2 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((0 1)(0 0))) + +(deftest bit-andc2.13 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-andc2 a1 a2 t))) + (values a1 a2 result)) + #2a((0 1)(0 0)) + #2a((0 0)(1 1)) + #2a((0 1)(0 0))) + +(deftest bit-andc2.14 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-andc2 a1 a2 nil))) + (values a1 a2 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((0 1)(0 0))) + +(deftest bit-andc2.15 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (a3 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(0 0)))) + (result (bit-andc2 a1 a2 a3))) + (values a1 a2 a3 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((0 1)(0 0)) + #2a((0 1)(0 0))) + +;;; Adjustable arrays + +(deftest bit-andc2.16 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)) + :adjustable t)) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)) + :adjustable t)) + (result (bit-andc2 a1 a2))) + (values a1 a2 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((0 1)(0 0))) + +;;; Displaced arrays + +(deftest bit-andc2.17 + (let* ((a0 (make-array '(8) :element-type 'bit + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-andc2 a1 a2))) + (values a0 a1 a2 result)) + #*01010011 + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((0 1)(0 0))) + +(deftest bit-andc2.18 + (let* ((a0 (make-array '(8) :element-type 'bit + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-andc2 a1 a2 t))) + (values a0 a1 a2 result)) + #*01000011 + #2a((0 1)(0 0)) + #2a((0 0)(1 1)) + #2a((0 1)(0 0))) + +(deftest bit-andc2.19 + (let* ((a0 (make-array '(12) :element-type 'bit + :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (a3 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 8)) + (result (bit-andc2 a1 a2 a3))) + (values a0 a1 a2 result)) + #*010100110100 + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((0 1)(0 0))) + +(deftest bit-andc2.order.1 + (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) + (s2 (make-array 1 :initial-element 0 :element-type 'bit)) + (x 0) y z) + (values + (bit-andc2 (progn (setf y (incf x)) s1) + (progn (setf z (incf x)) s2)) + x y z)) + #*0 2 1 2) + +;;; Error tests + +(deftest bit-andc2.error.1 + (classify-error (bit-andc2)) + program-error) + +(deftest bit-andc2.error.2 + (classify-error (bit-andc2 #*000)) + program-error) + +(deftest bit-andc2.error.3 + (classify-error (bit-andc2 #*000 #*0100 nil nil)) + program-error) + diff --git a/ansi-tests/bit-eqv.lsp b/ansi-tests/bit-eqv.lsp new file mode 100644 index 0000000..6593d97 --- /dev/null +++ b/ansi-tests/bit-eqv.lsp @@ -0,0 +1,245 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Jan 26 19:07:23 2003 +;;;; Contains: Tests of BIT-EQV + + +(in-package :cl-test) + +(deftest bit-eqv.1 + (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (values (bit-eqv s1 s2) s1 s2)) + #0a1 + #0a0 + #0a0) + +(deftest bit-eqv.2 + (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (values (bit-eqv s1 s2) s1 s2)) + #0a0 + #0a1 + #0a0) + +(deftest bit-eqv.3 + (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (values (bit-eqv s1 s2) s1 s2)) + #0a0 + #0a0 + #0a1) + +(deftest bit-eqv.4 + (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (values (bit-eqv s1 s2) s1 s2)) + #0a1 + #0a1 + #0a1) + +(deftest bit-eqv.5 + (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) + (s2 (make-array nil :initial-element 0 :element-type 'bit)) + (s3 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-eqv s1 s2 s3))) + (values s1 s2 s3 result (eqt s3 result))) + #0a0 + #0a0 + #0a1 + #0a1 + t) + +(deftest bit-eqv.6 + (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) + (s2 (make-array nil :initial-element 1 :element-type 'bit)) + (s3 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-eqv s1 s2 s3))) + (values s1 s2 s3 result (eqt s3 result))) + #0a1 + #0a1 + #0a1 + #0a1 + t) + +(deftest bit-eqv.7 + (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) + (s2 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-eqv s1 s2 t))) + (values s1 s2 result (eqt s1 result))) + #0a0 + #0a0 + #0a0 + t) + + +;;; Tests on bit vectors + +(deftest bit-eqv.8 + (let ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101))) + (values (check-values (bit-eqv a1 a2)) a1 a2)) + #*1001 #*0011 #*0101) + +(deftest bit-eqv.9 + (let* ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101)) + (result (check-values (bit-eqv a1 a2 t)))) + (values result a1 a2 (eqt result a1))) + #*1001 #*1001 #*0101 t) + +(deftest bit-eqv.10 + (let* ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101)) + (a3 (copy-seq #*0000)) + (result (check-values (bit-eqv a1 a2 a3)))) + (values result a1 a2 a3 (eqt result a3))) + #*1001 #*0011 #*0101 #*1001 t) + +(deftest bit-eqv.11 + (let ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101))) + (values (check-values (bit-eqv a1 a2 nil)) a1 a2)) + #*1001 #*0011 #*0101) + +;;; Tests on bit arrays + +(deftest bit-eqv.12 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-eqv a1 a2))) + (values a1 a2 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((1 0)(0 1))) + +(deftest bit-eqv.13 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-eqv a1 a2 t))) + (values a1 a2 result)) + #2a((1 0)(0 1)) + #2a((0 0)(1 1)) + #2a((1 0)(0 1))) + +(deftest bit-eqv.14 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-eqv a1 a2 nil))) + (values a1 a2 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((1 0)(0 1))) + +(deftest bit-eqv.15 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (a3 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(0 0)))) + (result (bit-eqv a1 a2 a3))) + (values a1 a2 a3 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((1 0)(0 1)) + #2a((1 0)(0 1))) + +;;; Adjustable arrays + +(deftest bit-eqv.16 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)) + :adjustable t)) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)) + :adjustable t)) + (result (bit-eqv a1 a2))) + (values a1 a2 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((1 0)(0 1))) + +;;; Displaced arrays + +(deftest bit-eqv.17 + (let* ((a0 (make-array '(8) :element-type 'bit + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-eqv a1 a2))) + (values a0 a1 a2 result)) + #*01010011 + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((1 0)(0 1))) + +(deftest bit-eqv.18 + (let* ((a0 (make-array '(8) :element-type 'bit + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-eqv a1 a2 t))) + (values a0 a1 a2 result)) + #*10010011 + #2a((1 0)(0 1)) + #2a((0 0)(1 1)) + #2a((1 0)(0 1))) + +(deftest bit-eqv.19 + (let* ((a0 (make-array '(12) :element-type 'bit + :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (a3 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 8)) + (result (bit-eqv a1 a2 a3))) + (values a0 a1 a2 result)) + #*010100111001 + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((1 0)(0 1))) + +(deftest bit-eqv.order.1 + (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) + (s2 (make-array 1 :initial-element 0 :element-type 'bit)) + (x 0) y z) + (values + (bit-eqv (progn (setf y (incf x)) s1) + (progn (setf z (incf x)) s2)) + x y z)) + #*1 2 1 2) + +;;; Error tests + +(deftest bit-eqv.error.1 + (classify-error (bit-eqv)) + program-error) + +(deftest bit-eqv.error.2 + (classify-error (bit-eqv #*000)) + program-error) + +(deftest bit-eqv.error.3 + (classify-error (bit-eqv #*000 #*0100 nil nil)) + program-error) + diff --git a/ansi-tests/bit-ior.lsp b/ansi-tests/bit-ior.lsp new file mode 100644 index 0000000..469c778 --- /dev/null +++ b/ansi-tests/bit-ior.lsp @@ -0,0 +1,244 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Jan 26 19:13:34 2003 +;;;; Contains: Tests of BIT-IOR + +(in-package :cl-test) + +(deftest bit-ior.1 + (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (values (bit-ior s1 s2) s1 s2)) + #0a0 + #0a0 + #0a0) + +(deftest bit-ior.2 + (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (values (bit-ior s1 s2) s1 s2)) + #0a1 + #0a1 + #0a0) + +(deftest bit-ior.3 + (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (values (bit-ior s1 s2) s1 s2)) + #0a1 + #0a0 + #0a1) + +(deftest bit-ior.4 + (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (values (bit-ior s1 s2) s1 s2)) + #0a1 + #0a1 + #0a1) + +(deftest bit-ior.5 + (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) + (s2 (make-array nil :initial-element 0 :element-type 'bit)) + (s3 (make-array nil :initial-element 1 :element-type 'bit)) + (result (bit-ior s1 s2 s3))) + (values s1 s2 s3 result (eqt s3 result))) + #0a0 + #0a0 + #0a0 + #0a0 + t) + +(deftest bit-ior.6 + (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) + (s2 (make-array nil :initial-element 1 :element-type 'bit)) + (s3 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-ior s1 s2 s3))) + (values s1 s2 s3 result (eqt s3 result))) + #0a1 + #0a1 + #0a1 + #0a1 + t) + +(deftest bit-ior.7 + (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) + (s2 (make-array nil :initial-element 1 :element-type 'bit)) + (result (bit-ior s1 s2 t))) + (values s1 s2 result (eqt s1 result))) + #0a1 + #0a1 + #0a1 + t) + + +;;; Tests on bit vectors + +(deftest bit-ior.8 + (let ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101))) + (values (check-values (bit-ior a1 a2)) a1 a2)) + #*0111 #*0011 #*0101) + +(deftest bit-ior.9 + (let* ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101)) + (result (check-values (bit-ior a1 a2 t)))) + (values result a1 a2 (eqt result a1))) + #*0111 #*0111 #*0101 t) + +(deftest bit-ior.10 + (let* ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101)) + (a3 (copy-seq #*1110)) + (result (check-values (bit-ior a1 a2 a3)))) + (values result a1 a2 a3 (eqt result a3))) + #*0111 #*0011 #*0101 #*0111 t) + +(deftest bit-ior.11 + (let ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101))) + (values (check-values (bit-ior a1 a2 nil)) a1 a2)) + #*0111 #*0011 #*0101) + +;;; Tests on bit arrays + +(deftest bit-ior.12 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-ior a1 a2))) + (values a1 a2 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((0 1)(1 1))) + +(deftest bit-ior.13 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-ior a1 a2 t))) + (values a1 a2 result)) + #2a((0 1)(1 1)) + #2a((0 0)(1 1)) + #2a((0 1)(1 1))) + +(deftest bit-ior.14 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-ior a1 a2 nil))) + (values a1 a2 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((0 1)(1 1))) + +(deftest bit-ior.15 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (a3 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(0 0)))) + (result (bit-ior a1 a2 a3))) + (values a1 a2 a3 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((0 1)(1 1)) + #2a((0 1)(1 1))) + +;;; Adjustable arrays + +(deftest bit-ior.16 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)) + :adjustable t)) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)) + :adjustable t)) + (result (bit-ior a1 a2))) + (values a1 a2 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((0 1)(1 1))) + +;;; Displaced arrays + +(deftest bit-ior.17 + (let* ((a0 (make-array '(8) :element-type 'bit + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-ior a1 a2))) + (values a0 a1 a2 result)) + #*01010011 + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((0 1)(1 1))) + +(deftest bit-ior.18 + (let* ((a0 (make-array '(8) :element-type 'bit + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-ior a1 a2 t))) + (values a0 a1 a2 result)) + #*01110011 + #2a((0 1)(1 1)) + #2a((0 0)(1 1)) + #2a((0 1)(1 1))) + +(deftest bit-ior.19 + (let* ((a0 (make-array '(12) :element-type 'bit + :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (a3 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 8)) + (result (bit-ior a1 a2 a3))) + (values a0 a1 a2 result)) + #*010100110111 + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((0 1)(1 1))) + +(deftest bit-ior.order.1 + (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) + (s2 (make-array 1 :initial-element 0 :element-type 'bit)) + (x 0) y z) + (values + (bit-ior (progn (setf y (incf x)) s1) + (progn (setf z (incf x)) s2)) + x y z)) + #*0 2 1 2) + +;;; Error tests + +(deftest bit-ior.error.1 + (classify-error (bit-ior)) + program-error) + +(deftest bit-ior.error.2 + (classify-error (bit-ior #*000)) + program-error) + +(deftest bit-ior.error.3 + (classify-error (bit-ior #*000 #*0100 nil nil)) + program-error) + diff --git a/ansi-tests/bit-nand.lsp b/ansi-tests/bit-nand.lsp new file mode 100644 index 0000000..840e686 --- /dev/null +++ b/ansi-tests/bit-nand.lsp @@ -0,0 +1,244 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Jan 26 19:16:15 2003 +;;;; Contains: Tests for BIT-NAND + +(in-package :cl-test) + +(deftest bit-nand.1 + (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (values (bit-nand s1 s2) s1 s2)) + #0a1 + #0a0 + #0a0) + +(deftest bit-nand.2 + (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (values (bit-nand s1 s2) s1 s2)) + #0a1 + #0a1 + #0a0) + +(deftest bit-nand.3 + (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (values (bit-nand s1 s2) s1 s2)) + #0a1 + #0a0 + #0a1) + +(deftest bit-nand.4 + (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (values (bit-nand s1 s2) s1 s2)) + #0a0 + #0a1 + #0a1) + +(deftest bit-nand.5 + (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) + (s2 (make-array nil :initial-element 0 :element-type 'bit)) + (s3 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-nand s1 s2 s3))) + (values s1 s2 s3 result (eqt s3 result))) + #0a0 + #0a0 + #0a1 + #0a1 + t) + +(deftest bit-nand.6 + (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) + (s2 (make-array nil :initial-element 1 :element-type 'bit)) + (s3 (make-array nil :initial-element 1 :element-type 'bit)) + (result (bit-nand s1 s2 s3))) + (values s1 s2 s3 result (eqt s3 result))) + #0a1 + #0a1 + #0a0 + #0a0 + t) + +(deftest bit-nand.7 + (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) + (s2 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-nand s1 s2 t))) + (values s1 s2 result (eqt s1 result))) + #0a1 + #0a0 + #0a1 + t) + + +;;; Tests on bit vectors + +(deftest bit-nand.8 + (let ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101))) + (values (check-values (bit-nand a1 a2)) a1 a2)) + #*1110 #*0011 #*0101) + +(deftest bit-nand.9 + (let* ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101)) + (result (check-values (bit-nand a1 a2 t)))) + (values result a1 a2 (eqt result a1))) + #*1110 #*1110 #*0101 t) + +(deftest bit-nand.10 + (let* ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101)) + (a3 (copy-seq #*1110)) + (result (check-values (bit-nand a1 a2 a3)))) + (values result a1 a2 a3 (eqt result a3))) + #*1110 #*0011 #*0101 #*1110 t) + +(deftest bit-nand.11 + (let ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101))) + (values (check-values (bit-nand a1 a2 nil)) a1 a2)) + #*1110 #*0011 #*0101) + +;;; Tests on bit arrays + +(deftest bit-nand.12 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-nand a1 a2))) + (values a1 a2 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((1 1)(1 0))) + +(deftest bit-nand.13 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-nand a1 a2 t))) + (values a1 a2 result)) + #2a((1 1)(1 0)) + #2a((0 0)(1 1)) + #2a((1 1)(1 0))) + +(deftest bit-nand.14 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-nand a1 a2 nil))) + (values a1 a2 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((1 1)(1 0))) + +(deftest bit-nand.15 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (a3 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(0 0)))) + (result (bit-nand a1 a2 a3))) + (values a1 a2 a3 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((1 1)(1 0)) + #2a((1 1)(1 0))) + +;;; Adjustable arrays + +(deftest bit-nand.16 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)) + :adjustable t)) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)) + :adjustable t)) + (result (bit-nand a1 a2))) + (values a1 a2 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((1 1)(1 0))) + +;;; Displaced arrays + +(deftest bit-nand.17 + (let* ((a0 (make-array '(8) :element-type 'bit + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-nand a1 a2))) + (values a0 a1 a2 result)) + #*01010011 + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((1 1)(1 0))) + +(deftest bit-nand.18 + (let* ((a0 (make-array '(8) :element-type 'bit + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-nand a1 a2 t))) + (values a0 a1 a2 result)) + #*11100011 + #2a((1 1)(1 0)) + #2a((0 0)(1 1)) + #2a((1 1)(1 0))) + +(deftest bit-nand.19 + (let* ((a0 (make-array '(12) :element-type 'bit + :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (a3 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 8)) + (result (bit-nand a1 a2 a3))) + (values a0 a1 a2 result)) + #*010100111110 + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((1 1)(1 0))) + +(deftest bit-nand.order.1 + (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) + (s2 (make-array 1 :initial-element 0 :element-type 'bit)) + (x 0) y z) + (values + (bit-nand (progn (setf y (incf x)) s1) + (progn (setf z (incf x)) s2)) + x y z)) + #*1 2 1 2) + +;;; Error tests + +(deftest bit-nand.error.1 + (classify-error (bit-nand)) + program-error) + +(deftest bit-nand.error.2 + (classify-error (bit-nand #*000)) + program-error) + +(deftest bit-nand.error.3 + (classify-error (bit-nand #*000 #*0100 nil nil)) + program-error) + diff --git a/ansi-tests/bit-nor.lsp b/ansi-tests/bit-nor.lsp new file mode 100644 index 0000000..36031ef --- /dev/null +++ b/ansi-tests/bit-nor.lsp @@ -0,0 +1,244 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Jan 26 19:20:40 2003 +;;;; Contains: Tests for BIT-NOR + +(in-package :cl-test) + +(deftest bit-nor.1 + (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (values (bit-nor s1 s2) s1 s2)) + #0a1 + #0a0 + #0a0) + +(deftest bit-nor.2 + (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (values (bit-nor s1 s2) s1 s2)) + #0a0 + #0a1 + #0a0) + +(deftest bit-nor.3 + (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (values (bit-nor s1 s2) s1 s2)) + #0a0 + #0a0 + #0a1) + +(deftest bit-nor.4 + (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (values (bit-nor s1 s2) s1 s2)) + #0a0 + #0a1 + #0a1) + +(deftest bit-nor.5 + (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) + (s2 (make-array nil :initial-element 0 :element-type 'bit)) + (s3 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-nor s1 s2 s3))) + (values s1 s2 s3 result (eqt s3 result))) + #0a0 + #0a0 + #0a1 + #0a1 + t) + +(deftest bit-nor.6 + (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) + (s2 (make-array nil :initial-element 1 :element-type 'bit)) + (s3 (make-array nil :initial-element 1 :element-type 'bit)) + (result (bit-nor s1 s2 s3))) + (values s1 s2 s3 result (eqt s3 result))) + #0a1 + #0a1 + #0a0 + #0a0 + t) + +(deftest bit-nor.7 + (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) + (s2 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-nor s1 s2 t))) + (values s1 s2 result (eqt s1 result))) + #0a0 + #0a0 + #0a0 + t) + + +;;; Tests on bit vectors + +(deftest bit-nor.8 + (let ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101))) + (values (check-values (bit-nor a1 a2)) a1 a2)) + #*1000 #*0011 #*0101) + +(deftest bit-nor.9 + (let* ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101)) + (result (check-values (bit-nor a1 a2 t)))) + (values result a1 a2 (eqt result a1))) + #*1000 #*1000 #*0101 t) + +(deftest bit-nor.10 + (let* ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101)) + (a3 (copy-seq #*1110)) + (result (check-values (bit-nor a1 a2 a3)))) + (values result a1 a2 a3 (eqt result a3))) + #*1000 #*0011 #*0101 #*1000 t) + +(deftest bit-nor.11 + (let ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101))) + (values (check-values (bit-nor a1 a2 nil)) a1 a2)) + #*1000 #*0011 #*0101) + +;;; Tests on bit arrays + +(deftest bit-nor.12 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-nor a1 a2))) + (values a1 a2 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((1 0)(0 0))) + +(deftest bit-nor.13 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-nor a1 a2 t))) + (values a1 a2 result)) + #2a((1 0)(0 0)) + #2a((0 0)(1 1)) + #2a((1 0)(0 0))) + +(deftest bit-nor.14 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-nor a1 a2 nil))) + (values a1 a2 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((1 0)(0 0))) + +(deftest bit-nor.15 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (a3 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(0 0)))) + (result (bit-nor a1 a2 a3))) + (values a1 a2 a3 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((1 0)(0 0)) + #2a((1 0)(0 0))) + +;;; Adjustable arrays + +(deftest bit-nor.16 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)) + :adjustable t)) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)) + :adjustable t)) + (result (bit-nor a1 a2))) + (values a1 a2 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((1 0)(0 0))) + +;;; Displaced arrays + +(deftest bit-nor.17 + (let* ((a0 (make-array '(8) :element-type 'bit + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-nor a1 a2))) + (values a0 a1 a2 result)) + #*01010011 + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((1 0)(0 0))) + +(deftest bit-nor.18 + (let* ((a0 (make-array '(8) :element-type 'bit + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-nor a1 a2 t))) + (values a0 a1 a2 result)) + #*10000011 + #2a((1 0)(0 0)) + #2a((0 0)(1 1)) + #2a((1 0)(0 0))) + +(deftest bit-nor.19 + (let* ((a0 (make-array '(12) :element-type 'bit + :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (a3 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 8)) + (result (bit-nor a1 a2 a3))) + (values a0 a1 a2 result)) + #*010100111000 + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((1 0)(0 0))) + +(deftest bit-nor.order.1 + (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) + (s2 (make-array 1 :initial-element 0 :element-type 'bit)) + (x 0) y z) + (values + (bit-nor (progn (setf y (incf x)) s1) + (progn (setf z (incf x)) s2)) + x y z)) + #*1 2 1 2) + +;;; Error tests + +(deftest bit-nor.error.1 + (classify-error (bit-nor)) + program-error) + +(deftest bit-nor.error.2 + (classify-error (bit-nor #*000)) + program-error) + +(deftest bit-nor.error.3 + (classify-error (bit-nor #*000 #*0100 nil nil)) + program-error) + diff --git a/ansi-tests/bit-not.lsp b/ansi-tests/bit-not.lsp new file mode 100644 index 0000000..550dce3 --- /dev/null +++ b/ansi-tests/bit-not.lsp @@ -0,0 +1,139 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Jan 26 19:40:13 2003 +;;;; Contains: Tests of BIT-NOT + +(in-package :cl-test) + +(deftest bit-not.1 + (let ((a1 (make-array nil :element-type 'bit :initial-element 0))) + (values (bit-not a1) a1)) + #0a1 #0a0) + +(deftest bit-not.2 + (let ((a1 (make-array nil :element-type 'bit :initial-element 1))) + (values (bit-not a1) a1)) + #0a0 #0a1) + +(deftest bit-not.3 + (let ((a1 (make-array nil :element-type 'bit :initial-element 0))) + (values (bit-not a1 t) a1)) + #0a1 #0a1) + +(deftest bit-not.4 + (let ((a1 (make-array nil :element-type 'bit :initial-element 1))) + (values (bit-not a1 t) a1)) + #0a0 #0a0) + +(deftest bit-not.5 + (let* ((a1 (make-array nil :element-type 'bit :initial-element 1)) + (a2 (make-array nil :element-type 'bit :initial-element 1)) + (result (bit-not a1 a2))) + (values a1 a2 (eqt a2 result))) + #0a1 #0a0 t) + +(deftest bit-not.6 + (let ((a1 (make-array nil :element-type 'bit :initial-element 0))) + (values (bit-not a1 nil) a1)) + #0a1 #0a0) + +;;; Tests on bit vectors + +(deftest bit-not.7 + (let ((a1 (copy-seq #*0011010110))) + (values (bit-not a1) a1)) + #*1100101001 + #*0011010110) + +(deftest bit-not.8 + (let ((a1 (copy-seq #*0011010110))) + (values (bit-not a1 t) a1)) + #*1100101001 + #*1100101001) + +(deftest bit-not.9 + (let ((a1 (copy-seq #*0011010110)) + (a2 (copy-seq #*0000000000))) + (values (bit-not a1 a2) a1 a2)) + #*1100101001 + #*0011010110 + #*1100101001) + +;;; Arrays + +(deftest bit-not.10 + (let ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(1 0))))) + (values (bit-not a1) a1)) + #2a((1 0)(0 1)) + #2a((0 1)(1 0))) + +(deftest bit-not.11 + (let ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(1 0))))) + (values (bit-not a1 nil) a1)) + #2a((1 0)(0 1)) + #2a((0 1)(1 0))) + +(deftest bit-not.12 + (let ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(1 0))))) + (values (bit-not a1 t) a1)) + #2a((1 0)(0 1)) + #2a((1 0)(0 1))) + +(deftest bit-not.13 + (let ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(1 0)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-element 0))) + (values (bit-not a1 a2) a1 a2)) + #2a((1 0)(0 1)) + #2a((0 1)(1 0)) + #2a((1 0)(0 1))) + +;;; Adjustable array + +(deftest bit-not.14 + (let ((a1 (make-array '(2 2) :element-type 'bit + :adjustable t + :initial-contents '((0 1)(1 0))))) + (values (bit-not a1) a1)) + #2a((1 0)(0 1)) + #2a((0 1)(1 0))) + +;;; Displaced arrays + +(deftest bit-not.15 + (let* ((a0 (make-array '(12) :element-type 'bit + :initial-contents '(0 0 0 1 1 0 0 0 0 0 0 0))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 2)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 6))) + (values (bit-not a1 a2) a0 a1 a2)) + #2a((1 0)(0 1)) + #*000110100100 + #2a((0 1)(1 0)) + #2a((1 0)(0 1))) + +(deftest bit-not.order.1 + (let ((a (copy-seq #*001101)) + (i 0) x) + (values + (bit-not (progn (setf x (incf i)) a)) + i x)) + #*110010 1 1) + +;;; Error tests + +(deftest bit-not.error.1 + (classify-error (bit-not)) + program-error) + +(deftest bit-not.error.2 + (classify-error (bit-not #*000 nil nil)) + program-error) + diff --git a/ansi-tests/bit-orc1.lsp b/ansi-tests/bit-orc1.lsp new file mode 100644 index 0000000..96467f9 --- /dev/null +++ b/ansi-tests/bit-orc1.lsp @@ -0,0 +1,244 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Jan 26 19:25:28 2003 +;;;; Contains: Tests of BIT-ORC1 + +(in-package :cl-test) + +(deftest bit-orc1.1 + (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (values (bit-orc1 s1 s2) s1 s2)) + #0a1 + #0a0 + #0a0) + +(deftest bit-orc1.2 + (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (values (bit-orc1 s1 s2) s1 s2)) + #0a0 + #0a1 + #0a0) + +(deftest bit-orc1.3 + (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (values (bit-orc1 s1 s2) s1 s2)) + #0a1 + #0a0 + #0a1) + +(deftest bit-orc1.4 + (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (values (bit-orc1 s1 s2) s1 s2)) + #0a1 + #0a1 + #0a1) + +(deftest bit-orc1.5 + (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) + (s2 (make-array nil :initial-element 0 :element-type 'bit)) + (s3 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-orc1 s1 s2 s3))) + (values s1 s2 s3 result (eqt s3 result))) + #0a0 + #0a0 + #0a1 + #0a1 + t) + +(deftest bit-orc1.6 + (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) + (s2 (make-array nil :initial-element 1 :element-type 'bit)) + (s3 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-orc1 s1 s2 s3))) + (values s1 s2 s3 result (eqt s3 result))) + #0a1 + #0a1 + #0a1 + #0a1 + t) + +(deftest bit-orc1.7 + (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) + (s2 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-orc1 s1 s2 t))) + (values s1 s2 result (eqt s1 result))) + #0a0 + #0a0 + #0a0 + t) + + +;;; Tests on bit vectors + +(deftest bit-orc1.8 + (let ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101))) + (values (check-values (bit-orc1 a1 a2)) a1 a2)) + #*1101 #*0011 #*0101) + +(deftest bit-orc1.9 + (let* ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101)) + (result (check-values (bit-orc1 a1 a2 t)))) + (values result a1 a2 (eqt result a1))) + #*1101 #*1101 #*0101 t) + +(deftest bit-orc1.10 + (let* ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101)) + (a3 (copy-seq #*1110)) + (result (check-values (bit-orc1 a1 a2 a3)))) + (values result a1 a2 a3 (eqt result a3))) + #*1101 #*0011 #*0101 #*1101 t) + +(deftest bit-orc1.11 + (let ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101))) + (values (check-values (bit-orc1 a1 a2 nil)) a1 a2)) + #*1101 #*0011 #*0101) + +;;; Tests on bit arrays + +(deftest bit-orc1.12 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-orc1 a1 a2))) + (values a1 a2 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((1 0)(1 1))) + +(deftest bit-orc1.13 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-orc1 a1 a2 t))) + (values a1 a2 result)) + #2a((1 0)(1 1)) + #2a((0 0)(1 1)) + #2a((1 0)(1 1))) + +(deftest bit-orc1.14 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-orc1 a1 a2 nil))) + (values a1 a2 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((1 0)(1 1))) + +(deftest bit-orc1.15 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (a3 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(0 0)))) + (result (bit-orc1 a1 a2 a3))) + (values a1 a2 a3 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((1 0)(1 1)) + #2a((1 0)(1 1))) + +;;; Adjustable arrays + +(deftest bit-orc1.16 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)) + :adjustable t)) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)) + :adjustable t)) + (result (bit-orc1 a1 a2))) + (values a1 a2 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((1 0)(1 1))) + +;;; Displaced arrays + +(deftest bit-orc1.17 + (let* ((a0 (make-array '(8) :element-type 'bit + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-orc1 a1 a2))) + (values a0 a1 a2 result)) + #*01010011 + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((1 0)(1 1))) + +(deftest bit-orc1.18 + (let* ((a0 (make-array '(8) :element-type 'bit + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-orc1 a1 a2 t))) + (values a0 a1 a2 result)) + #*10110011 + #2a((1 0)(1 1)) + #2a((0 0)(1 1)) + #2a((1 0)(1 1))) + +(deftest bit-orc1.19 + (let* ((a0 (make-array '(12) :element-type 'bit + :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (a3 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 8)) + (result (bit-orc1 a1 a2 a3))) + (values a0 a1 a2 result)) + #*010100111011 + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((1 0)(1 1))) + +(deftest bit-orc1.order.1 + (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) + (s2 (make-array 1 :initial-element 0 :element-type 'bit)) + (x 0) y z) + (values + (bit-orc1 (progn (setf y (incf x)) s1) + (progn (setf z (incf x)) s2)) + x y z)) + #*1 2 1 2) + +;;; Error tests + +(deftest bit-orc1.error.1 + (classify-error (bit-orc1)) + program-error) + +(deftest bit-orc1.error.2 + (classify-error (bit-orc1 #*000)) + program-error) + +(deftest bit-orc1.error.3 + (classify-error (bit-orc1 #*000 #*0100 nil nil)) + program-error) + diff --git a/ansi-tests/bit-orc2.lsp b/ansi-tests/bit-orc2.lsp new file mode 100644 index 0000000..1f7af72 --- /dev/null +++ b/ansi-tests/bit-orc2.lsp @@ -0,0 +1,245 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Jan 26 19:31:35 2003 +;;;; Contains: Tests of BIT-ORC2 + +(in-package :cl-test) + +(deftest bit-orc2.1 + (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (values (bit-orc2 s1 s2) s1 s2)) + #0a1 + #0a0 + #0a0) + +(deftest bit-orc2.2 + (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (values (bit-orc2 s1 s2) s1 s2)) + #0a1 + #0a1 + #0a0) + +(deftest bit-orc2.3 + (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (values (bit-orc2 s1 s2) s1 s2)) + #0a0 + #0a0 + #0a1) + +(deftest bit-orc2.4 + (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (values (bit-orc2 s1 s2) s1 s2)) + #0a1 + #0a1 + #0a1) + +(deftest bit-orc2.5 + (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) + (s2 (make-array nil :initial-element 0 :element-type 'bit)) + (s3 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-orc2 s1 s2 s3))) + (values s1 s2 s3 result (eqt s3 result))) + #0a0 + #0a0 + #0a1 + #0a1 + t) + +(deftest bit-orc2.6 + (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) + (s2 (make-array nil :initial-element 1 :element-type 'bit)) + (s3 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-orc2 s1 s2 s3))) + (values s1 s2 s3 result (eqt s3 result))) + #0a1 + #0a1 + #0a1 + #0a1 + t) + +(deftest bit-orc2.7 + (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) + (s2 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-orc2 s1 s2 t))) + (values s1 s2 result (eqt s1 result))) + #0a1 + #0a0 + #0a1 + t) + + +;;; Tests on bit vectors + +(deftest bit-orc2.8 + (let ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101))) + (values (check-values (bit-orc2 a1 a2)) a1 a2)) + #*1011 #*0011 #*0101) + +(deftest bit-orc2.9 + (let* ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101)) + (result (check-values (bit-orc2 a1 a2 t)))) + (values result a1 a2 (eqt result a1))) + #*1011 #*1011 #*0101 t) + +(deftest bit-orc2.10 + (let* ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101)) + (a3 (copy-seq #*1110)) + (result (check-values (bit-orc2 a1 a2 a3)))) + (values result a1 a2 a3 (eqt result a3))) + #*1011 #*0011 #*0101 #*1011 t) + +(deftest bit-orc2.11 + (let ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101))) + (values (check-values (bit-orc2 a1 a2 nil)) a1 a2)) + #*1011 #*0011 #*0101) + +;;; Tests on bit arrays + +(deftest bit-orc2.12 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-orc2 a1 a2))) + (values a1 a2 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((1 1)(0 1))) + +(deftest bit-orc2.13 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-orc2 a1 a2 t))) + (values a1 a2 result)) + #2a((1 1)(0 1)) + #2a((0 0)(1 1)) + #2a((1 1)(0 1))) + +(deftest bit-orc2.14 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-orc2 a1 a2 nil))) + (values a1 a2 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((1 1)(0 1))) + +(deftest bit-orc2.15 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (a3 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(0 0)))) + (result (bit-orc2 a1 a2 a3))) + (values a1 a2 a3 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((1 1)(0 1)) + #2a((1 1)(0 1))) + +;;; Adjustable arrays + +(deftest bit-orc2.16 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)) + :adjustable t)) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)) + :adjustable t)) + (result (bit-orc2 a1 a2))) + (values a1 a2 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((1 1)(0 1))) + +;;; Displaced arrays + +(deftest bit-orc2.17 + (let* ((a0 (make-array '(8) :element-type 'bit + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-orc2 a1 a2))) + (values a0 a1 a2 result)) + #*01010011 + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((1 1)(0 1))) + +(deftest bit-orc2.18 + (let* ((a0 (make-array '(8) :element-type 'bit + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-orc2 a1 a2 t))) + (values a0 a1 a2 result)) + #*11010011 + #2a((1 1)(0 1)) + #2a((0 0)(1 1)) + #2a((1 1)(0 1))) + +(deftest bit-orc2.19 + (let* ((a0 (make-array '(12) :element-type 'bit + :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (a3 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 8)) + (result (bit-orc2 a1 a2 a3))) + (values a0 a1 a2 result)) + #*010100111101 + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((1 1)(0 1))) + +(deftest bit-orc2.order.1 + (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) + (s2 (make-array 1 :initial-element 0 :element-type 'bit)) + (x 0) y z) + (values + (bit-orc2 (progn (setf y (incf x)) s1) + (progn (setf z (incf x)) s2)) + x y z)) + #*1 2 1 2) + +;;; Error tests + +(deftest bit-orc2.error.1 + (classify-error (bit-orc2)) + program-error) + +(deftest bit-orc2.error.2 + (classify-error (bit-orc2 #*000)) + program-error) + +(deftest bit-orc2.error.3 + (classify-error (bit-orc2 #*000 #*0100 nil nil)) + program-error) + + diff --git a/ansi-tests/bit-vector-p.lsp b/ansi-tests/bit-vector-p.lsp new file mode 100644 index 0000000..93ebbd2 --- /dev/null +++ b/ansi-tests/bit-vector-p.lsp @@ -0,0 +1,79 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Jan 26 20:16:50 2003 +;;;; Contains: Tests of BIT-VECTOR-P + +(in-package :cl-test) + +(deftest bit-vector-p.2 + (notnot-mv (bit-vector-p #*)) + t) + +(deftest bit-vector-p.3 + (notnot-mv (bit-vector-p #*00101)) + t) + +(deftest bit-vector-p.4 + (bit-vector-p #(0 1 1 1 0 0)) + nil) + +(deftest bit-vector-p.5 + (bit-vector-p "011100") + nil) + +(deftest bit-vector-p.6 + (bit-vector-p 0) + nil) + +(deftest bit-vector-p.7 + (bit-vector-p 1) + nil) + +(deftest bit-vector-p.8 + (bit-vector-p nil) + nil) + +(deftest bit-vector-p.9 + (bit-vector-p 'x) + nil) + +(deftest bit-vector-p.10 + (bit-vector-p '(0 1 1 0)) + nil) + +(deftest bit-vector-p.11 + (bit-vector-p (make-array '(2 2) :element-type 'bit + :initial-element 0)) + nil) + +(deftest bit-vector-p.12 + (loop for e in *universe* + for p1 = (typep e 'bit-vector) + for p2 = (bit-vector-p e) + always (if p1 p2 (not p2))) + t) + +(deftest bit-vector-p.order.1 + (let ((i 0) x) + (values + (notnot (bit-vector-p (progn (setf x (incf i)) #*0010))) + i x)) + t 1 1) + +(deftest bit-vector-p.order.2 + (let ((i 0) x) + (values + (bit-vector-p (progn (setf x (incf i)) 'a)) + i x)) + nil 1 1) + + + + +(deftest bit-vector-p.error.1 + (classify-error (bit-vector-p)) + program-error) + +(deftest bit-vector-p.error.2 + (classify-error (bit-vector-p #* #*)) + program-error) diff --git a/ansi-tests/bit-vector.lsp b/ansi-tests/bit-vector.lsp new file mode 100644 index 0000000..9acce28 --- /dev/null +++ b/ansi-tests/bit-vector.lsp @@ -0,0 +1,121 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Jan 26 13:03:22 2003 +;;;; Contains: Tests of type BIT-VECTOR + +(in-package :cl-test) + +(deftest bit-vector.1 + (notnot-mv (find-class 'bit-vector)) + t) + +(deftest bit-vector.2 + (notnot-mv (typep #* 'bit-vector)) + t) + +(deftest bit-vector.3 + (notnot-mv (typep #*00101 'bit-vector)) + t) + +(deftest bit-vector.4 + (typep #(0 1 1 1 0 0) 'bit-vector) + nil) + +(deftest bit-vector.5 + (typep "011100" 'bit-vector) + nil) + +(deftest bit-vector.6 + (typep 0 'bit-vector) + nil) + +(deftest bit-vector.7 + (typep 1 'bit-vector) + nil) + +(deftest bit-vector.8 + (typep nil 'bit-vector) + nil) + +(deftest bit-vector.9 + (typep 'x 'bit-vector) + nil) + +(deftest bit-vector.10 + (typep '(0 1 1 0) 'bit-vector) + nil) + +(deftest bit-vector.11 + (typep (make-array '(2 2) :element-type 'bit + :initial-element 0) + 'bit-vector) + nil) + +(deftest bit-vector.12 + (notnot-mv (typep #* '(bit-vector *))) + t) + +(deftest bit-vector.13 + (notnot-mv (typep #*01101 '(bit-vector *))) + t) + +(deftest bit-vector.14 + (notnot-mv (typep #* '(bit-vector 0))) + t) + +(deftest bit-vector.15 + (typep #*01101 '(bit-vector 0)) + nil) + +(deftest bit-vector.16 + (typep #* '(bit-vector 5)) + nil) + +(deftest bit-vector.17 + (notnot-mv (typep #*01101 '(bit-vector 5))) + t) + + +;;; Tests of typep on the class named bit-vector + +(deftest bit-vector.class.2 + (notnot-mv (typep #* (find-class 'bit-vector))) + t) + +(deftest bit-vector.class.3 + (notnot-mv (typep #*00101 (find-class 'bit-vector))) + t) + +(deftest bit-vector.class.4 + (typep #(0 1 1 1 0 0) (find-class 'bit-vector)) + nil) + +(deftest bit-vector.class.5 + (typep "011100" (find-class 'bit-vector)) + nil) + +(deftest bit-vector.class.6 + (typep 0 (find-class 'bit-vector)) + nil) + +(deftest bit-vector.class.7 + (typep 1 (find-class 'bit-vector)) + nil) + +(deftest bit-vector.class.8 + (typep nil (find-class 'bit-vector)) + nil) + +(deftest bit-vector.class.9 + (typep 'x (find-class 'bit-vector)) + nil) + +(deftest bit-vector.class.10 + (typep '(0 1 1 0) (find-class 'bit-vector)) + nil) + +(deftest bit-vector.class.11 + (typep (make-array '(2 2) :element-type 'bit + :initial-element 0) + (find-class 'bit-vector)) + nil) diff --git a/ansi-tests/bit-xor.lsp b/ansi-tests/bit-xor.lsp new file mode 100644 index 0000000..a2b58dd --- /dev/null +++ b/ansi-tests/bit-xor.lsp @@ -0,0 +1,244 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Jan 26 19:35:46 2003 +;;;; Contains: Tests of BIT-XOR + +(in-package :cl-test) + +(deftest bit-xor.1 + (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (values (bit-xor s1 s2) s1 s2)) + #0a0 + #0a0 + #0a0) + +(deftest bit-xor.2 + (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (values (bit-xor s1 s2) s1 s2)) + #0a1 + #0a1 + #0a0) + +(deftest bit-xor.3 + (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (values (bit-xor s1 s2) s1 s2)) + #0a1 + #0a0 + #0a1) + +(deftest bit-xor.4 + (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (values (bit-xor s1 s2) s1 s2)) + #0a0 + #0a1 + #0a1) + +(deftest bit-xor.5 + (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) + (s2 (make-array nil :initial-element 0 :element-type 'bit)) + (s3 (make-array nil :initial-element 1 :element-type 'bit)) + (result (bit-xor s1 s2 s3))) + (values s1 s2 s3 result (eqt s3 result))) + #0a0 + #0a0 + #0a0 + #0a0 + t) + +(deftest bit-xor.6 + (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) + (s2 (make-array nil :initial-element 1 :element-type 'bit)) + (s3 (make-array nil :initial-element 1 :element-type 'bit)) + (result (bit-xor s1 s2 s3))) + (values s1 s2 s3 result (eqt s3 result))) + #0a1 + #0a1 + #0a0 + #0a0 + t) + +(deftest bit-xor.7 + (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) + (s2 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-xor s1 s2 t))) + (values s1 s2 result (eqt s1 result))) + #0a1 + #0a0 + #0a1 + t) + + +;;; Tests on bit vectors + +(deftest bit-xor.8 + (let ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101))) + (values (check-values (bit-xor a1 a2)) a1 a2)) + #*0110 #*0011 #*0101) + +(deftest bit-xor.9 + (let* ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101)) + (result (check-values (bit-xor a1 a2 t)))) + (values result a1 a2 (eqt result a1))) + #*0110 #*0110 #*0101 t) + +(deftest bit-xor.10 + (let* ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101)) + (a3 (copy-seq #*1110)) + (result (check-values (bit-xor a1 a2 a3)))) + (values result a1 a2 a3 (eqt result a3))) + #*0110 #*0011 #*0101 #*0110 t) + +(deftest bit-xor.11 + (let ((a1 (copy-seq #*0011)) + (a2 (copy-seq #*0101))) + (values (check-values (bit-xor a1 a2 nil)) a1 a2)) + #*0110 #*0011 #*0101) + +;;; Tests on bit arrays + +(deftest bit-xor.12 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-xor a1 a2))) + (values a1 a2 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((0 1)(1 0))) + +(deftest bit-xor.13 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-xor a1 a2 t))) + (values a1 a2 result)) + #2a((0 1)(1 0)) + #2a((0 0)(1 1)) + #2a((0 1)(1 0))) + +(deftest bit-xor.14 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-xor a1 a2 nil))) + (values a1 a2 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((0 1)(1 0))) + +(deftest bit-xor.15 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (a3 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(0 0)))) + (result (bit-xor a1 a2 a3))) + (values a1 a2 a3 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((0 1)(1 0)) + #2a((0 1)(1 0))) + +;;; Adjustable arrays + +(deftest bit-xor.16 + (let* ((a1 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 1)(0 1)) + :adjustable t)) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)) + :adjustable t)) + (result (bit-xor a1 a2))) + (values a1 a2 result)) + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((0 1)(1 0))) + +;;; Displaced arrays + +(deftest bit-xor.17 + (let* ((a0 (make-array '(8) :element-type 'bit + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-xor a1 a2))) + (values a0 a1 a2 result)) + #*01010011 + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((0 1)(1 0))) + +(deftest bit-xor.18 + (let* ((a0 (make-array '(8) :element-type 'bit + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-xor a1 a2 t))) + (values a0 a1 a2 result)) + #*01100011 + #2a((0 1)(1 0)) + #2a((0 0)(1 1)) + #2a((0 1)(1 0))) + +(deftest bit-xor.19 + (let* ((a0 (make-array '(12) :element-type 'bit + :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (a3 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 8)) + (result (bit-xor a1 a2 a3))) + (values a0 a1 a2 result)) + #*010100110110 + #2a((0 1)(0 1)) + #2a((0 0)(1 1)) + #2a((0 1)(1 0))) + +(deftest bit-xor.order.1 + (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) + (s2 (make-array 1 :initial-element 0 :element-type 'bit)) + (x 0) y z) + (values + (bit-xor (progn (setf y (incf x)) s1) + (progn (setf z (incf x)) s2)) + x y z)) + #*0 2 1 2) + +;;; Error tests + +(deftest bit-xor.error.1 + (classify-error (bit-xor)) + program-error) + +(deftest bit-xor.error.2 + (classify-error (bit-xor #*000)) + program-error) + +(deftest bit-xor.error.3 + (classify-error (bit-xor #*000 #*0100 nil nil)) + program-error) + diff --git a/ansi-tests/bit.lsp b/ansi-tests/bit.lsp new file mode 100644 index 0000000..70b807c --- /dev/null +++ b/ansi-tests/bit.lsp @@ -0,0 +1,136 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Jan 26 13:22:59 2003 +;;;; Contains: Tests for accessor BIT + +(in-package :cl-test) + +(deftest bit.1 + (bit #*0010 2) + 1) + +(deftest bit.2 + (let ((a #*00000000)) + (loop for i from 0 below (length a) + collect (let ((b (copy-seq a))) + (setf (bit b i) 1) + b))) + (#*10000000 + #*01000000 + #*00100000 + #*00010000 + #*00001000 + #*00000100 + #*00000010 + #*00000001)) + +(deftest bit.3 + (let ((a #*11111111)) + (loop for i from 0 below (length a) + collect (let ((b (copy-seq a))) + (setf (bit b i) 0) + b))) + (#*01111111 + #*10111111 + #*11011111 + #*11101111 + #*11110111 + #*11111011 + #*11111101 + #*11111110)) + +(deftest bit.4 + (let ((a (make-array nil :element-type 'bit :initial-element 0))) + (values + (aref a) + (bit a) + (setf (bit a) 1) + (aref a) + (bit a))) + 0 0 1 1 1) + +(deftest bit.5 + (let ((a (make-array '(1 1) :element-type 'bit :initial-element 0))) + (values + (aref a 0 0) + (bit a 0 0) + (setf (bit a 0 0) 1) + (aref a 0 0) + (bit a 0 0))) + 0 0 1 1 1) + +(deftest bit.6 + (let ((a (make-array '(10 10) :element-type 'bit :initial-element 0))) + (values + (aref a 5 5) + (bit a 5 5) + (setf (bit a 5 5) 1) + (aref a 5 5) + (bit a 5 5))) + 0 0 1 1 1) + +;;; Check that the fill pointer is ignored + +(deftest bit.7 + (let ((a (make-array '(10) :initial-contents '(0 1 1 0 0 1 1 1 0 0) + :element-type 'bit + :fill-pointer 5))) + (values + (coerce a 'list) + (loop for i from 0 below 10 collect (bit a i)) + (loop for i from 0 below 10 + collect (setf (bit a i) (- 1 (bit a i)))) + (coerce a 'list) + (loop for i from 0 below 10 collect (bit a i)) + (fill-pointer a))) + (0 1 1 0 0) + (0 1 1 0 0 1 1 1 0 0) + (1 0 0 1 1 0 0 0 1 1) + (1 0 0 1 1) + (1 0 0 1 1 0 0 0 1 1) + 5) + +;;; Check that adjustability is not relevant + +(deftest bit.8 + (let ((a (make-array '(10) :initial-contents '(0 1 1 0 0 1 1 1 0 0) + :element-type 'bit + :adjustable t))) + (values + (coerce a 'list) + (loop for i from 0 below 10 collect (bit a i)) + (loop for i from 0 below 10 + collect (setf (bit a i) (- 1 (bit a i)))) + (coerce a 'list) + (loop for i from 0 below 10 collect (bit a i)))) + (0 1 1 0 0 1 1 1 0 0) + (0 1 1 0 0 1 1 1 0 0) + (1 0 0 1 1 0 0 0 1 1) + (1 0 0 1 1 0 0 0 1 1) + (1 0 0 1 1 0 0 0 1 1)) + +;;; Order of evaluation tests + +(deftest bit.order.1 + (let ((x 0) y z + (b (copy-seq #*01010))) + (values + (bit (progn (setf y (incf x)) b) + (progn (setf z (incf x)) 1)) + x y z)) + 1 2 1 2) + +(deftest bit.order.2 + (let ((x 0) y z w + (b (copy-seq #*01010))) + (values + (setf (bit (progn (setf y (incf x)) b) + (progn (setf z (incf x)) 1)) + (progn (setf w (incf x)) 0)) + b + x y z w)) + 0 #*00010 3 1 2 3) + +(deftest bit.error.1 + (classify-error (bit)) + program-error) diff --git a/ansi-tests/block.lsp b/ansi-tests/block.lsp new file mode 100644 index 0000000..b68d9df --- /dev/null +++ b/ansi-tests/block.lsp @@ -0,0 +1,73 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Oct 12 12:30:46 2002 +;;;; Contains: Tests of BLOCK + +(in-package :cl-test) + +(deftest block.1 + (block foo + (return-from foo 1)) + 1) + +(deftest block.2 + (block nil + (block foo + (return 'good)) + 'bad) + good) + +(deftest block.3 + (block done + (flet ((%f (x) (return-from done x))) + (%f 'good)) + 'bad) + good) + +(deftest block.4 + (block foo + (block foo + (return-from foo 'bad)) + 'good) + good) + +(deftest block.5 + (block done + (flet ((%f (x) (return-from done x))) + (mapcar #'%f '(good bad bad))) + 'bad) + good) + +(deftest block.6 + (block b1 + (return-from b1 (values)) + 1)) + +(deftest block.7 + (block b1 + (return-from b1 (values 1 2 3 4)) + 1) + 1 2 3 4) + +(deftest block.8 + (block foo) + nil) + +(deftest block.9 + (block foo (values 'a 'b) (values 'c 'd)) + c d) + +(deftest block.10 + (block done + (flet ((%f (x) (return-from done x))) + (block done (mapcar #'%f '(good bad bad)))) + 'bad) + good) + +#| +(deftest return.error.1 + (classify-error + (block nil + (return 'a 'b))) + program-error) +|# diff --git a/ansi-tests/boundp.lsp b/ansi-tests/boundp.lsp new file mode 100644 index 0000000..b0385ff --- /dev/null +++ b/ansi-tests/boundp.lsp @@ -0,0 +1,56 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Jan 14 05:58:01 2003 +;;;; Contains: Tests for BOUNDP + +(in-package :cl-test) + +(deftest boundp.error.1 + (classify-error (boundp)) + program-error) + +(deftest boundp.error.2 + (classify-error (boundp 'a 'a)) + program-error) + +(deftest boundp.error.3 + (classify-error (boundp 1)) + type-error) + +(deftest boundp.error.4 + (classify-error (boundp '(setf car))) + type-error) + +(deftest boundp.error.5 + (classify-error (boundp "abc")) + type-error) + +(deftest boundp.error.6 + (classify-error (locally (boundp "abc") t)) + type-error) + +;;; See other tests in cl-symbols.lsp + +(deftest boundp.1 + (notnot-mv (boundp 't)) + t) + +(deftest boundp.2 + (notnot-mv (boundp nil)) + t) + +(deftest boundp.3 + (notnot-mv (boundp :foo)) + t) + +(deftest boundp.4 + (boundp '#:foo) + nil) + +(deftest boundp.order.1 + (let ((i 0) x) + (values + (boundp (progn (setf x (incf i)) '#:foo)) + i x)) + nil 1 1) + diff --git a/ansi-tests/call-arguments-limit.lsp b/ansi-tests/call-arguments-limit.lsp new file mode 100644 index 0000000..60e3363 --- /dev/null +++ b/ansi-tests/call-arguments-limit.lsp @@ -0,0 +1,29 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Thu Oct 10 22:39:25 2002 +;;;; Contains: Tests for CALL-ARGUMENTS-LIMIT + +(in-package :cl-test) + +(deftest call-arguments-limit.1 + (notnot-mv (constantp 'call-arguments-limit)) + t) + +(deftest call-arguments-limit.2 + (notnot-mv (typep call-arguments-limit 'integer)) + t) + +(deftest call-arguments-limit.3 + (< call-arguments-limit 50) + nil) + +(deftest call-arguments-limit.4 + (let* ((m (min 65536 (1- call-arguments-limit))) + (args (make-list m :initial-element 'a))) + (equal (apply #'list args) args)) + t) + +(deftest call-arguments-limit.5 + (< call-arguments-limit lambda-parameters-limit) + nil) + diff --git a/ansi-tests/case.lsp b/ansi-tests/case.lsp new file mode 100644 index 0000000..3118ccc --- /dev/null +++ b/ansi-tests/case.lsp @@ -0,0 +1,171 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Oct 18 19:56:44 2002 +;;;; Contains: Tests of CASE + +(in-package :cl-test) + +(deftest case.1 + (case 'a) + nil) + +(deftest case.2 + (case 10 (10 'a)) + a) + +(deftest case.3 + (case (copy-seq "abc") ("abc" 'a)) + nil) + +(deftest case.4 + (case 'z ((a b c) 1) + ((d e) 2) + ((f z g) 3) + (t 4)) + 3) + +(deftest case.5 + (case (1+ most-positive-fixnum) + (#.(1+ most-positive-fixnum) 'a)) + a) + +(deftest case.6 + (case nil (nil 'a) (t 'b)) + b) + +(deftest case.7 + (case nil ((nil) 'a) (t 'b)) + a) + +(deftest case.8 + (case 'a (b 0) (a (values 1 2 3)) (t nil)) + 1 2 3) + +(deftest case.9 + (case 'c (b 0) (a (values 1 2 3)) (t (values 'x 'y 'z))) + x y z) + +(deftest case.10 + (case 'z (b 1) (a 2) (z (values)) (t nil))) + +(deftest case.11 + (case 'z (b 1) (a 2) (t (values)))) + +(deftest case.12 + (case t (a 10)) + nil) + +(deftest case.13 + (case t ((t) 10) (t 20)) + 10) + +(deftest case.14 + (let ((x (list 'a 'b))) + (eval `(case (quote ,x) ((,x) 1) (t 2)))) + 1) + +(deftest case.15 + (case 'otherwise ((t) 10)) + nil) + +(deftest case.16 + (case t ((otherwise) 10)) + nil) + +(deftest case.17 + (case 'a (b 0) (c 1) (otherwise 2)) + 2) + +(deftest case.18 + (case 'a (b 0) (c 1) ((otherwise) 2)) + nil) + +(deftest case.19 + (case 'a (b 0) (c 1) ((t) 2)) + nil) + +(deftest case.20 + (case #\a + ((#\b #\c) 10) + ((#\d #\e #\A) 20) + (() 30) + ((#\z #\a #\y) 40)) + 40) + +(deftest case.21 (case 1 (1 (values)))) + +(deftest case.22 (case 2 (t (values)))) + +(deftest case.23 (case 1 (1 (values 'a 'b 'c))) + a b c) + +(deftest case.24 (case 2 (t (values 'a 'b 'c))) + a b c) + +;;; Show that the key expression is evaluated only once. +(deftest case.25 + (let ((x 0)) + (values + (case (progn (incf x) 'c) + (a 1) + (b 2) + (c 3) + (t 4)) + x)) + 3 1) + +;;; Repeated keys are allowed (all but the first are ignored) + +(deftest case.26 + (case 'b ((a b c) 10) (b 20)) + 10) + +(deftest case.27 + (case 'b (b 20) ((a b c) 10)) + 20) + +(deftest case.28 + (case 'b (b 20) (b 10) (t 0)) + 20) + +;;; There are implicit progns + +(deftest case.29 + (let ((x nil)) + (values + (case 2 + (1 (setq x 'a) 'w) + (2 (setq x 'b) 'y) + (t (setq x 'c) 'z)) + x)) + y b) + +(deftest case.30 + (let ((x nil)) + (values + (case 10 + (1 (setq x 'a) 'w) + (2 (setq x 'b) 'y) + (t (setq x 'c) 'z)) + x)) + z c) + +(deftest case.31 + (case (values 'b 'c) (c 0) ((a b) 10) (t 20)) + 10) + +(deftest case.32 + (case 'a (a) (t 'b)) + nil) + +(deftest case.33 + (case 'a (b 'b) (t)) + nil) + +(deftest case.34 + (case 'a (b 'b) (otherwise)) + nil) + +;;; (deftest case.error.1 +;;; (classify-error (case)) +;;; program-error) diff --git a/ansi-tests/catch.lsp b/ansi-tests/catch.lsp new file mode 100644 index 0000000..5a3732e --- /dev/null +++ b/ansi-tests/catch.lsp @@ -0,0 +1,75 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Oct 12 13:04:02 2002 +;;;; Contains: Tests of CATCH and THROW + +(in-package :cl-test) + +(deftest catch.1 + (catch 'foo) + nil) + +(deftest catch.2 + (catch 'foo 'a) + a) + +(deftest catch.3 + (catch 'foo (values))) + +(deftest catch.4 + (catch 'foo (values 1 2 3)) + 1 2 3) + +(deftest catch.5 + (catch 'foo 'a (throw 'foo 'b) 'c) + b) + +(deftest catch.6 + (let ((tag1 (1+ most-positive-fixnum)) + (tag2 (1+ most-positive-fixnum))) + (if (eqt tag1 tag2) + 'good + (catch tag1 + (catch tag2 (throw tag1 'good)) + 'bad))) + good) + +(deftest catch.7 + (catch 'foo 'a (throw 'foo (values)) 'c)) + +(deftest catch.8 + (catch 'foo 'a (throw 'foo (values 1 2 3)) 'c) + 1 2 3) + +(deftest catch.9 + (let ((i 0)) + (catch (progn (incf i) 'foo) + (assert (eql i 1)) + (throw (progn (incf i 2) 'foo) i))) + 3) + +(deftest catch.10 + (flet ((%f (x) (throw 'foo x))) + (catch 'foo + (%f 'good) + 'bad)) + good) + +(defun catch.11-fn (x) (throw 'foo x)) + +(deftest catch.11 + (catch 'foo + (catch.11-fn 'good) + 'bad) + good) + +(deftest catch.12 + (labels ((%f (x) (throw 'foo x))) + (catch 'foo + (%f 'good) + 'bad)) + good) + +(deftest throw-error + (classify-error (throw (gensym) nil)) + control-error) diff --git a/ansi-tests/ccase.lsp b/ansi-tests/ccase.lsp new file mode 100644 index 0000000..8bbc445 --- /dev/null +++ b/ansi-tests/ccase.lsp @@ -0,0 +1,189 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Oct 18 21:06:45 2002 +;;;; Contains: Tests of CCASE + +(in-package :cl-test) + +(deftest ccase.1 + (let ((x 'b)) + (ccase x (a 1) (b 2) (c 3))) + 2) + +(deftest ccase.2 + (classify-error + (let ((x 1)) (ccase x))) + type-error) + +(deftest ccase.3 + (classify-error + (let ((x 1)) + (ccase x (a 1) (b 2) (c 3)))) + type-error) + +;;; It is legal to use T or OTHERWISE as key designators +;;; in CCASE forms. They have no special meaning here. + +(deftest ccase.4 + (classify-error + (let ((x 1)) + (ccase x (t nil)))) + type-error) + +(deftest ccase.5 + (classify-error + (let ((x 1)) + (ccase x (otherwise nil)))) + type-error) + +(deftest ccase.6 + (let ((x 'b)) + (ccase x ((a z) 1) ((y b w) 2) ((b c) 3))) + 2) + +(deftest ccase.7 + (let ((x 'z)) + (ccase x + ((a b c) 1) + ((d e) 2) + ((f z g) 3))) + 3) + +(deftest ccase.8 + (let ((x (1+ most-positive-fixnum))) + (ccase x (#.(1+ most-positive-fixnum) 'a))) + a) + +(deftest ccase.9 + (classify-error + (let (x) + (ccase x (nil 'a)))) + type-error) + +(deftest ccase.10 + (let (x) + (ccase x ((nil) 'a))) + a) + +(deftest ccase.11 + (let ((x 'a)) + (ccase x (b 0) (a (values 1 2 3)) (c nil))) + 1 2 3) + +(deftest ccase.12 + (classify-error + (let ((x t)) + (ccase x (a 10)))) + type-error) + +(deftest ccase.13 + (let ((x t)) + (ccase x ((t) 10) (t 20))) + 10) + +(deftest ccase.14 + (let ((x (list 'a 'b))) + (eval `(let ((y (quote ,x))) (ccase y ((,x) 1) (a 2))))) + 1) + +(deftest ccase.15 + (classify-error + (let ((x 'otherwise)) + (ccase x ((t) 10)))) + type-error) + +(deftest ccase.16 + (classify-error + (let ((x t)) + (ccase x ((otherwise) 10)))) + type-error) + +(deftest ccase.17 + (classify-error + (let ((x 'a)) + (ccase x (b 0) (c 1) (otherwise 2)))) + type-error) + +(deftest ccase.19 + (classify-error + (let ((x 'a)) + (ccase x (b 0) (c 1) ((t) 2)))) + type-error) + +(deftest ccase.20 + (let ((x #\a)) + (ccase x + ((#\b #\c) 10) + ((#\d #\e #\A) 20) + (() 30) + ((#\z #\a #\y) 40))) + 40) + +(deftest ccase.21 (let ((x 1)) (ccase x (1 (values)) (2 'a)))) + +(deftest ccase.23 (let ((x 1)) (ccase x (1 (values 'a 'b 'c)))) + a b c) + +;;; Show that the key expression is evaluated only once. +(deftest ccase.25 + (let ((a (vector 'a 'b 'c 'd 'e)) + (i 1)) + (values + (ccase (aref a (incf i)) + (a 1) + (b 2) + (c 3) + (d 4)) + i)) + 3 2) + +;;; Repeated keys are allowed (all but the first are ignored) + +(deftest ccase.26 + (let ((x 'b)) + (ccase x ((a b c) 10) (b 20))) + 10) + +(deftest ccase.27 + (let ((x 'b)) + (ccase x (b 20) ((a b c) 10))) + 20) + +(deftest ccase.28 + (let ((x 'b)) + (ccase x (b 20) (b 10) (d 0))) + 20) + +;;; There are implicit progns + +(deftest ccase.29 + (let ((x nil) (y 2)) + (values + (ccase y + (1 (setq x 'a) 'w) + (2 (setq x 'b) 'y) + (3 (setq x 'c) 'z)) + x)) + y b) + +(deftest ccase.30 + (let ((x 'a)) + (ccase x (a))) + nil) + +(deftest ccase.31 + (handler-bind + ((type-error #'(lambda (c) (store-value 7 c)))) + (let ((x 0)) + (ccase x + (1 :bad) + (7 :good) + (2 nil)))) + :good) + +;;; (deftest ccase.error.1 +;;; (classify-error (ccase)) +;;; program-error) + + + diff --git a/ansi-tests/cell-error-name.lsp b/ansi-tests/cell-error-name.lsp new file mode 100644 index 0000000..3a418ac --- /dev/null +++ b/ansi-tests/cell-error-name.lsp @@ -0,0 +1,51 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Mon Jan 27 22:36:48 2003 +;;;; Contains: Tests of CELL-ERROR-NAME + +(in-package :cl-test) + +(deftest cell-error-name.1 + (handler-case + (eval 'my-unbound-variable) + (cell-error (c) (cell-error-name c))) + my-unbound-variable) + +(deftest cell-error-name.2 + (handler-case + (eval '(my-undefined-function)) + ;; (warning (c) (muffle-warning c)) + (cell-error (c) (cell-error-name c))) + my-undefined-function) + +(deftest cell-error-name.3 + (cell-error-name (make-condition 'unbound-variable :name 'x)) + x) + +(deftest cell-error-name.4 + (cell-error-name (make-condition 'undefined-function :name 'f)) + f) + +(deftest cell-error-name.5 + (cell-error-name (make-condition 'unbound-slot :name 's)) + s) + +(deftest cell-error-name.6 + (let ((i 0)) + (values + (cell-error-name (progn (incf i) (make-condition + 'unbound-slot :name 's))) + i)) + s 1) + + +;;; Need test raising condition unbound-slot + + +(deftest cell-error-name.error.1 + (classify-error (cell-error-name)) + program-error) + +(deftest cell-error-name.error.2 + (classify-error (cell-error-name (make-condition 'unbound-variable :name 'foo) nil)) + program-error) diff --git a/ansi-tests/cerror.lsp b/ansi-tests/cerror.lsp new file mode 100644 index 0000000..1e60520 --- /dev/null +++ b/ansi-tests/cerror.lsp @@ -0,0 +1,56 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Feb 15 19:45:27 2003 +;;;; Contains: Tests of CERROR + + +(in-package :cl-test) + +(deftest cerror.1 + (let ((fmt "Cerror")) + (handler-case (cerror "Keep going." fmt) + (simple-error (c) (frob-simple-error c fmt)))) + t) + +(deftest cerror.2 + (let* ((fmt "Cerror") + (cnd (make-condition 'simple-error :format-control fmt))) + (handler-case (cerror "Continue on." cnd) + (simple-error (c) (frob-simple-error c fmt)))) + t) + +(deftest cerror.3 + (let ((fmt "Cerror")) + (handler-case (cerror "Continue" 'simple-error :format-control fmt) + (simple-error (c) (frob-simple-error c fmt)))) + t) + +(deftest cerror.4 + (let ((fmt "Cerror: ~A")) + (handler-case (cerror "On on" fmt 10) + (simple-error (c) (frob-simple-error c fmt 10)))) + t) + +(deftest cerror.5 + (let ((fmt (formatter "Cerror"))) + (handler-case (cerror "Keep going." fmt) + (simple-error (c) (frob-simple-error c fmt)))) + t) + +;;; Continuing from a cerror + +(deftest cerror.6 + (handler-bind ((simple-error #'(lambda (c) (continue c)))) + (progn + (cerror "Wooo" 'simple-error) + 10)) + 10) + + +(deftest cerror.error.1 + (classify-error (cerror)) + program-error) + +(deftest cerror.error.2 + (classify-error (cerror "foo")) + program-error) diff --git a/ansi-tests/char-aux.lsp b/ansi-tests/char-aux.lsp new file mode 100644 index 0000000..61d6d42 --- /dev/null +++ b/ansi-tests/char-aux.lsp @@ -0,0 +1,286 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Oct 5 20:15:55 2002 +;;;; Contains: Auxiliary functions for character tests + +(in-package :cl-test) + +(defun is-ordered-by (seq fn) + (let ((n (length seq))) + (loop for i from 0 below (1- n) + for e = (elt seq i) + always + (loop for j from (1+ i) below n + always (funcall fn e (elt seq j)))))) + +(defun is-antisymmetrically-ordered-by (seq fn) + (and (is-ordered-by seq fn) + (is-ordered-by (reverse seq) (complement fn)))) + +(defun is-case-insensitive (fn) + (loop for c across +code-chars+ + for c1 = (char-upcase c) + for c2 = (if (eql c c1) (char-downcase c) c1) + always + (loop for d across +code-chars+ + for d1 = (char-upcase d) + for d2 = (if (eql d d1) (char-downcase d) d1) + always (equiv (funcall fn c d) + (funcall fn c2 d) + (funcall fn c d2) + (funcall fn c2 d2))))) + +(defun equiv (&rest args) + (declare (dynamic-extent args)) + (cond + ((null args) t) + ((car args) + (loop for e in (cdr args) always e)) + (t (loop for e in (cdr args) never e)))) + +;;; From character.lsp +(defun char-type-error-check (fn) + (loop for x in *universe* + always (or (characterp x) + (eqt (catch-type-error (funcall fn x)) 'type-error)))) + +(defun standard-char.5.body () + (loop for i from 0 below (min 65536 char-code-limit) + always (let ((c (code-char i))) + (not (and (typep c 'standard-char) + (not (standard-char-p c))))))) + +(defun extended-char.3.body () + (loop for i from 0 below (min 65536 char-code-limit) + always (let ((c (code-char i))) + (not (and (typep c 'extended-char) + (typep c 'base-char)))))) + +(defun character.1.body () + (loop for i from 0 below (min 65536 char-code-limit) + always (let ((c (code-char i))) + (or (null c) + (let ((s (string c))) + (and + (eqlt (character c) c) + (eqlt (character s) c) + (eqlt (character (make-symbol s)) c))))))) + +(defun character.2.body () + (loop for x in *universe* + when (not (or (characterp x) + (and (stringp x) (eqlt (length x) 1)) + (and (symbolp x) (eqlt (length (symbol-name x)) 1)) + (let ((c (catch-type-error (character x)))) + (or (eqlt c 'type-error) + (let ((s (catch-type-error (string x)))) + (and (stringp s) (eqlt (char s 0) c))))))) + do (return x))) + +(defun characterp.2.body () + (loop for i from 0 below (min 65536 char-code-limit) + always (let ((c (code-char i))) + (or (null c) (characterp c))))) + +(defun characterp.3.body () + (loop for x in *universe* + always (let ((p (characterp x)) + (q (typep x 'character))) + (if p (notnot q) (not q))))) + +(defun alphanumericp.4.body () + (loop for x in *universe* + always (or (not (characterp x)) + (if (or (digit-char-p x) (alpha-char-p x)) + (alphanumericp x) + ;; The hyperspec has an example that claims alphanumeric == + ;; digit-char-p or alpha-char-p, but the text seems to suggest + ;; that there can be numeric characters for which digit-char-p + ;; returns NIL. Therefore, I've weakened the next line + ;; (not (alphanumericp x)) + t + )))) + +(defun alphanumericp.5.body () + (loop for i from 0 below (min 65536 char-code-limit) + for x = (code-char i) + always (or (not (characterp x)) + (if (or (digit-char-p x) (alpha-char-p x)) + (alphanumericp x) + ;; The hyperspec has an example that claims alphanumeric == + ;; digit-char-p or alpha-char-p, but the text seems to suggest + ;; that there can be numeric characters for which digit-char-p + ;; returns NIL. Therefore, I've weakened the next line + ;; (not (alphanumericp x)) + t + )))) + +(defun digit-char.1.body () + (loop + for r from 2 to 36 + always + (loop for i from 0 to 36 + always (let ((c (digit-char i r))) + (if (>= i r) (null c) + (eqlt c (char +extended-digit-chars+ i))))))) + +(defun digit-char-p.1.body () + (loop for x in *universe* + always (not (and (characterp x) + (not (alphanumericp x)) + (digit-char-p x))))) + +(defun digit-char-p.2.body () + (loop for i from 0 below (min 65536 char-code-limit) + for x = (code-char i) + always (or (not x) + (not (and (not (alphanumericp x)) + (digit-char-p x)))))) + +(defun digit-char-p.3.body () + (loop for r from 2 to 35 + always + (loop for i from r to 35 + for c = (char +extended-digit-chars+ i) + never (or (digit-char-p c r) + (digit-char-p (char-downcase c) r))))) + +(defun digit-char-p.4.body () + (loop for r from 2 to 35 + always + (loop for i from 0 below r + for c = (char +extended-digit-chars+ i) + always (and (eqlt (digit-char-p c r) i) + (eqlt (digit-char-p (char-downcase c) r) i))))) + +(defun standard-char-p.2.body () + (loop for x in *universe* + always (or (not (characterp x)) + (find x +standard-chars+) + (not (standard-char-p x))))) + +(defun standard-char-p.2a.body () + (loop for i from 0 below (min 65536 char-code-limit) + for x = (code-char i) + always (or (not (characterp x)) + (find x +standard-chars+) + (not (standard-char-p x))))) + +(defun char-upcase.1.body () + (loop for x in *universe* + always + (or (not (characterp x)) + (let ((u (char-upcase x))) + (and + (or (lower-case-p x) (eqlt u x)) + (eqlt u (char-upcase u))))))) + +(defun char-upcase.2.body () + (loop for i from 0 below (min 65536 char-code-limit) + for x = (code-char i) + always + (or (not x) + (let ((u (char-upcase x))) + (and + (or (lower-case-p x) (eqlt u x)) + (eqlt u (char-upcase u))))))) + +(defun char-downcase.1.body () + (loop for x in *universe* + always + (or (not (characterp x)) + (let ((u (char-downcase x))) + (and + (or (upper-case-p x) (eqlt u x)) + (eqlt u (char-downcase u))))))) + +(defun char-downcase.2.body () + (loop for i from 0 below (min 65536 char-code-limit) + for x = (code-char i) + always + (or (not x) + (let ((u (char-downcase x))) + (and + (or (upper-case-p x) (eqlt u x)) + (eqlt u (char-downcase u))))))) + +(defun both-case-p.1.body () + (loop for x in *universe* + always (or (not (characterp x)) + (if (both-case-p x) + (and (graphic-char-p x) + (or (upper-case-p x) + (lower-case-p x))) + (not (or (upper-case-p x) + (lower-case-p x))))))) + +(defun both-case-p.2.body () + (loop for i from 0 below (min 65536 char-code-limit) + for x = (code-char i) + always (or (not (characterp x)) + (if (both-case-p x) + (and (graphic-char-p x) + (or (upper-case-p x) + (lower-case-p x))) + (not (or (upper-case-p x) + (lower-case-p x))))))) + +(defun char-code.2.body () + (loop for i from 0 below (min 65536 char-code-limit) + for c = (code-char i) + always (or (not c) + (eqlt (char-code c) i)))) + +(defun char-int.2.fn () + (declare (optimize (safety 3) (speed 1) (space 1))) + (let ((c->i (make-hash-table :test #'equal)) + (i->c (make-hash-table :test #'eql))) + (flet ((%insert + (c) + (or (not (characterp c)) + (let* ((i (char-int c)) + (j (gethash c c->i)) + (d (gethash i i->c))) + (and + (or (null j) (eqlt j i)) + (or (null d) (char= c d)) + (progn + (setf (gethash c c->i) i) + (setf (gethash i i->c) c) + t)))))) + (and + (loop for i from 0 below char-code-limit + always (%insert (code-char i))) + (every #'%insert +standard-chars+) + (every #'%insert *universe*) + t)))) + +(defun char-name.1.fn () + (declare (optimize (safety 3) (speed 1) (space 1))) + (flet ((%check + (c) + (or (not (characterp c)) + (let ((name (char-name c))) + (or (null name) + (and (stringp name) + (eqlt c (name-char name)))))))) + (and + (loop for i from 0 below char-code-limit + always (%check (code-char i))) + (every #'%check +standard-chars+) + (every #'%check *universe*) + t))) + +(defun name-char.1.body () + (declare (optimize (safety 3))) + (loop for x in *universe* + for s = (catch-type-error (string x)) + always + (or (eqlt s 'type-error) + (let ((c (name-char x))) + (or (not c) + (characterp c) + (let ((name (char-name c))) + (declare (type (or null string) name)) + (and name + (string-equal name s)))))))) diff --git a/ansi-tests/char-compare.lsp b/ansi-tests/char-compare.lsp new file mode 100644 index 0000000..e26205e --- /dev/null +++ b/ansi-tests/char-compare.lsp @@ -0,0 +1,723 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Oct 5 19:36:00 2002 +;;;; Contains: Tests of character comparison functions + +(in-package :cl-test) + +;;; The character comparisons should throw a PROGRAM-ERROR when +;;; safe-called with no arguments +(deftest char-compare-no-args + (loop for f in '(char= char/= char< char> char<= char>= + char-lessp char-greaterp char-equal + char-not-lessp char-not-greaterp char-not-equal) + collect (eval `(classify-error (funcall ',f)))) + (program-error program-error program-error program-error + program-error program-error program-error program-error + program-error program-error program-error program-error + )) + +(deftest char=.1 + (is-ordered-by +code-chars+ #'(lambda (c1 c2) (not (char= c1 c2)))) + t) + +(deftest char=.2 + (loop for c across +code-chars+ + always (char= c c)) + t) + +(deftest char=.3 + (every #'char= +code-chars+) + t) + +(deftest char=.4 + (is-ordered-by +rev-code-chars+ + #'(lambda (c1 c2) (not (char= c1 c2)))) + t) + +(deftest char=.order.1 + (let ((i 0)) + (values (not (char= (progn (incf i) #\a))) i)) + nil 1) + +(deftest char=.order.2 + (let ((i 0) a b) + (values (char= (progn (setf a (incf i)) #\a) + (progn (setf b (incf i)) #\b)) + i a b)) + nil 2 1 2) + +(deftest char=.order.3 + (let ((i 0) a b c) + (values + (char= (progn (setq a (incf i)) #\a) + (progn (setq b (incf i)) #\a) + (progn (setq c (incf i)) #\b)) + i a b c)) + nil 3 1 2 3) + +;;; + +(deftest char/=.1 + (is-ordered-by +code-chars+ #'char/=) + t) + +(deftest char/=.2 + (loop for c across +code-chars+ + never (char/= c c)) + t) + +(deftest char/=.3 + (every #'char/= +code-chars+) + t) + +(deftest char/=.4 + (is-ordered-by +rev-code-chars+ #'char/=) + t) + +(deftest char/=.order.1 + (let ((i 0)) + (values (not (char/= (progn (incf i) #\a))) i)) + nil 1) + +(deftest char/=.order.2 + (let ((i 0) a b) + (values (not (char/= (progn (setf a (incf i)) #\a) + (progn (setf b (incf i)) #\b))) + i a b)) + nil 2 1 2) + +(deftest char/=.order.3 + (let ((i 0) a b c) + (values + (char/= (progn (setq a (incf i)) #\a) + (progn (setq b (incf i)) #\b) + (progn (setq c (incf i)) #\b)) + i a b c)) + nil 3 1 2 3) + +;;; + +(deftest char<=.1 + (loop for c across +code-chars+ + always (char<= c c)) + t) + +(deftest char<=.2 + (every #'char<= +code-chars+) + t) + +(deftest char<=.3 + (is-antisymmetrically-ordered-by +code-chars+ #'char<=) + t) + +(deftest char<=.4 + (is-antisymmetrically-ordered-by +lower-case-chars+ #'char<=) + t) + +(deftest char<=.5 + (is-antisymmetrically-ordered-by +upper-case-chars+ #'char<=) + t) + +(deftest char<=.6 + (is-antisymmetrically-ordered-by +digit-chars+ #'char<=) + t) + +(deftest char<=.7 + (notnot-mv (or (char<= #\9 #\A) (char<= #\Z #\0))) + t) + +(deftest char<=.8 + (notnot-mv (or (char<= #\9 #\a) (char<= #\z #\0))) + t) + +(deftest char<=.order.1 + (let ((i 0)) + (values (not (char<= (progn (incf i) #\a))) i)) + nil 1) + +(deftest char<=.order.2 + (let ((i 0) a b) + (values (not (char<= (progn (setf a (incf i)) #\a) + (progn (setf b (incf i)) #\b))) + i a b)) + nil 2 1 2) + +(deftest char<=.order.3 + (let ((i 0) a b c) + (values + (char<= (progn (setq a (incf i)) #\a) + (progn (setq b (incf i)) #\b) + (progn (setq c (incf i)) #\a)) + i a b c)) + nil 3 1 2 3) + +;;; + +(deftest char<.1 + (loop for c across +code-chars+ + never (char< c c)) + t) + +(deftest char<.2 + (every #'char< +code-chars+) + t) + +(deftest char<.3 + (is-antisymmetrically-ordered-by +code-chars+ #'char<) + t) + +(deftest char<.4 + (is-antisymmetrically-ordered-by +lower-case-chars+ #'char<) + t) + +(deftest char<.5 + (is-antisymmetrically-ordered-by +upper-case-chars+ #'char<) + t) + +(deftest char<.6 + (is-antisymmetrically-ordered-by +digit-chars+ #'char<) + t) + +(deftest char<.7 + (notnot-mv (or (char< #\9 #\A) (char< #\Z #\0))) + t) + +(deftest char<.8 + (notnot-mv (or (char< #\9 #\a) (char< #\z #\0))) + t) + +(deftest char<.order.1 + (let ((i 0)) + (values (not (char< (progn (incf i) #\a))) i)) + nil 1) + +(deftest char<.order.2 + (let ((i 0) a b) + (values (not (char< (progn (setf a (incf i)) #\a) + (progn (setf b (incf i)) #\b))) + i a b)) + nil 2 1 2) + +(deftest char<.order.3 + (let ((i 0) a b c) + (values + (char< (progn (setq a (incf i)) #\a) + (progn (setq b (incf i)) #\b) + (progn (setq c (incf i)) #\a)) + i a b c)) + nil 3 1 2 3) + +(deftest char<.order.4 + (let ((i 0) a b c) + (values + (char< (progn (setq a (incf i)) #\b) + (progn (setq b (incf i)) #\a) + (progn (setq c (incf i)) #\b)) + i a b c)) + nil 3 1 2 3) + +;;; + +(deftest char>=.1 + (loop for c across +code-chars+ + always (char>= c c)) + t) + +(deftest char>=.2 + (every #'char>= +code-chars+) + t) + +(deftest char>=.3 + (is-antisymmetrically-ordered-by +rev-code-chars+ #'char>=) + t) + +(deftest char>=.4 + (is-antisymmetrically-ordered-by (reverse +lower-case-chars+) #'char>=) + t) + +(deftest char>=.5 + (is-antisymmetrically-ordered-by (reverse +upper-case-chars+) #'char>=) + t) + +(deftest char>=.6 + (is-antisymmetrically-ordered-by (reverse +digit-chars+) #'char>=) + t) + +(deftest char>=.7 + (notnot-mv (or (char>= #\A #\9) (char>= #\0 #\Z))) + t) + +(deftest char>=.8 + (notnot-mv (or (char>= #\a #\9) (char>= #\0 #\z))) + t) + +(deftest char>=.order.1 + (let ((i 0)) + (values (not (char>= (progn (incf i) #\a))) i)) + nil 1) + +(deftest char>=.order.2 + (let ((i 0) a b) + (values (not (char>= (progn (setf a (incf i)) #\b) + (progn (setf b (incf i)) #\a))) + i a b)) + nil 2 1 2) + +(deftest char>=.order.3 + (let ((i 0) a b c) + (values + (char>= (progn (setq a (incf i)) #\b) + (progn (setq b (incf i)) #\a) + (progn (setq c (incf i)) #\b)) + i a b c)) + nil 3 1 2 3) + +(deftest char>=.order.4 + (let ((i 0) a b c) + (values + (char>= (progn (setq a (incf i)) #\a) + (progn (setq b (incf i)) #\b) + (progn (setq c (incf i)) #\a)) + i a b c)) + nil 3 1 2 3) + +;;; + +(deftest char>.1 + (loop for c across +code-chars+ + never (char> c c)) + t) + +(deftest char>.2 + (every #'char> +code-chars+) + t) + +(deftest char>.3 + (is-antisymmetrically-ordered-by +rev-code-chars+ #'char>) + t) + +(deftest char>.4 + (is-antisymmetrically-ordered-by (reverse +lower-case-chars+) #'char>) + t) + +(deftest char>.5 + (is-antisymmetrically-ordered-by (reverse +upper-case-chars+) #'char>) + t) + +(deftest char>.6 + (is-antisymmetrically-ordered-by (reverse +digit-chars+) #'char>) + t) + +(deftest char>.7 + (notnot-mv (or (char> #\A #\9) (char> #\0 #\Z))) + t) + +(deftest char>.8 + (notnot-mv (or (char> #\a #\9) (char> #\0 #\z))) + t) + +(deftest char>.order.1 + (let ((i 0)) + (values (not (char> (progn (incf i) #\a))) i)) + nil 1) + +(deftest char>.order.2 + (let ((i 0) a b) + (values (not (char> (progn (setf a (incf i)) #\b) + (progn (setf b (incf i)) #\a))) + i a b)) + nil 2 1 2) + +(deftest char>.order.3 + (let ((i 0) a b c) + (values + (char> (progn (setq a (incf i)) #\b) + (progn (setq b (incf i)) #\a) + (progn (setq c (incf i)) #\b)) + i a b c)) + nil 3 1 2 3) + +(deftest char>.order.4 + (let ((i 0) a b c) + (values + (char> (progn (setq a (incf i)) #\a) + (progn (setq b (incf i)) #\b) + (progn (setq c (incf i)) #\a)) + i a b c)) + nil 3 1 2 3) + +;;; Case-insensitive comparisons + +(deftest char-equal.1 + (is-ordered-by +code-chars+ + #'(lambda (c1 c2) + (or (char= (char-downcase c1) + (char-downcase c2)) + (not (char-equal c1 c2))))) + t) + +(deftest char-equal.2 + (loop for c across +code-chars+ + always (char-equal c c)) + t) + +(deftest char-equal.3 + (loop for c across +code-chars+ + always (char-equal c)) + t) + +(deftest char-equal.4 + (is-ordered-by +rev-code-chars+ + #'(lambda (c1 c2) + (or (char= (char-downcase c1) + (char-downcase c2)) + (not (char-equal c1 c2))))) + t) + +(deftest char-equal.order.1 + (let ((i 0)) + (values (not (char-equal (progn (incf i) #\a))) i)) + nil 1) + +(deftest char-equal.order.2 + (let ((i 0) a b) + (values (char-equal (progn (setf a (incf i)) #\b) + (progn (setf b (incf i)) #\a)) + i a b)) + nil 2 1 2) + +(deftest char-equal.order.3 + (let ((i 0) a b c) + (values + (char-equal (progn (setq a (incf i)) #\a) + (progn (setq b (incf i)) #\a) + (progn (setq c (incf i)) #\b)) + i a b c)) + nil 3 1 2 3) + +(deftest char-equal.order.4 + (let ((i 0) a b c) + (values + (char-equal (progn (setq a (incf i)) #\a) + (progn (setq b (incf i)) #\b) + (progn (setq c (incf i)) #\a)) + i a b c)) + nil 3 1 2 3) + +;;; + +(deftest char-not-equal.1 + (is-ordered-by +code-chars+ #'(lambda (c1 c2) + (or (char= (char-downcase c1) + (char-downcase c2)) + (char-not-equal c1 c2)))) + t) + +(deftest char-not-equal.2 + (loop for c across +code-chars+ + never (char-not-equal c c)) + t) + +(deftest char-not-equal.3 + (every #'char-not-equal +code-chars+) + t) + +(deftest char-not-equal.4 + (is-ordered-by +rev-code-chars+ #'(lambda (c1 c2) + (or (char= (char-downcase c1) + (char-downcase c2)) + (char-not-equal c1 c2)))) + t) + +(deftest char-not-equal.order.1 + (let ((i 0)) + (values (not (char-not-equal (progn (incf i) #\a))) i)) + nil 1) + +(deftest char-not-equal.order.2 + (let ((i 0) a b) + (values (not (char-not-equal (progn (setf a (incf i)) #\b) + (progn (setf b (incf i)) #\a))) + i a b)) + nil 2 1 2) + +(deftest char-not-equal.order.3 + (let ((i 0) a b c) + (values + (char-not-equal (progn (setq a (incf i)) #\a) + (progn (setq b (incf i)) #\b) + (progn (setq c (incf i)) #\b)) + i a b c)) + nil 3 1 2 3) + +(deftest char-not-equal.order.4 + (let ((i 0) a b c) + (values + (char-not-equal (progn (setq a (incf i)) #\a) + (progn (setq b (incf i)) #\a) + (progn (setq c (incf i)) #\b)) + i a b c)) + nil 3 1 2 3) + +;;; + +(deftest char-not-greaterp.1 + (loop for c across +code-chars+ + always (char-not-greaterp c c)) + t) + +(deftest char-not-greaterp.2 + (every #'char-not-greaterp +code-chars+) + t) + +(deftest char-not-greaterp.3 + (is-case-insensitive #'char-not-greaterp) + t) + +(deftest char-not-greaterp.4 + (is-antisymmetrically-ordered-by +lower-case-chars+ #'char-not-greaterp) + t) + +(deftest char-not-greaterp.5 + (is-antisymmetrically-ordered-by +upper-case-chars+ #'char-not-greaterp) + t) + +(deftest char-not-greaterp.6 + (is-antisymmetrically-ordered-by +digit-chars+ #'char-not-greaterp) + t) + +(deftest char-not-greaterp.7 + (notnot-mv (or (char-not-greaterp #\9 #\A) (char-not-greaterp #\Z #\0))) + t) + +(deftest char-not-greaterp.8 + (notnot-mv (or (char-not-greaterp #\9 #\a) (char-not-greaterp #\z #\0))) + t) + +(deftest char-not-greaterp.order.1 + (let ((i 0)) + (values (not (char-not-greaterp (progn (incf i) #\a))) i)) + nil 1) + +(deftest char-not-greaterp.order.2 + (let ((i 0) a b) + (values (not (char-not-greaterp (progn (setf a (incf i)) #\a) + (progn (setf b (incf i)) #\b))) + i a b)) + nil 2 1 2) + +(deftest char-not-greaterp.order.3 + (let ((i 0) a b c) + (values + (char-not-greaterp (progn (setq a (incf i)) #\a) + (progn (setq b (incf i)) #\b) + (progn (setq c (incf i)) #\a)) + i a b c)) + nil 3 1 2 3) + +(deftest char-not-greaterp.order.4 + (let ((i 0) a b c) + (values + (char-not-greaterp (progn (setq a (incf i)) #\b) + (progn (setq b (incf i)) #\a) + (progn (setq c (incf i)) #\a)) + i a b c)) + nil 3 1 2 3) + +;;; + +(deftest char-lessp.1 + (loop for c across +code-chars+ + never (char-lessp c c)) + t) + +(deftest char-lessp.2 + (every #'char-lessp +code-chars+) + t) + +(deftest char-lessp.3 + (is-case-insensitive #'char-lessp) + t) + +(deftest char-lessp.4 + (is-antisymmetrically-ordered-by +lower-case-chars+ #'char-lessp) + t) + +(deftest char-lessp.5 + (is-antisymmetrically-ordered-by +upper-case-chars+ #'char-lessp) + t) + +(deftest char-lessp.6 + (is-antisymmetrically-ordered-by +digit-chars+ #'char-lessp) + t) + +(deftest char-lessp.7 + (notnot-mv (or (char-lessp #\9 #\A) (char-lessp #\Z #\0))) + t) + +(deftest char-lessp.8 + (notnot-mv (or (char-lessp #\9 #\a) (char-lessp #\z #\0))) + t) + +(deftest char-lessp.order.1 + (let ((i 0)) + (values (not (char-lessp (progn (incf i) #\a))) i)) + nil 1) + +(deftest char-lessp.order.2 + (let ((i 0) a b) + (values (not (char-lessp (progn (setf a (incf i)) #\a) + (progn (setf b (incf i)) #\b))) + i a b)) + nil 2 1 2) + +(deftest char-lessp.order.3 + (let ((i 0) a b c) + (values + (char-lessp (progn (setq a (incf i)) #\a) + (progn (setq b (incf i)) #\b) + (progn (setq c (incf i)) #\a)) + i a b c)) + nil 3 1 2 3) + +(deftest char-lessp.order.4 + (let ((i 0) a b c) + (values + (char-lessp (progn (setq a (incf i)) #\b) + (progn (setq b (incf i)) #\a) + (progn (setq c (incf i)) #\a)) + i a b c)) + nil 3 1 2 3) + +;;; + +(deftest char-not-lessp.1 + (loop for c across +code-chars+ + always (char-not-lessp c c)) + t) + +(deftest char-not-lessp.2 + (every #'char-not-lessp +code-chars+) + t) + +(deftest char-not-lessp.3 + (is-case-insensitive #'char-not-lessp) + t) + +(deftest char-not-lessp.4 + (is-antisymmetrically-ordered-by (reverse +lower-case-chars+) + #'char-not-lessp) + t) + +(deftest char-not-lessp.5 + (is-antisymmetrically-ordered-by (reverse +upper-case-chars+) #'char-not-lessp) + t) + +(deftest char-not-lessp.6 + (is-antisymmetrically-ordered-by (reverse +digit-chars+) #'char-not-lessp) + t) + +(deftest char-not-lessp.7 + (notnot-mv (or (char-not-lessp #\A #\9) (char-not-lessp #\0 #\Z))) + t) + +(deftest char-not-lessp.8 + (notnot-mv (or (char-not-lessp #\a #\9) (char-not-lessp #\0 #\z))) + t) + +(deftest char-not-lessp.order.1 + (let ((i 0)) + (values (not (char-not-lessp (progn (incf i) #\a))) i)) + nil 1) + +(deftest char-not-lessp.order.2 + (let ((i 0) a b) + (values (not (char-not-lessp (progn (setf a (incf i)) #\b) + (progn (setf b (incf i)) #\a))) + i a b)) + nil 2 1 2) + +(deftest char-not-lessp.order.3 + (let ((i 0) a b c) + (values + (char-not-lessp (progn (setq a (incf i)) #\b) + (progn (setq b (incf i)) #\a) + (progn (setq c (incf i)) #\b)) + i a b c)) + nil 3 1 2 3) + +(deftest char-not-lessp.order.4 + (let ((i 0) a b c) + (values + (char-not-lessp (progn (setq a (incf i)) #\a) + (progn (setq b (incf i)) #\b) + (progn (setq c (incf i)) #\b)) + i a b c)) + nil 3 1 2 3) + +;;; + +(deftest char-greaterp.1 + (loop for c across +code-chars+ + never (char-greaterp c c)) + t) + +(deftest char-greaterp.2 + (every #'char-greaterp +code-chars+) + t) + +(deftest char-greaterp.3 + (is-case-insensitive #'char-greaterp) + t) + +(deftest char-greaterp.4 + (is-antisymmetrically-ordered-by (reverse +lower-case-chars+) + #'char-greaterp) + t) + +(deftest char-greaterp.5 + (is-antisymmetrically-ordered-by (reverse +upper-case-chars+) #'char-greaterp) + t) + +(deftest char-greaterp.6 + (is-antisymmetrically-ordered-by (reverse +digit-chars+) #'char-greaterp) + t) + +(deftest char-greaterp.7 + (notnot-mv (or (char-greaterp #\A #\9) (char-greaterp #\0 #\Z))) + t) + +(deftest char-greaterp.8 + (notnot-mv (or (char-greaterp #\a #\9) (char-greaterp #\0 #\z))) + t) + +(deftest char-greaterp.order.1 + (let ((i 0)) + (values (not (char-greaterp (progn (incf i) #\a))) i)) + nil 1) + +(deftest char-greaterp.order.2 + (let ((i 0) a b) + (values (not (char-greaterp (progn (setf a (incf i)) #\b) + (progn (setf b (incf i)) #\a))) + i a b)) + nil 2 1 2) + +(deftest char-greaterp.order.3 + (let ((i 0) a b c) + (values + (char-greaterp (progn (setq a (incf i)) #\b) + (progn (setq b (incf i)) #\a) + (progn (setq c (incf i)) #\b)) + i a b c)) + nil 3 1 2 3) + +(deftest char-greaterp.order.4 + (let ((i 0) a b c) + (values + (char-greaterp (progn (setq a (incf i)) #\a) + (progn (setq b (incf i)) #\b) + (progn (setq c (incf i)) #\a)) + i a b c)) + nil 3 1 2 3) diff --git a/ansi-tests/char-schar.lsp b/ansi-tests/char-schar.lsp new file mode 100644 index 0000000..617316f --- /dev/null +++ b/ansi-tests/char-schar.lsp @@ -0,0 +1,164 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Sep 29 21:04:44 2002 +;;;; Contains: Tests of CHAR and SCHAR accessors + +(in-package :cl-test) + +(deftest char.1 + (let ((s "abcd")) + (values (char s 0) (char s 1) (char s 2) (char s 3))) + #\a #\b #\c #\d) + +(deftest char.2 + (let ((s0 (copy-seq "abcd")) + (s1 (copy-seq "abcd")) + (s2 (copy-seq "abcd")) + (s3 (copy-seq "abcd"))) + (setf (char s0 0) #\X) + (setf (char s1 1) #\X) + (setf (char s2 2) #\X) + (setf (char s3 3) #\X) + (values s0 s1 s2 s3)) + "Xbcd" "aXcd" "abXd" "abcX") + +(deftest char.3 + (let ((s (make-array 6 :element-type 'character + :initial-contents '(#\a #\b #\c #\d #\e #\f)))) + (setf (char s 3) #\X) + s) + "abcXef") + +(deftest char.4 + (let ((s (make-array 6 :element-type 'character + :initial-contents '(#\a #\b #\c #\d #\e #\f) + :fill-pointer 4))) + (setf (char s 3) #\X) + s) + "abcX") + +(deftest char.5 + (let ((s (make-string 5 :initial-element #\a))) + (setf (char s 3) #\X) + s) + "aaaXa") + +(deftest char.6 + (let ((s (make-string 5 :initial-element #\a :element-type 'base-char))) + (setf (char s 3) #\X) + s) + "aaaXa") + +(deftest char.7 + (let ((s (make-string 5 :initial-element #\a :element-type 'character))) + (setf (char s 3) #\X) + s) + "aaaXa") + +(deftest char.8 + (let ((s (make-array 6 :element-type 'character + :initial-contents '(#\a #\b #\c #\d #\e #\f) + :fill-pointer 4))) + (setf (char s 5) #\X) + (setf (fill-pointer s) 6) + s) + "abcdeX") + +(deftest char.9 + (let ((s (make-string 5 :initial-element #\a + :element-type 'base-char))) + (setf (char s 3) #\X) + s) + "aaaXa") + +(deftest char.10 + (let ((s (make-string 5 :initial-element #\a + :element-type 'standard-char))) + (setf (char s 3) #\X) + s) + "aaaXa") + +(deftest char.order.1 + (let ((i 0) a b) + (values + (char (progn (setf a (incf i)) "abc") + (progn (setf b (incf i)) 1)) + i a b)) + #\b 2 1 2) + +(deftest char.order.2 + (let ((i 0) a b c (s (make-string 5 :initial-element #\z))) + (values + (setf + (char (progn (setf a (incf i)) s) + (progn (setf b (incf i)) 1)) + (progn (setf c (incf i)) #\a)) + s i a b c)) + #\a "zazzz" 3 1 2 3) + +;;; Tests of schar + +(deftest schar.1 + (let ((s "abcd")) (values (schar s 0) (schar s 1) (schar s 2) (schar s 3))) + #\a #\b #\c #\d) + +(deftest schar.2 + (let ((s0 (copy-seq "abcd")) + (s1 (copy-seq "abcd")) + (s2 (copy-seq "abcd")) + (s3 (copy-seq "abcd"))) + (setf (schar s0 0) #\X) + (setf (schar s1 1) #\X) + (setf (schar s2 2) #\X) + (setf (schar s3 3) #\X) + (values s0 s1 s2 s3)) + "Xbcd" "aXcd" "abXd" "abcX") + +(deftest schar.3 + (let ((s (make-string 6 :initial-element #\x))) + (setf (schar s 2) #\X) + s) + "xxXxxx") + +(deftest schar.4 + (let ((s (make-string 6 :initial-element #\x :element-type 'character))) + (setf (schar s 2) #\X) + s) + "xxXxxx") + +(deftest schar.5 + (let ((s (make-string 6 :initial-element #\x :element-type 'standard-char))) + (setf (schar s 2) #\X) + s) + "xxXxxx") + +(deftest schar.6 + (let ((s (make-string 6 :initial-element #\x :element-type 'base-char))) + (setf (schar s 2) #\X) + s) + "xxXxxx") + +(deftest schar.7 + (let ((s (make-string 6 :initial-element #\x + :element-type 'standard-char))) + (setf (schar s 2) #\X) + s) + "xxXxxx") + +(deftest schar.order.1 + (let ((i 0) a b) + (values + (schar (progn (setf a (incf i)) "abc") + (progn (setf b (incf i)) 1)) + i a b)) + #\b 2 1 2) + +(deftest schar.order.2 + (let ((i 0) a b c (s (copy-seq "zzzzz"))) + (values + (setf + (schar (progn (setf a (incf i)) s) + (progn (setf b (incf i)) 1)) + (progn (setf c (incf i)) #\a)) + s i a b c)) + #\a "zazzz" 3 1 2 3) diff --git a/ansi-tests/character.lsp b/ansi-tests/character.lsp new file mode 100644 index 0000000..4f5b06d --- /dev/null +++ b/ansi-tests/character.lsp @@ -0,0 +1,651 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Oct 5 12:52:18 2002 +;;;; Contains: Tests associated with the class CHARACTER + +(in-package :cl-test) + +(deftest character-class.1 + (subtypep* 'character t) + t t) + +(deftest base-char.1 + (subtypep* 'base-char 'character) + t t) + +(deftest base-char.2 + (subtypep* 'base-char t) + t t) + +(deftest base-char.3 + (every #'(lambda (c) (typep c 'base-char)) +standard-chars+) + t) + +(deftest standard-char.1 + (subtypep* 'standard-char 'base-char) + t t) + +(deftest standard-char.2 + (subtypep* 'standard-char 'character) + t t) + +(deftest standard-char.3 + (subtypep* 'standard-char t) + t t) + +(deftest standard-char.4 + (every #'(lambda (c) (typep c 'standard-char)) +standard-chars+) + t) + +(deftest standard-char.5 + (standard-char.5.body) + t) + +(deftest extended-char.1 + (subtypep* 'extended-char 'character) + t t) + +(deftest extended-char.2 + (subtypep* 'extended-char t) + t t) + +(deftest extended-char.3 + (extended-char.3.body) + t) + +;;; + +(deftest character.1 + (character.1.body) + t) + +(deftest character.2 + (character.2.body) + nil) + +(deftest character.order.1 + (let ((i 0)) + (values + (character (progn (incf i) #\a)) + i)) + #\a 1) + +(deftest character.error.1 + (classify-error (character)) + program-error) + +(deftest character.error.2 + (classify-error (character #\a #\a)) + program-error) + +;;; + +(deftest characterp.1 + (every #'characterp +standard-chars+) + t) + +(deftest characterp.2 + (characterp.2.body) + t) + +(deftest characterp.3 + (characterp.3.body) + t) + +(deftest characterp.order.1 + (let ((i 0)) + (values + (characterp (incf i)) + i)) + nil 1) + +(deftest characterp.error.1 + (classify-error (characterp)) + program-error) + +(deftest characterp.error.2 + (classify-error (characterp #\a #\b)) + program-error) + + +(deftest alpha-char-p.1 + (loop for c across +standard-chars+ + always + (or (find c +alpha-chars+) + (not (alpha-char-p c)))) + t) + +;;; + +(deftest alpha-char-p.2 + (every #'alpha-char-p +alpha-chars+) + t) + +(deftest alpha-char-p.3 + (char-type-error-check #'alpha-char-p) + t) + +(deftest alpha-char-p.order.1 + (let ((i 0)) + (values + (alpha-char-p (progn (incf i) #\8)) + i)) + nil 1) + +(deftest alpha-char-p.error.1 + (classify-error (alpha-char-p)) + program-error) + +(deftest alpha-char-p.error.2 + (classify-error (alpha-char-p #\a #\b)) + program-error) + +;;; + +(deftest alphanumericp.1 + (loop for c across +standard-chars+ + always + (or (find c +alphanumeric-chars+) + (not (alphanumericp c)))) + t) + +(deftest alphanumericp.2 + (every #'alphanumericp +alphanumeric-chars+) + t) + +(deftest alphanumericp.3 + (char-type-error-check #'alphanumericp) + t) + +(deftest alphanumericp.4 + (alphanumericp.4.body) + t) + +(deftest alphanumericp.5 + (alphanumericp.5.body) + t) + +(deftest alphanumericp.order.1 + (let ((i 0)) + (values + (alphanumericp (progn (incf i) #\?)) + i)) + nil 1) + +(deftest alphanumericp.error.1 + (classify-error (alphanumericp)) + program-error) + +(deftest alphanumericp.error.2 + (classify-error (alphanumericp #\a #\b)) + program-error) + +;;; + +(deftest digit-char.1 + (digit-char.1.body) + t) + +(deftest digit-char.2 + (map 'list #'digit-char (loop for i from 0 to 39 collect i)) + (#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 + nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil + nil nil nil nil nil nil nil nil nil nil)) + +(deftest digit-char.order.1 + (let ((i 0)) + (values + (digit-char (incf i)) + i)) + #\1 1) + +(deftest digit-char.order.2 + (let ((i 0) x) + (values + (digit-char (incf i) (progn (setf x (incf i)) 10)) + i x)) + #\1 2 2) + +(deftest digit-char.error.1 + (classify-error (digit-char)) + program-error) + +(deftest digit-char.error.2 + (classify-error (digit-char 0 10 'foo)) + program-error) + +;;; + +(deftest digit-char-p.1 + (digit-char-p.1.body) + t) + +(deftest digit-char-p.2 + (digit-char-p.2.body) + t) + +(deftest digit-char-p.3 + (digit-char-p.3.body) + t) + +(deftest digit-char-p.4 + (digit-char-p.4.body) + t) + +(deftest digit-char-p.5 + (loop for i from 10 to 35 + for c = (char +extended-digit-chars+ i) + never (or (digit-char-p c) + (digit-char-p (char-downcase c)))) + t) + +(deftest digit-char-p.6 + (loop for i from 0 below 10 + for c = (char +extended-digit-chars+ i) + always (eqlt (digit-char-p c) i)) + t) + +(deftest digit-char-p.order.1 + (let ((i 0)) + (values + (digit-char-p (progn (incf i) #\0)) + i)) + 0 1) + +(deftest digit-char-p.order.2 + (let ((i 0) x y) + (values + (digit-char-p (progn (setf x (incf i)) #\0) + (progn (setf y (incf i)) 10)) + i x y)) + 0 2 1 2) + +(deftest digit-char-p.error.1 + (classify-error (digit-char-p)) + program-error) + +(deftest digit-char-p.error.2 + (classify-error (digit-char-p #\1 10 'foo)) + program-error) + +;;; + +(deftest graphic-char-p.1 + (loop for c across +standard-chars+ + always (if (eqlt c #\Newline) + (not (graphic-char-p c)) + (graphic-char-p c))) + t) + +(deftest graphic-char-p.2 + (loop + for name in '("Rubout" "Page" "Backspace" "Tab" "Linefeed" "Return") + for c = (name-char name) + when (and c (graphic-char-p c)) collect c) + nil) + +(deftest graphic-char-p.3 + (char-type-error-check #'graphic-char-p) + t) + +(deftest graphic-char-p.order.1 + (let ((i 0)) + (values + (not (graphic-char-p (progn (incf i) #\a))) + i)) + nil 1) + +(deftest graphic-char-p.error.1 + (classify-error (graphic-char-p)) + program-error) + +(deftest graphic-char-p.error.2 + (classify-error (graphic-char-p #\a #\a)) + program-error) + +;;; + +(deftest standard-char-p.1 + (every #'standard-char-p +standard-chars+) + t) + +(deftest standard-char-p.2 + (standard-char-p.2.body) + t) + +(deftest standard-char-p.2a + (standard-char-p.2a.body) + t) + +(deftest standard-char-p.3 + (char-type-error-check #'standard-char-p) + t) + +(deftest standard-char-p.order.1 + (let ((i 0)) + (values + (not (standard-char-p (progn (incf i) #\a))) + i)) + nil 1) + +(deftest standard-char-p.error.1 + (classify-error (standard-char-p)) + program-error) + +(deftest standard-char-p.error.2 + (classify-error (standard-char-p #\a #\a)) + program-error) + +;;; + +(deftest char-upcase.1 + (char-upcase.1.body) + t) + +(deftest char-upcase.2 + (char-upcase.2.body) + t) + +(deftest char-upcase.3 + (map 'string #'char-upcase +alpha-chars+) + "ABCDEFGHIJKLMNOPQRSTUVWXYZABCDEFGHIJKLMNOPQRSTUVWXYZ") + +(deftest char-upcase.4 + (char-type-error-check #'char-upcase) + t) + +(deftest char-upcase.order.1 + (let ((i 0)) + (values + (char-upcase (progn (incf i) #\a)) + i)) + #\A 1) + +(deftest char-upcase.error.1 + (classify-error (char-upcase)) + program-error) + +(deftest char-upcase.error.2 + (classify-error (char-upcase #\a #\a)) + program-error) + +;;; + +(deftest char-downcase.1 + (char-downcase.1.body) + t) + +(deftest char-downcase.2 + (char-downcase.2.body) + t) + +(deftest char-downcase.3 + (map 'string #'char-downcase +alpha-chars+) + "abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz") + +(deftest char-downcase.4 + (char-type-error-check #'char-downcase) + t) + +(deftest char-downcase.order.1 + (let ((i 0)) + (values + (char-downcase (progn (incf i) #\A)) + i)) + #\a 1) + +(deftest char-downcase.error.1 + (classify-error (char-downcase)) + program-error) + +(deftest char-downcase.error.2 + (classify-error (char-downcase #\A #\A)) + program-error) + +;;; + +(deftest upper-case-p.1 + (find-if-not #'upper-case-p +standard-chars+ :start 26 :end 52) + nil) + +(deftest upper-case-p.2 + (find-if #'upper-case-p +standard-chars+ :end 26) + nil) + +(deftest upper-case-p.3 + (find #'upper-case-p +standard-chars+ :start 52) + nil) + +(deftest upper-case-p.4 + (char-type-error-check #'upper-case-p) + t) + +(deftest upper-case-p.order.1 + (let ((i 0)) + (values + (upper-case-p (progn (incf i) #\a)) + i)) + nil 1) + +(deftest upper-case-p.error.1 + (classify-error (upper-case-p)) + program-error) + +(deftest upper-case-p.error.2 + (classify-error (upper-case-p #\a #\A)) + program-error) + +;;; + +(deftest lower-case-p.1 + (find-if-not #'lower-case-p +standard-chars+ :end 26) + nil) + +(deftest lower-case-p.2 + (find-if #'lower-case-p +standard-chars+ :start 26) + nil) + +(deftest lower-case-p.3 + (char-type-error-check #'lower-case-p) + t) + +(deftest lower-case-p.order.1 + (let ((i 0)) + (values + (lower-case-p (progn (incf i) #\A)) + i)) + nil 1) + +(deftest lower-case-p.error.1 + (classify-error (lower-case-p)) + program-error) + +(deftest lower-case-p.error.2 + (classify-error (lower-case-p #\a #\a)) + program-error) + +;;; + +(deftest both-case-p.1 + (both-case-p.1.body) + t) + +(deftest both-case-p.2 + (both-case-p.2.body) + t) + +(deftest both-case-p.3 + (char-type-error-check #'both-case-p) + t) + +(deftest both-case-p.order.1 + (let ((i 0)) + (values + (both-case-p (progn (incf i) #\5)) + i)) + nil 1) + +(deftest both-case-p.error.1 + (classify-error (both-case-p)) + program-error) + +(deftest both-case-p.error.2 + (classify-error (both-case-p #\a #\a)) + program-error) + +;;; + +(deftest char-code.1 + (char-type-error-check #'char-code) + t) + +(deftest char-code.2 + (char-code.2.body) + t) + +(deftest char-code.order.1 + (let ((i 0)) + (values + (not (numberp (char-code (progn (incf i) #\a)))) + i)) + nil 1) + +(deftest char-code.error.1 + (classify-error (char-code)) + program-error) + +(deftest char-code.error.2 + (classify-error (char-code #\a #\a)) + program-error) + +;;; + +(deftest code-char.1 + (loop for x across +standard-chars+ + always (eqlt (code-char (char-code x)) x)) + t) + +(deftest code-char.order.1 + (let ((i 0)) + (values + (code-char (progn (incf i) (char-code #\a))) + i)) + #\a 1) + +(deftest code-char.error.1 + (classify-error (code-char)) + program-error) + +(deftest code-char.error.2 + (classify-error (code-char 1 1)) + program-error) + +;;; + +(deftest char-int.1 + (loop for x across +standard-chars+ + always (eqlt (char-int x) (char-code x))) + t) + +(deftest char-int.2 + (char-int.2.fn) + t) + +(deftest char-int.order.1 + (let ((i 0)) + (values + (code-char (char-int (progn (incf i) #\a))) + i)) + #\a 1) + +(deftest char-int.error.1 + (classify-error (char-int)) + program-error) + +(deftest char-int.error.2 + (classify-error (char-int #\a #\a)) + program-error) + +;;; + +(deftest char-name.1 + (char-name.1.fn) + t) + +(deftest char-name.2 + (notnot-mv (string= (char-name #\Space) "Space")) + t) + +(deftest char-name.3 + (notnot-mv (string= (char-name #\Newline) "Newline")) + t) + +;;; Check that the names of various semi-standard characters are +;;; appropriate. This is complicated by the possibility that two different +;;; names may refer to the same character (as is allowed by the standard, +;;; for example in the case of Newline and Linefeed). + +(deftest char-name.4 + (loop for s in '("Rubout" "Page" "Backspace" "Return" "Tab" "Linefeed") + for c = (name-char s) + unless (or (not c) + ;; If the char-name is not even string-equal, + ;; assume we're sharing the character with some other + ;; name, and assume it's ok + (not (string-equal (char-name c) s)) + (string= (char-name c) s)) + ;; Collect list of cases that failed + collect (list s c (char-name c))) + nil) + +(deftest char-name.5 + (char-type-error-check #'char-name) + t) + +(deftest char-name.order.1 + (let ((i 0)) + (values + (char-name (progn (incf i) #\Space)) + i)) + "Space" 1) + +(deftest char-name.error.1 + (classify-error (char-name)) + program-error) + +(deftest char-name.error.2 + (classify-error (char-name #\a #\a)) + program-error) + +;;; + +(deftest name-char.1 + (name-char.1.body) + t) + +(deftest name-char.2 + (loop for s in '("RubOut" "PAGe" "BacKspace" "RetUrn" "Tab" "LineFeed" + "SpaCE" "NewLine") + always + (let ((c1 (name-char (string-upcase s))) + (c2 (name-char (string-downcase s))) + (c3 (name-char (string-capitalize s))) + (c4 (name-char s))) + (and (eqlt c1 c2) (eqlt c2 c3) (eqlt c3 c4)))) + t) + +(deftest name-char.order.1 + (let ((i 0)) + (values + (name-char (progn (incf i) "Space")) + i)) + #\Space 1) + +(deftest name-char.error.1 + (classify-error (name-char)) + program-error) + +(deftest name-char.error.2 + (classify-error (name-char "space" "space")) + program-error) diff --git a/ansi-tests/check-type.lsp b/ansi-tests/check-type.lsp new file mode 100644 index 0000000..94a3e4f --- /dev/null +++ b/ansi-tests/check-type.lsp @@ -0,0 +1,51 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Feb 15 20:12:04 2003 +;;;; Contains: Tests of CHECK-TYPE + +(in-package :cl-test) + +(deftest check-type.1 + (let ((x 'a)) + (values (check-type x symbol) x)) + nil a) + +(deftest check-type.2 + (classify-error + (let ((x 'a)) + (check-type x integer))) + type-error) + +(deftest check-type.3 + (let ((x 'a)) + (handler-bind + ((type-error #'(lambda (c) (store-value 15 c)))) + (values (check-type x number) x))) + nil 15) + +(deftest check-type.4 + (let ((x 'a)) + (values (check-type x symbol "a symbol") x)) + nil a) + +(deftest check-type.5 + (let ((x 'a)) + (handler-bind + ((type-error #'(lambda (c) (store-value "abc" c)))) + (values (check-type x string "a string") x))) + nil "abc") + +(deftest check-type.6 + (let ((x 'a)) + (handler-bind + ((type-error #'(lambda (c) (declare (ignore c)) (store-value 15 nil)))) + (values (check-type x number) x))) + nil 15) + +(deftest check-type.7 + (let ((x 'a)) + (handler-bind + ((type-error #'(lambda (c) (declare (ignore c)) (store-value 15)))) + (values (check-type x number) x))) + nil 15) + diff --git a/ansi-tests/cl-symbol-names.lsp b/ansi-tests/cl-symbol-names.lsp new file mode 100644 index 0000000..98821da --- /dev/null +++ b/ansi-tests/cl-symbol-names.lsp @@ -0,0 +1,2155 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Oct 6 21:49:33 2002 +;;;; Contains: Names of standard CL symbols + +(in-package :cl-test) + +;;; +;;; These are the names of the 978 symbols that can and must be external to +;;; the COMMON-LISP package. +;;; + +(defparameter *cl-symbol-names* +(mapcar #'string +'( +#:&allow-other-keys +#:&aux +#:&body +#:&environment +#:&key +#:&optional +#:&rest +#:&whole +#:* +#:** +#:*** +#:*break-on-signals* +#:*compile-file-pathname* +#:*compile-file-truename* +#:*compile-print* +#:*compile-verbose* +#:*debug-io* +#:*debugger-hook* +#:*default-pathname-defaults* +#:*error-output* +#:*features* +#:*gensym-counter* +#:*load-pathname* +#:*load-print* +#:*load-truename* +#:*load-verbose* +#:*macroexpand-hook* +#:*modules* +#:*package* +#:*print-array* +#:*print-base* +#:*print-case* +#:*print-circle* +#:*print-escape* +#:*print-gensym* +#:*print-length* +#:*print-level* +#:*print-lines* +#:*print-miser-width* +#:*print-pprint-dispatch* +#:*print-pretty* +#:*print-radix* +#:*print-readably* +#:*print-right-margin* +#:*query-io* +#:*random-state* +#:*read-base* +#:*read-default-float-format* +#:*read-eval* +#:*read-suppress* +#:*readtable* +#:*standard-input* +#:*standard-output* +#:*terminal-io* +#:*trace-output* +#:+ +#:++ +#:+++ +#:- +#:/ +#:// +#:/// +#:/= +#:1+ +#:1- +#:< +#:<= +#:= +#:> +#:>= +#:abort +#:abs +#:acons +#:acos +#:acosh +#:add-method +#:adjoin +#:adjust-array +#:adjustable-array-p +#:allocate-instance +#:alpha-char-p +#:alphanumericp +#:and +#:append +#:apply +#:apropos +#:apropos-list +#:aref +#:arithmetic-error +#:arithmetic-error-operands +#:arithmetic-error-operation +#:array +#:array-dimension +#:array-dimension-limit +#:array-dimensions +#:array-displacement +#:array-element-type +#:array-has-fill-pointer-p +#:array-in-bounds-p +#:array-rank +#:array-rank-limit +#:array-row-major-index +#:array-total-size +#:array-total-size-limit +#:arrayp +#:ash +#:asin +#:asinh +#:assert +#:assoc +#:assoc-if +#:assoc-if-not +#:atan +#:atanh +#:atom +#:base-char +#:base-string +#:bignum +#:bit +#:bit-and +#:bit-andc1 +#:bit-andc2 +#:bit-eqv +#:bit-ior +#:bit-nand +#:bit-nor +#:bit-not +#:bit-orc1 +#:bit-orc2 +#:bit-vector +#:bit-vector-p +#:bit-xor +#:block +#:boole +#:boole-1 +#:boole-2 +#:boole-and +#:boole-andc1 +#:boole-andc2 +#:boole-c1 +#:boole-c2 +#:boole-clr +#:boole-eqv +#:boole-ior +#:boole-nand +#:boole-nor +#:boole-orc1 +#:boole-orc2 +#:boole-set +#:boole-xor +#:boolean +#:both-case-p +#:boundp +#:break +#:broadcast-stream +#:broadcast-stream-streams +#:built-in-class +#:butlast +#:byte +#:byte-position +#:byte-size +#:caaaar +#:caaadr +#:caaar +#:caadar +#:caaddr +#:caadr +#:caar +#:cadaar +#:cadadr +#:cadar +#:caddar +#:cadddr +#:caddr +#:cadr +#:call-arguments-limit +#:call-method +#:call-next-method +#:car +#:case +#:catch +#:ccase +#:cdaaar +#:cdaadr +#:cdaar +#:cdadar +#:cdaddr +#:cdadr +#:cdar +#:cddaar +#:cddadr +#:cddar +#:cdddar +#:cddddr +#:cdddr +#:cddr +#:cdr +#:ceiling +#:cell-error +#:cell-error-name +#:cerror +#:change-class +#:char +#:char-code +#:char-code-limit +#:char-downcase +#:char-equal +#:char-greaterp +#:char-int +#:char-lessp +#:char-name +#:char-not-equal +#:char-not-greaterp +#:char-not-lessp +#:char-upcase +#:char/= +#:char< +#:char<= +#:char= +#:char> +#:char>= +#:character +#:characterp +#:check-type +#:cis +#:class +#:class-name +#:class-of +#:clear-input +#:clear-output +#:close +#:clrhash +#:code-char +#:coerce +#:compilation-speed +#:compile +#:compile-file +#:compile-file-pathname +#:compiled-function +#:compiled-function-p +#:compiler-macro +#:compiler-macro-function +#:complement +#:complex +#:complexp +#:compute-applicable-methods +#:compute-restarts +#:concatenate +#:concatenated-stream +#:concatenated-stream-streams +#:cond +#:condition +#:conjugate +#:cons +#:consp +#:constantly +#:constantp +#:continue +#:control-error +#:copy-alist +#:copy-list +#:copy-pprint-dispatch +#:copy-readtable +#:copy-seq +#:copy-structure +#:copy-symbol +#:copy-tree +#:cos +#:cosh +#:count +#:count-if +#:count-if-not +#:ctypecase +#:debug +#:decf +#:declaim +#:declaration +#:declare +#:decode-float +#:decode-universal-time +#:defclass +#:defconstant +#:defgeneric +#:define-compiler-macro +#:define-condition +#:define-method-combination +#:define-modify-macro +#:define-setf-expander +#:define-symbol-macro +#:defmacro +#:defmethod +#:defpackage +#:defparameter +#:defsetf +#:defstruct +#:deftype +#:defun +#:defvar +#:delete +#:delete-duplicates +#:delete-file +#:delete-if +#:delete-if-not +#:delete-package +#:denominator +#:deposit-field +#:describe +#:describe-object +#:destructuring-bind +#:digit-char +#:digit-char-p +#:directory +#:directory-namestring +#:disassemble +#:division-by-zero +#:do +#:do* +#:do-all-symbols +#:do-external-symbols +#:do-symbols +#:documentation +#:dolist +#:dotimes +#:double-float +#:double-float-epsilon +#:double-float-negative-epsilon +#:dpb +#:dribble +#:dynamic-extent +#:ecase +#:echo-stream +#:echo-stream-input-stream +#:echo-stream-output-stream +#:ed +#:eighth +#:elt +#:encode-universal-time +#:end-of-file +#:endp +#:enough-namestring +#:ensure-directories-exist +#:ensure-generic-function +#:eq +#:eql +#:equal +#:equalp +#:error +#:etypecase +#:eval +#:eval-when +#:evenp +#:every +#:exp +#:export +#:expt +#:extended-char +#:fboundp +#:fceiling +#:fdefinition +#:ffloor +#:fifth +#:file-author +#:file-error +#:file-error-pathname +#:file-length +#:file-namestring +#:file-position +#:file-stream +#:file-string-length +#:file-write-date +#:fill +#:fill-pointer +#:find +#:find-all-symbols +#:find-class +#:find-if +#:find-if-not +#:find-method +#:find-package +#:find-restart +#:find-symbol +#:finish-output +#:first +#:fixnum +#:flet +#:float +#:float-digits +#:float-precision +#:float-radix +#:float-sign +#:floating-point-inexact +#:floating-point-invalid-operation +#:floating-point-overflow +#:floating-point-underflow +#:floatp +#:floor +#:fmakunbound +#:force-output +#:format +#:formatter +#:fourth +#:fresh-line +#:fround +#:ftruncate +#:ftype +#:funcall +#:function +#:function-keywords +#:function-lambda-expression +#:functionp +#:gcd +#:generic-function +#:gensym +#:gentemp +#:get +#:get-decoded-time +#:get-dispatch-macro-character +#:get-internal-real-time +#:get-internal-run-time +#:get-macro-character +#:get-output-stream-string +#:get-properties +#:get-setf-expansion +#:get-universal-time +#:getf +#:gethash +#:go +#:graphic-char-p +#:handler-bind +#:handler-case +#:hash-table +#:hash-table-count +#:hash-table-p +#:hash-table-rehash-size +#:hash-table-rehash-threshold +#:hash-table-size +#:hash-table-test +#:host-namestring +#:identity +#:if +#:ignorable +#:ignore +#:ignore-errors +#:imagpart +#:import +#:in-package +#:incf +#:initialize-instance +#:inline +#:input-stream-p +#:inspect +#:integer +#:integer-decode-float +#:integer-length +#:integerp +#:interactive-stream-p +#:intern +#:internal-time-units-per-second +#:intersection +#:invalid-method-error +#:invoke-debugger +#:invoke-restart +#:invoke-restart-interactively +#:isqrt +#:keyword +#:keywordp +#:labels +#:lambda +#:lambda-list-keywords +#:lambda-parameters-limit +#:last +#:lcm +#:ldb +#:ldb-test +#:ldiff +#:least-negative-double-float +#:least-negative-long-float +#:least-negative-normalized-double-float +#:least-negative-normalized-long-float +#:least-negative-normalized-short-float +#:least-negative-normalized-single-float +#:least-negative-short-float +#:least-negative-single-float +#:least-positive-double-float +#:least-positive-long-float +#:least-positive-normalized-double-float +#:least-positive-normalized-long-float +#:least-positive-normalized-short-float +#:least-positive-normalized-single-float +#:least-positive-short-float +#:least-positive-single-float +#:length +#:let +#:let* +#:lisp-implementation-type +#:lisp-implementation-version +#:list +#:list* +#:list-all-packages +#:list-length +#:listen +#:listp +#:load +#:load-logical-pathname-translations +#:load-time-value +#:locally +#:log +#:logand +#:logandc1 +#:logandc2 +#:logbitp +#:logcount +#:logeqv +#:logical-pathname +#:logical-pathname-translations +#:logior +#:lognand +#:lognor +#:lognot +#:logorc1 +#:logorc2 +#:logtest +#:logxor +#:long-float +#:long-float-epsilon +#:long-float-negative-epsilon +#:long-site-name +#:loop +#:loop-finish +#:lower-case-p +#:machine-instance +#:machine-type +#:machine-version +#:macro-function +#:macroexpand +#:macroexpand-1 +#:macrolet +#:make-array +#:make-broadcast-stream +#:make-concatenated-stream +#:make-condition +#:make-dispatch-macro-character +#:make-echo-stream +#:make-hash-table +#:make-instance +#:make-instances-obsolete +#:make-list +#:make-load-form +#:make-load-form-saving-slots +#:make-method +#:make-package +#:make-pathname +#:make-random-state +#:make-sequence +#:make-string +#:make-string-input-stream +#:make-string-output-stream +#:make-symbol +#:make-synonym-stream +#:make-two-way-stream +#:makunbound +#:map +#:map-into +#:mapc +#:mapcan +#:mapcar +#:mapcon +#:maphash +#:mapl +#:maplist +#:mask-field +#:max +#:member +#:member-if +#:member-if-not +#:merge +#:merge-pathnames +#:method +#:method-combination +#:method-combination-error +#:method-qualifiers +#:min +#:minusp +#:mismatch +#:mod +#:most-negative-double-float +#:most-negative-fixnum +#:most-negative-long-float +#:most-negative-short-float +#:most-negative-single-float +#:most-positive-double-float +#:most-positive-fixnum +#:most-positive-long-float +#:most-positive-short-float +#:most-positive-single-float +#:muffle-warning +#:multiple-value-bind +#:multiple-value-call +#:multiple-value-list +#:multiple-value-prog1 +#:multiple-value-setq +#:multiple-values-limit +#:name-char +#:namestring +#:nbutlast +#:nconc +#:next-method-p +#:nil +#:nintersection +#:ninth +#:no-applicable-method +#:no-next-method +#:not +#:notany +#:notevery +#:notinline +#:nreconc +#:nreverse +#:nset-difference +#:nset-exclusive-or +#:nstring-capitalize +#:nstring-downcase +#:nstring-upcase +#:nsublis +#:nsubst +#:nsubst-if +#:nsubst-if-not +#:nsubstitute +#:nsubstitute-if +#:nsubstitute-if-not +#:nth +#:nth-value +#:nthcdr +#:null +#:number +#:numberp +#:numerator +#:nunion +#:oddp +#:open +#:open-stream-p +#:optimize +#:or +#:otherwise +#:output-stream-p +#:package +#:package-error +#:package-error-package +#:package-name +#:package-nicknames +#:package-shadowing-symbols +#:package-use-list +#:package-used-by-list +#:packagep +#:pairlis +#:parse-error +#:parse-integer +#:parse-namestring +#:pathname +#:pathname-device +#:pathname-directory +#:pathname-host +#:pathname-match-p +#:pathname-name +#:pathname-type +#:pathname-version +#:pathnamep +#:peek-char +#:phase +#:pi +#:plusp +#:pop +#:position +#:position-if +#:position-if-not +#:pprint +#:pprint-dispatch +#:pprint-exit-if-list-exhausted +#:pprint-fill +#:pprint-indent +#:pprint-linear +#:pprint-logical-block +#:pprint-newline +#:pprint-pop +#:pprint-tab +#:pprint-tabular +#:prin1 +#:prin1-to-string +#:princ +#:princ-to-string +#:print +#:print-not-readable +#:print-not-readable-object +#:print-object +#:print-unreadable-object +#:probe-file +#:proclaim +#:prog +#:prog* +#:prog1 +#:prog2 +#:progn +#:program-error +#:progv +#:provide +#:psetf +#:psetq +#:push +#:pushnew +#:quote +#:random +#:random-state +#:random-state-p +#:rassoc +#:rassoc-if +#:rassoc-if-not +#:ratio +#:rational +#:rationalize +#:rationalp +#:read +#:read-byte +#:read-char +#:read-char-no-hang +#:read-delimited-list +#:read-from-string +#:read-line +#:read-preserving-whitespace +#:read-sequence +#:reader-error +#:readtable +#:readtable-case +#:readtablep +#:real +#:realp +#:realpart +#:reduce +#:reinitialize-instance +#:rem +#:remf +#:remhash +#:remove +#:remove-duplicates +#:remove-if +#:remove-if-not +#:remove-method +#:remprop +#:rename-file +#:rename-package +#:replace +#:require +#:rest +#:restart +#:restart-bind +#:restart-case +#:restart-name +#:return +#:return-from +#:revappend +#:reverse +#:room +#:rotatef +#:round +#:row-major-aref +#:rplaca +#:rplacd +#:safety +#:satisfies +#:sbit +#:scale-float +#:schar +#:search +#:second +#:sequence +#:serious-condition +#:set +#:set-difference +#:set-dispatch-macro-character +#:set-exclusive-or +#:set-macro-character +#:set-pprint-dispatch +#:set-syntax-from-char +#:setf +#:setq +#:seventh +#:shadow +#:shadowing-import +#:shared-initialize +#:shiftf +#:short-float +#:short-float-epsilon +#:short-float-negative-epsilon +#:short-site-name +#:signal +#:signed-byte +#:signum +#:simple-array +#:simple-base-string +#:simple-bit-vector +#:simple-bit-vector-p +#:simple-condition +#:simple-condition-format-arguments +#:simple-condition-format-control +#:simple-error +#:simple-string +#:simple-string-p +#:simple-type-error +#:simple-vector +#:simple-vector-p +#:simple-warning +#:sin +#:single-float +#:single-float-epsilon +#:single-float-negative-epsilon +#:sinh +#:sixth +#:sleep +#:slot-boundp +#:slot-exists-p +#:slot-makunbound +#:slot-missing +#:slot-unbound +#:slot-value +#:software-type +#:software-version +#:some +#:sort +#:space +#:special +#:special-operator-p +#:speed +#:sqrt +#:stable-sort +#:standard +#:standard-char +#:standard-char-p +#:standard-class +#:standard-generic-function +#:standard-method +#:standard-object +#:step +#:storage-condition +#:store-value +#:stream +#:stream-element-type +#:stream-error +#:stream-error-stream +#:stream-external-format +#:streamp +#:string +#:string-capitalize +#:string-downcase +#:string-equal +#:string-greaterp +#:string-left-trim +#:string-lessp +#:string-not-equal +#:string-not-greaterp +#:string-not-lessp +#:string-right-trim +#:string-stream +#:string-trim +#:string-upcase +#:string/= +#:string< +#:string<= +#:string= +#:string> +#:string>= +#:stringp +#:structure +#:structure-class +#:structure-object +#:style-warning +#:sublis +#:subseq +#:subsetp +#:subst +#:subst-if +#:subst-if-not +#:substitute +#:substitute-if +#:substitute-if-not +#:subtypep +#:svref +#:sxhash +#:symbol +#:symbol-function +#:symbol-macrolet +#:symbol-name +#:symbol-package +#:symbol-plist +#:symbol-value +#:symbolp +#:synonym-stream +#:synonym-stream-symbol +#:t +#:tagbody +#:tailp +#:tan +#:tanh +#:tenth +#:terpri +#:the +#:third +#:throw +#:time +#:trace +#:translate-logical-pathname +#:translate-pathname +#:tree-equal +#:truename +#:truncate +#:two-way-stream +#:two-way-stream-input-stream +#:two-way-stream-output-stream +#:type +#:type-error +#:type-error-datum +#:type-error-expected-type +#:type-of +#:typecase +#:typep +#:unbound-slot +#:unbound-slot-instance +#:unbound-variable +#:undefined-function +#:unexport +#:unintern +#:union +#:unless +#:unread-char +#:unsigned-byte +#:untrace +#:unuse-package +#:unwind-protect +#:update-instance-for-different-class +#:update-instance-for-redefined-class +#:upgraded-array-element-type +#:upgraded-complex-part-type +#:upper-case-p +#:use-package +#:use-value +#:user-homedir-pathname +#:values +#:values-list +#:variable +#:vector +#:vector-pop +#:vector-push +#:vector-push-extend +#:vectorp +#:warn +#:warning +#:when +#:wild-pathname-p +#:with-accessors +#:with-compilation-unit +#:with-condition-restarts +#:with-hash-table-iterator +#:with-input-from-string +#:with-open-file +#:with-open-stream +#:with-output-to-string +#:with-package-iterator +#:with-simple-restart +#:with-slots +#:with-standard-io-syntax +#:write +#:write-byte +#:write-char +#:write-line +#:write-sequence +#:write-string +#:write-to-string +#:y-or-n-p +#:yes-or-no-p +#:zerop))) + +(defparameter *cl-symbols* + (let ((pkg (find-package :common-lisp))) + (mapcar #'(lambda (str) (intern str pkg)) + *cl-symbol-names*))) + +;;; Symbols classified by their kind in the spec +(defparameter *cl-function-symbols* + '( + * + + + - + / + /= + 1+ + 1- + < + <= + = + > + >= + abort + abs + acons + acos + acosh + adjoin + adjust-array + adjustable-array-p + alpha-char-p + alphanumericp + append + apply + apropos + apropos-list + arithmetic-error-operands + arithmetic-error-operation + array-dimension + array-dimensions + array-displacement + array-element-type + array-has-fill-pointer-p + array-in-bounds-p + array-rank + array-row-major-index + array-total-size + arrayp + ash + asin + asinh + assoc-if-not + assoc + assoc-if + atan + atanh + atom + bit-and + bit-andc1 + bit-andc2 + bit-eqv + bit-ior + bit-nand + bit-nor + bit-not + bit-orc1 + bit-orc2 + bit-vector-p + bit-xor + boole + both-case-p + boundp + break + broadcast-stream-streams + butlast + byte + byte-position + byte-size + ceiling + cell-error-name + cerror + char-code + char-downcase + char-equal + char-greaterp + char-int + char-lessp + char-name + char-not-equal + char-not-greaterp + char-not-lessp + char-upcase + char/= + char< + char<= + char= + char> + char>= + character + characterp + cis + class-of + clear-input + clear-output + close + clrhash + code-char + coerce + compile + compile-file + compile-file-pathname + compiled-function-p + complement + complex + complexp + compute-restarts + concatenate + concatenated-stream-streams + conjugate + cons + consp + constantly + constantp + continue + copy-alist + copy-list + copy-pprint-dispatch + copy-readtable + copy-seq + copy-structure + copy-symbol + copy-tree + cos + cosh + count + count-if + count-if-not + decode-float + decode-universal-time + delete + delete-duplicates + delete-file + delete-if + delete-if-not + delete-package + denominator + deposit-field + describe + digit-char + digit-char-p + directory + directory-namestring + disassemble + dpb + dribble + echo-stream-input-stream + echo-stream-output-stream + ;;; The function ED is commented out because an implementation + ;;; needn't provide this function. + ;; ed + encode-universal-time + endp + enough-namestring + ensure-directories-exist + ensure-generic-function + eq + eql + equal + equalp + error + eval + evenp + every + exp + export + expt + fboundp + fceiling + ffloor + file-author + file-error-pathname + file-length + file-namestring + file-position + file-write-date + find + find-all-symbols + find-if + find-if-not + find-package + find-restart + find-symbol + finish-output + float + float-digits + float-precision + float-radix + float-sign + floatp + floor + fmakunbound + force-output + format + fresh-line + fround + funcall + function-lambda-expression + functionp + gcd + gensym + gentemp + get-decoded-time + get-dispatch-macro-character + get-internal-real-time + get-internal-run-time + get-macro-character + get-output-stream-string + get-properties + get-setf-expansion + get-universal-time + graphic-char-p + hash-table-count + hash-table-p + hash-table-rehash-size + hash-table-rehash-threshold + hash-table-size + hash-table-test + host-namestring + identity + imagpart + import + input-stream-p + inspect + integer-decode-float + integer-length + integerp + interactive-stream-p + intern + intersection + invalid-method-error + invoke-debugger + invoke-restart + invoke-restart-interactively + isqrt + keywordp + last + lcm + ldb-test + ldiff + length + lisp-implementation-type + lisp-implementation-version + list + list* + list-all-packages + list-length + listen + listp + load + load-logical-pathname-translations + log + logand + logandc1 + logandc2 + logbitp + logcount + logeqv + logical-pathname + logior + lognand + lognor + lognot + logorc1 + logorc2 + logtest + logxor + long-site-name + lower-case-p + machine-instance + machine-type + machine-version + macroexpand + macroexpand-1 + make-array + make-broadcast-stream + make-concatenated-stream + make-condition + make-dispatch-macro-character + make-echo-stream + make-hash-table + make-list + make-load-form-saving-slots + make-package + make-pathname + make-random-state + make-sequence + make-string + make-string-input-stream + make-string-output-stream + make-symbol + make-synonym-stream + make-two-way-stream + makunbound + map + map-into + mapc + mapcan + mapcar + mapcon + maphash + mapl + maplist + max + member + member-if + member-if-not + merge + merge-pathnames + method-combination-error + min + minusp + mismatch + mod + muffle-warning + name-char + namestring + nbutlast + nconc + nintersection + not + notany + notevery + nreconc + nreverse + nset-difference + nset-exclusive-or + nstring-capitalize + nstring-downcase + nstring-upcase + nsublis + nsubst + nsubst-if + nsubst-if-not + nsubstitute + nsubstitute-if + nsubstitute-if-not + nthcdr + null + numberp + numerator + nunion + oddp + open + open-stream-p + output-stream-p + package-error-package + package-name + package-nicknames + package-shadowing-symbols + package-use-list + package-used-by-list + packagep + pairlis + parse-integer + parse-namestring + pathname + pathname-device + pathname-directory + pathname-host + pathname-match-p + pathname-name + pathname-type + pathname-version + pathnamep + peek-char + phase + plusp + position + position-if + position-if-not + pprint + pprint-dispatch + pprint-fill + pprint-indent + pprint-linear + pprint-newline + pprint-tab + pprint-tabular + prin1 + prin1-to-string + princ + princ-to-string + print + print-not-readable-object + probe-file + proclaim + provide + random-state-p + rassoc + rassoc-if + rassoc-if-not + rational + rationalize + rationalp + read + read-byte + read-char + read-char-no-hang + read-delimited-list + read-from-string + read-line + read-preserving-whitespace + read-sequence + readtablep + realp + realpart + reduce + rem + remhash + remove + remove-duplicates + remove-if + remove-if-not + remprop + rename-file + rename-package + replace + require + restart-name + revappend + reverse + room + round + rplaca + rplacd + scale-float + search + set + set-difference + set-dispatch-macro-character + set-exclusive-or + set-macro-character + set-pprint-dispatch + set-syntax-from-char + shadow + shadowing-import + short-site-name + signal + signum + simple-bit-vector-p + simple-condition-format-arguments + simple-condition-format-control + simple-string-p + simple-vector-p + sin + sinh + slot-exists-p + sleep + slot-boundp + slot-makunbound + slot-value + software-type + software-version + some + sort + special-operator-p + sqrt + stable-sort + standard-char-p + store-value + stream-element-type + stream-error-stream + stream-external-format + streamp + string + string-capitalize + string-downcase + string-equal + string-greaterp + string-left-trim + string-lessp + string-not-equal + string-not-greaterp + string-not-lessp + string-right-trim + string-trim + string-upcase + string/= + string< + string<= + string= + string> + string>= + stringp + sublis + subsetp + subst + subst-if + subst-if-not + substitute + substitute-if + substitute-if-not + subtypep + sxhash + symbol-name + symbol-package + symbolp + synonym-stream-symbol + tailp + tan + tanh + terpri + translate-logical-pathname + translate-pathname + tree-equal + truename + truncate ftruncate + two-way-stream-input-stream + two-way-stream-output-stream + type-error-datum + type-error-expected-type + type-of + typep + unbound-slot-instance + unexport + unintern + union + unread-char + unuse-package + upgraded-array-element-type + upgraded-complex-part-type + upper-case-p + use-package + use-value + user-homedir-pathname + values-list + vector + vector-pop + vector-push + vector-push-extend + vectorp + warn + wild-pathname-p + write + write-byte + write-char + write-line + write-sequence + write-string + write-to-string + y-or-n-p + yes-or-no-p + zerop + )) + +(defparameter *cl-variable-symbols* + '( + * + ** + *** + *break-on-signals* + *compile-file-pathname* + *compile-file-truename* + *compile-print* + *compile-verbose* + *debug-io* + *debugger-hook* + *default-pathname-defaults* + *error-output* + *features* + *gensym-counter* + *load-pathname* + *load-print* + *load-truename* + *load-verbose* + *macroexpand-hook* + *modules* + *package* + *print-array* + *print-base* + *print-case* + *print-circle* + *print-escape* + *print-gensym* + *print-length* + *print-level* + *print-lines* + *print-miser-width* + *print-pprint-dispatch* + *print-pretty* + *print-radix* + *print-readably* + *print-right-margin* + *query-io* + *random-state* + *read-base* + *read-default-float-format* + *read-eval* + *read-suppress* + *readtable* + *standard-input* + *standard-output* + *terminal-io* + *trace-output* + + + ++ + +++ + / + // + /// + - + )) + +(defparameter *cl-constant-symbols* + '( + array-dimension-limit + array-rank-limit + array-total-size-limit + boole-1 + boole-2 + boole-and + boole-andc1 + boole-andc2 + boole-c1 + boole-c2 + boole-clr + boole-eqv + boole-ior + boole-nand + boole-nor + boole-orc1 + boole-orc2 + boole-set + boole-xor + call-arguments-limit + char-code-limit + double-float-epsilon + double-float-negative-epsilon + internal-time-units-per-second + lambda-list-keywords + lambda-parameters-limit + least-negative-double-float + least-negative-long-float + least-negative-normalized-double-float + least-negative-normalized-long-float + least-negative-normalized-short-float + least-negative-normalized-single-float + least-negative-short-float + least-negative-single-float + least-positive-double-float + least-positive-long-float + least-positive-normalized-double-float + least-positive-normalized-long-float + least-positive-normalized-short-float + least-positive-normalized-single-float + least-positive-short-float + least-positive-single-float + long-float-epsilon + long-float-negative-epsilon + most-negative-double-float + most-negative-fixnum + most-negative-long-float + most-negative-short-float + most-negative-single-float + most-positive-double-float + most-positive-fixnum + most-positive-long-float + most-positive-short-float + most-positive-single-float + multiple-values-limit + nil + pi + short-float-epsilon + short-float-negative-epsilon + single-float-epsilon + single-float-negative-epsilon + t + )) + +(defparameter *cl-macro-symbols* + '( + and + assert + case + ccase + ecase + check-type + cond + declaim + defclass + defconstant + defgeneric + define-compiler-macro + define-condition + define-method-combination + define-modify-macro + define-setf-expander + define-symbol-macro + defmacro + defmethod + defpackage + defparameter + defvar + defsetf + defstruct + deftype + defun + destructuring-bind + do + do* + do-symbols + do-external-symbols + do-all-symbols + dolist + dotimes + formatter + handler-bind + handler-case + ignore-errors + in-package + incf + decf + lambda + loop + multiple-value-bind + multiple-value-list + multiple-value-setq + nth-value + or + pop + pprint-logical-block + print-unreadable-object + prog + prog* + prog1 + prog2 + psetq + push + pushnew + remf + restart-bind + restart-case + return + rotatef + setf + psetf + shiftf + step + time + trace + untrace + typecase + ctypecase + etypecase + when + unless + with-accessors + with-compilation-unit + with-condition-restarts + with-hash-table-iterator + with-input-from-string + with-open-file + with-open-stream + with-output-to-string + with-package-iterator + with-simple-restart + with-slots + with-standard-io-syntax + )) + +(defparameter *cl-accessor-symbols* + '( + aref + bit + caaaar + caaadr + caaar + caadar + caaddr + caadr + caar + cadaar + cadadr + cadar + caddar + cadddr + caddr + cadr + car + cdaaar + cdaadr + cdaar + cdadar + cdaddr + cdadr + cdar + cddaar + cddadr + cddar + cdddar + cddddr + cdddr + cddr + cdr + char + compiler-macro-function + eighth + elt + fdefinition + fifth + fill-pointer + find-class + first + fourth + get + getf + gethash + ldb + logical-pathname-translations + macro-function + mask-field + ninth + nth + readtable-case + rest + row-major-aref + sbit + schar + second + seventh + sixth + subseq + svref + symbol-function + symbol-plist + symbol-value + tenth + third + values + )) + +(defparameter *cl-condition-type-symbols* + '( + arithmetic-error + cell-error + condition + control-error + division-by-zero + end-of-file + error + file-error + floating-point-inexact + floating-point-invalid-operation + floating-point-overflow + floating-point-underflow + package-error + parse-error + print-not-readable + program-error + reader-error + serious-condition + simple-condition + simple-error + simple-type-error + simple-warning + storage-condition + stream-error + style-warning + type-error + unbound-slot + unbound-variable + undefined-function + warning + )) + +(defparameter *cl-class-symbols* + '(standard-object structure-object)) + +(defparameter *cl-declaration-symbols* + '( + declaration + dynamic-extent + ftype + ignore + ignorable + inline + notinline + optimize + special + type)) + +(defparameter *cl-local-function-symbols* + '(call-next-method next-method-p)) + +(defparameter *cl-local-macro-symbols* + '( + call-method + make-method + loop-finish + pprint-exit-if-list-exhausted + pprint-pop + )) + +(defparameter *cl-special-operator-symbols* + '( + block + catch + eval-when + flet + function + go + if + labels + let + let* + load-time-value + locally + macrolet + multiple-value-call + multiple-value-prog1 + progn + progv + quote + return-from + setq + symbol-macrolet + tagbody + the + throw + unwind-protect +)) + +(defparameter *cl-standard-generic-function-symbols* + '( + add-method + allocate-instance + change-class + class-name + compute-applicable-methods + describe-object + documentation + find-method + function-keywords + initialize-instance + make-instance + make-instances-obsolete + make-load-form + method-qualifiers + no-applicable-method + no-next-method + print-object + reinitialize-instance + remove-method + shared-initialize + slot-missing + slot-unbound + update-instance-for-different-class + update-instance-for-redefined-class + )) + +(defparameter *cl-system-class-symbols* + '( + array + bit-vector + broadcast-stream + built-in-class + character + class + complex + concatenated-stream + cons + echo-stream + file-stream + float + function + generic-function + hash-table + integer + list + logical-pathname + method + method-combination + null + number + package + pathname + random-state + ratio + rational + readtable + real + restart + sequence + standard-class + standard-generic-function + standard-method + stream + string + string-stream + structure-class + symbol + synonym-stream + t + two-way-stream + vector + )) + +(defparameter *cl-type-symbols* + '( + atom + base-char + base-string + bignum + bit + boolean + compiled-function + extended-char + fixnum + keyword + nil + short-float + single-float + double-float + long-float + signed-byte + simple-array + simple-base-string + simple-bit-vector + simple-string + simple-vector + standard-char + unsigned-byte + )) + +(defparameter *cl-type-specifier-symbols* + '( + and + eql + member + mod + not + or + satisfies + values + )) + +(defparameter *cl-restart-symbols* + '( + abort + continue + muffle-warning + store-value + use-value + )) + +;;; Symbols that are names of types that are also classes +;;; See figure 4-8 in section 4.3.7 +(defparameter *cl-types-that-are-classes-symbols* + '( + arithmetic-error + array + bit-vector + broadcast-stream + built-in-class + cell-error + character + class + complex + concatenated-stream + condition + cons + control-error + division-by-zero + echo-stream + end-of-file + error + file-error + file-stream + float + floating-point-inexact + floating-point-invalid-operation + floating-point-overflow + floating-point-underflow + function + generic-function + hash-table + integer + list + logical-pathname + method + method-combination + null + number + package + package-error + parse-error + pathname + print-not-readable + program-error + random-state + ratio + rational + reader-error + readtable + real + restart + sequence + serious-condition + simple-condition + simple-error + simple-type-error + simple-warning + standard-class + standard-generic-function + standard-method + standard-object + storage-condition + stream + stream-error + string + string-stream + structure-class + structure-object + style-warning + symbol + synonym-stream + t + two-way-stream + type-error + unbound-slot + unbound-variable + undefined-function + vector + warning + )) + +(defparameter *cl-all-type-symbols* + (reduce #'union + (list *cl-type-symbols* *cl-types-that-are-classes-symbols* + *cl-system-class-symbols* *cl-class-symbols* + *cl-condition-type-symbols*))) + +(defparameter *cl-non-function-macro-special-operator-symbols* + (set-difference + *cl-symbols* + (reduce #'union + (list *cl-function-symbols* + *cl-macro-symbols* + *cl-accessor-symbols* + *cl-local-function-symbols* + *cl-local-macro-symbols* + *cl-special-operator-symbols* + *cl-standard-generic-function-symbols* + '(declare))))) + +(defparameter *cl-function-or-accessor-symbols* + (append *cl-function-symbols* *cl-accessor-symbols*)) + +(defparameter *cl-non-variable-constant-symbols* + (set-difference + *cl-symbols* + (union *cl-variable-symbols* + *cl-constant-symbols*))) diff --git a/ansi-tests/cl-symbols-aux.lsp b/ansi-tests/cl-symbols-aux.lsp new file mode 100644 index 0000000..542fe9c --- /dev/null +++ b/ansi-tests/cl-symbols-aux.lsp @@ -0,0 +1,43 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Thu Nov 28 06:43:51 2002 +;;;; Contains: Aux. functions for cl-symbols.lsp + +(in-package :cl-test) + +(declaim (optimize (safety 3))) + +(defun is-external-symbol-of (sym package) + (multiple-value-bind (sym2 status) + (find-symbol (symbol-name sym) package) + (and (eqt sym sym2) + (eqt status :external)))) + +(defun test-if-not-in-cl-package (str) + (multiple-value-bind (sym status) + (find-symbol #+lower-case str #-lower-case (string-upcase str) 'common-lisp) + (or + ;; Symbol not present in the common lisp package + (not status) + ;; Check if it has any properties whose indicators are + ;; external in any of the standard packages or are accessible + ;; in CL-USER + (and (eqt status :external) + (let ((plist (symbol-plist sym))) + (loop for e = plist then (cddr e) + while e + for indicator = (car e) + when (and (symbolp indicator) + (or (is-external-symbol-of indicator + "COMMON-LISP") + (is-external-symbol-of indicator "KEYWORD") + (eqt indicator (find-symbol + (symbol-name indicator) + "COMMON-LISP-USER")))) + collect indicator)))))) + +(defun safe-symbol-name (sym) + (catch-type-error (symbol-name sym))) + +(defun safe-make-symbol (name) + (catch-type-error (make-symbol name))) diff --git a/ansi-tests/cl-symbols.lsp b/ansi-tests/cl-symbols.lsp new file mode 100644 index 0000000..7b2c0a3 --- /dev/null +++ b/ansi-tests/cl-symbols.lsp @@ -0,0 +1,1587 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Mar 15 13:19:57 1998 +;;;; Contains: Test presence of symbols in the CL package, +;;;; and symbol-related functions + +(in-package :cl-test) + +(declaim (optimize (safety 3))) + +;;; Test for the presence of every darned symbol +;;; the standard says should be in the CL package. +;;; Also, test that they have no prohibited plist indicators (section 11.1.2.1.1) + +(deftest symbol-&allow-other-keys (test-if-not-in-cl-package "&allow-other-keys") nil) +(deftest symbol-&aux (test-if-not-in-cl-package "&aux") nil) +(deftest symbol-&body (test-if-not-in-cl-package "&body") nil) +(deftest symbol-&environment (test-if-not-in-cl-package "&environment") nil) +(deftest symbol-&key (test-if-not-in-cl-package "&key") nil) +(deftest symbol-&optional (test-if-not-in-cl-package "&optional") nil) +(deftest symbol-&rest (test-if-not-in-cl-package "&rest") nil) +(deftest symbol-&whole (test-if-not-in-cl-package "&whole") nil) +(deftest symbol-* (test-if-not-in-cl-package "*") nil) +(deftest symbol-** (test-if-not-in-cl-package "**") nil) +(deftest symbol-*** (test-if-not-in-cl-package "***") nil) +(deftest symbol-*break-on-signals* (test-if-not-in-cl-package "*break-on-signals*") nil) +(deftest symbol-*compile-file-pathname* (test-if-not-in-cl-package "*compile-file-pathname*") nil) +(deftest symbol-*compile-file-truename* (test-if-not-in-cl-package "*compile-file-truename*") nil) +(deftest symbol-*compile-print* (test-if-not-in-cl-package "*compile-print*") nil) +(deftest symbol-*compile-verbose* (test-if-not-in-cl-package "*compile-verbose*") nil) +(deftest symbol-*debug-io* (test-if-not-in-cl-package "*debug-io*") nil) +(deftest symbol-*debugger-hook* (test-if-not-in-cl-package "*debugger-hook*") nil) +(deftest symbol-*default-pathname-defaults* (test-if-not-in-cl-package "*default-pathname-defaults*") nil) +(deftest symbol-*error-output* (test-if-not-in-cl-package "*error-output*") nil) +(deftest symbol-*features* (test-if-not-in-cl-package "*features*") nil) +(deftest symbol-*gensym-counter* (test-if-not-in-cl-package "*gensym-counter*") nil) +(deftest symbol-*load-pathname* (test-if-not-in-cl-package "*load-pathname*") nil) +(deftest symbol-*load-print* (test-if-not-in-cl-package "*load-print*") nil) +(deftest symbol-*load-truename* (test-if-not-in-cl-package "*load-truename*") nil) +(deftest symbol-*load-verbose* (test-if-not-in-cl-package "*load-verbose*") nil) +(deftest symbol-*macroexpand-hook* (test-if-not-in-cl-package "*macroexpand-hook*") nil) +(deftest symbol-*modules* (test-if-not-in-cl-package "*modules*") nil) +(deftest symbol-*package* (test-if-not-in-cl-package "*package*") nil) +(deftest symbol-*print-array* (test-if-not-in-cl-package "*print-array*") nil) +(deftest symbol-*print-base* (test-if-not-in-cl-package "*print-base*") nil) +(deftest symbol-*print-case* (test-if-not-in-cl-package "*print-case*") nil) +(deftest symbol-*print-circle* (test-if-not-in-cl-package "*print-circle*") nil) +(deftest symbol-*print-escape* (test-if-not-in-cl-package "*print-escape*") nil) +(deftest symbol-*print-gensym* (test-if-not-in-cl-package "*print-gensym*") nil) +(deftest symbol-*print-length* (test-if-not-in-cl-package "*print-length*") nil) +(deftest symbol-*print-level* (test-if-not-in-cl-package "*print-level*") nil) +(deftest symbol-*print-lines* (test-if-not-in-cl-package "*print-lines*") nil) +(deftest symbol-*print-miser-width* (test-if-not-in-cl-package "*print-miser-width*") nil) +(deftest symbol-*print-pprint-dispatch* (test-if-not-in-cl-package "*print-pprint-dispatch*") nil) +(deftest symbol-*print-pretty* (test-if-not-in-cl-package "*print-pretty*") nil) +(deftest symbol-*print-radix* (test-if-not-in-cl-package "*print-radix*") nil) +(deftest symbol-*print-readably* (test-if-not-in-cl-package "*print-readably*") nil) +(deftest symbol-*print-right-margin* (test-if-not-in-cl-package "*print-right-margin*") nil) +(deftest symbol-*query-io* (test-if-not-in-cl-package "*query-io*") nil) +(deftest symbol-*random-state* (test-if-not-in-cl-package "*random-state*") nil) +(deftest symbol-*read-base* (test-if-not-in-cl-package "*read-base*") nil) +(deftest symbol-*read-default-float-format* (test-if-not-in-cl-package "*read-default-float-format*") nil) +(deftest symbol-*read-eval* (test-if-not-in-cl-package "*read-eval*") nil) +(deftest symbol-*read-suppress* (test-if-not-in-cl-package "*read-suppress*") nil) +(deftest symbol-*readtable* (test-if-not-in-cl-package "*readtable*") nil) +(deftest symbol-*standard-input* (test-if-not-in-cl-package "*standard-input*") nil) +(deftest symbol-*standard-output* (test-if-not-in-cl-package "*standard-output*") nil) +(deftest symbol-*terminal-io* (test-if-not-in-cl-package "*terminal-io*") nil) +(deftest symbol-*trace-output* (test-if-not-in-cl-package "*trace-output*") nil) +(deftest symbol-+ (test-if-not-in-cl-package "+") nil) +(deftest symbol-++ (test-if-not-in-cl-package "++") nil) +(deftest symbol-+++ (test-if-not-in-cl-package "+++") nil) +(deftest symbol-- (test-if-not-in-cl-package "-") nil) +(deftest symbol-/ (test-if-not-in-cl-package "/") nil) +(deftest symbol-// (test-if-not-in-cl-package "//") nil) +(deftest symbol-/// (test-if-not-in-cl-package "///") nil) +(deftest symbol-/= (test-if-not-in-cl-package "/=") nil) +(deftest symbol-1+ (test-if-not-in-cl-package "1+") nil) +(deftest symbol-1- (test-if-not-in-cl-package "1-") nil) +(deftest symbol-< (test-if-not-in-cl-package "<") nil) +(deftest symbol-<= (test-if-not-in-cl-package "<=") nil) +(deftest symbol-= (test-if-not-in-cl-package "=") nil) +(deftest symbol-> (test-if-not-in-cl-package ">") nil) +(deftest symbol->= (test-if-not-in-cl-package ">=") nil) +(deftest symbol-abort (test-if-not-in-cl-package "abort") nil) +(deftest symbol-abs (test-if-not-in-cl-package "abs") nil) +(deftest symbol-acons (test-if-not-in-cl-package "acons") nil) +(deftest symbol-acos (test-if-not-in-cl-package "acos") nil) +(deftest symbol-acosh (test-if-not-in-cl-package "acosh") nil) +(deftest symbol-add-method (test-if-not-in-cl-package "add-method") nil) +(deftest symbol-adjoin (test-if-not-in-cl-package "adjoin") nil) +(deftest symbol-adjust-array (test-if-not-in-cl-package "adjust-array") nil) +(deftest symbol-adjustable-array-p (test-if-not-in-cl-package "adjustable-array-p") nil) +(deftest symbol-allocate-instance (test-if-not-in-cl-package "allocate-instance") nil) +(deftest symbol-alpha-char-p (test-if-not-in-cl-package "alpha-char-p") nil) +(deftest symbol-alphanumericp (test-if-not-in-cl-package "alphanumericp") nil) +(deftest symbol-and (test-if-not-in-cl-package "and") nil) +(deftest symbol-append (test-if-not-in-cl-package "append") nil) +(deftest symbol-apply (test-if-not-in-cl-package "apply") nil) +(deftest symbol-apropos (test-if-not-in-cl-package "apropos") nil) +(deftest symbol-apropos-list (test-if-not-in-cl-package "apropos-list") nil) +(deftest symbol-aref (test-if-not-in-cl-package "aref") nil) +(deftest symbol-arithmetic-error (test-if-not-in-cl-package "arithmetic-error") nil) +(deftest symbol-arithmetic-error-operands (test-if-not-in-cl-package "arithmetic-error-operands") nil) +(deftest symbol-arithmetic-error-operation (test-if-not-in-cl-package "arithmetic-error-operation") nil) +(deftest symbol-array (test-if-not-in-cl-package "array") nil) +(deftest symbol-array-dimension (test-if-not-in-cl-package "array-dimension") nil) +(deftest symbol-array-dimension-limit (test-if-not-in-cl-package "array-dimension-limit") nil) +(deftest symbol-array-dimensions (test-if-not-in-cl-package "array-dimensions") nil) +(deftest symbol-array-displacement (test-if-not-in-cl-package "array-displacement") nil) +(deftest symbol-array-element-type (test-if-not-in-cl-package "array-element-type") nil) +(deftest symbol-array-has-fill-pointer-p (test-if-not-in-cl-package "array-has-fill-pointer-p") nil) +(deftest symbol-array-in-bounds-p (test-if-not-in-cl-package "array-in-bounds-p") nil) +(deftest symbol-array-rank (test-if-not-in-cl-package "array-rank") nil) +(deftest symbol-array-rank-limit (test-if-not-in-cl-package "array-rank-limit") nil) +(deftest symbol-array-row-major-index (test-if-not-in-cl-package "array-row-major-index") nil) +(deftest symbol-array-total-size (test-if-not-in-cl-package "array-total-size") nil) +(deftest symbol-array-total-size-limit (test-if-not-in-cl-package "array-total-size-limit") nil) +(deftest symbol-arrayp (test-if-not-in-cl-package "arrayp") nil) +(deftest symbol-ash (test-if-not-in-cl-package "ash") nil) +(deftest symbol-asin (test-if-not-in-cl-package "asin") nil) +(deftest symbol-asinh (test-if-not-in-cl-package "asinh") nil) +(deftest symbol-assert (test-if-not-in-cl-package "assert") nil) +(deftest symbol-assoc (test-if-not-in-cl-package "assoc") nil) +(deftest symbol-assoc-if (test-if-not-in-cl-package "assoc-if") nil) +(deftest symbol-assoc-if-not (test-if-not-in-cl-package "assoc-if-not") nil) +(deftest symbol-atan (test-if-not-in-cl-package "atan") nil) +(deftest symbol-atanh (test-if-not-in-cl-package "atanh") nil) +(deftest symbol-atom (test-if-not-in-cl-package "atom") nil) +(deftest symbol-base-char (test-if-not-in-cl-package "base-char") nil) +(deftest symbol-base-string (test-if-not-in-cl-package "base-string") nil) +(deftest symbol-bignum (test-if-not-in-cl-package "bignum") nil) +(deftest symbol-bit (test-if-not-in-cl-package "bit") nil) +(deftest symbol-bit-and (test-if-not-in-cl-package "bit-and") nil) +(deftest symbol-bit-andc1 (test-if-not-in-cl-package "bit-andc1") nil) +(deftest symbol-bit-andc2 (test-if-not-in-cl-package "bit-andc2") nil) +(deftest symbol-bit-eqv (test-if-not-in-cl-package "bit-eqv") nil) +(deftest symbol-bit-ior (test-if-not-in-cl-package "bit-ior") nil) +(deftest symbol-bit-nand (test-if-not-in-cl-package "bit-nand") nil) +(deftest symbol-bit-nor (test-if-not-in-cl-package "bit-nor") nil) +(deftest symbol-bit-not (test-if-not-in-cl-package "bit-not") nil) +(deftest symbol-bit-orc1 (test-if-not-in-cl-package "bit-orc1") nil) +(deftest symbol-bit-orc2 (test-if-not-in-cl-package "bit-orc2") nil) +(deftest symbol-bit-vector (test-if-not-in-cl-package "bit-vector") nil) +(deftest symbol-bit-vector-p (test-if-not-in-cl-package "bit-vector-p") nil) +(deftest symbol-bit-xor (test-if-not-in-cl-package "bit-xor") nil) +(deftest symbol-block (test-if-not-in-cl-package "block") nil) +(deftest symbol-boole (test-if-not-in-cl-package "boole") nil) +(deftest symbol-boole-1 (test-if-not-in-cl-package "boole-1") nil) +(deftest symbol-boole-2 (test-if-not-in-cl-package "boole-2") nil) +(deftest symbol-boole-and (test-if-not-in-cl-package "boole-and") nil) +(deftest symbol-boole-andc1 (test-if-not-in-cl-package "boole-andc1") nil) +(deftest symbol-boole-andc2 (test-if-not-in-cl-package "boole-andc2") nil) +(deftest symbol-boole-c1 (test-if-not-in-cl-package "boole-c1") nil) +(deftest symbol-boole-c2 (test-if-not-in-cl-package "boole-c2") nil) +(deftest symbol-boole-clr (test-if-not-in-cl-package "boole-clr") nil) +(deftest symbol-boole-eqv (test-if-not-in-cl-package "boole-eqv") nil) +(deftest symbol-boole-ior (test-if-not-in-cl-package "boole-ior") nil) +(deftest symbol-boole-nand (test-if-not-in-cl-package "boole-nand") nil) +(deftest symbol-boole-nor (test-if-not-in-cl-package "boole-nor") nil) +(deftest symbol-boole-orc1 (test-if-not-in-cl-package "boole-orc1") nil) +(deftest symbol-boole-orc2 (test-if-not-in-cl-package "boole-orc2") nil) +(deftest symbol-boole-set (test-if-not-in-cl-package "boole-set") nil) +(deftest symbol-boole-xor (test-if-not-in-cl-package "boole-xor") nil) +(deftest symbol-boolean (test-if-not-in-cl-package "boolean") nil) +(deftest symbol-both-case-p (test-if-not-in-cl-package "both-case-p") nil) +(deftest symbol-boundp (test-if-not-in-cl-package "boundp") nil) +(deftest symbol-break (test-if-not-in-cl-package "break") nil) +(deftest symbol-broadcast-stream (test-if-not-in-cl-package "broadcast-stream") nil) +(deftest symbol-broadcast-stream-streams (test-if-not-in-cl-package "broadcast-stream-streams") nil) +(deftest symbol-built-in-class (test-if-not-in-cl-package "built-in-class") nil) +(deftest symbol-butlast (test-if-not-in-cl-package "butlast") nil) +(deftest symbol-byte (test-if-not-in-cl-package "byte") nil) +(deftest symbol-byte-position (test-if-not-in-cl-package "byte-position") nil) +(deftest symbol-byte-size (test-if-not-in-cl-package "byte-size") nil) +(deftest symbol-caaaar (test-if-not-in-cl-package "caaaar") nil) +(deftest symbol-caaadr (test-if-not-in-cl-package "caaadr") nil) +(deftest symbol-caaar (test-if-not-in-cl-package "caaar") nil) +(deftest symbol-caadar (test-if-not-in-cl-package "caadar") nil) +(deftest symbol-caaddr (test-if-not-in-cl-package "caaddr") nil) +(deftest symbol-caadr (test-if-not-in-cl-package "caadr") nil) +(deftest symbol-caar (test-if-not-in-cl-package "caar") nil) +(deftest symbol-cadaar (test-if-not-in-cl-package "cadaar") nil) +(deftest symbol-cadadr (test-if-not-in-cl-package "cadadr") nil) +(deftest symbol-cadar (test-if-not-in-cl-package "cadar") nil) +(deftest symbol-caddar (test-if-not-in-cl-package "caddar") nil) +(deftest symbol-cadddr (test-if-not-in-cl-package "cadddr") nil) +(deftest symbol-caddr (test-if-not-in-cl-package "caddr") nil) +(deftest symbol-cadr (test-if-not-in-cl-package "cadr") nil) +(deftest symbol-call-arguments-limit (test-if-not-in-cl-package "call-arguments-limit") nil) +(deftest symbol-call-method (test-if-not-in-cl-package "call-method") nil) +(deftest symbol-call-next-method (test-if-not-in-cl-package "call-next-method") nil) +(deftest symbol-car (test-if-not-in-cl-package "car") nil) +(deftest symbol-case (test-if-not-in-cl-package "case") nil) +(deftest symbol-catch (test-if-not-in-cl-package "catch") nil) +(deftest symbol-ccase (test-if-not-in-cl-package "ccase") nil) +(deftest symbol-cdaaar (test-if-not-in-cl-package "cdaaar") nil) +(deftest symbol-cdaadr (test-if-not-in-cl-package "cdaadr") nil) +(deftest symbol-cdaar (test-if-not-in-cl-package "cdaar") nil) +(deftest symbol-cdadar (test-if-not-in-cl-package "cdadar") nil) +(deftest symbol-cdaddr (test-if-not-in-cl-package "cdaddr") nil) +(deftest symbol-cdadr (test-if-not-in-cl-package "cdadr") nil) +(deftest symbol-cdar (test-if-not-in-cl-package "cdar") nil) +(deftest symbol-cddaar (test-if-not-in-cl-package "cddaar") nil) +(deftest symbol-cddadr (test-if-not-in-cl-package "cddadr") nil) +(deftest symbol-cddar (test-if-not-in-cl-package "cddar") nil) +(deftest symbol-cdddar (test-if-not-in-cl-package "cdddar") nil) +(deftest symbol-cddddr (test-if-not-in-cl-package "cddddr") nil) +(deftest symbol-cdddr (test-if-not-in-cl-package "cdddr") nil) +(deftest symbol-cddr (test-if-not-in-cl-package "cddr") nil) +(deftest symbol-cdr (test-if-not-in-cl-package "cdr") nil) +(deftest symbol-ceiling (test-if-not-in-cl-package "ceiling") nil) +(deftest symbol-cell-error (test-if-not-in-cl-package "cell-error") nil) +(deftest symbol-cell-error-name (test-if-not-in-cl-package "cell-error-name") nil) +(deftest symbol-cerror (test-if-not-in-cl-package "cerror") nil) +(deftest symbol-change-class (test-if-not-in-cl-package "change-class") nil) +(deftest symbol-char (test-if-not-in-cl-package "char") nil) +(deftest symbol-char-code (test-if-not-in-cl-package "char-code") nil) +(deftest symbol-char-code-limit (test-if-not-in-cl-package "char-code-limit") nil) +(deftest symbol-char-downcase (test-if-not-in-cl-package "char-downcase") nil) +(deftest symbol-char-equal (test-if-not-in-cl-package "char-equal") nil) +(deftest symbol-char-greaterp (test-if-not-in-cl-package "char-greaterp") nil) +(deftest symbol-char-int (test-if-not-in-cl-package "char-int") nil) +(deftest symbol-char-lessp (test-if-not-in-cl-package "char-lessp") nil) +(deftest symbol-char-name (test-if-not-in-cl-package "char-name") nil) +(deftest symbol-char-not-equal (test-if-not-in-cl-package "char-not-equal") nil) +(deftest symbol-char-not-greaterp (test-if-not-in-cl-package "char-not-greaterp") nil) +(deftest symbol-char-not-lessp (test-if-not-in-cl-package "char-not-lessp") nil) +(deftest symbol-char-upcase (test-if-not-in-cl-package "char-upcase") nil) +(deftest symbol-char/= (test-if-not-in-cl-package "char/=") nil) +(deftest symbol-char< (test-if-not-in-cl-package "char<") nil) +(deftest symbol-char<= (test-if-not-in-cl-package "char<=") nil) +(deftest symbol-char= (test-if-not-in-cl-package "char=") nil) +(deftest symbol-char> (test-if-not-in-cl-package "char>") nil) +(deftest symbol-char>= (test-if-not-in-cl-package "char>=") nil) +(deftest symbol-character (test-if-not-in-cl-package "character") nil) +(deftest symbol-characterp (test-if-not-in-cl-package "characterp") nil) +(deftest symbol-check-type (test-if-not-in-cl-package "check-type") nil) +(deftest symbol-cis (test-if-not-in-cl-package "cis") nil) +(deftest symbol-class (test-if-not-in-cl-package "class") nil) +(deftest symbol-class-name (test-if-not-in-cl-package "class-name") nil) +(deftest symbol-class-of (test-if-not-in-cl-package "class-of") nil) +(deftest symbol-clear-input (test-if-not-in-cl-package "clear-input") nil) +(deftest symbol-clear-output (test-if-not-in-cl-package "clear-output") nil) +(deftest symbol-close (test-if-not-in-cl-package "close") nil) +(deftest symbol-clrhash (test-if-not-in-cl-package "clrhash") nil) +(deftest symbol-code-char (test-if-not-in-cl-package "code-char") nil) +(deftest symbol-coerce (test-if-not-in-cl-package "coerce") nil) +(deftest symbol-compilation-speed (test-if-not-in-cl-package "compilation-speed") nil) +(deftest symbol-compile (test-if-not-in-cl-package "compile") nil) +(deftest symbol-compile-file (test-if-not-in-cl-package "compile-file") nil) +(deftest symbol-compile-file-pathname (test-if-not-in-cl-package "compile-file-pathname") nil) +(deftest symbol-compiled-function (test-if-not-in-cl-package "compiled-function") nil) +(deftest symbol-compiled-function-p (test-if-not-in-cl-package "compiled-function-p") nil) +(deftest symbol-compiler-macro (test-if-not-in-cl-package "compiler-macro") nil) +(deftest symbol-compiler-macro-function (test-if-not-in-cl-package "compiler-macro-function") nil) +(deftest symbol-complement (test-if-not-in-cl-package "complement") nil) +(deftest symbol-complex (test-if-not-in-cl-package "complex") nil) +(deftest symbol-complexp (test-if-not-in-cl-package "complexp") nil) +(deftest symbol-compute-applicable-methods (test-if-not-in-cl-package "compute-applicable-methods") nil) +(deftest symbol-compute-restarts (test-if-not-in-cl-package "compute-restarts") nil) +(deftest symbol-concatenate (test-if-not-in-cl-package "concatenate") nil) +(deftest symbol-concatenated-stream (test-if-not-in-cl-package "concatenated-stream") nil) +(deftest symbol-concatenated-stream-streams (test-if-not-in-cl-package "concatenated-stream-streams") nil) +(deftest symbol-cond (test-if-not-in-cl-package "cond") nil) +(deftest symbol-condition (test-if-not-in-cl-package "condition") nil) +(deftest symbol-conjugate (test-if-not-in-cl-package "conjugate") nil) +(deftest symbol-cons (test-if-not-in-cl-package "cons") nil) +(deftest symbol-consp (test-if-not-in-cl-package "consp") nil) +(deftest symbol-constantly (test-if-not-in-cl-package "constantly") nil) +(deftest symbol-constantp (test-if-not-in-cl-package "constantp") nil) +(deftest symbol-continue (test-if-not-in-cl-package "continue") nil) +(deftest symbol-control-error (test-if-not-in-cl-package "control-error") nil) +(deftest symbol-copy-alist (test-if-not-in-cl-package "copy-alist") nil) +(deftest symbol-copy-list (test-if-not-in-cl-package "copy-list") nil) +(deftest symbol-copy-pprint-dispatch (test-if-not-in-cl-package "copy-pprint-dispatch") nil) +(deftest symbol-copy-readtable (test-if-not-in-cl-package "copy-readtable") nil) +(deftest symbol-copy-seq (test-if-not-in-cl-package "copy-seq") nil) +(deftest symbol-copy-structure (test-if-not-in-cl-package "copy-structure") nil) +(deftest symbol-copy-symbol (test-if-not-in-cl-package "copy-symbol") nil) +(deftest symbol-copy-tree (test-if-not-in-cl-package "copy-tree") nil) +(deftest symbol-cos (test-if-not-in-cl-package "cos") nil) +(deftest symbol-cosh (test-if-not-in-cl-package "cosh") nil) +(deftest symbol-count (test-if-not-in-cl-package "count") nil) +(deftest symbol-count-if (test-if-not-in-cl-package "count-if") nil) +(deftest symbol-count-if-not (test-if-not-in-cl-package "count-if-not") nil) +(deftest symbol-ctypecase (test-if-not-in-cl-package "ctypecase") nil) +(deftest symbol-debug (test-if-not-in-cl-package "debug") nil) +(deftest symbol-decf (test-if-not-in-cl-package "decf") nil) +(deftest symbol-declaim (test-if-not-in-cl-package "declaim") nil) +(deftest symbol-declaration (test-if-not-in-cl-package "declaration") nil) +(deftest symbol-declare (test-if-not-in-cl-package "declare") nil) +(deftest symbol-decode-float (test-if-not-in-cl-package "decode-float") nil) +(deftest symbol-decode-universal-time (test-if-not-in-cl-package "decode-universal-time") nil) +(deftest symbol-defclass (test-if-not-in-cl-package "defclass") nil) +(deftest symbol-defconstant (test-if-not-in-cl-package "defconstant") nil) +(deftest symbol-defgeneric (test-if-not-in-cl-package "defgeneric") nil) +(deftest symbol-define-compiler-macro (test-if-not-in-cl-package "define-compiler-macro") nil) +(deftest symbol-define-condition (test-if-not-in-cl-package "define-condition") nil) +(deftest symbol-define-method-combination (test-if-not-in-cl-package "define-method-combination") nil) +(deftest symbol-define-modify-macro (test-if-not-in-cl-package "define-modify-macro") nil) +(deftest symbol-define-setf-expander (test-if-not-in-cl-package "define-setf-expander") nil) +(deftest symbol-define-symbol-macro (test-if-not-in-cl-package "define-symbol-macro") nil) +(deftest symbol-defmacro (test-if-not-in-cl-package "defmacro") nil) +(deftest symbol-defmethod (test-if-not-in-cl-package "defmethod") nil) +(deftest symbol-defpackage (test-if-not-in-cl-package "defpackage") nil) +(deftest symbol-defparameter (test-if-not-in-cl-package "defparameter") nil) +(deftest symbol-defsetf (test-if-not-in-cl-package "defsetf") nil) +(deftest symbol-defstruct (test-if-not-in-cl-package "defstruct") nil) +(deftest symbol-deftype (test-if-not-in-cl-package "deftype") nil) +(deftest symbol-defun (test-if-not-in-cl-package "defun") nil) +(deftest symbol-defvar (test-if-not-in-cl-package "defvar") nil) +(deftest symbol-delete (test-if-not-in-cl-package "delete") nil) +(deftest symbol-delete-duplicates (test-if-not-in-cl-package "delete-duplicates") nil) +(deftest symbol-delete-file (test-if-not-in-cl-package "delete-file") nil) +(deftest symbol-delete-if (test-if-not-in-cl-package "delete-if") nil) +(deftest symbol-delete-if-not (test-if-not-in-cl-package "delete-if-not") nil) +(deftest symbol-delete-package (test-if-not-in-cl-package "delete-package") nil) +(deftest symbol-denominator (test-if-not-in-cl-package "denominator") nil) +(deftest symbol-deposit-field (test-if-not-in-cl-package "deposit-field") nil) +(deftest symbol-describe (test-if-not-in-cl-package "describe") nil) +(deftest symbol-describe-object (test-if-not-in-cl-package "describe-object") nil) +(deftest symbol-destructuring-bind (test-if-not-in-cl-package "destructuring-bind") nil) +(deftest symbol-digit-char (test-if-not-in-cl-package "digit-char") nil) +(deftest symbol-digit-char-p (test-if-not-in-cl-package "digit-char-p") nil) +(deftest symbol-directory (test-if-not-in-cl-package "directory") nil) +(deftest symbol-directory-namestring (test-if-not-in-cl-package "directory-namestring") nil) +(deftest symbol-disassemble (test-if-not-in-cl-package "disassemble") nil) +(deftest symbol-division-by-zero (test-if-not-in-cl-package "division-by-zero") nil) +(deftest symbol-do (test-if-not-in-cl-package "do") nil) +(deftest symbol-do* (test-if-not-in-cl-package "do*") nil) +(deftest symbol-do-all-symbols (test-if-not-in-cl-package "do-all-symbols") nil) +(deftest symbol-do-external-symbols (test-if-not-in-cl-package "do-external-symbols") nil) +(deftest symbol-do-symbols (test-if-not-in-cl-package "do-symbols") nil) +(deftest symbol-documentation (test-if-not-in-cl-package "documentation") nil) +(deftest symbol-dolist (test-if-not-in-cl-package "dolist") nil) +(deftest symbol-dotimes (test-if-not-in-cl-package "dotimes") nil) +(deftest symbol-double-float (test-if-not-in-cl-package "double-float") nil) +(deftest symbol-double-float-epsilon (test-if-not-in-cl-package "double-float-epsilon") nil) +(deftest symbol-double-float-negative-epsilon (test-if-not-in-cl-package "double-float-negative-epsilon") nil) +(deftest symbol-dpb (test-if-not-in-cl-package "dpb") nil) +(deftest symbol-dribble (test-if-not-in-cl-package "dribble") nil) +(deftest symbol-dynamic-extent (test-if-not-in-cl-package "dynamic-extent") nil) +(deftest symbol-ecase (test-if-not-in-cl-package "ecase") nil) +(deftest symbol-echo-stream (test-if-not-in-cl-package "echo-stream") nil) +(deftest symbol-echo-stream-input-stream (test-if-not-in-cl-package "echo-stream-input-stream") nil) +(deftest symbol-echo-stream-output-stream (test-if-not-in-cl-package "echo-stream-output-stream") nil) +(deftest symbol-ed (test-if-not-in-cl-package "ed") nil) +(deftest symbol-eighth (test-if-not-in-cl-package "eighth") nil) +(deftest symbol-elt (test-if-not-in-cl-package "elt") nil) +(deftest symbol-encode-universal-time (test-if-not-in-cl-package "encode-universal-time") nil) +(deftest symbol-end-of-file (test-if-not-in-cl-package "end-of-file") nil) +(deftest symbol-endp (test-if-not-in-cl-package "endp") nil) +(deftest symbol-enough-namestring (test-if-not-in-cl-package "enough-namestring") nil) +(deftest symbol-ensure-directories-exist (test-if-not-in-cl-package "ensure-directories-exist") nil) +(deftest symbol-ensure-generic-function (test-if-not-in-cl-package "ensure-generic-function") nil) +(deftest symbol-eq (test-if-not-in-cl-package "eq") nil) +(deftest symbol-eql (test-if-not-in-cl-package "eql") nil) +(deftest symbol-equal (test-if-not-in-cl-package "equal") nil) +(deftest symbol-equalp (test-if-not-in-cl-package "equalp") nil) +(deftest symbol-error (test-if-not-in-cl-package "error") nil) +(deftest symbol-etypecase (test-if-not-in-cl-package "etypecase") nil) +(deftest symbol-eval (test-if-not-in-cl-package "eval") nil) +(deftest symbol-eval-when (test-if-not-in-cl-package "eval-when") nil) +(deftest symbol-evenp (test-if-not-in-cl-package "evenp") nil) +(deftest symbol-every (test-if-not-in-cl-package "every") nil) +(deftest symbol-exp (test-if-not-in-cl-package "exp") nil) +(deftest symbol-export (test-if-not-in-cl-package "export") nil) +(deftest symbol-expt (test-if-not-in-cl-package "expt") nil) +(deftest symbol-extended-char (test-if-not-in-cl-package "extended-char") nil) +(deftest symbol-fboundp (test-if-not-in-cl-package "fboundp") nil) +(deftest symbol-fceiling (test-if-not-in-cl-package "fceiling") nil) +(deftest symbol-fdefinition (test-if-not-in-cl-package "fdefinition") nil) +(deftest symbol-ffloor (test-if-not-in-cl-package "ffloor") nil) +(deftest symbol-fifth (test-if-not-in-cl-package "fifth") nil) +(deftest symbol-file-author (test-if-not-in-cl-package "file-author") nil) +(deftest symbol-file-error (test-if-not-in-cl-package "file-error") nil) +(deftest symbol-file-error-pathname (test-if-not-in-cl-package "file-error-pathname") nil) +(deftest symbol-file-length (test-if-not-in-cl-package "file-length") nil) +(deftest symbol-file-namestring (test-if-not-in-cl-package "file-namestring") nil) +(deftest symbol-file-position (test-if-not-in-cl-package "file-position") nil) +(deftest symbol-file-stream (test-if-not-in-cl-package "file-stream") nil) +(deftest symbol-file-string-length (test-if-not-in-cl-package "file-string-length") nil) +(deftest symbol-file-write-date (test-if-not-in-cl-package "file-write-date") nil) +(deftest symbol-fill (test-if-not-in-cl-package "fill") nil) +(deftest symbol-fill-pointer (test-if-not-in-cl-package "fill-pointer") nil) +(deftest symbol-find (test-if-not-in-cl-package "find") nil) +(deftest symbol-find-all-symbols (test-if-not-in-cl-package "find-all-symbols") nil) +(deftest symbol-find-class (test-if-not-in-cl-package "find-class") nil) +(deftest symbol-find-if (test-if-not-in-cl-package "find-if") nil) +(deftest symbol-find-if-not (test-if-not-in-cl-package "find-if-not") nil) +(deftest symbol-find-method (test-if-not-in-cl-package "find-method") nil) +(deftest symbol-find-package (test-if-not-in-cl-package "find-package") nil) +(deftest symbol-find-restart (test-if-not-in-cl-package "find-restart") nil) +(deftest symbol-find-symbol (test-if-not-in-cl-package "find-symbol") nil) +(deftest symbol-finish-output (test-if-not-in-cl-package "finish-output") nil) +(deftest symbol-first (test-if-not-in-cl-package "first") nil) +(deftest symbol-fixnum (test-if-not-in-cl-package "fixnum") nil) +(deftest symbol-flet (test-if-not-in-cl-package "flet") nil) +(deftest symbol-float (test-if-not-in-cl-package "float") nil) +(deftest symbol-float-digits (test-if-not-in-cl-package "float-digits") nil) +(deftest symbol-float-precision (test-if-not-in-cl-package "float-precision") nil) +(deftest symbol-float-radix (test-if-not-in-cl-package "float-radix") nil) +(deftest symbol-float-sign (test-if-not-in-cl-package "float-sign") nil) +(deftest symbol-floating-point-inexact (test-if-not-in-cl-package "floating-point-inexact") nil) +(deftest symbol-floating-point-invalid-operation (test-if-not-in-cl-package "floating-point-invalid-operation") nil) +(deftest symbol-floating-point-overflow (test-if-not-in-cl-package "floating-point-overflow") nil) +(deftest symbol-floating-point-underflow (test-if-not-in-cl-package "floating-point-underflow") nil) +(deftest symbol-floatp (test-if-not-in-cl-package "floatp") nil) +(deftest symbol-floor (test-if-not-in-cl-package "floor") nil) +(deftest symbol-fmakunbound (test-if-not-in-cl-package "fmakunbound") nil) +(deftest symbol-force-output (test-if-not-in-cl-package "force-output") nil) +(deftest symbol-format (test-if-not-in-cl-package "format") nil) +(deftest symbol-formatter (test-if-not-in-cl-package "formatter") nil) +(deftest symbol-fourth (test-if-not-in-cl-package "fourth") nil) +(deftest symbol-fresh-line (test-if-not-in-cl-package "fresh-line") nil) +(deftest symbol-fround (test-if-not-in-cl-package "fround") nil) +(deftest symbol-ftruncate (test-if-not-in-cl-package "ftruncate") nil) +(deftest symbol-ftype (test-if-not-in-cl-package "ftype") nil) +(deftest symbol-funcall (test-if-not-in-cl-package "funcall") nil) +(deftest symbol-function (test-if-not-in-cl-package "function") nil) +(deftest symbol-function-keywords (test-if-not-in-cl-package "function-keywords") nil) +(deftest symbol-function-lambda-expression (test-if-not-in-cl-package "function-lambda-expression") nil) +(deftest symbol-functionp (test-if-not-in-cl-package "functionp") nil) +(deftest symbol-gcd (test-if-not-in-cl-package "gcd") nil) +(deftest symbol-generic-function (test-if-not-in-cl-package "generic-function") nil) +(deftest symbol-gensym (test-if-not-in-cl-package "gensym") nil) +(deftest symbol-gentemp (test-if-not-in-cl-package "gentemp") nil) +(deftest symbol-get (test-if-not-in-cl-package "get") nil) +(deftest symbol-get-decoded-time (test-if-not-in-cl-package "get-decoded-time") nil) +(deftest symbol-get-dispatch-macro-character (test-if-not-in-cl-package "get-dispatch-macro-character") nil) +(deftest symbol-get-internal-real-time (test-if-not-in-cl-package "get-internal-real-time") nil) +(deftest symbol-get-internal-run-time (test-if-not-in-cl-package "get-internal-run-time") nil) +(deftest symbol-get-macro-character (test-if-not-in-cl-package "get-macro-character") nil) +(deftest symbol-get-output-stream-string (test-if-not-in-cl-package "get-output-stream-string") nil) +(deftest symbol-get-properties (test-if-not-in-cl-package "get-properties") nil) +(deftest symbol-get-setf-expansion (test-if-not-in-cl-package "get-setf-expansion") nil) +(deftest symbol-get-universal-time (test-if-not-in-cl-package "get-universal-time") nil) +(deftest symbol-getf (test-if-not-in-cl-package "getf") nil) +(deftest symbol-gethash (test-if-not-in-cl-package "gethash") nil) +(deftest symbol-go (test-if-not-in-cl-package "go") nil) +(deftest symbol-graphic-char-p (test-if-not-in-cl-package "graphic-char-p") nil) +(deftest symbol-handler-bind (test-if-not-in-cl-package "handler-bind") nil) +(deftest symbol-handler-case (test-if-not-in-cl-package "handler-case") nil) +(deftest symbol-hash-table (test-if-not-in-cl-package "hash-table") nil) +(deftest symbol-hash-table-count (test-if-not-in-cl-package "hash-table-count") nil) +(deftest symbol-hash-table-p (test-if-not-in-cl-package "hash-table-p") nil) +(deftest symbol-hash-table-rehash-size (test-if-not-in-cl-package "hash-table-rehash-size") nil) +(deftest symbol-hash-table-rehash-threshold (test-if-not-in-cl-package "hash-table-rehash-threshold") nil) +(deftest symbol-hash-table-size (test-if-not-in-cl-package "hash-table-size") nil) +(deftest symbol-hash-table-test (test-if-not-in-cl-package "hash-table-test") nil) +(deftest symbol-host-namestring (test-if-not-in-cl-package "host-namestring") nil) +(deftest symbol-identity (test-if-not-in-cl-package "identity") nil) +(deftest symbol-if (test-if-not-in-cl-package "if") nil) +(deftest symbol-ignorable (test-if-not-in-cl-package "ignorable") nil) +(deftest symbol-ignore (test-if-not-in-cl-package "ignore") nil) +(deftest symbol-ignore-errors (test-if-not-in-cl-package "ignore-errors") nil) +(deftest symbol-imagpart (test-if-not-in-cl-package "imagpart") nil) +(deftest symbol-import (test-if-not-in-cl-package "import") nil) +(deftest symbol-in-package (test-if-not-in-cl-package "in-package") nil) +(deftest symbol-incf (test-if-not-in-cl-package "incf") nil) +(deftest symbol-initialize-instance (test-if-not-in-cl-package "initialize-instance") nil) +(deftest symbol-inline (test-if-not-in-cl-package "inline") nil) +(deftest symbol-input-stream-p (test-if-not-in-cl-package "input-stream-p") nil) +(deftest symbol-inspect (test-if-not-in-cl-package "inspect") nil) +(deftest symbol-integer (test-if-not-in-cl-package "integer") nil) +(deftest symbol-integer-decode-float (test-if-not-in-cl-package "integer-decode-float") nil) +(deftest symbol-integer-length (test-if-not-in-cl-package "integer-length") nil) +(deftest symbol-integerp (test-if-not-in-cl-package "integerp") nil) +(deftest symbol-interactive-stream-p (test-if-not-in-cl-package "interactive-stream-p") nil) +(deftest symbol-intern (test-if-not-in-cl-package "intern") nil) +(deftest symbol-internal-time-units-per-second (test-if-not-in-cl-package "internal-time-units-per-second") nil) +(deftest symbol-intersection (test-if-not-in-cl-package "intersection") nil) +(deftest symbol-invalid-method-error (test-if-not-in-cl-package "invalid-method-error") nil) +(deftest symbol-invoke-debugger (test-if-not-in-cl-package "invoke-debugger") nil) +(deftest symbol-invoke-restart (test-if-not-in-cl-package "invoke-restart") nil) +(deftest symbol-invoke-restart-interactively (test-if-not-in-cl-package "invoke-restart-interactively") nil) +(deftest symbol-isqrt (test-if-not-in-cl-package "isqrt") nil) +(deftest symbol-keyword (test-if-not-in-cl-package "keyword") nil) +(deftest symbol-keywordp (test-if-not-in-cl-package "keywordp") nil) +(deftest symbol-labels (test-if-not-in-cl-package "labels") nil) +(deftest symbol-lambda (test-if-not-in-cl-package "lambda") nil) +(deftest symbol-lambda-list-keywords (test-if-not-in-cl-package "lambda-list-keywords") nil) +(deftest symbol-lambda-parameters-limit (test-if-not-in-cl-package "lambda-parameters-limit") nil) +(deftest symbol-last (test-if-not-in-cl-package "last") nil) +(deftest symbol-lcm (test-if-not-in-cl-package "lcm") nil) +(deftest symbol-ldb (test-if-not-in-cl-package "ldb") nil) +(deftest symbol-ldb-test (test-if-not-in-cl-package "ldb-test") nil) +(deftest symbol-ldiff (test-if-not-in-cl-package "ldiff") nil) +(deftest symbol-least-negative-double-float (test-if-not-in-cl-package "least-negative-double-float") nil) +(deftest symbol-least-negative-long-float (test-if-not-in-cl-package "least-negative-long-float") nil) +(deftest symbol-least-negative-normalized-double-float (test-if-not-in-cl-package "least-negative-normalized-double-float") nil) +(deftest symbol-least-negative-normalized-long-float (test-if-not-in-cl-package "least-negative-normalized-long-float") nil) +(deftest symbol-least-negative-normalized-short-float (test-if-not-in-cl-package "least-negative-normalized-short-float") nil) +(deftest symbol-least-negative-normalized-single-float (test-if-not-in-cl-package "least-negative-normalized-single-float") nil) +(deftest symbol-least-negative-short-float (test-if-not-in-cl-package "least-negative-short-float") nil) +(deftest symbol-least-negative-single-float (test-if-not-in-cl-package "least-negative-single-float") nil) +(deftest symbol-least-positive-double-float (test-if-not-in-cl-package "least-positive-double-float") nil) +(deftest symbol-least-positive-long-float (test-if-not-in-cl-package "least-positive-long-float") nil) +(deftest symbol-least-positive-normalized-double-float (test-if-not-in-cl-package "least-positive-normalized-double-float") nil) +(deftest symbol-least-positive-normalized-long-float (test-if-not-in-cl-package "least-positive-normalized-long-float") nil) +(deftest symbol-least-positive-normalized-short-float (test-if-not-in-cl-package "least-positive-normalized-short-float") nil) +(deftest symbol-least-positive-normalized-single-float (test-if-not-in-cl-package "least-positive-normalized-single-float") nil) +(deftest symbol-least-positive-short-float (test-if-not-in-cl-package "least-positive-short-float") nil) +(deftest symbol-least-positive-single-float (test-if-not-in-cl-package "least-positive-single-float") nil) +(deftest symbol-length (test-if-not-in-cl-package "length") nil) +(deftest symbol-let (test-if-not-in-cl-package "let") nil) +(deftest symbol-let* (test-if-not-in-cl-package "let*") nil) +(deftest symbol-lisp-implementation-type (test-if-not-in-cl-package "lisp-implementation-type") nil) +(deftest symbol-lisp-implementation-version (test-if-not-in-cl-package "lisp-implementation-version") nil) +(deftest symbol-list (test-if-not-in-cl-package "list") nil) +(deftest symbol-list* (test-if-not-in-cl-package "list*") nil) +(deftest symbol-list-all-packages (test-if-not-in-cl-package "list-all-packages") nil) +(deftest symbol-list-length (test-if-not-in-cl-package "list-length") nil) +(deftest symbol-listen (test-if-not-in-cl-package "listen") nil) +(deftest symbol-listp (test-if-not-in-cl-package "listp") nil) +(deftest symbol-load (test-if-not-in-cl-package "load") nil) +(deftest symbol-load-logical-pathname-translations (test-if-not-in-cl-package "load-logical-pathname-translations") nil) +(deftest symbol-load-time-value (test-if-not-in-cl-package "load-time-value") nil) +(deftest symbol-locally (test-if-not-in-cl-package "locally") nil) +(deftest symbol-log (test-if-not-in-cl-package "log") nil) +(deftest symbol-logand (test-if-not-in-cl-package "logand") nil) +(deftest symbol-logandc1 (test-if-not-in-cl-package "logandc1") nil) +(deftest symbol-logandc2 (test-if-not-in-cl-package "logandc2") nil) +(deftest symbol-logbitp (test-if-not-in-cl-package "logbitp") nil) +(deftest symbol-logcount (test-if-not-in-cl-package "logcount") nil) +(deftest symbol-logeqv (test-if-not-in-cl-package "logeqv") nil) +(deftest symbol-logical-pathname (test-if-not-in-cl-package "logical-pathname") nil) +(deftest symbol-logical-pathname-translations (test-if-not-in-cl-package "logical-pathname-translations") nil) +(deftest symbol-logior (test-if-not-in-cl-package "logior") nil) +(deftest symbol-lognand (test-if-not-in-cl-package "lognand") nil) +(deftest symbol-lognor (test-if-not-in-cl-package "lognor") nil) +(deftest symbol-lognot (test-if-not-in-cl-package "lognot") nil) +(deftest symbol-logorc1 (test-if-not-in-cl-package "logorc1") nil) +(deftest symbol-logorc2 (test-if-not-in-cl-package "logorc2") nil) +(deftest symbol-logtest (test-if-not-in-cl-package "logtest") nil) +(deftest symbol-logxor (test-if-not-in-cl-package "logxor") nil) +(deftest symbol-long-float (test-if-not-in-cl-package "long-float") nil) +(deftest symbol-long-float-epsilon (test-if-not-in-cl-package "long-float-epsilon") nil) +(deftest symbol-long-float-negative-epsilon (test-if-not-in-cl-package "long-float-negative-epsilon") nil) +(deftest symbol-long-site-name (test-if-not-in-cl-package "long-site-name") nil) +(deftest symbol-loop (test-if-not-in-cl-package "loop") nil) +(deftest symbol-loop-finish (test-if-not-in-cl-package "loop-finish") nil) +(deftest symbol-lower-case-p (test-if-not-in-cl-package "lower-case-p") nil) +(deftest symbol-machine-instance (test-if-not-in-cl-package "machine-instance") nil) +(deftest symbol-machine-type (test-if-not-in-cl-package "machine-type") nil) +(deftest symbol-machine-version (test-if-not-in-cl-package "machine-version") nil) +(deftest symbol-macro-function (test-if-not-in-cl-package "macro-function") nil) +(deftest symbol-macroexpand (test-if-not-in-cl-package "macroexpand") nil) +(deftest symbol-macroexpand-1 (test-if-not-in-cl-package "macroexpand-1") nil) +(deftest symbol-macrolet (test-if-not-in-cl-package "macrolet") nil) +(deftest symbol-make-array (test-if-not-in-cl-package "make-array") nil) +(deftest symbol-make-broadcast-stream (test-if-not-in-cl-package "make-broadcast-stream") nil) +(deftest symbol-make-concatenated-stream (test-if-not-in-cl-package "make-concatenated-stream") nil) +(deftest symbol-make-condition (test-if-not-in-cl-package "make-condition") nil) +(deftest symbol-make-dispatch-macro-character (test-if-not-in-cl-package "make-dispatch-macro-character") nil) +(deftest symbol-make-echo-stream (test-if-not-in-cl-package "make-echo-stream") nil) +(deftest symbol-make-hash-table (test-if-not-in-cl-package "make-hash-table") nil) +(deftest symbol-make-instance (test-if-not-in-cl-package "make-instance") nil) +(deftest symbol-make-instances-obsolete (test-if-not-in-cl-package "make-instances-obsolete") nil) +(deftest symbol-make-list (test-if-not-in-cl-package "make-list") nil) +(deftest symbol-make-load-form (test-if-not-in-cl-package "make-load-form") nil) +(deftest symbol-make-load-form-saving-slots (test-if-not-in-cl-package "make-load-form-saving-slots") nil) +(deftest symbol-make-method (test-if-not-in-cl-package "make-method") nil) +(deftest symbol-make-package (test-if-not-in-cl-package "make-package") nil) +(deftest symbol-make-pathname (test-if-not-in-cl-package "make-pathname") nil) +(deftest symbol-make-random-state (test-if-not-in-cl-package "make-random-state") nil) +(deftest symbol-make-sequence (test-if-not-in-cl-package "make-sequence") nil) +(deftest symbol-make-string (test-if-not-in-cl-package "make-string") nil) +(deftest symbol-make-string-input-stream (test-if-not-in-cl-package "make-string-input-stream") nil) +(deftest symbol-make-string-output-stream (test-if-not-in-cl-package "make-string-output-stream") nil) +(deftest symbol-make-symbol (test-if-not-in-cl-package "make-symbol") nil) +(deftest symbol-make-synonym-stream (test-if-not-in-cl-package "make-synonym-stream") nil) +(deftest symbol-make-two-way-stream (test-if-not-in-cl-package "make-two-way-stream") nil) +(deftest symbol-makunbound (test-if-not-in-cl-package "makunbound") nil) +(deftest symbol-map (test-if-not-in-cl-package "map") nil) +(deftest symbol-map-into (test-if-not-in-cl-package "map-into") nil) +(deftest symbol-mapc (test-if-not-in-cl-package "mapc") nil) +(deftest symbol-mapcan (test-if-not-in-cl-package "mapcan") nil) +(deftest symbol-mapcar (test-if-not-in-cl-package "mapcar") nil) +(deftest symbol-mapcon (test-if-not-in-cl-package "mapcon") nil) +(deftest symbol-maphash (test-if-not-in-cl-package "maphash") nil) +(deftest symbol-mapl (test-if-not-in-cl-package "mapl") nil) +(deftest symbol-maplist (test-if-not-in-cl-package "maplist") nil) +(deftest symbol-mask-field (test-if-not-in-cl-package "mask-field") nil) +(deftest symbol-max (test-if-not-in-cl-package "max") nil) +(deftest symbol-member (test-if-not-in-cl-package "member") nil) +(deftest symbol-member-if (test-if-not-in-cl-package "member-if") nil) +(deftest symbol-member-if-not (test-if-not-in-cl-package "member-if-not") nil) +(deftest symbol-merge (test-if-not-in-cl-package "merge") nil) +(deftest symbol-merge-pathnames (test-if-not-in-cl-package "merge-pathnames") nil) +(deftest symbol-method (test-if-not-in-cl-package "method") nil) +(deftest symbol-method-combination (test-if-not-in-cl-package "method-combination") nil) +(deftest symbol-method-combination-error (test-if-not-in-cl-package "method-combination-error") nil) +(deftest symbol-method-qualifiers (test-if-not-in-cl-package "method-qualifiers") nil) +(deftest symbol-min (test-if-not-in-cl-package "min") nil) +(deftest symbol-minusp (test-if-not-in-cl-package "minusp") nil) +(deftest symbol-mismatch (test-if-not-in-cl-package "mismatch") nil) +(deftest symbol-mod (test-if-not-in-cl-package "mod") nil) +(deftest symbol-most-negative-double-float (test-if-not-in-cl-package "most-negative-double-float") nil) +(deftest symbol-most-negative-fixnum (test-if-not-in-cl-package "most-negative-fixnum") nil) +(deftest symbol-most-negative-long-float (test-if-not-in-cl-package "most-negative-long-float") nil) +(deftest symbol-most-negative-short-float (test-if-not-in-cl-package "most-negative-short-float") nil) +(deftest symbol-most-negative-single-float (test-if-not-in-cl-package "most-negative-single-float") nil) +(deftest symbol-most-positive-double-float (test-if-not-in-cl-package "most-positive-double-float") nil) +(deftest symbol-most-positive-fixnum (test-if-not-in-cl-package "most-positive-fixnum") nil) +(deftest symbol-most-positive-long-float (test-if-not-in-cl-package "most-positive-long-float") nil) +(deftest symbol-most-positive-short-float (test-if-not-in-cl-package "most-positive-short-float") nil) +(deftest symbol-most-positive-single-float (test-if-not-in-cl-package "most-positive-single-float") nil) +(deftest symbol-muffle-warning (test-if-not-in-cl-package "muffle-warning") nil) +(deftest symbol-multiple-value-bind (test-if-not-in-cl-package "multiple-value-bind") nil) +(deftest symbol-multiple-value-call (test-if-not-in-cl-package "multiple-value-call") nil) +(deftest symbol-multiple-value-list (test-if-not-in-cl-package "multiple-value-list") nil) +(deftest symbol-multiple-value-prog1 (test-if-not-in-cl-package "multiple-value-prog1") nil) +(deftest symbol-multiple-value-setq (test-if-not-in-cl-package "multiple-value-setq") nil) +(deftest symbol-multiple-values-limit (test-if-not-in-cl-package "multiple-values-limit") nil) +(deftest symbol-name-char (test-if-not-in-cl-package "name-char") nil) +(deftest symbol-namestring (test-if-not-in-cl-package "namestring") nil) +(deftest symbol-nbutlast (test-if-not-in-cl-package "nbutlast") nil) +(deftest symbol-nconc (test-if-not-in-cl-package "nconc") nil) +(deftest symbol-next-method-p (test-if-not-in-cl-package "next-method-p") nil) +(deftest symbol-nil (test-if-not-in-cl-package "nil") nil) +(deftest symbol-nintersection (test-if-not-in-cl-package "nintersection") nil) +(deftest symbol-ninth (test-if-not-in-cl-package "ninth") nil) +(deftest symbol-no-applicable-method (test-if-not-in-cl-package "no-applicable-method") nil) +(deftest symbol-no-next-method (test-if-not-in-cl-package "no-next-method") nil) +(deftest symbol-not (test-if-not-in-cl-package "not") nil) +(deftest symbol-notany (test-if-not-in-cl-package "notany") nil) +(deftest symbol-notevery (test-if-not-in-cl-package "notevery") nil) +(deftest symbol-notinline (test-if-not-in-cl-package "notinline") nil) +(deftest symbol-nreconc (test-if-not-in-cl-package "nreconc") nil) +(deftest symbol-nreverse (test-if-not-in-cl-package "nreverse") nil) +(deftest symbol-nset-difference (test-if-not-in-cl-package "nset-difference") nil) +(deftest symbol-nset-exclusive-or (test-if-not-in-cl-package "nset-exclusive-or") nil) +(deftest symbol-nstring-capitalize (test-if-not-in-cl-package "nstring-capitalize") nil) +(deftest symbol-nstring-downcase (test-if-not-in-cl-package "nstring-downcase") nil) +(deftest symbol-nstring-upcase (test-if-not-in-cl-package "nstring-upcase") nil) +(deftest symbol-nsublis (test-if-not-in-cl-package "nsublis") nil) +(deftest symbol-nsubst (test-if-not-in-cl-package "nsubst") nil) +(deftest symbol-nsubst-if (test-if-not-in-cl-package "nsubst-if") nil) +(deftest symbol-nsubst-if-not (test-if-not-in-cl-package "nsubst-if-not") nil) +(deftest symbol-nsubstitute (test-if-not-in-cl-package "nsubstitute") nil) +(deftest symbol-nsubstitute-if (test-if-not-in-cl-package "nsubstitute-if") nil) +(deftest symbol-nsubstitute-if-not (test-if-not-in-cl-package "nsubstitute-if-not") nil) +(deftest symbol-nth (test-if-not-in-cl-package "nth") nil) +(deftest symbol-nth-value (test-if-not-in-cl-package "nth-value") nil) +(deftest symbol-nthcdr (test-if-not-in-cl-package "nthcdr") nil) +(deftest symbol-null (test-if-not-in-cl-package "null") nil) +(deftest symbol-number (test-if-not-in-cl-package "number") nil) +(deftest symbol-numberp (test-if-not-in-cl-package "numberp") nil) +(deftest symbol-numerator (test-if-not-in-cl-package "numerator") nil) +(deftest symbol-nunion (test-if-not-in-cl-package "nunion") nil) +(deftest symbol-oddp (test-if-not-in-cl-package "oddp") nil) +(deftest symbol-open (test-if-not-in-cl-package "open") nil) +(deftest symbol-open-stream-p (test-if-not-in-cl-package "open-stream-p") nil) +(deftest symbol-optimize (test-if-not-in-cl-package "optimize") nil) +(deftest symbol-or (test-if-not-in-cl-package "or") nil) +(deftest symbol-otherwise (test-if-not-in-cl-package "otherwise") nil) +(deftest symbol-output-stream-p (test-if-not-in-cl-package "output-stream-p") nil) +(deftest symbol-package (test-if-not-in-cl-package "package") nil) +(deftest symbol-package-error (test-if-not-in-cl-package "package-error") nil) +(deftest symbol-package-error-package (test-if-not-in-cl-package "package-error-package") nil) +(deftest symbol-package-name (test-if-not-in-cl-package "package-name") nil) +(deftest symbol-package-nicknames (test-if-not-in-cl-package "package-nicknames") nil) +(deftest symbol-package-shadowing-symbols (test-if-not-in-cl-package "package-shadowing-symbols") nil) +(deftest symbol-package-use-list (test-if-not-in-cl-package "package-use-list") nil) +(deftest symbol-package-used-by-list (test-if-not-in-cl-package "package-used-by-list") nil) +(deftest symbol-packagep (test-if-not-in-cl-package "packagep") nil) +(deftest symbol-pairlis (test-if-not-in-cl-package "pairlis") nil) +(deftest symbol-parse-error (test-if-not-in-cl-package "parse-error") nil) +(deftest symbol-parse-integer (test-if-not-in-cl-package "parse-integer") nil) +(deftest symbol-parse-namestring (test-if-not-in-cl-package "parse-namestring") nil) +(deftest symbol-pathname (test-if-not-in-cl-package "pathname") nil) +(deftest symbol-pathname-device (test-if-not-in-cl-package "pathname-device") nil) +(deftest symbol-pathname-directory (test-if-not-in-cl-package "pathname-directory") nil) +(deftest symbol-pathname-host (test-if-not-in-cl-package "pathname-host") nil) +(deftest symbol-pathname-match-p (test-if-not-in-cl-package "pathname-match-p") nil) +(deftest symbol-pathname-name (test-if-not-in-cl-package "pathname-name") nil) +(deftest symbol-pathname-type (test-if-not-in-cl-package "pathname-type") nil) +(deftest symbol-pathname-version (test-if-not-in-cl-package "pathname-version") nil) +(deftest symbol-pathnamep (test-if-not-in-cl-package "pathnamep") nil) +(deftest symbol-peek-char (test-if-not-in-cl-package "peek-char") nil) +(deftest symbol-phase (test-if-not-in-cl-package "phase") nil) +(deftest symbol-pi (test-if-not-in-cl-package "pi") nil) +(deftest symbol-plusp (test-if-not-in-cl-package "plusp") nil) +(deftest symbol-pop (test-if-not-in-cl-package "pop") nil) +(deftest symbol-position (test-if-not-in-cl-package "position") nil) +(deftest symbol-position-if (test-if-not-in-cl-package "position-if") nil) +(deftest symbol-position-if-not (test-if-not-in-cl-package "position-if-not") nil) +(deftest symbol-pprint (test-if-not-in-cl-package "pprint") nil) +(deftest symbol-pprint-dispatch (test-if-not-in-cl-package "pprint-dispatch") nil) +(deftest symbol-pprint-exit-if-list-exhausted (test-if-not-in-cl-package "pprint-exit-if-list-exhausted") nil) +(deftest symbol-pprint-fill (test-if-not-in-cl-package "pprint-fill") nil) +(deftest symbol-pprint-indent (test-if-not-in-cl-package "pprint-indent") nil) +(deftest symbol-pprint-linear (test-if-not-in-cl-package "pprint-linear") nil) +(deftest symbol-pprint-logical-block (test-if-not-in-cl-package "pprint-logical-block") nil) +(deftest symbol-pprint-newline (test-if-not-in-cl-package "pprint-newline") nil) +(deftest symbol-pprint-pop (test-if-not-in-cl-package "pprint-pop") nil) +(deftest symbol-pprint-tab (test-if-not-in-cl-package "pprint-tab") nil) +(deftest symbol-pprint-tabular (test-if-not-in-cl-package "pprint-tabular") nil) +(deftest symbol-prin1 (test-if-not-in-cl-package "prin1") nil) +(deftest symbol-prin1-to-string (test-if-not-in-cl-package "prin1-to-string") nil) +(deftest symbol-princ (test-if-not-in-cl-package "princ") nil) +(deftest symbol-princ-to-string (test-if-not-in-cl-package "princ-to-string") nil) +(deftest symbol-print (test-if-not-in-cl-package "print") nil) +(deftest symbol-print-not-readable (test-if-not-in-cl-package "print-not-readable") nil) +(deftest symbol-print-not-readable-object (test-if-not-in-cl-package "print-not-readable-object") nil) +(deftest symbol-print-object (test-if-not-in-cl-package "print-object") nil) +(deftest symbol-print-unreadable-object (test-if-not-in-cl-package "print-unreadable-object") nil) +(deftest symbol-probe-file (test-if-not-in-cl-package "probe-file") nil) +(deftest symbol-proclaim (test-if-not-in-cl-package "proclaim") nil) +(deftest symbol-prog (test-if-not-in-cl-package "prog") nil) +(deftest symbol-prog* (test-if-not-in-cl-package "prog*") nil) +(deftest symbol-prog1 (test-if-not-in-cl-package "prog1") nil) +(deftest symbol-prog2 (test-if-not-in-cl-package "prog2") nil) +(deftest symbol-progn (test-if-not-in-cl-package "progn") nil) +(deftest symbol-program-error (test-if-not-in-cl-package "program-error") nil) +(deftest symbol-progv (test-if-not-in-cl-package "progv") nil) +(deftest symbol-provide (test-if-not-in-cl-package "provide") nil) +(deftest symbol-psetf (test-if-not-in-cl-package "psetf") nil) +(deftest symbol-psetq (test-if-not-in-cl-package "psetq") nil) +(deftest symbol-push (test-if-not-in-cl-package "push") nil) +(deftest symbol-pushnew (test-if-not-in-cl-package "pushnew") nil) +(deftest symbol-quote (test-if-not-in-cl-package "quote") nil) +(deftest symbol-random (test-if-not-in-cl-package "random") nil) +(deftest symbol-random-state (test-if-not-in-cl-package "random-state") nil) +(deftest symbol-random-state-p (test-if-not-in-cl-package "random-state-p") nil) +(deftest symbol-rassoc (test-if-not-in-cl-package "rassoc") nil) +(deftest symbol-rassoc-if (test-if-not-in-cl-package "rassoc-if") nil) +(deftest symbol-rassoc-if-not (test-if-not-in-cl-package "rassoc-if-not") nil) +(deftest symbol-ratio (test-if-not-in-cl-package "ratio") nil) +(deftest symbol-rational (test-if-not-in-cl-package "rational") nil) +(deftest symbol-rationalize (test-if-not-in-cl-package "rationalize") nil) +(deftest symbol-rationalp (test-if-not-in-cl-package "rationalp") nil) +(deftest symbol-read (test-if-not-in-cl-package "read") nil) +(deftest symbol-read-byte (test-if-not-in-cl-package "read-byte") nil) +(deftest symbol-read-char (test-if-not-in-cl-package "read-char") nil) +(deftest symbol-read-char-no-hang (test-if-not-in-cl-package "read-char-no-hang") nil) +(deftest symbol-read-delimited-list (test-if-not-in-cl-package "read-delimited-list") nil) +(deftest symbol-read-from-string (test-if-not-in-cl-package "read-from-string") nil) +(deftest symbol-read-line (test-if-not-in-cl-package "read-line") nil) +(deftest symbol-read-preserving-whitespace (test-if-not-in-cl-package "read-preserving-whitespace") nil) +(deftest symbol-read-sequence (test-if-not-in-cl-package "read-sequence") nil) +(deftest symbol-reader-error (test-if-not-in-cl-package "reader-error") nil) +(deftest symbol-readtable (test-if-not-in-cl-package "readtable") nil) +(deftest symbol-readtable-case (test-if-not-in-cl-package "readtable-case") nil) +(deftest symbol-readtablep (test-if-not-in-cl-package "readtablep") nil) +(deftest symbol-real (test-if-not-in-cl-package "real") nil) +(deftest symbol-realp (test-if-not-in-cl-package "realp") nil) +(deftest symbol-realpart (test-if-not-in-cl-package "realpart") nil) +(deftest symbol-reduce (test-if-not-in-cl-package "reduce") nil) +(deftest symbol-reinitialize-instance (test-if-not-in-cl-package "reinitialize-instance") nil) +(deftest symbol-rem (test-if-not-in-cl-package "rem") nil) +(deftest symbol-remf (test-if-not-in-cl-package "remf") nil) +(deftest symbol-remhash (test-if-not-in-cl-package "remhash") nil) +(deftest symbol-remove (test-if-not-in-cl-package "remove") nil) +(deftest symbol-remove-duplicates (test-if-not-in-cl-package "remove-duplicates") nil) +(deftest symbol-remove-if (test-if-not-in-cl-package "remove-if") nil) +(deftest symbol-remove-if-not (test-if-not-in-cl-package "remove-if-not") nil) +(deftest symbol-remove-method (test-if-not-in-cl-package "remove-method") nil) +(deftest symbol-remprop (test-if-not-in-cl-package "remprop") nil) +(deftest symbol-rename-file (test-if-not-in-cl-package "rename-file") nil) +(deftest symbol-rename-package (test-if-not-in-cl-package "rename-package") nil) +(deftest symbol-replace (test-if-not-in-cl-package "replace") nil) +(deftest symbol-require (test-if-not-in-cl-package "require") nil) +(deftest symbol-rest (test-if-not-in-cl-package "rest") nil) +(deftest symbol-restart (test-if-not-in-cl-package "restart") nil) +(deftest symbol-restart-bind (test-if-not-in-cl-package "restart-bind") nil) +(deftest symbol-restart-case (test-if-not-in-cl-package "restart-case") nil) +(deftest symbol-restart-name (test-if-not-in-cl-package "restart-name") nil) +(deftest symbol-return (test-if-not-in-cl-package "return") nil) +(deftest symbol-return-from (test-if-not-in-cl-package "return-from") nil) +(deftest symbol-revappend (test-if-not-in-cl-package "revappend") nil) +(deftest symbol-reverse (test-if-not-in-cl-package "reverse") nil) +(deftest symbol-room (test-if-not-in-cl-package "room") nil) +(deftest symbol-rotatef (test-if-not-in-cl-package "rotatef") nil) +(deftest symbol-round (test-if-not-in-cl-package "round") nil) +(deftest symbol-row-major-aref (test-if-not-in-cl-package "row-major-aref") nil) +(deftest symbol-rplaca (test-if-not-in-cl-package "rplaca") nil) +(deftest symbol-rplacd (test-if-not-in-cl-package "rplacd") nil) +(deftest symbol-safety (test-if-not-in-cl-package "safety") nil) +(deftest symbol-satisfies (test-if-not-in-cl-package "satisfies") nil) +(deftest symbol-sbit (test-if-not-in-cl-package "sbit") nil) +(deftest symbol-scale-float (test-if-not-in-cl-package "scale-float") nil) +(deftest symbol-schar (test-if-not-in-cl-package "schar") nil) +(deftest symbol-search (test-if-not-in-cl-package "search") nil) +(deftest symbol-second (test-if-not-in-cl-package "second") nil) +(deftest symbol-sequence (test-if-not-in-cl-package "sequence") nil) +(deftest symbol-serious-condition (test-if-not-in-cl-package "serious-condition") nil) +(deftest symbol-set (test-if-not-in-cl-package "set") nil) +(deftest symbol-set-difference (test-if-not-in-cl-package "set-difference") nil) +(deftest symbol-set-dispatch-macro-character (test-if-not-in-cl-package "set-dispatch-macro-character") nil) +(deftest symbol-set-exclusive-or (test-if-not-in-cl-package "set-exclusive-or") nil) +(deftest symbol-set-macro-character (test-if-not-in-cl-package "set-macro-character") nil) +(deftest symbol-set-pprint-dispatch (test-if-not-in-cl-package "set-pprint-dispatch") nil) +(deftest symbol-set-syntax-from-char (test-if-not-in-cl-package "set-syntax-from-char") nil) +(deftest symbol-setf (test-if-not-in-cl-package "setf") nil) +(deftest symbol-setq (test-if-not-in-cl-package "setq") nil) +(deftest symbol-seventh (test-if-not-in-cl-package "seventh") nil) +(deftest symbol-shadow (test-if-not-in-cl-package "shadow") nil) +(deftest symbol-shadowing-import (test-if-not-in-cl-package "shadowing-import") nil) +(deftest symbol-shared-initialize (test-if-not-in-cl-package "shared-initialize") nil) +(deftest symbol-shiftf (test-if-not-in-cl-package "shiftf") nil) +(deftest symbol-short-float (test-if-not-in-cl-package "short-float") nil) +(deftest symbol-short-float-epsilon (test-if-not-in-cl-package "short-float-epsilon") nil) +(deftest symbol-short-float-negative-epsilon (test-if-not-in-cl-package "short-float-negative-epsilon") nil) +(deftest symbol-short-site-name (test-if-not-in-cl-package "short-site-name") nil) +(deftest symbol-signal (test-if-not-in-cl-package "signal") nil) +(deftest symbol-signed-byte (test-if-not-in-cl-package "signed-byte") nil) +(deftest symbol-signum (test-if-not-in-cl-package "signum") nil) +(deftest symbol-simple-array (test-if-not-in-cl-package "simple-array") nil) +(deftest symbol-simple-base-string (test-if-not-in-cl-package "simple-base-string") nil) +(deftest symbol-simple-bit-vector (test-if-not-in-cl-package "simple-bit-vector") nil) +(deftest symbol-simple-bit-vector-p (test-if-not-in-cl-package "simple-bit-vector-p") nil) +(deftest symbol-simple-condition (test-if-not-in-cl-package "simple-condition") nil) +(deftest symbol-simple-condition-format-arguments (test-if-not-in-cl-package "simple-condition-format-arguments") nil) +(deftest symbol-simple-condition-format-control (test-if-not-in-cl-package "simple-condition-format-control") nil) +(deftest symbol-simple-error (test-if-not-in-cl-package "simple-error") nil) +(deftest symbol-simple-string (test-if-not-in-cl-package "simple-string") nil) +(deftest symbol-simple-string-p (test-if-not-in-cl-package "simple-string-p") nil) +(deftest symbol-simple-type-error (test-if-not-in-cl-package "simple-type-error") nil) +(deftest symbol-simple-vector (test-if-not-in-cl-package "simple-vector") nil) +(deftest symbol-simple-vector-p (test-if-not-in-cl-package "simple-vector-p") nil) +(deftest symbol-simple-warning (test-if-not-in-cl-package "simple-warning") nil) +(deftest symbol-sin (test-if-not-in-cl-package "sin") nil) +(deftest symbol-single-float (test-if-not-in-cl-package "single-float") nil) +(deftest symbol-single-float-epsilon (test-if-not-in-cl-package "single-float-epsilon") nil) +(deftest symbol-single-float-negative-epsilon (test-if-not-in-cl-package "single-float-negative-epsilon") nil) +(deftest symbol-sinh (test-if-not-in-cl-package "sinh") nil) +(deftest symbol-sixth (test-if-not-in-cl-package "sixth") nil) +(deftest symbol-sleep (test-if-not-in-cl-package "sleep") nil) +(deftest symbol-slot-boundp (test-if-not-in-cl-package "slot-boundp") nil) +(deftest symbol-slot-exists-p (test-if-not-in-cl-package "slot-exists-p") nil) +(deftest symbol-slot-makunbound (test-if-not-in-cl-package "slot-makunbound") nil) +(deftest symbol-slot-missing (test-if-not-in-cl-package "slot-missing") nil) +(deftest symbol-slot-unbound (test-if-not-in-cl-package "slot-unbound") nil) +(deftest symbol-slot-value (test-if-not-in-cl-package "slot-value") nil) +(deftest symbol-software-type (test-if-not-in-cl-package "software-type") nil) +(deftest symbol-software-version (test-if-not-in-cl-package "software-version") nil) +(deftest symbol-some (test-if-not-in-cl-package "some") nil) +(deftest symbol-sort (test-if-not-in-cl-package "sort") nil) +(deftest symbol-space (test-if-not-in-cl-package "space") nil) +(deftest symbol-special (test-if-not-in-cl-package "special") nil) +(deftest symbol-special-operator-p (test-if-not-in-cl-package "special-operator-p") nil) +(deftest symbol-speed (test-if-not-in-cl-package "speed") nil) +(deftest symbol-sqrt (test-if-not-in-cl-package "sqrt") nil) +(deftest symbol-stable-sort (test-if-not-in-cl-package "stable-sort") nil) +(deftest symbol-standard (test-if-not-in-cl-package "standard") nil) +(deftest symbol-standard-char (test-if-not-in-cl-package "standard-char") nil) +(deftest symbol-standard-char-p (test-if-not-in-cl-package "standard-char-p") nil) +(deftest symbol-standard-class (test-if-not-in-cl-package "standard-class") nil) +(deftest symbol-standard-generic-function (test-if-not-in-cl-package "standard-generic-function") nil) +(deftest symbol-standard-method (test-if-not-in-cl-package "standard-method") nil) +(deftest symbol-standard-object (test-if-not-in-cl-package "standard-object") nil) +(deftest symbol-step (test-if-not-in-cl-package "step") nil) +(deftest symbol-storage-condition (test-if-not-in-cl-package "storage-condition") nil) +(deftest symbol-store-value (test-if-not-in-cl-package "store-value") nil) +(deftest symbol-stream (test-if-not-in-cl-package "stream") nil) +(deftest symbol-stream-element-type (test-if-not-in-cl-package "stream-element-type") nil) +(deftest symbol-stream-error (test-if-not-in-cl-package "stream-error") nil) +(deftest symbol-stream-error-stream (test-if-not-in-cl-package "stream-error-stream") nil) +(deftest symbol-stream-external-format (test-if-not-in-cl-package "stream-external-format") nil) +(deftest symbol-streamp (test-if-not-in-cl-package "streamp") nil) +(deftest symbol-string (test-if-not-in-cl-package "string") nil) +(deftest symbol-string-capitalize (test-if-not-in-cl-package "string-capitalize") nil) +(deftest symbol-string-downcase (test-if-not-in-cl-package "string-downcase") nil) +(deftest symbol-string-equal (test-if-not-in-cl-package "string-equal") nil) +(deftest symbol-string-greaterp (test-if-not-in-cl-package "string-greaterp") nil) +(deftest symbol-string-left-trim (test-if-not-in-cl-package "string-left-trim") nil) +(deftest symbol-string-lessp (test-if-not-in-cl-package "string-lessp") nil) +(deftest symbol-string-not-equal (test-if-not-in-cl-package "string-not-equal") nil) +(deftest symbol-string-not-greaterp (test-if-not-in-cl-package "string-not-greaterp") nil) +(deftest symbol-string-not-lessp (test-if-not-in-cl-package "string-not-lessp") nil) +(deftest symbol-string-right-trim (test-if-not-in-cl-package "string-right-trim") nil) +(deftest symbol-string-stream (test-if-not-in-cl-package "string-stream") nil) +(deftest symbol-string-trim (test-if-not-in-cl-package "string-trim") nil) +(deftest symbol-string-upcase (test-if-not-in-cl-package "string-upcase") nil) +(deftest symbol-string/= (test-if-not-in-cl-package "string/=") nil) +(deftest symbol-string< (test-if-not-in-cl-package "string<") nil) +(deftest symbol-string<= (test-if-not-in-cl-package "string<=") nil) +(deftest symbol-string= (test-if-not-in-cl-package "string=") nil) +(deftest symbol-string> (test-if-not-in-cl-package "string>") nil) +(deftest symbol-string>= (test-if-not-in-cl-package "string>=") nil) +(deftest symbol-stringp (test-if-not-in-cl-package "stringp") nil) +(deftest symbol-structure (test-if-not-in-cl-package "structure") nil) +(deftest symbol-structure-class (test-if-not-in-cl-package "structure-class") nil) +(deftest symbol-structure-object (test-if-not-in-cl-package "structure-object") nil) +(deftest symbol-style-warning (test-if-not-in-cl-package "style-warning") nil) +(deftest symbol-sublis (test-if-not-in-cl-package "sublis") nil) +(deftest symbol-subseq (test-if-not-in-cl-package "subseq") nil) +(deftest symbol-subsetp (test-if-not-in-cl-package "subsetp") nil) +(deftest symbol-subst (test-if-not-in-cl-package "subst") nil) +(deftest symbol-subst-if (test-if-not-in-cl-package "subst-if") nil) +(deftest symbol-subst-if-not (test-if-not-in-cl-package "subst-if-not") nil) +(deftest symbol-substitute (test-if-not-in-cl-package "substitute") nil) +(deftest symbol-substitute-if (test-if-not-in-cl-package "substitute-if") nil) +(deftest symbol-substitute-if-not (test-if-not-in-cl-package "substitute-if-not") nil) +(deftest symbol-subtypep (test-if-not-in-cl-package "subtypep") nil) +(deftest symbol-svref (test-if-not-in-cl-package "svref") nil) +(deftest symbol-sxhash (test-if-not-in-cl-package "sxhash") nil) +(deftest symbol-symbol (test-if-not-in-cl-package "symbol") nil) +(deftest symbol-symbol-function (test-if-not-in-cl-package "symbol-function") nil) +(deftest symbol-symbol-macrolet (test-if-not-in-cl-package "symbol-macrolet") nil) +(deftest symbol-symbol-name (test-if-not-in-cl-package "symbol-name") nil) +(deftest symbol-symbol-package (test-if-not-in-cl-package "symbol-package") nil) +(deftest symbol-symbol-plist (test-if-not-in-cl-package "symbol-plist") nil) +(deftest symbol-symbol-value (test-if-not-in-cl-package "symbol-value") nil) +(deftest symbol-symbolp (test-if-not-in-cl-package "symbolp") nil) +(deftest symbol-synonym-stream (test-if-not-in-cl-package "synonym-stream") nil) +(deftest symbol-synonym-stream-symbol (test-if-not-in-cl-package "synonym-stream-symbol") nil) +(deftest symbol-t (test-if-not-in-cl-package "t") nil) +(deftest symbol-tagbody (test-if-not-in-cl-package "tagbody") nil) +(deftest symbol-tailp (test-if-not-in-cl-package "tailp") nil) +(deftest symbol-tan (test-if-not-in-cl-package "tan") nil) +(deftest symbol-tanh (test-if-not-in-cl-package "tanh") nil) +(deftest symbol-tenth (test-if-not-in-cl-package "tenth") nil) +(deftest symbol-terpri (test-if-not-in-cl-package "terpri") nil) +(deftest symbol-the (test-if-not-in-cl-package "the") nil) +(deftest symbol-third (test-if-not-in-cl-package "third") nil) +(deftest symbol-throw (test-if-not-in-cl-package "throw") nil) +(deftest symbol-time (test-if-not-in-cl-package "time") nil) +(deftest symbol-trace (test-if-not-in-cl-package "trace") nil) +(deftest symbol-translate-logical-pathname (test-if-not-in-cl-package "translate-logical-pathname") nil) +(deftest symbol-translate-pathname (test-if-not-in-cl-package "translate-pathname") nil) +(deftest symbol-tree-equal (test-if-not-in-cl-package "tree-equal") nil) +(deftest symbol-truename (test-if-not-in-cl-package "truename") nil) +(deftest symbol-truncate (test-if-not-in-cl-package "truncate") nil) +(deftest symbol-two-way-stream (test-if-not-in-cl-package "two-way-stream") nil) +(deftest symbol-two-way-stream-input-stream (test-if-not-in-cl-package "two-way-stream-input-stream") nil) +(deftest symbol-two-way-stream-output-stream (test-if-not-in-cl-package "two-way-stream-output-stream") nil) +(deftest symbol-type (test-if-not-in-cl-package "type") nil) +(deftest symbol-type-error (test-if-not-in-cl-package "type-error") nil) +(deftest symbol-type-error-datum (test-if-not-in-cl-package "type-error-datum") nil) +(deftest symbol-type-error-expected-type (test-if-not-in-cl-package "type-error-expected-type") nil) +(deftest symbol-type-of (test-if-not-in-cl-package "type-of") nil) +(deftest symbol-typecase (test-if-not-in-cl-package "typecase") nil) +(deftest symbol-typep (test-if-not-in-cl-package "typep") nil) +(deftest symbol-unbound-slot (test-if-not-in-cl-package "unbound-slot") nil) +(deftest symbol-unbound-slot-instance (test-if-not-in-cl-package "unbound-slot-instance") nil) +(deftest symbol-unbound-variable (test-if-not-in-cl-package "unbound-variable") nil) +(deftest symbol-undefined-function (test-if-not-in-cl-package "undefined-function") nil) +(deftest symbol-unexport (test-if-not-in-cl-package "unexport") nil) +(deftest symbol-unintern (test-if-not-in-cl-package "unintern") nil) +(deftest symbol-union (test-if-not-in-cl-package "union") nil) +(deftest symbol-unless (test-if-not-in-cl-package "unless") nil) +(deftest symbol-unread-char (test-if-not-in-cl-package "unread-char") nil) +(deftest symbol-unsigned-byte (test-if-not-in-cl-package "unsigned-byte") nil) +(deftest symbol-untrace (test-if-not-in-cl-package "untrace") nil) +(deftest symbol-unuse-package (test-if-not-in-cl-package "unuse-package") nil) +(deftest symbol-unwind-protect (test-if-not-in-cl-package "unwind-protect") nil) +(deftest symbol-update-instance-for-different-class (test-if-not-in-cl-package "update-instance-for-different-class") nil) +(deftest symbol-update-instance-for-redefined-class (test-if-not-in-cl-package "update-instance-for-redefined-class") nil) +(deftest symbol-upgraded-array-element-type (test-if-not-in-cl-package "upgraded-array-element-type") nil) +(deftest symbol-upgraded-complex-part-type (test-if-not-in-cl-package "upgraded-complex-part-type") nil) +(deftest symbol-upper-case-p (test-if-not-in-cl-package "upper-case-p") nil) +(deftest symbol-use-package (test-if-not-in-cl-package "use-package") nil) +(deftest symbol-use-value (test-if-not-in-cl-package "use-value") nil) +(deftest symbol-user-homedir-pathname (test-if-not-in-cl-package "user-homedir-pathname") nil) +(deftest symbol-values (test-if-not-in-cl-package "values") nil) +(deftest symbol-values-list (test-if-not-in-cl-package "values-list") nil) +(deftest symbol-variable (test-if-not-in-cl-package "variable") nil) +(deftest symbol-vector (test-if-not-in-cl-package "vector") nil) +(deftest symbol-vector-pop (test-if-not-in-cl-package "vector-pop") nil) +(deftest symbol-vector-push (test-if-not-in-cl-package "vector-push") nil) +(deftest symbol-vector-push-extend (test-if-not-in-cl-package "vector-push-extend") nil) +(deftest symbol-vectorp (test-if-not-in-cl-package "vectorp") nil) +(deftest symbol-warn (test-if-not-in-cl-package "warn") nil) +(deftest symbol-warning (test-if-not-in-cl-package "warning") nil) +(deftest symbol-when (test-if-not-in-cl-package "when") nil) +(deftest symbol-wild-pathname-p (test-if-not-in-cl-package "wild-pathname-p") nil) +(deftest symbol-with-accessors (test-if-not-in-cl-package "with-accessors") nil) +(deftest symbol-with-compilation-unit (test-if-not-in-cl-package "with-compilation-unit") nil) +(deftest symbol-with-condition-restarts (test-if-not-in-cl-package "with-condition-restarts") nil) +(deftest symbol-with-hash-table-iterator (test-if-not-in-cl-package "with-hash-table-iterator") nil) +(deftest symbol-with-input-from-string (test-if-not-in-cl-package "with-input-from-string") nil) +(deftest symbol-with-open-file (test-if-not-in-cl-package "with-open-file") nil) +(deftest symbol-with-open-stream (test-if-not-in-cl-package "with-open-stream") nil) +(deftest symbol-with-output-to-string (test-if-not-in-cl-package "with-output-to-string") nil) +(deftest symbol-with-package-iterator (test-if-not-in-cl-package "with-package-iterator") nil) +(deftest symbol-with-simple-restart (test-if-not-in-cl-package "with-simple-restart") nil) +(deftest symbol-with-slots (test-if-not-in-cl-package "with-slots") nil) +(deftest symbol-with-standard-io-syntax (test-if-not-in-cl-package "with-standard-io-syntax") nil) +(deftest symbol-write (test-if-not-in-cl-package "write") nil) +(deftest symbol-write-byte (test-if-not-in-cl-package "write-byte") nil) +(deftest symbol-write-char (test-if-not-in-cl-package "write-char") nil) +(deftest symbol-write-line (test-if-not-in-cl-package "write-line") nil) +(deftest symbol-write-sequence (test-if-not-in-cl-package "write-sequence") nil) +(deftest symbol-write-string (test-if-not-in-cl-package "write-string") nil) +(deftest symbol-write-to-string (test-if-not-in-cl-package "write-to-string") nil) +(deftest symbol-y-or-n-p (test-if-not-in-cl-package "y-or-n-p") nil) +(deftest symbol-yes-or-no-p (test-if-not-in-cl-package "yes-or-no-p") nil) +(deftest symbol-zerop (test-if-not-in-cl-package "zerop") nil) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Test that all keywords have themselves as their value, +;;; are external if present in KEYWORD, and have themselves +;;; as their values (and are constant). Symbols that are +;;; merely used in KEYWORD but not present there are exempt. + +(deftest keyword-behavior + (let ((result nil) + (keyword-package (find-package "KEYWORD"))) + (do-symbols (s keyword-package result) + (multiple-value-bind (sym status) + (find-symbol (symbol-name s) keyword-package) + (cond + ((not (eqt s sym)) (push (list s sym) result)) + ((eqt status :internal) + (push (list s status) result)) + ((eqt status :external) + (unless (and (eqt (symbol-value s) s) + (constantp s)) + (push (list s sym 'not-constant) result))))))) + nil) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; special-operator-p + + +;;; See section 3.1.2.1.2.1 +(defparameter +special-operators+ + '(block let* return-from catch load-time-value setq eval-when + locally symbol-macrolet flet macrolet tagbody function + multiple-value-call the go multiple-value-prog1 throw if + progn unwind-protect labels progv let quote)) + + +;;; All the symbols in +special-operators+ are special operators +(deftest special-operator-p.1 + (loop for s in +special-operators+ + unless (special-operator-p s) + collect s) + nil) + +;;; None of the standard symbols except those in +special-operators+ +;;; are special operators, unless they have a macro function +;;; (See the page for MACRO-FUNCTION) + +(deftest special-operator-p.2 + (let ((p (find-package "CL"))) + (loop for name in *cl-symbol-names* + unless (or (member name +special-operators+ :test #'string=) + (let ((sym (find-symbol name p))) + (or (not (special-operator-p sym)) + (macro-function sym)))) + collect name)) + nil) + +(deftest special-operator-p.order.1 + (let ((i 0)) + (values (notnot (special-operator-p (progn (incf i) 'catch))) + i)) + t 1) + +(deftest special-operator-p.error.1 + (classify-error (special-operator-p 1)) + type-error) + +(deftest special-operator-p.error.2 + (classify-error (special-operator-p)) + program-error) + +(deftest special-operator-p.error.3 + (classify-error (special-operator-p 'cons 'cons)) + program-error) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; keywordp + +(deftest keywordp.1 (keywordp 'hefalump) nil) +(deftest keywordp.2 (keywordp 17) nil) +(deftest keywordp.3 (notnot-mv (keywordp :stream)) t) +(deftest keywordp.4 (notnot-mv (keywordp ':stream)) t) +(deftest keywordp.5 (keywordp nil) nil) +(deftest keywordp.6 (notnot-mv (keywordp :nil)) t) +(deftest keywordp.7 (keywordp '(:stream)) nil) +(deftest keywordp.8 (keywordp "rest") nil) +(deftest keywordp.9 (keywordp ":rest") nil) +(deftest keywordp.10 (keywordp '&body) nil) +;;; This next test was busted. ::foo is not portable syntax +;;(deftest keywordp.11 (notnot-mv (keywordp ::foo)) t) +(deftest keywordp.12 (keywordp t) nil) + +(deftest keywordp.order.1 + (let ((i 0)) + (values (keywordp (progn (incf i) nil)) i)) + nil 1) + +(deftest keywordp.error.1 (classify-error (keywordp)) program-error) +(deftest keywordp.error.2 (classify-error (keywordp :x :x)) program-error) + +(deftest keywordp.error.3 + (classify-error (keywordp)) + program-error) + +(deftest keywordp.error.4 + (classify-error (keywordp nil nil)) + program-error) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; symbol-name + +(deftest symbol-name.1 + (symbol-name '|ABCD|) + "ABCD") + +(deftest symbol-name.2 + (symbol-name '|1234abcdABCD|) + "1234abcdABCD") + +(deftest symbol-name.3 + (classify-error (symbol-name 1)) + type-error) + +(deftest symbol-name.4 + (classify-error (symbol-name '(a))) + type-error) + +(deftest symbol-name.5 + (classify-error (symbol-name "ABCDE")) + type-error) + +(deftest symbol-name.6 + (classify-error (symbol-name 12913.0213)) + type-error) + +(deftest symbol-name.7 + (symbol-name :|abcdefg|) + "abcdefg") + +(deftest symbol-name.error.1 + (classify-error (symbol-name)) + program-error) + +(deftest symbol-name.error.2 + (classify-error (symbol-name 'a 'b)) + program-error) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; make-symbol + +(deftest make-symbol.1 + (notnot-mv (symbolp (make-symbol "FOO"))) + t) + +(deftest make-symbol.2 + (symbol-package (make-symbol "BAR")) + nil) + +(deftest make-symbol.3 + (symbol-package (make-symbol "CL::FOO")) + nil) + +(deftest make-symbol.4 + (symbol-package (make-symbol "CL:FOO")) + nil) + +(deftest make-symbol.5 + (symbol-name (make-symbol "xyz")) + "xyz") + +(deftest make-symbol.6 + (eqt (make-symbol "A") + (make-symbol "A")) + nil) + +(deftest make-symbol.7 + (boundp (make-symbol "B")) + nil) + +(deftest make-symbol.8 + (symbol-plist (make-symbol "C")) + nil) + +(deftest make-symbol.9 + (fboundp (make-symbol "D")) + nil) + +(deftest make-symbol.10 + (symbol-name (make-symbol "")) + "") + +(deftest make-symbol.order.1 + (let ((i 0)) + (values + (symbol-name (make-symbol (progn (incf i) "ABC"))) + i)) + "ABC" 1) + +(deftest make-symbol.error.1 + (classify-error (make-symbol nil)) + type-error) + +(deftest make-symbol.error.2 + (classify-error (make-symbol 'a)) + type-error) + +(deftest make-symbol.error.3 + (classify-error (make-symbol 1)) + type-error) + +(deftest make-symbol.error.4 + (classify-error (make-symbol -1)) + type-error) + +(deftest make-symbol.error.5 + (classify-error (make-symbol 1.213)) + type-error) + +(deftest make-symbol.error.6 + (classify-error (make-symbol -1312.2)) + type-error) + +(deftest make-symbol.error.7 + (classify-error (make-symbol #\w)) + type-error) + +(deftest make-symbol.error.8 + (classify-error (make-symbol '(a))) + type-error) + +(deftest make-symbol.error.9 + (classify-error (make-symbol)) + program-error) + +(deftest make-symbol.error.10 + (classify-error (make-symbol "a" "a")) + program-error) + +(deftest make-symbol.error.11 + (classify-error (make-symbol '(#\a #\b #\c))) + type-error) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; copy-symbol + +(deftest copy-symbol.1 + (notnot-mv + (every + #'(lambda (x) + (let ((y (copy-symbol x))) + (and (null (symbol-plist y)) + (symbolp y) + (not (boundp y)) + (not (fboundp y)) + (null (symbol-package y)) + (string= (symbol-name x) (symbol-name y)) + (symbolp (copy-symbol y)) + ))) + '(nil t a b |a| |123|))) + t) + +(deftest copy-symbol.2 + (progn + (setf (symbol-plist '|foo|) '(a b c d)) + (makunbound '|foo|) + (notnot-mv + (every + #'(lambda (x) + (let ((y (copy-symbol x t))) + (and + (equal (symbol-plist y) (symbol-plist x)) + (symbolp y) + (if (boundp x) + (boundp y) + (not (boundp y))) + (if (fboundp x) (fboundp y) (not (fboundp y))) + (null (symbol-package y)) + (string= (symbol-name x) (symbol-name y)) + ))) + '(nil t a b |foo| |a| |123|)))) + t) + +(deftest copy-symbol.3 + (progn + (setf (symbol-plist '|foo|) '(a b c d)) + (setf (symbol-value '|a|) 12345) + (notnot-mv + (every + #'(lambda (x) + (let ((y (copy-symbol x t))) + (and + (eql (length (symbol-plist y)) + (length (symbol-plist x))) + ;; Is a list copy + (every #'eq (symbol-plist y) (symbol-plist x)) + (symbolp y) + (if (boundp x) + (eqt (symbol-value x) + (symbol-value y)) + (not (boundp y))) + (if (fboundp x) (fboundp y) (not (fboundp y))) + (null (symbol-package y)) + (string= (symbol-name x) (symbol-name y)) + (eql (length (symbol-plist x)) + (length (symbol-plist y))) + ))) + '(nil t a b |foo| |a| |123|)))) + t) + +(deftest copy-symbol.4 + (eqt (copy-symbol 'a) (copy-symbol 'a)) + nil) + +(deftest copy-symbol.5 + (let ((i 0) x y (s '#:|x|)) + (let ((s2 (copy-symbol + (progn (setf x (incf i)) s) + (progn (setf y (incf i)) nil)))) + (values + (symbol-name s2) + (eq s s2) + i x y))) + "x" nil 2 1 2) + +(deftest copy-symbol.error.1 + (classify-error (copy-symbol)) + program-error) + +(deftest copy-symbol.error.2 + (classify-error (copy-symbol 'a t 'foo)) + program-error) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; gensym + +;;; Gensym returns unique symbols +(deftest gensym.1 + (equal (gensym) (gensym)) + nil) + +;;; Gensym returns symbols with distinct print names +(deftest gensym.2 + (string= (symbol-name (gensym)) + (symbol-name (gensym))) + nil) + +;;; Gensym uses the *gensym-counter* special variable, +;;; but does not increment it until after the symbol +;;; has been created. +(deftest gensym.3 + (let ((*gensym-counter* 1)) + (declare (special *gensym-counter*)) + (symbol-name (gensym))) + #.(string '#:g1)) + +;;; Gensym uses the string argument instead of the default +(deftest gensym.4 + (let ((*gensym-counter* 1327)) + (declare (special *gensym-counter*)) + (symbol-name (gensym "FOO"))) + "FOO1327") + +;;; The symbol returned by gensym should be unbound +(deftest gensym.5 + (boundp (gensym)) + nil) + +;;; The symbol returned by gensym should have no function binding +(deftest gensym.6 + (fboundp (gensym)) + nil) + +;;; The symbol returned by gensym should have no property list +(deftest gensym.7 + (symbol-plist (gensym)) + nil) + +;;; The symbol returned by gensym should be uninterned +(deftest gensym.8 + (symbol-package (gensym)) + nil) + +;;; *gensym-counter* is incremented by gensym +(deftest gensym.9 + (let ((*gensym-counter* 12345)) + (declare (special *gensym-counter*)) + (gensym) + *gensym-counter*) + 12346) + +;;; Gensym works when *gensym-counter* is Really Big +;;; (and does not increment the counter until after creating +;;; the symbol.) +(deftest gensym.10 + (let ((*gensym-counter* 1234567890123456789012345678901234567890)) + (declare (special *gensym-counter*)) + (symbol-name (gensym))) + #.(string '#:g1234567890123456789012345678901234567890)) + +;;; gensym increments Really Big values of *gensym-counter* +(deftest gensym.11 + (let ((*gensym-counter* 12345678901234567890123456789012345678901234567890)) + (declare (special *gensym-counter*)) + (gensym) + *gensym-counter*) + 12345678901234567890123456789012345678901234567891) + +;;; Gensym uses an integer argument instead of the counter +(deftest gensym.12 + (let ((*gensym-counter* 10)) + (declare (special *gensym-counter*)) + (symbol-name (gensym 123))) + #.(string '#:g123)) + +;;; When given an integer argument, gensym does not increment the +;;; *gensym-counter* +(deftest gensym.13 + (let ((*gensym-counter* 10)) + (declare (special *gensym-counter*)) + (gensym 123) + *gensym-counter*) + 10) + +;;; Check response to erroneous arguments +;;; Note! NIL is not the same as no argument +;;; gensym should be implemented so that its only +;;; argument defaults to "G", with NIL causing an error. + +(deftest gensym.error.1 + (classify-error (gensym 'aaa)) + type-error) + +(deftest gensym.error.2 + (classify-error (gensym 12.3)) + type-error) + +(deftest gensym.error.3 + (classify-error (gensym t)) + type-error) + +(deftest gensym.error.4 + (classify-error (gensym nil)) + type-error) ;; NIL /= no argument! + +(deftest gensym.error.5 + (classify-error (gensym '(a))) + type-error) + +(deftest gensym.error.6 + (classify-error (gensym #\x)) + type-error) + +(deftest gensym.error.7 + (classify-error (gensym 10 'foo)) + program-error) + +(deftest gensym.error.8 + (classify-error (locally (gensym t) t)) + type-error) + + +;;;;;;;;;;;;;;;;;;;; + +;;; Tests of CL package constraints from section 11.1.2.1.1 + +;;; Check that all symbols listed as 'functions' or 'accessors' +;;; are indeed functions. + +(deftest cl-function-symbols.1 + (loop + for s in (append *cl-function-symbols* *cl-accessor-symbols*) + when (or (not (fboundp s)) + (macro-function s) + (special-operator-p s) + (not (symbol-function s))) + collect s) + nil) + +;;; Check that all symols listed as 'macros' are macros. + +(deftest cl-macro-symbols.1 + (loop + for s in *cl-macro-symbols* + when (or (not (fboundp s)) + (not (macro-function s))) + collect s) + nil) + +;;; Check that all constants are indeed constant + +(deftest cl-constant-symbols.1 + (loop + for s in *cl-constant-symbols* + when (or (not (boundp s)) + (not (constantp s))) + collect s) + nil) + +;;; Check that all global variables have values + +(deftest cl-variable-symbols.1 + (loop + for s in *cl-variable-symbols* + when (not (boundp s)) + collect s) + nil) + +;;; Check that all types that are classes name classes. + +;;; "Many but not all of the predefined type specifiers have +;;; a corresponding class with the same proper name as the type. +;;; These type specifiers are listed in Figure 4-8." -- section 4.3.7 + +(deftest cl-types-that-are-classes.1 + ;; Collect class names that violate the condition in the + ;; above quotation. + (loop + for s in *cl-types-that-are-classes-symbols* + for c = (find-class s nil) + unless (and c + (eq (class-name c) s) + (typep c 'class)) + collect s) + nil) + + +(deftest cl-types-that-are-classes.2 + ;; The same as cl-types-that-are-classes.1 + ;; with an environment argument + (loop + for s in *cl-types-that-are-classes-symbols* + for c = (find-class s nil nil) + unless (and c + (eq (class-name c) s) + (typep c 'class)) + collect s) + nil) + +(deftest cl-types-that-are-classes.3 + ;; The same as cl-types-that-are-classes.1, + ;; with an environment argument + (loop + for s in *cl-types-that-are-classes-symbols* + for c = (eval `(macrolet ((%foo (&environment env) + (list 'quote + (find-class ',s nil env)))) + (%foo))) + unless (and c + (eq (class-name c) s) + (typep c 'class)) + collect s) + nil) + +;;; Various error cases for symbol-related functions + +(deftest symbolp.error.1 + (classify-error (symbolp)) + program-error) + +(deftest symbolp.error.2 + (classify-error (symbolp nil nil)) + program-error) + +(deftest symbol-function.error.1 + (classify-error (symbol-function)) + program-error) + +(deftest symbol-function.error.2 + (classify-error (symbol-function 'cons nil)) + program-error) + +(deftest symbol-package.error.1 + (classify-error (symbol-package)) + program-error) + +(deftest symbol-package.error.2 + (classify-error (symbol-package 'cons nil)) + program-error) + +(deftest symbol-plist.error.1 + (classify-error (symbol-plist)) + program-error) + +(deftest symbol-plist.error.2 + (classify-error (symbol-plist 'cons nil)) + program-error) + +(deftest symbol-value.error.1 + (classify-error (symbol-value)) + program-error) + +(deftest symbol-value.error.2 + (classify-error (symbol-value '*package* nil)) + program-error) + diff --git a/ansi-tests/cl-test-package.lsp b/ansi-tests/cl-test-package.lsp new file mode 100644 index 0000000..5a77e47 --- /dev/null +++ b/ansi-tests/cl-test-package.lsp @@ -0,0 +1,15 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 14 10:13:21 1998 +;;;; Contains: CL test case package definition + +(defpackage :cl-test + (:use :cl :regression-test) + ;; #+gcl (:use defpackage) + (:nicknames) + (:import-from "COMMON-LISP-USER" #:compile-and-load "==>") + (:export)) + +#+cmu (import 'cl::quit :cl-test) + + diff --git a/ansi-tests/cltest.system b/ansi-tests/cltest.system new file mode 100644 index 0000000..f62d5df --- /dev/null +++ b/ansi-tests/cltest.system @@ -0,0 +1,123 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Mar 27 09:57:28 1998 +;;;; Contains: MK portable system file for CL test suite + +;;; NOTE!! This file is not being maintained right now. +;;; To run the test suite, load "gclload.lsp" + +(mk::defsystem "cltest" + :source-pathname #.(directory-namestring *LOAD-TRUENAME*) + :source-extension "lsp" + :binary-pathname #.(mk::append-directories + (directory-namestring *LOAD-TRUENAME*) + "binary/") + :binary-extension + #+CMU #.(C::BACKEND-FASL-FILE-TYPE C::*TARGET-BACKEND*) + #+ALLEGRO "fasl" + #+(OR AKCL GCL) "o" + #+CLISP "fas" + #-(OR CMU ALLEGRO AKCL GCL CLISP) + #.(pathname-type (compile-file-pathname "foo.lisp")) + :initially-do (progn (load "rt/rt.system") + (mk::compile-system "rt")) + :components + ("cl-test-package" + (:subsystem "cl-test-code" + :source-pathname "" + :binary-pathname "" + :depends-on ("cl-test-package") + :components + ( + "ansi-aux" + "universe" + "cons-test-01" + "cons-test-02" + "cons-test-03" + "cons-test-04" + "cons-test-05" + "cons-test-06" + "cons-test-07" + "cons-test-08" + "cons-test-09" + "cons-test-10" + "cons-test-11" + "cons-test-12" + "cons-test-13" + "cons-test-14" + "cons-test-15" + "cons-test-16" + "cons-test-17" + "cons-test-18" + "cons-test-19" + "cons-test-20" + "cons-test-21" + "cons-test-22" + "cons-test-23" + "cons-test-24" + "types-and-class" + "cl-symbols" + "cases-14-1-arrays" + "cases-14-1-list" + "reader-test" + + "packages-00" + "packages-01" + "packages-02" + "packages-03" + "packages-04" + "packages-05" + "packages-06" + "packages-07" + "packages-08" + "packages-09" + "packages-10" + "packages-11" + "packages-12" + "packages-13" + "packages-14" + "packages-15" + "packages-16" + "packages-17" + "packages-18" + + "fill-strings" + "make-sequence" + "map" + "map-into" + "reduce" + "count" + "count-if" + "count-if-not" + "reverse" + "nreverse" + "sort" + "find" + "find-if" + "find-if-not" + "position" + "search-aux" + "search-list" + "search-vector" + "search-bitvector" + "search-string" + "mismatch" + "replace" + "substitute" + "substitute-if" + "substitute-if-not" + "nsubstitute" + "nsubstitute-if" + "nsubstitute-if-not" + "concatenate" + "merge" + "remove" ;; need to extend these tests + + "structure-00" + "structures-01" + "structures-02" + + )))) + + + diff --git a/ansi-tests/coerce.lsp b/ansi-tests/coerce.lsp new file mode 100644 index 0000000..a2dec72 --- /dev/null +++ b/ansi-tests/coerce.lsp @@ -0,0 +1,178 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Dec 13 20:48:04 2002 +;;;; Contains: Tests for COERCE + +(in-package :cl-test) + +(deftest coerce.1 + (loop for x in *universe* + for type = (type-of x) + unless (and (consp type) (eqt (car type) 'function)) + count (not (eq (coerce x type) x))) + 0) + +(deftest coerce.2 + (loop for x in *universe* + count (not (eq (coerce x t) x))) + 0) + +(deftest coerce.3 + (loop for x in *universe* + for class = (class-of x) + count (and class (not (eq (coerce x class) x)))) + 0) + +(deftest coerce.4 + (loop for x in '(() #() #*) + never (coerce x 'list)) + t) + +(deftest coerce.5 + (loop for x in '((1 0) #(1 0) #*10) + always (equal (coerce x 'list) '(1 0))) + t) + +(deftest coerce.6 + (loop for x in '(() #() #*) + always (equalp (coerce x 'vector) #())) + t) + +(deftest coerce.7 + (loop for x in '((1 0) #(1 0) #*10) + for y = (coerce x 'vector) + always (and (equalp y #(1 0)) + (vectorp y))) + t) + +(deftest coerce.8 + (loop for x in '((1 0) #(1 0) #*10) + for y = (coerce x '(vector *)) + always (and (equalp y #(1 0)) + (vectorp y))) + t) + +(deftest coerce.9 + (loop for x in '((1 0) #(1 0) #*10) + for y = (coerce x '(vector * 2)) + always (and (equalp y #(1 0)) + (vectorp y))) + t) + +(deftest coerce.10 + (values (coerce #\A 'character) + (coerce '|A| 'character) + (coerce "A" 'character)) + #\A #\A #\A) + +(deftest coerce.11 + (loop with class = (find-class 'vector) + for x in '((1 0) #(1 0) #*10) + for y = (coerce x class) + always (and (equalp y #(1 0)) + (vectorp y))) + t) + +(deftest coerce.12 + (loop for x in '((1 0) #(1 0) #*10) + for y = (coerce x 'bit-vector) + always (and (equalp y #*10) + (bit-vector-p y))) + t) + +(deftest coerce.13 + (loop for x in '((#\a #\b #\c) "abc") + for y = (coerce x 'string) + always (and (stringp y) + (string= y "abc"))) + t) + +(deftest coerce.14 + (loop for x in '((#\a #\b #\c) "abc") + for y = (coerce x 'simple-string) + always (and (typep y 'simple-string) + (string= y "abc"))) + t) + +(deftest coerce.15 + (loop for x in '((1 0) #(1 0) #*10) + for y = (coerce x 'simple-vector) + always (and (equalp y #(1 0)) + (simple-vector-p y))) + t) + +(deftest coerce.16 + (coerce 0 'integer) + 0) + +(deftest coerce.17 + (coerce 0 'complex) + 0) + +(deftest coerce.18 + (coerce 3 'complex) + 3) + +(deftest coerce.19 + (coerce 5/3 'complex) + 5/3) + +(deftest coerce.20 + (coerce 1.0 'complex) + #c(1.0 0.0)) + +(deftest coerce.21 + (eqt (symbol-function 'car) + (coerce 'car 'function)) + t) + +(deftest coerce.22 + (funcall (coerce '(lambda () 10) 'function)) + 10) + +(deftest coerce.order.1 + (let ((i 0) a b) + (values + (coerce (progn (setf a (incf i)) 10) + (progn (setf b (incf i)) 'single-float)) + i a b)) + 10.0f0 2 1 2) + +;;; Error tests + +;;; (deftest coerce.error.1 +;;; (classify-error (coerce -1 '(integer 0 100))) +;;; type-error) + +(deftest coerce.error.2 + (classify-error (coerce '(a b c) '(vector * 2))) + type-error) + +(deftest coerce.error.3 + (classify-error (coerce '(a b c) '(vector * 4))) + type-error) + +(deftest coerce.error.4 + (classify-error (coerce nil 'cons)) + type-error) + +(deftest coerce.error.5 + (handler-case (eval '(coerce 'not-a-bound-function 'function)) + (error () :caught)) + :caught) + +(deftest coerce.error.6 + (classify-error (coerce)) + program-error) + +(deftest coerce.error.7 + (classify-error (coerce t)) + program-error) + +(deftest coerce.error.8 + (classify-error (coerce 'x t 'foo)) + program-error) + +(deftest coerce.error.9 + (classify-error (locally (coerce nil 'cons) t)) + type-error) diff --git a/ansi-tests/compile-and-load.lsp b/ansi-tests/compile-and-load.lsp new file mode 100644 index 0000000..939fe5f --- /dev/null +++ b/ansi-tests/compile-and-load.lsp @@ -0,0 +1,26 @@ +(in-package :common-lisp-user) + +#+allegro +(progn + (setq *ignore-package-name-case* t) + (when (eq excl:*current-case-mode* :case-sensitive-lower) + (push :lower-case *features*))) + +(eval-when (load eval compile) + (intern "==>" "CL-USER") + (unless (fboundp 'compile-file-pathname) + (defun compile-file-pathname (pathname) + (make-pathname :defaults pathname :type "o")))) + +(defun compile-and-load (pathspec) + "Find the file indicated by PATHSPEC, compiling it first if + the associated compiled file is out of date." + (let* ((pathname (pathname pathspec)) + (compile-pathname (compile-file-pathname pathname)) + (source-write-time (file-write-date pathname)) + (target-write-time (and (probe-file compile-pathname) + (file-write-date compile-pathname)))) + (when (or (not target-write-time) + (<= target-write-time source-write-time)) + (compile-file pathname)) + (load compile-pathname))) diff --git a/ansi-tests/compile.lsp b/ansi-tests/compile.lsp new file mode 100644 index 0000000..f3d61f5 --- /dev/null +++ b/ansi-tests/compile.lsp @@ -0,0 +1,91 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Thu Oct 10 20:54:20 2002 +;;;; Contains: Tests for COMPILE, COMPILED-FUNCTION-P, COMPILED-FUNCTION + +(in-package :cl-test) + +(deftest compile.1 + (progn + (fmakunbound 'compile.1-fn) + (values + (defun compile.1-fn (x) x) + (compiled-function-p 'compile.1-fn) + (let ((x (compile 'compile.1-fn))) + (or (eqt x 'compile.1-fn) + (notnot (compiled-function-p x)))) + (compiled-function-p 'compile.1-fn) + (not (compiled-function-p #'compile.1-fn)) + (fmakunbound 'compile.1-fn))) + compile.1-fn + nil + t + nil + nil + compile.1-fn) + + +;;; COMPILE returns three values (function, warnings-p, failure-p) +(deftest compile.2 + (let* ((results (multiple-value-list + (compile nil '(lambda (x y) (cons y x))))) + (fn (car results))) + (values (length results) + (funcall fn 'a 'b) + (second results) + (third results))) + 3 + (b . a) + nil + nil) + +;;; Compile does not coalesce literal constants +(deftest compile.3 + (let ((x (list 'a 'b)) + (y (list 'a 'b))) + (and (not (eqt x y)) + (funcall (compile nil `(lambda () (eqt ',x ',y)))))) + nil) + +(deftest compile.4 + (let ((x (copy-seq "abc")) + (y (copy-seq "abc"))) + (and (not (eqt x y)) + (funcall (compile nil `(lambda () (eqt ,x ,y)))))) + nil) + +(deftest compile.5 + (let ((x (copy-seq "abc"))) + (funcall (compile nil `(lambda () (eqt ,x ,x))))) + t) + +(deftest compile.6 + (let ((x (copy-seq "abc"))) + (funcall (compile nil `(lambda () (eqt ',x ',x))))) + t) + +(deftest compile.7 + (let ((x (copy-seq "abc"))) + (eqt x (funcall (compile nil `(lambda () ,x))))) + t) + +(deftest compile.8 + (let ((x (list 'a 'b))) + (eqt x (funcall (compile nil `(lambda () ',x))))) + t) + +(deftest compile.9 + (let ((i 0) a b) + (values + (funcall (compile (progn (setf a (incf i)) nil) + (progn (setf b (incf i)) '(lambda () 'z)))) + i a b)) + z 2 1 2) + +(deftest compile.error.1 + (classify-error (compile)) + program-error) + +(deftest compile.error.2 + (classify-error (compile nil '(lambda () nil) 'garbage)) + program-error) diff --git a/ansi-tests/compiled-function-p.lsp b/ansi-tests/compiled-function-p.lsp new file mode 100644 index 0000000..f430182 --- /dev/null +++ b/ansi-tests/compiled-function-p.lsp @@ -0,0 +1,39 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Mon Jan 13 16:32:44 2003 +;;;; Contains: Tests of COMPILED-FUNCTION-P + +(in-package :cl-test) + +(deftest compiled-function-p.1 + (some #'(lambda (obj) + (if (check-values (compiled-function-p obj)) + (not (typep obj 'compiled-function)) + (typep obj 'compiled-function))) + *universe*) + nil) + +(deftest compiled-function-p.2 + (compiled-function-p '(lambda (x y) (cons y x))) + nil) + +(deftest compiled-function-p.3 + (notnot-mv (compiled-function-p (compile nil '(lambda (y x) (cons x y))))) + t) + +(deftest compiled-function-p.order.1 + (let ((i 0)) + (values + (compiled-function-p (progn (incf i) '(lambda () nil))) + i)) + nil 1) + +(deftest compiled-function-p.error.1 + (classify-error (compiled-function-p)) + program-error) + +(deftest compiled-function-p.error.2 + (classify-error (compiled-function-p nil nil)) + program-error) + + diff --git a/ansi-tests/compiler-macros.lsp b/ansi-tests/compiler-macros.lsp new file mode 100644 index 0000000..116b2aa --- /dev/null +++ b/ansi-tests/compiler-macros.lsp @@ -0,0 +1,8 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Mon Jan 13 18:51:30 2003 +;;;; Contains: Tests for compiler macros + +(in-package :cl-test) + +;;; Compiler macro tests will go here diff --git a/ansi-tests/complement.lsp b/ansi-tests/complement.lsp new file mode 100644 index 0000000..0fee0a8 --- /dev/null +++ b/ansi-tests/complement.lsp @@ -0,0 +1,57 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Oct 6 20:04:33 2002 +;;;; Contains: Tests for COMPLEMENT + +(in-package :cl-test) + +(deftest complement.1 + (notnot-mv (funcall (complement #'identity) nil)) + t) + +(deftest complement.2 + (funcall (complement #'identity) t) + nil) + +(deftest complement.3 + (every #'(lambda (x) (eql (funcall (cl::complement #'not) x) + (not (not x)))) + *universe*) + t) + +(deftest complement.4 + (let ((x '(#\b))) + (loop for i from 2 to (min 256 (1- call-arguments-limit)) + always (progn + (push #\a x) + (apply (complement #'char=) x)))) + t) + +(deftest complement.5 + (notnot-mv (complement #'identity)) + t) + +(deftest complement.order.1 + (let ((i 0)) + (let ((fn (complement (progn (incf i) #'null)))) + (values + i + (mapcar fn '(a b nil c 1 nil t nil)) + i))) + 1 (t t nil t t nil t nil) 1) + +(deftest complement.error.1 + (classify-error (complement)) + program-error) + +(deftest complement.error.2 + (classify-error (complement #'not t)) + program-error) + +(deftest complement.error.3 + (classify-error (funcall (complement #'identity))) + program-error) + +(deftest complement.error.4 + (classify-error (funcall (complement #'identity) t t)) + program-error) diff --git a/ansi-tests/concatenate.lsp b/ansi-tests/concatenate.lsp new file mode 100644 index 0000000..6fdb214 --- /dev/null +++ b/ansi-tests/concatenate.lsp @@ -0,0 +1,227 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Sep 4 22:53:51 2002 +;;;; Contains: Tests for CONCATENATE + +(in-package :cl-test) + +(deftest concatenate.1 + (concatenate 'list) + nil) + +(deftest concatenate.2 + (let* ((orig (list 'a 'b 'c 'd 'e)) + (copy (concatenate 'list orig))) + (values + copy + (intersection (loop for e on orig collect e) + (loop for e on copy collect e) + :test #'eq))) + (a b c d e) + nil) + +(deftest concatenate.3 + (concatenate 'list "") + nil) + +(deftest concatenate.4 + (concatenate 'list "abcd" '(x y z) nil #*1101 #()) + (#\a #\b #\c #\d x y z 1 1 0 1)) + +(deftest concatenate.5 + (concatenate 'vector) + #()) + +(deftest concatenate.6 + (concatenate 'vector nil "abcd" '(x y z) nil #*1101 #()) + #(#\a #\b #\c #\d x y z 1 1 0 1)) + +(deftest concatenate.7 + (let* ((orig (vector 'a 'b 'c 'd 'e)) + (copy (concatenate 'vector orig))) + (values + copy + (eqt copy orig))) + #(a b c d e) + nil) + +(deftest concatenate.8 + (concatenate 'simple-vector '(a b c) #(1 2 3)) + #(a b c 1 2 3)) + +(deftest concatenate.9 + (concatenate 'simple-vector) + #()) + +(deftest concatenate.10 + (concatenate 'bit-vector nil) + #*) + +(deftest concatenate.11 + (concatenate 'bit-vector) + #*) + +(deftest concatenate.12 + (concatenate 'bit-vector '(0 1 1) nil #(1 0 1) #()) + #*011101) + +(deftest concatenate.13 + (concatenate 'simple-bit-vector nil) + #*) + +(deftest concatenate.14 + (concatenate 'simple-bit-vector) + #*) + +(deftest concatenate.15 + (concatenate 'simple-bit-vector '(0 1 1) nil #(1 0 1) #()) + #*011101) + +(deftest concatenate.16 + (concatenate 'string "abc" '(#\d #\e) nil #() "fg") + "abcdefg") + +(deftest concatenate.17 + (concatenate 'simple-string "abc" '(#\d #\e) nil #() "fg") + "abcdefg") + +(deftest concatenate.18 + (concatenate '(vector * *) '(a b c) '(d e f) #(g h)) + #(a b c d e f g h)) + +(deftest concatenate.19 + (concatenate '(vector * 8) '(a b c) '(d e f) #(g h)) + #(a b c d e f g h)) + +(deftest concatenate.20 + (concatenate '(vector symbol 8) '(a b c) '(d e f) #(g h)) + #(a b c d e f g h)) + +(deftest concatenate.21 + (concatenate '(vector symbol) '(a b c) '(d e f) #(g h)) + #(a b c d e f g h)) + +(deftest concatenate.22 + (concatenate '(vector symbol *) '(a b c) '(d e f) #(g h)) + #(a b c d e f g h)) + +(deftest concatenate.23 + (concatenate 'cons '(a b c) '(d e f)) + (a b c d e f)) + +(deftest concatenate.24 + (concatenate 'null nil nil) + nil) + +;;; Tests on vectors with fill pointers + +(deftest concatenate.25 + (let ((x (make-array '(10) :initial-contents '(a b c d e f g h i j) + :fill-pointer 5))) + (concatenate 'list x x)) + (a b c d e a b c d e)) + +(deftest concatenate.26 + (let ((x (make-array '(10) :initial-contents '(a b c d e f g h i j) + :fill-pointer 5))) + (concatenate 'list x)) + (a b c d e)) + +(deftest concatenate.27 + (let* ((x (make-array '(10) :initial-contents '(a b c d e f g h i j) + :fill-pointer 5)) + (result (concatenate 'vector x))) + (values (not (simple-vector-p result)) + result)) + nil + #(a b c d e)) + +(deftest concatenate.28 + (let* ((x (make-array '(10) :initial-contents "abcdefghij" + :fill-pointer 5 :element-type 'character))) + (values + (concatenate 'string x '(#\z)) + (concatenate 'string '(#\z) x) + (concatenate 'string x x) + (concatenate 'string x) + (not (simple-string-p (concatenate 'string x))) + )) + "abcdez" + "zabcde" + "abcdeabcde" + "abcde" + nil) + +(deftest concatenate.29 + (let* ((x (make-array '(10) :initial-contents "abcdefghij" + :fill-pointer 5 :element-type 'base-char))) + (values + (concatenate 'string x '(#\z)) + (concatenate 'string '(#\z) x) + (concatenate 'string x x) + (concatenate 'string x) + (not (simple-string-p (concatenate 'string x))) + )) + "abcdez" + "zabcde" + "abcdeabcde" + "abcde" + nil) + +(deftest concatenate.30 + (let* ((x (make-array '(10) :initial-contents #*0110010111 + :fill-pointer 5 :element-type 'bit))) + (values + (concatenate 'bit-vector x '(0)) + (concatenate 'bit-vector '(0) x) + (concatenate 'bit-vector x x) + (concatenate 'bit-vector x) + (not (simple-bit-vector-p (concatenate 'bit-vector x))) + )) + #*011000 + #*001100 + #*0110001100 + #*01100 + nil) + +(deftest concatenate.order.1 + (let ((i 0) w x y z) + (values + (concatenate (progn (setf w (incf i)) 'string) + (progn (setf x (incf i)) "abc") + (progn (setf y (incf i)) "def") + (progn (setf z (incf i)) "ghi")) + i w x y z)) + "abcdefghi" 4 1 2 3 4) + +(deftest concatenate.order.2 + (let ((i 0) x y z) + (values + (concatenate 'string + (progn (setf x (incf i)) "abc") + (progn (setf y (incf i)) "def") + (progn (setf z (incf i)) "ghi")) + i x y z)) + "abcdefghi" 3 1 2 3) + +;;; Error tests + +(deftest concatenate.error.1 + (subtypep* (classify-error (concatenate 'sequence '(a b c))) 'error) + t t) + +(deftest concatenate.error.2 + (subtypep* (classify-error (concatenate 'fixnum '(a b c d e))) 'error) + t t) + +(deftest concatenate.error.3 + (classify-error (concatenate '(vector * 3) '(a b c d e))) + type-error) + +(deftest concatenate.error.4 + (classify-error (concatenate)) + program-error) + +(deftest concatenate.error.5 + (classify-error (locally (concatenate '(vector * 3) '(a b c d e)) t)) + type-error) diff --git a/ansi-tests/cond.lsp b/ansi-tests/cond.lsp new file mode 100644 index 0000000..df34248 --- /dev/null +++ b/ansi-tests/cond.lsp @@ -0,0 +1,75 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Oct 18 07:37:58 2002 +;;;; Contains: Tests of COND + +(in-package :cl-test) + +(deftest cond.1 + (cond) + nil) + +(deftest cond.2 + (cond ('a)) + a) + +(deftest cond.3 + (cond (nil)) + nil) + +(deftest cond.4 + (cond (nil 'a) (nil 'b)) + nil) + +(deftest cond.5 + (cond (nil 'a) ('b)) + b) + +(deftest cond.6 + (cond (t 'a) (t 'b)) + a) + +(deftest cond.7 + (let ((x 0)) + (values + (cond ((progn (incf x) nil) 'a) (t 'b) ((incf x) 'c)) + x)) + b 1) + +(deftest cond.8 + (let ((x 0)) + (values + (cond (nil (incf x) 'a) + (nil (incf x 10) 'b) + (t (incf x 2) 'c) + (t (incf x 100) 'd)) + x)) + c 2) + +(deftest cond.9 + (cond ((values 'a 'b 'c))) + a) + +(deftest cond.10 + (cond (t (values 'a 'b 'c))) + a b c) + +(deftest cond.11 + (cond + ((values nil t) 'a) + (t 'b)) + b) + +(deftest cond.12 + (cond ((values))) + nil) + +(deftest cond.13 + (cond ((values)) (t 'a)) + a) + +(deftest cond.14 (cond (t (values)))) + + + + diff --git a/ansi-tests/condition.lsp b/ansi-tests/condition.lsp new file mode 100644 index 0000000..a42ea74 --- /dev/null +++ b/ansi-tests/condition.lsp @@ -0,0 +1,63 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Mon Jan 27 22:13:25 2003 +;;;; Contains: Tests of class CONDITION + +(in-package :cl-test) + +(deftest condition.1 + (notnot-mv (find-class 'condition nil)) + t) + +(defparameter *allowed-condition-inclusions* + '( + (arithmetic-error error serious-condition condition) + (cell-error error serious-condition condition) + (condition) + (control-error error serious-condition condition) + (division-by-zero arithmetic-error error serious-condition condition) + (end-of-file stream-error error serious-condition condition) + (error serious-condition condition) + (file-error error serious-condition condition) + (floating-point-inexact arithmetic-error error serious-condition condition) + (floating-point-invalid-operation arithmetic-error error serious-condition condition) + (floating-point-overflow arithmetic-error error serious-condition condition) + (floating-point-underflow arithmetic-error error serious-condition condition) + (package-error error serious-condition condition) + (parse-error error serious-condition condition) + (print-not-readable error serious-condition condition) + (program-error error serious-condition condition) + (reader-error parse-error stream-error error serious-condition condition) + (serious-condition condition) + (simple-condition condition) + (simple-error simple-condition error serious-condition condition) + (simple-type-error simple-condition type-error error serious-condition condition) + (simple-warning simple-condition warning condition) + (storage-condition serious-condition condition) + (stream-error error serious-condition condition) + (style-warning warning condition) + (type-error error serious-condition condition) + (unbound-slot cell-error error serious-condition condition) + (unbound-variable cell-error error serious-condition condition) + (undefined-function cell-error error serious-condition condition) + (warning condition) + )) + +;;; Relationships given in *allowed-condition-inclusions* are the only +;;; subtype relationships allowed on condition types +(deftest condition.2 + (loop for (cnd . supers) in *allowed-condition-inclusions* + append (loop for super in supers + unless (subtypep cnd super) + collect (list cnd super))) + nil) + +(deftest condition.3 + ;; Relationships given in *allowed-condition-inclusions* are the only + ;; subtype relationships allowed on condition types + (loop for cnds in *allowed-condition-inclusions* + for cnd = (first cnds) + append (loop for super in (set-difference *condition-types* cnds) + when (subtypep cnd super) + collect (list cnd super))) + nil) diff --git a/ansi-tests/cons-test-01.lsp b/ansi-tests/cons-test-01.lsp new file mode 100644 index 0000000..c665a81 --- /dev/null +++ b/ansi-tests/cons-test-01.lsp @@ -0,0 +1,456 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 07:29:48 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 1 + +(in-package :cl-test) + +(declaim (optimize (safety 3))) + +;; +;; Test the subtype relationships between null, list, cons and atom +;; +(deftest subtypep-null-list + (subtypep* 'null 'list) + t t) + +(deftest subtypep-cons-list + (subtypep* 'cons 'list) + t t) + +(deftest subtypep-null-cons + (subtypep* 'null 'cons) + nil t) + +(deftest subtypep-cons-null + (subtypep* 'cons 'null) + nil t) + +(deftest subtypep-null-atom + (subtypep* 'null 'atom) + t t) + +(deftest subtypep-cons-atom + (subtypep* 'cons 'atom) + nil t) + +(deftest subtypep-atom-cons + (subtypep* 'atom 'cons) + nil t) + +(deftest subtypep-atom-list + (subtypep* 'atom 'list) + nil t) + +(deftest subtypep-list-atom + (subtypep* 'list 'atom) + nil t) + +;; +;; Check that the elements of *universe* in type null +;; are those for which the null predice is true. +;; +(deftest null-null-universe + (check-type-predicate 'null 'null) + 0) + +(defvar *cons-fns* + (list 'cons 'consp 'atom 'rplaca 'rplacd + 'car 'cdr 'caar 'cadr 'cdar 'cddr + 'caaar 'caadr 'cadar 'caddr + 'cdaar 'cdadr 'cddar 'cdddr + 'caaaar 'caaadr 'caadar 'caaddr + 'cadaar 'cadadr 'caddar 'cadddr + 'cdaaar 'cdaadr 'cdadar 'cdaddr + 'cddaar 'cddadr 'cdddar 'cddddr + 'copy-tree 'sublis 'nsublis + 'subst 'subst-if 'subst-if-not + 'nsubst 'nsubst-if 'nsubst-if-not + 'tree-equal + 'copy-list + 'list + 'list* + 'list-length + 'listp + 'make-list + 'first 'second 'third 'fourth + 'fifth 'sixth 'seventh 'eighth 'ninth 'tenth + 'nth + 'endp + 'null + 'nconc + 'append + 'revappend 'nreconc + 'butlast 'nbutlast + 'last 'ldiff 'tailp + 'nthcdr 'rest + 'member 'member-if 'member-if-not + 'mapc 'mapcar 'mapcan 'mapl 'maplist 'mapcon + 'acons + 'assoc 'assoc-if 'assoc-if-not + 'copy-alist + 'pairlis + 'rassoc 'rassoc-if 'rassoc-if-not + 'get-properties + 'getf + 'intersection + 'nintersection + 'adjoin + 'set-difference 'nset-difference + 'set-exclusive-or 'nset-exclusive-or + 'subsetp + 'union 'nunion + )) + +;; All the cons functions have a function binding + +(deftest function-bound-cons-fns + (loop + for x in *cons-fns* count + (when (or (not (fboundp x)) + (not (functionp (symbol-function x)))) + (format t "~%~S not bound to a function" x) + t)) + 0) + +;; All the cons-related macros have a macro binding +(deftest macro-bound-cons-macros + (notnot-mv (every #'macro-function + (list 'push 'pop 'pushnew 'remf))) + t) + +;; None of the cons-related functions have macro bindings +(deftest no-cons-fns-are-macros + (some #'macro-function *cons-fns*) + nil) + +;; Various easy tests of cons +(deftest cons-of-symbols + (cons 'a 'b) + (a . b)) + +(deftest cons-with-nil + (cons 'a nil) + (a)) + +;; successive calls to cons produces results that are equal, but not eq +(deftest cons-eq-equal + (let ((x (cons 'a 'b)) + (y (cons 'a 'b))) + (and (not (eqt x y)) + (equalt x y))) + t) + +;; list can be expressed as a bunch of conses (with nil) +(deftest cons-equal-list + (equalt (cons 'a (cons 'b (cons 'c nil))) + (list 'a 'b 'c)) + t) + +;;; Order of evaluation of cons arguments +(deftest cons.order.1 + (let ((i 0)) (values (cons (incf i) (incf i)) i)) + (1 . 2) 2) + +;; Lists satisfy consp +(deftest consp-list + (notnot-mv (consp '(a))) + t) + +;; cons satisfies consp +(deftest consp-cons + (notnot-mv (consp (cons nil nil))) + t) + +;; nil is not a consp +(deftest consp-nil + (consp nil) + nil) + +;; The empty list is not a cons +(deftest consp-empty-list + (consp (list)) + nil) + +;; A single element list is a cons +(deftest consp-single-element-list + (notnot-mv (consp (list 'a))) + t) + +;; For everything in *universe*, it is either an atom, or satisfies +;; consp, but not both +(deftest consp-xor-atom-universe + (notnot-mv + (every #'(lambda (x) (or (and (consp x) (not (atom x))) + (and (not (consp x)) (atom x)))) + *universe*)) + t) + +;; Everything in type cons satisfies consp, and vice versa +(deftest consp-cons-universe + (check-type-predicate 'consp 'cons) + 0) + +(deftest consp.order.1 + (let ((i 0)) + (values (consp (incf i)) i)) + nil 1) + +(deftest consp.error.1 + (classify-error (consp)) + program-error) + +(deftest consp.error.2 + (classify-error (consp 'a 'b)) + program-error) + +(deftest atom.order.1 + (let ((i 0)) + (values (atom (progn (incf i) '(a b))) i)) + nil 1) + +(deftest atom.error.1 + (classify-error (atom)) + program-error) + +(deftest atom.error.2 + (classify-error (atom 'a 'b)) + program-error) + +;; Tests of car, cdr and compound forms +(deftest cons.23 + (car '(a)) + a) + +(deftest cons.24 + (cdr '(a . b)) + b) + +(deftest cons.25 + (caar '((a))) + a) + +(deftest cons.26 + (cdar '((a . b))) + b) + +(deftest cons.27 + (cadr '(a b)) + b) + +(deftest cons.28 + (cddr '(a b . c)) + c) + +(deftest cons.29 + (caaar '(((a)))) + a) + +(deftest cons.30 + (cdaar '(((a . b)))) + b) + +(deftest cons.31 + (cadar (cons (cons 'a (cons 'b 'c)) 'd)) + b) + +(deftest cons.32 + (cddar (cons (cons 'a (cons 'b 'c)) 'd)) + c) + +(deftest cons.33 + (caadr (cons 'a (cons (cons 'b 'c) 'd))) + b) + +(deftest cons.34 + (caddr (cons 'a (cons 'b (cons 'c 'd)))) + c) + +(deftest cons.36 + (cdadr (cons 'a (cons (cons 'b 'c) 'd))) + c) + +(deftest cons.37 + (cdddr (cons 'a (cons 'b (cons 'c 'd)))) + d) + +(defvar *cons-test-4* + (cons (cons (cons (cons 'a 'b) + (cons 'c 'd)) + (cons (cons 'e 'f) + (cons 'g 'h))) + (cons (cons (cons 'i 'j) + (cons 'k 'l)) + (cons (cons 'm 'n) + (cons 'o 'p))))) + + +(deftest cons.38 + (caaaar *cons-test-4*) + a) + +(deftest cons.39 + (cdaaar *cons-test-4*) + b) + +(deftest cons.40 + (cadaar *cons-test-4*) + c) + +(deftest cons.41 + (cddaar *cons-test-4*) + d) + +(deftest cons.42 + (caadar *cons-test-4*) + e) + +(deftest cons.43 + (cdadar *cons-test-4*) + f) + +(deftest cons.44 + (caddar *cons-test-4*) + g) + +(deftest cons.45 + (cdddar *cons-test-4*) + h) + +;;; + +(deftest cons.46 + (caaadr *cons-test-4*) + i) + +(deftest cons.47 + (cdaadr *cons-test-4*) + j) + +(deftest cons.48 + (cadadr *cons-test-4*) + k) + +(deftest cons.49 + (cddadr *cons-test-4*) + l) + +(deftest cons.50 + (caaddr *cons-test-4*) + m) + +(deftest cons.51 + (cdaddr *cons-test-4*) + n) + +(deftest cons.52 + (cadddr *cons-test-4*) + o) + +(deftest cons.53 + (cddddr *cons-test-4*) + p) + +(deftest cons.error.1 + (classify-error (cons)) + program-error) + +(deftest cons.error.2 + (classify-error (cons 'a)) + program-error) + +(deftest cons.error.3 + (classify-error (cons 'a 'b 'c)) + program-error) + +;; Test rplaca, rplacd + +(deftest rplaca.1 + (let ((x (cons 'a 'b))) + (let ((y x)) + (and (eqt (rplaca x 'c) y) + (eqt x y) + (eqt (car x) 'c) + (eqt (cdr x) 'b)))) + t) + +(deftest rplaca.order.1 + (let ((x (cons 'a 'b)) + (i 0) a b) + (values + (rplaca (progn (setf a (incf i)) x) + (progn (setf b (incf i)) 'c)) + i a b)) + (c . b) 2 1 2) + +(deftest rplacd.1 + (let ((x (cons 'a 'b))) + (let ((y x)) + (and (eqt (rplacd x 'd) y) + (eqt x y) + (eqt (car x) 'a) + (eqt (cdr x) 'd)))) + t) + +(deftest rplacd.order.1 + (let ((x (cons 'a 'b)) + (i 0) a b) + (values + (rplacd (progn (setf a (incf i)) x) + (progn (setf b (incf i)) 'c)) + i a b)) + (a . c) 2 1 2) + +;; rplaca on a fixnum is a type error +(deftest rplaca.error.1 + (loop for x in *universe* + thereis (and (not (consp x)) + (not (eq (catch-type-error (rplaca x 1)) 'type-error)))) + nil) + +(deftest rplaca.error.2 + (classify-error (rplaca)) + program-error) + +(deftest rplaca.error.3 + (classify-error (rplaca (cons 'a 'b))) + program-error) + +(deftest rplaca.error.4 + (classify-error (rplaca (cons 'a 'b) (cons 'c 'd) 'garbage)) + program-error) + +(deftest rplaca.error.5 + (classify-error (rplaca 'a 1)) + type-error) + +(deftest rplaca.error.6 + (classify-error (locally (rplaca 'a 1) t)) + type-error) + +;; rplacd on a fixnum is a type error +(deftest rplacd.error.1 + (loop for x in *universe* + thereis (and (not (consp x)) + (not (eq (catch-type-error (rplacd x 1)) 'type-error)))) + nil) + +(deftest rplacd.error.2 + (classify-error (rplacd)) + program-error) + +(deftest rplacd.error.3 + (classify-error (rplacd (cons 'a 'b))) + program-error) + +(deftest rplacd.error.4 + (classify-error (rplacd (cons 'a 'b) (cons 'c 'd) 'garbage)) + program-error) + +(deftest rplacd.error.5 + (classify-error (rplacd 'a 1)) + type-error) + +(deftest rplacd.error.6 + (classify-error (locally (rplacd 'a 1) t)) + type-error) diff --git a/ansi-tests/cons-test-02.lsp b/ansi-tests/cons-test-02.lsp new file mode 100644 index 0000000..85cb288 --- /dev/null +++ b/ansi-tests/cons-test-02.lsp @@ -0,0 +1,1117 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 07:30:50 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 2 + +(in-package :cl-test) + +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; copy-tree + +;; Try copy-tree on a tree containing elements of various kinds +(deftest copy-tree.1 + (let ((x (cons 'a (list (cons 'b 'c) + (cons 1 1.2) + (list (list "abcde" + (make-array '(10) :initial-element (cons 'e 'f))) + 'g))))) + (let ((y (copy-tree x))) + (check-cons-copy x y))) + t) + +;; Try copy-tree on *universe* +(deftest copy-tree.2 + (let* ((x (copy-list *universe*)) + (y (copy-tree x))) + (check-cons-copy x y)) + t) + +(deftest copy-tree.order.1 + (let ((i 0)) + (values + (copy-tree (progn (incf i) '(a b c))) + i)) + (a b c) 1) + +(deftest copy-tree.error.1 + (classify-error (copy-tree)) + program-error) + +(deftest copy-tree.error.2 + (classify-error (copy-tree 'a 'b)) + program-error) + +;;; + +(deftest sublis.1 + (check-sublis '((a b) g (d e 10 g h) 15 . g) + '((e . e2) (g . 17))) + ((a b) 17 (d e2 10 17 h) 15 . 17)) + +(deftest sublis.2 + (check-sublis '(f6 10 (f4 (f3 (f1 a b) (f1 a p)) (f2 a b))) + '(((f1 a b) . (f2 a b)) ((f2 a b) . (f1 a b))) + :test #'equal) + (f6 10 (f4 (f3 (f2 a b) (f1 a p)) (f1 a b)))) + +(deftest sublis.3 + (check-sublis '(10 ((10 20 (a b c) 30)) (((10 20 30 40)))) + '((30 . "foo"))) + (10 ((10 20 (a b c) "foo")) (((10 20 "foo" 40))))) + +(deftest sublis.4 + (check-sublis (sublis + (copy-tree '((a . 2) (b . 4) (c . 1))) + (copy-tree '(a b c d e (a b c a d b) f))) + '((t . "yes")) + :key #'(lambda (x) (and (typep x 'integer) + (evenp x)))) + ("yes" "yes" 1 d e ("yes" "yes" 1 "yes" d "yes") f)) + +(deftest sublis.5 + (check-sublis '("fee" (("fee" "Fie" "foo")) + fie ("fee" "fie")) + `((,(copy-seq "fie") . #\f))) + ("fee" (("fee" "Fie" "foo")) fie ("fee" "fie"))) + +(deftest sublis.6 + (check-sublis '("fee" fie (("fee" "Fie" "foo") 1) + ("fee" "fie")) + `((,(copy-seq "fie") . #\f)) + :test 'equal) + ("fee" fie (("fee" "Fie" "foo") 1) ("fee" #\f))) + +(deftest sublis.7 + (check-sublis '(("aa" a b) + (z "bb" d) + ((x . "aa"))) + `((,(copy-seq "aa") . 1) + (,(copy-seq "bb") . 2)) + :test 'equal + :key #'(lambda (x) (if (consp x) (car x) + '*not-present*))) + (1 (z . 2) ((x . "aa")))) + +;; Check that a null key arg is ignored. + +(deftest sublis.8 + (check-sublis + '(1 2 a b) + '((1 . 2) (a . b)) + :key nil) + (2 2 b b)) + +;;; Order of argument evaluation +(deftest sublis.order.1 + (let ((i 0) w x y z) + (values + (sublis + (progn (setf w (incf i)) + '((a . z))) + (progn (setf x (incf i)) + (copy-tree '(a b c d))) + :test (progn (setf y (incf i)) #'eql) + :key (progn (setf z (incf i)) #'identity)) + i w x y z)) + (z b c d) + 4 1 2 3 4) + +(deftest sublis.order.2 + (let ((i 0) w x y z) + (values + (sublis + (progn (setf w (incf i)) + '((a . z))) + (progn (setf x (incf i)) + (copy-tree '(a b c d))) + :key (progn (setf y (incf i)) #'identity) + :test-not (progn (setf z (incf i)) (complement #'eql)) + ) + i w x y z)) + (z b c d) + 4 1 2 3 4) + + +;;; Keyword tests + +(deftest sublis.allow-other-keys.1 + (sublis nil 'a :bad t :allow-other-keys t) + a) + +(deftest sublis.allow-other-keys.2 + (sublis nil 'a :allow-other-keys t :bad t) + a) + +(deftest sublis.allow-other-keys.3 + (sublis nil 'a :allow-other-keys t) + a) + +(deftest sublis.allow-other-keys.4 + (sublis nil 'a :allow-other-keys nil) + a) + +(deftest sublis.allow-other-keys.5 + (sublis nil 'a :allow-other-keys t :allow-other-keys t :bad t) + a) + +(deftest sublis.keywords.6 + (sublis '((1 . a)) (list 0 1 2) :key #'(lambda (x) (if (numberp x) (1+ x) x)) + :key #'identity) + (a 1 2)) + + +;; Argument error cases + +(deftest sublis.error.1 + (classify-error (sublis)) + program-error) + +(deftest sublis.error.2 + (classify-error (sublis nil)) + program-error) + +(deftest sublis.error.3 + (classify-error (sublis nil 'a :test)) + program-error) + +(deftest sublis.error.4 + (classify-error (sublis nil 'a :bad-keyword t)) + program-error) + +(deftest sublis.error.5 + (classify-error (sublis '((a . 1) (b . 2)) + (list 'a 'b 'c 'd) + :test #'identity)) + program-error) + +(deftest sublis.error.6 + (classify-error (sublis '((a . 1) (b . 2)) + (list 'a 'b 'c 'd) + :key #'cons)) + program-error) + +(deftest sublis.error.7 + (classify-error (sublis '((a . 1) (b . 2)) + (list 'a 'b 'c 'd) + :test-not #'identity)) + program-error) + +;; nsublis + +(deftest nsublis.1 + (check-nsublis '((a b) g (d e 10 g h) 15 . g) + '((e . e2) (g . 17))) + ((a b) 17 (d e2 10 17 h) 15 . 17)) + +(deftest nsublis.2 + (check-nsublis '(f6 10 (f4 (f3 (f1 a b) (f1 a p)) (f2 a b))) + '(((f1 a b) . (f2 a b)) ((f2 a b) . (f1 a b))) + :test #'equal) + (f6 10 (f4 (f3 (f2 a b) (f1 a p)) (f1 a b)))) + +(deftest nsublis.3 + (check-nsublis '(10 ((10 20 (a b c) 30)) (((10 20 30 40)))) + '((30 . "foo"))) + (10 ((10 20 (a b c) "foo")) (((10 20 "foo" 40))))) + +(deftest nsublis.4 + (check-nsublis + (nsublis (copy-tree '((a . 2) (b . 4) (c . 1))) + (copy-tree '(a b c d e (a b c a d b) f))) + '((t . "yes")) + :key #'(lambda (x) (and (typep x 'integer) + (evenp x)))) + ("yes" "yes" 1 d e ("yes" "yes" 1 "yes" d "yes") f)) + +(deftest nsublis.5 + (check-nsublis '("fee" (("fee" "Fie" "foo")) + fie ("fee" "fie")) + `((,(copy-seq "fie") . #\f))) + ("fee" (("fee" "Fie" "foo")) fie ("fee" "fie"))) + +(deftest nsublis.6 + (check-nsublis '("fee" fie (("fee" "Fie" "foo") 1) + ("fee" "fie")) + `((,(copy-seq "fie") . #\f)) + :test 'equal) + ("fee" fie (("fee" "Fie" "foo") 1) ("fee" #\f))) + +(deftest nsublis.7 + (check-nsublis '(("aa" a b) + (z "bb" d) + ((x . "aa"))) + `((,(copy-seq "aa") . 1) + (,(copy-seq "bb") . 2)) + :test 'equal + :key #'(lambda (x) (if (consp x) (car x) + '*not-present*))) + (1 (z . 2) ((x . "aa")))) + +(deftest nsublis.8 + (nsublis nil 'a :bad-keyword t :allow-other-keys t) + a) + +;; Check that a null key arg is ignored. + +(deftest nsublis.9 + (check-nsublis + '(1 2 a b) + '((1 . 2) (a . b)) + :key nil) + (2 2 b b)) + +;;; Order of argument evaluation +(deftest nsublis.order.1 + (let ((i 0) w x y z) + (values + (nsublis + (progn (setf w (incf i)) + '((a . z))) + (progn (setf x (incf i)) + (copy-tree '(a b c d))) + :test (progn (setf y (incf i)) #'eql) + :key (progn (setf z (incf i)) #'identity)) + i w x y z)) + (z b c d) + 4 1 2 3 4) + +(deftest nsublis.order.2 + (let ((i 0) w x y z) + (values + (nsublis + (progn (setf w (incf i)) + '((a . z))) + (progn (setf x (incf i)) + (copy-tree '(a b c d))) + :key (progn (setf y (incf i)) #'identity) + :test-not (progn (setf z (incf i)) (complement #'eql)) + ) + i w x y z)) + (z b c d) + 4 1 2 3 4) + +;;; Keyword tests + +(deftest nsublis.allow-other-keys.1 + (nsublis nil 'a :bad t :allow-other-keys t) + a) + +(deftest nsublis.allow-other-keys.2 + (nsublis nil 'a :allow-other-keys t :bad t) + a) + +(deftest nsublis.allow-other-keys.3 + (nsublis nil 'a :allow-other-keys t) + a) + +(deftest nsublis.allow-other-keys.4 + (nsublis nil 'a :allow-other-keys nil) + a) + +(deftest nsublis.allow-other-keys.5 + (nsublis nil 'a :allow-other-keys t :allow-other-keys t :bad t) + a) + +(deftest nsublis.keywords.6 + (nsublis '((1 . a)) (list 0 1 2) + :key #'(lambda (x) (if (numberp x) (1+ x) x)) + :key #'identity) + (a 1 2)) + +;; Argument error cases + +(deftest nsublis.error.1 + (classify-error (nsublis)) + program-error) + +(deftest nsublis.error.2 + (classify-error (nsublis nil)) + program-error) + +(deftest nsublis.error.3 + (classify-error (nsublis nil 'a :test)) + program-error) + +(deftest nsublis.error.4 + (classify-error (nsublis nil 'a :bad-keyword t)) + program-error) + +(deftest nsublis.error.5 + (classify-error (nsublis '((a . 1) (b . 2)) + (list 'a 'b 'c 'd) + :test #'identity)) + program-error) + +(deftest nsublis.error.6 + (classify-error (nsublis '((a . 1) (b . 2)) + (list 'a 'b 'c 'd) + :key #'cons)) + program-error) + +(deftest nsublis.error.7 + (classify-error (nsublis '((a . 1) (b . 2)) + (list 'a 'b 'c 'd) + :test-not #'identity)) + program-error) + +;;;;;; + +(deftest sublis.shared + (let* ((shared-piece (list 'a 'b)) + (a (list shared-piece shared-piece))) + (check-sublis a '((a . b) (b . a)))) + ((b a) (b a))) + +(defvar *subst-tree-1* '(10 (30 20 10) (20 10) (10 20 30 40))) + +(deftest subst.1 + (check-subst "Z" 30 (copy-tree *subst-tree-1*)) + (10 ("Z" 20 10) (20 10) (10 20 "Z" 40))) + +(deftest subst.2 + (check-subst "A" 0 (copy-tree *subst-tree-1*)) + (10 (30 20 10) (20 10) (10 20 30 40))) + +(deftest subst.3 + (check-subst "Z" 100 (copy-tree *subst-tree-1*) :test-not #'eql) + "Z") + +(deftest subst.4 + (check-subst 'grape 'dick + '(melville wrote (moby dick))) + (melville wrote (moby grape))) + +(deftest subst.5 + (check-subst 'cha-cha-cha 'nil '(melville wrote (moby dick))) + (melville wrote (moby dick . cha-cha-cha) . cha-cha-cha)) + +(deftest subst.6 + (check-subst + '(1 2) '(foo . bar) + '((foo . baz) (foo . bar) (bar . foo) (baz foo . bar)) + :test #'equal) + ((foo . baz) (1 2) (bar . foo) (baz 1 2))) + +(deftest subst.7 + (check-subst + 'foo "aaa" + '((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) + :key #'(lambda (x) (if (and (numberp x) (evenp x)) + "aaa" + nil)) + :test #'string=) + ((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) + +(deftest subst.8 + (check-subst + 'foo nil + '((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) + :key #'(lambda (x) (if (and (numberp x) (evenp x)) + (copy-seq "aaa") + nil)) + :test-not #'equal) + ((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) + +(deftest subst.9 + (check-subst 'a 'b + (copy-tree '(a b c d a b)) + :key nil) + (a a c d a a)) + +;;; Order of argument evaluation +(deftest subst.order.1 + (let ((i 0) v w x y z) + (values + (subst (progn (setf v (incf i)) 'b) + (progn (setf w (incf i)) 'a) + (progn (setf x (incf i)) (copy-tree '((10 a . a) a b c ((a)) z))) + :key (progn (setf y (incf i)) #'identity) + :test (progn (setf z (incf i)) #'eql)) + i v w x y z)) + ((10 b . b) b b c ((b)) z) + 5 1 2 3 4 5) + +(deftest subst.order.2 + (let ((i 0) v w x y z) + (values + (subst (progn (setf v (incf i)) 'b) + (progn (setf w (incf i)) 'a) + (progn (setf x (incf i)) (copy-tree '((10 a . a) a b c ((a)) z))) + :test-not (progn (setf y (incf i)) (complement #'eql)) + :key (progn (setf z (incf i)) #'identity) + ) + i v w x y z)) + ((10 b . b) b b c ((b)) z) + 5 1 2 3 4 5) + + + +;;; Keyword tests for subst + +(deftest subst.allow-other-keys.1 + (subst 'a 'b (list 'a 'b 'c) :bad t :allow-other-keys t) + (a a c)) + +(deftest subst.allow-other-keys.2 + (subst 'a 'b (list 'a 'b 'c) :allow-other-keys t) + (a a c)) + +(deftest subst.allow-other-keys.3 + (subst 'a 'b (list 'a 'b 'c) :allow-other-keys nil) + (a a c)) + +(deftest subst.allow-other-keys.4 + (subst 'a 'b (list 'a 'b 'c) :allow-other-keys t :bad t) + (a a c)) + +(deftest subst.allow-other-keys.5 + (subst 'a 'b (list 'a 'b 'c) :allow-other-keys t :allow-other-keys nil + :bad t) + (a a c)) + +(deftest subst.keywords.6 + (subst 'a 'b (list 'a 'b 'c) :test #'eq :test (complement #'eq)) + (a a c)) + + +;;; Tests for subst-if, subst-if-not + +(deftest subst-if.1 + (check-subst-if 'a #'consp '((100 1) (2 3) (4 3 2 1) (a b c))) + a) + +(deftest subst-if-not.1 + (check-subst-if-not '(x) 'consp '(1 (1 2) (1 2 3) (1 2 3 4))) + ((x) + ((x) (x) x) + ((x) (x) (x) x) + ((x) (x) (x) (x) x) + x)) + +(deftest subst-if.2 + (check-subst-if 17 (complement #'listp) '(a (a b) (a c d) (a nil e f g))) + (17 (17 17) (17 17 17) (17 nil 17 17 17))) + +(deftest subst-if.3 + (check-subst-if '(z) + (complement #'consp) + '(a (a b) (c d e) (f g h i))) + ((z) + ((z) (z) z) + ((z) (z) (z) z) + ((z) (z) (z) (z) z) + z)) + +(deftest subst-if-not.2 + (check-subst-if-not 'a (complement #'listp) + '((100 1) (2 3) (4 3 2 1) (a b c))) + a) + +(deftest subst-if.4 + (check-subst-if 'b #'identity '((100 1) (2 3) (4 3 2 1) (a b c)) + :key #'listp) + b) + +(deftest subst-if-not.3 + (check-subst-if-not 'c #'identity + '((100 1) (2 3) (4 3 2 1) (a b c)) + :key (complement #'listp)) + c) + +(deftest subst-if.5 + (check-subst-if 4 #'(lambda (x) (eql x 1)) + '((1 3) (1) (1 10 20 30) (1 3 x y)) + :key #'(lambda (x) + (and (consp x) + (car x)))) + (4 4 4 4)) + +(deftest subst-if-not.4 + (check-subst-if-not + 40 + #'(lambda (x) (not (eql x 17))) + '((17) (17 22) (17 22 31) (17 21 34 54)) + :key #'(lambda (x) + (and (consp x) + (car x)))) + (40 40 40 40)) + +(deftest subst-if.6 + (check-subst-if 'a #'(lambda (x) (eql x 'b)) + '((a) (b) (c) (d)) + :key nil) + ((a) (a) (c) (d))) + +(deftest subst-if-not.5 + (check-subst-if-not 'a #'(lambda (x) (not (eql x 'b))) + '((a) (b) (c) (d)) + :key nil) + ((a) (a) (c) (d))) + +(deftest subst-if.7 + (let ((i 0) w x y z) + (values + (subst-if + (progn (setf w (incf i)) 'a) + (progn (setf x (incf i)) #'(lambda (x) (eql x 'b))) + (progn (setf y (incf i)) (copy-list '(1 2 a b c))) + :key (progn (setf z (incf i)) #'identity)) + i w x y z)) + (1 2 a a c) + 4 1 2 3 4) + +(deftest subst-if-not.7 + (let ((i 0) w x y z) + (values + (subst-if-not + (progn (setf w (incf i)) 'a) + (progn (setf x (incf i)) #'(lambda (x) (not (eql x 'b)))) + (progn (setf y (incf i)) (copy-list '(1 2 a b c))) + :key (progn (setf z (incf i)) #'identity)) + i w x y z)) + (1 2 a a c) + 4 1 2 3 4) + + + +;;; Keyword tests for subst-if + +(deftest subst-if.allow-other-keys.1 + (subst-if 'a #'null nil :bad t :allow-other-keys t) + a) + +(deftest subst-if.allow-other-keys.2 + (subst-if 'a #'null nil :allow-other-keys t) + a) + +(deftest subst-if.allow-other-keys.3 + (subst-if 'a #'null nil :allow-other-keys nil) + a) + +(deftest subst-if.allow-other-keys.4 + (subst-if 'a #'null nil :allow-other-keys t :bad t) + a) + +(deftest subst-if.allow-other-keys.5 + (subst-if 'a #'null nil :allow-other-keys t :allow-other-keys nil :bad t) + a) + +(deftest subst-if.keywords.6 + (subst-if 'a #'null nil :key nil :key (constantly 'b)) + a) + +;;; Keywords tests for subst-if-not + +(deftest subst-if-not.allow-other-keys.1 + (subst-if-not 'a #'identity nil :bad t :allow-other-keys t) + a) + +(deftest subst-if-not.allow-other-keys.2 + (subst-if-not 'a #'identity nil :allow-other-keys t) + a) + +(deftest subst-if-not.allow-other-keys.3 + (subst-if-not 'a #'identity nil :allow-other-keys nil) + a) + +(deftest subst-if-not.allow-other-keys.4 + (subst-if-not 'a #'identity nil :allow-other-keys t :bad t) + a) + +(deftest subst-if-not.allow-other-keys.5 + (subst-if-not 'a #'identity nil :allow-other-keys t :allow-other-keys nil :bad t) + a) + +(deftest subst-if-not.keywords.6 + (subst-if-not 'a #'identity nil :key nil :key (constantly 'b)) + a) + + +(defvar *nsubst-tree-1* '(10 (30 20 10) (20 10) (10 20 30 40))) + +(deftest nsubst.1 + (check-nsubst "Z" 30 (copy-tree *nsubst-tree-1*)) + (10 ("Z" 20 10) (20 10) (10 20 "Z" 40))) + +(deftest nsubst.2 + (check-nsubst "A" 0 (copy-tree *nsubst-tree-1*)) + (10 (30 20 10) (20 10) (10 20 30 40))) + +(deftest nsubst.3 + (check-nsubst "Z" 100 (copy-tree *nsubst-tree-1*) :test-not #'eql) + "Z") + +(deftest nsubst.4 + (check-nsubst 'grape 'dick + '(melville wrote (moby dick))) + (melville wrote (moby grape))) + +(deftest nsubst.5 + (check-nsubst 'cha-cha-cha 'nil '(melville wrote (moby dick))) + (melville wrote (moby dick . cha-cha-cha) . cha-cha-cha)) + +(deftest nsubst.6 + (check-nsubst + '(1 2) '(foo . bar) + '((foo . baz) (foo . bar) (bar . foo) (baz foo . bar)) + :test #'equal) + ((foo . baz) (1 2) (bar . foo) (baz 1 2))) + +(deftest nsubst.7 + (check-nsubst + 'foo "aaa" + '((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) + :key #'(lambda (x) (if (and (numberp x) (evenp x)) + "aaa" + nil)) + :test #'string=) + ((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) + +(deftest nsubst.8 + (check-nsubst + 'foo nil + '((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) + :key #'(lambda (x) (if (and (numberp x) (evenp x)) + (copy-seq "aaa") + nil)) + :test-not #'equal) + ((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) + +(deftest nsubst.9 + (check-nsubst 'a 'b + (copy-tree '(a b c d a b)) + :key nil) + (a a c d a a)) + +;;; Order of argument evaluation +(deftest nsubst.order.1 + (let ((i 0) v w x y z) + (values + (nsubst (progn (setf v (incf i)) 'b) + (progn (setf w (incf i)) 'a) + (progn (setf x (incf i)) (copy-tree '((10 a . a) a b c ((a)) z))) + :key (progn (setf y (incf i)) #'identity) + :test (progn (setf z (incf i)) #'eql)) + i v w x y z)) + ((10 b . b) b b c ((b)) z) + 5 1 2 3 4 5) + +(deftest nsubst.order.2 + (let ((i 0) v w x y z) + (values + (nsubst (progn (setf v (incf i)) 'b) + (progn (setf w (incf i)) 'a) + (progn (setf x (incf i)) (copy-tree '((10 a . a) a b c ((a)) z))) + :test-not (progn (setf y (incf i)) (complement #'eql)) + :key (progn (setf z (incf i)) #'identity) + ) + i v w x y z)) + ((10 b . b) b b c ((b)) z) + 5 1 2 3 4 5) + +;;; Keyword tests for nsubst + +(deftest nsubst.allow-other-keys.1 + (nsubst 'a 'b (list 'a 'b 'c) :bad t :allow-other-keys t) + (a a c)) + +(deftest nsubst.allow-other-keys.2 + (nsubst 'a 'b (list 'a 'b 'c) :allow-other-keys t) + (a a c)) + +(deftest nsubst.allow-other-keys.3 + (nsubst 'a 'b (list 'a 'b 'c) :allow-other-keys nil) + (a a c)) + +(deftest nsubst.allow-other-keys.4 + (nsubst 'a 'b (list 'a 'b 'c) :allow-other-keys t :bad t) + (a a c)) + +(deftest nsubst.allow-other-keys.5 + (nsubst 'a 'b (list 'a 'b 'c) :allow-other-keys t :allow-other-keys nil + :bad t) + (a a c)) + +(deftest nsubst.keywords.6 + (nsubst 'a 'b (list 'a 'b 'c) :test #'eq :test (complement #'eq)) + (a a c)) + +;;; Tests for nsubst-if, nsubst-if-not + +(deftest nsubst-if.1 + (check-nsubst-if 'a #'consp '((100 1) (2 3) (4 3 2 1) (a b c))) + a) + +(deftest nsubst-if-not.1 + (check-nsubst-if-not '(x) 'consp '(1 (1 2) (1 2 3) (1 2 3 4))) + ((x) + ((x) (x) x) + ((x) (x) (x) x) + ((x) (x) (x) (x) x) + x)) + +(deftest nsubst-if.2 + (check-nsubst-if 17 (complement #'listp) '(a (a b) (a c d) (a nil e f g))) + (17 (17 17) (17 17 17) (17 nil 17 17 17))) + +(deftest nsubst-if.3 + (check-nsubst-if '(z) + (complement #'consp) + '(a (a b) (c d e) (f g h i))) + ((z) + ((z) (z) z) + ((z) (z) (z) z) + ((z) (z) (z) (z) z) + z)) + +(deftest nsubst-if-not.2 + (check-nsubst-if-not 'a (complement #'listp) + '((100 1) (2 3) (4 3 2 1) (a b c))) + a) + +(deftest nsubst-if.4 + (check-nsubst-if 'b #'identity '((100 1) (2 3) (4 3 2 1) (a b c)) + :key #'listp) + b) + +(deftest nsubst-if-not.3 + (check-nsubst-if-not 'c #'identity + '((100 1) (2 3) (4 3 2 1) (a b c)) + :key (complement #'listp)) + c) + +(deftest nsubst-if.5 + (check-nsubst-if 4 #'(lambda (x) (eql x 1)) + '((1 3) (1) (1 10 20 30) (1 3 x y)) + :key #'(lambda (x) + (and (consp x) + (car x)))) + (4 4 4 4)) + +(deftest nsubst-if-not.4 + (check-nsubst-if-not + 40 + #'(lambda (x) (not (eql x 17))) + '((17) (17 22) (17 22 31) (17 21 34 54)) + :key #'(lambda (x) + (and (consp x) + (car x)))) + (40 40 40 40)) + +(deftest nsubst-if.6 + (check-nsubst-if 'a #'(lambda (x) (eql x 'b)) + '((a) (b) (c) (d)) + :key nil) + ((a) (a) (c) (d))) + +(deftest nsubst-if-not.5 + (check-nsubst-if-not 'a #'(lambda (x) (not (eql x 'b))) + '((a) (b) (c) (d)) + :key nil) + ((a) (a) (c) (d))) + +(deftest nsubst-if.7 + (nsubst-if 'a #'null nil :bad t :allow-other-keys t) + a) + +(deftest nsubst-if-not.6 + (nsubst-if-not 'a #'null nil :bad t :allow-other-keys t) + nil) + +(deftest nsubst-if.8 + (let ((i 0) w x y z) + (values + (nsubst-if + (progn (setf w (incf i)) 'a) + (progn (setf x (incf i)) #'(lambda (x) (eql x 'b))) + (progn (setf y (incf i)) (copy-list '(1 2 a b c))) + :key (progn (setf z (incf i)) #'identity)) + i w x y z)) + (1 2 a a c) + 4 1 2 3 4) + +(deftest nsubst-if-not.7 + (let ((i 0) w x y z) + (values + (nsubst-if-not + (progn (setf w (incf i)) 'a) + (progn (setf x (incf i)) #'(lambda (x) (not (eql x 'b)))) + (progn (setf y (incf i)) (copy-list '(1 2 a b c))) + :key (progn (setf z (incf i)) #'identity)) + i w x y z)) + (1 2 a a c) + 4 1 2 3 4) + +;;; Keyword tests for nsubst-if + +(deftest nsubst-if.allow-other-keys.1 + (nsubst-if 'a #'null nil :bad t :allow-other-keys t) + a) + +(deftest nsubst-if.allow-other-keys.2 + (nsubst-if 'a #'null nil :allow-other-keys t) + a) + +(deftest nsubst-if.allow-other-keys.3 + (nsubst-if 'a #'null nil :allow-other-keys nil) + a) + +(deftest nsubst-if.allow-other-keys.4 + (nsubst-if 'a #'null nil :allow-other-keys t :bad t) + a) + +(deftest nsubst-if.allow-other-keys.5 + (nsubst-if 'a #'null nil :allow-other-keys t :allow-other-keys nil :bad t) + a) + +(deftest nsubst-if.keywords.6 + (nsubst-if 'a #'null nil :key nil :key (constantly 'b)) + a) + +;;; Keywords tests for nsubst-if-not + +(deftest nsubst-if-not.allow-other-keys.1 + (nsubst-if-not 'a #'identity nil :bad t :allow-other-keys t) + a) + +(deftest nsubst-if-not.allow-other-keys.2 + (nsubst-if-not 'a #'identity nil :allow-other-keys t) + a) + +(deftest nsubst-if-not.allow-other-keys.3 + (nsubst-if-not 'a #'identity nil :allow-other-keys nil) + a) + +(deftest nsubst-if-not.allow-other-keys.4 + (nsubst-if-not 'a #'identity nil :allow-other-keys t :bad t) + a) + +(deftest nsubst-if-not.allow-other-keys.5 + (nsubst-if-not 'a #'identity nil :allow-other-keys t :allow-other-keys nil :bad t) + a) + +(deftest nsubst-if-not.keywords.6 + (nsubst-if-not 'a #'identity nil :key nil :key (constantly 'b)) + a) + +;;; Error cases + +;;; subst +(deftest subst.error.1 + (classify-error (subst)) + program-error) + +(deftest subst.error.2 + (classify-error (subst 'a)) + program-error) + +(deftest subst.error.3 + (classify-error (subst 'a 'b)) + program-error) + +(deftest subst.error.4 + (classify-error (subst 'a 'b nil :foo nil)) + program-error) + +(deftest subst.error.5 + (classify-error (subst 'a 'b nil :test)) + program-error) + +(deftest subst.error.6 + (classify-error (subst 'a 'b nil 1)) + program-error) + +(deftest subst.error.7 + (classify-error (subst 'a 'b nil :bad t :allow-other-keys nil)) + program-error) + +(deftest subst.error.8 + (classify-error (subst 'a 'b (list 'a 'b) :test #'identity)) + program-error) + +(deftest subst.error.9 + (classify-error (subst 'a 'b (list 'a 'b) :test-not #'identity)) + program-error) + +(deftest subst.error.10 + (classify-error (subst 'a 'b (list 'a 'b) :key #'equal)) + program-error) + +;;; nsubst +(deftest nsubst.error.1 + (classify-error (nsubst)) + program-error) + +(deftest nsubst.error.2 + (classify-error (nsubst 'a)) + program-error) + +(deftest nsubst.error.3 + (classify-error (nsubst 'a 'b)) + program-error) + +(deftest nsubst.error.4 + (classify-error (nsubst 'a 'b nil :foo nil)) + program-error) + +(deftest nsubst.error.5 + (classify-error (nsubst 'a 'b nil :test)) + program-error) + +(deftest nsubst.error.6 + (classify-error (nsubst 'a 'b nil 1)) + program-error) + +(deftest nsubst.error.7 + (classify-error (nsubst 'a 'b nil :bad t :allow-other-keys nil)) + program-error) + +(deftest nsubst.error.8 + (classify-error (nsubst 'a 'b (list 'a 'b) :test #'identity)) + program-error) + +(deftest nsubst.error.9 + (classify-error (nsubst 'a 'b (list 'a 'b) :test-not #'identity)) + program-error) + +(deftest nsubst.error.10 + (classify-error (nsubst 'a 'b (list 'a 'b) :key #'equal)) + program-error) + +;;; subst-if +(deftest subst-if.error.1 + (classify-error (subst-if)) + program-error) + +(deftest subst-if.error.2 + (classify-error (subst-if 'a)) + program-error) + +(deftest subst-if.error.3 + (classify-error (subst-if 'a #'null)) + program-error) + +(deftest subst-if.error.4 + (classify-error (subst-if 'a #'null nil :foo nil)) + program-error) + +(deftest subst-if.error.5 + (classify-error (subst-if 'a #'null nil :test)) + program-error) + +(deftest subst-if.error.6 + (classify-error (subst-if 'a #'null nil 1)) + program-error) + +(deftest subst-if.error.7 + (classify-error (subst-if 'a #'null nil :bad t :allow-other-keys nil)) + program-error) + +(deftest subst-if.error.8 + (classify-error (subst-if 'a #'null (list 'a nil 'c) :key #'cons)) + program-error) + +;;; subst-if-not +(deftest subst-if-not.error.1 + (classify-error (subst-if-not)) + program-error) + +(deftest subst-if-not.error.2 + (classify-error (subst-if-not 'a)) + program-error) + +(deftest subst-if-not.error.3 + (classify-error (subst-if-not 'a #'null)) + program-error) + +(deftest subst-if-not.error.4 + (classify-error (subst-if-not 'a #'null nil :foo nil)) + program-error) + +(deftest subst-if-not.error.5 + (classify-error (subst-if-not 'a #'null nil :test)) + program-error) + +(deftest subst-if-not.error.6 + (classify-error (subst-if-not 'a #'null nil 1)) + program-error) + +(deftest subst-if-not.error.7 + (classify-error (subst-if-not 'a #'null nil + :bad t :allow-other-keys nil)) + program-error) + +(deftest subst-if-not.error.8 + (classify-error (subst-if-not 'a #'null (list 'a nil 'c) :key #'cons)) + program-error) + +;;; nsubst-if +(deftest nsubst-if.error.1 + (classify-error (nsubst-if)) + program-error) + +(deftest nsubst-if.error.2 + (classify-error (nsubst-if 'a)) + program-error) + +(deftest nsubst-if.error.3 + (classify-error (nsubst-if 'a #'null)) + program-error) + +(deftest nsubst-if.error.4 + (classify-error (nsubst-if 'a #'null nil :foo nil)) + program-error) + +(deftest nsubst-if.error.5 + (classify-error (nsubst-if 'a #'null nil :test)) + program-error) + +(deftest nsubst-if.error.6 + (classify-error (nsubst-if 'a #'null nil 1)) + program-error) + +(deftest nsubst-if.error.7 + (classify-error (nsubst-if 'a #'null nil :bad t :allow-other-keys nil)) + program-error) + +(deftest nsubst-if.error.8 + (classify-error (nsubst-if 'a #'null (list 'a nil 'c) :key #'cons)) + program-error) + + +;;; nsubst-if-not +(deftest nsubst-if-not.error.1 + (classify-error (nsubst-if-not)) + program-error) + +(deftest nsubst-if-not.error.2 + (classify-error (nsubst-if-not 'a)) + program-error) + +(deftest nsubst-if-not.error.3 + (classify-error (nsubst-if-not 'a #'null)) + program-error) + +(deftest nsubst-if-not.error.4 + (classify-error (nsubst-if-not 'a #'null nil :foo nil)) + program-error) + +(deftest nsubst-if-not.error.5 + (classify-error (nsubst-if-not 'a #'null nil :test)) + program-error) + +(deftest nsubst-if-not.error.6 + (classify-error (nsubst-if-not 'a #'null nil 1)) + program-error) + +(deftest nsubst-if-not.error.7 + (classify-error (nsubst-if-not 'a #'null nil + :bad t :allow-other-keys nil)) + program-error) + +(deftest nsubst-if-not.error.8 + (classify-error (nsubst-if-not 'a #'null (list 'a nil 'c) :key #'cons)) + program-error) + diff --git a/ansi-tests/cons-test-03.lsp b/ansi-tests/cons-test-03.lsp new file mode 100644 index 0000000..43ddb61 --- /dev/null +++ b/ansi-tests/cons-test-03.lsp @@ -0,0 +1,325 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 07:32:20 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 3 + +(in-package :cl-test) + +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; copy-list + +(deftest copy-list.1 + (check-copy-list '(a b c d)) + (a b c d)) + +;; Check that copy-list works on dotted lists + +(deftest copy-list.2 + (check-copy-list '(a . b)) + (a . b)) + +(deftest copy-list.3 + (check-copy-list '(a b c . d)) + (a b c . d)) + +(deftest copy-list.4 + (let ((i 0)) + (values (copy-list (progn (incf i) '(a b c))) + i)) + (a b c) 1) + +(deftest copy-list.error.1 + (classify-error (copy-list)) + program-error) + +(deftest copy-list.error.2 + (classify-error (copy-list nil nil)) + program-error) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; list, list* + +(deftest list.1 + (list 'a 'b 'c) + (a b c)) + +(deftest list.2 + (list) + nil) + +(deftest list.order.1 + (let ((i 0)) + (list (incf i) (incf i) (incf i) (incf i))) + (1 2 3 4)) + +(deftest list.order.2 + (let ((i 0)) + (list (incf i) (incf i) (incf i) (incf i) + (incf i) (incf i) (incf i) (incf i))) + (1 2 3 4 5 6 7 8)) + +(deftest list.order.3 + (let ((i 0)) + (list (incf i) (incf i) (incf i) (incf i) + (incf i) (incf i) (incf i) (incf i) + (incf i) (incf i) (incf i) (incf i) + (incf i) (incf i) (incf i) (incf i))) + (1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16)) + +(deftest list*.1 + (list* 1 2 3) + (1 2 . 3)) + +(deftest list*.2 + (list* 'a) + a) + +(deftest list-list*.1 + (list* 'a 'b 'c (list 'd 'e 'f)) + (a b c d e f)) + +(deftest list*.3 + (list* 1) + 1) + +(deftest list*.order.1 + (let ((i 0)) + (list* (incf i) (incf i) (incf i) (incf i))) + (1 2 3 . 4)) + +(deftest list*.order.2 + (let ((i 0)) + (list* (incf i) (incf i) (incf i) (incf i) + (incf i) (incf i) (incf i) (incf i) + (incf i) (incf i) (incf i) (incf i) + (incf i) (incf i) (incf i) (incf i))) + (1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 . 16)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; list-length + +(deftest list-length-nil + (list-length nil) + 0) + +(deftest list-length-list + (list-length '(a b c d e f)) + 6) + +;; check that list-length returns nil +;; on a circular list + +(deftest list-length-circular-list + (let ((x (cons nil nil))) + (let ((y (list* 1 2 3 4 5 6 7 8 9 x))) + (setf (cdr x) y) + (let ((z (list* 'a 'b 'c 'd 'e y))) + (list-length z)))) + nil) + +(deftest list-length.order.1 + (let ((i 0)) + (values (list-length (progn (incf i) '(a b c))) i)) + 3 1) + + +;; Check that list-length produces a type-error +;; on arguments that are not proper lists or circular lists + +(deftest list-length.error.1 + (loop + for x in (list 'a 1 1.0 #\w (make-array '(10)) + '(a b . c) (symbol-package 'cons)) + count (not (eqt (catch-type-error (list-length x)) + 'type-error))) + 0) + +(deftest list-length.error.2 + (classify-error (list-length)) + program-error) + +(deftest list-length.error.3 + (classify-error (list-length nil nil)) + program-error) + +(deftest list-length.error.4 + (classify-error (list-length 'a)) + type-error) + +(deftest list-length.error.5 + (classify-error (locally (list-length 'a) t)) + type-error) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; listp + +;; Check listp against various simple cases + +(deftest listp-nil + (notnot-mv (listp nil)) + t) + +(deftest listp-symbol + (listp 'a) + nil) + +(deftest listp-singleton-list + (notnot-mv (listp '(a))) + t) + +(deftest listp-circular-list + (let ((x (cons nil nil))) + (setf (cdr x) x) + (notnot-mv (listp x))) + t) + +(deftest listp-longer-list + (notnot-mv (listp '(a b c d e f g h))) + t) + +;;; Check that (listp x) == (typep x 'list) + +(deftest listp-universe + (check-type-predicate 'listp 'list) + 0) + +(deftest listp.order.1 + (let ((i 0)) + (values (listp (incf i)) i)) + nil 1) + +(deftest listp.error.1 + (classify-error (listp)) + program-error) + +(deftest listp.error.2 + (classify-error (listp nil nil)) + program-error) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; (typep 'list) + +;;; These tests are now somewhat redundant + +(deftest typep-nil-list + (notnot-mv (typep nil 'list)) + t) + +(deftest typep-symbol-list + (typep 'a 'list) + nil) + +(deftest typep-singleton-list-list + (notnot-mv (typep '(a) 'list)) + t) + +(deftest typep-circular-list-list + (let ((x (cons nil nil))) + (setf (cdr x) x) + (notnot-mv (typep x 'list))) + t) + +(deftest typep-longer-list-list + (notnot-mv (typep '(a b c d e f g h) 'list)) + t) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; make-list + +(deftest make-list-empty.1 + (make-list 0) + nil) + +(deftest make-list-empty.2 + (make-list 0 :initial-element 'a) + nil) + +(deftest make-list-no-initial-element + (make-list 6) + (nil nil nil nil nil nil)) + +(deftest make-list-with-initial-element + (make-list 6 :initial-element 'a) + (a a a a a a)) + +(deftest make-list.allow-other-keys.1 + (make-list 5 :allow-other-keys t :foo 'a) + (nil nil nil nil nil)) + +(deftest make-list.allow-other-keys.2 + (make-list 5 :bar nil :allow-other-keys t) + (nil nil nil nil nil)) + +(deftest make-list.allow-other-keys.3 + (make-list 5 :allow-other-keys nil) + (nil nil nil nil nil)) + +(deftest make-list.allow-other-keys.4 + (make-list 5 :allow-other-keys t :allow-other-keys nil 'bad t) + (nil nil nil nil nil)) + +(deftest make-list.allow-other-keys.5 + (make-list 5 :allow-other-keys t) + (nil nil nil nil nil)) + +(deftest make-list-repeated-keyword + (make-list 5 :initial-element 'a :initial-element 'b) + (a a a a a)) + +(deftest make-list.order.1 + (let ((i 0) x y) + (values + (make-list (progn (setf x (incf i)) 5) + :initial-element + (progn (setf y (incf i)) 'a)) + i x y)) + (a a a a a) + 2 1 2) + +(deftest make-list.order.2 + (let ((i 0) x y z) + (values + (make-list (progn (setf x (incf i)) 5) + :initial-element + (progn (setf y (incf i)) 'a) + :initial-element + (progn (setf z (incf i)) 'b)) + i x y z)) + (a a a a a) + 3 1 2 3) + + +(deftest make-list.error.1 + (catch-type-error (make-list -1)) + type-error) + +(deftest make-list.error.2 + (classify-error (make-list 'a)) + type-error) + +(deftest make-list.error.3 + (classify-error (make-list)) + program-error) + +(deftest make-list.error.4 + (classify-error (make-list 5 :bad t)) + program-error) + +(deftest make-list.error.5 + (classify-error (make-list 5 :initial-element)) + program-error) + +(deftest make-list.error.6 + (classify-error (make-list 5 1 2)) + program-error) + +(deftest make-list.error.7 + (classify-error (make-list 5 :bad t :allow-other-keys nil)) + program-error) + +(deftest make-list.error.8 + (classify-error (locally (make-list 'a) t)) + type-error) diff --git a/ansi-tests/cons-test-04.lsp b/ansi-tests/cons-test-04.lsp new file mode 100644 index 0000000..0053f0d --- /dev/null +++ b/ansi-tests/cons-test-04.lsp @@ -0,0 +1,412 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 07:33:20 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 4 + +(in-package :cl-test) + +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; push +;;; There will be a separate test suite +;;; for ACCESSORS x SETF-like macros + +;;; See also places.lsp + +(deftest push.1 + (let ((x nil)) + (push 'a x)) + (a)) + +(deftest push.2 + (let ((x 'b)) + (push 'a x) + (push 'c x)) + (c a . b)) + +(deftest push.3 + (let ((x (copy-tree '(a)))) + (push x x) + (and + (eqt (car x) (cdr x)) + x)) + ((a) a)) + +(deftest push.order.1 + (let ((x (list nil)) (i 0) a b) + (values + (push (progn (setf a (incf i)) 'z) + (car (progn (setf b (incf i)) x))) + x + i a b)) + (z) ((z)) 2 1 2) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; pop + +(deftest pop.1 + (let ((x (copy-tree '(a b c)))) + (let ((y (pop x))) + (list x y))) + ((b c) a)) + +(deftest pop.2 + (let ((x nil)) + (let ((y (pop x))) + (list x y))) + (nil nil)) + +;;; Confirm argument is executed just once. +(deftest pop.order.1 + (let ((i 0) + (a (vector (list 'a 'b 'c)))) + (pop (aref a (progn (incf i) 0))) + (values a i)) + #((b c)) 1) + +(deftest push-and-pop + (let* ((x (copy-tree '(a b))) + (y x)) + (push 'c x) + (and + (eqt (cdr x) y) + (pop x))) + c) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; pushnew + +;;; See also places.lsp + +(deftest pushnew.1 + (let ((x nil)) + (let ((y (pushnew 'a x))) + (and + (eqt x y) + (equal x '(a)) + t))) + t) + +(deftest pushnew.2 + (let* ((x (copy-tree '(b c d a k f q))) + (y (pushnew 'a x))) + (and + (eqt x y) + x)) + (b c d a k f q)) + +(deftest pushnew.3 + (let* ((x (copy-tree '(1 2 3 4 5 6 7 8))) + (y (pushnew 7 x))) + (and + (eqt x y) + x)) + (1 2 3 4 5 6 7 8)) + +(deftest pushnew.4 + (let* ((x (copy-tree '((a b) 1 "and" c d e))) + (y (pushnew (copy-tree '(c d)) x + :test 'equal))) + (and (eqt x y) + x)) + ((c d) (a b) 1 "and" c d e)) + +(deftest pushnew.5 + (let* ((x (copy-tree '((a b) 1 "and" c d e))) + (y (pushnew (copy-tree '(a b)) x + :test 'equal))) + (and + (eqt x y) + x)) + ((a b) 1 "and" c d e)) + +(deftest pushnew.6 + (let* ((x (copy-tree '((a b) (c e) (d f) (g h)))) + (y (pushnew (copy-tree '(d i)) x :key #'car)) + (z (pushnew (copy-tree '(z 10)) x :key #'car))) + (and (eqt y (cdr z)) + (eqt z x) + x)) + ((z 10) (a b) (c e) (d f) (g h))) + +(deftest pushnew.7 + (let* ((x (copy-tree '(("abc" 1) ("def" 2) ("ghi" 3)))) + (y (pushnew (copy-tree '("def" 4)) x + :key #'car :test #'string=)) + (z (pushnew (copy-tree '("xyz" 10)) + x + :key #'car :test #'string=))) + (and + (eqt y (cdr x)) + (eqt x z) + x)) + (("xyz" 10) ("abc" 1) ("def" 2) ("ghi" 3))) + +(deftest pushnew.8 + (let* ((x (copy-tree '(("abc" 1) ("def" 2) ("ghi" 3)))) + (y (pushnew (copy-tree '("def" 4)) x + :key #'car :test-not (complement #'string=))) + (z (pushnew (copy-tree '("xyz" 10)) x + :key #'car :test-not (complement #'string=)))) + (and + (eqt y (cdr x)) + (eqt x z) + x)) + (("xyz" 10) ("abc" 1) ("def" 2) ("ghi" 3))) + +(deftest pushnew.9 + (let* ((x (copy-tree '(("abc" 1) ("def" 2) ("ghi" 3)))) + (y (pushnew (copy-tree '("def" 4)) x + :key 'car :test-not (complement #'string=))) + (z (pushnew (copy-tree '("xyz" 10)) x + :key 'car :test-not (complement #'string=)))) + (and + (eqt y (cdr x)) + (eqt x z) + x)) + (("xyz" 10) ("abc" 1) ("def" 2) ("ghi" 3))) + +;; Check that a NIL :key argument is the same as no key argument at all +(deftest pushnew.10 + (let* ((x (list 'a 'b 'c 'd)) + (result (pushnew 'z x :key nil))) + result) + (z a b c d)) + +;; Check that a NIL :key argument is the same as no key argument at all +(deftest pushnew.11 + (let* ((x (copy-tree '((a b) 1 "and" c d e))) + (y (pushnew (copy-tree '(a b)) x + :test 'equal :key nil))) + (and + (eqt x y) + x)) + ((a b) 1 "and" c d e)) + +(deftest pushnew.12 + (let ((i 0) x y z (d '(b c))) + (values + (pushnew (progn (setf x (incf i)) 'a) + d + :key (progn (setf y (incf i)) #'identity) + :test (progn (setf z (incf i)) #'eql)) + d i x y z)) + (a b c) (a b c) + 3 1 2 3) + +(deftest pushnew.13 + (let ((i 0) x y z (d '(b c))) + (values + (pushnew (progn (setf x (incf i)) 'a) + d + :key (progn (setf y (incf i)) #'identity) + :test-not (progn (setf z (incf i)) (complement #'eql))) + d i x y z)) + (a b c) (a b c) + 3 1 2 3) + +(deftest pushnew.14 + (let ((i 0) x y z (d '(b c))) + (values + (pushnew (progn (setf x (incf i)) 'a) + d + :test (progn (setf z (incf i)) #'eql) + :key (progn (setf y (incf i)) #'identity)) + d i x y z)) + (a b c) (a b c) + 3 1 3 2) + +(deftest pushnew.15 + (let ((i 0) x y z (d '(b c))) + (values + (pushnew (progn (setf x (incf i)) 'a) + d + :test-not (progn (setf z (incf i)) (complement #'eql)) + :key (progn (setf y (incf i)) #'identity)) + d i x y z)) + (a b c) (a b c) + 3 1 3 2) + +(deftest pushnew.error.1 + (classify-error + (let ((x '(a b))) + (pushnew 'c x :test #'identity))) + program-error) + +(deftest pushnew.error.2 + (classify-error + (let ((x '(a b))) + (pushnew 'c x :test-not #'identity))) + program-error) + +(deftest pushnew.error.3 + (classify-error + (let ((x '(a b))) + (pushnew 'c x :key #'cons))) + program-error) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; adjoin + +(deftest adjoin.1 + (adjoin 'a nil) + (a)) + +(deftest adjoin.2 + (adjoin nil nil) + (nil)) + +(deftest adjoin.3 + (adjoin 'a '(a)) + (a)) + +;; Check that a NIL :key argument is the same as no key argument at all +(deftest adjoin.4 + (adjoin 'a '(a) :key nil) + (a)) + +(deftest adjoin.5 + (adjoin 'a '(a) :key #'identity) + (a)) + +(deftest adjoin.6 + (adjoin 'a '(a) :key 'identity) + (a)) + +(deftest adjoin.7 + (adjoin (1+ 11) '(4 3 12 2 1)) + (4 3 12 2 1)) + +;; Check that the test is EQL, not EQ (by adjoining a bignum) +(deftest adjoin.8 + (adjoin (1+ 999999999999) '(4 1 1000000000000 3816734 a "aa")) + (4 1 1000000000000 3816734 a "aa")) + +(deftest adjoin.9 + (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a)) + ("aaa" aaa "AAA" "aaa" #\a)) + +(deftest adjoin.10 + (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) :test #'equal) + (aaa "AAA" "aaa" #\a)) + +(deftest adjoin.11 + (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) :test 'equal) + (aaa "AAA" "aaa" #\a)) + +(deftest adjoin.12 + (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) + :test-not (complement #'equal)) + (aaa "AAA" "aaa" #\a)) + +(deftest adjoin.14 + (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) + :test #'equal :key #'identity) + (aaa "AAA" "aaa" #\a)) + +(deftest adjoin.15 + (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) + :test 'equal :key #'identity) + (aaa "AAA" "aaa" #\a)) + +;; Test that a :key of NIL is the same as no key at all +(deftest adjoin.16 + (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) + :test #'equal :key nil) + (aaa "AAA" "aaa" #\a)) + +;; Test that a :key of NIL is the same as no key at all +(deftest adjoin.17 + (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) + :test 'equal :key nil) + (aaa "AAA" "aaa" #\a)) + +;; Test that a :key of NIL is the same as no key at all +(deftest adjoin.18 + (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) + :test-not (complement #'equal) :key nil) + (aaa "AAA" "aaa" #\a)) + +(deftest adjoin.order.1 + (let ((i 0) w x y z) + (values + (adjoin (progn (setf w (incf i)) 'a) + (progn (setf x (incf i)) '(b c d a e)) + :key (progn (setf y (incf i)) #'identity) + :test (progn (setf z (incf i)) #'eql)) + i w x y z)) + (b c d a e) + 4 1 2 3 4) + +(deftest adjoin.order.2 + (let ((i 0) w x y z p) + (values + (adjoin (progn (setf w (incf i)) 'a) + (progn (setf x (incf i)) '(b c d e)) + :test-not (progn (setf y (incf i)) (complement #'eql)) + :key (progn (setf z (incf i)) #'identity) + :key (progn (setf p (incf i)) nil)) + i w x y z p)) + (a b c d e) + 5 1 2 3 4 5) + +(deftest adjoin.allow-other-keys.1 + (adjoin 'a '(b c) :bad t :allow-other-keys t) + (a b c)) + +(deftest adjoin.allow-other-keys.2 + (adjoin 'a '(b c) :allow-other-keys t :foo t) + (a b c)) + +(deftest adjoin.allow-other-keys.3 + (adjoin 'a '(b c) :allow-other-keys t) + (a b c)) + +(deftest adjoin.allow-other-keys.4 + (adjoin 'a '(b c) :allow-other-keys nil) + (a b c)) + +(deftest adjoin.allow-other-keys.5 + (adjoin 'a '(b c) :allow-other-keys t :allow-other-keys nil 'bad t) + (a b c)) + +(deftest adjoin.repeat-key + (adjoin 'a '(b c) :test #'eq :test (complement #'eq)) + (a b c)) + +(deftest adjoin.error.1 + (classify-error (adjoin)) + program-error) + +(deftest adjoin.error.2 + (classify-error (adjoin 'a)) + program-error) + +(deftest adjoin.error.3 + (classify-error (adjoin 'a '(b c) :bad t)) + program-error) + +(deftest adjoin.error.4 + (classify-error (adjoin 'a '(b c) :allow-other-keys nil :bad t)) + program-error) + +(deftest adjoin.error.5 + (classify-error (adjoin 'a '(b c) 1 2)) + program-error) + +(deftest adjoin.error.6 + (classify-error (adjoin 'a '(b c) :test)) + program-error) + +(deftest adjoin.error.7 + (classify-error (adjoin 'a '(b c) :test #'identity)) + program-error) + +(deftest adjoin.error.8 + (classify-error (adjoin 'a '(b c) :test-not #'identity)) + program-error) + +(deftest adjoin.error.9 + (classify-error (adjoin 'a '(b c) :key #'cons)) + program-error) diff --git a/ansi-tests/cons-test-05.lsp b/ansi-tests/cons-test-05.lsp new file mode 100644 index 0000000..100c1ed --- /dev/null +++ b/ansi-tests/cons-test-05.lsp @@ -0,0 +1,192 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 07:34:08 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 5 + +(in-package :cl-test) + +(declaim (optimize (safety 3))) + +(defparameter *cons-accessors* + '(first second third fourth fifth sixth seventh eighth ninth tenth + car cdr caar cadr cdar cddr + caaar caadr cadar caddr cdaar cdadr cddar cdddr + caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr + cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; first, ..., tenth + +(deftest first-etc-1 + (let ((x (loop for i from 1 to 20 collect i))) + (list (first x) + (second x) + (third x) + (fourth x) + (fifth x) + (sixth x) + (seventh x) + (eighth x) + (ninth x) + (tenth x))) + (1 2 3 4 5 6 7 8 9 10)) + +(deftest first-etc-2 + (let ((x (make-list 15 :initial-element 'a))) + (and + (eql (setf (first x) 1) 1) + (eql (setf (second x) 2) 2) + (eql (setf (third x) 3) 3) + (eql (setf (fourth x) 4) 4) + (eql (setf (fifth x) 5) 5) + (eql (setf (sixth x) 6) 6) + (eql (setf (seventh x) 7) 7) + (eql (setf (eighth x) 8) 8) + (eql (setf (ninth x) 9) 9) + (eql (setf (tenth x) 10) 10) + x)) + (1 2 3 4 5 6 7 8 9 10 a a a a a)) + +(deftest rest-set-1 + (let ((x (list 'a 'b 'c))) + (and + (eqt (setf (rest x) 'd) 'd) + x)) + (a . d)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; setting of C*R accessors + +(loop + for fn in '(car cdr caar cadr cdar cddr + caaar caadr cadar caddr cdaar cdadr cddar cdddr + caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr + cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr) + do + (let ((level (- (length (symbol-name fn)) 2))) + (eval `(deftest ,(intern + (concatenate 'string + (symbol-name fn) + "-SET") + :cl-test) + (let ((x (create-c*r-test ,level)) + (y (list (create-c*r-test ,level))) + (i 0)) + (and + (setf (,fn (progn (incf i) x)) 'a) + (eqlt (,fn x) 'a) + (eqlt i 1) + (setf (,fn x) 'none) + (equalt x (create-c*r-test ,level)) + (setf (,fn (progn (incf i) (car y))) 'a) + (eqlt (,fn (car y)) 'a) + (eqlt i 2) + (setf (,fn (car y)) 'none) + (null (cdr y)) + (equalt (car y) (create-c*r-test ,level)) + )) + t)))) + +(loop + for (fn len) in '((first 1) (second 2) (third 3) (fourth 4) + (fifth 5) (sixth 6) (seventh 7) (eighth 8) + (ninth 9) (tenth 10)) + do + (eval + `(deftest ,(intern + (concatenate 'string + (symbol-name fn) + "-SET") + :cl-test) + (let* ((x (make-list 20 :initial-element nil)) + (y (list (copy-list x))) + (cnt 0)) + (and + (setf (,fn (progn (incf cnt) x)) 'a) + (eqlt cnt 1) + (loop + for i from 1 to 20 + do (when (and (not (eql i ,len)) + (nth (1- i) x)) + (return nil)) + finally (return t)) + (setf (,fn (car y)) 'a) + (loop + for i from 1 to 20 + do (when (and (not (eql i ,len)) + (nth (1- i) (car y))) + (return nil)) + finally (return t)) + (eqlt (,fn x) 'a) + (eqlt (nth ,(1- len) x) 'a) + (eqlt (,fn (car y)) 'a) + (nth ,(1- len) (car y)))) + a))) + +;; set up program error tests + +(loop for name in *cons-accessors* + do (eval + `(deftest ,(intern (concatenate 'string (symbol-name name) + ".ERROR.NO-ARGS") + :cl-test) + (classify-error (,name)) + program-error)) + do (eval + `(deftest ,(intern (concatenate 'string (symbol-name name) + ".ERROR.EXCESS-ARGS") + :cl-test) + (classify-error (,name nil nil)) + program-error))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; nth + +(deftest nth.1 + (nth-1-body (loop for i from 1 to 2000 collect (* 4 i))) + 0) + +(deftest nth.2 + (let ((x (loop for i from 1 to 2000 collect i))) + (loop + for i from 0 to 1999 do + (setf (nth i x) (- 1999 i))) + (equalt x (loop for i from 1999 downto 0 collect i))) + t) + +;;; Test side effects, evaluation order in assignment to NTH +(deftest nth.order.1 + (let ((i 0) + (x (list 'a 'b 'c 'd)) + y z) + (and + (eqlt (setf (nth (setf y (incf i)) x) (progn (setf z (incf i)) 'z)) + 'z) + (eqlt y 1) + (eqlt z 2) + x)) + (a z c d)) + +(deftest nth.order.2 + (let ((i 0) x y (z '(a b c d e))) + (values + (nth (progn (setf x (incf i)) 1) + (progn (setf y (incf i)) z)) + i x y)) + b 2 1 2) + +(deftest nth.error.1 + (classify-error (nth)) + program-error) + +(deftest nth.error.2 + (classify-error (nth 0)) + program-error) + +(deftest nth.error.3 + (classify-error (nth 1 '(a b c) nil)) + program-error) + +(deftest nth.error.4 + (classify-error (nth 0 '(a b c) nil)) + program-error) diff --git a/ansi-tests/cons-test-06.lsp b/ansi-tests/cons-test-06.lsp new file mode 100644 index 0000000..211003f --- /dev/null +++ b/ansi-tests/cons-test-06.lsp @@ -0,0 +1,54 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 07:34:40 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 6 + +(in-package :cl-test) + +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; endp + +(deftest endp-nil + (notnot-mv (endp nil)) + t) + +(deftest endp-cons + (endp (cons 'a 'a)) + nil) + +(deftest endp-singleton-list + (endp '(a)) + nil) + +(deftest endp.order.1 + (let ((i 0)) + (values + (endp (progn (incf i) '(a b c))) + i)) + nil 1) + +(deftest endp-symbol-error + (catch-type-error (endp 'a)) + type-error) + +(deftest endp-fixnum-error + (catch-type-error (endp 1)) + type-error) + +(deftest endp-float-error + (catch-type-error (endp 0.9212d4)) + type-error) + +(deftest endp.error.4 + (classify-error (endp)) + program-error) + +(deftest endp.error.5 + (classify-error (endp nil nil)) + program-error) + +(deftest endp.error.6 + (catch-type-error (locally (endp 1))) + type-error) diff --git a/ansi-tests/cons-test-07.lsp b/ansi-tests/cons-test-07.lsp new file mode 100644 index 0000000..445d0e8 --- /dev/null +++ b/ansi-tests/cons-test-07.lsp @@ -0,0 +1,211 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 07:35:15 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 7 + +(in-package :cl-test) + +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; nconc + +(deftest nconc.1 + (nconc) + nil) + +(deftest nconc.2 + (nconc (copy-tree '(a b c d e f))) + (a b c d e f)) + +(deftest nconc.3 + (nconc 1) + 1) + +(deftest nconc.4 + (let ((x (list 'a 'b 'c)) + (y (list 'd 'e 'f))) + (let ((ycopy (make-scaffold-copy y))) + (let ((result (nconc x y))) + (and + (check-scaffold-copy y ycopy) + (eqt (cdddr x) y) + result)))) + (a b c d e f)) + +(deftest nconc.5 + (let ((x (list 'a 'b 'c))) + (nconc x x) + (and + (eqt (cdddr x) x) + (null (list-length x)))) + t) + +(deftest nconc.6 + (let ((x (list 'a 'b 'c)) + (y (list 'd 'e 'f 'g 'h)) + (z (list 'i 'j 'k))) + (let ((result (nconc x y z 'foo))) + (and + (eqt (nthcdr 3 x) y) + (eqt (nthcdr 5 y) z) + (eqt (nthcdr 3 z) 'foo) + result))) + (a b c d e f g h i j k . foo)) + +(deftest nconc.7 + (nconc (copy-tree '(a . b)) + (copy-tree '(c . d)) + (copy-tree '(e . f)) + 'foo) + (a c e . foo)) + +(deftest nconc.order.1 + (let ((i 0) x y z) + (values + (nconc (progn (setf x (incf i)) (copy-list '(a b c))) + (progn (setf y (incf i)) (copy-list '(d e f))) + (progn (setf z (incf i)) (copy-list '(g h i)))) + i x y z)) + (a b c d e f g h i) 3 1 2 3) + +(deftest nconc.order.2 + (let ((i 0)) + (values + (nconc (incf i)) + i)) + 1 1) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; append + +(deftest append.1 + (append) + nil) + +(deftest append.2 + (append 'x) + x) + +(deftest append.3 + (let ((x (list 'a 'b 'c 'd)) + (y (list 'e 'f 'g))) + (let ((xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y))) + (let ((result (append x y))) + (and + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + result)))) + (a b c d e f g)) + +(deftest append.4 + (append (list 'a) (list 'b) (list 'c) + (list 'd) (list 'e) (list 'f) + (list 'g) 'h) + (a b c d e f g . h)) + +(deftest append.5 + (append nil nil nil nil nil nil nil nil 'a) + a) + +(deftest append.6 + (append-6-body) + 0) + +(deftest append.order.1 + (let ((i 0) x y z) + (values + (append (progn (setf x (incf i)) (copy-list '(a b c))) + (progn (setf y (incf i)) (copy-list '(d e f))) + (progn (setf z (incf i)) (copy-list '(g h i)))) + i x y z)) + (a b c d e f g h i) 3 1 2 3) + +(deftest append.order.2 + (let ((i 0)) (values (append (incf i)) i)) + 1 1) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; revappend + +(deftest revappend.1 + (let* ((x (list 'a 'b 'c)) + (y (list 'd 'e 'f)) + (xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y)) + ) + (let ((result (revappend x y))) + (and + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + (eqt (cdddr result) y) + result))) + (c b a d e f)) + +(deftest revappend.2 + (revappend (copy-tree '(a b c d e)) 10) + (e d c b a . 10)) + +(deftest revappend.3 + (revappend nil 'a) + a) + +(deftest revappend.4 + (revappend (copy-tree '(a (b c) d)) nil) + (d (b c) a)) + +(deftest revappend.order.1 + (let ((i 0) x y) + (values + (revappend (progn (setf x (incf i)) (copy-list '(a b c))) + (progn (setf y (incf i)) (copy-list '(d e f)))) + i x y)) + (c b a d e f) 2 1 2) + +(deftest revappend.error.1 + (classify-error (revappend)) + program-error) + +(deftest revappend.error.2 + (classify-error (revappend nil)) + program-error) + +(deftest revappend.error.3 + (classify-error (revappend nil nil nil)) + program-error) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; nreconc + +(deftest nreconc.1 + (let* ((x (list 'a 'b 'c)) + (y (copy-tree '(d e f))) + (result (nreconc x y))) + (and (equal y '(d e f)) + result)) + (c b a d e f)) + +(deftest nreconc.2 + (nreconc nil 'a) + a) + +(deftest nreconc.order.1 + (let ((i 0) x y) + (values + (nreconc (progn (setf x (incf i)) (copy-list '(a b c))) + (progn (setf y (incf i)) (copy-list '(d e f)))) + i x y)) + (c b a d e f) 2 1 2) + +(deftest nreconc.error.1 + (classify-error (nreconc)) + program-error) + +(deftest nreconc.error.2 + (classify-error (nreconc nil)) + program-error) + +(deftest nreconc.error.3 + (classify-error (nreconc nil nil nil)) + program-error) diff --git a/ansi-tests/cons-test-08.lsp b/ansi-tests/cons-test-08.lsp new file mode 100644 index 0000000..6b1e3f0 --- /dev/null +++ b/ansi-tests/cons-test-08.lsp @@ -0,0 +1,455 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 07:36:01 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 8 + +(in-package :cl-test) + +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Error checking car, cdr, list-length + +(deftest car.1 + (car '(a)) + a) + +(deftest car-nil + (car nil) + nil) + +(deftest car-symbol-error + (classify-error (car 'a)) + type-error) + +(deftest car-symbol-error.2 + (classify-error (locally (car 'a) t)) + type-error) + +(deftest car.order.1 + (let ((i 0)) + (values (car (progn (incf i) '(a b))) i)) + a 1) + +(deftest cdr.1 + (cdr '(a b)) + (b)) + +(deftest cdr-nil + (cdr ()) + nil) + +(deftest cdr.order.1 + (let ((i 0)) + (values (cdr (progn (incf i) '(a b))) i)) + (b) 1) + +(deftest cdr-symbol-error + (classify-error (cdr 'a)) + type-error) + +(deftest cdr-symbol-error.2 + (classify-error (locally (cdr 'a) t)) + type-error) + +(deftest list-length.4 + (list-length (copy-tree '(a b c))) + 3) + +(deftest list-length-symbol + (classify-error (list-length 'a)) + type-error) + +(deftest list-length-dotted-list + (classify-error (list-length (copy-tree '(a b c d . e)))) + type-error) + +;;; Error checking of c*r functions + +(deftest caar.error.1 + (classify-error (caar 'a)) + type-error) + +(deftest caar.error.2 + (classify-error (caar '(a))) + type-error) + +(deftest cadr.error.1 + (classify-error (cadr 'a)) + type-error) + +(deftest cadr.error.2 + (classify-error (cadr '(a . b))) + type-error) + +(deftest cdar.error.1 + (classify-error (cdar 'a)) + type-error) + +(deftest cdar.error.2 + (classify-error (cdar '(a . b))) + type-error) + +(deftest cddr.error.1 + (classify-error (cddr 'a)) + type-error) + +(deftest cddr.error.2 + (classify-error (cddr '(a . b))) + type-error) + +(deftest caaar.error.1 + (classify-error (caaar 'a)) + type-error) + +(deftest caaar.error.2 + (classify-error (caaar '(a))) + type-error) + +(deftest caaar.error.3 + (classify-error (caaar '((a)))) + type-error) + +(deftest caadr.error.1 + (classify-error (caadr 'a)) + type-error) + +(deftest caadr.error.2 + (classify-error (caadr '(a . b))) + type-error) + +(deftest caadr.error.3 + (classify-error (caadr '(a . (b)))) + type-error) + +(deftest cadar.error.1 + (classify-error (cadar 'a)) + type-error) + +(deftest cadar.error.2 + (classify-error (cadar '(a . b))) + type-error) + +(deftest cadar.error.3 + (classify-error (cadar '((a . c) . b))) + type-error) + +(deftest caddr.error.1 + (classify-error (caddr 'a)) + type-error) + +(deftest caddr.error.2 + (classify-error (caddr '(a . b))) + type-error) + +(deftest caddr.error.3 + (classify-error (caddr '(a c . b))) + type-error) + +(deftest cdaar.error.1 + (classify-error (cdaar 'a)) + type-error) + +(deftest cdaar.error.2 + (classify-error (cdaar '(a))) + type-error) + +(deftest cdaar.error.3 + (classify-error (cdaar '((a . b)))) + type-error) + +(deftest cdadr.error.1 + (classify-error (cdadr 'a)) + type-error) + +(deftest cdadr.error.2 + (classify-error (cdadr '(a . b))) + type-error) + +(deftest cdadr.error.3 + (classify-error (cdadr '(a b . c))) + type-error) + +(deftest cddar.error.1 + (classify-error (cddar 'a)) + type-error) + +(deftest cddar.error.2 + (classify-error (cddar '(a . b))) + type-error) + +(deftest cddar.error.3 + (classify-error (cddar '((a . b) . b))) + type-error) + +(deftest cdddr.error.1 + (classify-error (cdddr 'a)) + type-error) + +(deftest cdddr.error.2 + (classify-error (cdddr '(a . b))) + type-error) + +(deftest cdddr.error.3 + (classify-error (cdddr '(a c . b))) + type-error) + +;; + +(deftest caaaar.error.1 + (classify-error (caaaar 'a)) + type-error) + +(deftest caaaar.error.2 + (classify-error (caaaar '(a))) + type-error) + +(deftest caaaar.error.3 + (classify-error (caaaar '((a)))) + type-error) + +(deftest caaaar.error.4 + (classify-error (caaaar '(((a))))) + type-error) + +(deftest caaadr.error.1 + (classify-error (caaadr 'a)) + type-error) + +(deftest caaadr.error.2 + (classify-error (caaadr '(a . b))) + type-error) + +(deftest caaadr.error.3 + (classify-error (caaadr '(a . (b)))) + type-error) + +(deftest caaadr.error.4 + (classify-error (caaadr '(a . ((b))))) + type-error) + +(deftest caadar.error.1 + (classify-error (caadar 'a)) + type-error) + +(deftest caadar.error.2 + (classify-error (caadar '(a . b))) + type-error) + +(deftest caadar.error.3 + (classify-error (caadar '((a . c) . b))) + type-error) + +(deftest caadar.error.4 + (classify-error (caadar '((a . (c)) . b))) + type-error) + +(deftest caaddr.error.1 + (classify-error (caaddr 'a)) + type-error) + +(deftest caaddr.error.2 + (classify-error (caaddr '(a . b))) + type-error) + +(deftest caaddr.error.3 + (classify-error (caaddr '(a c . b))) + type-error) + +(deftest caaddr.error.4 + (classify-error (caaddr '(a c . (b)))) + type-error) + +(deftest cadaar.error.1 + (classify-error (cadaar 'a)) + type-error) + +(deftest cadaar.error.2 + (classify-error (cadaar '(a))) + type-error) + +(deftest cadaar.error.3 + (classify-error (cadaar '((a . b)))) + type-error) + +(deftest cadaar.error.4 + (classify-error (cadaar '((a . (b))))) + type-error) + +(deftest cadadr.error.1 + (classify-error (cadadr 'a)) + type-error) + +(deftest cadadr.error.2 + (classify-error (cadadr '(a . b))) + type-error) + +(deftest cadadr.error.3 + (classify-error (cadadr '(a b . c))) + type-error) + +(deftest cadadr.error.4 + (classify-error (cadadr '(a (b . e) . c))) + type-error) + +(deftest caddar.error.1 + (classify-error (caddar 'a)) + type-error) + +(deftest caddar.error.2 + (classify-error (caddar '(a . b))) + type-error) + +(deftest caddar.error.3 + (classify-error (caddar '((a . b) . b))) + type-error) + +(deftest caddar.error.4 + (classify-error (caddar '((a b . c) . b))) + type-error) + +(deftest cadddr.error.1 + (classify-error (cadddr 'a)) + type-error) + +(deftest cadddr.error.2 + (classify-error (cadddr '(a . b))) + type-error) + +(deftest cadddr.error.3 + (classify-error (cadddr '(a c . b))) + type-error) + +(deftest cadddr.error.4 + (classify-error (cadddr '(a c e . b))) + type-error) + +(deftest cdaaar.error.1 + (classify-error (cdaaar 'a)) + type-error) + +(deftest cdaaar.error.2 + (classify-error (cdaaar '(a))) + type-error) + +(deftest cdaaar.error.3 + (classify-error (cdaaar '((a)))) + type-error) + +(deftest cdaaar.error.4 + (classify-error (cdaaar '(((a . b))))) + type-error) + +(deftest cdaadr.error.1 + (classify-error (cdaadr 'a)) + type-error) + +(deftest cdaadr.error.2 + (classify-error (cdaadr '(a . b))) + type-error) + +(deftest cdaadr.error.3 + (classify-error (cdaadr '(a . (b)))) + type-error) + +(deftest cdaadr.error.4 + (classify-error (cdaadr '(a . ((b . c))))) + type-error) + +(deftest cdadar.error.1 + (classify-error (cdadar 'a)) + type-error) + +(deftest cdadar.error.2 + (classify-error (cdadar '(a . b))) + type-error) + +(deftest cdadar.error.3 + (classify-error (cdadar '((a . c) . b))) + type-error) + +(deftest cdadar.error.4 + (classify-error (cdadar '((a . (c . d)) . b))) + type-error) + +(deftest cdaddr.error.1 + (classify-error (cdaddr 'a)) + type-error) + +(deftest cdaddr.error.2 + (classify-error (cdaddr '(a . b))) + type-error) + +(deftest cdaddr.error.3 + (classify-error (cdaddr '(a c . b))) + type-error) + +(deftest cdaddr.error.4 + (classify-error (cdaddr '(a c b . d))) + type-error) + +(deftest cddaar.error.1 + (classify-error (cddaar 'a)) + type-error) + +(deftest cddaar.error.2 + (classify-error (cddaar '(a))) + type-error) + +(deftest cddaar.error.3 + (classify-error (cddaar '((a . b)))) + type-error) + +(deftest cddaar.error.4 + (classify-error (cddaar '((a . (b))))) + type-error) + +(deftest cddadr.error.1 + (classify-error (cddadr 'a)) + type-error) + +(deftest cddadr.error.2 + (classify-error (cddadr '(a . b))) + type-error) + +(deftest cddadr.error.3 + (classify-error (cddadr '(a b . c))) + type-error) + +(deftest cddadr.error.4 + (classify-error (cddadr '(a (b . e) . c))) + type-error) + +(deftest cdddar.error.1 + (classify-error (cdddar 'a)) + type-error) + +(deftest cdddar.error.2 + (classify-error (cdddar '(a . b))) + type-error) + +(deftest cdddar.error.3 + (classify-error (cdddar '((a . b) . b))) + type-error) + +(deftest cdddar.error.4 + (classify-error (cdddar '((a b . c) . b))) + type-error) + +(deftest cddddr.error.1 + (classify-error (cddddr 'a)) + type-error) + +(deftest cddddr.error.2 + (classify-error (cddddr '(a . b))) + type-error) + +(deftest cddddr.error.3 + (classify-error (cddddr '(a c . b))) + type-error) + +(deftest cddddr.error.4 + (classify-error (cddddr '(a c e . b))) + type-error) + +;;; Need to add 'locally' wrapped forms of these diff --git a/ansi-tests/cons-test-09.lsp b/ansi-tests/cons-test-09.lsp new file mode 100644 index 0000000..baba347 --- /dev/null +++ b/ansi-tests/cons-test-09.lsp @@ -0,0 +1,186 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 07:36:30 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 9 + +(in-package :cl-test) + +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; butlast, nbutlast + +(deftest butlast.1 + (let ((x (list 'a 'b 'c 'd 'e))) + (let ((xcopy (make-scaffold-copy x))) + (let ((result (butlast x 2))) + (and + (check-scaffold-copy x xcopy) + result)))) + (a b c)) + +(deftest butlast.2 + (let ((x (list 'a 'b 'c 'd 'e))) + (let ((xcopy (make-scaffold-copy x))) + (let ((result (butlast x 0))) + (and + (check-scaffold-copy x xcopy) + result)))) + (a b c d e)) + +(deftest butlast.3 + (let ((x (list 'a 'b 'c 'd 'e))) + (let ((xcopy (make-scaffold-copy x))) + (let ((result (butlast x 5))) + (and + (check-scaffold-copy x xcopy) + result)))) + nil) + +(deftest butlast.4 + (let ((x (list 'a 'b 'c 'd 'e))) + (let ((xcopy (make-scaffold-copy x))) + (let ((result (butlast x 6))) + (and + (check-scaffold-copy x xcopy) + result)))) + nil) + +(deftest butlast.5 + (butlast (copy-tree '(a b c . d)) 1) + (a b)) + +(deftest butlast.order.1 + (let ((i 0) x y) + (values + (butlast (progn (setf x (incf i)) + (list 'a 'b 'c 'd 'e)) + (progn (setf y (incf i)) + 2)) + i x y)) + (a b c) 2 1 2) + +(deftest butlast.order.2 + (let ((i 0)) + (values + (butlast (progn (incf i) '(a b c d))) + i)) + (a b c) 1) + +(deftest butlast.error.1 + (classify-error (butlast (copy-tree '(a b c d)) 'a)) + type-error) + +(deftest butlast.error.2 + (classify-error (butlast 'a 0)) + type-error) + +(deftest butlast.error.3 + (classify-error (butlast)) + program-error) + +(deftest butlast.error.4 + (classify-error (butlast '(a b c) 3 3)) + program-error) + +(deftest butlast.error.5 + (classify-error (locally (butlast 'a 0) t)) + type-error) + + +;;; Tests of NBUTLAST + +(deftest nbutlast.1 + (let ((x (list 'a 'b 'c 'd 'e))) + (let ((y (cdr x)) + (z (cddr x))) + (let ((result (nbutlast x 2))) + (and (eqt x result) + (eqt (cdr x) y) + (eqt (cddr x) z) + result)))) + (a b c)) + +(deftest nbutlast.2 + (let ((x (list 'a 'b 'c 'd 'e))) + (let ((result (nbutlast x 5))) + (list x result))) + ((a b c d e) nil)) + +(deftest nbutlast.3 + (let ((x (list 'a 'b 'c 'd 'e))) + (let ((result (nbutlast x 500))) + (list x result))) + ((a b c d e) nil)) + +(deftest nbutlast.4 + (let ((x (list* 'a 'b 'c 'd))) + (let ((result (nbutlast x 1))) + (and (eqt result x) + result))) + (a b)) + +(deftest nbutlast.5 + (nbutlast nil) + nil) + +(deftest nbutlast.6 + (nbutlast (list 'a)) + nil) + +(deftest nbutlast.order.1 + (let ((i 0) x y) + (values + (nbutlast (progn (setf x (incf i)) + (list 'a 'b 'c 'd 'e)) + (progn (setf y (incf i)) + 2)) + i x y)) + (a b c) 2 1 2) + +(deftest nbutlast.order.2 + (let ((i 0)) + (values + (nbutlast (progn (incf i) (list 'a 'b 'c 'd))) + i)) + (a b c) 1) + +(deftest nbutlast.error.1 + (classify-error (let ((x (list* 'a 'b 'c 'd))) (nbutlast x 'a))) + type-error) + +(deftest nbutlast.error.2 + (classify-error (nbutlast 'a 10)) + type-error) + +(deftest nbutlast.error.3 + (classify-error (nbutlast 2 10)) + type-error) + +(deftest nbutlast.error.4 + (classify-error (nbutlast #\w 10)) + type-error) + +(deftest nbutlast.error.5 + (classify-error (nbutlast (list 'a 'b 'c 'd) -3)) + type-error) + +(deftest nbutlast.error.6 + (classify-error (nbutlast (list 'a) 20.0)) + type-error) + +(deftest nbutlast.error.7 + (classify-error (nbutlast (list 'a) -100.0)) + type-error) + +(deftest nbutlast.error.8 + (classify-error (nbutlast)) + program-error) + +(deftest nbutlast.error.9 + (classify-error (nbutlast (list 'a 'b 'c) 3 3)) + program-error) + +(deftest nbutlast.error.10 + (classify-error (locally (nbutlast 'a 10) t)) + type-error) diff --git a/ansi-tests/cons-test-10.lsp b/ansi-tests/cons-test-10.lsp new file mode 100644 index 0000000..fc62578 --- /dev/null +++ b/ansi-tests/cons-test-10.lsp @@ -0,0 +1,96 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 07:37:21 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 10 + +(in-package :cl-test) + +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; last + +(deftest last.1 + (last nil) + nil) + +(deftest last.2 + (last (copy-tree '(a b))) + (b)) + +(deftest last.3 + (last (copy-tree '(a b . c))) + (b . c)) + +(deftest last.4 + (last (copy-tree '(a b c d)) 0) + nil) + +(deftest last.5 + (last (copy-tree '(a b c d)) 1) + (d)) + +(deftest last.6 + (last (copy-tree '(a b c d)) 2) + (c d)) + +(deftest last.7 + (last (copy-tree '(a b c d)) 5) + (a b c d)) + +(deftest last.8 + (last (cons 'a 'b) 0) + b) + +(deftest last.9 + (last (cons 'a 'b) 1) + (a . b)) + +(deftest last.10 + (last (cons 'a 'b) 2) + (a . b)) + +(deftest last.order.1 + (let ((i 0) x y) + (values + (last (progn (setf x (incf i)) (list 'a 'b 'c 'd)) + (setf y (incf i))) + i x y)) + (c d) 2 1 2) + +(deftest last.order.2 + (let ((i 0)) + (values (last (progn (incf i) (list 'a 'b 'c 'd))) i)) + (d) 1) + +(deftest last.error.1 + (classify-error (last (list 'a 'b 'c) -1)) + type-error) + +(deftest last.error.2 + (classify-error (last (list 'a 'b 'c) 'a)) + type-error) + +(deftest last.error.3 + (classify-error (last (list 'a 'b 'c) 10.0)) + type-error) + +(deftest last.error.4 + (classify-error (last (list 'a 'b 'c) -10.0)) + type-error) + +(deftest last.error.5 + (classify-error (last (list 'a 'b 'c) #\w)) + type-error) + +(deftest last.error.6 + (classify-error (last)) + program-error) + +(deftest last.error.7 + (classify-error (last '(a b c) 2 nil)) + program-error) + +(deftest last.error.8 + (classify-error (locally (last (list 'a 'b 'c) 'a) t)) + type-error) diff --git a/ansi-tests/cons-test-11.lsp b/ansi-tests/cons-test-11.lsp new file mode 100644 index 0000000..c807859 --- /dev/null +++ b/ansi-tests/cons-test-11.lsp @@ -0,0 +1,261 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 07:37:56 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 11 + +(in-package :cl-test) + +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ldiff, tailp + +(deftest ldiff.1 + (let* ((x (copy-tree '(a b c d e f))) + (xcopy (make-scaffold-copy x))) + (let ((result (ldiff x (cdddr x)))) + (and (check-scaffold-copy x xcopy) + result))) + (a b c)) + +(deftest ldiff.2 + (let* ((x (copy-tree '(a b c d e f))) + (xcopy (make-scaffold-copy x))) + (let ((result (ldiff x 'a))) + (and + (check-scaffold-copy x xcopy) + (zerop + (loop + for a on x and b on result count + (eqt a b))) + result))) + (a b c d e f)) + +;; Works when the end of the dotted list is a symbol +(deftest ldiff.3 + (let* ((x (copy-tree '(a b c d e . f))) + (xcopy (make-scaffold-copy x))) + (let ((result (ldiff x 'a))) + (and + (check-scaffold-copy x xcopy) + result))) + (a b c d e . f)) + +;; Works when the end of the dotted list is a fixnum +(deftest ldiff.4 + (let* ((n 18) + (x (list* 'a 'b 'c 18)) + (xcopy (make-scaffold-copy x))) + (let ((result (ldiff x n))) + (and + (check-scaffold-copy x xcopy) + result))) + (a b c)) + +;; Works when the end of the dotted list is a larger +;; integer (that is eql, but probably not eq). +(deftest ldiff.5 + (let* ((n 18000000000000) + (x (list* 'a 'b 'c (1- 18000000000001))) + (xcopy (make-scaffold-copy x))) + (let ((result (ldiff x n))) + (and + (check-scaffold-copy x xcopy) + result))) + (a b c)) + +;; Test works when the end of a dotted list is a string +(deftest ldiff.6 + (let* ((n (copy-seq "abcde")) + (x (list* 'a 'b 'c n)) + (xcopy (make-scaffold-copy x))) + (let ((result (ldiff x n))) + (if (equal result (list 'a 'b 'c)) + (check-scaffold-copy x xcopy) + result))) + t) + +;; Check that having the cdr of a dotted list be string-equal, but +;; not eql, does not result in success +(deftest ldiff.7 + (let* ((n (copy-seq "abcde")) + (x (list* 'a 'b 'c n)) + (xcopy (make-scaffold-copy x))) + (let ((result (ldiff x (copy-seq n)))) + (if (equal result x) + (check-scaffold-copy x xcopy) + result))) + t) + +;; Check that on failure, the list returned by ldiff is +;; a copy of the list, not the list itself. + +(deftest ldiff.8 + (let ((x (list 'a 'b 'c 'd))) + (let ((result (ldiff x '(e)))) + (and (equal x result) + (loop + for c1 on x + for c2 on result + count (eqt c1 c2))))) + 0) + +(deftest ldiff.order.1 + (let ((i 0) x y) + (values + (ldiff (progn (setf x (incf i)) + (list* 'a 'b 'c 'd)) + (progn (setf y (incf i)) + 'd)) + i x y)) + (a b c) 2 1 2) + +;; Error checking + +(deftest ldiff.error.1 + (classify-error (ldiff 10 'a)) + type-error) + +;; Single atoms are not dotted lists, so the next +;; case should be a type-error +(deftest ldiff.error.2 + (classify-error (ldiff 'a 'a)) + type-error) + +(deftest ldiff.error.3 + (classify-error (ldiff (make-array '(10) :initial-element 'a) '(a))) + type-error) + +(deftest ldiff.error.4 + (classify-error (ldiff 1.23 t)) + type-error) + +(deftest ldiff.error.5 + (classify-error (ldiff #\w 'a)) + type-error) + +(deftest ldiff.error.6 + (classify-error (ldiff)) + program-error) + +(deftest ldiff.error.7 + (classify-error (ldiff nil)) + program-error) + +(deftest ldiff.error.8 + (classify-error (ldiff nil nil nil)) + program-error) + +;; Note! The spec is ambiguous on whether this next test +;; is correct. The spec says that ldiff should be prepared +;; to signal an error if the list argument is not a proper +;; list or dotted list. If listp is false, the list argument +;; is neither (atoms are not dotted lists). +;; +;; However, the sample implementation *does* work even if +;; the list argument is an atom. +;; +#| +(defun ldiff-12-body () + (loop + for x in *universe* + count (and (not (listp x)) + (not (eqt 'type-error + (catch-type-error (ldiff x x))))))) + +(deftest ldiff-12 + (ldiff-12-body) + 0) +|# + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; tailp + +(deftest tailp.1 + (let ((x (copy-tree '(a b c d e . f)))) + (and + (tailp x x) + (tailp (cdr x) x) + (tailp (cddr x) x) + (tailp (cdddr x) x) + (tailp (cddddr x) x) + t)) + t) + +;; The next four tests test that tailp handles dotted lists. See +;; TAILP-NIL:T in the X3J13 documentation. + +(deftest tailp.2 + (notnot-mv (tailp 'e (copy-tree '(a b c d . e)))) + t) + +(deftest tailp.3 + (tailp 'z (copy-tree '(a b c d . e))) + nil) + +(deftest tailp.4 + (notnot-mv (tailp 10203040506070 + (list* 'a 'b (1- 10203040506071)))) + t) + +(deftest tailp.5 + (let ((x "abcde")) (tailp x (list* 'a 'b (copy-seq x)))) + nil) + +(deftest tailp.error.5 + (classify-error (tailp)) + program-error) + +(deftest tailp.error.6 + (classify-error (tailp nil)) + program-error) + +(deftest tailp.error.7 + (classify-error (tailp nil nil nil)) + program-error) + +;; Test that tailp does not modify its arguments + +(deftest tailp.6 + (let* ((x (copy-list '(a b c d e))) + (y (cddr x))) + (let ((xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y))) + (and + (tailp y x) + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy)))) + t) + +;; Note! The spec is ambiguous on whether this next test +;; is correct. The spec says that tailp should be prepared +;; to signal an error if the list argument is not a proper +;; list or dotted list. If listp is false, the list argument +;; is neither (atoms are not dotted lists). +;; +;; However, the sample implementation *does* work even if +;; the list argument is an atom. +;; + +#| +(defun tailp.7-body () + (loop + for x in *universe* + count (and (not (listp x)) + (eqt 'type-error + (catch-type-error (tailp x x)))))) + +(deftest tailp.7 + (tailp.7-body) + 0) +|# + +(deftest tailp.order.1 + (let ((i 0) x y) + (values + (notnot + (tailp (progn (setf x (incf i)) 'd) + (progn (setf y (incf i)) '(a b c . d)))) + i x y)) + t 2 1 2) + diff --git a/ansi-tests/cons-test-12.lsp b/ansi-tests/cons-test-12.lsp new file mode 100644 index 0000000..2402b86 --- /dev/null +++ b/ansi-tests/cons-test-12.lsp @@ -0,0 +1,103 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 07:38:26 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 12 + +(in-package :cl-test) + +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; nthcdr + +(deftest nthcdr.error.1 + (classify-error (nthcdr nil (copy-tree '(a b c d)))) + type-error) + +(deftest nthcdr.error.2 + (classify-error (nthcdr 'a (copy-tree '(a b c d)))) + type-error) + +(deftest nthcdr.error.3 + (classify-error (nthcdr 0.1 (copy-tree '(a b c d)))) + type-error) + +(deftest nthcdr.error.4 + (classify-error (nthcdr #\A (copy-tree '(a b c d)))) + type-error) + +(deftest nthcdr.error.5 + (classify-error (nthcdr '(a) (copy-tree '(a b c d)))) + type-error) + +(deftest nthcdr.error.6 + (classify-error (nthcdr -10 (copy-tree '(a b c d)))) + type-error) + +(deftest nthcdr.error.7 + (classify-error (nthcdr)) + program-error) + +(deftest nthcdr.error.8 + (classify-error (nthcdr 0)) + program-error) + +(deftest nthcdr.error.9 + (classify-error (nthcdr 0 nil nil)) + program-error) + +(deftest nthcdr.error.10 + (classify-error (nthcdr 3 (cons 'a 'b))) + type-error) + +(deftest nthcdr.error.11 + (classify-error (locally (nthcdr 'a (copy-tree '(a b c d))) t)) + type-error) + +(deftest nthcdr.1 + (nthcdr 0 (copy-tree '(a b c d . e))) + (a b c d . e)) + +(deftest nthcdr.2 + (nthcdr 1 (copy-tree '(a b c d))) + (b c d)) + +(deftest nthcdr.3 + (nthcdr 10 nil) + nil) + +(deftest nthcdr.4 + (nthcdr 4 (list 'a 'b 'c)) + nil) + +(deftest nthcdr.5 + (nthcdr 1 (cons 'a 'b)) + b) + +(deftest nthcdr.order.1 + (let ((i 0) x y) + (values + (nthcdr (setf x (incf i)) + (progn (setf y (incf i)) '(a b c d))) + i x y)) + (b c d) 2 1 2) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; rest + +(deftest rest.1 + (rest (list 'a 'b 'c)) + (b c)) + +(deftest rest.order.1 + (let ((i 0)) + (values (rest (progn (incf i) '(a b))) i)) + (b) 1) + +(deftest rest.error.1 + (classify-error (rest)) + program-error) + +(deftest rest.error.2 + (classify-error (rest nil nil)) + program-error) diff --git a/ansi-tests/cons-test-13.lsp b/ansi-tests/cons-test-13.lsp new file mode 100644 index 0000000..bdef6cc --- /dev/null +++ b/ansi-tests/cons-test-13.lsp @@ -0,0 +1,292 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 07:38:57 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 13 + +(in-package :cl-test) + +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; member + +(deftest member.1 + (let* ((x (copy-tree '(a b c d e f))) + (xcopy (make-scaffold-copy x)) + (result (member 'c x))) + (and + (eqt result (cddr x)) + (check-scaffold-copy x xcopy))) + t) + +(deftest member.2 + (let* ((x (copy-tree '(a b c d e f))) + (xcopy (make-scaffold-copy x)) + (result (member 'e x))) + (and + (eqt result (cddddr x)) + (check-scaffold-copy x xcopy))) + t) + +(deftest member.3 + (let* ((x (copy-tree '(1 2 3 4 5 6 7))) + (xcopy (make-scaffold-copy x)) + (result (member 4 x))) + (and + (eqt result (cdddr x)) + (check-scaffold-copy x xcopy))) + t) + +(deftest member.4 + (let* ((x (copy-tree '(2 4 6 8 10 12))) + (xcopy (make-scaffold-copy x)) + (result (member 9 x :key #'1+))) + (and + (eqt result (cdddr x)) + (check-scaffold-copy x xcopy))) + t) + +(deftest member.5 + (let* ((x (copy-tree '((a b) (c d) (e f) (g h)))) + (xcopy (make-scaffold-copy x)) + (result (member '(c d) x :test #'equal))) + (and + (eqt result (cdr x)) + (check-scaffold-copy x xcopy))) + t) + +(deftest member.6 + (let* ((x (copy-tree '((a b) (c d) (e f) (g h)))) + (xcopy (make-scaffold-copy x)) + (result (member 'c x :key #'car))) + (and + (eqt result (cdr x)) + (check-scaffold-copy x xcopy))) + t) + +(deftest member.7 + (let* ((x (copy-tree '((a b) (c d) (e f) (g h)))) + (xcopy (make-scaffold-copy x)) + (result (member 'c x :key #'car :test #'eq))) + (and + (eqt result (cdr x)) + (check-scaffold-copy x xcopy))) + t) + +(deftest member.8 + (let* ((x (copy-tree '((a b) (c d) (e f) (g h)))) + (xcopy (make-scaffold-copy x)) + (result (member 'c x :key #'car :test-not (complement #'eq)))) + (and + (eqt result (cdr x)) + (check-scaffold-copy x xcopy))) + t) + +(deftest member.9 + (let* ((x (copy-tree '((a b) (c d) (e f) (g h)))) + (xcopy (make-scaffold-copy x)) + (result (member 'c x :key #'car :test #'eql))) + (and + (eqt result (cdr x)) + (check-scaffold-copy x xcopy))) + t) + +(deftest member.10 + (let* ((x (copy-tree '((a b) (c d) (e f) (g h)))) + (xcopy (make-scaffold-copy x)) + (result (member (list 'd) x :key #'cdr :test #'equal))) + (and + (eqt result (cdr x)) + (check-scaffold-copy x xcopy))) + t) + +(deftest member.11 + (member (copy-seq "cc") (copy-tree '("aa" "bb" "cc" "dd" "ee"))) + nil) + +(deftest member.12 + (member 1 (copy-tree '(3 4 1 31 423))) + (1 31 423)) + +(deftest member.13 + (member (copy-seq "cc") (copy-tree '("aa" "bb" "cc" "dd" "ee")) + :test #'equal) + ("cc" "dd" "ee")) + +(deftest member.14 + (member 'a nil) + nil) + +(deftest member.15 + (member nil nil) + nil) + +(deftest member.16 + (member nil nil :test #'equal) + nil) + +(deftest member.16-a + (member nil nil :test #'(lambda (x y) (error "Should not call this function"))) + nil) + +(deftest member.17 + (member 'a nil :test #'(lambda (x y) (error "Should not call this function"))) + nil) + +;; Check that a null key argument is ignored + +(deftest member.18 + (member 'a '(c d a b e) :key nil) + (a b e)) + +(deftest member.19 + (member 'z '(a b c d) :key nil) + nil) + +;;; Order of evaluation + +(deftest member.order.1 + (let ((i 0) x y) + (values + (member (progn (setf x (incf i)) 'c) + (progn (setf y (incf i)) '(a b c d))) + i x y)) + (c d) 2 1 2) + +(deftest member.order.2 + (let ((i 0) x y z p) + (values + (member (progn (setf x (incf i)) 'c) + (progn (setf y (incf i)) '(a b c d)) + :key (progn (setf z (incf i)) #'identity) + :test (progn (setf p (incf i)) #'eq)) + i x y z p)) + (c d) 4 1 2 3 4) + +(deftest member.order.3 + (let ((i 0) x y) + (values + (member (progn (setf x (incf i)) 'c) + (progn (setf y (incf i)) '(a b c d)) + :test #'eq) + i x y)) + (c d) 2 1 2) + +(deftest member.order.4 + (let ((i 0) x y z p q) + (values + (member (progn (setf x (incf i)) 'c) + (progn (setf y (incf i)) '(a b c d)) + :key (progn (setf z (incf i)) #'identity) + :test (progn (setf p (incf i)) #'eq) + :key (progn (setf q (incf i)) (constantly 'z))) + i x y z p q)) + (c d) 5 1 2 3 4 5) + +(deftest member.order.5 + (let ((i 0) x y z q) + (values + (member (progn (setf x (incf i)) 'c) + (progn (setf y (incf i)) '(a b c d)) + :test #'eq + :key (progn (setf z (incf i)) #'identity) + :key (progn (setf q (incf i)) (constantly 'z))) + i x y z q)) + (c d) 4 1 2 3 4) + + +;;; Keyword tests + +(deftest member.allow-other-keys.1 + (member 'b '(a b c) :bad t :allow-other-keys t) + (b c)) + +(deftest member.allow-other-keys.2 + (member 'b '(a b c) :allow-other-keys t :bad t) + (b c)) + +(deftest member.allow-other-keys.3 + (member 'b '(a b c) :allow-other-keys t) + (b c)) + +(deftest member.allow-other-keys.4 + (member 'b '(a b c) :allow-other-keys nil) + (b c)) + +(deftest member.allow-other-keys.5 + (member 'b '(a b c) :allow-other-keys 17 :allow-other-keys nil '#:x t) + (b c)) + +(deftest member.keywords.6 + (member 'b '(a b c) :test #'eq :test (complement #'eq)) + (b c)) + +;;; Error cases + +(deftest member.error.1 + (classify-error (member 'a 'b)) + type-error) + +(deftest member.error.2 + (classify-error (member 'a 1.3)) + type-error) + +(deftest member.error.3 + (classify-error (member 'a 1)) + type-error) + +(deftest member.error.4 + (classify-error (member 'a 0)) + type-error) + +(deftest member.error.5 + (classify-error (member 'a "abcde")) + type-error) + +(deftest member.error.6 + (classify-error (member 'a #\w)) + type-error) + +(deftest member.error.7 + (classify-error (member 'a t)) + type-error) + +(deftest member.error.8 + (classify-error (member)) + program-error) + +(deftest member.error.9 + (classify-error (member nil)) + program-error) + +(deftest member.error.10 + (classify-error (member nil nil :bad t)) + program-error) + +(deftest member.error.11 + (classify-error (member nil nil :test)) + program-error) + +(deftest member.error.12 + (classify-error (member nil nil :bad t :allow-other-keys nil)) + program-error) + +(deftest member.error.13 + (classify-error (member nil nil nil)) + program-error) + +(deftest member.error.14 + (classify-error (locally (member 'a t) t)) + type-error) + +(deftest member.error.15 + (classify-error (member 'a '(a b c) :test #'identity)) + program-error) + +(deftest member.error.16 + (classify-error (member 'a '(a b c) :test-not #'identity)) + program-error) + +(deftest member.error.17 + (classify-error (member 'a '(a b c) :key #'cons)) + program-error) diff --git a/ansi-tests/cons-test-14.lsp b/ansi-tests/cons-test-14.lsp new file mode 100644 index 0000000..3b90821 --- /dev/null +++ b/ansi-tests/cons-test-14.lsp @@ -0,0 +1,275 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 07:39:29 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 14 + +(in-package :cl-test) + +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; member-if + +(deftest member-if.1 + (member-if #'listp nil) + nil) + +(deftest member-if.2 + (member-if #'(lambda (x) (eqt x 'a)) '(1 2 a 3 4)) + (a 3 4)) + +(deftest member-if.3 + (member-if #'(lambda (x) (eql x 12)) '(4 12 11 73 11) :key #'1+) + (11 73 11)) + +(deftest member-if.4 + (let ((test-inputs + `(1 a 11.3121 11.31s3 1.123f5 -1 0 + 13.13122d34 581.131e-10 + (a b c . d) + ,(make-array '(10)) + "ancadas" #\w))) + (notnot-mv + (every + #'(lambda (x) + (let ((result (catch-type-error (member-if #'listp x)))) + (or (eqt result 'type-error) + (progn + (format t "~%On ~S: returned ~%~S" x result) + nil)))) + test-inputs))) + t) + +(deftest member-if.5 + (member-if #'identity '(1 2 3 4 5) :key #'evenp) + (2 3 4 5)) + +;;; Order of argument tests + +(deftest member-if.order.1 + (let ((i 0) x y) + (values + (member-if (progn (setf x (incf i)) + #'identity) + (progn (setf y (incf i)) + '(nil nil a b nil c d))) + i x y)) + (a b nil c d) 2 1 2) + +(deftest member-if.order.2 + (let ((i 0) x y z w) + (values + (member-if (progn (setf x (incf i)) + #'identity) + (progn (setf y (incf i)) + '(nil nil a b nil c d)) + :key (progn (setf z (incf i)) #'identity) + :key (progn (setf w (incf i)) #'not)) + + i x y z w)) + (a b nil c d) 4 1 2 3 4) + + +;;; Keyword tests + +(deftest member-if.keywords.1 + (member-if #'identity '(1 2 3 4 5) :key #'evenp :key #'oddp) + (2 3 4 5)) + +(deftest member-if.allow-other-keys.2 + (member-if #'identity '(nil 2 3 4 5) :allow-other-keys t :bad t) + (2 3 4 5)) + +(deftest member-if.allow-other-keys.3 + (member-if #'identity '(nil 2 3 4 5) :bad t :allow-other-keys t) + (2 3 4 5)) + +(deftest member-if.allow-other-keys.4 + (member-if #'identity '(nil 2 3 4 5) :allow-other-keys t) + (2 3 4 5)) + +(deftest member-if.allow-other-keys.5 + (member-if #'identity '(nil 2 3 4 5) :allow-other-keys nil) + (2 3 4 5)) + +(deftest member-if.allow-other-keys.6 + (member-if #'identity '(nil 2 3 4 5) :allow-other-keys t + :allow-other-keys nil) + (2 3 4 5)) + +(deftest member-if.allow-other-keys.7 + (member-if #'identity '(nil 2 3 4 5) :allow-other-keys t + :allow-other-keys nil :key #'identity :key #'null) + (2 3 4 5)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; member-if-not + +(deftest member-if-not.1 + (member-if-not #'listp nil) + nil) + +(deftest member-if-not.2 + (member-if-not #'(lambda (x) (eqt x 'a)) '(a 1 2 a 3 4)) + (1 2 a 3 4)) + +(deftest member-if-not.3 + (member-if-not #'(lambda (x) (not (eql x 12))) '(4 12 11 73 11) :key #'1+) + (11 73 11)) + +(deftest member-if-not.4 + (let ((test-inputs + `(1 a 11.3121 11.31s3 1.123f5 -1 0 + 13.13122d34 581.131e-10 + ((a) (b) (c) . d) + ,(make-array '(10)) + "ancadas" #\w))) + (not (every + #'(lambda (x) + (let ((result (catch-type-error (member-if-not #'listp x)))) + (or (eqt result 'type-error) + (progn + (format t "~%On x = ~S, returns: ~%~S" x result) + nil)))) + test-inputs))) + nil) + +(deftest member-if-not.5 + (member-if-not #'not '(1 2 3 4 5) :key #'evenp) + (2 3 4 5)) + +;;; Order of evaluation tests + +(deftest member-if-not.order.1 + (let ((i 0) x y) + (values + (member-if-not (progn (setf x (incf i)) + #'not) + (progn (setf y (incf i)) + '(nil nil a b nil c d))) + i x y)) + (a b nil c d) 2 1 2) + +(deftest member-if-not.order.2 + (let ((i 0) x y z w) + (values + (member-if-not (progn (setf x (incf i)) + #'not) + (progn (setf y (incf i)) + '(nil nil a b nil c d)) + :key (progn (setf z (incf i)) #'identity) + :key (progn (setf w (incf i)) #'not)) + + i x y z w)) + (a b nil c d) 4 1 2 3 4) + +;;; Keyword tests + +(deftest member-if-not.keywords.1 + (member-if-not #'not '(1 2 3 4 5) :key #'evenp :key #'oddp) + (2 3 4 5)) + +(deftest member-if-not.allow-other-keys.2 + (member-if-not #'not '(nil 2 3 4 5) :allow-other-keys t :bad t) + (2 3 4 5)) + +(deftest member-if-not.allow-other-keys.3 + (member-if-not #'not '(nil 2 3 4 5) :bad t :allow-other-keys t) + (2 3 4 5)) + +(deftest member-if-not.allow-other-keys.4 + (member-if-not #'not '(nil 2 3 4 5) :allow-other-keys t) + (2 3 4 5)) + +(deftest member-if-not.allow-other-keys.5 + (member-if-not #'not '(nil 2 3 4 5) :allow-other-keys nil) + (2 3 4 5)) + +(deftest member-if-not.allow-other-keys.6 + (member-if-not #'not '(nil 2 3 4 5) :allow-other-keys t + :allow-other-keys nil :key #'identity :key #'null) + (2 3 4 5)) + + +;;; Error cases + +(deftest member-if.error.1 + (classify-error (member-if #'identity 'a)) + type-error) + +(deftest member-if.error.2 + (classify-error (member-if)) + program-error) + +(deftest member-if.error.3 + (classify-error (member-if #'null)) + program-error) + +(deftest member-if.error.4 + (classify-error (member-if #'null '(a b c) :bad t)) + program-error) + +(deftest member-if.error.5 + (classify-error (member-if #'null '(a b c) :bad t :allow-other-keys nil)) + program-error) + +(deftest member-if.error.6 + (classify-error (member-if #'null '(a b c) :key)) + program-error) + +(deftest member-if.error.7 + (classify-error (member-if #'null '(a b c) 1 2)) + program-error) + +(deftest member-if.error.8 + (classify-error (locally (member-if #'identity 'a) t)) + type-error) + +(deftest member-if.error.9 + (classify-error (member-if #'cons '(a b c))) + program-error) + +(deftest member-if.error.10 + (classify-error (member-if #'identity '(a b c) :key #'cons)) + program-error) + + +(deftest member-if-not.error.1 + (classify-error (member-if-not #'identity 'a)) + type-error) + +(deftest member-if-not.error.2 + (classify-error (member-if-not)) + program-error) + +(deftest member-if-not.error.3 + (classify-error (member-if-not #'null)) + program-error) + +(deftest member-if-not.error.4 + (classify-error (member-if-not #'null '(a b c) :bad t)) + program-error) + +(deftest member-if-not.error.5 + (classify-error (member-if-not #'null '(a b c) :bad t :allow-other-keys nil)) + program-error) + +(deftest member-if-not.error.6 + (classify-error (member-if-not #'null '(a b c) :key)) + program-error) + +(deftest member-if-not.error.7 + (classify-error (member-if-not #'null '(a b c) 1 2)) + program-error) + +(deftest member-if-not.error.8 + (classify-error (locally (member-if-not #'identity 'a) t)) + type-error) + +(deftest member-if-not.error.9 + (classify-error (member-if-not #'cons '(a b c))) + program-error) + +(deftest member-if-not.error.10 + (classify-error (member-if-not #'identity '(a b c) :key #'cons)) + program-error) diff --git a/ansi-tests/cons-test-15.lsp b/ansi-tests/cons-test-15.lsp new file mode 100644 index 0000000..89b2a8f --- /dev/null +++ b/ansi-tests/cons-test-15.lsp @@ -0,0 +1,652 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 07:40:12 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 15 + +(in-package :cl-test) + +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; mapc + +(deftest mapc.1 + (mapc #'list nil) + nil) + +(deftest mapc.2 + (let ((x 0)) + (let ((result + (mapc #'(lambda (y) (incf x y)) + '(1 2 3 4)))) + (list result x))) + ((1 2 3 4) 10)) + +(deftest mapc.3 + (let ((x 0)) + (list + (mapc #'(lambda (y z) (declare (ignore y z)) (incf x)) + (make-list 5 :initial-element 'a) + (make-list 5 )) + x)) + ((a a a a a) 5)) + +(deftest mapc.4 + (let ((x 0)) + (list + (mapc #'(lambda (y z) (declare (ignore y z)) (incf x)) + (make-list 5 :initial-element 'a) + (make-list 10)) + x)) + ((a a a a a) 5)) + +(deftest mapc.5 + (let ((x 0)) + (list + (mapc #'(lambda (y z) (declare (ignore y z)) (incf x)) + (make-list 5 :initial-element 'a) + (make-list 3)) + x)) + ((a a a a a) 3)) + +(defvar *mapc.6-var* nil) +(defun mapc.6-fun (x) + (push x *mapc.6-var*) + x) + +(deftest mapc.6 + (let* ((x (copy-list '(a b c d e f g h))) + (xcopy (make-scaffold-copy x))) + (setf *mapc.6-var* nil) + (let ((result (mapc 'mapc.6-fun x))) + (and (check-scaffold-copy x xcopy) + (eqt result x) + *mapc.6-var*))) + (h g f e d c b a)) + +(deftest mapc.order.1 + (let ((i 0) x y z) + (values + (mapc (progn (setf x (incf i)) + #'list) + (progn (setf y (incf i)) + '(a b c)) + (progn (setf z (incf i)) + '(1 2 3))) + i x y z)) + (a b c) 3 1 2 3) + +(deftest mapc.error.1 + (classify-error (mapc #'identity 1)) + type-error) + +(deftest mapc.error.2 + (classify-error (mapc)) + program-error) + +(deftest mapc.error.3 + (classify-error (mapc #'append)) + program-error) + +(deftest mapc.error.4 + (classify-error (locally (mapc #'identity 1) t)) + type-error) + +(deftest mapc.error.5 + (classify-error (mapc #'cons '(a b c))) + program-error) + +(deftest mapc.error.6 + (classify-error (mapc #'cons '(a b c) '(1 2 3) '(4 5 6))) + program-error) + +(deftest mapc.error.7 + (classify-error (mapc #'car '(a b c))) + type-error) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; mapcar + +(deftest mapcar.1 + (mapcar #'1+ nil) + nil) + +(deftest mapcar.2 + (let* ((x (copy-list '(1 2 3 4))) + (xcopy (make-scaffold-copy x))) + (let ((result (mapcar #'1+ x))) + (and (check-scaffold-copy x xcopy) + result))) + (2 3 4 5)) + +(deftest mapcar.3 + (let* ((n 0) + (x (copy-list '(a b c d))) + (xcopy (make-scaffold-copy x))) + (let ((result + (mapcar #'(lambda (y) (declare (ignore y)) (incf n)) + x))) + (and (check-scaffold-copy x xcopy) + result))) + (1 2 3 4)) + +(deftest mapcar.4 + (let* ((n 0) + (x (copy-list '(a b c d))) + (xcopy (make-scaffold-copy x)) + (x2 (copy-list '(a b c d e f))) + (x2copy (make-scaffold-copy x2)) + (result + (mapcar #'(lambda (y z) (declare (ignore y z)) (incf n)) + x x2))) + (and (check-scaffold-copy x xcopy) + (check-scaffold-copy x2 x2copy) + (list result n))) + ((1 2 3 4) 4)) + +(deftest mapcar.5 + (let* ((n 0) + (x (copy-list '(a b c d))) + (xcopy (make-scaffold-copy x)) + (x2 (copy-list '(a b c d e f))) + (x2copy (make-scaffold-copy x2)) + (result + (mapcar #'(lambda (y z) (declare (ignore y z)) (incf n)) + x2 x))) + (and (check-scaffold-copy x xcopy) + (check-scaffold-copy x2 x2copy) + (list result n))) + ((1 2 3 4) 4)) + +(deftest mapcar.6 + (let* ((x (copy-list '(a b c d e f g h))) + (xcopy (make-scaffold-copy x))) + (setf *mapc.6-var* nil) + (let ((result (mapcar 'mapc.6-fun x))) + (and (check-scaffold-copy x xcopy) + (list *mapc.6-var* result)))) + ((h g f e d c b a) (a b c d e f g h))) + +(deftest mapcar.order.1 + (let ((i 0) x y z) + (values + (mapcar (progn (setf x (incf i)) + #'list) + (progn (setf y (incf i)) + '(a b c)) + (progn (setf z (incf i)) + '(1 2 3))) + i x y z)) + ((a 1) (b 2) (c 3)) + 3 1 2 3) + +(deftest mapcar.error.1 + (classify-error (mapcar #'identity 1)) + type-error) + +(deftest mapcar.error.2 + (classify-error (mapcar)) + program-error) + +(deftest mapcar.error.3 + (classify-error (mapcar #'append)) + program-error) + +(deftest mapcar.error.4 + (classify-error (locally (mapcar #'identity 1) t)) + type-error) + +(deftest mapcar.error.5 + (classify-error (mapcar #'car '(a b c))) + type-error) + +(deftest mapcar.error.6 + (classify-error (mapcar #'cons '(a b c))) + program-error) + +(deftest mapcar.error.7 + (classify-error (mapcar #'cons '(a b c) '(1 2 3) '(4 5 6))) + program-error) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; mapcan + +(deftest mapcan.1 + (mapcan #'list nil) + nil) + +(deftest mapcan.2 + (mapcan #'list (copy-list '(a b c d e f))) + (a b c d e f)) + +(deftest mapcan.3 + (let* ((x (list 'a 'b 'c 'd)) + (xcopy (make-scaffold-copy x)) + (result (mapcan #'list x))) + (and + (= (length x) (length result)) + (check-scaffold-copy x xcopy) + (loop + for e1 on x + and e2 on result + count (or (eqt e1 e2) (not (eql (car e1) (car e2))))))) + 0) + +(deftest mapcan.4 + (mapcan #'list + (copy-list '(1 2 3 4)) + (copy-list '(a b c d))) + (1 a 2 b 3 c 4 d)) + +(deftest mapcan.5 + (mapcan #'(lambda (x y) (make-list y :initial-element x)) + (copy-list '(a b c d)) + (copy-list '(1 2 3 4))) + (a b b c c c d d d d)) + +(defvar *mapcan.6-var* nil) +(defun mapcan.6-fun (x) + (push x *mapcan.6-var*) + (copy-list *mapcan.6-var*)) + +(deftest mapcan.6 + (progn + (setf *mapcan.6-var* nil) + (mapcan 'mapcan.6-fun (copy-list '(a b c d)))) + (a b a c b a d c b a)) + +(deftest mapcan.order.1 + (let ((i 0) x y z) + (values + (mapcan (progn (setf x (incf i)) + #'list) + (progn (setf y (incf i)) + '(a b c)) + (progn (setf z (incf i)) + '(1 2 3))) + i x y z)) + (a 1 b 2 c 3) + 3 1 2 3) + +(deftest mapcan.8 + (mapcan #'(lambda (x y) (make-list y :initial-element x)) + (copy-list '(a b c d)) + (copy-list '(1 2 3 4 5 6))) + (a b b c c c d d d d)) + +(deftest mapcan.9 + (mapcan #'(lambda (x y) (make-list y :initial-element x)) + (copy-list '(a b c d e f)) + (copy-list '(1 2 3 4))) + (a b b c c c d d d d)) + +(deftest mapcan.10 + (mapcan #'list + (copy-list '(a b c d)) + (copy-list '(1 2 3 4)) + nil) + nil) + +(deftest mapcan.11 + (mapcan (constantly 1) (list 'a)) + 1) + +(deftest mapcan.error.1 + (classify-error (mapcan #'identity 1)) + type-error) + +(deftest mapcan.error.2 + (classify-error (mapcan)) + program-error) + +(deftest mapcan.error.3 + (classify-error (mapcan #'append)) + program-error) + +(deftest mapcan.error.4 + (classify-error (locally (mapcan #'identity 1) t)) + type-error) + +(deftest mapcan.error.5 + (classify-error (mapcan #'car '(a b c))) + type-error) + +(deftest mapcan.error.6 + (classify-error (mapcan #'cons '(a b c))) + program-error) + +(deftest mapcan.error.7 + (classify-error (mapcan #'cons '(a b c) '(1 2 3) '(4 5 6))) + program-error) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; mapl + +(deftest mapl.1 + (mapl #'list nil) + nil) + +(deftest mapl.2 + (let* ((a nil) + (x (copy-list '(a b c))) + (xcopy (make-scaffold-copy x)) + (result + (mapl #'(lambda (y) (push y a)) + x))) + (and + (check-scaffold-copy x xcopy) + (eqt result x) + a)) + ((c) (b c) (a b c))) + +(deftest mapl.3 + (let* ((a nil) + (x (copy-list '(a b c d))) + (y (copy-list '(1 2 3 4))) + (xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y)) + (result + (mapl #'(lambda (xtail ytail) + (setf a + (append (mapcar #'list xtail ytail) + a))) + x y))) + (and + (eqt result x) + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + a)) + ((d 4) (c 3) (d 4) (b 2) (c 3) (d 4) + (a 1) (b 2) (c 3) (d 4))) + +(deftest mapl.4 + (let* ((a nil) + (x (copy-list '(a b c d))) + (y (copy-list '(1 2 3 4 5 6 7 8))) + (xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y)) + (result + (mapl #'(lambda (xtail ytail) + (setf a + (append (mapcar #'list xtail ytail) + a))) + x y))) + (and + (eqt result x) + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + a)) + ((d 4) (c 3) (d 4) (b 2) (c 3) (d 4) + (a 1) (b 2) (c 3) (d 4))) + +(deftest mapl.5 + (let* ((a nil) + (x (copy-list '(a b c d e f g))) + (y (copy-list '(1 2 3 4))) + (xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y)) + (result + (mapl #'(lambda (xtail ytail) + (setf a + (append (mapcar #'list xtail ytail) + a))) + x y))) + (and + (eqt result x) + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + a)) + ((d 4) (c 3) (d 4) (b 2) (c 3) (d 4) + (a 1) (b 2) (c 3) (d 4))) + +(deftest mapl.order.1 + (let ((i 0) x y z) + (values + (mapl (progn + (setf x (incf i)) + (constantly nil)) + (progn + (setf y (incf i)) + '(a b c)) + (progn + (setf z (incf i)) + '(1 2 3))) + i x y z)) + (a b c) 3 1 2 3) + +(deftest mapl.error.1 + (classify-error (mapl #'identity 1)) + type-error) + +(deftest mapl.error.2 + (classify-error (mapl)) + program-error) + +(deftest mapl.error.3 + (classify-error (mapl #'append)) + program-error) + +(deftest mapl.error.4 + (classify-error (locally (mapl #'identity 1) t)) + type-error) + +(deftest mapl.error.5 + (classify-error (mapl #'cons '(a b c))) + program-error) + +(deftest mapl.error.6 + (classify-error (mapl #'cons '(a b c) '(1 2 3) '(4 5 6))) + program-error) + +(deftest mapl.error.7 + (classify-error (mapl #'caar '(a b c))) + type-error) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; maplist + +(deftest maplist.1 + (maplist #'list nil) + nil) + +(deftest maplist.2 + (let* ((x (copy-list '(a b c))) + (xcopy (make-scaffold-copy x)) + (result (maplist #'identity x))) + (and (check-scaffold-copy x xcopy) + result)) + ((a b c) (b c) (c))) + +(deftest maplist.3 + (let* ((x (copy-list '(a b c d))) + (y (copy-list '(1 2 3 4))) + (xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y)) + (result + (maplist #'append x y))) + (and + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + result)) + ((a b c d 1 2 3 4) + (b c d 2 3 4) + (c d 3 4) + (d 4))) + +(deftest maplist.4 + (let* ((x (copy-list '(a b c d))) + (y (copy-list '(1 2 3 4 5))) + (xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y)) + (result + (maplist #'append x y))) + (and + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + result)) + ((a b c d 1 2 3 4 5) + (b c d 2 3 4 5) + (c d 3 4 5) + (d 4 5))) + +(deftest maplist.5 + (let* ((x (copy-list '(a b c d e))) + (y (copy-list '(1 2 3 4))) + (xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y)) + (result + (maplist #'append x y))) + (and + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + result)) + ((a b c d e 1 2 3 4) + (b c d e 2 3 4) + (c d e 3 4) + (d e 4))) + +(deftest maplist.6 + (maplist 'append '(a b c) '(1 2 3)) + ((a b c 1 2 3) (b c 2 3) (c 3))) + +(deftest maplist.7 + (maplist #'(lambda (x y) (nth (car x) y)) + '(0 1 0 1 0 1 0) + '(a b c d e f g) + ) + (a c c e e g g)) + +(deftest maplist.order.1 + (let ((i 0) x y z) + (values + (maplist + (progn + (setf x (incf i)) + #'(lambda (x y) (declare (ignore x)) (car y))) + (progn + (setf y (incf i)) + '(a b c)) + (progn + (setf z (incf i)) + '(1 2 3))) + i x y z)) + (1 2 3) 3 1 2 3) + +(deftest maplist.error.1 + (classify-error (maplist #'identity 'a)) + type-error) + +(deftest maplist.error.2 + (classify-error (maplist #'identity 1)) + type-error) + +(deftest maplist.error.3 + (classify-error (maplist #'identity 1.1323)) + type-error) + +(deftest maplist.error.4 + (classify-error (maplist #'identity "abcde")) + type-error) + +(deftest maplist.error.5 + (classify-error (maplist)) + program-error) + +(deftest maplist.error.6 + (classify-error (maplist #'append)) + program-error) + +(deftest maplist.error.7 + (classify-error (locally (maplist #'identity 'a) t)) + type-error) + +(deftest maplist.error.8 + (classify-error (maplist #'caar '(a b c))) + type-error) + +(deftest maplist.error.9 + (classify-error (maplist #'cons '(a b c))) + program-error) + +(deftest maplist.error.10 + (classify-error (maplist #'cons '(a b c) '(1 2 3) '(4 5 6))) + program-error) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; mapcon + +(deftest mapcon.1 + (mapcon #'(lambda (x) (append '(a) x nil)) nil) + nil) + +(deftest mapcon.2 + (let* ((x (copy-list '(1 2 3 4))) + (xcopy (make-scaffold-copy x)) + (result + (mapcon #'(lambda (y) (append '(a) y nil)) x))) + (and + (check-scaffold-copy x xcopy) + result)) + (a 1 2 3 4 a 2 3 4 a 3 4 a 4)) + +(deftest mapcon.3 + (let* ((x (copy-list '(4 2 3 2 2))) + (y (copy-list '(a b c d e f g h i j k l))) + (xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y)) + (result + (mapcon #'(lambda (xt yt) + (subseq yt 0 (car xt))) + x y))) + (and + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + result)) + (a b c d b c c d e d e e f)) + +(deftest mapcon.4 + (mapcon (constantly 1) (list 'a)) + 1) + +(deftest mapcon.order.1 + (let ((i 0) x y z) + (values + (mapcon (progn (setf x (incf i)) + #'(lambda (x y) (list (car x) (car y)))) + (progn (setf y (incf i)) + '(a b c)) + (progn (setf z (incf i)) + '(1 2 3))) + i x y z)) + (a 1 b 2 c 3) + 3 1 2 3) + +(deftest mapcon.error.1 + (classify-error (mapcon #'identity 1)) + type-error) + +(deftest mapcon.error.2 + (classify-error (mapcon)) + program-error) + +(deftest mapcon.error.3 + (classify-error (mapcon #'append)) + program-error) + +(deftest mapcon.error.4 + (classify-error (locally (mapcon #'identity 1) t)) + type-error) + +(deftest mapcon.error.5 + (classify-error (mapcon #'caar '(a b c))) + type-error) + +(deftest mapcon.error.6 + (classify-error (mapcon #'cons '(a b c))) + program-error) + +(deftest mapcon.error.7 + (classify-error (mapcon #'cons '(a b c) '(1 2 3) '(4 5 6))) + program-error) diff --git a/ansi-tests/cons-test-16.lsp b/ansi-tests/cons-test-16.lsp new file mode 100644 index 0000000..be3978a --- /dev/null +++ b/ansi-tests/cons-test-16.lsp @@ -0,0 +1,678 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 07:41:13 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 16 + +(in-package :cl-test) + +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; acons + +(deftest acons.1 + (let* ((x (copy-tree '((c . d) (e . f)))) + (xcopy (make-scaffold-copy x)) + (result (acons 'a 'b x))) + (and + (check-scaffold-copy x xcopy) + (eqt (cdr result) x) + result)) + ((a . b) (c . d) (e . f))) + +(deftest acons.2 + (acons 'a 'b nil) + ((a . b))) + +(deftest acons.3 + (acons 'a 'b 'c) + ((a . b) . c)) + +(deftest acons.4 + (acons '((a b)) '(((c d) e) f) '((1 . 2))) + (( ((a b)) . (((c d) e) f)) (1 . 2))) + +(deftest acons.5 + (acons "ancd" 1.143 nil) + (("ancd" . 1.143))) + +(deftest acons.6 + (acons #\R :foo :bar) + ((#\R . :foo) . :bar)) + +(deftest acons.order.1 + (let ((i 0) x y z) + (values + (acons (progn (setf x (incf i)) 'a) + (progn (setf y (incf i)) 'b) + (progn (setf z (incf i)) '((c . d)))) + i x y z)) + ((a . b)(c . d)) + 3 1 2 3) + +(deftest acons.error.1 + (classify-error (acons)) + program-error) + +(deftest acons.error.2 + (classify-error (acons 'a)) + program-error) + +(deftest acons.error.3 + (classify-error (acons 'a 'b)) + program-error) + +(deftest acons.error.4 + (classify-error (acons 'a 'b 'c 'd)) + program-error) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; assoc + +(deftest assoc.1 + (assoc nil nil) + nil) + +(deftest assoc.2 + (assoc nil '(nil)) + nil) + +(deftest assoc.3 + (assoc nil '(nil (nil . 2) (a . b))) + (nil . 2)) + +(deftest assoc.4 + (assoc nil '((a . b) (c . d))) + nil) + +(deftest assoc.5 + (assoc 'a '((a . b))) + (a . b)) + +(deftest assoc.6 + (assoc 'a '((:a . b) (#:a . c) (a . d) (a . e) (z . f))) + (a . d)) + +(deftest assoc.7 + (let* ((x (copy-tree '((a . b) (b . c) (c . d)))) + (xcopy (make-scaffold-copy x)) + (result (assoc 'b x))) + (and + (eqt result (second x)) + (check-scaffold-copy x xcopy))) + t) + +(deftest assoc.8 + (assoc 1 '((0 . a) (1 . b) (2 . c))) + (1 . b)) + +(deftest assoc.9 + (assoc (copy-seq "abc") + '((abc . 1) ("abc" . 2) ("abc" . 3))) + nil) + +(deftest assoc.10 + (assoc (copy-list '(a)) (copy-tree '(((a) b) ((a) (c))))) + nil) + +(deftest assoc.11 + (let ((x (list 'a 'b))) + (assoc x `(((a b) c) (,x . d) (,x . e) ((a b) 1)))) + ((a b) . d)) + + +(deftest assoc.12 + (assoc #\e '(("abefd" . 1) ("aevgd" . 2) ("edada" . 3)) + :key #'(lambda (x) (char x 1))) + ("aevgd" . 2)) + +(deftest assoc.13 + (assoc nil '(((a) . b) ( nil . c ) ((nil) . d)) + :key #'car) + (nil . c)) + +(deftest assoc.14 + (assoc (copy-seq "abc") + '((abc . 1) ("abc" . 2) ("abc" . 3)) + :test #'equal) + ("abc" . 2)) + +(deftest assoc.15 + (assoc (copy-seq "abc") + '((abc . 1) ("abc" . 2) ("abc" . 3)) + :test #'equalp) + ("abc" . 2)) + +(deftest assoc.16 + (assoc (copy-list '(a)) (copy-tree '(((a) b) ((a) (c)))) + :test #'equal) + ((a) b)) + +(deftest assoc.17 + (assoc (copy-seq "abc") + '((abc . 1) (a . a) (b . b) ("abc" . 2) ("abc" . 3)) + :test-not (complement #'equalp)) + ("abc" . 2)) + +(deftest assoc.18 + (assoc 'a '((a . d)(b . c)) :test-not #'eq) + (b . c)) + +(deftest assoc.19 + (assoc 'a '((a . d)(b . c)) :test (complement #'eq)) + (b . c)) + +(deftest assoc.20 + (assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) + :key #'(lambda (x) (and (stringp x) (string-downcase x))) + :test #'equal) + ("A" . 6)) + +(deftest assoc.21 + (assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) + :key #'(lambda (x) (and (stringp x) x)) + :test #'equal) + ("a" . 3)) + +(deftest assoc.22 + (assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) + :key #'(lambda (x) (and (stringp x) (string-downcase x))) + :test-not (complement #'equal)) + ("A" . 6)) + +(deftest assoc.23 + (assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) + :key #'(lambda (x) (and (stringp x) x)) + :test-not (complement #'equal)) + ("a" . 3)) + +;; Check that it works when test returns a true value +;; other than T + +(deftest assoc.24 + (assoc 'a '((b . 1) (a . 2) (c . 3)) + :test #'(lambda (x y) (and (eqt x y) 'matched))) + (a . 2)) + +;; Check that the order of the arguments to test is correct + +(deftest assoc.25 + (block fail + (assoc 'a '((b . 1) (c . 2) (a . 3)) + :test #'(lambda (x y) + (unless (eqt x 'a) (return-from fail 'fail)) + (eqt x y)))) + (a . 3)) + +;;; Order of argument evaluation + +(deftest assoc.order.1 + (let ((i 0) x y) + (values + (assoc (progn (setf x (incf i)) 'c) + (progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4)))) + i x y)) + (c . 3) 2 1 2) + +(deftest assoc.order.2 + (let ((i 0) x y z) + (values + (assoc (progn (setf x (incf i)) 'c) + (progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4))) + :test (progn (setf z (incf i)) #'eq)) + i x y z)) + (c . 3) 3 1 2 3) + +(deftest assoc.order.3 + (let ((i 0) x y) + (values + (assoc (progn (setf x (incf i)) 'c) + (progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4))) + :test #'eq) + i x y)) + (c . 3) 2 1 2) + +(deftest assoc.order.4 + (let ((i 0) x y z w) + (values + (assoc (progn (setf x (incf i)) 'c) + (progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4))) + :key (progn (setf z (incf i)) #'identity) + :key (progn (setf w (incf i)) #'not)) + i x y z w)) + (c . 3) 4 1 2 3 4) + +;;; Keyword tests + +(deftest assoc.allow-other-keys.1 + (assoc 'b '((a . 1) (b . 2) (c . 3)) :bad t :allow-other-keys t) + (b . 2)) + +(deftest assoc.allow-other-keys.2 + (assoc 'b '((a . 1) (b . 2) (c . 3)) :allow-other-keys t :also-bad t) + (b . 2)) + +(deftest assoc.allow-other-keys.3 + (assoc 'b '((a . 1) (b . 2) (c . 3)) :allow-other-keys t :also-bad t + :test-not #'eql) + (a . 1)) + +(deftest assoc.allow-other-keys.4 + (assoc 'b '((a . 1) (b . 2) (c . 3)) :allow-other-keys t) + (b . 2)) + +(deftest assoc.allow-other-keys.5 + (assoc 'b '((a . 1) (b . 2) (c . 3)) :allow-other-keys nil) + (b . 2)) + +(deftest assoc.keywords.6 + (assoc 'b '((a . 1) (b . 2) (c . 3)) :key #'identity :key #'null) + (b . 2)) + +(deftest assoc.keywords.7 + (assoc 'b '((a . 1) (b . 2) (c . 3)) :key nil :key #'null) + (b . 2)) + + +(deftest assoc.error.1 + (classify-error (assoc)) + program-error) + +(deftest assoc.error.2 + (classify-error (assoc nil)) + program-error) + +(deftest assoc.error.3 + (classify-error (assoc nil nil :bad t)) + program-error) + +(deftest assoc.error.4 + (classify-error (assoc nil nil :key)) + program-error) + +(deftest assoc.error.5 + (classify-error (assoc nil nil 1 1)) + program-error) + +(deftest assoc.error.6 + (classify-error (assoc nil nil :bad t :allow-other-keys nil)) + program-error) + +(deftest assoc.error.7 + (classify-error (assoc 'a '((a . b)) :test #'identity)) + program-error) + +(deftest assoc.error.8 + (classify-error (assoc 'a '((a . b)) :test-not #'identity)) + program-error) + +(deftest assoc.error.9 + (classify-error (assoc 'a '((a . b)) :key #'cons)) + program-error) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; assoc-if + +(deftest assoc-if.1 + (let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) + (xcopy (make-scaffold-copy x)) + (result (assoc-if #'evenp x))) + (and + (check-scaffold-copy x xcopy) + (eqt result (third x)) + result)) + (6 . c)) + +(deftest assoc-if.2 + (let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) + (xcopy (make-scaffold-copy x)) + (result (assoc-if #'oddp x :key #'1+))) + (and + (check-scaffold-copy x xcopy) + (eqt result (third x)) + result)) + (6 . c)) + +(deftest assoc-if.3 + (let* ((x (copy-list '((1 . a) nil (3 . b) (6 . c) (7 . d)))) + (xcopy (make-scaffold-copy x)) + (result (assoc-if #'evenp x))) + (and + (check-scaffold-copy x xcopy) + (eqt result (fourth x)) + result)) + (6 . c)) + +(deftest assoc-if.4 + (assoc-if #'null '((a . b) nil (c . d) (nil . e) (f . g))) + (nil . e)) + +;;; Order of argument evaluation + +(deftest assoc-if.order.1 + (let ((i 0) x y) + (values + (assoc-if (progn (setf x (incf i)) #'null) + (progn (setf y (incf i)) + '((a . 1) (b . 2) (nil . 17) (d . 4)))) + i x y)) + (nil . 17) 2 1 2) + +(deftest assoc-if.order.2 + (let ((i 0) x y z) + (values + (assoc-if (progn (setf x (incf i)) #'null) + (progn (setf y (incf i)) + '((a . 1) (b . 2) (nil . 17) (d . 4))) + :key (progn (setf z (incf i)) #'null)) + i x y z)) + (a . 1) 3 1 2 3) + +;;; Keyword tests + +(deftest assoc-if.allow-other-keys.1 + (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) :bad t :allow-other-keys t) + (nil . 2)) + +(deftest assoc-if.allow-other-keys.2 + (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) + :allow-other-keys t :also-bad t) + (nil . 2)) + +(deftest assoc-if.allow-other-keys.3 + (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) + :allow-other-keys t :also-bad t :key #'not) + (a . 1)) + +(deftest assoc-if.allow-other-keys.4 + (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) :allow-other-keys t) + (nil . 2)) + +(deftest assoc-if.allow-other-keys.5 + (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) :allow-other-keys nil) + (nil . 2)) + +(deftest assoc-if.keywords.6 + (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) :key #'identity :key #'null) + (nil . 2)) + +(deftest assoc-if.keywords.7 + (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) :key nil :key #'null) + (nil . 2)) + +;;; Error cases + +(deftest assoc-if.error.1 + (classify-error (assoc-if)) + program-error) + +(deftest assoc-if.error.2 + (classify-error (assoc-if #'null)) + program-error) + +(deftest assoc-if.error.3 + (classify-error (assoc-if #'null nil :bad t)) + program-error) + +(deftest assoc-if.error.4 + (classify-error (assoc-if #'null nil :key)) + program-error) + +(deftest assoc-if.error.5 + (classify-error (assoc-if #'null nil 1 1)) + program-error) + +(deftest assoc-if.error.6 + (classify-error (assoc-if #'null nil :bad t :allow-other-keys nil)) + program-error) + +(deftest assoc-if.error.7 + (classify-error (assoc-if #'cons '((a b)(c d)))) + program-error) + +(deftest assoc-if.error.8 + (classify-error (assoc-if #'identity '((a b)(c d)) :key #'cons)) + program-error) + +(deftest assoc-if.error.9 + (classify-error (assoc-if #'car '((a b)(c d)))) + type-error) + +(deftest assoc-if.error.10 + (classify-error (assoc-if #'identity '((a b)(c d)) :key #'car)) + type-error) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; assoc-if-not + +(deftest assoc-if-not.1 + (let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) + (xcopy (make-scaffold-copy x)) + (result (assoc-if-not #'oddp x))) + (and + (check-scaffold-copy x xcopy) + (eqt result (third x)) + result)) + (6 . c)) + +(deftest assoc-if-not.2 + (let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) + (xcopy (make-scaffold-copy x)) + (result (assoc-if-not #'evenp x :key #'1+))) + (and + (check-scaffold-copy x xcopy) + (eqt result (third x)) + result)) + (6 . c)) + +(deftest assoc-if-not.3 + (let* ((x (copy-list '((1 . a) nil (3 . b) (6 . c) (7 . d)))) + (xcopy (make-scaffold-copy x)) + (result (assoc-if-not #'oddp x))) + (and + (check-scaffold-copy x xcopy) + (eqt result (fourth x)) + result)) + (6 . c)) + +(deftest assoc-if-not.4 + (assoc-if-not #'identity '((a . b) nil (c . d) (nil . e) (f . g))) + (nil . e)) + +;;; Order of argument evaluation tests + +(deftest assoc-if-not.order.1 + (let ((i 0) x y) + (values + (assoc-if-not (progn (setf x (incf i)) #'identity) + (progn (setf y (incf i)) + '((a . 1) (b . 2) (nil . 17) (d . 4)))) + i x y)) + (nil . 17) 2 1 2) + +(deftest assoc-if-not.order.2 + (let ((i 0) x y z) + (values + (assoc-if-not (progn (setf x (incf i)) #'identity) + (progn (setf y (incf i)) + '((a . 1) (b . 2) (nil . 17) (d . 4))) + :key (progn (setf z (incf i)) #'null)) + i x y z)) + (a . 1) 3 1 2 3) + +;;; Keyword tests + +(deftest assoc-if-not.allow-other-keys.1 + (assoc-if-not #'identity + '((a . 1) (nil . 2) (c . 3)) :bad t :allow-other-keys t) + (nil . 2)) + +(deftest assoc-if-not.allow-other-keys.2 + (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) + :allow-other-keys t :also-bad t) + (nil . 2)) + +(deftest assoc-if-not.allow-other-keys.3 + (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) + :allow-other-keys t :also-bad t :key #'not) + (a . 1)) + +(deftest assoc-if-not.allow-other-keys.4 + (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) :allow-other-keys t) + (nil . 2)) + +(deftest assoc-if-not.allow-other-keys.5 + (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) :allow-other-keys nil) + (nil . 2)) + +(deftest assoc-if-not.keywords.6 + (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) + :key #'identity :key #'null) + (nil . 2)) + +(deftest assoc-if-not.keywords.7 + (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) :key nil :key #'null) + (nil . 2)) + +;;; Error tests + +(deftest assoc-if-not.error.1 + (classify-error (assoc-if-not)) + program-error) + +(deftest assoc-if-not.error.2 + (classify-error (assoc-if-not #'null)) + program-error) + +(deftest assoc-if-not.error.3 + (classify-error (assoc-if-not #'null nil :bad t)) + program-error) + +(deftest assoc-if-not.error.4 + (classify-error (assoc-if-not #'null nil :key)) + program-error) + +(deftest assoc-if-not.error.5 + (classify-error (assoc-if-not #'null nil 1 1)) + program-error) + +(deftest assoc-if-not.error.6 + (classify-error (assoc-if-not #'null nil :bad t :allow-other-keys nil)) + program-error) + +(deftest assoc-if-not.error.7 + (classify-error (assoc-if-not #'cons '((a b)(c d)))) + program-error) + +(deftest assoc-if-not.error.8 + (classify-error (assoc-if-not #'identity '((a b)(c d)) :key #'cons)) + program-error) + +(deftest assoc-if-not.error.9 + (classify-error (assoc-if-not #'car '((a b)(c d)))) + type-error) + +(deftest assoc-if-not.error.10 + (classify-error (assoc-if-not #'identity '((a b)(c d)) :key #'car)) + type-error) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; copy-alist + +(deftest copy-alist-1 + (let* ((x (copy-tree '((a . b) (c . d) nil (e f) ((x) ((y z)) w) + ("foo" . "bar") (#\w . 1.234) + (1/3 . 4123.4d5)))) + (xcopy (make-scaffold-copy x)) + (result (copy-alist x))) + (and + (check-scaffold-copy x xcopy) + (= (length x) (length result)) + (every #'(lambda (p1 p2) + (or (and (null p1) (null p2)) + (and (not (eqt p1 p2)) + (eqt (car p1) (car p2)) + (eqt (cdr p1) (cdr p2))))) + x result) + t)) + t) + +(deftest copy-alist.error.1 + (classify-error (copy-alist)) + program-error) + +(deftest copy-alist.error.2 + (classify-error (copy-alist nil nil)) + program-error) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; pairlis + +;; Pairlis has two legal behaviors: the pairs +;; can be prepended in the same order, or in the +;; reverse order, that they appear in the first +;; two arguments + +(defun my-pairlis (x y &optional alist) + (if (null x) + alist + (acons (car x) (car y) + (my-pairlis (cdr x) (cdr y) alist)))) + +(deftest pairlis-1 + (pairlis nil nil nil) + nil) + +(deftest pairlis-2 + (pairlis '(a) '(b) nil) + ((a . b))) + +(deftest pairlis-3 + (let* ((x (copy-list '(a b c d e))) + (xcopy (make-scaffold-copy x)) + (y (copy-list '(1 2 3 4 5))) + (ycopy (make-scaffold-copy y)) + (result (pairlis x y)) + (expected (my-pairlis x y))) + (and + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + (or + (equal result expected) + (equal result (reverse expected))) + t)) + t) + +(deftest pairlis-4 + (let* ((x (copy-list '(a b c d e))) + (xcopy (make-scaffold-copy x)) + (y (copy-list '(1 2 3 4 5))) + (ycopy (make-scaffold-copy y)) + (z '((x . 10) (y . 20))) + (zcopy (make-scaffold-copy z)) + (result (pairlis x y z)) + (expected (my-pairlis x y z))) + (and + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + (check-scaffold-copy z zcopy) + (eqt (cdr (cddr (cddr result))) z) + (or + (equal result expected) + (equal result (append (reverse (subseq expected 0 5)) + (subseq expected 5)))) + t)) + t) + +(deftest pairlis.error.1 + (classify-error (pairlis)) + program-error) + +(deftest pairlis.error.2 + (classify-error (pairlis nil)) + program-error) + +(deftest pairlis.error.3 + (classify-error (pairlis nil nil nil nil)) + program-error) diff --git a/ansi-tests/cons-test-17.lsp b/ansi-tests/cons-test-17.lsp new file mode 100644 index 0000000..e1941c6 --- /dev/null +++ b/ansi-tests/cons-test-17.lsp @@ -0,0 +1,559 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 09:45:22 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 17 + +(in-package :cl-test) + +(declaim (optimize (safety 3))) + +(defun rev-assoc-list (x) + (cond + ((null x) nil) + ((null (car x)) + (cons nil (rev-assoc-list (cdr x)))) + (t + (acons (cdar x) (caar x) (rev-assoc-list (cdr x)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; rassoc + +(deftest rassoc.1 + (rassoc nil nil) + nil) + +(deftest rassoc.2 + (rassoc nil '(nil)) + nil) + +(deftest rassoc.3 + (rassoc nil (rev-assoc-list '(nil (nil . 2) (a . b)))) + (2 . nil)) + +(deftest rassoc.4 + (rassoc nil '((a . b) (c . d))) + nil) + +(deftest rassoc.5 + (rassoc 'a '((b . a))) + (b . a)) + +(deftest rassoc.6 + (rassoc 'a (rev-assoc-list '((:a . b) (#:a . c) (a . d) (a . e) (z . f)))) + (d . a)) + +(deftest rassoc.7 + (let* ((x (copy-tree (rev-assoc-list '((a . b) (b . c) (c . d))))) + (xcopy (make-scaffold-copy x)) + (result (rassoc 'b x))) + (and + (eqt result (second x)) + (check-scaffold-copy x xcopy))) + t) + +(deftest rassoc.8 + (rassoc 1 (rev-assoc-list '((0 . a) (1 . b) (2 . c)))) + (b . 1)) + +(deftest rassoc.9 + (rassoc (copy-seq "abc") + (rev-assoc-list '((abc . 1) ("abc" . 2) ("abc" . 3)))) + nil) + +(deftest rassoc.10 + (rassoc (copy-list '(a)) + (copy-tree (rev-assoc-list '(((a) b) ((a) (c)))))) + nil) + +(deftest rassoc.11 + (let ((x (list 'a 'b))) + (rassoc x + (rev-assoc-list `(((a b) c) (,x . d) (,x . e) ((a b) 1))))) + (d a b)) + + +(deftest rassoc.12 + (rassoc #\e + (copy-tree + (rev-assoc-list '(("abefd" . 1) ("aevgd" . 2) ("edada" . 3)))) + :key #'(lambda (x) (char x 1))) + (2 . "aevgd")) + +(deftest rassoc.13 + (rassoc nil + (copy-tree + (rev-assoc-list + '(((a) . b) ( nil . c ) ((nil) . d)))) + :key #'car) + (c)) + +(deftest rassoc.14 + (rassoc (copy-seq "abc") + (copy-tree + (rev-assoc-list + '((abc . 1) ("abc" . 2) ("abc" . 3)))) + :test #'equal) + (2 . "abc")) + +(deftest rassoc.15 + (rassoc (copy-seq "abc") + (copy-tree + (rev-assoc-list + '((abc . 1) ("abc" . 2) ("abc" . 3)))) + :test #'equalp) + (2 . "abc")) + +(deftest rassoc.16 + (rassoc (copy-list '(a)) + (copy-tree + (rev-assoc-list '(((a) b) ((a) (c))))) + :test #'equal) + ((b) a)) + +(deftest rassoc.17 + (rassoc (copy-seq "abc") + (copy-tree + (rev-assoc-list + '((abc . 1) (a . a) (b . b) ("abc" . 2) ("abc" . 3)))) + :test-not (complement #'equalp)) + (2 . "abc")) + +(deftest rassoc.18 + (rassoc 'a + (copy-tree + (rev-assoc-list + '((a . d)(b . c)))) + :test-not #'eq) + (c . b)) + +(deftest rassoc.19 + (rassoc 'a + (copy-tree + (rev-assoc-list + '((a . d)(b . c)))) + :test (complement #'eq)) + (c . b)) + +(deftest rassoc.20 + (rassoc "a" + (copy-tree + (rev-assoc-list + '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)))) + :key #'(lambda (x) (and (stringp x) (string-downcase x))) + :test #'equal) + (6 . "A")) + +(deftest rassoc.21 + (rassoc "a" + (copy-tree + (rev-assoc-list + '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)))) + :key #'(lambda (x) (and (stringp x) x)) + :test #'equal) + (3 . "a")) + +(deftest rassoc.22 + (rassoc "a" + (copy-tree + (rev-assoc-list + '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)))) + :key #'(lambda (x) (and (stringp x) (string-downcase x))) + :test-not (complement #'equal)) + (6 . "A")) + +(deftest rassoc.23 + (rassoc "a" + (copy-tree + (rev-assoc-list + '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)))) + :key #'(lambda (x) (and (stringp x) x)) + :test-not (complement #'equal)) + (3 . "a")) + +;; Check that it works when test returns a true value +;; other than T + +(deftest rassoc.24 + (rassoc 'a + (copy-tree + (rev-assoc-list + '((b . 1) (a . 2) (c . 3)))) + :test #'(lambda (x y) (and (eqt x y) 'matched))) + (2 . a)) + +;; Check that the order of the arguments to :test is correct + +(deftest rassoc.25 + (block fail + (rassoc 'a '((1 . b) (2 . c) (3 . a)) + :test #'(lambda (x y) + (unless (eqt x 'a) (return-from fail 'fail)) + (eqt x y)))) + (3 . a)) + +;;; Order of argument evaluation + +(deftest rassoc.order.1 + (let ((i 0) x y) + (values + (rassoc (progn (setf x (incf i)) 'c) + (progn (setf y (incf i)) '((1 . a) (2 . b) (3 . c) (4 . c)))) + i x y)) + (3 . c) 2 1 2) + +(deftest rassoc.order.2 + (let ((i 0) x y z) + (values + (rassoc (progn (setf x (incf i)) 'c) + (progn (setf y (incf i)) '((1 . a) (2 . b) (3 . c) (4 . c))) + :test (progn (setf z (incf i)) #'eql)) + i x y z)) + (3 . c) 3 1 2 3) + +(deftest rassoc.order.3 + (let ((i 0) x y) + (values + (rassoc (progn (setf x (incf i)) 'c) + (progn (setf y (incf i)) '((1 . a) (2 . b) (3 . c) (4 . c))) + :test #'eql) + i x y)) + (3 . c) 2 1 2) + +(deftest rassoc.order.4 + (let ((i 0) x y z w) + (values + (rassoc (progn (setf x (incf i)) 'c) + (progn (setf y (incf i)) '((1 . a) (2 . b) (3 . c) (4 . c))) + :key (progn (setf z (incf i)) #'identity) + :key (progn (setf w (incf i)) #'not)) + i x y z w)) + (3 . c) 4 1 2 3 4) + +;;; Keyword tests + +(deftest rassoc.allow-other-keys.1 + (rassoc 'b '((1 . a) (2 . b) (3 . c)) :bad t :allow-other-keys t) + (2 . b)) + +(deftest rassoc.allow-other-keys.2 + (rassoc 'b '((1 . a) (2 . b) (3 . c)) :allow-other-keys t :bad t) + (2 . b)) + +(deftest rassoc.allow-other-keys.3 + (rassoc 'a '((1 . a) (2 . b) (3 . c)) :allow-other-keys t :bad t + :test-not #'eql) + (2 . b)) + +(deftest rassoc.allow-other-keys.4 + (rassoc 'b '((1 . a) (2 . b) (3 . c)) :allow-other-keys t) + (2 . b)) + +(deftest rassoc.allow-other-keys.5 + (rassoc 'b '((1 . a) (2 . b) (3 . c)) :allow-other-keys nil) + (2 . b)) + +(deftest rassoc.keywords.6 + (rassoc 'b '((1 . a) (2 . b) (3 . c)) + :test #'eql :test (complement #'eql)) + (2 . b)) + +;;; Error tests + +(deftest rassoc.error.1 + (classify-error (rassoc)) + program-error) + +(deftest rassoc.error.2 + (classify-error (rassoc nil)) + program-error) + +(deftest rassoc.error.3 + (classify-error (rassoc nil nil :bad t)) + program-error) + +(deftest rassoc.error.4 + (classify-error (rassoc nil nil :key)) + program-error) + +(deftest rassoc.error.5 + (classify-error (rassoc nil nil 1 1)) + program-error) + +(deftest rassoc.error.6 + (classify-error (rassoc nil nil :bad t :allow-other-keys nil)) + program-error) + +(deftest rassoc.error.7 + (classify-error (rassoc 'a '((b . a)(c . d)) :test #'identity)) + program-error) + +(deftest rassoc.error.8 + (classify-error (rassoc 'a '((b . a)(c . d)) :test-not #'identity)) + program-error) + +(deftest rassoc.error.9 + (classify-error (rassoc 'a '((b . a)(c . d)) :key #'cons)) + program-error) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; rassoc-if + +(deftest rassoc-if.1 + (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d)))) + (xcopy (make-scaffold-copy x)) + (result (rassoc-if #'evenp x))) + (and + (check-scaffold-copy x xcopy) + (eqt result (third x)) + result)) + (c . 6)) + +(deftest rassoc-if.2 + (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d)))) + (xcopy (make-scaffold-copy x)) + (result (rassoc-if #'oddp x :key #'1+))) + (and + (check-scaffold-copy x xcopy) + (eqt result (third x)) + result)) + (c . 6)) + +(deftest rassoc-if.3 + (let* ((x (rev-assoc-list '((1 . a) nil (3 . b) (6 . c) (7 . d)))) + (xcopy (make-scaffold-copy x)) + (result (rassoc-if #'evenp x))) + (and + (check-scaffold-copy x xcopy) + (eqt result (fourth x)) + result)) + (c . 6)) + +(deftest rassoc-if.4 + (rassoc-if #'null + (rev-assoc-list '((a . b) nil (c . d) (nil . e) (f . g)))) + (e)) + +;;; Order of argument evaluation + +(deftest rassoc-if.order.1 + (let ((i 0) x y) + (values + (rassoc-if (progn (setf x (incf i)) #'null) + (progn (setf y (incf i)) + '((1 . a) (2 . b) (17) (4 . d)))) + i x y)) + (17) 2 1 2) + +(deftest rassoc-if.order.2 + (let ((i 0) x y z) + (values + (rassoc-if (progn (setf x (incf i)) #'null) + (progn (setf y (incf i)) + '((1 . a) (2 . b) (17) (4 . d))) + :key (progn (setf z (incf i)) #'null)) + i x y z)) + (1 . a) 3 1 2 3) + + +;;; Keyword tests + +(deftest rassoc-if.allow-other-keys.1 + (rassoc-if #'null '((1 . a) (2) (3 . c)) :bad t :allow-other-keys t) + (2)) + +(deftest rassoc-if.allow-other-keys.2 + (rassoc-if #'null '((1 . a) (2) (3 . c)) :allow-other-keys t :bad t) + (2)) + +(deftest rassoc-if.allow-other-keys.3 + (rassoc-if #'identity '((1 . a) (2) (3 . c)) :allow-other-keys t :bad t + :key 'not) + (2)) + +(deftest rassoc-if.allow-other-keys.4 + (rassoc-if #'null '((1 . a) (2) (3 . c)) :allow-other-keys t) + (2)) + +(deftest rassoc-if.allow-other-keys.5 + (rassoc-if #'null '((1 . a) (2) (3 . c)) :allow-other-keys nil) + (2)) + +(deftest rassoc-if.keywords.6 + (rassoc-if #'identity '((1 . a) (2) (3 . c)) :key #'not :key #'identity) + (2)) + +;;; Error tests + +(deftest rassoc-if.error.1 + (classify-error (rassoc-if)) + program-error) + +(deftest rassoc-if.error.2 + (classify-error (rassoc-if #'null)) + program-error) + +(deftest rassoc-if.error.3 + (classify-error (rassoc-if #'null nil :bad t)) + program-error) + +(deftest rassoc-if.error.4 + (classify-error (rassoc-if #'null nil :key)) + program-error) + +(deftest rassoc-if.error.5 + (classify-error (rassoc-if #'null nil 1 1)) + program-error) + +(deftest rassoc-if.error.6 + (classify-error (rassoc-if #'null nil :bad t :allow-other-keys nil)) + program-error) + +(deftest rassoc-if.error.7 + (classify-error (rassoc-if #'cons '((a . b)(c . d)))) + program-error) + +(deftest rassoc-if.error.8 + (classify-error (rassoc-if #'car '((a . b)(c . d)))) + type-error) + +(deftest rassoc-if.error.9 + (classify-error (rassoc-if #'identity '((a . b)(c . d)) :key #'cons)) + program-error) + +(deftest rassoc-if.error.10 + (classify-error (rassoc-if #'identity '((a . b)(c . d)) :key #'car)) + type-error) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; rassoc-if-not + +(deftest rassoc-if-not.1 + (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d)))) + (xcopy (make-scaffold-copy x)) + (result (rassoc-if-not #'oddp x))) + (and + (check-scaffold-copy x xcopy) + (eqt result (third x)) + result)) + (c . 6)) + +(deftest rassoc-if-not.2 + (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d)))) + (xcopy (make-scaffold-copy x)) + (result (rassoc-if-not #'evenp x :key #'1+))) + (and + (check-scaffold-copy x xcopy) + (eqt result (third x)) + result)) + (c . 6)) + +(deftest rassoc-if-not.3 + (let* ((x (rev-assoc-list '((1 . a) nil (3 . b) (6 . c) (7 . d)))) + (xcopy (make-scaffold-copy x)) + (result (rassoc-if-not #'oddp x))) + (and + (check-scaffold-copy x xcopy) + (eqt result (fourth x)) + result)) + (c . 6)) + +(deftest rassoc-if-not.4 + (rassoc-if-not #'identity + (rev-assoc-list '((a . b) nil (c . d) (nil . e) (f . g)))) + (e)) + +;;; Order of argument evaluation + +(deftest rassoc-if-not.order.1 + (let ((i 0) x y) + (values + (rassoc-if-not (progn (setf x (incf i)) #'identity) + (progn (setf y (incf i)) + '((1 . a) (2 . b) (17) (4 . d)))) + i x y)) + (17) 2 1 2) + +(deftest rassoc-if-not.order.2 + (let ((i 0) x y z) + (values + (rassoc-if-not (progn (setf x (incf i)) #'identity) + (progn (setf y (incf i)) + '((1 . a) (2 . b) (17) (4 . d))) + :key (progn (setf z (incf i)) #'null)) + i x y z)) + (1 . a) 3 1 2 3) + +;;; Keyword tests + +(deftest rassoc-if-not.allow-other-keys.1 + (rassoc-if-not #'identity '((1 . a) (2) (3 . c)) :bad t :allow-other-keys t) + (2)) + +(deftest rassoc-if-not.allow-other-keys.2 + (rassoc-if-not #'values '((1 . a) (2) (3 . c)) :allow-other-keys t :bad t) + (2)) + +(deftest rassoc-if-not.allow-other-keys.3 + (rassoc-if-not #'not '((1 . a) (2) (3 . c)) :allow-other-keys t :bad t + :key 'not) + (2)) + +(deftest rassoc-if-not.allow-other-keys.4 + (rassoc-if-not #'identity '((1 . a) (2) (3 . c)) :allow-other-keys t) + (2)) + +(deftest rassoc-if-not.allow-other-keys.5 + (rassoc-if-not #'identity '((1 . a) (2) (3 . c)) :allow-other-keys nil) + (2)) + +(deftest rassoc-if-not.allow-other-keys.6 + (rassoc-if-not #'identity '((1 . a) (2) (3 . c)) :allow-other-keys t + :allow-other-keys nil :bad t) + (2)) + +(deftest rassoc-if-not.keywords.7 + (rassoc-if-not #'identity '((1 . a) (2) (3 . c)) :key #'not :key nil) + (1 . a)) + +;;; Error tests + +(deftest rassoc-if-not.error.1 + (classify-error (rassoc-if-not)) + program-error) + +(deftest rassoc-if-not.error.2 + (classify-error (rassoc-if-not #'null)) + program-error) + +(deftest rassoc-if-not.error.3 + (classify-error (rassoc-if-not #'null nil :bad t)) + program-error) + +(deftest rassoc-if-not.error.4 + (classify-error (rassoc-if-not #'null nil :key)) + program-error) + +(deftest rassoc-if-not.error.5 + (classify-error (rassoc-if-not #'null nil 1 1)) + program-error) + +(deftest rassoc-if-not.error.6 + (classify-error (rassoc-if-not #'null nil :bad t :allow-other-keys nil)) + program-error) + +(deftest rassoc-if-not.error.7 + (classify-error (rassoc-if-not #'cons '((a . b)(c . d)))) + program-error) + +(deftest rassoc-if-not.error.8 + (classify-error (rassoc-if-not #'car '((a . b)(c . d)))) + type-error) + +(deftest rassoc-if-not.error.9 + (classify-error (rassoc-if-not #'identity '((a . b)(c . d)) :key #'cons)) + program-error) + +(deftest rassoc-if-not.error.10 + (classify-error (rassoc-if-not #'identity '((a . b)(c . d)) :key #'car)) + type-error) diff --git a/ansi-tests/cons-test-18.lsp b/ansi-tests/cons-test-18.lsp new file mode 100644 index 0000000..679ca9d --- /dev/null +++ b/ansi-tests/cons-test-18.lsp @@ -0,0 +1,338 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 10:23:31 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 18 + +(in-package :cl-test) + +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; get-properties + +(deftest get-properties.1 + (get-properties nil nil) + nil nil nil) + +(deftest get-properties.2 + (get-properties '(a b) nil) + nil nil nil) + +(deftest get-properties.3 + (get-properties '(a b c d) '(a)) + a b (a b c d)) + +(deftest get-properties.4 + (get-properties '(a b c d) '(c)) + c d (c d)) + +(deftest get-properties.5 + (get-properties '(a b c d) '(c a)) + a b (a b c d)) + +(deftest get-properties.6 + (get-properties '(a b c d) '(b)) + nil nil nil) + +(deftest get-properties.7 + (get-properties '("aa" b c d) (list (copy-seq "aa"))) + nil nil nil) + +(deftest get-properties.8 + (get-properties '(1000000000000 b c d) (list (1+ 999999999999))) + nil nil nil) + +(deftest get-properties.9 + (let* ((x (copy-list '(a b c d e f g h a c))) + (xcopy (make-scaffold-copy x)) + (y (copy-list '(x y f g))) + (ycopy (make-scaffold-copy y))) + (multiple-value-bind + (indicator value tail) + (get-properties x y) + (and + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + (eqt tail (nthcdr 6 x)) + (values indicator value tail)))) + g h (g h a c)) + +(deftest get-properties.order.1 + (let ((i 0) x y) + (values + (multiple-value-list + (get-properties (progn (setf x (incf i)) '(a b c d)) + (progn (setf y (incf i)) '(c)))) + i x y)) + (c d (c d)) 2 1 2) + +(deftest get-properties.error.1 + (classify-error (get-properties)) + program-error) + +(deftest get-properties.error.2 + (classify-error (get-properties nil)) + program-error) + +(deftest get-properties.error.3 + (classify-error (get-properties nil nil nil)) + program-error) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; getf + +(deftest getf.1 + (getf nil 'a) + nil) + +(deftest getf.2 + (getf nil 'a 'b) + b) + +(deftest getf.3 + (getf '(a b) 'a) + b) + +(deftest getf.4 + (getf '(a b) 'a 'c) + b) + +(deftest getf.5 + (let ((x 0)) + (values + (getf '(a b) 'a (incf x)) + x)) + b 1) + +(deftest getf.order.1 + (let ((i 0) x y) + (values + (getf (progn (setf x (incf i)) '(a b)) + (progn (setf y (incf i)) 'a)) + i x y)) + b 2 1 2) + +(deftest getf.order.2 + (let ((i 0) x y z) + (values + (getf (progn (setf x (incf i)) '(a b)) + (progn (setf y (incf i)) 'a) + (setf z (incf i))) + i x y z)) + b 3 1 2 3) + +(deftest setf-getf.1 + (let ((p (copy-list '(a 1 b 2)))) + (setf (getf p 'c) 3) + ;; Must check that only a, b, c have properties + (and + (eqlt (getf p 'a) 1) + (eqlt (getf p 'b) 2) + (eqlt (getf p 'c) 3) + (eqlt + (loop + for ptr on p by #'cddr count + (not (member (car ptr) '(a b c)))) + 0) + t)) + t) + +(deftest setf-getf.2 + (let ((p (copy-list '(a 1 b 2)))) + (setf (getf p 'a) 3) + ;; Must check that only a, b have properties + (and + (eqlt (getf p 'a) 3) + (eqlt (getf p 'b) 2) + (eqlt + (loop + for ptr on p by #'cddr count + (not (member (car ptr) '(a b)))) + 0) + t)) + t) + +(deftest setf-getf.3 + (let ((p (copy-list '(a 1 b 2)))) + (setf (getf p 'c 17) 3) + ;; Must check that only a, b, c have properties + (and + (eqlt (getf p 'a) 1) + (eqlt (getf p 'b) 2) + (eqlt (getf p 'c) 3) + (eqlt + (loop + for ptr on p by #'cddr count + (not (member (car ptr) '(a b c)))) + 0) + t)) + t) + +(deftest setf-getf.4 + (let ((p (copy-list '(a 1 b 2)))) + (setf (getf p 'a 17) 3) + ;; Must check that only a, b have properties + (and + (eqlt (getf p 'a) 3) + (eqlt (getf p 'b) 2) + (eqlt + (loop + for ptr on p by #'cddr count + (not (member (car ptr) '(a b)))) + 0) + t)) + t) + +(deftest setf-getf.5 + (let ((p (copy-list '(a 1 b 2))) + (foo nil)) + (setf (getf p 'a (progn (setf foo t) 0)) 3) + ;; Must check that only a, b have properties + (and + (eqlt (getf p 'a) 3) + (eqlt (getf p 'b) 2) + (eqlt + (loop + for ptr on p by #'cddr count + (not (member (car ptr) '(a b)))) + 0) + foo)) + t) + +(deftest setf-getf.order.1 + (let ((p (list (copy-list '(a 1 b 2)))) + (cnt1 0) (cnt2 0) (cnt3 0)) + (setf (getf (car (progn (incf cnt1) p)) 'c (incf cnt3)) + (progn (incf cnt2) 3)) + ;; Must check that only a, b, c have properties + (and + (eqlt cnt1 1) + (eqlt cnt2 1) + (eqlt cnt3 1) + (eqlt (getf (car p) 'a) 1) + (eqlt (getf (car p) 'b) 2) + (eqlt (getf (car p) 'c) 3) + (eqlt + (loop + for ptr on (car p) by #'cddr count + (not (member (car ptr) '(a b c)))) + 0) + t)) + t) + +(deftest setf-getf.order.2 + (let ((p (list (copy-list '(a 1 b 2)))) + (i 0) x y z w) + (setf (getf (car (progn (setf x (incf i)) p)) + (progn (setf y (incf i)) 'c) + (setf z (incf i))) + (progn (setf w (incf i)) 3)) + ;; Must check that only a, b, c have properties + (and + (eqlt i 4) + (eqlt x 1) + (eqlt y 2) + (eqlt z 3) + (eqlt w 4) + (eqlt (getf (car p) 'a) 1) + (eqlt (getf (car p) 'b) 2) + (eqlt (getf (car p) 'c) 3) + (eqlt + (loop + for ptr on (car p) by #'cddr count + (not (member (car ptr) '(a b c)))) + 0) + t)) + t) + +(deftest incf-getf.1 + (let ((p (copy-list '(a 1 b 2)))) + (incf (getf p 'b)) + ;; Must check that only a, b have properties + (and + (eqlt (getf p 'a) 1) + (eqlt (getf p 'b) 3) + (eqlt + (loop + for ptr on p by #'cddr count + (not (member (car ptr) '(a b)))) + 0) + t)) + t) + +(deftest incf-getf.2 + (let ((p (copy-list '(a 1 b 2)))) + (incf (getf p 'c 19)) + ;; Must check that only a, b have properties + (and + (eqlt (getf p 'a) 1) + (eqlt (getf p 'b) 2) + (eqlt (getf p 'c) 20) + (eqlt + (loop + for ptr on p by #'cddr count + (not (member (car ptr) '(a b c)))) + 0) + t)) + t) + +(deftest push-getf.1 + (let ((p nil)) + (values + (push 'x (getf p 'a)) + p)) + (x) (a (x))) + +(deftest getf.error.1 + (classify-error (getf)) + program-error) + +(deftest getf.error.2 + (classify-error (getf nil)) + program-error) + +(deftest getf.error.3 + (classify-error (getf nil nil nil nil)) + program-error) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; remf + +(deftest remf.1 + (let ((x nil)) + (values (remf x 'a) x)) + nil ()) + +(deftest remf.2 + (let ((x (list 'a 'b))) + (values (not (null (remf x 'a))) x)) + t ()) + +(deftest remf.3 + (let ((x (list 'a 'b 'a 'c))) + (values (not (null (remf x 'a))) x)) + t (a c)) + +(deftest remf.4 + (let ((x (list 'a 'b 'c 'd))) + (values + (and (remf x 'c) t) + (loop + for ptr on x by #'cddr count + (not (eqt (car ptr) 'a))))) + t 0) + +(deftest remf.order.1 + (let ((i 0) x y + (p (make-array 1 :initial-element (copy-list '(a b c d e f))))) + (values + (notnot + (remf (aref p (progn (setf x (incf i)) 0)) + (progn (setf y (incf i)) + 'c))) + (aref p 0) + i x y)) + t (a b e f) 2 1 2) + + \ No newline at end of file diff --git a/ansi-tests/cons-test-19.lsp b/ansi-tests/cons-test-19.lsp new file mode 100644 index 0000000..1214a72 --- /dev/null +++ b/ansi-tests/cons-test-19.lsp @@ -0,0 +1,738 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 11:53:33 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 19 + +(in-package :cl-test) + +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; intersection + +(deftest intersection.1 + (intersection nil nil) + nil) + +(deftest intersection.2 + (intersection (loop for i from 1 to 100 collect i) nil) + nil) + +(deftest intersection.3 + (intersection nil (loop for i from 1 to 100 collect i)) + nil) + +(deftest intersection.4 + (let* ((x (copy-list '(a 1 c 7 b 4 3 z))) + (xcopy (make-scaffold-copy x)) + (y (copy-list '(3 y c q z a 18))) + (ycopy (make-scaffold-copy y)) + (result (intersection x y))) + (and + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + (+ + (loop + for e in x count + (and (member e y) + (not (member e result)))) + (loop + for e in result count + (or (not (member e x)) + (not (member e y)))) + (loop + for hd on result count + (and (consp hd) + (member (car hd) (cdr hd))))))) + 0) + +(deftest intersection.5 + (let* ((x (copy-list '(a a a))) + (xcopy (make-scaffold-copy x)) + (y (copy-list '(a a a b b b))) + (ycopy (make-scaffold-copy y)) + (result (intersection x y))) + (and + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + (member 'a result) + (not (member 'b result)))) + t) + +(deftest intersection.6 + (intersection (list 1000000000000 'a 'b 'c) + (list (1+ 999999999999) 'd 'e 'f)) + (1000000000000)) + +(deftest intersection.7 + (intersection (list 'a 10 'b 17) + (list 'c 'd 4 'e 'f 10 1 13 'z)) + (10)) + +(deftest intersection.8 + (intersection (list 'a (copy-seq "aaa") 'b) + (list 'd (copy-seq "aaa") 'e)) + nil) + +(deftest intersection.9 + (intersection (list 'a (copy-seq "aaa") 'b) + (list 'd (copy-seq "aaa") 'e) + :test #'equal) + ("aaa")) + +;; Same as 9, but with a symbol function designator for :test +(deftest intersection.9-a + (intersection (list 'a (copy-seq "aaa") 'b) + (list 'd (copy-seq "aaa") 'e) + :test 'equal) + ("aaa")) + +(deftest intersection.9-b + (intersection (list 'a (copy-seq "aaa") 'b) + (list 'd (copy-seq "aaa") 'e) + :test-not #'(lambda (p q) (not (equal p q)))) + ("aaa")) + +(deftest intersection.10 + (equalt + (sort + (intersection (loop + for i from 0 to 1000 by 3 + collect i) + (loop + for i from 0 to 1000 by 7 + collect i)) + #'<) + (loop for i from 0 to 1000 by 21 collect i)) + t) + +(deftest intersection.11 + (equalt + (sort + (intersection (loop + for i from 0 to 999 by 5 + collect i) + (loop + for i from 0 to 999 by 7 + collect i) + :test #'(lambda (a b) + (and (eql a b) + (= (mod a 3) 0)))) + #'<) + (loop for i from 0 to 999 by (* 3 5 7) collect i)) + t) + +(deftest intersection.11-a + (equalt + (sort + (intersection (loop + for i from 0 to 999 by 5 + collect i) + (loop + for i from 0 to 999 by 7 + collect i) + :test-not + #'(lambda (a b) + (not (and (eql a b) + (= (mod a 3) 0))))) + #'<) + (loop for i from 0 to 999 by (* 3 5 7) collect i)) + t) + +;; +;; Do large numbers of random intersection tests +;; + +(deftest intersection.12 + (intersection-12-body 100 100) + nil) + + +;; +;; :key argument +;; + +(deftest intersection.13 + (let ((x (copy-list '(0 5 8 13 31 42))) + (y (copy-list '(3 5 42 0 7 100 312 33)))) + (equalt + (sort (copy-list (intersection x y)) #'<) + (sort (copy-list (intersection x y :key #'1+)) #'<))) + t) + +;; Same as 13, but with a symbol function designator for :key +(deftest intersection.13-a + (let ((x (copy-list '(0 5 8 13 31 42))) + (y (copy-list '(3 5 42 0 7 100 312 33)))) + (equalt + (sort (copy-list (intersection x y)) #'<) + (sort (copy-list (intersection x y :key '1+)) #'<))) + t) + +;; Test that a nil key argument is ignored + +(deftest intersection.14 + (let + ((result (intersection (copy-list '(a b c d)) + (copy-list '(e c f b g)) + :key nil))) + (and + (member 'b result) + (member 'c result) + (every #'(lambda (x) (member x '(b c))) result) + t)) + t) + +;; Test that intersection preserves the order of arguments to :test, :test-not + +(deftest intersection.15 + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (block fail + (intersection + list1 list2 + :test + #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + (eql x y))))) + (4)) + +(deftest intersection.16 + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (block fail + (intersection + list1 list2 + :key #'identity + :test + #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + (eql x y))))) + (4)) + +(deftest intersection.17 + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (block fail + (intersection + list1 list2 + :test-not + #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + (not (eql x y)))))) + (4)) + +(deftest intersection.18 + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (block fail + (intersection + list1 list2 + :key #'identity + :test-not + #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + (not (eql x y)))))) + (4)) + +;;; Order of argument evaluation tests + +(deftest intersection.order.1 + (let ((i 0) x y) + (values + (intersection (progn (setf x (incf i)) (list 'a 'b)) + (progn (setf y (incf i)) (list 'c 'd))) + i x y)) + nil 2 1 2) + +(deftest intersection.order.2 + (let ((i 0) x y) + (values + (intersection (progn (setf x (incf i)) (list 'a 'b)) + (progn (setf y (incf i)) (list 'c 'd)) + :test #'eq) + i x y)) + nil 2 1 2) + +(deftest intersection.order.3 + (let ((i 0) x y z w) + (values + (intersection (progn (setf x (incf i)) (list 'a 'b)) + (progn (setf y (incf i)) (list 'c 'd)) + :test (progn (setf z (incf i)) #'eq) + :test (progn (setf w (incf i)) + (complement #'eq))) + i x y z w)) + nil 4 1 2 3 4) + +(deftest intersection.order.4 + (let ((i 0) x y z w) + (values + (intersection (progn (setf x (incf i)) (list 'a 'b)) + (progn (setf y (incf i)) (list 'c 'd)) + :test (progn (setf z (incf i)) #'eq) + :key (progn (setf w (incf i)) #'identity)) + i x y z w)) + nil 4 1 2 3 4) + +(deftest intersection.order.5 + (let ((i 0) x y z w) + (values + (intersection (progn (setf x (incf i)) (list 'a 'b)) + (progn (setf y (incf i)) (list 'c 'd)) + :key (progn (setf z (incf i)) #'identity) + :test (progn (setf w (incf i)) #'eq)) + i x y z w)) + nil 4 1 2 3 4) + + +;;; Keyword tests + +(deftest intersection.allow-other-keys.1 + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (intersection list1 list2 :bad t :allow-other-keys 1)) + (4)) + +(deftest intersection.allow-other-keys.2 + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (intersection list1 list2 :allow-other-keys :foo :also-bad t)) + (4)) + +(deftest intersectionallow-other-keys.3 + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (intersection list1 list2 :allow-other-keys :foo :also-bad t + :test #'(lambda (x y) (= x (1+ y))))) + nil) + +(deftest intersection.allow-other-keys.4 + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (intersection list1 list2 :allow-other-keys t)) + (4)) + +(deftest intersection.allow-other-keys.5 + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (intersection list1 list2 :allow-other-keys nil)) + (4)) + +(deftest intersection.allow-other-keys.6 + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (intersection list1 list2 :allow-other-keys t + :allow-other-keys nil :bad t)) + (4)) + +(deftest intersection.allow-other-keys.7 + (sort + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (intersection list1 list2 :allow-other-keys t + :allow-other-keys nil + :test #'(lambda (x y) (eql x (1- y))))) + #'<) + (3 4)) + +(deftest intersection.keywords.8 + (sort + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (intersection list1 list2 + :test #'(lambda (x y) (eql x (1- y))) + :test #'eql)) + #'<) + (3 4)) + +;;; Error tests + +(deftest intersection.error.1 + (classify-error (intersection)) + program-error) + +(deftest intersection.error.2 + (classify-error (intersection nil)) + program-error) + +(deftest intersection.error.3 + (classify-error (intersection nil nil :bad t)) + program-error) + +(deftest intersection.error.4 + (classify-error (intersection nil nil :key)) + program-error) + +(deftest intersection.error.5 + (classify-error (intersection nil nil 1 2)) + program-error) + +(deftest intersection.error.6 + (classify-error (intersection nil nil :bad t :allow-other-keys nil)) + program-error) + +(deftest intersection.error.7 + (classify-error (intersection '(a b c) '(d e f) :test #'identity)) + program-error) + +(deftest intersection.error.8 + (classify-error (intersection '(a b c) '(d e f) :test-not #'identity)) + program-error) + +(deftest intersection.error.9 + (classify-error (intersection '(a b c) '(d e f) :key #'cons)) + program-error) + +(deftest intersection.error.10 + (classify-error (intersection '(a b c) '(d e f) :key #'car)) + type-error) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; nintersection + +(deftest nintersection.1 + (nintersection nil nil) + nil) + +(deftest nintersection.2 + (nintersection (loop for i from 1 to 100 collect i) nil) + nil) + +(deftest nintersection.3 + (nintersection-with-check nil (loop for i from 1 to 100 collect i)) + nil) + +(deftest nintersection.4 + (let* ((x (copy-list '(a 1 c 7 b 4 3 z))) + (xc (copy-list x)) + (y (copy-list '(3 y c q z a 18))) + (result (nintersection-with-check xc y))) + (and + (not (eqt result 'failed)) + (+ + (loop for e in x count + (and (member e y) + (not (member e result)))) + (loop for e in result count + (or (not (member e x)) (not (member e y)))) + (loop for hd on result count + (and (consp hd) + (member (car hd) (cdr hd))))))) + 0) + +(deftest nintersection.5 + (let* ((x (copy-list '(a a a))) + (y (copy-list '(a a a b b b))) + (result (nintersection-with-check x y))) + (and + (not (eqt result 'failed)) + (member 'a result) + (not (member 'b result)))) + t) + +(deftest nintersection.6 + (nintersection-with-check + (list 1000000000000 'a 'b 'c) + (list (1+ 999999999999) 'd 'e 'f)) + (1000000000000)) + +(deftest nintersection.7 + (nintersection-with-check (list 'a 10 'b 17) + (list 'c 'd 4 'e 'f 10 1 13 'z)) + (10)) + +(deftest nintersection.8 + (nintersection-with-check + (list 'a (copy-seq "aaa") 'b) + (list 'd (copy-seq "aaa") 'e)) + nil) + +(deftest nintersection.9 + (nintersection-with-check + (list 'a (copy-seq "aaa") 'b) + (list 'd (copy-seq "aaa") 'e) + :test #'equal) + ("aaa")) + +(deftest nintersection.9-a + (nintersection-with-check + (list 'a (copy-seq "aaa") 'b) + (list 'd (copy-seq "aaa") 'e) + :test 'equal) + ("aaa")) + +(deftest nintersection.9-b + (nintersection + (list 'a (copy-seq "aaa") 'b) + (list 'd (copy-seq "aaa") 'e) + :test-not #'(lambda (p q) (not (equal p q)))) + ("aaa")) + +(deftest nintersection.10 + (equalt + (sort + (let ((result + (nintersection-with-check + (loop for i from 0 to 1000 by 3 collect i) + (loop for i from 0 to 1000 by 7 collect i)))) + (if (eqt result 'failed) () result)) + #'<) + (loop for i from 0 to 1000 by 21 collect i)) + t) + +(deftest nintersection.11 + (equalt + (sort + (let ((result + (nintersection-with-check + (loop for i from 0 to 999 by 5 collect i) + (loop for i from 0 to 999 by 7 collect i) + :test #'(lambda (a b) + (and (eql a b) + (= (mod a 3) 0)))))) + (if (eqt result 'failed) () result)) + #'<) + (loop + for i from 0 to 999 by (* 3 5 7) collect i)) + t) + +(deftest nintersection.12 + (nintersection-12-body 100 100) + nil) + +;; Key argument + +(deftest nintersection.13 + (let ((x '(0 5 8 13 31 42)) + (y (copy-list '(3 5 42 0 7 100 312 33)))) + (equalt + (sort (copy-list (nintersection + (copy-list x) y)) #'<) + (sort (copy-list (nintersection + (copy-list x) y :key #'1+)) #'<))) + t) + +;; Check that a nil key argument is ignored + +(deftest nintersection.14 + (let + ((result (nintersection + (copy-list '(a b c d)) + (copy-list '(e c f b g)) + :key nil))) + (and + (member 'b result) + (member 'c result) + (every #'(lambda (x) (member x '(b c))) result) + t)) + t) + +;; Test that nintersection preserves the order of arguments to :test, :test-not + +(deftest nintersection.15 + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (block fail + (nintersection + list1 list2 + :test + #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + (eql x y))))) + (4)) + +(deftest nintersection.16 + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (block fail + (nintersection + list1 list2 + :key #'identity + :test + #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + (eql x y))))) + (4)) + +(deftest nintersection.17 + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (block fail + (nintersection + list1 list2 + :test-not + #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + (not (eql x y)))))) + (4)) + +(deftest nintersection.18 + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (block fail + (nintersection + list1 list2 + :key #'identity + :test-not + #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + (not (eql x y)))))) + (4)) + +;;; Order of argument evaluation tests + +(deftest nintersection.order.1 + (let ((i 0) x y) + (values + (nintersection (progn (setf x (incf i)) (list 'a 'b)) + (progn (setf y (incf i)) (list 'c 'd))) + i x y)) + nil 2 1 2) + +(deftest nintersection.order.2 + (let ((i 0) x y) + (values + (nintersection (progn (setf x (incf i)) (list 'a 'b)) + (progn (setf y (incf i)) (list 'c 'd)) + :test #'eq) + i x y)) + nil 2 1 2) + +(deftest nintersection.order.3 + (let ((i 0) x y z w) + (values + (nintersection (progn (setf x (incf i)) (list 'a 'b)) + (progn (setf y (incf i)) (list 'c 'd)) + :test (progn (setf z (incf i)) #'eq) + :test (progn (setf w (incf i)) + (complement #'eq))) + i x y z w)) + nil 4 1 2 3 4) + +(deftest nintersection.order.4 + (let ((i 0) x y z w) + (values + (nintersection (progn (setf x (incf i)) (list 'a 'b)) + (progn (setf y (incf i)) (list 'c 'd)) + :test (progn (setf z (incf i)) #'eq) + :key (progn (setf w (incf i)) #'identity)) + i x y z w)) + nil 4 1 2 3 4) + +(deftest nintersection.order.5 + (let ((i 0) x y z w) + (values + (nintersection (progn (setf x (incf i)) (list 'a 'b)) + (progn (setf y (incf i)) (list 'c 'd)) + :key (progn (setf z (incf i)) #'identity) + :test (progn (setf w (incf i)) #'eq)) + i x y z w)) + nil 4 1 2 3 4) + +;;; Keyword tests + +(deftest nintersection.allow-other-keys.1 + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (nintersection list1 list2 :bad t :allow-other-keys 1)) + (4)) + +(deftest nintersection.allow-other-keys.2 + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (nintersection list1 list2 :allow-other-keys :foo :also-bad t)) + (4)) + +(deftest nintersection.allow-other-keys.3 + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (nintersection list1 list2 :allow-other-keys :foo :also-bad t + :test #'(lambda (x y) (= x (1+ y))))) + nil) + +(deftest nintersection.allow-other-keys.4 + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (nintersection list1 list2 :allow-other-keys t)) + (4)) + +(deftest nintersection.allow-other-keys.5 + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (nintersection list1 list2 :allow-other-keys nil)) + (4)) + +(deftest nintersection.allow-other-keys.6 + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (nintersection list1 list2 :allow-other-keys t + :allow-other-keys nil :bad t)) + (4)) + +(deftest nintersection.allow-other-keys.7 + (sort + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (nintersection list1 list2 :allow-other-keys t + :allow-other-keys nil + :test #'(lambda (x y) (eql x (1- y))))) + #'<) + (3 4)) + +(deftest nintersection.keywords.8 + (sort + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (nintersection list1 list2 + :test #'(lambda (x y) (eql x (1- y))) + :test #'eql)) + #'<) + (3 4)) + +(deftest nintersection.allow-other-keys.9 + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (nintersection list1 list2 :allow-other-keys :foo :also-bad t + :test #'(lambda (x y) (= x (1+ y))))) + nil) + +(deftest nintersection.error.1 + (classify-error (nintersection)) + program-error) + +(deftest nintersection.error.2 + (classify-error (nintersection nil)) + program-error) + +(deftest nintersection.error.3 + (classify-error (nintersection nil nil :bad t)) + program-error) + +(deftest nintersection.error.4 + (classify-error (nintersection nil nil :key)) + program-error) + +(deftest nintersection.error.5 + (classify-error (nintersection nil nil 1 2)) + program-error) + +(deftest nintersection.error.6 + (classify-error (nintersection nil nil :bad t :allow-other-keys nil)) + program-error) + +(deftest nintersection.error.7 + (classify-error (nintersection (list 1 2 3) (list 4 5 6) :test #'identity)) + program-error) + +(deftest nintersection.error.8 + (classify-error (nintersection (list 1 2 3) (list 4 5 6) :test-not #'identity)) + program-error) + +(deftest nintersection.error.9 + (classify-error (nintersection (list 1 2 3) (list 4 5 6) :key #'cons)) + program-error) + +(deftest nintersection.error.10 + (classify-error (nintersection (list 1 2 3) (list 4 5 6) :key #'car)) + type-error) diff --git a/ansi-tests/cons-test-20.lsp b/ansi-tests/cons-test-20.lsp new file mode 100644 index 0000000..6fc53be --- /dev/null +++ b/ansi-tests/cons-test-20.lsp @@ -0,0 +1,404 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 22:11:27 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 20 + +(in-package :cl-test) + +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; union + +(deftest union.1 + (union nil nil) + nil) + +(deftest union.2 + (union-with-check (list 'a) nil) + (a)) + +(deftest union.3 + (union-with-check (list 'a) (list 'a)) + (a)) + +(deftest union-4 + (union-with-check (list 1) (list 1)) + (1)) + +(deftest union.5 + (let ((x (list 'a 'b))) + (union-with-check (list x) (list x))) + ((a b))) + +(deftest union.6 + (let ((x (copy-list '(a b c d e f))) + (y (copy-list '(z c y a v b)))) + (let ((result (union-with-check x y))) + (check-union x y result))) + t) + +(deftest union.6-a + (let ((x (copy-list '(a b c d e f))) + (y (copy-list '(z c y a v b)))) + (let ((result (union-with-check x y :test #'eq))) + (check-union x y result))) + t) + +(deftest union.7 + (let ((x (copy-list '(a b c d e f))) + (y (copy-list '(z c y a v b)))) + (let ((result (union-with-check x y :test #'eql))) + (check-union x y result))) + t) + +(deftest union.8 + (let ((x (copy-list '(a b c d e f))) + (y (copy-list '(z c y a v b)))) + (let ((result (union-with-check x y :test #'equal))) + (check-union x y result))) + t) + +(deftest union.9 + (let ((x (copy-list '(a b c d e f))) + (y (copy-list '(z c y a v b)))) + (let ((result (union-with-check x y :test-not (complement #'eql)))) + (check-union x y result))) + t) + +(deftest union.10 + (let ((x (copy-list '(a b c d e f))) + (y (copy-list '(z c y a v b)))) + (let ((result (union-with-check x y :test-not (complement #'equal)))) + (check-union x y result))) + t) + +(deftest union.11 + (let ((x (copy-list '(a b c d e f))) + (y (copy-list '(z c y a v b)))) + (let ((result (union-with-check x y :test-not (complement #'eq)))) + (check-union x y result))) + t) + +(deftest union.12 + (let ((x (copy-list '(1 2 3 4 5 6 7))) + (y (copy-list '(10 19 5 3 17 1001 2)))) + (let ((result (union-with-check x y))) + (check-union x y result))) + t) + +(deftest union.13 + (let ((x (copy-list '(1 2 3 4 5 6 7))) + (y (copy-list '(10 19 5 3 17 1001 2)))) + (let ((result (union-with-check x y :test #'equal))) + (check-union x y result))) + t) + +(deftest union.14 + (let ((x (copy-list '(1 2 3 4 5 6 7))) + (y (copy-list '(10 19 5 3 17 1001 2)))) + (let ((result (union-with-check x y :test #'eql))) + (check-union x y result))) + t) + +(deftest union.15 + (let ((x (copy-list '(1 2 3 4 5 6 7))) + (y (copy-list '(10 19 5 3 17 1001 2)))) + (let ((result (union-with-check x y :test-not (complement #'equal)))) + (check-union x y result))) + t) + +(deftest union.16 + (let ((x (copy-list '(1 2 3 4 5 6 7))) + (y (copy-list '(10 19 5 3 17 1001 2)))) + (let ((result (union-with-check x y :test-not (complement #'eql)))) + (check-union x y result))) + t) + +(deftest union.17 + (let ((x (copy-list '(1 2 3 4 5 6 7))) + (y (copy-list '(10 19 5 3 17 1001 2)))) + (let ((result (union-with-check-and-key x y #'1+))) + (check-union x y result))) + t) + +(deftest union.18 + (let ((x (copy-list '(1 2 3 4 5 6 7))) + (y (copy-list '(10 19 5 3 17 1001 2)))) + (let ((result (union-with-check-and-key x y #'1+ :test #'equal))) + (check-union x y result))) + t) + +(deftest union.19 + (let ((x (copy-list '(1 2 3 4 5 6 7))) + (y (copy-list '(10 19 5 3 17 1001 2)))) + (let ((result (union-with-check-and-key x y #'1+ :test #'eql))) + (check-union x y result))) + t) + +(deftest union.20 + (let ((x (copy-list '(1 2 3 4 5 6 7))) + (y (copy-list '(10 19 5 3 17 1001 2)))) + (let ((result (union-with-check-and-key x y #'1+ + :test-not (complement #'equal)))) + (check-union x y result))) + t) + +(deftest union.21 + (let ((x (copy-list '(1 2 3 4 5 6 7))) + (y (copy-list '(10 19 5 3 17 1001 2)))) + (let ((result (union-with-check-and-key x y #'1+ + :test-not (complement #'equal)))) + (check-union x y result))) + t) + +(deftest union.22 + (let ((x (copy-list '(1 2 3 4 5 6 7))) + (y (copy-list '(10 19 5 3 17 1001 2)))) + (let ((result (union-with-check-and-key x y nil))) + (check-union x y result))) + t) + +(deftest union.23 + (let ((x (copy-list '(1 2 3 4 5 6 7))) + (y (copy-list '(10 19 5 3 17 1001 2)))) + (let ((result (union-with-check-and-key x y '1+))) + (check-union x y result))) + t) + +;; Do large numbers of random units + +(deftest union.24 + (do-random-unions 100 100 200) + nil) + +(deftest union.25 + (let ((x (shuffle '(1 4 6 10 45 101))) + (y (copy-list '(102 5 2 11 44 6)))) + (let ((result (union-with-check x y + :test #'(lambda (a b) + (<= (abs (- a b)) 1))))) + (and + (not (eqt result 'failed)) + (sort + (sublis + '((2 . 1) (5 . 4) (11 . 10) (45 . 44) (102 . 101)) + (copy-list result)) + #'<)))) + (1 4 6 10 44 101)) + +;;; Check that union uses eql, not equal or eq + +(deftest union.26 + (let ((x 1000) + (y 1000)) + (loop + while (not (typep x 'bignum)) + do (progn + (setf x (* x x)) + (setf y (* y y)))) + (notnot-mv + (or + (eqt x y) ;; if bignums are eq, the test is worthless + (eql (length + (union-with-check + (list x) (list x))) + 1)))) + t) + +(deftest union.27 + (union-with-check (list (copy-seq "aa")) + (list (copy-seq "aa"))) + ("aa" "aa")) + +;; Check that union does not reverse the arguments to :test, :test-not + +(deftest union.28 + (block fail + (sort + (union-with-check + (list 1 2 3) + (list 4 5 6) + :test #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + (eql x y))) + #'<)) + (1 2 3 4 5 6)) + +(deftest union.29 + (block fail + (sort + (union-with-check-and-key + (list 1 2 3) + (list 4 5 6) + #'identity + :test #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + (eql x y))) + #'<)) + (1 2 3 4 5 6)) + +(deftest union.30 + (block fail + (sort + (union-with-check + (list 1 2 3) + (list 4 5 6) + :test-not + #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + (not (eql x y)))) + #'<)) + (1 2 3 4 5 6)) + +(deftest union.31 + (block fail + (sort + (union-with-check-and-key + (list 1 2 3) + (list 4 5 6) + #'identity + :test-not #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + (not (eql x y)))) + #'<)) + (1 2 3 4 5 6)) + +;;; Order of evaluation tests + +(deftest union.order.1 + (let ((i 0) x y) + (values + (sort + (union (progn (setf x (incf i)) (copy-list '(1 3 5))) + (progn (setf y (incf i)) (copy-list '(2 5 8)))) + #'<) + i x y)) + (1 2 3 5 8) + 2 1 2) + +(deftest union.order.2 + (let ((i 0) x y z w) + (values + (sort + (union (progn (setf x (incf i)) (copy-list '(1 3 5))) + (progn (setf y (incf i)) (copy-list '(2 5 8))) + :test (progn (setf z (incf i)) #'eql) + :key (progn (setf w (incf i)) #'identity)) + #'<) + i x y z w)) + (1 2 3 5 8) + 4 1 2 3 4) + + +(deftest union.order.3 + (let ((i 0) x y z w) + (values + (sort + (union (progn (setf x (incf i)) (copy-list '(1 3 5))) + (progn (setf y (incf i)) (copy-list '(2 5 8))) + :key (progn (setf z (incf i)) #'identity) + :test (progn (setf w (incf i)) #'eql)) + #'<) + i x y z w)) + (1 2 3 5 8) + 4 1 2 3 4) + +;;; Keyword tests + +(deftest union.allow-other-keys.1 + (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2) :bad t + :allow-other-keys "yes") + #'<) + (1 2 5 7 9 10 11 20)) + +(deftest union.allow-other-keys.2 + (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2) + :allow-other-keys t :also-bad t) + #'<) + (1 2 5 7 9 10 11 20)) + +(deftest union.allow-other-keys.3 + (sort (union (list 1 2 3) (list 1 2 3) + :allow-other-keys t :also-bad t + :test #'(lambda (x y) (= x (+ y 100)))) + #'<) + (1 1 2 2 3 3)) + +(deftest union.allow-other-keys.4 + (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2) + :allow-other-keys t) + #'<) + (1 2 5 7 9 10 11 20)) + +(deftest union.allow-other-keys.5 + (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2) + :allow-other-keys nil) + #'<) + (1 2 5 7 9 10 11 20)) + +(deftest union.allow-other-keys.6 + (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2) + :allow-other-keys t + :allow-other-keys nil) + #'<) + (1 2 5 7 9 10 11 20)) + +(deftest union.allow-other-keys.7 + (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2) + :allow-other-keys t + :allow-other-keys nil + '#:x 1) + #'<) + (1 2 5 7 9 10 11 20)) + +(deftest union.keywords.9 + (sort (union (list 1 2 3) (list 1 2 3) + :test #'(lambda (x y) (= x (+ y 100))) + :test #'eql) + #'<) + (1 1 2 2 3 3)) + +;;; Error tests + +(deftest union.error.1 + (classify-error (union)) + program-error) + +(deftest union.error.2 + (classify-error (union nil)) + program-error) + +(deftest union.error.3 + (classify-error (union nil nil :bad t)) + program-error) + +(deftest union.error.4 + (classify-error (union nil nil :key)) + program-error) + +(deftest union.error.5 + (classify-error (union nil nil 1 2)) + program-error) + +(deftest union.error.6 + (classify-error (union nil nil :bad t :allow-other-keys nil)) + program-error) + +(deftest union.error.7 + (classify-error (union (list 1 2) (list 3 4) :test #'identity)) + program-error) + +(deftest union.error.8 + (classify-error (union (list 1 2) (list 3 4) :test-not #'identity)) + program-error) + +(deftest union.error.9 + (classify-error (union (list 1 2) (list 3 4) :key #'cons)) + program-error) + +(deftest union.error.10 + (classify-error (union (list 1 2) (list 3 4) :key #'car)) + type-error) + + diff --git a/ansi-tests/cons-test-21.lsp b/ansi-tests/cons-test-21.lsp new file mode 100644 index 0000000..9457df0 --- /dev/null +++ b/ansi-tests/cons-test-21.lsp @@ -0,0 +1,402 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 22:11:27 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 21 + +(in-package :cl-test) + +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; nunion + +(deftest nunion.1 + (nunion nil nil) + nil) + +(deftest nunion.2 + (nunion-with-copy (list 'a) nil) + (a)) + +(deftest nunion.3 + (nunion-with-copy (list 'a) (list 'a)) + (a)) + +(deftest nunion.4 + (nunion-with-copy (list 1) (list 1)) + (1)) + +(deftest nunion.5 + (let ((x (list 'a 'b))) + (nunion-with-copy (list x) (list x))) + ((a b))) + +(deftest nunion.6 + (let ((x '(a b c d e f)) + (y '(z c y a v b))) + (let ((result (nunion-with-copy x y))) + (check-union x y result))) + t) + +(deftest nunion.6-a + (let ((x '(a b c d e f)) + (y '(z c y a v b))) + (let ((result (nunion-with-copy x y :test #'eq))) + (check-union x y result))) + t) + +(deftest nunion.7 + (let ((x '(a b c d e f)) + (y '(z c y a v b))) + (let ((result (nunion-with-copy x y :test #'eql))) + (check-union x y result))) + t) + +(deftest nunion.8 + (let ((x '(a b c d e f)) + (y '(z c y a v b))) + (let ((result (nunion-with-copy x y :test #'equal))) + (check-union x y result))) + t) + +(deftest nunion.9 + (let ((x '(a b c d e f)) + (y '(z c y a v b))) + (let ((result (nunion-with-copy x y :test-not (complement #'eql)))) + (check-union x y result))) + t) + +(deftest nunion.10 + (let ((x '(a b c d e f)) + (y '(z c y a v b))) + (let ((result (nunion-with-copy x y :test-not (complement #'equal)))) + (check-union x y result))) + t) + +(deftest nunion.11 + (let ((x '(a b c d e f)) + (y '(z c y a v b))) + (let ((result (nunion-with-copy x y :test-not (complement #'eq)))) + (check-union x y result))) + t) + +(deftest nunion.12 + (let ((x '(1 2 3 4 5 6 7)) + (y '(10 19 5 3 17 1001 2))) + (let ((result (nunion-with-copy x y))) + (check-union x y result))) + t) + +(deftest nunion.13 + (let ((x '(1 2 3 4 5 6 7)) + (y '(10 19 5 3 17 1001 2))) + (let ((result (nunion-with-copy x y :test #'equal))) + (check-union x y result))) + t) + +(deftest nunion.14 + (let ((x '(1 2 3 4 5 6 7)) + (y '(10 19 5 3 17 1001 2))) + (let ((result (nunion-with-copy x y :test #'eql))) + (check-union x y result))) + t) + +(deftest nunion.15 + (let ((x '(1 2 3 4 5 6 7)) + (y '(10 19 5 3 17 1001 2))) + (let ((result (nunion-with-copy x y :test-not (complement #'equal)))) + (check-union x y result))) + t) + +(deftest nunion.16 + (let ((x '(1 2 3 4 5 6 7)) + (y '(10 19 5 3 17 1001 2))) + (let ((result (nunion-with-copy x y :test-not (complement #'eql)))) + (check-union x y result))) + t) + +(deftest nunion.17 + (let ((x '(1 2 3 4 5 6 7)) + (y '(10 19 5 3 17 1001 2))) + (let ((result (nunion-with-copy-and-key x y #'1+))) + (check-union x y result))) + t) + +(deftest nunion.18 + (let ((x '(1 2 3 4 5 6 7)) + (y '(10 19 5 3 17 1001 2))) + (let ((result (nunion-with-copy-and-key x y #'1+ :test #'equal))) + (check-union x y result))) + t) + +(deftest nunion.19 + (let ((x '(1 2 3 4 5 6 7)) + (y '(10 19 5 3 17 1001 2))) + (let ((result (nunion-with-copy-and-key x y #'1+ :test #'eql))) + (check-union x y result))) + t) + +(deftest nunion.20 + (let ((x '(1 2 3 4 5 6 7)) + (y '(10 19 5 3 17 1001 2))) + (let ((result (nunion-with-copy-and-key x y #'1+ + :test-not (complement #'equal)))) + (check-union x y result))) + t) + +(deftest nunion.21 + (let ((x '(1 2 3 4 5 6 7)) + (y '(10 19 5 3 17 1001 2))) + (let ((result (nunion-with-copy-and-key x y #'1+ + :test-not (complement #'equal)))) + (check-union x y result))) + t) + +(deftest nunion.22 + (let ((x '(1 2 3 4 5 6 7)) + (y '(10 19 5 3 17 1001 2))) + (let ((result (nunion-with-copy-and-key x y nil))) + (check-union x y result))) + t) + +(deftest nunion.23 + (let ((x '(1 2 3 4 5 6 7)) + (y '(10 19 5 3 17 1001 2))) + (let ((result (nunion-with-copy-and-key x y '1+))) + (check-union x y result))) + t) + +;; Do large numbers of random nunions + +(deftest nunion.24 + (do-random-nunions 100 100 200) + nil) + +(deftest nunion.25 + (let ((x (shuffle '(1 4 6 10 45 101))) + (y '(102 5 2 11 44 6))) + (let ((result (nunion-with-copy x y + :test #'(lambda (a b) + (<= (abs (- a b)) 1))))) + (sort + (sublis + '((2 . 1) (5 . 4) (11 . 10) (45 . 44) (102 . 101)) + (copy-list result)) + #'<))) + (1 4 6 10 44 101)) + +;; Check that nunion uses eql, not equal or eq + +(deftest nunion.26 + (let ((x 1000) + (y 1000)) + (loop + while (not (typep x 'bignum)) + do (progn + (setf x (* x x)) + (setf y (* y y)))) + (notnot-mv + (or + (eqt x y) ;; if bignums are eq, the test is worthless + (eql (length + (nunion-with-copy (list x) (list x))) + 1)))) + t) + +(deftest nunion.27 + (nunion-with-copy (list (copy-seq "aa")) + (list (copy-seq "aa"))) + ("aa" "aa")) + + + +;; Check that nunion does not reverse the arguments to :test, :test-not + +(deftest nunion.28 + (block fail + (sort + (nunion-with-copy + '(1 2 3) + '(4 5 6) + :test #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + (eql x y))) + #'<)) + (1 2 3 4 5 6)) + +(deftest nunion.29 + (block fail + (sort + (nunion-with-copy-and-key + '(1 2 3) + '(4 5 6) + #'identity + :test #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + (eql x y))) + #'<)) + (1 2 3 4 5 6)) + +(deftest nunion.30 + (block fail + (sort + (nunion-with-copy + '(1 2 3) + '(4 5 6) + :test-not + #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + (not (eql x y)))) + #'<)) + (1 2 3 4 5 6)) + +(deftest nunion.31 + (block fail + (sort + (nunion-with-copy-and-key + '(1 2 3) + '(4 5 6) + #'identity + :test-not #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + (not (eql x y)))) + #'<)) + (1 2 3 4 5 6)) + +;;; Order of evaluation tests + +(deftest nunion.order.1 + (let ((i 0) x y) + (values + (sort + (nunion (progn (setf x (incf i)) (copy-list '(1 3 5))) + (progn (setf y (incf i)) (copy-list '(2 5 8)))) + #'<) + i x y)) + (1 2 3 5 8) + 2 1 2) + +(deftest nunion.order.2 + (let ((i 0) x y z w) + (values + (sort + (nunion (progn (setf x (incf i)) (copy-list '(1 3 5))) + (progn (setf y (incf i)) (copy-list '(2 5 8))) + :test (progn (setf z (incf i)) #'eql) + :key (progn (setf w (incf i)) #'identity)) + #'<) + i x y z w)) + (1 2 3 5 8) + 4 1 2 3 4) + + +(deftest nunion.order.3 + (let ((i 0) x y z w) + (values + (sort + (nunion (progn (setf x (incf i)) (copy-list '(1 3 5))) + (progn (setf y (incf i)) (copy-list '(2 5 8))) + :key (progn (setf z (incf i)) #'identity) + :test (progn (setf w (incf i)) #'eql)) + #'<) + i x y z w)) + (1 2 3 5 8) + 4 1 2 3 4) + +;;; Keyword tests + +(deftest nunion.allow-other-keys.1 + (sort (nunion (list 7 9 1 5) (list 10 11 9 20 1 2) :bad t + :allow-other-keys "yes") + #'<) + (1 2 5 7 9 10 11 20)) + +(deftest nunion.allow-other-keys.2 + (sort (nunion (list 7 9 1 5) (list 10 11 9 20 1 2) + :allow-other-keys t :also-bad t) + #'<) + (1 2 5 7 9 10 11 20)) + +(deftest nunion.allow-other-keys.3 + (sort (nunion (list 1 2 3) (list 1 2 3) + :allow-other-keys t :also-bad t + :test #'(lambda (x y) (= x (+ y 100)))) + #'<) + (1 1 2 2 3 3)) + +(deftest nunion.allow-other-keys.4 + (sort (nunion (list 7 9 1 5) (list 10 11 9 20 1 2) + :allow-other-keys t) + #'<) + (1 2 5 7 9 10 11 20)) + +(deftest nunion.allow-other-keys.5 + (sort (nunion (list 7 9 1 5) (list 10 11 9 20 1 2) + :allow-other-keys nil) + #'<) + (1 2 5 7 9 10 11 20)) + +(deftest nunion.allow-other-keys.6 + (sort (nunion (list 7 9 1 5) (list 10 11 9 20 1 2) + :allow-other-keys t + :allow-other-keys nil) + #'<) + (1 2 5 7 9 10 11 20)) + +(deftest nunion.allow-other-keys.7 + (sort (nunion (list 7 9 1 5) (list 10 11 9 20 1 2) + :allow-other-keys t + :allow-other-keys nil + '#:x 1) + #'<) + (1 2 5 7 9 10 11 20)) + +(deftest nunion.keywords.9 + (sort (nunion (list 1 2 3) (list 1 2 3) + :test #'(lambda (x y) (= x (+ y 100))) + :test #'eql) + #'<) + (1 1 2 2 3 3)) + +;;; Error tests + +(deftest nunion.error.1 + (classify-error (nunion)) + program-error) + +(deftest nunion.error.2 + (classify-error (nunion nil)) + program-error) + +(deftest nunion.error.3 + (classify-error (nunion nil nil :bad t)) + program-error) + +(deftest nunion.error.4 + (classify-error (nunion nil nil :key)) + program-error) + +(deftest nunion.error.5 + (classify-error (nunion nil nil 1 2)) + program-error) + +(deftest nunion.error.6 + (classify-error (nunion nil nil :bad t :allow-other-keys nil)) + program-error) + +(deftest nunion.error.7 + (classify-error (nunion (list 1 2) (list 3 4) :test #'identity)) + program-error) + +(deftest nunion.error.8 + (classify-error (nunion (list 1 2) (list 3 4) :test-not #'identity)) + program-error) + +(deftest nunion.error.9 + (classify-error (nunion (list 1 2) (list 3 4) :key #'cons)) + program-error) + +(deftest nunion.error.10 + (classify-error (nunion (list 1 2) (list 3 4) :key #'car)) + type-error) + diff --git a/ansi-tests/cons-test-22.lsp b/ansi-tests/cons-test-22.lsp new file mode 100644 index 0000000..380d1d4 --- /dev/null +++ b/ansi-tests/cons-test-22.lsp @@ -0,0 +1,613 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Mon Mar 30 22:10:34 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 22 + +(in-package :cl-test) + +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; set-difference + +(deftest set-difference.1 + (set-difference nil nil) + nil) + +(deftest set-difference.2 + (let ((result + (set-difference-with-check '(a b c) nil))) + (check-set-difference '(a b c) nil result)) + t) + +(deftest set-difference.3 + (let ((result + (set-difference-with-check '(a b c d e f) '(f b d)))) + (check-set-difference '(a b c d e f) '(f b d) result)) + t) + +(deftest set-difference.4 + (sort + (copy-list + (set-difference-with-check (shuffle '(1 2 3 4 5 6 7 8)) + '(10 101 4 74 2 1391 7 17831))) + #'<) + (1 3 5 6 8)) + +(deftest set-difference.5 + (set-difference-with-check nil '(a b c d e f g h)) + nil) + +(deftest set-difference.6 + (set-difference-with-check '(a b c d e) '(d a b e) + :key nil) + (c)) + +(deftest set-difference.7 + (set-difference-with-check '(a b c d e) '(d a b e) :test #'eq) + (c)) + +(deftest set-difference.8 + (set-difference-with-check '(a b c d e) '(d a b e) :test #'eql) + (c)) + +(deftest set-difference.9 + (set-difference-with-check '(a b c d e) '(d a b e) :test #'equal) + (c)) + +(deftest set-difference.10 + (set-difference-with-check '(a b c d e) '(d a b e) + :test 'eq) + (c)) + +(deftest set-difference.11 + (set-difference-with-check '(a b c d e) '(d a b e) + :test 'eql) + (c)) + +(deftest set-difference.12 + (set-difference-with-check '(a b c d e) '(d a b e) + :test 'equal) + (c)) + +(deftest set-difference.13 + (do-random-set-differences 100 100) + nil) + +(deftest set-difference.14 + (set-difference-with-check '((a . 1) (b . 2) (c . 3)) + '((a . 1) (c . 3)) + :key 'car) + ((b . 2))) + +(deftest set-difference.15 + (set-difference-with-check '((a . 1) (b . 2) (c . 3)) + '((a . 1) (c . 3)) + :key #'car) + ((b . 2))) + +;; +;; Verify that the :test argument is called with the arguments +;; in the correct order +;; +(deftest set-difference.16 + (block fail + (sort + (copy-list + (set-difference-with-check + '(1 2 3 4) '(e f g h) + :test #'(lambda (x y) + (when (or (member x '(e f g h)) + (member y '(1 2 3 4))) + (return-from fail 'fail)) + (eqt x y)))) + #'<)) + (1 2 3 4)) + +(deftest set-difference.17 + (block fail + (sort + (copy-list + (set-difference-with-check + '(1 2 3 4) '(e f g h) + :key #'identity + :test #'(lambda (x y) + (when (or (member x '(e f g h)) + (member y '(1 2 3 4))) + (return-from fail 'fail)) + (eqt x y)))) + #'<)) + (1 2 3 4)) + +(deftest set-difference.18 + (block fail + (sort + (copy-list + (set-difference-with-check + '(1 2 3 4) '(e f g h) + :test-not + #'(lambda (x y) + (when (or (member x '(e f g h)) + (member y '(1 2 3 4))) + (return-from fail 'fail)) + (not (eqt x y))))) + #'<)) + (1 2 3 4)) + +(deftest set-difference.19 + (block fail + (sort + (copy-list + (set-difference-with-check + '(1 2 3 4) '(e f g h) + :test-not + #'(lambda (x y) + (when (or (member x '(e f g h)) + (member y '(1 2 3 4))) + (return-from fail 'fail)) + (not (eqt x y))))) + #'<)) + (1 2 3 4)) + +;;; Order of argument evaluation tests + +(deftest set-difference.order.1 + (let ((i 0) x y) + (values + (set-difference (progn (setf x (incf i)) (list 1 2 3 4)) + (progn (setf y (incf i)) (list 2 3 4))) + i x y)) + (1) 2 1 2) + +(deftest set-difference.order.2 + (let ((i 0) x y z) + (values + (set-difference (progn (setf x (incf i)) (list 1 2 3 4)) + (progn (setf y (incf i)) (list 2 3 4)) + :test (progn (setf z (incf i)) + #'(lambda (x y) (= x (1- y))))) + i x y z)) + (4) 3 1 2 3) + +(deftest set-difference.order.3 + (let ((i 0) x y z w) + (values + (set-difference (progn (setf x (incf i)) (list 1 2 3 4)) + (progn (setf y (incf i)) (list 2 3 4)) + :test (progn (setf z (incf i)) + #'(lambda (x y) (= x (1- y)))) + :key (progn (setf w (incf i)) nil)) + i x y z w)) + (4) 4 1 2 3 4) + + +;;; Keyword tests + +(deftest set-difference.allow-other-keys.1 + (sort + (copy-list + (set-difference + (list 1 2 3 4 5) (list 2 3 4) + :bad t :allow-other-keys t)) + #'<) + (1 5)) + +(deftest set-difference.allow-other-keys.2 + (sort + (copy-list + (set-difference + (list 1 2 3 4 5) (list 2 3 4) + :allow-other-keys t :bad t)) + #'<) + (1 5)) + +(deftest set-difference.allow-other-keys.3 + (sort + (copy-list + (set-difference + (list 1 2 3 4 5) (list 2 3 4) + :allow-other-keys t :bad t :test #'(lambda (x y) (= x (1- y))))) + #'<) + (4 5)) + +(deftest set-difference.allow-other-keys.4 + (sort + (copy-list + (set-difference + (list 1 2 3 4 5) (list 2 3 4) + :allow-other-keys t)) + #'<) + (1 5)) + +(deftest set-difference.allow-other-keys.5 + (sort + (copy-list + (set-difference + (list 1 2 3 4 5) (list 2 3 4) + :allow-other-keys nil)) + #'<) + (1 5)) + +(deftest set-difference.allow-other-keys.6 + (sort + (copy-list + (set-difference + (list 1 2 3 4 5) (list 2 3 4) + :allow-other-keys t + :allow-other-keys nil)) + #'<) + (1 5)) + +(deftest set-difference.allow-other-keys.7 + (sort + (copy-list + (set-difference + (list 1 2 3 4 5) (list 2 3 4) + :allow-other-keys t + :allow-other-keys nil + '#:x 1)) + #'<) + (1 5)) + +(deftest set-difference.keywords.8 + (sort + (copy-list + (set-difference + (list 1 2 3 4 5) (list 2 3 4) + :test #'eql :test (complement #'eql))) + #'<) + (1 5)) + +(deftest set-difference.keywords.9 + (sort + (copy-list + (set-difference + (list 1 2 3 4 5) (list 2 3 4) + :test (complement #'eql) :test #'eql)) + #'<) + nil) + +;;; Error tests + + +(deftest set-difference.error.1 + (classify-error (set-difference)) + program-error) + +(deftest set-difference.error.2 + (classify-error (set-difference nil)) + program-error) + +(deftest set-difference.error.3 + (classify-error (set-difference nil nil :bad t)) + program-error) + +(deftest set-difference.error.4 + (classify-error (set-difference nil nil :key)) + program-error) + +(deftest set-difference.error.5 + (classify-error (set-difference nil nil 1 2)) + program-error) + +(deftest set-difference.error.6 + (classify-error (set-difference nil nil :bad t :allow-other-keys nil)) + program-error) + +(deftest set-difference.error.7 + (classify-error (set-difference (list 1 2) (list 3 4) :test #'identity)) + program-error) + +(deftest set-difference.error.8 + (classify-error (set-difference (list 1 2) (list 3 4) :test-not #'identity)) + program-error) + +(deftest set-difference.error.9 + (classify-error (set-difference (list 1 2) (list 3 4) :key #'cons)) + program-error) + +(deftest set-difference.error.10 + (classify-error (set-difference (list 1 2) (list 3 4) :key #'car)) + type-error) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; nset-difference + +(deftest nset-difference.1 + (nset-difference nil nil) + nil) + +(deftest nset-difference.2 + (let ((result + (nset-difference-with-check '(a b c) nil))) + (check-nset-difference '(a b c) nil result)) + t) + +(deftest nset-difference.3 + (let ((result + (nset-difference-with-check '(a b c d e f) '(f b d)))) + (check-nset-difference '(a b c d e f) '(f b d) result)) + t) + +(deftest nset-difference.4 + (sort + (copy-list + (nset-difference-with-check (shuffle '(1 2 3 4 5 6 7 8)) + '(10 101 4 74 2 1391 7 17831))) + #'<) + (1 3 5 6 8)) + +(deftest nset-difference.5 + (nset-difference-with-check nil '(a b c d e f g h)) + nil) + +(deftest nset-difference.6 + (nset-difference-with-check '(a b c d e) '(d a b e) + :key nil) + (c)) + +(deftest nset-difference.7 + (nset-difference-with-check '(a b c d e) '(d a b e) :test #'eq) + (c)) + +(deftest nset-difference.8 + (nset-difference-with-check '(a b c d e) '(d a b e) :test #'eql) + (c)) + +(deftest nset-difference.9 + (nset-difference-with-check '(a b c d e) '(d a b e) :test #'equal) + (c)) + +(deftest nset-difference.10 + (nset-difference-with-check '(a b c d e) '(d a b e) + :test 'eq) + (c)) + +(deftest nset-difference.11 + (nset-difference-with-check '(a b c d e) '(d a b e) + :test 'eql) + (c)) + +(deftest nset-difference.12 + (nset-difference-with-check '(a b c d e) '(d a b e) + :test 'equal) + (c)) + +(deftest nset-difference.13 + (do-random-nset-differences 100 100) + nil) + +(deftest nset-difference.14 + (nset-difference-with-check '((a . 1) (b . 2) (c . 3)) + '((a . 1) (c . 3)) + :key 'car) + ((b . 2))) + +(deftest nset-difference.15 + (nset-difference-with-check '((a . 1) (b . 2) (c . 3)) + '((a . 1) (c . 3)) + :key #'car) + ((b . 2))) + +;; +;; Verify that the :test argument is called with the arguments +;; in the correct order +;; +(deftest nset-difference.16 + (block fail + (sort + (copy-list + (nset-difference-with-check + '(1 2 3 4) '(e f g h) + :test #'(lambda (x y) + (when (or (member x '(e f g h)) + (member y '(1 2 3 4))) + (return-from fail 'fail)) + (eqt x y)))) + #'<)) + (1 2 3 4)) + +(deftest nset-difference.17 + (block fail + (sort + (copy-list + (nset-difference-with-check + '(1 2 3 4) '(e f g h) + :key #'identity + :test #'(lambda (x y) + (when (or (member x '(e f g h)) + (member y '(1 2 3 4))) + (return-from fail 'fail)) + (eqt x y)))) + #'<)) + (1 2 3 4)) + +(deftest nset-difference.18 + (block fail + (sort + (copy-list + (nset-difference-with-check + '(1 2 3 4) '(e f g h) + :test-not + #'(lambda (x y) + (when (or (member x '(e f g h)) + (member y '(1 2 3 4))) + (return-from fail 'fail)) + (not (eqt x y))))) + #'<)) + (1 2 3 4)) + +(deftest nset-difference.19 + (block fail + (sort (copy-list + (nset-difference-with-check + '(1 2 3 4) '(e f g h) + :test-not + #'(lambda (x y) + (when (or (member x '(e f g h)) + (member y '(1 2 3 4))) + (return-from fail 'fail)) + (not (eqt x y))))) + #'<)) + (1 2 3 4)) + +;;; Order of argument evaluation tests + +(deftest nset-difference.order.1 + (let ((i 0) x y) + (values + (nset-difference (progn (setf x (incf i)) (list 1 2 3 4)) + (progn (setf y (incf i)) (list 2 3 4))) + i x y)) + (1) 2 1 2) + +(deftest nset-difference.order.2 + (let ((i 0) x y z) + (values + (nset-difference (progn (setf x (incf i)) (list 1 2 3 4)) + (progn (setf y (incf i)) (list 2 3 4)) + :test (progn (setf z (incf i)) + #'(lambda (x y) (= x (1- y))))) + i x y z)) + (4) 3 1 2 3) + +(deftest nset-difference.order.3 + (let ((i 0) x y z w) + (values + (nset-difference (progn (setf x (incf i)) (list 1 2 3 4)) + (progn (setf y (incf i)) (list 2 3 4)) + :test (progn (setf z (incf i)) + #'(lambda (x y) (= x (1- y)))) + :key (progn (setf w (incf i)) nil)) + i x y z w)) + (4) 4 1 2 3 4) + + +;;; Keyword tests + +(deftest nset-difference.allow-other-keys.1 + (sort + (copy-list + (nset-difference + (list 1 2 3 4 5) (list 2 3 4) + :bad t :allow-other-keys t)) + #'<) + (1 5)) + +(deftest nset-difference.allow-other-keys.2 + (sort + (copy-list + (nset-difference + (list 1 2 3 4 5) (list 2 3 4) + :allow-other-keys t :bad t)) + #'<) + (1 5)) + +(deftest nset-difference.allow-other-keys.3 + (sort + (copy-list + (nset-difference + (list 1 2 3 4 5) (list 2 3 4) + :allow-other-keys t :bad t :test #'(lambda (x y) (= x (1- y))))) + #'<) + (4 5)) + +(deftest nset-difference.allow-other-keys.4 + (sort + (copy-list + (nset-difference + (list 1 2 3 4 5) (list 2 3 4) + :allow-other-keys t)) + #'<) + (1 5)) + +(deftest nset-difference.allow-other-keys.5 + (sort + (copy-list + (nset-difference + (list 1 2 3 4 5) (list 2 3 4) + :allow-other-keys nil)) + #'<) + (1 5)) + +(deftest nset-difference.allow-other-keys.6 + (sort + (copy-list + (nset-difference + (list 1 2 3 4 5) (list 2 3 4) + :allow-other-keys t + :allow-other-keys nil)) + #'<) + (1 5)) + +(deftest nset-difference.allow-other-keys.7 + (sort + (copy-list + (nset-difference + (list 1 2 3 4 5) (list 2 3 4) + :allow-other-keys t + :allow-other-keys nil + '#:x 1)) + #'<) + (1 5)) + +(deftest nset-difference.keywords.8 + (sort + (copy-list + (nset-difference + (list 1 2 3 4 5) (list 2 3 4) + :test #'eql :test (complement #'eql))) + #'<) + (1 5)) + +(deftest nset-difference.keywords.9 + (sort + (copy-list + (nset-difference + (list 1 2 3 4 5) (list 2 3 4) + :test (complement #'eql) :test #'eql)) + #'<) + nil) + +;;; Error tests + +(deftest nset-difference.error.1 + (classify-error (nset-difference)) + program-error) + +(deftest nset-difference.error.2 + (classify-error (nset-difference nil)) + program-error) + +(deftest nset-difference.error.3 + (classify-error (nset-difference nil nil :bad t)) + program-error) + +(deftest nset-difference.error.4 + (classify-error (nset-difference nil nil :key)) + program-error) + +(deftest nset-difference.error.5 + (classify-error (nset-difference nil nil 1 2)) + program-error) + +(deftest nset-difference.error.6 + (classify-error (nset-difference nil nil :bad t :allow-other-keys nil)) + program-error) + +(deftest nset-difference.error.7 + (classify-error (nset-difference (list 1 2) (list 3 4) :test #'identity)) + program-error) + +(deftest nset-difference.error.8 + (classify-error (nset-difference (list 1 2) (list 3 4) :test-not #'identity)) + program-error) + +(deftest nset-difference.error.9 + (classify-error (nset-difference (list 1 2) (list 3 4) :key #'cons)) + program-error) + +(deftest nset-difference.error.10 + (classify-error (nset-difference (list 1 2) (list 3 4) :key #'car)) + type-error) diff --git a/ansi-tests/cons-test-23.lsp b/ansi-tests/cons-test-23.lsp new file mode 100644 index 0000000..53cb224 --- /dev/null +++ b/ansi-tests/cons-test-23.lsp @@ -0,0 +1,693 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Apr 1 21:49:43 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 23 + +(in-package :cl-test) + +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; set-exclusive-or + +(deftest set-exclusive-or.1 + (set-exclusive-or nil nil) + nil) + +(deftest set-exclusive-or.2 + (let ((result + (set-exclusive-or-with-check '(a b c) nil))) + (check-set-exclusive-or '(a b c) nil result)) + t) + +(deftest set-exclusive-or.3 + (let ((result + (set-exclusive-or-with-check '(a b c d e f) '(f b d)))) + (check-set-exclusive-or '(a b c d e f) '(f b d) result)) + t) + +(deftest set-exclusive-or.4 + (sort + (copy-list + (set-exclusive-or-with-check (shuffle '(1 2 3 4 5 6 7 8)) + '(10 101 4 74 2 1391 7 17831))) + #'<) + (1 3 5 6 8 10 74 101 1391 17831)) + +(deftest set-exclusive-or.5 + (check-set-exclusive-or + nil + '(a b c d e f g h) + (set-exclusive-or-with-check nil '(a b c d e f g h))) + t) + +(deftest set-exclusive-or.6 + (set-exclusive-or-with-check '(a b c d e) '(d a b e) + :key nil) + (c)) + +(deftest set-exclusive-or.7 + (set-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'eq) + (c)) + +(deftest set-exclusive-or.7-a + (set-exclusive-or-with-check '(d a b e) '(a b c d e) :test #'eq) + (c)) + +(deftest set-exclusive-or.8 + (set-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'eql) + (c)) + +(deftest set-exclusive-or.8-a + (set-exclusive-or-with-check '(e d b a) '(a b c d e) :test #'eql) + (c)) + +(deftest set-exclusive-or.8-b + (set-exclusive-or-with-check '(a b c d e) '(d a b e) + :test-not (complement #'eql)) + (c)) + +(deftest set-exclusive-or.9 + (set-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'equal) + (c)) + +(deftest set-exclusive-or.10 + (set-exclusive-or-with-check '(a b c d e) '(d a b e) + :test 'eq) + (c)) + +(deftest set-exclusive-or.11 + (set-exclusive-or-with-check '(a b c d e) '(d a b e) + :test 'eql) + (c)) + +(deftest set-exclusive-or.12 + (set-exclusive-or-with-check '(a b c d e) '(d a b e) + :test 'equal) + (c)) + +(deftest set-exclusive-or.13 + (do-random-set-exclusive-ors 100 100) + nil) + +(deftest set-exclusive-or.14 + (set-exclusive-or-with-check '((a . 1) (b . 2) (c . 3012)) + '((a . 10) (c . 3)) + :key 'car) + ((b . 2))) + +(deftest set-exclusive-or.15 + (set-exclusive-or-with-check '((a . xx) (b . 2) (c . 3)) + '((a . 1) (c . 3313)) + :key #'car) + ((b . 2))) + +(deftest set-exclusive-or.16 + (set-exclusive-or-with-check '((a . xx) (b . 2) (c . 3)) + '((a . 1) (c . 3313)) + :key #'car + :test-not (complement #'eql)) + ((b . 2))) + +;; +;; Check that set-exclusive-or does not invert +;; the order of the arguments to the test function +;; +(deftest set-exclusive-or.17 + (let ((list1 '(a b c d)) + (list2 '(e f g h))) + (block fail + (notnot-mv + (set-exclusive-or-with-check + list1 list2 + :test #'(lambda (s1 s2) + (when (or (member s1 list2) + (member s2 list1)) + (return-from fail 'failed))))))) + t) + +(deftest set-exclusive-or.17-a + (let ((list1 '(a b c d)) + (list2 '(e f g h))) + (block fail + (notnot-mv + (set-exclusive-or-with-check + list1 list2 + :key #'identity + :test #'(lambda (s1 s2) + (when (or (member s1 list2) + (member s2 list1)) + (return-from fail 'failed))))))) + t) + +(deftest set-exclusive-or.18 + (let ((list1 '(a b c d)) + (list2 '(e f g h))) + (block fail + (notnot-mv + (set-exclusive-or-with-check + list1 list2 + :test-not + #'(lambda (s1 s2) + (when (or (member s1 list2) + (member s2 list1)) + (return-from fail 'failed)) + t))))) + t) + +(deftest set-exclusive-or.18-a + (let ((list1 '(a b c d)) + (list2 '(e f g h))) + (block fail + (notnot-mv + (set-exclusive-or-with-check + list1 list2 + :key #'identity + :test-not + #'(lambda (s1 s2) + (when (or (member s1 list2) + (member s2 list1)) + (return-from fail 'failed)) + t))))) + t) + +;;; Order of argument evaluation tests + +(deftest set-exclusive-or.order.1 + (let ((i 0) x y) + (values + (sort + (set-exclusive-or (progn (setf x (incf i)) + (list 1 2 3 4)) + (progn (setf y (incf i)) + (list 1 3 6 10))) + #'<) + i x y)) + (2 4 6 10) 2 1 2) + +(deftest set-exclusive-or.order.2 + (let ((i 0) x y z) + (values + (sort + (set-exclusive-or (progn (setf x (incf i)) + (list 1 2 3 4)) + (progn (setf y (incf i)) + (list 1 3 6 10)) + :test (progn (setf z (incf i)) + #'eql)) + #'<) + i x y z)) + (2 4 6 10) 3 1 2 3) + +(deftest set-exclusive-or.order.3 + (let ((i 0) x y z w) + (values + (sort + (set-exclusive-or (progn (setf x (incf i)) + (list 1 2 3 4)) + (progn (setf y (incf i)) + (list 1 3 6 10)) + :test (progn (setf z (incf i)) + #'eql) + :key (progn (setf w (incf i)) nil)) + #'<) + i x y z w)) + (2 4 6 10) 4 1 2 3 4) + +(deftest set-exclusive-or.order.4 + (let ((i 0) x y z w) + (values + (sort + (set-exclusive-or (progn (setf x (incf i)) + (list 1 2 3 4)) + (progn (setf y (incf i)) + (list 1 3 6 10)) + :key (progn (setf z (incf i)) nil) + :test (progn (setf w (incf i)) + #'eql)) + #'<) + i x y z w)) + (2 4 6 10) 4 1 2 3 4) + +(deftest set-exclusive-or.order.5 + (let ((i 0) x y z w) + (values + (sort + (set-exclusive-or (progn (setf x (incf i)) + (list 1 2 3 4)) + (progn (setf y (incf i)) + (list 1 3 6 10)) + :key (progn (setf z (incf i)) nil) + :key (progn (setf w (incf i)) + (complement #'eql))) + #'<) + i x y z w)) + (2 4 6 10) 4 1 2 3 4) + + +;;; Keyword tests + +(deftest set-exclusive.allow-other-keys.1 + (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) + :bad t :allow-other-keys t) + #'<) + (1 2 5 6)) + +(deftest set-exclusive.allow-other-keys.2 + (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) + :allow-other-keys t :bad t) + #'<) + (1 2 5 6)) + +(deftest set-exclusive.allow-other-keys.3 + (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) + :allow-other-keys t :bad t + :test #'(lambda (x y) (= x (1- y)))) + #'<) + (1 6)) + +(deftest set-exclusive.allow-other-keys.4 + (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) + :allow-other-keys t) + #'<) + (1 2 5 6)) + +(deftest set-exclusive.allow-other-keys.5 + (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) + :allow-other-keys nil) + #'<) + (1 2 5 6)) + +(deftest set-exclusive.allow-other-keys.6 + (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) + :allow-other-keys t + :allow-other-keys nil) + #'<) + (1 2 5 6)) + +(deftest set-exclusive.allow-other-keys.7 + (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) + :allow-other-keys t + :allow-other-keys nil + '#:x 1) + #'<) + (1 2 5 6)) + +(deftest set-exclusive.keywords.8 + (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) + :test #'eql + :test #'/=) + #'<) + (1 2 5 6)) + +(deftest set-exclusive.keywords.9 + (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) + :test #'/= + :test #'eql) + #'<) + nil) + +(deftest set-exclusive-or.error.1 + (classify-error (set-exclusive-or)) + program-error) + +(deftest set-exclusive-or.error.2 + (classify-error (set-exclusive-or nil)) + program-error) + +(deftest set-exclusive-or.error.3 + (classify-error (set-exclusive-or nil nil :bad t)) + program-error) + +(deftest set-exclusive-or.error.4 + (classify-error (set-exclusive-or nil nil :key)) + program-error) + +(deftest set-exclusive-or.error.5 + (classify-error (set-exclusive-or nil nil 1 2)) + program-error) + +(deftest set-exclusive-or.error.6 + (classify-error (set-exclusive-or nil nil :bad t :allow-other-keys nil)) + program-error) + +(deftest set-exclusive-or.error.7 + (classify-error (set-exclusive-or (list 1 2) (list 3 4) :test #'identity)) + program-error) + +(deftest set-exclusive-or.error.8 + (classify-error (set-exclusive-or (list 1 2) (list 3 4) :test-not #'identity)) + program-error) + +(deftest set-exclusive-or.error.9 + (classify-error (set-exclusive-or (list 1 2) (list 3 4) :key #'cons)) + program-error) + +(deftest set-exclusive-or.error.10 + (classify-error (set-exclusive-or (list 1 2) (list 3 4) :key #'car)) + type-error) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; nset-exclusive-or + +(deftest nset-exclusive-or.1 + (nset-exclusive-or nil nil) + nil) + +(deftest nset-exclusive-or.2 + (let ((result + (nset-exclusive-or-with-check '(a b c) nil))) + (check-set-exclusive-or '(a b c) nil result)) + t) + +(deftest nset-exclusive-or.3 + (let ((result + (nset-exclusive-or-with-check '(a b c d e f) '(f b d)))) + (check-set-exclusive-or '(a b c d e f) '(f b d) result)) + t) + +(deftest nset-exclusive-or.4 + (sort + (copy-list + (nset-exclusive-or-with-check (shuffle '(1 2 3 4 5 6 7 8)) + '(10 101 4 74 2 1391 7 17831))) + #'<) + (1 3 5 6 8 10 74 101 1391 17831)) + +(deftest nset-exclusive-or.5 + (check-set-exclusive-or + nil + '(a b c d e f g h) + (nset-exclusive-or-with-check nil '(a b c d e f g h))) + t) + +(deftest nset-exclusive-or.6 + (nset-exclusive-or-with-check '(a b c d e) '(d a b e) + :key nil) + (c)) + +(deftest nset-exclusive-or.7 + (nset-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'eq) + (c)) + +(deftest nset-exclusive-or.7-a + (nset-exclusive-or-with-check '(d a b e) '(a b c d e) :test #'eq) + (c)) + +(deftest nset-exclusive-or.8 + (nset-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'eql) + (c)) + +(deftest nset-exclusive-or.8-a + (nset-exclusive-or-with-check '(e d b a) '(a b c d e) :test #'eql) + (c)) + +(deftest nset-exclusive-or.8-b + (nset-exclusive-or-with-check '(a b c d e) '(d a b e) + :test-not (complement #'eql)) + (c)) + +(deftest nset-exclusive-or.9 + (nset-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'equal) + (c)) + +(deftest nset-exclusive-or.10 + (nset-exclusive-or-with-check '(a b c d e) '(d a b e) + :test 'eq) + (c)) + +(deftest nset-exclusive-or.11 + (nset-exclusive-or-with-check '(a b c d e) '(d a b e) + :test 'eql) + (c)) + +(deftest nset-exclusive-or.12 + (nset-exclusive-or-with-check '(a b c d e) '(d a b e) + :test 'equal) + (c)) + +(deftest nset-exclusive-or.13 + (do-random-nset-exclusive-ors 100 100) + nil) + +(deftest nset-exclusive-or.14 + (nset-exclusive-or-with-check '((a . 1) (b . 2) (c . 3012)) + '((a . 10) (c . 3)) + :key 'car) + ((b . 2))) + +(deftest nset-exclusive-or.15 + (nset-exclusive-or-with-check '((a . xx) (b . 2) (c . 3)) + '((a . 1) (c . 3313)) + :key #'car) + ((b . 2))) + +(deftest nset-exclusive-or.16 + (nset-exclusive-or-with-check '((a . xx) (b . 2) (c . 3)) + '((a . 1) (c . 3313)) + :key #'car + :test-not (complement #'eql)) + ((b . 2))) + +;; +;; Check that nset-exclusive-or does not invert +;; the order of the arguments to the test function +;; +(deftest nset-exclusive-or.17 + (let ((list1 '(a b c d)) + (list2 '(e f g h))) + (block fail + (notnot-mv + (nset-exclusive-or-with-check + list1 list2 + :test #'(lambda (s1 s2) + (when (or (member s1 list2) + (member s2 list1)) + (return-from fail 'failed))))))) + t) + +(deftest nset-exclusive-or.17-a + (let ((list1 '(a b c d)) + (list2 '(e f g h))) + (block fail + (notnot-mv + (nset-exclusive-or-with-check + list1 list2 + :key #'identity + :test #'(lambda (s1 s2) + (when (or (member s1 list2) + (member s2 list1)) + (return-from fail 'failed))))))) + t) + +(deftest nset-exclusive-or.18 + (let ((list1 '(a b c d)) + (list2 '(e f g h))) + (block fail + (notnot-mv + (nset-exclusive-or-with-check + list1 list2 + :test-not + #'(lambda (s1 s2) + (when (or (member s1 list2) + (member s2 list1)) + (return-from fail 'failed)) + t))))) + t) + +(deftest nset-exclusive-or.18-a + (let ((list1 '(a b c d)) + (list2 '(e f g h))) + (block fail + (notnot-mv + (nset-exclusive-or-with-check + list1 list2 + :key #'identity + :test-not + #'(lambda (s1 s2) + (when (or (member s1 list2) + (member s2 list1)) + (return-from fail 'failed)) + t))))) + t) + +;;; Order of argument evaluation tests + +(deftest nset-exclusive-or.order.1 + (let ((i 0) x y) + (values + (sort + (nset-exclusive-or (progn (setf x (incf i)) + (list 1 2 3 4)) + (progn (setf y (incf i)) + (list 1 3 6 10))) + #'<) + i x y)) + (2 4 6 10) 2 1 2) + +(deftest nset-exclusive-or.order.2 + (let ((i 0) x y z) + (values + (sort + (nset-exclusive-or (progn (setf x (incf i)) + (list 1 2 3 4)) + (progn (setf y (incf i)) + (list 1 3 6 10)) + :test (progn (setf z (incf i)) + #'eql)) + #'<) + i x y z)) + (2 4 6 10) 3 1 2 3) + +(deftest nset-exclusive-or.order.3 + (let ((i 0) x y z w) + (values + (sort + (nset-exclusive-or (progn (setf x (incf i)) + (list 1 2 3 4)) + (progn (setf y (incf i)) + (list 1 3 6 10)) + :test (progn (setf z (incf i)) + #'eql) + :key (progn (setf w (incf i)) nil)) + #'<) + i x y z w)) + (2 4 6 10) 4 1 2 3 4) + +(deftest nset-exclusive-or.order.4 + (let ((i 0) x y z w) + (values + (sort + (nset-exclusive-or (progn (setf x (incf i)) + (list 1 2 3 4)) + (progn (setf y (incf i)) + (list 1 3 6 10)) + :key (progn (setf z (incf i)) nil) + :test (progn (setf w (incf i)) + #'eql)) + #'<) + i x y z w)) + (2 4 6 10) 4 1 2 3 4) + +(deftest nset-exclusive-or.order.5 + (let ((i 0) x y z w) + (values + (sort + (nset-exclusive-or (progn (setf x (incf i)) + (list 1 2 3 4)) + (progn (setf y (incf i)) + (list 1 3 6 10)) + :key (progn (setf z (incf i)) nil) + :key (progn (setf w (incf i)) + (complement #'eql))) + #'<) + i x y z w)) + (2 4 6 10) 4 1 2 3 4) + + +;;; Keyword tests + +(deftest nset-exclusive.allow-other-keys.1 + (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) + :bad t :allow-other-keys t) + #'<) + (1 2 5 6)) + +(deftest nset-exclusive.allow-other-keys.2 + (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) + :allow-other-keys t :bad t) + #'<) + (1 2 5 6)) + +(deftest nset-exclusive.allow-other-keys.3 + (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) + :allow-other-keys t :bad t + :test #'(lambda (x y) (= x (1- y)))) + #'<) + (1 6)) + +(deftest nset-exclusive.allow-other-keys.4 + (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) + :allow-other-keys t) + #'<) + (1 2 5 6)) + +(deftest nset-exclusive.allow-other-keys.5 + (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) + :allow-other-keys nil) + #'<) + (1 2 5 6)) + +(deftest nset-exclusive.allow-other-keys.6 + (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) + :allow-other-keys t + :allow-other-keys nil) + #'<) + (1 2 5 6)) + +(deftest nset-exclusive.allow-other-keys.7 + (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) + :allow-other-keys t + :allow-other-keys nil + '#:x 1) + #'<) + (1 2 5 6)) + +(deftest nset-exclusive.keywords.8 + (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) + :test #'eql + :test #'/=) + #'<) + (1 2 5 6)) + +(deftest nset-exclusive.keywords.9 + (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) + :test #'/= + :test #'eql) + #'<) + nil) + +;;; Error tests + +(deftest nset-exclusive-or.error.1 + (classify-error (nset-exclusive-or)) + program-error) + +(deftest nset-exclusive-or.error.2 + (classify-error (nset-exclusive-or nil)) + program-error) + +(deftest nset-exclusive-or.error.3 + (classify-error (nset-exclusive-or nil nil :bad t)) + program-error) + +(deftest nset-exclusive-or.error.4 + (classify-error (nset-exclusive-or nil nil :key)) + program-error) + +(deftest nset-exclusive-or.error.5 + (classify-error (nset-exclusive-or nil nil 1 2)) + program-error) + +(deftest nset-exclusive-or.error.6 + (classify-error (nset-exclusive-or nil nil :bad t :allow-other-keys nil)) + program-error) + +(deftest nset-exclusive-or.error.7 + (classify-error (nset-exclusive-or (list 1 2) (list 3 4) :test #'identity)) + program-error) + +(deftest nset-exclusive-or.error.8 + (classify-error (nset-exclusive-or (list 1 2) (list 3 4) :test-not #'identity)) + program-error) + +(deftest nset-exclusive-or.error.9 + (classify-error (nset-exclusive-or (list 1 2) (list 3 4) :key #'cons)) + program-error) + +(deftest nset-exclusive-or.error.10 + (classify-error (nset-exclusive-or (list 1 2) (list 3 4) :key #'car)) + type-error) + diff --git a/ansi-tests/cons-test-24.lsp b/ansi-tests/cons-test-24.lsp new file mode 100644 index 0000000..04b07cd --- /dev/null +++ b/ansi-tests/cons-test-24.lsp @@ -0,0 +1,250 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Apr 1 22:10:54 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 24 + +(in-package :cl-test) + +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; subsetp + +(defvar cons-test-24-var '(78 "z" (8 9))) + +(deftest subsetp.1 + (subsetp-with-check (copy-tree '(78)) cons-test-24-var) + t) + +(deftest subsetp.2 + (subsetp-with-check (copy-tree '((8 9))) cons-test-24-var) + nil) + +(deftest subsetp.3 + (subsetp-with-check (copy-tree '((8 9))) + cons-test-24-var :test 'equal) + t) + +(deftest subsetp.4 + (subsetp-with-check (list 78 (copy-seq "Z")) cons-test-24-var + :test #'equalp) + t) + +(deftest subsetp.5 + (subsetp-with-check (list 1) (list 0 2 3 4) + :key #'(lambda (i) (floor (/ i 2)))) + t) + +(deftest subsetp.6 + (subsetp-with-check (list 1 6) (list 0 2 3 4) + :key #'(lambda (i) (floor (/ i 2)))) + nil) + +(deftest subsetp.7 + (subsetp-with-check (list '(a . 10) '(b . 20) '(c . 30)) + (list '(z . c) '(a . y) '(b . 100) '(e . f) + '(c . foo)) + :key #'car) + t) + +(deftest subsetp.8 + (subsetp-with-check (copy-tree '((a . 10) (b . 20) (c . 30))) + (copy-tree '((z . c) (a . y) (b . 100) (e . f) + (c . foo))) + :key 'car) + t) + +(deftest subsetp.9 + (subsetp-with-check (list 'a 'b 'c) + (copy-tree + (list '(z . c) '(a . y) '(b . 100) '(e . f) + '(c . foo))) + :test #'(lambda (e1 e2) + (eqt e1 (car e2)))) + t) + +(deftest subsetp.10 + (subsetp-with-check (list 'a 'b 'c) + (copy-tree + (list '(z . c) '(a . y) '(b . 100) '(e . f) + '(c . foo))) + :test #'(lambda (e1 e2) + (eqt e1 (car e2))) + :key nil) + t) + +(deftest subsetp.11 + (subsetp-with-check (list 'a 'b 'c) + (copy-tree + (list '(z . c) '(a . y) '(b . 100) '(e . f) + '(c . foo))) + :test-not #'(lambda (e1 e2) + (not (eqt e1 (car e2))))) + t) + +;; Check that it maintains order of arguments + +(deftest subsetp.12 + (block fail + (subsetp-with-check + (list 1 2 3) + (list 4 5 6) + :test #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + t))) + t) + +(deftest subsetp.13 + (block fail + (subsetp-with-check + (list 1 2 3) + (list 4 5 6) + :key #'identity + :test #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + t))) + t) + +(deftest subsetp.14 + (block fail + (subsetp-with-check + (list 1 2 3) + (list 4 5 6) + :test-not #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + nil))) + t) + +(deftest subsetp.15 + (block fail + (subsetp-with-check + (list 1 2 3) + (list 4 5 6) + :key #'identity + :test-not #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + nil))) + t) + +;;; Order of argument evaluation tests + +(deftest subsetp.order.1 + (let ((i 0) x y) + (values + (notnot (subsetp (progn (setf x (incf i)) + '(a b c)) + (progn (setf y (incf i)) + '(a b c d)))) + i x y)) + t 2 1 2) + +(deftest subsetp.order.2 + (let ((i 0) x y z w) + (values + (notnot (subsetp (progn (setf x (incf i)) + '(a b c)) + (progn (setf y (incf i)) + '(a b c d)) + :test (progn (setf z (incf i)) #'eql) + :key (progn (setf w (incf i)) nil))) + i x y z w)) + t 4 1 2 3 4) + +(deftest subsetp.order.3 + (let ((i 0) x y z w) + (values + (notnot (subsetp (progn (setf x (incf i)) + '(a b c)) + (progn (setf y (incf i)) + '(a b c d)) + :key (progn (setf z (incf i)) nil) + :test (progn (setf w (incf i)) #'eql))) + i x y z w)) + t 4 1 2 3 4) + +;;; Keyword tests + +(deftest subsetp.allow-other-keys.1 + (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4 5) :bad t :allow-other-keys 67)) + t) + +(deftest subsetp.allow-other-keys.2 + (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4 5) + :allow-other-keys #'cons :bad t)) + t) + +(deftest subsetp.allow-other-keys.3 + (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4) + :allow-other-keys (make-hash-table) + :bad t + :test #'(lambda (x y) (= (1+ x) y)))) + nil) + +(deftest subsetp.allow-other-keys.4 + (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4 5) :allow-other-keys t)) + t) + +(deftest subsetp.allow-other-keys.5 + (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4 5) :allow-other-keys nil)) + t) + +(deftest subsetp.allow-other-keys.6 + (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4 5) + :allow-other-keys t :bad1 t + :allow-other-keys nil :bad2 t)) + t) + +(deftest subsetp.keywords.7 + (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4) + :test #'(lambda (x y) (= (1+ x) y)) + :test #'eql)) + nil) + +(deftest subsetp.keywords.8 + (notnot-mv (subsetp '(1 2 3 4 10) '(0 1 2 3 4) + :key nil + :key #'(lambda (x) (mod x 2)))) + nil) + + +;;; Error tests + +(deftest subsetp.error.1 + (classify-error (subsetp)) + program-error) + +(deftest subsetp.error.2 + (classify-error (subsetp nil)) + program-error) + +(deftest subsetp.error.3 + (classify-error (subsetp nil nil :bad t)) + program-error) + +(deftest subsetp.error.4 + (classify-error (subsetp nil nil :key)) + program-error) + +(deftest subsetp.error.5 + (classify-error (subsetp nil nil 1 2)) + program-error) + +(deftest subsetp.error.6 + (classify-error (subsetp nil nil :bad t :allow-other-keys nil)) + program-error) + +(deftest subsetp.error.7 + (classify-error (subsetp (list 1 2) (list 3 4) :test #'identity)) + program-error) + +(deftest subsetp.error.8 + (classify-error (subsetp (list 1 2) (list 3 4) :test-not #'identity)) + program-error) + +(deftest subsetp.error.9 + (classify-error (subsetp (list 1 2) (list 3 4) :key #'cons)) + program-error) + +(deftest subsetp.error.10 + (classify-error (subsetp (list 1 2) (list 3 4) :key #'car)) + type-error) \ No newline at end of file diff --git a/ansi-tests/cons-test-25.lsp b/ansi-tests/cons-test-25.lsp new file mode 100644 index 0000000..baa1544 --- /dev/null +++ b/ansi-tests/cons-test-25.lsp @@ -0,0 +1,56 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Apr 5 22:26:59 1998 +;;;; Contains: Testing of CL Features related to "CONS", part 25 + +(in-package :cl-test) + +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; setting of C*R accessors + +(loop + for fn in '(car cdr caar cadr cdar cddr + caaar caadr cadar caddr cdaar cdadr cddar cdddr + caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr + cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr) + do + (let ((level (- (length (symbol-name fn)) 2))) + (eval `(deftest ,(intern + (concatenate 'string + (symbol-name fn) + "-SET-ALT") + :cl-test) + (let ((x (create-c*r-test ,level))) + (and + (setf (,fn x) 'a) + (eql (,fn x) 'a) + (setf (,fn x) 'none) + (equal x (create-c*r-test ,level)) + )) + t)))) + +(loop + for (fn len) in '((first 1) (second 2) (third 3) (fourth 4) + (fifth 5) (sixth 6) (seventh 7) (eighth 8) + (ninth 9) (tenth 10)) + do + (eval + `(deftest ,(intern + (concatenate 'string + (symbol-name fn) + "-SET-ALT") + :cl-test) + (let ((x (make-list 20 :initial-element nil))) + (and + (setf (,fn x) 'a) + (loop + for i from 1 to 20 + do (when (and (not (eql i ,len)) + (nth (1- i) x)) + (return nil)) + finally (return t)) + (eql (,fn x) 'a) + (nth ,(1- len) x))) + a))) diff --git a/ansi-tests/constantly.lsp b/ansi-tests/constantly.lsp new file mode 100644 index 0000000..59d7143 --- /dev/null +++ b/ansi-tests/constantly.lsp @@ -0,0 +1,37 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Oct 6 19:47:16 2002 +;;;; Contains: Tests for CONSTANTLY + +(in-package :cl-test) + +(deftest constantly.1 + (let ((fn (cl:constantly 10)) + (x nil)) + (loop for i from 0 to (min 256 (1- call-arguments-limit)) + always (prog1 (eql (apply fn x) 10) + (push 'a x)))) + t) + +(deftest constantly.2 + (notnot-mv (cl:constantly 1)) + t) + +(deftest constantly.3 + (let ((i 0)) + (let ((fn (cl:constantly (progn (incf i) 'a)))) + (values + i + (mapcar fn '(1 2 3 4)) + i))) + 1 (a a a a) 1) + +(deftest constantly.error.1 + (classify-error (cl:constantly)) + program-error) + +;;; The next test fails in CMUCL, which has non-conformantly extended +;;; the syntax of constantly. +(deftest constantly.error.2 + (classify-error (cl:constantly 1 1)) + program-error) diff --git a/ansi-tests/constantp.lsp b/ansi-tests/constantp.lsp new file mode 100644 index 0000000..99556a2 --- /dev/null +++ b/ansi-tests/constantp.lsp @@ -0,0 +1,84 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Mon Jan 13 19:12:17 2003 +;;;; Contains: Tests for CONSTANTP + +;;; See also defconstant.lsp + +(in-package :cl-test) + +(deftest constantp.error.1 + (classify-error (constantp)) + program-error) + +(deftest constantp.error.2 + (classify-error (constantp nil nil nil)) + program-error) + + +(deftest constantp.1 + (loop for e in *universe* + when (and (not (symbolp e)) + (not (consp e)) + (not (constantp e))) + collect e) + nil) + +(deftest constantp.2 + (notnot-mv (constantp t)) + t) + +(deftest constantp.3 + (notnot-mv (constantp nil)) + t) + +(deftest constantp.4 + (notnot-mv (constantp :foo)) + t) + +(deftest constantp.5 + (constantp (gensym)) + nil) + +(defconstant constantp-test-symbol 1) + +(defmacro constantp-macro (form &environment env) + (notnot-mv (constantp form env))) + +(deftest constantp.6 + (constantp-macro constantp-test-symbol) + t) + +(deftest constantp.7 + (constantp '(incf x)) + nil) + +(deftest constantp.8 + (notnot-mv (constantp 1 nil)) + t) + +(deftest constantp.9 + (notnot-mv (constantp ''(((foo))))) + t) + +(deftest constantp.10 + (notnot-mv (constantp 'pi)) + t) + +(deftest constantp.order.1 + (let ((i 0)) + (values + (notnot (constantp (progn (incf i) 1))) + i)) + t 1) + +(deftest constantp.order.2 + (let ((i 0) x y) + (values + (notnot (constantp (progn (setf x (incf i)) 1) + (progn (setf y (incf i)) nil))) + i x y)) + t 2 1 2) + + + diff --git a/ansi-tests/copy-seq.lsp b/ansi-tests/copy-seq.lsp new file mode 100644 index 0000000..bb2cd1e --- /dev/null +++ b/ansi-tests/copy-seq.lsp @@ -0,0 +1,187 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Nov 2 21:38:08 2002 +;;;; Contains: Tests for COPY-SEQ + +(in-package :cl-test) + +;;; This function is extensively used elsewhere, but is tested again +;;; here for completeness. + +(deftest copy-seq.1 + (copy-seq nil) + nil) + +(deftest copy-seq.2 + (let* ((s1 '(a b c)) + (s2 (check-values (copy-seq s1)))) + (and (not (eql s1 s2)) + (equalt s1 s2))) + t) + +(deftest copy-seq.3 + (let* ((s1 #(a b c)) + (s2 (check-values (copy-seq s1)))) + (and (not (eql s1 s2)) s2)) + #(a b c)) + +(deftest copy-seq.4 + (let* ((s1 (make-array '(4) :initial-contents '(a b c d) + :adjustable t)) + (s2 (check-values (copy-seq s1)))) + (and (not (eql s1 s2)) + (simple-vector-p s2) + s2)) + #(a b c d)) + + +(deftest copy-seq.5 + (let* ((s1 (make-array '(4) :initial-contents '(a b c d) + :fill-pointer 3)) + (s2 (check-values (copy-seq s1)))) + (and (not (eql s1 s2)) + (simple-vector-p s2) + s2)) + #(a b c)) + +(deftest copy-seq.6 + (let* ((a1 (make-array '(6) :initial-contents '(a b c d e f))) + (a2 (make-array '(4) :displaced-to a1 + :displaced-index-offset 1)) + (s2 (check-values (copy-seq a2)))) + (and (not (eql a2 s2)) + (simple-vector-p s2) + s2)) + #(b c d e)) + +(deftest copy-seq.7 + (let* ((s1 (make-array '(4) + :element-type 'base-char + :initial-contents '(#\a #\b #\c #\d) + :adjustable t)) + (s2 (check-values (copy-seq s1)))) + (and (not (eql s1 s2)) + (simple-string-p s2) + s2)) + "abcd") + + +(deftest copy-seq.8 + (let* ((s1 (make-array '(4) + :element-type 'base-char + :initial-contents '(#\a #\b #\c #\d) + :fill-pointer 3)) + (s2 (check-values (copy-seq s1)))) + (and (not (eql s1 s2)) + (simple-string-p s2) + s2)) + "abc") + +(deftest copy-seq.9 + (let* ((a1 (make-array '(6) :initial-contents '(#\a #\b #\c #\d #\e #\f) + :element-type 'base-char)) + (a2 (make-array '(4) :displaced-to a1 + :element-type 'base-char + :displaced-index-offset 1)) + (s2 (check-values (copy-seq a2)))) + (and (not (eql a2 s2)) + (simple-string-p s2) + s2)) + "bcde") + +(deftest copy-seq.10 + (let*((s1 "abcd") + (s2 (check-values (copy-seq s1)))) + (and (not (eql s1 s2)) + s2)) + "abcd") + +(deftest copy-seq.11 + (let* ((s1 #*0010110) + (s2 (check-values (copy-seq s1)))) + (and (not (eql s1 s2)) + (simple-bit-vector-p s2) + s2)) + #*0010110) + +(deftest copy-seq.12 + (let* ((s1 (make-array '(4) :initial-contents '(0 0 1 0) + :element-type 'bit + :adjustable t)) + (s2 (check-values (copy-seq s1)))) + (and (not (eql s1 s2)) + (simple-bit-vector-p s2) + s2)) + #*0010) + +(deftest copy-seq.13 + (let* ((s1 (make-array '(4) :initial-contents '(0 0 1 0) + :element-type 'bit + :fill-pointer 3)) + (s2 (check-values (copy-seq s1)))) + (and (not (eql s1 s2)) + (simple-bit-vector-p s2) + s2)) + #*001) + +(deftest copy-seq.14 + (let* ((a1 (make-array '(6) :initial-contents '(0 0 1 0 1 1) + :element-type 'bit)) + (a2 (make-array '(4) :displaced-to a1 + :displaced-index-offset 1 + :element-type 'bit)) + (s2 (check-values (copy-seq a2)))) + (and (not (eql a2 s2)) + (simple-bit-vector-p s2) + s2)) + #*0101) + +(deftest copy-seq.15 + (copy-seq "") + "") + +(deftest copy-seq.16 + (copy-seq #*) + #*) + +(deftest copy-seq.17 + (copy-seq #()) + #()) + +(deftest copy-seq.18 + (let* ((x (make-array '(10) :initial-contents '(a b c d e f g h i j))) + (y (check-values (copy-seq x)))) + (equal-array x y)) + t) + +(deftest copy-seq.order.1 + (let ((i 0)) + (values (copy-seq (progn (incf i) "abc")) i)) + "abc" 1) + +;;; Error tests + +(deftest copy-seq.error.1 + (classify-error (copy-seq 10)) + type-error) + +(deftest copy-seq.error.2 + (classify-error (copy-seq 'a)) + type-error) + +(deftest copy-seq.error.3 + (classify-error (copy-seq 13.21)) + type-error) + +(deftest copy-seq.error.4 + (classify-error (copy-seq)) + program-error) + +(deftest copy-seq.error.5 + (classify-error (copy-seq "abc" 2 nil)) + program-error) + +(deftest copy-seq.error.6 + (classify-error (locally (copy-seq 10) t)) + type-error) + diff --git a/ansi-tests/count-if-not.lsp b/ansi-tests/count-if-not.lsp new file mode 100644 index 0000000..bdcf63d --- /dev/null +++ b/ansi-tests/count-if-not.lsp @@ -0,0 +1,540 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Aug 20 22:42:35 2002 +;;;; Contains: Tests for COUNT-IF-NOT + +(in-package :cl-test) + +(deftest count-if-not-list.1 + (count-if-not #'identity '(a b nil c d nil e)) + 2) + +(deftest count-if-not-list.2 + (count-if-not #'not '(a b nil c d nil e)) + 5) + +(deftest count-if-not-list.3 + (count-if-not #'(lambda (x) (break)) nil) + 0) + +(deftest count-if-not-list.4 + (count-if-not #'identity '(a b nil c d nil e) :key #'identity) + 2) + +(deftest count-if-not-list.5 + (count-if-not 'identity '(a b nil c d nil e) :key #'identity) + 2) + +(deftest count-if-not-list.6 + (count-if-not #'identity '(a b nil c d nil e) :key 'identity) + 2) + +(deftest count-if-not-list.8 + (count-if-not #'identity '(a b nil c d nil e) :key 'not) + 5) + +(deftest count-if-not-list.9 + (count-if-not #'oddp '(1 2 3 4 4 1 8 10 1)) + 5) + +(deftest count-if-not-list.10 + (count-if-not #'oddp '(1 2 3 4 4 1 8 10 1) :key #'1+) + 4) + +(deftest count-if-not-list.11 + (let ((c 0)) + (count-if-not #'oddp '(1 2 3 4 4 1 8 10 1) + :key #'(lambda (x) (+ x (incf c))))) + 6) + +(deftest count-if-not-list.12 + (let ((c 0)) + (count-if-not #'oddp '(0 1 2 3 4 4 1 7 10 1) + :from-end t + :key #'(lambda (x) (+ x (incf c))))) + 8) + +(deftest count-if-not-list.13 + (count-if-not #'(lambda (x) (not (eqt x 'a))) + '(a b c d a e f a e f f a a) :start 2) + 4) + +(deftest count-if-not-list.14 + (count-if-not #'(lambda (x) (not (eqt x 'a))) + '(a b c d a e f a e f f a a) :end 7) + 2) + +(deftest count-if-not-list.15 + (count-if-not #'(lambda (x) (not (eqt x 'a))) + '(a b c d a e f a e f f a a) :end 7 + :start 2) + 1) + +(deftest count-if-not-list.16 + (count-if-not #'(lambda (x) (not (eqt x 'a))) + '(a b c d a e f a e f f a a) :end 7 + :start 2 :from-end t) + 1) + + +;;; tests on vectors + +(deftest count-if-not-vector.1 + (count-if-not #'identity #(a b nil c d nil e)) + 2) + +(deftest count-if-not-vector.2 + (count-if-not #'not #(a b nil c d nil e)) + 5) + +(deftest count-if-not-vector.3 + (count-if-not #'(lambda (x) (break)) #()) + 0) + +(deftest count-if-not-vector.4 + (count-if-not #'not #(a b nil c d nil e) :key #'identity) + 5) + +(deftest count-if-not-vector.5 + (count-if-not 'not #(a b nil c d nil e) :key #'identity) + 5) + +(deftest count-if-not-vector.6 + (count-if-not #'not #(a b nil c d nil e) :key 'identity) + 5) + +(deftest count-if-not-vector.8 + (count-if-not #'not #(a b nil c d nil e) :key 'not) + 2) + +(deftest count-if-not-vector.9 + (count-if-not #'oddp #(1 2 3 4 4 1 8 10 1)) + 5) + +(deftest count-if-not-vector.10 + (count-if-not #'oddp #(1 2 3 4 4 1 8 10 1) :key #'1+) + 4) + +(deftest count-if-not-vector.11 + (let ((c 0)) + (count-if-not #'oddp #(1 2 3 4 4 1 8 10 1) + :key #'(lambda (x) (+ x (incf c))))) + 6) + +(deftest count-if-not-vector.12 + (let ((c 0)) + (count-if-not #'oddp #(0 1 2 3 4 4 1 7 10 1) + :from-end t + :key #'(lambda (x) (+ x (incf c))))) + 8) + +(deftest count-if-not-vector.13 + (count-if-not #'(lambda (x) (not (eqt x 'a))) + #(a b c d a e f a e f f a a) :start 2) + 4) + +(deftest count-if-not-vector.14 + (count-if-not #'(lambda (x) (not (eqt x 'a))) + #(a b c d a e f a e f f a a) :end 7) + 2) + +(deftest count-if-not-vector.15 + (count-if-not #'(lambda (x) (not (eqt x 'a))) + #(a b c d a e f a e f f a a) :end 7 + :start 2) + 1) + +(deftest count-if-not-vector.16 + (count-if-not #'(lambda (x) (not (eqt x 'a))) + #(a b c d a e f a e f f a a) :end 7 + :start 2 :from-end t) + 1) + +;;; Non-simple vectors + +(deftest count-if-not-nonsimple-vector.1 + (count-if-not #'identity (make-array 7 :initial-contents '(a b nil c d nil e) + :fill-pointer t + :adjustable t)) + 2) + +(deftest count-if-not-nonsimple-vector.2 + (count-if-not #'not (make-array 7 :initial-contents '(a b nil c d nil e) + :fill-pointer t + :adjustable t)) + 5) + +(deftest count-if-not-nonsimple-vector.3 + (count-if-not #'(lambda (x) (break)) (make-array 0 + :fill-pointer t + :adjustable t)) + 0) + +(deftest count-if-not-nonsimple-vector.4 + (count-if-not #'not + (make-array 7 :initial-contents '(a b nil c d nil e) + :fill-pointer t + :adjustable t) + :key #'identity) + 5) + +(deftest count-if-not-nonsimple-vector.5 + (count-if-not 'not + (make-array 7 :initial-contents '(a b nil c d nil e) + :fill-pointer t + :adjustable t) + :key #'identity) + 5) + +(deftest count-if-not-nonsimple-vector.6 + (count-if-not #'not + (make-array 7 :initial-contents '(a b nil c d nil e) + :fill-pointer t + :adjustable t) + :key 'identity) + 5) + +(deftest count-if-not-nonsimple-vector.8 + (count-if-not #'not + (make-array 7 :initial-contents '(a b nil c d nil e) + :fill-pointer t + :adjustable t) + :key 'not) + 2) + +(deftest count-if-not-nonsimple-vector.9 + (count-if-not #'oddp (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) + :fill-pointer t :adjustable t)) + 5) + +(deftest count-if-not-nonsimple-vector.10 + (count-if-not #'oddp + (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) + :fill-pointer t :adjustable t) + :key #'1+) + 4) + +(deftest count-if-not-nonsimple-vector.11 + (let ((c 0)) + (count-if-not #'oddp + (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) + :fill-pointer t :adjustable t) + :key #'(lambda (x) (+ x (incf c))))) + 6) + +(deftest count-if-not-nonsimple-vector.12 + (let ((c 0)) + (count-if-not #'oddp + (make-array 10 :initial-contents '(0 1 2 3 4 4 1 7 10 1) + :fill-pointer t :adjustable t) + :from-end t + :key #'(lambda (x) (+ x (incf c))))) + 8) + +(deftest count-if-not-nonsimple-vector.13 + (count-if-not #'(lambda (x) (not (eqt x 'a))) + (make-array 13 :initial-contents '(a b c d a e f a e f f a a) + :fill-pointer t :adjustable t) + :start 2) + 4) + +(deftest count-if-not-nonsimple-vector.14 + (count-if-not #'(lambda (x) (not (eqt x 'a))) + (make-array 13 :initial-contents '(a b c d a e f a e f f a a) + :fill-pointer t :adjustable t) + :end 7) + 2) + +(deftest count-if-not-nonsimple-vector.15 + (count-if-not #'(lambda (x) (not (eqt x 'a))) + (make-array 13 :initial-contents '(a b c d a e f a e f f a a) + :fill-pointer t :adjustable t) + :end 7 :start 2) + 1) + +(deftest count-if-not-nonsimple-vector.16 + (count-if-not #'(lambda (x) (not (eqt x 'a))) + (make-array 13 :initial-contents '(a b c d a e f a e f f a a) + :fill-pointer t :adjustable t) + :end 7 :start 2 :from-end t) + 1) + +(deftest count-if-not-nonsimple-vector.17 + (flet ((%a (c) (not (eqt c 'a))) + (%f (c) (not (eqt c 'f)))) + (let ((a (make-array 13 :initial-contents '(a b c d a e f a e f f a a) + :fill-pointer 9))) + (values (count-if-not #'%a a) + (count-if-not #'%a a :from-end t) + (count-if-not #'%f a) + (count-if-not #'%f a :from-end t) + ))) + 3 3 1 1) + +;;; tests on bit-vectors + +(deftest count-if-not-bit-vector.1 + (count-if-not #'oddp #*001011101101) + 5) + +(deftest count-if-not-bit-vector.2 + (count-if-not #'identity #*001011101101) + 0) + +(deftest count-if-not-bit-vector.3 + (count-if-not #'(lambda (x) (break)) #*) + 0) + +(deftest count-if-not-bit-vector.4 + (count-if-not #'identity #*001011101101 :key #'zerop) + 7) + +(deftest count-if-not-bit-vector.5 + (count-if-not 'not #*001011101101 :key #'zerop) + 5) + +(deftest count-if-not-bit-vector.6 + (count-if-not #'not #*001011101101 :key 'zerop) + 5) + +(deftest count-if-not-bit-vector.8 + (count-if-not #'identity #*001011101101 :key 'oddp) + 5) + +(deftest count-if-not-bit-vector.10 + (count-if-not #'oddp #*001011101101 :key #'1+) + 7) + +(deftest count-if-not-bit-vector.11 + (let ((c 0)) + (count-if-not #'oddp #*001011101101 + :key #'(lambda (x) (+ x (incf c))))) + 7) + +(deftest count-if-not-bit-vector.12 + (let ((c 0)) + (count-if-not #'oddp #*001011101101 + :from-end t + :key #'(lambda (x) (+ x (incf c))))) + 5) + +(deftest count-if-not-bit-vector.13 + (count-if-not #'zerop #*0111011011100 :start 2) + 7) + +(deftest count-if-not-bit-vector.14 + (count-if-not #'zerop #*0111011011100 :end 7) + 5) + +(deftest count-if-not-bit-vector.15 + (count-if-not #'zerop #*0111011011100 :end 7 :start 2) + 4) + +(deftest count-if-not-bit-vector.16 + (count-if-not #'zerop #*0111011011100 :end 7 :start 2 :from-end t) + 4) + +(deftest count-if-not-bit-vector.17 + (let ((a (make-array '(10) :initial-contents '(0 0 0 1 1 1 0 1 0 0) + :fill-pointer 5 + :element-type 'bit))) + (and (bit-vector-p a) + (values (count-if-not #'zerop a) + (count-if-not #'oddp a) + (count-if-not #'zerop a :from-end t) + (count-if-not #'oddp a :from-end t)))) + 2 3 2 3) + +;;; tests on strings + +(deftest count-if-not-string.1 + (count-if-not #'(lambda (x) (eql x #\0)) "001011101101") + 7) + +(deftest count-if-not-string.2 + (count-if-not #'identity "001011101101") + 0) + +(deftest count-if-not-string.3 + (count-if-not #'(lambda (x) (break)) "") + 0) + +(deftest count-if-not-string.4 + (count-if-not #'identity "001011101101" :key #'(lambda (x) (eql x #\0))) + 7) + +(deftest count-if-not-string.5 + (count-if-not 'identity "001011101101" :key #'(lambda (x) (eql x #\0))) + 7) + +(deftest count-if-not-string.6 + (count-if-not #'(lambda (x) (eql x #\0)) "001011101101" :key 'identity) + 7) + +(deftest count-if-not-string.8 + (count-if-not #'identity "001011101101" :key #'(lambda (x) (eql x #\1))) + 5) + +(deftest count-if-not-string.11 + (let ((c 0)) + (count-if-not #'oddp "001011101101" + :key #'(lambda (x) (+ (if (eql x #\0) 0 1) (incf c))))) + 7) + +(deftest count-if-not-string.12 + (let ((c 0)) + (count-if-not #'oddp "001011101101" + :from-end t + :key #'(lambda (x) (+ (if (eql x #\0) 0 1) (incf c))))) + 5) + +(deftest count-if-not-string.13 + (count-if-not #'(lambda (x) (eql x #\0)) "0111011011100" :start 2) + 7) + +(deftest count-if-not-string.14 + (count-if-not #'(lambda (x) (eql x #\0)) "0111011011100" :end 7) + 5) + +(deftest count-if-not-string.15 + (count-if-not #'(lambda (x) (eql x #\0)) "0111011011100" :end 7 :start 2) + 4) + +(deftest count-if-not-string.16 + (count-if-not #'(lambda (x) (eql x #\0)) + "0111011011100" :end 7 :start 2 :from-end t) + 4) + +(deftest count-if-not-string.17 + (flet ((%zerop (c) (eql c #\0)) + (%onep (c) (eql c #\1))) + (let ((a (make-array '(10) :initial-contents "0001110100" + :fill-pointer 5 + :element-type 'character))) + (and (stringp a) + (values (count-if-not #'%zerop a) + (count-if-not #'%onep a) + (count-if-not #'%zerop a :from-end t) + (count-if-not #'%onep a :from-end t))))) + 2 3 2 3) + +;;; Argument order tests + +(deftest count-if-not.order.1 + (let ((i 0) c1 c2 c3 c4 c5 c6) + (values + (count-if-not + (progn (setf c1 (incf i)) #'null) + (progn (setf c2 (incf i)) '(a nil b c nil d e)) + :start (progn (setf c3 (incf i)) 0) + :end (progn (setf c4 (incf i)) 3) + :key (progn (setf c5 (incf i)) #'not) + :from-end (progn (setf c6 (incf i)) nil) + ) + i c1 c2 c3 c4 c5 c6)) + 1 6 1 2 3 4 5 6) + +(deftest count-if-not.order.2 + (let ((i 0) c1 c2 c3 c4 c5 c6) + (values + (count-if-not + (progn (setf c1 (incf i)) #'null) + (progn (setf c2 (incf i)) '(a nil b c nil d e)) + :from-end (progn (setf c3 (incf i)) nil) + :key (progn (setf c4 (incf i)) #'not) + :end (progn (setf c5 (incf i)) 3) + :start (progn (setf c6 (incf i)) 0) + ) + i c1 c2 c3 c4 c5 c6)) + 1 6 1 2 3 4 5 6) + +;;; Keyword tests + +(deftest count-if-not.keywords.1 + (count-if-not #'oddp '(1 2 3 4 5) :bad t :allow-other-keys t) + 2) + +(deftest count-if-not.keywords.2 + (count-if-not #'oddp '(1 2 3 4 5) :allow-other-keys #p"*" :also-bad t) + 2) + +;;; The leftmost of two :allow-other-keys arguments is the one that matters. +(deftest count-if-not.keywords.3 + (count-if-not #'oddp '(1 2 3 4 5) + :allow-other-keys t + :allow-other-keys nil + :bad t) + 2) + +(deftest count-if-not.keywords.4 + (count-if-not #'oddp '(1 2 3 4 5) :key #'identity :key #'1+) + 2) + +(deftest count-if-not.allow-other-keys.5 + (count-if-not #'null '(nil a b c nil) :allow-other-keys nil) + 3) + +;;; Error tests + +(deftest count-if-not.error.1 + (classify-error (count-if-not #'identity 1)) + type-error) + +(deftest count-if-not.error.2 + (classify-error (count-if-not #'identity 'a)) + type-error) + +(deftest count-if-not.error.3 + (classify-error (count-if-not #'identity #\a)) + type-error) + +(deftest count-if-not.error.4 + (classify-error (count-if-not)) + program-error) + +(deftest count-if-not.error.5 + (classify-error (count-if-not #'null)) + program-error) + +(deftest count-if-not.error.6 + (classify-error (count-if-not #'null nil :bad t)) + program-error) + +(deftest count-if-not.error.7 + (classify-error (count-if-not #'null nil :bad t :allow-other-keys nil)) + program-error) + +(deftest count-if-not.error.8 + (classify-error (count-if-not #'null nil :key)) + program-error) + +(deftest count-if-not.error.9 + (classify-error (count-if-not #'null nil 3 3)) + program-error) + +;;; Only leftmost :allow-other-keys argument matters +(deftest count-if-not.error.10 + (classify-error (count-if-not #'null nil :bad t + :allow-other-keys nil + :allow-other-keys t)) + program-error) + +(deftest count-if-not.error.11 + (classify-error (locally (count-if-not #'identity 1) t)) + type-error) + +(deftest count-if-not.error.12 + (classify-error (count-if-not #'cons '(a b c))) + program-error) + +(deftest count-if-not.error.13 + (classify-error (count-if-not #'car '(a b c))) + type-error) + +(deftest count-if-not.error.14 + (classify-error (count-if-not #'identity '(a b c) :key #'cdr)) + type-error) + +(deftest count-if-not.error.15 + (classify-error (count-if-not #'identity '(a b c) :key #'cons)) + program-error) diff --git a/ansi-tests/count-if.lsp b/ansi-tests/count-if.lsp new file mode 100644 index 0000000..3226584 --- /dev/null +++ b/ansi-tests/count-if.lsp @@ -0,0 +1,541 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Aug 20 08:01:30 2002 +;;;; Contains: Tests for COUNT-IF + +(in-package :cl-test) + +(deftest count-if-list.1 + (count-if #'identity '(a b nil c d nil e)) + 5) + +(deftest count-if-list.2 + (count-if #'not '(a b nil c d nil e)) + 2) + +(deftest count-if-list.3 + (count-if #'(lambda (x) (break)) nil) + 0) + +(deftest count-if-list.4 + (count-if #'identity '(a b nil c d nil e) :key #'identity) + 5) + +(deftest count-if-list.5 + (count-if 'identity '(a b nil c d nil e) :key #'identity) + 5) + +(deftest count-if-list.6 + (count-if #'identity '(a b nil c d nil e) :key 'identity) + 5) + +(deftest count-if-list.8 + (count-if #'identity '(a b nil c d nil e) :key 'not) + 2) + +(deftest count-if-list.9 + (count-if #'evenp '(1 2 3 4 4 1 8 10 1)) + 5) + +(deftest count-if-list.10 + (count-if #'evenp '(1 2 3 4 4 1 8 10 1) :key #'1+) + 4) + +(deftest count-if-list.11 + (let ((c 0)) + (count-if #'evenp '(1 2 3 4 4 1 8 10 1) + :key #'(lambda (x) (+ x (incf c))))) + 6) + +(deftest count-if-list.12 + (let ((c 0)) + (count-if #'evenp '(0 1 2 3 4 4 1 7 10 1) + :from-end t + :key #'(lambda (x) (+ x (incf c))))) + 8) + +(deftest count-if-list.13 + (count-if #'(lambda (x) (eqt x 'a)) + '(a b c d a e f a e f f a a) :start 2) + 4) + +(deftest count-if-list.14 + (count-if #'(lambda (x) (eqt x 'a)) + '(a b c d a e f a e f f a a) :end 7) + 2) + +(deftest count-if-list.15 + (count-if #'(lambda (x) (eqt x 'a)) + '(a b c d a e f a e f f a a) :end 7 + :start 2) + 1) + +(deftest count-if-list.16 + (count-if #'(lambda (x) (eqt x 'a)) + '(a b c d a e f a e f f a a) :end 7 + :start 2 :from-end t) + 1) + + +;;; tests on vectors + +(deftest count-if-vector.1 + (count-if #'identity #(a b nil c d nil e)) + 5) + +(deftest count-if-vector.2 + (count-if #'not #(a b nil c d nil e)) + 2) + +(deftest count-if-vector.3 + (count-if #'(lambda (x) (break)) #()) + 0) + +(deftest count-if-vector.4 + (count-if #'identity #(a b nil c d nil e) :key #'identity) + 5) + +(deftest count-if-vector.5 + (count-if 'identity #(a b nil c d nil e) :key #'identity) + 5) + +(deftest count-if-vector.6 + (count-if #'identity #(a b nil c d nil e) :key 'identity) + 5) + +(deftest count-if-vector.8 + (count-if #'identity #(a b nil c d nil e) :key 'not) + 2) + +(deftest count-if-vector.9 + (count-if #'evenp #(1 2 3 4 4 1 8 10 1)) + 5) + +(deftest count-if-vector.10 + (count-if #'evenp #(1 2 3 4 4 1 8 10 1) :key #'1+) + 4) + +(deftest count-if-vector.11 + (let ((c 0)) + (count-if #'evenp #(1 2 3 4 4 1 8 10 1) + :key #'(lambda (x) (+ x (incf c))))) + 6) + +(deftest count-if-vector.12 + (let ((c 0)) + (count-if #'evenp #(0 1 2 3 4 4 1 7 10 1) + :from-end t + :key #'(lambda (x) (+ x (incf c))))) + 8) + +(deftest count-if-vector.13 + (count-if #'(lambda (x) (eqt x 'a)) + #(a b c d a e f a e f f a a) :start 2) + 4) + +(deftest count-if-vector.14 + (count-if #'(lambda (x) (eqt x 'a)) + #(a b c d a e f a e f f a a) :end 7) + 2) + +(deftest count-if-vector.15 + (count-if #'(lambda (x) (eqt x 'a)) + #(a b c d a e f a e f f a a) :end 7 + :start 2) + 1) + +(deftest count-if-vector.16 + (count-if #'(lambda (x) (eqt x 'a)) + #(a b c d a e f a e f f a a) :end 7 + :start 2 :from-end t) + 1) + +;;; Non-simple vectors + +(deftest count-if-nonsimple-vector.1 + (count-if #'identity (make-array 7 :initial-contents '(a b nil c d nil e) + :fill-pointer t + :adjustable t)) + 5) + +(deftest count-if-nonsimple-vector.2 + (count-if #'not (make-array 7 :initial-contents '(a b nil c d nil e) + :fill-pointer t + :adjustable t)) + 2) + +(deftest count-if-nonsimple-vector.3 + (count-if #'(lambda (x) (break)) (make-array 0 + :fill-pointer t + :adjustable t)) + 0) + +(deftest count-if-nonsimple-vector.4 + (count-if #'identity + (make-array 7 :initial-contents '(a b nil c d nil e) + :fill-pointer t + :adjustable t) + :key #'identity) + 5) + +(deftest count-if-nonsimple-vector.5 + (count-if 'identity + (make-array 7 :initial-contents '(a b nil c d nil e) + :fill-pointer t + :adjustable t) + :key #'identity) + 5) + +(deftest count-if-nonsimple-vector.6 + (count-if #'identity + (make-array 7 :initial-contents '(a b nil c d nil e) + :fill-pointer t + :adjustable t) + :key 'identity) + 5) + +(deftest count-if-nonsimple-vector.8 + (count-if #'identity + (make-array 7 :initial-contents '(a b nil c d nil e) + :fill-pointer t + :adjustable t) + :key 'not) + 2) + +(deftest count-if-nonsimple-vector.9 + (count-if #'evenp (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) + :fill-pointer t :adjustable t)) + 5) + +(deftest count-if-nonsimple-vector.10 + (count-if #'evenp + (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) + :fill-pointer t :adjustable t) + :key #'1+) + 4) + +(deftest count-if-nonsimple-vector.11 + (let ((c 0)) + (count-if #'evenp + (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) + :fill-pointer t :adjustable t) + :key #'(lambda (x) (+ x (incf c))))) + 6) + +(deftest count-if-nonsimple-vector.12 + (let ((c 0)) + (count-if #'evenp + (make-array 10 :initial-contents '(0 1 2 3 4 4 1 7 10 1) + :fill-pointer t :adjustable t) + :from-end t + :key #'(lambda (x) (+ x (incf c))))) + 8) + +(deftest count-if-nonsimple-vector.13 + (count-if #'(lambda (x) (eqt x 'a)) + (make-array 13 :initial-contents '(a b c d a e f a e f f a a) + :fill-pointer t :adjustable t) + :start 2) + 4) + +(deftest count-if-nonsimple-vector.14 + (count-if #'(lambda (x) (eqt x 'a)) + (make-array 13 :initial-contents '(a b c d a e f a e f f a a) + :fill-pointer t :adjustable t) + :end 7) + 2) + +(deftest count-if-nonsimple-vector.15 + (count-if #'(lambda (x) (eqt x 'a)) + (make-array 13 :initial-contents '(a b c d a e f a e f f a a) + :fill-pointer t :adjustable t) + :end 7 :start 2) + 1) + +(deftest count-if-nonsimple-vector.16 + (count-if #'(lambda (x) (eqt x 'a)) + (make-array 13 :initial-contents '(a b c d a e f a e f f a a) + :fill-pointer t :adjustable t) + :end 7 :start 2 :from-end t) + 1) + +(deftest count-if-nonsimple-vector.17 + (flet ((%f (x) (eqt x 'a))) + (let ((s (make-array 13 :initial-contents '(a b c d a e f a e f f a a) + :fill-pointer 6))) + (values (count-if #'%f s) + (count-if #'%f s :end nil) + (count-if #'%f s :end 4) + (count-if #'%f s :start 1) + (count-if #'%f s :start 1 :end 4) + (count-if #'%f s :start 1 :end 4 :from-end t)))) + 2 2 1 1 0 0) + +;;; tests on bit-vectors + +(deftest count-if-bit-vector.1 + (count-if #'evenp #*001011101101) + 5) + +(deftest count-if-bit-vector.2 + (count-if #'identity #*001011101101) + 12) + +(deftest count-if-bit-vector.3 + (count-if #'(lambda (x) (break)) #*) + 0) + +(deftest count-if-bit-vector.4 + (count-if #'identity #*001011101101 :key #'zerop) + 5) + +(deftest count-if-bit-vector.5 + (count-if 'identity #*001011101101 :key #'zerop) + 5) + +(deftest count-if-bit-vector.6 + (count-if #'identity #*001011101101 :key 'zerop) + 5) + +(deftest count-if-bit-vector.8 + (count-if #'identity #*001011101101 :key 'oddp) + 7) + +(deftest count-if-bit-vector.10 + (count-if #'evenp #*001011101101 :key #'1+) + 7) + +(deftest count-if-bit-vector.11 + (let ((c 0)) + (count-if #'evenp #*001011101101 + :key #'(lambda (x) (+ x (incf c))))) + 7) + +(deftest count-if-bit-vector.12 + (let ((c 0)) + (count-if #'evenp #*001011101101 + :from-end t + :key #'(lambda (x) (+ x (incf c))))) + 5) + +(deftest count-if-bit-vector.13 + (count-if #'zerop #*0111011011100 :start 2) + 4) + +(deftest count-if-bit-vector.14 + (count-if #'zerop #*0111011011100 :end 7) + 2) + +(deftest count-if-bit-vector.15 + (count-if #'zerop #*0111011011100 :end 7 :start 2) + 1) + +(deftest count-if-bit-vector.16 + (count-if #'zerop #*0111011011100 :end 7 :start 2 :from-end t) + 1) + +(deftest count-if-bit-vector.17 + (let ((s (make-array '(10) :initial-contents '(0 0 1 0 1 0 0 1 1 0) + :element-type 'bit + :fill-pointer 6))) + (values (count-if #'zerop s) + (count-if #'zerop s :end nil) + (count-if #'zerop s :end 4) + (count-if #'zerop s :start 5) + (count-if #'zerop s :start 1 :end 4))) + 4 4 3 1 2) + +;;; tests on strings + +(deftest count-if-string.1 + (count-if #'(lambda (x) (eql x #\0)) "001011101101") + 5) + +(deftest count-if-string.2 + (count-if #'identity "001011101101") + 12) + +(deftest count-if-string.3 + (count-if #'(lambda (x) (break)) "") + 0) + +(deftest count-if-string.4 + (count-if #'identity "001011101101" :key #'(lambda (x) (eql x #\0))) + 5) + +(deftest count-if-string.5 + (count-if 'identity "001011101101" :key #'(lambda (x) (eql x #\0))) + 5) + +(deftest count-if-string.6 + (count-if #'(lambda (x) (eql x #\0)) "001011101101" :key 'identity) + 5) + +(deftest count-if-string.8 + (count-if #'identity "001011101101" :key #'(lambda (x) (eql x #\1))) + 7) + +(deftest count-if-string.11 + (let ((c 0)) + (count-if #'evenp "001011101101" + :key #'(lambda (x) (+ (if (eql x #\0) 0 1) (incf c))))) + 7) + +(deftest count-if-string.12 + (let ((c 0)) + (count-if #'evenp "001011101101" + :from-end t + :key #'(lambda (x) (+ (if (eql x #\0) 0 1) (incf c))))) + 5) + +(deftest count-if-string.13 + (count-if #'(lambda (x) (eql x #\0)) "0111011011100" :start 2) + 4) + +(deftest count-if-string.14 + (count-if #'(lambda (x) (eql x #\0)) "0111011011100" :end 7) + 2) + +(deftest count-if-string.15 + (count-if #'(lambda (x) (eql x #\0)) "0111011011100" :end 7 :start 2) + 1) + +(deftest count-if-string.16 + (count-if #'(lambda (x) (eql x #\0)) + "0111011011100" :end 7 :start 2 :from-end t) + 1) + +(deftest count-if-string.17 + (let ((s (make-array '(10) + :initial-contents "00a0aa0a0a" + :element-type 'character + :fill-pointer 6))) + (values (count-if #'digit-char-p s) + (count-if #'digit-char-p s :end nil) + (count-if #'digit-char-p s :start 1) + (count-if #'digit-char-p s :end 2) + (count-if #'digit-char-p s :start 1 :end 2))) + 3 3 2 2 1) + +;;; Argument order tests + +(deftest count-if.order.1 + (let ((i 0) c1 c2 c3 c4 c5 c6) + (values + (count-if (progn (setf c1 (incf i)) #'null) + (progn (setf c2 (incf i)) '(a nil b c nil d e)) + :start (progn (setf c3 (incf i)) 0) + :end (progn (setf c4 (incf i)) 3) + :key (progn (setf c5 (incf i)) #'identity) + :from-end (progn (setf c6 (incf i)) nil) + ) + i c1 c2 c3 c4 c5 c6)) + 1 6 1 2 3 4 5 6) + +(deftest count-if.order.2 + (let ((i 0) c1 c2 c3 c4 c5 c6) + (values + (count-if (progn (setf c1 (incf i)) #'null) + (progn (setf c2 (incf i)) '(a nil b c nil d e)) + :from-end (progn (setf c3 (incf i)) nil) + :key (progn (setf c4 (incf i)) #'identity) + :end (progn (setf c5 (incf i)) 3) + :start (progn (setf c6 (incf i)) 0) + ) + i c1 c2 c3 c4 c5 c6)) + 1 6 1 2 3 4 5 6) + + +;;; Keyword tests + +(deftest count-if.allow-other-keys.1 + (count-if #'evenp '(1 2 3 4 5) :bad t :allow-other-keys t) + 2) + +(deftest count-if.allow-other-keys.2 + (count-if #'evenp '(1 2 3 4 5) :allow-other-keys #p"*" :also-bad t) + 2) + +;;; The leftmost of two :allow-other-keys arguments is the one that matters. +(deftest count-if.allow-other-keys.3 + (count-if #'evenp '(1 2 3 4 5) + :allow-other-keys t + :allow-other-keys nil + :bad t) + 2) + +(deftest count-if.keywords.4 + (count-if #'evenp '(1 2 3 4 5) :key #'identity :key #'1+) + 2) + +(deftest count-if.allow-other-keys.5 + (count-if #'evenp '(1 2 3 4 5) :allow-other-keys nil) + 2) + + +;;; Error tests + +(deftest count-if.error.1 + (classify-error (count-if #'identity 1)) + type-error) + +(deftest count-if.error.2 + (classify-error (count-if #'identity 'a)) + type-error) + +(deftest count-if.error.3 + (classify-error (count-if #'identity #\a)) + type-error) + +(deftest count-if.error.4 + (classify-error (count-if)) + program-error) + +(deftest count-if.error.5 + (classify-error (count-if #'null)) + program-error) + +(deftest count-if.error.6 + (classify-error (count-if #'null nil :bad t)) + program-error) + +(deftest count-if.error.7 + (classify-error (count-if #'null nil :bad t :allow-other-keys nil)) + program-error) + +(deftest count-if.error.8 + (classify-error (count-if #'null nil :key)) + program-error) + +(deftest count-if.error.9 + (classify-error (count-if #'null nil 3 3)) + program-error) + +;;; Only leftmost :allow-other-keys argument matters +(deftest count-if.error.10 + (classify-error (count-if #'null nil :bad t + :allow-other-keys nil + :allow-other-keys t)) + program-error) + +(deftest count-if.error.11 + (classify-error (locally (count-if #'identity 1) t)) + type-error) + +(deftest count-if.error.12 + (classify-error (count-if #'cons '(a b c))) + program-error) + +(deftest count-if.error.13 + (classify-error (count-if #'car '(a b c))) + type-error) + +(deftest count-if.error.14 + (classify-error (count-if #'identity '(a b c) :key #'cdr)) + type-error) + +(deftest count-if.error.15 + (classify-error (count-if #'identity '(a b c) :key #'cons)) + program-error) + + diff --git a/ansi-tests/count.lsp b/ansi-tests/count.lsp new file mode 100644 index 0000000..ede89ed --- /dev/null +++ b/ansi-tests/count.lsp @@ -0,0 +1,609 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Mon Aug 19 07:31:55 2002 +;;;; Contains: Tests for COUNT + +(in-package :cl-test) + +(deftest count-list.1 + (count 'a '(a b c d e a e f)) + 2) + +(deftest count-list.2 + (count 'a '(a b c d e a e f) :test #'eql) + 2) + +(deftest count-list.3 + (count 'a '(a b c d e a e f) :test 'eql) + 2) + +(deftest count-list.4 + (count 1 '(1 2 2 3 2 1 2 2 5 4) :key #'1-) + 5) + +(deftest count-list.5 + (count 1 '(1 2 2 3 2 1 2 2 5 4) :key '1-) + 5) + +(deftest count-list.6 + (count 1 '(1 2 2 3 2 1 2 2 5 4) :key #'1- :test #'equal) + 5) + +(deftest count-list.7 + (count 1 '(2 1 1 2 3 1 4 1 7 6 1 8) :from-end t) + 5) + +(deftest count-list.8 + (let ((c 0)) + (count 1 '(1 2 3 1 4 1 7 6 1 8) + :key #'(lambda (x) + ;; (format t "~%~A ~A" x c) + (prog1 (- x c) (incf c))))) + 4) + +(deftest count-list.9 + (let ((c 0)) + (count 1 '(1 2 3 7 4 5 7 6 2 8) + :from-end t + :key #'(lambda (x) + ;; (format t "~%~A ~A" x c) + (prog1 (- x c) (incf c))))) + 3) + +(deftest count-list.10 + (count 1 '(1 1 1 1 1 2 1 1) :start 3) + 4) + +(deftest count-list.11 + (count 1 '(1 1 1 1 1 2 1 1) :end 6) + 5) + +(deftest count-list.12 + (count 1 '(1 1 1 1 1 2 1 1) :start 2 :end 7) + 4) + +(deftest count-list.13 + (count 1 '(1 1 1 1 1 2 1 1) :start 3 :end nil) + 4) + +(deftest count-list.14 + (count 1 '(1 1 1 1 1 2 1 1) :end nil) + 7) + +(deftest count-list.15 + (count 1 '(1 1 1 1 1 2 1 1) :test-not #'eql) + 1) + +(deftest count-list.16 + (count 1 '(1 1 1 3 1 2 1 1) :start 2 :end 7 + :test #'(lambda (x y) (declare (ignore x y)) t)) + 5) + +;;; On vectors + +(deftest count-vector.1 + (count 'a #(a b c d e a e f)) + 2) + +(deftest count-vector.2 + (count 'a #(a b c d e a e f) :test #'eql) + 2) + +(deftest count-vector.3 + (count 'a #(a b c d e a e f) :test 'eql) + 2) + +(deftest count-vector.4 + (count 1 #(1 2 2 3 2 1 2 2 5 4) :key #'1-) + 5) + +(deftest count-vector.5 + (count 1 #(1 2 2 3 2 1 2 2 5 4) :key '1-) + 5) + +(deftest count-vector.6 + (count 1 #(1 2 2 3 2 1 2 2 5 4) :key #'1- :test #'equal) + 5) + +(deftest count-vector.7 + (count 1 #(2 1 1 2 3 1 4 1 7 6 1 8) :from-end t) + 5) + +(deftest count-vector.8 + (let ((c 0)) + (count 1 #(1 2 3 1 4 1 7 6 1 8) + :key #'(lambda (x) + ;; (format t "~%~A ~A" x c) + (prog1 (- x c) (incf c))))) + 4) + +(deftest count-vector.9 + (let ((c 0)) + (count 1 #(1 2 3 7 4 5 7 6 2 8) + :from-end t + :key #'(lambda (x) + ;; (format t "~%~A ~A" x c) + (prog1 (- x c) (incf c))))) + 3) + +(deftest count-vector.10 + (count 1 #(1 1 1 1 1 2 1 1) :start 3) + 4) + +(deftest count-vector.11 + (count 1 #(1 1 1 1 1 2 1 1) :end 6) + 5) + +(deftest count-vector.12 + (count 1 #(1 1 1 1 1 2 1 1) :start 2 :end 7) + 4) + +(deftest count-vector.13 + (count 1 #(1 1 1 1 1 2 1 1) :start 3 :end nil) + 4) + +(deftest count-vector.14 + (count 1 #(1 1 1 1 1 2 1 1) :end nil) + 7) + +(deftest count-vector.15 + (count 1 #(1 1 1 1 1 2 1 1) :test-not #'eql) + 1) + +(deftest count-vector16 + (count 1 #(1 1 1 3 1 2 1 1) :start 2 :end 7 + :test #'(lambda (x y) (declare (ignore x y)) t)) + 5) + +;;; Non-simple vectors + +(deftest count-filled-vector.1 + (count 'a (make-array 8 :initial-contents '(a b c d e a e f) + :fill-pointer t)) + 2) + +(deftest count-filled-vector.2 + (count 'a (make-array 8 :initial-contents '(a b c d e a e f) + :fill-pointer t) + :test #'eql) + 2) + +(deftest count-filled-vector.3 + (count 'a (make-array 8 :initial-contents '(a b c d e a e f) + :fill-pointer t) + :test 'eql) + 2) + +(deftest count-filled-vector.4 + (count 1 (make-array 10 :initial-contents '(1 2 2 3 2 1 2 2 5 4) + :fill-pointer t) + :key #'1-) + 5) + +(deftest count-filled-vector.5 + (count 1 (make-array 10 :initial-contents '(1 2 2 3 2 1 2 2 5 4) + :fill-pointer t) + :key '1-) + 5) + +(deftest count-filled-vector.6 + (count 1 (make-array 10 :initial-contents '(1 2 2 3 2 1 2 2 5 4) + :fill-pointer t) + :key #'1- :test #'equal) + 5) + +(deftest count-filled-vector.7 + (count 1 (make-array 12 :initial-contents '(2 1 1 2 3 1 4 1 7 6 1 8) + :fill-pointer t) + :from-end t) + 5) + +(deftest count-filled-vector.8 + (let ((c 0)) + (count 1 (make-array 10 :initial-contents '(1 2 3 1 4 1 7 6 1 8) + :fill-pointer t) + :key #'(lambda (x) + ;; (format t "~%~A ~A" x c) + (prog1 (- x c) (incf c))))) + 4) + +(deftest count-filled-vector.9 + (let ((c 0)) + (count 1 (make-array 10 :initial-contents '(1 2 3 7 4 5 7 6 2 8) + :fill-pointer t) + :from-end t + :key #'(lambda (x) + ;; (format t "~%~A ~A" x c) + (prog1 (- x c) (incf c))))) + 3) + +(deftest count-filled-vector.10 + (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 2 1 1) + :fill-pointer t) + :start 3) + 4) + +(deftest count-filled-vector.11 + (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 2 1 1) + :fill-pointer t) + :end 6) + 5) + +(deftest count-filled-vector.12 + (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 2 1 1) + :fill-pointer t) + :start 2 :end 7) + 4) + +(deftest count-filled-vector.13 + (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 2 1 1) + :fill-pointer t) + :start 3 :end nil) + 4) + +(deftest count-filled-vector.14 + (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 2 1 1) + :fill-pointer t) + :end nil) + 7) + +(deftest count-filled-vector.15 + (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 2 1 1) + :fill-pointer t) + :test-not #'eql) + 1) + +(deftest count-filled-vector.16 + (count 1 (make-array 8 :initial-contents '(1 1 1 3 1 2 1 1) + :fill-pointer t) + :start 2 :end 7 + :test #'(lambda (x y) (declare (ignore x y)) t)) + 5) + +(deftest count-filled-vector.17 + (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 1 1 1) + :fill-pointer 6)) + 6) + +(deftest count-filled-vector.18 + (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 1 1 1) + :fill-pointer 6) + :start 2) + 4) +(deftest count-filled-vector.19 + (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 1 1 1) + :fill-pointer 6) + :from-end 'foo) + 6) + +(deftest count-filled-vector.20 + (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 1 1 1) + :fill-pointer 6) + :start 2 :from-end 'yes) + 4) + + + +;;; Tests on bit vectors + +(deftest count-bit-vector.1 + (count 1 #*00101100011011000) + 7) + +(deftest count-bit-vector.2 + (count 1 #*00101100011011000 :test #'eql) + 7) + +(deftest count-bit-vector.3 + (count 1 #*00101100011011000 :test 'eql) + 7) + +(deftest count-bit-vector.4 + (count 1 #*00101100011011000 :key #'1+) + 10) + +(deftest count-bit-vector.5 + (count 0 #*00101100011011000 :key '1-) + 7) + +(deftest count-bit-vector.6 + (count 0 #*00101100011011000 :key #'1- :test #'equal) + 7) + +(deftest count-bit-vector.7 + (count 1 #*00101100011011000 :from-end t) + 7) + +(deftest count-bit-vector.8 + (let ((c 1)) + (count 0 #*0000110101001 + :key #'(lambda (x) (setf c (- c)) (+ c x)))) + 2) + +(deftest count-bit-vector.9 + (let ((c 1)) + (count 0 #*0000011010101 + :from-end t + :key #'(lambda (x) (setf c (- c)) (+ c x)))) + 4) + +(deftest count-bit-vector.10 + (count 1 #*11000110110 :start 3) + 4) + +(deftest count-bit-vector.11 + (count 1 '#*110111110111 :end 6) + 5) + +(deftest count-bit-vector.12 + (count 1 #*11111011 :start 2 :end 7) + 4) + +(deftest count-bit-vector.13 + (count 1 #*11111011 :start 3 :end nil) + 4) + +(deftest count-bit-vector.14 + (count 1 #*11111011 :end nil) + 7) + +(deftest count-bit-vector.15 + (count 1 #*11111011 :test-not #'eql) + 1) + +(deftest count-bit-vector.16 + (count 1 #*11101101 :start 2 :end 7 + :test #'(lambda (x y) (declare (ignore x y)) t)) + 5) + +(deftest count-bit-vector.17 + (count 1 (make-array 8 :initial-contents '(1 0 1 1 1 1 1 1) + :element-type 'bit + :fill-pointer 5)) + 4) + +(deftest count-bit-vector.18 + (count 1 (make-array 8 :initial-contents '(1 0 1 1 1 1 1 1) + :element-type 'bit + :fill-pointer 5) + :start 1) + 3) + +(deftest count-bit-vector.19 + (count 1 (make-array 8 :initial-contents '(1 0 1 1 1 1 1 1) + :element-type 'bit + :fill-pointer 5) + :end nil) + 4) + + +(deftest count-bit-vector.20 + (count 1 (make-array 8 :initial-contents '(1 0 1 1 1 1 1 1) + :element-type 'bit + :fill-pointer 6) + :end 4) + 3) + + +;;; Tests on strings + +(deftest count-string.1 + (count #\1 "00101100011011000") + 7) + +(deftest count-string.2 + (count #\1 "00101100011011000" :test #'eql) + 7) + +(deftest count-string.3 + (count #\1 "00101100011011000" :test 'eql) + 7) + +(deftest count-string.4 + (count #\1 "00101100011011000" :key #'(lambda (x) (if (eql x #\0) #\1 #\2))) + 10) + +(deftest count-string.5 + (count #\1 "00101100011011000" :key 'identity) + 7) + +(deftest count-string.6 + (count #\1 "00101100011011000" :key #'identity :test #'equal) + 7) + +(deftest count-string.7 + (count #\1 "00101100011011000" :from-end t) + 7) + +(deftest count-string.8 + (let ((c nil)) + (count #\0 "0000110101001" + :key #'(lambda (x) (setf c (not c)) + (and c x)))) + 5) + +(deftest count-string.9 + (let ((c nil)) + (count #\0 "0000011010101" + :from-end t + :key #'(lambda (x) (setf c (not c)) + (and c x)))) + 3) + +(deftest count-string.10 + (count #\1 "11000110110" :start 3) + 4) + +(deftest count-string.11 + (count #\1 '"110111110111" :end 6) + 5) + +(deftest count-string.12 + (count #\1 "11111011" :start 2 :end 7) + 4) + +(deftest count-string.13 + (count #\1 "11111011" :start 3 :end nil) + 4) + +(deftest count-string.14 + (count #\1 "11111011" :end nil) + 7) + +(deftest count-string.15 + (count #\1 "11111011" :test-not #'eql) + 1) + +(deftest count-string.16 + (count #\1 "11101101" :start 2 :end 7 + :test #'(lambda (x y) (declare (ignore x y)) t)) + 5) + +(deftest count-string.17 + (count #\a (make-array 10 :initial-contents "abaaacaaaa" + :fill-pointer 7 + :element-type 'character)) + 5) + +(deftest count-string.18 + (count #\a (make-array 10 :initial-contents "abaaacaaaa" + :fill-pointer 7 + :element-type 'character) + :start 1) + 4) + +(deftest count-string.19 + (count #\a (make-array 10 :initial-contents "abaaacaaaa" + :fill-pointer 7 + :element-type 'character) + :end nil) + 5) + +(deftest count-string.20 + (count #\a (make-array 10 :initial-contents "abaaacaaaa" + :fill-pointer 7 + :element-type 'character) + :start 2 :end 5) + 3) + +;;; Argument order tests + +(deftest count.order.1 + (let ((i 0) c1 c2 c3 c4 c5 c6 c7) + (values + (count (progn (setf c1 (incf i)) nil) + (progn (setf c2 (incf i)) '(a nil b c nil d e)) + :start (progn (setf c3 (incf i)) 0) + :end (progn (setf c4 (incf i)) 3) + :key (progn (setf c5 (incf i)) #'identity) + :from-end (progn (setf c6 (incf i)) nil) + :test (progn (setf c7 (incf i)) #'eql) + ) + i c1 c2 c3 c4 c5 c6 c7)) + 1 7 1 2 3 4 5 6 7) + +(deftest count.order.2 + (let ((i 0) c1 c2 c3 c4 c5 c6 c7) + (values + (count (progn (setf c1 (incf i)) nil) + (progn (setf c2 (incf i)) '(a nil b c nil d e)) + :test (progn (setf c3 (incf i)) #'eql) + :from-end (progn (setf c4 (incf i)) nil) + :key (progn (setf c5 (incf i)) #'identity) + :end (progn (setf c6 (incf i)) 3) + :start (progn (setf c7 (incf i)) 0) + ) + i c1 c2 c3 c4 c5 c6 c7)) + 1 7 1 2 3 4 5 6 7) + + +;;; Keyword tests + +(deftest count.allow-other-keys.1 + (count 'a '(b a d a c) :bad t :allow-other-keys t) + 2) + +(deftest count.allow-other-keys.2 + (count 'a '(b a d a c) :allow-other-keys #p"*" :also-bad t) + 2) + +;;; The leftmost of two :allow-other-keys arguments is the one that matters. +(deftest count.allow-other-keys.3 + (count 'a '(b a d a c) + :allow-other-keys t + :allow-other-keys nil + :bad t) + 2) + +(deftest count.keywords.4 + (count 2 '(1 2 3 2 5) :key #'identity :key #'1+) + 2) + +(deftest count.allow-other-keys.5 + (count 'a '(a b c a) :allow-other-keys nil) + 2) + +;;; Error tests + +(deftest count.error.1 + (classify-error (count 'a 1)) + type-error) + +(deftest count.error.2 + (classify-error (count 'a 'a)) + type-error) + +(deftest count.error.3 + (classify-error (count 'a #\a)) + type-error) + +(deftest count.error.4 + (classify-error (count)) + program-error) + +(deftest count.error.5 + (classify-error (count nil)) + program-error) + +(deftest count.error.6 + (classify-error (count nil nil :bad t)) + program-error) + +(deftest count.error.7 + (classify-error (count nil nil :bad t :allow-other-keys nil)) + program-error) + +(deftest count.error.8 + (classify-error (count nil nil :key)) + program-error) + +(deftest count.error.9 + (classify-error (count nil nil 3 3)) + program-error) + +;;; Only leftmost :allow-other-keys argument matters +(deftest count.error.10 + (classify-error (count 'a nil :bad t + :allow-other-keys nil + :allow-other-keys t)) + program-error) + +(deftest count.error.11 + (classify-error (locally (count 'a 1) t)) + type-error) + +(deftest count.error.12 + (classify-error (count 'b '(a b c) :test #'identity)) + program-error) + +(deftest count.error.13 + (classify-error (count 'b '(a b c) :key #'car)) + type-error) + +(deftest count.error.14 + (classify-error (count 'b '(a b c) :test-not #'identity)) + program-error) + +(deftest count.error.15 + (classify-error (count 'b '(a b c) :key #'cons)) + program-error) diff --git a/ansi-tests/ctypecase.lsp b/ansi-tests/ctypecase.lsp new file mode 100644 index 0000000..7e7ea50 --- /dev/null +++ b/ansi-tests/ctypecase.lsp @@ -0,0 +1,88 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Oct 18 23:05:10 2002 +;;;; Contains: Tests of CTYPECASE + +(in-package :cl-test) + +(deftest ctypecase.1 + (let ((x 1)) + (ctypecase x (integer 'a) (t 'b))) + a) + +(deftest ctypecase.2 + (classify-error + (let ((x 1)) + (ctypecase x (symbol 'a)))) + type-error) + +(deftest ctypecase.3 + (let ((x 1)) + (ctypecase x (symbol 'a) (t 'b))) + b) + +(deftest ctypecase.4 + (let ((x 1)) + (ctypecase x (t (values))))) + +(deftest ctypecase.5 + (let ((x 1)) + (ctypecase x (integer (values)) (t 'a)))) + +(deftest ctypecase.6 + (let ((x 1)) + (ctypecase x (bit 'a) (integer 'b))) + a) + +(deftest ctypecase.7 + (let ((x 1)) + (ctypecase x (t 'a))) + a) + +(deftest ctypecase.8 + (let ((x 1)) + (ctypecase x (t (values 'a 'b 'c)))) + a b c) + +(deftest ctypecase.9 + (let ((x 1)) + (ctypecase x (integer (values 'a 'b 'c)) (t nil))) + a b c) + +(deftest ctypecase.10 + (let ((x 0) (y 1)) + (values + (ctypecase y + (bit (incf x) 'a) + (integer (incf x 2) 'b) + (t (incf x 4) 'c)) + x)) + a 1) + +(deftest ctypecase.11 + (let ((x 1)) + (ctypecase x (integer) (t 'a))) + nil) + +(deftest ctypecase.12 + (let ((x 1)) + (values + (handler-bind + ((type-error #'(lambda (c) (store-value 'a c)))) + (ctypecase x + (symbol :good) + (float :bad))) + x)) + :good a) + +;;; (deftest ctypecase.error.1 +;;; (classify-error (ctypecase)) +;;; program-error) + + +(deftest ctypecase.13 + (ctypecase 'a + (number 'bad) + (#.(find-class 'symbol nil) 'good)) + good) + diff --git a/ansi-tests/data-and-control-flow.lsp b/ansi-tests/data-and-control-flow.lsp new file mode 100644 index 0000000..86437dc --- /dev/null +++ b/ansi-tests/data-and-control-flow.lsp @@ -0,0 +1,34 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Mon Oct 21 22:21:48 2002 +;;;; Contains: Overall tests for section 5 of spec, "Data and Control Flow" + +(in-package :cl-test) + +;;; Functions from section 5 +(defparameter *dcf-fns* + '(apply fboundp fmakunbound funcall function-lambda-expression + functionp compiled-function-p not eq eql equal equalp identity + complement constantly every some notevery notany + values-list get-setf-expansion)) + +;;; Macros from section 5 +(defparameter *dcf-macros* + '(defun defconstant defparameter defvar destructuring-bind + psetq return and cond or when unless case ccase ecase + multiple-value-list multiple-value-setq nth-value + prog prog* prog1 prog2 define-modify-macro defsetf + define-setf-expander setf psetf shiftf rotatef)) + +(deftest dcf-funs + (remove-if #'fboundp *dcf-fns*) + nil) + +(deftest dcf-macros + (remove-if #'macro-function *dcf-macros*) + nil) + + + + + \ No newline at end of file diff --git a/ansi-tests/defconstant.lsp b/ansi-tests/defconstant.lsp new file mode 100644 index 0000000..f0b132c --- /dev/null +++ b/ansi-tests/defconstant.lsp @@ -0,0 +1,45 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Thu Oct 10 23:05:39 2002 +;;;; Contains: Tests of DEFCONSTANT + +(in-package :cl-test) + +(defconstant test-constant-1 17) + +(deftest defconstant.1 + (symbol-value 'test-constant-1) + 17) + +(deftest defconstant.2 + (notnot-mv (constantp 'test-constant-1)) + t) + +(deftest defconstant.3 + (documentation 'test-constant-1 'variable) + nil) + +(defconstant test-constant-2 'a + "This is the documentation.") + +(deftest defconstant.4 + (documentation 'test-constant-2 'variable) + "This is the documentation.") + +(deftest defconstant.5 + (defconstant test-constant-3 0) + test-constant-3) + +;;; (deftest defconstant.error.1 +;;; (classify-error (defconstant)) +;;; program-error) +;;; +;;; (deftest defconstant.error.2 +;;; (classify-error (defconstant +ignorable-constant-name+)) +;;; program-error) +;;; +;;; (deftest defconstant.error.3 +;;; (classify-error (defconstant +ignorable-constant-name2+ nil +;;; "This is a docstring" +;;; "This is an unnecessary extra argument.")) +;;; program-error) diff --git a/ansi-tests/define-modify-macro.lsp b/ansi-tests/define-modify-macro.lsp new file mode 100644 index 0000000..e1d4381 --- /dev/null +++ b/ansi-tests/define-modify-macro.lsp @@ -0,0 +1,83 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Oct 19 11:42:14 2002 +;;;; Contains: Tests of DEFINE-MODIFY-MACRO + +(in-package :cl-test) + +(deftest define-modify-macro.1 + (values + (eval '(define-modify-macro dmm1-appendf (&rest args) + append "Append lists onto a list")) + (eval + '(let ((u '(p q r)) v) + (list + (setq v u) + (dmm1-appendf u '(a b c d)) + (dmm1-appendf u ()) + (dmm1-appendf u '(e f g)) + u + v)))) + dmm1-appendf + ((p q r) + (p q r a b c d) + (p q r a b c d) + (p q r a b c d e f g) + (p q r a b c d e f g) + (p q r))) + +(deftest define-modify-macro.2 + (values + (eval '(define-modify-macro new-incf (&optional (delta 1)) +)) + (eval + '(let ((i 10)) + (list + (new-incf i) + (new-incf i 100) + i)))) + new-incf + (11 111 111)) + +(deftest define-modify-macro.3 + (values + (eval '(define-modify-macro new-incf1 (&optional (delta 1)) +)) + (eval + '(let ((a (vector 0 0 0 0 0)) + (i 1)) + (list + (new-incf1 (aref a (incf i))) + a + i)))) + new-incf1 + (1 #(0 0 1 0 0) 2)) + +(deftest define-modify-macro.4 + (values + (eval '(define-modify-macro new-incf2 (&optional (delta 1)) +)) + (eval + '(let ((a (vector 0 0 0 0 0)) + (i 1)) + (list + (new-incf2 (aref a (incf i)) (incf i)) + a + i)))) + new-incf2 + (3 #(0 0 3 0 0) 3)) + +;;; (deftest define-modify-macro.error.1 +;;; (classify-error (define-modify-macro)) +;;; program-error) +;;; +;;; (deftest define-modify-macro.error.2 +;;; (classify-error (define-modify-macro dfm-error-1)) +;;; program-error) +;;; +;;; (deftest define-modify-macro.error.3 +;;; (classify-error (define-modify-macro dfm-error-2 ())) +;;; program-error) +;;; +;;; (deftest define-modify-macro.error.4 +;;; (classify-error (define-modify-macro dfm-error-2 () nil "Documentation" +;;; "extra illegal argument")) +;;; program-error) + diff --git a/ansi-tests/defparameter.lsp b/ansi-tests/defparameter.lsp new file mode 100644 index 0000000..4cc3c90 --- /dev/null +++ b/ansi-tests/defparameter.lsp @@ -0,0 +1,66 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Thu Oct 10 23:13:22 2002 +;;;; Contains: Tests of DEFPARAMETER + +(in-package :cl-test) + +(defparameter *defparameter-test-var-1* 100) + +(deftest defparameter.1 + *defparameter-test-var-1* + 100) + +(deftest defparameter.2 + (documentation '*defparameter-test-var-1* 'variable) + nil) + +;;; Show that it's declared special. +(deftest defparameter.3 + (flet ((%f () *defparameter-test-var-1*)) + (let ((*defparameter-test-var-1* 29)) + (%f))) + 29) + +(deftest defparameter.4 + (values + (makunbound '*defparameter-test-var-2*) + (defparameter *defparameter-test-var-2* 200 "Whatever.") + (documentation '*defparameter-test-var-2* 'variable) + *defparameter-test-var-2*) + *defparameter-test-var-2* + *defparameter-test-var-2* + "Whatever." + 200) + +(deftest defparameter.5 + (values + (makunbound '*defparameter-test-var-2*) + (defparameter *defparameter-test-var-2* 200 "Whatever.") + (documentation '*defparameter-test-var-2* 'variable) + *defparameter-test-var-2* + (defparameter *defparameter-test-var-2* 300 "And ever.") + (documentation '*defparameter-test-var-2* 'variable) + *defparameter-test-var-2* + ) + *defparameter-test-var-2* + *defparameter-test-var-2* + "Whatever." + 200 + *defparameter-test-var-2* + "And ever." + 300) + +;;; (deftest defparameter.error.1 +;;; (classify-error (defparameter)) +;;; program-error) +;;; +;;; (deftest defparameter.error.2 +;;; (classify-error (defparameter *ignored-defparameter-name*)) +;;; program-error) +;;; +;;; (deftest defparameter.error.3 +;;; (classify-error (defparameter *ignored-defparameter-name* nil +;;; "documentation" +;;; "illegal extra argument")) +;;; program-error) diff --git a/ansi-tests/defun.lsp b/ansi-tests/defun.lsp new file mode 100644 index 0000000..f7e29a9 --- /dev/null +++ b/ansi-tests/defun.lsp @@ -0,0 +1,19 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Feb 16 23:40:32 2003 +;;;; Contains: Tests of DEFUN + +(in-package :cl-test) + +;;; DEFUN is used extensively elsewhere, so I'm just putting error +;;; case tests here + +#| +(deftest defun.error.1 + (classify-error (defun)) + program-error) + +(deftest defun.error.2 + (classify-error (defun ignored-defun-name)) + program-error) +|# diff --git a/ansi-tests/defvar.lsp b/ansi-tests/defvar.lsp new file mode 100644 index 0000000..02aadc8 --- /dev/null +++ b/ansi-tests/defvar.lsp @@ -0,0 +1,64 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Thu Oct 10 23:21:50 2002 +;;;; Contains: Tests for DEFVAR + +(in-package :cl-test) + +(defvar *defvar-test-var-1* 100) + +(deftest defvar.1 + *defvar-test-var-1* + 100) + +(deftest defvar.2 + (documentation '*defvar-test-var-1* 'variable) + nil) + +;;; Show that it's declared special. +(deftest defvar.3 + (flet ((%f () *defvar-test-var-1*)) + (let ((*defvar-test-var-1* 29)) + (%f))) + 29) + +(deftest defvar.4 + (values + (makunbound '*defvar-test-var-2*) + (defvar *defvar-test-var-2* 200 "Whatever.") + (documentation '*defvar-test-var-2* 'variable) + *defvar-test-var-2*) + *defvar-test-var-2* + *defvar-test-var-2* + "Whatever." + 200) + +(deftest defvar.5 + (let ((x 0)) + (values + (makunbound '*defvar-test-var-2*) + (defvar *defvar-test-var-2* 200 "Whatever.") + (documentation '*defvar-test-var-2* 'variable) + *defvar-test-var-2* + (defvar *defvar-test-var-2* (incf x) "And ever.") + (documentation '*defvar-test-var-2* 'variable) + *defvar-test-var-2* + x + )) + *defvar-test-var-2* + *defvar-test-var-2* + "Whatever." + 200 + *defvar-test-var-2* + "And ever." + 200 + 0) + +;;; (deftest defvar.error.1 +;;; (classify-error (defvar)) +;;; program-error) +;;; +;;; (deftest defvar.error.2 +;;; (classify-error (defvar *ignored-defvar-name* nil "documentation" +;;; "illegal extra argument")) +;;; program-error) diff --git a/ansi-tests/destructuring-bind.lsp b/ansi-tests/destructuring-bind.lsp new file mode 100644 index 0000000..d24eb5c --- /dev/null +++ b/ansi-tests/destructuring-bind.lsp @@ -0,0 +1,110 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Thu Oct 10 23:25:50 2002 +;;;; Contains: Tests for DESTRUCTURING-BIND + +(in-package :cl-test) + +;;; See the page for this in section 5.3 +;;; Also, see destructuring lambda lists in section 3.4.5 + +(deftest destructuring-bind.1 + (destructuring-bind (x y z) '(a b c) (values x y z)) + a b c) + +(deftest destructuring-bind.2 + (destructuring-bind (x y &rest z) '(a b c d) (values x y z)) + a b (c d)) + +(deftest destructuring-bind.3 + (destructuring-bind (x y &optional z) '(a b c) (values x y z)) + a b c) + +(deftest destructuring-bind.4 + (destructuring-bind (x y &optional z) '(a b) (values x y z)) + a b nil) + +(deftest destructuring-bind.5 + (destructuring-bind (x y &optional (z 'w)) '(a b) (values x y z)) + a b w) + +(deftest destructuring-bind.6 + (destructuring-bind (x y &optional (z 'w z-p)) '(a b) (values x y z z-p)) + a b w nil) + +(deftest destructuring-bind.7 + (destructuring-bind (x y &optional (z 'w z-p)) '(a b c) (values x y z z-p)) + a b c t) + +(deftest destructuring-bind.8 + (destructuring-bind (x y &optional z w) '(a b c) (values x y z w)) + a b c nil) + +(deftest destructuring-bind.9 + (destructuring-bind ((x y)) '((a b)) (values x y)) + a b) + +(deftest destructuring-bind.10 + (destructuring-bind (&whole w (x y)) '((a b)) (values x y w)) + a b ((a b))) + +(deftest destructuring-bind.11 + (destructuring-bind ((x . y) . w) '((a b) c) (values x y w)) + a (b) (c)) + +(deftest destructuring-bind.12 + (destructuring-bind (x y &body z) '(a b c d) (values x y z)) + a b (c d)) + +(deftest destructuring-bind.13 + (destructuring-bind (&whole x y z) '(a b) (values x y z)) + (a b) a b) + +(deftest destructuring-bind.14 + (destructuring-bind (w (&whole x y z)) '(1 (a b)) (values w x y z)) + 1 (a b) a b) + +(deftest destructuring-bind.15 + (destructuring-bind (&key a b c) '(:a 1) (values a b c)) + 1 nil nil) + +(deftest destructuring-bind.16 + (destructuring-bind (&key a b c) '(:b 1) (values a b c)) + nil 1 nil) + +(deftest destructuring-bind.17 + (destructuring-bind (&key a b c) '(:c 1) (values a b c)) + nil nil 1) + +(deftest destructuring-bind.18 + (destructuring-bind ((&key a b c)) '((:c 1 :b 2)) (values a b c)) + nil 2 1) + +;;; Error cases + +#| +(deftest destructuring-bind.error.1 + (classify-error (destructuring-bind (a b c) nil (list a b c))) + program-error) + +(deftest destructuring-bind.error.2 + (classify-error (destructuring-bind ((a b c)) nil (list a b c))) + program-error) + +(deftest destructuring-bind.error.3 + (classify-error (destructuring-bind (a b) 'x (list a b))) + program-error) + +(deftest destructuring-bind.error.4 + (classify-error (destructuring-bind (a . b) 'x (list a b))) + program-error) +|# + +;;; (deftest destructuring-bind.error.5 +;;; (classify-error (destructuring-bind)) +;;; program-error) +;;; +;;; (deftest destructuring-bind.error.6 +;;; (classify-error (destructuring-bind x)) +;;; program-error) + diff --git a/ansi-tests/ecase.lsp b/ansi-tests/ecase.lsp new file mode 100644 index 0000000..ed47af8 --- /dev/null +++ b/ansi-tests/ecase.lsp @@ -0,0 +1,149 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Oct 18 20:17:30 2002 +;;;; Contains: Tests for ECASE + +(in-package :cl-test) + +(deftest ecase.1 + (ecase 'b (a 1) (b 2) (c 3)) + 2) + +(deftest ecase.2 + (classify-error (ecase 1)) + type-error) + +(deftest ecase.3 + (classify-error (ecase 1 (a 1) (b 2) (c 3))) + type-error) + +;;; It is legal to use T or OTHERWISE as key designators +;;; in ECASE forms. They have no special meaning here. + +(deftest ecase.4 + (classify-error (ecase 1 (t nil))) + type-error) + +(deftest ecase.5 + (classify-error (ecase 1 (otherwise nil))) + type-error) + +(deftest ecase.6 + (ecase 'b ((a z) 1) ((y b w) 2) ((b c) 3)) + 2) + +(deftest ecase.7 + (ecase 'z + ((a b c) 1) + ((d e) 2) + ((f z g) 3)) + 3) + +(deftest ecase.8 + (ecase (1+ most-positive-fixnum) + (#.(1+ most-positive-fixnum) 'a)) + a) + +(deftest ecase.9 + (classify-error (ecase nil (nil 'a))) + type-error) + +(deftest ecase.10 + (ecase nil ((nil) 'a)) + a) + +(deftest ecase.11 + (ecase 'a (b 0) (a (values 1 2 3)) (c nil)) + 1 2 3) + +(deftest ecase.12 + (classify-error (ecase t (a 10))) + type-error) + +(deftest ecase.13 + (ecase t ((t) 10) (t 20)) + 10) + +(deftest ecase.14 + (let ((x (list 'a 'b))) + (eval `(ecase (quote ,x) ((,x) 1) (a 2)))) + 1) + +(deftest ecase.15 + (classify-error (ecase 'otherwise ((t) 10))) + type-error) + +(deftest ecase.16 + (classify-error (ecase t ((otherwise) 10))) + type-error) + +(deftest ecase.17 + (classify-error (ecase 'a (b 0) (c 1) (otherwise 2))) + type-error) + +(deftest ecase.18 + (classify-error (ecase 'a (b 0) (c 1) ((otherwise) 2))) + type-error) + +(deftest ecase.19 + (classify-error (ecase 'a (b 0) (c 1) ((t) 2))) + type-error) + +(deftest ecase.20 + (ecase #\a + ((#\b #\c) 10) + ((#\d #\e #\A) 20) + (() 30) + ((#\z #\a #\y) 40)) + 40) + +(deftest ecase.21 (ecase 1 (1 (values)) (2 'a))) + +(deftest ecase.23 (ecase 1 (1 (values 'a 'b 'c))) + a b c) + +;;; Show that the key expression is evaluated only once. +(deftest ecase.25 + (let ((x 0)) + (values + (ecase (progn (incf x) 'c) + (a 1) + (b 2) + (c 3) + (d 4)) + x)) + 3 1) + +;;; Repeated keys are allowed (all but the first are ignored) + +(deftest ecase.26 + (ecase 'b ((a b c) 10) (b 20)) + 10) + +(deftest ecase.27 + (ecase 'b (b 20) ((a b c) 10)) + 20) + +(deftest ecase.28 + (ecase 'b (b 20) (b 10) (d 0)) + 20) + +;;; There are implicit progns + +(deftest ecase.29 + (let ((x nil)) + (values + (ecase 2 + (1 (setq x 'a) 'w) + (2 (setq x 'b) 'y) + (3 (setq x 'c) 'z)) + x)) + y b) + +(deftest ecase.31 + (ecase (values 'b 'c) (c 0) ((a b) 10) (d 20)) + 10) + +(deftest ecase.32 + (ecase 'a (a) (b 'b)) + nil) diff --git a/ansi-tests/elt.lsp b/ansi-tests/elt.lsp new file mode 100644 index 0000000..16698cc --- /dev/null +++ b/ansi-tests/elt.lsp @@ -0,0 +1,368 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Oct 12 19:38:29 2002 +;;;; Contains: Tests of ELT + +(in-package :cl-test) + +(declaim (optimize (safety 3))) + +;; elt on lists + +(deftest elt.1 + (classify-error (elt nil 0)) + type-error) + +(deftest elt.1a + (classify-error (elt nil -10)) + type-error) + +(deftest elt.1b + (classify-error (locally (elt nil 0) t)) + type-error) + +(deftest elt.2 + (classify-error (elt nil 1000000)) + type-error) + +(deftest elt.3 (elt '(a b c d e) 0) a) +(deftest elt.4 (elt '(a b c d e) 2) c) +(deftest elt.5 (elt '(a b c d e) 4) e) +(deftest elt.5a + (classify-error (elt '(a b c d e) -4)) + type-error) + +(deftest elt.6 + (let ((x (make-int-list 1000))) + (notnot-mv + (every + #'(lambda (i) (eql i (elt x i))) + x))) + t) + +(deftest elt.7 + (let* ((x (list 'a 'b 'c 'd)) + (y (setf (elt x 0) 'e))) + (list x y)) + ((e b c d) e)) + +(deftest elt.8 + (let* ((x (list 'a 'b 'c 'd)) + (y (setf (elt x 1) 'e))) + (list x y)) + ((a e c d) e)) + +(deftest elt.9 + (let* ((x (list 'a 'b 'c 'd)) + (y (setf (elt x 3) 'e))) + (list x y)) + ((a b c e) e)) + +(deftest elt.10 + (classify-error + (let ((x (list 'a 'b 'c))) + (setf (elt x 4) 'd))) + type-error) + +(deftest elt.11 + (let ((x (list 'a 'b 'c 'd 'e))) + (let ((y (loop for c on x collect c))) + (setf (elt x 2) 'f) + (notnot-mv + (every #'eq + y + (loop for c on x collect c))))) + t) + +(deftest elt.12 + (let ((x (make-int-list 100000))) + (elt x 90000)) + 90000) + +(deftest elt.13 + (let ((x (make-int-list 100000))) + (setf (elt x 80000) 'foo) + (list (elt x 79999) + (elt x 80000) + (elt x 80001))) + (79999 foo 80001)) + +(deftest elt.14 + (classify-error + (let ((x (list 'a 'b 'c))) + (elt x 10))) + type-error) + +(deftest elt.15 + (classify-error + (let ((x (list 'a 'b 'c))) + (elt x 'a))) + type-error) + +(deftest elt.16 + (classify-error + (let ((x (list 'a 'b 'c))) + (elt x 10.0))) + type-error) + +(deftest elt.17 + (classify-error + (let ((x (list 'a 'b 'c))) + (elt x -1))) + type-error) + +(deftest elt.18 + (classify-error + (let ((x (list 'a 'b 'c))) + (elt x -100000000000000000))) + type-error) + +(deftest elt.19 + (classify-error + (let ((x (list 'a 'b 'c))) + (elt x #\w))) + type-error) + +(deftest elt.order.1 + (let ((i 0) x y) + (values + (elt (progn (setf x (incf i)) '(a b c d e)) + (progn (setf y (incf i)) 3)) + i x y)) + d 2 1 2) + +(deftest elt.order.2 + (let ((i 0) x y z) + (let ((a (make-array 1 :initial-element (list 'a 'b 'c 'd 'e)))) + (values + (setf (elt (aref a (progn (setf x (incf i)) 0)) + (progn (setf y (incf i)) 3)) + (progn (setf z (incf i)) 'k)) + (aref a 0) + i x y z))) + k (a b c k e) 3 1 2 3) + +(deftest elt-v.1 + (classify-error + (elt (make-array '(0)) 0)) + type-error) + +;; (deftest elt-v.2 (elt (make-array '(1)) 0) nil) ;; actually undefined +(deftest elt-v.3 + (elt (make-array '(5) :initial-contents '(a b c d e)) 0) + a) + +(deftest elt-v.4 + (elt (make-array '(5) :initial-contents '(a b c d e)) 2) + c) + +(deftest elt-v.5 + (elt (make-array '(5) :initial-contents '(a b c d e)) 4) + e) + +(deftest elt-v.6 + (elt-v-6-body) + t) + +(deftest elt-v.7 + (let* ((x (make-array '(4) :initial-contents (list 'a 'b 'c 'd))) + (y (setf (elt x 0) 'e))) + (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y)) + (e b c d e)) + +(deftest elt-v.8 + (let* ((x (make-array '(4) :initial-contents (list 'a 'b 'c 'd))) + (y (setf (elt x 1) 'e))) + (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y)) + (a e c d e)) + +(deftest elt-v.9 + (let* ((x (make-array '(4) :initial-contents (list 'a 'b 'c 'd))) + (y (setf (elt x 3) 'e))) + (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y)) + (a b c e e)) + +(deftest elt-v.10 + (classify-error + (let ((x (make-array '(3) :initial-contents (list 'a 'b 'c)))) + (setf (elt x 4) 'd))) + type-error) + +(deftest elt-v.11 + (classify-error + (let ((x (make-array '(3) :initial-contents (list 'a 'b 'c)))) + (setf (elt x -100) 'd))) + type-error) + +(deftest elt-v.12 + (let ((x (make-int-array 100000))) + (elt x 90000)) + 90000) + +(deftest elt-v.13 + (let ((x (make-int-array 100000))) + (setf (elt x 80000) 'foo) + (list (elt x 79999) + (elt x 80000) + (elt x 80001))) + (79999 foo 80001)) + +;;; Adjustable arrays + +(deftest elt-adj-array.1 + (classify-error (elt (make-adj-array '(0)) 0)) + type-error) + +;;; (deftest elt-adj-array.2 (elt (make-adj-array '(1)) 0) nil) ;; actually undefined + +(deftest elt-adj-array.3 + (elt (make-adj-array '(5) :initial-contents '(a b c d e)) 0) + a) + +(deftest elt-adj-array.4 + (elt (make-adj-array '(5) :initial-contents '(a b c d e)) 2) + c) + +(deftest elt-adj-array.5 + (elt (make-adj-array '(5) :initial-contents '(a b c d e)) 4) + e) + +(deftest elt-adj-array.6 + (elt-adj-array-6-body) + t) + +(deftest elt-adj-array.7 + (let* ((x (make-adj-array '(4) :initial-contents (list 'a 'b 'c 'd))) + (y (setf (elt x 0) 'e))) + (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y)) + (e b c d e)) + +(deftest elt-adj-array.8 + (let* ((x (make-adj-array '(4) :initial-contents (list 'a 'b 'c 'd))) + (y (setf (elt x 1) 'e))) + (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y)) + (a e c d e)) + +(deftest elt-adj-array.9 + (let* ((x (make-adj-array '(4) :initial-contents (list 'a 'b 'c 'd))) + (y (setf (elt x 3) 'e))) + (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y)) + (a b c e e)) + +(deftest elt-adj-array.10 + (classify-error + (let ((x (make-adj-array '(3) :initial-contents (list 'a 'b 'c)))) + (setf (elt x 4) 'd))) + type-error) + +(deftest elt-adj-array.11 + (classify-error + (let ((x (make-adj-array '(3) :initial-contents (list 'a 'b 'c)))) + (setf (elt x -100) 'd))) + type-error) + +(deftest elt-adj-array.12 + (let ((x (make-int-array 100000 #'make-adj-array))) + (elt x 90000)) + 90000) + +(deftest elt-adj-array.13 + (let ((x (make-int-array 100000 #'make-adj-array))) + (setf (elt x 80000) 'foo) + (list (elt x 79999) + (elt x 80000) + (elt x 80001))) + (79999 foo 80001)) + +;; displaced arrays + +(deftest elt-displaced-array.1 + (classify-error (elt (make-displaced-array '(0) 100) 0)) + type-error) + +(deftest elt-displaced-array.2 + (elt (make-displaced-array '(1) 100) 0) + 100) + +(deftest elt-displaced-array.3 + (elt (make-displaced-array '(5) 100) 4) + 104) + +;;; Arrays with fill points + +(deftest elt-fill-pointer.1 + (let ((a (make-array '(5) :initial-contents '(a b c d e) + :fill-pointer 3))) + (values (elt a 0) (elt a 1) (elt a 2))) + a b c) + +(deftest elt-fill-pointer.2 + (let ((a (make-array '(5) + :initial-contents '(0 0 1 0 0) + :element-type 'bit + :fill-pointer 3))) + (values (elt a 0) (elt a 1) (elt a 2))) + 0 0 1) + +(deftest elt-fill-pointer.3 + (classify-error + (let ((a (make-array '(5) + :initial-contents '(0 0 1 0 0) + :fill-pointer 3))) + (elt a 4))) + type-error) + +(deftest elt-fill-pointer.4 + (classify-error + (let ((a (make-array '(5) + :initial-contents '(0 0 1 0 0) + :element-type 'bit + :fill-pointer 3))) + (elt a 4))) + type-error) + +(deftest elt-fill-pointer.5 + (let ((a (make-array '(5) + :initial-contents '(#\a #\b #\c #\d #\e) + :element-type 'character + :fill-pointer 3))) + (values (elt a 0) (elt a 1) (elt a 2))) + #\a #\b #\c) + +(deftest elt-fill-pointer.6 + (classify-error + (let ((a (make-array '(5) + :initial-contents '(#\a #\b #\c #\d #\e) + :element-type 'character + :fill-pointer 3))) + (elt a 4))) + type-error) + +(deftest elt-fill-pointer.7 + (let ((a (make-array '(5) + :initial-contents '(#\a #\b #\c #\d #\e) + :element-type 'base-char + :fill-pointer 3))) + (values (elt a 0) (elt a 1) (elt a 2))) + #\a #\b #\c) + +(deftest elt-fill-pointer.8 + (classify-error + (let ((a (make-array '(5) + :initial-contents '(#\a #\b #\c #\d #\e) + :element-type 'base-char + :fill-pointer 3))) + (elt a 4))) + type-error) + +(deftest elt.error.1 + (classify-error (elt)) + program-error) + +(deftest elt.error.2 + (classify-error (elt nil)) + program-error) + +(deftest elt.error.3 + (classify-error (elt nil 0 nil)) + program-error) diff --git a/ansi-tests/eql.lsp b/ansi-tests/eql.lsp new file mode 100644 index 0000000..10318a0 --- /dev/null +++ b/ansi-tests/eql.lsp @@ -0,0 +1,87 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Thu Oct 17 19:36:33 2002 +;;;; Contains: Tests of EQL + +(in-package :cl-test) + +;;; EQLT is defined in ansi-aux.lsp +;;; It calls EQL, returning NIL when the result is false and T when it +;;; is true. + +(deftest eql.1 + (loop for x in *universe* always (check-values (eql x x))) + t) + +(deftest eql.2 + (eqlt 2 (1+ 1)) + t) + +(deftest eql.3 + (let ((x "abc")) + (eql x (copy-seq x))) + nil) + +(deftest eql.4 + (eqlt #\a #\a) + t) + +(deftest eql.5 + (eqlt 12345678901234567890 12345678901234567890) + t) + +(deftest eql.7 + (eql 12.0 12) + nil) + +(deftest eql.8 + (eqlt #c(1 -2) #c(1 -2)) + t) + +(deftest eql.9 + (let ((x "abc") (y "abc")) + (if (eq x y) (eqlt x y) (not (eql x y)))) + t) + +(deftest eql.10 + (eql (list 'a) (list 'b)) + nil) + +(deftest eql.11 + (eqlt #c(1 -2) (- #c(-1 2))) + t) + +(deftest eql.order.1 + (let ((i 0) x y) + (values + (eql (setf x (incf i)) (setf y (incf i))) + i x y)) + nil 2 1 2) + +(deftest eql.error.1 + (classify-error (eql)) + program-error) + +(deftest eql.error.2 + (classify-error (eql nil)) + program-error) + +(deftest eql.error.3 + (classify-error (eql nil nil nil)) + program-error) + +;;; Error tests for EQ + +(deftest eq.error.1 + (classify-error (eq)) + program-error) + +(deftest eq.error.2 + (classify-error (eq nil)) + program-error) + +(deftest eq.error.3 + (classify-error (eq nil nil nil)) + program-error) + + \ No newline at end of file diff --git a/ansi-tests/equal.lsp b/ansi-tests/equal.lsp new file mode 100644 index 0000000..a2a5244 --- /dev/null +++ b/ansi-tests/equal.lsp @@ -0,0 +1,81 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Thu Oct 17 21:38:16 2002 +;;;; Contains: Tests for EQUAL + +(in-package :cl-test) + +(deftest equal.1 + (loop for x in *symbols* + always (loop for y in *symbols* + always (if (eq x y) (equal x y) + (not (equal x y))))) + t) + +(deftest equal.2 + (equalt (cons 'a 'b) (cons 'a 'b)) + t) + +(deftest equal.3 + (equalt (cons 'a 'c) (cons 'a 'b)) + nil) + +(deftest equal.4 + (equalt (vector 1 2 3) (vector 1 2 3)) + nil) + +(deftest equal.5 + (loop for c in *characters* + always (loop for d in *characters* + always (if (eql c d) (equalt c d) + (not (equalt c d))))) + t) + +(deftest equal.6 + (equalt (make-pathname :name (copy-seq "foo")) + (make-pathname :name (copy-seq "foo"))) + t) + +(deftest equal.7 + (equalt (make-pathname :name (copy-seq "foo")) + (make-pathname :name (copy-seq "bar"))) + nil) + +(deftest equal.8 + (equalt (copy-seq "abcd") (copy-seq "abcd")) + t) + +(deftest equal.9 + (equalt (copy-seq "abcd") (copy-seq "abc")) + nil) + +(deftest equal.10 + (equalt (copy-seq "abcd") (copy-seq "ABCD")) + nil) + +(deftest equal.11 + (equalt (copy-seq #*000110) (copy-seq #*000110)) + t) + +(deftest equal.12 + (equalt (copy-seq #*000110) (copy-seq #*000111)) + nil) + +(deftest equal.order.1 + (let ((i 0) x y) + (values + (equal (setf x (incf i)) (setf y (incf i))) + i x y)) + nil 2 1 2) + +(deftest equal.error.1 + (classify-error (equal)) + program-error) + +(deftest equal.error.2 + (classify-error (equal nil)) + program-error) + +(deftest equal.error.3 + (classify-error (equal nil nil nil)) + program-error) diff --git a/ansi-tests/equalp.lsp b/ansi-tests/equalp.lsp new file mode 100644 index 0000000..5248fc7 --- /dev/null +++ b/ansi-tests/equalp.lsp @@ -0,0 +1,47 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Thu Oct 17 22:14:42 2002 +;;;; Contains: Tests for EQUALP + +(in-package :cl-test) + +(deftest equalp.1 + (loop for c across +base-chars+ + always (loop for d across +base-chars+ + always (if (char-equal c d) (equalpt c d) + (not (equalpt c d))))) + t) + +(deftest equalp.2 + (loop for i from 1 to 100 + always (loop for j from 1 to 100 + always (if (eqlt i j) (equalpt i j) + (not (equalpt i j))))) + t) + +(deftest equalp.3 + (equalpt "abc" "ABC") + t) + +(deftest equalp.4 + (equalpt "abc" "abd") + nil) + +(deftest equalp.order.1 + (let ((i 0) x y) + (values + (equalp (setf x (incf i)) (setf y (incf i))) + i x y)) + nil 2 1 2) + +(deftest equalp.error.1 + (classify-error (equalp)) + program-error) + +(deftest equalp.error.2 + (classify-error (equalp nil)) + program-error) + +(deftest equalp.error.3 + (classify-error (equalp nil nil nil)) + program-error) diff --git a/ansi-tests/error.lsp b/ansi-tests/error.lsp new file mode 100644 index 0000000..1bd9c7d --- /dev/null +++ b/ansi-tests/error.lsp @@ -0,0 +1,66 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Jan 28 21:37:43 2003 +;;;; Contains: Tests of ERROR + +(in-package :cl-test) + +(deftest error.1 + (let ((fmt "Error")) + (handler-case + (error fmt) + (simple-error (c) (frob-simple-error c fmt)))) + t) + +(deftest error.2 + (let* ((fmt "Error") + (cnd (make-condition 'simple-error :format-control fmt))) + (handler-case + (error cnd) + (simple-error (c) (frob-simple-error c fmt)))) + t) + +(deftest error.3 + (let ((fmt "Error")) + (handler-case + (error 'simple-error :format-control fmt) + (simple-error (c) (frob-simple-error c fmt)))) + t) + +(deftest error.4 + (let ((fmt "Error: ~A")) + (handler-case + (error fmt 10) + (simple-error (c) (frob-simple-error c fmt 10)))) + t) + +(deftest error.5 + (let ((fmt (formatter "Error"))) + (handler-case + (error fmt) + (simple-error (c) (frob-simple-error c fmt)))) + t) + +(deftest error.6 + (handler-case + (error 'simple-condition) + (error (c) :wrong) + (simple-condition (c) :right)) + :right) + +(deftest error.7 + (handler-case + (error 'simple-warning) + (error (c) :wrong) + (simple-warning (c) :right) + (condition (c) :wrong2)) + :right) + +(deftest error.8 + (let ((fmt "Boo!")) + (handler-case + (error 'simple-warning :format-control fmt) + (simple-warning (c) (frob-simple-warning c fmt)))) + t) + +;;; Tests for other conditions will in their own files. diff --git a/ansi-tests/etypecase.lsp b/ansi-tests/etypecase.lsp new file mode 100644 index 0000000..06d46ec --- /dev/null +++ b/ansi-tests/etypecase.lsp @@ -0,0 +1,61 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Oct 18 23:02:23 2002 +;;;; Contains: Tests of ETYPECASE + +(in-package :cl-test) + +(deftest etypecase.1 + (etypecase 1 (integer 'a) (t 'b)) + a) + +(deftest etypecase.2 + (classify-error (etypecase 1 (symbol 'a))) + type-error) + +(deftest etypecase.3 + (etypecase 1 (symbol 'a) (t 'b)) + b) + +(deftest etypecase.4 + (etypecase 1 (t (values)))) + +(deftest etypecase.5 + (etypecase 1 (integer (values)) (t 'a))) + +(deftest etypecase.6 + (etypecase 1 (bit 'a) (integer 'b)) + a) + +(deftest etypecase.7 + (etypecase 1 (t 'a)) + a) + +(deftest etypecase.8 + (etypecase 1 (t (values 'a 'b 'c))) + a b c) + +(deftest etypecase.9 + (etypecase 1 (integer (values 'a 'b 'c)) (t nil)) + a b c) + +(deftest etypecase.10 + (let ((x 0)) + (values + (etypecase 1 + (bit (incf x) 'a) + (integer (incf x 2) 'b) + (t (incf x 4) 'c)) + x)) + a 1) + +(deftest etypecase.11 + (etypecase 1 (integer) (t 'a)) + nil) + +(deftest etypecase.12 + (etypecase 'a + (number 'bad) + (#.(find-class 'symbol nil) 'good)) + good) + diff --git a/ansi-tests/eval-and-compile.lsp b/ansi-tests/eval-and-compile.lsp new file mode 100644 index 0000000..4580c55 --- /dev/null +++ b/ansi-tests/eval-and-compile.lsp @@ -0,0 +1,22 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Mon Oct 21 22:52:19 2002 +;;;; Contains: Overall tests for section 3, 'Evaluation and Compilation' + +(in-package :cl-test) + +(defparameter *eval-and-compile-fns* + '(compile eval macroexpand macroexpand-1 proclaim special-operator-p + constantp)) + +(deftest eval-and-compile-fns + (remove-if #'fboundp *eval-and-compile-fns*) + nil) + +(defparameter *eval-and-compile-macros* + '(lambda define-compiler-macro defmacro define-symbol-macro declaim)) + +(deftest eval-and-compile-macros + (remove-if #'macro-function *eval-and-compile-macros*) + nil) + diff --git a/ansi-tests/eval.lsp b/ansi-tests/eval.lsp new file mode 100644 index 0000000..cf16659 --- /dev/null +++ b/ansi-tests/eval.lsp @@ -0,0 +1,52 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Thu Nov 21 10:43:15 2002 +;;;; Contains: Tests of EVAL + +(in-package :cl-test) + +(deftest eval.1 + (eval 1) + 1) + +(deftest eval.2 + (loop for x being the symbols of "KEYWORD" + always (eq (eval x) x)) + t) + +(deftest eval.3 + (let ((s "abcd")) + (eqlt (eval s) s)) + t) + +(deftest eval.4 + (eval '(car '(a . b))) + a) + +(deftest eval.5 + (eval '(let ((x 0)) x)) + 0) + +(deftest eval.6 + (funcall #'eval 1) + 1) + +(deftest eval.order.1 + (let ((i 0)) + (values (eval (progn (incf i) 10)) i)) + 10 1) + +;;; Error cases + +(deftest eval.error.1 + (classify-error (eval)) + program-error) + +(deftest eval.error.2 + (classify-error (eval nil nil)) + program-error) + +(deftest eval.error.3 + (classify-error (eval (list (gensym)))) + undefined-function) + diff --git a/ansi-tests/every.lsp b/ansi-tests/every.lsp new file mode 100644 index 0000000..412fb15 --- /dev/null +++ b/ansi-tests/every.lsp @@ -0,0 +1,150 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Thu Oct 17 23:25:58 2002 +;;;; Contains: Tests of EVERY + +(in-package :cl-test) + +(deftest every.1 + (notnot-mv (every #'identity nil)) + t) + +(deftest every.2 + (notnot-mv (every #'identity #())) + t) + +(deftest every.3 + (let ((count 0)) + (values + (every #'(lambda (x) (incf count) (< x 10)) + '(1 2 4 13 5 1)) + count)) + nil 4) + +(deftest every.4 + (notnot-mv (every #'= '(1 2 3 4) '(1 2 3 4 5))) + t) + +(deftest every.5 + (notnot-mv (every #'= '(1 2 3 4 5) '(1 2 3 4))) + t) + +(deftest every.6 + (every #'= '(1 2 3 4 5) '(1 2 3 4 6)) + nil) + +(deftest every.7 + (notnot-mv (every #'(lambda (x y) (or x y)) + '(nil t t nil t) #(t nil t t nil nil))) + t) + +(deftest every.8 + (let ((x '(1)) + (args nil)) + (loop for i from 1 below (1- (min 100 call-arguments-limit)) + do (push x args) + always (apply #'every #'= args))) + t) + +(deftest every.9 + (notnot-mv (every #'zerop #*000000000000)) + t) + +(deftest every.10 + (notnot-mv (every #'zerop #*)) + t) + +(deftest every.11 + (every #'zerop #*0000010000) + nil) + +(deftest every.12 + (notnot-mv (every #'(lambda (x) (eql x #\a)) "aaaaaaaa")) + t) + +(deftest every.13 + (notnot-mv (every #'(lambda (x) (eql x #\a)) "")) + t) + +(deftest every.14 + (every #'(lambda (x) (eql x #\a)) "aaaaaabaaaa") + nil) + +(deftest every.15 + (every 'null '(nil nil t nil)) + nil) + +(deftest every.16 + (notnot-mv (every 'null '(nil nil nil nil))) + t) + +(deftest every.order.1 + (let ((i 0) x y) + (values + (every (progn (setf x (incf i)) #'null) + (progn (setf y (incf i)) '(nil nil a nil))) + i x y)) + nil 2 1 2) + +(deftest every.order.2 + (let ((i 0) x y z) + (values + (every (progn (setf x (incf i)) #'equal) + (progn (setf y (incf i)) '(nil nil a nil)) + (progn (setf z (incf i)) '(nil nil a b))) + i x y z)) + nil 3 1 2 3) + +;;; Error cases + +(deftest every.error.1 + (classify-error (every 1 '(a b c))) + type-error) + +(deftest every.error.2 + (classify-error (every #\a '(a b c))) + type-error) + +(deftest every.error.3 + (classify-error (every #() '(a b c))) + type-error) + +(deftest every.error.4 + (classify-error (every #'null 'a)) + type-error) + +(deftest every.error.5 + (classify-error (every #'null 100)) + type-error) + +(deftest every.error.6 + (classify-error (every #'null 'a)) + type-error) + +(deftest every.error.7 + (classify-error (every #'eq () 'a)) + type-error) +` +(deftest every.error.8 + (classify-error (every)) + program-error) + +(deftest every.error.9 + (classify-error (every #'null)) + program-error) + +(deftest every.error.10 + (classify-error (locally (every 1 '(a b c)) t)) + type-error) + +(deftest every.error.11 + (classify-error (every #'cons '(a b c))) + program-error) + +(deftest every.error.12 + (classify-error (every #'cons '(a b c) '(1 2 3) '(4 5 6))) + program-error) + +(deftest every.error.13 + (classify-error (every #'car '(a b c))) + type-error) diff --git a/ansi-tests/fboundp.lsp b/ansi-tests/fboundp.lsp new file mode 100644 index 0000000..0ec7332 --- /dev/null +++ b/ansi-tests/fboundp.lsp @@ -0,0 +1,69 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Mon Oct 7 22:37:22 2002 +;;;; Contains: Tests of FBOUNDP + +(in-package :cl-test) + +(deftest fboundp.1 + (not-mv (fboundp 'car)) + nil) + +(deftest fboundp.2 + (not-mv (fboundp 'cdr)) + nil) + +(deftest fboundp.3 + (not-mv (fboundp 'defun)) ; a macro + nil) + +(deftest fboundp.4 + ;; fresh symbols are not fbound + (let ((g (gensym))) (fboundp g)) + nil) + +(defun fboundp-5-fn (x) x) +(deftest fboundp.5 + (not-mv (fboundp 'fboundp-5-fn)) + nil) + +(eval-when (eval compile) + (ignore-errors + (defun (setf fboundp-6-accessor) (y x) (setf (car x) y)))) + +(deftest fboundp.6 + (not-mv (fboundp '(setf fboundp-6-accessor))) + nil) + +(deftest fboundp.7 + (let ((g (gensym))) (fboundp (list 'setf g))) + nil) + +(deftest fboundp.order.1 + (let ((i 0)) + (values (notnot (fboundp (progn (incf i) 'car))) i)) + t 1) + +(deftest fboundp.error.1 + (classify-error (fboundp 1)) + type-error) + +(deftest fboundp.error.2 + (classify-error (fboundp #\a)) + type-error) + +(deftest fboundp.error.3 + (classify-error (fboundp '(foo))) + type-error) + +(deftest fboundp.error.4 + (classify-error (fboundp)) + program-error) + +(deftest fboundp.error.5 + (classify-error (fboundp 'cons nil)) + program-error) + +(deftest fboundp.error.6 + (classify-error (locally (fboundp 1) t)) + type-error) diff --git a/ansi-tests/fdefinition.lsp b/ansi-tests/fdefinition.lsp new file mode 100644 index 0000000..1cfaa8d --- /dev/null +++ b/ansi-tests/fdefinition.lsp @@ -0,0 +1,83 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Mon Jan 13 15:27:51 2003 +;;;; Contains: Tests for FDEFINITION + +(in-package :cl-test) + +;;; Error cases + +(deftest fdefinition.error.1 + (classify-error (fdefinition)) + program-error) + +(deftest fdefinition.error.2 + (classify-error (fdefinition 'cons nil)) + program-error) + +(deftest fdefinition.error.3 + (classify-error (fdefinition (gensym))) + undefined-function) + +(deftest fdefinition.error.4 + (classify-error (fdefinition 10)) + type-error) + +(deftest fdefinition.error.5 + (classify-error (fdefinition (list 'setf (gensym)))) + undefined-function) + +(deftest fdefinition.error.6 + (classify-error (locally (fdefinition 10) t)) + type-error) + +;;; Non-error cases + +(deftest fdefinition.1 + (let ((fun (fdefinition 'cons))) + (funcall fun 'a 'b)) + (a . b)) + +(deftest fdefinition.2 + (progn + (fdefinition 'cond) + :good) + :good) + +(deftest fdefinition.3 + (progn + (fdefinition 'setq) + :good) + :good) + +(deftest fdefinition.4 + (let ((sym (gensym))) + (values + (fboundp sym) + (progn + (setf (fdefinition sym) (fdefinition 'cons)) + (funcall (symbol-function sym) 'a 'b)) + (notnot (fboundp sym)))) + nil + (a . b) + t) + +(deftest fdefinition.5 + (let* ((sym (gensym)) + (fname (list 'setf sym))) + (values + (fboundp fname) + (progn + (setf (fdefinition fname) (fdefinition 'cons)) + (eval `(setf (,sym 'a) 'b))) + (notnot (fboundp fname)))) + nil + (b . a) + t) + +(deftest fdefinition.order.1 + (let ((i 0)) + (fdefinition (progn (incf i) 'setq)) + i) + 1) + diff --git a/ansi-tests/features.lsp b/ansi-tests/features.lsp new file mode 100644 index 0000000..57d0a47 --- /dev/null +++ b/ansi-tests/features.lsp @@ -0,0 +1,22 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Mon Dec 2 07:44:40 2002 +;;;; Contains: Tests of *FEATURES* + +(in-package :cl-test) + +(deftest features.1 + (let ((f *features*)) + (or (not (member :draft-ansi-cl f)) + (not (intersection '(:draft-ansi-cl-2 :ansi-cl) f)))) + t) + +(deftest features.2 + (let ((f *features*)) + (or (not (intersection '(:x3j13 :draft-ansi-cl :ansi-cl) f)) + (notnot (member :common-lisp f)))) + t) + +(deftest features.3 + (not (member :cltl2 *features*)) + t) diff --git a/ansi-tests/fill-pointer.lsp b/ansi-tests/fill-pointer.lsp new file mode 100644 index 0000000..2f86e42 --- /dev/null +++ b/ansi-tests/fill-pointer.lsp @@ -0,0 +1,82 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Jan 21 22:14:23 2003 +;;;; Contains: Tests of FILL-POINTER + +(in-package :cl-test) + +;;; More tests are in make-array.lsp + +(deftest fill-pointer.1 + (fill-pointer (make-array '(10) :fill-pointer 5)) + 5) + +(deftest fill-pointer.2 + (fill-pointer (make-array '(10) :fill-pointer t)) + 10) + +(deftest fill-pointer.3 + (let ((a (make-array '(10) :fill-pointer 5 + :initial-contents '(1 2 3 4 5 6 7 8 9 10)))) + (values + (fill-pointer a) + (setf (fill-pointer a) 6) + a)) + 5 6 #(1 2 3 4 5 6)) + +(deftest fill-pointer.order.1 + (let ((i 0) + (a (make-array '(10) :fill-pointer 5))) + (values + (fill-pointer (progn (incf i) a)) + i)) + 5 1) + +(deftest fill-pointer.order.2 + (let ((i 0) x y + (a (make-array '(10) :fill-pointer 5 + :initial-contents '(1 2 3 4 5 6 7 8 9 10)))) + (values + i + (setf (fill-pointer (progn (setf x (incf i)) a)) + (progn (setf y (incf i)) 6)) + a + i x y)) + 0 6 #(1 2 3 4 5 6) 2 1 2) + +;;; Error tests + +(deftest fill-pointer.error.1 + (classify-error (fill-pointer)) + program-error) + +(deftest fill-pointer.error.2 + (classify-error (fill-pointer (make-array '(10) :fill-pointer 4) + nil)) + program-error) + +(deftest fill-pointer.error.3 + (classify-error (fill-pointer (make-array '(10) :fill-pointer nil))) + type-error) + +(deftest fill-pointer.error.4 + (classify-error (fill-pointer #0aNIL)) + type-error) + +(deftest fill-pointer.error.5 + (classify-error (fill-pointer #2a((a b c)(d e f)))) + type-error) + +(deftest fill-pointer.error.6 + (let (why) + (loop for e in *mini-universe* + when (and (or (not (typep e 'vector)) + (not (array-has-fill-pointer-p e))) + (not (eql (setq why (classify-error** `(fill-pointer ',e))) + 'type-error))) + collect (list e why))) + nil) + +(deftest fill-pointer.error.7 + (classify-error (locally (fill-pointer #2a((a b c)(d e f))) t)) + type-error) diff --git a/ansi-tests/fill-strings.lsp b/ansi-tests/fill-strings.lsp new file mode 100644 index 0000000..38bdc3c --- /dev/null +++ b/ansi-tests/fill-strings.lsp @@ -0,0 +1,26 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Aug 17 08:04:27 2002 +;;;; Contains: Test cases for FILL on strings + +(in-package :cl-test) + +(deftest array-string-fill.1 + (array-string-fill-test-fn "abcde" #\Z) + t "ZZZZZ") + +(deftest array-string-fill.2 + (array-string-fill-test-fn "abcde" #\Z :start 2) + t "abZZZ") + +(deftest array-string-fill.3 + (array-string-fill-test-fn "abcde" #\Z :end 3) + t "ZZZde") + +(deftest array-string-fill.4 + (array-string-fill-test-fn "abcde" #\Z :start 1 :end 4) + t "aZZZe") + +(deftest array-string-fill.5 + (array-string-fill-test-fn "abcde" #\Z :start 2 :end 3) + t "abZde") diff --git a/ansi-tests/fill.lsp b/ansi-tests/fill.lsp new file mode 100644 index 0000000..6e85f1f --- /dev/null +++ b/ansi-tests/fill.lsp @@ -0,0 +1,522 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Oct 12 19:44:45 2002 +;;;; Contains: Tests on FILL + +(in-package :cl-test) + +(deftest fill.error.1 + (classify-error (fill 'a 'b)) + type-error) + +(deftest fill.error.2 + (classify-error (fill)) + program-error) + +(deftest fill.error.3 + (classify-error (fill (list 'a 'b))) + program-error) + +(deftest fill.error.4 + (classify-error (fill (list 'a 'b) 'c :bad t)) + program-error) + +(deftest fill.error.5 + (classify-error (fill (list 'a 'b) 'c :bad t :allow-other-keys nil)) + program-error) + +(deftest fill.error.6 + (classify-error (fill (list 'a 'b) 'c :start)) + program-error) + +(deftest fill.error.7 + (classify-error (fill (list 'a 'b) 'c :end)) + program-error) + +(deftest fill.error.8 + (classify-error (fill (list 'a 'b) 'c 1 2)) + program-error) + +(deftest fill.error.10 + (classify-error (fill (list 'a 'b) 'c :bad t :allow-other-keys nil + :allow-other-keys t)) + program-error) + +(deftest fill.error.11 + (classify-error (locally (fill 'a 'b) t)) + type-error) + +;;; Fill on arrays + +(deftest array-fill-1 + (let* ((a (make-array '(5) :initial-contents '(a b c d e))) + (b (fill a 'x))) + (values (eqt a b) + (map 'list #'identity a))) + t (x x x x x)) + +(deftest array-fill-2 + (let* ((a (make-array '(5) :initial-contents '(a b c d e))) + (b (fill a 'x :start 2))) + (values (eqt a b) + (map 'list #'identity a))) + t (a b x x x)) + +(deftest array-fill-3 + (let* ((a (make-array '(5) :initial-contents '(a b c d e))) + (b (fill a 'x :end 2))) + (values (eqt a b) + (map 'list #'identity a))) + t (x x c d e)) + +(deftest array-fill-4 + (let* ((a (make-array '(5) :initial-contents '(a b c d e))) + (b (fill a 'x :start 1 :end 3))) + (values (eqt a b) + (map 'list #'identity a))) + t (a x x d e)) + +(deftest array-fill-5 + (let* ((a (make-array '(5) :initial-contents '(a b c d e))) + (b (fill a 'x :start 1 :end nil))) + (values (eqt a b) + (map 'list #'identity a))) + t (a x x x x)) + +(deftest array-fill-6 + (let* ((a (make-array '(5) :initial-contents '(a b c d e))) + (b (fill a 'x :end nil))) + (values (eqt a b) + (map 'list #'identity a))) + t (x x x x x)) + +(deftest array-fill-7 + (classify-error + (let* ((a (make-array '(5)))) + (fill a 'x :start -1))) + type-error) + +(deftest array-fill-8 + (classify-error + (let* ((a (make-array '(5)))) + (fill a 'x :start 'a))) + type-error) + +(deftest array-fill-9 + (classify-error + (let* ((a (make-array '(5)))) + (fill a 'x :end -1))) + type-error) + +(deftest array-fill-10 + (classify-error + (let* ((a (make-array '(5)))) + (fill a 'x :end 'a))) + type-error) + +;;; fill on arrays of fixnums + +(deftest array-fixnum-fill-1 + (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) + (b (fill a 6))) + (values (eqt a b) + (map 'list #'identity a))) + t (6 6 6 6 6)) + +(deftest array-fixnum-fill-2 + (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) + (b (fill a 6 :start 2))) + (values (eqt a b) + (map 'list #'identity a))) + t (1 2 6 6 6)) + +(deftest array-fixnum-fill-3 + (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) + (b (fill a 7 :end 2))) + (values (eqt a b) + (map 'list #'identity a))) + t (7 7 3 4 5)) + +(deftest array-fixnum-fill-4 + (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) + (b (fill a 8 :start 1 :end 3))) + (values (eqt a b) + (map 'list #'identity a))) + t (1 8 8 4 5)) + +(deftest array-fixnum-fill-5 + (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) + (b (fill a 0 :start 1 :end nil))) + (values (eqt a b) + (map 'list #'identity a))) + t (1 0 0 0 0)) + +(deftest array-fixnum-fill-6 + (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) + (b (fill a -1 :end nil))) + (values (eqt a b) + (map 'list #'identity a))) + t (-1 -1 -1 -1 -1)) + +(deftest array-fixnum-fill-7 + (classify-error + (let* ((a (make-array '(5) :element-type 'fixnum))) + (fill a 10 :start -1))) + type-error) + +(deftest array-fixnum-fill-8 + (classify-error + (let* ((a (make-array '(5) :element-type 'fixnum))) + (fill a 100 :start 'a))) + type-error) + +(deftest array-fixnum-fill-9 + (classify-error + (let* ((a (make-array '(5) :element-type 'fixnum))) + (fill a -5 :end -1))) + type-error) + +(deftest array-fixnum-fill-10 + (classify-error + (let* ((a (make-array '(5) :element-type 'fixnum))) + (fill a 17 :end 'a))) + type-error) + +;;; fill on arrays of unsigned eight bit bytes + +(deftest array-unsigned-byte8-fill-1 + (array-unsigned-byte-fill-test-fn 8 6) + t (6 6 6 6 6)) + +(deftest array-unsigned-byte8-fill-2 + (array-unsigned-byte-fill-test-fn 8 6 :start 2) + t (1 2 6 6 6)) + +(deftest array-unsigned-byte8-fill-3 + (array-unsigned-byte-fill-test-fn 8 7 :end 2) + t (7 7 3 4 5)) + +(deftest array-unsigned-byte8-fill-4 + (array-unsigned-byte-fill-test-fn 8 8 :start 1 :end 3) + t (1 8 8 4 5)) + +(deftest array-unsigned-byte8-fill-5 + (array-unsigned-byte-fill-test-fn 8 9 :start 1 :end nil) + t (1 9 9 9 9)) + +(deftest array-unsigned-byte8-fill-6 + (array-unsigned-byte-fill-test-fn 8 0 :end nil) + t (0 0 0 0 0)) + +(deftest array-unsigned-byte8-fill-7 + (classify-error (array-unsigned-byte-fill-test-fn 8 0 :start -1)) + type-error) + +(deftest array-unsigned-byte8-fill-8 + (classify-error (array-unsigned-byte-fill-test-fn 8 100 :start 'a)) + type-error) + +(deftest array-unsigned-byte8-fill-9 + (classify-error (array-unsigned-byte-fill-test-fn 8 19 :end -1)) + type-error) + +(deftest array-unsigned-byte8-fill-10 + (classify-error (array-unsigned-byte-fill-test-fn 8 17 :end 'a)) + type-error) + +;;; Tests on arrays with fill pointers + +(deftest array-fill-pointer-fill.1 + (let ((s1 (make-array '(10) :fill-pointer 5 :initial-element nil))) + (fill s1 'a) + (loop for i from 0 to 9 collect (aref s1 i))) + (a a a a a nil nil nil nil nil)) + +(deftest array-fill-pointer-fill.2 + (let ((s1 (make-array '(10) :fill-pointer 5 :initial-element nil))) + (fill s1 'a :end nil) + (loop for i from 0 to 9 collect (aref s1 i))) + (a a a a a nil nil nil nil nil)) + +;;; Tests on strings + +(deftest fill.string.1 + (let* ((s1 (copy-seq "abcde")) + (s2 (fill s1 #\z))) + (values (eqt s1 s2) s2)) + t + "zzzzz") + +(deftest fill.string.2 + (let* ((s1 (copy-seq "abcde")) + (s2 (fill s1 #\z :start 0 :end 1))) + (values (eqt s1 s2) s2)) + t + "zbcde") + +(deftest fill.string.3 + (let* ((s1 (copy-seq "abcde")) + (s2 (fill s1 #\z :end 2))) + (values (eqt s1 s2) s2)) + t + "zzcde") + +(deftest fill.string.4 + (let* ((s1 (copy-seq "abcde")) + (s2 (fill s1 #\z :end nil))) + (values (eqt s1 s2) s2)) + t + "zzzzz") + +(deftest fill.string.5 + (let* ((s1 "aaaaaaaa") + (len (length s1))) + (loop for start from 0 to (1- len) + always + (loop for end from (1+ start) to len + always + (let* ((s2 (copy-seq s1)) + (s3 (fill s2 #\z :start start :end end))) + (and (eqt s2 s3) + (string= s3 + (substitute-if #\z (constantly t) s1 + :start start :end end)) + t))))) + t) + +(deftest fill.string.6 + (let* ((s1 "aaaaaaaa") + (len (length s1))) + (loop for start from 0 to (1- len) + always + (let* ((s2 (copy-seq s1)) + (s3 (fill s2 #\z :start start))) + (and (eqt s2 s3) + (string= s3 + (substitute-if #\z (constantly t) s1 + :start start)) + t)))) + t) + +(deftest fill.string.7 + (let* ((s1 "aaaaaaaa") + (len (length s1))) + (loop for start from 0 to (1- len) + always + (let* ((s2 (copy-seq s1)) + (s3 (fill s2 #\z :end nil :start start))) + (and (eqt s2 s3) + (string= s3 + (substitute-if #\z (constantly t) s1 + :end nil :start start)) + t)))) + t) + +(deftest fill.string.8 + (let* ((s1 "aaaaaaaa") + (len (length s1))) + (loop for end from 1 to len + always + (let* ((s2 (copy-seq s1)) + (s3 (fill s2 #\z :end end))) + (and (eqt s2 s3) + (string= s3 + (substitute-if #\z (constantly t) s1 + :end end)) + t)))) + t) + +(deftest fill.string.9 + (let* ((s1 (make-array '(8) :element-type 'character + :initial-element #\z + :fill-pointer 4)) + (s2 (fill s1 #\a))) + (and (eqt s1 s2) + (coerce (loop for i from 0 to 7 collect (aref s2 i)) + 'string))) + "aaaazzzz") + +(deftest fill.string.10 + (let* ((s1 (make-array '(8) :element-type 'base-char + :initial-element #\z + :fill-pointer 4)) + (s2 (fill s1 #\a))) + (and (eqt s1 s2) + (coerce (loop for i from 0 to 7 collect (aref s2 i)) + 'base-string))) + "aaaazzzz") + +;;; Tests for bit vectors + +(deftest fill.bit-vector.1 + (let* ((s1 (copy-seq #*01100)) + (s2 (fill s1 0))) + (values (eqt s1 s2) s2)) + t + #*00000) + +(deftest fill.bit-vector.2 + (let* ((s1 (copy-seq #*00100)) + (s2 (fill s1 1 :start 0 :end 1))) + (values (eqt s1 s2) s2)) + t + #*10100) + +(deftest fill.bit-vector.3 + (let* ((s1 (copy-seq #*00010)) + (s2 (fill s1 1 :end 2))) + (values (eqt s1 s2) s2)) + t + #*11010) + +(deftest fill.bit-vector.4 + (let* ((s1 (copy-seq #*00111)) + (s2 (fill s1 0 :end nil))) + (values (eqt s1 s2) s2)) + t + #*00000) + +(deftest fill.bit-vector.5 + (let* ((s1 #*00000000) + (len (length s1))) + (loop for start from 0 to (1- len) + always + (loop for end from (1+ start) to len + always + (let* ((s2 (copy-seq s1)) + (s3 (fill s2 1 :start start :end end))) + (and (eqt s2 s3) + (equalp s3 + (substitute-if 1 (constantly t) s1 + :start start :end end)) + t))))) + t) + +(deftest fill.bit-vector.6 + (let* ((s1 #*11111111) + (len (length s1))) + (loop for start from 0 to (1- len) + always + (let* ((s2 (copy-seq s1)) + (s3 (fill s2 0 :start start))) + (and (eqt s2 s3) + (equalp s3 + (substitute-if 0 (constantly t) s1 + :start start)) + t)))) + t) + +(deftest fill.bit-vector.7 + (let* ((s1 #*00000000) + (len (length s1))) + (loop for start from 0 to (1- len) + always + (let* ((s2 (copy-seq s1)) + (s3 (fill s2 1 :end nil :start start))) + (and (eqt s2 s3) + (equalp s3 + (substitute-if 1 (constantly t) s1 + :end nil :start start)) + t)))) + t) + +(deftest fill.bit-vector.8 + (let* ((s1 #*11111111) + (len (length s1))) + (loop for end from 1 to len + always + (let* ((s2 (copy-seq s1)) + (s3 (fill s2 0 :end end))) + (and (eqt s2 s3) + (equalp s3 + (substitute-if 0 (constantly t) s1 + :end end)) + t)))) + t) + +(deftest fill.bit-vector.9 + (let* ((s1 (make-array '(8) :element-type 'bit + :initial-element 0 + :fill-pointer 4)) + (s2 (fill s1 1))) + (and (eqt s1 s2) + (coerce (loop for i from 0 to 7 collect (aref s2 i)) + 'bit-vector))) + #*11110000) + +;;; Test of :allow-other-keys + +(deftest fill.allow-other-keys.1 + (fill (list 'a 'b 'c 'd 'e) 'a :allow-other-keys t) + (a a a a a)) + +(deftest fill.allow-other-keys.2 + (fill (list 'a 'b 'c 'd 'e) 'a :allow-other-keys nil) + (a a a a a)) + +(deftest fill.allow-other-keys.3 + (fill (list 'a 'b 'c 'd 'e) 'a :allow-other-keys t :bad t) + (a a a a a)) + +(deftest fill.allow-other-keys.4 + (fill (list 'a 'b 'c 'd 'e) 'a :bad t :allow-other-keys t) + (a a a a a)) + +(deftest fill.allow-other-keys.5 + (fill (list 'a 'b 'c 'd 'e) 'a 'bad t :allow-other-keys t) + (a a a a a)) + +(deftest fill.allow-other-keys.6 + (fill (list 'a 'b 'c 'd 'e) 'a :bad t :allow-other-keys t + :allow-other-keys nil) + (a a a a a)) + +(deftest fill.allow-other-keys.7 + (fill (list 'a 'b 'c 'd 'e) 'a :allow-other-keys t :allow-other-keys nil + :bad t) + (a a a a a)) + + +;;; Tests of evaluation order + +(deftest fill.order.1 + (let ((i 0) x y (a (copy-seq #(a a a a)))) + (values + (fill (progn (setf x (incf i)) a) + (progn (setf y (incf i)) 'z)) + i x y)) + #(z z z z) 2 1 2) + +(deftest fill.order.2 + (let ((i 0) x y z w (a (copy-seq #(a a a a)))) + (values + (fill (progn (setf x (incf i)) a) + (progn (setf y (incf i)) 'z) + :start (progn (setf z (incf i)) 1) + :end (progn (setf w (incf i)) 3)) + i x y z w)) + #(a z z a) 4 1 2 3 4) + +(deftest fill.order.3 + (let ((i 0) x y z w (a (copy-seq #(a a a a)))) + (values + (fill (progn (setf x (incf i)) a) + (progn (setf y (incf i)) 'z) + :end (progn (setf z (incf i)) 3) + :start (progn (setf w (incf i)) 1)) + i x y z w)) + #(a z z a) 4 1 2 3 4) + +(deftest fill.order.4 + (let ((i 0) x y z p q r s w (a (copy-seq #(a a a a)))) + (values + (fill (progn (setf x (incf i)) a) + (progn (setf y (incf i)) 'z) + :end (progn (setf z (incf i)) 3) + :end (progn (setf p (incf i)) 1) + :end (progn (setf q (incf i)) 1) + :end (progn (setf r (incf i)) 1) + :start (progn (setf s (incf i)) 1) + :start (progn (setf w (incf i)) 0)) + i x y z p q r s w)) + #(a z z a) 8 1 2 3 4 5 6 7 8) diff --git a/ansi-tests/find-if-not.lsp b/ansi-tests/find-if-not.lsp new file mode 100644 index 0000000..7d5e7b2 --- /dev/null +++ b/ansi-tests/find-if-not.lsp @@ -0,0 +1,611 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Aug 28 20:53:24 2002 +;;;; Contains: Tests for FIND-IF-NOT + +(in-package :cl-test) + +(deftest find-if-not-list.1 + (find-if-not #'identity ()) + nil) + +(deftest find-if-not-list.2 + (find-if-not #'null '(a)) + a) + +(deftest find-if-not-list.2a + (find-if-not 'null '(a)) + a) + +(deftest find-if-not-list.3 + (find-if-not #'oddp '(1 2 4 8 3 1 6 7)) + 2) + +(deftest find-if-not-list.4 + (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :from-end t) + 6) + +(deftest find-if-not-list.5 + (loop for i from 0 to 7 collect + (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start i)) + (2 2 4 8 6 6 6 nil)) + +(deftest find-if-not-list.6 + (loop for i from 0 to 7 collect + (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start i :end nil)) + (2 2 4 8 6 6 6 nil)) + +(deftest find-if-not-list.7 + (loop for i from 0 to 7 collect + (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start i :from-end t)) + (6 6 6 6 6 6 6 nil)) + +(deftest find-if-not-list.8 + (loop for i from 0 to 7 collect + (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start i :end nil :from-end t)) + (6 6 6 6 6 6 6 nil)) + +(deftest find-if-not-list.9 + (loop for i from 0 to 8 collect + (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :end i)) + (nil nil 2 2 2 2 2 2 2)) + +(deftest find-if-not-list.10 + (loop for i from 0 to 8 collect + (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :end i :from-end t)) + (nil nil 2 4 8 8 8 6 6)) + +(deftest find-if-not-list.11 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start j :end i))) + ((nil 2 2 2 2 2 2 2) + (2 2 2 2 2 2 2) + (4 4 4 4 4 4) + (8 8 8 8 8) + (nil nil 6 6) + (nil 6 6) + (6 6) + (nil))) + +(deftest find-if-not-list.12 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start j :end i + :from-end t))) + ((nil 2 4 8 8 8 6 6) + (2 4 8 8 8 6 6) + (4 8 8 8 6 6) + (8 8 8 6 6) + (nil nil 6 6) + (nil 6 6) + (6 6) + (nil))) + +(deftest find-if-not-list.13 + (loop for i from 0 to 6 + collect + (find-if-not #'oddp '(1 6 11 32 45 71 100) :key #'1+ :start i)) + (1 11 11 45 45 71 nil)) + +(deftest find-if-not-list.14 + (loop for i from 0 to 6 + collect + (find-if-not #'oddp '(1 6 11 32 45 71 100) :key '1+ :start i :from-end t)) + (71 71 71 71 71 71 nil)) + +(deftest find-if-not-list.15 + (loop for i from 0 to 7 + collect + (find-if-not #'oddp '(1 6 11 32 45 71 100) :key #'1+ :end i)) + (nil 1 1 1 1 1 1 1)) + +(deftest find-if-not-list.16 + (loop for i from 0 to 7 + collect + (find-if-not #'oddp '(1 6 11 32 45 71 100) :key '1+ :end i :from-end t)) + (nil 1 1 11 11 45 71 71)) + +(deftest find-if-not-list.17 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if-not #'evenp '(1 2 4 8 3 1 6 7) :start j :end i :key #'1-))) + ((nil 2 2 2 2 2 2 2) + (2 2 2 2 2 2 2) + (4 4 4 4 4 4) + (8 8 8 8 8) + (nil nil 6 6) + (nil 6 6) + (6 6) + (nil))) + +(deftest find-if-not-list.18 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if-not #'evenp '(1 2 4 8 3 1 6 7) :start j :end i + :from-end t :key #'1+))) + ((nil 2 4 8 8 8 6 6) + (2 4 8 8 8 6 6) + (4 8 8 8 6 6) + (8 8 8 6 6) + (nil nil 6 6) + (nil 6 6) + (6 6) + (nil))) + +;;; tests for vectors + +(deftest find-if-not-vector.1 + (find-if-not #'identity #()) + nil) + +(deftest find-if-not-vector.2 + (find-if-not #'not #(a)) + a) + +(deftest find-if-not-vector.2a + (find-if-not 'null #(a)) + a) + +(deftest find-if-not-vector.3 + (find-if-not #'oddp #(1 2 4 8 3 1 6 7)) + 2) + +(deftest find-if-not-vector.4 + (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :from-end t) + 6) + +(deftest find-if-not-vector.5 + (loop for i from 0 to 7 collect + (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start i)) + (2 2 4 8 6 6 6 nil)) + +(deftest find-if-not-vector.6 + (loop for i from 0 to 7 collect + (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start i :end nil)) + (2 2 4 8 6 6 6 nil)) + +(deftest find-if-not-vector.7 + (loop for i from 0 to 7 collect + (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start i :from-end t)) + (6 6 6 6 6 6 6 nil)) + +(deftest find-if-not-vector.8 + (loop for i from 0 to 7 collect + (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start i :end nil :from-end t)) + (6 6 6 6 6 6 6 nil)) + +(deftest find-if-not-vector.9 + (loop for i from 0 to 8 collect + (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :end i)) + (nil nil 2 2 2 2 2 2 2)) + +(deftest find-if-not-vector.10 + (loop for i from 0 to 8 collect + (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :end i :from-end t)) + (nil nil 2 4 8 8 8 6 6)) + +(deftest find-if-not-vector.11 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start j :end i))) + ((nil 2 2 2 2 2 2 2) + (2 2 2 2 2 2 2) + (4 4 4 4 4 4) + (8 8 8 8 8) + (nil nil 6 6) + (nil 6 6) + (6 6) + (nil))) + +(deftest find-if-not-vector.12 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start j :end i + :from-end t))) + ((nil 2 4 8 8 8 6 6) + (2 4 8 8 8 6 6) + (4 8 8 8 6 6) + (8 8 8 6 6) + (nil nil 6 6) + (nil 6 6) + (6 6) + (nil))) + +(deftest find-if-not-vector.13 + (loop for i from 0 to 6 + collect + (find-if-not #'oddp #(1 6 11 32 45 71 100) :key #'1+ :start i)) + (1 11 11 45 45 71 nil)) + +(deftest find-if-not-vector.14 + (loop for i from 0 to 6 + collect + (find-if-not #'oddp #(1 6 11 32 45 71 100) :key '1+ :start i :from-end t)) + (71 71 71 71 71 71 nil)) + +(deftest find-if-not-vector.15 + (loop for i from 0 to 7 + collect + (find-if-not #'oddp #(1 6 11 32 45 71 100) :key #'1+ :end i)) + (nil 1 1 1 1 1 1 1)) + +(deftest find-if-not-vector.16 + (loop for i from 0 to 7 + collect + (find-if-not #'oddp #(1 6 11 32 45 71 100) :key '1+ :end i :from-end t)) + (nil 1 1 11 11 45 71 71)) + +(deftest find-if-not-vector.17 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if-not #'evenp #(1 2 4 8 3 1 6 7) :start j :end i :key #'1-))) + ((nil 2 2 2 2 2 2 2) + (2 2 2 2 2 2 2) + (4 4 4 4 4 4) + (8 8 8 8 8) + (nil nil 6 6) + (nil 6 6) + (6 6) + (nil))) + +(deftest find-if-not-vector.18 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if-not #'evenp #(1 2 4 8 3 1 6 7) :start j :end i + :from-end t :key #'1+))) + ((nil 2 4 8 8 8 6 6) + (2 4 8 8 8 6 6) + (4 8 8 8 6 6) + (8 8 8 6 6) + (nil nil 6 6) + (nil 6 6) + (6 6) + (nil))) + +;;; Tests for bit vectors + +(deftest find-if-not-bit-vector.1 + (find-if-not #'identity #*) + nil) + +(deftest find-if-not-bit-vector.2 + (find-if-not #'null #*1) + 1) + +(deftest find-if-not-bit-vector.3 + (find-if-not #'not #*0) + 0) + +(deftest find-if-not-bit-vector.4 + (loop for i from 0 to 6 + collect (loop for j from i to 7 + collect (find-if-not #'oddp #*0110110 :start i :end j))) + ((nil 0 0 0 0 0 0 0) + (nil nil nil 0 0 0 0) + (nil nil 0 0 0 0) + (nil 0 0 0 0) + (nil nil nil 0) + (nil nil 0) + (nil 0))) + +(deftest find-if-not-bit-vector.5 + (loop for i from 0 to 6 + collect (loop for j from i to 7 + collect (find-if-not #'oddp #*0110110 :start i :end j + :from-end t))) + ((nil 0 0 0 0 0 0 0) + (nil nil nil 0 0 0 0) + (nil nil 0 0 0 0) + (nil 0 0 0 0) + (nil nil nil 0) + (nil nil 0) + (nil 0))) + +(deftest find-if-not-bit-vector.6 + (loop for i from 0 to 6 + collect (loop for j from i to 7 + collect (find-if-not #'evenp #*0110110 :start i :end j + :from-end t :key #'1+))) + ((nil 0 0 0 0 0 0 0) + (nil nil nil 0 0 0 0) + (nil nil 0 0 0 0) + (nil 0 0 0 0) + (nil nil nil 0) + (nil nil 0) + (nil 0))) + +(deftest find-if-not-bit-vector.7 + (loop for i from 0 to 6 + collect (loop for j from i to 7 + collect (find-if-not #'evenp #*0110110 :start i :end j + :key '1-))) + ((nil 0 0 0 0 0 0 0) + (nil nil nil 0 0 0 0) + (nil nil 0 0 0 0) + (nil 0 0 0 0) + (nil nil nil 0) + (nil nil 0) + (nil 0))) + +;;; Tests for strings + +(deftest find-if-not-string.1 + (find-if-not #'identity "") + nil) + +(deftest find-if-not-string.2 + (find-if-not #'null "a") + #\a) + +(deftest find-if-not-string.2a + (find-if-not 'null "a") + #\a) + +(deftest find-if-not-string.3 + (find-if-not #'odddigitp "12483167") + #\2) + +(deftest find-if-not-string.3a + (find-if-not #'oddp "12483167" :key #'(lambda (c) (read-from-string (string c)))) + #\2) + +(deftest find-if-not-string.4 + (find-if-not #'odddigitp "12483167" :from-end t) + #\6) + +(deftest find-if-not-string.5 + (loop for i from 0 to 7 collect + (find-if-not #'odddigitp "12483167" :start i)) + (#\2 #\2 #\4 #\8 #\6 #\6 #\6 nil)) + +(deftest find-if-not-string.6 + (loop for i from 0 to 7 collect + (find-if-not #'odddigitp "12483167" :start i :end nil)) + (#\2 #\2 #\4 #\8 #\6 #\6 #\6 nil)) + +(deftest find-if-not-string.7 + (loop for i from 0 to 7 collect + (find-if-not #'odddigitp "12483167" :start i :from-end t)) + (#\6 #\6 #\6 #\6 #\6 #\6 #\6 nil)) + +(deftest find-if-not-string.8 + (loop for i from 0 to 7 collect + (find-if-not #'odddigitp "12483167" :start i :end nil :from-end t)) + (#\6 #\6 #\6 #\6 #\6 #\6 #\6 nil)) + +(deftest find-if-not-string.9 + (loop for i from 0 to 8 collect + (find-if-not #'odddigitp "12483167" :end i)) + (nil nil #\2 #\2 #\2 #\2 #\2 #\2 #\2)) + +(deftest find-if-not-string.10 + (loop for i from 0 to 8 collect + (find-if-not #'odddigitp "12483167" :end i :from-end t)) + (nil nil #\2 #\4 #\8 #\8 #\8 #\6 #\6)) + +(deftest find-if-not-string.11 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if-not #'odddigitp "12483167" :start j :end i))) + ((nil #\2 #\2 #\2 #\2 #\2 #\2 #\2) + (#\2 #\2 #\2 #\2 #\2 #\2 #\2) + (#\4 #\4 #\4 #\4 #\4 #\4) + (#\8 #\8 #\8 #\8 #\8) + (nil nil #\6 #\6) + (nil #\6 #\6) + (#\6 #\6) + (nil))) + +(deftest find-if-not-string.12 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if-not #'odddigitp "12483167" :start j :end i + :from-end t))) + ((nil #\2 #\4 #\8 #\8 #\8 #\6 #\6) + (#\2 #\4 #\8 #\8 #\8 #\6 #\6) + (#\4 #\8 #\8 #\8 #\6 #\6) + (#\8 #\8 #\8 #\6 #\6) + (nil nil #\6 #\6) + (nil #\6 #\6) + (#\6 #\6) + (nil))) + +(deftest find-if-not-string.13 + (loop for i from 0 to 6 + collect + (find-if-not #'oddp "1473816" + :key (compose #'read-from-string #'string) + :start i)) + (#\4 #\4 #\8 #\8 #\8 #\6 #\6)) + +(deftest find-if-not-string.14 + (loop for i from 0 to 6 + collect + (find-if-not #'oddp "1473816" + :key (compose #'read-from-string #'string) + :start i :from-end t)) + (#\6 #\6 #\6 #\6 #\6 #\6 #\6)) + +(deftest find-if-not-string.15 + (loop for i from 0 to 7 + collect + (find-if-not #'oddp "1473816" + :key (compose #'read-from-string #'string) + :end i)) + (nil nil #\4 #\4 #\4 #\4 #\4 #\4)) + +(deftest find-if-not-string.16 + (loop for i from 0 to 7 + collect + (find-if-not #'oddp "1473816" + :key (compose #'read-from-string #'string) + :end i :from-end t)) + (nil nil #\4 #\4 #\4 #\8 #\8 #\6)) + +(deftest find-if-not-string.17 + (loop for j from 0 to 6 + collect + (loop for i from (1+ j) to 7 collect + (find-if-not #'oddp "1473816" + :key (compose #'read-from-string #'string) + :start j :end i))) + ((nil #\4 #\4 #\4 #\4 #\4 #\4) + (#\4 #\4 #\4 #\4 #\4 #\4) + (nil nil #\8 #\8 #\8) + (nil #\8 #\8 #\8) + (#\8 #\8 #\8) + (nil #\6) + (#\6))) + +(deftest find-if-not-string.18 + (loop for j from 0 to 6 + collect + (loop for i from (1+ j) to 7 collect + (find-if-not #'oddp "1473816" + :key (compose #'read-from-string #'string) + :start j :end i + :from-end t))) + ((nil #\4 #\4 #\4 #\8 #\8 #\6) + (#\4 #\4 #\4 #\8 #\8 #\6) + (nil nil #\8 #\8 #\6) + (nil #\8 #\8 #\6) + (#\8 #\8 #\6) + (nil #\6) + (#\6))) + + +;;; Keyword tests + +(deftest find-if-not.allow-other-keys.1 + (find-if-not #'oddp '(1 2 3 4 5) :bad t :allow-other-keys t) + 2) + +(deftest find-if-not.allow-other-keys.2 + (find-if-not #'oddp '(1 2 3 4 5) :allow-other-keys t :also-bad t) + 2) + +;;; The leftmost of two :allow-other-keys arguments is the one that matters. +(deftest find-if-not.allow-other-keys.3 + (find-if-not #'oddp '(1 2 3 4 5) + :allow-other-keys t + :allow-other-keys nil + :bad t) + 2) + +(deftest find-if-not.keywords.4 + (find-if-not #'oddp '(1 2 3 4 5) :key #'identity :key #'1+) + 2) + +(deftest find-if-not.allow-other-keys.5 + (find-if-not #'null '(nil a b c nil) :allow-other-keys nil) + a) + +;;; Error tests + +(deftest find-if-not.error.1 + (classify-error (find-if-not #'null 'b)) + type-error) + +(deftest find-if-not.error.2 + (classify-error (find-if-not #'identity 10)) + type-error) + +(deftest find-if-not.error.3 + (classify-error (find-if-not '1+ 1.4)) + type-error) + +(deftest find-if-not.error.4 + (classify-error (find-if-not 'identity '(a b c . d))) + type-error) + +(deftest find-if-not.error.5 + (classify-error (find-if-not)) + program-error) + +(deftest find-if-not.error.6 + (classify-error (find-if-not #'null)) + program-error) + +(deftest find-if-not.error.7 + (classify-error (find-if-not #'null nil :bad t)) + program-error) + +(deftest find-if-not.error.8 + (classify-error (find-if-not #'null nil :bad t :allow-other-keys nil)) + program-error) + +(deftest find-if-not.error.9 + (classify-error (find-if-not #'null nil 1 1)) + program-error) + +(deftest find-if-not.error.10 + (classify-error (find-if-not #'null nil :key)) + program-error) + +(deftest find-if-not.error.11 + (classify-error (locally (find-if-not #'null 'b) t)) + type-error) + +(deftest find-if-not.error.12 + (classify-error (find-if-not #'cons '(a b c))) + program-error) + +(deftest find-if-not.error.13 + (classify-error (find-if-not #'car '(a b c))) + type-error) + +(deftest find-if-not.error.14 + (classify-error (find-if-not #'identity '(a b c) :key #'cons)) + program-error) + +(deftest find-if-not.error.15 + (classify-error (find-if-not #'identity '(a b c) :key #'car)) + type-error) + +;;; Order of evaluation tests + +(deftest find-if-not.order.1 + (let ((i 0) x y) + (values + (find-if-not (progn (setf x (incf i)) #'null) + (progn (setf y (incf i)) '(nil nil nil a nil nil))) + i x y)) + a 2 1 2) + +(deftest find-if-not.order.2 + (let ((i 0) a b c d e f g) + (values + (find-if-not (progn (setf a (incf i)) #'identity) + (progn (setf b (incf i)) '(nil nil nil a nil nil)) + :start (progn (setf c (incf i)) 1) + :end (progn (setf d (incf i)) 4) + :from-end (setf e (incf i)) + :key (progn (setf f (incf i)) #'null) + ) + i a b c d e f)) + a 6 1 2 3 4 5 6) + + +(deftest find-if-not.order.3 + (let ((i 0) a b c d e f g) + (values + (find-if-not (progn (setf a (incf i)) #'identity) + (progn (setf b (incf i)) '(nil nil nil a nil nil)) + :key (progn (setf c (incf i)) #'null) + :from-end (setf d (incf i)) + :end (progn (setf e (incf i)) 4) + :start (progn (setf f (incf i)) 1) + ) + i a b c d e f)) + a 6 1 2 3 4 5 6) diff --git a/ansi-tests/find-if.lsp b/ansi-tests/find-if.lsp new file mode 100644 index 0000000..71e2a0d --- /dev/null +++ b/ansi-tests/find-if.lsp @@ -0,0 +1,634 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Aug 28 18:37:52 2002 +;;;; Contains: Tests for FIND-IF + +(in-package :cl-test) + +(deftest find-if-list.1 + (find-if #'identity ()) + nil) + +(deftest find-if-list.2 + (find-if #'identity '(a)) + a) + +(deftest find-if-list.2a + (find-if 'identity '(a)) + a) + +(deftest find-if-list.3 + (find-if #'evenp '(1 2 4 8 3 1 6 7)) + 2) + +(deftest find-if-list.4 + (find-if #'evenp '(1 2 4 8 3 1 6 7) :from-end t) + 6) + +(deftest find-if-list.5 + (loop for i from 0 to 7 collect + (find-if #'evenp '(1 2 4 8 3 1 6 7) :start i)) + (2 2 4 8 6 6 6 nil)) + +(deftest find-if-list.6 + (loop for i from 0 to 7 collect + (find-if #'evenp '(1 2 4 8 3 1 6 7) :start i :end nil)) + (2 2 4 8 6 6 6 nil)) + +(deftest find-if-list.7 + (loop for i from 0 to 7 collect + (find-if #'evenp '(1 2 4 8 3 1 6 7) :start i :from-end t)) + (6 6 6 6 6 6 6 nil)) + +(deftest find-if-list.8 + (loop for i from 0 to 7 collect + (find-if #'evenp '(1 2 4 8 3 1 6 7) :start i :end nil :from-end t)) + (6 6 6 6 6 6 6 nil)) + +(deftest find-if-list.9 + (loop for i from 0 to 8 collect + (find-if #'evenp '(1 2 4 8 3 1 6 7) :end i)) + (nil nil 2 2 2 2 2 2 2)) + +(deftest find-if-list.10 + (loop for i from 0 to 8 collect + (find-if #'evenp '(1 2 4 8 3 1 6 7) :end i :from-end t)) + (nil nil 2 4 8 8 8 6 6)) + +(deftest find-if-list.11 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if #'evenp '(1 2 4 8 3 1 6 7) :start j :end i))) + ((nil 2 2 2 2 2 2 2) + (2 2 2 2 2 2 2) + (4 4 4 4 4 4) + (8 8 8 8 8) + (nil nil 6 6) + (nil 6 6) + (6 6) + (nil))) + +(deftest find-if-list.12 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if #'evenp '(1 2 4 8 3 1 6 7) :start j :end i + :from-end t))) + ((nil 2 4 8 8 8 6 6) + (2 4 8 8 8 6 6) + (4 8 8 8 6 6) + (8 8 8 6 6) + (nil nil 6 6) + (nil 6 6) + (6 6) + (nil))) + +(deftest find-if-list.13 + (loop for i from 0 to 6 + collect + (find-if #'evenp '(1 6 11 32 45 71 100) :key #'1+ :start i)) + (1 11 11 45 45 71 nil)) + +(deftest find-if-list.14 + (loop for i from 0 to 6 + collect + (find-if #'evenp '(1 6 11 32 45 71 100) :key '1+ :start i :from-end t)) + (71 71 71 71 71 71 nil)) + +(deftest find-if-list.15 + (loop for i from 0 to 7 + collect + (find-if #'evenp '(1 6 11 32 45 71 100) :key #'1+ :end i)) + (nil 1 1 1 1 1 1 1)) + +(deftest find-if-list.16 + (loop for i from 0 to 7 + collect + (find-if #'evenp '(1 6 11 32 45 71 100) :key '1+ :end i :from-end t)) + (nil 1 1 11 11 45 71 71)) + +(deftest find-if-list.17 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if #'oddp '(1 2 4 8 3 1 6 7) :start j :end i :key #'1-))) + ((nil 2 2 2 2 2 2 2) + (2 2 2 2 2 2 2) + (4 4 4 4 4 4) + (8 8 8 8 8) + (nil nil 6 6) + (nil 6 6) + (6 6) + (nil))) + +(deftest find-if-list.18 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if #'oddp '(1 2 4 8 3 1 6 7) :start j :end i + :from-end t :key #'1+))) + ((nil 2 4 8 8 8 6 6) + (2 4 8 8 8 6 6) + (4 8 8 8 6 6) + (8 8 8 6 6) + (nil nil 6 6) + (nil 6 6) + (6 6) + (nil))) + +;;; tests for vectors + +(deftest find-if-vector.1 + (find-if #'identity #()) + nil) + +(deftest find-if-vector.2 + (find-if #'identity #(a)) + a) + +(deftest find-if-vector.2a + (find-if 'identity #(a)) + a) + +(deftest find-if-vector.3 + (find-if #'evenp #(1 2 4 8 3 1 6 7)) + 2) + +(deftest find-if-vector.4 + (find-if #'evenp #(1 2 4 8 3 1 6 7) :from-end t) + 6) + +(deftest find-if-vector.5 + (loop for i from 0 to 7 collect + (find-if #'evenp #(1 2 4 8 3 1 6 7) :start i)) + (2 2 4 8 6 6 6 nil)) + +(deftest find-if-vector.6 + (loop for i from 0 to 7 collect + (find-if #'evenp #(1 2 4 8 3 1 6 7) :start i :end nil)) + (2 2 4 8 6 6 6 nil)) + +(deftest find-if-vector.7 + (loop for i from 0 to 7 collect + (find-if #'evenp #(1 2 4 8 3 1 6 7) :start i :from-end t)) + (6 6 6 6 6 6 6 nil)) + +(deftest find-if-vector.8 + (loop for i from 0 to 7 collect + (find-if #'evenp #(1 2 4 8 3 1 6 7) :start i :end nil :from-end t)) + (6 6 6 6 6 6 6 nil)) + +(deftest find-if-vector.9 + (loop for i from 0 to 8 collect + (find-if #'evenp #(1 2 4 8 3 1 6 7) :end i)) + (nil nil 2 2 2 2 2 2 2)) + +(deftest find-if-vector.10 + (loop for i from 0 to 8 collect + (find-if #'evenp #(1 2 4 8 3 1 6 7) :end i :from-end t)) + (nil nil 2 4 8 8 8 6 6)) + +(deftest find-if-vector.11 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if #'evenp #(1 2 4 8 3 1 6 7) :start j :end i))) + ((nil 2 2 2 2 2 2 2) + (2 2 2 2 2 2 2) + (4 4 4 4 4 4) + (8 8 8 8 8) + (nil nil 6 6) + (nil 6 6) + (6 6) + (nil))) + +(deftest find-if-vector.12 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if #'evenp #(1 2 4 8 3 1 6 7) :start j :end i + :from-end t))) + ((nil 2 4 8 8 8 6 6) + (2 4 8 8 8 6 6) + (4 8 8 8 6 6) + (8 8 8 6 6) + (nil nil 6 6) + (nil 6 6) + (6 6) + (nil))) + +(deftest find-if-vector.13 + (loop for i from 0 to 6 + collect + (find-if #'evenp #(1 6 11 32 45 71 100) :key #'1+ :start i)) + (1 11 11 45 45 71 nil)) + +(deftest find-if-vector.14 + (loop for i from 0 to 6 + collect + (find-if #'evenp #(1 6 11 32 45 71 100) :key '1+ :start i :from-end t)) + (71 71 71 71 71 71 nil)) + +(deftest find-if-vector.15 + (loop for i from 0 to 7 + collect + (find-if #'evenp #(1 6 11 32 45 71 100) :key #'1+ :end i)) + (nil 1 1 1 1 1 1 1)) + +(deftest find-if-vector.16 + (loop for i from 0 to 7 + collect + (find-if #'evenp #(1 6 11 32 45 71 100) :key '1+ :end i :from-end t)) + (nil 1 1 11 11 45 71 71)) + +(deftest find-if-vector.17 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if #'oddp #(1 2 4 8 3 1 6 7) :start j :end i :key #'1-))) + ((nil 2 2 2 2 2 2 2) + (2 2 2 2 2 2 2) + (4 4 4 4 4 4) + (8 8 8 8 8) + (nil nil 6 6) + (nil 6 6) + (6 6) + (nil))) + +(deftest find-if-vector.18 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if #'oddp #(1 2 4 8 3 1 6 7) :start j :end i + :from-end t :key #'1+))) + ((nil 2 4 8 8 8 6 6) + (2 4 8 8 8 6 6) + (4 8 8 8 6 6) + (8 8 8 6 6) + (nil nil 6 6) + (nil 6 6) + (6 6) + (nil))) + +(deftest find-if-vector.19 + (let ((a (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) + :fill-pointer 5))) + (values + (find-if #'evenp a) + (find-if #'evenp a :from-end t) + (find-if #'oddp a) + (find-if #'oddp a :from-end t) + )) + 2 4 1 5) + +;;; Tests for bit vectors + +(deftest find-if-bit-vector.1 + (find-if #'identity #*) + nil) + +(deftest find-if-bit-vector.2 + (find-if #'identity #*1) + 1) + +(deftest find-if-bit-vector.3 + (find-if #'identity #*0) + 0) + +(deftest find-if-bit-vector.4 + (loop for i from 0 to 6 + collect (loop for j from i to 7 + collect (find-if #'evenp #*0110110 :start i :end j))) + ((nil 0 0 0 0 0 0 0) + (nil nil nil 0 0 0 0) + (nil nil 0 0 0 0) + (nil 0 0 0 0) + (nil nil nil 0) + (nil nil 0) + (nil 0))) + +(deftest find-if-bit-vector.5 + (loop for i from 0 to 6 + collect (loop for j from i to 7 + collect (find-if #'evenp #*0110110 :start i :end j + :from-end t))) + ((nil 0 0 0 0 0 0 0) + (nil nil nil 0 0 0 0) + (nil nil 0 0 0 0) + (nil 0 0 0 0) + (nil nil nil 0) + (nil nil 0) + (nil 0))) + +(deftest find-if-bit-vector.6 + (loop for i from 0 to 6 + collect (loop for j from i to 7 + collect (find-if #'oddp #*0110110 :start i :end j + :from-end t :key #'1+))) + ((nil 0 0 0 0 0 0 0) + (nil nil nil 0 0 0 0) + (nil nil 0 0 0 0) + (nil 0 0 0 0) + (nil nil nil 0) + (nil nil 0) + (nil 0))) + +(deftest find-if-bit-vector.7 + (loop for i from 0 to 6 + collect (loop for j from i to 7 + collect (find-if #'oddp #*0110110 :start i :end j + :key '1-))) + ((nil 0 0 0 0 0 0 0) + (nil nil nil 0 0 0 0) + (nil nil 0 0 0 0) + (nil 0 0 0 0) + (nil nil nil 0) + (nil nil 0) + (nil 0))) + +;;; Tests for strings + +(deftest find-if-string.1 + (find-if #'identity "") + nil) + +(deftest find-if-string.2 + (find-if #'identity "a") + #\a) + +(deftest find-if-string.2a + (find-if 'identity "a") + #\a) + +(deftest find-if-string.3 + (find-if #'evendigitp "12483167") + #\2) + +(deftest find-if-string.3a + (find-if #'evenp "12483167" :key #'(lambda (c) (read-from-string (string c)))) + #\2) + +(deftest find-if-string.4 + (find-if #'evendigitp "12483167" :from-end t) + #\6) + +(deftest find-if-string.5 + (loop for i from 0 to 7 collect + (find-if #'evendigitp "12483167" :start i)) + (#\2 #\2 #\4 #\8 #\6 #\6 #\6 nil)) + +(deftest find-if-string.6 + (loop for i from 0 to 7 collect + (find-if #'evendigitp "12483167" :start i :end nil)) + (#\2 #\2 #\4 #\8 #\6 #\6 #\6 nil)) + +(deftest find-if-string.7 + (loop for i from 0 to 7 collect + (find-if #'evendigitp "12483167" :start i :from-end t)) + (#\6 #\6 #\6 #\6 #\6 #\6 #\6 nil)) + +(deftest find-if-string.8 + (loop for i from 0 to 7 collect + (find-if #'evendigitp "12483167" :start i :end nil :from-end t)) + (#\6 #\6 #\6 #\6 #\6 #\6 #\6 nil)) + +(deftest find-if-string.9 + (loop for i from 0 to 8 collect + (find-if #'evendigitp "12483167" :end i)) + (nil nil #\2 #\2 #\2 #\2 #\2 #\2 #\2)) + +(deftest find-if-string.10 + (loop for i from 0 to 8 collect + (find-if #'evendigitp "12483167" :end i :from-end t)) + (nil nil #\2 #\4 #\8 #\8 #\8 #\6 #\6)) + +(deftest find-if-string.11 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if #'evendigitp "12483167" :start j :end i))) + ((nil #\2 #\2 #\2 #\2 #\2 #\2 #\2) + (#\2 #\2 #\2 #\2 #\2 #\2 #\2) + (#\4 #\4 #\4 #\4 #\4 #\4) + (#\8 #\8 #\8 #\8 #\8) + (nil nil #\6 #\6) + (nil #\6 #\6) + (#\6 #\6) + (nil))) + +(deftest find-if-string.12 + (loop for j from 0 to 7 + collect + (loop for i from (1+ j) to 8 collect + (find-if #'evendigitp "12483167" :start j :end i + :from-end t))) + ((nil #\2 #\4 #\8 #\8 #\8 #\6 #\6) + (#\2 #\4 #\8 #\8 #\8 #\6 #\6) + (#\4 #\8 #\8 #\8 #\6 #\6) + (#\8 #\8 #\8 #\6 #\6) + (nil nil #\6 #\6) + (nil #\6 #\6) + (#\6 #\6) + (nil))) + +(deftest find-if-string.13 + (loop for i from 0 to 6 + collect + (find-if #'evenp "1473816" + :key (compose #'read-from-string #'string) + :start i)) + (#\4 #\4 #\8 #\8 #\8 #\6 #\6)) + +(deftest find-if-string.14 + (loop for i from 0 to 6 + collect + (find-if #'evenp "1473816" + :key (compose #'read-from-string #'string) + :start i :from-end t)) + (#\6 #\6 #\6 #\6 #\6 #\6 #\6)) + +(deftest find-if-string.15 + (loop for i from 0 to 7 + collect + (find-if #'evenp "1473816" + :key (compose #'read-from-string #'string) + :end i)) + (nil nil #\4 #\4 #\4 #\4 #\4 #\4)) + +(deftest find-if-string.16 + (loop for i from 0 to 7 + collect + (find-if #'evenp "1473816" + :key (compose #'read-from-string #'string) + :end i :from-end t)) + (nil nil #\4 #\4 #\4 #\8 #\8 #\6)) + +(deftest find-if-string.17 + (loop for j from 0 to 6 + collect + (loop for i from (1+ j) to 7 collect + (find-if #'evenp "1473816" + :key (compose #'read-from-string #'string) + :start j :end i))) + ((nil #\4 #\4 #\4 #\4 #\4 #\4) + (#\4 #\4 #\4 #\4 #\4 #\4) + (nil nil #\8 #\8 #\8) + (nil #\8 #\8 #\8) + (#\8 #\8 #\8) + (nil #\6) + (#\6))) + +(deftest find-if-string.18 + (loop for j from 0 to 6 + collect + (loop for i from (1+ j) to 7 collect + (find-if #'evenp "1473816" + :key (compose #'read-from-string #'string) + :start j :end i + :from-end t))) + ((nil #\4 #\4 #\4 #\8 #\8 #\6) + (#\4 #\4 #\4 #\8 #\8 #\6) + (nil nil #\8 #\8 #\6) + (nil #\8 #\8 #\6) + (#\8 #\8 #\6) + (nil #\6) + (#\6))) + +(deftest find-if-string.19 + (let ((a (make-array '(10) :initial-contents "123456789a" + :fill-pointer 5 + :element-type 'character))) + (values + (find-if #'evendigitp a) + (find-if #'evendigitp a :from-end t) + (find-if #'odddigitp a) + (find-if #'odddigitp a :from-end t) + )) + #\2 #\4 #\1 #\5) + +;;; Keyword tests + +(deftest find-if.allow-other-keys.1 + (find-if #'evenp '(1 2 3 4 5) :bad t :allow-other-keys t) + 2) + +(deftest find-if.allow-other-keys.2 + (find-if #'evenp '(1 2 3 4 5) :allow-other-keys t :also-bad t) + 2) + +;;; The leftmost of two :allow-other-keys arguments is the one that matters. +(deftest find-if.allow-other-keys.3 + (find-if #'evenp '(1 2 3 4 5) + :allow-other-keys t + :allow-other-keys nil + :bad t) + 2) + +(deftest find-if.keywords.4 + (find-if #'evenp '(1 2 3 4 5) :key #'identity :key #'1+) + 2) + +(deftest find-if.allow-other-keys.5 + (find-if #'identity '(nil a b c nil) :allow-other-keys nil) + a) + + +;;; Error tests + +(deftest find-if.error.1 + (classify-error (find-if #'null 'b)) + type-error) + +(deftest find-if.error.2 + (classify-error (find-if #'identity 10)) + type-error) + +(deftest find-if.error.3 + (classify-error (find-if '1+ 1.4)) + type-error) + +(deftest find-if.error.4 + (classify-error (find-if 'null '(a b c . d))) + type-error) + +(deftest find-if.error.5 + (classify-error (find-if)) + program-error) + +(deftest find-if.error.6 + (classify-error (find-if #'null)) + program-error) + +(deftest find-if.error.7 + (classify-error (find-if #'null nil :bad t)) + program-error) + +(deftest find-if.error.8 + (classify-error (find-if #'null nil :bad t :allow-other-keys nil)) + program-error) + +(deftest find-if.error.9 + (classify-error (find-if #'null nil 1 1)) + program-error) + +(deftest find-if.error.10 + (classify-error (find-if #'null nil :key)) + program-error) + +(deftest find-if.error.11 + (classify-error (locally (find-if #'null 'b) t)) + type-error) + +(deftest find-if.error.12 + (classify-error (find-if #'cons '(a b c))) + program-error) + +(deftest find-if.error.13 + (classify-error (find-if #'car '(a b c))) + type-error) + +(deftest find-if.error.14 + (classify-error (find-if #'identity '(a b c) :key #'cons)) + program-error) + +(deftest find-if.error.15 + (classify-error (find-if #'identity '(a b c) :key #'car)) + type-error) + +;;; Order of evaluation tests + +(deftest find-if.order.1 + (let ((i 0) x y) + (values + (find-if (progn (setf x (incf i)) #'identity) + (progn (setf y (incf i)) '(nil nil nil a nil nil))) + i x y)) + a 2 1 2) + +(deftest find-if.order.2 + (let ((i 0) a b c d e f g) + (values + (find-if (progn (setf a (incf i)) #'null) + (progn (setf b (incf i)) '(nil nil nil a nil nil)) + :start (progn (setf c (incf i)) 1) + :end (progn (setf d (incf i)) 4) + :from-end (setf e (incf i)) + :key (progn (setf f (incf i)) #'null) + ) + i a b c d e f)) + a 6 1 2 3 4 5 6) + + +(deftest find-if.order.3 + (let ((i 0) a b c d e f g) + (values + (find-if (progn (setf a (incf i)) #'null) + (progn (setf b (incf i)) '(nil nil nil a nil nil)) + :key (progn (setf c (incf i)) #'null) + :from-end (setf d (incf i)) + :end (progn (setf e (incf i)) 4) + :start (progn (setf f (incf i)) 1) + ) + i a b c d e f)) + a 6 1 2 3 4 5 6) diff --git a/ansi-tests/find.lsp b/ansi-tests/find.lsp new file mode 100644 index 0000000..c9de8b0 --- /dev/null +++ b/ansi-tests/find.lsp @@ -0,0 +1,870 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Aug 23 07:49:49 2002 +;;;; Contains: Tests for FIND + +(in-package :cl-test) + +(deftest find-list.1 + (find 'c '(a b c d e c a)) + c) + +(deftest find-list.2 + (find 'c '(a b c d e c a) :from-end t) + c) + +(deftest find-list.3 + (loop for i from 0 to 7 collect + (find 'c '(a b c d e c a) :start i)) + (c c c c c c nil nil)) + +(deftest find-list.4 + (loop for i from 0 to 7 collect + (find 'c '(a b c d e c a) :start i :end nil)) + (c c c c c c nil nil)) + +(deftest find-list.5 + (loop for i from 7 downto 0 collect + (find 'c '(a b c d e c a) :end i)) + (c c c c c nil nil nil)) + +(deftest find-list.6 + (loop for i from 0 to 7 collect + (find 'c '(a b c d e c a) :start i :from-end t)) + (c c c c c c nil nil)) + +(deftest find-list.7 + (loop for i from 0 to 7 collect + (find 'c '(a b c d e c a) :start i :end nil :from-end t)) + (c c c c c c nil nil)) + +(deftest find-list.8 + (loop for i from 7 downto 0 collect + (find 'c '(a b c d e c a) :end i :from-end t)) + (c c c c c nil nil nil)) + +(deftest find-list.9 + (loop for i from 0 to 6 collect + (loop for j from (1+ i) to 7 + collect + (find 'c '(a b c d e c a) :start i :end j))) + ((nil nil c c c c c) + (nil c c c c c) + (c c c c c) + (nil nil c c) + (nil c c) + (c c) + (nil))) + +(deftest find-list.10 + (loop for i from 0 to 6 collect + (loop for j from (1+ i) to 7 + collect + (find 'c '(a b c d e c a) :start i :end j :from-end t))) + ((nil nil c c c c c) + (nil c c c c c) + (c c c c c) + (nil nil c c) + (nil c c) + (c c) + (nil))) + +(deftest find-list.11 + (find 5 '(1 2 3 4 5 6 4 8) :key #'1+) + 4) + +(deftest find-list.12 + (find 5 '(1 2 3 4 5 6 4 8) :key '1+) + 4) + +(deftest find-list.13 + (find 5 '(1 2 3 4 5 6 4 8) :key #'1+ :from-end t) + 4) + +(deftest find-list.14 + (find 'a '(a a b a c e d a f a) :test (complement #'eql)) + b) + +(deftest find-list.15 + (find 'a '(a a b a c e d a f a) :test (complement #'eql) + :from-end t) + f) + +(deftest find-list.16 + (find 'a '(a a b a c e d a f a) :test-not #'eql) + b) + +(deftest find-list.17 + (find 'a '(a a b a c e d a f a) :test-not 'eql + :from-end t) + f) + +(deftest find-list.18 + (find 'a '(a a b a c e d a f a) :test-not 'eql) + b) + +(deftest find-list.19 + (find 'a '(a a b a c e d a f a) :test-not #'eql + :from-end t) + f) + +(deftest find-list.20 + (find 'a '(a a b a c e d a f a) :test-not #'eql) + b) + +(deftest find-list.21 + (find 'a '(a a b a c e d a f a) :test #'eql + :start 2) + a) + +(deftest find-list.22 + (find 'a '(a a b a c e d a f a) :test #'eql + :start 2 :end nil) + a) + +(deftest find-list.23 + (find 'a '(a a b a c e d a f a) :test-not #'eql + :start 0 :end 5) + b) + +(deftest find-list.24 + (find 'a '(a a b a c e d a f a) :test-not #'eql + :start 0 :end 5 :from-end t) + c) + +(deftest find-list.25 + (find "ab" '("a" #(#\b #\a) #(#\a #\b #\c) #(#\a #\b) #(#\d #\e) f) :test #'equalp) + #(#\a #\b)) + +(deftest find-list.26 + (find 'a '((c) (b a) (a b c) (a b) (d e) f) :key #'car) + (a b c)) + +(deftest find-list.27 + (find 'a '((c) (b a) (a b c) (z) (a b) (d e) f) :key #'car + :start 3) + (a b)) + +(deftest find-list.28 + (find 'a '((c) (b a) (a b c) (z) (a b) (d e) (f)) :key #'car + :start 2 :from-end t) + (a b)) + +;;; Tests on vectors + +(deftest find-vector.1 + (find 'c #(a b c d e c a)) + c) + +(deftest find-vector.1a + (find 'z #(a b c d e c a)) + nil) + +(deftest find-vector.2 + (find 'c #(a b c d e c a) :from-end t) + c) + +(deftest find-vector.2a + (find 'z #(a b c d e c a) :from-end t) + nil) + +(deftest find-vector.3 + (loop for i from 0 to 7 collect + (find 'c #(a b c d e c a) :start i)) + (c c c c c c nil nil)) + +(deftest find-vector.4 + (loop for i from 0 to 7 collect + (find 'c #(a b c d e c a) :start i :end nil)) + (c c c c c c nil nil)) + +(deftest find-vector.5 + (loop for i from 7 downto 0 collect + (find 'c #(a b c d e c a) :end i)) + (c c c c c nil nil nil)) + +(deftest find-vector.6 + (loop for i from 0 to 7 collect + (find 'c #(a b c d e c a) :start i :from-end t)) + (c c c c c c nil nil)) + +(deftest find-vector.7 + (loop for i from 0 to 7 collect + (find 'c #(a b c d e c a) :start i :end nil :from-end t)) + (c c c c c c nil nil)) + +(deftest find-vector.8 + (loop for i from 7 downto 0 collect + (find 'c #(a b c d e c a) :end i :from-end t)) + (c c c c c nil nil nil)) + +(deftest find-vector.9 + (loop for i from 0 to 6 collect + (loop for j from (1+ i) to 7 + collect + (find 'c #(a b c d e c a) :start i :end j))) + ((nil nil c c c c c) + (nil c c c c c) + (c c c c c) + (nil nil c c) + (nil c c) + (c c) + (nil))) + +(deftest find-vector.10 + (loop for i from 0 to 6 collect + (loop for j from (1+ i) to 7 + collect + (find 'c #(a b c d e c a) :start i :end j :from-end t))) + ((nil nil c c c c c) + (nil c c c c c) + (c c c c c) + (nil nil c c) + (nil c c) + (c c) + (nil))) + +(deftest find-vector.11 + (find 5 #(1 2 3 4 5 6 4 8) :key #'1+) + 4) + +(deftest find-vector.12 + (find 5 #(1 2 3 4 5 6 4 8) :key '1+) + 4) + +(deftest find-vector.13 + (find 5 #(1 2 3 4 5 6 4 8) :key #'1+ :from-end t) + 4) + +(deftest find-vector.14 + (find 'a #(a a b a c e d a f a) :test (complement #'eql)) + b) + +(deftest find-vector.15 + (find 'a #(a a b a c e d a f a) :test (complement #'eql) + :from-end t) + f) + +(deftest find-vector.16 + (find 'a #(a a b a c e d a f a) :test-not #'eql) + b) + +(deftest find-vector.17 + (find 'a #(a a b a c e d a f a) :test-not 'eql + :from-end t) + f) + +(deftest find-vector.18 + (find 'a #(a a b a c e d a f a) :test-not 'eql) + b) + +(deftest find-vector.19 + (find 'a #(a a b a c e d a f a) :test-not #'eql + :from-end t) + f) + +(deftest find-vector.20 + (find 'a #(a a b a c e d a f a) :test-not #'eql) + b) + +(deftest find-vector.21 + (find 'a #(a a b a c e d a f a) :test #'eql + :start 2) + a) + +(deftest find-vector.22 + (find 'a #(a a b a c e d a f a) :test #'eql + :start 2 :end nil) + a) + +(deftest find-vector.23 + (find 'a #(a a b a c e d a f a) :test-not #'eql + :start 0 :end 5) + b) + +(deftest find-vector.24 + (find 'a #(a a b a c e d a f a) :test-not #'eql + :start 0 :end 5 :from-end t) + c) + +(deftest find-vector.25 + (find "ab" #("a" #(#\b #\a) #(#\a #\b #\c) #(#\a #\b) #(#\d #\e) f) :test #'equalp) + #(#\a #\b)) + +(deftest find-vector.26 + (find 'a #((c) (b a) (a b c) (a b) (d e) f) :key #'car) + (a b c)) + +(deftest find-vector.27 + (find 'a #((c) (b a) (a b c) (z) (a b) (d e) f) :key #'car + :start 3) + (a b)) + +(deftest find-vector.28 + (find 'a #((c) (b a) (a b c) (z) (a b) (d e) (f)) :key #'car + :start 2 :from-end t) + (a b)) + +(deftest find-vector.29 + (let ((a (make-array '(10) + :initial-contents '(1 2 3 4 5 6 7 8 9 10) + :fill-pointer 5))) + (loop for i from 1 to 10 collect (find i a))) + (1 2 3 4 5 nil nil nil nil nil)) + +(deftest find-vector.30 + (let ((a (make-array '(10) + :initial-contents (loop for i from 1 for e in '(1 2 3 4 5 5 4 3 2 1) + collect (list e i)) + :fill-pointer 5))) + (loop for i from 1 to 5 collect (find i a :from-end t :key #'car))) + ((1 1) (2 2) (3 3) (4 4) (5 5))) + +;;; tests on bit vectors + +(deftest find-bit-vector.1 + (find 1 #*001001010100) + 1) + +(deftest find-bit-vector.1a + (find 0 #*001001010100) + 0) + +(deftest find-bit-vector.1b + (find 2 #*001001010100) + nil) + +(deftest find-bit-vector.1c + (find 'a #*001001010100) + nil) + +(deftest find-bit-vector.1d + (find 1 #*000000) + nil) + +(deftest find-bit-vector.2 + (find 1 #*001001010100 :from-end t) + 1) + +(deftest find-bit-vector.2a + (find 1 #*00000 :from-end t) + nil) + +(deftest find-bit-vector.2b + (find 0 #*00000 :from-end t) + 0) + +(deftest find-bit-vector.2c + (find 0 #*11111 :from-end t) + nil) + +(deftest find-bit-vector.2d + (find 2 #*11111 :from-end t) + nil) + +(deftest find-bit-vector.2e + (find 'a #*11111 :from-end t) + nil) + +(deftest find-bit-vector.3 + (loop for i from 0 to 7 collect + (find 1 #*0010010 :start i)) + (1 1 1 1 1 1 nil nil)) + +(deftest find-bit-vector.4 + (loop for i from 0 to 7 collect + (find 1 #*0010010 :start i :end nil)) + (1 1 1 1 1 1 nil nil)) + +(deftest find-bit-vector.5 + (loop for i from 7 downto 0 collect + (find 1 #*0010010 :end i)) + (1 1 1 1 1 nil nil nil)) + +(deftest find-bit-vector.6 + (loop for i from 0 to 7 collect + (find 1 #*0010010 :start i :from-end t)) + (1 1 1 1 1 1 nil nil)) + +(deftest find-bit-vector.7 + (loop for i from 0 to 7 collect + (find 0 #*1101101 :start i :end nil :from-end t)) + (0 0 0 0 0 0 nil nil)) + +(deftest find-bit-vector.8 + (loop for i from 7 downto 0 collect + (find 0 #*1101101 :end i :from-end t)) + (0 0 0 0 0 nil nil nil)) + +(deftest find-bit-vector.9 + (loop for i from 0 to 6 collect + (loop for j from (1+ i) to 7 + collect + (find 1 #*0010010 :start i :end j))) + ((nil nil 1 1 1 1 1) + (nil 1 1 1 1 1) + (1 1 1 1 1) + (nil nil 1 1) + (nil 1 1) + (1 1) + (nil))) + +(deftest find-bit-vector.10 + (loop for i from 0 to 6 collect + (loop for j from (1+ i) to 7 + collect + (find 1 #*0010010 :start i :end j :from-end t))) + ((nil nil 1 1 1 1 1) + (nil 1 1 1 1 1) + (1 1 1 1 1) + (nil nil 1 1) + (nil 1 1) + (1 1) + (nil))) + +(deftest find-bit-vector.11 + (find 2 #*00010001010 :key #'1+) + 1) + +(deftest find-bit-vector.12 + (find 2 #*00010001010 :key '1+) + 1) + +(deftest find-bit-vector.13 + (find 2 #*0010001000 :key #'1+ :from-end t) + 1) + +(deftest find-bit-vector.14 + (find 0 #*0010111010 :test (complement #'eql)) + 1) + +(deftest find-bit-vector.15 + (find 0 #*0010111010 :test (complement #'eql) + :from-end t) + 1) + +(deftest find-bit-vector.16 + (find 0 #*0010111010 :test-not #'eql) + 1) + +(deftest find-bit-vector.16a + (find 1 #*111111111111 :test-not #'eql) + nil) + +(deftest find-bit-vector.16b + (find 0 #*0000000 :test-not #'eql) + nil) + +(deftest find-bit-vector.17 + (find 0 #*001011101 :test-not 'eql + :from-end t) + 1) + +(deftest find-bit-vector.17a + (find 0 #*0000000 :test-not 'eql + :from-end t) + nil) + +(deftest find-bit-vector.17b + (find 1 #*111111111111 :test-not 'eql + :from-end t) + nil) + +(deftest find-bit-vector.18 + (find 0 #*00101110 :test-not 'eql) + 1) + +(deftest find-bit-vector.18a + (find 0 #*00000000 :test-not 'eql) + nil) + +(deftest find-bit-vector.19 + (find 0 #*00101110 :test-not #'eql + :from-end t) + 1) + +(deftest find-bit-vector.19a + (find 0 #*00000000 :test-not #'eql + :from-end t) + nil) + +(deftest find-bit-vector.20 + (find 0 #*00101110 :test-not #'eql) + 1) + +(deftest find-bit-vector.21 + (find 0 #*00101110 :test #'eql + :start 2) + 0) + +(deftest find-bit-vector.21a + (find 0 #*00111111 :test #'eql + :start 2) + nil) + +(deftest find-bit-vector.21b + (find 1 #*00111111 :test #'eql + :start 2) + 1) + +(deftest find-bit-vector.22 + (find 0 #*00101110 :test #'eql + :start 2 :end nil) + 0) + +(deftest find-bit-vector.22a + (find 0 #*001111111 :test #'eql + :start 2 :end nil) + nil) + +(deftest find-bit-vector.22b + (find 1 #*001111111 :test #'eql + :start 2 :end nil) + 1) + +(deftest find-bit-vector.23 + (find 0 #*00101110 :test-not #'eql + :start 0 :end 5) + 1) + +(deftest find-bit-vector.23a + (find 0 #*00000111 :test-not #'eql + :start 0 :end 5) + nil) + +(deftest find-bit-vector.23b + (find 0 #*00001000 :test-not #'eql + :start 0 :end 5) + 1) + +(deftest find-bit-vector.24 + (find 0 #*00101110 :test-not #'eql + :start 0 :end 5 :from-end t) + 1) + +(deftest find-bit-vector.24a + (find 0 #*0000001111 :test-not #'eql + :start 0 :end 5 :from-end t) + nil) + +(deftest find-bit-vector.24b + (find 0 #*0000100 :test-not #'eql + :start 0 :end 5 :from-end t) + 1) + +(deftest find-bit-vector.25 + (find 2 #*1100001010 :key #'1+ + :start 3) + 1) + +(deftest find-bit-vector.26 + (find 2 #*11100000 :key #'1+ + :start 3) + nil) + +(deftest find-bit-vector.26a + (find 2 #*11110000 :key #'1+ + :start 3) + 1) + +(deftest find-bit-vector.27 + (find 2 #*1100001010 :key #'1+ + :start 2 :from-end t) + 1) + +(deftest find-bit-vector.28 + (find 2 #*1100000000 :key #'1+ + :start 2 :from-end t) + nil) + +(deftest find-bit-vector.29 + (let ((a + (make-array '(10) :initial-contents '(1 1 1 1 1 0 0 0 0 0) + :element-type 'bit + :fill-pointer 5))) + (values (find 0 a) + (find 0 a :from-end t))) + nil nil) + +(deftest find-bit-vector.30 + (let ((a (make-array '(10) :initial-contents '(1 1 1 1 0 0 0 0 0 0) + :element-type 'bit + :fill-pointer 5))) + (values (find 0 a) (find 0 a :from-end t))) + 0 0) + +;;; strings + +(deftest find-string.1 + (find #\c "abcdeca") + #\c) + +(deftest find-string.1a + (find #\c "abCa") + nil) + +(deftest find-string.2 + (find #\c "abcdeca" :from-end t) + #\c) + +(deftest find-string.2a + (find #\c "abCCCa" :from-end t) + nil) + +(deftest find-string.3 + (loop for i from 0 to 7 collect + (find #\c "abcdeca" :start i)) + (#\c #\c #\c #\c #\c #\c nil nil)) + +(deftest find-string.4 + (loop for i from 0 to 7 collect + (find #\c "abcdeca" :start i :end nil)) + (#\c #\c #\c #\c #\c #\c nil nil)) + +(deftest find-string.5 + (loop for i from 7 downto 0 collect + (find #\c "abcdeca" :end i)) + (#\c #\c #\c #\c #\c nil nil nil)) + +(deftest find-string.6 + (loop for i from 0 to 7 collect + (find #\c "abcdeca" :start i :from-end t)) + (#\c #\c #\c #\c #\c #\c nil nil)) + +(deftest find-string.7 + (loop for i from 0 to 7 collect + (find #\c "abcdeca" :start i :end nil :from-end t)) + (#\c #\c #\c #\c #\c #\c nil nil)) + +(deftest find-string.8 + (loop for i from 7 downto 0 collect + (find #\c "abcdeca" :end i :from-end t)) + (#\c #\c #\c #\c #\c nil nil nil)) + +(deftest find-string.9 + (loop for i from 0 to 6 collect + (loop for j from (1+ i) to 7 + collect + (find #\c "abcdeca" :start i :end j))) + ((nil nil #\c #\c #\c #\c #\c) + (nil #\c #\c #\c #\c #\c) + (#\c #\c #\c #\c #\c) + (nil nil #\c #\c) + (nil #\c #\c) + (#\c #\c) + (nil))) + +(deftest find-string.10 + (loop for i from 0 to 6 collect + (loop for j from (1+ i) to 7 + collect + (find #\c "abcdeca" :start i :end j :from-end t))) + ((nil nil #\c #\c #\c #\c #\c) + (nil #\c #\c #\c #\c #\c) + (#\c #\c #\c #\c #\c) + (nil nil #\c #\c) + (nil #\c #\c) + (#\c #\c) + (nil))) + +(deftest find-string.11 + (find 5 "12345648" :key #'(lambda (c) + (1+ (read-from-string (string c))))) + #\4) + +(deftest find-string.13 + (find 5 "12345648" :key #'(lambda (c) + (1+ (read-from-string (string c)))) + :from-end t) + #\4) + +(deftest find-string.14 + (find #\a "aabacedafa" :test (complement #'eql)) + #\b) + +(deftest find-string.15 + (find #\a "aabacedafa" :test (complement #'eql) + :from-end t) + #\f) + +(deftest find-string.16 + (find #\a "aabacedafa" :test-not #'eql) + #\b) + +(deftest find-string.17 + (find #\a "aabacedafa" :test-not 'eql + :from-end t) + #\f) + +(deftest find-string.18 + (find #\a "aabacedafa" :test-not 'eql) + #\b) + +(deftest find-string.19 + (find #\a "aabacedafa" :test-not #'eql + :from-end t) + #\f) + +(deftest find-string.20 + (find #\a "aabacedafa" :test-not #'eql) + #\b) + +(deftest find-string.21 + (find #\a "aabAcedafa" :test #'char-equal + :start 2) + #\A) + +(deftest find-string.22 + (find #\a "aabAcedafa" :test #'char-equal + :start 2 :end nil) + #\A) + +(deftest find-string.23 + (find #\a "aAbAcedafa" :test-not #'char-equal + :start 0 :end 5) + #\b) + +(deftest find-string.24 + (find #\a "aabacedafa" :test-not #'char-equal + :start 0 :end 5 :from-end t) + #\c) + +(deftest find-string.25 + (let ((s (make-array '(10) :initial-contents "abcdefghij" + :element-type 'character + :fill-pointer 5))) + (values + (loop for e across "abcdefghij" + collect (find e s)) + (loop for e across "abcdefghij" + collect (find e s :from-end t)))) + (#\a #\b #\c #\d #\e nil nil nil nil nil) + (#\a #\b #\c #\d #\e nil nil nil nil nil)) + +;;; Keyword tests + +(deftest find.allow-other-keys.1 + (find 0 '(1 2 3 4 5) :key #'(lambda (x) (mod x 2)) + :bad t :allow-other-keys t) + 2) + +(deftest find.allow-other-keys.2 + (find 0 '(1 2 3 4 5) :key #'(lambda (x) (mod x 2)) + :allow-other-keys t :also-bad t) + 2) + +;;; The leftmost of two :allow-other-keys arguments is the one that matters. +(deftest find.allow-other-keys.3 + (find 0 '(1 2 3 4 5) :key #'(lambda (x) (mod x 2)) + :allow-other-keys t + :allow-other-keys nil + :bad t) + 2) + +(deftest find.keywords.4 + (find 2 '(1 2 3 4 5) :key #'identity :key #'1+) + 2) + +(deftest find.allow-other-keys.5 + (find 'b '(nil a b c nil) :allow-other-keys nil) + b) + + +;;; Error tests + +(deftest find.error.1 + (classify-error (find 'a 'b)) + type-error) + +(deftest find.error.2 + (classify-error (find 'a 10)) + type-error) + +(deftest find.error.3 + (classify-error (find 'a 1.4)) + type-error) + +(deftest find.error.4 + (classify-error (find 'e '(a b c . d))) + type-error) + +(deftest find.error.5 + (classify-error (find)) + program-error) + +(deftest find.error.6 + (classify-error (find 'a)) + program-error) + +(deftest find.error.7 + (classify-error (find 'a nil :bad t)) + program-error) + +(deftest find.error.8 + (classify-error (find 'a nil :bad t :allow-other-keys nil)) + program-error) + +(deftest find.error.9 + (classify-error (find 'a nil 1 1)) + program-error) + +(deftest find.error.10 + (classify-error (find 'a nil :key)) + program-error) + +(deftest find.error.11 + (classify-error (locally (find 'a 'b) t)) + type-error) + +(deftest find.error.12 + (classify-error (find 'b '(a b c) :test #'identity)) + program-error) + +(deftest find.error.13 + (classify-error (find 'b '(a b c) :test-not #'identity)) + program-error) + +(deftest find.error.14 + (classify-error (find 'c '(a b c) :key #'cons)) + program-error) + +(deftest find.error.15 + (classify-error (find 'c '(a b c) :key #'car)) + type-error) + + +;;; Order of evaluation tests + +(deftest find.order.1 + (let ((i 0) x y) + (values + (find (progn (setf x (incf i)) 'a) + (progn (setf y (incf i)) '(nil nil nil a nil nil))) + i x y)) + a 2 1 2) + +(deftest find.order.2 + (let ((i 0) a b c d e f g) + (values + (find (progn (setf a (incf i)) nil) + (progn (setf b (incf i)) '(nil nil nil a nil nil)) + :start (progn (setf c (incf i)) 1) + :end (progn (setf d (incf i)) 4) + :from-end (setf e (incf i)) + :key (progn (setf f (incf i)) #'null) + ) + i a b c d e f)) + a 6 1 2 3 4 5 6) + +(deftest find.order.3 + (let ((i 0) a b c d e f g) + (values + (find (progn (setf a (incf i)) nil) + (progn (setf b (incf i)) '(nil nil nil a nil nil)) + :key (progn (setf c (incf i)) #'null) + :from-end (setf d (incf i)) + :end (progn (setf e (incf i)) 4) + :start (progn (setf f (incf i)) 1) + ) + i a b c d e f)) + a 6 1 2 3 4 5 6) diff --git a/ansi-tests/flet.lsp b/ansi-tests/flet.lsp new file mode 100644 index 0000000..a4691f7 --- /dev/null +++ b/ansi-tests/flet.lsp @@ -0,0 +1,431 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Oct 8 22:55:02 2002 +;;;; Contains: Tests of FLET + +(in-package :cl-test) + +(deftest flet.1 + (flet ((%f () 1)) + (%f)) + 1) + +(deftest flet.2 + (flet ((%f (x) x)) + (%f 2)) + 2) + +(deftest flet.3 + (flet ((%f (&rest args) args)) + (%f 'a 'b 'c)) + (a b c)) + +;;; The optional arguments are not in the block defined by +;;; the local function declaration +(deftest flet.4 + (block %f + (flet ((%f (&optional (x (return-from %f 10))) + 20)) + (%f))) + 10) + +(deftest flet.5 + (flet ((%f () (return-from %f 15) 35)) + (%f)) + 15) + +;;; The aux parameters are not in the block defined by +;;; the local function declaration +(deftest flet.6 + (block %f + (flet ((%f (&aux (x (return-from %f 10))) + 20)) + (%f))) + 10) + +;;; The function is not visible inside itself +(deftest flet.7 + (flet ((%f (x) (+ x 5))) + (flet ((%f (y) (cond ((eql y 20) 30) + (t (%f 20))))) + (%f 15))) + 25) + +;;; Keyword arguments +(deftest flet.8 + (flet ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) + (%f)) + nil 0 nil) + +(deftest flet.9 + (flet ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) + (%f :a 1)) + 1 0 nil) + +(deftest flet.10 + (flet ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) + (%f :b 2)) + nil 2 t) + +(deftest flet.11 + (flet ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) + (%f :b 2 :a 3)) + 3 2 t) + +;;; Unknown keyword parameter should throw a program-error in safe code +;;; (section 3.5.1.4) +(deftest flet.12 + (classify-error + (flet ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :c 4))) + program-error) + +;;; Odd # of keyword args should throw a program-error in safe code +;;; (section 3.5.1.6) +(deftest flet.13 + (classify-error + (flet ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :a))) + program-error) + +;;; Too few arguments (section 3.5.1.2) +(deftest flet.14 + (classify-error (flet ((%f (a) a)) (%f))) + program-error) + +;;; Too many arguments (section 3.5.1.3) +(deftest flet.15 + (classify-error (flet ((%f (a) a)) (%f 1 2))) + program-error) + +;;; Invalid keyword argument (section 3.5.1.5) +(deftest flet.16 + (classify-error (flet ((%f (&key a) a)) (%f '(foo)))) + program-error) + + +;;; Definition of a (setf ...) function + +(deftest flet.17 + (flet (((setf %f) (x y) (setf (car y) x))) + (let ((z (list 1 2))) + (setf (%f z) 'a) + z)) + (a 2)) + +;;; Body is an implicit progn +(deftest flet.18 + (flet ((%f (x) (incf x) (+ x x))) + (%f 10)) + 22) + +;;; Can handle at least 50 lambda parameters +(deftest flet.19 + (flet ((%f (a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 + b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 + c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 + d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 + e1 e2 e3 e4 e5 e6 e7 e8 e9 e10) + (+ a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 + b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 + c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 + d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 + e1 e2 e3 e4 e5 e6 e7 e8 e9 e10))) + (%f 1 2 3 4 5 6 7 8 9 10 + 11 12 13 14 15 16 17 18 19 20 + 21 22 23 24 25 26 27 28 29 30 + 31 32 33 34 35 36 37 38 39 40 + 41 42 43 44 45 46 47 48 49 50)) + 1275) + +;;; flet works with a large (maximal?) number of arguments +(deftest flet.20 + (let* ((n (min lambda-parameters-limit 1024)) + (vars (loop for i from 1 to n collect (gensym)))) + (eval + `(eql ,n + (flet ((%f ,vars (+ ,@ vars))) + (%f ,@(loop for e in vars collect 1)))))) + t) + +;;; Declarations and documentation strings are ok +(deftest flet.21 + (flet ((%f (x) + (declare (type fixnum x)) + "Add one to the fixnum x." + (1+ x))) + (declare (ftype (function (fixnum) integer) %f)) + (%f 10)) + 11) + +(deftest flet.22 + (flet ((%f (x &optional (y 1 y-p) (z 2 z-p)) + (list x y (not (not y-p)) z (not (not z-p))))) + (values (%f 10) (%f 20 40) (%f 'a 'b 'c))) + (10 1 nil 2 nil) + (20 40 t 2 nil) + (a b t c t)) + +(deftest flet.23 + (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r) + (list x y (not (not y-p)) z (not (not z-p)) r))) + (values (%f 10) (%f 20 40) (%f 'a 'b 'c) (%f 'd 'e 'f 'g 'h))) + (10 1 nil 2 nil nil) + (20 40 t 2 nil nil) + (a b t c t nil) + (d e t f t (g h))) + +(deftest flet.24 + (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r &key foo bar) + (list x y (not (not y-p)) z (not (not z-p)) r foo bar))) + (values (%f 10) (%f 20 40) (%f 'a 'b 'c) + (%f 'd 'e 'f :foo 'h) + (%f 'd 'e 'f :bar 'i) )) + (10 1 nil 2 nil nil nil nil) + (20 40 t 2 nil nil nil nil) + (a b t c t nil nil nil) + (d e t f t (:foo h) h nil) + (d e t f t (:bar i) nil i)) + +(deftest flet.25 + (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r &key foo bar + &allow-other-keys) + (list x y (not (not y-p)) z (not (not z-p)) r foo bar))) + (values (%f 10) (%f 20 40) (%f 'a 'b 'c) + (%f 'd 'e 'f :foo 'h :whatever nil) + (%f 'd 'e 'f :bar 'i :illegal t :foo 'z) )) + (10 1 nil 2 nil nil nil nil) + (20 40 t 2 nil nil nil nil) + (a b t c t nil nil nil) + (d e t f t (:foo h :whatever nil) h nil) + (d e t f t (:bar i :illegal t :foo z) z i)) + +(deftest flet.26 + (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r &key foo bar) + (list x y (not (not y-p)) z (not (not z-p)) r foo bar))) + (values (%f 10) (%f 20 40) (%f 'a 'b 'c) + (%f 'd 'e 'f :foo 'h :whatever nil :allow-other-keys t) + (%f 'd 'e 'f :bar 'i :illegal t :foo 'z :allow-other-keys t) )) + (10 1 nil 2 nil nil nil nil) + (20 40 t 2 nil nil nil nil) + (a b t c t nil nil nil) + (d e t f t (:foo h :whatever nil :allow-other-keys t) h nil) + (d e t f t (:bar i :illegal t :foo z :allow-other-keys t) z i)) + +;;; Section 3.4.1.4.1: "The :allow-other-keys argument is permissible +;;; in all situations involving keyword[2] arguments, even when its +;;; associated value is false." +(deftest flet.27 + (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r &key foo bar) + (list x y (not (not y-p)) z (not (not z-p)) r foo bar))) + (values (%f 10) (%f 20 40) (%f 'a 'b 'c) + (%f 'd 'e 'f :foo 'h :allow-other-keys nil) + (%f 'd 'e 'f :bar 'i :allow-other-keys nil) )) + (10 1 nil 2 nil nil nil nil) + (20 40 t 2 nil nil nil nil) + (a b t c t nil nil nil) + (d e t f t (:foo h :allow-other-keys nil) h nil) + (d e t f t (:bar i :allow-other-keys nil) nil i)) + +(deftest flet.28 + (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r + &key foo bar allow-other-keys) + (list x y (not (not y-p)) z (not (not z-p)) allow-other-keys + r foo bar))) + (values (%f 10) (%f 20 40) (%f 'a 'b 'c) + (%f 'd 'e 'f :foo 'h :whatever nil :allow-other-keys 100) + (%f 'd 'e 'f :bar 'i :illegal t :foo 'z :allow-other-keys 200) )) + (10 1 nil 2 nil nil nil nil nil) + (20 40 t 2 nil nil nil nil nil) + (a b t c t nil nil nil nil) + (d e t f t 100 (:foo h :whatever nil :allow-other-keys 100) h nil) + (d e t f t 200 (:bar i :illegal t :foo z :allow-other-keys 200) z i)) + +(deftest flet.29 + (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r + &key foo bar allow-other-keys &allow-other-keys) + (list x y (not (not y-p)) z (not (not z-p)) allow-other-keys + r foo bar))) + (values (%f 10) (%f 20 40) (%f 'a 'b 'c) + (%f 'd 'e 'f :foo 'h :whatever nil :allow-other-keys nil :blah t) + (%f 'd 'e 'f :bar 'i :illegal t :foo 'z + :allow-other-keys nil :zzz 10) )) + (10 1 nil 2 nil nil nil nil nil) + (20 40 t 2 nil nil nil nil nil) + (a b t c t nil nil nil nil) + (d e t f t nil (:foo h :whatever nil :allow-other-keys nil :blah t) h nil) + (d e t f t nil (:bar i :illegal t :foo z :allow-other-keys nil :zzz 10) z i)) + +;;; Tests of non-keyword keywords (see section 3.4.1.4, paragrph 2). +(deftest flet.30 + (flet ((%f (&key ((foo bar) nil)) bar)) + (values (%f) (%f 'foo 10))) + nil 10) + +(deftest flet.31 + (flet ((%f (&key ((:foo bar) nil)) bar)) + (values (%f) (%f :foo 10))) + nil 10) + +;;; Multiple keyword actual parameters +(deftest flet.32 + (flet ((%f (&key a b c) (list a b c))) + (%f :a 10 :b 20 :c 30 :a 40 :b 50 :c 60)) + (10 20 30)) + +;;; More aux parameters +(deftest flet.33 + (flet ((%f (x y &aux (a (1+ x)) (b (+ x y a)) (c (list x y a b))) + c)) + (%f 5 9)) + (5 9 6 20)) + +(deftest flet.34 + (flet ((%f (x y &rest r &key foo bar &aux (c (list x y r foo bar))) + c)) + (values + (%f 1 2) + (%f 1 2 :foo 'a) + (%f 1 2 :bar 'b) + (%f 1 2 :foo 'a :bar 'b) + (%f 1 2 :bar 'b :foo 'a))) + (1 2 nil nil nil) + (1 2 (:foo a) a nil) + (1 2 (:bar b) nil b) + (1 2 (:foo a :bar b) a b) + (1 2 (:bar b :foo a) a b)) + +;;; Binding of formal parameters that are also special variables +(deftest flet.35 + (let ((x 'bad)) + (declare (special x)) + (flet ((%f () x)) + (flet ((%g (x) + (declare (special x)) + (%f))) + (%g 'good)))) + good) + +(deftest flet.36 + (let ((x 'bad)) + (declare (special x)) + (flet ((%f () x)) + (flet ((%g (&aux (x 'good)) + (declare (special x)) + (%f))) + (%g)))) + good) + +(deftest flet.37 + (let ((x 'bad)) + (declare (special x)) + (flet ((%f () x)) + (flet ((%g (&rest x) + (declare (special x)) + (%f))) + (%g 'good)))) + (good)) + +(deftest flet.38 + (let ((x 'bad)) + (declare (special x)) + (flet ((%f () x)) + (flet ((%g (&key (x 'good)) + (declare (special x)) + (%f))) + (%g)))) + good) + +(deftest flet.39 + (let ((x 'bad)) + (declare (special x)) + (flet ((%f () x)) + (flet ((%g (&key (x 'bad)) + (declare (special x)) + (%f))) + (%g :x 'good)))) + good) + +(deftest flet.40 + (let ((x 'good)) + (declare (special x)) + (flet ((%f () x)) + (flet ((%g (&key (x 'bad)) + (%f))) + (%g :x 'worse)))) + good) + +;;; Test that [:&]allow-other-keys suppress errors for illegal keywords +;;; or odd numbers of keyword arguments + +;;; Note -- These are apparently bad tests! -- PFD +;;;(deftest flet.41 +;;; (classify-error +;;; (flet ((%f (&key (a :good)) a)) +;;; (%f :allow-other-keys t :b))) +;;; :good) +;;; +;;;(deftest flet.42 +;;; (classify-error +;;; (flet ((%f (&key (a :good)) a)) +;;; (%f :allow-other-keys t 10 20))) +;;; :good) +;;; +;;;(deftest flet.43 +;;; (classify-error +;;; (flet ((%f (&key (a :good) &allow-other-keys) a)) +;;; (%f :b))) +;;; :good) +;;; +;;;(deftest flet.44 +;;; (classify-error +;;; (flet ((%f (&key (a :good) &allow-other-keys) a)) +;;; (%f 10 20))) +;;; :good) + + +(deftest flet.45 + (flet ((nil () 'a)) (nil)) + a) + +(deftest flet.46 + (flet ((t () 'b)) (t)) + b) + +;;; Keywords can be function names +(deftest flet.47 + (flet ((:foo () 'bar)) (:foo)) + bar) + +(deftest flet.48 + (flet ((:foo () 'bar)) (funcall #':foo)) + bar) + +(deftest flet.49 + (loop for s in *cl-non-function-macro-special-operator-symbols* + for form = `(classify-error (flet ((,s () 'a)) (,s))) + unless (eq (eval form) 'a) + collect s) + nil) + +(deftest flet.50 + (loop for s in *cl-non-function-macro-special-operator-symbols* + for form = `(classify-error (flet ((,s () 'a)) + (declare (ftype (function () symbol) + ,s)) + (,s))) + unless (eq (eval form) 'a) + collect s) + nil) + +;;; Binding SETF functions of certain COMMON-LISP symbols +(deftest flet.51 + (loop for s in *cl-non-function-macro-special-operator-symbols* + for form = `(classify-error + (flet (((setf ,s) (&rest args) + (declare (ignore args)) + 'a)) + (setf (,s) 10))) + unless (eq (eval form) 'a) + collect s) + nil) + + diff --git a/ansi-tests/fmakunbound.lsp b/ansi-tests/fmakunbound.lsp new file mode 100644 index 0000000..f6c44f5 --- /dev/null +++ b/ansi-tests/fmakunbound.lsp @@ -0,0 +1,67 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Oct 8 00:09:14 2002 +;;;; Contains: Tests for FMAKUNBOUND + +(in-package :cl-test) + +(deftest fmakunbound.1 + (let ((g (gensym))) + (and (not (fboundp g)) + (setf (symbol-function g) #'car) + (fboundp g) + (values (eqt (check-values (fmakunbound g)) g) + (fboundp g)))) + t nil) + +(deftest fmakunbound.2 + (let ((g (gensym))) + (and (not (fboundp g)) + (eval `(defun ,g () nil)) + (fboundp g) + (values (eqt (check-values (fmakunbound g)) g) + (fboundp g)))) + t nil) + +(deftest fmakunbound.3 + (let ((g (gensym))) + (and (not (fboundp g)) + (eval `(defmacro ,g () nil)) + (fboundp g) + (values (eqt (check-values (fmakunbound g)) g) + (fboundp g)))) + t nil) + +(deftest fmakunbound.4 + (let* ((g (gensym)) + (n `(setf ,g))) + (and (not (fboundp n)) + (eval `(defun ,n () nil)) + (fboundp n) + (values (equal (check-values (fmakunbound n)) n) + (fboundp n)))) + t nil) + +(deftest fmakunbound.error.1 + (classify-error (fmakunbound 1)) + type-error) + +(deftest fmakunbound.error.2 + (classify-error (fmakunbound #\a)) + type-error) + +(deftest fmakunbound.error.3 + (classify-error (fmakunbound '(x))) + type-error) + +(deftest fmakunbound.error.4 + (classify-error (fmakunbound)) + program-error) + +(deftest fmakunbound.error.5 + (classify-error (fmakunbound (gensym) nil)) + program-error) + +(deftest fmakunbound.error.6 + (classify-error (locally (fmakunbound 1) t)) + type-error) diff --git a/ansi-tests/funcall.lsp b/ansi-tests/funcall.lsp new file mode 100644 index 0000000..f39e4fd --- /dev/null +++ b/ansi-tests/funcall.lsp @@ -0,0 +1,105 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Oct 9 21:45:07 2002 +;;;; Contains: Tests of FUNCALL + +(in-package :cl-test) + +(deftest funcall.1 + (let ((fn #'cons)) + (funcall fn 'a 'b)) + (a . b)) + +(deftest funcall.2 + (funcall (symbol-function 'cons) 'a 'b) + (a . b)) + +(deftest funcall.3 + (let ((fn 'cons)) + (funcall fn 'a 'b)) + (a . b)) + +(deftest funcall.4 + (funcall 'cons 'a 'b) + (a . b)) + +(deftest funcall.5 + (let ((fn #'+)) + (funcall fn 1 2 3 4)) + 10) + +(deftest funcall.6 + (funcall #'(lambda (x y) (cons x y)) 'a 'b) + (a . b)) + +(defun xcons (x y) (cons x y)) + +(deftest funcall.7 + (flet ((xcons (x y) (list y x))) + (values (funcall 'xcons 1 2) + (funcall #'xcons 1 2))) + (1 . 2) + (2 1)) + +(deftest funcall.8 + (flet ((foo (x y z) (values x y z))) + (funcall #'foo 1 2 3)) + 1 2 3) + +(deftest funcall.9 + (flet ((foo () (values))) + (funcall #'foo)) + ) + +(deftest funcall.order.1 + (let ((i 0) a b) + (values + (funcall (progn (setf a (incf i)) #'car) + (progn (setf b (incf i)) '(x . y))) + i a b)) + x 2 1 2) + +(deftest funcall.order.2 + (let ((i 0) a b c) + (values + (funcall (progn (setf a (incf i)) #'cons) + (progn (setf b (incf i)) 'x) + (progn (setf c (incf i)) 'y)) + i a b c)) + (x . y) 3 1 2 3) + + +;;; FUNCALL should throw an UNDEFINED-FUNCTION condition when +;;; called on a symbol with a global definition as a special +;;; operator +(deftest funcall.error.1 + (classify-error (funcall 'quote 1)) + undefined-function) + +(deftest funcall.error.2 + (classify-error (funcall 'progn 1)) + undefined-function) + +;;; FUNCALL should throw an UNDEFINED-FUNCTION condition when +;;; called on a symbol with a global definition as a macro +(deftest funcall.error.3 + (classify-error (funcall 'defconstant '(defconstant x 10))) + undefined-function) + +(deftest funcall.error.4 + (classify-error (funcall)) + program-error) + +(deftest funcall.error.5 + (classify-error (funcall #'cons)) + program-error) + +(deftest funcall.error.6 + (classify-error (funcall #'cons 1)) + program-error) + +(deftest funcall.error.7 + (classify-error (funcall #'car 'a)) + type-error) + + diff --git a/ansi-tests/function-lambda-expression.lsp b/ansi-tests/function-lambda-expression.lsp new file mode 100644 index 0000000..1ac0a07 --- /dev/null +++ b/ansi-tests/function-lambda-expression.lsp @@ -0,0 +1,42 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Mon Jan 13 16:27:12 2003 +;;;; Contains: Tests for FUNCTION-LAMBDA-EXPRESSION + +(in-package :cl-test) + +(deftest function-lambda-expression.1 + (length + (multiple-value-list + (function-lambda-expression #'cons))) + 3) + +(deftest function-lambda-expression.2 + (let ((x nil)) + (flet ((%f () x)) + (let ((ret-vals + (multiple-value-list + (function-lambda-expression #'%f)))) + (values (length ret-vals) + (notnot (second ret-vals)))))) + 3 t) + +(deftest function-lambda-expression.order.1 + (let ((i 0)) + (function-lambda-expression (progn (incf i) #'cons)) + i) + 1) + +(deftest function-lambda-expression.error.1 + (classify-error (function-lambda-expression)) + program-error) + +(deftest function-lambda-expression.error.2 + (classify-error (function-lambda-expression #'cons nil)) + program-error) + + + + + + diff --git a/ansi-tests/function.lsp b/ansi-tests/function.lsp new file mode 100644 index 0000000..f6039c6 --- /dev/null +++ b/ansi-tests/function.lsp @@ -0,0 +1,95 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Mon Oct 7 07:34:29 2002 +;;;; Contains: Tests for type FUNCTION and the special form FUNCTION + +(in-package :cl-test) + +;;; +;;; Note! There are significant incompatibilities between CLTL1 and ANSI CL +;;; in the meaning of FUNCTION and FUNCTIONP. +;;; + +(deftest function.1 + (typep nil 'function) + nil) + +;;; The next test demonstrates an incompatibility between CLtL1 and ANSI CL. +;;; In ANSI CL, symbols are no longer of type FUNCTION. +(deftest function.2 + (typep 'identity 'function) + nil) + +(deftest function.3 + (not-mv (typep #'identity 'function)) + nil) + +(deftest function.4 + (loop for x in *cl-symbol-names* + for s = (find-symbol x "CL") + for f = (and (fboundp s) + (symbol-function s) + (not (special-operator-p s)) + (not (macro-function s)) + (symbol-function s)) + unless (or (null f) + (typep f 'function)) + collect x) + nil) + +(deftest function.5 + (typep '(setf car) 'function) + nil) + +;;; The next test demonstrates an incompatibility between CLtL1 and ANSI CL. +;;; In ANSI CL, lambda forms are no longer of type FUNCTION. +(deftest function.6 + (typep '(lambda (x) x) 'function) + nil) + +(eval-when (eval compile) + (ignore-errors + (defun (setf function-7-accessor) (y x) (setf (car x) y) y))) + +(deftest function.7 + (not-mv (typep #'(setf function-7-accessor) 'function)) + nil) + +(deftest function.8 + (not-mv (typep #'(lambda (x) x) 'function)) + nil) + +(deftest function.9 + (not-mv (typep (compile nil '(lambda (x) x)) 'function)) + nil) + +;;; The next test demonstrates an incompatibility between CLtL1 and ANSI CL. +;;; In ANSI CL, symbols and cons can no longer also be of type FUNCTION. +(deftest function.10 + (loop for x in *universe* + when (and (or (numberp x) (characterp x) + (symbolp x) (consp x) + (typep x 'array)) + (typep x 'function)) + collect x) + nil) + +(deftest function.11 + (flet ((%f () nil)) (typep '%f 'function)) + nil) + +(deftest function.12 + (flet ((%f () nil)) (not-mv (typep #'%f 'function))) + nil) + +(deftest function.13 + (labels ((%f () nil)) (not-mv (typep #'%f 'function))) + nil) + +;;; "If name is a function name, the functional definition of that +;;; name is that established by the innermost lexically enclosing flet, +;;; labels, or macrolet form, if there is one." (page for FUNCTION, sec. 5.3) +;;; ^^^^^^^^ +;;;(deftest function.14 +;;; (macrolet ((%f () nil)) (not-mv (typep #'%f 'function))) +;;; nil) diff --git a/ansi-tests/functionp.lsp b/ansi-tests/functionp.lsp new file mode 100644 index 0000000..23edd09 --- /dev/null +++ b/ansi-tests/functionp.lsp @@ -0,0 +1,96 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Mon Oct 7 06:39:21 2002 +;;;; Contains: Tests for FUNCTIONP + +(in-package :cl-test) + +;;; +;;; Note! FUNCTIONP and FUNCTION behave differently in ANSI CL than +;;; in CLTL1. In particular, symbols and various lists are no longer +;;; in the class FUNCTION in ANSI CL. +;;; + +(deftest functionp.1 + (functionp nil) + nil) + +;;; In ANSI CL, symbols can no longer be functions +(deftest functionp.2 + (functionp 'identity) + nil) + +(deftest functionp.3 + (not (functionp #'identity)) + nil) + +(deftest functionp.4 + (loop for x in *cl-symbol-names* + for s = (find-symbol x "CL") + for f = (and (fboundp s) + (symbol-function s) + (not (special-operator-p s)) + (not (macro-function s)) + (symbol-function s)) + unless (or (null f) + (functionp f)) + collect x) + nil) + +(deftest functionp.5 + (functionp '(setf car)) + nil) + +;;; In ANSI CL, lambda forms are no longer functions +(deftest functionp.6 + (functionp '(lambda (x) x)) + nil) + +(eval-when (eval compile) + (ignore-errors + (defun (setf functionp-7-accessor) (y x) (setf (car x) y) y))) + +(deftest functionp.7 + (not-mv (functionp #'(setf functionp-7-accessor))) + nil) + +(deftest functionp.8 + (not-mv (functionp #'(lambda (x) x))) + nil) + +(deftest functionp.9 + (not-mv (functionp (compile nil '(lambda (x) x)))) + nil) + +;;; In ANSI CL, symbols and cons can no longer be functions +(deftest functionp.10 + (loop for x in *universe* + when (and (or (numberp x) (characterp x) + (symbolp x) (consp x) + (typep x 'array)) + (functionp x)) + collect x) + nil) + +(deftest functionp.11 + (flet ((%f () nil)) (functionp '%f)) + nil) + +(deftest functionp.12 + (flet ((%f () nil)) (not-mv (functionp #'%f))) + nil) + +(deftest functionp.order.1 + (let ((i 0)) + (values + (notnot (functionp (progn (incf i) #'cons))) + i)) + t 1) + +(deftest functionp.error.1 + (classify-error (functionp)) + program-error) + +(deftest functionp.error.2 + (classify-error (functionp #'cons nil)) + program-error) diff --git a/ansi-tests/gclload.lsp b/ansi-tests/gclload.lsp new file mode 100644 index 0000000..8d8110c --- /dev/null +++ b/ansi-tests/gclload.lsp @@ -0,0 +1,4 @@ +(load "gclload1.lsp") +(load "gclload2.lsp") +(in-package :cl-test) +(regression-test:do-tests) diff --git a/ansi-tests/gclload1.lsp b/ansi-tests/gclload1.lsp new file mode 100644 index 0000000..de81d08 --- /dev/null +++ b/ansi-tests/gclload1.lsp @@ -0,0 +1,33 @@ +(load "compile-and-load.lsp") +(load "rt-package.lsp") +(compile-and-load "rt.lsp") +;;; (unless (probe-file "rt.o") (compile-file "rt.lsp")) +;;; (load "rt.o") +(load "cl-test-package.lsp") +(in-package :cl-test) +(load "universe.lsp") +(compile-and-load "random-aux.lsp") +(compile-and-load "ansi-aux.lsp") +;;; (unless (probe-file "ansi-aux.o") (compile-file "ansi-aux.lsp")) +;;; (load "ansi-aux.o") + +(load "cl-symbol-names.lsp") +;(load "notes.lsp") + +(setq *compile-verbose* nil + *compile-print* nil + *load-verbose* nil) + +#+cmu (setq ext:*gc-verbose* nil) + +#+gcl (setq compiler:*suppress-compiler-notes* t + compiler:*suppress-compiler-warnings* t + compiler:*compile-verbose* nil + compiler:*compile-print* nil) + +#+lispworks (setq compiler::*compiler-warnings* nil) + +#+ecl (setq c:*suppress-compiler-warnings* t + c:*suppress-compiler-notes* t) + +#+clisp (setq custom::*warn-on-floating-point-contagion* nil) diff --git a/ansi-tests/gclload2.lsp b/ansi-tests/gclload2.lsp new file mode 100644 index 0000000..ab760ff --- /dev/null +++ b/ansi-tests/gclload2.lsp @@ -0,0 +1,55 @@ +;;; Load test files + +;;; Tests of symbols +(load "load-symbols.lsp") + +;;; Tests of evaluation and compilation +(load "load-eval-and-compile.lsp") + +;;; Tests of data and control flow +(load "load-data-and-control-flow.lsp") + +;;; Tests of iteration forms +(load "load-iteration.lsp") + +;;; Tests of conditions +(load "load-conditions.lsp") + +;;; Tests of conses +(load "load-cons.lsp") + +;;; Tests on arrays +(load "load-arrays.lsp") + +;;; Tests of hash tables + +(load "hash-table.lsp") +(load "make-hash-table.lsp") + ; More to come + +;;; Tests of packages + +#-ecl (load "packages.lsp") + +;;; Tests of sequences +(load "load-sequences.lsp") + +;;; Tests of structures +(load "load-structures.lsp") + +;;; Tests of types and classes +(load "load-types-and-class.lsp") + +;;; Tests of the reader +(load "reader-test.lsp") + +;;; Tests of strings +(load "load-strings.lsp") + +;;; Tests for character functions +(compile-and-load "char-aux.lsp") +(load "character.lsp") +(load "char-compare.lsp") + +;;; Tests of system construction +(load "features.lsp") diff --git a/ansi-tests/get-setf-expansion.lsp b/ansi-tests/get-setf-expansion.lsp new file mode 100644 index 0000000..77c603a --- /dev/null +++ b/ansi-tests/get-setf-expansion.lsp @@ -0,0 +1,16 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Mon Jan 13 17:05:17 2003 +;;;; Contains: Tests for GET-SETF-EXPANSION + +(in-package :cl-test) + +(deftest get-setf-expansion.error.1 + (classify-error (get-setf-expansion)) + program-error) + +(deftest get-setf-expansion.error.2 + (classify-error (get-setf-expansion 'x nil nil)) + program-error) + +;;; Tests for proper behavior will go here diff --git a/ansi-tests/handler-bind.lsp b/ansi-tests/handler-bind.lsp new file mode 100644 index 0000000..2bbef0c --- /dev/null +++ b/ansi-tests/handler-bind.lsp @@ -0,0 +1,144 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Feb 28 22:07:25 2003 +;;;; Contains: Tests of HANDLER-BIND + +(in-package :cl-test) + +(deftest handler-bind.1 + (handler-bind ()) + nil) + +(deftest handler-bind.2 + (handler-bind () (values))) + +(deftest handler-bind.3 + (handler-bind () (values 1 2 3)) + 1 2 3) + +(deftest handler-bind.4 + (let ((x 0)) + (values + (handler-bind () (incf x) (+ x 10)) + x)) + 11 1) + +(deftest handler-bind.5 + (block foo + (handler-bind ((error #'(lambda (c) (return-from foo 'good)))) + (error "an error"))) + good) + +(deftest handler-bind.6 + (block foo + (handler-bind + ((error #'(lambda (c) (return-from foo 'good)))) + (handler-bind ((error #'(lambda (c) (error c))) + (error #'(lambda (c) (return-from foo 'bad)))) + (error "an error")))) + good) + +(defun handler-bind.7-handler-fn (c) + (declare (ignore c)) + (throw 'foo 'good)) + +(deftest handler-bind.7 + (catch 'foo + (handler-bind ((simple-error #'handler-bind.7-handler-fn)) + (error "simple error"))) + good) + +(deftest handler-bind.8 + (catch 'foo + (handler-bind ((simple-error 'handler-bind.7-handler-fn)) + (error "simple error"))) + good) + +(deftest handler-bind.9 + (catch 'foo + (handler-bind ((simple-error #.(symbol-function + 'handler-bind.7-handler-fn))) + (error "simple error"))) + good) + +(deftest handler-bind.10 + (block done + (flet ((%foo () (signal "A simple condition")) + (%succeed (c) (declare (ignore c)) (return-from done 'good)) + (%fail (c) (declare (ignore c)) (return-from done 'bad))) + (handler-bind + ((error #'%fail) + (simple-condition #'%succeed)) + (%foo)))) + good) + +(deftest handler-bind.11 + (block done + (handler-bind + ((error #'(lambda (c) c)) + (error #'(lambda (c) (declare (ignore c)) (return-from done 'good)))) + (error "an error"))) + good) + +(deftest handler-bind.12 + (block done + (handler-bind + ((error #'(lambda (c) (declare (ignore c)) (return-from done 'good)))) + (handler-bind + ((error #'(lambda (c) c))) + (error "an error")))) + good) + +(deftest handler-bind.13 + (handler-bind + ((error #'(lambda (c) (declare (ignore c)) + (throw 'done 'good)))) + (catch 'done + (error "an error"))) + good) + +(deftest handler-bind.14 + (catch 'done + (handler-bind + ((symbol #'identity) ;; can never succeed + (error #'(lambda (c) (declare (ignore c)) + (throw 'done 'good)))) + (error "an error"))) + good) + +(deftest handler-bind.15 + (catch 'done + (handler-bind + ((t #'(lambda (c) (declare (ignore c)) + (throw 'done 'good)))) + (error "an error"))) + good) + +(deftest handler-bind.16 + (catch 'done + (handler-bind + (((not error) #'identity) + (error + #'(lambda (c) (declare (ignore c)) + (throw 'done 'good)))) + (error "an error"))) + good) + +(deftest handler-bind.17 + (catch 'done + (handler-bind + ((#.(find-class 'error) + #'(lambda (c) (declare (ignore c)) + (throw 'done 'good)))) + (error "an error"))) + good) + +;;; More handler-bind tests elsewhere + + + + + + + + diff --git a/ansi-tests/handler-case.lsp b/ansi-tests/handler-case.lsp new file mode 100644 index 0000000..373bad4 --- /dev/null +++ b/ansi-tests/handler-case.lsp @@ -0,0 +1,9 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 1 14:08:07 2003 +;;;; Contains: Tests of HANDLER-CASE + +(in-package :cl-test) + +;;; (deftest handler-case.1 +;;; (handler-case (( diff --git a/ansi-tests/hash-table.lsp b/ansi-tests/hash-table.lsp new file mode 100644 index 0000000..fb6c5fd --- /dev/null +++ b/ansi-tests/hash-table.lsp @@ -0,0 +1,71 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Jan 26 21:30:42 2003 +;;;; Contains: Tests of HASH-TABLE and related interface + +(in-package :cl-test) + +(deftest hash-table.1 + (notnot-mv (find-class 'hash-table)) + t) + +(deftest hash-table.2 + (loop for e in '(nil t 1 10.0 (a b c) #(a b c) #*1011 + #0aNIL #2a((a b)(c d)) #p"foo" + "bar" #\a 3/5 #c(1.0 2.0)) + when (typep e 'hash-table) + collect e) + nil) + +(deftest hash-table.3 + (let ((c (find-class 'hash-table))) + (loop for e in '(nil t 1 10.0 (a b c) #(a b c) #*1011 + #0aNIL #2a((a b)(c d)) #p"foo" + "bar" #\a 3/5 #c(1.0 2.0)) + when (typep e c) + collect e)) + nil) + +(deftest hash-table.4 + (notnot-mv (typep (make-hash-table) 'hash-table)) + t) + +(deftest hash-table.5 + (notnot-mv (typep (make-hash-table) (find-class 'hash-table))) + t) + +;;; + +(deftest hash-table-p.1 + (loop for e in '(nil t 1 10.0 (a b c) #(a b c) #*1011 + #0aNIL #2a((a b)(c d)) #p"foo" + "bar" #\a 3/5 #c(1.0 2.0)) + when (hash-table-p e) + collect e) + nil) + +(deftest hash-table-p.2 + (loop for e in *universe* + for p = (typep e 'hash-table) + for q = (hash-table-p e) + always (if p q (not q))) + t) + +(deftest hash-table-p.3 + (let ((i 0)) + (values (hash-table-p (incf i)) i)) + nil 1) + +(deftest hash-table-p.error.1 + (classify-error (hash-table-p)) + program-error) + +(deftest hash-table-p.error.2 + (classify-error (let ((h (make-hash-table))) (hash-table-p h nil))) + program-error) + + + + + + diff --git a/ansi-tests/identity.lsp b/ansi-tests/identity.lsp new file mode 100644 index 0000000..0ea8f70 --- /dev/null +++ b/ansi-tests/identity.lsp @@ -0,0 +1,34 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Thu Oct 17 23:21:11 2002 +;;;; Contains: Tests for IDENTITY + +(in-package :cl-test) + +(deftest identity.1 + (loop for x in *universe* + always (eqlt x (check-values (identity x)))) + t) + +(deftest identity.2 + (let ((x (ash 1 100))) + (eqlt x (check-values (identity x)))) + t) + +(deftest identity.3 + (let ((x 1.00000001)) + (eqlt x (check-values (identity x)))) + t) + +(deftest identity.order.1 + (let ((i 0)) + (values (identity (incf i)) i)) + 1 1) + +(deftest identity.error.1 + (classify-error (identity)) + program-error) + +(deftest identity.error.2 + (classify-error (identity 'a 'a)) + program-error) diff --git a/ansi-tests/if.lsp b/ansi-tests/if.lsp new file mode 100644 index 0000000..764e287 --- /dev/null +++ b/ansi-tests/if.lsp @@ -0,0 +1,35 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Oct 18 08:21:29 2002 +;;;; Contains: Tests for IF + +(in-package :cl-test) + +(deftest if.1 + (if t 1 2) + 1) + +(deftest if.2 + (if nil 1 2) + 2) + +(deftest if.3 (if t (values) 'a)) + +(deftest if.4 + (if nil 'a) + nil) + +(deftest if.5 + (if t (values 'a 'b 'c) 'd) + a b c) + +(deftest if.6 + (if nil 'a (values 'b 'c 'd)) + b c d) + +(deftest if.7 (if nil 'a (values))) + +(deftest if.order.1 + (let ((i 0)) + (values (if (= (incf i) 1) 't nil) i)) + t 1) diff --git a/ansi-tests/invoke-debugger.lsp b/ansi-tests/invoke-debugger.lsp new file mode 100644 index 0000000..700cf42 --- /dev/null +++ b/ansi-tests/invoke-debugger.lsp @@ -0,0 +1,23 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Feb 28 21:59:57 2003 +;;;; Contains: Tests of INVOKE-DEBUGGER + +(in-package :cl-test) + +;;; We can't test actual entry into the debugger, but we can test +;;; that the function in *debugger-hook* is properly called. + +(deftest invoke-debugger.1 + (block done + (let (fn (cnd (make-condition 'simple-error))) + (setq fn #'(lambda (c hook) + (return-from done + (and (null *debugger-hook*) + (eqt hook fn) + (eqt cnd c) + 'good)))) + (let ((*debugger-hook* fn)) + (invoke-debugger cnd))) + 'bad) + good) diff --git a/ansi-tests/iteration.lsp b/ansi-tests/iteration.lsp new file mode 100644 index 0000000..5b6d13b --- /dev/null +++ b/ansi-tests/iteration.lsp @@ -0,0 +1,494 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Mon Oct 21 22:58:00 2002 +;;;; Contains: Tests for iteration forms other than LOOP + +(in-package :cl-test) + +;;; Confirm that most macros exist + +(defparameter *iteration-macros* + '(do do* dotimes dolist loop)) + +(deftest iteration-macros + (remove-if #'macro-function *iteration-macros*) + nil) + +;;; Tests of DO + +(deftest do.1 + (do ((i 0 (1+ i))) + ((>= i 10) i)) + 10) + +(deftest do.2 + (do ((i 0 (1+ j)) + (j 0 (1+ i))) + ((>= i 10) (+ i j))) + 20) + +(deftest do.3 + (let ((x nil)) + (do ((i 0 (1+ i))) + ((>= i 10) x) + (push i x))) + (9 8 7 6 5 4 3 2 1 0)) + +(deftest do.4 + (let ((x nil)) + (do ((i 0 (1+ i))) + ((>= i 10) x) + (declare (fixnum i)) + (push i x))) + (9 8 7 6 5 4 3 2 1 0)) + +(deftest do.5 + (do ((i 0 (1+ i))) + (nil) + (when (> i 10) (return i))) + 11) + +;;; Zero iterations +(deftest do.6 + (do ((i 0 (+ i 10))) + ((> i -1) i) + (return 'bad)) + 0) + +;;; Tests of go tags +(deftest do.7 + (let ((x nil)) + (do ((i 0 (1+ i))) + ((>= i 10) x) + (go around) + small + (push 'a x) + (go done) + big + (push 'b x) + (go done) + around + (if (> i 4) (go big) (go small)) + done)) + (b b b b b a a a a a)) + +;;; No increment form +(deftest do.8 + (do ((i 0 (1+ i)) + (x nil)) + ((>= i 10) x) + (push 'a x)) + (a a a a a a a a a a)) + +;;; No do locals +(deftest do.9 + (let ((i 0)) + (do () + ((>= i 10) i) + (incf i))) + 10) + +;;; Return of no values +(deftest do.10 + (do ((i 0 (1+ i))) + ((> i 10) (values)))) + +;;; Return of two values +(deftest do.11 + (do ((i 0 (1+ i))) + ((> i 10) (values i (1+ i)))) + 11 12) + +;;; The results* list is an implicit progn +(deftest do.12 + (do ((i 0 (1+ i))) + ((> i 10) (incf i) (incf i) i)) + 13) + +(deftest do.13 + (do ((i 0 (1+ i))) + ((> i 10))) + nil) + +;; Special var +(deftest do.14 + (let ((x 0)) + (flet ((%f () (locally (declare (special i)) + (incf x i)))) + (do ((i 0 (1+ i))) + ((>= i 10) x) + (declare (special i)) + (%f)))) + 45) + +;;; Confirm that the variables in succesive iterations are +;;; identical +(deftest do.15 + (mapcar #'funcall + (let ((x nil)) + (do ((i 0 (1+ i))) + ((= i 5) x) + (push #'(lambda () i) x)))) + (5 5 5 5 5)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;; Tests of DO* + +(deftest do*.1 + (do* ((i 0 (1+ i))) + ((>= i 10) i)) + 10) + +(deftest do*.2 + (do* ((i 0 (1+ j)) + (j 0 (1+ i))) + ((>= i 10) (+ i j))) + 23) + +(deftest do*.3 + (let ((x nil)) + (do* ((i 0 (1+ i))) + ((>= i 10) x) + (push i x))) + (9 8 7 6 5 4 3 2 1 0)) + +(deftest do*.4 + (let ((x nil)) + (do* ((i 0 (1+ i))) + ((>= i 10) x) + (declare (fixnum i)) + (push i x))) + (9 8 7 6 5 4 3 2 1 0)) + +(deftest do*.5 + (do* ((i 0 (1+ i))) + (nil) + (when (> i 10) (return i))) + 11) + +;;; Zero iterations +(deftest do*.6 + (do* ((i 0 (+ i 10))) + ((> i -1) i) + (return 'bad)) + 0) + +;;; Tests of go tags +(deftest do*.7 + (let ((x nil)) + (do* ((i 0 (1+ i))) + ((>= i 10) x) + (go around) + small + (push 'a x) + (go done) + big + (push 'b x) + (go done) + around + (if (> i 4) (go big) (go small)) + done)) + (b b b b b a a a a a)) + +;;; No increment form +(deftest do*.8 + (do* ((i 0 (1+ i)) + (x nil)) + ((>= i 10) x) + (push 'a x)) + (a a a a a a a a a a)) + +;;; No do* locals +(deftest do*.9 + (let ((i 0)) + (do* () + ((>= i 10) i) + (incf i))) + 10) + +;;; Return of no values +(deftest do*.10 + (do* ((i 0 (1+ i))) + ((> i 10) (values)))) + +;;; Return of two values +(deftest do*.11 + (do* ((i 0 (1+ i))) + ((> i 10) (values i (1+ i)))) + 11 12) + +;;; The results* list is an implicit progn +(deftest do*.12 + (do* ((i 0 (1+ i))) + ((> i 10) (incf i) (incf i) i)) + 13) + +(deftest do*.13 + (do* ((i 0 (1+ i))) + ((> i 10))) + nil) + +;; Special var +(deftest do*.14 + (let ((x 0)) + (flet ((%f () (locally (declare (special i)) + (incf x i)))) + (do* ((i 0 (1+ i))) + ((>= i 10) x) + (declare (special i)) + (%f)))) + 45) + +;;; Confirm that the variables in succesive iterations are +;;; identical +(deftest do*.15 + (mapcar #'funcall + (let ((x nil)) + (do* ((i 0 (1+ i))) + ((= i 5) x) + (push #'(lambda () i) x)))) + (5 5 5 5 5)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;; Tests for DOLIST + +(deftest dolist.1 + (let ((count 0)) + (dolist (x '(a b nil d)) (incf count)) + count) + 4) + +(deftest dolist.2 + (let ((count 0)) + (dolist (x '(a nil c d) count) (incf count))) + 4) + +(deftest dolist.3 + (let ((count 0)) + (dolist (x nil count) (incf count))) + 0) + +(deftest dolist.4 + (let ((y nil)) + (flet ((%f () (locally (declare (special e)) + (push e y)))) + (dolist (e '(a b c) (reverse y)) + (declare (special e)) + (%f)))) + (a b c)) + +;;; Tests that it's a tagbody +(deftest dolist.5 + (let ((even nil) + (odd nil)) + (dolist (i '(1 2 3 4 5 6 7 8) (values (reverse even) + (reverse odd))) + (when (evenp i) (go even)) + (push i odd) + (go done) + even + (push i even) + done)) + (2 4 6 8) + (1 3 5 7)) + +;;; Test that bindings are not normally special +(deftest dolist.6 + (let ((i 0) (y nil)) + (declare (special i)) + (flet ((%f () i)) + (dolist (i '(1 2 3 4)) + (push (%f) y))) + y) + (0 0 0 0)) + +;;; Test multiple return values + +(deftest dolist..7 + (dolist (x '(a b) (values)))) + +(deftest dolist.8 + (let ((count 0)) + (dolist (x '(a b c) (values count count)) + (incf count))) + 3 3) + +;;; Test ability to return, and the scope of the implicit +;;; nil block +(deftest dolist.9 + (block nil + (eqlt (dolist (x '(a b c)) + (return 1)) + 1)) + t) + +(deftest dolist.10 + (block nil + (eqlt (dolist (x '(a b c)) + (return-from nil 1)) + 1)) + t) + +(deftest dolist.11 + (block nil + (dolist (x (return 1))) + 2) + 2) + +(deftest dolist.12 + (block nil + (dolist (x '(a b) (return 1))) + 2) + 2) + +;;; Check that binding of element var is visible in the result form +(deftest dolist.13 + (dolist (e '(a b c) e)) + nil) + +(deftest dolist.14 + (let ((e 1)) + (dolist (e '(a b c) (setf e 2))) + e) + 1) + +(deftest dolist.15 + (let ((x nil)) + (dolist (e '(a b c d e f)) + (push e x) + (when (eq e 'c) (return x)))) + (c b a)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Tests for DOTIMES + +(deftest dotimes.1 + (dotimes (i 10)) + nil) + +(deftest dotimes.2 + (dotimes (i 10 'a)) + a) + +(deftest dotimes.3 + (dotimes (i 10 (values)))) + +(deftest dotimes.3a + (dotimes (i 10 (values 'a 'b 'c))) + a b c) + +(deftest dotimes.4 + (let ((x nil)) + (dotimes (i 5 x) (push i x))) + (4 3 2 1 0)) + +(deftest dotimes.5 + (let ((x nil)) + (dotimes (i 0 x) (push i x))) + nil) + +(deftest dotimes.6 + (let ((x nil)) + (dotimes (i -1 x) (push i x))) + nil) + +(deftest dotimes.7 + (let ((x nil)) + (dotimes (i (1- most-negative-fixnum) x) (push i x))) + nil) + +;;; Implicit nil block has the right scope +(deftest dotimes.8 + (block nil + (dotimes (i (return 1))) + 2) + 2) + +(deftest dotimes.9 + (block nil + (dotimes (i 10 (return 1))) + 2) + 2) + +(deftest dotimes.10 + (block nil + (dotimes (i 10) (return 1)) + 2) + 2) + +(deftest dotimes.11 + (let ((x nil)) + (dotimes (i 10) + (push i x) + (when (= i 5) (return x)))) + (5 4 3 2 1 0)) + +;;; Check there's an implicit tagbody +(deftest dotimes.12 + (let ((even nil) + (odd nil)) + (dotimes (i 8 (values (reverse even) + (reverse odd))) + (when (evenp i) (go even)) + (push i odd) + (go done) + even + (push i even) + done)) + (0 2 4 6) + (1 3 5 7)) + +;;; Check that at the time the result form is evaluated, +;;; the index variable is set to the number of times the loop +;;; was executed. + +(deftest dotimes.13 + (let ((i 100)) + (dotimes (i 10 i))) + 10) + +(deftest dotimes.14 + (let ((i 100)) + (dotimes (i 0 i))) + 0) + +(deftest dotimes.15 + (let ((i 100)) + (dotimes (i -1 i))) + 0) + +;;; Check that the variable is not bound in the count form +(deftest dotimes.16 + (let ((i nil)) + (values + i + (dotimes (i (progn (setf i 'a) 10) i)) + i)) + nil 10 a) + +;;; Check special variable decls +(deftest dotimes.17 + (let ((i 0) (y nil)) + (declare (special i)) + (flet ((%f () i)) + (dotimes (i 4) + (push (%f) y))) + y) + (0 0 0 0)) + +(deftest dotimes.18 + (let ((i 0) (y nil)) + (declare (special i)) + (flet ((%f () i)) + (dotimes (i 4) + (declare (special i)) + (push (%f) y))) + y) + (3 2 1 0)) + + + + diff --git a/ansi-tests/labels.lsp b/ansi-tests/labels.lsp new file mode 100644 index 0000000..37f8802 --- /dev/null +++ b/ansi-tests/labels.lsp @@ -0,0 +1,214 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Oct 9 19:06:33 2002 +;;;; Contains: Tests of LABELS + +(in-package :cl-test) + +(deftest labels.1 + (labels ((%f () 1)) + (%f)) + 1) + +(deftest labels.2 + (labels ((%f (x) x)) + (%f 2)) + 2) + +(deftest labels.3 + (labels ((%f (&rest args) args)) + (%f 'a 'b 'c)) + (a b c)) + +;;; The optional arguments are not in the block defined by +;;; the local function declaration +(deftest labels.4 + (block %f + (labels ((%f (&optional (x (return-from %f 10))) + 20)) + (%f))) + 10) + +(deftest labels.5 + (labels ((%f () (return-from %f 15) 35)) + (%f)) + 15) + +;;; The aux parameters are not in the block defined by +;;; the local function declaration +(deftest labels.6 + (block %f + (labels ((%f (&aux (x (return-from %f 10))) + 20)) + (%f))) + 10) + +;;; The function is visible inside itself +(deftest labels.7 + (labels ((%f (x n) (cond ((eql n 0) x) + (t (%f (+ x n) (1- n)))))) + (%f 0 10)) + 55) + +;;; Keyword arguments +(deftest labels.8 + (labels ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) + (%f)) + nil 0 nil) + +(deftest labels.9 + (labels ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) + (%f :a 1)) + 1 0 nil) + +(deftest labels.10 + (labels ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) + (%f :b 2)) + nil 2 t) + +(deftest labels.11 + (labels ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) + (%f :b 2 :a 3)) + 3 2 t) + +;;; Unknown keyword parameter should throw a program-error in safe code +;;; (section 3.5.1.4) +(deftest labels.12 + (classify-error + (labels ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :c 4))) + program-error) + +;;; Odd # of keyword args should throw a program-error in safe code +;;; (section 3.5.1.6) +(deftest labels.13 + (classify-error + (labels ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :a))) + program-error) + +;;; Too few arguments (section 3.5.1.2) +(deftest labels.14 + (classify-error (labels ((%f (a) a)) (%f))) + program-error) + +;;; Too many arguments (section 3.5.1.3) +(deftest labels.15 + (classify-error (labels ((%f (a) a)) (%f 1 2))) + program-error) + +;;; Invalid keyword argument (section 3.5.1.5) +(deftest labels.16 + (classify-error (labels ((%f (&key a) a)) (%f '(foo)))) + program-error) + + +;;; Definition of a (setf ...) function + +(deftest labels.17 + (labels (((setf %f) (x y) (setf (car y) x))) + (let ((z (list 1 2))) + (setf (%f z) 'a) + z)) + (a 2)) + +;;; Scope of defined function names includes &AUX parameters + +(deftest labels.7b + (labels ((%f (x &aux (b (%g x))) b) + (%g (y) (+ y y))) + (%f 10)) + 20) + +;;; Body is an implicit progn +(deftest labels.18 + (labels ((%f (x) (incf x) (+ x x))) + (%f 10)) + 22) + +;;; Can handle at least 50 lambda parameters +(deftest labels.19 + (labels ((%f (a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 + b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 + c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 + d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 + e1 e2 e3 e4 e5 e6 e7 e8 e9 e10) + (+ a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 + b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 + c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 + d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 + e1 e2 e3 e4 e5 e6 e7 e8 e9 e10))) + (%f 1 2 3 4 5 6 7 8 9 10 + 11 12 13 14 15 16 17 18 19 20 + 21 22 23 24 25 26 27 28 29 30 + 31 32 33 34 35 36 37 38 39 40 + 41 42 43 44 45 46 47 48 49 50)) + 1275) + +;;; labels works with the maximum number of arguments (if +;;; not too many.) +(deftest labels.20 + (let* ((n (min lambda-parameters-limit 1024)) + (vars (loop for i from 1 to n collect (gensym)))) + (eval + `(eql ,n + (labels ((%f ,vars (+ ,@ vars))) + (%f ,@(loop for e in vars collect 1)))))) + t) + +;;; Declarations and documentation strings are ok +(deftest labels.21 + (labels ((%f (x) + (declare (type fixnum x)) + "Add one to the fixnum x." + (1+ x))) + (declare (ftype (function (fixnum) integer) %f)) + (%f 10)) + 11) + +;;; Keywords can be function names +(deftest labels.22 + (labels ((:foo () 10) + (:bar () (1+ (:foo)))) + (:bar)) + 11) + +(deftest labels.23 + (labels ((:foo () 10) + (:bar () (1+ (funcall #':foo)))) + (funcall #':bar)) + 11) + +(deftest labels.24 + (loop for s in *cl-non-function-macro-special-operator-symbols* + for form = `(classify-error (labels ((,s (x) (foo (1- x))) + (foo (y) + (if (<= y 0) 'a + (,s (1- y))))) + (,s 10))) + unless (eq (eval form) 'a) + collect s) + nil) + +(deftest labels.25 + (loop for s in *cl-non-function-macro-special-operator-symbols* + for form = `(classify-error + (labels ((,s (x) (foo (1- x))) + (foo (y) + (if (<= y 0) 'a + (,s (1- y))))) + (declare (ftype (function (integer) symbol) + foo ,s)) + (,s 10))) + unless (eq (eval form) 'a) + collect s) + nil) + +(deftest labels.26 + (loop for s in *cl-non-function-macro-special-operator-symbols* + for form = `(classify-error + (labels (((setf ,s) (&rest args) + (declare (ignore args)) + 'a)) + (setf (,s) 10))) + unless (eq (eval form) 'a) + collect s) + nil) diff --git a/ansi-tests/lambda-list-keywords.lsp b/ansi-tests/lambda-list-keywords.lsp new file mode 100644 index 0000000..856727d --- /dev/null +++ b/ansi-tests/lambda-list-keywords.lsp @@ -0,0 +1,39 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Mon Oct 7 22:11:31 2002 +;;;; Contains: Tests for LAMBDA-LIST-KEYWORDS + +(in-package :cl-test) + +;;; The variable is bound +(deftest lambda-list-keywords.1 + (not-mv (boundp 'lambda-list-keywords)) + nil) + +;;; The variable is a constant +(deftest lambda-list-keywords.2 + (not-mv (constantp 'lambda-list-keywords)) + nil) + +;;; The standard keywords are present in the list +(deftest lambda-list-keywords.3 + (and (consp lambda-list-keywords) + (not-mv (set-difference '(&allow-other-keys + &aux &body &environment + &key &optional &rest &whole) + lambda-list-keywords))) + t) + +;;; No lambda list keywords are in the keyword package +(deftest lambda-list-keywords.4 + (some #'keywordp lambda-list-keywords) + nil) + +;;; Every keyword starts with an ampersand +(deftest lambda-list-keywords.5 + (notevery #'(lambda (sym) + (let ((name (symbol-name sym))) + (and (> (length name) 0) + (eql (aref name 0) #\&)))) + lambda-list-keywords) + nil) diff --git a/ansi-tests/lambda-parameters-limit.lsp b/ansi-tests/lambda-parameters-limit.lsp new file mode 100644 index 0000000..c886cf1 --- /dev/null +++ b/ansi-tests/lambda-parameters-limit.lsp @@ -0,0 +1,17 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Thu Oct 10 22:45:44 2002 +;;;; Contains: Tests for LAMBDA-PARAMETERS-LIMIT + +(in-package :cl-test) + +(deftest lambda-parameters-limit.1 + (not (typep lambda-parameters-limit 'integer)) + nil) + +(deftest lambda-parameters-limit.2 + (< lambda-parameters-limit 50) + nil) + +;;; See also tests is flet.lsp, labels.lsp + diff --git a/ansi-tests/lambda.lsp b/ansi-tests/lambda.lsp new file mode 100644 index 0000000..d3751a8 --- /dev/null +++ b/ansi-tests/lambda.lsp @@ -0,0 +1,60 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Nov 27 06:43:21 2002 +;;;; Contains: Tests of LAMBDA forms + +(in-package :cl-test) + +(deftest lambda.1 + ((lambda (x) x) 'a) + a) + +(deftest lambda.2 + ((lambda () 'a)) + a) + +(deftest lambda.3 + ((lambda () "documentation" 'a)) + a) + +(deftest lambda.4 + ((lambda (x) (declare (type symbol x)) x) 'z) + z) + +(deftest lambda.5 + ((lambda (&aux (x 'a)) x)) + a) + +(deftest lambda.6 + ((lambda (&aux (x 'a)) (declare (type symbol x)) x)) + a) + +(deftest lambda.7 + ((lambda () "foo")) + "foo") + +(deftest lambda.8 + ((lambda () "foo" "bar")) + "bar") + +(deftest lambda.9 + ((lambda (x y) (declare (ignore x)) "foo" (declare (ignore y)) "bar") 1 2) + "bar") + +(deftest lambda.10 + ((lambda (x) (declare (type symbol x))) 'z) + nil) + +;;; Should test lambda argument lists more fully here + +;;; Tests of lambda as a macro + +(deftest lambda.macro.1 + (notnot (macro-function 'lambda)) + t) + +(deftest lambda.macro.2 + (funcall (eval (macroexpand '(lambda () 10)))) + 10) + + \ No newline at end of file diff --git a/ansi-tests/length.lsp b/ansi-tests/length.lsp new file mode 100644 index 0000000000000000000000000000000000000000..79aab2dad52374b917f84fc851513fa657fb29b6 GIT binary patch literal 2452 zcmb7FOLN*V5bl{@u|p2X%s9m+Neel3+Dv;$J3VmBMHm4}gyc$c8~W?JdIaoZO^7%k zOZ)ovTkYQF;~c)L6`O-w_uSNgM}u2j@Tsv|rQOX>+6ef5A(iAU`F365PG4I&{ z!sV6YHiX#7c7XX+zErC{5a$E~wLr)-etA82qEziY_zZAZYqf(3SOv4$3|1=Kky@*b z40}{+q+rGXVZX!y{Bs681EQI2wDhTP9{nP9W46HIIXZcH#!7w=vbkT?U#6`sKYJQM&?o$yG>fU!^a(HCA)E=@K_i@phE&P&Y=>5OYsfj|v^~#+aVh z6guRMCx!btt(zV= i 4) (return x)) + (incf i) + (push 'a x))) + (a a a a)) + +(deftest sloop.6 + (let ((i 0) (x nil)) + (block foo + (tagbody + (loop + (when (>= i 4) (go a)) + (incf i) + (push 'a x)) + a + (return-from foo x)))) + (a a a a)) + +(deftest sloop.7 + (catch 'foo + (let ((i 0) (x nil)) + (loop + (when (>= i 4) (throw 'foo x)) + (incf i) + (push 'a x)))) + (a a a a)) diff --git a/ansi-tests/loop1.lsp b/ansi-tests/loop1.lsp new file mode 100644 index 0000000..37f9c75 --- /dev/null +++ b/ansi-tests/loop1.lsp @@ -0,0 +1,227 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Oct 25 19:07:19 2002 +;;;; Contains: Tests of extended loop, part 1 + +(in-package :cl-test) + +;;; Tests of variable initialization and stepping clauses + +;;; for-as-arithmetic + +(deftest loop.1.1 + (loop for x from 1 to 10 collect x) + (1 2 3 4 5 6 7 8 9 10)) + +(deftest loop.1.2 + (loop for x from 6 downto 1 collect x) + (6 5 4 3 2 1)) + +(deftest loop.1.3 + (loop for x from 1 to 1 collect x) + (1)) + +(deftest loop.1.4 + (loop for x from 1 to 0 collect x) + nil) + +(deftest loop.1.5 + (loop for x to 5 collect x) + (0 1 2 3 4 5)) + +(deftest loop.1.6 + (loop for x downfrom 5 to 0 collect x) + (5 4 3 2 1 0)) + +(deftest loop.1.7 + (loop for x upfrom 1 to 5 collect x) + (1 2 3 4 5)) + +(deftest loop.1.8 + (loop for x from 1.0 to 5.0 count x) + 5) + +(deftest loop.1.9 + (loop for x from 1 to 9 by 2 collect x) + (1 3 5 7 9)) + +(deftest loop.1.10 + (loop for x from 1 to 10 by 2 collect x) + (1 3 5 7 9)) + +(deftest loop.1.11 + (loop for x to 10 from 1 collect x) + (1 2 3 4 5 6 7 8 9 10)) + +(deftest loop.1.12 + (loop for x to 10 by 2 from 1 collect x) + (1 3 5 7 9)) + +(deftest loop.1.13 + (loop for x by 2 to 10 from 1 collect x) + (1 3 5 7 9)) + +(deftest loop.1.14 + (loop for x by 2 to 10 collect x) + (0 2 4 6 8 10)) + +(deftest loop.1.15 + (loop for x to 10 by 2 collect x) + (0 2 4 6 8 10)) + +(deftest loop.1.16 + (let ((n 0)) + (loop for x from (incf n) to (+ n 5) collect x)) + (1 2 3 4 5 6)) + +(deftest loop.1.17 + (let ((n 0)) + (loop for x to (+ n 5) from (incf n) collect x)) + (1 2 3 4 5)) + +(deftest loop.1.18 + (let ((n 0)) + (loop for x from (incf n) to (+ n 9) by (incf n) collect x)) + (1 3 5 7 9)) + +(deftest loop.1.19 + (let ((n 0)) + (loop for x from (incf n) by (incf n) to (+ n 9) collect x)) + (1 3 5 7 9 11)) + +(deftest loop.1.20 + (let ((a 0) (b 5) (c 1)) + (loop for x from a to b by c + collect (progn (incf a) (incf b 2) (incf c 3) x))) + (0 1 2 3 4 5)) + +(deftest loop.1.21 + (loop for x from 0 to 5 by 1/2 collect x) + (0 1/2 1 3/2 2 5/2 3 7/2 4 9/2 5)) + +(deftest loop.1.22 + (loop for x from 1 below 5 collect x) + (1 2 3 4)) + +(deftest loop.1.23 + (loop for x from 1 below 5.01 collect x) + (1 2 3 4 5)) + +(deftest loop.1.24 + (loop for x below 5 from 2 collect x) + (2 3 4)) + +(deftest loop.1.25 + (loop for x from 10 above 4 collect x) + (10 9 8 7 6 5)) + +(deftest loop.1.26 + (loop for x from 14 above 6 by 2 collect x) + (14 12 10 8)) + +(deftest loop.1.27 + (loop for x above 6 from 14 by 2 collect x) + (14 12 10 8)) + +(deftest loop.1.28 + (loop for x downfrom 16 above 7 by 3 collect x) + (16 13 10)) + +(deftest loop.1.29 + (let (a b c (i 0)) + (values + (loop for x from (progn (setq a (incf i)) 0) + below (progn (setq b (incf i)) 9) + by (progn (setq c (incf i)) 2) + collect x) + a b c i)) + (0 2 4 6 8) + 1 2 3 3) + +(deftest loop.1.30 + (let (a b c (i 0)) + (values + (loop for x from (progn (setq a (incf i)) 0) + by (progn (setq c (incf i)) 2) + below (progn (setq b (incf i)) 9) + collect x) + a b c i)) + (0 2 4 6 8) + 1 3 2 3) + +(deftest loop.1.31 + (let (a b c (i 0)) + (values + (loop for x + below (progn (setq b (incf i)) 9) + by (progn (setq c (incf i)) 2) + from (progn (setq a (incf i)) 0) + collect x) + a b c i)) + (0 2 4 6 8) + 3 1 2 3) + +(deftest loop.1.32 + (let (a b c (i 0)) + (values + (loop for x + by (progn (setq c (incf i)) 2) + below (progn (setq b (incf i)) 9) + from (progn (setq a (incf i)) 0) + collect x) + a b c i)) + (0 2 4 6 8) + 3 2 1 3) + +(deftest loop.1.33 + (loop for x from 1 upto 5 collect x) + (1 2 3 4 5)) + +(deftest loop.1.34 + (loop for x from 1 to 4.0 collect x) + (1 2 3 4)) + +(deftest loop.1.35 + (loop for x below 5 collect x) + (0 1 2 3 4)) + +(deftest loop.1.36 + (loop for x below 20 by 3 collect x) + (0 3 6 9 12 15 18)) + +(deftest loop.1.37 + (loop for x by 3 below 20 collect x) + (0 3 6 9 12 15 18)) + +(deftest loop.1.38 + (loop for x of-type fixnum from 1 to 5 collect x) + (1 2 3 4 5)) + +#| +;;; The following provides an example where an incorrect +;;; implementation will assign X an out-of-range value +;;; at the end. +(deftest loop.1.39 + (loop for x of-type (integer 1 5) from 1 to 5 collect x) + (1 2 3 4 5)) + +;;; Test that the index variable achieves the inclusive +;;; upper bound, but does not exceed it. +(deftest loop.1.40 + (loop for x from 1 to 5 do nil finally (return x)) + 5) + +;;; Test that the index variable acheives the exclusive +;;; upper bound, but does not exceed it. +(deftest loop.1.41 + (loop for x from 1 below 5 do nil finally (return x)) + 4) + +(deftest loop.1.42 + (loop for x from 10 downto 0 do nil finally (return x)) + 0) + +(deftest loop.1.43 + (loop for x from 10 above 0 do nil finally (return x)) + 1) +|# \ No newline at end of file diff --git a/ansi-tests/loop10.lsp b/ansi-tests/loop10.lsp new file mode 100644 index 0000000..c34ea30 --- /dev/null +++ b/ansi-tests/loop10.lsp @@ -0,0 +1,450 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Nov 16 09:07:02 2002 +;;;; Contains: Tests of LOOP numeric value accumulation clauses + +(in-package :cl-test) + +;; Tests of COUNT, COUNTING + +(deftest loop.10.1 + (loop for x from 1 to 10 count (< x 5)) + 4) + +(deftest loop.10.2 + (loop for x from 1 to 10 counting (< x 7)) + 6) + +(deftest loop.10.3 + (loop for x from 1 to 10 count (< x 5) fixnum) + 4) + +(deftest loop.10.4 + (loop for x from 1 to 10 count (< x 5) of-type integer) + 4) + +(deftest loop.10.5 + (let (z) + (values + (loop for x from 1 to 10 count (< x 5) into foo + finally (setq z foo)) + z)) + nil + 4) + +(deftest loop.10.6 + (let (z) + (values + (loop for x from 1 to 10 count (< x 5) into foo fixnum + finally (setq z foo)) + z)) + nil + 4) + +(deftest loop.10.7 + (let (z) + (values + (loop for x from 1 to 10 count (< x 5) into foo of-type (integer 0 100) + finally (setq z foo)) + z)) + nil + 4) + +(deftest loop.10.8 + (let (z) + (values + (loop for x from 1 to 10 count (< x 5) into foo float + finally (setq z foo)) + z)) + nil + 4.0) + +(deftest loop.10.9 + (classify-error + (loop with foo = 10 + for x in '(a b c) count x into foo + finally (return foo))) + program-error) + +(deftest loop.10.10 + (classify-error + (loop with foo = 10 + for x in '(a b c) counting x into foo + finally (return foo))) + program-error) + +(declaim (special *loop-count-var*)) + +(deftest loop.10.11 + (let ((*loop-count-var* 100)) + (values + (loop for x in '(a b c d) count x into *loop-count-var* + finally (return *loop-count-var*)) + *loop-count-var*)) + 4 100) + +(deftest loop.10.12 + (loop for x in '(a b nil d nil e) + count x into foo + collect foo) + (1 2 2 3 3 4)) + +(deftest loop.10.13 + (loop for x in '(a b nil d nil e) + counting x into foo + collect foo) + (1 2 2 3 3 4)) + +(deftest loop.10.14 + (loop for x in '(a b c) count (return 10)) + 10) + + +;;; Tests of MAXIMIZE, MAXIMIZING + +(deftest loop.10.20 + (loop for x in '(1 4 10 5 7 9) maximize x) + 10) + +(deftest loop.10.21 + (loop for x in '(1 4 10 5 7 9) maximizing x) + 10) + +(deftest loop.10.22 + (loop for x in '(1000000000000) maximizing x) + 1000000000000) + +(deftest loop.10.23 + (loop for x in '(-1000000000000) maximize x) + -1000000000000) + +(deftest loop.10.24 + (loop for x in '(1.0 2.0 3.0 -1.0) maximize x) + 3.0) + +(deftest loop.10.25 + (loop for x in '(8 20 5 3 24 1 19 4 20 3) maximize x fixnum) + 24) + +(deftest loop.10.26 + (loop for x in '(8 20 5 3 24 1 19 4 20 3) maximize x of-type integer) + 24) + +(deftest loop.10.27 + (loop for x in '(8 20 5 3 24 1 19 4 20 3) maximize x of-type rational) + 24) + +(deftest loop.10.28 + (loop for x in '(1 4 10 5 7 9) maximize x into foo finally (return foo)) + 10) + +(deftest loop.10.29 + (let (z) + (values + (loop for x in '(1 4 10 5 7 9) maximize x into foo finally (setq z foo)) + z)) + nil + 10) + +(deftest loop.10.30 + (loop for x in '(8 20 5 3 24 1 19 4 20 3) maximize x of-type real) + 24) + +(deftest loop.10.31 + (loop for x in '(0.08 0.20 0.05 0.03 0.24 0.01 0.19 0.04 0.20 0.03) maximize x of-type float) + 0.24) + +(deftest loop.10.32 + (loop for x in '(-1/8 -1/20 -1/5 -1/3 -1/24 -1/1 -1/19 -1/4 -1/20 -1/3) maximize x of-type rational) + -1/24) + +(deftest loop.10.33 + (loop for x in '(1 4 10 5 7 9) maximize x into foo fixnum finally (return foo)) + 10) + +(deftest loop.10.34 + (loop for x in '(1 4 10 5 7 9) maximize x into foo of-type integer finally (return foo)) + 10) + +(deftest loop.10.35 + (let ((foo 20)) + (values + (loop for x in '(3 5 8 3 7) maximize x into foo finally (return foo)) + foo)) + 8 20) + +(declaim (special *loop-max-var*)) + +(deftest loop.10.36 + (let ((*loop-max-var* 100)) + (values + (loop for x in '(1 10 4 8) maximize x into *loop-max-var* + finally (return *loop-max-var*)) + *loop-max-var*)) + 10 100) + +(deftest loop.10.37 + (classify-error + (loop with foo = 100 + for i from 1 to 10 maximize i into foo + finally (return foo))) + program-error) + +(deftest loop.10.38 + (classify-error + (loop with foo = 100 + for i from 1 to 10 maximizing i into foo + finally (return foo))) + program-error) + + +(deftest loop.10.39 + (loop for x in '(1 2 3) maximize (return 10)) + 10) + +;;; Tests of MINIMIZE, MINIMIZING + +(deftest loop.10.40 + (loop for x in '(4 10 1 5 7 9) minimize x) + 1) + +(deftest loop.10.41 + (loop for x in '(4 10 5 7 1 9) minimizing x) + 1) + +(deftest loop.10.42 + (loop for x in '(1000000000000) minimizing x) + 1000000000000) + +(deftest loop.10.43 + (loop for x in '(-1000000000000) minimize x) + -1000000000000) + +(deftest loop.10.44 + (loop for x in '(1.0 2.0 -1.0 3.0) minimize x) + -1.0) + +(deftest loop.10.45 + (loop for x in '(8 20 5 3 24 1 19 4 20 3) minimize x fixnum) + 1) + +(deftest loop.10.46 + (loop for x in '(8 20 5 3 24 1 19 4 20 3) minimize x of-type integer) + 1) + +(deftest loop.10.47 + (loop for x in '(8 20 5 3 24 1 19 4 20 3) minimize x of-type rational) + 1) + +(deftest loop.10.48 + (loop for x in '(1 4 10 5 7 9) minimize x into foo finally (return foo)) + 1) + +(deftest loop.10.49 + (let (z) + (values + (loop for x in '(4 1 10 1 5 7 9) minimize x into foo finally (setq z foo)) + z)) + nil + 1) + +(deftest loop.10.50 + (loop for x in '(8 20 5 3 24 1 19 4 20 3) minimize x of-type real) + 1) + +(deftest loop.10.51 + (loop for x in '(0.08 0.40 0.05 0.03 0.44 0.01 0.19 0.04 0.40 0.03) minimize x of-type float) + 0.01) + +(deftest loop.10.52 + (loop for x in '(-1/8 -1/20 -1/5 -1/3 -1/24 -1/1 -1/19 -1/4 -1/20 -1/3) minimize x of-type rational) + -1/1) + +(deftest loop.10.53 + (loop for x in '(4 10 5 1 7 9) minimize x into foo fixnum finally (return foo)) + 1) + +(deftest loop.10.54 + (loop for x in '(1 4 10 5 7 9) minimize x into foo of-type integer finally (return foo)) + 1) + +(deftest loop.10.55 + (let ((foo 20)) + (values + (loop for x in '(4 5 8 3 7) minimize x into foo finally (return foo)) + foo)) + 3 20) + +(declaim (special *loop-min-var*)) + +(deftest loop.10.56 + (let ((*loop-min-var* 100)) + (values + (loop for x in '(10 4 8) minimize x into *loop-min-var* + finally (return *loop-min-var*)) + *loop-min-var*)) + 4 100) + +(deftest loop.10.57 + (classify-error + (loop with foo = 100 + for i from 1 to 10 minimize i into foo + finally (return foo))) + program-error) + +(deftest loop.10.58 + (classify-error + (loop with foo = 100 + for i from 1 to 10 minimizing i into foo + finally (return foo))) + program-error) + +(deftest loop.10.58a + (loop for x in '(1 2 3) minimize (return 10)) + 10) + +;;; Tests combining MINIMIZE, MAXIMIZE + +(deftest loop.10.59 + (loop for i from 1 to 10 + minimize i + maximize (- i)) + 1) + +(deftest loop.10.60 + (loop for i from 1 to 10 + maximize (- i) + minimize i) + -1) + +(deftest loop.10.61 + (loop for i from 5 downto 1 + maximize i + minimize (- i)) + -1) + + +;;; Tests for SUM, SUMMING + +(deftest loop.10.70 + (loop for i from 1 to 4 sum i) + 10) + +(deftest loop.10.71 + (loop for i from 1 to 4 summing i) + 10) + +(deftest loop.10.72 + (loop for i from 1 to 4 sum (float i)) + 10.0) + +(deftest loop.10.73 + (loop for i from 1 to 4 sum (complex i i)) + #c(10 10)) + +(deftest loop.10.74 + (loop for i from 1 to 4 sum i fixnum) + 10) + +(deftest loop.10.75 + (loop for i from 1 to 4 sum i of-type integer) + 10) + +(deftest loop.10.76 + (loop for i from 1 to 4 sum i of-type rational) + 10) + +(deftest loop.10.77 + (loop for i from 1 to 4 sum (float i) float) + 10.0) + +(deftest loop.10.78 + (loop for i from 1 to 4 sum i of-type number) + 10) + +(deftest loop.10.79 + (loop for i from 1 to 4 sum i into foo finally (return foo)) + 10) + +(deftest loop.10.80 + (loop for i from 1 to 4 sum i into foo fixnum finally (return foo)) + 10) + +(deftest loop.10.81 + (let (z) + (values + (loop for i from 1 to 4 sum i into foo of-type (integer 0 10) + finally (setq z foo)) + z)) + nil + 10) + +(deftest loop.10.82 + (loop for i from 1 to 4 + sum i fixnum + count t) + 14) + +(deftest loop.10.83 + (loop for i from 1 to 4 + sum i fixnum + count t fixnum) + 14) + +(deftest loop.10.84 + (let ((foo 100)) + (values + (loop for i from 1 to 4 sum i into foo of-type integer + finally (return foo)) + foo)) + 10 100) + +(deftest loop.10.85 + (classify-error + (loop with foo = 100 + for i from 1 to 4 sum i into foo + finally (return foo))) + program-error) + +(deftest loop.10.86 + (classify-error + (loop with foo = 100 + for i from 1 to 4 summing i into foo + finally (return foo))) + program-error) + +(deftest loop.10.87 + (loop for i from 1 to 4 + sum (complex i (1+ i)) of-type complex) + #c(10 14)) + +(deftest loop.10.88 + (loop for i from 1 to 4 + sum (/ i 17) of-type rational) + 10/17) + +(deftest loop.10.89 + (loop for i from 1 to 4 summing (/ i 17)) + 10/17) + +(deftest loop.10.90 + (loop for i from 1 to 4 + sum i into foo + sum (1+ i) into bar + finally (return (values foo bar))) + 10 14) + +(deftest loop.10.91 + (loop for i from 1 to 4 + sum i into foo fixnum + sum (float (1+ i)) into bar float + finally (return (values foo bar))) + 10 14.0) + +(deftest loop.10.92 + (loop for i from 1 to 4 sum (return 100)) + 100) + +(deftest loop.10.93 + (loop for i from 1 to 4 summing (return 100)) + 100) diff --git a/ansi-tests/loop11.lsp b/ansi-tests/loop11.lsp new file mode 100644 index 0000000..3ff8f31 --- /dev/null +++ b/ansi-tests/loop11.lsp @@ -0,0 +1,165 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Nov 16 21:39:33 2002 +;;;; Contains: Tests for loop termination clauses REPEAT, WHILE and UNTIL + +(in-package :cl-test) + +;;; Tests of REPEAT + +(deftest loop.11.1 + (let ((z 0)) + (values + (loop repeat 10 do (incf z)) + z)) + nil + 10) + +(deftest loop.11.2 + (loop repeat 10 collect 'a) + (a a a a a a a a a a)) + +(deftest loop.11.3 + (let ((z 0)) + (loop repeat 0 do (incf z)) + z) + 0) + +(deftest loop.11.4 + (let ((z 0)) + (loop repeat -1 do (incf z)) + z) + 0) + +(deftest loop.11.5 + (let ((z 0)) + (loop repeat -1.5 do (incf z)) + z) + 0) + +(deftest loop.11.6 + (let ((z 0)) + (loop repeat -1000000000000 do (incf z)) + z) + 0) + +(deftest loop.11.7 + (let ((z 0)) + (loop repeat 10 do (incf z) (loop-finish)) + z) + 1) + +(deftest loop.11.8 + (loop repeat 3 for i in '(a b c d e) collect i) + (a b c)) + +(deftest loop.11.9 + (loop for i in '(a b c d e) collect i repeat 3) + (a b c)) + + +;;; Tests of WHILE + +(deftest loop.11.10 + (loop with i = 0 while (< i 10) collect (incf i)) + (1 2 3 4 5 6 7 8 9 10)) + +(deftest loop.11.11 + (loop with i = 0 while (if (< i 10) t (return 'good)) + collect (incf i)) + good) + +(deftest loop.11.12 + (loop with i = 0 + while (< i 10) collect (incf i) + while (< i 10) collect (incf i) + while (< i 10) collect (incf i)) + (1 2 3 4 5 6 7 8 9 10)) + +(deftest loop.11.13 + (loop with i = 0 while (< i 10) collect (incf i) + finally (return 'done)) + done) + +(deftest loop.11.14 + (loop for i in '(a b c) + while nil + collect i) + nil) + +(deftest loop.11.15 + (loop for i in '(a b c) + collect i + while nil) + (a)) + +(deftest loop.11.16 + (loop for i in '(a b c) + while t + collect i) + (a b c)) + +(deftest loop.11.17 + (loop for i in '(a b c) + collect i + while t) + (a b c)) + +(deftest loop.11.18 + (loop for i from 1 to 10 + while (< i 6) + finally (return i)) + 6) + +;;; Tests of UNTIL + +(deftest loop.11.20 + (loop with i = 0 until (>= i 10) collect (incf i)) + (1 2 3 4 5 6 7 8 9 10)) + +(deftest loop.11.21 + (loop with i = 0 while (if (< i 10) t (return 'good)) + collect (incf i)) + good) + +(deftest loop.11.22 + (loop with i = 0 + until (>= i 10) collect (incf i) + until (>= i 10) collect (incf i) + until (>= i 10) collect (incf i)) + (1 2 3 4 5 6 7 8 9 10)) + +(deftest loop.11.23 + (loop with i = 0 until (>= i 10) collect (incf i) + finally (return 'done)) + done) + +(deftest loop.11.24 + (loop for i in '(a b c) + until t + collect i) + nil) + +(deftest loop.11.25 + (loop for i in '(a b c) + collect i + until t) + (a)) + +(deftest loop.11.26 + (loop for i in '(a b c) + until nil + collect i) + (a b c)) + +(deftest loop.11.27 + (loop for i in '(a b c) + collect i + until nil) + (a b c)) + +(deftest loop.11.28 + (loop for i from 1 to 10 + until (>= i 6) + finally (return i)) + 6) diff --git a/ansi-tests/loop12.lsp b/ansi-tests/loop12.lsp new file mode 100644 index 0000000..edc3f61 --- /dev/null +++ b/ansi-tests/loop12.lsp @@ -0,0 +1,234 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Nov 17 08:47:43 2002 +;;;; Contains: Tests for ALWAYS, NEVER, THEREIS + +(in-package :cl-test) + +;;; Tests of ALWAYS clauses + +(deftest loop.12.1 + (loop for i in '(1 2 3 4) always (< i 10)) + t) + +(deftest loop.12.2 + (loop for i in nil always nil) + t) + +(deftest loop.12.3 + (loop for i in '(a) always nil) + nil) + +(deftest loop.12.4 + (loop for i in '(1 2 3 4 5 6 7) + always t + until (> i 5)) + t) + +(deftest loop.12.5 + (loop for i in '(1 2 3 4 5 6 7) + always (< i 6) + until (>= i 5)) + t) + +(deftest loop.12.6 + (loop for x in '(a b c d e) always x) + t) + +(deftest loop.12.7 + (loop for x in '(1 2 3 4 5 6) + always (< x 20) + never (> x 10)) + t) + +(deftest loop.12.8 + (loop for x in '(1 2 3 4 5 6) + always (< x 20) + never (> x 5)) + nil) + +(deftest loop.12.9 + (loop for x in '(1 2 3 4 5 6) + never (> x 5) + always (< x 20)) + nil) + +(deftest loop.12.10 + (loop for x in '(1 2 3 4 5) + always (< x 10) + finally (return 'good)) + good) + +(deftest loop.12.11 + (loop for x in '(1 2 3 4 5) + always (< x 3) + finally (return 'bad)) + nil) + +(deftest loop.12.12 + (loop for x in '(1 2 3 4 5 6) + always t + when (= x 4) do (loop-finish)) + t) + +(deftest loop.12.13 + (loop for x in '(1 2 3 4 5 6) + do (loop-finish) + always nil) + t) + +;;; Tests of NEVER + +(deftest loop.12.21 + (loop for i in '(1 2 3 4) never (> i 10)) + t) + +(deftest loop.12.22 + (loop for i in nil never t) + t) + +(deftest loop.12.23 + (loop for i in '(a) never t) + nil) + +(deftest loop.12.24 + (loop for i in '(1 2 3 4 5 6 7) + never nil + until (> i 5)) + t) + +(deftest loop.12.25 + (loop for i in '(1 2 3 4 5 6 7) + never (>= i 6) + until (>= i 5)) + t) + +(deftest loop.12.26 + (loop for x in '(a b c d e) never (not x)) + t) + +(deftest loop.12.30 + (loop for x in '(1 2 3 4 5) + never (>= x 10) + finally (return 'good)) + good) + +(deftest loop.12.31 + (loop for x in '(1 2 3 4 5) + never (>= x 3) + finally (return 'bad)) + nil) + +(deftest loop.12.32 + (loop for x in '(1 2 3 4 5 6) + never nil + when (= x 4) do (loop-finish)) + t) + +(deftest loop.12.33 + (loop for x in '(1 2 3 4 5 6) + do (loop-finish) + never t) + t) + +;;; Tests of THEREIS + +(deftest loop.12.41 + (loop for x in '(1 2 3 4 5) + thereis (and (eqlt x 3) 'good)) + good) + +(deftest loop.12.42 + (loop for x in '(nil nil a nil nil) + thereis x) + a) + +(deftest loop.12.43 + (loop for x in '(1 2 3 4 5) + thereis (eql x 4) + when (eql x 2) do (loop-finish)) + nil) + +;;; Error cases + +(deftest loop.12.error.50 + (classify-error + (loop for i from 1 to 10 + collect i + always (< i 20))) + program-error) + +(deftest loop.12.error.50a + (classify-error + (loop for i from 1 to 10 + always (< i 20) + collect i)) + program-error) + +(deftest loop.12.error.51 + (classify-error + (loop for i from 1 to 10 + collect i + never (> i 20))) + program-error) + +(deftest loop.12.error.51a + (classify-error + (loop for i from 1 to 10 + never (> i 20) + collect i)) + program-error) + +(deftest loop.12.error.52 + (classify-error + (loop for i from 1 to 10 + collect i + thereis (> i 20))) + program-error) + +(deftest loop.12.error.52a + (classify-error + (loop for i from 1 to 10 + thereis (> i 20) + collect i)) + program-error) + +;;; Non-error cases + +(deftest loop.12.53 + (loop for i from 1 to 10 + collect i into foo + always (< i 20)) + t) + +(deftest loop.12.53a + (loop for i from 1 to 10 + always (< i 20) + collect i into foo) + t) + +(deftest loop.12.54 + (loop for i from 1 to 10 + collect i into foo + never (> i 20)) + t) + +(deftest loop.12.54a + (loop for i from 1 to 10 + never (> i 20) + collect i into foo) + t) + +(deftest loop.12.55 + (loop for i from 1 to 10 + collect i into foo + thereis i) + 1) + +(deftest loop.12.55a + (loop for i from 1 to 10 + thereis i + collect i into foo) + 1) + + diff --git a/ansi-tests/loop13.lsp b/ansi-tests/loop13.lsp new file mode 100644 index 0000000..f8e65c2 --- /dev/null +++ b/ansi-tests/loop13.lsp @@ -0,0 +1,433 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Nov 17 12:37:45 2002 +;;;; Contains: Tests of DO, DOING, RETURN in LOOP. Tests of NAMED loops + +(in-package :cl-test) + +(deftest loop.13.1 + (loop do (return 10)) + 10) + +(deftest loop.13.2 + (loop doing (return 10)) + 10) + +(deftest loop.13.3 + (loop for i from 0 below 100 by 7 + when (> i 50) return i) + 56) + +(deftest loop.13.4 + (let ((x 0)) + (loop do + (incf x) + (when (= x 10) (return x)))) + 10) + +(deftest loop.13.5 + (loop return 'a) + a) + +(deftest loop.13.6 + (loop return (values))) + +(deftest loop.13.7 + (loop return (values 1 2)) + 1 2) + +(deftest loop.13.8 + (let* ((limit (min 1000 (1- multiple-values-limit))) + (vals (make-list limit :initial-element :a)) + (vals2 (multiple-value-list (eval `(loop return (values ,@vals)))))) + (equalt vals vals2)) + t) + +(deftest loop.13.9 + (loop named foo return 'a) + a) + +(deftest loop.13.10 + (block nil + (return (loop named foo return :good)) + :bad) + :good) + +(deftest loop.13.11 + (block nil + (loop named foo do (return :good)) + :bad) + :good) + +(deftest loop.13.12 + (loop named foo with a = (return-from foo :good) return :bad) + :good) + +(deftest loop.13.13 + (loop named foo + with b = 1 + and a = (return-from foo :good) return :bad) + :good) + +(deftest loop.13.14 + (loop named foo + for a = (return-from foo :good) return :bad) + :good) + +(deftest loop.13.15 + (loop named foo for a in (return-from foo :good)) + :good) + +(deftest loop.13.16 + (loop named foo for a from (return-from foo :good) return :bad) + :good) + +(deftest loop.13.17 + (loop named foo for a on (return-from foo :good) return :bad) + :good) + +(deftest loop.13.18 + (loop named foo for a across (return-from foo :good) return :bad) + :good) + +(deftest loop.13.19 + (loop named foo for a being the hash-keys of (return-from foo :good) + return :bad) + :good) + +(deftest loop.13.20 + (loop named foo for a being the symbols of (return-from foo :good) + return :bad) + :good) + +(deftest loop.13.21 + (loop named foo repeat (return-from foo :good) return :bad) + :good) + +(deftest loop.13.22 + (loop named foo for i from 0 to (return-from foo :good) return :bad) + :good) + +(deftest loop.13.23 + (loop named foo for i from 0 to 10 by (return-from foo :good) return :bad) + :good) + +(deftest loop.13.24 + (loop named foo for i from 10 downto (return-from foo :good) return :bad) + :good) + +(deftest loop.13.25 + (loop named foo for i from 10 above (return-from foo :good) return :bad) + :good) + +(deftest loop.13.26 + (loop named foo for i from 10 below (return-from foo :good) return :bad) + :good) + +(deftest loop.13.27 + (loop named foo for i in '(a b c) by (return-from foo :good) return :bad) + :good) + +(deftest loop.13.28 + (loop named foo for i on '(a b c) by (return-from foo :good) return :bad) + :good) + +(deftest loop.13.29 + (loop named foo for i = 1 then (return-from foo :good)) + :good) + +(deftest loop.13.30 + (loop named foo for x in '(a b c) collect (return-from foo :good)) + :good) + +(deftest loop.13.31 + (loop named foo for x in '(a b c) append (return-from foo :good)) + :good) + +(deftest loop.13.32 + (loop named foo for x in '(a b c) nconc (return-from foo :good)) + :good) + +(deftest loop.13.33 + (loop named foo for x in '(a b c) count (return-from foo :good)) + :good) + +(deftest loop.13.34 + (loop named foo for x in '(a b c) sum (return-from foo :good)) + :good) + +(deftest loop.13.35 + (loop named foo for x in '(a b c) maximize (return-from foo :good)) + :good) + +(deftest loop.13.36 + (loop named foo for x in '(a b c) minimize (return-from foo :good)) + :good) + +(deftest loop.13.37 + (loop named foo for x in '(a b c) thereis (return-from foo :good)) + :good) + +(deftest loop.13.38 + (loop named foo for x in '(a b c) always (return-from foo :good)) + :good) + +(deftest loop.13.39 + (loop named foo for x in '(a b c) never (return-from foo :good)) + :good) + +(deftest loop.13.40 + (loop named foo for x in '(a b c) until (return-from foo :good)) + :good) + +(deftest loop.13.41 + (loop named foo for x in '(a b c) while (return-from foo :good)) + :good) + +(deftest loop.13.42 + (loop named foo for x in '(a b c) when (return-from foo :good) return :bad) + :good) + +(deftest loop.13.43 + (loop named foo for x in '(a b c) unless (return-from foo :good) return :bad) + :good) + +(deftest loop.13.44 + (loop named foo for x in '(a b c) if (return-from foo :good) return :bad) + :good) + +(deftest loop.13.45 + (loop named foo for x in '(a b c) return (return-from foo :good)) + :good) + +(deftest loop.13.46 + (loop named foo initially (return-from foo :good) return :bad) + :good) + +(deftest loop.13.47 + (loop named foo do (loop-finish) finally (return-from foo :good)) + :good) + + +(deftest loop.13.52 + (block nil + (loop named foo with a = (return :good) return :bad) + :bad) + :good) + +(deftest loop.13.53 + (block nil + (loop named foo + with b = 1 + and a = (return :good) return :bad) + :bad) + :good) + +(deftest loop.13.54 + (block nil + (loop named foo + for a = (return :good) return :bad) + :bad) + :good) + +(deftest loop.13.55 + (block nil + (loop named foo for a in (return :good)) + :bad) + :good) + +(deftest loop.13.56 + (block nil + (loop named foo for a from (return :good) return :bad) + :bad) + :good) + +(deftest loop.13.57 + (block nil + (loop named foo for a on (return :good) return :bad) + :bad) + :good) + +(deftest loop.13.58 + (block nil + (loop named foo for a across (return :good) return :bad) + :bad) + :good) + +(deftest loop.13.59 + (block nil + (loop named foo for a being the hash-keys of (return :good) + return :bad) + :bad) + :good) + +(deftest loop.13.60 + (block nil + (loop named foo for a being the symbols of (return :good) + return :bad) + :bad) + :good) + +(deftest loop.13.61 + (block nil + (loop named foo repeat (return :good) return :bad) + :bad) + :good) + +(deftest loop.13.62 + (block nil + (loop named foo for i from 0 to (return :good) return :bad) + :bad) + :good) + +(deftest loop.13.63 + (block nil + (loop named foo for i from 0 to 10 by (return :good) return :bad) + :bad) + :good) + +(deftest loop.13.64 + (block nil + (loop named foo for i from 10 downto (return :good) return :bad) + :bad) + :good) + +(deftest loop.13.65 + (block nil + (loop named foo for i from 10 above (return :good) return :bad) + :bad) + :good) + +(deftest loop.13.66 + (block nil + (loop named foo for i from 10 below (return :good) return :bad) + :bad) + :good) + +(deftest loop.13.67 + (block nil + (loop named foo for i in '(a b c) by (return :good) return :bad) + :bad) + :good) + +(deftest loop.13.68 + (block nil + (loop named foo for i on '(a b c) by (return :good) return :bad) + :bad) + :good) + +(deftest loop.13.69 + (block nil + (loop named foo for i = 1 then (return :good)) + :bad) + :good) + +(deftest loop.13.70 + (block nil + (loop named foo for x in '(a b c) collect (return :good)) + :bad) + :good) + +(deftest loop.13.71 + (block nil + (loop named foo for x in '(a b c) append (return :good)) + :bad) + :good) + +(deftest loop.13.72 + (block nil + (loop named foo for x in '(a b c) nconc (return :good)) + :bad) + :good) + +(deftest loop.13.73 + (block nil + (loop named foo for x in '(a b c) count (return :good)) + :bad) + :good) + +(deftest loop.13.74 + (block nil + (loop named foo for x in '(a b c) sum (return :good)) + :bad) + :good) + +(deftest loop.13.75 + (block nil + (loop named foo for x in '(a b c) maximize (return :good)) + :bad) + :good) + +(deftest loop.13.76 + (block nil + (loop named foo for x in '(a b c) minimize (return :good)) + :bad) + :good) + +(deftest loop.13.77 + (block nil + (loop named foo for x in '(a b c) thereis (return :good)) + :bad) + :good) + +(deftest loop.13.78 + (block nil + (loop named foo for x in '(a b c) always (return :good)) + :bad) + :good) + +(deftest loop.13.79 + (block nil + (loop named foo for x in '(a b c) never (return :good)) + :bad) + :good) + +(deftest loop.13.80 + (block nil + (loop named foo for x in '(a b c) until (return :good)) + :bad) + :good) + +(deftest loop.13.81 + (block nil + (loop named foo for x in '(a b c) while (return :good)) + :bad) + :good) + +(deftest loop.13.82 + (block nil + (loop named foo for x in '(a b c) when (return :good) return :bad) + :bad) + :good) + +(deftest loop.13.83 + (block nil + (loop named foo for x in '(a b c) unless (return :good) return :bad) + :bad) + :good) + +(deftest loop.13.84 + (block nil + (loop named foo for x in '(a b c) if (return :good) return :bad) + :bad) + :good) + +(deftest loop.13.85 + (block nil + (loop named foo for x in '(a b c) return (return :good)) + :bad) + :good) + +(deftest loop.13.86 + (block nil + (loop named foo initially (return :good) return :bad) + :bad) + :good) + +(deftest loop.13.87 + (block nil + (loop named foo do (loop-finish) finally (return :good)) + :bad) + :good) + + diff --git a/ansi-tests/loop14.lsp b/ansi-tests/loop14.lsp new file mode 100644 index 0000000..f22fa3c --- /dev/null +++ b/ansi-tests/loop14.lsp @@ -0,0 +1,333 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Nov 20 06:33:21 2002 +;;;; Contains: Tests of LOOP conditional execution clauses + +(in-package :cl-test) + +(deftest loop.14.1 + (loop for x from 1 to 6 + when (evenp x) + collect x) + (2 4 6)) + +(deftest loop.14.2 + (loop for x from 1 to 6 + unless (evenp x) + collect x) + (1 3 5)) + +(deftest loop.14.3 + (loop for x from 1 to 10 + when (evenp x) + collect x into foo + and count t into bar + finally (return (values foo bar))) + (2 4 6 8 10) + 5) + +(deftest loop.14.4 + (loop for x from 1 to 10 + when (evenp x) collect x end) + (2 4 6 8 10)) + +(deftest loop.14.5 + (loop for x from 1 to 10 + when (evenp x) collect x into evens + else collect x into odds + end + finally (return (values evens odds))) + (2 4 6 8 10) + (1 3 5 7 9)) + +(deftest loop.14.6 + (loop for x from 1 to 10 + unless (oddp x) + collect x into foo + and count t into bar + finally (return (values foo bar))) + (2 4 6 8 10) + 5) + +(deftest loop.14.7 + (loop for x from 1 to 10 + unless (oddp x) collect x end) + (2 4 6 8 10)) + +(deftest loop.14.8 + (loop for x from 1 to 10 + unless (oddp x) collect x into evens + else collect x into odds + end + finally (return (values evens odds))) + (2 4 6 8 10) + (1 3 5 7 9)) + +(deftest loop.14.9 + (loop for x from 1 to 6 + if (evenp x) + collect x) + (2 4 6)) + +(deftest loop.14.10 + (loop for x from 1 to 10 + if (evenp x) + collect x into foo + and count t into bar + finally (return (values foo bar))) + (2 4 6 8 10) + 5) + +(deftest loop.14.11 + (loop for x from 1 to 10 + if (evenp x) collect x end) + (2 4 6 8 10)) + +(deftest loop.14.12 + (loop for x from 1 to 10 + if (evenp x) collect x into evens + else collect x into odds + end + finally (return (values evens odds))) + (2 4 6 8 10) + (1 3 5 7 9)) + +;;; Test that else associates with the nearest conditional unclosed +;;; by end + +(deftest loop.14.13 + (loop for i from 1 to 20 + if (evenp i) + if (= (mod i 3) 0) + collect i into list1 + else collect i into list2 + finally (return (values list1 list2))) + (6 12 18) + (2 4 8 10 14 16 20)) + +(deftest loop.14.14 + (loop for i from 1 to 20 + when (evenp i) + if (= (mod i 3) 0) + collect i into list1 + else collect i into list2 + finally (return (values list1 list2))) + (6 12 18) + (2 4 8 10 14 16 20)) + +(deftest loop.14.15 + (loop for i from 1 to 20 + if (evenp i) + when (= (mod i 3) 0) + collect i into list1 + else collect i into list2 + finally (return (values list1 list2))) + (6 12 18) + (2 4 8 10 14 16 20)) + +(deftest loop.14.16 + (loop for i from 1 to 20 + if (evenp i) + if (= (mod i 3) 0) + collect i into list1 + end + else collect i into list2 + finally (return (values list1 list2))) + (6 12 18) + (1 3 5 7 9 11 13 15 17 19)) + +(deftest loop.14.17 + (loop for i from 1 to 20 + when (evenp i) + if (= (mod i 3) 0) + collect i into list1 + end + else collect i into list2 + finally (return (values list1 list2))) + (6 12 18) + (1 3 5 7 9 11 13 15 17 19)) + +(deftest loop.14.18 + (loop for i from 1 to 20 + if (evenp i) + when (= (mod i 3) 0) + collect i into list1 + end + else collect i into list2 + finally (return (values list1 list2))) + (6 12 18) + (1 3 5 7 9 11 13 15 17 19)) + +(deftest loop.14.19 + (loop for i from 1 to 20 + when (evenp i) + when (= (mod i 3) 0) + collect i into list1 + end + else collect i into list2 + finally (return (values list1 list2))) + (6 12 18) + (1 3 5 7 9 11 13 15 17 19)) + +(deftest loop.14.20 + (loop for i from 1 to 20 + unless (oddp i) + if (= (mod i 3) 0) + collect i into list1 + end + else collect i into list2 + finally (return (values list1 list2))) + (6 12 18) + (1 3 5 7 9 11 13 15 17 19)) + +(deftest loop.14.21 + (loop for i from 1 to 20 + if (evenp i) + unless (/= (mod i 3) 0) + collect i into list1 + end + else collect i into list2 + finally (return (values list1 list2))) + (6 12 18) + (1 3 5 7 9 11 13 15 17 19)) + +(deftest loop.14.22 + (loop for i from 1 to 20 + unless (oddp i) + unless (/= (mod i 3) 0) + collect i into list1 + end + else collect i into list2 + finally (return (values list1 list2))) + (6 12 18) + (1 3 5 7 9 11 13 15 17 19)) + +;;; More tests conditionals + +(deftest loop.14.23 + (loop for i from 1 to 20 + if (evenp i) + collect i into list1 + else if (= (mod i 3) 0) + collect i into list2 + else collect i into list3 + finally (return (values list1 list2 list3))) + (2 4 6 8 10 12 14 16 18 20) + (3 9 15) + (1 5 7 11 13 17 19)) + +;;; Tests of 'IT' + +(deftest loop.14.24 + (loop for x in '((a) nil (b) (c) (nil) (d)) + when (car x) collect it) + (a b c d)) + +(deftest loop.14.25 + (loop for x in '((a) nil (b) (c) (nil) (d)) + if (car x) collect it) + (a b c d)) + +(deftest loop.14.26 + (loop for x in '(nil (a) nil (b) (c) (nil) (d)) + when (car x) return it) + a) + +(deftest loop.14.27 + (loop for x in '(nil (a) nil (b) (c) (nil) (d)) + if (car x) return it) + a) + +(deftest loop.14.28 + (loop for x in '((a) nil (b) (c) (nil) (d)) + when (car x) collect it and collect 'foo) + (a foo b foo c foo d foo)) + +(deftest loop.14.29 + (let ((it 'z)) + (loop for x in '(a b c d) + when x collect it and collect it)) + (a z b z c z d z)) + +(deftest loop.14.30 + (let ((it 'z)) + (loop for x in '(a b c d) + if x collect it end + collect it)) + (a z b z c z d z)) + +(deftest loop.14.31 + (loop for it on '(a b c d) + when (car it) collect it) + (a b c d)) + +(deftest loop.14.32 + (loop for x in '(a b nil c d nil e) + when x collecting it) + (a b c d e)) + +(deftest loop.14.33 + (loop for x in '(a b nil c d nil e) + when x append (list x)) + (a b c d e)) + +(deftest loop.14.34 + (loop for x in '(a b nil c d nil e) + when x appending (list x)) + (a b c d e)) + +(deftest loop.14.35 + (loop for x in '(a b nil c d nil e) + when x nconc (list x)) + (a b c d e)) + +(deftest loop.14.36 + (loop for x in '(a b nil c d nil e) + when x nconcing (list x)) + (a b c d e)) + +(deftest loop.14.37 + (loop for it on '(a b c d) + when (car it) collect it into foo + finally (return foo)) + (a b c d)) + +(deftest loop.14.38 + (loop for x in '(1 2 nil 3 4 nil 5 nil) + when x count it) + 5) + +(deftest loop.14.39 + (loop for x in '(1 2 nil 3 4 nil 5 nil) + when x counting it) + 5) + +(deftest loop.14.40 + (loop for x in '(1 2 nil 3 4 nil 6 nil) + when x maximize it) + 6) + +(deftest loop.14.41 + (loop for x in '(1 2 nil 3 4 nil 6 nil) + when x maximizing it) + 6) + +(deftest loop.14.42 + (loop for x in '(1 2 nil 3 4 nil 6 nil) + when x minimize it) + 1) + +(deftest loop.14.43 + (loop for x in '(1 2 nil 3 4 nil 6 nil) + when x minimizing it) + 1) + +(deftest loop.14.44 + (loop for x in '(1 2 nil 3 4 nil 6 nil) + when x sum it) + 16) + +(deftest loop.14.45 + (loop for x in '(1 2 nil 3 4 nil 6 nil) + when x summing it) + 16) diff --git a/ansi-tests/loop15.lsp b/ansi-tests/loop15.lsp new file mode 100644 index 0000000..e7d2cb3 --- /dev/null +++ b/ansi-tests/loop15.lsp @@ -0,0 +1,249 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Thu Nov 21 07:08:21 2002 +;;;; Contains: Tests that keywords can be loop keywords + +(in-package :cl-test) + +;;; Tests of loop keywords + +(deftest loop.15.30 + (loop :for i :from 1 :to 10 :collect i) + (1 2 3 4 5 6 7 8 9 10)) + +(deftest loop.15.31 + (loop :for i :upfrom 1 :below 10 :by 2 :collect i) + (1 3 5 7 9)) + +(deftest loop.15.32 + (loop :with x = 1 :and y = 2 :return (values x y)) + 1 2) + +(deftest loop.15.33 + (loop :named foo :doing (return-from foo 1)) + 1) + +(deftest loop.15.34 + (let ((x 0)) + (loop + :initially (setq x 2) + :until t + :finally (return x))) + 2) + +(deftest loop.15.35 + (loop :for x :in '(a b c) :collecting x) + (a b c)) + +(deftest loop.15.36 + (loop :for x :in '(a b c) :append (list x)) + (a b c)) + +(deftest loop.15.37 + (loop :for x :in '(a b c) :appending (list x)) + (a b c)) + +(deftest loop.15.38 + (loop :for x :in '(a b c) :nconc (list x)) + (a b c)) + +(deftest loop.15.39 + (loop :for x :in '(a b c) :nconcing (list x)) + (a b c)) + +(deftest loop.15.40 + (loop :for x :in '(1 2 3) :count x) + 3) + +(deftest loop.15.41 + (loop :for x :in '(1 2 3) :counting x) + 3) + +(deftest loop.15.42 + (loop :for x :in '(1 2 3) :sum x) + 6) + +(deftest loop.15.43 + (loop :for x :in '(1 2 3) :summing x) + 6) + +(deftest loop.15.44 + (loop :for x :in '(10 20 30) :maximize x) + 30) + +(deftest loop.15.45 + (loop :for x :in '(10 20 30) :maximizing x) + 30) + +(deftest loop.15.46 + (loop :for x :in '(10 20 30) :minimize x) + 10) + +(deftest loop.15.47 + (loop :for x :in '(10 20 30) :minimizing x) + 10) + +(deftest loop.15.48 + (loop :for x :in '(1 2 3 4) :sum x :into foo :of-type fixnum + :finally (return foo)) + 10) + +(deftest loop.15.49 + (loop :for x :upfrom 1 :to 10 + :if (evenp x) :sum x :into foo + :else :sum x :into bar + :end + :finally (return (values foo bar))) + 30 25) + +(deftest loop.15.50 + (loop :for x :downfrom 10 :above 0 + :when (evenp x) :sum x :into foo + :else :sum x :into bar + :end + :finally (return (values foo bar))) + 30 25) + +(deftest loop.15.51 + (loop :for x :in '(a b nil c d nil) + :unless x :count t) + 2) + +(deftest loop.15.52 + (loop :for x :in '(a b nil c d nil) + :unless x :collect x :into bar :and :count t :into foo + :end + finally (return (values bar foo))) + (nil nil) + 2) + +(deftest loop.15.53 + (loop :for x :in '(nil nil a b nil c nil) + :collect x + :until x) + (nil nil a)) + +(deftest loop.15.54 + (loop :for x :in '(a b nil c nil) + :while x :collect x) + (a b)) + +(deftest loop.15.55 + (loop :for x :in '(nil nil a b nil c nil) + :thereis x) + a) + +(deftest loop.15.56 + (loop :for x :in '(nil nil a b nil c nil) + :never x) + nil) + +(deftest loop.15.57 + (loop :for x :in '(a b c d e) + :always x) + t) + +(deftest loop.15.58 + (loop :as x :in '(a b c) :count t) + 3) + +(deftest loop.15.59 + (loop :for i :from 10 :downto 5 :collect i) + (10 9 8 7 6 5)) + +(deftest loop.15.60 + (loop :for i :from 0 :upto 5 :collect i) + (0 1 2 3 4 5)) + +(deftest loop.15.61 + (loop :for x :on '(a b c) :collecting (car x)) + (a b c)) + +(deftest loop.15.62 + (loop :for x = '(a b c) :then (cdr x) + :while x + :collect (car x)) + (a b c)) + +(deftest loop.15.63 + (loop :for x :across #(a b c) :collect x) + (a b c)) + +(deftest loop.15.64 + (loop :for x :being :the :hash-keys :of (make-hash-table) + :count t) + 0) + +(deftest loop.15.65 + (loop :for x :being :each :hash-key :in (make-hash-table) + :count t) + 0) + +(deftest loop.15.66 + (loop :for x :being :each :hash-value :of (make-hash-table) + :count t) + 0) + +(deftest loop.15.67 + (loop :for x :being :the :hash-values :in (make-hash-table) + :count t) + 0) + +(deftest loop.15.68 + (loop :for x :being :the :hash-values :in (make-hash-table) + :using (:hash-key k) + :count t) + 0) + +(deftest loop.15.69 + (loop :for x :being :the :hash-keys :in (make-hash-table) + :using (:hash-value v) + :count t) + 0) + +(deftest loop.15.70 + (progn + (ignore-errors (delete-package "LOOP.15.PACKAGE")) + (let ((p (make-package "LOOP.15.PACKAGE" :use nil))) + (loop :for x :being :the :symbols :of p :count t))) + 0) + +(deftest loop.15.71 + (progn + (ignore-errors (delete-package "LOOP.15.PACKAGE")) + (let ((p (make-package "LOOP.15.PACKAGE" :use nil))) + (loop :for x :being :each :symbol :of p :count t))) + 0) + +(deftest loop.15.72 + (progn + (ignore-errors (delete-package "LOOP.15.PACKAGE")) + (let ((p (make-package "LOOP.15.PACKAGE" :use nil))) + (loop :for x :being :the :external-symbols :of p :count t))) + 0) + +(deftest loop.15.73 + (progn + (ignore-errors (delete-package "LOOP.15.PACKAGE")) + (let ((p (make-package "LOOP.15.PACKAGE" :use nil))) + (loop :for x :being :each :external-symbol :of p :count t))) + 0) + +(deftest loop.15.74 + (progn + (ignore-errors (delete-package "LOOP.15.PACKAGE")) + (let ((p (make-package "LOOP.15.PACKAGE" :use nil))) + (loop :for x :being :the :present-symbols :of p :count t))) + 0) + +(deftest loop.15.75 + (progn + (ignore-errors (delete-package "LOOP.15.PACKAGE")) + (let ((p (make-package "LOOP.15.PACKAGE" :use nil))) + (loop :for x :being :each :present-symbol :of p :count t))) + 0) + + + + + diff --git a/ansi-tests/loop16.lsp b/ansi-tests/loop16.lsp new file mode 100644 index 0000000..205ef95 --- /dev/null +++ b/ansi-tests/loop16.lsp @@ -0,0 +1,243 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Thu Nov 21 09:46:27 2002 +;;;; Contains: Tests that uninterned symbols can be loop keywords + +(in-package :cl-test) + + +(deftest loop.16.30 + (loop #:for i #:from 1 #:to 10 #:collect i) + (1 2 3 4 5 6 7 8 9 10)) + +(deftest loop.16.31 + (loop #:for i #:upfrom 1 #:below 10 #:by 2 #:collect i) + (1 3 5 7 9)) + +(deftest loop.16.32 + (loop #:with x = 1 #:and y = 2 #:return (values x y)) + 1 2) + +(deftest loop.16.33 + (loop #:named foo #:doing (return-from foo 1)) + 1) + +(deftest loop.16.34 + (let ((x 0)) + (loop + #:initially (setq x 2) + #:until t + #:finally (return x))) + 2) + +(deftest loop.16.35 + (loop #:for x #:in '(a b c) #:collecting x) + (a b c)) + +(deftest loop.16.36 + (loop #:for x #:in '(a b c) #:append (list x)) + (a b c)) + +(deftest loop.16.37 + (loop #:for x #:in '(a b c) #:appending (list x)) + (a b c)) + +(deftest loop.16.38 + (loop #:for x #:in '(a b c) #:nconc (list x)) + (a b c)) + +(deftest loop.16.39 + (loop #:for x #:in '(a b c) #:nconcing (list x)) + (a b c)) + +(deftest loop.16.40 + (loop #:for x #:in '(1 2 3) #:count x) + 3) + +(deftest loop.16.41 + (loop #:for x #:in '(1 2 3) #:counting x) + 3) + +(deftest loop.16.42 + (loop #:for x #:in '(1 2 3) #:sum x) + 6) + +(deftest loop.16.43 + (loop #:for x #:in '(1 2 3) #:summing x) + 6) + +(deftest loop.16.44 + (loop #:for x #:in '(10 20 30) #:maximize x) + 30) + +(deftest loop.16.45 + (loop #:for x #:in '(10 20 30) #:maximizing x) + 30) + +(deftest loop.16.46 + (loop #:for x #:in '(10 20 30) #:minimize x) + 10) + +(deftest loop.16.47 + (loop #:for x #:in '(10 20 30) #:minimizing x) + 10) + +(deftest loop.16.48 + (loop #:for x #:in '(1 2 3 4) #:sum x #:into foo #:of-type fixnum + #:finally (return foo)) + 10) + +(deftest loop.16.49 + (loop #:for x #:upfrom 1 #:to 10 + #:if (evenp x) #:sum x #:into foo + #:else #:sum x #:into bar + #:end + #:finally (return (values foo bar))) + 30 25) + +(deftest loop.16.50 + (loop #:for x #:downfrom 10 #:above 0 + #:when (evenp x) #:sum x #:into foo + #:else #:sum x #:into bar + #:end + #:finally (return (values foo bar))) + 30 25) + +(deftest loop.16.51 + (loop #:for x #:in '(a b nil c d nil) + #:unless x #:count t) + 2) + +(deftest loop.16.52 + (loop #:for x #:in '(a b nil c d nil) + #:unless x #:collect x #:into bar #:and #:count t #:into foo + #:end + finally (return (values bar foo))) + (nil nil) + 2) + +(deftest loop.16.53 + (loop #:for x #:in '(nil nil a b nil c nil) + #:collect x + #:until x) + (nil nil a)) + +(deftest loop.16.54 + (loop #:for x #:in '(a b nil c nil) + #:while x #:collect x) + (a b)) + +(deftest loop.16.55 + (loop #:for x #:in '(nil nil a b nil c nil) + #:thereis x) + a) + +(deftest loop.16.56 + (loop #:for x #:in '(nil nil a b nil c nil) + #:never x) + nil) + +(deftest loop.16.57 + (loop #:for x #:in '(a b c d e) + #:always x) + t) + +(deftest loop.16.58 + (loop #:as x #:in '(a b c) #:count t) + 3) + +(deftest loop.16.59 + (loop #:for i #:from 10 #:downto 5 #:collect i) + (10 9 8 7 6 5)) + +(deftest loop.16.60 + (loop #:for i #:from 0 #:upto 5 #:collect i) + (0 1 2 3 4 5)) + +(deftest loop.16.61 + (loop #:for x #:on '(a b c) #:collecting (car x)) + (a b c)) + +(deftest loop.16.62 + (loop #:for x = '(a b c) #:then (cdr x) + #:while x + #:collect (car x)) + (a b c)) + +(deftest loop.16.63 + (loop #:for x #:across #(a b c) #:collect x) + (a b c)) + +(deftest loop.16.64 + (loop #:for x #:being #:the #:hash-keys #:of (make-hash-table) + #:count t) + 0) + +(deftest loop.16.65 + (loop #:for x #:being #:each #:hash-key #:in (make-hash-table) + #:count t) + 0) + +(deftest loop.16.66 + (loop #:for x #:being #:each #:hash-value #:of (make-hash-table) + #:count t) + 0) + +(deftest loop.16.67 + (loop #:for x #:being #:the #:hash-values #:in (make-hash-table) + #:count t) + 0) + +(deftest loop.16.68 + (loop #:for x #:being #:the #:hash-values #:in (make-hash-table) + #:using (#:hash-key k) + #:count t) + 0) + +(deftest loop.16.69 + (loop #:for x #:being #:the #:hash-keys #:in (make-hash-table) + #:using (#:hash-value v) + #:count t) + 0) + +(deftest loop.16.70 + (progn + (ignore-errors (delete-package "LOOP.16.PACKAGE")) + (let ((p (make-package "LOOP.16.PACKAGE" :use nil))) + (loop #:for x #:being #:the #:symbols #:of p #:count t))) + 0) + +(deftest loop.16.71 + (progn + (ignore-errors (delete-package "LOOP.16.PACKAGE")) + (let ((p (make-package "LOOP.16.PACKAGE" :use nil))) + (loop #:for x #:being #:each #:symbol #:of p #:count t))) + 0) + +(deftest loop.16.72 + (progn + (ignore-errors (delete-package "LOOP.16.PACKAGE")) + (let ((p (make-package "LOOP.16.PACKAGE" :use nil))) + (loop #:for x #:being #:the #:external-symbols #:of p #:count t))) + 0) + +(deftest loop.16.73 + (progn + (ignore-errors (delete-package "LOOP.16.PACKAGE")) + (let ((p (make-package "LOOP.16.PACKAGE" :use nil))) + (loop #:for x #:being #:each #:external-symbol #:of p #:count t))) + 0) + +(deftest loop.16.74 + (progn + (ignore-errors (delete-package "LOOP.16.PACKAGE")) + (let ((p (make-package "LOOP.16.PACKAGE" :use nil))) + (loop #:for x #:being #:the #:present-symbols #:of p #:count t))) + 0) + +(deftest loop.16.75 + (progn + (ignore-errors (delete-package "LOOP.16.PACKAGE")) + (let ((p (make-package "LOOP.16.PACKAGE" :use nil))) + (loop #:for x #:being #:each #:present-symbol #:of p #:count t))) + 0) diff --git a/ansi-tests/loop17.lsp b/ansi-tests/loop17.lsp new file mode 100644 index 0000000..2297099 --- /dev/null +++ b/ansi-tests/loop17.lsp @@ -0,0 +1,133 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Thu Nov 21 09:48:38 2002 +;;;; Contains: Miscellaneous loop tests + +(in-package :cl-test) + +;;; Initially and finally take multiple forms, +;;; and execute them in the right order +(deftest loop.17.1 + (loop + with x = 0 + initially (incf x 1) (incf x (+ x x)) + initially (incf x (+ x x x)) + until t + finally (incf x 100) (incf x (+ x x)) + finally (return x)) + 336) + +(deftest loop.17.2 + (loop + with x = 0 + until t + initially (incf x 1) (incf x (+ x x)) + finally (incf x 100) (incf x (+ x x)) + initially (incf x (+ x x x)) + finally (return x)) + 336) + +(deftest loop.17.3 + (let ((x 0)) + (loop + with y = (incf x 1) + initially (incf x 2) + until t + finally (return (values x y)))) + 3 1) + +(deftest loop.17.4 + (loop + doing (return 'a) + finally (return 'b)) + a) + +(deftest loop.17.5 + (loop + return 'a + finally (return 'b)) + a) + +(deftest loop.17.6 + (let ((x 0)) + (tagbody + (loop + do (go done) + finally (incf x)) + done) + x) + 0) + +(deftest loop.17.7 + (let ((x 0)) + (catch 'done + (loop + do (throw 'done nil) + finally (incf x))) + x) + 0) + +(deftest loop.17.8 + (loop + for x in '(1 2 3) + collect x + finally (return 'good)) + good) + +(deftest loop.17.9 + (loop + for x in '(1 2 3) + append (list x) + finally (return 'good)) + good) + +(deftest loop.17.10 + (loop + for x in '(1 2 3) + nconc (list x) + finally (return 'good)) + good) + +(deftest loop.17.11 + (loop + for x in '(1 2 3) + count (> x 1) + finally (return 'good)) + good) + +(deftest loop.17.12 + (loop + for x in '(1 2 3) + sum x + finally (return 'good)) + good) + +(deftest loop.17.13 + (loop + for x in '(1 2 3) + maximize x + finally (return 'good)) + good) + +(deftest loop.17.14 + (loop + for x in '(1 2 3) + minimize x + finally (return 'good)) + good) + +;;; iteration clause grouping + +(deftest loop.17.20 + (loop + for i from 1 to 5 + for j = 0 then (+ j i) + collect j) + (0 2 5 9 14)) + +(deftest loop.17.21 + (loop + for i from 1 to 5 + and j = 0 then (+ j i) + collect j) + (0 1 3 6 10)) diff --git a/ansi-tests/loop2.lsp b/ansi-tests/loop2.lsp new file mode 100644 index 0000000..f93c566 --- /dev/null +++ b/ansi-tests/loop2.lsp @@ -0,0 +1,139 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Oct 26 13:45:45 2002 +;;;; Contains: Tests of the FOR-AS-IN-LIST loop iteration control form, +;;;; and of destructuring in loop forms + +(in-package :cl-test) + +(deftest loop.2.1 + (loop for x in '(1 2 3) sum x) + 6) + +(deftest loop.2.2 + (loop for x in '(1 2 3 4) + do (when (evenp x) (return x))) + 2) + +(deftest loop.2.3 + (classify-error (loop for x in '(a . b) collect x)) + type-error) + +(deftest loop.2.4 + (let ((x nil)) + (loop for e in '(a b c d) do (push e x)) + x) + (d c b a)) + +(deftest loop.2.5 + (loop for e in '(a b c d e f) by #'cddr + collect e) + (a c e)) + +(deftest loop.2.6 + (loop for e in '(a b c d e f g) by #'cddr + collect e) + (a c e g)) + +(deftest loop.2.7 + (loop for e in '(a b c d e f) + by #'(lambda (l) (and (cdr l) (cons (car l) (cddr l)))) + collect e) + (a a a a a a)) + +(deftest loop.2.8 + (loop for (x . y) in '((a . b) (c . d) (e . f)) + collect (list x y)) + ((a b) (c d) (e f))) + +(deftest loop.2.9 + (loop for (x nil y) in '((a b c) (d e f) (g h i)) + collect (list x y)) + ((a c) (d f) (g i))) + +(deftest loop.2.10 + (loop for (x y) of-type fixnum in '((1 2) (3 4) (5 6)) + collect (+ x y)) + (3 7 11)) + +(deftest loop.2.11 + (loop for (x y) of-type fixnum in '((1 2) (3 4) (5 6)) + collect (+ x y)) + (3 7 11)) + +(deftest loop.2.12 + (loop for (x y) of-type (fixnum fixnum) in '((1 2) (3 4) (5 6)) + collect (+ x y)) + (3 7 11)) + + +(deftest loop.2.13 + (loop for (x . y) of-type (fixnum . fixnum) in '((1 . 2) (3 . 4) (5 . 6)) + collect (+ x y)) + (3 7 11)) + +(deftest loop.2.14 + (classify-error + (loop for x in '(a b c) + for x in '(d e f) collect x)) + program-error) + +(deftest loop.2.15 + (classify-error + (loop for (x . x) in '((a b) (c d)) collect x)) + program-error) + +(deftest loop.2.16 + (loop for nil in nil do (return t)) + nil) + +(deftest loop.2.17 + (let ((x '(a b c))) + (values + x + (loop for x in '(d e f) collect (list x)) + x)) + (a b c) + ((d) (e) (f)) + (a b c)) + +(deftest loop.2.18 + (loop for x of-type (integer 0 10) in '(2 4 6 7) sum x) + 19) + +;;; Tests of the 'AS' form + +(deftest loop.2.19 + (loop as x in '(1 2 3) sum x) + 6) + +(deftest loop.2.20 + (loop as x in '(a b c) + as y in '(1 2 3) + collect (list x y)) + ((a 1) (b 2) (c 3))) + +(deftest loop.2.21 + (loop as x in '(a b c) + for y in '(1 2 3) + collect (list x y)) + ((a 1) (b 2) (c 3))) + +(deftest loop.2.22 + (loop for x in '(a b c) + as y in '(1 2 3) + collect (list x y)) + ((a 1) (b 2) (c 3))) + +(deftest loop.2.23 + (let (a b (i 0)) + (values + (loop for e in (progn (setf a (incf i)) + '(a b c d e f g)) + by (progn (setf b (incf i)) #'cddr) + collect e) + a b i)) + (a c e g) + 1 2 2) + + diff --git a/ansi-tests/loop3.lsp b/ansi-tests/loop3.lsp new file mode 100644 index 0000000..44ccd03 --- /dev/null +++ b/ansi-tests/loop3.lsp @@ -0,0 +1,136 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Oct 27 08:36:36 2002 +;;;; Contains: Tests of FOR-ON-AS-LIST iteration control in LOOP + +(in-package :cl-test) + +(deftest loop.3.1 + (loop for x on '(1 2 3) sum (car x)) + 6) + +(deftest loop.3.2 + (loop for x on '(1 2 3 4) + do (when (evenp (car x)) (return x))) + (2 3 4)) + + +(deftest loop.3.3 + (loop for x on '(a b c . d) collect (car x)) + (a b c)) + +(deftest loop.3.4 + (let ((x nil)) + (loop for e on '(a b c d) do (push (car e) x)) + x) + (d c b a)) + +(deftest loop.3.5 + (loop for e on '(a b c d e f) by #'cddr + collect (car e)) + (a c e)) + +(deftest loop.3.6 + (loop for e on '(a b c d e f g) by #'cddr + collect (car e)) + (a c e g)) + +(deftest loop.3.7 + (loop for e on '(a b c d e f) + by #'(lambda (l) (and (cdr l) (cons (car l) (cddr l)))) + collect (car e)) + (a a a a a a)) + +(deftest loop.3.8 + (loop for ((x . y)) on '((a . b) (c . d) (e . f)) + collect (list x y)) + ((a b) (c d) (e f))) + +(deftest loop.3.9 + (loop for ((x nil y)) on '((a b c) (d e f) (g h i)) + collect (list x y)) + ((a c) (d f) (g i))) + +(deftest loop.3.10 + (loop for ((x y)) of-type (fixnum) on '((1 2) (3 4) (5 6)) + collect (+ x y)) + (3 7 11)) + +(deftest loop.3.11 + (loop for ((x y)) of-type (fixnum) on '((1 2) (3 4) (5 6)) + collect (+ x y)) + (3 7 11)) + +(deftest loop.3.12 + (loop for ((x y)) of-type ((fixnum fixnum)) on '((1 2) (3 4) (5 6)) + collect (+ x y)) + (3 7 11)) + +(deftest loop.3.13 + (loop for ((x . y)) of-type ((fixnum . fixnum)) on '((1 . 2) (3 . 4) (5 . 6)) + collect (+ x y)) + (3 7 11)) + +(deftest loop.3.14 + (classify-error + (loop for x on '(a b c) + for x on '(d e f) collect x)) + program-error) + +(deftest loop.3.15 + (classify-error + (loop for (x . x) on '((a b) (c d)) collect x)) + program-error) + +(deftest loop.3.16 + (loop for nil on nil do (return t)) + nil) + +(deftest loop.3.17 + (let ((x '(a b c))) + (values + x + (loop for x on '(d e f) collect x) + x)) + (a b c) + ((d e f) (e f) (f)) + (a b c)) + +(deftest loop.3.18 + (loop for (x) of-type ((integer 0 10)) on '(2 4 6 7) sum x) + 19) + +;;; Tests of the 'AS' form + +(deftest loop.3.19 + (loop as x on '(1 2 3) sum (car x)) + 6) + +(deftest loop.3.20 + (loop as x on '(a b c) + as y on '(1 2 3) + collect (list (car x) (car y))) + ((a 1) (b 2) (c 3))) + +(deftest loop.3.21 + (loop as x on '(a b c) + for y on '(1 2 3) + collect (list (car x) (car y))) + ((a 1) (b 2) (c 3))) + +(deftest loop.3.22 + (loop for x on '(a b c) + as y on '(1 2 3) + collect (list (car x) (car y))) + ((a 1) (b 2) (c 3))) + +(deftest loop.3.23 + (let (a b (i 0)) + (values + (loop for e on (progn (setf a (incf i)) + '(a b c d e f g)) + by (progn (setf b (incf i)) #'cddr) + collect (car e)) + a b i)) + (a c e g) + 1 2 2) diff --git a/ansi-tests/loop4.lsp b/ansi-tests/loop4.lsp new file mode 100644 index 0000000..bd0f7e1 --- /dev/null +++ b/ansi-tests/loop4.lsp @@ -0,0 +1,57 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Oct 27 22:46:39 2002 +;;;; Contains: Tests for LOOP FOR-AS-EQUAL-THEN + +(in-package :cl-test) + +(deftest loop.4.1 + (loop + for x = 1 then (1+ x) + until (> x 5) + collect x) + (1 2 3 4 5)) + +(deftest loop.4.2 + (loop + for i from 1 to 10 + for j = (1+ i) collect j) + (2 3 4 5 6 7 8 9 10 11)) + +(deftest loop.4.3 + (loop + for i from 1 to 10 + for j of-type integer = (1+ i) collect j) + (2 3 4 5 6 7 8 9 10 11)) + +(deftest loop.4.4 + (loop for e on '(a b c d e) + for (x . y) = e + collect x) + (a b c d e)) + +(deftest loop.4.5 + (loop for (x . y) = '(a b c d e) then y + while x + collect x) + (a b c d e)) + +;;; Error cases + +(deftest loop.4.6 + (classify-error + (loop for (x . x) = '(nil nil nil) + until x count t)) + program-error) + +(deftest loop.4.7 + (classify-error* + (macroexpand '(loop for (x . x) = '(nil nil nil) + until x count t))) + program-error) + +(deftest loop.4.8 + (classify-error* + (macroexpand '(loop for x = '(nil nil nil) + for x = 1 count x until t))) + program-error) diff --git a/ansi-tests/loop5.lsp b/ansi-tests/loop5.lsp new file mode 100644 index 0000000..d5f2a8c --- /dev/null +++ b/ansi-tests/loop5.lsp @@ -0,0 +1,172 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Nov 2 13:52:50 2002 +;;;; Contains: Tests of LOOP clause FOR-AS-ACROSS + +(in-package :cl-test) + +(deftest loop.5.1 + (let ((x "abcd")) (loop for e across x collect e)) + (#\a #\b #\c #\d)) + +(deftest loop.5.2 + (let ((x "abcd")) (loop for e across (the string x) collect e)) + (#\a #\b #\c #\d)) + +(deftest loop.5.3 + (let ((x "abcd")) (loop for e across (the simple-string x) collect e)) + (#\a #\b #\c #\d)) + +(deftest loop.5.4 + (loop for e across "abcd" collect e) + (#\a #\b #\c #\d)) + +(deftest loop.5.5 + (loop for e across "abcd" + for i from 1 to 3 collect e) + (#\a #\b #\c)) + +(deftest loop.5.6 + (loop for e of-type base-char across "abcd" + for i from 1 to 3 collect e) + (#\a #\b #\c)) + +(deftest loop.5.7 + (let ((x "abcd")) (loop for e across (the base-string x) collect e)) + (#\a #\b #\c #\d)) + +(deftest loop.5.8 + (let ((x "abcd")) (loop for e of-type character across x collect e)) + (#\a #\b #\c #\d)) + + +(deftest loop.5.10 + (let ((x #*00010110)) + (loop for e across x collect e)) + (0 0 0 1 0 1 1 0)) + +(deftest loop.5.11 + (let ((x #*00010110)) + (loop for e across (the bit-vector x) collect e)) + (0 0 0 1 0 1 1 0)) + +(deftest loop.5.12 + (let ((x #*00010110)) + (loop for e across (the simple-bit-vector x) collect e)) + (0 0 0 1 0 1 1 0)) + +(deftest loop.5.13 + (let ((x #*00010110)) + (loop for e of-type bit across (the simple-bit-vector x) collect e)) + (0 0 0 1 0 1 1 0)) + +(deftest loop.5.14 + (let ((x #*00010110)) + (loop for e of-type bit across x + for i from 1 to 4 collect e)) + (0 0 0 1)) + + +(deftest loop.5.20 + (let ((x (vector 'a 'b 'c 'd))) + (loop for e across x collect e)) + (a b c d)) + +(deftest loop.5.21 + (let ((x (vector 'a 'b 'c 'd))) + (loop for e across (the vector x) collect e)) + (a b c d)) + +(deftest loop.5.22 + (let ((x (vector 'a 'b 'c 'd))) + (loop for e across (the simple-vector x) collect e)) + (a b c d)) + +(deftest loop.5.23 + (let ((x (vector '(a) '(b) '(c) '(d)))) + (loop for (e) across x collect e)) + (a b c d)) + + +(deftest loop.5.30 + (let ((x (make-array '(5) :initial-contents '(a b c d e) + :adjustable t))) + (loop for e across x collect e)) + (a b c d e)) + +(deftest loop.5.32 + (let* ((x (make-array '(5) :initial-contents '(a b c d e))) + (y (make-array '(3) :displaced-to x + :displaced-index-offset 1))) + (loop for e across y collect e)) + (b c d)) + +;;; tests of 'as' form + +(deftest loop.5.33 + (loop as e across "abc" collect e) + (#\a #\b #\c)) + +(deftest loop.5.34 + (loop as e of-type character across "abc" collect e) + (#\a #\b #\c)) + +(deftest loop.5.35 + (loop as e of-type integer across (the simple-vector (coerce '(1 2 3) 'simple-vector)) + sum e) + 6) + +;;; Loop across displaced vectors + +(deftest loop.5.36 + (let* ((a (make-array '(10) :initial-contents '(a b c d e f g h i j))) + (da (make-array '(5) :displaced-to a + :displaced-index-offset 2))) + (loop for e across da collect e)) + (c d e f g)) + +(deftest loop.5.37 + (let* ((a (make-array '(10) :element-type 'base-char + :initial-contents "abcdefghij")) + (da (make-array '(5) :element-type 'base-char + :displaced-to a + :displaced-index-offset 2))) + (loop for e across da collect e)) + (#\c #\d #\e #\f #\g)) + +(deftest loop.5.38 + (let* ((a (make-array '(10) :element-type 'bit + :initial-contents '(0 1 1 0 0 1 0 1 1 1))) + (da (make-array '(5) :element-type 'bit + :displaced-to a + :displaced-index-offset 2))) + (loop for e across da collect e)) + (1 0 0 1 0)) + + +;;; Error cases + +(deftest loop.5.error.1 + (classify-error + (loop for (e . e) across (vector '(x . y) '(u . v)) collect e)) + program-error) + +(deftest loop.5.error.2 + (classify-error + (loop for e across (vector '(x . y) '(u . v)) + for e from 1 to 5 collect e)) + program-error) + +(deftest loop.5.error.3 + (classify-error* + (macroexpand + '(loop for (e . e) across (vector '(x . y) '(u . v)) collect e))) + program-error) + +(deftest loop.5.error.4 + (classify-error* + (macroexpand + '(loop for e across (vector '(x . y) '(u . v)) + for e from 1 to 5 collect e))) + program-error) + diff --git a/ansi-tests/loop6.lsp b/ansi-tests/loop6.lsp new file mode 100644 index 0000000..3dc4123 --- /dev/null +++ b/ansi-tests/loop6.lsp @@ -0,0 +1,294 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Nov 10 21:13:04 2002 +;;;; Contains: Tests for LOOP-AS-HASH forms + +(in-package :cl-test) + +(defparameter *loop.6.alist* + '((a . 1) (b . 2) (c . 3))) + +(defparameter *loop.6.alist.2* + '(("a" . 1) ("b" . 2) ("c" . 3))) + +(defparameter *loop.6.alist.3* + '(((a1 . a2) . 1) ((b1 . b2) . 2) ((c1 . c2) . 3))) + +(defparameter *loop.6.hash.1* + (let ((table (make-hash-table :test #'eq))) + (loop for (key . val) in *loop.6.alist* + do (setf (gethash key table) val)) + table)) + +(defparameter *loop.6.hash.2* + (let ((table (make-hash-table :test #'eql))) + (loop for (key . val) in *loop.6.alist* + do (setf (gethash key table) val)) + table)) + +(defparameter *loop.6.hash.3* + (let ((table (make-hash-table :test #'equal))) + (loop for (key . val) in *loop.6.alist.3* + do (setf (gethash key table) val)) + table)) + +;;; (defparameter *loop.6.hash.4* +;;; (let ((table (make-hash-table :test #'equalp))) +;;; (loop for (key . val) in *loop.6.alist.2* +;;; do (setf (gethash key table) val)) +;;; table)) + +(defparameter *loop.6.hash.5* + (let ((table (make-hash-table :test #'eql))) + (loop for (val . key) in *loop.6.alist.3* + do (setf (gethash key table) val)) + table)) + +(defparameter *loop.6.hash.6* + (let ((table (make-hash-table :test #'eq))) + (loop for (key . val) in *loop.6.alist* + do (setf (gethash key table) (coerce val 'float))) + table)) + +(defparameter *loop.6.hash.7* + (let ((table (make-hash-table :test #'equal))) + (loop for (val . key) in *loop.6.alist.3* + do (setf (gethash (coerce key 'float) table) val)) + table)) + +(defparameter *loop.6.alist.8* + '(((1 . 2) . 1) ((3 . 4) . b) ((5 . 6) . c))) + +(defparameter *loop.6.hash.8* + (let ((table (make-hash-table :test #'equal))) + (loop for (key . val) in *loop.6.alist.8* + do (setf (gethash key table) val)) + table)) + +(defparameter *loop.6.hash.9* + (let ((table (make-hash-table :test #'equal))) + (loop for (val . key) in *loop.6.alist.8* + do (setf (gethash key table) val)) + table)) + +;;; being {each | the} {hash-value | hash-values | hash-key | hash-keys} {in | of } + +(deftest loop.6.1 + (loop for x being the hash-value of *loop.6.hash.1* sum x) + 6) + +(deftest loop.6.2 + (loop for x being the hash-values of *loop.6.hash.1* sum x) + 6) + +(deftest loop.6.3 + (loop for x being each hash-value of *loop.6.hash.1* sum x) + 6) + +(deftest loop.6.4 + (loop for x being each hash-values of *loop.6.hash.1* sum x) + 6) + +(deftest loop.6.5 + (loop for x being the hash-values in *loop.6.hash.1* sum x) + 6) + +(deftest loop.6.6 + (sort (loop for x being the hash-key of *loop.6.hash.1* collect x) + #'symbol<) + (a b c)) + +(deftest loop.6.7 + (sort (loop for x being the hash-keys of *loop.6.hash.1* collect x) + #'symbol<) + (a b c)) + +(deftest loop.6.8 + (sort (loop for x being each hash-key of *loop.6.hash.1* collect x) + #'symbol<) + (a b c)) + +(deftest loop.6.9 + (sort (loop for x being each hash-keys of *loop.6.hash.1* collect x) + #'symbol<) + (a b c)) + +(deftest loop.6.10 + (sort (loop for x being each hash-keys in *loop.6.hash.1* collect x) + #'symbol<) + (a b c)) + +(deftest loop.6.11 + (sort (loop for (u . v) being the hash-keys of *loop.6.hash.3* collect u) + #'symbol<) + (a1 b1 c1)) + +(deftest loop.6.12 + (sort (loop for (u . v) being the hash-keys of *loop.6.hash.3* collect v) + #'symbol<) + (a2 b2 c2)) + +(deftest loop.6.13 + (sort (loop for (u . v) being the hash-values of *loop.6.hash.5* collect u) + #'symbol<) + (a1 b1 c1)) + +(deftest loop.6.14 + (sort (loop for (u . v) being the hash-values of *loop.6.hash.5* collect v) + #'symbol<) + (a2 b2 c2)) + +(deftest loop.6.15 + (sort (loop for k being the hash-keys of *loop.6.hash.1* using (hash-value v) + collect (list k v)) + #'< :key #'second) + ((a 1) (b 2) (c 3))) + +(deftest loop.6.16 + (sort (loop for v being the hash-values of *loop.6.hash.1* using (hash-key k) + collect (list k v)) + #'< :key #'second) + ((a 1) (b 2) (c 3))) + +(deftest loop.6.17 + (sort (loop for (u . nil) being the hash-values of *loop.6.hash.5* collect u) + #'symbol<) + (a1 b1 c1)) + +(deftest loop.6.18 + (sort (loop for (nil . v) being the hash-values of *loop.6.hash.5* collect v) + #'symbol<) + (a2 b2 c2)) + +(deftest loop.6.19 + (loop for nil being the hash-values of *loop.6.hash.5* count t) + 3) + +(deftest loop.6.20 + (loop for nil being the hash-keys of *loop.6.hash.5* count t) + 3) + +(deftest loop.6.21 + (loop for v being the hash-values of *loop.6.hash.5* using (hash-key nil) count t) + 3) + +(deftest loop.6.22 + (loop for k being the hash-keys of *loop.6.hash.5* using (hash-value nil) count t) + 3) + +(deftest loop.6.23 + (loop for v fixnum being the hash-values of *loop.6.hash.1* sum v) + 6) + +(deftest loop.6.24 + (loop for v of-type fixnum being the hash-values of *loop.6.hash.1* sum v) + 6) + +(deftest loop.6.25 + (loop for k fixnum being the hash-keys of *loop.6.hash.5* sum k) + 6) + +(deftest loop.6.26 + (loop for k of-type fixnum being the hash-keys of *loop.6.hash.5* sum k) + 6) + +(deftest loop.6.27 + (loop for k t being the hash-keys of *loop.6.hash.5* sum k) + 6) + +(deftest loop.6.28 + (loop for k of-type t being the hash-keys of *loop.6.hash.5* sum k) + 6) + +(deftest loop.6.29 + (loop for v t being the hash-values of *loop.6.hash.1* sum v) + 6) + +(deftest loop.6.30 + (loop for v of-type t being the hash-values of *loop.6.hash.1* sum v) + 6) + +(deftest loop.6.31 + (loop for v float being the hash-values of *loop.6.hash.6* sum v) + 6.0) + +(deftest loop.6.32 + (loop for v of-type float being the hash-values of *loop.6.hash.6* sum v) + 6.0) + +(deftest loop.6.33 + (loop for k float being the hash-keys of *loop.6.hash.7* sum k) + 6.0) + +(deftest loop.6.34 + (loop for k of-type float being the hash-keys of *loop.6.hash.7* sum k) + 6.0) + +(deftest loop.6.35 + (loop for (k1 . k2) of-type (integer . integer) being the hash-keys + of *loop.6.hash.8* sum (+ k1 k2)) + 21) + +(deftest loop.6.36 + (loop for (v1 . v2) of-type (integer . integer) being the hash-values + of *loop.6.hash.9* sum (+ v1 v2)) + 21) + +(deftest loop.6.37 + (loop for v being the hash-values of *loop.6.hash.8* + using (hash-key (k1 . k2)) sum (+ k1 k2)) + 21) + +(deftest loop.6.38 + (loop for k being the hash-keys of *loop.6.hash.9* + using (hash-value (v1 . v2)) sum (+ v1 v2)) + 21) + +(deftest loop.6.39 + (loop as x being the hash-value of *loop.6.hash.1* sum x) + 6) + +(deftest loop.6.40 + (sort (loop as x being the hash-key of *loop.6.hash.1* collect x) + #'symbol<) + (a b c)) + +;;; Error tests + +(deftest loop.6.error.1 + (classify-error + (loop for k from 1 to 10 + for k being the hash-keys of *loop.6.hash.1* + count t)) + program-error) + +(deftest loop.6.error.2 + (classify-error + (loop for k being the hash-keys of *loop.6.hash.1* + for k from 1 to 10 + count t)) + program-error) + +(deftest loop.6.error.3 + (classify-error + (loop for (k . k) being the hash-keys of *loop.6.hash.3* + count t)) + program-error) + +(deftest loop.6.error.4 + (classify-error + (loop for k being the hash-keys of *loop.6.hash.3* + using (hash-value k) + count t)) + program-error) + +(deftest loop.6.error.5 + (classify-error + (loop for k being the hash-values of *loop.6.hash.3* + using (hash-key k) + count t)) + program-error) + + + + diff --git a/ansi-tests/loop7.lsp b/ansi-tests/loop7.lsp new file mode 100644 index 0000000..d6594eb --- /dev/null +++ b/ansi-tests/loop7.lsp @@ -0,0 +1,206 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Mon Nov 11 21:40:05 2002 +;;;; Contains: Tests for FOR-AS-PACKAGE clause for LOOP + +(in-package :cl-test) + +(defpackage "LOOP.CL-TEST.1" + (:use) + (:intern "FOO" "BAR" "BAZ") + (:export "A" "B" "C")) + +(defpackage "LOOP.CL-TEST.2" + (:use "LOOP.CL-TEST.1") + (:intern "X" "Y" "Z")) + +(deftest loop.7.1 + (sort (mapcar #'symbol-name + (loop for x being the symbols of "LOOP.CL-TEST.1" collect x)) + #'string<) + ("A" "B" "BAR" "BAZ" "C" "FOO")) + +(deftest loop.7.2 + (sort (mapcar #'symbol-name + (loop for x being each symbol of "LOOP.CL-TEST.1" collect x)) + #'string<) + ("A" "B" "BAR" "BAZ" "C" "FOO")) + +(deftest loop.7.3 + (sort (mapcar #'symbol-name + (loop for x being the symbol of "LOOP.CL-TEST.1" collect x)) + #'string<) + ("A" "B" "BAR" "BAZ" "C" "FOO")) + +(deftest loop.7.4 + (sort (mapcar #'symbol-name + (loop for x being each symbols of "LOOP.CL-TEST.1" collect x)) + #'string<) + ("A" "B" "BAR" "BAZ" "C" "FOO")) + +(deftest loop.7.5 + (sort (mapcar #'symbol-name + (loop for x being the symbols in "LOOP.CL-TEST.1" collect x)) + #'string<) + ("A" "B" "BAR" "BAZ" "C" "FOO")) + +(deftest loop.7.6 + (sort (mapcar #'symbol-name + (loop for x being each symbol in "LOOP.CL-TEST.1" collect x)) + #'string<) + ("A" "B" "BAR" "BAZ" "C" "FOO")) + +(deftest loop.7.7 + (sort (mapcar #'symbol-name + (loop for x being the symbol in "LOOP.CL-TEST.1" collect x)) + #'string<) + ("A" "B" "BAR" "BAZ" "C" "FOO")) + +(deftest loop.7.8 + (sort (mapcar #'symbol-name + (loop for x being each symbols in "LOOP.CL-TEST.1" collect x)) + #'string<) + ("A" "B" "BAR" "BAZ" "C" "FOO")) + +(deftest loop.7.9 + (sort (mapcar #'symbol-name + (loop for x being the external-symbols of "LOOP.CL-TEST.1" collect x)) + #'string<) + ("A" "B" "C")) + +(deftest loop.7.10 + (sort (mapcar #'symbol-name + (loop for x being each external-symbol in "LOOP.CL-TEST.1" collect x)) + #'string<) + ("A" "B" "C")) + +(deftest loop.7.11 + (sort (mapcar #'symbol-name + (loop for x being each external-symbol in (find-package "LOOP.CL-TEST.1") collect x)) + #'string<) + ("A" "B" "C")) + +(deftest loop.7.12 + (sort (mapcar #'symbol-name + (loop for x being each external-symbol in :LOOP.CL-TEST.1 collect x)) + #'string<) + ("A" "B" "C")) + +(deftest loop.7.13 + (sort (mapcar #'symbol-name + (loop for x being the symbols of "LOOP.CL-TEST.2" collect x)) + #'string<) + ("A" "B" "C" "X" "Y" "Z")) + +(deftest loop.7.14 + (sort (mapcar #'symbol-name + (loop for x being the present-symbols of "LOOP.CL-TEST.2" collect x)) + #'string<) + ("X" "Y" "Z")) + +;;; According to the ANSI CL spec, "If the package for the iteration is not supplied, +;;; the current package is used." Thse next tests are of the cases that the package +;;; is not supplied in the loop form. + +(deftest loop.7.15 + (let ((*package* (find-package "LOOP.CL-TEST.1"))) + (sort (mapcar #'symbol-name (loop for x being each symbol collect x)) + #'string<)) + ("A" "B" "BAR" "BAZ" "C" "FOO")) + +(deftest loop.7.16 + (let ((*package* (find-package "LOOP.CL-TEST.1"))) + (sort (mapcar #'symbol-name (loop for x being each external-symbol collect x)) + #'string<)) + ("A" "B" "C")) + +(deftest loop.7.17 + (let ((*package* (find-package "LOOP.CL-TEST.2"))) + (sort (mapcar #'symbol-name (loop for x being each present-symbol collect x)) + #'string<)) + ("X" "Y" "Z")) + +;;; Cases where the package doesn't exist. According to the standard, +;;; (section 6.1.2.1.7), this should cause a pacakge-error. + +(deftest loop.7.18 + (progn + (ignore-errors (delete-package "LOOP.MISSING.PACKAGE")) + (classify-error + (loop for x being each symbol of "LOOP.MISSING.PACKAGE" collect x))) + package-error) + +(deftest loop.7.19 + (progn + (ignore-errors (delete-package "LOOP.MISSING.PACKAGE")) + (classify-error + (loop for x being each present-symbol of "LOOP.MISSING.PACKAGE" collect x))) + package-error) + +(deftest loop.7.20 + (progn + (ignore-errors (delete-package "LOOP.MISSING.PACKAGE")) + (classify-error + (loop for x being each external-symbol of "LOOP.MISSING.PACKAGE" collect x))) + package-error) + +;;; NIL d-var-specs + +(deftest loop.7.21 + (loop for nil being the symbols of "LOOP.CL-TEST.1" count t) + 6) + +(deftest loop.7.22 + (loop for nil being the external-symbols of "LOOP.CL-TEST.1" count t) + 3) + +(deftest loop.7.23 + (loop for nil being the present-symbols of "LOOP.CL-TEST.2" count t) + 3) + +;;; Type specs + +(deftest loop.7.24 + (loop for x t being the symbols of "LOOP.CL-TEST.1" count x) + 6) + +(deftest loop.7.25 + (loop for x t being the external-symbols of "LOOP.CL-TEST.1" count x) + 3) + +(deftest loop.7.26 + (loop for x t being the present-symbols of "LOOP.CL-TEST.2" count x) + 3) + +(deftest loop.7.27 + (loop for x of-type symbol being the symbols of "LOOP.CL-TEST.1" count x) + 6) + +(deftest loop.7.28 + (loop for x of-type symbol being the external-symbols of "LOOP.CL-TEST.1" count x) + 3) + +(deftest loop.7.29 + (loop for x of-type symbol being the present-symbols of "LOOP.CL-TEST.2" count x) + 3) + +;;; Tests of the 'as' form + +(deftest loop.7.30 + (sort (mapcar #'symbol-name + (loop as x being the symbols of "LOOP.CL-TEST.1" collect x)) + #'string<) + ("A" "B" "BAR" "BAZ" "C" "FOO")) + +(deftest loop.7.31 + (sort (mapcar #'symbol-name + (loop as x being each symbol of "LOOP.CL-TEST.1" collect x)) + #'string<) + ("A" "B" "BAR" "BAZ" "C" "FOO")) + +(deftest loop.7.32 + (sort (mapcar #'symbol-name + (loop as x being the symbol of "LOOP.CL-TEST.1" collect x)) + #'string<) + ("A" "B" "BAR" "BAZ" "C" "FOO")) + diff --git a/ansi-tests/loop8.lsp b/ansi-tests/loop8.lsp new file mode 100644 index 0000000..5866429 --- /dev/null +++ b/ansi-tests/loop8.lsp @@ -0,0 +1,141 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Nov 12 06:30:14 2002 +;;;; Contains: Tests of LOOP local variable initialization + +(in-package :cl-test) + +(deftest loop.8.1 + (loop with x = 1 do (return x)) + 1) + +(deftest loop.8.2 + (loop with x = 1 + with y = (1+ x) do (return (list x y))) + (1 2)) + +(deftest loop.8.3 + (let ((y 2)) + (loop with x = y + with y = (1+ x) do (return (list x y)))) + (2 3)) + +(deftest loop.8.4 + (let (a b) + (loop with a = 1 + and b = (list a) + and c = (list b) + return (list a b c))) + (1 (nil) (nil))) + + +;;; type specs + +(deftest loop.8.5 + (loop with a t = 1 return a) + 1) + +(deftest loop.8.6 + (loop with a fixnum = 2 return a) + 2) + +(deftest loop.8.7 + (loop with a float = 3.0 return a) + 3.0) + +(deftest loop.8.8 + (loop with a of-type string = "abc" return a) + "abc") + +(deftest loop.8.9 + (loop with (a b) = '(1 2) return (list b a)) + (2 1)) + +(deftest loop.8.10 + (loop with (a b) of-type (fixnum fixnum) = '(3 4) return (+ a b)) + 7) + +(deftest loop.8.11 + (loop with a of-type fixnum return a) + 0) + +(deftest loop.8.12 + (loop with a of-type float return a) + 0.0) + +(deftest loop.8.13 + (loop with a of-type t return a) + nil) + +(deftest loop.8.14 + (loop with a t return a) + nil) + +(deftest loop.8.15 + (loop with a t and b t return (list a b)) + (nil nil)) + +(deftest loop.8.16 + (loop with (a b c) of-type (fixnum float t) return (list a b c)) + (0 0.0 nil)) + +(deftest loop.8.17 + (loop with nil = nil return nil) + nil) + +;;; The NIL block of a loop encloses the entire loop. + +(deftest loop.8.18 + (loop with nil = (return t) return nil) + t) + +(deftest loop.8.19 + (loop with (nil a) = '(1 2) return a) + 2) + +(deftest loop.8.20 + (loop with (a nil) = '(1 2) return a) + 1) + +(deftest loop.8.21 + (loop with b = 3 + and (a nil) = '(1 2) return (list a b)) + (1 3)) + +(deftest loop.8.22 + (loop with b = 3 + and (nil a) = '(1 2) return (list a b)) + (2 3)) + +;;; The NIL block of a loop encloses the entire loop. + +(deftest loop.8.23 + (loop + with a = 1 + and b = (return 2) + return 3) + 2) + +;;; Error cases + +;;; The spec says (in section 6.1.1.7) that: +;;; "An error of type program-error is signaled (at macro expansion time) +;;; if the same variable is bound twice in any variable-binding clause +;;; of a single loop expression. Such variables include local variables, +;;; iteration control variables, and variables found by destructuring." +;;; +;;; This is somewhat ambiguous. Test loop.8.error.1 binds A twice in +;;; the same clause, but loop.8.error.2 binds A in two different clauses. +;;; I am interpreting the spec as ruling out the latter as well. + +(deftest loop.8.error.1 + (classify-error + (loop with a = 1 + and a = 2 return a)) + program-error) + +(deftest loop.8.error.2 + (classify-error + (loop with a = 1 + with a = 2 return a)) + program-error) diff --git a/ansi-tests/loop9.lsp b/ansi-tests/loop9.lsp new file mode 100644 index 0000000..fbf9478 --- /dev/null +++ b/ansi-tests/loop9.lsp @@ -0,0 +1,222 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Thu Nov 14 06:25:21 2002 +;;;; Contains: Tests for loop list accumulation clauses + +(in-package :cl-test) + +;;; Tests of COLLECT, COLLECTING + +(deftest loop.9.1 + (loop for x in '(2 3 4) collect (1+ x)) + (3 4 5)) + +(deftest loop.9.2 + (loop for x in '(2 3 4) collecting (1+ x)) + (3 4 5)) + +(deftest loop.9.3 + (loop for x in '(0 1 2) + when (eql x 2) do (return 'good) + collect x) + good) + +(deftest loop.9.4 + (loop for x in '(a b c) + collect (list x) into foo + finally (return (reverse foo))) + ((c) (b) (a))) + +(deftest loop.9.5 + (loop for x in '(a b c) + collecting (list x) into foo + finally (return (reverse foo))) + ((c) (b) (a))) + +(deftest loop.9.6 + (loop for x from 1 to 10 + when (evenp x) collect x into foo + when (oddp x) collect x into bar + finally (return (list foo bar))) + ((2 4 6 8 10) (1 3 5 7 9))) + +(deftest loop.9.7 + (loop for x from 1 to 10 + collect (if (> x 5) (loop-finish) x)) + (1 2 3 4 5)) + +(deftest loop.9.8 + (loop for x from 1 to 20 + when (eql (mod x 5) 0) collect x into foo + when (eql (mod x 5) 2) collect x into foo + finally (return foo)) + (2 5 7 10 12 15 17 20)) + +(deftest loop.9.9 + (loop for x from 1 to 20 + when (eql (mod x 5) 0) collecting x into foo + when (eql (mod x 5) 2) collecting x into foo + finally (return foo)) + (2 5 7 10 12 15 17 20)) + +(deftest loop.9.10 + (classify-error + (loop with foo = '(a b) + for x in '(c d) collect x into foo + finally (return foo))) + program-error) + +(deftest loop.9.11 + (classify-error + (loop with foo = '(a b) + for x in '(c d) collecting x into foo + finally (return foo))) + program-error) + +(deftest loop.9.12 + (let ((foo '(a b))) + (values + (loop for x in '(c d e) collect x into foo finally (return foo)) + foo)) + (c d e) + (a b)) + +;;; Tests of APPEND, APPENDING + +(deftest loop.9.20 + (loop for x in '((a b) (c d) (e f g) () (i)) append x) + (a b c d e f g i)) + +(deftest loop.9.21 + (loop for x in '((a b) (c d) (e f g) () (i)) appending x) + (a b c d e f g i)) + +(deftest loop.9.22 + (loop for x in '((a) (b) (c . whatever)) append x) + (a b c . whatever)) + +(deftest loop.9.23 + (loop for x in '((a) (b) (c . whatever)) appending x) + (a b c . whatever)) + +(deftest loop.9.24 + (loop for x in '(a b c d) + append (list x) + when (eq x 'b) append '(1 2 3) + when (eq x 'd) appending '(4 5 6)) + (a b 1 2 3 c d 4 5 6)) + +(deftest loop.9.25 + (let (z) + (values + (loop for x in '((a) (b) (c) (d)) + append x into foo + finally (setq z foo)) + z)) + nil + (a b c d)) + +(deftest loop.9.26 + (loop for x in '((a) (b) (c) (d)) + for i from 1 + append x into foo + append x into foo + appending (list i) into foo + finally (return foo)) + (a a 1 b b 2 c c 3 d d 4)) + +(deftest loop.9.27 + (classify-error + (loop with foo = '(a b) + for x in '(c d) append (list x) into foo + finally (return foo))) + program-error) + +(deftest loop.9.28 + (classify-error + (loop with foo = '(a b) + for x in '(c d) appending (list x) into foo + finally (return foo))) + program-error) + + +;;; NCONC, NCONCING + +(deftest loop.9.30 + (loop for x in '((a b) (c d) (e f g) () (i)) nconc (copy-seq x)) + (a b c d e f g i)) + +(deftest loop.9.31 + (loop for x in '((a b) (c d) (e f g) () (i)) nconcing (copy-seq x)) + (a b c d e f g i)) + +(deftest loop.9.32 + (loop for x in '((a) (b) (c . whatever)) nconc (cons (car x) (cdr x))) + (a b c . whatever)) + +(deftest loop.9.33 + (loop for x in '((a) (b) (c . whatever)) nconcing (cons (car x) (cdr x))) + (a b c . whatever)) + +(deftest loop.9.34 + (loop for x in '(a b c d) + nconc (list x) + when (eq x 'b) nconc (copy-seq '(1 2 3)) + when (eq x 'd) nconcing (copy-seq '(4 5 6))) + (a b 1 2 3 c d 4 5 6)) + +(deftest loop.9.35 + (let (z) + (values + (loop for x in '((a) (b) (c) (d)) + nconc (copy-seq x) into foo + finally (setq z foo)) + z)) + nil + (a b c d)) + +(deftest loop.9.36 + (loop for x in '((a) (b) (c) (d)) + for i from 1 + nconc (copy-seq x) into foo + nconc (copy-seq x) into foo + nconcing (list i) into foo + finally (return foo)) + (a a 1 b b 2 c c 3 d d 4)) + +(deftest loop.9.37 + (classify-error + (loop with foo = '(a b) + for x in '(c d) nconc (list x) into foo + finally (return foo))) + program-error) + +(deftest loop.9.38 + (classify-error + (loop with foo = '(a b) + for x in '(c d) nconcing (list x) into foo + finally (return foo))) + program-error) + +;;; Combinations + +(deftest loop.9.40 + (loop for x in '(1 2 3 4 5 6 7) + if (< x 2) append (list x) + else if (< x 5) nconc (list (1+ x)) + else collect (+ x 2)) + (1 3 4 5 7 8 9)) + +(deftest loop.9.41 + (loop for x in '(1 2 3 4 5 6 7) + if (< x 2) append (list x) into foo + else if (< x 5) nconc (list (1+ x)) into foo + else collect (+ x 2) into foo + finally (return foo)) + (1 3 4 5 7 8 9)) + +;;; More nconc tests + +(deftest loop.9.42 + (loop for x in '(a b c d e) nconc (cons x 'foo)) + (a b c d e . foo)) diff --git a/ansi-tests/macrolet.lsp b/ansi-tests/macrolet.lsp new file mode 100644 index 0000000..1b92b7e --- /dev/null +++ b/ansi-tests/macrolet.lsp @@ -0,0 +1,160 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Oct 9 19:41:24 2002 +;;;; Contains: Tests of MACROLET + +(in-package :cl-test) + +(deftest macrolet.1 + (let ((z (list 3 4))) + (macrolet ((%m (x) `(car ,x))) + (let ((y (list 1 2))) + (values (%m y) (%m z))))) + 1 3) + +(deftest macrolet.2 + (let ((z (list 3 4))) + (macrolet ((%m (x) `(car ,x))) + (let ((y (list 1 2))) + (values + (setf (%m y) 6) + (setf (%m z) 'a) + y z)))) + 6 a (6 2) (a 4)) + + +;;; Inner definitions shadow outer ones +(deftest macrolet.3 + (macrolet ((%m (w) `(cadr ,w))) + (let ((z (list 3 4))) + (macrolet ((%m (x) `(car ,x))) + (let ((y (list 1 2))) + (values + (%m y) (%m z) + (setf (%m y) 6) + (setf (%m z) 'a) + y z))))) + 1 3 6 a (6 2) (a 4)) + +;;; &whole parameter +(deftest macrolet.4 + (let ((x nil)) + (macrolet ((%m (&whole w arg) + `(progn (setq x (quote ,w)) + ,arg))) + (values (%m 1) x))) + 1 (%m 1)) + +;;; &whole parameter (nested, destructuring; see section 3.4.4) +(deftest macrolet.5 + (let ((x nil)) + (macrolet ((%m ((&whole w arg)) + `(progn (setq x (quote ,w)) + ,arg))) + (values (%m (1)) x))) + 1 (1)) + +;;; key parameter +(deftest macrolet.6 + (let ((x nil)) + (macrolet ((%m (&key (a 'xxx) b) + `(setq x (quote ,a)))) + + (values (%m :a foo) x + (%m :b bar) x))) + foo foo xxx xxx) + +;;; nested key parameters +(deftest macrolet.7 + (let ((x nil)) + (macrolet ((%m ((&key a b)) + `(setq x (quote ,a)))) + + (values (%m (:a foo)) x + (%m (:b bar)) x))) + foo foo nil nil) + +;;; nested key parameters +(deftest macrolet.8 + (let ((x nil)) + (macrolet ((%m ((&key (a 10) b)) + `(setq x (quote ,a)))) + + (values (%m (:a foo)) x + (%m (:b bar)) x))) + foo foo 10 10) + +;;; keyword parameter with supplied-p parameter +(deftest macrolet.9 + (let ((x nil)) + (macrolet ((%m (&key (a 'xxx a-p) b) + `(setq x (quote ,(list a (not (not a-p))))))) + + (values (%m :a foo) x + (%m :b bar) x))) + (foo t) (foo t) (xxx nil) (xxx nil)) + + +;;; rest parameter +(deftest macrolet.10 + (let ((x nil)) + (macrolet ((%m (b &rest a) + `(setq x (quote ,a)))) + (values (%m a1 a2) x))) + (a2) (a2)) + +;;; rest parameter w. destructuring +(deftest macrolet.11 + (let ((x nil)) + (macrolet ((%m ((b &rest a)) + `(setq x (quote ,a)))) + (values (%m (a1 a2)) x))) + (a2) (a2)) + +;;; rest parameter w. whole +(deftest macrolet.12 + (let ((x nil)) + (macrolet ((%m (&whole w b &rest a) + `(setq x (quote ,(list a w))))) + (values (%m a1 a2) x))) + ((a2) (%m a1 a2)) + ((a2) (%m a1 a2))) + +;;; Interaction with symbol-macrolet + +(deftest macrolet.13 + (symbol-macrolet ((a b)) + (macrolet ((foo (x &environment env) + (let ((y (macroexpand x env))) + (if (eq y 'a) 1 2)))) + (foo a))) + 2) + +(deftest macrolet.14 + (symbol-macrolet ((a b)) + (macrolet ((foo (x &environment env) + (let ((y (macroexpand-1 x env))) + (if (eq y 'a) 1 2)))) + (foo a))) + 2) + +(deftest macrolet.15 + (macrolet ((nil () ''a)) + (nil)) + a) + +(deftest macrolet.16 + (loop for s in *cl-non-function-macro-special-operator-symbols* + for form = `(classify-error (macrolet ((,s () ''a)) (,s))) + unless (eq (eval form) 'a) + collect s) + nil) + +;;; Symbol-macrolet tests + +(deftest symbol-macrolet.1 + (loop for s in *cl-non-variable-constant-symbols* + for form = `(classify-error (symbol-macrolet ((,s 17)) ,s)) + unless (eql (eval form) 17) + collect s) + nil) diff --git a/ansi-tests/make-array.lsp b/ansi-tests/make-array.lsp new file mode 100644 index 0000000..761b860 --- /dev/null +++ b/ansi-tests/make-array.lsp @@ -0,0 +1,670 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Sep 20 06:47:37 2002 +;;;; Contains: Tests for MAKE-ARRAY + +(in-package :cl-test) + +;;; See array-aux.lsp for auxiliary functions + +(deftest make-array.1 + (let ((a (make-array-with-checks 10))) + (and (symbolp a) a)) + nil) + +(deftest make-array.1a + (let ((a (make-array-with-checks '(10)))) + (and (symbolp a) a)) + nil) + +(deftest make-array.2 + (make-array-with-checks 3 :initial-element 'z) + #(z z z)) + +(deftest make-array.2a + (make-array-with-checks 3 :initial-contents '(a b c)) + #(a b c)) + +(deftest make-array.2b + (make-array-with-checks 3 :initial-contents #(a b c)) + #(a b c)) + +(deftest make-array.2c + (make-array-with-checks 3 :initial-contents "abc") + #(#\a #\b #\c)) + +(deftest make-array.2d + (make-array-with-checks 3 :initial-contents #*010) + #(0 1 0)) + +(deftest make-array.3 + (let ((a (make-array-with-checks 5 :element-type 'bit))) + (and (symbolp a) a)) + nil) + +(deftest make-array.4 + (make-array-with-checks 5 :element-type 'bit :initial-element 1) + #*11111) + +(deftest make-array.4a + (make-array-with-checks 5 :element-type 'bit :initial-contents '(1 0 0 1 0)) + #*10010) + +(deftest make-array.4b + (make-array-with-checks 5 :element-type 'bit :initial-contents #(1 0 0 1 0)) + #*10010) + +(deftest make-array.4c + (make-array-with-checks 5 :element-type 'bit :initial-contents #*10010) + #*10010) + +(deftest make-array.5 + (let ((a (make-array-with-checks 4 :element-type 'character))) + (and (symbolp a) a)) + nil) + +(deftest make-array.5a + (let ((a (make-array-with-checks '(4) :element-type 'character))) + (and (symbolp a) a)) + nil) + +(deftest make-array.6 + (make-array-with-checks 4 :element-type 'character + :initial-element #\x) + "xxxx") + +(deftest make-array.6a + (make-array-with-checks 4 :element-type 'character + :initial-contents '(#\a #\b #\c #\d)) + "abcd") + +(deftest make-array.6b + (make-array-with-checks 4 :element-type 'character + :initial-contents "abcd") + "abcd") + +(deftest make-array.7 + (make-array-with-checks 5 :element-type 'symbol + :initial-element 'a) + #(a a a a a)) + +(deftest make-array.7a + (make-array-with-checks 5 :element-type 'symbol + :initial-contents '(a b c d e)) + #(a b c d e)) + +(deftest make-array.7b + (make-array-with-checks '(5) :element-type 'symbol + :initial-contents '(a b c d e)) + #(a b c d e)) + +(deftest make-array.8 + (let ((a (make-array-with-checks 8 :element-type '(integer 0 (256))))) + (and (symbolp a) a)) + nil) + +(deftest make-array.8a + (make-array-with-checks 8 :element-type '(integer 0 (256)) + :initial-element 9) + #(9 9 9 9 9 9 9 9)) + +(deftest make-array.8b + (make-array-with-checks '(8) :element-type '(integer 0 (256)) + :initial-contents '(4 3 2 1 9 8 7 6)) + #(4 3 2 1 9 8 7 6)) + +;;; Zero dimensional arrays + +(deftest make-array.9 + (let ((a (make-array-with-checks nil))) + (and (symbolp a) a)) + nil) + +(deftest make-array.10 + (make-array-with-checks nil :initial-element 1) + #0a1) + +(deftest make-array.11 + (make-array-with-checks nil :initial-contents 2) + #0a2) + +(deftest make-array.12 + (make-array-with-checks nil :element-type 'bit :initial-contents 1) + #0a1) + +(deftest make-array.13 + (make-array-with-checks nil :element-type t :initial-contents 'a) + #0aa) + +;;; Higher dimensional arrays + +(deftest make-array.14 + (let ((a (make-array-with-checks '(2 3)))) + (and (symbolp a) a)) + nil) + +(deftest make-array.15 + (make-array-with-checks '(2 3) :initial-element 'x) + #2a((x x x) (x x x))) + +(deftest make-array.16 + (equalpt (make-array-with-checks '(0 0)) + (read-from-string "#2a()")) + t) + +(deftest make-array.17 + (make-array-with-checks '(2 3) :initial-contents '((a b c) (d e f))) + #2a((a b c) (d e f))) + +(deftest make-array.18 + (make-array-with-checks '(2 3) :initial-contents '(#(a b c) #(d e f))) + #2a((a b c) (d e f))) + +(deftest make-array.19 + (make-array-with-checks '(4) :initial-contents + (make-array '(10) :initial-element 1 + :fill-pointer 4)) + #(1 1 1 1)) + +(deftest make-array.20 + (let ((a (make-array '(10) :initial-element 1 + :fill-pointer 4))) + (make-array-with-checks '(3 4) :initial-contents + (list a a a))) + #2a((1 1 1 1) (1 1 1 1) (1 1 1 1))) + +(deftest make-array.21 + (make-array-with-checks '(3 4) :initial-contents + (make-array '(10) :initial-element '(1 2 3 4) + :fill-pointer 3)) + #2a((1 2 3 4) (1 2 3 4) (1 2 3 4))) + +(deftest make-array.22 + (loop for i from 3 below (min array-rank-limit 128) + always + (equalpt (make-array-with-checks (make-list i :initial-element 0)) + (read-from-string (format nil "#~Aa()" i)))) + t) + +(deftest make-array.23 + (let ((len (1- array-rank-limit))) + (equalpt (make-array-with-checks (make-list len :initial-element 0)) + (read-from-string (format nil "#~Aa()" len)))) + t) + +(deftest make-array.24 + (make-array-with-checks '(5) :initial-element 'a :displaced-to nil) + #(a a a a a)) + +(deftest make-array.25 + (make-array '(4) :initial-element 'x :nonsense-argument t + :allow-other-keys t) + #(x x x x)) + +(deftest make-array.26 + (make-array '(4) :initial-element 'x + :allow-other-keys nil) + #(x x x x)) + +(deftest make-array.27 + (make-array '(4) :initial-element 'x + :allow-other-keys t + :allow-other-keys nil + :nonsense-argument t) + #(x x x x)) + +(deftest make-array.28 + (let ((*package* (find-package :cl-test))) + (let ((len (1- (min 10000 array-rank-limit)))) + (equalpt (make-array (make-list len :initial-element 1) :initial-element 'x) + (read-from-string (concatenate + 'string + (format nil "#~dA" len) + (make-string len :initial-element #\() + "x" + (make-string len :initial-element #\))))))) + t) + +(deftest make-array.29 + (make-array-with-checks '(5) :element-type '(integer 0 (256)) + :initial-contents '(0 5 255 119 57)) + #(0 5 255 119 57)) + +(deftest make-array.30 + (make-array-with-checks '(5) :element-type '(integer -128 127) + :initial-contents '(-10 5 -128 86 127)) + #(-10 5 -128 86 127)) + +(deftest make-array.31 + (make-array-with-checks '(5) :element-type '(integer 0 (65536)) + :initial-contents '(0 100 65535 7623 13)) + #(0 100 65535 7623 13)) + +(deftest make-array.32 + (make-array-with-checks '(5) :element-type 'fixnum + :initial-contents '(1 2 3 4 5)) + #(1 2 3 4 5)) + +(deftest make-array.33 + (make-array-with-checks '(5) :element-type 'short-float + :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0)) + #(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0)) + +(deftest make-array.34 + (make-array-with-checks '(5) :element-type 'single-float + :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0)) + #(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0)) + +(deftest make-array.35 + (make-array-with-checks '(5) :element-type 'double-float + :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0)) + #(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0)) + +(deftest make-array.36 + (make-array-with-checks '(5) :element-type 'long-float + :initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0)) + #(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0)) + + +;;; Adjustable arrays + +(deftest make-array.adjustable.1 + (let ((a (make-array-with-checks '(10) :adjustable t))) + (and (symbolp a) a)) + nil) + +(deftest make-array.adjustable.2 + (make-array-with-checks '(4) :adjustable t + :initial-element 6) + #(6 6 6 6)) + +(deftest make-array.adjustable.3 + (make-array-with-checks nil :adjustable t :initial-element 7) + #0a7) + +(deftest make-array.adjustable.4 + (make-array-with-checks '(2 3) :adjustable t :initial-element 7) + #2a((7 7 7) (7 7 7))) + +(deftest make-array.adjustable.5 + (make-array-with-checks '(2 3) :adjustable t + :initial-contents '((1 2 3) "abc")) + #2a((1 2 3) (#\a #\b #\c))) + +(deftest make-array.adjustable.6 + (make-array-with-checks '(4) :adjustable t + :initial-contents '(a b c d)) + #(a b c d)) + +(deftest make-array.adjustable.7 + (make-array-with-checks '(4) :adjustable t + :fill-pointer t + :initial-contents '(a b c d)) + #(a b c d)) + +(deftest make-array.adjustable.8 + (make-array-with-checks '(4) :adjustable t + :element-type '(integer 0 (256)) + :initial-contents '(1 4 7 9)) + #(1 4 7 9)) + +(deftest make-array.adjustable.9 + (make-array-with-checks '(4) :adjustable t + :element-type 'base-char + :initial-contents "abcd") + "abcd") + +(deftest make-array.adjustable.10 + (make-array-with-checks '(4) :adjustable t + :element-type 'bit + :initial-contents '(0 1 1 0)) + #*0110) + +(deftest make-array.adjustable.11 + (make-array-with-checks '(4) :adjustable t + :element-type 'symbol + :initial-contents '(a b c d)) + #(a b c d)) + +;;; Displaced arrays + +(deftest make-array.displaced.1 + (let ((a (make-array '(10) :initial-contents '(a b c d e f g h i j)))) + (make-array-with-checks '(5) :displaced-to a)) + #(a b c d e)) + +(deftest make-array.displaced.2 + (let ((a (make-array '(10) :initial-contents '(a b c d e f g h i j)))) + (make-array-with-checks '(5) :displaced-to a + :displaced-index-offset 3)) + #(d e f g h)) + +(deftest make-array.displaced.3 + (let ((a (make-array '(10) :initial-contents '(a b c d e f g h i j)))) + (make-array-with-checks '(5) :displaced-to a + :displaced-index-offset 5)) + #(f g h i j)) + +(deftest make-array.displaced.4 + (let ((a (make-array '(10) :initial-contents '(a b c d e f g h i j)))) + (make-array-with-checks '(0) :displaced-to a + :displaced-index-offset 10)) + #()) + +(deftest make-array.displaced.5 + (let ((a (make-array '(10) :element-type '(integer 0 (256)) + :initial-contents '(1 3 5 7 9 11 13 15 17 19)))) + (make-array-with-checks '(5) :element-type '(integer 0 (256)) + :displaced-to a)) + #(1 3 5 7 9)) + +(deftest make-array.displaced.6 + (let ((a (make-array '(10) :element-type '(integer 0 (256)) + :initial-contents '(1 3 5 7 9 11 13 15 17 19)))) + (loop for i from 0 to 5 collect + (make-array-with-checks '(5) :element-type '(integer 0 (256)) + :displaced-to a + :displaced-index-offset i))) + (#(1 3 5 7 9) + #(3 5 7 9 11) + #(5 7 9 11 13) + #(7 9 11 13 15) + #(9 11 13 15 17) + #(11 13 15 17 19))) + +(deftest make-array.displaced.7 + (let ((a (make-array '(10) :element-type '(integer 0 (256)) + :initial-contents '(1 3 5 7 9 11 13 15 17 19)))) + (make-array-with-checks '(0) :element-type '(integer 0 (256)) + :displaced-to a + :displaced-index-offset 10)) + #()) + +(deftest make-array.displaced.8 + (let ((a (make-array '(10) :element-type 'bit + :initial-contents '(0 1 1 0 1 1 1 0 1 0)))) + (make-array-with-checks '(5) :element-type 'bit + :displaced-to a)) + #*01101) + +(deftest make-array.displaced.9 + (let ((a (make-array '(10) :element-type 'bit + :initial-contents '(0 1 1 0 1 1 1 0 1 0)))) + (loop for i from 0 to 5 collect + (make-array-with-checks '(5) :element-type 'bit + :displaced-to a + :displaced-index-offset i))) + (#*01101 #*11011 #*10111 #*01110 #*11101 #*11010)) + +(deftest make-array.displaced.10 + (let ((a (make-array '(10) :element-type 'bit + :initial-contents '(0 1 1 0 1 1 1 0 1 0)))) + (make-array-with-checks '(0) :element-type 'bit + :displaced-to a + :displaced-index-offset 10)) + #*) + +(deftest make-array.displaced.11 + (let ((a (make-array '(10) :element-type 'base-char + :initial-contents "abcdefghij"))) + (make-array-with-checks '(5) :element-type 'base-char + :displaced-to a)) + "abcde") + +(deftest make-array.displaced.12 + (let ((a (make-array '(10) :element-type 'base-char + :initial-contents "abcdefghij"))) + (loop for i from 0 to 5 collect + (make-array-with-checks '(5) :element-type 'base-char + :displaced-to a + :displaced-index-offset i))) + ("abcde" + "bcdef" + "cdefg" + "defgh" + "efghi" + "fghij")) + +(deftest make-array.displaced.13 + (let ((a (make-array '(10) :element-type 'base-char + :initial-contents "abcdefghij"))) + (make-array-with-checks '(0) :element-type 'base-char + :displaced-to a + :displaced-index-offset 10)) + "") + +(deftest make-array.displaced.14 + (let ((a (make-array '(10) :element-type 'character + :initial-contents "abcdefghij"))) + (make-array-with-checks '(5) :element-type 'character + :displaced-to a)) + "abcde") + +(deftest make-array.displaced.15 + (let ((a (make-array '(10) :element-type 'character + :initial-contents "abcdefghij"))) + (loop for i from 0 to 5 collect + (make-array-with-checks '(5) :element-type 'character + :displaced-to a + :displaced-index-offset i))) + ("abcde" + "bcdef" + "cdefg" + "defgh" + "efghi" + "fghij")) + +(deftest make-array.displaced.16 + (let ((a (make-array '(10) :element-type 'character + :initial-contents "abcdefghij"))) + (make-array-with-checks '(0) :element-type 'character + :displaced-to a + :displaced-index-offset 10)) + "") + +;;; Multidimensional displaced arrays + +(deftest make-array.displaced.17 + (let ((a (make-array '(3 4) :initial-contents '((1 2 3 4) (5 6 7 8) + (9 10 11 12))))) + (make-array-with-checks '(8) :displaced-to a)) + #(1 2 3 4 5 6 7 8)) + +(deftest make-array.displaced.18 + (let ((a (make-array '(3 4) :initial-contents '((1 2 3 4) (5 6 7 8) + (9 10 11 12))))) + (make-array-with-checks '(8) :displaced-to a + :displaced-index-offset 3)) + #(4 5 6 7 8 9 10 11)) + +(deftest make-array.displaced.19 + (let ((a (make-array '(3 4) :initial-contents '((1 2 3 4) (5 6 7 8) + (9 10 11 12))))) + (make-array-with-checks '(2 4) :displaced-to a + :displaced-index-offset 4)) + #2a((5 6 7 8) (9 10 11 12))) + +(deftest make-array.displaced.20 + (let ((a (make-array '(2 3 4) + :initial-contents '(((a b c d) (e f g h) (i j k l)) + ((m n o p) (q r s t) (u v w x)))))) + (make-array-with-checks '(24) :displaced-to a)) + #(a b c d e f g h i j k l m n o p q r s t u v w x)) + +(deftest make-array.displaced.21 + (let ((a (make-array '(2 3 4) + :initial-contents '(((a b c d) (e f g h) (i j k l)) + ((m n o p) (q r s t) (u v w x)))))) + (make-array-with-checks '(3 8) :displaced-to a)) + #2a((a b c d e f g h) (i j k l m n o p) (q r s t u v w x))) + +(deftest make-array.displaced.22 + (let ((a (make-array '(2 3 4) + :initial-contents '(((a b c d) (e f g h) (i j k l)) + ((m n o p) (q r s t) (u v w x)))))) + (make-array-with-checks '(10) :displaced-to a + :displaced-index-offset 5)) + #(f g h i j k l m n o)) + +(deftest make-array.displaced.23 + (let ((a (make-array '(2 3 4) + :initial-contents '(((a b c d) (e f g h) (i j k l)) + ((m n o p) (q r s t) (u v w x)))))) + (make-array-with-checks '(10) :displaced-to a + :displaced-index-offset 5 + :fill-pointer t)) + #(f g h i j k l m n o)) + +(deftest make-array.displaced.24 + (let ((a (make-array '(2 3 4) + :initial-contents '(((a b c d) (e f g h) (i j k l)) + ((m n o p) (q r s t) (u v w x)))))) + (make-array-with-checks '(10) :displaced-to a + :displaced-index-offset 5 + :fill-pointer 5)) + #(f g h i j)) + +(deftest make-array.displaced.25 + (let ((a (make-array '(2 3 4) + :initial-contents '(((a b c d) (e f g h) (i j k l)) + ((m n o p) (q r s t) (u v w x)))))) + (make-array-with-checks '(10) :displaced-to a + :displaced-index-offset 5 + :adjustable t)) + #(f g h i j k l m n o)) + +(deftest make-array.displaced.26 + (let ((a (make-array '(2 3 4) + :initial-contents '(((a b c d) (e f g h) (i j k l)) + ((m n o p) (q r s t) (u v w x)))))) + (make-array-with-checks '(10) :displaced-to a + :displaced-index-offset 5 + :fill-pointer 8 + :adjustable t)) + #(f g h i j k l m)) + +(deftest make-array.displaced.27 + (let ((a (make-array '(10) + :initial-contents '(1 2 3 4 5 6 7 8 9 10) + :fill-pointer t))) + (make-array-with-checks '(2 4) :displaced-to a)) + #2a((1 2 3 4) (5 6 7 8))) + +(deftest make-array.displaced.28 + (let ((a (make-array '(10) + :initial-contents '(1 2 3 4 5 6 7 8 9 10) + :fill-pointer 4))) + (make-array-with-checks '(2 4) :displaced-to a)) + #2a((1 2 3 4) (5 6 7 8))) + +(deftest make-array.displaced.29 + (let ((a (make-array '(10) :initial-element 0))) + (prog1 + (make-array-with-checks '(2 4) :displaced-to a) + (loop for i below 10 do (setf (aref a i) (1+ i))))) + #2a((1 2 3 4) (5 6 7 8))) + +(deftest make-array.displaced.30 + (let* ((a1 (make-array '(10) :initial-element 0)) + (a2 (make-array '(10) :displaced-to a1))) + (prog1 + (make-array-with-checks '(2 4) :displaced-to a2) + (loop for i below 10 do (setf (aref a2 i) (1+ i))))) + #2a((1 2 3 4) (5 6 7 8))) + +(deftest make-array.displaced.31 + (let* ((a1 (make-array '(10) :initial-element 0)) + (a2 (make-array '(10) :displaced-to a1))) + (prog1 + (make-array-with-checks '(2 4) :displaced-to a2) + (loop for i below 10 do (setf (aref a1 i) (1+ i))))) + #2a((1 2 3 4) (5 6 7 8))) + + +;;; Keywords tests + +(deftest make-array.allow-other-keys.1 + (make-array '(5) :initial-element 'a :allow-other-keys t) + #(a a a a a)) + +(deftest make-array.allow-other-keys.2 + (make-array '(5) :initial-element 'a :allow-other-keys nil) + #(a a a a a)) + +(deftest make-array.allow-other-keys.3 + (make-array '(5) :initial-element 'a :allow-other-keys t '#:bad t) + #(a a a a a)) + +(deftest make-array.allow-other-keys.4 + (make-array '(5) :initial-element 'a :bad t :allow-other-keys t) + #(a a a a a)) + +(deftest make-array.allow-other-keys.5 + (make-array '(5) :bad t :initial-element 'a :allow-other-keys t) + #(a a a a a)) + +(deftest make-array.allow-other-keys.6 + (make-array '(5) :bad t :initial-element 'a :allow-other-keys t + :allow-other-keys nil :also-bad nil) + #(a a a a a)) + +(deftest make-array.allow-other-keys.7 + (make-array '(5) :allow-other-keys t :initial-element 'a) + #(a a a a a)) + +(deftest make-array.keywords.8. + (make-array '(5) :initial-element 'x :initial-element 'a) + #(x x x x x)) + +;;; Error tests + +(deftest make-array.error.1 + (classify-error (make-array)) + program-error) + +(deftest make-array.error.2 + (classify-error (make-array '(10) :bad t)) + program-error) + +(deftest make-array.error.3 + (classify-error (make-array '(10) :allow-other-keys nil :bad t)) + program-error) + +(deftest make-array.error.4 + (classify-error (make-array '(10) :allow-other-keys nil + :allow-other-keys t :bad t)) + program-error) + +(deftest make-array.error.5 + (classify-error (make-array '(10) :bad)) + program-error) + +(deftest make-array.error.6 + (classify-error (make-array '(10) 1 2)) + program-error) + +;;; Order of evaluation tests + +(deftest make-array.order.1 + (let ((i 0) a b c d e) + (values + (make-array (progn (setf a (incf i)) 5) + :initial-element (progn (setf b (incf i)) 'a) + :fill-pointer (progn (setf c (incf i)) nil) + :displaced-to (progn (setf d (incf i)) nil) + :element-type (progn (setf e (incf i)) t) + ) + i a b c d e)) + #(a a a a a) 5 1 2 3 4 5) + +(deftest make-array.order.2 + (let ((i 0) a b c d e) + (values + (make-array (progn (setf a (incf i)) 5) + :element-type (progn (setf b (incf i)) t) + :displaced-to (progn (setf c (incf i)) nil) + :fill-pointer (progn (setf d (incf i)) nil) + :initial-element (progn (setf e (incf i)) 'a) + ) + i a b c d e)) + #(a a a a a) 5 1 2 3 4 5) diff --git a/ansi-tests/make-hash-table.lsp b/ansi-tests/make-hash-table.lsp new file mode 100644 index 0000000..b6750ef --- /dev/null +++ b/ansi-tests/make-hash-table.lsp @@ -0,0 +1,16 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Jan 26 21:36:33 2003 +;;;; Contains: Tests for MAKE-HASH-TABLE + +(in-package :cl-test) +#| +(deftest make-hash-table.1 + (let ((ht (make-hash-table))) + (values + (check-values (typep ht 'hash-table)) + (notnot (check-values (hash-table-p ht))) + (check-values (hash-table-count ht)) +|# + + diff --git a/ansi-tests/make-sequence.lsp b/ansi-tests/make-sequence.lsp new file mode 100644 index 0000000..dd8101c --- /dev/null +++ b/ansi-tests/make-sequence.lsp @@ -0,0 +1,273 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Sep 14 09:58:47 2002 +;;;; Contains: Tests for MAKE-SEQUENCE + +(in-package :cl-test) + +(deftest make-sequence.1 + (let ((x (make-sequence 'list 4))) + (and (eql (length x) 4) + (listp x) + (loop for e in x always (eql (car x) e)) + t)) + t) + +(deftest make-sequence.2 + (make-sequence 'list 4 :initial-element 'a) + (a a a a)) + +(deftest make-sequence.3 + (let ((x (make-sequence 'cons 4))) + (and (eql (length x) 4) + (listp x) + (loop for e in x always (eql (car x) e)) + t)) + t) + +(deftest make-sequence.4 + (make-sequence 'cons 4 :initial-element 'a) + (a a a a)) + +(deftest make-sequence.5 + (make-sequence 'string 10 :initial-element #\a) + "aaaaaaaaaa") + +(deftest make-sequence.6 + (let ((s (make-sequence 'string 10))) + (and (eql (length s) 10) + (loop for e across s always (eql e (aref s 0))) + t)) + t) + +(deftest make-sequence.7 + (make-sequence 'simple-string 10 :initial-element #\a) + "aaaaaaaaaa") + +(deftest make-sequence.8 + (let ((s (make-sequence 'simple-string 10))) + (and (eql (length s) 10) + (loop for e across s always (eql e (aref s 0))) + t)) + t) + +(deftest make-sequence.9 + (make-sequence 'null 0) + nil) + +(deftest make-sequence.10 + (let ((x (make-sequence 'vector 10))) + (and (eql (length x) 10) + (loop for e across x always (eql e (aref x 0))) + t)) + t) + +(deftest make-sequence.11 + (let* ((u (list 'a)) + (x (make-sequence 'vector 10 :initial-element u))) + (and (eql (length x) 10) + (loop for e across x always (eql e u)) + t)) + t) + +(deftest make-sequence.12 + (let ((x (make-sequence 'simple-vector 10))) + (and (eql (length x) 10) + (loop for e across x always (eql e (aref x 0))) + t)) + t) + +(deftest make-sequence.13 + (let* ((u (list 'a)) + (x (make-sequence 'simple-vector 10 :initial-element u))) + (and (eql (length x) 10) + (loop for e across x always (eql e u)) + t)) + t) + +(deftest make-sequence.14 + (let ((x (make-sequence '(vector *) 10))) + (and (eql (length x) 10) + (loop for e across x always (eql e (aref x 0))) + t)) + t) + +(deftest make-sequence.15 + (let* ((u (list 'a)) + (x (make-sequence '(vector *) 10 :initial-element u))) + (and (eql (length x) 10) + (loop for e across x always (eql e u)) + t)) + t) + +(deftest make-sequence.16 + (let ((x (make-sequence '(simple-vector *) 10))) + (and (eql (length x) 10) + (loop for e across x always (eql e (aref x 0))) + t)) + t) + +(deftest make-sequence.17 + (let* ((u (list 'a)) + (x (make-sequence '(simple-vector *) 10 :initial-element u))) + (and (eql (length x) 10) + (loop for e across x always (eql e u)) + t)) + t) + +(deftest make-sequence.18 + (let ((x (make-sequence '(string *) 10))) + (and (eql (length x) 10) + (loop for e across x always (eql e (aref x 0))) + t)) + t) + +(deftest make-sequence.19 + (let* ((u #\a) + (x (make-sequence '(string *) 10 :initial-element u))) + (and (eql (length x) 10) + (loop for e across x always (eql e u)) + t)) + t) + +(deftest make-sequence.20 + (let ((x (make-sequence '(simple-string *) 10))) + (and (eql (length x) 10) + (loop for e across x always (eql e (aref x 0))) + t)) + t) + +(deftest make-sequence.21 + (let* ((u #\a) + (x (make-sequence '(simple-string *) 10 :initial-element u))) + (and (eql (length x) 10) + (loop for e across x always (eql e u)) + t)) + t) + +(deftest make-sequence.22 + (make-sequence '(vector * 5) 5 :initial-element 'a) + #(a a a a a)) + +(deftest make-sequence.23 + (make-sequence '(vector fixnum 5) 5 :initial-element 1) + #(1 1 1 1 1)) + +(deftest make-sequence.24 + (make-sequence '(vector (integer 0 255) 5) 5 :initial-element 17) + #(17 17 17 17 17)) + +(deftest make-sequence.25 + (make-sequence '(simple-vector 5) 5 :initial-element 'a) + #(a a a a a)) + +(deftest make-sequence.26 + (equalp (make-sequence 'string 5) (make-string 5)) + t) + +;;; Keyword tests + +(deftest make-sequence.allow-other-keys.1 + (make-sequence 'list 5 :allow-other-keys t :initial-element 'a :bad t) + (a a a a a)) + +(deftest make-sequence.allow-other-keys.2 + (make-sequence 'list 5 :initial-element 'a :bad t :allow-other-keys t) + (a a a a a)) + +(deftest make-sequence.allow-other-keys.3 + (make-sequence 'list 5 :initial-element 'a :allow-other-keys t) + (a a a a a)) + +(deftest make-sequence.allow-other-keys.4 + (make-sequence 'list 5 :initial-element 'a :allow-other-keys nil) + (a a a a a)) + +(deftest make-sequence.allow-other-keys.5 + (make-sequence 'list 5 :initial-element 'a :allow-other-keys t + :allow-other-keys nil :bad t) + (a a a a a)) + +(deftest make-sequence.keywords.6 + (make-sequence 'list 5 :initial-element 'a :initial-element 'b) + (a a a a a)) + +;;; Tests for errors + +(deftest make-sequence.error.1 + (classify-error (make-sequence 'symbol 10)) + type-error) + +(deftest make-sequence.error.2 + (classify-error (make-sequence 'null 1)) + type-error) + +(deftest make-sequence.error.3 + (classify-error (make-sequence '(vector * 4) 3)) + type-error) + +(deftest make-sequence.error.4 + (classify-error (make-sequence '(vector * 2) 3)) + type-error) + +(deftest make-sequence.error.5 + (classify-error (make-sequence '(string 4) 3)) + type-error) + +(deftest make-sequence.error.6 + (classify-error (make-sequence '(simple-string 2) 3)) + type-error) + +(deftest make-sequence.error.7 + (classify-error (make-sequence 'cons 0)) + type-error) + +(deftest make-sequence.error.8 + (classify-error (make-sequence)) + program-error) + +(deftest make-sequence.error.9 + (classify-error (make-sequence 'list)) + program-error) + +(deftest make-sequence.error.10 + (classify-error (make-sequence 'list 10 :bad t)) + program-error) + +(deftest make-sequence.error.11 + (classify-error (make-sequence 'list 10 :bad t :allow-other-keys nil)) + program-error) + +(deftest make-sequence.error.12 + (classify-error (make-sequence 'list 10 :initial-element)) + program-error) + +(deftest make-sequence.error.13 + (classify-error (make-sequence 'list 10 0 0)) + program-error) + +(deftest make-sequence.error.14 + (classify-error (locally (make-sequence 'symbol 10) t)) + type-error) + +;;; Order of execution tests + +(deftest make-sequence.order.1 + (let ((i 0) a b c) + (values + (make-sequence (progn (setf a (incf i)) 'list) + (progn (setf b (incf i)) 5) + :initial-element (progn (setf c (incf i)) 'a)) + i a b c)) + (a a a a a) 3 1 2 3) + +(deftest make-sequence.order.2 + (let ((i 0) a b c d e) + (values + (make-sequence (progn (setf a (incf i)) 'list) + (progn (setf b (incf i)) 5) + :allow-other-keys (setf c (incf i)) + :initial-element (progn (setf d (incf i)) 'a) + :foo (setf e (incf i))) + i a b c d e)) + (a a a a a) 5 1 2 3 4 5) diff --git a/ansi-tests/make-string.lsp b/ansi-tests/make-string.lsp new file mode 100644 index 0000000..160f05e --- /dev/null +++ b/ansi-tests/make-string.lsp @@ -0,0 +1,163 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Oct 5 12:32:20 2002 +;;;; Contains: Tests for MAKE-STRING + +(in-package :cl-test) + +(deftest make-string.1 + (let ((s (make-string 10))) + (and (stringp s) + ;; (string-all-the-same s) + (eqlt (length s) 10) + )) + t) + +(deftest make-string.2 + (let ((s (make-string 10 :initial-element #\a))) + (and (stringp s) + (eql (length s) 10) + s)) + "aaaaaaaaaa") + +(deftest make-string.3 + (let ((s (make-string 10 :initial-element #\a + :element-type 'character))) + (and (stringp s) + (eql (length s) 10) + s)) + "aaaaaaaaaa") + +(deftest make-string.4 + (let ((s (make-string 10 :initial-element #\a + :element-type 'standard-char))) + (and (stringp s) + (eql (length s) 10) + s)) + "aaaaaaaaaa") + +(deftest make-string.5 + (let ((s (make-string 10 :initial-element #\a + :element-type 'base-char))) + (and (stringp s) + (eql (length s) 10) + s)) + "aaaaaaaaaa") + +(deftest make-string.6 + (make-string 0) + "") + +(deftest make-string.7 + (let ((s (make-string 10 :element-type 'character))) + (and (stringp s) + (eqlt (length s) 10) + #| (string-all-the-same s) |# + )) + t) + +(deftest make-string.8 + (let ((s (make-string 10 :element-type 'standard-char))) + (and (stringp s) + (eqlt (length s) 10) + #| (string-all-the-same s) |# + )) + t) + +(deftest make-string.9 + (let ((s (make-string 10 :element-type 'base-char))) + (and (stringp s) + (eqlt (length s) 10) + #| (string-all-the-same s) |# + )) + t) + +;;; Keyword tests +; +(deftest make-string.allow-other-keys.1 + (make-string 5 :allow-other-keys t :initial-element #\a) + "aaaaa") + +(deftest make-string.allow-other-keys.2 + (make-string 5 :initial-element #\a :allow-other-keys t) + "aaaaa") + +(deftest make-string.allow-other-keys.3 + (make-string 5 :initial-element #\a :allow-other-keys t + :bad t) + "aaaaa") + +(deftest make-string.allow-other-keys.4 + (make-string 5 :bad t :allow-other-keys t :allow-other-keys nil + :initial-element #\a) + "aaaaa") + +(deftest make-string.allow-other-keys.5 + (make-string 5 :allow-other-keys t :bad t :allow-other-keys nil + :initial-element #\a) + "aaaaa") + +(deftest make-string.allow-other-keys.6 + (make-string 5 :allow-other-keys t :allow-other-keys nil :bad nil + :initial-element #\a) + "aaaaa") + +(deftest make-string.keywords.7 + (make-string 5 :initial-element #\a :initial-element #\b) + "aaaaa") + +;; Error cases + +(deftest make-string.error.1 + (classify-error (make-string)) + program-error) + +(deftest make-string.error.2 + (classify-error (make-string 10 :bad t)) + program-error) + +(deftest make-string.error.3 + (classify-error (make-string 10 :bad t :allow-other-keys nil)) + program-error) + +(deftest make-string.error.4 + (classify-error (make-string 10 :initial-element)) + program-error) + +(deftest make-string.error.5 + (classify-error (make-string 10 1 1)) + program-error) + +(deftest make-string.error.6 + (classify-error (make-string 10 :element-type)) + program-error) + +;;; Order of evaluation + +(deftest make-string.order.1 + (let ((i 0) a b) + (values + (make-string (progn (setf a (incf i)) 4) + :initial-element (progn (setf b (incf i)) #\a)) + i a b)) + "aaaa" 2 1 2) + +(deftest make-string.order.2 + (let ((i 0) a b c) + (values + (make-string (progn (setf a (incf i)) 4) + :initial-element (progn (setf b (incf i)) #\a) + :element-type (progn (setf c (incf i)) 'base-char)) + i a b c)) + "aaaa" 3 1 2 3) + +(deftest make-string.order.3 + (let ((i 0) a b c) + (values + (make-string (progn (setf a (incf i)) 4) + :element-type (progn (setf b (incf i)) 'base-char) + :initial-element (progn (setf c (incf i)) #\a)) + i a b c)) + "aaaa" 3 1 2 3) + + diff --git a/ansi-tests/make-tar b/ansi-tests/make-tar new file mode 100755 index 0000000..cb7257b --- /dev/null +++ b/ansi-tests/make-tar @@ -0,0 +1,2 @@ +rm -f binary/* rt/binary/* +tar cvf cltest.tar README *.system *.lsp make-tar binary/ rt/*.system rt/*.lsp rt/*.txt rt/binary/ diff --git a/ansi-tests/makefile b/ansi-tests/makefile new file mode 100644 index 0000000..8c138f0 --- /dev/null +++ b/ansi-tests/makefile @@ -0,0 +1,10 @@ +-include ../makedefs + +test-unixport: + echo "(load \"gclload.lsp\")" | ../unixport/saved_ansi_gcl$(EXE) | tee test.out + +test: + echo "(load \"gclload.lsp\")" | gcl | tee test.out + +clean: + rm -f test.out *.fasl *.o *.so *~ *.fn *.x86f *.fasl *.ufsl diff --git a/ansi-tests/map-into.lsp b/ansi-tests/map-into.lsp new file mode 100644 index 0000000..cc0c1f4 --- /dev/null +++ b/ansi-tests/map-into.lsp @@ -0,0 +1,407 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Aug 18 10:10:04 2002 +;;;; Contains: Tests for the MAP-INTO function + +(in-package :cl-test) + +(deftest map-into-list.1 + (let ((a (copy-seq '(a b c d e f))) + (b nil)) + (map-into a #'(lambda (x) (push x b) x) '(1 2 3 4 5 6)) + (values a b)) + (1 2 3 4 5 6) + (6 5 4 3 2 1)) + +(deftest map-into-list.2 + (let ((a (copy-seq '(a b c d e f g)))) + (map-into a #'identity '(1 2 3)) + a) + (1 2 3 d e f g)) + +(deftest map-into-list.3 + (let ((a (copy-seq '(a b c)))) + (map-into a #'identity '(1 2 3 4 5 6)) + a) + (1 2 3)) + +(deftest map-into-list.4 + (let ((a (copy-seq '(a b c d e f))) + (b nil)) + (map-into a #'(lambda (x y) (let ((z (+ x y))) (push z b) z)) + '(1 2 3 4 5 6) + '(10 11 12 13 14 15)) + (values a b)) + (11 13 15 17 19 21) + (21 19 17 15 13 11)) + +(deftest map-into-list.5 + (let ((a (copy-seq '(a b c d e f)))) + (map-into a 'identity '(1 2 3 4 5 6)) + a) + (1 2 3 4 5 6)) + +(deftest map-into-list.6 + (let ((b nil)) + (values + (map-into nil #'(lambda (x y) (let ((z (+ x y))) (push z b) z)) + '(1 2 3 4 5 6) + '(10 11 12 13 14 15)) + b)) + nil nil) + +(deftest map-into-list.7 + (let ((a (copy-seq '(a b c d e f)))) + (map-into a #'(lambda () 1)) + a) + (1 1 1 1 1 1)) + +(deftest map-into-list.8 + (let ((a (copy-seq '(a b c d e f))) + (s2 (make-array '(6) :initial-element 'x + :fill-pointer 4))) + (map-into a #'identity s2) + a) + (x x x x e f)) + +(deftest map-into-array.1 + (let ((a (copy-seq #(a b c d e f))) + b) + (map-into a #'(lambda (x) (push x b) x) '(1 2 3 4 5 6)) + (values a b)) + #(1 2 3 4 5 6) + (6 5 4 3 2 1)) + +(deftest map-into-array.2 + (let ((a (copy-seq #(a b c d e f g h))) + b) + (map-into a #'(lambda (x) (push x b) x) '(1 2 3 4 5 6)) + (values a b)) + #(1 2 3 4 5 6 g h) + (6 5 4 3 2 1)) + +(deftest map-into-array.3 + (let ((a (copy-seq #(a b c d))) + b) + (map-into a #'(lambda (x) (push x b) x) '(1 2 3 4 5 6)) + (values a b)) + #(1 2 3 4) + (4 3 2 1)) + +(deftest map-into-array.4 + (let ((a (copy-seq #(a b c d e f))) + b) + (map-into a #'(lambda (x) (push x b) x) #(1 2 3 4 5 6)) + (values a b)) + #(1 2 3 4 5 6) + (6 5 4 3 2 1)) + +(deftest map-into-array.5 + (let ((a (copy-seq #(a b c d e f g h))) + b) + (map-into a #'(lambda (x) (push x b) x) #(1 2 3 4 5 6)) + (values a b)) + #(1 2 3 4 5 6 g h) + (6 5 4 3 2 1)) + +(deftest map-into-array.6 + (let ((a (copy-seq #(a b c d))) + b) + (map-into a #'(lambda (x) (push x b) x) #(1 2 3 4 5 6)) + (values a b)) + #(1 2 3 4) + (4 3 2 1)) + +;;; Tests of mapping into arrays with fill pointers +(deftest map-into-array.7 + (let ((a (make-array 6 :initial-element 'x + :fill-pointer 3))) + (map-into a #'identity '(1 2 3)) + a) + #(1 2 3)) + +(deftest map-into-array.8 + (let ((a (make-array 6 :initial-element 'x + :fill-pointer 3))) + (map-into a #'identity '(1 2)) + a) + #(1 2)) + +(deftest map-into-array.9 + (let ((a (make-array 6 :initial-element 'x + :fill-pointer 3))) + (map-into a #'identity '(1 2 3 4 5)) + (and (eqlt (fill-pointer a) 5) + a)) + #(1 2 3 4 5)) + +(deftest map-into-array.10 + (let ((a (make-array 6 :initial-element 'x + :fill-pointer 3))) + (map-into a #'(lambda () 'y)) + (and (eqlt (fill-pointer a) 6) + a)) + #(y y y y y y)) + +(deftest map-into-array.11 + (let ((a (copy-seq #(a b c d e f))) + (s2 (make-array '(6) :initial-element 'x + :fill-pointer 4))) + (map-into a #'identity s2) + a) + #(x x x x e f)) + +;;; mapping into strings + +(deftest map-into-string.1 + (let ((a (copy-seq "abcdef"))) + (map-into a #'identity "123456") + (values (not (not (stringp a))) a)) + t + "123456") + +(deftest map-into-string.2 + (let ((a (copy-seq "abcdef"))) + (map-into a #'identity "1234") + (values (not (not (stringp a))) a)) + t + "1234ef") + +(deftest map-into-string.3 + (let ((a (copy-seq "abcd"))) + (map-into a #'identity "123456") + (values (not (not (stringp a))) a)) + t + "1234") + +(deftest map-into-string.4 + (let ((a (make-array 6 :initial-element #\x + :element-type 'character + :fill-pointer 3))) + (map-into a #'identity "abcde") + (values + (fill-pointer a) + (aref a 5) + a)) + 5 + #\x + "abcde") + +(deftest map-into-string.5 + (let ((a (make-array 6 :initial-element #\x + :element-type 'character + :fill-pointer 3))) + (map-into a #'(lambda () #\y)) + (values (fill-pointer a) + a)) + 6 + "yyyyyy") + +(deftest map-into-string.6 + (let ((a (make-array 6 :initial-element #\x + :element-type 'character))) + (map-into a #'(lambda () #\y)) + a) + "yyyyyy") + +(deftest map-into-string.7 + (let ((a (make-array 6 :initial-element #\x + :element-type 'base-char + :fill-pointer 3))) + (map-into a #'identity "abcde") + (values (fill-pointer a) + (aref a 5) + a)) + 5 + #\x + "abcde") + +(deftest map-into-string.8 + (let ((a (make-array 6 :initial-element #\x + :element-type 'base-char + :fill-pointer 3))) + (map-into a #'(lambda () #\y)) + (values (fill-pointer a) + a)) + 6 + "yyyyyy") + +(deftest map-into-string.9 + (let ((a (make-array 6 :initial-element #\x + :element-type 'base-char))) + (map-into a #'(lambda () #\y)) + a) + "yyyyyy") + +(deftest map-into-string.10 + (let ((a (copy-seq "abcdef")) + (s2 (make-array '(6) :initial-element #\x + :fill-pointer 4))) + (map-into a #'identity s2) + a) + "xxxxef") + +(deftest map-into-string.11 + (let ((a (make-array 6 :initial-element #\x + :element-type 'character + :fill-pointer 3))) + (map-into a #'identity "abcd") + (values + (fill-pointer a) + (aref a 4) + (aref a 5) + a)) + 4 + #\x + #\x + "abcd") + +(deftest map-into-string.12 + (let ((a (make-array 6 :initial-element #\x + :element-type 'character + :fill-pointer 3))) + (map-into a #'identity "abcdefgh") + (values + (fill-pointer a) + a)) + 6 + "abcdef") + +;;; Tests on bit vectors + +(deftest map-into.bit-vector.1 + (let ((v (copy-seq #*0100110))) + (map-into v #'(lambda (x) (- 1 x)) v) + (and (bit-vector-p v) + v)) + #*1011001) + +(deftest map-into.bit-vector.2 + (let ((v (copy-seq #*0100110))) + (map-into v #'(lambda () 0)) + (and (bit-vector-p v) + v)) + #*0000000) + +(deftest map-into.bit-vector.3 + (let ((v (copy-seq #*0100110))) + (map-into v #'identity '(0 1 1 1 0 0 1)) + (and (bit-vector-p v) + v)) + #*0111001) + +(deftest map-into.bit-vector.4 + (let ((v (copy-seq #*0100110))) + (map-into v #'identity '(0 1 1 1)) + (and (bit-vector-p v) + v)) + #*0111110) + +(deftest map-into.bit-vector.5 + (let ((v (copy-seq #*0100110))) + (map-into v #'identity '(0 1 1 1 0 0 1 4 5 6 7)) + (and (bit-vector-p v) + v)) + #*0111001) + +(deftest map-into.bit-vector.6 + (let ((v (make-array '(8) :initial-contents '(0 1 0 0 1 1 0 1) + :fill-pointer 4 + :element-type 'bit))) + (map-into v #'(lambda () 1)) + (and (bit-vector-p v) + v)) + #*11111111) + +(deftest map-into.bit-vector.7 + (let ((v (make-array '(8) :initial-contents '(0 1 0 0 1 1 0 1) + :fill-pointer 4 + :element-type 'bit))) + (map-into v #'identity v) + (and (bit-vector-p v) + v)) + #*0100) + +(deftest map-into.bit-vector.8 + (let ((v (make-array '(8) :initial-contents '(0 1 0 0 1 1 0 1) + :fill-pointer 4 + :element-type 'bit))) + (map-into v #'identity '(1 1 1 1 1 1)) + (and (bit-vector-p v) + (values (fill-pointer v) + v))) + 6 + #*111111) + +(deftest map-into.bit-vector.9 + (let ((v (make-array '(8) :initial-contents '(0 1 0 0 1 1 0 1) + :fill-pointer 4 + :element-type 'bit))) + (map-into v #'identity '(1 1 1 1 1 1 0 0 1 1 1)) + (and (bit-vector-p v) + (values (fill-pointer v) + v))) + 8 + #*11111100) + + +;;; Error cases + +(deftest map-into.error.1 + (classify-error (map-into 'a #'(lambda () nil))) + type-error) + +;;; The next test was changed because if the first argument +;;; is NIL, map-into is said to 'return nil immediately', so +;;; the 'should be prepared' notation for the error checking +;;; means that error checking may be skipped. +(deftest map-into.error.2 + (case (classify-error (map-into nil #'identity 'a)) + ((nil type-error) 'good) + (t 'bad)) + good) + +(deftest map-into.error.3 + (classify-error (map-into (copy-seq '(a b c)) #'cons '(d e f) 100)) + type-error) + +(deftest map-into.error.4 + (classify-error (map-into)) + program-error) + +(deftest map-into.error.5 + (classify-error (map-into (list 'a 'b 'c))) + program-error) + +(deftest map-into.error.6 + (classify-error (locally (map-into 'a #'(lambda () nil)) t)) + type-error) + +(deftest map-into.error.7 + (classify-error (map-into (list 'a 'b 'c) #'cons '(a b c))) + program-error) + +(deftest map-into.error.8 + (classify-error (map-into (list 'a 'b 'c) #'car '(a b c))) + type-error) + +;;; Order of evaluation tests + +(deftest map-into.order.1 + (let ((i 0) a b c) + (values + (map-into (progn (setf a (incf i)) (list 1 2 3 4)) + (progn (setf b (incf i)) #'identity) + (progn (setf c (incf i)) '(a b c d))) + i a b c)) + (a b c d) 3 1 2 3) + +(deftest map-into.order.2 + (let ((i 0) a b c d) + (values + (map-into (progn (setf a (incf i)) (list 1 2 3 4)) + (progn (setf b (incf i)) #'list) + (progn (setf c (incf i)) '(a b c d)) + (progn (setf d (incf i)) '(e f g h))) + i a b c d)) + ((a e) (b f) (c g) (d h)) 4 1 2 3 4) diff --git a/ansi-tests/map.lsp b/ansi-tests/map.lsp new file mode 100644 index 0000000..11316cc --- /dev/null +++ b/ansi-tests/map.lsp @@ -0,0 +1,257 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Aug 17 20:54:48 2002 +;;;; Contains: Tests for the MAP function + +(in-package :cl-test) + +(deftest map-array.1 + (map 'list #'1+ #(1 2 3 4)) + (2 3 4 5)) + +(deftest map-array.2 + (map 'vector #'+ #(1 2 3 4) #(6 6 6 6)) + #(7 8 9 10)) + +(deftest map-array.3 + (map 'vector #'+ #(1 2 3 4 5) #(6 6 6 6)) + #(7 8 9 10)) + +(deftest map-array.4 + (map 'vector #'+ #(1 2 3 4) #(6 6 6 6 6)) + #(7 8 9 10)) + +(deftest map-array.5 + (map '(vector *) #'+ #(1 2 3 4) #(6 6 6 6)) + #(7 8 9 10)) + +(deftest map-array.6 + (map '(vector * 4) #'+ #(1 2 3 4) #(6 6 6 6)) + #(7 8 9 10)) + +;;; (deftest map-array.7 +;;; (map 'array #'identity '(a b c d e f)) +;;; #(a b c d e f)) + +;;; (deftest map-array.8 +;;; (map 'simple-array #'identity '(a b c d e f)) +;;; #(a b c d e f)) + +(deftest map-array.9 + (map 'simple-vector #'identity '(a b c d e f)) + #(a b c d e f)) + +(deftest map-array.10 + (map 'simple-vector #'cons '(a b c d e f) #(1 2 3 4 5 6)) + #((a . 1) (b . 2) (c . 3) (d . 4) (e . 5) (f . 6))) + +(deftest map-array.11 + (map 'vector #'identity '(#\a #\b #\c #\d #\e)) + #(#\a #\b #\c #\d #\e)) + +(deftest map-array.12 + (map 'vector #'identity "abcde") + #(#\a #\b #\c #\d #\e)) + +(deftest map-array.13 + (map 'vector #'identity #*000001) + #(0 0 0 0 0 1)) + +(deftest map-array.14 + (map 'list #'identity #*000001) + (0 0 0 0 0 1)) + +(deftest map-bit-vector.15 + (map 'bit-vector #'identity '(0 0 0 0 0 1)) + #*000001) + +(deftest map-bit-vector.16 + (map 'simple-bit-vector #'identity '(0 0 0 0 0 1)) + #*000001) + +(deftest map-bit-vector.17 + (map '(vector bit) #'identity '(0 0 0 0 0 1)) + #*000001) + +(deftest map-bit-vector.18 + (map '(simple-vector *) #'identity '(0 0 0 0 0 1)) + #*000001) + +(deftest map-bit-vector.19 + (map '(bit-vector 6) #'identity '(0 0 0 0 0 1)) + #*000001) + +(deftest map-bit-vector.20 + (map '(bit-vector *) #'identity '(0 0 0 0 0 1)) + #*000001) + +(deftest map-bit-vector.21 + (map '(simple-bit-vector 6) #'identity '(0 0 0 0 0 1)) + #*000001) + +(deftest map-bit-vector.22 + (map '(simple-bit-vector *) #'identity '(0 0 0 0 0 1)) + #*000001) + +(deftest map-bit-vector.23 + (map '(vector bit 6) #'identity '(0 0 0 0 0 1)) + #*000001) + +(deftest map-bit-vector.24 + (map '(vector bit *) #'identity '(0 0 0 0 0 1)) + #*000001) + +(deftest map-bit-vector.25 + (map '(simple-vector 6) #'identity '(0 0 0 0 0 1)) + #*000001) + +(deftest map-string.26 + (map 'string #'identity '(#\a #\b #\c #\d #\e)) + "abcde") + +(deftest map-string.27 + (map 'string #'identity "abcde") + "abcde") + +(deftest map-string.28 + (map '(vector character) #'identity '(#\a #\b #\c #\d #\e)) + "abcde") + +(deftest map-string.29 + (map '(vector character 5) #'identity '(#\a #\b #\c #\d #\e)) + "abcde") + +(deftest map-string.30 + (map '(simple-vector 5) #'identity '(#\a #\b #\c #\d #\e)) + "abcde") + +;;; Use a more elaborate form of the simple-array type specifier +;;; (deftest map-string.31 +;;; (map '(simple-array character *) #'identity "abcde") +;;; "abcde") + +;;; Use a more elaborate form of the simple-array type specifier +;;; (deftest map-string.32 +;;; (map '(simple-array character 5) #'identity "abcde") +;;; "abcde") + +(deftest map-nil.33 + (let ((a nil)) + (values (map nil #'(lambda (x) (push x a)) "abcdef") a)) + nil (#\f #\e #\d #\c #\b #\a)) + +(deftest map-nil.34 + (let ((a nil)) + (values (map nil #'(lambda (x) (push x a)) '(a b c d e)) a)) + nil (e d c b a)) + +(deftest map-nil.35 + (let ((a nil)) + (values (map nil #'(lambda (x) (push x a)) #(a b c d e)) a)) + nil (e d c b a)) + +(deftest map-nil.36 + (let ((a nil)) + (values (map nil #'(lambda (x) (push x a)) #*001011110) a)) + nil (0 1 1 1 1 0 1 0 0)) + +(deftest map-null.1 + (map 'null #'identity nil) + nil) + +(deftest map-cons.1 + (map 'cons #'identity '(a b c)) + (a b c)) + +(deftest map.error.1 + (handler-case (progn (proclaim '(optimize (safety 3))) + (eval '(map 'symbol #'identity '(a b c)))) + (error () :caught)) + :caught) + +(deftest map.error.2 + (classify-error (map '(vector * 8) #'identity '(a b c))) + type-error) + +(deftest map.error.3 + (classify-error (map 'list #'identity '(a b . c))) + type-error) + +(deftest map.error.4 + (classify-error (map)) + program-error) + +(deftest map.error.5 + (classify-error (map 'list)) + program-error) + +(deftest map.error.6 + (classify-error (map 'list #'null)) + program-error) + +(deftest map.error.7 + (classify-error (map 'list #'cons '(a b c d))) + program-error) + +(deftest map.error.8 + (classify-error (map 'list #'cons '(a b c d) '(1 2 3 4) '(5 6 7 8))) + program-error) + +(deftest map.error.9 + (classify-error (map 'list #'car '(a b c d))) + type-error) + + +;;; Test mapping on arrays with fill pointers + +(deftest map.fill.1 + (let ((s1 (make-array '(10) :initial-contents '(a b c d e f g h i j) + :fill-pointer 8))) + (map 'list #'identity s1)) + (a b c d e f g h)) + +(deftest map.fill.2 + (let ((s1 (make-array '(10) :initial-contents '(a b c d e f g h i j) + :fill-pointer 8))) + (map 'list #'(lambda (x y) x) '(1 2 3 4 5 6 7 8 9 10) s1)) + (1 2 3 4 5 6 7 8)) + +(deftest map.fill.3 + (let ((s1 (make-array '(10) :initial-element #\a + :element-type 'character + :fill-pointer 8))) + (map 'string #'identity s1)) + "aaaaaaaa") + +(deftest map.fill.4 + (let ((s1 (make-array '(10) :initial-element #\a + :element-type 'base-char + :fill-pointer 8))) + (map 'list #'(lambda (x y) x) '(1 2 3 4 5 6 7 8 9 10) s1)) + (1 2 3 4 5 6 7 8)) + +(deftest map.fill.5 + (let ((s1 (make-array '(10) :initial-element 0 + :element-type 'bit + :fill-pointer 8))) + (map 'bit-vector #'identity s1)) + #*00000000) + +(deftest map.fill.6 + (let ((s1 (make-array '(10) :initial-element 1 + :element-type 'bit + :fill-pointer 8))) + (map 'list #'(lambda (x y) x) '(1 2 3 4 5 6 7 8 9 10) s1)) + (1 2 3 4 5 6 7 8)) + +;;; Order of evaluation tests + +(deftest map.order.1 + (let ((i 0) a b c d) + (values + (map (progn (setf a (incf i)) 'list) + (progn (setf b (incf i)) #'list) + (progn (setf c (incf i)) '(a b c)) + (progn (setf d (incf i)) '(b c d))) + i a b c d)) + ((a b)(b c)(c d)) 4 1 2 3 4) diff --git a/ansi-tests/merge.lsp b/ansi-tests/merge.lsp new file mode 100644 index 0000000..688c8d8 --- /dev/null +++ b/ansi-tests/merge.lsp @@ -0,0 +1,572 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Sep 6 07:24:17 2002 +;;;; Contains: Tests for MERGE + +(in-package :cl-test) + +(deftest merge-list.1 + (let ((x (list 1 3 7 8 10)) + (y (list 2 4 5 8 11))) + (merge 'list x y #'<)) + (1 2 3 4 5 7 8 8 10 11)) + +(deftest merge-list.2 + (let ((x nil) + (y (list 2 4 5 8 11))) + (merge 'list x y #'<)) + (2 4 5 8 11)) + +(deftest merge-list.3 + (let ((x nil) + (y (list 2 4 5 8 11))) + (merge 'list y x #'<)) + (2 4 5 8 11)) + +(deftest merge-list.4 + (merge 'list nil nil #'<) + nil) + +(deftest merge-list.5 + (let ((x (vector 1 3 7 8 10)) + (y (list 2 4 5 8 11))) + (merge 'list x y #'<)) + (1 2 3 4 5 7 8 8 10 11)) + +(deftest merge-list.6 + (let ((x (list 1 3 7 8 10)) + (y (vector 2 4 5 8 11))) + (merge 'list x y #'<)) + (1 2 3 4 5 7 8 8 10 11)) + +(deftest merge-list.7 + (let ((x (vector 1 3 7 8 10)) + (y (vector 2 4 5 8 11))) + (merge 'list x y #'<)) + (1 2 3 4 5 7 8 8 10 11)) + +(deftest merge-list.8 + (let ((x (sort (list 1 3 7 8 10) #'>)) + (y (sort (list 2 4 5 8 11) #'>))) + (merge 'list x y #'< :key #'-)) + (11 10 8 8 7 5 4 3 2 1)) + +(deftest merge-list.9 + (let ((x (list 1 3 7 8 10)) + (y (list 2 4 5 8 11))) + (merge 'list x y #'< :key nil)) + (1 2 3 4 5 7 8 8 10 11)) + +(deftest merge-list.10 + (let ((x (list 1 3 7 8 10)) + (y (list 2 4 5 8 11))) + (merge 'list x y '<)) + (1 2 3 4 5 7 8 8 10 11)) + +(deftest merge-list.11 + (let ((x (vector)) (y (vector))) + (merge 'list x y #'<)) + nil) + +(deftest merge-list.12 + (let ((x nil) (y (vector 1 2 3))) + (merge 'list x y #'<)) + (1 2 3)) + +(deftest merge-list.13 + (let ((x (vector)) (y (list 1 2 3))) + (merge 'list x y #'<)) + (1 2 3)) + +(deftest merge-list.14 + (let ((x nil) (y (vector 1 2 3))) + (merge 'list y x #'<)) + (1 2 3)) + +(deftest merge-list.15 + (let ((x (vector)) (y (list 1 2 3))) + (merge 'list y x #'<)) + (1 2 3)) + +;;; Tests yielding vectors + +(deftest merge-vector.1 + (let ((x (list 1 3 7 8 10)) + (y (list 2 4 5 8 11))) + (merge 'vector x y #'<)) + #(1 2 3 4 5 7 8 8 10 11)) + +(deftest merge-vector.2 + (let ((x nil) + (y (list 2 4 5 8 11))) + (merge 'vector x y #'<)) + #(2 4 5 8 11)) + +(deftest merge-vector.3 + (let ((x nil) + (y (list 2 4 5 8 11))) + (merge 'vector y x #'<)) + #(2 4 5 8 11)) + +(deftest merge-vector.4 + (merge 'vector nil nil #'<) + #()) + +(deftest merge-vector.5 + (let ((x (vector 1 3 7 8 10)) + (y (list 2 4 5 8 11))) + (merge 'vector x y #'<)) + #(1 2 3 4 5 7 8 8 10 11)) + +(deftest merge-vector.6 + (let ((x (list 1 3 7 8 10)) + (y (vector 2 4 5 8 11))) + (merge 'vector x y #'<)) + #(1 2 3 4 5 7 8 8 10 11)) + +(deftest merge-vector.7 + (let ((x (vector 1 3 7 8 10)) + (y (vector 2 4 5 8 11))) + (merge 'vector x y #'<)) + #(1 2 3 4 5 7 8 8 10 11)) + +(deftest merge-vector.8 + (let ((x (sort (list 1 3 7 8 10) #'>)) + (y (sort (list 2 4 5 8 11) #'>))) + (merge 'vector x y #'< :key #'-)) + #(11 10 8 8 7 5 4 3 2 1)) + +(deftest merge-vector.9 + (let ((x (list 1 3 7 8 10)) + (y (list 2 4 5 8 11))) + (merge 'vector x y #'< :key nil)) + #(1 2 3 4 5 7 8 8 10 11)) + +(deftest merge-vector.10 + (let ((x (list 1 3 7 8 10)) + (y (list 2 4 5 8 11))) + (merge 'vector x y '<)) + #(1 2 3 4 5 7 8 8 10 11)) + +(deftest merge-vector.11 + (let ((x (vector)) (y (vector))) + (merge 'vector x y #'<)) + #()) + +(deftest merge-vector.12 + (let ((x nil) (y (vector 1 2 3))) + (merge 'vector x y #'<)) + #(1 2 3)) + +(deftest merge-vector.13 + (let ((x (vector)) (y (list 1 2 3))) + (merge 'vector x y #'<)) + #(1 2 3)) + +(deftest merge-vector.14 + (let ((x nil) (y (vector 1 2 3))) + (merge 'vector y x #'<)) + #(1 2 3)) + +(deftest merge-vector.15 + (let ((x (vector)) (y (list 1 2 3))) + (merge 'vector y x #'<)) + #(1 2 3)) + +(deftest merge-vector.16 + (let ((x (make-array '(10) :initial-contents '(2 5 8 9 11 12 14 15 18 30) + :fill-pointer 5)) + (y (list 1 6 10))) + (merge 'vector x y #'<)) + #(1 2 5 6 8 9 10 11)) + +(deftest merge-vector.16a + (let ((x (make-array '(10) :initial-contents '(2 5 8 9 11 12 14 15 18 30) + :fill-pointer 5)) + (y (list 1 6 10))) + (merge 'vector y x #'<)) + #(1 2 5 6 8 9 10 11)) + +(deftest merge-vector.17 + (let* ((x (make-array '(10) :initial-contents '(2 5 8 9 11 12 14 15 18 30) + :fill-pointer 5)) + (result (merge 'vector x () #'<))) + (values + (array-element-type result) + result)) + t + #(2 5 8 9 11)) + +;;; Tests on strings + +(deftest merge-string.1 + (let ((x (list #\1 #\3 #\7 #\8)) + (y (list #\2 #\4 #\5 #\9))) + (merge 'string x y #'char<)) + "12345789") + +(deftest merge-string.1a + (let ((x "1378") + (y (list #\2 #\4 #\5 #\9))) + (merge 'string x y #'char<)) + "12345789") + +(deftest merge-string.1b + (let ((x (list #\1 #\3 #\7 #\8)) + (y "2459")) + (merge 'string x y #'char<)) + "12345789") + +(deftest merge-string.1c + (let ((x "1378") + (y "2459")) + (merge 'string x y #'char<)) + "12345789") + +(deftest merge-string.1d + (let ((x "1378") + (y "2459")) + (merge 'string y x #'char<)) + "12345789") + +(deftest merge-string.2 + (let ((x nil) + (y (list #\2 #\4 #\5 #\9))) + (merge 'string x y #'char<)) + "2459") + +(deftest merge-string.3 + (let ((x nil) + (y (list #\2 #\4 #\5 #\9))) + (merge 'string y x #'char<)) + "2459") + +(deftest merge-string.4 + (merge 'string nil nil #'char<) + "") + +(deftest merge-string.8 + (let ((x (list #\1 #\3 #\7 #\8)) + (y (list #\2 #\4 #\5))) + (merge 'string x y #'char< :key #'nextdigit)) + "1234578") + +(deftest merge-string.9 + (let ((x (list #\1 #\3 #\7 #\8)) + (y (list #\2 #\4 #\5 #\9))) + (merge 'string x y #'char< :key nil)) + "12345789") + +(deftest merge-string.10 + (let ((x (list #\1 #\3 #\7 #\8)) + (y (list #\2 #\4 #\5 #\9))) + (merge 'string x y 'char<)) + "12345789") + +(deftest merge-string.11 + (let ((x (vector)) (y (vector))) + (merge 'string x y #'char<)) + "") + +(deftest merge-string.12 + (let ((x nil) (y (vector #\1 #\2 #\3))) + (merge 'string x y #'char<)) + "123") + +(deftest merge-string.13 + (let ((x (vector)) (y (list #\1 #\2 #\3))) + (merge 'string x y #'char<)) + "123") + +(deftest merge-string.13a + (let ((x (copy-seq "")) (y (list #\1 #\2 #\3))) + (merge 'string x y #'char<)) + "123") + +(deftest merge-string.14 + (let ((x nil) (y (vector #\1 #\2 #\3))) + (merge 'string y x #'char<)) + "123") + +(deftest merge-string.14a + (let ((x (copy-seq "")) (y (vector #\1 #\2 #\3))) + (merge 'string y x #'char<)) + "123") + +(deftest merge-string.15 + (let* ((x (make-array '(10) :initial-contents "adgkmpruwv" + :fill-pointer 5 :element-type 'character)) + (y (copy-seq "bci"))) + (merge 'string x y #'char<)) + "abcdgikm") + +(deftest merge-string.16 + (let* ((x (make-array '(10) :initial-contents "adgkmpruwv" + :fill-pointer 5 :element-type 'character)) + (y (copy-seq "bci"))) + (merge 'string y x #'char<)) + "abcdgikm") + +(deftest merge-string.17 + (let* ((x (make-array '(10) :initial-contents "adgkmpruwv" + :fill-pointer 5 :element-type 'character))) + (merge 'string nil x #'char<)) + "adgkm") + +(deftest merge-string.18 + (let* ((x (make-array '(10) :initial-contents "adgkmpruwv" + :fill-pointer 5 :element-type 'character))) + (merge 'string x nil #'char<)) + "adgkm") + +;;; Tests for bit vectors + +(deftest merge-bit-vector.1 + (let ((x (list 0 0 1 1 1)) + (y (list 0 0 0 1 1))) + (merge 'bit-vector x y #'<)) + #*0000011111) + +(deftest merge-bit-vector.2 + (let ((x nil) + (y (list 0 0 0 1 1))) + (merge 'bit-vector x y #'<)) + #*00011) + +(deftest merge-bit-vector.3 + (let ((x nil) + (y (list 0 0 0 1 1))) + (merge 'bit-vector y x #'<)) + #*00011) + +(deftest merge-bit-vector.4 + (merge 'bit-vector nil nil #'<) + #*) + +(deftest merge-bit-vector.5 + (let ((x (vector 0 0 1 1 1)) + (y (list 0 0 0 1 1))) + (merge 'bit-vector x y #'<)) + #*0000011111) + +(deftest merge-bit-vector.5a + (let ((x (copy-seq #*00111)) + (y (list 0 0 0 1 1))) + (merge 'bit-vector x y #'<)) + #*0000011111) + +(deftest merge-bit-vector.5b + (let ((x (list 0 0 1 1 1)) + (y (copy-seq #*00011))) + (merge 'bit-vector x y #'<)) + #*0000011111) + +(deftest merge-bit-vector.5c + (let ((x (copy-seq #*00111)) + (y (copy-seq #*00011))) + (merge 'bit-vector x y #'<)) + #*0000011111) + +(deftest merge-bit-vector.5d + (let ((x (copy-seq #*11111)) + (y (copy-seq #*00000))) + (merge 'bit-vector x y #'<)) + #*0000011111) + +(deftest merge-bit-vector.5e + (let ((x (copy-seq #*11111)) + (y (copy-seq #*00000))) + (merge 'bit-vector y x #'<)) + #*0000011111) + +(deftest merge-bit-vector.6 + (let ((x (list 0 0 1 1 1)) + (y (vector 0 0 0 1 1))) + (merge 'bit-vector x y #'<)) + #*0000011111) + +(deftest merge-bit-vector.7 + (let ((x (vector 0 0 1 1 1)) + (y (vector 0 0 0 1 1))) + (merge 'bit-vector x y #'<)) + #*0000011111) + +(deftest merge-bit-vector.8 + (let ((x (list 1 1 1 0 0)) + (y (list 1 1 0 0 0))) + (merge 'bit-vector x y #'< :key #'-)) + #*1111100000) + +(deftest merge-bit-vector.9 + (let ((x (list 0 0 1 1 1)) + (y (list 0 0 0 1 1))) + (merge 'bit-vector x y #'< :key nil)) + #*0000011111) + +(deftest merge-bit-vector.10 + (let ((x (list 0 0 1 1 1)) + (y (list 0 0 0 1 1))) + (merge 'bit-vector x y '<)) + #*0000011111) + +(deftest merge-bit-vector.11 + (let ((x (copy-seq #*)) (y (copy-seq #*))) + (merge 'bit-vector x y #'<)) + #*) + +(deftest merge-bit-vector.12 + (let ((x (copy-seq #*)) (y (copy-seq #*011))) + (merge 'bit-vector x y #'<)) + #*011) + +(deftest merge-bit-vector.13 + (let ((x (copy-seq #*)) (y (list 0 1 1))) + (merge 'bit-vector x y #'<)) + #*011) + +(deftest merge-bit-vector.14 + (let ((x nil) (y (vector 0 1 1))) + (merge 'bit-vector y x #'<)) + #*011) + +(deftest merge-bit-vector.15 + (let ((x (copy-seq #*)) (y (list 0 1 1))) + (merge 'bit-vector y x #'<)) + #*011) + +(deftest merge-bit-vector.16 + (let* ((x (make-array '(10) :initial-contents #*0001101010 + :fill-pointer 5 :element-type 'bit)) + (y (copy-seq #*001))) + (merge 'bit-vector x y #'<)) + #*00000111) + +(deftest merge-bit-vector.17 + (let* ((x (make-array '(10) :initial-contents #*0001101010 + :fill-pointer 5 :element-type 'bit)) + (y (copy-seq #*001))) + (merge 'bit-vector y x #'<)) + #*00000111) + +(deftest merge-bit-vector.18 + (let* ((x (make-array '(10) :initial-contents #*0001101010 + :fill-pointer 5 :element-type 'bit))) + (merge 'bit-vector nil x #'<)) + #*00011) + +(deftest merge-bit-vector.19 + (let* ((x (make-array '(10) :initial-contents #*0001101010 + :fill-pointer 5 :element-type 'bit))) + (merge 'bit-vector x nil #'<)) + #*00011) + + +;;; Cons (which is a recognizable subtype of list) + +(deftest merge-cons.1 + (merge 'cons (list 1 2 3) (list 4 5 6) #'<) + (1 2 3 4 5 6)) + +;;; Null, which is a recognizable subtype of list + +(deftest merge-null.1 + (merge 'null nil nil #'<) + nil) + +;;; Vectors with length + +(deftest merge-vector-length.1 + (merge '(vector * 6) (list 1 2 3) (list 4 5 6) #'<) + #(1 2 3 4 5 6)) + +(deftest merge-bit-vector-length.1 + (merge '(bit-vector 6) (list 0 1 1) (list 0 0 1) #'<) + #*000111) + +;;; Order of evaluation + +(deftest merge.order.1 + (let ((i 0) a b c d) + (values + (merge (progn (setf a (incf i)) 'list) + (progn (setf b (incf i)) (list 2 5 6)) + (progn (setf c (incf i)) (list 1 3 4)) + (progn (setf d (incf i)) #'<)) + i a b c d)) + (1 2 3 4 5 6) 4 1 2 3 4) + +;;; Tests of error situations + +(deftest merge.error.1 + (handler-case (eval + '(locally (declare (optimize (safety 3))) + (merge 'symbol (list 1 2 3) (list 4 5 6) #'<))) + (error () :caught)) + :caught) + +(deftest merge.error.2 + (classify-error (merge '(vector * 3) (list 1 2 3) (list 4 5 6) #'<)) + type-error) + +(deftest merge.error.3 + (classify-error (merge '(bit-vector 3) (list 0 0 0) (list 1 1 1) #'<)) + type-error) + +(deftest merge.error.4 + (classify-error (merge '(vector * 7) (list 1 2 3) (list 4 5 6) #'<)) + type-error) + +(deftest merge.error.5 + (classify-error (merge '(bit-vector 7) (list 0 0 0) (list 1 1 1) #'<)) + type-error) + +(deftest merge.error.6 + (classify-error (merge 'null (list 1 2 3) (list 4 5 6) #'<)) + type-error) + +(deftest merge.error.7 + (classify-error (merge)) + program-error) + +(deftest merge.error.8 + (classify-error (merge 'list)) + program-error) + +(deftest merge.error.9 + (classify-error (merge 'list (list 2 4 6))) + program-error) + +(deftest merge.error.10 + (classify-error (merge 'list (list 2 4 6) (list 1 3 5))) + program-error) + +(deftest merge.error.11 + (classify-error (merge 'list (list 2 4 6) (list 1 3 5) #'< :bad t)) + program-error) + +(deftest merge.error.12 + (classify-error (merge 'list (list 2 4 6) (list 1 3 5) #'< :key)) + program-error) + +(deftest merge.error.13 + (classify-error (merge 'list (list 2 4 6) (list 1 3 5) #'< :bad t + :allow-other-keys nil)) + program-error) + +(deftest merge.error.14 + (classify-error (merge 'list (list 2 4 6) (list 1 3 5) #'< 1 2)) + program-error) + +(deftest merge.error.15 + (classify-error (locally (merge '(vector * 3) (list 1 2 3) + (list 4 5 6) #'<) + t)) + type-error) + +(deftest merge.error.16 + (classify-error (merge 'list (list 1 2) (list 3 4) #'car)) + program-error) + +(deftest merge.error.17 + (classify-error (merge 'list (list 'a 'b) (list 3 4) #'max)) + type-error) diff --git a/ansi-tests/mismatch.lsp b/ansi-tests/mismatch.lsp new file mode 100644 index 0000000..2f9b4c3 --- /dev/null +++ b/ansi-tests/mismatch.lsp @@ -0,0 +1,715 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Mon Aug 26 23:55:29 2002 +;;;; Contains: Tests for MISMATCH + +(in-package :cl-test) + +(deftest mismatch-list.1 + (mismatch '() '(a b c)) + 0) + +(deftest mismatch-list.2 + (mismatch '(a b c d) '()) + 0) + +(deftest mismatch-list.3 + (mismatch '(a b c) '(a b c)) + nil) + +(deftest mismatch-list.4 + (mismatch '(a b c) '(a b d)) + 2) + +(deftest mismatch-list.5 + (mismatch '(a b c) '(b c) :start1 1) + nil) + +(deftest mismatch-list.6 + (mismatch '(a b c d) '(z b c e) :start1 1 :start2 1) + 3) + +(deftest mismatch-list.7 + (mismatch '(a b c d) '(z b c e) :start1 1 :start2 1 :end1 3 :end2 3) + nil) + +(deftest mismatch-list.8 + (mismatch '(1 2 3 4) '(5 6 7 8) :test #'(lambda (x y) (= x (- y 4)))) + nil) + +(deftest mismatch-list.9 + (mismatch '(1 2 3 4) '(5 6 17 8) :test #'(lambda (x y) (= x (- y 4)))) + 2) + +(deftest mismatch-list.10 + (mismatch '(1 2 3 4) '(10 11 7 123) :test-not #'(lambda (x y) (= x (- y 4)))) + 2) + +(deftest mismatch-list.11 + (mismatch '(1 2 3 4) '(5 6 17 8) :key #'evenp) + nil) + +(deftest mismatch-list.12 + (mismatch '(1 2 3 4) '(5 6 12 8) :key 'oddp) + 2) + +(deftest mismatch-list.13 + (mismatch '(1 2 3 4) '(1 2 3 4) :test 'eql) + nil) + +(deftest mismatch-list.14 + (mismatch '(1 2 3 4) '(5 6 7 8) :test-not 'eql) + nil) + +(deftest mismatch-list.15 + (mismatch '(a b c d e f g h i j k) '(a b c c e f g h z j k)) + 3) + +(deftest mismatch-list.16 + (mismatch '(a b c d e f g h i j k) '(a b c c y f g h z j k) :from-end t) + 9) + +(deftest mismatch-list.17 + (mismatch '(a b c) '(a b c a b c d) :from-end t) + 3) + +(deftest mismatch-list.18 + (mismatch '(a b c a b c d) '(a b c) :from-end t) + 7) + +(deftest mismatch-list.19 + (mismatch '(1 1 1) '(2 2 2 2 2 1 2 2) :from-end t :test-not 'eql) + 1) + +(deftest mismatch-list.20 + (mismatch '(1 1 1 1 1 1 1) '(2 3 3) :from-end t :key #'evenp) + 5) + +(deftest mismatch-list.21 + (mismatch '(1 1 1) '(2 2 2 2 2 1 2 2) :from-end t :test-not #'equal) + 1) + +(deftest mismatch-list.22 + (mismatch '(1 1 1 1 1 1 1) '(2 3 3) :from-end t :key 'evenp) + 5) + +;;; tests on vectors + +(deftest mismatch-vector.1 + (mismatch #() #(a b c)) + 0) + +(deftest mismatch-vector.2 + (mismatch #(a b c d) #()) + 0) + +(deftest mismatch-vector.3 + (mismatch #(a b c) #(a b c)) + nil) + +(deftest mismatch-vector.4 + (mismatch #(a b c) #(a b d)) + 2) + +(deftest mismatch-vector.5 + (mismatch #(a b c) #(b c) :start1 1) + nil) + +(deftest mismatch-vector.6 + (mismatch #(a b c d) #(z b c e) :start1 1 :start2 1) + 3) + +(deftest mismatch-vector.7 + (mismatch #(a b c d) #(z b c e) :start1 1 :start2 1 :end1 3 :end2 3) + nil) + +(deftest mismatch-vector.8 + (mismatch #(1 2 3 4) #(5 6 7 8) :test #'(lambda (x y) (= x (- y 4)))) + nil) + +(deftest mismatch-vector.9 + (mismatch #(1 2 3 4) #(5 6 17 8) :test #'(lambda (x y) (= x (- y 4)))) + 2) + +(deftest mismatch-vector.10 + (mismatch #(1 2 3 4) #(10 11 7 123) :test-not #'(lambda (x y) (= x (- y 4)))) + 2) + +(deftest mismatch-vector.11 + (mismatch #(1 2 3 4) #(5 6 17 8) :key #'evenp) + nil) + +(deftest mismatch-vector.12 + (mismatch #(1 2 3 4) #(5 6 12 8) :key 'oddp) + 2) + +(deftest mismatch-vector.13 + (mismatch #(1 2 3 4) #(1 2 3 4) :test 'eql) + nil) + +(deftest mismatch-vector.14 + (mismatch #(1 2 3 4) #(5 6 7 8) :test-not 'eql) + nil) + +(deftest mismatch-vector.15 + (mismatch #(a b c d e f g h i j k) #(a b c c e f g h z j k)) + 3) + +(deftest mismatch-vector.16 + (mismatch #(a b c d e f g h i j k) #(a b c c y f g h z j k) :from-end t) + 9) + +(deftest mismatch-vector.17 + (mismatch #(a b c) #(a b c a b c d) :from-end t) + 3) + +(deftest mismatch-vector.18 + (mismatch #(a b c a b c d) #(a b c) :from-end t) + 7) + +(deftest mismatch-vector.19 + (mismatch #(1 1 1) #(2 2 2 2 2 1 2 2) :from-end t :test-not 'eql) + 1) + +(deftest mismatch-vector.20 + (mismatch #(1 1 1 1 1 1 1) #(2 3 3) :from-end t :key #'evenp) + 5) + +(deftest mismatch-vector.21 + (mismatch #(1 1 1) #(2 2 2 2 2 1 2 2) :from-end t :test-not #'equal) + 1) + +(deftest mismatch-vector.22 + (mismatch #(1 1 1 1 1 1 1) #(2 3 3) :from-end t :key 'evenp) + 5) + +(deftest mismatch-vector.23 + (let ((a (make-array '(9) :initial-contents '(1 2 3 4 5 6 7 8 9) + :fill-pointer 5))) + (values + (mismatch '(1 2 3 4 5) a) + (mismatch '(1 2 3 4 5) a :from-end t) + (mismatch '(1 2 3 4) a) + (mismatch '(1 2 3 4 5 6) a) + (mismatch '(6 7 8 9) a :from-end t) + (mismatch '(2 3 4 5) a :from-end t))) + nil nil 4 5 4 0) + +(deftest mismatch-vector.24 + (let ((m (make-array '(6) :initial-contents '(1 2 3 4 5 6) + :fill-pointer 4)) + (a '(1 2 3 4 5))) + (list + (mismatch m a) + (mismatch m a :from-end t) + (setf (fill-pointer m) 5) + (mismatch m a) + (mismatch m a :from-end t) + (setf (fill-pointer m) 6) + (mismatch m a) + (mismatch m a :from-end t))) + (4 4 5 nil nil 6 5 6)) + +;;; tests on bit vectors + +(deftest mismatch-bit-vector.1 + (mismatch "" #*111) + 0) + +(deftest mismatch-bit-vector.1a + (mismatch '() #*111) + 0) + +(deftest mismatch-bit-vector.1b + (mismatch "" '(1 1 1)) + 0) + +(deftest mismatch-bit-vector.2 + (mismatch #*1010 #*) + 0) + +(deftest mismatch-bit-vector.2a + (mismatch #*1010 '()) + 0) + +(deftest mismatch-bit-vector.2b + (mismatch '(1 0 1 0) #*) + 0) + +(deftest mismatch-bit-vector.3 + (mismatch #*101 #*101) + nil) + +(deftest mismatch-bit-vector.4 + (mismatch #*101 #*100) + 2) + +(deftest mismatch-bit-vector.5 + (mismatch #*101 #*01 :start1 1) + nil) + +(deftest mismatch-bit-vector.6 + (mismatch #*0110 #*0111 :start1 1 :start2 1) + 3) + +(deftest mismatch-bit-vector.7 + (mismatch #*0110 #*0111 :start1 1 :start2 1 :end1 3 :end2 3) + nil) + +(deftest mismatch-bit-vector.7a + (mismatch '(0 1 1 0) #*0111 :start1 1 :start2 1 :end1 3 :end2 3) + nil) + +(deftest mismatch-bit-vector.7b + (mismatch #*0110 '(0 1 1 1) :start1 1 :start2 1 :end1 3 :end2 3) + nil) + +(deftest mismatch-bit-vector.8 + (mismatch #*1001 #*0110 :test #'(lambda (x y) (= x (- 1 y)))) + nil) + +(deftest mismatch-bit-vector.8a + (mismatch #*1001 '(5 4 4 5) :test #'(lambda (x y) (= x (- y 4)))) + nil) + +(deftest mismatch-bit-vector.9 + (mismatch #*1001 '(5 4 17 5) :test #'(lambda (x y) (= x (- y 4)))) + 2) + +(deftest mismatch-bit-vector.9a + (mismatch '(5 4 17 5) #*1001 :test #'(lambda (x y) (= y (- x 4)))) + 2) + +(deftest mismatch-bit-vector.9b + (mismatch #*0100 #*1001 :test #'(lambda (x y) (= x (- 1 y)))) + 2) + +(deftest mismatch-bit-vector.10 + (mismatch #*1001 '(10 11 4 123) :test-not #'(lambda (x y) (= x (- y 4)))) + 2) + +(deftest mismatch-bit-vector.10a + (mismatch #*1001 '(10 11 100 123) :test-not #'(lambda (x y) (= x (- y 4)))) + nil) + +(deftest mismatch-bit-vector.11 + (mismatch #*1010 '(5 6 17 8) :key #'evenp) + nil) + +(deftest mismatch-bit-vector.11a + (mismatch '(5 6 17 8) #*1010 :key #'evenp) + nil) + +(deftest mismatch-bit-vector.11b + (mismatch #*0101 #*1010 :key #'evenp :test-not 'eql) + nil) + +(deftest mismatch-bit-vector.11c + (mismatch '(5 6 17 8) #*10101 :key #'evenp) + 4) + +(deftest mismatch-bit-vector.11d + (mismatch '(5 6 17 8 100) #*1010 :key #'evenp) + 4) + +(deftest mismatch-bit-vector.12 + (mismatch #*1010 #*1000 :key 'oddp) + 2) + +(deftest mismatch-bit-vector.12a + (mismatch #*1010 '(5 6 8 8) :key 'oddp) + 2) + +(deftest mismatch-bit-vector.12b + (mismatch '(5 6 8 8) #*1010 :key 'oddp) + 2) + +(deftest mismatch-bit-vector.13 + (mismatch #*0001 #*0001 :test 'eql) + nil) + +(deftest mismatch-bit-vector.14 + (mismatch '#*10001 #*01110 :test-not 'eql) + nil) + +(deftest mismatch-bit-vector.15 + (mismatch #*00100010100 #*00110010000) + 3) + +(deftest mismatch-bit-vector.16 + (mismatch #*00100010100 #*00110010000 :from-end t) + 9) + +(deftest mismatch-bit-vector.17 + (mismatch #*001 #*0010010 :from-end t) + 3) + +(deftest mismatch-bit-vector.18 + (mismatch #*0010010 #*001 :from-end t) + 7) + +(deftest mismatch-bit-vector.19 + (mismatch #*000 #*11111011 :from-end t :test-not 'eql) + 1) + +(deftest mismatch-bit-vector.20 + (mismatch #*1111111 '(2 3 3) :from-end t :key #'evenp) + 5) + +(deftest mismatch-bit-vector.21 + (mismatch #*111 #*00000100 :from-end t :test-not #'equal) + 1) + +(deftest mismatch-bit-vector.22 + (mismatch #*1111111 '(2 3 3) :from-end t :key 'evenp) + 5) + +(deftest mismatch-bit-vector.23 + (let ((a (make-array '(9) :initial-contents #*001011000 + :fill-pointer 5 + :element-type 'bit))) + (values + (mismatch #*00101 a) + (mismatch #*00101 a :from-end t) + (mismatch #*0010 a) + (mismatch #*001011 a) + (mismatch #*1000 a :from-end t) + (mismatch #*0010 a :from-end t))) + nil nil 4 5 4 4) + +(deftest mismatch-bit-vector.24 + (let ((m (make-array '(6) :initial-contents #*001011 + :fill-pointer 4 + :element-type 'bit)) + (a #*00101)) + (list + (mismatch m a) + (mismatch m a :from-end t) + (setf (fill-pointer m) 5) + (mismatch m a) + (mismatch m a :from-end t) + (setf (fill-pointer m) 6) + (mismatch m a) + (mismatch m a :from-end t))) + (4 4 5 nil nil 6 5 5)) + +;;; tests on strings + +(deftest mismatch-string.1 + (mismatch "" "111") + 0) + +(deftest mismatch-string.1a + (mismatch '() "111") + 0) + +(deftest mismatch-string.1b + (mismatch "" '(1 1 1)) + 0) + +(deftest mismatch-string.2 + (mismatch "1010" "") + 0) + +(deftest mismatch-string.2a + (mismatch "1010" '()) + 0) + +(deftest mismatch-string.2b + (mismatch '(1 0 1 0) "") + 0) + +(deftest mismatch-string.3 + (mismatch "101" "101") + nil) + +(deftest mismatch-string.4 + (mismatch "101" "100") + 2) + +(deftest mismatch-string.5 + (mismatch "101" "01" :start1 1) + nil) + +(deftest mismatch-string.6 + (mismatch "0110" "0111" :start1 1 :start2 1) + 3) + +(deftest mismatch-string.7 + (mismatch "0110" "0111" :start1 1 :start2 1 :end1 3 :end2 3) + nil) + +(deftest mismatch-string.7a + (mismatch '(#\0 #\1 #\1 #\0) "0111" :start1 1 :start2 1 :end1 3 :end2 3) + nil) + +(deftest mismatch-string.7b + (mismatch "0110" '(#\0 #\1 #\1 #\1) :start1 1 :start2 1 :end1 3 :end2 3) + nil) + +(deftest mismatch-string.8 + (mismatch "1001" "0110" :test #'(lambda (x y) (eql x (if (eql y #\0) + #\1 #\0)))) + nil) + +(deftest mismatch-string.8a + (mismatch "1001" '(5 4 4 5) :test #'(lambda (x y) + (setq x (read-from-string (string x))) + (= x (- y 4)))) + nil) + +(deftest mismatch-string.9 + (mismatch "1001" '(5 4 17 5) :test #'(lambda (x y) + (setq x (read-from-string (string x))) + (= x (- y 4)))) + 2) + +(deftest mismatch-string.9a + (mismatch '(5 4 17 5) "1001" :test #'(lambda (x y) + (setq y (read-from-string (string y))) + (= y (- x 4)))) + 2) + +(deftest mismatch-string.9b + (mismatch "0100" "1001" :test #'(lambda (x y) (eql x (if (eql y #\0) #\1 #\0)))) + 2) + +(deftest mismatch-string.10 + (mismatch "1001" "0049" :test-not #'(lambda (x y) + (setq x (read-from-string (string x))) + (setq y (read-from-string (string y))) + (eql x (- y 4)))) + 2) + +(deftest mismatch-string.10a + (mismatch "1001" "3333" :test-not #'(lambda (x y) + (setq x (read-from-string (string x))) + (setq y (read-from-string (string y))) + (eql x (- y 4)))) + nil) + +(deftest mismatch-string.11 + (mismatch "1010" "5678" :key #'evendigitp) + nil) + +(deftest mismatch-string.11a + (mismatch "5678" "1010" :key #'odddigitp) + nil) + +(deftest mismatch-string.11b + (mismatch "0101" "1010" :key #'evendigitp :test-not 'eql) + nil) + +(deftest mismatch-string.11c + (mismatch "5678" "10101" :key #'evendigitp) + 4) + +(deftest mismatch-string.11d + (mismatch "56122" "1010" :key #'evendigitp) + 4) + +(deftest mismatch-string.11e + (mismatch "0101" '(#\1 #\0 #\1 #\0) :key #'evendigitp :test-not 'eql) + nil) + +(deftest mismatch-string.12 + (mismatch "1010" "1000" :key 'odddigitp) + 2) + +(deftest mismatch-string.12a + (mismatch "1010" "5688" :key 'odddigitp) + 2) + +(deftest mismatch-string.12b + (mismatch '(#\5 #\6 #\8 #\8) "1010" :key 'odddigitp) + 2) + +(deftest mismatch-string.13 + (mismatch "0001" "0001" :test 'eql) + nil) + +(deftest mismatch-string.14 + (mismatch "10001" "01110" :test-not 'eql) + nil) + +(deftest mismatch-string.15 + (mismatch "00100010100" "00110010000") + 3) + +(deftest mismatch-string.16 + (mismatch "00100010100" "00110010000" :from-end t) + 9) + +(deftest mismatch-string.17 + (mismatch "001" "0010010" :from-end t) + 3) + +(deftest mismatch-string.18 + (mismatch "0010010" "001" :from-end t) + 7) + +(deftest mismatch-string.19 + (mismatch "000" "11111011" :from-end t :test-not 'eql) + 1) + +(deftest mismatch-string.20 + (mismatch "1111111" "233" :from-end t :key #'evendigitp) + 5) + +(deftest mismatch-string.20a + (mismatch "1111111" '(#\2 #\3 #\3) :from-end t :key #'evendigitp) + 5) + +(deftest mismatch-string.21 + (mismatch "111" "00000100" :from-end t :test-not #'equal) + 1) + +(deftest mismatch-string.22 + (mismatch "1111111" "233" :from-end t :key 'evendigitp) + 5) + +(deftest mismatch-string.23 + (let ((a (make-array '(9) :initial-contents "123456789" + :fill-pointer 5 + :element-type 'character))) + (values + (mismatch "12345" a) + (mismatch "12345" a :from-end t) + (mismatch "1234" a) + (mismatch "123456" a) + (mismatch "6789" a :from-end t) + (mismatch "2345" a :from-end t))) + nil nil 4 5 4 0) + +(deftest mismatch-string.24 + (let ((m (make-array '(6) :initial-contents "123456" + :fill-pointer 4 + :element-type 'character)) + (a "12345")) + (list + (mismatch m a) + (mismatch m a :from-end t) + (setf (fill-pointer m) 5) + (mismatch m a) + (mismatch m a :from-end t) + (setf (fill-pointer m) 6) + (mismatch m a) + (mismatch m a :from-end t))) + (4 4 5 nil nil 6 5 6)) + +;;; Keyword tests + +(deftest mismatch.allow-other-keys.1 + (mismatch "1234" "1244" :allow-other-keys t :bad t) + 2) + +(deftest mismatch.allow-other-keys.2 + (mismatch "1234" "1244" :bad t :allow-other-keys t) + 2) + +(deftest mismatch.allow-other-keys.3 + (mismatch "1234" "1244" :bad t :allow-other-keys t :allow-other-keys nil) + 2) + +(deftest mismatch.allow-other-keys.4 + (mismatch "1234" "1244" :allow-other-keys t :bad t + :allow-other-keys nil) + 2) + +(deftest mismatch.allow-other-keys.5 + (mismatch "1234" "1244" :allow-other-keys t + :allow-other-keys nil + :bad t) + 2) + +(deftest mismatch.keywords.6 + (mismatch "1234" "1244" :test #'equal :test (complement #'equal)) + 2) + +(deftest mismatch.allow-other-keys.7 + (mismatch "1234" "1244" :bad t :allow-other-keys t + :test (complement #'equal)) + 0) + +;;; Order of evaluation + +(deftest mismatch.order.1 + (let ((i 0) a b) + (values + (mismatch (progn (setf a (incf i)) "abcd") + (progn (setf b (incf i)) "abzd")) + i a b)) + 2 2 1 2) + +(deftest mismatch.order.2 + (let ((i 0) a b c d e f g h j) + (values + (mismatch (progn (setf a (incf i)) "abcdef") + (progn (setf b (incf i)) "abcdef") + :key (progn (setf c (incf i)) #'identity) + :test (progn (setf d (incf i)) #'equal) + :start1 (progn (setf e (incf i)) 1) + :start2 (progn (setf f (incf i)) 1) + :end1 (progn (setf g (incf i)) 4) + :end2 (progn (setf h (incf i)) 4) + :from-end (setf j (incf i))) + i a b c d e f g h j)) + nil 9 1 2 3 4 5 6 7 8 9) + +(deftest mismatch.order.3 + (let ((i 0) a b c d e f g h j) + (values + (mismatch (progn (setf a (incf i)) "abcdef") + (progn (setf b (incf i)) "abcdef") + :from-end (setf c (incf i)) + :end2 (progn (setf d (incf i)) 4) + :end1 (progn (setf e (incf i)) 4) + :start2 (progn (setf f (incf i)) 1) + :start1 (progn (setf g (incf i)) 1) + :test (progn (setf h (incf i)) #'equal) + :key (progn (setf j (incf i)) #'identity)) + i a b c d e f g h j)) + nil 9 1 2 3 4 5 6 7 8 9) + + +;;; Error cases + +(deftest mismatch.error.1 + (classify-error (mismatch)) + program-error) + +(deftest mismatch.error.2 + (classify-error (mismatch nil)) + program-error) + +(deftest mismatch.error.3 + (classify-error (mismatch nil nil :bad t)) + program-error) + +(deftest mismatch.error.4 + (classify-error (mismatch nil nil :bad t :allow-other-keys nil)) + program-error) + +(deftest mismatch.error.5 + (classify-error (mismatch nil nil :key)) + program-error) + +(deftest mismatch.error.6 + (classify-error (mismatch nil nil 1 2)) + program-error) + +(deftest mismatch.error.7 + (classify-error (mismatch '(a b) '(a b) :test #'identity)) + program-error) + +(deftest mismatch.error.8 + (classify-error (mismatch '(a b) '(a b) :test-not #'identity)) + program-error) + +(deftest mismatch.error.9 + (classify-error (mismatch '(a b) '(a b) :key #'car)) + type-error) + +(deftest mismatch.error.10 + (classify-error (mismatch '(a b) '(a b) :key #'cons)) + program-error) diff --git a/ansi-tests/multiple-value-bind.lsp b/ansi-tests/multiple-value-bind.lsp new file mode 100644 index 0000000..9c5b855 --- /dev/null +++ b/ansi-tests/multiple-value-bind.lsp @@ -0,0 +1,62 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Oct 18 23:16:23 2002 +;;;; Contains: Tests for MULTIPLE-VALUE-BIND + +(in-package :cl-test) + +(deftest multiple-value-bind.1 + (multiple-value-bind (x y z) (values 1 2 3) + (declare (type integer x)) + (declare (type integer y)) + (declare (type integer z)) + (list z y x)) + (3 2 1)) + +(deftest multiple-value-bind.2 + (multiple-value-bind (x y z) (values 1 2 3) + (let ((x 4)) + (list x y z))) + (4 2 3)) + +(deftest multiple-value-bind.3 + (multiple-value-bind (x y z) (values 1 2 3 4 5 6) + (list x y z)) + (1 2 3)) + +(deftest multiple-value-bind.4 + (multiple-value-bind (x y z) (values 1 2) + (list x y z)) + (1 2 nil)) + +(deftest multiple-value-bind.5 + (multiple-value-bind () (values 1 2) (values 'a 'b 'c)) + a b c) + +(deftest multiple-value-bind.6 + (multiple-value-bind (x y z) (values) + (list x y z)) + (nil nil nil)) + +(deftest multiple-value-bind.7 + (let ((z 0) x y) + (declare (special z)) + (values + (flet ((%x () (symbol-value 'x)) + (%y () (symbol-value 'y)) + (%z () (symbol-value 'z))) + (multiple-value-bind (x y z) (values 1 2 3) + (declare (special x y)) + (list (%x) (%y) (%z)))) + x y z)) + (1 2 0) nil nil 0) + +;;; (deftest multiple-value-bind.error.1 +;;; (classify-error (multiple-value-bind)) +;;; program-error) +;;; +;;; (deftest multiple-value-bind.error.2 +;;; (classify-error (multiple-value-bind (a b c))) +;;; program-error) + + \ No newline at end of file diff --git a/ansi-tests/multiple-value-call.lsp b/ansi-tests/multiple-value-call.lsp new file mode 100644 index 0000000..012d942 --- /dev/null +++ b/ansi-tests/multiple-value-call.lsp @@ -0,0 +1,42 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Oct 18 23:35:07 2002 +;;;; Contains: Tests of MULTIPLE-VALUE-CALL, MULTIPLE-VALUE-LIST + +(in-package :cl-test) + +(deftest multiple-value-call.1 + (multiple-value-call #'+ (values 1 2) (values) 3 (values 4 5 6)) + 21) + +(deftest multiple-value-call.2 + (multiple-value-call 'list) + nil) + +(deftest multiple-value-call.3 + (multiple-value-call 'list (floor 13 4)) + (3 1)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(deftest multiple-value-list.1 + (multiple-value-list (values)) + nil) + +(deftest multiple-value-list.2 + (multiple-value-list (values 'a)) + (a)) + +(deftest multiple-value-list.3 + (multiple-value-list (values 'a 'b)) + (a b)) + +(deftest multiple-value-list.4 + (not + (loop + for i from 0 below (min multiple-values-limit 100) + for x = (make-list i :initial-element 'a) + always (equal x (multiple-value-list (values-list x))))) + nil) + + diff --git a/ansi-tests/multiple-value-list.lsp b/ansi-tests/multiple-value-list.lsp new file mode 100644 index 0000000..cdb3277 --- /dev/null +++ b/ansi-tests/multiple-value-list.lsp @@ -0,0 +1,37 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Mon Feb 17 06:38:07 2003 +;;;; Contains: Tests of MULTIPLE-VALUE-LIST + +(in-package :cl-test) + +(deftest multiple-value-list.1 + (multiple-value-list 'a) + (a)) + +(deftest multiple-value-list.2 + (multiple-value-list (values)) + nil) + +(deftest multiple-value-list.3 + (multiple-value-list (values 'a 'b 'c 'd 'e)) + (a b c d e)) + +(deftest multiple-value-list.4 + (multiple-value-list (values (values 'a 'b 'c 'd 'e))) + (a)) + +(deftest multiple-value-list.order.1 + (let ((i 0)) + (values (multiple-value-list (incf i)) i)) + (1) 1) + +#| +(deftest multiple-value-list.error.1 + (classify-error (multiple-value-list)) + program-error) + +(deftest multiple-value-list.error.2 + (classify-error (multiple-value-list 'a 'b)) + program-error) +|# diff --git a/ansi-tests/multiple-value-prog1.lsp b/ansi-tests/multiple-value-prog1.lsp new file mode 100644 index 0000000..d8ab80c --- /dev/null +++ b/ansi-tests/multiple-value-prog1.lsp @@ -0,0 +1,71 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Oct 19 06:48:02 2002 +;;;; Contains: Tests for MULTIPLE-VALUE-PROG1 + +(in-package :cl-test) + +(deftest multiple-value-prog1.1 + (multiple-value-prog1 nil) + nil) + +(deftest multiple-value-prog1.2 + (multiple-value-prog1 '(a b c)) + (a b c)) + +(deftest multiple-value-prog1.3 + (multiple-value-prog1 (values-list '(a b c))) + a b c) + +(deftest multiple-value-prog1.4 + (multiple-value-prog1 (values))) + +(deftest multiple-value-prog1.5 + (let ((x 0) (y 0)) + (multiple-value-prog1 (values x y) + (incf x) (incf y 2))) + 0 0) + +(deftest multiple-value-prog1.6 + (let ((x 0) (y 0)) + (multiple-value-call + #'list + (multiple-value-prog1 (values x y) + (incf x) (incf y 2)) + x y)) + (0 0 1 2)) + +(deftest multiple-value-prog1.7 + (let ((x 0) (y 0)) + (multiple-value-call + #'list + (multiple-value-prog1 (values (incf x) y) + (incf x x) + (incf y 10)) + x y)) + (1 0 2 10)) + + +(deftest multiple-value-prog1.8 + (let* ((n (min 100 multiple-values-limit))) + (not-mv + (loop for i from 0 below n + for x = (make-int-list i) + always + (equalt + (multiple-value-list + (eval `(multiple-value-prog1 (values-list (quote ,(copy-seq x))) + nil))) + x)))) + nil) + + +(deftest multiple-value-prog1.9 + (let ((x 0) (y 0)) + (values + (block foo + (multiple-value-prog1 + (values (incf x) (incf y 2)) + (return-from foo 'a))) + x y)) + a 1 2) diff --git a/ansi-tests/multiple-value-setq.lsp b/ansi-tests/multiple-value-setq.lsp new file mode 100644 index 0000000..088ff88 --- /dev/null +++ b/ansi-tests/multiple-value-setq.lsp @@ -0,0 +1,109 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Oct 19 07:00:57 2002 +;;;; Contains: Tests of MULTIPLE-VALUE-SETQ + +(in-package :cl-test) + +(deftest multiple-value-setq.1 + (let ((x 1) (y 2)) + (values + (multiple-value-list + (multiple-value-setq (x y) (values 3 4))) + x y)) + (3) 3 4) + +(deftest multiple-value-setq.2 + (let (x) + (multiple-value-setq (x) (values 1 2)) + x) + 1) + +(deftest multiple-value-setq.3 + (let (x) + (symbol-macrolet ((y x)) + (multiple-value-setq (y) (values 1 2)) + x)) + 1) + +(deftest multiple-value-setq.4 + (let ((x (list nil))) + (symbol-macrolet ((y (car x))) + (multiple-value-setq (y) (values 1 2)) + x)) + (1)) + +;;; test of order of evaluation +;;; The (INCF I) should be evaluated before the assigned form I. +(deftest multiple-value-setq.5 + (let ((i 0) (x (list nil))) + (symbol-macrolet ((y (car (progn (incf i) x)))) + (multiple-value-setq (y) i)) + x) + (1)) + +(deftest multiple-value-setq.6 + (let ((x (list nil)) z) + (symbol-macrolet ((y (car x))) + (multiple-value-setq (y z) (values 1 2))) + (values x z)) + (1) 2) + +(deftest multiple-value-setq.7 + (let ((x (list nil)) (z (list nil))) + (symbol-macrolet ((y (car x)) + (w (car z))) + (multiple-value-setq (y w) (values 1 2))) + (values x z)) + (1) (2)) + +;;; Another order of evaluation tests, this time with two +;;; symbol macro arguments +(deftest multiple-value-setq.8 + (let ((x (list nil)) (z (list nil)) (i 0)) + (symbol-macrolet ((y (car (progn (incf i 3) x))) + (w (car (progn (incf i i) z)))) + (multiple-value-setq (y w) (values i 10))) + (values x z)) + (6) (10)) + +(deftest multiple-value-setq.9 + (let (x) + (values + (multiple-value-setq (x x) (values 1 2)) + x)) + 1 2) + +(deftest multiple-value-setq.10 + (let (x) + (values + (multiple-value-setq (x x) (values 1)) + x)) + 1 nil) + +(deftest multiple-value-setq.11 + (let ((x 1) (y 2) (z 3)) + (multiple-value-setq (x y z) (values)) + (values x y z)) + nil nil nil) + + +(deftest multiple-value-setq.12 + (let ((n (min 100 multiple-values-limit)) + (vars nil) + (result nil)) + (loop + for i from 1 below n + for form = + (progn + (push (gensym) vars) + (push i result) + `(let ,vars + (and (eql (multiple-value-setq ,vars (values-list (quote ,result))) + ,(car result)) + (equal ,(make-list-expr vars) + (quote ,result))))) + unless (eval form) + collect (list i form))) + nil) + diff --git a/ansi-tests/nil.lsp b/ansi-tests/nil.lsp new file mode 100644 index 0000000..b0f5674 --- /dev/null +++ b/ansi-tests/nil.lsp @@ -0,0 +1,44 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Thu Oct 17 06:32:46 2002 +;;;; Contains: Tests for NIL + +(in-package :cl-test) + +(deftest nil.1 + (loop for x in *universe* + thereis (subtypep (type-of x) nil)) + nil) + + +(deftest nil.2 + (loop for x in *universe* + unless (subtypep nil (type-of x)) + collect (type-of x)) + nil) + +(deftest nil.3 + (not-mv (constantp nil)) + nil) + +(deftest nil.4 + (car nil) + nil) + +(deftest nil.5 + (cdr nil) + nil) + +(deftest nil.6 + (eval nil) + nil) + +(deftest nil.7 + (symbol-value nil) + nil) + +(deftest nil.8 + (eqt nil 'nil) + t) + +;;; NIL is, of course, present in many other files diff --git a/ansi-tests/not-and-null.lsp b/ansi-tests/not-and-null.lsp new file mode 100644 index 0000000..e4fdf56 --- /dev/null +++ b/ansi-tests/not-and-null.lsp @@ -0,0 +1,59 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Thu Oct 17 06:38:33 2002 +;;;; Contains: Tests of NOT and NULL + +(in-package :cl-test) + +(deftest null.1 + (null nil) + t) + +(deftest null.2 + (null t) + nil) + +(deftest null.3 + (some #'(lambda (x) (and x (null x))) *universe*) + nil) + +(deftest null.4 + (not (some #'null + `(1 a 1.2 "a" #\w (a) ,*terminal-io* + #'car (make-array '(10))))) + t) + +(deftest null.error.1 + (classify-error (null)) + program-error) + +(deftest null.error.2 + (classify-error (null nil nil)) + program-error) + +(deftest not.1 + (not nil) + t) + +(deftest not.2 + (not t) + nil) + +(deftest not.3 + (some #'(lambda (x) (and x (not x))) *universe*) + nil) + +(deftest not.4 + (not (some #'not + `(1 a 1.2 "a" #\w (a) ,*terminal-io* + #'car (make-array '(10))))) + t) + + +(deftest not.error.1 + (classify-error (not)) + program-error) + +(deftest not.error.2 + (classify-error (not nil nil)) + program-error) diff --git a/ansi-tests/notany.lsp b/ansi-tests/notany.lsp new file mode 100644 index 0000000..66491af --- /dev/null +++ b/ansi-tests/notany.lsp @@ -0,0 +1,142 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Oct 18 07:14:14 2002 +;;;; Contains: Tests for NOTANY + +(in-package :cl-test) + +(deftest notany.1 + (not-mv (notany #'identity nil)) + nil) + +(deftest notany.2 + (not-mv (notany #'identity #())) + nil) + +(deftest notany.3 + (let ((count 0)) + (values + (notany #'(lambda (x) (incf count) (if (>= x 10) x nil)) + '(1 2 4 13 5 1)) + count)) + nil 4) + +(deftest notany.4 + (not-mv (notany #'/= '(1 2 3 4) '(1 2 3 4 5))) + nil) + +(deftest notany.5 + (not-mv (notany #'/= '(1 2 3 4 5) '(1 2 3 4))) + nil) + +(deftest notany.6 + (notany #'/= '(1 2 3 4 5) '(1 2 3 4 6)) + nil) + +(deftest notany.7 + (not-mv (notany #'(lambda (x y) (and x y)) + '(nil t t nil t) #(t nil nil t nil nil))) + nil) + +(deftest notany.8 + (let* ((x '(1)) + (args (list x))) + (not + (loop for i from 2 below (1- (min 100 call-arguments-limit)) + do (push x args) + always (apply #'notany #'/= args)))) + nil) + +(deftest notany.9 + (not-mv (notany #'zerop #*11111111111111)) + nil) + +(deftest notany.10 + (not-mv (notany #'zerop #*)) + nil) + +(deftest notany.11 + (notany #'zerop #*1111111011111) + nil) + +(deftest notany.12 + (not-mv (notany #'(lambda (x) (not (eql x #\a))) "aaaaaaaa")) + nil) + +(deftest notany.13 + (not-mv (notany #'(lambda (x) (eql x #\a)) "")) + nil) + +(deftest notany.14 + (notany #'(lambda (x) (not (eql x #\a))) "aaaaaabaaaa") + nil) + +(deftest notany.15 + (not-mv (notany 'null '(1 2 3 4))) + nil) + +(deftest notany.16 + (notany 'null '(1 2 3 nil 5)) + nil) + +(deftest notany.order.1 + (let ((i 0) a b) + (values + (not (notany (progn (setf a (incf i)) 'null) + (progn (setf b (incf i)) '(a b c)))) + i a b)) + nil 2 1 2) + +;;; Error cases + +(deftest notany.error.1 + (classify-error (notany 1 '(a b c))) + type-error) + +(deftest notany.error.2 + (classify-error (notany #\a '(a b c))) + type-error) + +(deftest notany.error.3 + (classify-error (notany #() '(a b c))) + type-error) + +(deftest notany.error.4 + (classify-error (notany #'null 'a)) + type-error) + +(deftest notany.error.5 + (classify-error (notany #'null 100)) + type-error) + +(deftest notany.error.6 + (classify-error (notany #'null 'a)) + type-error) + +(deftest notany.error.7 + (classify-error (notany #'eq () 'a)) + type-error) + +(deftest notany.error.8 + (classify-error (notany)) + program-error) + +(deftest notany.error.9 + (classify-error (notany #'null)) + program-error) + +(deftest notany.error.10 + (classify-error (locally (notany 1 '(a b c)) t)) + type-error) + +(deftest notany.error.11 + (classify-error (notany #'cons '(a b c))) + program-error) + +(deftest notany.error.12 + (classify-error (notany #'cons '(a b c) '(1 2 4) '(g h j))) + program-error) + +(deftest notany.error.13 + (classify-error (notany #'car '(a b c))) + type-error) \ No newline at end of file diff --git a/ansi-tests/notevery.lsp b/ansi-tests/notevery.lsp new file mode 100644 index 0000000..35ddba1 --- /dev/null +++ b/ansi-tests/notevery.lsp @@ -0,0 +1,142 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Oct 18 07:20:12 2002 +;;;; Contains: Tests for NOTEVERY + +(in-package :cl-test) + +(deftest notevery.1 + (notevery #'identity nil) + nil) + +(deftest notevery.2 + (notevery #'identity #()) + nil) + +(deftest notevery.3 + (let ((count 0)) + (values + (not (notevery #'(lambda (x) (incf count) (< x 10)) + '(1 2 4 13 5 1))) + count)) + nil 4) + +(deftest notevery.4 + (notevery #'= '(1 2 3 4) '(1 2 3 4 5)) + nil) + +(deftest notevery.5 + (notevery #'= '(1 2 3 4 5) '(1 2 3 4)) + nil) + +(deftest notevery.6 + (not-mv (notevery #'= '(1 2 3 4 5) '(1 2 3 4 6))) + nil) + +(deftest notevery.7 + (notevery #'(lambda (x y) (or x y)) + '(nil t t nil t) #(t nil t t nil nil)) + nil) + +(deftest notevery.8 + (let ((x '(1)) + (args nil)) + (not + (loop for i from 1 below (1- (min 100 call-arguments-limit)) + do (push x args) + always (not (apply #'notevery #'= args))))) + nil) + +(deftest notevery.9 + (notevery #'zerop #*000000000000) + nil) + +(deftest notevery.10 + (notevery #'zerop #*) + nil) + +(deftest notevery.11 + (not-mv (notevery #'zerop #*0000010000)) + nil) + +(deftest notevery.12 + (notevery #'(lambda (x) (eql x #\a)) "aaaaaaaa") + nil) + +(deftest notevery.13 + (notevery #'(lambda (x) (eql x #\a)) "") + nil) + +(deftest notevery.14 + (not-mv (notevery #'(lambda (x) (eql x #\a)) "aaaaaabaaaa")) + nil) + +(deftest notevery.15 + (not-mv (notevery 'null '(nil nil t nil))) + nil) + +(deftest notevery.16 + (notevery 'null '(nil nil nil nil)) + nil) + +(deftest notevery.order.1 + (let ((i 0) a b) + (values + (notevery (progn (setf a (incf i)) #'identity) + (progn (setf b (incf i)) '(a b c d))) + i a b)) + nil 2 1 2) + +;;; Error cases + +(deftest notevery.error.1 + (classify-error (notevery 1 '(a b c))) + type-error) + +(deftest notevery.error.2 + (classify-error (notevery #\a '(a b c))) + type-error) + +(deftest notevery.error.3 + (classify-error (notevery #() '(a b c))) + type-error) + +(deftest notevery.error.4 + (classify-error (notevery #'null 'a)) + type-error) + +(deftest notevery.error.5 + (classify-error (notevery #'null 100)) + type-error) + +(deftest notevery.error.6 + (classify-error (notevery #'null 'a)) + type-error) + +(deftest notevery.error.7 + (classify-error (notevery #'eq () 'a)) + type-error) + +(deftest notevery.error.8 + (classify-error (notevery)) + program-error) + +(deftest notevery.error.9 + (classify-error (notevery #'null)) + program-error) + +(deftest notevery.error.10 + (classify-error (locally (notevery 1 '(a b c)) t)) + type-error) + +(deftest notevery.error.11 + (classify-error (notevery #'cons '(a b c))) + program-error) + +(deftest notevery.error.12 + (classify-error (notevery #'cons '(a b c) '(1 2 4) '(g h j))) + program-error) + +(deftest notevery.error.13 + (classify-error (notevery #'car '(a b c))) + type-error) \ No newline at end of file diff --git a/ansi-tests/nreverse.lsp b/ansi-tests/nreverse.lsp new file mode 100644 index 0000000..d752aa0 --- /dev/null +++ b/ansi-tests/nreverse.lsp @@ -0,0 +1,126 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Aug 21 00:04:57 2002 +;;;; Contains: Tests for NREVERSE + +(in-package :cl-test) + +(deftest nreverse-list.1 + (nreverse nil) + nil) + +(deftest nreverse-list.2 + (let ((x (copy-seq '(a b c)))) + (nreverse x)) + (c b a)) + +(deftest nreverse-vector.1 + (nreverse #()) + #()) + +(deftest nreverse-vector.2 + (let ((x (copy-seq #(a b c d e)))) + (nreverse x)) + #(e d c b a)) + +(deftest nreverse-nonsimple-vector.1 + (let ((x (make-array 0 :fill-pointer t :adjustable t))) + (nreverse x)) + #()) + +(deftest nreverse-nonsimple-vector.2 + (let* ((x (make-array 5 :initial-contents '(1 2 3 4 5) + :fill-pointer t :adjustable t)) + (y (nreverse x))) + (values y (equalt (type-of x) (type-of y)))) + #(5 4 3 2 1) + t) + +(deftest nreverse-nonsimple-vector.3 + (let* ((x (make-array 10 :initial-contents '(1 2 3 4 5 6 7 8 9 10) + :fill-pointer 5)) + (y (nreverse x))) + (values y (equalt (type-of x) (type-of y)))) + #(5 4 3 2 1) + t) + +(deftest nreverse-bit-vector.1 + (nreverse #*) + #*) + +(deftest nreverse-bit-vector.2 + (let ((x (copy-seq #*000110110110))) + (nreverse x)) + #*011011011000) + +(deftest nreverse-bit-vector.3 + (let* ((x (make-array 10 :initial-contents '(0 0 0 1 1 0 1 0 1 0) + :fill-pointer 5 + :element-type 'bit)) + (y (nreverse x))) + y) + #*11000) + +(deftest nreverse-string.1 + (nreverse "") + "") + +(deftest nreverse-string.2 + (let ((x (copy-seq "000110110110"))) + (nreverse x)) + "011011011000") + +(deftest nreverse-string.3 + (let* ((x (make-array 10 :initial-contents "abcdefghij" + :fill-pointer 5 + :element-type 'character)) + (y (nreverse x))) + y) + "edcba") + +(deftest nreverse-string.4 + (let* ((x (make-array 10 :initial-contents "abcdefghij" + :fill-pointer 5 + :element-type 'base-char)) + (y (nreverse x))) + y) + "edcba") + +(deftest nreverse.order.1 + (let ((i 0)) + (values + (nreverse (progn (incf i) (list 'a 'b 'c 'd))) + i)) + (d c b a) 1) + +(deftest nreverse.error.1 + (classify-error (nreverse 'a)) + type-error) + +(deftest nreverse.error.2 + (classify-error (nreverse #\a)) + type-error) + +(deftest nreverse.error.3 + (classify-error (nreverse 10)) + type-error) + +(deftest nreverse.error.4 + (classify-error (nreverse 0.3)) + type-error) + +(deftest nreverse.error.5 + (classify-error (nreverse 10/3)) + type-error) + +(deftest nreverse.error.6 + (classify-error (nreverse)) + program-error) + +(deftest nreverse.error.7 + (classify-error (nreverse nil nil)) + program-error) + +(deftest nreverse.error.8 + (classify-error (locally (nreverse 'a) t)) + type-error) diff --git a/ansi-tests/nstring-capitalize.lsp b/ansi-tests/nstring-capitalize.lsp new file mode 100644 index 0000000..9c9eb17 --- /dev/null +++ b/ansi-tests/nstring-capitalize.lsp @@ -0,0 +1,108 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Thu Oct 3 21:38:49 2002 +;;;; Contains: Tests for NSTRING-CAPITALIZE + +(in-package :cl-test) + +(deftest nstring-capitalize.1 + (let* ((s (copy-seq "abCd")) + (s2 (nstring-capitalize s))) + (values (eqt s s2) s)) + t "Abcd") + +(deftest nstring-capitalize.2 + (let* ((s (copy-seq "0adA2Cdd3wXy")) + (s2 (nstring-capitalize s))) + (values (eqt s s2) s)) + t "0ada2cdd3wxy") + +(deftest nstring-capitalize.3 + (let* ((s (copy-seq "1a")) + (s2 (nstring-capitalize s))) + (values (eqt s s2) s)) + t "1a") + +(deftest nstring-capitalize.4 + (let* ((s (copy-seq "a1a")) + (s2 (nstring-capitalize s))) + (values (eqt s s2) s)) + t "A1a") + +(deftest nstring-capitalize.7 + (let ((s "ABCDEF")) + (loop for i from 0 to 5 + collect (nstring-capitalize (copy-seq s) :start i))) + ("Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF")) + +(deftest nstring-capitalize.8 + (let ((s "ABCDEF")) + (loop for i from 0 to 5 + collect (nstring-capitalize (copy-seq s) :start i :end nil))) + ("Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF")) + +(deftest nstring-capitalize.9 + (let ((s "ABCDEF")) + (loop for i from 0 to 6 + collect (nstring-capitalize (copy-seq s) :end i))) + ("ABCDEF" "ABCDEF" "AbCDEF" "AbcDEF" "AbcdEF" "AbcdeF" "Abcdef")) + +(deftest nstring-capitalize.10 + (let ((s "ABCDEF")) + (loop for i from 0 to 5 + collect (loop for j from i to 6 + collect (nstring-capitalize (copy-seq s) + :start i :end j)))) + (("ABCDEF" "ABCDEF" "AbCDEF" "AbcDEF" "AbcdEF" "AbcdeF" "Abcdef") + ("ABCDEF" "ABCDEF" "ABcDEF" "ABcdEF" "ABcdeF" "ABcdef") + ("ABCDEF" "ABCDEF" "ABCdEF" "ABCdeF" "ABCdef") + ("ABCDEF" "ABCDEF" "ABCDeF" "ABCDef") + ("ABCDEF" "ABCDEF" "ABCDEf") + ("ABCDEF" "ABCDEF"))) + +(deftest nstring-capitalize.order.1 + (let ((i 0) a b c (s (copy-seq "abcdef"))) + (values + (nstring-capitalize + (progn (setf a (incf i)) s) + :start (progn (setf b (incf i)) 1) + :end (progn (setf c (incf i)) 4)) + i a b c)) + "aBcdef" 3 1 2 3) + +(deftest nstring-capitalize.order.2 + (let ((i 0) a b c (s (copy-seq "abcdef"))) + (values + (nstring-capitalize + (progn (setf a (incf i)) s) + :end (progn (setf b (incf i)) 4) + :start (progn (setf c (incf i)) 1)) + i a b c)) + "aBcdef" 3 1 2 3) + +;;; Error cases + +(deftest nstring-capitalize.error.1 + (classify-error (nstring-capitalize)) + program-error) + +(deftest nstring-capitalize.error.2 + (classify-error (nstring-capitalize (copy-seq "abc") :bad t)) + program-error) + +(deftest nstring-capitalize.error.3 + (classify-error (nstring-capitalize (copy-seq "abc") :start)) + program-error) + +(deftest nstring-capitalize.error.4 + (classify-error (nstring-capitalize (copy-seq "abc") :bad t + :allow-other-keys nil)) + program-error) + +(deftest nstring-capitalize.error.5 + (classify-error (nstring-capitalize (copy-seq "abc") :end)) + program-error) + +(deftest nstring-capitalize.error.6 + (classify-error (nstring-capitalize (copy-seq "abc") 1 2)) + program-error) diff --git a/ansi-tests/nstring-downcase.lsp b/ansi-tests/nstring-downcase.lsp new file mode 100644 index 0000000..409bc3c --- /dev/null +++ b/ansi-tests/nstring-downcase.lsp @@ -0,0 +1,118 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Thu Oct 3 21:33:16 2002 +;;;; Contains: Tests for NSTRING-DOWNCASE + +(in-package :cl-test) + +(deftest nstring-downcase.1 + (let* ((s (copy-seq "A")) + (s2 (nstring-downcase s))) + (values (eqt s s2) s)) + t "a") + +(deftest nstring-downcase.2 + (let* ((s (copy-seq "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")) + (s2 (nstring-downcase s))) + (values (eqt s s2) s)) + t + "abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz") + +(deftest nstring-downcase.3 + (let* ((s (copy-seq "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ")) + (s2 (nstring-downcase s))) + (values (eqt s s2) s)) + t + "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ") + +(deftest nstring-downcase.6 + (let* ((s (make-array 6 :element-type 'character + :initial-contents '(#\A #\B #\C #\D #\E #\F))) + (s2 (nstring-downcase s))) + (values (eqt s s2) s)) + t "abcdef") + +(deftest nstring-downcase.7 + (let* ((s (make-array 6 :element-type 'standard-char + :initial-contents '(#\A #\B #\7 #\D #\E #\F))) + (s2 (nstring-downcase s))) + (values (eqt s s2) s)) + t + "ab7def") + +;; Tests with :start, :end + +(deftest nstring-downcase.8 + (let ((s "ABCDEF")) + (loop for i from 0 to 6 + collect (nstring-downcase (copy-seq s) :start i))) + ("abcdef" "Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF")) + +(deftest nstring-downcase.9 + (let ((s "ABCDEF")) + (loop for i from 0 to 6 + collect (nstring-downcase (copy-seq s) :start i :end nil))) + ("abcdef" "Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF")) + +(deftest nstring-downcase.10 + (let ((s "ABCDE")) + (loop for i from 0 to 4 + collect (loop for j from i to 5 + collect (string-invertcase + (nstring-downcase (copy-seq s) + :start i :end j))))) + (("abcde" "Abcde" "ABcde" "ABCde" "ABCDe" "ABCDE") + ("abcde" "aBcde" "aBCde" "aBCDe" "aBCDE") + ("abcde" "abCde" "abCDe" "abCDE") + ("abcde" "abcDe" "abcDE") + ("abcde" "abcdE"))) + +(deftest nstring-downcase.order.1 + (let ((i 0) a b c (s (copy-seq "ABCDEF"))) + (values + (nstring-downcase + (progn (setf a (incf i)) s) + :start (progn (setf b (incf i)) 1) + :end (progn (setf c (incf i)) 4)) + i a b c)) + "AbcdEF" 3 1 2 3) + +(deftest nstring-downcase.order.2 + (let ((i 0) a b c (s (copy-seq "ABCDEF"))) + (values + (nstring-downcase + (progn (setf a (incf i)) s) + :end (progn (setf b (incf i)) 4) + :start (progn (setf c (incf i)) 1)) + i a b c)) + "AbcdEF" 3 1 2 3) + +;;; Error cases + +(deftest nstring-downcase.error.1 + (classify-error (nstring-downcase)) + program-error) + +(deftest nstring-downcase.error.2 + (classify-error (nstring-downcase (copy-seq "abc") :bad t)) + program-error) + +(deftest nstring-downcase.error.3 + (classify-error (nstring-downcase (copy-seq "abc") :start)) + program-error) + +(deftest nstring-downcase.error.4 + (classify-error (nstring-downcase (copy-seq "abc") :bad t + :allow-other-keys nil)) + program-error) + +(deftest nstring-downcase.error.5 + (classify-error (nstring-downcase (copy-seq "abc") :end)) + program-error) + +(deftest nstring-downcase.error.6 + (classify-error (nstring-downcase (copy-seq "abc") 1 2)) + program-error) + + + diff --git a/ansi-tests/nstring-upcase.lsp b/ansi-tests/nstring-upcase.lsp new file mode 100644 index 0000000..5f6baf1 --- /dev/null +++ b/ansi-tests/nstring-upcase.lsp @@ -0,0 +1,115 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Thu Oct 3 21:12:40 2002 +;;;; Contains: Tests for NSTRING-UPCASE + +(in-package :cl-test) + +(deftest nstring-upcase.1 + (let* ((s (copy-seq "a")) + (s2 (nstring-upcase s))) + (values (eqt s s2) s)) + t "A") + +(deftest nstring-upcase.2 + (let* ((s (copy-seq "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")) + (s2 (nstring-upcase s))) + (values (eqt s s2) s)) + t + "ABCDEFGHIJKLMNOPQRSTUVWXYZABCDEFGHIJKLMNOPQRSTUVWXYZ") + +(deftest nstring-upcase.3 + (let* ((s (copy-seq "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ")) + (s2 (nstring-upcase s))) + (values (eqt s s2) s)) + t + "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ") + +(deftest nstring-upcase.6 + (let* ((s (make-array 6 :element-type 'character + :initial-contents '(#\a #\b #\c #\d #\e #\f))) + (s2 (nstring-upcase s))) + (values (eqt s s2) s)) + t "ABCDEF") + +(deftest nstring-upcase.7 + (let* ((s (make-array 6 :element-type 'standard-char + :initial-contents '(#\a #\b #\7 #\d #\e #\f))) + (s2 (nstring-upcase s))) + (values (eqt s s2) s)) + t "AB7DEF") + +;; Tests with :start, :end + +(deftest nstring-upcase.8 + (let ((s "abcdef")) + (loop for i from 0 to 6 + collect (nstring-upcase (copy-seq s) :start i))) + ("ABCDEF" "aBCDEF" "abCDEF" "abcDEF" "abcdEF" "abcdeF" "abcdef")) + +(deftest nstring-upcase.9 + (let ((s "abcdef")) + (loop for i from 0 to 6 + collect + (nstring-upcase (copy-seq s) :start i :end nil))) + ("ABCDEF" "aBCDEF" "abCDEF" "abcDEF" "abcdEF" "abcdeF" "abcdef")) + +(deftest nstring-upcase.10 + (let ((s "abcde")) + (loop for i from 0 to 4 + collect (loop for j from i to 5 + collect (nstring-upcase (copy-seq s) + :start i :end j)))) + (("abcde" "Abcde" "ABcde" "ABCde" "ABCDe" "ABCDE") + ("abcde" "aBcde" "aBCde" "aBCDe" "aBCDE") + ("abcde" "abCde" "abCDe" "abCDE") + ("abcde" "abcDe" "abcDE") + ("abcde" "abcdE"))) + +(deftest nstring-upcase.order.1 + (let ((i 0) a b c (s (copy-seq "abcdef"))) + (values + (nstring-upcase + (progn (setf a (incf i)) s) + :start (progn (setf b (incf i)) 1) + :end (progn (setf c (incf i)) 4)) + i a b c)) + "aBCDef" 3 1 2 3) + +(deftest nstring-upcase.order.2 + (let ((i 0) a b c (s (copy-seq "abcdef"))) + (values + (nstring-upcase + (progn (setf a (incf i)) s) + :end (progn (setf b (incf i)) 4) + :start (progn (setf c (incf i)) 1)) + i a b c)) + "aBCDef" 3 1 2 3) + + +;;; Error cases + +(deftest nstring-upcase.error.1 + (classify-error (nstring-upcase)) + program-error) + +(deftest nstring-upcase.error.2 + (classify-error (nstring-upcase (copy-seq "abc") :bad t)) + program-error) + +(deftest nstring-upcase.error.3 + (classify-error (nstring-upcase (copy-seq "abc") :start)) + program-error) + +(deftest nstring-upcase.error.4 + (classify-error (nstring-upcase (copy-seq "abc") :bad t + :allow-other-keys nil)) + program-error) + +(deftest nstring-upcase.error.5 + (classify-error (nstring-upcase (copy-seq "abc") :end)) + program-error) + +(deftest nstring-upcase.error.6 + (classify-error (nstring-upcase (copy-seq "abc") 1 2)) + program-error) diff --git a/ansi-tests/nsubstitute-if-not.lsp b/ansi-tests/nsubstitute-if-not.lsp new file mode 100644 index 0000000..78528a3 --- /dev/null +++ b/ansi-tests/nsubstitute-if-not.lsp @@ -0,0 +1,761 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Aug 31 19:00:55 2002 +;;;; Contains: Tests for NSUBSTITUTE-IF-NOT + +(in-package :cl-test) + +(deftest nsubstitute-if-not-list.1 + (nsubstitute-if-not 'b 'identity nil) + nil) + +(deftest nsubstitute-if-not-list.2 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x) x) + (b b b c)) + +(deftest nsubstitute-if-not-list.3 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count nil)) + (b b b c)) + +(deftest nsubstitute-if-not-list.4 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 2)) + (b b b c)) + +(deftest nsubstitute-if-not-list.5 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 1)) + (b b a c)) + +(deftest nsubstitute-if-not-list.6 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 0)) + (a b a c)) + +(deftest nsubstitute-if-not-list.7 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count -1)) + (a b a c)) + +(deftest nsubstitute-if-not-list.8 + (nsubstitute-if-not 'b (is-not-eq-p 'a) nil :from-end t) + nil) + +(deftest nsubstitute-if-not-list.9 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :from-end t)) + (b b b c)) + +(deftest nsubstitute-if-not-list.10 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :from-end t :count nil)) + (b b b c)) + +(deftest nsubstitute-if-not-list.11 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 2 :from-end t)) + (b b b c)) + +(deftest nsubstitute-if-not-list.12 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 1 :from-end t)) + (a b b c)) + +(deftest nsubstitute-if-not-list.13 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 0 :from-end t)) + (a b a c)) + +(deftest nsubstitute-if-not-list.14 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count -1 :from-end t)) + (a b a c)) + +(deftest nsubstitute-if-not-list.15 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if-not 'x (is-not-eq-p 'a) x :start i :end j))) + (equal y (nconc (make-list i :initial-element 'a) + (make-list (- j i) :initial-element 'x) + (make-list (- 10 j) :initial-element 'a)))))) + t) + +(deftest nsubstitute-if-not-list.16 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :from-end t))) + (equal y (nconc (make-list i :initial-element 'a) + (make-list (- j i) :initial-element 'x) + (make-list (- 10 j) :initial-element 'a)))))) + t) + +(deftest nsubstitute-if-not-list.17 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :count c))) + (equal y (nconc (make-list i :initial-element 'a) + (make-list c :initial-element 'x) + (make-list (- 10 (+ i c)) :initial-element 'a))))))) + t) + +(deftest nsubstitute-if-not-list.18 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :count c :from-end t))) + (equal y (nconc (make-list (- j c) :initial-element 'a) + (make-list c :initial-element 'x) + (make-list (- 10 j) :initial-element 'a))))))) + t) + +;;; Tests on vectors + +(deftest nsubstitute-if-not-vector.1 + (let ((x #())) (nsubstitute-if-not 'b (is-not-eq-p 'a) x)) + #()) + +(deftest nsubstitute-if-not-vector.2 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x)) + #(b b b c)) + +(deftest nsubstitute-if-not-vector.3 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count nil) x) + #(b b b c)) + +(deftest nsubstitute-if-not-vector.4 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 2)) + #(b b b c)) + +(deftest nsubstitute-if-not-vector.5 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 1)) + #(b b a c)) + +(deftest nsubstitute-if-not-vector.6 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 0)) + #(a b a c)) + +(deftest nsubstitute-if-not-vector.7 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count -1)) + #(a b a c)) + +(deftest nsubstitute-if-not-vector.8 + (let ((x #())) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :from-end t)) + #()) + +(deftest nsubstitute-if-not-vector.9 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :from-end t)) + #(b b b c)) + +(deftest nsubstitute-if-not-vector.10 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :from-end t :count nil)) + #(b b b c)) + +(deftest nsubstitute-if-not-vector.11 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 2 :from-end t)) + #(b b b c)) + +(deftest nsubstitute-if-not-vector.12 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 1 :from-end t)) + #(a b b c)) + +(deftest nsubstitute-if-not-vector.13 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count 0 :from-end t)) + #(a b a c)) + +(deftest nsubstitute-if-not-vector.14 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eq-p 'a) x :count -1 :from-end t)) + #(a b a c)) + +(deftest nsubstitute-if-not-vector.15 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if-not 'x (is-not-eq-p 'a) x :start i :end j))) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array (- j i) :initial-element 'x) + (make-array (- 10 j) :initial-element 'a)))))) + t) + +(deftest nsubstitute-if-not-vector.16 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :from-end t))) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array (- j i) :initial-element 'x) + (make-array (- 10 j) :initial-element 'a)))))) + t) + +(deftest nsubstitute-if-not-vector.17 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :count c))) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array c :initial-element 'x) + (make-array (- 10 (+ i c)) :initial-element 'a))))))) + t) + +(deftest nsubstitute-if-not-vector.18 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :count c :from-end t))) + (equalp y (concatenate 'simple-vector + (make-array (- j c) :initial-element 'a) + (make-array c :initial-element 'x) + (make-array (- 10 j) :initial-element 'a))))))) + t) + +(deftest nsubstitute-if-not-vector.28 + (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) + :fill-pointer 5)) + (result (nsubstitute-if-not 'z (is-not-eql-p 'a) x))) + result) + #(z b z c b)) + +(deftest nsubstitute-if-not-vector.29 + (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) + :fill-pointer 5)) + (result (nsubstitute-if-not 'z (is-not-eql-p 'a) x :from-end t))) + result) + #(z b z c b)) + +(deftest nsubstitute-if-not-vector.30 + (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) + :fill-pointer 5)) + (result (nsubstitute-if-not 'z (is-not-eql-p 'a) x :count 1))) + result) + #(z b a c b)) + +(deftest nsubstitute-if-not-vector.31 + (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) + :fill-pointer 5)) + (result (nsubstitute-if-not 'z (is-not-eql-p 'a) x + :from-end t :count 1))) + result) + #(a b z c b)) + +;;; Tests on strings + +(deftest nsubstitute-if-not-string.1 + (let ((x "")) (nsubstitute-if-not #\b (is-not-eq-p #\a) x)) + "") + +(deftest nsubstitute-if-not-string.2 + (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x)) + "bbbc") + +(deftest nsubstitute-if-not-string.3 + (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :count nil)) + "bbbc") + +(deftest nsubstitute-if-not-string.4 + (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :count 2)) + "bbbc") + +(deftest nsubstitute-if-not-string.5 + (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :count 1)) + "bbac") + +(deftest nsubstitute-if-not-string.6 + (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :count 0)) + "abac") + +(deftest nsubstitute-if-not-string.7 + (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :count -1)) + "abac") + +(deftest nsubstitute-if-not-string.8 + (let ((x "")) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :from-end t)) + "") + +(deftest nsubstitute-if-not-string.9 + (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :from-end t)) + "bbbc") + +(deftest nsubstitute-if-not-string.10 + (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :from-end t :count nil)) + "bbbc") + +(deftest nsubstitute-if-not-string.11 + (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :count 2 :from-end t)) + "bbbc") + +(deftest nsubstitute-if-not-string.12 + (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :count 1 :from-end t)) + "abbc") + +(deftest nsubstitute-if-not-string.13 + (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :count 0 :from-end t)) + "abac") + +(deftest nsubstitute-if-not-string.14 + (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eq-p #\a) x :count -1 :from-end t)) + "abac") + +(deftest nsubstitute-if-not-string.15 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (nsubstitute-if-not #\x (is-not-eq-p #\a) x :start i :end j))) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array (- j i) :initial-element #\x) + (make-array (- 10 j) :initial-element #\a)))))) + t) + +(deftest nsubstitute-if-not-string.16 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (nsubstitute-if-not #\x (is-not-eq-p #\a) x :start i :end j :from-end t))) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array (- j i) :initial-element #\x) + (make-array (- 10 j) :initial-element #\a)))))) + t) + +(deftest nsubstitute-if-not-string.17 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (nsubstitute-if-not #\x (is-not-eq-p #\a) x :start i :end j :count c))) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array c :initial-element #\x) + (make-array (- 10 (+ i c)) :initial-element #\a))))))) + t) + +(deftest nsubstitute-if-not-string.18 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (nsubstitute-if-not #\x (is-not-eq-p #\a) x :start i :end j :count c :from-end t))) + (equalp y (concatenate 'simple-string + (make-array (- j c) :initial-element #\a) + (make-array c :initial-element #\x) + (make-array (- 10 j) :initial-element #\a))))))) + t) + +(deftest nsubstitute-if-not-string.28 + (let* ((x (make-array '(10) :initial-contents "abacbadeaf" + :fill-pointer 5 :element-type 'character)) + (result (nsubstitute-if-not #\z (is-not-eql-p #\a) x))) + result) + "zbzcb") + +(deftest nsubstitute-if-not-string.29 + (let* ((x (make-array '(10) :initial-contents "abacbadeaf" + :fill-pointer 5 :element-type 'character)) + (result (nsubstitute-if-not #\z (is-not-eql-p #\a) x :from-end t))) + result) + "zbzcb") + +(deftest nsubstitute-if-not-string.30 + (let* ((x (make-array '(10) :initial-contents "abacbadeaf" + :fill-pointer 5 :element-type 'character)) + (result (nsubstitute-if-not #\z (is-not-eql-p #\a) x :count 1))) + result) + "zbacb") + +(deftest nsubstitute-if-not-string.31 + (let* ((x (make-array '(10) :initial-contents "abacbadeaf" + :fill-pointer 5 :element-type 'character)) + (result (nsubstitute-if-not #\z (is-not-eql-p #\a) x + :from-end t :count 1))) + result) + "abzcb") + + +;;; Tests on bit-vectors + +(deftest nsubstitute-if-not-bit-vector.1 + (let* ((orig #*) + (x (copy-seq orig)) + (result (nsubstitute-if-not 0 (is-not-eq-p 1) x))) + result) + #*) + +(deftest nsubstitute-if-not-bit-vector.2 + (let* ((orig #*) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eq-p 0) x))) + result) + #*) + +(deftest nsubstitute-if-not-bit-vector.3 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if-not 0 (is-not-eq-p 1) x))) + result) + #*000000) + +(deftest nsubstitute-if-not-bit-vector.4 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eq-p 0) x))) + result) + #*111111) + +(deftest nsubstitute-if-not-bit-vector.5 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :start 1))) + result) + #*011111) + +(deftest nsubstitute-if-not-bit-vector.6 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if-not 0 (is-not-eq-p 1) x :start 2 :end nil))) + result) + #*010000) + +(deftest nsubstitute-if-not-bit-vector.7 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :end 4))) + result) + #*111101) + +(deftest nsubstitute-if-not-bit-vector.8 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if-not 0 (is-not-eq-p 1) x :end nil))) + result) + #*000000) + +(deftest nsubstitute-if-not-bit-vector.9 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if-not 0 (is-not-eq-p 1) x :end 3))) + result) + #*000101) + +(deftest nsubstitute-if-not-bit-vector.10 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if-not 0 (is-not-eq-p 1) x :start 2 :end 4))) + result) + #*010001) + +(deftest nsubstitute-if-not-bit-vector.11 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :start 2 :end 4))) + result) + #*011101) + +(deftest nsubstitute-if-not-bit-vector.12 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :count 1))) + result) + #*110101) + +(deftest nsubstitute-if-not-bit-vector.13 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :count 0))) + result) + #*010101) + +(deftest nsubstitute-if-not-bit-vector.14 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :count -1))) + result) + #*010101) + +(deftest nsubstitute-if-not-bit-vector.15 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :count 1 :from-end t))) + result) + #*010111) + +(deftest nsubstitute-if-not-bit-vector.16 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :count 0 :from-end t))) + result) + #*010101) + +(deftest nsubstitute-if-not-bit-vector.17 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :count -1 :from-end t))) + result) + #*010101) + +(deftest nsubstitute-if-not-bit-vector.18 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :count nil))) + result) + #*111111) + +(deftest nsubstitute-if-not-bit-vector.19 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eq-p 0) x :count nil :from-end t))) + result) + #*111111) + +(deftest nsubstitute-if-not-bit-vector.20 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #*0000000000) + (x (copy-seq orig)) + (y (nsubstitute-if-not 1 (is-not-eq-p 0) x :start i :end j :count c))) + (equalp y (concatenate + 'simple-bit-vector + (make-list i :initial-element 0) + (make-list c :initial-element 1) + (make-list (- 10 (+ i c)) :initial-element 0))))))) + t) + +(deftest nsubstitute-if-not-bit-vector.21 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #*1111111111) + (x (copy-seq orig)) + (y (nsubstitute-if-not 0 (is-not-eq-p 1) x :start i :end j :count c :from-end t))) + (equalp y (concatenate + 'simple-bit-vector + (make-list (- j c) :initial-element 1) + (make-list c :initial-element 0) + (make-list (- 10 j) :initial-element 1))))))) + t) + + +;;; More tests + +(deftest nsubstitute-if-not-list.24 + (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (nsubstitute-if-not '(a 10) (is-not-eq-p 'a) x :key #'car))) + result) + ((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) + +(deftest nsubstitute-if-not-list.25 + (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (nsubstitute-if-not '(a 10) (is-not-eq-p 'a) x + :key #'car :start 1 :end 5))) + result) + ((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) + +(deftest nsubstitute-if-not-vector.24 + (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (nsubstitute-if-not '(a 10) (is-not-eq-p 'a) x :key #'car))) + result) + #((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) + +(deftest nsubstitute-if-not-vector.25 + (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (nsubstitute-if-not '(a 10) (is-not-eq-p 'a) x :key #'car :start 1 :end 5))) + result) + #((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) + +(deftest nsubstitute-if-not-string.24 + (let* ((orig "0102342015") + (x (copy-seq orig)) + (result (nsubstitute-if-not #\a (is-not-eq-p #\1) x :key #'nextdigit))) + result) + "a1a2342a15") + +(deftest nsubstitute-if-not-string.25 + (let* ((orig "0102342015") + (x (copy-seq orig)) + (result (nsubstitute-if-not #\a (is-not-eq-p #\1) x :key #'nextdigit :start 1 :end 6))) + result) + "01a2342015") + +(deftest nsubstitute-if-not-bit-vector.26 + (let* ((orig #*00111001011010110) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eq-p 1) x :key #'1+))) + result) + #*11111111111111111) + +(deftest nsubstitute-if-not-bit-vector.27 + (let* ((orig #*00111001011010110) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eq-p 1) x :key #'1+ :start 1 :end 10))) + result) + #*01111111111010110) + +(deftest nsubstitute-if-not-bit-vector.30 + (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) + :fill-pointer 5 :element-type 'bit)) + (result (nsubstitute-if-not 1 #'onep x))) + result) + #*11111) + +(deftest nsubstitute-if-not-bit-vector.31 + (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) + :fill-pointer 5 :element-type 'bit)) + (result (nsubstitute-if-not 1 #'onep x :from-end t))) + result) + #*11111) + +(deftest nsubstitute-if-not-bit-vector.32 + (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) + :fill-pointer 5 :element-type 'bit)) + (result (nsubstitute-if-not 1 #'onep x :count 1))) + result) + #*11011) + +(deftest nsubstitute-if-not-bit-vector.33 + (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) + :fill-pointer 5 :element-type 'bit)) + (result (nsubstitute-if-not 1 #'onep x :from-end t :count 1))) + result) + #*01111) + +(deftest nsubstitute-if-not.order.1 + (let ((i 0) a b c d e f g h) + (values + (nsubstitute-if-not + (progn (setf a (incf i)) 'a) + (progn (setf b (incf i)) #'identity) + (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) + :count (progn (setf d (incf i)) 2) + :start (progn (setf e (incf i)) 0) + :end (progn (setf f (incf i)) 7) + :key (progn (setf g (incf i)) #'identity) + :from-end (setf h (incf i)) + ) + i a b c d e f g h)) + (nil 1 2 a 3 4 a 5) + 8 1 2 3 4 5 6 7 8) + +(deftest nsubstitute-if-not.order.2 + (let ((i 0) a b c d e f g h) + (values + (nsubstitute-if-not + (progn (setf a (incf i)) 'a) + (progn (setf b (incf i)) #'identity) + (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) + :from-end (setf h (incf i)) + :key (progn (setf g (incf i)) #'identity) + :end (progn (setf f (incf i)) 7) + :start (progn (setf e (incf i)) 0) + :count (progn (setf d (incf i)) 2) + ) + i a b c d e f g h)) + (nil 1 2 a 3 4 a 5) + 8 1 2 3 8 7 6 5 4) + + +;;; Keyword tests + +(deftest nsubstitute-if-not.allow-other-keys.1 + (nsubstitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) + :allow-other-keys t :bad t) + (a a 0 a a 0 a)) + +(deftest nsubstitute-if-not.allow-other-keys.2 + (nsubstitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) + :bad t :allow-other-keys t) + (a a 0 a a 0 a)) + +(deftest nsubstitute-if-not.allow-other-keys.3 + (nsubstitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t + :allow-other-keys nil :bad t) + (a a 0 a a 0 a)) + +(deftest nsubstitute-if-not.allow-other-keys.4 + (nsubstitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :bad t + :allow-other-keys t :allow-other-keys nil) + (a a 0 a a 0 a)) + +(deftest nsubstitute-if-not.allow-other-keys.5 + (nsubstitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) + :allow-other-keys t :key #'1-) + (1 a a a 1 a a)) + +(deftest nsubstitute-if-not.keywords.6 + (nsubstitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) + :key #'1- :key #'identity) + (1 a a a 1 a a)) + +(deftest nsubstitute-if-not.allow-other-keys.7 + (nsubstitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t + :bad t :allow-other-keys nil) + (a a 0 a a 0 a)) + +(deftest nsubstitute-if-not.allow-other-keys.8 + (nsubstitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys nil) + (a a 0 a a 0 a)) + + +;;; Error cases + +(deftest nsubstitute-if-not.error.1 + (classify-error (nsubstitute-if-not)) + program-error) + +(deftest nsubstitute-if-not.error.2 + (classify-error (nsubstitute-if-not 'a)) + program-error) + +(deftest nsubstitute-if-not.error.3 + (classify-error (nsubstitute-if-not 'a #'null)) + program-error) + +(deftest nsubstitute-if-not.error.4 + (classify-error (nsubstitute-if-not 'a #'null nil 'bad t)) + program-error) + +(deftest nsubstitute-if-not.error.5 + (classify-error (nsubstitute-if-not 'a #'null nil + 'bad t :allow-other-keys nil)) + program-error) + +(deftest nsubstitute-if-not.error.6 + (classify-error (nsubstitute-if-not 'a #'null nil :key)) + program-error) + +(deftest nsubstitute-if-not.error.7 + (classify-error (nsubstitute-if-not 'a #'null nil 1 2)) + program-error) + +(deftest nsubstitute-if-not.error.8 + (classify-error (nsubstitute-if-not 'a #'cons (list 'a 'b 'c))) + program-error) + +(deftest nsubstitute-if-not.error.9 + (classify-error (nsubstitute-if-not 'a #'car (list 'a 'b 'c))) + type-error) + +(deftest nsubstitute-if-not.error.10 + (classify-error (nsubstitute-if-not 'a #'identity (list 'a 'b 'c) + :key #'car)) + type-error) + +(deftest nsubstitute-if-not.error.11 + (classify-error (nsubstitute-if-not 'a #'identity (list 'a 'b 'c) + :key #'cons)) + program-error) + diff --git a/ansi-tests/nsubstitute-if.lsp b/ansi-tests/nsubstitute-if.lsp new file mode 100644 index 0000000..91f7ade --- /dev/null +++ b/ansi-tests/nsubstitute-if.lsp @@ -0,0 +1,753 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Aug 31 18:56:41 2002 +;;;; Contains: Tests for NSUBSTITUTE-IF + +(in-package :cl-test) + +(deftest nsubstitute-if-list.1 + (nsubstitute-if 'b 'identity nil) + nil) + +(deftest nsubstitute-if-list.2 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x) x) + (b b b c)) + +(deftest nsubstitute-if-list.3 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count nil)) + (b b b c)) + +(deftest nsubstitute-if-list.4 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 2)) + (b b b c)) + +(deftest nsubstitute-if-list.5 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 1)) + (b b a c)) + +(deftest nsubstitute-if-list.6 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 0)) + (a b a c)) + +(deftest nsubstitute-if-list.7 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count -1)) + (a b a c)) + +(deftest nsubstitute-if-list.8 + (nsubstitute-if 'b (is-eq-p 'a) nil :from-end t) + nil) + +(deftest nsubstitute-if-list.9 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :from-end t)) + (b b b c)) + +(deftest nsubstitute-if-list.10 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :from-end t :count nil)) + (b b b c)) + +(deftest nsubstitute-if-list.11 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 2 :from-end t)) + (b b b c)) + +(deftest nsubstitute-if-list.12 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 1 :from-end t)) + (a b b c)) + +(deftest nsubstitute-if-list.13 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 0 :from-end t)) + (a b a c)) + +(deftest nsubstitute-if-list.14 + (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count -1 :from-end t)) + (a b a c)) + +(deftest nsubstitute-if-list.15 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if 'x (is-eq-p 'a) x :start i :end j))) + (equal y (nconc (make-list i :initial-element 'a) + (make-list (- j i) :initial-element 'x) + (make-list (- 10 j) :initial-element 'a)))))) + t) + +(deftest nsubstitute-if-list.16 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if 'x (is-eq-p 'a) x :start i :end j :from-end t))) + (equal y (nconc (make-list i :initial-element 'a) + (make-list (- j i) :initial-element 'x) + (make-list (- 10 j) :initial-element 'a)))))) + t) + +(deftest nsubstitute-if-list.17 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if 'x (is-eq-p 'a) x :start i :end j :count c))) + (equal y (nconc (make-list i :initial-element 'a) + (make-list c :initial-element 'x) + (make-list (- 10 (+ i c)) :initial-element 'a))))))) + t) + +(deftest nsubstitute-if-list.18 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if 'x (is-eq-p 'a) x :start i :end j :count c :from-end t))) + (equal y (nconc (make-list (- j c) :initial-element 'a) + (make-list c :initial-element 'x) + (make-list (- 10 j) :initial-element 'a))))))) + t) + +;;; Tests on vectors + +(deftest nsubstitute-if-vector.1 + (let ((x #())) (nsubstitute-if 'b (is-eq-p 'a) x)) + #()) + +(deftest nsubstitute-if-vector.2 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x)) + #(b b b c)) + +(deftest nsubstitute-if-vector.3 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count nil) x) + #(b b b c)) + +(deftest nsubstitute-if-vector.4 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 2)) + #(b b b c)) + +(deftest nsubstitute-if-vector.5 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 1)) + #(b b a c)) + +(deftest nsubstitute-if-vector.6 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 0)) + #(a b a c)) + +(deftest nsubstitute-if-vector.7 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count -1)) + #(a b a c)) + +(deftest nsubstitute-if-vector.8 + (let ((x #())) (nsubstitute-if 'b (is-eq-p 'a) x :from-end t)) + #()) + +(deftest nsubstitute-if-vector.9 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :from-end t)) + #(b b b c)) + +(deftest nsubstitute-if-vector.10 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :from-end t :count nil)) + #(b b b c)) + +(deftest nsubstitute-if-vector.11 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 2 :from-end t)) + #(b b b c)) + +(deftest nsubstitute-if-vector.12 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 1 :from-end t)) + #(a b b c)) + +(deftest nsubstitute-if-vector.13 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count 0 :from-end t)) + #(a b a c)) + +(deftest nsubstitute-if-vector.14 + (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eq-p 'a) x :count -1 :from-end t)) + #(a b a c)) + +(deftest nsubstitute-if-vector.15 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if 'x (is-eq-p 'a) x :start i :end j))) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array (- j i) :initial-element 'x) + (make-array (- 10 j) :initial-element 'a)))))) + t) + +(deftest nsubstitute-if-vector.16 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if 'x (is-eq-p 'a) x :start i :end j :from-end t))) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array (- j i) :initial-element 'x) + (make-array (- 10 j) :initial-element 'a)))))) + t) + +(deftest nsubstitute-if-vector.17 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if 'x (is-eq-p 'a) x :start i :end j :count c))) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array c :initial-element 'x) + (make-array (- 10 (+ i c)) :initial-element 'a))))))) + t) + +(deftest nsubstitute-if-vector.18 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if 'x (is-eq-p 'a) x :start i :end j :count c :from-end t))) + (equalp y (concatenate 'simple-vector + (make-array (- j c) :initial-element 'a) + (make-array c :initial-element 'x) + (make-array (- 10 j) :initial-element 'a))))))) + t) + +(deftest nsubstitute-if-vector.28 + (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) + :fill-pointer 5)) + (result (nsubstitute-if 'z (is-eql-p 'a) x))) + result) + #(z b z c b)) + +(deftest nsubstitute-if-vector.29 + (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) + :fill-pointer 5)) + (result (nsubstitute-if 'z (is-eql-p 'a) x :from-end t))) + result) + #(z b z c b)) + +(deftest nsubstitute-if-vector.30 + (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) + :fill-pointer 5)) + (result (nsubstitute-if 'z (is-eql-p 'a) x :count 1))) + result) + #(z b a c b)) + +(deftest nsubstitute-if-vector.31 + (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) + :fill-pointer 5)) + (result (nsubstitute-if 'z (is-eql-p 'a) x :from-end t :count 1))) + result) + #(a b z c b)) + +;;; Tests on strings + +(deftest nsubstitute-if-string.1 + (let ((x "")) (nsubstitute-if #\b (is-eq-p #\a) x)) + "") + +(deftest nsubstitute-if-string.2 + (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x)) + "bbbc") + +(deftest nsubstitute-if-string.3 + (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :count nil)) + "bbbc") + +(deftest nsubstitute-if-string.4 + (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :count 2)) + "bbbc") + +(deftest nsubstitute-if-string.5 + (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :count 1)) + "bbac") + +(deftest nsubstitute-if-string.6 + (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :count 0)) + "abac") + +(deftest nsubstitute-if-string.7 + (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :count -1)) + "abac") + +(deftest nsubstitute-if-string.8 + (let ((x "")) (nsubstitute-if #\b (is-eq-p #\a) x :from-end t)) + "") + +(deftest nsubstitute-if-string.9 + (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :from-end t)) + "bbbc") + +(deftest nsubstitute-if-string.10 + (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :from-end t :count nil)) + "bbbc") + +(deftest nsubstitute-if-string.11 + (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :count 2 :from-end t)) + "bbbc") + +(deftest nsubstitute-if-string.12 + (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :count 1 :from-end t)) + "abbc") + +(deftest nsubstitute-if-string.13 + (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :count 0 :from-end t)) + "abac") + +(deftest nsubstitute-if-string.14 + (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eq-p #\a) x :count -1 :from-end t)) + "abac") + +(deftest nsubstitute-if-string.15 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (nsubstitute-if #\x (is-eq-p #\a) x :start i :end j))) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array (- j i) :initial-element #\x) + (make-array (- 10 j) :initial-element #\a)))))) + t) + +(deftest nsubstitute-if-string.16 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (nsubstitute-if #\x (is-eq-p #\a) x :start i :end j :from-end t))) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array (- j i) :initial-element #\x) + (make-array (- 10 j) :initial-element #\a)))))) + t) + +(deftest nsubstitute-if-string.17 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (nsubstitute-if #\x (is-eq-p #\a) x :start i :end j :count c))) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array c :initial-element #\x) + (make-array (- 10 (+ i c)) :initial-element #\a))))))) + t) + +(deftest nsubstitute-if-string.18 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (nsubstitute-if #\x (is-eq-p #\a) x :start i :end j :count c :from-end t))) + (equalp y (concatenate 'simple-string + (make-array (- j c) :initial-element #\a) + (make-array c :initial-element #\x) + (make-array (- 10 j) :initial-element #\a))))))) + t) + +(deftest nsubstitute-if-string.28 + (let* ((x (make-array '(10) :initial-contents "abacbadeaf" + :fill-pointer 5 :element-type 'character)) + (result (nsubstitute-if #\z (is-eql-p #\a) x))) + result) + "zbzcb") + +(deftest nsubstitute-if-string.29 + (let* ((x (make-array '(10) :initial-contents "abacbadeaf" + :fill-pointer 5 :element-type 'character)) + (result (nsubstitute-if #\z (is-eql-p #\a) x :from-end t))) + result) + "zbzcb") + +(deftest nsubstitute-if-string.30 + (let* ((x (make-array '(10) :initial-contents "abacbadeaf" + :fill-pointer 5 :element-type 'character)) + (result (nsubstitute-if #\z (is-eql-p #\a) x :count 1))) + result) + "zbacb") + +(deftest nsubstitute-if-string.31 + (let* ((x (make-array '(10) :initial-contents "abacbadeaf" + :fill-pointer 5 :element-type 'character)) + (result (nsubstitute-if #\z (is-eql-p #\a) x :from-end t :count 1))) + result) + "abzcb") + + +;;; Tests on bit-vectors + +(deftest nsubstitute-if-bit-vector.1 + (let* ((orig #*) + (x (copy-seq orig)) + (result (nsubstitute-if 0 (is-eq-p 1) x))) + result) + #*) + +(deftest nsubstitute-if-bit-vector.2 + (let* ((orig #*) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eq-p 0) x))) + result) + #*) + +(deftest nsubstitute-if-bit-vector.3 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if 0 (is-eq-p 1) x))) + result) + #*000000) + +(deftest nsubstitute-if-bit-vector.4 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eq-p 0) x))) + result) + #*111111) + +(deftest nsubstitute-if-bit-vector.5 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eq-p 0) x :start 1))) + result) + #*011111) + +(deftest nsubstitute-if-bit-vector.6 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if 0 (is-eq-p 1) x :start 2 :end nil))) + result) + #*010000) + +(deftest nsubstitute-if-bit-vector.7 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eq-p 0) x :end 4))) + result) + #*111101) + +(deftest nsubstitute-if-bit-vector.8 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if 0 (is-eq-p 1) x :end nil))) + result) + #*000000) + +(deftest nsubstitute-if-bit-vector.9 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if 0 (is-eq-p 1) x :end 3))) + result) + #*000101) + +(deftest nsubstitute-if-bit-vector.10 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if 0 (is-eq-p 1) x :start 2 :end 4))) + result) + #*010001) + +(deftest nsubstitute-if-bit-vector.11 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eq-p 0) x :start 2 :end 4))) + result) + #*011101) + +(deftest nsubstitute-if-bit-vector.12 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eq-p 0) x :count 1))) + result) + #*110101) + +(deftest nsubstitute-if-bit-vector.13 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eq-p 0) x :count 0))) + result) + #*010101) + +(deftest nsubstitute-if-bit-vector.14 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eq-p 0) x :count -1))) + result) + #*010101) + +(deftest nsubstitute-if-bit-vector.15 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eq-p 0) x :count 1 :from-end t))) + result) + #*010111) + +(deftest nsubstitute-if-bit-vector.16 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eq-p 0) x :count 0 :from-end t))) + result) + #*010101) + +(deftest nsubstitute-if-bit-vector.17 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eq-p 0) x :count -1 :from-end t))) + result) + #*010101) + +(deftest nsubstitute-if-bit-vector.18 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eq-p 0) x :count nil))) + result) + #*111111) + +(deftest nsubstitute-if-bit-vector.19 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eq-p 0) x :count nil :from-end t))) + result) + #*111111) + +(deftest nsubstitute-if-bit-vector.20 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #*0000000000) + (x (copy-seq orig)) + (y (nsubstitute-if 1 (is-eq-p 0) x :start i :end j :count c))) + (equalp y (concatenate + 'simple-bit-vector + (make-list i :initial-element 0) + (make-list c :initial-element 1) + (make-list (- 10 (+ i c)) :initial-element 0))))))) + t) + +(deftest nsubstitute-if-bit-vector.21 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #*1111111111) + (x (copy-seq orig)) + (y (nsubstitute-if 0 (is-eq-p 1) x :start i :end j :count c :from-end t))) + (equalp y (concatenate + 'simple-bit-vector + (make-list (- j c) :initial-element 1) + (make-list c :initial-element 0) + (make-list (- 10 j) :initial-element 1))))))) + t) + +;;; More tests + +(deftest nsubstitute-if-list.24 + (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (nsubstitute-if '(a 10) (is-eq-p 'a) x :key #'car))) + result) + ((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) + +(deftest nsubstitute-if-list.25 + (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (nsubstitute-if '(a 10) (is-eq-p 'a) x + :key #'car :start 1 :end 5))) + result) + ((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) + +(deftest nsubstitute-if-vector.24 + (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (nsubstitute-if '(a 10) (is-eq-p 'a) x :key #'car))) + result) + #((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) + +(deftest nsubstitute-if-vector.25 + (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (nsubstitute-if '(a 10) (is-eq-p 'a) x :key #'car :start 1 :end 5))) + result) + #((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) + +(deftest nsubstitute-if-string.24 + (let* ((orig "0102342015") + (x (copy-seq orig)) + (result (nsubstitute-if #\a (is-eq-p #\1) x :key #'nextdigit))) + result) + "a1a2342a15") + +(deftest nsubstitute-if-string.25 + (let* ((orig "0102342015") + (x (copy-seq orig)) + (result (nsubstitute-if #\a (is-eq-p #\1) x :key #'nextdigit :start 1 :end 6))) + result) + "01a2342015") + +(deftest nsubstitute-if-bit-vector.26 + (let* ((orig #*00111001011010110) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eq-p 1) x :key #'1+))) + result) + #*11111111111111111) + +(deftest nsubstitute-if-bit-vector.27 + (let* ((orig #*00111001011010110) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eq-p 1) x :key #'1+ :start 1 :end 10))) + result) + #*01111111111010110) + +(deftest nsubstitute-if-bit-vector.30 + (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) + :fill-pointer 5 :element-type 'bit)) + (result (nsubstitute-if 1 #'zerop x))) + result) + #*11111) + +(deftest nsubstitute-if-bit-vector.31 + (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) + :fill-pointer 5 :element-type 'bit)) + (result (nsubstitute-if 1 #'zerop x :from-end t))) + result) + #*11111) + +(deftest nsubstitute-if-bit-vector.32 + (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) + :fill-pointer 5 :element-type 'bit)) + (result (nsubstitute-if 1 #'zerop x :count 1))) + result) + #*11011) + +(deftest nsubstitute-if-bit-vector.33 + (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) + :fill-pointer 5 :element-type 'bit)) + (result (nsubstitute-if 1 #'zerop x :from-end t :count 1))) + result) + #*01111) + +(deftest nsubstitute-if.order.1 + (let ((i 0) a b c d e f g h) + (values + (nsubstitute-if + (progn (setf a (incf i)) 'a) + (progn (setf b (incf i)) #'null) + (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) + :count (progn (setf d (incf i)) 2) + :start (progn (setf e (incf i)) 0) + :end (progn (setf f (incf i)) 7) + :key (progn (setf g (incf i)) #'identity) + :from-end (setf h (incf i)) + ) + i a b c d e f g h)) + (nil 1 2 a 3 4 a 5) + 8 1 2 3 4 5 6 7 8) + +(deftest nsubstitute-if.order.2 + (let ((i 0) a b c d e f g h) + (values + (nsubstitute-if + (progn (setf a (incf i)) 'a) + (progn (setf b (incf i)) #'null) + (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) + :from-end (setf h (incf i)) + :key (progn (setf g (incf i)) #'identity) + :end (progn (setf f (incf i)) 7) + :start (progn (setf e (incf i)) 0) + :count (progn (setf d (incf i)) 2) + ) + i a b c d e f g h)) + (nil 1 2 a 3 4 a 5) + 8 1 2 3 8 7 6 5 4) + + +;;; Keyword tests + +(deftest nsubstitute-if.allow-other-keys.1 + (nsubstitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t :bad t) + (1 2 a 3 1 a 3)) + +(deftest nsubstitute-if.allow-other-keys.2 + (nsubstitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :bad t :allow-other-keys t) + (1 2 a 3 1 a 3)) + +(deftest nsubstitute-if.allow-other-keys.3 + (nsubstitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t + :allow-other-keys nil :bad t) + (1 2 a 3 1 a 3)) + +(deftest nsubstitute-if.allow-other-keys.4 + (nsubstitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :bad t + :allow-other-keys t :allow-other-keys nil) + (1 2 a 3 1 a 3)) + +(deftest nsubstitute-if.allow-other-keys.5 + (nsubstitute-if 'a #'zerop (list 1 2 0 3 1 0 3) + :allow-other-keys t :key #'1-) + (a 2 0 3 a 0 3)) + +(deftest nsubstitute-if.keywords.6 + (nsubstitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :key #'1- :key #'identity) + (a 2 0 3 a 0 3)) + +(deftest nsubstitute-if.allow-other-keys.7 + (nsubstitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t + :bad t :allow-other-keys nil) + (1 2 a 3 1 a 3)) + +(deftest nsubstitute-if.allow-other-keys.8 + (nsubstitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys nil) + (1 2 a 3 1 a 3)) + +;;; Error cases + +(deftest nsubstitute-if.error.1 + (classify-error (nsubstitute-if)) + program-error) + +(deftest nsubstitute-if.error.2 + (classify-error (nsubstitute-if 'a)) + program-error) + +(deftest nsubstitute-if.error.3 + (classify-error (nsubstitute-if 'a #'null)) + program-error) + +(deftest nsubstitute-if.error.4 + (classify-error (nsubstitute-if 'a #'null nil 'bad t)) + program-error) + +(deftest nsubstitute-if.error.5 + (classify-error (nsubstitute-if 'a #'null nil 'bad t :allow-other-keys nil)) + program-error) + +(deftest nsubstitute-if.error.6 + (classify-error (nsubstitute-if 'a #'null nil :key)) + program-error) + +(deftest nsubstitute-if.error.7 + (classify-error (nsubstitute-if 'a #'null nil 1 2)) + program-error) + +(deftest nsubstitute-if.error.8 + (classify-error (nsubstitute-if 'a #'cons (list 'a 'b 'c))) + program-error) + +(deftest nsubstitute-if.error.9 + (classify-error (nsubstitute-if 'a #'car (list 'a 'b 'c))) + type-error) + +(deftest nsubstitute-if.error.10 + (classify-error (nsubstitute-if 'a #'identity (list 'a 'b 'c) + :key #'car)) + type-error) + +(deftest nsubstitute-if.error.11 + (classify-error (nsubstitute-if 'a #'identity (list 'a 'b 'c) + :key #'cons)) + program-error) + diff --git a/ansi-tests/nsubstitute.lsp b/ansi-tests/nsubstitute.lsp new file mode 100644 index 0000000..ea6a6b0 --- /dev/null +++ b/ansi-tests/nsubstitute.lsp @@ -0,0 +1,957 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Aug 31 16:56:48 2002 +;;;; Contains: Tests for NSUBSTITUTE + +(in-package :cl-test) + +(deftest nsubstitute-list.1 + (nsubstitute 'b 'a nil) + nil) + +(deftest nsubstitute-list.2 + (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x) x) + (b b b c)) + +(deftest nsubstitute-list.3 + (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count nil)) + (b b b c)) + +(deftest nsubstitute-list.4 + (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count 2)) + (b b b c)) + +(deftest nsubstitute-list.5 + (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count 1)) + (b b a c)) + +(deftest nsubstitute-list.6 + (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count 0)) + (a b a c)) + +(deftest nsubstitute-list.7 + (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count -1)) + (a b a c)) + +(deftest nsubstitute-list.8 + (nsubstitute 'b 'a nil :from-end t) + nil) + +(deftest nsubstitute-list.9 + (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :from-end t)) + (b b b c)) + +(deftest nsubstitute-list.10 + (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :from-end t :count nil)) + (b b b c)) + +(deftest nsubstitute-list.11 + (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count 2 :from-end t)) + (b b b c)) + +(deftest nsubstitute-list.12 + (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count 1 :from-end t)) + (a b b c)) + +(deftest nsubstitute-list.13 + (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count 0 :from-end t)) + (a b a c)) + +(deftest nsubstitute-list.14 + (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count -1 :from-end t)) + (a b a c)) + +(deftest nsubstitute-list.15 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute 'x 'a x :start i :end j))) + (equal y (nconc (make-list i :initial-element 'a) + (make-list (- j i) :initial-element 'x) + (make-list (- 10 j) :initial-element 'a)))))) + t) + +(deftest nsubstitute-list.16 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute 'x 'a x :start i :end j :from-end t))) + (equal y (nconc (make-list i :initial-element 'a) + (make-list (- j i) :initial-element 'x) + (make-list (- 10 j) :initial-element 'a)))))) + t) + +(deftest nsubstitute-list.17 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute 'x 'a x :start i :end j :count c))) + (equal y (nconc (make-list i :initial-element 'a) + (make-list c :initial-element 'x) + (make-list (- 10 (+ i c)) :initial-element 'a))))))) + t) + +(deftest nsubstitute-list.18 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute 'x 'a x :start i :end j :count c :from-end t))) + (equal y (nconc (make-list (- j c) :initial-element 'a) + (make-list c :initial-element 'x) + (make-list (- 10 j) :initial-element 'a))))))) + t) + +(deftest nsubstitute-list.19 + (let* ((orig '(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (result (nsubstitute 'x 5 x :test #'(lambda (a b) (<= (abs (- a b)) 2))))) + result) + (1 2 x x x x x 8 9)) + +(deftest nsubstitute-list.20 + (let* ((orig '(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (c -4) + (result (nsubstitute 'x 5 x :test #'(lambda (a b) (incf c 2) (= (+ b c) a))))) + result) + (1 2 x 4 5 6 7 8 9)) + + +(deftest nsubstitute-list.21 + (let* ((orig '(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (c 5) + (result (nsubstitute 'x 9 x :test #'(lambda (a b) (incf c -2) (= (+ b c) a)) + :from-end t))) + result) + (1 2 3 4 5 6 7 x 9)) + +(deftest nsubstitute-list.22 + (let* ((orig '(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (c -4) + (result (nsubstitute 'x 5 x :test-not #'(lambda (a b) (incf c 2) (/= (+ b c) a))))) + result) + (1 2 x 4 5 6 7 8 9)) + + +(deftest nsubstitute-list.23 + (let* ((orig '(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (c 5) + (result (nsubstitute 'x 9 x :test-not #'(lambda (a b) (incf c -2) (/= (+ b c) a)) + :from-end t))) + result) + (1 2 3 4 5 6 7 x 9)) + +;;; Tests on vectors + +(deftest nsubstitute-vector.1 + (let ((x #())) (values (nsubstitute 'b 'a x) x)) + #() #()) + +(deftest nsubstitute-vector.2 + (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x)) + #(b b b c)) + +(deftest nsubstitute-vector.3 + (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count nil) x) + #(b b b c)) + +(deftest nsubstitute-vector.4 + (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count 2)) + #(b b b c)) + +(deftest nsubstitute-vector.5 + (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count 1)) + #(b b a c)) + +(deftest nsubstitute-vector.6 + (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count 0)) + #(a b a c)) + +(deftest nsubstitute-vector.7 + (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count -1)) + #(a b a c)) + +(deftest nsubstitute-vector.8 + (let ((x #())) (nsubstitute 'b 'a x :from-end t)) + #()) + +(deftest nsubstitute-vector.9 + (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :from-end t)) + #(b b b c)) + +(deftest nsubstitute-vector.10 + (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :from-end t :count nil)) + #(b b b c)) + +(deftest nsubstitute-vector.11 + (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count 2 :from-end t)) + #(b b b c)) + +(deftest nsubstitute-vector.12 + (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count 1 :from-end t)) + #(a b b c)) + +(deftest nsubstitute-vector.13 + (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count 0 :from-end t)) + #(a b a c)) + +(deftest nsubstitute-vector.14 + (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count -1 :from-end t)) + #(a b a c)) + +(deftest nsubstitute-vector.15 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute 'x 'a x :start i :end j))) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array (- j i) :initial-element 'x) + (make-array (- 10 j) :initial-element 'a)))))) + t) + +(deftest nsubstitute-vector.16 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute 'x 'a x :start i :end j :from-end t))) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array (- j i) :initial-element 'x) + (make-array (- 10 j) :initial-element 'a)))))) + t) + +(deftest nsubstitute-vector.17 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute 'x 'a x :start i :end j :count c))) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array c :initial-element 'x) + (make-array (- 10 (+ i c)) :initial-element 'a))))))) + t) + +(deftest nsubstitute-vector.18 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute 'x 'a x :start i :end j :count c :from-end t))) + (equalp y (concatenate 'simple-vector + (make-array (- j c) :initial-element 'a) + (make-array c :initial-element 'x) + (make-array (- 10 j) :initial-element 'a))))))) + t) + +(deftest nsubstitute-vector.19 + (let* ((orig #(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (result (nsubstitute 'x 5 x :test #'(lambda (a b) (<= (abs (- a b)) 2))))) + result) + #(1 2 x x x x x 8 9)) + +(deftest nsubstitute-vector.20 + (let* ((orig #(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (c -4) + (result (nsubstitute 'x 5 x :test #'(lambda (a b) (incf c 2) (= (+ b c) a))))) + result) + #(1 2 x 4 5 6 7 8 9)) + + +(deftest nsubstitute-vector.21 + (let* ((orig #(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (c 5) + (result (nsubstitute 'x 9 x :test #'(lambda (a b) (incf c -2) (= (+ b c) a)) + :from-end t))) + result) + #(1 2 3 4 5 6 7 x 9)) + +(deftest nsubstitute-vector.22 + (let* ((orig #(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (c -4) + (result (nsubstitute 'x 5 x :test-not #'(lambda (a b) (incf c 2) (/= (+ b c) a))))) + result) + #(1 2 x 4 5 6 7 8 9)) + +(deftest nsubstitute-vector.23 + (let* ((orig #(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (c 5) + (result (nsubstitute 'x 9 x :test-not #'(lambda (a b) (incf c -2) (/= (+ b c) a)) + :from-end t))) + result) + #(1 2 3 4 5 6 7 x 9)) + +(deftest nsubstitute-vector.28 + (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) + :fill-pointer 5)) + (result (nsubstitute 'z 'a x))) + result) + #(z b z c b)) + +(deftest nsubstitute-vector.29 + (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) + :fill-pointer 5)) + (result (nsubstitute 'z 'a x :from-end t))) + result) + #(z b z c b)) + +(deftest nsubstitute-vector.30 + (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) + :fill-pointer 5)) + (result (nsubstitute 'z 'a x :count 1))) + result) + #(z b a c b)) + +(deftest nsubstitute-vector.31 + (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) + :fill-pointer 5)) + (result (nsubstitute 'z 'a x :from-end t :count 1))) + result) + #(a b z c b)) + +;;; Tests on strings + +(deftest nsubstitute-string.1 + (let ((x "")) (nsubstitute #\b #\a x)) + "") + +(deftest nsubstitute-string.2 + (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x)) + "bbbc") + +(deftest nsubstitute-string.3 + (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count nil)) + "bbbc") + +(deftest nsubstitute-string.4 + (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count 2)) + "bbbc") + +(deftest nsubstitute-string.5 + (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count 1)) + "bbac") + +(deftest nsubstitute-string.6 + (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count 0)) + "abac") + +(deftest nsubstitute-string.7 + (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count -1)) + "abac") + +(deftest nsubstitute-string.8 + (let ((x "")) (nsubstitute #\b #\a x :from-end t)) + "") + +(deftest nsubstitute-string.9 + (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :from-end t)) + "bbbc") + +(deftest nsubstitute-string.10 + (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :from-end t :count nil)) + "bbbc") + +(deftest nsubstitute-string.11 + (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count 2 :from-end t)) + "bbbc") + +(deftest nsubstitute-string.12 + (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count 1 :from-end t)) + "abbc") + +(deftest nsubstitute-string.13 + (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count 0 :from-end t)) + "abac") + +(deftest nsubstitute-string.14 + (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count -1 :from-end t)) + "abac") + +(deftest nsubstitute-string.15 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (nsubstitute #\x #\a x :start i :end j))) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array (- j i) :initial-element #\x) + (make-array (- 10 j) :initial-element #\a)))))) + t) + +(deftest nsubstitute-string.16 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (nsubstitute #\x #\a x :start i :end j :from-end t))) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array (- j i) :initial-element #\x) + (make-array (- 10 j) :initial-element #\a)))))) + t) + +(deftest nsubstitute-string.17 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (nsubstitute #\x #\a x :start i :end j :count c))) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array c :initial-element #\x) + (make-array (- 10 (+ i c)) :initial-element #\a))))))) + t) + +(deftest nsubstitute-string.18 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (nsubstitute #\x #\a x :start i :end j :count c :from-end t))) + (equalp y (concatenate 'simple-string + (make-array (- j c) :initial-element #\a) + (make-array c :initial-element #\x) + (make-array (- 10 j) :initial-element #\a))))))) + t) + +(deftest nsubstitute-string.19 + (let* ((orig "123456789") + (x (copy-seq orig)) + (result (nsubstitute #\x #\5 x :test #'(lambda (a b) + (setq a (read-from-string (string a))) + (setq b (read-from-string (string b))) + (<= (abs (- a b)) 2))))) + result) + "12xxxxx89") + +(deftest nsubstitute-string.20 + (let* ((orig "123456789") + (x (copy-seq orig)) + (c -4) + (result (nsubstitute #\x #\5 x :test #'(lambda (a b) + (setq a (read-from-string (string a))) + (setq b (read-from-string (string b))) + (incf c 2) (= (+ b c) a))))) + result) + "12x456789") + + +(deftest nsubstitute-string.21 + (let* ((orig "123456789") + (x (copy-seq orig)) + (c 5) + (result (nsubstitute #\x #\9 x :test #'(lambda (a b) + (setq a (read-from-string (string a))) + (setq b (read-from-string (string b))) + (incf c -2) (= (+ b c) a)) + :from-end t))) + result) + "1234567x9") + +(deftest nsubstitute-string.22 + (let* ((orig "123456789") + (x (copy-seq orig)) + (c -4) + (result (nsubstitute #\x #\5 x :test-not #'(lambda (a b) + (setq a (read-from-string (string a))) + (setq b (read-from-string (string b))) + (incf c 2) (/= (+ b c) a))))) + result) + "12x456789") + + +(deftest nsubstitute-string.23 + (let* ((orig "123456789") + (x (copy-seq orig)) + (c 5) + (result (nsubstitute #\x #\9 x :test-not #'(lambda (a b) + (setq a (read-from-string (string a))) + (setq b (read-from-string (string b))) + (incf c -2) (/= (+ b c) a)) + :from-end t))) + result) + "1234567x9") + +(deftest nsubstitute-string.28 + (let* ((x (make-array '(10) :initial-contents "abacbadeaf" + :fill-pointer 5 :element-type 'character)) + (result (nsubstitute #\z #\a x))) + result) + "zbzcb") + +(deftest nsubstitute-string.29 + (let* ((x (make-array '(10) :initial-contents "abacbadeaf" + :fill-pointer 5 :element-type 'character)) + (result (nsubstitute #\z #\a x :from-end t))) + result) + "zbzcb") + +(deftest nsubstitute-string.30 + (let* ((x (make-array '(10) :initial-contents "abacbadeaf" + :fill-pointer 5 :element-type 'character)) + (result (nsubstitute #\z #\a x :count 1))) + result) + "zbacb") + +(deftest nsubstitute-string.31 + (let* ((x (make-array '(10) :initial-contents "abacbadeaf" + :fill-pointer 5 :element-type 'character)) + (result (nsubstitute #\z #\a x :from-end t :count 1))) + result) + "abzcb") + + +;;; Tests on bit-vectors + +(deftest nsubstitute-bit-vector.1 + (let* ((orig #*) + (x (copy-seq orig)) + (result (nsubstitute 0 1 x))) + result) + #*) + +(deftest nsubstitute-bit-vector.2 + (let* ((orig #*) + (x (copy-seq orig)) + (result (nsubstitute 1 0 x))) + result) + #*) + +(deftest nsubstitute-bit-vector.3 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute 0 1 x))) + result) + #*000000) + +(deftest nsubstitute-bit-vector.4 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute 1 0 x))) + result) + #*111111) + +(deftest nsubstitute-bit-vector.5 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute 1 0 x :start 1))) + result) + #*011111) + +(deftest nsubstitute-bit-vector.6 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute 0 1 x :start 2 :end nil))) + result) + #*010000) + +(deftest nsubstitute-bit-vector.7 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute 1 0 x :end 4))) + result) + #*111101) + +(deftest nsubstitute-bit-vector.8 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute 0 1 x :end nil))) + result) + #*000000) + +(deftest nsubstitute-bit-vector.9 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute 0 1 x :end 3))) + result) + #*000101) + +(deftest nsubstitute-bit-vector.10 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute 0 1 x :start 2 :end 4))) + result) + #*010001) + +(deftest nsubstitute-bit-vector.11 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute 1 0 x :start 2 :end 4))) + result) + #*011101) + +(deftest nsubstitute-bit-vector.12 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute 1 0 x :count 1))) + result) + #*110101) + +(deftest nsubstitute-bit-vector.13 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute 1 0 x :count 0))) + result) + #*010101) + +(deftest nsubstitute-bit-vector.14 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute 1 0 x :count -1))) + result) + #*010101) + +(deftest nsubstitute-bit-vector.15 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute 1 0 x :count 1 :from-end t))) + result) + #*010111) + +(deftest nsubstitute-bit-vector.16 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute 1 0 x :count 0 :from-end t))) + result) + #*010101) + +(deftest nsubstitute-bit-vector.17 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute 1 0 x :count -1 :from-end t))) + result) + #*010101) + +(deftest nsubstitute-bit-vector.18 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute 1 0 x :count nil))) + result) + #*111111) + +(deftest nsubstitute-bit-vector.19 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (nsubstitute 1 0 x :count nil :from-end t))) + result) + #*111111) + +(deftest nsubstitute-bit-vector.20 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #*0000000000) + (x (copy-seq orig)) + (y (nsubstitute 1 0 x :start i :end j :count c))) + (equalp y (concatenate + 'simple-bit-vector + (make-list i :initial-element 0) + (make-list c :initial-element 1) + (make-list (- 10 (+ i c)) :initial-element 0))))))) + t) + +(deftest nsubstitute-bit-vector.21 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #*1111111111) + (x (copy-seq orig)) + (y (nsubstitute 0 1 x :start i :end j :count c :from-end t))) + (equalp y (concatenate + 'simple-bit-vector + (make-list (- j c) :initial-element 1) + (make-list c :initial-element 0) + (make-list (- 10 j) :initial-element 1))))))) + t) + +(deftest nsubstitute-bit-vector.22 + (let* ((orig #*0101010101) + (x (copy-seq orig)) + (c 0) + (result (nsubstitute 1 0 x :test #'(lambda (a b) (incf c) (and (<= 2 c 5) (= a b)))))) + result) + #*0111110101) + +(deftest nsubstitute-bit-vector.23 + (let* ((orig #*0101010101) + (x (copy-seq orig)) + (c 0) + (result (nsubstitute 1 0 x :test-not #'(lambda (a b) (incf c) + (not (and (<= 2 c 5) (= a b))))))) + result) + #*0111110101) + +(deftest nsubstitute-bit-vector.24 + (let* ((orig #*0101010101) + (x (copy-seq orig)) + (c 0) + (result (nsubstitute 1 0 x :test #'(lambda (a b) (incf c) (and (<= 2 c 5) (= a b))) + :from-end t))) + result) + #*0101011111) + +(deftest nsubstitute-bit-vector.25 + (let* ((orig #*0101010101) + (x (copy-seq orig)) + (c 0) + (result (nsubstitute 1 0 x :test-not #'(lambda (a b) (incf c) + (not (and (<= 2 c 5) (= a b)))) + :from-end t))) + result) + #*0101011111) + +;;;; additional tests + +(deftest nsubstitute-list.24 + (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (nsubstitute '(a 10) 'a x :key #'car))) + result) + ((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) + +(deftest nsubstitute-list.25 + (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (nsubstitute '(a 10) 'a x :key #'car :start 1 :end 5))) + result) + ((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) + +(deftest nsubstitute-list.26 + (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (nsubstitute '(a 10) 'a x :key #'car :test (complement #'eql)))) + result) + ((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) + +(deftest nsubstitute-list.27 + (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (nsubstitute '(a 10) 'a x :key #'car :test-not #'eql))) + result) + ((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) + +(deftest nsubstitute-vector.24 + (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (nsubstitute '(a 10) 'a x :key #'car))) + result) + #((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) + +(deftest nsubstitute-vector.25 + (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (nsubstitute '(a 10) 'a x :key #'car :start 1 :end 5))) + result) + #((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) + +(deftest nsubstitute-vector.26 + (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (nsubstitute '(a 10) 'a x :key #'car :test (complement #'eql)))) + result) + #((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) + +(deftest nsubstitute-vector.27 + (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (nsubstitute '(a 10) 'a x :key #'car :test-not #'eql))) + result) + #((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) + +(deftest nsubstitute-string.24 + (let* ((orig "0102342015") + (x (copy-seq orig)) + (result (nsubstitute #\a #\1 x :key #'nextdigit))) + result) + "a1a2342a15") + +(deftest nsubstitute-string.25 + (let* ((orig "0102342015") + (x (copy-seq orig)) + (result (nsubstitute #\a #\1 x :key #'nextdigit :start 1 :end 6))) + result) + "01a2342015") + +(deftest nsubstitute-string.26 + (let* ((orig "0102342015") + (x (copy-seq orig)) + (result (nsubstitute #\a #\1 x :key #'nextdigit :test (complement #'eql)))) + result) + "0a0aaaa0aa") + +(deftest nsubstitute-string.27 + (let* ((orig "0102342015") + (x (copy-seq orig)) + (result (nsubstitute #\a #\1 x :key #'nextdigit :test-not #'eql))) + result) + "0a0aaaa0aa") + +(deftest nsubstitute-bit-vector.30 + (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) + :fill-pointer 5 :element-type 'bit)) + (result (nsubstitute 1 0 x))) + result) + #*11111) + +(deftest nsubstitute-bit-vector.31 + (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) + :fill-pointer 5 :element-type 'bit)) + (result (nsubstitute 1 0 x :from-end t))) + result) + #*11111) + +(deftest nsubstitute-bit-vector.32 + (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) + :fill-pointer 5 :element-type 'bit)) + (result (nsubstitute 1 0 x :count 1))) + result) + #*11011) + +(deftest nsubstitute-bit-vector.33 + (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) + :fill-pointer 5 :element-type 'bit)) + (result (nsubstitute 1 0 x :from-end t :count 1))) + result) + #*01111) + +(deftest nsubstitute.order.1 + (let ((i 0) a b c d e f g h) + (values + (nsubstitute + (progn (setf a (incf i)) 'a) + (progn (setf b (incf i)) nil) + (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) + :count (progn (setf d (incf i)) 2) + :start (progn (setf e (incf i)) 0) + :end (progn (setf f (incf i)) 7) + :key (progn (setf g (incf i)) #'identity) + :from-end (setf h (incf i)) + ) + i a b c d e f g h)) + (nil 1 2 a 3 4 a 5) + 8 1 2 3 4 5 6 7 8) + +(deftest nsubstitute.order.2 + (let ((i 0) a b c d e f g h) + (values + (nsubstitute + (progn (setf a (incf i)) 'a) + (progn (setf b (incf i)) nil) + (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) + :from-end (setf h (incf i)) + :key (progn (setf g (incf i)) #'identity) + :end (progn (setf f (incf i)) 7) + :start (progn (setf e (incf i)) 0) + :count (progn (setf d (incf i)) 2) + ) + i a b c d e f g h)) + (nil 1 2 a 3 4 a 5) + 8 1 2 3 8 7 6 5 4) + +;;; Keyword tests + +(deftest nsubstitute.allow-other-keys.1 + (nsubstitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys t :bad t) + (1 2 a 3 1 a 3)) + +(deftest nsubstitute.allow-other-keys.2 + (nsubstitute 'a 0 (list 1 2 0 3 1 0 3) :bad t :allow-other-keys t) + (1 2 a 3 1 a 3)) + +(deftest nsubstitute.allow-other-keys.3 + (nsubstitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys t + :allow-other-keys nil :bad t) + (1 2 a 3 1 a 3)) + +(deftest nsubstitute.allow-other-keys.4 + (nsubstitute 'a 0 (list 1 2 0 3 1 0 3) :bad t + :allow-other-keys t :allow-other-keys nil) + (1 2 a 3 1 a 3)) + +(deftest nsubstitute.allow-other-keys.5 + (nsubstitute 'a 0 (list 1 2 0 3 1 0 3) + :allow-other-keys t :key #'1-) + (a 2 0 3 a 0 3)) + +(deftest nsubstitute.keywords.6 + (nsubstitute 'a 0 (list 1 2 0 3 1 0 3) :key #'1- :key #'identity) + (a 2 0 3 a 0 3)) + +(deftest nsubstitute.allow-other-keys.7 + (nsubstitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys t + :bad t :allow-other-keys nil) + (1 2 a 3 1 a 3)) + +(deftest nsubstitute.allow-other-keys.8 + (nsubstitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys nil) + (1 2 a 3 1 a 3)) + + +;;; Error cases + +(deftest nsubstitute.error.1 + (classify-error (nsubstitute)) + program-error) + +(deftest nsubstitute.error.2 + (classify-error (nsubstitute 'a)) + program-error) + +(deftest nsubstitute.error.3 + (classify-error (nsubstitute 'a 'b)) + program-error) + +(deftest nsubstitute.error.4 + (classify-error (nsubstitute 'a 'b nil 'bad t)) + program-error) + +(deftest nsubstitute.error.5 + (classify-error (nsubstitute 'a 'b nil 'bad t :allow-other-keys nil)) + program-error) + +(deftest nsubstitute.error.6 + (classify-error (nsubstitute 'a 'b nil :key)) + program-error) + +(deftest nsubstitute.error.7 + (classify-error (nsubstitute 'a 'b nil 1 2)) + program-error) + +(deftest nsubstitute.error.8 + (classify-error (nsubstitute 'a 'b (list 'a 'b 'c) :test #'identity)) + program-error) + +(deftest nsubstitute.error.9 + (classify-error (nsubstitute 'a 'b (list 'a 'b 'c) :test-not #'identity)) + program-error) + +(deftest nsubstitute.error.10 + (classify-error (nsubstitute 'a 'b (list 'a 'b 'c) :key #'cons)) + program-error) + +(deftest nsubstitute.error.11 + (classify-error (nsubstitute 'a 'b (list 'a 'b 'c) :key #'car)) + type-error) + diff --git a/ansi-tests/nth-value.lsp b/ansi-tests/nth-value.lsp new file mode 100644 index 0000000..1d825ad --- /dev/null +++ b/ansi-tests/nth-value.lsp @@ -0,0 +1,36 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Oct 19 08:24:14 2002 +;;;; Contains: Tests of NTH-VALUE + +(in-package :cl-test) + +(deftest nth-value.1 + (nth-value 0 'a) + a) + +(deftest nth-value.2 + (nth-value 1 'a) + nil) + +(deftest nth-value.3 + (nth-value 0 (values)) + nil) + +(deftest nth-value.4 + (loop for i from 0 to 19 + collect (nth-value i (values 'a 'b 'c 'd 'e 'f 'g 'h 'i 'j 'k + 'l 'm 'n 'o 'p 'q 'r 's))) + (a b c d e f g h i j k l m n o p q r s nil)) + +(deftest nth-value.5 + (nth-value 100 'a) + nil) + +(deftest nth-value.order.1 + (let ((i 0) x y) + (values + (nth-value (progn (setf x (incf i)) 3) + (progn (setf y (incf i)) (values 'a 'b 'c 'd 'e 'f 'g))) + i x y)) + d 2 1 2) diff --git a/ansi-tests/or.lsp b/ansi-tests/or.lsp new file mode 100644 index 0000000..4b7d746 --- /dev/null +++ b/ansi-tests/or.lsp @@ -0,0 +1,48 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Oct 18 07:29:27 2002 +;;;; Contains: Tests of OR + +(in-package :cl-test) + +(deftest or.1 + (or) + nil) + +(deftest or.2 + (or nil) + nil) + +(deftest or.3 + (or 'a) + a) + +(deftest or.4 + (or (values 'a 'b 'c)) + a b c) + +(deftest or.5 (or (values))) + +(deftest or.6 + (or (values t nil) 'a) + t) + +(deftest or.7 + (or nil (values 'a 'b 'c)) + a b c) + +(deftest or.8 + (let ((x 0)) + (values (or t (incf x)) + x)) + t 0) + +(deftest or.9 + (or (values nil 1 2) (values 1 nil 2)) + 1 nil 2) + + + + + + diff --git a/ansi-tests/packages-00.lsp b/ansi-tests/packages-00.lsp new file mode 100644 index 0000000..0f951e3 --- /dev/null +++ b/ansi-tests/packages-00.lsp @@ -0,0 +1,39 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 25 08:07:31 1998 +;;;; Contains: Package test code (common code) + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +(defpackage "A" + (:use) + (:nicknames "Q") + (:export "FOO")) + +(defpackage "B" + (:use "A") + (:export "BAR")) + +(defpackage "DS1" + (:use) + (:intern "C" "D") + (:export "A" "B")) + +(defpackage "DS2" + (:use) + (:intern "E" "F") + (:export "G" "H" "A")) + +(defpackage "DS3" + (:shadow "B") + (:shadowing-import-from "DS1" "A") + (:use "DS1" "DS2") + (:export "A" "B" "G" "I" "J" "K") + (:intern "L" "M")) + +(defpackage "DS4" + (:shadowing-import-from "DS1" "B") + (:use "DS1" "DS3") + (:intern "X" "Y" "Z") + (:import-from "DS2" "F")) diff --git a/ansi-tests/packages-01.lsp b/ansi-tests/packages-01.lsp new file mode 100644 index 0000000..f811c79 --- /dev/null +++ b/ansi-tests/packages-01.lsp @@ -0,0 +1,92 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 25 07:49:34 1998 +;;;; Contains: Package test code, part 01 + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +;; Test find-symbol, with the various combinations of +;; package designators + +(deftest find-symbol.1 + (find-symbol "aBmAchb1c") + nil nil) + +(deftest find-symbol.2 + (find-symbol "aBmAchb1c" "CL") + nil nil) + +(deftest find-symbol.3 + (find-symbol "aBmAchb1c" "COMMON-LISP") + nil nil) + +(deftest find-symbol.4 + (find-symbol "aBmAchb1c" "KEYWORD") + nil nil) + +(deftest find-symbol.5 + (find-symbol "aBmAchb1c" "COMMON-LISP-USER") + nil nil) + +(deftest find-symbol.6 + (find-symbol (string '#:car) "CL") + car :external) + +(deftest find-symbol.7 + (find-symbol (string '#:car) "COMMON-LISP") + car :external) + +(deftest find-symbol.8 + (values (find-symbol (string '#:car) "COMMON-LISP-USER")) + car #| :inherited |# ) + +(deftest find-symbol.9 + (find-symbol (string '#:car) "CL-TEST") + car :inherited) + +(deftest find-symbol.10 + (find-symbol (string '#:test) "KEYWORD") + :test :external) + +(deftest find-symbol.11 + (find-symbol (string '#:find-symbol.11) "CL-TEST") + find-symbol.11 :internal) + +(deftest find-symbol.12 + (find-symbol "FOO" #\A) + A::FOO :external) + +(deftest find-symbol.13 + (progn + (intern "X" (find-package "A")) + (find-symbol "X" #\A)) + A::X :internal) + +(deftest find-symbol.14 + (find-symbol "FOO" #\B) + A::FOO :inherited) + +(deftest find-symbol.15 + (find-symbol "FOO" "B") + A::FOO :inherited) + +(deftest find-symbol.16 + (find-symbol "FOO" (find-package "B")) + A::FOO :inherited) + +(deftest find-symbol.order.1 + (let ((i 0) x y) + (values + (find-symbol (progn (setf x (incf i)) (string '#:car)) + (progn (setf y (incf i)) "COMMON-LISP")) + i x y)) + car 2 1 2) + +(deftest find-symbol.error.1 + (classify-error (find-symbol)) + program-error) + +(deftest find-symbol.error.2 + (classify-error (find-symbol "CAR" "CL" nil)) + program-error) \ No newline at end of file diff --git a/ansi-tests/packages-02.lsp b/ansi-tests/packages-02.lsp new file mode 100644 index 0000000..3139da7 --- /dev/null +++ b/ansi-tests/packages-02.lsp @@ -0,0 +1,91 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 25 07:50:39 1998 +;;;; Contains: Package test code, aprt 02 + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; find-package + +(deftest find-package.1 + (let ((p (find-package "CL")) + (p2 (find-package "COMMON-LISP"))) + (and p p2 (eqt p p2))) + t) + +(deftest find-package.2 + (let ((p (find-package "CL-USER")) + (p2 (find-package "COMMON-LISP-USER"))) + (and p p2 (eqt p p2))) + t) + +(deftest find-package.3 + (let ((p (find-package "KEYWORD"))) + (and p (eqt p (symbol-package :test)))) + t) + +(deftest find-package.4 + (let ((p (ignore-errors (find-package "A")))) + (if (packagep p) + t + p)) + t) + +(deftest find-package.5 + (let ((p (ignore-errors (find-package #\A)))) + (if (packagep p) + t + p)) + t) + +(deftest find-package.6 + (let ((p (ignore-errors (find-package "B")))) + (if (packagep p) + t + p)) + t) + +(deftest find-package.7 + (let ((p (ignore-errors (find-package #\B)))) + (if (packagep p) + t + p)) + t) + +(deftest find-package.8 + (let ((p (ignore-errors (find-package "Q"))) + (p2 (ignore-errors (find-package "A")))) + (and (packagep p) + (packagep p2) + (eqt p p2))) + t) + +(deftest find-package.9 + (let ((p (ignore-errors (find-package "A"))) + (p2 (ignore-errors (find-package "B")))) + (eqt p p2)) + nil) + +(deftest find-package.10 + (let ((p (ignore-errors (find-package #\Q))) + (p2 (ignore-errors (find-package "Q")))) + (and (packagep p) + (eqt p p2))) + t) + +(deftest find-package.11 + (let* ((cl (find-package "CL")) + (cl2 (find-package cl))) + (and (packagep cl) + (eqt cl cl2))) + t) + +(deftest find-package.error.1 + (classify-error (find-package)) + program-error) + +(deftest find-package.error.2 + (classify-error (find-package "CL" nil)) + program-error) diff --git a/ansi-tests/packages-03.lsp b/ansi-tests/packages-03.lsp new file mode 100644 index 0000000..dc8dfb1 --- /dev/null +++ b/ansi-tests/packages-03.lsp @@ -0,0 +1,220 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 25 07:51:26 1998 +;;;; Contains: Package test code, part 03 + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; list-all-packages + +;; list-all-packages returns a list +(deftest list-all-packages.1 + (numberp (ignore-errors (list-length (list-all-packages)))) + t) + +;; The required packages are present +(deftest list-all-packages.2 + (subsetp + (list (find-package "CL") + (find-package "CL-USER") + (find-package "KEYWORD") + (find-package "A") + (find-package "RT") + (find-package "CL-TEST") + (find-package "B")) + (list-all-packages)) + t) + +;; The list returned has only packages in it +(deftest list-all-packages.3 + (notnot-mv (every #'packagep (list-all-packages))) + t) + +;; It returns a list of the same packages each time it is called +(deftest list-all-packages.4 + (let ((p1 (list-all-packages)) + (p2 (list-all-packages))) + (and (subsetp p1 p2) + (subsetp p2 p1))) + t) + +(deftest list-all-packages.error.1 + (classify-error (list-all-packages nil)) + program-error) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; package-name + +(deftest package-name.1 + (ignore-errors (package-name "A")) + "A") + +(deftest package-name.2 + (ignore-errors (package-name #\A)) + "A") + +(deftest package-name.3 + (ignore-errors (package-name "Q")) + "A") + +(deftest package-name.4 + (ignore-errors (package-name #\Q)) + "A") + +(deftest package-name.5 + (notnot-mv (member (classify-error (package-name "NOT-THERE")) + '(type-error package-error))) + t) + +(deftest package-name.6 + (notnot-mv (member (classify-error (package-name #\*)) + '(type-error package-error))) + t) + +(deftest package-name.6a + (notnot-mv (member (classify-error (locally (package-name #\*) t)) + '(type-error package-error))) + t) + +(deftest package-name.7 + (package-name "CL") + #.(string '#:common-lisp)) + +(deftest package-name.8 + (package-name "COMMON-LISP") + #.(string '#:common-lisp)) + +(deftest package-name.9 + (package-name "COMMON-LISP-USER") + #.(string '#:common-lisp-user)) + +(deftest package-name.10 + (package-name "CL-USER") + #.(string '#:common-lisp-user)) + +(deftest package-name.11 + (package-name "KEYWORD") + #.(string '#:keyword)) + +(deftest package-name.12 + (package-name (find-package "CL")) + #.(string '#:common-lisp)) + +(deftest package-name.13 + (let* ((p (make-package "TEMP1")) + (pname1 (package-name p))) + (rename-package "TEMP1" "TEMP2") + (let ((pname2 (package-name p))) + (safely-delete-package p) + (list pname1 pname2 (package-name p)))) + ("TEMP1" "TEMP2" nil)) + +;; (find-package (package-name p)) == p for any package p +(deftest package-name.14 + (loop + for p in (list-all-packages) count + (not + (let ((name (package-name p))) + (and (stringp name) + (eqt (find-package name) p))))) + 0) + +;; package-name applied to a package's name +;; should return an equal string +(deftest package-name.15 + (loop + for p in (list-all-packages) count + (not (equal (package-name p) + (ignore-errors (package-name (package-name p)))))) + 0) + +(deftest package-name.error.1 + (classify-error (package-name)) + program-error) + +(deftest package-name.error.2 + (classify-error (package-name "CL" nil)) + program-error) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; package-nicknames + +(deftest package-nicknames.1 + (ignore-errors (package-nicknames "A")) + ("Q")) + +(deftest package-nicknames.2 + (ignore-errors (package-nicknames #\A)) + ("Q")) + +(deftest package-nicknames.3 + (ignore-errors (package-nicknames ':|A|)) + ("Q")) + +(deftest package-nicknames.4 + (ignore-errors (package-nicknames "B")) + nil) + +(deftest package-nicknames.5 + (ignore-errors (package-nicknames #\B)) + nil) + +(deftest package-nicknames.6 + (ignore-errors (package-nicknames '#:|B|)) + nil) + +(deftest package-nicknames.7 + (ignore-errors + (subsetp '(#.(string '#:cl)) + (package-nicknames "COMMON-LISP") + :test #'string=)) + t) + +(deftest package-nicknames.8 + (ignore-errors + (notnot + (subsetp '(#.(string '#:cl-user)) + (package-nicknames "COMMON-LISP-USER") + :test #'string=))) + t) + +(deftest package-nicknames.9 + (classify-error (package-nicknames 10)) + type-error) + +(deftest package-nicknames.9a + (classify-error (locally (package-nicknames 10) t)) + type-error) + +(deftest package-nicknames.10 + (ignore-errors (package-nicknames (find-package "A"))) + ("Q")) + +(deftest package-nicknames.11 + (notnot-mv (member (classify-error (package-nicknames "NOT-A-PACKAGE-NAME")) + '(type-error package-error))) + t) + + +;; (find-package n) == p for each n in (package-nicknames p), +;; for any package p +(deftest package-nicknames.12 + (loop + for p in (list-all-packages) sum + (loop + for nk in (package-nicknames p) count + (not + (and (stringp nk) + (eqt p (find-package nk)))))) + 0) + +(deftest package-nicknames.error.1 + (classify-error (package-nicknames)) + program-error) + +(deftest package-nicknames.error.2 + (classify-error (package-nicknames "CL" nil)) + program-error) diff --git a/ansi-tests/packages-04.lsp b/ansi-tests/packages-04.lsp new file mode 100644 index 0000000..f9dabec --- /dev/null +++ b/ansi-tests/packages-04.lsp @@ -0,0 +1,57 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 25 07:59:10 1998 +;;;; Contains: Package test code, part 04 + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; intern + +(deftest intern.1 + (progn + (safely-delete-package "TEMP1") + (let ((p (make-package "TEMP1")) + (i 0) x y) + (multiple-value-bind* (sym1 status1) + (find-symbol "FOO" p) + (intern (progn (setf x (incf i)) "FOO") + (progn (setf y (incf i)) p)) + (multiple-value-bind* (sym2 status2) + (find-symbol "FOO" p) + (and (eql i 2) + (eql x 1) + (eql y 2) + (null sym1) + (null status1) + (string= (symbol-name sym2) "FOO") + (eqt (symbol-package sym2) p) + (eqt status2 :internal) + (progn (delete-package p) t)))))) + t) + +(deftest intern.2 + (progn + (safely-delete-package "TEMP1") + (let ((p (make-package "TEMP1"))) + (multiple-value-bind* (sym1 status1) + (find-symbol "FOO" "TEMP1") + (intern "FOO" "TEMP1") + (multiple-value-bind* (sym2 status2) + (find-symbol "FOO" p) + (and (null sym1) + (null status1) + (string= (symbol-name sym2) "FOO") + (eqt (symbol-package sym2) p) + (eqt status2 :internal) + (progn (delete-package p) t)))))) + t) + +(deftest intern.error.1 + (classify-error (intern)) + program-error) + +(deftest intern.error.2 + (classify-error (intern "X" "CL" nil)) + program-error) diff --git a/ansi-tests/packages-05.lsp b/ansi-tests/packages-05.lsp new file mode 100644 index 0000000..6085e34 --- /dev/null +++ b/ansi-tests/packages-05.lsp @@ -0,0 +1,110 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 25 07:59:45 1998 +;;;; Contains: Package test code, part 05 + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; export + +(deftest export.1 + (let ((return-value nil)) + (safely-delete-package "TEST1") + (let ((p (make-package "TEST1"))) + (let ((sym (intern "FOO" p)) + (i 0) x y) + (setf return-value (export (progn (setf x (incf i)) sym) + (progn (setf y (incf i)) p))) + (multiple-value-bind* (sym2 status) + (find-symbol "FOO" p) + (prog1 + (and sym2 + (eql i 2) + (eql x 1) + (eql y 2) + (eqt (symbol-package sym2) p) + (string= (symbol-name sym2) "FOO") + (eqt sym sym2) + (eqt status :external)) + (delete-package p))))) + return-value) + t) + +(deftest export.2 + (progn + (safely-delete-package "TEST1") + (let ((p (make-package "TEST1"))) + (let ((sym (intern "FOO" p))) + (export (list sym) p) + (multiple-value-bind* (sym2 status) + (find-symbol "FOO" p) + (prog1 + (and sym2 + (eqt (symbol-package sym2) p) + (string= (symbol-name sym2) "FOO") + (eqt sym sym2) + (eqt status :external)) + (delete-package p)))))) + t) + +(deftest export.3 + (handler-case + (progn + (safely-delete-package "F") + (make-package "F") + (let ((sym (intern "FOO" "F"))) + (export sym #\F) + (delete-package "F") + t)) + (error (c) (safely-delete-package "F") c)) + t) + +;; +;; When a symbol not in a package is exported, export +;; should signal a correctable package-error asking the +;; user whether the symbol should be imported. +;; +(deftest export.4 + (handler-case + (export 'b::bar "A") + (package-error () 'package-error) + (error (c) c)) + package-error) + +;; +;; Test that it catches an attempt to export a symbol +;; from a package that is used by another package that +;; is exporting a symbol with the same name. +;; +(deftest export.5 + (progn + (safely-delete-package "TEST1") + (safely-delete-package "TEST2") + (make-package "TEST1") + (make-package "TEST2" :use '("TEST1")) + (export (intern "X" "TEST2") "TEST2") + (prog1 + (handler-case + (let ((sym (intern "X" "TEST1"))) + (handler-case + (export sym "TEST1") + (error (c) + (format t "Caught error in EXPORT.5: ~A~%" c) + 'caught))) + (error (c) c)) + (delete-package "TEST2") + (delete-package "TEST1"))) + caught) + +(deftest export.error.1 + (classify-error (export)) + program-error) + +(deftest export.error.2 + (classify-error (export 'X "CL-TEST" NIL)) + program-error) + + + diff --git a/ansi-tests/packages-06.lsp b/ansi-tests/packages-06.lsp new file mode 100644 index 0000000..a1580c6 --- /dev/null +++ b/ansi-tests/packages-06.lsp @@ -0,0 +1,176 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 25 08:00:28 1998 +;;;; Contains: Package test code, part 06 + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; rename-package + +(deftest rename-package.1 + (block nil + (safely-delete-package "TEST1") + (safely-delete-package "TEST2") + (let ((p (make-package "TEST1")) + (i 0) x y) + (unless (packagep p) (return nil)) + (let ((p2 (rename-package (progn (setf x (incf i)) "TEST1") + (progn (setf y (incf i)) "TEST2")))) + (unless (packagep p2) + (safely-delete-package p) + (return p2)) + (unless (and (eqt p p2) + (eql i 2) + (eql x 1) + (eql y 2) + (equal (package-name p2) "TEST2")) + (safely-delete-package p) + (safely-delete-package p2) + (return nil)) + (safely-delete-package p2) + t))) + t) + +(deftest rename-package.2 + (block nil + (safely-delete-package "TEST1") + (safely-delete-package "TEST2") + (safely-delete-package "TEST3") + (safely-delete-package "TEST4") + (safely-delete-package "TEST5") + (let ((p (make-package "TEST1")) + (nicknames (copy-list '("TEST3" "TEST4" "TEST5")))) + (unless (packagep p) (return nil)) + (let ((p2 (rename-package "TEST1" "TEST2" nicknames))) + (unless (packagep p2) + (safely-delete-package p) + (return p2)) + (unless (and (eqt p p2) + (equal (package-name p2) "TEST2") + (null (set-exclusive-or nicknames + (package-nicknames p2) + :test #'equal))) + (safely-delete-package p) + (safely-delete-package p2) + (return nil)) + (safely-delete-package p2) + t))) + t) + +(deftest rename-package.3 + (block nil + (safely-delete-package "TEST1") + (safely-delete-package "TEST2") + (let ((p (make-package "TEST1")) + (nicknames (copy-list '(#\M #\N)))) + (unless (packagep p) (return nil)) + (let ((p2 (ignore-errors (rename-package "TEST1" "TEST2" nicknames)))) + (unless (packagep p2) + (safely-delete-package p) + (return p2)) + (unless (and (eqt p p2) + (equal (package-name p2) "TEST2") + (equal + (sort (copy-list (package-nicknames p2)) + #'string<) + (sort (mapcar #'(lambda (c) + (make-string 1 :initial-element c)) + nicknames) + #'string<))) + (safely-delete-package p) + (safely-delete-package p2) + (return nil)) + (safely-delete-package p2) + t))) + t) + +(deftest rename-package.4 + (block nil + (safely-delete-package "G") + (safely-delete-package "TEST2") + (let ((p (make-package "G")) + (nicknames nil)) + (unless (packagep p) (return nil)) + (let ((p2 (ignore-errors (rename-package #\G "TEST2" nicknames)))) + (unless (packagep p2) + (safely-delete-package p) + (return p2)) + (unless (and (eqt p p2) + (equal (package-name p2) "TEST2") + (null (set-exclusive-or nicknames + (package-nicknames p2) + :test #'equal))) + (safely-delete-package p) + (safely-delete-package p2) + (return nil)) + (ignore-errors (safely-delete-package p2)) + t))) + t) + +(deftest rename-package.5 + (block nil + (safely-delete-package "TEST1") + (safely-delete-package "G") + (let ((p (make-package "TEST1")) + (nicknames nil)) + (unless (packagep p) (return nil)) + (let ((p2 (ignore-errors (rename-package "TEST1" #\G nicknames)))) + (unless (packagep p2) + (safely-delete-package p) + (return p2)) + (unless (and (eqt p p2) + (equal (package-name p2) "G") + (null (set-exclusive-or nicknames + (package-nicknames p2) + :test #'equal))) + (safely-delete-package p) + (safely-delete-package p2) + (return nil)) + (safely-delete-package p2) + t))) + t) + +(deftest rename-package.6 + (block nil + (safely-delete-package '|TEST1|) + (safely-delete-package '|TEST2|) + (safely-delete-package '|M|) + (safely-delete-package '|N|) + (let ((p (make-package '|TEST1|)) + (nicknames (copy-list '(|M| |N|)))) + (unless (packagep p) (return nil)) + (let ((p2 (ignore-errors (rename-package + '|TEST1| '|TEST2| nicknames)))) + (unless (packagep p2) + (safely-delete-package p) + (return p2)) + (unless (and (eqt p p2) + (equal (package-name p2) "TEST2") + (equal + (sort (copy-list (package-nicknames p2)) + #'string<) + (sort (mapcar #'symbol-name nicknames) + #'string<))) + (safely-delete-package p) + (safely-delete-package p2) + (return nil)) + (safely-delete-package p2) + t))) + t) + +(deftest rename-package.error.1 + (classify-error (rename-package)) + program-error) + +(deftest rename-package.error.2 + (classify-error (rename-package "CL")) + program-error) + +(deftest rename-package.error.3 + (classify-error (rename-package "A" "XXXXX" NIL NIL)) + program-error) + + + diff --git a/ansi-tests/packages-07.lsp b/ansi-tests/packages-07.lsp new file mode 100644 index 0000000..9d3c0cf --- /dev/null +++ b/ansi-tests/packages-07.lsp @@ -0,0 +1,231 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 25 08:01:20 1998 +;;;; Contains: Package test code, part 07 + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; shadow + +(deftest shadow.1 + (prog1 + (progn + (safely-delete-package "TEST5") + (safely-delete-package "TEST4") + (handler-case + (let* ((p1 (prog1 + (make-package "TEST4") + (export (intern "A" "TEST4") "TEST4"))) + (p2 (make-package "TEST5" :use '("TEST4"))) + (r1 (package-shadowing-symbols "TEST4")) + (r2 (package-shadowing-symbols "TEST5"))) + (multiple-value-bind* (s1 kind1) + (find-symbol "A" p1) + (multiple-value-bind* (s2 kind2) + (find-symbol "A" p2) + (let ((r3 (shadow "A" p2))) + (multiple-value-bind* (s3 kind3) + (find-symbol "A" p2) + (list + (package-name p1) + (package-name p2) + r1 r2 + (symbol-name s1) + (package-name (symbol-package s1)) + kind1 + (symbol-name s2) + (package-name (symbol-package s2)) + kind2 + r3 + (symbol-name s3) + (package-name (symbol-package s3)) + kind3)))))) + (error (c) c))) + (safely-delete-package "TEST5") + (safely-delete-package "TEST4")) + ("TEST4" "TEST5" nil nil "A" "TEST4" :external + "A" "TEST4" :inherited + t + "A" "TEST5" :internal)) + +(deftest shadow.2 + (progn + (safely-delete-package "H") + (safely-delete-package "G") + (handler-case + (let* ((p1 (prog1 + (make-package "G") + (export (intern "A" "G") "G"))) + (p2 (make-package "H" :use '("G"))) + (r1 (package-shadowing-symbols "G")) + (r2 (package-shadowing-symbols "H"))) + (multiple-value-bind* (s1 kind1) + (find-symbol "A" p1) + (multiple-value-bind* (s2 kind2) + (find-symbol "A" p2) + (let ((r3 (shadow "A" "H"))) + (multiple-value-bind* (s3 kind3) + (find-symbol "A" p2) + (prog1 + (list (package-name p1) (package-name p2) + r1 r2 (symbol-name s1) (package-name (symbol-package s1)) + kind1 (symbol-name s2) (package-name (symbol-package s2)) + kind2 r3 (symbol-name s3) (package-name (symbol-package s3)) + kind3) + (safely-delete-package p2) + (safely-delete-package p1) + )))))) + (error (c) + (safely-delete-package "H") + (safely-delete-package "G") + c))) + ("G" "H" nil nil "A" "G" :external + "A" "G" :inherited + t + "A" "H" :internal)) + +;; shadow in which the package is given +;; by a character +(deftest shadow.3 + (progn + (safely-delete-package "H") + (safely-delete-package "G") + (handler-case + (let* ((p1 (prog1 + (make-package "G") + (export (intern "A" "G") "G"))) + (p2 (make-package "H" :use '("G"))) + (r1 (package-shadowing-symbols "G")) + (r2 (package-shadowing-symbols "H"))) + (multiple-value-bind* (s1 kind1) + (find-symbol "A" p1) + (multiple-value-bind* (s2 kind2) + (find-symbol "A" p2) + (let ((r3 (shadow "A" #\H))) + (multiple-value-bind* (s3 kind3) + (find-symbol "A" p2) + (prog1 + (list (package-name p1) (package-name p2) + r1 r2 (symbol-name s1) (package-name (symbol-package s1)) + kind1 (symbol-name s2) (package-name (symbol-package s2)) + kind2 r3 (symbol-name s3) (package-name (symbol-package s3)) + kind3) + (safely-delete-package p2) + (safely-delete-package p1) + )))))) + (error (c) + (safely-delete-package "H") + (safely-delete-package "G") + c))) + ("G" "H" nil nil "A" "G" :external + "A" "G" :inherited + t + "A" "H" :internal)) + + +;; shadow on an existing internal symbol returns the existing symbol +(deftest shadow.4 + (prog1 + (handler-case + (progn + (safely-delete-package :G) + (make-package :G) + (let ((s1 (intern "X" :G))) + (shadow "X" :G) + (multiple-value-bind* (s2 kind) + (find-symbol "X" :G) + (list (eqt s1 s2) + (symbol-name s2) + (package-name (symbol-package s2)) + kind)))) + (error (c) c)) + (safely-delete-package "G")) + (t "X" "G" :internal)) + + +;; shadow of an existing shadowed symbol returns the symbol +(deftest shadow.5 + (prog1 + (handler-case + (progn + (safely-delete-package :H) + (safely-delete-package :G) + (make-package :G) + (export (intern "X" :G) :G) + (make-package :H :use '("G")) + (shadow "X" :H) + (multiple-value-bind* (s1 kind1) + (find-symbol "X" :H) + (shadow "X" :H) + (multiple-value-bind* (s2 kind2) + (find-symbol "X" :H) + (list (eqt s1 s2) kind1 kind2)))) + (error (c) c)) + (safely-delete-package :H) + (safely-delete-package :G)) + (t :internal :internal)) + +;; Shadow several names simultaneously + +(deftest shadow.6 + (prog1 + (handler-case + (progn + (safely-delete-package :G) + (make-package :G) + (shadow '("X" "Y" |Z|) :G) + (let ((results + (append (multiple-value-list + (find-symbol "X" :G)) + (multiple-value-list + (find-symbol "Y" :G)) + (multiple-value-list + (find-symbol "Z" :G)) + nil))) + (list + (symbol-name (first results)) + (second results) + (symbol-name (third results)) + (fourth results) + (symbol-name (fifth results)) + (sixth results) + (length (package-shadowing-symbols :G))))) + (error (c) c)) + (safely-delete-package :G)) + ("X" :internal "Y" :internal "Z" :internal 3)) + +;; Same, but shadow character string designators +(deftest shadow.7 + (prog1 + (handler-case + (let ((i 0) x y) + (safely-delete-package :G) + (make-package :G) + (shadow (progn (setf x (incf i)) '(#\X #\Y)) + (progn (setf y (incf i)) :G)) + (let ((results + (append (multiple-value-list + (find-symbol "X" :G)) + (multiple-value-list + (find-symbol "Y" :G)) + nil))) + (list + i x y + (symbol-name (first results)) + (second results) + (symbol-name (third results)) + (fourth results) + (length (package-shadowing-symbols :G))))) + (error (c) c)) + (safely-delete-package :G)) + (2 1 2 "X" :internal "Y" :internal 2)) + +(deftest shadow.error.1 + (classify-error (shadow)) + program-error) + +(deftest shadow.error.2 + (classify-error (shadow "X" "CL-USER" nil)) + program-error) diff --git a/ansi-tests/packages-08.lsp b/ansi-tests/packages-08.lsp new file mode 100644 index 0000000..d35d09b --- /dev/null +++ b/ansi-tests/packages-08.lsp @@ -0,0 +1,148 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 25 08:01:58 1998 +;;;; Contains: Package test code, part 08 + +(in-package :cl-test) +(declaim (optimize (safety 3))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; delete-package + +;; check return value of delete-package, and check +;; that package-name is nil on the deleted package object +(deftest delete-package.1 + (progn + (safely-delete-package :test1) + (let ((p (make-package :test1 :use nil))) + (list + (notnot (delete-package :test1)) + (notnot (packagep p)) + (package-name p)))) + (t t nil)) + +(deftest delete-package.2 + (progn + (safely-delete-package :test1) + (let ((p (make-package :test1 :use nil))) + (list + (notnot (delete-package :test1)) + (notnot (packagep p)) + (delete-package p)))) + (t t nil)) + +;; Check that deletion of different package designators works +(deftest delete-package.3 + (progn + (safely-delete-package "X") + (make-package "X") + (handler-case + (notnot (delete-package "X")) + (error (c) c))) + t) + +(deftest delete-package.4 + (progn + (safely-delete-package "X") + (make-package "X") + (handler-case + (notnot (delete-package #\X)) + (error (c) c))) + t) + +;;; PFD 10/14/02 -- These tests are broken again. I suspect +;;; some sort of interaction with the test harness. + +;;; PFD 01.18.03 This test is working, but suspicious. + +(deftest delete-package.5 + (prog (P1 S1 P2 S2 P3) + (safely-delete-package "P3") + (safely-delete-package "P2") + (safely-delete-package "P1") + + (setq P1 (make-package "P1" :use ())) + (setq S1 (intern "S1" P1)) + (export S1 "P1") + + (setq P2 (make-package "P2" :use '("P1"))) + (setq S2 (intern "S2" P2)) + (export S1 P2) + (export S2 "P2") + + (setf P3 (make-package "P3" :use '("P2"))) + + ;; Delete the P2 package, catching the continuable + ;; error and deleting the package + + (handler-bind ((package-error + #'(lambda (c) + (let ((r (find-restart 'continue c))) + (and r (invoke-restart r)))))) + (delete-package P2)) + + (unless (and (equal (package-name P1) "P1") + (null (package-name P2)) + (equal (package-name P3) "P3")) + (return 'fail1)) + + (unless (eqt (symbol-package S1) P1) + (return 'fail2)) + (unless (equal (prin1-to-string S1) "P1:S1") + (return 'fail3)) + + (unless (equal (multiple-value-list (find-symbol "S1" P3)) + '(nil nil)) + (return 'fail4)) + + (unless (equal (multiple-value-list (find-symbol "S2" P3)) + '(nil nil)) + (return 'fail5)) + + (unless (and (null (package-used-by-list P1)) + (null (package-used-by-list P3))) + (return 'fail6)) + + (unless (and (packagep P1) + (packagep P2) + (packagep P3)) (return 'fail7)) + + (unless (and (null (package-use-list P1)) + (null (package-use-list P3))) + (return 'fail8)) + + (safely-delete-package P3) + (safely-delete-package P1) + (return t)) + t) + +;; deletion of a nonexistent package should cause a continuable +;; package-error (same comments for delete-package.5 apply +;; here as well) + +;;; PFD 10/14/02 -- These tests are broken again. I suspect +;;; some sort of interaction with the test harness. + +;;; PFD 01.18.03 This test is working, but suspicious. + +(deftest delete-package.6 + (progn + (safely-delete-package "TEST-20)") + (handler-bind ((package-error + #'(lambda (c) + (let ((r (find-restart 'continue c))) + (and r (invoke-restart r)))))) + (and (not (delete-package "TEST-20")) + t))) + t) + +(deftest delete-package.error.1 + (classify-error (delete-package)) + program-error) + +(deftest delete-package.error.2 + (progn + (unless (find-package "TEST-DPE2") + (make-package "TEST-DPE2" :use nil)) + (classify-error (delete-package "TEST-DPE2" nil))) + program-error) + diff --git a/ansi-tests/packages-09.lsp b/ansi-tests/packages-09.lsp new file mode 100644 index 0000000..67a86ba --- /dev/null +++ b/ansi-tests/packages-09.lsp @@ -0,0 +1,324 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 25 08:02:43 1998 +;;;; Contains: Package test code, part 09 + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; make-package + +;; Test basic make-package, using string, symbol and character +;; package-designators + +(deftest make-package.1 + (progn + (safely-delete-package "TEST1") + (let ((p (ignore-errors (make-package "TEST1")))) + (prog1 + (and (packagep p) + (equalt (package-name p) "TEST1") + (equalt (package-nicknames p) nil) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) + t) + +(deftest make-package.2 + (progn + (safely-delete-package '#:|TEST1|) + (let ((p (ignore-errors (make-package '#:|TEST1|)))) + (prog1 + (and (packagep p) + (equalt (package-name p) "TEST1") + (equalt (package-nicknames p) nil) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) + t) + +(deftest make-package.3 + (progn + (safely-delete-package #\X) + (let ((p (ignore-errors (make-package #\X)))) + (prog1 + (and (packagep p) + (equalt (package-name p) "X") + (equalt (package-nicknames p) nil) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) + t) + +;; Same, but with a null :use list + +(deftest make-package.4 + (progn + (safely-delete-package "TEST1") + (let ((p (ignore-errors (make-package "TEST1" :use nil)))) + (prog1 + (and (packagep p) + (equalt (package-name p) "TEST1") + (equalt (package-nicknames p) nil) + (equalt (package-use-list p) nil) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) + t) + +(deftest make-package.5 + (progn + (safely-delete-package '#:|TEST1|) + (let ((p (ignore-errors (make-package '#:|TEST1| :use nil)))) + (prog1 + (and (packagep p) + (equalt (package-name p) "TEST1") + (equalt (package-nicknames p) nil) + (equalt (package-use-list p) nil) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) + t) + +(deftest make-package.6 + (progn + (safely-delete-package #\X) + (let ((p (make-package #\X))) + (prog1 + (and (packagep p) + (equalt (package-name p) "X") + (equalt (package-nicknames p) nil) + ;; (equalt (package-use-list p) nil) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) + t) + +;; Same, but use the A package + +(deftest make-package.7 + (progn + (safely-delete-package "TEST1") + (let ((p (ignore-errors (make-package "TEST1" :use '("A"))))) + (prog1 + (and (packagep p) + (equalt (package-name p) "TEST1") + (equalt (package-nicknames p) nil) + (equalt (package-use-list p) (list (find-package "A"))) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) + t) + +(deftest make-package.7a + (progn + (safely-delete-package "TEST1") + (let ((p (ignore-errors (make-package "TEST1" :use '(#:|A|))))) + (prog1 + (and (packagep p) + (equalt (package-name p) "TEST1") + (equalt (package-nicknames p) nil) + (equalt (package-use-list p) (list (find-package "A"))) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) + t) + +(deftest make-package.7b + (progn + (safely-delete-package "TEST1") + (let ((p (ignore-errors (make-package "TEST1" :use '(#\A))))) + (prog1 + (and (packagep p) + (equalt (package-name p) "TEST1") + (equalt (package-nicknames p) nil) + (equalt (package-use-list p) (list (find-package "A"))) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) + t) + +(deftest make-package.8 + (progn + (safely-delete-package '#:|TEST1|) + (let ((p (ignore-errors (make-package '#:|TEST1| :use '("A"))))) + (prog1 + (and (packagep p) + (equalt (package-name p) "TEST1") + (equalt (package-nicknames p) nil) + (equalt (package-use-list p) (list (find-package "A"))) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) + t) + +(deftest make-package.8a + (progn + (safely-delete-package '#:|TEST1|) + (let ((p (ignore-errors (make-package '#:|TEST1| :use '(#:|A|))))) + (prog1 + (and (packagep p) + (equalt (package-name p) "TEST1") + (equalt (package-nicknames p) nil) + (equalt (package-use-list p) (list (find-package "A"))) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) + t) + +(deftest make-package.8b + (progn + (safely-delete-package '#:|TEST1|) + (let ((p (ignore-errors (make-package '#:|TEST1| :use '(#\A))))) + (prog1 + (and (packagep p) + (equalt (package-name p) "TEST1") + (equalt (package-nicknames p) nil) + (equalt (package-use-list p) (list (find-package "A"))) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) + t) + +(deftest make-package.9 + (progn + (safely-delete-package #\X) + (let ((p (ignore-errors (make-package #\X :use '("A"))))) + (prog1 + (and (packagep p) + (equalt (package-name p) "X") + (equalt (package-nicknames p) nil) + (equalt (package-use-list p) (list (find-package "A"))) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) + t) + +(deftest make-package.9a + (progn + (safely-delete-package #\X) + (let ((p (ignore-errors (make-package #\X :use '(#:|A|))))) + (prog1 + (and (packagep p) + (equalt (package-name p) "X") + (equalt (package-nicknames p) nil) + (equalt (package-use-list p) (list (find-package "A"))) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) + t) + +(deftest make-package.9b + (progn + (safely-delete-package #\X) + (let ((p (ignore-errors (make-package #\X :use '(#\A))))) + (prog1 + (and (packagep p) + (equalt (package-name p) "X") + (equalt (package-nicknames p) nil) + (equalt (package-use-list p) (list (find-package "A"))) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) + t) + +;; make-package with nicknames + +(deftest make-package.10 + (progn + (safely-delete-package "TEST1") + (let ((p (make-package "TEST1" :nicknames '("F")))) + (prog1 + (and (packagep p) + (equalt (package-name p) "TEST1") + (equalt (package-nicknames p) '("F")) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) + t) + +(deftest make-package.11 + (progn + (safely-delete-package '#:|TEST1|) + (let ((p (make-package '#:|TEST1| :nicknames '(#:|G|)))) + (prog1 + (and (packagep p) + (equalt (package-name p) "TEST1") + (equalt (package-nicknames p) '("G")) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) + t) + +(deftest make-package.12 + (progn + (safely-delete-package '#:|TEST1|) + (let ((p (make-package '#:|TEST1| :nicknames '(#\G)))) + (prog1 + (and (packagep p) + (equalt (package-name p) "TEST1") + (equalt (package-nicknames p) '("G")) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) + t) + +(deftest make-package.13 + (progn + (safely-delete-package #\X) + (let ((p (make-package #\X :nicknames '("F" #\G #:|H|)))) + (prog1 + (and (packagep p) + (equalt (package-name p) "X") + (null (set-exclusive-or (package-nicknames p) + '("F" "G" "H") + :test #'equal)) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) + t) + +;; Signal a continuable error if the package or any nicknames +;; exist as packages or nicknames of packages + +(deftest make-package.error.1 + (handle-non-abort-restart (make-package "A")) + success) + +(deftest make-package.error.2 + (handle-non-abort-restart (make-package "Q")) + success) + +(deftest make-package.error.3 + (handle-non-abort-restart + (safely-delete-package "TEST1") + (make-package "TEST1" :nicknames '("A"))) + success) + +(deftest make-package.error.4 + (handle-non-abort-restart + (safely-delete-package "TEST1") + (make-package "TEST1" :nicknames '("Q"))) + success) + +(deftest make-package.error.5 + (classify-error (make-package)) + program-error) + +(deftest make-package.error.6 + (progn + (safely-delete-package "MPE6") + (classify-error (make-package "MPE6" :bad t))) + program-error) + +(deftest make-package.error.7 + (progn + (safely-delete-package "MPE7") + (classify-error (make-package "MPE7" :nicknames))) + program-error) + +(deftest make-package.error.8 + (progn + (safely-delete-package "MPE8") + (classify-error (make-package "MPE8" :use))) + program-error) + +(deftest make-package.error.9 + (progn + (safely-delete-package "MPE9") + (classify-error (make-package "MPE9" 'bad t))) + program-error) + +(deftest make-package.error.10 + (progn + (safely-delete-package "MPE10") + (classify-error (make-package "MPE10" 1 2))) + program-error) + +(deftest make-package.error.11 + (progn + (safely-delete-package "MPE11") + (classify-error (make-package "MPE11" 'bad t :allow-other-keys nil))) + program-error) diff --git a/ansi-tests/packages-10.lsp b/ansi-tests/packages-10.lsp new file mode 100644 index 0000000..d8ff897 --- /dev/null +++ b/ansi-tests/packages-10.lsp @@ -0,0 +1,121 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 25 08:03:36 1998 +;;;; Contains: Package test code, part 10 + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; with-package-iterator + +(deftest with-package-iterator.1 + (with-package-iterator-internal (list (find-package "COMMON-LISP-USER"))) + t) + +(deftest with-package-iterator.2 + (with-package-iterator-external (list (find-package "COMMON-LISP-USER"))) + t) + +(deftest with-package-iterator.3 + (with-package-iterator-inherited (list (find-package "COMMON-LISP-USER"))) + t) + +(deftest with-package-iterator.4 + (with-package-iterator-all (list (find-package "COMMON-LISP-USER"))) + t) + +;;; Should test on some packages containing shadowed symbols, +;;; multiple inheritance + +(deftest with-package-iterator.5 + (with-package-iterator-all '("A")) + t) + +(deftest with-package-iterator.6 + (with-package-iterator-all '(#:|A|)) + t) + +(deftest with-package-iterator.7 + (with-package-iterator-all '(#\A)) + t) + +(deftest with-package-iterator.8 + (with-package-iterator-internal (list (find-package "A"))) + t) + +(deftest with-package-iterator.9 + (with-package-iterator-external (list (find-package "A"))) + t) + +(deftest with-package-iterator.10 + (with-package-iterator-inherited (list (find-package "A"))) + t) + +;;; Check that if no access symbols are provided, a program error is +;;; raised +#| +(deftest with-package-iterator.11 + (handler-case + (progn + (test-with-package-iterator (list (find-package "COMMON-LISP-USER"))) + nil) + (program-error () t) + (error (c) c)) + t) +|# + +;;; Paul Werkowski" pointed out that +;;; that test is broken. Here's a version of the replacement +;;; he suggested. +;; +;;; I'm not sure if this is correct either; it depends on +;;; whether with-package-iterator should signal the error +;;; at macro expansion time or at run time. +;; +;;; PFD 01-18-03: I should rewrite this to use CLASSIFY-ERROR, which +;;; uses EVAL to avoid that problem. + +(deftest with-package-iterator.11 + (handler-case (macroexpand-1 + '(with-package-iterator (x "COMMON-LISP-USER"))) + (program-error () t) + (error (c) c)) + t) + +;;; Apply to all packages +(deftest with-package-iterator.12 + (loop + for p in (list-all-packages) count + (handler-case + (progn + (format t "Package ~S~%" p) + (not (with-package-iterator-internal (list p)))) + (error (c) + (format "Error ~S on package ~A~%" c p) + t))) + 0) + +(deftest with-package-iterator.13 + (loop + for p in (list-all-packages) count + (handler-case + (progn + (format t "Package ~S~%" p) + (not (with-package-iterator-external (list p)))) + (error (c) + (format "Error ~S on package ~A~%" c p) + t))) + 0) + +(deftest with-package-iterator.14 + (loop + for p in (list-all-packages) count + (handler-case + (progn + (format t "Package ~S~%" p) + (not (with-package-iterator-inherited (list p)))) + (error (c) + (format t "Error ~S on package ~S~%" c p) + t))) + 0) diff --git a/ansi-tests/packages-11.lsp b/ansi-tests/packages-11.lsp new file mode 100644 index 0000000..71e2cd3 --- /dev/null +++ b/ansi-tests/packages-11.lsp @@ -0,0 +1,143 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 25 08:04:19 1998 +;;;; Contains: Package test code, part 11 + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; unexport + +(deftest unexport.1 + (progn + (safely-delete-package "X") + (let* ((p (make-package "X" :use nil)) + (r (export (intern "X" p) p)) + (i 0) x y) + (multiple-value-bind* + (sym1 access1) + (find-symbol "X" p) + (unexport (progn (setf x (incf i)) sym1) + (progn (setf y (incf i)) p)) + (multiple-value-bind* + (sym2 access2) + (find-symbol "X" p) + (and (eqt r t) + (eql i 2) (eql x 1) (eql y 2) + (eqt sym1 sym2) + (eqt access1 :external) + (eqt access2 :internal) + (equal (symbol-name sym1) "X") + t))))) + t) + +(deftest unexport.2 + (progn + (safely-delete-package "X") + (let* ((p (make-package "X" :use nil)) + (r (export (intern "X" p) p))) + (multiple-value-bind* + (sym1 access1) + (find-symbol "X" p) + (unexport (list sym1) "X") + (multiple-value-bind* + (sym2 access2) + (find-symbol "X" p) + (and (eqt sym1 sym2) + (eqt r t) + (eqt access1 :external) + (eqt access2 :internal) + (equal (symbol-name sym1) "X") + t))))) + t) + +(deftest unexport.3 + (progn + (safely-delete-package "X") + (let* ((p (make-package "X" :use nil)) + (r1 (export (intern "X" p) p)) + (r2 (export (intern "Y" p) p))) + (multiple-value-bind* + (sym1 access1) + (find-symbol "X" p) + (multiple-value-bind* + (sym1a access1a) + (find-symbol "Y" p) + (unexport (list sym1 sym1a) '#:|X|) + (multiple-value-bind* + (sym2 access2) + (find-symbol "X" p) + (multiple-value-bind* + (sym2a access2a) + (find-symbol "Y" p) + (and (eqt sym1 sym2) + (eqt sym1a sym2a) + (eqt r1 t) + (eqt r2 t) + (eqt access1 :external) + (eqt access2 :internal) + (eqt access1a :external) + (eqt access2a :internal) + (equal (symbol-name sym1) "X") + (equal (symbol-name sym1a) "Y") + t))))))) + t) + +(deftest unexport.4 + (progn + (safely-delete-package "X") + (let* ((p (make-package "X" :use nil)) + (r (export (intern "X" p) p))) + (multiple-value-bind* + (sym1 access1) + (find-symbol "X" p) + (unexport (list sym1) #\X) + (multiple-value-bind* + (sym2 access2) + (find-symbol "X" p) + (and (eqt sym1 sym2) + (eqt r t) + (eqt access1 :external) + (eqt access2 :internal) + (equal (symbol-name sym1) "X") + t))))) + t) + +;; Check that it signals a package error when unexporting +;; an inaccessible symbol + +(deftest unexport.5 + (classify-error + (progn + (when (find-package "X") (delete-package "X")) + (unexport 'a (make-package "X" :use nil)) + nil)) + package-error) + +;; Check that internal symbols are left alone + +(deftest unexport.6 + (progn + (when (find-package "X") (delete-package "X")) + (let ((p (make-package "X" :use nil))) + (let* ((sym (intern "FOO" p)) + (r (unexport sym p))) + (multiple-value-bind* + (sym2 access) + (find-symbol "FOO" p) + (and (eqt r t) + (eqt access :internal) + (eqt sym sym2) + (equal (symbol-name sym) "FOO") + t))))) + t) + +(deftest unexport.error.1 + (classify-error (unexport)) + program-error) + +(deftest unexport.error.2 + (classify-error (unexport 'xyz "CL-TEST" nil)) + program-error) + diff --git a/ansi-tests/packages-12.lsp b/ansi-tests/packages-12.lsp new file mode 100644 index 0000000..b1614ca --- /dev/null +++ b/ansi-tests/packages-12.lsp @@ -0,0 +1,247 @@ +();-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 25 08:04:56 1998 +;;;; Contains: Package test code, part 12 + +(in-package :cl-test) +(declaim (optimize (safety 3))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; unintern + +;; Simple unintern of an internal symbol, package explicitly +;; given as a package object +(deftest unintern.1 + (progn + (safely-delete-package "H") + (prog1 + (let ((p (make-package "H")) + (i 0) x y) + (intern "FOO" p) + (multiple-value-bind* + (sym access) + (find-symbol "FOO" p) + (and + (eqt access :internal) + (unintern (progn (setf x (incf i)) sym) + (progn (setf y (incf i)) p)) + (eql i 2) (eql x 1) (eql y 2) + (null (symbol-package sym)) + (not (find-symbol "FOO" p))))) + (safely-delete-package "H"))) + t) + +;; Simple unintern, package taken from the *PACKAGES* +;; special variable (should this have unwind protect?) +(deftest unintern.2 + (progn + (safely-delete-package "H") + (prog1 + (let ((*PACKAGE* (make-package "H"))) + (declare (special *PACKAGE*)) + (intern "FOO") + (multiple-value-bind* (sym access) + (find-symbol "FOO") + (and + (eqt access :internal) + (unintern sym) + (null (symbol-package sym)) + (not (find-symbol "FOO"))))) + (safely-delete-package "H"))) + t) + +;; Simple unintern, package given as string +(deftest unintern.3 + (progn + (safely-delete-package "H") + (prog1 + (let ((p (make-package "H"))) + (intern "FOO" p) + (multiple-value-bind* (sym access) + (find-symbol "FOO" p) + (and + (eqt access :internal) + (unintern sym "H") + (null (symbol-package sym)) + (not (find-symbol "FOO" p))))) + (safely-delete-package "H"))) + t) + +;; Simple unintern, package given as symbol +(deftest unintern.4 + (progn + (safely-delete-package "H") + (prog1 + (let ((p (make-package "H"))) + (intern "FOO" p) + (multiple-value-bind* (sym access) + (find-symbol "FOO" p) + (and + (eqt access :internal) + (unintern sym '#:|H|) + (null (symbol-package sym)) + (not (find-symbol "FOO" p))))) + (safely-delete-package "H"))) + t) + +;; Simple unintern, package given as character +(deftest unintern.5 + (handler-case + (progn + (safely-delete-package "H") + (prog1 + (let ((p (make-package "H"))) + (intern "FOO" p) + (multiple-value-bind* (sym access) + (find-symbol "FOO" p) + (and + (eqt access :internal) + (unintern sym #\H) + (null (symbol-package sym)) + (not (find-symbol "FOO" p))))) + (safely-delete-package "H"))) + (error (c) c)) + t) + + +;; Test more complex examples of unintern + +;; Unintern an external symbol that is also inherited + +(deftest unintern.6 + (handler-case + (progn + (safely-delete-package "H") + (safely-delete-package "G") + (make-package "G") + (export (intern "FOO" "G") "G") + (make-package "H" :use '("G")) + (export (intern "FOO" "H") "H") + ;; At this point, G:FOO is also an external + ;; symbol of H. + (multiple-value-bind* (sym1 access1) + (find-symbol "FOO" "H") + (and sym1 + (eqt access1 :external) + (equal "FOO" (symbol-name sym1)) + (eqt (find-package "G") + (symbol-package sym1)) + (unintern sym1 "H") + (multiple-value-bind* (sym2 access2) + (find-symbol "FOO" "H") + (and (eqt sym1 sym2) + (eqt (symbol-package sym1) + (find-package "G")) + (eqt access2 :inherited)))))) + (error (c) c)) + t) + +;; unintern a symbol that is shadowing another symbol + +(deftest unintern.7 + (block failed + (safely-delete-package "H") + (safely-delete-package "G") + (let* ((pg (make-package "G")) + (ph (make-package "H" :use (list pg)))) + (handler-case + (shadow "FOO" ph) + (error (c) (return-from failed (list :shadow-error c)))) + (export (intern "FOO" pg) pg) + ;; At this point, H::FOO shadows G:FOO + (multiple-value-bind* (sym1 access1) + (find-symbol "FOO" ph) + (and + sym1 + (eqt (symbol-package sym1) ph) + (eqt access1 :internal) + (equal (list sym1) (package-shadowing-symbols ph)) + (unintern sym1 ph) + (multiple-value-bind* (sym2 access2) + (find-symbol "FOO" ph) + (and (not (eqt sym1 sym2)) + (eqt access2 :inherited) + (null (symbol-package sym1)) + (eqt (symbol-package sym2) pg))))))) + t) + +;; Error situation: when the symbol is uninterned, creates +;; a name conflict from two used packages +(deftest unintern.8 + (block failed + (safely-delete-package "H") + (safely-delete-package "G1") + (safely-delete-package "G2") + (let* ((pg1 (make-package "G1")) + (pg2 (make-package "G2")) + (ph (make-package "H" :use (list pg1 pg2)))) + (handler-case + (shadow "FOO" ph) + (error (c) (return-from failed (list :shadow-error c)))) + (let ((gsym1 (intern "FOO" pg1)) + (gsym2 (intern "FOO" pg2))) + (export gsym1 pg1) + (export gsym2 pg2) + (multiple-value-bind* (sym1 access1) + (find-symbol "FOO" ph) + (and + (equal (list sym1) (package-shadowing-symbols ph)) + (not (eqt sym1 gsym1)) + (not (eqt sym1 gsym2)) + (eqt (symbol-package sym1) ph) + (eqt access1 :internal) + (equal (symbol-name sym1) "FOO") + (handler-case + (progn + (unintern sym1 ph) + nil) + (error (c) + (format t "Properly threw an error: ~S~%" c) + t))))))) + t) + +;; Now, inherit the same symbol through two intermediate +;; packages. No error should occur when the shadowing +;; is removed +(deftest unintern.9 + (block failed + (safely-delete-package "H") + (safely-delete-package "G1") + (safely-delete-package "G2") + (safely-delete-package "G3") + (let* ((pg3 (make-package "G3")) + (pg1 (make-package "G1" :use (list pg3))) + (pg2 (make-package "G2" :use (list pg3))) + (ph (make-package "H" :use (list pg1 pg2)))) + (handler-case + (shadow "FOO" ph) + (error (c) (return-from failed (list :shadow-error c)))) + (let ((gsym (intern "FOO" pg3))) + (export gsym pg3) + (export gsym pg1) + (export gsym pg2) + (multiple-value-bind* (sym access) + (find-symbol "FOO" ph) + (and + (equal (list sym) (package-shadowing-symbols ph)) + (not (eqt sym gsym)) + (equal (symbol-name sym) "FOO") + (equal (symbol-package sym) ph) + (eqt access :internal) + (handler-case + (and (unintern sym ph) + (multiple-value-bind* (sym2 access2) + (find-symbol "FOO" ph) + (and (eqt gsym sym2) + (eqt access2 :inherited)))) + (error (c) c))))))) + t) + +(deftest unintern.error.1 + (classify-error (unintern)) + program-error) + +(deftest unintern.error.2 + (classify-error (unintern '#:x "CL-TEST" nil)) + program-error) diff --git a/ansi-tests/packages-13.lsp b/ansi-tests/packages-13.lsp new file mode 100644 index 0000000..4add73c --- /dev/null +++ b/ansi-tests/packages-13.lsp @@ -0,0 +1,52 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 25 08:06:03 1998 +;;;; Contains: Package test code, part 13 + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; in-package + +(deftest in-package.1 + (let ((*package* *package*)) + (declare (special *package*)) + (let ((p2 (in-package "A"))) + (and (eqt p2 (find-package "A")) + (eqt *package* p2)))) + t) + +(deftest in-package.2 + (let ((*package* *package*)) + (declare (special *package*)) + (let ((p2 (in-package |A|))) + (and (eqt p2 (find-package "A")) + (eqt *package* p2)))) + t) + +(deftest in-package.3 + (let ((*package* *package*)) + (declare (special *package*)) + (let ((p2 (in-package :|A|))) + (and (eqt p2 (find-package "A")) + (eqt *package* p2)))) + t) + +(deftest in-package.4 + (let ((*package* *package*)) + (declare (special *package*)) + (let ((p2 (in-package #\A))) + (and (eqt p2 (find-package "A")) + (eqt *package* p2)))) + t) + +(deftest in-package.5 + (let ((*package* *package*)) + (declare (special *package*)) + (safely-delete-package "H") + (handler-case + (eval '(in-package "H")) + (package-error () 'package-error) + (error (c) c))) + package-error) diff --git a/ansi-tests/packages-14.lsp b/ansi-tests/packages-14.lsp new file mode 100644 index 0000000..fe3a9b2 --- /dev/null +++ b/ansi-tests/packages-14.lsp @@ -0,0 +1,201 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 25 08:06:48 1998 +;;;; Contains: Package test code, part 14 + +(in-package :cl-test) +(declaim (optimize (safety 3))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; unuse-package + +(deftest unuse-package.1 + (progn + (safely-delete-package "H") + (safely-delete-package "G") + (let* ((pg (make-package "G" :use nil)) + (ph (make-package "H" :use '("G"))) + (i 0) x y) + (prog1 + (and + (equal (package-use-list ph) (list pg)) + (equal (package-used-by-list pg) (list ph)) + (unuse-package (progn (setf x (incf i)) pg) + (progn (setf y (incf i)) ph)) + (eql i 2) (eql x 1) (eql y 2) + (equal (package-use-list ph) nil) + (null (package-used-by-list pg))) + (safely-delete-package "H") + (safely-delete-package "G")))) + t) + +(deftest unuse-package.2 + (progn + (safely-delete-package "H") + (safely-delete-package "G") + (let* ((pg (make-package "G" :use nil)) + (ph (make-package "H" :use '("G")))) + (prog1 + (and + (equal (package-use-list ph) (list pg)) + (equal (package-used-by-list pg) (list ph)) + (unuse-package "G" ph) + (equal (package-use-list ph) nil) + (null (package-used-by-list pg))) + (safely-delete-package "H") + (safely-delete-package "G")))) + t) + +(deftest unuse-package.3 + (progn + (safely-delete-package "H") + (safely-delete-package "G") + (let* ((pg (make-package "G" :use nil)) + (ph (make-package "H" :use '("G")))) + (prog1 + (and + (equal (package-use-list ph) (list pg)) + (equal (package-used-by-list pg) (list ph)) + (unuse-package :|G| ph) + (equal (package-use-list ph) nil) + (null (package-used-by-list pg))) + (safely-delete-package "H") + (safely-delete-package "G")))) + t) + +(deftest unuse-package.4 + (progn + (safely-delete-package "H") + (safely-delete-package "G") + (let* ((pg (make-package "G" :use nil)) + (ph (make-package "H" :use '("G")))) + (prog1 + (and + (equal (package-use-list ph) (list pg)) + (equal (package-used-by-list pg) (list ph)) + (ignore-errors (unuse-package #\G ph)) + (equal (package-use-list ph) nil) + (null (package-used-by-list pg))) + (safely-delete-package "H") + (safely-delete-package "G")))) + t) + +(deftest unuse-package.5 + (progn + (safely-delete-package "H") + (safely-delete-package "G") + (let* ((pg (make-package "G" :use nil)) + (ph (make-package "H" :use '("G")))) + (prog1 + (and + (equal (package-use-list ph) (list pg)) + (equal (package-used-by-list pg) (list ph)) + (unuse-package (list pg) ph) + (equal (package-use-list ph) nil) + (null (package-used-by-list pg))) + (safely-delete-package "H") + (safely-delete-package "G")))) + t) + +(deftest unuse-package.6 + (progn + (safely-delete-package "H") + (safely-delete-package "G") + (let* ((pg (make-package "G" :use nil)) + (ph (make-package "H" :use '("G")))) + (prog1 + (and + (equal (package-use-list ph) (list pg)) + (equal (package-used-by-list pg) (list ph)) + (unuse-package (list "G") ph) + (equal (package-use-list ph) nil) + (null (package-used-by-list pg))) + (safely-delete-package "H") + (safely-delete-package "G")))) + t) + +(deftest unuse-package.7 + (progn + (safely-delete-package "H") + (safely-delete-package "G") + (let* ((pg (make-package "G" :use nil)) + (ph (make-package "H" :use '("G")))) + (prog1 + (and + (equal (package-use-list ph) (list pg)) + (equal (package-used-by-list pg) (list ph)) + (unuse-package (list :|G|) ph) + (equal (package-use-list ph) nil) + (null (package-used-by-list pg))) + (safely-delete-package "H") + (safely-delete-package "G")))) + t) + +(deftest unuse-package.8 + (progn + (safely-delete-package "H") + (safely-delete-package "G") + (let* ((pg (make-package "G" :use nil)) + (ph (make-package "H" :use '("G")))) + (prog1 + (and + (equal (package-use-list ph) (list pg)) + (equal (package-used-by-list pg) (list ph)) + (ignore-errors (unuse-package (list #\G) ph)) + (equal (package-use-list ph) nil) + (null (package-used-by-list pg))) + (safely-delete-package "H") + (safely-delete-package "G")))) + t) + +;; Now test with multiple packages + +(deftest unuse-package.9 + (progn + (dolist (p '("H1" "H2" "G1" "G2" "G3")) + (safely-delete-package p)) + (let* ((pg1 (make-package "G1" :use nil)) + (pg2 (make-package "G2" :use nil)) + (pg3 (make-package "G3" :use nil)) + (ph1 (make-package "H1" :use (list pg1 pg2 pg3))) + (ph2 (make-package "H2" :use (list pg1 pg2 pg3)))) + (let ((pubg1 (sort-package-list (package-used-by-list pg1))) + (pubg2 (sort-package-list (package-used-by-list pg2))) + (pubg3 (sort-package-list (package-used-by-list pg3))) + (puh1 (sort-package-list (package-use-list ph1))) + (puh2 (sort-package-list (package-use-list ph2)))) + (prog1 + (and + (= (length (remove-duplicates (list pg1 pg2 pg3 ph1 ph2))) + 5) + (equal (list ph1 ph2) pubg1) + (equal (list ph1 ph2) pubg2) + (equal (list ph1 ph2) pubg3) + (equal (list pg1 pg2 pg3) puh1) + (equal (list pg1 pg2 pg3) puh2) + (unuse-package (list pg1 pg3) ph1) + (equal (package-use-list ph1) (list pg2)) + (equal (package-used-by-list pg1) (list ph2)) + (equal (package-used-by-list pg3) (list ph2)) + (equal (sort-package-list (package-use-list ph2)) + (list pg1 pg2 pg3)) + (equal (sort-package-list (package-used-by-list pg2)) + (list ph1 ph2)) + t) + (dolist (p '("H1" "H2" "G1" "G2" "G3")) + (safely-delete-package p)))))) + t) + +(deftest unuse-package.error.1 + (classify-error (unuse-package)) + program-error) + +(deftest unuse-package.error.2 + (progn + (safely-delete-package "UPE2A") + (safely-delete-package "UPE2") + (make-package "UPE2" :use ()) + (make-package "UPE2A" :use '("UPE2")) + (classify-error (unuse-package "UPE2" "UPE2A" nil))) + program-error) diff --git a/ansi-tests/packages-15.lsp b/ansi-tests/packages-15.lsp new file mode 100644 index 0000000..c4d24a7 --- /dev/null +++ b/ansi-tests/packages-15.lsp @@ -0,0 +1,210 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 25 08:08:41 1998 +;;;; Contains: Package test code, part 15 + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; use-package + +(deftest use-package.1 + (progn + (safely-delete-package "H") + (safely-delete-package "G") + (let* ((pg (make-package "G" :use nil)) + (ph (make-package "H" :use nil)) + (sym1 (intern "FOO" pg)) + (i 0) x y) + (and + (eqt (export sym1 pg) t) + (null (package-used-by-list pg)) + (null (package-used-by-list ph)) + (null (package-use-list pg)) + (null (package-use-list ph)) + (eqt (use-package (progn (setf x (incf i)) pg) + (progn (setf y (incf i)) ph)) + t) ;; "H" will use "G" + (eql i 2) (eql x 1) (eql y 2) + (multiple-value-bind (sym2 access) + (find-symbol "FOO" ph) + (and + (eqt access :inherited) + (eqt sym1 sym2))) + (equal (package-use-list ph) (list pg)) + (equal (package-used-by-list pg) (list ph)) + (null (package-use-list pg)) + (null (package-used-by-list ph)) + (eqt (unuse-package pg ph) t) + (null (find-symbol "FOO" ph))))) + t) + +(deftest use-package.2 + (progn + (safely-delete-package "H") + (safely-delete-package "G") + (let* ((pg (make-package "G" :use nil)) + (ph (make-package "H" :use nil)) + (sym1 (intern "FOO" pg))) + (and + (eqt (export sym1 pg) t) + (null (package-used-by-list pg)) + (null (package-used-by-list ph)) + (null (package-use-list pg)) + (null (package-use-list ph)) + (eqt (use-package "G" "H") t) ;; "H" will use "G" + (multiple-value-bind (sym2 access) + (find-symbol "FOO" ph) + (and + (eqt access :inherited) + (eqt sym1 sym2))) + (equal (package-use-list ph) (list pg)) + (equal (package-used-by-list pg) (list ph)) + (null (package-use-list pg)) + (null (package-used-by-list ph)) + (eqt (unuse-package pg ph) t) + (null (find-symbol "FOO" ph))))) + t) + +(deftest use-package.3 + (progn + (safely-delete-package "H") + (safely-delete-package "G") + (let* ((pg (make-package "G" :use nil)) + (ph (make-package "H" :use nil)) + (sym1 (intern "FOO" pg))) + (and + (eqt (export sym1 pg) t) + (null (package-used-by-list pg)) + (null (package-used-by-list ph)) + (null (package-use-list pg)) + (null (package-use-list ph)) + (eqt (use-package '#:|G| '#:|H|) t) ;; "H" will use "G" + (multiple-value-bind (sym2 access) + (find-symbol "FOO" ph) + (and + (eqt access :inherited) + (eqt sym1 sym2))) + (equal (package-use-list ph) (list pg)) + (equal (package-used-by-list pg) (list ph)) + (null (package-use-list pg)) + (null (package-used-by-list ph)) + (eqt (unuse-package pg ph) t) + (null (find-symbol "FOO" ph))))) + t) + +(deftest use-package.4 + (progn + (safely-delete-package "H") + (safely-delete-package "G") + (let* ((pg (make-package "G" :use nil)) + (ph (make-package "H" :use nil)) + (sym1 (intern "FOO" pg))) + (and + (eqt (export sym1 pg) t) + (null (package-used-by-list pg)) + (null (package-used-by-list ph)) + (null (package-use-list pg)) + (null (package-use-list ph)) + (eqt (ignore-errors (use-package #\G #\H)) + t) ;; "H" will use "G" + (multiple-value-bind (sym2 access) + (find-symbol "FOO" ph) + (and + (eqt access :inherited) + (eqt sym1 sym2))) + (equal (package-use-list ph) (list pg)) + (equal (package-used-by-list pg) (list ph)) + (null (package-use-list pg)) + (null (package-used-by-list ph)) + (eqt (unuse-package pg ph) t) + (null (find-symbol "FOO" ph))))) + t) + +;; use lists of packages + +(deftest use-package.5 + (let ((pkgs '("H" "G1" "G2" "G3")) + (vars '("FOO1" "FOO2" "FOO3"))) + (dolist (p pkgs) + (safely-delete-package p) + (make-package p :use nil)) + (and + (every (complement #'package-use-list) pkgs) + (every (complement #'package-used-by-list) pkgs) + (every #'(lambda (v p) + (export (intern v p) p)) + vars (cdr pkgs)) + (progn + (dolist (p (cdr pkgs)) (intern "MINE" p)) + (eqt (use-package (cdr pkgs) (car pkgs)) t)) + (every #'(lambda (v p) + (eqt (find-symbol v p) + (find-symbol v (car pkgs)))) + vars (cdr pkgs)) + (null (find-symbol "MINE" (car pkgs))) + (every #'(lambda (p) + (equal (package-used-by-list p) + (list (find-package (car pkgs))))) + (cdr pkgs)) + (equal (sort-package-list (package-use-list (car pkgs))) + (mapcar #'find-package (cdr pkgs))) + (every (complement #'package-use-list) (cdr pkgs)) + (null (package-used-by-list (car pkgs))))) + t) + +;; Circular package use + +(deftest use-package.6 + (progn + (safely-delete-package "H") + (safely-delete-package "G") + (let ((pg (make-package "G")) + (ph (make-package "H")) + sym1 sym2 sym3 sym4 + a1 a2 a3 a4) + (prog1 + (and + (export (intern "X" pg) pg) + (export (intern "Y" ph) ph) + (use-package pg ph) + (use-package ph pg) + (progn + (multiple-value-setq + (sym1 a1) (find-symbol "X" pg)) + (multiple-value-setq + (sym2 a2) (find-symbol "Y" ph)) + (multiple-value-setq + (sym3 a3) (find-symbol "Y" pg)) + (multiple-value-setq + (sym4 a4) (find-symbol "X" ph)) + (and + (eqt a1 :external) + (eqt a2 :external) + (eqt a3 :inherited) + (eqt a4 :inherited) + (eqt sym1 sym4) + (eqt sym2 sym3) + (eqt (symbol-package sym1) pg) + (eqt (symbol-package sym2) ph) + (unuse-package pg ph) + (unuse-package ph pg)))) + (safely-delete-package pg) + (safely-delete-package ph)))) + t) + +;; Also: need to check that *PACKAGE* is used as a default + +(deftest use-package.error.1 + (classify-error (use-package)) + program-error) + +(deftest use-package.error.2 + (progn + (safely-delete-package "UPE2A") + (safely-delete-package "UPE2") + (make-package "UPE2" :use ()) + (make-package "UPE2A" :use ()) + (classify-error (use-package "UPE2" "UPE2A" nil))) + program-error) diff --git a/ansi-tests/packages-16.lsp b/ansi-tests/packages-16.lsp new file mode 100644 index 0000000..44a052a --- /dev/null +++ b/ansi-tests/packages-16.lsp @@ -0,0 +1,614 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 25 08:09:18 1998 +;;;; Contains: Package test code, part 16 + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; defpackage + +;; Test basic defpackage call, with no options +;; The use-list is implementation dependent, so +;; we don't examine it here. +;; Try several ways of specifying the package name. +(deftest defpackage.1 + (loop + for n in '("H" #:|H| #\H) count + (not + (progn + (safely-delete-package "H") + (let ((p (ignore-errors (eval `(defpackage ,n))))) + (and + (packagep p) + (equal (package-name p) "H") + ;; (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (equal (package-shadowing-symbols p) nil) + (null (documentation p t)) + ))))) + 0) + +;; Test :nicknames option +;; Do not check use-list, because it is implementation dependent +;; Try several ways of specifying a nickname. +(deftest defpackage.2 + (loop + for n in '("I" #:|I| #\I) count + (not + (ignore-errors + (progn + (safely-delete-package "H") + (let ((p (ignore-errors + (eval `(defpackage "H" (:nicknames ,n "J")))))) + (and + (packagep p) + (equal (package-name p) "H") + ;; (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (sort (copy-list (package-nicknames p)) + #'string<) + '("I" "J")) + (equal (package-shadowing-symbols p) nil) + (null (documentation p t)) + )))))) + 0) + +;; Test defpackage with documentation option +;; Do not check use-list, because it is implementation dependent +(deftest defpackage.3 + (progn + (safely-delete-package "H") + (ignore-errors + (let ((p (eval '(defpackage "H" (:documentation "This is a doc string"))))) + (and + (packagep p) + (equal (package-name p) "H") + ;; (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (equal (package-shadowing-symbols p) nil) + ;; The spec says implementations are free to discard + ;; documentations, so this next form was wrong. + ;; Instead, we'll just computation DOCUMENTATION + ;; and throw away the value. + ;; (equal (documentation p t) "This is a doc string") + (progn (documentation p t) t) + )))) + t) + +;; Check use argument +;; Try several ways of specifying the package to be used +(deftest defpackage.4 + (loop + for n in '("A" :|A| #\A) count + (not + (ignore-errors + (progn + (safely-delete-package "H") + (let ((p (ignore-errors (eval `(defpackage "H" (:use ,n)))))) + (and + (packagep p) + (equal (package-name p) "H") + (equal (package-use-list p) (list (find-package "A"))) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (equal (package-shadowing-symbols p) nil) + (eql (num-symbols-in-package p) + (num-external-symbols-in-package "A")) + (equal (documentation p t) nil) + )))))) + 0) + +;; Test defpackage shadow option, and null use +(deftest defpackage.5 + (progn + (safely-delete-package "H") + (ignore-errors + (let ((p (ignore-errors (eval `(defpackage "H" (:use) + (:shadow "foo")))))) + (mapcar + #'notnot + (list + (packagep p) + (equal (package-name p) "H") + (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (eql (num-symbols-in-package p) 1) + (multiple-value-bind* (sym access) + (find-symbol "foo" p) + (and (eqt access :internal) + (equal (symbol-name sym) "foo") + (equal (symbol-package sym) p) + (equal (package-shadowing-symbols p) + (list sym)))) + (equal (documentation p t) nil) + ))))) + (t t t t t t t t)) + +;; Test defpackage shadow and null use, with several ways +;; of specifying the name of the shadowed symbol +(deftest defpackage.6 + (loop + for s in '(:|f| #\f) + collect + (ignore-errors + (safely-delete-package "H") + (let ((p (ignore-errors (eval `(defpackage "H" + (:use) + (:shadow ,s)))))) + (mapcar + #'notnot + (list + (packagep p) + (equal (package-name p) "H") + (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (eql (num-symbols-in-package p) 1) + (multiple-value-bind* (sym access) + (find-symbol "f" p) + (and (eqt access :internal) + (equal (symbol-name sym) "f") + (equal (symbol-package sym) p) + (equal (package-shadowing-symbols p) + (list sym)))) + (equal (documentation p t) nil) + ))))) + ((t t t t t t t t) + (t t t t t t t t))) + + +;; Testing defpackage with shadowing-import-from. +;; Test several ways of specifying the symbol name +(deftest defpackage.7 + (progn + (safely-delete-package "H") + (safely-delete-package "G") + (let ((pg (make-package "G" :use nil))) + ;; Populate package G with several symbols + (export (intern "A" pg) pg) + (export (intern "foo" pg) pg) + (intern "bar" pg) + ;; Do test with several ways of specifying the + ;; shadowing-imported symbol + (loop + for n in '("A" :|A| #\A) + collect + (ignore-errors + (safely-delete-package "H") + (let ((p (ignore-errors + (eval + `(defpackage "H" + (:use) + (:shadowing-import-from "G" ,n)))))) + (mapcar + #'notnot + (list + (packagep p) + (equal (package-name p) "H") + (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (eql (num-symbols-in-package p) 1) + (multiple-value-bind* (sym access) + (find-symbol "A" p) + (and (eqt access :internal) + (equal (symbol-name sym) "A") + (equal (symbol-package sym) pg) + (equal (package-shadowing-symbols p) + (list sym)))) + (equal (documentation p t) nil) + ))))))) + ((t t t t t t t t) + (t t t t t t t t) + (t t t t t t t t))) + +;; Test import-from option +;; Test for each way of specifying the imported symbol name, +;; and for each way of specifying the package name from which +;; the symbol is imported +(deftest defpackage.8 + (progn + (safely-delete-package "H") + (safely-delete-package "G") + (let ((pg (eval '(defpackage "G" (:use) (:intern "A" "B" "C"))))) + (loop + for pn in '("G" #:|G| #\G) + collect + (loop + for n in '("B" #:|B| #\B) + collect + (ignore-errors + (safely-delete-package "H") + (let ((p (ignore-errors + (eval `(defpackage + "H" (:use) + (:import-from ,pn ,n "A")))))) + (mapcar + #'notnot + (list + (packagep p) + (equal (package-name p) "H") + (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (equal (package-shadowing-symbols p) nil) + (eql (num-symbols-in-package p) 2) + (multiple-value-bind* (sym access) + (find-symbol "A" p) + (and (eqt access :internal) + (equal (symbol-name sym) "A") + (equal (symbol-package sym) pg))) + (multiple-value-bind* (sym access) + (find-symbol "B" p) + (and (eqt access :internal) + (equal (symbol-name sym) "B") + (equal (symbol-package sym) pg))) + (equal (documentation p t) nil) + )))))))) + (((t t t t t t t t t t) (t t t t t t t t t t) (t t t t t t t t t t)) + ((t t t t t t t t t t) (t t t t t t t t t t) (t t t t t t t t t t)) + ((t t t t t t t t t t) (t t t t t t t t t t) (t t t t t t t t t t)))) + +;; Test defpackage with export option + +(deftest defpackage.9 + (progn + (loop + for n in '("Z" #:|Z| #\Z) + collect + (ignore-errors + (safely-delete-package "H") + (let ((p (ignore-errors + (eval `(defpackage + "H" + (:export "Q" ,n "R") (:use)))))) + (mapcar + #'notnot + (list + (packagep p) + (equal (package-name p) "H") + (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (equal (package-shadowing-symbols p) nil) + (eql (num-symbols-in-package p) 3) + (loop + for s in '("Q" "Z" "R") do + (unless + (multiple-value-bind* (sym access) + (find-symbol s p) + (and (eqt access :external) + (equal (symbol-name sym) s) + (equal (symbol-package sym) p))) + (return nil)) + finally (return t)) + )))))) + ((t t t t t t t t)(t t t t t t t t)(t t t t t t t t))) + +;; Test defpackage with the intern option + +(deftest defpackage.10 + (progn + (loop + for n in '("Z" #:|Z| #\Z) + collect + (ignore-errors + (safely-delete-package "H") + (let ((p (ignore-errors + (eval `(defpackage + "H" + (:intern "Q" ,n "R") (:use)))))) + (mapcar + #'notnot + (list + (packagep p) + (equal (package-name p) "H") + (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (equal (package-shadowing-symbols p) nil) + (eql (num-symbols-in-package p) 3) + (loop + for s in '("Q" "Z" "R") do + (unless + (multiple-value-bind* (sym access) + (find-symbol s p) + (and (eqt access :internal) + (equal (symbol-name sym) s) + (equal (symbol-package sym) p))) + (return nil)) + finally (return t)) + )))))) + ((t t t t t t t t) (t t t t t t t t) (t t t t t t t t))) + +;; Test defpackage with size + +(deftest defpackage.11 + (ignore-errors + (safely-delete-package "H") + (let ((p (ignore-errors + (eval '(defpackage "H" (:use) (:size 0)))))) + (mapcar + #'notnot + (list + (packagep p) + (equal (package-name p) "H") + (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (equal (package-shadowing-symbols p) nil) + (zerop (num-symbols-in-package p)))))) + (t t t t t t t)) + +(deftest defpackage.12 + (ignore-errors + (safely-delete-package "H") + (let ((p (ignore-errors + (eval '(defpackage "H" (:use) (:size 10000)))))) + (mapcar + #'notnot + (list + (packagep p) + (equal (package-name p) "H") + (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (equal (package-shadowing-symbols p) nil) + (zerop (num-symbols-in-package p)))))) + (t t t t t t t)) + +;; defpackage error handling + +;; Repeated size field should cause a program-error +(deftest defpackage.13 + (progn + (safely-delete-package "H") + (classify-error + (eval '(defpackage "H" (:use) (:size 10) (:size 20))))) + program-error) + +;; Repeated documentation field should cause a program-error +(deftest defpackage.14 + (progn + (safely-delete-package "H") + (classify-error + (eval '(defpackage "H" (:use) + (:documentation "foo") + (:documentation "bar"))))) + program-error) + +;; When a nickname refers to an existing package or nickname, +;; signal a package-error + +(deftest defpackage.15 + (progn + (safely-delete-package "H") + (classify-error + (eval '(defpackage "H" (:use) + (:nicknames "A"))))) + package-error) + +(deftest defpackage.16 + (progn + (safely-delete-package "H") + (classify-error + (eval '(defpackage "H" (:use) + (:nicknames "Q"))))) + package-error) + +;; Names in :shadow, :shadowing-import-from, :import-from, and :intern +;; must be disjoint, or a package-error is signalled. + +;; :shadow and :shadowing-import-from +(deftest defpackage.17 + (progn + (safely-delete-package "H") + (safely-delete-package "G") + (eval '(defpackage "G" (:use) (:export "A"))) + (classify-error + (eval '(defpackage "H" (:use) + (:shadow "A") + (:shadowing-import-from "G" "A"))))) + program-error) + +;; :shadow and :import-from +(deftest defpackage.18 + (progn + (safely-delete-package "H") + (safely-delete-package "G") + (eval '(defpackage "G" (:use) (:export "A"))) + (classify-error + (eval '(defpackage "H" (:use) + (:shadow "A") + (:import-from "G" "A"))))) + program-error) + +;; :shadow and :intern +(deftest defpackage.19 + (progn + (safely-delete-package "H") + (classify-error + (eval '(defpackage "H" (:use) + (:shadow "A") + (:intern "A"))))) + program-error) + +;; :shadowing-import-from and :import-from +(deftest defpackage.20 + (progn + (safely-delete-package "H") + (safely-delete-package "G") + (eval '(defpackage "G" (:use) (:export "A"))) + (classify-error + (eval '(defpackage "H" (:use) + (:shadowing-import-from "G" "A") + (:import-from "G" "A"))))) + program-error) + +;; :shadowing-import-from and :intern +(deftest defpackage.21 + (progn + (safely-delete-package "H") + (safely-delete-package "G") + (eval '(defpackage "G" (:use) (:export "A"))) + (classify-error + (eval '(defpackage "H" (:use) + (:shadowing-import-from "G" "A") + (:intern "A"))))) + program-error) + +;; :import-from and :intern +(deftest defpackage.22 + (progn + (safely-delete-package "H") + (safely-delete-package "G") + (eval '(defpackage "G" (:use) (:export "A"))) + (classify-error + (eval '(defpackage "H" (:use) + (:import-from "G" "A") + (:intern "A"))))) + program-error) + +;; Names given to :export and :intern must be disjoint, +;; otherwise signal a program-error +(deftest defpackage.23 + (progn + (safely-delete-package "H") + (classify-error + (eval '(defpackage "H" (:use) + (:export "A") + (:intern "A"))))) + program-error) + +;; :shadowing-import-from signals a correctable package-error +;; if the symbol is not accessible in the named package +(deftest defpackage.24 + (progn + (safely-delete-package "H") + (safely-delete-package "G") + (eval '(defpackage "G" (:use))) + (handle-non-abort-restart + (eval '(defpackage "H" (:shadowing-import-from + "G" "NOT-THERE"))))) + success) + +;; :import-from signals a correctable package-error if a symbol with +;; the indicated name is not accessible in the package indicated + +(deftest defpackage.25 + (progn + (safely-delete-package "H") + (safely-delete-package "G") + (eval '(defpackage "G" (:use))) + (handle-non-abort-restart + (eval '(defpackage "H" (:import-from "G" "NOT-THERE"))))) + success) + +;; A big test that combines all the options to defpackage + +(deftest defpackage.26 + (ignore-errors + (flet + ((%do-it% + (args) + (safely-delete-package "H") + (safely-delete-package "G1") + (safely-delete-package "G2") + (safely-delete-package "G3") + (let ((pg1 + (progn + (format t "Making G1...~%") + (eval '(defpackage "G1" + (:use) + (:export "A" "B" "C") + (:intern "D" "E" "F"))))) + (pg2 + (progn + (format t "Making G2...~%") + (eval '(defpackage "G2" + (:use) + (:export "A" "D" "G") + (:intern "E" "H" "I"))))) + (pg3 + (progn + (format t "Making G3...~%") + (eval '(defpackage "G3" + (:use) + (:export "J" "K" "L") + (:intern "M" "N" "O")))))) + (let ((p (eval (list* 'defpackage "H" (copy-tree args))))) + (prog + () + (unless (packagep p) (return 1)) + (unless (equal (package-name p) "H") (return 2)) + (unless (equal (package-name pg1) "G1") (return 3)) + (unless (equal (package-name pg2) "G2") (return 4)) + (unless (equal (package-name pg3) "G3") (return 5)) + (unless + (equal (sort (copy-list (package-nicknames p)) #'string<) + '("H1" "H2")) + (return 6)) + (unless + (or + (equal (package-use-list p) (list pg1 pg2)) + (equal (package-use-list p) (list pg2 pg1))) + (return 7)) + (unless (equal (package-used-by-list pg1) (list p)) + (return 8)) + (unless (equal (package-used-by-list pg2) (list p)) + (return 9)) + (when (package-used-by-list pg3) (return 10)) + (unless (equal (sort (mapcar #'symbol-name + (package-shadowing-symbols p)) + #'string<) + '("A" "B")) + (return 10)) + (let ((num 11)) + (unless + (every + #'(lambda (str acc pkg) + (multiple-value-bind* + (sym access) + (find-symbol str p) + (or + (and (or (not acc) (equal (symbol-name sym) str)) + (or (not acc) (equal (symbol-package sym) pkg)) + (equal access acc) + (incf num)) + (progn + (format t + "Failed on str = ~S, acc = ~S, pkg = ~S, sym = ~S, access = ~S~%" + str acc pkg sym access) + nil)))) + (list "A" "B" "C" "D" "E" "F" "G" + "H" "I" "J" "K" "L" "M" "N" "O") + (list :internal :internal + :external :inherited + nil nil + :inherited :internal + nil nil + nil :external + nil nil + :internal) + (list pg2 p pg1 pg2 nil nil + pg2 p nil nil nil pg3 + nil nil pg3)) + (return num))) + (return 'success)))))) + (let ((args '((:nicknames "H1" "H2") + (:use "G1" "G2") + (:shadow "B") + (:shadowing-import-from "G2" "A") + (:import-from "G3" "L" "O") + (:intern "D" "H") + (:export "L" "C") + (:size 20) + (:documentation "A test package")))) + (list (%do-it% args) + (%do-it% (reverse args)))))) + (success success)) diff --git a/ansi-tests/packages-17.lsp b/ansi-tests/packages-17.lsp new file mode 100644 index 0000000..2555f7b --- /dev/null +++ b/ansi-tests/packages-17.lsp @@ -0,0 +1,145 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 25 19:20:29 1998 +;;;; Contains: Package test code, part 17 + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +(deftest do-symbols.1 + (equalt + (remove-duplicates + (sort-symbols (let ((all nil)) + (do-symbols (x "B" all) (push x all))))) + (list (find-symbol "BAR" "B") + (find-symbol "FOO" "A"))) + t) + +;; +;; Test up some test packages +;; + +(defun collect-symbols (pkg) + (remove-duplicates + (sort-symbols + (let ((all nil)) + (do-symbols (x pkg all) (push x all)))))) + +(defun collect-external-symbols (pkg) + (remove-duplicates + (sort-symbols + (let ((all nil)) + (do-external-symbols (x pkg all) (push x all)))))) + +(deftest do-symbols.2 + (collect-symbols "DS1") + (DS1:A DS1:B DS1::C DS1::D)) + +(deftest do-symbols.3 + (collect-symbols "DS2") + (DS2:A DS2::E DS2::F DS2:G DS2:H)) + +(deftest do-symbols.4 + (collect-symbols "DS3") + (DS1:A DS3:B DS2:G DS2:H DS3:I DS3:J DS3:K DS3::L DS3::M)) + +(deftest do-symbols.5 + (remove-duplicates + (collect-symbols "DS4") + :test #'(lambda (x y) + (and (eqt x y) + (not (eqt x 'DS4::B))))) + (DS1:A DS1:B DS2::F DS3:G DS3:I DS3:J DS3:K DS4::X DS4::Y DS4::Z)) + + +(deftest do-external-symbols.1 + (collect-external-symbols "DS1") + (DS1:A DS1:B)) + +(deftest do-external-symbols.2 + (collect-external-symbols "DS2") + (DS2:A DS2:G DS2:H)) + +(deftest do-external-symbols.3 + (collect-external-symbols "DS3") + (DS1:A DS3:B DS2:G DS3:I DS3:J DS3:K)) + +(deftest do-external-symbols.4 + (collect-external-symbols "DS4") + ()) + +(deftest do-external-symbols.5 + (equalt (collect-external-symbols "KEYWORD") + (collect-symbols "KEYWORD")) + t) + +;; Test that do-symbols, do-external-symbols work without +;; a return value (and that the default return value is nil) + +(deftest do-symbols.6 + (do-symbols (s "DS1") (declare (ignore s)) t) + nil) + +(deftest do-external-symbols.6 + (do-external-symbols (s "DS1") (declare (ignore s)) t) + nil) + +;; Test that do-symbols, do-external-symbols work without +;; a package being specified + +(deftest do-symbols.7 + (let ((x nil) + (*package* (find-package "DS1"))) + (declare (special *package*)) + (list + (do-symbols (s) (push s x)) + (sort-symbols x))) + (nil (DS1:A DS1:B DS1::C DS1::D))) + +(deftest do-external-symbols.7 + (let ((x nil) + (*package* (find-package "DS1"))) + (declare (special *package*)) + (list + (do-external-symbols (s) (push s x)) + (sort-symbols x))) + (nil (DS1:A DS1:B))) + +;; Test that the tags work in the tagbody, +;; and that multiple statements work + +(deftest do-symbols.8 + (handler-case + (let ((x nil)) + (list + (do-symbols + (s "DS1") + (when (equalt (symbol-name s) "C") (go bar)) + (push s x) + (go foo) + bar + (push t x) + foo) + (sort-symbols x))) + (error (c) c)) + (NIL (DS1:A DS1:B DS1::D T))) + +(deftest do-external-symbols.8 + (handler-case + (let ((x nil)) + (list + (do-external-symbols + (s "DS1") + (when (equalt (symbol-name s) "A") (go bar)) + (push s x) + (go foo) + bar + (push t x) + foo) + (sort-symbols x))) + (error (c) c)) + (NIL (DS1:B T))) + + + + diff --git a/ansi-tests/packages-18.lsp b/ansi-tests/packages-18.lsp new file mode 100644 index 0000000..2fd03b2 --- /dev/null +++ b/ansi-tests/packages-18.lsp @@ -0,0 +1,106 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 25 08:07:31 1998 +;;;; Contains: Package test code, part 18 + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +(declaim (special *universe*)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; packagep, typep * 'package + +(deftest packagep.1 + (loop + for x in *universe* count + (unless (eqt (not (packagep x)) + (not (typep x 'package))) + (format t + "(packagep ~S) = ~S, (typep x 'package) = ~S~%" + x (packagep x) x (typep x 'package)) + t)) + 0) + +;;; *package* is always a package + +(deftest packagep.2 + (not-mv (packagep *package*)) + nil) + +(deftest packagep.error.1 + (classify-error (packagep)) + program-error) + +(deftest packagep.error.2 + (classify-error (packagep nil nil)) + program-error) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; package-error + +(deftest package-error.1 + (not + (typep (make-condition 'package-error :package "CL") + 'package-error)) + nil) + +(deftest package-error.2 + (not + (typep (make-condition 'package-error + :package (find-package "CL")) + 'package-error)) + nil) + +(deftest package-error.3 + (subtypep* 'package-error 'error) + t t) + +(deftest package-error.4 + (not + (typep (make-condition 'package-error + :package (find-package '#:|CL|)) + 'package-error)) + nil) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; package-error-package + +(deftest package-error-package.1 + (eqt (find-package (package-error-package + (make-condition 'package-error + :package "CL"))) + (find-package "CL")) + t) + +(deftest package-error-package.2 + (eqt (find-package (package-error-package + (make-condition 'package-error + :package (find-package "CL")))) + (find-package "CL")) + t) + +(deftest package-error-package.3 + (eqt (find-package (package-error-package + (make-condition 'package-error + :package '#:|CL|))) + (find-package "CL")) + t) + +(deftest package-error-package.4 + (eqt (find-package (package-error-package + (make-condition 'package-error + :package #\A))) + (find-package "A")) + t) + +(deftest package-error-package.error.1 + (classify-error (package-error-package)) + program-error) + +(deftest package-error-package.error.2 + (classify-error + (package-error-package + (make-condition 'package-error :package #\A) + nil)) + program-error) diff --git a/ansi-tests/packages-19.lsp b/ansi-tests/packages-19.lsp new file mode 100644 index 0000000..be4b3b7 --- /dev/null +++ b/ansi-tests/packages-19.lsp @@ -0,0 +1,61 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue May 5 17:22:49 1998 +;;;; Contains: Packages test code, part 19. Tests of the keyword package. +;;;; See also cl-symbols.lsp (for keywordp test cases) + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +;; Check that each keyword satisfies keywordp + +(deftest keyword.1 + (do-symbols (s "KEYWORD" t) + (unless (keywordp s) + (return (list s nil)))) + t) + +;; Every keyword is external +(deftest keyword.2 + (do-symbols (s "KEYWORD" t) + (multiple-value-bind (s2 access) + (find-symbol (symbol-name s) "KEYWORD") + (unless (and (eqt s s2) + (eqt access :external)) + (return (list s2 access))))) + t) + +;; Every keyword evaluates to itself +(deftest keyword.3 + (do-symbols (s "KEYWORD" t) + (unless (eqt s (eval s)) + (return (list s (eval s))))) + t) + + +;;; Other error tests + +(deftest package-shadowing-symbols.error.1 + (classify-error (package-shadowing-symbols)) + program-error) + +(deftest package-shadowing-symbols.error.2 + (classify-error (package-shadowing-symbols "CL" nil)) + program-error) + +(deftest package-use-list.error.1 + (classify-error (package-use-list)) + program-error) + +(deftest package-use-list.error.2 + (classify-error (package-use-list "CL" nil)) + program-error) + +(deftest package-used-by-list.error.1 + (classify-error (package-used-by-list)) + program-error) + +(deftest package-used-by-list.error.2 + (classify-error (package-used-by-list "CL" nil)) + program-error) + diff --git a/ansi-tests/packages.lsp b/ansi-tests/packages.lsp new file mode 100644 index 0000000..dc6b38e --- /dev/null +++ b/ansi-tests/packages.lsp @@ -0,0 +1,26 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Oct 6 00:32:56 2002 +;;;; Contains: Loader for files containing package tests + + +(load "packages-00.lsp") +(load "packages-01.lsp") +(load "packages-02.lsp") +(load "packages-03.lsp") +(load "packages-04.lsp") +(load "packages-05.lsp") +(load "packages-06.lsp") +(load "packages-07.lsp") +(load "packages-08.lsp") +(load "packages-09.lsp") +(load "packages-10.lsp") +(load "packages-11.lsp") +(load "packages-12.lsp") +(load "packages-13.lsp") +(load "packages-14.lsp") +(load "packages-15.lsp") +(load "packages-16.lsp") +(load "packages-17.lsp") +(load "packages-18.lsp") +(load "packages-19.lsp") diff --git a/ansi-tests/places.lsp b/ansi-tests/places.lsp new file mode 100644 index 0000000..caf7815 --- /dev/null +++ b/ansi-tests/places.lsp @@ -0,0 +1,467 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Mon Oct 7 19:20:17 2002 +;;;; Contains: Tests of various kinds of places (section 5.1) + +(in-package :cl-test) + +;;; Section 5.1.1.1 +(deftest setf-order + (let ((x (vector nil nil nil nil)) + (i 0)) + (setf (aref x (incf i)) (incf i)) + (values x i)) + #(nil 2 nil nil) 2) + +(deftest setf-order.2 + (let ((x (vector nil nil nil nil)) + (i 0)) + (setf (aref x (incf i)) (incf i) + (aref x (incf i)) (incf i 10)) + (values x i)) + #(nil 2 nil 13) 13) + +(deftest push-order + (let ((x (vector nil nil nil nil)) + (y (vector 'a 'b 'c 'd)) + (i 1)) + (push (aref y (incf i)) (aref x (incf i))) + (values x y i)) + #(nil nil nil (c)) + #(a b c d) + 3) + +(deftest pushnew-order + (let ((x (vector nil nil nil nil)) + (y (vector 'a 'b 'c 'd)) + (i 1)) + (pushnew (aref y (incf i)) (aref x (incf i))) + (values x y i)) + #(nil nil nil (c)) + #(a b c d) + 3) + +(deftest pushnew-order.2 + (let ((x (vector nil nil nil nil nil)) + (y (vector 'a 'b 'c 'd 'e)) + (i 1)) + (pushnew (aref y (incf i)) (aref x (incf i)) + :test (progn (incf i) #'eql)) + (values x y i)) + #(nil nil nil (c) nil) + #(a b c d e) + 4) + +(deftest remf-order + (let ((x (copy-seq #(nil :a :b))) + (pa (vector (list :a 1) (list :b 2) (list :c 3) (list :d 4))) + (i 0)) + (values + (not (remf (aref pa (incf i)) (aref x (incf i)))) + pa)) + nil #((:a 1) nil (:c 3) (:d 4))) + +(deftest incf-order + (let ((x (copy-seq #(0 0 0 0 0))) + (i 1)) + (values + (incf (aref x (incf i)) (incf i)) + x i)) + 3 #(0 0 3 0 0) 3) + +(deftest decf-order + (let ((x (copy-seq #(0 0 0 0 0))) + (i 1)) + (values + (decf (aref x (incf i)) (incf i)) + x i)) + -3 #(0 0 -3 0 0) 3) + +(deftest shiftf-order.1 + (let ((x (vector 'a 'b 'c 'd 'e)) + (i 2)) + (values (shiftf (aref x (incf i)) (incf i)) x i)) + d #(a b c 4 e) 4) + +(deftest shiftf-order.2 + (let ((x (vector 'a 'b 'c 'd 'e 'f 'g 'h)) + (i 2)) + (values (shiftf (aref x (incf i)) (aref x (incf i)) (incf i)) x i)) + d #(a b c e 5 f g h) 5) + +(deftest rotatef-order.1 + (let ((x (vector 'a 'b 'c 'd 'e 'f)) + (i 2)) + (values + (rotatef (aref x (incf i)) (aref x (incf i))) + x i)) + nil + #(a b c e d f) + 4) + +(deftest rotatef-order.2 + (let ((x (vector 'a 'b 'c 'd 'e 'f)) + (i 2)) + (values + (rotatef (aref x (incf i)) (aref x (incf i)) (aref x (incf i))) + x i)) + nil + #(a b c e f d) + 5) + +(deftest psetf-order + (let ((x (vector nil nil nil nil)) + (i 0)) + (psetf (aref x (incf i)) (incf i)) + (values x i)) + #(nil 2 nil nil) 2) + +(deftest psetf-order.2 + (let ((x (vector nil nil nil nil)) + (i 0)) + (psetf (aref x (incf i)) (incf i) + (aref x (incf i)) (incf i 10)) + (values x i)) + #(nil 2 nil 13) 13) + +(deftest pop-order + (let ((x (vector '(a b) '(c d) '(e f))) + (i 0)) + (values (pop (aref x (incf i))) x i)) + c #((a b) (d) (e f)) 1) + + +;;; Section 5.1.2.1 +(deftest setf-var + (let ((x nil)) + (setf x 'a) + x) + a) + +;;; Section 5.1.2.2 +;;; See SETF forms at various accessor functions + +;;; Section 5.1.2.3 +(deftest setf-values.1 + (let ((x nil) (y nil) (z nil)) + (setf (values x y z) (values 1 2 3))) + 1 2 3) + +(deftest setf-values.2 + (let ((x nil) (y nil) (z nil)) + (setf (values x y z) (values 1 2 3)) + (values z y x)) + 3 2 1) + +(deftest setf-values.3 + (let ((x nil) (y nil) (z nil)) + (setf (values x x x) (values 1 2 3)) + x) + 3) + +;;; Test that the subplaces of a VALUES place can be +;;; complex, and that the various places' subforms are +;;; evaluated in the correct (left-to-right) order. + +(deftest setf-values.4 + (let ((x (list 'a 'b))) + (setf (values (car x) (cadr x)) (values 1 2)) + x) + (1 2)) + +(deftest setf-values.5 + (let ((a (vector nil nil)) + (i 0) + x y z) + (setf (values (aref a (progn (setf x (incf i)) 0)) + (aref a (progn (setf y (incf i)) 1))) + (progn + (setf z (incf i)) + (values 'foo 'bar))) + (values a i x y z)) + #(foo bar) 3 1 2 3) + +(deftest setf-values.6 + (setf (values) (values))) + +;;; Section 5.1.2.4 +(deftest setf-the.1 + (let ((x 1)) + (setf (the integer x) 2) + x) + 2) + +(deftest setf-the.2 + (let ((x (list 'a))) + (values + (setf (the symbol (car x)) 'b) + x)) + b (b)) + +;;; Section 5.1.2.5 +(deftest setf-apply.1 + (let ((x (vector 0 1 2 3 4 5))) + (setf (apply #'aref x '(0)) 10) + x) + #(10 1 2 3 4 5)) + +(deftest setf-apply.2 + (let ((a (make-array '(2 2) :initial-contents '((0 0)(0 0))))) + (setf (apply #'aref a 1 1 nil) 'a) + (equalp a (make-array '(2 2) :initial-contents '((0 0)(0 a))))) + t) + +(deftest setf-apply.3 + (let ((bv (copy-seq #*0000000000))) + (setf (apply #'bit bv 4 nil) 1) + bv) + #*0000100000) + +(deftest setf-apply.4 + (let ((bv (copy-seq #*0000000000))) + (setf (apply #'sbit bv 4 nil) 1) + bv) + #*0000100000) + +;;; Section 5.1.2.6 +(defun accessor-5-1-2-6-update-fn (x y) + (setf (car x) y) + y) + +(defsetf accessor-5-1-2-6 accessor-5-1-2-6-update-fn) + +(deftest setf-expander.1 + (let ((x (list 1))) + (values (setf (accessor-5-1-2-6 x) 2) + (1+ (car x)))) + 2 3) + +;;; Section 5.1.2.7 + +(defmacro accessor-5-1-2-7 (x) `(car ,x)) +(deftest setf-macro.1 + (let ((x (list 1))) + (values (setf (accessor-5-1-2-7 x) 2) + (1+ (car x)))) + 2 3) + +(defun accessor-5-1-2-7a-update-fn (x y) + (declare (special *x*)) + (setf (car x) y) + (setf *x* 'boo) + y) + +(defmacro accessor-5-1-2-7a (x) `(car ,x)) +(defsetf accessor-5-1-2-7a accessor-5-1-2-7a-update-fn) +;; Test that the defsetf override the macro expansion +(deftest setf-macro.2 + (let ((x (list 1)) + (*x* nil)) + (declare (special *x*)) + (values (setf (accessor-5-1-2-7a x) 2) + *x* + (1+ (car x)))) + 2 boo 3) + +(defmacro accessor-5-1-2-7b (x) `(accessor-5-1-2-7 ,x)) +;; Test that the macroexpansion occurs more than once +(deftest setf-macro.3 + (let ((x (list 1))) + (values (setf (accessor-5-1-2-7b x) 2) + (1+ (car x)))) + 2 3) + +;; Macroexpansion from a macrolet +(deftest setf-macro.4 + (macrolet ((%m (y) `(car ,y))) + (let ((x (list 1))) + (values (setf (%m x) 2) + (1+ (car x))))) + 2 3) + +;;; section 5.1.2.8 -- symbol macros +(deftest setf-symbol-macro.1 + (symbol-macrolet ((x y)) + (let ((y nil)) + (values (setf x 1) x y))) + 1 1 1) + +;;; Symbol macros in SETQs are treated as if the form were a SETF +(deftest setf-symbol-macro.2 + (symbol-macrolet ((x y)) + (let ((y nil)) + (values (setq x 1) x y))) + 1 1 1) + +;;; Tests that, being treated like SETF, this causes multiple values +;;; to be assigned to (values y z) +(deftest setf-symbol-macro.3 + (symbol-macrolet ((x (values y z))) + (let ((y nil) (z nil)) + (values (setq x (values 1 2)) x y z))) + 1 1 1 2) + +(deftest setq.1 + (setq) + nil) + +(deftest setq.2 + (let ((x 0) (y 0)) + (values (setq x 1 y 2) x y)) + 2 1 2) + +(deftest setq.3 + (let ((x 0) (y 0)) + (values (setq x (values 1 3) y (values 2 4)) x y)) + 2 1 2) + +(deftest setq.4 + (let (x) (setq x (values 1 2))) + 1) + +(deftest setf.1 + (setf) + nil) + +(deftest setf.2 + (let ((x 0) (y 0)) + (values (setf x 1 y 2) x y)) + 2 1 2) + +(deftest setf.3 + (let ((x 0) (y 0)) + (values (setf x (values 1 3) y (values 2 4)) x y)) + 2 1 2) + +(deftest setf.4 + (let (x) (setf x (values 1 2))) + 1) + +;;; Tests of PSETQ + +(deftest psetq.1 + (psetq) + nil) + +(deftest psetq.2 + (let ((x 0)) + (values (psetq x 1) x)) + nil 1) + +(deftest psetq.3 + (let ((x 0) (y 1)) + (values (psetq x y y x) x y)) + nil 1 0) + +(deftest psetq.4 + (let ((x 0)) + (values + (symbol-macrolet ((x y)) + (let ((y 1)) + (psetq x 2) + y)) + x)) + 2 0) + +(deftest psetq.5 + (let ((w (list nil))) + (values + (symbol-macrolet ((x (car w))) + (psetq x 2)) + w)) + nil (2)) + +(deftest psetq.6 + (let ((c 0) x y) + (psetq x (incf c) + y (incf c)) + (values c x y)) + 2 1 2) + +;;; The next test is a PSETQ that is equivalent to a PSETF +;;; See PSETF.7 for comments related to this test. + +(deftest psetq.7 + (symbol-macrolet ((x (aref a (incf i))) + (y (aref a (incf i)))) + (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9))) + (i 0)) + (psetq x (aref a (incf i)) + y (aref a (incf i))) + (values a i))) + #(0 2 2 4 4 5 6 7 8 9) + 4) + +;;; Tests of PSETF + +(deftest psetf.1 + (psetf) + nil) + +(deftest psetf.2 + (let ((x 0)) + (values (psetf x 1) x)) + nil 1) + +(deftest psetf.3 + (let ((x 0) (y 1)) + (values (psetf x y y x) x y)) + nil 1 0) + +(deftest psetf.4 + (let ((x 0)) + (values + (symbol-macrolet ((x y)) + (let ((y 1)) + (psetf x 2) + y)) + x)) + 2 0) + +(deftest psetf.5 + (let ((w (list nil))) + (values + (symbol-macrolet ((x (car w))) + (psetf x 2)) + w)) + nil (2)) + +(deftest psetf.6 + (let ((c 0) x y) + (psetf x (incf c) + y (incf c)) + (values c x y)) + 2 1 2) + +;;; According to the standard, the forms to be assigned and +;;; the subforms in the places to be assigned to are evaluated +;;; from left to right. Therefore, PSETF.7 and PSETF.8 should +;;; do the same thing to A as PSETF.9 does. +;;; (See the page for PSETF) + +(deftest psetf.7 + (symbol-macrolet ((x (aref a (incf i))) + (y (aref a (incf i)))) + (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9))) + (i 0)) + (psetf x (aref a (incf i)) + y (aref a (incf i))) + (values a i))) + #(0 2 2 4 4 5 6 7 8 9) + 4) + +(deftest psetf.8 + (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9))) + (i 0)) + (psetf (aref a (incf i)) (aref a (incf i)) + (aref a (incf i)) (aref a (incf i))) + (values a i)) + #(0 2 2 4 4 5 6 7 8 9) + 4) + +(deftest psetf.9 + (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9)))) + (psetf (aref a 1) (aref a 2) + (aref a 3) (aref a 4)) + a) + #(0 2 2 4 4 5 6 7 8 9)) diff --git a/ansi-tests/position-if-not.lsp b/ansi-tests/position-if-not.lsp new file mode 100644 index 0000000..00b1d7d --- /dev/null +++ b/ansi-tests/position-if-not.lsp @@ -0,0 +1,575 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Aug 24 07:10:05 2002 +;;;; Contains: Tests for POSITION-IF-NOT-NOT + +(in-package :cl-test) + +(deftest position-if-not-list.1 + (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9)) + 3) + +(deftest position-if-not-list.2 + (position-if-not 'oddp '(1 3 1 4 3 2 1 8 9)) + 3) + +(deftest position-if-not-list.3 + (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :start 4) + 5) + +(deftest position-if-not-list.4 + (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :from-end t) + 7) + +(deftest position-if-not-list.5 + (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :from-end nil) + 3) + +(deftest position-if-not-list.6 + (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :start 4 + :from-end t) + 7) + +(deftest position-if-not-list.7 + (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :end nil) + 3) + +(deftest position-if-not-list.8 + (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :end 3) + nil) + +(deftest position-if-not-list.9 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :start i :end j))) + ((nil nil nil 3 3 3 3 3 3) + (nil nil 3 3 3 3 3 3) + (nil 3 3 3 3 3 3) + (3 3 3 3 3 3) + (nil 5 5 5 5) + (5 5 5 5) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-not-list.10 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :start i :end j + :from-end t))) + ((nil nil nil 3 3 5 5 7 7) + (nil nil 3 3 5 5 7 7) + (nil 3 3 5 5 7 7) + (3 3 5 5 7 7) + (nil 5 5 7 7) + (5 5 7 7) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-not-list.11 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'evenp '(1 3 1 4 3 2 1 8 9) :start i :end j + :key '1+))) + ((nil nil nil 3 3 3 3 3 3) + (nil nil 3 3 3 3 3 3) + (nil 3 3 3 3 3 3) + (3 3 3 3 3 3) + (nil 5 5 5 5) + (5 5 5 5) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-not-list.12 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'evenp '(1 3 1 4 3 2 1 8 9) :start i :end j + :key #'1+ :from-end t))) + ((nil nil nil 3 3 5 5 7 7) + (nil nil 3 3 5 5 7 7) + (nil 3 3 5 5 7 7) + (3 3 5 5 7 7) + (nil 5 5 7 7) + (5 5 7 7) + (nil 7 7) + (7 7) + (nil))) + +;;; Vector tests + +(deftest position-if-not-vector.1 + (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9)) + 3) + +(deftest position-if-not-vector.2 + (position-if-not 'oddp #(1 3 1 4 3 2 1 8 9)) + 3) + +(deftest position-if-not-vector.3 + (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :start 4) + 5) + +(deftest position-if-not-vector.4 + (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :from-end t) + 7) + +(deftest position-if-not-vector.5 + (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :from-end nil) + 3) + +(deftest position-if-not-vector.6 + (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :start 4 + :from-end t) + 7) + +(deftest position-if-not-vector.7 + (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :end nil) + 3) + +(deftest position-if-not-vector.8 + (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :end 3) + nil) + +(deftest position-if-not-vector.9 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :start i :end j))) + ((nil nil nil 3 3 3 3 3 3) + (nil nil 3 3 3 3 3 3) + (nil 3 3 3 3 3 3) + (3 3 3 3 3 3) + (nil 5 5 5 5) + (5 5 5 5) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-not-vector.10 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :start i :end j + :from-end t))) + ((nil nil nil 3 3 5 5 7 7) + (nil nil 3 3 5 5 7 7) + (nil 3 3 5 5 7 7) + (3 3 5 5 7 7) + (nil 5 5 7 7) + (5 5 7 7) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-not-vector.11 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'evenp #(1 3 1 4 3 2 1 8 9) :start i :end j + :key '1+))) + ((nil nil nil 3 3 3 3 3 3) + (nil nil 3 3 3 3 3 3) + (nil 3 3 3 3 3 3) + (3 3 3 3 3 3) + (nil 5 5 5 5) + (5 5 5 5) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-not-vector.12 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'evenp #(1 3 1 4 3 2 1 8 9) :start i :end j + :key #'1+ :from-end t))) + ((nil nil nil 3 3 5 5 7 7) + (nil nil 3 3 5 5 7 7) + (nil 3 3 5 5 7 7) + (3 3 5 5 7 7) + (nil 5 5 7 7) + (5 5 7 7) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-not-vector.13 + (let ((a (make-array '(10) :initial-contents '(1 2 3 4 5 a b c d e) + :fill-pointer 5))) + (values + (position-if-not #'numberp a) + (position-if-not #'symbolp a) + (position-if-not #'numberp a :from-end t) + (position-if-not #'symbolp a :from-end t))) + nil 0 nil 4) + +;;; Bit vector tests + +(deftest position-if-not-bit-vector.1 + (position-if-not #'oddp #*111010101) + 3) + +(deftest position-if-not-bit-vector.2 + (position-if-not 'oddp #*111010101) + 3) + +(deftest position-if-not-bit-vector.3 + (position-if-not #'oddp #*111010101 :start 4) + 5) + +(deftest position-if-not-bit-vector.4 + (position-if-not #'oddp #*111010101 :from-end t) + 7) + +(deftest position-if-not-bit-vector.5 + (position-if-not #'oddp #*111010101 :from-end nil) + 3) + +(deftest position-if-not-bit-vector.6 + (position-if-not #'oddp #*111010101 :start 4 + :from-end t) + 7) + +(deftest position-if-not-bit-vector.7 + (position-if-not #'oddp #*111010101 :end nil) + 3) + +(deftest position-if-not-bit-vector.8 + (position-if-not #'oddp #*111010101 :end 3) + nil) + +(deftest position-if-not-bit-vector.9 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'oddp #*111010101 :start i :end j))) + ((nil nil nil 3 3 3 3 3 3) + (nil nil 3 3 3 3 3 3) + (nil 3 3 3 3 3 3) + (3 3 3 3 3 3) + (nil 5 5 5 5) + (5 5 5 5) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-not-bit-vector.10 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'oddp #*111010101 :start i :end j + :from-end t))) + ((nil nil nil 3 3 5 5 7 7) + (nil nil 3 3 5 5 7 7) + (nil 3 3 5 5 7 7) + (3 3 5 5 7 7) + (nil 5 5 7 7) + (5 5 7 7) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-not-bit-vector.11 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'evenp #*111010101 :start i :end j + :key #'1+))) + ((nil nil nil 3 3 3 3 3 3) + (nil nil 3 3 3 3 3 3) + (nil 3 3 3 3 3 3) + (3 3 3 3 3 3) + (nil 5 5 5 5) + (5 5 5 5) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-not-bit-vector.12 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'evenp #*111010101 :start i :end j + :key '1+ :from-end t))) + ((nil nil nil 3 3 5 5 7 7) + (nil nil 3 3 5 5 7 7) + (nil 3 3 5 5 7 7) + (3 3 5 5 7 7) + (nil 5 5 7 7) + (5 5 7 7) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-not-bit-vector.13 + (let ((a (make-array '(10) :initial-contents '(1 1 1 1 1 0 0 0 0 0) + :fill-pointer 5 + :element-type 'bit))) + (values + (position-if-not #'zerop a) + (position-if-not (complement #'zerop) a) + (position-if-not #'zerop a :from-end t) + (position-if-not (complement #'zerop) a :from-end t))) + 0 nil 4 nil) + +;;; string tests + +(deftest position-if-not-string.1 + (position-if-not #'odddigitp "131432189") + 3) + +(deftest position-if-not-string.2 + (position-if-not 'odddigitp "131432189") + 3) + +(deftest position-if-not-string.3 + (position-if-not #'odddigitp "131432189" :start 4) + 5) + +(deftest position-if-not-string.4 + (position-if-not #'odddigitp "131432189" :from-end t) + 7) + +(deftest position-if-not-string.5 + (position-if-not #'odddigitp "131432189" :from-end nil) + 3) + +(deftest position-if-not-string.6 + (position-if-not #'odddigitp "131432189" :start 4 + :from-end t) + 7) + +(deftest position-if-not-string.7 + (position-if-not #'odddigitp "131432189" :end nil) + 3) + +(deftest position-if-not-string.8 + (position-if-not #'odddigitp "131432189" :end 3) + nil) + +(deftest position-if-not-string.9 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'odddigitp "131432189" :start i :end j))) + ((nil nil nil 3 3 3 3 3 3) + (nil nil 3 3 3 3 3 3) + (nil 3 3 3 3 3 3) + (3 3 3 3 3 3) + (nil 5 5 5 5) + (5 5 5 5) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-not-string.10 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'odddigitp "131432189" :start i :end j + :from-end t))) + ((nil nil nil 3 3 5 5 7 7) + (nil nil 3 3 5 5 7 7) + (nil 3 3 5 5 7 7) + (3 3 5 5 7 7) + (nil 5 5 7 7) + (5 5 7 7) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-not-string.11 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'evendigitp "131432183" :start i :end j + :key #'nextdigit))) + ((nil nil nil 3 3 3 3 3 3) + (nil nil 3 3 3 3 3 3) + (nil 3 3 3 3 3 3) + (3 3 3 3 3 3) + (nil 5 5 5 5) + (5 5 5 5) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-not-string.12 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'evendigitp "131432183" :start i :end j + :key 'nextdigit :from-end t))) + ((nil nil nil 3 3 5 5 7 7) + (nil nil 3 3 5 5 7 7) + (nil 3 3 5 5 7 7) + (3 3 5 5 7 7) + (nil 5 5 7 7) + (5 5 7 7) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-not-string.13 + (let ((a (make-array '(10) :initial-contents "55555aaaaa" + :fill-pointer 5 + :element-type 'character))) + (and (stringp a) + (values + (position-if-not #'digit-char-p a) + (position-if-not (complement #'digit-char-p) a) + (position-if-not #'digit-char-p a :from-end t) + (position-if-not (complement #'digit-char-p) a :from-end t)))) + nil 0 nil 4) + +(deftest position-if-not.order.1 + (let ((i 0) a b c d e f) + (values + (position-if-not + (progn (setf a (incf i)) (complement #'zerop)) + (progn (setf b (incf i)) '(3 1 8 2 1 2 3 4)) + :from-end (setf c (incf i)) + :start (progn (setf d (incf i)) 1) + :end (progn (setf e (incf i)) 6) + :key (progn (setf f (incf i)) #'1-)) + i a b c d e f)) + 4 6 1 2 3 4 5 6) + +(deftest position-if-not.order.2 + (let ((i 0) a b c d e f) + (values + (position-if-not + (progn (setf a (incf i)) (complement #'zerop)) + (progn (setf b (incf i)) '(3 1 8 2 1 2 3 4)) + :key (progn (setf c (incf i)) #'1-) + :end (progn (setf d (incf i)) 6) + :start (progn (setf e (incf i)) 1) + :from-end (setf f (incf i))) + i a b c d e f)) + 4 6 1 2 3 4 5 6) + +;;; Keyword tests + +(deftest position-if-not.allow-other-keys.1 + (position-if-not #'zerop '(0 0 3 2 0 1) :allow-other-keys t) + 2) + +(deftest position-if-not.allow-other-keys.2 + (position-if-not #'zerop '(0 0 3 2 0 1) :allow-other-keys nil) + 2) + +(deftest position-if-not.allow-other-keys.3 + (position-if-not #'zerop '(0 0 1 2 3 0) :allow-other-keys t :bad t) + 2) + +(deftest position-if-not.allow-other-keys.4 + (position-if-not #'zerop '(0 0 1 2 3 0) :bad t :allow-other-keys t) + 2) + +(deftest position-if-not.allow-other-keys.5 + (position-if-not #'zerop '(0 0 1 2 3 0) :bad t :allow-other-keys t :key #'1-) + 0) + +(deftest position-if-not.keywords.6 + (position-if-not #'zerop '(0 0 1 2 3 0) :key #'1- :key #'identity) + 0) + +(deftest position-if-not.allow-other-keys.7 + (position-if-not #'zerop '(0 0 1 2 3 0) :bad t :allow-other-keys t + :allow-other-keys nil) + 2) + +(deftest position-if-not.allow-other-keys.8 + (position-if-not #'zerop '(0 0 1 2 3 0) :allow-other-keys t :bad t + :allow-other-keys nil) + 2) + +(deftest position-if-not.allow-other-keys.9 + (position-if-not #'zerop '(0 0 1 2 3 0) :allow-other-keys t + :allow-other-keys nil :bad t) + 2) + + +;;; Error tests + +(deftest position-if-not.error.1 + (classify-error (position-if-not #'identity 'b)) + type-error) + +(deftest position-if-not.error.2 + (classify-error (position-if-not #'identity 10)) + type-error) + +(deftest position-if-not.error.3 + (classify-error (position-if-not 'null 1.4)) + type-error) + +(deftest position-if-not.error.4 + (classify-error (position-if-not 'identity '(a b c . d))) + type-error) + +(deftest position-if-not.error.5 + (classify-error (position-if-not)) + program-error) + +(deftest position-if-not.error.6 + (classify-error (position-if-not #'null)) + program-error) + +(deftest position-if-not.error.7 + (classify-error (position-if-not #'null nil :key)) + program-error) + +(deftest position-if-not.error.8 + (classify-error (position-if-not #'null nil 'bad t)) + program-error) + +(deftest position-if-not.error.9 + (classify-error (position-if-not #'null nil 'bad t :allow-other-keys nil)) + program-error) + +(deftest position-if-not.error.10 + (classify-error (position-if-not #'null nil 1 2)) + program-error) + +(deftest position-if-not.error.11 + (classify-error (locally (position-if-not #'identity 'b) t)) + type-error) + +(deftest position-if-not.error.12 + (classify-error (position-if-not #'cons '(a b c d))) + program-error) + +(deftest position-if-not.error.13 + (classify-error (position-if-not #'car '(a b c d))) + type-error) + +(deftest position-if-not.error.14 + (classify-error (position-if-not #'identity '(a b c d) :key #'cdr)) + type-error) + +(deftest position-if-not.error.15 + (classify-error (position-if-not #'identity '(a b c d) :key #'cons)) + program-error) diff --git a/ansi-tests/position-if.lsp b/ansi-tests/position-if.lsp new file mode 100644 index 0000000..cad0748 --- /dev/null +++ b/ansi-tests/position-if.lsp @@ -0,0 +1,574 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Aug 23 22:08:57 2002 +;;;; Contains: Tests for POSITION-IF + +(in-package :cl-test) + +(deftest position-if-list.1 + (position-if #'evenp '(1 3 1 4 3 2 1 8 9)) + 3) + +(deftest position-if-list.2 + (position-if 'evenp '(1 3 1 4 3 2 1 8 9)) + 3) + +(deftest position-if-list.3 + (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :start 4) + 5) + +(deftest position-if-list.4 + (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :from-end t) + 7) + +(deftest position-if-list.5 + (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :from-end nil) + 3) + +(deftest position-if-list.6 + (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :start 4 + :from-end t) + 7) + +(deftest position-if-list.7 + (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :end nil) + 3) + +(deftest position-if-list.8 + (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :end 3) + nil) + +(deftest position-if-list.9 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :start i :end j))) + ((nil nil nil 3 3 3 3 3 3) + (nil nil 3 3 3 3 3 3) + (nil 3 3 3 3 3 3) + (3 3 3 3 3 3) + (nil 5 5 5 5) + (5 5 5 5) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-list.10 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :start i :end j + :from-end t))) + ((nil nil nil 3 3 5 5 7 7) + (nil nil 3 3 5 5 7 7) + (nil 3 3 5 5 7 7) + (3 3 5 5 7 7) + (nil 5 5 7 7) + (5 5 7 7) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-list.11 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'oddp '(1 3 1 4 3 2 1 8 9) :start i :end j + :key '1+))) + ((nil nil nil 3 3 3 3 3 3) + (nil nil 3 3 3 3 3 3) + (nil 3 3 3 3 3 3) + (3 3 3 3 3 3) + (nil 5 5 5 5) + (5 5 5 5) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-list.12 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'oddp '(1 3 1 4 3 2 1 8 9) :start i :end j + :key #'1+ :from-end t))) + ((nil nil nil 3 3 5 5 7 7) + (nil nil 3 3 5 5 7 7) + (nil 3 3 5 5 7 7) + (3 3 5 5 7 7) + (nil 5 5 7 7) + (5 5 7 7) + (nil 7 7) + (7 7) + (nil))) + +;;; Vector tests + +(deftest position-if-vector.1 + (position-if #'evenp #(1 3 1 4 3 2 1 8 9)) + 3) + +(deftest position-if-vector.2 + (position-if 'evenp #(1 3 1 4 3 2 1 8 9)) + 3) + +(deftest position-if-vector.3 + (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :start 4) + 5) + +(deftest position-if-vector.4 + (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :from-end t) + 7) + +(deftest position-if-vector.5 + (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :from-end nil) + 3) + +(deftest position-if-vector.6 + (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :start 4 + :from-end t) + 7) + +(deftest position-if-vector.7 + (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :end nil) + 3) + +(deftest position-if-vector.8 + (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :end 3) + nil) + +(deftest position-if-vector.9 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :start i :end j))) + ((nil nil nil 3 3 3 3 3 3) + (nil nil 3 3 3 3 3 3) + (nil 3 3 3 3 3 3) + (3 3 3 3 3 3) + (nil 5 5 5 5) + (5 5 5 5) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-vector.10 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :start i :end j + :from-end t))) + ((nil nil nil 3 3 5 5 7 7) + (nil nil 3 3 5 5 7 7) + (nil 3 3 5 5 7 7) + (3 3 5 5 7 7) + (nil 5 5 7 7) + (5 5 7 7) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-vector.11 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'oddp #(1 3 1 4 3 2 1 8 9) :start i :end j + :key '1+))) + ((nil nil nil 3 3 3 3 3 3) + (nil nil 3 3 3 3 3 3) + (nil 3 3 3 3 3 3) + (3 3 3 3 3 3) + (nil 5 5 5 5) + (5 5 5 5) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-vector.12 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'oddp #(1 3 1 4 3 2 1 8 9) :start i :end j + :key #'1+ :from-end t))) + ((nil nil nil 3 3 5 5 7 7) + (nil nil 3 3 5 5 7 7) + (nil 3 3 5 5 7 7) + (3 3 5 5 7 7) + (nil 5 5 7 7) + (5 5 7 7) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-vector.13 + (let ((a (make-array '(10) :initial-contents '(1 3 1 4 3 1 2 1 8 9) + :fill-pointer 5))) + (flet ((%f (x) (eql x 1))) + (values (position-if #'%f a) + (position-if #'%f a :from-end t)))) + 0 2) + +;;; Bit vector tests + +(deftest position-if-bit-vector.1 + (position-if #'evenp #*111010101) + 3) + +(deftest position-if-bit-vector.2 + (position-if 'evenp #*111010101) + 3) + +(deftest position-if-bit-vector.3 + (position-if #'evenp #*111010101 :start 4) + 5) + +(deftest position-if-bit-vector.4 + (position-if #'evenp #*111010101 :from-end t) + 7) + +(deftest position-if-bit-vector.5 + (position-if #'evenp #*111010101 :from-end nil) + 3) + +(deftest position-if-bit-vector.6 + (position-if #'evenp #*111010101 :start 4 + :from-end t) + 7) + +(deftest position-if-bit-vector.7 + (position-if #'evenp #*111010101 :end nil) + 3) + +(deftest position-if-bit-vector.8 + (position-if #'evenp #*111010101 :end 3) + nil) + +(deftest position-if-bit-vector.9 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'evenp #*111010101 :start i :end j))) + ((nil nil nil 3 3 3 3 3 3) + (nil nil 3 3 3 3 3 3) + (nil 3 3 3 3 3 3) + (3 3 3 3 3 3) + (nil 5 5 5 5) + (5 5 5 5) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-bit-vector.10 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'evenp #*111010101 :start i :end j + :from-end t))) + ((nil nil nil 3 3 5 5 7 7) + (nil nil 3 3 5 5 7 7) + (nil 3 3 5 5 7 7) + (3 3 5 5 7 7) + (nil 5 5 7 7) + (5 5 7 7) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-bit-vector.11 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'oddp #*111010101 :start i :end j + :key #'1+))) + ((nil nil nil 3 3 3 3 3 3) + (nil nil 3 3 3 3 3 3) + (nil 3 3 3 3 3 3) + (3 3 3 3 3 3) + (nil 5 5 5 5) + (5 5 5 5) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-bit-vector.12 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'oddp #*111010101 :start i :end j + :key '1+ :from-end t))) + ((nil nil nil 3 3 5 5 7 7) + (nil nil 3 3 5 5 7 7) + (nil 3 3 5 5 7 7) + (3 3 5 5 7 7) + (nil 5 5 7 7) + (5 5 7 7) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-bit-vector.13 + (let ((a (make-array '(10) :initial-contents '(1 1 1 1 1 0 0 0 0 0) + :fill-pointer 5 + :element-type 'bit))) + (values (position-if #'evenp a) + (position-if #'evenp a :from-end 'foo) + (position-if #'oddp a) + (position-if #'oddp a :from-end 'foo))) + nil nil 0 4) + +;;; string tests + +(deftest position-if-string.1 + (position-if #'evendigitp "131432189") + 3) + +(deftest position-if-string.2 + (position-if 'evendigitp "131432189") + 3) + +(deftest position-if-string.3 + (position-if #'evendigitp "131432189" :start 4) + 5) + +(deftest position-if-string.4 + (position-if #'evendigitp "131432189" :from-end t) + 7) + +(deftest position-if-string.5 + (position-if #'evendigitp "131432189" :from-end nil) + 3) + +(deftest position-if-string.6 + (position-if #'evendigitp "131432189" :start 4 + :from-end t) + 7) + +(deftest position-if-string.7 + (position-if #'evendigitp "131432189" :end nil) + 3) + +(deftest position-if-string.8 + (position-if #'evendigitp "131432189" :end 3) + nil) + +(deftest position-if-string.9 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'evendigitp "131432189" :start i :end j))) + ((nil nil nil 3 3 3 3 3 3) + (nil nil 3 3 3 3 3 3) + (nil 3 3 3 3 3 3) + (3 3 3 3 3 3) + (nil 5 5 5 5) + (5 5 5 5) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-string.10 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'evendigitp "131432189" :start i :end j + :from-end t))) + ((nil nil nil 3 3 5 5 7 7) + (nil nil 3 3 5 5 7 7) + (nil 3 3 5 5 7 7) + (3 3 5 5 7 7) + (nil 5 5 7 7) + (5 5 7 7) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-string.11 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'odddigitp "131432189" :start i :end j + :key #'nextdigit))) + ((nil nil nil 3 3 3 3 3 3) + (nil nil 3 3 3 3 3 3) + (nil 3 3 3 3 3 3) + (3 3 3 3 3 3) + (nil 5 5 5 5) + (5 5 5 5) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-string.12 + (loop for i from 0 to 8 + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'odddigitp "131432189" :start i :end j + :key 'nextdigit :from-end t))) + ((nil nil nil 3 3 5 5 7 7) + (nil nil 3 3 5 5 7 7) + (nil 3 3 5 5 7 7) + (3 3 5 5 7 7) + (nil 5 5 7 7) + (5 5 7 7) + (nil 7 7) + (7 7) + (nil))) + +(deftest position-if-string.13 + (flet ((%f (c) (eql c #\0)) + (%g (c) (eql c #\1))) + (let ((a (make-array '(10) :initial-contents "1111100000" + :fill-pointer 5 + :element-type 'character))) + (values (position-if #'%f a) + (position-if #'%f a :from-end 'foo) + (position-if #'%g a) + (position-if #'%g a :from-end 'foo)))) + nil nil 0 4) + +(deftest position-if.order.1 + (let ((i 0) a b c d e f) + (values + (position-if + (progn (setf a (incf i)) #'zerop) + (progn (setf b (incf i)) '(3 1 8 2 1 2 3 4)) + :from-end (setf c (incf i)) + :start (progn (setf d (incf i)) 1) + :end (progn (setf e (incf i)) 6) + :key (progn (setf f (incf i)) #'1-)) + i a b c d e f)) + 4 6 1 2 3 4 5 6) + +(deftest position-if.order.2 + (let ((i 0) a b c d e f) + (values + (position-if + (progn (setf a (incf i)) #'zerop) + (progn (setf b (incf i)) '(3 1 8 2 1 2 3 4)) + :key (progn (setf c (incf i)) #'1-) + :end (progn (setf d (incf i)) 6) + :start (progn (setf e (incf i)) 1) + :from-end (setf f (incf i))) + i a b c d e f)) + 4 6 1 2 3 4 5 6) + +;;; Keyword tests + +(deftest position-if.allow-other-keys.1 + (position-if #'zerop '(1 2 0 3 2 1) :allow-other-keys t) + 2) + +(deftest position-if.allow-other-keys.2 + (position-if #'zerop '(1 2 0 3 2 1) :allow-other-keys nil) + 2) + +(deftest position-if.allow-other-keys.3 + (position-if #'zerop '(1 2 0 3 2 1) :allow-other-keys t :bad t) + 2) + +(deftest position-if.allow-other-keys.4 + (position-if #'zerop '(1 2 0 3 2 1) :bad t :allow-other-keys t) + 2) + +(deftest position-if.allow-other-keys.5 + (position-if #'zerop '(1 2 0 3 2 1) :bad t :allow-other-keys t :key #'1-) + 0) + +(deftest position-if.keywords.6 + (position-if #'zerop '(1 2 0 3 2 1) :key #'1- :key #'identity) + 0) + +(deftest position-if.allow-other-keys.7 + (position-if #'zerop '(1 2 0 3 2 1) :bad t :allow-other-keys t + :allow-other-keys nil) + 2) + +(deftest position-if.allow-other-keys.8 + (position-if #'zerop '(1 2 0 3 2 1) :allow-other-keys t :bad t + :allow-other-keys nil) + 2) + +(deftest position-if.allow-other-keys.9 + (position-if #'zerop '(1 2 0 3 2 1) :allow-other-keys t + :allow-other-keys nil :bad t) + 2) + + +;;; Error tests + +(deftest position-if.error.1 + (classify-error (position-if #'identity 'b)) + type-error) + +(deftest position-if.error.2 + (classify-error (position-if #'identity 10)) + type-error) + +(deftest position-if.error.3 + (classify-error (position-if 'null 1.4)) + type-error) + +(deftest position-if.error.4 + (classify-error (position-if 'null '(a b c . d))) + type-error) + +(deftest position-if.error.5 + (classify-error (position-if)) + program-error) + +(deftest position-if.error.6 + (classify-error (position-if #'null)) + program-error) + +(deftest position-if.error.7 + (classify-error (position-if #'null nil :key)) + program-error) + +(deftest position-if.error.8 + (classify-error (position-if #'null nil 'bad t)) + program-error) + +(deftest position-if.error.9 + (classify-error (position-if #'null nil 'bad t :allow-other-keys nil)) + program-error) + +(deftest position-if.error.10 + (classify-error (position-if #'null nil 1 2)) + program-error) + +(deftest position-if.error.11 + (classify-error (locally (position-if #'identity 'b) t)) + type-error) + +(deftest position-if.error.12 + (classify-error (position-if #'cons '(a b c d))) + program-error) + +(deftest position-if.error.13 + (classify-error (position-if #'car '(a b c d))) + type-error) + +(deftest position-if.error.14 + (classify-error (position-if #'identity '(a b c d) :key #'cdr)) + type-error) + +(deftest position-if.error.15 + (classify-error (position-if #'identity '(a b c d) :key #'cons)) + program-error) + + diff --git a/ansi-tests/position.lsp b/ansi-tests/position.lsp new file mode 100644 index 0000000..e070b90 --- /dev/null +++ b/ansi-tests/position.lsp @@ -0,0 +1,773 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Aug 23 07:49:49 2002 +;;;; Contains: Tests for POSITION + +(in-package :cl-test) + +(deftest position-list.1 + (position 'c '(a b c d e c a)) + 2) + +(deftest position-list.2 + (position 'c '(a b c d e c a) :from-end t) + 5) + +(deftest position-list.3 + (loop for i from 0 to 7 collect + (position 'c '(a b c d e c a) :start i)) + (2 2 2 5 5 5 nil nil)) + +(deftest position-list.4 + (loop for i from 0 to 7 collect + (position 'c '(a b c d e c a) :start i :end nil)) + (2 2 2 5 5 5 nil nil)) + +(deftest position-list.5 + (loop for i from 7 downto 0 collect + (position 'c '(a b c d e c a) :end i)) + (2 2 2 2 2 nil nil nil)) + +(deftest position-list.6 + (loop for i from 0 to 7 collect + (position 'c '(a b c d e c a) :start i :from-end t)) + (5 5 5 5 5 5 nil nil)) + +(deftest position-list.7 + (loop for i from 0 to 7 collect + (position 'c '(a b c d e c a) :start i :end nil :from-end t)) + (5 5 5 5 5 5 nil nil)) + +(deftest position-list.8 + (loop for i from 7 downto 0 collect + (position 'c '(a b c d e c a) :end i :from-end t)) + (5 5 2 2 2 nil nil nil)) + +(deftest position-list.9 + (loop for i from 0 to 6 collect + (loop for j from (1+ i) to 7 + collect + (position 'c '(a b c d e c a) :start i :end j))) + ((nil nil 2 2 2 2 2) + (nil 2 2 2 2 2) + (2 2 2 2 2) + (nil nil 5 5) + (nil 5 5) + (5 5) + (nil))) + +(deftest position-list.10 + (loop for i from 0 to 6 collect + (loop for j from (1+ i) to 7 + collect + (position 'c '(a b c d e c a) :start i :end j :from-end t))) + ((nil nil 2 2 2 5 5) + (nil 2 2 2 5 5) + (2 2 2 5 5) + (nil nil 5 5) + (nil 5 5) + (5 5) + (nil))) + +(deftest position-list.11 + (position 5 '(1 2 3 4 5 6 4 8) :key #'1+) + 3) + +(deftest position-list.12 + (position 5 '(1 2 3 4 5 6 4 8) :key '1+) + 3) + +(deftest position-list.13 + (position 5 '(1 2 3 4 5 6 4 8) :key #'1+ :from-end t) + 6) + +(deftest position-list.14 + (position 'a '(a a b a c e d a f a) :test (complement #'eql)) + 2) + +(deftest position-list.15 + (position 'a '(a a b a c e d a f a) :test (complement #'eql) + :from-end t) + 8) + +(deftest position-list.16 + (position 'a '(a a b a c e d a f a) :test-not #'eql) + 2) + +(deftest position-list.17 + (position 'a '(a a b a c e d a f a) :test-not 'eql + :from-end t) + 8) + +(deftest position-list.18 + (position 'a '(a a b a c e d a f a) :test-not 'eql) + 2) + +(deftest position-list.19 + (position 'a '(a a b a c e d a f a) :test-not #'eql + :from-end t) + 8) + +(deftest position-list.20 + (position 'a '(a a b a c e d a f a) :test-not #'eql) + 2) + +(deftest position-list.21 + (position 'a '(a a b a c e d a f a) :test #'eql + :start 2) + 3) + +(deftest position-list.22 + (position 'a '(a a b a c e d a f a) :test #'eql + :start 2 :end nil) + 3) + +(deftest position-list.23 + (position 'a '(a a b a c e d a f a) :test-not #'eql + :start 0 :end 5) + 2) + +(deftest position-list.24 + (position 'a '(a a b a c e d a f a) :test-not #'eql + :start 0 :end 5 :from-end t) + 4) + +(deftest position-list.25 + (position '(a b) '(a (b a) (a b c) (a b) (d e) f) :test #'equal) + 3) + +(deftest position-list.26 + (position 'a '((c) (b a) (a b c) (a b) (d e) f) :key #'car) + 2) + +(deftest position-list.27 + (position 'a '((c) (b a) (a b c) (z) (a b) (d e) f) :key #'car + :start 3) + 4) + +(deftest position-list.28 + (position 'a '((c) (b a) (a b c) (z) (a b) (d e) (f)) :key #'car + :start 2 :from-end t) + 4) + +;;; Tests on vectors + +(deftest position-vector.1 + (position 'c #(a b c d e c a)) + 2) + +(deftest position-vector.2 + (position 'c #(a b c d e c a) :from-end t) + 5) + +(deftest position-vector.3 + (loop for i from 0 to 7 collect + (position 'c #(a b c d e c a) :start i)) + (2 2 2 5 5 5 nil nil)) + +(deftest position-vector.4 + (loop for i from 0 to 7 collect + (position 'c #(a b c d e c a) :start i :end nil)) + (2 2 2 5 5 5 nil nil)) + +(deftest position-vector.5 + (loop for i from 7 downto 0 collect + (position 'c #(a b c d e c a) :end i)) + (2 2 2 2 2 nil nil nil)) + +(deftest position-vector.6 + (loop for i from 0 to 7 collect + (position 'c #(a b c d e c a) :start i :from-end t)) + (5 5 5 5 5 5 nil nil)) + +(deftest position-vector.7 + (loop for i from 0 to 7 collect + (position 'c #(a b c d e c a) :start i :end nil :from-end t)) + (5 5 5 5 5 5 nil nil)) + +(deftest position-vector.8 + (loop for i from 7 downto 0 collect + (position 'c #(a b c d e c a) :end i :from-end t)) + (5 5 2 2 2 nil nil nil)) + +(deftest position-vector.9 + (loop for i from 0 to 6 collect + (loop for j from (1+ i) to 7 + collect + (position 'c #(a b c d e c a) :start i :end j))) + ((nil nil 2 2 2 2 2) + (nil 2 2 2 2 2) + (2 2 2 2 2) + (nil nil 5 5) + (nil 5 5) + (5 5) + (nil))) + +(deftest position-vector.10 + (loop for i from 0 to 6 collect + (loop for j from (1+ i) to 7 + collect + (position 'c #(a b c d e c a) :start i :end j :from-end t))) + ((nil nil 2 2 2 5 5) + (nil 2 2 2 5 5) + (2 2 2 5 5) + (nil nil 5 5) + (nil 5 5) + (5 5) + (nil))) + +(deftest position-vector.11 + (position 5 #(1 2 3 4 5 6 4 8) :key #'1+) + 3) + +(deftest position-vector.12 + (position 5 #(1 2 3 4 5 6 4 8) :key '1+) + 3) + +(deftest position-vector.13 + (position 5 #(1 2 3 4 5 6 4 8) :key #'1+ :from-end t) + 6) + +(deftest position-vector.14 + (position 'a #(a a b a c e d a f a) :test (complement #'eql)) + 2) + +(deftest position-vector.15 + (position 'a #(a a b a c e d a f a) :test (complement #'eql) + :from-end t) + 8) + +(deftest position-vector.16 + (position 'a #(a a b a c e d a f a) :test-not #'eql) + 2) + +(deftest position-vector.17 + (position 'a #(a a b a c e d a f a) :test-not 'eql + :from-end t) + 8) + +(deftest position-vector.18 + (position 'a #(a a b a c e d a f a) :test-not 'eql) + 2) + +(deftest position-vector.19 + (position 'a #(a a b a c e d a f a) :test-not #'eql + :from-end t) + 8) + +(deftest position-vector.20 + (position 'a #(a a b a c e d a f a) :test-not #'eql) + 2) + +(deftest position-vector.21 + (position 'a #(a a b a c e d a f a) :test #'eql + :start 2) + 3) + +(deftest position-vector.22 + (position 'a #(a a b a c e d a f a) :test #'eql + :start 2 :end nil) + 3) + +(deftest position-vector.23 + (position 'a #(a a b a c e d a f a) :test-not #'eql + :start 0 :end 5) + 2) + +(deftest position-vector.24 + (position 'a #(a a b a c e d a f a) :test-not #'eql + :start 0 :end 5 :from-end t) + 4) + +(deftest position-vector.25 + (position '(a b) #(a (b a) (a b c) (a b) (d e) f) :test #'equal) + 3) + +(deftest position-vector.26 + (position 'a #((c) (b a) (a b c) (a b) (d e) f) :key #'car) + 2) + +(deftest position-vector.27 + (position 'a #((c) (b a) (a b c) (z) (a b) (d e) f) :key #'car + :start 3) + 4) + +(deftest position-vector.28 + (position 'a #((c) (b a) (a b c) (z) (a b) (d e) (f)) :key #'car + :start 2 :from-end t) + 4) + +(deftest position-vector.29 + (position 'a (make-array '(10) :initial-contents '(b b b b b a a a a a) + :fill-pointer 5)) + nil) + +(deftest position-vector.30 + (position 'a (make-array '(10) :initial-contents '(b b b b a a a a a a) + :fill-pointer 5)) + 4) + +(deftest position-vector.31 + (position 'a (make-array '(10) :initial-contents '(b a b b a a a a a a) + :fill-pointer 5) + :from-end t) + 4) + +;;; tests on bit vectors + +(deftest position-bit-vector.1 + (position 1 #*001001010100) + 2) + +(deftest position-bit-vector.2 + (position 1 #*001001010100 :from-end t) + 9) + +(deftest position-bit-vector.3 + (loop for i from 0 to 7 collect + (position 1 #*0010010 :start i)) + (2 2 2 5 5 5 nil nil)) + +(deftest position-bit-vector.4 + (loop for i from 0 to 7 collect + (position 1 #*0010010 :start i :end nil)) + (2 2 2 5 5 5 nil nil)) + +(deftest position-bit-vector.5 + (loop for i from 7 downto 0 collect + (position 1 #*0010010 :end i)) + (2 2 2 2 2 nil nil nil)) + +(deftest position-bit-vector.6 + (loop for i from 0 to 7 collect + (position 1 #*0010010 :start i :from-end t)) + (5 5 5 5 5 5 nil nil)) + +(deftest position-bit-vector.7 + (loop for i from 0 to 7 collect + (position 0 #*1101101 :start i :end nil :from-end t)) + (5 5 5 5 5 5 nil nil)) + +(deftest position-bit-vector.8 + (loop for i from 7 downto 0 collect + (position 0 #*1101101 :end i :from-end t)) + (5 5 2 2 2 nil nil nil)) + +(deftest position-bit-vector.9 + (loop for i from 0 to 6 collect + (loop for j from (1+ i) to 7 + collect + (position 1 #*0010010 :start i :end j))) + ((nil nil 2 2 2 2 2) + (nil 2 2 2 2 2) + (2 2 2 2 2) + (nil nil 5 5) + (nil 5 5) + (5 5) + (nil))) + +(deftest position-bit-vector.10 + (loop for i from 0 to 6 collect + (loop for j from (1+ i) to 7 + collect + (position 1 #*0010010 :start i :end j :from-end t))) + ((nil nil 2 2 2 5 5) + (nil 2 2 2 5 5) + (2 2 2 5 5) + (nil nil 5 5) + (nil 5 5) + (5 5) + (nil))) + +(deftest position-bit-vector.11 + (position 2 #*00010001010 :key #'1+) + 3) + +(deftest position-bit-vector.12 + (position 2 #*00010001010 :key '1+) + 3) + +(deftest position-bit-vector.13 + (position 2 #*0010001000 :key #'1+ :from-end t) + 6) + +(deftest position-bit-vector.14 + (position 0 #*0010111010 :test (complement #'eql)) + 2) + +(deftest position-bit-vector.15 + (position 0 #*0010111010 :test (complement #'eql) + :from-end t) + 8) + +(deftest position-bit-vector.16 + (position 0 #*0010111010 :test-not #'eql) + 2) + +(deftest position-bit-vector.17 + (position 0 #*001011101 :test-not 'eql + :from-end t) + 8) + +(deftest position-bit-vector.18 + (position 0 #*00101110 :test-not 'eql) + 2) + +(deftest position-bit-vector.19 + (position 0 #*00101110 :test-not #'eql + :from-end t) + 6) + +(deftest position-bit-vector.20 + (position 0 #*00101110 :test-not #'eql) + 2) + +(deftest position-bit-vector.21 + (position 0 #*00101110 :test #'eql + :start 2) + 3) + +(deftest position-bit-vector.22 + (position 0 #*00101110 :test #'eql + :start 2 :end nil) + 3) + +(deftest position-bit-vector.23 + (position 0 #*00101110 :test-not #'eql + :start 0 :end 5) + 2) + +(deftest position-bit-vector.24 + (position 0 #*00101110 :test-not #'eql + :start 0 :end 5 :from-end t) + 4) + +(deftest position-bit-vector.25 + (position 2 #*1100001010 :key #'1+ + :start 3) + 6) + +(deftest position-bit-vector.27 + (position 2 #*1100001010 :key #'1+ + :start 2 :from-end t) + 8) + +(deftest position-bit-vector.28 + (position 0 (make-array '(10) :initial-contents '(1 1 1 1 1 0 0 0 0 0) + :element-type 'bit + :fill-pointer 5)) + nil) + +(deftest position-bit-vector.29 + (position 0 (make-array '(10) :initial-contents '(1 1 1 1 1 0 0 0 0 0) + :element-type 'bit + :fill-pointer 5) + :from-end t) + nil) + +(deftest position-bit-vector.30 + (position 0 (make-array '(10) :initial-contents '(1 1 1 1 0 0 0 0 0 0) + :element-type 'bit + :fill-pointer 5)) + 4) + +(deftest position-bit-vector.31 + (position 0 (make-array '(10) :initial-contents '(0 1 0 1 0 0 0 0 0 0) + :element-type 'bit + :fill-pointer 5) + :from-end t) + 4) + +(deftest position-bit-vector.32 + (position 0 (make-array '(10) :initial-contents '(1 0 1 1 0 0 0 0 0 0) + :element-type 'bit + :fill-pointer 5)) + 1) + +;;; strings + +(deftest position-string.1 + (position #\c "abcdeca") + 2) + +(deftest position-string.2 + (position #\c "abcdeca" :from-end t) + 5) + +(deftest position-string.3 + (loop for i from 0 to 7 collect + (position #\c "abcdeca" :start i)) + (2 2 2 5 5 5 nil nil)) + +(deftest position-string.4 + (loop for i from 0 to 7 collect + (position #\c "abcdeca" :start i :end nil)) + (2 2 2 5 5 5 nil nil)) + +(deftest position-string.5 + (loop for i from 7 downto 0 collect + (position #\c "abcdeca" :end i)) + (2 2 2 2 2 nil nil nil)) + +(deftest position-string.6 + (loop for i from 0 to 7 collect + (position #\c "abcdeca" :start i :from-end t)) + (5 5 5 5 5 5 nil nil)) + +(deftest position-string.7 + (loop for i from 0 to 7 collect + (position #\c "abcdeca" :start i :end nil :from-end t)) + (5 5 5 5 5 5 nil nil)) + +(deftest position-string.8 + (loop for i from 7 downto 0 collect + (position #\c "abcdeca" :end i :from-end t)) + (5 5 2 2 2 nil nil nil)) + +(deftest position-string.9 + (loop for i from 0 to 6 collect + (loop for j from (1+ i) to 7 + collect + (position #\c "abcdeca" :start i :end j))) + ((nil nil 2 2 2 2 2) + (nil 2 2 2 2 2) + (2 2 2 2 2) + (nil nil 5 5) + (nil 5 5) + (5 5) + (nil))) + +(deftest position-string.10 + (loop for i from 0 to 6 collect + (loop for j from (1+ i) to 7 + collect + (position #\c "abcdeca" :start i :end j :from-end t))) + ((nil nil 2 2 2 5 5) + (nil 2 2 2 5 5) + (2 2 2 5 5) + (nil nil 5 5) + (nil 5 5) + (5 5) + (nil))) + +(deftest position-string.11 + (position 5 "12345648" :key #'(lambda (c) + (1+ (read-from-string (string c))))) + 3) + +(deftest position-string.13 + (position 5 "12345648" :key #'(lambda (c) + (1+ (read-from-string (string c)))) + :from-end t) + 6) + +(deftest position-string.14 + (position #\a "aabacedafa" :test (complement #'eql)) + 2) + +(deftest position-string.15 + (position #\a "aabacedafa" :test (complement #'eql) + :from-end t) + 8) + +(deftest position-string.16 + (position #\a "aabacedafa" :test-not #'eql) + 2) + +(deftest position-string.17 + (position #\a "aabacedafa" :test-not 'eql + :from-end t) + 8) + +(deftest position-string.18 + (position #\a "aabacedafa" :test-not 'eql) + 2) + +(deftest position-string.19 + (position #\a "aabacedafa" :test-not #'eql + :from-end t) + 8) + +(deftest position-string.20 + (position #\a "aabacedafa" :test-not #'eql) + 2) + +(deftest position-string.21 + (position #\a "aabacedafa" :test #'eql + :start 2) + 3) + +(deftest position-string.22 + (position #\a "aabacedafa" :test #'eql + :start 2 :end nil) + 3) + +(deftest position-string.23 + (position #\a "aabacedafa" :test-not #'eql + :start 0 :end 5) + 2) + +(deftest position-string.24 + (position #\a "aabacedafa" :test-not #'eql + :start 0 :end 5 :from-end t) + 4) + +(deftest position-string.25 + (position #\a (make-array '(10) :initial-contents "bbbbbaaaaa" + :element-type 'character + :fill-pointer 5)) + nil) + +(deftest position-string.26 + (position #\a (make-array '(10) :initial-contents "bbbbbaaaaa" + :element-type 'character + :fill-pointer 5) + :from-end t) + nil) + +(deftest position-string.27 + (position #\a (make-array '(10) :initial-contents "bbbbaaaaaa" + :element-type 'character + :fill-pointer 5)) + 4) + +(deftest position-string.28 + (position #\a (make-array '(10) :initial-contents "babbaaaaaa" + :element-type 'character + :fill-pointer 5) + :from-end t) + 4) + +(deftest position.order.1 + (let ((i 0) a b c d e f g) + (values + (position + (progn (setf a (incf i)) 0) + (progn (setf b (incf i)) '(3 1 8 2 1 2 3 4)) + :from-end (setf c (incf i)) + :start (progn (setf d (incf i)) 1) + :end (progn (setf e (incf i)) 6) + :key (progn (setf f (incf i)) #'1-) + :test (progn (setf g (incf i)) #'=) + ) + i a b c d e f g)) + 4 7 1 2 3 4 5 6 7) + +(deftest position.order.2 + (let ((i 0) a b c d e f g) + (values + (position + (progn (setf a (incf i)) 0) + (progn (setf b (incf i)) '(3 1 8 2 1 2 3 4)) + :test-not (progn (setf c (incf i)) #'/=) + :key (progn (setf d (incf i)) #'1-) + :end (progn (setf e (incf i)) 6) + :start (progn (setf f (incf i)) 1) + :from-end (setf g (incf i)) + ) + i a b c d e f g)) + 4 7 1 2 3 4 5 6 7) + +;;; Keyword tests + +(deftest position.allow-other-keys.1 + (position 0 '(1 2 0 3 2 1) :allow-other-keys t) + 2) + +(deftest position.allow-other-keys.2 + (position 0 '(1 2 0 3 2 1) :allow-other-keys nil) + 2) + +(deftest position.allow-other-keys.3 + (position 0 '(1 2 0 3 2 1) :allow-other-keys t :bad t) + 2) + +(deftest position.allow-other-keys.4 + (position 0 '(1 2 0 3 2 1) :bad t :allow-other-keys t) + 2) + +(deftest position.allow-other-keys.5 + (position 0 '(1 2 0 3 2 1) :bad t :allow-other-keys t :key #'1-) + 0) + +(deftest position.keywords.6 + (position 0 '(1 2 0 3 2 1) :key #'1- :key #'identity) + 0) + +(deftest position.allow-other-keys.7 + (position 0 '(1 2 0 3 2 1) :bad t :allow-other-keys t + :allow-other-keys nil) + 2) + +(deftest position.allow-other-keys.8 + (position 0 '(1 2 0 3 2 1) :allow-other-keys t :bad t + :allow-other-keys nil) + 2) + +(deftest position.allow-other-keys.9 + (position 0 '(1 2 0 3 2 1) :allow-other-keys t + :allow-other-keys nil :bad t) + 2) + +;;; Error tests + +(deftest position.error.1 + (classify-error (position 'a 'b)) + type-error) + +(deftest position.error.2 + (classify-error (position 'a 10)) + type-error) + +(deftest position.error.3 + (classify-error (position 'a 1.4)) + type-error) + +(deftest position.error.4 + (classify-error (position 'e '(a b c . d))) + type-error) + +(deftest position.error.5 + (classify-error (position)) + program-error) + +(deftest position.error.6 + (classify-error (position 'a)) + program-error) + +(deftest position.error.7 + (classify-error (position 'a nil :key)) + program-error) + +(deftest position.error.8 + (classify-error (position 'a nil 'bad t)) + program-error) + +(deftest position.error.9 + (classify-error (position 'a nil 'bad t :allow-other-keys nil)) + program-error) + +(deftest position.error.10 + (classify-error (position 'a nil 1 2)) + program-error) + +(deftest position.error.11 + (classify-error (locally (position 'a 'b) t)) + type-error) + +(deftest position.error.12 + (classify-error (position 'b '(a b c d) :test #'identity)) + program-error) + +(deftest position.error.13 + (classify-error (position 'b '(a b c d) :test-not #'not)) + program-error) + +(deftest position.error.14 + (classify-error (position 'b '(a b c d) :key #'cdr)) + type-error) + +(deftest position.error.15 + (classify-error (position 'b '(a b c d) :key #'cons)) + program-error) + diff --git a/ansi-tests/prog.lsp b/ansi-tests/prog.lsp new file mode 100644 index 0000000..8b508f2 --- /dev/null +++ b/ansi-tests/prog.lsp @@ -0,0 +1,147 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Oct 19 09:21:57 2002 +;;;; Contains: Tests of PROG + +(in-package :cl-test) + +(deftest prog.1 + (prog ()) + nil) + +(deftest prog.2 + (prog () 'a) + nil) + +(deftest prog.3 + (prog () (return 'a)) + a) + +(deftest prog.4 + (prog () (return (values 1 2 3 4 5))) + 1 2 3 4 5) + +(deftest prog.5 + (let ((x 'a)) + (prog ((x 'b) (y x)) + (declare (type symbol x y)) + (return (values x y)))) + b a) + +(deftest prog.6 + (let ((x 'a)) + (prog (x) (setq x 'b)) + x) + a) + +(deftest prog.7 + (prog ((i 1) (s 0)) + (declare (type fixnum i s)) + again + (when (> i 10) (return s)) + (incf s i) + (incf i) + (go again)) + 55) + +(deftest prog.8 + (let ((x 0)) + (prog ((y (incf x)) (z (incf x))) + (return (values x y z)))) + 2 1 2) + +(deftest prog.9 + (flet ((%f () (locally (declare (special z)) z))) + (prog ((z 10)) + (declare (special z)) + (return (%f)))) + 10) + +(deftest prog.10 + (prog () + (return + (1+ + (prog () + (go end) + done + (return 1) + end + (go done)))) + done + (return 'bad)) + 2) + + +;;; Tests of PROG* + +(deftest prog*.1 + (prog* ()) + nil) + +(deftest prog*.2 + (prog* () 'a) + nil) + +(deftest prog*.3 + (prog* () (return 'a)) + a) + +(deftest prog*.4 + (prog* () (return (values 1 2 3 4 5))) + 1 2 3 4 5) + +(deftest prog*.5 + (let ((x 'a)) + (prog* ((z x) (x 'b) (y x)) + (declare (type symbol x y)) + (return (values x y z)))) + b b a) + +(deftest prog*.6 + (let ((x 'a)) + (prog* (x) (setq x 'b)) + x) + a) + +(deftest prog*.7 + (prog* ((i 1) (s 0)) + (declare (type fixnum i s)) + again + (when (> i 10) (return s)) + (incf s i) + (incf i) + (go again)) + 55) + +(deftest prog*.8 + (let ((x 0)) + (prog* ((y (incf x)) (z (incf x))) + (return (values x y z)))) + 2 1 2) + +(deftest prog*.9 + (flet ((%f () (locally (declare (special z)) z))) + (prog* ((z 10)) + (declare (special z)) + (return (%f)))) + 10) + +(deftest prog*.10 + (prog* () + (return + (1+ + (prog* () + (go end) + done + (return 1) + end + (go done)))) + done + (return 'bad)) + 2) + + + + + + diff --git a/ansi-tests/prog1.lsp b/ansi-tests/prog1.lsp new file mode 100644 index 0000000..66c8459 --- /dev/null +++ b/ansi-tests/prog1.lsp @@ -0,0 +1,27 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Oct 19 09:37:14 2002 +;;;; Contains: Tests for PROG1 + +(in-package :cl-test) + +(deftest prog1.1 + (prog1 'a) + a) + +(deftest prog1.2 + (prog1 'a 'b) + a) + +(deftest prog1.3 + (prog1 (values 'a 'b) 'c) + a) + +(deftest prog1.4 + (prog1 (values) 'c) + nil) + +(deftest prog1.5 + (let ((x 0)) + (values (prog1 x (incf x)) x)) + 0 1) diff --git a/ansi-tests/prog2.lsp b/ansi-tests/prog2.lsp new file mode 100644 index 0000000..97dbed8 --- /dev/null +++ b/ansi-tests/prog2.lsp @@ -0,0 +1,36 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Oct 19 09:40:51 2002 +;;;; Contains: Tests for PROG2 + +(in-package :cl-test) + +(deftest prog2.1 + (prog2 'a 'b) + b) + +(deftest prog2.2 + (prog2 'a 'b 'c) + b) + +(deftest prog2.3 + (prog2 'a (values) 'c) + nil) + +(deftest prog2.4 + (prog2 'a (values 'b 'd) 'c) + b) + +(deftest prog2.5 + (let ((x 0)) + (values + (prog2 (incf x) (incf x) (incf x)) + x)) + 2 3) + +(deftest prog2.6 + (let ((x 1)) + (values + (prog2 (incf x (1+ x)) (incf x (+ 2 x)) (incf x 100)) + x)) + 8 108) diff --git a/ansi-tests/progn.lsp b/ansi-tests/progn.lsp new file mode 100644 index 0000000..159530c --- /dev/null +++ b/ansi-tests/progn.lsp @@ -0,0 +1,38 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Oct 19 09:33:51 2002 +;;;; Contains: Tests of PROGN + +(in-package :cl-test) + +(deftest progn.1 + (progn) + nil) + +(deftest progn.2 + (progn 'a) + a) + +(deftest progn.3 + (progn 'b 'a) + a) + +(deftest progn.4 + (let ((x 0)) + (values (progn (incf x) x) x)) + 1 1) + +(deftest progn.5 (progn (values))) + +(deftest progn.6 + (progn (values 1 2) (values 'a 'b 'c 'd 'e)) + a b c d e) + +(deftest progn.7 + (let ((x 0)) + (prog () + (progn (go x) x 'a) + (return 'bad) + x + (return 'good))) + good) diff --git a/ansi-tests/progv.lsp b/ansi-tests/progv.lsp new file mode 100644 index 0000000..5b863f0 --- /dev/null +++ b/ansi-tests/progv.lsp @@ -0,0 +1,75 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Oct 12 10:00:50 2002 +;;;; Contains: Tests for PROGV + +(in-package :cl-test) + +(deftest progv.1 + (progv () () t) + t) + +(deftest progv.2 + (progv '(x) '(1) (not (not (boundp 'x)))) + t) + +(deftest progv.3 + (progv '(x) '(1) (symbol-value 'x)) + 1) + +(deftest progv.4 + (progv '(x) '(1) + (locally (declare (special x)) + x)) + 1) + +(deftest progv.5 + (let ((x 0)) + (progv '(x) '(1) x)) + 0) + +(deftest progv.6 + (let ((x 0)) + (declare (special x)) + (progv '(x) () + (boundp 'x))) + nil) + +(deftest progv.6a + (let ((x 0)) + (declare (special x)) + (progv '(x) () (setq x 1)) + x) + 0) + +(deftest progv.7 + (progv '(x y z) '(1 2 3) + (locally (declare (special x y z)) + (values x y z))) + 1 2 3) + +(deftest progv.8 + (progv '(x y z) '(1 2 3 4 5 6 7 8) + (locally (declare (special x y z)) + (values x y z))) + 1 2 3) + +(deftest progv.9 + (let ((x 0)) + (declare (special x)) + (progv '(x y z w) '(1) + (values (not (not (boundp 'x))) + (boundp 'y) + (boundp 'z) + (boundp 'w)))) + t nil nil nil) + +;; forms are evaluated in order + +(deftest progv.10 + (let ((x 0) (y 0) (c 0)) + (progv + (progn (setf x (incf c)) nil) + (progn (setf y (incf c)) nil) + (values x y c))) + 1 2 2) diff --git a/ansi-tests/random-aux.lsp b/ansi-tests/random-aux.lsp new file mode 100644 index 0000000..56895a9 --- /dev/null +++ b/ansi-tests/random-aux.lsp @@ -0,0 +1,90 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Jun 8 06:56:15 2003 +;;;; Contains: Aux. functions and macros used for randomization + +(in-package :cl-test) + +(defun random-from-seq (seq) + "Generate a random member of a sequence." + (let ((len (length seq))) + (assert (> len 0)) + (elt seq (random len)))) + +(defmacro random-case (&body cases) + (let ((len (length cases))) + (assert (> len 0)) + `(case (random ,len) + ,@(loop for i from 0 for e in cases collect `(,i ,e)) + (t (error "Can't happen?! (in random-case)~%"))))) + +(defmacro rcase (&body cases) + "Usage: (RCASE (
+)+), where is a positive real + indicating the relative probability of executing the associated implicit + progn." + (assert cases) + (let* ((weights (mapcar #'car cases)) + (cumulative-weights (let ((sum 0)) + (loop for w in weights collect (incf sum w)))) + (total (car (last cumulative-weights))) + (r (gensym))) + (assert (every #'plusp weights)) + `(let ((,r (random ,total))) + (cond + ,@(loop for case in (butlast cases) + for cw in cumulative-weights + collect `((< ,r ,cw) ,@(cdr case))) + (t ,@(cdar (last cases))))))) + +(defun random-nonnegative-real () + (if (coin 3) + (random-case + (/ (random 10000) (1+ (random 1000))) + (/ (random 1000000) (1+ (random 100000))) + (/ (random 100000000) (1+ (random 10000000))) + (/ (random 1000000000000) (1+ (random 10000000)))) + (random (random-case + 1000 + 100000 + 10000000 + 1000000000 + (expt 2.0s0 (random 15)) + (expt 2.0f0 (random 32)) + (expt 2.0d0 (random 32)) + (expt 2.0l0 (random 32)))))) + +(defun random-real () + (if (coin) (random-nonnegative-real) + (- (random-nonnegative-real)))) + +(defun random-fixnum () + (+ (random (1+ (- most-positive-fixnum most-negative-fixnum))) + most-negative-fixnum)) + +(defun random-from-interval (upper &optional (lower (- upper))) + (+ (random (- upper lower)) lower)) + +(defun coin (&optional (n 2)) + "Flip an n-sided coin." + (eql (random n) 0)) + +;;; Randomly permute a sequence +(defun random-permute (seq) + (setq seq (copy-seq seq)) + (let ((len (length seq))) + (loop for i from len downto 2 + do (let ((r (random i))) + (rotatef (elt seq r) (elt seq (1- i)))))) + seq) + +(defun binomial-distribution-test (n fn) + (let* ((count (loop repeat n count (funcall fn))) + (sigma (/ (sqrt n) 2.0)) + (bound (* sigma 6)) + (expected (/ n 2.0))) + (<= (- expected bound) + count + (+ expected bound)))) + + + diff --git a/ansi-tests/random-int-form.lsp b/ansi-tests/random-int-form.lsp new file mode 100644 index 0000000..0104908 --- /dev/null +++ b/ansi-tests/random-int-form.lsp @@ -0,0 +1,2115 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Sep 10 18:03:52 2003 +;;;; Contains: Simple randon form generator/tester + +(in-package :cl-test) + +(compile-and-load "random-aux.lsp") + +;;; +;;; This file contains a routine for generating random legal Common Lisp functions +;;; for differential testing. +;;; +;;; To run the random tests by themselves, start a lisp in the ansi-tests directory +;;; and do the following: +;;; (load "gclload1.lsp") +;;; (compile-and-load "random-int-form.lsp") +;;; (in-package :cl-test) +;;; (let ((*random-state* (make-random-state t))) +;;; (test-random-integer-forms 100 4 10000)) ;; or other parameters +;;; +;;; If a test breaks during testing the variables *optimized-fn-src*, +;;; *unoptimized-fn-src*, and *int-form-vals* can be used to get the source +;;; of the optimized/unoptimized lambda forms being compiled, and the arguments +;;; on which they are called. +;;; +;;; If a difference is found between optimized/unoptimized functions the forms, +;;; values, and results are collected. A list of all these discrepancies is returned +;;; after testing finishes (assuming nothing breaks). +;;; +;;; The variable *compile-unoptimized-form* controls whether the low optimization +;;; form is compiled, or if a form funcalling it is EVALed. The latter is often +;;; faster, and may find more problems since an interpreter and compiler may evaluate +;;; forms in very different ways. +;;; +;;; The rctest/ subdirectory contains fragments of a more OO random form generator +;;; that will eventually replace this preliminary effort. +;;; +;;; The file misc.lsp contains tests that were mostly for bugs found by this +;;; random tester in various Common Lisp implementations. +;;; + +(declaim (special *optimized-fn-src* *unoptimized-fn-src* *int-form-vals* + *opt-result* *unopt-result* $x $y $z + *compile-unoptimized-form*)) + +;;; Little functions used to run collected tests. +;;; (f i) runs the ith collected optimized test +;;; (g i) runs the ith collected unoptimized test +;;; (p i) prints the ith test (forms, input values, and other information) + +(defun f (i) (let ((plist (elt $y i))) + (apply (compile nil (getf plist :optimized-lambda-form)) + (getf plist :vals)))) + +(defun g (i) (let ((plist (elt $y i))) + (if *compile-unoptimized-form* + (apply (compile nil (getf plist :unoptimized-lambda-form)) + (getf plist :vals)) + (apply (the function (eval `(function ,(getf plist :unoptimized-lambda-form)))) + (getf plist :vals))))) + +(defun p (i) (write (elt $y i) :pretty t :escape t) (values)) + +(defun tn (n &optional (size 100)) + (length (setq $y (prune-results (setq $x (test-random-integer-forms size 2 n)))))) + +(declaim (special *s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8* *s9*)) + +(defparameter *loop-random-int-form-period* 2000) + +;;; Run the random tester, collecting failures into the special +;;; variable $y. + +(defun loop-random-int-forms (&optional (size 200) (nvars 3)) + (unless (boundp '$x) (setq $x nil)) + (unless (boundp '$y) (setq $y nil)) + (loop + for i from 1 + do + (format t "~6D | " i) + (finish-output *standard-output*) + (let ((x (test-random-integer-forms + size nvars *loop-random-int-form-period* + :index (* (1- i) *loop-random-int-form-period*)))) + (when x + (setq $x (append $x x)) + (setq x (prune-results x)) + (terpri) (print x) (finish-output *standard-output*) + (setq $y (append $y x))) + (terpri)))) + +(defvar *random-int-form-blocks* nil) +(defvar *random-int-form-catch-tags* nil) +(defvar *go-tags* nil) + +(defvar *maximum-random-int-bits* 45) + +(defvar *random-vals-list-bound* 10) + +(defvar *max-compile-time* 0) +(defvar *max-compile-term* nil) + +(defvar *print-immediately* nil) + +(defvar *compile-unoptimized-form* + #+(or allegro sbcl) t + #-(or allegro sbcl) nil) + +(declaim (special *vars*)) + +(defstruct var-desc + (name nil :type symbol) + (type t)) + +(defun test-random-integer-forms + (size nvars n + &key ((:random-state *random-state*) (make-random-state t)) + (file-prefix "b") + (index 0) + (random-size nil) + (random-nvars nil) + ) + + "Generate random integer forms of size SIZE with NVARS variables. + Do this N times, returning all those on which a discrepancy + is found between optimized and nonoptimize, notinlined code." + + (assert (integerp nvars)) + (assert (<= 1 nvars 26)) + (assert (and (integerp n) (plusp n))) + (assert (and (integerp n) (plusp size))) + +;;; #+sbcl +;;; (loop for x in (reverse sb-ext:*before-gc-hooks*) +;;; do (pushnew x sb-ext:*after-gc-hooks*)) + + (loop for i from 1 to n + do (when (= (mod i 100) 0) + ;; #+sbcl (print "Do gc...") + ;; #+sbcl (sb-ext::gc :full t) + (prin1 i) (princ " ") (finish-output *standard-output*)) + nconc (let ((result (test-random-integer-form + (if random-size (1+ (random size)) size) + (if random-nvars (1+ (random nvars)) nvars) + :index (+ index i) + :file-prefix file-prefix))) + (when result + (let ((*print-readably* t)) + (format t "~%~A~%" (format nil "~S" (car result))) + (finish-output *standard-output*))) + result))) + +(defun test-random-integer-form + (size nvars &key (index 0) (file-prefix "b")) + (let* ((vars (subseq '(a b c d e f g h i j k l m + n o p q r s u v w x y z) 0 nvars)) + (var-ranges (mapcar #'make-random-integer-range vars)) + (var-types (mapcar #'(lambda (range) + (let ((lo (car range)) + (hi (cadr range))) + (assert (>= hi lo)) + `(integer ,lo ,hi))) + var-ranges)) + (form (let ((*vars* (loop for v in vars + for tp in var-types + collect (make-var-desc :name v + :type tp))) + (*random-int-form-blocks* nil) + (*random-int-form-catch-tags* nil) + (*go-tags* nil) + ) + (make-random-integer-form (1+ (random size))))) + (vals-list + (loop repeat *random-vals-list-bound* + collect + (mapcar #'(lambda (range) + (let ((lo (car range)) + (hi (cadr range))) + (random-from-interval (1+ hi) lo))) + var-ranges))) + (opt-decls-1 (make-random-optimize-settings)) + (opt-decls-2 (make-random-optimize-settings))) + (when *print-immediately* + (with-open-file + (s (format nil "~A~A.lsp" file-prefix index) + :direction :output :if-exists :error) + (print `(defparameter *x* + '(:vars ,vars + :var-types ,var-types + :vals-list ,vals-list + :decls1 ,opt-decls-1 + :decls2 ,opt-decls-2 + :form ,form)) + s) + (print '(load "c.lsp") s) + (finish-output s)) + ;; (cl-user::gc) + (make-list 1000000) ;; try to trigger a gc + ) + (test-int-form form vars var-types vals-list opt-decls-1 opt-decls-2))) + +(defun make-random-optimize-settings () + (loop for settings = (cons + (list 'speed (1+ (random 3))) + (loop for s in '(space safety debug compilation-speed) + for n = (random 4) + collect (list s n))) + while + #+allegro (subsetp '((speed 3) (safety 0)) settings :test 'equal) + #-allegro nil + finally (return settings))) + +(defun fn-symbols-in-form (form) + "Return a list of the distinct standardized lisp function + symbols occuring ing FORM. These are used to generate a NOTINLINE + declaration for the unoptimized form." + (intersection + (remove-duplicates (fn-symbols-in-form* form) :test #'eq) + *cl-function-or-accessor-symbols*)) + +(defun fn-symbols-in-form* (form) + (when (consp form) + (if (symbolp (car form)) + (cons (car form) (mapcan #'fn-symbols-in-form* (cdr form))) + (mapcan #'fn-symbols-in-form* form)))) + +(defun make-random-integer-range (&optional var) + "Generate a list (LO HI) of integers, LO <= HI. This is used + for generating integer types." + (declare (ignore var)) + (rcase + (1 (flet ((%r () (let ((r (ash 1 (1+ (random *maximum-random-int-bits*))))) + (- (random r) (floor (/ r 2)))))) + (let ((x (%r)) + (y (%r))) + (list (min x y) (max x y))))) + (1 (let* ((b (ash 1 (1+ (random *maximum-random-int-bits*)))) + (b2 (floor (/ b 2)))) + (let ((x (- (random b) b2)) + (y (- (random b) b2))) + (list (min x y) (max x y))))))) + +(defun fn-arg-name (fn-name arg-index) + (intern (concatenate 'string + (subseq (symbol-name fn-name) 1) + (format nil "-~D" arg-index)) + (symbol-package fn-name))) + +(declaim (special *flet-names*)) +(defparameter *flet-names* nil) + +(defun make-random-integer () + (let ((r (ash 1 (1+ (random 32))))) + (- (random r) (floor (/ r 2))))) + +(defun random-var-desc () + (loop + (let* ((pos (random (length *vars*))) + (desc (elt *vars* pos))) + (when (= pos (position (var-desc-name desc) (the list *vars*) + :key #'var-desc-name)) + (return desc))))) + +(defun make-random-integer-form (size) + "Generate a random legal lisp form of size SIZE (roughly)." + + (if (<= size 1) + ;; Leaf node -- generate a variable, constant, or flet function call + (loop + when + (rcase + (10 (make-random-integer)) + (9 (if *vars* + (let* ((desc (random-var-desc)) + (type (var-desc-type desc)) + (name (var-desc-name desc))) + (cond + ((subtypep type 'integer) name) + ((subtypep type '(array integer nil)) `(aref ,name)) + ((subtypep type '(cons integer integer)) + (rcase (1 `(car ,name)) + (1 `(cdr ,name)))) + (t nil))) + nil)) + (1 (if *go-tags* `(go ,(random-from-seq *go-tags*)) nil)) + (2 (if *flet-names* + (let* ((flet-entry (random-from-seq *flet-names*)) + (flet-name (car flet-entry)) + (flet-minargs (cadr flet-entry)) + (flet-maxargs (caddr flet-entry)) + (nargs (random-from-interval (1+ flet-maxargs) flet-minargs)) + (args (loop repeat nargs + collect (make-random-integer-form 1)))) + `(,flet-name ,@args)) + nil))) + return it) + ;; (> size 1) + (rcase + ;; flet call + #-(or armedbear) + (30 ;; 5 + (make-random-integer-flet-call-form size)) + + ;; Unary ops + (40 + (let ((op (random-from-seq '(- abs signum 1+ 1- conjugate + rational rationalize + numerator denominator + identity progn floor + #-(or armedbear) ignore-errors + cl:handler-case restart-case + ceiling truncate round realpart imagpart + integer-length logcount values + locally)))) + `(,op ,(make-random-integer-form (1- size))))) + + #-(or armedbear) + (4 + (make-random-integer-unwind-protect-form size)) + + (5 (make-random-integer-mapping-form size)) + + ;; prog1, multiple-value-prog1 + #-(or armedbear) + (4 + (let* ((op (random-from-seq #(prog1 multiple-value-prog1))) + (nforms (random 4)) + (sizes (random-partition (1- size) (1+ nforms))) + (args (mapcar #'make-random-integer-form sizes))) + `(,op ,@args))) + + ;; prog2 + (2 (let* ((nforms (random 4)) + (sizes (random-partition (1- size) (+ nforms 2))) + (args (mapcar #'make-random-integer-form sizes))) + `(prog2 ,@args))) + + (2 `(isqrt (abs ,(make-random-integer-form (- size 2))))) + + (2 `(the integer ,(make-random-integer-form (1- size)))) + + (1 `(cl:handler-bind nil ,(make-random-integer-form (1- size)))) + (1 `(restart-bind nil ,(make-random-integer-form (1- size)))) + (1 `(macrolet () ,(make-random-integer-form (1- size)))) + + ;; dotimes + #-allegro + (5 + (let* ((var (random-from-seq #(iv1 iv2 iv3 iv4))) + (count (random 4)) + (sizes (random-partition (1- size) 2)) + (body (let ((*vars* (cons (make-var-desc :name var :type nil) + *vars*))) + (make-random-integer-form (first sizes)))) + (ret-form (make-random-integer-form (second sizes)))) + (unless (consp body) (setq body `(progn ,body))) + `(dotimes (,var ,count ,ret-form) ,body))) + + ;; loop + (5 (make-random-loop-form (1- size))) + + #-(or gcl ecl armedbear) + ;; load-time-value + (2 + (let ((arg (let ((*flet-names* nil) + (*vars* nil) + (*random-int-form-blocks* nil) + (*random-int-form-catch-tags* nil) + (*go-tags* nil)) + (make-random-integer-form (1- size))))) + (rcase + (4 `(load-time-value ,arg t)) + (2 `(load-time-value ,arg)) + (2 `(load-time-value ,arg nil))))) + + ;; eval + (2 (make-random-integer-eval-form size)) + + #-(or cmu allegro) + (2 + (destructuring-bind (s1 s2) + (random-partition (- size 2) 2) + `(ash ,(make-random-integer-form s1) + (min ,(random 100) + ,(make-random-integer-form s2))))) + + ;; binary floor, ceiling, truncate, round + (4 + (let ((op (random-from-seq #(floor ceiling truncate round mod rem))) + (op2 (random-from-seq #(max min)))) + (destructuring-bind (s1 s2) + (random-partition (- size 2) 2) + `(,op ,(make-random-integer-form s1) + (,op2 ,(if (eq op2 'max) + (1+ (random 100)) + (- (1+ (random 100)))) + ,(make-random-integer-form s2)))))) + + ;; Binary op + (30 + (let* ((op (random-from-seq + '(+ - * logand min max gcd + lcm + #-:allegro + logandc1 + logandc2 logeqv logior lognand lognor + #-:allegro + logorc1 + logorc2 + logxor + )))) + (destructuring-bind (leftsize rightsize) + (random-partition (1- size) 2) + (let ((e1 (make-random-integer-form leftsize)) + (e2 (make-random-integer-form rightsize))) + `(,op ,e1 ,e2))))) + + ;; boole + (4 + (let* ((op (random-from-seq + #(boole-1 boole-2 boole-and boole-andc1 boole-andc2 + boole-c1 boole-c2 boole-clr boole-eqv boole-ior boole-nand + boole-nor boole-orc1 boole-orc2 boole-set boole-xor)))) + (destructuring-bind (leftsize rightsize) + (random-partition (- size 2) 2) + (let ((e1 (make-random-integer-form leftsize)) + (e2 (make-random-integer-form rightsize))) + `(boole ,op ,e1 ,e2))))) + + ;; n-ary ops + (30 + (let* ((op (random-from-seq #(+ - * logand min max logior + lcm gcd logxor))) + (nargs (1+ (min (random 10) (random 10) (random 10)))) + (sizes (random-partition (1- size) nargs)) + (args (mapcar #'make-random-integer-form sizes))) + `(,op ,@args))) + + ;; expt + (3 `(expt ,(make-random-integer-form (1- size)) ,(random 3))) + + ;; coerce + (2 `(coerce ,(make-random-integer-form (1- size)) 'integer)) + + ;; complex (degenerate case) + (2 `(complex ,(make-random-integer-form (1- size)) 0)) + + ;; quotient (degenerate cases) + (1 `(/ ,(make-random-integer-form (1- size)) 1)) + (1 `(/ ,(make-random-integer-form (1- size)) -1)) + + ;; tagbody + (5 (make-random-tagbody-and-progn size)) + + ;; conditionals + (20 + (let* ((cond-size (random (max 1 (floor size 2)))) + (then-size (random (- size cond-size))) + (else-size (- size 1 cond-size then-size)) + (pred (make-random-pred-form cond-size)) + (then-part (make-random-integer-form then-size)) + (else-part (make-random-integer-form else-size))) + `(if ,pred ,then-part ,else-part))) + (5 + (destructuring-bind (s1 s2 s3) (random-partition (1- size) 3) + `(,(random-from-seq '(deposit-field dpb)) + ,(make-random-integer-form s1) + ,(make-random-byte-spec-form s2) + ,(make-random-integer-form s3)))) + + #-:allegro + (10 + (destructuring-bind (s1 s2) (random-partition (1- size) 2) + `(,(random-from-seq '(ldb mask-field)) + ,(make-random-byte-spec-form s1) + ,(make-random-integer-form s2)))) + + (20 (make-random-integer-binding-form size)) + + ;; progv + #-(or armedbear) + (4 (make-random-integer-progv-form size)) + + (4 `(let () ,(make-random-integer-form (1- size)))) + + (10 + (let* ((name (random-from-seq #(b1 b2 b3 b4 b5 b6 b7 b8))) + (*random-int-form-blocks* (adjoin name *random-int-form-blocks*))) + `(block ,name ,(make-random-integer-form (1- size))))) + + #-(or armedbear) + (20 + (let* ((tag (list 'quote (random-from-seq #(ct1 ct2 ct2 ct4 ct5 ct6 ct7 ct8)))) + (*random-int-form-catch-tags* (cons tag *random-int-form-catch-tags*))) + `(catch ,tag ,(make-random-integer-form (1- size))))) + + (4 ;; setq and similar + (make-random-integer-setq-form size)) + + (10 (make-random-integer-case-form size)) + + (3 + (if *random-int-form-blocks* + (let ((name (random-from-seq *random-int-form-blocks*)) + (form (make-random-integer-form (1- size)))) + `(return-from ,name ,form)) + ;; No blocks -- try again + (make-random-integer-form size))) + + (20 + (if *random-int-form-catch-tags* + (let ((tag (random-from-seq *random-int-form-catch-tags*)) + (form (make-random-integer-form (1- size)))) + `(throw ,tag ,form)) + ;; No catch tags -- try again + (make-random-integer-form size))) + + (5 + (if *random-int-form-blocks* + (destructuring-bind (s1 s2 s3) (random-partition (1- size) 3) + (let ((name (random-from-seq *random-int-form-blocks*)) + (pred (make-random-pred-form s1)) + (then (make-random-integer-form s2)) + (else (make-random-integer-form s3))) + `(if ,pred (return-from ,name ,then) ,else))) + ;; No blocks -- try again + (make-random-integer-form size))) + + #-(or armedbear) + (20 + (make-random-flet-form size)) + + (2 + (let* ((nbits (1+ (min (random 20) (random 20)))) + (bvec (coerce (loop repeat nbits collect (random 2)) 'simple-bit-vector)) + (op (random-from-seq #(bit sbit)))) + `(,op ,bvec (min ,(1- nbits) (max 0 ,(make-random-integer-form (- size 3 nbits))))))) + + (2 + (let* ((nvals (1+ (min (random 20) (random 20)))) + (lim (ash 1 (+ 3 (random 40)))) + (vec (coerce (loop repeat nvals collect (random lim)) 'simple-vector)) + (op (random-from-seq #(aref svref elt)))) + `(,op ,vec (min ,(1- nvals) (max 0 ,(make-random-integer-form (- size 3 nvals))))))) + + (2 + (let* ((nvals (1+ (min (random 20) (random 20)))) + (lim (ash 1 (+ 3 (random 40)))) + (vals (loop repeat nvals collect (random lim))) + (op 'elt)) + `(,op ',vals (min ,(1- nvals) (max 0 ,(make-random-integer-form (- size 3 nvals))))))) + + ))) + +(defun make-random-integer-flet-call-form (size) + (if *flet-names* + (let* ((flet-entry (random-from-seq *flet-names*)) + (flet-name (car flet-entry)) + (flet-minargs (cadr flet-entry)) + (flet-maxargs (caddr flet-entry)) + (nargs (random-from-interval (1+ flet-maxargs) flet-minargs)) + ) + (cond + ((> nargs 0) + (let* ((arg-sizes (random-partition (1- size) nargs)) + (args (mapcar #'make-random-integer-form arg-sizes))) + (rcase + (1 `(,flet-name ,@args)) + (1 `(multiple-value-call #',flet-name (values ,@args))) + (1 `(funcall (function ,flet-name) ,@args)) + (1 (let ((r (random (1+ (length args))))) + `(apply (function ,flet-name) + ,@(subseq args 0 r) + (list ,@(subseq args r)))))))) + (t (make-random-integer-form size)))) + (make-random-integer-form size))) + +(defun make-random-integer-unwind-protect-form (size) + (let* ((op 'unwind-protect) + (nforms (random 4)) + (sizes (random-partition (1- size) (1+ nforms))) + (arg (make-random-integer-form (first sizes))) + (unwind-forms + ;; We have to be careful not to generate code that will + ;; illegally transfer control to a dead location + (let ((*flet-names* nil) + (*go-tags* nil) + (*random-int-form-blocks* nil) + (*random-int-form-catch-tags* nil)) + (mapcar #'make-random-integer-form (rest sizes))))) + `(,op ,arg ,@unwind-forms))) + +(defun make-random-integer-eval-form (size) + (flet ((%arg (size) + (let ((*flet-names* nil) + (*vars* (remove-if-not #'(lambda (s) + (member (var-desc-name s) + '(*s1* *s2* *s3* *s4* *s5* + *s6* *s7* *s8* *s9*) + :test #'eq)) + *vars*)) + (*random-int-form-blocks* nil) + (*go-tags* nil)) + (make-random-integer-form size)))) + (rcase + (2 `(eval ',(%arg (1- size)))) + (2 (let* ((nargs (1+ (random 4))) + (sizes (random-partition (1- size) nargs)) + (args (mapcar #'%arg sizes))) + `(eval (values ,@args)))) + ))) + +(defun make-random-type-for-var (var e1) + (let (desc) + (values + (cond + ((and (member var '(*s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8*) :test #'eq) + (setq desc (find var *vars* :key #'var-desc-name))) + (var-desc-type desc)) + (t (rcase + (4 '(integer * *)) + (2 (setq e1 `(make-array nil :initial-element ,e1 + ,@(rcase (1 nil) (1 '(:adjustable t))))) + '(array integer nil)) + (1 (setq e1 `(cons ,e1 ,(make-random-integer-form 1))) + '(cons integer integer)) + (1 (setq e1 `(cons ,(make-random-integer-form 1) ,e1)) + '(cons integer integer))))) + e1))) + +(defun make-random-integer-binding-form (size) + (destructuring-bind (s1 s2) (random-partition (1- size) 2) + (let* ((var (rcase + (2 (random-from-seq #(v1 v2 v3 v4 v5 v6 v7 v8 v9 v10))) + (2 (random-from-seq #(*s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8*))))) + (e1 (make-random-integer-form s1)) + (type (multiple-value-bind (type2 e) + (make-random-type-for-var var e1) + (setq e1 e) + type2)) + (e2 (let ((*vars* (cons (make-var-desc :name var :type type) + *vars*))) + (make-random-integer-form s2))) + (op (random-from-seq #(let let*)))) + ;; for now, avoid shadowing + (if (member var *vars* :key #'var-desc-name) + (make-random-integer-form size) + (rcase + (8 `(,op ((,var ,e1)) + ,@(rcase (1 `((declare (dynamic-extent ,var)))) + (1 nil)) + ,e2)) + (2 `(multiple-value-bind (,var) ,e1 ,e2))))))) + +(defun make-random-integer-progv-form (size) + (let* ((num-vars (random 4)) + (possible-vars #(*s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8*)) + (vars nil)) + (loop repeat num-vars + do (loop for r = (elt possible-vars (random (length possible-vars))) + while (member r vars) + finally (push r vars))) + (setq vars (remove-if #'(lambda (var) (let ((desc (find var *vars* :key #'var-desc-name))) + (and desc (not (subtypep (var-desc-type desc) 'integer))))) + vars) + num-vars (length vars)) + (if (null vars) + `(progv nil nil ,(make-random-integer-form (1- size))) + (destructuring-bind (s1 s2) (random-partition (1- size) 2) + (let* ((var-sizes (random-partition s1 num-vars)) + (var-forms (mapcar #'make-random-integer-form var-sizes)) + (*vars* (append (loop for v in vars collect + (make-var-desc :name v :type '(integer * *))) + *vars*)) + (body-form (make-random-integer-form s2))) + `(progv ',vars (list ,@var-forms) ,body-form)))))) + +(defun make-random-integer-mapping-form (size) + ;; reduce + (let ((keyargs nil) + (nargs (1+ (random (min 10 (max 1 size))))) + (sequence-op (random-from-seq '(vector list)))) + (when (coin 2) (setq keyargs '(:from-end t))) + (cond + ((coin 2) + (let ((start (random nargs))) + (setq keyargs `(:start ,start ,@keyargs)) + (when (coin 2) + (let ((end (+ start 1 (random (- nargs start))))) + (setq keyargs `(:end ,end ,@keyargs)))))) + (t + (when (coin 2) + (let ((end (1+ (random nargs)))) + (setq keyargs `(:end ,end ,@keyargs)))))) + (rcase + (1 + (let ((sizes (random-partition (1- size) nargs)) + (op (random-from-seq #(+ - * logand logxor logior max min)))) + `(reduce ,(rcase (1 `(function ,op)) + (1 `(quote ,op))) + (,sequence-op + ,@(mapcar #'make-random-integer-form sizes)) + ,@keyargs))) + #-(or armedbear) + (1 + (destructuring-bind (size1 size2) (random-partition (1- size) 2) + (let* ((vars '(lmv1 lmv2 lmv3 lmv4 lmv5 lmv6)) + (var1 (random-from-seq vars)) + (var2 (random-from-seq (remove var1 vars))) + (form (let ((*vars* (list* + (make-var-desc :name var1 :type '(integer * *)) + (make-var-desc :name var2 :type '(integer * *)) + *vars*))) + (make-random-integer-form size1))) + (sizes (random-partition size2 nargs)) + (args (mapcar #'make-random-integer-form sizes))) + `(reduce (function (lambda (,var1 ,var2) ,form)) + (,sequence-op ,@args) + ,@keyargs))))))) + +(defun make-random-integer-setq-form (size) + (if *vars* + (let* ((vdesc (random-from-seq *vars*)) + (var (var-desc-name vdesc)) + (type (var-desc-type vdesc)) + (op (random-from-seq #(setq setf #-(or armedbear)shiftf)))) + (cond + ((subtypep '(integer * *) type) + (assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8)))) + (when (coin 4) + (setq op 'multiple-value-setq) + (setq var (list var))) + `(,op ,var ,(make-random-integer-form (1- size)))) + ((and (consp type) + (eq (car type) 'integer) + (integerp (second type)) + (integerp (third type))) + (assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8)))) + (when (coin 4) + (setq op 'multiple-value-setq) + (setq var (list var))) + `(,op ,var ,(random-from-interval (1+ (third type)) (second type)))) + ((and (subtypep '(array integer nil) type)) + (assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8)))) + (when (eq op 'setq) + (setq op (random-from-seq #(setf shiftf)))) + `(,op (aref ,var) ,(make-random-integer-form (- size 2)))) + ;; Abort -- can't assign + (t (make-random-integer-form size)))) + (make-random-integer-form size))) + + +(defun make-random-integer-case-form (size) + (let ((ncases (1+ (random 10)))) + (if (< (+ size size) (+ ncases 2)) + ;; Too small, give up + (make-random-integer-form size) + (let* ((sizes (random-partition (1- size) (+ ncases 2))) + (bound (ash 1 (+ 2 (random 16)))) + (lower-bound (if (coin 3) 0 (- bound))) + (upper-bound (if (and (< lower-bound 0) (coin 3)) + 1 + (1+ bound))) + (cases + (loop + for case-size in (cddr sizes) + for vals = (loop repeat (1+ (min (random 10) (random 10))) + collect (random-from-interval + upper-bound lower-bound)) + for result = (make-random-integer-form case-size) + repeat ncases + collect `(,vals ,result))) + (expr (make-random-integer-form (first sizes)))) + `(case ,expr + ,@cases + (t ,(make-random-integer-form (second sizes)))))))) + +(defun make-random-flet-form (size) + "Generate random flet, labels forms, for now with no arguments + and a single binding per form." + (let ((fname (random-from-seq #(%f1 %f2 %f3 %f4 %f5 %f6 %f7 %f8 %f9 %f10 + %f11 %f12 %f13 %f14 %f15 %f16 %f17 %f18)))) + (if (assoc fname *flet-names*) + ;; Fail if the name is in use + (make-random-integer-form size) + (let* ((op (random-from-seq #(flet labels))) + (minargs (random 4)) + (maxargs #+:allegro minargs + #-:allegro + (rcase + (1 minargs) + (1 (+ minargs (random 4))))) + (keyarg-p (coin 2)) + (keyarg-n (if keyarg-p (random 3) 0)) + (arg-names (loop for i from 1 to maxargs + collect (fn-arg-name fname i))) + (key-arg-names (loop for i from 1 to keyarg-n + collect (intern (format nil "KEY~A" i) + (find-package "CL-TEST")))) + (allow-other-keys (and keyarg-p (coin 3))) + ) + (destructuring-bind (s1 s2 . opt-sizes) + (random-partition (1- size) (+ 2 keyarg-n (- maxargs minargs))) + (let* ((form1 + ;; Allow return-from of the flet/labels function + (let ((*random-int-form-blocks* + (cons fname *random-int-form-blocks*)) + (*vars* (nconc (loop for var in (append arg-names key-arg-names) + collect (make-var-desc :name var + :type '(integer * *))) + *vars*))) + (make-random-integer-form s1))) + (form2 (let ((*flet-names* (cons (list fname minargs maxargs keyarg-p) + *flet-names*))) + (make-random-integer-form s2))) + (opt-forms (mapcar #'make-random-integer-form opt-sizes))) + (if opt-forms + `(,op ((,fname (,@(subseq arg-names 0 minargs) + &optional + ,@(mapcar #'list + (subseq arg-names minargs) + opt-forms) + ,@(when keyarg-p + (append '(&key) + (mapcar #'list + key-arg-names + (subseq opt-forms (- maxargs minargs))) + (when allow-other-keys '(&allow-other-keys)) + ))) + ,form1)) + ,form2) + `(,op ((,fname (,@arg-names + ,@(when keyarg-p + (append '(&key) + (mapcar #'list + key-arg-names + opt-forms ) + (when allow-other-keys '(&allow-other-keys)) + ))) + ,form1)) + ,form2)))))))) + +(defun make-random-tagbody (size) + (let* ((num-forms (random 6)) + (tags nil)) + (loop for i below num-forms + do (loop for tag = (rcase + #-allegro (1 (random 8)) + (1 (random-from-seq #(tag1 tag2 tag3 tag4 + tag5 tag6 tag7 tag8)))) + while (member tag tags) + finally (push tag tags))) + (assert (= (length (remove-duplicates tags)) (length tags))) + (let* ((*go-tags* (set-difference *go-tags* tags)) + (sizes (if (> num-forms 0) (random-partition (1- size) num-forms) nil)) + (forms + (loop for tag-list on tags + for i below num-forms + for size in sizes + collect (let ((*go-tags* (append tag-list *go-tags*))) + (make-random-integer-form size))))) + `(tagbody ,@(loop for tag in tags + for form in forms + when (atom form) do (setq form `(progn ,form)) + append `(,form ,tag)))))) + +(defun make-random-tagbody-and-progn (size) + (let* ((final-size (random (max 1 (floor size 5)))) + (tagbody-size (- size final-size))) + (let ((final-form (make-random-integer-form final-size)) + (tagbody-form (make-random-tagbody tagbody-size))) + `(progn ,tagbody-form ,final-form)))) + +(defun make-random-pred-form (size) + "Make a random form whose value is to be used as a generalized boolean." + (if (<= size 1) + (rcase + (1 (if (coin) t nil)) + (2 + `(,(random-from-seq '(< <= = > >= /= eql equal)) + ,(make-random-integer-form size) + ,(make-random-integer-form size)))) + (rcase + (1 (if (coin) t nil)) + (3 `(not ,(make-random-pred-form (1- size)))) + (6 (destructuring-bind (leftsize rightsize) + (random-partition (1- size) 2) + `(,(random-from-seq '(and or)) + ,(make-random-pred-form leftsize) + ,(make-random-pred-form rightsize)))) + (1 (destructuring-bind (leftsize rightsize) + (random-partition (1- size) 2) + `(,(random-from-seq '(< <= > >= = /= eql equal)) + ,(make-random-integer-form leftsize) + ,(make-random-integer-form rightsize)))) + (3 (let* ((cond-size (random (max 1 (floor size 2)))) + (then-size (random (- size cond-size))) + (else-size (- size 1 cond-size then-size)) + (pred (make-random-pred-form cond-size)) + (then-part (make-random-pred-form then-size)) + (else-part (make-random-pred-form else-size))) + `(if ,pred ,then-part ,else-part))) + (1 (destructuring-bind (s1 s2) + (random-partition (1- size) 2) + `(ldb-test ,(make-random-byte-spec-form s1) + ,(make-random-integer-form s2)))) + (1 (let ((index (random (1+ (random *maximum-random-int-bits*)))) + (form (make-random-integer-form (1- size)))) + `(logbitp ,index ,form))) + (1 ;; typep form + (let ((subform (make-random-integer-form (- size 2))) + (type + (rcase + (1 `(integer ,@(make-random-integer-range))) + (1 `(integer ,(make-random-integer))) + (1 `(integer * ,(make-random-integer))) + (1 `(integer))))) + `(typep ,subform ',type))) + ))) + +(defun make-random-loop-form (size) + (if (<= size 2) + (make-random-integer-form size) + (let* ((var (random-from-seq #(lv1 lv2 lv3 lv4))) + (count (random 4)) + (*vars* (cons (make-var-desc :name var :type nil) + *vars*))) + (rcase + (1 `(loop for ,var below ,count count ,(make-random-pred-form (- size 2)))) + (1 `(loop for ,var below ,count sum ,(make-random-integer-form (- size 2)))) + )))) + +(defun make-random-byte-spec-form (size) + (declare (ignore size)) + (let* ((pform (random 33)) + (sform (1+ (random 33)))) + `(byte ,sform ,pform))) + +(defun make-random-element-of-type (type) + "Create a random element of a lisp type." + (cond + ((consp type) + (let ((type-op (first type))) + (ecase type-op + (integer + (let ((lo (let ((lo (cadr type))) + (cond + ((consp lo) (1+ (car lo))) + ((eq lo nil) '*) + (t lo)))) + (hi (let ((hi (caddr type))) + (cond + ((consp hi) (1- (car hi))) + ((eq hi nil) '*) + (t hi))))) + (if (eq lo '*) + (if (eq hi '*) + (let ((x (ash 1 (random *maximum-random-int-bits*)))) + (random-from-interval x (- x))) + (random-from-interval (1+ hi) + (- hi (random (ash 1 *maximum-random-int-bits*))))) + + (if (eq hi '*) + (random-from-interval (+ lo (random (ash 1 *maximum-random-int-bits*)) 1) + lo) + ;; May generalize the next case to increase odds + ;; of certain integers (near 0, near endpoints, near + ;; powers of 2...) + (random-from-interval (1+ hi) lo))))) + (mod + (let ((modulus (second type))) + (assert (and (integerp modulus) + (plusp modulus))) + (make-random-element-of-type `(integer 0 (,modulus))))) + (unsigned-byte + (if (null (cdr type)) + (make-random-element-of-type '(integer 0 *)) + (let ((bits (second type))) + (if (eq bits'*) + (make-random-element-of-type '(integer 0 *)) + (progn + (assert (and (integerp bits) (>= bits 1))) + (make-random-element-of-type + `(integer 0 ,(1- (ash 1 bits))))))))) + ))) + (t + (ecase type + (bit (random 2)) + (boolean (random-from-seq #(nil t))) + (symbol (random-from-seq #(nil t a b c :a :b :c |z| foo |foo| cl:car))) + (unsigned-byte (random-from-interval + (1+ (ash 1 (random *maximum-random-int-bits*))) 0)) + (integer (let ((x (ash 1 (random *maximum-random-int-bits*)))) + (random-from-interval (1+ x) (- x)))) + )))) + +(defun make-optimized-lambda-form (form vars var-types opt-decls) + `(lambda ,vars + ,@(mapcar #'(lambda (tp var) `(declare (type ,tp ,var))) + var-types vars) + (declare (ignorable ,@vars)) + #+cmu (declare (optimize (extensions:inhibit-warnings 3))) + (declare (optimize ,@opt-decls)) + ,form)) + +(defun make-unoptimized-lambda-form (form vars var-types opt-decls) + (declare (ignore var-types)) + `(lambda ,vars + (declare (notinline ,@(fn-symbols-in-form form))) + #+cmu (declare (optimize (extensions:inhibit-warnings 3))) + (declare (optimize ,@opt-decls)) + ,form)) + +(defvar *compile-using-defun* + #-(or allegro lispworks) nil + #+(or allegro lispworks) t) +(defvar *name-to-use-in-optimized-defun* 'dummy-fn-name1) +(defvar *name-to-use-in-unoptimized-defun* 'dummy-fn-name2) + +(defun test-int-form (form vars var-types vals-list opt-decls-1 opt-decls-2) + ;; Try to compile FORM with associated VARS, and if it compiles + ;; check for equality of the two compiled forms. + ;; Return a non-nil list of details if a problem is found, + ;; NIL otherwise. + (let ((optimized-fn-src (make-optimized-lambda-form form vars var-types opt-decls-1)) + (unoptimized-fn-src (make-unoptimized-lambda-form form vars var-types opt-decls-2))) + (setq *int-form-vals* nil + *optimized-fn-src* optimized-fn-src + *unoptimized-fn-src* unoptimized-fn-src) + (flet ((%compile + (lambda-form opt-defun-name) + (cl:handler-bind + (#+sbcl (sb-ext::compiler-note #'muffle-warning) + (warning #'muffle-warning) + (error #'(lambda (c) + (format t "Compilation failure~%~A~%" + (format nil "~S" form)) + (finish-output *standard-output*) + (return-from test-int-form + (list (list :vars vars + :form form + :var-types var-types + :vals (first vals-list) + :lambda-form lambda-form + :decls1 opt-decls-1 + :decls2 opt-decls-2 + :compiler-condition + (with-output-to-string + (s) + (prin1 c s)))))))) + (let ((start-time (get-universal-time))) + (prog1 + (if *compile-using-defun* + (progn + (eval `(defun ,opt-defun-name + ,@(cdr lambda-form))) + (compile opt-defun-name) + (symbol-function opt-defun-name)) + (compile nil lambda-form)) + (let* ((stop-time (get-universal-time)) + (total-time (- stop-time start-time))) + (when (> total-time *max-compile-time*) + (setf *max-compile-time* total-time) + (setf *max-compile-term* lambda-form))) + ;; #+:ecl (si:gc t) + ))))) + (let ((optimized-compiled-fn (%compile optimized-fn-src + *name-to-use-in-optimized-defun*)) + (unoptimized-compiled-fn + (if *compile-unoptimized-form* + (%compile unoptimized-fn-src *name-to-use-in-unoptimized-defun*) + (eval `(function ,unoptimized-fn-src))))) + (declare (type function optimized-compiled-fn unoptimized-compiled-fn)) + (dolist (vals vals-list) + (setq *int-form-vals* vals) + (flet ((%eval-error + (kind) + (let ((*print-circle* t)) + (format t "~A~%" (format nil "~S" form))) + (finish-output *standard-output*) + (return + (list (list :vars vars + :vals vals + :form form + :var-types var-types + :decls1 opt-decls-1 + :decls2 opt-decls-2 + :optimized-lambda-form optimized-fn-src + :unoptimized-lambda-form unoptimized-fn-src + :kind kind))))) + + (let ((unopt-result + (cl:handler-case + (cl:handler-bind + (#+sbcl (sb-ext::compiler-note #'muffle-warning) + (warning #'muffle-warning)) + (identity ;; multiple-value-list + (apply unoptimized-compiled-fn vals))) + ((or error serious-condition) + (c) + (%eval-error (list :unoptimized-form-error + (with-output-to-string + (s) (prin1 c s))))))) + (opt-result + (cl:handler-case + (cl:handler-bind + (#+sbcl (sb-ext::compiler-note #'muffle-warning) + (warning #'muffle-warning)) + (identity ;; multiple-value-list + (apply optimized-compiled-fn vals))) + ((or error serious-condition) + (c) + (%eval-error (list :optimized-form-error + (with-output-to-string + (s) (prin1 c s)))))))) + (if (equal opt-result unopt-result) + nil + (progn + (format t "Different results: ~A, ~A~%" + opt-result unopt-result) + (setq *opt-result* opt-result + *unopt-result* unopt-result) + (%eval-error (list :different-results + opt-result + unopt-result))))))))))) + +;;; Interface to the form pruner + +(declaim (special *prune-table*)) + +(defun prune-int-form (input-form vars var-types vals-list opt-decls-1 opt-decls-2) + "Conduct tests on selected simplified versions of INPUT-FORM. Return the + minimal form that still causes some kind of failure." + (loop do + (let ((form input-form)) + (flet ((%try-fn (new-form) + (when (test-int-form new-form vars var-types vals-list + opt-decls-1 opt-decls-2) + (setf form new-form) + (throw 'success nil)))) + (let ((*prune-table* (make-hash-table :test #'eq))) + (loop + (catch 'success + (prune form #'%try-fn) + (return form))))) + (when (equal form input-form) (return form)) + (setq input-form form)))) + +(defun prune-results (result-list) + "Given a list of test results, prune their forms down to a minimal set." + (loop for result in result-list + collect + (let* ((form (getf result :form)) + (vars (getf result :vars)) + (var-types (getf result :var-types)) + (vals-list (list (getf result :vals))) + (opt-decl-1 (getf result :decls1)) + (opt-decl-2 (getf result :decls2)) + (pruned-form (prune-int-form form vars var-types vals-list opt-decl-1 opt-decl-2)) + (optimized-lambda-form (make-optimized-lambda-form + pruned-form vars var-types opt-decl-1)) + (unoptimized-lambda-form (make-unoptimized-lambda-form + pruned-form vars var-types opt-decl-2))) + `(:vars ,vars + :var-types ,var-types + :vals ,(first vals-list) + :form ,pruned-form + :decls1 ,opt-decl-1 + :decls2 ,opt-decl-2 + :optimized-lambda-form ,optimized-lambda-form + :unoptimized-lambda-form ,unoptimized-lambda-form)))) + +;;; +;;; The call (PRUNE form try-fn) attempts to simplify the lisp form +;;; so that it still satisfies TRY-FN. The function TRY-FN should +;;; return if the substitution is a failure. Otherwise, it should +;;; transfer control elsewhere via GO, THROW, etc. +;;; +;;; The return value of PRUNE should be ignored. +;;; +(defun prune (form try-fn) + (declare (type function try-fn)) + (when (gethash form *prune-table*) + (return-from prune nil)) + (flet ((try (x) (funcall try-fn x))) + (cond + ((keywordp form) nil) + ((integerp form) + (unless (zerop form) (try 0))) + ((consp form) + (let* ((op (car form)) + (args (cdr form)) + (nargs (length args))) + (case op + + ((quote) nil) + + ((go) + (try 0)) + + ((signum integer-length logcount + logandc1 logandc2 lognand lognor logorc1 logorc2 + realpart imagpart) + (try 0) + (mapc try-fn args) + (prune-fn form try-fn)) + + ((make-array) + (when (and (eq (car args) nil) + (eq (cadr args) ':initial-element) + ; (null (cdddr args)) + ) + (prune (caddr args) #'(lambda (form) (try `(make-array nil :initial-element ,form . ,(cdddr args))))) + (when (cdddr args) + (try `(make-array nil :initial-element ,(caddr args)))) + )) + + ((cons) + (prune-fn form try-fn)) + + ((dotimes) + (try 0) + (let* ((binding-form (first args)) + (body (rest args)) + (var (first binding-form)) + (count-form (second binding-form)) + (result (third binding-form))) + (try result) + (unless (eql count-form 0) + (try `(dotimes (,var 0 ,result) ,@body))) + (prune result #'(lambda (form) + (try `(dotimes (,var ,count-form ,form) ,@body)))) + (when (= (length body) 1) + (prune (first body) + #'(lambda (form) + (when (consp form) + (try `(dotimes (,var ,count-form ,result) ,form)))))))) + + ((abs 1+ 1-) + (try 0) + (mapc try-fn args) + (prune-fn form try-fn)) + + ((identity values ignore-errors cl:handler-case restart-case locally) + (unless (and (consp args) + (consp (car args)) + (eql (caar args) 'tagbody)) + (mapc try-fn args)) + (prune-fn form try-fn)) + + ((boole) + (try (second args)) + (try (third args)) + (prune (second args) + #'(lambda (form) (try `(boole ,(first args) ,form ,(third args))))) + (prune (third args) + #'(lambda (form) (try `(boole ,(first args) ,(second args) ,form))))) + + ((unwind-protect prog1 multiple-value-prog1) + (try (first args)) + (let ((val (first args)) + (rest (rest args))) + (when rest + (try `(unwind-protect ,val)) + (when (cdr rest) + (loop for i from 0 below (length rest) + do + (try `(unwind-protect ,val + ,@(subseq rest 0 i) + ,@(subseq rest (1+ i)))))))) + (prune-fn form try-fn)) + + ((prog2) + (assert (>= (length args) 2)) + (let ((val1 (first args)) + (arg2 (second args)) + (rest (cddr args))) + (try arg2) + (prune-fn form try-fn) + (when rest + (try `(prog2 ,val1 ,arg2)) + (when (cdr rest) + (loop for i from 0 below (length rest) + do + (try `(prog2 ,val1 ,arg2 + ,@(subseq rest 0 i) + ,@(subseq rest (1+ i))))))))) + + ((typep) + (try (car args)) + (prune (car args) + #'(lambda (form) `(,op ,form ,@(cdr args))))) + + ((load-time-value) + (let ((arg (first args))) + (try arg) + (cond + ((cdr args) + (try `(load-time-value ,arg)) + (prune arg + #'(lambda (form) + (try `(load-time-value ,form ,(second args)))))) + (t + (prune arg + #'(lambda (form) + (try `(load-time-value ,form)))))))) + + ((eval) + (try 0) + (let ((arg (first args))) + (cond + ((consp arg) + (cond + ((eql (car arg) 'quote) + (prune (cadr arg) #'(lambda (form) (try `(eval ',form))))) + (t + (try arg) + (prune arg #'(lambda (form) `(eval ,form)))))) + (t (try arg))))) + + ((the macrolet cl:handler-bind restart-bind) + (assert (= (length args) 2)) + (try (second args)) + (prune (second args) try-fn)) + + ((not eq eql equal) + (when (every #'constantp args) + (try (eval form))) + (try t) + (try nil) + (mapc try-fn args) + (prune-fn form try-fn) + ) + + ((and or = < > <= >= /=) + (when (every #'constantp args) + (try (eval form))) + (try t) + (try nil) + (mapc try-fn args) + (prune-nary-fn form try-fn) + (prune-fn form try-fn)) + + ((- + * min max logand logior logxor logeqv gcd lcm) + (when (every #'constantp args) + (try (eval form))) + (try 0) + (mapc try-fn args) + (prune-nary-fn form try-fn) + (prune-fn form try-fn)) + + ((/) + (when (every #'constantp args) + (try (eval form))) + (try 0) + (try (car args)) + (when (cddr args) + (prune (car args) #'(lambda (form) (try `(/ ,form ,(second args))))))) + + ((multiple-value-call) + ;; Simplify usual case + (when (= nargs 2) + (destructuring-bind (arg1 arg2) args + (when (and (consp arg1) (consp arg2) + (eql (first arg1) 'function) + (eql (first arg2) 'values)) + (mapc try-fn (rest arg2)) + (let ((fn (second arg1))) + (when (symbolp fn) + (try `(,fn ,@(rest arg2))))) + ;; Prune the VALUES form + (prune-list (rest arg2) + #'prune + #'(lambda (args) + (try `(multiple-value-call ,arg1 (values ,@args))))) + ))) + (mapc try-fn (rest args))) + + ((bit sbit elt aref svref) + (try 0) + (when (= (length args) 2) + (let ((arg1 (car args)) + (arg2 (cadr args))) + (when (and (consp arg2) + (eql (car arg2) 'min) + (integerp (cadr arg2))) + (let ((arg2.2 (caddr arg2))) + (when (and (consp arg2.2) + (eql (car arg2.2) 'max) + (integerp (cadr arg2.2))) + (prune (caddr arg2.2) + #'(lambda (form) + (try `(,op ,arg1 (min ,(cadr arg2) + (max ,(cadr arg2.2) ,form)))))))))))) + + ((car cdr) + (try 0) + (try 1)) + + ((if) + (let (;; (pred (first args)) + (then (second args)) + (else (third args))) + (try then) + (try else) + (when (every #'constantp args) + (try (eval form))) + (prune-fn form try-fn))) + + ((setq setf shiftf) + (try 0) + ;; Assumes only one assignment + (assert (= (length form) 3)) + (try (second args)) + (unless (integerp (second args)) + (prune (second args) + #'(lambda (form) + (try `(,op ,(first args) ,form)))))) + + ((multiple-value-setq) + (try 0) + ;; Assumes only one assignment, and one variable + (assert (= (length form) 3)) + (assert (= (length (first args)) 1)) + (try `(setq ,(caar args) ,(cadr args))) + (unless (integerp (second args)) + (prune (second args) + #'(lambda (form) + (try `(,op ,(first args) ,form)))))) + + ((byte) + (prune-fn form try-fn)) + + ((deposit-field dpb) + (try 0) + (destructuring-bind (a1 a2 a3) + args + (try a1) + (try a3) + (when (and (integerp a1) + (integerp a3) + (and (consp a2) + (eq (first a2) 'byte) + (integerp (second a2)) + (integerp (third a2)))) + (try (eval form)))) + (prune-fn form try-fn)) + + ((ldb mask-field) + (try 0) + (try (second args)) + (when (and (consp (first args)) + (eq 'byte (first (first args))) + (every #'numberp (cdr (first args))) + (numberp (second args))) + (try (eval form))) + (prune-fn form try-fn)) + + ((ldb-test) + (try t) + (try nil) + (prune-fn form try-fn)) + + ((let let*) + (prune-let form try-fn)) + + ((multiple-value-bind) + (assert (= (length args) 3)) + (let ((arg1 (first args)) + (arg2 (second args)) + (body (caddr args))) + (when (= (length arg1) 1) + (try `(let ((,(first arg1) ,arg2)) ,body))) + (prune arg2 #'(lambda (form) + (try `(multiple-value-bind ,arg1 ,form ,body)))) + (prune body #'(lambda (form) + (try `(multiple-value-bind ,arg1 ,arg2 ,form)))))) + + ((block) + (let ((name (second form)) + (body (cddr form))) + (when (and body (null (cdr body))) + (let ((form1 (first body))) + + ;; Try removing the block entirely if it is not in use + (when (not (find-in-tree name body)) + (try form1)) + + ;; Try removing the block if its only use is an immediately + ;; enclosed return-from: (block (return-from )) + (when (and (consp form1) + (eq (first form1) 'return-from) + (eq (second form1) name) + (not (find-in-tree name (third form1)))) + (try (third form1))) + + ;; Otherwise, try to simplify the subexpression + (prune form1 + #'(lambda (x) + (try `(block ,name ,x)))))))) + + ((catch) + (let* ((tag (second form)) + (name (if (consp tag) (cadr tag) tag)) + (body (cddr form))) + (when (and body (null (cdr body))) + (let ((form1 (first body))) + + ;; Try removing the catch entirely if it is not in use + ;; We make assumptions here about what throws can + ;; be present. + (when (or (not (find-in-tree 'throw body)) + (not (find-in-tree name body))) + (try form1)) + + ;; Try removing the block if its only use is an immediately + ;; enclosed return-from: (block (return-from )) + (when (and (consp form1) + (eq (first form1) 'throw) + (equal (second form1) name) + (not (find-in-tree name (third form1)))) + (try (third form1))) + + ;; Otherwise, try to simplify the subexpression + (prune form1 + #'(lambda (x) + (try `(catch ,tag ,x)))))))) + + ((throw) + (try (second args)) + (prune (second args) + #'(lambda (x) (try `(throw ,(first args) ,x))))) + + ((flet labels) + (try 0) + (prune-flet form try-fn)) + + ((case) + (prune-case form try-fn)) + + ((isqrt) + (let ((arg (second form))) + (assert (null (cddr form))) + (assert (consp arg)) + (assert (eq (first arg) 'abs)) + (let ((arg2 (second arg))) + (try arg2) + ;; Try to fold + (when (integerp arg2) + (try (isqrt (abs arg2)))) + ;; Otherwise, simplify arg2 + (prune arg2 #'(lambda (form) + (try `(isqrt (abs ,form)))))))) + + ((ash) + (try 0) + (let ((form1 (second form)) + (form2 (third form))) + (try form1) + (try form2) + (prune form1 + #'(lambda (form) + (try `(ash ,form ,form2)))) + (when (and (consp form2) + (= (length form2) 3)) + (when (and (integerp form1) + (eq (first form2) 'min) + (every #'integerp (cdr form2))) + (try (eval form))) + (let ((form3 (third form2))) + (prune form3 + #'(lambda (form) + (try + `(ash ,form1 (,(first form2) ,(second form2) + ,form))))))))) + + ((floor ceiling truncate round mod rem) + (try 0) + (let ((form1 (second form)) + (form2 (third form))) + (try form1) + (when (cddr form) (try form2)) + (prune form1 + (if (cddr form) + #'(lambda (form) + (try `(,op ,form ,form2))) + #'(lambda (form) (try `(,op ,form))))) + (when (and (consp form2) + (= (length form2) 3)) + (when (and (integerp form1) + (member (first form2) '(max min)) + (every #'integerp (cdr form2))) + (try (eval form))) + (let ((form3 (third form2))) + (prune form3 + #'(lambda (form) + (try + `(,op ,form1 (,(first form2) ,(second form2) + ,form))))))))) + + ((constantly) + (unless (eql (car args) 0) + (prune (car args) + #'(lambda (arg) (try `(constantly ,arg)))))) + + ((funcall) + (try 0) + (let ((fn (second form)) + (fn-args (cddr form))) + (mapc try-fn fn-args) + (unless (equal fn '(constantly 0)) + (try `(funcall (constantly 0) ,@fn-args))) + (when (and (consp fn) + (eql (car fn) 'function) + (symbolp (cadr fn))) + (try `(,(cadr fn) ,@fn-args))) + (prune-list fn-args + #'prune + #'(lambda (args) + (try `(funcall ,fn ,@args)))))) + + ((reduce) + (try 0) + (let ((arg1 (car args)) + (arg2 (cadr args)) + (rest (cddr args))) + (when (and ;; (null (cddr args)) + (consp arg1) + (eql (car arg1) 'function)) + (let ((arg1.2 (cadr arg1))) + (when (and (consp arg1.2) + (eql (car arg1.2) 'lambda)) + (let ((largs (cadr arg1.2)) + (body (cddr arg1.2))) + (when (null (cdr body)) + (prune (car body) + #'(lambda (bform) + (try `(reduce (function (lambda ,largs ,bform)) + ,arg2 ,@rest))))))))) + (when (consp arg2) + (case (car arg2) + ((list vector) + (let ((arg2.rest (cdr arg2))) + (mapc try-fn arg2.rest) + (prune-list arg2.rest + #'prune + #'(lambda (args) + (try `(reduce ,arg1 + (,(car arg2) ,@args) + ,@rest)))))))))) + + ((apply) + (try 0) + (let ((fn (second form)) + (fn-args (butlast (cddr form))) + (list-arg (car (last form)))) + (mapc try-fn fn-args) + (unless (equal fn '(constantly 0)) + (try `(apply (constantly 0) ,@(cddr form)))) + (when (and (consp list-arg) + (eq (car list-arg) 'list)) + (mapc try-fn (cdr list-arg))) + (prune-list fn-args + #'prune + #'(lambda (args) + (try `(apply ,fn ,@args ,list-arg)))) + (when (and (consp list-arg) + (eq (car list-arg) 'list)) + (try `(apply ,fn ,@fn-args ,@(cdr list-arg) nil)) + (prune-list (cdr list-arg) + #'prune + #'(lambda (args) + (try `(apply ,fn ,@fn-args + (list ,@args)))))))) + + ((progv) + (try 0) + (prune-progv form try-fn)) + + ((tagbody) + (try 0) + (prune-tagbody form try-fn)) + + ((progn) + (when (null args) (try nil)) + (try (car (last args))) + (loop for i from 0 below (1- (length args)) + for a in args + do (try `(progn ,@(subseq args 0 i) + ,@(subseq args (1+ i)))) + do (when (and (consp a) + (or + (eq (car a) 'progn) + (and (eq (car a) 'tagbody) + (every #'consp (cdr a))))) + (try `(progn ,@(subseq args 0 i) + ,@(copy-list (cdr a)) + ,@(subseq args (1+ i)))))) + (prune-fn form try-fn)) + + ((loop) + (try 0) + (when (and (eql (length args) 6) + (eql (elt args 0) 'for) + (eql (elt args 2) 'below)) + (let ((var (elt args 1)) + (count (elt args 3)) + (form (elt args 5))) + (unless (eql count 0) (try count)) + (case (elt args 4) + (sum + (try `(let ((,(elt args 1) 0)) ,(elt args 5))) + (prune form #'(lambda (form) + (try `(loop for ,var below ,count sum ,form))))) + (count + (unless (or (eql form t) (eql form nil)) + (try `(loop for ,var below ,count count t)) + (try `(loop for ,var below ,count count nil)) + (prune form + #'(lambda (form) + (try `(loop for ,var below ,count count ,form)))))) + )))) + + (otherwise + (try 0) + (prune-fn form try-fn)) + + ))))) + (setf (gethash form *prune-table*) t) + nil) + +(defun find-in-tree (value tree) + "Return true if VALUE is eql to a node in TREE." + (or (eql value tree) + (and (consp tree) + (or (find-in-tree value (car tree)) + (find-in-tree value (cdr tree)))))) + +(defun prune-list (list element-prune-fn list-try-fn) + (declare (type function element-prune-fn list-try-fn)) + "Utility function for pruning in a list." + (loop for i from 0 + for e in list + do (funcall element-prune-fn + e + #'(lambda (form) + (funcall list-try-fn + (append (subseq list 0 i) + (list form) + (subseq list (1+ i)))))))) + +(defun prune-case (form try-fn) + (declare (type function try-fn)) + (flet ((try (e) (funcall try-fn e))) + (let* ((op (first form)) + (expr (second form)) + (cases (cddr form))) + + ;; Try just the top expression + (try expr) + + ;; Try simplifying the expr + (prune expr + #'(lambda (form) + (try `(,op ,form ,@cases)))) + + ;; Try individual cases + (loop for case in cases + do (try (first (last (rest case))))) + + ;; Try deleting individual cases + (loop for i from 0 below (1- (length cases)) + do (try `(,op ,expr + ,@(subseq cases 0 i) + ,@(subseq cases (1+ i))))) + + ;; Try simplifying the cases + ;; Assume each case has a single form + (prune-list cases + #'(lambda (case try-fn) + (declare (type function try-fn)) + (when (eql (length case) 2) + (prune (cadr case) + #'(lambda (form) + (funcall try-fn + (list (car case) form)))))) + #'(lambda (cases) + (try `(,op ,expr ,@cases))))))) + +(defun prune-tagbody (form try-fn) + (declare (type function try-fn)) + (let (;; (op (car form)) + (body (cdr form))) + (loop for i from 0 + for e in body + do + (cond + ((atom e) + ;; A tag + (unless (find-in-tree e (subseq body 0 i)) + (funcall try-fn `(tagbody ,@(subseq body 0 i) + ,@(subseq body (1+ i)))))) + (t + (funcall try-fn + `(tagbody ,@(subseq body 0 i) + ,@(subseq body (1+ i)))) + (prune e + #'(lambda (form) + ;; Don't put an atom here. + (when (consp form) + (funcall + try-fn + `(tagbody ,@(subseq body 0 i) + ,form + ,@(subseq body (1+ i)))))))))))) + +(defun prune-progv (form try-fn) + (declare (type function try-fn)) + (let (;; (op (car form)) + (vars-form (cadr form)) + (vals-form (caddr form)) + (body-list (cdddr form))) + (when (and (null vars-form) (null vals-form)) + (funcall try-fn `(let () ,@body-list))) + (when (and (consp vals-form) (eql (car vals-form) 'list)) + (when (and (consp vars-form) (eql (car vars-form) 'quote)) + (let ((vars (cadr vars-form)) + (vals (cdr vals-form))) + (when (eql (length vars) (length vals)) + (let ((let-form `(let () ,@body-list))) + (mapc #'(lambda (var val) + (setq let-form `(let ((,var ,val)) ,let-form))) + vars vals) + (funcall try-fn let-form))) + ;; Try simplifying the vals forms + (prune-list vals + #'prune + #'(lambda (vals) + (funcall try-fn + `(progv ,vars-form (list ,@vals) ,@body-list))))))) + ;; Try simplifying the body + (when (eql (length body-list) 1) + (prune (car body-list) + #'(lambda (form) + (funcall try-fn + `(progv ,vars-form ,vals-form ,form))))))) + +(defun prune-nary-fn (form try-fn) + ;; Attempt to reduce the number of arguments to the fn + ;; Do not reduce below 1 + (declare (type function try-fn)) + (let* ((op (car form)) + (args (cdr form)) + (nargs (length args))) + (when (> nargs 1) + (loop for i from 1 to nargs + do (funcall try-fn `(,op ,@(subseq args 0 (1- i)) + ,@(subseq args i))))))) + +(defun prune-fn (form try-fn) + "Attempt to simplify a function call form. It is considered + acceptable to replace the call by one of its argument forms." + (declare (type function try-fn)) + (prune-list (cdr form) + #'prune + #'(lambda (args) + (funcall try-fn (cons (car form) args))))) + +(defun prune-let (form try-fn) + "Attempt to simplify a LET form." + (declare (type function try-fn)) + (let* ((op (car form)) + (binding-list (cadr form)) + (body (cddr form)) + ;; (body-len (length body)) + ;; (len (length binding-list)) + ) + + ;; Try to simplify (let (( )) ...) to + #| + (when (and (>= len 1) + ;; (eql body-len 1) + ;; (eql (caar binding-list) (car body)) + ) + (let ((val-form (cadar binding-list))) + (unless (and (consp val-form) + (eql (car val-form) 'make-array)) + (funcall try-fn val-form)))) + |# + + ;; Try to simplify the forms in the RHS of the bindings + (prune-list binding-list + #'(lambda (binding try-fn) + (declare (type function try-fn)) + (prune (cadr binding) + #'(lambda (form) + (funcall try-fn + (list (car binding) + form))))) + #'(lambda (bindings) + (funcall try-fn `(,op ,bindings ,@body)))) + + ;; Try to simplify the body of the LET form + (when body + (unless binding-list + (funcall try-fn (car (last body)))) + (when (and (first binding-list) + (not (rest binding-list)) + (not (rest body))) + (let ((binding (first binding-list))) + (unless (or (consp (second binding)) + (has-binding-to-var (first binding) body) + (has-assignment-to-var (first binding) body) + ) + (funcall try-fn `(let () + ,@(subst (second binding) + (first binding) + (remove-if #'(lambda (x) (and (consp x) (eq (car x) 'declare))) + body) + )))))) + (prune (car (last body)) + #'(lambda (form2) + (funcall try-fn + `(,@(butlast form) ,form2))))))) + +(defun has-assignment-to-var (var form) + (find-if-subtree + #'(lambda (form) + (and (consp form) + (or + (and (member (car form) '(setq setf shiftf) :test #'eq) + (eq (cadr form) var)) + (and (eql (car form) 'multiple-value-setq) + (member var (cadr form)))))) + form)) + +(defun has-binding-to-var (var form) + (find-if-subtree + #'(lambda (form) + (and (consp form) + (case (car form) + ((let let*) + (loop for binding in (cadr form) + thereis (eq (car binding) var))) + ((progv) + (and (consp (cadr form)) + (eq (caadr form) 'quote) + (consp (second (cadr form))) + (member var (second (cadr form))))) + (t nil)))) + form)) + +(defun find-if-subtree (pred tree) + (declare (type function pred)) + (cond + ((funcall pred tree) tree) + ((consp tree) + (or (find-if-subtree pred (car tree)) + (find-if-subtree pred (cdr tree)))) + (t nil))) + +(defun prune-flet (form try-fn) + "Attempt to simplify a FLET form." + (declare (type function try-fn)) + + (let* ((op (car form)) + (binding-list (cadr form)) + (body (cddr form))) + + ;; Remove a declaration, if any + (when (and (consp body) + (consp (car body)) + (eq (caar body) 'declare)) + (funcall try-fn `(,op ,binding-list ,@(cdr body)))) + + ;; Try to prune optional arguments + (prune-list binding-list + #'(lambda (binding try-fn) + (declare (type function try-fn)) + (let* ((name (car binding)) + (args (cadr binding)) + (body (cddr binding)) + (opt-pos (position-if #'(lambda (e) (member e '(&key &optional))) + (the list args)))) + (when opt-pos + (incf opt-pos) + (let ((normal-args (subseq args 0 (1- opt-pos))) + (optionals (subseq args opt-pos))) + (prune-list optionals + #'(lambda (opt-lambda-arg try-fn) + (declare (type function try-fn)) + (when (consp opt-lambda-arg) + (let ((name (first opt-lambda-arg)) + (form (second opt-lambda-arg))) + (prune form + #'(lambda (form) + (funcall try-fn (list name form))))))) + #'(lambda (opt-args) + (funcall try-fn + `(,name (,@normal-args + &optional + ,@opt-args) + ,@body)))))))) + #'(lambda (bindings) + (funcall try-fn `(,op ,bindings ,@body)))) + + + ;; Try to simplify the forms in the RHS of the bindings + (prune-list binding-list + #'(lambda (binding try-fn) + (declare (type function try-fn)) + + ;; Prune body of a binding + (prune (third binding) + #'(lambda (form) + (funcall try-fn + (list (first binding) + (second binding) + form))))) + #'(lambda (bindings) + (funcall try-fn `(,op ,bindings ,@body)))) + + ;; ;; Try to simplify the body of the FLET form + (when body + + ;; No bindings -- try to simplify to the last form in the body + (unless binding-list + (funcall try-fn (first (last body)))) + + (when (and (consp binding-list) + (null (rest binding-list))) + (let ((binding (first binding-list))) + ;; One binding -- match on (flet (( () )) ()) + (when (and (symbolp (first binding)) + (not (find-in-tree (first binding) (rest binding))) + (null (second binding)) + (equal body (list (list (first binding))))) + (funcall try-fn `(,op () ,@(cddr binding)))) + ;; One binding -- try to remove it if not used + (when (and (symbolp (first binding)) + (not (find-in-tree (first binding) body))) + (funcall try-fn (first (last body)))) + )) + + + ;; Try to simplify (the last form in) the body. + (prune (first (last body)) + #'(lambda (form2) + (funcall try-fn + `(,@(butlast form) ,form2))))))) + +;;; Routine to walk form, applying a function at each form +;;; The fn is applied in preorder. When it returns :stop, do +;;; not descend into subforms + +#| +(defun walk (form fn) + (declare (type function fn)) + (unless (eq (funcall fn form) :stop) + (when (consp form) + (let ((op (car form))) + (case op + ((let let*) + (walk-let form fn)) + ((cond) + (dolist (clause (cdr form)) + (walk-implicit-progn clause fn))) + ((multiple-value-bind) + (walk (third form) fn) + (walk-body (cdddr form) fn)) + ((function quote declare) nil) + ((block the return-from) + (walk-implicit-progn (cddr form) fn)) + ((case typecase) + (walk (cadr form) fn) + (dolist (clause (cddr form)) + (walk-implicit-progn (cdr clause) fn))) + ((flet labels) + + + + +|# + +;;;;;;;;;;;;;;;;;;;;;; +;;; Convert pruned results to test cases + +(defun produce-test-cases (instances &key + (stream *standard-output*) + (prefix "MISC.") + (index 1)) + (dolist (inst instances) + (let* (;; (vars (getf inst :vars)) + (vals (getf inst :vals)) + (optimized-lambda-form (getf inst :optimized-lambda-form)) + (unoptimized-lambda-form (getf inst :unoptimized-lambda-form)) + (name (intern + (concatenate 'string prefix (format nil "~D" index)) + "CL-TEST")) + (test-form + `(deftest ,name + (let* ((fn1 ',optimized-lambda-form) + (fn2 ',unoptimized-lambda-form) + (vals ',vals) + (v1 (apply (compile nil fn1) vals)) + (v2 (apply (compile nil fn2) vals))) + (if (eql v1 v2) + :good + (list v1 v2))) + :good))) + (print test-form stream) + (terpri stream) + (incf index))) + (values)) diff --git a/ansi-tests/random-intern.lsp b/ansi-tests/random-intern.lsp new file mode 100644 index 0000000..80bda18 --- /dev/null +++ b/ansi-tests/random-intern.lsp @@ -0,0 +1,72 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Contains: Code to randomly intern and unintern random strings +;;;; in a package. Exercises package and hash table routines + +(in-package :cl-test) + +(defconstant +max-len-random-symbol+ 63) + +(defun make-random-symbol (package) + (declare (optimize (speed 3) (safety 3))) + (loop + (let* ((len (random (1+ +max-len-random-symbol+))) + (str (make-string len))) + (declare (type (integer 0 #.+max-len-random-symbol+) len)) + (loop + for i from 0 to (1- len) do + (setf (schar str i) + (schar +base-chars+ + (random +num-base-chars+)))) + (multiple-value-bind + (symbol status) + (intern (copy-seq str) package) + (unless (equal str (symbol-name symbol)) + (error "Intern gave bad symbol: ~A, ~A~%" str symbol)) + (unless status (return symbol)))))) + +(defun queue-insert (q x) + (declare (type cons q)) + (push x (cdr q))) + +(defun queue-remove (q) + (declare (type cons q)) + (when (null (car q)) + (when (null (cdr q)) + (error "Attempty to remove from empty queue.~%")) + (setf (car q) (nreverse (cdr q))) + (setf (cdr q) nil)) + (pop (car q))) + +(defun queue-empty (q) + (and (null (car q)) + (null (cdr q)))) + +(defun random-intern (n) + (declare (fixnum n)) + (let ((q (list nil)) + (xp (defpackage "X" (:use)))) + (declare (type cons q)) + (loop + for i from 1 to n do + (if (and + (= (random 2) 0) + (not (queue-empty q))) + (unintern (queue-remove q) xp) + (queue-insert q (make-random-symbol xp)))))) + +(defun fill-intern (n) + (declare (fixnum n)) + (let ((xp (defpackage "X" (:use)))) + (loop + for i from 1 to n do + (make-random-symbol xp)))) + + + + + + + + + diff --git a/ansi-tests/reader-test.lsp b/ansi-tests/reader-test.lsp new file mode 100644 index 0000000..6ec37c2 --- /dev/null +++ b/ansi-tests/reader-test.lsp @@ -0,0 +1,155 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Apr 8 20:03:45 1998 +;;;; Contains: Tests on readtables (just started, very incomplete) + +(in-package :cl-test) + +(declaim (optimize (safety 3))) + +(deftest readtable-valid (not (readtablep *readtable*)) nil) +(deftest readtablep.1 + (and (not (readtablep nil)) + (not (readtablep 'a)) + (not (readtablep 0)) + (not (readtablep 1/2)) + (not (readtablep 1.2)) + (not (readtablep 1.2s2)) + (not (readtablep 1.2f3)) + (not (readtablep 1.2e2)) + (not (readtablep 1.2d2)) + (not (readtablep (list 'a))) + (not (readtablep "abcde")) + (not (readtablep t)) + (not (readtablep '*readtable*)) + (not (readtablep (make-array '(10)))) + (not (readtablep (make-array '(10) :element-type 'fixnum))) + (not (readtablep (make-array '(10) :element-type 'float))) + (not (readtablep (make-array '(10) :element-type 'double-float))) + (not (readtablep (make-array '(10) :element-type 'string))) + (not (readtablep (make-array '(10) :element-type 'character))) + (not (readtablep (make-array '(10) :element-type 'bit))) + (not (readtablep (make-array '(10) :element-type 'boolean))) + (not (not (readtablep (copy-readtable)))) + (not (readtablep #'car)) + ) + t) + +(deftest read-symbol.1 + (let ((*package* (find-package "CL-TEST"))) + (ignore-errors (read-from-string "a"))) + a 1) + +(deftest read-symbol.2 + (let ((*package* (find-package "CL-TEST"))) + (ignore-errors (read-from-string "|a|"))) + |a| 3) + +(deftest read-symbol.3 + (multiple-value-bind (s n) + (ignore-errors (read-from-string "#:abc")) + (not + (and (symbolp s) + (eql n 5) + (not (symbol-package s)) + (string-equal (symbol-name s) "abc")))) + nil) + +(deftest read-symbol.4 + (multiple-value-bind (s n) + (ignore-errors (read-from-string "#:|abc|")) + (not + (and (symbolp s) + (eql n 7) + (not (symbol-package s)) + (string= (symbol-name s) "abc")))) + nil) + +(deftest read-symbol.5 + (multiple-value-bind (s n) + (ignore-errors (read-from-string "#:||")) + (if (not (symbolp s)) + s + (not (not + (and (eql n 4) + (not (symbol-package s)) + (string= (symbol-name s) "")))))) + t) + +(deftest read-symbol.6 + (let ((str "cl-test::abcd0123")) + (multiple-value-bind (s n) + (ignore-errors (read-from-string str)) + (if (not (symbolp s)) + s + (not (not + (and (eql n (length str)) + (eqt (symbol-package s) (find-package :cl-test)) + (string-equal (symbol-name s) + "abcd0123"))))))) + t) + +(deftest read-symbol.7 + (multiple-value-bind (s n) + (ignore-errors (read-from-string ":ABCD")) + (if (not (symbolp s)) + s + (not (not + (and (eql n 5) + (eqt (symbol-package s) (find-package "KEYWORD")) + (string-equal (symbol-name s) + "ABCD")))))) + t) + +(defun read-symbol.9-body (natoms maxlen) + (let* ((chars (concatenate 'string + "abcdefghijklmnopqrstuvwxyz" + "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + "0123456789" + "<,>.?/\"':;[{]}~`!@#$%^&*()_-+= \\|")) + (nchars (length chars))) + (loop + for i from 1 to natoms + count + (let* ((len (random (1+ maxlen))) + (actual-len 0) + (s (make-string (+ 2 (* 2 len)))) + (s2 (make-string len))) + (loop for j from 0 to (1- len) do + (let ((c (elt chars (random (max 1 (1- nchars)))))) + (when (member c '(#\| #\\)) + (setf (elt s actual-len) #\\) + (incf actual-len)) + (setf (elt s actual-len) c) + (setf (elt s2 j) c) + (incf actual-len))) + (let ((actual-string (subseq s 0 actual-len))) + (multiple-value-bind (sym nread) + (ignore-errors (read-from-string + (concatenate 'string + "#:|" actual-string "|"))) + (unless (and (symbolp sym) + (eql nread (+ 4 actual-len)) + (string-equal s2 (symbol-name sym))) + (format t "Symbol read failed: ~S (~S) read as ~S~%" + actual-string s2 sym :readably t) + t))))))) + +(deftest read-symbol.9 + (read-symbol.9-body 1000 100) + 0) + +(deftest read-symbol.10 + (handler-case + (not (not + (equal (symbol-name + (read-from-string + (with-output-to-string (s) + (write (make-symbol ":") + :readably t + :stream s)))) + ":"))) + (error (c) c)) + t) + + diff --git a/ansi-tests/reduce.lsp b/ansi-tests/reduce.lsp new file mode 100644 index 0000000..cb74c38 --- /dev/null +++ b/ansi-tests/reduce.lsp @@ -0,0 +1,470 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Aug 18 14:08:57 2002 +;;;; Contains: Tests for function REDUCE + +(in-package :cl-test) + +(deftest reduce-list.1 + (reduce #'cons '(a b c d e f)) + (((((a . b) . c) . d) . e) . f)) + +(deftest reduce-list.2 + (reduce #'cons '(a b c d e f) :from-end t) + (a b c d e . f)) + +(deftest reduce-list.3 + (reduce #'cons '(a b c d e f) :initial-value 'z) + ((((((z . a) . b) . c) . d) . e) . f)) + +(deftest reduce-list.4 + (reduce #'cons '(a b c d e f) :from-end t :initial-value 'g) + (a b c d e f . g)) + +(deftest reduce-list.5 + (reduce #'cons '(a b c d e f) :from-end nil) + (((((a . b) . c) . d) . e) . f)) + +(deftest reduce-list.6 + (reduce #'cons '(a b c d e f) :from-end 17) + (a b c d e . f)) + +(deftest reduce-list.7 + (reduce #'cons '(a b c d e f) :end nil) + (((((a . b) . c) . d) . e) . f)) + +(deftest reduce-list.8 + (reduce #'cons '(a b c d e f) :end 3) + ((a . b) . c)) + +(deftest reduce-list.9 + (reduce #'cons '(a b c d e f) :start 1 :end 4) + ((b . c) . d)) + +(deftest reduce-list.10 + (reduce #'cons '(a b c d e f) :start 1 :end 4 :from-end t) + (b c . d)) + +(deftest reduce-list.11 + (reduce #'cons '(a b c d e f) :start 1 :end 4 :from-end t + :initial-value nil) + (b c d)) + +(deftest reduce-list.12 + (reduce 'cons '(a b c d e f)) + (((((a . b) . c) . d) . e) . f)) + +(deftest reduce-list.13 + (reduce #'+ nil) + 0) + +(deftest reduce-list.14 + (reduce #'+ '(1 2 3) :start 0 :end 0) + 0) + +(deftest reduce-list.15 + (reduce #'+ '(1 2 3) :key '1+) + 9) + +(deftest reduce-list.16 + (reduce #'cons '(1 2 3) :key '1+ :from-end t :initial-value nil) + (2 3 4)) + +(deftest reduce-list.17 + (reduce #'+ '(1 2 3 4 5 6 7) :key '1+ :start 2 :end 6) + 22) + +;;;;;;; + +(deftest reduce-array.1 + (reduce #'cons #(a b c d e f)) + (((((a . b) . c) . d) . e) . f)) + +(deftest reduce-array.2 + (reduce #'cons #(a b c d e f) :from-end t) + (a b c d e . f)) + +(deftest reduce-array.3 + (reduce #'cons #(a b c d e f) :initial-value 'z) + ((((((z . a) . b) . c) . d) . e) . f)) + +(deftest reduce-array.4 + (reduce #'cons #(a b c d e f) :from-end t :initial-value 'g) + (a b c d e f . g)) + +(deftest reduce-array.5 + (reduce #'cons #(a b c d e f) :from-end nil) + (((((a . b) . c) . d) . e) . f)) + +(deftest reduce-array.6 + (reduce #'cons #(a b c d e f) :from-end 17) + (a b c d e . f)) + +(deftest reduce-array.7 + (reduce #'cons #(a b c d e f) :end nil) + (((((a . b) . c) . d) . e) . f)) + +(deftest reduce-array.8 + (reduce #'cons #(a b c d e f) :end 3) + ((a . b) . c)) + +(deftest reduce-array.9 + (reduce #'cons #(a b c d e f) :start 1 :end 4) + ((b . c) . d)) + +(deftest reduce-array.10 + (reduce #'cons #(a b c d e f) :start 1 :end 4 :from-end t) + (b c . d)) + +(deftest reduce-array.11 + (reduce #'cons #(a b c d e f) :start 1 :end 4 :from-end t + :initial-value nil) + (b c d)) + +(deftest reduce-array.12 + (reduce 'cons #(a b c d e f)) + (((((a . b) . c) . d) . e) . f)) + +(deftest reduce-array.13 + (reduce #'+ #(1 2 3) :start 0 :end 0) + 0) + +(deftest reduce-array.14 + (let ((a (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8) + :fill-pointer 4))) + (reduce #'+ a)) + 10) + +(deftest reduce-array.15 + (let ((a (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8) + :fill-pointer 4))) + (reduce #'+ a :end nil)) + 10) + +(deftest reduce-array.16 + (let ((a (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8) + :fill-pointer 4))) + (reduce #'+ a :from-end t)) + 10) + +(deftest reduce-array.17 + (let ((a (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8) + :fill-pointer 4))) + (reduce #'+ a :initial-value 1)) + 11) + +(deftest reduce-array.18 + (let ((a (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8) + :fill-pointer 4))) + (reduce #'+ a :initial-value 1 :start 2)) + 8) + +(deftest reduce-array.19 + (let ((a (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8) + :fill-pointer 4))) + (reduce #'+ a :end 3)) + 6) + + +;;;;;;;; + +(deftest reduce.error.1 + (classify-error (reduce 'cons 'a)) + type-error) + +(deftest reduce.error.2 + (classify-error (reduce)) + program-error) + +(deftest reduce.error.3 + (classify-error (reduce #'list nil :start)) + program-error) + +(deftest reduce.error.4 + (classify-error (reduce #'list nil 'bad t)) + program-error) + +(deftest reduce.error.5 + (classify-error (reduce #'list nil 'bad t :allow-other-keys nil)) + program-error) + +(deftest reduce.error.6 + (classify-error (reduce #'list nil 1 2)) + program-error) + +(deftest reduce.error.7 + (classify-error (locally (reduce 'cons 'a) t)) + type-error) + +(deftest reduce.error.8 + (classify-error (reduce #'identity '(a b c))) + program-error) + +(deftest reduce.error.9 + (classify-error (reduce #'cons '(a b c) :key #'cons)) + program-error) + +(deftest reduce.error.10 + (classify-error (reduce #'cons '(a b c) :key #'car)) + type-error) + + +;;;;;;;; + +(deftest reduce-string.1 + (reduce #'cons "abcdef") + (((((#\a . #\b) . #\c) . #\d) . #\e) . #\f)) + +(deftest reduce-string.2 + (reduce #'cons "abcdef" :from-end t) + (#\a #\b #\c #\d #\e . #\f)) + +(deftest reduce-string.3 + (reduce #'cons "abcdef" :initial-value 'z) + ((((((z . #\a) . #\b) . #\c) . #\d) . #\e) . #\f)) + +(deftest reduce-string.4 + (reduce #'cons "abcdef" :from-end t :initial-value 'g) + (#\a #\b #\c #\d #\e #\f . g)) + +(deftest reduce-string.5 + (reduce #'cons "abcdef" :from-end nil) + (((((#\a . #\b) . #\c) . #\d) . #\e) . #\f)) + +(deftest reduce-string.6 + (reduce #'cons "abcdef" :from-end 17) + (#\a #\b #\c #\d #\e . #\f)) + +(deftest reduce-string.7 + (reduce #'cons "abcdef" :end nil) + (((((#\a . #\b) . #\c) . #\d) . #\e) . #\f)) + +(deftest reduce-string.8 + (reduce #'cons "abcdef" :end 3) + ((#\a . #\b) . #\c)) + +(deftest reduce-string.9 + (reduce #'cons "abcdef" :start 1 :end 4) + ((#\b . #\c) . #\d)) + +(deftest reduce-string.10 + (reduce #'cons "abcdef" :start 1 :end 4 :from-end t) + (#\b #\c . #\d)) + +(deftest reduce-string.11 + (reduce #'cons "abcdef" :start 1 :end 4 :from-end t + :initial-value nil) + (#\b #\c #\d)) + +(deftest reduce-string.12 + (reduce 'cons "abcdef") + (((((#\a . #\b) . #\c) . #\d) . #\e) . #\f)) + +(deftest reduce-string.13 + (reduce #'+ "abc" :start 0 :end 0) + 0) + +(deftest reduce-string.14 + (let ((s (make-array '(8) :initial-contents "abcdefgh" + :fill-pointer 6 + :element-type 'character))) + (coerce (reduce #'(lambda (x y) (cons y x)) s :initial-value nil) + 'string)) + "fedcba") + +(deftest reduce-string.15 + (let ((s (make-array '(8) :initial-contents "abcdefgh" + :fill-pointer 6 + :element-type 'character))) + (coerce (reduce #'(lambda (x y) (cons y x)) s :initial-value nil + :start 1) + 'string)) + "fedcb") + +(deftest reduce-string.16 + (let ((s (make-array '(8) :initial-contents "abcdefgh" + :fill-pointer 6 + :element-type 'character))) + (coerce (reduce #'(lambda (x y) (cons y x)) s :end nil + :initial-value nil) + 'string)) + "fedcba") + +(deftest reduce-string.17 + (let ((s (make-array '(8) :initial-contents "abcdefgh" + :fill-pointer 6 + :element-type 'character))) + (coerce (reduce #'(lambda (x y) (cons y x)) s :end 4 + :initial-value nil) + 'string)) + "dcba") + +;;;;;;;; + +(deftest reduce-bitstring.1 + (reduce #'cons #*001101) + (((((0 . 0) . 1) . 1) . 0) . 1)) + +(deftest reduce-bitstring.2 + (reduce #'cons #*001101 :from-end t) + (0 0 1 1 0 . 1)) + +(deftest reduce-bitstring.3 + (reduce #'cons #*001101 :initial-value 'z) + ((((((z . 0) . 0) . 1) . 1) . 0) . 1)) + +(deftest reduce-bitstring.4 + (reduce #'cons #*001101 :from-end t :initial-value 'g) + (0 0 1 1 0 1 . g)) + +(deftest reduce-bitstring.5 + (reduce #'cons #*001101 :from-end nil) + (((((0 . 0) . 1) . 1) . 0) . 1)) + +(deftest reduce-bitstring.6 + (reduce #'cons #*001101 :from-end 17) + (0 0 1 1 0 . 1)) + +(deftest reduce-bitstring.7 + (reduce #'cons #*001101 :end nil) + (((((0 . 0) . 1) . 1) . 0) . 1)) + +(deftest reduce-bitstring.8 + (reduce #'cons #*001101 :end 3) + ((0 . 0) . 1)) + +(deftest reduce-bitstring.9 + (reduce #'cons #*001101 :start 1 :end 4) + ((0 . 1) . 1)) + +(deftest reduce-bitstring.10 + (reduce #'cons #*001101 :start 1 :end 4 :from-end t) + (0 1 . 1)) + +(deftest reduce-bitstring.11 + (reduce #'cons #*001101 :start 1 :end 4 :from-end t + :initial-value nil) + (0 1 1)) + +(deftest reduce-bitstring.12 + (reduce 'cons #*001101) + (((((0 . 0) . 1) . 1) . 0) . 1)) + +(deftest reduce-bitstring.13 + (reduce #'+ #(1 1 1) :start 0 :end 0) + 0) + +(deftest reduce-bitstring.14 + (let ((s (make-array '(8) :initial-contents '(0 0 1 0 1 1 0 1) + :fill-pointer 6 + :element-type 'bit))) + (reduce #'+ s)) + 3) + +(deftest reduce-bitstring.15 + (let ((s (make-array '(8) :initial-contents '(0 0 1 0 1 1 0 1) + :fill-pointer 6 + :element-type 'bit))) + (reduce #'+ s :start 3)) + 2) + +(deftest reduce-bitstring.16 + (let ((s (make-array '(8) :initial-contents '(0 0 1 0 1 1 0 1) + :fill-pointer 6 + :element-type 'bit))) + (reduce #'+ s :start 3 :initial-value 10)) + 12) + +(deftest reduce-bitstring.17 + (let ((s (make-array '(8) :initial-contents '(0 0 1 0 1 1 0 1) + :fill-pointer 6 + :element-type 'bit))) + (reduce #'+ s :end nil)) + 3) + +(deftest reduce-bitstring.18 + (let ((s (make-array '(8) :initial-contents '(1 1 1 1 1 1 1 1) + :fill-pointer 6 + :element-type 'bit))) + (reduce #'+ s :start 2 :end 4)) + 2) + +;;; Order of evaluation tests + +(deftest reduce.order.1 + (let ((i 0) x y) + (values + (reduce (progn (setf x (incf i)) #'cons) + (progn (setf y (incf i)) '(a b c))) + i x y)) + ((a . b) . c) 2 1 2) + +(deftest reduce.order.2 + (let ((i 0) a b c d e f g) + (values + (reduce (progn (setf a (incf i)) #'cons) + (progn (setf b (incf i)) '(a b c d e f)) + :from-end (progn (setf c (incf i)) t) + :initial-value (progn (setf d (incf i)) 'nil) + :start (progn (setf e (incf i)) 1) + :end (progn (setf f (incf i)) 4) + :key (progn (setf g (incf i)) #'identity) + ) + i a b c d e f g)) + (b c d) 7 1 2 3 4 5 6 7) + +(deftest reduce.order.3 + (let ((i 0) a b c d e f g) + (values + (reduce (progn (setf a (incf i)) #'cons) + (progn (setf b (incf i)) '(a b c d e f)) + :key (progn (setf c (incf i)) #'identity) + :end (progn (setf d (incf i)) 4) + :start (progn (setf e (incf i)) 1) + :initial-value (progn (setf f (incf i)) 'nil) + :from-end (progn (setf g (incf i)) t) + ) + i a b c d e f g)) + (b c d) 7 1 2 3 4 5 6 7) + + +;;; Keyword tests + +(deftest reduce.allow-other-keys.1 + (reduce #'+ '(1 2 3) :allow-other-keys t) + 6) + +(deftest reduce.allow-other-keys.2 + (reduce #'+ '(1 2 3) :allow-other-keys nil) + 6) + +(deftest reduce.allow-other-keys.3 + (reduce #'+ '(1 2 3) :bad t :allow-other-keys t) + 6) + +(deftest reduce.allow-other-keys.4 + (reduce #'+ '(1 2 3) :allow-other-keys t :bad t) + 6) + +(deftest reduce.allow-other-keys.5 + (reduce #'+ '(1 2 3) :allow-other-keys t :allow-other-keys nil :bad t) + 6) + +(deftest reduce.allow-other-keys.6 + (reduce #'+ '(1 2 3) :allow-other-keys t :bad t :allow-other-keys nil) + 6) + +(deftest reduce.allow-other-keys.7 + (reduce #'+ '(1 2 3) :bad t :allow-other-keys t :allow-other-keys nil) + 6) + +(deftest reduce.allow-other-keys.8 + (reduce #'cons '(1 2 3) :allow-other-keys t :from-end t :bad t + :initial-value nil) + (1 2 3)) + +(deftest reduce.keywords.9 + (reduce #'cons '(1 2 3) :from-end t :from-end nil + :initial-value nil :initial-value 'a) + (1 2 3)) + diff --git a/ansi-tests/remove-aux.lsp b/ansi-tests/remove-aux.lsp new file mode 100644 index 0000000..4dda4d5 --- /dev/null +++ b/ansi-tests/remove-aux.lsp @@ -0,0 +1,273 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Sep 15 07:42:36 2002 +;;;; Contains: Auxiliary functions for testing REMOVE and related functions + +(in-package :cl-test) + +(defun make-random-element (type) + (cond + ((subtypep* 'fixnum type) + (random most-positive-fixnum)) + ((subtypep* '(integer 0 255) type) + (random 255)) + ((subtypep* '(integer 0 7) type) + (random 8)) + ((subtypep* 'bit type) + (random 2)) + ((subtypep* 'symbol type) + (elt '(a b c d e f g h) (random 8))) + ((subtypep* '(member #\a #\b #\c #\d #\e #\f #\g #\h) type) + (elt "abcdefgh" (random 8))) + (t (error "Can't get random element of type ~A~%." type)))) + +(defun make-random-remove-input (len type element-type) + + "Randomly generate a test case for REMOVE. Given a length + a sequence type, and an element type, produce a random + sequence of length LEN of sequence type TYPE, and either + generate a random member of the sequence or a random + element of the element type to delete from the sequence." + + (let* ((seq (if (subtypep* type 'list) + (loop for i from 1 to len collect + (make-random-element element-type)) + (let ((seq (if (and (subtypep type 'vector) + (coin 3)) + (make-array + (list (+ len (random (1+ len)))) + :initial-element (make-random-element element-type) + :fill-pointer len + :element-type element-type) + (make-sequence type len)))) + (dotimes (i len) + (setf (elt seq i) (make-random-element element-type))) + seq))) + (e (if (and (> len 0) (coin)) + (elt seq (random len)) + (make-random-element element-type))) + ) + (values len seq e))) + +(defun my-remove (element + sequence + &key + (start 0) + (end nil) + (test #'eql test-p) + (test-not nil test-not-p) + (key nil) + (from-end nil) + (count nil)) + (assert (not (and test-p test-not-p))) + (my-remove-if + (cond (test-p #'(lambda (x) (funcall test element x))) + (test-not-p #'(lambda (x) (not (funcall test-not element x)))) + (t #'(lambda (x) (eql element x)))) + sequence :start start :end end :key key :from-end from-end :count count)) + +(defun my-remove-if (predicate + original-sequence + &key (from-end nil) + (start 0) + (end nil) + (count nil) + (key #'identity)) + (let ((len (length original-sequence)) + (sequence (copy-seq original-sequence))) + (unless end (setq end len)) + (unless key (setq key #'identity)) + (unless count (setq count len)) + + ;; Check that everything's kosher + (assert (<= 0 start end len)) + (assert (typep sequence 'sequence)) + (assert (integerp count)) + (assert (or (symbolp predicate) (functionp predicate))) + (assert (or (symbolp key) (functionp key))) + + ;; If FROM-END, reverse the sequence and flip + ;; start, end + (when from-end + (psetq sequence (nreverse sequence) + start (- len end) + end (- len start))) + + ;; Accumulate a list of elements for the result + (let ((pos 0) + (result nil)) ;; accumulate in reverse order + (map nil + #'(lambda (e) + (if (and (> count 0) + (>= pos start) + (< pos end) + (funcall predicate (funcall key e))) + (decf count) + (push e result)) + (incf pos)) + sequence) + (unless from-end + (setq result (nreverse result))) + ;; Convert to the correct type + (if (listp sequence) + result + (let ((element-type (array-element-type original-sequence))) + (make-array (length result) :element-type element-type + :initial-contents result)))))) + +(defun my-remove-if-not (pred &rest args) + (when (symbolp pred) + (setq pred (coerce pred 'function))) + (assert (typep pred 'function)) + (apply #'my-remove-if (complement pred) args)) + +(defun make-random-rd-params (maxlen) + "Generate random paramaters for remove/delete/etc. functions." + (let* ((element-type t) + (type-select (random 7)) + (type + (case type-select + (0 'list) + (1 'vector) + (2 (setq element-type 'character) 'string) + (3 (setq element-type 'bit) 'bit-vector) + (4 'simple-vector) + (5 (setq element-type '(integer 0 255)) + '(vector (integer 0 255))) + (6 (setq element-type 'fixnum) '(vector fixnum)) + (t (error "Can't happen?!~%")))) + (len (random maxlen)) + (start (and (coin) (> len 0) + (random len))) + (end (and (coin) + (if start (+ start (random (- len start))) + (random (1+ len))))) + (from-end (coin)) + (count (case (random 5) + ((0 1) nil) + ((2 3) (random (1+ len))) + (t (if (coin) -1 -10000000000000)))) + (seq (multiple-value-bind (x y z) (make-random-remove-input len type element-type) + (declare (ignore x z)) + y)) + (key (and (coin) + (case type-select + (2 (random-case + #'char-upcase 'char-upcase + #'char-downcase 'char-downcase)) + (3 #'(lambda (x) (- 1 x))) + ((5 6) (random-case #'1+ '1+ #'1- '1-)) + (t (random-case 'identity #'identity))))) + (test (and (eql (random 3) 0) + (random-case 'eq 'eql 'equal + #'eq #'eql #'equal))) + (test-not (and (not test) + (coin) + (random-case 'eq 'eql 'equal + #'eq #'eql #'equal))) + ) + ;; Return parameters + (values + element-type type len start end from-end count seq key test test-not))) + +(defun random-test-remove-args (maxlen) + (multiple-value-bind (element-type type len start end from-end count seq key test test-not) + (make-random-rd-params maxlen) + (declare (ignore type)) + (let ((element (if (and (coin) (> len 0)) + (random-from-seq seq) + (make-random-element element-type))) + (arg-list + (reduce #'nconc + (random-permute + (list + (when start (list :start start)) + (cond (end (list :end end)) + ((coin) (list :end nil))) + (cond (from-end (list :from-end from-end)) + ((coin) (list :from-end nil))) + (cond (count (list :count count)) + ((coin) (list :count nil))) + (cond (key (list :key key)) + ;; ((coin) (list :key nil)) + ) + (when test (list :test test)) + (when test-not (list :test test-not))))))) + (values element seq arg-list)))) + +(defparameter *remove-fail-args* nil) + +(defun random-test-remove (maxlen &key (tested-fn #'remove) + (check-fn #'my-remove) + (pure t)) + (multiple-value-bind (element seq arg-list) + (random-test-remove-args maxlen) + (let* ((seq1 (copy-seq seq)) + (seq2 (copy-seq seq)) + (seq1r (apply tested-fn element seq1 arg-list)) + (seq2r (apply check-fn element seq2 arg-list))) + (setq *remove-fail-args* (list* element seq1 arg-list)) + (cond + ((and pure (not (equalp seq seq1))) :fail1) + ((and pure (not (equalp seq seq2))) :fail2) + ((not (equalp seq1r seq2r)) :fail3) + (t t))))) + +(defun random-test-remove-if (maxlen &optional (negate nil)) + (multiple-value-bind (element seq arg-list) + (random-test-remove-args maxlen) + (let ((fn (getf arg-list :key)) + (test (getf arg-list :test))) + (remf arg-list :key) + (remf arg-list :test) + (remf arg-list :test-not) + (unless test (setq test #'eql)) + (if fn + (case (random 3) + (0 (setf arg-list (list* :key 'identity arg-list))) + (1 (setf arg-list (list* :key #'identity arg-list))) + (t nil)) + (setf fn (if (coin) 'identity + #'(lambda (x) (funcall test element x))))) + (let* ((seq1 (copy-seq seq)) + (seq2 (copy-seq seq)) + (seq1r (apply (if negate #'remove-if-not #'remove-if) + fn seq1 arg-list)) + (seq2r (apply (if negate #'my-remove-if-not #'my-remove-if) + fn seq2 arg-list))) + (setq *remove-fail-args* (cons seq1 arg-list)) + (cond + ((not (equalp seq seq1)) :fail1) + ((not (equalp seq seq2)) :fail2) + ((not (equalp seq1r seq2r)) :fail3) + (t t)))))) + +(defun random-test-delete (maxlen) + (random-test-remove maxlen :tested-fn #'delete :pure nil)) + +(defun random-test-delete-if (maxlen &optional (negate nil)) + (multiple-value-bind (element seq arg-list) + (random-test-remove-args maxlen) + (let ((fn (getf arg-list :key)) + (test (getf arg-list :test))) + (remf arg-list :key) + (remf arg-list :test) + (remf arg-list :test-not) + (unless test (setq test #'eql)) + (if fn + (case (random 3) + (0 (setf arg-list (list* :key 'identity arg-list))) + (1 (setf arg-list (list* :key #'identity arg-list))) + (t nil)) + (setf fn (if (coin) 'identity + #'(lambda (x) (funcall test element x))))) + (setq *remove-fail-args* (list* seq arg-list)) + (let* ((seq1 (copy-seq seq)) + (seq2 (copy-seq seq)) + (seq1r (apply (if negate #'delete-if-not #'delete-if) + fn seq1 arg-list)) + (seq2r (apply (if negate #'my-remove-if-not #'my-remove-if) + fn seq2 arg-list))) + (cond + ((not (equalp seq1r seq2r)) :fail3) + (t t)))))) diff --git a/ansi-tests/remove-duplicates-aux.lsp b/ansi-tests/remove-duplicates-aux.lsp new file mode 100644 index 0000000..1f482ba --- /dev/null +++ b/ansi-tests/remove-duplicates-aux.lsp @@ -0,0 +1,88 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Mon Sep 23 20:59:10 2002 +;;;; Contains: Aux. functions for testing REMOVE-DUPLICATES/DELETE-DUPLICATES + +(in-package :cl-test) + +(defun my-remove-duplicates (orig-sequence + &key from-end test test-not (start 0) end key) + (assert (typep orig-sequence 'sequence)) + (let* ((sequence orig-sequence) + (len (length sequence))) + (unless end (setq end len)) + (unless key (setq key #'identity)) + (cond + (test (assert (not test-not))) + (test-not (setq test #'(lambda (x y) (not (funcall test x y))))) + (t (setq test #'eql))) + (assert (integerp start)) + (assert (integerp end)) + (assert (<= 0 start end len)) + ;; (format t "start = ~A, end = ~A, len = ~A~%" start end len) + (if from-end + (psetq start (- len end) + end (- len start) + sequence (reverse sequence)) + (setq sequence (copy-seq sequence))) + ;; (format t "start = ~A, end = ~A, len = ~A~%" start end len) + (assert (<= 0 start end len) (start end len)) + (let ((result nil)) + (loop for i from 0 below start + do (push (elt sequence i) result)) + (loop for i from start below end + for x = (elt sequence i) + for kx = (if key (funcall key x) x) + unless (position kx + sequence + :start (1+ i) + :end end + :test test + :key key) + do (push x result)) + (loop for i from end below len + do (push (elt sequence i) result)) + (unless from-end (setq result (reverse result))) + (cond + ((listp orig-sequence) result) + ((arrayp orig-sequence) + (make-array (length result) :initial-contents result + :element-type (array-element-type orig-sequence))) + (t (assert nil)))))) + +(defun make-random-rdup-params (maxlen) + "Make random input parameters for REMOVE-DUPLICATES." + (multiple-value-bind (element-type type len start end from-end + count seq key test test-not) + (make-random-rd-params maxlen) + (declare (ignore count element-type)) + (let ((arg-list + (reduce #'nconc + (random-permute + (list + (when start (list :start start)) + (cond (end (list :end end)) + ((coin) (list :end nil))) + (cond (from-end (list :from-end from-end)) + ((coin) (list :from-end nil))) + (cond (key (list :key key)) + ;; ((coin) (list :key nil)) + ) + (when test (list :test test)) + (when test-not (list :test test-not))))))) + (values seq arg-list)))) + +(defun random-test-remove-dups (maxlen &optional (pure t)) + (multiple-value-bind (seq arg-list) + (make-random-rdup-params maxlen) + (let* ((seq1 (copy-seq seq)) + (seq2 (copy-seq seq)) + (seq1r (apply (if pure #'remove-duplicates + #'delete-duplicates) + seq1 arg-list)) + (seq2r (apply #'my-remove-duplicates seq2 arg-list))) + (cond + ((and pure (not (equalp seq seq1))) :fail1) + ((and pure (not (equalp seq seq2))) :fail2) + ((not (equalp seq1r seq2r)) :fail3) + (t t))))) diff --git a/ansi-tests/remove-duplicates.lsp b/ansi-tests/remove-duplicates.lsp new file mode 100644 index 0000000..ac5956b --- /dev/null +++ b/ansi-tests/remove-duplicates.lsp @@ -0,0 +1,253 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Sep 29 20:49:47 2002 +;;;; Contains: Tests for REMOVE-DUPLICATES, DELETE-DUPLICATES + +(in-package :cl-test) + +(deftest random-remove-duplicates + (loop for i from 1 to 5000 + always (random-test-remove-dups 20)) + t) + +(deftest random-delete-duplicates + (loop for i from 1 to 5000 + always (random-test-remove-dups 20 nil)) + t) + +;;; Look for :KEY NIL bugs + +(deftest remove-duplicates.1 + (let* ((orig '(1 2 3 4 1 3 4 1 2 5 6 2 7)) + (x (copy-seq orig)) + (y (remove-duplicates x :key nil))) + (and (equalp orig x) y)) + (3 4 1 5 6 2 7)) + +(deftest delete-duplicates.1 + (let* ((orig '(1 2 3 4 1 3 4 1 2 5 6 2 7)) + (x (copy-seq orig)) + (y (delete-duplicates x :key nil))) + y) + (3 4 1 5 6 2 7)) + + +;;; Order of evaluation tests + +(deftest remove-duplicates.order.1 + (let ((i 0) a b c d e f) + (values + (remove-duplicates + (progn (setf a (incf i)) (list 1 2 3 1 3 1 2 4)) + :from-end (progn (setf b (incf i)) nil) + :start (progn (setf c (incf i)) 0) + :end (progn (setf d (incf i)) nil) + :key (progn (setf e (incf i)) #'identity) + :test (progn (setf f (incf i)) #'=) + ) + i a b c d e f)) + (3 1 2 4) 6 1 2 3 4 5 6) + +(deftest remove-duplicates.order.2 + (let ((i 0) a b c d e f) + (values + (remove-duplicates + (progn (setf a (incf i)) (list 1 2 3 1 3 1 2 4)) + :test-not (progn (setf b (incf i)) #'/=) + :key (progn (setf c (incf i)) #'identity) + :end (progn (setf d (incf i)) nil) + :start (progn (setf e (incf i)) 0) + :from-end (progn (setf f (incf i)) nil) + ) + i a b c d e f)) + (3 1 2 4) 6 1 2 3 4 5 6) + + +;;; Keyword tests + +(deftest remove-duplicates.allow-other-keys.1 + (remove-duplicates '(1 2 3 4 2 7 8 1 5) :allow-other-keys t) + (3 4 2 7 8 1 5)) + +(deftest remove-duplicates.allow-other-keys.2 + (remove-duplicates '(1 2 3 4 2 7 8 1 5) :allow-other-keys nil) + (3 4 2 7 8 1 5)) + +(deftest remove-duplicates.allow-other-keys.3 + (remove-duplicates '(1 2 3 4 2 7 8 1 5) :bad t :allow-other-keys t) + (3 4 2 7 8 1 5)) + +(deftest remove-duplicates.allow-other-keys.4 + (remove-duplicates '(1 2 3 4 2 7 8 1 5) :allow-other-keys t :bad t) + (3 4 2 7 8 1 5)) + +(deftest remove-duplicates.allow-other-keys.5 + (remove-duplicates '(1 2 3 4 2 7 8 1 5) :bad t + :allow-other-keys t :allow-other-keys nil) + (3 4 2 7 8 1 5)) + +(deftest remove-duplicates.allow-other-keys.6 + (remove-duplicates '(1 2 3 4 2 7 8 1 5) + :allow-other-keys t :bad t :allow-other-keys nil) + (3 4 2 7 8 1 5)) + +(deftest remove-duplicates.allow-other-keys.7 + (remove-duplicates '(1 2 3 4 2 7 8 1 5) + :allow-other-keys t :allow-other-keys nil :bad t) + (3 4 2 7 8 1 5)) + +(deftest remove-duplicates.allow-other-keys.8 + (remove-duplicates '(1 2 3 4 2 7 8 1 5) + :allow-other-keys t :from-end t) + (1 2 3 4 7 8 5)) + +(deftest remove-duplicates.keywords.1 + (remove-duplicates '(1 2 3 4 2 7 8 1 5) :from-end t :from-end nil) + (1 2 3 4 7 8 5)) + + +(deftest delete-duplicates.allow-other-keys.1 + (delete-duplicates (list 1 2 3 4 2 7 8 1 5) :allow-other-keys t) + (3 4 2 7 8 1 5)) + +(deftest delete-duplicates.allow-other-keys.2 + (delete-duplicates (list 1 2 3 4 2 7 8 1 5) :allow-other-keys nil) + (3 4 2 7 8 1 5)) + +(deftest delete-duplicates.allow-other-keys.3 + (delete-duplicates (list 1 2 3 4 2 7 8 1 5) :bad t :allow-other-keys t) + (3 4 2 7 8 1 5)) + +(deftest delete-duplicates.allow-other-keys.4 + (delete-duplicates (list 1 2 3 4 2 7 8 1 5) :allow-other-keys t :bad t) + (3 4 2 7 8 1 5)) + +(deftest delete-duplicates.allow-other-keys.5 + (delete-duplicates (list 1 2 3 4 2 7 8 1 5) :bad t + :allow-other-keys t :allow-other-keys nil) + (3 4 2 7 8 1 5)) + +(deftest delete-duplicates.allow-other-keys.6 + (delete-duplicates (list 1 2 3 4 2 7 8 1 5) + :allow-other-keys t :bad t :allow-other-keys nil) + (3 4 2 7 8 1 5)) + +(deftest delete-duplicates.allow-other-keys.7 + (delete-duplicates (list 1 2 3 4 2 7 8 1 5) + :allow-other-keys t :allow-other-keys nil :bad t) + (3 4 2 7 8 1 5)) + +(deftest delete-duplicates.allow-other-keys.8 + (delete-duplicates (list 1 2 3 4 2 7 8 1 5) + :allow-other-keys t :from-end t) + (1 2 3 4 7 8 5)) + +(deftest delete-duplicates.keywords.1 + (delete-duplicates (list 1 2 3 4 2 7 8 1 5) :from-end t :from-end nil) + (1 2 3 4 7 8 5)) + +;;; Order of evaluation tests + +(deftest delete-duplicates.order.1 + (let ((i 0) a b c d e f) + (values + (delete-duplicates + (progn (setf a (incf i)) (list 1 2 3 1 3 1 2 4)) + :from-end (progn (setf b (incf i)) nil) + :start (progn (setf c (incf i)) 0) + :end (progn (setf d (incf i)) nil) + :key (progn (setf e (incf i)) #'identity) + :test (progn (setf f (incf i)) #'=) + ) + i a b c d e f)) + (3 1 2 4) 6 1 2 3 4 5 6) + +(deftest delete-duplicates.order.2 + (let ((i 0) a b c d e f) + (values + (delete-duplicates + (progn (setf a (incf i)) (list 1 2 3 1 3 1 2 4)) + :test-not (progn (setf b (incf i)) #'/=) + :key (progn (setf c (incf i)) #'identity) + :end (progn (setf d (incf i)) nil) + :start (progn (setf e (incf i)) 0) + :from-end (progn (setf f (incf i)) nil) + ) + i a b c d e f)) + (3 1 2 4) 6 1 2 3 4 5 6) + +;;; Error cases + +(deftest remove-duplicates.error.1 + (classify-error (remove-duplicates)) + program-error) + +(deftest remove-duplicates.error.2 + (classify-error (remove-duplicates nil :start)) + program-error) + +(deftest remove-duplicates.error.3 + (classify-error (remove-duplicates nil 'bad t)) + program-error) + +(deftest remove-duplicates.error.4 + (classify-error (remove-duplicates nil 'bad t :allow-other-keys nil)) + program-error) + +(deftest remove-duplicates.error.5 + (classify-error (remove-duplicates nil 1 2)) + program-error) + +(deftest remove-duplicates.error.6 + (classify-error (remove-duplicates (list 'a 'b 'c) :test #'identity)) + program-error) + +(deftest remove-duplicates.error.7 + (classify-error (remove-duplicates (list 'a 'b 'c) :test-not #'identity)) + program-error) + +(deftest remove-duplicates.error.8 + (classify-error (remove-duplicates (list 'a 'b 'c) :key #'cons)) + program-error) + +(deftest remove-duplicates.error.9 + (classify-error (remove-duplicates (list 'a 'b 'c) :key #'car)) + type-error) + +;;; + +(deftest delete-duplicates.error.1 + (classify-error (delete-duplicates)) + program-error) + +(deftest delete-duplicates.error.2 + (classify-error (delete-duplicates nil :start)) + program-error) + +(deftest delete-duplicates.error.3 + (classify-error (delete-duplicates nil 'bad t)) + program-error) + +(deftest delete-duplicates.error.4 + (classify-error (delete-duplicates nil 'bad t :allow-other-keys nil)) + program-error) + +(deftest delete-duplicates.error.5 + (classify-error (delete-duplicates nil 1 2)) + program-error) + +(deftest delete-duplicates.error.6 + (classify-error (delete-duplicates (list 'a 'b 'c) :test #'identity)) + program-error) + +(deftest delete-duplicates.error.7 + (classify-error (delete-duplicates (list 'a 'b 'c) :test-not #'identity)) + program-error) + +(deftest delete-duplicates.error.8 + (classify-error (delete-duplicates (list 'a 'b 'c) :key #'cons)) + program-error) + +(deftest delete-duplicates.error.9 + (classify-error (delete-duplicates (list 'a 'b 'c) :key #'car)) + type-error) \ No newline at end of file diff --git a/ansi-tests/remove.lsp b/ansi-tests/remove.lsp new file mode 100644 index 0000000..ecb0127 --- /dev/null +++ b/ansi-tests/remove.lsp @@ -0,0 +1,806 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Sep 14 11:46:05 2002 +;;;; Contains: Tests for REMOVE + +(in-package :cl-test) + +(deftest remove-list.1 + (let* ((orig '(a b c a b d a c b a e)) + (x (copy-seq orig)) + (y (remove 'a x))) + (and (equalp orig x) y)) + (b c b d c b e)) + +(deftest remove-list.2 + (let* ((orig '(a b c a b d a c b a e)) + (x (copy-seq orig)) + (y (remove 'a x :count nil))) + (and (equalp orig x) y)) + (b c b d c b e)) + +(deftest remove-list.3 + (let* ((orig '(a b c a b d a c b a e)) + (x (copy-seq orig)) + (y (remove 'a x :key nil))) + (and (equalp orig x) y)) + (b c b d c b e)) + +(deftest remove-list.4 + (let* ((orig '(a b c a b d a c b a e)) + (x (copy-seq orig)) + (y (remove 'a x :count 100))) + (and (equalp orig x) y)) + (b c b d c b e)) + +(deftest remove-list.5 + (let* ((orig '(a b c a b d a c b a e)) + (x (copy-seq orig)) + (y (remove 'a x :count 0))) + (and (equalp orig x) y)) + (a b c a b d a c b a e)) + +(deftest remove-list.6 + (let* ((orig '(a b c a b d a c b a e)) + (x (copy-seq orig)) + (y (remove 'a x :count 1))) + (and (equalp orig x) y)) + (b c a b d a c b a e)) + +(deftest remove-list.7 + (let* ((orig '(a b c a b d a c b a e)) + (x (copy-seq orig)) + (y (remove 'c x :count 1))) + (and (equalp orig x) y)) + (a b a b d a c b a e)) + +(deftest remove-list.8 + (let* ((orig '(a b c a b d a c b a e)) + (x (copy-seq orig)) + (y (remove 'a x :from-end t))) + (and (equalp orig x) y)) + (b c b d c b e)) + +(deftest remove-list.9 + (let* ((orig '(a b c a b d a c b a e)) + (x (copy-seq orig)) + (y (remove 'a x :from-end t :count 1))) + (and (equalp orig x) y)) + (a b c a b d a c b e)) + +(deftest remove-list.10 + (let* ((orig '(a b c a b d a c b a e)) + (x (copy-seq orig)) + (y (remove 'a x :from-end t :count 4))) + (and (equalp orig x) y)) + (b c b d c b e)) + +(deftest remove-list.11 + (let* ((orig '(a b c a b d a c b a e)) + (x (copy-seq orig))) + (values + (loop for i from 0 to 10 + collect (remove 'a x :start i)) + (equalp orig x))) + ((b c b d c b e) + (a b c b d c b e) + (a b c b d c b e) + (a b c b d c b e) + (a b c a b d c b e) + (a b c a b d c b e) + (a b c a b d c b e) + (a b c a b d a c b e) + (a b c a b d a c b e) + (a b c a b d a c b e) + (a b c a b d a c b a e)) + t) + +(deftest remove-list.12 + (let* ((orig '(a b c a b d a c b a e)) + (x (copy-seq orig))) + (values + (loop for i from 0 to 10 + collect (remove 'a x :start i :end nil)) + (equalp orig x))) + ((b c b d c b e) + (a b c b d c b e) + (a b c b d c b e) + (a b c b d c b e) + (a b c a b d c b e) + (a b c a b d c b e) + (a b c a b d c b e) + (a b c a b d a c b e) + (a b c a b d a c b e) + (a b c a b d a c b e) + (a b c a b d a c b a e)) + t) + +(deftest remove-list.13 + (let* ((orig '(a b c a b d a c b a e)) + (x (copy-seq orig))) + (values + (loop for i from 0 to 10 + collect (remove 'a x :start i :end 11)) + (equalp orig x))) + ((b c b d c b e) + (a b c b d c b e) + (a b c b d c b e) + (a b c b d c b e) + (a b c a b d c b e) + (a b c a b d c b e) + (a b c a b d c b e) + (a b c a b d a c b e) + (a b c a b d a c b e) + (a b c a b d a c b e) + (a b c a b d a c b a e)) + t) + +(deftest remove-list.14 + (let* ((orig '(a b c a b d a c b a e)) + (x (copy-seq orig)) + (y (remove 'a x :end nil))) + (and (equalp orig x) y)) + (b c b d c b e)) + +(deftest remove-list.15 + (let* ((orig '(a b c a b d a c b a e)) + (x (copy-seq orig))) + (values + (loop for i from 0 to 9 + collect (remove 'a x :start i :end 9)) + (equalp orig x))) + ((b c b d c b a e) + (a b c b d c b a e) + (a b c b d c b a e) + (a b c b d c b a e) + (a b c a b d c b a e) + (a b c a b d c b a e) + (a b c a b d c b a e) + (a b c a b d a c b a e) + (a b c a b d a c b a e) + (a b c a b d a c b a e)) + t) + +(deftest remove-list.16 + (let* ((orig '(a b c a b d a c b a e)) + (x (copy-seq orig))) + (values + (loop for i from 0 to 10 + collect (remove 'a x :start i :end 11 :count 1)) + (equalp orig x))) + ((b c a b d a c b a e) + (a b c b d a c b a e) + (a b c b d a c b a e) + (a b c b d a c b a e) + (a b c a b d c b a e) + (a b c a b d c b a e) + (a b c a b d c b a e) + (a b c a b d a c b e) + (a b c a b d a c b e) + (a b c a b d a c b e) + (a b c a b d a c b a e)) + t) + +(deftest remove-list.17 + (let* ((orig '(a b c a b d a c b a e)) + (x (copy-seq orig))) + (values + (loop for i from 0 to 10 + collect (remove 'a x :start i :end (1+ i))) + (equalp orig x))) + (( b c a b d a c b a e) + (a b c a b d a c b a e) + (a b c a b d a c b a e) + (a b c b d a c b a e) + (a b c a b d a c b a e) + (a b c a b d a c b a e) + (a b c a b d c b a e) + (a b c a b d a c b a e) + (a b c a b d a c b a e) + (a b c a b d a c b e) + (a b c a b d a c b a e)) + t) + +;;; Show that it tests using EQL, not EQ +(deftest remove-list.18 + (let* ((i (1+ most-positive-fixnum)) + (orig (list i 0 i 1 i 2 3)) + (x (copy-seq orig)) + (y (remove (1+ most-positive-fixnum) x))) + (and (equalp orig x) y)) + (0 1 2 3)) + +(deftest remove-list.19 + (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) + (x (copy-seq orig)) + (y (remove 1 x :key #'1-))) + (and (equalp orig x) y)) + (1 3 6 1 4 1 3 7)) + +(deftest remove-list.20 + (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) + (x (copy-seq orig)) + (y (remove 3 x :test #'>))) + (and (equalp orig x) y)) + (3 6 4 3 7)) + +(deftest remove-list.21 + (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) + (x (copy-seq orig)) + (y (remove 3 x :test '> :from-end t))) + (and (equalp orig x) y)) + (3 6 4 3 7)) + +(deftest remove-list.22 + (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) + (x (copy-seq orig)) + (y (remove 2 x :key nil))) + (and (equalp orig x) y)) + (1 3 6 1 4 1 3 7)) + +(deftest remove-list.23 + (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) + (x (copy-seq orig)) + (y (remove 1 x :key '1-))) + (and (equalp orig x) y)) + (1 3 6 1 4 1 3 7)) + +(deftest remove-list.24 + (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) + (x (copy-seq orig)) + (y (remove 3 x :test-not #'<=))) + (and (equalp orig x) y)) + (3 6 4 3 7)) + +(deftest remove-list.25 + (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) + (x (copy-seq orig)) + (y (remove 3 x :test-not '<= :from-end t))) + (and (equalp orig x) y)) + (3 6 4 3 7)) + +(deftest remove-list.26 + (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) + (x (copy-seq orig)) + (y (remove 3 x :from-end t :start 1 :end 5))) + (and (equalp orig x) y)) + (1 2 2 6 1 2 4 1 3 2 7)) + +(deftest remove-list.27 + (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) + (x (copy-seq orig)) + (y (remove 3 x :count -1))) + (and (equalp orig x) + (equalpt x y))) + t) + +(deftest remove-list.28 + (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) + (x (copy-seq orig)) + (y (remove 3 x :count -1000000000000))) + (and (equalp orig x) + (equalpt x y))) + t) + +(deftest remove-list.29 + (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) + (x (copy-seq orig)) + (y (remove 3 x :count 1000000000000))) + (and (equalp orig x) + y)) + (1 2 2 6 1 2 4 1 2 7)) + +;;; Assorted tests of remove and delete on vectors, strings, +;;; and bit vectors. These are mostly to exercise bugs previously +;;; detected by the randomized tests + +(deftest remove-vector.1 + (remove 'a (vector 'b 'c 'd)) + #(b c d)) + +(deftest remove-vector.2 + (remove 'a (vector 'b 'c 'd) :count -1) + #(b c d)) + +(deftest remove-vector.3 + (remove 'a (vector 'a 'b 'c 'd) :count -1) + #(a b c d)) + +(deftest remove-string.1 + (remove #\a (copy-seq "abcad")) + "bcd") + +(deftest remove-string.2 + (remove #\a (copy-seq "abcad") :count -1) + "abcad") + +(deftest remove-string.3 + (remove #\a (copy-seq "bcd") :count -1) + "bcd") + +(deftest delete-vector.1 + (delete 'a (vector 'b 'c 'd)) + #(b c d)) + +(deftest delete-vector.2 + (delete 'a (vector 'b 'c 'd) :count -1) + #(b c d)) + +(deftest delete-vector.3 + (delete 'a (vector 'a 'b 'c 'd) :count -1) + #(a b c d)) + +(deftest delete-string.1 + (delete #\a (copy-seq "abcad")) + "bcd") + +(deftest delete-string.2 + (delete #\a (copy-seq "abcad") :count -1) + "abcad") + +(deftest delete-string.3 + (delete #\a (copy-seq "bcd") :count -1) + "bcd") + +(deftest remove-bit-vector.1 + (remove 0 (copy-seq #*00011101101)) + #*111111) + +(deftest remove-bit-vector.2 + (remove 0 (copy-seq #*00011101101) :count -1) + #*00011101101) + +(deftest remove-bit-vector.3 + (remove 0 (copy-seq #*11111) :count -1) + #*11111) + +(deftest delete-bit-vector.1 + (delete 0 (copy-seq #*00011101101)) + #*111111) + +(deftest delete-bit-vector.2 + (delete 0 (copy-seq #*00011101101) :count -1) + #*00011101101) + +(deftest delete-bit-vector.3 + (delete 0 (copy-seq #*11111) :count -1) + #*11111) + +;;; Order of evaluation tests + +(deftest remove.order.1 + (let ((i 0) a b c d e f g h) + (values + (remove + (progn (setf a (incf i)) 'a) + (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) + :from-end (progn (setf c (incf i)) t) + :count (progn (setf d (incf i)) 1) + :key (progn (setf e (incf i)) #'identity) + :test (progn (setf f (incf i)) #'eq) + :start (progn (setf g (incf i)) 0) + :end (progn (setf h (incf i)) nil)) + i a b c d e f g h)) + (a b c d f) 8 1 2 3 4 5 6 7 8) + +(deftest remove.order.2 + (let ((i 0) a b c d e f g h) + (values + (remove + (progn (setf a (incf i)) 'a) + (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) + :end (progn (setf c (incf i)) nil) + :start (progn (setf d (incf i)) 0) + :test-not (progn (setf e (incf i)) (complement #'eq)) + :key (progn (setf f (incf i)) #'identity) + :count (progn (setf g (incf i)) 1) + :from-end (progn (setf h (incf i)) t) + ) + i a b c d e f g h)) + (a b c d f) 8 1 2 3 4 5 6 7 8) + +(deftest delete.order.1 + (let ((i 0) a b c d e f g h) + (values + (delete + (progn (setf a (incf i)) 'a) + (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) + :from-end (progn (setf c (incf i)) t) + :count (progn (setf d (incf i)) 1) + :key (progn (setf e (incf i)) #'identity) + :test (progn (setf f (incf i)) #'eq) + :start (progn (setf g (incf i)) 0) + :end (progn (setf h (incf i)) nil)) + i a b c d e f g h)) + (a b c d f) 8 1 2 3 4 5 6 7 8) + +(deftest delete.order.2 + (let ((i 0) a b c d e f g h) + (values + (delete + (progn (setf a (incf i)) 'a) + (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) + :end (progn (setf c (incf i)) nil) + :start (progn (setf d (incf i)) 0) + :test-not (progn (setf e (incf i)) (complement #'eq)) + :key (progn (setf f (incf i)) #'identity) + :count (progn (setf g (incf i)) 1) + :from-end (progn (setf h (incf i)) t) + ) + i a b c d e f g h)) + (a b c d f) 8 1 2 3 4 5 6 7 8) + +(deftest remove-if.order.1 + (let ((i 0) a b c d e f g) + (values + (remove-if + (progn (setf a (incf i)) #'(lambda (x) (eq x 'a))) + (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) + :from-end (progn (setf c (incf i)) t) + :count (progn (setf d (incf i)) 1) + :key (progn (setf e (incf i)) #'identity) + :start (progn (setf f (incf i)) 0) + :end (progn (setf g (incf i)) nil)) + i a b c d e f g)) + (a b c d f) 7 1 2 3 4 5 6 7) + +(deftest remove-if.order.2 + (let ((i 0) a b c d e f g) + (values + (remove-if + (progn (setf a (incf i)) #'(lambda (x) (eq x 'a))) + (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) + :end (progn (setf c (incf i)) nil) + :start (progn (setf d (incf i)) 0) + :key (progn (setf e (incf i)) #'identity) + :count (progn (setf f (incf i)) 1) + :from-end (progn (setf g (incf i)) t) + ) + i a b c d e f g)) + (a b c d f) 7 1 2 3 4 5 6 7) + +(deftest delete-if.order.1 + (let ((i 0) a b c d e f g) + (values + (delete-if + (progn (setf a (incf i)) #'(lambda (x) (eq x 'a))) + (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) + :from-end (progn (setf c (incf i)) t) + :count (progn (setf d (incf i)) 1) + :key (progn (setf e (incf i)) #'identity) + :start (progn (setf f (incf i)) 0) + :end (progn (setf g (incf i)) nil)) + i a b c d e f g)) + (a b c d f) 7 1 2 3 4 5 6 7) + +(deftest delete-if.order.2 + (let ((i 0) a b c d e f g) + (values + (delete-if + (progn (setf a (incf i)) #'(lambda (x) (eq x 'a))) + (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) + :end (progn (setf c (incf i)) nil) + :start (progn (setf d (incf i)) 0) + :key (progn (setf e (incf i)) #'identity) + :count (progn (setf f (incf i)) 1) + :from-end (progn (setf g (incf i)) t) + ) + i a b c d e f g)) + (a b c d f) 7 1 2 3 4 5 6 7) + +(deftest remove-if-not.order.1 + (let ((i 0) a b c d e f g) + (values + (remove-if-not + (progn (setf a (incf i)) #'(lambda (x) (not (eq x 'a)))) + (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) + :from-end (progn (setf c (incf i)) t) + :count (progn (setf d (incf i)) 1) + :key (progn (setf e (incf i)) #'identity) + :start (progn (setf f (incf i)) 0) + :end (progn (setf g (incf i)) nil)) + i a b c d e f g)) + (a b c d f) 7 1 2 3 4 5 6 7) + +(deftest remove-if-not.order.2 + (let ((i 0) a b c d e f g) + (values + (remove-if-not + (progn (setf a (incf i)) #'(lambda (x) (not (eq x 'a)))) + (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) + :end (progn (setf c (incf i)) nil) + :start (progn (setf d (incf i)) 0) + :key (progn (setf e (incf i)) #'identity) + :count (progn (setf f (incf i)) 1) + :from-end (progn (setf g (incf i)) t) + ) + i a b c d e f g)) + (a b c d f) 7 1 2 3 4 5 6 7) + +(deftest delete-if-not.order.1 + (let ((i 0) a b c d e f g) + (values + (delete-if-not + (progn (setf a (incf i)) #'(lambda (x) (not (eq x 'a)))) + (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) + :from-end (progn (setf c (incf i)) t) + :count (progn (setf d (incf i)) 1) + :key (progn (setf e (incf i)) #'identity) + :start (progn (setf f (incf i)) 0) + :end (progn (setf g (incf i)) nil)) + i a b c d e f g)) + (a b c d f) 7 1 2 3 4 5 6 7) + +(deftest delete-if-not.order.2 + (let ((i 0) a b c d e f g) + (values + (delete-if-not + (progn (setf a (incf i)) #'(lambda (x) (not (eq x 'a)))) + (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) + :end (progn (setf c (incf i)) nil) + :start (progn (setf d (incf i)) 0) + :key (progn (setf e (incf i)) #'identity) + :count (progn (setf f (incf i)) 1) + :from-end (progn (setf g (incf i)) t) + ) + i a b c d e f g)) + (a b c d f) 7 1 2 3 4 5 6 7) + +;;; Randomized tests + +(deftest remove-random + (loop for i from 1 to 2500 + unless (eq (random-test-remove 20) t) + do (return *remove-fail-args*)) + nil) + +(deftest remove-if-random + (loop for i from 1 to 2500 + unless (eq (random-test-remove-if 20) t) + do (return *remove-fail-args*)) + nil) + +(deftest remove-if-not-random + (loop for i from 1 to 2500 + unless (eq (random-test-remove-if 20 t) t) + do (return *remove-fail-args*)) + nil) + +(deftest delete-random + (loop for i from 1 to 2500 + unless (eq (random-test-delete 20) t) + do (return *remove-fail-args*)) + nil) + +(deftest delete-if-random + (loop for i from 1 to 2500 + unless (eq (random-test-delete-if 20) t) + do (return *remove-fail-args*)) + nil) + +(deftest delete-if-not-random + (loop for i from 1 to 2500 + unless (eq (random-test-delete-if 20 t) t) + do (return *remove-fail-args*)) + nil) + +;;; Additional tests with KEY = NIL + +(deftest remove-if-list.1 + (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) + (x (copy-seq orig)) + (y (remove-if #'evenp x :key nil))) + (and (equalp orig x) y)) + (1 3 1 1 3 7)) + +(deftest remove-if-list.2 + (let* ((orig '(a b c a b d a c b a e)) + (x (copy-seq orig)) + (y (remove-if #'(lambda (y) (eqt y 'a)) x :key nil))) + (and (equalp orig x) y)) + (b c b d c b e)) + +(deftest remove-if-not-list.1 + (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) + (x (copy-seq orig)) + (y (remove-if-not #'oddp x :key nil))) + (and (equalp orig x) y)) + (1 3 1 1 3 7)) + +(deftest remove-if-not-list.2 + (let* ((orig '(a b c a b d a c b a e)) + (x (copy-seq orig)) + (y (remove-if-not #'(lambda (y) (not (eqt y 'a))) x :key nil))) + (and (equalp orig x) y)) + (b c b d c b e)) + +(deftest delete-if-list.1 + (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) + (x (copy-seq orig)) + (y (delete-if #'evenp x :key nil))) + y) + (1 3 1 1 3 7)) + +(deftest delete-if-list.2 + (let* ((orig '(a b c a b d a c b a e)) + (x (copy-seq orig)) + (y (delete-if #'(lambda (y) (eqt y 'a)) x :key nil))) + y) + (b c b d c b e)) + +(deftest delete-if-not-list.1 + (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) + (x (copy-seq orig)) + (y (delete-if-not #'oddp x :key nil))) + y) + (1 3 1 1 3 7)) + +(deftest delete-if-not-list.2 + (let* ((orig '(a b c a b d a c b a e)) + (x (copy-seq orig)) + (y (delete-if-not #'(lambda (y) (not (eqt y 'a))) x :key nil))) + y) + (b c b d c b e)) + +(deftest delete-list.1 + (let* ((orig '(a b c a b d a c b a e)) + (x (copy-seq orig)) + (y (delete 'a x :key nil))) + y) + (b c b d c b e)) + +(deftest delete-list.2 + (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) + (x (copy-seq orig)) + (y (delete 2 x :key nil))) + y) + (1 3 6 1 4 1 3 7)) + +;;; Keyword tests + +(deftest remove.allow-other-keys.1 + (remove 'a '(a b c a d) :allow-other-keys t) + (b c d)) + +(deftest remove.allow-other-keys.2 + (remove 'a '(a b c a d) :allow-other-keys nil) + (b c d)) + +(deftest remove.allow-other-keys.3 + (remove 'a '(a b c a d) :bad t :allow-other-keys t) + (b c d)) + +(deftest remove.allow-other-keys.4 + (remove 'a '(a b c a d) :allow-other-keys t :bad t :bad nil) + (b c d)) + +(deftest remove.allow-other-keys.5 + (remove 'a '(a b c a d) :bad1 t :allow-other-keys t :bad2 t + :allow-other-keys nil :bad3 t) + (b c d)) + +(deftest remove.allow-other-keys.6 + (remove 'a '(a b c a d) :allow-other-keys t :from-end t :count 1) + (a b c d)) + +(deftest remove.keywords.7 + (remove 'a '(a b c a d) :from-end t :count 1 :from-end nil :count 10) + (a b c d)) + + +(deftest delete.allow-other-keys.1 + (delete 'a (copy-seq '(a b c a d)) :allow-other-keys t) + (b c d)) + +(deftest delete.allow-other-keys.2 + (delete 'a (copy-seq '(a b c a d)) :allow-other-keys nil) + (b c d)) + +(deftest delete.allow-other-keys.3 + (delete 'a (copy-seq '(a b c a d)) :bad t :allow-other-keys t) + (b c d)) + +(deftest delete.allow-other-keys.4 + (delete 'a (copy-seq '(a b c a d)) :allow-other-keys t :bad t :bad nil) + (b c d)) + +(deftest delete.allow-other-keys.5 + (delete 'a (copy-seq '(a b c a d)) :bad1 t :allow-other-keys t :bad2 t + :allow-other-keys nil :bad3 t) + (b c d)) + +(deftest delete.allow-other-keys.6 + (delete 'a (copy-seq '(a b c a d)) :allow-other-keys t :from-end t :count 1) + (a b c d)) + +(deftest delete.keywords.7 + (delete 'a (copy-seq '(a b c a d)) + :from-end t :count 1 :from-end nil :count 10) + (a b c d)) + + + +;;; Error cases + +(deftest remove.error.1 + (classify-error (remove)) + program-error) + +(deftest remove.error.2 + (classify-error (remove 'a)) + program-error) + +(deftest remove.error.3 + (classify-error (remove 'a nil :key)) + program-error) + +(deftest remove.error.4 + (classify-error (remove 'a nil 'bad t)) + program-error) + +(deftest remove.error.5 + (classify-error (remove 'a nil 'bad t :allow-other-keys nil)) + program-error) + +(deftest remove.error.6 + (classify-error (remove 'a nil 1 2)) + program-error) + +(deftest remove.error.7 + (classify-error (remove 'a (list 'a 'b 'c) :test #'identity)) + program-error) + +(deftest remove.error.8 + (classify-error (remove 'a (list 'a 'b 'c) :test-not #'identity)) + program-error) + +(deftest remove.error.9 + (classify-error (remove 'a (list 'a 'b 'c) :key #'cons)) + program-error) + +(deftest remove.error.10 + (classify-error (remove 'a (list 'a 'b 'c) :key #'car)) + type-error) + + +;;; + +(deftest delete.error.1 + (classify-error (delete)) + program-error) + +(deftest delete.error.2 + (classify-error (delete 'a)) + program-error) + +(deftest delete.error.3 + (classify-error (delete 'a nil :key)) + program-error) + +(deftest delete.error.4 + (classify-error (delete 'a nil 'bad t)) + program-error) + +(deftest delete.error.5 + (classify-error (delete 'a nil 'bad t :allow-other-keys nil)) + program-error) + +(deftest delete.error.6 + (classify-error (delete 'a nil 1 2)) + program-error) + +(deftest delete.error.7 + (classify-error (delete 'a (list 'a 'b 'c) :test #'identity)) + program-error) + +(deftest delete.error.8 + (classify-error (delete 'a (list 'a 'b 'c) :test-not #'identity)) + program-error) + +(deftest delete.error.9 + (classify-error (delete 'a (list 'a 'b 'c) :key #'cons)) + program-error) + +(deftest delete.error.10 + (classify-error (delete 'a (list 'a 'b 'c) :key #'car)) + type-error) diff --git a/ansi-tests/replace.lsp b/ansi-tests/replace.lsp new file mode 100644 index 0000000..310db89 --- /dev/null +++ b/ansi-tests/replace.lsp @@ -0,0 +1,685 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Aug 27 16:11:38 2002 +;;;; Contains: Tests for REPLACE + +(in-package :cl-test) + +(deftest replace-list.1 + (let* ((x (copy-seq '(a b c d e f g))) + (result (replace x '(x y z)))) + (values (eqt x result) result)) + t + (x y z d e f g)) + +(deftest replace-list.2 + (let* ((x (copy-seq '(a b c d e f g))) + (result (replace x '(x y z) :start1 1))) + (values (eqt x result) result)) + t + (a x y z e f g)) + +(deftest replace-list.3 + (let* ((x (copy-seq '(a b c d e f g))) + (result (replace x '(x y z) :start1 4))) + (values (eqt x result) result)) + t + (a b c d x y z)) + +(deftest replace-list.4 + (let* ((x (copy-seq '(a b c d e f g))) + (result (replace x '(x y z) :start1 5))) + (values (eqt x result) result)) + t + (a b c d e x y)) + +(deftest replace-list.5 + (let* ((x (copy-seq '(a b c d e f g))) + (result (replace x '(x y z) :start1 6))) + (values (eqt x result) result)) + t + (a b c d e f x)) + +(deftest replace-list.6 + (let* ((x (copy-seq '(a b c d e f g))) + (result (replace x #(x y z) :start1 2))) + (values (eqt x result) result)) + t + (a b x y z f g)) + +(deftest replace-list.7 + (replace nil #(x y z)) + nil) + +(deftest replace-list.8 + (let* ((x (copy-seq '(a b c d e f g))) + (result (replace x '(x y z) :end1 1))) + (values (eqt x result) result)) + t + (x b c d e f g)) + +(deftest replace-list.9 + (let* ((x (copy-seq '(a b c d e f g))) + (result (replace x '(x y z) :start1 3 :end1 4))) + (values (eqt x result) result)) + t + (a b c x e f g)) + +(deftest replace-list.10 + (let* ((x (copy-seq '(a b c d e f g))) + (result (replace x '(x y z) :start1 0 :end1 5))) + (values (eqt x result) result)) + t + (x y z d e f g)) + + +(deftest replace-list.11 + (let* ((x (copy-seq '(a b c d e f g))) + (result (replace x '(x y z) :start2 1))) + (values (eqt x result) result)) + t + (y z c d e f g)) + +(deftest replace-list.12 + (let* ((x (copy-seq '(a b c d e f g))) + (result (replace x '(x y z) :start2 1 :end1 nil))) + (values (eqt x result) result)) + t + (y z c d e f g)) + +(deftest replace-list.13 + (let* ((x (copy-seq '(a b c d e f g))) + (result (replace x '(x y z) :start2 1 :end2 nil))) + (values (eqt x result) result)) + t + (y z c d e f g)) + +(deftest replace-list.14 + (let* ((x (copy-seq '(a b c d e f g))) + (result (replace x '(x y z) :start2 1 :end2 2))) + (values (eqt x result) result)) + t + (y b c d e f g)) + +(deftest replace-list.15 + (let* ((x (copy-seq '(a b c d e f g))) + (result (replace x '(x y z) :start1 4 :end1 5 :start2 1 :end2 2))) + (values (eqt x result) result)) + t + (a b c d y f g)) + +(deftest replace-list.16 + (let* ((x (copy-seq '(a b c d e f))) + (y #(1 2 3)) + (result (replace x y :start1 1))) + (values (eqt x result) result)) + t + (a 1 2 3 e f)) + +(deftest replace-list.17 + (let* ((x (copy-seq '(a b c d e f))) + (y (make-array '(3) :initial-contents '(1 2 3) + :fill-pointer t)) + (result (replace x y :start1 1))) + (values (eqt x result) result)) + t + (a 1 2 3 e f)) + +(deftest replace-list.18 + (let* ((x (copy-seq '(a b c d e f))) + (y (make-array '(6) :initial-contents '(1 2 3 4 5 6) + :fill-pointer 3)) + (result (replace x y :start1 1))) + (values (eqt x result) result)) + t + (a 1 2 3 e f)) + +(deftest replace-list.19 + (let* ((x (copy-seq '(a b c d e f))) + (result (replace x x :start1 0 :end1 3 :start2 1 :end2 4))) + (values (eqt x result) result)) + t + (b c d d e f)) + +(deftest replace-list.20 + (let* ((x (copy-seq '(a b c d e f))) + (result (replace x x :start1 1 :end1 4 :start2 0 :end2 3))) + (values (eqt x result) result)) + t + (a a b c e f)) + + +;;; Tests of vectors + +(deftest replace-vector.1 + (let* ((x (copy-seq #(a b c d e f g))) + (result (replace x #(x y z)))) + (values (eqt x result) result)) + t + #(x y z d e f g)) + +(deftest replace-vector.2 + (let* ((x (copy-seq #(a b c d e f g))) + (result (replace x #(x y z) :start1 1))) + (values (eqt x result) result)) + t + #(a x y z e f g)) + +(deftest replace-vector.3 + (let* ((x (copy-seq #(a b c d e f g))) + (result (replace x #(x y z) :start1 4))) + (values (eqt x result) result)) + t + #(a b c d x y z)) + +(deftest replace-vector.4 + (let* ((x (copy-seq #(a b c d e f g))) + (result (replace x #(x y z) :start1 5))) + (values (eqt x result) result)) + t + #(a b c d e x y)) + +(deftest replace-vector.5 + (let* ((x (copy-seq #(a b c d e f g))) + (result (replace x #(x y z) :start1 6))) + (values (eqt x result) result)) + t + #(a b c d e f x)) + +(deftest replace-vector.6 + (let* ((x (copy-seq #(a b c d e f g))) + (result (replace x '(x y z) :start1 2))) + (values (eqt x result) result)) + t + #(a b x y z f g)) + +(deftest replace-vector.7 + (replace #() #(x y z)) + #()) + +(deftest replace-vector.8 + (let* ((x (copy-seq #(a b c d e f g))) + (result (replace x #(x y z) :end1 1))) + (values (eqt x result) result)) + t + #(x b c d e f g)) + +(deftest replace-vector.9 + (let* ((x (copy-seq #(a b c d e f g))) + (result (replace x #(x y z) :start1 3 :end1 4))) + (values (eqt x result) result)) + t + #(a b c x e f g)) + +(deftest replace-vector.10 + (let* ((x (copy-seq #(a b c d e f g))) + (result (replace x #(x y z) :start1 0 :end1 5))) + (values (eqt x result) result)) + t + #(x y z d e f g)) + + +(deftest replace-vector.11 + (let* ((x (copy-seq #(a b c d e f g))) + (result (replace x #(x y z) :start2 1))) + (values (eqt x result) result)) + t + #(y z c d e f g)) + +(deftest replace-vector.12 + (let* ((x (copy-seq #(a b c d e f g))) + (result (replace x #(x y z) :start2 1 :end1 nil))) + (values (eqt x result) result)) + t + #(y z c d e f g)) + +(deftest replace-vector.13 + (let* ((x (copy-seq #(a b c d e f g))) + (result (replace x #(x y z) :start2 1 :end2 nil))) + (values (eqt x result) result)) + t + #(y z c d e f g)) + +(deftest replace-vector.14 + (let* ((x (copy-seq #(a b c d e f g))) + (result (replace x #(x y z) :start2 1 :end2 2))) + (values (eqt x result) result)) + t + #(y b c d e f g)) + +(deftest replace-vector.15 + (let* ((x (copy-seq #(a b c d e f g))) + (result (replace x #(x y z) :start1 4 :end1 5 :start2 1 :end2 2))) + (values (eqt x result) result)) + t + #(a b c d y f g)) + +(deftest replace-vector.16 + (let* ((x (copy-seq #(a b c d e f))) + (y '(1 2 3)) + (result (replace x y :start1 1))) + (values (eqt x result) result)) + t + #(a 1 2 3 e f)) + +(deftest replace-vector.17 + (let* ((x (copy-seq #(a b c d e f))) + (y (make-array '(3) :initial-contents '(1 2 3) + :fill-pointer t)) + (result (replace x y :start1 1))) + (values (eqt x result) result)) + t + #(a 1 2 3 e f)) + +(deftest replace-vector.18 + (let* ((x (copy-seq #(a b c d e f))) + (y (make-array '(6) :initial-contents '(1 2 3 4 5 6) + :fill-pointer 3)) + (result (replace x y :start1 1))) + (values (eqt x result) result)) + t + #(a 1 2 3 e f)) + +(deftest replace-vector.19 + (let* ((x (copy-seq #(a b c d e f))) + (result (replace x x :start1 0 :end1 3 :start2 1 :end2 4))) + (values (eqt x result) result)) + t + #(b c d d e f)) + +(deftest replace-vector.21 + (let* ((x (copy-seq #(a b c d e f))) + (result (replace x x :start1 1 :end1 4 :start2 0 :end2 3))) + (values (eqt x result) result)) + t + #(a a b c e f)) + +;;; tests on bit vectors + +(deftest replace-bit-vector.1 + (let* ((x (copy-seq #*1101001)) + (result (replace x #*011))) + (values (eqt x result) result)) + t + #*0111001) + +(deftest replace-bit-vector.2 + (let* ((x (copy-seq #*1101001)) + (result (replace x #*011 :start1 1))) + (values (eqt x result) result)) + t + #*1011001) + +(deftest replace-bit-vector.3 + (let* ((x (copy-seq #*1101001)) + (result (replace x #*011 :start1 4))) + (values (eqt x result) result)) + t + #*1101011) + +(deftest replace-bit-vector.4 + (let* ((x (copy-seq #*0000000)) + (result (replace x #*111 :start1 5))) + (values (eqt x result) result)) + t + #*0000011) + +(deftest replace-bit-vector.5 + (let* ((x (copy-seq #*0000000)) + (result (replace x #*100 :start1 6))) + (values (eqt x result) result)) + t + #*0000001) + +(deftest replace-bit-vector.6 + (let* ((x (copy-seq #*0000000)) + (result (replace x '(1 1 1) :start1 2))) + (values (eqt x result) result)) + t + #*0011100) + +(deftest replace-bit-vector.7 + (replace #* #*111) + #*) + +(deftest replace-bit-vector.8 + (let* ((x (copy-seq #*0000000)) + (result (replace x #*111 :end1 1))) + (values (eqt x result) result)) + t + #*1000000) + +(deftest replace-bit-vector.9 + (let* ((x (copy-seq #*0000000)) + (result (replace x #*110 :start1 3 :end1 4))) + (values (eqt x result) result)) + t + #*0001000) + +(deftest replace-bit-vector.10 + (let* ((x (copy-seq #*0000000)) + (result (replace x #*111 :start1 0 :end1 5))) + (values (eqt x result) result)) + t + #*1110000) + + +(deftest replace-bit-vector.11 + (let* ((x (copy-seq #*0000000)) + (result (replace x #*011 :start2 1))) + (values (eqt x result) result)) + t + #*1100000) + +(deftest replace-bit-vector.12 + (let* ((x (copy-seq #*0000000)) + (result (replace x #*011 :start2 1 :end1 nil))) + (values (eqt x result) result)) + t + #*1100000) + +(deftest replace-bit-vector.13 + (let* ((x (copy-seq #*0000000)) + (result (replace x #*011 :start2 1 :end2 nil))) + (values (eqt x result) result)) + t + #*1100000) + +(deftest replace-bit-vector.14 + (let* ((x (copy-seq #*0000000)) + (result (replace x #*011 :start2 1 :end2 2))) + (values (eqt x result) result)) + t + #*1000000) + +(deftest replace-bit-vector.15 + (let* ((x (copy-seq #*0000000)) + (result (replace x #*011 :start1 4 :end1 5 :start2 1 :end2 2))) + (values (eqt x result) result)) + t + #*0000100) + +(deftest replace-bit-vector.16 + (let* ((x (copy-seq #*001011)) + (y '(1 0 1)) + (result (replace x y :start1 1))) + (values (eqt x result) result)) + t + #*010111) + +(deftest replace-bit-vector.17 + (let* ((x (copy-seq #*001011)) + (y (make-array '(3) :initial-contents '(1 0 1) + :fill-pointer t :element-type 'bit)) + (result (replace x y :start1 1))) + (values (eqt x result) result)) + t + #*010111) + +(deftest replace-bit-vector.18 + (let* ((x (copy-seq #*001011)) + (y (make-array '(6) :initial-contents '(1 0 1 0 0 1) + :fill-pointer 3 + :element-type 'bit)) + (result (replace x y :start1 1))) + (values (eqt x result) result)) + t + #*010111) + +(deftest replace-bit-vector.19 + (let* ((x (copy-seq #*001011)) + (result (replace x x :start1 0 :end1 3 :start2 1 :end2 4))) + (values (eqt x result) result)) + t + #*010011) + +(deftest replace-bit-vector.21 + (let* ((x (copy-seq #*001011)) + (result (replace x x :start1 1 :end1 4 :start2 0 :end2 3))) + (values (eqt x result) result)) + t + #*000111) + +;;; Tests on strings + +(deftest replace-string.1 + (let* ((x (copy-seq "abcdefg")) + (result (replace x "xyz"))) + (values (eqt x result) result)) + t + "xyzdefg") + +(deftest replace-string.2 + (let* ((x (copy-seq "abcdefg")) + (result (replace x "xyz" :start1 1))) + (values (eqt x result) result)) + t + "axyzefg") + +(deftest replace-string.3 + (let* ((x (copy-seq "abcdefg")) + (result (replace x "xyz" :start1 4))) + (values (eqt x result) result)) + t + "abcdxyz") + +(deftest replace-string.4 + (let* ((x (copy-seq "abcdefg")) + (result (replace x "xyz" :start1 5))) + (values (eqt x result) result)) + t + "abcdexy") + +(deftest replace-string.5 + (let* ((x (copy-seq "abcdefg")) + (result (replace x "xyz" :start1 6))) + (values (eqt x result) result)) + t + "abcdefx") + +(deftest replace-string.6 + (let* ((x (copy-seq "abcdefg")) + (result (replace x '(#\x #\y #\z) :start1 2))) + (values (eqt x result) result)) + t + "abxyzfg") + +(deftest replace-string.7 + (replace "" "xyz") + "") + +(deftest replace-string.8 + (let* ((x (copy-seq "abcdefg")) + (result (replace x "xyz" :end1 1))) + (values (eqt x result) result)) + t + "xbcdefg") + +(deftest replace-string.9 + (let* ((x (copy-seq "abcdefg")) + (result (replace x "xyz" :start1 3 :end1 4))) + (values (eqt x result) result)) + t + "abcxefg") + +(deftest replace-string.10 + (let* ((x (copy-seq "abcdefg")) + (result (replace x "xyz" :start1 0 :end1 5))) + (values (eqt x result) result)) + t + "xyzdefg") + + +(deftest replace-string.11 + (let* ((x (copy-seq "abcdefg")) + (result (replace x "xyz" :start2 1))) + (values (eqt x result) result)) + t + "yzcdefg") + +(deftest replace-string.12 + (let* ((x (copy-seq "abcdefg")) + (result (replace x "xyz" :start2 1 :end1 nil))) + (values (eqt x result) result)) + t + "yzcdefg") + +(deftest replace-string.13 + (let* ((x (copy-seq "abcdefg")) + (result (replace x "xyz" :start2 1 :end2 nil))) + (values (eqt x result) result)) + t + "yzcdefg") + +(deftest replace-string.14 + (let* ((x (copy-seq "abcdefg")) + (result (replace x "xyz" :start2 1 :end2 2))) + (values (eqt x result) result)) + t + "ybcdefg") + +(deftest replace-string.15 + (let* ((x (copy-seq "abcdefg")) + (result (replace x "xyz" :start1 4 :end1 5 :start2 1 :end2 2))) + (values (eqt x result) result)) + t + "abcdyfg") + +(deftest replace-string.16 + (let* ((x (copy-seq "abcdef")) + (y (coerce "123" 'list)) + (result (replace x y :start1 1))) + (values (eqt x result) result)) + t + "a123ef") + +(deftest replace-string.17 + (let* ((x (copy-seq "abcdef")) + (y (make-array '(3) :initial-contents '(#\1 #\2 #\3) + :fill-pointer t :element-type 'character)) + (result (replace x y :start1 1))) + (values (eqt x result) result)) + t + "a123ef") + +(deftest replace-string.18 + (let* ((x (copy-seq "abcdef")) + (y (make-array '(6) :initial-contents "123456" + :fill-pointer 3 + :element-type 'character)) + (result (replace x y :start1 1))) + (values (eqt x result) result)) + t + "a123ef") + +(deftest replace-string.19 + (let* ((x (copy-seq "abcdef")) + (result (replace x x :start1 0 :end1 3 :start2 1 :end2 4))) + (values (eqt x result) result)) + t + "bcddef") + +(deftest replace-string.21 + (let* ((x (copy-seq "abcdef")) + (result (replace x x :start1 1 :end1 4 :start2 0 :end2 3))) + (values (eqt x result) result)) + t + "aabcef") + +;;; Order of evaluation tests + +(deftest replace.order.1 + (let ((i 0) a b) + (values + (replace (progn (setf a (incf i)) (list 'a 'b 'c)) + (progn (setf b (incf i)) (list 'e 'f))) + i a b)) + (e f c) 2 1 2) + +(deftest replace.order.2 + (let ((i 0) a b c d e f) + (values + (replace (progn (setf a (incf i)) (list 'a 'b 'c)) + (progn (setf b (incf i)) (list 'e 'f)) + :start1 (progn (setf c (incf i)) 1) + :end1 (progn (setf d (incf i)) 3) + :start2 (progn (setf e (incf i)) 0) + :end2 (progn (setf f (incf i)) 2) + ) + i a b c d e f)) + (a e f) 6 1 2 3 4 5 6) + +(deftest replace.order.3 + (let ((i 0) a b c d e f) + (values + (replace (progn (setf a (incf i)) (list 'a 'b 'c)) + (progn (setf b (incf i)) (list 'e 'f)) + :end2 (progn (setf c (incf i)) 2) + :start2 (progn (setf d (incf i)) 0) + :end1 (progn (setf e (incf i)) 3) + :start1 (progn (setf f (incf i)) 1) + ) + i a b c d e f)) + (a e f) 6 1 2 3 4 5 6) + +;;; Keyword tests + +(deftest replace.allow-other-keys.1 + (replace (copy-seq "abcdefg") "xyz" :allow-other-keys t) + "xyzdefg") + +(deftest replace.allow-other-keys.2 + (replace (copy-seq "abcdefg") "xyz" :allow-other-keys nil) + "xyzdefg") + +(deftest replace.allow-other-keys.3 + (replace (copy-seq "abcdefg") "xyz" :allow-other-keys t :bad t) + "xyzdefg") + +(deftest replace.allow-other-keys.4 + (replace (copy-seq "abcdefg") "xyz" :bad t :allow-other-keys t) + "xyzdefg") + +(deftest replace.allow-other-keys.5 + (replace (copy-seq "abcdefg") "xyz" :bad1 t :allow-other-keys t + :bad2 t :allow-other-keys nil :bad3 nil) + "xyzdefg") + +(deftest replace.allow-other-keys.6 + (replace (copy-seq "abcdefg") "xyz" :allow-other-keys t :start1 1) + "axyzefg") + +(deftest replace.keywords.7 + (replace (copy-seq "abcdefg") "xyz" :start1 0 :start2 0 :end1 3 :end2 3 + :start1 1 :start2 1 :end1 2 :end1 2) + "xyzdefg") + + + + +;;; Error cases + +(deftest replace.error.1 + (classify-error (replace)) + program-error) + +(deftest replace.error.2 + (classify-error (replace nil)) + program-error) + +(deftest replace.error.3 + (classify-error (replace nil nil :start)) + program-error) + +(deftest replace.error.4 + (classify-error (replace nil nil 'bad t)) + program-error) + +(deftest replace.error.5 + (classify-error (replace nil nil :allow-other-keys nil 'bad t)) + program-error) + +(deftest replace.error.6 + (classify-error (replace nil nil 1 2)) + program-error) + diff --git a/ansi-tests/reverse.lsp b/ansi-tests/reverse.lsp new file mode 100644 index 0000000..cf1ab93 --- /dev/null +++ b/ansi-tests/reverse.lsp @@ -0,0 +1,131 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Aug 20 23:47:28 2002 +;;;; Contains: Tests for REVERSE + +(in-package :cl-test) + +(deftest reverse-list.1 + (reverse nil) + nil) + +(deftest reverse-list.2 + (let ((x '(a b c))) + (values (reverse x) x)) + (c b a) + (a b c)) + +(deftest reverse-vector.1 + (reverse #()) + #()) + +(deftest reverse-vector.2 + (let ((x #(a b c d e))) + (values (reverse x) x)) + #(e d c b a) + #(a b c d e)) + +(deftest reverse-nonsimple-vector.1 + (let ((x (make-array 0 :fill-pointer t :adjustable t))) + (reverse x)) + #()) + +(deftest reverse-nonsimple-vector.2 + (let* ((x (make-array 5 :initial-contents '(1 2 3 4 5) + :fill-pointer t :adjustable t)) + (y (reverse x))) + (values y x)) + #(5 4 3 2 1) + #(1 2 3 4 5)) + +(deftest reverse-nonsimple-vector.3 + (let* ((x (make-array 10 :initial-contents '(1 2 3 4 5 6 7 8 9 10) + :fill-pointer 5)) + (y (reverse x))) + y) + #(5 4 3 2 1)) + +(deftest reverse-bit-vector.1 + (reverse #*) + #*) + +(deftest reverse-bit-vector.2 + (let ((x #*000110110110)) + (values (reverse x) x)) + #*011011011000 + #*000110110110) + +(deftest reverse-bit-vector.3 + (let* ((x (make-array 10 :initial-contents '(0 0 0 1 1 0 1 0 1 0) + :fill-pointer 5 + :element-type 'bit)) + (y (reverse x))) + y) + #*11000) + +(deftest reverse-string.1 + (reverse "") + "") + +(deftest reverse-string.2 + (let ((x "000110110110")) + (values (reverse x) x)) + "011011011000" + "000110110110") + +(deftest reverse-string.3 + (let* ((x (make-array 10 :initial-contents "abcdefghij" + :fill-pointer 5 + :element-type 'character)) + (y (reverse x))) + y) + "edcba") + +(deftest reverse-string.4 + (let* ((x (make-array 10 :initial-contents "abcdefghij" + :fill-pointer 5 + :element-type 'base-char)) + (y (reverse x))) + y) + "edcba") + +(deftest reverse.order.1 + (let ((i 0)) + (values + (reverse (progn (incf i) (list 'a 'b 'c 'd))) + i)) + (d c b a) 1) + +;;; Error cases + +(deftest reverse.error.1 + (classify-error (reverse 'a)) + type-error) + +(deftest reverse.error.2 + (classify-error (reverse #\a)) + type-error) + +(deftest reverse.error.3 + (classify-error (reverse 10)) + type-error) + +(deftest reverse.error.4 + (classify-error (reverse 0.3)) + type-error) + +(deftest reverse.error.5 + (classify-error (reverse 10/3)) + type-error) + +(deftest reverse.error.6 + (classify-error (reverse)) + program-error) + +(deftest reverse.error.7 + (classify-error (reverse nil nil)) + program-error) + +(deftest reverse.error.8 + (classify-error (locally (reverse 'a) t)) + type-error) diff --git a/ansi-tests/row-major-aref.lsp b/ansi-tests/row-major-aref.lsp new file mode 100644 index 0000000..48d4d3e --- /dev/null +++ b/ansi-tests/row-major-aref.lsp @@ -0,0 +1,112 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Jan 22 20:16:38 2003 +;;;; Contains: Tests of ROW-MAJOR-AREF + +(in-package :cl-test) + +;;; ROW-MAJOR-AREF is also used by equalp-with-case (see rt/rt.lsp) + +(deftest row-major-aref.1 + (loop for i from 0 to 5 collect (row-major-aref #(a b c d e f) i)) + (a b c d e f)) + +(deftest row-major-aref.2 + (loop for i from 0 to 5 collect (row-major-aref #2a((a b c d)(e f g h)) i)) + (a b c d e f)) + +(deftest row-major-aref.3 + (row-major-aref #0a100 0) + 100) + +(deftest row-major-aref.4 + (loop for i from 0 to 5 collect (row-major-aref #*011100 i)) + (0 1 1 1 0 0)) + +(deftest row-major-aref.5 + (loop for i from 0 to 5 collect (row-major-aref "abcdef" i)) + (#\a #\b #\c #\d #\e #\f)) + +(deftest row-major-aref.6 + (let ((a (make-array nil :initial-element 'x))) + (values + (aref a) + (setf (row-major-aref a 0) 'y) + (aref a) + a)) + x y y #0ay) + +(deftest row-major-aref.7 + (let ((a (make-array '(4) :initial-element 'x))) + (values + (aref a 0) + (aref a 1) + (aref a 2) + (aref a 3) + (setf (row-major-aref a 0) 'a) + (setf (row-major-aref a 1) 'b) + (setf (row-major-aref a 2) 'c) + a)) + x x x x a b c #(a b c x)) + +(deftest row-major-aref.8 + (let ((a (make-array '(4) :element-type 'base-char + :initial-element #\x))) + (values + (aref a 0) + (aref a 1) + (aref a 2) + (aref a 3) + (setf (row-major-aref a 0) #\a) + (setf (row-major-aref a 1) #\b) + (setf (row-major-aref a 2) #\c) + a)) + #\x #\x #\x #\x #\a #\b #\c "abcx") + +(deftest row-major-aref.9 + (let ((a (make-array '(4) :initial-element 0 + :element-type 'bit))) + (values + (aref a 0) + (aref a 1) + (aref a 2) + (aref a 3) + (setf (row-major-aref a 0) 1) + (setf (row-major-aref a 1) 1) + (setf (row-major-aref a 3) 1) + a)) + 0 0 0 0 1 1 1 #*1101) + +(deftest row-major-aref.10 + (let ((a (make-array '(2 3 4) + :initial-contents '(((a b c d)(e f g h)(i j k l)) + ((m n o p)(q r s t)(u v w x)))))) + (loop for i from 0 to 23 collect (row-major-aref a i))) + (a b c d e f g h i j k l m n o p q r s t u v w x)) + +(deftest row-major-aref.order.1 + (let ((i 0) x y) + (values + (row-major-aref + (progn (setf x (incf i)) #(a b c d e f)) + (progn (setf y (incf i)) 2)) + i x y)) + c 2 1 2) + +(deftest row-major-aref.order.2 + (let ((i 0) x y z + (a (copy-seq #(a b c d e f)))) + (values + (setf + (row-major-aref + (progn (setf x (incf i)) a) + (progn (setf y (incf i)) 2)) + (progn (setf z (incf i)) 'w)) + a i x y z)) + w #(a b w d e f) 3 1 2 3) + +;;; Error tests + +(deftest row-major-aref.error.1 + (classify-error (row-major-aref)) + program-error) diff --git a/ansi-tests/rt-acl.system b/ansi-tests/rt-acl.system new file mode 100644 index 0000000..d9cfc7f --- /dev/null +++ b/ansi-tests/rt-acl.system @@ -0,0 +1,12 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 7 23:30:22 1998 +;;;; Contains: Allegro CL defsystem for RT testing system + +(defsystem :rt-acl + (:default-pathname #.(directory-namestring (truename *LOAD-PATHNAME*)) + :default-file-type "lsp") + (:definitions + "rt-package" + "rt")) + diff --git a/ansi-tests/rt-doc.txt b/ansi-tests/rt-doc.txt new file mode 100644 index 0000000..8c07b8d --- /dev/null +++ b/ansi-tests/rt-doc.txt @@ -0,0 +1,194 @@ + +#|----------------------------------------------------------------------------| + | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. | + | | + | Permission to use, copy, modify, and distribute this software and its | + | documentation for any purpose and without fee is hereby granted, provided | + | that this copyright and permission notice appear in all copies and | + | supporting documentation, and that the name of M.I.T. not be used in | + | advertising or publicity pertaining to distribution of the software | + | without specific, written prior permission. M.I.T. makes no | + | representations about the suitability of this software for any purpose. | + | It is provided "as is" without express or implied warranty. | + | | + | M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING | + | ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL | + | M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR | + | ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, | + | WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, | + | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS | + | SOFTWARE. | + |----------------------------------------------------------------------------|# + + (This is the December 19, 1990 version of brief documentation for the + RT regression tester. A more complete discussion can be found in + the article in Lisp Pointers.) + +The functions, macros, and variables that make up the RT regression tester are +in a package called "RT". The ten exported symbols are documented below. If +you want to refer to these symbols without a package prefix, you have to `use' +the package. + +The basic unit of concern of RT is the test. Each test has an identifying name +and a body that specifies the action of the test. Functions are provided for +defining, redefining, removing, and performing individual tests and the test +suite as a whole. In addition, information is maintained about which tests have +succeeded and which have failed. + + +<> deftest NAME FORM &rest VALUES + +Individual tests are defined using the macro DEFTEST. The identifying NAME is +typically a number or symbol, but can be any Lisp form. If the test suite +already contains a test with the same (EQUAL) NAME, then this test is redefined +and a warning message printed. (This warning is important to alert the user +when a test suite definition file contains two tests with the same name.) When +the test is a new one, it is added to the end of the suite. In either case, +NAME is returned as the value of DEFTEST and stored in the variable *TEST*. + +(deftest t-1 (floor 15/7) 2 1/7) => t-1 + +(deftest (t 2) (list 1) (1)) => (t 2) + +(deftest bad (1+ 1) 1) => bad + +(deftest good (1+ 1) 2) => good + +The FORM can be any kind of Lisp form. The zero or more VALUES can be any kind +of Lisp objects. The test is performed by evaluating FORM and comparing the +results with the VALUES. The test succeeds if and only if FORM produces the +correct number of results and each one is EQUAL to the corresponding VALUE. + + +<> *test* NAME-OF-CURRENT-TEST + +The variable *TEST* contains the name of the test most recently defined or +performed. It is set by DEFTEST and DO-TEST. + + +<> do-test &optional (NAME *TEST*) + +The function DO-TEST performs the test identified by NAME, which defaults to +*TEST*. Before running the test, DO-TEST stores NAME in the variable *TEST*. +If the test succeeds, DO-TEST returns NAME as its value. If the test fails, +DO-TEST returns NIL, after printing an error report on *STANDARD-OUTPUT*. The +following examples show the results of performing two of the tests defined +above. + +(do-test '(t 2)) => (t 2) + +(do-test 'bad) => nil ; after printing: +Test BAD failed +Form: (1+ 1) +Expected value: 1 +Actual value: 2. + + +<> *do-tests-when-defined* default value NIL + +If the value of this variable is non-null, each test is performed at the moment +that it is defined. This is helpful when interactively constructing a suite of +tests. However, when loading a test suite for later use, performing tests as +they are defined is not liable to be helpful. + + +<> get-test &optional (NAME *TEST*) + +This function returns the NAME, FORM, and VALUES of the specified test. + +(get-test '(t 2)) => ((t 2) (list 1) (1)) + + +<> rem-test &optional (NAME *TEST*) + +If the indicated test is in the test suite, this function removes it and returns +NAME. Otherwise, NIL is returned. + + +<> rem-all-tests + +This function reinitializes RT by removing every test from the test suite and +returns NIL. Generally, it is advisable for the whole test suite to apply to +some one system. When switching from testing one system to testing another, it +is wise to remove all the old tests before beginning to define new ones. + + +<> do-tests &optional (OUT *STANDARD-OUTPUT*) + +This function uses DO-TEST to run each of the tests in the test suite and prints +a report of the results on OUT, which can either be an output stream or the name +of a file. If OUT is omitted, it defaults to *STANDARD-OUTPUT*. DO-TESTS +returns T if every test succeeded and NIL if any test failed. + +As illustrated below, the first line of the report produced by DO-TEST shows how +many tests need to be performed. The last line shows how many tests failed and +lists their names. While the tests are being performed, DO-TESTS prints the +names of the successful tests and the error reports from the unsuccessful tests. + +(do-tests "report.txt") => nil +; the file "report.txt" contains: +Doing 4 pending tests of 4 tests total. + T-1 (T 2) +Test BAD failed +Form: (1+ 1) +Expected value: 1 +Actual value: 2. + GOOD +1 out of 4 total tests failed: BAD. + +It is best if the individual tests in the suite are totally independent of each +other. However, should the need arise for some interdependence, you can rely on +the fact that DO-TESTS will run tests in the order they were originally defined. + + +<> pending-tests + +When a test is defined or redefined, it is marked as pending. In addition, +DO-TEST marks the test to be run as pending before running it and DO-TESTS marks +every test as pending before running any of them. The only time a test is +marked as not pending is when it completes successfully. The function +PENDING-TESTS returns a list of the names of the currently pending tests. + +(pending-tests) => (bad) + + +<> continue-testing + +This function is identical to DO-TESTS except that it only runs the tests that +are pending and always writes its output on *STANDARD-OUTPUT*. + +(continue-testing) => nil ; after printing: +Doing 1 pending test out of 4 total tests. +Test BAD failed +Form: (1+ 1) +Expected value: 1 +Actual value: 2. +1 out of 4 total tests failed: BAD. + +CONTINUE-TESTING has a special meaning if called at a breakpoint generated while +a test is being performed. The failure of a test to return the correct value +does not trigger an error break. However, there are many kinds of things that +can go wrong while a test is being performed (e.g., dividing by zero) that will +cause breaks. + +If CONTINUE-TESTING is evaluated in a break generated during testing, it aborts +the current test (which remains pending) and forces the processing of tests to +continue. Note that in such a breakpoint, *TEST* is bound to the name of the +test being performed and (GET-TEST) can be used to look at the test. + +When building a system, it is advisable to start constructing a test suite for +it as soon as possible. Since individual tests are rather weak, a comprehensive +test suite requires large numbers of tests. However, these can be accumulated +over time. In particular, whenever a bug is found by some means other than +testing, it is wise to add a test that would have found the bug and therefore +will ensure that the bug will not reappear. + +Every time the system is changed, the entire test suite should be run to make +sure that no unintended changes have occurred. Typically, some tests will fail. +Sometimes, this merely means that tests have to be changed to reflect changes in +the system's specification. Other times, it indicates bugs that have to be +tracked down and fixed. During this phase, CONTINUE-TESTING is useful for +focusing on the tests that are failing. However, for safety sake, it is always +wise to reinitialize RT, redefine the entire test suite, and run DO-TESTS one +more time after you think all of the tests are working. + diff --git a/ansi-tests/rt-package.lsp b/ansi-tests/rt-package.lsp new file mode 100644 index 0000000..dd4d4ec --- /dev/null +++ b/ansi-tests/rt-package.lsp @@ -0,0 +1,25 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Dec 17 21:10:53 2002 +;;;; Contains: Package definition for RT + +(eval-when + ;;(:execute :compile-toplevel :load-toplevel) + (load eval compile) + (defpackage :regression-test + (:use :cl) + (:nicknames :rtest #-lispworks :rt) + (:export + #:*do-tests-when-defined* + #:*test* + #:continue-testing + #:deftest + #:do-test + #:do-tests + #:get-test + #:pending-tests + #:rem-all-tests + #:rem-test + ))) + +(in-package :regression-test) diff --git a/ansi-tests/rt-test.lsp b/ansi-tests/rt-test.lsp new file mode 100644 index 0000000..73a87be --- /dev/null +++ b/ansi-tests/rt-test.lsp @@ -0,0 +1,229 @@ +;-*-syntax:COMMON-LISP-*- + +#|----------------------------------------------------------------------------| + | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. | + | | + | Permission to use, copy, modify, and distribute this software and its | + | documentation for any purpose and without fee is hereby granted, provided | + | that this copyright and permission notice appear in all copies and | + | supporting documentation, and that the name of M.I.T. not be used in | + | advertising or publicity pertaining to distribution of the software | + | without specific, written prior permission. M.I.T. makes no | + | representations about the suitability of this software for any purpose. | + | It is provided "as is" without express or implied warranty. | + | | + | M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING | + | ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL | + | M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR | + | ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, | + | WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, | + | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS | + | SOFTWARE. | + |----------------------------------------------------------------------------|# + +;This is the December 19, 1990 version of a set of tests that use the +;RT regression tester to test itself. See the documentation of RT for +;a discusion of how to use this file. + +(in-package :user) +;; (require "RT") +(use-package :regression-test) + +(defmacro setup (&rest body) + `(do-setup '(progn ., body))) + +(defun do-setup (form) + (let ((*test* nil) + (*do-tests-when-defined* nil) + (regression-test::*entries* (list nil)) + (regression-test::*in-test* nil) + (regression-test::*debug* t) + result) + (deftest t1 4 4) + (deftest (t 2) 4 3) + (values-list + (cons (normalize + (with-output-to-string (*standard-output*) + (setq result + (multiple-value-list + (catch 'regression-test::*debug* (eval form)))))) + result)))) + +(defun normalize (string) + (with-input-from-string (s string) + (normalize-stream s))) + +(defvar *file-name* nil) + +(defun get-file-name () + (loop (if *file-name* (return *file-name*)) + (format *error-output* + "~%Type a string representing naming of a scratch disk file: ") + (setq *file-name* (read)) + (if (not (stringp *file-name*)) (setq *file-name* nil)))) + +(get-file-name) + +(defmacro with-temporary-file (f &body forms) + `(let ((,f *file-name*)) + ,@ forms + (get-file-output ,f))) + +(defun get-file-output (f) + (prog1 (with-open-file (in f) + (normalize-stream in)) + (delete-file f))) + +(defun normalize-stream (s) + (let ((l nil)) + (loop (push (read-line s nil s) l) + (when (eq (car l) s) + (setq l (nreverse (cdr l))) + (return nil))) + (delete "" l :test #'equal))) + +(rem-all-tests) + +(deftest deftest-1 + (setup (deftest t1 3 3) (values (get-test 't1) *test* (pending-tests))) + ("Redefining test T1") (t1 3 3) t1 (t1 (t 2))) +(deftest deftest-2 + (setup (deftest (t 2) 3 3) (get-test '(t 2))) + ("Redefining test (T 2)") ((t 2) 3 3)) +(deftest deftest-3 + (setup (deftest 2 3 3) (values (get-test 2) *test* (pending-tests))) + () (2 3 3) 2 (t1 (t 2) 2)) +(deftest deftest-4 + (setup (let ((*do-tests-when-defined* t)) (deftest (temp) 4 3))) + ("Test (TEMP) failed" + "Form: 4" + "Expected value: 3" + "Actual value: 4.") + (temp)) + +(deftest do-test-1 + (setup (values (do-test 't1) *test* (pending-tests))) + () t1 t1 ((t 2))) +(deftest do-test-2 + (setup (values (do-test '(t 2)) (pending-tests))) + ("Test (T 2) failed" + "Form: 4" + "Expected value: 3" + "Actual value: 4.") nil (t1 (t 2))) +(deftest do-test-3 + (setup (let ((*test* 't1)) (do-test))) + () t1) + +(deftest get-test-1 + (setup (values (get-test 't1) *test*)) + () (t1 4 4) (t 2)) +(deftest get-test-2 + (setup (get-test '(t 2))) + () ((t 2) 4 3)) +(deftest get-test-3 + (setup (let ((*test* 't1)) (get-test))) + () (t1 4 4)) +(deftest get-test-4 + (setup (deftest t3 1 1) (get-test)) + () (t3 1 1)) +(deftest get-test-5 + (setup (get-test 't0)) + ("No test with name T0.") nil) + +(deftest rem-test-1 + (setup (values (rem-test 't1) (pending-tests))) + () t1 ((t 2))) +(deftest rem-test-2 + (setup (values (rem-test '(t 2)) (pending-tests))) + () (t 2) (t1)) +(deftest rem-test-3 + (setup (let ((*test* '(t 2))) (rem-test)) (pending-tests)) + () (t1)) +(deftest rem-test-4 + (setup (values (rem-test 't0) (pending-tests))) + () nil (t1 (t 2))) +(deftest rem-test-5 + (setup (rem-all-tests) (rem-test 't0) (pending-tests)) + () ()) + +(deftest rem-all-tests-1 + (setup (values (rem-all-tests) (pending-tests))) + () nil nil) +(deftest rem-all-tests-2 + (setup (rem-all-tests) (rem-all-tests) (pending-tests)) + () nil) + +(deftest do-tests-1 + (setup (let ((*print-case* :downcase)) + (values (do-tests) (continue-testing) (do-tests)))) + ("Doing 2 pending tests of 2 tests total." + " T1" + "Test (T 2) failed" + "Form: 4" + "Expected value: 3" + "Actual value: 4." + "1 out of 2 total tests failed: (T 2)." + "Doing 1 pending test of 2 tests total." + "Test (T 2) failed" + "Form: 4" + "Expected value: 3" + "Actual value: 4." + "1 out of 2 total tests failed: (T 2)." + "Doing 2 pending tests of 2 tests total." + " T1" + "Test (T 2) failed" + "Form: 4" + "Expected value: 3" + "Actual value: 4." + "1 out of 2 total tests failed: (T 2).") + nil + nil + nil) + +(deftest do-tests-2 + (setup (rem-test '(t 2)) + (deftest (t 2) 3 3) + (values (do-tests) (continue-testing) (do-tests))) + ("Doing 2 pending tests of 2 tests total." + " T1 (T 2)" + "No tests failed." + "Doing 0 pending tests of 2 tests total." + "No tests failed." + "Doing 2 pending tests of 2 tests total." + " T1 (T 2)" + "No tests failed.") + t + t + t) +(deftest do-tests-3 + (setup (rem-all-tests) (values (do-tests) (continue-testing))) + ("Doing 0 pending tests of 0 tests total." + "No tests failed." + "Doing 0 pending tests of 0 tests total." + "No tests failed.") + t + t) +(deftest do-tests-4 + (setup (normalize (with-output-to-string (s) (do-tests s)))) + () + ("Doing 2 pending tests of 2 tests total." + " T1" + "Test (T 2) failed" + "Form: 4" + "Expected value: 3" + "Actual value: 4." + "1 out of 2 total tests failed: (T 2).")) +(deftest do-tests-5 + (setup (with-temporary-file s (do-tests s))) + () + ("Doing 2 pending tests of 2 tests total." + " T1" + "Test (T 2) failed" + "Form: 4" + "Expected value: 3" + "Actual value: 4." + "1 out of 2 total tests failed: (T 2).")) + +(deftest continue-testing-1 + (setup (deftest temp (continue-testing) 5) (do-test 'temp) (pending-tests)) + () (t1 (t 2) temp)) diff --git a/ansi-tests/rt.lsp b/ansi-tests/rt.lsp new file mode 100644 index 0000000..7ebb8cb --- /dev/null +++ b/ansi-tests/rt.lsp @@ -0,0 +1,270 @@ +;-*-syntax:COMMON-LISP;Package:(RT :use "COMMON-LISP" :colon-mode :external)-*- + +#|----------------------------------------------------------------------------| + | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. | + | | + | Permission to use, copy, modify, and distribute this software and its | + | documentation for any purpose and without fee is hereby granted, provided | + | that this copyright and permission notice appear in all copies and | + | supporting documentation, and that the name of M.I.T. not be used in | + | advertising or publicity pertaining to distribution of the software | + | without specific, written prior permission. M.I.T. makes no | + | representations about the suitability of this software for any purpose. | + | It is provided "as is" without express or implied warranty. | + | | + | M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING | + | ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL | + | M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR | + | ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, | + | WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, | + | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS | + | SOFTWARE. | + |----------------------------------------------------------------------------|# + +;This is the December 19, 1990 version of the regression tester. + +(in-package :regression-test) + +(defvar *test* nil "Current test name") +(defvar *do-tests-when-defined* nil) +(defvar *entries* '(nil) "Test database") +(defvar *in-test* nil "Used by TEST") +(defvar *debug* nil "For debugging") +(defvar *catch-errors* t "When true, causes errors in a test to be caught.") +(defvar *print-circle-on-failure* nil + "Failure reports are printed with *PRINT-CIRCLE* bound to this value.") + +(defvar *compile-tests* nil "When true, compile the tests before running +them.") +(defvar *optimization-settings* '((safety 3))) + +(defvar *expected-failures* nil + "A list of test names that are expected to fail.") + +(defstruct (entry (:conc-name nil) + (:type list)) + pend name form) + +(defmacro vals (entry) `(cdddr ,entry)) + +(defmacro defn (entry) `(cdr ,entry)) + +(defun pending-tests () + (do ((l (cdr *entries*) (cdr l)) + (r nil)) + ((null l) (nreverse r)) + (when (pend (car l)) + (push (name (car l)) r)))) + +(defun rem-all-tests () + (setq *entries* (list nil)) + nil) + +(defun rem-test (&optional (name *test*)) + (do ((l *entries* (cdr l))) + ((null (cdr l)) nil) + (when (equal (name (cadr l)) name) + (setf (cdr l) (cddr l)) + (return name)))) + +(defun get-test (&optional (name *test*)) + (defn (get-entry name))) + +(defun get-entry (name) + (let ((entry (find name (cdr *entries*) + :key #'name + :test #'equal))) + (when (null entry) + (report-error t + "~%No test with name ~:@(~S~)." + name)) + entry)) + +(defmacro deftest (name form &rest values) + `(add-entry '(t ,name ,form .,values))) + +(defun add-entry (entry) + (setq entry (copy-list entry)) + (do ((l *entries* (cdr l))) (nil) + (when (null (cdr l)) + (setf (cdr l) (list entry)) + (return nil)) + (when (equal (name (cadr l)) + (name entry)) + (setf (cadr l) entry) + (report-error nil + "Redefining test ~:@(~S~)" + (name entry)) + (return nil))) + (when *do-tests-when-defined* + (do-entry entry)) + (setq *test* (name entry))) + +(defun report-error (error? &rest args) + (cond (*debug* + (apply #'format t args) + (if error? (throw '*debug* nil))) + (error? (apply #'error args)) + (t (apply #'warn args)))) + +(defun do-test (&optional (name *test*)) + (do-entry (get-entry name))) + +(defun equalp-with-case (x y) + "Like EQUALP, but doesn't do case conversion of characters. + Currently doesn't work on arrays of dimension > 2." + (cond + ((consp x) + (and (consp y) + (equalp-with-case (car x) (car y)) + (equalp-with-case (cdr x) (cdr y)))) + ((and (typep x 'array) + (= (array-rank x) 0)) + (equalp-with-case (aref x) (aref y))) + ((typep x 'vector) + (and (typep y 'vector) + (let ((x-len (length x)) + (y-len (length y))) + (and (eql x-len y-len) + (loop + for e1 across x + for e2 across y + always (equalp-with-case e1 e2)))))) + ((and (typep x 'array) + (typep y 'array) + (not (equal (array-dimensions x) + (array-dimensions y)))) + nil) + #| + ((and (typep x 'array) + (= (array-rank x) 2)) + (let ((dim (array-dimensions x))) + (loop for i from 0 below (first dim) + always (loop for j from 0 below (second dim) + always (equalp-with-case (aref x i j) + (aref y i j)))))) + |# + + ((typep x 'array) + (and (typep y 'array) + (let ((size (array-total-size x))) + (loop for i from 0 below size + always (equalp-with-case (row-major-aref x i) + (row-major-aref y i)))))) + + (t (eql x y)))) + +(defun do-entry (entry &optional + (s *standard-output*)) + (catch '*in-test* + (setq *test* (name entry)) + (setf (pend entry) t) + (let* ((*in-test* t) + ;; (*break-on-warnings* t) + (aborted nil) + r) + ;; (declare (special *break-on-warnings*)) + + (flet ((%do + () + (setf r + (multiple-value-list + (if *compile-tests* + (funcall (compile + nil + `(lambda () + (declare + (optimize ,@*optimization-settings*)) + ,(form entry)))) + (eval (form entry))))))) + (block aborted + (if *catch-errors* + (handler-bind (#-ecl (style-warning #'muffle-warning) + (error #'(lambda (c) + (setf aborted t) + (setf r (list c)) + (return-from aborted nil)))) + (%do)) + (%do)))) + + (setf (pend entry) + (or aborted + (not (equalp-with-case r (vals entry))))) + (when (pend entry) + (let ((*print-circle* *print-circle-on-failure*)) + (format s "~&Test ~:@(~S~) failed~%Form: ~S~%Expected value~P:~%" + *test* (form entry) (length (vals entry))) + (dolist (v (vals entry)) (format s "~10t~S~%" v)) + (format s "Actual value~P:~%" (length r)) + (dolist (v r) + (format s "~10t~S~:[~; [~2:*~A]~]~%" + v (typep v 'condition))))))) + (when (not (pend entry)) *test*)) + +(defun continue-testing () + (if *in-test* + (throw '*in-test* nil) + (do-entries *standard-output*))) + +(defun do-tests (&optional + (out *standard-output*)) + (dolist (entry (cdr *entries*)) + (setf (pend entry) t)) + (if (streamp out) + (do-entries out) + (with-open-file + (stream out :direction :output) + (do-entries stream)))) + +(defun do-entries (s) + (format s "~&Doing ~A pending test~:P ~ + of ~A tests total.~%" + (count t (cdr *entries*) + :key #'pend) + (length (cdr *entries*))) + (dolist (entry (cdr *entries*)) + (when (pend entry) + (format s "~@[~<~%~:; ~:@(~S~)~>~]" + (do-entry entry s)))) + (let ((pending (pending-tests)) + (expected-table (make-hash-table :test #'equal))) + (dolist (ex *expected-failures*) + (setf (gethash ex expected-table) t)) + (let ((new-failures + (loop for pend in pending + unless (gethash pend expected-table) + collect pend))) + (if (null pending) + (format s "~&No tests failed.") + (progn + (format s "~&~A out of ~A ~ + total tests failed: ~ + ~:@(~{~<~% ~1:;~S~>~ + ~^, ~}~)." + (length pending) + (length (cdr *entries*)) + pending) + (if (null new-failures) + (format s "~&No unexpected failures.") + (when *expected-failures* + (format s "~&~A unexpected failures: ~ + ~:@(~{~<~% ~1:;~S~>~ + ~^, ~}~)." + (length new-failures) + new-failures))) + (when *expected-failures* + (let ((pending-table (make-hash-table :test #'equal))) + (dolist (ex pending) + (setf (gethash ex pending-table) t)) + (let ((unexpected-successes + (loop :for ex :in *expected-failures* + :unless (gethash ex pending-table) :collect ex))) + (if unexpected-successes + (format t "~&~:D unexpected successes: ~ + ~:@(~{~<~% ~1:;~S~>~ + ~^, ~}~)." + (length unexpected-successes) + unexpected-successes) + (format t "~&No unexpected successes."))))) + )) + (null pending)))) diff --git a/ansi-tests/rt.system b/ansi-tests/rt.system new file mode 100644 index 0000000..e0cce97 --- /dev/null +++ b/ansi-tests/rt.system @@ -0,0 +1,22 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 7 23:30:22 1998 +;;;; Contains: Portable defsystem for RT testing system + +(mk::defsystem "rt" + :source-pathname #.(directory-namestring *LOAD-TRUENAME*) + :binary-pathname #.(mk::append-directories + (directory-namestring *LOAD-TRUENAME*) + "binary/") + :source-extension "lsp" + :binary-extension + #+CMU #.(C::BACKEND-FASL-FILE-TYPE C::*TARGET-BACKEND*) + #+ALLEGRO "fasl" + #+(OR AKCL GCL) "o" + #+CLISP "fas" + #-(OR CMU ALLEGRO AKCL GCL CLISP) + #.(pathname-type (compile-file-pathname "foo.lisp")) + :components + ( + "rt-package" + ("rt" :depends-on ("rt-package")))) diff --git a/ansi-tests/sbit.lsp b/ansi-tests/sbit.lsp new file mode 100644 index 0000000..f657f59 --- /dev/null +++ b/ansi-tests/sbit.lsp @@ -0,0 +1,95 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Jan 26 15:30:31 2003 +;;;; Contains: Tests for SBIT + +(in-package :cl-test) + +(deftest sbit.1 + (sbit #*0010 2) + 1) + +(deftest sbit.2 + (let ((a #*00000000)) + (loop for i from 0 below (length a) + collect (let ((b (copy-seq a))) + (setf (sbit b i) 1) + b))) + (#*10000000 + #*01000000 + #*00100000 + #*00010000 + #*00001000 + #*00000100 + #*00000010 + #*00000001)) + +(deftest sbit.3 + (let ((a #*11111111)) + (loop for i from 0 below (length a) + collect (let ((b (copy-seq a))) + (setf (sbit b i) 0) + b))) + (#*01111111 + #*10111111 + #*11011111 + #*11101111 + #*11110111 + #*11111011 + #*11111101 + #*11111110)) + +(deftest sbit.4 + (let ((a (make-array nil :element-type 'bit :initial-element 0))) + (values + (aref a) + (sbit a) + (setf (sbit a) 1) + (aref a) + (sbit a))) + 0 0 1 1 1) + +(deftest sbit.5 + (let ((a (make-array '(1 1) :element-type 'bit :initial-element 0))) + (values + (aref a 0 0) + (sbit a 0 0) + (setf (sbit a 0 0) 1) + (aref a 0 0) + (sbit a 0 0))) + 0 0 1 1 1) + +(deftest sbit.6 + (let ((a (make-array '(10 10) :element-type 'bit :initial-element 0))) + (values + (aref a 5 5) + (sbit a 5 5) + (setf (sbit a 5 5) 1) + (aref a 5 5) + (sbit a 5 5))) + 0 0 1 1 1) + +(deftest sbit.order.1 + (let ((i 0) a b) + (values + (sbit (progn (setf a (incf i)) #*001001) + (progn (setf b (incf i)) 1)) + i a b)) + 0 2 1 2) + +(deftest sbit.order.2 + (let ((i 0) a b c + (v (copy-seq #*001001))) + (values + (setf (sbit (progn (setf a (incf i)) v) + (progn (setf b (incf i)) 1)) + (progn (setf c (incf i)) 1)) + v i a b c)) + 1 #*011001 3 1 2 3) + +(deftest sbit.error.1 + (classify-error (sbit)) + program-error) + + + \ No newline at end of file diff --git a/ansi-tests/search-aux.lsp b/ansi-tests/search-aux.lsp new file mode 100644 index 0000000..129a794 --- /dev/null +++ b/ansi-tests/search-aux.lsp @@ -0,0 +1,92 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Aug 24 07:22:10 2002 +;;;; Contains: Aux. functions for testing SEARCH + +(in-package :cl-test) + +(defparameter *searched-list* + '(b b a b b b b b b b a b a b b b a b a b b b a a a a b a a b a a a a a + a b a b b a b a a b a a a b b a a b a a a a b b a b a b a a a b a b + b a b a a b b b b b a a a a a b a b b b b b a b a b b a b a b)) + +(defparameter *pattern-sublists* + (remove-duplicates + (let* ((s *searched-list*) (len (length s))) + (loop for x from 0 to 8 nconc + (loop for y from 0 to (- len x) + collect (subseq s y (+ y x))))) + :test #'equal)) + +(defparameter *searched-vector* + (make-array (length *searched-list*) + :initial-contents *searched-list*)) + +(defparameter *pattern-subvectors* + (mapcar #'(lambda (x) (apply #'vector x)) *pattern-sublists*)) + +(defparameter *searched-bitvector* + #*1101111111010111010111000010010000001011010010001100100001101010001011010011111000001011111010110101) + +(defparameter *pattern-subbitvectors* + (remove-duplicates + (let* ((s *searched-bitvector*) (len (length s))) + (loop for x from 0 to 8 nconc + (loop for y from 0 to (- len x) + collect (subseq s y (+ y x))))) + :test #'equalp)) + +(defparameter *searched-string* + "1101111111010111010111000010010000001011010010001100100001101010001011010011111000001011111010110101") + +(defparameter *pattern-substrings* + (remove-duplicates + (let* ((s *searched-string*) (len (length s))) + (loop for x from 0 to 8 nconc + (loop for y from 0 to (- len x) + collect (subseq s y (+ y x))))) + :test #'equalp)) + +(defun subseq-equalp (seq1 seq2 start1 start2 len &key (test #'equalp)) + (assert + (and + (>= start1 0) + (>= start2 0) + (<= (+ start1 len) (length seq1)) + (<= (+ start2 len) (length seq2)))) + (if (and (listp seq1) (listp seq2)) + (loop for i from 0 to (1- len) + for e1 in (nthcdr start1 seq1) + for e2 in (nthcdr start2 seq2) + always (funcall test e1 e2)) + (loop for i from 0 to (1- len) + always + (funcall test + (elt seq1 (+ start1 i)) + (elt seq2 (+ start2 i)))))) + +(defun search-check (pattern searched pos + &key (start1 0) (end1 nil) (start2 0) (end2 nil) + key from-end (test #'equalp)) + (unless end1 (setq end1 (length pattern))) + (unless end2 (setq end2 (length searched))) + (assert (<= start1 end1)) + (assert (<= start2 end2)) + (let* ((plen (- end1 start1))) + (when key + (setq pattern (map 'list key pattern)) + (setq searched (map 'list key searched))) + (if pos + (and + (subseq-equalp searched pattern pos start1 plen :test test) + (if from-end + (loop for i from (1+ pos) to (- end2 plen) + never + (subseq-equalp searched pattern i start1 plen :test test)) + (loop for i from start2 to (1- pos) + never + (subseq-equalp searched pattern i start1 plen :test test)))) + (loop for i from start2 to (- end2 plen) + never (subseq-equalp searched pattern i start1 plen :test test))))) + + diff --git a/ansi-tests/search-bitvector.lsp b/ansi-tests/search-bitvector.lsp new file mode 100644 index 0000000..4080812 --- /dev/null +++ b/ansi-tests/search-bitvector.lsp @@ -0,0 +1,176 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Aug 25 13:06:54 2002 +;;;; Contains: Tests for SEARCH on bit vectors + +(in-package :cl-test) + +(deftest search-bitvector.1 + (let ((target *searched-bitvector*) + (pat #(a))) + (loop for i from 0 to (1- (length target)) + for tail on target + always + (let ((pos (search pat tail))) + (search-check pat tail pos)))) + t) + +(deftest search-bitvector.2 + (let ((target *searched-bitvector*) + (pat #(a))) + (loop for i from 1 to (length target) + always + (let ((pos (search pat target :end2 i :from-end t))) + (search-check pat target pos :end2 i :from-end t)))) + t) + +(deftest search-bitvector.3 + (let ((target *searched-bitvector*)) + (loop for pat in *pattern-subbitvectors* + for pos = (search pat target) + unless (search-check pat target pos) + collect pat)) + nil) + +(deftest search-bitvector.4 + (let ((target *searched-bitvector*)) + (loop for pat in *pattern-subbitvectors* + for pos = (search pat target :from-end t) + unless (search-check pat target pos :from-end t) + collect pat)) + nil) + +(deftest search-bitvector.5 + (let ((target *searched-bitvector*)) + (loop for pat in *pattern-subbitvectors* + for pos = (search pat target :start2 25 :end2 75) + unless (search-check pat target pos :start2 25 :end2 75) + collect pat)) + nil) + +(deftest search-bitvector.6 + (let ((target *searched-bitvector*)) + (loop for pat in *pattern-subbitvectors* + for pos = (search pat target :from-end t :start2 25 :end2 75) + unless (search-check pat target pos :from-end t + :start2 25 :end2 75) + collect pat)) + nil) + +(deftest search-bitvector.7 + (let ((target *searched-bitvector*)) + (loop for pat in *pattern-subbitvectors* + for pos = (search pat target :start2 20) + unless (search-check pat target pos :start2 20) + collect pat)) + nil) + +(deftest search-bitvector.8 + (let ((target *searched-bitvector*)) + (loop for pat in *pattern-subbitvectors* + for pos = (search pat target :from-end t :start2 20) + unless (search-check pat target pos :from-end t + :start2 20) + collect pat)) + nil) + +(deftest search-bitvector.9 + (let ((target *searched-bitvector*)) + (loop for pat in (mapcar #'(lambda (x) + (map 'vector + #'(lambda (y) + (sublis '((a . 2) (b . 3)) y)) + x)) + *pattern-sublists*) + for pos = (search pat target :start2 20 :key #'evenp) + unless (search-check pat target pos :start2 20 :key #'evenp) + collect pat)) + nil) + +(deftest search-bitvector.10 + (let ((target *searched-bitvector*)) + (loop for pat in (mapcar #'(lambda (x) + (map 'vector + #'(lambda (y) + (sublis '((a . 2) (b . 3)) y)) + x)) + *pattern-sublists*) + for pos = (search pat target :from-end t :start2 20 :key 'oddp) + unless (search-check pat target pos :from-end t + :start2 20 :key 'oddp) + collect pat)) + nil) + +(deftest search-bitvector.11 + (let ((target *searched-bitvector*)) + (loop for pat in *pattern-subbitvectors* + for pos = (search pat target :start2 20 :test (complement #'eql)) + unless (search-check pat target pos :start2 20 + :test (complement #'eql)) + collect pat)) + nil) + +(deftest search-bitvector.12 + (let ((target *searched-bitvector*)) + (loop for pat in *pattern-subbitvectors* + for pos = (search pat target :from-end t :start2 20 :test-not #'eql) + unless (search-check pat target pos :from-end t + :start2 20 :test (complement #'eql)) + collect pat)) + nil) + +(deftest search-bitvector.13 + (let ((target *searched-bitvector*)) + (loop for pat in *pattern-subbitvectors* + when (and (> (length pat) 0) + (let ((pos (search pat target :start1 1 + :test (complement #'eql)))) + (not (search-check pat target pos + :start1 1 + :test (complement #'eql))))) + collect pat)) + nil) + +(deftest search-bitvector.14 + (let ((target *searched-bitvector*)) + (loop for pat in *pattern-subbitvectors* + when (let ((len (length pat))) + (and (> len 0) + (let ((pos (search pat target :end1 (1- len) + :test (complement #'eql)))) + (not (search-check pat target pos + :end1 (1- len) + :test (complement #'eql)))))) + collect pat)) + nil) + +(deftest search-bitvector.15 + (let ((a (make-array '(10) :initial-contents '(0 1 1 0 0 0 1 0 1 1) + :fill-pointer 5 + :element-type 'bit))) + (values + (search #*0 a) + (search #*0 a :from-end t) + (search #*01 a) + (search #*01 a :from-end t) + (search #*010 a) + (search #*010 a :from-end t))) + 0 4 0 0 nil nil) + +(deftest search-bitvector.16 + (let ((pat (make-array '(3) :initial-contents '(0 1 0) + :fill-pointer 1)) + (a #*01100)) + (values + (search pat a) + (search pat a :from-end t) + (progn + (setf (fill-pointer pat) 2) + (search pat a)) + (search pat a :from-end t) + (progn + (setf (fill-pointer pat) 3) + (search pat a)) + (search pat a :from-end t))) + 0 4 0 0 nil nil) + diff --git a/ansi-tests/search-list.lsp b/ansi-tests/search-list.lsp new file mode 100644 index 0000000..5dba4fc --- /dev/null +++ b/ansi-tests/search-list.lsp @@ -0,0 +1,251 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Aug 24 07:22:10 2002 +;;;; Contains: Tests for SEARCH on lists + +(in-package :cl-test) + +(deftest search-list.1 + (let ((target *searched-list*) + (pat '(a))) + (loop for i from 0 to (1- (length target)) + for tail on target + always + (let ((pos (search pat tail))) + (search-check pat tail pos)))) + t) + +(deftest search-list.2 + (let ((target *searched-list*) + (pat '(a))) + (loop for i from 1 to (length target) + always + (let ((pos (search pat target :end2 i :from-end t))) + (search-check pat target pos :end2 i :from-end t)))) + t) + +(deftest search-list.3 + (let ((target *searched-list*)) + (loop for pat in *pattern-sublists* + for pos = (search pat target) + unless (search-check pat target pos) + collect pat)) + nil) + +(deftest search-list.4 + (let ((target *searched-list*)) + (loop for pat in *pattern-sublists* + for pos = (search pat target :from-end t) + unless (search-check pat target pos :from-end t) + collect pat)) + nil) + +(deftest search-list.5 + (let ((target *searched-list*)) + (loop for pat in *pattern-sublists* + for pos = (search pat target :start2 25 :end2 75) + unless (search-check pat target pos :start2 25 :end2 75) + collect pat)) + nil) + +(deftest search-list.6 + (let ((target *searched-list*)) + (loop for pat in *pattern-sublists* + for pos = (search pat target :from-end t :start2 25 :end2 75) + unless (search-check pat target pos :from-end t + :start2 25 :end2 75) + collect pat)) + nil) + +(deftest search-list.7 + (let ((target *searched-list*)) + (loop for pat in *pattern-sublists* + for pos = (search pat target :start2 20) + unless (search-check pat target pos :start2 20) + collect pat)) + nil) + +(deftest search-list.8 + (let ((target *searched-list*)) + (loop for pat in *pattern-sublists* + for pos = (search pat target :from-end t :start2 20) + unless (search-check pat target pos :from-end t + :start2 20) + collect pat)) + nil) + +(deftest search-list.9 + (let ((target (sublis '((a . 1) (b . 2)) *searched-list*))) + (loop for pat in (sublis '((a . 3) (b . 4)) *pattern-sublists*) + for pos = (search pat target :start2 20 :key #'evenp) + unless (search-check pat target pos :start2 20 :key #'evenp) + collect pat)) + nil) + +(deftest search-list.10 + (let ((target (sublis '((a . 1) (b . 2)) *searched-list*))) + (loop for pat in (sublis '((a . 3) (b . 4)) *pattern-sublists*) + for pos = (search pat target :from-end t :start2 20 :key 'oddp) + unless (search-check pat target pos :from-end t + :start2 20 :key 'oddp) + collect pat)) + nil) + +(deftest search-list.11 + (let ((target *searched-list*)) + (loop for pat in *pattern-sublists* + for pos = (search pat target :start2 20 :test (complement #'eql)) + unless (search-check pat target pos :start2 20 + :test (complement #'eql)) + collect pat)) + nil) + +(deftest search-list.12 + (let ((target *searched-list*)) + (loop for pat in *pattern-sublists* + for pos = (search pat target :from-end t :start2 20 :test-not #'eql) + unless (search-check pat target pos :from-end t + :start2 20 :test (complement #'eql)) + collect pat)) + nil) + +(deftest search-list.13 + (let ((target *searched-list*)) + (loop for pat in *pattern-sublists* + when (and (> (length pat) 0) + (let ((pos (search pat target :start1 1 + :test (complement #'eql)))) + (not (search-check pat target pos + :start1 1 + :test (complement #'eql))))) + collect pat)) + nil) + +(deftest search-list.14 + (let ((target *searched-list*)) + (loop for pat in *pattern-sublists* + when (let ((len (length pat))) + (and (> len 0) + (let ((pos (search pat target :end1 (1- len) + :test (complement #'eql)))) + (not (search-check pat target pos + :end1 (1- len) + :test (complement #'eql)))))) + collect pat)) + nil) + +;;; Keyword tests + +(deftest search.allow-other-keys.1 + (search '(c d) '(a b c d c d e) :allow-other-keys t) + 2) + +(deftest search.allow-other-keys.2 + (search '(c d) '(a b c d c d e) :allow-other-keys nil) + 2) + +(deftest search.allow-other-keys.3 + (search '(c d) '(a b c d c d e) :bad t :allow-other-keys t) + 2) + +(deftest search.allow-other-keys.4 + (search '(c d) '(a b c d c d e) :allow-other-keys 'foo :bad nil) + 2) + +(deftest search.allow-other-keys.5 + (search '(c d) '(a b c d c d e) :bad1 1 :allow-other-keys t :bad2 2 + :allow-other-keys nil :bad3 3) + 2) + +(deftest search.allow-other-keys.6 + (search '(c d) '(a b c d c d e) :allow-other-keys 'foo + :from-end t) + 4) + +(deftest search.allow-other-keys.7 + (search '(c d) '(a b c d c d e) :from-end t :allow-other-keys t) + 4) + +(deftest search.keywords.8 + (search '(c d) '(a b c d c d e) :start1 0 :start2 0 :start1 1 + :start2 6 :from-end t :from-end nil) + 4) + + +;;; Error cases + +(deftest search.error.1 + (classify-error (search)) + program-error) + +(deftest search.error.2 + (classify-error (search "a")) + program-error) + +(deftest search.error.3 + (classify-error (search "a" "a" :key)) + program-error) + +(deftest search.error.4 + (classify-error (search "a" "a" 'bad t)) + program-error) + +(deftest search.error.5 + (classify-error (search "a" "a" 'bad t :allow-other-keys nil)) + program-error) + +(deftest search.error.6 + (classify-error (search "a" "a" 1 2)) + program-error) + +(deftest search.error.7 + (classify-error (search "c" "abcde" :test #'identity)) + program-error) + +(deftest search.error.8 + (classify-error (search "c" "abcde" :test-not #'identity)) + program-error) + +(deftest search.error.9 + (classify-error (search "c" "abcde" :key #'cons)) + program-error) + +(deftest search.error.10 + (classify-error (search "c" "abcde" :key #'car)) + type-error) + +;;; Order of evaluation + +(deftest search.order.1 + (let ((i 0) a b c d e f g h j) + (values + (search + (progn (setf a (incf i)) '(nil a b nil)) + (progn (setf b (incf i)) '(z z z a a b b z z z)) + :from-end (progn (setf c (incf i)) t) + :start1 (progn (setf d (incf i)) 1) + :end1 (progn (setf e (incf i)) 3) + :start2 (progn (setf f (incf i)) 1) + :end2 (progn (setf g (incf i)) 8) + :key (progn (setf h (incf i)) #'identity) + :test (progn (setf j (incf i)) #'eql) + ) + i a b c d e f g h j)) + 4 9 1 2 3 4 5 6 7 8 9) + +(deftest search.order.2 + (let ((i 0) a b c d e f g h j) + (values + (search + (progn (setf a (incf i)) '(nil a b nil)) + (progn (setf b (incf i)) '(z z z a a b b z z z)) + :test-not (progn (setf c (incf i)) (complement #'eql)) + :key (progn (setf d (incf i)) #'identity) + :end2 (progn (setf e (incf i)) 8) + :start2 (progn (setf f (incf i)) 1) + :end1 (progn (setf g (incf i)) 3) + :start1 (progn (setf h (incf i)) 1) + :from-end (progn (setf j (incf i)) t) + ) + i a b c d e f g h j)) + 4 9 1 2 3 4 5 6 7 8 9) \ No newline at end of file diff --git a/ansi-tests/search-string.lsp b/ansi-tests/search-string.lsp new file mode 100644 index 0000000..243af8d --- /dev/null +++ b/ansi-tests/search-string.lsp @@ -0,0 +1,163 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Aug 25 13:06:54 2002 +;;;; Contains: Tests for SEARCH on strings + +(in-package :cl-test) + +;;; The next test was busted due to to a stupid cut and paste +;;; error. The loop terminates immediately, doing nothing +;;; useful. -- PFD +#| +(deftest search-string.1 + (let ((target *searched-string*) + (pat #(a))) + (loop for i from 0 to (1- (length target)) + for tail on target + always + (let ((pos (search pat tail))) + (search-check pat tail pos)))) + t) +|# + +(deftest search-string.2 + (let ((target *searched-string*) + (pat #(a))) + (loop for i from 1 to (length target) + always + (let ((pos (search pat target :end2 i :from-end t))) + (search-check pat target pos :end2 i :from-end t)))) + t) + +(deftest search-string.3 + (let ((target *searched-string*)) + (loop for pat in *pattern-substrings* + for pos = (search pat target) + unless (search-check pat target pos) + collect pat)) + nil) + +(deftest search-string.4 + (let ((target *searched-string*)) + (loop for pat in *pattern-substrings* + for pos = (search pat target :from-end t) + unless (search-check pat target pos :from-end t) + collect pat)) + nil) + +(deftest search-string.5 + (let ((target *searched-string*)) + (loop for pat in *pattern-substrings* + for pos = (search pat target :start2 25 :end2 75) + unless (search-check pat target pos :start2 25 :end2 75) + collect pat)) + nil) + +(deftest search-string.6 + (let ((target *searched-string*)) + (loop for pat in *pattern-substrings* + for pos = (search pat target :from-end t :start2 25 :end2 75) + unless (search-check pat target pos :from-end t + :start2 25 :end2 75) + collect pat)) + nil) + +(deftest search-string.7 + (let ((target *searched-string*)) + (loop for pat in *pattern-substrings* + for pos = (search pat target :start2 20) + unless (search-check pat target pos :start2 20) + collect pat)) + nil) + +(deftest search-string.8 + (let ((target *searched-string*)) + (loop for pat in *pattern-substrings* + for pos = (search pat target :from-end t :start2 20) + unless (search-check pat target pos :from-end t + :start2 20) + collect pat)) + nil) + +(deftest search-string.9 + (flet ((%f (x) (case x ((#\0 a) 'c) ((#\1 b) 'd) (t nil)))) + (let ((target *searched-string*)) + (loop for pat in *pattern-sublists* + for pos = (search pat target :start2 20 :key #'%f) + unless (search-check pat target pos :start2 20 :key #'%f) + collect pat))) + nil) + +(deftest search-string.10 + (let ((target *searched-string*)) + (loop for pat in *pattern-substrings* + for pos = (search pat target :start2 20 :test (complement #'eql)) + unless (search-check pat target pos :start2 20 + :test (complement #'eql)) + collect pat)) + nil) + +(deftest search-string.11 + (let ((target *searched-string*)) + (loop for pat in *pattern-substrings* + for pos = (search pat target :from-end t :start2 20 :test-not #'eql) + unless (search-check pat target pos :from-end t + :start2 20 :test (complement #'eql)) + collect pat)) + nil) + +(deftest search-string.13 + (let ((target *searched-string*)) + (loop for pat in *pattern-substrings* + when (and (> (length pat) 0) + (let ((pos (search pat target :start1 1 + :test (complement #'eql)))) + (not (search-check pat target pos + :start1 1 + :test (complement #'eql))))) + collect pat)) + nil) + +(deftest search-string.14 + (let ((target *searched-string*)) + (loop for pat in *pattern-substrings* + when (let ((len (length pat))) + (and (> len 0) + (let ((pos (search pat target :end1 (1- len) + :test (complement #'eql)))) + (not (search-check pat target pos + :end1 (1- len) + :test (complement #'eql)))))) + collect pat)) + nil) + +(deftest search-string.15 + (let ((a (make-array '(10) :initial-contents "abbaaababb" + :fill-pointer 5 + :element-type 'character))) + (values + (search "a" a) + (search "a" a :from-end t) + (search "ab" a) + (search "ab" a :from-end t) + (search "aba" a) + (search "aba" a :from-end t))) + 0 4 0 0 nil nil) + +(deftest search-string.16 + (let ((pat (make-array '(3) :initial-contents '(#\a #\b #\a) + :fill-pointer 1)) + (a "abbaa")) + (values + (search pat a) + (search pat a :from-end t) + (progn + (setf (fill-pointer pat) 2) + (search pat a)) + (search pat a :from-end t) + (progn + (setf (fill-pointer pat) 3) + (search pat a)) + (search pat a :from-end t))) + 0 4 0 0 nil nil) + diff --git a/ansi-tests/search-vector.lsp b/ansi-tests/search-vector.lsp new file mode 100644 index 0000000..6be7d0b --- /dev/null +++ b/ansi-tests/search-vector.lsp @@ -0,0 +1,176 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Aug 25 13:06:54 2002 +;;;; Contains: Tests for SEARCH on vectors + +(in-package :cl-test) + +(deftest search-vector.1 + (let ((target *searched-vector*) + (pat #(a))) + (loop for i from 0 to (1- (length target)) + for tail on target + always + (let ((pos (search pat tail))) + (search-check pat tail pos)))) + t) + +(deftest search-vector.2 + (let ((target *searched-vector*) + (pat #(a))) + (loop for i from 1 to (length target) + always + (let ((pos (search pat target :end2 i :from-end t))) + (search-check pat target pos :end2 i :from-end t)))) + t) + +(deftest search-vector.3 + (let ((target *searched-vector*)) + (loop for pat in *pattern-subvectors* + for pos = (search pat target) + unless (search-check pat target pos) + collect pat)) + nil) + +(deftest search-vector.4 + (let ((target *searched-vector*)) + (loop for pat in *pattern-subvectors* + for pos = (search pat target :from-end t) + unless (search-check pat target pos :from-end t) + collect pat)) + nil) + +(deftest search-vector.5 + (let ((target *searched-vector*)) + (loop for pat in *pattern-subvectors* + for pos = (search pat target :start2 25 :end2 75) + unless (search-check pat target pos :start2 25 :end2 75) + collect pat)) + nil) + +(deftest search-vector.6 + (let ((target *searched-vector*)) + (loop for pat in *pattern-subvectors* + for pos = (search pat target :from-end t :start2 25 :end2 75) + unless (search-check pat target pos :from-end t + :start2 25 :end2 75) + collect pat)) + nil) + +(deftest search-vector.7 + (let ((target *searched-vector*)) + (loop for pat in *pattern-subvectors* + for pos = (search pat target :start2 20) + unless (search-check pat target pos :start2 20) + collect pat)) + nil) + +(deftest search-vector.8 + (let ((target *searched-vector*)) + (loop for pat in *pattern-subvectors* + for pos = (search pat target :from-end t :start2 20) + unless (search-check pat target pos :from-end t + :start2 20) + collect pat)) + nil) + +(deftest search-vector.9 + (let ((target (map 'vector #'(lambda (x) (sublis '((a . 1) (b . 2)) x)) + *searched-list*))) + (loop for pat in (mapcar #'(lambda (x) + (map 'vector + #'(lambda (y) + (sublis '((a . 3) (b . 4)) y)) + x)) + *pattern-sublists*) + for pos = (search pat target :start2 20 :key #'evenp) + unless (search-check pat target pos :start2 20 :key #'evenp) + collect pat)) + nil) + +(deftest search-vector.10 + (let ((target (map 'vector #'(lambda (x) (sublis '((a . 1) (b . 2)) x)) + *searched-list*))) + (loop for pat in (mapcar #'(lambda (x) + (map 'vector + #'(lambda (y) + (sublis '((a . 3) (b . 4)) y)) + x)) + *pattern-sublists*) + for pos = (search pat target :from-end t :start2 20 :key 'oddp) + unless (search-check pat target pos :from-end t + :start2 20 :key 'oddp) + collect pat)) + nil) + +(deftest search-vector.11 + (let ((target *searched-vector*)) + (loop for pat in *pattern-subvectors* + for pos = (search pat target :start2 20 :test (complement #'eql)) + unless (search-check pat target pos :start2 20 + :test (complement #'eql)) + collect pat)) + nil) + +(deftest search-vector.12 + (let ((target *searched-vector*)) + (loop for pat in *pattern-subvectors* + for pos = (search pat target :from-end t :start2 20 :test-not #'eql) + unless (search-check pat target pos :from-end t + :start2 20 :test (complement #'eql)) + collect pat)) + nil) + +(deftest search-vector.13 + (let ((target *searched-vector*)) + (loop for pat in *pattern-subvectors* + when (and (> (length pat) 0) + (let ((pos (search pat target :start1 1 + :test (complement #'eql)))) + (not (search-check pat target pos + :start1 1 + :test (complement #'eql))))) + collect pat)) + nil) + +(deftest search-vector.14 + (let ((target *searched-vector*)) + (loop for pat in *pattern-subvectors* + when (let ((len (length pat))) + (and (> len 0) + (let ((pos (search pat target :end1 (1- len) + :test (complement #'eql)))) + (not (search-check pat target pos + :end1 (1- len) + :test (complement #'eql)))))) + collect pat)) + nil) + +(deftest search-vector.15 + (let ((a (make-array '(10) :initial-contents '(a b b a a a b a b b) + :fill-pointer 5))) + (values + (search '(a) a) + (search '(a) a :from-end t) + (search '(a b) a) + (search '(a b) a :from-end t) + (search '(a b a) a) + (search '(a b a) a :from-end t))) + 0 4 0 0 nil nil) + +(deftest search-vector.16 + (let ((pat (make-array '(3) :initial-contents '(a b a) + :fill-pointer 1)) + (a #(a b b a a))) + (values + (search pat a) + (search pat a :from-end t) + (progn + (setf (fill-pointer pat) 2) + (search pat a)) + (search pat a :from-end t) + (progn + (setf (fill-pointer pat) 3) + (search pat a)) + (search pat a :from-end t))) + 0 4 0 0 nil nil) diff --git a/ansi-tests/simple-array-t.lsp b/ansi-tests/simple-array-t.lsp new file mode 100644 index 0000000..255f280 --- /dev/null +++ b/ansi-tests/simple-array-t.lsp @@ -0,0 +1,275 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Jan 26 07:23:45 2003 +;;;; Contains: Tests of SIMPLE-ARRAY on T element type + +(in-package :cl-test) + +;;; Tests of (simple-array t) + +(deftest simple-array-t.2.1 + (notnot-mv (typep #() '(simple-array t))) + t) + +(deftest simple-array-t.2.2 + (notnot-mv (typep #0aX '(simple-array t))) + t) + +(deftest simple-array-t.2.3 + (notnot-mv (typep #2a(()) '(simple-array t))) + t) + +(deftest simple-array-t.2.4 + (notnot-mv (typep #(1 2 3) '(simple-array t))) + t) + +(deftest simple-array-t.2.5 + (typep "abcd" '(simple-array t)) + nil) + +(deftest simple-array-t.2.6 + (typep #*010101 '(simple-array t)) + nil) + +;;; Tests of (simple-array t ()) + +(deftest simple-array-t.3.1 + (notnot-mv (typep #() '(simple-array t nil))) + nil) + +(deftest simple-array-t.3.2 + (notnot-mv (typep #0aX '(simple-array t nil))) + t) + +(deftest simple-array-t.3.3 + (typep #2a(()) '(simple-array t nil)) + nil) + +(deftest simple-array-t.3.4 + (typep #(1 2 3) '(simple-array t nil)) + nil) + +(deftest simple-array-t.3.5 + (typep "abcd" '(simple-array t nil)) + nil) + +(deftest simple-array-t.3.6 + (typep #*010101 '(simple-array t nil)) + nil) + +;;; Tests of (simple-array t 1) +;;; The '1' indicates rank, so this is equivalent to 'vector' + +(deftest simple-array-t.4.1 + (notnot-mv (typep #() '(simple-array t 1))) + t) + +(deftest simple-array-t.4.2 + (typep #0aX '(simple-array t 1)) + nil) + +(deftest simple-array-t.4.3 + (typep #2a(()) '(simple-array t 1)) + nil) + +(deftest simple-array-t.4.4 + (notnot-mv (typep #(1 2 3) '(simple-array t 1))) + t) + +(deftest simple-array-t.4.5 + (typep "abcd" '(simple-array t 1)) + nil) + +(deftest simple-array-t.4.6 + (typep #*010101 '(simple-array t 1)) + nil) + +;;; Tests of (simple-array t 0) + +(deftest simple-array-t.5.1 + (typep #() '(simple-array t 0)) + nil) + +(deftest simple-array-t.5.2 + (notnot-mv (typep #0aX '(simple-array t 0))) + t) + +(deftest simple-array-t.5.3 + (typep #2a(()) '(simple-array t 0)) + nil) + +(deftest simple-array-t.5.4 + (typep #(1 2 3) '(simple-array t 0)) + nil) + +(deftest simple-array-t.5.5 + (typep "abcd" '(simple-array t 0)) + nil) + +(deftest simple-array-t.5.6 + (typep #*010101 '(simple-array t 0)) + nil) + +;;; Tests of (simple-array t *) + +(deftest simple-array-t.6.1 + (notnot-mv (typep #() '(simple-array t *))) + t) + +(deftest simple-array-t.6.2 + (notnot-mv (typep #0aX '(simple-array t *))) + t) + +(deftest simple-array-t.6.3 + (notnot-mv (typep #2a(()) '(simple-array t *))) + t) + +(deftest simple-array-t.6.4 + (notnot-mv (typep #(1 2 3) '(simple-array t *))) + t) + +(deftest simple-array-t.6.5 + (typep "abcd" '(simple-array t *)) + nil) + +(deftest simple-array-t.6.6 + (typep #*010101 '(simple-array t *)) + nil) + +;;; Tests of (simple-array t 2) + +(deftest simple-array-t.7.1 + (typep #() '(simple-array t 2)) + nil) + +(deftest simple-array-t.7.2 + (typep #0aX '(simple-array t 2)) + nil) + +(deftest simple-array-t.7.3 + (notnot-mv (typep #2a(()) '(simple-array t 2))) + t) + +(deftest simple-array-t.7.4 + (typep #(1 2 3) '(simple-array t 2)) + nil) + +(deftest simple-array-t.7.5 + (typep "abcd" '(simple-array t 2)) + nil) + +(deftest simple-array-t.7.6 + (typep #*010101 '(simple-array t 2)) + nil) + +;;; Testing '(simple-array t (--)) + +(deftest simple-array-t.8.1 + (typep #() '(simple-array t (1))) + nil) + +(deftest simple-array-t.8.2 + (notnot-mv (typep #() '(simple-array t (0)))) + t) + +(deftest simple-array-t.8.3 + (notnot-mv (typep #() '(simple-array t (*)))) + t) + +(deftest simple-array-t.8.4 + (typep #(a b c) '(simple-array t (2))) + nil) + +(deftest simple-array-t.8.5 + (notnot-mv (typep #(a b c) '(simple-array t (3)))) + t) + +(deftest simple-array-t.8.6 + (notnot-mv (typep #(a b c) '(simple-array t (*)))) + t) + +(deftest simple-array-t.8.7 + (typep #(a b c) '(simple-array t (4))) + nil) + +(deftest simple-array-t.8.8 + (typep #2a((a b c)) '(simple-array t (*))) + nil) + +(deftest simple-array-t.8.9 + (typep #2a((a b c)) '(simple-array t (3))) + nil) + +(deftest simple-array-t.8.10 + (typep #2a((a b c)) '(simple-array t (1))) + nil) + +(deftest simple-array-t.8.11 + (typep "abc" '(simple-array t (2))) + nil) + +(deftest simple-array-t.8.12 + (typep "abc" '(simple-array t (3))) + nil) + +(deftest simple-array-t.8.13 + (typep "abc" '(simple-array t (*))) + nil) + +(deftest simple-array-t.8.14 + (typep "abc" '(simple-array t (4))) + nil) + +;;; Two dimensional simple-array type tests + +(deftest simple-array-t.9.1 + (typep #() '(simple-array t (* *))) + nil) + +(deftest simple-array-t.9.2 + (typep "abc" '(simple-array t (* *))) + nil) + +(deftest simple-array-t.9.3 + (typep #(a b c) '(simple-array t (3 *))) + nil) + +(deftest simple-array-t.9.4 + (typep #(a b c) '(simple-array t (* 3))) + nil) + +(deftest simple-array-t.9.5 + (typep "abc" '(simple-array t (3 *))) + nil) + +(deftest simple-array-t.9.6 + (typep "abc" '(simple-array t (* 3))) + nil) + +(deftest simple-array-t.9.7 + (notnot-mv (typep #2a((a b)(c d)(e f)) '(simple-array t (* *)))) + t) + +(deftest simple-array-t.9.8 + (notnot-mv (typep #2a((a b)(c d)(e f)) '(simple-array t (3 *)))) + t) + +(deftest simple-array-t.9.9 + (typep #2a((a b)(c d)(e f)) '(simple-array t (2 *))) + nil) + +(deftest simple-array-t.9.10 + (notnot-mv (typep #2a((a b)(c d)(e f)) '(simple-array t (* 2)))) + t) + +(deftest simple-array-t.9.11 + (typep #2a((a b)(c d)(e f)) '(simple-array t (* 3))) + nil) + +(deftest simple-array-t.9.12 + (notnot-mv (typep #2a((a b)(c d)(e f)) '(simple-array t (3 2)))) + t) + +(deftest simple-array-t.9.13 + (typep #2a((a b)(c d)(e f)) '(simple-array t (2 3))) + nil) diff --git a/ansi-tests/simple-array.lsp b/ansi-tests/simple-array.lsp new file mode 100644 index 0000000..c6e1099 --- /dev/null +++ b/ansi-tests/simple-array.lsp @@ -0,0 +1,329 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Jan 26 07:20:31 2003 +;;;; Contains: Tests of SIMPLE-ARRAY + +(in-package :cl-test) + +;;; Tests of simple-array by itself + +(deftest simple-array.1.1 + (notnot-mv (typep #() 'simple-array)) + t) + +(deftest simple-array.1.2 + (notnot-mv (typep #0aX 'simple-array)) + t) + +(deftest simple-array.1.3 + (notnot-mv (typep #2a(()) 'simple-array)) + t) + +(deftest simple-array.1.4 + (notnot-mv (typep #(1 2 3) 'simple-array)) + t) + +(deftest simple-array.1.5 + (notnot-mv (typep "abcd" 'simple-array)) + t) + +(deftest simple-array.1.6 + (notnot-mv (typep #*010101 'simple-array)) + t) + +(deftest simple-array.1.7 + (typep nil 'simple-array) + nil) + +(deftest simple-array.1.8 + (typep 'x 'simple-array) + nil) + +(deftest simple-array.1.9 + (typep '(a b c) 'simple-array) + nil) + +(deftest simple-array.1.10 + (typep 10.0 'simple-array) + nil) + +(deftest simple-array.1.11 + (typep #'(lambda (x) (cons x nil)) 'simple-array) + nil) + +(deftest simple-array.1.12 + (typep 1 'simple-array) + nil) + +(deftest simple-array.1.13 + (typep (1+ most-positive-fixnum) 'simple-array) + nil) + +;;; Tests of (simple-array *) + +(deftest simple-array.2.1 + (notnot-mv (typep #() '(simple-array *))) + t) + +(deftest simple-array.2.2 + (notnot-mv (typep #0aX '(simple-array *))) + t) + +(deftest simple-array.2.3 + (notnot-mv (typep #2a(()) '(simple-array *))) + t) + +(deftest simple-array.2.4 + (notnot-mv (typep #(1 2 3) '(simple-array *))) + t) + +(deftest simple-array.2.5 + (notnot-mv (typep "abcd" '(simple-array *))) + t) + +(deftest simple-array.2.6 + (notnot-mv (typep #*010101 '(simple-array *))) + t) + +;;; Tests of (simple-array * ()) + +(deftest simple-array.3.1 + (notnot-mv (typep #() '(simple-array * nil))) + nil) + +(deftest simple-array.3.2 + (notnot-mv (typep #0aX '(simple-array * nil))) + t) + +(deftest simple-array.3.3 + (typep #2a(()) '(simple-array * nil)) + nil) + +(deftest simple-array.3.4 + (typep #(1 2 3) '(simple-array * nil)) + nil) + +(deftest simple-array.3.5 + (typep "abcd" '(simple-array * nil)) + nil) + +(deftest simple-array.3.6 + (typep #*010101 '(simple-array * nil)) + nil) + +;;; Tests of (simple-array * 1) +;;; The '1' indicates rank, so this is equivalent to 'vector' + +(deftest simple-array.4.1 + (notnot-mv (typep #() '(simple-array * 1))) + t) + +(deftest simple-array.4.2 + (typep #0aX '(simple-array * 1)) + nil) + +(deftest simple-array.4.3 + (typep #2a(()) '(simple-array * 1)) + nil) + +(deftest simple-array.4.4 + (notnot-mv (typep #(1 2 3) '(simple-array * 1))) + t) + +(deftest simple-array.4.5 + (notnot-mv (typep "abcd" '(simple-array * 1))) + t) + +(deftest simple-array.4.6 + (notnot-mv (typep #*010101 '(simple-array * 1))) + t) + +;;; Tests of (simple-array * 0) + +(deftest simple-array.5.1 + (typep #() '(simple-array * 0)) + nil) + +(deftest simple-array.5.2 + (notnot-mv (typep #0aX '(simple-array * 0))) + t) + +(deftest simple-array.5.3 + (typep #2a(()) '(simple-array * 0)) + nil) + +(deftest simple-array.5.4 + (typep #(1 2 3) '(simple-array * 0)) + nil) + +(deftest simple-array.5.5 + (typep "abcd" '(simple-array * 0)) + nil) + +(deftest simple-array.5.6 + (typep #*010101 '(simple-array * 0)) + nil) + +;;; Tests of (simple-array * *) + +(deftest simple-array.6.1 + (notnot-mv (typep #() '(simple-array * *))) + t) + +(deftest simple-array.6.2 + (notnot-mv (typep #0aX '(simple-array * *))) + t) + +(deftest simple-array.6.3 + (notnot-mv (typep #2a(()) '(simple-array * *))) + t) + +(deftest simple-array.6.4 + (notnot-mv (typep #(1 2 3) '(simple-array * *))) + t) + +(deftest simple-array.6.5 + (notnot-mv (typep "abcd" '(simple-array * *))) + t) + +(deftest simple-array.6.6 + (notnot-mv (typep #*010101 '(simple-array * *))) + t) + +;;; Tests of (simple-array * 2) + +(deftest simple-array.7.1 + (typep #() '(simple-array * 2)) + nil) + +(deftest simple-array.7.2 + (typep #0aX '(simple-array * 2)) + nil) + +(deftest simple-array.7.3 + (notnot-mv (typep #2a(()) '(simple-array * 2))) + t) + +(deftest simple-array.7.4 + (typep #(1 2 3) '(simple-array * 2)) + nil) + +(deftest simple-array.7.5 + (typep "abcd" '(simple-array * 2)) + nil) + +(deftest simple-array.7.6 + (typep #*010101 '(simple-array * 2)) + nil) + +;;; Testing '(simple-array * (--)) + +(deftest simple-array.8.1 + (typep #() '(simple-array * (1))) + nil) + +(deftest simple-array.8.2 + (notnot-mv (typep #() '(simple-array * (0)))) + t) + +(deftest simple-array.8.3 + (notnot-mv (typep #() '(simple-array * (*)))) + t) + +(deftest simple-array.8.4 + (typep #(a b c) '(simple-array * (2))) + nil) + +(deftest simple-array.8.5 + (notnot-mv (typep #(a b c) '(simple-array * (3)))) + t) + +(deftest simple-array.8.6 + (notnot-mv (typep #(a b c) '(simple-array * (*)))) + t) + +(deftest simple-array.8.7 + (typep #(a b c) '(simple-array * (4))) + nil) + +(deftest simple-array.8.8 + (typep #2a((a b c)) '(simple-array * (*))) + nil) + +(deftest simple-array.8.9 + (typep #2a((a b c)) '(simple-array * (3))) + nil) + +(deftest simple-array.8.10 + (typep #2a((a b c)) '(simple-array * (1))) + nil) + +(deftest simple-array.8.11 + (typep "abc" '(simple-array * (2))) + nil) + +(deftest simple-array.8.12 + (notnot-mv (typep "abc" '(simple-array * (3)))) + t) + +(deftest simple-array.8.13 + (notnot-mv (typep "abc" '(simple-array * (*)))) + t) + +(deftest simple-array.8.14 + (typep "abc" '(simple-array * (4))) + nil) + +;;; Two dimensional simple-array type tests + +(deftest simple-array.9.1 + (typep #() '(simple-array * (* *))) + nil) + +(deftest simple-array.9.2 + (typep "abc" '(simple-array * (* *))) + nil) + +(deftest simple-array.9.3 + (typep #(a b c) '(simple-array * (3 *))) + nil) + +(deftest simple-array.9.4 + (typep #(a b c) '(simple-array * (* 3))) + nil) + +(deftest simple-array.9.5 + (typep "abc" '(simple-array * (3 *))) + nil) + +(deftest simple-array.9.6 + (typep "abc" '(simple-array * (* 3))) + nil) + +(deftest simple-array.9.7 + (notnot-mv (typep #2a((a b)(c d)(e f)) '(simple-array * (* *)))) + t) + +(deftest simple-array.9.8 + (notnot-mv (typep #2a((a b)(c d)(e f)) '(simple-array * (3 *)))) + t) + +(deftest simple-array.9.9 + (typep #2a((a b)(c d)(e f)) '(simple-array * (2 *))) + nil) + +(deftest simple-array.9.10 + (notnot-mv (typep #2a((a b)(c d)(e f)) '(simple-array * (* 2)))) + t) + +(deftest simple-array.9.11 + (typep #2a((a b)(c d)(e f)) '(simple-array * (* 3))) + nil) + +(deftest simple-array.9.12 + (notnot-mv (typep #2a((a b)(c d)(e f)) '(simple-array * (3 2)))) + t) + +(deftest simple-array.9.13 + (typep #2a((a b)(c d)(e f)) '(simple-array * (2 3))) + nil) diff --git a/ansi-tests/simple-bit-vector-p.lsp b/ansi-tests/simple-bit-vector-p.lsp new file mode 100644 index 0000000..debd322 --- /dev/null +++ b/ansi-tests/simple-bit-vector-p.lsp @@ -0,0 +1,62 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Jan 26 20:20:27 2003 +;;;; Contains: Tests of SIMPLE-BIT-VECTOR-P + +(in-package :cl-test) + +(deftest simple-bit-vector-p.2 + (notnot-mv (simple-bit-vector-p #*)) + t) + +(deftest simple-bit-vector-p.3 + (notnot-mv (simple-bit-vector-p #*00101)) + t) + +(deftest simple-bit-vector-p.4 + (simple-bit-vector-p #(0 1 1 1 0 0)) + nil) + +(deftest simple-bit-vector-p.5 + (simple-bit-vector-p "011100") + nil) + +(deftest simple-bit-vector-p.6 + (simple-bit-vector-p 0) + nil) + +(deftest simple-bit-vector-p.7 + (simple-bit-vector-p 1) + nil) + +(deftest simple-bit-vector-p.8 + (simple-bit-vector-p nil) + nil) + +(deftest simple-bit-vector-p.9 + (simple-bit-vector-p 'x) + nil) + +(deftest simple-bit-vector-p.10 + (simple-bit-vector-p '(0 1 1 0)) + nil) + +(deftest simple-bit-vector-p.11 + (simple-bit-vector-p (make-array '(2 2) :element-type 'bit + :initial-element 0)) + nil) + +(deftest simple-bit-vector-p.12 + (loop for e in *universe* + for p1 = (typep e 'simple-bit-vector) + for p2 = (simple-bit-vector-p e) + always (if p1 p2 (not p2))) + t) + +(deftest simple-bit-vector-p.error.1 + (classify-error (simple-bit-vector-p)) + program-error) + +(deftest simple-bit-vector-p.error.2 + (classify-error (simple-bit-vector-p #* #*)) + program-error) diff --git a/ansi-tests/simple-bit-vector.lsp b/ansi-tests/simple-bit-vector.lsp new file mode 100644 index 0000000..a46fd21 --- /dev/null +++ b/ansi-tests/simple-bit-vector.lsp @@ -0,0 +1,72 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Jan 26 13:12:07 2003 +;;;; Contains: Tests for type SIMPLE-BIT-VECTOR + +(in-package :cl-test) + +(deftest simple-bit-vector.2 + (notnot-mv (typep #* 'simple-bit-vector)) + t) + +(deftest simple-bit-vector.3 + (notnot-mv (typep #*00101 'simple-bit-vector)) + t) + +(deftest simple-bit-vector.4 + (typep #(0 1 1 1 0 0) 'simple-bit-vector) + nil) + +(deftest simple-bit-vector.5 + (typep "011100" 'simple-bit-vector) + nil) + +(deftest simple-bit-vector.6 + (typep 0 'simple-bit-vector) + nil) + +(deftest simple-bit-vector.7 + (typep 1 'simple-bit-vector) + nil) + +(deftest simple-bit-vector.8 + (typep nil 'simple-bit-vector) + nil) + +(deftest simple-bit-vector.9 + (typep 'x 'simple-bit-vector) + nil) + +(deftest simple-bit-vector.10 + (typep '(0 1 1 0) 'simple-bit-vector) + nil) + +(deftest simple-bit-vector.11 + (typep (make-array '(2 2) :element-type 'bit + :initial-element 0) + 'simple-bit-vector) + nil) + +(deftest simple-bit-vector.12 + (notnot-mv (typep #* '(simple-bit-vector *))) + t) + +(deftest simple-bit-vector.13 + (notnot-mv (typep #*01101 '(simple-bit-vector *))) + t) + +(deftest simple-bit-vector.14 + (notnot-mv (typep #* '(simple-bit-vector 0))) + t) + +(deftest simple-bit-vector.15 + (typep #*01101 '(simple-bit-vector 0)) + nil) + +(deftest simple-bit-vector.16 + (typep #* '(simple-bit-vector 5)) + nil) + +(deftest simple-bit-vector.17 + (notnot-mv (typep #*01101 '(simple-bit-vector 5))) + t) diff --git a/ansi-tests/simple-vector-p.lsp b/ansi-tests/simple-vector-p.lsp new file mode 100644 index 0000000..2246e09 --- /dev/null +++ b/ansi-tests/simple-vector-p.lsp @@ -0,0 +1,71 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Jan 22 21:23:45 2003 +;;;; Contains: Tests for SIMPLE-VECTOR-P + +(in-package :cl-test) + +;;; More tests for this are in make-array.lsp + +(deftest simple-vector-p.1 + (loop for e in *universe* + unless (if (typep e 'simple-vector) + (simple-vector-p e) + (not (simple-vector-p e))) + collect e) + nil) + +(deftest simple-vector-p.2 + (notnot-mv (simple-vector-p (make-array '(10)))) + t) + +;; (deftest simple-vector-p.3 +;; (simple-vector-p (make-array '(5) :fill-pointer t)) +;; nil) + +(deftest simple-vector-p.4 + (notnot-mv (simple-vector-p (vector 'a 'b 'c))) + t) + +;;; (deftest simple-vector-p.5 +;;; (simple-vector-p (make-array '(5) :adjustable t)) +;;; nil) + +;;; (deftest simple-vector-p.6 +;;; (let ((a #(a b c d e g h))) +;;; (simple-vector-p (make-array '(5) :displaced-to a))) +;;; nil) + +(deftest simple-vector-p.7 + (simple-vector-p #*001101) + nil) + +(deftest simple-vector-p.8 + (simple-vector-p "abcdef") + nil) + +(deftest simple-vector-p.9 + (simple-vector-p (make-array nil)) + nil) + +(deftest simple-vector-p.10 + (simple-vector-p (make-array '(10) :element-type 'base-char)) + nil) + +(deftest simple-vector-p.11 + (simple-vector-p (make-array '(10) :element-type 'character)) + nil) + +(deftest simple-vector-p.12 + (simple-vector-p (make-array '(10) :element-type 'bit)) + nil) + +;;; Error tests + +(deftest simple-vector-p.error.1 + (classify-error (simple-vector-p)) + program-error) + +(deftest simple-vector-p.error.2 + (classify-error (simple-vector-p #(a b) nil)) + program-error) diff --git a/ansi-tests/some.lsp b/ansi-tests/some.lsp new file mode 100644 index 0000000..5932375 --- /dev/null +++ b/ansi-tests/some.lsp @@ -0,0 +1,151 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Oct 18 07:07:07 2002 +;;;; Contains: Tests for SOME + +(in-package :cl-test) + +(deftest some.1 + (some #'identity nil) + nil) + +(deftest some.2 + (some #'identity #()) + nil) + +(deftest some.3 + (let ((count 0)) + (values + (some #'(lambda (x) (incf count) (if (>= x 10) x nil)) + '(1 2 4 13 5 1)) + count)) + 13 4) + +(deftest some.4 + (some #'/= '(1 2 3 4) '(1 2 3 4 5)) + nil) + +(deftest some.5 + (some #'/= '(1 2 3 4 5) '(1 2 3 4)) + nil) + +(deftest some.6 + (not-mv (some #'/= '(1 2 3 4 5) '(1 2 3 4 6))) + nil) + +(deftest some.7 + (some #'(lambda (x y) (and x y)) + '(nil t t nil t) #(t nil nil t nil nil)) + nil) + +(deftest some.8 + (let ((x '(1)) + (args nil)) + (loop for i from 1 below (1- (min 100 call-arguments-limit)) + do (push x args) + always (apply #'some #'/= args))) + nil) + +(deftest some.9 + (some #'zerop #*11111111111111) + nil) + +(deftest some.10 + (some #'zerop #*) + nil) + +(deftest some.11 + (not-mv (some #'zerop #*1111111011111)) + nil) + +(deftest some.12 + (some #'(lambda (x) (not (eql x #\a))) "aaaaaaaa") + nil) + +(deftest some.13 + (some #'(lambda (x) (eql x #\a)) "") + nil) + +(deftest some.14 + (not-mv (some #'(lambda (x) (not (eql x #\a))) "aaaaaabaaaa")) + nil) + +(deftest some.15 + (some 'null '(1 2 3 4)) + nil) + +(deftest some.16 + (not-mv (some 'null '(1 2 3 nil 5))) + nil) + +(deftest some.order.1 + (let ((i 0) x y) + (values + (some (progn (setf x (incf i)) #'null) + (progn (setf y (incf i)) '(a b c d))) + i x y)) + nil 2 1 2) + +(deftest some.order.2 + (let ((i 0) x y z) + (values + (some (progn (setf x (incf i)) #'eq) + (progn (setf y (incf i)) '(a b c d)) + (progn (setf z (incf i)) '(e f g h))) + i x y z)) + nil 3 1 2 3) + + +(deftest some.error.1 + (classify-error (some 1 '(a b c))) + type-error) + +(deftest some.error.2 + (classify-error (some #\a '(a b c))) + type-error) + +(deftest some.error.3 + (classify-error (some #() '(a b c))) + type-error) + +(deftest some.error.4 + (classify-error (some #'null 'a)) + type-error) + +(deftest some.error.5 + (classify-error (some #'null 100)) + type-error) + +(deftest some.error.6 + (classify-error (some #'null 'a)) + type-error) + +(deftest some.error.7 + (classify-error (some #'eq () 'a)) + type-error) + +(deftest some.error.8 + (classify-error (some)) + program-error) + +(deftest some.error.9 + (classify-error (some #'null)) + program-error) + +(deftest some.error.10 + (classify-error (locally (some 1 '(a b c)) t)) + type-error) + +(deftest some.error.11 + (classify-error (some #'cons '(a b c))) + program-error) + +(deftest some.error.12 + (classify-error (some #'car '(a b c))) + type-error) + +(deftest some.error.13 + (classify-error (some #'cons '(a b c) '(b c d) '(c d e))) + program-error) + + diff --git a/ansi-tests/sort.lsp b/ansi-tests/sort.lsp new file mode 100644 index 0000000..1eabcac --- /dev/null +++ b/ansi-tests/sort.lsp @@ -0,0 +1,143 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Aug 21 00:11:24 2002 +;;;; Contains: Tests for SORT + +(in-package :cl-test) + +(deftest sort-list.1 + (let ((a (list 1 4 2 5 3))) + (sort a #'<)) + (1 2 3 4 5)) + +(deftest sort-list.2 + (let ((a (list 1 4 2 5 3))) + (sort a #'< :key #'-)) + (5 4 3 2 1)) + +(deftest sort-list.3 + (let ((a (list 1 4 2 5 3))) + (sort a #'(lambda (x y) nil)) + (sort a #'<)) + (1 2 3 4 5)) + +(deftest sort-vector.1 + (let ((a (copy-seq #(1 4 2 5 3)))) + (sort a #'<)) + #(1 2 3 4 5)) + +(deftest sort-vector.2 + (let ((a (copy-seq #(1 4 2 5 3)))) + (sort a #'< :key #'-)) + #(5 4 3 2 1)) + +(deftest sort-vector.3 + (let ((a (copy-seq #(1 4 2 5 3)))) + (sort a #'(lambda (x y) nil)) + (sort a #'<)) + #(1 2 3 4 5)) + +(deftest sort-vector.4 + (let ((a (make-array 10 :initial-contents '(10 40 20 50 30 15 45 25 55 35) + :fill-pointer 5))) + (sort a #'<)) + #(10 20 30 40 50)) + +(deftest sort-bit-vector.1 + (let ((a (copy-seq #*10011101))) + (sort a #'<)) + #*00011111) + +(deftest sort-bit-vector.2 + (let ((a (copy-seq #*10011101))) + (values (sort a #'< :key #'-) a)) + #*11111000 + #*11111000) + +(deftest sort-bit-vector.3 + (let ((a (make-array 10 :initial-contents '(1 0 0 1 1 1 1 0 1 1) + :element-type 'bit + :fill-pointer 5))) + (sort a #'<)) + #*00111) + +(deftest sort-string.1 + (let ((a (copy-seq "10011101"))) + (values (sort a #'char<) a)) + "00011111" + "00011111") + +(deftest sort-string.2 + (let ((a (copy-seq "10011101"))) + (values (sort a #'char< :key #'(lambda (c) (if (eql c #\0) #\1 #\0))) a)) + "11111000" + "11111000") + +(deftest sort-string.3 + (let ((a (make-array 10 :initial-contents "1001111011" + :element-type 'character + :fill-pointer 5))) + (sort a #'char<)) + "00111") + +;;; Order of evaluation tests + +(deftest sort.order.1 + (let ((i 0) x y) + (values + (sort (progn (setf x (incf i)) (list 1 7 3 2)) + (progn (setf y (incf i)) #'<)) + i x y)) + (1 2 3 7) 2 1 2) + +(deftest sort.order.2 + (let ((i 0) x y z) + (values + (sort (progn (setf x (incf i)) (list 1 7 3 2)) + (progn (setf y (incf i)) #'<) + :key (progn (setf z (incf i)) #'-)) + i x y z)) + (7 3 2 1) 3 1 2 3) + + +;;; Error cases + +(deftest sort.error.1 + (classify-error (sort)) + program-error) + +(deftest sort.error.2 + (classify-error (sort nil)) + program-error) + +(deftest sort.error.3 + (classify-error (sort nil #'< :key)) + program-error) + +(deftest sort.error.4 + (classify-error (sort nil #'< 'bad t)) + program-error) + +(deftest sort.error.5 + (classify-error (sort nil #'< 'bad t :allow-other-keys nil)) + program-error) + +(deftest sort.error.6 + (classify-error (sort nil #'< 1 2)) + program-error) + +(deftest sort.error.7 + (classify-error (sort (list 1 2 3 4) #'identity)) + program-error) + +(deftest sort.error.8 + (classify-error (sort (list 1 2 3 4) #'< :key #'cons)) + program-error) + +(deftest sort.error.9 + (classify-error (sort (list 1 2 3 4) #'< :key #'car)) + type-error) + +(deftest sort.error.10 + (classify-error (sort (list 1 2 3 4) #'elt)) + type-error) diff --git a/ansi-tests/stable-sort.lsp b/ansi-tests/stable-sort.lsp new file mode 100644 index 0000000..9925d9c --- /dev/null +++ b/ansi-tests/stable-sort.lsp @@ -0,0 +1,154 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Aug 28 21:00:44 2002 +;;;; Contains: Tests for STABLE-SORT + +(in-package :cl-test) + +(deftest stable-sort-list.1 + (let ((a (list 1 4 2 5 3))) + (stable-sort a #'<)) + (1 2 3 4 5)) + +(deftest stable-sort-list.2 + (let ((a (list 1 4 2 5 3))) + (stable-sort a #'< :key #'-)) + (5 4 3 2 1)) + +(deftest stable-sort-list.3 + (let ((a (list 1 4 2 5 3))) + (stable-sort a #'(lambda (x y) nil)) + (stable-sort a #'<)) + (1 2 3 4 5)) + +(deftest stable-sort-list.4 + (let ((a (copy-seq '((1 a) (2 a) (1 b) (2 b) (1 c) (2 c))))) + (stable-sort a #'(lambda (x y) (< (car x) (car y))))) + ((1 a) (1 b) (1 c) (2 a) (2 b) (2 c))) + +(deftest stable-sort-list.5 + (let ((a (reverse (copy-seq '((1 a) (2 a) (1 b) (2 b) (1 c) (2 c)))))) + (stable-sort a #'(lambda (x y) (< (car x) (car y))))) + ((1 c) (1 b) (1 a) (2 c) (2 b) (2 a))) + +(deftest stable-sort-vector.1 + (let ((a (copy-seq #(1 4 2 5 3)))) + (stable-sort a #'<)) + #(1 2 3 4 5)) + +(deftest stable-sort-vector.2 + (let ((a (copy-seq #(1 4 2 5 3)))) + (stable-sort a #'< :key #'-)) + #(5 4 3 2 1)) + +(deftest stable-sort-vector.3 + (let ((a (copy-seq #(1 4 2 5 3)))) + (stable-sort a #'(lambda (x y) nil)) + (stable-sort a #'<)) + #(1 2 3 4 5)) + +(deftest stable-sort-vector.4 + (let ((a (make-array 10 :initial-contents '(10 40 20 50 30 15 45 25 55 35) + :fill-pointer 5))) + (stable-sort a #'<)) + #(10 20 30 40 50)) + +(deftest stable-sort-bit-vector.1 + (let ((a (copy-seq #*10011101))) + (stable-sort a #'<)) + #*00011111) + +(deftest stable-sort-bit-vector.2 + (let ((a (copy-seq #*10011101))) + (values (stable-sort a #'< :key #'-) a)) + #*11111000 + #*11111000) + +(deftest stable-sort-bit-vector.3 + (let ((a (make-array 10 :initial-contents '(1 0 0 1 1 1 1 0 1 1) + :element-type 'bit + :fill-pointer 5))) + (stable-sort a #'<)) + #*00111) + +(deftest stable-sort-string.1 + (let ((a (copy-seq "10011101"))) + (values (stable-sort a #'char<) a)) + "00011111" + "00011111") + +(deftest stable-sort-string.2 + (let ((a (copy-seq "10011101"))) + (values (stable-sort a #'char< + :key #'(lambda (c) (if (eql c #\0) #\1 #\0))) a)) + "11111000" + "11111000") + +(deftest stable-sort-string.3 + (let ((a (make-array 10 :initial-contents "1001111011" + :element-type 'character + :fill-pointer 5))) + (stable-sort a #'char<)) + "00111") + +;;; Order of evaluation tests + +(deftest stable-sort.order.1 + (let ((i 0) x y) + (values + (stable-sort (progn (setf x (incf i)) (list 1 7 3 2)) + (progn (setf y (incf i)) #'<)) + i x y)) + (1 2 3 7) 2 1 2) + +(deftest stable-sort.order.2 + (let ((i 0) x y z) + (values + (stable-sort (progn (setf x (incf i)) (list 1 7 3 2)) + (progn (setf y (incf i)) #'<) + :key (progn (setf z (incf i)) #'-)) + i x y z)) + (7 3 2 1) 3 1 2 3) + + +;;; Error cases + +(deftest stable-sort.error.1 + (classify-error (stable-sort)) + program-error) + +(deftest stable-sort.error.2 + (classify-error (stable-sort nil)) + program-error) + +(deftest stable-sort.error.3 + (classify-error (stable-sort nil #'< :key)) + program-error) + +(deftest stable-sort.error.4 + (classify-error (stable-sort nil #'< 'bad t)) + program-error) + +(deftest stable-sort.error.5 + (classify-error (stable-sort nil #'< 'bad t :allow-other-keys nil)) + program-error) + +(deftest stable-sort.error.6 + (classify-error (stable-sort nil #'< 1 2)) + program-error) + +(deftest stable-sort.error.7 + (classify-error (stable-sort (list 1 2 3 4) #'identity)) + program-error) + +(deftest stable-sort.error.8 + (classify-error (stable-sort (list 1 2 3 4) #'< :key #'cons)) + program-error) + +(deftest stable-sort.error.9 + (classify-error (stable-sort (list 1 2 3 4) #'< :key #'car)) + type-error) + +(deftest stable-sort.error.10 + (classify-error (stable-sort (list 1 2 3 4) #'elt)) + type-error) diff --git a/ansi-tests/string-aux.lsp b/ansi-tests/string-aux.lsp new file mode 100644 index 0000000..ba765c2 --- /dev/null +++ b/ansi-tests/string-aux.lsp @@ -0,0 +1,165 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Oct 4 06:51:32 2002 +;;;; Contains: Auxiliary functions for string testing + +(in-package :cl-test) + +(defun my-string-compare (string1 string2 comparison + &key (start1 0) end1 (start2 0) end2 case + &aux + (len1 (progn (assert (stringp string1)) + (length string1))) + (len2 (progn (assert (stringp string2)) + (length string2))) + (compare-fn + (case comparison + (< (if case #'char-lessp #'char<)) + (<= (if case #'char-not-greaterp + #'char<=)) + (= (if case #'char-equal #'char=)) + (/= (if case #'char-not-equal #'char/=)) + (> (if case #'char-greaterp #'char>)) + (>= (if case #'char-not-lessp #'char>=)) + (t (error "Bad comparison arg: ~A~%" + comparison)))) + (equal-fn (if case #'char-equal #'char=))) + + (assert (integerp start1)) + (assert (integerp start2)) + (unless end1 (setq end1 len1)) + (unless end2 (setq end2 len2)) + (assert (<= 0 start1 end1)) + (assert (<= 0 start2 end2)) + (loop + for i1 from start1 + for i2 from start2 + do + (cond + ((= i1 end1) + (return + (cond + ((= i2 end2) + ;; Both ended -- equality case + (if (member comparison '(= <= >=)) + end1 + nil)) + (t ;; string2 still extending + (if (member comparison '(/= < <=)) + end1 + nil))))) + ((= i2 end2) + ;; string1 still extending + (return + (if (member comparison '(/= > >=)) + i1 + nil))) + (t + (let ((c1 (char string1 i1)) + (c2 (char string2 i2))) + (cond + ((funcall equal-fn c1 c2)) + (t ;; mismatch found -- what kind? + (return + (if (funcall compare-fn c1 c2) + i1 + nil))))))))) + +(defun make-random-string-compare-test (n) + (let* ((len (random n)) + ;; Lengths of the two strings + (len1 (if (or (coin) (= len 0)) len (+ len (random len)))) + (len2 (if (or (coin) (= len 0)) len (+ len (random len)))) + ;; Lengths of the parts of the strings to be matched + (sublen1 (if (or (coin) (= len1 0)) (min len1 len2) (random len1))) + (sublen2 (if (or (coin) (= len2 0)) (min len2 sublen1) (random len2))) + ;; Start and end of the substring of the first string + (start1 (if (coin 3) 0 + (max 0 (min (1- len1) (random (- len1 sublen1 -1)))))) + (end1 (+ start1 sublen1)) + ;; Start and end of the substring of the second string + (start2 (if (coin 3) 0 + (max 0 (min (1- len2) (random (- len2 sublen2 -1)))))) + (end2 (+ start2 sublen2)) + ;; generate the strings + (s1 (make-random-string len1)) + (s2 (make-random-string len2))) + #| + (format t "len = ~A, len1 = ~A, len2 = ~A, sublen1 = ~A, sublen2 = ~A~%" + len len1 len2 sublen1 sublen2) + (format t "start1 = ~A, end1 = ~A, start2 = ~A, end2 = ~A~%" + start1 end1 start2 end2) + (format t "s1 = ~S, s2 = ~S~%" s1 s2) + |# + ;; Sometimes we want them to have a common prefix + (when (coin) + (if (<= sublen1 sublen2) + (setf (subseq s2 start2 (+ start2 sublen1)) + (subseq s1 start1 (+ start1 sublen1))) + (setf (subseq s1 start1 (+ start1 sublen2)) + (subseq s2 start2 (+ start2 sublen2))))) + (values + s1 + s2 + (reduce #'nconc + (random-permute + (list + (if (and (= start1 0) (coin)) + nil + (list :start1 start1)) + (if (and (= end1 len1) (coin)) + nil + (list :end1 end1)) + (if (and (= start2 0) (coin)) + nil + (list :start2 start2)) + (if (and (= end2 len2) (coin)) + nil + (list :end2 end2)))))))) + +(defun random-string-compare-test (n comparison case &optional (iterations 1)) + (loop for i from 1 to iterations + count + (multiple-value-bind (s1 s2 args) + (make-random-string-compare-test n) + ;; (format t "Args = ~S~%" args) + (let ((x (apply (case comparison + (< (if case #'string-lessp #'string<)) + (<= (if case #'string-not-greaterp + #'string<=)) + (= (if case #'string-equal #'string=)) + (/= (if case #'string-not-equal #'string/=)) + (> (if case #'string-greaterp #'string>)) + (>= (if case #'string-not-lessp #'string>=)) + (t (error "Bad comparison arg: ~A~%" comparison))) + s1 s2 args)) + (y (apply #'my-string-compare s1 s2 comparison :case case args))) + (not + (or (eql x y) + (and x y (eqt comparison '=)))))))) + +(defun make-random-string (n) + (let ((s (random-case + (make-string n) + (make-array n :element-type 'character + :initial-element #\a) + (make-array n :element-type 'standard-char + :initial-element #\a) + (make-array n :element-type 'base-char + :initial-element #\a)))) + (if (coin) + (dotimes (i n) + (setf (char s i) (elt #(#\a #\b #\A #\B) (random 4)))) + (dotimes (i n) + (dotimes (i n) + (setf (char s i) + (or (code-char (random 256)) + (elt "abcdefghijklmnopqrstuvwyxzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" + (random 62))))))) + s)) + +(defun string-all-the-same (s) + (let ((len (length s))) + (or (= len 0) + (let ((c (char s 0))) + (loop for d across s always (eql c d)))))) diff --git a/ansi-tests/string-capitalize.lsp b/ansi-tests/string-capitalize.lsp new file mode 100644 index 0000000..82be8ce --- /dev/null +++ b/ansi-tests/string-capitalize.lsp @@ -0,0 +1,132 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Thu Oct 3 20:08:26 2002 +;;;; Contains: Tests for STRING-CAPITALIZE + +(in-package :cl-test) + +(deftest string-capitalize.1 + (let ((s "abCd")) + (values (string-capitalize s) s)) + "Abcd" + "abCd") + + +(deftest string-capitalize.2 + (let ((s "0adA2Cdd3wXy")) + (values (string-capitalize s) s)) + "0ada2cdd3wxy" + "0adA2Cdd3wXy") + +(deftest string-capitalize.3 + (let ((s "1a")) + (values (string-capitalize s) s)) + "1a" + "1a") + +(deftest string-capitalize.4 + (let ((s "a1a")) + (values (string-capitalize s) s)) + "A1a" + "a1a") + +(deftest string-capitalize.5 + (let ((s #\a)) + (values (string-capitalize s) s)) + "A" + #\a) + +(deftest string-capitalize.6 + (let ((s '|abcDe|)) + (values (string-capitalize s) (symbol-name s))) + "Abcde" + "abcDe") + +(deftest string-capitalize.7 + (let ((s "ABCDEF")) + (values + (loop for i from 0 to 5 + collect (string-capitalize s :start i)) + s)) + ("Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF") + "ABCDEF") + +(deftest string-capitalize.8 + (let ((s "ABCDEF")) + (values + (loop for i from 0 to 5 + collect (string-capitalize s :start i :end nil)) + s)) + ("Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF") + "ABCDEF") + +(deftest string-capitalize.9 + (let ((s "ABCDEF")) + (values + (loop for i from 0 to 6 + collect (string-capitalize s :end i)) + s)) + ("ABCDEF" "ABCDEF" "AbCDEF" "AbcDEF" "AbcdEF" "AbcdeF" "Abcdef") + "ABCDEF") + +(deftest string-capitalize.10 + (let ((s "ABCDEF")) + (values + (loop for i from 0 to 5 + collect (loop for j from i to 6 + collect (string-capitalize s :start i :end j))) + s)) + (("ABCDEF" "ABCDEF" "AbCDEF" "AbcDEF" "AbcdEF" "AbcdeF" "Abcdef") + ("ABCDEF" "ABCDEF" "ABcDEF" "ABcdEF" "ABcdeF" "ABcdef") + ("ABCDEF" "ABCDEF" "ABCdEF" "ABCdeF" "ABCdef") + ("ABCDEF" "ABCDEF" "ABCDeF" "ABCDef") + ("ABCDEF" "ABCDEF" "ABCDEf") + ("ABCDEF" "ABCDEF")) + "ABCDEF") + +(deftest string-capitalize.order.1 + (let ((i 0) a b c (s (copy-seq "abcdef"))) + (values + (string-capitalize + (progn (setf a (incf i)) s) + :start (progn (setf b (incf i)) 1) + :end (progn (setf c (incf i)) 4)) + i a b c)) + "aBcdef" 3 1 2 3) + +(deftest string-capitalize.order.2 + (let ((i 0) a b c (s (copy-seq "abcdef"))) + (values + (string-capitalize + (progn (setf a (incf i)) s) + :end (progn (setf b (incf i)) 4) + :start (progn (setf c (incf i)) 1)) + i a b c)) + "aBcdef" 3 1 2 3) + +;;; Error cases + +(deftest string-capitalize.error.1 + (classify-error (string-capitalize)) + program-error) + +(deftest string-capitalize.error.2 + (classify-error (string-capitalize (copy-seq "abc") :bad t)) + program-error) + +(deftest string-capitalize.error.3 + (classify-error (string-capitalize (copy-seq "abc") :start)) + program-error) + +(deftest string-capitalize.error.4 + (classify-error (string-capitalize (copy-seq "abc") :bad t + :allow-other-keys nil)) + program-error) + +(deftest string-capitalize.error.5 + (classify-error (string-capitalize (copy-seq "abc") :end)) + program-error) + +(deftest string-capitalize.error.6 + (classify-error (string-capitalize (copy-seq "abc") 1 2)) + program-error) diff --git a/ansi-tests/string-comparisons.lsp b/ansi-tests/string-comparisons.lsp new file mode 100644 index 0000000..617390e --- /dev/null +++ b/ansi-tests/string-comparisons.lsp @@ -0,0 +1,514 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Oct 4 06:32:41 2002 +;;;; Contains: Tests of string comparison functions + +(in-package :cl-test) + +(deftest string=.1 + (not (string= "abc" (copy-seq "abc"))) + nil) + +(deftest string=.2 + (string= "A" "a") + nil) + +(deftest string=.3 + (not (string= #\a "a")) + nil) + +(deftest string=.4 + (not (string= '|abc| (copy-seq "abc"))) + nil) + +(deftest string=.5 + (not (string= (copy-seq "abc") '#:|abc|)) + nil) + +;;; Test that it doesn't stop at null characters +(deftest string=.6 + (let ((s1 (copy-seq "abc")) + (s2 (copy-seq "abd")) + (c (or (code-char 0) #\a))) + (setf (char s1 1) c) + (setf (char s2 1) c) + (values (length s1) (length s2) (string= s1 s2))) + 3 3 nil) + +(deftest string=.7 + (loop for i from 0 to 3 + collect (not (string= "abc" "abd" :start1 0 :end1 i :end2 i))) + (nil nil nil t)) + +(deftest string=.8 + (loop for i from 0 to 3 + collect (not (string= "abc" "ab" :end1 i))) + (t t nil t)) + +(deftest string=.9 + (loop for i from 0 to 3 + collect (not (string= "abc" "abd" :start2 0 :end2 i :end1 i))) + (nil nil nil t)) + +(deftest string=.10 + (loop for i from 0 to 3 + collect (not (string= "ab" "abc" :end2 i))) + (t t nil t)) + +(deftest string=.11 + (loop for i from 0 to 3 + collect (not (string= "xyab" "ab" :start1 i))) + (t t nil t)) + +(deftest string=.12 + (loop for i from 0 to 3 + collect (not (string= "ab" "xyab" :start2 i))) + (t t nil t)) + +(deftest string=.13 + (loop for i from 0 to 3 + collect (not (string= "xyab" "ab" :start1 i :end1 nil))) + (t t nil t)) + +(deftest string=.14 + (loop for i from 0 to 3 + collect (not (string= "ab" "xyab" :start2 i :end2 nil))) + (t t nil t)) + +;;; Order of evaluation + +(deftest string=.order.1 + (let ((i 0) x y) + (values + (string= (progn (setf x (incf i)) "abc") + (progn (setf y (incf i)) "abd")) + i x y)) + nil 2 1 2) + +(deftest string=.order.2 + (let ((i 0) a b c d e f) + (values + (string= (progn (setf a (incf i)) "abc") + (progn (setf b (incf i)) "abd") + :start1 (progn (setf c (incf i)) 0) + :start2 (progn (setf d (incf i)) 0) + :end1 (progn (setf e (incf i)) nil) + :end2 (progn (setf f (incf i)) nil) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string=.order.3 + (let ((i 0) a b c d e f) + (values + (string= (progn (setf a (incf i)) "abc") + (progn (setf b (incf i)) "abd") + :end2 (progn (setf c (incf i)) nil) + :end1 (progn (setf d (incf i)) nil) + :start2 (progn (setf e (incf i)) 0) + :start1 (progn (setf f (incf i)) 0) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string<=.order.1 + (let ((i 0) x y) + (values + (string<= (progn (setf x (incf i)) "abf") + (progn (setf y (incf i)) "abd")) + i x y)) + nil 2 1 2) + +(deftest string<=.order.2 + (let ((i 0) a b c d e f) + (values + (string<= (progn (setf a (incf i)) "abf") + (progn (setf b (incf i)) "abd") + :start1 (progn (setf c (incf i)) 0) + :start2 (progn (setf d (incf i)) 0) + :end1 (progn (setf e (incf i)) nil) + :end2 (progn (setf f (incf i)) nil) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string<=.order.3 + (let ((i 0) a b c d e f) + (values + (string<= (progn (setf a (incf i)) "abf") + (progn (setf b (incf i)) "abd") + :end2 (progn (setf c (incf i)) nil) + :end1 (progn (setf d (incf i)) nil) + :start2 (progn (setf e (incf i)) 0) + :start1 (progn (setf f (incf i)) 0) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string<.order.1 + (let ((i 0) x y) + (values + (string< (progn (setf x (incf i)) "abf") + (progn (setf y (incf i)) "abd")) + i x y)) + nil 2 1 2) + +(deftest string<.order.2 + (let ((i 0) a b c d e f) + (values + (string< (progn (setf a (incf i)) "abf") + (progn (setf b (incf i)) "abd") + :start1 (progn (setf c (incf i)) 0) + :start2 (progn (setf d (incf i)) 0) + :end1 (progn (setf e (incf i)) nil) + :end2 (progn (setf f (incf i)) nil) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string<.order.3 + (let ((i 0) a b c d e f) + (values + (string< (progn (setf a (incf i)) "abf") + (progn (setf b (incf i)) "abd") + :end2 (progn (setf c (incf i)) nil) + :end1 (progn (setf d (incf i)) nil) + :start2 (progn (setf e (incf i)) 0) + :start1 (progn (setf f (incf i)) 0) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + + +(deftest string/=.order.1 + (let ((i 0) x y) + (values + (string/= (progn (setf x (incf i)) "abc") + (progn (setf y (incf i)) "abc")) + i x y)) + nil 2 1 2) + +(deftest string/=.order.2 + (let ((i 0) a b c d e f) + (values + (string/= (progn (setf a (incf i)) "abc") + (progn (setf b (incf i)) "abc") + :start1 (progn (setf c (incf i)) 0) + :start2 (progn (setf d (incf i)) 0) + :end1 (progn (setf e (incf i)) nil) + :end2 (progn (setf f (incf i)) nil) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string/=.order.3 + (let ((i 0) a b c d e f) + (values + (string/= (progn (setf a (incf i)) "abc") + (progn (setf b (incf i)) "abc") + :end2 (progn (setf c (incf i)) nil) + :end1 (progn (setf d (incf i)) nil) + :start2 (progn (setf e (incf i)) 0) + :start1 (progn (setf f (incf i)) 0) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string>=.order.1 + (let ((i 0) x y) + (values + (string<= (progn (setf x (incf i)) "abf") + (progn (setf y (incf i)) "abd")) + i x y)) + nil 2 1 2) + +(deftest string>=.order.2 + (let ((i 0) a b c d e f) + (values + (string>= (progn (setf a (incf i)) "abc") + (progn (setf b (incf i)) "abd") + :start1 (progn (setf c (incf i)) 0) + :start2 (progn (setf d (incf i)) 0) + :end1 (progn (setf e (incf i)) nil) + :end2 (progn (setf f (incf i)) nil) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string>=.order.3 + (let ((i 0) a b c d e f) + (values + (string>= (progn (setf a (incf i)) "abc") + (progn (setf b (incf i)) "abd") + :end2 (progn (setf c (incf i)) nil) + :end1 (progn (setf d (incf i)) nil) + :start2 (progn (setf e (incf i)) 0) + :start1 (progn (setf f (incf i)) 0) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string>.order.1 + (let ((i 0) x y) + (values + (string> (progn (setf x (incf i)) "abc") + (progn (setf y (incf i)) "abd")) + i x y)) + nil 2 1 2) + +(deftest string>.order.2 + (let ((i 0) a b c d e f) + (values + (string> (progn (setf a (incf i)) "abc") + (progn (setf b (incf i)) "abd") + :start1 (progn (setf c (incf i)) 0) + :start2 (progn (setf d (incf i)) 0) + :end1 (progn (setf e (incf i)) nil) + :end2 (progn (setf f (incf i)) nil) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string>.order.3 + (let ((i 0) a b c d e f) + (values + (string> (progn (setf a (incf i)) "abc") + (progn (setf b (incf i)) "abd") + :end2 (progn (setf c (incf i)) nil) + :end1 (progn (setf d (incf i)) nil) + :start2 (progn (setf e (incf i)) 0) + :start1 (progn (setf f (incf i)) 0) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + + +(deftest string-equal.order.1 + (let ((i 0) x y) + (values + (string-equal (progn (setf x (incf i)) "abc") + (progn (setf y (incf i)) "abd")) + i x y)) + nil 2 1 2) + +(deftest string-equal.order.2 + (let ((i 0) a b c d e f) + (values + (string-equal (progn (setf a (incf i)) "abc") + (progn (setf b (incf i)) "abd") + :start1 (progn (setf c (incf i)) 0) + :start2 (progn (setf d (incf i)) 0) + :end1 (progn (setf e (incf i)) nil) + :end2 (progn (setf f (incf i)) nil) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string-equal.order.3 + (let ((i 0) a b c d e f) + (values + (string-equal (progn (setf a (incf i)) "abc") + (progn (setf b (incf i)) "abd") + :end2 (progn (setf c (incf i)) nil) + :end1 (progn (setf d (incf i)) nil) + :start2 (progn (setf e (incf i)) 0) + :start1 (progn (setf f (incf i)) 0) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string-not-greaterp.order.1 + (let ((i 0) x y) + (values + (string-not-greaterp (progn (setf x (incf i)) "abf") + (progn (setf y (incf i)) "abd")) + i x y)) + nil 2 1 2) + +(deftest string-not-greaterp.order.2 + (let ((i 0) a b c d e f) + (values + (string-not-greaterp (progn (setf a (incf i)) "abf") + (progn (setf b (incf i)) "abd") + :start1 (progn (setf c (incf i)) 0) + :start2 (progn (setf d (incf i)) 0) + :end1 (progn (setf e (incf i)) nil) + :end2 (progn (setf f (incf i)) nil) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string-not-greaterp.order.3 + (let ((i 0) a b c d e f) + (values + (string-not-greaterp (progn (setf a (incf i)) "abf") + (progn (setf b (incf i)) "abd") + :end2 (progn (setf c (incf i)) nil) + :end1 (progn (setf d (incf i)) nil) + :start2 (progn (setf e (incf i)) 0) + :start1 (progn (setf f (incf i)) 0) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string-lessp.order.1 + (let ((i 0) x y) + (values + (string-lessp (progn (setf x (incf i)) "abf") + (progn (setf y (incf i)) "abd")) + i x y)) + nil 2 1 2) + +(deftest string-lessp.order.2 + (let ((i 0) a b c d e f) + (values + (string-lessp (progn (setf a (incf i)) "abf") + (progn (setf b (incf i)) "abd") + :start1 (progn (setf c (incf i)) 0) + :start2 (progn (setf d (incf i)) 0) + :end1 (progn (setf e (incf i)) nil) + :end2 (progn (setf f (incf i)) nil) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string-lessp.order.3 + (let ((i 0) a b c d e f) + (values + (string-lessp (progn (setf a (incf i)) "abf") + (progn (setf b (incf i)) "abd") + :end2 (progn (setf c (incf i)) nil) + :end1 (progn (setf d (incf i)) nil) + :start2 (progn (setf e (incf i)) 0) + :start1 (progn (setf f (incf i)) 0) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + + +(deftest string-not-equal.order.1 + (let ((i 0) x y) + (values + (string-not-equal (progn (setf x (incf i)) "abc") + (progn (setf y (incf i)) "abc")) + i x y)) + nil 2 1 2) + +(deftest string-not-equal.order.2 + (let ((i 0) a b c d e f) + (values + (string-not-equal (progn (setf a (incf i)) "abc") + (progn (setf b (incf i)) "abc") + :start1 (progn (setf c (incf i)) 0) + :start2 (progn (setf d (incf i)) 0) + :end1 (progn (setf e (incf i)) nil) + :end2 (progn (setf f (incf i)) nil) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string-not-equal.order.3 + (let ((i 0) a b c d e f) + (values + (string-not-equal (progn (setf a (incf i)) "abc") + (progn (setf b (incf i)) "abc") + :end2 (progn (setf c (incf i)) nil) + :end1 (progn (setf d (incf i)) nil) + :start2 (progn (setf e (incf i)) 0) + :start1 (progn (setf f (incf i)) 0) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string-not-lessp.order.1 + (let ((i 0) x y) + (values + (string-not-lessp (progn (setf x (incf i)) "abc") + (progn (setf y (incf i)) "abd")) + i x y)) + nil 2 1 2) + +(deftest string-not-lessp.order.2 + (let ((i 0) a b c d e f) + (values + (string-not-lessp (progn (setf a (incf i)) "abc") + (progn (setf b (incf i)) "abd") + :start1 (progn (setf c (incf i)) 0) + :start2 (progn (setf d (incf i)) 0) + :end1 (progn (setf e (incf i)) nil) + :end2 (progn (setf f (incf i)) nil) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string-not-lessp.order.3 + (let ((i 0) a b c d e f) + (values + (string-not-lessp (progn (setf a (incf i)) "abc") + (progn (setf b (incf i)) "abd") + :end2 (progn (setf c (incf i)) nil) + :end1 (progn (setf d (incf i)) nil) + :start2 (progn (setf e (incf i)) 0) + :start1 (progn (setf f (incf i)) 0) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string-greaterp.order.1 + (let ((i 0) x y) + (values + (string-greaterp (progn (setf x (incf i)) "abc") + (progn (setf y (incf i)) "abd")) + i x y)) + nil 2 1 2) + +(deftest string-greaterp.order.2 + (let ((i 0) a b c d e f) + (values + (string-greaterp (progn (setf a (incf i)) "abc") + (progn (setf b (incf i)) "abd") + :start1 (progn (setf c (incf i)) 0) + :start2 (progn (setf d (incf i)) 0) + :end1 (progn (setf e (incf i)) nil) + :end2 (progn (setf f (incf i)) nil) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + +(deftest string-greaterp.order.3 + (let ((i 0) a b c d e f) + (values + (string-greaterp (progn (setf a (incf i)) "abc") + (progn (setf b (incf i)) "abd") + :end2 (progn (setf c (incf i)) nil) + :end1 (progn (setf d (incf i)) nil) + :start2 (progn (setf e (incf i)) 0) + :start1 (progn (setf f (incf i)) 0) + ) + i a b c d e f)) + nil 6 1 2 3 4 5 6) + + +;;; Random tests (of all the string comparson functions) + +(deftest random-string-comparison-tests + (loop for cmp in '(= /= < > <= >=) + append + (loop for case in '(nil t) + collect + (list cmp case + (random-string-compare-test 10 cmp case 1000)))) + ((= nil 0) (= t 0) (/= nil 0) (/= t 0) (< nil 0) (< t 0) + (> nil 0) (> t 0) (<= nil 0) (<= t 0) (>= nil 0) (>= t 0))) + + + + + + + + + + + + diff --git a/ansi-tests/string-downcase.lsp b/ansi-tests/string-downcase.lsp new file mode 100644 index 0000000..a1c4dd2 --- /dev/null +++ b/ansi-tests/string-downcase.lsp @@ -0,0 +1,128 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Mon Sep 30 21:41:59 2002 +;;;; Contains: Tests for STRING-DOWNCASE + +(in-package :cl-test) + +(deftest string-downcase.1 + (let ((s "A")) + (values (string-downcase s) s)) + "a" "A") + +(deftest string-downcase.2 + (let ((s "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")) + (values (string-downcase s) s)) + "abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz" + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz") + +(deftest string-downcase.3 + (let ((s "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ")) + (values (string-downcase s) s)) + "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ " + "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ") + +(deftest string-downcase.4 + (string-downcase #\A) + "a") + +(deftest string-downcase.5 + (let ((sym '|A|)) + (values (string-downcase sym) sym)) + "a" |A|) + +(deftest string-downcase.6 + (let ((s (make-array 6 :element-type 'character + :initial-contents '(#\A #\B #\C #\D #\E #\F)))) + (values (string-downcase s) s)) + "abcdef" + "ABCDEF") + +(deftest string-downcase.7 + (let ((s (make-array 6 :element-type 'standard-char + :initial-contents '(#\A #\B #\7 #\D #\E #\F)))) + (values (string-downcase s) s)) + "ab7def" + "AB7DEF") + +;; Tests with :start, :end + +(deftest string-downcase.8 + (let ((s "ABCDEF")) + (values + (loop for i from 0 to 6 + collect (string-downcase s :start i)) + s)) + ("abcdef" "Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF") + "ABCDEF") + +(deftest string-downcase.9 + (let ((s "ABCDEF")) + (values + (loop for i from 0 to 6 + collect (string-downcase s :start i :end nil)) + s)) + ("abcdef" "Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF") + "ABCDEF") + +(deftest string-downcase.10 + (let ((s "ABCDE")) + (values + (loop for i from 0 to 4 + collect (loop for j from i to 5 + collect (string-invertcase + (string-downcase s :start i :end j)))) + s)) + (("abcde" "Abcde" "ABcde" "ABCde" "ABCDe" "ABCDE") + ("abcde" "aBcde" "aBCde" "aBCDe" "aBCDE") + ("abcde" "abCde" "abCDe" "abCDE") + ("abcde" "abcDe" "abcDE") + ("abcde" "abcdE")) + "ABCDE") + +(deftest string-downcase.order.1 + (let ((i 0) a b c (s (copy-seq "ABCDEF"))) + (values + (string-downcase + (progn (setf a (incf i)) s) + :start (progn (setf b (incf i)) 1) + :end (progn (setf c (incf i)) 4)) + i a b c)) + "AbcdEF" 3 1 2 3) + +(deftest string-downcase.order.2 + (let ((i 0) a b c (s (copy-seq "ABCDEF"))) + (values + (string-downcase + (progn (setf a (incf i)) s) + :end (progn (setf b (incf i)) 4) + :start (progn (setf c (incf i)) 1)) + i a b c)) + "AbcdEF" 3 1 2 3) + +;;; Error cases + +(deftest string-downcase.error.1 + (classify-error (string-downcase)) + program-error) + +(deftest string-downcase.error.2 + (classify-error (string-downcase (copy-seq "abc") :bad t)) + program-error) + +(deftest string-downcase.error.3 + (classify-error (string-downcase (copy-seq "abc") :start)) + program-error) + +(deftest string-downcase.error.4 + (classify-error (string-downcase (copy-seq "abc") :bad t + :allow-other-keys nil)) + program-error) + +(deftest string-downcase.error.5 + (classify-error (string-downcase (copy-seq "abc") :end)) + program-error) + +(deftest string-downcase.error.6 + (classify-error (string-downcase (copy-seq "abc") 1 2)) + program-error) diff --git a/ansi-tests/string-left-trim.lsp b/ansi-tests/string-left-trim.lsp new file mode 100644 index 0000000..c620670 --- /dev/null +++ b/ansi-tests/string-left-trim.lsp @@ -0,0 +1,165 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Oct 4 04:57:41 2002 +;;;; Contains: Tests for STRING-LEFT-TRIM + +(in-package :cl-test) + +(deftest string-left-trim.1 + (let* ((s (copy-seq "abcdaba")) + (s2 (string-left-trim "ab" s))) + (values s s2)) + "abcdaba" + "cdaba") + +(deftest string-left-trim.2 + (let* ((s (copy-seq "abcdaba")) + (s2 (string-left-trim '(#\a #\b) s))) + (values s s2)) + "abcdaba" + "cdaba") + +(deftest string-left-trim.3 + (let* ((s (copy-seq "abcdaba")) + (s2 (string-left-trim #(#\a #\b) s))) + (values s s2)) + "abcdaba" + "cdaba") + +(deftest string-left-trim.4 + (let* ((s (copy-seq "abcdaba")) + (s2 (string-left-trim (make-array 2 :initial-contents '(#\a #\b)) + s))) + (values s s2)) + "abcdaba" + "cdaba") + +(deftest string-left-trim.5 + (let* ((s (copy-seq "abcdaba")) + (s2 (string-left-trim (make-array 2 :initial-contents '(#\a #\b) + :element-type 'character) + s))) + (values s s2)) + "abcdaba" + "cdaba") + +(deftest string-left-trim.6 + (let* ((s (copy-seq "abcdaba")) + (s2 (string-left-trim (make-array 2 :initial-contents '(#\a #\b) + :element-type 'standard-char) + s))) + (values s s2)) + "abcdaba" + "cdaba") + +(deftest string-left-trim.7 + (let* ((s (copy-seq "abcdaba")) + (s2 (string-left-trim (make-array 2 :initial-contents '(#\a #\b) + :element-type 'base-char) + s))) + (values s s2)) + "abcdaba" + "cdaba") + +(deftest string-left-trim.8 + (let* ((s (copy-seq "abcdaba")) + (s2 (string-left-trim (make-array 4 :initial-contents '(#\a #\b #\c #\d) + :element-type 'character + :fill-pointer 2) + s))) + (values s s2)) + "abcdaba" + "cdaba") + +(deftest string-left-trim.9 + (let* ((s (make-array 7 :initial-contents "abcdaba" + :element-type 'character + )) + (s2 (string-left-trim "ab" s))) + (values s s2)) + "abcdaba" + "cdaba") + +(deftest string-left-trim.10 + (let* ((s (make-array 9 :initial-contents "abcdabadd" + :element-type 'character + :fill-pointer 7)) + (s2 (string-left-trim "ab" s))) + (values s s2)) + "abcdaba" + "cdaba") + +(deftest string-left-trim.11 + (let* ((s (make-array 7 :initial-contents "abcdaba" + :element-type 'standard-char + )) + (s2 (string-left-trim "ab" s))) + (values s s2)) + "abcdaba" + "cdaba") + +(deftest string-left-trim.12 + (let* ((s (make-array 7 :initial-contents "abcdaba" + :element-type 'base-char + )) + (s2 (string-left-trim "ab" s))) + (values s s2)) + "abcdaba" + "cdaba") + +;;; Test that trimming is case sensitive +(deftest string-left-trim.13 + (let* ((s (copy-seq "aA")) + (s2 (string-left-trim "a" s))) + (values s s2)) + "aA" "A") + +(deftest string-left-trim.14 + (let* ((s '|abcdaba|) + (s2 (string-left-trim "ab" s))) + (values (symbol-name s) s2)) + "abcdaba" + "cdaba") + +(deftest string-left-trim.15 + (string-left-trim "abc" "") + "") + +(deftest string-left-trim.16 + (string-left-trim "a" #\a) + "") + +(deftest string-left-trim.17 + (string-left-trim "b" #\a) + "a") + +(deftest string-left-trim.18 + (string-left-trim "" (copy-seq "abcde")) + "abcde") + +(deftest string-left-trim.19 + (string-left-trim "abc" (copy-seq "abcabcabc")) + "") + +(deftest string-left-trim.order.1 + (let ((i 0) x y) + (values + (string-left-trim (progn (setf x (incf i)) " ") + (progn (setf y (incf i)) + (copy-seq " abc d e f "))) + i x y)) + "abc d e f " 2 1 2) + +;;; Error cases + +(deftest string-left-trim.error.1 + (classify-error (string-left-trim)) + program-error) + +(deftest string-left-trim.error.2 + (classify-error (string-left-trim "abc")) + program-error) + +(deftest string-left-trim.error.3 + (classify-error (string-left-trim "abc" "abcdddabc" nil)) + program-error) diff --git a/ansi-tests/string-right-trim.lsp b/ansi-tests/string-right-trim.lsp new file mode 100644 index 0000000..883348e --- /dev/null +++ b/ansi-tests/string-right-trim.lsp @@ -0,0 +1,165 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Oct 4 04:59:46 2002 +;;;; Contains: Tests of STRING-RIGHT-TRIM + +(in-package :cl-test) + +(deftest string-right-trim.1 + (let* ((s (copy-seq "abcdaba")) + (s2 (string-right-trim "ab" s))) + (values s s2)) + "abcdaba" + "abcd") + +(deftest string-right-trim.2 + (let* ((s (copy-seq "abcdaba")) + (s2 (string-right-trim '(#\a #\b) s))) + (values s s2)) + "abcdaba" + "abcd") + +(deftest string-right-trim.3 + (let* ((s (copy-seq "abcdaba")) + (s2 (string-right-trim #(#\a #\b) s))) + (values s s2)) + "abcdaba" + "abcd") + +(deftest string-right-trim.4 + (let* ((s (copy-seq "abcdaba")) + (s2 (string-right-trim (make-array 2 :initial-contents '(#\a #\b)) + s))) + (values s s2)) + "abcdaba" + "abcd") + +(deftest string-right-trim.5 + (let* ((s (copy-seq "abcdaba")) + (s2 (string-right-trim (make-array 2 :initial-contents '(#\a #\b) + :element-type 'character) + s))) + (values s s2)) + "abcdaba" + "abcd") + +(deftest string-right-trim.6 + (let* ((s (copy-seq "abcdaba")) + (s2 (string-right-trim (make-array 2 :initial-contents '(#\a #\b) + :element-type 'standard-char) + s))) + (values s s2)) + "abcdaba" + "abcd") + +(deftest string-right-trim.7 + (let* ((s (copy-seq "abcdaba")) + (s2 (string-right-trim (make-array 2 :initial-contents '(#\a #\b) + :element-type 'base-char) + s))) + (values s s2)) + "abcdaba" + "abcd") + +(deftest string-right-trim.8 + (let* ((s (copy-seq "abcdaba")) + (s2 (string-right-trim (make-array 4 :initial-contents '(#\a #\b #\c #\d) + :element-type 'character + :fill-pointer 2) + s))) + (values s s2)) + "abcdaba" + "abcd") + +(deftest string-right-trim.9 + (let* ((s (make-array 7 :initial-contents "abcdaba" + :element-type 'character + )) + (s2 (string-right-trim "ab" s))) + (values s s2)) + "abcdaba" + "abcd") + +(deftest string-right-trim.10 + (let* ((s (make-array 9 :initial-contents "abcdabadd" + :element-type 'character + :fill-pointer 7)) + (s2 (string-right-trim "ab" s))) + (values s s2)) + "abcdaba" + "abcd") + +(deftest string-right-trim.11 + (let* ((s (make-array 7 :initial-contents "abcdaba" + :element-type 'standard-char + )) + (s2 (string-right-trim "ab" s))) + (values s s2)) + "abcdaba" + "abcd") + +(deftest string-right-trim.12 + (let* ((s (make-array 7 :initial-contents "abcdaba" + :element-type 'base-char + )) + (s2 (string-right-trim "ab" s))) + (values s s2)) + "abcdaba" + "abcd") + +;;; Test that trimming is case sensitive +(deftest string-right-trim.13 + (let* ((s (copy-seq "Aa")) + (s2 (string-right-trim "a" s))) + (values s s2)) + "Aa" "A") + +(deftest string-right-trim.14 + (let* ((s '|abcdaba|) + (s2 (string-right-trim "ab" s))) + (values (symbol-name s) s2)) + "abcdaba" + "abcd") + +(deftest string-right-trim.15 + (string-right-trim "abc" "") + "") + +(deftest string-right-trim.16 + (string-right-trim "a" #\a) + "") + +(deftest string-right-trim.17 + (string-right-trim "b" #\a) + "a") + +(deftest string-right-trim.18 + (string-right-trim "" (copy-seq "abcde")) + "abcde") + +(deftest string-right-trim.19 + (string-right-trim "abc" (copy-seq "abcabcabc")) + "") + +(deftest string-right-trim.order.1 + (let ((i 0) x y) + (values + (string-right-trim (progn (setf x (incf i)) " ") + (progn (setf y (incf i)) + (copy-seq " abc d e f "))) + i x y)) + " abc d e f" 2 1 2) + +;;; Error cases + +(deftest string-right-trim.error.1 + (classify-error (string-right-trim)) + program-error) + +(deftest string-right-trim.error.2 + (classify-error (string-right-trim "abc")) + program-error) + +(deftest string-right-trim.error.3 + (classify-error (string-right-trim "abc" "abcdddabc" nil)) + program-error) diff --git a/ansi-tests/string-trim.lsp b/ansi-tests/string-trim.lsp new file mode 100644 index 0000000..a722268 --- /dev/null +++ b/ansi-tests/string-trim.lsp @@ -0,0 +1,165 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Thu Oct 3 21:53:38 2002 +;;;; Contains: Tests for STRING-TRIM + +(in-package :cl-test) + +(deftest string-trim.1 + (let* ((s (copy-seq "abcdaba")) + (s2 (string-trim "ab" s))) + (values s s2)) + "abcdaba" + "cd") + +(deftest string-trim.2 + (let* ((s (copy-seq "abcdaba")) + (s2 (string-trim '(#\a #\b) s))) + (values s s2)) + "abcdaba" + "cd") + +(deftest string-trim.3 + (let* ((s (copy-seq "abcdaba")) + (s2 (string-trim #(#\a #\b) s))) + (values s s2)) + "abcdaba" + "cd") + +(deftest string-trim.4 + (let* ((s (copy-seq "abcdaba")) + (s2 (string-trim (make-array 2 :initial-contents '(#\a #\b)) + s))) + (values s s2)) + "abcdaba" + "cd") + +(deftest string-trim.5 + (let* ((s (copy-seq "abcdaba")) + (s2 (string-trim (make-array 2 :initial-contents '(#\a #\b) + :element-type 'character) + s))) + (values s s2)) + "abcdaba" + "cd") + +(deftest string-trim.6 + (let* ((s (copy-seq "abcdaba")) + (s2 (string-trim (make-array 2 :initial-contents '(#\a #\b) + :element-type 'standard-char) + s))) + (values s s2)) + "abcdaba" + "cd") + +(deftest string-trim.7 + (let* ((s (copy-seq "abcdaba")) + (s2 (string-trim (make-array 2 :initial-contents '(#\a #\b) + :element-type 'base-char) + s))) + (values s s2)) + "abcdaba" + "cd") + +(deftest string-trim.8 + (let* ((s (copy-seq "abcdaba")) + (s2 (string-trim (make-array 4 :initial-contents '(#\a #\b #\c #\d) + :element-type 'character + :fill-pointer 2) + s))) + (values s s2)) + "abcdaba" + "cd") + +(deftest string-trim.9 + (let* ((s (make-array 7 :initial-contents "abcdaba" + :element-type 'character + )) + (s2 (string-trim "ab" s))) + (values s s2)) + "abcdaba" + "cd") + +(deftest string-trim.10 + (let* ((s (make-array 9 :initial-contents "abcdabadd" + :element-type 'character + :fill-pointer 7)) + (s2 (string-trim "ab" s))) + (values s s2)) + "abcdaba" + "cd") + +(deftest string-trim.11 + (let* ((s (make-array 7 :initial-contents "abcdaba" + :element-type 'standard-char + )) + (s2 (string-trim "ab" s))) + (values s s2)) + "abcdaba" + "cd") + +(deftest string-trim.12 + (let* ((s (make-array 7 :initial-contents "abcdaba" + :element-type 'base-char + )) + (s2 (string-trim "ab" s))) + (values s s2)) + "abcdaba" + "cd") + +;;; Test that trimming is case sensitive +(deftest string-trim.13 + (let* ((s (copy-seq "Aa")) + (s2 (string-trim "a" s))) + (values s s2)) + "Aa" "A") + +(deftest string-trim.14 + (let* ((s '|abcdaba|) + (s2 (string-trim "ab" s))) + (values (symbol-name s) s2)) + "abcdaba" + "cd") + +(deftest string-trim.15 + (string-trim "abc" "") + "") + +(deftest string-trim.16 + (string-trim "a" #\a) + "") + +(deftest string-trim.17 + (string-trim "b" #\a) + "a") + +(deftest string-trim.18 + (string-trim "" (copy-seq "abcde")) + "abcde") + +(deftest string-trim.19 + (string-trim "abc" (copy-seq "abcabcabc")) + "") + +(deftest string-trim.order.1 + (let ((i 0) x y) + (values + (string-trim (progn (setf x (incf i)) " ") + (progn (setf y (incf i)) + (copy-seq " abc d e f "))) + i x y)) + "abc d e f" 2 1 2) + +;;; Error cases + +(deftest string-trim.error.1 + (classify-error (string-trim)) + program-error) + +(deftest string-trim.error.2 + (classify-error (string-trim "abc")) + program-error) + +(deftest string-trim.error.3 + (classify-error (string-trim "abc" "abcdddabc" nil)) + program-error) diff --git a/ansi-tests/string-upcase.lsp b/ansi-tests/string-upcase.lsp new file mode 100644 index 0000000..4999f5c --- /dev/null +++ b/ansi-tests/string-upcase.lsp @@ -0,0 +1,129 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Oct 1 07:51:00 2002 +;;;; Contains: Tests for STRING-UPCASE + +(in-package :cl-test) + +(deftest string-upcase.1 + (let ((s "a")) + (values (string-upcase s) s)) + "A" "a") + +(deftest string-upcase.2 + (let ((s "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")) + (values (string-upcase s) s)) + "ABCDEFGHIJKLMNOPQRSTUVWXYZABCDEFGHIJKLMNOPQRSTUVWXYZ" + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz") + +(deftest string-upcase.3 + (let ((s "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ")) + (values (string-upcase s) s)) + "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ " + "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ") + +(deftest string-upcase.4 + (string-upcase #\a) + "A") + +(deftest string-upcase.5 + (let ((sym '|a|)) + (values (string-upcase sym) sym)) + "A" |a|) + +(deftest string-upcase.6 + (let ((s (make-array 6 :element-type 'character + :initial-contents '(#\a #\b #\c #\d #\e #\f)))) + (values (string-upcase s) s)) + "ABCDEF" + "abcdef") + +(deftest string-upcase.7 + (let ((s (make-array 6 :element-type 'standard-char + :initial-contents '(#\a #\b #\7 #\d #\e #\f)))) + (values (string-upcase s) s)) + "AB7DEF" + "ab7def") + +;; Tests with :start, :end + +(deftest string-upcase.8 + (let ((s "abcdef")) + (values + (loop for i from 0 to 6 + collect (string-upcase s :start i)) + s)) + ("ABCDEF" "aBCDEF" "abCDEF" "abcDEF" "abcdEF" "abcdeF" "abcdef") + "abcdef") + +(deftest string-upcase.9 + (let ((s "abcdef")) + (values + (loop for i from 0 to 6 + collect + (string-upcase s :start i :end nil)) + s)) + ("ABCDEF" "aBCDEF" "abCDEF" "abcDEF" "abcdEF" "abcdeF" "abcdef") + "abcdef") + +(deftest string-upcase.10 + (let ((s "abcde")) + (values + (loop for i from 0 to 4 + collect (loop for j from i to 5 + collect (string-upcase s :start i :end j))) + s)) + (("abcde" "Abcde" "ABcde" "ABCde" "ABCDe" "ABCDE") + ("abcde" "aBcde" "aBCde" "aBCDe" "aBCDE") + ("abcde" "abCde" "abCDe" "abCDE") + ("abcde" "abcDe" "abcDE") + ("abcde" "abcdE")) + "abcde") + +(deftest string-upcase.order.1 + (let ((i 0) a b c (s (copy-seq "abcdef"))) + (values + (string-upcase + (progn (setf a (incf i)) s) + :start (progn (setf b (incf i)) 1) + :end (progn (setf c (incf i)) 4)) + i a b c)) + "aBCDef" 3 1 2 3) + +(deftest string-upcase.order.2 + (let ((i 0) a b c (s (copy-seq "abcdef"))) + (values + (string-upcase + (progn (setf a (incf i)) s) + :end (progn (setf b (incf i)) 4) + :start (progn (setf c (incf i)) 1)) + i a b c)) + "aBCDef" 3 1 2 3) + + +;;; Error cases + +(deftest string-upcase.error.1 + (classify-error (string-upcase)) + program-error) + +(deftest string-upcase.error.2 + (classify-error (string-upcase (copy-seq "abc") :bad t)) + program-error) + +(deftest string-upcase.error.3 + (classify-error (string-upcase (copy-seq "abc") :start)) + program-error) + +(deftest string-upcase.error.4 + (classify-error (string-upcase (copy-seq "abc") :bad t + :allow-other-keys nil)) + program-error) + +(deftest string-upcase.error.5 + (classify-error (string-upcase (copy-seq "abc") :end)) + program-error) + +(deftest string-upcase.error.6 + (classify-error (string-upcase (copy-seq "abc") 1 2)) + program-error) diff --git a/ansi-tests/string.lsp b/ansi-tests/string.lsp new file mode 100644 index 0000000..6752ddb --- /dev/null +++ b/ansi-tests/string.lsp @@ -0,0 +1,202 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Mon Sep 30 19:16:59 2002 +;;;; Contains: Tests for string related functions and classes + +(in-package :cl-test) + +(deftest string.1 + (subtypep* 'string 'array) + t t) + +(deftest string.2 + (subtypep* 'string 'vector) + t t) + +(deftest string.3 + (subtypep* 'string 'sequence) + t t) + +(deftest string.4 + (let ((s (string #\a))) + (values (notnot (stringp s)) s)) + t "a") + +(deftest string.5 + (let ((s (string ""))) + (values (notnot (stringp s)) s)) + t "") + +(deftest string.6 + (let ((s (string '|FOO|))) + (values (notnot (stringp s)) s)) + t "FOO") + +(deftest string.7 + (loop for x in *universe* + always (handler-case (stringp (string x)) + (type-error () :caught))) + t) + +;;; Tests of base-string + +(deftest base-string.1 + (subtypep* 'base-string 'string) + t t) + +(deftest base-string.2 + (subtypep* 'base-string 'vector) + t t) + +(deftest base-string.3 + (subtypep* 'base-string 'array) + t t) + +(deftest base-string.4 + (subtypep* 'base-string 'sequence) + t t) + +;;; Tests of simple-string + +(deftest simple-string.1 + (subtypep* 'simple-string 'string) + t t) + +(deftest simple-string.2 + (subtypep* 'simple-string 'vector) + t t) + +(deftest simple-string.3 + (subtypep* 'simple-string 'simple-array) + t t) + +(deftest simple-string.4 + (subtypep* 'simple-string 'array) + t t) + +(deftest simple-string.5 + (subtypep* 'simple-string 'sequence) + t t) + +;;; Tests for simple-base-string + +(deftest simple-base-string.1 + (subtypep* 'simple-base-string 'string) + t t) + +(deftest simple-base-string.2 + (subtypep* 'simple-base-string 'vector) + t t) + +(deftest simple-base-string.3 + (subtypep* 'simple-base-string 'simple-array) + t t) + +(deftest simple-base-string.4 + (subtypep* 'simple-base-string 'array) + t t) + +(deftest simple-base-string.5 + (subtypep* 'simple-base-string 'sequence) + t t) + +(deftest simple-base-string.6 + (subtypep* 'simple-base-string 'base-string) + t t) + +(deftest simple-base-string.7 + (subtypep* 'simple-base-string 'simple-string) + t t) + +(deftest simple-base-string.8 + (subtypep* 'simple-base-string 'simple-vector) + nil t) + +;;; Tests for simple-string-p + +(deftest simple-string-p.1 + (loop for x in *universe* + always (if (typep x 'simple-string) + (simple-string-p x) + (not (simple-string-p x)))) + t) + +(deftest simple-string-p.2 + (notnot (simple-string-p "ancd")) + t) + +(deftest simple-string-p.3 + (simple-string-p 0) + nil) + +(deftest simple-string-p.4 + (simple-string-p (make-array 4 :element-type 'character + :initial-contents '(#\a #\a #\a #\b) + :fill-pointer t)) + nil) + +(deftest simple-string-p.5 + (notnot (simple-string-p (make-array + 4 :element-type 'base-char + :initial-contents '(#\a #\a #\a #\b)))) + t) + +(deftest simple-string-p.6 + (notnot (simple-string-p (make-array + 4 :element-type 'standard-char + :initial-contents '(#\a #\a #\a #\b)))) + t) + +(deftest simple-string-p.7 + (let* ((s (make-array 10 :element-type 'character + :initial-element #\a)) + (s2 (make-array 4 :element-type 'character + :displaced-to s + :displaced-index-offset 2))) + (simple-string-p s2)) + nil) + +;;; Tests of stringp + +(deftest stringp.1 + (loop for x in *universe* + always (if (typep x 'string) + (stringp x) + (not (stringp x)))) + t) + +(deftest stringp.2 + (notnot (stringp "abcd")) + t) + +(deftest stringp.3 + (notnot (stringp (make-array 4 :element-type 'character + :initial-contents '(#\a #\b #\c #\d)))) + t) + +(deftest stringp.4 + (notnot (stringp (make-array 4 :element-type 'base-char + :initial-contents '(#\a #\b #\c #\d)))) + t) + +(deftest stringp.5 + (notnot (stringp (make-array 4 :element-type 'standard-char + :initial-contents '(#\a #\b #\c #\d)))) + t) + +(deftest stringp.6 + (stringp 0) + nil) + +(deftest stringp.7 + (stringp #\a) + nil) + +(deftest stringp.8 + (let* ((s (make-array 10 :element-type 'character + :initial-element #\a)) + (s2 (make-array 4 :element-type 'character + :displaced-to s + :displaced-index-offset 2))) + (notnot (stringp s2))) + t) diff --git a/ansi-tests/structure-00.lsp b/ansi-tests/structure-00.lsp new file mode 100644 index 0000000..d1b00e3 --- /dev/null +++ b/ansi-tests/structure-00.lsp @@ -0,0 +1,552 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat May 9 11:21:25 1998 +;;;; Contains: Common code for creating structure tests + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +(defun make-struct-test-name (structure-name n) + ;; (declare (type (or string symbol character) structure-name) + ;; (type fixnum n)) + (assert (typep structure-name '(or string symbol character))) + ;; (assert (typep n 'fixnum)) + (setf structure-name (string structure-name)) + (intern (concatenate 'string + structure-name + "/" + (princ-to-string n)))) + +(defun make-struct-p-fn (structure-name) + (assert (typep structure-name '(or string symbol character))) + (setf structure-name (string structure-name)) + (intern (concatenate 'string + structure-name + (string '#:-p)))) + +(defun make-struct-copy-fn (structure-name) + (assert (typep structure-name '(or string symbol character))) + (setf structure-name (string structure-name)) + (intern (concatenate 'string + (string '#:copy-) + structure-name))) + +(defun make-struct-field-fn (conc-name field-name) + "Make field accessor for a field in a structure" + (cond + ((null conc-name) field-name) + (t + (assert (typep conc-name '(or string symbol character))) + (assert (typep field-name '(or string symbol character))) + (setf conc-name (string conc-name)) + (setf field-name (string field-name)) + (intern (concatenate 'string conc-name field-name))))) + +(defun make-struct-make-fn (structure-name) + "Make the make- function for a structure" + (assert (typep structure-name '(or string symbol character))) + (setf structure-name (string structure-name)) + (intern (concatenate 'string + (string '#:make-) structure-name))) + +(defun create-instance-of-type (type) + "Return an instance of a type. Signal an error if + it can't figure out a value for the type." + (cond + ((eqt type t) ;; anything + 'a) + ((eqt type 'symbol) + 'b) + ((eqt type 'null) nil) + ((eqt type 'boolean) t) + ((eqt type 'keyword) :foo) + ((eqt type nil) (error "Cannot obtain element of type ~S~%" type)) + ((eqt type 'cons) (cons 'a 'b)) + ((eqt type 'list) (list 1 2 3)) + ((eqt type 'fixnum) 17) + ((eqt type 'bignum) + (let ((x 1)) + (loop until (typep x 'bignum) + do (setq x (* 2 x))) + x)) + ((and (symbolp type) + (typep type 'structure-class)) + (let ((make-fn + (intern (concatenate 'string (string '#:make-) (symbol-name type)) + (symbol-package type)))) + (eval (list make-fn)))) + ((eqt type 'character) #\w) + ((eqt type 'base-char) #\z) + ((member type '(integer unsigned-byte signed-byte)) 35) + ((eqt type 'bit) 1) + ((and (consp type) + (consp (cdr type)) + (consp (cddr type)) + (null (cdddr type)) + (eqt (car type) 'integer) + (integerp (second type))) + (second type)) + ((member type '(float single-float long-float double-float short-float)) + 0.0) + ((and (consp type) + (eqt (car type) 'member) + (consp (cdr type))) + (second type)) + ((and (consp type) + (eqt (car type) 'or) + (consp (second type))) + (create-instance-of-type (second type))) + (t (error "Cannot generate element for type ~S~%" type)))) + +(defun find-option (option-list option &optional default) + (loop for opt in option-list + when (or (eq opt option) + (and (consp opt) + (eq (car opt) option))) + return opt + finally (return default))) + +(defvar *defstruct-with-tests-names* nil + "Names of structure types defined with DEFSRUCT-WITH-TESTS.") + +#| +(defvar *subtypep-works-with-classes* t + "Becomes NIL if SUBTYPEP doesn't work with classes. We test this first to avoid + repeated test failures that cause GCL to bomb.") + +(deftest subtypep-works-with-classes + (let ((c1 (find-class 'vector))) + ;; (setq *subtypep-works-with-classes* nil) + (subtypep c1 'vector) + (subtypep 'vector c1) + ;; (setq *subtypep-works-with-classes* t)) + t) + +(defvar *typep-works-with-classes* t + "Becomes NIL if TYPEP doesn't work with classes. We test this first to avoid + repeated test failures that cause GCL to bomb.") + +(deftest typep-works-with-classes + (let ((c1 (find-class 'vector))) + ;; (setq *typep-works-with-classes* nil) + (typep #(0 0) c1) + ;; (setq *typep-works-with-classes* t)) + t) +|# + +;; +;; There are a number of standardized tests for +;; structures. The following macro generates the +;; structure definition and the tests. +;; + +(defmacro defstruct-with-tests + (name-and-options &body slot-descriptions-and-documentation) +"Construct standardized tests for a defstruct, and also +do the defstruct." + (defstruct-with-tests-fun name-and-options + slot-descriptions-and-documentation)) + +(defun defstruct-with-tests-fun (name-and-options + slot-descriptions-and-documentation) + ;; Function called from macro defstruct-with-tests + (let* ( + ;; Either NIL or the documentation string for the structure + (doc-string + (when (and (consp slot-descriptions-and-documentation) + (stringp (car slot-descriptions-and-documentation))) + (car slot-descriptions-and-documentation))) + + ;; The list of slot descriptions that follows either the + ;; name and options or the doc string + (slot-descriptions + (if doc-string (cdr slot-descriptions-and-documentation) + slot-descriptions-and-documentation)) + + ;; The name of the structure (should be a symbol) + (name (if (consp name-and-options) + (car name-and-options) + name-and-options)) + + ;; The options list, or NIL if there were no options + (options (if (consp name-and-options) + (cdr name-and-options) + nil)) + + ;; List of symbols that are the names of the slots + (slot-names + (loop + for x in slot-descriptions collect + (if (consp x) (car x) x))) + + ;; List of slot types, if any + (slot-types + (loop + for x in slot-descriptions collect + (if (consp x) + (getf (cddr x) :type :none) + :none))) + + ;; read-only flags for slots + (slot-read-only + (loop + for x in slot-descriptions collect + (and (consp x) + (getf (cddr x) :read-only)))) + + ;; Symbol obtained by prepending MAKE- to the name symbol + (make-fn (make-struct-make-fn name)) + + ;; The type option, if specified + (type-option (find-option options :type)) + (struct-type (second type-option)) + + (named-option (find-option options :named)) + (include-option (find-option options :include)) + + ;; The :predicate option entry from OPTIONS, or NIL if none + (predicate-option (find-option options :predicate)) + + ;; The name of the -P function, either the default or the + ;; one specified in the :predicate option + (p-fn-default (make-struct-p-fn name)) + (p-fn (cond + ((and type-option (not named-option)) nil) + ((or (eq predicate-option :predicate) + (null (cdr predicate-option))) + p-fn-default) + ((cadr predicate-option) (cadr predicate-option)) + (t nil))) + + ;; The :copier option, or NIL if no such option specified + (copier-option (find-option options :copier)) + ;; The name of the copier function, either the default or + ;; one speciefied in the :copier option + (copy-fn-default (make-struct-copy-fn name)) + (copy-fn (cond + ((or (eq copier-option :copier) + (null (cdr copier-option))) + copy-fn-default) + ((cadr copier-option) (cadr copier-option)) + (t nil))) + + ;; The :conc-name option, or NIL if none specified + (conc-option (find-option options :conc-name)) + ;; String to be prepended to slot names to get the + ;; slot accessor function + (conc-prefix-default (concatenate 'string (string name) "-")) + (conc-prefix (cond + ((null conc-option) + conc-prefix-default) + ((or (eq conc-option :conc-name) + (null (cadr conc-option))) + nil) + (t (string (cadr conc-option))))) + + (initial-offset-option (find-option options :initial-offset)) + (initial-offset (second initial-offset-option)) + + ;; Accessor names + (field-fns + (loop for slot-name in slot-names + collect (make-struct-field-fn conc-prefix slot-name))) + + ;; a list of initial values + (initial-value-alist + (loop + for slot-desc in slot-descriptions + for slot-name in slot-names + for type in slot-types + for i from 1 + collect (if (not (eq type :none)) + (cons slot-name (create-instance-of-type type)) + (cons slot-name (defstruct-maketemp name "SLOTTEMP" i))))) + ) + ;; Build the tests in an eval-when form + `(eval-when (compile load eval) + + (ignore-errors + (eval '(defstruct ,name-and-options + ,@slot-descriptions-and-documentation)) + ,(unless (or type-option include-option) + `(pushnew ',name *defstruct-with-tests-names*)) + nil) + + ;; Test that structure is of the correct type + (deftest ,(make-struct-test-name name 1) + (and (fboundp (quote ,make-fn)) + (functionp (function ,make-fn)) + (symbol-function (quote ,make-fn)) + (typep (,make-fn) (quote ,(if type-option struct-type + name))) + t) + t) + + ;; Test that the predicate exists + ,@(when p-fn + `((deftest ,(make-struct-test-name name 2) + (let ((s (,make-fn))) + (and (fboundp (quote ,p-fn)) + (functionp (function ,p-fn)) + (symbol-function (quote ,p-fn)) + (notnot (funcall #',p-fn s)) + (notnot-mv (,p-fn s)) + )) + t) + (deftest ,(make-struct-test-name name "ERROR.1") + (classify-error (,p-fn)) + program-error) + (deftest ,(make-struct-test-name name "ERROR.2") + (classify-error (,p-fn (,make-fn) nil)) + program-error) + )) + + ;; Test that the elements of *universe* are not + ;; of this type + ,@(when p-fn + `((deftest ,(make-struct-test-name name 3) + (count-if (function ,p-fn) *universe*) + 0))) + ,@(unless type-option + `((deftest ,(make-struct-test-name name 4) + (count-if (function (lambda (x) (typep x (quote ,name)))) + *universe*) + 0))) + + ;; Check that the fields can be read after being initialized + (deftest ,(make-struct-test-name name 5) + ,(let ((inits nil) + (tests nil) + (var (defstruct-maketemp name "TEMP-5"))) + (loop + for (slot-name . initval) in initial-value-alist + for field-fn in field-fns + do + (setf inits + (list* (intern (string slot-name) "KEYWORD") + (list 'quote initval) + inits)) + (push `(and + (eqlt (quote ,initval) + (,field-fn ,var)) + (eqlt (quote ,initval) + (funcall #',field-fn ,var))) + tests)) + `(let ((,var (,make-fn . ,inits))) + (and ,@tests t))) + t) + + (deftest ,(make-struct-test-name name "ERROR.3") + (remove nil + (list + ,@(loop + for (slot-name . initval) in initial-value-alist + for field-fn in field-fns + collect + `(let ((x (classify-error (,field-fn)))) + (unless (eqt x 'program-error) + (list ',slot-name ',field-fn x)))))) + nil) + + (deftest ,(make-struct-test-name name "ERROR.4") + (remove nil + (list + ,@(loop + for (slot-name . initval) in initial-value-alist + for field-fn in field-fns + collect + `(let ((x (classify-error (,field-fn (,make-fn) nil)))) + (unless (eqt x 'program-error) + (list ',slot-name ',field-fn x)))))) + nil) + + ;; Check that two invocations return different structures + (deftest ,(make-struct-test-name name 6) + (eqt (,make-fn) (,make-fn)) + nil) + + ;; Check that we can setf the fields + (deftest ,(make-struct-test-name name 7) + ,(let* ((var (defstruct-maketemp name "TEMP-7-1")) + (var2 (defstruct-maketemp name "TEMP-7-2")) + (tests + (loop + for (slot-name . initval) in initial-value-alist + for read-only-p in slot-read-only + for slot-desc in slot-descriptions + for field-fn in field-fns + unless read-only-p + collect + `(let ((,var2 (quote ,initval))) + (setf (,field-fn ,var) ,var2) + (eqlt (,field-fn ,var) ,var2))))) + `(let ((,var (,make-fn))) + (and ,@tests t))) + t) + + ;; Check that the copy function exists + ,@(when copy-fn + `((deftest ,(make-struct-test-name name 8) + (and (fboundp (quote ,copy-fn)) + (functionp (function ,copy-fn)) + (symbol-function (quote ,copy-fn)) + t) + t) + (deftest ,(make-struct-test-name name "ERROR.5") + (classify-error (,copy-fn)) + program-error) + (deftest ,(make-struct-test-name name "ERROR.6") + (classify-error (,copy-fn (,make-fn) nil)) + program-error) + )) + + ;; Check that the copy function properly copies fields + ,@(when copy-fn + `((deftest ,(make-struct-test-name name 9) + ,(let* ((var 'XTEMP-9) + (var2 'YTEMP-9) + (var3 'ZTEMP-9)) + `(let ((,var (,make-fn + ,@(loop + for (slot-name . initval) + in initial-value-alist + nconc (list (intern (string slot-name) + "KEYWORD") + `(quote ,initval)))))) + (let ((,var2 (,copy-fn ,var)) + (,var3 (funcall #',copy-fn ,var))) + (and + (not (eqlt ,var ,var2)) + (not (eqlt ,var ,var3)) + (not (eqlt ,var2 ,var3)) + ,@(loop + for (slot-name . nil) in initial-value-alist + for fn in field-fns + collect + `(and (eqlt (,fn ,var) (,fn ,var2)) + (eqlt (,fn ,var) (,fn ,var3)))) + t)))) + t))) + + ;; When the predicate is not the default, check + ;; that the default is not defined. Tests should + ;; be designed so that this function name doesn't + ;; collide with anything else. + ,@(unless (eq p-fn p-fn-default) + `((deftest ,(make-struct-test-name name 10) + (fboundp (quote ,p-fn-default)) + nil))) + + ;; When the copy function name is not the default, check + ;; that the default function is not defined. Tests should + ;; be designed so that this name is not accidently defined + ;; for something else. + ,@(unless (eq copy-fn copy-fn-default) + `((deftest ,(make-struct-test-name name 11) + (fboundp (quote ,copy-fn-default)) + nil))) + + ;; When there are read-only slots, test that the SETF + ;; form for them is not FBOUNDP + ,@(when (loop for x in slot-read-only thereis x) + `((deftest ,(make-struct-test-name name 12) + (and + ,@(loop for slot-name in slot-names + for read-only in slot-read-only + for field-fn in field-fns + when read-only + collect `(not-mv (fboundp '(setf ,field-fn)))) + t) + t))) + + ;; When the structure is a true structure type, check that + ;; the various class relationships hold + ,@(unless type-option + `( + (deftest ,(make-struct-test-name name 13) + (notnot-mv (typep (,make-fn) (find-class (quote ,name)))) + t) + (deftest ,(make-struct-test-name name 14) + (let ((class (find-class (quote ,name)))) + (notnot-mv (typep class 'structure-class))) + t) + (deftest ,(make-struct-test-name name 15) + (notnot-mv (typep (,make-fn) 'structure-object)) + t) + (deftest ,(make-struct-test-name name 16) + (loop for type in *disjoint-types-list* + unless (and + (equalt (multiple-value-list + (subtypep* type (quote ,name))) + '(nil t)) + (equalt (multiple-value-list + (subtypep* (quote ,name) type)) + '(nil t))) + collect type) + nil) + (deftest ,(make-struct-test-name name 17) + (let ((class (find-class (quote ,name)))) + (loop for type in *disjoint-types-list* + unless (and + (equalt (multiple-value-list + (subtypep* type class)) + '(nil t)) + (equalt (multiple-value-list + (subtypep* class type)) + '(nil t))) + collect type)) + nil) + (deftest ,(make-struct-test-name name "15A") + (let ((class (find-class (quote ,name)))) + (notnot-mv (subtypep class 'structure-object))) + t t) + (deftest ,(make-struct-test-name name "15B") + (notnot-mv (subtypep (quote ,name) 'structure-object)) + t t) + + )) + + ;;; Documentation tests + + ,(when doc-string + `(deftest ,(make-struct-test-name name 18) + (let ((doc (documentation ',name 'structure))) + (or (null doc) (equalt doc ',doc-string))) + t)) + + ,(when (and doc-string (not type-option)) + `(deftest ,(make-struct-test-name name 19) + (let ((doc (documentation ',name 'type))) + (or (null doc) (equalt doc ',doc-string))) + t)) + + ;; Test that COPY-STRUCTURE works, if this is a structure + ;; type + ,@(unless type-option + `((deftest ,(make-struct-test-name name 20) + ,(let* ((var 'XTEMP-20) + (var2 'YTEMP-20)) + `(let ((,var (,make-fn + ,@(loop + for (slot-name . initval) + in initial-value-alist + nconc (list (intern (string slot-name) + "KEYWORD") + `(quote ,initval)))))) + (let ((,var2 (copy-structure ,var))) + (and + (not (eqlt ,var ,var2)) + ,@(loop + for (slot-name . nil) in initial-value-alist + for fn in field-fns + collect + `(eqlt (,fn ,var) (,fn ,var2))) + t)))) + t))) + nil + ))) + +(defun defstruct-maketemp (stem suffix1 &optional suffix2) + "Make a temporary variable for DEFSTRUCT-WITH-TESTS." + (intern (if suffix2 (format nil "~A-~A-~A" stem suffix1 suffix2) + (format nil "~A-~A" stem suffix1)))) diff --git a/ansi-tests/structures-01.lsp b/ansi-tests/structures-01.lsp new file mode 100644 index 0000000..022adff --- /dev/null +++ b/ansi-tests/structures-01.lsp @@ -0,0 +1,103 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat May 2 21:45:32 1998 +;;;; Contains: Test code for structures, part 01 + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +;;; Tests for structures +;;; +;;; The CL Spec leaves undefined just what will happen when a structure is +;;; redefined. These tests don't redefine structures, but reloading a file +;;; with structure definition will do so. I assume that this leaves the +;;; structure type unchanged. + +;; Test simple defstruct (fields, no options) + +(defstruct s-1 + foo bar) + +;; Test that make-s-1 produces objects +;; of the correct type +(deftest structure-1-1 + (notnot-mv (typep (make-s-1) 's-1)) + t) + +;; Test that the -p predicate exists +(deftest structure-1-2 + (notnot-mv (s-1-p (make-s-1))) + t) + +;; Test that all the objects in the universe are +;; not of this type +(deftest structure-1-3 + (count-if #'s-1-p *universe*) + 0) + +(deftest structure-1-4 + (count-if #'(lambda (x) (typep x 's-1)) *universe*) + 0) + +;; Check that the fields can be read after being initialized +(deftest structure-1-5 + (s-1-foo (make-s-1 :foo 'a)) + a) + +(deftest structure-1-6 + (s-1-bar (make-s-1 :bar 'b)) + b) + +(deftest structure-1-7 + (let ((s (make-s-1 :foo 'c :bar 'd))) + (list (s-1-foo s) (s-1-bar s))) + (c d)) + +;; Can setf the fields +(deftest structure-1-8 + (let ((s (make-s-1))) + (setf (s-1-foo s) 'e) + (setf (s-1-bar s) 'f) + (list (s-1-foo s) (s-1-bar s))) + (e f)) + +(deftest structure-1-9 + (let ((s (make-s-1 :foo 'a :bar 'b))) + (setf (s-1-foo s) 'e) + (setf (s-1-bar s) 'f) + (list (s-1-foo s) (s-1-bar s))) + (e f)) + +;; copier function defined +(deftest structure-1-10 + (let ((s (make-s-1 :foo 'a :bar 'b))) + (let ((s2 (copy-s-1 s))) + (setf (s-1-foo s) nil) + (setf (s-1-bar s) nil) + (list (s-1-foo s2) + (s-1-bar s2)))) + (a b)) + +;; Make produces unique items +(deftest structure-1-11 + (eqt (make-s-1) (make-s-1)) + nil) + +(deftest structure-1-12 + (eqt (make-s-1 :foo 'a :bar 'b) + (make-s-1 :foo 'a :bar 'b)) + nil) + +;; More type and class checks + +(deftest structure-1-13 + (notnot-mv (typep (class-of (make-s-1)) 'structure-class)) + t) + +(deftest structure-1-14 + (notnot-mv (typep (make-s-1) 'structure-object)) + t) + +(deftest structure-1-15 + (subtypep* 's-1 'structure-object) + t t) diff --git a/ansi-tests/structures-02.lsp b/ansi-tests/structures-02.lsp new file mode 100644 index 0000000..357d0f2 --- /dev/null +++ b/ansi-tests/structures-02.lsp @@ -0,0 +1,420 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun May 3 22:46:54 1998 +;;;; Contains: Test code for structures, part 02 + +(in-package :cl-test) +(declaim (optimize (safety 3))) + +;; Test initializers for fields + +(defvar *s-2-f6-counter* 0) + +(defstruct s-2 + (f1 0) + (f2 'a) + (f3 1.21) + (f4 #\d) + (f5 (list 'a 'b)) + (f6 (incf *s-2-f6-counter*))) + +;; Standard structure tests + + +;; Fields have appropriate values +(deftest structure-2-1 + (let ((*s-2-f6-counter* 0)) + (let ((s (make-s-2))) + (and + (eqlt (s-2-f1 s) 0) + (eqt (s-2-f2 s) 'a) + (= (s-2-f3 s) 1.21) + (eqlt (s-2-f4 s) #\d) + (equalt (s-2-f5 s) '(a b)) + (eqlt (s-2-f6 s) *s-2-f6-counter*) + (eqlt *s-2-f6-counter* 1)))) + t) + +;; Two successive invocations of make-s-2 return different objects +(deftest structure-2-2 + (let ((*s-2-f6-counter* 0)) + (eqt (s-2-f5 (make-s-2)) + (s-2-f5 (make-s-2)))) + nil) + +;; Creation with various fields does the right thing +(deftest structure-2-3 + (let* ((*s-2-f6-counter* 0) + (s (make-s-2 :f1 17))) + (and + (eqlt (s-2-f1 s) 17) + (eqt (s-2-f2 s) 'a) + (= (s-2-f3 s) 1.21) + (eqlt (s-2-f4 s) #\d) + (equalt (s-2-f5 s) '(a b)) + (eqlt (s-2-f6 s) *s-2-f6-counter*) + (eqlt *s-2-f6-counter* 1))) + t) + +(deftest structure-2-4 + (let* ((*s-2-f6-counter* 0) + (s (make-s-2 :f2 'z))) + (and + (eqlt (s-2-f1 s) 0) + (eqt (s-2-f2 s) 'z) + (= (s-2-f3 s) 1.21) + (eqlt (s-2-f4 s) #\d) + (equalt (s-2-f5 s) '(a b)) + (eqlt (s-2-f6 s) *s-2-f6-counter*) + (eqlt *s-2-f6-counter* 1))) + t) + +(deftest structure-2-5 + (let* ((*s-2-f6-counter* 0) + (s (make-s-2 :f3 1.0))) + (and + (eqlt (s-2-f1 s) 0) + (eqt (s-2-f2 s) 'a) + (= (s-2-f3 s) 1.0) + (eqlt (s-2-f4 s) #\d) + (equalt (s-2-f5 s) '(a b)) + (eqlt (s-2-f6 s) *s-2-f6-counter*) + (eqlt *s-2-f6-counter* 1))) + t) + +(deftest structure-2-6 + (let* ((*s-2-f6-counter* 0) + (s (make-s-2 :f4 #\z))) + (and + (eqlt (s-2-f1 s) 0) + (eqt (s-2-f2 s) 'a) + (= (s-2-f3 s) 1.21) + (eqlt (s-2-f4 s) #\z) + (equalt (s-2-f5 s) '(a b)) + (eqlt (s-2-f6 s) *s-2-f6-counter*) + (eqlt *s-2-f6-counter* 1))) + t) + +(deftest structure-2-7 + (let* ((*s-2-f6-counter* 0) + (s (make-s-2 :f5 '(c d e)))) + (and + (eqlt (s-2-f1 s) 0) + (eqt (s-2-f2 s) 'a) + (= (s-2-f3 s) 1.21) + (eqlt (s-2-f4 s) #\d) + (equalt (s-2-f5 s) '(c d e)) + (eqlt (s-2-f6 s) *s-2-f6-counter*) + (eqlt *s-2-f6-counter* 1))) + t) + +(deftest structure-2-8 + (let* ((*s-2-f6-counter* 0) + (s (make-s-2 :f6 10))) + (and + (eqlt (s-2-f1 s) 0) + (eqt (s-2-f2 s) 'a) + (= (s-2-f3 s) 1.21) + (eqlt (s-2-f4 s) #\d) + (equalt (s-2-f5 s) '(a b)) + (eqlt (s-2-f6 s) 10) + (eqlt *s-2-f6-counter* 0))) + t) + +;;; Tests using the defstruct-with-tests infrastructure + +(defstruct-with-tests struct-test-03 a b c d) + +(defstruct-with-tests (struct-test-04) a b c) + +(defstruct-with-tests (struct-test-05 :constructor) a05 b05 c05) +(defstruct-with-tests (struct-test-06 (:constructor)) a06 b06 c06) + +(defstruct-with-tests (struct-test-07 :conc-name) a07 b07) +(defstruct-with-tests (struct-test-08 (:conc-name)) a08 b08) +(defstruct-with-tests (struct-test-09 (:conc-name nil)) a09 b09) +(defstruct-with-tests (struct-test-10 (:conc-name "")) a10 b10) +(defstruct-with-tests (struct-test-11 (:conc-name "BLAH-")) a11 b11) +(defstruct-with-tests (struct-test-12 (:conc-name BLAH-)) a12 b12) +(defstruct-with-tests (struct-test-13 (:conc-name #\X)) foo-a13 foo-b13) + +(defstruct-with-tests (struct-test-14 (:predicate)) a14 b14) +(defstruct-with-tests (struct-test-15 (:predicate nil)) a15 b15) +(defstruct-with-tests (struct-test-16 :predicate) a16 b16) +(defstruct-with-tests (struct-test-17 + (:predicate struct-test-17-alternate-pred)) + a17 b17) + +(defstruct-with-tests (struct-test-18 :copier) a18 b18) +(defstruct-with-tests (struct-test-19 (:copier)) a19 b19) +(defstruct-with-tests (struct-test-20 (:copier nil)) a20 b20) +(defstruct-with-tests (struct-test-21 (:copier struct-test-21-alt-copier)) + a21 b21) + +(defstruct-with-tests struct-test-22 (a22) (b22)) +(defstruct-with-tests struct-test-23 (a23 1) (b23 2)) +(defstruct-with-tests struct-test-24 + (a24 1 :type fixnum) + (b24 2 :type integer)) + +(defstruct-with-tests struct-test-25) +(defstruct-with-tests struct-test-26 + (a26 nil :read-only nil) + (b26 'a :read-only nil)) + +(defstruct-with-tests struct-test-27 + (a27 1 :read-only t) + (b27 1.4 :read-only a)) + +(defstruct-with-tests struct-test-28 + (a28 1 :type integer :read-only t) + (b28 'xx :read-only a :type symbol)) + +(defstruct-with-tests struct-test-29 + a29 + (b29 'xx :read-only 1) + c29) + +(defstruct-with-tests struct-test-30 #:a30 #:b30) +(defstruct-with-tests #:struct-test-31 a31 b31) + +(defpackage struct-test-package (:use)) + +(defstruct-with-tests struct-test-32 + struct-test-package::a32 struct-test-package::b32) + +;;; If the :conc-name option is given no argument or +;;; a nil argument, the accessor names are the same as +;;; slot names. Note that this is different from prepending +;;; an empty string, since that may get you a name in +;;; a different package. + +(defstruct-with-tests (struct-test-33 (:conc-name)) + struct-test-package::a33 struct-test-package::b33) +(defstruct-with-tests (struct-test-34 :conc-name) + struct-test-package::a34 struct-test-package::b34) +(defstruct-with-tests (struct-test-35 (:conc-name nil)) + struct-test-package::a35 struct-test-package::b35) + +(defstruct-with-tests (struct-test-36 (:conc-name "")) + struct-test-package::st36-a36 struct-test-package::st26-b36) + +;;; List and vector structures + +(defstruct-with-tests (struct-test-37 (:type list)) a37 b37 c37) + +(deftest structure-37-1 + (make-struct-test-37 :a37 1 :b37 2 :c37 4) + (1 2 4)) + +(defstruct-with-tests (struct-test-38 (:type list) :named) a38 b38 c38) + +(deftest structure-38-1 + (make-struct-test-38 :a38 11 :b38 12 :c38 4) + (struct-test-38 11 12 4)) + +(defstruct-with-tests (struct-test-39 (:predicate nil) + (:type list) :named) + a39 b39 c39) + +(deftest structure-39-1 + (make-struct-test-39 :a39 11 :b39 12 :c39 4) + (struct-test-39 11 12 4)) + +(defstruct-with-tests (struct-test-40 (:type vector)) a40 b40) +(defstruct-with-tests (struct-test-41 (:type vector) :named) a41 b41) +(defstruct-with-tests (struct-test-42 (:type (vector t))) a42 b42) +(defstruct-with-tests (struct-test-43 (:type (vector t)) :named) a43 b43) + +(defstruct-with-tests (struct-test-44 (:type list)) + (a44 0 :type integer) + (b44 'a :type symbol)) + +;;; Confirm that the defined structure types are all disjoint +(deftest structs-are-disjoint + (loop for s1 in *defstruct-with-tests-names* + sum (loop for s2 in *defstruct-with-tests-names* + unless (eq s1 s2) + count (not (equalt (multiple-value-list + (subtypep* s1 s2)) + '(nil t))))) + 0) + +(defstruct-with-tests (struct-test-45 (:type list) (:initial-offset 2)) + a45 b45) + +(deftest structure-45-1 + (cddr (make-struct-test-45 :a45 1 :b45 2)) + (1 2)) + +(defstruct-with-tests (struct-test-46 (:type list) + (:include struct-test-45)) + c46 d46) + +(deftest structure-46-1 + (cddr (make-struct-test-46 :a45 1 :b45 2 :c46 3 :d46 4)) + (1 2 3 4)) + +(defstruct-with-tests (struct-test-47 (:type list) + (:initial-offset 3) + (:include struct-test-45)) + c47 d47) + +(deftest structure-47-1 + (let ((s (make-struct-test-47 :a45 1 :b45 2 :c47 3 :d47 4))) + (values (third s) (fourth s) (eighth s) (ninth s))) + 1 2 3 4) + +(defstruct-with-tests (struct-test-48 (:type list) + (:initial-offset 0) + (:include struct-test-45)) + c48 d48) + +(deftest structure-48-1 + (cddr (make-struct-test-48 :a45 1 :b45 2 :c48 3 :d48 4)) + (1 2 3 4)) + +(defstruct-with-tests (struct-test-49 (:type (vector bit))) + (a49 0 :type bit) + (b49 0 :type bit)) + +(defstruct-with-tests (struct-test-50 (:type (vector character))) + (a50 #\g :type character) + (b50 #\k :type character)) + +(defstruct-with-tests (struct-test-51 (:type (vector (integer 0 255)))) + (a51 17 :type (integer 0 255)) + (b51 25 :type (integer 0 255))) + +(defstruct-with-tests (struct-test-52 (:type vector) + (:initial-offset 0)) + a52 b52) + +(defstruct-with-tests (struct-test-53 (:type vector) + (:initial-offset 5)) + "This is struct-test-53" + a53 b53) + +(deftest structure-53-1 + (let ((s (make-struct-test-53 :a53 10 :b53 'a))) + (values (aref s 5) (aref s 6))) + 10 a) + +(defstruct-with-tests (struct-test-54 (:type vector) + (:initial-offset 2) + (:include struct-test-53)) + "This is struct-test-54" + a54 b54) + +(deftest structure-54-1 + (let ((s (make-struct-test-54 :a53 8 :b53 'g :a54 10 :b54 'a))) + (values (aref s 5) (aref s 6) (aref s 9) (aref s 10))) + 8 g 10 a) + +(defstruct-with-tests (struct-test-55 (:type list) + (:initial-offset 2) + :named) + a55 b55 c55) + +(deftest structure-55-1 + (let ((s (make-struct-test-55 :a55 'p :c55 'q))) + (values (third s) (fourth s) (sixth s))) + struct-test-55 p q) + +(defstruct-with-tests (struct-test-56 (:type list) + (:initial-offset 3) + (:include struct-test-55) + :named) + d56 e56) + +(deftest structure-56-1 + (let ((s (make-struct-test-56 :a55 3 :b55 7 :d56 'x :e56 'y))) + (mapcar #'(lambda (i) (nth i s)) '(2 3 4 9 10 11))) + (struct-test-55 3 7 struct-test-56 x y)) + +(defstruct-with-tests (struct-test-57 (:include struct-test-22)) + c57 d57) + +(defstruct-with-tests struct-test-58 + "This is struct-test-58" a-58 b-58) + +(defstruct-with-tests (struct-test-59 (:include struct-test-58)) + "This is struct-test-59" a-59 b-59) + +;;; When a field name of a structure is also a special variable, +;;; the constructor must not bind that name. + +(defvar *st-60* 100) + +(defstruct-with-tests struct-test-60 + (a60 *st-60* :type integer) + (*st-60* 0 :type integer) + (b60 *st-60* :type integer)) + +(deftest structure-60-1 + (let ((*st-60* 10)) + (let ((s (make-struct-test-60 :*st-60* 200))) + (values (struct-test-60-a60 s) + (struct-test-60-*st-60* s) + (struct-test-60-b60 s)))) + 10 200 10) + + +;;; When default initializers of the wrong type are given, they do not +;;; cause an error unless actually invoked + +(defstruct struct-test-61 + (a nil :type integer) + (b 0 :type symbol)) + +(deftest structure-61-1 + (let ((s (make-struct-test-61 :a 10 :b 'c))) + (values (struct-test-61-a s) + (struct-test-61-b s))) + 10 c) + +;;; Initializer forms are evaluated only when needed, and are +;;; evaluated in the lexical environment in which they were defined + +(eval-when (load eval) + (let ((x nil)) + (flet ((%f () x) + (%g (y) (setf x y))) + (defstruct struct-test-62 + (a (progn (setf x 'a) nil)) + (f #'%f) + (g #'%g))))) + +(deftest structure-62-1 + (let* ((s (make-struct-test-62 :a 1)) + (f (struct-test-62-f s))) + (values + (struct-test-62-a s) + (funcall f))) + 1 nil) + +(deftest structure-62-2 + (let* ((s (make-struct-test-62)) + (f (struct-test-62-f s)) + (g (struct-test-62-g s))) + (values + (struct-test-62-a s) + (funcall f) + (funcall g nil) + (funcall f))) + nil a nil nil) + +;;; Keywords are allowed in defstruct +(defstruct-with-tests :struct-test-63 a63 b63 c63) +(defstruct-with-tests struct-test-64 :a63 :b63 :c63) + +;;; Error tests + +(deftest copy-structure.error.1 + (classify-error (copy-structure)) + program-error) + +(deftest copy-structure.error.2 + (classify-error (copy-structure (make-s-2) nil)) + program-error) + diff --git a/ansi-tests/structures-03.lsp b/ansi-tests/structures-03.lsp new file mode 100644 index 0000000..11b9a4e --- /dev/null +++ b/ansi-tests/structures-03.lsp @@ -0,0 +1,417 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Dec 20 05:58:06 2002 +;;;; Contains: BOA Constructor Tests + +(in-package :cl-test) + +(defun sbt-slots (sname s &rest slots) + (loop for slotname in slots collect + (let ((fun (intern (concatenate 'string (string sname) + "-" (string slotname)) + :cl-test))) + (funcall (symbol-function fun) s)))) + +;;; See the DEFSTRUCT page, and section 3.4.6 (Boa Lambda Lists) + +(defstruct* (sbt-01 (:constructor sbt-01-con (b a c))) + a b c) + +(deftest structure-boa-test-01/1 + (let ((s (sbt-01-con 1 2 3))) + (values (sbt-01-a s) + (sbt-01-b s) + (sbt-01-c s))) + 2 1 3) + +(defstruct* (sbt-02 (:constructor sbt-02-con (a b c)) + (:constructor sbt-02-con-2 (a b)) + (:constructor sbt-02-con-3 ())) + (a 'x) (b 'y) (c 'z)) + +(deftest structure-boa-test-02/1 + (let ((s (sbt-02-con 1 2 3))) + (values (sbt-02-a s) + (sbt-02-b s) + (sbt-02-c s))) + 1 2 3) + +(deftest structure-boa-test-02/2 + (let ((s (sbt-02-con-2 'p 'q))) + (values (sbt-02-a s) + (sbt-02-b s) + (sbt-02-c s))) + p q z) + +(deftest structure-boa-test-02/3 + (let ((s (sbt-02-con-3))) + (values (sbt-02-a s) + (sbt-02-b s) + (sbt-02-c s))) + x y z) + +;;; &optional in BOA LL + +(defstruct* (sbt-03 (:constructor sbt-03-con (a b &optional c))) + c b a) + +(deftest structure-boa-test-03/1 + (let ((s (sbt-03-con 1 2))) + (values (sbt-03-a s) (sbt-03-b s))) + 1 2) + +(deftest structure-boa-test-03/2 + (let ((s (sbt-03-con 1 2 3))) + (values (sbt-03-a s) (sbt-03-b s) (sbt-03-c s))) + 1 2 3) + + +(defstruct* (sbt-04 (:constructor sbt-04-con (a b &optional c))) + (c nil) b (a nil)) + +(deftest structure-boa-test-04/1 + (let ((s (sbt-04-con 1 2))) + (values (sbt-04-a s) (sbt-04-b s) (sbt-04-c s))) + 1 2 nil) + +(deftest structure-boa-test-04/2 + (let ((s (sbt-04-con 1 2 4))) + (values (sbt-04-a s) (sbt-04-b s) (sbt-04-c s))) + 1 2 4) + + +(defstruct* (sbt-05 (:constructor sbt-05-con (&optional a b c))) + (c 1) (b 2) (a 3)) + +(deftest structure-boa-test-05/1 + (let ((s (sbt-05-con))) + (values (sbt-05-a s) (sbt-05-b s) (sbt-05-c s))) + 3 2 1) + +(deftest structure-boa-test-05/2 + (let ((s (sbt-05-con 'x))) + (values (sbt-05-a s) (sbt-05-b s) (sbt-05-c s))) + x 2 1) + +(deftest structure-boa-test-05/3 + (let ((s (sbt-05-con 'x 'y))) + (values (sbt-05-a s) (sbt-05-b s) (sbt-05-c s))) + x y 1) + +(deftest structure-boa-test-05/4 + (let ((s (sbt-05-con 'x 'y 'z))) + (values (sbt-05-a s) (sbt-05-b s) (sbt-05-c s))) + x y z) + + +(defstruct* (sbt-06 (:constructor sbt-06-con (&optional (a 'p) (b 'q) (c 'r)))) + (c 1) (b 2) (a 3)) + +(deftest structure-boa-test-06/1 + (let ((s (sbt-06-con))) + (values (sbt-06-a s) (sbt-06-b s) (sbt-06-c s))) + p q r) + +(deftest structure-boa-test-06/2 + (let ((s (sbt-06-con 'x))) + (values (sbt-06-a s) (sbt-06-b s) (sbt-06-c s))) + x q r) + +(deftest structure-boa-test-06/3 + (let ((s (sbt-06-con 'x 'y))) + (values (sbt-06-a s) (sbt-06-b s) (sbt-06-c s))) + x y r) + +(deftest structure-boa-test-06/4 + (let ((s (sbt-06-con 'x 'y 'z))) + (values (sbt-06-a s) (sbt-06-b s) (sbt-06-c s))) + x y z) + + +;;; Test presence flag in optional parameters + +(defstruct* (sbt-07 (:constructor sbt-07-con + (&optional (a 'p a-p) (b 'q b-p) (c 'r c-p) + &aux (d (list (notnot a-p) + (notnot b-p) + (notnot c-p)))))) + a b c d) + +(deftest structure-boa-test-07/1 + (sbt-slots 'sbt-07 (sbt-07-con) :a :b :c :d) + (p q r (nil nil nil))) + +(deftest structure-boa-test-07/2 + (sbt-slots 'sbt-07 (sbt-07-con 'x) :a :b :c :d) + (x q r (t nil nil))) + +(deftest structure-boa-test-07/3 + (sbt-slots 'sbt-07 (sbt-07-con 'x 'y) :a :b :c :d) + (x y r (t t nil))) + +(deftest structure-boa-test-07/4 + (sbt-slots 'sbt-07 (sbt-07-con 'x 'y 'z) :a :b :c :d) + (x y z (t t t))) + + +;;; Keyword arguments + +(defstruct* (sbt-08 (:constructor sbt-08-con + (&key ((:foo a))))) + a) + +(deftest structure-boa-test-08/1 + (sbt-slots 'sbt-08 (sbt-08-con :foo 10) :a) + (10)) + +(defstruct* (sbt-09 (:constructor sbt-09-con + (&key (a 'p a-p) + ((:x b) 'q) + (c 'r) + d + ((:y e)) + ((:z f) 's z-p) + &aux (g (list (notnot a-p) + (notnot z-p)))))) + a b c d e f g) + +(deftest structure-boa-test-09/1 + (sbt-slots 'sbt-09 (sbt-09-con) :a :b :c :f :g) + (p q r s (nil nil))) + +(deftest structure-boa-test-09/2 + (sbt-slots 'sbt-09 (sbt-09-con :d 1) :a :b :c :d :f :g) + (p q r 1 s (nil nil))) + +(deftest structure-boa-test-09/3 + (sbt-slots 'sbt-09 (sbt-09-con :a 1) :a :b :c :f :g) + (1 q r s (t nil))) + +(deftest structure-boa-test-09/4 + (sbt-slots 'sbt-09 (sbt-09-con :x 1) :a :b :c :f :g) + (p 1 r s (nil nil))) + +(deftest structure-boa-test-09/5 + (sbt-slots 'sbt-09 (sbt-09-con :c 1) :a :b :c :f :g) + (p q 1 s (nil nil))) + +(deftest structure-boa-test-09/6 + (sbt-slots 'sbt-09 (sbt-09-con :y 1) :a :b :c :e :f :g) + (p q r 1 s (nil nil))) + +(deftest structure-boa-test-09/7 + (sbt-slots 'sbt-09 (sbt-09-con :z 1) :a :b :c :f :g) + (p q r 1 (nil t))) + +;;; Aux variable overriding a default value + +(defstruct* (sbt-10 (:constructor sbt-10-con (&aux (a 10) + (b (1+ a))))) + (a 1) (b 2)) + +(deftest structure-boa-test-10/1 + (sbt-slots 'sbt-10 (sbt-10-con) :a :b) + (10 11)) + +;;; Aux variables with no value + +(defstruct* (sbt-11 (:constructor sbt-11-con (&aux a b))) + a (b 0 :type integer)) + +(deftest structure-boa-test-11/1 + (let ((s (sbt-11-con))) + (setf (sbt-11-a s) 'p) + (setf (sbt-11-b s) 10) + (sbt-slots 'sbt-11 s :a :b)) + (p 10)) + +;;; Arguments that correspond to no slots + +(defstruct* (sbt-12 (:constructor sbt-12-con (a &optional (b 1) + &rest c + &aux (d (list a b c))))) + d) + +(deftest structure-boa-12/1 + (sbt-12-d (sbt-12-con 'x)) + (x 1 nil)) + +(deftest structure-boa-12/2 + (sbt-12-d (sbt-12-con 'x 'y)) + (x y nil)) + +(deftest structure-boa-12/3 + (sbt-12-d (sbt-12-con 'x 'y 1 2 3)) + (x y (1 2 3))) + + +(defstruct* (sbt-13 (:constructor sbt-13-con + (&key (a 1) (b 2) c &aux (d (list a b c))))) + d) + +(deftest structure-boa-test-13/1 + (sbt-13-d (sbt-13-con)) + (1 2 nil)) + +(deftest structure-boa-test-13/2 + (sbt-13-d (sbt-13-con :a 10)) + (10 2 nil)) + +(deftest structure-boa-test-13/3 + (sbt-13-d (sbt-13-con :b 10)) + (1 10 nil)) + +(deftest structure-boa-test-13/4 + (sbt-13-d (sbt-13-con :c 10)) + (1 2 10)) + +(deftest structure-boa-test-13/5 + (sbt-13-d (sbt-13-con :c 10 :a 3)) + (3 2 10)) + +(deftest structure-boa-test-13/6 + (sbt-13-d (sbt-13-con :c 10 :b 3)) + (1 3 10)) + +(deftest structure-boa-test-13/7 + (sbt-13-d (sbt-13-con :a 10 :b 3)) + (10 3 nil)) + +(deftest structure-boa-test-13/8 + (sbt-13-d (sbt-13-con :a 10 :c 'a :b 3)) + (10 3 a)) + + +;;; Allow other keywords + +(defstruct* (sbt-14 (:constructor sbt-14-con (&key a b c &allow-other-keys))) + (a 1) (b 2) (c 3)) + +(deftest structure-boa-test-14/1 + (sbt-slots 'sbt-14 (sbt-14-con) :a :b :c) + (1 2 3)) + +(deftest structure-boa-test-14/2 + (sbt-slots 'sbt-14 (sbt-14-con :a 9) :a :b :c) + (9 2 3)) + +(deftest structure-boa-test-14/3 + (sbt-slots 'sbt-14 (sbt-14-con :b 9) :a :b :c) + (1 9 3)) + +(deftest structure-boa-test-14/4 + (sbt-slots 'sbt-14 (sbt-14-con :c 9) :a :b :c) + (1 2 9)) + +(deftest structure-boa-test-14/5 + (sbt-slots 'sbt-14 (sbt-14-con :d 9) :a :b :c) + (1 2 3)) + +;;; Keywords are in the correct package, and slot names are not +;;; keyword parameters if not specified. + +(defstruct* (sbt-15 (:constructor sbt-15-con + (&key ((:x a) nil) + ((y b) nil) + (c nil)))) + a b c) + +(deftest structure-boa-test-15/1 + (sbt-slots 'sbt-15 (sbt-15-con :x 1 'y 2 :c 3) :a :b :c) + (1 2 3)) + +(deftest structure-boa-test-15/2 + (classify-error (sbt-15-con :a 1)) + program-error) + +(deftest structure-boa-test-15/3 + (classify-error (sbt-15-con :b 1)) + program-error) + +(deftest structure-boa-test-15/4 + (classify-error (sbt-15-con 'x 1)) + program-error) + +(deftest structure-boa-test-15/5 + (classify-error (sbt-15-con :y 1)) + program-error) + +(deftest structure-boa-test-15/6 + (classify-error (sbt-15-con 'c 1)) + program-error) + +(deftest structure-boa-test-15/7 + (classify-error (sbt-15-con 'a 1)) + program-error) + +(deftest structure-boa-test-15/8 + (classify-error (sbt-15-con 'b 1)) + program-error) + + +;;; Default constructor w. BOA constructor, and error cases + +(defstruct* (sbt-16 (:constructor) + (:constructor sbt-16-con (a b c))) + a b c) + +(deftest structure-boa-test-16/1 + (sbt-slots 'sbt-16 (make-sbt-16 :a 1 :b 2 :c 3) :a :b :c) + (1 2 3)) + +(deftest structure-boa-test-16/2 + (sbt-slots 'sbt-16 (sbt-16-con 4 5 6) :a :b :c) + (4 5 6)) + +(deftest structure-boa-test-16/3 + (classify-error (make-sbt-16 :d 1)) + program-error) + +(deftest structure-boa-test-16/4 + (classify-error (make-sbt-16 :a)) + program-error) + +(deftest structure-boa-test-16/5 + (classify-error (make-sbt-16 'a)) + program-error) + +(deftest structure-boa-test-16/6 + (classify-error (make-sbt-16 1 1)) + program-error) + +(deftest structure-boa-test-16/7 + (sbt-slots 'sbt-16 (make-sbt-16 :a 1 :b 2 :c 3 :d 5 :allow-other-keys t) + :a :b :c) + (1 2 3)) + +(deftest structure-boa-test-16/8 + (sbt-slots 'sbt-16 (make-sbt-16 :allow-other-keys t :a 1 :b 2 :c 3 :d 5) + :a :b :c) + (1 2 3)) + +;;; :allow-other-keys turns off keyword error checking, including +;;; invalid (nonsymbol) keyword arguments +;;;(deftest structure-boa-test-16/9 +;;; (sbt-slots 'sbt-16 (make-sbt-16 :allow-other-keys t +;;; :a 3 :b 6 :c 9 1000 1000) +;;; :a :b :c) +;;; (3 6 9)) + +;;; Repeated keyword arguments are allowed; the leftmost one is used +(deftest structure-boa-test-16/10 + (sbt-slots 'sbt-16 (make-sbt-16 :a 1 :a 2 :b 3 :b 4 :c 5 :c 6) :a :b :c) + (1 3 5)) + +(deftest structure-boa-test-16/11 + (sbt-slots 'sbt-16 (make-sbt-16 :allow-other-keys t + :allow-other-keys nil + :a 1 :b 2 :c 3 :d 5) + :a :b :c) + (1 2 3)) + +;; Checking of # of keywords is suppressed when :allow-other-keys is true +;;;(deftest structure-boa-test-16/12 +;;; (sbt-slots 'sbt-16 (make-sbt-16 :allow-other-keys t :a 3 :b 6 :c 9 :a) +;;; :a :b :c) +;;; (3 6 9)) + diff --git a/ansi-tests/subseq-aux.lsp b/ansi-tests/subseq-aux.lsp new file mode 100644 index 0000000..ef466de --- /dev/null +++ b/ansi-tests/subseq-aux.lsp @@ -0,0 +1,239 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Nov 26 20:01:27 2002 +;;;; Contains: Aux. functions for subseq tests + +(in-package :cl-test) + +(defun subseq-list.4-body () + (block done + (let ((x (loop for i from 0 to 19 collect i))) + (loop + for i from 0 to 20 do + (loop + for j from i to 20 do + (let ((y (subseq x i j))) + (loop + for e in y and k from i to (1- j) do + (unless (eqlt e k) (return-from done nil))))))) + t)) + +(defun subseq-list.5-body () + (block done + (let ((x (loop for i from 0 to 29 collect i))) + (loop + for i from 0 to 30 do + (unless (equalt (subseq x i) + (loop for j from i to 29 collect j)) + (return-from done nil)))) + t)) + +(defun subseq-list.6-body () + (let* ((x (make-list 100)) + (z (loop for e on x collect e)) + (y (subseq x 0))) + (loop + for e on x + and f on y + and g in z do + (when (or (not (eqt g e)) + (not (eqlt (car e) (car f))) + (car e) + (eqt e f)) + (return nil)) + finally (return t)))) + +(defun subseq-vector.1-body () + (block nil + (let* ((x (make-sequence 'vector 10 :initial-element 'a)) + (y (subseq x 4 8))) + (unless (every #'(lambda (e) (eqt e 'a)) x) + (return 1)) + (unless (every #'(lambda (e) (eqt e 'a)) y) + (return 2)) + (unless (eqlt (length x) 10) (return 3)) + (unless (eqlt (length y) 4) (return 4)) + (loop for i from 0 to 9 do (setf (aref x i) 'b)) + (unless (every #'(lambda (e) (eqt e 'a)) y) + (return 5)) + (loop for i from 0 to 3 do (setf (aref y i) 'c)) + (or + (not (not (every #'(lambda (e) (eqt e 'b)) x))) + 6)))) + +(defun subseq-vector.2-body () + (block nil + (let* ((x (make-sequence '(vector fixnum) 10 :initial-element 1)) + (y (subseq x 4 8))) + (unless (every #'(lambda (e) (eqlt e 1)) x) + (return 1)) + (unless (every #'(lambda (e) (eqlt e 1)) y) + (return 2)) + (unless (eqlt (length x) 10) (return 3)) + (unless (eqlt (length y) 4) (return 4)) + (loop for i from 0 to 9 do (setf (aref x i) 2)) + (unless (every #'(lambda (e) (eqlt e 1)) y) + (return 5)) + (loop for i from 0 to 3 do (setf (aref y i) 3)) + (or + (not (not (every #'(lambda (e) (eqlt e 2)) x))) + 6)))) + +(defun subseq-vector.3-body () + (block nil + (let* ((x (make-sequence '(vector single-float) 10 :initial-element 1.0)) + (y (subseq x 4 8))) + (unless (every #'(lambda (e) (= e 1.0)) x) + (return 1)) + (unless (every #'(lambda (e) (= e 1.0)) y) + (return 2)) + (unless (eqlt (length x) 10) (return 3)) + (unless (eqlt (length y) 4) (return 4)) + (loop for i from 0 to 9 do (setf (aref x i) 2.0)) + (unless (every #'(lambda (e) (= e 1.0)) y) + (return 5)) + (loop for i from 0 to 3 do (setf (aref y i) 3.0)) + (or + (not (not (every #'(lambda (e) (= e 2.0)) x))) + 6)))) + +(defun subseq-vector.4-body () + (block nil + (let* ((x (make-sequence '(vector double-float) 10 :initial-element 1.0d0)) + (y (subseq x 4 8))) + (unless (every #'(lambda (e) (= e 1.0)) x) + (return 1)) + (unless (every #'(lambda (e) (= e 1.0)) y) + (return 2)) + (unless (eqlt (length x) 10) (return 3)) + (unless (eqlt (length y) 4) (return 4)) + (loop for i from 0 to 9 do (setf (aref x i) 2.0d0)) + (unless (every #'(lambda (e) (= e 1.0)) y) + (return 5)) + (loop for i from 0 to 3 do (setf (aref y i) 3.0d0)) + (or + (not (not (every #'(lambda (e) (= e 2.0)) x))) + 6)))) + +(defun subseq-vector.5-body () + (block nil + (let* ((x (make-sequence '(vector short-float) 10 :initial-element 1.0s0)) + (y (subseq x 4 8))) + (unless (every #'(lambda (e) (= e 1.0)) x) + (return 1)) + (unless (every #'(lambda (e) (= e 1.0)) y) + (return 2)) + (unless (eqlt (length x) 10) (return 3)) + (unless (eqlt (length y) 4) (return 4)) + (loop for i from 0 to 9 do (setf (aref x i) 2.0s0)) + (unless (every #'(lambda (e) (= e 1.0)) y) + (return 5)) + (loop for i from 0 to 3 do (setf (aref y i) 3.0s0)) + (or + (not (not (every #'(lambda (e) (= e 2.0)) x))) + 6)))) + +(defun subseq-vector.6-body () + (block nil + (let* ((x (make-sequence '(vector long-float) 10 :initial-element 1.0l0)) + (y (subseq x 4 8))) + (unless (every #'(lambda (e) (= e 1.0)) x) + (return 1)) + (unless (every #'(lambda (e) (= e 1.0)) y) + (return 2)) + (unless (eqlt (length x) 10) (return 3)) + (unless (eqlt (length y) 4) (return 4)) + (loop for i from 0 to 9 do (setf (aref x i) 2.0l0)) + (unless (every #'(lambda (e) (= e 1.0)) y) + (return 5)) + (loop for i from 0 to 3 do (setf (aref y i) 3.0l0)) + (or + (not (not (every #'(lambda (e) (= e 2.0)) x))) + 6)))) + +(defun subseq-string.1-body () + (let* ((s1 "abcdefgh") + (len (length s1))) + (loop for start from 0 below len + always + (string= (subseq s1 start) + (coerce (loop for i from start to (1- len) + collect (aref s1 i)) + 'string))))) + +(defun subseq-string.2-body () + (let* ((s1 "abcdefgh") + (len (length s1))) + (loop for start from 0 below len + always + (loop for end from (1+ start) to len + always + (string= (subseq s1 start end) + (coerce (loop for i from start below end + collect (aref s1 i)) + 'string)))))) + +(defun subseq-string.3-body () + (let* ((s1 (make-array '(10) :initial-contents "abcdefghij" + :fill-pointer 8 + :element-type 'character)) + (len (length s1))) + (and + (eqlt len 8) + (loop for start from 0 below len + always + (string= (subseq s1 start) + (coerce (loop for i from start to (1- len) + collect (aref s1 i)) + 'string))) + (loop for start from 0 below len + always + (loop for end from (1+ start) to len + always + (string= (subseq s1 start end) + (coerce (loop for i from start below end + collect (aref s1 i)) + 'string))))))) +(defun subseq-bit-vector.1-body () + (let* ((s1 #*11001000) + (len (length s1))) + (loop for start from 0 below len + always + (equalp (subseq s1 start) + (coerce (loop for i from start to (1- len) + collect (aref s1 i)) + 'bit-vector))))) + +(defun subseq-bit-vector.2-body () + (let* ((s1 #*01101011) + (len (length s1))) + (loop for start from 0 below len + always + (loop for end from (1+ start) to len + always + (equalp (subseq s1 start end) + (coerce (loop for i from start below end + collect (aref s1 i)) + 'bit-vector)))))) + +(defun subseq-bit-vector.3-body () + (let* ((s1 (make-array '(10) :initial-contents #*1101100110 + :fill-pointer 8 + :element-type 'bit)) + (len (length s1))) + (and + (eqlt len 8) + (loop for start from 0 below len + always + (equalp (subseq s1 start) + (coerce (loop for i from start to (1- len) + collect (aref s1 i)) + 'bit-vector))) + (loop for start from 0 below len + always + (loop for end from (1+ start) to len + always + (equalp (subseq s1 start end) + (coerce (loop for i from start below end + collect (aref s1 i)) + 'bit-vector))))))) diff --git a/ansi-tests/subseq.lsp b/ansi-tests/subseq.lsp new file mode 100644 index 0000000..d9304b2 --- /dev/null +++ b/ansi-tests/subseq.lsp @@ -0,0 +1,235 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Oct 12 19:41:14 2002 +;;;; Contains: Tests on SUBSEQ + +(in-package :cl-test) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; subseq, on lists + +(deftest subseq-list.1 + (subseq '(a b c d e) 0 0) + nil) + +(deftest subseq-list.2 + (subseq '(a b c) 0) + (a b c)) + +(deftest subseq-list.3 + (subseq '(a b c) 1) + (b c)) + + +(deftest subseq-list.4 + (subseq-list.4-body) + t) + +(deftest subseq-list.5 + (subseq-list.5-body) + t) + +(deftest subseq-list.6 ;; check that no structure is shared + (subseq-list.6-body) + t) + +(deftest subseq-list.7 + (let ((x (loop for i from 0 to 9 collect i))) + (setf (subseq x 0 3) (list 'a 'b 'c)) + x) + (a b c 3 4 5 6 7 8 9)) + +(deftest subseq-list.8 + (let* ((x '(a b c d e)) + (y (copy-seq x))) + (setf (subseq y 0) '(f g h)) + (list x y)) + ((a b c d e) (f g h d e))) + +(deftest subseq-list.9 + (let* ((x '(a b c d e)) + (y (copy-seq x))) + (setf (subseq y 1 3) '(1 2 3 4 5)) + (list x y)) + ((a b c d e) (a 1 2 d e))) + +(deftest subseq-list.10 + (let* ((x '(a b c d e)) + (y (copy-seq x))) + (setf (subseq y 5) '(1 2 3 4 5)) + (list x y)) + ((a b c d e) (a b c d e))) + +(deftest subseq-list.11 + (let* ((x '(a b c d e)) + (y (copy-seq x))) + (setf (subseq y 2 5) '(1)) + (list x y)) + ((a b c d e) (a b 1 d e))) + +(deftest subseq-list.12 + (let* ((x '(a b c d e)) + (y (copy-seq x))) + (setf (subseq y 0 0) '(1 2)) + (list x y)) + ((a b c d e) (a b c d e))) + +;; subseq on vectors + + +(deftest subseq-vector.1 + (subseq-vector.1-body) + t) + + +(deftest subseq-vector.2 + (subseq-vector.2-body) + t) + + +(deftest subseq-vector.3 + (subseq-vector.3-body) + t) + +(deftest subseq-vector.4 + (subseq-vector.4-body) + t) + +(deftest subseq-vector.5 + (subseq-vector.5-body) + t) + +(deftest subseq-vector.6 + (subseq-vector.6-body) + t) + +(deftest subseq-vector.7 + (let* ((x (make-array '(10) :initial-contents '(a b c d e f g h i j))) + (y (subseq x 2 8))) + (equal-array y (make-array '(6) :initial-contents '(c d e f g h)))) + t) + +(deftest subseq-vector.8 + (let* ((x (make-array '(200) :initial-element 107 + :element-type 'fixnum)) + (y (subseq x 17 95))) + (and (eqlt (length y) (- 95 17)) + (equal-array y + (make-array (list (- 95 17)) + :initial-element 107 + :element-type 'fixnum)))) + t) + +(deftest subseq-vector.9 + (let* ((x (make-array '(1000) :initial-element 17.6e-1 + :element-type 'single-float)) + (lo 164) + (hi 873) + (y (subseq x lo hi))) + (and (eqlt (length y) (- hi lo)) + (equal-array y + (make-array (list (- hi lo)) + :initial-element 17.6e-1 + :element-type 'single-float)))) + t) + +(deftest subseq-vector.10 + (let* ((x (make-array '(2000) :initial-element 3.1415927d4 + :element-type 'double-float)) + (lo 731) + (hi 1942) + (y (subseq x lo hi))) + (and (eqlt (length y) (- hi lo)) + (equal-array y + (make-array (list (- hi lo)) + :initial-element 3.1415927d4 + :element-type 'double-float)))) + t) + +;;; subseq on strings + +(deftest subseq-string.1 + (subseq-string.1-body) + t) + +(deftest subseq-string.2 + (subseq-string.2-body) + t) + +(deftest subseq-string.3 + (subseq-string.3-body) + t) + +;;; Tests on bit vectors + +(deftest subseq-bit-vector.1 + (subseq-bit-vector.1-body) + t) + +(deftest subseq-bit-vector.2 + (subseq-bit-vector.2-body) + t) + +(deftest subseq-bit-vector.3 + (subseq-bit-vector.3-body) + t) + +;;; Order of evaluation + +(deftest subseq.order.1 + (let ((i 0) a b c) + (values + (subseq + (progn (setf a (incf i)) "abcdefgh") + (progn (setf b (incf i)) 1) + (progn (setf c (incf i)) 4)) + i a b c)) + "bcd" 3 1 2 3) + +(deftest subseq.order.2 + (let ((i 0) a b) + (values + (subseq + (progn (setf a (incf i)) "abcdefgh") + (progn (setf b (incf i)) 1)) + i a b)) + "bcdefgh" 2 1 2) + +(deftest subseq.order.3 + (let ((i 0) a b c d + (s (copy-seq "abcdefgh"))) + (values + (setf (subseq + (progn (setf a (incf i)) s) + (progn (setf b (incf i)) 1) + (progn (setf c (incf i)) 4)) + (progn (setf d (incf i)) "xyz")) + s i a b c d)) + "xyz" "axyzefgh" 4 1 2 3 4) + +(deftest subseq.order.4 + (let ((i 0) a b c + (s (copy-seq "abcd"))) + (values + (setf (subseq + (progn (setf a (incf i)) s) + (progn (setf b (incf i)) 1)) + (progn (setf c (incf i)) "xyz")) + s i a b c)) + "xyz" "axyz" 3 1 2 3) + +;;; Error cases + +(deftest subseq.error.1 + (classify-error (subseq)) + program-error) + +(deftest subseq.error.2 + (classify-error (subseq nil)) + program-error) + +(deftest subseq.error.3 + (classify-error (subseq nil 0 0 0)) + program-error) + + diff --git a/ansi-tests/substitute-if-not.lsp b/ansi-tests/substitute-if-not.lsp new file mode 100644 index 0000000..ad57f65 --- /dev/null +++ b/ansi-tests/substitute-if-not.lsp @@ -0,0 +1,837 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Aug 31 18:17:09 2002 +;;;; Contains: Tests for SUBSTITUTE-IF-NOT + +(in-package :cl-test) + +(deftest substitute-if-not-list.1 + (let ((x '())) (values (substitute-if-not 'b #'null x) x)) + nil nil) + +(deftest substitute-if-not-list.2 + (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x) x)) + (b b b c) + (a b a c)) + +(deftest substitute-if-not-list.3 + (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count nil) x)) + (b b b c) + (a b a c)) + +(deftest substitute-if-not-list.4 + (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 2) x)) + (b b b c) + (a b a c)) + +(deftest substitute-if-not-list.5 + (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 1) x)) + (b b a c) + (a b a c)) + +(deftest substitute-if-not-list.6 + (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 0) x)) + (a b a c) + (a b a c)) + +(deftest substitute-if-not-list.7 + (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count -1) x)) + (a b a c) + (a b a c)) + +(deftest substitute-if-not-list.8 + (let ((x '())) (values (substitute-if-not 'b (is-not-eq-p 'a) x :from-end t) x)) + nil nil) + +(deftest substitute-if-not-list.9 + (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :from-end t) x)) + (b b b c) + (a b a c)) + +(deftest substitute-if-not-list.10 + (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :from-end t :count nil) x)) + (b b b c) + (a b a c)) + +(deftest substitute-if-not-list.11 + (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 2 :from-end t) x)) + (b b b c) + (a b a c)) + +(deftest substitute-if-not-list.12 + (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 1 :from-end t) x)) + (a b b c) + (a b a c)) + +(deftest substitute-if-not-list.13 + (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 0 :from-end t) x)) + (a b a c) + (a b a c)) + +(deftest substitute-if-not-list.14 + (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count -1 :from-end t) x)) + (a b a c) + (a b a c)) + +(deftest substitute-if-not-list.15 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if-not 'x (is-not-eq-p 'a) x :start i :end j))) + (and (equal orig x) + (equal y (nconc (make-list i :initial-element 'a) + (make-list (- j i) :initial-element 'x) + (make-list (- 10 j) :initial-element 'a))))))) + t) + +(deftest substitute-if-not-list.16 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :from-end t))) + (and (equal orig x) + (equal y (nconc (make-list i :initial-element 'a) + (make-list (- j i) :initial-element 'x) + (make-list (- 10 j) :initial-element 'a))))))) + t) + +(deftest substitute-if-not-list.17 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :count c))) + (and (equal orig x) + (equal y (nconc (make-list i :initial-element 'a) + (make-list c :initial-element 'x) + (make-list (- 10 (+ i c)) :initial-element 'a)))))))) + t) + +(deftest substitute-if-not-list.18 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :count c :from-end t))) + (and (equal orig x) + (equal y (nconc (make-list (- j c) :initial-element 'a) + (make-list c :initial-element 'x) + (make-list (- 10 j) :initial-element 'a)))))))) + t) + +;;; Tests on vectors + +(deftest substitute-if-not-vector.1 + (let ((x #())) (values (substitute-if-not 'b (is-not-eq-p 'a) x) x)) + #() #()) + +(deftest substitute-if-not-vector.2 + (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x) x)) + #(b b b c) + #(a b a c)) + +(deftest substitute-if-not-vector.3 + (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count nil) x)) + #(b b b c) + #(a b a c)) + +(deftest substitute-if-not-vector.4 + (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 2) x)) + #(b b b c) + #(a b a c)) + +(deftest substitute-if-not-vector.5 + (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 1) x)) + #(b b a c) + #(a b a c)) + +(deftest substitute-if-not-vector.6 + (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 0) x)) + #(a b a c) + #(a b a c)) + +(deftest substitute-if-not-vector.7 + (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count -1) x)) + #(a b a c) + #(a b a c)) + +(deftest substitute-if-not-vector.8 + (let ((x #())) (values (substitute-if-not 'b (is-not-eq-p 'a) x :from-end t) x)) + #() #()) + +(deftest substitute-if-not-vector.9 + (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :from-end t) x)) + #(b b b c) + #(a b a c)) + +(deftest substitute-if-not-vector.10 + (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :from-end t :count nil) x)) + #(b b b c) + #(a b a c)) + +(deftest substitute-if-not-vector.11 + (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 2 :from-end t) x)) + #(b b b c) + #(a b a c)) + +(deftest substitute-if-not-vector.12 + (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 1 :from-end t) x)) + #(a b b c) + #(a b a c)) + +(deftest substitute-if-not-vector.13 + (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count 0 :from-end t) x)) + #(a b a c) + #(a b a c)) + +(deftest substitute-if-not-vector.14 + (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eq-p 'a) x :count -1 :from-end t) x)) + #(a b a c) + #(a b a c)) + +(deftest substitute-if-not-vector.15 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if-not 'x (is-not-eq-p 'a) x :start i :end j))) + (and (equalp orig x) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array (- j i) :initial-element 'x) + (make-array (- 10 j) :initial-element 'a))))))) + t) + +(deftest substitute-if-not-vector.16 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :from-end t))) + (and (equalp orig x) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array (- j i) :initial-element 'x) + (make-array (- 10 j) :initial-element 'a))))))) + t) + +(deftest substitute-if-not-vector.17 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :count c))) + (and (equalp orig x) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array c :initial-element 'x) + (make-array (- 10 (+ i c)) :initial-element 'a)))))))) + t) + +(deftest substitute-if-not-vector.18 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if-not 'x (is-not-eq-p 'a) x :start i :end j :count c :from-end t))) + (and (equalp orig x) + (equalp y (concatenate 'simple-vector + (make-array (- j c) :initial-element 'a) + (make-array c :initial-element 'x) + (make-array (- 10 j) :initial-element 'a)))))))) + t) + +(deftest substitute-if-not-vector.28 + (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) + :fill-pointer 5)) + (result (substitute-if-not 'z (is-not-eql-p 'a) x))) + result) + #(z b z c b)) + +(deftest substitute-if-not-vector.29 + (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) + :fill-pointer 5)) + (result (substitute-if-not 'z (is-not-eql-p 'a) x :from-end t))) + result) + #(z b z c b)) + +(deftest substitute-if-not-vector.30 + (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) + :fill-pointer 5)) + (result (substitute-if-not 'z (is-not-eql-p 'a) x :count 1))) + result) + #(z b a c b)) + +(deftest substitute-if-not-vector.31 + (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) + :fill-pointer 5)) + (result (substitute-if-not 'z (is-not-eql-p 'a) x + :from-end t :count 1))) + result) + #(a b z c b)) + + +;;; Tests on strings + +(deftest substitute-if-not-string.1 + (let ((x "")) (values (substitute-if-not #\b (is-not-eq-p #\a) x) x)) + "" "") + +(deftest substitute-if-not-string.2 + (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x) x)) + "bbbc" + "abac") + +(deftest substitute-if-not-string.3 + (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :count nil) x)) + "bbbc" + "abac") + +(deftest substitute-if-not-string.4 + (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :count 2) x)) + "bbbc" + "abac") + +(deftest substitute-if-not-string.5 + (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :count 1) x)) + "bbac" + "abac") + +(deftest substitute-if-not-string.6 + (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :count 0) x)) + "abac" + "abac") + +(deftest substitute-if-not-string.7 + (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :count -1) x)) + "abac" + "abac") + +(deftest substitute-if-not-string.8 + (let ((x "")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :from-end t) x)) + "" "") + +(deftest substitute-if-not-string.9 + (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :from-end t) x)) + "bbbc" + "abac") + +(deftest substitute-if-not-string.10 + (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :from-end t :count nil) x)) + "bbbc" + "abac") + +(deftest substitute-if-not-string.11 + (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :count 2 :from-end t) x)) + "bbbc" + "abac") + +(deftest substitute-if-not-string.12 + (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :count 1 :from-end t) x)) + "abbc" + "abac") + +(deftest substitute-if-not-string.13 + (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :count 0 :from-end t) x)) + "abac" + "abac") + +(deftest substitute-if-not-string.14 + (let ((x "abac")) (values (substitute-if-not #\b (is-not-eq-p #\a) x :count -1 :from-end t) x)) + "abac" + "abac") + +(deftest substitute-if-not-string.15 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (substitute-if-not #\x (is-not-eq-p #\a) x :start i :end j))) + (and (equalp orig x) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array (- j i) :initial-element #\x) + (make-array (- 10 j) :initial-element #\a))))))) + t) + +(deftest substitute-if-not-string.16 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (substitute-if-not #\x (is-not-eq-p #\a) x :start i :end j :from-end t))) + (and (equalp orig x) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array (- j i) :initial-element #\x) + (make-array (- 10 j) :initial-element #\a))))))) + t) + +(deftest substitute-if-not-string.17 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (substitute-if-not #\x (is-not-eq-p #\a) x :start i :end j :count c))) + (and (equalp orig x) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array c :initial-element #\x) + (make-array (- 10 (+ i c)) :initial-element #\a)))))))) + t) + +(deftest substitute-if-not-string.18 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (substitute-if-not #\x (is-not-eq-p #\a) x :start i :end j :count c :from-end t))) + (and (equalp orig x) + (equalp y (concatenate 'simple-string + (make-array (- j c) :initial-element #\a) + (make-array c :initial-element #\x) + (make-array (- 10 j) :initial-element #\a)))))))) + t) + +(deftest substitute-if-not-string.28 + (let* ((x (make-array '(10) :initial-contents "abacbadeaf" + :fill-pointer 5 :element-type 'character)) + (result (substitute-if-not #\z (is-not-eql-p #\a) x))) + result) + "zbzcb") + +(deftest substitute-if-not-string.29 + (let* ((x (make-array '(10) :initial-contents "abacbadeaf" + :fill-pointer 5 :element-type 'character)) + (result (substitute-if-not #\z (is-not-eql-p #\a) x :from-end t))) + result) + "zbzcb") + +(deftest substitute-if-not-string.30 + (let* ((x (make-array '(10) :initial-contents "abacbadeaf" + :fill-pointer 5 :element-type 'character)) + (result (substitute-if-not #\z (is-not-eql-p #\a) x :count 1))) + result) + "zbacb") + +(deftest substitute-if-not-string.31 + (let* ((x (make-array '(10) :initial-contents "abacbadeaf" + :fill-pointer 5 :element-type 'character)) + (result (substitute-if-not #\z (is-not-eql-p #\a) x + :from-end t :count 1))) + result) + "abzcb") + + + +;;; Tests on bitstrings + +(deftest substitute-if-not-bitstring.1 + (let* ((orig #*) + (x (copy-seq orig)) + (result (substitute-if-not 0 (is-not-eq-p 1) x))) + (and (equalp orig x) + result)) + #*) + +(deftest substitute-if-not-bitstring.2 + (let* ((orig #*) + (x (copy-seq orig)) + (result (substitute-if-not 1 (complement #'zerop) x))) + (and (equalp orig x) + result)) + #*) + +(deftest substitute-if-not-bitstring.3 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if-not 0 (is-not-eq-p 1) x))) + (and (equalp orig x) + result)) + #*000000) + +(deftest substitute-if-not-bitstring.4 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if-not 1 (complement #'zerop) x))) + (and (equalp orig x) + result)) + #*111111) + +(deftest substitute-if-not-bitstring.5 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if-not 1 (complement #'zerop) x :start 1))) + (and (equalp orig x) + result)) + #*011111) + +(deftest substitute-if-not-bitstring.6 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if-not 0 (is-not-eq-p 1) x :start 2 :end nil))) + (and (equalp orig x) + result)) + #*010000) + +(deftest substitute-if-not-bitstring.7 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if-not 1 (complement #'zerop) x :end 4))) + (and (equalp orig x) + result)) + #*111101) + +(deftest substitute-if-not-bitstring.8 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if-not 0 (is-not-eq-p 1) x :end nil))) + (and (equalp orig x) + result)) + #*000000) + +(deftest substitute-if-not-bitstring.9 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if-not 0 (is-not-eq-p 1) x :end 3))) + (and (equalp orig x) + result)) + #*000101) + +(deftest substitute-if-not-bitstring.10 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if-not 0 (is-not-eq-p 1) x :start 2 :end 4))) + (and (equalp orig x) + result)) + #*010001) + +(deftest substitute-if-not-bitstring.11 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if-not 1 (complement #'zerop) x :start 2 :end 4))) + (and (equalp orig x) + result)) + #*011101) + +(deftest substitute-if-not-bitstring.12 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if-not 1 (complement #'zerop) x :count 1))) + (and (equalp orig x) + result)) + #*110101) + +(deftest substitute-if-not-bitstring.13 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if-not 1 (complement #'zerop) x :count 0))) + (and (equalp orig x) + result)) + #*010101) + +(deftest substitute-if-not-bitstring.14 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if-not 1 (complement #'zerop) x :count -1))) + (and (equalp orig x) + result)) + #*010101) + +(deftest substitute-if-not-bitstring.15 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if-not 1 (complement #'zerop) x :count 1 :from-end t))) + (and (equalp orig x) + result)) + #*010111) + +(deftest substitute-if-not-bitstring.16 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if-not 1 (complement #'zerop) x :count 0 :from-end t))) + (and (equalp orig x) + result)) + #*010101) + +(deftest substitute-if-not-bitstring.17 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if-not 1 (complement #'zerop) x :count -1 :from-end t))) + (and (equalp orig x) + result)) + #*010101) + +(deftest substitute-if-not-bitstring.18 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if-not 1 (complement #'zerop) x :count nil))) + (and (equalp orig x) + result)) + #*111111) + +(deftest substitute-if-not-bitstring.19 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if-not 1 (complement #'zerop) x :count nil :from-end t))) + (and (equalp orig x) + result)) + #*111111) + +(deftest substitute-if-not-bitstring.20 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #*0000000000) + (x (copy-seq orig)) + (y (substitute-if-not 1 (complement #'zerop) x :start i :end j :count c))) + (and (equalp orig x) + (equalp y (concatenate + 'simple-bit-vector + (make-list i :initial-element 0) + (make-list c :initial-element 1) + (make-list (- 10 (+ i c)) :initial-element 0)))))))) + t) + +(deftest substitute-if-not-bitstring.21 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #*1111111111) + (x (copy-seq orig)) + (y (substitute-if-not 0 (is-not-eq-p 1) x :start i :end j :count c :from-end t))) + (and (equalp orig x) + (equalp y (concatenate + 'simple-bit-vector + (make-list (- j c) :initial-element 1) + (make-list c :initial-element 0) + (make-list (- 10 j) :initial-element 1)))))))) + t) + +;;; More tests + +(deftest substitute-if-not-list.24 + (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (substitute-if-not '(a 10) (is-not-eq-p 'a) x :key #'car))) + (and (equal orig x) + result)) + ((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) + +(deftest substitute-if-not-list.25 + (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (substitute-if-not '(a 10) (is-not-eq-p 'a) x + :key #'car :start 1 :end 5))) + (and (equal orig x) + result)) + ((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) + +(deftest substitute-if-not-vector.24 + (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (substitute-if-not '(a 10) (is-not-eq-p 'a) x :key #'car))) + (and (equalp orig x) + result)) + #((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) + +(deftest substitute-if-not-vector.25 + (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (substitute-if-not '(a 10) (is-not-eq-p 'a) x :key #'car :start 1 :end 5))) + (and (equalp orig x) + result)) + #((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) + +(deftest substitute-if-not-string.24 + (let* ((orig "0102342015") + (x (copy-seq orig)) + (result (substitute-if-not #\a (is-not-eq-p #\1) x :key #'nextdigit))) + (and (equalp orig x) + result)) + "a1a2342a15") + +(deftest substitute-if-not-string.25 + (let* ((orig "0102342015") + (x (copy-seq orig)) + (result (substitute-if-not #\a (is-not-eq-p #\1) x :key #'nextdigit :start 1 :end 6))) + (and (equalp orig x) + result)) + "01a2342015") + +(deftest substitute-if-not-bitstring.26 + (let* ((orig #*00111001011010110) + (x (copy-seq orig)) + (result (substitute-if-not 1 (is-not-eq-p 1) x :key #'1+))) + (and (equalp orig x) + result)) + #*11111111111111111) + +(deftest substitute-if-not-bitstring.27 + (let* ((orig #*00111001011010110) + (x (copy-seq orig)) + (result (substitute-if-not 1 (is-not-eq-p 1) x :key #'1+ :start 1 :end 10))) + (and (equalp orig x) + result)) + #*01111111111010110) + +(deftest substitute-if-not-bit-vector.30 + (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) + :fill-pointer 5 :element-type 'bit)) + (result (substitute-if-not 1 #'onep x))) + result) + #*11111) + +(deftest substitute-if-not-bit-vector.31 + (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) + :fill-pointer 5 :element-type 'bit)) + (result (substitute-if-not 1 #'onep x :from-end t))) + result) + #*11111) + +(deftest substitute-if-not-bit-vector.32 + (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) + :fill-pointer 5 :element-type 'bit)) + (result (substitute-if-not 1 #'onep x :count 1))) + result) + #*11011) + +(deftest substitute-if-not-bit-vector.33 + (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) + :fill-pointer 5 :element-type 'bit)) + (result (substitute-if-not 1 #'onep x :from-end t :count 1))) + result) + #*01111) + +(deftest substitute-if-not.order.1 + (let ((i 0) a b c d e f g h) + (values + (substitute-if-not + (progn (setf a (incf i)) 'a) + (progn (setf b (incf i)) #'identity) + (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) + :count (progn (setf d (incf i)) 2) + :start (progn (setf e (incf i)) 0) + :end (progn (setf f (incf i)) 7) + :key (progn (setf g (incf i)) #'identity) + :from-end (setf h (incf i)) + ) + i a b c d e f g h)) + (nil 1 2 a 3 4 a 5) + 8 1 2 3 4 5 6 7 8) + +(deftest substitute-if-not.order.2 + (let ((i 0) a b c d e f g h) + (values + (substitute-if-not + (progn (setf a (incf i)) 'a) + (progn (setf b (incf i)) #'identity) + (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) + :from-end (setf h (incf i)) + :key (progn (setf g (incf i)) #'identity) + :end (progn (setf f (incf i)) 7) + :start (progn (setf e (incf i)) 0) + :count (progn (setf d (incf i)) 2) + ) + i a b c d e f g h)) + (nil 1 2 a 3 4 a 5) + 8 1 2 3 8 7 6 5 4) + +;;; Keyword tests + +(deftest substitute-if-not.allow-other-keys.1 + (substitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) + :allow-other-keys t :bad t) + (a a 0 a a 0 a)) + +(deftest substitute-if-not.allow-other-keys.2 + (substitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) + :bad t :allow-other-keys t) + (a a 0 a a 0 a)) + +(deftest substitute-if-not.allow-other-keys.3 + (substitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t + :allow-other-keys nil :bad t) + (a a 0 a a 0 a)) + +(deftest substitute-if-not.allow-other-keys.4 + (substitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :bad t + :allow-other-keys t :allow-other-keys nil) + (a a 0 a a 0 a)) + +(deftest substitute-if-not.allow-other-keys.5 + (substitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) + :allow-other-keys t :key #'1-) + (1 a a a 1 a a)) + +(deftest substitute-if-not.keywords.6 + (substitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) + :key #'1- :key #'identity) + (1 a a a 1 a a)) + +(deftest substitute-if-not.allow-other-keys.7 + (substitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t + :bad t :allow-other-keys nil) + (a a 0 a a 0 a)) + +(deftest substitute-if-not.allow-other-keys.8 + (substitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys nil) + (a a 0 a a 0 a)) + +;;; Error cases + +(deftest substitute-if-not.error.1 + (classify-error (substitute-if-not)) + program-error) + +(deftest substitute-if-not.error.2 + (classify-error (substitute-if-not 'a)) + program-error) + +(deftest substitute-if-not.error.3 + (classify-error (substitute-if-not 'a #'null)) + program-error) + +(deftest substitute-if-not.error.4 + (classify-error (substitute-if-not 'a #'null nil 'bad t)) + program-error) + +(deftest substitute-if-not.error.5 + (classify-error (substitute-if-not 'a #'null nil + 'bad t :allow-other-keys nil)) + program-error) + +(deftest substitute-if-not.error.6 + (classify-error (substitute-if-not 'a #'null nil :key)) + program-error) + +(deftest substitute-if-not.error.7 + (classify-error (substitute-if-not 'a #'null nil 1 2)) + program-error) + +(deftest substitute-if-not.error.8 + (classify-error (substitute-if-not 'a #'cons (list 'a 'b 'c))) + program-error) + +(deftest substitute-if-not.error.9 + (classify-error (substitute-if-not 'a #'car (list 'a 'b 'c))) + type-error) + +(deftest substitute-if-not.error.10 + (classify-error (substitute-if-not 'a #'identity (list 'a 'b 'c) + :key #'car)) + type-error) + +(deftest substitute-if-not.error.11 + (classify-error (substitute-if-not 'a #'identity (list 'a 'b 'c) + :key #'cons)) + program-error) + diff --git a/ansi-tests/substitute-if.lsp b/ansi-tests/substitute-if.lsp new file mode 100644 index 0000000..2643cc2 --- /dev/null +++ b/ansi-tests/substitute-if.lsp @@ -0,0 +1,856 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Aug 31 17:42:04 2002 +;;;; Contains: Tests for SUBSTITUTE-IF + +(in-package :cl-test) + +(deftest substitute-if-list.1 + (let ((x '())) (values (substitute-if 'b #'identity x) x)) + nil nil) + +(deftest substitute-if-list.2 + (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x) x)) + (b b b c) + (a b a c)) + +(deftest substitute-if-list.3 + (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count nil) x)) + (b b b c) + (a b a c)) + +(deftest substitute-if-list.4 + (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 2) x)) + (b b b c) + (a b a c)) + +(deftest substitute-if-list.5 + (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 1) x)) + (b b a c) + (a b a c)) + +(deftest substitute-if-list.6 + (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 0) x)) + (a b a c) + (a b a c)) + +(deftest substitute-if-list.7 + (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count -1) x)) + (a b a c) + (a b a c)) + +(deftest substitute-if-list.8 + (let ((x '())) (values (substitute-if 'b (is-eq-p 'a) x :from-end t) x)) + nil nil) + +(deftest substitute-if-list.9 + (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :from-end t) x)) + (b b b c) + (a b a c)) + +(deftest substitute-if-list.10 + (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :from-end t :count nil) x)) + (b b b c) + (a b a c)) + +(deftest substitute-if-list.11 + (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 2 :from-end t) x)) + (b b b c) + (a b a c)) + +(deftest substitute-if-list.12 + (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 1 :from-end t) x)) + (a b b c) + (a b a c)) + +(deftest substitute-if-list.13 + (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 0 :from-end t) x)) + (a b a c) + (a b a c)) + +(deftest substitute-if-list.14 + (let ((x '(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count -1 :from-end t) x)) + (a b a c) + (a b a c)) + +(deftest substitute-if-list.15 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if 'x (is-eq-p 'a) x :start i :end j))) + (and (equal orig x) + (equal y (nconc (make-list i :initial-element 'a) + (make-list (- j i) :initial-element 'x) + (make-list (- 10 j) :initial-element 'a))))))) + t) + +(deftest substitute-if-list.16 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if 'x (is-eq-p 'a) x :start i :end j :from-end t))) + (and (equal orig x) + (equal y (nconc (make-list i :initial-element 'a) + (make-list (- j i) :initial-element 'x) + (make-list (- 10 j) :initial-element 'a))))))) + t) + +(deftest substitute-if-list.17 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if 'x (is-eq-p 'a) x :start i :end j :count c))) + (and (equal orig x) + (equal y (nconc (make-list i :initial-element 'a) + (make-list c :initial-element 'x) + (make-list (- 10 (+ i c)) :initial-element 'a)))))))) + t) + +(deftest substitute-if-list.18 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if 'x (is-eq-p 'a) x :start i :end j :count c :from-end t))) + (and (equal orig x) + (equal y (nconc (make-list (- j c) :initial-element 'a) + (make-list c :initial-element 'x) + (make-list (- 10 j) :initial-element 'a)))))))) + t) + + +;;; Tests on vectors + +(deftest substitute-if-vector.1 + (let ((x #())) (values (substitute-if 'b (is-eq-p 'a) x) x)) + #() #()) + +(deftest substitute-if-vector.2 + (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x) x)) + #(b b b c) + #(a b a c)) + +(deftest substitute-if-vector.3 + (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count nil) x)) + #(b b b c) + #(a b a c)) + +(deftest substitute-if-vector.4 + (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 2) x)) + #(b b b c) + #(a b a c)) + +(deftest substitute-if-vector.5 + (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 1) x)) + #(b b a c) + #(a b a c)) + +(deftest substitute-if-vector.6 + (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 0) x)) + #(a b a c) + #(a b a c)) + +(deftest substitute-if-vector.7 + (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count -1) x)) + #(a b a c) + #(a b a c)) + +(deftest substitute-if-vector.8 + (let ((x #())) (values (substitute-if 'b (is-eq-p 'a) x :from-end t) x)) + #() #()) + +(deftest substitute-if-vector.9 + (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :from-end t) x)) + #(b b b c) + #(a b a c)) + +(deftest substitute-if-vector.10 + (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :from-end t :count nil) x)) + #(b b b c) + #(a b a c)) + +(deftest substitute-if-vector.11 + (let ((x #(a b a c))) (values (substitute-if 'b (is-eq-p 'a) x :count 2 :from-end t) x)) + #(b b b c) + #(a b a c)) + +(deftest substitute-if-vector.12 + (let ((x #(a b a c))) + (values (substitute-if 'b (is-eq-p 'a) x :count 1 :from-end t) x)) + #(a b b c) + #(a b a c)) + +(deftest substitute-if-vector.13 + (let ((x #(a b a c))) + (values (substitute-if 'b (is-eq-p 'a) x :count 0 :from-end t) x)) + #(a b a c) + #(a b a c)) + +(deftest substitute-if-vector.14 + (let ((x #(a b a c))) + (values (substitute-if 'b (is-eq-p 'a) x :count -1 :from-end t) x)) + #(a b a c) + #(a b a c)) + +(deftest substitute-if-vector.15 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if 'x (is-eq-p 'a) x :start i :end j))) + (and (equalp orig x) + (equalp y + (concatenate + 'simple-vector + (make-array i :initial-element 'a) + (make-array (- j i) :initial-element 'x) + (make-array (- 10 j) :initial-element 'a))))))) + t) + +(deftest substitute-if-vector.16 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if 'x (is-eq-p 'a) x :start i :end j :from-end t))) + (and (equalp orig x) + (equalp y + (concatenate + 'simple-vector + (make-array i :initial-element 'a) + (make-array (- j i) :initial-element 'x) + (make-array (- 10 j) :initial-element 'a))))))) + t) + +(deftest substitute-if-vector.17 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if 'x (is-eq-p 'a) x + :start i :end j :count c))) + (and (equalp orig x) + (equalp + y (concatenate + 'simple-vector + (make-array i :initial-element 'a) + (make-array c :initial-element 'x) + (make-array (- 10 (+ i c)) + :initial-element 'a)))))))) + t) + +(deftest substitute-if-vector.18 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if 'x (is-eq-p 'a) x + :start i :end j :count c + :from-end t))) + (and (equalp orig x) + (equalp + y + (concatenate + 'simple-vector + (make-array (- j c) :initial-element 'a) + (make-array c :initial-element 'x) + (make-array (- 10 j) :initial-element 'a)))))))) + t) + +(deftest substitute-if-vector.28 + (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) + :fill-pointer 5)) + (result (substitute-if 'z (is-eql-p 'a) x))) + result) + #(z b z c b)) + +(deftest substitute-if-vector.29 + (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) + :fill-pointer 5)) + (result (substitute-if 'z (is-eql-p 'a) x :from-end t))) + result) + #(z b z c b)) + +(deftest substitute-if-vector.30 + (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) + :fill-pointer 5)) + (result (substitute-if 'z (is-eql-p 'a) x :count 1))) + result) + #(z b a c b)) + +(deftest substitute-if-vector.31 + (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) + :fill-pointer 5)) + (result (substitute-if 'z (is-eql-p 'a) x :from-end t :count 1))) + result) + #(a b z c b)) + +;;; Tests on strings + +(deftest substitute-if-string.1 + (let ((x "")) (values (substitute-if #\b (is-eq-p #\a) x) x)) + "" "") + +(deftest substitute-if-string.2 + (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x) x)) + "bbbc" + "abac") + +(deftest substitute-if-string.3 + (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :count nil) x)) + "bbbc" + "abac") + +(deftest substitute-if-string.4 + (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :count 2) x)) + "bbbc" + "abac") + +(deftest substitute-if-string.5 + (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :count 1) x)) + "bbac" + "abac") + +(deftest substitute-if-string.6 + (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :count 0) x)) + "abac" + "abac") + +(deftest substitute-if-string.7 + (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :count -1) x)) + "abac" + "abac") + +(deftest substitute-if-string.8 + (let ((x "")) (values (substitute-if #\b (is-eq-p #\a) x :from-end t) x)) + "" "") + +(deftest substitute-if-string.9 + (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :from-end t) x)) + "bbbc" + "abac") + +(deftest substitute-if-string.10 + (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :from-end t :count nil) x)) + "bbbc" + "abac") + +(deftest substitute-if-string.11 + (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :count 2 :from-end t) x)) + "bbbc" + "abac") + +(deftest substitute-if-string.12 + (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :count 1 :from-end t) x)) + "abbc" + "abac") + +(deftest substitute-if-string.13 + (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :count 0 :from-end t) x)) + "abac" + "abac") + +(deftest substitute-if-string.14 + (let ((x "abac")) (values (substitute-if #\b (is-eq-p #\a) x :count -1 :from-end t) x)) + "abac" + "abac") + +(deftest substitute-if-string.15 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (substitute-if #\x (is-eq-p #\a) x :start i :end j))) + (and (equalp orig x) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array (- j i) :initial-element #\x) + (make-array (- 10 j) :initial-element #\a))))))) + t) + +(deftest substitute-if-string.16 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (substitute-if #\x (is-eq-p #\a) x + :start i :end j :from-end t))) + (and (equalp orig x) + (equalp y + (concatenate + 'simple-string + (make-array i :initial-element #\a) + (make-array (- j i) :initial-element #\x) + (make-array (- 10 j) :initial-element #\a))))))) + t) + +(deftest substitute-if-string.17 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (substitute-if #\x (is-eq-p #\a) x + :start i :end j :count c))) + (and (equalp orig x) + (equalp y + (concatenate + 'simple-string + (make-array i :initial-element #\a) + (make-array c :initial-element #\x) + (make-array (- 10 (+ i c)) + :initial-element #\a)))))))) + t) + +(deftest substitute-if-string.18 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (substitute-if #\x (is-eq-p #\a) x + :start i :end j :count c + :from-end t))) + (and (equalp orig x) + (equalp y (concatenate + 'simple-string + (make-array (- j c) :initial-element #\a) + (make-array c :initial-element #\x) + (make-array (- 10 j) + :initial-element #\a)))))))) + t) + + +(deftest substitute-if-string.28 + (let* ((x (make-array '(10) :initial-contents "abacbadeaf" + :fill-pointer 5 :element-type 'character)) + (result (substitute-if #\z (is-eql-p #\a) x))) + result) + "zbzcb") + +(deftest substitute-if-string.29 + (let* ((x (make-array '(10) :initial-contents "abacbadeaf" + :fill-pointer 5 :element-type 'character)) + (result (substitute-if #\z (is-eql-p #\a) x :from-end t))) + result) + "zbzcb") + +(deftest substitute-if-string.30 + (let* ((x (make-array '(10) :initial-contents "abacbadeaf" + :fill-pointer 5 :element-type 'character)) + (result (substitute-if #\z (is-eql-p #\a) x :count 1))) + result) + "zbacb") + +(deftest substitute-if-string.31 + (let* ((x (make-array '(10) :initial-contents "abacbadeaf" + :fill-pointer 5 :element-type 'character)) + (result (substitute-if #\z (is-eql-p #\a) x :from-end t :count 1))) + result) + "abzcb") + +;;; Tests on bit-vectors + +(deftest substitute-if-bit-vector.1 + (let* ((orig #*) + (x (copy-seq orig)) + (result (substitute-if 0 (is-eq-p 1) x))) + (and (equalp orig x) + result)) + #*) + +(deftest substitute-if-bit-vector.2 + (let* ((orig #*) + (x (copy-seq orig)) + (result (substitute-if 1 'zerop x))) + (and (equalp orig x) + result)) + #*) + +(deftest substitute-if-bit-vector.3 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if 0 (is-eq-p 1) x))) + (and (equalp orig x) + result)) + #*000000) + +(deftest substitute-if-bit-vector.4 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if 1 #'zerop x))) + (and (equalp orig x) + result)) + #*111111) + +(deftest substitute-if-bit-vector.5 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if 1 #'zerop x :start 1))) + (and (equalp orig x) + result)) + #*011111) + +(deftest substitute-if-bit-vector.6 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if 0 (is-eq-p 1) x :start 2 :end nil))) + (and (equalp orig x) + result)) + #*010000) + +(deftest substitute-if-bit-vector.7 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if 1 #'zerop x :end 4))) + (and (equalp orig x) + result)) + #*111101) + +(deftest substitute-if-bit-vector.8 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if 0 (is-eq-p 1) x :end nil))) + (and (equalp orig x) + result)) + #*000000) + +(deftest substitute-if-bit-vector.9 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if 0 (is-eq-p 1) x :end 3))) + (and (equalp orig x) + result)) + #*000101) + +(deftest substitute-if-bit-vector.10 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if 0 (is-eq-p 1) x :start 2 :end 4))) + (and (equalp orig x) + result)) + #*010001) + +(deftest substitute-if-bit-vector.11 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if 1 #'zerop x :start 2 :end 4))) + (and (equalp orig x) + result)) + #*011101) + +(deftest substitute-if-bit-vector.12 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if 1 #'zerop x :count 1))) + (and (equalp orig x) + result)) + #*110101) + +(deftest substitute-if-bit-vector.13 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if 1 #'zerop x :count 0))) + (and (equalp orig x) + result)) + #*010101) + +(deftest substitute-if-bit-vector.14 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if 1 #'zerop x :count -1))) + (and (equalp orig x) + result)) + #*010101) + +(deftest substitute-if-bit-vector.15 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if 1 #'zerop x :count 1 :from-end t))) + (and (equalp orig x) + result)) + #*010111) + +(deftest substitute-if-bit-vector.16 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if 1 #'zerop x :count 0 :from-end t))) + (and (equalp orig x) + result)) + #*010101) + +(deftest substitute-if-bit-vector.17 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if 1 #'zerop x :count -1 :from-end t))) + (and (equalp orig x) + result)) + #*010101) + +(deftest substitute-if-bit-vector.18 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if 1 #'zerop x :count nil))) + (and (equalp orig x) + result)) + #*111111) + +(deftest substitute-if-bit-vector.19 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute-if 1 #'zerop x :count nil :from-end t))) + (and (equalp orig x) + result)) + #*111111) + +(deftest substitute-if-bit-vector.20 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #*0000000000) + (x (copy-seq orig)) + (y (substitute-if 1 #'zerop x :start i :end j :count c))) + (and (equalp orig x) + (equalp y (concatenate + 'simple-bit-vector + (make-list i :initial-element 0) + (make-list c :initial-element 1) + (make-list (- 10 (+ i c)) :initial-element 0)))))))) + t) + +(deftest substitute-if-bit-vector.21 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #*1111111111) + (x (copy-seq orig)) + (y (substitute-if 0 (is-eq-p 1) x :start i :end j :count c :from-end t))) + (and (equalp orig x) + (equalp y (concatenate + 'simple-bit-vector + (make-list (- j c) :initial-element 1) + (make-list c :initial-element 0) + (make-list (- 10 j) :initial-element 1)))))))) + t) + +;;; More tests + +(deftest substitute-if-list.24 + (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (substitute-if '(a 10) (is-eq-p 'a) x :key #'car))) + (and (equal orig x) + result)) + ((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) + +(deftest substitute-if-list.25 + (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (substitute-if '(a 10) (is-eq-p 'a) x + :key #'car :start 1 :end 5))) + (and (equal orig x) + result)) + ((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) + +(deftest substitute-if-vector.24 + (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (substitute-if '(a 10) (is-eq-p 'a) x :key #'car))) + (and (equalp orig x) + result)) + #((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) + +(deftest substitute-if-vector.25 + (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (substitute-if '(a 10) (is-eq-p 'a) x :key #'car :start 1 :end 5))) + (and (equalp orig x) + result)) + #((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) + +(deftest substitute-if-string.24 + (let* ((orig "0102342015") + (x (copy-seq orig)) + (result (substitute-if #\a (is-eq-p #\1) x :key #'nextdigit))) + (and (equalp orig x) + result)) + "a1a2342a15") + +(deftest substitute-if-string.25 + (let* ((orig "0102342015") + (x (copy-seq orig)) + (result (substitute-if #\a (is-eq-p #\1) x :key #'nextdigit :start 1 :end 6))) + (and (equalp orig x) + result)) + "01a2342015") + +(deftest substitute-if-bit-vector.26 + (let* ((orig #*00111001011010110) + (x (copy-seq orig)) + (result (substitute-if 1 (is-eq-p 1) x :key #'1+))) + (and (equalp orig x) + result)) + #*11111111111111111) + +(deftest substitute-if-bit-vector.27 + (let* ((orig #*00111001011010110) + (x (copy-seq orig)) + (result (substitute-if 1 (is-eq-p 1) x :key #'1+ :start 1 :end 10))) + (and (equalp orig x) + result)) + #*01111111111010110) + +(deftest substitute-if-bit-vector.30 + (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) + :fill-pointer 5 :element-type 'bit)) + (result (substitute-if 1 #'zerop x))) + result) + #*11111) + +(deftest substitute-if-bit-vector.31 + (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) + :fill-pointer 5 :element-type 'bit)) + (result (substitute-if 1 #'zerop x :from-end t))) + result) + #*11111) + +(deftest substitute-if-bit-vector.32 + (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) + :fill-pointer 5 :element-type 'bit)) + (result (substitute-if 1 #'zerop x :count 1))) + result) + #*11011) + +(deftest substitute-if-bit-vector.33 + (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) + :fill-pointer 5 :element-type 'bit)) + (result (substitute-if 1 #'zerop x :from-end t :count 1))) + result) + #*01111) + +(deftest substitute-if.order.1 + (let ((i 0) a b c d e f g h) + (values + (substitute-if + (progn (setf a (incf i)) 'a) + (progn (setf b (incf i)) #'null) + (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) + :count (progn (setf d (incf i)) 2) + :start (progn (setf e (incf i)) 0) + :end (progn (setf f (incf i)) 7) + :key (progn (setf g (incf i)) #'identity) + :from-end (setf h (incf i)) + ) + i a b c d e f g h)) + (nil 1 2 a 3 4 a 5) + 8 1 2 3 4 5 6 7 8) + +(deftest substitute-if.order.2 + (let ((i 0) a b c d e f g h) + (values + (substitute-if + (progn (setf a (incf i)) 'a) + (progn (setf b (incf i)) #'null) + (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) + :from-end (setf h (incf i)) + :key (progn (setf g (incf i)) #'identity) + :end (progn (setf f (incf i)) 7) + :start (progn (setf e (incf i)) 0) + :count (progn (setf d (incf i)) 2) + ) + i a b c d e f g h)) + (nil 1 2 a 3 4 a 5) + 8 1 2 3 8 7 6 5 4) + +;;; Keyword tests + +(deftest substitute-if.allow-other-keys.1 + (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t :bad t) + (1 2 a 3 1 a 3)) + +(deftest substitute-if.allow-other-keys.2 + (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :bad t :allow-other-keys t) + (1 2 a 3 1 a 3)) + +(deftest substitute-if.allow-other-keys.3 + (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t + :allow-other-keys nil :bad t) + (1 2 a 3 1 a 3)) + +(deftest substitute-if.allow-other-keys.4 + (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :bad t + :allow-other-keys t :allow-other-keys nil) + (1 2 a 3 1 a 3)) + +(deftest substitute-if.allow-other-keys.5 + (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) + :allow-other-keys t :key #'1-) + (a 2 0 3 a 0 3)) + +(deftest substitute-if.keywords.6 + (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :key #'1- :key #'identity) + (a 2 0 3 a 0 3)) + +(deftest substitute-if.allow-other-keys.7 + (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t + :bad t :allow-other-keys nil) + (1 2 a 3 1 a 3)) + +(deftest substitute-if.allow-other-keys.8 + (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys nil) + (1 2 a 3 1 a 3)) + +;;; Error cases + +(deftest substitute-if.error.1 + (classify-error (substitute-if)) + program-error) + +(deftest substitute-if.error.2 + (classify-error (substitute-if 'a)) + program-error) + +(deftest substitute-if.error.3 + (classify-error (substitute-if 'a #'null)) + program-error) + +(deftest substitute-if.error.4 + (classify-error (substitute-if 'a #'null nil 'bad t)) + program-error) + +(deftest substitute-if.error.5 + (classify-error (substitute-if 'a #'null nil 'bad t :allow-other-keys nil)) + program-error) + +(deftest substitute-if.error.6 + (classify-error (substitute-if 'a #'null nil :key)) + program-error) + +(deftest substitute-if.error.7 + (classify-error (substitute-if 'a #'null nil 1 2)) + program-error) + +(deftest substitute-if.error.8 + (classify-error (substitute-if 'a #'cons (list 'a 'b 'c))) + program-error) + +(deftest substitute-if.error.9 + (classify-error (substitute-if 'a #'car (list 'a 'b 'c))) + type-error) + +(deftest substitute-if.error.10 + (classify-error (substitute-if 'a #'identity (list 'a 'b 'c) + :key #'car)) + type-error) + +(deftest substitute-if.error.11 + (classify-error (substitute-if 'a #'identity (list 'a 'b 'c) + :key #'cons)) + program-error) diff --git a/ansi-tests/substitute.lsp b/ansi-tests/substitute.lsp new file mode 100644 index 0000000..bd17f8e --- /dev/null +++ b/ansi-tests/substitute.lsp @@ -0,0 +1,1086 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Aug 28 21:15:33 2002 +;;;; Contains: Tests for SUBSTITUTE + +(in-package :cl-test) + +(deftest substitute-list.1 + (let ((x '())) (values (substitute 'b 'a x) x)) + nil nil) + +(deftest substitute-list.2 + (let ((x '(a b a c))) (values (substitute 'b 'a x) x)) + (b b b c) + (a b a c)) + +(deftest substitute-list.3 + (let ((x '(a b a c))) (values (substitute 'b 'a x :count nil) x)) + (b b b c) + (a b a c)) + +(deftest substitute-list.4 + (let ((x '(a b a c))) (values (substitute 'b 'a x :count 2) x)) + (b b b c) + (a b a c)) + +(deftest substitute-list.5 + (let ((x '(a b a c))) (values (substitute 'b 'a x :count 1) x)) + (b b a c) + (a b a c)) + +(deftest substitute-list.6 + (let ((x '(a b a c))) (values (substitute 'b 'a x :count 0) x)) + (a b a c) + (a b a c)) + +(deftest substitute-list.7 + (let ((x '(a b a c))) (values (substitute 'b 'a x :count -1) x)) + (a b a c) + (a b a c)) + +(deftest substitute-list.8 + (let ((x '())) (values (substitute 'b 'a x :from-end t) x)) + nil nil) + +(deftest substitute-list.9 + (let ((x '(a b a c))) (values (substitute 'b 'a x :from-end t) x)) + (b b b c) + (a b a c)) + +(deftest substitute-list.10 + (let ((x '(a b a c))) (values (substitute 'b 'a x :from-end t :count nil) x)) + (b b b c) + (a b a c)) + +(deftest substitute-list.11 + (let ((x '(a b a c))) (values (substitute 'b 'a x :count 2 :from-end t) x)) + (b b b c) + (a b a c)) + +(deftest substitute-list.12 + (let ((x '(a b a c))) (values (substitute 'b 'a x :count 1 :from-end t) x)) + (a b b c) + (a b a c)) + +(deftest substitute-list.13 + (let ((x '(a b a c))) (values (substitute 'b 'a x :count 0 :from-end t) x)) + (a b a c) + (a b a c)) + +(deftest substitute-list.14 + (let ((x '(a b a c))) (values (substitute 'b 'a x :count -1 :from-end t) x)) + (a b a c) + (a b a c)) + +(deftest substitute-list.15 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute 'x 'a x :start i :end j))) + (and (equal orig x) + (equal y (nconc (make-list i :initial-element 'a) + (make-list (- j i) :initial-element 'x) + (make-list (- 10 j) :initial-element 'a))))))) + t) + +(deftest substitute-list.16 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute 'x 'a x :start i :end j :from-end t))) + (and (equal orig x) + (equal y (nconc (make-list i :initial-element 'a) + (make-list (- j i) :initial-element 'x) + (make-list (- 10 j) :initial-element 'a))))))) + t) + +(deftest substitute-list.17 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute 'x 'a x :start i :end j :count c))) + (and (equal orig x) + (equal y (nconc (make-list i :initial-element 'a) + (make-list c :initial-element 'x) + (make-list (- 10 (+ i c)) :initial-element 'a)))))))) + t) + +(deftest substitute-list.18 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute 'x 'a x :start i :end j :count c :from-end t))) + (and (equal orig x) + (equal y (nconc (make-list (- j c) :initial-element 'a) + (make-list c :initial-element 'x) + (make-list (- 10 j) :initial-element 'a)))))))) + t) + +(deftest substitute-list.19 + (let* ((orig '(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (result (substitute 'x 5 x :test #'(lambda (a b) (<= (abs (- a b)) 2))))) + (and (equal orig x) + result)) + (1 2 x x x x x 8 9)) + +(deftest substitute-list.20 + (let* ((orig '(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (c -4) + (result (substitute 'x 5 x :test #'(lambda (a b) (incf c 2) (= (+ b c) a))))) + (and (equal orig x) + result)) + (1 2 x 4 5 6 7 8 9)) + + +(deftest substitute-list.21 + (let* ((orig '(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (c 5) + (result (substitute 'x 9 x :test #'(lambda (a b) (incf c -2) (= (+ b c) a)) + :from-end t))) + (and (equal orig x) + result)) + (1 2 3 4 5 6 7 x 9)) + +(deftest substitute-list.22 + (let* ((orig '(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (c -4) + (result (substitute 'x 5 x :test-not #'(lambda (a b) (incf c 2) (/= (+ b c) a))))) + (and (equal orig x) + result)) + (1 2 x 4 5 6 7 8 9)) + + +(deftest substitute-list.23 + (let* ((orig '(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (c 5) + (result (substitute 'x 9 x :test-not #'(lambda (a b) (incf c -2) (/= (+ b c) a)) + :from-end t))) + (and (equal orig x) + result)) + (1 2 3 4 5 6 7 x 9)) + +(deftest substitute-list.24 + (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (substitute '(a 10) 'a x :key #'car))) + (and (equal orig x) + result)) + ((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) + +(deftest substitute-list.25 + (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (substitute '(a 10) 'a x :key #'car :start 1 :end 5))) + (and (equal orig x) + result)) + ((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) + +(deftest substitute-list.26 + (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (substitute '(a 10) 'a x :key #'car :test (complement #'eql)))) + (and (equal orig x) + result)) + ((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) + +(deftest substitute-list.27 + (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (substitute '(a 10) 'a x :key #'car :test-not #'eql))) + (and (equal orig x) + result)) + ((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) + +;;; Tests on vectors + +(deftest substitute-vector.1 + (let ((x #())) (values (substitute 'b 'a x) x)) + #() #()) + +(deftest substitute-vector.2 + (let ((x #(a b a c))) (values (substitute 'b 'a x) x)) + #(b b b c) + #(a b a c)) + +(deftest substitute-vector.3 + (let ((x #(a b a c))) (values (substitute 'b 'a x :count nil) x)) + #(b b b c) + #(a b a c)) + +(deftest substitute-vector.4 + (let ((x #(a b a c))) (values (substitute 'b 'a x :count 2) x)) + #(b b b c) + #(a b a c)) + +(deftest substitute-vector.5 + (let ((x #(a b a c))) (values (substitute 'b 'a x :count 1) x)) + #(b b a c) + #(a b a c)) + +(deftest substitute-vector.6 + (let ((x #(a b a c))) (values (substitute 'b 'a x :count 0) x)) + #(a b a c) + #(a b a c)) + +(deftest substitute-vector.7 + (let ((x #(a b a c))) (values (substitute 'b 'a x :count -1) x)) + #(a b a c) + #(a b a c)) + +(deftest substitute-vector.8 + (let ((x #())) (values (substitute 'b 'a x :from-end t) x)) + #() #()) + +(deftest substitute-vector.9 + (let ((x #(a b a c))) (values (substitute 'b 'a x :from-end t) x)) + #(b b b c) + #(a b a c)) + +(deftest substitute-vector.10 + (let ((x #(a b a c))) (values (substitute 'b 'a x :from-end t :count nil) x)) + #(b b b c) + #(a b a c)) + +(deftest substitute-vector.11 + (let ((x #(a b a c))) (values (substitute 'b 'a x :count 2 :from-end t) x)) + #(b b b c) + #(a b a c)) + +(deftest substitute-vector.12 + (let ((x #(a b a c))) (values (substitute 'b 'a x :count 1 :from-end t) x)) + #(a b b c) + #(a b a c)) + +(deftest substitute-vector.13 + (let ((x #(a b a c))) (values (substitute 'b 'a x :count 0 :from-end t) x)) + #(a b a c) + #(a b a c)) + +(deftest substitute-vector.14 + (let ((x #(a b a c))) (values (substitute 'b 'a x :count -1 :from-end t) x)) + #(a b a c) + #(a b a c)) + +(deftest substitute-vector.15 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute 'x 'a x :start i :end j))) + (and (equalp orig x) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array (- j i) :initial-element 'x) + (make-array (- 10 j) :initial-element 'a))))))) + t) + +(deftest substitute-vector.16 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute 'x 'a x :start i :end j :from-end t))) + (and (equalp orig x) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array (- j i) :initial-element 'x) + (make-array (- 10 j) :initial-element 'a))))))) + t) + +(deftest substitute-vector.17 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute 'x 'a x :start i :end j :count c))) + (and (equalp orig x) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array c :initial-element 'x) + (make-array (- 10 (+ i c)) :initial-element 'a)))))))) + t) + +(deftest substitute-vector.18 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute 'x 'a x :start i :end j :count c :from-end t))) + (and (equalp orig x) + (equalp y (concatenate 'simple-vector + (make-array (- j c) :initial-element 'a) + (make-array c :initial-element 'x) + (make-array (- 10 j) :initial-element 'a)))))))) + t) + +(deftest substitute-vector.19 + (let* ((orig #(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (result (substitute 'x 5 x :test #'(lambda (a b) (<= (abs (- a b)) 2))))) + (and (equalp orig x) + result)) + #(1 2 x x x x x 8 9)) + +(deftest substitute-vector.20 + (let* ((orig #(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (c -4) + (result (substitute 'x 5 x :test #'(lambda (a b) (incf c 2) (= (+ b c) a))))) + (and (equalp orig x) + result)) + #(1 2 x 4 5 6 7 8 9)) + + +(deftest substitute-vector.21 + (let* ((orig #(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (c 5) + (result (substitute 'x 9 x :test #'(lambda (a b) (incf c -2) (= (+ b c) a)) + :from-end t))) + (and (equalp orig x) + result)) + #(1 2 3 4 5 6 7 x 9)) + +(deftest substitute-vector.22 + (let* ((orig #(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (c -4) + (result (substitute 'x 5 x :test-not #'(lambda (a b) (incf c 2) (/= (+ b c) a))))) + (and (equalp orig x) + result)) + #(1 2 x 4 5 6 7 8 9)) + + +(deftest substitute-vector.23 + (let* ((orig #(1 2 3 4 5 6 7 8 9)) + (x (copy-seq orig)) + (c 5) + (result (substitute 'x 9 x :test-not #'(lambda (a b) (incf c -2) (/= (+ b c) a)) + :from-end t))) + (and (equalp orig x) + result)) + #(1 2 3 4 5 6 7 x 9)) + +(deftest substitute-vector.24 + (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (substitute '(a 10) 'a x :key #'car))) + (and (equalp orig x) + result)) + #((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) + +(deftest substitute-vector.25 + (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (substitute '(a 10) 'a x :key #'car :start 1 :end 5))) + (and (equalp orig x) + result)) + #((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) + +(deftest substitute-vector.26 + (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (substitute '(a 10) 'a x :key #'car :test (complement #'eql)))) + (and (equalp orig x) + result)) + #((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) + +(deftest substitute-vector.27 + (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) + (x (copy-seq orig)) + (result (substitute '(a 10) 'a x :key #'car :test-not #'eql))) + (and (equalp orig x) + result)) + #((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) + +(deftest substitute-vector.28 + (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) + :fill-pointer 5)) + (result (substitute 'z 'a x))) + result) + #(z b z c b)) + +(deftest substitute-vector.29 + (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) + :fill-pointer 5)) + (result (substitute 'z 'a x :from-end t))) + result) + #(z b z c b)) + +(deftest substitute-vector.30 + (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) + :fill-pointer 5)) + (result (substitute 'z 'a x :count 1))) + result) + #(z b a c b)) + +(deftest substitute-vector.31 + (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) + :fill-pointer 5)) + (result (substitute 'z 'a x :from-end t :count 1))) + result) + #(a b z c b)) + +;;; Tests on strings + +(deftest substitute-string.1 + (let ((x "")) (values (substitute #\b #\a x) x)) + "" "") + +(deftest substitute-string.2 + (let ((x "abac")) (values (substitute #\b #\a x) x)) + "bbbc" + "abac") + +(deftest substitute-string.3 + (let ((x "abac")) (values (substitute #\b #\a x :count nil) x)) + "bbbc" + "abac") + +(deftest substitute-string.4 + (let ((x "abac")) (values (substitute #\b #\a x :count 2) x)) + "bbbc" + "abac") + +(deftest substitute-string.5 + (let ((x "abac")) (values (substitute #\b #\a x :count 1) x)) + "bbac" + "abac") + +(deftest substitute-string.6 + (let ((x "abac")) (values (substitute #\b #\a x :count 0) x)) + "abac" + "abac") + +(deftest substitute-string.7 + (let ((x "abac")) (values (substitute #\b #\a x :count -1) x)) + "abac" + "abac") + +(deftest substitute-string.8 + (let ((x "")) (values (substitute #\b #\a x :from-end t) x)) + "" "") + +(deftest substitute-string.9 + (let ((x "abac")) (values (substitute #\b #\a x :from-end t) x)) + "bbbc" + "abac") + +(deftest substitute-string.10 + (let ((x "abac")) (values (substitute #\b #\a x :from-end t :count nil) x)) + "bbbc" + "abac") + +(deftest substitute-string.11 + (let ((x "abac")) (values (substitute #\b #\a x :count 2 :from-end t) x)) + "bbbc" + "abac") + +(deftest substitute-string.12 + (let ((x "abac")) (values (substitute #\b #\a x :count 1 :from-end t) x)) + "abbc" + "abac") + +(deftest substitute-string.13 + (let ((x "abac")) (values (substitute #\b #\a x :count 0 :from-end t) x)) + "abac" + "abac") + +(deftest substitute-string.14 + (let ((x "abac")) (values (substitute #\b #\a x :count -1 :from-end t) x)) + "abac" + "abac") + +(deftest substitute-string.15 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (substitute #\x #\a x :start i :end j))) + (and (equalp orig x) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array (- j i) :initial-element #\x) + (make-array (- 10 j) :initial-element #\a))))))) + t) + +(deftest substitute-string.16 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (substitute #\x #\a x :start i :end j :from-end t))) + (and (equalp orig x) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array (- j i) :initial-element #\x) + (make-array (- 10 j) :initial-element #\a))))))) + t) + +(deftest substitute-string.17 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (substitute #\x #\a x :start i :end j :count c))) + (and (equalp orig x) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array c :initial-element #\x) + (make-array (- 10 (+ i c)) :initial-element #\a)))))))) + t) + +(deftest substitute-string.18 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (substitute #\x #\a x :start i :end j :count c :from-end t))) + (and (equalp orig x) + (equalp y (concatenate 'simple-string + (make-array (- j c) :initial-element #\a) + (make-array c :initial-element #\x) + (make-array (- 10 j) :initial-element #\a)))))))) + t) + +(deftest substitute-string.19 + (let* ((orig "123456789") + (x (copy-seq orig)) + (result (substitute #\x #\5 x :test #'(lambda (a b) + (setq a (read-from-string (string a))) + (setq b (read-from-string (string b))) + (<= (abs (- a b)) 2))))) + (and (equalp orig x) + result)) + "12xxxxx89") + +(deftest substitute-string.20 + (let* ((orig "123456789") + (x (copy-seq orig)) + (c -4) + (result (substitute #\x #\5 x :test #'(lambda (a b) + (setq a (read-from-string (string a))) + (setq b (read-from-string (string b))) + (incf c 2) (= (+ b c) a))))) + (and (equalp orig x) + result)) + "12x456789") + + +(deftest substitute-string.21 + (let* ((orig "123456789") + (x (copy-seq orig)) + (c 5) + (result (substitute #\x #\9 x :test #'(lambda (a b) + (setq a (read-from-string (string a))) + (setq b (read-from-string (string b))) + (incf c -2) (= (+ b c) a)) + :from-end t))) + (and (equalp orig x) + result)) + "1234567x9") + +(deftest substitute-string.22 + (let* ((orig "123456789") + (x (copy-seq orig)) + (c -4) + (result (substitute #\x #\5 x :test-not #'(lambda (a b) + (setq a (read-from-string (string a))) + (setq b (read-from-string (string b))) + (incf c 2) (/= (+ b c) a))))) + (and (equalp orig x) + result)) + "12x456789") + + +(deftest substitute-string.23 + (let* ((orig "123456789") + (x (copy-seq orig)) + (c 5) + (result (substitute #\x #\9 x :test-not #'(lambda (a b) + (setq a (read-from-string (string a))) + (setq b (read-from-string (string b))) + (incf c -2) (/= (+ b c) a)) + :from-end t))) + (and (equalp orig x) + result)) + "1234567x9") + +(deftest substitute-string.24 + (let* ((orig "0102342015") + (x (copy-seq orig)) + (result (substitute #\a #\1 x :key #'nextdigit))) + (and (equalp orig x) + result)) + "a1a2342a15") + +(deftest substitute-string.25 + (let* ((orig "0102342015") + (x (copy-seq orig)) + (result (substitute #\a #\1 x :key #'nextdigit :start 1 :end 6))) + (and (equalp orig x) + result)) + "01a2342015") + +(deftest substitute-string.26 + (let* ((orig "0102342015") + (x (copy-seq orig)) + (result (substitute #\a #\1 x :key #'nextdigit :test (complement #'eql)))) + (and (equalp orig x) + result)) + "0a0aaaa0aa") + +(deftest substitute-string.27 + (let* ((orig "0102342015") + (x (copy-seq orig)) + (result (substitute #\a #\1 x :key #'nextdigit :test-not #'eql))) + (and (equalp orig x) + result)) + "0a0aaaa0aa") + +(deftest substitute-string.28 + (let* ((x (make-array '(10) :initial-contents "abacbadeaf" + :fill-pointer 5 :element-type 'character)) + (result (substitute #\z #\a x))) + result) + "zbzcb") + +(deftest substitute-string.29 + (let* ((x (make-array '(10) :initial-contents "abacbadeaf" + :fill-pointer 5 :element-type 'character)) + (result (substitute #\z #\a x :from-end t))) + result) + "zbzcb") + +(deftest substitute-string.30 + (let* ((x (make-array '(10) :initial-contents "abacbadeaf" + :fill-pointer 5 :element-type 'character)) + (result (substitute #\z #\a x :count 1))) + result) + "zbacb") + +(deftest substitute-string.31 + (let* ((x (make-array '(10) :initial-contents "abacbadeaf" + :fill-pointer 5 :element-type 'character)) + (result (substitute #\z #\a x :from-end t :count 1))) + result) + "abzcb") + +;;; Tests on bit-vectors + +(deftest substitute-bit-vector.1 + (let* ((orig #*) + (x (copy-seq orig)) + (result (substitute 0 1 x))) + (and (equalp orig x) + result)) + #*) + +(deftest substitute-bit-vector.2 + (let* ((orig #*) + (x (copy-seq orig)) + (result (substitute 1 0 x))) + (and (equalp orig x) + result)) + #*) + +(deftest substitute-bit-vector.3 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute 0 1 x))) + (and (equalp orig x) + result)) + #*000000) + +(deftest substitute-bit-vector.4 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute 1 0 x))) + (and (equalp orig x) + result)) + #*111111) + +(deftest substitute-bit-vector.5 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute 1 0 x :start 1))) + (and (equalp orig x) + result)) + #*011111) + +(deftest substitute-bit-vector.6 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute 0 1 x :start 2 :end nil))) + (and (equalp orig x) + result)) + #*010000) + +(deftest substitute-bit-vector.7 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute 1 0 x :end 4))) + (and (equalp orig x) + result)) + #*111101) + +(deftest substitute-bit-vector.8 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute 0 1 x :end nil))) + (and (equalp orig x) + result)) + #*000000) + +(deftest substitute-bit-vector.9 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute 0 1 x :end 3))) + (and (equalp orig x) + result)) + #*000101) + +(deftest substitute-bit-vector.10 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute 0 1 x :start 2 :end 4))) + (and (equalp orig x) + result)) + #*010001) + +(deftest substitute-bit-vector.11 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute 1 0 x :start 2 :end 4))) + (and (equalp orig x) + result)) + #*011101) + +(deftest substitute-bit-vector.12 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute 1 0 x :count 1))) + (and (equalp orig x) + result)) + #*110101) + +(deftest substitute-bit-vector.13 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute 1 0 x :count 0))) + (and (equalp orig x) + result)) + #*010101) + +(deftest substitute-bit-vector.14 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute 1 0 x :count -1))) + (and (equalp orig x) + result)) + #*010101) + +(deftest substitute-bit-vector.15 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute 1 0 x :count 1 :from-end t))) + (and (equalp orig x) + result)) + #*010111) + +(deftest substitute-bit-vector.16 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute 1 0 x :count 0 :from-end t))) + (and (equalp orig x) + result)) + #*010101) + +(deftest substitute-bit-vector.17 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute 1 0 x :count -1 :from-end t))) + (and (equalp orig x) + result)) + #*010101) + +(deftest substitute-bit-vector.18 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute 1 0 x :count nil))) + (and (equalp orig x) + result)) + #*111111) + +(deftest substitute-bit-vector.19 + (let* ((orig #*010101) + (x (copy-seq orig)) + (result (substitute 1 0 x :count nil :from-end t))) + (and (equalp orig x) + result)) + #*111111) + +(deftest substitute-bit-vector.20 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #*0000000000) + (x (copy-seq orig)) + (y (substitute 1 0 x :start i :end j :count c))) + (and (equalp orig x) + (equalp y (concatenate + 'simple-bit-vector + (make-list i :initial-element 0) + (make-list c :initial-element 1) + (make-list (- 10 (+ i c)) :initial-element 0)))))))) + t) + +(deftest substitute-bit-vector.21 + (loop for i from 0 to 9 always + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #*1111111111) + (x (copy-seq orig)) + (y (substitute 0 1 x :start i :end j :count c :from-end t))) + (and (equalp orig x) + (equalp y (concatenate + 'simple-bit-vector + (make-list (- j c) :initial-element 1) + (make-list c :initial-element 0) + (make-list (- 10 j) :initial-element 1)))))))) + t) + +(deftest substitute-bit-vector.22 + (let* ((orig #*0101010101) + (x (copy-seq orig)) + (c 0) + (result (substitute 1 0 x :test #'(lambda (a b) (incf c) (and (<= 2 c 5) (= a b)))))) + (and (equalp orig x) + result)) + #*0111110101) + +(deftest substitute-bit-vector.23 + (let* ((orig #*0101010101) + (x (copy-seq orig)) + (c 0) + (result (substitute 1 0 x :test-not #'(lambda (a b) (incf c) + (not (and (<= 2 c 5) (= a b))))))) + (and (equalp orig x) + result)) + #*0111110101) + +(deftest substitute-bit-vector.24 + (let* ((orig #*0101010101) + (x (copy-seq orig)) + (c 0) + (result (substitute 1 0 x :test #'(lambda (a b) (incf c) (and (<= 2 c 5) (= a b))) + :from-end t))) + (and (equalp orig x) + result)) + #*0101011111) + +(deftest substitute-bit-vector.25 + (let* ((orig #*0101010101) + (x (copy-seq orig)) + (c 0) + (result (substitute 1 0 x :test-not #'(lambda (a b) (incf c) + (not (and (<= 2 c 5) (= a b)))) + :from-end t))) + (and (equalp orig x) + result)) + #*0101011111) + +(deftest substitute-bit-vector.26 + (let* ((orig #*00111001011010110) + (x (copy-seq orig)) + (result (substitute 1 1 x :key #'1+))) + (and (equalp orig x) + result)) + #*11111111111111111) + +(deftest substitute-bit-vector.27 + (let* ((orig #*00111001011010110) + (x (copy-seq orig)) + (result (substitute 1 1 x :key #'1+ :start 1 :end 10))) + (and (equalp orig x) + result)) + #*01111111111010110) + +(deftest substitute-bit-vector.28 + (let* ((orig #*00111001011010110) + (x (copy-seq orig)) + (result (substitute 0 1 x :key #'1+ :test (complement #'eql)))) + (and (equalp orig x) + result)) + #*00000000000000000) + +(deftest substitute-bit-vector.29 + (let* ((orig #*00111001011010110) + (x (copy-seq orig)) + (result (substitute 0 1 x :key #'1+ :test-not #'eql))) + (and (equalp orig x) + result)) + #*00000000000000000) + +(deftest substitute-bit-vector.30 + (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) + :fill-pointer 5 :element-type 'bit)) + (result (substitute 1 0 x))) + result) + #*11111) + +(deftest substitute-bit-vector.31 + (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) + :fill-pointer 5 :element-type 'bit)) + (result (substitute 1 0 x :from-end t))) + result) + #*11111) + +(deftest substitute-bit-vector.32 + (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) + :fill-pointer 5 :element-type 'bit)) + (result (substitute 1 0 x :count 1))) + result) + #*11011) + +(deftest substitute-bit-vector.33 + (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) + :fill-pointer 5 :element-type 'bit)) + (result (substitute 1 0 x :from-end t :count 1))) + result) + #*01111) + +(deftest substitute.order.1 + (let ((i 0) a b c d e f g h) + (values + (substitute + (progn (setf a (incf i)) 'a) + (progn (setf b (incf i)) nil) + (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) + :count (progn (setf d (incf i)) 2) + :start (progn (setf e (incf i)) 0) + :end (progn (setf f (incf i)) 7) + :key (progn (setf g (incf i)) #'identity) + :from-end (setf h (incf i)) + ) + i a b c d e f g h)) + (nil 1 2 a 3 4 a 5) + 8 1 2 3 4 5 6 7 8) + +(deftest substitute.order.2 + (let ((i 0) a b c d e f g h) + (values + (substitute + (progn (setf a (incf i)) 'a) + (progn (setf b (incf i)) nil) + (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) + :from-end (setf h (incf i)) + :key (progn (setf g (incf i)) #'identity) + :end (progn (setf f (incf i)) 7) + :start (progn (setf e (incf i)) 0) + :count (progn (setf d (incf i)) 2) + ) + i a b c d e f g h)) + (nil 1 2 a 3 4 a 5) + 8 1 2 3 8 7 6 5 4) + +;;; Keyword tests + +(deftest substitute.allow-other-keys.1 + (substitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys t :bad t) + (1 2 a 3 1 a 3)) + +(deftest substitute.allow-other-keys.2 + (substitute 'a 0 (list 1 2 0 3 1 0 3) :bad t :allow-other-keys t) + (1 2 a 3 1 a 3)) + +(deftest substitute.allow-other-keys.3 + (substitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys t + :allow-other-keys nil :bad t) + (1 2 a 3 1 a 3)) + +(deftest substitute.allow-other-keys.4 + (substitute 'a 0 (list 1 2 0 3 1 0 3) :bad t + :allow-other-keys t :allow-other-keys nil) + (1 2 a 3 1 a 3)) + +(deftest substitute.allow-other-keys.5 + (substitute 'a 0 (list 1 2 0 3 1 0 3) + :allow-other-keys t :key #'1-) + (a 2 0 3 a 0 3)) + +(deftest substitute.keywords.6 + (substitute 'a 0 (list 1 2 0 3 1 0 3) :key #'1- :key #'identity) + (a 2 0 3 a 0 3)) + +(deftest substitute.allow-other-keys.7 + (substitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys t + :bad t :allow-other-keys nil) + (1 2 a 3 1 a 3)) + +(deftest substitute.allow-other-keys.8 + (substitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys nil) + (1 2 a 3 1 a 3)) + +;;; Error cases + +(deftest substitute.error.1 + (classify-error (substitute)) + program-error) + +(deftest substitute.error.2 + (classify-error (substitute 'a)) + program-error) + +(deftest substitute.error.3 + (classify-error (substitute 'a 'b)) + program-error) + +(deftest substitute.error.4 + (classify-error (substitute 'a 'b nil 'bad t)) + program-error) + +(deftest substitute.error.5 + (classify-error (substitute 'a 'b nil 'bad t :allow-other-keys nil)) + program-error) + +(deftest substitute.error.6 + (classify-error (substitute 'a 'b nil :key)) + program-error) + +(deftest substitute.error.7 + (classify-error (substitute 'a 'b nil 1 2)) + program-error) + +(deftest substitute.error.8 + (classify-error (substitute 'a 'b (list 'a 'b 'c) :test #'identity)) + program-error) + +(deftest substitute.error.9 + (classify-error (substitute 'a 'b (list 'a 'b 'c) :test-not #'identity)) + program-error) + +(deftest substitute.error.10 + (classify-error (substitute 'a 'b (list 'a 'b 'c) :key #'cons)) + program-error) + +(deftest substitute.error.11 + (classify-error (substitute 'a 'b (list 'a 'b 'c) :key #'car)) + type-error) + diff --git a/ansi-tests/subtypep-array.lsp b/ansi-tests/subtypep-array.lsp new file mode 100644 index 0000000..fde2604 --- /dev/null +++ b/ansi-tests/subtypep-array.lsp @@ -0,0 +1,98 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 1 16:23:57 2003 +;;;; Contains: Tests of SUBTYPEP on array types + +(in-package :cl-test) + +;;; *array-element-types* is defined in ansi-aux.lsp + +(deftest subtypep.array.1 + (let ((array-types (cons (find-class 'array) + '(array (array) (array *) (array * *))))) + (loop for tp1 in array-types append + (loop for tp2 in array-types + unless (subtypep tp1 tp2) + collect (list tp1 tp2)))) + nil) + +(deftest subtypep.array.2 + (and (subtypep* '(array t) '(array t *)) + (subtypep* '(array t *) '(array t)) + t) + t) + +(deftest subtypep.array.3 + (loop for i from 0 below (min 16 array-rank-limit) + for type = `(array * ,i) + for type2 = `(array * ,(make-list i :initial-element '*)) + unless (and (subtypep type 'array) + (subtypep type '(array)) + (subtypep type '(array *)) + (subtypep type '(array * *)) + (subtypep type type2)) + collect type) + nil) + +(deftest subtypep.array.4 + (loop for i from 0 below (min 16 array-rank-limit) + for type = `(array t ,i) + for type2 = `(array t ,(make-list i :initial-element '*)) + unless (and (subtypep type '(array t)) + (subtypep type '(array t *)) + (subtypep type type2)) + collect type) + nil) + +(deftest subtypep.array.5 + (loop + for element-type in (cons '* *array-element-types*) + nconc + (loop for i from 0 below (min 16 array-rank-limit) + for type = `(array ,element-type ,i) + for type2 = `(array ,element-type ,(make-list i :initial-element '0)) + for type3 = `(array ,element-type ,(make-list i :initial-element '1)) + unless + (and (subtypep type2 type) + (subtypep type3 type) + (loop for j from 0 to i + always + (and + (subtypep + `(array ,element-type + (,@(make-list j :initial-element '*) + ,@(make-list (- i j) :initial-element 2))) + type) + (subtypep + `(array ,element-type + (,@(make-list j :initial-element 2) + ,@(make-list (- i j) :initial-element '*))) + type)))) + collect type)) + nil) + +(deftest subtypep.aray.6 + (loop + for etype in (cons '* *array-element-types*) + append + (check-equivalence + `(and (array ,etype (* 10 * * *)) + (array ,etype (* * * 29 *))) + `(array ,etype (* 10 * 29 *)))) + nil) + +(deftest subtypep.aray.7 + (let ((etypes *array-element-types*)) + (loop + for etp1 in etypes + for uaetp1 = (upgraded-array-element-type etp1) + append + (loop for etp2 in etypes + for uaetp2 = (upgraded-array-element-type etp2) + when (equal (multiple-value-list (subtypep* uaetp1 uaetp2)) + '(nil t)) + append (check-disjointness `(array ,etp1) `(array ,etp2))))) + nil) + + + \ No newline at end of file diff --git a/ansi-tests/subtypep-cons.lsp b/ansi-tests/subtypep-cons.lsp new file mode 100644 index 0000000..76d4f5b --- /dev/null +++ b/ansi-tests/subtypep-cons.lsp @@ -0,0 +1,202 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Feb 15 11:57:03 2003 +;;;; Contains: Tests for subtype relationships on cons types + +(in-package :cl-test) + +;;; SUBTYPEP on CONS types + +(defvar *cons-types* + '(cons (cons) (cons *) (cons * *) (cons t) (cons t t) + (cons t *) (cons * t))) + +(deftest subtypep.cons.1 + (loop for t1 in *cons-types* + append (loop for t2 in *cons-types* + unless (equal (mapcar #'notnot + (multiple-value-list + (subtypep t1 t2))) + '(t t)) + collect (list t1 t2))) + nil) + +(deftest subtypep.cons.2 + (loop for t1 in '((cons nil) (cons nil *) (cons nil t) + (cons * nil) (cons t nil) (cons nil nil)) + unless (subtypep t1 nil) + collect t1) + nil) + +(deftest subtypep.cons.3 + (check-equivalence '(and (cons symbol *) (cons * symbol)) + '(cons symbol symbol)) + nil) + +(deftest subtypep.cons.4 + (check-equivalence '(and (cons (integer 0 10) *) + (cons (integer 5 15) (integer 10 20)) + (cons * (integer 15 25))) + '(cons (integer 5 10) (integer 15 20))) + nil) + +(deftest subtypep.cons.5 + (check-equivalence + '(and cons (not (cons symbol symbol))) + '(or (cons (not symbol) *) + (cons * (not symbol)))) + nil) + +(deftest subtypep.cons.6 + (check-equivalence + '(or (cons integer symbol) (cons integer integer) + (cons symbol integer) (cons symbol symbol)) + '(cons (or integer symbol) (or integer symbol))) + nil) + +(deftest subtypep.cons.7 + (check-equivalence + '(or (cons (integer 0 8) (integer 5 15)) + (cons (integer 0 7) (integer 0 6)) + (cons (integer 6 15) (integer 0 9)) + (cons (integer 3 15) (integer 4 15))) + '(cons (integer 0 15) (integer 0 15))) + nil) + +(deftest subtypep.cons.8 + (check-equivalence + '(or + (cons integer (cons symbol integer)) + (cons symbol (cons integer symbol)) + (cons symbol (cons symbol integer)) + (cons symbol (cons integer integer)) + (cons integer (cons integer symbol)) + (cons symbol (cons symbol symbol)) + (cons integer (cons integer integer)) + (cons integer (cons symbol symbol))) + '(cons (or symbol integer) + (cons (or symbol integer) (or symbol integer)))) + nil) + +(deftest subtypep.cons.9 + (check-equivalence + '(or + (cons (integer 0 (3)) (integer 0 (6))) + (cons (integer 3 (9)) (integer 0 (3))) + (cons (integer 0 (6)) (integer 6 (9))) + (cons (integer 6 (9)) (integer 3 (9))) + (cons (integer 3 (6)) (integer 3 (6)))) + '(cons (integer 0 (9)) (integer 0 (9)))) + nil) + +(deftest subtypep.cons.10 + (check-equivalence + '(or + (cons (rational 0 (3)) (rational 0 (6))) + (cons (rational 3 (9)) (rational 0 (3))) + (cons (rational 0 (6)) (rational 6 (9))) + (cons (rational 6 (9)) (rational 3 (9))) + (cons (rational 3 (6)) (rational 3 (6)))) + '(cons (rational 0 (9)) (rational 0 (9)))) + nil) + +(deftest subtypep.cons.11 + (check-equivalence + '(or + (cons (real 0 (3)) (real 0 (6))) + (cons (real 3 (9)) (real 0 (3))) + (cons (real 0 (6)) (real 6 (9))) + (cons (real 6 (9)) (real 3 (9))) + (cons (real 3 (6)) (real 3 (6)))) + '(cons (real 0 (9)) (real 0 (9)))) + nil) + +;;; Test suggested by C.R. +(deftest subtypep.cons.12 + (check-all-not-subtypep + '(cons (or integer symbol) + (or integer symbol)) + '(or (cons integer symbol) + (cons symbol integer))) + nil) + +(deftest subtypep.cons.13 + (check-all-not-subtypep '(not list) 'cons) + nil) + + +;;; a -> b, a ==> b +(deftest subtypep.cons.14 + (check-all-subtypep + '(and (or (cons (not symbol)) (cons * integer)) + (cons symbol)) + '(cons * integer)) + nil) + +;;; a -> b, not b ==> not a +(deftest subtypep.cons.15 + (check-all-subtypep + '(and (or (cons (not symbol)) (cons * integer)) + (cons * (not integer))) + '(cons (not symbol))) + nil) + +;;; (and (or a b) (or (not b) c)) ==> (or a c) +(deftest subtypep.cons.16 + (check-all-subtypep + '(and (or (cons symbol (cons * *)) + (cons * (cons integer *))) + (or (cons * (cons (not integer) *)) + (cons * (cons * float)))) + '(or (cons symbol (cons * *)) + (cons * (cons * float)))) + nil) + +(deftest subtypep.cons.17 + (check-all-subtypep + '(and (or (cons symbol (cons * *)) + (cons * (cons integer *))) + (or (cons * (cons (not integer))) + (cons * (cons * float))) + (or (cons * (cons * (not float))) + (cons symbol (cons * *)))) + '(cons symbol)) + nil) + +(deftest subtypep.cons.18 + (check-all-subtypep + '(cons symbol) + '(or (cons symbol (not integer)) + (cons * integer))) + nil) + +(deftest subtypep.cons.19 + (check-equivalence + '(or + (cons (eql a) (eql x)) + (cons (eql b) (eql y)) + (cons (eql c) (eql z)) + (cons (eql a) (eql y)) + (cons (eql b) (eql z)) + (cons (eql c) (eql x)) + (cons (eql a) (eql z)) + (cons (eql b) (eql x)) + (cons (eql c) (eql y))) + '(cons (member a b c) (member x y z))) + nil) + +(deftest subtypep.cons.20 + (check-equivalence + '(or + (cons (eql a) (eql x)) + (cons (eql b) (eql y)) + (cons (eql a) (eql y)) + (cons (eql b) (eql z)) + (cons (eql c) (eql x)) + (cons (eql a) (eql z)) + (cons (eql b) (eql x)) + (cons (eql c) (eql y))) + '(and (cons (member a b c) (member x y z)) + (not (cons (eql c) (eql z))))) + nil) + diff --git a/ansi-tests/subtypep-eql.lsp b/ansi-tests/subtypep-eql.lsp new file mode 100644 index 0000000..1c7192e --- /dev/null +++ b/ansi-tests/subtypep-eql.lsp @@ -0,0 +1,54 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Feb 15 11:58:43 2003 +;;;; Contains: Tests for subtype relationships on EQL types + +(in-package :cl-test) + +(deftest subtypep.eql.1 + (let ((s1 (copy-seq "abc")) + (s2 (copy-seq "abc"))) + (let ((t1 `(eql ,s1)) + (t2 `(eql ,s2))) + (cond + ((subtypep t1 t2) "T1 is subtype of T2") + ((subtypep t2 t1) "T2 is subtype of T1") + (t (check-disjointness t1 t2))))) + nil) + +(deftest subtypep.eql.2 + (let ((s1 (copy-seq '(a b c))) + (s2 (copy-seq '(a b c)))) + (let ((t1 `(eql ,s1)) + (t2 `(eql ,s2))) + (cond + ((subtypep t1 t2) "T1 is subtype of T2") + ((subtypep t2 t1) "T2 is subtype of T1") + (t (check-disjointness t1 t2))))) + nil) + +(deftest subtypep.eql.3 + (let ((i1 (1+ most-positive-fixnum)) + (i2 (1+ most-positive-fixnum))) + (check-equivalence `(eql ,i1) `(eql ,i2))) + nil) + +(deftest subtypep.eql.4 + (check-equivalence '(and (eql a) (eql b)) nil) + nil) + +(deftest subtypep.eql.5 + (check-all-subtypep '(eql a) '(satisfies symbolp)) + nil) + +(deftest subtypep.eql.6 + (check-disjointness '(eql 17) '(satisfies symbolp)) + nil) + +(deftest subtypep.eql.7 + (check-all-subtypep '(eql nil) '(satisfies symbolp)) + nil) + +(deftest subtypep.eql.8 + (check-all-not-subtypep '(satisfies symbolp) '(eql a)) + nil) diff --git a/ansi-tests/subtypep-float.lsp b/ansi-tests/subtypep-float.lsp new file mode 100644 index 0000000..48a23f6 --- /dev/null +++ b/ansi-tests/subtypep-float.lsp @@ -0,0 +1,175 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Feb 15 11:55:37 2003 +;;;; Contains: Tests for subtype relationships on float types + +(in-package :cl-test) + +;;;;;;; + +(deftest subtypep.float.1 + (loop for tp in +float-types+ + append (check-subtypep tp 'float t t)) + nil) + +(deftest subtypep.float.2 + (if (subtypep 'short-float 'long-float) + (loop for tp in +float-types+ + append + (loop for tp2 in +float-types+ + append (check-subtypep tp tp2 t t))) + nil) + nil) + +(deftest subtypep.float.3 + (if (and (not (subtypep 'short-float 'single-float)) + (subtypep 'single-float 'long-float)) + (append + (check-equivalence 'single-float 'double-float) + (check-equivalence 'single-float 'long-float) + (check-equivalence 'double-float 'long-float) + (classes-are-disjoint 'short-float 'single-float) + (classes-are-disjoint 'short-float 'double-float) + (classes-are-disjoint 'short-float 'long-float)) + nil) + nil) + +(deftest subtypep.float.4 + (if (and (subtypep 'single-float 'short-float) + (subtypep 'double-float 'long-float) + (not (subtypep 'short-float 'double-float))) + (append + (check-equivalence 'short-float 'single-float) + (check-equivalence 'double-float 'long-float) + (loop for tp in '(short-float single-float) + append + (loop for tp2 in '(double-float long-float) + append (classes-are-disjoint tp tp2)))) + nil) + nil) + +(deftest subtypep.float.5 + (if (and (not (subtypep 'single-float 'short-float)) + (not (subtypep 'single-float 'double-float)) + (subtypep 'double-float 'long-float)) + (append + (classes-are-disjoint 'short-float 'single-float) + (classes-are-disjoint 'short-float 'double-float) + (classes-are-disjoint 'short-float 'long-float) + (classes-are-disjoint 'single-float 'double-float) + (classes-are-disjoint 'single-float 'long-float) + (check-equivalence 'double-float 'long-float)) + nil) + nil) + +(deftest subtypep.float.6 + (if (and (subtypep 'single-float 'short-float) + (not (subtypep 'single-float 'double-float)) + (not (subtypep 'double-float 'long-float))) + (append + (check-equivalence 'short-float 'single-float) + (classes-are-disjoint 'single-float 'double-float) + (classes-are-disjoint 'single-float 'long-float) + (classes-are-disjoint 'double-float 'long-float)) + nil) + nil) + +(deftest subtypep.float.7 + (if (and (not (subtypep 'single-float 'short-float)) + (not (subtypep 'single-float 'double-float)) + (not (subtypep 'double-float 'long-float))) + (loop for tp in +float-types+ + append + (loop for tp2 in +float-types+ + unless (eq tp tp2) + append (classes-are-disjoint tp tp2))) + nil) + nil) + +(deftest subtypep.float.8 + (subtypep* '(short-float 0.0s0 10.0s0) '(short-float 0.0s0 11.0s0)) + t t) + +(deftest subtypep.float.9 + (subtypep* '(single-float 0.0f0 10.0f0) '(single-float 0.0f0 11.0f0)) + t t) + +(deftest subtypep.float.10 + (subtypep* '(double-float 0.0d0 10.0d0) '(double-float 0.0d0 11.0d0)) + t t) + +(deftest subtypep.float.11 + (subtypep* '(long-float 0.0l0 10.0l0) '(long-float 0.0l0 11.0l0)) + t t) + +(deftest subtypep.float.12 + (subtypep* '(short-float 0.0s0 11.0s0) '(short-float 0.0s0 10.0s0)) + nil t) + +(deftest subtypep.float.13 + (subtypep* '(single-float 0.0f0 11.0f0) '(single-float 0.0f0 10.0f0)) + nil t) + +(deftest subtypep.float.14 + (subtypep* '(double-float 0.0d0 11.0d0) '(double-float 0.0d0 10.0d0)) + nil t) + +(deftest subtypep.float.15 + (subtypep* '(long-float 0.0l0 11.0l0) '(long-float 0.0l0 10.0l0)) + nil t) + +(deftest subtypep.float.16 + (subtypep* '(short-float 0.0s0 (10.0s0)) '(short-float 0.0s0 10.0s0)) + t t) + +(deftest subtypep.float.17 + (subtypep* '(single-float 0.0f0 (10.0f0)) '(single-float 0.0f0 10.0f0)) + t t) + +(deftest subtypep.float.18 + (subtypep* '(double-float 0.0d0 (10.0d0)) '(double-float 0.0d0 10.0d0)) + t t) + +(deftest subtypep.float.19 + (subtypep* '(long-float 0.0l0 (10.0l0)) '(long-float 0.0l0 10.0l0)) + t t) + +(deftest subtypep.float.20 + (subtypep* '(short-float 0.0s0 10.0s0) '(short-float 0.0s0 (10.0s0))) + nil t) + +(deftest subtypep.float.21 + (subtypep* '(single-float 0.0f0 10.0f0) '(single-float 0.0f0 (10.0f0))) + nil t) + +(deftest subtypep.float.22 + (subtypep* '(double-float 0.0d0 10.0d0) '(double-float 0.0d0 (10.0d0))) + nil t) + +(deftest subtypep.float.23 + (subtypep* '(long-float 0.0l0 10.0l0) '(long-float 0.0l0 (10.0l0))) + nil t) + +(deftest subtypep.float.24 + (check-equivalence '(and (short-float 0.0s0 2.0s0) + (short-float 1.0s0 3.0s0)) + '(short-float 1.0s0 2.0s0)) + nil) + +(deftest subtypep.float.25 + (check-equivalence '(and (single-float 0.0f0 2.0f0) + (single-float 1.0f0 3.0f0)) + '(single-float 1.0f0 2.0f0)) + nil) + +(deftest subtypep.float.26 + (check-equivalence '(and (double-float 0.0d0 2.0d0) + (double-float 1.0d0 3.0d0)) + '(double-float 1.0d0 2.0d0)) + nil) + +(deftest subtypep.float.27 + (check-equivalence '(and (long-float 0.0l0 2.0l0) + (long-float 1.0l0 3.0l0)) + '(long-float 1.0l0 2.0l0)) + nil) diff --git a/ansi-tests/subtypep-integer.lsp b/ansi-tests/subtypep-integer.lsp new file mode 100644 index 0000000..ead0fe1 --- /dev/null +++ b/ansi-tests/subtypep-integer.lsp @@ -0,0 +1,434 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Feb 15 11:54:05 2003 +;;;; Contains: Tests for subtype relationships on integer types + +(in-package :cl-test) + +(deftest subtypep.fixnum-or-bignum + (check-equivalence '(or fixnum bignum) 'integer) + nil) + +(deftest subtypep.fixnum.integer + (check-equivalence `(integer ,most-negative-fixnum ,most-positive-fixnum) + 'fixnum) + nil) + +(deftest subtypep.bignum.integer + (check-equivalence + `(or (integer * (,most-negative-fixnum)) + (integer (,most-positive-fixnum) *)) + 'bignum) + nil) + +;;;;;;; + +(deftest subtypep.integer.1 + (subtypep* '(integer 0 10) '(integer 0 20)) + t t) + +(deftest subtypep.integer.2 + (subtypep* '(integer 0 10) '(integer 0 (10))) + nil t) + +(deftest subtypep.integer.3 + (subtypep* '(integer 10 100) 'integer) + t t) + +(deftest subtypep.integer.3a + (subtypep* '(integer 10 100) '(integer)) + t t) + +(deftest subtypep.integer.3b + (subtypep* '(integer 10 100) '(integer *)) + t t) + +(deftest subtypep.integer.3c + (subtypep* '(integer 10 100) '(integer * *)) + t t) + +(deftest subtypep.integer.4 + (subtypep* 'integer '(integer 10 100)) + nil t) + +(deftest subtypep.integer.4a + (subtypep* '(integer) '(integer 10 100)) + nil t) + +(deftest subtypep.integer.4b + (subtypep* '(integer *) '(integer 10 100)) + nil t) + +(deftest subtypep.integer.4c + (subtypep* '(integer * *) '(integer 10 100)) + nil t) + +(deftest subtypep.integer.5 + (subtypep* '(integer 10 *) 'integer) + t t) + +(deftest subtypep.integer.5a + (subtypep* '(integer 10 *) '(integer)) + t t) + +(deftest subtypep.integer.5b + (subtypep* '(integer 10 *) '(integer *)) + t t) + +(deftest subtypep.integer.5c + (subtypep* '(integer 10 *) '(integer * *)) + t t) + +(deftest subtypep.integer.6 + (subtypep* 'integer '(integer 10 *)) + nil t) + +(deftest subtypep.integer.6a + (subtypep* '(integer) '(integer 10 *)) + nil t) + +(deftest subtypep.integer.6b + (subtypep* '(integer *) '(integer 10 *)) + nil t) + +(deftest subtypep.integer.6c + (subtypep* '(integer * *) '(integer 10 *)) + nil t) + +(deftest subtypep.integer.7 + (subtypep* '(integer 10) 'integer) + t t) + +(deftest subtypep.integer.7a + (subtypep* '(integer 10) '(integer)) + t t) + +(deftest subtypep.integer.7b + (subtypep* '(integer 10) '(integer *)) + t t) + +(deftest subtypep.integer.7c + (subtypep* '(integer 10) '(integer * *)) + t t) + +(deftest subtypep.integer.8 + (subtypep* 'integer '(integer 10)) + nil t) + +(deftest subtypep.integer.8a + (subtypep* '(integer) '(integer 10)) + nil t) + +(deftest subtypep.integer.8b + (subtypep* '(integer *) '(integer 10)) + nil t) + +(deftest subtypep.integer.8c + (subtypep* '(integer * *) '(integer 10)) + nil t) + +(deftest subtypep.integer.9 + (subtypep* '(integer * 10) 'integer) + t t) + +(deftest subtypep.integer.9a + (subtypep* '(integer * 10) '(integer)) + t t) + +(deftest subtypep.integer.9b + (subtypep* '(integer * 10) '(integer *)) + t t) + +(deftest subtypep.integer.9c + (subtypep* '(integer * 10) '(integer * *)) + t t) + +(deftest subtypep.integer.10 + (subtypep* 'integer '(integer * 10)) + nil t) + +(deftest subtypep.integer.10a + (subtypep* '(integer) '(integer * 10)) + nil t) + +(deftest subtypep.integer.10b + (subtypep* '(integer *) '(integer * 10)) + nil t) + +(deftest subtypep.integer.10c + (subtypep* '(integer * *) '(integer * 10)) + nil t) + +(deftest subtypep.integer.11 + (subtypep* '(integer 10) '(integer 5)) + t t) + +(deftest subtypep.integer.12 + (subtypep* '(integer 5) '(integer 10)) + nil t) + +(deftest subtypep.integer.13 + (subtypep* '(integer 10 *) '(integer 5)) + t t) + +(deftest subtypep.integer.14 + (subtypep* '(integer 5) '(integer 10 *)) + nil t) + +(deftest subtypep.integer.15 + (subtypep* '(integer 10) '(integer 5 *)) + t t) + +(deftest subtypep.integer.16 + (subtypep* '(integer 5 *) '(integer 10)) + nil t) + +(deftest subtypep.integer.17 + (subtypep* '(integer 10 *) '(integer 5 *)) + t t) + +(deftest subtypep.integer.18 + (subtypep* '(integer 5 *) '(integer 10 *)) + nil t) + +(deftest subtypep.integer.19 + (subtypep* '(integer * 5) '(integer * 10)) + t t) + +(deftest subtypep.integer.20 + (subtypep* '(integer * 10) '(integer * 5)) + nil t) + +(deftest subtypep.integer.21 + (subtypep* '(integer 10 *) '(integer * 10)) + nil t) + +(deftest subtypep.integer.22 + (subtypep* '(integer * 10) '(integer 10 *)) + nil t) + +(deftest subtypep.integer.23 + (check-equivalence '(integer (9)) '(integer 10)) + nil) + +(deftest subtypep.integer.24 + (check-equivalence '(integer * (11)) '(integer * 10)) + nil) + +(deftest subtypep.integer.25 + (check-equivalence + '(and (or (integer 0 10) (integer 20 30)) + (or (integer 5 15) (integer 25 35))) + '(or (integer 5 10) (integer 25 30))) + nil) + +(deftest subtypep.integer.26 + (check-equivalence + '(and (integer 0 10) (integer 5 15)) + '(integer 5 10)) + nil) + +(deftest subtypep.integer.27 + (check-equivalence + '(or (integer 0 10) (integer 5 15)) + '(integer 0 15)) + nil) + +(deftest subtypep.integer.28 + (check-equivalence + '(and integer (not (eql 10))) + '(or (integer * 9) (integer 11 *))) + nil) + +(deftest subtypep.integer.29 + (check-equivalence + '(and integer (not (integer 1 10))) + '(or (integer * 0) (integer 11 *))) + nil) + +(deftest subtypep.integer.30 + (check-equivalence + '(and (integer -100 100) (not (integer 1 10))) + '(or (integer -100 0) (integer 11 100))) + nil) + +;;; Relations between integer and real types + +(deftest subtypep.integer.real.1 + (check-equivalence + '(and integer (real 4 10)) + '(integer 4 10)) + nil) + +(deftest subtypep.integer.real.2 + (check-equivalence + '(and (integer 4 *) (real * 10)) + '(integer 4 10)) + nil) + +(deftest subtypep.integer.real.3 + (check-equivalence + '(and (integer * 10) (real 4)) + '(integer 4 10)) + nil) + +(deftest subtypep.integer.real.4 + (loop for int-type in '(integer (integer) (integer *) (integer * *)) + append (loop for real-type in '(real (real) (real *) (real * *)) + unless (equal (multiple-value-list + (subtypep* int-type real-type)) + '(t t)) + collect (list int-type real-type))) + nil) + +(deftest subtypep.integer.real.5 + (loop for int-type in '((integer 10) (integer 10 *)) + append (loop for real-type in '(real (real) (real *) (real * *) + (real 10.0) (real 10.0 *) + (real 10) (real 10 *)) + unless (equal (multiple-value-list + (subtypep* int-type real-type)) + '(t t)) + collect (list int-type real-type))) + nil) + +(deftest subtypep.integer.real.6 + (loop for int-type in '((integer * 10) (integer * 5)) + append (loop for real-type in '(real (real) (real *) (real * *) + (real * 10.0) + (real * 10) (real * 1000000000000)) + unless (equal (multiple-value-list + (subtypep* int-type real-type)) + '(t t)) + collect (list int-type real-type))) + nil) + +(deftest subtypep.integer.real.7 + (loop for int-type in '((integer 0 10) (integer 2 5)) + append (loop for real-type in '(real (real) (real *) (real * *) + (real * 10) (real * 1000000000000) + (real -10) (real -10.0) + (real -10 *) (real -10.0 *) + (real 0) (real 0.0) + (real 0 10) (real * 10) + (real 0 *) (real 0 10)) + unless (equal (multiple-value-list + (subtypep* int-type real-type)) + '(t t)) + collect (list int-type real-type))) + nil) + +(deftest subtypep.integer.real.8 + (check-equivalence + '(and (integer 4) (real * 10)) + '(integer 4 10)) + nil) + +(deftest subtypep.integer.real.9 + (check-equivalence + '(and (integer * 10) (real 4)) + '(integer 4 10)) + nil) + +(deftest subtypep.integer.real.10 + (check-equivalence + '(and (integer 4) (real * (10))) + '(integer 4 9)) + nil) + +(deftest subtypep.integer.real.11 + (check-equivalence + '(and (integer * 10) (real (4))) + '(integer 5 10)) + nil) + + +;;; Between integer and rational types + +(deftest subtypep.integer.rational.1 + (check-equivalence + '(and integer (rational 4 10)) + '(integer 4 10)) + nil) + +(deftest subtypep.integer.rational.2 + (check-equivalence + '(and (integer 4 *) (rational * 10)) + '(integer 4 10)) + nil) + +(deftest subtypep.integer.rational.3 + (check-equivalence + '(and (integer * 10) (rational 4)) + '(integer 4 10)) + nil) + + + +(deftest subtypep.integer.rational.4 + (loop for int-type in '(integer (integer) (integer *) (integer * *)) + append (loop for rational-type + in '(rational (rational) (rational *) (rational * *)) + unless (equal (multiple-value-list + (subtypep* int-type rational-type)) + '(t t)) + collect (list int-type rational-type))) + nil) + +(deftest subtypep.integer.rational.5 + (loop for int-type in '((integer 10) (integer 10 *)) + append (loop for rational-type + in '(rational (rational) (rational *) (rational * *) + (rational 19/2) (rational 19/2 *) + (rational 10) (rational 10 *)) + unless (equal (multiple-value-list + (subtypep* int-type rational-type)) + '(t t)) + collect (list int-type rational-type))) + nil) + +(deftest subtypep.integer.rational.6 + (loop for int-type in '((integer * 10) (integer * 5)) + append (loop for rational-type + in '(rational (rational) (rational *) (rational * *) + (rational * 21/2) + (rational * 10) (rational * 1000000000000)) + unless (equal (multiple-value-list + (subtypep* int-type rational-type)) + '(t t)) + collect (list int-type rational-type))) + nil) + +(deftest subtypep.integer.rational.7 + (loop for int-type in '((integer 0 10) (integer 2 5)) + append (loop for rational-type in + '(rational (rational) (rational *) (rational * *) + (rational * 10) (rational * 1000000000000) + (rational -1) (rational -1/2) + (rational -1 *) (rational -1/2 *) + (rational 0) + (rational 0 10) (rational * 10) + (rational 0 *) (rational 0 10)) + unless (equal (multiple-value-list + (subtypep* int-type rational-type)) + '(t t)) + collect (list int-type rational-type))) + nil) + +(deftest subtypep.integer.rational.8 + (check-equivalence + '(and integer (rational (4) 10)) + '(integer 5 10)) + nil) + +(deftest subtypep.integer.rational.9 + (check-equivalence + '(and (integer 4 *) (rational * (10))) + '(integer 4 9)) + nil) + +(deftest subtypep.integer.rational.10 + (check-equivalence + '(and (integer * 10) (rational (4))) + '(integer 5 10)) + nil) diff --git a/ansi-tests/subtypep-member.lsp b/ansi-tests/subtypep-member.lsp new file mode 100644 index 0000000..3a5fa78 --- /dev/null +++ b/ansi-tests/subtypep-member.lsp @@ -0,0 +1,229 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Feb 15 11:58:06 2003 +;;;; Contains: Tests for subtype relationships on member types + +(in-package :cl-test) + +;;; SUBTYPEP on MEMBER types + +(deftest subtypep.member.1 + (check-all-subtypep '(member a b c) '(member a b c d)) + nil) + +(deftest subtypep.member.2 + (check-all-not-subtypep '(member a b c) '(member a b)) + nil) + +(deftest subtypep.member.3 + (check-equivalence '(member) nil) + nil) + +(deftest subtypep.member.4 + (check-all-subtypep '(eql b) '(member a b c)) + nil) + +(deftest subtypep.member.5 + (check-all-subtypep '(member a b c d e) 'symbol) + nil) + +(deftest subtypep.member.6 + (check-all-not-subtypep '(member a b 10 d e) 'symbol) + nil) + +(deftest subtypep.member.7 + (check-all-subtypep 'null '(member a b nil c d e)) + nil) + +(deftest subtypep.member.8 + (check-all-not-subtypep 'null '(member a b c d e)) + nil) + +(deftest subtypep.member.9 + (let ((b1 (1+ most-positive-fixnum)) + (b2 (1+ most-positive-fixnum))) + (check-all-subtypep `(member 10 ,b1 20) `(member 10 20 ,b2))) + nil) + +(deftest subtypep.member.10 + (check-all-subtypep '(member :a :b :c) 'keyword) + nil) + +(deftest subtypep.member.11 + (let ((b1 (copy-list '(a))) + (b2 (copy-list '(a)))) + (check-all-not-subtypep `(member 10 ,b1 20) `(member 10 20 ,b2))) + nil) + +(deftest subtypep.member.12 + (let ((b1 '(a))) + (check-all-subtypep `(member 10 ,b1 20) `(member 10 20 ,b1))) + nil) + +(deftest subtypep.member.13 + (check-all-subtypep '(member 10 20 30) '(integer 0 100)) + nil) + +(deftest subtypep.member.14 + (check-all-subtypep '(integer 3 6) '(member 0 1 2 3 4 5 6 7 8 100)) + nil) + +(deftest subtypep.member.15 + (check-all-not-subtypep '(integer 3 6) '(member 0 1 2 3 5 6 7 8)) + nil) + +(deftest subtypep.member.16 + (check-equivalence '(integer 2 5) '(member 2 5 4 3)) + nil) + +(deftest subtypep.member.17 + (let ((s1 (copy-seq "abc")) + (s2 (copy-seq "abc"))) + (let ((t1 `(member ,s1)) + (t2 `(member ,s2))) + (cond + ((subtypep t1 t2) "T1 is subtype of T2") + ((subtypep t2 t1) "T2 is subtype of T1") + (t (check-disjointness t1 t2))))) + nil) + +(deftest subtypep.member.18 + (let ((s1 (copy-seq '(a b c))) + (s2 (copy-seq '(a b c)))) + (let ((t1 `(member ,s1)) + (t2 `(member ,s2))) + (cond + ((subtypep t1 t2) "T1 is subtype of T2") + ((subtypep t2 t1) "T2 is subtype of T1") + (t (check-disjointness t1 t2))))) + nil) + +(deftest subtypep.member.19 + (let ((i1 (1+ most-positive-fixnum)) + (i2 (1+ most-positive-fixnum))) + (check-equivalence `(member 0 ,i1) `(member 0 ,i2))) + nil) + +(deftest subtypep.member.20 + (check-equivalence '(and (member a b c d) (member e d b f g)) + '(member b d)) + nil) + +(deftest subtypep.member.21 + (check-equivalence '(and (member a b c d) (member e d f g)) + '(eql d)) + nil) + +(deftest subtypep.member.22 + (check-equivalence '(and (member a b c d) (member e f g)) + nil) + nil) + +(deftest subtypep.member.23 + (check-equivalence '(or (member a b c) (member z b w)) + '(member z a b w c)) + nil) + +(deftest subtypep.member.24 + (check-equivalence '(or (member a b c) (eql d)) + '(member d c b a)) + nil) + +(deftest subtypep.member.25 + (check-equivalence 'boolean '(member nil t)) + nil) + +(deftest subtypep.member.26 + (check-equivalence '(or (eql a) (eql b)) + '(member a b)) + nil) + +(deftest subtypep.member.27 + (check-all-subtypep '(member a b c d) '(satisfies symbolp)) + nil) + +(deftest subtypep.member.28 + (check-all-subtypep '(member a b c d) t) + nil) + +(deftest subtypep.member.29 + (check-all-not-subtypep '(member a b 10 z) '(satisfies symbolp)) + nil) + +(deftest subtypep.member.30 + (check-disjointness '(member 1 6 10) '(satisfies symbolp)) + nil) + +(deftest subtypep.member.31 + (check-equivalence '(member a b c d) '(member c d b a)) + nil) + +(deftest subtypep.member.32 + (check-all-not-subtypep '(not (member a b 10 z)) '(satisfies symbolp)) + nil) + +(deftest subtypep.member.33 + (check-all-not-subtypep '(satisfies symbolp) '(member a b 10 z)) + nil) + +(deftest subtypep.member.34 + (check-all-not-subtypep '(member a b 10 z) '(not (satisfies symbolp))) + nil) + +(deftest subtypep.member.35 + (check-all-not-subtypep '(satisfies symbolp) '(member a b c d)) + nil) + +(deftest subtypep.member.36 + (check-disjointness '(eql a) '(or (member b c d) (eql e))) + nil) + +(deftest subtypep.member.37 + (check-equivalence + '(and (member a b c d) (not (eql c))) + '(member a b d)) + nil) + +(deftest subtypep.member.38 + (check-equivalence + '(and (member a b c d e f g) + (not (member b f))) + '(member a c d e g)) + nil) + +(deftest subtypep.member.39 + (check-equivalence + '(and (not (member b d e f g)) + (not (member x y b z d))) + '(not (member b d e f g x y z))) + nil) + +(deftest subtypep.member.40 + (check-equivalence + '(and (not (eql a)) (not (eql b))) + '(not (member a b))) + nil) + +(deftest subtypep.member.41 + (check-equivalence + '(and (not (eql a)) (not (eql b)) (not (eql c))) + '(not (member c b a))) + nil) + +(deftest subtypep.member.42 + (check-equivalence + '(and (not (member a b)) (not (member b c))) + '(not (member c b a))) + nil) + +(deftest subtypep.member.43 + (check-equivalence + '(and (not (member a g b k e)) (not (member b h k c f))) + '(not (member c b k a e f g h))) + nil) + +(deftest subtypep.member.44 + (check-equivalence + '(and (integer 0 30) (not (member 3 4 5 9 10 11 17 18 19))) + '(or (integer 0 2) (integer 6 8) (integer 12 16) (integer 20 30))) + nil) diff --git a/ansi-tests/subtypep-rational.lsp b/ansi-tests/subtypep-rational.lsp new file mode 100644 index 0000000..e2059a8 --- /dev/null +++ b/ansi-tests/subtypep-rational.lsp @@ -0,0 +1,173 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Feb 15 11:56:19 2003 +;;;; Contains: Tests for subtype relationships on rational types + +(in-package :cl-test) + +;;; SUBTYPEP on rational types + +(deftest subtypep.rational.1 + (loop for tp1 in '((rational 10) (rational 10 *) + (rational 10 20) + (rational (10) 20) + (rational 10 (20)) + (rational (10) (20)) + (rational 10 1000000000000000) + (rational (10)) (rational (10) *)) + append + (loop for tp2 in '(rational (rational) (rational *) + (rational * *) (rational 10) (rational 10 *) + (rational 0) (rational 0 *) + (rational 19/2) (rational 19/2 *) + (rational -1000000000000000) + real (real) (real *) + (real * *) (real 10) (real 10 *) + (real 0) (real 0 *) + (real 19/2) (real 19/2 *) + (real -1000000000000000)) + unless (equal (multiple-value-list + (subtypep* tp1 tp2)) + '(t t)) + collect (list tp1 tp2))) + nil) + +(deftest subtypep.rational.2 + (loop for tp1 in '((rational * 10) + (rational 0 10) + (rational 0 (10)) + (rational (0) 10) + (rational (0) (10)) + (rational -1000000000000000 10) + (rational * (10))) + append + (loop for tp2 in '(rational (rational) (rational *) + (rational * *) (rational * 10) + (rational * 21/2) + (rational * 1000000000000000) + real (real) (real *) + (real * *) (real * 10) + (real * 21/2) + (real * 1000000000000000)) + unless (equal (multiple-value-list + (subtypep* tp1 tp2)) + '(t t)) + collect (list tp1 tp2))) + nil) + +(deftest subtypep.rational.3 + (loop for tp1 in '((rational 10) (rational 10 *) + (rational 10 20) + (rational 10 (21)) + (rational 10 1000000000000000)) + append + (loop for tp2 in '((rational 11) (rational 11 *) + (rational (10)) (rational (10) *) + (integer 10) (integer 10 *) + (real 11) + (real (10)) + (real 11 *) + (real (10) *) + (rational * (20)) + (rational * 19) + (real * (20)) + (real * 19)) + unless (equal (multiple-value-list + (subtypep* tp1 tp2)) + '(nil t)) + collect (list tp1 tp2))) + nil) + +(deftest subtypep.rational.4 + (loop for tp1 in '((rational * 10) + (rational 0 10) + (rational (0) 10) + (rational -1000000000000000 10)) + append + (loop for tp2 in '((rational * 9) + (rational * (10)) + (integer * 10) + (real * 9) + (real * (10))) + unless (equal (multiple-value-list + (subtypep* tp1 tp2)) + '(nil t)) + collect (list tp1 tp2))) + nil) + +(deftest subtypep.rational.5 + (check-equivalence + '(or (rational 0 0) (rational (0))) + '(rational 0)) + nil) + +(deftest subtypep.rational.6 + (check-equivalence + '(and (rational 0 10) (rational 5 15)) + '(rational 5 10)) + nil) + +(deftest subtypep.rational.7 + (check-equivalence + '(and (rational (0) 10) (rational 5 15)) + '(rational 5 10)) + nil) + +(deftest subtypep.rational.8 + (check-equivalence + '(and (rational 0 (10)) (rational 5 15)) + '(rational 5 (10))) + nil) + +(deftest subtypep.rational.9 + (check-equivalence + '(and (rational (0) (10)) (rational 5 15)) + '(rational 5 (10))) + nil) + +(deftest subtypep.rational.10 + (check-equivalence + '(and (rational 0 10) (rational (5) 15)) + '(rational (5) 10)) + nil) + +(deftest subtypep.rational.11 + (check-equivalence + '(and (rational 0 (10)) (rational (5) 15)) + '(rational (5) (10))) + nil) + +(deftest subtypep.rational.12 + (check-equivalence + '(and integer (rational 0 10) (not (rational (0) (10)))) + '(member 0 10)) + nil) + +(deftest subtypep.rational.13 + (check-equivalence '(and integer (rational -1/2 1/2)) + '(integer 0 0)) + nil) + +(deftest subtypep.rational.14 + (check-equivalence '(and integer (rational -1/2 1/2)) + '(eql 0)) + nil) + +(deftest subtypep.rational.15 + (check-equivalence '(and integer (rational (-1/2) 1/2)) + '(integer 0 0)) + nil) + +(deftest subtypep.rational.16 + (check-equivalence '(and integer (rational (-1/2) (1/2))) + '(integer 0 0)) + nil) + +(deftest subtypep.rational.17 + (check-all-subtypep '(not (rational -1/2 1/2)) '(not (integer 0 0))) + nil) + +(deftest subtypep.rational.18 + (check-all-subtypep '(not (rational -1/2 1/2)) '(not (eql 0))) + nil) + diff --git a/ansi-tests/subtypep-real.lsp b/ansi-tests/subtypep-real.lsp new file mode 100644 index 0000000..d27c183 --- /dev/null +++ b/ansi-tests/subtypep-real.lsp @@ -0,0 +1,194 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Feb 18 18:38:55 2003 +;;;; Contains: Tests of SUBTYPEP on REAL types. + +(in-package :cl-test) + +;;; SUBTYPEP on real types + +(deftest subtypep.real.1 + (loop for tp1 in '((real 10) (real 10 *) + (real 10 20) + (real (10) 20) + (real 10 (20)) + (real (10) (20)) + (real 10 1000000000000000) + (real (10)) (real (10) *)) + append + (loop for tp2 in '(real (real) (real *) + (real * *) (real 10) (real 10 *) + (real 0) (real 0 *) + (real 19/2) (real 19/2 *) + (real 9.5) (real 9.5 *) + (real -1000000000000000)) + unless (equal (multiple-value-list + (subtypep* tp1 tp2)) + '(t t)) + collect (list tp1 tp2))) + nil) + +(deftest subtypep.real.2 + (loop for tp1 in '((real * 10) + (real 0 10) + (real 0 (10)) + (real (0) 10) + (real (0) (10)) + (real -1000000000000000 10) + (real * (10))) + append + (loop for tp2 in '(real (real) (real *) + (real * *) (real * 10) + (real * 21/2) + (real * 10.5) + (real * 1000000000000000)) + unless (equal (multiple-value-list + (subtypep* tp1 tp2)) + '(t t)) + collect (list tp1 tp2))) + nil) + +(deftest subtypep.real.3 + (loop for tp1 in '((real 10) (real 10 *) + (real 10 20) + (real 10 (21)) + (real 10 1000000000000000)) + append + (loop for tp2 in '((real 11) (real 11 *) + (real (10)) (real (10) *) + (integer 10) (integer 10 *) + (real 11) + (real (10)) + (real 11 *) + (real (10) *) + (real * (20)) + (real * 19) + (real * (20)) + (real * 19)) + unless (equal (multiple-value-list + (subtypep* tp1 tp2)) + '(nil t)) + collect (list tp1 tp2))) + nil) + +(deftest subtypep.real.4 + (loop for tp1 in '((real * 10) + (real 0 10) + (real (0) 10) + (real -1000000000000000 10)) + append + (loop for tp2 in '((real * 9) + (real * (10)) + (integer * 10) + (real * 9) + (real * (10))) + unless (equal (multiple-value-list + (subtypep* tp1 tp2)) + '(nil t)) + collect (list tp1 tp2))) + nil) + +(deftest subtypep.real.5 + (check-equivalence + '(or (real 0 0) (real (0))) + '(real 0)) + nil) + +(deftest subtypep.real.6 + (check-equivalence + '(and (real 0 10) (real 5 15)) + '(real 5 10)) + nil) + +(deftest subtypep.real.7 + (check-equivalence + '(and (real (0) 10) (real 5 15)) + '(real 5 10)) + nil) + +(deftest subtypep.real.8 + (check-equivalence + '(and (real 0 (10)) (real 5 15)) + '(real 5 (10))) + nil) + +(deftest subtypep.real.9 + (check-equivalence + '(and (real (0) (10)) (real 5 15)) + '(real 5 (10))) + nil) + +(deftest subtypep.real.10 + (check-equivalence + '(and (real 0 10) (real (5) 15)) + '(real (5) 10)) + nil) + +(deftest subtypep.real.11 + (check-equivalence + '(and (real 0 (10)) (real (5) 15)) + '(real (5) (10))) + nil) + +(deftest subtypep.real.12 + (check-equivalence + '(and integer (real 0 10) (not (real (0) (10)))) + '(member 0 10)) + nil) + +(deftest subtypep.real.13 + (check-equivalence '(and integer (real -1/2 1/2)) + '(integer 0 0)) + nil) + +(deftest subtypep.real.14 + (check-equivalence '(and integer (real -1/2 1/2)) + '(eql 0)) + nil) + +(deftest subtypep.real.15 + (check-equivalence '(and integer (real (-1/2) 1/2)) + '(integer 0 0)) + nil) + +(deftest subtypep.real.16 + (check-equivalence '(and integer (real (-1/2) (1/2))) + '(integer 0 0)) + nil) + +(deftest subtypep.real.17 + (check-equivalence '(real 0 10) '(real 0.0 10.0)) + nil) + +(deftest subtypep.real.18 + (check-equivalence '(and rational (real 0 10)) + '(rational 0 10)) + nil) + +(deftest subtypep.real.19 + (check-equivalence '(and rational (real 0 (10))) + '(rational 0 (10))) + nil) + +(deftest subtypep.real.20 + (check-equivalence '(and rational (real (0) (10))) + '(rational (0) (10))) + nil) + +(deftest subtypep.real.21 + (check-equivalence '(and rational (real 1/2 7/3)) + '(rational 1/2 7/3)) + nil) + +(deftest subtypep.real.22 + (check-equivalence '(and rational (real (1/11) (8/37))) + '(rational (1/11) (8/37))) + nil) + +(deftest subtypep.real.23 + (check-all-subtypep '(not (real -1/2 1/2)) '(not (integer 0 0))) + nil) + +(deftest subtypep.real.24 + (check-all-subtypep '(not (real -1/2 1/2)) '(not (eql 0))) + nil) diff --git a/ansi-tests/subtypep.lsp b/ansi-tests/subtypep.lsp new file mode 100644 index 0000000..e46221b --- /dev/null +++ b/ansi-tests/subtypep.lsp @@ -0,0 +1,200 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Jan 29 17:28:19 2003 +;;;; Contains: Tests of SUBTYPEP + +(in-package :cl-test) + +;;; More subtypep tests are in types-and-class.lsp + +(deftest subtypep.order.1 + (let ((i 0) x y) + (values + (notnot (subtypep (progn (setf x (incf i)) t) + (progn (setf y (incf i)) t))) + i x y)) + t 2 1 2) + +(deftest simple-base-string-is-sequence + (subtypep* 'simple-base-string 'sequence) + t t) + +(deftest subtype.env.1 + (mapcar #'notnot + (multiple-value-list (subtypep 'bit 'integer nil))) + (t t)) + +(deftest subtype.env.2 + (macrolet + ((%foo (&environment env) + (list 'quote + (mapcar #'notnot + (multiple-value-list + (subtypep 'bit 'integer env)))))) + (%foo)) + (t t)) + +(deftest subtype.env.3 + (macrolet + ((%foo (&environment env) + (multiple-value-bind (sub good) + (subtypep nil (type-of env)) + (or (not good) (notnot sub))))) + (%foo)) + t) + +(deftest subtype.env.4 + (macrolet + ((%foo (&environment env) + (multiple-value-bind (sub good) + (subtypep (type-of env) (type-of env)) + (or (not good) (notnot sub))))) + (%foo)) + t) + +(deftest subtype.env.5 + (macrolet + ((%foo (&environment env) + (multiple-value-bind (sub good) + (subtypep (type-of env) t) + (or (not good) (notnot sub))))) + (%foo)) + t) + +(deftest subtypep.error.1 + (classify-error (subtypep)) + program-error) + +(deftest subtypep.error.2 + (classify-error (subtypep t)) + program-error) + +(deftest subtypep.error.3 + (classify-error (subtypep t t nil nil)) + program-error) + +;;; Special cases of types-6 that are/were causing problems in CMU CL + +(deftest keyword-is-subtype-of-atom + (subtypep* 'keyword 'atom) + t t) + +(deftest ratio-is-subtype-of-atom + (subtypep* 'ratio 'atom) + t t) + +(deftest extended-char-is-subtype-of-atom + (subtypep* 'extended-char 'atom) + t t) + +(deftest string-is-not-simple-vector + (subtypep* 'string 'simple-vector) + nil t) + +(deftest base-string-is-not-simple-vector + (subtypep* 'base-string 'simple-vector) + nil t) + +(deftest simple-string-is-not-simple-vector + (subtypep* 'simple-string 'simple-vector) + nil t) + +(deftest simple-base-string-is-not-simple-vector + (subtypep* 'simple-base-string 'simple-vector) + nil t) + +(deftest bit-vector-is-not-simple-vector + (subtypep* 'bit-vector 'simple-vector) + nil t) + +(deftest simple-bit-vector-is-not-simple-vector + (subtypep* 'simple-bit-vector 'simple-vector) + nil t) + +(deftest subtypep.extended-char.1 + (if (subtypep* 'character 'base-char) + (subtypep* 'extended-char nil) + (values t t)) + t t) + +(deftest subtypep.and/or.1 + (check-equivalence + '(and (or symbol (integer 0 15)) + (or symbol (integer 10 25))) + '(or symbol (integer 10 15))) + nil) + +(deftest subtypep.and/or.2 + (check-equivalence + '(and (or (not symbol) (integer 0 10)) + (or symbol (integer 11 25))) + '(integer 11 25)) + nil) + +(deftest subtypep.and.1 + (loop for type in *types-list3* + append (check-equivalence `(and ,type ,type) type)) + nil) + +(deftest subtypep.or.1 + (loop for type in *types-list3* + append (check-equivalence `(or ,type ,type) type)) + nil) + +(deftest subtypep.and.2 + (check-equivalence t '(and)) + nil) + +(deftest subtypep.or.2 + (check-equivalence nil '(or)) + nil) + +(deftest subtypep.and.3 + (loop for type in *types-list3* + append (check-equivalence `(and ,type) type)) + nil) + +(deftest subtypep.or.3 + (loop for type in *types-list3* + append (check-equivalence `(or ,type) type)) + nil) + +(deftest subtypep.and.4 + (let* ((n (length *types-list3*)) + (a (make-array n :initial-contents *types-list3*))) + (trim-list + (loop for i below 1000 + for tp1 = (aref a (random n)) + for tp2 = (aref a (random n)) + append (check-equivalence `(and ,tp1 ,tp2) + `(and ,tp2 ,tp1))) + 100)) + nil) + +(deftest subtypep.or.4 + (let* ((n (length *types-list3*)) + (a (make-array n :initial-contents *types-list3*))) + (trim-list + (loop for i below 1000 + for tp1 = (aref a (random n)) + for tp2 = (aref a (random n)) + append (check-equivalence `(or ,tp1 ,tp2) + `(or ,tp2 ,tp1))) + 100)) + nil) + +;;; Check that types that are supposed to be nonempty are +;;; not subtypes of NIL + +(deftest subtypep.nil.1 + (loop for (type) in *subtype-table* + unless (member type '(nil extended-char)) + append (check-all-not-subtypep type nil)) + nil) + +(deftest subtypep.nil.2 + (loop for (type) in *subtype-table* + for class = (find-class type nil) + unless (or (not class) (member type '(nil extended-char))) + append (check-all-not-subtypep class nil)) + nil) diff --git a/ansi-tests/svref.lsp b/ansi-tests/svref.lsp new file mode 100644 index 0000000..af0f7c4 --- /dev/null +++ b/ansi-tests/svref.lsp @@ -0,0 +1,59 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Jan 22 21:39:30 2003 +;;;; Contains: Tests of SVREF + +(in-package :cl-test) + +(deftest svref.1 + (let ((a (vector 1 2 3 4))) + (loop for i below 4 collect (svref a i))) + (1 2 3 4)) + +(deftest svref.2 + (let ((a (vector 1 2 3 4))) + (values + (loop for i below 4 + collect (setf (svref a i) (+ i 10))) + a)) + (10 11 12 13) + #(10 11 12 13)) + +(deftest svref.order.1 + (let ((v (vector 'a 'b 'c 'd)) + (i 0) a b) + (values + (svref (progn (setf a (incf i)) v) + (progn (setf b (incf i)) 2)) + i a b)) + c 2 1 2) + +(deftest svref.order.2 + (let ((v (vector 'a 'b 'c 'd)) + (i 0) a b c) + (values + (setf + (svref (progn (setf a (incf i)) v) + (progn (setf b (incf i)) 2)) + (progn (setf c (incf i)) 'w)) + v i a b c)) + w #(a b w d) 3 1 2 3) + + +;;; Error tests + +(deftest svref.error.1 + (classify-error (svref)) + program-error) + +(deftest svref.error.2 + (classify-error (svref (vector 1))) + program-error) + +(deftest svref.error.3 + (classify-error (svref (vector 1) 0 0)) + program-error) + +(deftest svref.error.4 + (classify-error (svref (vector 1) 0 nil)) + program-error) diff --git a/ansi-tests/t.lsp b/ansi-tests/t.lsp new file mode 100644 index 0000000..eecb697 --- /dev/null +++ b/ansi-tests/t.lsp @@ -0,0 +1,24 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Thu Oct 17 06:44:45 2002 +;;;; Contains: Tests of T + +(in-package :cl-test) + +(deftest t.1 + t t) + +(deftest t.2 + (not-mv (constantp t)) + nil) + +(deftest t.3 + (eqt t 't) + t) + +(deftest t.4 + (symbol-value t) + t) + +;;; Tests for use of T in case forms, as a stream designator, or as a class +;;; designator will be elsewhere diff --git a/ansi-tests/tagbody.lsp b/ansi-tests/tagbody.lsp new file mode 100644 index 0000000..fd373e1 --- /dev/null +++ b/ansi-tests/tagbody.lsp @@ -0,0 +1,161 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Oct 12 13:27:22 2002 +;;;; Contains: Tests of TAGBODY + +(in-package :cl-test) + +(deftest tagbody.1 + (tagbody) + nil) + +(deftest tagbody.2 + (tagbody 'a) + nil) + +(deftest tagbody.3 + (tagbody (values)) + nil) + +(deftest tagbody.4 + (tagbody (values 1 2 3 4 5)) + nil) + +(deftest tagbody.5 + (let ((x 0)) + (values + (tagbody + (setq x 1) + (go a) + (setq x 2) + a) + x)) + nil 1) + +(deftest tagbody.6 + (let ((x 0)) + (tagbody + (setq x 1) + (go a) + b + (setq x 2) + (go c) + a + (setq x 3) + (go b) + c) + x) + 2) + +;;; Macroexpansion occurs after tag determination +(deftest tagbody.7 + (let ((x 0)) + (macrolet ((%m () 'a)) + (tagbody + (tagbody + (go a) + (%m) + (setq x 1)) + a )) + x) + 0) + +(deftest tagbody.8 + (let ((x 0)) + (tagbody + (flet ((%f (y) (setq x y) (go a))) + (%f 10)) + (setq x 1) + a) + x) + 10) + +;;; Tag names are in their own name space +(deftest tagbody.9 + (let (result) + (tagbody + (flet ((a (x) x)) + (setq result (a 10)) + (go a)) + a) + result) + 10) + +(deftest tagbody.10 + (let (result) + (tagbody + (block a + (setq result 10) + (go a)) + (setq result 20) + a) + result) + 10) + +(deftest tagbody.11 + (let (result) + (tagbody + (catch 'a + (setq result 10) + (go a)) + (setq result 20) + a) + result) + 10) + +(deftest tagbody.12 + (let (result) + (tagbody + (block a + (setq result 10) + (return-from a nil)) + (setq result 20) + a) + result) + 20) + +;;; Test that integers are accepted as go tags + +(deftest tagbody.13 + (block done + (tagbody + (go around) + 10 + (return-from done 'good) + around + (go 10))) + good) + +(deftest tagbody.14 + (block done + (tagbody + (go around) + -10 + (return-from done 'good) + around + (go -10))) + good) + +(deftest tagbody.15 + (block done + (tagbody + (go around) + #.(1+ most-positive-fixnum) + (return-from done 'good) + around + (go #.(1+ most-positive-fixnum)))) + good) + +(deftest tagbody.16 + (let* ((t1 (1+ most-positive-fixnum)) + (t2 (1+ most-positive-fixnum)) + (form `(block done + (tagbody + (go around) + ,t1 + (return-from done 'good) + around + (go ,t2))))) + (eval form)) + good) + diff --git a/ansi-tests/typecase.lsp b/ansi-tests/typecase.lsp new file mode 100644 index 0000000..2c83a42 --- /dev/null +++ b/ansi-tests/typecase.lsp @@ -0,0 +1,72 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Oct 18 22:51:25 2002 +;;;; Contains: Tests for TYPECASE + +(in-package :cl-test) + +(deftest typecase.1 + (typecase 1 (integer 'a) (t 'b)) + a) + +(deftest typecase.2 + (typecase 1 (symbol 'a)) + nil) + +(deftest typecase.3 + (typecase 1 (symbol 'a) (t 'b)) + b) + +(deftest typecase.4 + (typecase 1 (t (values)))) + +(deftest typecase.5 + (typecase 1 (integer (values)) (t 'a))) + +(deftest typecase.6 + (typecase 1 (bit 'a) (integer 'b)) + a) + +(deftest typecase.7 + (typecase 1 (otherwise 'a)) + a) + +(deftest typecase.8 + (typecase 1 (t (values 'a 'b 'c))) + a b c) + +(deftest typecase.9 + (typecase 1 (integer (values 'a 'b 'c)) (t nil)) + a b c) + +(deftest typecase.10 + (let ((x 0)) + (values + (typecase 1 + (bit (incf x) 'a) + (integer (incf x 2) 'b) + (t (incf x 4) 'c)) + x)) + a 1) + +(deftest typecase.11 + (typecase 1 (otherwise 'a)) + a) + +(deftest typecase.12 + (typecase 1 (integer) (t 'a)) + nil) + +(deftest typecase.13 + (typecase 1 (symbol 'a) (t)) + nil) + +(deftest typecase.14 + (typecase 1 (symbol 'a) (otherwise)) + nil) + +(deftest typecase.15 + (typecase 'a + (number 'bad) + (#.(find-class 'symbol nil) 'good)) + good) diff --git a/ansi-tests/types-and-class-2.lsp b/ansi-tests/types-and-class-2.lsp new file mode 100644 index 0000000..9a30250 --- /dev/null +++ b/ansi-tests/types-and-class-2.lsp @@ -0,0 +1,197 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Feb 5 21:20:05 2003 +;;;; Contains: More tests of types and classes + +(in-package :cl-test) + +;;; Union of a type with its complement is universal + +(deftest type-or-not-type-is-everything + (loop for l in *disjoint-types-list2* + append + (loop + for type in l + append (check-subtypep t `(or ,type (not ,type)) t) + append (check-subtypep t `(or (not ,type) ,type) t))) + nil) + +(defclass tac-1-class () (a b c)) +(defclass tac-1a-class (tac-1-class) (d e)) +(defclass tac-1b-class (tac-1-class) (f g)) + +(deftest user-class-disjointness + (loop for l in *disjoint-types-list2* + append + (loop + for type in l + append (classes-are-disjoint type 'tac-1-class))) + nil) + +(deftest user-class-disjointness-2 + (check-disjointness 'tac-1a-class 'tac-1b-class) + nil) + +(defstruct tac-2-struct a b c) +(defstruct (tac-2a-struct (:include tac-2-struct)) d e) +(defstruct (tac-2b-struct (:include tac-2-struct)) f g) + +(deftest user-struct-disjointness + (loop for l in *disjoint-types-list2* + append + (loop + for type in l + append (check-disjointness type 'tac-2-struct))) + nil) + +(deftest user-struct-disjointness-2 + (check-disjointness 'tac-2a-struct 'tac-2b-struct) + nil) + +(defclass tac-3-a () (x)) +(defclass tac-3-b () (y)) +(defclass tac-3-c () (z)) + +(defclass tac-3-ab (tac-3-a tac-3-b) ()) +(defclass tac-3-ac (tac-3-a tac-3-c) ()) +(defclass tac-3-bc (tac-3-b tac-3-c) ()) + +(defclass tac-3-abc (tac-3-ab tac-3-ac tac-3-bc) ()) + +(deftest tac-3.1 + (subtypep* 'tac-3-ab 'tac-3-a) + t t) + +(deftest tac-3.2 + (subtypep* 'tac-3-ab 'tac-3-b) + t t) + +(deftest tac-3.3 + (subtypep* 'tac-3-ab 'tac-3-c) + nil t) + +(deftest tac-3.4 + (subtypep* 'tac-3-a 'tac-3-ab) + nil t) + +(deftest tac-3.5 + (subtypep* 'tac-3-b 'tac-3-ab) + nil t) + +(deftest tac-3.6 + (subtypep* 'tac-3-c 'tac-3-ab) + nil t) + +(deftest tac-3.7 + (subtypep* 'tac-3-abc 'tac-3-a) + t t) + +(deftest tac-3.8 + (subtypep* 'tac-3-abc 'tac-3-b) + t t) + +(deftest tac-3.9 + (subtypep* 'tac-3-abc 'tac-3-c) + t t) + +(deftest tac-3.10 + (subtypep* 'tac-3-abc 'tac-3-ab) + t t) + +(deftest tac-3.11 + (subtypep* 'tac-3-abc 'tac-3-ac) + t t) + +(deftest tac-3.12 + (subtypep* 'tac-3-abc 'tac-3-bc) + t t) + +(deftest tac-3.13 + (subtypep* 'tac-3-ab 'tac-3-abc) + nil t) + +(deftest tac-3.14 + (subtypep* 'tac-3-ac 'tac-3-abc) + nil t) + +(deftest tac-3.15 + (subtypep* 'tac-3-bc 'tac-3-abc) + nil t) + +(deftest tac-3.16 + (check-equivalence '(and tac-3-a tac-3-b) 'tac-3-ab) + nil) + +(deftest tac-3.17 + (check-equivalence '(and (or tac-3-a tac-3-b) + (or (not tac-3-a) (not tac-3-b)) + (or tac-3-a tac-3-c) + (or (not tac-3-a) (not tac-3-c)) + (or tac-3-b tac-3-c) + (or (not tac-3-b) (not tac-3-c))) + nil) + nil) + +;;; +;;; Check that disjointness of types in *disjoint-types-list* +;;; is respected by all the elements of *universe* +;;; +(deftest universe-elements-in-at-most-one-disjoint-type + (loop for e in *universe* + for types = (remove-if-not #'(lambda (x) (typep e x)) + *disjoint-types-list*) + when (> (length types) 1) + collect (list e types)) + nil) + + + +;;;;; + +(deftest integer-and-ratio-are-disjoint + (classes-are-disjoint 'integer 'ratio) + nil) + +(deftest bignum-and-ratio-are-disjoint + (classes-are-disjoint 'bignum 'ratio) + nil) + +(deftest bignum-and-fixnum-are-disjoint + (classes-are-disjoint 'bignum 'fixnum) + nil) + +(deftest fixnum-and-ratio-are-disjoint + (classes-are-disjoint 'fixnum 'ratio) + nil) + +(deftest byte8-and-ratio-are-disjoint + (classes-are-disjoint '(unsigned-byte 8) 'ratio) + nil) + +(deftest bit-and-ratio-are-disjoint + (classes-are-disjoint 'bit 'ratio) + nil) + +(deftest integer-and-float-are-disjoint + (classes-are-disjoint 'integer 'float) + nil) + +(deftest ratio-and-float-are-disjoint + (classes-are-disjoint 'ratio 'float) + nil) + +(deftest complex-and-float-are-disjoint + (classes-are-disjoint 'complex 'float) + nil) + +(deftest integer-subranges-are-disjoint + (classes-are-disjoint '(integer 0 (10)) '(integer 10 (20))) + nil) + +(deftest keyword-and-null-are-disjoint + (classes-are-disjoint 'keyword 'null) + nil) + +(deftest keyword-and-boolean-are-disjoint + (classes-are-disjoint 'keyword 'boolean) + nil) diff --git a/ansi-tests/types-and-class.lsp b/ansi-tests/types-and-class.lsp new file mode 100644 index 0000000..1b1bd45 --- /dev/null +++ b/ansi-tests/types-and-class.lsp @@ -0,0 +1,422 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Thu Mar 19 21:48:39 1998 +;;;; Contains: Data for testing type and class inclusions + +;; We should check for every type that NIL is a subtype, and T a supertype + +(in-package :cl-test) + +(declaim (optimize (safety 3))) + +(deftest boolean-type.1 + (notnot-mv (typep nil 'boolean)) + t) + +(deftest boolean-type.2 + (notnot-mv (typep t 'boolean)) + t) + +(deftest boolean-type.3 + (check-type-predicate 'is-t-or-nil 'boolean) + 0) + +;; Two type inclusions on booleans +;; have been conditionalized to prevent +;; some tests from doing too badly on CMU CL on x86 +;; These should get removed when I get a more up to date +;; image for that platform -- pfd + + + +(deftest types.3 + (loop + for (t1 t2) in *subtype-table* + for m1 = (check-subtypep t1 t2 t t) + for m2 = (check-subtypep `(and ,t1 ,t2) t1 t) + for m3 = (check-subtypep `(and ,t2 ,t1) t1 t) + for m4 = (check-subtypep `(and ,t1 (not ,t2)) nil t) + for m5 = (check-subtypep `(and (not ,t2) ,t1) nil t) + when m1 collect m1 + when m2 collect m2 + when m3 collect m3 + when m4 collect m4 + when m5 collect m5) + nil) + +(declaim (special +float-types+ *subtype-table*)) + +;;; This next test is all screwed up. Basically, it assumes +;;; incorrectly that certain subtype relationships that are +;;; not specified in the spec cannot occur. +#| +(defun types.4-body () + (let ((parent-table (make-hash-table :test #'equal)) + (types nil)) + (loop + for p in *subtype-table* do + (let ((tp (first p)) + (parent (second p))) + (pushnew tp types) + (pushnew parent types) + (let ((parents (gethash tp parent-table))) + (pushnew parent parents) + ;; (format t "~S ==> ~S~%" tp parent) + (loop + for pp in (gethash parent parent-table) do + ;; (format t "~S ==> ~S~%" tp pp) + (pushnew pp parents)) + (setf (gethash tp parent-table) parents)))) + ;; parent-table now contains lists of ancestors + (loop + for tp in types sum + (let ((parents (gethash tp parent-table))) + (loop + for tp2 in types sum + (cond + ((and (not (eqt tp tp2)) + (not (eqt tp2 'standard-object)) + (not (eqt tp2 'structure-object)) + (not (member tp2 parents)) + (subtypep* tp tp2) + (not (and (member tp +float-types+) + (member tp2 +float-types+))) + (not (and (eqt tp2 'structure-object) + (member 'standard-object parents)))) + (format t "~%Improper subtype: ~S of ~S" + tp tp2) + 1) + (t 0))))) + )) + +(deftest types.4 + (types.4-body) + 0) +|# + +(deftest types.6 + (types.6-body) + nil) + +(declaim (special *disjoint-types-list*)) + +;;; Check that the disjoint types really are disjoint + +(deftest types.7b + (loop for e on *disjoint-types-list* + for tp1 = (first e) + append + (loop for tp2 in (rest e) + append (classes-are-disjoint tp1 tp2))) + nil) + +(deftest types.7c + (loop for e on *disjoint-types-list2* + for list1 = (first e) + append + (loop for tp1 in list1 append + (loop for list2 in (rest e) + append + (loop for tp2 in list2 append + (classes-are-disjoint tp1 tp2))))) + nil) + +(deftest types.8 + (loop + for tp in *disjoint-types-list* count + (cond + ((and (not (eqt tp 'cons)) + (not (subtypep* tp 'atom))) + (format t "~%Should be atomic, but isn't: ~S" tp) + t))) + 0) + +(declaim (special *type-list* *supertype-table*)) + +;;; +;;; TYPES.9 checks the transitivity of SUBTYPEP on pairs of types +;;; occuring in *SUBTYPE-TABLE*, as well as the types KEYWORD, ATOM, +;;; and LIST (the relationships given in *SUBTYPE-TABLE* are not used +;;; here.) +;;; + +(deftest types.9 + (types.9-body) + nil) + +;;; +;;; TYPES.9A takes the supertype relationship computed by test TYPE.9 +;;; and checks that TYPEP respects it for all elements of *UNIVERSE*. +;;; That is, if T1 and T2 are two types, and X is an element of *UNIVERSE*, +;;; then if (SUBTYPEP T1) then (TYPEP X T1) implies (TYPEP X T2). +;;; +;;; The function prints error messages when this fails, and returns the +;;; number of occurences of failure. +;;; +;;; Test TYPES.9 must be run before this test. +;;; + +(deftest types.9a + (types.9a-body) + 0) + + +;;; All class names in CL denote classes that are subtypep +;;; equivalent to themselves +(deftest all-classes-are-type-equivalent-to-their-names + (loop for sym being the external-symbols of "COMMON-LISP" + for class = (find-class sym nil) + when class + append (check-equivalence sym class)) + nil) + +;;; Check that all class names in CL that name standard-classes or +;;; structure-classes are subtypes of standard-object and structure-object, +;;; respectively + +(deftest all-standard-classes-are-subtypes-of-standard-object + (loop for sym being the external-symbols of "COMMON-LISP" + for class = (find-class sym nil) + when (and class + (typep class 'standard-class) + (or (not (subtypep sym 'standard-object)) + (not (subtypep class 'standard-object)))) + collect sym) + nil) + +(deftest all-structure-classes-are-subtypes-of-structure-object + (loop for sym being the external-symbols of "COMMON-LISP" + for class = (find-class sym nil) + when (and class + (typep class 'structure-class) + (or (not (subtypep sym 'structure-object)) + (not (subtypep class 'structure-object)))) + collect sym) + nil) + +;;; Confirm that only the symbols exported from CL that are supposed +;;; to be types are actually classes (see section 11.1.2.1.1) + +(deftest all-exported-cl-class-names-are-valid + (loop for sym being the external-symbols of "COMMON-LISP" + when (and (find-class sym nil) + (not (member sym *cl-all-type-symbols* :test #'eq))) + collect sym) + nil) + +;;; Confirm that all standard generic functions are instances of +;;; the class standard-generic-function. + +(deftest all-standard-generic-functions-are-instances-of-that-class + (loop for sym in *cl-standard-generic-function-symbols* + for fun = (and (fboundp sym) (symbol-function sym)) + unless (and (typep fun 'generic-function) + (typep fun 'standard-generic-function)) + collect (list sym fun)) + nil) + +;;; Canonical metaobjects are in the right classes + +(deftest structure-object-is-in-structure-class + (notnot-mv (typep (find-class 'structure-object) 'structure-class)) + t) + +(deftest standard-object-is-in-standard-class + (notnot-mv (typep (find-class 'standard-object) 'standard-class)) + t) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; deftype + +(deftype even-array (&optional type size) + `(and (array ,type ,size) + (satisfies even-size-p))) + +(deftest deftype.1 + (typep 1 '(even-array integer (10))) + nil) + +(deftest deftype.2 + (typep nil '(even-array t (*))) + nil) + +(deftest deftype.3 + (notnot-mv (typep (make-array '(10)) '(even-array t (*)))) + t) + +(deftest deftype.4 + (typep (make-array '(5)) '(even-array t (*))) + nil) + +(deftest deftype.5 + (notnot-mv (typep (make-string 10) '(even-array character (*)))) + t) + +(deftest deftype.6 + (notnot-mv + (typep (make-array '(3 5 6) :element-type '(unsigned-byte 8)) + '(even-array (unsigned-byte 8)))) + t) + +;; This should be greatly expanded + +(defparameter *type-and-class-fns* + '(coerce subtypep type-of typep type-error-datum type-error-expected-type)) + +(deftest type-and-class-fns + (remove-if #'fboundp *type-and-class-fns*) + nil) + +(deftest type-and-class-macros + (notnot-mv (macro-function 'deftype)) + t) + +(deftest typep-nil-null + (notnot-mv (typep nil 'null)) + t) + +(deftest typep-t-null + (typep t 'null) + nil) + + +;;; Error checking of type-related functions + +(deftest type-of.error.1 + (classify-error (type-of)) + program-error) + +(deftest type-of.error.2 + (classify-error (type-of nil nil)) + program-error) + +(deftest typep.error.1 + (classify-error (typep)) + program-error) + +(deftest typep.error.2 + (classify-error (typep nil)) + program-error) + +(deftest typep.error.3 + (classify-error (typep nil t nil nil)) + program-error) + +(deftest type-error-datum.error.1 + (classify-error (type-error-datum)) + program-error) + +(deftest type-error-datum.error.2 + (classify-error + (let ((c (make-condition 'type-error :datum nil + :expected-type t))) + (type-error-datum c nil))) + program-error) + +(deftest type-error-expected-type.error.1 + (classify-error (type-error-expected-type)) + program-error) + +(deftest type-error-expected-type.error.2 + (classify-error + (let ((c (make-condition 'type-error :datum nil + :expected-type t))) + (type-error-expected-type c nil))) + program-error) + +;;; Tests of env arguments to typep + +(deftest typep.env.1 + (notnot-mv (typep 0 'bit nil)) + t) + +(deftest typep.env.2 + (macrolet ((%foo (&environment env) + (notnot-mv (typep 0 'bit env)))) + (%foo)) + t) + +(deftest typep.env.3 + (macrolet ((%foo (&environment env) + (notnot-mv (typep env (type-of env))))) + (%foo)) + t) + +;;; Other typep tests + +(deftest typep.1 + (notnot-mv (typep 'a '(eql a))) + t) + +(deftest typep.2 + (notnot-mv (typep 'a '(and (eql a)))) + t) + +(deftest typep.3 + (notnot-mv (typep 'a '(or (eql a)))) + t) + +(deftest typep.4 + (typep 'a '(eql b)) + nil) + +(deftest typep.5 + (typep 'a '(and (eql b))) + nil) + +(deftest typep.6 + (typep 'a '(or (eql b))) + nil) + +(deftest typep.7 + (notnot-mv (typep 'a '(satisfies symbolp))) + t) + +(deftest typep.8 + (typep 10 '(satisfies symbolp)) + nil) + +(deftest typep.9 + (let ((class (find-class 'symbol))) + (notnot-mv (typep 'a class))) + t) + +(deftest typep.10 + (let ((class (find-class 'symbol))) + (notnot-mv (typep 'a `(and ,class)))) + t) + +(deftest typep.11 + (let ((class (find-class 'symbol))) + (typep 10 class)) + nil) + +(deftest typep.12 + (let ((class (find-class 'symbol))) + (typep 10 `(and ,class))) + nil) + +(deftest typep.13 + (typep 'a '(and symbol integer)) + nil) + +(deftest typep.14 + (notnot-mv (typep 'a '(or symbol integer))) + t) + +(deftest typep.15 + (notnot-mv (typep 'a '(or integer symbol))) + t) + +(deftest typep.16 + (let ((c1 (find-class 'number)) + (c2 (find-class 'symbol))) + (notnot-mv (typep 'a `(or ,c1 ,c2)))) + t) + +(deftest typep.17 + (let ((c1 (find-class 'number)) + (c2 (find-class 'symbol))) + (notnot-mv (typep 'a `(or ,c2 ,c1)))) + t) diff --git a/ansi-tests/universe.lsp b/ansi-tests/universe.lsp new file mode 100644 index 0000000..d7383d1 --- /dev/null +++ b/ansi-tests/universe.lsp @@ -0,0 +1,397 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Thu Apr 9 19:32:56 1998 +;;;; Contains: A global variable containing a list of +;;;; as many kinds of CL objects as we can think of +;;;; This list is used to test many other CL functions + +(in-package :cl-test) + +(defvar *condition-types* + '(arithmetic-error + cell-error + condition + control-error + division-by-zero + end-of-file + error + file-error + floating-point-inexact + floating-point-invalid-operation + floating-point-underflow + floating-point-overflow + package-error + parse-error + print-not-readable + program-error + reader-error + serious-condition + simple-condition + simple-error + simple-type-error + simple-warning + storage-condition + stream-error + style-warning + type-error + unbound-slot + unbound-variable + undefined-function + warning)) + +(defvar *condition-objects* + (loop for tp in *condition-types* append + (handler-case (list (make-condition tp)) + (error () nil)))) + +(defvar *standard-package-names* + '("COMMON-LISP" "COMMON-LISP-USER" "KEYWORD")) + +(defvar *package-objects* + (loop for pname in *standard-package-names* append + (handler-case (let ((pkg (find-package pname))) + (and pkg (list pkg))) + (error () nil)))) + +(defvar *integers* + (remove-duplicates + `( + 0 + ;; Integers near the fixnum/bignum boundaries + ,@(loop for i from -5 to 5 collect (+ i most-positive-fixnum)) + ,@(loop for i from -5 to 5 collect (+ i most-negative-fixnum)) + ;; Powers of two, negatives, and off by one. + ,@(loop for i from 1 to 64 collect (ash 1 i)) + ,@(loop for i from 1 to 64 collect (1- (ash 1 i))) + ,@(loop for i from 1 to 64 collect (ash -1 i)) + ,@(loop for i from 1 to 64 collect (1+ (ash -1 i))) + ;; A big integer + ,(expt 17 50) + ;; Some arbitrarily chosen integers + 12387131 1272314 231 -131 -561823 23713 -1234611312123 444121 991))) + +(defvar *floats* + (append + (loop for sym in '(pi + most-positive-short-float + least-positive-short-float + least-positive-normalized-short-float + most-positive-double-float + least-positive-double-float + least-positive-normalized-double-float + most-positive-long-float + least-positive-long-float + least-positive-normalized-long-float + most-positive-single-float + least-positive-single-float + least-positive-normalized-single-float + most-negative-short-float + least-negative-short-float + least-negative-normalized-short-float + most-negative-single-float + least-negative-single-float + least-negative-normalized-single-float + most-negative-double-float + least-negative-double-float + least-negative-normalized-double-float + most-negative-long-float + least-negative-long-float + least-negative-normalized-long-float + short-float-epsilon + short-float-negative-epsilon + single-float-epsilon + single-float-negative-epsilon + double-float-epsilon + double-float-negative-epsilon + long-float-epsilon + long-float-negative-epsilon) + when (boundp sym) collect (symbol-value sym)) + (list + 0.0 1.0 -1.0 313123.13 283143.231 -314781.9 + 1.31283d2 834.13812D-45 + 8131238.1E14 -4618926.231e-2 + -37818.131F3 81.318231f-19 + 1.31273s3 12361.12S-7 + 6124.124l0 13123.1L-23))) + +(defvar *ratios* + '(1/3 1/1000 1/1000000000000000 -10/3 -1000/7 -987129387912381/13612986912361 + 189729874978126783786123/1234678123487612347896123467851234671234)) + +(defvar *complexes* + '(#C(0.0 0.0) + #C(1.0 0.0) + #C(0.0 1.0) + #C(1.0 1.0) + #C(-1.0 -1.0) + #C(1289713.12312 -9.12681271) + #C(1.0D100 1.0D100) + #C(-1.0D-100 -1.0D-100))) + +(defvar *numbers* + (append *integers* + *floats* + *ratios* + *complexes*)) + +(defun try-to-read-chars (&rest namelist) + (loop + for name in namelist append + (handler-case + (list (read-from-string + (concatenate 'string "\#\\" name))) + (error () nil)))) + +(defvar *characters* + (remove-duplicates + `(#\Newline + #\Space + ,@(try-to-read-chars "Rubout" + "Page" + "Tab" + "Backspace" + "Return" + "Linefeed" + "Null") + #\a #\A #\0 #\9 #\. #\( #\) #\[ #\] + ))) + + +(defvar *strings* + (append + (and (code-char 0) + (list + (make-string 1 :initial-element (code-char 0)) + (make-string 10 :initial-element (code-char 0)))) + (list + "" "A" "a" "0" "abcdef" + "~!@#$%^&*()_+`1234567890-=<,>.?/:;\"'{[}]|\\ abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWYXZ" + (make-string 100000 :initial-element #\g) + (let ((s (make-string 256))) + (loop + for i from 0 to 255 + do (let ((c (code-char i))) + (when c + (setf (elt s i) c)))) + s) + ))) + +(defvar *conses* + (list + (list 'a 'b) + (list nil) + (list 1 2 3 4 5 6))) + +(defvar *circular-conses* + (list + (let ((s (copy-list '(a b c d)))) + (nconc s s) + s) + (let ((s (list nil))) + (setf (car s) s) + s) + (let ((s (list nil))) + (setf (car s) s) + (setf (cdr s) s)))) + +(defvar *booleans* '(nil t)) +(defvar *keywords* '(:a :b :|| :|a| :|1234|)) +(defvar *uninterned-symbols* + (list '#:nil '#:t '#:foo '#:||)) +(defvar *cl-test-symbols* + `(,(intern "a" :cl-test) + ,(intern "" :cl-test) + ,@(and (code-char 0) + (list (intern (make-string 1 :initial-element (code-char 0)) :cl-test))) + ,@(and (code-char 0) + (let* ((s (make-string 10 :initial-element (code-char 0))) + (s2 (copy-seq s)) + (s3 (copy-seq s))) + (setf (subseq s 3 4) "a") + (setf (subseq s2 4 5) "a") + (setf (subseq s3 4 5) "a") + (setf (subseq s3 7 8) "b") + (list (intern s :cl-test) + (intern s2 :cl-test) + (intern s3 :cl-test)))) + )) + +(defvar *cl-user-symbols* + '(cl-user::foo cl-user::x + cl-user::cons cl-user::lambda + cl-user::*print-readably* cl-user::push)) + +(defvar *symbols* + (append *booleans* *keywords* *uninterned-symbols* + *cl-test-symbols* + *cl-user-symbols*)) + +(defvar *array-dimensions* + (loop + for i from 0 to 8 collect + (loop for j from 1 to i collect 2))) + +(defvar *default-array-target* (make-array '(300))) + +(defvar *arrays* + (append + (list (make-array '10)) + (mapcar #'make-array *array-dimensions*) + + ;; typed arrays + (loop for tp in '(fixnum float bit character base-char + (signed-byte 8) (unsigned-byte 8)) + append + (loop + for d in *array-dimensions* + collect (make-array d :element-type tp))) + + ;; adjustable arrays + (loop + for d in *array-dimensions* + collect (make-array d :adjustable t)) + + ;; Displaced arrays + (loop + for d in *array-dimensions* + for i from 1 + collect (make-array d :displaced-to *default-array-target* + :displaced-index-offset i)) + + (list + #() + #* + #*00000 + #*1010101010101101) + + ;; Integer arrays + (list + (make-array '(10) :element-type '(integer 0 (256)) + :initial-contents '(8 9 10 11 12 1 2 3 4 5)) + (make-array '(10) :element-type '(integer -128 (128)) + :initial-contents '(8 9 -10 11 -12 1 -2 -3 4 5)) + (make-array '(6) :element-type '(integer 0 (#.(ash 1 16))) + :initial-contents '(5 9 100 1312 23432 87)) + (make-array '(4) :element-type '(integer 0 (#.(ash 1 28))) + :initial-contents '(100000 231213 8123712 19)) + (make-array '(4) :element-type '(integer 0 (#.(ash 1 32))) + :initial-contents '(#.(1- (ash 1 32)) 0 872312 10000000)) + + (make-array nil :element-type '(integer 0 (256)) + :initial-element 14) + (make-array '(2 2) :element-type '(integer 0 (256)) + :initial-contents '((34 98)(14 119))) + ) + + ;; Float arrays + (list + (make-array '(5) :element-type 'short-float + :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0)) + (make-array '(5) :element-type 'single-float + :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0)) + (make-array '(5) :element-type 'double-float + :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0)) + (make-array '(5) :element-type 'long-float + :initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0)) + ) + + ;; more kinds of arrays here later + )) + +(defvar *hash-tables* + (list + (make-hash-table) + (make-hash-table :test #'eq) + (make-hash-table :test #'eql) + (make-hash-table :test #'equal) + #-(or GCL CMU ECL) (make-hash-table :test #'equalp) + )) + +(defvar *pathnames* + (list + (make-pathname :name "foo") + (make-pathname :name "bar") + (make-pathname :name "foo" :type "txt") + (make-pathname :name "bar" :type "txt") + (make-pathname :name :wild) + (make-pathname :name :wild :type "txt") + )) + +(defvar *streams* + (remove-duplicates + (remove-if + #'null + (list + *debug-io* + *error-output* + *query-io* + *standard-input* + *standard-output* + *terminal-io* + *trace-output*)))) + +(defvar *readtables* + (list *readtable* + (copy-readtable))) + +(defstruct foo-structure + x y z) + +(defstruct bar-structure + x y z) + +(defvar *structures* + (list + (make-foo-structure :x 1 :y 'a :z nil) + (make-foo-structure :x 1 :y 'a :z nil) + (make-bar-structure :x 1 :y 'a :z nil) + )) + +(defvar *functions* + (list #'cons #'car #'append #'values + (macro-function 'cond) + #'(lambda (x) x))) + +(defvar *random-states* + (list (make-random-state))) + +(defvar *universe* + (remove-duplicates + (append + *symbols* + *numbers* + *characters* + (mapcar #'copy-seq *strings*) + *conses* + *condition-objects* + *package-objects* + *arrays* + *hash-tables* + *pathnames* + *streams* + *readtables* + *structures* + *functions* + *random-states* + nil))) + +(defvar *mini-universe* + (remove-duplicates + (mapcar #'first + (list *symbols* + *numbers* + *characters* + (mapcar #'copy-seq *strings*) + *conses* + *condition-objects* + *package-objects* + *arrays* + *hash-tables* + *pathnames* + *streams* + *readtables* + *structures* + *functions* + *random-states*)))) + + diff --git a/ansi-tests/unless.lsp b/ansi-tests/unless.lsp new file mode 100644 index 0000000..11a93a6 --- /dev/null +++ b/ansi-tests/unless.lsp @@ -0,0 +1,49 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Oct 18 19:39:34 2002 +;;;; Contains: Tests of UNLESS + +(in-package :cl-test) + +(deftest unless.1 + (unless t) + nil) + +(deftest unless.2 + (unless nil) + nil) + +(deftest unless.3 + (unless 'b 'a) + nil) + +(deftest unless.4 + (unless nil 'a) + a) + +(deftest unless.5 (unless nil (values))) + +(deftest unless.6 + (unless nil (values 1 2 3 4)) + 1 2 3 4) + +(deftest unless.7 + (unless 1 (values)) + nil) + +(deftest unless.8 + (unless #() (values 1 2 3 4)) + nil) + +(deftest unless.9 + (let ((x 0)) + (values + (unless nil + (incf x) + 'a) + x)) + a 1) + +;;; (deftest unless.error.1 +;;; (classify-error (unless)) +;;; program-error) diff --git a/ansi-tests/unwind-protect.lsp b/ansi-tests/unwind-protect.lsp new file mode 100644 index 0000000..03d6fd3 --- /dev/null +++ b/ansi-tests/unwind-protect.lsp @@ -0,0 +1,90 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Oct 12 14:41:16 2002 +;;;; Contains: Tests of UNWIND-PROTECT + +(in-package :cl-test) + +(deftest unwind-protect.1 + (let ((x nil)) + (unwind-protect + (push 1 x) + (incf (car x)))) + (2)) + +(deftest unwind-protect.2 + (let ((x nil)) + (block foo + (unwind-protect + (progn (push 1 x) (return-from foo x)) + (incf (car x))))) + (2)) + +(deftest unwind-protect.3 + (let ((x nil)) + (tagbody + (unwind-protect + (progn (push 1 x) (go done)) + (incf (car x))) + done) + x) + (2)) + +(deftest unwind-protect.4 + (let ((x nil)) + (catch 'done + (unwind-protect + (progn (push 1 x) (throw 'done x)) + (incf (car x))))) + (2)) + +(deftest unwind-protect.5 + (let ((x nil)) + (ignore-errors + (unwind-protect + (progn (push 1 x) (error "Boo!")) + (incf (car x)))) + x) + (2)) + +(deftest unwind-protect.6 + (let ((x nil)) + (block done + (flet ((%f () (return-from done nil))) + (unwind-protect (%f) + (push 'a x)))) + x) + (a)) + +(deftest unwind-protect.7 + (let ((x nil)) + (block done + (flet ((%f () (return-from done nil))) + (unwind-protect + (unwind-protect (%f) + (push 'b x)) + (push 'a x)))) + x) + (a b)) + +(deftest unwind-protect.8 + (let ((x nil)) + (block done + (unwind-protect + (flet ((%f () (return-from done nil))) + (unwind-protect + (unwind-protect (%f) + (push 'b x)) + (push 'a x))) + (push 'c x))) + x) + (c a b)) + +(deftest unwind-protect.9 + (let ((x nil)) + (handler-case + (flet ((%f () (error 'type-error :datum 'foo :expected-type nil))) + (unwind-protect (handler-case (%f)) + (push 'a x))) + (type-error () x))) + (a)) diff --git a/ansi-tests/upgraded-array-element-type.lsp b/ansi-tests/upgraded-array-element-type.lsp new file mode 100644 index 0000000..58eb51c --- /dev/null +++ b/ansi-tests/upgraded-array-element-type.lsp @@ -0,0 +1,108 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Jan 22 20:43:55 2003 +;;;; Contains: Tests of UPGRADED-ARRAY-ELEMENT-TYPE + +(in-package :cl-test) + +(deftest upgraded-array-element-type.1 + (let ((upgraded-bit (upgraded-array-element-type 'bit))) + (and (empirical-subtypep 'bit upgraded-bit) + (empirical-subtypep upgraded-bit 'bit))) + t) + +(deftest upgraded-array-element-type.2 + (let ((upgraded-base-char (upgraded-array-element-type 'base-char))) + (and (empirical-subtypep 'base-char upgraded-base-char) + (empirical-subtypep upgraded-base-char 'base-char))) + t) + +(deftest upgraded-array-element-type.3 + (let ((upgraded-character (upgraded-array-element-type 'character))) + (and (empirical-subtypep 'character upgraded-character) + (empirical-subtypep upgraded-character 'character))) + t) + +(defparameter *upgraded-array-types-to-check* + `(boolean + base-char + character + t + ,@(loop for i from 0 to 32 + collect `(integer 0 (,(ash 1 i)))) + symbol + ,@(loop for i from 0 to 32 + collect `(integer ,(- (ash 1 i)) (,(ash 1 i)))) + (integer -10000000000000000000000000000000000 + 10000000000000000000000000000000000) + float + short-float + single-float + double-float + complex + rational + fixnum + function + sequence + list + cons + atom + symbol)) + +(deftest upgraded-array-element-type.4 + (loop for type in *upgraded-array-types-to-check* + for upgraded-type = (upgraded-array-element-type type) + always (empirical-subtypep type upgraded-type)) + t) + +;; Include an environment (NIL, denoting the default null lexical +;; environment) + +(deftest upgraded-array-element-type.5 + (loop for type in *upgraded-array-types-to-check* + for upgraded-type = (upgraded-array-element-type type nil) + always (empirical-subtypep type upgraded-type)) + t) + +(deftest upgraded-array-element-type.6 + (macrolet + ((%foo (&environment env) + (empirical-subtypep + 'bit + (upgraded-array-element-type 'bit env)))) + (%foo)) + t) + +(deftest upgraded-array-element-type.7 + (let ((upgraded-types (mapcar #'upgraded-array-element-type + *upgraded-array-types-to-check*))) + (loop for type in *upgraded-array-types-to-check* + for upgraded-type in upgraded-types + append + (loop for type2 in *upgraded-array-types-to-check* + for upgraded-type2 in upgraded-types + when (and (subtypep type type2) + (equal (subtypep* upgraded-type upgraded-type) + '(nil t))) + collect (list type type2)))) + nil) + +;;; Tests of upgrading NIL (it should be type equivalent to NIL) + +(deftest upgraded-array-element-type.nil.1 + (let ((uaet-nil (upgraded-array-element-type nil))) + (loop for e in *universe* + when (typep e uaet-nil) + collect e)) + nil) + + +;;; Error tests + +(deftest upgraded-array-element-type.error.1 + (classify-error (upgraded-array-element-type)) + program-error) + +(deftest upgraded-array-element-type.error.2 + (classify-error (upgraded-array-element-type 'bit nil nil)) + program-error) diff --git a/ansi-tests/values-list.lsp b/ansi-tests/values-list.lsp new file mode 100644 index 0000000..f48e924 --- /dev/null +++ b/ansi-tests/values-list.lsp @@ -0,0 +1,40 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Mon Jan 13 16:53:39 2003 +;;;; Contains: Tests for VALUES-LIST + +(in-package :cl-test) + +(deftest values-list.error.1 + (classify-error (values-list)) + program-error) + +(deftest values-list.error.2 + (classify-error (values-list nil nil)) + program-error) + +(deftest values-list.1 + (values-list nil)) + +(deftest values-list.2 + (values-list '(1)) + 1) + +(deftest values-list.3 + (values-list '(1 2)) + 1 2) + +(deftest values-list.4 + (values-list '(a b c d e f g h i j)) + a b c d e f g h i j) + +(deftest values-list.5 + (let ((x (loop for i from 1 to (min 1000 + (1- call-arguments-limit) + (1- multiple-values-limit)) + collect i))) + (equalt x + (multiple-value-list (values-list x)))) + t) + + diff --git a/ansi-tests/values.lsp b/ansi-tests/values.lsp new file mode 100644 index 0000000..32e4d99 --- /dev/null +++ b/ansi-tests/values.lsp @@ -0,0 +1,62 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Oct 19 08:18:50 2002 +;;;; Contains: Tests of VALUES + +(in-package :cl-test) + +(deftest values.0 + (values)) + +(deftest values.1 + (values 1) + 1) + +(deftest values.2 + (values 1 2) + 1 2) + +(deftest values.3 + (values 1 2 3) + 1 2 3) + +(deftest values.4 + (values 1 2 3 4) + 1 2 3 4) + +(deftest values.10 + (values 1 2 3 4 5 6 7 8 9 10) + 1 2 3 4 5 6 7 8 9 10) + +(deftest values.15 + (values 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) + 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) + +(deftest values.19 + (values 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19) + 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19) + +(deftest values.A + (values (values 1 2) (values 3 4 5) (values) (values 10)) + 1 3 nil 10) + +(deftest values.B + (funcall #'values 1 2 3 4) + 1 2 3 4) + +(deftest values.C + (let ((x (loop for i from 1 to (min 1000 + (1- call-arguments-limit) + (1- multiple-values-limit)) + collect i))) + (equalt x + (multiple-value-list (apply #'values x)))) + t) + +(deftest values.order.1 + (let ((i 0) a b c) + (values (multiple-value-list + (values (setf a (incf i)) (setf b (incf i)) (setf c (incf i)))) + i a b c)) + (1 2 3) 3 1 2 3) + diff --git a/ansi-tests/vector-pop.lsp b/ansi-tests/vector-pop.lsp new file mode 100644 index 0000000..e5d7d9e --- /dev/null +++ b/ansi-tests/vector-pop.lsp @@ -0,0 +1,44 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Jan 24 07:46:29 2003 +;;;; Contains: Tests for VECTOR-POP + +(in-package :cl-test) + +(deftest vector-pop.1 + (let ((v (make-array '(5) :initial-contents '(a b c d e) + :fill-pointer 3))) + (values + (length v) + (check-values (vector-pop v)) + (fill-pointer v) + (length v) + v)) + 3 c 2 2 #(a b)) + +;;; Error cases + +(deftest vector-pop.error.1 + (classify-error (vector-pop (vector 1 2 3))) + type-error) + +(deftest vector-pop.error.2 + (let ((v (make-array '(5) :initial-element 'x + :fill-pointer 0))) + (handler-case (vector-pop v) + (error () 'error))) + error) + +(deftest vector-pop.error.3 + (classify-error (vector-pop)) + program-error) + +(deftest vector-pop.error.4 + (classify-error (let ((v (make-array '(5) :fill-pointer t + :initial-element 'x))) + (vector-pop v nil))) + program-error) + +(deftest vector-pop.error.5 + (classify-error (locally (vector-pop (vector 1 2 3)) t)) + type-error) diff --git a/ansi-tests/vector-push-extend.lsp b/ansi-tests/vector-push-extend.lsp new file mode 100644 index 0000000..63903d6 --- /dev/null +++ b/ansi-tests/vector-push-extend.lsp @@ -0,0 +1,362 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Jan 25 08:04:35 2003 +;;;; Contains: Tests for VECTOR-PUSH-EXTEND + +(in-package :cl-test) + +(deftest vector-push-extend.1 + (let ((a (make-array '(5) :fill-pointer 2 + :initial-contents '(a b c d e))) + (i 0) x y) + (values + (fill-pointer a) + (vector-push-extend (progn (setf x (incf i)) 'x) + (progn (setf y (incf i)) a)) + (fill-pointer a) + a + i x y)) + 2 2 3 #(a b x) 2 1 2) + +(deftest vector-push-extend.2 + (let ((a (make-array '(5) :fill-pointer 5 + :adjustable t + :initial-contents '(a b c d e)))) + (values + (fill-pointer a) + (vector-push-extend 'x a) + (fill-pointer a) + (<= (array-total-size a) 5) + a)) + 5 5 6 nil #(a b c d e x)) + +(deftest vector-push-extend.3 + (let ((a (make-array '(5) :fill-pointer 2 + :initial-contents "abcde" + :element-type 'base-char))) + (values + (fill-pointer a) + (vector-push-extend #\x a) + (fill-pointer a) + a)) + 2 2 3 "abx") + +(deftest vector-push-extend.4 + (let ((a (make-array '(5) :fill-pointer 5 + :adjustable t + :initial-contents "abcde" + :element-type 'base-char)) + (i 0) x y z) + (values + (fill-pointer a) + (vector-push-extend (progn (setf x (incf i)) #\x) + (progn (setf y (incf i)) a) + (progn (setf z (incf i)) 1)) + (fill-pointer a) + (<= (array-total-size a) 5) + a + i x y z)) + 5 5 6 nil "abcdex" 3 1 2 3) + +(deftest vector-push-extend.5 + (let ((a (make-array '(5) :fill-pointer 2 + :initial-contents "abcde" + :element-type 'character))) + (values + (fill-pointer a) + (vector-push-extend #\x a) + (fill-pointer a) + a)) + 2 2 3 "abx") + +(deftest vector-push-extend.6 + (let ((a (make-array '(5) :fill-pointer 5 + :adjustable t + :initial-contents "abcde" + :element-type 'character))) + (values + (fill-pointer a) + (vector-push-extend #\x a 10) + (fill-pointer a) + (<= (array-total-size a) 5) + a)) + 5 5 6 nil "abcdex") + +(deftest vector-push-extend.7 + (let ((a (make-array '(5) :fill-pointer 2 + :initial-contents '(0 1 1 0 0) + :element-type 'bit))) + (values + (fill-pointer a) + (vector-push-extend 0 a) + (fill-pointer a) + a)) + 2 2 3 #*010) + +(deftest vector-push-extend.8 + (let ((a (make-array '(5) :fill-pointer 5 + :adjustable t + :initial-contents '(0 0 0 0 0) + :element-type 'bit))) + (values + (fill-pointer a) + (vector-push-extend 1 a 100) + (fill-pointer a) + (<= (array-total-size a) 5) + a)) + 5 5 6 nil #*000001) + +(deftest vector-push-extend.9 + (let ((a (make-array '(5) :fill-pointer 2 + :initial-contents '(1 2 3 4 5) + :element-type 'fixnum))) + (values + (fill-pointer a) + (vector-push-extend 0 a) + (fill-pointer a) + a)) + 2 2 3 #(1 2 0)) + +(deftest vector-push-extend.10 + (let ((a (make-array '(5) :fill-pointer 5 + :adjustable t + :initial-contents '(1 2 3 4 5) + :element-type 'fixnum))) + (values + (fill-pointer a) + (vector-push-extend 0 a 1) + (fill-pointer a) + (<= (array-total-size a) 5) + a)) + 5 5 6 nil #(1 2 3 4 5 0)) + +(deftest vector-push-extend.11 + (let ((a (make-array '(5) :fill-pointer 2 + :initial-contents '(1 2 3 4 5) + :element-type '(integer 0 (256))))) + (values + (fill-pointer a) + (vector-push-extend 0 a) + (fill-pointer a) + a)) + 2 2 3 #(1 2 0)) + +(deftest vector-push-extend.12 + (let ((a (make-array '(5) :fill-pointer 5 + :adjustable t + :initial-contents '(1 2 3 4 5) + :element-type '(integer 0 (256))))) + (values + (fill-pointer a) + (vector-push-extend 0 a 1) + (fill-pointer a) + (<= (array-total-size a) 5) + a)) + 5 5 6 nil #(1 2 3 4 5 0)) + +(deftest vector-push-extend.13 + (let ((a (make-array '(5) :fill-pointer 2 + :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0) + :element-type 'short-float))) + (values + (fill-pointer a) + (vector-push-extend 0.0s0 a) + (fill-pointer a) + a)) + 2 2 3 #(1.0s0 2.0s0 0.0s0)) + +(deftest vector-push-extend.14 + (let ((a (make-array '(5) :fill-pointer 5 + :adjustable t + :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0) + :element-type 'short-float))) + (values + (fill-pointer a) + (vector-push-extend 0.0s0 a 1) + (fill-pointer a) + (<= (array-total-size a) 5) + a)) + 5 5 6 nil #(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0 0.0s0)) + +(deftest vector-push-extend.15 + (let ((a (make-array '(5) :fill-pointer 2 + :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0) + :element-type 'single-float))) + (values + (fill-pointer a) + (vector-push-extend 0.0f0 a) + (fill-pointer a) + a)) + 2 2 3 #(1.0f0 2.0f0 0.0f0)) + +(deftest vector-push-extend.16 + (let ((a (make-array '(5) :fill-pointer 5 + :adjustable t + :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0) + :element-type 'single-float))) + (values + (fill-pointer a) + (vector-push-extend 0.0f0 a 1) + (fill-pointer a) + (<= (array-total-size a) 5) + a)) + 5 5 6 nil #(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0 0.0f0)) + + +(deftest vector-push-extend.17 + (let ((a (make-array '(5) :fill-pointer 2 + :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0) + :element-type 'double-float))) + (values + (fill-pointer a) + (vector-push-extend 0.0d0 a) + (fill-pointer a) + a)) + 2 2 3 #(1.0d0 2.0d0 0.0d0)) + +(deftest vector-push-extend.18 + (let ((a (make-array '(5) :fill-pointer 5 + :adjustable t + :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0) + :element-type 'double-float))) + (values + (fill-pointer a) + (vector-push-extend 0.0d0 a 1) + (fill-pointer a) + (<= (array-total-size a) 5) + a)) + 5 5 6 nil #(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0 0.0d0)) + +(deftest vector-push-extend.19 + (let ((a (make-array '(5) :fill-pointer 2 + :initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0) + :element-type 'long-float))) + (values + (fill-pointer a) + (vector-push-extend 0.0l0 a) + (fill-pointer a) + a)) + 2 2 3 #(1.0l0 2.0l0 0.0l0)) + +(deftest vector-push-extend.20 + (let ((a (make-array '(5) :fill-pointer 5 + :adjustable t + :initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0) + :element-type 'long-float))) + (values + (fill-pointer a) + (vector-push-extend 0.0l0 a 1) + (fill-pointer a) + (<= (array-total-size a) 5) + a)) + 5 5 6 nil #(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0 0.0l0)) + + + +;;; Error tests + +(defun vector-push-extend-error-test (seq val) + (declare (optimize (safety 3))) + (handler-case + (eval `(let ((a (copy-seq ,seq))) + (declare (optimize (safety 3))) + (or (notnot (array-has-fill-pointer-p a)) + (vector-push-extend ',val a 1)))) + (error () t))) + +(deftest vector-push-extend.error.1 + (vector-push-extend-error-test #(a b c d) 'x) + t) + +(deftest vector-push-extend.error.2 + (vector-push-extend-error-test #*00000 1) + t) + +(deftest vector-push-extend.error.3 + (vector-push-extend-error-test "abcde" #\x) + t) + +(deftest vector-push-extend.error.4 + (vector-push-extend-error-test #() 'x) + t) + +(deftest vector-push-extend.error.5 + (vector-push-extend-error-test #* 1) + t) + +(deftest vector-push-extend.error.6 + (vector-push-extend-error-test "" #\x) + t) + +(deftest vector-push-extend.error.7 + (vector-push-extend-error-test (make-array '5 :element-type 'base-char + :initial-element #\a) + #\x) + t) + +(deftest vector-push-extend.error.8 + (vector-push-extend-error-test (make-array '5 :element-type '(integer 0 (256)) + :initial-element 0) + 17) + t) + +(deftest vector-push-extend.error.9 + (vector-push-extend-error-test (make-array '5 :element-type 'float + :initial-element 1.0) + 2.0) + t) + +(deftest vector-push-extend.error.10 + (vector-push-extend-error-test (make-array '5 :element-type 'short-float + :initial-element 1.0s0) + 2.0s0) + t) + +(deftest vector-push-extend.error.11 + (vector-push-extend-error-test (make-array '5 :element-type 'long-float + :initial-element 1.0l0) + 2.0l0) + t) + +(deftest vector-push-extend.error.12 + (vector-push-extend-error-test (make-array '5 :element-type 'single-float + :initial-element 1.0f0) + 2.0f0) + t) + +(deftest vector-push-extend.error.13 + (vector-push-extend-error-test (make-array '5 :element-type 'double-float + :initial-element 1.0d0) + 2.0d0) + t) + +(deftest vector-push-extend.error.14 + (classify-error (vector-push-extend)) + program-error) + +(deftest vector-push-extend.error.15 + (classify-error (vector-push-extend (vector 1 2 3))) + program-error) + +(deftest vector-push-extend.error.16 + (classify-error (vector-push-extend (vector 1 2 3) 4 1 nil)) + program-error) + +(deftest vector-push-extend.error.17 + (handler-case + (eval + `(locally + (declare (optimize (safety 3))) + (let ((a (make-array '5 :fill-pointer t :adjustable nil + :initial-element nil))) + (or (notnot (adjustable-array-p a)) ; It's actually adjustable, or... + (vector-push-extend a 'x) ; ... this fails + )))) + (error () t)) + t) + + + + + + diff --git a/ansi-tests/vector-push.lsp b/ansi-tests/vector-push.lsp new file mode 100644 index 0000000..6cb106b --- /dev/null +++ b/ansi-tests/vector-push.lsp @@ -0,0 +1,319 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Jan 25 00:55:43 2003 +;;;; Contains: Tests for VECTOR-PUSH + +(in-package :cl-test) + +(deftest vector-push.1 + (let ((a (make-array '(5) :fill-pointer 2 + :initial-contents '(a b c d e))) + (i 0) x y) + (values + (fill-pointer a) + (vector-push (progn (setf x (incf i)) 'x) + (progn (setf y (incf i)) a)) + (fill-pointer a) + a i x y)) + 2 2 3 #(a b x) 2 1 2) + + +(deftest vector-push.2 + (let ((a (make-array '(5) :fill-pointer 5 + :initial-contents '(a b c d e)))) + (values + (fill-pointer a) + (vector-push 'x a) + (fill-pointer a) + a)) + 5 nil 5 #(a b c d e)) + +(deftest vector-push.3 + (let ((a (make-array '(5) :fill-pointer 2 + :initial-contents "abcde" + :element-type 'base-char))) + (values + (fill-pointer a) + (vector-push #\x a) + (fill-pointer a) + a)) + 2 2 3 "abx") + +(deftest vector-push.4 + (let ((a (make-array '(5) :fill-pointer 5 + :initial-contents "abcde" + :element-type 'base-char))) + (values + (fill-pointer a) + (vector-push #\x a) + (fill-pointer a) + a)) + 5 nil 5 "abcde") + +(deftest vector-push.5 + (let ((a (make-array '(5) :fill-pointer 2 + :initial-contents "abcde" + :element-type 'character))) + (values + (fill-pointer a) + (vector-push #\x a) + (fill-pointer a) + a)) + 2 2 3 "abx") + +(deftest vector-push.6 + (let ((a (make-array '(5) :fill-pointer 5 + :initial-contents "abcde" + :element-type 'character))) + (values + (fill-pointer a) + (vector-push #\x a) + (fill-pointer a) + a)) + 5 nil 5 "abcde") + +(deftest vector-push.7 + (let ((a (make-array '(5) :fill-pointer 2 + :initial-contents '(0 1 1 0 0) + :element-type 'bit))) + (values + (fill-pointer a) + (vector-push 0 a) + (fill-pointer a) + a)) + 2 2 3 #*010) + +(deftest vector-push.8 + (let ((a (make-array '(5) :fill-pointer 5 + :initial-contents '(0 0 0 0 0) + :element-type 'bit))) + (values + (fill-pointer a) + (vector-push 1 a) + (fill-pointer a) + a)) + 5 nil 5 #*00000) + +(deftest vector-push.9 + (let ((a (make-array '(5) :fill-pointer 2 + :initial-contents '(1 2 3 4 5) + :element-type 'fixnum))) + (values + (fill-pointer a) + (vector-push 0 a) + (fill-pointer a) + a)) + 2 2 3 #(1 2 0)) + +(deftest vector-push.10 + (let ((a (make-array '(5) :fill-pointer 5 + :initial-contents '(1 2 3 4 5) + :element-type 'fixnum))) + (values + (fill-pointer a) + (vector-push 0 a) + (fill-pointer a) + a)) + 5 nil 5 #(1 2 3 4 5)) + +(deftest vector-push.11 + (let ((a (make-array '(5) :fill-pointer 2 + :initial-contents '(1 2 3 4 5) + :element-type '(integer 0 (256))))) + (values + (fill-pointer a) + (vector-push 0 a) + (fill-pointer a) + a)) + 2 2 3 #(1 2 0)) + +(deftest vector-push.12 + (let ((a (make-array '(5) :fill-pointer 5 + :initial-contents '(1 2 3 4 5) + :element-type '(integer 0 (256))))) + (values + (fill-pointer a) + (vector-push 0 a) + (fill-pointer a) + a)) + 5 nil 5 #(1 2 3 4 5)) + +(deftest vector-push.13 + (let ((a (make-array '(5) :fill-pointer 2 + :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0) + :element-type 'short-float))) + (values + (fill-pointer a) + (vector-push 0.0s0 a) + (fill-pointer a) + a)) + 2 2 3 #(1.0s0 2.0s0 0.0s0)) + +(deftest vector-push.14 + (let ((a (make-array '(5) :fill-pointer 5 + :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0) + :element-type 'short-float))) + (values + (fill-pointer a) + (vector-push 0.0s0 a) + (fill-pointer a) + a)) + 5 nil 5 #(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0)) + +(deftest vector-push.15 + (let ((a (make-array '(5) :fill-pointer 2 + :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0) + :element-type 'single-float))) + (values + (fill-pointer a) + (vector-push 0.0f0 a) + (fill-pointer a) + a)) + 2 2 3 #(1.0f0 2.0f0 0.0f0)) + +(deftest vector-push.16 + (let ((a (make-array '(5) :fill-pointer 5 + :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0) + :element-type 'single-float))) + (values + (fill-pointer a) + (vector-push 0.0f0 a) + (fill-pointer a) + a)) + 5 nil 5 #(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0)) + + +(deftest vector-push.17 + (let ((a (make-array '(5) :fill-pointer 2 + :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0) + :element-type 'double-float))) + (values + (fill-pointer a) + (vector-push 0.0d0 a) + (fill-pointer a) + a)) + 2 2 3 #(1.0d0 2.0d0 0.0d0)) + +(deftest vector-push.18 + (let ((a (make-array '(5) :fill-pointer 5 + :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0) + :element-type 'double-float))) + (values + (fill-pointer a) + (vector-push 0.0d0 a) + (fill-pointer a) + a)) + 5 nil 5 #(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0)) + +(deftest vector-push.19 + (let ((a (make-array '(5) :fill-pointer 2 + :initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0) + :element-type 'long-float))) + (values + (fill-pointer a) + (vector-push 0.0l0 a) + (fill-pointer a) + a)) + 2 2 3 #(1.0l0 2.0l0 0.0l0)) + +(deftest vector-push.20 + (let ((a (make-array '(5) :fill-pointer 5 + :initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0) + :element-type 'long-float))) + (values + (fill-pointer a) + (vector-push 0.0l0 a) + (fill-pointer a) + a)) + 5 nil 5 #(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0)) + + + +;;; Error tests + +(defun vector-push-error-test (seq val) + (declare (optimize (safety 3))) + (handler-case + (eval `(let ((a (copy-seq ,seq))) + (declare (optimize (safety 3))) + (or (notnot (array-has-fill-pointer-p a)) + (vector-push ',val a)))) + (error () t))) + +(deftest vector-push.error.1 + (vector-push-error-test #(a b c d) 'x) + t) + +(deftest vector-push.error.2 + (vector-push-error-test #*00000 1) + t) + +(deftest vector-push.error.3 + (vector-push-error-test "abcde" #\x) + t) + +(deftest vector-push.error.4 + (vector-push-error-test #() 'x) + t) + +(deftest vector-push.error.5 + (vector-push-error-test #* 1) + t) + +(deftest vector-push.error.6 + (vector-push-error-test "" #\x) + t) + +(deftest vector-push.error.7 + (vector-push-error-test (make-array '5 :element-type 'base-char + :initial-element #\a) + #\x) + t) + +(deftest vector-push.error.8 + (vector-push-error-test (make-array '5 :element-type '(integer 0 (256)) + :initial-element 0) + 17) + t) + +(deftest vector-push.error.9 + (vector-push-error-test (make-array '5 :element-type 'float + :initial-element 1.0) + 2.0) + t) + +(deftest vector-push.error.10 + (vector-push-error-test (make-array '5 :element-type 'short-float + :initial-element 1.0s0) + 2.0s0) + t) + +(deftest vector-push.error.11 + (vector-push-error-test (make-array '5 :element-type 'long-float + :initial-element 1.0l0) + 2.0l0) + t) + +(deftest vector-push.error.12 + (vector-push-error-test (make-array '5 :element-type 'single-float + :initial-element 1.0f0) + 2.0f0) + t) + +(deftest vector-push.error.13 + (vector-push-error-test (make-array '5 :element-type 'double-float + :initial-element 1.0d0) + 2.0d0) + t) + +(deftest vector-push.error.14 + (classify-error (vector-push)) + program-error) + +(deftest vector-push.error.15 + (classify-error (vector-push (vector 1 2 3))) + program-error) + +(deftest vector-push.error.16 + (classify-error (vector-push (vector 1 2 3) 4 nil)) + program-error) diff --git a/ansi-tests/vector.lsp b/ansi-tests/vector.lsp new file mode 100644 index 0000000..2dc1bd4 --- /dev/null +++ b/ansi-tests/vector.lsp @@ -0,0 +1,331 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Thu Jan 23 06:32:02 2003 +;;;; Contains: Tests of VECTOR (type and function) + +(in-package :cl-test) + +;;; More tests of type vector in make-array.lsp + +(deftest vector.type.1 + (notnot-mv (typep #(a b c) 'vector)) + t) + +(deftest vector.type.2 + (notnot-mv (typep #() 'vector)) + t) + +(deftest vector.type.3 + (notnot-mv (typep "" 'vector)) + t) + +(deftest vector.type.4 + (notnot-mv (typep "abcdef" 'vector)) + t) + +(deftest vector.type.5 + (notnot-mv (typep #* 'vector)) + t) + +(deftest vector.type.6 + (notnot-mv (typep #*011011101011 'vector)) + t) + +(deftest vector.type.7 + (typep #0aNIL 'vector) + nil) + +(deftest vector.type.8 + (typep #2a((a b c d)) 'vector) + nil) + +(deftest vector.type.9 + (subtypep* 'vector 'array) + t t) + +(deftest vector.type.10 + (notnot-mv (typep #(a b c) '(vector *))) + t) + +(deftest vector.type.11 + (notnot-mv (typep #(a b c) '(vector t))) + t) + +(deftest vector.type.12 + (notnot-mv (typep "abcde" '(vector *))) + t) + +(deftest vector.type.13 + (typep "abcdef" '(vector t)) + nil) + +(deftest vector.type.14 + (notnot-mv (typep #*00110 '(vector *))) + t) + +(deftest vector.type.15 + (typep #*00110 '(vector t)) + nil) + +(deftest vector.type.16 + (notnot-mv (typep #(a b c) '(vector * 3))) + t) + +(deftest vector.type.17 + (typep #(a b c) '(vector * 2)) + nil) + +(deftest vector.type.18 + (typep #(a b c) '(vector * 4)) + nil) + +(deftest vector.type.19 + (notnot-mv (typep #(a b c) '(vector t 3))) + t) + +(deftest vector.type.20 + (typep #(a b c) '(vector t 2)) + nil) + +(deftest vector.type.21 + (typep #(a b c) '(vector t 4)) + nil) + +(deftest vector.type.23 + (notnot-mv (typep #(a b c) '(vector t *))) + t) + +(deftest vector.type.23a + (notnot-mv (typep "abcde" '(vector * 5))) + t) + +(deftest vector.type.24 + (typep "abcde" '(vector * 4)) + nil) + +(deftest vector.type.25 + (typep "abcde" '(vector * 6)) + nil) + +(deftest vector.type.26 + (notnot-mv (typep "abcde" '(vector * *))) + t) + +(deftest vector.type.27 + (typep "abcde" '(vector t 5)) + nil) + +(deftest vector.type.28 + (typep "abcde" '(vector t 4)) + nil) + +(deftest vector.type.29 + (typep "abcde" '(vector t 6)) + nil) + +(deftest vector.type.30 + (typep "abcde" '(vector t *)) + nil) + +(deftest vector.type.31 + (let ((s (coerce "abc" 'simple-base-string))) + (notnot-mv (typep s '(vector base-char)))) + t) + +(deftest vector.type.32 + (let ((s (coerce "abc" 'simple-base-string))) + (notnot-mv (typep s '(vector base-char 3)))) + t) + +(deftest vector.type.33 + (let ((s (coerce "abc" 'simple-base-string))) + (typep s '(vector base-char 2))) + nil) + +(deftest vector.type.34 + (let ((s (coerce "abc" 'simple-base-string))) + (typep s '(vector base-char 4))) + nil) + +(deftest vector.type.35 + (let ((s (coerce "abc" 'simple-base-string))) + (notnot-mv (typep s 'vector))) + t) + +(deftest vector.type.36 + (let ((s (coerce "abc" 'simple-base-string))) + (notnot-mv (typep s '(vector *)))) + t) + +(deftest vector.type.37 + (let ((s (coerce "abc" 'simple-base-string))) + (notnot-mv (typep s '(vector * 3)))) + t) + +(deftest vector.type.38 + (let ((s (coerce "abc" 'simple-base-string))) + (notnot-mv (typep s '(vector * *)))) + t) + +(deftest vector.type.39 + (let ((s (coerce "abc" 'simple-base-string))) + (typep s '(vector t))) + nil) + +(deftest vector.type.40 + (let ((s (coerce "abc" 'simple-base-string))) + (typep s '(vector t *))) + nil) + +(deftest vector.type.41 + (notnot-mv (typep (make-array '10 :element-type 'short-float) 'vector)) + t) + +(deftest vector.type.42 + (notnot-mv (typep (make-array '10 :element-type 'single-float) 'vector)) + t) + +(deftest vector.type.43 + (notnot-mv (typep (make-array '10 :element-type 'double-float) 'vector)) + t) + +(deftest vector.type.44 + (notnot-mv (typep (make-array '10 :element-type 'long-float) 'vector)) + t) + + +;;; Tests of vector as class + +(deftest vector-as-class.1 + (notnot-mv (find-class 'vector)) + t) + +(deftest vector-as-class.2 + (notnot-mv (typep #() (find-class 'vector))) + t) + +(deftest vector-as-class.3 + (notnot-mv (typep #(a b c) (find-class 'vector))) + t) + +(deftest vector-as-class.4 + (notnot-mv (typep "" (find-class 'vector))) + t) + +(deftest vector-as-class.5 + (notnot-mv (typep "abcd" (find-class 'vector))) + t) + +(deftest vector-as-class.6 + (notnot-mv (typep #* (find-class 'vector))) + t) + +(deftest vector-as-class.7 + (notnot-mv (typep #*01101010100 (find-class 'vector))) + t) + +(deftest vector-as-class.8 + (typep #0aNIL (find-class 'vector)) + nil) + +(deftest vector-as-class.9 + (typep #2a((a b)(c d)) (find-class 'vector)) + nil) + +(deftest vector-as-class.10 + (typep (make-array '(1 0)) (find-class 'vector)) + nil) + +(deftest vector-as-class.11 + (typep (make-array '(0 1)) (find-class 'vector)) + nil) + +(deftest vector-as-class.12 + (typep 1 (find-class 'vector)) + nil) + +(deftest vector-as-class.13 + (typep nil (find-class 'vector)) + nil) + +(deftest vector-as-class.14 + (typep 'x (find-class 'vector)) + nil) + +(deftest vector-as-class.15 + (typep '(a b c) (find-class 'vector)) + nil) + +(deftest vector-as-class.16 + (typep 10.0 (find-class 'vector)) + nil) + +(deftest vector-as-class.17 + (typep 3/5 (find-class 'vector)) + nil) + +(deftest vector-as-class.18 + (typep (1+ most-positive-fixnum) (find-class 'vector)) + nil) + +;;;; Tests of the function VECTOR + +(deftest vector.1 + (vector) + #()) + +(deftest vector.2 + (vector 1 2 3) + #(1 2 3)) + +(deftest vector.3 + (let* ((len (min 1000 (1- call-arguments-limit))) + (args (make-int-list len)) + (v (apply #'vector args))) + (and + (typep v '(vector t)) + (typep v '(vector t *)) + (typep v `(vector t ,len)) + (typep v 'simple-vector) + (typep v `(simple-vector ,len)) + (eql (length v) len) + (loop for i from 0 + for e across v + always (eql i e)) + t)) + t) + +(deftest vector.4 + (notnot-mv (typep (vector) '(vector t 0))) + t) + +(deftest vector.5 + (notnot-mv (typep (vector) 'simple-vector)) + t) + +(deftest vector.6 + (notnot-mv (typep (vector) '(simple-vector 0))) + t) + +(deftest vector.7 + (notnot-mv (typep (vector 1 2 3) 'simple-vector)) + t) + +(deftest vector.8 + (notnot-mv (typep (vector 1 2 3) '(simple-vector 3))) + t) + +(deftest vector.9 + (typep (vector #\a #\b #\c) 'string) + nil) + +(deftest vector.10 + (notnot-mv (typep (vector 1 2 3) '(simple-vector *))) + t) + +(deftest vector.order.1 + (let ((i 0) a b c) + (values + (vector (setf a (incf i)) (setf b (incf i)) (setf c (incf i))) + i a b c)) + #(1 2 3) 3 1 2 3) diff --git a/ansi-tests/vectorp.lsp b/ansi-tests/vectorp.lsp new file mode 100644 index 0000000..2404993 --- /dev/null +++ b/ansi-tests/vectorp.lsp @@ -0,0 +1,82 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Jan 26 13:17:05 2003 +;;;; Contains: Tests for VECTORP + +(in-package :cl-test) + +(deftest vectorp.1 + (vectorp 1) + nil) + +(deftest vectorp.2 + (vectorp (1+ most-positive-fixnum)) + nil) + +(deftest vectorp.3 + (vectorp #\a) + nil) + +(deftest vectorp.4 + (vectorp 10.0) + nil) + +(deftest vectorp.5 + (vectorp #'(lambda (x y) (cons y x))) + nil) + +(deftest vectorp.6 + (vectorp '(a b)) + nil) + +(deftest vectorp.7 + (vectorp #0aT) + nil) + +(deftest vectorp.8 + (vectorp #2a((a b)(c d))) + nil) + +(deftest vectorp.9 + (notnot-mv (vectorp "abcd")) + t) + +(deftest vectorp.10 + (notnot-mv (vectorp #*)) + t) + +(deftest vectorp.11 + (notnot-mv (vectorp #*1101)) + t) + +(deftest vectorp.12 + (notnot-mv (vectorp "")) + t) + +(deftest vectorp.13 + (notnot-mv (vectorp #(1 2 3))) + t) + +(deftest vectorp.14 + (notnot-mv (vectorp #())) + t) + +(deftest vectorp.15 + (vectorp #b11010) + nil) + +;;; Error tests + +(deftest vectorp.error.1 + (classify-error (vectorp)) + program-error) + +(deftest vectorp.error.2 + (classify-error (vectorp #() #())) + program-error) + + + + + + diff --git a/ansi-tests/warn.lsp b/ansi-tests/warn.lsp new file mode 100644 index 0000000..d16498d --- /dev/null +++ b/ansi-tests/warn.lsp @@ -0,0 +1,161 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Feb 23 20:48:12 2003 +;;;; Contains: Tests for WARN + +(in-package :cl-test) + +(deftest warn.1 + (let ((warned nil)) + (handler-bind + ((warning #'(lambda (c) + (assert (typep c 'simple-warning)) + (setf warned t) + (muffle-warning c)))) + (values + (multiple-value-list (warn "This is a warning")) + warned))) + (nil) t) + +(deftest warn.2 + (let ((warned nil)) + (handler-bind + ((warning #'(lambda (c) + (assert (typep c 'simple-warning)) + (setf warned t) + (muffle-warning)))) + (values + (multiple-value-list (warn "This is a warning")) + warned))) + (nil) t) + +(deftest warn.3 + (with-output-to-string + (*error-output*) + (let ((warned nil)) + (handler-bind + ((warning #'(lambda (c) + (assert (typep c 'simple-warning)) + (setf warned t) + (muffle-warning c)))) + (warn "Foo!")))) + "") + +(deftest warn.4 + (let ((str (with-output-to-string + (*error-output*) + (warn "Foo!")))) + (not (string= str ""))) + t) + +(deftest warn.5 + (let ((warned nil)) + (handler-bind + ((simple-warning #'(lambda (c) + (assert (typep c 'simple-warning)) + (setf warned t) + (muffle-warning c)))) + (values + (multiple-value-list (warn "This is a warning")) + warned))) + (nil) t) + +(deftest warn.6 + (let ((warned nil)) + (handler-bind + ((simple-condition #'(lambda (c) + (assert (typep c 'simple-warning)) + (setf warned t) + (muffle-warning c)))) + (values + (multiple-value-list (warn "This is a warning")) + warned))) + (nil) t) + +(deftest warn.7 + (let ((warned nil)) + (handler-bind + ((condition #'(lambda (c) + (assert (typep c 'simple-warning)) + (setf warned t) + (muffle-warning c)))) + (values + (multiple-value-list (warn "This is a warning")) + warned))) + (nil) t) + +(deftest warn.8 + (let ((warned nil)) + (handler-bind + ((warning #'(lambda (c) + (assert (typep c 'simple-warning)) + (setf warned t) + (muffle-warning c)))) + (values + (multiple-value-list (warn 'simple-warning :format-control "Foo!")) + warned))) + (nil) t) + +(deftest warn.9 + (let ((warned nil)) + (handler-bind + ((warning #'(lambda (c) + (assert (typep c 'warning)) + (setf warned t) + (muffle-warning c)))) + (values + (multiple-value-list (warn 'warning)) + warned))) + (nil) t) + +(deftest warn.10 + (let ((warned nil)) + (handler-bind + ((warning #'(lambda (c) + (assert (typep c 'simple-warning)) + (setf warned t) + (muffle-warning c)))) + (values + (multiple-value-list (warn (make-condition 'simple-warning :format-control "Foo!"))) + warned))) + (nil) t) + +(deftest warn.11 + (let ((warned nil)) + (handler-bind + ((warning #'(lambda (c) + (assert (typep c 'warning)) + (setf warned t) + (muffle-warning c)))) + (values + (multiple-value-list (warn (make-condition 'warning))) + warned))) + (nil) t) + +(deftest warn.12 + (classify-error (warn 'condition)) + type-error) + +(deftest warn.13 + (classify-error (warn 'simple-condition)) + type-error) + +(deftest warn.14 + (classify-error (warn (make-condition 'simple-warning) :format-control "Foo")) + type-error) + +(deftest warn.15 + (classify-error (warn)) + program-error) + +(deftest warn.16 + (classify-error (warn (make-condition 'condition))) + type-error) + +(deftest warn.17 + (classify-error (warn (make-condition 'simple-condition))) + type-error) + +(deftest warn.18 + (classify-error (warn (make-condition 'simple-error))) + type-error) diff --git a/ansi-tests/when.lsp b/ansi-tests/when.lsp new file mode 100644 index 0000000..67840fb --- /dev/null +++ b/ansi-tests/when.lsp @@ -0,0 +1,39 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Fri Oct 18 19:36:57 2002 +;;;; Contains: Tests of WHEN + +(in-package :cl-test) + +(deftest when.1 + (when t) + nil) + +(deftest when.2 + (when nil 'a) + nil) + +(deftest when.3 (when t (values))) + +(deftest when.4 + (when t (values 'a 'b 'c 'd)) + a b c d) + +(deftest when.5 + (when nil (values)) + nil) + +(deftest when.6 + (when nil (values 'a 'b 'c 'd)) + nil) + +(deftest when.7 + (let ((x 0)) + (values + (when t (incf x) 'a) + x)) + a 1) + +;;; (deftest when.error.1 +;;; (classify-error (when)) +;;; program-error) diff --git a/bfdtest.c b/bfdtest.c new file mode 100644 index 0000000..ad3d657 --- /dev/null +++ b/bfdtest.c @@ -0,0 +1,418 @@ +#define IN_GCC +#include +#include +#include +#include + +static bfd *exe_bfd = NULL; +struct bfd_link_info link_info; + +int build_symbol_table_bfd ( char *oname ) { + + int u,v; + asymbol **q; + + if ( ! ( exe_bfd = bfd_openr ( oname, 0 ) ) ) { + fprintf ( stderr, "Cannot open self.\n" ); + exit ( 0 ); + } + + if ( ! bfd_check_format ( exe_bfd, bfd_object ) ) { + fprintf ( stderr, "I'm not an object.\n" ); + exit ( 0 ); + } + + if (!(link_info.hash = bfd_link_hash_table_create (exe_bfd))) { + fprintf ( stderr, "Cannot make hash table.\n" ); + exit ( 0 ); + } + + if (!bfd_link_add_symbols(exe_bfd,&link_info)) { + fprintf ( stderr, "Cannot add self symbols\n.\n" ); + exit ( 0 ); + } + + if ((u=bfd_get_symtab_upper_bound(exe_bfd))<0) { + fprintf ( stderr, "Cannot get self's symtab upper bound.\n" ); + exit ( 0 ); + } + + fprintf ( stderr, "Allocating symbol table (%d bytes)\n", u ); + q = (asymbol **) malloc ( u ); + + if ( ( v = bfd_canonicalize_symtab ( exe_bfd, q ) ) < 0 ) { + fprintf ( stderr, "Cannot canonicalize self's symtab.\n" ); + exit ( 0 ); + } + +#ifdef _WIN32 + for ( u=0; u < v; u++ ) { + char *c; + if ( ( c = (char *) strstr ( q[u]->name, "_" ) ) ) { + struct bfd_link_hash_entry *h; + if ( ! ( h = bfd_link_hash_lookup ( link_info.hash, q[u]->name, true, true, true ) ) ) + fprintf ( stderr, "Cannot make new hash entry.\n" ); + h->type=bfd_link_hash_defined; + if ( !q[u]->section ) + fprintf ( stderr, "Symbol is missing section.\n" ); + h->u.def.value = q[u]->value + q[u]->section->vma; + h->u.def.section = q[u]->section; + fprintf ( stderr, "Processed %s\n", q[u]->name ); + } + } +#else + for (u=0;uname,"@@GLIBC\n" ))) { + struct bfd_link_hash_entry *h; + *c=0; + if (!(h=bfd_link_hash_lookup(link_info.hash,q[u]->name,true,true,true))) + fprintf ( stderr, "Cannot make new hash entry.\n" ); + h->type=bfd_link_hash_defined; + if (!q[u]->section) + fprintf ( stderr, "Symbol is missing section.\n" ); + h->u.def.value=q[u]->value+q[u]->section->vma; + h->u.def.section=q[u]->section; + *c='@'; + } + } +#endif + bfd_close ( exe_bfd ); + free(q); + return 0; + +} + + +/* align for power of two n */ +static void * + round_up(void *address, unsigned long n) +{ + fprintf ( stderr, "round_up: address = %d, n = %d, returning %d\n", + address, n, (void *)(((unsigned long)address + n -1) & ~(n-1)) ); + fflush ( stderr ); + return (void *)(((unsigned long)address + n -1) & ~(n-1)) ; +} +#define ROUND_UP(a,b) round_up(a,b) + + +static boolean + madd_archive_element (struct bfd_link_info * link_info, + bfd *abfd, + const char *name) { + fprintf ( stderr, "madd_archive_element\n"); + return false; + + } + +static boolean + mmultiple_definition (struct bfd_link_info * link_info, + const char *name, + bfd *obfd, + asection *osec, + bfd_vma oval, + bfd *nbfd, + asection *nsec, + bfd_vma nval) { + + fprintf ( stderr, "mmultiple_definition\n"); + return false; + + } + +static boolean + mmultiple_common (struct bfd_link_info * link_info, + const char *name, + bfd *obfd, + enum bfd_link_hash_type otype, + bfd_vma osize, + bfd *nbfd, + enum bfd_link_hash_type ntype, + bfd_vma nsize) { + + fprintf ( stderr, " mmultiple_common\n"); + return false; + + } + +static boolean + madd_to_set (struct bfd_link_info * link_info, + struct bfd_link_hash_entry *entry, + bfd_reloc_code_real_type reloc, + bfd *abfd, asection *sec, bfd_vma value) { + + fprintf ( stderr, "madd_to_set\n"); + return false; + + } + +static boolean + mconstructor (struct bfd_link_info * link_info,boolean constructor, + const char *name, bfd *abfd, asection *sec, + bfd_vma value) { + + fprintf ( stderr, "mconstructor\n"); + return false; + + } + +static boolean + mwarning (struct bfd_link_info * link_info, + const char *warning, const char *symbol, + bfd *abfd, asection *section, + bfd_vma address) { + + fprintf ( stderr, "mwarning\n"); + return false; + + } + +static boolean + mundefined_symbol (struct bfd_link_info * link_info, + const char *name, bfd *abfd, + asection *section, + bfd_vma address, + boolean fatal) { + + printf("mundefined_symbol %s is undefined\n",name); + return false; + } + +static boolean + mreloc_overflow (struct bfd_link_info * link_info, + const char *name, + const char *reloc_name, bfd_vma addend, + bfd *abfd, asection *section, + bfd_vma address) { + + printf("mreloc_overflow reloc for %s is overflowing\n",name); + return false; + + } + +static boolean + mreloc_dangerous (struct bfd_link_info * link_info, + const char *message, + bfd *abfd, asection *section, + bfd_vma address) { + + printf("mreloc_dangerous reloc is dangerous %s\n",message); + return false; + + } + +static boolean + munattached_reloc (struct bfd_link_info * link_info, + const char *name, + bfd *abfd, asection *section, + bfd_vma address) { + + fprintf ( stderr, " munattached_reloc\n"); + return false; + + } + +static boolean + mnotice (struct bfd_link_info * link_info, const char *name, + bfd *abfd, asection *section, bfd_vma address) { + + fprintf ( stderr, "mnotice\n"); + return false; + + } + + +int main ( int argc, char ** argv ) +{ + int init_address=-1; + int max_align = 0; + unsigned long curr_size = 0; + bfd *obj_bfd = NULL; + bfd_error_type myerr; + unsigned u = 0, v = 0; + asymbol **q = NULL; + asection *s = NULL; + static struct bfd_link_callbacks link_callbacks; + static struct bfd_link_order link_order; + + void *current = NULL; + void *cfd_self = NULL; + void *cfd_start = NULL; + int cfd_size = 0; + void *the_start = NULL; + void *start_address = NULL; + void *m = NULL; + + fprintf ( stderr, "In BFD fast load test.\n" ); + if ( argc < 3 ) { + fprintf ( stderr, "Need an executable and an object file as arguments.\n" ); + } else { + + memset ( &link_info, 0, sizeof (link_info) ); + memset ( &link_order, 0, sizeof (link_order) ); + memset ( &link_callbacks, 0, sizeof (link_callbacks) ); + + + bfd_init(); + + fprintf ( stderr, "BUILDING EXECUTABLE SYMBOL TABLE (ARGV[1]) \n\n" ); + build_symbol_table_bfd ( argv[1] ); + + link_callbacks.add_archive_element=madd_archive_element; + link_callbacks.multiple_definition=mmultiple_definition; + link_callbacks.multiple_common=mmultiple_common; + link_callbacks.add_to_set=madd_to_set; + link_callbacks.constructor=mconstructor; + link_callbacks.warning=mwarning; + link_callbacks.undefined_symbol=mundefined_symbol; + link_callbacks.reloc_overflow=mreloc_overflow; + link_callbacks.reloc_dangerous=mreloc_dangerous; + link_callbacks.unattached_reloc=munattached_reloc; + link_callbacks.notice = mnotice; + link_info.callbacks = &link_callbacks; + link_order.type = bfd_indirect_link_order; + + if ( ! ( obj_bfd = bfd_openr ( argv[2], 0 ) ) ) { + fprintf ( stderr, "Cannot open bfd.\n" ); + } + + if ( ( myerr = bfd_get_error () ) && myerr != 3 ) { + fprintf ( stderr, "Unknown bfd error code on openr %s %d\n.", argv[2], myerr ); + } + fflush ( stderr ); + if ( ! bfd_check_format ( obj_bfd, bfd_object ) ) { + fprintf ( stderr, "Unknown bfd format %s.\n", argv[2] ); + } + + if ( ( myerr = bfd_get_error () ) && myerr != 3 ) { + fprintf ( stderr, "Unknown bfd error code on check_format %s\n", argv[2] ); + } + + bfd_set_error(0); + + current = NULL; + + fprintf ( stderr, "CALCULATING CURRENT, MAX_ALIGN and ALLOCATING \n\n" ); + + for ( s= obj_bfd->sections;s;s=s->next) { + + s->owner = obj_bfd; + s->output_section = ( s->flags & SEC_ALLOC) ? s : obj_bfd->sections; + s->output_offset=0; + + if (!(s->flags & SEC_ALLOC)) + continue; + + if (max_alignalignment_power) + max_align=s->alignment_power; + + current=round_up(current,1<alignment_power); + + current+=s->_raw_size; + + fprintf ( stderr, "Section %s: owner = %x, output_offset = %x, output_section = %x (%s)\n", + s->name, s->owner, s->output_offset, s->output_section, s->output_section->name ); + } + + fprintf ( stderr, "1\n"); + curr_size=(unsigned long)current; + max_align=1< sizeof(char *) ? max_align :0); + + cfd_start = (void *) malloc ( cfd_size ); + the_start = start_address = cfd_start; + + fprintf ( stderr, "ALLOCATED %d bytes \n\n", cfd_size ); + fprintf ( stderr, + "max_align = %d, current = %d, cfd_self = %x, " + "cfd_size = %x, cfd_start = %x\n", + max_align, current, cfd_self, cfd_size, cfd_start ); + + start_address = ROUND_UP ( start_address, max_align ); + cfd_size = cfd_size - ( start_address - the_start ); + cfd_start = (void *) start_address; + + fprintf ( stderr, + "max_align = %d, current = %d, cfd_self = %x, " + "cfd_size = %x, cfd_start = %x\n", + max_align, current, cfd_self, cfd_size, cfd_start ); + + memset ( cfd_start, 0, cfd_size ); + + for ( m = start_address, s = obj_bfd->sections; s; s=s->next ) { + + if (!(s->flags & SEC_ALLOC)) + continue; + + m=round_up(m,1<alignment_power); + s->output_section->vma=(unsigned long)m; + m+=s->_raw_size; + fprintf ( stderr, "Section address %x\n", s ); + fprintf ( stderr, "m loop Section %s: owner = %x, output_offset = %x, " + "output_section = %x (%s), vma = %x, m = %x\n", + s->name, s->owner, s->output_offset, s->output_section, s->output_section->name, + s->output_section->vma, m ); + + } + + fprintf ( stderr, "\n\nDOING SOMETHING WITH THE HASHED SYMBOLS\n\n" ); + if ((u=bfd_get_symtab_upper_bound(obj_bfd))<0) + fprintf ( stderr, "Cannot get symtab uppoer bound.\n" ); + q = (asymbol **) alloca ( u ); + if ( ( v = bfd_canonicalize_symtab ( obj_bfd, q ) ) < 0 ) + fprintf ( stderr, "cannot canonicalize symtab.\n" ); + fprintf ( stderr, "u = %d, v = %d\n", u, v ); + for (u=0;uname = %s\n", u, q[u]->name ); + + if (!strncmp("init_",q[u]->name,5)) { + init_address=q[u]->value; + continue; + } + + if (!(h=bfd_link_hash_lookup(link_info.hash,q[u]->name, false, false, true))) + continue; + + if (h->type!=bfd_link_hash_defined) + fprintf ( stderr, "Undefined symbol.\n" ); + + if (h->u.def.section) { + q[u]->value=h->u.def.value+h->u.def.section->vma; + q[u]->flags|=BSF_WEAK; + } else + fprintf ( stderr, "Symbol without section.\n" ); + + } + + fprintf ( stderr, "\n\nDOING RELOCATIONS\n\n", cfd_size ); + fflush ( stderr ); + for ( s = obj_bfd->sections; s; s = s->next ) { + + fprintf ( stderr, "s->name %s, s->flags = %x\n", s->name, s->flags ); + if ( ! ( s->flags & SEC_LOAD ) ) + continue; + + link_order.u.indirect.section=s; + + fprintf ( stderr, "About to get reloc section contents\n" ); + + fprintf ( stderr, "obj_bfd = %x, section %s, s->output_section = %x, q = %x\n", + obj_bfd, s->name, s->output_section, q); + + fflush ( stderr ); + if (!bfd_get_relocated_section_contents(obj_bfd, &link_info,&link_order, + (void *)(unsigned long)s->output_section->vma,0,q)) + fprintf ( stderr, "Cannot get relocated section contents\n"); + + } + + bfd_close ( obj_bfd ); + printf("start address -T %x \n", cfd_start); + } +} diff --git a/bin/append.c b/bin/append.c new file mode 100755 index 0000000..4712e10 --- /dev/null +++ b/bin/append.c @@ -0,0 +1,35 @@ +#include +/* usage: append a b c + equivalent to cat a b >> c + if only cat were binary... but by some wonderful dos like deicision, + it is not under cygnus.. + */ +int +main(int argc,char *argv[]) +{ int i; + FILE *out ; + if (argc < 2) return 0; + out = fopen(argv[argc-1],"a+b"); + if (out == 0) + { perror("cant open"); return 1; } + for (i=1; i < argc-1 ; i++) + { + FILE *fp = fopen(argv[i],"rb"); + int ch; + if (fp == 0) + { perror("cant open"); return 1; } + while (1) { + ch =getc(fp); + if (ch == EOF && feof(fp)) + { fclose(fp); + break; + } else + putc(ch,out); + + } + } + fclose(out); + return 0; +} + + diff --git a/bin/dpp.c b/bin/dpp.c new file mode 100755 index 0000000..242709b --- /dev/null +++ b/bin/dpp.c @@ -0,0 +1,680 @@ +/* + dpp.c + + defun preprocessor +*/ + +/* + Usage: + dpp file + + The file named file.d is preprocessed and the output will be + written to the file whose name is file.c. + + + ;changes: remove \n from beginning of main output so debuggers + can find the right foo.d source file name.--wfs + ;add \" to the line output for ansi C --wfs + + The function definition: + + @(defun name ({var}* + [&optional {var | (var [initform [svar]])}*] + [&rest] + [&key {var | + ({var | (keyword var)} [initform [svar]])}* + [&allow_other_keys]] + [&aux {var | (var [initform])}*]) + + C-declaration + + @ + + C-body + + @) + + &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 macro name + defined to be an expression of the form + vs_base[...]. + + Each supplied-p parameter becomes a boolean C variable. + + Initforms are C expressions. + It an expression contain non-alphanumeric characters, + it should be surrounded by backquotes (`). + + + Function return: + + @(return {form}*) + + It becomes a C block. + +*/ + +#include +#include +#include + +#include "gclincl.h" +#include "config.h" + +#ifdef UNIX +#include +#define isalphanum(c) isalnum(c) +#endif + +#define POOLSIZE 2048 +#define MAXREQ 16 +#define MAXOPT 16 +#define MAXKEY 16 +#define MAXAUX 16 +#define MAXRES 16 + +#define TRUE 1 +#define FALSE 0 + +typedef int bool; + +FILE *in, *out; + +char filename[BUFSIZ]; +int line; +int tab; +int tab_save; + +char pool[POOLSIZE]; +char *poolp; + +char *function; +int fstatic; + +char *required[MAXREQ]; +int nreq; + +struct optional { + char *o_var; + char *o_init; + char *o_svar; +} optional[MAXOPT]; +int nopt; + +bool rest_flag; + +bool key_flag; +struct keyword { + 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; +} aux[MAXAUX]; +int naux; + +char *result[MAXRES]; +int nres; + +void +error(s) +char *s; +{ + printf("Error in line %d: %s.\n", line, s); + exit(0); +} + +int +readc() +{ + int c; + + c = getc(in); + if (feof(in)) { + if (function != NULL) + error("unexpected end of file"); + exit(0); + } + if (c == '\n') { + line++; + tab = 0; + } else if (c == '\t') + tab++; + return(c); +} + +int +nextc() +{ + int c; + + while (isspace(c = readc())) + ; + return(c); +} + +void +unreadc(c) +int c; +{ + if (c == '\n') + --line; + else if (c == '\t') + --tab; + ungetc(c, in); +} + +void +put_tabs(n) +int n; +{ + int i; + + for (i = 0; i < n; i++) + putc('\t', out); +} + +void +pushc(c) +int c; +{ + if (poolp >= &pool[POOLSIZE]) + error("buffer bool overflow"); + *poolp++ = c; +} + +char * +read_token() +{ + int c; + char *p; + + p = poolp; + if ((c = nextc()) == '`') { + while ((c = readc()) != '`') + pushc(c); + pushc('\0'); + return(p); + } + do + pushc(c); + while (isalphanum(c = readc()) || c == '_'); + pushc('\0'); + unreadc(c); + return(p); +} + +void +reset() +{ + int i; + + poolp = pool; + function = NULL; + 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; + 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() +{ + function = read_token(); +} + +void +get_lambda_list() +{ + int c; + char *p; + + if ((c = nextc()) != '(') + error("( expected"); + for (;;) { + if ((c = nextc()) == ')') + return; + if (c == '&') { + p = read_token(); + goto OPTIONAL; + } + unreadc(c); + p = read_token(); + if (nreq >= MAXREQ) + error("too many required variables"); + required[nreq++] = p; + } + +OPTIONAL: + 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 KEYWORD; + rest_flag = TRUE; + if ((c = nextc()) == ')') + return; + if (c != '&') + error("& expected"); + p = read_token(); + goto KEYWORD; + +KEYWORD: + if (strcmp(p, "key") != 0 && strcmp(p, "k") != 0) + goto AUX_L; + 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_L; + } + 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_L: + 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() +{ + int c; + + nres = 0; + for (;;) { + if ((c = nextc()) == ')') + return; + unreadc(c); + result[nres++] = read_token(); + } +} + +void +put_fhead() +{ +#ifdef STATIC_FUNCTION_POINTERS + fprintf(out, "static void L%s_static ();\n",function); + if (!fstatic) + fprintf(out,"void\nL%s()\n{ L%s_static();}\n\n",function,function); + fprintf(out,"static void\nL%s_static()\n{",function); +#else + fprintf(out, "%svoid\nL%s()\n{", fstatic ? "static " : "",function); +#endif +} + +void +put_declaration() +{ + int i; + + fprintf(out, "\tint narg;\n"); + fprintf(out, "\tregister object *DPPbase=vs_base;\n"); + + for (i = 0; i < nopt; i++) + if (optional[i].o_svar != NULL) + fprintf(out, "\tbool %s;\n", + optional[i].o_svar); + for (i = 0; i < nreq; i++) + fprintf(out, "#define\t%s\tDPPbase[%d]\n", + required[i], i); + for (i = 0; i < nopt; i++) + fprintf(out, "#define\t%s\tDPPbase[%d+%d]\n", + optional[i].o_var, nreq, i); + for (i = 0; i < nkey; i++) + fprintf(out, "#define\t%s\tDPPbase[%d+%d+%d]\n", + keyword[i].k_var, nreq, nopt, i); + for (i = 0; i < nkey; i++) + if (keyword[i].k_svar != NULL) + fprintf(out, "\tbool %s;\n", keyword[i].k_svar); + for (i = 0; i < naux; i++) + fprintf(out, "#define\t%s\tDPPbase[%d+%d+2*%d+%d]\n", + aux[i].a_var, nreq, nopt, nkey, i); + fprintf(out, "\n"); + fprintf(out, "\tnarg = vs_top - vs_base;\n"); + if (nopt == 0 && !rest_flag && !key_flag) + fprintf(out, "\tcheck_arg(%d);\n", nreq); + else { + fprintf(out, "\tif (narg < %d)\n", nreq); + fprintf(out, "\t\ttoo_few_arguments();\n"); + } + for (i = 0; i < nopt; i++) + if (optional[i].o_svar != NULL) { + fprintf(out, "\tif (narg > %d + %d)\n", + nreq, i); + fprintf(out, "\t\t%s = TRUE;\n", + optional[i].o_svar); + fprintf(out, "\telse {\n"); + fprintf(out, "\t\t%s = FALSE;\n", + optional[i].o_svar); + fprintf(out, "\t\tvs_push(%s);\n", + optional[i].o_init); + fprintf(out, "\t\tnarg++;\n"); + fprintf(out, "\t}\n"); + } else if (optional[i].o_init != NULL) { + fprintf(out, "\tif (narg <= %d + %d) {\n", + nreq, i); + fprintf(out, "\t\tvs_push(%s);\n", + optional[i].o_init); + fprintf(out, "\t\tnarg++;\n"); + fprintf(out, "\t}\n"); + } else { + fprintf(out, "\tif (narg <= %d + %d) {\n", + nreq, i); + fprintf(out, "\t\tvs_push(Cnil);\n"); + fprintf(out, "\t\tnarg++;\n"); + fprintf(out, "\t}\n"); + } + if (nopt > 0 && !key_flag && !rest_flag) { + fprintf(out, "\tif (narg > %d + %d)\n", nreq, nopt); + fprintf(out, "\t\ttoo_many_arguments();\n"); + } + if (key_flag) { + fprintf(out, "\tparse_key(vs_base+%d+%d,FALSE, %s, %d,\n", + nreq, nopt, + allow_other_keys_flag ? "TRUE" : "FALSE", nkey); + if (nkey > 0) { + i = 0; + for (;;) { + fprintf(out, "\t\tsK%s", keyword[i].k_key); + if (++i == nkey) { + fprintf(out, ");\n"); + break; + } else + fprintf(out, ",\n"); + } + } else + fprintf(out, "\t\tCnil);"); + fprintf(out, "\tvs_top = vs_base + %d+%d+2*%d;\n", + nreq, nopt, nkey); + for (i = 0; i < nkey; i++) { + if (keyword[i].k_init == NULL) + continue; + fprintf(out, "\tif (vs_base[%d+%d+%d+%d]==Cnil)\n", + nreq, nopt, nkey, i); + fprintf(out, "\t\t%s = %s;\n", + keyword[i].k_var, keyword[i].k_init); + } + for (i = 0; i < nkey; i++) + if (keyword[i].k_svar != NULL) + fprintf(out, + "\t%s = vs_base[%d+%d+%d+%d] != Cnil;\n", + keyword[i].k_svar, nreq, nopt, nkey, i); + } + for (i = 0; i < naux; i++) + if (aux[i].a_init != NULL) + fprintf(out, "\tvs_push(%s);\n", aux[i].a_init); + else + fprintf(out, "\tvs_push(Cnil);\n"); +} + +void +put_ftail() +{ + int i; + + for (i = 0; i < nreq; i++) + fprintf(out, "#undef %s\n", required[i]); + for (i = 0; i < nopt; i++) + fprintf(out, "#undef %s\n", optional[i].o_var); + for (i = 0; i < nkey; i++) + fprintf(out, "#undef %s\n", keyword[i].k_var); + for (i = 0; i < naux; i++) + fprintf(out, "#undef %s\n", aux[i].a_var); + fprintf(out, "}"); +} + +void +put_return() +{ + int i, t; + + t = tab_save + 1; + if (nres == 0) { + fprintf(out, "{\n"); + put_tabs(t); + fprintf(out, "vs_top = vs_base;\n"); + put_tabs(t); + fprintf(out, "vs_base[0] = Cnil;\n"); + put_tabs(t); + fprintf(out, "return;\n"); + put_tabs(tab_save); + fprintf(out, "}"); + } else if (nres == 1) { + fprintf(out, "{\n"); + put_tabs(t); + fprintf(out, "vs_base[0] = %s;\n", result[0]); + put_tabs(t); + fprintf(out, "vs_top = vs_base + 1;\n"); + put_tabs(t); + fprintf(out, "return;\n"); + put_tabs(tab_save); + fprintf(out, "}"); + } else { + fprintf(out, "{\n"); + for (i = 0; i < nres; i++) { + put_tabs(t); + fprintf(out, "object R%d;\n", i); + } + for (i = 0; i < nres; i++) { + put_tabs(t); + fprintf(out, "R%d = %s;\n", i, result[i]); + } + for (i = 0; i < nres; i++) { + put_tabs(t); + fprintf(out, "vs_base[%d] = R%d;\n", i, i); + } + put_tabs(t); + fprintf(out, "vs_top = vs_base + %d;\n", nres); + put_tabs(t); + fprintf(out, "return;\n"); + put_tabs(tab_save); + fprintf(out, "}"); + } +} + +void +main_loop() +{ + int c; + char *p; + + line = 1; + fprintf(out, "# line %d \"%s\"\n", line, filename); +LOOP: + reset(); + fprintf(out, "\n# line %d \"%s\"\n", line, filename); + while ((c = readc()) != '@') + putc(c, out); + if (readc() != '(') + error("@( expected"); + p = read_token(); + fstatic=0; + if (strcmp(p, "static") == 0) { + fstatic=1; + p = read_token(); + } + if (strcmp(p, "defun") == 0) { + get_function(); + get_lambda_list(); + put_fhead(); + fprintf(out, "\n# line %d \"%s\"\n", line, filename); + while ((c = readc()) != '@') + putc(c, out); + put_declaration(); + + BODY: + fprintf(out, "\n# line %d \"%s\"\n", line, filename); + while ((c = readc()) != '@') + putc(c, out); + if ((c = readc()) == ')') { + put_ftail(); + goto LOOP; + } else if (c != '(') + error("@( expected"); + p = read_token(); + if (strcmp(p, "return") == 0) { + tab_save = tab; + get_return(); + put_return(); + goto BODY; + } else + error("illegal symbol"); + } else + error("illegal symbol"); +} + +int +main(argc, argv) +int argc; +char **argv; +{ + char *p, *q; + + if (argc != 2) + error("arg count"); + for (p = argv[1], q = filename; *p != '\0'; p++, q++) + if (q >= &filename[BUFSIZ-3]) + error("too long file name"); + else + *q = *p; + q[0] = '.'; + q[1] = 'd'; + q[2] = '\0'; + in = fopen(filename, "r"); + if (in == NULL) + error("can't open input file"); + q[1] = 'c'; + out = fopen(filename, "w"); + if (out == NULL) + error("can't open output file"); + q[1] = 'd'; + printf("dpp: %s -> ", filename); + q[1] = 'c'; + printf("%s\n", filename); + q[1] = 'd'; + main_loop(); + return 0; +} diff --git a/bin/file-sub.c b/bin/file-sub.c new file mode 100644 index 0000000..e6dbb90 --- /dev/null +++ b/bin/file-sub.c @@ -0,0 +1,71 @@ +/* + +# Substitute the region between BEGIN and END in FILE1 into FILE2 + + */ + +#include +#include +#include + +void scanCopyToLine(FILE *fp, char *line,FILE *outstream); + +int +main(int argc,char *argv[]) +{ + if (argc < 5) + { + ERROR: + fprintf(stderr,"Usage: file-sub subFile FileToSubInto BEGIN END [outfile -]"); + exit(1); + } + { + FILE *file1; + FILE *file2; + FILE *outstream = stdout; + char *begin=argv[3]; + char *end=argv[4]; + + file2= fopen(argv[2],"rb"); + file1= fopen(argv[1],"rb"); + if (argc>=6 && strcmp(argv[5],"-")!=0) { + outstream= fopen(argv[5],"wb"); + } + + if (file1==0 || file2==0) goto ERROR; + { + scanCopyToLine(file2,begin,outstream); + scanCopyToLine(file1,begin,0); + scanCopyToLine(file1,end,outstream); + scanCopyToLine(file2,end,0); + scanCopyToLine(file2,0,outstream); + } + if (outstream != stdout) fclose(outstream); + } + + return 0; +} + + + + +/* copy from fp to outstream all lines up to and including + one beginning with LINE +*/ +void +scanCopyToLine(FILE *fp, char *line,FILE *outstream) +{ + int length=0; + int finish=0; + char buf[5000]; + if (line) length = strlen(line); + while (!finish && !feof(fp)) { + char *s = fgets(buf,sizeof(buf),fp); + if (line && s && strncmp(line,s,length)==0) { + finish=1; + } + if (s && outstream) + fputs(s,outstream); + } + +} diff --git a/bin/info b/bin/info new file mode 100755 index 0000000..0ce4b37 --- /dev/null +++ b/bin/info @@ -0,0 +1,3 @@ +#!/bin/sh +gcl -batch -eval '(si::error-set (quote (progn (tk::tkconnect :args "-geometry 20x20-2+2")(tk::wm :iconify ".")(si::info '\"$1\"')(tk::bind (quote .info) "" (quote (bye)))(read))))' + diff --git a/bin/info1 b/bin/info1 new file mode 100755 index 0000000..a7f6183 --- /dev/null +++ b/bin/info1 @@ -0,0 +1,13 @@ +#!/usr/local/bin/gcl.exe -f +(si::error-set + '(progn + (tk::tkconnect :args + "-geometry 20x20-2+2") + (tk::wm :iconify ".") + (si::info (nth 1 SYSTEM::*COMMAND-ARGS*)) + (tk::bind (quote .info) + "" + (quote (bye))) + + (read))) + diff --git a/bin/makefile b/bin/makefile new file mode 100644 index 0000000..f856465 --- /dev/null +++ b/bin/makefile @@ -0,0 +1,19 @@ +DEFS = -I../h +CC = cc +APPEND = ../bin/append + +-include ../makedefs + +all: dpp${EXE} ${APPEND}${EXE} file-sub${EXE} + +dpp${EXE}: dpp.c + ${CC} ${DEFS} -o dpp${EXE} dpp.c + +file-sub${EXE}: file-sub.c + ${CC} ${DEFS} -o file-sub${EXE} file-sub.c + +${APPEND}${EXE}: append.c + ${CC} ${DEFS} -o append${EXE} append.c + +clean: + rm -f dpp${EXE} append${EXE} file-sub${EXE} core a.out *.o gcl gclm.bat diff --git a/bin/tkinfo b/bin/tkinfo new file mode 100755 index 0000000..97a5446 --- /dev/null +++ b/bin/tkinfo @@ -0,0 +1,19 @@ +#!/home/wfs/bin/gcl -f +(in-package "SI") +(setq *load-verbose* nil) +(tkconnect) +(tk::wm :iconify ".") +(offer-choices + (sloop::sloop for v in (cdr si::*command-args*) + appending (info-aux v *default-info-files*)) + *default-info-files*) +(tk::bind '.info "" '(bye)) +(read) + + + + + + + + diff --git a/clcs/gcl_clcs_condition_definitions.lisp b/clcs/gcl_clcs_condition_definitions.lisp new file mode 100755 index 0000000..8367016 --- /dev/null +++ b/clcs/gcl_clcs_condition_definitions.lisp @@ -0,0 +1,145 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- + +(IN-PACKAGE :CONDITIONS) + +(define-condition warning (condition) nil) +(define-condition style-warning (warning) nil) + +(define-condition serious-condition (condition) nil) +(define-condition error (serious-condition) nil) + +(define-condition simple-condition (condition) + ((format-control :type string + :initarg :format-control + :reader simple-condition-format-control + :initform "") + (format-arguments :initarg :format-arguments + :reader simple-condition-format-arguments + :initform nil)) + (:report (lambda (c s) + (call-next-method) + (apply 'format s + (simple-condition-format-control c) + (simple-condition-format-arguments c))))) + +(define-condition simple-warning (simple-condition warning) nil) +(define-condition simple-error (simple-condition error) nil) + +(define-condition storage-condition (serious-condition) nil) +(define-condition stack-overflow (storage-condition) nil) +(define-condition storage-exhausted (storage-condition) nil) + +(define-condition type-error (error) + ((datum :initarg :datum + :reader type-error-datum) + (expected-type :initarg :expected-type + :reader type-error-expected-type)) + (:report ("~s is not of type ~s: " datum expected-type))) +(define-condition simple-type-error (simple-error type-error) nil) + +(define-condition program-error (error) nil) +(define-condition control-error (error) nil) +(define-condition parse-error (error) nil) + +(define-condition print-not-readable (error) + ((object :initarg :object + :reader print-not-readable-object)) + (:report ("Object ~s is unreadable: " object))) + +(define-condition stream-error (error) + ((stream :initarg :stream + :reader stream-error-stream)) + (:report ("Stream error on stream ~s: " stream))) + +(define-condition reader-error (parse-error stream-error) nil) + +(define-condition end-of-file (stream-error) + nil + (:report ("Unexpected end of file: "))) + +(define-condition file-error (error) + ((pathname :initarg :pathname + :reader file-error-pathname)) + (:report ("File error on ~s: " pathname))) + +(define-condition pathname-error (file-error) nil) + +(define-condition package-error (error) + ((package :initarg :package + :reader package-error-package)) + (:report ("Package error on ~s: " package))) + +(define-condition cell-error (error) + ((name :initarg :name + :reader cell-error-name)) + (:report ("Cell error on ~s: " name))) + +(define-condition unbound-variable (cell-error) + nil + (:report ("Unbound variable: "))) + +(define-condition unbound-slot (cell-error) + ((instance :initarg :instance + :reader unbound-slot-instance)) + (:report ("Slot is unbound in ~s: " instance))) + +(define-condition undefined-function (cell-error) + nil + (:report ("Undefined function: "))) + +(define-condition arithmetic-error (ERROR) + ((operation :initarg :operation + :reader arithmetic-error-operation) + (operands :initarg :operands + :reader arithmetic-error-operands)) + (:report ("~%Arithmetic error when performing ~s on ~s: " operation operands))) + +(define-condition division-by-zero (arithmetic-error) nil) +(define-condition floating-point-overflow (arithmetic-error) nil) +(define-condition floating-point-invalid-operation (arithmetic-error) nil) +(define-condition floating-point-inexact (arithmetic-error) nil) +(define-condition floating-point-underflow (arithmetic-error) nil) + +(define-condition case-failure (type-error) + ((name :initarg :name + :reader case-failure-name) + (possibilities :initarg :possibilities + :reader case-failure-possibilities)) + (: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))))) + +(define-condition abort-failure (control-error) nil (:report "abort failed.")) + +(define-condition internal-condition (condition) + ((function-name :initarg :function-name + :reader internal-condition-function-name + :initform nil)) + (:report (lambda (condition stream) + (when (internal-condition-function-name condition) + (format stream "Condition in ~S [or a callee]: " + (internal-condition-function-name condition))) + (call-next-method)))) + +(define-condition internal-simple-condition (internal-condition simple-condition) nil) + +(define-condition internal-simple-error (internal-condition simple-error) nil) +(define-condition internal-simple-type-error (internal-condition simple-type-error) nil) +(define-condition internal-simple-warning (internal-condition simple-warning) nil) + +#.`(progn + ,@(mapcar (lambda (x) + `(define-condition + ,(intern (concatenate 'string "INTERNAL-SIMPLE-" (string x))) + (internal-condition simple-condition ,x) nil)) + `(stack-overflow storage-exhausted print-not-readable end-of-file style-warning + unbound-variable unbound-slot undefined-function division-by-zero + case-failure abort-failure + ,@(mapcar (lambda (x) (intern (concatenate 'string "FLOATING-POINT-" (string x)))) + '(overflow underflow invalid-operation inexact)) + ,@(mapcar (lambda (x) (intern (concatenate 'string (string x) "-ERROR"))) + '(program control parse stream reader file + package cell arithmetic pathname))))) diff --git a/clcs/gcl_clcs_conditions.lisp b/clcs/gcl_clcs_conditions.lisp new file mode 100755 index 0000000..c473060 --- /dev/null +++ b/clcs/gcl_clcs_conditions.lisp @@ -0,0 +1,85 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- + +;(in-package "CONDITIONS" :USE '(:cl #+(and clos (not pcl)) "CLOS" #+pcl "PCL")) + +(in-package :conditions) + +(defun slot-sym (base slot) + (values (intern (concatenate 'string (string base) "-" (string slot))))) + +(defun coerce-to-fn (x y) + (cond ((stringp x) `(lambda (c s) (declare (ignore c)) (write-string ,x s))) + ((symbolp x) x) + ((atom x) nil) + ((eq (car x) 'lambda) x) + ((stringp (car x)) + `(lambda (c s) + (declare (ignorable c)) + (call-next-method) + (format s ,(car x) ,@(mapcar (lambda (st) `(if (slot-boundp c ',st) (,(slot-sym y st) c) 'unbound)) (cdr x))))))) + +(defun default-report (x) + `(lambda (c s) (call-next-method) (format s "~s " ',x))) + +(defmacro define-condition (name parent-list slot-specs &rest options) + (unless (or parent-list (eq name 'condition)) + (setq parent-list (list 'condition))) + (let* ((report-function nil) + (default-initargs nil) + (documentation nil)) + (do ((o options (cdr o))) + ((null o)) + (let ((option (car o))) + (case (car option) + (:report (setq report-function (coerce-to-fn (cadr option) name))) + (:default-initargs (setq default-initargs option)) + (:documentation (setq documentation (cadr option))) + (otherwise (cerror "ignore this define-condition option." + "invalid define-condition option: ~s" option))))) + `(progn + (eval-when (compile) + (setq pcl::*defclass-times* '(compile load eval))) + ,(if default-initargs + `(defclass ,name ,parent-list ,slot-specs ,default-initargs) + `(defclass ,name ,parent-list ,slot-specs)) + (eval-when (compile load eval) +; (setf (get ',name 'documentation) ',documentation) + (setf (get ',name 'si::s-data) nil)) + ,@(when report-function + `((defmethod print-object ((x ,name) stream) + (if *print-escape* + (call-next-method) + (,report-function x stream))))) + ',name))) + +(eval-when (compile load eval) + (define-condition condition nil nil)) + +(defmethod pcl::make-load-form ((object condition) &optional env) + (declare (ignore env)) + (error "~@" 'pcl::make-load-form object)) + +(mapc 'pcl::proclaim-incompatible-superclasses '((condition pcl::metaobject))) + +(defun conditionp (object) (typep object 'condition)) + +(defun is-condition (x) (conditionp x)) +(defun is-warning (x) (typep x 'warning)) + +(defmethod print-object ((x condition) stream) + (let ((y (class-name (class-of x)))) + (if *print-escape* + (format stream "#<~s.~d>" y (unique-id x)) + (format stream "~a: " y))));(type-of x) + +(defun make-condition (type &rest slot-initializations) + (when (and (consp type) (eq (car type) 'or)) + (return-from make-condition (apply 'make-condition (cadr type) slot-initializations)));FIXME + (unless (condition-class-p type) + (error 'simple-type-error + :datum type + :expected-type '(satisfies condition-class-p) + :format-control "not a condition type: ~s" + :format-arguments (list type))) + (apply 'make-instance type slot-initializations)) + diff --git a/clcs/gcl_clcs_handler.lisp b/clcs/gcl_clcs_handler.lisp new file mode 100755 index 0000000..9a5513f --- /dev/null +++ b/clcs/gcl_clcs_handler.lisp @@ -0,0 +1,39 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- + +(in-package :conditions) + +(defmacro handler-bind (bindings &body forms) + (declare (optimize (safety 2))) + `(let ((*handler-clusters* (cons (list ,@(mapcar (lambda (x) `(cons ',(car x) ,(cadr x))) bindings)) + *handler-clusters*))) + ,@forms)) + + +(defmacro handler-case (form &rest cases) + (declare (optimize (safety 2))) + (let ((no-error-clause (assoc ':no-error cases))) + (if no-error-clause + (let ((normal-return (gensym)) (error-return (gensym))) + `(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 ((block (gensym))(var (gensym))(tcases (mapcar (lambda (x) (cons (gensym) x)) cases))) + `(block ,block + (let (,var) + (declare (ignorable ,var)) + (tagbody + (handler-bind ,(mapcar (lambda (x &aux (tag (pop x))(type (pop x))(ll (car x))) + (list type `(lambda (x) ,(if ll `(setq ,var x) `(declare (ignore x))) (go ,tag)))) + tcases) + (return-from ,block ,form)) + ,@(mapcan (lambda (x &aux (tag (pop x))(type (pop x))(ll (pop x))(body x)) + (list tag `(return-from ,block (let ,(when ll `((,(car ll) ,var))) ,@body)))) + tcases)))))))) + +(defmacro ignore-errors (&rest forms) + `(handler-case (progn ,@forms) + (error (condition) (values nil condition)))) + diff --git a/clcs/gcl_clcs_precom.lisp b/clcs/gcl_clcs_precom.lisp new file mode 100755 index 0000000..761607c --- /dev/null +++ b/clcs/gcl_clcs_precom.lisp @@ -0,0 +1,6 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- + +(in-package "CONDITIONS" :USE '("LISP" #+(and clos (not pcl)) "CLOS" #+pcl "PCL")) + +#+pcl +(pcl::precompile-random-code-segments clcs) diff --git a/clcs/gcl_cmpinit.lsp b/clcs/gcl_cmpinit.lsp new file mode 100644 index 0000000..a242bb8 --- /dev/null +++ b/clcs/gcl_cmpinit.lsp @@ -0,0 +1,7 @@ +;(proclaim '(optimize (safety 2) (space 3))) + +(setq compiler::*eval-when-defaults* '(compile eval load)) +(setq compiler::*compile-ordinaries* t) +(if (probe-file "sys-proclaim.lisp")(load "sys-proclaim.lisp")) + +;;;;; diff --git a/clcs/loading.lisp b/clcs/loading.lisp new file mode 100755 index 0000000..d06e484 --- /dev/null +++ b/clcs/loading.lisp @@ -0,0 +1,26 @@ +(defun jamie-load-clcs (&optional (mode :compiled)) + (let ((files (list + ;"package" + "clcs_precom" + "clcs_macros" + "clcs_restart" + "clcs_handler" + "clcs_debugger" + "clcs_conditions" + "clcs_condition_definitions" + "clcs_kcl_cond" + "clcs_top_patches" + "clcs_install"))) +; (load "package.lisp") + (when (eql :compile mode) +; (load "package.lisp") + (load "clcs_precom.lisp")) + (mapc #'(lambda (file) + (ecase mode + (:interpreted (load (format nil "~A.lisp" file))) + (:compiled (load (format nil "~A.o" file))) + (:compile (compile-file (format nil "~A.lisp" file) :c-file t :h-file t :data-file t :system-p t)))) + files))) + + + diff --git a/clcs/makefile b/clcs/makefile new file mode 100644 index 0000000..9411ca3 --- /dev/null +++ b/clcs/makefile @@ -0,0 +1,37 @@ +-include ../makedefs + +COMPILE_FILE=./saved_clcs_gcl$(EXE) ./ -system-p -c-file -data-file \ + -o-file nil -h-file -compile + +FILES:=$(shell ls -1 gcl_clcs_*.lisp | sed 's,\.lisp,,1') + +all: $(addsuffix .c,$(FILES)) $(addsuffix .o,$(FILES)) + +saved_clcs_gcl: ../unixport/saved_pcl_gcl$(EXE) + echo '(load "package.lisp")(load "myload.lisp")(si::save-system "$@")' | $< $(| |top - base| + ("FEtoo_few_argumentsF" :too-few-arguments "Too few arguments." + internal-simple-control-error) ; || |args| + ("FEtoo_many_arguments" :too-many-arguments "~S [or a callee] requires less than ~R argument~:p." + internal-simple-control-error) ; || |top - base| + ("FEtoo_many_argumentsF" :too-many-arguments "Too many arguments." + internal-simple-control-error) ; || |args| + ("FEinvalid_macro_call" :invalid-form "Invalid macro call to ~S." + internal-simple-program-error) ; || + ("FEunexpected_keyword" :unexpected-keyword "~S does not allow the keyword ~S." + internal-simple-control-error) ; || |key| + ("FEunbound_variable" :unbound-variable "The variable ~S is unbound." + internal-unbound-variable :name) ; |sym| + ("FEundefined_function" :undefined-function "The function ~S is undefined." + internal-undefined-function :name) + ("FEinvalid_function" :invalid-function "~S is invalid as a function." + internal-simple-program-error) ; |obj| + ("check_arg_failed" :too-few-arguments "~S [or a callee] requires ~R argument~:p,~%\ +but only ~R ~:*~[were~;was~:;were~] supplied." + internal-simple-control-error) ; || |n| |top - base| + ("check_arg_failed" :too-many-arguments "~S [or a callee] requires only ~R argument~:p,~%\ +but ~R ~:*~[were~;was~:;were~] supplied." + internal-simple-control-error) ; || |n| |top - base| + ("ck_larg_at_least" :error "APPLY sended too few arguments to LAMBDA." + internal-simple-control-error) + ("ck_larg_exactly" :error "APPLY sended too few arguments to LAMBDA." + internal-simple-control-error) + ("keyword_value_mismatch" :error "Keywords and values do not match." + internal-simple-error) ;?? + ("not_a_keyword" :error "~S is not a keyword." + internal-simple-error) ;?? + ("illegal_declare" :invalid-form "~S is an illegal declaration form." + internal-simple-program-error) + ("not_a_symbol" :invalid-variable "~S is not a symbol." + internal-simple-error) ;?? + ("not_a_variable" :invalid-variable "~S is not a variable." + internal-simple-program-error) + ("illegal_index" :error "~S is an illegal index to ~S." + internal-simple-error) + ("vfun_wrong_number_of_args" :error "Expected ~S args but received ~S args" + internal-simple-control-error) + + ("end_of_stream" :error "Unexpected end of ~S." + internal-end-of-file :stream) + ("open_stream" :error "~S is an illegal IF-DOES-NOT-EXIST option." + internal-simple-control-error) + ("open_stream" :error "The file ~A already exists." + internal-simple-file-error :pathname) + ("open_stream" :error "Cannot append to the file ~A." + internal-simple-file-error :pathname) + ("open_stream" :error "~S is an illegal IF-EXISTS option." + internal-simple-control-error) + ("close_stream" :error "Cannot close the standard output." + internal-simple-stream-error) ; no stream here!! + ("close_stream" :error "Cannot close the standard input." + internal-simple-stream-error) ; no stream here!! + ("too_long_file_name" :error "~S is a too long file name." + internal-simple-file-error :pathname) + ("cannot_open" :error "Cannot open the file ~A." + internal-simple-file-error :pathname) + ("cannot_create" :error "Cannot create the file ~A." + internal-simple-file-error :pathname) + ("cannot_read" :error "Cannot read the stream ~S." + internal-simple-stream-error :stream) + ("cannot_write" :error "Cannot write to the stream ~S." + internal-simple-stream-error :stream) + )) + +(initialize-internal-error-table) + +(defun condition-backtrace (condition) + (let* ((*debug-io* *error-output*) + (si::*ihs-base* (1+ si::*ihs-top*)) + (si::*ihs-top* (1- (si::ihs-top))) + (si::*current-ihs* si::*ihs-top*) + (si::*frs-base* (or (si::sch-frs-base si::*frs-top* si::*ihs-base*) + (1+ (si::frs-top)))) + (si::*frs-top* (si::frs-top)) + (si::*break-env* nil)) + (format *error-output* "~%~A~%" condition) + (si::simple-backtrace))) + +(defvar *error-set-break-p* nil) + +(defun clcs-error-set (form) + (let ((cond nil)) + (restart-case (handler-bind ((error #'(lambda (condition) + (unless (or si::*break-enable* + *error-set-break-p*) + (condition-backtrace condition) + (return-from clcs-error-set condition)) + (setq cond condition) + nil))) + (values-list (cons nil (multiple-value-list (eval form))))) + (si::error-set () + :report (lambda (stream) + (format stream "~S" `(si::error-set ',form))) + cond)))) + +(eval-when (compile load eval) + +(defun reset-function (symbol) ; invoke compiler::compiler-clear-compiler-properties + (setf (symbol-function symbol) (symbol-function symbol))) + +(reset-function 'si::error-set) +(reset-function 'load) +(reset-function 'open) +) + +(setq compiler::*compiler-break-enable* t) + +(defun compiler::cmp-toplevel-eval (form) + (let* (;;(si::*ihs-base* si::*ihs-top*) ; show the whole stack + (si::*ihs-top* (1- (si::ihs-top))) + (*break-enable* compiler::*compiler-break-enable*) + (si::*break-hidden-packages* + (cons (find-package 'compiler) + si::*break-hidden-packages*))) + (si:error-set form))) diff --git a/clcs/unused/test2.lisp b/clcs/unused/test2.lisp new file mode 100755 index 0000000..5ed87e5 --- /dev/null +++ b/clcs/unused/test2.lisp @@ -0,0 +1,41 @@ +(in-package "conditions") + +(define-condition internal-unbound-variable + (#+(or clos pcl) internal-error unbound-variable) + #-(or clos pcl) + ((function-name nil)) + #+(or clos pcl) + () + #-(or clos pcl)(:conc-name %%internal-unbound-variable-) + #-(or clos pcl)(:REPORT (LAMBDA (CONDITION STREAM) + (when (internal-error-function-name condition) + (format stream "Error in ~S [or a callee]: " + (internal-error-function-name condition))) + (FORMAT STREAM "The variable ~S is unbound." + (CELL-ERROR-NAME CONDITION))))) + + +#-(or pcl clos) +(defun internal-error-function-name (condition) + (etypecase condition + (internal-error + (%%internal-simple-error-function-name condition)) + (internal-simple-error + (%%internal-simple-error-function-name condition)) + (internal-type-error + (%%internal-type-error-function-name condition)) + (internal-simple-program-error + (%%internal-simple-program-error-function-name condition)) + (internal-simple-control-error + (%%internal-simple-control-error-function-name condition)) + (internal-unbound-variable + (%%internal-unbound-variable-function-name condition)) + (internal-undefined-function + (%%internal-undefined-function-function-name condition)) + (internal-end-of-file + (%%internal-end-of-file-function-name condition)) + (internal-simple-file-error + (%%internal-simple-file-error-function-name condition)) + (internal-simple-stream-error + (%%internal-simple-stream-error-function-name condition)))) + diff --git a/clcs/unused/test3.lisp b/clcs/unused/test3.lisp new file mode 100755 index 0000000..288cc90 --- /dev/null +++ b/clcs/unused/test3.lisp @@ -0,0 +1,103 @@ +(IN-PACKAGE "CONDITIONS") + +(define-condition internal-simple-error + (internal-error #+(or clos pcl) simple-condition) + #-(or clos pcl) + ((function-name nil) format-string (format-arguments '())) + #+(or clos pcl) + () + #-(or clos pcl)(:conc-name %%internal-simple-error-) + (:report internal-simple-error-printer)) + +(define-condition internal-type-error + (#+(or clos pcl) internal-error type-error) + #-(or clos pcl) + ((function-name nil)) + #+(or clos pcl) + () + #-(or clos pcl)(:conc-name %%internal-type-error-) + #-(or clos pcl)(:report (lambda (condition stream) + (when (internal-error-function-name condition) + (format stream "Error in ~S [or a callee]: " + (internal-error-function-name condition))) + (format stream "~S is not of type ~S." + (type-error-datum condition) + (type-error-expected-type condition))))) + +(define-condition internal-simple-program-error + (#+(or clos pcl) internal-simple-error program-error) + #-(or clos pcl) + ((function-name nil) format-string (format-arguments '())) + #+(or clos pcl) + () + #-(or clos pcl)(:conc-name %%internal-simple-program-error-) + #-(or clos pcl)(:report internal-simple-error-printer)) + +(define-condition internal-simple-control-error + (#+(or clos pcl) internal-simple-error control-error) + #-(or clos pcl) + ((function-name nil) format-string (format-arguments '())) + #+(or clos pcl) + () + #-(or clos pcl)(:conc-name %%internal-simple-control-error-) + #-(or clos pcl)(:report internal-simple-error-printer)) + +(define-condition internal-unbound-variable + (#+(or clos pcl) internal-error unbound-variable) + #-(or clos pcl) + ((function-name nil)) + #+(or clos pcl) + () + #-(or clos pcl)(:conc-name %%internal-unbound-variable-) + #-(or clos pcl)(:REPORT (LAMBDA (CONDITION STREAM) + (when (internal-error-function-name condition) + (format stream "Error in ~S [or a callee]: " + (internal-error-function-name condition))) + (FORMAT STREAM "The variable ~S is unbound." + (CELL-ERROR-NAME CONDITION))))) + +(define-condition internal-undefined-function + (#+(or clos pcl) internal-error undefined-function) + #-(or clos pcl) + ((function-name nil)) + #+(or clos pcl) + () + #-(or clos pcl)(:conc-name %%internal-undefined-function-) + #-(or clos pcl)(:REPORT (LAMBDA (CONDITION STREAM) + (when (internal-error-function-name condition) + (format stream "Error in ~S [or a callee]: " + (internal-error-function-name condition))) + (FORMAT STREAM "The function ~S is undefined." + (CELL-ERROR-NAME CONDITION))))) + +(define-condition internal-end-of-file + (#+(or clos pcl) internal-error end-of-file) + #-(or clos pcl) + ((function-name nil)) + #+(or clos pcl) + () + #-(or clos pcl)(:conc-name %%internal-end-of-file-) + #-(or clos pcl)(:REPORT (LAMBDA (CONDITION STREAM) + (when (internal-error-function-name condition) + (format stream "Error in ~S [or a callee]: " + (internal-error-function-name condition))) + (FORMAT STREAM "Unexpected end of file on ~S." + (STREAM-ERROR-STREAM CONDITION))))) + +(define-condition internal-simple-file-error + (#+(or clos pcl) internal-simple-error file-error) + #-(or clos pcl) + ((function-name nil) format-string (format-arguments '())) + #+(or clos pcl) + () + #-(or clos pcl)(:conc-name %%internal-simple-file-error-) + #-(or clos pcl)(:report internal-simple-error-printer)) + +(define-condition internal-simple-stream-error + (#+(or clos pcl) internal-simple-error stream-error) + #-(or clos pcl) + ((function-name nil) format-string (format-arguments '())) + #+(or clos pcl) + () + #-(or clos pcl)(:conc-name %%internal-simple-stream-error-) + #-(or clos pcl)(:report internal-simple-error-printer)) diff --git a/clcs/unused/test4.lisp b/clcs/unused/test4.lisp new file mode 100755 index 0000000..aa9455f --- /dev/null +++ b/clcs/unused/test4.lisp @@ -0,0 +1,12 @@ +(IN-PACKAGE "CONDITIONS") + +(define-condition internal-unbound-variable + (#+(or clos pcl) internal-error unbound-variable) #-(or clos pcl) ((function-name nil)) + #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-unbound-variable-) + #-(or clos pcl)(:REPORT (LAMBDA (CONDITION STREAM) + (when (internal-error-function-name condition) + (format stream "Error in ~S [or a callee]: " + (internal-error-function-name condition))) + (FORMAT STREAM "The variable ~S is unbound." + (CELL-ERROR-NAME CONDITION))))) + diff --git a/clcs/unused/test5.lisp b/clcs/unused/test5.lisp new file mode 100755 index 0000000..603b488 --- /dev/null +++ b/clcs/unused/test5.lisp @@ -0,0 +1,342 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- + +(IN-PACKAGE "CONDITIONS") + +(eval-when (compile load eval) +(pushnew #+(or clos pcl) :clos-conditions #-(or clos pcl) :defstruct-conditions + *features*) +) + +(eval-when (compile load eval) +(when (and (member :clos-conditions *features*) + (member :defstruct-conditions *features*)) + (dolist (sym '(simple-condition-format-string simple-condition-format-arguments + type-error-datum type-error-expected-type + case-failure-name case-failure-possibilities + stream-error-stream file-error-pathname package-error-package + cell-error-name arithmetic-error-operation + internal-error-function-name)) + (when (fboundp sym) (fmakunbound sym))) + (setq *features* (remove :defstruct-conditions *features*))) +) + +;;; Start + +(DEFINE-CONDITION WARNING (CONDITION) + ()) + +(DEFINE-CONDITION SERIOUS-CONDITION (CONDITION) + ()) + +(DEFINE-CONDITION lisp:ERROR (SERIOUS-CONDITION) + ()) + +(DEFUN SIMPLE-CONDITION-PRINTER (CONDITION STREAM) + (APPLY #'FORMAT STREAM (SIMPLE-CONDITION-FORMAT-STRING CONDITION) + (SIMPLE-CONDITION-FORMAT-ARGUMENTS CONDITION))) + +(DEFINE-CONDITION SIMPLE-CONDITION (CONDITION) + #-(or clos pcl) + (FORMAT-STRING (FORMAT-ARGUMENTS '())) + #+(or clos pcl) + ((FORMAT-STRING :type string + :initarg :FORMAT-STRING + :reader SIMPLE-CONDITION-FORMAT-STRING) + (FORMAT-ARGUMENTS :initarg :FORMAT-ARGUMENTS + :reader SIMPLE-CONDITION-FORMAT-ARGUMENTS + :initform '())) + #-(or clos pcl)(:CONC-NAME %%SIMPLE-CONDITION-) + (:REPORT SIMPLE-CONDITION-PRINTER)) + +(DEFINE-CONDITION SIMPLE-WARNING (#+(or clos pcl) SIMPLE-CONDITION WARNING) + #-(or clos pcl) + (FORMAT-STRING (FORMAT-ARGUMENTS '())) + #+(or clos pcl) + () + #-(or clos pcl)(:CONC-NAME %%SIMPLE-WARNING-) + #-(or clos pcl)(:REPORT SIMPLE-CONDITION-PRINTER)) + +(DEFINE-CONDITION SIMPLE-ERROR (#+(or clos pcl) SIMPLE-CONDITION lisp:ERROR) + #-(or clos pcl) + (FORMAT-STRING (FORMAT-ARGUMENTS '())) + #+(or clos pcl) + () + #-(or clos pcl)(:CONC-NAME %%SIMPLE-ERROR-) + #-(or clos pcl)(:REPORT SIMPLE-CONDITION-PRINTER)) + +(DEFINE-CONDITION STORAGE-CONDITION (SERIOUS-CONDITION) ()) + +(DEFINE-CONDITION STACK-OVERFLOW (STORAGE-CONDITION) ()) + +(DEFINE-CONDITION STORAGE-EXHAUSTED (STORAGE-CONDITION) ()) + +(DEFINE-CONDITION TYPE-ERROR (lisp:ERROR) + #-(or clos pcl) + (DATUM EXPECTED-TYPE) + #+(or clos pcl) + ((DATUM :initarg :DATUM + :reader TYPE-ERROR-DATUM) + (EXPECTED-TYPE :initarg :EXPECTED-TYPE + :reader TYPE-ERROR-EXPECTED-TYPE)) + (:report + (lambda (condition stream) + (format stream "~S is not of type ~S." + (TYPE-ERROR-DATUM CONDITION) + (TYPE-ERROR-EXPECTED-TYPE CONDITION))))) + +(DEFINE-CONDITION SIMPLE-TYPE-ERROR (#+(or clos pcl) SIMPLE-CONDITION TYPE-ERROR) + #-(or clos pcl) + (FORMAT-STRING (FORMAT-ARGUMENTS '())) + #+(or clos pcl) + () + #-(or clos pcl)(:CONC-NAME %%SIMPLE-TYPE-ERROR-) + #-(or clos pcl)(:REPORT SIMPLE-CONDITION-PRINTER)) + +(DEFINE-CONDITION CASE-FAILURE (TYPE-ERROR) + #-(or clos pcl) + (NAME POSSIBILITIES) + #+(or clos pcl) + ((NAME :initarg :NAME + :reader CASE-FAILURE-NAME) + (POSSIBILITIES :initarg :POSSIBILITIES + :reader CASE-FAILURE-POSSIBILITIES)) + (: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))))) + +(DEFINE-CONDITION PROGRAM-ERROR (lisp:ERROR) + ()) + +(DEFINE-CONDITION CONTROL-ERROR (lisp:ERROR) + ()) + +(DEFINE-CONDITION STREAM-ERROR (lisp:ERROR) + #-(or clos pcl) + (STREAM) + #+(or clos pcl) + ((STREAM :initarg :STREAM + :reader STREAM-ERROR-STREAM))) + +(DEFINE-CONDITION END-OF-FILE (STREAM-ERROR) + () + (:REPORT (LAMBDA (CONDITION STREAM) + (FORMAT STREAM "Unexpected end of file on ~S." + (STREAM-ERROR-STREAM CONDITION))))) + +(DEFINE-CONDITION FILE-ERROR (lisp:ERROR) + #-(or clos pcl) + (PATHNAME) + #+(or clos pcl) + ((PATHNAME :initarg :PATHNAME + :reader FILE-ERROR-PATHNAME))) + +(DEFINE-CONDITION PACKAGE-ERROR (lisp:ERROR) + #-(or clos pcl) + (PACKAGE) + #+(or clos pcl) + ((PACKAGE :initarg :PACKAGE + :reader PACKAGE-ERROR-PACKAGE))) + +(DEFINE-CONDITION CELL-ERROR (lisp:ERROR) + #-(or clos pcl) + (NAME) + #+(or clos pcl) + ((NAME :initarg :NAME + :reader CELL-ERROR-NAME))) + +(DEFINE-CONDITION UNDEFINED-FUNCTION (CELL-ERROR) + () + (:REPORT (LAMBDA (CONDITION STREAM) + (FORMAT STREAM "The function ~S is undefined." + (CELL-ERROR-NAME CONDITION))))) + +(DEFINE-CONDITION ARITHMETIC-ERROR (lisp:ERROR) + #-(or clos pcl) + (OPERATION OPERANDS) + #+(or clos pcl) + ((OPERATION :initarg :OPERATION + :reader ARITHMETIC-ERROR-OPERATION))) + +(DEFINE-CONDITION DIVISION-BY-ZERO (ARITHMETIC-ERROR) + ()) + +(DEFINE-CONDITION FLOATING-POINT-OVERFLOW (ARITHMETIC-ERROR) + ()) + +(DEFINE-CONDITION FLOATING-POINT-UNDERFLOW (ARITHMETIC-ERROR) + ()) + +(DEFINE-CONDITION ABORT-FAILURE (CONTROL-ERROR) () + (:REPORT "Abort failed.")) + + +#+kcl +(progn + +;;; When this form is present, the compiled behavior disagrees with +;;; the interpreted behavior. The interpreted behavior is correct. +(define-condition internal-error (lisp:error) + #-(or clos pcl) + ((function-name nil)) + #+(or clos pcl) + ((function-name :initarg :function-name + :reader internal-error-function-name + :initform 'nil)) + (:report (lambda (condition stream) + (when (internal-error-function-name condition) + (format stream "Error in ~S [or a callee]: " + (internal-error-function-name condition))) + #+(or clos pcl)(call-next-method)))) + +(defun internal-simple-error-printer (condition stream) + (when (internal-error-function-name condition) + (format stream "Error in ~S [or a callee]: " + (internal-error-function-name condition))) + (apply #'format stream (simple-condition-format-string condition) + (simple-condition-format-arguments condition))) + +(define-condition internal-simple-error + (internal-error #+(or clos pcl) simple-condition) + #-(or clos pcl) + ((function-name nil) format-string (format-arguments '())) + #+(or clos pcl) + () + #-(or clos pcl)(:conc-name %%internal-simple-error-) + (:report internal-simple-error-printer)) + +(define-condition internal-type-error + (#+(or clos pcl) internal-error type-error) + #-(or clos pcl) + ((function-name nil)) + #+(or clos pcl) + () + #-(or clos pcl)(:conc-name %%internal-type-error-) + #-(or clos pcl)(:report (lambda (condition stream) + (when (internal-error-function-name condition) + (format stream "Error in ~S [or a callee]: " + (internal-error-function-name condition))) + (format stream "~S is not of type ~S." + (type-error-datum condition) + (type-error-expected-type condition))))) + +(define-condition internal-simple-program-error + (#+(or clos pcl) internal-simple-error program-error) + #-(or clos pcl) + ((function-name nil) format-string (format-arguments '())) + #+(or clos pcl) + () + #-(or clos pcl)(:conc-name %%internal-simple-program-error-) + #-(or clos pcl)(:report internal-simple-error-printer)) + +(define-condition internal-simple-control-error + (#+(or clos pcl) internal-simple-error control-error) + #-(or clos pcl) + ((function-name nil) format-string (format-arguments '())) + #+(or clos pcl) + () + #-(or clos pcl)(:conc-name %%internal-simple-control-error-) + #-(or clos pcl)(:report internal-simple-error-printer)) + + +(define-condition internal-unbound-variable + (#+(or clos pcl) internal-error unbound-variable) + #-(or clos pcl) + ((function-name nil)) + #+(or clos pcl) + () + #-(or clos pcl)(:conc-name %%internal-unbound-variable-) + #-(or clos pcl)(:REPORT (LAMBDA (CONDITION STREAM) + (when (internal-error-function-name condition) + (format stream "Error in ~S [or a callee]: " + (internal-error-function-name condition))) + (FORMAT STREAM "The variable ~S is unbound." + (CELL-ERROR-NAME CONDITION))))) + +#-(or pcl clos) +(defun internal-error-function-name (condition) + (etypecase condition + (internal-error + (%%internal-error-function-name condition)) + (internal-simple-error + (%%internal-simple-error-function-name condition)) + (internal-type-error + (%%internal-type-error-function-name condition)) + (internal-simple-program-error + (%%internal-simple-program-error-function-name condition)) + (internal-simple-control-error + (%%internal-simple-control-error-function-name condition)) + (internal-unbound-variable + (%%internal-unbound-variable-function-name condition)) + (internal-undefined-function + (%%internal-undefined-function-function-name condition)) + (internal-end-of-file + (%%internal-end-of-file-function-name condition)) + (internal-simple-file-error + (%%internal-simple-file-error-function-name condition)) + (internal-simple-stream-error + (%%internal-simple-stream-error-function-name condition)))) +) + +#-(or clos pcl) +(progn + +(DEFUN SIMPLE-CONDITION-FORMAT-STRING (CONDITION) + (ETYPECASE CONDITION + (SIMPLE-CONDITION (%%SIMPLE-CONDITION-FORMAT-STRING CONDITION)) + (SIMPLE-WARNING (%%SIMPLE-WARNING-FORMAT-STRING CONDITION)) + (SIMPLE-TYPE-ERROR (%%SIMPLE-TYPE-ERROR-FORMAT-STRING CONDITION)) + (SIMPLE-ERROR (%%SIMPLE-ERROR-FORMAT-STRING CONDITION)) + #+kcl(internal-simple-error + (%%internal-simple-error-format-string condition)) + #+kcl(internal-simple-program-error + (%%internal-simple-program-error-format-string condition)) + #+kcl(internal-simple-control-error + (%%internal-simple-control-error-format-string condition)) + #+kcl(internal-simple-file-error + (%%internal-simple-file-error-format-string condition)) + #+kcl(internal-simple-stream-error + (%%internal-simple-stream-error-format-string condition)))) + +(DEFUN SIMPLE-CONDITION-FORMAT-ARGUMENTS (CONDITION) + (ETYPECASE CONDITION + (SIMPLE-CONDITION (%%SIMPLE-CONDITION-FORMAT-ARGUMENTS CONDITION)) + (SIMPLE-WARNING (%%SIMPLE-WARNING-FORMAT-ARGUMENTS CONDITION)) + (SIMPLE-TYPE-ERROR (%%SIMPLE-TYPE-ERROR-FORMAT-ARGUMENTS CONDITION)) + (SIMPLE-ERROR (%%SIMPLE-ERROR-FORMAT-ARGUMENTS CONDITION)) + #+kcl(internal-simple-error + (%%internal-simple-error-format-arguments condition)) + #+kcl(internal-simple-program-error + (%%internal-simple-program-error-format-arguments condition)) + #+kcl(internal-simple-control-error + (%%internal-simple-control-error-format-arguments condition)) + #+kcl(internal-simple-file-error + (%%internal-simple-file-error-format-arguments condition)) + #+kcl(internal-simple-stream-error + (%%internal-simple-stream-error-format-arguments condition)))) + +(defun simple-condition-class-p (type) + (member type '(SIMPLE-CONDITION SIMPLE-WARNING SIMPLE-TYPE-ERROR SIMPLE-ERROR + #+kcl internal-simple-error + #+kcl internal-simple-program-error + #+kcl internal-simple-control-error + #+kcl internal-simple-file-error + #+kcl internal-simple-stream-error))) +) + +#+(or clos pcl) +(progn +(defvar *simple-condition-class* (find-class 'simple-condition)) + +(defun simple-condition-class-p (TYPE) + (when (symbolp TYPE) + (setq TYPE (find-class TYPE))) + (and (typep TYPE 'standard-class) + (member *simple-condition-class* + (#+pcl pcl::class-precedence-list + #-pcl clos::class-precedence-list + type)))) +) + diff --git a/clcs/unused/tester.lisp b/clcs/unused/tester.lisp new file mode 100755 index 0000000..799c3aa --- /dev/null +++ b/clcs/unused/tester.lisp @@ -0,0 +1,11 @@ +(in-package "conditions") + +(defun compare-semantics (file condition) + (let ((results)) + (load (format nil "~A.lisp" file)) + (push (with-output-to-string (s) (princ condition s)) results) + (compile-file (format nil "~A.lisp" file)) + (load (format nil "~A.o" file)) + (push (with-output-to-string (s) (princ condition s)) results) + (print (reverse results)) + (values))) \ No newline at end of file diff --git a/cmpnew/gcl_cmpbind.lsp b/cmpnew/gcl_cmpbind.lsp new file mode 100755 index 0000000..fe4a8cd --- /dev/null +++ b/cmpnew/gcl_cmpbind.lsp @@ -0,0 +1,131 @@ +;;; CMPBIND Variable Binding. +;;; +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +(in-package 'compiler) + +(si:putprop 'bds-bind 'set-bds-bind 'set-loc) + +;;; Those functions that call the following binding functions should +;;; rebind the special variables, +;;; *vs*, *clink*, *ccb-vs*, and *unwind-exit*. + +(defun c2bind (var) + (case (var-kind var) + (LEXICAL + (when (var-ref-ccb var) + (wt-nl) + (wt-vs (var-ref var)) + (wt "=MMcons(") (wt-vs (var-ref var)) + (wt ",") (wt-clink) (wt ");") + (clink (var-ref var)) + (setf (var-ref-ccb var) (ccb-vs-push)))) + (SPECIAL + (wt-nl "bds_bind(" (vv-str (var-loc var)) ",") (wt-vs (var-ref var)) + (wt ");") + (push 'bds-bind *unwind-exit*)) + (DOWN + (cond ((integerp (var-loc var)) + (wt-nl "base0[" (var-loc var) "]=") + (wt-vs (var-ref var)) + (wt ";")) + (t (wfs-error)))) + (INTEGER + (wt-nl "SETQ_IO(V" (var-loc var)"," + "V" (var-loc var)"alloc,") + (wt "(") (wt-vs (var-ref var)) (wt "),") + (wt (bignum-expansion-storage) ");")) + (t + (wt-nl "V" (var-loc var) "=") + (case (var-kind var) + (OBJECT) + (FIXNUM (wt "fix")) + (CHARACTER (wt "char_code")) + (LONG-FLOAT (wt "lf")) + (SHORT-FLOAT (wt "sf")) + (t (baboon))) + (wt "(") (wt-vs (var-ref var)) (wt ");"))) + ) + +(defun c2bind-loc (var loc) + (case (var-kind var) + (LEXICAL + (cond ((var-ref-ccb var) + (wt-nl) + (wt-vs (var-ref var)) + (wt "=MMcons(" loc ",") (wt-clink) (wt ");") + (clink (var-ref var)) + (setf (var-ref-ccb var) (ccb-vs-push))) + (t + (wt-nl) (wt-vs (var-ref var)) (wt "= " loc ";")))) + (SPECIAL + (wt-nl "bds_bind(" (vv-str (var-loc var)) "," loc ");") + (push 'bds-bind *unwind-exit*)) + + (DOWN + (wt-nl "base0[" (var-loc var) "]=" loc ";")) + (INTEGER + (let ((*inline-blocks* 0) (*restore-avma* *restore-avma*)) + (save-avma '(nil integer)) + (wt-nl "V" (var-loc var) "= ") + (wt-integer-loc loc var) + (wt ";") + (close-inline-blocks))) + (t + (wt-nl "V" (var-loc var) "= ") + (case (var-kind var) + (OBJECT (wt-loc loc)) + (FIXNUM (wt-fixnum-loc loc)) + (CHARACTER (wt-character-loc loc)) + (LONG-FLOAT (wt-long-float-loc loc)) + (SHORT-FLOAT (wt-short-float-loc loc)) + (t (baboon))) + (wt ";"))) + ) + +(defun c2bind-init (var init) + (case (var-kind var) + (LEXICAL + (cond ((var-ref-ccb var) + (let ((loc (list 'vs (var-ref var)))) + (let ((*value-to-go* loc)) + (c2expr* init)) + (wt-nl loc "=MMcons(" loc ",") (wt-clink *clink*) + (wt ");")) + (clink (var-ref var)) + (setf (var-ref-ccb var) (ccb-vs-push))) + (t + (let ((*value-to-go* (list 'vs (var-ref var)))) + (c2expr* init))))) + (SPECIAL + (let ((*value-to-go* (list 'bds-bind (var-loc var)))) + (c2expr* init)) + (push 'bds-bind *unwind-exit*)) + (DOWN + (let ((*value-to-go* (list 'down (var-loc var)))) + (c2expr* init))) + ((OBJECT FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT INTEGER) + (let ((*value-to-go* (list 'var var nil))) + (c2expr* init))) + (t (baboon))) + ) + +(defun set-bds-bind (loc vv) + (wt-nl "bds_bind(" (vv-str vv) "," loc ");")) diff --git a/cmpnew/gcl_cmpblock.lsp b/cmpnew/gcl_cmpblock.lsp new file mode 100755 index 0000000..2653cec --- /dev/null +++ b/cmpnew/gcl_cmpblock.lsp @@ -0,0 +1,169 @@ +;;; CMPBLOCK Block and Return-from. +;;; +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +(in-package 'compiler) + +(si:putprop 'block 'c1block 'c1special) +(si:putprop 'block 'c2block 'c2) + +(si:putprop 'return-from 'c1return-from 'c1special) +(si:putprop 'return-from 'c2return-from 'c2) + +(defstruct blk + name ;;; Block name. + ref ;;; Referenced or not. T or NIL. + ref-clb ;;; Cross local function reference. + ;;; During Pass1, T or NIL. + ;;; During Pass2, the vs-address for the + ;;; block id, or NIL. + ref-ccb ;;; Cross closure reference. + ;;; During Pass1, T or NIL. + ;;; During Pass2, the ccb-vs for the + ;;; block id, or NIL. + exit ;;; Where to return. A label. + value-to-go ;;; Where the value of the block to go. + var ;;; The block name holder. Used only in + ;;; the error message. + ) + +(defvar *blocks* nil) + +;;; During Pass 1, *blocks* holds a list of blk objects and the symbols 'CB' +;;; (Closure Boundary) and 'LB' (Level Boundary). 'CB' will be pushed on +;;; *blocks* when the compiler begins to process a closure. 'LB' will be +;;; pushed on *blocks* when *level* is incremented. + +(defun c1block (args) + (when (endp args) (too-few-args 'block 1 0)) + (cmpck (not (symbolp (car args))) + "The block name ~s is not a symbol." (car args)) + (let* ((blk (make-blk :name (car args) :ref nil :ref-ccb nil :ref-clb nil)) + (*blocks* (cons blk *blocks*)) + (body (c1progn (cdr args)))) + (if (or (blk-ref-ccb blk) (blk-ref-clb blk)) + (incf *setjmps*)) + + (if (or (blk-ref-ccb blk) (blk-ref-clb blk) (blk-ref blk)) + (list 'block (reset-info-type (cadr body)) blk body) + body)) + ) + +(defun c2block (blk body) + (cond ((blk-ref-ccb blk) (c2block-ccb blk body)) + ((blk-ref-clb blk) (c2block-clb blk body)) + (t (c2block-local blk body)))) + +(defun c2block-local (blk body) + (setf (blk-exit blk) *exit*) + (setf (blk-value-to-go blk) *value-to-go*) + (c2expr body) + ) + +(defun c2block-clb (blk body &aux (*vs* *vs*)) + (setf (blk-exit blk) *exit*) + (setf (blk-value-to-go blk) *value-to-go*) + (setf (blk-ref-clb blk) (vs-push)) + (wt-nl) + (wt-vs (blk-ref-clb blk)) + (wt "=alloc_frame_id();") + (wt-nl "frs_push(FRS_CATCH,") (wt-vs (blk-ref-clb blk)) (wt ");") + (wt-nl "if(nlj_active)") + (wt-nl "{nlj_active=FALSE;frs_pop();") + (unwind-exit 'fun-val 'jump) + (wt "}") + (wt-nl "else{") + (let ((*unwind-exit* (cons 'frame *unwind-exit*))) (c2expr body)) + (wt-nl "}") + ) + +(defun c2block-ccb (blk body &aux (*vs* *vs*) (*clink* *clink*) + (*ccb-vs* *ccb-vs*)) + (setf (blk-exit blk) *exit*) + (setf (blk-value-to-go blk) *value-to-go*) + (setf (blk-ref-clb blk) (vs-push)) + (setf (blk-var blk) (add-symbol (blk-name blk))) + (wt-nl) (wt-vs (blk-ref-clb blk)) (wt "=alloc_frame_id();") + (wt-nl) (wt-vs (blk-ref-clb blk)) + (wt "=MMcons(") (wt-vs (blk-ref-clb blk)) (wt ",") (wt-clink) (wt ");") + (clink (blk-ref-clb blk)) + (setf (blk-ref-ccb blk) (ccb-vs-push)) + (wt-nl "frs_push(FRS_CATCH,") (wt-vs* (blk-ref-clb blk)) (wt ");") + (wt-nl "if(nlj_active)") + (wt-nl "{nlj_active=FALSE;frs_pop();") + (unwind-exit 'fun-val 'jump) + (wt "}") + (wt-nl "else{") + (let ((*unwind-exit* (cons 'frame *unwind-exit*))) (c2expr body)) + (wt-nl "}") + ) + +(defun c1return-from (args) + (cond ((endp args) (too-few-args 'return-from 1 0)) + ((and (not (endp (cdr args))) (not (endp (cddr args)))) + (too-many-args 'return-from 2 (length args))) + ((not (symbolp (car args))) + "The block name ~s is not a symbol." (car args))) + (do ((blks *blocks* (cdr blks)) + (name (car args)) + (ccb nil) (clb nil)) + ((endp blks) + (cmperr "The block ~s is undefined." name)) + (declare (object name ccb clb)) + (case (car blks) + (cb (setq ccb t)) + (lb (setq clb t)) + (t (when (eq (blk-name (car blks)) name) + (let ((val (c1expr (cadr args))) + (blk (car blks))) + (cond + (ccb (setf (blk-ref-ccb blk) t)) + (clb (setf (blk-ref-clb blk) t)) + (t (setf (blk-ref blk) t))) + (return (list 'return-from + (reset-info-type (cadr val)) + blk clb ccb val))))))) + ) + +(defun c2return-from (blk clb ccb val) + (cond (ccb (c2return-ccb blk val)) + (clb (c2return-clb blk val)) + (t (c2return-local blk val)))) + +(defun c2return-local (blk val) + (let ((*value-to-go* (blk-value-to-go blk)) + (*exit* (blk-exit blk))) + (c2expr val)) + ) + +(defun c2return-clb (blk val) + (let ((*value-to-go* 'top)) (c2expr* val)) + (wt-nl "unwind(frs_sch(") + (if (blk-ref-ccb blk) (wt-vs* (blk-ref-clb blk)) (wt-vs (blk-ref-clb blk))) + (wt "),Cnil);") + ) + +(defun c2return-ccb (blk val) + (wt-nl "{frame_ptr fr;") + (wt-nl "fr=frs_sch(") (wt-ccb-vs (blk-ref-ccb blk)) (wt ");") + (wt-nl "if(fr==NULL) FEerror(\"The block ~s is missing.\",1," (vv-str (blk-var blk)) ");") + (let ((*value-to-go* 'top)) (c2expr* val)) + (wt-nl "unwind(fr,Cnil);}") + ) diff --git a/cmpnew/gcl_cmpcall.lsp b/cmpnew/gcl_cmpcall.lsp new file mode 100755 index 0000000..c2ac971 --- /dev/null +++ b/cmpnew/gcl_cmpcall.lsp @@ -0,0 +1,578 @@ +;;; CMPCALL Function call. +;;; +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +(in-package 'compiler) + +(defvar *ifuncall* nil) + + +(eval-when (compile eval) +(defmacro link-arg-p (x) + `(let ((.u ,x)) + (not (member .u '(character boolean long-float short-float))))) +) + +(defun fast-link-proclaimed-type-p (fname &optional args) + (and + (symbolp fname) + (and (< (the fixnum(length args)) 64) + (or (and (get fname 'fixed-args) + (listp args)) + (and + (get fname 'proclaimed-function) + (link-arg-p (get fname 'proclaimed-return-type)) + (dolist (v (get fname 'proclaimed-arg-types) t) + (or (eq v '*)(link-arg-p v) (return nil)))))))) + +(si::putprop 'funcall 'c2funcall-aux 'wholec2) +(si:putprop 'call-lambda 'c2call-lambda 'c2) +(si:putprop 'call-global 'c2call-global 'c2) + +;;Like macro-function except it searches the lexical environment, +;;to determine if the macro is shadowed by a function or a macro. +(defun cmp-macro-function (name &aux fd) + (cond ((setq fd (c1local-fun name)) + (if (eq (car fd) 'call-local) nil fd)) + (t (macro-function name)))) + +(defun c1funob (fun &aux fd) + ;;; NARGS is the number of arguments. If the number is unknown, (e.g. + ;;; in case of APPLY), then NARGS should be NIL. + (cond ((and (consp fun) + (symbolp (car fun)) + (cmp-macro-function (car fun))) + (setq fun (cmp-macroexpand fun)))) + (or + (and + (consp fun) + (or (and (eq (car fun) 'quote) + (not (endp (cdr fun))) + (endp (cddr fun)) + (or (and (consp (cadr fun)) + (not (endp (cdadr fun))) + (eq (caadr fun) 'lambda) + (let ((*vars* nil) (*funs* nil) (*blocks* nil) + (*tags* nil)) + (let ((lambda-expr (c1lambda-expr (cdadr fun)))) + (list 'call-lambda (cadr lambda-expr) + lambda-expr)))) + (and (symbolp (cadr fun)) + (or (and (setq fd (c1local-fun (cadr fun))) + (eq (car fd) 'call-local) + fd) + (list 'call-global + (make-info + :sp-change + (null (get (cadr fun) 'no-sp-change))) + (cadr fun))) + ))) + (and (eq (car fun) 'function) + (not (endp (cdr fun))) + (endp (cddr fun)) + (or (and (consp (cadr fun)) + (eq (caadr fun) 'lambda) + (not (endp (cdadr fun))) + (let ((lambda-expr (c1lambda-expr (cdadr fun)))) + (list 'call-lambda (cadr lambda-expr) lambda-expr)) + ) + (and (symbolp (cadr fun)) + (or (and (setq fd (c1local-fun (cadr fun))) + (eq (car fd) 'call-local) + fd) + (list 'call-global + (make-info + :sp-change + (null (get (cadr fun) 'no-sp-change))) + (cadr fun))) + ))))) + (let ((x (c1expr fun)) (info (make-info :sp-change t))) + (add-info info (cadr x)) + (list 'ordinary info x)) + )) + + +(defun c2funcall-aux(form &aux (info (cadr form)) + (funob (caddr form)) + (args (cadddr form)) + (loc (nth 4 form))) + (c2funcall funob args loc info)) + +(defvar *use-sfuncall* t) +(defvar *super-funcall* nil) + +(defun c2funcall (funob args &optional loc info) + + ;;; Usually, ARGS holds a list of forms, which are arguments to the + ;;; function. If, however, the arguments are already pushed on the stack, + ;;; ARGS should be set to the symbol ARGS-PUSHED. + (case (car funob) + (call-global (c2call-global (caddr funob) args loc t)) + (call-local (c2call-local (cddr funob) args)) + (call-lambda (c2call-lambda (caddr funob) args)) + (ordinary ;;; An ordinary expression. In this case, if + ;;; arguments are already pushed on the stack, then + ;;; LOC cannot be NIL. Callers of C2FUNCALL must be + ;;; responsible for maintaining this condition. + (let ((*vs* *vs*) (form (caddr funob))) + (declare (object form)) + (cond ((and (listp args) + *use-sfuncall* + ;;Determine if only one value at most is required: + (or + (member *value-to-go* '(return-object trash)) + (and (consp *value-to-go*) + (member (car *value-to-go*) '(var cvar jump-false jump-true))) + (and info (equal (info-type info) '(values t))) + )) + (c2funcall-sfun form args info) + (return-from c2funcall nil))) + (unless loc + (unless (listp args) (baboon)) + (cond ((eq (car form) 'LOCATION) (setq loc (caddr form))) + ((and (eq (car form) 'VAR) + (not (args-info-changed-vars (caaddr form) args))) + (setq loc (cons 'VAR (caddr form)))) + (t + (setq loc (list 'vs (vs-push))) + (let ((*value-to-go* loc)) (c2expr* (caddr funob)))))) + (push-args args) + (if *compiler-push-events* + (wt-nl "super_funcall(" loc ");") + (if *super-funcall* + (funcall *super-funcall* loc) + (wt-nl "super_funcall_no_event(" loc ");"))) + (unwind-exit 'fun-val))) + (otherwise (baboon)) + )) + + +(defun fcalln-inline (&rest args) + (wt-nl "({object _f=" (car args) ";enum type _t=type_of(_f);") + (wt-nl "_f = _t==t_symbol && _f->s.s_gfdef!=OBJNULL ? (_t=type_of(_f->s.s_gfdef),_f->s.s_gfdef) : _f;") + (wt-nl "_t==t_sfun ? _f->sfn.sfn_self : ") + (wt-nl "(fcall.argd= " (length (cdr args)) ",_t==t_vfun ? _f->vfn.vfn_self : ") + (wt-nl "(fcall.fun=_f,fcalln));})") + (wt-nl "(") + (when (cdr args) (wt (cadr args)) + (dolist (loc (cddr args)) (wt #\, loc))) + (wt-nl ")")) + +(defun c2call-lambda (lambda-expr args &aux (lambda-list (caddr lambda-expr))) + (declare (object lambda-list)) + (cond ((or (cadr lambda-list) ;;; Has optional? + (caddr lambda-list) ;;; Has rest? + (cadddr lambda-list) ;;; Has key? + (not (listp args)) ;;; Args already pushed? + ) + (when (listp args) ;;; Args already pushed? + (let ((*vs* *vs*) (base *vs*)) + (push-args-lispcall args) + (when (need-to-set-vs-pointers lambda-list) + (wt-nl "vs_top=(vs_base=base+" base ")+" (- *vs* base) ";") + (base-used) + ))) + (c2lambda-expr lambda-list (caddr (cddr lambda-expr))) + ) + (t + (let ((l-length (length (car lambda-list))) + (a-length (length args))) + (or (eql a-length l-length) + (cmperr "Calling lambda with ~a args not ~a" a-length + l-length))) + + (c2let (car lambda-list) args (caddr (cddr lambda-expr))))) + ) + +(defun check-fname-args (fname args) + (let ((a (get fname 'arg-types t))) + (and (eq t a) (get fname 'si::structure-access) + (setq a '(t))) + (cond ((and (listp a) + (listp args) + (not (member '* a))) + (or (eql (length a) (length args)) + (cmpwarn "Wrong number of args for ~s: ~a instead of ~a." + fname + (length args) (length a))))))) + +(defun save-avma (fd) + (when (and (not *restore-avma*) + (setq *restore-avma* + (or + (member 'integer (car fd)) + (eq (cadr fd) 'integer) + (flag-p (caddr fd) is)))) + (wt-nl "{ save_avma;") + (inc-inline-blocks) + (or (consp *inline-blocks*) + (setq *inline-blocks* (cons *inline-blocks* 'restore-avma))))) + + + + + +(defun c2call-global (fname args loc return-type &aux fd (*vs* *vs*)) +;this is now done in get-inline-info +; (and *Fast-link-compiling* (fast-link-proclaimed-type-p fname args) +; (add-fast-link fname t args)) + (if (inline-possible fname) + (cond + ;;; Tail-recursive case. + ((and (listp args) + *do-tail-recursion* + *tail-recursion-info* + (eq (car *tail-recursion-info*) fname) + (member *exit* + '(RETURN RETURN-FIXNUM RETURN-CHARACTER RETURN-SHORT-FLOAT + RETURN-LONG-FLOAT RETURN-OBJECT)) + (tail-recursion-possible) + (= (length args) (length (cdr *tail-recursion-info*)))) + (let* ((*value-to-go* 'trash) + (*exit* (next-label)) + (*unwind-exit* (cons *exit* *unwind-exit*))) + (c2psetq (mapcar #'(lambda (v) (list v nil)) + (cdr *tail-recursion-info*)) + args) + (wt-label *exit*)) + (unwind-no-exit 'tail-recursion-mark) + (wt-nl "goto TTL;") + (cmpnote "Tail-recursive call of ~s was replaced by iteration." fname)) + + ;;; Open-codable function call. + ((and (listp args) + (null loc) + (setq fd (get-inline-info fname args return-type))) + (let ((*inline-blocks* 0) + (*restore-avma* *restore-avma*)) + (save-avma fd) + (unwind-exit (get-inline-loc fd args) nil fname) + (close-inline-blocks))) + + ;;; Call to a function whose C language function name is known. + ((setq fd (or (get fname 'Lfun) (get fname 'Ufun))) + (check-fname-args fname args) + (push-args args) + (wt-h "void " fd "();") + (wt-nl fd "();") + (unwind-exit 'fun-val nil fname) + ) + + ( t; *Fast-link-compiling* + (cond ((and + (listp args) + (< (the fixnum (length args)) 10) + (or + *ifuncall* + (get fname 'ifuncall)) + (progn (if (eq *value-to-go* 'top) (format t "~%Called with top:~a" fname)) t) + (not (eq 'top *value-to-go*)) + (null loc) + ) + (let ((*inline-blocks* 0)) + (unwind-exit (get-inline-loc (inline-proc fname args) args) + nil fname) + (close-inline-blocks))) + (t + (push-args args) + (let ((num (add-fast-link fname nil args))) + (wt-nl "(void) (*Lnk" num ")(") + (if (get fname 'proclaimed-closure) (wt "Lclptr" num)) + (wt ");") + (unwind-exit 'fun-val nil fname))))) + + + ;;; Call to a function defined in the same file. + ((setq fd (assoc fname *global-funs*)) + (push-args args) + (wt-nl (c-function-name "L" (cdr fd) fname) "();") + (unwind-exit 'fun-val nil fname) + ) + ((eql fname 'funcall-c) + (wt-funcall-c args)) + + ;;; Otherwise. + (t (c2call-unknown-global fname args loc t))) + (c2call-unknown-global fname args loc nil)) + ) + + + +(defun add-fast-link (fname type args) + (let (link link-info (n (add-object2 (add-symbol fname))) vararg) + (cond (type + ;;should do some args checking in that case too. + (let* (link-string tem argtypes + (leng (and (listp args) (length args)))) + (setq argtypes + (cond ((get fname 'proclaimed-function) + (get fname 'proclaimed-arg-types)) + ((setq tem (get fname ' fixed-args)) + (cond ((si:fixnump tem) + (or (equal leng tem) + (cmpwarn "~a: Fixed args not fixed!" + fname))) + (t (setf (get fname 'fixed-args) leng))) + (make-list leng :initial-element t)))) + (and leng + (or (eql leng (length argtypes)) + (MEMBER '* ARGTYPES) + (cmpwarn "~a called with ~a args, expected ~a " + fname leng + (length argtypes)))) + (unless + (cddr (setq link-info (car (member-if (lambda (x) (and (eq fname (car x)) (stringp (cadr x)))) *function-links*)))) + (setq link-string + (with-output-to-string + (st) + (format st "(*(LnkLI~d))(" n) + (do ((com) + (v argtypes (cdr v)) + (i 0 (+ 1 i))) + ((null v)) + (cond ((eq (car v) '*) + (setq vararg t) + (princ (if (eq v argtypes) "#?" "#*") st)) + (t + (if com (princ "," st) (setq com t)) + (format st "#~a" i)))) + (princ ")" st) + ) + ) +; (print (list 'link-string link-string)) +; (format t "~{~a~#[~:;,~]~}" '(1 2 3 4)) +; 1,2,3,4 + + (if vararg (setq link + #'(lambda ( &rest l) + (wt "(VFUN_NARGS="(length l) ",") + (wt-inline-loc link-string l) + (wt ")")))) + + (push (list fname argtypes + (or (get fname 'proclaimed-return-type) + t) + (flags side-effect-p allocates-new-storage) + (or link link-string) 'link-call) + *inline-functions*) + (setq link-info (list fname (format nil "LI~d" n) + (or (get fname 'proclaimed-return-type) + t) + argtypes))))) + (t + (check-fname-args fname args) + (setq link-info (list fname n + (if (get fname 'proclaimed-closure) 'proclaimed-closure) + )))) + (pushnew link-info *function-links* :test 'equal) + n)) + +;;make a function which will be called hopefully only once, +;;and will establish the link. +(defun wt-function-link (x) + (let ((name (first x)) + (num (second x)) + (type (third x)) + (args (fourth x))) + (cond + ((null type) + (wt-nl1 "static void LnkT" + num "(){ call_or_link(VV[" num "],(void **)(void *)&Lnk" num");}")) + ((eql type 'proclaimed-closure) + (wt-nl1 "static void LnkT" num + "(ptr) object *ptr;{ call_or_link_closure(VV[" num "],(void **)(void *)&Lnk" num",(void **)(void *)&Lclptr" num");}")) + (t + ;;change later to include above. + ;;(setq type (cdr (assoc type '((t . "object")(:btpr . "bptr"))))) + (wt-nl1 "static " (declaration-type (rep-type type)) " LnkT" num ) + (cond ((or args (not (eq t type))) + (let ((vararg (member '* args))) + (wt "(object first,...){" + (declaration-type (rep-type type)) "V1;" + "va_list ap;va_start(ap,first);V1=call_" + (if vararg "v" "") "proc_new(" (vv-str (add-object name)) ",(void **)(void *)&Lnk" num) + (or vararg (wt "," (proclaimed-argd args type))) + (wt ",first,ap);va_end(ap);return V1;}" ))) + (t (wt "(){return call_proc0(" (vv-str (add-object name)) ",(void **)(void *)&Lnk" num ");}" )))) + (t (error "unknown link type ~a" type))) + (setq name (symbol-name name)) + (if (find #\/ name) (setq name (remove #\/ name))) + (wt " /* " name " */") + )) + + + +;;For funcalling when the argument is guaranteed to be a compiled-function. +;;For (funcall-c he 3 4), he being a compiled function. (not a symbol)! +(defun wt-funcall-c (args) + (let ((fun (car args)) + (real-args (cdr args)) + loc) + (cond ((eql (car fun) 'var) + (let ((fun-loc (cons (car fun) (third fun)))) + (when *safe-compile* + (wt-nl "(type_of(") + (wt-loc fun-loc) + (wt ")==t_cfun)||FEinvalid_function(") + (wt-loc fun-loc)(wt ");")) + (push-args real-args) + (wt-nl "(") + (wt-loc fun-loc))) + (t + (setq loc (list 'cvar (incf *next-cvar*))) + (let ((*value-to-go* loc)) + (wt-nl + "{object V" (second loc) ";") + (c2expr* (car args)) + (push-args (cdr args)) + (wt "(V" (second loc))))) + (wt ")->cf.cf_self ();") + (and loc (wt "}"))) + (unwind-exit 'fun-val)) + +(defun inline-proc (fname args &aux (n (length args)) res + (obj (add-object fname))) + (format t "~%Using ifuncall: ~a" fname) + (let ((result + (case n + ;(0 (list () t (flags ans set) (format nil "ifuncall0(VV[~d])" obj))) + (1 (list '(t) t (flags ans set) (format nil "ifuncall1(~a,(#0))" (vv-str obj)) + 'ifuncall)) + (2 (list '(t t) t (flags ans set) + (format nil "ifuncall2(~a,(#0),(#1))" (vv-str obj)) + 'ifuncall)) + (t + (list (make-list n :initial-element t) + t (flags ans set) + (format nil "ifuncall(~a,~a~{,#~a~})" + (vv-str obj) n + (dotimes (i n(nreverse res)) + (push i res))) + 'ifuncall))))) + (push (cons fname result ) *inline-functions*) + result + )) + + +(si:putprop 'simple-call 'wt-simple-call 'wt-loc) + +(defun wt-simple-call (cfun base n &optional (vv-index nil)) + (wt "simple_" cfun "(") + (when vv-index (wt (vv-str vv-index) ",")) + (wt "base+" base "," n ")") + (base-used)) + +;;; Functions that use SAVE-FUNOB should reset *vs*. +(defun save-funob (funob) + (case (car funob) + ((call-lambda call-quote-lambda call-local)) + (call-global + (unless (and (inline-possible (caddr funob)) + (or (get (caddr funob) 'Lfun) + (get (caddr funob) 'Ufun) + (get (caddr funob) 'proclaimed-function) + (assoc (caddr funob) *global-funs*))) + (let ((temp (list 'vs (vs-push)))) + (if *safe-compile* + (wt-nl + temp + "=symbol_function(" (vv-str (add-symbol (caddr funob))) ");") + (wt-nl temp "=" (vv-str (add-symbol (caddr funob))) "->s.s_gfdef;")) + temp))) + (ordinary (let* ((temp (list 'vs (vs-push))) + (*value-to-go* temp)) + (c2expr* (caddr funob)) + temp)) + (otherwise (baboon)) + )) + +(defun push-args (args) + (cond ((null args) (wt-nl "vs_base=vs_top;")) + ((consp args) + (let ((*vs* *vs*) (base *vs*)) + (dolist** (arg args) + (let ((*value-to-go* (list 'vs (vs-push)))) + (c2expr* arg))) + (wt-nl "vs_top=(vs_base=base+" base ")+" (- *vs* base) ";") + (base-used))))) + +(defun push-args-lispcall (args) + (dolist** (arg args) + (let ((*value-to-go* (list 'vs (vs-push)))) + (c2expr* arg)))) + +(defun c2call-unknown-global (fname args loc inline-p) + (cond (*compiler-push-events* + ;;; Want to set up the return catcher. + (unless loc + (setq loc (list 'vs (vs-push))) + (wt-nl loc "=symbol_function(" (vv-str (add-symbol fname)) ");")) + (push-args args) + (wt-nl "funcall_with_catcher(" (vv-str (add-symbol fname)) "," loc ");") + (unwind-exit 'fun-val nil fname)) + (loc + ;;; The function was already pushed. + (push-args args) + (if inline-p + (if *safe-compile* + (wt-nl "funcall_no_event(" loc ");") + (wt-nl "CMPfuncall(" loc ");")) + (wt-nl "funcall(" loc ");")) + (unwind-exit 'fun-val)) + ((args-cause-side-effect args) + ;;; Evaluation of the arguments may cause side-effect. + ;;; Arguments are not yet pushed. + (let ((base *vs*)) + (setq loc (list 'vs (vs-push))) + (if *safe-compile* + (wt-nl loc "=symbol_function(" (vv-str (add-symbol fname)) ");") + (wt-nl loc "=(" (vv-str (add-symbol fname)) "->s.s_gfdef);")) + (push-args-lispcall args) + (cond ((or (eq *value-to-go* 'return) + (eq *value-to-go* 'top)) + (wt-nl "lispcall") + (when inline-p (wt "_no_event")) + (wt "(base+" base "," (length args) ");") + (base-used) + (unwind-exit 'fun-val)) + (t (unwind-exit + (list 'SIMPLE-CALL + (if inline-p "lispcall_no_event" "lispcall") + base (length args)))))) + ) + (t + ;;; Evaluation of the arguments causes no side-effect. + ;;; Arguments are not yet pushed. + (let ((base *vs*)) + (push-args-lispcall args) + (cond ((or (eq *value-to-go* 'return) + (eq *value-to-go* 'top)) + (wt-nl "symlispcall") + (when inline-p (wt "_no_event")) + (wt "(" (vv-str (add-symbol fname)) ",base+" base "," + (length args) ");") + (base-used) + (unwind-exit 'fun-val nil fname)) + (t (unwind-exit + (list 'SIMPLE-CALL + (if inline-p "symlispcall_no_event" "symlispcall") + base (length args) (add-symbol fname)) + nil fname)))) + ))) diff --git a/cmpnew/gcl_cmpcatch.lsp b/cmpnew/gcl_cmpcatch.lsp new file mode 100755 index 0000000..b2e7769 --- /dev/null +++ b/cmpnew/gcl_cmpcatch.lsp @@ -0,0 +1,124 @@ +;;; CMPCATCH Catch, Unwind-protect, and Throw. +;;; +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +(in-package 'compiler) + +(si:putprop 'catch 'c1catch 'c1special) +(si:putprop 'catch 'c2catch 'c2) +(si:putprop 'unwind-protect 'c1unwind-protect 'c1special) +(si:putprop 'unwind-protect 'c2unwind-protect 'c2) +(si:putprop 'throw 'c1throw 'c1special) +(si:putprop 'throw 'c2throw 'c2) + +(defun c1catch (args &aux (info (make-info :sp-change t)) tag) + (incf *setjmps*) + (when (endp args) (too-few-args 'catch 1 0)) + (setq tag (c1expr (car args))) + (add-info info (cadr tag)) + (setq args (c1progn (cdr args))) + (add-info info (cadr args)) + (list 'catch info tag args)) + +(si:putprop 'push-catch-frame 'set-push-catch-frame 'set-loc) + +(defun c2catch (tag body &aux (*vs* *vs*)) + (let ((*value-to-go* '(push-catch-frame))) (c2expr* tag)) + (wt-nl "if(nlj_active)") + (wt-nl "{nlj_active=FALSE;frs_pop();") + (unwind-exit 'fun-val 'jump) + (wt "}") + (wt-nl "else{") + (let ((*unwind-exit* (cons 'frame *unwind-exit*))) + (c2expr body)) + (wt "}") + ) + +(defun set-push-catch-frame (loc) + (wt-nl "frs_push(FRS_CATCH," loc ");")) + +(defun c1unwind-protect (args &aux (info (make-info :sp-change t)) form) + (incf *setjmps*) + (when (endp args) (too-few-args 'unwind-protect 1 0)) + (setq form (let ((*blocks* (cons 'lb *blocks*)) + (*tags* (cons 'lb *tags*)) + (*vars* (cons 'lb *vars*))) + (c1expr (car args)))) + (add-info info (cadr form)) + (setq args (c1progn (cdr args))) + (add-info info (cadr args)) + (list 'unwind-protect info form args) + ) + +(defun c2unwind-protect (form body + &aux (*vs* *vs*) (loc (list 'vs (vs-push))) + top-data) + ;;; exchanged following two lines to eliminate setjmp clobbering warning + (wt-nl "frs_push(FRS_PROTECT,Cnil);") + (wt-nl "{object tag=Cnil;frame_ptr fr=NULL;object p;bool active;") + (wt-nl "if(nlj_active){tag=nlj_tag;fr=nlj_fr;active=TRUE;}") + (wt-nl "else{") + (let ((*value-to-go* 'top) + *top-data* ) + (c2expr* form) + (setq top-data *top-data*)) + (wt-nl "active=FALSE;}") + (wt-nl loc "=Cnil;") + (wt-nl "while(vs_base= (cadr x) 1)) + (setq *safe-compile* (>= (cadr x) 2)) + (setq *compiler-push-events* (>= (cadr x) 3))) + (space (setq *space* (cadr x))) + (speed (setq *speed* (cadr x))) + (compilation-speed (setq *speed* (- 3 (cadr x)))) + (t (warn "The OPTIMIZE quality ~s is unknown." (car x))))))) + (type + (if (consp (cdr decl)) + (proclaim-var (cadr decl) (cddr decl)) + (warn "The type declaration ~s is illegal." decl))) + ((fixnum character short-float long-float) + (proclaim-var (car decl) (cdr decl))) + (ftype + (cond ((and (consp (cdr decl)) + (consp (cadr decl)) + (eq (caadr decl) 'function)) + (add-function-proclamation (caddr decl) (cdr (cadr decl)) + (cddr decl))) + (t (cmpwarn "Bad function proclamation ~a" decl)))) + (function + (cond ((and (consp (cdr decl))) + (add-function-proclamation (cadr decl) (cddr decl) nil)) + (t (cmpwarn "Bad function proclamation ~a" decl)))) + (inline + (dolist** (fun (cdr decl)) + (if (symbolp fun) + (remprop fun 'cmp-notinline) + (warn "The function name ~s is not a symbol." fun)))) + (notinline + (dolist** (fun (cdr decl)) + (if (symbolp fun) + (si:putprop fun t 'cmp-notinline) + (warn "The function name ~s is not a symbol." fun)))) + ((object ignore ignorable) + (dolist** (var (cdr decl)) + (unless (symbolp var) + (warn "The variable name ~s is not a symbol." var)))) + (declaration + (dolist** (x (cdr decl)) + (if (symbolp x) + (unless (member x *alien-declarations*) + (push x *alien-declarations*)) + (warn "The declaration specifier ~s is not a symbol." x)))) + ((array atom bignum bit bit-vector character common compiled-function + complex cons double-float fixnum float 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 + dynamic-extent :dynamic-extent + string-char symbol t vector signed-byte unsigned-byte) + (proclaim-var (car decl) (cdr decl))) + (otherwise + (unless (member (car decl) *alien-declarations*) + (warn "The declaration specifier ~s is unknown." (car decl))) + (and (functionp (get (car decl) :proclaim)) + (dolist** (v (cdr decl)) + (funcall (get (car decl) :proclaim) v))) +) + ) + nil + ) + +(defun proclaim-var (type vl) + (setq type (type-filter type)) + (dolist** (var vl) + (cond ((symbolp var) + (let ((type1 (get var 'cmp-type)) + (v (sch-global var))) + (setq type1 (if type1 (type-and type1 type) type)) + (when v (setq type1 (type-and type1 (var-type v)))) + (when (null type1) (warn + "Inconsistent type declaration was found for the variable ~s." + var)) + (si:putprop var type1 'cmp-type) + (when v (setf (var-type v) type1)))) + (t + (warn "The variable name ~s is not a symbol." var))))) + +(defun c1body (body doc-p &aux (ss nil) (is nil) (ts nil) (others nil) + doc form) + (loop + (when (endp body) (return)) + (setq form (cmp-macroexpand (car body))) + (when (and (consp form) (eq (car form) 'load-time-value)) + (setq form (cmp-eval form))) + (cond + ((stringp form) + (when (or (null doc-p) (endp (cdr body)) doc) (return)) + (setq doc form)) + ((and (consp form) (eq (car form) 'declare)) + (dolist** (decl (cdr form)) +;;; Add support for 'cons' declarations, such as (declare ((vector t) foo)) +;;; 20040320 CM + (cmpck (not (consp decl)) + "The declaration ~s is illegal." decl) + (let* ((dtype (car decl))) +;; Can process user deftypes here in the future -- 20040318 CM +;; (dft (and (symbolp dtype) (get dtype 'si::deftype-definition))) +;; (dtype (or (and dft (funcall dft)) dtype))) + (if (consp dtype) + (let ((stype (car dtype))) + (cmpck (or (not (symbolp stype)) (cdddr dtype)) "The declaration ~s is illegal." decl) + (case stype + (satisfies + (push decl others)) + (otherwise + (dolist** (var (cdr decl)) + (cmpck (not (symbolp var)) + "The type declaration ~s contains a non-symbol ~s." + decl var) + (push (cons var dtype) ts))))) + (let ((stype dtype)) + (cmpck (not (symbolp stype)) "The declaration ~s is illegal." decl) + (case stype + (special + (dolist** (var (cdr decl)) + (cmpck (not (symbolp var)) + "The special declaration ~s contains a non-symbol ~s." + decl var) + (push var ss))) + ((ignore ignorable) + (dolist** (var (cdr decl)) + (cmpck (not (symbolp var)) + "The ignore declaration ~s contains a non-symbol ~s." + decl var) + (when (eq stype 'ignorable) + (push 'ignorable is)) + (push var is))) + (type + (cmpck (endp (cdr decl)) + "The type declaration ~s is illegal." decl) + (let ((type (type-filter (cadr decl)))) + (when type + (dolist** (var (cddr decl)) + (cmpck (not (symbolp var)) + "The type declaration ~s contains a non-symbol ~s." + decl var) + (push (cons var type) ts))))) + (object + (dolist** (var (cdr decl)) + (cmpck (not (symbolp var)) + "The object declaration ~s contains a non-symbol ~s." + decl var) + (push (cons var 'object) ts))) + (:register + (dolist** (var (cdr decl)) + (cmpck (not (symbolp var)) + "The register declaration ~s contains a non-symbol ~s." + decl var) + (push (cons var 'register) ts) + )) + ((:dynamic-extent dynamic-extent) + (dolist (var (cdr decl)) + (cmpck (not (symbolp var)) "The type declaration ~s contains a non-symbol ~s." + decl var) + (push (cons var :dynamic-extent) ts))) + ((fixnum character double-float short-float array atom bignum bit + bit-vector common compiled-function complex cons float hash-table + integer keyword list long-float nil null number package pathname + random-state ratio rational readtable sequence simple-array + simple-bit-vector simple-string simple-base-string simple-vector single-float + standard-char stream string string-char symbol t vector + signed-byte unsigned-byte) + (let ((type (type-filter stype))) + (when type + (dolist** (var (cdr decl)) + (cmpck (not (symbolp var)) + "The type declaration ~s contains a non-symbol ~s." + decl var) + (push (cons var type) ts))))) + (otherwise + (push decl others)))))))) + (t (return))) + (pop body) + ) + (values body ss ts is others doc) + ) + +(defun c1decl-body (decls body &aux (dl nil)) + (if (null decls) + (c1progn body) + (let ((*function-declarations* *function-declarations*) + (*alien-declarations* *alien-declarations*) + (*notinline* *notinline*) + (*space* *space*) + (*safe-compile* *safe-compile*)) + (dolist** (decl decls dl) + (case (car decl) + (optimize + (dolist (x (cdr decl)) + (when (symbolp x) (setq x (list x 3))) + (if (or (not (consp x)) + (not (consp (cdr x))) + (not (numberp (cadr x))) + (not (<= 0 (cadr x) 3))) + (warn "The OPTIMIZE proclamation ~s is illegal." x) + (case (car x) + (safety + (setq *safe-compile* + (>= (the fixnum (cadr x)) 2)) + (push (list 'safety (cadr x)) dl)) + (space (setq *space* (cadr x)) + (push (list 'space (cadr x)) dl)) + ((speed compilation-speed)) + (t (warn "The OPTIMIZE quality ~s is unknown." + (car x))))))) + (ftype + (if (or (endp (cdr decl)) + (not (consp (cadr decl))) + (not (eq (caadr decl) 'function)) + (endp (cdadr decl))) + (warn "The function declaration ~s is illegal." decl) + (dolist** (fname (cddr decl)) + (add-function-declaration + fname (cadadr decl) (cddadr decl))))) + (function + (if (or (endp (cdr decl)) + (endp (cddr decl)) + (not (symbolp (cadr decl)))) + (warn "The function declaration ~s is illegal." decl) + (add-function-declaration + (cadr decl) (caddr decl) (cdddr decl)))) + (inline + (dolist** (fun (cdr decl)) + (if (symbolp fun) + (progn (push (list 'inline fun) dl) + (setq *notinline* (remove fun *notinline*))) + (warn "The function name ~s is not a symbol." fun)))) + (notinline + (dolist** (fun (cdr decl)) + (if (symbolp fun) + (progn (push (list 'notinline fun) dl) + (push fun *notinline*)) + (warn "The function name ~s is not a symbol." fun)))) + (declaration + (dolist** (x (cdr decl)) + (if (symbolp x) + (unless (member x *alien-declarations*) + (push x *alien-declarations*)) + (warn "The declaration specifier ~s is not a symbol." + x)))) + (otherwise + (unless (member (car decl) *alien-declarations*) + (warn "The declaration specifier ~s is unknown." + (car decl)))) + )) + (setq body (c1progn body)) + (list 'decl-body (cadr body) dl body) + ) + ) + ) + +(si:putprop 'decl-body 'c2decl-body 'c2) + +(defun c2decl-body (decls body) + (let ((*compiler-check-args* *compiler-check-args*) + (*safe-compile* *safe-compile*) + (*compiler-push-events* *compiler-push-events*) + (*notinline* *notinline*) + (*space* *space*) + ) + (dolist** (decl decls) + (case (car decl) + (safety + (let ((level (cadr decl))) + (declare (fixnum level)) + (setq *compiler-check-args* (>= level 1) + *safe-compile* (>= level 2) + *compiler-push-events* (>= level 3)))) + (space (setq *space* (cadr decl))) + (notinline (push (cadr decl) *notinline*)) + (inline + (setq *notinline* (remove (cadr decl) *notinline*))) + (otherwise (baboon)))) + (c2expr body)) + ) + +(defun check-vdecl (vnames ts is) + (dolist** (x ts) + (unless (member (car x) vnames) + (cmpwarn "Type declaration was found for not bound variable ~s." + (car x)))) + (dolist** (x is) + (unless (or (eq x 'ignorable) (member x vnames)) + (cmpwarn "Ignore/ignorable declaration was found for not bound variable ~s." x))) + ) + +(defun proclamation (decl) + (case (car decl) + (special + (dolist** (var (cdr decl) t) + (if (symbolp var) + (unless (si:specialp var) (return nil)) + (warn "The variable name ~s is not a symbol." var)))) + (optimize + (dolist (x (cdr decl) t) + (when (symbolp x) (setq x (list x 3))) + (if (or (not (consp x)) + (not (consp (cdr x))) + (not (numberp (cadr x))) + (not (<= 0 (cadr x) 3))) + (warn "The OPTIMIZE proclamation ~s is illegal." x) + (case (car x) + (safety + (unless (= (cadr x) + (cond ((null *compiler-check-args*) 0) + ((null *safe-compile*) 1) + ((null *compiler-push-events*) 2) + (t 3))) + (return nil))) + (space (unless (= (cadr x) *space*) (return nil))) + (speed (unless (= (cadr x) *speed*) (return nil))) + (compilation-speed + (unless (= (- 3 (cadr x)) *speed*) (return nil))) + (t (warn "The OPTIMIZE quality ~s is unknown." + (car x))))))) + (type + (if (consp (cdr decl)) + (let ((type (type-filter (cadr decl))) + x) + (dolist** (var (cddr decl) t) + (if (symbolp var) + (unless (and (setq x (get var 'cmp-type)) + (equal x type)) + (return nil)) + (warn "The variable name ~s is not a symbol." var)))) + (warn "The type declaration ~s is illegal." decl))) + ((fixnum character short-float long-float) + (let ((type (type-filter (car decl))) + x) + (dolist** (var (cdr decl) t) + (if (symbolp var) + (unless (and (setq x (get var 'cmp-type)) (equal x type)) + (return nil)) + (warn "The variable name ~s is not a symbol." var))))) + (ftype + (if (or (endp (cdr decl)) + (not (consp (cadr decl))) + (not (eq (caadr decl) 'function)) + (endp (cdadr decl))) + (warn "The function declaration ~s is illegal." decl) + (dolist** (fname (cddr decl) t) + (unless (and (get fname 'proclaimed-function) + (equal (function-arg-types (cadadr decl)) + (get fname 'proclaimed-arg-types)) + (equal (function-return-type (cddadr decl)) + (get fname 'proclaimed-return-type))) + (return nil))))) + (function + (if (or (endp (cdr decl)) (endp (cddr decl))) + (warn "The function declaration ~s is illegal." decl) + (and (get (cadr decl) 'proclaimed-function) + (equal (function-arg-types (caddr decl)) + (get (cadr decl) 'proclaimed-arg-types)) + (equal (function-return-type (cdddr decl)) + (get (cadr decl) 'proclaimed-return-type))))) + (inline (dolist** (fun (cdr decl) t) + (if (symbolp fun) + (when (get fun 'cmp-notinline) (return nil)) + (warn "The function name ~s is not a symbol." fun)))) + (notinline (dolist** (fun (cdr decl) t) + (if (symbolp fun) + (unless (get fun 'cmp-notinline) (return nil)) + (warn "The function name ~s is not a symbol." fun)))) + ((object ignore ignorable) + (dolist** (var (cdr decl) t) + (unless (symbolp var) + (warn "The variable name ~s is not a symbol." var)))) + (declaration (dolist** (x (cdr decl) t) + (if (symbolp x) + (unless (member x *alien-declarations*) (return nil)) + (warn "The declaration specifier ~s is not a symbol." + x)))) + ((array atom bignum bit bit-vector character common compiled-function + complex cons double-float fixnum float 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 + dynamic-extent :dynamic-extent + string-char symbol t vector signed-byte unsigned-byte) + (let ((type (type-filter (car decl)))) + (dolist** (var (cdr decl) t) + (if (symbolp var) + (unless (equal (get var 'cmp-type) type) (return nil)) + (warn "The variable name ~s is not a symbol." var))))) + (otherwise + (unless (member (car decl) *alien-declarations*) + (warn "The declaration specifier ~s is unknown." (car decl)))) + ) + ) + diff --git a/cmpnew/gcl_cmpeval.lsp b/cmpnew/gcl_cmpeval.lsp new file mode 100755 index 0000000..bfefe92 --- /dev/null +++ b/cmpnew/gcl_cmpeval.lsp @@ -0,0 +1,679 @@ +;;; CMPEVAL The Expression Dispatcher. +;;; +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + + + +(export '(si::define-compiler-macro + si::undef-compiler-macro + si::define-inline-function) 'system) + +(in-package 'compiler) + +(si:putprop 'progn 'c1progn 'c1special) +(si:putprop 'progn 'c2progn 'c2) + +(si:putprop 'si:structure-ref 'c1structure-ref 'c1) +(si:putprop 'structure-ref 'c2structure-ref 'c2) +(si:putprop 'structure-ref 'wt-structure-ref 'wt-loc) +(si:putprop 'si:structure-set 'c1structure-set 'c1) +(si:putprop 'structure-set 'c2structure-set 'c2) + +(defun c1expr* (form info) + (setq form (c1expr form)) + (add-info info (cadr form)) + form) + +(defun c1expr (form) + (setq form (catch *cmperr-tag* + (cond ((symbolp form) + (cond ((eq form nil) (c1nil)) + ((eq form t) (c1t)) + ((keywordp form) + (list 'LOCATION (make-info :type (object-type form)) + (list 'VV (add-object form)))) + ((constantp form) + (let ((val (symbol-value form))) + (or (c1constant-value val nil) + (list 'LOCATION (make-info :type (object-type val)) + (list 'VV (add-constant form)))))) + (t (c1var form)))) + ((consp form) + (let ((fun (car form))) + (cond ((symbolp fun) + (c1symbol-fun fun (cdr form))) + ((and (consp fun) (eq (car fun) 'lambda)) + (c1lambda-fun (cdr fun) (cdr form))) + ((and (consp fun) (eq (car fun) 'si:|#,|)) + (cmperr "Sharp-comma-macro was found in a bad place.")) + (t (cmperr "The function ~s is illegal." fun))))) + (t (c1constant-value form t))))) + (if (eq form '*cmperr-tag*) (c1nil) form)) + +(si::putprop 'si:|#,| 'c1sharp-comma 'c1special) +(si::putprop 'load-time-value 'c1load-time-value 'c1special) + +(defun c1sharp-comma (arg) + (c1constant-value (cons 'si:|#,| arg) t)) + +(defun c1load-time-value (arg) + (c1constant-value + (cons 'si:|#,| + (if *compiler-compile* + (let ((x (cmp-eval (car arg)))) + (if (and (cdr arg) (cadr arg)) + x + `(si::nani ,(si::address x)))) + (car arg))) + t)) + +(si::putprop 'si::define-structure 'c1define-structure 't1) + +(defun c1define-structure (arg &aux *sharp-commas*) + (declare (special *sharp-commas*)) + (eval (cons 'si::define-structure arg)) + (c1constant-value (cons 'si:|#,| (cons 'si::define-structure arg)) t) + (add-load-time-sharp-comma) + nil) + +(defvar *c1nil* (list 'LOCATION (make-info :type (object-type nil)) nil)) +(defun c1nil () *c1nil*) +(defvar *c1t* (list 'LOCATION (make-info :type (object-type t)) t)) +(defun c1t () *c1t*) + + +(defun flags-pos (flag &aux (i 0)) + (declare (fixnum i)) + (dolist + (v + '((allocates-new-storage ans); might invoke gbc + (side-effect-p set) ; no effect on arguments + (constantp) ; always returns same result, + ;double eval ok. + (result-type-from-args rfa); if passed args of matching + ;type result is of result type + (is))) ;; extends the `integer stack'. + (cond ((member flag v :test 'eq) + (return-from flags-pos i))) + (setq i (+ i 1))) + (error "unknown opt flag")) + +(defmacro flag-p (n flag) + `(logbitp ,(flags-pos flag) ,n)) + +;; old style opts had '(args ret new-storage side-effect string) +;; these new-storage and side-effect have been combined into +;; one integer, along with several other flags. + +(defun fix-opt (opt) + (let ((a (cddr opt))) + (unless (typep (car a ) 'fixnum) + (if *compiler-in-use* + (cmpwarn "Obsolete optimization: use fix-opt ~s" opt)) + + (setf (cddr opt) + (cons (logior (if (car a) 2 0) + (if (cadr a) 1 0)) + (cddr a)))) + opt)) + +;; some hacks for revising a list of optimizers. +#+revise +(progn +(defun output-opt (opt sym flag) + (fix-opt opt) + (format t "(push '(~(~s ~s #.(flags~)" (car opt) (second opt)) + (let ((o (third opt))) + (if (flag-p o set) (princ " set")) + (if (flag-p o ans) (princ " ans")) + (if (flag-p o rfa) (princ " rfa")) + (if (flag-p o constantp) (princ "constantp "))) + (format t ")") + (if (and (stringp (nth 3 opt)) + (> (length (nth 3 opt)) 40)) + (format t "~% ")) + (prin1 (nth 3 opt)) + (format t ")~% ~((get '~s '~s)~))~%" sym flag)) + +(defun output-all-opts (&aux lis did) + (sloop::sloop + for v in ;(list (find-package "LISP")) + (list-all-packages) + do + (setq lis + (sloop::sloop + for sym in-package (package-name v) + when (or (get sym 'inline-always) + (get sym 'inline-safe) + (get sym 'inline-unsafe)) + collect sym)) + (setq lis (sort lis #'(lambda (x y) (string-lessp (symbol-name x) + (symbol-name y))))) + do + (sloop::sloop for sym in lis do + (format t "~%;;~s~% " sym) + (sloop::sloop for u in '(inline-always inline-safe inline-unsafe) + do (sloop::sloop + for w in (nreverse (remove-duplicates + (copy-list (get sym u)) + :test 'equal)) + do (output-opt w sym u)))))) + +) + + +(defun result-type-from-args(f args &aux tem) + (when (and (setq tem (get f 'return-type)) + (not (eq tem '*)) + (not (consp tem))) + (dolist (v '(inline-always inline-unsafe)) + (dolist (w (get f v)) + (fix-opt w) + (when (and + (flag-p (third w) result-type-from-args) + (eql (length args) (length (car w))) + (do ((a args (cdr a)) + (b (car w) (cdr b))) + ((null a) t) + (unless (or (eq (car a) (car b)) + (type>= (car b)(car a) )) + (return nil)))) + (return-from result-type-from-args (second w))))))) + + +;; omitting a flag means it is set to nil. +(defmacro flags (&rest lis &aux (i 0)) + (dolist (v lis) + (setq i (logior i (ash 1 (flags-pos v))))) + i) + +;; Usage: +; (flagp-p (caddr ii) side-effect-p) +; (push '((integer integer) integer #.(flags const raf) "addii(#0,#1)") +; (get '+ 'inline-always)) + + + +(defun c1symbol-fun (fname args &aux fd) + (cond ((setq fd (get fname 'c1special)) (funcall fd args)) + ((and (setq fd (get fname 'co1special)) + (funcall fd fname args))) + ((setq fd (c1local-fun fname)) + (if (eq (car fd) 'call-local) + ;; c1local-fun now adds fun-info into (cadr fd), so we need no longer + ;; do it explicitly here. CM 20031030 + (let* ((info (add-info (make-info :sp-change t) (cadr fd))) + (forms (c1args args info))) + (let ((return-type (get-local-return-type (caddr fd)))) + (when return-type (setf (info-type info) return-type))) + (let ((arg-types (get-local-arg-types (caddr fd)))) + ;;; 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)) + fl) + (pop arg-types) + (pop args)))) + (setq forms (nreverse fl))))) + (list 'call-local info (cddr fd) forms)) + (c1expr (cmp-expand-macro fd fname args)))) + ((and (setq fd (get fname 'co1)) + (inline-possible fname) + (funcall fd fname args))) + ((and (setq fd (get fname 'c1)) (inline-possible fname)) + (funcall fd args)) + ((and (setq fd (get fname 'c1conditional)) + (inline-possible fname) + (funcall (car fd) args)) + (funcall (cdr fd) args)) + ;; record the call info if we get to here + ((progn + (and (eq (symbol-package fname) (symbol-package 'and)) + (not (fboundp fname)) + (cmpwarn "~A (in lisp package) is called as a function--not yet defined" + fname)) + (and *record-call-info* (record-call-info 'record-call-info + fname)) + nil)) + ;;continue + ((setq fd (macro-function fname)) + (c1expr (cmp-expand-macro fd fname args))) + ((setq fd (get fname 'compiler-macro)) + (c1expr (cmp-eval `(funcall ',fd ',(cons fname args) nil)))) + ((and (setq fd (get fname 'si::structure-access)) + (inline-possible fname) + ;;; Structure hack. + (consp fd) + (si:fixnump (cdr fd)) + (not (endp args)) + (endp (cdr args))) + (case (car fd) + (vector (c1expr `(elt ,(car args) ,(cdr fd)))) + (list (c1expr `(si:list-nth ,(cdr fd) ,(car args)))) + (t (c1structure-ref1 (car args) (car fd) (cdr fd))) + ) + ) + ((eq fname 'si:|#,|) + (cmperr "Sharp-comma-macro was found in a bad place.")) + (t (let* ((info (make-info + :sp-change (null (get fname 'no-sp-change)))) + (forms (c1args args info))) ;; info updated by args here + (let ((return-type (get-return-type fname))) + (when return-type + (if (equal return-type '(*)) + (setf return-type nil) + (setf (info-type info) return-type)))) + (let ((arg-types (get-arg-types fname))) + ;;; Add type information to the arguments. + (when arg-types + (do ((fl forms (cdr fl)) + (fl1 nil) + (al args (cdr al))) + ((endp fl) + (setq forms (nreverse fl1))) + (cond ((endp arg-types) (push (car fl) fl1)) + (t (push (and-form-type (car arg-types) + (car fl) + (car al)) + fl1) + (pop arg-types)))))) + (let ((arg-types (get fname 'arg-types))) + ;;; Check argument types. + (when arg-types + (do ((fl forms (cdr fl)) + (al args (cdr al))) + ((or (endp arg-types) (endp fl))) + (check-form-type (car arg-types) + (car fl) (car al)) + (pop arg-types)))) + (case fname + (aref + (let ((etype (info-type (cadar forms)))) + (when (or (and (eq etype 'string) + (setq etype 'character)) + (and (consp etype) + (or (eq (car etype) 'array) + (eq (car etype) 'vector)) + (setq etype (cadr etype)))) + (setq etype + (type-and (info-type info) etype)) + (when (null etype) + (cmpwarn + "Type mismatch was found in ~s." + (cons fname args))) + (setf (info-type info) etype)))) + (si:aset + (let ((etype (info-type (cadar forms)))) + (when (or (and (eq etype 'string) + (setq etype 'character)) + (and (consp etype) + (or (eq (car etype) 'array) + (eq (car etype) 'vector)) + (setq etype (cadr etype)))) + (setq etype + (type-and (info-type info) + (type-and (info-type + (cadar (last forms))) + etype))) + (when (null etype) + (cmpwarn + "Type mismatch was found in ~s." + (cons fname args))) + (setf (info-type info) etype) + (setf (info-type (cadar (last forms))) + etype) + )))) + ;; some functions can have result type deduced from + ;; arg types. + + (let ((tem (result-type-from-args fname + (mapcar #'(lambda (x) (info-type (cadr x))) + forms)))) + (when tem + (setq tem (type-and tem (info-type info))) + (setf (info-type info) tem))) + (list 'call-global info fname forms))) + ) + ) + +;;numbers and character constants may be sometimes used, instead +;;of the variable, eg inside eql + +(defun replace-constant (lis &aux found tem) + (do ((v lis (cdr v))) + ((null v) found) + (cond ((and (constantp (car v)) + (or (numberp (setq tem(eval (car v)))) + (characterp tem))) + (setq found t) (setf (car v) tem))))) + + + +(defun c1lambda-fun (lambda-expr args &aux (info (make-info :sp-change t))) + (setq args (c1args args info)) + (setq lambda-expr (c1lambda-expr lambda-expr)) + (add-info info (cadr lambda-expr)) + (list 'call-lambda info lambda-expr args) + ) + +(defun c2expr (form) + (if (eq (car form) 'call-global) + (c2call-global (caddr form) (cadddr form) nil (info-type (cadr form))) + (if (or (eq (car form) 'let) + (eq (car form) 'let*)) + (let ((*volatile* (volatile (cadr form)))) + (declare (special *volatile*)) + (apply (get (car form) 'c2) (cddr form))) + (let ((tem (get (car form) 'c2))) + (cond (tem (apply tem (cddr form))) + ((setq tem (get (car form) 'wholec2)) + (funcall tem form)) + (t (baboon))))))) + +(defun c2funcall-sfun (fn args info &aux locs (all (cons fn args))) info + (let ((*inline-blocks* 0)) + (setq locs (get-inline-loc + (list (make-list (length all) :initial-element t) + t #.(flags ans set) 'fcalln-inline) all)) + (unwind-exit locs) + (close-inline-blocks))) + +(defun c2expr* (form) + (let* ((*exit* (next-label)) + (*unwind-exit* (cons *exit* *unwind-exit*))) + (c2expr form) + (wt-label *exit*)) + ) + +(defun c2expr-top (form top &aux (*vs* 0) (*max-vs* 0) (*level* (1+ *level*)) + (*reservation-cmacro* (next-cmacro))) + (wt-nl "{register object *base" (1- *level*) "=base;") + (base-used) + (wt-nl "{register object *base=V" top ";") + (wt-nl "register object *sup=vs_base+VM" *reservation-cmacro* ";") + ;;; Dummy assignments for lint + (wt-nl "base" (1- *level*) "[0]=base" (1- *level*) "[0];") + (wt-nl "base[0]=base[0];") + (if *safe-compile* + (wt-nl "vs_reserve(VM" *reservation-cmacro* ");") + (wt-nl "vs_check;")) + (wt-nl) (reset-top) + (c2expr form) + (push (cons *reservation-cmacro* *max-vs*) *reservations*) + (wt-nl "}}") + ) + +(defun c2expr-top* (form top) + (let* ((*exit* (next-label)) + (*unwind-exit* (cons *exit* *unwind-exit*))) + (c2expr-top form top) + (wt-label *exit*))) + +(defun c1progn (forms &aux (fl nil)) + (cond ((endp forms) (c1nil)) + ((endp (cdr forms)) (c1expr (car forms))) + (t (let ((info (make-info))) + (dolist (form forms) + (setq form (c1expr form)) + (push form fl) + (add-info info (cadr form))) + (setf (info-type info) (info-type (cadar fl))) + (list 'progn info (nreverse fl)) + ))) + ) + +;;; Should be deleted. +(defun c1progn* (forms info) + (setq forms (c1progn forms)) + (add-info info (cadr forms)) + forms) + +(defun c2progn (forms) + ;;; The length of forms may not be less than 1. + (do ((l forms (cdr l))) + ((endp (cdr l)) + (c2expr (car l))) + (declare (object l)) + (let* ((*value-to-go* 'trash) + (*exit* (next-label)) + (*unwind-exit* (cons *exit* *unwind-exit*))) + (c2expr (car l)) + (wt-label *exit*) + )) + ) + +(defun c1args (forms info) + (mapcar #'(lambda (form) (c1expr* form info)) forms)) + +;;; Structures + +(defun c1structure-ref (args) + (if (and (not *safe-compile*) + (not (endp args)) + (not (endp (cdr args))) + (consp (cadr args)) + (eq (caadr args) 'quote) + (not (endp (cdadr args))) + (symbolp (cadadr args)) + (endp (cddadr args)) + (not (endp (cddr args))) + (si:fixnump (caddr args)) + (endp (cdddr args))) + (c1structure-ref1 (car args) (cadadr args) (caddr args)) + (let ((info (make-info))) + (list 'call-global info 'si:structure-ref (c1args args info))))) + +(defun c1structure-ref1 (form name index &aux (info (make-info))) + ;;; Explicitly called from c1expr and c1structure-ref. + (declare (special *aet-types*)) + (cond (*safe-compile* (c1expr `(si::structure-ref ,form ',name ,index))) + (t + (let* ((sd (get name 'si::s-data)) + (aet-type (aref (si::s-data-raw sd) index)) + ) + (setf (info-type info) (type-filter (aref *aet-types* aet-type))) + (list 'structure-ref info + (c1expr* form info) + (add-symbol name) + index sd) + + )))) + +(defun coerce-loc-structure-ref (arg type-wanted &aux (form (cdr arg))) + (let* ((sd (fourth form)) + (index (caddr form))) + (cond (sd + (let* ((aet-type (aref (si::s-data-raw sd) index)) + (type (aref *aet-types* aet-type))) + (cond ((eq (inline-type (type-filter type)) 'inline) + (or (eql aet-type 0) (error "bad type ~a" type)))) + (setf (info-type (car arg)) (type-filter type)) + (coerce-loc + (list (inline-type + (type-filter type)) + (flags) + 'my-call + (list + (car + (inline-args (list (car form)) + '(t))) + 'joe index sd)) + (type-filter type-wanted))) + ) + (t (wfs-error))))) + + +(defun c2structure-ref (form name-vv index sd + &aux (*vs* *vs*) (*inline-blocks* 0)) + (let ((loc (car (inline-args (list form) '(t)))) + (type (aref *aet-types* (aref (si::s-data-raw sd) index)))) + (unwind-exit + (list (inline-type (type-filter type)) + (flags) 'my-call + (list loc name-vv + index sd)))) + (close-inline-blocks) + ) + + +(defun my-call (loc name-vv ind sd) name-vv + (let* ((raw (si::s-data-raw sd)) + (spos (si::s-data-slot-position sd))) + (if *safe-compile* (wfs-error) + (wt "STREF(" (aet-c-type (aref *aet-types* (aref raw ind)) ) + "," loc "," (aref spos ind) ")")))) + + +(defun c1structure-set (args &aux (info (make-info))) + (if (and (not (endp args)) (not *safe-compile*) + (not (endp (cdr args))) + (consp (cadr args)) + (eq (caadr args) 'quote) + (not (endp (cdadr args))) + (symbolp (cadadr args)) + (endp (cddadr args)) + (not (endp (cddr args))) + (si:fixnump (caddr args)) + (not (endp (cdddr args))) + (endp (cddddr args))) + (let ((x (c1expr (car args))) + (y (c1expr (cadddr args)))) + (add-info info (cadr x)) + (add-info info (cadr y)) + (setf (info-type info) (info-type (cadr y))) + (list 'structure-set info x + (add-symbol (cadadr args)) ;;; remove QUOTE. + (caddr args) y (get (cadadr args) 'si::s-data))) + (list 'call-global info 'si:structure-set (c1args args info)))) + + +;; The following (side-effects) exists for putting at the end of an +;; argument list to force all previous arguments to be stored in +;; variables, when computing inline-args. + + +(push '(() t #.(flags ans set) "Ct") (get 'side-effects 'inline-always)) + +(defun c2structure-set (x name-vv ind y sd + &aux locs (*vs* *vs*) (*inline-blocks* 0)) + name-vv + (let* ((raw (si::s-data-raw sd)) + (type (aref *aet-types* (aref raw ind))) + (spos (si::s-data-slot-position sd)) + (tftype (type-filter type)) + ix iy) + + (setq locs (inline-args + (list x y (list 'call-global (make-info) 'side-effects nil)) + (if (eq type t) '(t t t) + `(t ,tftype t)))) + + (setq ix (car locs)) + (setq iy (cadr locs)) + (if *safe-compile* (wfs-error)) + (wt-nl "STSET(" (aet-c-type type )"," + ix "," (aref spos ind) ", " iy ");") + (unwind-exit (list (inline-type tftype) (flags) 'wt-loc (list iy))) + (close-inline-blocks) + )) + +(defun c1constant-value (val always-p) + (cond + ((eq val nil) (c1nil)) + ((eq val t) (c1t)) + ((when (si:fixnump val) (< most-negative-fixnum val)) + (list 'LOCATION (make-info :type 'fixnum) + (list 'FIXNUM-VALUE (and (>= (abs val) 1024)(add-object val)) + val))) + ((characterp val) + (list 'LOCATION (make-info :type 'character) + (list 'CHARACTER-VALUE (add-object val) (char-code val)))) + ((typep val 'long-float) + ;; We can't read in long-floats which are too big: + (let* (sc (vv (cond ((> (abs val) (/ most-positive-long-float 2)) + (add-object `(si::|#,| * ,(/ val most-positive-long-float) most-positive-long-float))) + ((< (abs val) (* least-positive-normalized-long-float 2.0)) + (add-object `(si::|#,| * ,(/ val least-positive-normalized-long-float) least-positive-normalized-long-float))) + ((setq sc t) (add-object val))))) + `(location ,(make-info :type 'long-float) + ,(if sc (list 'LONG-FLOAT-VALUE vv val) (list 'vv vv))))) + ((typep val 'short-float) + (list 'LOCATION (make-info :type 'short-float) + (list 'SHORT-FLOAT-VALUE (add-object val) val))) + ((and *compiler-compile* (not *keep-gaz*)) + (list 'LOCATION (make-info :type (object-type val)) + (list 'VV (add-object (cons 'si::|#,| `(si::nani ,(si::address val))))))) + (always-p + (list 'LOCATION (make-info :type (object-type val)) + (list 'VV (add-object val)))) + (t nil))) + +(defmacro si::define-compiler-macro (name vl &rest body) + `(progn (si:putprop ',name + (caddr (si:defmacro* ',name ',vl ',body)) + 'compiler-macro) + ',name)) + +(defun si::undef-compiler-macro (name) + (remprop name 'compiler-macro)) + +(defvar *compiler-temps* + '(tmp0 tmp1 tmp2 tmp3 tmp4 tmp5 tmp6 tmp7 tmp8 tmp9)) + +(defmacro si:define-inline-function (name vars &body body) + (let ((temps nil) + (*compiler-temps* *compiler-temps*)) + (dolist (var vars) + (if (and (symbolp var) + (not (si:memq var '(&optional &rest &key &aux)))) + (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)))) + `(progn + (defun ,name ,vars ,@body) + (si:define-compiler-macro ,name ,temps + (list* 'let ,binding ',body)))))) + +(defun name-to-sd (x &aux sd) + (or (and (symbolp x) (setq sd (get x 'si::s-data))) + (error "The structure ~a is undefined." x)) + sd) + +;; lay down code for a load time eval constant. +(defun name-sd1 (x) + (or (get x 'name-to-sd) + (setf (get x 'name-sd) + `(si::|#,| name-to-sd ',x)))) + +(defun co1structure-predicate (f args &aux tem) + (cond ((and (symbolp f) + (setq tem (get f 'si::struct-predicate))) + (c1expr `(typep ,(car args) ',tem))))) + + diff --git a/cmpnew/gcl_cmpflet.lsp b/cmpnew/gcl_cmpflet.lsp new file mode 100755 index 0000000..e9fc44f --- /dev/null +++ b/cmpnew/gcl_cmpflet.lsp @@ -0,0 +1,405 @@ +;;; CMPFLET Flet, Labels, and Macrolet. +;;; +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +(in-package 'compiler) + +(si:putprop 'flet 'c1flet 'c1special) +(si:putprop 'flet 'c2flet 'c2) +(si:putprop 'labels 'c1labels 'c1special) +(si:putprop 'labels 'c2labels 'c2) +(si:putprop 'macrolet 'c1macrolet 'c1special) +;;; c2macrolet is not defined, because MACROLET is replaced by PROGN +;;; during Pass 1. +(si:putprop 'call-local 'c2call-local 'c2) + +(defstruct fun + name ;;; Function name. + ref ;;; Referenced or not. + ;;; 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. + ;;; During Pass2, the vs-address for the + ;;; function closure, or NIL. + cfun ;;; The cfun for the function. + level ;;; The level of the function. + + info ;;; fun-info; CM, 20031008 + ;;; collect info structure when processing + ;;; function lambda list in flet and labels + ;;; and pass upwards to call-local and call-global + ;;; to determine more accurately when + ;;; args-info-changed-vars should prevent certain + ;;; inlining + ;;; examples: (defun foo (a) (flet ((%f8 nil (setq a 0))) + ;;; (let ((v9 a)) (- (%f8) v9)))) + ;;; (defun foo (a) (flet ((%f8 nil (setq a 2))) + ;;; (* a (%f8)))) + ) + +(defvar *funs* nil) + +;;; During Pass 1, *funs* holds a list of fun objects, local macro definitions +;;; and the symbol 'CB' (Closure Boundary). 'CB' will be pushed on *funs* +;;; when the compiler begins to process a closure. A local macro definition +;;; is a list ( macro-name expansion-function). + +(defun c1flet (args &aux body ss ts is other-decl info + (defs1 nil) (local-funs nil) (closures nil) (*info* (copy-info *info*))) + (when (endp args) (too-few-args 'flet 1 0)) + + (let ((*funs* *funs*)) + (dolist** (def (car args)) + (cmpck (or (endp def) + (not (symbolp (car def))) + (endp (cdr def))) + "The function definition ~s is illegal." def) + (let ((fun (make-fun :name (car def) :ref nil :ref-ccb nil :info (make-info :sp-change t)))) + (push fun *funs*) + (push (list fun (cdr def)) defs1))) + + (multiple-value-setq (body ss ts is other-decl) (c1body (cdr args) t)) + + (let ((*vars* *vars*)) + (c1add-globals ss) + (check-vdecl nil ts is) + (setq body (c1decl-body other-decl body))) + + (setq info (copy-info (cadr body)))) + + (dolist* (def (setq defs1 (nreverse defs1))) + (when (fun-ref-ccb (car def)) + (let ((*vars* (cons 'cb *vars*)) + (*funs* (cons 'cb *funs*)) + (*blocks* (cons 'cb *blocks*)) + (*tags* (cons 'cb *tags*))) + (let ((lam (c1lambda-expr (cadr def) (fun-name (car def))))) + (add-info info (cadr lam)) + ;; fun-info, CM 20031008 accumulate local function info, particularly changed-vars, + ;; and pass upwards to call-local and call-global to prevent certain inlining in inline-args + ;; via args-info-changed-vars + (add-info (fun-info (car def)) (cadr lam)) + (push (list (car def) lam) closures)))) + + (when (fun-ref (car def)) + (let ((*blocks* (cons 'lb *blocks*)) + (*tags* (cons 'lb *tags*)) + (*vars* (cons 'lb *vars*))) + (let ((lam (c1lambda-expr (cadr def) (fun-name (car def))))) + (add-info info (cadr lam)) + ;; fun-info, CM 20031008 accumulate local function info, particularly changed-vars, + ;; and pass upwards to call-local and call-global to prevent certain inlining in inline-args + ;; via args-info-changed-vars + (add-info (fun-info (car def)) (cadr lam)) + (push (list (car def) lam) local-funs)))) + + (when (or (fun-ref (car def)) (fun-ref-ccb (car def))) + (setf (fun-cfun (car def)) (next-cfun)))) + + ;; fun-info, CM 20031008 accumulate local function info, particularly changed-vars, + ;; and pass upwards to call-local and call-global to prevent certain inlining in inline-args + ;; via args-info-changed-vars + ;; + ;; walk body a second time to incorporate changed variable info from local function + ;; lambda lists + + (let ((*funs* *funs*)) + + (setq *funs* (nconc (mapcar 'car defs1) *funs*)) + + (multiple-value-setq (body ss ts is other-decl) (c1body (cdr args) t)) + + (let ((*vars* *vars*)) + (c1add-globals ss) + (check-vdecl nil ts is) + (setq body (c1decl-body other-decl body))) + + ;; Apparently this is not scricttly necessary, just changes to body + (add-info info (cadr body))) + + (if (or local-funs closures) + (list 'flet info (nreverse local-funs) (nreverse closures) body) + body)) + +(defun c2flet (local-funs closures body + &aux (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*)) + + (dolist** (def local-funs) + (setf (fun-level (car def)) *level*) + ;; Append *initial-ccb-vs* here and use it to initialize *initial-ccb-vs* when writing + ;; the code for this function. Local functions, unlike closures, get an envinment + ;; level with the *initial-ccb-vs* at this point, and *ccb-vs* can be further incremented + ;; here, in c2tagbody-ccb, and in c2block-ccb. CM 20031130 + (push (list nil *clink* *ccb-vs* (car def) (cadr def) *initial-ccb-vs*) *local-funs*)) + + ;;; Setup closures. + (dolist** (def closures) + (push (list 'closure + (if (null *clink*) nil (cons 'fun-env 0)) + *ccb-vs* (car def) (cadr def)) + *local-funs*) + (push (car def) *closures*) + (let ((fun (car def))) + (declare (object fun)) + (setf (fun-ref fun) (vs-push)) + (wt-nl) + (wt-vs (fun-ref fun)) + (wt "=make_cclosure_new(" (c-function-name "LC" (fun-cfun fun) (fun-name fun)) ",Cnil,") (wt-clink) + (wt ",Cdata);") + (wt-nl) + (wt-vs (fun-ref fun)) + (wt "=MMcons(") (wt-vs (fun-ref fun)) (wt ",") (wt-clink) (wt ");") + (clink (fun-ref fun)) + (setf (fun-ref-ccb fun) (ccb-vs-push)) + )) + + (c2expr body) + ) + +(defun c1labels (args &aux body ss ts is other-decl info + (defs1 nil) (local-funs nil) (closures nil) + (fnames nil) (processed-flag nil) (*funs* *funs*) (*info* (copy-info *info*))) + (when (endp args) (too-few-args 'labels 1 0)) + + ;;; bind local-functions + (dolist** (def (car args)) + (cmpck (or (endp def) (not (symbolp (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)) + (push (car def) fnames) + (let ((fun (make-fun :name (car def) :ref nil :ref-ccb nil :info (make-info :sp-change t)))) + (push fun *funs*) + (push (list fun nil nil (cdr def)) defs1))) + + (setq defs1 (nreverse defs1)) + + ;;; Now DEFS1 holds ( { ( fun-object NIL NIL body ) }* ). + + (multiple-value-setq (body ss ts is other-decl) (c1body (cdr args) t)) + (let ((*vars* *vars*)) + (c1add-globals ss) + (check-vdecl nil ts is) + (setq body (c1decl-body other-decl body))) + (setq info (copy-info (cadr body))) + + (block local-process + (loop + (setq processed-flag nil) + (dolist** (def defs1) + (when (and (fun-ref (car def)) ;;; referred locally and + (null (cadr def))) ;;; not processed yet + (setq processed-flag t) + (setf (cadr def) t) + (let ((*blocks* (cons 'lb *blocks*)) + (*tags* (cons 'lb *tags*)) + (*vars* (cons 'lb *vars*))) + (let ((lam (c1lambda-expr (cadddr def) (fun-name (car def))))) + (add-info info (cadr lam)) + ;; fun-info, CM 20031008 accumulate local function info, particularly changed-vars, + ;; and pass upwards to call-local and call-global to prevent certain inlining in inline-args + ;; via args-info-changed-vars + (add-info (fun-info (car def)) (cadr lam)) + (push (list (car def) lam) local-funs))))) + (unless processed-flag (return-from local-process)) + )) ;;; end local process + + (block closure-process + (loop + (setq processed-flag nil) + (dolist** (def defs1) + (when (and (fun-ref-ccb (car def)) ; referred across closure + (null (caddr def))) ; and not processed + (setq processed-flag t) + (setf (caddr def) t) + (let ((*vars* (cons 'cb *vars*)) + (*funs* (cons 'cb *funs*)) + (*blocks* (cons 'cb *blocks*)) + (*tags* (cons 'cb *tags*))) + (let ((lam (c1lambda-expr (cadddr def) (fun-name (car def))))) + (add-info info (cadr lam)) + ;; fun-info, CM 20031008 accumulate local function info, particularly changed-vars, + ;; and pass upwards to call-local and call-global to prevent certain inlining in inline-args + ;; via args-info-changed-vars + (add-info (fun-info (car def)) (cadr lam)) + (push (list (car def) lam) closures)))) + ) + (unless processed-flag (return-from closure-process)) + )) ;;; end closure process + + (dolist** (def defs1) + (when (or (fun-ref (car def)) (fun-ref-ccb (car def))) + (setf (fun-cfun (car def)) (next-cfun)))) + + ;; fun-info, CM 20031008 accumulate local function info, particularly changed-vars, + ;; and pass upwards to call-local and call-global to prevent certain inlining in inline-args + ;; via args-info-changed-vars + ;; + ;; walk body a second time to gather info in labels lambda lists + + (multiple-value-setq (body ss ts is other-decl) (c1body (cdr args) t)) + (let ((*vars* *vars*)) + (c1add-globals ss) + (check-vdecl nil ts is) + (setq body (c1decl-body other-decl body))) + (add-info info (cadr body)) + + (if (or local-funs closures) + (list 'labels info (nreverse local-funs) (nreverse closures) body) + body)) + +(defun c2labels (local-funs closures body &aux (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*)) + + ;;; Prepare for cross-referencing closures. + (dolist** (def closures) + (let ((fun (car def))) + (declare (object fun)) + (setf (fun-ref fun) (vs-push)) + (wt-nl) + (wt-vs (fun-ref fun)) + (wt "=MMcons(Cnil,") (wt-clink) (wt ");") + (clink (fun-ref fun)) + (setf (fun-ref-ccb fun) (ccb-vs-push)) + )) + + (dolist** (def local-funs) + (setf (fun-level (car def)) *level*) + ;; Append *initial-ccb-vs* here and use it to initialize *initial-ccb-vs* when writing + ;; the code for this function. Local functions, unlike closures, get an envinment + ;; level with the *initial-ccb-vs* at this point, and *ccb-vs* can be further incremented + ;; here, in c2tagbody-ccb, and in c2block-ccb. CM 20031130 + (push (list nil *clink* *ccb-vs* (car def) (cadr def) *initial-ccb-vs*) *local-funs*)) + + ;;; Then make closures. + (dolist** (def closures) + (push (list 'closure (if (null *clink*) nil (cons 'fun-env 0)) + *ccb-vs* (car def) (cadr def)) + *local-funs*) + (push (car def) *closures*) + (wt-nl) + (wt-vs* (fun-ref (car def))) + (wt "=make_cclosure_new(" (c-function-name "LC" (fun-cfun (car def)) (fun-name (car def))) ",Cnil,") (wt-clink) + (wt ",Cdata);") + ) + + ;;; now the body of flet + + (c2expr body) + ) + +(defun c1macrolet (args &aux body ss ts is other-decl + (*funs* *funs*) (*vars* *vars*)) + (when (endp args) (too-few-args 'macrolet 1 0)) + (dolist** (def (car args)) + (cmpck (or (endp def) (not (symbolp (car def))) (endp (cdr def))) + "The macro definition ~s is illegal." def) + (push (list (car def) + (caddr (si:defmacro* (car def) (cadr def) (cddr def)))) + *funs*)) + (multiple-value-setq (body ss ts is other-decl) (c1body (cdr args) t)) + (c1add-globals ss) + (check-vdecl nil ts is) + (c1decl-body other-decl body) + ) + +(defun c1local-fun (fname &aux (ccb nil)) + (declare (object ccb)) + (dolist* (fun *funs* nil) + (cond ((eq fun 'CB) (setq ccb t)) + ((consp fun) + (when (eq (car fun) fname) (return (cadr fun)))) + ((eq (fun-name fun) fname) + (if ccb + (setf (fun-ref-ccb fun) t) + (setf (fun-ref fun) t)) + ;; Add fun-info here at the bottom of the call-local processing tree + ;; FIXME -- understand why special variable *info* is used in certain + ;; cases and copy-info in othes. + ;; This extends local call arg side-effect protection (via args-info-changed-vars) + ;; through c1funob to other call methods than previously supported c1symbol-fun, + ;; e.g. c1multiple-value-call, etc. CM 20031030 + (add-info *info* (fun-info fun)) + (return (list 'call-local *info* fun ccb)))))) + +(defun sch-local-fun (fname) + ;;; Returns fun-ob for the local function (not locat macro) named FNAME, + ;;; if any. Otherwise, returns FNAME itself. + (dolist* (fun *funs* fname) + (when (and (not (eq fun 'CB)) + (not (consp fun)) + (eq (fun-name fun) fname)) + (return fun))) + ) + +(defun c1local-closure (fname &aux (ccb nil)) + (declare (object ccb)) + ;;; Called only from C1FUNCTION. + (dolist* (fun *funs* nil) + (cond ((eq fun 'CB) (setq ccb t)) + ((consp fun) + (when (eq (car fun) fname) (return (cadr fun)))) + ((eq (fun-name fun) fname) + (setf (fun-ref-ccb fun) t) + ;; Add fun-info here at the bottom of the call-local processing tree + ;; FIXME -- understand why special variable *info* is used in certain + ;; cases and copy-info in othes. + ;; This extends local call arg side-effect protection (via args-info-changed-vars) + ;; through c1funob to other call methods than previously supported c1symbol-fun, + ;; e.g. c1multiple-value-call, etc. CM 20031030 + (add-info *info* (fun-info fun)) + (return (list 'call-local *info* fun ccb)))))) + +(defun c2call-local (fd args &aux (*vs* *vs*)) + ;;; FD is a list ( fun-object ccb ). + (cond + ((cadr fd) + (push-args args) + (wt-nl "funcall(") (wt-ccb-vs (fun-ref-ccb (car fd))) (wt ");")) + ((and (listp args) + *do-tail-recursion* + *tail-recursion-info* + (eq (car *tail-recursion-info*) (car fd)) + (eq *exit* 'RETURN) + (tail-recursion-possible) + (= (length args) (length (cdr *tail-recursion-info*)))) + (let* ((*value-to-go* 'trash) + (*exit* (next-label)) + (*unwind-exit* (cons *exit* *unwind-exit*))) + (c2psetq (mapcar #'(lambda (v) (list v nil)) + (cdr *tail-recursion-info*)) + args) + (wt-label *exit*)) + (unwind-no-exit 'tail-recursion-mark) + (wt-nl "goto TTL;") + (cmpnote "Tail-recursive call of ~s was replaced by iteration." + (fun-name (car fd)))) + (t (push-args args) + (wt-nl (c-function-name "L" (fun-cfun (car fd)) (fun-name (car fd))) "(") + (dotimes** (n (fun-level (car fd))) + (if (when *closure-p* (zerop n)) (wt "fun->cc.cc_turbo,") (wt "base" n ","))) + (wt "base") + (unless (= (fun-level (car fd)) *level*) (wt (fun-level (car fd)))) + (wt ");") + (base-used))) + (unwind-exit 'fun-val) + ) + diff --git a/cmpnew/gcl_cmpfun.lsp b/cmpnew/gcl_cmpfun.lsp new file mode 100755 index 0000000..4143af2 --- /dev/null +++ b/cmpnew/gcl_cmpfun.lsp @@ -0,0 +1,984 @@ +;; CMPFUN Library functions. +;;; +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +(in-package 'compiler) + +(si:putprop 'princ 'c1princ 'c1) +(si:putprop 'princ 'c2princ 'c2) +(si:putprop 'terpri 'c1terpri 'c1) + +(si:putprop 'apply 'c1apply 'c1) +(si:putprop 'apply 'c2apply 'c2) +(si:putprop 'apply-optimize 'c2apply-optimize 'c2) +(si:putprop 'funcall 'c1funcall 'c1) + +(si:putprop 'rplaca 'c1rplaca 'c1) +(si:putprop 'rplaca 'c2rplaca 'c2) +(si:putprop 'rplacd 'c1rplacd 'c1) +(si:putprop 'rplacd 'c2rplacd 'c2) + +(si:putprop 'si::memq 'c1memq 'c1) +(si:putprop 'member 'c1member 'c1) +(si:putprop 'member!2 'c2member!2 'c2) +(si:putprop 'assoc 'c1assoc 'c1) +(si:putprop 'assoc!2 'c2assoc!2 'c2) +(si:putprop 'get 'c1get 'c1) +(si:putprop 'get 'c2get 'c2) + +(si:putprop 'nth '(c1nth-condition . c1nth) 'c1conditional) +(si:putprop 'nthcdr '(c1nthcdr-condition . c1nthcdr) 'c1conditional) +(si:putprop 'si:rplaca-nthcdr 'c1rplaca-nthcdr 'c1) +(si:putprop 'si:list-nth 'c1list-nth 'c1) +(si:putprop 'list-nth-immediate 'c2list-nth-immediate 'c2) + +(si:putprop 'gethash 'c1gethash 'c1) +(si:putprop 'gethash 'c2gethash 'c2) + + +(defvar *princ-string-limit* 80) + +(defun c1princ (args &aux stream (info (make-info))) + (when (endp args) (too-few-args 'princ 1 0)) + (unless (or (endp (cdr args)) (endp (cddr args))) + (too-many-args 'princ 2 (length args))) + (setq stream (if (endp (cdr args)) + (c1nil) + (c1expr* (cadr args) info))) + (if (and (or (and (stringp (car args)) + (<= (length (car args)) *princ-string-limit*)) + (characterp (car args))) + (or (endp (cdr args)) + (and (eq (car stream) 'var) + (member (var-kind (caaddr stream)) '(GLOBAL SPECIAL))))) + (list 'princ info (car args) + (if (endp (cdr args)) nil (var-loc (caaddr stream))) + stream) + (list 'call-global info 'princ + (list (c1expr* (car args) info) stream)))) + +(defun c2princ (string vv-index stream) + (cond ((eq *value-to-go* 'trash) + (cond ((characterp string) + (wt-nl "princ_char(" (char-code string)) + (if (null vv-index) (wt ",Cnil") (wt "," (vv-str vv-index))) + (wt ");")) + ((= (length string) 1) + (wt-nl "princ_char(" (char-code (aref string 0))) + (if (null vv-index) (wt ",Cnil") (wt "," (vv-str vv-index))) + (wt ");")) + (t + (wt-nl "princ_str(\"") + (dotimes** (n (length string)) + (let ((char (schar string n))) + (cond ((char= char #\\) (wt "\\\\")) + ((char= char #\") (wt "\\\"")) + ((char= char #\Newline) (wt "\\n")) + (t (wt char))))) + (wt "\",") + (if (null vv-index) (wt "Cnil") (wt (vv-str vv-index))) + (wt ");"))) + (unwind-exit nil)) + ((eql string #\Newline) (c2call-global 'terpri (list stream) nil t)) + (t (c2call-global + 'princ + (list (list 'LOCATION + (make-info :type + (if (characterp string) 'character 'string)) + (list 'VV (add-object string))) + stream) nil t)))) + +(defun c1terpri (args &aux stream (info (make-info))) + (unless (or (endp args) (endp (cdr args))) + (too-many-args 'terpri 1 (length args))) + (setq stream (if (endp args) + (c1nil) + (c1expr* (car args) info))) + (if (or (endp args) + (and (eq (car stream) 'var) + (member (var-kind (caaddr stream)) '(GLOBAL SPECIAL)))) + (list 'princ info #\Newline + (if (endp args) nil (var-loc (caaddr stream))) + stream) + (list 'call-global info 'terpri (list stream)))) + +(defun c1apply (args &aux info) + (when (or (endp args) (endp (cdr args))) + (too-few-args 'apply 2 (length args))) + (let ((funob (c1funob (car args)))) + (setq info (copy-info (cadr funob))) + (setq args (c1args (cdr args) info)) + (cond ((eq (car funob) 'call-lambda) + (let* ((lambda-expr (caddr funob)) + (lambda-list (caddr lambda-expr))) + (declare (object lambda-expr lambda-list)) + (if (and (null (cadr lambda-list)) ; No optional + (null (cadddr lambda-list))) ; No keyword + (c1apply-optimize info + (car lambda-list) + (caddr lambda-list) + (car (cddddr lambda-expr)) + args) + (list 'apply info funob args)))) + (t (list 'apply info funob args)))) + ) + +(defun c2apply (funob args &aux (*vs* *vs*) loc) + (setq loc (save-funob funob)) + (let ((*vs* *vs*) (base *vs*) (last-arg (list 'CVAR (next-cvar)))) + (do ((l args (cdr l))) + ((endp (cdr l)) + (wt-nl "{object " last-arg ";") + (let ((*value-to-go* last-arg)) (c2expr* (car l)))) + (declare (object l)) + (let ((*value-to-go* (list 'vs (vs-push)))) (c2expr* (car l)))) + (wt-nl " vs_top=base+" *vs* ";") + (base-used) + (cond (*safe-compile* + (wt-nl " while(!endp(" last-arg "))") + (wt-nl " {vs_push(car(" last-arg "));") + (wt last-arg "=cdr(" last-arg ");}")) + (t + (wt-nl " while(" last-arg "!=Cnil)") + (wt-nl " {vs_push((" last-arg ")->c.c_car);") + (wt last-arg "=(" last-arg ")->c.c_cdr;}"))) + (wt-nl "vs_base=base+" base ";}") + (base-used)) + (c2funcall funob 'args-pushed loc) + ) + +(defun c1apply-optimize (info requireds rest body args + &aux (vl nil) (fl nil)) + (do () + ((or (endp (cdr args)) (endp requireds))) + (push (pop requireds) vl) + (push (pop args) fl)) + + (cond ((cdr args) ;;; REQUIREDS is NIL. + (cmpck (null rest) + "APPLY passes too many arguments to LAMBDA expression.") + (push rest vl) + (push (list 'call-global info 'list* args) fl) + (list 'let info (reverse vl) (reverse fl) body)) + (requireds ;;; ARGS is singleton. + (let ((temp (make-var :kind 'LEXICAL :ref t))) + (push temp vl) + (push (car args) fl) + (list 'let info (reverse vl) (reverse fl) + (list 'apply-optimize + (cadr body) temp requireds rest body)))) + (rest (push rest vl) + (push (car args) fl) + (list 'let info (reverse vl) (reverse fl) body)) + (t + (let ((temp (make-var :kind 'LEXICAL :ref t))) + (push temp vl) + (push (car args) fl) + (list 'let info (reverse vl) (reverse fl) + (list 'apply-optimize + (cadr body) temp requireds rest body)))) + ) + ) + +(defun c2apply-optimize (temp requireds rest body + &aux (*unwind-exit* *unwind-exit*) (*vs* *vs*) + (*clink* *clink*) (*ccb-vs* *ccb-vs*)) + (when (or *safe-compile* *compiler-check-args*) + (wt-nl (if rest "ck_larg_at_least" "ck_larg_exactly") + "(" (length requireds) ",") + (wt-var temp nil) + (wt ");")) + + (dolist** (v requireds) (setf (var-ref v) (vs-push))) + (when rest (setf (var-ref rest) (vs-push))) + + (do ((n 0 (1+ n)) + (vl requireds (cdr vl))) + ((endp vl) + (when rest + (wt-nl) (wt-vs (var-ref rest)) (wt "= ") + (dotimes** (i n) (wt "(")) + (wt-var temp nil) + (dotimes** (i n) (wt-nl ")->c.c_cdr")) + (wt ";"))) + (declare (fixnum n) (object vl)) + (wt-nl) (wt-vs (var-ref (car vl))) (wt "=(") + (dotimes** (i n) (wt "(")) + (wt-var temp nil) + (dotimes** (i n) (wt-nl ")->c.c_cdr")) + (wt ")->c.c_car;")) + + (dolist** (var requireds) (c2bind var)) + (when rest (c2bind rest)) + + (c2expr body) + ) + +(defun c1funcall (args &aux funob (info (make-info))) + (when (endp args) (too-few-args 'funcall 1 0)) + (setq funob (c1funob (car args))) + (add-info info (cadr funob)) + (list 'funcall info funob (c1args (cdr args) info)) + ) + + +(defun c1rplaca (args &aux (info (make-info))) + (when (or (endp args) (endp (cdr args))) + (too-few-args 'rplaca 2 (length args))) + (unless (endp (cddr args)) + (too-many-args 'rplaca 2 (length args))) + (setq args (c1args args info)) + (list 'rplaca info args)) + +(defun c2rplaca (args &aux (*vs* *vs*) (*inline-blocks* 0)) + (setq args (inline-args args '(t t))) + (safe-compile + (wt-nl "if(type_of(" (car args) ")!=t_cons)" + "FEwrong_type_argument(Scons," (car args) ");")) + (wt-nl "(" (car args) ")->c.c_car = " (cadr args) ";") + (unwind-exit (car args)) + (close-inline-blocks) + ) + +(defun c1rplacd (args &aux (info (make-info))) + (when (or (endp args) (endp (cdr args))) + (too-few-args 'rplacd 2 (length args))) + (when (not (endp (cddr args))) + (too-many-args 'rplacd 2 (length args))) + (setq args (c1args args info)) + (list 'rplacd info args)) + +(defun c2rplacd (args &aux (*vs* *vs*) (*inline-blocks* 0)) + (setq args (inline-args args '(t t))) + (safe-compile + (wt-nl "if(type_of(" (car args) ")!=t_cons)" + "FEwrong_type_argument(Scons," (car args) ");")) + (wt-nl "(" (car args) ")->c.c_cdr = SAFE_CDR(" (cadr args) ");") + (unwind-exit (car args)) + (close-inline-blocks) + ) + +(defun c1memq (args &aux (info (make-info))) + (when (or (endp args) (endp (cdr args))) + (too-few-args 'si::memq 2 (length args))) + (unless (endp (cddr args)) + (too-many-args 'si::memq 2 (length args))) + (list 'member!2 info 'eq (c1args (list (car args) (cadr args)) info))) + +(defun c1member (args &aux (info (make-info))) + (when (or (endp args) (endp (cdr args))) + (too-few-args 'member 2 (length args))) + (cond ((endp (cddr args)) + (list 'member!2 info 'eql (c1args args info))) + ((and (eq (caddr args) :test) + (eql (length args) 4) + (member (cadddr args) '('eq #'eq 'equal #'equal + 'equalp #'equalp 'eql #'eql) + :test 'equal)) + (list 'member!2 info (cadr (cadddr args)) + (c1args (list (car args) (cadr args)) info))) + (t + (list 'call-global info 'member (c1args args info))))) + +(defun c2member!2 (fun args + &aux (*vs* *vs*) (*inline-blocks* 0) (l (next-cvar))) + (setq args (inline-args args '(t t))) + (wt-nl "{register object x= " (car args) ",V" l "= " (cadr args) ";") + (if *safe-compile* + (wt-nl "while(!endp(V" l "))") + (wt-nl "while(V" l "!=Cnil)")) + (if (eq fun 'eq) + (wt-nl "if(x==(V" l "->c.c_car)){") + (wt-nl "if(" (string-downcase (symbol-name fun)) + "(x,V" l "->c.c_car)){")) + (if (and (consp *value-to-go*) + (or (eq (car *value-to-go*) 'JUMP-TRUE) + (eq (car *value-to-go*) 'JUMP-FALSE))) + (unwind-exit t 'JUMP) + (unwind-exit (list 'CVAR l) 'JUMP)) + (wt-nl "}else V" l "=V" l "->c.c_cdr;") + (unwind-exit nil) + (wt "}") + (close-inline-blocks) + ) + +(defun c1assoc (args &aux (info (make-info))) + (when (or (endp args) (endp (cdr args))) + (too-few-args 'assoc 2 (length args))) + (cond ((endp (cddr args)) + (list 'assoc!2 info 'eql (c1args args info))) + ((and (eq (caddr args) ':test) + (eql (length args) 4) + (member (cadddr args) '('eq #'eq 'equal #'equal + 'equalp #'equalp 'eql #'eql) + :test 'equal)) + (list 'assoc!2 info (cadr (cadddr args)) (c1args (list (car args) (cadr args)) info))) + (t + (list 'call-global info 'assoc (c1args args info))))) + +(defun c2assoc!2 (fun args + &aux (*vs* *vs*) (*inline-blocks* 0) (al (next-cvar))name) + (setq args (inline-args args '(t t))) + (setq name (symbol-name fun)) + (or (eq fun 'eq) (setq name (string-downcase name))) + (wt-nl "{register object x= " (car args) ",V" al "= " (cadr args) ";") + (cond (*safe-compile* + (wt-nl "while(!endp(V" al "))") + (wt-nl "if(type_of(V"al"->c.c_car)==t_cons &&" + name "(x,V" al "->c.c_car->c.c_car)){")) + (t + (wt-nl "while(V" al "!=Cnil)") + (wt-nl "if(" name "(x,V" al "->c.c_car->c.c_car) &&" + "V"al"->c.c_car != Cnil){"))) + (if (and (consp *value-to-go*) + (or (eq (car *value-to-go*) 'jump-true) + (eq (car *value-to-go*) 'jump-false))) + (unwind-exit t 'jump) + (unwind-exit (list 'CAR al) 'jump)) + (wt-nl "}else V" al "=V" al "->c.c_cdr;") + (unwind-exit nil) + (wt "}") + (close-inline-blocks) + ) + + + + +(defun boole3 (a b c) (boole a b c)) +;(si:putprop 'boole '(c1boole-condition . c1boole3) 'c1conditional) + +(defun c1boole-condition (args) + (and (not (endp (cddr args))) + (endp (cdddr args)) + (inline-boole3-string (car args)))) + +(defun c1boole3 (args) + (c1expr (cons 'boole3 args))) + +(defun inline-boole3 (&rest args) + (let ((boole-op-arg (second (car args)))) + (or (eq (car boole-op-arg) 'fixnum-value) (error "must be constant")) + (let ((string (inline-boole3-string (third boole-op-arg)))) + (or string (error "should not get here boole opt")) + (wt-inline-loc string (cdr args))))) + +(defun inline-boole3-string (op-code) + (and (constantp op-code) (setq op-code (eval op-code))) + (case op-code + (#. boole-andc1 "((~(#0))&(#1))") + (#. boole-andc2 "(((#0))&(~(#1)))") + (#. boole-nor "(~((#0)|(#1)))") + (#. boole-orc1 "(~(#0)) | (#1)))") + (#. boole-orc2 "((#0) | (~(#1)))") + (#. boole-nand "(~((#0) & (#1)))") + (#. boole-eqv "(~((#0) ^ (#1)))") + (#. boole-and "((#0) & (#1))") + (#. boole-xor "((#0) ^ (#1))") + (#. boole-ior "((#0) | (#1))"))) + +(si:putprop 'ash '(c1ash-condition . c1ash) 'c1conditional) + +(defun c1ash-condition (args &aux (z '#.(let ((z (integer-length most-positive-fixnum))) `(integer ,(- z) ,z)))) + (let ((shamt (second args))) + (or (typep shamt z) + (and (consp shamt) + (eq (car shamt) 'the) + (let ((type (cadr shamt))) + (subtypep type z)))))) + +(defun c1ash (args) + (let ((shamt (second args))fun) + (cond ((constantp shamt) (setq shamt (eval shamt)) + (or (si:fixnump shamt) (error "integer shift only")) + (cond ((< shamt 0) (setq fun 'shift>> )) + ((>= shamt 0) (setq fun 'shift<<)))) + (t (let ((type (second shamt))) + ;;it had to be a (the type..) + (cond ((subtypep type '#.`(integer 0 ,(integer-length most-positive-fixnum))) + (setq fun 'shift<< )) + ((subtypep type '#.`(integer ,(- (integer-length most-positive-fixnum)) 0)) + (setq fun 'shift>> )) + (t (error "should not get here"))) + ))) + (c1expr (cons fun args)))) +(defun shift>> (a b) (ash a b)) +(defun shift<< (a b) (ash a b)) +(si:putprop 'ash '(c1ash-condition . c1ash) 'c1conditional) +(si:putprop 'shift>> "Lash" 'lfun) +(si:putprop 'shift<< "Lash" 'lfun) + +(si::putprop 'ldb 'co1ldb 'co1) + +(defun co1ldb (f args &aux tem (len (integer-length most-positive-fixnum))) f + (let ((specs + (cond ((and (consp (setq tem (first args))) + (eq 'byte (car tem)) + (cons (second tem) (third tem))))))) + (cond ((and (integerp (cdr specs)) + (integerp (car specs)) + (< (+ (car specs)(cdr specs)) + len) + (subtypep (result-type (second args)) 'fixnum)) + (c1expr `(the fixnum (si::ldb1 ,(car specs) ,(cdr specs) ,(second args)))))))) + + +(si:putprop 'length 'c1length 'c1) + +(defun c1length (args &aux (info (make-info))) + (setf (info-type info) 'fixnum) + (cond ((and (consp (car args)) + (eq (caar args) 'symbol-name) + (let ((args1 (cdr (car args)))) + (and args1 (not (cddr args1)) + (list 'call-global info 'symbol-length + (c1args args1 info)))))) + (t (setq args (c1args args info)) + (list 'call-global info 'length args )))) + + +(defun c1get (args &aux (info (make-info))) + + (when (or (endp args) (endp (cdr args))) + (too-few-args 'get 2 (length args))) + (when (and (not (endp (cddr args))) (not (endp (cdddr args)))) + (too-many-args 'get 3 (length args))) + (list 'get info (c1args args info))) + +(defun c2get (args) + (if *safe-compile* + (c2call-global 'get args nil t) + (let ((*vs* *vs*) (*inline-blocks* 0) (pl (next-cvar))) + (setq args (inline-args args (if (cddr args) '(t t t) '(t t)))) + (wt-nl "{object V" pl" =(" (car args) ")->s.s_plist;") + (wt-nl " object ind= " (cadr args) ";") + (wt-nl "while(V" pl "!=Cnil){") + (wt-nl "if(V" pl "->c.c_car==ind){") + (unwind-exit (list 'CADR pl) 'jump) + (wt-nl "}else V" pl "=V" pl "->c.c_cdr->c.c_cdr;}") + (unwind-exit (if (cddr args) (caddr args) nil)) + (wt "}") + (close-inline-blocks))) + ) + +(defun co1eql (f args) f + (or (and (cdr args) (not *safe-compile*)) + (return-from co1eql nil)) + (cond ((replace-constant args) + (cond ((characterp (second args)) + (setq args (reverse args)))) + (cond ((characterp (car args)) + (let ((c (gensym))) + (c1expr + `(let ((,c ,(second args))) + (declare (type ,(result-type (second args)) + ,c)) + (and (typep ,c 'character) + (= (char-code ,(car args)) + (the fixnum + (char-code + (the character + ,c))) + )))))))))) + + + +(si::putprop 'eql 'co1eql 'co1) + +(defvar *frozen-defstructs* nil) + +;; Return the most particular type we can EASILY obtain +;; from x. +(defun result-type (x) + (cond ((symbolp x) + (let ((tem (c1expr x))) + (info-type (second tem)))) + ((constantp x) + (type-filter (type-of x))) + ((and (consp x) (eq (car x) 'the)) + (type-filter (second x))) + (t t))) + + + +(defvar *type-alist* + '((fixnum . si::fixnump) + (float . floatp) + (si::spice . si::spice-p) + (short-float . short-float-p) + (long-float . long-float-p) + (integer . integerp) + (character . characterp) + (symbol . symbolp) + (cons . consp) + (null . null) + (array . arrayp) + (vector . vectorp) + (bit-vector . bit-vector-p) + (string . stringp) + (list . (lambda (y) (or (consp y) (null y)))) + (number . numberp) + (rational . rationalp) + (complex . complexp) + (ratio . ratiop) + (sequence . (lambda (y) (or (listp y) (vectorp y)))) + (function . functionp) + )) + + +(defun co1typep (f args &aux tem) f + (let* + ((x (car args)) new + (type (and (consp (second args)) + (eq (car (second args)) 'quote) + (second (second args))))) + (cond ((subtypep (result-type (car args)) type) + (setq new t) + (return-from co1typep (c1expr new)))) + (setq new + (cond + ((null type) nil) + ((setq f (assoc type *type-alist* :test 'equal)) + (list (cdr f) x)) + ((and (consp type) + (or (and (eq (car type) 'vector) + (null (cddr type))) + (and + (member (car type) + '(array vector simple-array)) + (equal (third type) '(*))))) + (setq tem (si::best-array-element-type + (second type))) + (cond ((eq tem 'string-char) `(stringp ,x)) + ((eq tem 'bit) `(bit-vector-p ,x)) + ((setq tem (position tem *aet-types*)) + `(the boolean (vector-type ,x ,tem))))) + ((and (consp type) + (eq (car type) 'satisfies) + (consp (cdr type)) + (cadr type) + (symbolp (cadr type)) + (symbol-package (cadr type)) + (null (cddr type)) + `(,(cadr type) ,x))) + ((subtypep type 'fixnum) + (setq tem (si::normalize-type type)) + (and (consp tem) + (si::fixnump (second tem)) + (si::fixnump (third tem)) + `(let ((.tem ,x)) + (declare (type ,(result-type x) .tem)) + (and (typep .tem 'fixnum) + (>= (the fixnum .tem) ,(second tem)) + (<= (the fixnum .tem) ,(third tem)))))) + ((and (symbolp type) + (setq tem (get type 'si::s-data))) + (cond ((or (si::s-data-frozen tem) + *frozen-defstructs*) + (struct-type-opt x tem)) + (t + `(si::structure-subtype-p + ,x ',type)))) +; ((and (print (list 'slow 'typep type)) nil)) + (t nil))) + (and new (c1expr `(the boolean , new))))) + +;; this is going the wrong way. want to go up.. +(defun struct-type-opt (x sd) + (let ((s (gensym)) + (included (get-included (si::s-data-name sd)))) + `(let ((,s ,x)) + (and + (si::structurep ,s) + ,(cond ((< (length included) 3) + `(or ,@ + (mapcar #'(lambda (x) + `(eq (si::structure-def ,s) + ,(name-sd1 x))) + included))) + (t `(si::structure-subtype-p ,s + ,(name-sd1 + (si::s-data-name sd))))))))) + +(defun get-included (name) + (let ((sd (get name 'si::s-data))) + (cons (si::s-data-name sd) + (mapcan 'get-included + (si::s-data-included sd))))) + + + +(si::putprop 'typep 'co1typep 'co1) + +(defun co1schar (f args) f + (and (listp (car args)) (not *safe-compile*) + (cdr args) + (eq (caar args) 'symbol-name) + (c1expr `(aref (the string ,(second (car args))) + ,(second args))))) + +(si::putprop 'schar 'co1schar 'co1) + +(si::putprop 'cons 'co1cons 'co1) +;; turn repetitious cons's into a list* + +(defun cons-to-lista (x) + (let ((tem (last x))) + (cond + ((and (consp tem) + (consp (car tem)) + (eq (caar tem) 'cons) + (eql (length (cdar tem)) 2) + (cons-to-lista (append (butlast x) + (cdar tem))))) + (t x)))) + + +(defun co1cons (f args) f + (let ((tem (and (eql (length args) 2) (cons-to-lista args)))) + (and (not (eq tem args)) + (c1expr (if (equal '(nil) (last tem)) + (cons 'list (butlast tem)) + (cons 'list* tem)))))) + +;; I don't feel it is good to replace the list call, but rather +;; usually better the other way around. We removed c1list +;; because of possible feedback. + +(defun c1nth-condition (args) + (and (not (endp args)) + (not (endp (cdr args))) + (endp (cddr args)) + (numberp (car args)) + (<= 0 (car args) 7))) + +(defun c1nth (args) + (c1expr (case (car args) + (0 (cons 'car (cdr args))) + (1 (cons 'cadr (cdr args))) + (2 (cons 'caddr (cdr args))) + (3 (cons 'cadddr (cdr args))) + (4 (list 'car (cons 'cddddr (cdr args)))) + (5 (list 'cadr (cons 'cddddr (cdr args)))) + (6 (list 'caddr (cons 'cddddr (cdr args)))) + (7 (list 'cadddr (cons 'cddddr (cdr args)))) + ))) + +(defun c1nthcdr-condition (args) + (and (not (endp args)) + (not (endp (cdr args))) + (endp (cddr args)) + (numberp (car args)) + (<= 0 (car args) 7))) + +(defun c1nthcdr (args) + (c1expr (case (car args) + (0 (cadr args)) + (1 (cons 'cdr (cdr args))) + (2 (cons 'cddr (cdr args))) + (3 (cons 'cdddr (cdr args))) + (4 (cons 'cddddr (cdr args))) + (5 (list 'cdr (cons 'cddddr (cdr args)))) + (6 (list 'cddr (cons 'cddddr (cdr args)))) + (7 (list 'cdddr (cons 'cddddr (cdr args)))) + ))) + +(defun c1rplaca-nthcdr (args &aux (info (make-info))) + (when (or (endp args) (endp (cdr args)) (endp (cddr args))) + (too-few-args 'si:rplaca-nthcdr 3 (length args))) + (unless (endp (cdddr args)) + (too-few-args 'si:rplaca-nthcdr 3 (length args))) + (if (and (numberp (cadr args)) (<= 0 (cadr args) 10)) + (let ((x (gensym))(y (gensym))) + (c1expr + `(let ((,x ,(car args)) + (,y ,(third args))) + (setf ,x (nthcdr ,(cadr args) ,x)) + (setf (car ,x) ,y) + ,y))) + (list 'call-global info 'si:rplaca-nthcdr (c1args args info)))) + + +;; Facilities for faster reading and writing from file streams. +;; You must declare the stream to be :in-file +;; or :out-file + +(si::putprop 'read-byte 'co1read-byte 'co1) +(si::putprop 'read-char 'co1read-char 'co1) +(si::putprop 'write-byte 'co1write-byte 'co1) +(si::putprop 'write-char 'co1write-char 'co1) + + + +(defun fast-read (args read-fun) + (cond + ((and (not *safe-compile*) + (< *space* 2) + (null (second args)) + (boundp 'si::*eof*)) + (cond + ((atom (car args)) + (or (car args) (setq args (cons '*standard-input* (cdr args)))) + (let ((stream (car args)) + (eof (third args))) + `(let ((ans 0)) + (declare (fixnum ans)) + (cond ((fp-okp ,stream) + (setq ans (sgetc1 ,stream)) + (cond ((and (eql ans ,si::*eof*) + (sfeof ,stream)) + ,eof) + (t ,(if (eq read-fun 'read-char1) + '(code-char ans) 'ans)) + )) + (t + (,read-fun ,stream ,eof) + ) + )))) + (t + `(let ((.strm. ,(car args))) + (declare (type ,(result-type (car args)) .strm.)) + ,(fast-read (cons '.strm. (cdr args)) read-fun))))))) + +(defun co1read-byte (f args &aux tem) f + (cond ((setq tem (fast-read args 'read-byte1)) + (let ((*space* 10)) ;prevent recursion! + (c1expr tem))))) + +(defun co1read-char (f args &aux tem) f + (cond ((setq tem (fast-read args 'read-char1)) + (let ((*space* 10)) ;prevent recursion! + (c1expr tem))))) + +(defun cfast-write (args write-fun) + (cond + ((and (not *safe-compile*) + (< *space* 2) + (boundp 'si::*eof*)) + (let ((stream (second args))) + (or stream (setq stream '*standard-output*)) + (cond + ((atom stream) + `(cond ((fp-okp ,stream) + (the fixnum (sputc .ch ,stream))) + (t (,write-fun .ch ,stream)))) + (t `(let ((.str ,stream)) + (declare (type ,(result-type stream) .str)) + ,(cfast-write (list '.ch '.str) write-fun)))))))) + +(defun co1write-byte (f args) f + (let ((tem (cfast-write args 'write-byte))) + (if tem (let ((*space* 10)) + (c1expr + `(let ((.ch ,(car args))) + (declare (fixnum .ch)) + ,tem + ,(if (atom (car args)) (car args) '.ch))))))) + +(defun co1write-char (f args) f + (let ((tem (cfast-write args 'write-char))) + (if tem (let ((*space* 10)) + (c1expr + `(let ((.ch ,(car args))) + (declare (character .ch)) + ,tem + ,(if (atom (car args)) (car args) '.ch))))))) + + + +(defvar *aet-types* + #(T STRING-CHAR SIGNED-CHAR FIXNUM SHORT-FLOAT LONG-FLOAT + SIGNED-CHAR + UNSIGNED-CHAR SIGNED-SHORT UNSIGNED-SHORT)) + + +(defun aet-c-type (type) + (ecase type + ((t) "object") + ((string-char signed-char) "char") + (fixnum "fixnum") + (unsigned-char "unsigned char") + (unsigned-short "unsigned short") + (signed-short "short") + (unsigned-short "unsigned short") + (long-float "longfloat") + (short-float "shortfloat"))) + + +(si:putprop 'vector-push 'co1vector-push 'co1) +(si:putprop 'vector-push-extend 'co1vector-push 'co1) +(defun co1vector-push (f args) f + (unless + (or *safe-compile* + (> *space* 3) + (null (cdr args)) + ) + (let ((*space* 10)) + (c1expr + `(let* ((.val ,(car args)) + (.v ,(second args)) + (.i (fill-pointer .v)) + (.dim (array-total-size .v))) + (declare (fixnum .i .dim)) + (declare (type ,(result-type (second args)) .v)) + (declare (type ,(result-type (car args)) .val)) + (cond ((< .i .dim) + (the fixnum (si::fill-pointer-set .v (the fixnum (+ 1 .i)))) + (si::aset .v .i .val) + .i) + (t ,(cond ((eq f 'vector-push-extend) + `(vector-push-extend .val + .v ,@(cddr args))))))))))) + +(defun constant-fold-p (x) + (cond ((constantp x) t) + ((atom x) nil) + ((eq (car x) 'the) + (constant-fold-p (third x))) + ((and + (symbolp (car x)) + (eq (get (car x) 'co1) + 'co1constant-fold)) + (dolist (w (cdr x)) + (or (constant-fold-p w) + (return-from constant-fold-p nil))) + t) + (t nil))) + +(defun co1constant-fold (f args ) + (cond ((and (fboundp f) + (dolist (v args t) + (or (constant-fold-p v) + (return-from co1constant-fold nil)))) + (c1expr (cmp-eval (cons f args)))))) + + +(si::putprop 'do 'co1special-fix-decl 'co1special) +(si::putprop 'do* 'co1special-fix-decl 'co1special) +(si::putprop 'prog 'co1special-fix-decl 'co1special) +(si::putprop 'prog* 'co1special-fix-decl 'co1special) + +(defun co1special-fix-decl (f args) + (flet ((fixup (forms &aux decls ) + (block nil + (tagbody + top + (or (consp forms) (go end)) + (let ((tem (car forms))) + (if (and (consp tem) + (setq tem (cmp-macroexpand tem)) + (eq (car tem) 'declare)) + (progn (push tem decls) (pop forms)) + (go end))) + (go top) + ; all decls made explicit. + end + (return (nconc (nreverse decls) forms)))))) + (c1expr + (cmp-macroexpand + (case f + ((do do*) `(,f ,(car args) + ,(second args) + ,@ (fixup (cddr args)))) + ((prog prog*) + `(,f ,(car args) + ,@ (fixup (cdr args))))))))) +(si::putprop 'sublis 'co1sublis 'co1) +(defun co1sublis (f args &aux test) f + (and (case (length args) + (2 (setq test 'eql)) + (4 (and (eq (third args) :test) + (cond ((member (fourth args) '(equal (function equal))) (setq test 'equal)) + ((member (fourth args) '(eql (function eql))) (setq test 'eql)) + ((member (fourth args) '(eq (function eq))) (setq test 'eq)) + )))) + (let ((s (gensym))) + (c1expr `(let ((,s ,(car args))) + (sublis1 ,s ,(second args) ',test)))))) + +(defun sublis1-inline (a b c) + (let ((tst (ltvp-eval (cadr c)))) + (or (member tst '(eq equal eql)) (error "bad test")) + (wt "(check_alist(" a "),sublis1("a "," b "," (format nil "&o~(~a~)))" tst)))) + + +;; end new + +(defun c1list-nth (args &aux (info (make-info))) + (when (or (endp args) (endp (cdr args))) + (too-few-args 'si:rplaca-nthcdr 2 (length args))) + (unless (endp (cddr args)) + (too-few-args 'si:rplaca-nthcdr 2 (length args))) + (if (and (numberp (car args)) (<= 0 (car args) 10)) + (list 'list-nth-immediate info + (car args) + (c1args (list (cadr args)) info)) + (list 'call-global info 'si:list-nth (c1args args info)))) + +(defun c2list-nth-immediate (index args &aux (l (next-cvar)) + (*vs* *vs*) (*inline-blocks* 0)) + (setq args (inline-args args '(t t))) + (wt-nl "{object V" l "= ") + (if *safe-compile* + (progn + (dotimes** (i index) (wt "cdr(")) + (wt (car args)) + (dotimes** (i index) (wt ")")) + (wt ";") + (wt-nl "if((type_of(V" l ")!=t_cons) && (" (car args) "!= Cnil))") + (wt-nl " FEwrong_type_argument(Scons,V" l ");") + ) + (progn + (wt-nl (car args)) + (dotimes** (i index) (wt-nl "->c.c_cdr")) + (wt ";"))) + (unwind-exit (list 'CAR l)) + (wt "}") + (close-inline-blocks) + ) + + +(defun c1gethash (args) + (unless (cdr args) (too-few-args 'gethash 2 (length args))) + (when (cdddr args) (too-many-args 'gethash 3 (length args))) + (let* ((info (make-info)) + (nargs (c1args args info))) + `(gethash ,info ,nargs))) + +(defun c2gethash (args) + (cond ((member *value-to-go* '(top return)) + (let* ((nargs (inline-args args '(t t))) + (base *vs*)(*vs* *vs*) + (r (cdr (vs-push)))(f (cdr (vs-push)))) + (wt-nl "{ struct htent *_z=gethash" (if *safe-compile* "_with_check" "") "(" (car nargs) "," (cadr nargs) ");") + (wt-nl "if (_z->hte_key==OBJNULL) {") + (wt-nl "base[" r "]=" (caddr nargs) ";") + (wt-nl "base[" f "]=Cnil;") + (wt-nl "} else {") + (wt-nl "base[" r "]=_z->hte_value;") + (wt-nl "base[" f "]=Ct;") + (wt-nl "}}") + (wt-nl "vs_top=(vs_base=base+" base ")+" (- *vs* base) ";") + (unwind-exit 'fun-val nil (cons 'values 2)))) + ((unwind-exit (get-inline-loc `((t t) t #.(flags rfa) + ,(concatenate 'string + "({struct htent *_z=gethash" + (if *safe-compile* "_with_check" "") + "(#0,#1);_z->hte_key==OBJNULL ? (#2) : _z->hte_value;})")) + args))))) diff --git a/cmpnew/gcl_cmpif.lsp b/cmpnew/gcl_cmpif.lsp new file mode 100755 index 0000000..8c0b100 --- /dev/null +++ b/cmpnew/gcl_cmpif.lsp @@ -0,0 +1,438 @@ +;;; CMPIF Conditionals. +;;; +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +(in-package 'compiler) + +(si:putprop 'if 'c1if 'c1special) +(si:putprop 'if 'c2if 'c2) +(si:putprop 'and 'c1and 'c1) +(si:putprop 'and 'c2and 'c2) +(si:putprop 'or 'c1or 'c1) +(si:putprop 'or 'c2or 'c2) + +(si:putprop 'jump-true 'set-jump-true 'set-loc) +(si:putprop 'jump-false 'set-jump-false 'set-loc) + +(si:putprop 'case 'c1case 'c1) +(si:putprop 'ecase 'c1ecase 'c1) +(si:putprop 'case 'c2case 'c2) + +(defun c1if (args &aux info f) + (when (or (endp args) (endp (cdr args))) + (too-few-args 'if 2 (length args))) + (unless (or (endp (cddr args)) (endp (cdddr args))) + (too-many-args 'if 3 (length args))) + (setq f (c1fmla-constant (car args))) + + (case f + ((t) (c1expr (cadr args))) + ((nil) (if (endp (cddr args)) (c1nil) (c1expr (caddr args)))) + (otherwise + (setq info (make-info)) + (list 'if info + (c1fmla f info) + (c1expr* (cadr args) info) + (if (endp (cddr args)) (c1nil) (c1expr* (caddr args) info))))) + ) + +(defun c1fmla-constant (fmla &aux f) + (cond + ((consp fmla) + (case (car fmla) + (and (do ((fl (cdr fmla) (cdr fl))) + ((endp fl) t) + (declare (object fl)) + (setq f (c1fmla-constant (car fl))) + (case f + ((t)) + ((nil) (return nil)) + (t (if (endp (cdr fl)) + (return f) + (return (list* 'and f (cdr fl)))))))) + (or (do ((fl (cdr fmla) (cdr fl))) + ((endp fl) nil) + (declare (object fl)) + (setq f (c1fmla-constant (car fl))) + (case f + ((t) (return t)) + ((nil)) + (t (if (endp (cdr fl)) + (return f) + (return (list* 'or f (cdr fl)))))))) + ((not null) + (when (endp (cdr fmla)) (too-few-args 'not 1 0)) + (unless (endp (cddr fmla)) + (too-many-args 'not 1 (length (cdr fmla)))) + (setq f (c1fmla-constant (cadr fmla))) + (case f + ((t) nil) + ((nil) t) + (t (list 'not f)))) + (t fmla))) + ((symbolp fmla) (if (constantp fmla) + (if (symbol-value fmla) t nil) + fmla)) + (t t)) + ) + +(defun c1fmla (fmla info) + (if (consp fmla) + (case (car fmla) + (and (case (length (cdr fmla)) + (0 (c1t)) + (1 (c1fmla (cadr fmla) info)) + (t (cons 'FMLA-AND + (mapcar #'(lambda (x) (c1fmla x info)) + (cdr fmla)))))) + (or (case (length (cdr fmla)) + (0 (c1nil)) + (1 (c1fmla (cadr fmla) info)) + (t (cons 'FMLA-OR + (mapcar #'(lambda (x) (c1fmla x info)) + (cdr fmla)))))) + ((not null) + (when (endp (cdr fmla)) (too-few-args 'not 1 0)) + (unless (endp (cddr fmla)) + (too-many-args 'not 1 (length (cdr fmla)))) + (list 'FMLA-NOT (c1fmla (cadr fmla) info))) + (t (c1expr* `(the boolean ,fmla) info))) + (c1expr* fmla info)) + ) + +(defun c2if (fmla form1 form2 + &aux (Tlabel (next-label)) Flabel) + (cond ((and (eq (car form2) 'LOCATION) + (null (caddr form2)) + (eq *value-to-go* 'TRASH) + (not (eq *exit* 'RETURN))) + (let ((exit *exit*) + (*unwind-exit* (cons Tlabel *unwind-exit*)) + (*exit* Tlabel)) + (CJF fmla Tlabel exit)) + (wt-label Tlabel) + (c2expr form1)) + (t + (setq Flabel (next-label)) + (let ((*unwind-exit* (cons Flabel (cons Tlabel *unwind-exit*))) + (*exit* Tlabel)) + (CJF fmla Tlabel Flabel)) + (wt-label Tlabel) + (let ((*unwind-exit* (cons 'JUMP *unwind-exit*))) (c2expr form1)) + (wt-label Flabel) + (c2expr form2))) + ) + +;;; If fmla is true, jump to Tlabel. If false, do nothing. +(defun CJT (fmla Tlabel Flabel) + (case (car fmla) + (fmla-and (do ((fs (cdr fmla) (cdr fs))) + ((endp (cdr fs)) + (CJT (car fs) Tlabel Flabel)) + (declare (object fs)) + (let* ((label (next-label)) + (*unwind-exit* (cons label *unwind-exit*))) + (CJF (car fs) label Flabel) + (wt-label label)))) + (fmla-or (do ((fs (cdr fmla) (cdr fs))) + ((endp (cdr fs)) + (CJT (car fs) Tlabel Flabel)) + (declare (object fs)) + (let* ((label (next-label)) + (*unwind-exit* (cons label *unwind-exit*))) + (CJT (car fs) Tlabel label) + (wt-label label)))) + (fmla-not (CJF (cadr fmla) Flabel Tlabel)) + (LOCATION + (case (caddr fmla) + ((t) (unwind-no-exit Tlabel) (wt-nl) (wt-go Tlabel)) + ((nil)) + (t (let ((*value-to-go* (list 'jump-true Tlabel))) + (c2expr* fmla))))) + (t (let ((*value-to-go* (list 'jump-true Tlabel))) (c2expr* fmla)))) + ) + +;;; If fmla is false, jump to Flabel. If true, do nothing. +(defun CJF (fmla Tlabel Flabel) + (case (car fmla) + (FMLA-AND (do ((fs (cdr fmla) (cdr fs))) + ((endp (cdr fs)) (CJF (car fs) Tlabel Flabel)) + (declare (object fs)) + (let* ((label (next-label)) + (*unwind-exit* (cons label *unwind-exit*))) + (CJF (car fs) label Flabel) + (wt-label label)))) + (FMLA-OR (do ((fs (cdr fmla) (cdr fs))) + ((endp (cdr fs)) (CJF (car fs) Tlabel Flabel)) + (declare (object fs)) + (let* ((label (next-label)) + (*unwind-exit* (cons label *unwind-exit*))) + (CJT (car fs) Tlabel label) + (wt-label label)))) + (FMLA-NOT (CJT (cadr fmla) Flabel Tlabel)) + (LOCATION + (case (caddr fmla) + ((t)) + ((nil) (unwind-no-exit Flabel) (wt-nl) (wt-go Flabel)) + (t (let ((*value-to-go* (list 'jump-false Flabel))) + (c2expr* fmla))))) + (t (let ((*value-to-go* (list 'jump-false Flabel))) (c2expr* fmla)))) + ) + +(defun c1and (args) + (cond ((endp args) (c1t)) + ((endp (cdr args)) (c1expr (car args))) + (t (let ((info (make-info))) (list 'AND info (c1args args info)))))) + +(defun c2and (forms) + (do ((forms forms (cdr forms))) + ((endp (cdr forms)) + (c2expr (car forms))) + (declare (object forms)) + (cond ((eq (caar forms) 'LOCATION) + (case (caddar forms) + ((t)) + ((nil) (unwind-exit nil 'JUMP)) + (t (wt-nl "if(" (caddar forms) "==Cnil){") + (unwind-exit nil 'JUMP) (wt "}") + ))) + ((eq (caar forms) 'VAR) + (wt-nl "if(") + (wt-var (car (caddar forms)) (cadr (caddar forms))) + (wt "==Cnil){") + (unwind-exit nil 'jump) (wt "}")) + (t + (let* ((label (next-label)) + (*unwind-exit* (cons label *unwind-exit*))) + (let ((*value-to-go* (list 'jump-true label))) + (c2expr* (car forms))) + (unwind-exit nil 'jump) + (wt-label label)))) + )) + +(defun c1or (args) + (cond ((endp args) (c1nil)) + ((endp (cdr args)) (c1expr (car args))) + (t (let ((info (make-info))) + (list 'OR info (c1args args info)))))) + +(defun c2or (forms &aux (*vs* *vs*) temp) + (do ((forms forms (cdr forms)) + ) + ((endp (cdr forms)) + (c2expr (car forms))) + (declare (object forms)) + (cond ((eq (caar forms) 'LOCATION) + (case (caddar forms) + ((t) (unwind-exit t 'JUMP)) + ((nil)) + (t (wt-nl "if(" (caddar forms) "!=Cnil){") + (unwind-exit (caddar forms) 'JUMP) (wt "}")))) + ((eq (caar forms) 'VAR) + (wt-nl "if(") + (wt-var (car (caddar forms)) (cadr (caddar forms))) + (wt "!=Cnil){") + (unwind-exit (cons 'VAR (caddar forms)) 'jump) (wt "}")) + ((and (eq (caar forms) 'CALL-GLOBAL) + (get (caddar forms) 'predicate)) + (let* ((label (next-label)) + (*unwind-exit* (cons label *unwind-exit*))) + (let ((*value-to-go* (list 'jump-false label))) + (c2expr* (car forms))) + (unwind-exit t 'jump) + (wt-label label))) + (t + (let* ((label (next-label)) + (*inline-blocks* 0) + (*unwind-exit* (cons label *unwind-exit*))) + (setq temp (wt-c-push)) + (let ((*value-to-go* temp)) (c2expr* (car forms))) + (wt-nl "if(" temp "==Cnil)") (wt-go label) + (unwind-exit temp 'jump) + (wt-label label) + (close-inline-blocks) + ))) + ) + ) + +(defun set-jump-true (loc label) + (unless (null loc) + (cond ((eq loc t)) + ((and (consp loc) (eq (car loc) 'INLINE-COND)) + (wt-nl "if(") + (wt-inline-loc (caddr loc) (cadddr loc)) + (wt ")")) + (t (wt-nl "if((" loc ")!=Cnil)"))) + (unless (eq loc t) (wt "{")) + (unwind-no-exit label) + (wt-nl) (wt-go label) + (unless (eq loc t) (wt "}"))) + ) + +(defun set-jump-false (loc label) + (unless (eq loc t) + (cond ((null loc)) + ((and (consp loc) (eq (car loc) 'INLINE-COND)) + (wt-nl "if(!(") + (wt-inline-loc (caddr loc) (cadddr loc)) + (wt "))")) + (t (wt-nl "if((" loc ")==Cnil)"))) + (unless (null loc) (wt "{")) + (unwind-no-exit label) + (wt-nl) (wt-go label) + (unless (null loc) (wt "}"))) + ) + +(defun c1ecase (args) (c1case args t)) + +;;If the key is declared fixnum, then we convert a case statement to a switch, +;;so that we may see the benefit of a table jump. + +(defun convert-case-to-switch (args default) + (let ((sym (gensym)) body keys) + (dolist (v (cdr args)) + (cond ((si::fixnump (car v)) (push (car v) body)) + ((consp (car v))(dolist (w (car v)) (push w body))) + ((member (car v) '(t otherwise)) + (and default + (cmperror "T or otherwise found in an ecase")) + (push t body))) + (push `(return-from ,sym (progn ,@ (cdr v))) body)) + (cond (default (push t body) + (dolist (v (cdr args)) + (cond ((atom (car v)) (push (car v) keys)) + (t (setq keys (append (car v) keys))))) + (push `(error "The key ~a for ECASE was not found in cases ~a" + ,(car args) ',keys) + body))) + `(block ,sym (si::switch ,(car args) ,@ (nreverse body))))) + + + +(defun c1case (args &optional (default nil)) + (when (endp args) (too-few-args 'case 1 0)) + (let* ((info (make-info)) + (key-form (c1expr* (car args) info)) + clauses) + (cond ((subtypep (info-type (second key-form)) 'fixnum) + (return-from c1case (c1expr (convert-case-to-switch args default ))))) + (do ((c (cdr args) (cdr c))) ((not c)) + (let* ((clause (car c))) + (cmpck (endp clause) "The CASE clause ~S is illegal." clause) + (let* ((k (pop clause))(dfp (unless default (member k '(t otherwise)))) + (keylist + (cond ((listp k) + (mapcar (lambda (key) (if (symbolp key) key (add-object key))) k)) + ((symbolp k) + (when dfp (when (cdr c) (cmperr "default case found in bad place"))) + (list k)) + ((list (add-object k))))) + (body (c1progn clause))) + (add-info info (cadr body)) + (if dfp (setq default body) (push (cons keylist body) clauses))))) + (list 'case info key-form (nreverse clauses) (or default (c1nil))))) + +;; (defun c1case (args &optional (default nil)) +;; (when (endp args) (too-few-args 'case 1 0)) +;; (let* ((info (make-info)) +;; (key-form (c1expr* (car args) info)) +;; (clauses nil)) +;; (cond ((subtypep (info-type (second key-form)) 'fixnum) +;; (return-from c1case (c1expr (convert-case-to-switch +;; args default ))))) +;; (dolist (clause (cdr args)) +;; (cmpck (endp clause) "The CASE clause ~S is illegal." clause) +;; (case (car clause) +;; ((nil)) +;; ((t otherwise) +;; (when default +;; (cmperr (if (eq default 't) +;; "ECASE had an OTHERWISE clause." +;; "CASE had more than one OTHERWISE clauses."))) +;; (setq default (c1progn (cdr clause))) +;; (add-info info (cadr default))) +;; (t (let* ((keylist +;; (cond ((consp (car clause)) +;; (mapcar #'(lambda (key) (if (symbolp key) key +;; (add-object key))) +;; (car clause))) +;; ((symbolp (car clause)) (list (car clause))) +;; (t (list (add-object (car clause)))))) +;; (body (c1progn (cdr clause)))) +;; (add-info info (cadr body)) +;; (push (cons keylist body) clauses))))) +;; (list 'case info key-form (reverse clauses) (or default (c1nil))))) + +(defun c2case (key-form clauses default + &aux (cvar (next-cvar)) (*vs* *vs*) (*inline-blocks* 0)) + (setq key-form (car (inline-args (list key-form) '(t)))) + (wt-nl "{object V" cvar "= " key-form ";") + + (dolist (clause clauses) + (let* ((label (next-label)) + (keylist (car clause)) + (local-label nil)) + (do () + ((<= (length keylist) 5)) + (when (null local-label) (setq local-label (next-label))) + (wt-nl "if(") + (dotimes (i 5) + (cond ((symbolp (car keylist)) + (wt "(V" cvar "== ") + (case (car keylist) + ((t) (wt "Ct")) + ((nil) (wt "Cnil")) + (otherwise (wt (vv-str (add-symbol (car keylist)))))) + (wt ")")) + (t (wt "eql(V" cvar "," (vv-str (car keylist)) ")"))) + (when (< i 4) (wt-nl "|| ")) + (pop keylist)) + (wt ")") + (wt-go local-label)) + + (when keylist + (wt-nl "if(") + (do () + ((endp keylist)) + (cond ((symbolp (car keylist)) + (wt "(V" cvar "!= ") + (case (car keylist) + ((t) (wt "Ct")) + ((nil) (wt "Cnil")) + (otherwise (wt (vv-str (add-symbol (car keylist)))))) + (wt ")")) + (t (wt "!eql(V" cvar "," (vv-str (car keylist)) ")"))) + (unless (endp (cdr keylist)) (wt-nl "&& ")) + (pop keylist)) + (wt ")") + (wt-go label) + (when local-label (wt-label local-label)) + (let ((*unwind-exit* (cons 'JUMP *unwind-exit*))) (c2expr (cdr clause))) + (wt-label label)))) + + (if (eq default 't) + (progn (wt-nl "FEerror(\"The ECASE key value ~s is illegal.\",1,V" cvar ");") + (unwind-exit nil 'jump)) + (c2expr default)) + + (wt "}") + (close-inline-blocks)) + + diff --git a/cmpnew/gcl_cmpinit.lsp b/cmpnew/gcl_cmpinit.lsp new file mode 100755 index 0000000..6185b16 --- /dev/null +++ b/cmpnew/gcl_cmpinit.lsp @@ -0,0 +1,7 @@ +;(proclaim '(optimize (safety 0) (space 3))) +;(proclaim '(optimize (safety 2) (space 3))) +(load "../lsp/sys-proclaim.lisp") +(load "sys-proclaim.lisp") +(setq compiler::*eval-when-defaults* '(compile eval load)) +;(load "cmptop.lsp") +;(dolist (v '( cmpeval cmpopt cmptype cmpbind cmpinline cmploc cmpvar cmptop cmplet cmpcall cmpmulti cmplam cmplabel cmpeval )) (si::nload (format nil "~(~a~).lsp" v))) diff --git a/cmpnew/gcl_cmpinline.lsp b/cmpnew/gcl_cmpinline.lsp new file mode 100755 index 0000000..21e9257 --- /dev/null +++ b/cmpnew/gcl_cmpinline.lsp @@ -0,0 +1,715 @@ +;;; CMPINLINE Open coding optimizer. +;;; +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +(in-package 'compiler) + +;;; Pass 1 generates the internal form +;;; ( id info-object . rest ) +;;; for each form encountered. + +;;; Change changed-vars and referrred-vars slots in info structure to arrays +;;; for dramatic compilation speed improvements when the number of variables +;;; are large, as occurs at present in running the random-int-form tester. +;;; 20040320 CM + +(defmacro mia (x y) `(si:make-vector t ,x t ,y nil 0 nil nil)) +;(defmacro mia (x y) `(make-array ,x :adjustable t :fill-pointer ,y)) +(defmacro eql-not-nil (x y) `(and ,x (eql ,x ,y))) + +(defstruct (info (:copier old-copy-info)) + (type t) ;;; Type of the form. + (sp-change nil) ;;; Whether execution of the form may change + ;;; the value of a special variable *VS*. + (volatile nil) ;;; whether there is a possible setjmp + (changed-array (mia 10 0)) ;;; List of var-objects changed by the form. + (referred-array (mia 10 0)) ;;; List of var-objects referred in the form. + ) + +(defun copy-array (array) + (declare ((vector t) array)) + (let ((new-array (mia (the fixnum (array-total-size array)) (length array)))) + (declare ((vector t) new-array)) + (do ((i 0 (1+ i))) ((>= i (length array)) new-array) + (declare (fixnum i)) + (setf (aref new-array i) (aref array i))))) + +(defun copy-info (info) + (let ((new-info (old-copy-info info))) + (setf (info-referred-array new-info) + (copy-array (info-referred-array info))) + (setf (info-changed-array new-info) + (copy-array (info-changed-array info))) + new-info)) + +(defun bsearchleq (x a i j le) + (declare (object x le) ((vector t) a) (fixnum i j)) + (when (eql i j) + (return-from bsearchleq (if (or le (and (< i (length a)) (eq x (aref a i)))) i (length a)))) + (let* ((k (the fixnum (+ i (the fixnum (ash (the fixnum (- j i) ) -1))))) + (y (aref a k))) + (declare (fixnum k) (object y)) + (cond ((si::objlt x y) + (bsearchleq x a i k le)) + ((eq x y) k) + (t (bsearchleq x a (1+ k) j le))))) + +(defun push-array (x ar s lin) + (declare (object x lin) ((vector t) ar) (fixnum s) (ignore lin)) +; (j (if lin +; (do ((k s (1+ k))) ((or (eql k (length ar)) (si::objlt x (aref ar k)) (eq x (aref ar k))) k) +; (declare (fixnum k))) +; (bsearchleq x ar s (length ar))))) + (let ((j (bsearchleq x ar s (length ar) t))) + (declare (fixnum j)) + (when (and (< j (length ar)) (eq (aref ar j) x)) + (return-from push-array -1)) + (let ((ar (if (eql (length ar) (the fixnum (array-total-size ar))) + (adjust-array ar (the fixnum (* 2 (length ar)))) + ar))) + (declare ((vector t) ar)) + (do ((i (length ar) (1- i))) ((<= i j)) + (declare (fixnum i)) + (setf (aref ar i) (aref ar (the fixnum (1- i))))) + (setf (aref ar j) x) + (setf (fill-pointer ar) (the fixnum (1+ (length ar)))) + j))) + + +(defmacro do-array ((v oar) &rest body) + (let ((count (gensym)) (ar (gensym))) + `(let* ((,ar ,oar)) + (declare ((vector t) ,ar)) + (do ((,count 0 (1+ ,count))) ((eql ,count (length ,ar))) + (declare (fixnum ,count)) + (let ((,v (aref ,ar ,count))) + ,@body))))) + +(defmacro in-array (v ar) + `(< (bsearchleq ,v ,ar 0 (length ,ar) nil) (length ,ar))) + + +(defmacro do-referred ((v info) &rest body) + `(do-array (,v (info-referred-array ,info)) ,@body)) +(defmacro do-changed ((v info) &rest body) + `(do-array (,v (info-changed-array ,info)) ,@body)) +(defmacro is-referred (var info) + `(in-array ,var (info-referred-array ,info))) +(defmacro is-changed (var info) + `(in-array ,var (info-changed-array ,info))) +(defmacro push-referred (var info) + `(push-array ,var (info-referred-array ,info) 0 nil)) +(defmacro push-changed (var info) + `(push-array ,var (info-changed-array ,info) 0 nil)) +(defmacro push-referred-with-start (var info s lin) + `(push-array ,var (info-referred-array ,info) ,s ,lin)) +(defmacro push-changed-with-start (var info s lin) + `(push-array ,var (info-changed-array ,info) ,s ,lin)) +(defmacro changed-length (info) + `(length (info-changed-array ,info))) +(defmacro referred-length (info) + `(length (info-referred-array ,info))) + + +(defvar *info* (make-info)) + +(defun mlin (x y) + (declare (fixnum x y)) + (when (<= y 3) + (return-from mlin nil)) + (let ((ly + (do ((tl y (ash tl -1)) (k -1 (1+ k))) ((eql tl 0) k) + (declare (fixnum k tl))))) + (declare (fixnum ly)) + (let ((lyr (the fixnum (truncate y (the fixnum (1- ly)))))) + (declare (fixnum lyr)) + (> x (the fixnum (1+ lyr)))))) + +(defun add-info (to-info from-info) + ;; Allow nil from-info without error CM 20031030 + (unless from-info + (return-from add-info to-info)) + (let* ((s 0) + (lin)); (mlin (changed-length from-info) (changed-length to-info)))) + (declare (fixnum s) (object lin)) + (do-changed (v from-info) + (let ((res (push-changed-with-start v to-info s lin))) + (declare (fixnum res)) + (when (>= res 0) + (setq s (the fixnum (1+ res))))))) + (let* ((s 0) + (lin)); (mlin (referred-length from-info) (referred-length to-info)))) + (declare (fixnum s) (object lin)) + (do-referred (v from-info) + (let ((res (push-referred-with-start v to-info s lin))) + (declare (fixnum res)) + (when (>= res 0) + (setq s (the fixnum (1+ res))))))) + (when (info-sp-change from-info) + (setf (info-sp-change to-info) t)) + ;; Return to-info, CM 20031030 + to-info) + +(defun args-info-changed-vars (var forms) + (case (var-kind var) + ((LEXICAL FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT OBJECT) + (dolist** (form forms) + (when (is-changed var (cadr form)) + (return-from args-info-changed-vars t)))) + (REPLACED nil) + (t (dolist** (form forms nil) + (when (or (is-changed var (cadr form)) + (info-sp-change (cadr form))) + (return-from args-info-changed-vars t))))) + ) + +;; Variable references in arguments can also be via replaced variables +;; (see gcl_cmplet.lsp) It appears that this is not necessary when +;; checking for changed variables, as matches would appear to require +;; that the variable not be replaced. It might be better to provide a +;; new slot in the var structure to point to the variable by which one +;; is replaced -- one would need to consider chains in such a case. +;; Here we match on the C variable reference, which should be complete. +;; 20040306 CM + +(defun var-rep-loc (x) + (and + (eq (var-kind x) 'replaced) + (consp (var-loc x)) ;; may not be necessary, but vars can also be replaced to 'locations + ;; see gcl_cmplet.lsp + (cadr (var-loc x)))) + +(defun is-rep-referred (var info) + (let ((rx (var-rep-loc var))) + (do-referred (v info) + (let ((ry (var-rep-loc v))) + (when (or (eql-not-nil (var-loc var) ry) + (eql-not-nil (var-loc v) rx) + (eql-not-nil rx ry)) + (return-from is-rep-referred t)))))) + +(defun args-info-referred-vars (var forms) + (case (var-kind var) + ((LEXICAL REPLACED FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT OBJECT) + (dolist** (form forms nil) + (when (or (is-referred var (cadr form)) + (is-rep-referred var (cadr form))) + (return-from args-info-referred-vars t)))) + (t (dolist** (form forms nil) + (when (or (is-referred var (cadr form)) + (is-rep-referred var (cadr form)) + (info-sp-change (cadr form))) + (return-from args-info-referred-vars t)))) + )) + +;;; Valid property names for open coded functions are: +;;; INLINE +;;; 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 } side-effect new-object { string | function } ). +;;; +;;; For each open-codable function, open coding will occur only if there exits +;;; an appropriate property with the argument types equal to 'types' and with +;;; the return-type equal to 'type'. The third element +;;; is T if and only if side effects may occur by the call of the function. +;;; Even if *VALUE-TO-GO* is TRASH, open code for such a function with side +;;; effects must be included in the compiled code. +;;; The forth element is T if and only if the result value is a new Lisp +;;; object, i.e., it must be explicitly protected against GBC. + +(defvar *inline-functions* nil) +(defvar *inline-blocks* 0) +;;; *inline-functions* holds: +;;; (...( function-name . inline-info )...) +;;; +;;; *inline-blocks* holds the number of temporary cvars used to save +;;; intermediate results during evaluation of inlined function calls. +;;; This variable is used to close up blocks introduced to declare static +;;; c variables. + +(defvar *special-types* '(FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT integer)) + +(defun inc-inline-blocks() + (cond ((consp *inline-blocks*) + (incf (car *inline-blocks*))) + (t (incf *inline-blocks*)))) + +(defun inline-args (forms types &optional fun &aux (locs nil) ii) + (do ((forms forms (cdr forms)) + (types types (cdr types))) + ((endp forms) (nreverse locs)) + (declare (object forms types)) + (let ((form (car forms)) + (type (car types))) + (declare (object form type)) + (case (car form) + (LOCATION (push (coerce-loc (caddr form) type) locs)) + (VAR + (cond ((args-info-changed-vars (caaddr form) (cdr forms)) + (cond ((and (member (var-kind (caaddr form)) + *special-types*) + (eq type (var-kind (caaddr form)))) + (let ((cvar (next-cvar))) + (wt-nl "{" (rep-type type) "V" cvar "= V" + (var-loc (caaddr form)) ";") + (push (list 'cvar cvar 'inline-args) locs) + (inc-inline-blocks))) + (t + (let ((temp (wt-c-push))) + (wt-nl temp "= ") + (wt-var (caaddr form) (cadr (caddr form))) + (wt ";") + (push (coerce-loc temp type) locs))))) + ((and (member (var-kind (caaddr form)) + '(FIXNUM LONG-FLOAT SHORT-FLOAT INTEGER)) + (not (eq type (var-kind (caaddr form))))) + (let ((temp (cs-push type))) + (wt-nl "V" temp " = " + (coerce-loc (cons 'var (caddr form)) type) ";") + (push (list 'cvar temp) locs))) + (t (push (coerce-loc (cons 'VAR (caddr form)) type) + locs)))) + (CALL-GLOBAL + (if (let ((fname (caddr form))) + (and (inline-possible fname) + (setq ii (get-inline-info + fname (cadddr form) + (info-type (cadr form)))) + (progn (save-avma ii) t))) + (let ((loc (get-inline-loc ii (cadddr form)))) + (cond + ((or (and (flag-p (caddr ii) ans)(not *c-gc*)) + ; returns new object + (and (member (cadr ii) + '(FIXNUM LONG-FLOAT SHORT-FLOAT)) + (not (eq type (cadr ii))))) + (let ((temp (cs-push type))) + (wt-nl "V" temp " = " (coerce-loc loc type) ";") + (push (list 'cvar temp) locs)) + ) + ((or (need-to-protect (cdr forms) (cdr types)) + ;;if either new form or side effect, + ;;we don't want double evaluation + (and (flag-p (caddr ii) allocates-new-storage) + (or (null fun) + ;; Any fun such as list,list* which + ;; does not cause side effects or + ;; do double eval (ie not "@..") + ;; could go here. + (not + (si::memq + fun '(list-inline list*-inline))))) + (flag-p (caddr ii) is) + (and (flag-p (caddr ii) set) ; side-effectp + (not (null (cdr forms))))) + (let (cvar) + (cond + ((eq type t) + (setq cvar (cs-push)) + (wt-nl "V" cvar "= ") + (wt-loc loc)) + (t (setq cvar (next-cvar)) + (wt-nl "{" (rep-type type) "V" cvar "= ") + (case type + (fixnum (wt-fixnum-loc loc)) + (integer (wt-integer-loc loc 'inline-args)) + (character (wt-character-loc loc)) + (long-float (wt-long-float-loc loc)) + (short-float (wt-short-float-loc loc)) + (otherwise (wt-loc loc))) + (inc-inline-blocks))) + (wt ";") + (push (list 'cvar cvar 'inline-args) locs) + )) + (t (push (coerce-loc loc type) locs)))) + (let ((temp (if *c-gc* (list 'cvar (cs-push)) (list 'vs (vs-push))))) + (let ((*value-to-go* temp)) (c2expr* form)) + (push (coerce-loc temp type) locs)))) + (structure-ref + (push (coerce-loc-structure-ref (cdr form) type) + locs)) + (SETQ + (let ((vref (caddr form)) + (form1 (cadddr form))) + (let ((*value-to-go* (cons 'var vref))) (c2expr* form1)) + (cond ((eq (car form1) 'LOCATION) + (push (coerce-loc (caddr form1) type) locs)) + (t + (setq forms (list* form + (list 'VAR (cadr form) vref) + (cdr forms))) + ;; want (setq types (list* type type (cdr types))) + ;; but type is first of types + (setq types (list* type types)))))) + (t (let + ((temp + (cond (*c-gc* + (cond ((eq type t) + (list 'cvar (cs-push))) + (t (push (cons type (next-cvar)) *c-vars*) + (list 'var + (make-var + :type type + :kind + (if (member type + *special-types*) + type 'object) + :loc (cdar *c-vars*)) + nil + )))) + (t (list 'vs (vs-push)))))) + (let ((*value-to-go* temp)) + (c2expr* form) + (push (coerce-loc temp type) locs)))))))) + +(defun coerce-loc (loc type) + (case type + (fixnum (list 'FIXNUM-LOC loc)) + (integer (list 'integer-loc loc )) + (character (list 'CHARACTER-LOC loc)) + (long-float (list 'LONG-FLOAT-LOC loc)) + (short-float (list 'SHORT-FLOAT-LOC loc)) + (t loc))) + +(defun get-inline-loc (ii args &aux (fun (car (cdddr ii))) locs) + ;;; Those functions that use GET-INLINE-LOC must rebind the variable *VS*. + (setq locs (inline-args args (car ii) fun)) + (when (and (stringp fun) (char= (char (the string fun) 0) #\@)) + (let ((i 1) (saves nil)) + (declare (fixnum i)) + (do ((char (char (the string fun) i) + (char (the string fun) i))) + ((char= char #\;) (incf i)) + (declare (character char)) + (push (the fixnum (- (char-code char) #.(char-code #\0))) saves) + (incf i)) + (do ((l locs (cdr l)) + (n 0 (1+ n)) + (locs1 nil)) + ((endp l) (setq locs (nreverse locs1))) + (declare (fixnum n) (object l)) + (if (member n saves) + (let* ((loc1 (car l)) (loc loc1) (coersion nil)) + (declare (object loc loc1)) + (when (and (consp loc1) + (member (car loc1) + '(FIXNUM-LOC integer-loc CHARACTER-LOC + LONG-FLOAT-LOC SHORT-FLOAT-LOC))) + (setq coersion (car loc1)) + (setq loc (cadr loc1)) ; remove coersion + ) + (cond + ((and (consp loc) + (or + (member (car loc) + '(INLINE INLINE-COND)) + (and (member (car loc) + '( + INLINE-FIXNUM inline-integer + INLINE-CHARACTER INLINE-LONG-FLOAT + INLINE-SHORT-FLOAT)) + (or (flag-p (cadr loc) allocates-new-storage) + (flag-p (cadr loc) side-effect-p)) + ))) + (wt-nl "{") + (inc-inline-blocks) + (let ((cvar (next-cvar))) + (push (list 'CVAR cvar) locs1) + (case coersion + ((nil) (wt "object V" cvar "= ") (wt-loc loc1)) + (FIXNUM-LOC (wt "int V" cvar "= ") (wt-fixnum-loc loc)) + (integer-loc (wt "MP_INT * V" cvar "= ") (wt-integer-loc loc + 'get-inline-locs)) + (CHARACTER-LOC + (wt "unsigned char V" cvar "= ") (wt-character-loc loc)) + (LONG-FLOAT-LOC + (wt "double V" cvar "= ") (wt-long-float-loc loc)) + (SHORT-FLOAT-LOC + (wt "float V" cvar "= ") (wt-short-float-loc loc)) + (t (baboon)))) + (wt ";") + ) + (t (push loc1 locs1)))) + (push (car l) locs1))))) + (list (inline-type (cadr ii)) + (caddr ii) + fun + locs) + ) +(defvar *inline-types* + '((boolean . INLINE-COND) + (fixnum . INLINE-FIXNUM) + (character . INLINE-CHARACTER) + (long-float . INLINE-LONG-FLOAT) + (short-float . INLINE-SHORT-FLOAT) + (integer . INLINE-INTEGER) + (t . INLINE))) + +(defun inline-type (type) + (or (cdr (assoc type *inline-types*)) 'inline)) + +(defun get-inline-info (fname args return-type &aux x ii) + (and (fast-link-proclaimed-type-p fname args) + (add-fast-link fname return-type args)) + (setq args (mapcar #'(lambda (form) (info-type (cadr form))) args)) + (when (if *safe-compile* + (setq x (get fname 'inline-safe)) + (setq x (get fname 'inline-unsafe))) + (dolist** (y x nil) + (when (setq ii (inline-type-matches y args return-type)) + (return-from get-inline-info ii)))) + (when (setq x (get fname 'inline-always)) + (dolist** (y x) + (when (setq ii (inline-type-matches y args return-type)) + (return-from get-inline-info ii)))) + (dolist* (x *inline-functions*) + (when (and (eq (car x) fname) + (setq ii (inline-type-matches (cdr x) args return-type))) + (return-from get-inline-info ii))) + nil) + +(defun inline-type-matches (inline-info arg-types return-type + &aux (rts nil)) + (if (not (typep (third inline-info) 'fixnum)) + (fix-opt inline-info)) + (if (member 'integer (car inline-info)) + (return-from inline-type-matches nil)) + (if (and (let ((types (car inline-info))) + (declare (object types)) + (dolist** (arg-type arg-types (or (equal types '(*)) + (endp types))) + (when (endp types) (return nil)) + (cond ((equal types '(*)) + (setq types '(t *)))) + (cond ((eq (car types) 'fixnum-float) + (cond ((type>= 'fixnum arg-type) + (push 'fixnum rts)) + ((type>= 'long-float arg-type) + (push 'long-float rts)) + ((type>= 'short-float arg-type) + (push 'short-float rts)) + (t (return nil)))) + ((type>= (car types) arg-type) + (push (car types) rts)) + (t (return nil))) + (pop types))) + (type>= (cadr inline-info) return-type)) + (cons (nreverse rts) (cdr inline-info)) + nil) + ) + +(defun need-to-protect (forms types &aux ii) + (do ((forms forms (cdr forms)) + (types types (cdr types))) + ((endp forms) nil) + (declare (object forms types)) + (let ((form (car forms))) + (declare (object form)) + (case (car form) + (LOCATION) + (VAR + (when (or (args-info-changed-vars (caaddr form) (cdr forms)) + (and (member (var-kind (caaddr form)) + '(FIXNUM LONG-FLOAT SHORT-FLOAT)) + (not (eq (car types) + (var-kind (caaddr form)))))) + (return t))) + (CALL-GLOBAL + (let ((fname (caddr form))) + (declare (object fname)) + (when + (or (not (inline-possible fname)) + (null (setq ii (get-inline-info + fname (cadddr form) + (info-type (cadr form))))) + (flag-p (caddr ii) allocates-new-storage) + (flag-p (caddr ii) set) + (flag-p (caddr ii) is) + (and (member (cadr ii) + '(fixnum long-float short-float)) + (not (eq (car types) (cadr ii)))) + (need-to-protect (cadddr form) (car ii))) + (return t)))) + (structure-ref + (when (need-to-protect (list (caddr form)) '(t)) + (return t))) + (t (return t))))) + ) + +(defun wt-c-push () + (cond (*c-gc* (inc-inline-blocks) + (let ((tem (next-cvar))) + (wt "{" *volatile* "object V" tem ";") + (list 'cvar tem))) + (t (list 'VS (vs-push))))) + +(defun close-inline-blocks ( &aux (bl *inline-blocks*)) + (when (consp bl) + (if (eql (cdr bl) 'restore-avma) (wt "restore_avma;")) + (setq bl (car bl))) + (dotimes** (i bl) (wt "}"))) + +(si:putprop 'inline 'wt-inline 'wt-loc) +(si:putprop 'inline-cond 'wt-inline-cond 'wt-loc) +(si:putprop 'inline-fixnum 'wt-inline-fixnum 'wt-loc) +(si:putprop 'inline-integer 'wt-inline-integer 'wt-loc) +(si:putprop 'inline-character 'wt-inline-character 'wt-loc) +(si:putprop 'inline-long-float 'wt-inline-long-float 'wt-loc) +(si:putprop 'inline-short-float 'wt-inline-short-float 'wt-loc) + +(defun wt-inline-loc (fun locs &aux (i 0) (max -1)) + (declare (fixnum i max)) + (cond ((stringp fun) + (when (char= (char (the string fun) 0) #\@) + (setq i 1) + (do () + ((char= (char (the string fun) i) #\;) (incf i)) + (incf i))) + (do ((size (length (the string fun)))) + ((>= i size)) + (declare (fixnum size )) + (let ((char (char (the string fun) i))) + (declare (character char)) + (cond ((char= char #\#) + (let ((ch (char (the string fun) + (the fixnum (1+ i)))) + (n 0)) + (cond ((or (eql ch #\*) (eql ch #\?));#? ensures 'first' vararg is initialized + (let* ((f (char= (char fun (1- i)) #\()) + (e (char= (char fun (+ 2 i)) #\))) + (locs (nthcdr (1+ max) locs)) + (locs (or locs (when (eql ch #\?) `((fixnum-value nil 0)))))) + (dolist (v locs (unless (or f e) (wt ","))) + (unless f (wt ",")) + (setq f nil) + (wt-loc v)))) + ((digit-char-p ch 10) + (setq n (- (char-code ch) + (char-code #\0))) + (when (and + (> (length fun) (+ i 2)) + (progn (setq ch (char (the string fun) + (+ i 2))) + (digit-char-p ch))) + (setq n (+ (* n 10) + (- (char-code ch) + (char-code #\0)))) + (incf i)) + (cond ((>= n max) (setq max n))) + (wt-loc (nth n locs))))) + (incf i 2)) + (t + (princ char *compiler-output1*) + (incf i))))) + ) + (t (apply fun locs)))) + +(defun wt-inline (side-effectp fun locs) + (declare (ignore side-effectp)) + (wt-inline-loc fun locs)) + +(defun wt-inline-cond (side-effectp fun locs) + (declare (ignore side-effectp)) + (wt "(") (wt-inline-loc fun locs) (wt "?Ct:Cnil)")) + +(defun wt-inline-fixnum (side-effectp fun locs) + (declare (ignore side-effectp)) + (when (zerop *space*) (wt "CMP")) + (wt "make_fixnum((long)(") (wt-inline-loc fun locs) (wt "))")) + +(defun wt-inline-integer (side-effectp fun locs) + (declare (ignore side-effectp)) + (wt "make_integer(") (wt-inline-loc fun locs) (wt ")")) + +(defun wt-inline-character (side-effectp fun locs) + (declare (ignore side-effectp)) + (wt "code_char(") (wt-inline-loc fun locs) (wt ")")) + +(defun wt-inline-long-float (side-effectp fun locs) + (declare (ignore side-effectp)) + (wt "make_longfloat(") (wt-inline-loc fun locs) (wt ")")) + +(defun wt-inline-short-float (side-effectp fun locs) + (declare (ignore side-effectp)) + (wt "make_shortfloat(") (wt-inline-loc fun locs) (wt ")")) + +(defun args-cause-side-effect (forms &aux ii) + (dolist** (form forms nil) + (case (car form) + ((LOCATION VAR structure-ref)) + (CALL-GLOBAL + (let ((fname (caddr form))) + (declare (object fname)) + (unless (and (inline-possible fname) + (setq ii (get-inline-info + fname (cadddr form) + (info-type (cadr form)))) + (progn (fix-opt ii) + (not (flag-p (caddr ii) side-effect-p))) + ) + (return t)))) + (otherwise (return t))))) + +;;; Borrowed from CMPOPT.LSP + +(defun list-inline (&rest x &aux tem (n (length x))) + (cond ((setq tem + (and (consp *value-to-go*) + (eq (car *value-to-go*) 'var) + (eq (var-type (second *value-to-go*)) :dynamic-extent))) + (wt "(ALLOCA_CONS(" n "),ON_STACK_LIST(" n)) + (t (wt "list(" (length x)))) + (dolist (loc x) (wt #\, loc)) + (wt #\)) + (if tem (wt #\))) +) + + +(defun list*-inline (&rest x) + (case (length x) + (1 (wt (car x))) + (2 (wt "make_cons(" (car x) "," (cadr x) ")")) + (otherwise + (wt "listA(" (length x)) (dolist (loc x) (wt #\, loc)) (wt #\))))) + +;;; Borrowed from LFUN_LIST.LSP + +(defun defsysfun (fname cname-string arg-types return-type + never-change-special-var-p predicate) + ;;; The value NIL for each parameter except for fname means "not known". + (when cname-string (si:putprop fname cname-string 'Lfun)) + (when arg-types + (si:putprop fname (mapcar #'(lambda (x) + (if (eq x '*) '* (type-filter x))) + arg-types) 'arg-types)) + + (when return-type + (let ((rt (function-return-type (if (atom return-type) + (list return-type) + return-type)))) + (or (consp rt) (setq rt (list rt))) + (si:putprop fname (if (null (cdr rt)) (car rt) (cons 'values rt)) + 'return-type))) + (when never-change-special-var-p (si:putprop fname t 'no-sp-change)) + (when predicate (si:putprop fname t 'predicate)) + ) + diff --git a/cmpnew/gcl_cmplabel.lsp b/cmpnew/gcl_cmplabel.lsp new file mode 100755 index 0000000..64811c0 --- /dev/null +++ b/cmpnew/gcl_cmplabel.lsp @@ -0,0 +1,252 @@ +;;; CMPLABEL Exit manager. +;;; +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +(in-package 'compiler) + +(defvar *last-label* 0) +(defvar *exit*) +(defvar *unwind-exit*) +(defvar *record-call-info* nil) + +;;; *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-LONG-FLOAT, RETURN-SHORT-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), and +;;; cvar (which holds the bind stack pointer used to unbind). + +(defmacro next-label () `(cons (incf *last-label*) nil)) + +(defmacro next-label* () `(cons (incf *last-label*) t)) + +(defmacro wt-label (label) + `(when (cdr ,label) (wt-nl "goto T" (car ,label) ";")(wt-nl1 "T" (car ,label) ":;"))) + +(defmacro wt-go (label) + `(progn (rplacd ,label t) (wt "goto T" (car ,label) ";"))) + + +(defvar *restore-avma* nil) + +(defun unwind-bds (bds-cvar bds-bind) + (when (consp *inline-blocks*) (wt-nl "restore_avma; ")) + (when bds-cvar (wt-nl "bds_unwind(V" bds-cvar ");")) + (dotimes* (n bds-bind) (wt-nl "bds_unwind1;"))) + +(defun unwind-exit (loc &optional (jump-p nil) fname + &aux (*vs* *vs*) (bds-cvar nil) (bds-bind 0) type.wt) + (declare (fixnum bds-bind)) + (and *record-call-info* (record-call-info loc fname)) + (when (and (eq loc 'fun-val) + (not (eq *value-to-go* 'return)) + (not (eq *value-to-go* 'top))) + (wt-nl) (reset-top)) + (cond ((and (consp *value-to-go*) (eq (car *value-to-go*) 'jump-true)) + (set-jump-true loc (cadr *value-to-go*)) + (when (eq loc t) (return-from unwind-exit))) + ((and (consp *value-to-go*) (eq (car *value-to-go*) 'jump-false)) + (set-jump-false loc (cadr *value-to-go*)) + (when (null loc) (return-from unwind-exit)))) + (dolist* (ue *unwind-exit* (baboon)) + (cond + ((consp ue) + (cond ((eq ue *exit*) + (cond ((and (consp *value-to-go*) + (or (eq (car *value-to-go*) 'jump-true) + (eq (car *value-to-go*) 'jump-false))) + (unwind-bds bds-cvar bds-bind)) + (t + (if (or bds-cvar (plusp bds-bind)) + ;;; Save the value if LOC may possibly refer + ;;; to special binding. + (if (and (consp loc) + (or (and (eq (car loc) 'var) + (member (var-kind (cadr loc)) + '(SPECIAL GLOBAL))) + (member (car loc) + '(SIMPLE-CALL + INLINE + INLINE-COND INLINE-FIXNUM + INLINE-CHARACTER + INLINE-INTEGER + INLINE-LONG-FLOAT + INLINE-SHORT-FLOAT)))) + (cond ((and (consp *value-to-go*) + (eq (car *value-to-go*) 'vs)) + (set-loc loc) + (unwind-bds bds-cvar bds-bind)) + (t (let + ((temp (list 'cvar (cs-push)))) + (let ((*value-to-go* temp)) + (set-loc loc)) + (unwind-bds bds-cvar bds-bind) + (set-loc temp)))) + (progn (unwind-bds bds-cvar bds-bind) + (set-loc loc))) + (set-loc loc)))) + + (when jump-p + (when (consp *inline-blocks*) (wt-nl "restore_avma; ")) + (wt-nl) (wt-go *exit*)) + (return)) + ;; Add (sup .var) handling in unwind-exit -- in + ;; c2multiple-value-prog1 and c2-multiple-value-call, apparently + ;; alone, c2expr-top is used to evaluate arguments, presumably to + ;; preserve certain states of the value stack for the purposes of + ;; retrieving the final results. c2exprt-top rebinds sup, and + ;; vs_top in turn to the new sup, causing non-local exits to lose + ;; the true top of the stack vital for subsequent function + ;; evaluations. We unwind this stack supremum variable change here + ;; when necessary. CM 20040301 + ((eq (car ue) 'sup) + (when (and ;; If we've pushed the sup, we've always reset vs_top, as we're + ;; using c2expr-top{*}. Regardless then of whether we are + ;; explicitly unwinding a fun-val, we must reset the top, unless + ;; unless returning, when we rely on the returning code to leave + ;; the stack in the correct state, regardless of loc being a fun-val + ;; or otherwise. We might need to reset when returning and loc is not + ;; fun-val, but this appears doubtful. 20040306 CM + ;; (eq loc 'fun-val) + (not (eq *value-to-go* 'return)) + (not (eq *value-to-go* 'top))) + (wt-nl "sup=V" (cdr ue) ";") + (wt-nl) + (reset-top))) + (t (setq jump-p t)))) + ((numberp ue) (setq bds-cvar ue bds-bind 0)) + ((eq ue 'bds-bind) (incf bds-bind)) + ((eq ue 'return) + (when (eq *exit* 'return) + ;;; *VALUE-TO-GO* must be either *RETURN* or *TRASH*. + (set-loc loc) + (unwind-bds bds-cvar bds-bind) + (wt-nl "return;") + (return)) + ;;; Never reached + ) + ((eq ue 'frame) + (when (and (consp loc) + (member (car loc) + '(SIMPLE-CALL INLINE INLINE-COND INLINE-FIXNUM inline-integer + INLINE-CHARACTER INLINE-LONG-FLOAT + INLINE-SHORT-FLOAT))) + (cond ((and (consp *value-to-go*) + (eq (car *value-to-go*) 'vs)) + (set-loc loc) + (setq loc *value-to-go*)) + (t (let ((*value-to-go* (if *c-gc* (list 'cvar (cs-push)) + (list 'vs (vs-push))))) + (set-loc loc) + (setq loc *value-to-go*))))) + (wt-nl "frs_pop();")) + ((eq ue 'tail-recursion-mark)) + ((eq ue 'jump) (setq jump-p t)) + ((setq type.wt + (assoc ue + '((return-fixnum fixnum . wt-fixnum-loc) + (return-character character . wt-character-loc) + (return-short-float short-float . wt-short-float-loc) + (return-long-float long-float . wt-long-float-loc) + (return-object t . wt-loc)))) + (let ((cvar (next-cvar))) + (or (eq *exit* (car type.wt)) (wfs-error)) + (setq type.wt (cdr type.wt)) + (wt-nl "{" (rep-type (car type.wt)) "V" cvar " = ") + (funcall (cdr type.wt) loc) (wt ";") + (unwind-bds bds-cvar bds-bind) + (wt-nl "VMR" *reservation-cmacro* "(" + (if (equal (rep-type (car type.wt)) "long ") "(object)" "") + "V" cvar")}") + (return))) + (t (baboon)) + ;;; Never reached + )) + ) + +(defun unwind-no-exit (exit &aux (bds-cvar nil) (bds-bind 0)) + (declare (fixnum bds-bind)) + (dolist* (ue *unwind-exit* (baboon)) + (cond + ((consp ue) + (when (eq ue exit) + (unwind-bds bds-cvar bds-bind) + (return)) + ;; Add (sup .var) handling in unwind-exit -- in + ;; c2multiple-value-prog1 and c2-multiple-value-call, apparently + ;; alone, c2expr-top is used to evaluate arguments, presumably to + ;; preserve certain states of the value stack for the purposes of + ;; retrieving the final results. c2exprt-top rebinds sup, and + ;; vs_top in turn to the new sup, causing non-local exits to lose + ;; the true top of the stack vital for subsequent function + ;; evaluations. We unwind this stack supremum variable change here + ;; when necessary. CM 20040301 + (when (eq (car ue) 'sup) + (wt-nl "sup=V" (cdr ue) ";") + (wt-nl) + (reset-top))) + ((numberp ue) (setq bds-cvar ue bds-bind 0)) + ((eq ue 'bds-bind) (incf bds-bind)) + ((member ue '(return return-object return-fixnum return-character + return-long-float return-short-float)) + (cond ((eq exit ue) (unwind-bds bds-cvar bds-bind) + (return)) + (t (baboon))) + ;;; Never reached + ) + ((eq ue 'frame) (wt-nl "frs_pop();")) + ((eq ue 'tail-recursion-mark) + (cond ((eq exit 'tail-recursion-mark) (unwind-bds bds-cvar bds-bind) + (return)) + (t (baboon))) + ;;; Never reached + ) + ((eq ue 'jump)) + (t (baboon)) + ;;; Never reached + )) + ) + +;;; Tail-recursion optimization for a function F is possible only if +;;; 1. the value of *DO-TAIL-RECURSION* is non-nil (this is default), +;;; 2. F receives only required parameters, and +;;; 3. 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. the arguments are +;;; pushed on the stack, +;;; 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)) + (cond ((eq ue 'tail-recursion-mark) (return t)) + ((or (numberp ue) (eq ue 'bds-bind) (eq ue 'frame)) + (return nil)) + ((or (consp ue) (eq ue 'jump))) + (t (baboon))))) diff --git a/cmpnew/gcl_cmplam.lsp b/cmpnew/gcl_cmplam.lsp new file mode 100755 index 0000000..29d27bf --- /dev/null +++ b/cmpnew/gcl_cmplam.lsp @@ -0,0 +1,974 @@ +;;; CMPLAM Lambda expression. +;;; +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +(in-package 'compiler) + +;;; 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])}*] +;;; ) +;;; +;;; is transformed into +;;; +;;; ( ( { var }* ) ; required +;;; ( { (var initform svar) }* ) ; optional +;;; { var | nil } ; rest +;;; key-flag +;;; ( { ( kwd-vv-index var initform svar) }* ) ; key +;;; allow-other-keys-flag +;;; ) +;;; +;;; where +;;; svar: nil ; means svar is not supplied +;;; | var +;;; +;;; &aux parameters will be embedded into LET*. +;;; +;;; c1lambda-expr receives +;;; ( lambda-list { doc | decl }* . body ) +;;; and returns +;;; ( 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 +;;; supplied) and an implicit block. + +(defmacro ck-spec (condition) + `(unless ,condition + (cmperr "The parameter specification ~s is illegal." spec))) + +(defmacro ck-vl (condition) + `(unless ,condition + (cmperr "The lambda list ~s is illegal." vl))) + + +;;;the following code implements downward closures. +;;;These are like closures, except they are guaranteed not +;;;to survive past the exit of the function in which they +;;;are born. + + +(defmacro downward-function (x) + `(function ,x)) + +(setf (get 'downward-function 'c1special) + 'c1downward-function) + +(defun c1downward-function (x) + (let* ((tem (c1expr (list 'function (car x)))) + (info (cadr tem))) + ;; for the moment we only allow downward closures with no args + (cond ((and (consp x) (consp (car x)) + (eq (caar x) 'lambda) + (null (second (car x)))) + (do-referred (var info) + (cond ((and (eq (var-kind var) 'lexical) + (var-ref-ccb var) t) + (setf (var-kind var) 'down))) + ) + (setf (car tem) 'downward-function) + tem) + (t tem)))) + +(si::putprop 'downward-function 'c2downward-function 'c2) +(si:putprop 'make-dclosure 'wt-make-dclosure 'wt-loc) + +(defun wt-make-dclosure (cfun clink)clink ;;Dbase=base0 + (wt-nl "(DownClose"cfun".t=t_dclosure,DownClose" cfun ".dc_self=LC" cfun"," + "DownClose" cfun ".dc_env=base0,(object)&DownClose" cfun ")")) + +(defun wfs-error () + (error "This error is not supposed to occur: Contact Schelter ~ + ~%wfs@math.utexas.edu")) + +(defun wt-downward-closure-macro (cfun) + (cond (*downward-closures* + (wt-h "#define DCnames" cfun " ") + (setq *downward-closures* (delete 'dcnames *downward-closures*)) + (cond (*downward-closures* + (wt-h1 "struct dclosure ") + (do ((v *downward-closures* (cdr v))) + ((null v)) + (wt-h1 "DownClose") + (wt-h1 (car v)) + (if (cdr v) (wt-h1 ","))) + (wt-h1 ";")))))) + +(defun c2downward-function (funob) + (let ((fun (make-fun :name 'closure :cfun (next-cfun)))) + (push (list 'dclosure (if (null *clink*) nil (cons 'fun-env 0)) + *ccb-vs* fun funob) + *local-funs*) + (push fun *closures*) + (push (fun-cfun fun) *downward-closures*) + (unwind-exit (list 'make-dclosure (fun-cfun fun) *clink*)))) + + + +(defun c1lambda-expr (lambda-expr + &optional (block-name nil block-it) + &aux (requireds nil) (optionals nil) (rest nil) + (keywords nil) (key-flag nil) + lambda-list + (allow-other-keys nil) (aux-vars nil) + (aux-inits nil) doc vl spec body ss is ts + other-decls vnames + (*vars* *vars*) + (info (make-info)) + (aux-info nil) + (setjmps *setjmps*) + ) + (cmpck (endp lambda-expr) + "The lambda expression ~s is illegal." (cons 'lambda lambda-expr)) + + (multiple-value-setq (body ss ts is other-decls doc) + (c1body (cdr lambda-expr) t)) + + (when block-it (setq body (list (cons 'block (cons block-name body))))) + + (c1add-globals ss) + + (setq vl (car lambda-expr)) + (block parse + (tagbody + Lreq + (when (null vl) (return-from parse)) + (ck-vl (consp vl)) + (case (setq spec (pop vl)) + (&optional (go Lopt)) + (&rest (go Lrest)) + (&key (go Lkey)) + (&aux (go Laux))) + (let ((v (c1make-var spec ss is ts))) + (push spec vnames) + (push v *vars*) + (push v requireds)) + (go Lreq) + + Lopt + (when (null vl) (return-from parse)) + (ck-vl (consp vl)) + (case (setq spec (pop vl)) + (&rest (go Lrest)) + (&key (go Lkey)) + (&aux (go Laux))) + (cond ((not (consp spec)) + (let ((v (c1make-var spec ss is ts))) + (push spec vnames) + (push (list v (default-init (var-type v)) nil) optionals) + (push v *vars*))) + ((not (consp (cdr spec))) + (ck-spec (null (cdr spec))) + (let ((v (c1make-var (car spec) ss is ts))) + (push (car spec) vnames) + (push (list v (default-init (var-type v)) nil) optionals) + (push v *vars*))) + ((not (consp (cddr spec))) + (ck-spec (null (cddr spec))) + (let ((init (c1expr* (cadr spec) info)) + (v (c1make-var (car spec) ss is ts))) + (push (car spec) vnames) + (push + (list v (and-form-type (var-type v) init (cadr spec)) nil) + optionals) + (push v *vars*))) + (t + (ck-spec (null (cdddr spec))) + (let ((init (c1expr* (cadr spec) info)) + (v (c1make-var (car spec) ss is ts)) + (sv (c1make-var (caddr spec) ss is ts)) + ) + (push (car spec) vnames) + (push (caddr spec) vnames) + (push + (list v (and-form-type (var-type v) init (cadr spec)) sv) + optionals) + (push v *vars*) + (push sv *vars*)))) + (go Lopt) + + Lrest + (ck-vl (consp vl)) + (push (car vl) vnames) + (setq rest (c1make-var (pop vl) ss is ts)) + (push rest *vars*) + (when (null vl) (return-from parse)) + (ck-vl (consp vl)) + (case (setq spec (pop vl)) + (&key (go Lkey)) + (&aux (go Laux))) + (cmperr "Either &key or &aux is missing before ~s." spec) + + Lkey + (setq key-flag t) + (when (null vl) (return-from parse)) + (ck-vl (consp vl)) + (case (setq spec (pop vl)) + (&aux (go Laux)) + (&allow-other-keys (setq allow-other-keys t) + (when (null vl) (return-from parse)) + (ck-vl (consp vl)) + (case (setq spec (pop vl)) + (&aux (go Laux))) + (cmperr "&aux is missing before ~s." spec))) + (when (not (consp spec)) (setq spec (list spec))) + (cond ((consp (car spec)) + (ck-spec (and (keywordp (caar spec)) + (consp (cdar spec)) + (null (cddar spec)))) + (setq spec (cons (caar spec) (cons (cadar spec) (cdr spec))))) + (t + (ck-spec (symbolp (car spec))) + (setq spec (cons (intern (string (car spec)) 'keyword) + (cons (car spec) (cdr spec)))))) + (cond ((not (consp (cddr spec))) + (ck-spec (null (cddr spec))) + (let ((v (c1make-var (cadr spec) ss is ts))) + (push (cadr spec) vnames) + (push + (list (car spec) v (default-init (var-type v)) + (make-var :kind 'DUMMY)) + keywords) + (push v *vars*))) + ((not (consp (cdddr spec))) + (ck-spec (null (cdddr spec))) + (let ((init (c1expr* (caddr spec) info)) + (v (c1make-var (cadr spec) ss is ts))) + (push (cadr spec) vnames) + (push (list (car spec) v + (and-form-type (var-type v) init (caddr spec)) + (make-var :kind 'DUMMY)) + keywords) + (push v *vars*))) + (t + (ck-spec (null (cddddr spec))) + (let ((init (c1expr* (caddr spec) info)) + (v (c1make-var (cadr spec) ss is ts)) + (sv (c1make-var (cadddr spec) ss is ts))) + (push (cadr spec) vnames) + (push (cadddr spec) vnames) + (push (list (car spec) v + (and-form-type (var-type v) init (caddr spec)) + sv) + keywords) + (push v *vars*) + (push sv *vars*)))) + (go Lkey) + + Laux + (setq aux-info (make-info)) + Laux1 + (when (null vl) (add-info info aux-info) (return-from parse)) + (ck-vl (consp vl)) + (setq spec (pop vl)) + (cond ((consp spec) + (cond ((not (consp (cdr spec))) + (ck-spec (null (cdr spec))) + (let ((v (c1make-var (car spec) ss is ts))) + (push (car spec) vnames) + (push (default-init (var-type v)) aux-inits) + (push v aux-vars) + (push v *vars*))) + (t + (ck-spec (null (cddr spec))) + (let ((init (c1expr* (cadr spec) aux-info)) + (v (c1make-var (car spec) ss is ts))) + (push (car spec) vnames) + (push (and-form-type (var-type v) init (cadr spec)) + aux-inits) + (push v aux-vars) + (push v *vars*))))) + (t + (let ((v (c1make-var spec ss is ts))) + (push spec vnames) + (push (default-init (var-type v)) aux-inits) + (push v aux-vars) + (push v *vars*)))) + (go Laux1) + ) + ) + (setq requireds (nreverse requireds) + optionals (nreverse optionals) + keywords (nreverse keywords) + aux-vars (nreverse aux-vars) + aux-inits (nreverse aux-inits)) + + (check-vdecl vnames ts is) + + (setq body (c1decl-body other-decls body)) + + (add-info info (cadr body)) + + (dolist** (var requireds) (check-vref var)) + (dolist** (opt optionals) + (check-vref (car opt)) + (when (caddr opt) (check-vref (caddr opt)))) + (when rest (check-vref rest)) + (dolist** (kwd keywords) + (check-vref (cadr kwd)) + (when (cadddr kwd) (check-vref (cadddr kwd)))) + (dolist** (var aux-vars) (check-vref var)) + + (when aux-vars + (add-info aux-info (cadr body)) + (setq body (list 'let* aux-info aux-vars aux-inits body)) + (or (eql setjmps *setjmps*) (setf (info-volatile aux-info) t))) + + (setq body (fix-down-args requireds body block-name)) + (setq lambda-list + (list requireds optionals rest key-flag keywords allow-other-keys)) + (and *record-call-info* (record-arg-info lambda-list)) + (list 'lambda + info + lambda-list + doc + body) + ) + + +;;this makes a let for REQUIREDS which are used in a downward +;;lexical closure + +(defun fix-down-args(requireds body name &aux auxv auxinit info v) + (let ((types (get name 'proclaimed-arg-types)) + (fixed (get name 'fixed-args))) + (do ((vv requireds (cdr vv)) + (typ types (cdr typ))) + ((null vv)) + (setq v (car vv)) + (cond ((not (or fixed (eq (car typ) t))) + (return-from fix-down-args body)) + ((and (eq (var-kind v) 'DOWN) (eq (var-loc v) 'object)) + ;;a downward variable could not have been special + ;;and must be type t. We create a new variable + ;;for the arg, and bind the old one to it. + (let* ((new (c1make-var (var-name v) nil nil nil)) + (init + (list 'var + (or info (setq info (make-info))) + (list new nil)))) + (push v auxv) + (setf (car vv) new) + (push-referred new info) + (push init auxinit))))) + (if auxv (list 'let* info auxv auxinit body) + body))) + +(defun the-parameter (name) + (cmpck (not (symbolp name)) "The parameter ~s is not a symbol." name) + (cmpck (constantp name) "The constant ~s is being bound." name) + name + ) + +(defvar *rest-on-stack* nil) ;; non nil means put rest arg on C stack. + +(defun c2lambda-expr (lambda-list body &optional (fname nil s-fname)) + (let ((*tail-recursion-info* ;;; Tail recursion possible if + (if (and *do-tail-recursion* + s-fname ;;; named function, + (dolist* (var (car lambda-list) t) + (when (var-ref-ccb var) (return nil))) + ;;; no required is closed in a closure, + (null (cadr lambda-list)) ;;; no optionals, + (null (caddr lambda-list)) ;;; no rest parameter, and + (not (cadddr lambda-list))) ;;; no keywords. + (cons fname (car lambda-list)) + nil))) + (let ((*rest-on-stack* + (cond ((and (caddr lambda-list) + (eq (var-type (caddr lambda-list)) :dynamic-extent)) + t) + (t *rest-on-stack*)))) + (if (cadddr lambda-list) ;;; key-flag + (c2lambda-expr-with-key lambda-list body) + (c2lambda-expr-without-key lambda-list body))) + )) + +(defun c2lambda-expr-without-key + (lambda-list body + &aux (requireds (car lambda-list)) + (optionals (cadr lambda-list)) + (rest (caddr lambda-list)) + (labels nil) + (*unwind-exit* *unwind-exit*) + (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*) + (block-p nil) + ) + (declare (object requireds optionals rest)) + ;;; Allocate immediate-type parameters. + + (flet ((do-decl (var) + (let ((kind (c2var-kind var))) + (declare (object kind)) + (when kind + (let ((cvar (next-cvar))) + (setf (var-kind var) kind) + (setf (var-loc var) cvar) + (wt-nl) + (unless block-p (wt "{") (setq block-p t)) + (wt-var-decl var) + ))))) + + (dolist** (v requireds) (do-decl v)) + (dolist** (opt optionals) + (do-decl (car opt)) + (when (caddr opt) (do-decl (caddr opt)))) + (when rest (do-decl rest)) + ) + ;;; check arguments + (when (or *safe-compile* *compiler-check-args*) + (cond ((or rest optionals) + (when requireds + (wt-nl "if(vs_top-vs_base<" (length requireds) + ") too_few_arguments();")) + (unless rest + (wt-nl "if(vs_top-vs_base>" + (+ (length requireds) (length optionals)) + ") too_many_arguments();"))) + (t (wt-nl "check_arg(" (length requireds) ");")))) + + ;;; Allocate the parameters. + (dolist** (var requireds) (setf (var-ref var) (vs-push))) + (dolist** (opt optionals) (setf (var-ref (car opt)) (vs-push))) + (when rest (setf (var-ref rest) (vs-push))) + (dolist** (opt optionals) + (when (caddr opt) (setf (var-ref (caddr opt)) (vs-push)))) + + ;;; Bind required parameters. + (dolist** (var requireds) (c2bind var)) + + ;;; Bind optional parameters as long as there remain arguments. + ;;; The compile-time binding is discarded because they are bound again. + (when (and (or optionals rest) (not (null requireds))) + (wt-nl "vs_base=vs_base+" (length requireds) ";")) + (cond (optionals + (let ((*clink* *clink*) + (*unwind-exit* *unwind-exit*) + (*ccb-vs* *ccb-vs*)) + (when rest + (wt-nl "vs_top[0]=Cnil;") + (wt-nl "{object *p=vs_top, *q=vs_base+" (length optionals) ";") + (wt-nl " for(;p>q;p--)p[-1]=MMcons(p[-1],p[0]);}")) + (do ((opts optionals (cdr opts))) + ((endp opts)) + (declare (object opts)) + (push (next-label) labels) + (wt-nl "if(vs_base>=vs_top){") + (reset-top) + (wt-go (car labels)) (wt "}") + (c2bind (caar opts)) + (when (caddar opts) (c2bind-loc (caddar opts) t)) + (when (cdr opts) (wt-nl "vs_base++;")) + ) + (when rest (c2bind rest)) + ) + + (wt-nl) (reset-top) + + (let ((label (next-label))) + (wt-nl) (wt-go label) + + (setq labels (nreverse labels)) + + ;;; Bind unspecified optional parameters. + (dolist** (opt optionals) + (wt-label (car labels)) + (pop labels) + (c2bind-init (car opt) (cadr opt)) + (when (caddr opt) (c2bind-loc (caddr opt) nil))) + + (when rest (c2bind-loc rest nil)) + + (wt-label label))) + (rest + (wt-nl "vs_top[0]=Cnil;") + (wt-nl "{object *p=vs_top;") + (wt-nl " for(;p>vs_base;p--)p[-1]=" + (if *rest-on-stack* "ON_STACK_CONS" "MMcons") + "(p[-1],p[0]);}") + (c2bind rest) + (wt-nl) + (reset-top)) + (t + (wt-nl) + (reset-top))) + + (when *tail-recursion-info* + (push 'tail-recursion-mark *unwind-exit*) (wt-nl "goto TTL;")(wt-nl1 "TTL:;")) + + ;;; Now the parameters are ready! + (c2expr body) + + (when block-p (wt-nl "}")) + ) + +(defun c2lambda-expr-with-key + (lambda-list body + &aux (requireds (nth 0 lambda-list)) + (optionals (nth 1 lambda-list)) + (rest (nth 2 lambda-list)) + (keywords (nth 4 lambda-list)) + (allow-other-keys (nth 5 lambda-list)) + (labels nil) + (*unwind-exit* *unwind-exit*) + (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*) + (block-p nil) + ) + (declare + (object requireds optionals rest keywords allow-other-keys)) + ;;; Allocate immediate-type parameters. + (flet ((do-decl (var) + (let ((kind (c2var-kind var))) + (declare (object kind)) + (when kind + (let ((cvar (next-cvar))) + (setf (var-kind var) kind) + (setf (var-loc var) cvar) + (wt-nl) + (unless block-p (wt "{") (setq block-p t)) + (wt-var-decl var) + ))))) + + (dolist** (v requireds) (do-decl v)) + (dolist** (opt optionals) + (do-decl (car opt)) + (when (caddr opt) (do-decl (caddr opt)))) + (when rest (do-decl rest)) + (dolist** (kwd keywords) + (do-decl (cadr kwd)) + (when (cadddr kwd) (do-decl (cadddr kwd)))) + ) + ;;; Check arguments. + (when (and (or *safe-compile* *compiler-check-args*) requireds) + (when requireds + (wt-nl "if(vs_top-vs_base<" (length requireds) + ") too_few_arguments();"))) + + ;;; Allocate the parameters. + (dolist** (var requireds) (setf (var-ref var) (vs-push))) + (dolist** (opt optionals) + (setf (var-ref (car opt)) (vs-push))) + (when rest (setf (var-ref rest) (vs-push))) + (dolist** (kwd keywords) + (setf (var-ref (cadr kwd)) (vs-push))) + (dolist** (kwd keywords) + (setf (var-ref (cadddr kwd)) (vs-push))) + (dolist** (opt optionals) + (when (caddr opt) (setf (var-ref (caddr opt)) (vs-push)))) + + ;;; Assign rest and keyword parameters first. + ;;; parse_key does not change vs_base and vs_top. + + (wt-nl "parse_key(vs_base") + (when (or requireds optionals) + (wt "+" (+ (length requireds) (length optionals)))) + (if rest (wt ",TRUE,") (wt ",FALSE,")) + (if allow-other-keys (wt "TRUE,") (wt "FALSE,")) + (wt (length keywords)) + (dolist** (kwd keywords) (wt "," (vv-str (add-symbol (car kwd))))) + (wt ");") + + ;;; Bind required parameters. + (dolist** (var requireds) (c2bind var)) + + ;;; Bind optional parameters as long as there remain arguments. + ;;; The compile-time binding is discarded because they are bound again. + + (when optionals + + (when requireds (wt-nl "vs_base += " (length requireds) ";")) + + (let ((*clink* *clink*) + (*unwind-exit* *unwind-exit*) + (*ccb-vs* *ccb-vs*)) + (do ((opts optionals (cdr opts))) + ((endp opts)) + (declare (object opts)) + (push (next-label) labels) + (wt-nl "if(vs_base>=vs_top){") + (reset-top) + (wt-go (car labels)) (wt "}") + (c2bind (caar opts)) + (when (caddar opts) (c2bind-loc (caddar opts) t)) + (when (cdr opts) (wt-nl "vs_base++;")))) + + (setq labels (nreverse labels)) + ) + + (reset-top) + + (when optionals + (let ((label (next-label))) + (wt-go label) + + ;;; Bind unspecified optional parameters. + + (dolist** (opt optionals) + (wt-label (car labels)) + (pop labels) + (c2bind-init (car opt) (cadr opt)) + (when (caddr opt) (c2bind-loc (caddr opt) nil))) + + (wt-label label) + )) + + (when rest (c2bind rest)) + + ;;; Bind keywords. + + (dolist** (kwd keywords) + (cond ((and (eq (caaddr kwd) 'LOCATION) (null (caddr (caddr kwd)))) + ;;; Cnil has been set if keyword parameter is not supplied. + (c2bind (cadr kwd))) + (t + (wt-nl "if(") (wt-vs (var-ref (cadddr kwd))) (wt "==Cnil){") + (let ((*clink* *clink*) + (*unwind-exit* *unwind-exit*) + (*ccb-vs* *ccb-vs*)) + (c2bind-init (cadr kwd) (caddr kwd))) + (wt-nl "}else{") + (c2bind (cadr kwd)) + (wt "}"))) + (unless (eq (var-kind (cadddr kwd)) 'DUMMY) (c2bind (cadddr kwd)))) + + ;;; Now the parameters are ready, after all! + (c2expr body) + + (when block-p (wt-nl "}")) + ) + +(defun need-to-set-vs-pointers (lambda-list) + ;;; On entry to in-line lambda expression, + ;;; vs_base and vs_top must be set iff, + (or *safe-compile* + *compiler-check-args* + (nth 1 lambda-list) ;;; optional, + (nth 2 lambda-list) ;;; rest, or + (nth 3 lambda-list) ;;; key-flag. + )) + + +;;; The DEFMACRO compiler. + +;;; 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 } +;;; ) +;;; +;;; where v is short for { defmacro-lambda-list | sym }. +;;; Defamcro-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 } +;;; ) + +(defvar *vnames*) +(defvar *dm-info*) +(defvar *dm-vars*) + + +(defun c1dm (macro-name vl body + &aux (*vs* *vs*) (whole nil) (env nil) + (setjmps *setjmps*) + (*vnames* nil) (*dm-info* (make-info)) (*dm-vars* nil) + doc ss is ts other-decls ppn) + + (multiple-value-setq (body ss ts is other-decls doc) (c1body body t)) + (setq body (list (list* 'block macro-name body))) + + (c1add-globals ss) + + (when (and (listp vl) (eq (car vl) '&whole)) + (push (cadr vl) *vnames*) + (setq whole (c1make-var (cadr vl) ss is ts)) + (push whole *dm-vars*) + (push whole *vars*) + (setq vl (cddr vl)) + ) + (let ((env-m (and (listp vl) (do ((tail vl (cdr tail))) + ((not (consp tail)) nil) + (when (eq '&environment (car tail)) + (return tail)))))) + (when env-m + (push (cadr env-m) *vnames*) + (setq env (c1make-var (cadr env-m) ss is ts)) + (push env *dm-vars*) + (push env *vars*) + (setq vl (append (ldiff vl env-m) (cddr env-m))))) + (multiple-value-setq (vl ppn) (c1dm-vl vl ss is ts)) + + (check-vdecl *vnames* ts is) + (setq body (c1decl-body other-decls body)) + (add-info *dm-info* (cadr body)) + (cond ((eql setjmps *setjmps*)) + (t(setf (info-volatile *dm-info*) t) + (setf (get macro-name 'contains-setjmp) t) + )) + (dolist* (v *dm-vars*) (check-vref v)) + (list doc ppn whole env vl body *dm-info*) + ) + +(defun c1dm-vl (vl ss is ts) + (do ((optionalp nil) (restp nil) (keyp nil) (allow-other-keys-p nil) + (auxp nil) + (requireds nil) (optionals nil) (rest nil) (key-flag nil) + (keywords nil) (auxs nil) (allow-other-keys nil) + (n 0) (ppn nil) + ) + ((not (consp vl)) + (when vl + (when restp (dm-bad-key '&rest)) + (setq rest (c1dm-v vl ss is ts))) + (values (list (nreverse requireds) (nreverse optionals) rest key-flag + (nreverse keywords) allow-other-keys (nreverse auxs)) + ppn) + ) + (let ((v (car vl))) + (declare (object v)) + (cond + ((eq v '&optional) + (when optionalp (dm-bad-key '&optional)) + (setq optionalp t) + (pop vl)) + ((or (eq v '&rest) (eq v '&body)) + (when restp (dm-bad-key v)) + (setq rest (c1dm-v (cadr vl) ss is ts)) + (setq restp t optionalp t) + (setq vl (cddr vl)) + (when (eq v '&body) (setq ppn n))) + ((eq v '&key) + (when keyp (dm-bad-key '&key)) + (setq keyp t restp t optionalp t key-flag t) + (pop vl)) + ((eq v '&allow-other-keys) + (when (or (not keyp) allow-other-keys-p) + (dm-bad-key '&allow-other-keys)) + (setq allow-other-keys-p t allow-other-keys t) + (pop vl)) + ((eq v '&aux) + (when auxp (dm-bad-key '&aux)) + (setq auxp t allow-other-keys-p t keyp t restp t optionalp t) + (pop vl)) + (auxp + (let (x init) + (cond ((symbolp v) (setq x v init (c1nil))) + (t (setq x (car v)) + (if (endp (cdr v)) + (setq init (c1nil)) + (setq init (c1expr* (cadr v) *dm-info*))))) + (push (list (c1dm-v x ss is ts) init) auxs)) + (pop vl)) + (keyp + (let (x k init (sv nil)) + (cond ((symbolp v) + (setq x v k (intern (string v) 'keyword) init (c1nil))) + (t (if (symbolp (car v)) + (setq x (car v) + k (intern (string (car v)) 'keyword)) + (setq x (cadar v) k (caar v))) + (cond ((endp (cdr v)) (setq init (c1nil))) + (t (setq init (c1expr* (cadr v) *dm-info*)) + (unless (endp (cddr v)) + (setq sv (caddr v))))))) + (push (list k (c1dm-v x ss is ts) init + (if sv (c1dm-v sv ss is ts) nil)) + keywords) + ) + (pop vl)) + (optionalp + (let (x init (sv nil)) + (cond ((symbolp v) (setq x v init (c1nil))) + (t (setq x (car v)) + (cond ((endp (cdr v)) + (setq init (c1nil))) + (t (setq init (c1expr* (cadr v) *dm-info*)) + (unless (endp (cddr v)) + (setq sv (caddr v))))))) + (push (list (c1dm-v x ss is ts) init + (if sv (c1dm-v sv ss is ts) nil)) + optionals)) + (pop vl) + (incf n) + ) + (t (push (c1dm-v v ss is ts) requireds) + (pop vl) + (incf n)) + ))) + ) + +(defun c1dm-v (v ss is ts) + (cond ((symbolp v) + (push v *vnames*) + (setq v (c1make-var v ss is ts)) + (push v *vars*) + (push v *dm-vars*) + v) + (t (c1dm-vl v ss is ts)))) + +(defun c1dm-bad-key (key) + (cmperr "Defmacro-lambda-list contains illegal use of ~s." key)) + +(defmacro maybe-wt-c2dm-bind-vl (vl cvar form end-form) + `(let ((ipos (file-position *compiler-output1*))) + ,form + (let ((npos (file-position *compiler-output1*))) + (c2dm-bind-vl ,vl ,cvar) + (if (eql npos (file-position *compiler-output1*)) + (file-position *compiler-output1* ipos) + ,end-form)))) + +(defun c2dm (whole env vl body + &aux (cvar (next-cvar))) + (when (or *safe-compile* *compiler-check-args*) + (wt-nl "check_arg(2);")) + (cond (whole (setf (var-ref whole) (vs-push))) + (t (vs-push))) + (cond (env (setf (var-ref env) (vs-push))) + (t (vs-push))) + (c2dm-reserve-vl vl) + (reset-top) + (when whole (c2bind whole)) + (when env (c2bind env)) + (maybe-wt-c2dm-bind-vl vl cvar (wt-nl "{object V" cvar "=base[0]->c.c_cdr;") (wt "}")) + (c2expr body) + ) + +(defun c2dm-reserve-vl (vl) + (dolist** (var (car vl)) (c2dm-reserve-v var)) + (dolist** (opt (cadr vl)) + (c2dm-reserve-v (car opt)) + (when (caddr opt) (c2dm-reserve-v (caddr opt)))) + (when (caddr vl) (c2dm-reserve-v (caddr vl))) + (dolist** (kwd (car (cddddr vl))) + (c2dm-reserve-v (cadr kwd)) + (when (cadddr kwd) (c2dm-reserve-v (cadddr kwd)))) + (dolist** (aux (caddr (cddddr vl))) + (c2dm-reserve-v (car aux))) + ) + +(defun c2dm-reserve-v (v) + (if (consp v) + (c2dm-reserve-vl v) + (setf (var-ref v) (vs-push)))) + +(defun c2dm-bind-vl (vl cvar + &aux + (requireds (car vl)) (optionals (cadr vl)) + (rest (caddr vl)) (key-flag (cadddr vl)) + (keywords (car (cddddr vl))) + (allow-other-keys (cadr (cddddr vl))) + (auxs (caddr (cddddr vl))) + ) + (declare (object requireds optionals rest key-flag keywords allow-other-keys + auxs)) + (do ((reqs requireds (cdr reqs))) + ((endp reqs)) + (declare (object reqs)) + (when (or *safe-compile* *compiler-check-args*) + (wt-nl "if(endp(V" cvar "))invalid_macro_call();")) + (c2dm-bind-loc (car reqs) `(car ,cvar)) + (when (or (cdr reqs) optionals rest key-flag + *safe-compile* *compiler-check-args*) + (wt-nl "V" cvar "=V" cvar "->c.c_cdr;"))) + (do ((opts optionals (cdr opts))) + ((endp opts)) + (declare (object opts)) + (let ((opt (car opts))) + (declare (object opt)) + (wt-nl "if(endp(V" cvar ")){") + (let ((*clink* *clink*) + (*unwind-exit* *unwind-exit*) + (*ccb-vs* *ccb-vs*)) + (c2dm-bind-init (car opt) (cadr opt)) + (when (caddr opt) (c2dm-bind-loc (caddr opt) nil)) + ) + (wt-nl "} else {") + (c2dm-bind-loc (car opt) `(car ,cvar)) + (when (caddr opt) (c2dm-bind-loc (caddr opt) t))) + (when (or (cdr opts) rest key-flag + *safe-compile* *compiler-check-args*) + (wt-nl "V" cvar "=V" cvar "->c.c_cdr;")) + (wt "}")) + (when rest (c2dm-bind-loc rest `(cvar ,cvar))) + (dolist** (kwd keywords) + (let ((cvar1 (next-cvar))) + (wt-nl + "{object V" cvar1 "=getf(V" cvar "," (vv-str (add-symbol (car kwd))) ",OBJNULL);") + (wt-nl "if(V" cvar1 "==OBJNULL){") + (let ((*clink* *clink*) + (*unwind-exit* *unwind-exit*) + (*ccb-vs* *ccb-vs*)) + (c2dm-bind-init (cadr kwd) (caddr kwd)) + (when (cadddr kwd) (c2dm-bind-loc (cadddr kwd) nil)) + (wt "} else {")) + (c2dm-bind-loc (cadr kwd) `(cvar ,cvar1)) + (when (cadddr kwd) (c2dm-bind-loc (cadddr kwd) t)) + (wt-nl "}}"))) + (when (and (or *safe-compile* *compiler-check-args*) + (null rest) + (null key-flag)) + (wt-nl "if(!endp(V" cvar "))invalid_macro_call();")) + (when (and (or *safe-compile* *compiler-check-args*) + key-flag + (not allow-other-keys)) + (wt-nl "check_other_key(V" cvar "," (length keywords)) + (dolist** (kwd keywords) + (wt "," (vv-str (add-symbol (car kwd))))) + (wt ");")) + (dolist** (aux auxs) + (c2dm-bind-init (car aux) (cadr aux))) + ) + +(defun c2dm-bind-loc (v loc) + (if (consp v) + (let ((cvar (next-cvar))) + (maybe-wt-c2dm-bind-vl v cvar (wt-nl "{object V" cvar "= " loc ";") (wt "}"))) + (c2bind-loc v loc))) + +(defun c2dm-bind-init (v init) + (if (consp v) + (let* ((*vs* *vs*) (*inline-blocks* 0) + (cvar (next-cvar)) + (loc (car (inline-args (list init) '(t))))) + (maybe-wt-c2dm-bind-vl v cvar (wt-nl "{object V" cvar "= " loc ";") (wt "}")) + (close-inline-blocks)) + (c2bind-init v init))) + + + diff --git a/cmpnew/gcl_cmplet.lsp b/cmpnew/gcl_cmplet.lsp new file mode 100755 index 0000000..0d244c3 --- /dev/null +++ b/cmpnew/gcl_cmplet.lsp @@ -0,0 +1,361 @@ +;;; CMPLET Let and Let*. +;;; +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +(in-package 'compiler) +(eval-when (compile) + (or (fboundp 'write-block-open) (load "cmplet.lsp"))) + +(si:putprop 'let 'c1let 'c1special) +(si:putprop 'let 'c2let 'c2) +(si:putprop 'let* 'c1let* 'c1special) +(si:putprop 'let* 'c2let* 'c2) + +(defun c1let (args &aux (info (make-info))(setjmps *setjmps*) + (forms nil) (vars nil) (vnames nil) + ss is ts body other-decls + (*vars* *vars*)) + (when (endp args) (too-few-args 'let 1 0)) + + (multiple-value-setq (body ss ts is other-decls) (c1body (cdr args) nil)) + + (c1add-globals ss) + + (dolist** (x (car args)) + (cond ((symbolp x) + (let ((v (c1make-var x ss is ts))) + (push x vnames) + (push v vars) + (push (default-init (var-type v)) forms))) + (t (cmpck (not (and (consp x) (or (endp (cdr x)) (endp (cddr x))))) + "The variable binding ~s is illegal." x) + (let ((v (c1make-var (car x) ss is ts))) + (push (car x) vnames) + (push v vars) + (push (if (endp (cdr x)) + (default-init (var-type v)) + (and-form-type (var-type v) + (c1expr* (cadr x) info) + (cadr x))) + forms))))) + + (setq *vars* (append vars *vars*)) +; (dolist* (v (reverse vars)) (push v *vars*)) + + (check-vdecl vnames ts is) + + (setq body (c1decl-body other-decls body)) + + (add-info info (cadr body)) + (setf (info-type info) (info-type (cadr body))) + + (dolist** (var vars) (check-vref var)) + + + (or (eql setjmps *setjmps*) (setf (info-volatile info) t)) + (list 'let info (nreverse vars) (nreverse forms) body) + ) + +(defun c2let (vars forms body + &aux (block-p nil) (bindings nil) initials + + (*unwind-exit* *unwind-exit*) + (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*)) + (declare (object block-p)) + + (do ((vl vars (cdr vl)) (fl forms (cdr fl)) (prev-ss nil)) + ((endp vl)) + (declare (object vl fl)) + (let* ((form (car fl)) (var (car vl)) + (kind (c2var-kind var))) + (declare (object form var)) + (cond (kind (setf (var-kind var) kind) + (setf (var-loc var) (next-cvar))) + ((eq (var-kind var) 'down) + (or (si::fixnump (var-loc var)) (wfs-error))) + (t (setf (var-ref var) (vs-push)))) + (case (var-kind var) + ((FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT INTEGER) + (push (list 'c2expr* (list 'var var nil) form) initials)) + (otherwise + (case (car form) + (LOCATION + (if (can-be-replaced var body) + (progn (setf (var-kind var) 'REPLACED) + (setf (var-loc var) (caddr form))) + (push (list var (caddr form)) bindings))) + (VAR + (let ((var1 (caaddr form))) + (declare (object var1)) + (cond ((or (args-info-changed-vars var1 (cdr fl)) + (and (member (var-kind var1) '(SPECIAL GLOBAL)) + (member (var-name var1) prev-ss))) + (push (list 'c2expr* + (cond ((eq (var-kind var) 'object) + (list 'var var nil)) + ((eq (var-kind var) 'down) + ;(push (list var) bindings) + (list 'down (var-loc var))) + (t(push (list var) bindings) + (list 'vs (var-ref var)))) + form)initials)) + ((and (can-be-replaced var body) + (member (var-kind var1) + '(LEXICAL REPLACED OBJECT)) + (null (var-ref-ccb var1)) + (not (is-changed var1 (cadr body)))) + (setf (var-kind var) 'REPLACED) + (setf (var-loc var) + (case (var-kind var1) + (LEXICAL (list 'vs (var-ref var1))) + (REPLACED (var-loc var1)) + (OBJECT (list 'cvar (var-loc var1))) + (otherwise (baboon))))) + (t (push (list var + (list 'var var1 (cadr (caddr form)))) + bindings))))) + (t (push (list 'c2expr* + (cond ((eq (var-kind var) 'object) + (list 'var var nil)) + ((eq (var-kind var) 'down) + ;(push (list var) bindings) + (list 'down (var-loc var))) + (t(push (list var) bindings) + (list 'vs (var-ref var)))) + form) initials)) + ))) + (when (eq (var-kind var) 'SPECIAL) (push (var-name var) prev-ss)) + )) + + (setq block-p (write-block-open vars)) + + (dolist* (binding (nreverse initials)) + (let ((*value-to-go* (second binding))) + (c2expr* (third binding)))) + (dolist* (binding (nreverse bindings)) + (if (cdr binding) + (c2bind-loc (car binding) (cadr binding)) + (c2bind (car binding)))) + + (c2expr body) + (when block-p (wt "}")) + ) + +(defun c1let* (args &aux (forms nil) (vars nil) (vnames nil) + (setjmps *setjmps*) + ss is ts body other-decls + (info (make-info)) (*vars* *vars*)) + (when (endp args) (too-few-args 'let* 1 0)) + + (multiple-value-setq (body ss ts is other-decls) (c1body (cdr args) nil)) + (c1add-globals ss) + + (dolist** (x (car args)) + (cond ((symbolp x) + (let ((v (c1make-var x ss is ts))) + (push x vnames) + (push (default-init (var-type v)) forms) + (push v vars) + (push v *vars*))) + ((not (and (consp x) (or (endp (cdr x)) (endp (cddr x))))) + (cmperr "The variable binding ~s is illegal." x)) + (t (let ((v (c1make-var (car x) ss is ts))) + (push (car x) vnames) + (push (if (endp (cdr x)) + (default-init (var-type v)) + (and-form-type (var-type v) + (c1expr* (cadr x) info) + (cadr x))) + forms) + (push v vars) + (push v *vars*))))) + + (check-vdecl vnames ts is) + (setq body (c1decl-body other-decls body)) + (add-info info (cadr body)) + (setf (info-type info) (info-type (cadr body))) + (dolist** (var vars) (check-vref var)) + (or (eql setjmps *setjmps*) (setf (info-volatile info) t)) + (list 'let* info (nreverse vars) (nreverse forms) body) + ) + +(defun c2let* (vars forms body + &aux (block-p nil) + (*unwind-exit* *unwind-exit*) + (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*)) + (declare (object block-p)) + + + (do ((vl vars (cdr vl)) + (fl forms (cdr fl))) + ((endp vl)) + (declare (object vl fl)) + (let* ((form (car fl)) (var (car vl)) + (kind (c2var-kind var))) + (declare (object form var)) + (cond (kind (setf (var-kind var) kind) + (setf (var-loc var) (next-cvar)))) + (if (member (var-kind var) + '(FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT INTEGER)) + nil + (case (car form) + (LOCATION + (cond ((can-be-replaced* var body (cdr fl)) + (setf (var-kind var) 'REPLACED) + (setf (var-loc var) (caddr form))) + ((eq (var-kind var) 'object)) + ((eq (var-kind var) 'down) + (or (si::fixnump (var-loc var)) (baboon))) + (t (setf (var-ref var) (vs-push)) + ))) + (VAR + (let ((var1 (caaddr form))) + (declare (object var1)) + (cond ((and (can-be-replaced* var body (cdr fl)) + (member (var-kind var1) + '(LEXICAL REPLACED OBJECT)) + (null (var-ref-ccb var1)) + (not (args-info-changed-vars var1 (cdr fl))) + (not (is-changed var1 (cadr body)))) + (setf (var-kind var) 'REPLACED) + (setf (var-loc var) + (case (var-kind var1) + (LEXICAL (list 'vs (var-ref var1))) + (REPLACED (var-loc var1)) + (OBJECT (list 'cvar (var-loc var1))) + (t (baboon))))) + ((eq (var-kind var)'object)) + (t (setf (var-ref var) (vs-push)) + ))) + ) +; ((eq (var-kind var) 'object)) + (t (unless (eq (var-kind var) 'object) (setf (var-ref var) (vs-push))) + ))) + )) + + (setq block-p (write-block-open vars)) + + (do ((vl vars (cdr vl)) + (fl forms (cdr fl)) + (var nil) (form nil)) + ((null vl)) + (setq var (car vl))(setq form (car fl)) +; (print (list (var-kind var) (car form))) + (case + (var-kind var) + ((FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT OBJECT INTEGER) + (let ((*value-to-go* (list 'var var nil))) + (c2expr* form))) + (REPLACED ) + (t + (case + (car form) + (LOCATION (c2bind-loc var (caddr form))) + (VAR (c2bind-loc var (list 'var (caaddr form) (cadr (caddr form))))) + (t (c2bind-init var form)))))) + + (c2expr body) + + (when block-p (wt "}")) + ) + +(defun can-be-replaced (var body) + (and (or (eq (var-kind var) 'LEXICAL) + (and (eq (var-kind var) 'object) + (< (the fixnum (var-register var)) + (the fixnum *register-min*)))) + (null (var-ref-ccb var)) + (not (eq (var-loc var) 'clb)) + (not (is-changed var (cadr body))))) + +(defun can-be-replaced* (var body forms) + (and (can-be-replaced var body) + (dolist** (form forms t) + (when (is-changed var (cadr form)) + (return nil))) + )) + + +(defun write-block-open (vars) + (let ( block-p) + (dolist** + (var vars) + (let ((kind (var-kind var))) + (declare (object kind)) + (when (member kind '(FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT OBJECT + INTEGER)) + (wt-nl) + (unless block-p (wt "{") (setq block-p t)) + (wt-var-decl var) + ))) + block-p )) + + +;; ---------- stack-let for consing on stack --------- + +;; Usage: (stack-let ((a (cons 1 2)) (b (cons 3 4))) (foo a) (print b) 7) +;; where foo must not keep a copy of `a', since the cons will be formed +;; on the c stack. + +(setf (get 'stack-let 'c1special) 'c1stack-let) + +(defmacro stack-let (&rest x) (cons `let x)) + +(defun c1stack-let (args &aux npairs nums) + (let ((pairs (car args)) + ) + (dolist (v pairs) + (push + (cond ((atom v) v) + ((let ((var (car v)) + (val (second v))) + (and (consp val) + (or (eq (car val) 'cons) + (and (eq (car val) 'list) + (null (cddr val)) + (setq val `(cons ,(second val) nil)))) + (progn + (push (next-cvar) nums) + `(,var (stack-cons ,(car nums) ,@ (cdr val))))))) + (t (cmpwarn "Stack let = regular let for ~a ~a" + v (cdr args)) + v)) + npairs)) + (let ((result (c1expr (cons 'let (cons (nreverse npairs) (cdr args)))))) + (list 'stack-let (second result) nums result)))) + +(setf (get 'stack-let 'c2) 'c2stack-let) + +(defun c2stack-let (nums form) + (let ((n (next-cvar))) + (wt-nl "{Cons_Macro" n ";") + (c2expr form) + (wt "}") + (wt-h + "#define Cons_Macro" n (format nil " struct cons ~{STcons~a ~^,~};" nums) + ))) + +(push '((fixnum t t) t #.(flags) + "(STcons#0.t=t_cons,STcons#0.m=0,STcons#0.c_car=(#1), + STcons#0.c_cdr=SAFE_CDR(#2),(object)&STcons#0)") + (get 'stack-cons 'inline-always)) + +;; ---------- end stack-let for consing on stack --------- + diff --git a/cmpnew/gcl_cmploc.lsp b/cmpnew/gcl_cmploc.lsp new file mode 100755 index 0000000..ac76112 --- /dev/null +++ b/cmpnew/gcl_cmploc.lsp @@ -0,0 +1,297 @@ +;;; CMPLOC Set-loc and Wt-loc. +;;; +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +(in-package 'compiler) + +(defvar *value-to-go*) + +;;; Valid locations are: +;;; NIL +;;; T +;;; 'FUN-VAL' +;;; ( 'VS' vs-address ) +;;; ( 'VS*' vs-address ) +;;; ( 'CCB-VS' ccb-vs ) +;;; ( 'VAR' var-object ccb ) +;;; ( 'VV' vv-index ) +;;; ( 'CVAR' cvar ) +;;; ( 'INLINE' side-effect-p fun/string locs ) +;;; ( 'INLINE-COND' side-effect-p fun/string locs ) +;;; ( 'INLINE-FIXNUM' side-effect-p fun/string locs ) +;;; ( 'INLINE-CHARACTER' side-effect-p fun/string locs ) +;;; ( 'INLINE-LONG-FLOAT' side-effect-p fun/string locs ) +;;; ( 'INLINE-SHORT-FLOAT' side-effect-p fun/string locs ) +;;; ( 'SIMPLE-CALL { SYMLISPCALL-NO-EVENT +;;; | LISPCALL-NO-EVENT +;;; | SYMLISPCALL +;;; | LISPCALL } +;;; vs-index number-of-arguments [ vv-index ] ) +;;; ( 'VS-BASE' offset ) +;;; ( 'CAR' cvar ) +;;; ( 'CADR' cvar ) +;;; ( 'SYMBOL-FUNCTION' vv-index ) +;;; ( 'MAKE-CCLOSURE' cfun cllink ) +;;; ( 'FIXNUM-VALUE' vv-index fixnum-value ) +;;; ( 'FIXNUM-LOC' loc ) +;;; ( 'CHARACTER-VALUE' vv-index character-code ) +;;; ( 'CHARACTER-LOC' loc ) +;;; ( 'LONG-FLOAT-VALUE' vv-index long-float-value ) +;;; ( 'LONG-FLOAT-LOC' loc ) +;;; ( 'SHORT-FLOAT-VALUE' vv-index short-float-value ) +;;; ( 'SHORT-FLOAT-LOC' loc ) + + +;;; Valid *value-to-go* locations are: +;;; +;;; 'RETURN' The value is returned from the current function. +;;; 'RETURN-FIXNUM' +;;; 'RETURN-CHARACTER' +;;; 'RETURN-LONG-FLOAT' +;;; 'RETURN-SHORT-FLOAT' +;;; 'RETURN-OBJECT +;;; 'TRASH' The value may be thrown away. +;;; 'TOP' The value should be set at the top of vs as if it were +;;; a resulted value of a function call. +;;; ( 'VS' vs-address ) +;;; ( 'VS*' vs-address ) +;;; ( 'CCB-VS' ccb-vs ) +;;; ( 'VAR' var-object ccb ) +;;; ( 'JUMP-TRUE' label ) +;;; ( 'JUMP-FALSE' label ) +;;; ( 'BDS-BIND' vv-index ) +;;; ( 'PUSH-CATCH-FRAME' ) +;;; ( 'DBIND' symbol-name-vv ) + +(si:putprop 'cvar 'wt-cvar 'wt-loc) +(si:putprop 'vv 'wt-vv 'wt-loc) +(si:putprop 'car 'wt-car 'wt-loc) +(si:putprop 'cdr 'wt-cdr 'wt-loc) +(si:putprop 'cadr 'wt-cadr 'wt-loc) +(si:putprop 'vs-base 'wt-vs-base 'wt-loc) +(si:putprop 'fixnum-value 'wt-fixnum-value 'wt-loc) +(si:putprop 'fixnum-loc 'wt-fixnum-loc 'wt-loc) +(si:putprop 'integer-loc 'wt-integer-loc 'wt-loc) +(si:putprop 'character-value 'wt-character-value 'wt-loc) +(si:putprop 'character-loc 'wt-character-loc 'wt-loc) +(si:putprop 'long-float-value 'wt-long-float-value 'wt-loc) +(si:putprop 'long-float-loc 'wt-long-float-loc 'wt-loc) +(si:putprop 'short-float-value 'wt-short-float-value 'wt-loc) +(si:putprop 'short-float-loc 'wt-short-float-loc 'wt-loc) +(si::putprop 'next-var-arg 'wt-next-var-arg 'wt-loc) +(si::putprop 'first-var-arg 'wt-first-var-arg 'wt-loc) + +(defun wt-first-var-arg () + (wt "first")) + +(defun wt-next-var-arg () + (wt "va_arg(ap,object)")) + +(defun set-loc (loc &aux fd) + (cond ((eq *value-to-go* 'return) (set-return loc)) + ((eq *value-to-go* 'trash) + (cond ((and (consp loc) + (member (car loc) + '(INLINE INLINE-COND INLINE-FIXNUM inline-integer + INLINE-CHARACTER INLINE-LONG-FLOAT + INLINE-SHORT-FLOAT)) + (cadr loc)) + (wt-nl "(void)(") (wt-inline t (caddr loc) (cadddr loc)) + (wt ");")) + ((and (consp loc) (eq (car loc) 'SIMPLE-CALL)) + (wt-nl "(void)" loc ";")))) + ((eq *value-to-go* 'top) + (unless (eq loc 'fun-val) (set-top loc))) + ((eq *value-to-go* 'return-fixnum) (set-return-fixnum loc)) + ((eq *value-to-go* 'return-character) (set-return-character loc)) + ((eq *value-to-go* 'return-long-float) (set-return-long-float loc)) + ((eq *value-to-go* 'return-short-float) (set-return-short-float loc)) + ((or (not (consp *value-to-go*)) + (not (symbolp (car *value-to-go*)))) + (baboon)) + ((setq fd (get (car *value-to-go*) 'set-loc)) + (apply fd loc (cdr *value-to-go*))) + ((setq fd (get (car *value-to-go*) 'wt-loc)) + (wt-nl) (apply fd (cdr *value-to-go*)) (wt "= " loc ";")) + (t (baboon))) + ) + +(defun wt-loc (loc) + (cond ((eq loc nil) (wt "Cnil")) + ((eq loc t) (wt "Ct")) + ((eq loc 'fun-val) (wt "vs_base[0]")) + ((or (not (consp loc)) + (not (symbolp (car loc)))) + (baboon)) + (t (let ((fd (get (car loc) 'wt-loc))) + (when (null fd) (baboon)) + (apply fd (cdr loc))))) + ) + +(defun set-return (loc) + (cond ((eq loc 'fun-val)) + ((and (consp loc) (eq (car loc) 'vs) (= (caadr loc) *level*)) + (wt-nl "vs_top=(vs_base=base+" (cdadr loc) ")+1;") + (base-used)) + ((and (consp loc) + (eq (car loc) 'var) + (eq (var-kind (cadr loc)) 'LEXICAL) + (not (var-ref-ccb (cadr loc))) + (eql (car (var-ref (cadr loc))) *level*)) + (wt-nl "vs_top=(vs_base=base+" (cdr (var-ref (cadr loc))) ")+1;") + (base-used)) + (t (set-top loc))) + ) + +(defun set-top (loc) + (let ((*vs* *vs*)) + (wt-nl) (wt-vs (vs-push)) (wt "= " loc ";") + (wt-nl "vs_top=(vs_base=base+" (1- *vs*) ")+1;") + (base-used))) + +(defun wt-vs-base (offset) (wt "vs_base[" offset "]")) + +(defun wt-car (cvar) (wt "(V" cvar "->c.c_car)")) + +(defun wt-cdr (cvar) (wt "(V" cvar "->c.c_cdr)")) + +(defun wt-cadr (cvar) (wt "(V" cvar "->c.c_cdr->c.c_car)")) + +(defun wt-cvar (cvar &optional type) + (if type (wt "/* " (symbol-name type) " */")) + (wt "V" cvar)) + +(defun vv-str (vv) (let ((vv (add-object2 vv))) (si::string-concatenate "((object)VV[" (write-to-string vv) "])"))) + +(defun wt-vv (vv) (wt (vv-str vv))) + +(defun wt-fixnum-loc (loc) + (cond ((and (consp loc) + (eq (car loc) 'var) + (eq (var-kind (cadr loc)) 'FIXNUM)) + (wt "V" (var-loc (cadr loc)))) + ((and (consp loc) (eq (car loc) 'INLINE-FIXNUM)) + (wt "(long)")(wt-inline-loc (caddr loc) (cadddr loc))) + ((and (consp loc) (eq (car loc) 'fixnum-value)) + (wt "(long)")(wt (caddr loc))) + ((and (consp loc) (member (car loc) '(INLINE-SHORT-FLOAT + INLINE-LONG-FLOAT))) + (wt "((long)(") + (wt-inline-loc (caddr loc) (cadddr loc)) + (wt "))")) + (t (wt "fix(" loc ")")))) + +(defun wt-integer-loc (loc &optional type + &aux (avma t)(first (and (consp loc) (car loc)))) + (declare (ignore type)) + (case first + (inline-fixnum + (wt "stoi(") + (wt-inline-loc (caddr loc) (cadddr loc)) + (wt ")")) + (INLINE-INTEGER (setq avma nil) (wt-inline-loc (caddr loc) (cadddr loc))) + (fixnum-value (wt "stoi(" (caddr loc) ")")) + (var + (case (var-kind (cadr loc)) + (integer (setq avma nil) (wt "V" (var-loc (cadr loc)))) + (fixnum (wt "stoi(V" (var-loc (cadr loc))")")) + (otherwise (wt "otoi(" loc ")")))) + (otherwise (wt "otoi(" loc ")"))) + (and avma (not *restore-avma*)(wfs-error)) + ) + + +(defun fixnum-loc-p (loc) + (and (consp loc) + (or (and (eq (car loc) 'var) + (eq (var-kind (cadr loc)) 'FIXNUM)) + (eq (car loc) 'INLINE-FIXNUM) + (eq (car loc) 'fixnum-value)))) + +(defun wt-fixnum-value (vv fixnum-value) + (if vv (wt (vv-str vv)) + (wt "small_fixnum(" fixnum-value ")"))) + + +(defun wt-character-loc (loc) + (cond ((and (consp loc) + (eq (car loc) 'var) + (eq (var-kind (cadr loc)) 'CHARACTER)) + (wt "V" (var-loc (cadr loc)))) + ((and (consp loc) (eq (car loc) 'INLINE-CHARACTER)) + (wt-inline-loc (caddr loc) (cadddr loc))) + ((and (consp loc) (eq (car loc) 'CHARACTER-VALUE)) + (wt (caddr loc))) + (t (wt "char_code(" loc ")")))) + +(defun character-loc-p (loc) + (and (consp loc) + (or (and (eq (car loc) 'var) + (eq (var-kind (cadr loc)) 'CHARACTER)) + (eq (car loc) 'INLINE-CHARACTER) + (eq (car loc) 'character-value)))) + +(defun wt-character-value (vv character-code) + (declare (ignore character-code)) + (wt (vv-str vv))) + +(defun wt-long-float-loc (loc) + (cond ((and (consp loc) + (eq (car loc) 'var) + (eq (var-kind (cadr loc)) 'LONG-FLOAT)) + (wt "V" (var-loc (cadr loc)))) + ((and (consp loc) (eq (car loc) 'INLINE-LONG-FLOAT)) + (wt-inline-loc (caddr loc) (cadddr loc))) + ((and (consp loc) (eq (car loc) 'long-float-value)) + (wt (caddr loc))) + (t (wt "lf(" loc ")")))) + +(defun long-float-loc-p (loc) + (and (consp loc) + (or (and (eq (car loc) 'var) + (eq (var-kind (cadr loc)) 'LONG-FLOAT)) + (eq (car loc) 'INLINE-LONG-FLOAT) + (eq (car loc) 'long-float-value)))) + +(defun wt-long-float-value (vv long-float-value) + (declare (ignore long-float-value)) + (wt (vv-str vv))) + +(defun wt-short-float-loc (loc) + (cond ((and (consp loc) + (eq (car loc) 'var) + (eq (var-kind (cadr loc)) 'SHORT-FLOAT)) + (wt "V" (var-loc (cadr loc)))) + ((and (consp loc) (eq (car loc) 'INLINE-SHORT-FLOAT)) + (wt-inline-loc (caddr loc) (cadddr loc))) + ((and (consp loc) (eq (car loc) 'short-float-value)) + (wt (caddr loc))) + (t (wt "sf(" loc ")")))) + +(defun short-float-loc-p (loc) + (and (consp loc) + (or (and (eq (car loc) 'var) + (eq (var-kind (cadr loc)) 'SHORT-FLOAT)) + (eq (car loc) 'INLINE-SHORT-FLOAT) + (eq (car loc) 'short-float-value)))) + +(defun wt-short-float-value (vv short-float-value) + (declare (ignore short-float-value)) + (wt (vv-str vv))) diff --git a/cmpnew/gcl_cmpmain.lsp b/cmpnew/gcl_cmpmain.lsp new file mode 100755 index 0000000..3e9571e --- /dev/null +++ b/cmpnew/gcl_cmpmain.lsp @@ -0,0 +1,839 @@ +;;; CMPMAIN Compiler main program. +;;; +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +;;; **** Caution **** +;;; This file is machine/OS dependant. +;;; ***************** + + +(in-package 'compiler) + + +(export '(*compile-print* *compile-verbose*)) +(import 'si::*tmp-dir* 'compiler) +(import 'si::*error-p* 'compiler) + +;;; This had been true with Linux 1.2.13 a.out or even older +;;; #+linux (push :ld-not-accept-data *features*) +;;; its now a bug preventing the :linux feature. + + +(defvar *compiler-in-use* nil) +(defvar *compiler-compile* nil) +(defvar *compiler-input*) +(defvar *compiler-output1*) +(defvar *compiler-output2*) +(defvar *compiler-output-data*) +(defvar *compiler-output-i*) + +(defvar *compile-print* nil) +(defvar *compile-verbose* t) +(defvar *cmpinclude* "\"cmpinclude.h\"") +;;If the following is a string, then it is inserted instead of +;; the include file cmpinclude.h, EXCEPT for system-p calls. +(defvar *cmpinclude-string* t) + + +;; Let the user write dump c-file etc to /dev/null. +(defun get-output-pathname (file ext name &optional (dir (pathname-directory *default-pathname-defaults*)) + (device (pathname-device *default-pathname-defaults*))) + (cond + ((equal file "/dev/null") (pathname file)) + #+aix3 + ((and (equal name "float") + (equal ext "h")) + (get-output-pathname file ext "Float" )) + (t + (make-pathname :device (or (and (not (null file)) + (not (eq file t)) + (pathname-device file)) + device) + :directory (or (and (not (null file)) + (not (eq file t)) + (pathname-directory file)) + dir) + :name (or (and (not (null file)) + (not (eq file t)) + (pathname-name file)) + name) + :type ext)))) + +(defun safe-system (string) + (multiple-value-bind + (code result) (system (ts string)) + (unless (and (zerop code) (zerop result)) + (cerror "Continues anyway." + "(SYSTEM ~S) returned a non-zero value ~D." + string + result) + (setq *error-p* t)) + (values result))) + +;; If this is t we use fasd-data on all but system-p files. If it +;; is :system-p we use it on all files. If nil use it on none. +(defvar *fasd-data* t) +(defvar *data* nil) +(defvar *default-system-p* nil) +(defvar *default-c-file* nil) +(defvar *default-h-file* nil) +(defvar *default-data-file* nil) +(defvar *keep-gaz* nil) + +;; (list section-length split-file-names next-section-start-file-position) +;; Many c compilers cannot handle the large C files resulting from large lisp files. +;; If *split-files* is a number then, separate compilations for sections +;; *split-files* long, with the +;; will be performed for separate chunks of the lisp files. +(defvar *split-files* nil) ;; if + +(defun check-end (form eof) + (cond ((eq form eof) + (setf (third *split-files*) nil)) + ((> (file-position *compiler-input*) + (car *split-files*)) + (setf (third *split-files*)(file-position *compiler-input*))))) + + +(defun compile-file (&rest args + &aux (*print-pretty* nil) + (*package* *package*) (*split-files* *split-files*) + (*PRINT-CIRCLE* NIL) + (*PRINT-RADIX* NIL) + (*PRINT-ARRAY* T) + (*PRINT-LEVEL* NIL) + (*PRINT-PRETTY* T) + (*PRINT-LENGTH* NIL) + (*PRINT-GENSYM* T) + (*PRINT-CASE* :UPCASE) + (*PRINT-BASE* 10) + (*PRINT-ESCAPE* T) + (section-length *split-files*) + tem) + (loop + (compiler::init-env) + (setq tem (apply 'compiler::compile-file1 args)) + (cond ((atom *split-files*)(return tem)) + ((and (consp *split-files*) + (null (third *split-files*))) + (let ((gaz (let ((*DEFAULT-PATHNAME-DEFAULTS* (car args))) + (gazonk-name))) + (*readtable* (si::standard-readtable))) + (setq gaz (get-output-pathname gaz "lsp" (car args))) + (with-open-file (st gaz :direction :output) + (print + `(eval-when (load eval) + (dolist (v ',(nreverse (second *split-files*))) + (load (merge-pathnames v si::*load-pathname*)))) + st)) + (setq *split-files* nil) + (or (member :output-file args) + (setq args (append args (list :output-file (car args))))) + (return + (prog1 (apply 'compile-file gaz (cdr args)) + (unless *keep-gaz* (mdelete-file gaz)))) + )) + (t nil)) + (if (consp *split-files*) + (setf (car *split-files*) (+ (third *split-files*) section-length))) + )) + + +(defun compile-file1 (input-pathname + &key (output-file input-pathname) + (o-file t) + (c-file *default-c-file*) + (h-file *default-h-file*) + (data-file *default-data-file*) + (c-debug nil) + (system-p *default-system-p*) + (print nil) + (load nil) + &aux (*standard-output* *standard-output*) + (*error-output* *error-output*) + (*compiler-in-use* *compiler-in-use*) + (*c-debug* c-debug) + (*compile-print* (or print *compile-print*)) + (*package* *package*) + (*DEFAULT-PATHNAME-DEFAULTS* #"") + (*data* (list (make-array 50 :fill-pointer 0 :adjustable t) nil nil)) + *init-name* + (*fasd-data* *fasd-data*) + (*error-count* 0)) + + (declare (special *c-debug* *init-name* system-p)) + + (cond (*compiler-in-use* + (format t "~&The compiler was called recursively.~%~ +Cannot compile ~a.~%" + (namestring (merge-pathnames input-pathname #".lsp"))) + (setq *error-p* t) + (return-from compile-file1 (values))) + (t (setq *error-p* nil) + (setq *compiler-in-use* t))) + + (unless (probe-file (merge-pathnames input-pathname #".lsp")) + (format t "~&The source file ~a is not found.~%" + (namestring (merge-pathnames input-pathname #".lsp"))) + (setq *error-p* t) + (return-from compile-file1 (values))) + + (when *compile-verbose* + (format t "~&Compiling ~a.~%" (namestring (merge-pathnames input-pathname #".lsp")))) + + (and *record-call-info* (clear-call-table)) + + (with-open-file + (*compiler-input* (merge-pathnames input-pathname #".lsp")) + + + (cond ((numberp *split-files*) + (if (< (file-length *compiler-input*) *split-files*) + (setq *split-files* nil) + (setq *split-files* (list *split-files* nil 0 nil))))) + + (cond ((consp *split-files*) + (file-position *compiler-input* (third *split-files*)) + (setq output-file + (make-pathname :directory (pathname-directory output-file) + :name (format nil "~a~a" (length (second *split-files*)) (pathname-name (pathname output-file))) + :type "o")) + + (push (pathname-name output-file) (second *split-files*)))) + + + (let* ((eof (cons nil nil)) + (dir (or (and (not (null output-file)) + (pathname-directory output-file)) + (pathname-directory input-pathname))) + (name (or (and (not (null output-file)) + (pathname-name output-file)) + (pathname-name input-pathname))) + (device (or (and (not (null output-file)) + (pathname-device output-file)) + (pathname-device input-pathname))) + + (o-pathname (get-output-pathname o-file "o" name dir device)) + (c-pathname (get-output-pathname c-file "c" name dir device)) + (h-pathname (get-output-pathname h-file "h" name dir device)) + (data-pathname (get-output-pathname data-file "data" name dir device))) + + (declare (special dir name )) + + (init-env) + + (and (boundp 'si::*gcl-version*) + (not system-p) + (add-init `(si::warn-version ,si::*gcl-major-version* + ,si::*gcl-minor-version* + ,si::*gcl-extra-version*))) + + (when (probe-file "./gcl_cmpinit.lsp") + (load "./gcl_cmpinit.lsp" :verbose *compile-verbose*)) + + (with-open-file (*compiler-output-data* data-pathname :direction :output) + + (when *fasd-data* + (setq *fasd-data* (list (si::open-fasd *compiler-output-data* :output nil nil)))) + + (wt-data-begin) + + (if *compiler-compile* + (t1expr *compiler-compile*) + (let* ((rtb *readtable*) + (prev (and (eq (get-macro-character #\# rtb) + (get-macro-character + #\# (si:standard-readtable))) + (get-dispatch-macro-character #\# #\, rtb)))) + (if (and prev (eq prev (get-dispatch-macro-character + #\# #\, (si:standard-readtable)))) + (set-dispatch-macro-character #\# #\, 'si:sharp-comma-reader-for-compiler rtb) + (setq prev nil)) + + ;; t1expr the package ops again.. + (if (consp *split-files*) + (dolist (v (fourth *split-files*)) (t1expr v))) + (unwind-protect + (do ((form (read *compiler-input* nil eof) + (read *compiler-input* nil eof)) + (load-flag (or (eq :defaults *eval-when-defaults*) + (member 'load *eval-when-defaults*)))) + (nil) + (cond + ((eq form eof)) + (load-flag (t1expr form)) + ((maybe-eval nil form))) + (cond + ((and *split-files* (check-end form eof)) + (setf (fourth *split-files*) (reverse (third *data*))) + (return nil)) + ((eq form eof) (return nil)))) + + (when prev (set-dispatch-macro-character #\# #\, prev rtb))))) + + (setq *init-name* (init-name input-pathname system-p)) + + (when (zerop *error-count*) + (when *compile-verbose* (format t "~&End of Pass 1. ~%")) + (compiler-pass2 c-pathname h-pathname system-p )) + + (wt-data-end)) ;;; *compiler-output-data* closed. + + (init-env) + + (if (zerop *error-count*) + + (progn + (when *compile-verbose* (format t "~&End of Pass 2. ~%")) + (cond (*record-call-info* + (dump-fn-data (get-output-pathname output-file "fn" name dir device)))) + (cond (o-file + (compiler-cc c-pathname o-pathname ) + (cond ((probe-file o-pathname) + (compiler-build o-pathname data-pathname) + (when load (load o-pathname)) + (when *compile-verbose* + (print-compiler-info) + (format t "~&Finished compiling ~a.~%" (namestring output-file) + ))) + (t + (format t "~&Your C compiler failed to compile the intermediate file.~%") + (setq *error-p* t)))) + (*compile-verbose* + (print-compiler-info) + (format t "~&Finished compiling ~a.~%" (namestring output-file) + ))) + (unless c-file (mdelete-file c-pathname)) + (unless h-file (mdelete-file h-pathname)) + (unless (or data-file #+ld-not-accept-data t system-p) (mdelete-file data-pathname)) + o-pathname) + + (progn + (when (probe-file c-pathname) (mdelete-file c-pathname)) + (when (probe-file h-pathname) (mdelete-file h-pathname)) + (when (probe-file data-pathname) (mdelete-file data-pathname)) + (format t "~&No FASL generated.~%") + (setq *error-p* t) + (values) + )))))) + +(defun gazonk-name () + (dotimes (i 1000) + (let ((tem (merge-pathnames + (format nil "~agazonk_~d_~d.lsp" (if (boundp '*tmp-dir*) *tmp-dir* "") (abs (si::getpid)) i)))) + (unless (probe-file tem) + (return-from gazonk-name (pathname tem))))) + (error "1000 gazonk names used already!")) + +(defun prin1-cmp (form strm) + (let ((*compiler-output-data* strm) + (*fasd-data* nil)) + (wt-data1 form) ;; this binds all the print stuff + )) + +(defun compile (name &optional def &aux tem gaz (*default-pathname-defaults* #".")) + + (cond ((not(symbolp name)) (error "Must be a name")) + ((and (consp def) + (member (car def) '(lambda ))) + (or name (setf name 'cmp-anon)) + (setf (symbol-function name) + def) + (compile name)) + (def (error "def not a lambda expression")) + ((setq tem (macro-function name)) + (setf (symbol-function 'cmp-anon) tem) + (compile 'cmp-anon) + (setf (macro-function name) (macro-function name)) + ;; FIXME -- support warnings-p and failures-p. CM 20041119 + (values name nil nil)) + ((and (setq tem (symbol-function name)) + (consp tem)) + (let ((na (if (symbol-package name) name 'cmp-anon))) + (unless (and (fboundp 'si::init-cmp-anon) (or (si::init-cmp-anon) (fmakunbound 'si::init-cmp-anon))) + (with-open-file + (st (setq gaz (gazonk-name)) :direction :output)) + (let* ((*compiler-compile* + `(defun ,na + ,@(ecase (car tem) + (lambda (cdr tem)) + (lambda-block (cddr tem))))) + (fi (compile-file gaz))) + (when (pathnamep fi) + (load fi) + (mdelete-file fi))) + (unless *keep-gaz* (mdelete-file gaz))) + (or (eq na name) (setf (symbol-function name) (symbol-function na))) + ;; FIXME -- support warnings-p and failures-p. CM 20041119 + (values (symbol-function name) nil nil) + )) + (t (error "can't compile ~a" name)))) + +(defun disassemble (name &aux tem) + (cond ((and (consp name) + (eq (car name) 'lambda)) + (eval `(defun cmp-anon ,@ (cdr name))) + (disassemble 'cmp-anon)) + ((not(symbolp name)) (error "Not a lambda or a name")) + ((setq tem(macro-function name)) + (setf (symbol-function 'cmp-tmp-macro) tem) + (disassemble 'cmp-tmp-macro) + (setf (macro-function name) (macro-function name)) + name) + ((and (setq tem (symbol-function name)) + (consp tem) + (eq (car tem) 'lambda-block)) + (let ((gaz (gazonk-name))) + (with-open-file + (st gaz :direction :output) + (prin1-cmp `(defun ,name ,@ (cddr tem)) st)) + (let (*fasd-data*) + (compile-file gaz + :h-file t + :c-file t + :data-file t + :o-file t)) + (let ((cn (get-output-pathname gaz "c" gaz )) + (dn (get-output-pathname gaz "data" gaz )) + (hn (get-output-pathname gaz "h" gaz )) + (on (get-output-pathname gaz "o" gaz ))) + (with-open-file (st cn) + (do () ((let ((a (read-line st))) + (when (>= (si::string-match "gazonk_[0-9]*_[0-9]*.h" a) 0) + (format t "~%~d~%" a) + a)))) + (si::copy-stream st *standard-output*)) + (with-open-file (st dn) + (si::copy-stream st *standard-output*)) + (with-open-file (st hn) + (si::copy-stream st *standard-output*)) + (when (zerop (system "which objdump >/dev/null")) + (safe-system (si::string-concatenate "objdump --source " (namestring on)))) + (mdelete-file cn) + (mdelete-file dn) + (mdelete-file hn) + (mdelete-file on) + (unless *keep-gaz* (mdelete-file gaz))))) + (t (error "can't disassemble ~a" name)))) + + +(defun compiler-pass2 (c-pathname h-pathname system-p + &aux + (ci *cmpinclude*) + (ci (when (stringp ci) (subseq ci 1 (1- (length ci))))) + (ci (concatenate 'string si::*system-directory* "../h/" ci)) + (system-p (when (probe-file ci) system-p))) + (declare (special *init-name*)) + (with-open-file (st c-pathname :direction :output) + (let ((*compiler-output1* st)) + (declare (special *compiler-output1*)) + (with-open-file (*compiler-output2* h-pathname :direction :output) + (cond ((and + (stringp *cmpinclude-string*) + (not system-p) + (si::fwrite *cmpinclude-string* 0 + (length *cmpinclude-string*) *compiler-output1*))) + (t (wt-nl1 "#include " *cmpinclude*))) + (wt-nl1 "#include \"" + (namestring + (make-pathname :name + (pathname-name h-pathname) + :type (pathname-type h-pathname))) + "\"") + + (catch *cmperr-tag* (ctop-write *init-name*)) + + (terpri *compiler-output1*) + ;; write ctl-z at end to make sure preprocessor stops! + #+dos (write-char (code-char 26) *compiler-output1*) + (terpri *compiler-output2*))))) + + +(defvar *cc* "cc") +(defvar *ld* "ld") +(defvar *ld-libs* "ld-libs") +(defvar *opt-three* "") +(defvar *opt-two* "") +(defvar *init-lsp* "init-lsp") + +(defvar *use-buggy* nil) + +(defun compiler-command (&rest args &aux na ) + (declare (special *c-debug*)) + (let ((dirlist (pathname-directory (first args))) + (name (pathname-name (first args))) + dir) + (cond (dirlist (setq dir (namestring (make-pathname :directory dirlist)))) + (t (setq dir "."))) + (setq na (namestring + (make-pathname :name name :type (pathname-type(first args))))) + #+(or dos winnt) + (format nil "~a -I~a ~a ~a -c -w ~s -o ~s" + *cc* + (concatenate 'string si::*system-directory* "../h") + (if (and (boundp '*c-debug*) *c-debug*) " -g " "") + (case *speed* + (3 *opt-three* ) + (2 *opt-two*) + (t "")) + (namestring (make-pathname :type "c" :defaults (first args))) + (namestring (make-pathname :type "o" :defaults (first args))) + ) + + #-(or dos winnt) + (format nil "~a -I~a ~a ~a -c ~s -o ~s ~a" + *cc* + (concatenate 'string si::*system-directory* "../h") + (if (and (boundp '*c-debug*) *c-debug*) " -g " "") + (case *speed* + (3 *opt-three* ) + (2 *opt-two*) + (t "")) + (namestring (first args)) + (namestring (second args)) + (prog1 + #+aix3 + (format nil " -w ;ar x /lib/libc.a fsavres.o ; ar qc XXXfsave fsavres.o ; echo init_~a > XXexp ; mv ~a XXX~a ; ld -r -D-1 -bexport:XXexp -bgc XXX~a -o ~a XXXfsave ; rm -f XXX~a XXexp XXXfsave fsavres.o" + *init-name* + (setq na (namestring (get-output-pathname na "o" nil))) + na na na na na) + #+(or dlopen irix5) + (if (not system-p) + (format nil + " -w ; mv ~a XX~a ; ld ~a -shared XX~a -o ~a -lc ; rm -f XX~a" + (setq na (namestring (get-output-pathname na "o" nil))) na + #+ignore-unresolved "-ignore_unresolved" + #+expect-unresolved "-expect_unresolved '*'" + na na na)) + + #+bsd ""; "-w" + #-(or aix3 bsd irix3) " 2> /dev/null ") + + + ) + ) + ) + +#+winnt (defun prep-win-path-acc ( s acc) + (let ((pos (search "\~" s))) + (if pos + (let ((start (subseq s 0 (1+ pos))) + (finish (subseq s (1+ pos)))) + (prep-win-path-acc finish (concatenate 'string acc start "~"))) + (concatenate 'string acc s)))) + +#+winnt +(defun no-device (c) + (let* ((c (namestring (truename c))) + (p (search ":" c))) + (if p (subseq c (1+ p)) c))) + +;; #+winnt +;; (defun prep-win-path (c o) +;; (let* ((w si::*wine-detected*) +;; (c (if w (no-device c) c)) +;; (o (if w (no-device o) o))) +;; (prep-win-path-acc (compiler-command c o) ""))) + +(defun compiler-cc (c-pathname o-pathname) + (safe-system + (format + nil + (prog1 + #+irix5 (compiler-command c-pathname o-pathname ) + #+vax "~a ~@[~*-O ~]-S -I. -w ~a ; as -J -W -o ~A ~A" + #+(or system-v e15 dgux sgi ) "~a ~@[~*-O ~]-c -I. ~a 2> /dev/null" + #+winnt (prep-win-path-acc (compiler-command c-pathname o-pathname) "") + #-winnt (compiler-command c-pathname o-pathname) + ) + *cc* + (if (or (= *speed* 2) (= *speed* 3)) t nil) + (namestring c-pathname) + (namestring o-pathname) + + )) + + #+dont_need + (let ((cname (pathname-name c-pathname)) + (odir (pathname-directory o-pathname)) + (oname (pathname-name o-pathname))) + (unless (and (equalp (truename "./") + (truename (make-pathname :directory odir))) + (equal cname oname)) + (rename-file (make-pathname :name cname :type "o") + o-pathname) +))) + + +(defun compiler-build (o-pathname data-pathname) + #+(and system-v (not e15)) + (safe-system (format nil "echo \"\\000\\000\\000\\000\" >> ~A" + (namestring o-pathname))) + #+(or hp-ux sun sgi) + (with-open-file (o-file + (namestring o-pathname) + :direction :output + :if-exists :append) + ; we could do a safe-system, but forking is slow on the Iris + #+(or hp-ux (and sgi (not irix5))) + (dotimes (i 12) + (write-char #\^@ o-file)) + #+sun ; we could do a safe-system, but forking is slow on the Iris + (dolist (v '(0 0 4 16 0 0 0 0)) + (write-byte v o-file)) + + ) + #-ld-not-accept-data + (when (probe-file o-pathname) + (nconc-files o-pathname data-pathname) + #+never + (safe-system (format nil + "cat ~a >> ~A" + (namestring data-pathname) + (namestring o-pathname))))) + +(defun print-compiler-info () + (format t "~&OPTIMIZE levels: Safety=~d~:[ (No runtime error checking)~;~], Space=~d, Speed=~d~%" + (cond ((null *compiler-check-args*) 0) + ((null *safe-compile*) 1) + ((null *compiler-push-events*) 2) + (t 3)) + *safe-compile* *space* *speed*)) + +(defun nconc-files (a b) + (let* ((n 256) + (tem (make-string n)) + (m 0)) + (with-open-file (st-a a :direction :output :if-exists :append) + (with-open-file (st-b b ) + (sloop::sloop + do (setq m (si::fread tem 0 n st-b)) + while (and m (> m 0)) + do (si::fwrite tem 0 m st-a)))))) + +#+dos +(progn +(defun directory (x &aux ans) + (let* ((pa (pathname x)) + (temp "XXDIR") + tem + (name (pathname-name pa))) + (setq pa (make-pathname :directory (pathname-directory pa) + :name (or (pathname-name pa) :wild) + :type (pathname-type pa))) + (setq name (namestring pa)) + (safe-system (format nil "ls -d ~a > ~a" name temp)) + (with-open-file (st temp) + (loop (setq tem (read-line st nil nil)) + (if (and tem (setq tem (probe-file tem))) + (push tem ans) (return)))) + ans)) + +(defvar *old-compile-file* #'compile-file) +(defun compile-file (f &rest l) + (let* ((p (pathname f)) dir pwd) + (setq dir (pathname-directory p)) + (when dir + (setq dir (namestring (make-pathname :directory dir + :name "."))) + (setq pwd (namestring (truename "."))) + ) + (unwind-protect + (progn (if dir (si::chdir dir)) + (apply *old-compile-file* f l)) + (if pwd (si::chdir pwd))))) + +(defun user-homedir-pathname () + (or (si::getenv "HOME") "/")) + +) + +; +; These functions are added to build custom images requiring +; the loading of binary objects on systems relocating with dlopen. +; + +(defun make-user-init (files outn) + + (let* ((c (pathname outn)) + (c (merge-pathnames c (make-pathname :directory '(:current)))) + (o (merge-pathnames (make-pathname :type "o") c)) + (c (merge-pathnames (make-pathname :type "c") c))) + + (with-open-file (st c :direction :output) + (format st "#include ~a~%~%" *cmpinclude*) + + (format st "#define load2(a) do {") + (format st "printf(\"Loading %s...\\n\",(a));") + (format st "load(a);") + (format st "printf(\"Finished %s...\\n\",(a));} while(0)~%~%") + + (let ((p nil)) + (dolist (tem files) + (when (equal (pathname-type tem) "o") + (let ((tem (namestring tem))) + (push (list (si::find-init-name tem) tem) p)))) + + (setq p (nreverse p)) + + (dolist (tem p) + (format st "extern void ~a(void);~%" (car tem))) + (format st "~%") + + (format st "typedef struct {void (*fn)(void);char *s;} Fnlst;~%") + (format st "#define NF ~a~%" (length p)) + (format st "static Fnlst my_fnlst[NF]={") + (dolist (tem p) + (when (not (eq tem (car p))) + (format st ",~%")) + (format st "{~a,\"~a\"}" (car tem) (cadr tem))) + (format st "};~%~%") + + (format st "static int user_init_run;~%") + (format st "#define my_load(a_,b_) {if (!user_init_run && (a_) && (b_)) gcl_init_or_load1((a_),(b_));(a_)=0;(b_)=0;}~%~%") + + (format st "object user_init(void) {~%") + (format st "user_init_run=1;~%") + (dolist (tem files) + (let ((tem (namestring tem))) + (cond ((equal (cadr (car p)) tem) + (format st "gcl_init_or_load1(~a,\"~a\");~%" + (car (car p)) tem) + (setq p (cdr p))) + (t + (format st "load2(\"~a\");~%" tem))))) + (format st "return Cnil;}~%~%") + + (format st "static int my_strncmp(const char *s1,const char *s2,unsigned long n) {") + (format st " for (;n--;) if (*s1++!=*s2++) return 1; return 0;}") + + (format st "int user_match(const char *s,int n) {~%") + (format st " Fnlst *f;~%") + (format st " for (f=my_fnlst;fs && !my_strncmp(s,f->s,n)) {~%") + (format st " my_load(f->fn,f->s);~%") + (format st " return 1;~%") + (format st " }~%") + (format st " }~%") + (format st " return 0;~%") + (format st "}~%~%"))) + + (compiler-cc c o) + (mdelete-file c) + + o)) + +(defun mysub (str it new) + (let ((x (search it str))) + (unless x + (return-from mysub str)) + (let ((y (+ (length it) (the fixnum x)))) + (declare (fixnum y)) + (concatenate (type-of str) + (subseq str 0 x) + new + (mysub (subseq str y) it new))))) + + +(eval-when (compile eval) +(defmacro fcr (x) `(load-time-value (si::compile-regexp ,x))) +(defmacro sml (x y &optional z) + (let ((q (gensym))) + `(let ((,q (si::string-match ,x ,y ,@(when z (list z))))) + (if (= ,q -1) (length ,y) ,q))))) + +(defun ts (s &optional (r "")) + (declare (string s) (ignorable r)) + #+winnt + (if (not si::*wine-detected*) s + (let* ((x (sml (fcr #u"[^ \n\t]") s)) + (y (sml (fcr #u"[ \n\t]") s x)) + (f (subseq s x y)) + (l (subseq s y)) + (k (when (> (length f) 0) (aref f 0))) + (q (if (eql k #\") (string k) "")) + (f (if (eql k #\") (subseq f 1 (1- (length f))) f)) + (f (if (and k (not (eql k #\-))) (namestring (no-device f)) f))) + (if k (concatenate 'string r q f q (ts l " ")) ""))) + #-winnt s) + +(defun mdelete-file (x) + (delete-file (ts (namestring x)))) + + +(defun link (files image &optional post extra-libs (run-user-init t)) + + (let* ((ui (make-user-init files "user-init")) + (raw (pathname image)) + (init (merge-pathnames (make-pathname + :name (concatenate 'string "init_" (pathname-name raw)) + :type "lsp") raw)) + (raw (merge-pathnames raw (truename "./"))) + (raw (merge-pathnames (make-pathname + :name (concatenate 'string "raw_" (pathname-name raw))) + raw)) + (map (merge-pathnames (make-pathname + :name (concatenate 'string (pathname-name raw) "_map")) raw)) + #+winnt (raw (merge-pathnames (make-pathname :type "exe") raw)) + ) + + (with-open-file (st (namestring map) :direction :output)) + (safe-system + (let* ((par (namestring (make-pathname :directory '(:parent)))) + (i (concatenate 'string " " par)) + (j (concatenate 'string " " si::*system-directory* par))) + (format nil "~a ~a ~a ~a -L~a ~a ~a ~a" + (mysub *ld* i j) + (namestring raw) + (namestring ui) + (let ((sfiles "")) + (dolist (tem files) + (if (equal (pathname-type tem) "o") + (setq sfiles (concatenate 'string sfiles " " (namestring tem))))) + sfiles) + si::*system-directory* + #+gnu-ld (format nil "-Wl,-Map ~a" (namestring map)) #-gnu-ld "" + (if (stringp extra-libs) extra-libs "") + (mysub *ld-libs* i j)))) + + (mdelete-file ui) + + (with-open-file (st init :direction :output) + (unless run-user-init + (format st "(fmakunbound 'si::user-init)~%")) + (format st "(setq si::*no-init* '(") + (dolist (tem files) + (format st " \"~a\"" (pathname-name tem))) + (format st "))~%") + (with-open-file (st1 + (format nil "~a~a" si::*system-directory* *init-lsp*)) + (si::copy-stream st1 st)) + (if (stringp post) (format st "~a~%" post)) + (format st "(si::save-system \"~a\")~%" (ts (namestring image)))) + + (safe-system (format nil "~a ~a < ~a" + (namestring raw) + si::*system-directory* + (namestring init))) + + (mdelete-file raw) + (mdelete-file init)) + + image) diff --git a/cmpnew/gcl_cmpmap.lsp b/cmpnew/gcl_cmpmap.lsp new file mode 100755 index 0000000..c164489 --- /dev/null +++ b/cmpnew/gcl_cmpmap.lsp @@ -0,0 +1,262 @@ +;;; CMPMAP Map functions. +;;; +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +(in-package 'compiler) + +(si:putprop 'mapcar 'c1mapcar 'c1) +(si:putprop 'maplist 'c1maplist 'c1) +(si:putprop 'mapcar 'c2mapcar 'c2) +(si:putprop 'mapc 'c1mapc 'c1) +(si:putprop 'mapl 'c1mapl 'c1) +(si:putprop 'mapc 'c2mapc 'c2) +(si:putprop 'mapcan 'c1mapcan 'c1) +(si:putprop 'mapcon 'c1mapcon 'c1) +(si:putprop 'mapcan 'c2mapcan 'c2) + +(defun c1mapcar (args) (c1map-functions 'mapcar t args)) +(defun c1maplist (args) (c1map-functions 'mapcar nil args)) +(defun c1mapc (args) (c1map-functions 'mapc t args)) +(defun c1mapl (args) (c1map-functions 'mapc nil args)) +(defun c1mapcan (args) (c1map-functions 'mapcan t args)) +(defun c1mapcon (args) (c1map-functions 'mapcan nil args)) + +(defun c1map-functions (name car-p args &aux funob info) + (when (or (endp args) (endp (cdr args))) + (too-few-args 'map-function 2 (length args))) + (setq funob (c1funob (car args))) + (setq info (copy-info (cadr funob))) + (list name info funob car-p (c1args (cdr args) info)) + ) + +(defun c2mapcar (funob car-p args &aux (*vs* *vs*) (*inline-blocks* 0)) + (let ((label (next-label*)) + (value-loc (list 'VS (vs-push))) + (handy (list 'CVAR (next-cvar))) + (handies (mapcar #'(lambda (x) (declare (ignore x)) + (list 'CVAR (next-cvar))) + args)) + save + ) + (setq save (save-funob funob)) +; (setq args (inline-args args +; (make-list (length args) :initial-element t))) + (setq args (push-changed-vars + (inline-args args (make-list (length args) + :initial-element t)) + funob)) + (wt-nl "{object " handy ";") + (dolist** (loc handies) + (wt-nl "object " loc "= " (car args) ";") + (pop args)) + (cond (*safe-compile* + (wt-nl "if(endp(" (car handies) ")") + (dolist** (loc (cdr handies)) (wt "||endp(" loc ")")) + (wt "){")) + (t + (wt-nl "if(" (car handies) "==Cnil") + (dolist** (loc (cdr handies)) (wt "||" loc "==Cnil")) + (wt "){"))) + (unwind-exit nil 'jump) + (wt "}") + (wt-nl value-loc "=" handy "=MMcons(Cnil,Cnil);") + (wt-label label) + (let* ((*value-to-go* (list 'CAR (cadr handy))) + (*exit* (next-label)) + (*unwind-exit* (cons *exit* *unwind-exit*))) + (c2funcall funob + (if car-p + (mapcar + #'(lambda (loc) + (list 'LOCATION *info* (list 'CAR (cadr loc)))) + handies) + (mapcar #'(lambda (loc) (list 'LOCATION *info* loc)) + handies)) + save) + (wt-label *exit*)) + (cond (*safe-compile* + (wt-nl (car handies) "=MMcdr(" (car handies) ");") + (dolist** (loc (cdr handies)) + (wt-nl loc "=MMcdr(" loc ");")) + (wt-nl "if(endp(" (car handies) ")") + (dolist** (loc (cdr handies)) + (wt "||endp(" loc ")")) + (wt "){")) + (t + (wt-nl "if((" (car handies) "=MMcdr(" (car handies) "))==Cnil") + (dolist** (loc (cdr handies)) + (wt "||(" loc "=MMcdr(" loc "))==Cnil")) + (wt "){"))) + (unwind-exit value-loc 'jump) + (wt "}") + (wt-nl handy "=MMcdr(" handy ")=MMcons(Cnil,Cnil);") + (wt-nl) (wt-go label) + (wt "}") + (close-inline-blocks) + ) + ) + +(defun c2mapc (funob car-p args &aux (*vs* *vs*) (*inline-blocks* 0)) + (let ((label (next-label*)) + value-loc + (handies (mapcar #'(lambda (x) (declare (ignore x)) + (list 'CVAR (next-cvar))) + args)) + save + ) + (setq save (save-funob funob)) +; (setq args (inline-args args +; (make-list (length args) :initial-element t))) + (setq args (push-changed-vars + (inline-args args (make-list (length args) + :initial-element t)) + funob)) + (setq value-loc (car args)) + (wt-nl "{") + (dolist** (loc handies) + (wt-nl "object " loc "= " (car args) ";") + (pop args)) + (cond (*safe-compile* + (wt-nl "if(endp(" (car handies) ")") + (dolist** (loc (cdr handies)) (wt "||endp(" loc ")")) + (wt "){")) + (t + (wt-nl "if(" (car handies) "==Cnil") + (dolist** (loc (cdr handies)) (wt "||" loc "==Cnil")) + (wt "){"))) + (unwind-exit nil 'jump) + (wt "}") + (wt-label label) + (let* ((*value-to-go* 'trash) + (*exit* (next-label)) + (*unwind-exit* (cons *exit* *unwind-exit*))) + (c2funcall funob + (if car-p + (mapcar + #'(lambda (loc) + (list 'LOCATION *info* (list 'CAR (cadr loc)))) + handies) + (mapcar #'(lambda (loc) (list 'LOCATION *info* loc)) + handies)) + save) + (wt-label *exit*)) + (cond (*safe-compile* + (wt-nl (car handies) "=MMcdr(" (car handies) ");") + (dolist** (loc (cdr handies)) + (wt-nl loc "=MMcdr(" loc ");")) + (wt-nl "if(endp(" (car handies) ")") + (dolist** (loc (cdr handies)) + (wt "||endp(" loc ")")) + (wt "){")) + (t + (wt-nl "if((" (car handies) "=MMcdr(" (car handies) "))==Cnil") + (dolist** (loc (cdr handies)) + (wt "||(" loc "=MMcdr(" loc "))==Cnil")) + (wt "){"))) + (unwind-exit value-loc 'jump) + (wt "}") + (wt-nl) (wt-go label) + (wt "}") + (close-inline-blocks) + ) + ) + +(defun c2mapcan (funob car-p args &aux (*vs* *vs*) (*inline-blocks* 0)) + (let ((label (next-label*)) + (value-loc (list 'VS (vs-push))) + (handy (list 'CVAR (next-cvar))) + (handies (mapcar #'(lambda (x) (declare (ignore x)) + (list 'CVAR (next-cvar))) + args)) + save + ) + (setq save (save-funob funob)) +; (setq args (inline-args args +; (make-list (length args) :initial-element t))) + (setq args (push-changed-vars + (inline-args args (make-list (length args) + :initial-element t)) + funob)) + (wt-nl "{object " handy ";") + (dolist** (loc handies) + (wt-nl "object " loc "= " (car args) ";") + (pop args)) + (cond (*safe-compile* + (wt-nl "if(endp(" (car handies) ")") + (dolist** (loc (cdr handies)) (wt "||endp(" loc ")")) + (wt "){")) + (t + (wt-nl "if(" (car handies) "==Cnil") + (dolist** (loc (cdr handies)) (wt "||" loc "==Cnil")) + (wt "){"))) + (unwind-exit nil 'jump) + (wt "}") + (wt-nl value-loc "=" handy "=MMcons(Cnil,Cnil);") + (wt-label label) + (let* ((*value-to-go* (list 'cdr (cadr handy))) + (*exit* (next-label)) + (*unwind-exit* (cons *exit* *unwind-exit*)) + ) + (c2funcall funob + (if car-p + (mapcar + #'(lambda (loc) + (list 'LOCATION *info* (list 'CAR (cadr loc)))) + handies) + (mapcar #'(lambda (loc) (list 'LOCATION *info* loc)) + handies)) + save) + (wt-label *exit*)) + (cond + (*safe-compile* + (wt-nl "{object cdr_" handy "=MMcdr(" handy ");while(!endp(cdr_" handy ")) {cdr_" handy "=MMcdr(cdr_" handy ");" handy "=MMcdr(" handy ");}}") + (wt-nl (car handies) "=MMcdr(" (car handies) ");") + (dolist** (loc (cdr handies)) + (wt-nl loc "=MMcdr(" loc ");")) + (wt-nl "if(endp(" (car handies) ")") + (dolist** (loc (cdr handies)) + (wt "||endp(" loc ")")) + (wt "){")) + (t + (wt-nl "while(MMcdr(" handy ")!=Cnil)" handy "=MMcdr(" handy ");") + (wt-nl "if((" (car handies) "=MMcdr(" (car handies) "))==Cnil") + (dolist** (loc (cdr handies)) + (wt "||(" loc "=MMcdr(" loc "))==Cnil")) + (wt "){"))) + (wt-nl value-loc "=" value-loc "->c.c_cdr;") + (unwind-exit value-loc 'jump) + (wt "}") + (wt-nl) (wt-go label) + (wt "}") + (close-inline-blocks) + ) + ) + + +(defun push-changed-vars (locs funob &aux (locs1 nil) (forms (list funob))) + (dolist (loc locs (reverse locs1)) + (if (and (consp loc) + (eq (car loc) 'VAR) + (args-info-changed-vars (cadr loc) forms)) + (let ((temp (list 'VS (vs-push)))) + (wt-nl temp "= " loc ";") + (push temp locs1)) + (push loc locs1)))) + diff --git a/cmpnew/gcl_cmpmulti.lsp b/cmpnew/gcl_cmpmulti.lsp new file mode 100755 index 0000000..5c9c088 --- /dev/null +++ b/cmpnew/gcl_cmpmulti.lsp @@ -0,0 +1,287 @@ +;;; CMPMULT Multiple-value-call and Multiple-value-prog1. +;;; +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +(in-package 'compiler) + +(si:putprop 'multiple-value-call 'c1multiple-value-call 'c1special) +(si:putprop 'multiple-value-call 'c2multiple-value-call 'c2) +(si:putprop 'multiple-value-prog1 'c1multiple-value-prog1 'c1special) +(si:putprop 'multiple-value-prog1 'c2multiple-value-prog1 'c2) +(si:putprop 'values 'c1values 'c1) +(si:putprop 'values 'c2values 'c2) +(si:putprop 'multiple-value-setq 'c1multiple-value-setq 'c1) +(si:putprop 'multiple-value-setq 'c2multiple-value-setq 'c2) +(si:putprop 'multiple-value-bind 'c1multiple-value-bind 'c1) +(si:putprop 'multiple-value-bind 'c2multiple-value-bind 'c2) + +(defun c1multiple-value-call (args &aux info funob) + (when (endp args) (too-few-args 'multiple-value-call 1 0)) + (cond ((endp (cdr args)) (c1funcall args)) + (t (setq funob (c1funob (car args))) + (setq info (copy-info (cadr funob))) + (setq args (c1args (cdr args) info)) + (list 'multiple-value-call info funob args))) + ) + +(defun c2multiple-value-call (funob forms &aux (*vs* *vs*) loc top sup) + (cond ((endp (cdr forms)) + (setq loc (save-funob funob)) + (let ((*value-to-go* 'top)) (c2expr* (car forms))) + (c2funcall funob 'args-pushed loc)) + (t + (setq top (next-cvar)) + (setq sup (next-cvar)) + (setq loc (save-funob funob)) + (base-used) + ;; Add (sup .var) handling in unwind-exit -- in + ;; c2multiple-value-prog1 and c2-multiple-value-call, apparently + ;; alone, c2expr-top is used to evaluate arguments, presumably to + ;; preserve certain states of the value stack for the purposes of + ;; retrieving the final results. c2exprt-top rebinds sup, and + ;; vs_top in turn to the new sup, causing non-local exits to lose + ;; the true top of the stack vital for subsequent function + ;; evaluations. We unwind this stack supremum variable change here + ;; when necessary. CM 20040301 + (wt-nl "{object *V" top "=base+" *vs* ",*V" sup "=sup;") + (dolist** (form forms) + (let ((*value-to-go* 'top) + (*unwind-exit* (cons (cons 'sup sup) *unwind-exit*))) + (c2expr-top* form top)) + (wt-nl "while(vs_base=vs_top){") + (reset-top) + (wt-go (car labels)) (wt "}") + (c2bind-loc (car vs) '(vs-base 0)) + (unless (endp (cdr vs)) (wt-nl "vs_base++;")))) + + (wt-nl) (reset-top) + + (let ((label (next-label))) + (wt-nl) (wt-go label) + + (setq labels (nreverse labels)) + + (dolist** (v vars) + (wt-label (car labels)) + (pop labels) + (c2bind-loc v nil)) + + (wt-label label)) + + (c2expr body) + (when block-p (wt "}")) + ) diff --git a/cmpnew/gcl_cmpopt.lsp b/cmpnew/gcl_cmpopt.lsp new file mode 100755 index 0000000..b6d0649 --- /dev/null +++ b/cmpnew/gcl_cmpopt.lsp @@ -0,0 +1,1284 @@ +(in-package 'compiler) + +;; The optimizers have been redone to allow more flags +;; The old style optimizations correspond to the first 2 +;; flags. +;; ( arglist result-type flags {string | function}) + +;; meaning of the flags slot. +; '((allocates-new-storage ans); might invoke gbc +; (side-effect-p set) ; no effect on arguments +; (constantp) ; always returns same result, +; ;double eval ok. +; (result-type-from-args rfa); if passed args of matching +; ;type result is of result type +; (is))) ;; extends the `integer stack'. +; (cond ((member flag v :test 'eq) +; +;;; valid properties are 'inline-always 'inline-safe 'inline-unsafe + +;; Note: The order of the properties is important, since the first +;; one whose arg types and result type can be matched will be chosen. + + +(or (fboundp 'flags) (load "../cmpnew/cmpeval.lsp")) + +;;INTEGER-LENGTH +(push '((t) t #.(compiler::flags) "immnum_length(#0)") (get 'integer-length 'compiler::inline-always)) +;;LOGCOUNT +(push '((t) t #.(compiler::flags) "immnum_count(#0)") (get 'logcount 'compiler::inline-always)) +;;LOGBITP +(push '((t t) boolean #.(compiler::flags) "immnum_bitp(#0,#1)") (get 'logbitp 'compiler::inline-always)) + +;;ABS +(push '((t) t #.(compiler::flags) "immnum_abs(#0)") (get 'abs 'compiler::inline-always)) + +;;ASH +(push '((t t) t #.(compiler::flags) "immnum_shft(#0,#1)") (get 'ash 'compiler::inline-always)) + +;;GCD +(push '((t t) t #.(compiler::flags) "immnum_gcd(#0,#1)") (get 'gcd 'compiler::inline-always)) + +;;LCM +(push '((t t) t #.(compiler::flags) "immnum_lcm(#0,#1)") (get 'lcm 'compiler::inline-always)) + +;;BOOLE +(push '((t t t) t #.(compiler::flags) "immnum_bool(#0,#1,#2)") (get 'boole 'compiler::inline-always)) +(push '((fixnum t t) t #.(compiler::flags) "immnum_boole(#0,#1,#2)") (get 'boole 'compiler::inline-always)) + +;;BOOLE3 + (push '((fixnum fixnum fixnum) fixnum #.(flags rfa)INLINE-BOOLE3) + (get 'boole3 'inline-always)) + +;;FP-OKP + (push '((t) boolean #.(flags set) + "@0;(type_of(#0)==t_stream? ((#0)->sm.sm_fp)!=0: 0 )") + (get 'fp-okp 'inline-unsafe)) +(push '((stream) boolean #.(flags set)"((#0)->sm.sm_fp)!=0") + (get 'fp-okp 'inline-unsafe)) + +;;LDB1 + (push '((fixnum fixnum fixnum) fixnum #.(flags) + "((((~(-1 << (#0))) << (#1)) & (#2)) >> (#1))") + (get 'si::ldb1 'inline-always)) + +;;LONG-FLOAT-P + (push '((t) boolean #.(flags)"type_of(#0)==t_longfloat") + (get 'long-float-p 'inline-always)) + +;;SFEOF + (push '((object) boolean #.(flags set)"(gcl_feof((#0)->sm.sm_fp))") + (get 'sfeof 'inline-unsafe)) + + +;;SGETC1 + (push '((object) fixnum #.(flags set rfa) "gcl_getc((#0)->sm.sm_fp)") + (get 'sgetc1 'inline-unsafe)) + +;;SPUTC + (push '((fixnum object) fixnum #.(flags set rfa)"(gcl_putc(#0,(#1)->sm.sm_fp))") + (get 'sputc 'inline-unsafe)) +(push '((character object) fixnum #.(flags set rfa)"(gcl_putc(#0,(#1)->sm.sm_fp))") + (get 'sputc 'inline-unsafe)) + +;;READ-BYTE1 + (push '((t t) t #.(flags ans set)"read_byte1(#0,#1)") + (get 'read-byte1 'inline-unsafe)) + +;;READ-CHAR1 + (push '((t t) t #.(flags ans set)"read_char1(#0,#1)") + (get 'read-char1 'inline-unsafe)) + +;;SHIFT<< + (push '((fixnum fixnum) fixnum #.(flags)"((#0) << (#1))") + (get 'shift<< 'inline-always)) + +;;SHIFT>> + (push '((fixnum fixnum) fixnum #.(flags set rfa)"((#0) >> (- (#1)))") + (get 'shift>> 'inline-always)) + +;;SHORT-FLOAT-P + (push '((t) boolean #.(flags)"type_of(#0)==t_shortfloat") + (get 'short-float-p 'inline-always)) + +;;SIDE-EFFECTS + (push '(nil t #.(flags ans set)"Ct") + (get 'side-effects 'inline-always)) + +;;STACK-CONS + (push '((fixnum t t) t #.(flags) + "(STcons#0.t=t_cons,STcons#0.m=0,STcons#0.c_car=(#1), + STcons#0.c_cdr=SAFE_CDR(#2),(object)&STcons#0)") + (get 'stack-cons 'inline-always)) + +;;SUBLIS1 + (push '((t t t) t #.(flags ans set)SUBLIS1-INLINE) + (get 'sublis1 'inline-always)) + +;;SYMBOL-LENGTH + (push '((t) fixnum #.(flags rfa) + "@0;(type_of(#0)==t_symbol ? (#0)->s.s_fillp :not_a_variable((#0)))") + (get 'symbol-length 'inline-always)) + +;;VECTOR-TYPE + (push '((t fixnum) boolean #.(flags) + "@0;(type_of(#0) == t_vector && (#0)->v.v_elttype == (#1))") + (get 'vector-type 'inline-always)) + +;;SYSTEM:ASET + (push '((t t t) t #.(flags set)"aset1(#0,fixint(#1),#2)") + (get 'system:aset 'inline-always)) +(push '((t fixnum t) t #.(flags set)"aset1(#0,#1,#2)") + (get 'system:aset 'inline-always)) +(push '((t t t) t #.(flags set)"aset1(#0,fix(#1),#2)") + (get 'system:aset 'inline-unsafe)) +(push '((t fixnum t) t #.(flags set)"aset1(#0,#1,#2)") + (get 'system:aset 'inline-unsafe)) +(push '(((array t) fixnum t) t #.(flags set)"(#0)->v.v_self[#1]= (#2)") + (get 'system:aset 'inline-unsafe)) +(push '(((array string-char) fixnum character) character #.(flags rfa set)"(#0)->ust.ust_self[#1]= (#2)") + (get 'system:aset 'inline-unsafe)) +(push '(((array fixnum) fixnum fixnum) fixnum #.(flags set rfa)"(#0)->fixa.fixa_self[#1]= (#2)") + (get 'system:aset 'inline-unsafe)) +(push '(((array signed-short) fixnum fixnum) fixnum #.(flags rfa set)"((short *)(#0)->ust.ust_self)[#1]=(#2)") + (get 'system:aset 'inline-unsafe)) +(push '(((array signed-char) fixnum fixnum) fixnum #.(flags rfa set)"((#0)->ust.ust_self)[#1]=(#2)") + (get 'system:aset 'inline-unsafe)) +(push '(((array unsigned-short) fixnum fixnum) fixnum #.(flags rfa set) + "((unsigned short *)(#0)->ust.ust_self)[#1]=(#2)") + (get 'system:aset 'inline-unsafe)) +(push '(((array unsigned-char) fixnum fixnum) fixnum #.(flags rfa set)"((#0)->ust.ust_self)[#1]=(#2)") + (get 'system:aset 'inline-unsafe)) +(push '(((array short-float) fixnum short-float) short-float #.(flags rfa set)"(#0)->sfa.sfa_self[#1]= (#2)") + (get 'system:aset 'inline-unsafe)) +(push '(((array long-float) fixnum long-float) long-float #.(flags rfa set)"(#0)->lfa.lfa_self[#1]= (#2)") + (get 'system:aset 'inline-unsafe)) +(push '((t t t t) t #.(flags set) + "@0;aset(#0,fix(#1)*(#0)->a.a_dims[1]+fix(#2),#3)") + (get 'system:aset 'inline-unsafe)) +(push '(((array t) fixnum fixnum t) t #.(flags set) + "@0;(#0)->a.a_self[(#1)*(#0)->a.a_dims[1]+#2]= (#3)") + (get 'system:aset 'inline-unsafe)) +(push '(((array string-char) fixnum fixnum character) character + #.(flags rfa set) + "@0;(#0)->ust.ust_self[(#1)*(#0)->a.a_dims[1]+#2]= (#3)") + (get 'system:aset 'inline-unsafe)) +(push '(((array fixnum) fixnum fixnum fixnum) fixnum #.(flags set rfa) + "@0;(#0)->fixa.fixa_self[(#1)*(#0)->a.a_dims[1]+#2]= (#3)") + (get 'system:aset 'inline-unsafe)) +(push '(((array short-float) fixnum fixnum short-float) short-float #.(flags rfa set) + "@0;(#0)->sfa.sfa_self[(#1)*(#0)->a.a_dims[1]+#2]= (#3)") + (get 'system:aset 'inline-unsafe)) +(push '(((array long-float) fixnum fixnum long-float) long-float #.(flags rfa set) + "@0;(#0)->lfa.lfa_self[(#1)*(#0)->a.a_dims[1]+#2]= (#3)") + (get 'system:aset 'inline-unsafe)) + +;;SYSTEM:CHAR-SET + (push '((t t t) t #.(flags set)"elt_set(#0,fixint(#1),#2)") + (get 'system:char-set 'inline-always)) +(push '((t fixnum t) t #.(flags set)"elt_set(#0,#1,#2)") + (get 'system:char-set 'inline-always)) +(push '((t t t) t #.(flags set) + "@2;((#0)->ust.ust_self[fix(#1)]=char_code(#2),(#2))") + (get 'system:char-set 'inline-unsafe)) +(push '((t fixnum character) character #.(flags rfa set)"(#0)->ust.ust_self[#1]= (#2)") + (get 'system:char-set 'inline-unsafe)) + +;;SYSTEM:ELT-SET + (push '((t t t) t #.(flags set)"elt_set(#0,fixint(#1),#2)") + (get 'system:elt-set 'inline-always)) +(push '((t fixnum t) t #.(flags set)"elt_set(#0,#1,#2)") + (get 'system:elt-set 'inline-always)) +(push '((t t t) t #.(flags set)"elt_set(#0,fix(#1),#2)") + (get 'system:elt-set 'inline-unsafe)) +(push '((t fixnum t) t #.(flags set)"elt_set(#0,#1,#2)") + (get 'system:elt-set 'inline-unsafe)) + +;;SYSTEM:FILL-POINTER-SET + (push '((t fixnum) fixnum #.(flags rfa set)"((#0)->st.st_fillp)=(#1)") + (get 'system:fill-pointer-set 'inline-unsafe)) + +;;SYSTEM:FIXNUMP + (push '((t) boolean #.(flags)"type_of(#0)==t_fixnum") + (get 'system:fixnump 'inline-always)) +(push '((fixnum) boolean #.(flags)"1") + (get 'system:fixnump 'inline-always)) + +;;SYSTEM:HASH-SET +(push '((t t t) t #.(flags rfa) "@2;(sethash(#0,#1,#2),#2)") (get 'si::hash-set 'inline-unsafe)) +(push '((t t t) t #.(flags rfa) "@2;(sethash_with_check(#0,#1,#2),#2)") (get 'si::hash-set 'inline-always)) + +;;SYSTEM:MV-REF + (push '((fixnum) t #.(flags ans set)"(MVloc[(#0)])") + (get 'system:mv-ref 'inline-always)) + +;;SYSTEM:PUTPROP + (push '((t t t) t #.(flags set)"putprop(#0,#1,#2)") + (get 'system:putprop 'inline-always)) + +;;SYSTEM:SCHAR-SET + (push '((t t t) t #.(flags set)"elt_set(#0,fixint(#1),#2)") + (get 'system:schar-set 'inline-always)) +(push '((t fixnum t) t #.(flags set)"elt_set(#0,#1,#2)") + (get 'system:schar-set 'inline-always)) +(push '((t t t) t #.(flags set) + "@2;((#0)->ust.ust_self[fix(#1)]=char_code(#2),(#2))") + (get 'system:schar-set 'inline-unsafe)) +(push '((t fixnum character) character #.(flags set rfa)"(#0)->ust.ust_self[#1]= (#2)") + (get 'system:schar-set 'inline-unsafe)) + +;;SYSTEM:SET-MV + (push '((fixnum t) t #.(flags ans set)"(MVloc[(#0)]=(#1))") + (get 'system:set-mv 'inline-always)) + +;;SYSTEM:SPUTPROP + (push '((t t t) t #.(flags set)"sputprop(#0,#1,#2)") + (get 'system:sputprop 'inline-always)) + +;;SYSTEM:STRUCTURE-DEF + (push '((t) t #.(flags)"(#0)->str.str_def") + (get 'system:structure-def 'inline-unsafe)) + +;;SYSTEM:STRUCTURE-LENGTH + (push '((t) fixnum #.(flags rfa)"S_DATA(#0)->length") + (get 'system:structure-length 'inline-unsafe)) + +;;SYSTEM:STRUCTURE-REF + (push '((t t fixnum) t #.(flags ans)"structure_ref(#0,#1,#2)") + (get 'system:structure-ref 'inline-always)) + +;;SYSTEM:STRUCTURE-SET + (push '((t t fixnum t) t #.(flags set)"structure_set(#0,#1,#2,#3)") + (get 'system:structure-set 'inline-always)) + +;;SYSTEM:STRUCTUREP + (push '((t) boolean #.(flags)"type_of(#0)==t_structure") + (get 'system:structurep 'inline-always)) + +;;SYSTEM:gethash1 + (push '((t t) t #.(flags)"({struct htent *e=gethash(#0,#1);e->hte_key != OBJNULL ? e->hte_value : Cnil;})") + (get 'system:gethash1 'inline-always)) + +;;SYSTEM:SVSET + (push '((t t t) t #.(flags set)"aset1(#0,fixint(#1),#2)") + (get 'system:svset 'inline-always)) +(push '((t fixnum t) t #.(flags set)"aset1(#0,#1,#2)") + (get 'system:svset 'inline-always)) +(push '((t t t) t #.(flags set)"((#0)->v.v_self[fix(#1)]=(#2))") + (get 'system:svset 'inline-unsafe)) +(push '((t fixnum t) t #.(flags set)"(#0)->v.v_self[#1]= (#2)") + (get 'system:svset 'inline-unsafe)) + +;;* +(push '((t t) t #.(flags ans) "immnum_times(#0,#1)");"number_times(#0,#1)" + (get '* 'inline-always)) +(push '((fixnum-float fixnum-float) short-float #.(flags)"(double)(#0)*(double)(#1)") + (get '* 'inline-always)) +(push '((fixnum-float fixnum-float) long-float #.(flags)"(double)(#0)*(double)(#1)") + (get '* 'inline-always)) +(push '((long-float long-float) long-float #.(flags rfa)"(double)(#0)*(double)(#1)") + (get '* 'inline-always)) +(push '((short-float short-float) short-float #.(flags rfa)"(#0)*(#1)") + (get '* 'inline-always)) + + +(push '((fixnum fixnum) fixnum #.(flags)"(#0)*(#1)") + (get '* 'inline-always)) + + +;;+ +;; (push '((t t) t #.(flags ans)"number_plus(#0,#1)") +;; (get '+ 'inline-always)) +(push '((t t) t #.(flags ans)"immnum_plus(#0,#1)") (get '+ 'inline-always)) +(push '((fixnum-float fixnum-float) short-float #.(flags)"(double)(#0)+(double)(#1)") + (get '+ 'inline-always)) +(push '((fixnum-float fixnum-float) long-float #.(flags)"(double)(#0)+(double)(#1)") + (get '+ 'inline-always)) +(push '((long-float long-float) long-float #.(flags rfa)"(double)(#0)+(double)(#1)") + (get '+ 'inline-always)) +(push '((short-float short-float) short-float #.(flags rfa)"(#0)+(#1)") + (get '+ 'inline-always)) + + +(push '((fixnum fixnum) fixnum #.(flags)"(#0)+(#1)") + (get '+ 'inline-always)) + + +;;- + ;; (push '((t) t #.(flags ans)"number_negate(#0)") + ;; (get '- 'inline-always)) +(push '((t) t #.(flags ans)"immnum_negate(#0)") (get '- 'inline-always)) +(push '((t t) t #.(flags ans)"immnum_minus(#0,#1)") (get '- 'inline-always)) +;; (push '((t t) t #.(flags ans)"number_minus(#0,#1)") +;; (get '- 'inline-always)) +(push '((fixnum-float fixnum-float) short-float #.(flags)"(double)(#0)-(double)(#1)") + (get '- 'inline-always)) +(push '((fixnum-float) short-float #.(flags)"-(double)(#0)") + (get '- 'inline-always)) +(push '((fixnum-float) long-float #.(flags)"-(double)(#0)") + (get '- 'inline-always)) +(push '((fixnum-float fixnum-float) long-float #.(flags)"(double)(#0)-(double)(#1)") + (get '- 'inline-always)) +(push '((long-float long-float) long-float #.(flags rfa)"(double)(#0)-(double)(#1)") + (get '- 'inline-always)) +(push '((short-float short-float) short-float #.(flags rfa)"(#0)-(#1)") + (get '- 'inline-always)) + + +(push '((fixnum fixnum) fixnum #.(flags)"(#0)-(#1)") + (get '- 'inline-always)) +(push '((fixnum) fixnum #.(flags)"-(#0)") + (get '- 'inline-always)) + + +;;/ +(push '((fixnum fixnum) fixnum #.(flags)"(#0)/(#1)") + (get '/ 'inline-always)) + (push '((fixnum-float fixnum-float) short-float #.(flags)"(double)(#0)/(double)(#1)") + (get '/ 'inline-always)) +(push '((fixnum-float fixnum-float) long-float #.(flags)"(double)(#0)/(double)(#1)") + (get '/ 'inline-always)) +(push '((long-float long-float) long-float #.(flags rfa)"(double)(#0)/(double)(#1)") + (get '/ 'inline-always)) +(push '((short-float short-float) short-float #.(flags rfa)"(#0)/(#1)") + (get '/ 'inline-always)) + +;;/= + (push '((t t) boolean #.(flags rfa)"immnum_ne(#0,#1)") + (get '/= 'inline-always)) + ;; (push '((t t) boolean #.(flags)"number_compare(#0,#1)!=0") + ;; (get '/= 'inline-always)) +(push '((fixnum-float fixnum-float) boolean #.(flags)"(#0)!=(#1)") + (get '/= 'inline-always)) + +;;1+ + ;; (push '((t) t #.(flags ans)"one_plus(#0)") + ;; (get '1+ 'inline-always)) + (push '((t) t #.(flags ans)"immnum_plus(#0,make_fixnum(1))") + (get '1+ 'inline-always)) +(push '((fixnum-float) short-float #.(flags)"(double)(#0)+1") + (get '1+ 'inline-always)) +(push '((fixnum-float) long-float #.(flags)"(double)(#0)+1") + (get '1+ 'inline-always)) +(push '((fixnum) fixnum #.(flags)"(#0)+1") + (get '1+ 'inline-always)) + + +;;1- + ;; (push '((t) t #.(flags ans)"one_minus(#0)") + ;; (get '1- 'inline-always)) + (push '((t) t #.(flags ans)"immnum_plus(#0,make_fixnum(-1))") + (get '1- 'inline-always)) +(push '((fixnum) fixnum #.(flags)"(#0)-1") + (get '1- 'inline-always)) +(push '((fixnum-float) short-float #.(flags)"(double)(#0)-1") + (get '1- 'inline-always)) +(push '((fixnum-float) long-float #.(flags)"(double)(#0)-1") + (get '1- 'inline-always)) + +;;< + (push '((t t) boolean #.(flags rfa)"immnum_lt(#0,#1)") (get '< 'inline-always)) + ;; (push '((t t) boolean #.(flags)"number_compare(#0,#1)<0") + ;; (get '< 'inline-always)) +(push '((fixnum-float fixnum-float) boolean #.(flags)"(#0)<(#1)") + (get '< 'inline-always)) + +;;compiler::objlt + (push '((t t) boolean #.(flags)"((object)(#0))<((object)(#1))") + (get 'si::objlt 'inline-always)) + +;;<= + (push '((t t) boolean #.(flags rfa)"immnum_le(#0,#1)") (get '<= 'inline-always)) + ;; (push '((t t) boolean #.(flags)"number_compare(#0,#1)<=0") + ;; (get '<= 'inline-always)) + +(push '((fixnum-float fixnum-float) boolean #.(flags)"(#0)<=(#1)") + (get '<= 'inline-always)) + +;;= + (push '((t t) boolean #.(flags rfa)"immnum_eq(#0,#1)") (get '= 'inline-always)) + ;; (push '((t t) boolean #.(flags)"number_compare(#0,#1)==0") + ;; (get '= 'inline-always)) + +(push '((fixnum-float fixnum-float) boolean #.(flags)"(#0)==(#1)") + (get '= 'inline-always)) + +;;> + (push '((t t) boolean #.(flags rfa)"immnum_gt(#0,#1)") (get '> 'inline-always)) + ;; (push '((t t) boolean #.(flags)"number_compare(#0,#1)>0") + ;; (get '> 'inline-always)) + +(push '((fixnum-float fixnum-float) boolean #.(flags)"(#0)>(#1)") + (get '> 'inline-always)) + +;;>= + (push '((t t) boolean #.(flags rfa)"immnum_ge(#0,#1)") (get '>= 'inline-always)) + ;; (push '((t t) boolean #.(flags)"number_compare(#0,#1)>=0") + ;; (get '>= 'inline-always)) +(push '((fixnum-float fixnum-float) boolean #.(flags)"(#0)>=(#1)") + (get '>= 'inline-always)) + +;;APPEND + (push '((t t) t #.(flags ans)"append(#0,#1)") + (get 'append 'inline-always)) + +;;AREF +(push '((t t) t #.(flags ans)"fLrow_major_aref(#0,fixint(#1))") + (get 'aref 'inline-always)) +(push '((t fixnum) t #.(flags ans)"fLrow_major_aref(#0,#1)") + (get 'aref 'inline-always)) +(push '((t t) t #.(flags ans)"fLrow_major_aref(#0,fix(#1))") + (get 'aref 'inline-unsafe)) +(push '((t fixnum) t #.(flags ans)"fLrow_major_aref(#0,#1)") + (get 'aref 'inline-unsafe)) +(push '(((array t) fixnum) t #.(flags)"(#0)->v.v_self[#1]") + (get 'aref 'inline-unsafe)) +(push '(((array string-char) fixnum) character #.(flags rfa)"(#0)->ust.ust_self[#1]") + (get 'aref 'inline-unsafe)) +(push '(((array fixnum) fixnum) fixnum #.(flags rfa)"(#0)->fixa.fixa_self[#1]") + (get 'aref 'inline-unsafe)) +(push '(((array unsigned-char) fixnum) fixnum #.(flags rfa)"(#0)->ust.ust_self[#1]") + (get 'aref 'inline-unsafe)) +(push '(((array signed-char) fixnum) fixnum #.(flags rfa)"SIGNED_CHAR((#0)->ust.ust_self[#1])") + (get 'aref 'inline-unsafe)) +(push '(((array unsigned-short) fixnum) fixnum #.(flags rfa) + "((unsigned short *)(#0)->ust.ust_self)[#1]") + (get 'aref 'inline-unsafe)) +(push '(((array signed-short) fixnum) fixnum #.(flags rfa)"((short *)(#0)->ust.ust_self)[#1]") + (get 'aref 'inline-unsafe)) +(push '(((array short-float) fixnum) short-float #.(flags rfa)"(#0)->sfa.sfa_self[#1]") + (get 'aref 'inline-unsafe)) +(push '(((array long-float) fixnum) long-float #.(flags rfa)"(#0)->lfa.lfa_self[#1]") + (get 'aref 'inline-unsafe)) +;; (push '((t t t) t #.(flags ans) +;; "@0;aref(#0,fix(#1)*(#0)->a.a_dims[1]+fix(#2))") +;; (get 'aref 'inline-unsafe)) +(push '(((array t) fixnum fixnum) t #.(flags ) + "@0;(#0)->a.a_self[(#1)*(#0)->a.a_dims[1]+#2]") + (get 'aref 'inline-unsafe)) +(push '(((array string-char) fixnum fixnum) character #.(flags rfa) + "@0;(#0)->ust.ust_self[(#1)*(#0)->a.a_dims[1]+#2]") + (get 'aref 'inline-unsafe)) +(push '(((array fixnum) fixnum fixnum) fixnum #.(flags rfa) + "@0;(#0)->fixa.fixa_self[(#1)*(#0)->a.a_dims[1]+#2]") + (get 'aref 'inline-unsafe)) +(push '(((array short-float) fixnum fixnum) short-float #.(flags rfa) + "@0;(#0)->sfa.sfa_self[(#1)*(#0)->a.a_dims[1]+#2]") + (get 'aref 'inline-unsafe)) +(push '(((array long-float) fixnum fixnum) long-float #.(flags rfa) + "@0;(#0)->lfa.lfa_self[(#1)*(#0)->a.a_dims[1]+#2]") + (get 'aref 'inline-unsafe)) + +;;ARRAY-TOTAL-SIZE + (push '((t) fixnum #.(flags rfa)"((#0)->st.st_dim)") + (get 'array-total-size 'inline-unsafe)) + +;;ARRAYP + (push '((t) boolean #.(flags) + "@0;type_of(#0)==t_array|| +type_of(#0)==t_vector|| +type_of(#0)==t_string|| +type_of(#0)==t_bitvector") + (get 'arrayp 'inline-always)) + +;;ATOM + (push '((t) boolean #.(flags)"type_of(#0)!=t_cons") + (get 'atom 'inline-always)) + +;;BIT-VECTOR-P + (push '((t) boolean #.(flags)"(type_of(#0)==t_bitvector)") + (get 'bit-vector-p 'inline-always)) + +;;BOUNDP + (push '((t) boolean #.(flags)"(#0)->s.s_dbind!=OBJNULL") + (get 'boundp 'inline-unsafe)) + +;;CAAAAR + (push '((t) t #.(flags)"caaaar(#0)") + (get 'caaaar 'inline-safe)) +(push '((t) t #.(flags)"CMPcaaaar(#0)") + (get 'caaaar 'inline-unsafe)) + +;;CAAADR + (push '((t) t #.(flags)"caaadr(#0)") + (get 'caaadr 'inline-safe)) +(push '((t) t #.(flags)"CMPcaaadr(#0)") + (get 'caaadr 'inline-unsafe)) + +;;CAAAR + (push '((t) t #.(flags)"caaar(#0)") + (get 'caaar 'inline-safe)) +(push '((t) t #.(flags)"CMPcaaar(#0)") + (get 'caaar 'inline-unsafe)) + +;;CAADAR + (push '((t) t #.(flags)"caadar(#0)") + (get 'caadar 'inline-safe)) +(push '((t) t #.(flags)"CMPcaadar(#0)") + (get 'caadar 'inline-unsafe)) + +;;CAADDR + (push '((t) t #.(flags)"caaddr(#0)") + (get 'caaddr 'inline-safe)) +(push '((t) t #.(flags)"CMPcaaddr(#0)") + (get 'caaddr 'inline-unsafe)) + +;;CAADR + (push '((t) t #.(flags)"caadr(#0)") + (get 'caadr 'inline-safe)) +(push '((t) t #.(flags)"CMPcaadr(#0)") + (get 'caadr 'inline-unsafe)) + +;;CAAR + (push '((t) t #.(flags)"caar(#0)") + (get 'caar 'inline-safe)) +(push '((t) t #.(flags)"CMPcaar(#0)") + (get 'caar 'inline-unsafe)) + +;;CADAAR + (push '((t) t #.(flags)"cadaar(#0)") + (get 'cadaar 'inline-safe)) +(push '((t) t #.(flags)"CMPcadaar(#0)") + (get 'cadaar 'inline-unsafe)) + +;;CADADR + (push '((t) t #.(flags)"cadadr(#0)") + (get 'cadadr 'inline-safe)) +(push '((t) t #.(flags)"CMPcadadr(#0)") + (get 'cadadr 'inline-unsafe)) + +;;CADAR + (push '((t) t #.(flags)"cadar(#0)") + (get 'cadar 'inline-safe)) +(push '((t) t #.(flags)"CMPcadar(#0)") + (get 'cadar 'inline-unsafe)) + +;;CADDAR + (push '((t) t #.(flags)"caddar(#0)") + (get 'caddar 'inline-safe)) +(push '((t) t #.(flags)"CMPcaddar(#0)") + (get 'caddar 'inline-unsafe)) + +;;CADDDR + (push '((t) t #.(flags)"cadddr(#0)") + (get 'cadddr 'inline-safe)) +(push '((t) t #.(flags)"CMPcadddr(#0)") + (get 'cadddr 'inline-unsafe)) + +;;CADDR + (push '((t) t #.(flags)"caddr(#0)") + (get 'caddr 'inline-safe)) +(push '((t) t #.(flags)"CMPcaddr(#0)") + (get 'caddr 'inline-unsafe)) + +;;CADR + (push '((t) t #.(flags)"cadr(#0)") + (get 'cadr 'inline-safe)) +(push '((t) t #.(flags)"CMPcadr(#0)") + (get 'cadr 'inline-unsafe)) + +;;CAR + (push '((t) t #.(flags)"car(#0)") + (get 'car 'inline-safe)) +(push '((t) t #.(flags)"CMPcar(#0)") + (get 'car 'inline-unsafe)) + +;;CDAAAR + (push '((t) t #.(flags)"cdaaar(#0)") + (get 'cdaaar 'inline-safe)) +(push '((t) t #.(flags)"CMPcdaaar(#0)") + (get 'cdaaar 'inline-unsafe)) + +;;CDAADR + (push '((t) t #.(flags)"cdaadr(#0)") + (get 'cdaadr 'inline-safe)) +(push '((t) t #.(flags)"CMPcdaadr(#0)") + (get 'cdaadr 'inline-unsafe)) + +;;CDAAR + (push '((t) t #.(flags)"cdaar(#0)") + (get 'cdaar 'inline-safe)) +(push '((t) t #.(flags)"CMPcdaar(#0)") + (get 'cdaar 'inline-unsafe)) + +;;CDADAR + (push '((t) t #.(flags)"cdadar(#0)") + (get 'cdadar 'inline-safe)) +(push '((t) t #.(flags)"CMPcdadar(#0)") + (get 'cdadar 'inline-unsafe)) + +;;CDADDR + (push '((t) t #.(flags)"cdaddr(#0)") + (get 'cdaddr 'inline-safe)) +(push '((t) t #.(flags)"CMPcdaddr(#0)") + (get 'cdaddr 'inline-unsafe)) + +;;CDADR + (push '((t) t #.(flags)"cdadr(#0)") + (get 'cdadr 'inline-safe)) +(push '((t) t #.(flags)"CMPcdadr(#0)") + (get 'cdadr 'inline-unsafe)) + +;;CDAR + (push '((t) t #.(flags)"cdar(#0)") + (get 'cdar 'inline-safe)) +(push '((t) t #.(flags)"CMPcdar(#0)") + (get 'cdar 'inline-unsafe)) + +;;CDDAAR + (push '((t) t #.(flags)"cddaar(#0)") + (get 'cddaar 'inline-safe)) +(push '((t) t #.(flags)"CMPcddaar(#0)") + (get 'cddaar 'inline-unsafe)) + +;;CDDADR + (push '((t) t #.(flags)"cddadr(#0)") + (get 'cddadr 'inline-safe)) +(push '((t) t #.(flags)"CMPcddadr(#0)") + (get 'cddadr 'inline-unsafe)) + +;;CDDAR + (push '((t) t #.(flags)"cddar(#0)") + (get 'cddar 'inline-safe)) +(push '((t) t #.(flags)"CMPcddar(#0)") + (get 'cddar 'inline-unsafe)) + +;;CDDDAR + (push '((t) t #.(flags)"cdddar(#0)") + (get 'cdddar 'inline-safe)) +(push '((t) t #.(flags)"CMPcdddar(#0)") + (get 'cdddar 'inline-unsafe)) + +;;CDDDDR + (push '((t) t #.(flags)"cddddr(#0)") + (get 'cddddr 'inline-safe)) +(push '((t) t #.(flags)"CMPcddddr(#0)") + (get 'cddddr 'inline-unsafe)) + +;;CDDDR + (push '((t) t #.(flags)"cdddr(#0)") + (get 'cdddr 'inline-safe)) +(push '((t) t #.(flags)"CMPcdddr(#0)") + (get 'cdddr 'inline-unsafe)) + +;;CDDR + (push '((t) t #.(flags)"cddr(#0)") + (get 'cddr 'inline-safe)) +(push '((t) t #.(flags)"CMPcddr(#0)") + (get 'cddr 'inline-unsafe)) + +;;CDR + (push '((t) t #.(flags)"cdr(#0)") + (get 'cdr 'inline-safe)) +(push '((t) t #.(flags)"CMPcdr(#0)") + (get 'cdr 'inline-unsafe)) + +;;CHAR + (push '((t t) t #.(flags ans)"elt(#0,fixint(#1))") + (get 'char 'inline-always)) +(push '((t fixnum) t #.(flags ans)"elt(#0,#1)") + (get 'char 'inline-always)) +(push '((t t) t #.(flags)"code_char((#0)->ust.ust_self[fix(#1)])") + (get 'char 'inline-unsafe)) +(push '((t fixnum) character #.(flags rfa)"(#0)->ust.ust_self[#1]") + (get 'char 'inline-unsafe)) + +;;CHAR-CODE + (push '((character) fixnum #.(flags rfa)"(#0)") + (get 'char-code 'inline-always)) + +;;CHAR/= + (push '((character character) boolean #.(flags)"(#0)!=(#1)") + (get 'char/= 'inline-always)) +(push '((t t) boolean #.(flags)"!eql(#0,#1)") + (get 'char/= 'inline-unsafe)) +(push '((t t) boolean #.(flags)"char_code(#0)!=char_code(#1)") + (get 'char/= 'inline-unsafe)) + +;;CHAR< + (push '((character character) boolean #.(flags)"(#0)<(#1)") + (get 'char< 'inline-always)) + +;;CHAR<= + (push '((character character) boolean #.(flags)"(#0)<=(#1)") + (get 'char<= 'inline-always)) + +;;CHAR= + (push '((t t) boolean #.(flags)"eql(#0,#1)") + (get 'char= 'inline-unsafe)) +(push '((t t) boolean #.(flags)"char_code(#0)==char_code(#1)") + (get 'char= 'inline-unsafe)) +(push '((character character) boolean #.(flags)"(#0)==(#1)") + (get 'char= 'inline-unsafe)) + +;;CHAR> + (push '((character character) boolean #.(flags)"(#0)>(#1)") + (get 'char> 'inline-always)) + +;;CHAR>= + (push '((character character) boolean #.(flags)"(#0)>=(#1)") + (get 'char>= 'inline-always)) + +;;CHARACTERP + (push '((t) boolean #.(flags)"type_of(#0)==t_character") + (get 'characterp 'inline-always)) + +;;CODE-CHAR + (push '((fixnum) character #.(flags)"(#0)") + (get 'code-char 'inline-always)) + +;;CONS + (push '((t t) t #.(flags ans)"make_cons(#0,#1)") + (get 'cons 'inline-always)) +(push '((t t) :dynamic-extent #.(flags ans)"ON_STACK_CONS(#0,#1)") + (get 'cons 'inline-always)) + +;;CONSP + (push '((t) boolean #.(flags)"type_of(#0)==t_cons") + (get 'consp 'inline-always)) + +;;COS + (push '((long-float) long-float #.(flags rfa)"cos(#0)") + (get 'cos 'inline-always)) + +;;DIGIT-CHAR-P + (push '((character) boolean #.(flags)"@0; ((#0) <= '9' && (#0) >= '0')") + (get 'digit-char-p 'inline-always)) + +;;ELT + (push '((t t) t #.(flags ans)"elt(#0,fixint(#1))") + (get 'elt 'inline-always)) +(push '((t fixnum) t #.(flags ans)"elt(#0,#1)") + (get 'elt 'inline-always)) +(push '((t t) t #.(flags ans)"elt(#0,fix(#1))") + (get 'elt 'inline-unsafe)) +(push '((t fixnum) t #.(flags ans)"elt(#0,#1)") + (get 'elt 'inline-unsafe)) + +;;ENDP +;;Must use endp_prop here as generic lisp code containing (endp +;;can be compiled to take function output as its argument, which +;;cannot be redirected via a macro, e.g. endp(cdr(V20)). CM + (push '((t) boolean #.(flags)"endp_prop(#0)") + (get 'endp 'inline-safe)) +(push '((t) boolean #.(flags)"(#0)==Cnil") + (get 'endp 'inline-unsafe)) + +;;EQ + (push '((t t) boolean #.(flags rfa)"(#0)==(#1)") + (get 'eq 'inline-always)) +(push '((fixnum fixnum) boolean #.(flags rfa)"0") + (get 'eq 'inline-always)) + +;;EQL + (push '((t t) boolean #.(flags rfa)"eql(#0,#1)") + (get 'eql 'inline-always)) +(push '((fixnum fixnum) boolean #.(flags rfa)"(#0)==(#1)") + (get 'eql 'inline-always)) +(push '((character character) boolean #.(flags rfa)"(#0)==(#1)") + (get 'eql 'inline-always)) + + +;;EQUAL + (push '((t t) boolean #.(flags rfa)"equal(#0,#1)") + (get 'equal 'inline-always)) +(push '((fixnum fixnum) boolean #.(flags rfa)"(#0)==(#1)") + (get 'equal 'inline-always)) + +;;EQUALP + (push '((t t) boolean #.(flags rfa)"equalp(#0,#1)") + (get 'equalp 'inline-always)) +(push '((fixnum fixnum) boolean #.(flags rfa)"(#0)==(#1)") + (get 'equalp 'inline-always)) + +;;EXPT + (push '((t t) t #.(flags ans)"number_expt(#0,#1)") + (get 'expt 'inline-always)) + +(push '((fixnum fixnum) fixnum #.(flags)(LAMBDA (LOC1 LOC2) + (IF + (AND (CONSP LOC1) + (EQ (CAR LOC1) 'FIXNUM-LOC) + (CONSP (CADR LOC1)) + (EQ (CAADR LOC1) + 'FIXNUM-VALUE) + (EQUAL (CADDR (CADR LOC1)) + 2)) + (WT "(1<<(" LOC2 "))") + (WT "fixnum_expt(" LOC1 #\, + LOC2 #\))))) + (get 'expt 'inline-always)) + + +;;FILL-POINTER + (push '((t) fixnum #.(flags rfa)"((#0)->st.st_fillp)") + (get 'fill-pointer 'inline-unsafe)) + +;;FIRST + (push '((t) t #.(flags)"car(#0)") + (get 'first 'inline-safe)) +(push '((t) t #.(flags)"CMPcar(#0)") + (get 'first 'inline-unsafe)) + +;;FLOAT + (push '((fixnum-float) long-float #.(flags)"((longfloat)(#0))") + (get 'float 'inline-always)) +(push '((fixnum-float) short-float #.(flags)"((shortfloat)(#0))") + (get 'float 'inline-always)) + +;;FLOATP + (push '((t) boolean #.(flags) + "@0;type_of(#0)==t_shortfloat||type_of(#0)==t_longfloat") + (get 'floatp 'inline-always)) + +;;CEILING +(push '((t t) t #.(compiler::flags) "immnum_ceiling(#0,#1)") (get 'ceiling 'compiler::inline-always)) + +;;FLOOR +; (push '((fixnum fixnum) fixnum #.(flags rfa) +; "@01;(#0>=0&&(#1)>0?(#0)/(#1):ifloor(#0,#1))") +; (get 'floor 'inline-always)) +(push '((t t) t #.(compiler::flags) "immnum_floor(#0,#1)") (get 'floor 'compiler::inline-always)) +(push '((fixnum fixnum) fixnum #.(flags rfa) + "@01;({fixnum _t=(#0)/(#1);((#1)<0 && (#0)<=0) || ((#1)>0 && (#0)>=0) || ((#1)*_t == (#0)) ? _t : _t - 1;})") + (get 'floor 'inline-always)) + +;;FOURTH + (push '((t) t #.(flags)"cadddr(#0)") + (get 'fourth 'inline-safe)) +(push '((t) t #.(flags)"CMPcadddr(#0)") + (get 'fourth 'inline-unsafe)) + +;;GET + (push '((t t t) t #.(flags)"get(#0,#1,#2)") + (get 'get 'inline-always)) +(push '((t t) t #.(flags)"get(#0,#1,Cnil)") + (get 'get 'inline-always)) + +;;INTEGERP + (push '((t) boolean #.(flags) + "@0;type_of(#0)==t_fixnum||type_of(#0)==t_bignum") + (get 'integerp 'inline-always)) +(push '((fixnum) boolean #.(flags) + "1") + (get 'integerp 'inline-always)) + + +;;KEYWORDP + (push '((t) boolean #.(flags) + "@0;(type_of(#0)==t_symbol&&(#0)->s.s_hpack==keyword_package)") + (get 'keywordp 'inline-always)) + +;;ADDRESS + (push '((t) fixnum #.(flags rfa)"((fixnum)(#0))") + (get 'si::address 'inline-always)) + +;;NANI + (push '((fixnum) t #.(flags rfa)"((object)(#0))") + (get 'si::nani 'inline-always)) + + +;;LENGTH + (push '((t) fixnum #.(flags rfa)"length(#0)") + (get 'length 'inline-always)) +(push '(((array t)) fixnum #.(flags rfa)"(#0)->v.v_fillp") + (get 'length 'inline-unsafe)) +(push '(((array fixnum)) fixnum #.(flags rfa)"(#0)->v.v_fillp") + (get 'length 'inline-unsafe)) +(push '((string) fixnum #.(flags rfa)"(#0)->v.v_fillp") + (get 'length 'inline-unsafe)) + +;;LIST + (push '(nil t #.(flags)"Cnil") + (get 'list 'inline-always)) +(push '((t) t #.(flags ans)"make_cons(#0,Cnil)") + (get 'list 'inline-always)) +(push '((t t) t #.(flags ans)LIST-INLINE) + (get 'list 'inline-always)) +(push '((t t t) t #.(flags ans)LIST-INLINE) + (get 'list 'inline-always)) +(push '((t t t t) t #.(flags ans)LIST-INLINE) + (get 'list 'inline-always)) +(push '((t t t t t) t #.(flags ans)LIST-INLINE) + (get 'list 'inline-always)) +(push '((t t t t t t) t #.(flags ans)LIST-INLINE) + (get 'list 'inline-always)) +(push '((t t t t t t t) t #.(flags ans)LIST-INLINE) + (get 'list 'inline-always)) +(push '((t t t t t t t t) t #.(flags ans)LIST-INLINE) + (get 'list 'inline-always)) +(push '((t t t t t t t t t) t #.(flags ans)LIST-INLINE) + (get 'list 'inline-always)) +(push '((t t t t t t t t t t) t #.(flags ans)LIST-INLINE) + (get 'list 'inline-always)) + +;;LIST* + (push '((t) t #.(flags)"(#0)") + (get 'list* 'inline-always)) +(push '((t t) t #.(flags ans)"make_cons(#0,#1)") + (get 'list* 'inline-always)) +(push '((t t t) t #.(flags ans)LIST*-INLINE) + (get 'list* 'inline-always)) +(push '((t t t t) t #.(flags ans)LIST*-INLINE) + (get 'list* 'inline-always)) +(push '((t t t t t) t #.(flags ans)LIST*-INLINE) + (get 'list* 'inline-always)) +(push '((t t t t t t) t #.(flags ans)LIST*-INLINE) + (get 'list* 'inline-always)) +(push '((t t t t t t t) t #.(flags ans)LIST*-INLINE) + (get 'list* 'inline-always)) +(push '((t t t t t t t t) t #.(flags ans)LIST*-INLINE) + (get 'list* 'inline-always)) +(push '((t t t t t t t t t) t #.(flags ans)LIST*-INLINE) + (get 'list* 'inline-always)) +(push '((t t t t t t t t t t) t #.(flags ans)LIST*-INLINE) + (get 'list* 'inline-always)) + +;;LISTP + (push '((t) boolean #.(flags)"@0;type_of(#0)==t_cons||(#0)==Cnil") + (get 'listp 'inline-always)) + +;;si::spice-p + (push '((t) boolean #.(flags)"@0;type_of(#0)==t_spice") + (get 'si::spice-p 'inline-always)) + +;;LOGNAND +(push '((t t) t #.(compiler::flags) "immnum_nand(#0,#1)") (get 'lognand 'compiler::inline-always)) +;;LOGNOR +(push '((t t) t #.(compiler::flags) "immnum_nor(#0,#1)") (get 'lognor 'compiler::inline-always)) +;;LOGEQV +(push '((t t) t #.(compiler::flags) "immnum_eqv(#0,#1)") (get 'logeqv 'compiler::inline-always)) + +;;LOGANDC1 +(push '((t t) t #.(compiler::flags) "immnum_andc1(#0,#1)") (get 'logandc1 'compiler::inline-always)) +;;LOGANDC2 +(push '((t t) t #.(compiler::flags) "immnum_andc2(#0,#1)") (get 'logandc2 'compiler::inline-always)) +;;LOGORC1 +(push '((t t) t #.(compiler::flags) "immnum_orc1(#0,#1)") (get 'logorc1 'compiler::inline-always)) +;;LOGORC1 +(push '((t t) t #.(compiler::flags) "immnum_orc2(#0,#1)") (get 'logorc2 'compiler::inline-always)) + + +;;LOGAND + (push '((t t) t #.(flags)"immnum_and((#0),(#1))") + (get 'logand 'inline-always)) + (push '((fixnum fixnum) fixnum #.(flags rfa)"((#0) & (#1))") + (get 'logand 'inline-always)) + +;;LOGIOR + (push '((t t) t #.(flags)"immnum_ior((#0),(#1))") + (get 'logior 'inline-always)) + (push '((fixnum fixnum) fixnum #.(flags rfa)"((#0) | (#1))") + (get 'logior 'inline-always)) + +;;LOGXOR + (push '((t t) t #.(flags)"immnum_xor((#0),(#1))") + (get 'logxor 'inline-always)) + (push '((fixnum fixnum) fixnum #.(flags rfa)"((#0) ^ (#1))") + (get 'logxor 'inline-always)) + +;;LOGNOT + (push '((t) t #.(flags)"immnum_not(#0)") + (get 'lognot 'inline-always)) + (push '((fixnum) fixnum #.(flags rfa)"(~(#0))") + (get 'lognot 'inline-always)) + +;;MAKE-LIST + (push '((fixnum) :dynamic-extent #.(flags ans) + "@0;(ALLOCA_CONS(#0),ON_STACK_MAKE_LIST(#0))") + (get 'make-list 'inline-always)) + +;;MAX + (push '((t t) t #.(flags) "immnum_max(#0,#1)");"@01;(number_compare(#0,#1)>=0?(#0):#1)" + (get 'max 'inline-always)) +(push '((fixnum fixnum) fixnum #.(flags rfa)"@01;((#0)>=(#1)?(#0):#1)") + (get 'max 'inline-always)) + +;;MIN + (push '((t t) t #.(flags) "immnum_min(#0,#1)");"@01;(number_compare(#0,#1)<=0?(#0):#1)" + (get 'min 'inline-always)) +(push '((fixnum fixnum) fixnum #.(flags rfa)"@01;((#0)<=(#1)?(#0):#1)") + (get 'min 'inline-always)) + +;;LDB +(push '((t t) t #.(compiler::flags) "immnum_ldb(#0,#1)") (get 'ldb 'compiler::inline-always)) +;;LDB-TEST +(push '((t t) boolean #.(compiler::flags) "immnum_ldbt(#0,#1)") (get 'ldb-test 'compiler::inline-always)) +;;LOGTEST +(push '((t t) boolean #.(compiler::flags) "immnum_logt(#0,#1)") (get 'logtest 'compiler::inline-always)) +;;DPB +(push '((t t t) t #.(compiler::flags) "immnum_dpb(#0,#1,#2)") (get 'dpb 'compiler::inline-always)) +;;DEPOSIT-FIELD +(push '((t t t) t #.(compiler::flags) "immnum_dpf(#0,#1,#2)") (get 'deposit-field 'compiler::inline-always)) + + +;;MINUSP + (push '((t) boolean #.(flags) "immnum_minusp(#0)");"number_compare(small_fixnum(0),#0)>0" + (get 'minusp 'inline-always)) +(push '((fixnum-float) boolean #.(flags)"(#0)<0") + (get 'minusp 'inline-always)) + +;;MOD +; (push '((fixnum fixnum) fixnum #.(flags rfa)"@01;(#0>=0&&(#1)>0?(#0)%(#1):imod(#0,#1))") +; (get 'mod 'inline-always)) +(push '((t t) t #.(compiler::flags) "immnum_mod(#0,#1)") (get 'mod 'compiler::inline-always)) +(push '((fixnum fixnum) fixnum #.(flags rfa)"@01;({fixnum _t=(#0)%(#1);((#1)<0 && _t<=0) || ((#1)>0 && _t>=0) ? _t : _t + (#1);})") + (get 'mod 'inline-always)) + +;;NCONC + (push '((t t) t #.(flags set)"nconc(#0,#1)") + (get 'nconc 'inline-always)) + +;;NOT + (push '((t) boolean #.(flags)"(#0)==Cnil") + (get 'not 'inline-always)) + +;;NREVERSE + (push '((t) t #.(flags ans set)"nreverse(#0)") + (get 'nreverse 'inline-always)) + +;;NTH +; (push '((t t) t #.(flags)"nth(fixint(#0),#1)") +; (get 'nth 'inline-always)) +; (push '((fixnum t) t #.(flags)"nth(#0,#1)") +; (get 'nth 'inline-always)) +; (push '((t t) t #.(flags)"nth(fix(#0),#1)") +; (get 'nth 'inline-unsafe)) + +;(push '((fixnum proper-list) proper-list #.(flags rfa)"({register fixnum _i=#0;register object _x=#1;for (;_i--;_x=_x->c.c_cdr);_x->c.c_car;})") +; (get 'nth 'inline-always)) +;(push '(((and (integer 0) (not fixnum)) proper-list) null #.(flags rfa)"Cnil") +; (get 'nth 'inline-always)) +(push '((fixnum t) t #.(flags)"({register fixnum _i=#0;register object _x=#1;for (;_i--;_x=_x->c.c_cdr);_x->c.c_car;})") + (get 'nth 'inline-unsafe)) +;(push '(((not fixnum) proper-list) null #.(flags rfa)"Cnil") +; (get 'nth 'inline-unsafe)) + +;;NTHCDR +; (push '((t t) t #.(flags)"nthcdr(fixint(#0),#1)") +; (get 'nthcdr 'inline-always)) +; (push '((fixnum t) t #.(flags)"nthcdr(#0,#1)") +; (get 'nthcdr 'inline-always)) +; (push '((t t) t #.(flags)"nthcdr(fix(#0),#1)") +; (get 'nthcdr 'inline-unsafe)) + +;(push '((fixnum proper-list) proper-list #.(flags rfa)"({register fixnum _i=#0;register object _x=#1;for (;_i--;_x=_x->c.c_cdr);_x;})") +; (get 'nthcdr 'inline-always)) +;(push '(((and (integer 0) (not fixnum)) proper-list) null #.(flags rfa)"Cnil") +; (get 'nthcdr 'inline-always)) +(push '((fixnum t) t #.(flags)"({register fixnum _i=#0;register object _x=#1;for (;_i--;_x=_x->c.c_cdr);_x;})") + (get 'nthcdr 'inline-unsafe)) +;(push '(((not fixnum) proper-list) null #.(flags rfa)"Cnil") +; (get 'nthcdr 'inline-unsafe)) + + +;;NULL + (push '((t) boolean #.(flags)"(#0)==Cnil") + (get 'null 'inline-always)) + +;;NUMBERP + (push '((t) boolean #.(flags) + "@0;type_of(#0)==t_fixnum|| +type_of(#0)==t_bignum|| +type_of(#0)==t_ratio|| +type_of(#0)==t_shortfloat|| +type_of(#0)==t_longfloat|| +type_of(#0)==t_complex") + (get 'numberp 'inline-always)) + +;;PLUSP + (push '((t) boolean #.(flags) "immnum_plusp(#0)");"number_compare(small_fixnum(0),#0)<0" + (get 'plusp 'inline-always)) +(push '((fixnum-float) boolean #.(flags)"(#0)>0") + (get 'plusp 'inline-always)) + +;;PRIN1 + (push '((t t) t #.(flags set)"prin1(#0,#1)") + (get 'prin1 'inline-always)) +(push '((t) t #.(flags set)"prin1(#0,Cnil)") + (get 'prin1 'inline-always)) + +;;PRINC + (push '((t t) t #.(flags set)"princ(#0,#1)") + (get 'princ 'inline-always)) +(push '((t) t #.(flags set)"princ(#0,Cnil)") + (get 'princ 'inline-always)) + +;;PRINT + (push '((t t) t #.(flags set)"print(#0,#1)") + (get 'print 'inline-always)) +(push '((t) t #.(flags set)"print(#0,Cnil)") + (get 'print 'inline-always)) + +;;PROBE-FILE + (push '((t) boolean #.(flags)"(file_exists(#0))") + (get 'probe-file 'inline-always)) + +;;RATIOP +(push '((t) boolean #.(flags) "type_of(#0)==t_ratio") + (get 'ratiop 'inline-always)) + +;;REM +(push '((t t) t #.(compiler::flags) "immnum_rem(#0,#1)") (get 'rem 'compiler::inline-always)) +#+TRUNCATE_USE_C +(push '((fixnum fixnum) fixnum #.(flags rfa)"(#0)%(#1)") + (get 'rem 'inline-always)) + + + + +;;REMPROP + (push '((t t) t #.(flags set)"remprop(#0,#1)") + (get 'remprop 'inline-always)) + +;;REST + (push '((t) t #.(flags)"cdr(#0)") + (get 'rest 'inline-safe)) +(push '((t) t #.(flags)"CMPcdr(#0)") + (get 'rest 'inline-unsafe)) + +;;REVERSE + (push '((t) t #.(flags ans)"reverse(#0)") + (get 'reverse 'inline-always)) + +;;SCHAR + (push '((t t) t #.(flags ans)"elt(#0,fixint(#1))") + (get 'schar 'inline-always)) +(push '((t fixnum) t #.(flags ans)"elt(#0,#1)") + (get 'schar 'inline-always)) +(push '((t t) t #.(flags rfa)"code_char((#0)->ust.ust_self[fix(#1)])") + (get 'schar 'inline-unsafe)) +(push '((t fixnum) character #.(flags rfa)"(#0)->ust.ust_self[#1]") + (get 'schar 'inline-unsafe)) + +;;SECOND + (push '((t) t #.(flags)"cadr(#0)") + (get 'second 'inline-safe)) +(push '((t) t #.(flags)"CMPcadr(#0)") + (get 'second 'inline-unsafe)) + +;;SIN + (push '((long-float) long-float #.(flags rfa)"sin(#0)") + (get 'sin 'inline-always)) + +;;STRING + (push '((t) t #.(flags ans)"coerce_to_string(#0)") + (get 'string 'inline-always)) + +;;STRINGP + (push '((t) boolean #.(flags)"type_of(#0)==t_string") + (get 'stringp 'inline-always)) + +;;SVREF +;; (push '((t t) t #.(flags ans)"aref1(#0,fixint(#1))") +;; (get 'svref 'inline-always)) +;; (push '((t fixnum) t #.(flags ans)"aref1(#0,#1)") +;; (get 'svref 'inline-always)) +(push '((t t) t #.(flags)"(#0)->v.v_self[fix(#1)]") + (get 'svref 'inline-unsafe)) +(push '((t fixnum) t #.(flags)"(#0)->v.v_self[#1]") + (get 'svref 'inline-unsafe)) + +;;SYMBOL-NAME + (push '((t) t #.(flags ans)"symbol_name(#0)") + (get 'symbol-name 'inline-always)) + +;;SYMBOL-PLIST +(push (list '(t) t #.(flags) "((#0)->s.s_plist)") + (get 'symbol-plist 'inline-unsafe)) + +;;SYMBOLP + (push '((t) boolean #.(flags)"type_of(#0)==t_symbol") + (get 'symbolp 'inline-always)) + +;;TAN + (push '((long-float) long-float #.(flags rfa)"tan(#0)") + (get 'tan 'inline-always)) + +;;SQRT + (push '((long-float) long-float #.(flags rfa)"sqrt((double)#0)") + (get 'sqrt 'inline-always)) + +;;TERPRI + (push '((t) t #.(flags set)"terpri(#0)") + (get 'terpri 'inline-always)) +(push '(nil t #.(flags set)"terpri(Cnil)") + (get 'terpri 'inline-always)) + +;;THIRD + (push '((t) t #.(flags)"caddr(#0)") + (get 'third 'inline-safe)) +(push '((t) t #.(flags)"CMPcaddr(#0)") + (get 'third 'inline-unsafe)) + +;;TRUNCATE +(push '((t t) t #.(compiler::flags) "immnum_truncate(#0,#1)") (get 'truncate 'compiler::inline-always)) +#+TRUNCATE_USE_C +(push '((fixnum fixnum) fixnum #.(flags rfa)"(#0)/(#1)") + (get 'truncate 'inline-always)) +(push '((fixnum-float) fixnum #.(flags)"(fixnum)(#0)") + (get 'truncate 'inline-always)) + + + +;;VECTORP + (push '((t) boolean #.(flags) + "@0;type_of(#0)==t_vector|| +type_of(#0)==t_string|| +type_of(#0)==t_bitvector") + (get 'vectorp 'inline-always)) + +;;WRITE-CHAR + (push '((t) t #.(flags set) + "@0;(writec_stream(char_code(#0),Vstandard_output->s.s_dbind),(#0))") + (get 'write-char 'inline-unsafe)) + +;;EVENP +(push '((t) boolean #.(compiler::flags) "immnum_evenp(#0)") (get 'evenp 'compiler::inline-always)) +;;ODDP +(push '((t) boolean #.(compiler::flags) "immnum_oddp(#0)") (get 'oddp 'compiler::inline-always)) + +;;SIGNUM +(push '((t) t #.(compiler::flags) "immnum_signum(#0)") (get 'signum 'compiler::inline-always)) + + +;;ZEROP + (push '((t) boolean #.(flags) "immnum_zerop(#0)");"number_compare(small_fixnum(0),#0)==0" + (get 'zerop 'inline-always)) + +(push '((fixnum-float) boolean #.(flags)"(#0)==0") + (get 'zerop 'inline-always)) + +;;CMOD + (push '((t) t #.(flags) "cmod(#0)") + (get 'system:cmod 'inline-always)) + +;;CTIMES + (push '((t t) t #.(flags) "ctimes(#0,#1)") + (get 'system:ctimes 'inline-always)) + +;;CPLUS + (push '((t t) t #.(flags) "cplus(#0,#1)") + (get 'system:cplus 'inline-always)) + +;;CDIFFERENCE + (push '((t t) t #.(flags) "cdifference(#0,#1)") + (get 'system:cdifference 'inline-always)) + +;;si::static-inverse-cons +(push '((t) t #.(compiler::flags) "({object _y=(object)fixint(#0);is_imm_fixnum(_y) ? Cnil : (is_imm_fixnum(_y->c.c_cdr) ? _y : (_y->d.f||_y->d.e ? Cnil : _y));})") (get 'si::static-inverse-cons 'compiler::inline-always)) +(push '((fixnum) t #.(compiler::flags) "({object _y=(object)#0;is_imm_fixnum(_y) ? Cnil : (is_imm_fixnum(_y->c.c_cdr) ? _y : (_y->d.f||_y->d.e ? Cnil : _y));})") (get 'si::static-inverse-cons 'compiler::inline-always)) +(push '((t) t #.(compiler::flags) "({object _y=(object)fix(#0);is_imm_fixnum(_y) ? Cnil : (is_imm_fixnum(_y->c.c_cdr) ? _y : (_y->d.f||_y->d.e ? Cnil : _y));})") (get 'si::static-inverse-cons 'compiler::inline-unsafe)) +(push '((fixnum) t #.(compiler::flags) "({object _y=(object)#0;is_imm_fixnum(_y) ? Cnil : (is_imm_fixnum(_y->c.c_cdr) ? _y : (_y->d.f||_y->d.e ? Cnil : _y));})") (get 'si::static-inverse-cons 'compiler::inline-unsafe)) + +;;symbol-value +(push '((t) t #.(compiler::flags) "(#0)->s.s_dbind") + (get 'symbol-value 'compiler::inline-unsafe)) +(push '((t) t #.(compiler::flags) "@0;type_of(#0)!=t_symbol ? (not_a_symbol(#0),Cnil) : ((#0)->s.s_dbind==OBJNULL ? (FEerror(\"unbound variable\",0),Cnil) : (#0)->s.s_dbind)") + (get 'symbol-value 'compiler::inline-always)) +(push '((symbol) t #.(compiler::flags) "@0;(#0)->s.s_dbind==OBJNULL ? (FEerror(\"unbound variable\",0),Cnil) : (#0)->s.s_dbind") + (get 'symbol-value 'compiler::inline-always)) + +;;acons +(push '((t t t) t #.(compiler::flags) "MMcons(MMcons((#0),(#1)),(#2))") + (get 'acons 'compiler::inline-always)) diff --git a/cmpnew/gcl_cmpspecial.lsp b/cmpnew/gcl_cmpspecial.lsp new file mode 100755 index 0000000..7c7d043 --- /dev/null +++ b/cmpnew/gcl_cmpspecial.lsp @@ -0,0 +1,153 @@ +;;; CMPSPECIAL Miscellaneous special forms. +;;; +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +(in-package 'compiler) + +(si:putprop 'quote 'c1quote 'c1special) +(si:putprop 'function 'c1function 'c1special) +(si:putprop 'function 'c2function 'c2) +(si:putprop 'the 'c1the 'c1special) +(si:putprop 'eval-when 'c1eval-when 'c1special) +(si:putprop 'declare 'c1declare 'c1special) +(si:putprop 'compiler-let 'c1compiler-let 'c1special) +(si:putprop 'compiler-let 'c2compiler-let 'c2) + +(defun c1quote (args) + (when (endp args) (too-few-args 'quote 1 0)) + (unless (endp (cdr args)) (too-many-args 'quote 1 (length args))) + (c1constant-value (car args) t) + ) + +(defun c1eval-when (args) + (when (endp args) (too-few-args 'eval-when 1 0)) + (dolist** (situation (car args) (c1nil)) + (case situation + (eval (return-from c1eval-when (c1progn (cdr args)))) + ((load compile)) + (otherwise + (cmperr "The situation ~s is illegal." situation)))) + ) + +(defun c1declare (args) + (cmperr "The declaration ~s was found in a bad place." (cons 'declare args)) + ) + +(defun c1the (args &aux info form type) + (when (or (endp args) (endp (cdr args))) + (too-few-args 'the 2 (length args))) + (unless (endp (cddr args)) + (too-many-args 'the 2 (length args))) + (setq form (c1expr (cadr args))) + (setq info (copy-info (cadr form))) + (setq type (type-and (type-filter (car args)) (info-type info))) + (when (null type) + (when (and (type>= 'boolean (type-filter (car args))) + (type>= (type-filter (car args)) 'boolean)) + (return-from c1the (c1the (list 'boolean `(unless (eq nil ,(cadr args)) t))))) + (cmpwarn "Type mismatch was found in ~s." (cons 'the args))) + (setf (info-type info) type) + (list* (car form) info (cddr form)) + ) + +(defun c1compiler-let (args &aux (symbols nil) (values nil)) + (when (endp args) (too-few-args 'compiler-let 1 0)) + (dolist** (spec (car args)) + (cond ((consp spec) + (cmpck (not (and (symbolp (car spec)) + (or (endp (cdr spec)) + (endp (cddr spec))))) + "The variable binding ~s is illegal." spec) + (push (car spec) symbols) + (push (if (endp (cdr spec)) nil (eval (cadr spec))) values)) + ((symbolp spec) + (push spec symbols) + (push nil values)) + (t (cmperr "The variable binding ~s is illegal." spec)))) + (setq symbols (reverse symbols)) + (setq values (reverse values)) + (setq args (progv symbols values (c1progn (cdr args)))) + (list 'compiler-let (cadr args) symbols values args) + ) + +(defun c2compiler-let (symbols values body) + (progv symbols values (c2expr body))) + +(defun c1function (args &aux fd) + (when (endp args) (too-few-args 'function 1 0)) + (unless (endp (cdr args)) (too-many-args 'function 1 (length args))) + (let ((fun (car args))) + (cond ((symbolp fun) + (cond ((and (setq fd (c1local-closure fun)) + (eq (car fd) 'call-local)) + (list 'function *info* fd)) + (t (let ((info (make-info + :sp-change + (null (get fun 'no-sp-change))))) + (list 'function info (list 'call-global info fun)) + )))) + ((and (consp fun) (eq (car fun) 'lambda)) + (cmpck (endp (cdr fun)) + "The lambda expression ~s is illegal." fun) + (let ((*vars* (cons 'cb *vars*)) + (*funs* (cons 'cb *funs*)) + (*blocks* (cons 'cb *blocks*)) + (*tags* (cons 'cb *tags*))) + (setq fun (c1lambda-expr (cdr fun))) + (list 'function (cadr fun) fun))) + (t (cmperr "The function ~s is illegal." fun)))) + ) + +(defun c2function (funob) + (case (car funob) + (call-global + (unwind-exit (list 'symbol-function (add-symbol (caddr funob))))) + (call-local + (if (cadddr funob) + (unwind-exit (list 'ccb-vs (fun-ref-ccb (caddr funob)))) + (unwind-exit (list 'vs* (fun-ref (caddr funob)))))) + (t + ;;; Lambda closure. + (let ((fun (make-fun :name 'closure :cfun (next-cfun)))) + (push (list 'closure (if (null *clink*) nil (cons 'fun-env 0)) + *ccb-vs* fun funob) + *local-funs*) + (push fun *closures*) + (cond (*clink* + (unwind-exit (list 'make-cclosure (fun-cfun fun) *clink* (fun-name fun)))) + (t (unwind-exit (list 'vv (cons 'si::|#,| + `(si::mc nil ,(add-address + (c-function-name "&LC" (fun-cfun fun) (fun-name fun)))))))))) + )) + ) + +(si:putprop 'symbol-function 'wt-symbol-function 'wt-loc) +(si:putprop 'make-cclosure 'wt-make-cclosure 'wt-loc) + +(defun wt-symbol-function (vv) + (if *safe-compile* + (wt "symbol_function(" (vv-str vv) ")") + (wt "(" (vv-str vv) "->s.s_gfdef)"))) + +(defun wt-make-cclosure (cfun clink fname) + (wt-nl "make_cclosure_new(" (c-function-name "LC" cfun fname) ",Cnil,") + (wt-clink clink) + (wt ",Cdata)")) + diff --git a/cmpnew/gcl_cmptag.lsp b/cmpnew/gcl_cmptag.lsp new file mode 100755 index 0000000..58ba247 --- /dev/null +++ b/cmpnew/gcl_cmptag.lsp @@ -0,0 +1,418 @@ +;;; CMPTAG Tagbody and Go. +;;; +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +(in-package 'compiler) +(import 'si::switch) +(import 'si::switch-finish) + + +(si:putprop 'tagbody 'c1tagbody 'c1special) +(si:putprop 'tagbody 'c2tagbody 'c2) + +(si:putprop 'go 'c1go 'c1special) +(si:putprop 'go 'c2go 'c2) + +(defstruct tag + name ;;; Tag name. + ref ;;; Referenced or not. T or NIL. + ref-clb ;;; Cross local function reference. + ;;; During Pass1, T or NIL. + ;;; During Pass2, the vs-address for the + ;;; tagbody id, or NIL. + ref-ccb ;;; Cross closure reference. + ;;; During Pass1, T or NIL. + ;;; During Pass2, the vs-address for the + ;;; block id, or NIL. + label ;;; Where to jump. A label. + unwind-exit ;;; Where to unwind-no-exit. + var ;;; The tag-name holder. A VV index. + switch ;;; tag for switch. A fixnum or 'default + ) + +(defvar *tags* nil) + +;;; During Pass 1, *tags* holds a list of tag objects and the symbols 'CB' +;;; (Closure Boundary) and 'LB' (Level Boundary). 'CB' will be pushed on +;;; *tags* when the compiler begins to process a closure. 'LB' will be pushed +;;; on *tags* when *level* is incremented. + + + +(defun jumps-to-p (clause tag-name &aux tem) +;;Does CLAUSE have a go TAG-NAME in it? + (cond ((atom clause)nil) + ((and (eq (car clause) 'go) + (tag-p (setq tem (cadddr (cdr clause)))) + (eq (tag-name tem) tag-name))) + (t (or (jumps-to-p (car clause) tag-name) + (jumps-to-p (cdr clause) tag-name))))) + +(defvar *reg-amount* 60) +;;amount to increase var-register for each variable reference in side a loop + +(defun add-reg1 (form) +;;increase the var-register in FORM for all vars + (cond ((atom form) + (cond ((typep form 'var) + (setf (var-register form) + (the fixnum (+ (the fixnum (var-register form)) + (the fixnum *reg-amount*)))) + ))) + (t (add-reg1 (car form)) + (add-reg1 (cdr form))))) + + +(defun add-loop-registers (tagbody) +;;Find a maximal iteration interval in TAGBODY from first to end +;;then increment the var-register slot. + (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)))) + (cond ((typep (car v) 'tag) + (or first (setq first v)) + (do ((w (cdr v) (cdr w)) + (name (tag-name (car v)))) + ((null w) ) + (cond ((jumps-to-p (car w) name) + (setq end w)))))))) + +(defun c1tagbody (body &aux (*tags* *tags*) (info (make-info))) + ;;; Establish tags. + (setq body + (mapcar + #'(lambda (x) + (cond ((or (symbolp x) (integerp x)) + (let ((tag (make-tag :name x :ref nil + :ref-ccb nil :ref-clb nil))) + (push tag *tags*) + tag)) + (t x))) + body)) + + ;;; Process non-tag forms. + (setq body (mapcar #'(lambda (x) (if (typep x 'tag) x (c1expr* x info))) + body)) + + ;;; Delete redundant tags. + (do ((l body (cdr l)) + (body1 nil) (ref nil) (ref-clb nil) (ref-ccb nil)) + ((endp l) + (if (or ref-ccb ref-clb ref) + (progn (setq body1 (nreverse body1)) + ;; If ref-ccb is set, we will cons up the environment, hence + ;; all tags which had level boundary references must be changed + ;; to ccb references. FIXME -- review this logic carefully + ;; CM 20040228 + (when ref-ccb + (dolist (l body1) + (when (and (typep l 'tag) (tag-ref-clb l)) + (setf (tag-ref-ccb l) t)))) + (cond ((or ref-clb ref-ccb) + (incf *setjmps*)) + (t + (add-loop-registers body1 ))) + (list 'tagbody info ref-clb ref-ccb body1)) + (list 'progn info (nreverse (cons (c1nil) body1))))) + (declare (object l ref ref-clb ref-ccb)) + (if (typep (car l) 'tag) + (cond ((tag-ref-ccb (car l)) + (push (car l) body1) + (setf (tag-var (car l)) (add-object (tag-name (car l)))) + (setq ref-ccb t)) + ((tag-ref-clb (car l)) + (push (car l) body1) + (setf (tag-var (car l)) (add-object (tag-name (car l)))) + (setq ref-clb t)) + ((tag-ref (car l)) (push (car l) body1) (setq ref t))) + (push (car l) body1)))) + +(defun c2tagbody (ref-clb ref-ccb body) + (cond (ref-ccb (c2tagbody-ccb body)) + (ref-clb (c2tagbody-clb body)) + (t (c2tagbody-local body)))) + +(defun c2tagbody-local (body &aux (label (next-label))) + ;;; Allocate labels. + (dolist** (x body) + (when (typep x 'tag) + (setf (tag-label x) (next-label*)) + (setf (tag-unwind-exit x) label))) + (let ((*unwind-exit* (cons label *unwind-exit*))) + (c2tagbody-body body)) + + ) + +(defun c2tagbody-body (body) + (do ((l body (cdr l)) (written nil)) + ((endp (cdr l)) + (cond (written (unwind-exit nil)) + ((typep (car l) 'tag) + (wt-switch-case (tag-switch (car l))) + (wt-label (tag-label (car l))) + (unwind-exit nil)) + (t (let* ((*exit* (next-label)) + (*unwind-exit* (cons *exit* *unwind-exit*)) + (*value-to-go* 'trash)) + (c2expr (car l)) + (wt-label *exit*)) + (unless (eq (caar l) 'go) (unwind-exit nil))))) + (declare (object l written)) + (cond (written (setq written nil)) + ((typep (car l) 'tag) + (wt-switch-case (tag-switch (car l))) + (wt-label (tag-label (car l)))) + (t (let* ((*exit* (if (typep (cadr l) 'tag) + (progn (setq written t) (tag-label (cadr l))) + (next-label))) + (*unwind-exit* (cons *exit* *unwind-exit*)) + (*value-to-go* 'trash)) + (c2expr (car l)) + (and (typep (cadr l) 'tag) + (wt-switch-case (tag-switch (cadr l)))) + (wt-label *exit*)))))) + +(defun c2tagbody-clb (body &aux (label (next-label)) (*vs* *vs*)) + (let ((*unwind-exit* (cons 'frame *unwind-exit*)) + (ref-clb (vs-push))) + (wt-nl) (wt-vs ref-clb) (wt "=alloc_frame_id();") + (wt-nl "frs_push(FRS_CATCH,") (wt-vs ref-clb) (wt ");") + (wt-nl "if(nlj_active){") + (wt-nl "nlj_active=FALSE;") + ;;; Allocate labels. + (dolist** (tag body) + (when (typep tag 'tag) + (setf (tag-label tag) (next-label*)) + (setf (tag-unwind-exit tag) label) + (when (tag-ref-clb tag) + (setf (tag-ref-clb tag) ref-clb) + (wt-nl "if(eql(nlj_tag," (vv-str (tag-var tag)) ")) {") + (wt-nl " ") + (reset-top) + (wt-nl " ") + (wt-go (tag-label tag)) + (wt-nl "}")))) + (wt-nl "FEerror(\"The GO tag ~s is not established.\",1,nlj_tag);") + (wt-nl "}") + (let ((*unwind-exit* (cons label *unwind-exit*))) + (c2tagbody-body body)))) + +(defun c2tagbody-ccb (body &aux (label (next-label)) + (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*)) + (let ((*unwind-exit* (cons 'frame *unwind-exit*)) + (ref-clb (vs-push)) ref-ccb) + (wt-nl) (wt-vs ref-clb) (wt "=alloc_frame_id();") + (wt-nl) (wt-vs ref-clb) (wt "=MMcons(") (wt-vs ref-clb) (wt ",") + (wt-clink) (wt ");") + (clink ref-clb) + (setq ref-ccb (ccb-vs-push)) + (wt-nl "frs_push(FRS_CATCH,") (wt-vs* ref-clb) (wt ");") + (wt-nl "if(nlj_active){") + (wt-nl "nlj_active=FALSE;") + ;;; Allocate labels. + (dolist** (tag body) + (when (typep tag 'tag) + (setf (tag-label tag) (next-label*)) + (setf (tag-unwind-exit tag) label) + (when (or (tag-ref-clb tag) (tag-ref-ccb tag)) + (setf (tag-ref-clb tag) ref-clb) + (when (tag-ref-ccb tag) (setf (tag-ref-ccb tag) ref-ccb)) + (wt-nl "if(eql(nlj_tag," (vv-str (tag-var tag)) ")) {") + (wt-nl " ") + (reset-top) + (wt-nl " ") + (wt-go (tag-label tag)) + (wt-nl "}")))) + (wt-nl "FEerror(\"The GO tag ~s is not established.\",1,nlj_tag);") + (wt-nl "}") + (let ((*unwind-exit* (cons label *unwind-exit*))) + (c2tagbody-body body)))) + +(defun c1go (args) + (cond ((endp args) (too-few-args 'go 1 0)) + ((not (endp (cdr args))) (too-many-args 'go 1 (length args))) + ((not (or (symbolp (car args)) (integerp (car args)))) + "The tag name ~s is not a symbol nor an integer." (car args))) + (do ((tags *tags* (cdr tags)) + (name (car args)) + (ccb nil) (clb nil)) + ((endp tags) (cmperr "The tag ~s is undefined." name)) + (declare (object name ccb clb)) + (case (car tags) + (cb (setq ccb t)) + (lb (setq clb t)) + (t (when (eq (tag-name (car tags)) name) + (let ((tag (car tags))) + (cond (ccb (setf (tag-ref-ccb tag) t)) + (clb (setf (tag-ref-clb tag) t)) + (t (setf (tag-ref tag) t))) + (return (list 'go *info* clb ccb tag)))))))) + +(defun c2go (clb ccb tag) + (cond (ccb (c2go-ccb tag)) + (clb (c2go-clb tag)) + (t (c2go-local tag)))) + +(defun c2go-local (tag) + (unwind-no-exit (tag-unwind-exit tag)) + (wt-nl) (wt-go (tag-label tag))) + +(defun c2go-clb (tag) + (wt-nl "vs_base=vs_top;") + (wt-nl "unwind(frs_sch(") + (if (tag-ref-ccb tag) + (wt-vs* (tag-ref-clb tag)) + (wt-vs (tag-ref-clb tag))) + (wt ")," (vv-str (tag-var tag)) ");")) + +(defun c2go-ccb (tag) + (wt-nl "{frame_ptr fr;") + (wt-nl "fr=frs_sch(") (wt-ccb-vs (tag-ref-ccb tag)) (wt ");") + (wt-nl "if(fr==NULL)FEerror(\"The GO tag ~s is missing.\",1," (vv-str (tag-var tag)) ");") + (wt-nl "vs_base=vs_top;") + (wt-nl "unwind(fr," (vv-str (tag-var tag)) ");}")) + + +(defun wt-switch-case (x) + (cond (x (wt-nl (if (typep x 'fixnum) "case " "") x ":")))) + +(defun c1switch(form &aux (*tags* *tags*)) + (let* ((switch-op (car form)) + (body (cdr form)) + (switch-op-1 (c1expr switch-op))) + (cond ((and (typep (second switch-op-1 ) 'info) + (subtypep (info-type (second switch-op-1)) 'fixnum)) + ;;optimize into a C switch: + ;;If we ever get GCC to do switch's with an enum arg, + ;;which don't do bounds checking, then we will + ;;need to carry over the restricted range. + ;;more generally the compiler should carry along the original type + ;;decl, not just the coerced one. This needs another slot in + ;;info. + (or (member t body) (setq body (append body (list t)))) + ;; Remove duplicate tags in C switch statement -- CM 20031112 + (setq body + (let (tags new-body) + (dolist (b body) + (cond ((or (symbolp b) (integerp b)) + (unless (member b tags) + (push b tags) + (push b new-body))) + (t + (push b new-body)))) + (nreverse new-body))) + (setq body + (mapcar + #'(lambda (x) + (cond ((or (symbolp x) (integerp x)) + (let ((tag (make-tag :name x :ref + nil + :ref-ccb nil + :ref-clb nil))) + (cond((typep x 'fixnum) + (setf (tag-ref tag) t) + (setf (tag-switch tag) x)) + ((eq t x) + (setf (tag-ref tag) t) + (setf (tag-switch tag) "default"))) + tag)) + (t x))) + body)) + (let ((tem (c1tagbody + `(,@ body + switch-finish-label)))) + (nconc (list 'switch (cadr tem) switch-op-1) + (cddr tem)) + )) + (t (c1expr (cmp-macroexpand-1 (cons 'switch form))))))) + +(defun c2switch (op ref-clb ref-ccb body &aux (*inline-blocks* 0)(*vs* *vs*)) + (let ((args (inline-args (list op ) '(fixnum )))) + (wt-inline-loc "switch(#0){" args) + (cond (ref-ccb (c2tagbody-ccb body)) + (ref-clb (c2tagbody-clb body)) + (t (c2tagbody-local body))) + (wt "}") + (unwind-exit nil) + (close-inline-blocks))) + + + +;; SWITCH construct for Common Lisp. (TEST &body BODY) (in package SI) + +;; TEST must evaluate to something of INTEGER TYPE. If test matches one +;; of the labels (ie integers) in the body of switch, control will jump +;; to that point. It is an error to have two or more constants which are +;; eql in the the same switch. If none of the constants match the value, +;; then control moves to a label T. If there is no label T, control +;; flows as if the last term in the switch were a T. It is an error +;; however if TEST were declared to be in a given integer range, and at +;; runtime a value outside that range were provided. The value of a +;; switch construct is undefined. If you wish to return a value use a +;; block construct outside the switch and a return-from. `GO' may also +;; be used to jump to labels in the SWITCH. + +;; Control falls through from case to case, just as if the cases were +;; labels in a tagbody. To jump to the end of the switch, use +;; (switch-finish). + +;; The reason for using a new construct rather than building on CASE, is +;; that CASE does not allow the user to use invoke a `GO' if necessary. +;; to switch from one case to another. Also CASE does not allow sharing +;; of parts of code between different cases. They have to be either the +;; same or disjoint. + +;; The SWITCH may be implemented very efficiently using a jump table, if +;; the range of cases is not too much larger than the number of cases. +;; If the range is much larger than the number of cases, a binary +;; splitting of cases might be used. + +;; Sample usage: +;; (defun goo (x) +;; (switch x +;; 1 (princ "x is one, ") +;; 2 (princ "x is one or two, ") +;; (switch-finish) +;; 3 (princ "x is three, ") +;; (switch-finish) +;; t (princ "none"))) + +;; We provide a Common Lisp macro for implementing the above construct: + + +(defmacro switch (test &body body &aux cases) + (dolist (v body) + (cond ((integerp v) (push `(if (eql ,v ,test) (go ,v) nil) cases)))) + `(tagbody + ,@ (nreverse cases) + (go t) + ,@ body + ,@ (if (member t body) nil '(t)) + switch-finish-label )) + +(defmacro switch-finish nil '(go switch-finish-label)) + + +(si::putprop 'switch 'c1switch 'c1special) +(si::putprop 'switch 'c2switch 'c2) diff --git a/cmpnew/gcl_cmptest.lsp b/cmpnew/gcl_cmptest.lsp new file mode 100755 index 0000000..cef5c78 --- /dev/null +++ b/cmpnew/gcl_cmptest.lsp @@ -0,0 +1,267 @@ +;;; CMPTEST Functions for compiler test. +;;; +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +(in-package 'compiler) + +(defun self-compile () + (with-open-file (log "lsplog" :direction :output) + (let ((*standard-output* (make-broadcast-stream *standard-output* log))) + +; (self-compile2 "cmpbind") +; (self-compile2 "cmpblock") +; (self-compile2 "cmpcall") +; (self-compile2 "cmpcatch") + (self-compile2 "cmpenv") +; (self-compile2 "cmpeval") +; (self-compile2 "cmpflet") +; (self-compile2 "cmpfun") +; (self-compile2 "cmpif") +; (self-compile2 "cmpinline") + (self-compile2 "cmplabel") +; (self-compile2 "cmplam") +; (self-compile2 "cmplet") +; (self-compile2 "cmploc") +; (self-compile2 "cmpmap") +; (self-compile2 "cmpmulti") +; (self-compile2 "cmpspecial") +; (self-compile2 "cmptag") +; (self-compile2 "cmptop") +; (self-compile2 "cmptype") + (self-compile2 "cmputil") +; (self-compile2 "cmpvar") +; (self-compile2 "cmpvs") +; (self-compile2 "cmpwt") + + )) + t) + +(defun setup () + +; (allocate 'cons 800) +; (allocate 'string 256) +; (allocate 'structure 32) +; (allocate-relocatable-pages 128) + +; (load ":udd:common:cmpnew:cmpinline.lsp") + (load ":udd:common:cmpnew:cmputil.lsp") +; (load ":udd:common:cmpnew:cmptype.lsp") + +; (load ":udd:common:cmpnew:cmpbind.lsp") +; (load ":udd:common:cmpnew:cmpblock.lsp") + (load ":udd:common:cmpnew:cmpcall.lsp") +; (load ":udd:common:cmpnew:cmpcatch.lsp") +; (load ":udd:common:cmpnew:cmpenv.lsp") +; (load ":udd:common:cmpnew:cmpeval.lsp") + (load ":udd:common:cmpnew:cmpflet.lsp") +; (load ":udd:common:cmpnew:cmpfun.lsp") +; (load ":udd:common:cmpnew:cmpif.lsp") + (load ":udd:common:cmpnew:cmplabel.lsp") +; (load ":udd:common:cmpnew:cmplam.lsp") +; (load ":udd:common:cmpnew:cmplet.lsp") + (load ":udd:common:cmpnew:cmploc.lsp") +; (load ":udd:common:cmpnew:cmpmain.lsp") +; (load ":udd:common:cmpnew:cmpmap.lsp") +; (load ":udd:common:cmpnew:cmpmulti.lsp") +; (load ":udd:common:cmpnew:cmpspecial.lsp") +; (load ":udd:common:cmpnew:cmptag.lsp") + (load ":udd:common:cmpnew:cmptop.lsp") +; (load ":udd:common:cmpnew:cmpvar.lsp") +; (load ":udd:common:cmpnew:cmpvs.lsp") +; (load ":udd:common:cmpnew:cmpwt.lsp") + +; (load ":udd:common:cmpnew:lfun_list") +; (load ":udd:common:cmpnew:cmpopt.lsp") + + ) + +(defun cli () (process ":cli.pr")) + +(defun load-fasl () + + (load "cmpinline") + (load "cmputil") + (load "cmpbind") + (load "cmpblock") + (load "cmpcall") + (load "cmpcatch") + (load "cmpenv") + (load "cmpeval") + (load "cmpflet") + (load "cmpfun") + (load "cmpif") + (load "cmplabel") + (load "cmplam") + (load "cmplet") + (load "cmploc") + (load "cmpmap") + (load "cmpmulti") + (load "cmpspecial") + (load "cmptag") + (load "cmptop") + (load "cmptype") + (load "cmpvar") + (load "cmpvs") + (load "cmpwt") + + (load "cmpmain.lsp") + (load "lfun_list.lsp") + (load "cmpopt.lsp") + + ) + +(setq *macroexpand-hook* 'funcall) + +(defun self-compile1 (file) + (prin1 file) (terpri) + (compile-file1 file + :fasl-file t :c-file t :h-file t :data-file t :ob-file t :system-p t)) + +(defun self-compile2 (file) + (prin1 file) (terpri) + (compile-file1 file + :fasl-file t :c-file t :h-file t :data-file t :ob-file t :system-p t) + (prin1 (load file)) (terpri)) + +(defvar *previous-form* nil) + +(defun cmp (form) + (setq *previous-form* form) + (again)) + +(defun again () + (init-env) + (print *previous-form*) + (terpri) + (setq *compiler-output1* *standard-output*) + (setq *compiler-output2* *standard-output*) + (setq *compiler-output-data* *standard-output*) + (let ((prev (get-dispatch-macro-character #\# #\,))) + (set-dispatch-macro-character #\# #\, + 'si:sharp-comma-reader-for-compiler) + (unwind-protect + (t1expr *previous-form*) + (set-dispatch-macro-character #\# #\, prev))) + (catch *cmperr-tag* (ctop-write "test")) + t) + +;(defun make-cmpmain-for-unix () +; (print "unixmain") +; (format t "~&The old value of *FEATURES* is ~s." *features*) +; (let ((*features* '(unix common kcl))) +; (format t "~&The new value of *FEATURES* is ~s." *features*) +; (init-env) +; (compile-file1 "cmpmain.lsp" +; :output-file "unixmain" +; :c-file t +; :h-file t +; :data-file t +; :system-p t +; )) +; (format t "~&The resumed value of *FEATURES* is ~s." *features*) +; ) + +(defun compiler-make-ufun () + (make-ufun '( + "cmpbind.lsp" + "cmpblock.lsp" + "cmpcall.lsp" + "cmpcatch.lsp" + "cmpenv.lsp" + "cmpeval.lsp" + "cmpflet.lsp" + "cmpfun.lsp" + "cmpif.lsp" + "cmpinline.lsp" + "cmplabel.lsp" + "cmplam.lsp" + "cmplet.lsp" + "cmploc.lsp" + "cmpmain.lsp" + "cmpmap.lsp" + "cmpmulti.lsp" + "cmpspecial.lsp" + "cmptag.lsp" + "cmptop.lsp" + "cmptype.lsp" + "cmputil.lsp" + "cmpvar.lsp" + "cmpvs.lsp" + "cmpwt.lsp" + + )) + + t) + +(defun remrem () + (do-symbols (x (find-package 'lisp)) + (remprop x 'inline-always) + (remprop x 'inline-safe) + (remprop x 'inline-unsafe)) + (do-symbols (x (find-package 'system)) + (remprop x 'inline-always) + (remprop x 'inline-safe) + (remprop x 'inline-unsafe))) +(defun ckck () + (do-symbols (x (find-package 'lisp)) + (when (or (get x 'inline-always) + (get x 'inline-safe) + (get x 'inline-unsafe)) + (print x))) + (do-symbols (x (find-package 'si)) + (when (or (get x 'inline-always) + (get x 'inline-safe) + (get x 'inline-unsafe)) + (print x)))) + +(defun make-cmpopt (&aux (eof (cons nil nil))) + (with-open-file (in "cmpopt.db") + (with-open-file (out "cmpopt.lsp" :direction :output) + (print '(in-package 'compiler) out) + (terpri out) (terpri out) + (do ((x (read in nil eof) (read in nil eof))) + ((eq x eof)) + (apply #'(lambda (property return-type side-effectp new-object-p + name arg-types body) + (when (stringp body) + (do ((i 0 (1+ i)) + (l nil) + (l1 nil)) + ((>= i (length body)) + (when l1 + (setq body + (concatenate 'string + "@" + (reverse l1) + ";" + body)))) + (when (char= (aref body i) #\#) + (incf i) + (cond ((member (aref body i) l) + (pushnew (aref body i) l1)) + (t (push (aref body i) l)))))) + (print + `(push '(,arg-types ,return-type ,side-effectp + ,new-object-p ,body) + (get ',name ',property)) + out)) + (cdr x))) + (terpri out)))) + diff --git a/cmpnew/gcl_cmptop.lsp b/cmpnew/gcl_cmptop.lsp new file mode 100755 index 0000000..6341117 --- /dev/null +++ b/cmpnew/gcl_cmptop.lsp @@ -0,0 +1,1822 @@ +;;; CMPTOP Compiler top-level. +;;; +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +(in-package 'compiler) + +(defvar *objects* (make-hash-table :test 'eq)) +;(defvar *objects* nil) +(defvar *constants* nil) +(defvar *sharp-commas* nil) +(defvar *function-links* nil) +(defvar *c-gc* t) ;if we gc the c stack. +(defvar *c-vars*) ;list of *c-vars* to put at beginning of function. +;;number of address registers available not counting the +;;frame pointer and the stack pointer +;;If sup and base are used, then their are even 2 less +;;To do: If the regs hold data then there are really more available; +(defvar *free-address-registers* 5) +(defvar *free-data-registers* 6) +;;Inside t3defun this collects the list of downward closures defined. +(defvar *downward-closures* nil) + +(defvar *volatile*) +(defvar *setjmps* 0) + +;; Functions may use a block of C stack space. +;; (cs . i) will become Vcs[i]. + +(defvar *cs* 0) + +;; Holds list of local-functions resulting from c1function of +;; a lambda. Is used to eliminate mix of downward and regular closures. +(defvar *local-functions* nil) + + + +;;; *objects* holds ( { object vv-index }* ). +;;; *constants* holds ( { symbol vv-index }* ). +;;; *sharp-commas* holds ( vv-index* ), indicating that the value +;;; of each vv should be turned into an object from a string before +;;; defining the current function during loading process, so that +;;; sharp-comma-macros may be evaluated correctly. +;;; *function-links* ( {symbol vv-index} ) for function symbols needing link + +(defvar *global-funs* nil) + +;;; *global-funs* holds +;;; ( { global-fun-name cfun }* ) + +(defvar *closures* nil) +(defvar *local-funs* nil) + +;;; *closure* holds fun-objects for closures. + + + +(defvar *top-level-forms* nil) +(defvar *non-package-operation* nil) + +;;; *top-level-forms* 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' cfun expr) +;;; | ( 'DECLARE' var-name-vv ) +;;; | ( 'DEFVAR' var-name-vv expr doc-vv) +;;; | ( 'CLINES' string ) +;;; | ( 'DEFCFUN' header vs-size body) +;;; | ( 'DEFENTRY' fun-name cfun cvspecs type cfun-name ) +;;; | ( 'SHARP-COMMA' vv ) + +(defvar *reservations* nil) +(defvar *reservation-cmacro* nil) + +;;; *reservations* holds (... ( cmacro . value ) ...). +;;; *reservation-cmacro* holds the cmacro current used as vs reservation. + +(defvar *global-entries* nil) + +;;; *global-entries* holds (... ( fname cfun return-types arg-type ) ...). + +;;; Package operations. + +(si:putprop 'make-package t 'package-operation) +(si:putprop 'in-package t 'package-operation) +(si:putprop 'shadow t 'package-operation) +(si:putprop 'shadowing-import t 'package-operation) +(si:putprop 'export t 'package-operation) +(si:putprop 'unexport t 'package-operation) +(si:putprop 'use-package t 'package-operation) +(si:putprop 'unuse-package t 'package-operation) +(si:putprop 'import t 'package-operation) +(si:putprop 'provide t 'package-operation) +(si:putprop 'require t 'package-operation) +(si:putprop 'defpackage:defpackage t 'package-operation) + +;;; Pass 1 top-levels. + +(si:putprop 'eval-when 't1eval-when 't1) +(si:putprop 'progn 't1progn 't1) +(si:putprop 'macrolet 't1macrolet 't1) +(si:putprop 'defun 't1defun 't1) +(si:putprop 'defmacro 't1defmacro 't1) +(si:putprop 'clines 't1clines 't1) +(si:putprop 'defcfun 't1defcfun 't1) +(si:putprop 'defentry 't1defentry 't1) +(si:putprop 'defla 't1defla 't1) + +;;; Top-level macros. + +(si:putprop 'defconstant t 'top-level-macro) +(si:putprop 'defparameter t 'top-level-macro) +(si:putprop 'defstruct t 'top-level-macro) +(si:putprop 'deftype t 'top-level-macro) +(si:putprop 'defsetf t 'top-level-macro) + +;;; Pass 2 initializers. + +(si:putprop 'defun 't2defun 't2) +(si:putprop 'defmacro 't2defmacro 't2) +(si:putprop 'declare 't2declare 't2) +(si:putprop 'defentry 't2defentry 't2) +(si:putprop 'si:putprop 't2putprop 't2) + +;;; Pass 2 C function generators. + +(si:putprop 'defun 't3defun 't3) +(si:putprop 'defmacro 't3defmacro 't3) +(si:putprop 'ordinary 't3ordinary 't3) +(si:putprop 'sharp-comma 't3sharp-comma 't3) +(si:putprop 'clines 't3clines 't3) +(si:putprop 'defcfun 't3defcfun 't3) +(si:putprop 'defentry 't3defentry 't3) + + +(eval-when (compile eval) +(defmacro lambda-list (lambda-expr) `(caddr ,lambda-expr)) +(defmacro ll-requireds (lambda-list) `(car ,lambda-list)) +(defmacro ll-keywords (lambda-list) `(nth 4 ,lambda-list)) +(defmacro ll-optionals (lambda-list) `(nth 1 ,lambda-list)) +(defmacro ll-keywords-p (lambda-list) `(nth 3 ,lambda-list)) +(defmacro ll-rest (lambda-list) `(nth 2 ,lambda-list)) +(defmacro ll-allow-other-keys (lambda-list) `(nth 5 ,lambda-list)) +(defmacro vargd (min max) `(+ ,min (ash ,max 8))) +(defmacro let-pass3 (binds &body body &aux res) + (let ((usual '((*c-vars* nil) + (*vs* 0) (*max-vs* 0) (*level* 0) (*ccb-vs* 0) (*clink* nil) + (*unwind-exit* (list *exit*)) + (*value-to-go* *exit*) + (*reservation-cmacro* (next-cmacro)) + (*sup-used* nil) + (*restore-avma* nil) + (*base-used* nil) + (*cs* 0) + ))) + (dolist (v binds) + (or (assoc (car v) usual) + (push v usual))) + (do ((v (setq usual (copy-list usual)) (cdr v))) + ((null v)) + (let ((tem (assoc (caar v) binds))) + (if tem (setf (car v) tem)))) + `(let* ,usual ,@body))) +) + + +;; FIXME case does not optimize as well +(defun dash-to-underscore-int (str beg end) + (declare (string str) (fixnum beg end)) + (unless (< beg end) + (return-from dash-to-underscore-int str)) + (let ((ch (aref str beg))) + (declare (character ch)) + (setf (aref str beg) + (cond + ((eql ch #\-) #\_) + ((eql ch #\/) #\_) + ((eql ch #\.) #\_) + ((eql ch #\_) #\_) + ((eql ch #\!) #\E) + ((eql ch #\*) #\A) + (t (if (alphanumericp ch) ch #\$))))) + (dash-to-underscore-int str (1+ beg) end)) + +(defun dash-to-underscore (str) + (declare (string str)) + (let ((new (copy-seq str))) + (dash-to-underscore-int new 0 (length new)))) + +(defun init-name (p &optional sp (gp t) (dc t) (nt t)) + + (cond ((not sp) "code") + ((not (pathnamep p)) (init-name (pathname p) sp gp dc nt)) + (gp (init-name (truename (merge-pathnames p #".lsp")) sp nil dc nt)) + ((pathname-type p) + (init-name (make-pathname + :host (pathname-host p) + :device (pathname-device p) + :directory (pathname-directory p) + :name (pathname-name p) + :version (pathname-version p)) sp gp dc nt)) +; #-aosvs(dc (string-downcase (init-name p sp gp nil nt))) + ((and nt + (let* ((pn (pathname-name p)) + (pp (make-pathname :name pn))) + (and (not (equal pp p)) + (eql 4 (string<= "gcl_" pn)) + (init-name pp sp gp dc nil))))) + ((dash-to-underscore (namestring p))))) + +;; FIXME consider making this a macro +(defun c-function-name (prefix num fname) + #-gprof(declare (ignore fname)) + (si::string-concatenate + (string prefix) + (write-to-string num) + #+gprof(let ((fname (string fname))) + (si::string-concatenate + "__" + (dash-to-underscore fname) + "__" + (if (boundp '*compiler-input*) + (subseq (init-name *compiler-input* t) 4) + ""))))) + +(defun t1expr (form &aux (*current-form* form) (*first-error* t)) + (catch *cmperr-tag* + (when (consp form) + (let ((fun (car form)) (args (cdr form)) fd) + (declare (object fun args)) + (cond + ((symbolp fun) + (cond ((eq fun 'si:|#,|) + (cmperr "Sharp-comma-macro is in a bad place.")) + ((get fun 'package-operation) + (when *non-package-operation* + (cmpwarn "The package operation ~s was in a bad place." + form)) + (let ((res (if (setq fd (macro-function fun)) + (cmp-expand-macro fd fun (copy-list (cdr form))) + form))) + (maybe-eval t res) + (wt-data-package-operation res))) + ((setq fd (get fun 't1)) + (when *compile-print* (print-current-form)) + (funcall fd args)) + ((get fun 'top-level-macro) + (when *compile-print* (print-current-form)) + (t1expr (cmp-macroexpand-1 form))) + ((get fun 'c1) (t1ordinary form)) + ((setq fd (or (macro-function fun) (cadr (assoc fun *funs*)))) + (let ((res + (cmp-expand-macro fd fun (copy-list (cdr form))) + )) + (t1expr res))) + (t (t1ordinary form)) + )) + ((consp fun) (t1ordinary form)) + (t (cmperr "~s is illegal function." fun))) + ))) + ) + +(defun declaration-type (type) + (cond ((equal type "") "void") + ((equal type "long ") "object ") + (t type))) + +(defvar *vaddress-list*) ;; hold addresses of C functions, and other data +(defvar *vind*) ;; index in the VV array where the address is. +(defvar *Inits*) +(defun ctop-write (name &aux + def + (*function-links* nil) *c-vars* (*volatile* " VOL ") + *vaddress-list* (*vind* 0) *inits* + *current-form* *vcs-used*) + (declare (special *current-form* *vcs-used*)) + + (setq *top-level-forms* (nreverse *top-level-forms*)) + + ;;; Initialization function. + (wt-nl1 "void init_" name "(){" + #+sgi3d "Init_Links ();" + "do_init((void *)VV);" + "}") + + + ;; write all the inits. + (dolist* (*current-form* *top-level-forms*) + (setq *first-error* t) + (setq *vcs-used* nil) + (when (setq def (get (car *current-form*) 't2)) + (apply def (cdr *current-form*)))) + + + ;;; C function definitions. + (dolist* (*current-form* *top-level-forms*) + (setq *first-error* t) + (setq *vcs-used* nil) + (when (setq def (get (car *current-form*) 't3)) + (apply def (cdr *current-form*)))) + + ;;; Local function and closure function definitions. + (let (lf) + (block local-fun-process + (loop + (when (endp *local-funs*) (return-from local-fun-process)) + (setq lf (car *local-funs*)) + (pop *local-funs*) + (setq *vcs-used* nil) + (apply 't3local-fun lf)))) + + ;;; Global entries for directly called functions. + + (dolist* (x *global-entries*) + (setq *vcs-used* nil) + (apply 'wt-global-entry x)) + + ;;; Fastlinks + (dolist* (x *function-links*) + (setq *vcs-used* nil) + (wt-function-link x)) + #+sgi3d + (progn + (wt-nl1 "" "static void Init_Links () {") + (dolist* (x *function-links*) + (let ((num (second x))) + (wt-nl "Lnk" num " = LnkT" num ";"))) + (wt-nl1 "}")) + + ;;; Declarations in h-file. + (dolist* (fun *closures*) (wt-h "static void " (c-function-name "LC" (fun-cfun fun) (fun-name fun)) "();")) + (dolist* (x *reservations*) + (wt-h "#define VM" (car x) " " (cdr x))) + + ;;*next-vv* is the index of the last entry pushed onto the data vector + ;;*vind* is the index of the next constant to be pushed. + ;;make sure enough room in VV to handle *vind* + + ;;reserve a spot for the Cdata which will be swapped for the (si::%init..): + (push-data-incf nil) + + ;Ensure there is enough room to write t + (dotimes (i (- *vind* *next-vv* +1)) + (push-data-incf nil)) + ;; now *next-vv* >= *vind* + + ;; reserve space for the Cdata the cfdata object as the + ;; last entry in the VV vector. + + + (wt-h "static void * VVi[" (+ 1 *next-vv*) "]={") + (wt-h "#define Cdata VV[" *next-vv* "]") + (or *vaddress-list* (wt-h 0)) + (do ((v (nreverse *Vaddress-List*) (cdr v))) + ((null v) (wt-h "};")) + (wt-h "(void *)(" (caar v) (if (cdr v) ")," ")"))) + + (wt-h "#define VV (VVi)") + + + (wt-data-file) + +; (break "f") + (dolist (x *function-links* ) + (let ((num (second x)) + (type (third x)) + (args (fourth x)) + (newtype nil)) + (cond ((eq type 'proclaimed-closure) + (wt-h "static object Lclptr"num";") + (setq newtype "")) + (t + (setq newtype (if type (Rep-type type) "")))) + + (if (and (not (null type)) + (not (eq type 'proclaimed-closure)) + (or args (not (eq t type)))) + (progn + (wt-h "static " (declaration-type newtype) " LnkT" num "(object,...);") + #-sgi3d (wt-h "static " (declaration-type newtype) " (*Lnk" num ")() = (" + (declaration-type newtype) "(*)()) LnkT" num ";") + #+sgi3d (wt-h "static " (declaration-type newtype) " (*Lnk" num ")();")) + (progn + (wt-h "static " (declaration-type newtype) " LnkT" num "();") + #-sgi3d (wt-h "static " (declaration-type newtype) " (*Lnk" num ")() = LnkT" num ";") + #+sgi3d (wt-h "static " (declaration-type newtype) " (*Lnk" num ")();")))))) + + +;; this default will be as close to the the decision of the x3j13 committee +;; as I can make it. Valid values of *eval-when-defaults* are +;; a sublist of '(compile eval load) + +(defvar *eval-when-defaults* :defaults) + +(defun maybe-eval (default-action form) + (or default-action (and (symbolp (car form)) + (setq default-action (get (car form) 'eval-at-compile)))) + (cond ((or (and default-action (eq :defaults *eval-when-defaults*)) + (and (consp *eval-when-defaults*)(member 'compile *eval-when-defaults* ))) + (if form (cmp-eval form)) + t))) + + +(defun t1eval-when (args &aux load-flag compile-flag) + (when (endp args) (too-few-args 'eval-when 1 0)) + (dolist** (situation (car args)) + (case situation + ((load :load-toplevel) (setq load-flag t)) + ((compile :compile-toplevel) (setq compile-flag t)) + ((eval :execute)) + (otherwise (cmperr "The EVAL-WHEN situation ~s is illegal." + situation)))) + (let ((*eval-when-defaults* (car args))) + (cond (load-flag + (t1progn (cdr args))) + (compile-flag + (cmp-eval (cons 'progn (cdr args))))))) + +(defun t1macrolet(args &aux (*funs* *funs*)) + (dolist (def (car args)) + (push (list (car def) + (caddr (si:defmacro* (car def) (cadr def) (cddr def)))) + *funs*)) + (dolist (form (cdr args)) + (t1expr form))) + +(defvar *compile-ordinaries* nil) + +(defun t1progn (args) + (cond ((equal (car args) ''compile) + (let ((*compile-ordinaries* t)) + (t1progn (cdr args)))) + (t + (dolist** (form args) (t1expr form))))) + +;; (defun foo (x) .. -> (defun foo (g102 &aux (x g102)) ... +(defun cmpfix-args (args bind &aux tem (lam (copy-list (second args)))) + (dolist (v bind) + (setq tem (member (car v) lam)) + (and tem + (setf (car tem) (second v)))) + (cond ((setq tem (member '&aux lam)) + (setf (cdr tem) (append bind (cdr tem)))) + (t (setf lam (append lam (cons '&aux bind))))) + (list* (car args) lam (cddr args))) + + + +(defun t1defun (args &aux (setjmps *setjmps*) (defun 'defun) (*sharp-commas* nil)) + (when (or (endp args) (endp (cdr args))) + (too-few-args 'defun 2 (length args))) + (cmpck (not (symbolp (car args))) + "The function name ~s is not a symbol." (car args)) + (maybe-eval nil (cons 'defun args)) + (tagbody + top + (setq *non-package-operation* t) + (setq *local-functions* nil) + (let ((*vars* nil) (*funs* nil) (*blocks* nil) (*tags* nil) lambda-expr + (*special-binding* nil) + (cfun (or (get (car args) 'Ufun) (next-cfun))) + (doc nil) (fname (car args))) + (declare (object fname)) + (setq lambda-expr (c1lambda-expr (cdr args) fname)) + (or (eql setjmps *setjmps*) (setf (info-volatile (cadr lambda-expr)) t)) + (check-downward (cadr lambda-expr)) + +;;provide a simple way for the user to declare functions to +;;have fixed args without having to count them, and make mistakes. + (cond ((get fname 'fixed-args) + ;the number of regular args in definition + (let ((n (length (car (lambda-list lambda-expr))))) + (setf (get fname 'fixed-args) n);;for error checking. + (proclaim (list 'function fname + (make-list n :initial-element t) t))))) + + (cond + ((and + (get fname 'proclaimed-function) + ;; check the args: + (let ((lambda-list (lambda-list lambda-expr))bind) + (declare (object lambda-list)) + (and (null (cadr lambda-list)) ;;; no optional + (null (caddr lambda-list)) ;;; no rest + (null (cadddr lambda-list)) ;;; no keyword + (< (length (car lambda-list)) call-arguments-limit) + ;;; less than 10 requireds + ;;; For all required parameters... + (do ((vars (car lambda-list) (cdr vars)) + (types (get fname 'proclaimed-arg-types) (cdr types)) + (problem)) + ((endp vars) + (and (endp types) + (cond (bind (setq args (cmpfix-args args bind)) + (go top)) + (t (not problem))))) + (declare (object vars types)) + (let ((var (car vars))) + (declare (object var)) + (cond ((equal (car types) '*)(return nil))) + (unless + (and + (or (and (or (eq (var-kind var) 'LEXICAL) + (and (eq (var-kind var) + 'special) + (eq (car types) t))) + (not (var-ref-ccb var)) + (not (eq (var-loc var) 'clb))) + (progn (push (list + (var-name var) (gensym)) + bind) + t)) + (type-and (car types) (var-type var)) + (or (member (car types) + '(fixnum character + long-float short-float)) + (eq (var-loc var) 'object) + *c-gc* + (not (is-changed var (cadr lambda-expr))))) + (unless bind + (cmpwarn "Calls to ~a will be VERY SLOW. Recommend not to proclaim. ~%;;The arg caused the problem. ~a" + fname (var-name var))) + (setq problem t)))) + (numberp cfun)))) + ;;whew: it is acceptable. + (push (list fname + (get fname 'proclaimed-arg-types) + (get fname 'proclaimed-return-type) + (flags set ans) + (make-inline-string + cfun (get fname 'proclaimed-arg-types) fname)) + *inline-functions*)) + ((and ;(get fname 'proclaimed-function) + (eq (get fname 'proclaimed-return-type) t)) +; (setq me lambda-list) +; (setq me (lambda-list lambda-expr)) + +; (print args) + )) + ;; variable number of args; + + + + (when (cadddr lambda-expr) + (setq doc (cadddr lambda-expr))) + (add-load-time-sharp-comma) + (push (list defun fname cfun lambda-expr doc *special-binding*) + *top-level-forms*) + (push (cons fname cfun) *global-funs*) + + + ))) + +(defun make-inline-string (cfun args fname) + (if (null args) + (format nil "~d()" (c-function-name "LI" cfun fname)) + (let ((o (make-array 100 :element-type 'string-char :fill-pointer 0 + :adjustable t ))) + (format o "~d(" (c-function-name "LI" cfun fname)) + (do ((l args (cdr l)) + (n 0 (1+ n))) + ((endp (cdr l)) + (format o "#~d)" n)) + (declare (fixnum n)) + (format o "#~d," n)) + o))) + + + +(defun cs-push (&optional type) + (let ((tem (next-cvar))) + (push (if type (cons type tem) tem) *c-vars*) + tem)) +; For the moment only two types are recognized. +(defun f-type (x) + (if (var-p x) (setq x (var-type x))) + (cond ((and x (subtypep x 'fixnum)) + 1) + (t 0))) + + +(defun proclaimed-argd (args return) + (let ((ans (length args)) + (i 8) + (type (the fixnum (f-type return))) + (begin t)) + (declare (fixnum ans i)) + (loop + (if (not (eql 0 type)) + (setq ans (the fixnum (+ ans + (the fixnum (ash (the fixnum type) + (the (integer 0 30) + i))))))) + (when begin (setq i 10) (setq begin nil)) + (if (null args) (return ans)) + (setq i (the fixnum (+ i 2))) + (setq type (f-type (pop args)))))) + + +(defun wt-if-proclaimed (fname cfun lambda-expr) + (cond ((fast-link-proclaimed-type-p fname) + (cond ((unless (member '* (get fname 'proclaimed-arg-types)) (assoc fname *inline-functions*)) + (add-init `(si::mfsfun ',fname ,(add-address (c-function-name "LI" cfun fname)) + ,(proclaimed-argd (get fname 'proclaimed-arg-types) + (get fname 'proclaimed-return-type) + ) ) + ) + t) + (t + (let ((arg-c (length (car (lambda-list lambda-expr)))) + (arg-p (length (get fname 'proclaimed-arg-types))) + (va (member '* (get fname 'proclaimed-arg-types)))) + (cond (va + (or (>= arg-c) + (- arg-p (length va)) + (cmpwarn "~a needs ~a args. ~a supplied." + fname (- arg-p (length va)) + arg-c))) + + ((not (eql arg-c arg-p)) + (cmpwarn + "~%;; ~a Number of proclaimed args was ~a. ~ + ~%;;Its definition had ~a." fname arg-p arg-c)) + ;((>= arg-c 10.)) ;checked above + ;(cmpwarn " t1defun only likes 10 args ~ + ; ~%for proclaimed functions") + (t (cmpwarn + " ~a is proclaimed but not in *inline-functions* ~ + ~%T1defun could not assure suitability of args for C call" fname + )))) + nil))))) + + +(defun volatile (info) + (if (info-volatile info) "VOL " "")) + +(defun register (var) + (cond ((and (equal *volatile* "") + (>= (the fixnum (var-register var)) + (the fixnum *register-min*))) + "register ") + (t ""))) + +(defun vararg-p (x) + (and (equal (get x 'proclaimed-return-type) t) + (do ((v (get x 'proclaimed-arg-types) (cdr v))) + ((null v) t) + (or (consp v) (return nil)) + (or (eq (car v) t) + (eq (car v) '*) + (return nil))))) + + +(defun maxargs (lambda-list) +; any function can take &allow-other-keys in ANSI lisp + (cond ( +; (or (ll-allow-other-keys lambda-list)(ll-rest lambda-list)) + (or (ll-keywords-p lambda-list) (ll-rest lambda-list)) + 64) + (t (+ (length (car lambda-list)) ;reg + (length (ll-optionals lambda-list)) + (* 2 (length (ll-keywords lambda-list))))))) + + + + +(defun add-address (a) + ;; if need ampersand before function for address + ;; (setq a (string-concatenate "&" a)) + (push (list a) *vaddress-list*) + (prog1 *vind* (incf *vind*))) + +(defun t2defun (fname cfun lambda-expr doc sp) + (declare (ignore cfun lambda-expr doc sp)) + (cond ((get fname 'no-global-entry)(return-from t2defun nil))) + (cond ((< *space* 2) + (setf (get fname 'debug-prop) t) + ))) + +(defun si::add-debug (fname x) + (si::putprop fname x 'si::debug)) + +(defun t3init-fun (fname cfun lambda-expr doc) + + (when doc (add-init `(si::putprop ',fname ,doc 'si::function-documentation))) + + (cond ((wt-if-proclaimed fname cfun lambda-expr)) + ((vararg-p fname) + (let ((keyp (ll-keywords-p (lambda-list lambda-expr)))) +; (wt-h "static object LI" cfun "();") + (if keyp + (add-init `(si::mfvfun-key + ',fname ,(add-address (c-function-name "LI" cfun fname)) + ,(vargd (length (car (lambda-list lambda-expr))) + (maxargs (lambda-list lambda-expr))) + ,(add-address (format nil "&LI~akey" cfun))) + ) + (add-init `(si::mfvfun ',fname ,(add-address (c-function-name "LI" cfun fname)) + ,(vargd (length (car (lambda-list lambda-expr))) + (maxargs (lambda-list lambda-expr)))) + )))) + ((numberp cfun) + (wt-h "static void " (c-function-name "L" cfun fname) "();") + (add-init `(si::mf ',fname ,(add-address (c-function-name "L" cfun fname))))) + (t (wt-h cfun "();") + (add-init `(si::mf ',fname ,(add-address (c-function-name "" cfun fname))))))) + +(defun t3defun (fname cfun lambda-expr doc sp &aux inline-info + (*current-form* (list 'defun fname)) + (*volatile* (volatile (second lambda-expr))) + *downward-closures*) + (cond + ((dolist (v *inline-functions*) + (or (si::fixnump (nth 3 v)) + (error "Old style inline")) + (and (eq (car v) fname) + (not (nth 5 v)) ; ie.not 'link-call or 'ifuncall + (return (setq inline-info v)))) + + ;;; Add global entry information. + (when (not (fast-link-proclaimed-type-p fname)) + (push (list fname cfun (cadr inline-info) (caddr inline-info)) + *global-entries*)) + + ;;; Local entry + (analyze-regs (cadr lambda-expr) 0) + (t3defun-aux 't3defun-local-entry + (case (caddr inline-info) + (fixnum 'return-fixnum) + (character 'return-character) + (long-float 'return-long-float) + (short-float 'return-short-float) + (otherwise 'return-object)) + fname cfun lambda-expr sp inline-info + )) + ((vararg-p fname) + (analyze-regs (cadr lambda-expr) 0) + (t3defun-aux 't3defun-vararg 'return-object + fname cfun lambda-expr sp)) + (t + (analyze-regs (cadr lambda-expr) 2) + (t3defun-aux 't3defun-normal 'return fname cfun lambda-expr sp))) + + (wt-downward-closure-macro cfun) + + (t3init-fun fname cfun lambda-expr doc) + + (add-debug-info fname lambda-expr)) + +(defun t3defun-aux (f *exit* &rest lis) + (let-pass3 () (apply f lis))) + +(defun t3defun-local-entry (fname cfun lambda-expr sp inline-info + &aux specials + (requireds (caaddr lambda-expr))) + (do ((vl requireds (cdr vl)) + (types (cadr inline-info) (cdr types))) + ((endp vl)) + (declare (object vl types)) + (cond ((eq (var-kind (car vl)) 'special) + (push (cons (car vl) (var-loc (car vl))) specials)) + (t + (setf (var-kind (car vl)) + (case (car types) + (fixnum 'FIXNUM) + (character 'CHARACTER) + (long-float 'LONG-FLOAT) + (short-float 'SHORT-FLOAT) + (otherwise 'OBJECT)))) + ) + (setf (var-loc (car vl)) (next-cvar))) + (wt-comment "local entry for function " fname) + (wt-h "static " (declaration-type (rep-type (caddr inline-info))) (c-function-name "LI" cfun fname) "();") + (wt-nl1 "static " (declaration-type (rep-type (caddr inline-info))) (c-function-name "LI" cfun fname) "(") + (wt-requireds requireds + (cadr inline-info)) + ;;; Now the body. + (let ((cm *reservation-cmacro*) + (*tail-recursion-info* + (if *do-tail-recursion* (cons fname requireds) nil)) + (*unwind-exit* *unwind-exit*)) + (wt-nl1 "{ ") + (assign-down-vars (cadr lambda-expr) cfun + 't3defun) + (wt " VMB" cm " VMS" cm " VMV" cm) + + (when sp (wt-nl "bds_check;")) + (when *compiler-push-events* (wt-nl "ihs_check;")) + (when *tail-recursion-info* + (push 'tail-recursion-mark *unwind-exit*) + (wt-nl "goto TTL;") (wt-nl1 "TTL:;")) + (dolist + (v specials) + (wt-nl "bds_bind(" (vv-str (cdr v)) ",V" (var-loc (car v)) ");") + (push 'bds-bind *unwind-exit*) + (setf (var-kind (car v)) 'SPECIAL) + (setf (var-loc (car v)) (cdr v))) + (c2expr (caddr (cddr lambda-expr))) + +;;; Use base if defined for lint + (if (and (zerop *max-vs*) (not *sup-used*) (not *base-used*)) t (wt-nl "base[0]=base[0];")) + +;;; Make sure to return object if necessary + (if (equal "object " (rep-type (caddr inline-info))) (wt-nl "return Cnil;")) + + (wt-nl1 "}") + (wt-V*-macros cm (caddr inline-info)) + )) + + + +(defvar *vararg-use-vs* nil) +(defun set-up-var-cvs (var) + (cond (*vararg-use-vs* + (setf (var-ref var) (vs-push))) +; ((numberp (var-loc var))) + (t (setf (var-ref var) (cvs-push))))) + +(defun t3defun-vararg (fname cfun lambda-expr sp &aux reqs *vararg-use-vs* + block-p labels (deflt t) key-offset + (*inline-blocks* 0) rest-var + (ll (lambda-list lambda-expr)) + (is-var-arg (or (ll-rest ll) + (ll-optionals ll) + (ll-keywords-p ll))) + (first (unless (car ll) is-var-arg))) + (dolist (v (car ll)) + (push (list 'cvar (next-cvar)) reqs)) + + (wt-comment "local entry for function " fname) + + (let ((tmp "")) + (wt-nl1 "static object " (c-function-name "LI" cfun fname) "(") + (when reqs + (do ((v reqs (cdr v))) + ((null v)) + (wt "object " (car v)) + (setq tmp (concatenate 'string tmp "object")) + (or (null (cdr v)) + (progn + (wt ",") + (setq tmp (concatenate 'string tmp ",")))))) + (when is-var-arg + (when first (wt "object first") (setq tmp (concatenate 'string tmp "object"))) + (wt ",...") (setq tmp (concatenate 'string tmp ",..."))) + (wt ")") + (wt-h "static object " (c-function-name "LI" cfun fname) "(" tmp ");")) + + +; (when reqs (wt-nl "object ") +; (wt-list reqs) (wt ";")) +; (if is-var-arg (wt-nl "va_dcl ")) + ;;; Now the body. + + (let ((cm *reservation-cmacro*) + (*tail-recursion-info* + ;; to do: When can we do tail recursion? + ;; Should be able to do the optionals case, where the + ;; optional defaults are constants. But this + ;; is probably not worth it. + (and + *do-tail-recursion* + (not (ll-rest ll)) + (dolist* (var (ll-requireds ll) t) + (when (var-ref-ccb var) (return nil))) + (null (ll-optionals ll)) + (null (ll-keywords ll)) + (cons fname (car ll)))) + (*unwind-exit* *unwind-exit*)) + (wt-nl1 "{ ") + (when is-var-arg (wt-nl "va_list ap;")) + (wt-nl "int narg = VFUN_NARGS;") + + (assign-down-vars (cadr lambda-expr) cfun + 't3defun) + (wt " VMB" cm " VMS" cm " VMV" cm) + + (when sp (wt-nl "bds_check;")) + (when *compiler-push-events* (wt-nl "ihs_check;")) + (or is-var-arg (wt-nl "if ( narg!= " (length reqs) ") vfun_wrong_number_of_args(small_fixnum(" + (length reqs) + "));")) + + (flet ((do-decl (var) + (and (eql (var-loc var) 'clb) (setf *vararg-use-vs* t)) + (let ((kind (c2var-kind var))) + (declare (object kind)) + (when kind + (let ((cvar (next-cvar))) + (setf (var-kind var) kind) + (setf (var-loc var) cvar) + (wt-nl) + (unless block-p (wt "{") (setq block-p t)) + (wt-var-decl var) + ))))) + + (dolist** (var (car ll)) + (do-decl var)) + (dolist** (opt (ll-optionals ll)) + (do-decl (car opt)) + (when (caddr opt) (do-decl (caddr opt)))) + (when (ll-rest ll) (do-decl (ll-rest ll))) + (dolist** (kwd (ll-keywords ll)) + (do-decl (cadr kwd)) + (when (cadddr kwd) (do-decl (cadddr kwd)))) + ) + + ;;; Use Vcs for lint + ; (if *vararg-use-vs* t (progn (wt-nl "Vcs[0]=Vcs[0];"))) + + ;;; start va_list at beginning + (when is-var-arg + (wt-nl "va_start(ap," (if first "first" (car (last reqs))) ");")) + + ;;; Check arguments. + (when (and (or *safe-compile* *compiler-check-args*) (car ll)) + (wt-nl "if(narg <" (length (car ll)) + ") too_few_arguments();")) + + ;;; Allocate the parameters. + (dolist** (var (car ll)) (set-up-var-cvs var)) + (dolist** (opt (ll-optionals ll)) (set-up-var-cvs (car opt))) + + + (when (ll-rest ll) (set-up-var-cvs (ll-rest ll))) + + (setf key-offset (if *vararg-use-vs* *vs* *cs*)) + (dolist** (kwd (ll-keywords ll)) + (set-up-var-cvs (cadr kwd))) + (dolist** (kwd (ll-keywords ll)) + (set-up-var-cvs (cadddr kwd))) + + ;;bind the params: + (do ((v reqs (cdr v)) + (vl (car ll) (cdr vl))) + ((null v)) + (c2bind-loc (car vl) (car v))) + (when (ll-optionals ll) + (let ((*clink* *clink*) + (*unwind-exit* *unwind-exit*) + (*ccb-vs* *ccb-vs*)) + (wt-nl "narg = narg - " (length reqs) ";") + (dolist** (opt (ll-optionals ll)) + (push (next-label) labels) + (wt-nl "if (" (if (cdr labels) "--" "") "narg <= 0) ") + (wt-go (car labels)) + (wt-nl "else {" ) + (c2bind-loc (car opt) (if first (list 'first-var-arg) (list 'next-var-arg))) + (setq first nil) + (wt "}") + (when (caddr opt) (c2bind-loc (caddr opt) t)))) + (setq labels (nreverse labels)) + + (let ((label (next-label))) + (wt-nl "--narg; ") + (wt-go label) + + ;;; Bind unspecified optional parameters. + + (dolist** (opt (ll-optionals ll)) + (wt-label (car labels)) + (pop labels) + (c2bind-init (car opt) (cadr opt)) + (when (caddr opt) (c2bind-loc (caddr opt) nil))) + ; (if (or (ll-rest ll)(ll-keywords-p ll))(wt-nl "narg=0;")) + + (wt-label label) + )) + (if (ll-rest ll) + (progn + (setq rest-var (cs-push)) + (cond ((ll-optionals ll)) + (t (wt-nl "narg= narg - " (length (car ll)) ";"))) + (wt-nl "V" rest-var " = ") + + (let ((*rest-on-stack* + (or (eq (var-type (ll-rest ll)) :dynamic-extent) + *rest-on-stack*))) + (if (ll-keywords-p ll) + (cond (*rest-on-stack* + (wt "(ALLOCA_CONS(narg),ON_STACK_MAKE_LIST(narg));")) + (t (wt "make_list(narg);"))) + (cond (*rest-on-stack* + (wt "(ALLOCA_CONS(narg),ON_STACK_LIST_VECTOR_NEW(narg," (if first "first" "OBJNULL") ",ap));" + )) + (t (wt "list_vector_new(narg," (if first "first" "OBJNULL") ",ap);")))) + (c2bind-loc (ll-rest ll) (list 'cvar rest-var))))) + (when (ll-keywords-p ll) + (cond ((ll-rest ll)) + ((ll-optionals ll)) + (t (wt-nl "narg= narg - " (length (car ll)) ";"))) + + (setq deflt (mapcar 'caddr (ll-keywords ll))) + (let ((vkdefaults nil) + (n (length (ll-keywords ll)))) + (do* ((v deflt (cdr v)) + (kwds (ll-keywords ll) (cdr kwds)) + (kwd (car kwds) (car kwds))) + ((null v)) + (unless (and (eq (caar v) 'location) + (eq (third (car v)) nil)) + (setq vkdefaults t)) + (when (or (not (and (eq (caar v) 'location) + (let ((tem (third (car v)))) + (or (eq tem nil) + (and (consp tem) + (member (car tem) + '(vv fixnum-value)) + ))))) + ;; the supplied-p variable is not there + (not (eq (var-kind (cadddr kwd)) 'DUMMY))) + (setf Vkdefaults t) + (setf (car v) 0))) + (if (> (length deflt) 15) (setq vkdefaults t)) + + (wt-nl "{") + (inc-inline-blocks) + (let ((*compiler-output1* *compiler-output2*)) + (when vkdefaults + (terpri *compiler-output2*) + (wt "static object VK" cfun + "defaults[" (length deflt) "]={") + (do ((v deflt(cdr v))(tem)) + ((null v)) + (wt "(void *)") + (cond ((eql (car v) 0) + (wt "-1")) + ;; must be location + ((and (eq (setq tem (third (car v))) nil)) + (wt "-2")) + ((and (consp tem) (eq (car tem) 'vv)) + (wt (add-object2 (add-object (second tem))) )) + ((and (consp tem) (eq (car tem) 'fixnum-value)) +; (print (setq ttem tem)) (break) + (wt (add-object2 (add-object (third tem))) )) + (t (baboon))) + + (if (cdr v) (wt ","))) + (wt "};")) + (terpri *compiler-output2*) + (wt "static struct { short n,allow_other_keys;" + "object *defaults;") + (wt-nl " KEYTYPE keys[" (max n 1) "];") + (wt "} " "LI" cfun "key=") + + (wt "{" (length (ll-keywords ll)) "," + (if (ll-allow-other-keys ll) 1 0) + ",") + (if vkdefaults (wt "VK" cfun "defaults") + (wt "Cstd_key_defaults")) + (when (ll-keywords ll) + (wt ",{") + (do ((v (reverse (ll-keywords ll)) (cdr v))) + ((null v)) + ;; We write this list backwards for convenience + ;; in stepping through it in parse_key + (wt "(void *)") +; (print (setq ss v))(break "h") + (wt (add-object2 (add-symbol (caar v)))) + (if (cdr v) (wt ","))) + (wt "}")) + (wt "};") + ) + (cond ((ll-rest ll) + (wt-nl "parse_key_rest_new(" (list 'cvar rest-var) ",")) + (t (wt-nl "parse_key_new_new("))) + (if (eql 0 *cs*)(setq *cs* 1)) + (wt "narg," (if *vararg-use-vs* "base " (progn (setq *vcs-used* t) "Vcs ")) + "+" key-offset",(struct key *)(void *)&LI" cfun "key," (if first "first" "OBJNULL") ",ap);") + + )) + + + + ;; bind keywords + + (dolist** (kwd (ll-keywords ll)) + (cond ((not (eql 0 (pop deflt))) + ;; keyword default bound by parse_key.. and no supplied-p + (c2bind (cadr kwd))) + (t + (wt-nl "if(") (wt-vs (var-ref (cadr kwd))) (wt "==OBJNULL){") + (let ((*clink* *clink*) + (*unwind-exit* *unwind-exit*) + (*ccb-vs* *ccb-vs*)) + (c2bind-init (cadr kwd) (caddr kwd))) + (unless (eq (var-kind (cadddr kwd)) 'DUMMY) (c2bind-loc (cadddr kwd) nil)) + + (wt-nl "}else{") + (c2bind (cadr kwd)) + (unless (eq (var-kind (cadddr kwd)) 'DUMMY) (c2bind-loc (cadddr kwd) + t)) + + (wt "}"))) + + + + ) + + (when *tail-recursion-info* + (push 'tail-recursion-mark *unwind-exit*) + (wt-nl "goto TTL;") (wt-nl1 "TTL:;")) + (c2expr (caddr (cddr lambda-expr))) + + ;;; End va_list at function end + + (when is-var-arg (wt-nl "va_end(ap);")) + +;;; Use base if defined for lint + (if (and (zerop *max-vs*) (not *sup-used*) (not *base-used*)) t (wt-nl "base[0]=base[0];")) + +;;; Need to ensure return of type object + (wt-nl "return Cnil;") + + (wt "}") + (when block-p (wt-nl "}")) + (close-inline-blocks) + (wt-V*-macros cm (get fname 'proclaimed-return-type)) + )) + +(defun t3defun-normal (fname cfun lambda-expr sp) + (wt-comment "function definition for " fname) + (if (numberp cfun) + (wt-nl1 "static void " (c-function-name "L" cfun fname) "()") + (wt-nl1 cfun "()")) + (wt-nl1 "{" "register object *" *volatile*"base=vs_base;") + (assign-down-vars (cadr lambda-expr) cfun + 't3defun) + (wt-nl + "register object *" *volatile*"sup=base+VM" *reservation-cmacro* ";") + (wt " VC" *reservation-cmacro*) + (if *safe-compile* + (wt-nl "vs_reserve(VM" *reservation-cmacro* ");") + (wt-nl "vs_check;")) + (when sp (wt-nl "bds_check;")) + (when *compiler-push-events* (wt-nl "ihs_check;")) + (c2lambda-expr (lambda-list lambda-expr) (caddr (cddr lambda-expr)) fname) + (wt-nl1 "}") + (push (cons *reservation-cmacro* *max-vs*) *reservations*) + + (wt-h "#define VC" *reservation-cmacro*) + (wt-cvars) + + ) + + +;;Macros for conditionally writing vs_base ..preamble, and for setting +;;up the return. +(defun wt-V*-macros (cm return-type) + (declare (ignore return-type)) + (push (cons cm *max-vs*) *reservations*) + (if (and (zerop *max-vs*) (not *sup-used*) (not *base-used*)) + ;;note if (proclaim '(function foo () t)) + ;;(defun foo () (goo)) ;then *max-vs*=0,*sup-used*=t;--wfs + (wt-h "#define VMB" cm) + (wt-h "#define VMB" cm " " + "register object *" *volatile*"base=vs_top;")) + ;;tack following onto the VMB macro.. + (wt-cvars) + (if *sup-used* + (wt-h "#define VMS" cm + " " " register object *" *volatile*"sup=vs_top+" *max-vs* + ";vs_top=sup;") + (if (zerop *max-vs*) + (wt-h "#define VMS" cm) + (wt-h "#define VMS" cm " vs_top += " *max-vs* ";"))) + (if (zerop *max-vs*) + (wt-h "#define VMV" cm) + (if *safe-compile* + (wt-h "#define VMV" cm " vs_reserve(" *max-vs* ");") + (wt-h "#define VMV" cm " vs_check;"))) + (if (zerop *max-vs*) + (wt-h "#define VMR" cm "(VMT" cm ") return(VMT" cm ");") + (wt-h "#define VMR" cm "(VMT" cm ") vs_top=base ; return(VMT" cm ");")) + ) + +;;Write the required args as c arguments, and declarations for the arguments. +(defun wt-requireds (requireds arg-types) + (do ((vl requireds (cdr vl))) + ((endp vl)) + (declare (object vl)) + (let ((cvar (next-cvar))) + (setf (var-loc (car vl)) cvar) + (wt "V" cvar)) + (unless (endp (cdr vl)) (wt ","))) + (wt ") +") + (when requireds + (wt-nl1) + (do ((vl requireds (cdr vl)) + (types arg-types (cdr types)) + (prev-type nil)) + ((endp vl) (wt ";")) + (declare (object vl)) + + (if prev-type (wt ";")) + + (wt *volatile* (register (car vl)) + (rep-type (car types))) + (setq prev-type (car types)) + (wt "V" (var-loc (car vl)))))) + + +(defun add-debug-info (fname lambda-expr &aux locals) + (cond + ((>= *space* 2)) + ((null (get fname 'debug-prop)) + (warn "~a has a duplicate definition in this file" fname)) + (t + (remprop fname 'debug-prop) + (let ((leng 0)) + (do-referred (va (second lambda-expr)) + (when (and (consp (var-ref va)) + (si::fixnump (cdr (var-ref va)))) + (setq leng (max leng (cdr (var-ref va)))))) + (setq locals (make-list (1+ leng))) + (do-referred (va (second lambda-expr)) + (when (and (consp (var-ref va)) ;always fixnum ? + (si::fixnump (cdr (var-ref va)))) + (setf (nth (cdr (var-ref va)) locals) + (var-name va)))) + (setf (get fname 'si::debug) locals) + (let ((locals (get fname 'si::debug))) + (if (and locals (or (cdr locals) (not (null (car locals))))) + (add-init `(si::debug ',fname ',locals) ) + )) + )))) + + +;;Checks the register slots of variables, and finds which +;;variables should be in registers, zero'ing the register slot +;;in the remaining. Data and address variables are done separately. +(defun analyze-regs (info for-sup-base) + (let ((addr-regs (- *free-address-registers* for-sup-base))) + (cond ((zerop *free-data-registers*) + (analyze-regs1 info addr-regs)) + (t + (let ((addr (make-info)) + (data (make-info))) + (do-referred (v info) + (cond ((member (var-type v) '(FIXNUM CHARACTER SHORT-FLOAT LONG-FLOAT) :test #'eq) + (push-referred v data)) + (t + (push-referred v addr)))) + (analyze-regs1 addr addr-regs) + (analyze-regs1 data *free-data-registers*)))))) + +(defun analyze-regs1 (info want ) + (let ((tem 0)(real-min 3)(this-min 100000)(want want)(have 0)) + (declare (fixnum tem real-min this-min want have)) + (tagbody + START + (do-referred (v info) + (setq tem (var-register v)) + (cond ((>= tem real-min) + (setq have (the fixnum (+ have 1))) + (cond ((< tem this-min ) + (setq this-min tem))) + (cond ((> have want) (go NEXT))) + ))) + (cond ((< have want) (setq real-min (- real-min 1)))) + (do-referred (v info) + (cond ((< (the fixnum (var-register v)) + real-min) + (setf (var-register v) 0)))) + (return-from analyze-regs1 real-min) + NEXT + (setq have 0) + (setq real-min (the fixnum (+ this-min 1))) + (setq this-min 1000000) + (go START) +))) + + + +(defun wt-global-entry (fname cfun arg-types return-type) + (cond ((get fname 'no-global-entry)(return-from wt-global-entry nil))) + (wt-comment "global entry for the function " fname) + (wt-nl1 "static void " (c-function-name "L" cfun fname) "()") + (wt-nl1 "{ register object *base=vs_base;") + (when (or *safe-compile* *compiler-check-args*) + (wt-nl "check_arg(" (length arg-types) ");")) + (wt-nl "base[0]=" (case return-type + (fixnum (if (zerop *space*) + "CMPmake_fixnum" + "make_fixnum")) + (character "code_char") + (long-float "make_longfloat") + (short-float "make_shortfloat") + (otherwise "")) + "(" (c-function-name "LI" cfun fname) "(") + (do ((types arg-types (cdr types)) + (n 0 (1+ n))) + ((endp types)) + (declare (object types) (fixnum n)) + (wt (case (car types) + (fixnum "fix") + (character "char_code") + (long-float "lf") + (short-float "sf") + (otherwise "")) + "(base[" n "])") + (unless (endp (cdr types)) (wt ","))) + (wt "));") + (wt-nl "vs_top=(vs_base=base)+1;") + (wt-nl1 "}") + ) + +(defun rep-type (type) + (case type + (fixnum "long ") + (integer "MP_INT * ") + (character "unsigned char ") + (short-float "float ") + (long-float "double ") + (otherwise "object "))) + + +(defun t1defmacro (args) + (when (or (endp args) (endp (cdr args))) + (too-few-args 'defmacro 2 (length args))) + (cmpck (not (symbolp (car args))) + "The macro name ~s is not a symbol." (car args)) + (maybe-eval t (cons 'defmacro args)) + (setq *non-package-operation* t) + (let ((*vars* nil) (*funs* nil) (*blocks* nil) (*tags* nil) + (*sharp-commas* nil) (*special-binding* nil) + macro-lambda (cfun (next-cfun))) + (setq macro-lambda (c1dm (car args) (cadr args) (cddr args))) + (add-load-time-sharp-comma) + (push (list 'defmacro (car args) cfun (cddr macro-lambda) + (car macro-lambda) ;doc + (cadr macro-lambda) ; ppn + *special-binding*) + *top-level-forms*)) + ) + + +(defun t2defmacro (fname cfun macro-lambda doc ppn sp) + + (declare (ignore macro-lambda doc ppn sp)) + (wt-h "static void " (c-function-name "L" cfun fname) "();") + ) + +(defun t3defmacro (fname cfun macro-lambda doc ppn sp + &aux (*volatile* (if (get fname 'contains-setjmp) + " VOL " ""))) + (let-pass3 + ((*exit* 'return)) + (wt-comment "macro definition for " fname) + (wt-nl1 "static void " (c-function-name "L" cfun fname) "()") + (wt-nl1 "{register object *" *volatile* "base=vs_base;") + (assign-down-vars (nth 4 macro-lambda) cfun ;*dm-info* + 't3defun) + (wt-nl "register object *"*volatile* "sup=base+VM" *reservation-cmacro* ";") + (wt " VC" *reservation-cmacro*) + (if *safe-compile* + (wt-nl "vs_reserve(VM" *reservation-cmacro* ");") + (wt-nl "vs_check;")) + (when sp (wt-nl "bds_check;")) + (when *compiler-push-events* (wt-nl "ihs_check;")) + (c2dm (car macro-lambda) (cadr macro-lambda) (caddr macro-lambda) + (cadddr macro-lambda)) + (wt-nl1 "}") + (push (cons *reservation-cmacro* *max-vs*) *reservations*) + (wt-h "#define VC" *reservation-cmacro*) + (wt-cvars) + + (when doc (add-init `(si::putprop ',fname ,doc 'si::function-documentation) )) + (when ppn + (add-init `(si::putprop ',fname ',ppn 'si::pretty-print-format) )) + (add-init `(si::MM ',fname ,(add-address (c-function-name "L" cfun fname))) ) + + )) + +(defun t1ordinary (form &aux tem ) + (setq *non-package-operation* t) + ;; check for top level functions + (cond ((or *compile-ordinaries* (when (listp form) (member (car form) '(let let* flet labels)))) + (maybe-eval nil form) + (let ((gen (gensym "progn 'compile"))) + (proclaim `(function ,gen nil t)) + (t1expr `(defun ,gen (), form nil)) + (push (list 'ordinary `(,gen) ) *top-level-forms*))) + ;;Hack to things like (setq bil #'(lambda () ...)) or (foo nil #'(lambda () ..)) + ;; but not (let ((x ..)) (setq bil #'(lambda () ..))) + ;; for the latter you must use (progn 'compile ...) + ((and (consp form) + (symbolp (car form)) + (or (eq (car form) 'setq) + (not (special-form-p (car form)))) + (do ((v (cdr form) (and (consp v) (cdr v))) + (i 1 (the fixnum (+ 1 i)))) + ((or (>= i 1000) + (not (consp v))) nil) + (declare (fixnum i)) + (cond ((and (consp (car v)) + (eq (caar v) 'function) + (consp (setq tem (second (car v)))) + (eq (car tem) 'lambda)) + (let ((gen (gensym))) + (t1expr `(defun ,gen ,@ (cdr tem))) + (return-from t1ordinary + (t1ordinary (append + (subseq form 0 i) + `((symbol-function ', gen)) + (nthcdr (+ 1 i) form)))))))))) + (t + (maybe-eval nil form) + (let ((*vars* nil) (*funs* nil) (*blocks* nil) (*tags* nil) + (*sharp-commas* nil)) + (push (list 'ordinary form) *top-level-forms*) + nil + )))) + +(defun t3ordinary (form) + (cond ((atom form)) + ((constantp form)) + (t (add-init form )))) + +(defun add-load-time-sharp-comma () + (dolist* (vv (reverse *sharp-commas*)) + (cond ((atom vv) (wfs-error))) + (push (cons 'sharp-comma vv) *top-level-forms*))) + +(defun t3sharp-comma (vv val) + (add-init `(si::setvv ,vv ,val) )) + +(defun t2declare (vv) vv + (wfs-error)) + +;; Some top level functions which should be eval'd in the :default case +;; for eval-when +(setf (get 'si::*make-special 'eval-at-compile) t) +(setf (get 'si::*make-constant 'eval-at-compile) t) +(setf (get 'proclaim 'eval-at-compile) t) + + +(setf (get 'si::define-structure 't1) 't1define-structure) + +(defun t1define-structure (args) + (maybe-eval t `(si::define-structure ,@args ,(not (maybe-eval nil nil)))) + (t1ordinary (cons 'si::define-structure args))) + + +(si:putprop 'dbind 'set-dbind 'set-loc) + +(defun set-dbind (loc vv) + (wt-nl (vv-str vv) "->s.s_dbind = " loc ";")) + +(defun t1clines (args) + (dolist** (s args) + (cmpck (not (stringp s)) "The argument to CLINE, ~s, is not a string." s)) + (push (list 'clines args) *top-level-forms*)) + +(defun t3clines (ss) (dolist** (s ss) (wt-nl1 s))) + +(defun t1defcfun (args &aux (body nil)) + (when (or (endp args) (endp (cdr args))) + (too-few-args 'defcfun 2 (length args))) + (cmpck (not (stringp (car args))) + "The first argument to defCfun ~s is not a string." (car args)) + (cmpck (not (numberp (cadr args))) + "The second argument to defCfun ~s is not a number." (cadr args)) + (dolist** (s (cddr args)) + (cond ((stringp s) (push s body)) + ((consp s) + (cond ((symbolp (car s)) + (cmpck (special-form-p (car s)) + "Special form ~s is not allowed in defCfun." (car s)) + (push (list (cons (car s) (parse-cvspecs (cdr s)))) body)) + ((and (consp (car s)) (symbolp (caar s)) + (not (if (eq (caar s) 'quote) + (or (endp (cdar s)) + (not (endp (cddar s))) + (endp (cdr s)) + (not (endp (cddr s)))) + (special-form-p (caar s))))) + (push (cons (cons (caar s) + (if (eq (caar s) 'quote) + (list (add-object (cadar s))) + (parse-cvspecs (cdar s)))) + (parse-cvspecs (cdr s))) + body)) + (t (cmperr "The defCfun body ~s is illegal." s)))) + (t (cmperr "The defCfun body ~s is illegal." s)))) + (push (list 'defcfun (car args) (cadr args) (nreverse body)) + *top-level-forms*) + ) + +(defun t3defcfun (header vs-size body &aux fd) + (wt-comment "C function defined by " 'defcfun) + (wt-nl1 header) + (wt-h header ";") + (wt-nl1 "{") + (wt-nl1 "object *vs=vs_top;") + (when (> vs-size 0) (wt-nl1 "object *old_top=vs_top+" vs-size ";")(wt-nl "vs_top=old_top;")) + (wt-nl1 "{") + (dolist** (s body) + (cond ((stringp s) (wt-nl1 s)) + ((eq (caar s) 'quote) + (wt-nl1 (cadadr s)) + (case (caadr s) + (object (wt "=" (vv-str (cadar s)) ";")) + (otherwise + (wt "=object_to_" (string-downcase (symbol-name (caadr s))) + "(" (vv-str (cadar s)) ");")))) + (t (wt-nl1 "{vs_base=vs_top=old_top;") + (dolist** (arg (cdar s)) + (wt-nl1 "vs_push(") + (case (car arg) + (object (wt (cadr arg))) + (char (wt "code_char((long)" (cadr arg) ")")) + (int (when (zerop *space*) (wt "CMP")) + (wt "make_fixnum((long)(" (cadr arg) "))")) + (float (wt "make_shortfloat((double)" (cadr arg) ")")) + (double (wt "make_longfloat((double)" (cadr arg) ")"))) + (wt ");")) + (cond ((setq fd (assoc (caar s) *global-funs*)) + (cond (*compiler-push-events* + (wt-nl1 "ihs_push(" (vv-str (add-symbol (caar s))) ");") + (wt-nl1 (c-function-name "L" (cdr fd) (caar s)) "();") + (wt-nl1 "ihs_pop();")) + (t (wt-nl1 (c-function-name "L" (cdr fd) (caar s)) "();")))) + (*compiler-push-events* + (wt-nl1 "super_funcall(" (vv-str (add-symbol (caar s))) ");")) + (*safe-compile* + (wt-nl1 "super_funcall_no_event(" (vv-str (add-symbol (caar s))) ");")) + (t (wt-nl1 "CMPfuncall(" (vv-str (add-symbol (caar s))) "->s.s_gfdef);")) + ) + (unless (endp (cdr s)) + (wt-nl1 (cadadr s)) + (case (caadr s) + (object (wt "=vs_base[0];")) + (otherwise (wt "=object_to_" + (string-downcase (symbol-name (caadr s))) + "(vs_base[0]);"))) + (dolist** (dest (cddr s)) + (wt-nl1 "vs_base++;") + (wt-nl1 (cadr dest)) + (case (car dest) + (object + (wt "=(vs_base= (type1 type2) + (equal (type-and type1 type2) type2)) + +(defun reset-info-type (info) + (if (info-type info) + (let ((info1 (copy-info info))) + (setf (info-type info1) t) + info1) + info)) + +(defun and-form-type (type form original-form &aux type1) + (setq type1 (type-and type (info-type (cadr form)))) + (when (null type1) + (cmpwarn "The type of the form ~s is not ~s." original-form type)) + (if (eq type1 (info-type (cadr form))) + form + (let ((info (copy-info (cadr form)))) + (setf (info-type info) type1) + (list* (car form) info (cddr form))))) + +(defun check-form-type (type form original-form) + (when (null (type-and type (info-type (cadr form)))) + (cmpwarn "The type of the form ~s is not ~s." original-form type))) + +(defun default-init (type) + (case type + (fixnum (cmpwarn "The default value of NIL is not FIXNUM.")) + (character (cmpwarn "The default value of NIL is not CHARACTER.")) + (long-float (cmpwarn "The default value of NIL is not LONG-FLOAT.")) + (short-float (cmpwarn "The default value of NIL is not SHORT-FLOAT.")) + (integer (cmpwarn "The default value of NIL is not INTEGER")) + + ) + (c1nil)) diff --git a/cmpnew/gcl_cmputil.lsp b/cmpnew/gcl_cmputil.lsp new file mode 100755 index 0000000..c28d987 --- /dev/null +++ b/cmpnew/gcl_cmputil.lsp @@ -0,0 +1,247 @@ +;;; CMPUTIL Miscellaneous Functions. +;;; +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +(in-package 'compiler) + +(export '(*suppress-compiler-warnings* + *suppress-compiler-notes* + *compiler-break-enable*)) + +(defmacro safe-compile (&rest forms) `(when *safe-compile* ,@forms)) + +(defvar *current-form* '|compiler preprocess|) +(defvar *first-error* t) +(defvar *error-count* 0) + +(defconstant *cmperr-tag* (cons nil nil)) + +(defun cmperr (string &rest args &aux (*print-case* :upcase)) + (print-current-form) + (format t "~&;;; ") + (apply #'format t string args) + (incf *error-count*) + (throw *cmperr-tag* '*cmperr-tag*)) + +(defmacro cmpck (condition string &rest args) + `(if ,condition (cmperr ,string ,@args))) + +(defun too-many-args (name upper-bound n &aux (*print-case* :upcase)) + (print-current-form) + (format t + ";;; ~S requires at most ~R argument~:p, ~ + but ~R ~:*~[were~;was~:;were~] supplied.~%" + name + upper-bound + n) + (incf *error-count*) + (throw *cmperr-tag* '*cmperr-tag*)) + +(defun too-few-args (name lower-bound n &aux (*print-case* :upcase)) + (print-current-form) + (format t + ";;; ~S requires at least ~R argument~:p, ~ + but only ~R ~:*~[were~;was~:;were~] supplied.~%" + name + lower-bound + n) + (incf *error-count*) + (throw *cmperr-tag* '*cmperr-tag*)) + +(defvar *suppress-compiler-warnings* nil) + +(defun cmpwarn (string &rest args &aux (*print-case* :upcase)) + (unless *suppress-compiler-warnings* + (print-current-form) + (format t ";; Warning: ") + (apply #'format t string args) + (terpri)) + nil) + +(defvar *suppress-compiler-notes* nil) + +(defun cmpnote (string &rest args &aux (*print-case* :upcase)) + (unless *suppress-compiler-notes* + (terpri) + (format t ";; Note: ") + (apply #'format t string args)) + nil) + +(defun print-current-form () + (when *first-error* + (setq *first-error* nil) + (fresh-line) + (cond + ((and (consp *current-form*) + (eq (car *current-form*) 'si:|#,|)) + (format t "; #,~s is being compiled.~%" (cdr *current-form*))) + (t + (let ((*print-length* 2) + (*print-level* 2)) + (format t "; ~s is being compiled.~%" *current-form*))))) + nil) + +(defun undefined-variable (sym &aux (*print-case* :upcase)) + (print-current-form) + (format t + ";; The variable ~s is undefined.~%~ + ;; The compiler will assume this variable is a global.~%" + sym) + nil) + +(defun baboon (&aux (*print-case* :upcase)) + (print-current-form) + (format t ";;; A bug was found in the compiler. Contact Taiichi.~%") + (incf *error-count*) + (break) +; (throw *cmperr-tag* '*cmperr-tag*) +) + +;;; Internal Macros with type declarations + +(defmacro dolist* ((v l &optional (val nil)) . body) + (let ((temp (gensym))) + `(do* ((,temp ,l (cdr ,temp)) (,v (car ,temp) (car ,temp))) + ((endp ,temp) ,val) + (declare (object ,v)) + ,@body))) + +(defmacro dolist** ((v l &optional (val nil)) . body) + (let ((temp (gensym))) + `(do* ((,temp ,l (cdr ,temp)) (,v (car ,temp) (car ,temp))) + ((endp ,temp) ,val) + (declare (object ,temp ,v)) + ,@body))) + +(defmacro dotimes* ((v n &optional (val nil)) . body) + (let ((temp (gensym))) + `(do* ((,temp ,n) (,v 0 (1+ ,v))) + ((>= ,v ,temp) ,val) + (declare (fixnum ,v)) + ,@body))) + +(defmacro dotimes** ((v n &optional (val nil)) . body) + (let ((temp (gensym))) + `(do* ((,temp ,n) (,v 0 (1+ ,v))) + ((>= ,v ,temp) ,val) + (declare (fixnum ,temp ,v)) + ,@body))) + +(defun cmp-eval (form) + (let ((x (multiple-value-list (cmp-toplevel-eval `(eval ',form))))) + (if (car x) + (let ((*print-case* :upcase)) + (incf *error-count*) + (print-current-form) + (format t + ";;; The form ~s was not evaluated successfully.~%~ + ;;; You are recommended to compile again.~%" + form) + nil) + (values-list (cdr x))))) + + +;(si::putprop 'setf 'c1setf 'c1special) + +;;The PLACE may be a local macro, so we must take care to expand it +;;before trying to call the macro form of setf, or an error will + +;(defun c1setf (args &aux fd) +; (cond ((and +; (consp (car args)) +; (symbolp (caar args)) +; (setq fd (cmp-macro-function (caar args)))) +; (c1expr `(setf ,(cmp-expand-macro fd (caar args) (cdar args)) +; ,@ (cdr args)))) +; (t +; (c1expr (cmp-expand-macro (macro-function 'setf) +; 'setf +; args))))) + +(defun macro-def-p (form &aux (fname (when (consp form) (car form)))) + (when (symbolp fname) + (or (member-if (lambda (x) (when (consp x) (eq (car x) fname))) *funs*) + (macro-function fname)))) + +(defun do-macro-expansion (how form &aux env) + (dolist (v *funs*) + (when (consp v) + (push (list (car v) 'macro (cadr v)) env))) + (when env (setq env (list nil (nreverse env) nil))) + (let ((x (multiple-value-list (cmp-toplevel-eval `(,@how ',form ',env))))) + (if (car x) + (let ((*print-case* :upcase)) + (incf *error-count*) + (print-current-form) + (format t ";;; The macro form ~s was not expanded successfully.~%" form) + `(error "Macro-expansion of ~s failed at compile time." ',form)) + (cadr x)))) + +(defun cmp-macroexpand (form) + (if (macro-def-p form) + (do-macro-expansion '(macroexpand) form) + form)) + +(defun cmp-macroexpand-1 (form) + (if (macro-def-p form) + (do-macro-expansion '(macroexpand-1) form) + form)) + +(defun cmp-expand-macro (fd fname args &aux env (form (cons fname args))) + (if (macro-def-p form) + (do-macro-expansion `(funcall *macroexpand-hook* ',fd) form) + form)) + +(defvar *compiler-break-enable* nil) + +(defun cmp-toplevel-eval (form) + (let* ((si::*ihs-base* si::*ihs-top*) + (si::*ihs-top* (1- (si::ihs-top))) + (*break-enable* *compiler-break-enable*) + (si::*break-hidden-packages* + (cons (find-package 'compiler) + si::*break-hidden-packages*))) + (si:error-set form))) + +(dolist (v '(si::cdefn lfun inline-safe inline-unsafe + inline-always c1conditional c2 c1 c1+ co1 + si::structure-access co1special + top-level-macro t3 t2 t1 package-operation)) + (si::putprop v t 'compiler-prop )) + +(defun compiler-def-hook (symbol code) symbol code nil) + +(defun compiler-clear-compiler-properties (symbol code) + code + (let ((v (symbol-plist symbol)) w) + (tagbody + top + (setq w (car v)) + (cond ((and (symbolp w) + (get w 'compiler-prop)) + + (setq v (cddr v)) + (remprop symbol w)) + (t (setq v (cddr v)))) + (or (null v) (go top))) + (compiler-def-hook symbol code) + )) + +;hi diff --git a/cmpnew/gcl_cmpvar.lsp b/cmpnew/gcl_cmpvar.lsp new file mode 100755 index 0000000..6ab0e24 --- /dev/null +++ b/cmpnew/gcl_cmpvar.lsp @@ -0,0 +1,476 @@ +;;; CMPVAR Variables. +;;; +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +(in-package 'compiler) + +(si:putprop 'var 'c2var 'c2) +(si:putprop 'location 'c2location 'c2) +(si:putprop 'setq 'c1setq 'c1special) +(si:putprop 'setq 'c2setq 'c2) +(si:putprop 'progv 'c1progv 'c1special) +(si:putprop 'progv 'c2progv 'c2) +(si:putprop 'psetq 'c1psetq 'c1) +(si:putprop 'psetq 'c2psetq 'c2) + +(si:putprop 'var 'set-var 'set-loc) +(si:putprop 'var 'wt-var 'wt-loc) + +(defstruct var + name ;;; Variable name. + kind ;;; One of LEXICAL, SPECIAL, GLOBAL, REPLACED, FIXNUM, + ;;; CHARACTER, LONG-FLOAT, SHORT-FLOAT, and OBJECT. + ref ;;; Referenced or not. + ;;; During Pass1, T, NIL, or IGNORE. + ;;; During Pass2, the vs-address for the variable. + ref-ccb ;;; Cross closure reference. + ;;; During Pass1, T or NIL. + ;;; During Pass2, the ccb-vs for the variable, or NIL. + loc ;;; For SPECIAL and GLOBAL, the vv-index for variable name. + ;;; For others, this field is used to indicate whether + ;;; to be allocated on the value-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. + ;;; For REPLACED, the actual location of the variable. + ;;; For FIXNUM, CHARACTER, LONG-FLOAT, SHORT-FLOAT, and + ;;; OBJECT, the cvar for the C variable that holds the value. + ;;; Not used for LEXICAL. + (type t) ;;; Type of the variable. + (register 0) ;;; If greater than specified am't this goes into register. + ) + +;;; A special binding creates a var object with the kind field SPECIAL, +;;; whereas a special declaration without binding creates a var object with +;;; the kind field GLOBAL. Thus a reference to GLOBAL may need to make sure +;;; that the variable has a value. + +(defvar *vars* nil) +(defvar *register-min* 4) ;criteria for putting in register. +(defvar *undefined-vars* nil) +(defvar *special-binding* nil) + +;;; During Pass 1, *vars* holds a list of var objects and the symbols 'CB' +;;; (Closure Boundary) and 'LB' (Level Boundary). 'CB' will be pushed on +;;; *vars* when the compiler begins to process a closure. 'LB' will be pushed +;;; on *vars* when *level* is incremented. +;;; *GLOBALS* holds a list of var objects for those variables that are +;;; not defined. This list is used only to suppress duplicated warnings when +;;; undefined variables are detected. + +(defun c1make-var (name specials ignores types &aux x) + (let ((var (make-var :name name))) + (cmpck (not (symbolp name)) "The variable ~s is not a symbol." name) + (cmpck (constantp name) "The constant ~s is being bound." name) + + (cond ((or (member name specials) (si:specialp name)) + (setf (var-kind var) 'SPECIAL) + (setf (var-loc var) (add-symbol name)) + (cond ((setq x (assoc name types)) + (setf (var-type var) (cdr x))) + ((setq x (get name 'cmp-type)) + (setf (var-type var) x))) + (setq *special-binding* t)) + (t + (dolist** (v types) + (cond ((eq (car v) name) + (case (cdr v) + (object (setf (var-loc var) 'object)) + (register + (setf (var-register var) + (+ (var-register var) 100))) + (t (setf (var-type var) (cdr v))))))) + (and (boundp '*c-gc*) *c-gc* + (or (null (var-type var)) + (eq t (var-type var))) + (setf (var-loc var) 'object)) + (setf (var-kind var) 'LEXICAL))) + (let ((ign (member name ignores))) + (when ign + (setf (var-ref var) (if (eq (cadr ign) 'ignorable) 'IGNORABLE 'IGNORE)))) + var) + ) + +(defun check-vref (var) + (when (and (eq (var-kind var) 'LEXICAL) + (not (var-ref var)) ;;; This field may be IGNORE. + (not (var-ref-ccb var))) + (cmpwarn "The variable ~s is not used." (var-name var)))) + +(defun c1var (name) + (let ((info (make-info)) + (vref (c1vref name))) + (push-referred (car vref) info) + (setf (info-type info) (var-type (car vref))) + (list 'var info vref)) + ) + +;;; A variable reference (vref for short) is a pair +;;; ( var-object ccb-reference ) + +(defun c1vref (name &aux (ccb nil) (clb nil)) + (declare (object ccb clb)) + (dolist* (var *vars* + (let ((var (sch-global name))) + (unless var + (unless (si:specialp name) (undefined-variable name)) + (setq var (make-var :name name + :kind 'GLOBAL + :loc (add-symbol name) + :type (or (get name 'cmp-type) t) + )) + (push var *undefined-vars*)) + (list var ccb))) + (cond ((eq var 'cb) (setq ccb t)) + ((eq var 'lb) (setq clb t)) + ((eq (var-name var) name) + (when (eq (var-ref var) 'IGNORE) + (cmpwarn "The ignored variable ~s is used." name) + (setf (var-ref var) t)) + (cond (ccb (setf (var-ref-ccb var) t)) + (clb (when (eq (var-kind var) 'lexical) + (setf (var-loc var) 'clb)) + (setf (var-ref var) t)) + (t (setf (var-ref var) t) + (setf (var-register var) + (the fixnum (+ 1 (the fixnum (var-register var))))) + )) + (return-from c1vref (list var ccb))))) + ) + +(defun c2var-kind (var) + (if (and (eq (var-kind var) 'LEXICAL) + (not (var-ref-ccb var)) + (not (eq (var-loc var) 'clb))) + (if (eq (var-loc var) 'OBJECT) + 'OBJECT + (let ((type (var-type var))) + (declare (object type)) + (cond ((type>= 'fixnum type) 'FIXNUM) +; ((type>= 'integer type) 'INTEGER) + ((type>= 'CHARACTER type) 'CHARACTER) + ((type>= 'long-float type) 'LONG-FLOAT) + ((type>= 'short-float type) 'SHORT-FLOAT) + ((and (boundp '*c-gc*) *c-gc* 'OBJECT)) + (t nil)))) + nil) + ) + +(defun c2var (vref) (unwind-exit (cons 'var vref) nil 'single-value)) + +(defun c2location (loc) (unwind-exit loc nil 'single-value)) + + +(defun check-downward (info &aux no-down ) + (dolist (v *local-functions*) + (cond ((eq (car v) 'function) + (setq no-down t) + (dolist (w *local-functions*) + (cond ((eq (car w) 'downward-function) + (setf (car w) 'function)))) + (return nil)))) + (setq *local-functions* nil) + (cond (no-down + (do-referred (var info) + (if (eq (var-kind var) 'down) + (setf (var-kind var) 'lexical)))))) + + +(defun assign-down-vars (info cfun inside &aux (ind 0) ) + (do-referred (var info) + (cond ((eq (var-kind var) 'down) + ;;don't do twice since this list may have duplicates. + (cond ((integerp (var-loc var) ) + ;(or (integerp (var-ref var)) (print var)) + (setq ind (max ind (1+ (var-loc var)))) + (setf (var-ref var) (var-loc var)) ;delete later + ) + ;((integerp (var-loc var)) (break "bil")) + (t (setf (var-ref var) ind) ;delete later + (setf (var-loc var) ind) + (setf ind (+ ind 1))))))) + (cond ((> ind 0) + ;;(wt-nl "object Dbase[" ind "];") + (cond ((eq inside 't3defun) + (wt-nl "object base0[" ind "];"))) + ;DCnames gets defined at end whe + (push 'dcnames *downward-closures*) + (wt-nl "DCnames"cfun ""))) + ind) + +(si::putprop 'down 'wt-down 'wt-loc) + +(defun wt-down (n) + (or (si::fixnump n) (wfs-error)) + (wt "base0[" n "]")) + +(defun wt-var (var ccb) + (case (var-kind var) + (LEXICAL (cond (ccb (wt-ccb-vs (var-ref-ccb var))) + ((var-ref-ccb var) (wt-vs* (var-ref var))) + ((and (eq t (var-ref var)) + (si:fixnump (var-loc var)) + *c-gc* + (eq t (var-type var))) + (setf (var-kind var) 'object) + (wt-var var ccb)) + (t (wt-vs (var-ref var))))) + (SPECIAL (wt "(" (vv-str (var-loc var)) "->s.s_dbind)")) + (REPLACED (wt (var-loc var))) + (DOWN (wt-down (var-loc var))) + (GLOBAL (if *safe-compile* + (wt "symbol_value(" (vv-str (var-loc var)) ")") + (wt "(" (vv-str (var-loc var)) "->s.s_dbind)"))) + (t (case (var-kind var) + (FIXNUM (when (zerop *space*) (wt "CMP")) + (wt "make_fixnum")) + (INTEGER (wt "make_integer")) + (CHARACTER (wt "code_char")) + (LONG-FLOAT (wt "make_longfloat")) + (SHORT-FLOAT (wt "make_shortfloat")) + (OBJECT) + (t (baboon))) + (wt "(V" (var-loc var) ")")) + )) + +;; When setting bignums across setjmps, cannot use alloca as longjmp +;; restores the C stack. FIXME -- only need malloc when reading variable +;; outside frame. CM 20031201 +(defmacro bignum-expansion-storage () + `(if (and (boundp '*unwind-exit*) (member 'frame *unwind-exit*)) + "gcl_gmp_alloc" + "alloca")) + +(defun set-var (loc var ccb) + (unless (and (consp loc) + (eq (car loc) 'var) + (eq (cadr loc) var) + (eq (caddr loc) ccb)) + (case (var-kind var) + (LEXICAL (wt-nl) + (cond (ccb (wt-ccb-vs (var-ref-ccb var))) + ((var-ref-ccb var) (wt-vs* (var-ref var))) + (t (wt-vs (var-ref var)))) + (wt "= " loc ";")) + (SPECIAL (wt-nl "(" (vv-str (var-loc var)) "->s.s_dbind)= " loc ";")) + (GLOBAL + (if *safe-compile* + (wt-nl "setq(" (vv-str (var-loc var)) "," loc ");") + (wt-nl "(" (vv-str (var-loc var)) "->s.s_dbind)= " loc ";"))) + (DOWN + (wt-nl "") (wt-down (var-loc var)) + (wt "=" loc ";")) + (INTEGER + (let ((first (and (consp loc) (car loc))) + (n (var-loc var))) + (case first + (inline-fixnum + (wt-nl "ISETQ_FIX(V"n",V"n"alloc,") + (wt-inline-loc (caddr loc) (cadddr loc))) + (fixnum-value (wt-nl "ISETQ_FIX(V"n",V"n"alloc,"(caddr loc))) + + (var + (case (var-kind (cadr loc)) + (integer (wt "SETQ_II(V"n",V"n"alloc,V" (var-loc (cadr loc)) "," + (bignum-expansion-storage))) + (fixnum (wt "ISETQ_FIX(V"n",V"n"alloc,V" (var-loc (cadr loc)))) + (otherwise (wt "SETQ_IO(V"n",V"n"alloc,"loc "," + (bignum-expansion-storage))))) + (vs (wt "SETQ_IO(V"n",V"n"alloc,"loc "," + (bignum-expansion-storage))) + (otherwise + (let ((*inline-blocks* 0) (*restore-avma* *restore-avma*)) + (save-avma '(nil integer)) + (wt-nl "SETQ_II(V"n",V" n"alloc,") + (wt-integer-loc loc (cons 'set-var var)) + (wt "," (bignum-expansion-storage) ");") + (close-inline-blocks)) + (return-from set-var nil)) + ) + (wt ");"))) + (t + (wt-nl "V" (var-loc var) "= ") + (case (var-kind var) + (FIXNUM (wt-fixnum-loc loc)) + (CHARACTER (wt-character-loc loc)) + (LONG-FLOAT (wt-long-float-loc loc)) + (SHORT-FLOAT (wt-short-float-loc loc)) + (OBJECT (wt-loc loc)) + (t (baboon))) + (wt ";")) + ))) + +(defun sch-global (name) + (dolist* (var *undefined-vars* nil) + (when (eq (var-name var) name) (return-from sch-global var)))) + +(defun c1add-globals (globals) + (dolist** (name globals) + (push (make-var :name name + :kind 'GLOBAL + :loc (add-symbol name) + :type (let ((x (get name 'cmp-type))) (if x x t)) + ) + *vars*)) + ) + +(defun c1setq (args) + (cond ((endp args) (c1nil)) + ((endp (cdr args)) (too-few-args 'setq 2 1)) + ((endp (cddr args)) (c1setq1 (car args) (cadr args))) + (t + (do ((pairs args (cddr pairs)) + (forms nil)) + ((endp pairs) (c1expr (cons 'progn (nreverse forms)))) + (declare (object pairs)) + (cmpck (endp (cdr pairs)) + "No form was given for the value of ~s." (car pairs)) + (push (list 'setq (car pairs) (cadr pairs)) forms) + ))) + ) + +(defun c1setq1 (name form &aux (info (make-info)) type form1 name1) + (cmpck (not (symbolp name)) "The variable ~s is not a symbol." name) + (cmpck (constantp name) "The constant ~s is being assigned a value." name) + (setq name1 (c1vref name)) + (push-changed (car name1) info) + (setq form1 (c1expr form)) + (add-info info (cadr form1)) + (setq type (type-and (var-type (car name1)) (info-type (cadr form1)))) + (when (null type) + (cmpwarn "Type mismatches between ~s and ~s." name form)) + (unless (eq type (info-type (cadr form1))) + (let ((info1 (copy-info (cadr form1)))) + (setf (info-type info1) type) + (setq form1 (list* (car form1) info1 (cddr form1))))) + (setf (info-type info) type) + (list 'setq info name1 form1) + ) + +(defun c2setq (vref form) + (let ((*value-to-go* (cons 'var vref))) (c2expr* form)) + (case (car form) + (LOCATION (c2location (caddr form))) + (otherwise (unwind-exit (cons 'var vref)))) + ) + +(defun c1progv (args &aux symbols values (info (make-info))) + (when (or (endp args) (endp (cdr args))) + (too-few-args 'progv 2 (length args))) + (setq symbols (c1expr* (car args) info)) + (setq values (c1expr* (cadr args) info)) + (list 'progv info symbols values (c1progn* (cddr args) info)) + ) + +(defun c2progv (symbols values body + &aux (cvar (next-cvar)) + (*unwind-exit* *unwind-exit*)) + + (wt-nl "{object symbols,values;") + (wt-nl "bds_ptr V" cvar "=bds_top;") + (push cvar *unwind-exit*) + + (let ((*vs* *vs*)) + (let ((*value-to-go* (list 'vs (vs-push)))) + (c2expr* symbols) + (wt-nl "symbols= " *value-to-go* ";")) + + (let ((*value-to-go* (list 'vs (vs-push)))) + (c2expr* values) + (wt-nl "values= " *value-to-go* ";")) + + (wt-nl "while(!endp(symbols)){") + (when *safe-compile* + (wt-nl "if(type_of(MMcar(symbols))!=t_symbol)") + (wt-nl + "FEinvalid_variable(\"~s is not a symbol.\",MMcar(symbols));")) + (wt-nl "if(endp(values))bds_bind(MMcar(symbols),OBJNULL);") + (wt-nl "else{bds_bind(MMcar(symbols),MMcar(values));") + (wt-nl "values=MMcdr(values);}") + (wt-nl "symbols=MMcdr(symbols);}") + ) + (c2expr body) + (wt "}") + ) + +(defun c1psetq (args &aux (vrefs nil) (forms nil) + (info (make-info :type '(member nil)))) + (do ((l args (cddr l))) + ((endp l)) + (declare (object l)) + (cmpck (not (symbolp (car l))) + "The variable ~s is not a symbol." (car l)) + (cmpck (constantp (car l)) + "The constant ~s is being assigned a value." (car l)) + (cmpck (endp (cdr l)) + "No form was given for the value of ~s." (car l)) + (let* ((vref (c1vref (car l))) + (form (c1expr (cadr l))) + (type (type-and (var-type (car vref)) + (info-type (cadr form))))) + (unless (equal type (info-type (cadr form))) + (let ((info1 (copy-info (cadr form)))) + (setf (info-type info1) type) + (setq form (list* (car form) info1 (cddr form))))) + (push vref vrefs) + (push form forms) + (push-changed (car vref) info) + (add-info info (cadar forms))) + ) + (list 'psetq info (nreverse vrefs) (nreverse forms)) + ) + +(defun c2psetq (vrefs forms &aux (*vs* *vs*) (saves nil) (blocks 0)) + (dolist** (vref vrefs) + (if (or (args-info-changed-vars (car vref) (cdr forms)) + (args-info-referred-vars (car vref) (cdr forms))) + (case (caar forms) + (LOCATION (push (cons vref (caddar forms)) saves)) + (otherwise + (if (member (var-kind (car vref)) + '(FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT OBJECT)) + (let* ((kind (var-kind (car vref))) + (cvar (next-cvar)) + (temp (list 'var (make-var :kind kind :loc cvar) nil))) + (wt-nl "{" *volatile* (rep-type kind) "V" cvar ";") + (incf blocks) + (let ((*value-to-go* temp)) (c2expr* (car forms))) + (push (cons vref temp) saves)) + (let ((*value-to-go* (list 'vs (vs-push)))) + (c2expr* (car forms)) + (push (cons vref *value-to-go*) saves))))) + (let ((*value-to-go* (cons 'var vref))) (c2expr* (car forms)))) + (pop forms)) + (dolist** (save saves) (set-var (cdr save) (caar save) (cadar save))) + (dotimes (i blocks) (wt "}")) + (unwind-exit nil) + ) +(defun wt-var-decl (var) + (cond ((var-p var) + (let ((n (var-loc var))) + (cond ((eq (var-kind var) 'integer)(wt "IDECL("))) + (wt *volatile* (register var) (rep-type (var-kind var)) + "V" n ) + (if (eql (var-kind var) 'integer) (wt ",V"n"space,V"n"alloc)")) + (wt ";"))) + (t (wfs-error)))) diff --git a/cmpnew/gcl_cmpvs.lsp b/cmpnew/gcl_cmpvs.lsp new file mode 100755 index 0000000..15ef9b1 --- /dev/null +++ b/cmpnew/gcl_cmpvs.lsp @@ -0,0 +1,100 @@ +;;; CMPVS Value stack manager. +;;; +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +(in-package 'compiler) + +(si:putprop 'vs 'set-vs 'set-loc) +(si:putprop 'vs 'wt-vs 'wt-loc) +(si:putprop 'vs* 'wt-vs* 'wt-loc) +(si:putprop 'ccb-vs 'wt-ccb-vs 'wt-loc) + +(defvar *vs* 0) +(defvar *max-vs* 0) +(defvar *clink* nil) +(defvar *ccb-vs* 0) +;; We need an initial binding for *initial-ccb-vs* for use in defining +;; local functions at the toplevel in c2flet and c2labels. CM +;; 20031130. +(defvar *initial-ccb-vs* 0) +(defvar *level* 0) +(defvar *vcs-used*) + +;;; *vs* holds the offset of the current vs-top. +;;; *max-vs* holds the maximum offset so far. +;;; *clink* holds NIL or the vs-address of the last ccb object. +;;; *ccb-vs* holds the top of the level 0 vs. +;;; *initial-ccb-vs* holds the value of *ccb-vs* when Pass 2 began to process +;;; a local (possibly closure) function. +;;; *level* holds the current function level. *level* is 0 for a top-level +;;; function. + +(defun vs-push () + (prog1 (cons *level* *vs*) + (incf *vs*) + (setq *max-vs* (max *vs* *max-vs*)))) + +(defun set-vs (loc vs) + (unless (and (consp loc) + (eq (car loc) 'vs) + (equal (cadr loc) vs)) + (wt-nl) + (wt-vs vs) + (wt "= " loc ";"))) + +(defun wt-vs (vs) + (cond ((eq (car vs) 'cvar) + (wt "V" (second vs))) + ((eq (car vs) 'cs) + (setq *vcs-used* t) + (wt "Vcs[" (cdr vs) "]")) + ((eq (car vs) 'fun-env) + (wt "fun->cc.cc_turbo[" (cdr vs) "]")) + (t + (if (= (car vs) *level*) + (wt "base[" (cdr vs) "]") + (wt "base" (car vs) "[" (cdr vs) "]"))))) + +(defun wt-vs* (vs) + (wt "(" )(wt-vs vs) (wt "->c.c_car)")) + +(defun wt-ccb-vs (ccb-vs) + (wt "(fun->cc.cc_turbo[" (- *initial-ccb-vs* ccb-vs) "]->c.c_car)")) + +(defun clink (vs) (setq *clink* vs)) + +(defun wt-clink (&optional (clink *clink*)) + (if (null clink) (wt "Cnil") (wt-vs clink))) + +(defun ccb-vs-push () (incf *ccb-vs*)) + + +(defun cvs-push () + (prog1 (cons 'cs *cs*) + (incf *cs*) + )) + + +(defun wt-list (l) + (do ((v l (cdr v))) + ((null v)) + (wt (car v)) + (or (null (cdr v)) (wt ",")))) + diff --git a/cmpnew/gcl_cmpwt.lsp b/cmpnew/gcl_cmpwt.lsp new file mode 100755 index 0000000..1c2d6ee --- /dev/null +++ b/cmpnew/gcl_cmpwt.lsp @@ -0,0 +1,216 @@ +;;; CMPWT Output routines. +;;; +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +(in-package 'compiler) + +(eval-when (compile eval) + (require 'FASDMACROS "../cmpnew/gcl_fasdmacros.lsp") + + +(defmacro data-vector () `(car *data*)) +(defmacro data-inits () `(second *data*)) +(defmacro data-package-ops () `(third *data*)) + +) + +(defun wt-comment (message &optional (symbol nil)) + (princ " +/* " *compiler-output1*) + (princ message *compiler-output1*) + (when symbol + (let ((s (symbol-name symbol))) + (declare (string s)) + (dotimes** (n (length s)) + (let ((c (schar s n))) + (declare (character c)) + (unless (char= c #\/) + (princ c *compiler-output1*)))))) + (princ " */ +" *compiler-output1*) + nil + ) + +(defun wt1 (form) + (cond ((or (stringp form) (integerp form) (characterp form)) + (princ form *compiler-output1*)) + ((or (typep form 'long-float) + (typep form 'short-float)) + (format *compiler-output1* "~10,,,,,,'eG" form)) + (t (wt-loc form))) + nil) + +(defun wt-h1 (form) + (cond ((consp form) + (let ((fun (get (car form) 'wt))) + (if fun + (apply fun (cdr form)) + (cmpiler-error "The location ~s is undefined." form)))) + (t (princ form *compiler-output2*))) + nil) + +(defvar *fasd-data*) + +(defvar *hash-eq* nil) +(defvar *run-hash-equal-data-checking* nil) +(defun memoized-hash-equal (x depth);FIXME implement all this in lisp + (declare (fixnum depth)) + (when *run-hash-equal-data-checking* + (unless *hash-eq* (setq *hash-eq* (make-hash-table :test 'eq))) + (or (gethash x *hash-eq*) + (setf (gethash x *hash-eq*) + (if (> depth 3) 0 + (if (typep x 'cons) + (logxor (setq depth (the fixnum (1+ depth)));FIXME? + (logxor + (memoized-hash-equal (car x) depth) + (memoized-hash-equal (cdr x) depth))) + (si::hash-equal x depth))))))) + +(defun push-data-incf (x) + (vector-push-extend (cons (memoized-hash-equal x -1000) x) (data-vector)) + (incf *next-vv*)) + +(defun wt-data1 (expr) + (let ((*print-radix* nil) + (*print-base* 10) + (*print-circle* t) + (*print-pretty* nil) + (*print-level* nil) + (*print-length* nil) + (*print-case* :downcase) + (*print-gensym* t) + (*print-array* t) + ;;This forces the printer to add the float type in the .data file. + (*READ-DEFAULT-FLOAT-FORMAT* t) + (si::*print-package* t) + (si::*print-structure* t)) + (terpri *compiler-output-data*) + (prin1 expr *compiler-output-data*))) + +(defun verify-data-vector(vec &aux v) + (dotimes (i (length vec)) + (setq v (aref vec i)) + (let ((has (memoized-hash-equal (cdr v) -1000))) + (cond ((not (eql (car v) has)) + (cmpwarn "A form or constant:~% ~s ~%has changed during the eval compile procedure!.~% The changed form will be the one put in the compiled file" (cdr v))))) + (setf (aref vec i) (cdr v))) + vec + ) + +(defun add-init (x &optional endp) + (let ((tem (cons (memoized-hash-equal x -1000) x))) + (setf (data-inits) + (if endp + (nconc (data-inits) (list tem)) + (cons tem (data-inits) ))) + x)) + +(defun wt-data-file () + (verify-data-vector (data-vector)) + (let* ((vec (coerce (nreverse (data-inits)) 'vector))) + (verify-data-vector vec) + (setf (aref (data-vector) (- (length (data-vector)) 1)) + (cons 'si::%init vec)) + (setf (data-package-ops) (nreverse (data-package-ops))) + (cond (*fasd-data* + (wt-fasd-data-file)) + (t + (format *compiler-output-data* " ~%#(") + (dolist (v (data-package-ops)) + (format *compiler-output-data* "#! ") + (wt-data1 v)) + (wt-data1 (data-vector)) + (format *compiler-output-data* "~%)~%") + )))) + +(defun wt-fasd-data-file ( &aux (x (data-vector)) tem) +; (si::find-sharing-top (data-package-ops) (fasd-table (car *fasd-data*))) + (si::find-sharing-top x (fasd-table (car *fasd-data*))) + (cond ((setq tem (data-package-ops)) + (dolist (v tem) + (put-op d_eval_skip *compiler-output-data*) + (si::write-fasd-top v (car *fasd-data*))))) + (si::write-fasd-top x (car *fasd-data*)) +; (sloop::sloop for (k v) in-table (fasd-table (car *fasd-data*)) +; when (>= v 0) do (print (list k v))) + (si::close-fasd (car *fasd-data*))) +(defun wt-data-begin ()) +(defun wt-data-end ()) +(defun wt-data-package-operation (x) + (push x (data-package-ops))) + +(defmacro wt (&rest forms &aux (fl nil)) + (dolist** (form forms (cons 'progn (reverse (cons nil fl)))) + (if (stringp form) + (push `(princ ,form *compiler-output1*) fl) + (push `(wt1 ,form) fl)))) + +(defmacro wt-h (&rest forms &aux (fl nil)) + (cond ((endp forms) '(princ " +" *compiler-output2*)) + ((stringp (car forms)) + (dolist** (form (cdr forms) + (list* 'progn `(princ ,(concatenate 'string " +" (car forms)) *compiler-output2*) (reverse (cons nil fl)))) + (if (stringp form) + (push `(princ ,form *compiler-output2*) fl) + (push `(wt-h1 ,form) fl)))) + (t (dolist** (form forms + (list* 'progn '(princ " +" *compiler-output2*) (reverse (cons nil fl)))) + (if (stringp form) + (push `(princ ,form *compiler-output2*) fl) + (push `(wt-h1 ,form) fl)))))) + +(defmacro wt-nl (&rest forms &aux (fl nil)) + (cond ((endp forms) '(princ " + " *compiler-output1*)) + ((stringp (car forms)) + (dolist** (form (cdr forms) + (list* 'progn `(princ ,(concatenate 'string " + " (car forms)) *compiler-output1*) (reverse (cons nil fl)))) + (if (stringp form) + (push `(princ ,form *compiler-output1*) fl) + (push `(wt1 ,form) fl)))) + (t (dolist** (form forms + (list* 'progn '(princ " + " *compiler-output1*) (reverse (cons nil fl)))) + (if (stringp form) + (push `(princ ,form *compiler-output1*) fl) + (push `(wt1 ,form) fl)))))) + +(defmacro wt-nl1 (&rest forms &aux (fl nil)) + (cond ((endp forms) '(princ " +" *compiler-output1*)) + ((stringp (car forms)) + (dolist** (form (cdr forms) + (list* 'progn `(princ ,(concatenate 'string " +" (car forms)) *compiler-output1*) (nreverse (cons nil fl)))) + (if (stringp form) + (push `(princ ,form *compiler-output1*) fl) + (push `(wt1 ,form) fl)))) + (t (dolist** (form forms + (list* 'progn '(princ " +" *compiler-output1*) (nreverse (cons nil fl)))) + (if (stringp form) + (push `(princ ,form *compiler-output1*) fl) + (push `(wt1 ,form) fl)))))) + diff --git a/cmpnew/gcl_collectfn.lsp b/cmpnew/gcl_collectfn.lsp new file mode 100755 index 0000000..3f9c7f0 --- /dev/null +++ b/cmpnew/gcl_collectfn.lsp @@ -0,0 +1,401 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;;;; +;;; Copyright (c) 1989 by William Schelter,University of Texas ;;;;; +;;; All rights reserved ;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; See the doc/DOC file for information on emit-fn and +;; make-all-proclaims. The basic idea is to utilize information gathered +;; by the compiler in a compile of a system of files in order to generate +;; better code on subsequent compiles of the system. To do this a file +;; sys-proclaim.lisp should be produced. + +;; Additionally cross reference information about functions in the system is +;; collected. + +(in-package 'compiler) +(import 'sloop::sloop) + +(defstruct fn + name ;; name of THIS FUNCTION + def ;; defun, defmacro + value-type ;; If this function's body contained + ;; (cond ((> a 3) 7) + ;; ((> a 1) (foo))) + ;; then the return type of 7 is known at compile time + ;; and value-type would be fixnum. [see return-type] + fun-values ;; list of functions whose values are the values of THIS FN + ;; (foo) in the previous example. + callees ;; list of all functions called by THIS FUNCTION + return-type ;; Store a return-type computed from the fun-values + ;; and value-type field. This computation is done later. + arg-types ;; non optional arg types. + no-emit ;; if not nil don't emit declaration. + macros + ) + +(defvar *other-form* (make-fn)) +(defvar *all-fns* nil) +(defvar *call-table* (make-hash-table)) +(defvar *current-fn* nil) +(defun add-callee (fname) + (cond ((consp fname) + (or (eq (car fname) 'values) + (add-callee (car fname)))) + ((eq fname 'single-value)) + (fname (pushnew fname (fn-callees (current-fn)))))) + +(defun add-macro-callee (fname) + (or + ;; make sure the macro fname is not shadowed in the current environment. + (sloop::sloop for v in *funs* + when (and (consp v) (eq (car v) fname)) + do (return t)) + (pushnew fname (fn-macros (current-fn))))) + +(defun clear-call-table () + (setf *current-fn* nil) + (setq *all-fns* nil) + (setq *other-form* (make-fn :name 'other-form)) + (clrhash *call-table*) + (setf (gethash 'other-form *call-table*) *other-form*) + ) + +(defun emit-fn (flag) (setq *record-call-info* flag)) + +(defun type-or (a b) + (if (eq b '*) '* + (case a + ((nil) b) + ((t inline) t) + ((fixnum inline-fixnum fixnum-value) (if (eq b 'fixnum) 'fixnum + (type-or t b))) + (otherwise '*) + ))) + +(defun current-fn () + (cond ((and (consp *current-form*) + (member (car *current-form*) '(defun defmacro)) + (symbolp (second *current-form*)) + (symbol-package (second *current-form*));;don't record gensym'd + ) + (cond ((and *current-fn* + (equal (second *current-form*) (fn-name *current-fn*))) + *current-fn*) + (t + (unless + (setq *current-fn* + (gethash (second *current-form*) *call-table*)) + (setq *current-fn* (make-fn :name (second *current-form*) + :def (car *current-form*))) + (setf (gethash (second *current-form*) *call-table*) + *current-fn*) + (setq *all-fns* (cons *current-fn* *all-fns*))) + *current-fn*))) + ;; catch all for other top level forms + (t *other-form*))) + +(defun who-calls (f) + (sloop for (ke val) in-table *call-table* + when (or (member f (fn-callees val)) + (member f (fn-macros val))) + collect ke)) + + +(defun add-value-type (x fn &aux (current-fn (current-fn))) + (cond (fn (pushnew fn + (fn-fun-values current-fn) :test 'equal)) + (t + (setf (fn-value-type current-fn) + (type-or (fn-value-type current-fn) x))))) + + +(defun get-var-types (lis) + (sloop::sloop for v in lis collect (var-type v))) + +(defun record-arg-info( lambda-list &aux (cf (current-fn))) + (setf (fn-arg-types cf) (get-var-types (car lambda-list))) + (when (sloop::sloop for v in (cdr lambda-list) + for w in '(&optional &rest &key + nil &allow-other-keys + ) + when (and v w) do (return '*)) + (setf (fn-arg-types cf) (nconc(fn-arg-types cf) (list '*))) + )) + +(defvar *depth* 0) +(defvar *called-from* nil) + +(defun get-value-type (fname) + (cond ((member fname *called-from* :test 'eq) nil) + (t + (let ((tem (cons fname *called-from*))) + (declare (:dynamic-extent tem)) + (let ((*called-from* tem)) + (get-value-type1 fname)))))) + +(defun get-value-type1 (fname + &aux tem (*depth* (the fixnum (+ 1 (the fixnum + *depth* ))))) + (cond ((> (the fixnum *depth*) 100) '*) + ((setq tem (gethash fname *call-table*)) + (or + (fn-return-type tem) + (sloop::sloop with typ = (fn-value-type tem) + for v in (fn-fun-values tem) + when (symbolp v) + do (setq typ (type-or typ (get-value-type v))) + else + when (and (consp v) (eq (car v) 'values)) + do + (setq typ (type-or typ (if (eql (cdr v) 1) t '*))) + else do (error "unknown fun value ~a" v) + finally + ;; if there is no visible return, then we can assume + ;; one value. + (or typ (fn-value-type tem) + (fn-fun-values tem) + (setf typ t)) + (setf (fn-return-type tem) typ) + (return typ) + ))) + ((get fname 'return-type)) + ((get fname 'proclaimed-return-type)) + (t '*))) + +(defun result-type-from-loc (x) + (cond ((consp x) + (case (car x) + ((fixnum-value inline-fixnum) 'fixnum) + (var (var-type (second x))) + ;; eventually separate out other inlines + (t (cond ((and (symbolp (car x)) + (get (car x) 'wt-loc)) + t) + (t (print (list 'type '* x)) '*))))) + ((or (eq x t) (null x)) t) + (t (print (list 'type '*2 x)) '*))) + + +(defun small-all-t-p (args ret) + (and (eq ret t) + (< (length args) 10) + (sloop::sloop for v in args always (eq v t)))) + +;; Don't change return type but pretend all these are optional args. + +(defun no-make-proclaims-hack () + (sloop::sloop for (ke val) in-table *call-table* + do (progn ke) (setf (fn-no-emit val) 1))) + +(defun set-closure () + (setf (fn-def (current-fn)) 'closure)) + +(defun make-proclaims ( &optional (st *standard-output*) + &aux (ht (make-hash-table :test 'equal)) + *print-length* *print-level* + (si::*print-package* t) + ) +; (require "VLFUN" +; (concatenate 'string si::*system-directory* +; "../cmpnew/lfun_list.lsp")) + + (print `(in-package ,(package-name *package*)) st) + (sloop::sloop with ret with at + for (ke val) in-table *call-table* + do + (cond ((eq (fn-def val) 'closure) + (push ke (gethash 'proclaimed-closure ht))) + ((or (eql 1 (fn-no-emit val)) + (not (eq (fn-def val) 'defun)))) + (t (setq ret (get-value-type ke)) + (setq at (fn-arg-types val)) + (push ke (gethash (list at ret) ht))))) + (sloop::sloop for (at fns) in-table ht + do + (print + (if (symbolp at) `(mapc (lambda (x) (setf (get x 'compiler::proclaimed-closure) t)) '(,@fns)) + `(proclaim '(ftype (function ,@ at) ,@ fns))) + st))) + +(defun setup-sys-proclaims() + (or (gethash 'si::call-test *call-table*) + (get 'si::call-test 'proclaimed-function) + (load (concatenate 'string si::*system-directory* + "../lsp/sys-proclaim.lisp")) + (no-make-proclaims-hack) + )) + +(defun make-all-proclaims (&rest files) + (setup-sys-proclaims) + (dolist (v files) + (mapcar 'load (directory v))) + (write-sys-proclaims)) + +(defun write-sys-proclaims () + (with-open-file (st "sys-proclaim.lisp" :direction :output) + (make-proclaims st))) + +(defvar *file-table* (make-hash-table :test 'eq)) + +(defvar *warn-on-multiple-fn-definitions* t) + +(defun add-fn-data (lis &aux tem file) + (let ((file (and (setq file (si::fp-input-stream *standard-input*)) + (truename file)))) + (dolist (v lis) + (cond ((eql (fn-name v) 'other-form) + (setf (fn-name v) (intern + (concatenate 'string "OTHER-FORM-" + (namestring file)))) + (setf (get (fn-name v) 'other-form) t))) + (setf (gethash (fn-name v) *call-table*) v) + (when *warn-on-multiple-fn-definitions* + (when (setq tem (gethash (fn-name v) *file-table*)) + (unless (equal tem file) + (warn 'simple-warning :format-control "~% ~a redefined in ~a. Originally in ~a." + :format-arguments (list (fn-name v) file tem))))) + (setf (gethash (fn-name v) *file-table*) file)))) + +(defun dump-fn-data (&optional (file "fn-data.lsp") + &aux (*package* (find-package "COMPILER")) + (*print-length* nil) + (*print-level* nil) + ) + (with-open-file (st file :direction :output) + (format st "(in-package 'compiler)(init-fn)~%(~s '(" 'add-fn-data) + (sloop::sloop for (ke val) in-table *call-table* + do (progn ke) (print val st)) + (princ "))" st) + (truename st))) + +(defun record-call-info (loc fname) + (cond ((and fname (symbolp fname)) + (add-callee fname))) + (cond ((eq loc 'record-call-info) (return-from record-call-info nil))) + (case *value-to-go* + (return + (if (eq loc 'fun-val) + (add-value-type nil (or fname 'unknown-values)) + (add-value-type (result-type-from-loc loc) nil))) + (return-fixnum + (add-value-type 'fixnum nil)) + (return-object + (add-value-type t nil)) + + (top (setq *top-data* (cons fname nil)) + )) + ) + +(defun list-undefined-functions (&aux undefs) + (sloop::sloop for (name fn) in-table *call-table* + declare (ignore name) + do (sloop for w in (fn-callees fn) + when (not (or (fboundp w) + (gethash w *call-table*) + (get w 'inline-always) + (get w 'inline-unsafe) + (get w 'other-form) + )) + do (pushnew w undefs))) + undefs) + + + +(dolist (v '(throw coerce single-value sort delete remove char-upcase + si::fset typep)) + (si::putprop v t 'return-type)) + +(defun init-fn () nil) + +(defun list-uncalled-functions ( ) + (let* ((size (sloop::sloop for (ke v) + in-table *call-table* count t + do (progn ke v nil))) + (called (make-hash-table :test 'eq :size (+ 3 size)))) + (sloop::sloop for (ke fn) in-table *call-table* + declare (ignore ke) + do (sloop::sloop for w in (fn-callees fn) + do + (setf (gethash w called) t)) + (sloop::sloop for w in (fn-macros fn) + do + (setf (gethash w called) t)) + + ) + (sloop::sloop for (ke fn) in-table *call-table* + when(and + (not (gethash ke called)) + (member (fn-def fn) '(defun defmacro) + :test 'eq)) + collect ke))) + +;; redefine the stub in defstruct.lsp +(defun si::record-fn (name def arg-types return-type) + (if (null return-type) (setq return-type t)) + (and *record-call-info* + *compiler-in-use* + (let ((fn (make-fn :name name + :def def + :return-type return-type + :arg-types arg-types))) + (push fn *all-fns*) + (setf (gethash name *call-table*) fn)))) + +(defun get-packages (&optional (st "sys-package.lisp") pass + &aux (si::*print-package* t)) + (flet ((pr (x) (format st "~%~s" x))) + (cond ((null pass) + (with-open-file (st st :direction :output) + (get-packages st 'establish) + (get-packages st 'export) + (get-packages st 'shadow) + (format st "~2%") + (return-from get-packages nil)))) + (dolist (p (list-all-packages)) + (unless + (member (package-name p) + '("SLOOP" + "COMPILER" "SYSTEM" "KEYWORD" "LISP" "USER") + :test 'equal + ) + (format st "~2%;;; Definitions for package ~a of type ~a" + (package-name p) pass) + (ecase pass + (establish + (let ((SYSTEM::*PRINT-PACKAGE* t)) + (pr + `(in-package ,(package-name p) :use nil + ,@ (if (package-nicknames p) + `(:nicknames ',(package-nicknames p))))))) + (export + (let ((SYSTEM::*PRINT-PACKAGE* t)) + (pr + `(in-package ,(package-name p) + :use + '(,@ + (mapcar 'package-name (package-use-list p))) + ,@(if (package-nicknames p) + `(:nicknames ',(package-nicknames p)))))) + (let (ext (*package* p) + imps) + (do-external-symbols (sym p) (push sym ext) + (or (eq (symbol-package sym) p) + (push sym imps))) + (pr `(import ',imps)) + (pr `(export ',ext)))) + (shadow + (let ((SYSTEM::*PRINT-PACKAGE* t)) + (pr `(in-package ,(package-name p)))) + (let (in out (*package* (find-package "LISP"))) + (dolist (v (package-shadowing-symbols p)) + (cond ((eq (symbol-package v) p) + (push v in)) + (t (push v out)))) + (pr `(shadow ',in)) + (pr `(shadowing-import ',out)) + (let (imp) + (do-symbols (v p) + (cond ((not (eq (symbol-package v) p)) + (push v imp)))) + (pr `(import ',imp)))))))))) diff --git a/cmpnew/gcl_fasdmacros.lsp b/cmpnew/gcl_fasdmacros.lsp new file mode 100755 index 0000000..a041e99 --- /dev/null +++ b/cmpnew/gcl_fasdmacros.lsp @@ -0,0 +1,81 @@ + + +(defstruct (fasd (:type vector)) + stream + table + eof + direction + package + index + filepos + table_length + evald_forms ; list of forms eval'd. (load-time-eval) + ) + +(defvar *fasd-ops* +'( d_nil ;/* dnil: nil */ + d_eval_skip ; /* deval o1: evaluate o1 after reading it */ + d_delimiter ;/* occurs after d_listd_general and d_new_indexed_items */ + d_enter_vector ; /* d_enter_vector o1 o2 .. on d_delimiter make a cf_data with + ; this length. Used internally by gcl. Just make + ; an array in other lisps */ + d_cons ; /* d_cons o1 o2: (o1 . o2) */ + d_dot ; + d_list ;/* list* delimited by d_delimiter d_list,o1,o2, ... ,d_dot,on + ;for (o1 o2 . on) + ;or d_list,o1,o2, ... ,on,d_delimiter for (o1 o2 ... on) + ;*/ + d_list1 ;/* nil terminated length 1 d_list1o1 */ + d_list2 ; /* nil terminated length 2 */ + d_list3 + d_list4 + d_eval + d_short_symbol + d_short_string + d_short_fixnum + d_short_symbol_and_package + d_bignum + d_fixnum + d_string + d_objnull + d_structure + d_package + d_symbol + d_symbol_and_package + d_end_of_file + d_standard_character + d_vector + d_array + d_begin_dump + d_general_type + d_sharp_equals ; /* define a sharp */ + d_sharp_value + d_sharp_value2 + d_new_indexed_item + d_new_indexed_items + d_reset_index + d_macro + d_reserve1 + d_reserve2 + d_reserve3 + d_reserve4 + d_indexed_item3 ; /* d_indexed_item3 followed by 3bytes to give index */ + d_indexed_item2 ; /* d_indexed_item2 followed by 2bytes to give index */ + d_indexed_item1 + d_indexed_item0 ; /* This must occur last ! */ +)) + +(defmacro put-op (op str) + `(write-byte ,(or (position op *fasd-ops*) + (error "illegal op")) ,str)) + +(defmacro put2 (n str) + `(progn (write-bytei ,n 0 ,str) + (write-bytei ,n 1 ,str))) + +(defmacro write-bytei (n i str) + `(write-byte (the fixnum (ash (the fixnum ,n) >> ,(* i 8))) ,str)) + + +(provide 'FASDMACROS) + diff --git a/cmpnew/gcl_init.lsp b/cmpnew/gcl_init.lsp new file mode 100755 index 0000000..26b96d9 --- /dev/null +++ b/cmpnew/gcl_init.lsp @@ -0,0 +1,4 @@ +(defun lcs1 (file) + (compile-file file + :c-file t :h-file t :data-file t :ob-file t + :system-p t)) diff --git a/cmpnew/gcl_lfun_list.lsp b/cmpnew/gcl_lfun_list.lsp new file mode 100755 index 0000000..f84ffcf --- /dev/null +++ b/cmpnew/gcl_lfun_list.lsp @@ -0,0 +1,462 @@ + +;; Modified data base including return values types +;; and making the arglists correct if they have optional args. +;; + +(in-package 'compiler) + +(DEFSYSFUN 'GENSYM "Lgensym" '(*) 'T NIL NIL) +(DEFSYSFUN 'SUBSEQ "Lsubseq" '(T T *) 'T NIL NIL) +(DEFSYSFUN 'MINUSP "Lminusp" '(T) 'T NIL T) +(DEFSYSFUN 'INTEGER-DECODE-FLOAT "Linteger_decode_float" '(T) + '(VALUES T T T) NIL NIL) +(DEFSYSFUN '- "Lminus" '(T *) 'T NIL NIL) +(DEFSYSFUN 'INT-CHAR "Lint_char" '(T) 'CHARACTER NIL NIL) +(DEFSYSFUN 'CHAR-INT "Lchar_int" '(T) 'FIXNUM NIL NIL) +(DEFSYSFUN '/= "Lall_different" '(T *) 'T NIL T) +(DEFSYSFUN 'COPY-SEQ "Lcopy_seq" '(T) 'T NIL NIL) +(DEFSYSFUN 'KEYWORDP "Lkeywordp" '(T) 'T NIL T) +(DEFSYSFUN 'NAME-CHAR "Lname_char" '(T) 'CHARACTER NIL NIL) +(DEFSYSFUN 'CHAR-NAME "Lchar_name" '(T) 'T NIL NIL) +(DEFSYSFUN 'RASSOC-IF "Lrassoc_if" '(T T) 'T NIL NIL) +(DEFSYSFUN 'MAKE-LIST "Lmake_list" '(T *) 'T NIL NIL) +(DEFSYSFUN 'HOST-NAMESTRING "Lhost_namestring" '(T) 'STRING NIL NIL) +(DEFSYSFUN 'MAKE-ECHO-STREAM "Lmake_echo_stream" '(T T) 'T NIL NIL) +;(DEFSYSFUN 'NTH "Lnth" '(T T) 'T NIL NIL) +(DEFSYSFUN 'SIN "Lsin" '(T) 'T NIL NIL) +(DEFSYSFUN 'NUMERATOR "Lnumerator" '(T) 'T NIL NIL) +(DEFSYSFUN 'ARRAY-RANK "Larray_rank" '(T) 'FIXNUM NIL NIL) +(DEFSYSFUN 'CAAR "Lcaar" '(T) 'T NIL NIL) +;#-clcs (DEFSYSFUN 'LOAD "Lload" '(T *) 'T NIL NIL) +;#-clcs (DEFSYSFUN 'OPEN "Lopen" '(T *) 'T NIL NIL) +(DEFSYSFUN 'BOTH-CASE-P "Lboth_case_p" '(T) 'T NIL T) +(DEFSYSFUN 'NULL "Lnull" '(T) 'T NIL T) +(DEFSYSFUN 'RENAME-FILE "Lrename_file" '(T T) 'T NIL NIL) +(DEFSYSFUN 'FILE-AUTHOR "Lfile_author" '(T) 'T NIL NIL) +(DEFSYSFUN 'STRING-CAPITALIZE "Lstring_capitalize" '(T *) 'STRING NIL + NIL) +(DEFSYSFUN 'MACROEXPAND "Lmacroexpand" '(T *) '(VALUES T T) NIL NIL) +(DEFSYSFUN 'NCONC "Lnconc" '(*) 'T NIL NIL) +(DEFSYSFUN 'BOOLE "Lboole" '(T T T) 'T NIL NIL) +(DEFSYSFUN 'TAILP "Ltailp" '(T T) 'T NIL T) +(DEFSYSFUN 'CONSP "Lconsp" '(T) 'T NIL T) +(DEFSYSFUN 'LISTP "Llistp" '(T) 'T NIL T) +(DEFSYSFUN 'MAPCAN "Lmapcan" '(T T *) 'T NIL NIL) +(DEFSYSFUN 'LENGTH "Llength" '(T) 'FIXNUM T NIL) +(DEFSYSFUN 'RASSOC "Lrassoc" '(T T *) 'T NIL NIL) +(DEFSYSFUN 'PPRINT "Lpprint" '(T *) 'T NIL NIL) +(DEFSYSFUN 'PATHNAME-HOST "Lpathname_host" '(T) 'T NIL NIL) +(DEFSYSFUN 'NSUBST-IF-NOT "Lnsubst_if_not" '(T T T *) 'T NIL NIL) +(DEFSYSFUN 'FILE-POSITION "Lfile_position" '(T *) 'T NIL NIL) +(DEFSYSFUN 'STRING< "Lstring_l" '(T T *) 'T NIL NIL) +(DEFSYSFUN 'REVERSE "Lreverse" '(T) 'T NIL NIL) +(DEFSYSFUN 'STREAMP "Lstreamp" '(T) 'T NIL T) +(DEFSYSFUN 'SYSTEM::PUTPROP "siLputprop" '(T T T) 'T NIL NIL) +(DEFSYSFUN 'REMPROP "Lremprop" '(T T) 'T NIL NIL) +(DEFSYSFUN 'SYMBOL-PACKAGE "Lsymbol_package" '(T) 'T NIL NIL) +(DEFSYSFUN 'NSTRING-UPCASE "Lnstring_upcase" '(T *) 'STRING NIL NIL) +(DEFSYSFUN 'STRING>= "Lstring_ge" '(T T *) 'T NIL NIL) +(DEFSYSFUN 'REALPART "Lrealpart" '(T) 'T NIL NIL) +;;broken on suns.. +;(DEFSYSFUN 'USER-HOMEDIR-PATHNAME "Luser_homedir_pathname" '(*) 'T NIL +; NIL) +(DEFSYSFUN 'NBUTLAST "Lnbutlast" '(T *) 'T NIL NIL) +(DEFSYSFUN 'ARRAY-DIMENSION "Larray_dimension" '(T T) 'FIXNUM NIL NIL) +(DEFSYSFUN 'CDR "Lcdr" '(T) 'T NIL NIL) +;(DEFSYSFUN 'EQL "Leql" '(T T) 'T NIL T) +(DEFSYSFUN 'LOG "Llog" '(T *) 'T NIL NIL) +(DEFSYSFUN 'DIRECTORY "Ldirectory" '(T) 'T NIL NIL) +(DEFSYSFUN 'STRING-NOT-EQUAL "Lstring_not_equal" '(T T *) 'T NIL NIL) +(DEFSYSFUN 'SHADOWING-IMPORT "Lshadowing_import" '(T *) 'T NIL NIL) +(DEFSYSFUN 'MAPC "Lmapc" '(T T *) 'T NIL NIL) +(DEFSYSFUN 'MAPL "Lmapl" '(T T *) 'T NIL NIL) +(DEFSYSFUN 'MAKUNBOUND "Lmakunbound" '(T) 'T NIL NIL) +(DEFSYSFUN 'CONS "Lcons" '(T T) 'T NIL NIL) +(DEFSYSFUN 'LIST "Llist" '(*) 'T NIL NIL) +(DEFSYSFUN 'USE-PACKAGE "Luse_package" '(T *) 'T NIL NIL) +(DEFSYSFUN 'FILE-LENGTH "Lfile_length" '(T) 'T NIL NIL) +(DEFSYSFUN 'MAKE-SYMBOL "Lmake_symbol" '(T) 'T NIL NIL) +(DEFSYSFUN 'STRING-RIGHT-TRIM "Lstring_right_trim" '(T T) 'STRING NIL + NIL) +(DEFSYSFUN 'ENOUGH-NAMESTRING "Lenough_namestring" '(T *) 'STRING NIL + NIL) +(DEFSYSFUN 'PRINT "Lprint" '(T *) 'T NIL NIL) +(DEFSYSFUN 'CDDAAR "Lcddaar" '(T) 'T NIL NIL) +(DEFSYSFUN 'CDADAR "Lcdadar" '(T) 'T NIL NIL) +(DEFSYSFUN 'CDAADR "Lcdaadr" '(T) 'T NIL NIL) +(DEFSYSFUN 'CADDAR "Lcaddar" '(T) 'T NIL NIL) +(DEFSYSFUN 'CADADR "Lcadadr" '(T) 'T NIL NIL) +(DEFSYSFUN 'CAADDR "Lcaaddr" '(T) 'T NIL NIL) +(DEFSYSFUN 'SET-MACRO-CHARACTER "Lset_macro_character" '(T T *) 'T NIL + NIL) +(DEFSYSFUN 'FORCE-OUTPUT "Lforce_output" '(*) 'T NIL NIL) +;(DEFSYSFUN 'NTHCDR "Lnthcdr" '(T T) 'T NIL NIL) +(DEFSYSFUN 'LOGIOR "Llogior" '(*) 'T NIL NIL) +(DEFSYSFUN 'CHAR-DOWNCASE "Lchar_downcase" '(T) 'CHARACTER NIL NIL) +(DEFSYSFUN 'STRING-CHAR-P "Lstring_char_p" '(T) 'T NIL T) +(DEFSYSFUN 'STREAM-ELEMENT-TYPE "Lstream_element_type" '(T) 'T NIL NIL) +(DEFSYSFUN 'PACKAGE-USED-BY-LIST "Lpackage_used_by_list" '(T) 'T NIL + NIL) +(DEFSYSFUN '/ "Ldivide" '(T *) 'T NIL NIL) +(DEFSYSFUN 'MAPHASH "Lmaphash" '(T T) 'T NIL NIL) +(DEFSYSFUN 'STRING= "Lstring_eq" '(T T *) 'T NIL T) +(DEFSYSFUN 'PAIRLIS "Lpairlis" '(T T *) 'T NIL NIL) +(DEFSYSFUN 'SYMBOLP "Lsymbolp" '(T) 'T NIL T) +(DEFSYSFUN 'CHAR-NOT-LESSP "Lchar_not_lessp" '(T *) 'T NIL T) +(DEFSYSFUN '1+ "Lone_plus" '(T) 'T NIL NIL) +(DEFSYSFUN 'BY "Lby" 'NIL 'T NIL NIL) +(DEFSYSFUN 'NSUBST-IF "Lnsubst_if" '(T T T *) 'T NIL NIL) +(DEFSYSFUN 'COPY-LIST "Lcopy_list" '(T) 'T NIL NIL) +(DEFSYSFUN 'TAN "Ltan" '(T) 'T NIL NIL) +(DEFSYSFUN 'SET "Lset" '(T T) 'T NIL NIL) +(DEFSYSFUN 'FUNCTIONP "Lfunctionp" '(T) 'T NIL T) +(DEFSYSFUN 'WRITE-BYTE "Lwrite_byte" '(T T) 'T NIL NIL) +(DEFSYSFUN 'LAST "Llast" '(T *) 'T NIL NIL) +(DEFSYSFUN 'MAKE-STRING "Lmake_string" '(T *) 'STRING NIL NIL) +(DEFSYSFUN 'CAAAR "Lcaaar" '(T) 'T NIL NIL) +(DEFSYSFUN 'LIST-LENGTH "Llist_length" '(T) 'T NIL NIL) +(DEFSYSFUN 'CDDDR "Lcdddr" '(T) 'T NIL NIL) +(DEFSYSFUN 'PRIN1 "Lprin1" '(T *) 'T NIL NIL) +(DEFSYSFUN 'PRINC "Lprinc" '(T *) 'T NIL NIL) +(DEFSYSFUN 'LOWER-CASE-P "Llower_case_p" '(T) 'T NIL T) +(DEFSYSFUN 'CHAR<= "Lchar_le" '(T *) 'T NIL T) +(DEFSYSFUN 'STRING-EQUAL "Lstring_equal" '(T T *) 'T NIL T) +(DEFSYSFUN 'CLEAR-OUTPUT "Lclear_output" '(*) 'T NIL NIL) +#-clcs (DEFSYSFUN 'CERROR "Lcerror" '(T T *) 'T NIL NIL) +(DEFSYSFUN 'TERPRI "Lterpri" '(*) 'T NIL NIL) +(DEFSYSFUN 'NSUBST "Lnsubst" '(T T T *) 'T NIL NIL) +(DEFSYSFUN 'UNUSE-PACKAGE "Lunuse_package" '(T *) 'T NIL NIL) +(DEFSYSFUN 'STRING-NOT-GREATERP "Lstring_not_greaterp" '(T T *) 'T NIL NIL) +(DEFSYSFUN 'STRING> "Lstring_g" '(T T *) 'T NIL NIL) +(DEFSYSFUN 'FINISH-OUTPUT "Lfinish_output" '(*) 'T NIL NIL) +(DEFSYSFUN 'SPECIAL-FORM-P "Lspecial_form_p" '(T) 'T NIL T) +(DEFSYSFUN 'STRINGP "Lstringp" '(T) 'T NIL T) +(DEFSYSFUN 'GET-INTERNAL-RUN-TIME "Lget_internal_run_time" 'NIL 'T NIL + NIL) +(DEFSYSFUN 'TRUNCATE "Ltruncate" '(T *) '(VALUES T T) NIL NIL) +(DEFSYSFUN 'CODE-CHAR "Lcode_char" '(T *) 'CHARACTER NIL NIL) +(DEFSYSFUN 'CHAR-CODE "Lchar_code" '(T) 'FIXNUM NIL NIL) +(DEFSYSFUN 'SIMPLE-STRING-P "Lsimple_string_p" '(T) 'T NIL T) +(DEFSYSFUN 'REVAPPEND "Lrevappend" '(T T) 'T NIL NIL) +(DEFSYSFUN 'HASH-TABLE-COUNT "Lhash_table_count" '(T) 'T NIL NIL) +(DEFSYSFUN 'PACKAGE-USE-LIST "Lpackage_use_list" '(T) 'T NIL NIL) +(DEFSYSFUN 'REM "Lrem" '(T T) 'T NIL NIL) +(DEFSYSFUN 'MIN "Lmin" '(T *) 'T NIL NIL) +(DEFSYSFUN 'APPLYHOOK "Lapplyhook" '(T T T T *) 'T NIL NIL) +(DEFSYSFUN 'EXP "Lexp" '(T) 'T NIL NIL) +(DEFSYSFUN 'CHAR-LESSP "Lchar_lessp" '(T *) 'T NIL T) +(DEFSYSFUN 'CDAR "Lcdar" '(T) 'T NIL NIL) +(DEFSYSFUN 'CADR "Lcadr" '(T) 'T NIL NIL) +(DEFSYSFUN 'LIST-ALL-PACKAGES "Llist_all_packages" 'NIL 'T NIL NIL) +(DEFSYSFUN 'REST "Lcdr" '(T) 'T NIL NIL) +(DEFSYSFUN 'COPY-SYMBOL "Lcopy_symbol" '(T *) 'T NIL NIL) +(DEFSYSFUN 'ACONS "Lacons" '(T T T) 'T NIL NIL) +(DEFSYSFUN 'ADJUSTABLE-ARRAY-P "Ladjustable_array_p" '(T) 'T NIL T) +(DEFSYSFUN 'SVREF "Lsvref" '(T T) 'T NIL NIL) +(DEFSYSFUN 'APPLY "Lapply" '(T T *) 'T NIL NIL) +(DEFSYSFUN 'DECODE-FLOAT "Ldecode_float" '(T) '(VALUES T T T) NIL NIL) +(DEFSYSFUN 'SUBST-IF-NOT "Lsubst_if_not" '(T T T *) 'T NIL NIL) +(DEFSYSFUN 'RPLACA "Lrplaca" '(T T) 'T NIL NIL) +(DEFSYSFUN 'SYMBOL-PLIST "Lsymbol_plist" '(T) 'T NIL NIL) +(DEFSYSFUN 'WRITE-STRING "Lwrite_string" '(T *) 'T NIL NIL) +(DEFSYSFUN 'LOGEQV "Llogeqv" '(*) 'T NIL NIL) +(DEFSYSFUN 'STRING "Lstring" '(T) 'STRING NIL NIL) +(DEFSYSFUN 'STRING-UPCASE "Lstring_upcase" '(T *) 'STRING NIL NIL) +(DEFSYSFUN 'CEILING "Lceiling" '(T *) '(VALUES T T) NIL NIL) +;(DEFSYSFUN 'GETHASH "Lgethash" '(T T *) '(VALUES T T) NIL NIL) +(DEFSYSFUN 'TYPE-OF "Ltype_of" '(T) 'T NIL NIL) +(DEFSYSFUN 'BUTLAST "Lbutlast" '(T *) 'T NIL NIL) +(DEFSYSFUN '1- "Lone_minus" '(T) 'T NIL NIL) +(DEFSYSFUN 'MAKE-HASH-TABLE "Lmake_hash_table" '(*) 'T NIL NIL) +(DEFSYSFUN 'STRING/= "Lstring_neq" '(T T *) 'T NIL NIL) +(DEFSYSFUN '<= "Lmonotonically_nondecreasing" '(T *) 'T NIL T) +(DEFSYSFUN 'MAKE-BROADCAST-STREAM "Lmake_broadcast_stream" '(*) 'T NIL + NIL) +(DEFSYSFUN 'IMAGPART "Limagpart" '(T) 'T NIL NIL) +(DEFSYSFUN 'INTEGERP "Lintegerp" '(T) 'T NIL T) +(DEFSYSFUN 'READ-CHAR "Lread_char" '(*) 'T NIL NIL) +(DEFSYSFUN 'PEEK-CHAR "Lpeek_char" '(*) 'T NIL NIL) +(DEFSYSFUN 'CHAR-FONT "Lchar_font" '(T) 'FIXNUM NIL NIL) +(DEFSYSFUN 'STRING-GREATERP "Lstring_greaterp" '(T T *) 'T NIL NIL) +(DEFSYSFUN 'OUTPUT-STREAM-P "Loutput_stream_p" '(T) 'T NIL T) +(DEFSYSFUN 'ASH "Lash" '(T T) 'T NIL NIL) +(DEFSYSFUN 'LCM "Llcm" '(T *) 'T NIL NIL) +(DEFSYSFUN 'ELT "Lelt" '(T T) 'T NIL NIL) +(DEFSYSFUN 'COS "Lcos" '(T) 'T NIL NIL) +(DEFSYSFUN 'NSTRING-DOWNCASE "Lnstring_downcase" '(T *) 'STRING NIL + NIL) +(DEFSYSFUN 'COPY-ALIST "Lcopy_alist" '(T) 'T NIL NIL) +(DEFSYSFUN 'ATAN "Latan" '(T *) 'T NIL NIL) +(DEFSYSFUN 'DELETE-FILE "Ldelete_file" '(T) 'T NIL NIL) +(DEFSYSFUN 'FLOAT-RADIX "Lfloat_radix" '(T) 'FIXNUM NIL NIL) +(DEFSYSFUN 'SYMBOL-NAME "Lsymbol_name" '(T) 'STRING NIL NIL) +(DEFSYSFUN 'CLEAR-INPUT "Lclear_input" '(*) 'T NIL NIL) +(DEFSYSFUN 'FIND-SYMBOL "Lfind_symbol" '(T *) '(VALUES T T) NIL NIL) +(DEFSYSFUN 'CHAR< "Lchar_l" '(T *) 'T NIL T) +(DEFSYSFUN 'HASH-TABLE-P "Lhash_table_p" '(T) 'T NIL T) +(DEFSYSFUN 'EVENP "Levenp" '(T) 'T NIL T) +(DEFSYSFUN 'SYSTEM::CMOD "siLcmod" '(T) 'T NIL T) +(DEFSYSFUN 'SYSTEM::CPLUS "siLcplus" '(T T) 'T NIL T) +(DEFSYSFUN 'SYSTEM::CTIMES "siLctimes" '(T T) 'T NIL T) +(DEFSYSFUN 'SYSTEM::CDIFFERENCE "siLcdifference" '(T T) 'T NIL T) +(DEFSYSFUN 'ZEROP "Lzerop" '(T) 'T NIL T) +(DEFSYSFUN 'CAAAAR "Lcaaaar" '(T) 'T NIL NIL) +(DEFSYSFUN 'CHAR>= "Lchar_ge" '(T *) 'T NIL T) +(DEFSYSFUN 'CDDDAR "Lcdddar" '(T) 'T NIL NIL) +(DEFSYSFUN 'CDDADR "Lcddadr" '(T) 'T NIL NIL) +(DEFSYSFUN 'CDADDR "Lcdaddr" '(T) 'T NIL NIL) +(DEFSYSFUN 'CADDDR "Lcadddr" '(T) 'T NIL NIL) +(DEFSYSFUN 'FILL-POINTER "Lfill_pointer" '(T) 'FIXNUM NIL NIL) +(DEFSYSFUN 'MAPCAR "Lmapcar" '(T T *) 'T NIL NIL) +(DEFSYSFUN 'FLOATP "Lfloatp" '(T) 'T NIL T) +(DEFSYSFUN 'SHADOW "Lshadow" '(T *) 'T NIL NIL) +(DEFSYSFUN 'MACROEXPAND-1 "Lmacroexpand_1" '(T *) '(VALUES T T) NIL + NIL) +(DEFSYSFUN 'SXHASH "Lsxhash" '(T) 'FIXNUM NIL NIL) +(DEFSYSFUN 'LISTEN "Llisten" '(*) 'T NIL NIL) +(DEFSYSFUN 'ARRAYP "Larrayp" '(T) 'T NIL T) +(DEFSYSFUN 'MAKE-PATHNAME "Lmake_pathname" '(*) 'T NIL NIL) +(DEFSYSFUN 'PATHNAME-TYPE "Lpathname_type" '(T) 'T NIL NIL) +(DEFSYSFUN 'FUNCALL "Lfuncall" '(T *) 'T NIL NIL) +(DEFSYSFUN 'CLRHASH "Lclrhash" '(T) 'T NIL NIL) +(DEFSYSFUN 'GRAPHIC-CHAR-P "Lgraphic_char_p" '(T) 'T NIL T) +(DEFSYSFUN 'FBOUNDP "Lfboundp" '(T) 'T NIL T) +(DEFSYSFUN 'NSUBLIS "Lnsublis" '(T T *) 'T NIL NIL) +(DEFSYSFUN 'CHAR-NOT-EQUAL "Lchar_not_equal" '(T *) 'T NIL T) +(DEFSYSFUN 'MACRO-FUNCTION "Lmacro_function" '(T) 'T NIL NIL) +(DEFSYSFUN 'SUBST-IF "Lsubst_if" '(T T T *) 'T NIL NIL) +(DEFSYSFUN 'COMPLEXP "Lcomplexp" '(T) 'T NIL T) +(DEFSYSFUN 'READ-LINE "Lread_line" '(*) '(VALUES T T) NIL NIL) +(DEFSYSFUN 'PATHNAMEP "Lpathnamep" '(T) 'T NIL T) +(DEFSYSFUN 'MAX "Lmax" '(T *) 'T NIL NIL) +(DEFSYSFUN 'IN-PACKAGE "Lin_package" '(T *) 'T NIL NIL) +(DEFSYSFUN 'READTABLEP "Lreadtablep" '(T) 'T NIL T) +(DEFSYSFUN 'FLOAT-SIGN "Lfloat_sign" '(T *) 'T NIL NIL) +(DEFSYSFUN 'CHARACTERP "Lcharacterp" '(T) 'T NIL T) +(DEFSYSFUN 'READ "Lread" '(*) 'T NIL NIL) +(DEFSYSFUN 'NAMESTRING "Lnamestring" '(T) 'T NIL NIL) +(DEFSYSFUN 'UNREAD-CHAR "Lunread_char" '(T *) 'T NIL NIL) +(DEFSYSFUN 'CDAAR "Lcdaar" '(T) 'T NIL NIL) +(DEFSYSFUN 'CADAR "Lcadar" '(T) 'T NIL NIL) +(DEFSYSFUN 'CAADR "Lcaadr" '(T) 'T NIL NIL) +(DEFSYSFUN 'CHAR= "Lchar_eq" '(T *) 'T NIL T) +(DEFSYSFUN 'ALPHA-CHAR-P "Lalpha_char_p" '(T) 'T NIL T) +(DEFSYSFUN 'STRING-TRIM "Lstring_trim" '(T T) 'STRING NIL NIL) +(DEFSYSFUN 'MAKE-PACKAGE "Lmake_package" '(T *) 'T NIL NIL) +(DEFSYSFUN 'CLOSE "Lclose" '(T *) 'T NIL NIL) +(DEFSYSFUN 'DENOMINATOR "Ldenominator" '(T) 'T NIL NIL) +(DEFSYSFUN 'FLOAT "Lfloat" '(T *) 'T NIL NIL) +;(DEFSYSFUN 'FIRST "Lcar" '(T) 'T NIL NIL) +(DEFSYSFUN 'ROUND "Lround" '(T *) '(VALUES T T) NIL NIL) +(DEFSYSFUN 'SUBST "Lsubst" '(T T T *) 'T NIL NIL) +(DEFSYSFUN 'UPPER-CASE-P "Lupper_case_p" '(T) 'T NIL T) +(DEFSYSFUN 'ARRAY-ELEMENT-TYPE "Larray_element_type" '(T) 'T NIL NIL) +(DEFSYSFUN 'ADJOIN "Ladjoin" '(T T *) 'T NIL NIL) +(DEFSYSFUN 'LOGAND "Llogand" '(*) 'T NIL NIL) +(DEFSYSFUN 'MAPCON "Lmapcon" '(T T *) 'T NIL NIL) +(DEFSYSFUN 'INTERN "Lintern" '(T *) '(VALUES T T) NIL NIL) +(DEFSYSFUN 'VALUES "Lvalues" '(*) '* NIL NIL) +(DEFSYSFUN 'EXPORT "Lexport" '(T *) 'T NIL NIL) +(DEFSYSFUN '* "Ltimes" '(*) 'T NIL NIL) +(DEFSYSFUN '< "Lmonotonically_increasing" '(T *) 'T NIL T) +(DEFSYSFUN 'COMPLEX "Lcomplex" '(T *) 'T NIL NIL) +(DEFSYSFUN 'SET-SYNTAX-FROM-CHAR "Lset_syntax_from_char" '(T T *) 'T + NIL NIL) +(DEFSYSFUN 'CHAR-BIT "Lchar_bit" '(T T) 'FIXNUM NIL NIL) +(DEFSYSFUN 'INTEGER-LENGTH "Linteger_length" '(T) 'FIXNUM NIL NIL) +(DEFSYSFUN 'PACKAGEP "Lpackagep" '(T) 'T NIL T) +(DEFSYSFUN 'INPUT-STREAM-P "Linput_stream_p" '(T) 'T NIL T) +(DEFSYSFUN '>= "Lmonotonically_nonincreasing" '(T *) 'T NIL T) +(DEFSYSFUN 'PATHNAME "Lpathname" '(T) 'T NIL NIL) +;(DEFSYSFUN 'EQ "Leq" '(T T) 'T NIL T) +(DEFSYSFUN 'MAKE-CHAR "Lmake_char" '(T *) 'CHARACTER NIL NIL) +(DEFSYSFUN 'FILE-NAMESTRING "Lfile_namestring" '(T) 'STRING NIL NIL) +(DEFSYSFUN 'CHARACTER "Lcharacter" '(T) 'CHARACTER NIL NIL) +(DEFSYSFUN 'SYMBOL-FUNCTION "Lsymbol_function" '(T) 'T NIL NIL) +(DEFSYSFUN 'CONSTANTP "Lconstantp" '(T) 'T NIL T) +(DEFSYSFUN 'CHAR-EQUAL "Lchar_equal" '(T *) 'T NIL T) +(DEFSYSFUN 'TREE-EQUAL "Ltree_equal" '(T T *) 'T NIL T) +(DEFSYSFUN 'CDDR "Lcddr" '(T) 'T NIL NIL) +(DEFSYSFUN 'GETF "Lgetf" '(T T *) 'T NIL NIL) +(DEFSYSFUN 'SAVE "Lsave" '(T) 'T NIL NIL) +(DEFSYSFUN 'MAKE-RANDOM-STATE "Lmake_random_state" '(*) 'T NIL NIL) +(DEFSYSFUN 'CHAR-NOT-GREATERP "Lchar_not_greaterp" '(T *) 'T NIL T) +(DEFSYSFUN 'EXPT "Lexpt" '(T T) 'T NIL NIL) +(DEFSYSFUN 'SQRT "Lsqrt" '(T) 'T NIL NIL) +(DEFSYSFUN 'SCALE-FLOAT "Lscale_float" '(T T) 'T NIL NIL) +(DEFSYSFUN 'CHAR> "Lchar_g" '(T *) 'T NIL T) +(DEFSYSFUN 'LDIFF "Lldiff" '(T T) 'T NIL NIL) +(DEFSYSFUN 'ASSOC-IF-NOT "Lassoc_if_not" '(T T) 'T NIL NIL) +(DEFSYSFUN 'BIT-VECTOR-P "Lbit_vector_p" '(T) 'T NIL T) +(DEFSYSFUN 'NSTRING-CAPITALIZE "Lnstring_capitalize" '(T *) 'STRING NIL + NIL) +(DEFSYSFUN 'SYMBOL-VALUE "Lsymbol_value" '(T) 'T NIL NIL) +(DEFSYSFUN 'RPLACD "Lrplacd" '(T T) 'T NIL NIL) +(DEFSYSFUN 'BOUNDP "Lboundp" '(T) 'T NIL T) +;(DEFSYSFUN 'EQUALP "Lequalp" '(T T) 'T NIL T) +(DEFSYSFUN 'SIMPLE-BIT-VECTOR-P "Lsimple_bit_vector_p" '(T) 'T NIL T) +(DEFSYSFUN 'MEMBER-IF-NOT "Lmember_if_not" '(T T *) 'T NIL NIL) +(DEFSYSFUN 'MAKE-TWO-WAY-STREAM "Lmake_two_way_stream" '(T T) 'T NIL + NIL) +(DEFSYSFUN 'PARSE-INTEGER "Lparse_integer" '(T *) 'T NIL NIL) +(DEFSYSFUN '+ "Lplus" '(*) 'T NIL NIL) +(DEFSYSFUN '= "Lall_the_same" '(T *) 'T NIL T) +(DEFSYSFUN 'GENTEMP "Lgentemp" '(*) 'T NIL NIL) +(DEFSYSFUN 'RENAME-PACKAGE "Lrename_package" '(T T *) 'T NIL NIL) +(DEFSYSFUN 'COMMONP "Lcommonp" '(T) 'T NIL T) +(DEFSYSFUN 'NUMBERP "Lnumberp" '(T) 'T NIL T) +(DEFSYSFUN 'COPY-READTABLE "Lcopy_readtable" '(*) 'T NIL NIL) +(DEFSYSFUN 'RANDOM-STATE-P "Lrandom_state_p" '(T) 'T NIL T) +(DEFSYSFUN 'DIRECTORY-NAMESTRING "Ldirectory_namestring" '(T) 'STRING + NIL NIL) +(DEFSYSFUN 'STANDARD-CHAR-P "Lstandard_char_p" '(T) 'T NIL T) +(DEFSYSFUN 'TRUENAME "Ltruename" '(T) 'T NIL NIL) +(DEFSYSFUN 'IDENTITY "Lidentity" '(T) 'T NIL NIL) +(DEFSYSFUN 'NREVERSE "Lnreverse" '(T) 'T NIL NIL) +(DEFSYSFUN 'PATHNAME-DEVICE "Lpathname_device" '(T) 'T NIL NIL) +(DEFSYSFUN 'UNINTERN "Lunintern" '(T *) 'T NIL NIL) +(DEFSYSFUN 'UNEXPORT "Lunexport" '(T *) 'T NIL NIL) +(DEFSYSFUN 'FLOAT-PRECISION "Lfloat_precision" '(T) 'FIXNUM NIL NIL) +(DEFSYSFUN 'STRING-DOWNCASE "Lstring_downcase" '(T *) 'STRING NIL NIL) +(DEFSYSFUN 'CAR "Lcar" '(T) 'T NIL NIL) +(DEFSYSFUN 'CONJUGATE "Lconjugate" '(T) 'T NIL NIL) +(DEFSYSFUN 'NOT "Lnull" '(T) 'T NIL T) +(DEFSYSFUN 'READ-CHAR-NO-HANG "Lread_char_no_hang" '(*) 'T NIL NIL) +(DEFSYSFUN 'FRESH-LINE "Lfresh_line" '(*) 'T NIL NIL) +(DEFSYSFUN 'WRITE-CHAR "Lwrite_char" '(T *) 'T NIL NIL) +(DEFSYSFUN 'PARSE-NAMESTRING "Lparse_namestring" '(T *) 'T NIL NIL) +(DEFSYSFUN 'STRING-NOT-LESSP "Lstring_not_lessp" '(T T *) 'T NIL NIL) +(DEFSYSFUN 'CHAR "Lchar" '(T T) 'CHARACTER NIL NIL) +(DEFSYSFUN 'AREF "Laref" '(T *) 'T NIL NIL) +(DEFSYSFUN 'PACKAGE-NICKNAMES "Lpackage_nicknames" '(T) 'T NIL NIL) +(DEFSYSFUN 'ENDP "Lendp" '(T) 'T NIL T) +(DEFSYSFUN 'ODDP "Loddp" '(T) 'T NIL T) +(DEFSYSFUN 'CHAR-UPCASE "Lchar_upcase" '(T) 'CHARACTER NIL NIL) +(DEFSYSFUN 'LIST* "LlistA" '(T *) 'T NIL NIL) +(DEFSYSFUN 'VALUES-LIST "Lvalues_list" '(T) '* NIL NIL) +;(DEFSYSFUN 'EQUAL "Lequal" '(T T) 'T NIL T) +(DEFSYSFUN 'DIGIT-CHAR-P "Ldigit_char_p" '(T *) 'T NIL NIL) +;; #-clcs (DEFSYSFUN 'ERROR "Lerror" '(T *) 'T NIL NIL) +(DEFSYSFUN 'CHAR/= "Lchar_neq" '(T *) 'T NIL T) +(DEFSYSFUN 'PATHNAME-DIRECTORY "Lpathname_directory" '(T) 'T NIL NIL) +(DEFSYSFUN 'CDAAAR "Lcdaaar" '(T) 'T NIL NIL) +(DEFSYSFUN 'CADAAR "Lcadaar" '(T) 'T NIL NIL) +(DEFSYSFUN 'CAADAR "Lcaadar" '(T) 'T NIL NIL) +(DEFSYSFUN 'CAAADR "Lcaaadr" '(T) 'T NIL NIL) +(DEFSYSFUN 'CDDDDR "Lcddddr" '(T) 'T NIL NIL) +(DEFSYSFUN 'GET-MACRO-CHARACTER "Lget_macro_character" '(T *) 'T NIL + NIL) +(DEFSYSFUN 'FORMAT "Lformat" '(T T *) 'T NIL NIL) +(DEFSYSFUN 'COMPILED-FUNCTION-P "Lcompiled_function_p" '(T) 'T NIL T) +(DEFSYSFUN 'SUBLIS "Lsublis" '(T T *) 'T NIL NIL) +(DEFSYSFUN 'PATHNAME-NAME "Lpathname_name" '(T) 'T NIL NIL) +(DEFSYSFUN 'IMPORT "Limport" '(T *) 'T NIL NIL) +(DEFSYSFUN 'LOGXOR "Llogxor" '(*) 'T NIL NIL) +(DEFSYSFUN 'RASSOC-IF-NOT "Lrassoc_if_not" '(T T) 'T NIL NIL) +(DEFSYSFUN 'CHAR-GREATERP "Lchar_greaterp" '(T *) 'T NIL T) +(DEFSYSFUN 'MAKE-SYNONYM-STREAM "Lmake_synonym_stream" '(T) 'T NIL NIL) +(DEFSYSFUN 'ALPHANUMERICP "Lalphanumericp" '(T) 'T NIL T) +(DEFSYSFUN 'REMHASH "Lremhash" '(T T) 'T NIL NIL) +(DEFSYSFUN 'NRECONC "Lreconc" '(T T) 'T NIL NIL) +(DEFSYSFUN '> "Lmonotonically_decreasing" '(T *) 'T NIL T) +(DEFSYSFUN 'LOGBITP "Llogbitp" '(T T) 'T NIL T) +(DEFSYSFUN 'MAPLIST "Lmaplist" '(T T *) 'T NIL NIL) +(DEFSYSFUN 'VECTORP "Lvectorp" '(T) 'T NIL T) +(DEFSYSFUN 'ASSOC-IF "Lassoc_if" '(T T) 'T NIL NIL) +(DEFSYSFUN 'GET-PROPERTIES "Lget_properties" '(T T) '* NIL NIL) +(DEFSYSFUN 'STRING<= "Lstring_le" '(T T *) 'T NIL NIL) +(DEFSYSFUN 'EVALHOOK "Levalhook" '(T T T *) 'T NIL NIL) +(DEFSYSFUN 'FILE-WRITE-DATE "Lfile_write_date" '(T) 'T NIL NIL) +(DEFSYSFUN 'LOGCOUNT "Llogcount" '(T) 'T NIL NIL) +(DEFSYSFUN 'MERGE-PATHNAMES "Lmerge_pathnames" '(T *) 'T NIL NIL) +(DEFSYSFUN 'MEMBER-IF "Lmember_if" '(T T *) 'T NIL NIL) +(DEFSYSFUN 'READ-BYTE "Lread_byte" '(T *) 'T NIL NIL) +(DEFSYSFUN 'SIMPLE-VECTOR-P "Lsimple_vector_p" '(T) 'T NIL T) +(DEFSYSFUN 'CHAR-BITS "Lchar_bits" '(T) 'FIXNUM NIL NIL) +(DEFSYSFUN 'COPY-TREE "Lcopy_tree" '(T) 'T NIL NIL) +(DEFSYSFUN 'GCD "Lgcd" '(*) 'T NIL NIL) +(DEFSYSFUN 'BYE "Lby" 'NIL 'T NIL NIL) +;(DEFSYSFUN 'QUIT "Lquit" 'NIL 'T NIL NIL) +;(DEFSYSFUN 'EXIT "Lexit" 'NIL 'T NIL NIL) +(DEFSYSFUN 'GET "Lget" '(T T *) 'T NIL NIL) +(DEFSYSFUN 'MOD "Lmod" '(T T) 'T NIL NIL) +(DEFSYSFUN 'DIGIT-CHAR "Ldigit_char" '(T *) 'CHARACTER NIL NIL) +(DEFSYSFUN 'PROBE-FILE "Lprobe_file" '(T) 'T NIL NIL) +(DEFSYSFUN 'STRING-LEFT-TRIM "Lstring_left_trim" '(T T) 'STRING NIL + NIL) +(DEFSYSFUN 'PATHNAME-VERSION "Lpathname_version" '(T) 'T NIL NIL) +(DEFSYSFUN 'WRITE-LINE "Lwrite_line" '(T *) 'T NIL NIL) +(DEFSYSFUN 'EVAL "Leval" '(T) 'T NIL NIL) +(DEFSYSFUN 'ATOM "Latom" '(T) 'T NIL T) +(DEFSYSFUN 'CDDAR "Lcddar" '(T) 'T NIL NIL) +(DEFSYSFUN 'CDADR "Lcdadr" '(T) 'T NIL NIL) +(DEFSYSFUN 'CADDR "Lcaddr" '(T) 'T NIL NIL) +(DEFSYSFUN 'FMAKUNBOUND "Lfmakunbound" '(T) 'T NIL NIL) +(DEFSYSFUN 'SLEEP "Lsleep" '(T) 'T NIL NIL) +(DEFSYSFUN 'PACKAGE-NAME "Lpackage_name" '(T) 'T NIL NIL) +(DEFSYSFUN 'FIND-PACKAGE "Lfind_package" '(T) 'T NIL NIL) +(DEFSYSFUN 'ASSOC "Lassoc" '(T T *) 'T NIL NIL) +(DEFSYSFUN 'SET-CHAR-BIT "Lset_char_bit" '(T T T) 'CHARACTER NIL NIL) +(DEFSYSFUN 'FLOOR "Lfloor" '(T *) '(VALUES T T) NIL NIL) +(DEFSYSFUN 'WRITE "Lwrite" '(T *) 'T NIL NIL) +(DEFSYSFUN 'PLUSP "Lplusp" '(T) 'T NIL T) +(DEFSYSFUN 'FLOAT-DIGITS "Lfloat_digits" '(T) 'FIXNUM NIL NIL) +(DEFSYSFUN 'READ-DELIMITED-LIST "Lread_delimited_list" '(T *) 'T NIL + NIL) +(DEFSYSFUN 'APPEND "Lappend" '(*) 'T NIL NIL) +(DEFSYSFUN 'MEMBER "Lmember" '(T T *) 'T NIL NIL) +(DEFSYSFUN 'STRING-LESSP "Lstring_lessp" '(T T *) 'T NIL NIL) +(DEFSYSFUN 'RANDOM "Lrandom" '(T *) 'T NIL NIL) +(DEFSYSFUN 'SYSTEM::SPECIALP "siLspecialp" '(T) 'T NIL T) +(DEFSYSFUN 'SYSTEM::OUTPUT-STREAM-STRING "siLoutput_stream_string" '(T) + 'T NIL NIL) +;#-clcs (DEFSYSFUN 'SYSTEM::ERROR-SET "siLerror_set" '(T) '* NIL NIL) +(DEFSYSFUN 'SYSTEM::STRUCTUREP "siLstructurep" '(T) 'T NIL T) +(DEFSYSFUN 'SYSTEM::COPY-STREAM "siLcopy_stream" '(T T) 'T NIL NIL) +(DEFSYSFUN 'SYSTEM::INIT-SYSTEM "siLinit_system" 'NIL 'T NIL NIL) +(DEFSYSFUN 'SYSTEM::STRING-TO-OBJECT "siLstring_to_object" '(T) 'T NIL + NIL) +(DEFSYSFUN 'SYSTEM::RESET-STACK-LIMITS "siLreset_stack_limits" 'NIL 'T + NIL NIL) +(DEFSYSFUN 'SYSTEM::DISPLACED-ARRAY-P "siLdisplaced_array_p" '(T) 'T NIL + T) +(DEFSYSFUN 'SYSTEM::RPLACA-NTHCDR "siLrplaca_nthcdr" NIL T NIL NIL) +(DEFSYSFUN 'SYSTEM::LIST-NTH "siLlist_nth" NIL T NIL NIL) +;(DEFSYSFUN 'SYSTEM::MAKE-PURE-ARRAY "siLmake_pure_array" NIL T NIL NIL) +(DEFSYSFUN 'SYSTEM::MAKE-VECTOR "siLmake_vector" NIL 'VECTOR NIL NIL) +;(DEFSYSFUN 'SYSTEM::ARRAY-DISPLACEMENT "siLarray_displacement" NIL T NIL NIL) +(DEFSYSFUN 'SYSTEM::ASET "siLaset" '(ARRAY *) NIL NIL NIL) +(DEFSYSFUN 'SYSTEM::SVSET "siLsvset" '(SIMPLE-VECTOR FIXNUM T) T NIL + NIL) +(DEFSYSFUN 'SYSTEM::FILL-POINTER-SET "siLfill_pointer_set" + '(VECTOR FIXNUM) 'FIXNUM NIL NIL) +(DEFSYSFUN 'SYSTEM::REPLACE-ARRAY "siLreplace_array" NIL T NIL NIL) +(DEFSYSFUN 'SYSTEM::FSET "siLfset" '(SYMBOL T) NIL NIL NIL) +;(DEFSYSFUN 'SYSTEM::HASH-SET "siLhash_set" NIL T NIL NIL) +(DEFSYSFUN 'BOOLE3 "Lboole" NIL T NIL NIL) +(DEFSYSFUN 'SYSTEM::PACKAGE-INTERNAL "siLpackage_internal" NIL T NIL + NIL) +(DEFSYSFUN 'SYSTEM::PACKAGE-EXTERNAL "siLpackage_external" NIL T NIL + NIL) +(DEFSYSFUN 'SYSTEM::ELT-SET "siLelt_set" '(SEQUENCE FIXNUM T) T NIL NIL) +(DEFSYSFUN 'SYSTEM::CHAR-SET "siLchar_set" '(STRING FIXNUM CHARACTER) + 'CHARACTER NIL NIL) +(DEFSYSFUN 'SYSTEM::MAKE-STRUCTURE "siLmake_structure" NIL T NIL NIL) +(DEFSYSFUN 'SYSTEM::STRUCTURE-NAME "siLstructure_name" '(T) 'SYMBOL NIL + NIL) +;; (DEFSYSFUN 'SYSTEM::STRUCTURE-REF "siLstructure_ref" '(T T FIXNUM) T NIL +;; NIL) +;; (DEFSYSFUN 'SYSTEM::STRUCTURE-SET "siLstructure_set" '(T T FIXNUM T) T +;; NIL NIL) +(DEFSYSFUN 'SYSTEM::PUT-F "siLput_f" NIL '(T T) NIL NIL) +(DEFSYSFUN 'SYSTEM::REM-F "siLrem_f" NIL '(T T) NIL NIL) +(DEFSYSFUN 'SYSTEM::SET-SYMBOL-PLIST "siLset_symbol_plist" '(SYMBOL T) T + NIL NIL) +(DEFSYSFUN 'SI::BIT-ARRAY-OP "siLbit_array_op" NIL T NIL NIL) + +(dolist (l '(eq eql equal equalp ldb-test logtest)) + (setf (get l 'predicate) t)) + + + + diff --git a/cmpnew/gcl_make-fn.lsp b/cmpnew/gcl_make-fn.lsp new file mode 100755 index 0000000..ebff2c2 --- /dev/null +++ b/cmpnew/gcl_make-fn.lsp @@ -0,0 +1,4 @@ +(load (concatenate 'string si::*system-directory* "../cmpnew/gcl_collectfn")) +(compiler::emit-fn t) + + diff --git a/cmpnew/gcl_make_ufun.lsp b/cmpnew/gcl_make_ufun.lsp new file mode 100755 index 0000000..26bf132 --- /dev/null +++ b/cmpnew/gcl_make_ufun.lsp @@ -0,0 +1,86 @@ +;;; MAKE_UFUN Makes Ufun list for user-defined functions. +;;; +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + + +(in-package 'compiler) + +(defvar gazonk (make-package 'symbol-table :use nil)) +(defvar eof (cons nil nil)) +(defvar *Ufun-out*) + +(defvar *str* (make-array 128 :element-type 'string-char :fill-pointer 0)) + +(defun make-Ufun (in-files &key (out-file "Ufun_list.lsp")) + (with-open-file (*Ufun-out* out-file :direction :output) + (print '(in-package "COMPILER") *Ufun-out*) + (dolist (file in-files) + (with-open-file (in (merge-pathnames file #".lsp")) + (loop (when (eq (setq form (read in nil eof)) eof) (return)) + (do-form form)))))) + +(defun do-form (form) + (when (consp form) + (case (car form) + (defun + (let ((*package* (find-package 'compiler))) + (print `(si:putprop + ',(cadr form) + ,(get-cname (cadr form)) + 'Ufun) + *Ufun-out*)) + (eval form)) + (progn (mapc #'do-form (cdr form))) + (eval-when + (if (member 'load (cadr form)) + (mapc #'do-form (cddr form)) + (if (member 'compile (cadr form)) + (mapc #'eval (cddr form))))) + (t + (if (macro-function (car form)) + (do-form (macroexpand-1 form)) + (eval form)))))) + +(defun get-cname (symbol &aux (name (symbol-name symbol))) + (setf (fill-pointer *str*) 0) + (vector-push #\U *str*) + (dotimes (n (length name)) + (let ((char (schar name n))) + (cond ((alphanumericp char) + (vector-push (char-downcase char) *str*)) + ((char= char #\-) (vector-push #\_ *str*)) + ((char= char #\*) (vector-push #\A *str*)) + ))) + (multiple-value-bind (foo flag) (find-symbol *str* 'symbol-table) + (unless flag + ;(setq foo (intern (copy-seq *str*) 'symbol-table)) + (setq foo (intern *str* 'symbol-table)) + ;(set foo nil) + (return-from get-cname *str*)) + (gensym *str*) + (gensym 0) + (loop + (setq name (symbol-name (gensym))) + (multiple-value-bind (foo flag1) + (intern name 'symbol-table) + (unless flag1 + ;(set foo nil) + (return-from get-cname name))))) + ) diff --git a/cmpnew/gcl_nocmpinc.lsp b/cmpnew/gcl_nocmpinc.lsp new file mode 100755 index 0000000..20f1e84 --- /dev/null +++ b/cmpnew/gcl_nocmpinc.lsp @@ -0,0 +1,23 @@ + + +(in-package 'compiler) + +(defvar *cmpinclude-string* nil) + +(defun write-out-cmpinclude (stream string) + (do ((i 0 (setq i (the fixnum (+ i 1)))) + (l (length *cmpinclude-string*))) + ((>= i l)) + (declare (fixnum i l)) + (or string (setq string *cmpinclude-string*)) + (or string (error "need a string")) + (let ((tem (aref (the string string i)))) + (declare (character tem)) + (write-char tem stream)))) + + + + + + + \ No newline at end of file diff --git a/cmpnew/makefile b/cmpnew/makefile new file mode 100644 index 0000000..dcca963 --- /dev/null +++ b/cmpnew/makefile @@ -0,0 +1,66 @@ + +.SUFFIXES: +.SUFFIXES: .o .c .lsp .lisp .fn + +-include ../makedefs + +PORTDIR = ../unixport +CAT=cat +APPEND=../xbin/append + +OBJS = gcl_cmpbind.o gcl_cmpblock.o gcl_cmpcall.o gcl_cmpcatch.o gcl_cmpenv.o gcl_cmpeval.o \ + gcl_cmpflet.o gcl_cmpfun.o gcl_cmpif.o gcl_cmpinline.o gcl_cmplabel.o gcl_cmplam.o gcl_cmplet.o \ + gcl_cmploc.o gcl_cmpmap.o gcl_cmpmulti.o gcl_cmpspecial.o gcl_cmptag.o gcl_cmptop.o \ + gcl_cmptype.o gcl_cmputil.o gcl_cmpvar.o gcl_cmpvs.o gcl_cmpwt.o gcl_cmpmain.o #gcl_cmpopt.o gcl_lfun_list.o + +FNS:= $(OBJS:.o=.fn) + +LISP=$(PORTDIR)/saved_pre_gcl$(EXE) +COMPILE_FILE=$(LISP) $(PORTDIR) -system-p -c-file -data-file -h-file -compile + +%.o: $(PORTDIR)/saved_pre_gcl$(EXE) %.lsp + $(COMPILE_FILE) $* + +all: $(OBJS) + +.lsp.fn: ../cmpnew/gcl_collectfn.o + ../xbin/make-fn $*.lsp $(LISP) + +fns1: $(FNS) + +fns: ../cmpnew/gcl_collectfn.o + $(MAKE) fns1 -e "FNS=`echo ${OBJS} | sed -e 's:\.o:\.fn:g'`" + +gcl_collectfn.o: + $(PORTDIR)/saved_pre_gcl$(EXE) $(PORTDIR)/ -compile $*.lsp + +.lisp.o: + @ ../xbin/if-exists $(PORTDIR)/saved_pre_gcl$(EXE) \ + "$(PORTDIR)/saved_pre_gcl$(EXE) $(PORTDIR)/ -compile $*.lisp " + +sys-proclaim.lisp: fns + echo '(in-package "COMPILER")' \ + '(load "../cmpnew/gcl_collectfn")(load "../lsp/sys-proclaim.lisp")'\ + '(compiler::make-all-proclaims "*.fn")' | ../xbin/gcl + + +newfn: + $(MAKE) `echo $(OBJS) | sed -e 's:\.o:.fn:g'` + + + +remake: + for v in `"ls" *.lsp.V | sed -e "s:\.lsp\.V::g"` ; \ + do rm -f $$v.c $$v.h $$v.data $$v.lsp $$v.o ; \ + ln -s $(MAINDIR)/cmpnew/$$v.c . ; ln -s $(MAINDIR)/cmpnew/$$v.h . ; \ + ln -s $(MAINDIR)/cmpnew/$$v.data . ; \ + done + rm -f ../unixport/$(FLISP) + (cd .. ; $(MAKE) sources) + (cd .. ; $(MAKE)) + (cd .. ; $(MAKE)) + +clean: + rm -f *.o core a.out *.fn *.c *.data *.h +allclean: + rm -f *.h *.data *.c diff --git a/cmpnew/so_locations b/cmpnew/so_locations new file mode 100755 index 0000000..142f563 --- /dev/null +++ b/cmpnew/so_locations @@ -0,0 +1,4 @@ +collectfn.o \ + :st = .text 0x000000005ffe0000, 0x0000000000010000:\ + :st = .data 0x000000005fff0000, 0x0000000000010000:\ + diff --git a/cmpnew/sys-proclaim.lisp b/cmpnew/sys-proclaim.lisp new file mode 100755 index 0000000..25237c3 --- /dev/null +++ b/cmpnew/sys-proclaim.lisp @@ -0,0 +1,168 @@ + +(IN-PACKAGE "COMPILER") +(MAPC (LAMBDA (X) (SETF (GET X 'PROCLAIMED-CLOSURE) T)) + '(CMP-TMP-MACRO COMPILE DISASSEMBLE CMP-ANON)) +(PROCLAIM '(FTYPE (FUNCTION (STRING *) T) TS)) +(PROCLAIM + '(FTYPE (FUNCTION (T) T) VAR-REP-LOC C1FUNOB C1STRUCTURE-REF + T1PROGN GET-RETURN-TYPE ADD-REG1 C1VAR C1ECASE + C1SHARP-COMMA C1ASH LTVP CTOP-WRITE C2FUNCTION + DECLARATION-TYPE C1TERPRI C1FUNCALL VAR-REGISTER C1ASSOC + CONS-TO-LISTA WT-LIST C1NTHCDR-CONDITION + C1MULTIPLE-VALUE-CALL CHECK-DOWNWARD TYPE-FILTER + C2TAGBODY-LOCAL BLK-NAME C1FSET T1DEFENTRY C1MEMBER + C1GETHASH C2GO-CCB SCH-LOCAL-FUN C1RPLACD C1RPLACA-NTHCDR + INLINE-POSSIBLE C1MAPC C2VAR WT-FUNCALL-C C1ADD-GLOBALS + FUN-NAME SAVE-FUNOB FUN-CFUN PROCLAIM TAG-REF-CCB + FIXNUM-LOC-P UNWIND-NO-EXIT WT-H1 MAXARGS C1GO INFO-P TAG-P + C1AND INLINE-TYPE VAR-REF-CCB C1MULTIPLE-VALUE-BIND C1THE + C2DM-RESERVE-VL WT-DOWNWARD-CLOSURE-MACRO VAR-NAME C1THROW + INFO-TYPE C1ASH-CONDITION LTVP-EVAL CHARACTER-LOC-P + C2DOWNWARD-FUNCTION C1EXPR C1TAGBODY BLK-REF INFO-VOLATILE + VAR-REF CONSTANT-FOLD-P WT-DATA-PACKAGE-OPERATION FUN-P + VAR-LOC C1PROGN C1NTHCDR VOLATILE TAG-UNWIND-EXIT + REPLACE-CONSTANT NAME-TO-SD SET-TOP C1GET PUSH-ARGS + FUN-REF-CCB INLINE-BOOLE3-STRING C1SETQ C1LOCAL-CLOSURE + CLINK GET-INCLUDED SET-PUSH-CATCH-FRAME FUNCTION-ARG-TYPES + T2DECLARE OBJECT-TYPE CHECK-VREF COPY-INFO + T1DEFINE-STRUCTURE C1BOOLE3 FUN-LEVEL C1NTH C2GET FIX-OPT + C1OR FUNCTION-RETURN-TYPE T1DEFUN T1CLINES FLAGS-POS + SAVE-AVMA WT-DOWN C2GO-CLB C1SWITCH WT-SWITCH-CASE + C1FUNCTION C2RPLACD C1LABELS C1MULTIPLE-VALUE-SETQ WT-VV + C2TAGBODY-CLB WT-CADR C1MAPCAR MACRO-DEF-P T1DEFMACRO + SET-RETURN THE-PARAMETER BLK-REF-CCB AET-C-TYPE + PUSH-ARGS-LISPCALL WRITE-BLOCK-OPEN SET-UP-VAR-CVS TAG-VAR + INFO-SP-CHANGE ADD-LOOP-REGISTERS C1MULTIPLE-VALUE-PROG1 + WT-VS C2LOCATION C1COMPILER-LET T3CLINES RESULT-TYPE + PROCLAMATION C1MAPL C1PRINC TAG-LABEL C2FUNCALL-AUX BLK-VAR + TAG-REF-CLB C2TAGBODY-CCB VERIFY-DATA-VECTOR C1MAPCAN + BLK-EXIT WT-VS-BASE REGISTER UNDEFINED-VARIABLE + SYSTEM:UNDEF-COMPILER-MACRO C1BLOCK C1MAPLIST + ARGS-CAUSE-SIDE-EFFECT C2BIND C1LET WT-SYMBOL-FUNCTION + CMP-MACRO-FUNCTION WT1 C1MEMQ BLK-REF-CLB ADD-ADDRESS + GET-LOCAL-ARG-TYPES C1UNWIND-PROTECT REP-TYPE ADD-CONSTANT + C1IF C1QUOTE C1FMLA-CONSTANT WT-DATA1 NAME-SD1 BLK-P + C1CATCH CMP-MACROEXPAND SHORT-FLOAT-LOC-P T3ORDINARY + C1LENGTH NEED-TO-SET-VS-POINTERS C1DOWNWARD-FUNCTION C1FLET + TAG-SWITCH TAG-REF PARSE-CVSPECS TAG-NAME VAR-P VAR-KIND + C1VREF C2GETHASH LONG-FLOAT-LOC-P C1MAPCON C1NTH-CONDITION + WT-FUNCTION-LINK WT-VAR-DECL C1STACK-LET ADD-SYMBOL T1DEFLA + C2EXPR* C1LOAD-TIME-VALUE C1DM-BAD-KEY C1PROGV FSET-FN-NAME + C2VALUES FUN-REF C2VAR-KIND C1PSETQ VARARG-P T1ORDINARY + C2GO-LOCAL C1LET* C2DM-RESERVE-V PUSH-DATA-INCF + C1DEFINE-STRUCTURE DEFAULT-INIT MDELETE-FILE + C1BOOLE-CONDITION C2RPLACA C1VALUES GET-ARG-TYPES WT-CAR + FUN-INFO C1DECLARE C1STRUCTURE-SET WT-VS* CMP-MACROEXPAND-1 + SCH-GLOBAL GET-LOCAL-RETURN-TYPE C1EVAL-WHEN C2TAGBODY-BODY + C1APPLY C1LOCAL-FUN C1MACROLET ADD-OBJECT C1RETURN-FROM + SAFE-SYSTEM RESET-INFO-TYPE T1DEFCFUN C1RPLACA WT-CDR + VAR-TYPE T1MACROLET C1LIST-NTH INFO-CHANGED-ARRAY + INFO-REFERRED-ARRAY BLK-VALUE-TO-GO ADD-OBJECT2 WT-CCB-VS)) +(PROCLAIM '(FTYPE (FUNCTION (*) *) INLINE-BOOLE3)) +(PROCLAIM '(FTYPE (FUNCTION (T) FIXNUM) F-TYPE)) +(PROCLAIM + '(FTYPE (FUNCTION (T (VECTOR T) FIXNUM T) FIXNUM) PUSH-ARRAY)) +(PROCLAIM + '(FTYPE (FUNCTION (T (VECTOR T) FIXNUM FIXNUM T) FIXNUM) + BSEARCHLEQ)) +(PROCLAIM + '(FTYPE (FUNCTION (T) *) C2EXPR WT-FIXNUM-LOC WT-LONG-FLOAT-LOC + C2OR WT-SHORT-FLOAT-LOC CMP-EVAL C2PROGN WT-TO-STRING + SET-LOC CMP-TOPLEVEL-EVAL VV-STR T1EXPR T1EVAL-WHEN WT-LOC + C2AND WT-CHARACTER-LOC)) +(PROCLAIM + '(FTYPE (FUNCTION (*) T) FCALLN-INLINE MAKE-BLK MAKE-FUN + LIST*-INLINE WT-CLINK COMPILE-FILE C2FSET MAKE-TAG CS-PUSH + LIST-INLINE MAKE-VAR COMPILER-COMMAND MAKE-INFO)) +(PROCLAIM + '(FTYPE (FUNCTION (STRING FIXNUM FIXNUM) T) DASH-TO-UNDERSCORE-INT)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T) *) C2COMPILER-LET C2FLET C2LABELS C2IF + WT-INLINE)) +(PROCLAIM '(FTYPE (FUNCTION (T T *) *) T3DEFUN-AUX)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T) *) C1DM-V C2RETURN-FROM C2DM C1DM-VL + C2APPLY-OPTIMIZE)) +(PROCLAIM + '(FTYPE (FUNCTION (T T) T) C2APPLY C2RETURN-CCB C2BIND-INIT + PROCLAIM-VAR PRIN1-CMP C2LAMBDA-EXPR-WITH-KEY + SYSTEM::ADD-DEBUG C2LAMBDA-EXPR-WITHOUT-KEY C2STACK-LET + MULTIPLE-VALUE-CHECK C1DECL-BODY COMPILER-CC C1EXPR* + C2MULTIPLE-VALUE-PROG1 CO1VECTOR-PUSH + ARGS-INFO-CHANGED-VARS C2DM-BIND-INIT C1PROGN* + CO1WRITE-CHAR COERCE-LOC WT-FIXNUM-VALUE IS-REP-REFERRED + C2MULTIPLE-VALUE-CALL CO1SPECIAL-FIX-DECL INLINE-PROC + WT-CHARACTER-VALUE SET-VS C2PSETQ T3SHARP-COMMA + STRUCT-TYPE-OPT WT-MAKE-DCLOSURE C2DM-BIND-VL SET-JUMP-TRUE + DO-MACRO-EXPANSION CO1SCHAR C2BLOCK-CLB + C2LIST-NTH-IMMEDIATE C2DM-BIND-LOC WT-LONG-FLOAT-VALUE + CO1CONS COMPILER-CLEAR-COMPILER-PROPERTIES C2EXPR-TOP + ARGS-INFO-REFERRED-VARS C2MEMBER!2 C2MULTIPLE-VALUE-SETQ + C2SETQ ADD-DEBUG-INFO GET-INLINE-LOC RESULT-TYPE-FROM-ARGS + C2BIND-LOC CO1STRUCTURE-PREDICATE C1ARGS SHIFT<< UNWIND-BDS + MAYBE-EVAL C2UNWIND-PROTECT TYPE-AND C2CALL-LOCAL C2THROW + CO1TYPEP SET-BDS-BIND C1SETQ1 C2CATCH TYPE>= C1LAMBDA-FUN + NEED-TO-PROTECT C2ASSOC!2 CO1READ-BYTE CO1LDB + CONVERT-CASE-TO-SWITCH FAST-READ MAKE-USER-INIT + CO1CONSTANT-FOLD C1FMLA CHECK-FNAME-ARGS + COERCE-LOC-STRUCTURE-REF WT-SHORT-FLOAT-VALUE C2BLOCK-CCB + ADD-INFO CAN-BE-REPLACED CO1READ-CHAR C2CALL-LAMBDA + CFAST-WRITE PUSH-CHANGED-VARS SHIFT>> JUMPS-TO-P CO1SUBLIS + C1CONSTANT-VALUE C2RETURN-CLB WT-VAR CHECK-END C2EXPR-TOP* + WT-V*-MACROS SET-JUMP-FALSE CMPFIX-ARGS SET-DBIND + CO1WRITE-BYTE CO1EQL COMPILER-DEF-HOOK WT-REQUIREDS)) +(PROCLAIM '(FTYPE (FUNCTION (T *) *) COMPILE-FILE1)) +(PROCLAIM '(FTYPE (FUNCTION (FIXNUM FIXNUM) T) MLIN)) +(PROCLAIM '(FTYPE (FUNCTION (STRING) T) DASH-TO-UNDERSCORE)) +(PROCLAIM + '(FTYPE (FUNCTION (T T) FIXNUM) PROCLAIMED-ARGD ANALYZE-REGS1 + ANALYZE-REGS)) +(PROCLAIM '(FTYPE (FUNCTION (T FIXNUM) T) MEMOIZED-HASH-EQUAL)) +(PROCLAIM '(FTYPE (FUNCTION ((VECTOR T)) T) COPY-ARRAY)) +(PROCLAIM + '(FTYPE (FUNCTION (T T) *) C2BLOCK-LOCAL C1SYMBOL-FUN C1BODY + C2BLOCK C2DECL-BODY C2RETURN-LOCAL NCONC-FILES + WT-INLINE-LOC COMPILER-BUILD)) +(PROCLAIM + '(FTYPE (FUNCTION (T *) T) WT-CVAR C1LAMBDA-EXPR UNWIND-EXIT + CMPWARN WT-COMMENT WT-INTEGER-LOC CMPERR ADD-INIT + FAST-LINK-PROCLAIMED-TYPE-P CMPNOTE C1CASE INIT-NAME)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T) T) T3DEFUN-VARARG C2STRUCTURE-REF + C2CALL-UNKNOWN-GLOBAL C1MAKE-VAR C2SWITCH WT-GLOBAL-ENTRY + C2CALL-GLOBAL T3INIT-FUN MY-CALL T3DEFUN-NORMAL)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T) T) CJT WT-INLINE-INTEGER CMP-EXPAND-MACRO + CHECK-FORM-TYPE SET-VAR C2CASE ADD-FUNCTION-PROCLAMATION + INLINE-TYPE-MATCHES T3DEFCFUN C2MAPCAN AND-FORM-TYPE + C2PROGV C1DM WT-INLINE-CHARACTER C2MULTIPLE-VALUE-BIND + C2FUNCALL-SFUN C2LET MYSUB C-FUNCTION-NAME WT-MAKE-CCLOSURE + C2GO WT-INLINE-COND ADD-FAST-LINK C1STRUCTURE-REF1 C2MAPCAR + BOOLE3 TOO-FEW-ARGS FIX-DOWN-ARGS COMPILER-PASS2 + GET-INLINE-INFO C2LET* WT-INLINE-SHORT-FLOAT + WT-IF-PROCLAIMED C2PRINC ASSIGN-DOWN-VARS + WT-INLINE-LONG-FLOAT C2TAGBODY C1MAP-FUNCTIONS CHECK-VDECL + MAKE-INLINE-STRING WT-INLINE-FIXNUM C2MAPC CAN-BE-REPLACED* + SUBLIS1-INLINE TOO-MANY-ARGS ADD-FUNCTION-DECLARATION CJF)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T *) T) T3LOCAL-DCFUN T3LOCAL-FUN)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T) T) T2DEFUN T3DEFUN C2STRUCTURE-SET + C1APPLY-OPTIMIZE T3DEFUN-LOCAL-ENTRY)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T *) T) WT-SIMPLE-CALL GET-OUTPUT-PATHNAME)) +(PROCLAIM + '(FTYPE (FUNCTION (T T *) T) INLINE-ARGS C2FUNCALL C2LAMBDA-EXPR + LINK)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T T) T) T3DEFMACRO DEFSYSFUN T2DEFENTRY + T2DEFMACRO T3DEFENTRY)) +(PROCLAIM + '(FTYPE (FUNCTION NIL T) WT-DATA-BEGIN PRINT-COMPILER-INFO + GAZONK-NAME CCB-VS-PUSH INC-INLINE-BLOCKS + PRINT-CURRENT-FORM C1NIL WT-DATA-FILE + ADD-LOAD-TIME-SHARP-COMMA CVS-PUSH RESET-TOP WT-CVARS + BABOON WT-FASD-DATA-FILE WT-DATA-END INIT-ENV + TAIL-RECURSION-POSSIBLE WFS-ERROR C1T VS-PUSH + WT-NEXT-VAR-ARG WT-FIRST-VAR-ARG WT-C-PUSH + CLOSE-INLINE-BLOCKS)) \ No newline at end of file diff --git a/comp/bo1.lsp b/comp/bo1.lsp new file mode 100755 index 0000000..e8924d8 --- /dev/null +++ b/comp/bo1.lsp @@ -0,0 +1,149 @@ +(in-package "BCOMP") +(defvar *space* 0) + + +(defmacro once-only (((v val) . res) &body body) + (cond (res `(once-only ((,v,val)) (once-only ,res ,@ body))) + ((and (consp val) (or (eq (car val) 'function)(eq (car val) 'quote))) + `(symbol-macrolet ((,v ,val)) ,@ body)) + (t (let ((w (gensym))) + `(let ((,w ,val)) + (symbol-macrolet ((,v ,w)) + ,@ body)))))) + +(defun get-test (x &aux item lis res key fn) + (when (<= *space* 0) + (desetq (item lis . res) (cdr x)) + (cond (res + (desetq (key fn . res) res) + (cond ((or res + (not (eq key :test)) + (not (and (consp fn) + (member (car fn) '(quote function))))) + nil) + (t (cadr fn)))) + (t 'eql)))) + +(setf (get 'assoc 'bo1) 'bo1-assoc) +(defun bo1-assoc (x where &aux fn ) where + (when (setq fn (get-test x)) + `(funcall #'(lambda (item lis) + (sloop for v in lis + when (funcall #',fn (car v) item) + do (return v))) + ,@ (cdr x)))) + +(setf (get 'member 'bo1) 'bo1-member) +(defun bo1-member (x where &aux fn ) where + (when (setq fn (get-test x)) + `(funcall #'(lambda (item lis) + (sloop for v on lis + when (funcall #',fn (car v) item) + do (return v))) + ,@ (cdr x)))) + +(setf (get 'get 'bo1) 'bo1-get) +(defun bo1-get (x where) where + (when (and (= *safety* 0) (< *space* 2)) + `(funcall #'(lambda (plis key &optional dflt) + (setq plis (symbol-plist plis)) + (loop (cond ((null plis) (return dflt)) + ((eq (car plis) key)(return (cadr plis))) + (t (setq plis (cddr plis)))))) + ,@ (cdr x)))) + +(setf (get 'mapcar 'bo1) 'bo1-mapcar) +(setf (get 'mapc 'bo1) 'bo1-mapcar) +(setf (get 'mapcan 'bo1) 'bo1-mapcar) +(defun bo1-mapcar (x where &aux fn l coll) where + (when (and (= *safety* 0) (< *space* 2)) + (desetq (fn l) (cdr x)) + (setq coll (cdr (assoc (car x) '((mapcar . collect) (mapc . do) + (mapcan . nconc))))) + (cond ((cdddr x) nil) + ((and (consp fn) (member (car fn) '(quote function))) + `(funcall #'(lambda (lis) + (sloop for v in lis ,coll (funcall ,fn v))) + ,@ (cddr x))) + (t `(funcall #'(lambda (fn lis) + (if (symbolp fn) (setq fn (symbol-function fn))) + (sloop for v in lis ,coll (funcall fn v))) + ,@ (cdr x)))))) + +(setf (get 'funcall 'bo1) 'bo1-funcall) +(defun bo1-funcall (x where &aux fn tem args ll w binds) where + (desetq (fn . args) (cdr x)) + (cond ((and (consp fn) + (or (eq (car fn) 'quote) + (eq (car fn) 'function)) + (consp (cdr fn)) + (setq tem (cadr fn)) + (symbolp tem)) + `(,(cadr fn) ,@ args)) + (tem + (cond ((and (consp tem) (eq (car tem) 'lambda)) + (desetq (ll) (cdr tem)) + (setq ll (decode-ll ll)) + (cond ((and (null (ll &key ll)) + (null (ll &rest ll)) + (null (ll &aux ll))) + (sloop for v in (ll &required ll) + do (desetq (w) args) + (setq args (cdr args)) + (push (list v w) binds)) + (sloop for v in (ll &optional ll) + do + (cond (args + (or (consp args) (comp-error "bad arglist in ~a " x)) + (push (list (car v) (pop args)) binds)) + (t (push (list (car v) (cadr v)) binds))) + (cond ((caddr v) + (push (list (caddr v) + (not (null args))) + binds)))) + `(let ,(nreverse binds) + ,@ (cddr tem))))))) + (t nil))) + +(setf (get 'typep 'b1.5) 'b1.5-typep) +(defun b1.5-typep (x where &aux (cd (third x)) + (args (call-data-arglist cd))) + where + (let ((rt (result-type (nth 0 args))) + (typ (nth 1 args))) + (cond ((and (consp typ) + (eq (car typ) 'dv) + (subtypep rt (THIRD typ))) + (get-object t))))) + +(defmacro dotimes ((var form &optional (val nil)) &rest body + &aux (temp (gensym))) + `(do* ((,temp ,form) (,var 0 (1+ ,var))) + ((>= ,var ,temp) ,val) + ,@ (cond ((typep form 'fixnum) + `((declare (fixnum ,temp ,var))))) + ,@body)) + +(defmacro psetq (&optional var val &rest l &aux sets types decls binds) + (cond ((null var) nil) + ((null l) `(setq ,var ,val)) + (t (loop + (push `(,(gensym) ,val) binds) + (push var sets) + (push (caar binds) sets) + (push `(type (type-of ,var) ,(caar binds)) types) + (or l (return nil)) + (desetq (var val) l) (setq l (cddr l))) + `(let ,(nreverse binds) + (declare ,@ types) + (setq ,@(nreverse sets)))))) + +;; +;;- Local variables: +;;- mode:lisp +;;- version-control:t +;;- End: + + + + diff --git a/comp/c-pass1.lsp b/comp/c-pass1.lsp new file mode 100755 index 0000000..c94ed7d --- /dev/null +++ b/comp/c-pass1.lsp @@ -0,0 +1,70 @@ +(in-package "BCOMP") +(setf (get 'call-set-mv 'b1) 'b1-call-set-mv) +(defun b1-call-set-mv (x where &aux form) where + (desetq (nil form) x) + `(call-set-mv #.(make-desk t) + ,(b1-walk form 'call-set-mv))) + + +(setf (get 'multiple-value-bind 'b1) 'b1-multiple-value-bind) +(defun b1-multiple-value-bind(x where &aux vars form body ) + (desetq (nil vars form . body) x) + (b1-walk + `(progn + (call-set-mv , form) + (let , + (sloop for v in vars + for i from 0 + collect `(,v (nth-mv ,i ))) + ,@ body)) + where)) + +(setf (get 'multiple-value-setq 'b1) 'b1-multiple-value-setq) +(defun b1-multiple-value-setq(x where &aux vars form body gens) + (desetq (nil vars form . body) x) + (setq gens (sloop for v in-list vars collect (gensym))) + (b1-walk + `(multiple-value-bind ,gens ,form + (setq ,@ (sloop for v in vars for w in gens collect v collect w)) + ,@ body) where )) + +(setf (get 'multiple-value-list 'b1) 'b1-multiple-value-list) +(defun b1-multiple-value-list(x where &aux form ) + (desetq (nil form ) x) + (b1-walk `(progn (call-set-mv ,form) + (list-mv)) + where)) + + +;; replace this by storage allocation in c stack of n*multiple-value-limit +;; and then copy into this storage at each stage. Then c_apply_n +;; which funcalls a vector. +(setf (get 'multiple-value-call 'b1) 'b1-multiple-value-call) +(defun b1-multiple-value-call(x where &aux bod fun ) + (desetq (nil fun . bod) x) + (b1-walk + `(apply ,fun + (nconc ,@ (sloop for v in-list bod + collect `(the dynamic-extent (multiple-value-list ,v))))) + + where + )) + +(setf (get 'multiple-value-prog1 'b1) 'b1-multiple-value-prog1) +(defun b1-multiple-value-prog1(x where &aux form bod (sym (gensym ))) + (desetq (nil form . bod) x) + (b1-walk + `(let ((,sym (multiple-value-list ,form))) + (declare (dynamic-extent ,sym)) + ,@ bod + (apply #'values ,sym)) + where)) + + + + + + + + + diff --git a/comp/cmpinit.lsp b/comp/cmpinit.lsp new file mode 100755 index 0000000..658d5fa --- /dev/null +++ b/comp/cmpinit.lsp @@ -0,0 +1,16 @@ + +(proclaim '(optimize (safety 2)(speed 0))) +(in-package "BCOMP") +(Use-package '("LISP" "SLOOP")) +(or (get 'call-data 'si::s-data) (load "defs.lsp")) +(or (macro-function 'dolist-safe)(load "macros.lsp")) +(or (si::specialp '*top-form*) (load "top.lsp")) +(or (si::specialp '*next-data*) (load "top2.lsp")) +(or (si::specialp '*C-OUTPUT*) (load "top.lsp")) +(or (si::specialp '*function-decls*)(load "top1.lsp")) +(or (si::specialp '*immediate-types*) (load "comptype.lsp")) +(or (fboundp 'flags-pos) (load "inline.lsp")) +(or (si::specialp '*value*)(Load "stmt.lsp")) +(or (si::specialp ' *PROMOTED-ARG-TYPES*) (load "utils.lsp")) + + diff --git a/comp/comptype.lsp b/comp/comptype.lsp new file mode 100755 index 0000000..5e7769d --- /dev/null +++ b/comp/comptype.lsp @@ -0,0 +1,227 @@ +(in-package "BCOMP") + + +(defvar *immediate-types* + '(fixnum character short-float double-float boolean)) + +(dolist (v + '((t array package + atom float pathname + bignum function random-state + hash-table ratio single-float + rational standard-char + keyword readtable stream + common list sequence + compiled-function + complex nil signed-byte symbol + cons null unsigned-byte t + number simple-array vector + ) + (bit bit) + (integer integer) + (double-float long-float single-float) + (character string-char) + ((vector character) string simple-string) + ((vector bit) bit-vector simple-bit-vector) + ((vector t) simple-vector) + (stream stream) + (dynamic-extent dynamic-extent ) + (fix-or-sf-or-df fix-or-sf-or-df) + )) + (dolist (w (cdr v)) + (setf (get w 'comp-type) (car v)))) +(dolist (v *immediate-types*) (setf (get v 'comp-type) v)) + +(deftype fix-or-sf-or-df nil '(or fixnum short-float double-float)) +(deftype boolean nil t) +(proclaim '(declaration dynamic-extent)) +;(deftype dynamic-extent nil t) + +(defun grab-1-decl (x decls &aux type l tem place) + (tagbody + (go begin) + ERROR + (comp-warn "bad declaration ~a" x) + (return-from grab-1-decl decls) + BEGIN + (or (consp x) (go error)) + (setq type (car x) l (cdr x)) + (or (null l) (consp l) (go error)) + (unless + (symbolp type) + (comp-warn "bad declaration ~a" x) + (return-from grab-1-decl decls) + ) + (cond ((or (setq tem (get type 'comp-type)) + (and (eq type 'type) + (consp l) + (setq tem (comp-type (car l))) + (setq l (cdr l)))) + (unless (eq t (setq tem (comp-type tem))) + (or decls (setq decls (list nil))) + (dolist-safe (v l) + (or (symbolp v) (go error)) + (push (cons v tem) (car decls))))) + ((eq type 'special) + (cond ((null decls) (setq decls (list nil nil))) + ((null (cdr decls)) + (setf (cdr decls) (list nil)))) + (setq place (cdr decls)) + (dolist-safe (v l) + (or (symbolp v) (go error)) + (push v (car place)) + )) + ((or (eq type 'inline) + (eq type 'not-inline) + (and (eq type 'ftype) + (progn (desetq (type . l) l) t))) + (dolist-safe (v l) (push + (cons v (increment-function-decl + type (function-declaration v))) + *function-decls*))) + (t nil))) + ; (((v1 . type1) (v2 . type2) ..)(special-var1 special-var2 ..)) + decls) + +(defun best-array-element-type (type) + (cond ((or (eql t type) (null type)) t) + ((memq type '(bit unsigned-char signed-char + unsigned-short + signed-short fixnum + character + )) + type) + ((subtypep type 'fixnum) + (dolist (v '(bit unsigned-char signed-char + unsigned-short + signed-short) + 'fixnum) + (cond ((subtypep type v) + (return v))))) + ((eql type 'string-char) 'character) + (t (or (dolist (v '(string-char bit short-float + long-float)) + (cond ((subtypep type v) + (return v)))) + t)))) + +(deftype type-of (x) + (cond (*in-pass-1* + (let ((tem (b1-walk x 'type-of))) + (result-type tem))) + (t t))) + +(defun assure-list (x) + (loop + (if (null x) (return t)) + (if (consp x) (setq x (cdr x)) + (error "expected a list ~a" x)))) + +(deftype struct (x) 'structure) +(defun comp-type (type &aux tem element-type sizes) +;; coerce type to ones understood by compiler + (cond ;((member type *immediate-types*) + ;(return-from comp-type type)) + ((and (symbolp type) + (setq tem (get type 'comp-type))) + (return-from comp-type tem)) + ((and(symbolp type) + (setq tem (get type 'si::deftype-definition))) + (comp-type (funcall tem))) + ((consp type) + (cond + ((eq (car type) 'struct) + (list 'struct (best-array-element-type (cadr type)))) + ((progn (setq type (si::normalize-type type)) nil)) + ((member (car type) '(array simple-array vector simple-vector)) + (when (consp (cdr type)) + (setq element-type (best-array-element-type (cadr type))) + (when(consp (cddr type)) + (setq sizes (caddr type)) + (cond ((consp sizes) + (assure-list sizes) + (unless (typep (second sizes) 'fixnum) (setq sizes nil))) + ((typep sizes 'fixnum) ) + (t (setq sizes nil)))) + (cond ((or (eql sizes 1) (null (cdr sizes))) + (setq tem 'vector) (setq sizes nil)) + (t (setq tem 'array))) + (list* tem element-type (if sizes (list sizes))))) + ((eq (car type) 'integer) + (if (si::sub-interval-p (cdr type) + (list most-negative-fixnum + most-positive-fixnum)) + 'fixnum + 'integer)) + ((eq (car type) 'values) + (if (null (cddr type)) + (comp-type (second type)) + (cons 'values (mapcar 'comp-type (cdr (the-list type)))))) + (t t))) + (t t))) + +(setf (get 'var 'result-type-b1) 'result-type-b1-var) +(defun result-type-b1-var (x) (or (third x) t)) + +(defun result-type (form &aux fd) +;; compute the result type of form , where FORM is somethign +;; returned by b1-walk + (cond ((consp form) + (cond ((and (symbolp (car form)) + (setq fd (get (car form) 'result-type-b1))) + (funcall fd form)) + ((and (atom (second form)) + (typep (second form) 'desk)) + (desk-result-type (second form))) + (t t))) + ((typep form 'var) + (var-type form)) + (t + (wfs-error) + ))) + +(setf (get 'dv 'result-type-b1) 'dv-result-type) +(defun dv-result-type (x) + (let ((val (third x))) + (cond ((typep val 'fixnum) 'fixnum) + ((typep val 'short-float) 'short-float) + ((typep val 'double-float) 'double-float) + ((typep val 'character) 'character) + ((typep val 'character) 'character) + (t t)))) + +(defun comp-subtypep (x y &aux xa xb) +; (cond ((and (atom x) (not (eq y t)) (not (eq x y)) +; (subtypep x y))(comp-warn "subtypep ~a ~a" x y))) + (cond ((eq y t) t) + ((atom x) + (subtypep x y)) + ((atom y) + (subtypep x y)) + ((member (car x) '(array struct)) + (and (eq (car y) (car y)) (subtypep (cdr x) (cdr y)))) + (t (subtypep x y)))) + +(defun type-and (a b) + (if (eq a b) (return-from type-and a)) + (if (eq a t) (return-from type-and b)) + (if (eq b t) (return-from type-and a)) + (multiple-value-bind (typ sure) + (subtypep a b) + sure + (cond (typ (return-from type-and a)))) + (multiple-value-bind (typ sure) + (subtypep b a) + sure + (cond (typ (return-from type-and b)))) + t) + + + + + + + + + + diff --git a/comp/data.lsp b/comp/data.lsp new file mode 100755 index 0000000..cbf3cc6 --- /dev/null +++ b/comp/data.lsp @@ -0,0 +1,107 @@ + +(in-package "BCOMP") + +(eval-when (compile eval) + (require 'FASDMACROS "../comp/fasdmacros.lsp") +(defvar *data*) +(defvar *data-output*) +(defmacro data-vector () `(car *data*)) +) +(defvar *fasd-data*) + + +; +; (defun verify-data-vector(vec &aux v) +; (dotimes (i (length vec)) +; (setq v (aref vec i)) +; (let ((has (si::hash-equal (cdr v) -1000))) +; (cond ((and (typep (car v) 'fixnum) +; (not (eql (car v) has))) +; (cmpwarn "A form or constant:~% ~s ~%has changed during the eval compile procedure!.~% The changed form will be the one put in the compiled file" (cdr v))))) +; (setf (aref vec i) (cdr v))) +; vec +; ) + + + + +(defun wt-data-file ( &aux (x (data-vector)) + (*package* (find-package "LISP")) + fd tem + ) + (declare (type (array (t)) x)) +; (verify-data-vector x) + (setq fd (si::open-fasd *data-output* :output nil nil)) + + (si::find-sharing-top x (fasd-table fd)) + (put-op d_enter_vector *data-output*) + (sloop for i below (length x) + do (setq tem (aref x i)) + (cond ((consp tem) + (cond ((eq (car tem) 'd_eval_skip) + (put-op d_eval_skip *data-output*)) + ((eq (car tem) 'd_eval) + (put-op d_eval *data-output*))))) + (si::write-fasd-top (cdr tem) fd)) + (put-op d_delimiter *data-output*) + (si::close-fasd fd)) + +(defun display-data-file(file &aux fd (eof '(nil)) tem ) + (with-open-file (st file) + ; (setq fd (si::open-fasd st :input eof nil)) + (setq fd (si::open-fasd st :input eof + (make-array 100 :adjustable t))) + (sloop::sloop for i from 0 + while + (not (eq eof (setq tem (si::read-fasd-top fd)))) + do + (format t "~%item ~a:~%~s" i tem )) + )) +(defun display-data-file1(file &aux fd (eof '(nil)) ) + (with-open-file (st file) + ; (setq fd (si::open-fasd st :input eof nil)) + (setq fd (si::open-fasd st :input eof + (make-array 100 :adjustable t))) + (let ((si::%memory nil)) + (declare (special si::%memory)) + (si::read-fasd-top fd)))) + +(defun push-data (flag val) + (vector-push-extend (cons flag val) (data-vector)) + (prog1 *next-data* + (if (or (eq flag 'dv) (eq flag 'd_eval)) + (incf *next-data*)))) + +(defun get-load-time-form (x) + (let ((tem (cdr (assoc x *load-time-forms*)))) + (cond (tem) + (t (setq tem (list 'dv nil x)) + (setf (second tem) (push-data 'd_eval x)) + (push (cons x tem) *load-time-forms*) + tem)))) + + +(defun get-object (x &aux tem) + (cond ((setq tem (gethash x *data-table*))) + ((typep x 'compiled-function) + (setq tem (list 'd_eval + nil + `(function + ,(or (si::compiled-function-name x) + (comp-error + "Can't dump un named compiled funs"))) + )) + (setf (gethash x *data-table*) tem) + tem) + (t + (setq tem (list 'dv nil x)) + (setf (gethash x *data-table*) tem) + tem))) + +#| steps in loading +0) (let (*cfun-addresses* *data-object*) +1) copy address in VV vector into *vv-addresses* vector. +2) make a *data-object* whose body is the VV. +3) readin the items into the vector. using read-fasd-top + +|# diff --git a/comp/defmacro.lsp b/comp/defmacro.lsp new file mode 100755 index 0000000..359c17c --- /dev/null +++ b/comp/defmacro.lsp @@ -0,0 +1,257 @@ +(in-package "BCOMP") + +(eval-when (load eval compile) + +(defvar *let-bindings* nil) + +(defvar *pending-action* nil) + + +(defun find-declarations (body &aux decls doc bod) + (do ((v body (cdr v))) + (()) + (or (consp v) (return nil)) + (cond ((and (consp (car v)) (eq (caar v) 'declare)) + (push (car v) decls)) + ((stringp (car v))(if doc (return (setq bod v)) (setq doc (car v)))) + (t (setq bod v)(return nil)))) + (values (if doc (cons doc decls) decls) bod)) + + +(defun parse-mll (argl whole top + &aux u (pos 0) key-list key-test) + ;; parse a macro lambda list ARGL, where WHOLE is a variable bound + ;; to the whole list we gradually cdr down WHOLE + ;; This is called recursively by add-binding, whenever the item to be + ;; bound is not a symbol. + (declare (fixnum pos)) + (when (eq (car argl) '&whole) + (or (consp (cdr argl)) (macro-arg-error '&whole)) + (setq u (cadr argl)) + (add-binding u whole) + (setq argl (cddr argl))) + (if top (push `(setq ,whole (cdr ,whole)) *pending-action*)) + + (do () + ((atom argl) + (cond (key-test + (setf (third key-test) `(quote , key-list)))) + (when argl + (if (>= pos 2) (macro-arg-error '&rest)) + ;; ` . body' at the end is the same as `&rest body' + (add-binding argl whole))) + (let ((x (car argl))) + (case x + ;; The lambda list keywords must appear in the following order (with ommissions). + ;; We have deleted the &environment and &whole at this point. + ;; pos 1 &optional, 2 &rest &body, 3 &key, 4 &allow-other-keys, 5 &aux + (&optional + (when (>= pos 1) (macro-arg-error x)) + (setq pos 1)) + ((&rest &body) + (if (>= pos 2) (macro-arg-error x)) + (setq argl (cdr argl)) + (if (consp argl) nil (macro-arg-error x)) + (add-binding (car argl) whole) + (setq pos 2) + ) + (&key + (if (>= pos 3) (macro-arg-error x)) + (setq key-test `(dont-allow-other-keys ,whole nil)) + (push key-test *pending-action*) + (setq pos 3)) + (&allow-other-keys + (if (or (< pos 3) (>= pos 4)) (macro-arg-error x)) + (setf (car key-test) 'progn key-test nil) + (setq pos 4)) + (&aux + (if (>= pos 5) (macro-arg-error x)) + (setq pos 5)) + (t + (cond + ((= pos 5) ;&aux + (let ((var x) (val nil)) + (cond ((atom x)) + (t (or (consp (cdr x)) (macro-arg-error '&aux)) + ;(or (cddr x) (macro-arg-error '&aux)) + (setq var (car x) val (cadr x)))) + (or (symbolp var) (macro-arg-error '&aux)) + (add-binding var val))) + ((= pos 4) + (macro-arg-error '&allow-other-keys)) + ((= pos 3) ; &key + (let (var val supplied-p keyword dont-intern) + (cond + ((atom x) (setq var x keyword x)) + (t (setq var (car x)) + (cond ((symbolp var) + (setq keyword var)) + ((consp var) + (setq dont-intern t) + (if (consp (cdr var)) nil (macro-arg-error '&key)) + (setq keyword (car var) var (cadr var)) + (if (symbolp keyword) nil (macro-arg-error '&key))) + (t (macro-arg-error '&key))) + (cond ((consp (cdr x)) + (setq val (cadr x)) + (cond ((consp (cddr x)) + (setq supplied-p (caddr x)))))))) + (or dont-intern (setq keyword (intern (symbol-name keyword) 'keyword))) + (push keyword key-list) + (let ((key-val (gensym))) + (add-binding key-val `(getf ,whole ',keyword 'not-found)) + (add-binding var `(if (eq ,key-val 'not-found) ,val ,key-val)) + (if supplied-p + (add-binding supplied-p `(not (eq ,key-val 'not-found))))))) + ((= pos 2) + ;; they duplicated an &rest arg eg `&rest a b' + (macro-arg-error '&rest)) + ((= pos 1) ; &optional + (let (var val supplied-p) + (cond ((atom x) (setq var x)) + ((consp (cdr x)) + (setq var (car x) val (cadr x)) + (if (consp (cddr x)) + (setq supplied-p (caddr x)))) + (t (macro-arg-error x))) + (add-binding var `(cond ((consp ,whole) + ,@(if supplied-p `((setq ,supplied-p t))) + (prog1 (car ,whole) + (setq ,whole (cdr ,whole)))) + (t ,val))))) + ((= pos 0) ;&required arg + (let ((last-arg (or (null (cdr argl)) + (and (consp (cdr argl)) + (eq (car argl) '&aux))))) + (add-binding x + `(cond ((consp ,whole) + ,(if last-arg + `(if (cdr ,whole) + (too-many-arguments-to-macro) + (car , whole)) + `(car ,whole))) + (t (too-few-arguments-to-macro)))) + (or last-arg (push `(setq ,whole (cdr ,whole)) + *pending-action*)) + + )))))) + (pop argl))) + +(defun too-many-arguments-to-macro() + (error "Too many arguments to a macro or destructuring bind")) + +(defun too-few-arguments-to-macro() + (error "Too few arguments to a macro or destructuring bind")) + +(defun add-binding (v val) + (when *pending-action* (setq val `(progn ,@ (reverse *pending-action*) ,val)) + (setq *pending-action* nil)) + (cond ((symbolp v) + (push (list v val) *let-bindings*)) + ((consp v) + (let ((sub-whole (gensym))) + (push `(,sub-whole ,val) *let-bindings*) + (parse-mll v sub-whole nil))) + (t (error "Bad lambda list entry ~a" v)))) + +(defun parse-macro (name lambda-list body &optional env &aux envir whole) + ;; process a macro function body, laying out code for destructuring the + ;; lambda-list. An implicit block with NAME is placed around the body. + ;; The resulting lambda expression is a function of two arguments, suitable + ;; for calling as a macroexpander. + env + (let (*let-bindings* *pending-action*) + (do ((v lambda-list (cdr v)) (res nil)) + (()) + (if (atom v) (return nil)) + (cond ((eq (car v) '&environment) + (if (consp (cdr v)) nil (macro-arg-error '&environment)) + (setq envir (cadr v)) + (setf lambda-list (nconc (nreverse res) (cddr v))) + (return nil)) + (t (push (car v) res)))) + (if envir nil (setq envir (gensym))) + (setq whole (gensym)) + (parse-mll lambda-list whole t) + `(function (lambda (,whole ,envir) + ,envir + (block ,name + (let* ,(nreverse *let-bindings*) + ,@ body)))) + )) + +(defun macro-arg-error (x) + (error "Incorrect position or duplication of ~a arg in macro lambda list" x)) + +(defun dont-allow-other-keys(arglist allowed-keys) + ;; Make sure arglist doesn't contain other keys. + (do ((v arglist)) + ((null v)) + (cond ((consp v) + (if (consp (cdr v)) nil (error "Odd number of keyword args")) + (if (and (eq (car v) :allow-other-keys) + (cadr v)) + (return nil)) + (if (member (car v) allowed-keys :test 'eq) nil + (error "~s is not among the permitted keys ~s" (car v) allowed-keys)) + (setq v (cddr v))) + (t (error "The keyword args end in an atom ~a instead of NIL" v))))) + +(defun mset (sym fun) (setf (symbol-function sym) (cons 'macro fun))) + +;(defmacro defmacro (name ll &body body)) +(setf (macro-function 'defmacro) + #'(lambda (bod env &aux ll body name) + (setf bod (cdr bod)) + (or (consp bod) (too-few-arguments-to-macro)) + (setq name (car bod) bod (cdr bod)) + (or (consp bod) (too-few-arguments-to-macro)) + (setq ll (car bod) body (cdr bod)) + (let ((doc (car (find-declarations body))) + (def `(eval-when (compile eval load) + (mset ',name + ,(parse-macro name ll body t))))) + (when (stringp doc) + (setq def `(progn ,def + (setf (get ',name 'si::function-documentation) + ,doc)))) + def))) + + +(defmacro destructuring-bind (lambda-list expr &body body) + (let ((whole (gensym)) + *let-bindings* *pending-action*) + (parse-mll lambda-list whole nil) + `(let* ((,whole ,expr) + ,@ (nreverse *let-bindings*)) + ,@ body))) +) +#+test +(progn + +(defmacro1 billy (a b &key ((:u bil) 0 sup) sil &allow-other-keys) + `(billy-list ,a ,b ,sil ,bil,sup ,a)) + +(defmacro1 mwith ((st . open-args) &body body) + `(let (,st (open ,@ open-args)) + (unwind-protect + (progn ,@ body) + (close ,st)))) + +(defmacro1 joe ((st a) y) `(joe-flat ,st,a,y)) +(defmacro jo2 ((a b &key c d) &body body) + (list 'hi a b c d body)) +(jo2 (1 2 :c 3 ) 4 6) + +(mwith (st "foo" :direction :input) (read-char st)) +(billy 1 2 :sil 1 :u 4 :james 1) +(joe (1 2) 3) +) + + + + + + + + \ No newline at end of file diff --git a/comp/defs.lsp b/comp/defs.lsp new file mode 100755 index 0000000..99aaa88 --- /dev/null +++ b/comp/defs.lsp @@ -0,0 +1,126 @@ + +(in-package "BCOMP") + +#| +after pass 1 only the following forms are allowed + +forms1 == (form1 form1 ... form1) +form1 == output of (w1-walk form) +N == 0,1,2,3.. +desk == desk structure +var1 == var structure + | (var N) +binds == ((var1 form1) (var1 form1) ..) +arglist == (form1 form1 ... form1) +(LET desk binds forms1) +;(LET* desk binds forms1) ; not needed since the variable assign done. +(CALL desk call-data ) +(FUNCTION desk function-data) + +---------------------- +|# + +;;Globals for Second pass +;; push on to this when special is bound, so that it can be unbound. +(defvar *sp-bind* nil) +;; set when a setjmp is laid down, so variables can be declared volatile +(defvar *volatile* nil) + +;; tells unwind-set that number of values already set. +(defvar *MV-N-VALUES-SET* nil) + +(defvar *top-form* +;; Passes of the compiler may bind this to a form name which they are compiling +;; to make the errors more meaninful. + nil) + +(defstruct var name + ;; count of cross lambda block closure references + clb + type ;; rep type + changed ;; var was altered + ref ;; var referred to + special-p ;; var declared special + ;;for special var, something to which wr applies to write it + ;;for a closure var, if the the var is NOT in the *closure-vars* + ;; (ie those passed in to this function), then it is an (next-cvars) index + ;; if the var was passed in then this field is ignored, and the index is + ;; the position in the *closure-vars* list. + ;;for a normal variable the (next-cvar), eg ind = 3 , var written V3 + ind + ;; vars which are maybe referred to after return from a setjmp + volatile + ) + +(defstruct (desk (:constructor make-desk1 (result-type ))) + result-type ;result of first value + ;CHANGED-VARS are the plain-var-p vars which are altered in the + ;scope of the form of which this desk appears as the second member. + ;used when setting up args for a c call, to know if we need to save a var + changed-vars + single-value + ) + +(defun make-desk (x) + (or x (setq x t)) + (make-desk1 x)) + +(defstruct fdata + name + ll ; list : (ll &required (fdata-ll fd)) == the list of required args. + closure-vars + ind + address-index + doc + form + function-declaration ;; at the time of definition + argd + local-template ;; local function call template. + closure-self ;; if this is a closure and non nil then it points to a funobj = self + tail-label +) + +(defstruct (call-data (:constructor make-call-data + (fname arglist local-fun + function-declaration))) + fname ; may be a name or else fdata for a local function. + arglist + local-fun + ;;declaration at the point of call. + ;;If nil, and if not local then + ;; it may be retrieved later. + function-declaration + ) + +(defstruct label + identifier + ;; If this label is referred to across functions, a unique-id + ;; is assigned and put in the clb-reference field. Otherwise this is nil + clb-reference + ;; On pass1 this is set to 'clb by clb references. If it is null it is + ;; set to t by ordinary references. + referred + ind + ) + +(defstruct (block (:constructor make-block (label))) + label + value + exit) + +(defstruct top-form + lisp + walked + funp ;T if contains a function + ) + +(defstruct (link (:constructor make-link (fname proclaimed))) + (argd 0 :type fixnum) + ind + proclaimed + fname + ) + + + + \ No newline at end of file diff --git a/comp/exit.lsp b/comp/exit.lsp new file mode 100755 index 0000000..96de32a --- /dev/null +++ b/comp/exit.lsp @@ -0,0 +1,44 @@ +(in-package "BCOMP") + +(setf (get 'let-control-stack 'b2) 'b2-let-control-stack) +(defun b2-let-control-stack (x) + (let ((*control-stack* *control-stack*)(*blocks* 0)) + (open-block) + (wr "object *VOL SaveVs = VsTop;") + (expr-b2 (cadr x)) + (close-blocks) + )) + +(defopt control-jumped-back + ((t) boolean #.(flags set safe) control-jumped-back-aux)) + +(defun control-jumped-back-aux(x) + (push 'ctl-push *control-stack*) + (wr-inline-call1 x "@0;CtlJumpedBack(ctl_TAGGED_CATCH,$0)")) + +(defopt push-unwind-protect + ;; The second argument is a function to call to do unwinding + ((t) t #.(flags safe set) push-unwind-protect-aux)) + +(defun push-unwind-protect-aux (x) +;; we use this function call to push something on control stack + (push (list 'unwind-protect (car x)) *control-stack*) + (or (and (eq (car *exit*) 'next) + (or (and (eq (cadr *control-stack*) 'avma-bind) + (eq (cdr *exit*) (cddr *control-stack*))) + (eq (cdr *exit*) (cdr *control-stack*)))) + (wfs-error)) + (setq *exit* (cons 'next *control-stack*)) + (wr-inline-call1 x "CtlUnwindPush($0)")) + + + + + + + + + + + + diff --git a/comp/fasdmacros.lsp b/comp/fasdmacros.lsp new file mode 100755 index 0000000..b00d2ac --- /dev/null +++ b/comp/fasdmacros.lsp @@ -0,0 +1,92 @@ +(in-package "BCOMP") +(provide 'FASDMACROS) +(defstruct (fasd (:type vector)) + stream + table + eof + direction + package + index + filepos + table_length + macro + ) + +(defvar *fasd-ops* +'( d_nil ;/* dnil: nil */ + d_eval_skip ; /* deval o1: evaluate o1 after reading it */ + d_delimiter ;/* occurs after d_listd_general and d_new_indexed_items */ + d_enter_vector ; /* d_enter_vector o1 o2 .. on d_delimiter make a cf_data with + ; this length. Used internally by akcl. Just make + ; an array in other lisps */ + d_cons ; /* d_cons o1 o2: (o1 . o2) */ + d_dot ; + d_list ;/* list* delimited by d_delimiter d_list,o1,o2, ... ,d_dot,on + ;for (o1 o2 . on) + ;or d_list,o1,o2, ... ,on,d_delimiter for (o1 o2 ... on) + ;*/ + d_list1 ;/* nil terminated length 1 d_list1o1 */ + d_list2 ; /* nil terminated length 2 */ + d_list3 + d_list4 + d_eval + d_short_symbol + d_short_string + d_short_fixnum + d_short_symbol_and_package + d_bignum + d_fixnum + d_string + d_objnull + d_structure + d_package + d_symbol + d_symbol_and_package + d_end_of_file + d_standard_character + d_vector + d_array + d_begin_dump + d_general_type + d_sharp_equals ; /* define a sharp */ + d_sharp_value + d_sharp_value2 + d_new_indexed_item + d_new_indexed_items + d_reset_index + d_macro + d_reserve1 + d_reserve2 + d_reserve3 + d_reserve4 + d_indexed_item3 ; /* d_indexed_item3 followed by 3bytes to give index */ + d_indexed_item2 ; /* d_indexed_item2 followed by 2bytes to give index */ + d_indexed_item1 + d_indexed_item0 ; /* This must occur last ! */ +)) + +(defmacro put-op (op str) + `(write-byte ,(or (position op *fasd-ops*) + (error "illegal op")) ,str)) + +(defmacro putd (n str) + `(write-byte ,n ,str)) + +(defmacro put2 (n str) + `(progn (write-bytei ,n 0 ,str) + (write-bytei ,n 1 ,str))) + +(defmacro put4 (n str) + `(progn (write-bytei ,n 0 ,str) + (write-bytei ,n 1 ,str) + (write-bytei ,n 2 ,str) + (write-bytei ,n 3 ,str) + )) + + +(defmacro write-bytei (n i str) + `(write-byte (the fixnum (ash (the fixnum ,n) >> ,(* i 8))) ,str)) + + + + diff --git a/comp/inline.lsp b/comp/inline.lsp new file mode 100755 index 0000000..3e4a745 --- /dev/null +++ b/comp/inline.lsp @@ -0,0 +1,599 @@ +(in-package "BCOMP") + +(eval-when (compile load eval) + +(defmacro opt (key opt) + `(nth ,(position key '(args return flag template )) ,opt)) +) +(eval-when (eval compile load) + +(defun flags-pos (flag &aux (i 0)) + (declare (fixnum i)) + (dolist (v *flags*) + (cond ((member flag v :test 'eq) + (return-from flags-pos i))) + (setq i (+ i 1))) + (error "unknown opt flag")) + + +(defvar *flags* + '((allocates-new-storage ans) ; might invoke gbc + (side-effect-p set) ; no effect on arguments + (constantp) ; always returns same result, + ;double eval ok. + (result-type-from-args rfa) ; if passed args of matching + ;type result is of result type + (is);; extends the `integer stack'. + (mv);; in a declaration, function may return MV. + (safe);; can be used at safety 3 + (notinline) + (touch-mv);;Invoking this may alter the MV locations. + (not-1-val) ;; obsoluete + (proclaim) ; do a proclaim. + )) +) +(defmacro flags (&rest lis &aux (i 0)) + (dolist (v lis) + (setq i (logior i (ash 1 (flags-pos v))))) + i) + + +(defun print-flag (n &optional safe) + (princ "#.(flags") + (dotimes (i (length *flags*)) + (if (logbitp i n) (format t " ~(~s~)"(car (last (nth i *flags*))) ))) + (if safe (princ " safe")) + (princ ")") + n) +;#+assist +(progn + ;; Convert old AKCL opts. + +(defun print-opt (sym prop &aux tem ) + (unless (get 'compiler::boolean 'comp-type) + (setf (get 'compiler::boolean 'comp-type) 'boolean) + (setf (get :dynamic-extent 'comp-type) 'dynamic-extent) + (setf (get 'compiler::fixnum-float 'comp-type) 'fix-or-sf-or-df)) + (cond ((setq tem (get sym prop)) + (format t "~%(defopt ~s" sym) + (let ((*print-case* :downcase)) + (dolist (v (reverse tem)) + (format t "~% (~s ~s " (mapcar 'comp-type (car v)) + (comp-type (second v))) + (print-flag (third v) (eq prop 'compiler::inline-always)) + (format t " ~s)" + (if (stringp (fourth v)) + (substitute #\$ #\# (fourth v)) + (fourth v))))) + (princ ")")))) + +(defun convert-old (&rest props &aux syms) + (sloop for pack in '(lisp si compiler) + do + (sloop for v in-package pack + when (sloop for w in props when (get v w) return t) + do (push v syms))) + (setq syms (sort syms #'(lambda (x y) (string-lessp (symbol-name x) + (symbol-name y))))) + (sloop for v in syms + do (sloop for w in props + do (print-opt v w)))) + +;(with-open-file (*standard-output* "/tmp/opts1.lsp" :direction :output) (convert-old 'compiler::inline-always 'compiler::inline-unsafe)) +;(load "/tmp/opts.lsp") +;(with-open-file (*standard-output* "/tmp/opts.lsp" :direction :output) (convert-old 'bcomp-opt)) + +) + +(defmacro defopt (fname &rest l) + ;; adds additional opts to the front. + ;; last added is most significant. + `(defopt1 ',fname ',l)) +(defun defopt1 (fname l) + (dolist (v l) + (let ((fl (opt flag v))) + (cond ((flag-p fl proclaim) + (proclaim1 `(ftype (function ,(opt args v) ,(opt return v)) ,fname))))) + (push v (get fname 'bcomp-opt)))) + +(defmacro flag-p (n flag) + `(logbitp ,(flags-pos flag) ,n)) + +(setf (get 'aref 'coerce-arg-types) '(t fixnum fixnum fixnum fixnum)) +(setf (get 'si::aset1 'coerce-arg-types) '(t fixnum )) + + + +(defun get-inline-template (fname fdecl arg-types ret-type type-wanted + &aux lis opt-ret tem + (opt-flag 0) + (mask (if (> *safety* 0) ;*unsafe* + #.(flags safe) + #.(flags)))) + (declare (fixnum mask opt-flag)) + (or (symbolp fname) (wfs-error)) + (setq lis (get fname 'bcomp-opt)) + (or lis (return-from get-inline-template nil)) + (cond ((eq type-wanted 'mv) + (setq type-wanted t) + (unless + (and fdecl (not (flag-p (second fdecl) mv))) + ;function proclaimed to return 1 arg + (setq mask (logior mask #. (flags mv) + ))))) + (when (setq tem (get fname 'coerce-arg-types)) + (sloop for v on arg-types + for w in tem + unless (eq w t) do (setf (car v) (type-and (car v) w)))) + (if (member type-wanted *immediate-types*) + (setq ret-type type-wanted)) + (sloop for opt in lis + do + (setq opt-ret (opt return opt)) + (setq opt-flag (opt flag opt)) + ;; check return return matches + do + (when + (and + (eql mask (logand opt-flag mask)) + (or (eql opt-ret t) + (eql opt-ret '*) + (comp-subtypep ret-type opt-ret))) + (sloop + for v on arg-types + for w on (opt args opt) + do + (cond ((eq (car w) '*) + (return-from get-inline-template opt)) + ((or (comp-subtypep (car v) (car w)) (return nil)))) + finally + (cond ((eq (car w) '*) + (return-from get-inline-template opt)) + ((and (null v) (null w)) + (return-from get-inline-template opt)))))) + ) + +(defun result-from-args (sym argl &aux arg-types) + (let ((tem (get sym 'bcomp-opt))) + (when tem + (sloop for opt in tem + when (flag-p (opt flag opt) rfa) + do (or arg-types (setq arg-types (mapcar 'result-type argl))) + (sloop + for v on arg-types + for w on (opt args opt) + do + (cond ((eq (car w) '*) + (return-from result-from-args (opt return opt))) + ((or (subtypep (car v) (car w)) (return nil)))) + finally + (cond ((eq (car w) '*) + (return-from result-from-args (opt return opt)) + ) + ((and (null v) (null w)) + (return-from result-from-args (opt return opt)) + )))) + (cond ((get sym 'arithmetic-contagion) + (or arg-types (setq arg-types (mapcar 'result-type argl))) + (setq tem + (or (member 'double-float arg-types ) + (member 'short-float arg-types))) + (if (and tem (sloop for v in arg-types + always (or (subtypep v 'fixnum) + (subtypep v 'double-float) + (subtypep v 'short-float)))) + (return-from result-from-args (car tem))) + ))))) + +(dolist (v '(* + - 1- 1+ /)) (setf (get v 'arithmetic-contagion) t)) + +;; symbol_value ;; the result depends on WHEN the form is evaluated. +;; list ;; Different invocations give different results with same +;; args, but order of eval is not important. Double EVAL is. +;; (add x y) ;; May be multiple eval'd. WHEN is not important. +;; (aref x i) ;; May be multiple eval'd. WHEN is important. +;; (set x 3) ;; May be multiple eval'd. Changes something in x. WHEN important. + +;; by 'not side-effect' in the property of an inline, means that it may be +;; multiple eval'd as long as there were no intervening operation which does +;; not have the no-side-effect property, and the results would be same EXCEPT, +;; that we might get a different storage location. + +;; by allocates-new-storage we mean that storage is allocated. + +;; A function which has no-side-effect and 'not allocates-new-storage' +;; must return eq results if multiple-eval'd with no intervening +;; no-side-effect function. + +;; Call a function foo and goo `unordered' if +;; (setq a (goo x y)) +;; (setq b (foo x y)) +;; Then no common lisp function could tell whether a or b was computed first. +;; The set of 'not side-effect' functions are unordered. + +;; This is the case for LIST, CONS, MAKE-ARRAY, APPEND, AREF, .. + +(defun inline-args (args arg-types &aux type-wanted) + ;; returns (cons arglist referred-vars) + ;; where REFERRED-VARS is a list of vars which will be eval'd + ;; during the inline writeout of the forms in ARGLIST. The + ;; list of these variables is necessary so that INLINE-CALL + ;; may produce this list. + + ;; we check thru each ARG, and any one which we find which does not + ;; meet the following criteria, is pre eval'd as a temp. + ;; 1: Are them selves inline calls to functions with 'not side-effect-p' flag + ;; 2: Refer to vars which are setq'd by subsequent inline-calls (since + ;; it will be to late to eliminate them then. Those setq's will actually + ;; be written out in the preevalling. ) + ;; 3: lexical or special vars unless the last arg. + + ;; eg (foo x (progn (setq x 3) 7)) would require saving initial value of x in a + ;; temp, because it is changed by a subsequent arg. + ;; In (foo (progn (setq x 3) 7) x (+ x y)) the second x and the (+ x y) + ;; could stay and be inlined. + ;; All user functions are presumed to have 'side-effect-p' + + (sloop for v on args with referred = (cons nil nil) + do (setf type-wanted + (or (equal arg-types '(*)) (pop arg-types))) + collect (inline-arg (car v) type-wanted (cdr v) referred) into all + finally (setf (car referred) all) + (return referred))) + +(defun function-constant-p (x) +;; a function which returns something which will be the SAME for a given +;; set of arguments, where SAME means that there would not be a way in common lisp +;; of distinguishing between two results of an invocation OTHER than using eq. + (member x '(+ * list cons))) + +(defun remaining-args-constant (rest &aux cd) + (sloop for v in rest + do + (cond ((atom v)) + ((eq (car v) 'var)) + ((eq (car v) 'call) + (setq cd (third v)) + (unless (and (function-constant-p (call-data-fname cd)) + (remaining-args-constant (call-data-arglist cd))) + (return nil))) + (t (return nil))) + finally (return t))) + +(defun is-var-changed (var subsequent-args &aux cd) + (sloop for v in subsequent-args + do + (cond ((or (atom v) (eq (car v) 'var) (eq (car v) 'dv)) nil) + ((not (plain-var-p var)) + (setq cd (third v)) + (unless (and + (eq (car v) 'call) + (function-constant-p (call-data-fname cd)) + (not (is-var-changed var (call-data-arglist cd)))) + (return t))) + ((typep (second v) 'desk) + (return (memq var (desk-changed-vars (second v))))) + (t (return t))))) + +(defun inline-arg(a type-wanted rest referred &aux referred-vars result n tem) + ;; a value which can be written inline as an arg, and + ;; sets referred-vars + ;; + (when (eq type-wanted 'fix-or-sf-or-df) + (let ((x (car (member (result-type a) '(fixnum short-float double-float))))) + (and x (setq type-wanted x)))) + + (when (eq type-wanted 'double_ptr) + (let ((v (get-temp 'double-float)) + (tem (inline-arg a 'double-float rest referred))) + (wr-set-inline-loc v tem) + (return-from inline-arg (list 'address v)))) + + (cond ((atom a) + (or (typep a 'var) (wfs-error)) + (setq result a) + (cond ((or (null rest) + (remaining-args-constant rest) + (and (plain-var-p a) + (not (is-var-changed a rest)))) + (push a (cdr referred))) + (t (setq result (get-temp (var-implementation-type a))) + (wr-nl result "=" a ";"))) + (or (eq (var-implementation-type a) type-wanted) + (setq result (list 'inline-loc type-wanted result)))) + ((eq (car a) 'var) ;a temp var + (setq result a) + (or (eq (third a) type-wanted) + (setq result (list 'inline-loc type-wanted result)))) + ((eq (car a) 'dv) + (setq result (add-data a)) + (or (eq t type-wanted) + (setq result (list 'inline-loc type-wanted result)))) + ((eq (car a) 'the) + (setq result (inline-arg (third a) type-wanted rest referred))) + ((eq (car a) 'call) + (setq result (inline-call a type-wanted )) + (setq tem nil) + (setf referred-vars (car result) + (car result) 'inline-call) + (let ((templ (cddr result)) + tem1) + (setq n (opt flag templ)) + (cond ( ;; need a temp: + (or (not (or (flag-p n constantp) + (and (not (flag-p n set)) + (not (flag-p n ans))))) + (and (typep (setq tem1 (fourth templ)) 'link) + (or (argd-flag-p (link-argd tem1) requires-nargs) + (argd-flag-p (link-argd tem1) requires-fun-passed)))) + (setq tem (get-temp type-wanted))) + (rest + (sloop for referred-var in referred-vars + when (is-var-changed referred-var rest) + do (setq tem (get-temp (opt return templ))) + (loop-finish)))) + (unless (null tem) + (setq referred-vars nil) + (wr-set-inline-loc tem result) + (setf result tem)) + (unless (eq (opt return templ) type-wanted) + (setq result + (list 'inline-loc type-wanted result))) + (if referred-vars + (setf (cdr referred) (nconc referred-vars (cdr referred)))) + )) + (t (setq result (get-temp type-wanted)) + (when *do-pending-open* + (setq *do-pending-open* nil)(open-block)) + (valex (list 'var result) (next-exit) (expr-b2 a)) + result)) + result + ) + +(defun constant-inline-fixnum(x &aux y) + (or (and (consp x) (eq (car x) 'inline-loc) + (eq (second x) 'fixnum) + (and (consp (setq y (third x))) + (eq (car y) 'dv) + (typep (third y) 'fixnum))) + (wfs-error)) + (third y)) + +(setf (get 'boole 'bo2) 'bo2-boole) + +(defun bo2-boole(a type-wanted arg-types) + (when (and (equal arg-types '(fixnum fixnum fixnum)) + (dv-p (car (call-data-arglist (third a))))) + (do-inline-call 'boole3 a 'fixnum))) + +(defun wr-inline-boole3 (iargs) + (wr-inline-call1 (cdr iargs) + (ecase (constant-inline-fixnum (car iargs)) + (#.boole-ior "(($0) | ($1))" ) + (#.boole-xor "(($0) ^ ($1))" ) + (#.boole-and "(($0) & ($1))" ) + (#.boole-eqv "(~(($0) ^ ($1)))" ) + (#.boole-nand "(~(($0) & ($1)))" ) + (#.boole-nor "(~(($0) | ($1)))" ) + (#.boole-andc1 "((~($0)) & ($1))" ) + (#.boole-andc2 "(($0) & (~($1)))" ) + (#.boole-orc1 "((~($0)) | ($1))" ) + (#.boole-orc2 "(($0) | (~($1)))" ) + (#.boole-clr "(0)" ) + (#.boole-set "(-1)" ) + (#.boole-1 "(($0))" ) + (#.boole-2 "(($1))" ) + (#.boole-c1 "(~($0))" ) + (#.boole-c2 "(~($1))" )))) + + +(defun do-inline-call (fname a type-wanted) + (inline-call (list 'call (second a) (make-call-data + fname + (call-data-arglist (third a)) nil nil)) + type-wanted)) + +(defun coerce-to-binary (sym dsk argl &aux first) + (setq first + `(call ,dsk ,(make-call-data sym (list (car argl)(second argl)) nil nil))) + (cond ((cddr argl) + (coerce-to-binary sym dsk (cons first (cddr argl)))) + (t first))) + +(defun bo2-coerce-to-binary (a type-wanted arg-types) arg-types + (let* ((form-type (desk-result-type (second a))) + (call-dat (third a)) + (arglist (call-data-arglist (third a)))) + (cond ((and (cddr arglist) + (or (not (eq type-wanted t)) + (not (eq form-type t)))) + (if (eq type-wanted 'mv) (setq type-wanted t)) + (inline-call (coerce-to-binary (call-data-fname call-dat) + (make-desk (type-and type-wanted + form-type)) + arglist) + type-wanted))))) + + +(dolist (v '(+ * - /)) (setf (get v 'bo2) 'bo2-coerce-to-binary)) + +(setf (get 'aref 'bo2) 'bo2-aref) + +(defun bo2-aref (a type-wanted arg-types &aux (cd (third a)) argl type size) arg-types + (setq argl (call-data-arglist cd)) + (setq type (result-type (car argl))) + (cond ((and + (= *safety* 0) + (eql 3 (length argl)) + (consp type) + (eq (car type) 'array) + (eq (second type) t) + (consp (setq size (third type))) + (typep (second size) 'fixnum)) + (if (eq type-wanted 'mv) (setq type-wanted t)) + (inline-call (list 'call (second a) + (make-call-data + 'aref-2d + (append argl + (list (get-object (second size)))) + nil nil)) + type-wanted)))) + + +(defun inline-call (a type-wanted &aux call-dat in-args template tem + (*exit* (next-exit))) + ;; The arg A is a (call ..) as returned from b1-walk. + ;; If TYPE-WANTED is NIL then we may need Mult Values. + ;; This function returns a list: + ;; (referred-vars inlined-args result-type flags fname-or-string) + ;; The REFERRED-VARS and RESULT-TYPE and FLAGS are necessary for + ;; recursive calls, while the FNAME-OR-STRING and INLINED-ARGS + ;; are used to actually write out the result. + (setq call-dat (third a)) + + (let* ((fname (call-data-fname call-dat)) + fdecl check + (arglist (call-data-arglist call-dat)) + (arg-types (mapcar 'result-type arglist)) + (form-type (desk-result-type (second a)))) + + + (cond ((and (setq tem (get fname 'bo2)) + (setq tem (funcall tem a type-wanted arg-types))) + (return-from inline-call tem))) + + + + (cond ((call-data-local-fun call-dat) + (setq check t) + (setq template (get-template-fdata + (second (second + (call-data-local-fun call-dat)))))) + ((setq template + (progn + (setq fdecl (function-declaration fname)) + (let ((ret (if fdecl (ret-from-argd (fdecl argd fdecl))))) + (cond (ret + (cond ((eq ret 'double_ptr) + (setq form-type (type-and 'double-float form-type))) + ((or (eq ret t)(eq ret '*))) + (t (setq form-type (type-and ret form-type))))))) + (get-inline-template fname fdecl + arg-types form-type type-wanted)))) + ((setq template (add-link-template fname fdecl + arg-types type-wanted)))) + ;; now we have template. + (when check + (sloop for v in (car template) with al = arglist + do + (cond ((eq v '*) (return t)) + ((null al) (comp-error "Too few args passed to ~a " fname)) + (t (pop al))))) + (cond ((flag-p (opt flag template)is ) + (sloop for v on *control-stack* + when (or (eq (car v) 'avma-bind) + (eq (car v) 'avma-bind-needed)) + do (setf (car v) 'avma-bind-needed) + (return nil) + finally (wfs-error)))) + + (setq in-args (inline-args arglist (opt args template))) + (list* (cdr in-args) ; the referred-vars + (car in-args) ; the arglist + template))) + +(defun add-link-template (fname fdecl arg-types type-wanted &aux tem link ans + (leng (length arg-types))) + (declare (fixnum leng)) + (setq tem (assoc fname *file-inline-templates*)) + (when tem + (setq link (fourth tem)) + (cond ((typep link 'link) + (cond ((< leng (argd-minargs (link-argd link))) + (setf (argd-minargs (link-argd link)) leng)) + ((> leng (argd-maxargs (link-argd link))) + (setf (argd-maxargs (link-argd link)) leng)) + (t nil)) + (if (eq type-wanted 'mv) (setf (argd-flag-p (link-argd link) sets-mv) t)))) + (return-from add-link-template (cdr tem))) + (let ((ret t) + (argl '(*)) + (flags #.(flags set ans mv)) + (argd 0) + link) + (declare (fixnum argd)) + (cond (fdecl + (setq argd (car fdecl)) + (setq argl (argl-from-argd argd)) + (setq ret (ret-from-argd argd)) + (setq flags (second fdecl))) + (t (setf (argd-minargs argd) (length arg-types)) + (setf (argd-maxargs argd) (length arg-types)) + (setf (argd-flag-p argd requires-nargs) t) + (setf (argd-flag-p argd sets-mv) t))) + (setq link (make-link fname fdecl)) + (setf (link-argd link) argd) + ;; we need the data object now, so make sure it gets in the vector + ;; in time + (add-data (get-object fname)) + (push (setq ans (list fname argl ret flags link)) *file-inline-templates*) + (cdr ans))) + +(defun get-template-fdata (fd &aux fstring tem) + ;; make a template for a local fdata + (or (typep fd 'fdata) (wfs-error)) + (cond ((setq tem (fdata-local-template fd)) + (return-from get-template-fdata tem))) + (let* ((vararg (vararg-p fd)) + (fdecl (fdata-function-declaration fd)) + (ll (fdata-ll fd))) + (unless fdecl + (setq fdecl + (increment-function-decl + `(function + , (nconc + (sloop for v in (ll &required ll) collect (value-type v)) + (if (ll &optional ll) + (cons '&optional + (sloop for v in (ll &optional ll) collect + (value-type (car v))))) + (if (or (ll &rest ll) (ll &key ll)) '(*) nil)) + ;; todo arrange that pickup ret type + ;; from fdata some day10q + *) + nil))) + + (setq fstring (format nil "L~a($@0)" (fdata-ind fd))) + (if vararg (setq fstring (format nil "(VFUN_NARGS = $#,~a)" fstring))) +; (wr-h (rep-type t) " L" (fdata-ind fd) "();") + ;; it is only fitting that a closure's template `format string' should in + ;; fact be a closure. Takes a closure to know a closure. + (cond ((fdata-closure-vars fd) + (let ((fdc fd) + (string fstring)) + (setf fstring #'(lambda (iargs) + (wr "(fcall.fun=" + (or (fdata-closure-self fdc) + (fdata-to-obj fdc)) ",") + (wr-inline-call1 iargs string) + (wr ")")))))) + (let ((ans + (list (argl-from-argd (fdecl argd fdecl)) (ret-from-argd (fdecl argd fdecl)) + (fdecl flag fdecl) fstring))) + (setf (fdata-local-template fd) ans) + ans))) + + + +(defun replace-inline-by-temp (x) + (let* ((type (result-type x)) + (tem (get-temp type))) + (wr-set-inline-loc tem x) + tem)) + + + + + + + diff --git a/comp/integer.doc b/comp/integer.doc new file mode 100755 index 0000000..7f5f708 --- /dev/null +++ b/comp/integer.doc @@ -0,0 +1,35 @@ + +1) b2-call (or anyone who calls inline-arg or inline-args) + will push an 'avma-bind onto the *control-stack* if it is there + is not one between where it is and the next tag. If it did the push, + then it will pop it off an leaving. If the 'avma-bind has been changed to + 'avma-bind-needed then + a) it will also set the *used-function-saved-avma* to be t if at outer scope + b) bind *do-restore-avma* to the point in the *control-stack* where we pushed + to 'avma-bind, for the benefit of unwind-set. + c)It is an error if the *value* var is of type GEN and the level is outer. + +2) Any call to an 'is' fun will cause the most recent 'avma-bind or 'avma-bind-needed +to 'avma-bind-needed + +3) unwind-set if doing a go or return must do the restore to the level appropriate +to the tag, if there is an intervening 'avma-bind-needed in the *control-stack* + +If not going to a tag then if *do-restore-avma* is set, then unwind to the +current avma level. current level is global_saved_avma if there is not an intervening +inner-avma on the stack. + +4) entering tagbody, if there is an 'avma-bind on the stack, then push an +'inner-avma and write { GEN Inner_avma= avma; ..}. + + + + + + + + + + + + diff --git a/comp/lambda.lsp b/comp/lambda.lsp new file mode 100755 index 0000000..c9c6d6f --- /dev/null +++ b/comp/lambda.lsp @@ -0,0 +1,38 @@ +(in-package "BCOMP") + +#| +(let ((a 3)) + (defun f0 (x) (+ x 2)) + (defun f1 (x) (setq a x) (+ x 2)) + (defun f2 (x &aux u) #'(lambda (y) (+ x y a u))) + (list #'f0 #'f1 #'f2 (f2 1) (f2 1))) + +f1 alters the a which the function f2 outputs. +each call to f2 makes a different closure variable x however. +There is only one closure variable a. + + (function (lambda ....)) + is a closure if in (lambda ....) there are references to the cross boundary + You get the list of such vars + + +A compiled closure will be + + struct closure + { object name; + .. + object *cldata; + short cldata_dim; + } + +MakeClosure(3,fn,argd,V1,V2,V3) + + would construct it, and the V1,V2,V4 would be the cons's whose cars + represent the closure variables. + inside the closure we will have this_cldata variable, and can reference + the variables by position for this closure. + Each time we enter a let or &aux or lambda variable which freshly binds + a closure variable, a new cons must be created. This cons is immediately + put in the accessor array for this closure. + +|# diff --git a/comp/lisp-decls.doc b/comp/lisp-decls.doc new file mode 100755 index 0000000..217dd9d --- /dev/null +++ b/comp/lisp-decls.doc @@ -0,0 +1,531 @@ +(in-package "BCOMP") +;first load the proclaims then get them: +;(setq lis (sort (sloop for v in-package 'lisp when (get v 'PROCLAIMED-FUNCTION-DECLARATION) collect v) #'(lambda (x y) (string-lessp (symbol-name x) (symbol-name y))))) + +;(sloop for v in lis when (setq tem (get v 'proclaimed-function-declaration)) do (format t "(~a ~a ~a " v (car tem)(second tem)) (print-flag (third tem))(princ ")") (unless (eq (second tem) '*) (princ " ;Mv touched?")) (terpri)) +(defmacro proclaim2 (name args res flag) + (progn (proclaim1 `(ftype (function ,args ,res) ,name)) + (setf (fdecl flag (get name 'proclaimed-function-declaration) ) + flag))) +(proclaim2 * (*) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 + (*) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 - (T *) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 / (T *) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 /= (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 1+ (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 1- (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 < (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 <= (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 = (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 > (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 >= (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 ABS (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 ACONS (T T T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 ACOS (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 ACOSH (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 ADJOIN (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 ADJUST-ARRAY (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 ADJUSTABLE-ARRAY-P (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 ALPHA-CHAR-P (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 ALPHANUMERICP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 APPEND (*) T #.(flags ans set )) ;Mv touched? +(proclaim2 APPLY (T T *) * #.(flags ans set mv touch-mv)) +(proclaim2 APROPOS (T *) * #.(flags ans set mv touch-mv)) +(proclaim2 APROPOS-LIST (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 AREF (T &optional fixnum fixnum fixnum fixnum *) T + #.(flags ans constantp)) +(proclaim2 si::aset1 (T fixnum t) T #.(flags ans set constantp)) + +(proclaim2 ARRAY-DIMENSION (T FIXNUM) FIXNUM #.(flags ans constantp)) ;Mv touched? +(proclaim2 ARRAY-DIMENSIONS (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 ARRAY-ELEMENT-TYPE (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 ARRAY-HAS-FILL-POINTER-P (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 ARRAY-IN-BOUNDS-P (T *) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 ARRAY-RANK (T) FIXNUM #.(flags ans constantp)) ;Mv touched? +(proclaim2 ARRAY-ROW-MAJOR-INDEX (T *) FIXNUM #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 ARRAY-TOTAL-SIZE (T) FIXNUM #.(flags ans constantp)) ;Mv touched? +(proclaim2 ARRAYP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 ASH (INTEGER FIXNUM) INTEGER #.(flags ans constantp)) ;Mv touched? +(proclaim2 ASIN (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 ASINH (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 ASSOC (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 ASSOC-IF (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 ASSOC-IF-NOT (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 ATAN (T *) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 ATANH (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 ATOM (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 BIT (T *) BIT #.(flags ans constantp)) ;Mv touched? +(proclaim2 BIT-AND (T T *) (ARRAY BIT) #.(flags ans set)) ;Mv touched? +(proclaim2 BIT-ANDC1 (T T *) (ARRAY BIT) #.(flags ans set)) ;Mv touched? +(proclaim2 BIT-ANDC2 (T T *) (ARRAY BIT) #.(flags ans set)) ;Mv touched? +(proclaim2 BIT-EQV (T T *) (ARRAY BIT) #.(flags ans set)) ;Mv touched? +(proclaim2 BIT-IOR (T T *) (ARRAY BIT) #.(flags ans set)) ;Mv touched? +(proclaim2 BIT-NAND (T T *) (ARRAY BIT) #.(flags ans set)) ;Mv touched? +(proclaim2 BIT-NOR (T T *) (ARRAY BIT) #.(flags ans set)) ;Mv touched? +(proclaim2 BIT-NOT (T *) (ARRAY BIT) #.(flags ans set)) ;Mv touched? +(proclaim2 BIT-ORC1 (T T *) (ARRAY BIT) #.(flags ans set)) ;Mv touched? +(proclaim2 BIT-ORC2 (T T *) (ARRAY BIT) #.(flags ans set)) ;Mv touched? +(proclaim2 BIT-VECTOR-P (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 BIT-XOR (T T *) (ARRAY BIT) #.(flags ans set )) ;Mv touched? +(proclaim2 BOOLE (FIXNUM INTEGER INTEGER) INTEGER #.(flags ans constantp)) ;Mv touched? +(proclaim2 BOTH-CASE-P (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 BOUNDP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 BREAK (*) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 BUTLAST (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 BYTE (FIXNUM FIXNUM) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 BYTE-POSITION (T) FIXNUM #.(flags ans constantp)) ;Mv touched? +(proclaim2 BYTE-SIZE (T) FIXNUM #.(flags ans constantp)) ;Mv touched? +(proclaim2 CAAAAR (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CAAADR (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CAAAR (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CAADAR (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CAADDR (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CAADR (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CAAR (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CADAAR (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CADADR (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CADAR (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CADDAR (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CADDDR (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CADDR (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CADR (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CAR (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CDAAAR (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CDAADR (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CDAAR (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CDADAR (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CDADDR (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CDADR (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CDAR (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CDDAAR (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CDDADR (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CDDAR (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CDDDAR (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CDDDDR (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CDDDR (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CDDR (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CDR (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CEILING (T *) * #.(flags ans set mv touch-mv)) +(proclaim2 CERROR (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 CHAR (T FIXNUM) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CHAR-CODE (T) FIXNUM #.(flags ans constantp)) ;Mv touched? +(proclaim2 CHAR-DOWNCASE (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CHAR-EQUAL (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 CHAR-GREATERP (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 CHAR-INT (T) FIXNUM #.(flags ans constantp)) ;Mv touched? +(proclaim2 CHAR-LESSP (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 CHAR-NAME (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CHAR-NOT-EQUAL (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 CHAR-NOT-GREATERP (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 CHAR-NOT-LESSP (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 CHAR-UPCASE (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CHAR/= (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 CHAR< (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 CHAR<= (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 CHAR= (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 CHAR> (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 CHAR>= (T *) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 CHARACTER (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CHARACTERP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 CIS (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CLEAR-INPUT (*) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CLEAR-OUTPUT (*) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CLOSE (T *) STREAM #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 CLRHASH (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 CODE-CHAR (FIXNUM) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 COERCE (T T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 COMPILE (T *) * #.(flags ans set mv touch-mv)) +(proclaim2 COMPILE-FILE (T *) * #.(flags ans set mv touch-mv)) +(proclaim2 COMPILED-FUNCTION-P (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 COMPLEX (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 COMPLEXP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 CONCATENATE (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 CONJUGATE (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CONS (T T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 CONSP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 CONSTANTP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 COPY-ALIST (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 COPY-LIST (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 COPY-READTABLE (*) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 COPY-SEQ (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 COPY-SYMBOL (T *) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 COPY-TREE (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 COS (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 COSH (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 COUNT (T T *) FIXNUM #.(flags ans constantp)) ;Mv touched? +(proclaim2 COUNT-IF (T T *) FIXNUM #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 COUNT-IF-NOT (T T *) FIXNUM #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 DECODE-UNIVERSAL-TIME (T *) * #.(flags ans set mv touch-mv)) +(proclaim2 DELETE (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 DELETE-DUPLICATES (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 DELETE-FILE (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 DELETE-IF (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 DELETE-IF-NOT (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 DENOMINATOR (T) INTEGER #.(flags ans constantp)) ;Mv touched? +(proclaim2 DEPOSIT-FIELD (INTEGER T INTEGER) INTEGER #.(flags ans set)) ;Mv touched? +(proclaim2 DESCRIBE (T *) * #.(flags ans set mv touch-mv)) +(proclaim2 DIGIT-CHAR (T *) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 DIGIT-CHAR-P (T *) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 DIRECTORY (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 DIRECTORY-NAMESTRING (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 DOCUMENTATION (T T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 DPB (INTEGER T INTEGER) INTEGER #.(flags ans set )) ;Mv touched? +(proclaim2 DRIBBLE (*) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 ED (*) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 EIGHTH (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 ELT (T FIXNUM) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 ENCODE-UNIVERSAL-TIME (T T T T T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 ENDP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 ENOUGH-NAMESTRING (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 EQ (T T) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 EQL (T T) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 EQUAL (T T) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 EQUALP (T T) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 ERROR (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 EVAL (T) * #.(flags ans set mv touch-mv)) +(proclaim2 EVENP (INTEGER) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 EVERY (T T *) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 EXP (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 EXPORT (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 EXPT (T T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 FBOUNDP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 FCEILING (T *) * #.(flags ans set mv touch-mv)) +(proclaim2 FFLOOR (T *) * #.(flags ans set mv touch-mv)) +(proclaim2 FIFTH (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 FILE-AUTHOR (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 FILE-LENGTH (STREAM) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 FILE-NAMESTRING (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 FILE-POSITION (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 FILE-WRITE-DATE (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 FILL (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 FILL-POINTER (T) FIXNUM #.(flags ans constantp)) ;Mv touched? +(proclaim2 FIND (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 FIND-ALL-SYMBOLS (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 FIND-IF (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 FIND-IF-NOT (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 FIND-PACKAGE (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 FIND-SYMBOL (T *) * #.(flags ans set mv touch-mv)) +(proclaim2 FINISH-OUTPUT (*) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 FIRST (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 FLOAT-DIGITS (T) FIXNUM #.(flags ans constantp)) ;Mv touched? +(proclaim2 FLOAT-PRECISION (T) FIXNUM #.(flags ans constantp)) ;Mv touched? +(proclaim2 FLOAT-RADIX (T) FIXNUM #.(flags ans constantp)) ;Mv touched? +(proclaim2 FLOAT-SIGN (T *) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 FLOATP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 FLOOR (T *) * #.(flags ans set mv touch-mv)) +(proclaim2 FMAKUNBOUND (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 FORCE-OUTPUT (*) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 FORMAT (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 FOURTH (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 FRESH-LINE (*) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 FROUND (T *) * #.(flags ans set mv touch-mv)) +(proclaim2 FTRUNCATE (T *) * #.(flags ans set mv touch-mv)) +(proclaim2 FUNCALL (T *) * #.(flags ans set mv touch-mv)) +(proclaim2 FUNCTIONP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 GCD (*) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 GENSYM (*) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 GENTEMP (*) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 GET (T T *) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 GET-DECODED-TIME NIL * #.(flags ans set mv touch-mv)) +(proclaim2 GET-DISPATCH-MACRO-CHARACTER (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 GET-INTERNAL-REAL-TIME NIL T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 GET-INTERNAL-RUN-TIME NIL T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 GET-MACRO-CHARACTER (T *) * #.(flags ans set mv touch-mv)) +(proclaim2 GET-OUTPUT-STREAM-STRING (STREAM) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 GET-PROPERTIES (T T) * #.(flags ans set mv touch-mv)) +(proclaim2 GET-SETF-METHOD (T *) * #.(flags ans set mv touch-mv)) +(proclaim2 GET-SETF-METHOD-MULTIPLE-VALUE (T *) * #.(flags ans set mv touch-mv)) +(proclaim2 GET-UNIVERSAL-TIME NIL T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 GETF (T T *) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 GETHASH (T T *) * #.(flags ans set mv touch-mv)) +(proclaim2 GRAPHIC-CHAR-P (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 HASH-TABLE-COUNT (T) FIXNUM #.(flags ans constantp)) ;Mv touched? +(proclaim2 HOST-NAMESTRING (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 IDENTITY (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 IMAGPART (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 IMPORT (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 IN-PACKAGE (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 INPUT-STREAM-P (STREAM) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 INSPECT (T) * #.(flags ans set mv touch-mv)) +(proclaim2 INTEGER-DECODE-FLOAT (T) * #.(flags ans set mv touch-mv)) +(proclaim2 INTEGER-LENGTH (INTEGER) FIXNUM #.(flags ans constantp)) ;Mv touched? +(proclaim2 INTEGERP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 INTERN (T *) * #.(flags ans set mv touch-mv)) +(proclaim2 INTERSECTION (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 ISQRT (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 KEYWORDP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 LCM (*) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 LDB (T INTEGER) INTEGER #.(flags ans set )) ;Mv touched? +(proclaim2 LDB-TEST (T INTEGER) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 LDIFF (T T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 LENGTH (T) FIXNUM #.(flags ans constantp)) ;Mv touched? +(proclaim2 LISP-IMPLEMENTATION-VERSION NIL T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 LIST (*) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 LIST* (T *) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 LIST-ALL-PACKAGES NIL T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 LIST-LENGTH (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 LISTEN (*) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 LISTP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 LOAD (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 LOG (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 LOGAND (*) INTEGER #.(flags ans constantp)) ;Mv touched? +(proclaim2 LOGANDC1 (INTEGER INTEGER) INTEGER #.(flags ans constantp)) ;Mv touched? +(proclaim2 LOGANDC2 (INTEGER INTEGER) INTEGER #.(flags ans constantp)) ;Mv touched? +(proclaim2 LOGBITP (FIXNUM INTEGER) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 LOGCOUNT (INTEGER) FIXNUM #.(flags ans constantp)) ;Mv touched? +(proclaim2 LOGEQV (*) INTEGER #.(flags ans constantp)) ;Mv touched? +(proclaim2 LOGIOR (*) INTEGER #.(flags ans constantp)) ;Mv touched? +(proclaim2 LOGNAND (INTEGER INTEGER) INTEGER #.(flags ans constantp)) ;Mv touched? +(proclaim2 LOGNOR (INTEGER INTEGER) INTEGER #.(flags ans constantp)) ;Mv touched? +(proclaim2 LOGNOT (INTEGER) INTEGER #.(flags ans constantp)) ;Mv touched? +(proclaim2 LOGORC1 (INTEGER INTEGER) INTEGER #.(flags ans constantp)) ;Mv touched? +(proclaim2 LOGORC2 (INTEGER INTEGER) INTEGER #.(flags ans constantp)) ;Mv touched? +(proclaim2 LOGTEST (INTEGER INTEGER) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 LOGXOR (*) INTEGER #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 LONG-SITE-NAME NIL T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 LOWER-CASE-P (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 MACHINE-INSTANCE NIL T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 MACHINE-TYPE NIL T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 MACHINE-VERSION NIL T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 MACRO-FUNCTION (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 MACROEXPAND (T *) * #.(flags ans set mv touch-mv)) +(proclaim2 MACROEXPAND-1 (T *) * #.(flags ans set mv touch-mv)) +(proclaim2 MAKE-BROADCAST-STREAM (*) STREAM #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 MAKE-CONCATENATED-STREAM (*) STREAM #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 MAKE-DISPATCH-MACRO-CHARACTER (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 MAKE-ECHO-STREAM (STREAM STREAM) STREAM #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 MAKE-HASH-TABLE (*) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 MAKE-LIST (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 MAKE-PACKAGE (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 MAKE-PATHNAME (*) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 MAKE-RANDOM-STATE (*) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 MAKE-SEQUENCE (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 MAKE-STRING (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 MAKE-STRING-INPUT-STREAM (T *) STREAM #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 MAKE-STRING-OUTPUT-STREAM NIL STREAM #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 MAKE-SYMBOL (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 MAKE-SYNONYM-STREAM (T) STREAM #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 MAKE-TWO-WAY-STREAM (STREAM STREAM) STREAM #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 MAKUNBOUND (T) T #.(flags ans set )) ;Mv touched? +(proclaim2 MAP (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 MAPC (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 MAPCAN (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 MAPCAR (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 MAPCON (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 MAPHASH (T T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 MAPL (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 MAPLIST (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 MASK-FIELD (T INTEGER) INTEGER #.(flags ans constantp)) ;Mv touched? +(proclaim2 MAX (T *) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 MEMBER (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 MEMBER-IF (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 MEMBER-IF-NOT (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 MERGE (T T T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 MERGE-PATHNAMES (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 MIN (T *) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 MINUSP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 MISMATCH (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 MOD (T T) T #.(flags ans touch-mv)) ;Mv touched? +(proclaim2 NAME-CHAR (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 NAMESTRING (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 NBUTLAST (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 NCONC (*) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 NINTERSECTION (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 NINTH (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 NOT (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 NOTANY (T T *) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 NOTEVERY (T T *) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 NRECONC (T T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 NREVERSE (T) T #.(flags ans set )) ;Mv touched? +(proclaim2 NSET-DIFFERENCE (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 NSET-EXCLUSIVE-OR (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 NSTRING-CAPITALIZE (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 NSTRING-DOWNCASE (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 NSTRING-UPCASE (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 NSUBLIS (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 NSUBST (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 NSUBST-IF (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 NSUBST-IF-NOT (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 NSUBSTITUTE (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 NSUBSTITUTE-IF (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 NSUBSTITUTE-IF-NOT (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 NTH (FIXNUM T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 NTHCDR (FIXNUM T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 NULL (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 NUMBERP (T) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 NUMERATOR (T) INTEGER #.(flags ans constantp)) ;Mv touched? +(proclaim2 NUNION (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 ODDP (INTEGER) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 OPEN (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 OUTPUT-STREAM-P (STREAM) BOOLEAN #.(flags ans constantp)) ;Mv touched? +(proclaim2 PACKAGE-NAME (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 PACKAGE-NICKNAMES (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 PACKAGE-SHADOWING-SYMBOLS (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 PACKAGE-USE-LIST (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 PACKAGE-USED-BY-LIST (T) T #.(flags ans constantp)) ;Mv touched? +(proclaim2 PAIRLIS (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 PARSE-INTEGER (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 PARSE-NAMESTRING (T *) * #.(flags ans set mv touch-mv)) +(proclaim2 PATHNAME (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 PATHNAME-DEVICE (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 PATHNAME-DIRECTORY (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 PATHNAME-HOST (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 PATHNAME-NAME (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 PATHNAME-TYPE (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 PATHNAME-VERSION (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 PEEK-CHAR (*) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 PHASE (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 PLUSP (T) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 POSITION (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 POSITION-IF (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 POSITION-IF-NOT (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 PRIN1 (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 PRIN1-TO-STRING (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 PRINC (T *) T #.(flags ans set )) ;Mv touched? +(proclaim2 PRINC-TO-STRING (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 PRINT (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 PROBE-FILE (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 RANDOM (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 RASSOC (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 RASSOC-IF (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 RASSOC-IF-NOT (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 RATIONAL (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 RATIONALIZE (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 RATIONALP (T) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 READ (*) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 READ-BYTE (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 READ-CHAR (*) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 READ-CHAR-NO-HANG (*) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 READ-DELIMITED-LIST (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 READ-FROM-STRING (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 READ-LINE (*) * #.(flags ans set mv touch-mv)) +(proclaim2 READ-PRESERVING-WHITESPACE (*) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 REALPART (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 REDUCE (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 REM (T T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 REMHASH (T T) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 REMOVE (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 REMOVE-DUPLICATES (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 REMOVE-IF (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 REMOVE-IF-NOT (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 REMPROP (T T) T #.(flags ans set )) ;Mv touched? +(proclaim2 RENAME-FILE (T T) * #.(flags ans set mv touch-mv)) +(proclaim2 RENAME-PACKAGE (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 REPLACE (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 REST (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 REVAPPEND (T T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 REVERSE (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 ROOM (*) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 ROUND (T *) * #.(flags ans set mv touch-mv)) +(proclaim2 RPLACA (T T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 RPLACD (T T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SBIT (T *) BIT #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SCALE-FLOAT (T T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SCHAR (T FIXNUM) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SEARCH (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SECOND (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SET (T T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SET-DIFFERENCE (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SET-DISPATCH-MACRO-CHARACTER (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SET-EXCLUSIVE-OR (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SET-MACRO-CHARACTER (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SET-SYNTAX-FROM-CHAR (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SEVENTH (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SHADOW (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SHADOWING-IMPORT (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SHORT-SITE-NAME NIL T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SIGNUM (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SIMPLE-BIT-VECTOR-P (T) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SIMPLE-STRING-P (T) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SIMPLE-VECTOR-P (T) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SIN (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SINH (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SIXTH (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SLEEP (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SOFTWARE-TYPE NIL T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SOFTWARE-VERSION NIL T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SOME (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SORT (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SPECIAL-FORM-P (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SQRT (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 STABLE-SORT (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 STANDARD-CHAR-P (T) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 STREAM-ELEMENT-TYPE (STREAM) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 STRING (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 STRING-CAPITALIZE (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 STRING-DOWNCASE (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 STRING-EQUAL (T T *) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 STRING-GREATERP (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 STRING-LEFT-TRIM (T T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 STRING-LESSP (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 STRING-NOT-EQUAL (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 STRING-NOT-GREATERP (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 STRING-NOT-LESSP (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 STRING-RIGHT-TRIM (T T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 STRING-TRIM (T T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 STRING-UPCASE (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 STRING/= (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 STRING< (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 STRING<= (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 STRING= (T T *) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 STRING> (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 STRING>= (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 STRINGP (T) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SUBLIS (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SUBSEQ (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SUBSETP (T T *) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SUBST (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SUBST-IF (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SUBST-IF-NOT (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SUBSTITUTE (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SUBSTITUTE-IF (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SUBSTITUTE-IF-NOT (T T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SUBTYPEP (T T) * #.(flags ans set mv touch-mv)) +(proclaim2 SVREF ((VECTOR T) FIXNUM) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SXHASH (T) FIXNUM #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SYMBOL-FUNCTION (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SYMBOL-NAME (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SYMBOL-PACKAGE (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SYMBOL-PLIST (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SYMBOL-VALUE (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 SYMBOLP (T) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 TAN (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 TANH (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 TENTH (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 TERPRI (*) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 THIRD (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 TREE-EQUAL (T T *) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 TRUENAME (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 TRUNCATE (T *) * #.(flags ans set mv touch-mv)) +(proclaim2 TYPE-OF (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 TYPEP (T T) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 UNEXPORT (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 UNINTERN (T *) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 UNION (T T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 UNREAD-CHAR (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 UNUSE-PACKAGE (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 UPPER-CASE-P (T) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 USE-PACKAGE (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 USER-HOMEDIR-PATHNAME (*) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 VALUES (*) * #.(flags ans set mv touch-mv)) +(proclaim2 VALUES-LIST (T) * #.(flags ans set mv touch-mv)) +(proclaim2 VECTOR (*) (VECTOR T) #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 VECTOR-POP (T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 VECTOR-PUSH (T T) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 VECTOR-PUSH-EXTEND (T T *) FIXNUM #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 VECTORP (T) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 WARN (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 WRITE (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 WRITE-BYTE (INTEGER STREAM) INTEGER #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 WRITE-CHAR (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 WRITE-LINE (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 WRITE-STRING (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 WRITE-TO-STRING (T *) T #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 Y-OR-N-P (*) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 YES-OR-NO-P (*) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? +(proclaim2 ZEROP (T) BOOLEAN #.(flags ans set touch-mv)) ;Mv touched? + + +(proclaim2 si::structure-ref (t t fixnum) t #.(flags ans)) +(proclaim2 si::structure-set (t t fixnum t) t #.(flags ans set)) + diff --git a/comp/macros.lsp b/comp/macros.lsp new file mode 100755 index 0000000..6d502fc --- /dev/null +++ b/comp/macros.lsp @@ -0,0 +1,79 @@ +(in-package "BCOMP") + +;(dolist-safe (a b) (foo a)) +(defmacro dolist-safe ((x l &optional res) &body body) + (let ((l1 (gensym)) + (l2 (gensym))) + `(let* ( + (,l1 ,l) + (,l2 ,l1) + ,x) + (loop + (cond ((consp ,l1) + (setq ,x (car ,l1) ,l1 (cdr ,l1)) + ,@body) + ((null ,l1) + (return ,res)) + (t (comp-error "expected a list ~a" ,l2)))))))) + +;; go through a list safely signalling an error if not a true list. +(def-loop-for in-list (var lis) + (let ((point (gensym "POINT")) + (l1 (gensym))) + `(with ,point with ,l1 with ,var initially (setf ,l1 (setf ,point ,lis)) + do(or (consp ,point) + (comp-error "Expected a list ~a " ,l1)) + (desetq ,var (car ,point)) + end-test (and (null ,point)(local-finish)) + increment (setf ,point (cdr ,point))))) + +(def-loop-for on-list (point lis) + (let ((l1 (gensym))) + `(with ,point with ,l1 initially (setf ,l1 (setf ,point ,lis)) + do(or (consp ,point) + (comp-error "Expected a list ~a " ,l1)) + end-test (and (null ,point)(local-finish)) + increment (setf ,point (cdr ,point))))) + + +(defmacro safe-cdr (x) + (if (symbolp x) `(progn (or (consp ,x)(null ,x) + (comp-error "expected list ~a" ,x)) + (cdr ,x)) + (let ((xx (gensym))) + `(let ((,xx ,x)) + (safe-cdr ,xx))))) + + +(defmacro memq (a l) `(member ,a,l :test 'eq)) +(defmacro valex (a b form) + (let (binds ) + (or (eq b '*exit*) (push (list '*exit* b) binds)) + (or (eq a '*value*) (push (list '*value* a) binds)) + `(let ,binds ,form))) + +(defsetf logbitp logstore) +(defmacro logstore ( i a val) + `(setf (ldb (byte 1 ,i) ,a) (if ,val 1 0))) + + + +(defmacro argd-minargs(x) + `(the fixnum (ldb (byte 6 0) (the fixnum ,x)))) +(defmacro argd-maxargs(x) + `(the fixnum (ldb (byte 6 9) (the fixnum ,x)))) +(defmacro argd-flags(x) + `(the fixnum (ldb (byte 3 6) (the fixnum ,x)))) +(defmacro argd-atypes(x) + `(the fixnum (ldb (byte 16 15) (the fixnum ,x)))) +(defmacro argd-flag-p (x name) + `(logbitp ,(+ 6 (position name + '(requires-nargs sets-mv + requires-fun-passed))) + (the fixnum ,x) + )) + + +(defmacro ll (key lambda-list) + `(nth ,(position key (cons '&required lambda-list-keywords)) ,lambda-list)) + \ No newline at end of file diff --git a/comp/makefile b/comp/makefile new file mode 100644 index 0000000..0f87fc1 --- /dev/null +++ b/comp/makefile @@ -0,0 +1,37 @@ + +LISP=../unixport/saved_kcl + +LOAD='(load "sysdef.lsp")(make::make :bcomp :compile t)' + +all: + echo ${LOAD} | ${LISP} + + +tests: + echo ${LOAD}'(load "try1")(load "../tests/all-tests.lsp")(in-package "BCOMP")(do-some-tests)' \ + '(test-sloop)' | ${LISP} + + +test1: + echo '(load "../tests/try-comp")' | ${LISP} + + +TFILES=src/makefile comp/makefile unixport/makefile o/makefile \ + h/enum.h src/kclobjs src/sobjs src/NewInit src/make-init + +tar: + (cd .. ; tar cvf - ${TFILES} src/sobjs src/*.c src/*.el newh/*.el src/makefile comp/*.lsp comp/*.doc newh/*.h newh/makefile | gzip -c > ${HOME}/`date '+acl-%y%m%d'`.tar.z) + +all-tests: + $(MAKE) + - $(MAKE) tests test1 + - (cd /u11/wfs/nqthm1 ; rm *.o ; $(MAKE) "LISP=nacl") + - (cd /u11/wfs/gabriel ; $(MAKE) "LISP=nacl") + +tests2: + $(MAKE) + - $(MAKE) tests test1 + - (cd /u11/wfs/nqthm1 ; rm *.o ; $(MAKE) "LISP=nacl") + + +-include ../makedefs diff --git a/comp/mangle.lsp b/comp/mangle.lsp new file mode 100755 index 0000000..d8ffa6a --- /dev/null +++ b/comp/mangle.lsp @@ -0,0 +1,116 @@ +(in-package "BCOMP") +;; Naming convention +;; {f | s | q | l} +;; where f = Function, s = Symbol , q = special form (Quote) , l= Lexical +;; eg fLcar, sLnil, fSallocate_internal,sLAstandard_outputA.qLprogn + +(eval-when (load eval compile) +(defvar *mangle-base* (make-array 128 :element-type 'character)) +(defvar *mangle-escapes* (make-array 128 :element-type 'character)) +(defmacro mangle-type (flag) `(position ',flag '(octal self special-escape))) +(defvar *mangle-escape* #\E) + +(sloop for i below 128 with tem + for ch = (code-char i) + + do (setf (aref *mangle-escapes* i) (code-char 0)) + (setf (aref *mangle-base* i) (code-char (mangle-type octal))) + (when (alphanumericp ch) (setf (aref *mangle-base* i) + (if (upper-case-p ch) (char-downcase ch) + (char-upcase ch))))) + +(sloop for (v ch) in + '((#\+ #\Q)(#\- #\_)(#\* #\A)(#\% #\P) + (#\; #\X)(#\. #\Z)(#\, #\Y) + (#\ #\E) + (#\@ #\B) + ) + do (setf (aref *mangle-base* (char-code v)) ch) + (setf (aref *mangle-base* (char-code v)) ch) + (setf (aref *mangle-base* (char-code (char-downcase ch))) + (code-char (mangle-type special-escape))) + (setf (aref *mangle-escapes* (char-code (char-downcase ch))) + (char-downcase ch))) +(sloop for i from (char-code #\0) to (char-code #\9) + for j from (char-code #\A) + do (setf (aref *mangle-escapes* i) (code-char j))) + +(defvar *mangle-out* (make-array 40 :element-type 'string-char :fill-pointer 0 + :adjustable t)) +(proclaim '(string *mangle-out* *mangle-escapes* *mangle-base*)) +(proclaim '(character *mangle-escape*)) +) + + +(defun mangle(string) + (let ((string + (if (symbolp string) (symbol-name string) + string))) + (declare (string string)) + (let ((n (length string)) (start 0)) + (declare (fixnum n)) + (unless (> (array-total-size *mangle-out*) + (the fixnum (* 4 n))) + (adjust-array *mangle-out* (* 4 n) :fill-pointer 0 )) + (cond ((and (> n 0) + (digit-char-p (aref string 0))) + (setf (aref *mangle-out* 0) *mangle-escape*) + (setf (aref *mangle-out* 1) + (aref *mangle-escapes* (char-code (aref string 0)))) + (setf (fill-pointer *mangle-out*) 2) + (incf start)) + (t (setf (fill-pointer *mangle-out*) 0))) + (sloop for i from start below n + do (mangle1 (aref string i))) + *mangle-out*))) + +(defun mangle1 (ch ) + (declare (character ch)) + (let* ((tem (aref *mangle-base* (char-code ch))) + (n (char-code tem)) + (out *mangle-out*)) + (declare (character tem)(fixnum n)) + (cond ((> n (mangle-type special-escape)) + (vector-push tem *mangle-out*)) + ((= n (mangle-type special-escape)) + (vector-push *mangle-escape* out) + (vector-push (aref *mangle-escapes* (char-code ch) )out)) + ((= n (mangle-type octal)) + (vector-push #.(char-upcase *mangle-escape*) out) + (let ((m (char-code ch))) + (vector-push (code-char + (the fixnum (+ (logand (the fixnum + (ash m -6)) 7) + (char-code #\0)))) + out) + (vector-push (code-char + (the fixnum (+ (logand (the fixnum + (ash m -3)) 7) + (char-code #\0)))) + out) + (vector-push (code-char + (the fixnum (+ (logand m 7) + (char-code #\0)))) + out))) + (t (wfs-error))))) + +#+how_to_unmangle ;; get next character and unmangle it. +(defun unmangle-next () + (let ((y (get-next))) + (cond ((alpha-char-p y) + (cond ((lower-case-p y) (upcase-char y)) + ((eql y *mangle-escape*) + (let ((n (get-next))) + (cond ((digit-char-p n) + (make-octal-char n (get-next) (get-next))) + ((upper-case-p n) + (code-char (+ (char-code #\0) (- n (char-code #\A))))) + (t n)))) + ((car (rassoc (list n) + '((#\+ #\Q)(#\- #\_)(#\* #\A)(#\% #\P) + (#\; #\X)(#\. #\Z)(#\, #\Y) + (#\e #\E))))) + (t (char-downcase n)))) + (t y)))) + + diff --git a/comp/opts-base.lsp b/comp/opts-base.lsp new file mode 100755 index 0000000..81320bc --- /dev/null +++ b/comp/opts-base.lsp @@ -0,0 +1,52 @@ +(in-package "BCOMP") + +(defopt NTH-MV + ((fixnum) t #.(flags safe constantp) + "(fcall.nvalues > $0 ? fcall.values[$0] : sLnil)")) + +(defopt LIST-MV + (() t #.(flags proclaim safe ans ) "ListVector(fcall.nvalues,&fcall.values[0])") + ;(() dynamic-extent #.(flags safe ans ) + ; "ON_STACK_LIST_VECTOR(fcall.nvalues,&fcall.values[0])") + ) + +;(defopt pop-control-stack +; (() t #.(flags safe set) "CtlPop")) + +(defopt progv-bind + ((t t) fixnum #.(flags set safe) "IprogvBind(#0,#1)")) + +(defopt do-throw + ((t)t #.(flags proclaim set safe) "Ido_throw(#0)")) + +(defopt unique-id + (() t #.(flags ans safe) "alloc_object(t_spice)")) + +(defopt pass-values + (() * #.(flags proclaim mv safe) "fcall.values[0]")) + +(defopt nlj-active-off + (()t #.(flags safe set) "nlj_active=0;VsTop = SaveVs ")) + +;(defopt nlj-active-off +; (()t #.(flags safe set) "nlj_active=0; ")) + + +(defopt assign-args + (( *) t #.(flags safe set) do-assign-args)) + +(defopt funcall + ((t *) t #.(flags set ) + "@0;(VFUN_NARGS=($#-1),fcall.fun=$0,(type_of($0)==t_afun||type_of($0)==t_closure) + && F_PLAIN($0->sfn.Argd) ? *($0->sfn.Body) : fcalln)($@1)")) +(proclaim1 '(ftype (function (*) t) si::make-structure)) +(defopt si::make-structure ((t *) t #.(flags ans safe) "ImakeStructure($#,$*0)")) + + + + + + + + + diff --git a/comp/opts.lsp b/comp/opts.lsp new file mode 100755 index 0000000..db4ffaa --- /dev/null +++ b/comp/opts.lsp @@ -0,0 +1,492 @@ +(in-package "BCOMP") + +(defopt * + ((t t) t #.(flags ans safe) "number_times($0,$1)") + ((fix-or-sf-or-df fix-or-sf-or-df) short-float #.(flags safe) "(double)($0)*(double)($1)") + ((fix-or-sf-or-df fix-or-sf-or-df) double-float #.(flags safe) "(double)($0)*(double)($1)") + ((integer integer) integer #.(flags rfa is safe) "mulii($0,$1)") + ((integer integer integer) integer #.(flags rfa is safe) "mulii($0,mulii($1,$2))") + ((fixnum integer) integer #.(flags rfa is safe) "mulsi($0,$1)") + ((fixnum fixnum) fixnum #.(flags safe) "($0)*($1)")) +(defopt + + ((t t) t #.(flags ans safe) "number_plus($0,$1)") + ((fix-or-sf-or-df fix-or-sf-or-df) short-float #.(flags safe) "(double)($0)+(double)($1)") + ((fix-or-sf-or-df fix-or-sf-or-df) double-float #.(flags safe) "(double)($0)+(double)($1)") + ((integer integer) integer #.(flags rfa is safe) "addii($0,$1)") + ((integer integer integer) integer #.(flags rfa is safe) "addii($0,addii($1,$2))") + ((fixnum fixnum) fixnum #.(flags safe) "($0)+($1)")) +(defopt - + ((t) t #.(flags ans safe) "number_negate($0)") + ((t t) t #.(flags ans safe) "number_minus($0,$1)") + ((fix-or-sf-or-df fix-or-sf-or-df) short-float #.(flags safe) "(double)($0)-(double)($1)") + ((fix-or-sf-or-df) short-float #.(flags safe) "-(double)($0)") + ((fix-or-sf-or-df) double-float #.(flags safe) "-(double)($0)") + ((fix-or-sf-or-df fix-or-sf-or-df) double-float #.(flags safe) "(double)($0)-(double)($1)") + ((integer integer) integer #.(flags rfa is safe) "subii($0,$1)") + ((integer) integer #.(flags rfa is safe) "subii(gzero,$0)") + ((fixnum fixnum) fixnum #.(flags safe) "($0)-($1)") + ((fixnum) fixnum #.(flags safe) "-($0)")) +(defopt / + ((fix-or-sf-or-df fix-or-sf-or-df) short-float #.(flags rfa safe) "(double)($0)/(double)($1)") + ((fix-or-sf-or-df fix-or-sf-or-df) double-float #.(flags rfa safe) "(double)($0)/(double)($1)") + ((fixnum fixnum) fixnum #.(flags ) "($0)/($1)") + ) +(defopt /= + ((t t) boolean #.(flags safe) "number_compare($0,$1)!=0") + ((fix-or-sf-or-df fix-or-sf-or-df) boolean #.(flags safe) "($0)!=($1)")) +(defopt 1+ + ((t) t #.(flags ans safe) "one_plus($0)") + ((fix-or-sf-or-df) short-float #.(flags safe) "(double)($0)+1") + ((fix-or-sf-or-df) double-float #.(flags safe) "(double)($0)+1") + ((fixnum) fixnum #.(flags safe) "($0)+1")) +(defopt 1- + ((t) t #.(flags ans safe) "one_minus($0)") + ((fixnum) fixnum #.(flags safe) "($0)-1") + ((fix-or-sf-or-df) short-float #.(flags safe) "(double)($0)-1") + ((fix-or-sf-or-df) double-float #.(flags safe) "(double)($0)-1")) +(defopt < + ((t t) boolean #.(flags safe) "number_compare($0,$1)<0") + ((integer integer) boolean #.(flags safe) "cmpii($0,$1)<0") + ((fix-or-sf-or-df fix-or-sf-or-df) boolean #.(flags safe) "($0)<($1)")) +(defopt <= + ((t t) boolean #.(flags safe) "number_compare($0,$1)<=0") + ((integer integer) boolean #.(flags safe) "cmpii($0,$1)<=0") + ((fix-or-sf-or-df fix-or-sf-or-df) boolean #.(flags safe) "($0)<=($1)")) +(defopt = + ((t t) boolean #.(flags safe) "number_compare($0,$1)==0") + ((integer integer) boolean #.(flags safe) "cmpii($0,$1)==0") + ((fix-or-sf-or-df fix-or-sf-or-df) boolean #.(flags safe) "($0)==($1)")) +(defopt > + ((t t) boolean #.(flags safe) "number_compare($0,$1)>0") + ((integer integer) boolean #.(flags safe) "cmpii($0,$1)>0") + ((fix-or-sf-or-df fix-or-sf-or-df) boolean #.(flags safe) "($0)>($1)")) +(defopt >= + ((t t) boolean #.(flags safe) "number_compare($0,$1)>=0") + ((integer integer) boolean #.(flags safe) "cmpii($0,$1)>=0") + ((fix-or-sf-or-df fix-or-sf-or-df) boolean #.(flags safe) "($0)>=($1)")) +(defopt APPEND + ((t t) t #.(flags ans safe) "append($0,$1)")) +(defopt aref-2d + (((array t) fixnum fixnum fixnum) t #.(flags) "@0;($0)->a.Body[($1)*($3)+$2]")) +(defopt AREF + ((t t) t #.(flags ans safe) "aref1($0,fixint($1))") + ((t fixnum) t #.(flags ans safe) "aref1($0,$1)") + ((t t) t #.(flags ans) "aref1($0,fix($1))") + (((array t) fixnum) t #.(flags) "($0)->v.Body[$1]") + (((array character) fixnum) character #.(flags rfa) "($0)->ust.Body[$1]") + (((array fixnum) fixnum) fixnum #.(flags rfa) "($0)->fixa.Body[$1]") + (((array unsigned-char) fixnum) fixnum #.(flags rfa) "($0)->ust.Body[$1]") + (((array signed-char) fixnum) fixnum #.(flags rfa) "SIGNED_CHAR(($0)->ust.Body[$1])") + (((array unsigned-short) fixnum) fixnum #.(flags rfa) "((unsigned short *)($0)->ust.Body)[$1]") + (((array signed-short) fixnum) fixnum #.(flags rfa) "((short *)($0)->ust.Body)[$1]") + (((array short-float) fixnum) short-float #.(flags rfa) "($0)->sfa.Body[$1]") + (((array long-float) fixnum) double-float #.(flags rfa) "($0)->lfa.Body[$1]") + ((t t t) t #.(flags ans) "@0;aref($0,fix($1)*($0)->a.Dims[1]+fix($2))") + (((array t) fixnum fixnum) t #.(flags) "@0;($0)->a.Body[($1)*($0)->a.Dims[1]+$2]") + (((array character) fixnum fixnum) character #.(flags rfa) "@0;($0)->ust.Body[($1)*($0)->a.Dims[1]+$2]") + (((array fixnum) fixnum fixnum) fixnum #.(flags rfa) "@0;($0)->fixa.Body[($1)*($0)->a.Dims[1]+$2]") + (((array short-float) fixnum fixnum) short-float #.(flags rfa) "@0;($0)->sfa.Body[($1)*($0)->a.Dims[1]+$2]") + (((array long-float) fixnum fixnum) double-float #.(flags rfa) "@0;($0)->lfa.Body[($1)*($0)->a.Dims[1]+$2]")) +(defopt ARRAY-TOTAL-SIZE + ((t) fixnum #.(flags rfa) "(($0)->st.Dim)")) +(defopt ARRAYP + ((t) boolean #.(flags safe) "@0;type_of($0)==t_array|| +type_of($0)==t_vector|| +type_of($0)==t_string|| +type_of($0)==t_bitvector")) +(defopt SYSTEM:ASET + ((t t t) t #.(flags set safe) "aset1($0,fixint($1),$2)") + ((t fixnum t) t #.(flags set safe) "aset1($0,$1,$2)") + ((t t t) t #.(flags set) "aset1($0,fix($1),$2)") + (((array t) fixnum t) t #.(flags set) "($0)->v.Body[$1]= ($2)") + (((array character) fixnum character) character #.(flags set rfa) "($0)->ust.Body[$1]= ($2)") + (((array fixnum) fixnum fixnum) fixnum #.(flags set rfa) "($0)->fixa.Body[$1]= ($2)") + (((array signed-short) fixnum fixnum) fixnum #.(flags set rfa) "((short *)($0)->ust.Body)[$1]=($2)") + (((array signed-char) fixnum fixnum) fixnum #.(flags set rfa) "(($0)->ust.Body)[$1]=($2)") + (((array unsigned-short) fixnum fixnum) fixnum #.(flags set rfa) "((unsigned short *)($0)->ust.Body)[$1]=($2)") + (((array unsigned-char) fixnum fixnum) fixnum #.(flags set rfa) "(($0)->ust.Body)[$1]=($2)") + (((array short-float) fixnum short-float) short-float #.(flags set rfa) "($0)->sfa.Body[$1]= ($2)") + (((array long-float) fixnum double-float) double-float #.(flags set rfa) "($0)->lfa.Body[$1]= ($2)") + ((t t t t) t #.(flags set) "@0;aset($0,fix($1)*($0)->a.Dims[1]+fix($2),$3)") + (((array t) fixnum fixnum t) t #.(flags set) "@0;($0)->a.Body[($1)*($0)->a.Dims[1]+$2]= ($3)") + (((array character) fixnum fixnum character) character #.(flags set rfa) "@0;($0)->ust.Body[($1)*($0)->a.Dims[1]+$2]= ($3)") + (((array fixnum) fixnum fixnum fixnum) fixnum #.(flags set rfa) "@0;($0)->fixa.Body[($1)*($0)->a.Dims[1]+$2]= ($3)") + (((array short-float) fixnum fixnum short-float) short-float #.(flags set rfa) "@0;($0)->sfa.Body[($1)*($0)->a.Dims[1]+$2]= ($3)") + (((array long-float) fixnum fixnum double-float) double-float #.(flags set rfa) "@0;($0)->lfa.Body[($1)*($0)->a.Dims[1]+$2]= ($3)")) +(defopt ash + ((fixnum fixnum) fixnum #.(flags ) "@1;($1 > 0 ? ($0) <<( $1 ): ($0) >> (-($1)))")) +(defopt ATOM + ((t) boolean #.(flags safe) "type_of($0)!=t_cons")) +(defopt BIT-VECTOR-P + ((t) boolean #.(flags safe) "(type_of($0)==t_bitvector)")) +(defopt BOOLE3 + ((fixnum fixnum fixnum) fixnum #.(flags rfa safe) wr-inline-boole3)) +(defopt BOUNDP + ((t) boolean #.(flags) "($0)->s.Bind!=OBJNULL")) +(defopt CAAAAR + ((t) t #.(flags) "Mcaaaar($0)")) +(defopt CAAADR + ((t) t #.(flags) "Mcaaadr($0)")) +(defopt CAAAR + ((t) t #.(flags) "Mcaaar($0)")) +(defopt CAADAR + ((t) t #.(flags) "Mcaadar($0)")) +(defopt CAADDR + ((t) t #.(flags) "Mcaaddr($0)")) +(defopt CAADR + ((t) t #.(flags) "Mcaadr($0)")) +(defopt CAAR + ((t) t #.(flags) "Mcaar($0)")) +(defopt CADAAR + ((t) t #.(flags) "Mcadaar($0)")) +(defopt CADADR + ((t) t #.(flags) "Mcadadr($0)")) +(defopt CADAR + ((t) t #.(flags) "Mcadar($0)")) +(defopt CADDAR + ((t) t #.(flags) "Mcaddar($0)")) +(defopt CADDDR + ((t) t #.(flags) "Mcadddr($0)")) +(defopt CADDR + ((t) t #.(flags) "Mcaddr($0)")) +(defopt CADR + ((t) t #.(flags) "Mcadr($0)")) +(defopt CAR + ((t) t #.(flags) "Mcar($0)")) +(defopt CDAAAR + ((t) t #.(flags) "Mcdaaar($0)")) +(defopt CDAADR + ((t) t #.(flags) "Mcdaadr($0)")) +(defopt CDAAR + ((t) t #.(flags) "Mcdaar($0)")) +(defopt CDADAR + ((t) t #.(flags) "Mcdadar($0)" )) +(defopt CDADDR + ((t) t #.(flags) "Mcdaddr($0)")) +(defopt CDADR + ((t) t #.(flags) "Mcdadr($0)")) +(defopt CDAR + ((t) t #.(flags) "Mcdar($0)")) +(defopt CDDAAR + ((t) t #.(flags) "Mcddaar($0)")) +(defopt CDDADR + ((t) t #.(flags) "Mcddadr($0)")) +(defopt CDDAR + ((t) t #.(flags) "Mcddar($0)")) +(defopt CDDDAR + ((t) t #.(flags) "Mcdddar($0)")) +(defopt CDDDDR + ((t) t #.(flags) "Mcddddr($0)")) +(defopt CDDDR + ((t) t #.(flags) "Mcdddr($0)")) +(defopt CDDR + ((t) t #.(flags) "Mcddr($0)")) +(defopt CDR + ((t) t #.(flags) "Mcdr($0)")) +(defopt CHAR + ((t t) t #.(flags ans safe) "elt($0,fixint($1))") + ((t fixnum) t #.(flags ans safe) "elt($0,$1)") + ((t t) t #.(flags) "code_char(($0)->ust.Body[fix($1)])") + ((t fixnum) character #.(flags rfa) "($0)->ust.Body[$1]")) +(defopt CHAR-CODE + ((character) fixnum #.(flags rfa safe) "($0)")) +(defopt SYSTEM:CHAR-SET + ((t t t) t #.(flags set safe) "elt_set($0,fixint($1),$2)") + ((t fixnum t) t #.(flags set safe) "elt_set($0,$1,$2)") + ((t t t) t #.(flags set) "@2;(($0)->ust.Body[fix($1)]=char_code($2),($2))") + ((t fixnum character) character #.(flags set rfa) "($0)->ust.Body[$1]= ($2)")) +(defopt CHAR/= + ((character character) boolean #.(flags safe) "($0)!=($1)") + ((t t) boolean #.(flags) "!eql($0,$1)") + ((t t) boolean #.(flags) "char_code($0)!=char_code($1)")) +(defopt CHAR< + ((character character) boolean #.(flags safe) "($0)<($1)")) +(defopt CHAR<= + ((character character) boolean #.(flags safe) "($0)<=($1)")) +(defopt CHAR= + ((t t) boolean #.(flags) "eql($0,$1)") + ((t t) boolean #.(flags) "char_code($0)==char_code($1)") + ((character character) boolean #.(flags) "($0)==($1)")) +(defopt CHAR> + ((character character) boolean #.(flags safe) "($0)>($1)")) +(defopt CHAR>= + ((character character) boolean #.(flags safe) "($0)>=($1)")) +(defopt CHARACTERP + ((t) boolean #.(flags safe) "type_of($0)==t_character")) +(defopt CODE-CHAR + ((fixnum) character #.(flags safe rfa) "($0)") + ((t) character #.(flags rfa) "fix($0)")) +(defopt CONS + ((t t) t #.(flags ans constantp safe) "make_cons($0,$1)") + ((t t) dynamic-extent #.(flags ans safe) "ON_STACK_CONS($0,$1)")) +(defopt CONSP + ((t) boolean #.(flags safe) "type_of($0)==t_cons")) +(defopt COS + ((double-float) double-float #.(flags rfa safe) "cos($0)")) +(defopt DIGIT-CHAR-P + ((character) boolean #.(flags safe) "@0; (($0) <= '9' && ($0) >= '0')")) +(defopt ELT + ((t t) t #.(flags ans safe) "elt($0,fixint($1))") + ((t fixnum) t #.(flags ans safe) "elt($0,$1)") + ((t t) t #.(flags ans) "elt($0,fix($1))")) +(defopt SYSTEM:ELT-SET + ((t t t) t #.(flags set safe) "elt_set($0,fixint($1),$2)") + ((t fixnum t) t #.(flags set safe) "elt_set($0,$1,$2)") + ((t t t) t #.(flags set) "elt_set($0,fix($1),$2)")) +(defopt ENDP + ((t) boolean #.(flags) "($0)==sLnil")) +(defopt EQ + ((t t) boolean #.(flags safe) "($0)==($1)") + ((fixnum fixnum) boolean #.(flags safe) "0")) +(defopt EQL + ((t t) boolean #.(flags safe) "eql($0,$1)") + ((fixnum fixnum) boolean #.(flags safe) "($0)==($1)")) +(defopt EQUAL + ((t t) boolean #.(flags safe) "equal($0,$1)") + ((fixnum fixnum) boolean #.(flags safe) "($0)==($1)")) +(defopt EQUALP + ((t t) boolean #.(flags safe) "equalp($0,$1)") + ((fixnum fixnum) boolean #.(flags safe) "($0)==($1)")) +(defopt EXPT + ((t t) t #.(flags ans safe) "number_expt($0,$1)") + ((integer integer) integer #.(flags is safe) "powerii($0,$1)") + ((fixnum fixnum) fixnum #.(flags safe) + (lambda (l &aux (x1 (car l))tem) + (if (and (consp x1) (eq (car x1) 'inline-loc) + (consp (setq tem (third x1)))(eq 'dv (car tem)) + (eql (third tem) 2)) + (wr-inline-call1 l "(1 << ($1))") + (wr-inline-call1 l "fixnum_expt($@0)"))))) +(defopt FILL-POINTER + ((t) fixnum #.(flags rfa) "(($0)->st.Fillp)")) +(defopt SYSTEM:FILL-POINTER-SET + ((t fixnum) fixnum #.(flags set rfa) "(($0)->st.Fillp)=($1)")) +(defopt FIRST + ((t) t #.(flags) "Mcar($0)")) +(defopt SYSTEM:FIXNUMP + ((t) boolean #.(flags safe) "type_of($0)==t_fixnum") + ((fixnum) boolean #.(flags safe) "1")) +(defopt FLOAT + ((fix-or-sf-or-df) double-float #.(flags safe) "((doublefloat)($0))") + ((fix-or-sf-or-df) short-float #.(flags safe) "((shortfloat)($0))")) +(defopt FLOATP + ((t) boolean #.(flags safe) "@0;type_of($0)==t_shortfloat||type_of($0)==t_doublefloat")) +(defopt FLOOR + ((fixnum fixnum) fixnum #.(flags rfa safe) "@01;($0>=0&&($1)>0?($0)/($1):ifloor($0,$1))")) +(defopt FOURTH + ((t) t #.(flags) "Mcadddr($0)")) +(defopt COMPILER::FP-OK + ((t) fixnum #.(flags set) "@0;(type_of($0)==t_stream? (int)(($0)->sm.Fp): 0 )") + ((stream) fixnum #.(flags set) "(($0)->sm.Fp)")) +(defopt GET + ((t t t) t #.(flags safe) "get($0,$1,$2)") + ((t t) t #.(flags safe) "get($0,$1,sLnil)")) +(defopt INTEGERP + ((t) boolean #.(flags safe) "@0;type_of($0)==t_fixnum||type_of($0)==t_bignum")) +(defopt KEYWORDP + ((t) boolean #.(flags safe) "@0;(type_of($0)==t_symbol&&($0)->s.Hpack==keyword_package)")) +(defopt COMPILER::LDB1 + ((fixnum fixnum fixnum) fixnum #.(flags safe) "((((~(-1 << ($0))) << ($1)) & ($2)) >> ($1))")) +(defopt LENGTH + ((t) fixnum #.(flags rfa safe) "length($0)") + (((array t)) fixnum #.(flags rfa) "($0)->v.Fillp") + (((vector character)) fixnum #.(flags rfa) "($0)->v.Fillp")) +(defopt LIST + ((t *) t #.(flags ans safe constantp) "list($#,$@0)") + (() t #.(flags ans safe constantp) "sLnil") + ) +(defopt LIST* + ((t *) t #.(flags ans safe constantp) "listA($#,$@0)")) +(defopt LISTP + ((t) boolean #.(flags constantp safe) "@0;type_of($0)==t_cons||($0)==sLnil")) +(defopt LOGAND + ((fixnum fixnum) fixnum #.(flags rfa safe) "(($0) & ($1))")) +(defopt LOGIOR + ((fixnum fixnum) fixnum #.(flags rfa safe) "(($0) | ($1))")) +(defopt LOGNOT + ((fixnum) fixnum #.(flags rfa safe) "(~($0))")) +(defopt COMPILER::LONG-FLOAT-P + ((t) boolean #.(flags safe) "type_of($0)==t_doublefloat")) +(defopt MAKE-LIST + ((fixnum) dynamic-extent #.(flags ans safe) "@0;(ALLOCA_CONS($0),ON_STACK_MAKE_LIST($0))")) +(defopt MAX + ((t t) t #.(flags safe) "@01;(number_compare($0,$1)>=0?($0):$1)") + ((fixnum fixnum) fixnum #.(flags rfa safe) "@01;($0)>=($1)?($0):$1")) +(defopt MIN + ((t t) t #.(flags safe) "@01;(number_compare($0,$1)<=0?($0):$1)") + ((fixnum fixnum) fixnum #.(flags rfa safe) "@01;($0)<=($1)?($0):$1")) +(defopt MINUSP + ((t) boolean #.(flags safe) "number_compare(small_fixnum(0),$0)>0") + ((fix-or-sf-or-df) boolean #.(flags safe) "($0)<0")) +(defopt MOD + ((fixnum fixnum) fixnum #.(flags rfa safe) "@01;($0>=0&&($1)>0?($0)%($1):imod($0,$1))")) +(defopt SYSTEM:MV-REF + ((fixnum) t #.(flags ans set safe) "(MVloc[($0)])")) +(defopt NCONC + ((t t) t #.(flags set safe) "nconc($0,$1)")) +(defopt NOT + ((t) boolean #.(flags safe) "($0)==sLnil") + ((boolean) boolean #.(flags safe) "!($0)")) +(defopt NREVERSE + ((t) t #.(flags ans set safe) "nreverse($0)")) +(defopt NTH + ((t t) t #.(flags safe) "nth(fixint($0),$1)") + ((fixnum t) t #.(flags safe) "nth($0,$1)") + ((t t) t #.(flags) "nth(fix($0),$1)")) +(defopt NTHCDR + ((t t) t #.(flags safe) "nthcdr(fixint($0),$1)") + ((fixnum t) t #.(flags safe) "nthcdr($0,$1)") + ((t t) t #.(flags) "nthcdr(fix($0),$1)")) +(defopt NULL + ((t) boolean #.(flags safe) "($0)==sLnil")) +(defopt NUMBERP + ((t) boolean #.(flags safe) "@0;type_of($0)==t_fixnum|| +type_of($0)==t_bignum|| +type_of($0)==t_ratio|| +type_of($0)==t_shortfloat|| +type_of($0)==t_doublefloat|| +type_of($0)==t_complex")) +(defopt PLUSP + ((t) boolean #.(flags safe) "number_compare(small_fixnum(0),$0)<0") + ((fix-or-sf-or-df) boolean #.(flags safe) "($0)>0")) +(defopt PRIN1 + ((t t) t #.(flags set safe) "prin1($0,$1)") + ((t) t #.(flags set safe) "prin1($0,sLnil)")) +(defopt PRINC + ((t t) t #.(flags set safe) "princ($0,$1)") + ((t) t #.(flags set safe) "princ($0,sLnil)")) +(defopt PRINT + ((t t) t #.(flags set safe) "print($0,$1)") + ((t) t #.(flags set safe) "print($0,sLnil)")) +(defopt PROBE-FILE + ((t) boolean #.(flags safe) "(file_exists($0))")) +(defopt SYSTEM:PUTPROP + ((t t t) t #.(flags set safe) "putprop($0,$1,$2)")) +(defopt COMPILER::QFEOF + ((fixnum) boolean #.(flags set) "(feof((FILE *)($0)))")) +(defopt COMPILER::QGETC + ((fixnum) fixnum #.(flags set rfa) "($0=getc((FILE *)($0)))")) +(defopt COMPILER::QPUTC + ((fixnum fixnum) fixnum #.(flags set rfa) "(putc($0,((FILE *)($1))))") + ((character fixnum) fixnum #.(flags set rfa) "(putc($0,((FILE *)($1))))")) +(defopt COMPILER::READ-BYTE1 + ((t t) t #.(flags ans set) "read_byte1($0,$1)")) +(defopt COMPILER::READ-CHAR1 + ((t t) t #.(flags ans set) "read_char1($0,$1)")) +(defopt REM + ((integer integer) integer #.(flags rfa is safe) "dvmdii($0,$1,-1)") + ((integer fixnum) fixnum #.(flags rfa is safe) "(FIXtemp=(int)dvmdii($0,stoi($1),-1), (signe(FIXtemp)> 0 ? (int) + ((GEN)FIXtemp)[2] : (signe(FIXtemp)< 0 ? -(int)((GEN)FIXtemp)[2] : 0)))") + #+truncate_use_c ((fixnum fixnum) fixnum #.(flags rfa safe) "($0)%($1)")) +(defopt REMPROP + ((t t) t #.(flags set safe) "remprop($0,$1)")) +(defopt REST + ((t) t #.(flags) "Mcdr($0)")) +(defopt REVERSE + ((t) t #.(flags ans safe) "reverse($0)")) +(defopt RPLACD + ((t t) t #.(flags set) "@0;($0->c.Cdr=$1,$0)")) +(defopt RPLACA + ((t t) t #.(flags set) "@0;($0->c.Car=$1,$0)")) +(defopt SCHAR + ((t t) t #.(flags ans safe) "elt($0,fixint($1))") + ((t fixnum) t #.(flags ans safe) "elt($0,$1)") + ((t t) t #.(flags rfa) "code_char(($0)->ust.Body[fix($1)])") + ((t fixnum) character #.(flags rfa) "($0)->ust.Body[$1]")) +(defopt SYSTEM:SCHAR-SET + ((t t t) t #.(flags set safe) "elt_set($0,fixint($1),$2)") + ((t fixnum t) t #.(flags set safe) "elt_set($0,$1,$2)") + ((t t t) t #.(flags set) "@2;(($0)->ust.Body[fix($1)]=char_code($2),($2))") + ((t fixnum character) character #.(flags set rfa) "($0)->ust.Body[$1]= ($2)")) +(defopt SECOND + ((t) t #.(flags) "Mcadr($0)")) +(defopt SYSTEM:SET-MV + ((fixnum t) t #.(flags ans set safe) "(MVloc[($0)]=($1))")) +(defopt COMPILER::SHIFT<< + ((fixnum fixnum) fixnum #.(flags safe) "(($0) << ($1))")) +(defopt COMPILER::SHIFT>> + ((fixnum fixnum) fixnum #.(flags safe) "(($0) >> (- ($1)))")) +(defopt COMPILER::SHORT-FLOAT-P + ((t) boolean #.(flags safe) "type_of($0)==t_shortfloat")) +(defopt COMPILER::SIDE-EFFECTS + (nil t #.(flags ans set safe) "Ct")) +(defopt SIN + ((double-float) double-float #.(flags rfa safe) "sin($0)")) +(defopt SYSTEM:SPUTPROP + ((t t t) t #.(flags set safe) "sputprop($0,$1,$2)")) +(defopt COMPILER::STACK-CONS + ((fixnum t t) t #.(flags safe) "(STcons$0.t=t_cons,STcons$0.m=0,STcons$0.Car=($1), + STcons$0.Cdr=($2),(object)&STcons$0)") + ((fixnum t t) t #.(flags safe) "(STcons$0.t=t_cons,STcons$0.m=0,STcons$0.Car=($1), + STcons$0.Cdr=($2),(object)&STcons$0)")) +(defopt STRING + ((t) t #.(flags ans safe) "coerce_to_string($0)")) +(defopt STRINGP + ((t) boolean #.(flags safe) "type_of($0)==t_string")) +(defopt SYSTEM:STRUCTURE-DEF + ((t) t #.(flags) "($0)->str.Def")) + +(defopt SYSTEM:STRUCTURE-REF + ((t t fixnum) t #.(flags ans safe) "structure_ref($0,$1,$2)") + ((t t fixnum) t #.(flags ) do-structure-ref) + (((struct fixnum) t fixnum) fixnum #.(flags ) do-structure-ref) + (((struct character) t fixnum) character #.(flags ) do-structure-ref) + (((struct double-float) t fixnum) double-float #.(flags ) do-structure-ref) + (((struct short-float) t fixnum) short-float #.(flags ) do-structure-ref) + ) + +(defopt SYSTEM:STRUCTURE-SET + ((t t fixnum t) t #.(flags set safe) "structure_set($0,$1,$2,$3)") + ((t t fixnum t) t #.(flags set ) do-structure-set) + (((struct fixnum) t fixnum fixnum) fixnum #.(flags set ) do-structure-set) + (((struct character) t fixnum character) character #.(flags set ) do-structure-set) + (((struct double-float) t fixnum double-float) double-float #.(flags set ) do-structure-set) + (((struct short-float) t fixnum short-float) short-float #.(flags set ) do-structure-set) + ) +(defopt SYSTEM:STRUCTUREP + ((t) boolean #.(flags safe) "type_of($0)==t_structure")) +(defopt COMPILER::SUBLIS1 + ((t t t) t #.(flags ans set safe) compiler::sublis1-inline)) +(defopt SVREF + ((t t) t #.(flags ans safe) "aref1($0,fixint($1))") + ((t fixnum) t #.(flags ans safe) "aref1($0,$1)") + ((t t) t #.(flags) "($0)->v.Body[fix($1)]") + ((t fixnum) t #.(flags) "($0)->v.Body[$1]")) +(defopt SYSTEM:SVSET + ((t t t) t #.(flags set safe) "aset1($0,fixint($1),$2)") + ((t fixnum t) t #.(flags set safe) "aset1($0,$1,$2)") + ((t t t) t #.(flags set) "(($0)->v.Body[fix($1)]=($2))") + ((t fixnum t) t #.(flags set) "($0)->v.Body[$1]= ($2)")) +(defopt COMPILER::SYMBOL-LENGTH + ((t) fixnum #.(flags rfa safe) "@0;(type_of($0)==t_symbol ? ($0)->s.Fillp :not_a_variable(($0)))")) +(defopt SYMBOL-NAME + ((t) t #.(flags ans safe) "symbol_name($0)")) +(defopt SYMBOL-PLIST + ((t) t #.(flags) "(($0)->s.Plist)")) +(defopt SYMBOLP + ((t) boolean #.(flags safe) "type_of($0)==t_symbol")) +(defopt TAN + ((double-float) double-float #.(flags rfa safe) "tan($0)")) +(defopt TERPRI + ((t) t #.(flags set safe) "terpri($0)") + (nil t #.(flags set safe) "terpri(sLnil)")) +(defopt THIRD + ((t) t #.(flags) "Mcaddr($0)")) +(defopt TRUNCATE + ((integer integer) integer #.(flags rfa is safe) "dvmdii($0,$1,0)") +#+truncate_use_c ((fixnum fixnum) fixnum #.(flags rfa safe) "($1)/($2)") + ((fix-or-sf-or-df) fixnum #.(flags safe) "(fixnum)($0)")) +(defopt COMPILER::VECTOR-TYPE + ((t fixnum) boolean #.(flags safe) "@0;(type_of($0) == t_vector && ($0)->v.Elttype == ($1))")) +(defopt VECTORP + ((t) boolean #.(flags safe) "@0;type_of($0)==t_vector|| +type_of($0)==t_string|| +type_of($0)==t_bitvector")) +(defopt WRITE-CHAR + ((t) t #.(flags set) "@0;(writec_stream(char_code($0),Vstandard_output->s.Bind),($0))")) +(defopt ZEROP + ((t) boolean #.(flags safe) "number_compare(small_fixnum(0),$0)==0") + ((integer) boolean #.(flags rfa safe) "lgef($0)==2") + ((fix-or-sf-or-df) boolean #.(flags safe) "($0)==0")) + + diff --git a/comp/proclaim.lsp b/comp/proclaim.lsp new file mode 100755 index 0000000..2274894 --- /dev/null +++ b/comp/proclaim.lsp @@ -0,0 +1 @@ +(in-package "BCOMP") diff --git a/comp/smash-oldcmp.lsp b/comp/smash-oldcmp.lsp new file mode 100755 index 0000000..384396e --- /dev/null +++ b/comp/smash-oldcmp.lsp @@ -0,0 +1,7 @@ + +(dolist (v '((compile-file . bcomp::compile-file1) + (proclaim . bcomp::proclaim1) + (disassemble . bcomp::disassemble1))) + (setf (symbol-function (car v)) (symbol-function (cdr v)))) + +(setq compiler::*cc* (si::concatenate 'string compiler::*cc* " -g ")) diff --git a/comp/stmt.lsp b/comp/stmt.lsp new file mode 100755 index 0000000..6b60c95 --- /dev/null +++ b/comp/stmt.lsp @@ -0,0 +1,407 @@ +(in-package "BCOMP") +;; pass 2 c compilation + +(defvar *value* + ;; indicates where to store the value of the current expression being + ;; computed. + ;; one of '(var ) + ;; '(mv ) + ;; '(ignore) + ) + +(setf (get 'nil 'dv) "sLnil") +(setf (get 't 'dv) "sLt") + +;; This function is the main dispatch. It causes writing out of the +;; code for x. An implicit *value* is set during this write out. +;; The code for doing that is in b2-call, b2-var, b2-return, and +;; any other primitives which might return a value. Note things like +;; progn, let, prog1, all just call expr-b2 on their last term. + +(defun expr-b2(x &aux fd) + (cond ((consp x) + (setq fd (get (car x) 'b2)) + (cond (fd (funcall fd x)) + (t (wfs-error)))) + ((typep x 'var) + (unwind-set x)) + ((eq x nil) + (unwind-set '(dv "sLnil" nil))) + ((eq x t) + (unwind-set '(dv "sLt" t))) + (t (wfs-error)))) + +(setf (get 'call 'b2) 'b2-call) + +(defun maybe-push-avma-bind () + (sloop for v on *control-stack* + do (cond ((or (eq (car v) 'avma-bind) + (eq (car v) 'avma-bind-needed)) + (return nil)) + ((typep (car v) 'label) + (loop-finish))) + finally + (push 'avma-bind *control-stack*) + (return *control-stack*))) + + +(defun b2-call (x &aux type-wanted (loc (second *value*)) tem avma-bind) + + (cond ((eq (car *value*) 'mv) (setq type-wanted 'mv)) + (loc + (cond ((typep loc 'var) + (setq type-wanted (var-type loc))) + ((and (consp loc) (eq (car loc) 'var)) + (setq type-wanted (third loc))) + (t (wfs-error)))) + (t (setq type-wanted t))) + + + (setq avma-bind (maybe-push-avma-bind)) + + (setq tem (cons 'inline-call + (cdr (inline-call x type-wanted )))) + (cond ((eq (car *value*) 'ignore) + (unwind-set tem avma-bind)) + (t (let ((*MV-N-VALUES-SET* *MV-N-VALUES-SET*)) + ;; We must communicate whether or not this inline-call + ;; sets multiple values, before we replace it by a temp + (when (unwind-stack-p (cdr *exit*)) + (if (flag-p (opt flag (cddr tem)) mv) + (setq *MV-N-VALUES-SET* t)) + (setq tem (replace-inline-by-temp tem))) + (unwind-set tem avma-bind)))) + ) + +(setf (get 'setq 'b2) 'b2-setq) + +(defun b2-setq (form &aux last) + ;;(setq desk var val var val..) + (do ((x (cddr form) (cddr x))) + ((null x)) + (setq last (car x)) + (valex (list 'var last) (next-exit) (expr-b2 (second x)))) + (unwind-set last)) + + + +(setf (get 'tagbody 'b2) 'b2-tagbody) + +(defun b2-tagbody (x &aux bod lab + all-labels it + (*blocks* 0) + (*control-stack* *control-stack*)) + (setq bod (third x)) + (dolist (v bod) + (when (and (consp v) (eq (car v) 'label)) + (setq lab (second v)) + (setf (label-ind lab) (next-label)) + (push lab all-labels))) + (sloop for v on *control-stack* + when (or (eq (car v) 'avma-bind) + (eq (car v) 'avma-bind-needed)) + do (push 'inner-avma *control-stack*) + (open-block) (wr "long InnerAvma=avma;") (return nil)) + + (setq *control-stack* (nconc all-labels *control-stack*)) + (sloop for v on bod do (setq it (car v)) + (valex '(ignore) (next-exit) (expr-b2 it))) + ;; this should do the unwinding to the outside frame. + (cond ((and (consp it) (or (eq (car it) 'return-from) + (eq (car it) 'go))) + ;;I don't even think this unwind-stack is necessary. + ;; I don't see hwo it will be reached. + (unwind-stack (cdr *exit*))) + (t (expr-b2 (get-object nil)))) + (close-blocks) + ) + +(setf (get 'label 'b2) 'b2-label) + +(defun b2-label (x &aux (lab (second x))) + (or (typep lab 'label) (wfs-error)) + (wr-label x) (wr ";")) + +(setf (get 'go 'b2) 'b2-go) + +(defun b2-go (x &aux lab) + (setq lab (cadr x)) + (let ((upto (member lab *control-stack* :test 'eq))) + (or upto + (wfs-error)) + (unwind-stack upto) + (wr-go lab))) + + +(setf (get 'if 'b2) 'b2-if) + +(defmacro ifb (x y) `(nth ,(position x '(test then else)) (cddr ,y))) + +(defun dv-p (x) (and (consp x) (eq (car x) 'dv))) + +(defun trans-if (x &aux test then else t-test t-then t-else + lab new (desk (second x))) +;; transform an if expression so that the TEST is neither an IF nor a CONSTANT. + + (desetq (test then else) (cddr x)) + (cond ((and (consp test) (eq (car test) 'if)) + (setq t-then (ifb then test) t-else (ifb else test) + t-test (ifb test test)) + (setq lab (make-label)) + (cond ((dv-p t-then)) + ((dv-p t-else) + (setq t-test (do-not t-test)) + (rotatef t-then t-else)) + (t (return-from trans-if x))) + (setq new + (cond ((null (third t-then)) + `(if ,desk,t-test (progn ,desk ((nlabel ,lab) ,else)) + (if ,desk ,t-else ,then (go ,lab) ))) + (t + `(if ,(second x),t-test (progn ,desk ((nlabel ,lab) ,then)) + (if ,desk ,t-else (go ,lab) ,else)))))) + ((dv-p test) + (setq new (if (third test) then else)) + (cond ((and (consp new) (eq (car new) 'if)) + (setq new (trans-if new)))) + (return-from trans-if new))) + (cond (new (trans-if new)) + (t x))) + +(defun do-not (x) + `(call ,(make-desk 'boolean) + ,(make-call-data 'not (list x) nil nil))) + +(setf (get 'nlabel 'b2) 'b2-nlabel) +(defun b2-nlabel (x) + (push (second x) *control-stack*) + (wr-label (second x)) (wr ";")) + +(defun b2-if (form &aux test then else (*control-stack* *control-stack*) avma-bind) + (setq form (trans-if form)) + (unless (and (consp form) (eq (car form) 'if)) + (return-from b2-if (expr-b2 form))) + (desetq (test then else) (cddr form)) + (setq avma-bind (maybe-push-avma-bind)) + (let ((tem (inline-arg test 'boolean nil (cons nil nil)))) + (when avma-bind + (cond ((eq (car avma-bind) 'avma-bind-needed) + (let ((tem1 (get-temp 'boolean))) + (valex (list 'var tem1) (next-exit) + (unwind-set tem avma-bind)))) + (t (remove-avma-bind avma-bind)))) + (wr-nl "if(" tem "){")) + (let ((*blocks* 0)) + (expr-b2 then) + (close-blocks) (wr "}")) + (unless (and + (or (atom else) (eq (car else) 'dv)) + (eq (car *value*) 'ignore) + (eq (car *exit*) 'next) + (not (unwind-stack-p (cdr *exit*)))) + (let ((*blocks* 0)) + (wr-nl "else ") + (open-block) + (expr-b2 else) + (close-blocks))) + ) + +(setf (get 'block 'b2) 'b2-block) + +(defun b2-block (x &aux sform block bod dsk + end-label + (*control-stack* *control-stack*)) + (desetq (sform dsk block bod) x) + (push block *control-stack*) + (setq end-label (make-label)) + (setf (block-exit block) + (cond ((eq (car *exit*) 'next) + (cons end-label (cdr *exit*))) + (t *exit*))) + (setf (block-value block) *value*) + (valex *value* (block-exit block) (progn-b2 bod)) + (cond ((label-ind end-label) + (wr-label end-label) (wr ";")))) + +(setf (get 'return-from 'b2) 'b2-return-from) + +(defun b2-return-from (x &aux block form tem) + (desetq (block form) (cddr x)) + (cond ((setq tem (member block *control-stack*)) + (valex (block-value block) (block-exit block) (expr-b2 form))) + (t (wfs-error)))) + +(setf (get 'the 'b2) 'b2-the) + +(defun b2-the (x) + (expr-b2 (third x))) + +(defun fdata-to-obj (fdat ) + (or (typep fdat 'fdata) (wfs-error)) + (or (fdata-ind fdat) (setf (fdata-ind fdat) (incf *next-function*))) + (cond ((fdata-closure-vars fdat) + (let ((args (mapcar #'(lambda (x) (list 'var (var-ind x))) + (fdata-closure-vars fdat)))) + (list 'inline-call (list* + (get-load-time-form 'si::%memory) + fdat + args) + '(*) t #.(flags ans) + (format nil "MakeClosure(~a,~a,$@0)" + (length (fdata-closure-vars fdat)) + (fdata-to-argd fdat) + )))) + (t + (list 'inline-call + (list fdat + (fdata-to-argd fdat) + (get-load-time-form 'si::%memory) + ) '(t fixnum t) t #.(flags ans constantp) + "MakeAfun($0,$1,$2)" )))) + +(setf (get 'pointer-to-funobj 'b2) 'b2-pointer-to-funobj) +(defun b2-pointer-to-funobj (x &aux ans tem) + (setq tem (second x)) + (cond ((and (consp tem) (eq (car tem) 'lambda-block)) + (setq tem (second tem)))) + (setq ans (fdata-to-obj tem)) + (unwind-set ans)) + +(setf (get 'lambda-block 'b2) 'b2-lambda-block) +(setf (get 'lambda 'b2) 'b2-lambda-block) + +(defun b2-lambda-block (x &aux result (*used-names* *used-names*)) + (let ((fdat (second x))) + (unless (fdata-ind fdat) + (setf (fdata-ind fdat) + (mangle-name (fdata-name fdat) 'function))) + (push (list 'local-function x) *local-funs*) +; (wr-h "static object " fdat "();") + (setq result (fdata-to-obj fdat)) + (unwind-set result))) + +(defun might-touch-mv (x) + ;; This needs expanding to handle functions like LIST,+, + ;; .. etc which do not touch mv + (not (or (atom x) (eq (car x) 'var) (eq (car x) 'dv)))) +(setf (get 'values 'b2) 'b2-values) + +(defun b2-values (x &aux (argl (third x)) avma-bind) + (cond ((eq (car *value*) 'mv) + (setq avma-bind (maybe-push-avma-bind)) + (let ((args (car (inline-args argl '(*))))) + (sloop for v on args + when (and (consp (car v)) (might-touch-mv (car v))) + do (setf (car v) (replace-inline-by-temp (car v)))) + (when (cdr args) + (wr-nl "{obj *MVptr = &fcall.values[1];" + "*MVptr =" (second args) ";") + (dolist (v (cddr args))(wr "*(++MVptr) = " v ";")) + (wr "}")) + (wr " fcall.nvalues=" (length args) ";") + (let ((*MV-N-VALUES-SET* t)) + (unwind-set (if args (car args) (get-object nil)) avma-bind)) + )) + (argl (expr-b2 (car argl))) + (t (expr-b2 (get-object nil))))) + +(setf (get 'call-set-mv 'b2) 'b2-call-set-mv) + +(defun b2-call-set-mv (x &aux form) +;; invoke form setting up multiple-values. +;; x == (call-set-mv desk form) + (setq form (third x)) + (valex `(mv (var "fcall.values[0]")) (next-exit) (expr-b2 form))) + +(setf (get 'progv 'b2) 'b2-progv) + +(defun b2-progv (x &aux binds body) + (desetq (binds body) (cddr x)) + (let ((tem (get-temp 'fixnum))) + (valex `(var ,tem) (next-exit) (expr-b2 binds)) + (let ((*control-stack* (cons `(progv-bind ,tem) *control-stack*))) + (progn-b2 body)))) + +(setf (get 'flet 'b2) 'b2-flet) + +(defun b2-flet (x &aux binds body fd) + (desetq (binds body) (cddr x)) + (sloop for v in binds + do + (setq fd (cadr (third v))) + (or (typep fd 'fdata) (wfs-error)) + (or (fdata-ind fd) (setf (fdata-ind fd) (incf *next-function*))) + (valex '(ignore) (next-exit) + (expr-b2 (third v))) + ) + (progn-b2 body)) + +(defun do-assign-args (x &aux reqs) + (setq reqs (ll &required (fdata-ll *fdata*))) + (or (eql (length x) (length reqs)) + (comp-error "Wrong number of args in call to ~a " (fdata-name *fdata*))) + (sloop for v in reqs + for val in x + do (wr-set-inline-loc (car v) val) + ) + ) + +(defvar *aet-types* + #(T STRING-CHAR SIGNED-CHAR FIXNUM SHORT-FLOAT DOUBLE-FLOAT + SIGNED-CHAR + UNSIGNED-CHAR SIGNED-SHORT UNSIGNED-SHORT)) + +(defun aet-type (i) (aref *aet-types* i)) + +(defun aet-c-type (type) + (ecase type + ((t) "object") + ((string-char signed-char) "char") + (fixnum "fixnum") + (unsigned-char "unsigned char") + (unsigned-short "unsigned short") + (signed-short "short") + (unsigned-short "unsigned short") + (double-float "double") + (short-float "float"))) + +(defun do-structure-ref (iargs &aux x name ind (index 0) sd) + (declare (fixnum index)) + (setq x (car iargs) name (second iargs) ind (third iargs)) + (or (and (consp ind) (eq (car ind)'inline-loc) + (dv-p (third ind))) (wfs-error)) + (setq index (third (third ind))) + (setq sd (get (third name) 'si::s-data)) + (or sd (wfs-error)) + (let* ((aet (aref (si::s-data-raw sd) index)) + (c-type (aet-c-type (aref *aet-types* aet))) + (pos (aref (si::s-data-slot-position sd) index))) + (wr "STREF(" c-type "," x "," pos")"))) + +(defun do-structure-set (iargs) + (let ((rargs (butlast iargs))) + (do-structure-ref rargs) + (wr " = " (car (last iargs))))) + +(defun si::setf-structure-access (struct type index newvalue) + (case type + (list `(si:rplaca-nthcdr ,struct ,index ,newvalue)) + (vector `(si:aset ,struct ,index ,newvalue)) + (t + (let ((sd (get type 'si::s-data))) + (when sd + (let ((res-type (comp-type(aet-type (aref (si::s-data-raw sd) index))))) + (cond ((eq res-type t) + `(si::structure-set ,struct ',type ,index ,newvalue)) + (t `(the ,res-type + (si::structure-set + (the (struct ,res-type),struct) ',type ,index + (the ,res-type ,newvalue))))))))))) + + +(setf (get 'eval-when 'b2) 'b2-eval-when) +(defun b2-eval-when + (x) + (progn-b2 (cddr x))) + + diff --git a/comp/sysdef.lsp b/comp/sysdef.lsp new file mode 100755 index 0000000..f8f9db1 --- /dev/null +++ b/comp/sysdef.lsp @@ -0,0 +1,23 @@ +(in-package "BCOMP" :use '("LISP" "SLOOP")) +(setq compiler::*cc* (concatenate 'string compiler::*cc* " -I../newh -I../h")) +(setf macros '(defmacro data defs macros wr)) +(require "MAKE" "../lsp/make.lisp") +(setf files '( var c-pass1 fasdmacros lambda top top1 + bo1 + inline top2 stmt exit + mangle + utils comptype)) +(proclaim '(optimize (speed 0))) +(setf (get :bcomp :make) + `((:serial ,@ macros) + ,@ files + (:progn (unless (get 'list 'bcomp-opt) + (load "lisp-decls.doc") + (load "opts.lsp")) + (load "opts-base.lsp") + ) + (:depends ,files ,macros))) +(setf (get :bcomp :source-path) "foo.lsp") +(setf (get :bcomp :object-path) "foo.o") + + diff --git a/comp/top.lsp b/comp/top.lsp new file mode 100755 index 0000000..88c1992 --- /dev/null +++ b/comp/top.lsp @@ -0,0 +1,92 @@ +(in-package "BCOMP") + +(eval-when (compile eval load) + +(defparameter *comp-vars* '(*c-output* *h-output* *lsp-input* *data-output* + *next-vv* + *data* + *data-table* + *hard-error* + *top-form* + *top-forms* + )) +(proclaim (cons 'special *comp-vars*)) +) + +(defun get-output-pathname (ext) + (declare (special input-pathname )) + (setq input-pathname (pathname input-pathname)) + (let ((dir (pathname-directory *default-pathname-defaults*))) + (make-pathname :directory + (or (pathname-directory input-pathname) + dir) + :name + (pathname-name input-pathname) + :type + ext))) + +(defvar *safety* 0 + ;; the safety level set by proclaim '(optimize (safety n)) + ) +(defvar *speed* 3 + ;; the desired speed level of the final code. The higher the + ;; speed the slower the compilation, but the faster the code runs. + ) +(proclaim '(fixnum *safety* *space* *speed*)) + +(defun open-out (ext flag) + (if (streamp flag) flag + (open (get-output-pathname ext) :direction :output))) + +(defun compile-file1 (input-pathname + &key output-file (load nil) (message-file nil) + system-p (c-debug t) + (c-file t) (h-file t)( data-file t) + (o-file t) + &aux (*package* *package*) + (*readtable* *readtable*)) + (declare (special input-pathname output-file c-debug)) + message-file system-p + (progv *comp-vars* '#. (make-list (length *comp-vars*)) + (unwind-protect + (progn + (setq *data-table* (make-hash-table :test 'eql)) + (setq *data* (list (make-array 50 :fill-pointer 0 ))) + (setq *lsp-input* (open input-pathname)) + + (execute-pass-1) + + (setq *c-output* (open-out "c" c-file)) + (setq *h-output* (open-out "h" h-file)) + (setq *data-output* (open-out "data" data-file)) + + (execute-pass-2) + + (compile-and-add-data-file o-file) + (let ((out (get-output-pathname "o"))) + (and output-file + (rename-file out output-file)) + (if load (load out)) + out) + + + ) + + ;; unwind protect forms: + (flet ((maybe-delete (f flag) + (cond ((and (streamp f) + (not (eq f flag))) + (close f) + (if (not flag) + (delete-file (pathname f))))))) + (maybe-delete *c-output* c-file) + (maybe-delete *h-output* h-file) + (maybe-delete *data-output* data-file) + (if (streamp *lsp-input*) (close *lsp-input*)) + )))) + + + + + + \ No newline at end of file diff --git a/comp/top1.lsp b/comp/top1.lsp new file mode 100755 index 0000000..20b56b5 --- /dev/null +++ b/comp/top1.lsp @@ -0,0 +1,137 @@ +(in-package "BCOMP") + + +(setf (get 'eval-when 't1) 't1eval-when) +(setf (get 'progn 't1) 't1progn) +(setf (get 'defun 't1) 't1top-macro) +(setf (get 'quote 't1) 't1ignore) +(setf (get 'defmacro 't1) 't1top-macro) +(setf (get 'defvar 't1) 't1top-macro) +(setf (get 'defparameter 't1) 't1top-macro) + + +(defun t1top-macro (x) + (let ((*top-form* x)) + (setq x (macroexpand x)) + (pass-1 x))) + + +(defun t1ignore (form) form nil) + +(defvar *changed* nil) +(defvar *FUNCTION-DECLS* nil) +(defvar *in-pass-1* nil) + +(defun execute-pass-1 ( &aux (eof '(nil)) tem + (*in-pass-1* t) + (*changed* + (make-array 40 :fill-pointer 0 :adjustable t))) + (sloop while (not (eq eof (setq tem (read *lsp-input* nil eof)))) + do (pass-1 tem)) + (setq *top-forms* (nreverse *top-forms*)) + ) + +(defvar *eval-when-defaults* :defaults) + +(dolist + (v '(si::*make-special si::*make-constant proclaim si::define-macro + make-package in-package shadow shadowing-import export unexport + si::define-structure + use-package unuse-package import provide require)) + (setf (get v 'eval-at-compile) t)) + + +;; return t if we do an eval, +(defun maybe-comp-eval (default-action form) + (or default-action + (and (symbolp (car form)) + (setq default-action (get (car form) 'eval-at-compile)))) + (cond + ((or (and default-action (eq :defaults *eval-when-defaults*)) + (and (consp *eval-when-defaults*)(member 'compile *eval-when-defaults* ))) + (comp-eval form) + t))) + +(defun t1eval-when (x &aux do-load do-compile) + (sloop for v in-list (second x) + do + (case v + (eval) + (load (setq do-compile t)) + (compile (setq do-compile t)) + (otherwise (comp-error "Bad arg to eval-when ~a" v)))) + (let ((*eval-when-defaults* (second x))) + (cond (do-compile (t1progn (cddr x)))))) + + +(defun walk-top-form (x &aux (*top-form* x)) + (let* (*contains-function* + (tem (walk-top x))) + (setq tem + (make-top-form + :lisp x + :walked tem + :funp *contains-function*)))) + +(defvar *variable-decls*) +(defvar *function-decls*) + +(defun pass-1 (x &aux *variable-decls* fd) + ;; fix for symbol macro + (cond ((atom x) (return-from pass-1 nil))) + (cond ((symbolp (car x)) + (cond ((setq fd (get (car x) 't1)) + (funcall fd x)) + ((macro-function (car x)) + (setq x (macroexpand x)) + (pass-1 x)) + (t + (maybe-comp-eval nil x) + (push (walk-top-form x) *top-forms*) + ))) + ((and (consp (car x)) (eq (caar x) 'lambda)) + (pass-1 `(funcall (function ,(car x)) ,@ (cdr x)))) + (t (comp-error "Unexpected form ~a" x)))) + +(setf (get 'si::defmacro* 'b1) 'b1-defmacro*) + + +(setf (get 'si::fset 't1) 't1-set) + +(setf (get 'mset 't1) 't1-set) + + +;; use for fset,define-macro and defvar +(defun t1-set (form &aux var val sform) + (maybe-comp-eval nil form) + (desetq (sform var val) form) + (or (and (consp var) (eq (car var) 'quote) + (symbolp (second var))) (error "expected a symbol")) + (push `(,sform ,var ,(walk-top-form val)) *top-forms*) + ) + + +(defun t1progn(form) + (sloop for v in-list form do (pass-1 v))) + +(defun b1-defmacro* (form where) + (let* ((tem (comp-eval form))) + (push 'list tem) + (b1-walk tem where))) + + +(defun comp-eval (form ) + (multiple-value-bind (error res) + (si::error-set `(eval ',form)) + (or error (return-from comp-eval res))) + (comp-error "Evaluation of ~s failed" form)) + + + + + + + + + + diff --git a/comp/top2.lsp b/comp/top2.lsp new file mode 100755 index 0000000..f9f12f7 --- /dev/null +++ b/comp/top2.lsp @@ -0,0 +1,1086 @@ +(in-package "BCOMP") +;; pass 2 c compilation + +(eval-when (compile eval load) + +(defparameter + *pass-2-vars* '( + *address-vector* + ;; At load time the index in *cfun-addresses* + ;; will be the address of the function. This *address-vector* is used + ;; at the end to create this vector in the .h file. + *next-data* + ;; is the next data index available + *next-label* + ;; is next label available number + *next-function* + ;; next function number as `3' in L3 + *blocks* + ;; number of '{' we have nested using open-block + *next-cvar* + ;; is next c variable number + *file-inline-templates* + *local-funs* + ;; are extra-local-funs to do + *local-inline-templates* + ;; inline templates + *top-level-closure-vars* + ;; call links. + *links* + ;; alist of forms to eval at load time and put in constant vector. + *load-time-forms* + ;; if not nil open a block + *do-pending-open* + )) + +(proclaim (cons 'special *pass-2-vars*)) + + ) + +(defun vararg-p (fd) + (let ((ll (fdata-ll fd))) + (or (ll &optional ll) + (ll &rest ll) + (ll &key ll)))) + +(eval-when (load compile eval) + +(defvar *illegal-names* (make-hash-table :size 100 :test 'equal)) +(unless +; (gethash "case" *illegal-names*) + (dolist (v'(;;C reserved words: + "do" "for" "sizeof" "typedef" "extern" "static" "auto" + "register" "void" "char" "short" "int" "long" "float" "double" + "signed" "unsigned" "struct" "union" "enum" "const" "volatile" "case" + "default" "if" "else" "switch" "while" "do" "for" "goto" "continue" + "break" + ;;varargs + "va_start" "va_end" "va_list" "va_dcl" "va_alist" + "stdin" "stdout" + "inline" + ;lisp specific: + "length" "elt" + "object" "car" "cdr" "list" + "number_plus" "number_times" "bool" fixnum" shortfloat" + "doublefloat" + )) + (setf (gethash v *illegal-names*) t))) + +(defvar *use-mangled-names* t) + +(defvar *used-names* + ;; bound by lets and constructions which bind variables + nil) + +(defun mangle-name (name name-type &aux p) + ;; NAME is a symbol which we wish to mangle, and name-type is + ;; 'var or 'function. + + (cond ((or (null *use-mangled-names*) (null name) + (null (setq p (symbol-package name)))) + (cond ((eq name-type 'var) *next-cvar*) + ((eq name-type 'function) + (incf *next-function*)) + (t (incf *next-cvar*)))) + (t (or (eq name-type 'var) + (setq p (get-package-shortname p))) + (let ((v (mangle name))) + (cond ((eq name-type 'var) + (do ((i 0) + (w v (setq w (format nil "V~a~a" (incf i) v)))) + ((not (or (gethash w *illegal-names*) + (member w *used-names* :test 'equal))) + (setq w (copy-seq w)) + (Push w *used-names*) + w))) + (t + (si::string-concatenate + (cond ((eq name-type 'function) "f") + ((eq name-type 'symbol) "s") + (t "u")) + p + v + ))))))) + +(defvar *package-names* nil) + +(defun get-package-shortname (x) + (or *package-names* + (setq *package-names* + `((,(find-package "LISP") . "L") + (,(find-package "SYSTEM") . "S") + (,(find-package "KEYWORD") . "K")))) + (let ((tem (cdr (assoc x *package-names*)))) + (cond (tem tem) + (t + (let((na (or (car (package-nicknames x)) + (package-name x)))) + (setq na (mangle (string-downcase na))) + (if (rassoc na *package-names*) + (error "You need to add another nickname: ~a is in use" na)) + (setq na (copy-seq na)) + (push (cons x na) *package-names*) + na))))) + +(defun next-cvar (&optional v &aux name) + (let ((n (incf *next-cvar*))) + (cond ((null v) n) + ((consp v) (setf (second v) n) v) + ((typep v 'var) + (cond ((var-special-p v) + (setf (var-special-p v) n)) + (t (setq name (var-name v)) + (setf (var-ind v) + (if (and name (symbol-package name)) + (copy-seq (mangle-name name 'var)) + n))))) + (t (wfs-error))))) + +(defun next-label() + (incf *next-label*)) + + (proclaim (cons 'special *pass-2-vars*)) + +(defun execute-pass-2 ( &aux (top *top-forms*) ) + (let #.*pass-2-vars* + (setq *next-data* 0 *next-label* 0 *next-function* 0 + *address-vector* (make-array 30 :adjustable t :fill-pointer 0)) + (terpri *c-output*) + (wr " +#include \"cmpinclude.h\" +#include \"" (pathname-name *h-output*) ".h\"") + (wr " + +init_code(){IdoInit(sizeof(VV)/sizeof(char *),VV);} + +") + (sloop for v in top do + (do-one-pass-2 v)) + (write-out-links) + (write-out-address-and-data) + (terpri *h-output*) + (wr-nl "") + ; (print *data*) + )) + +(defun do-one-pass-2 (x &aux df *local-funs* fd) + (cond ((consp x) + (cond ((and (symbolp (car x)) + (setq fd (get (car x) 'e2))) + (funcall fd x)) + (t (wfs-error)))) + ((typep x 'top-form) + (cond ((top-form-funp x) + (setq df (add-dummy-fun + (top-form-walked x)))) + (t (push-data 'd_eval_skip + (top-form-lisp x))))) + (t (wfs-error))) + (dolist (v *local-funs*) + (do-one-pass-2 v)) + (when df + (push-data 'd_eval_skip `(si::invoke ,df)))) + +(proclaim '(ftype (function () t) dummy-top)) + +(defun add-dummy-fun (x &aux ans) + ;; create a simple C function of no args which invokes the + ;; lisp form x in compiled form. returns the integer index + ;; of the *function-addresses* array where the C function's address resides. + (setq ans`(lambda-block ,(make-fun-data 'dummy-top nil nil nil nil x nil))) + (setf (fdata-ind (second ans)) (incf *next-function*)) + (e2-write-top (make-top-form :walked ans :funp t)) + (push-address (second ans)) + ) + +(defun car-get (x flag) + (and (consp x) (symbolp (car x)) + (get (car x) flag))) + + (setf (get 'write-top 'e2) 'e2-write-top) + +(defun e2-write-top (x &aux fd) + ;(print x) + ; for (lambda #S(fdata ..)) + ; sets the ind in #s(fdata ) and writes out the definition. + ; writes out the L20() { ..} + ; side .. + (cond ((and (typep x 'top-form) + (setq fd (car-get (top-form-walked x) 'e2))) + (return-from e2-write-top (funcall fd (top-form-walked x))))) + + (unless (and (consp x) (symbolp (car x))) + (wfs-error)) + (cond ((setq fd (get (car x) 'e2)) + (funcall fd x)) + (t (wfs-error))) + ) + + ;; writing out the .data file: + ;; each time something in *data-table* is first referenced we assign + ;; an index and put it in *data*. This normally happens while a function + ;; definition (and its local functions) are being written out. After + ;; that is written out (so all its constants are looked after) we push + ;; the (d_eval_skip (fset argd function-address-index "docstring")) + + (setf (get 'si::fset 'e2) 'e2fset) + (setf (get 'mset 'e2) 'e2fset) + +(defun push-address (x) + (let ((n (fill-pointer *address-vector*))) + (vector-push-extend x *address-vector*) + n)) + +(defun link-descriptor-from-decl (argl ret &aux (atypes 0) saw-optional + (min 0) (max 0) ) + (declare (fixnum min max atypes)) + (sloop for v in-list argl + when (eq v '&optional) + do (setq saw-optional t) + else + when (member v '#. (cons '* lambda-list-keywords)) + do (setq max 63) (return nil) + else + do +; (if (eq v 'short-float) (setq v 'double-float)) + (unless saw-optional + (incf min)) + (incf max) + (cond ((< max 7) + (setq atypes (+ atypes + (the fixnum (ash + (arg-type-code (promote-arg-type v)) + (the fixnum (* max 2))))) + )))) + ;; set the return type: + (setq atypes (logior atypes (arg-type-code (promote-arg-type ret)))) + + (let ((res 0)) + (declare (fixnum res)) + (setf res (make-argd min max atypes)) + (or (eql max min) + (setf (argd-flag-p res requires-nargs) t)) + (when (or (eql ret '*)(and (consp ret)(eq (car ret) 'values))) + (setf (argd-flag-p res sets-mv) t)) + res)) + +(defun make-argd (min max atypes &aux (result 0)) + (declare (fixnum min max atypes result)) + (setf (argd-minargs result) min) + (setf (argd-maxargs result) max) + (setf (argd-atypes result) atypes) + result) + +(defun describe-argd (argd) + (format t "~%min=~a,max=~a,atypes=~a,arg-types=~a,ret=~a +flags[set-mv=~a, requires-nargs=~a,requires-fun-passed=~a " + (argd-minargs argd) + (argd-maxargs argd) + (argd-atypes argd) + (argl-from-argd argd) + (ret-from-argd argd) + (argd-flag-p argd sets-mv) + (argd-flag-p argd requires-nargs) + (argd-flag-p argd requires-fun-passed))) + +;(defstruct arg-stepper (atype 0 :type fixnum)) +;(defvar *arg-stepper* (make-arg-stepper)) +; +;(defun init-arg-stepper (argd) (setf (arg-stepper-atype *arg-stepper*) +; (argd-atypes (the fixnum argd))) +; nil) +; +;(defun next-arg-type () +; (let* ((a (arg-stepper-atype *arg-stepper*)) +; (res (aref *promoted-arg-types* (the fixnum (logand a 3))))) +; (setf a (ash a -2)) +; (setf (arg-stepper-atype *arg-stepper*) a) +; res)) + +(defun argl-from-argd (argd &aux ans) + + (declare (fixnum argd)) + (let ((atypes (argd-atypes argd)) + (min (argd-minargs argd)) + (max (argd-maxargs argd)) + (i 0)) + (declare (fixnum atypes min max i)) + (sloop while (<= i 7) + do (setq atypes (ash atypes -2)) + (cond ((and (>= i min) (eql atypes 0)) + (if (< i max) (push '* ans)) + (return nil)) + ((eql i min) (push '&optional ans))) + (push (aref *promoted-arg-types* (logand atypes 3)) ans) + (setq i (+ i 1))) + (or (eq (car ans) '*) + (<= max 7) + (push '* ans)) + (nreverse ans))) + +(defun ret-from-argd (argd &aux ans) + (declare (Fixnum argd)) + (let ((tem (logand (argd-atypes argd) 3))) + (declare (fixnum tem)) + (setq ans (aref *promoted-arg-types* tem)) + (cond ((argd-flag-p argd sets-mv) '*) + (t ans)))) +) + +(defun fdata-to-argd(fdat &aux tem) + (cond ((setq tem (fdata-function-declaration fdat)) + (return-from fdata-to-argd (the fixnum(car tem))))) + (let* ((ll (fdata-ll fdat)) + (min (length (ll &required ll))) + (max (+ min (length (ll &optional ll)))) + (argd 0)) + (declare (fixnum min max argd)) + (cond ((or (ll &rest ll) + (ll &key ll)) + (setq max 63))) + (setq argd (make-argd min max 0)) + (setf (argd-flag-p argd requires-nargs ) (> max min)) + (setf (argd-flag-p argd sets-mv) t) + (setf (argd-flag-p argd requires-fun-passed)(fdata-closure-vars fdat)) + argd)) + +(defun get-install-form (fdat sym &aux tem) + (let ((argd (fdata-to-argd fdat)) + (n (push-address fdat))) + `(si::initfun ,sym ,n + ,argd,@ + (sloop for v in (fdata-closure-vars fdat) + do (setq tem (cdr (assoc v *top-level-closure-vars*))) + (or tem (setq tem (push-data 'dv (cons nil nil)))) + collect tem)))) + +(defun e2fset (form &aux sym fun fdat tem sform) + (desetq (sform sym fun) form) + (or (typep fun 'top-form) (wfs-error)) + (cond ((and (consp (setq tem (top-form-walked fun))) + (consp (cdr tem)) + (typep (setq fdat (cadr tem)) 'fdata)) + (e2-write-top fun) + (push-data 'd_eval_skip + (ecase sform + (si::fset + (get-install-form fdat sym)) + (mset + (cons 'si::initmacro (cdr (get-install-form fdat sym)))))) + ) + (t (setf (third form) (top-form-lisp (third form))) + + (push-data 'd_eval_skip form)))) + +(setf (get 'local-function 'e2) 'e2-local-function) + +(defun e2-local-function (x ) + (e2-write-top (second x)) + ) + + #+later + +(defun multiple-value-p (ret-type) + ;; return T if the ret-type is one for not a single value. + (or (eq ret-type '*) + (and (consp ret-type) (eq (car ret-type) 'values)))) + +(setf (get 'lambda-block 'e2) 'e2-lambda-block) +(setf (get 'lambda 'e2) 'e2-lambda-block) + +(defvar *temp-cvars* + ;; list of C Vars (ind type) which will be written out as the + ;; TEMP_CVARSi macro at the beginning. + ) + +(defvar *next-vcs* + ;; size of block of c stack reserved for this function + ;; declare by object Vcs[n]; + ) + +(defvar *exit* + ;; a CONS whose CAR + ;; 'function-return' indicates return from function after set + ;; 'next' control just continues + ;; a label struct do a goto this lavel + ;; Its CDR is a pointer into the control stack. The interval of the controlstack + ;; between this pointer and the current *control-stack*, must be unwound before jumping + ;; or setting a possibly special variable. + ) + +(defvar *closure-vars* nil) + +(defvar *fdata* nil) + +(defvar *used-function-saved-avma* nil + ;; is set to t if we need to + ;; save the entering avma address. +) + +(defun e2-lambda-block (x &aux (*next-cvar* 0) (*blocks* 0) fdat + *used-names* + (*next-vcs* 0) + (*next-label* 0) + *temp-cvars* + *closure-vars* + freturn-type + *control-stack* + ;; in this pass *control-stack* contains info about + ;; binding specials,saved-avma, tags so we know when + ;; we jump if we need a setjmp, or if we need to unwind. + ;; also for function-return. + *alloc-decls* + *fdata* + *used-function-saved-avma* + ) + (declare (special *fdata*)) + (setq fdat (second x)) + (setq *fdata* fdat) + (unless (fdata-ind fdat) + (setf (fdata-ind fdat) + (mangle-name (fdata-name fdat) 'function))) + (setq *closure-vars* (fdata-closure-vars fdat)) + + (wr-comment "function definition: " (fdata-name fdat)) + (wr" +static " (rep-type (setq freturn-type (function-return-type fdat))) +" " fdat"(") + (wr-h "static " (rep-type freturn-type) fdat "() ;"); + (write-args-and-open (fdata-ll fdat) (fdata-closure-vars fdat)) + (if (eq freturn-type 'double_ptr)(setq freturn-type 'double-float)) + (let* ((var (get-temp freturn-type)) + (value `(,(if (eq freturn-type 'mv) 'mv 'var) ,var))) + (valex value `(function-return ,var) (expr-b2 (fdata-form fdat)))) + (close-blocks) + (wr-h-temp-vars) + ;; This var is shared elsewhere and we want new reference mechanism. + (dolist (v *closure-vars*) (setf (var-ind v) nil)) + (when (ll &key (fdata-ll fdat)) + (let ((tem (push-address (list 'VK (fdata-ind fdat) )))) + (push-data 'd_eval_skip `(si::set-key-struct ,tem)))) + ) + +(defun wr-h-temp-vars( &aux type v) + (let ((*c-output* *h-output*)) + (wr " +#define TEMP_VARS" *fdata*) + (cond (*used-function-saved-avma* + (wr " long FunctionEntryAvma = avma;"))) + (dolist (w *temp-cvars*) + (let ((t1 (or (second w) t))) + (setq v (car w)) + (cond ((eq type t1) + (wr " ,V" v) ) + (t (or (null type) + (wr ";")) + (setq type t1) + (format *h-output* " ~a V~a" + (rep-type type) v))) + (cond ((eq type 'integer) + (format *h-output* "= 0,V~aalloc" v) + )) + )) + (and *temp-cvars* (format *h-output* ";")) + (unless (eql *next-vcs* 0) + (format *h-output* " object Vcs[~a];" *next-vcs*)) + )) + +(defun open-block () + (incf *blocks*) + (wr-nl "{")) + +(defun close-blocks() + (loop (if (<= *blocks* 0) (return nil)) + (wr "}")(incf *blocks* -1))) + +(defun rep-type (type) + (cond ((stringp type) (return-from rep-type type))) + (case type + ((character fixnum boolean) "int ") + ((gen integer) "GEN ") + (short-float "float ") + (double-float "double ") + (double_ptr "DoublePtr ") + (otherwise "object "))) + +(defun bind-special (var val) + (push 'bdsp *control-stack*) + ; (incf *bdsp*) + (or (var-ind var) (setf (var-ind var) (get-object (var-name var)))) + (wr-nl "BdSp("(var-ind var)","(list 'inline-loc t val)");") + ) + +(defun b2-bind-var (w v) + (cond + ((typep w 'var) + (cond + ((var-special-p w) + (bind-special w v)) + ((var-clb w) + (wr-nl) + (wr-vind (var-ind w)) + (wr "=MakeClosVar(" v ");") + (or (var-ind w) (wfs-error)) + ) + ((and (consp v) (eq (car v) 'var) + (eql (second v) (var-ind w)))) + (t + (wr-set-inline-loc w v)))) + + ;; save writing V3=V3 + ((and (consp w) (eq (car w) 'var)) + (cond ((and (typep v 'var) (eql (second w) (var-ind v)))) + (t (wr-set-inline-loc w v)))) + (t (wfs-error) + ;(wr-nl w "=" v ";") + ))) + +(defun b2-bind-var-b2 (var val &aux tem) + ;; like b2-bind-var-b2, but does a b2 eval on its second arg. + (if (plain-var-p var) (setq tem var ) (setq tem (get-temp t))) + (valex (list 'var tem) (next-exit) (expr-b2 val)) + (or (eq tem var) (b2-bind-var var tem))) + +(defun assign-reqds-and-optionals (ll fdat &aux (atypes 0) var tem type + (did-required nil) + (lis (ll &required ll))) + (declare (fixnum atypes)(boolean did-required)) + (let ((fdecl (fdata-function-declaration fdat))) + (cond (fdecl (setq atypes (argd-atypes(fdecl argd fdecl)))))) + (tagbody + again + (sloop for v on lis with vtype + do (setq var (if did-required (caar v) (car v))) + (setq type (aref *promoted-arg-types* (logand (setq atypes (ash atypes -2)) 3))) + (setq vtype (var-implementation-type var)) + (cond ((or (eq type vtype) + (eql (rep-type type) (rep-type vtype))) + (setq tem var)) + (t + (setq tem nil) + (cond ((plain-var-p var) + (next-cvar var) + (push var *alloc-decls*))))) + (setf (car v) (cons (list 'var (next-cvar tem) type) (car v)))) + (unless did-required + (setq did-required t) + (setq lis (ll &optional ll)) + (go again)) + )) + + ;; if not nil try to allocate all rest args on the c stack. + +(defun wr-decl-var (var) + (cond ((typep var 'var) + (if (var-volatile var) (wr "VOL ")) + (let ((type (var-type var))) + (cond ((eq type 'integer) + (wr "IDECL("var","var"__space,"var"__alloc);")) + (t + (wr (rep-type type) " ") + (wr-vind (var-ind var))(wr ";"))))) + ((and (consp var) (eq (car var) 'var)) + (wr (if (third var) (rep-type (third var)) + "object ") var ";")) + (t (wfs-error)))) + +(defvar *rest-on-stack* nil) + +(defvar *alloc-decls* nil) + +(defun write-args-and-open(ll closure-vars &aux reqds varargp va-start labels + deflt rest-var (fdat *fdata*) tem + (cfun (fdata-ind fdat))) + (assign-reqds-and-optionals ll fdat) + (setq reqds (ll &required ll)) + (wr-list (mapcar 'car reqds)) + (cond ((vararg-p fdat)(setq varargp t) + (if reqds (wr ",")) + (wr "va_alist) +")) + (t (wr ") +"))) + (sloop for v in reqds do (wr-decl-var (car v))) + (cond (varargp (wr "va_dcl "))) + (incf *blocks*) + (wr " +{ TEMP_VARS" fdat" + ") + (sloop for v in *alloc-decls* do (wr-decl-var v)) + (setq *alloc-decls* nil) + + ;; we must actually have the pointers in our function point to the closure cells. + ;; Otherwise if noone keeps a pointer to the closure itself during the call, + ;; the closure might be gc'd and the variables themselves be unprotected. + + (when closure-vars + (dolist (v closure-vars) + (allocate-var v 'kw)) + (wr "VOL object CLfun;") + (wr-nl "struct { ") + (write-alloc-decls (rep-type t)) + ;; the *& is to make sure this goes into the Cstack. + (wr "} *CLvars = (void *) (*&CLfun = fcall.fun, CLfun->cl.Env);")) + + (cond (varargp + (wr-nl "int Inargs = VFUN_NARGS - " + (length reqds)";va_list Iap;") + (dolist (v (ll &optional ll)) + (wr-decl-var (car v)) + (allocate-var (cadddr v) t)) + (write-alloc-decls (rep-type t)) + (when (ll &rest ll) + (setq rest-var (caar (ll &rest ll))) + (allocate-var rest-var t)) + (write-alloc-decls (rep-type t)) + + ;; Todo : Use a structure to get named args: + ;; struct { object V1,V2,...V10;} Vk; + ;; Refer Kw.V2 + (when (ll &key ll) + + (wr-nl " struct {") + + (dolist (v (ll &key ll)) (allocate-var (car v) 'kw)) + (write-alloc-decls (rep-type t)) + (dolist (v (ll &key ll)) (allocate-var (caddr v) 'kw)) + (wr-nl"") + (write-alloc-decls (rep-type t)) + + (wr "} Vk;")) + )) + + (cond ((and (setq tem (fdata-tail-label fdat))(label-referred tem)) + (wr "LA" tem ":;") + (push tem *control-stack*) + )) + + (sloop for v in reqds do + (b2-bind-var (cdr v) (car v))) + + (when varargp + (wr-nl "Inargs = VFUN_NARGS - " (length reqds) " ; ") + (when + (ll &optional ll) + (let (*control-stack*) + ;; don't double BDSP. These will be added below + + (dolist (opt (ll &optional ll)) + (push (next-label) labels) + (wr-nl "if( --Inargs < 0)") + (wr-go (car labels)) + (wr-nl "else {") + (unless va-start (setq va-start t) (wr-nl "va_start(Iap);")) + (b2-bind-var (car opt) (list 'next-var-arg)) + (b2-bind-var (cadr opt) (car opt)) + (wr "}") + (when (cadddr opt) (b2-bind-var (cadddr opt) (get-object t))) + )) + (setq labels (nreverse labels)) + (let ((label (next-label))) + (wr-go label) + + ;;; Bind unspecified optional parameters. + + (dolist-safe (opt (ll &optional ll)) + (wr-label (car labels)) + (pop labels) + (b2-bind-var-b2 (car opt) (caddr opt)) + (b2-bind-var (cadr opt) (car opt)) + (when (cadddr opt) (b2-bind-var (cadddr opt) (get-object nil)))) + (wr-label label) + )) + + ;; bind &rest arg + (when rest-var + (let ((dynamic-extent (or *rest-on-stack* + (eq 'dynamic-extent + (var-type rest-var)))) + (temp (get-temp t))) + (unless va-start (setq va-start t) (wr-nl "va_start(Iap);")) + (wr-nl temp "=" ) + (cond ((ll &key ll) + (cond (*rest-on-stack* + (wr "(ALLOCA_CONS(Inargs),ON_STACK_MAKE_LIST(Inargs));")) + (t (wr "make_list(Inargs);")))) + (dynamic-extent + (wr "(ALLOCA_CONS(Inargs),ON_STACK_LIST_VECTOR(Inargs,Iap));")) + (t (wr "list_vector(Inargs,Iap);"))) + + (b2-bind-var rest-var temp))) + + + ;; bind keywords + + (when (ll &key ll) + (unless va-start (setq va-start t) (wr-nl "va_start(Iap);")) + (setq deflt (mapcar 'cadr (ll &key ll))) + (let ((vkdefaults nil) + (n (length (ll &key ll)))) + (do* ((v deflt (cdr v)) + (kwds (ll &key ll) (cdr kwds)) + (kwd (car kwds) (car kwds))) + ((null v)) + (unless (and (dv-p (car v)) + (eq (third (car v)) nil)) + (setq vkdefaults t)) + (when (or (not (and (dv-p (car v)) + (progn (add-data (car v))))) + ;; the supplied-p variable is not there + (not (null (third kwd))) + ) + (setf Vkdefaults t) + (setf (car v) 0))) + (if (> (length deflt) 15) (setq vkdefaults t)) + + (open-block) + (let ((*c-output* *h-output*)) + (when vkdefaults + (terpri *h-output*) + (wr "static int VK" cfun + "defaults[" (length deflt) "]={") + (do ((v deflt(cdr v))(tem)) + ((null v)) + (cond ((eql (car v) 0) + (wr "-1")) + ;; must be location + ((and + (eq (caar v) 'dv) + (eq (setq tem (third (car v))) nil)) + (wr "-2")) + ;; fix these two to allow fixnum constants. + ((eq (caar v) 'dv) + (wr (get-dv-index (car v)))) + (t (wfs-error))) + (if (cdr v) (wr ","))) + (wr "};")) + (terpri *h-output*) + (wr "static struct { short n,allow_other_keys;" + "int *defaults;") + (wr-nl " int keys[" n "];") + (wr "} VK" cfun "key=") + + (wr "{" (length (ll &key ll)) "," + (if (ll &allow-other-keys ll) 1 0) + ",") + (if vkdefaults (wr "VK" cfun "defaults") + (wr "(int *)Cstd_key_defaults")) + (when (ll &key ll) + (wr ",{") + (do ((v (reverse (ll &key ll)) (cdr v))) + ((null v)) + ;; We write this list backwards for convenience + ;; in stepping through it in parse_key + (wr (second (add-data (fourth (car v)) ))) + (if (cdr v) (wr ","))) + (wr "}")) + (wr "};") + ) + (cond (rest-var + (wr-nl "parse_key_rest(" rest-var ",")) + (t (wr-nl "parse_key_new("))) + + (wr "Inargs,&Vk,&VK" cfun "key,Iap);") + ) + ;; end setup keys + ;; bind the keys + (dolist (kwd (ll &key ll)) + (cond ((not (eql 0 (pop deflt))) + ;; keyword default bound by parse_key.. and no supplied-p + (b2-bind (car kwd))) + (t + (wr-nl "if(" `(key-var ,(car kwd)) "==0){") + (b2-bind-var-b2 (car kwd) (cadr kwd)) + (unless (null (caddr kwd)) + (b2-bind-var (caddr kwd) (get-object nil))) + + (wr-nl "}else{") + (let (*control-stack*) + ;; don't do extr BdSP + (b2-bind (car kwd)) + (and (caddr kwd) (b2-bind-var (caddr kwd) (get-object t)))) + + (wr "}")))))) + + )) + +(defun b2-bind (w) + (cond ((var-special-p w) + (b2-bind-var w (var-special-p w))) + ((var-clb w) + (or (consp (var-ind w)) (wfs-error)) + (b2-bind-var w (list 'closure-var-loc w))) + (t nil))) + + +(setf (get 'var 'b2) 'b2-var) +(setf (get 'dv 'b2) 'b2-dv) + +(defun b2-dv (x ) + (unless (cadr x) (add-data x)) + (unwind-set x)) + +(defun b2-var (v) + ;; what about the strategy of having everything except var's + ;; eval'd into a temp var. + (unwind-set v) + v) + +(defun needs-temp (val sofar rest &aux tem) + ;; VAL is the result of a expr-b2 ? '(1val) and SOFAR is the list of + ;; results sofar and REST is the list of future arguments to expr-b2. + ;; We must create a temp variable and assign it to val if any evaluation + ;; of the things in rest or sofar might alter the value in VAL. + (and (null sofar) (null rest) + (return-from needs-temp nil)) + ;; if sofar is only vars and rest is null + ;; also would be ok. + (cond ((consp val) + (cond ((eq (car val) 'var) (return-from needs-temp nil)) + ((eq (car val) 'dv) + (if (or (numberp (third val)) + (keywordp (third val))) + (return-from needs-temp nil))) + ((eq (car val) 'call) + ;; symbol-function does not have side-effect, but + ;; we need to preeval both to make sure order is write. + ;; (foo (symbol-function 'bil) (deff 'bil)) + (cond ((not (side-effect-p val)) + (return-from needs-temp nil)))))) + ((typep val 'var) + (or (null (var-special-p val)) (wfs-error)) + (cond ((and (null (var-clb val))) + (return-from needs-temp nil))))) + (setq tem (get-temp (result-type val))) + (wr-nl tem "=" val ";") + tem) + +(defun sets-mv-p (loc) + (cond ((atom loc) nil) + ((eq (car loc) 'inline-loc) + (sets-mv-p (third loc))) + ((eq (car loc) 'inline-call) + (flag-p (opt flag (cddr loc)) mv)) + (t nil))) + +(defun unwind-avma (ctl-stack) + (sloop for v on *control-stack* + do + (cond ((eq v ctl-stack)(return nil)) + ((eq (car v) 'avma-bind-needed) + (cond ((member 'inner-avma (cdr v)) + (wr-nl "avma = InnerAvma;")) + (t (wr-nl "avma = FunctionEntryAvma;") + (setq *used-function-saved-avma* t))))))) + +(defun unwind-stack (ctl-stack) + ;; Does the unbinding of special variables, popping the CtlStack, + ;; Cases here must also appear in unwind-stack-p + (sloop for v on *control-stack* + until (eq v ctl-stack) + do + (case (car v) + (bdsp + (wr-nl "UnBdSp;")) + (ctl-push + (wr-nl "CtlPop;")) + (t (cond ((consp (car v)) + (case (caar v) + (progv-bind + (wr-nl "IunwindBdSp(" (cadar v) ");")) + (unwind-protect + (wr-nl "CtlPop;IcallUnwindFun(" (cadar v) ");")) + ))))))) + +(defun unwind-stack-p (ctl-stack) + (sloop for v on *control-stack* + until (eq v ctl-stack) + when + (or (eq (car v) 'bdsp) + (eq (car v) 'ctl-push) + (and (consp (car v)) + (or (eq (caar v) 'progv-bind) + (eq (caar v) 'unwind-protect)))) + do (return t))) + +(defun restore-function-avma () + (wr-nl "avma = EntryAvma;") + (setq *used-function-saved-avma* t)) + +(defun unwind-set (val &optional avma-bind) + (cond ((and (typep val 'var) + (var-special-p val) + (cdr *value*) + (unwind-stack-p (cdr *exit*))) + (setq val (replace-inline-by-temp val)))) + (cond ((second *value*) + (unwind-stack (cdr *exit*)) + (wr-set-inline-loc (second *value*) val)) + ((and (consp val) (eq (car val) 'inline-call)) + (let ((flag (opt flag (cddr val)))) + (cond ((flag-p flag set) + (wr-nl val ";"))) + (unwind-stack (cdr *exit*)))) + (t (unwind-stack (cdr *exit*)))) + + (cond ((and (eq (car *value*) 'mv) + ;; *MV-N-VALUES-SET* bound to t by values special form + (null *MV-N-VALUES-SET*) + (not (sets-mv-p val))) + ;; detect if val does a set of MV + ;; if not then we must + (wr "fcall.nvalues = 1;"))) + + (case (car *exit*) + (function-return + (or (eq (second *exit*) (second *value*)) + (wfs-error)) + ;; must make sure CLfun and so its closure vars are not gc'd. The + ;; usage *&CLfun may mean this touch can be empty, since I think ANSI + (unwind-avma nil) + (if *closure-vars* (wr "TOUCH_CLfun;")) + (let ((val (second *value*))) + (or (eq (car val) 'var) (wfs-error)) + (cond ((eq (third val) 'double-float) + (wr-nl "RETURN_DOUBLE_PTR(" val ");")) + (t (wr-nl "return " val ";"))))) + (next + (if avma-bind (unwind-avma (cdr *exit*)))) + (otherwise + (cond ((typep (car *exit*) 'label) + (unwind-avma (cdr *exit*)) + (wr-go (car *exit*))) + (t (wfs-error))))) + ;; remove the avma-bind which has just been used. + (if avma-bind (remove-avma-bind avma-bind)) + ) +(defun remove-avma-bind (avma-bind) + (cond ((eq *control-stack* avma-bind) + (setq *control-stack* (cdr avma-bind))) + ((eq (cddr *control-stack*) (cdr avma-bind)) + (setq *control-stack* (cons (car *control-stack*) (cdr avma-bind)))) + (t (wfs-error)))) + +(setf (get 'progn 'b2) 'b2-progn) + +(defun b2-progn (x) + (progn-b2 (third x))) + +(defun progn-b2 (body) + (sloop for v on body + do (if (cdr v) (valex '(ignore) (next-exit) (expr-b2 (car v))) + (expr-b2 (car v)))) + (or body (expr-b2 (get-object nil)))) + +(defun get-temp (type) + (cond ((eq type 'integer) (setq type 'gen))) + (let ((tem (list 'var (next-cvar) type))) + (push (cdr tem) *temp-cvars*) + tem)) + +(defun push-vcs () + (prog1 (list 'vcs *next-vcs*) (incf *next-vcs*))) + +(defun write-alloc-decls(str) + (when *alloc-decls* + (wr str) + (wr-list (nreverse *alloc-decls*)) + (wr ";") + (setq *alloc-decls* nil))) + +(defun allocate-var (v type) + (cond ((if (null v) (push `(var ,(next-cvar)) *alloc-decls*)) + (return-from allocate-var nil)) + ((typep v 'var) + (cond ((eq type 'kw) + (let ((ind (next-cvar v))) + (push (list 'var ind) *alloc-decls*) + (cond ((var-special-p v) + (setf (var-special-p v) `(var (kw ,ind)))) + (t (setf (var-ind v) (list 'kw ind)))))) + ((var-special-p v)) + (t (next-cvar v) + (push (list 'var (var-ind v)) *alloc-decls*)))))) + +(defun plain-var-p (x) + (and (typep x 'var) + (not (var-special-p x)) + (not (var-clb x)))) + +(setf (get 'let 'b2) 'b2-let) +(setf (get 'let* 'b2) 'b2-let) + +(defvar *last* nil) + +(defun next-exit () + ;; a hack to avoid some consing. + (cond ((and *last* (eq (cdr *last*) *control-stack*)) *last*) + (t (setq *last* (cons 'next *control-stack*))))) + +(defun b2-let (x &aux (*control-stack* *control-stack*) + (*blocks* 0) binds body + (*used-names* *used-names*) + todo ) + (desetq (binds body) (cddr x)) + (open-block) + (sloop for (var) in binds + when (not (var-special-p var)) + do (next-cvar var) + (wr-decl-var var)) + (sloop for (var val) in binds + do (cond ((plain-var-p var) + (valex (list 'var var) (next-exit) (expr-b2 val))) + (t (let ((tem (get-temp t))) + (valex (list 'var tem) (next-exit) (expr-b2 val)) + (if (eql (car x) 'let) (push (cons var tem) todo) + (b2-bind-var var tem)))))) + (sloop for (var . val) in (nreverse todo) + do (b2-bind-var var val)) + (progn-b2 body) + (close-blocks) + nil) + +(defun safe-system (x) + (unless (eql 0 (system x)) + (error "The command ~s failed" x))) + +(defun compile-and-add-data-file ( o-file &aux command dir) + (declare (special c-debug)) + (force-output *c-output*) + (force-output *data-output*) + (force-output *h-output*) + (if (eql *c-output* *standard-output*) + (return-from compile-and-add-data-file nil)) + (setq dir (namestring + (make-pathname :directory (or (pathname-directory *c-output*) + '(:current))))) + (setq command (format nil "(cd ~a ; ~a -c -I. -I/u/wfs/new-lisp/newh ~a ~a ~a )" + dir + compiler::*cc* + (namestring *c-output*) + (if c-debug "-g" "") + (if (> *speed* 0) "-O" "") + )) + + (cond (o-file + (safe-system command) + (with-open-file (st (get-output-pathname "o") :direction :output + :if-exists :append) + (setq o-file (truename st)) + (sloop for v in-array "" + do (write-char v st)) + (write-char #\N st)) + (system (format nil "cat ~a >> ~a" (namestring *data-output*) + (namestring o-file))))) + ) + +(defun disassemble1 (name) + (with-open-file (st "/tmp/wfs1.lsp" :direction :output) + (print `(in-package ,(package-name *package*))) + (let ((def (symbol-function name))) + (cond ((and (consp def) (eq (car def) 'lambda-block)) + (print `(defun ,name ,@ (cddr def)) st)) + (t (return-from disassemble1 'cant)))) + (force-output st) + (compile-file1 (pathname st) :c-file *standard-output*))) + diff --git a/comp/try.lsp b/comp/try.lsp new file mode 100755 index 0000000..35bd890 --- /dev/null +++ b/comp/try.lsp @@ -0,0 +1,26 @@ +(in-package "BCOMP" :use '("SLOOP" "LISP")) +(setq *print-pretty* t) +(defun compiler::boole3 (a b c) (boole a b c)) +(setq compiler::*cc* (concatenate 'string compiler::*cc* " -I../newh -I../h")) + +(let ((*load-verbose* nil)) + (dolist (v '( data defs macros var c-pass1 fasdmacros lambda top top1 + inline top2 stmt wr + bo1 + exit + defmacro + utils comptype + )) + (si::nload (format nil "~(~a~).lsp" v))) + (load "opts-base.lsp") + (let ((u "top2.o")) + (unless (get 'list 'bcomp-opt) + (if (probe-file u) (load u)) + (load "lisp-decls.doc") + (load "opts.lsp") + (if (probe-file U ) (si::nload "top2.lsp")) + )) + (or (fboundp 'do-some-tests) (load "../tests/all-tests.lsp")) + (load "mangle") + ) + diff --git a/comp/try1.lsp b/comp/try1.lsp new file mode 100755 index 0000000..c904697 --- /dev/null +++ b/comp/try1.lsp @@ -0,0 +1,8 @@ +(setq *load-verbose* nil) +(defun compiler::boole3 (a b c) (boole a b c)) +(load "sysdef.lsp") +(make::make :bcomp) +(load "smash-oldcmp.lsp") + +(setq *load-verbose* t) + diff --git a/comp/utils.lsp b/comp/utils.lsp new file mode 100755 index 0000000..8c73f8d --- /dev/null +++ b/comp/utils.lsp @@ -0,0 +1,166 @@ + +(in-package "BCOMP") + +(defmacro fdecl (key fd) `(nth ,(position key '(argd flag)) ,fd)) + +(defun comp-warn (fmt &rest l &aux (*print-length* 3) (*print-level* 3)) + (if *top-form* (format t ";~%~s is being compiled" *top-form*)) + (setq *top-form* nil) + (format t ";;~%Warning:") + (apply 'format t fmt l)) + +(defun comp-error (fmt &rest l &aux (*print-length* 3) (*print-level* 3)) + (setq *hard-error* t) + (format t "~%Error:") + (apply 'format t fmt l)) + +(defun add-prop (symbol-lis prop val) + (dolist-safe (v symbol-lis) + (or (symbolp v) (comp-error "Can't add ~a prop ~a to non symbol ~a" val prop v)) + (setf (get v prop) val))) + +(defun bad-proclamation () + (declare (special *procl*)) + (comp-error "The proclamation ~a was illegal." *procl*)) + + +(defun proclaim1 (x &aux ptype body (*procl* x) flag val tem) + (declare (special *space* *speed*)) +;; will eventually be proclaim. + (declare (special *procl*)) + (desetq (ptype . body) x) + (case ptype + (optimize (sloop for v in-list body + do (cond ((atom v) (setq flag v val 3)) + (t (desetq (flag val) v))) + (or (typep val 'fixnum) (bad-proclamation)) + (case flag + (safety (if (> (the fixnum val) 0) (setq *safety* val))) + (space (setq *space* val)) + (speed (setq *speed* val)) + (compilation-speed (setq *speed* 0)) + (t (comp-warn "Unknown optimize quality ~a" flag))))) + (special (dolist-safe (v body) (si::*make-special v))) + (type (desetq (ptype . body) body) + (setq ptype (comp-type ptype)) + (add-prop body 'proclaimed-variable-type ptype)) + (function + (let (name ) + (desetq (name . body) body) + (proclaim1 `(ftype (function ,@ body) ,name)))) + (ftype + (desetq (ptype . body) body) + (add-prop body 'proclaimed-function-declaration + (increment-function-decl ptype nil))) + (inline + (add-prop body 'proclaimed-inline t)) + (declaration + (add-prop body 'proclaimed-declaration t)) + (t (cond ((symbolp ptype) + (cond ((setq tem (get ptype 'comp-type)) + (add-prop body 'proclaimed-variable-type (comp-type ptype))) + ((get ptype 'proclaimed-declaration)) + (t (bad-proclamation)))) + (t (bad-proclamation)))))) + +(defun ftype-from-fdecl (fdecl &aux (n (fdecl argd fdecl))) +;; (setq fdecl (get fname 'proclaimed-fun57qction-declaration)) + (when n + (let ((args (argl-from-argd n)) + (ret (ret-from-argd n))) + `(ftype (function ,args ,ret))))) + +(defun describe-fdecl(fdecl) + (format t "Ftype is ~s, flags are " (ftype-from-fdecl fdecl)) + (print-flag (fdecl flag fdecl))) + + +(defun promote-arg-type (x) + (setq x (comp-type x)) + (case x + (fixnum 'fixnum) + ((t) t) +; (short-float 'short-float) + ((long-float double-float ) 'double_ptr) + (t (cond ((subtypep x 'fixnum) 'fixnum) + (t t))))) + +(defvar *promoted-arg-types* #( t fixnum double_ptr ;short-float + )) +(defun arg-type-code (x) + (cond ((eq x t) 0) + ((eq x 'fixnum) 1) + ((eq x 'double_ptr) 2) +; ((eq x 'short-float) 3) + (t (wfs-error) 0))) + +(defun increment-function-decl (new-prop old-decl &aux tem + args ret-types retl) + ;; produce a new function-decl with prop added. + (setq old-decl (list 0 (if old-decl (second old-decl) + #.(flags set ans mv touch-mv) + ))) + (cond ((atom new-prop) + (case new-prop + (inline (setf (flag-p (fdecl flag old-decl) notinline) nil)) + (notinline (setf (flag-p (fdecl flag old-decl) notinline) t)) + (t (wfs-error))) + old-decl) + ((eq (car new-prop) 'function) + (desetq (args . ret-types) (cdr new-prop)) + (tagbody + again + (cond ((null ret-types) (setq retl '*)) + ((atom ret-types) (comp-error "Bad return decl ~a" retl)) + ((cdr ret-types) (setq retl '*)) + ((eq (setq tem (car ret-types)) '*)(setq retl '*)) + ((and (consp tem) + (eq (car tem) 'values)) + (setq ret-types (cdr tem)) (go again)) + (t (setq retl (comp-type tem))))) + (setf (car old-decl) (link-descriptor-from-decl args retl)) + (cond ((not (eq retl '*)) + (setf (flag-p (second old-decl) mv) nil))) + old-decl) + (t (wfs-error)))) + +(defun function-declaration (v) + (or (symbolp v) (wfs-error)) + (or (cdr (assoc v *function-decls*)) + (get v 'proclaimed-function-declaration))) + + +(defun function-return-type (fdat &aux ret fdecl) + ;; returns (member *immediate-types*), T, or MV + ;; (member *immediate-types*), T, *, (values t t) (values) .. + (let ((fname (fdata-name fdat))) + (cond ((and fname (setq fdecl (get fname 'proclaimed-function-declaration))) + (setf (fdata-function-declaration fdat) fdecl) + (setq ret (ret-from-argd (fdecl argd fdecl))) + (cond ((eq ret '*) 'mv) + (t ret))) + (t 'mv)))) + +(defun the-list (x &aux (y x)) + (sloop while x + do (or (consp x) (comp-error "not a list ~a" x)) + (setq x (cdr x))) + y) + + + + + + + + + + + + + + + + + + diff --git a/comp/var.lsp b/comp/var.lsp new file mode 100755 index 0000000..6c764b1 --- /dev/null +++ b/comp/var.lsp @@ -0,0 +1,1147 @@ +;;Copyright William F. Schelter 1990, All Rights Reserved + + +(in-package "BCOMP") +(use-package "SLOOP") + +(setq SYSTEM:*INHIBIT-MACRO-SPECIAL* nil) +;(fmakunbound 'multiple-value-list) + +(defvar *default-desk* (make-desk t)) + +(defun get-desk (type) + (if (eq type t) *default-desk* (make-desk type))) + +(defun set-desk-type (desk new-type) + (cond ((eq desk *default-desk*) (make-desk new-type)) + (t (setf (desk-result-type desk) (type-and (desk-result-type desk) new-type)) + desk))) + +(setq SYSTEM:*INHIBIT-MACRO-SPECIAL* t) + +(do ((v '(QUOTE b1-quote + MACROLET b1-macrolet + symbol-macrolet b1-symbol-macrolet + MULTIPLE-VALUE-PROG1 b1-MULTIPLE-VALUE-PROG1 + UNWIND-PROTECT b1-unwind-protect + EVAL-WHEN b1-quote-first + LET b1-let + RETURN-FROM b1-return-from + MULTIPLE-VALUE-LIST b1-eval + IF b1-if + THE b1-the + PROGV b1-progv + FUNCTION b1-function + FLET b1-flet + COMPILER-LET b1-compiler-let + DECLARE b1-declare + TAGBODY b1-tagbody + LABELS b1-flet + PROGN b1-progn + LET* b1-let* + CATCH b1-catch + THROW b1-throw + BLOCK b1-block + GO b1-go + SETQ b1-setq + VALUES b1-values + LAMBDA-BLOCK b1-lambda-block + DONE-b1 b1-done-b1 + #+c-pass1 MULTIPLE-VALUE-BIND b1-multiple-value-bind + #+c-pass1 MULTIPLE-VALUE-setq b1-multiple-value-setq + + + ) (cddr v))) + ((null v)) + (setf (get (car v) 'b1) (second v))) + +(defmacro locally (&body body) + `(let nil ,@body)) + +(defvar *control-stack* + ;; When a special is bound 'bound-special is pushed + ;; When clb lambda is entered 'clb is pushed + ;; When save_avma is entered 'save-avma is pushed + ;; Thus go can tell whether the tag is acros 'clb or + ;; or else how many bds-unbinds it has to do before going. + nil) + +(defvar *walk-functions* + ;; bindings of functions and macros by flet,macrolet,labels + nil) + +(defvar *walk-variable-bindings* + ;; bindings of variables by let,lambda, let*, symbol-macrolet. + ;; + nil) + +(defvar *digest-line-info* (make-hash-table :test 'eq)) + +(defvar *line-info* nil) + +(defun walk-environment () + (list nil *walk-functions*)) + +(defun mapcar2 (f lis c &optional last) + (or last (setq last c)) + (do ((v lis (cdr v)) + (result) (ptr)) + ((null v) result) + (or (consp v) (comp-error "Expected a list of forms ~a" lis)) + (let ((tem (funcall (the (function (t t) t) f) + (car v) + (if (cdr v) c last)))) + (cond (ptr (setf (cdr ptr) (list tem)) + (setf ptr (cdr ptr))) + (t (setq result (setq ptr (list tem)))))))) + +(eval-when (compile eval load) + +(defun desetq-consp-check (val) + (or (consp val) (error "~a is not a cons" val))) + +(defun desetq1 (form val) + (cond ((symbolp form) + (cond (form ;(push form *desetq-binds*) + `(setf ,form ,val)))) + ((consp form) + `(progn + (desetq-consp-check ,val) + ,(desetq1 (car form) `(car ,val)) + ,@ (if (consp (cdr form)) + (list(desetq1 (cdr form) `(cdr ,val))) + (and (cdr form) `((setf ,(cdr form) (cdr ,val))))))) + (t (error "")))) + ) + +(defmacro desetq (form val) + (cond ((atom val) (desetq1 form val)) + (t (let ((value (gensym))) + `(let ((,value ,val)) , (desetq1 form value)))))) + +(defun b1-quote-two (form where &aux sform a b c) where + (desetq (sform a b . c) form) + (list* sform a b (mapcar2 'b1-walk c sform))) + +(eval-when (compile eval load) + +(defun wbind1 (v decls &aux var specialp tem) + (or (symbolp v) (comp-error "binding non symbol ~a")) + (if (null v) (comp-error "binding nil ~a")) + (sloop for w on-list (second decls) + when (eq (car w) v) do (setq specialp t)(setf (car w) nil)) + (if (si::specialp v) (setq specialp t)) + (setq var (makevar v specialp)) + (if specialp (push 'bound-special + *control-stack*)) + + (push var *walk-variable-bindings*) + (cond ((setq tem (assoc v (car decls))) + (setf (var-type var) (cdr tem)))) + var + ) + +(defmacro wbind (v decls) + `(setf ,v (wbind1 ,v ,decls))) + +(defun makevar (var specialp) + (or (symbolp var) (error "not a symbol ~a" var)) + (let ((v (make-var :name var))) + (when specialp (setf (var-special-p v) t) + (setf (var-ind v) (get-object var))) + (setf (var-type v) (or (get var 'proclaimed-variable-type) t)) + + v)) + +(defun canon-opt-arg (v type + &aux var val supplied-p keyword + (intern (eql type '&key))) + ;; (list var val supplied-p keyword) + (tagbody + (if intern (setq keyword v)) + (cond ((atom v) + (or (symbolp v) (go error)) + (setq var v)) + (t + (cond ((consp (car v)) + (or intern (go error)) + (setq intern nil) + (desetq (keyword var) (car v))) + (t + (setq keyword (car v) var (car v)))) + (or (consp (cdr v)) (go error)) + (setq val (cadr v)) + (if (consp (cddr v)) + (setq supplied-p (caddr v))))) + (or (symbolp keyword) (go error)) + (or (symbolp var ) (go error)) + (or (null intern) + (setq keyword (intern (symbol-name keyword) 'keyword))) + (return-from canon-opt-arg (list var val supplied-p keyword)) + error + (comp-error "bad ~a arg ~s" type v))) + +;;lambda-list-keywords has value: +;; '(&optional &rest &key &allow-other-keys &aux &whole &environment &body) + +(defun decode-ll (list) + (let (ll sections) + (do ((v list (cdr v)) + (this (list '&required))) + ((null v) (push (nreverse this) sections) + (setq sections (nreverse sections ))) + (cond ((member (car v) lambda-list-keywords) + (push (nreverse this) sections) + (setq this (list (car v)))) + (t (push (if (consp (car v)) (car v) + (if sections (list (car v) nil) (car v))) + this)))) + (do ((v (cons '&required lambda-list-keywords) (cdr v)) + tem) + ((eq (car v) '&whole) + (or (null sections) + (error "unrecognized or duplicate '&' keyword in lambda-list ~a" + sections))) + (cond ((setq tem (assoc (car v) sections)) + (or (eq (car sections) tem) + (error "~a in incorrect position" (car v))) + (setf sections (cdr sections)))) + (push tem ll) + ) + (setq ll (nreverse ll)) + (dolist (v (ll &required ll)) + (unless (symbolp v) (error "required arg not a symbol ~a" v))) + (if (ll &allow-other-keys ll) + (setf (cdr (ll &allow-other-keys ll)) t)) + (setf (ll &key ll) + (sloop for v in-list (ll &key ll) + collect (canon-opt-arg v '&key))) + (setf (ll &optional ll) + (sloop for v in-list (ll &optional ll) + collect (canon-opt-arg v '&optional))) + (setf ll (mapcar 'cdr ll)))) + +(defun lambda-bind-b1 (decoded clb decls) + (let ((*walk-variable-bindings* *walk-variable-bindings*) + (*control-stack* *control-stack*)) + (if clb (push 'clb *walk-variable-bindings*)) + (flet ((fbind1 ( l decls &aux v) + (sloop for w on l + do + (cond ((atom (car w)) (wbind (car w) decls)) + (t (setq v (car w)) + ; v = (list var val supplied-p keyword) + (setf (nth 1 v) (b1-walk (nth 1 v) 'bind)) + (wbind (nth 0 v) decls) + (setq v (cddr v)) + (if (car v) (wbind (car v) decls)) + (setq v (cdr v)) + (if (car v) (setf (car v) + (get-object (car v))))))))) + (fbind1 (ll &required decoded) decls) + (fbind1 (ll &optional decoded) decls) + (if (ll &rest decoded) (wbind (caar (ll &rest decoded)) decls)) + (fbind1 (ll &key decoded) decls)) + (add-remaining-special-decls decls) + *walk-variable-bindings*)) +;;end eval-when +) + +(defvar *contains-function* + ;; set if the form contains a lambda expression. + ) + +(defvar *setjmps* + ;; the number of setjmps encountered so far. + ;; tagbody with clb tags, unwind-protect, catch all lay down setjmps. + ) + +(defun bound-variables-volatile () + (dolist (v *walk-variable-bindings*) + (cond ((eql v 'clb) (return nil)) + ((typep v 'var) + (setf (var-volatile v) t))))) + +(defun check-used (binds pos &aux w) + (dolist (v binds) + (cond ((consp v) + (setq w (nth pos v)) + (if (typep w 'var) + (or (var-special-p w) (var-changed w ) (var-ref w ) + + (comp-warn "Variable ~s was not used" (var-name w)))))))) + +(defun add-remaining-special-decls (decls) + (sloop for v in (second decls) + when v + do (push (list v 'special (makevar v t)) *walk-variable-bindings*))) + +(defun b1-lambda-block (form where &optional (clb 'clb) + &aux sform name closure-record + result decls doc + (*control-stack* (cons clb *control-stack*)) + (*function-decls* *function-decls*) + (tail-label (make-label :identifier '#.(gensym "tail"))) + ll bod decoded) + where + (desetq (sform) form) (setq form (cdr form)) + ;; set + (setq *contains-function* t) + (cond ((eq sform 'lambda-block) + (desetq (name) form) + (setq form (cdr form)))) + (desetq (ll . bod) form) + (setq decoded (decode-ll ll)) + (desetq (decls bod doc) (grab-declares bod t)) + (cond ((and (null name) + (consp bod) + (consp (car bod)) + (eq (caar bod) 'block)) + (desetq (name) (cdar bod))) + ((and (symbolp name) (eq sform 'lambda-block)) + (setq bod `((block ,name ,. bod))))) + (when clb + (dolist (v *walk-variable-bindings*) + (and (typep v 'var) + (var-clb v) + (push (cons v (var-clb v)) closure-record)))) + + (let* ((*control-stack* *control-stack*) + (*walk-variable-bindings* + (lambda-bind-b1 decoded clb decls)) + (tail-recursion + (and (not (ll &optional decoded)) + (eq sform 'lambda) + (not (ll &key decoded)) + (not (ll &rest decoded)) + (list 'lambda-block name (ll &required decoded) tail-label)))) + + + (push tail-label *control-stack*) + (setq result + (b1-walk `(let* ,(ll &aux decoded) + ,@ (get-back-some-decls decls (mapcar 'car (ll &aux decoded))) + ,@ bod) tail-recursion)) + + (check-used *walk-variable-bindings* 1)) + (if (ll &aux decoded) + (setf ll (butlast ll (length (member '&aux ll))))) + `(,sform , (make-fun-data name closure-record clb decoded doc result tail-label + ) ))) + +(defun make-fun-data (name closure-record clb ll doc form tail-label &aux tem result) + (setq result (make-fdata :name name :ll ll :doc doc)) + (setf (fdata-form result) form) + (setf (fdata-tail-label result) tail-label) + (when clb + (dolist (v *walk-variable-bindings*) + (cond ((and (typep v 'var) + (setq tem (var-clb v))) + (if (> tem + (or (cdr (assoc v closure-record)) 0)) + (push v (fdata-closure-vars result))))))) + result) + +(defun declare-volatile (binds) + (dolist (v binds) + (or (and (consp v) (typep (car v) 'var) (wfs-error))) + (setf (var-volatile (car v)) t))) + +(defun find-bind (var &optional (set-clb t) &aux clb) + (cond ((and (consp var) (eq (car var) 'done-b1)) + (setq var (cdr var)))) + (dolist (v *walk-variable-bindings*) + (cond ((var-p v) + (when (or (eq var (var-name v)) + (eq var v)) + (cond ((and clb set-clb + (not (var-special-p v))) + (setf (var-clb v) + (+ 1 (the fixnum (or (var-clb v) 0)))))) + (return-from find-bind v))) + ((eq 'clb v) + (setq clb t)) + ((consp v) + (cond ((eq (car v) var) + (case (second v) + (special + (return-from find-bind (third v))) + (symbol-macro (return-from find-bind (cdr v))) + (otherwise (wfs-error)))))) + (t (wfs-error)))) + (or (si::specialp var) (keywordp var) + (comp-warn "~a is an unknown variable. Assuming it is special." var)) + (let ((tem (makevar var t))) + (push (list var 'special tem) *walk-variable-bindings*) + tem)) + + +(defun b1-macro-function (name) + (let ((tem (assoc name *walk-functions*))) + (cond (tem + (if (eq 'macro (cadr tem)) (third tem) nil)) + (t (macro-function name))))) + +(eval-when (compile) (proclaim '(function expand-fun (t) t))) + +(defun expand-fun (form &aux f) + (unless (and (consp form) (eq (car form) 'lambda-block)) + (return-from expand-fun form)) + (setq f (second form)) + (let* ((line-info (get f 'line-info)) + (*digest-line-info* + (if (and line-info *digest-line-info*) + (progn (clrhash *digest-line-info*) + (dotimes (i (length line-info)) + (setf (gethash (aref line-info i) + *digest-line-info*) + i)) + *digest-line-info*) + nil)) + (*line-info* line-info)) + (let ((result (walk-top form))) + (setf (car form) 'lambda-block-expanded) + (setf (cdr form) (cdr result)) + form))) + +(defun walk-top (form) + (let ((*walk-variable-bindings* nil) + (*control-stack* nil) + (*walk-functions* nil) + ) + (b1-walk form 'top))) + +(defun transfer-line-info (form result for-sure &aux tem) + ;; transfer the line info from FORM to RESULT. + ;; If FOR-SURE holds, do it even if this would destroy + ;; line info of RESULT. + (cond ((atom result) nil) + ((setq tem (gethash form *digest-line-info*)) + (when (or for-sure (not (gethash result *digest-line-info*))) + (remhash form *digest-line-info*) + (and *line-info* (setf (aref *line-info* tem) result)) + (setf (gethash result *digest-line-info*) tem))))) + +(defun b1-walk (form where &aux tem sym result (changed 0)) + (declare (fixnum changed)) + (setq + result + (cond ((atom form) + (cond + ((constantp form) + (cond ((symbolp form) + (get-object (symbol-value form))) + (t (get-object form)))) + ((symbolp form) + (let ((v (find-bind form t))) + (cond ((and (consp v) (eq (car v) 'symbol-macro)) + (b1-walk (second v) where)) + (t (or (var-ref v) (setf (var-ref v) t)) + v)))))) + ((symbolp (setq sym (car form))) + ;;possibly fix line info + (and *digest-line-info* + (cond ((setq tem (get sym 'wl)) + (funcall tem form)))) + (setq changed (fill-pointer *changed*)) + (cond ((setq tem (get sym 'b1)) + (funcall tem form where)) + ((and (setq tem (get sym 'bo1)) + (setq tem (funcall tem form where))) + (b1-walk tem where)) + ((b1-macro-function sym) + (b1-walk (macroexpand form (walk-environment)) where)) + ((setq tem (get sym 'si::structure-access)) + (let (arg res-type sd (index (cdr tem))) + (desetq (arg) (cdr form)) + (setq tem + (case (car tem) + (vector `(aref (the (array t) ,arg) ,index)) + (list `(nth ,index ,arg)) + (t + (setq sd (get (car tem) 'si::s-data)) + (or (null (cddr form)) (comp-warn "Too many args to ~a" sym)) + (cond ((null sd) (comp-warn "Structure not defined ~a" (car tem))) + (t + (setq res-type + (comp-type(aet-type (aref (si::s-data-raw sd) index)))) + (cond ((eq res-type t) + `(si::structure-ref ,arg ',(car tem) ,index)) + (t + `(the,res-type + (si::structure-ref + (the (struct ,res-type) ,arg) + ',(car tem) ,index))))))))) + (b1-walk tem where))) + ;; function application + (t + (do-call-b1 form where) + ))) + ((and (consp (car form)) + (eq (caar form) 'lambda)) + (b1-walk `(funcall (function ,(car form)) ,@ (cdr form)) where)) + (t (error "unrecognized form to eval ~a" form)))) + (when (and (consp result) + (consp (cdr result)) + (typep (second result) 'desk)) + (let ((tem + (let ((v *changed*)) + (declare (type (vector (t)) v)) + (sloop for i from changed below (fill-pointer v) + collect (aref v i))))) + (when tem + (if (eq (second result) *default-desk*) + (setf (second result) (make-desk t))) + (setf (desk-changed-vars (second result))tem) + ))) + (and *digest-line-info* (transfer-line-info form result t)) + result) + +(defun constant-call (sym arglist) + (and (sloop for v in arglist + always (and (consp v) (eq (car v) 'dv))) + (cons + (b1-walk (apply sym (mapcar 'caddr arglist)) 'call) + nil))) + +(defun do-call-b1 (form where &aux (sym (car form)) tem args) + (let* ((wf (cdr (assoc sym *walk-functions*))) + (res + `(call ,*default-desk* + ,(make-call-data sym + (setq args (mapcar2 'b1-walk (cdr form) + 'funcall)) + wf + (cdr (assoc sym *function-decls*)) + )))) + (cond (wf + ;; indicate a closure ref if necessary. + (if (third wf) (find-bind (var-name (third wf)))) + ) + ((setq tem (result-from-args sym args)) + (setf (second res) (set-desk-type (second res) tem))) + ((setq tem (get sym 'proclaimed-function-declaration)) + (setq tem (ret-from-argd (fdecl argd tem))) + (cond ((eq tem 'double_ptr) (setq tem 'double-float)) + ((eq tem '*) (setq tem 't))) + (setf (second res) (set-desk-type (second res) tem)))) + (cond ((and (member sym '(< > length + - * / )) + (setq tem (constant-call sym (call-data-arglist (third res))))) + (return-from do-call-b1 (car tem)))) + + ;; tail recursion???? + (cond ((and (consp where) + (eq (car where) 'lambda-block) + (eq (second where) sym) + (not (member 'bound-special *control-stack*)) + (not wf)) + (format t "~%;;Note: Replaced tail call of ~a by iteration." sym) + (let ((args (call-data-arglist (third res)))) + (sloop for v in args with s + do + (unless (cdr args) + (setq sets (list (cons 'done-b1 (car args)))) + (loop-finish)) + (setq s (gensym)) + for var in (third where) + collect (list s (cons 'done-b1 v)) into binds + unless (eq t (var-type var)) + collect (list 'type (var-type var) s) into decls + collect s into sets + finally + (setq res (b1-walk + `(let ,binds + ,(cons 'declare decls) + (assign-args ,@sets) + (go ,(label-identifier (nth 3 where)))) + 'let)))))) + + ;;ordinary functioncall + res)) + +(defun b1-quote-first (form where &aux sform fir bod) where + (desetq (sform fir . bod) form) + `(,sform ,fir ,@ (mapcar2 'b1-walk bod sform))) + +(defun b1-quote (form where &aux val) where + (desetq (nil val) form) + (and (cddr form) (comp-error "Two many args to quote ~a"form)) + (get-object val)) + +(defun b1-setq (form where &aux sform var bod val ans) where + (cond ((null (cdr form)) (return-from b1-setq (get-object nil)))) + (desetq (sform var val . bod) form) + (do () (nil) + (let ((v (find-bind var t))) + (setf (var-changed v) t) + (and (plain-var-p v) (vector-push-extend v *changed*)) + (setq val (b1-walk val sform)) + (push v ans) (push val ans) + (if bod (desetq (var val . bod) bod) + (return nil)))) + `(,sform, (make-desk (var-type (second ans))) ,@ (nreverse ans))) + +(defun b1-eval (form where &aux sform bod) where + (desetq (sform . bod) form) + `(,sform ,@ (mapcar2 'b1-walk bod sform))) + +;; using (control-jumped-back id) +;; +;; and (pass-values) + +(defun b1-tagbody (form where &aux sform bod + (*walk-variable-bindings* *walk-variable-bindings*) + (*control-stack* *control-stack*) + (longjmp-id (makevar nil nil)) + sym + (clb-ref (list 0 longjmp-id)) + ) + where + (desetq (sform . bod) form) + (push longjmp-id *walk-variable-bindings*) + (setq bod + (sloop for v in-list bod + when (or (integerp v) (symbolp v)) + collect (list 'done-b1 + 'label + (let ((tem (make-label :identifier v + :clb-reference + (cons nil clb-ref) + ))) + (push tem *control-stack*) + tem)) + else + collect v)) + (setq bod (mapcar2 'b1-walk bod sform)) + (cond ((var-clb longjmp-id) + (setq sym (gensym)) + (bound-variables-volatile) + `(let-control-stack + (let ,*default-desk* + ((,longjmp-id ,(b1-walk '(unique-id) 'let-var))) + (,(b1-walk + `(let ((,sym 0) + (ctl-came-back (control-jumped-back (done-b1 . ,longjmp-id)))) + (declare (fixnum ,sym)(boolean ctl-came-back)) + (if ctl-came-back + (progn (nlj-active-off)(setq ,sym (pass-values)))) + (switch ,sym + ,@ (sloop for v in bod with tem + when (and (consp v) + (eq (car v) 'label) + (setq tem (car (label-clb-reference (cadr v))))) + collect `(case ,tem) + collect (cons 'done-b1 v)))) + 'tagbody))))) + + (t + `(,sform ,*default-desk* ,bod)))) + + + + + +;; wrapper so you can avoid doing b1 twice on a form. +;; when we need to do it once to get the result type. + +(defun b1-done-b1 (form where) where (cdr form)) + +(defun b1-prog1 (form where &aux sform body first) + (desetq (sform first body) form) + (setq first (b1-walk first where)) + (let ((sym (gensym))) + (b1-walk + `(let ((,sym (done-b1 . ,first))) + (declare (type ,(result-type first) ,sym)) + ,@ (append body (list sym))) + where))) + +(defun b1-progn (form where &aux sform bod) where + (desetq (sform . bod) form) + (cond ((and (eq sform 'progn) (null (cdr bod))) + (b1-walk (car bod) where)) + (t (setq bod (mapcar2 'b1-walk bod sform where)) + `(progn ,(make-desk (result-type (car (last bod)))) ,bod )))) + +(defun b1-if (form where &aux sform test then else) where + (desetq (sform test then) form) + (setq form (cdddr form)) + (when (consp form) (setq else (car form)) (setq form (cdr form))) + (if form (error "Too many args to if")) + (setq test (b1-walk test sform)) + (setq then (b1-walk then where)) + (setq else (b1-walk else where)) + (cond ((and (consp test) (eq (car test) 'dv)) + (return-from b1-if + (if (eq (third test) nil) else then)))) + `(,sform ,(make-desk (type-and (result-type then) + (result-type else))) + ,test ,then ,else)) + +(defun b1-macrolet (form where &aux sform mbinds ll name body mbody funs) + (desetq (sform mbinds . body) form) + (do ((v mbinds (cdr v))) + ((atom v)) + (desetq ((name ll . mbody)) v) + (let ((fun (second (parse-macro name ll mbody t)))) + (push (list name 'macro fun) funs))) + (let ((*walk-functions* (nconc (nreverse funs) *walk-functions*))) + (b1-walk (cons 'progn body) where))) + +(defun b1-flet (form where &aux sform mbinds name ll body mbody + new-binds fun ans let-binds let-sets var fdat tem + (*walk-variable-bindings* *walk-variable-bindings*) + (*walk-functions* *walk-functions*)) + (desetq (sform mbinds . body) form) + (do ((v mbinds (cdr v))) + ((atom v)) + (desetq ((name ll . mbody)) v) + (setq fun `(lambda-block ,name ,ll ,@mbody)) + ;;a variable to hold a pointer to the function itself. + ;; so we don't have to cons up more than one copy of itself. + (setq var (makevar (gensym "flet") nil)) + (push var *walk-variable-bindings*) + (push (list name fun nil var) new-binds)) + (if (eq sform 'labels) + (setf *walk-functions* + (append new-binds *walk-functions*))) + (dolist (v new-binds) + (setq var (fourth v)) + (setq ans(b1-lambda-block (second v) sform 'clb )) + (setq fdat (second ans)) + (setf (third v) ans) + (cond ((setq tem (fdata-closure-vars fdat)) + (cond ((and (null (cdr tem)) + (eq (car tem) var)) + ;; if the only reason for it being a closure is the self reference var + ;; forget it. + (setf (fdata-closure-vars fdat) nil)) + (t + (setf (fdata-closure-self fdat) var) + (push (list var nil) let-binds) + (push `(pointer-to-funobj ,fdat) let-sets) + (push var let-sets)))) + (t (setf (fourth v) nil) + ))) + + (if (eq sform 'flet) + (setf *walk-functions* (append new-binds *walk-functions*))) + (setq body (mapcar2 'b1-walk body sform where)) + (setq ans + `(flet ,(make-desk (result-type (car (last body)))) + ,(reverse new-binds) ,body)) + (if let-binds + `(let ,(second ans) ,let-binds + ((setq ,*default-desk* ,@ let-sets) + ,ans)) + ans)) + +(defun b1-symbol-macrolet (x where &aux sform binds body expansion decls tem + new-binds name + ) + (desetq (sform binds . body) x) + (desetq (decls body) (grab-declares body t)) + (do ((v binds (cdr v))) + ((atom v)) + (desetq ((name expansion)) v) + (if (member name (car decls)) + (error "special declaration of symbol-macrolet var ~a" + name)) + (when (setq tem (assoc name (second decls))) + (setf expansion `(the , (cdr tem) ,expansion))) + (push (list name 'symbol-macro expansion) new-binds)) + (let ((*walk-variable-bindings* (nconc new-binds *walk-variable-bindings*))) + (b1-progn (cons 'progn body) where))) + +(defun b1-let (form where &optional compiler-let + &aux sform var vars body val + (*function-decls* *function-decls*) + (*walk-variable-bindings* *walk-variable-bindings*) + (*control-stack* *control-stack*) + decls + binds) + (desetq (sform vars . body) form) + (do ((v vars (cdr v))) + ((atom v)) + (cond ((consp (car v)) + (setq var (caar v)) + (setq val (cdar v)) + (and (not compiler-let) + (setq val (b1-walk (car val) sform)))) + (t (setq var (car v) val nil))) + (push (list var val) binds)) + (setq binds (nreverse binds)) + (if compiler-let + (return-from b1-let + (progv (mapcar 'car binds) (mapcar 'cadr binds) + (b1-progn (cons 'progn body) where)))) + (desetq (decls body) (grab-declares body nil)) + (dolist-safe (v binds) + (wbind (car v) decls)) + (add-remaining-special-decls decls) + (cond ((null vars) (b1-progn (cons 'progn body) where)) + (t (setq body (mapcar2 'b1-walk body sform where)) + (check-used binds 0) + `(let ,(make-desk (result-type (car (last body)))) + ,binds, body)))) + +(defun b1-compiler-let (form where) + (b1-let form where t)) + +(defun b1-let* (form where &aux sform var val binds + (*function-decls* *function-decls*) + (*control-stack* *control-stack*) + (*walk-variable-bindings* *walk-variable-bindings*) + vars body decls) + (desetq (sform vars . body) form) + (desetq (decls body) (grab-declares body nil)) + (do ((v vars (cdr v))) + ((atom v)) + (cond ((consp (car v)) + (setq var (caar v)) + (setq val (cdar v)) + (and (consp val) + (setq val (b1-walk (car val) sform)))) + (t (setq var (car v) val nil))) + (push (list var val) binds) + (wbind (caar binds) decls) + ) + (add-remaining-special-decls decls) + (setq binds (nreverse binds)) + (cond ((null vars) (b1-progn (cons 'progn body) where)) + (t (setq body (mapcar2 'b1-walk body sform where)) + (check-used binds 0) + `(let* ,(make-desk (result-type (car (last body)))) + ,binds, body))) + ) + +;; Scope of declarations: +;; Note Xrj13 voted that for +;; (let ((x 0)) (declare (fixnum x)) +;; .. (let ((x 5))(declare (type t x)) ..)) +;; then the inner declaration of x is also (and fixnum t) ie fixnum. +;; We DO NOT take advantage of this declaration, since it is very easy +;; for users to slip up on this, and since it is contrary to CltlI. The +;; Compiler has license to ignore type decls if it wants, and we do so here. +;; They explicitly say for +;; (let ((x 0)) (declare (special x)) +;; .. (let ((x 5)) ..)) +;; then the inner binding of x is NOT special unless there is another decl. +;; We do this. + +(defun grab-declares (form doc-allowed &aux (dec t) decls doc tem) doc-allowed + ;; return (cons form decls) + ;; decls == (list specials type-decls ..) + (if (stringp (car form)) (setq doc (car form) + form (cdr form))) + (sloop while dec + do + (setq tem (car form)) + (cond ((and (consp tem) (eq (car tem) 'declare)) + (setq form (cdr form)) + (dolist-safe (v (cdr tem)) (setq decls (grab-1-decl v decls)))) + ((eq tem (car form))(setq dec nil)) + (t (setq form (cons tem (car form)))))) +; (if (and doc (not decls)) (setq form (cons doc form))) + ;decls= (((v1 . type1) (v2 . type2) ..)(special-var1 special-var2 ..)) + (list decls form doc)) + +(defun get-back-some-decls (decls vars &aux specials types tem) +;; build up a declare to restore the decls. + (setq specials(sloop for v in vars when (member v (second decls)) + collect v )) + (setq types(sloop for v in vars + when (setq tem (assoc v (car decls))) + collect `(type ,(cdr tem) ,v))) + (cond (specials (push (cons 'special specials) types))) + (if types `((declare ,@ types))nil)) + +(defun b1-declare (form where &aux type vars) + where + (dolist (v (cdr form)) + (desetq (type . vars) v) + (cond ((eq type'special) + (sloop for w in-list vars + do (push (list v 'special (makevar v t)) *walk-variable-bindings*))) + ((member type '(ftype optimize function + ignore + declaration + dynamic-extent)) + nil) + ((member type '(inline notinline)) + (dolist-safe (v vars) + (push (cons v + (increment-function-decl type + (function-declaration v))) + *function-decls*))) + ((eq type 'type) + (desetq (type . vars) vars) + ;; do nothing. + ))) + nil) + +(defun b1-the (form where &aux sform type val tem) + ;; note this takes away the checking + (desetq (sform type val) form) + (setq val (b1-walk val where)) + (setq type (comp-type type)) + (cond ((and (consp val) (typep (setq tem (second val)) 'desk)) + (setf (second val) (set-desk-type tem type)) +; (unless (and (consp type) (eq (car type )'values) +; (consp (cdr type)) (consp (cddr type))) +; (setf (desk-single-value (second val)) t)) + val) + (t (setq tem (result-type val)) + (setq type (type-and tem type)) + `(the ,(make-desk type) ,val)))) + +(defun b1function-object (object where) + ;; this might be called by b1-funcall, b1-mapcar and others + ;; to avoid getting closure varialbes. They must promise to inline + ;; this, since the closure vars are not set up, for cross closure stuff. + + (cond ((matches object '(function (lambda . tem))) + + `(inline-function ,(b1-lambda-block (second object) 'function nil))) + (t (b1-walk object where )))) + +(defun b1-function (form where &aux sform body tem) where + (desetq (sform body) form) + (cond ((symbolp body) + (cond ((setq tem (assoc body *walk-functions*)) + (cons 'pointer-to-funobj (cddr tem))) + (t (b1-walk `(symbol-function ',body) where)))) + ((and (consp body) + (eq (car body) 'lambda)) + (b1-lambda-block body 'function 'clb)) + ;`(lambda-block ,(b1-lambda-block body 'function t)) + (t (error "unrecognized function ~a" body)))) + +(defun b1-go (form where &aux sform label clb result ) where + (desetq (sform label) form) + (sloop for v in *control-stack* + when (eq v 'clb) do (setq clb t) + else when (and (typep v 'label) + (eql (label-identifier v) label)) + do(setq result v) + (when clb + (setq clb (label-clb-reference v)) + (or (car clb) (setf (car clb) (incf (cadr clb)))) + (let ((tem (or (var-clb (third clb)) 0))) + (incf tem) + (setf (var-clb (third clb) ) tem))) + (return nil) + finally (comp-error "~a label is not found " label)) + (cond (clb (b1-walk `(progn (call-set-mv ,(car clb)) + (do-throw (done-b1 . ,(third clb))) nil) 'go)) + (t (setf (label-referred result) t) (list 'go result)))) + +;(defun b1-unwind-protect (x where &aux form cleanup +; (var (gensym)) +; ) +; (desetq (nil form . cleanup) x) +; (bound-variables-volatile) +; (b1-walk +; `(let ((,var (function (lambda () ,@ cleanup)))) +; (declare (dynamic-extent ,var)) +; (push-unwind-protect ,var) +; (multiple-value-prog1 +; ,form +; (pop-control-stack) +; (funcall ,var))) +; where)) + +(defun simple-b1 (x where &aux sform form) + (desetq (sform form) x) + `(,sform ,(b1-walk form where))) +(setf (get 'let-control-stack 'b1) 'simple-b1) + +(defun b1-unwind-protect (x where &aux form cleanup + (var (gensym)) + ) + (desetq (nil form . cleanup) x) + (bound-variables-volatile) + (b1-walk + `(let ((,var (function (lambda () ,@ cleanup)))) + (declare (dynamic-extent ,var)) + (let-control-stack (progn (push-unwind-protect ,var) ,form))) + where)) + +(defun b1-progv (x where &aux vars vals body bind) + (desetq (vars vals . body) (cdr x)) + (setq bind (b1-walk `(the fixnum (progv-bind ,vars ,vals)) 'progv)) + (let ((*control-stack* (cons 'progv *control-stack*))) + (setq body (mapcar2 'b1-walk body 'progv where)) + `(progv ,(make-desk (result-type (car (last body)))) + ,bind ,body))) + +(defun b1-catch (x where &aux tag bod ) + where + (desetq (tag . bod) (cdr x)) + (bound-variables-volatile) + `(let-control-stack + ,(b1-walk + `(if (control-jumped-back ,tag) (progn (nlj-active-off)(pass-values)) + (progn ,@ bod)) + 'catch))) + +(defun b1-throw (x where &aux tag bod form) where + (desetq ( tag form . bod ) (cdr x)) + (or (null bod) (comp-error "too many args to throw ~a" x)) + (let (sym) + (b1-walk + `(let ,(cond ((and (consp tag)(eq (car tag) 'quote))(setq sym tag) nil) + (t (setq sym (gensym)) `((,sym ,tag)))) + (call-set-mv ,form) + (do-throw ,sym) + nil) + 'throw))) + +;(defun b1-throw (x where &aux tag bod form) where +; (desetq ( tag form . bod ) (cdr x)) +; (or (null bod) (comp-error "too many args to throw ~a" x)) +; `(throw ,*default-desk* ,tag ,(b1-walk form 'throw))) + +(defun b1-multiple-value-prog1 (x where &aux first bod) + (desetq (nil first . bod) x) + `(multiple-value-prog1 ,*default-desk* ,(b1-walk first where) + ,(mapcar2 'b1-walk bod 'progn))) + +(defun b1-block (x where &aux sform tag bod + ( *control-stack* *control-stack*) + (*walk-variable-bindings* *walk-variable-bindings*) + block ans var) + (desetq (sform tag . bod) x) + (setq block (make-block (make-label :identifier tag + :clb-reference (setq var (makevar nil nil)) + ))) + (push var *walk-variable-bindings*) + (push block *control-stack*) + (or bod (setq bod '(nil))) + (setq bod (mapcar2 'b1-walk bod sform where)) + (setq ans `(,sform ,(make-desk (result-type (car (last bod)))) + ,block ,bod)) + (cond ((var-clb var) + (bound-variables-volatile) + (setq ans + `(let-control-stack + (let ,(second ans) , + `((,var ,(b1-walk '(unique-id) 'let-var))) + (,(b1-walk `(if (control-jumped-back (done-b1 . ,var)) + (progn + (nlj-active-off) + (pass-values)) + (done-b1 . ,ans)) + where)))))) + (t (setf (label-clb-reference (block-label block)) nil))) + ans + ) + +(defun b1-return-from (x where &aux clb tag block form bod) where + (desetq (nil tag . bod) x) + (cond ((null bod) (setq form nil)) + ((consp bod) (setq form (car bod)) + (or (null (cdr bod)) + (comp-error "Too many values for return-from ~a"x))) + (t (comp-error "Bad return from ~a" x))) + (sloop for v in *control-stack* + when (eq v 'clb) do (setq clb t) + else + when (and (typep v 'block) + (eql (label-identifier (block-label v)) tag)) + do (setq block v) + (when clb + (setq clb (label-clb-reference (block-label v))) + (cond ((var-clb clb) (incf (var-clb clb))) + (t (setf (var-clb clb) 1)))) + (return nil) + finally (comp-error "Could not find ~a tag to return from" block)) + (cond (clb + (b1-walk `(progn + (call-set-mv ,form) + (do-throw ,(cons 'done-b1 clb)) + nil + ) + 'return-from)) + (t (setq form (b1-walk form 'return-from)) + `(return-from ,(make-desk (result-type form)) ,block ,form)))) + +(defun b1-values (x where) + (let ((argl (mapcar2 'b1-walk (cdr x) where))) + `(values , (make-desk (if argl (result-type (car argl)) t)) ,argl))) + + + +;; Several WL functions for Walk to fix Line-info, and +;; make it more sensible for special forms. + +(do ((v '(let wl-let + let* wl-let + compiler-let wl-let + cond wl-cond + ) (cddr v))) + ((null v)) + (setf (get (car v) 'wl) (second v))) + +(defun wl-let (form &aux sform vars bod) + (desetq (sform vars . bod) form) + (dolist (v vars) + (if (consp v) + (transfer-line-info v (second v) nil)))) + +(defun wl-cond (form &aux clauses) + (desetq (nil . clauses) form) + (dolist (v clauses) + (or (consp v) (error "bad cond clause")) + (transfer-line-info v (if (consp (car v)) (car v) + (second v)) nil))) + +(defun use-expansion (do) + (if do (setf si::lambda-block-expanded (symbol-function 'si::expand-fun)) + (setf si::lambda-block-expanded nil))) + +(defmacro switch (test &body body &aux tem (tes (gensym ))) + (sloop for v in-list body + when + (and (consp v) (eq (car v) 'case) + (consp (cdr v)) + (null (cddr v))) + collect (setq tem (make-symbol (format nil "case~a_" (cadr v)))) into bod + and + collect (cons (cadr v) tem) into cases + else collect v into bod + finally + (return + `(tagbody + (let ((,tes ,test)) + (declare (fixnum ,tes)) + (cond ,@ (sloop for v in cases + when (typep (car v) 'fixnum) + collect `((eql ,tes ,(car v))(go ,(cdr v))) + else + collect `(t (go ,(cdr v)))))) + ,@ bod)))) + +;(switch n (case 0) 3) + + + + + + +;; +;;- Local variables: +;;- mode:lisp +;;- version-control:t +;;- End: + + + + + + + + + + + diff --git a/comp/wr.lsp b/comp/wr.lsp new file mode 100755 index 0000000..e36fdbf --- /dev/null +++ b/comp/wr.lsp @@ -0,0 +1,476 @@ +(in-package "BCOMP") +(defmacro wr (&rest l) + `(progn ,@ (mapcar #'(lambda (x) + (if (stringp x) `(princ ,x *c-output*) + `(wr1 ,x))) + l + ))) +(defmacro wr-nl (&rest l) + `(wr " + " ,@l)) + +(defmacro wr-h (&rest l) + `(progn (princ " + " *h-output*) + ,@ (mapcar #'(lambda (x) + (if (stringp x) `(princ ,x *h-output*) + `(wr1-h ,x))) + l))) + +(defun wr1 (x ) + (cond ((or (typep x 'fixnum)(stringp x)) (princ x *c-output*)) + ((consp x) + (or (symbolp (car x)) (wfs-error)) + (let ((fd (get (car x) 'wr))) + (or fd (wfs-error)) + (funcall fd x))) + ((typep x 'var) + (cond ((var-clb x) + (wr "ClosRef(" (list 'closure-var-loc x) ")")) + ((var-special-p x) + (or (var-ind x) (wfs-error)) + (cond ((= *safety* 0) + (wr "("(var-ind x)")->s.Bind" )) + (t (wr "symbol_value("(var-ind x)")" )))) + (t (or (var-ind x) (next-cvar x)) + (cond ((stringp (var-ind x)) (wr (var-ind x))) + (t (wr "V" (var-ind x))))))) + ((eq t x)(wr "Ct")) + ((eq nil x)(wr "Cnil")) + ((typep x 'label) + (or (label-ind x) (setf (label-ind x) (next-label))) + (wr (label-ind x))) + ((typep x 'fdata) + (let ((i (fdata-ind x))) + (if (stringp i) (wr i) (wr "L" i)))) + (t (wfs-error)))) + +(defun wr1-h (x &aux (*c-output* *h-output*)) + (wr1 x)) + +(setf (get 'dv 'wr) 'wr-dv) +(setf (get 'd_eval 'wr) 'wr-dv) + +(defun add-data (x &aux tem) + (or (and (consp x) (or (eq (car x) 'dv) + (eq (car x) 'd_eval))) + (wfs-error)) + (let ((item (third x))) + (unless (second x) + (cond + ((and (symbolp item) + (setq tem (get item 'dv))) + (setf (second x) tem)) + ((and (typep item 'fixnum) + (eql 0 (logand #. (lognot 1023) (the fixnum item)))) + (setf (cadr x) + (format nil "small_fixnum(~a)" item))) + (t (setf (second x) *next-data*) + (push-data (car x) (third x))))) + x)) + +;; Some things namely the keyword mechanism REQUIRES a constant which +;; has an index. This means that named ones will have to get an index +;; We could smash this place +(defun get-dv-index (x) + ;; a (dv which may have a string. We put an index in the fourth place.) + (cond ((typep (second x) 'fixnum) (second x)) + ((cdddr x) (fourth x)) + (t (setq x (nconc x (list *next-data*))) + (push-data (car x) (third x))))) + +(defun wr-dv (x) + (let ((tem (second x))) + (cond (tem + (cond ((typep tem 'fixnum) (wr "VV[" tem"]")) + (t (wr tem)))) + (t (add-data x) + (wr-dv x))))) + + +(setf (get 'var 'wr) 'wr-var) +(defun wr-var (x) + (cond ((and (consp x) (eq (car x) 'var)) + (wr-vind (second x))) + (t (wfs-error)))) + +(defun wr-vind (x) + (if (stringp x) (wr x) (wr "V" x))) + +(setf (get 'closure-var-loc 'wr) 'wr-closure-var-loc) +(defun wr-closure-var-loc (x &aux (var (second x))) + (cond ((member var *closure-vars*) + (wr "CLvars->") + (or (and (consp (var-ind var)) (eq (car (var-ind var)) 'kw)) + (wfs-error)) + (wr-vind (second (var-ind var)))) + (t (wr-vind (var-ind var))))) + +(setf (get 'key-var 'wr) 'wr-key-var) +(defun wr-key-var (x &aux (v (second x)) tem) + (or (typep v 'var) (wfs-error)) + (cond ((setq tem (var-special-p v)) + (wr tem)) + (t + (wr-vind (var-ind v))))) + + + +(setf (get 'vcs 'wr) 'wr-vcs) +(defun wr-vcs(x) + (wr "cs[" (second x)"]")) + +(setf (get 'kw 'wr) 'wr-kw) +(defun wr-kw(x) + (wr "k.") + (wr-vind (second x))) + +(setf (get 'vk 'wr) 'wr-vk) +(defun wr-vk (x) + (wr "&VK" (second x) "key")) + +(defun wr-comment (message &optional (symbol nil)) + (wr " +/* " message) + (and symbol (wr (mangle symbol))) + + (wr " */ +") + nil) + +(setf (get 'label 'wr) 'wr-label) +(defun wr-label (n &aux) + (when (consp n) + (or (eq (car n) 'label) (wfs-error)) + (setq n (second n))) + (wr " + LA" n ": ")) + +(defun wr-go (n) + (if (typep n 'label) + (or (label-ind n) (setq n (setf (label-ind n) (next-label))))) + (wr "goto LA" n ";")) + +(defun wr-list (l) + (do ((v l (cdr v))) + ((null v)) + (wr (car v)) + (or (null (cdr v)) (wr ",")))) + +(setf (get 'next-var-arg 'wr) 'wr-next-var-arg) +(defun wr-next-var-arg (x) + x (wr "va_arg(Iap,object)")) + + +(setf (get 'call 'wr) 'wr-call) +(defun wr-call (x) + (let* ((cdat (second x)) + (fname (call-data-fname cdat)) + (name (if (symbolp fname) (symbol-name fname) + (format nil "L~a" (fdata-ind fname))))) + (wr "CA_" name "(") + (wr-list (third x)) + (wr ")")) + ) + +(defmacro var-implementation-type (x) + `(cond ((and (plain-var-p ,x) + (not (and (consp (var-ind ,x)) (eq (car (var-ind ,x)) 'kw)))) + (var-type ,x)) + (t t))) + +(defun wr-set-inline-loc (a b &aux type) + (cond ((eq a b) (wr ";")(return-from wr-set-inline-loc nil))) + (cond((atom a) + (or (typep a 'var) (wfs-error)) + (cond ((var-special-p a) + (setq type 'special) + (wr-nl "(" (var-ind a) ")->s.Bind = ")) + (t (setq type (var-implementation-type a))))) + ((and (consp a) (eq (car a) 'var)) + (setq type (third a))) + (t (wfs-error))) + + (cond ((eq type 'integer) + (let ((val-type (value-type b))) + (case val-type + (fixnum (wr-nl "ISETQ_FIX(") ) + (integer (wr-nl "SETQ_II(") ) + (otherwise (wr-nl "SETQ_IO(") (setq val-type t))) + (setq b (list 'inline-loc val-type b)) + (wr a","a"__alloc," b ");") + (return-from wr-set-inline-loc nil))) + ((eq type 'special) + (setq type t)) + (t (wr-nl a "="))) + (case type + (fixnum (wr-fixnum-loc b)) + (character (wr-character-loc b)) + (gen (wr-integer-loc b)) + (double-float (wr-double-float-loc b)) + (double_ptr (wr-double_ptr-loc b)) + (short-float (wr-short-float-loc b)) + (boolean (wr-boolean-loc b)) + (t (wr-obj-loc b))) + (wr ";") + ) + +(defun wr-integer-loc (x) + (cond ((and (dv-p x) (typep (third x) 'fixnum)) + (setq x (list 'inline-loc 'fixnum x)))) + (case (value-type x) + (integer (wr x)) + (fixnum (wr "stoi(" x ")")) + (t (wr "otoi(" x ")")))) + + + +(defun value-type (x &aux tem) + ;; returns the representation type of form x + (setq tem + (cond ((consp x) + (cond ((eq (car x) 'dv) t) + + ((eq (car x) 'var) (or (third x) t)) + ((eq (car x) 'inline-call) (nth 3 x)) + ((eq (car x) 'inline-loc) (nth 1 x)) + ((eq (car x) 'let-control-stack) + (value-type (second x))) + ((eq (car x) 'next-var-arg) t) + )) + ((typep x 'var) + (var-implementation-type x)))) + + (unless tem + (comp-warn "Don't know type of ~a. Assuming type t" x)) + (or (memq tem '(fixnum integer short-float double-float character boolean double_ptr)) + (setq tem t)) + tem) + + +(setf (get 'inline-loc 'wr) 'wr-inline-loc) + +(defun wr-inline-loc (x &aux (y (third x)) (type (second x))) + (case type + (fixnum (wr-fixnum-loc y)) + (short-float (wr-short-float-loc y)) + (double-float (wr-double-float-loc y)) + (double_ptr (wr-double_ptr-loc y)) + (character (wr-character-loc y)) + ((gen integer) (wr-integer-loc y)) + (boolean (wr-boolean-loc y)) + (t (wr-obj-loc y)))) + +(setf (get 'fixnum 'loc) 'wr-fixnum) + +(defun wr-boolean-loc (x) + (let ((type (value-type x))) + (case type + (boolean (wr x)) + ((short-float double_ptr character long-float integer) (wr "1")) + (t (wr "(" x ")!=sLnil" ))))) + + +(defun wr-fixnum-loc (b) + (case (value-type b) + (fixnum (wr b)) + ((short-float long-float) (wr "(int)(" b")" )) + (double_ptr (wr "(int)(*(" b "))")) + (integer (wr "itos(" b")")) + (t + (cond ((and (consp b) (eq (car b) 'dv)) + (cond ((typep (third b) 'fixnum) + (wr (third b)) (return-from wr-fixnum-loc nil)) + (t (comp-warn "Not a fixnum ~a "(third b)))))) + (wr "fix(" b ")")))) + +(defun wr-character-loc (b) + (case (value-type b) + (character (wr b)) + ((short-float long-float) + (comp-error "Cant coerce float to character") + (wr "(int)(" b")" )) + (integer (wfs-todo)) + (t + (cond ((and (consp b) (eq (car b) 'dv)) + (cond ((typep (third b) 'character) + (wr (char-code (third b))) (return-from wr-character-loc nil)) + (t (comp-warn "Not a character ~a "(third b)))))) + (wr "char_code(" b ")")))) + + +(defun wr-double-float-loc (b) + (case (value-type b) + ((short-float fixnum) (wr "(double)(" b ")")) + (double-float (wr b)) + (double_ptr (wr "*(" b ")")) + (integer (wfs-todo)) + (t (wr "DFloat(" b ")")))) + +(defun wr-short-float-loc (b) + (case (value-type b) + ((short-float fixnum double-float) (wr "(float)(" b ")")) + (double_ptr (wr "(float)(*(" b "))")) + (integer (wfs-todo)) + (t (wr "SFloat(" b ")")))) + +(defun wr-double_ptr-loc (b &aux tem) + (case (value-type b) + ((short-float fixnum) + (setq tem (get-temp 'double_ptr)) + (wr "*"tem" = (double)(" b ")") ) + (double (wr "*("b")")) + (integer (wfs-todo)) + (t + ;;wrong + (object (wr "&(DFloat(" b "))"))))) + + +(defun wr-obj-loc (x) + (case (value-type x) + (short-float (wr "make_shortfloat(" x ")")) + (double-float (wr "Imake_doublefloat(" x ")")) + (double_ptr (wr "Imake_doublefloat(*(" x "))")) + (fixnum (wr "make_fixnum(" x ")")) + (integer + (wr "make_integer(" x ")")) + (character (wr "code_char(" x ")")) + (boolean (wr "(" x "? sLt : sLnil)")) + (t (wr x)))) + +(setf (get 'inline-call 'wr) 'wr-inline-call) + +(defun wr-inline-call (x ) +; (desetq (sform iargs arg-types res flags fstring) x) + (wr-inline-call1 (cadr x) (opt template (cddr x)))) + +(defun wr-link-call (lnk iargs &aux nochange) + (let* ((argd (link-argd lnk)) + (n (length iargs))) + (declare (fixnum argd )) + (cond ((< n (argd-minargs argd)) + (setf (argd-minargs argd) n)) + ((> n (argd-maxargs argd)) + (setf (argd-maxargs argd) n)) + (t (setq nochange t)) + (setf (argd-minargs (link-argd lnk)))) + (unless nochange + (setf (link-argd lnk) argd)) + (or (link-ind lnk) (setf (link-ind lnk) (mangle-name (link-fname lnk) 'function))) + (cond ((argd-flag-p argd requires-nargs) + (wr "(VFUN_NARGS=" n ","))) + + (wr "(*LnK" (link-ind lnk) ")(") + (wr-list iargs) + (wr ")") + (cond ((argd-flag-p argd requires-nargs) + (wr ")"))))) + +(defun wr-inline-call1 (iargs fstring &aux + (leng 0) wrote-paren + (ch #\space) (ind 0) (start 0) + (out *c-output*)) +;; $@i : write out all (nthcdr i args) in a comma separated list. +;; $i : write out arg i ( 0<= i < 10) +;; $# : write out (length iargs) +;; @i,j,..; i,j,.. are multiple eval'd. +;; $*i : push args starting at the ith onto value stack and pass the pointer +;; to the place where you start. + (declare (character ch) (fixnum ind leng start) + (string fstring)) + (cond ((stringp fstring)) + ((typep fstring 'link) + (wr-link-call fstring iargs) (return-from wr-inline-call1 nil)) + (t (return-from wr-inline-call1 (funcall fstring iargs)))) + (setq leng (length fstring)) + ;; save multiple eval'd args. @0,3; means args 0 and 3 need temps. + (cond ((eql (aref fstring 0) #\@) + (sloop for i from 1 below leng + until (eql (setq ch (aref fstring i)) #\;) + when (digit-char-p ch) + do (let ((tem (nth (setq ind (- (char-code ch )(char-code #\0))) + iargs))) + (unless (or (typep tem 'var) + (and (consp tem) + (or (eq (car tem) 'dv) + (eq (car tem) 'var)))) + (let ((v (get-temp (value-type + (nth ind iargs))))) + (setf (nth ind iargs) v) + (unless wrote-paren + (setq wrote-paren t) + (wr "(")) + (wr v "= " tem ",")))) + finally (setq start (+ 1 i))))) + + ;; write out the template. + (sloop for i from start below leng with l = (length iargs) + declare (fixnum l) + do (setq ch (aref (the string fstring) i)) + (cond + ((or (eql ch #\$) + (eql ch #\#);; compatibility with akcl + ) + (setq i (+ i 1)) + (setq ch (aref (the string fstring) i)) + (setq ind (- (char-code ch) (char-code #\0))) + (cond ((and (< ind 10) (>= ind 0)) + (if (>= ind l) + (comp-error "Bad inline template ~a" fstring)) + (wr (nth ind iargs))) + ((eql ch #\@) + (setq i (+ i 1)) + (let ((n (- (char-code (aref fstring i)) (char-code #\0)))) + (declare (fixnum n)) + (wr-list (nthcdr n iargs)))) + ((eql ch #\*) + (setq i (+ i 1)) + (let* ((n (- (char-code (aref fstring i)) (char-code #\0))) + (m (- (length iargs) n)) + (p (get-temp "object *"))) + (declare (fixnum n m)) + (wr "(" p "= (vs_top+=" m"),") + (sloop for v in (reverse (nthcdr n iargs)) + do (wr "*--"p" =" v",")) + (wr p ")"))) + ((eql ch #\# ) (wr (length iargs))) + (t (comp-error "Bad inline string ~s" fstring)))) + (t (write-char ch out)))) + ; + (if wrote-paren (wr ")")) + ) +(defun write-out-links( &aux lnk) + (dolist (v *file-inline-templates*) + (or (typep (setq lnk (nth 4 v)) 'link) (wfs-error)) + (let ((ind (link-ind lnk)) + (rett (rep-type (third v)))) + (wr " +static " rett "LnKT" ind "(va_alist)va_dcl +{va_list Iap; va_start(Iap); return ("rett ")Icall_proc" + (if (eq (third v) 'short-float) "_float(" "(") + (get-object (link-fname lnk)) "," + (link-argd lnk) + ",&LnK" (link-ind lnk ) ",Iap);}") + (wr-h "static "rett "LnKT"ind"(),(*LnK" + ind ")()=LnKT" ind ";") + ) + )) + +(defun write-out-address-and-data () + (let ((*c-output* *h-output*)) + (wr" +static object VV[" (max 1 (length *address-vector*) *next-data*) "]={") + (let ((l (length *address-vector*)) + (i 0)) + (declare (fixnum i l)) + (sloop while (< i l) + do (wr-nl "(void *)" (aref *address-vector* i)) + when (< (setq i (+ i 1)) l) + do (wr ",")) + (if (eql i 0) (wr 0)) + (wr "};"))) + (wt-data-file)) + +(setf (get 'address 'wr) 'wr-address) +(defun wr-address (x) + (wr "&" (second x))) \ No newline at end of file diff --git a/config.guess b/config.guess new file mode 100755 index 0000000..1f5c50c --- /dev/null +++ b/config.guess @@ -0,0 +1,1420 @@ +#! /bin/sh +# Attempt to guess a canonical system name. +# Copyright 1992-2014 Free Software Foundation, Inc. + +timestamp='2014-03-23' + +# This file is free software; you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, see . +# +# As a special exception to the GNU General Public License, if you +# distribute this file as part of a program that contains a +# configuration script generated by Autoconf, you may include it under +# the same distribution terms that you use for the rest of that +# program. This Exception is an additional permission under section 7 +# of the GNU General Public License, version 3 ("GPLv3"). +# +# Originally written by Per Bothner. +# +# You can get the latest version of this script from: +# http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.guess;hb=HEAD +# +# Please send patches with a ChangeLog entry to config-patches@gnu.org. + + +me=`echo "$0" | sed -e 's,.*/,,'` + +usage="\ +Usage: $0 [OPTION] + +Output the configuration name of the system \`$me' is run on. + +Operation modes: + -h, --help print this help, then exit + -t, --time-stamp print date of last modification, then exit + -v, --version print version number, then exit + +Report bugs and patches to ." + +version="\ +GNU config.guess ($timestamp) + +Originally written by Per Bothner. +Copyright 1992-2014 Free Software Foundation, Inc. + +This is free software; see the source for copying conditions. There is NO +warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." + +help=" +Try \`$me --help' for more information." + +# Parse command line +while test $# -gt 0 ; do + case $1 in + --time-stamp | --time* | -t ) + echo "$timestamp" ; exit ;; + --version | -v ) + echo "$version" ; exit ;; + --help | --h* | -h ) + echo "$usage"; exit ;; + -- ) # Stop option processing + shift; break ;; + - ) # Use stdin as input. + break ;; + -* ) + echo "$me: invalid option $1$help" >&2 + exit 1 ;; + * ) + break ;; + esac +done + +if test $# != 0; then + echo "$me: too many arguments$help" >&2 + exit 1 +fi + +trap 'exit 1' 1 2 15 + +# CC_FOR_BUILD -- compiler used by this script. Note that the use of a +# compiler to aid in system detection is discouraged as it requires +# temporary files to be created and, as you can see below, it is a +# headache to deal with in a portable fashion. + +# Historically, `CC_FOR_BUILD' used to be named `HOST_CC'. We still +# use `HOST_CC' if defined, but it is deprecated. + +# Portable tmp directory creation inspired by the Autoconf team. + +set_cc_for_build=' +trap "exitcode=\$?; (rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null) && exit \$exitcode" 0 ; +trap "rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null; exit 1" 1 2 13 15 ; +: ${TMPDIR=/tmp} ; + { tmp=`(umask 077 && mktemp -d "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } || + { test -n "$RANDOM" && tmp=$TMPDIR/cg$$-$RANDOM && (umask 077 && mkdir $tmp) ; } || + { tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir $tmp) && echo "Warning: creating insecure temp directory" >&2 ; } || + { echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; } ; +dummy=$tmp/dummy ; +tmpfiles="$dummy.c $dummy.o $dummy.rel $dummy" ; +case $CC_FOR_BUILD,$HOST_CC,$CC in + ,,) echo "int x;" > $dummy.c ; + for c in cc gcc c89 c99 ; do + if ($c -c -o $dummy.o $dummy.c) >/dev/null 2>&1 ; then + CC_FOR_BUILD="$c"; break ; + fi ; + done ; + if test x"$CC_FOR_BUILD" = x ; then + CC_FOR_BUILD=no_compiler_found ; + fi + ;; + ,,*) CC_FOR_BUILD=$CC ;; + ,*,*) CC_FOR_BUILD=$HOST_CC ;; +esac ; set_cc_for_build= ;' + +# This is needed to find uname on a Pyramid OSx when run in the BSD universe. +# (ghazi@noc.rutgers.edu 1994-08-24) +if (test -f /.attbin/uname) >/dev/null 2>&1 ; then + PATH=$PATH:/.attbin ; export PATH +fi + +UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown +UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown +UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown +UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown + +case "${UNAME_SYSTEM}" in +Linux|GNU|GNU/*) + # If the system lacks a compiler, then just pick glibc. + # We could probably try harder. + LIBC=gnu + + eval $set_cc_for_build + cat <<-EOF > $dummy.c + #include + #if defined(__UCLIBC__) + LIBC=uclibc + #elif defined(__dietlibc__) + LIBC=dietlibc + #else + LIBC=gnu + #endif + EOF + eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^LIBC' | sed 's, ,,g'` + ;; +esac + +# Note: order is significant - the case branches are not exclusive. + +case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in + *:NetBSD:*:*) + # NetBSD (nbsd) targets should (where applicable) match one or + # more of the tuples: *-*-netbsdelf*, *-*-netbsdaout*, + # *-*-netbsdecoff* and *-*-netbsd*. For targets that recently + # switched to ELF, *-*-netbsd* would select the old + # object file format. This provides both forward + # compatibility and a consistent mechanism for selecting the + # object file format. + # + # Note: NetBSD doesn't particularly care about the vendor + # portion of the name. We always set it to "unknown". + sysctl="sysctl -n hw.machine_arch" + UNAME_MACHINE_ARCH=`(/sbin/$sysctl 2>/dev/null || \ + /usr/sbin/$sysctl 2>/dev/null || echo unknown)` + case "${UNAME_MACHINE_ARCH}" in + armeb) machine=armeb-unknown ;; + arm*) machine=arm-unknown ;; + sh3el) machine=shl-unknown ;; + sh3eb) machine=sh-unknown ;; + sh5el) machine=sh5le-unknown ;; + *) machine=${UNAME_MACHINE_ARCH}-unknown ;; + esac + # The Operating System including object format, if it has switched + # to ELF recently, or will in the future. + case "${UNAME_MACHINE_ARCH}" in + arm*|i386|m68k|ns32k|sh3*|sparc|vax) + eval $set_cc_for_build + if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \ + | grep -q __ELF__ + then + # Once all utilities can be ECOFF (netbsdecoff) or a.out (netbsdaout). + # Return netbsd for either. FIX? + os=netbsd + else + os=netbsdelf + fi + ;; + *) + os=netbsd + ;; + esac + # The OS release + # Debian GNU/NetBSD machines have a different userland, and + # thus, need a distinct triplet. However, they do not need + # kernel version information, so it can be replaced with a + # suitable tag, in the style of linux-gnu. + case "${UNAME_VERSION}" in + Debian*) + release='-gnu' + ;; + *) + release=`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'` + ;; + esac + # Since CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM: + # contains redundant information, the shorter form: + # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used. + echo "${machine}-${os}${release}" + exit ;; + *:Bitrig:*:*) + UNAME_MACHINE_ARCH=`arch | sed 's/Bitrig.//'` + echo ${UNAME_MACHINE_ARCH}-unknown-bitrig${UNAME_RELEASE} + exit ;; + *:OpenBSD:*:*) + UNAME_MACHINE_ARCH=`arch | sed 's/OpenBSD.//'` + echo ${UNAME_MACHINE_ARCH}-unknown-openbsd${UNAME_RELEASE} + exit ;; + *:ekkoBSD:*:*) + echo ${UNAME_MACHINE}-unknown-ekkobsd${UNAME_RELEASE} + exit ;; + *:SolidBSD:*:*) + echo ${UNAME_MACHINE}-unknown-solidbsd${UNAME_RELEASE} + exit ;; + macppc:MirBSD:*:*) + echo powerpc-unknown-mirbsd${UNAME_RELEASE} + exit ;; + *:MirBSD:*:*) + echo ${UNAME_MACHINE}-unknown-mirbsd${UNAME_RELEASE} + exit ;; + alpha:OSF1:*:*) + case $UNAME_RELEASE in + *4.0) + UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $3}'` + ;; + *5.*) + UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $4}'` + ;; + esac + # According to Compaq, /usr/sbin/psrinfo has been available on + # OSF/1 and Tru64 systems produced since 1995. I hope that + # covers most systems running today. This code pipes the CPU + # types through head -n 1, so we only detect the type of CPU 0. + ALPHA_CPU_TYPE=`/usr/sbin/psrinfo -v | sed -n -e 's/^ The alpha \(.*\) processor.*$/\1/p' | head -n 1` + case "$ALPHA_CPU_TYPE" in + "EV4 (21064)") + UNAME_MACHINE="alpha" ;; + "EV4.5 (21064)") + UNAME_MACHINE="alpha" ;; + "LCA4 (21066/21068)") + UNAME_MACHINE="alpha" ;; + "EV5 (21164)") + UNAME_MACHINE="alphaev5" ;; + "EV5.6 (21164A)") + UNAME_MACHINE="alphaev56" ;; + "EV5.6 (21164PC)") + UNAME_MACHINE="alphapca56" ;; + "EV5.7 (21164PC)") + UNAME_MACHINE="alphapca57" ;; + "EV6 (21264)") + UNAME_MACHINE="alphaev6" ;; + "EV6.7 (21264A)") + UNAME_MACHINE="alphaev67" ;; + "EV6.8CB (21264C)") + UNAME_MACHINE="alphaev68" ;; + "EV6.8AL (21264B)") + UNAME_MACHINE="alphaev68" ;; + "EV6.8CX (21264D)") + UNAME_MACHINE="alphaev68" ;; + "EV6.9A (21264/EV69A)") + UNAME_MACHINE="alphaev69" ;; + "EV7 (21364)") + UNAME_MACHINE="alphaev7" ;; + "EV7.9 (21364A)") + UNAME_MACHINE="alphaev79" ;; + esac + # A Pn.n version is a patched version. + # A Vn.n version is a released version. + # A Tn.n version is a released field test version. + # A Xn.n version is an unreleased experimental baselevel. + # 1.2 uses "1.2" for uname -r. + echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[PVTX]//' | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` + # Reset EXIT trap before exiting to avoid spurious non-zero exit code. + exitcode=$? + trap '' 0 + exit $exitcode ;; + Alpha\ *:Windows_NT*:*) + # How do we know it's Interix rather than the generic POSIX subsystem? + # Should we change UNAME_MACHINE based on the output of uname instead + # of the specific Alpha model? + echo alpha-pc-interix + exit ;; + 21064:Windows_NT:50:3) + echo alpha-dec-winnt3.5 + exit ;; + Amiga*:UNIX_System_V:4.0:*) + echo m68k-unknown-sysv4 + exit ;; + *:[Aa]miga[Oo][Ss]:*:*) + echo ${UNAME_MACHINE}-unknown-amigaos + exit ;; + *:[Mm]orph[Oo][Ss]:*:*) + echo ${UNAME_MACHINE}-unknown-morphos + exit ;; + *:OS/390:*:*) + echo i370-ibm-openedition + exit ;; + *:z/VM:*:*) + echo s390-ibm-zvmoe + exit ;; + *:OS400:*:*) + echo powerpc-ibm-os400 + exit ;; + arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*) + echo arm-acorn-riscix${UNAME_RELEASE} + exit ;; + arm*:riscos:*:*|arm*:RISCOS:*:*) + echo arm-unknown-riscos + exit ;; + SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*) + echo hppa1.1-hitachi-hiuxmpp + exit ;; + Pyramid*:OSx*:*:* | MIS*:OSx*:*:* | MIS*:SMP_DC-OSx*:*:*) + # akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE. + if test "`(/bin/universe) 2>/dev/null`" = att ; then + echo pyramid-pyramid-sysv3 + else + echo pyramid-pyramid-bsd + fi + exit ;; + NILE*:*:*:dcosx) + echo pyramid-pyramid-svr4 + exit ;; + DRS?6000:unix:4.0:6*) + echo sparc-icl-nx6 + exit ;; + DRS?6000:UNIX_SV:4.2*:7* | DRS?6000:isis:4.2*:7*) + case `/usr/bin/uname -p` in + sparc) echo sparc-icl-nx7; exit ;; + esac ;; + s390x:SunOS:*:*) + echo ${UNAME_MACHINE}-ibm-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + sun4H:SunOS:5.*:*) + echo sparc-hal-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*) + echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + i86pc:AuroraUX:5.*:* | i86xen:AuroraUX:5.*:*) + echo i386-pc-auroraux${UNAME_RELEASE} + exit ;; + i86pc:SunOS:5.*:* | i86xen:SunOS:5.*:*) + eval $set_cc_for_build + SUN_ARCH="i386" + # If there is a compiler, see if it is configured for 64-bit objects. + # Note that the Sun cc does not turn __LP64__ into 1 like gcc does. + # This test works for both compilers. + if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then + if (echo '#ifdef __amd64'; echo IS_64BIT_ARCH; echo '#endif') | \ + (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \ + grep IS_64BIT_ARCH >/dev/null + then + SUN_ARCH="x86_64" + fi + fi + echo ${SUN_ARCH}-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + sun4*:SunOS:6*:*) + # According to config.sub, this is the proper way to canonicalize + # SunOS6. Hard to guess exactly what SunOS6 will be like, but + # it's likely to be more like Solaris than SunOS4. + echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + sun4*:SunOS:*:*) + case "`/usr/bin/arch -k`" in + Series*|S4*) + UNAME_RELEASE=`uname -v` + ;; + esac + # Japanese Language versions have a version number like `4.1.3-JL'. + echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'` + exit ;; + sun3*:SunOS:*:*) + echo m68k-sun-sunos${UNAME_RELEASE} + exit ;; + sun*:*:4.2BSD:*) + UNAME_RELEASE=`(sed 1q /etc/motd | awk '{print substr($5,1,3)}') 2>/dev/null` + test "x${UNAME_RELEASE}" = "x" && UNAME_RELEASE=3 + case "`/bin/arch`" in + sun3) + echo m68k-sun-sunos${UNAME_RELEASE} + ;; + sun4) + echo sparc-sun-sunos${UNAME_RELEASE} + ;; + esac + exit ;; + aushp:SunOS:*:*) + echo sparc-auspex-sunos${UNAME_RELEASE} + exit ;; + # The situation for MiNT is a little confusing. The machine name + # can be virtually everything (everything which is not + # "atarist" or "atariste" at least should have a processor + # > m68000). The system name ranges from "MiNT" over "FreeMiNT" + # to the lowercase version "mint" (or "freemint"). Finally + # the system name "TOS" denotes a system which is actually not + # MiNT. But MiNT is downward compatible to TOS, so this should + # be no problem. + atarist[e]:*MiNT:*:* | atarist[e]:*mint:*:* | atarist[e]:*TOS:*:*) + echo m68k-atari-mint${UNAME_RELEASE} + exit ;; + atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*) + echo m68k-atari-mint${UNAME_RELEASE} + exit ;; + *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*) + echo m68k-atari-mint${UNAME_RELEASE} + exit ;; + milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*) + echo m68k-milan-mint${UNAME_RELEASE} + exit ;; + hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*) + echo m68k-hades-mint${UNAME_RELEASE} + exit ;; + *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*) + echo m68k-unknown-mint${UNAME_RELEASE} + exit ;; + m68k:machten:*:*) + echo m68k-apple-machten${UNAME_RELEASE} + exit ;; + powerpc:machten:*:*) + echo powerpc-apple-machten${UNAME_RELEASE} + exit ;; + RISC*:Mach:*:*) + echo mips-dec-mach_bsd4.3 + exit ;; + RISC*:ULTRIX:*:*) + echo mips-dec-ultrix${UNAME_RELEASE} + exit ;; + VAX*:ULTRIX*:*:*) + echo vax-dec-ultrix${UNAME_RELEASE} + exit ;; + 2020:CLIX:*:* | 2430:CLIX:*:*) + echo clipper-intergraph-clix${UNAME_RELEASE} + exit ;; + mips:*:*:UMIPS | mips:*:*:RISCos) + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c +#ifdef __cplusplus +#include /* for printf() prototype */ + int main (int argc, char *argv[]) { +#else + int main (argc, argv) int argc; char *argv[]; { +#endif + #if defined (host_mips) && defined (MIPSEB) + #if defined (SYSTYPE_SYSV) + printf ("mips-mips-riscos%ssysv\n", argv[1]); exit (0); + #endif + #if defined (SYSTYPE_SVR4) + printf ("mips-mips-riscos%ssvr4\n", argv[1]); exit (0); + #endif + #if defined (SYSTYPE_BSD43) || defined(SYSTYPE_BSD) + printf ("mips-mips-riscos%sbsd\n", argv[1]); exit (0); + #endif + #endif + exit (-1); + } +EOF + $CC_FOR_BUILD -o $dummy $dummy.c && + dummyarg=`echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` && + SYSTEM_NAME=`$dummy $dummyarg` && + { echo "$SYSTEM_NAME"; exit; } + echo mips-mips-riscos${UNAME_RELEASE} + exit ;; + Motorola:PowerMAX_OS:*:*) + echo powerpc-motorola-powermax + exit ;; + Motorola:*:4.3:PL8-*) + echo powerpc-harris-powermax + exit ;; + Night_Hawk:*:*:PowerMAX_OS | Synergy:PowerMAX_OS:*:*) + echo powerpc-harris-powermax + exit ;; + Night_Hawk:Power_UNIX:*:*) + echo powerpc-harris-powerunix + exit ;; + m88k:CX/UX:7*:*) + echo m88k-harris-cxux7 + exit ;; + m88k:*:4*:R4*) + echo m88k-motorola-sysv4 + exit ;; + m88k:*:3*:R3*) + echo m88k-motorola-sysv3 + exit ;; + AViiON:dgux:*:*) + # DG/UX returns AViiON for all architectures + UNAME_PROCESSOR=`/usr/bin/uname -p` + if [ $UNAME_PROCESSOR = mc88100 ] || [ $UNAME_PROCESSOR = mc88110 ] + then + if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx ] || \ + [ ${TARGET_BINARY_INTERFACE}x = x ] + then + echo m88k-dg-dgux${UNAME_RELEASE} + else + echo m88k-dg-dguxbcs${UNAME_RELEASE} + fi + else + echo i586-dg-dgux${UNAME_RELEASE} + fi + exit ;; + M88*:DolphinOS:*:*) # DolphinOS (SVR3) + echo m88k-dolphin-sysv3 + exit ;; + M88*:*:R3*:*) + # Delta 88k system running SVR3 + echo m88k-motorola-sysv3 + exit ;; + XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3) + echo m88k-tektronix-sysv3 + exit ;; + Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD) + echo m68k-tektronix-bsd + exit ;; + *:IRIX*:*:*) + echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'` + exit ;; + ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX. + echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id + exit ;; # Note that: echo "'`uname -s`'" gives 'AIX ' + i*86:AIX:*:*) + echo i386-ibm-aix + exit ;; + ia64:AIX:*:*) + if [ -x /usr/bin/oslevel ] ; then + IBM_REV=`/usr/bin/oslevel` + else + IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} + fi + echo ${UNAME_MACHINE}-ibm-aix${IBM_REV} + exit ;; + *:AIX:2:3) + if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #include + + main() + { + if (!__power_pc()) + exit(1); + puts("powerpc-ibm-aix3.2.5"); + exit(0); + } +EOF + if $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` + then + echo "$SYSTEM_NAME" + else + echo rs6000-ibm-aix3.2.5 + fi + elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then + echo rs6000-ibm-aix3.2.4 + else + echo rs6000-ibm-aix3.2 + fi + exit ;; + *:AIX:*:[4567]) + IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | sed 1q | awk '{ print $1 }'` + if /usr/sbin/lsattr -El ${IBM_CPU_ID} | grep ' POWER' >/dev/null 2>&1; then + IBM_ARCH=rs6000 + else + IBM_ARCH=powerpc + fi + if [ -x /usr/bin/oslevel ] ; then + IBM_REV=`/usr/bin/oslevel` + else + IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} + fi + echo ${IBM_ARCH}-ibm-aix${IBM_REV} + exit ;; + *:AIX:*:*) + echo rs6000-ibm-aix + exit ;; + ibmrt:4.4BSD:*|romp-ibm:BSD:*) + echo romp-ibm-bsd4.4 + exit ;; + ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC BSD and + echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to + exit ;; # report: romp-ibm BSD 4.3 + *:BOSX:*:*) + echo rs6000-bull-bosx + exit ;; + DPX/2?00:B.O.S.:*:*) + echo m68k-bull-sysv3 + exit ;; + 9000/[34]??:4.3bsd:1.*:*) + echo m68k-hp-bsd + exit ;; + hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*) + echo m68k-hp-bsd4.4 + exit ;; + 9000/[34678]??:HP-UX:*:*) + HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` + case "${UNAME_MACHINE}" in + 9000/31? ) HP_ARCH=m68000 ;; + 9000/[34]?? ) HP_ARCH=m68k ;; + 9000/[678][0-9][0-9]) + if [ -x /usr/bin/getconf ]; then + sc_cpu_version=`/usr/bin/getconf SC_CPU_VERSION 2>/dev/null` + sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null` + case "${sc_cpu_version}" in + 523) HP_ARCH="hppa1.0" ;; # CPU_PA_RISC1_0 + 528) HP_ARCH="hppa1.1" ;; # CPU_PA_RISC1_1 + 532) # CPU_PA_RISC2_0 + case "${sc_kernel_bits}" in + 32) HP_ARCH="hppa2.0n" ;; + 64) HP_ARCH="hppa2.0w" ;; + '') HP_ARCH="hppa2.0" ;; # HP-UX 10.20 + esac ;; + esac + fi + if [ "${HP_ARCH}" = "" ]; then + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + + #define _HPUX_SOURCE + #include + #include + + int main () + { + #if defined(_SC_KERNEL_BITS) + long bits = sysconf(_SC_KERNEL_BITS); + #endif + long cpu = sysconf (_SC_CPU_VERSION); + + switch (cpu) + { + case CPU_PA_RISC1_0: puts ("hppa1.0"); break; + case CPU_PA_RISC1_1: puts ("hppa1.1"); break; + case CPU_PA_RISC2_0: + #if defined(_SC_KERNEL_BITS) + switch (bits) + { + case 64: puts ("hppa2.0w"); break; + case 32: puts ("hppa2.0n"); break; + default: puts ("hppa2.0"); break; + } break; + #else /* !defined(_SC_KERNEL_BITS) */ + puts ("hppa2.0"); break; + #endif + default: puts ("hppa1.0"); break; + } + exit (0); + } +EOF + (CCOPTS= $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null) && HP_ARCH=`$dummy` + test -z "$HP_ARCH" && HP_ARCH=hppa + fi ;; + esac + if [ ${HP_ARCH} = "hppa2.0w" ] + then + eval $set_cc_for_build + + # hppa2.0w-hp-hpux* has a 64-bit kernel and a compiler generating + # 32-bit code. hppa64-hp-hpux* has the same kernel and a compiler + # generating 64-bit code. GNU and HP use different nomenclature: + # + # $ CC_FOR_BUILD=cc ./config.guess + # => hppa2.0w-hp-hpux11.23 + # $ CC_FOR_BUILD="cc +DA2.0w" ./config.guess + # => hppa64-hp-hpux11.23 + + if echo __LP64__ | (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | + grep -q __LP64__ + then + HP_ARCH="hppa2.0w" + else + HP_ARCH="hppa64" + fi + fi + echo ${HP_ARCH}-hp-hpux${HPUX_REV} + exit ;; + ia64:HP-UX:*:*) + HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` + echo ia64-hp-hpux${HPUX_REV} + exit ;; + 3050*:HI-UX:*:*) + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #include + int + main () + { + long cpu = sysconf (_SC_CPU_VERSION); + /* The order matters, because CPU_IS_HP_MC68K erroneously returns + true for CPU_PA_RISC1_0. CPU_IS_PA_RISC returns correct + results, however. */ + if (CPU_IS_PA_RISC (cpu)) + { + switch (cpu) + { + case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break; + case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break; + case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break; + default: puts ("hppa-hitachi-hiuxwe2"); break; + } + } + else if (CPU_IS_HP_MC68K (cpu)) + puts ("m68k-hitachi-hiuxwe2"); + else puts ("unknown-hitachi-hiuxwe2"); + exit (0); + } +EOF + $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` && + { echo "$SYSTEM_NAME"; exit; } + echo unknown-hitachi-hiuxwe2 + exit ;; + 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* ) + echo hppa1.1-hp-bsd + exit ;; + 9000/8??:4.3bsd:*:*) + echo hppa1.0-hp-bsd + exit ;; + *9??*:MPE/iX:*:* | *3000*:MPE/iX:*:*) + echo hppa1.0-hp-mpeix + exit ;; + hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* ) + echo hppa1.1-hp-osf + exit ;; + hp8??:OSF1:*:*) + echo hppa1.0-hp-osf + exit ;; + i*86:OSF1:*:*) + if [ -x /usr/sbin/sysversion ] ; then + echo ${UNAME_MACHINE}-unknown-osf1mk + else + echo ${UNAME_MACHINE}-unknown-osf1 + fi + exit ;; + parisc*:Lites*:*:*) + echo hppa1.1-hp-lites + exit ;; + C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*) + echo c1-convex-bsd + exit ;; + C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*) + if getsysinfo -f scalar_acc + then echo c32-convex-bsd + else echo c2-convex-bsd + fi + exit ;; + C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*) + echo c34-convex-bsd + exit ;; + C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*) + echo c38-convex-bsd + exit ;; + C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*) + echo c4-convex-bsd + exit ;; + CRAY*Y-MP:*:*:*) + echo ymp-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit ;; + CRAY*[A-Z]90:*:*:*) + echo ${UNAME_MACHINE}-cray-unicos${UNAME_RELEASE} \ + | sed -e 's/CRAY.*\([A-Z]90\)/\1/' \ + -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ \ + -e 's/\.[^.]*$/.X/' + exit ;; + CRAY*TS:*:*:*) + echo t90-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit ;; + CRAY*T3E:*:*:*) + echo alphaev5-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit ;; + CRAY*SV1:*:*:*) + echo sv1-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit ;; + *:UNICOS/mp:*:*) + echo craynv-cray-unicosmp${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit ;; + F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*) + FUJITSU_PROC=`uname -m | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` + FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` + FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'` + echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" + exit ;; + 5000:UNIX_System_V:4.*:*) + FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` + FUJITSU_REL=`echo ${UNAME_RELEASE} | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/ /_/'` + echo "sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" + exit ;; + i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*) + echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE} + exit ;; + sparc*:BSD/OS:*:*) + echo sparc-unknown-bsdi${UNAME_RELEASE} + exit ;; + *:BSD/OS:*:*) + echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE} + exit ;; + *:FreeBSD:*:*) + UNAME_PROCESSOR=`/usr/bin/uname -p` + case ${UNAME_PROCESSOR} in + amd64) + echo x86_64-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; + *) + echo ${UNAME_PROCESSOR}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; + esac + exit ;; + i*:CYGWIN*:*) + echo ${UNAME_MACHINE}-pc-cygwin + exit ;; + *:MINGW64*:*) + echo ${UNAME_MACHINE}-pc-mingw64 + exit ;; + *:MINGW*:*) + echo ${UNAME_MACHINE}-pc-mingw32 + exit ;; + *:MSYS*:*) + echo ${UNAME_MACHINE}-pc-msys + exit ;; + i*:windows32*:*) + # uname -m includes "-pc" on this system. + echo ${UNAME_MACHINE}-mingw32 + exit ;; + i*:PW*:*) + echo ${UNAME_MACHINE}-pc-pw32 + exit ;; + *:Interix*:*) + case ${UNAME_MACHINE} in + x86) + echo i586-pc-interix${UNAME_RELEASE} + exit ;; + authenticamd | genuineintel | EM64T) + echo x86_64-unknown-interix${UNAME_RELEASE} + exit ;; + IA64) + echo ia64-unknown-interix${UNAME_RELEASE} + exit ;; + esac ;; + [345]86:Windows_95:* | [345]86:Windows_98:* | [345]86:Windows_NT:*) + echo i${UNAME_MACHINE}-pc-mks + exit ;; + 8664:Windows_NT:*) + echo x86_64-pc-mks + exit ;; + i*:Windows_NT*:* | Pentium*:Windows_NT*:*) + # How do we know it's Interix rather than the generic POSIX subsystem? + # It also conflicts with pre-2.0 versions of AT&T UWIN. Should we + # UNAME_MACHINE based on the output of uname instead of i386? + echo i586-pc-interix + exit ;; + i*:UWIN*:*) + echo ${UNAME_MACHINE}-pc-uwin + exit ;; + amd64:CYGWIN*:*:* | x86_64:CYGWIN*:*:*) + echo x86_64-unknown-cygwin + exit ;; + p*:CYGWIN*:*) + echo powerpcle-unknown-cygwin + exit ;; + prep*:SunOS:5.*:*) + echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + *:GNU:*:*) + # the GNU system + echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-${LIBC}`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'` + exit ;; + *:GNU/*:*:*) + # other systems with GNU libc and userland + echo ${UNAME_MACHINE}-unknown-`echo ${UNAME_SYSTEM} | sed 's,^[^/]*/,,' | tr '[A-Z]' '[a-z]'``echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`-${LIBC} + exit ;; + i*86:Minix:*:*) + echo ${UNAME_MACHINE}-pc-minix + exit ;; + aarch64:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + aarch64_be:Linux:*:*) + UNAME_MACHINE=aarch64_be + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + alpha:Linux:*:*) + case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in + EV5) UNAME_MACHINE=alphaev5 ;; + EV56) UNAME_MACHINE=alphaev56 ;; + PCA56) UNAME_MACHINE=alphapca56 ;; + PCA57) UNAME_MACHINE=alphapca56 ;; + EV6) UNAME_MACHINE=alphaev6 ;; + EV67) UNAME_MACHINE=alphaev67 ;; + EV68*) UNAME_MACHINE=alphaev68 ;; + esac + objdump --private-headers /bin/sh | grep -q ld.so.1 + if test "$?" = 0 ; then LIBC="gnulibc1" ; fi + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + arc:Linux:*:* | arceb:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + arm*:Linux:*:*) + eval $set_cc_for_build + if echo __ARM_EABI__ | $CC_FOR_BUILD -E - 2>/dev/null \ + | grep -q __ARM_EABI__ + then + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + else + if echo __ARM_PCS_VFP | $CC_FOR_BUILD -E - 2>/dev/null \ + | grep -q __ARM_PCS_VFP + then + echo ${UNAME_MACHINE}-unknown-linux-${LIBC}eabi + else + echo ${UNAME_MACHINE}-unknown-linux-${LIBC}eabihf + fi + fi + exit ;; + avr32*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + cris:Linux:*:*) + echo ${UNAME_MACHINE}-axis-linux-${LIBC} + exit ;; + crisv32:Linux:*:*) + echo ${UNAME_MACHINE}-axis-linux-${LIBC} + exit ;; + frv:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + hexagon:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + i*86:Linux:*:*) + echo ${UNAME_MACHINE}-pc-linux-${LIBC} + exit ;; + ia64:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + m32r*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + m68*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + mips:Linux:*:* | mips64:Linux:*:*) + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #undef CPU + #undef ${UNAME_MACHINE} + #undef ${UNAME_MACHINE}el + #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL) + CPU=${UNAME_MACHINE}el + #else + #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB) + CPU=${UNAME_MACHINE} + #else + CPU= + #endif + #endif +EOF + eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^CPU'` + test x"${CPU}" != x && { echo "${CPU}-unknown-linux-${LIBC}"; exit; } + ;; + openrisc*:Linux:*:*) + echo or1k-unknown-linux-${LIBC} + exit ;; + or32:Linux:*:* | or1k*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + padre:Linux:*:*) + echo sparc-unknown-linux-${LIBC} + exit ;; + parisc64:Linux:*:* | hppa64:Linux:*:*) + echo hppa64-unknown-linux-${LIBC} + exit ;; + parisc:Linux:*:* | hppa:Linux:*:*) + # Look for CPU level + case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in + PA7*) echo hppa1.1-unknown-linux-${LIBC} ;; + PA8*) echo hppa2.0-unknown-linux-${LIBC} ;; + *) echo hppa-unknown-linux-${LIBC} ;; + esac + exit ;; + ppc64:Linux:*:*) + echo powerpc64-unknown-linux-${LIBC} + exit ;; + ppc:Linux:*:*) + echo powerpc-unknown-linux-${LIBC} + exit ;; + ppc64le:Linux:*:*) + echo powerpc64le-unknown-linux-${LIBC} + exit ;; + ppcle:Linux:*:*) + echo powerpcle-unknown-linux-${LIBC} + exit ;; + s390:Linux:*:* | s390x:Linux:*:*) + echo ${UNAME_MACHINE}-ibm-linux-${LIBC} + exit ;; + sh64*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + sh*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + sparc:Linux:*:* | sparc64:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + tile*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + vax:Linux:*:*) + echo ${UNAME_MACHINE}-dec-linux-${LIBC} + exit ;; + x86_64:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + xtensa*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + i*86:DYNIX/ptx:4*:*) + # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. + # earlier versions are messed up and put the nodename in both + # sysname and nodename. + echo i386-sequent-sysv4 + exit ;; + i*86:UNIX_SV:4.2MP:2.*) + # Unixware is an offshoot of SVR4, but it has its own version + # number series starting with 2... + # I am not positive that other SVR4 systems won't match this, + # I just have to hope. -- rms. + # Use sysv4.2uw... so that sysv4* matches it. + echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION} + exit ;; + i*86:OS/2:*:*) + # If we were able to find `uname', then EMX Unix compatibility + # is probably installed. + echo ${UNAME_MACHINE}-pc-os2-emx + exit ;; + i*86:XTS-300:*:STOP) + echo ${UNAME_MACHINE}-unknown-stop + exit ;; + i*86:atheos:*:*) + echo ${UNAME_MACHINE}-unknown-atheos + exit ;; + i*86:syllable:*:*) + echo ${UNAME_MACHINE}-pc-syllable + exit ;; + i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.[02]*:*) + echo i386-unknown-lynxos${UNAME_RELEASE} + exit ;; + i*86:*DOS:*:*) + echo ${UNAME_MACHINE}-pc-msdosdjgpp + exit ;; + i*86:*:4.*:* | i*86:SYSTEM_V:4.*:*) + UNAME_REL=`echo ${UNAME_RELEASE} | sed 's/\/MP$//'` + if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then + echo ${UNAME_MACHINE}-univel-sysv${UNAME_REL} + else + echo ${UNAME_MACHINE}-pc-sysv${UNAME_REL} + fi + exit ;; + i*86:*:5:[678]*) + # UnixWare 7.x, OpenUNIX and OpenServer 6. + case `/bin/uname -X | grep "^Machine"` in + *486*) UNAME_MACHINE=i486 ;; + *Pentium) UNAME_MACHINE=i586 ;; + *Pent*|*Celeron) UNAME_MACHINE=i686 ;; + esac + echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION} + exit ;; + i*86:*:3.2:*) + if test -f /usr/options/cb.name; then + UNAME_REL=`sed -n 's/.*Version //p' /dev/null >/dev/null ; then + UNAME_REL=`(/bin/uname -X|grep Release|sed -e 's/.*= //')` + (/bin/uname -X|grep i80486 >/dev/null) && UNAME_MACHINE=i486 + (/bin/uname -X|grep '^Machine.*Pentium' >/dev/null) \ + && UNAME_MACHINE=i586 + (/bin/uname -X|grep '^Machine.*Pent *II' >/dev/null) \ + && UNAME_MACHINE=i686 + (/bin/uname -X|grep '^Machine.*Pentium Pro' >/dev/null) \ + && UNAME_MACHINE=i686 + echo ${UNAME_MACHINE}-pc-sco$UNAME_REL + else + echo ${UNAME_MACHINE}-pc-sysv32 + fi + exit ;; + pc:*:*:*) + # Left here for compatibility: + # uname -m prints for DJGPP always 'pc', but it prints nothing about + # the processor, so we play safe by assuming i586. + # Note: whatever this is, it MUST be the same as what config.sub + # prints for the "djgpp" host, or else GDB configury will decide that + # this is a cross-build. + echo i586-pc-msdosdjgpp + exit ;; + Intel:Mach:3*:*) + echo i386-pc-mach3 + exit ;; + paragon:*:*:*) + echo i860-intel-osf1 + exit ;; + i860:*:4.*:*) # i860-SVR4 + if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then + echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4 + else # Add other i860-SVR4 vendors below as they are discovered. + echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4 + fi + exit ;; + mini*:CTIX:SYS*5:*) + # "miniframe" + echo m68010-convergent-sysv + exit ;; + mc68k:UNIX:SYSTEM5:3.51m) + echo m68k-convergent-sysv + exit ;; + M680?0:D-NIX:5.3:*) + echo m68k-diab-dnix + exit ;; + M68*:*:R3V[5678]*:*) + test -r /sysV68 && { echo 'm68k-motorola-sysv'; exit; } ;; + 3[345]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 3[34]??/*:*:4.0:3.0 | 4400:*:4.0:3.0 | 4850:*:4.0:3.0 | SKA40:*:4.0:3.0 | SDS2:*:4.0:3.0 | SHG2:*:4.0:3.0 | S7501*:*:4.0:3.0) + OS_REL='' + test -r /etc/.relid \ + && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` + /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ + && { echo i486-ncr-sysv4.3${OS_REL}; exit; } + /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ + && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; + 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*) + /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ + && { echo i486-ncr-sysv4; exit; } ;; + NCR*:*:4.2:* | MPRAS*:*:4.2:*) + OS_REL='.3' + test -r /etc/.relid \ + && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` + /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ + && { echo i486-ncr-sysv4.3${OS_REL}; exit; } + /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ + && { echo i586-ncr-sysv4.3${OS_REL}; exit; } + /bin/uname -p 2>/dev/null | /bin/grep pteron >/dev/null \ + && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; + m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*) + echo m68k-unknown-lynxos${UNAME_RELEASE} + exit ;; + mc68030:UNIX_System_V:4.*:*) + echo m68k-atari-sysv4 + exit ;; + TSUNAMI:LynxOS:2.*:*) + echo sparc-unknown-lynxos${UNAME_RELEASE} + exit ;; + rs6000:LynxOS:2.*:*) + echo rs6000-unknown-lynxos${UNAME_RELEASE} + exit ;; + PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.[02]*:*) + echo powerpc-unknown-lynxos${UNAME_RELEASE} + exit ;; + SM[BE]S:UNIX_SV:*:*) + echo mips-dde-sysv${UNAME_RELEASE} + exit ;; + RM*:ReliantUNIX-*:*:*) + echo mips-sni-sysv4 + exit ;; + RM*:SINIX-*:*:*) + echo mips-sni-sysv4 + exit ;; + *:SINIX-*:*:*) + if uname -p 2>/dev/null >/dev/null ; then + UNAME_MACHINE=`(uname -p) 2>/dev/null` + echo ${UNAME_MACHINE}-sni-sysv4 + else + echo ns32k-sni-sysv + fi + exit ;; + PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort + # says + echo i586-unisys-sysv4 + exit ;; + *:UNIX_System_V:4*:FTX*) + # From Gerald Hewes . + # How about differentiating between stratus architectures? -djm + echo hppa1.1-stratus-sysv4 + exit ;; + *:*:*:FTX*) + # From seanf@swdc.stratus.com. + echo i860-stratus-sysv4 + exit ;; + i*86:VOS:*:*) + # From Paul.Green@stratus.com. + echo ${UNAME_MACHINE}-stratus-vos + exit ;; + *:VOS:*:*) + # From Paul.Green@stratus.com. + echo hppa1.1-stratus-vos + exit ;; + mc68*:A/UX:*:*) + echo m68k-apple-aux${UNAME_RELEASE} + exit ;; + news*:NEWS-OS:6*:*) + echo mips-sony-newsos6 + exit ;; + R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*) + if [ -d /usr/nec ]; then + echo mips-nec-sysv${UNAME_RELEASE} + else + echo mips-unknown-sysv${UNAME_RELEASE} + fi + exit ;; + BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only. + echo powerpc-be-beos + exit ;; + BeMac:BeOS:*:*) # BeOS running on Mac or Mac clone, PPC only. + echo powerpc-apple-beos + exit ;; + BePC:BeOS:*:*) # BeOS running on Intel PC compatible. + echo i586-pc-beos + exit ;; + BePC:Haiku:*:*) # Haiku running on Intel PC compatible. + echo i586-pc-haiku + exit ;; + x86_64:Haiku:*:*) + echo x86_64-unknown-haiku + exit ;; + SX-4:SUPER-UX:*:*) + echo sx4-nec-superux${UNAME_RELEASE} + exit ;; + SX-5:SUPER-UX:*:*) + echo sx5-nec-superux${UNAME_RELEASE} + exit ;; + SX-6:SUPER-UX:*:*) + echo sx6-nec-superux${UNAME_RELEASE} + exit ;; + SX-7:SUPER-UX:*:*) + echo sx7-nec-superux${UNAME_RELEASE} + exit ;; + SX-8:SUPER-UX:*:*) + echo sx8-nec-superux${UNAME_RELEASE} + exit ;; + SX-8R:SUPER-UX:*:*) + echo sx8r-nec-superux${UNAME_RELEASE} + exit ;; + Power*:Rhapsody:*:*) + echo powerpc-apple-rhapsody${UNAME_RELEASE} + exit ;; + *:Rhapsody:*:*) + echo ${UNAME_MACHINE}-apple-rhapsody${UNAME_RELEASE} + exit ;; + *:Darwin:*:*) + UNAME_PROCESSOR=`uname -p` || UNAME_PROCESSOR=unknown + eval $set_cc_for_build + if test "$UNAME_PROCESSOR" = unknown ; then + UNAME_PROCESSOR=powerpc + fi + if test `echo "$UNAME_RELEASE" | sed -e 's/\..*//'` -le 10 ; then + if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then + if (echo '#ifdef __LP64__'; echo IS_64BIT_ARCH; echo '#endif') | \ + (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \ + grep IS_64BIT_ARCH >/dev/null + then + case $UNAME_PROCESSOR in + i386) UNAME_PROCESSOR=x86_64 ;; + powerpc) UNAME_PROCESSOR=powerpc64 ;; + esac + fi + fi + elif test "$UNAME_PROCESSOR" = i386 ; then + # Avoid executing cc on OS X 10.9, as it ships with a stub + # that puts up a graphical alert prompting to install + # developer tools. Any system running Mac OS X 10.7 or + # later (Darwin 11 and later) is required to have a 64-bit + # processor. This is not true of the ARM version of Darwin + # that Apple uses in portable devices. + UNAME_PROCESSOR=x86_64 + fi + echo ${UNAME_PROCESSOR}-apple-darwin${UNAME_RELEASE} + exit ;; + *:procnto*:*:* | *:QNX:[0123456789]*:*) + UNAME_PROCESSOR=`uname -p` + if test "$UNAME_PROCESSOR" = "x86"; then + UNAME_PROCESSOR=i386 + UNAME_MACHINE=pc + fi + echo ${UNAME_PROCESSOR}-${UNAME_MACHINE}-nto-qnx${UNAME_RELEASE} + exit ;; + *:QNX:*:4*) + echo i386-pc-qnx + exit ;; + NEO-?:NONSTOP_KERNEL:*:*) + echo neo-tandem-nsk${UNAME_RELEASE} + exit ;; + NSE-*:NONSTOP_KERNEL:*:*) + echo nse-tandem-nsk${UNAME_RELEASE} + exit ;; + NSR-?:NONSTOP_KERNEL:*:*) + echo nsr-tandem-nsk${UNAME_RELEASE} + exit ;; + *:NonStop-UX:*:*) + echo mips-compaq-nonstopux + exit ;; + BS2000:POSIX*:*:*) + echo bs2000-siemens-sysv + exit ;; + DS/*:UNIX_System_V:*:*) + echo ${UNAME_MACHINE}-${UNAME_SYSTEM}-${UNAME_RELEASE} + exit ;; + *:Plan9:*:*) + # "uname -m" is not consistent, so use $cputype instead. 386 + # is converted to i386 for consistency with other x86 + # operating systems. + if test "$cputype" = "386"; then + UNAME_MACHINE=i386 + else + UNAME_MACHINE="$cputype" + fi + echo ${UNAME_MACHINE}-unknown-plan9 + exit ;; + *:TOPS-10:*:*) + echo pdp10-unknown-tops10 + exit ;; + *:TENEX:*:*) + echo pdp10-unknown-tenex + exit ;; + KS10:TOPS-20:*:* | KL10:TOPS-20:*:* | TYPE4:TOPS-20:*:*) + echo pdp10-dec-tops20 + exit ;; + XKL-1:TOPS-20:*:* | TYPE5:TOPS-20:*:*) + echo pdp10-xkl-tops20 + exit ;; + *:TOPS-20:*:*) + echo pdp10-unknown-tops20 + exit ;; + *:ITS:*:*) + echo pdp10-unknown-its + exit ;; + SEI:*:*:SEIUX) + echo mips-sei-seiux${UNAME_RELEASE} + exit ;; + *:DragonFly:*:*) + echo ${UNAME_MACHINE}-unknown-dragonfly`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` + exit ;; + *:*VMS:*:*) + UNAME_MACHINE=`(uname -p) 2>/dev/null` + case "${UNAME_MACHINE}" in + A*) echo alpha-dec-vms ; exit ;; + I*) echo ia64-dec-vms ; exit ;; + V*) echo vax-dec-vms ; exit ;; + esac ;; + *:XENIX:*:SysV) + echo i386-pc-xenix + exit ;; + i*86:skyos:*:*) + echo ${UNAME_MACHINE}-pc-skyos`echo ${UNAME_RELEASE}` | sed -e 's/ .*$//' + exit ;; + i*86:rdos:*:*) + echo ${UNAME_MACHINE}-pc-rdos + exit ;; + i*86:AROS:*:*) + echo ${UNAME_MACHINE}-pc-aros + exit ;; + x86_64:VMkernel:*:*) + echo ${UNAME_MACHINE}-unknown-esx + exit ;; +esac + +cat >&2 < in order to provide the needed +information to handle your system. + +config.guess timestamp = $timestamp + +uname -m = `(uname -m) 2>/dev/null || echo unknown` +uname -r = `(uname -r) 2>/dev/null || echo unknown` +uname -s = `(uname -s) 2>/dev/null || echo unknown` +uname -v = `(uname -v) 2>/dev/null || echo unknown` + +/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null` +/bin/uname -X = `(/bin/uname -X) 2>/dev/null` + +hostinfo = `(hostinfo) 2>/dev/null` +/bin/universe = `(/bin/universe) 2>/dev/null` +/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null` +/bin/arch = `(/bin/arch) 2>/dev/null` +/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null` +/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null` + +UNAME_MACHINE = ${UNAME_MACHINE} +UNAME_RELEASE = ${UNAME_RELEASE} +UNAME_SYSTEM = ${UNAME_SYSTEM} +UNAME_VERSION = ${UNAME_VERSION} +EOF + +exit 1 + +# Local variables: +# eval: (add-hook 'write-file-hooks 'time-stamp) +# time-stamp-start: "timestamp='" +# time-stamp-format: "%:y-%02m-%02d" +# time-stamp-end: "'" +# End: diff --git a/config.sub b/config.sub new file mode 100755 index 0000000..d654d03 --- /dev/null +++ b/config.sub @@ -0,0 +1,1794 @@ +#! /bin/sh +# Configuration validation subroutine script. +# Copyright 1992-2014 Free Software Foundation, Inc. + +timestamp='2014-05-01' + +# This file is free software; you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, see . +# +# As a special exception to the GNU General Public License, if you +# distribute this file as part of a program that contains a +# configuration script generated by Autoconf, you may include it under +# the same distribution terms that you use for the rest of that +# program. This Exception is an additional permission under section 7 +# of the GNU General Public License, version 3 ("GPLv3"). + + +# Please send patches with a ChangeLog entry to config-patches@gnu.org. +# +# Configuration subroutine to validate and canonicalize a configuration type. +# Supply the specified configuration type as an argument. +# If it is invalid, we print an error message on stderr and exit with code 1. +# Otherwise, we print the canonical config type on stdout and succeed. + +# You can get the latest version of this script from: +# http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.sub;hb=HEAD + +# This file is supposed to be the same for all GNU packages +# and recognize all the CPU types, system types and aliases +# that are meaningful with *any* GNU software. +# Each package is responsible for reporting which valid configurations +# it does not support. The user should be able to distinguish +# a failure to support a valid configuration from a meaningless +# configuration. + +# The goal of this file is to map all the various variations of a given +# machine specification into a single specification in the form: +# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM +# or in some cases, the newer four-part form: +# CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM +# It is wrong to echo any other type of specification. + +me=`echo "$0" | sed -e 's,.*/,,'` + +usage="\ +Usage: $0 [OPTION] CPU-MFR-OPSYS + $0 [OPTION] ALIAS + +Canonicalize a configuration name. + +Operation modes: + -h, --help print this help, then exit + -t, --time-stamp print date of last modification, then exit + -v, --version print version number, then exit + +Report bugs and patches to ." + +version="\ +GNU config.sub ($timestamp) + +Copyright 1992-2014 Free Software Foundation, Inc. + +This is free software; see the source for copying conditions. There is NO +warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." + +help=" +Try \`$me --help' for more information." + +# Parse command line +while test $# -gt 0 ; do + case $1 in + --time-stamp | --time* | -t ) + echo "$timestamp" ; exit ;; + --version | -v ) + echo "$version" ; exit ;; + --help | --h* | -h ) + echo "$usage"; exit ;; + -- ) # Stop option processing + shift; break ;; + - ) # Use stdin as input. + break ;; + -* ) + echo "$me: invalid option $1$help" + exit 1 ;; + + *local*) + # First pass through any local machine types. + echo $1 + exit ;; + + * ) + break ;; + esac +done + +case $# in + 0) echo "$me: missing argument$help" >&2 + exit 1;; + 1) ;; + *) echo "$me: too many arguments$help" >&2 + exit 1;; +esac + +# Separate what the user gave into CPU-COMPANY and OS or KERNEL-OS (if any). +# Here we must recognize all the valid KERNEL-OS combinations. +maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'` +case $maybe_os in + nto-qnx* | linux-gnu* | linux-android* | linux-dietlibc | linux-newlib* | \ + linux-musl* | linux-uclibc* | uclinux-uclibc* | uclinux-gnu* | kfreebsd*-gnu* | \ + knetbsd*-gnu* | netbsd*-gnu* | \ + kopensolaris*-gnu* | \ + storm-chaos* | os2-emx* | rtmk-nova*) + os=-$maybe_os + basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'` + ;; + android-linux) + os=-linux-android + basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'`-unknown + ;; + *) + basic_machine=`echo $1 | sed 's/-[^-]*$//'` + if [ $basic_machine != $1 ] + then os=`echo $1 | sed 's/.*-/-/'` + else os=; fi + ;; +esac + +### Let's recognize common machines as not being operating systems so +### that things like config.sub decstation-3100 work. We also +### recognize some manufacturers as not being operating systems, so we +### can provide default operating systems below. +case $os in + -sun*os*) + # Prevent following clause from handling this invalid input. + ;; + -dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \ + -att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \ + -unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \ + -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\ + -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \ + -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \ + -apple | -axis | -knuth | -cray | -microblaze*) + os= + basic_machine=$1 + ;; + -bluegene*) + os=-cnk + ;; + -sim | -cisco | -oki | -wec | -winbond) + os= + basic_machine=$1 + ;; + -scout) + ;; + -wrs) + os=-vxworks + basic_machine=$1 + ;; + -chorusos*) + os=-chorusos + basic_machine=$1 + ;; + -chorusrdb) + os=-chorusrdb + basic_machine=$1 + ;; + -hiux*) + os=-hiuxwe2 + ;; + -sco6) + os=-sco5v6 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco5) + os=-sco3.2v5 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco4) + os=-sco3.2v4 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco3.2.[4-9]*) + os=`echo $os | sed -e 's/sco3.2./sco3.2v/'` + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco3.2v[4-9]*) + # Don't forget version if it is 3.2v4 or newer. + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco5v6*) + # Don't forget version if it is 3.2v4 or newer. + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco*) + os=-sco3.2v2 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -udk*) + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -isc) + os=-isc2.2 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -clix*) + basic_machine=clipper-intergraph + ;; + -isc*) + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -lynx*178) + os=-lynxos178 + ;; + -lynx*5) + os=-lynxos5 + ;; + -lynx*) + os=-lynxos + ;; + -ptx*) + basic_machine=`echo $1 | sed -e 's/86-.*/86-sequent/'` + ;; + -windowsnt*) + os=`echo $os | sed -e 's/windowsnt/winnt/'` + ;; + -psos*) + os=-psos + ;; + -mint | -mint[0-9]*) + basic_machine=m68k-atari + os=-mint + ;; +esac + +# Decode aliases for certain CPU-COMPANY combinations. +case $basic_machine in + # Recognize the basic CPU types without company name. + # Some are omitted here because they have special meanings below. + 1750a | 580 \ + | a29k \ + | aarch64 | aarch64_be \ + | alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \ + | alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \ + | am33_2.0 \ + | arc | arceb \ + | arm | arm[bl]e | arme[lb] | armv[2-8] | armv[3-8][lb] | armv7[arm] \ + | avr | avr32 \ + | be32 | be64 \ + | bfin \ + | c4x | c8051 | clipper \ + | d10v | d30v | dlx | dsp16xx \ + | epiphany \ + | fido | fr30 | frv \ + | h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \ + | hexagon \ + | i370 | i860 | i960 | ia64 \ + | ip2k | iq2000 \ + | k1om \ + | le32 | le64 \ + | lm32 \ + | m32c | m32r | m32rle | m68000 | m68k | m88k \ + | maxq | mb | microblaze | microblazeel | mcore | mep | metag \ + | mips | mipsbe | mipseb | mipsel | mipsle \ + | mips16 \ + | mips64 | mips64el \ + | mips64octeon | mips64octeonel \ + | mips64orion | mips64orionel \ + | mips64r5900 | mips64r5900el \ + | mips64vr | mips64vrel \ + | mips64vr4100 | mips64vr4100el \ + | mips64vr4300 | mips64vr4300el \ + | mips64vr5000 | mips64vr5000el \ + | mips64vr5900 | mips64vr5900el \ + | mipsisa32 | mipsisa32el \ + | mipsisa32r2 | mipsisa32r2el \ + | mipsisa32r6 | mipsisa32r6el \ + | mipsisa64 | mipsisa64el \ + | mipsisa64r2 | mipsisa64r2el \ + | mipsisa64r6 | mipsisa64r6el \ + | mipsisa64sb1 | mipsisa64sb1el \ + | mipsisa64sr71k | mipsisa64sr71kel \ + | mipsr5900 | mipsr5900el \ + | mipstx39 | mipstx39el \ + | mn10200 | mn10300 \ + | moxie \ + | mt \ + | msp430 \ + | nds32 | nds32le | nds32be \ + | nios | nios2 | nios2eb | nios2el \ + | ns16k | ns32k \ + | open8 | or1k | or1knd | or32 \ + | pdp10 | pdp11 | pj | pjl \ + | powerpc | powerpc64 | powerpc64le | powerpcle \ + | pyramid \ + | rl78 | rx \ + | score \ + | sh | sh[1234] | sh[24]a | sh[24]aeb | sh[23]e | sh[34]eb | sheb | shbe | shle | sh[1234]le | sh3ele \ + | sh64 | sh64le \ + | sparc | sparc64 | sparc64b | sparc64v | sparc86x | sparclet | sparclite \ + | sparcv8 | sparcv9 | sparcv9b | sparcv9v \ + | spu \ + | tahoe | tic4x | tic54x | tic55x | tic6x | tic80 | tron \ + | ubicom32 \ + | v850 | v850e | v850e1 | v850e2 | v850es | v850e2v3 \ + | we32k \ + | x86 | xc16x | xstormy16 | xtensa \ + | z8k | z80) + basic_machine=$basic_machine-unknown + ;; + c54x) + basic_machine=tic54x-unknown + ;; + c55x) + basic_machine=tic55x-unknown + ;; + c6x) + basic_machine=tic6x-unknown + ;; + m6811 | m68hc11 | m6812 | m68hc12 | m68hcs12x | nvptx | picochip) + basic_machine=$basic_machine-unknown + os=-none + ;; + m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65 | z8k) + ;; + ms1) + basic_machine=mt-unknown + ;; + + strongarm | thumb | xscale) + basic_machine=arm-unknown + ;; + xgate) + basic_machine=$basic_machine-unknown + os=-none + ;; + xscaleeb) + basic_machine=armeb-unknown + ;; + + xscaleel) + basic_machine=armel-unknown + ;; + + # We use `pc' rather than `unknown' + # because (1) that's what they normally are, and + # (2) the word "unknown" tends to confuse beginning users. + i*86 | x86_64) + basic_machine=$basic_machine-pc + ;; + # Object if more than one company name word. + *-*-*) + echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 + exit 1 + ;; + # Recognize the basic CPU types with company name. + 580-* \ + | a29k-* \ + | aarch64-* | aarch64_be-* \ + | alpha-* | alphaev[4-8]-* | alphaev56-* | alphaev6[78]-* \ + | alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \ + | alphapca5[67]-* | alpha64pca5[67]-* | arc-* | arceb-* \ + | arm-* | armbe-* | armle-* | armeb-* | armv*-* \ + | avr-* | avr32-* \ + | be32-* | be64-* \ + | bfin-* | bs2000-* \ + | c[123]* | c30-* | [cjt]90-* | c4x-* \ + | c8051-* | clipper-* | craynv-* | cydra-* \ + | d10v-* | d30v-* | dlx-* \ + | elxsi-* \ + | f30[01]-* | f700-* | fido-* | fr30-* | frv-* | fx80-* \ + | h8300-* | h8500-* \ + | hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \ + | hexagon-* \ + | i*86-* | i860-* | i960-* | ia64-* \ + | ip2k-* | iq2000-* \ + | k1om-* \ + | le32-* | le64-* \ + | lm32-* \ + | m32c-* | m32r-* | m32rle-* \ + | m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* \ + | m88110-* | m88k-* | maxq-* | mcore-* | metag-* \ + | microblaze-* | microblazeel-* \ + | mips-* | mipsbe-* | mipseb-* | mipsel-* | mipsle-* \ + | mips16-* \ + | mips64-* | mips64el-* \ + | mips64octeon-* | mips64octeonel-* \ + | mips64orion-* | mips64orionel-* \ + | mips64r5900-* | mips64r5900el-* \ + | mips64vr-* | mips64vrel-* \ + | mips64vr4100-* | mips64vr4100el-* \ + | mips64vr4300-* | mips64vr4300el-* \ + | mips64vr5000-* | mips64vr5000el-* \ + | mips64vr5900-* | mips64vr5900el-* \ + | mipsisa32-* | mipsisa32el-* \ + | mipsisa32r2-* | mipsisa32r2el-* \ + | mipsisa32r6-* | mipsisa32r6el-* \ + | mipsisa64-* | mipsisa64el-* \ + | mipsisa64r2-* | mipsisa64r2el-* \ + | mipsisa64r6-* | mipsisa64r6el-* \ + | mipsisa64sb1-* | mipsisa64sb1el-* \ + | mipsisa64sr71k-* | mipsisa64sr71kel-* \ + | mipsr5900-* | mipsr5900el-* \ + | mipstx39-* | mipstx39el-* \ + | mmix-* \ + | mt-* \ + | msp430-* \ + | nds32-* | nds32le-* | nds32be-* \ + | nios-* | nios2-* | nios2eb-* | nios2el-* \ + | none-* | np1-* | ns16k-* | ns32k-* \ + | open8-* \ + | or1k*-* \ + | orion-* \ + | pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \ + | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* \ + | pyramid-* \ + | rl78-* | romp-* | rs6000-* | rx-* \ + | sh-* | sh[1234]-* | sh[24]a-* | sh[24]aeb-* | sh[23]e-* | sh[34]eb-* | sheb-* | shbe-* \ + | shle-* | sh[1234]le-* | sh3ele-* | sh64-* | sh64le-* \ + | sparc-* | sparc64-* | sparc64b-* | sparc64v-* | sparc86x-* | sparclet-* \ + | sparclite-* \ + | sparcv8-* | sparcv9-* | sparcv9b-* | sparcv9v-* | sv1-* | sx?-* \ + | tahoe-* \ + | tic30-* | tic4x-* | tic54x-* | tic55x-* | tic6x-* | tic80-* \ + | tile*-* \ + | tron-* \ + | ubicom32-* \ + | v850-* | v850e-* | v850e1-* | v850es-* | v850e2-* | v850e2v3-* \ + | vax-* \ + | we32k-* \ + | x86-* | x86_64-* | xc16x-* | xps100-* \ + | xstormy16-* | xtensa*-* \ + | ymp-* \ + | z8k-* | z80-*) + ;; + # Recognize the basic CPU types without company name, with glob match. + xtensa*) + basic_machine=$basic_machine-unknown + ;; + # Recognize the various machine names and aliases which stand + # for a CPU type and a company and sometimes even an OS. + 386bsd) + basic_machine=i386-unknown + os=-bsd + ;; + 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc) + basic_machine=m68000-att + ;; + 3b*) + basic_machine=we32k-att + ;; + a29khif) + basic_machine=a29k-amd + os=-udi + ;; + abacus) + basic_machine=abacus-unknown + ;; + adobe68k) + basic_machine=m68010-adobe + os=-scout + ;; + alliant | fx80) + basic_machine=fx80-alliant + ;; + altos | altos3068) + basic_machine=m68k-altos + ;; + am29k) + basic_machine=a29k-none + os=-bsd + ;; + amd64) + basic_machine=x86_64-pc + ;; + amd64-*) + basic_machine=x86_64-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + amdahl) + basic_machine=580-amdahl + os=-sysv + ;; + amiga | amiga-*) + basic_machine=m68k-unknown + ;; + amigaos | amigados) + basic_machine=m68k-unknown + os=-amigaos + ;; + amigaunix | amix) + basic_machine=m68k-unknown + os=-sysv4 + ;; + apollo68) + basic_machine=m68k-apollo + os=-sysv + ;; + apollo68bsd) + basic_machine=m68k-apollo + os=-bsd + ;; + aros) + basic_machine=i386-pc + os=-aros + ;; + aux) + basic_machine=m68k-apple + os=-aux + ;; + balance) + basic_machine=ns32k-sequent + os=-dynix + ;; + blackfin) + basic_machine=bfin-unknown + os=-linux + ;; + blackfin-*) + basic_machine=bfin-`echo $basic_machine | sed 's/^[^-]*-//'` + os=-linux + ;; + bluegene*) + basic_machine=powerpc-ibm + os=-cnk + ;; + c54x-*) + basic_machine=tic54x-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + c55x-*) + basic_machine=tic55x-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + c6x-*) + basic_machine=tic6x-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + c90) + basic_machine=c90-cray + os=-unicos + ;; + cegcc) + basic_machine=arm-unknown + os=-cegcc + ;; + convex-c1) + basic_machine=c1-convex + os=-bsd + ;; + convex-c2) + basic_machine=c2-convex + os=-bsd + ;; + convex-c32) + basic_machine=c32-convex + os=-bsd + ;; + convex-c34) + basic_machine=c34-convex + os=-bsd + ;; + convex-c38) + basic_machine=c38-convex + os=-bsd + ;; + cray | j90) + basic_machine=j90-cray + os=-unicos + ;; + craynv) + basic_machine=craynv-cray + os=-unicosmp + ;; + cr16 | cr16-*) + basic_machine=cr16-unknown + os=-elf + ;; + crds | unos) + basic_machine=m68k-crds + ;; + crisv32 | crisv32-* | etraxfs*) + basic_machine=crisv32-axis + ;; + cris | cris-* | etrax*) + basic_machine=cris-axis + ;; + crx) + basic_machine=crx-unknown + os=-elf + ;; + da30 | da30-*) + basic_machine=m68k-da30 + ;; + decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn) + basic_machine=mips-dec + ;; + decsystem10* | dec10*) + basic_machine=pdp10-dec + os=-tops10 + ;; + decsystem20* | dec20*) + basic_machine=pdp10-dec + os=-tops20 + ;; + delta | 3300 | motorola-3300 | motorola-delta \ + | 3300-motorola | delta-motorola) + basic_machine=m68k-motorola + ;; + delta88) + basic_machine=m88k-motorola + os=-sysv3 + ;; + dicos) + basic_machine=i686-pc + os=-dicos + ;; + djgpp) + basic_machine=i586-pc + os=-msdosdjgpp + ;; + dpx20 | dpx20-*) + basic_machine=rs6000-bull + os=-bosx + ;; + dpx2* | dpx2*-bull) + basic_machine=m68k-bull + os=-sysv3 + ;; + ebmon29k) + basic_machine=a29k-amd + os=-ebmon + ;; + elxsi) + basic_machine=elxsi-elxsi + os=-bsd + ;; + encore | umax | mmax) + basic_machine=ns32k-encore + ;; + es1800 | OSE68k | ose68k | ose | OSE) + basic_machine=m68k-ericsson + os=-ose + ;; + fx2800) + basic_machine=i860-alliant + ;; + genix) + basic_machine=ns32k-ns + ;; + gmicro) + basic_machine=tron-gmicro + os=-sysv + ;; + go32) + basic_machine=i386-pc + os=-go32 + ;; + h3050r* | hiux*) + basic_machine=hppa1.1-hitachi + os=-hiuxwe2 + ;; + h8300hms) + basic_machine=h8300-hitachi + os=-hms + ;; + h8300xray) + basic_machine=h8300-hitachi + os=-xray + ;; + h8500hms) + basic_machine=h8500-hitachi + os=-hms + ;; + harris) + basic_machine=m88k-harris + os=-sysv3 + ;; + hp300-*) + basic_machine=m68k-hp + ;; + hp300bsd) + basic_machine=m68k-hp + os=-bsd + ;; + hp300hpux) + basic_machine=m68k-hp + os=-hpux + ;; + hp3k9[0-9][0-9] | hp9[0-9][0-9]) + basic_machine=hppa1.0-hp + ;; + hp9k2[0-9][0-9] | hp9k31[0-9]) + basic_machine=m68000-hp + ;; + hp9k3[2-9][0-9]) + basic_machine=m68k-hp + ;; + hp9k6[0-9][0-9] | hp6[0-9][0-9]) + basic_machine=hppa1.0-hp + ;; + hp9k7[0-79][0-9] | hp7[0-79][0-9]) + basic_machine=hppa1.1-hp + ;; + hp9k78[0-9] | hp78[0-9]) + # FIXME: really hppa2.0-hp + basic_machine=hppa1.1-hp + ;; + hp9k8[67]1 | hp8[67]1 | hp9k80[24] | hp80[24] | hp9k8[78]9 | hp8[78]9 | hp9k893 | hp893) + # FIXME: really hppa2.0-hp + basic_machine=hppa1.1-hp + ;; + hp9k8[0-9][13679] | hp8[0-9][13679]) + basic_machine=hppa1.1-hp + ;; + hp9k8[0-9][0-9] | hp8[0-9][0-9]) + basic_machine=hppa1.0-hp + ;; + hppa-next) + os=-nextstep3 + ;; + hppaosf) + basic_machine=hppa1.1-hp + os=-osf + ;; + hppro) + basic_machine=hppa1.1-hp + os=-proelf + ;; + i370-ibm* | ibm*) + basic_machine=i370-ibm + ;; + i*86v32) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-sysv32 + ;; + i*86v4*) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-sysv4 + ;; + i*86v) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-sysv + ;; + i*86sol2) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-solaris2 + ;; + i386mach) + basic_machine=i386-mach + os=-mach + ;; + i386-vsta | vsta) + basic_machine=i386-unknown + os=-vsta + ;; + iris | iris4d) + basic_machine=mips-sgi + case $os in + -irix*) + ;; + *) + os=-irix4 + ;; + esac + ;; + isi68 | isi) + basic_machine=m68k-isi + os=-sysv + ;; + m68knommu) + basic_machine=m68k-unknown + os=-linux + ;; + m68knommu-*) + basic_machine=m68k-`echo $basic_machine | sed 's/^[^-]*-//'` + os=-linux + ;; + m88k-omron*) + basic_machine=m88k-omron + ;; + magnum | m3230) + basic_machine=mips-mips + os=-sysv + ;; + merlin) + basic_machine=ns32k-utek + os=-sysv + ;; + microblaze*) + basic_machine=microblaze-xilinx + ;; + mingw64) + basic_machine=x86_64-pc + os=-mingw64 + ;; + mingw32) + basic_machine=i686-pc + os=-mingw32 + ;; + mingw32ce) + basic_machine=arm-unknown + os=-mingw32ce + ;; + miniframe) + basic_machine=m68000-convergent + ;; + *mint | -mint[0-9]* | *MiNT | *MiNT[0-9]*) + basic_machine=m68k-atari + os=-mint + ;; + mips3*-*) + basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'` + ;; + mips3*) + basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown + ;; + monitor) + basic_machine=m68k-rom68k + os=-coff + ;; + morphos) + basic_machine=powerpc-unknown + os=-morphos + ;; + msdos) + basic_machine=i386-pc + os=-msdos + ;; + ms1-*) + basic_machine=`echo $basic_machine | sed -e 's/ms1-/mt-/'` + ;; + msys) + basic_machine=i686-pc + os=-msys + ;; + mvs) + basic_machine=i370-ibm + os=-mvs + ;; + nacl) + basic_machine=le32-unknown + os=-nacl + ;; + ncr3000) + basic_machine=i486-ncr + os=-sysv4 + ;; + netbsd386) + basic_machine=i386-unknown + os=-netbsd + ;; + netwinder) + basic_machine=armv4l-rebel + os=-linux + ;; + news | news700 | news800 | news900) + basic_machine=m68k-sony + os=-newsos + ;; + news1000) + basic_machine=m68030-sony + os=-newsos + ;; + news-3600 | risc-news) + basic_machine=mips-sony + os=-newsos + ;; + necv70) + basic_machine=v70-nec + os=-sysv + ;; + next | m*-next ) + basic_machine=m68k-next + case $os in + -nextstep* ) + ;; + -ns2*) + os=-nextstep2 + ;; + *) + os=-nextstep3 + ;; + esac + ;; + nh3000) + basic_machine=m68k-harris + os=-cxux + ;; + nh[45]000) + basic_machine=m88k-harris + os=-cxux + ;; + nindy960) + basic_machine=i960-intel + os=-nindy + ;; + mon960) + basic_machine=i960-intel + os=-mon960 + ;; + nonstopux) + basic_machine=mips-compaq + os=-nonstopux + ;; + np1) + basic_machine=np1-gould + ;; + neo-tandem) + basic_machine=neo-tandem + ;; + nse-tandem) + basic_machine=nse-tandem + ;; + nsr-tandem) + basic_machine=nsr-tandem + ;; + op50n-* | op60c-*) + basic_machine=hppa1.1-oki + os=-proelf + ;; + openrisc | openrisc-*) + basic_machine=or32-unknown + ;; + os400) + basic_machine=powerpc-ibm + os=-os400 + ;; + OSE68000 | ose68000) + basic_machine=m68000-ericsson + os=-ose + ;; + os68k) + basic_machine=m68k-none + os=-os68k + ;; + pa-hitachi) + basic_machine=hppa1.1-hitachi + os=-hiuxwe2 + ;; + paragon) + basic_machine=i860-intel + os=-osf + ;; + parisc) + basic_machine=hppa-unknown + os=-linux + ;; + parisc-*) + basic_machine=hppa-`echo $basic_machine | sed 's/^[^-]*-//'` + os=-linux + ;; + pbd) + basic_machine=sparc-tti + ;; + pbb) + basic_machine=m68k-tti + ;; + pc532 | pc532-*) + basic_machine=ns32k-pc532 + ;; + pc98) + basic_machine=i386-pc + ;; + pc98-*) + basic_machine=i386-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pentium | p5 | k5 | k6 | nexgen | viac3) + basic_machine=i586-pc + ;; + pentiumpro | p6 | 6x86 | athlon | athlon_*) + basic_machine=i686-pc + ;; + pentiumii | pentium2 | pentiumiii | pentium3) + basic_machine=i686-pc + ;; + pentium4) + basic_machine=i786-pc + ;; + pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*) + basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pentiumpro-* | p6-* | 6x86-* | athlon-*) + basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pentiumii-* | pentium2-* | pentiumiii-* | pentium3-*) + basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pentium4-*) + basic_machine=i786-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pn) + basic_machine=pn-gould + ;; + power) basic_machine=power-ibm + ;; + ppc | ppcbe) basic_machine=powerpc-unknown + ;; + ppc-* | ppcbe-*) + basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ppcle | powerpclittle | ppc-le | powerpc-little) + basic_machine=powerpcle-unknown + ;; + ppcle-* | powerpclittle-*) + basic_machine=powerpcle-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ppc64) basic_machine=powerpc64-unknown + ;; + ppc64-*) basic_machine=powerpc64-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ppc64le | powerpc64little | ppc64-le | powerpc64-little) + basic_machine=powerpc64le-unknown + ;; + ppc64le-* | powerpc64little-*) + basic_machine=powerpc64le-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ps2) + basic_machine=i386-ibm + ;; + pw32) + basic_machine=i586-unknown + os=-pw32 + ;; + rdos | rdos64) + basic_machine=x86_64-pc + os=-rdos + ;; + rdos32) + basic_machine=i386-pc + os=-rdos + ;; + rom68k) + basic_machine=m68k-rom68k + os=-coff + ;; + rm[46]00) + basic_machine=mips-siemens + ;; + rtpc | rtpc-*) + basic_machine=romp-ibm + ;; + s390 | s390-*) + basic_machine=s390-ibm + ;; + s390x | s390x-*) + basic_machine=s390x-ibm + ;; + sa29200) + basic_machine=a29k-amd + os=-udi + ;; + sb1) + basic_machine=mipsisa64sb1-unknown + ;; + sb1el) + basic_machine=mipsisa64sb1el-unknown + ;; + sde) + basic_machine=mipsisa32-sde + os=-elf + ;; + sei) + basic_machine=mips-sei + os=-seiux + ;; + sequent) + basic_machine=i386-sequent + ;; + sh) + basic_machine=sh-hitachi + os=-hms + ;; + sh5el) + basic_machine=sh5le-unknown + ;; + sh64) + basic_machine=sh64-unknown + ;; + sparclite-wrs | simso-wrs) + basic_machine=sparclite-wrs + os=-vxworks + ;; + sps7) + basic_machine=m68k-bull + os=-sysv2 + ;; + spur) + basic_machine=spur-unknown + ;; + st2000) + basic_machine=m68k-tandem + ;; + stratus) + basic_machine=i860-stratus + os=-sysv4 + ;; + strongarm-* | thumb-*) + basic_machine=arm-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + sun2) + basic_machine=m68000-sun + ;; + sun2os3) + basic_machine=m68000-sun + os=-sunos3 + ;; + sun2os4) + basic_machine=m68000-sun + os=-sunos4 + ;; + sun3os3) + basic_machine=m68k-sun + os=-sunos3 + ;; + sun3os4) + basic_machine=m68k-sun + os=-sunos4 + ;; + sun4os3) + basic_machine=sparc-sun + os=-sunos3 + ;; + sun4os4) + basic_machine=sparc-sun + os=-sunos4 + ;; + sun4sol2) + basic_machine=sparc-sun + os=-solaris2 + ;; + sun3 | sun3-*) + basic_machine=m68k-sun + ;; + sun4) + basic_machine=sparc-sun + ;; + sun386 | sun386i | roadrunner) + basic_machine=i386-sun + ;; + sv1) + basic_machine=sv1-cray + os=-unicos + ;; + symmetry) + basic_machine=i386-sequent + os=-dynix + ;; + t3e) + basic_machine=alphaev5-cray + os=-unicos + ;; + t90) + basic_machine=t90-cray + os=-unicos + ;; + tile*) + basic_machine=$basic_machine-unknown + os=-linux-gnu + ;; + tx39) + basic_machine=mipstx39-unknown + ;; + tx39el) + basic_machine=mipstx39el-unknown + ;; + toad1) + basic_machine=pdp10-xkl + os=-tops20 + ;; + tower | tower-32) + basic_machine=m68k-ncr + ;; + tpf) + basic_machine=s390x-ibm + os=-tpf + ;; + udi29k) + basic_machine=a29k-amd + os=-udi + ;; + ultra3) + basic_machine=a29k-nyu + os=-sym1 + ;; + v810 | necv810) + basic_machine=v810-nec + os=-none + ;; + vaxv) + basic_machine=vax-dec + os=-sysv + ;; + vms) + basic_machine=vax-dec + os=-vms + ;; + vpp*|vx|vx-*) + basic_machine=f301-fujitsu + ;; + vxworks960) + basic_machine=i960-wrs + os=-vxworks + ;; + vxworks68) + basic_machine=m68k-wrs + os=-vxworks + ;; + vxworks29k) + basic_machine=a29k-wrs + os=-vxworks + ;; + w65*) + basic_machine=w65-wdc + os=-none + ;; + w89k-*) + basic_machine=hppa1.1-winbond + os=-proelf + ;; + xbox) + basic_machine=i686-pc + os=-mingw32 + ;; + xps | xps100) + basic_machine=xps100-honeywell + ;; + xscale-* | xscalee[bl]-*) + basic_machine=`echo $basic_machine | sed 's/^xscale/arm/'` + ;; + ymp) + basic_machine=ymp-cray + os=-unicos + ;; + z8k-*-coff) + basic_machine=z8k-unknown + os=-sim + ;; + z80-*-coff) + basic_machine=z80-unknown + os=-sim + ;; + none) + basic_machine=none-none + os=-none + ;; + +# Here we handle the default manufacturer of certain CPU types. It is in +# some cases the only manufacturer, in others, it is the most popular. + w89k) + basic_machine=hppa1.1-winbond + ;; + op50n) + basic_machine=hppa1.1-oki + ;; + op60c) + basic_machine=hppa1.1-oki + ;; + romp) + basic_machine=romp-ibm + ;; + mmix) + basic_machine=mmix-knuth + ;; + rs6000) + basic_machine=rs6000-ibm + ;; + vax) + basic_machine=vax-dec + ;; + pdp10) + # there are many clones, so DEC is not a safe bet + basic_machine=pdp10-unknown + ;; + pdp11) + basic_machine=pdp11-dec + ;; + we32k) + basic_machine=we32k-att + ;; + sh[1234] | sh[24]a | sh[24]aeb | sh[34]eb | sh[1234]le | sh[23]ele) + basic_machine=sh-unknown + ;; + sparc | sparcv8 | sparcv9 | sparcv9b | sparcv9v) + basic_machine=sparc-sun + ;; + cydra) + basic_machine=cydra-cydrome + ;; + orion) + basic_machine=orion-highlevel + ;; + orion105) + basic_machine=clipper-highlevel + ;; + mac | mpw | mac-mpw) + basic_machine=m68k-apple + ;; + pmac | pmac-mpw) + basic_machine=powerpc-apple + ;; + *-unknown) + # Make sure to match an already-canonicalized machine name. + ;; + *) + echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 + exit 1 + ;; +esac + +# Here we canonicalize certain aliases for manufacturers. +case $basic_machine in + *-digital*) + basic_machine=`echo $basic_machine | sed 's/digital.*/dec/'` + ;; + *-commodore*) + basic_machine=`echo $basic_machine | sed 's/commodore.*/cbm/'` + ;; + *) + ;; +esac + +# Decode manufacturer-specific aliases for certain operating systems. + +if [ x"$os" != x"" ] +then +case $os in + # First match some system type aliases + # that might get confused with valid system types. + # -solaris* is a basic system type, with this one exception. + -auroraux) + os=-auroraux + ;; + -solaris1 | -solaris1.*) + os=`echo $os | sed -e 's|solaris1|sunos4|'` + ;; + -solaris) + os=-solaris2 + ;; + -svr4*) + os=-sysv4 + ;; + -unixware*) + os=-sysv4.2uw + ;; + -gnu/linux*) + os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'` + ;; + # First accept the basic system types. + # The portable systems comes first. + # Each alternative MUST END IN A *, to match a version number. + # -sysv* is not here because it comes later, after sysvr4. + -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \ + | -*vms* | -sco* | -esix* | -isc* | -aix* | -cnk* | -sunos | -sunos[34]*\ + | -hpux* | -unos* | -osf* | -luna* | -dgux* | -auroraux* | -solaris* \ + | -sym* | -kopensolaris* | -plan9* \ + | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \ + | -aos* | -aros* \ + | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \ + | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \ + | -hiux* | -386bsd* | -knetbsd* | -mirbsd* | -netbsd* \ + | -bitrig* | -openbsd* | -solidbsd* \ + | -ekkobsd* | -kfreebsd* | -freebsd* | -riscix* | -lynxos* \ + | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \ + | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \ + | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \ + | -chorusos* | -chorusrdb* | -cegcc* \ + | -cygwin* | -msys* | -pe* | -psos* | -moss* | -proelf* | -rtems* \ + | -mingw32* | -mingw64* | -linux-gnu* | -linux-android* \ + | -linux-newlib* | -linux-musl* | -linux-uclibc* \ + | -uxpv* | -beos* | -mpeix* | -udk* \ + | -interix* | -uwin* | -mks* | -rhapsody* | -darwin* | -opened* \ + | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \ + | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \ + | -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \ + | -morphos* | -superux* | -rtmk* | -rtmk-nova* | -windiss* \ + | -powermax* | -dnix* | -nx6 | -nx7 | -sei* | -dragonfly* \ + | -skyos* | -haiku* | -rdos* | -toppers* | -drops* | -es* | -tirtos*) + # Remember, each alternative MUST END IN *, to match a version number. + ;; + -qnx*) + case $basic_machine in + x86-* | i*86-*) + ;; + *) + os=-nto$os + ;; + esac + ;; + -nto-qnx*) + ;; + -nto*) + os=`echo $os | sed -e 's|nto|nto-qnx|'` + ;; + -sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \ + | -windows* | -osx | -abug | -netware* | -os9* | -beos* | -haiku* \ + | -macos* | -mpw* | -magic* | -mmixware* | -mon960* | -lnews*) + ;; + -mac*) + os=`echo $os | sed -e 's|mac|macos|'` + ;; + -linux-dietlibc) + os=-linux-dietlibc + ;; + -linux*) + os=`echo $os | sed -e 's|linux|linux-gnu|'` + ;; + -sunos5*) + os=`echo $os | sed -e 's|sunos5|solaris2|'` + ;; + -sunos6*) + os=`echo $os | sed -e 's|sunos6|solaris3|'` + ;; + -opened*) + os=-openedition + ;; + -os400*) + os=-os400 + ;; + -wince*) + os=-wince + ;; + -osfrose*) + os=-osfrose + ;; + -osf*) + os=-osf + ;; + -utek*) + os=-bsd + ;; + -dynix*) + os=-bsd + ;; + -acis*) + os=-aos + ;; + -atheos*) + os=-atheos + ;; + -syllable*) + os=-syllable + ;; + -386bsd) + os=-bsd + ;; + -ctix* | -uts*) + os=-sysv + ;; + -nova*) + os=-rtmk-nova + ;; + -ns2 ) + os=-nextstep2 + ;; + -nsk*) + os=-nsk + ;; + # Preserve the version number of sinix5. + -sinix5.*) + os=`echo $os | sed -e 's|sinix|sysv|'` + ;; + -sinix*) + os=-sysv4 + ;; + -tpf*) + os=-tpf + ;; + -triton*) + os=-sysv3 + ;; + -oss*) + os=-sysv3 + ;; + -svr4) + os=-sysv4 + ;; + -svr3) + os=-sysv3 + ;; + -sysvr4) + os=-sysv4 + ;; + # This must come after -sysvr4. + -sysv*) + ;; + -ose*) + os=-ose + ;; + -es1800*) + os=-ose + ;; + -xenix) + os=-xenix + ;; + -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) + os=-mint + ;; + -aros*) + os=-aros + ;; + -zvmoe) + os=-zvmoe + ;; + -dicos*) + os=-dicos + ;; + -nacl*) + ;; + -none) + ;; + *) + # Get rid of the `-' at the beginning of $os. + os=`echo $os | sed 's/[^-]*-//'` + echo Invalid configuration \`$1\': system \`$os\' not recognized 1>&2 + exit 1 + ;; +esac +else + +# Here we handle the default operating systems that come with various machines. +# The value should be what the vendor currently ships out the door with their +# machine or put another way, the most popular os provided with the machine. + +# Note that if you're going to try to match "-MANUFACTURER" here (say, +# "-sun"), then you have to tell the case statement up towards the top +# that MANUFACTURER isn't an operating system. Otherwise, code above +# will signal an error saying that MANUFACTURER isn't an operating +# system, and we'll never get to this point. + +case $basic_machine in + score-*) + os=-elf + ;; + spu-*) + os=-elf + ;; + *-acorn) + os=-riscix1.2 + ;; + arm*-rebel) + os=-linux + ;; + arm*-semi) + os=-aout + ;; + c4x-* | tic4x-*) + os=-coff + ;; + c8051-*) + os=-elf + ;; + hexagon-*) + os=-elf + ;; + tic54x-*) + os=-coff + ;; + tic55x-*) + os=-coff + ;; + tic6x-*) + os=-coff + ;; + # This must come before the *-dec entry. + pdp10-*) + os=-tops20 + ;; + pdp11-*) + os=-none + ;; + *-dec | vax-*) + os=-ultrix4.2 + ;; + m68*-apollo) + os=-domain + ;; + i386-sun) + os=-sunos4.0.2 + ;; + m68000-sun) + os=-sunos3 + ;; + m68*-cisco) + os=-aout + ;; + mep-*) + os=-elf + ;; + mips*-cisco) + os=-elf + ;; + mips*-*) + os=-elf + ;; + or32-*) + os=-coff + ;; + *-tti) # must be before sparc entry or we get the wrong os. + os=-sysv3 + ;; + sparc-* | *-sun) + os=-sunos4.1.1 + ;; + *-be) + os=-beos + ;; + *-haiku) + os=-haiku + ;; + *-ibm) + os=-aix + ;; + *-knuth) + os=-mmixware + ;; + *-wec) + os=-proelf + ;; + *-winbond) + os=-proelf + ;; + *-oki) + os=-proelf + ;; + *-hp) + os=-hpux + ;; + *-hitachi) + os=-hiux + ;; + i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent) + os=-sysv + ;; + *-cbm) + os=-amigaos + ;; + *-dg) + os=-dgux + ;; + *-dolphin) + os=-sysv3 + ;; + m68k-ccur) + os=-rtu + ;; + m88k-omron*) + os=-luna + ;; + *-next ) + os=-nextstep + ;; + *-sequent) + os=-ptx + ;; + *-crds) + os=-unos + ;; + *-ns) + os=-genix + ;; + i370-*) + os=-mvs + ;; + *-next) + os=-nextstep3 + ;; + *-gould) + os=-sysv + ;; + *-highlevel) + os=-bsd + ;; + *-encore) + os=-bsd + ;; + *-sgi) + os=-irix + ;; + *-siemens) + os=-sysv4 + ;; + *-masscomp) + os=-rtu + ;; + f30[01]-fujitsu | f700-fujitsu) + os=-uxpv + ;; + *-rom68k) + os=-coff + ;; + *-*bug) + os=-coff + ;; + *-apple) + os=-macos + ;; + *-atari*) + os=-mint + ;; + *) + os=-none + ;; +esac +fi + +# Here we handle the case where we know the os, and the CPU type, but not the +# manufacturer. We pick the logical manufacturer. +vendor=unknown +case $basic_machine in + *-unknown) + case $os in + -riscix*) + vendor=acorn + ;; + -sunos*) + vendor=sun + ;; + -cnk*|-aix*) + vendor=ibm + ;; + -beos*) + vendor=be + ;; + -hpux*) + vendor=hp + ;; + -mpeix*) + vendor=hp + ;; + -hiux*) + vendor=hitachi + ;; + -unos*) + vendor=crds + ;; + -dgux*) + vendor=dg + ;; + -luna*) + vendor=omron + ;; + -genix*) + vendor=ns + ;; + -mvs* | -opened*) + vendor=ibm + ;; + -os400*) + vendor=ibm + ;; + -ptx*) + vendor=sequent + ;; + -tpf*) + vendor=ibm + ;; + -vxsim* | -vxworks* | -windiss*) + vendor=wrs + ;; + -aux*) + vendor=apple + ;; + -hms*) + vendor=hitachi + ;; + -mpw* | -macos*) + vendor=apple + ;; + -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) + vendor=atari + ;; + -vos*) + vendor=stratus + ;; + esac + basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"` + ;; +esac + +echo $basic_machine$os +exit + +# Local variables: +# eval: (add-hook 'write-file-hooks 'time-stamp) +# time-stamp-start: "timestamp='" +# time-stamp-format: "%:y-%02m-%02d" +# time-stamp-end: "'" +# End: diff --git a/configure b/configure new file mode 100755 index 0000000..6ea12fb --- /dev/null +++ b/configure @@ -0,0 +1,10716 @@ +#! /bin/sh +# Guess values for system-dependent variables and create Makefiles. +# Generated by GNU Autoconf 2.69. +# +# +# Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc. +# +# +# This configure script is free software; the Free Software Foundation +# gives unlimited permission to copy, distribute and modify it. +## -------------------- ## +## M4sh Initialization. ## +## -------------------- ## + +# Be more Bourne compatible +DUALCASE=1; export DUALCASE # for MKS sh +if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : + emulate sh + NULLCMD=: + # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which + # is contrary to our usage. Disable this feature. + alias -g '${1+"$@"}'='"$@"' + setopt NO_GLOB_SUBST +else + case `(set -o) 2>/dev/null` in #( + *posix*) : + set -o posix ;; #( + *) : + ;; +esac +fi + + +as_nl=' +' +export as_nl +# Printing a long string crashes Solaris 7 /usr/bin/printf. +as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' +as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo +as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo +# Prefer a ksh shell builtin over an external printf program on Solaris, +# but without wasting forks for bash or zsh. +if test -z "$BASH_VERSION$ZSH_VERSION" \ + && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then + as_echo='print -r --' + as_echo_n='print -rn --' +elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then + as_echo='printf %s\n' + as_echo_n='printf %s' +else + if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then + as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' + as_echo_n='/usr/ucb/echo -n' + else + as_echo_body='eval expr "X$1" : "X\\(.*\\)"' + as_echo_n_body='eval + arg=$1; + case $arg in #( + *"$as_nl"*) + expr "X$arg" : "X\\(.*\\)$as_nl"; + arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; + esac; + expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" + ' + export as_echo_n_body + as_echo_n='sh -c $as_echo_n_body as_echo' + fi + export as_echo_body + as_echo='sh -c $as_echo_body as_echo' +fi + +# The user is always right. +if test "${PATH_SEPARATOR+set}" != set; then + PATH_SEPARATOR=: + (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { + (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || + PATH_SEPARATOR=';' + } +fi + + +# IFS +# We need space, tab and new line, in precisely that order. Quoting is +# there to prevent editors from complaining about space-tab. +# (If _AS_PATH_WALK were called with IFS unset, it would disable word +# splitting by setting IFS to empty value.) +IFS=" "" $as_nl" + +# Find who we are. Look in the path if we contain no directory separator. +as_myself= +case $0 in #(( + *[\\/]* ) as_myself=$0 ;; + *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break + done +IFS=$as_save_IFS + + ;; +esac +# We did not find ourselves, most probably we were run as `sh COMMAND' +# in which case we are not to be found in the path. +if test "x$as_myself" = x; then + as_myself=$0 +fi +if test ! -f "$as_myself"; then + $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 + exit 1 +fi + +# Unset variables that we do not need and which cause bugs (e.g. in +# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" +# suppresses any "Segmentation fault" message there. '((' could +# trigger a bug in pdksh 5.2.14. +for as_var in BASH_ENV ENV MAIL MAILPATH +do eval test x\${$as_var+set} = xset \ + && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : +done +PS1='$ ' +PS2='> ' +PS4='+ ' + +# NLS nuisances. +LC_ALL=C +export LC_ALL +LANGUAGE=C +export LANGUAGE + +# CDPATH. +(unset CDPATH) >/dev/null 2>&1 && unset CDPATH + +# Use a proper internal environment variable to ensure we don't fall + # into an infinite loop, continuously re-executing ourselves. + if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then + _as_can_reexec=no; export _as_can_reexec; + # We cannot yet assume a decent shell, so we have to provide a +# neutralization value for shells without unset; and this also +# works around shells that cannot unset nonexistent variables. +# Preserve -v and -x to the replacement shell. +BASH_ENV=/dev/null +ENV=/dev/null +(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV +case $- in # (((( + *v*x* | *x*v* ) as_opts=-vx ;; + *v* ) as_opts=-v ;; + *x* ) as_opts=-x ;; + * ) as_opts= ;; +esac +exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} +# Admittedly, this is quite paranoid, since all the known shells bail +# out after a failed `exec'. +$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 +as_fn_exit 255 + fi + # We don't want this to propagate to other subprocesses. + { _as_can_reexec=; unset _as_can_reexec;} +if test "x$CONFIG_SHELL" = x; then + as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then : + emulate sh + NULLCMD=: + # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which + # is contrary to our usage. Disable this feature. + alias -g '\${1+\"\$@\"}'='\"\$@\"' + setopt NO_GLOB_SUBST +else + case \`(set -o) 2>/dev/null\` in #( + *posix*) : + set -o posix ;; #( + *) : + ;; +esac +fi +" + as_required="as_fn_return () { (exit \$1); } +as_fn_success () { as_fn_return 0; } +as_fn_failure () { as_fn_return 1; } +as_fn_ret_success () { return 0; } +as_fn_ret_failure () { return 1; } + +exitcode=0 +as_fn_success || { exitcode=1; echo as_fn_success failed.; } +as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } +as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } +as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } +if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then : + +else + exitcode=1; echo positional parameters were not saved. +fi +test x\$exitcode = x0 || exit 1 +test -x / || exit 1" + as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO + as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO + eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && + test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1 +test \$(( 1 + 1 )) = 2 || exit 1" + if (eval "$as_required") 2>/dev/null; then : + as_have_required=yes +else + as_have_required=no +fi + if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then : + +else + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_found=false +for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + as_found=: + case $as_dir in #( + /*) + for as_base in sh bash ksh sh5; do + # Try only shells that exist, to save several forks. + as_shell=$as_dir/$as_base + if { test -f "$as_shell" || test -f "$as_shell.exe"; } && + { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then : + CONFIG_SHELL=$as_shell as_have_required=yes + if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then : + break 2 +fi +fi + done;; + esac + as_found=false +done +$as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } && + { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then : + CONFIG_SHELL=$SHELL as_have_required=yes +fi; } +IFS=$as_save_IFS + + + if test "x$CONFIG_SHELL" != x; then : + export CONFIG_SHELL + # We cannot yet assume a decent shell, so we have to provide a +# neutralization value for shells without unset; and this also +# works around shells that cannot unset nonexistent variables. +# Preserve -v and -x to the replacement shell. +BASH_ENV=/dev/null +ENV=/dev/null +(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV +case $- in # (((( + *v*x* | *x*v* ) as_opts=-vx ;; + *v* ) as_opts=-v ;; + *x* ) as_opts=-x ;; + * ) as_opts= ;; +esac +exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} +# Admittedly, this is quite paranoid, since all the known shells bail +# out after a failed `exec'. +$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 +exit 255 +fi + + if test x$as_have_required = xno; then : + $as_echo "$0: This script requires a shell more modern than all" + $as_echo "$0: the shells that I found on your system." + if test x${ZSH_VERSION+set} = xset ; then + $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should" + $as_echo "$0: be upgraded to zsh 4.3.4 or later." + else + $as_echo "$0: Please tell bug-autoconf@gnu.org about your system, +$0: including any error possibly output before this +$0: message. Then install a modern shell, or manually run +$0: the script under such a shell if you do have one." + fi + exit 1 +fi +fi +fi +SHELL=${CONFIG_SHELL-/bin/sh} +export SHELL +# Unset more variables known to interfere with behavior of common tools. +CLICOLOR_FORCE= GREP_OPTIONS= +unset CLICOLOR_FORCE GREP_OPTIONS + +## --------------------- ## +## M4sh Shell Functions. ## +## --------------------- ## +# as_fn_unset VAR +# --------------- +# Portably unset VAR. +as_fn_unset () +{ + { eval $1=; unset $1;} +} +as_unset=as_fn_unset + +# as_fn_set_status STATUS +# ----------------------- +# Set $? to STATUS, without forking. +as_fn_set_status () +{ + return $1 +} # as_fn_set_status + +# as_fn_exit STATUS +# ----------------- +# Exit the shell with STATUS, even in a "trap 0" or "set -e" context. +as_fn_exit () +{ + set +e + as_fn_set_status $1 + exit $1 +} # as_fn_exit + +# as_fn_mkdir_p +# ------------- +# Create "$as_dir" as a directory, including parents if necessary. +as_fn_mkdir_p () +{ + + case $as_dir in #( + -*) as_dir=./$as_dir;; + esac + test -d "$as_dir" || eval $as_mkdir_p || { + as_dirs= + while :; do + case $as_dir in #( + *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( + *) as_qdir=$as_dir;; + esac + as_dirs="'$as_qdir' $as_dirs" + as_dir=`$as_dirname -- "$as_dir" || +$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_dir" : 'X\(//\)[^/]' \| \ + X"$as_dir" : 'X\(//\)$' \| \ + X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X"$as_dir" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + test -d "$as_dir" && break + done + test -z "$as_dirs" || eval "mkdir $as_dirs" + } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" + + +} # as_fn_mkdir_p + +# as_fn_executable_p FILE +# ----------------------- +# Test if FILE is an executable regular file. +as_fn_executable_p () +{ + test -f "$1" && test -x "$1" +} # as_fn_executable_p +# as_fn_append VAR VALUE +# ---------------------- +# Append the text in VALUE to the end of the definition contained in VAR. Take +# advantage of any shell optimizations that allow amortized linear growth over +# repeated appends, instead of the typical quadratic growth present in naive +# implementations. +if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : + eval 'as_fn_append () + { + eval $1+=\$2 + }' +else + as_fn_append () + { + eval $1=\$$1\$2 + } +fi # as_fn_append + +# as_fn_arith ARG... +# ------------------ +# Perform arithmetic evaluation on the ARGs, and store the result in the +# global $as_val. Take advantage of shells that can avoid forks. The arguments +# must be portable across $(()) and expr. +if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : + eval 'as_fn_arith () + { + as_val=$(( $* )) + }' +else + as_fn_arith () + { + as_val=`expr "$@" || test $? -eq 1` + } +fi # as_fn_arith + + +# as_fn_error STATUS ERROR [LINENO LOG_FD] +# ---------------------------------------- +# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are +# provided, also output the error to LOG_FD, referencing LINENO. Then exit the +# script with STATUS, using 1 if that was 0. +as_fn_error () +{ + as_status=$1; test $as_status -eq 0 && as_status=1 + if test "$4"; then + as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 + fi + $as_echo "$as_me: error: $2" >&2 + as_fn_exit $as_status +} # as_fn_error + +if expr a : '\(a\)' >/dev/null 2>&1 && + test "X`expr 00001 : '.*\(...\)'`" = X001; then + as_expr=expr +else + as_expr=false +fi + +if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then + as_basename=basename +else + as_basename=false +fi + +if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then + as_dirname=dirname +else + as_dirname=false +fi + +as_me=`$as_basename -- "$0" || +$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ + X"$0" : 'X\(//\)$' \| \ + X"$0" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X/"$0" | + sed '/^.*\/\([^/][^/]*\)\/*$/{ + s//\1/ + q + } + /^X\/\(\/\/\)$/{ + s//\1/ + q + } + /^X\/\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + +# Avoid depending upon Character Ranges. +as_cr_letters='abcdefghijklmnopqrstuvwxyz' +as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' +as_cr_Letters=$as_cr_letters$as_cr_LETTERS +as_cr_digits='0123456789' +as_cr_alnum=$as_cr_Letters$as_cr_digits + + + as_lineno_1=$LINENO as_lineno_1a=$LINENO + as_lineno_2=$LINENO as_lineno_2a=$LINENO + eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && + test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { + # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) + sed -n ' + p + /[$]LINENO/= + ' <$as_myself | + sed ' + s/[$]LINENO.*/&-/ + t lineno + b + :lineno + N + :loop + s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ + t loop + s/-\n.*// + ' >$as_me.lineno && + chmod +x "$as_me.lineno" || + { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } + + # If we had to re-execute with $CONFIG_SHELL, we're ensured to have + # already done that, so ensure we don't try to do so again and fall + # in an infinite loop. This has already happened in practice. + _as_can_reexec=no; export _as_can_reexec + # Don't try to exec as it changes $[0], causing all sort of problems + # (the dirname of $[0] is not the place where we might find the + # original and so on. Autoconf is especially sensitive to this). + . "./$as_me.lineno" + # Exit status is that of the last command. + exit +} + +ECHO_C= ECHO_N= ECHO_T= +case `echo -n x` in #((((( +-n*) + case `echo 'xy\c'` in + *c*) ECHO_T=' ';; # ECHO_T is single tab character. + xy) ECHO_C='\c';; + *) echo `echo ksh88 bug on AIX 6.1` > /dev/null + ECHO_T=' ';; + esac;; +*) + ECHO_N='-n';; +esac + +rm -f conf$$ conf$$.exe conf$$.file +if test -d conf$$.dir; then + rm -f conf$$.dir/conf$$.file +else + rm -f conf$$.dir + mkdir conf$$.dir 2>/dev/null +fi +if (echo >conf$$.file) 2>/dev/null; then + if ln -s conf$$.file conf$$ 2>/dev/null; then + as_ln_s='ln -s' + # ... but there are two gotchas: + # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. + # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. + # In both cases, we have to default to `cp -pR'. + ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || + as_ln_s='cp -pR' + elif ln conf$$.file conf$$ 2>/dev/null; then + as_ln_s=ln + else + as_ln_s='cp -pR' + fi +else + as_ln_s='cp -pR' +fi +rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file +rmdir conf$$.dir 2>/dev/null + +if mkdir -p . 2>/dev/null; then + as_mkdir_p='mkdir -p "$as_dir"' +else + test -d ./-p && rmdir ./-p + as_mkdir_p=false +fi + +as_test_x='test -x' +as_executable_p=as_fn_executable_p + +# Sed expression to map a string onto a valid CPP name. +as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" + +# Sed expression to map a string onto a valid variable name. +as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" + + +test -n "$DJDIR" || exec 7<&0 &1 + +# Name of the host. +# hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, +# so uname gets run too. +ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` + +# +# Initializations. +# +ac_default_prefix=/usr/local +ac_clean_files= +ac_config_libobj_dir=. +LIBOBJS= +cross_compiling=no +subdirs= +MFLAGS= +MAKEFLAGS= + +# Identity of this package. +PACKAGE_NAME= +PACKAGE_TARNAME= +PACKAGE_VERSION= +PACKAGE_STRING= +PACKAGE_BUGREPORT= +PACKAGE_URL= + +# Factoring default headers for most tests. +ac_includes_default="\ +#include +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#ifdef HAVE_SYS_STAT_H +# include +#endif +#ifdef STDC_HEADERS +# include +# include +#else +# ifdef HAVE_STDLIB_H +# include +# endif +#endif +#ifdef HAVE_STRING_H +# if !defined STDC_HEADERS && defined HAVE_MEMORY_H +# include +# endif +# include +#endif +#ifdef HAVE_STRINGS_H +# include +#endif +#ifdef HAVE_INTTYPES_H +# include +#endif +#ifdef HAVE_STDINT_H +# include +#endif +#ifdef HAVE_UNISTD_H +# include +#endif" + +ac_subst_vars='LTLIBOBJS +LIBOBJS +use +GNU_LD +LEADING_UNDERSCORE +EXTRA_LOBJS +PRELINK_CHECK +O2FLAGS +O3FLAGS +NIFLAGS +FINAL_CFLAGS +ALLOCA +NOTIFY +TCL_LIBS +TCL_DL_LIBS +TCL_LIB_SPEC +TK_XLIBSW +TK_BUILD_LIB_SPEC +TK_LIB_SPEC +TCL_INCLUDE +TK_INCLUDE +TK_XINCLUDES +TCL_LIBRARY +TK_LIBRARY +TK_CONFIG_PREFIX +TCLSH +INFO_DIR +EMACS_DEFAULT_EL +EMACS_SITE_LISP +EMACS +HAVE_SIGEMT +HAVE_SIGSYS +HAVE_SV_ONSTACK +USE_CLEANUP +HAVE_PUTENV +HAVE_SETENV +NO_PROFILE +RL_LIB +RL_OBJS +CLSTANDARD +SYSTEM +FLISP +HAVE_LONG_LONG +PAGEWIDTH +DOUBLE_BIGENDIAN +WORDS_BIGENDIAN +LIBIBERTY +LIBBFD +BUILD_BFD +HAVE_OUTPUT_BFD +X_CFLAGS +X_LIBS +XMKMF +GMPDIR +GMP +HAVE_MALLOC_ZONE_MEMALIGN +EGREP +GREP +MAKEINFO +AWK +CPP +OBJEXT +EXEEXT +ac_ct_CC +CPPFLAGS +LDFLAGS +CFLAGS +CC +PROCESSOR_FLAGS +host_os +host_vendor +host_cpu +host +build_os +build_vendor +build_cpu +build +VERSION +target_alias +host_alias +build_alias +LIBS +ECHO_T +ECHO_N +ECHO_C +DEFS +mandir +localedir +libdir +psdir +pdfdir +dvidir +htmldir +infodir +docdir +oldincludedir +includedir +localstatedir +sharedstatedir +sysconfdir +datadir +datarootdir +libexecdir +sbindir +bindir +program_transform_name +prefix +exec_prefix +PACKAGE_URL +PACKAGE_BUGREPORT +PACKAGE_STRING +PACKAGE_VERSION +PACKAGE_TARNAME +PACKAGE_NAME +PATH_SEPARATOR +SHELL' +ac_subst_files='' +ac_user_opts=' +enable_option_checking +enable_widecons +enable_safecdr +enable_safecdrdbg +enable_prelink +enable_fastimmfix +enable_holepage +enable_vssize +enable_bdssize +enable_ihssize +enable_frssize +enable_machine +enable_immfix +enable_notify +enable_tcltk +enable_tkconfig +enable_tclconfig +enable_infodir +enable_emacsdir +enable_common_binary +enable_japi +enable_xdr +enable_xgcl +enable_dlopen +enable_statsysbfd +enable_dynsysbfd +enable_custreloc +enable_debug +enable_gprof +enable_static +enable_pic +enable_oldgmp +enable_dynsysgmp +with_x +enable_readline +enable_ansi +' + ac_precious_vars='build_alias +host_alias +target_alias +CC +CFLAGS +LDFLAGS +LIBS +CPPFLAGS +CPP +XMKMF' + + +# Initialize some variables set by options. +ac_init_help= +ac_init_version=false +ac_unrecognized_opts= +ac_unrecognized_sep= +# The variables have the same names as the options, with +# dashes changed to underlines. +cache_file=/dev/null +exec_prefix=NONE +no_create= +no_recursion= +prefix=NONE +program_prefix=NONE +program_suffix=NONE +program_transform_name=s,x,x, +silent= +site= +srcdir= +verbose= +x_includes=NONE +x_libraries=NONE + +# Installation directory options. +# These are left unexpanded so users can "make install exec_prefix=/foo" +# and all the variables that are supposed to be based on exec_prefix +# by default will actually change. +# Use braces instead of parens because sh, perl, etc. also accept them. +# (The list follows the same order as the GNU Coding Standards.) +bindir='${exec_prefix}/bin' +sbindir='${exec_prefix}/sbin' +libexecdir='${exec_prefix}/libexec' +datarootdir='${prefix}/share' +datadir='${datarootdir}' +sysconfdir='${prefix}/etc' +sharedstatedir='${prefix}/com' +localstatedir='${prefix}/var' +includedir='${prefix}/include' +oldincludedir='/usr/include' +docdir='${datarootdir}/doc/${PACKAGE}' +infodir='${datarootdir}/info' +htmldir='${docdir}' +dvidir='${docdir}' +pdfdir='${docdir}' +psdir='${docdir}' +libdir='${exec_prefix}/lib' +localedir='${datarootdir}/locale' +mandir='${datarootdir}/man' + +ac_prev= +ac_dashdash= +for ac_option +do + # If the previous option needs an argument, assign it. + if test -n "$ac_prev"; then + eval $ac_prev=\$ac_option + ac_prev= + continue + fi + + case $ac_option in + *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; + *=) ac_optarg= ;; + *) ac_optarg=yes ;; + esac + + # Accept the important Cygnus configure options, so we can diagnose typos. + + case $ac_dashdash$ac_option in + --) + ac_dashdash=yes ;; + + -bindir | --bindir | --bindi | --bind | --bin | --bi) + ac_prev=bindir ;; + -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) + bindir=$ac_optarg ;; + + -build | --build | --buil | --bui | --bu) + ac_prev=build_alias ;; + -build=* | --build=* | --buil=* | --bui=* | --bu=*) + build_alias=$ac_optarg ;; + + -cache-file | --cache-file | --cache-fil | --cache-fi \ + | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) + ac_prev=cache_file ;; + -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ + | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) + cache_file=$ac_optarg ;; + + --config-cache | -C) + cache_file=config.cache ;; + + -datadir | --datadir | --datadi | --datad) + ac_prev=datadir ;; + -datadir=* | --datadir=* | --datadi=* | --datad=*) + datadir=$ac_optarg ;; + + -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ + | --dataroo | --dataro | --datar) + ac_prev=datarootdir ;; + -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ + | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) + datarootdir=$ac_optarg ;; + + -disable-* | --disable-*) + ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid feature name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"enable_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval enable_$ac_useropt=no ;; + + -docdir | --docdir | --docdi | --doc | --do) + ac_prev=docdir ;; + -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) + docdir=$ac_optarg ;; + + -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) + ac_prev=dvidir ;; + -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) + dvidir=$ac_optarg ;; + + -enable-* | --enable-*) + ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid feature name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"enable_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval enable_$ac_useropt=\$ac_optarg ;; + + -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ + | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ + | --exec | --exe | --ex) + ac_prev=exec_prefix ;; + -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ + | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ + | --exec=* | --exe=* | --ex=*) + exec_prefix=$ac_optarg ;; + + -gas | --gas | --ga | --g) + # Obsolete; use --with-gas. + with_gas=yes ;; + + -help | --help | --hel | --he | -h) + ac_init_help=long ;; + -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) + ac_init_help=recursive ;; + -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) + ac_init_help=short ;; + + -host | --host | --hos | --ho) + ac_prev=host_alias ;; + -host=* | --host=* | --hos=* | --ho=*) + host_alias=$ac_optarg ;; + + -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) + ac_prev=htmldir ;; + -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ + | --ht=*) + htmldir=$ac_optarg ;; + + -includedir | --includedir | --includedi | --included | --include \ + | --includ | --inclu | --incl | --inc) + ac_prev=includedir ;; + -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ + | --includ=* | --inclu=* | --incl=* | --inc=*) + includedir=$ac_optarg ;; + + -infodir | --infodir | --infodi | --infod | --info | --inf) + ac_prev=infodir ;; + -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) + infodir=$ac_optarg ;; + + -libdir | --libdir | --libdi | --libd) + ac_prev=libdir ;; + -libdir=* | --libdir=* | --libdi=* | --libd=*) + libdir=$ac_optarg ;; + + -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ + | --libexe | --libex | --libe) + ac_prev=libexecdir ;; + -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ + | --libexe=* | --libex=* | --libe=*) + libexecdir=$ac_optarg ;; + + -localedir | --localedir | --localedi | --localed | --locale) + ac_prev=localedir ;; + -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) + localedir=$ac_optarg ;; + + -localstatedir | --localstatedir | --localstatedi | --localstated \ + | --localstate | --localstat | --localsta | --localst | --locals) + ac_prev=localstatedir ;; + -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ + | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) + localstatedir=$ac_optarg ;; + + -mandir | --mandir | --mandi | --mand | --man | --ma | --m) + ac_prev=mandir ;; + -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) + mandir=$ac_optarg ;; + + -nfp | --nfp | --nf) + # Obsolete; use --without-fp. + with_fp=no ;; + + -no-create | --no-create | --no-creat | --no-crea | --no-cre \ + | --no-cr | --no-c | -n) + no_create=yes ;; + + -no-recursion | --no-recursion | --no-recursio | --no-recursi \ + | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) + no_recursion=yes ;; + + -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ + | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ + | --oldin | --oldi | --old | --ol | --o) + ac_prev=oldincludedir ;; + -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ + | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ + | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) + oldincludedir=$ac_optarg ;; + + -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) + ac_prev=prefix ;; + -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) + prefix=$ac_optarg ;; + + -program-prefix | --program-prefix | --program-prefi | --program-pref \ + | --program-pre | --program-pr | --program-p) + ac_prev=program_prefix ;; + -program-prefix=* | --program-prefix=* | --program-prefi=* \ + | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) + program_prefix=$ac_optarg ;; + + -program-suffix | --program-suffix | --program-suffi | --program-suff \ + | --program-suf | --program-su | --program-s) + ac_prev=program_suffix ;; + -program-suffix=* | --program-suffix=* | --program-suffi=* \ + | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) + program_suffix=$ac_optarg ;; + + -program-transform-name | --program-transform-name \ + | --program-transform-nam | --program-transform-na \ + | --program-transform-n | --program-transform- \ + | --program-transform | --program-transfor \ + | --program-transfo | --program-transf \ + | --program-trans | --program-tran \ + | --progr-tra | --program-tr | --program-t) + ac_prev=program_transform_name ;; + -program-transform-name=* | --program-transform-name=* \ + | --program-transform-nam=* | --program-transform-na=* \ + | --program-transform-n=* | --program-transform-=* \ + | --program-transform=* | --program-transfor=* \ + | --program-transfo=* | --program-transf=* \ + | --program-trans=* | --program-tran=* \ + | --progr-tra=* | --program-tr=* | --program-t=*) + program_transform_name=$ac_optarg ;; + + -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) + ac_prev=pdfdir ;; + -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) + pdfdir=$ac_optarg ;; + + -psdir | --psdir | --psdi | --psd | --ps) + ac_prev=psdir ;; + -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) + psdir=$ac_optarg ;; + + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + silent=yes ;; + + -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) + ac_prev=sbindir ;; + -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ + | --sbi=* | --sb=*) + sbindir=$ac_optarg ;; + + -sharedstatedir | --sharedstatedir | --sharedstatedi \ + | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ + | --sharedst | --shareds | --shared | --share | --shar \ + | --sha | --sh) + ac_prev=sharedstatedir ;; + -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ + | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ + | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ + | --sha=* | --sh=*) + sharedstatedir=$ac_optarg ;; + + -site | --site | --sit) + ac_prev=site ;; + -site=* | --site=* | --sit=*) + site=$ac_optarg ;; + + -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) + ac_prev=srcdir ;; + -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) + srcdir=$ac_optarg ;; + + -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ + | --syscon | --sysco | --sysc | --sys | --sy) + ac_prev=sysconfdir ;; + -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ + | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) + sysconfdir=$ac_optarg ;; + + -target | --target | --targe | --targ | --tar | --ta | --t) + ac_prev=target_alias ;; + -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) + target_alias=$ac_optarg ;; + + -v | -verbose | --verbose | --verbos | --verbo | --verb) + verbose=yes ;; + + -version | --version | --versio | --versi | --vers | -V) + ac_init_version=: ;; + + -with-* | --with-*) + ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid package name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"with_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval with_$ac_useropt=\$ac_optarg ;; + + -without-* | --without-*) + ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid package name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"with_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval with_$ac_useropt=no ;; + + --x) + # Obsolete; use --with-x. + with_x=yes ;; + + -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ + | --x-incl | --x-inc | --x-in | --x-i) + ac_prev=x_includes ;; + -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ + | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) + x_includes=$ac_optarg ;; + + -x-libraries | --x-libraries | --x-librarie | --x-librari \ + | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) + ac_prev=x_libraries ;; + -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ + | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) + x_libraries=$ac_optarg ;; + + -*) as_fn_error $? "unrecognized option: \`$ac_option' +Try \`$0 --help' for more information" + ;; + + *=*) + ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` + # Reject names that are not valid shell variable names. + case $ac_envvar in #( + '' | [0-9]* | *[!_$as_cr_alnum]* ) + as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; + esac + eval $ac_envvar=\$ac_optarg + export $ac_envvar ;; + + *) + # FIXME: should be removed in autoconf 3.0. + $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 + expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && + $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2 + : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" + ;; + + esac +done + +if test -n "$ac_prev"; then + ac_option=--`echo $ac_prev | sed 's/_/-/g'` + as_fn_error $? "missing argument to $ac_option" +fi + +if test -n "$ac_unrecognized_opts"; then + case $enable_option_checking in + no) ;; + fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; + *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; + esac +fi + +# Check all directory arguments for consistency. +for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ + datadir sysconfdir sharedstatedir localstatedir includedir \ + oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ + libdir localedir mandir +do + eval ac_val=\$$ac_var + # Remove trailing slashes. + case $ac_val in + */ ) + ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` + eval $ac_var=\$ac_val;; + esac + # Be sure to have absolute directory names. + case $ac_val in + [\\/$]* | ?:[\\/]* ) continue;; + NONE | '' ) case $ac_var in *prefix ) continue;; esac;; + esac + as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" +done + +# There might be people who depend on the old broken behavior: `$host' +# used to hold the argument of --host etc. +# FIXME: To remove some day. +build=$build_alias +host=$host_alias +target=$target_alias + +# FIXME: To remove some day. +if test "x$host_alias" != x; then + if test "x$build_alias" = x; then + cross_compiling=maybe + elif test "x$build_alias" != "x$host_alias"; then + cross_compiling=yes + fi +fi + +ac_tool_prefix= +test -n "$host_alias" && ac_tool_prefix=$host_alias- + +test "$silent" = yes && exec 6>/dev/null + + +ac_pwd=`pwd` && test -n "$ac_pwd" && +ac_ls_di=`ls -di .` && +ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || + as_fn_error $? "working directory cannot be determined" +test "X$ac_ls_di" = "X$ac_pwd_ls_di" || + as_fn_error $? "pwd does not report name of working directory" + + +# Find the source files, if location was not specified. +if test -z "$srcdir"; then + ac_srcdir_defaulted=yes + # Try the directory containing this script, then the parent directory. + ac_confdir=`$as_dirname -- "$as_myself" || +$as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_myself" : 'X\(//\)[^/]' \| \ + X"$as_myself" : 'X\(//\)$' \| \ + X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X"$as_myself" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + srcdir=$ac_confdir + if test ! -r "$srcdir/$ac_unique_file"; then + srcdir=.. + fi +else + ac_srcdir_defaulted=no +fi +if test ! -r "$srcdir/$ac_unique_file"; then + test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." + as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" +fi +ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" +ac_abs_confdir=`( + cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" + pwd)` +# When building in place, set srcdir=. +if test "$ac_abs_confdir" = "$ac_pwd"; then + srcdir=. +fi +# Remove unnecessary trailing slashes from srcdir. +# Double slashes in file names in object file debugging info +# mess up M-x gdb in Emacs. +case $srcdir in +*/) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; +esac +for ac_var in $ac_precious_vars; do + eval ac_env_${ac_var}_set=\${${ac_var}+set} + eval ac_env_${ac_var}_value=\$${ac_var} + eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} + eval ac_cv_env_${ac_var}_value=\$${ac_var} +done + +# +# Report the --help message. +# +if test "$ac_init_help" = "long"; then + # Omit some internal or obsolete options to make the list less imposing. + # This message is too long to be a string in the A/UX 3.1 sh. + cat <<_ACEOF +\`configure' configures this package to adapt to many kinds of systems. + +Usage: $0 [OPTION]... [VAR=VALUE]... + +To assign environment variables (e.g., CC, CFLAGS...), specify them as +VAR=VALUE. See below for descriptions of some of the useful variables. + +Defaults for the options are specified in brackets. + +Configuration: + -h, --help display this help and exit + --help=short display options specific to this package + --help=recursive display the short help of all the included packages + -V, --version display version information and exit + -q, --quiet, --silent do not print \`checking ...' messages + --cache-file=FILE cache test results in FILE [disabled] + -C, --config-cache alias for \`--cache-file=config.cache' + -n, --no-create do not create output files + --srcdir=DIR find the sources in DIR [configure dir or \`..'] + +Installation directories: + --prefix=PREFIX install architecture-independent files in PREFIX + [$ac_default_prefix] + --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX + [PREFIX] + +By default, \`make install' will install all the files in +\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify +an installation prefix other than \`$ac_default_prefix' using \`--prefix', +for instance \`--prefix=\$HOME'. + +For better control, use the options below. + +Fine tuning of the installation directories: + --bindir=DIR user executables [EPREFIX/bin] + --sbindir=DIR system admin executables [EPREFIX/sbin] + --libexecdir=DIR program executables [EPREFIX/libexec] + --sysconfdir=DIR read-only single-machine data [PREFIX/etc] + --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] + --localstatedir=DIR modifiable single-machine data [PREFIX/var] + --libdir=DIR object code libraries [EPREFIX/lib] + --includedir=DIR C header files [PREFIX/include] + --oldincludedir=DIR C header files for non-gcc [/usr/include] + --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] + --datadir=DIR read-only architecture-independent data [DATAROOTDIR] + --infodir=DIR info documentation [DATAROOTDIR/info] + --localedir=DIR locale-dependent data [DATAROOTDIR/locale] + --mandir=DIR man documentation [DATAROOTDIR/man] + --docdir=DIR documentation root [DATAROOTDIR/doc/PACKAGE] + --htmldir=DIR html documentation [DOCDIR] + --dvidir=DIR dvi documentation [DOCDIR] + --pdfdir=DIR pdf documentation [DOCDIR] + --psdir=DIR ps documentation [DOCDIR] +_ACEOF + + cat <<\_ACEOF + +X features: + --x-includes=DIR X include files are in DIR + --x-libraries=DIR X library files are in DIR + +System types: + --build=BUILD configure for building on BUILD [guessed] + --host=HOST cross-compile to build programs to run on HOST [BUILD] +_ACEOF +fi + +if test -n "$ac_init_help"; then + + cat <<\_ACEOF + +Optional Features: + --disable-option-checking ignore unrecognized --enable/--with options + --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) + --enable-FEATURE[=ARG] include FEATURE [ARG=yes] +use a three word cons with simplified typing +protect cdr from immfix and speed up type processing +debug safecdr code +--enable-prelink will insist that the produced images may be prelinked +--enable-fastimmfix=XXXX will reject low immediate fixnums unless 1< if you have libraries in a + nonstandard directory + LIBS libraries to pass to the linker, e.g. -l + CPPFLAGS (Objective) C/C++ preprocessor flags, e.g. -I if + you have headers in a nonstandard directory + CPP C preprocessor + XMKMF Path to xmkmf, Makefile generator for X Window System + +Use these variables to override the choices made by `configure' or to help +it to find libraries and programs with nonstandard names/locations. + +Report bugs to the package provider. +_ACEOF +ac_status=$? +fi + +if test "$ac_init_help" = "recursive"; then + # If there are subdirs, report their specific --help. + for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue + test -d "$ac_dir" || + { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } || + continue + ac_builddir=. + +case "$ac_dir" in +.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; +*) + ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` + # A ".." for each directory in $ac_dir_suffix. + ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` + case $ac_top_builddir_sub in + "") ac_top_builddir_sub=. ac_top_build_prefix= ;; + *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; + esac ;; +esac +ac_abs_top_builddir=$ac_pwd +ac_abs_builddir=$ac_pwd$ac_dir_suffix +# for backward compatibility: +ac_top_builddir=$ac_top_build_prefix + +case $srcdir in + .) # We are building in place. + ac_srcdir=. + ac_top_srcdir=$ac_top_builddir_sub + ac_abs_top_srcdir=$ac_pwd ;; + [\\/]* | ?:[\\/]* ) # Absolute name. + ac_srcdir=$srcdir$ac_dir_suffix; + ac_top_srcdir=$srcdir + ac_abs_top_srcdir=$srcdir ;; + *) # Relative name. + ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix + ac_top_srcdir=$ac_top_build_prefix$srcdir + ac_abs_top_srcdir=$ac_pwd/$srcdir ;; +esac +ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix + + cd "$ac_dir" || { ac_status=$?; continue; } + # Check for guested configure. + if test -f "$ac_srcdir/configure.gnu"; then + echo && + $SHELL "$ac_srcdir/configure.gnu" --help=recursive + elif test -f "$ac_srcdir/configure"; then + echo && + $SHELL "$ac_srcdir/configure" --help=recursive + else + $as_echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 + fi || ac_status=$? + cd "$ac_pwd" || { ac_status=$?; break; } + done +fi + +test -n "$ac_init_help" && exit $ac_status +if $ac_init_version; then + cat <<\_ACEOF +configure +generated by GNU Autoconf 2.69 + +Copyright (C) 2012 Free Software Foundation, Inc. +This configure script is free software; the Free Software Foundation +gives unlimited permission to copy, distribute and modify it. +_ACEOF + exit +fi + +## ------------------------ ## +## Autoconf initialization. ## +## ------------------------ ## + +# ac_fn_c_try_compile LINENO +# -------------------------- +# Try to compile conftest.$ac_ext, and return whether this succeeded. +ac_fn_c_try_compile () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + rm -f conftest.$ac_objext + if { { ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_compile") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + grep -v '^ *+' conftest.err >conftest.er1 + cat conftest.er1 >&5 + mv -f conftest.er1 conftest.err + fi + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest.$ac_objext; then : + ac_retval=0 +else + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=1 +fi + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + +} # ac_fn_c_try_compile + +# ac_fn_c_try_cpp LINENO +# ---------------------- +# Try to preprocess conftest.$ac_ext, and return whether this succeeded. +ac_fn_c_try_cpp () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + if { { ac_try="$ac_cpp conftest.$ac_ext" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_cpp conftest.$ac_ext") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + grep -v '^ *+' conftest.err >conftest.er1 + cat conftest.er1 >&5 + mv -f conftest.er1 conftest.err + fi + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } > conftest.i && { + test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || + test ! -s conftest.err + }; then : + ac_retval=0 +else + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=1 +fi + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + +} # ac_fn_c_try_cpp + +# ac_fn_c_try_run LINENO +# ---------------------- +# Try to link conftest.$ac_ext, and return whether this succeeded. Assumes +# that executables *can* be run. +ac_fn_c_try_run () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + if { { ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_link") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } && { ac_try='./conftest$ac_exeext' + { { case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_try") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; }; then : + ac_retval=0 +else + $as_echo "$as_me: program exited with status $ac_status" >&5 + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=$ac_status +fi + rm -rf conftest.dSYM conftest_ipa8_conftest.oo + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + +} # ac_fn_c_try_run + +# ac_fn_c_check_header_mongrel LINENO HEADER VAR INCLUDES +# ------------------------------------------------------- +# Tests whether HEADER exists, giving a warning if it cannot be compiled using +# the include files in INCLUDES and setting the cache variable VAR +# accordingly. +ac_fn_c_check_header_mongrel () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + if eval \${$3+:} false; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 +$as_echo_n "checking for $2... " >&6; } +if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 +fi +eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +$as_echo "$ac_res" >&6; } +else + # Is the header compilable? +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 usability" >&5 +$as_echo_n "checking $2 usability... " >&6; } +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +#include <$2> +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_header_compiler=yes +else + ac_header_compiler=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_compiler" >&5 +$as_echo "$ac_header_compiler" >&6; } + +# Is the header present? +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 presence" >&5 +$as_echo_n "checking $2 presence... " >&6; } +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include <$2> +_ACEOF +if ac_fn_c_try_cpp "$LINENO"; then : + ac_header_preproc=yes +else + ac_header_preproc=no +fi +rm -f conftest.err conftest.i conftest.$ac_ext +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_preproc" >&5 +$as_echo "$ac_header_preproc" >&6; } + +# So? What about this header? +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in #(( + yes:no: ) + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&5 +$as_echo "$as_me: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5 +$as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;} + ;; + no:yes:* ) + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: present but cannot be compiled" >&5 +$as_echo "$as_me: WARNING: $2: present but cannot be compiled" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: check for missing prerequisite headers?" >&5 +$as_echo "$as_me: WARNING: $2: check for missing prerequisite headers?" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: see the Autoconf documentation" >&5 +$as_echo "$as_me: WARNING: $2: see the Autoconf documentation" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&5 +$as_echo "$as_me: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5 +$as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;} + ;; +esac + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 +$as_echo_n "checking for $2... " >&6; } +if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 +else + eval "$3=\$ac_header_compiler" +fi +eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +$as_echo "$ac_res" >&6; } +fi + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + +} # ac_fn_c_check_header_mongrel + +# ac_fn_c_check_header_compile LINENO HEADER VAR INCLUDES +# ------------------------------------------------------- +# Tests whether HEADER exists and can be compiled using the include files in +# INCLUDES, setting the cache variable VAR accordingly. +ac_fn_c_check_header_compile () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 +$as_echo_n "checking for $2... " >&6; } +if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +#include <$2> +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + eval "$3=yes" +else + eval "$3=no" +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +$as_echo "$ac_res" >&6; } + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + +} # ac_fn_c_check_header_compile + +# ac_fn_c_check_member LINENO AGGR MEMBER VAR INCLUDES +# ---------------------------------------------------- +# Tries to find if the field MEMBER exists in type AGGR, after including +# INCLUDES, setting cache variable VAR accordingly. +ac_fn_c_check_member () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2.$3" >&5 +$as_echo_n "checking for $2.$3... " >&6; } +if eval \${$4+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$5 +int +main () +{ +static $2 ac_aggr; +if (ac_aggr.$3) +return 0; + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + eval "$4=yes" +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$5 +int +main () +{ +static $2 ac_aggr; +if (sizeof ac_aggr.$3) +return 0; + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + eval "$4=yes" +else + eval "$4=no" +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +eval ac_res=\$$4 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +$as_echo "$ac_res" >&6; } + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + +} # ac_fn_c_check_member + +# ac_fn_c_check_func LINENO FUNC VAR +# ---------------------------------- +# Tests whether FUNC exists, setting the cache variable VAR accordingly +ac_fn_c_check_func () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 +$as_echo_n "checking for $2... " >&6; } +if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +/* Define $2 to an innocuous variant, in case declares $2. + For example, HP-UX 11i declares gettimeofday. */ +#define $2 innocuous_$2 + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char $2 (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef $2 + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char $2 (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined __stub_$2 || defined __stub___$2 +choke me +#endif + +int +main () +{ +return $2 (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + eval "$3=yes" +else + eval "$3=no" +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +$as_echo "$ac_res" >&6; } + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + +} # ac_fn_c_check_func + +# ac_fn_c_compute_int LINENO EXPR VAR INCLUDES +# -------------------------------------------- +# Tries to find the compile-time value of EXPR in a program that includes +# INCLUDES, setting VAR accordingly. Returns whether the value could be +# computed +ac_fn_c_compute_int () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + if test "$cross_compiling" = yes; then + # Depending upon the size, compute the lo and hi bounds. +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +int +main () +{ +static int test_array [1 - 2 * !(($2) >= 0)]; +test_array [0] = 0; +return test_array [0]; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_lo=0 ac_mid=0 + while :; do + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +int +main () +{ +static int test_array [1 - 2 * !(($2) <= $ac_mid)]; +test_array [0] = 0; +return test_array [0]; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_hi=$ac_mid; break +else + as_fn_arith $ac_mid + 1 && ac_lo=$as_val + if test $ac_lo -le $ac_mid; then + ac_lo= ac_hi= + break + fi + as_fn_arith 2 '*' $ac_mid + 1 && ac_mid=$as_val +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + done +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +int +main () +{ +static int test_array [1 - 2 * !(($2) < 0)]; +test_array [0] = 0; +return test_array [0]; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_hi=-1 ac_mid=-1 + while :; do + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +int +main () +{ +static int test_array [1 - 2 * !(($2) >= $ac_mid)]; +test_array [0] = 0; +return test_array [0]; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_lo=$ac_mid; break +else + as_fn_arith '(' $ac_mid ')' - 1 && ac_hi=$as_val + if test $ac_mid -le $ac_hi; then + ac_lo= ac_hi= + break + fi + as_fn_arith 2 '*' $ac_mid && ac_mid=$as_val +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + done +else + ac_lo= ac_hi= +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +# Binary search between lo and hi bounds. +while test "x$ac_lo" != "x$ac_hi"; do + as_fn_arith '(' $ac_hi - $ac_lo ')' / 2 + $ac_lo && ac_mid=$as_val + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +int +main () +{ +static int test_array [1 - 2 * !(($2) <= $ac_mid)]; +test_array [0] = 0; +return test_array [0]; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_hi=$ac_mid +else + as_fn_arith '(' $ac_mid ')' + 1 && ac_lo=$as_val +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +done +case $ac_lo in #(( +?*) eval "$3=\$ac_lo"; ac_retval=0 ;; +'') ac_retval=1 ;; +esac + else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +static long int longval () { return $2; } +static unsigned long int ulongval () { return $2; } +#include +#include +int +main () +{ + + FILE *f = fopen ("conftest.val", "w"); + if (! f) + return 1; + if (($2) < 0) + { + long int i = longval (); + if (i != ($2)) + return 1; + fprintf (f, "%ld", i); + } + else + { + unsigned long int i = ulongval (); + if (i != ($2)) + return 1; + fprintf (f, "%lu", i); + } + /* Do not output a trailing newline, as this causes \r\n confusion + on some platforms. */ + return ferror (f) || fclose (f) != 0; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + echo >>conftest.val; read $3 &5 +$as_echo_n "checking for $2... " >&6; } +if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 +else + eval "$3=no" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +int +main () +{ +if (sizeof ($2)) + return 0; + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +int +main () +{ +if (sizeof (($2))) + return 0; + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + +else + eval "$3=yes" +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +$as_echo "$ac_res" >&6; } + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + +} # ac_fn_c_check_type +cat >config.log <<_ACEOF +This file contains any messages produced by compilers while +running configure, to aid debugging if configure makes a mistake. + +It was created by $as_me, which was +generated by GNU Autoconf 2.69. Invocation command line was + + $ $0 $@ + +_ACEOF +exec 5>>config.log +{ +cat <<_ASUNAME +## --------- ## +## Platform. ## +## --------- ## + +hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` +uname -m = `(uname -m) 2>/dev/null || echo unknown` +uname -r = `(uname -r) 2>/dev/null || echo unknown` +uname -s = `(uname -s) 2>/dev/null || echo unknown` +uname -v = `(uname -v) 2>/dev/null || echo unknown` + +/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` +/bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` + +/bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` +/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` +/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` +/usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` +/bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` +/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` +/bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` + +_ASUNAME + +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + $as_echo "PATH: $as_dir" + done +IFS=$as_save_IFS + +} >&5 + +cat >&5 <<_ACEOF + + +## ----------- ## +## Core tests. ## +## ----------- ## + +_ACEOF + + +# Keep a trace of the command line. +# Strip out --no-create and --no-recursion so they do not pile up. +# Strip out --silent because we don't want to record it for future runs. +# Also quote any args containing shell meta-characters. +# Make two passes to allow for proper duplicate-argument suppression. +ac_configure_args= +ac_configure_args0= +ac_configure_args1= +ac_must_keep_next=false +for ac_pass in 1 2 +do + for ac_arg + do + case $ac_arg in + -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + continue ;; + *\'*) + ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; + esac + case $ac_pass in + 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; + 2) + as_fn_append ac_configure_args1 " '$ac_arg'" + if test $ac_must_keep_next = true; then + ac_must_keep_next=false # Got value, back to normal. + else + case $ac_arg in + *=* | --config-cache | -C | -disable-* | --disable-* \ + | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ + | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ + | -with-* | --with-* | -without-* | --without-* | --x) + case "$ac_configure_args0 " in + "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; + esac + ;; + -* ) ac_must_keep_next=true ;; + esac + fi + as_fn_append ac_configure_args " '$ac_arg'" + ;; + esac + done +done +{ ac_configure_args0=; unset ac_configure_args0;} +{ ac_configure_args1=; unset ac_configure_args1;} + +# When interrupted or exit'd, cleanup temporary files, and complete +# config.log. We remove comments because anyway the quotes in there +# would cause problems or look ugly. +# WARNING: Use '\'' to represent an apostrophe within the trap. +# WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. +trap 'exit_status=$? + # Save into config.log some information that might help in debugging. + { + echo + + $as_echo "## ---------------- ## +## Cache variables. ## +## ---------------- ##" + echo + # The following way of writing the cache mishandles newlines in values, +( + for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do + eval ac_val=\$$ac_var + case $ac_val in #( + *${as_nl}*) + case $ac_var in #( + *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 +$as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; + esac + case $ac_var in #( + _ | IFS | as_nl) ;; #( + BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( + *) { eval $ac_var=; unset $ac_var;} ;; + esac ;; + esac + done + (set) 2>&1 | + case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( + *${as_nl}ac_space=\ *) + sed -n \ + "s/'\''/'\''\\\\'\'''\''/g; + s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" + ;; #( + *) + sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" + ;; + esac | + sort +) + echo + + $as_echo "## ----------------- ## +## Output variables. ## +## ----------------- ##" + echo + for ac_var in $ac_subst_vars + do + eval ac_val=\$$ac_var + case $ac_val in + *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; + esac + $as_echo "$ac_var='\''$ac_val'\''" + done | sort + echo + + if test -n "$ac_subst_files"; then + $as_echo "## ------------------- ## +## File substitutions. ## +## ------------------- ##" + echo + for ac_var in $ac_subst_files + do + eval ac_val=\$$ac_var + case $ac_val in + *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; + esac + $as_echo "$ac_var='\''$ac_val'\''" + done | sort + echo + fi + + if test -s confdefs.h; then + $as_echo "## ----------- ## +## confdefs.h. ## +## ----------- ##" + echo + cat confdefs.h + echo + fi + test "$ac_signal" != 0 && + $as_echo "$as_me: caught signal $ac_signal" + $as_echo "$as_me: exit $exit_status" + } >&5 + rm -f core *.core core.conftest.* && + rm -f -r conftest* confdefs* conf$$* $ac_clean_files && + exit $exit_status +' 0 +for ac_signal in 1 2 13 15; do + trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal +done +ac_signal=0 + +# confdefs.h avoids OS command line length limits that DEFS can exceed. +rm -f -r conftest* confdefs.h + +$as_echo "/* confdefs.h */" > confdefs.h + +# Predefined preprocessor variables. + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_NAME "$PACKAGE_NAME" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_TARNAME "$PACKAGE_TARNAME" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_VERSION "$PACKAGE_VERSION" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_STRING "$PACKAGE_STRING" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_URL "$PACKAGE_URL" +_ACEOF + + +# Let the site file select an alternate cache file if it wants to. +# Prefer an explicitly selected file to automatically selected ones. +ac_site_file1=NONE +ac_site_file2=NONE +if test -n "$CONFIG_SITE"; then + # We do not want a PATH search for config.site. + case $CONFIG_SITE in #(( + -*) ac_site_file1=./$CONFIG_SITE;; + */*) ac_site_file1=$CONFIG_SITE;; + *) ac_site_file1=./$CONFIG_SITE;; + esac +elif test "x$prefix" != xNONE; then + ac_site_file1=$prefix/share/config.site + ac_site_file2=$prefix/etc/config.site +else + ac_site_file1=$ac_default_prefix/share/config.site + ac_site_file2=$ac_default_prefix/etc/config.site +fi +for ac_site_file in "$ac_site_file1" "$ac_site_file2" +do + test "x$ac_site_file" = xNONE && continue + if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 +$as_echo "$as_me: loading site script $ac_site_file" >&6;} + sed 's/^/| /' "$ac_site_file" >&5 + . "$ac_site_file" \ + || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "failed to load site script $ac_site_file +See \`config.log' for more details" "$LINENO" 5; } + fi +done + +if test -r "$cache_file"; then + # Some versions of bash will fail to source /dev/null (special files + # actually), so we avoid doing that. DJGPP emulates it as a regular file. + if test /dev/null != "$cache_file" && test -f "$cache_file"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 +$as_echo "$as_me: loading cache $cache_file" >&6;} + case $cache_file in + [\\/]* | ?:[\\/]* ) . "$cache_file";; + *) . "./$cache_file";; + esac + fi +else + { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 +$as_echo "$as_me: creating cache $cache_file" >&6;} + >$cache_file +fi + +# Check that the precious variables saved in the cache have kept the same +# value. +ac_cache_corrupted=false +for ac_var in $ac_precious_vars; do + eval ac_old_set=\$ac_cv_env_${ac_var}_set + eval ac_new_set=\$ac_env_${ac_var}_set + eval ac_old_val=\$ac_cv_env_${ac_var}_value + eval ac_new_val=\$ac_env_${ac_var}_value + case $ac_old_set,$ac_new_set in + set,) + { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 +$as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} + ac_cache_corrupted=: ;; + ,set) + { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 +$as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} + ac_cache_corrupted=: ;; + ,);; + *) + if test "x$ac_old_val" != "x$ac_new_val"; then + # differences in whitespace do not lead to failure. + ac_old_val_w=`echo x $ac_old_val` + ac_new_val_w=`echo x $ac_new_val` + if test "$ac_old_val_w" != "$ac_new_val_w"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 +$as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} + ac_cache_corrupted=: + else + { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 +$as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} + eval $ac_var=\$ac_old_val + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 +$as_echo "$as_me: former value: \`$ac_old_val'" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 +$as_echo "$as_me: current value: \`$ac_new_val'" >&2;} + fi;; + esac + # Pass precious variables to config.status. + if test "$ac_new_set" = set; then + case $ac_new_val in + *\'*) ac_arg=$ac_var=`$as_echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; + *) ac_arg=$ac_var=$ac_new_val ;; + esac + case " $ac_configure_args " in + *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. + *) as_fn_append ac_configure_args " '$ac_arg'" ;; + esac + fi +done +if $ac_cache_corrupted; then + { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 +$as_echo "$as_me: error: changes in the environment can compromise the build" >&2;} + as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 +fi +## -------------------- ## +## Main body of script. ## +## -------------------- ## + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + + +ac_config_headers="$ac_config_headers h/gclincl.h" + + +VERSION=`cat majvers`.`cat minvers` + + +# some parts of this configure script are taken from the tcl configure.in + +# +# Arguments +# + + + + +# Check whether --enable-widecons was given. +if test "${enable_widecons+set}" = set; then : + enableval=$enable_widecons; +$as_echo "#define WIDE_CONS 1" >>confdefs.h + +fi + + + +# Check whether --enable-safecdr was given. +if test "${enable_safecdr+set}" = set; then : + enableval=$enable_safecdr; +else + enable_safecdr="no" +fi + +if test "$enable_safecdr" = "yes" ; then + +$as_echo "#define USE_SAFE_CDR 1" >>confdefs.h + +fi +# Check whether --enable-safecdrdbg was given. +if test "${enable_safecdrdbg+set}" = set; then : + enableval=$enable_safecdrdbg; +$as_echo "#define DEBUG_SAFE_CDR 1" >>confdefs.h + +fi + + +# Check whether --enable-prelink was given. +if test "${enable_prelink+set}" = set; then : + enableval=$enable_prelink; PRELINK_CHECK=t +else + PRELINK_CHECK= +fi + + +# Check whether --enable-fastimmfix was given. +if test "${enable_fastimmfix+set}" = set; then : + enableval=$enable_fastimmfix; +else + enable_fastimmfix=64 +fi + + + +# Check whether --enable-holepage was given. +if test "${enable_holepage+set}" = set; then : + enableval=$enable_holepage; +cat >>confdefs.h <<_ACEOF +#define HOLEPAGE $enable_holepage +_ACEOF + +fi + + +# Check whether --enable-vssize was given. +if test "${enable_vssize+set}" = set; then : + enableval=$enable_vssize; +else + enable_vssize=262144 +fi + + +cat >>confdefs.h <<_ACEOF +#define VSSIZE $enable_vssize +_ACEOF + + +# Check whether --enable-bdssize was given. +if test "${enable_bdssize+set}" = set; then : + enableval=$enable_bdssize; +else + enable_bdssize=2048 +fi + + +cat >>confdefs.h <<_ACEOF +#define BDSSIZE $enable_bdssize +_ACEOF + + +# Check whether --enable-ihssize was given. +if test "${enable_ihssize+set}" = set; then : + enableval=$enable_ihssize; +else + enable_ihssize=4096 +fi + + +cat >>confdefs.h <<_ACEOF +#define IHSSIZE $enable_ihssize +_ACEOF + + +# Check whether --enable-frssize was given. +if test "${enable_frssize+set}" = set; then : + enableval=$enable_frssize; +else + enable_frssize=4096 +fi + + +cat >>confdefs.h <<_ACEOF +#define FRSSIZE $enable_frssize +_ACEOF + + +# Check whether --enable-machine was given. +if test "${enable_machine+set}" = set; then : + enableval=$enable_machine; enable_machine=$enableval +else + enable_machine="" +fi + + +# Check whether --enable-immfix was given. +if test "${enable_immfix+set}" = set; then : + enableval=$enable_immfix; +else + enable_immfix=yes +fi + + +#AC_ARG_ENABLE(gmp,[ --enable-gmp=no will disable use of GMP gnu multiprecision arithmetic, (default is =yes)] , +#[use_gmp=$enableval],[use_gmp="yes"]) + +use_gmp="yes" + +# Check whether --enable-notify was given. +if test "${enable_notify+set}" = set; then : + enableval=$enable_notify; enable_notify=$enableval +else + enable_notify="yes" +fi + + +# Check whether --enable-tcltk was given. +if test "${enable_tcltk+set}" = set; then : + enableval=$enable_tcltk; enable_tcltk=$enableval +else + enable_tcltk="yes" +fi + + +# Check whether --enable-tkconfig was given. +if test "${enable_tkconfig+set}" = set; then : + enableval=$enable_tkconfig; TK_CONFIG_PREFIX=$enableval +else + TK_CONFIG_PREFIX="unknown" +fi + + + +# Check whether --enable-tclconfig was given. +if test "${enable_tclconfig+set}" = set; then : + enableval=$enable_tclconfig; TCL_CONFIG_PREFIX=$enableval +else + TCL_CONFIG_PREFIX="unknown" +fi + + +# Check whether --enable-infodir was given. +if test "${enable_infodir+set}" = set; then : + enableval=$enable_infodir; INFO_DIR=$enableval +else + INFO_DIR=$prefix/share/info +fi + +INFO_DIR=`eval echo $INFO_DIR/` + +# Check whether --enable-emacsdir was given. +if test "${enable_emacsdir+set}" = set; then : + enableval=$enable_emacsdir; EMACS_SITE_LISP=$enableval +else + EMACS_SITE_LISP=$prefix/share/emacs/site-lisp +fi + +EMACS_SITE_LISP=`eval echo $EMACS_SITE_LISP/` + +# Check whether --enable-common-binary was given. +if test "${enable_common_binary+set}" = set; then : + enableval=$enable_common_binary; use_common_binary=$enableval +else + use_common_binary="yes" +fi + + +# Check whether --enable-japi was given. +if test "${enable_japi+set}" = set; then : + enableval=$enable_japi; try_japi=$enableval +else + try_japi="no" +fi + + +# Check whether --enable-xdr was given. +if test "${enable_xdr+set}" = set; then : + enableval=$enable_xdr; enable_xdr=$enableval +else + enable_xdr="yes" +fi + + +# Check whether --enable-xgcl was given. +if test "${enable_xgcl+set}" = set; then : + enableval=$enable_xgcl; enable_xgcl=$enableval +else + enable_xgcl="yes" +fi + + +# +# Host information +# + + +ac_aux_dir= +for ac_dir in "$srcdir" "$srcdir/.." "$srcdir/../.."; do + if test -f "$ac_dir/install-sh"; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/install-sh -c" + break + elif test -f "$ac_dir/install.sh"; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/install.sh -c" + break + elif test -f "$ac_dir/shtool"; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/shtool install -c" + break + fi +done +if test -z "$ac_aux_dir"; then + as_fn_error $? "cannot find install-sh, install.sh, or shtool in \"$srcdir\" \"$srcdir/..\" \"$srcdir/../..\"" "$LINENO" 5 +fi + +# These three variables are undocumented and unsupported, +# and are intended to be withdrawn in a future Autoconf release. +# They can cause serious problems if a builder's source tree is in a directory +# whose full name contains unusual characters. +ac_config_guess="$SHELL $ac_aux_dir/config.guess" # Please don't use this var. +ac_config_sub="$SHELL $ac_aux_dir/config.sub" # Please don't use this var. +ac_configure="$SHELL $ac_aux_dir/configure" # Please don't use this var. + + +# Make sure we can run config.sub. +$SHELL "$ac_aux_dir/config.sub" sun4 >/dev/null 2>&1 || + as_fn_error $? "cannot run $SHELL $ac_aux_dir/config.sub" "$LINENO" 5 + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking build system type" >&5 +$as_echo_n "checking build system type... " >&6; } +if ${ac_cv_build+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_build_alias=$build_alias +test "x$ac_build_alias" = x && + ac_build_alias=`$SHELL "$ac_aux_dir/config.guess"` +test "x$ac_build_alias" = x && + as_fn_error $? "cannot guess build type; you must specify one" "$LINENO" 5 +ac_cv_build=`$SHELL "$ac_aux_dir/config.sub" $ac_build_alias` || + as_fn_error $? "$SHELL $ac_aux_dir/config.sub $ac_build_alias failed" "$LINENO" 5 + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_build" >&5 +$as_echo "$ac_cv_build" >&6; } +case $ac_cv_build in +*-*-*) ;; +*) as_fn_error $? "invalid value of canonical build" "$LINENO" 5;; +esac +build=$ac_cv_build +ac_save_IFS=$IFS; IFS='-' +set x $ac_cv_build +shift +build_cpu=$1 +build_vendor=$2 +shift; shift +# Remember, the first character of IFS is used to create $*, +# except with old shells: +build_os=$* +IFS=$ac_save_IFS +case $build_os in *\ *) build_os=`echo "$build_os" | sed 's/ /-/g'`;; esac + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking host system type" >&5 +$as_echo_n "checking host system type... " >&6; } +if ${ac_cv_host+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test "x$host_alias" = x; then + ac_cv_host=$ac_cv_build +else + ac_cv_host=`$SHELL "$ac_aux_dir/config.sub" $host_alias` || + as_fn_error $? "$SHELL $ac_aux_dir/config.sub $host_alias failed" "$LINENO" 5 +fi + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_host" >&5 +$as_echo "$ac_cv_host" >&6; } +case $ac_cv_host in +*-*-*) ;; +*) as_fn_error $? "invalid value of canonical host" "$LINENO" 5;; +esac +host=$ac_cv_host +ac_save_IFS=$IFS; IFS='-' +set x $ac_cv_host +shift +host_cpu=$1 +host_vendor=$2 +shift; shift +# Remember, the first character of IFS is used to create $*, +# except with old shells: +host_os=$* +IFS=$ac_save_IFS +case $host_os in *\ *) host_os=`echo "$host_os" | sed 's/ /-/g'`;; esac + + +canonical=$host +my_host_kernel=`echo $host_os | awk '{j=split($1,A,"-");print A[1]}'` +my_host_system=`echo $host_os | awk '{j=split($1,A,"-");if (j>=2) print A[2]}'` + +cat >>confdefs.h <<_ACEOF +#define HOST_CPU "`echo $host_cpu | awk '{print toupper($0)}'`" +_ACEOF + + +cat >>confdefs.h <<_ACEOF +#define HOST_KERNEL "`echo $my_host_kernel | awk '{print toupper($0)}'`" +_ACEOF + +if test "$my_host_system" != "" ; then + +cat >>confdefs.h <<_ACEOF +#define HOST_SYSTEM "`echo $my_host_system | awk '{print toupper($0)}'`" +_ACEOF + +fi +## host=CPU-COMPANY-SYSTEM +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: host=$host" >&5 +$as_echo "host=$host" >&6; } + +PROCESSOR_FLAGS=${PROCESSOR_FLAGS:-""} + +use=unknown +TLDFLAGS="" +case $canonical in + older) + use=386-bsd;; + + sh4*linux*) + use=sh4-linux;; + + *x86_64*linux*) + use=amd64-linux;; + + *x86_64*kfreebsd*) + use=amd64-kfreebsd;; + + *86*linux*) + use=386-linux;; + + *86*kfreebsd*) + use=386-kfreebsd;; + + *86*gnu*) + use=386-gnu;; + +# m6800 not working with gcc-3.2 + m68k*linux*) + if test "$use_common_binary" = "yes"; then + host=m68020-unknown-linux-gnu + echo "The host is canonicalised to $host" + fi + use=m68k-linux;; + + alpha*linux*) + use=alpha-linux;; + + mips*linux*) + use=mips-linux;; + + mipsel*linux*) + use=mipsel-linux;; + + sparc*linux*) + use=sparc-linux;; + + aarch64*linux*) + use=aarch64-linux;; + + arm*linux*) + use=arm-linux;; + + s390*linux*) + use=s390-linux;; + + ia64*linux*) + use=ia64-linux;; + + hppa*linux*) + use=hppa-linux;; + + powerpc*linux*) + use=powerpc-linux;; + + powerpc-*-darwin*) + use=powerpc-macosx;; + + *86*darwin*) + use=386-macosx + if test "$build_cpu" = "x86_64" ; then + CFLAGS="-m64 $CFLAGS"; + LDFLAGS="-m64 -Wl,-headerpad,72 $LDFLAGS"; + else + CFLAGS="-m32 $CFLAGS"; + LDFLAGS="-m32 -Wl,-headerpad,56 $LDFLAGS"; + fi;; + + alpha-dec-osf) + use=alpha-osf1;; + + mips-dec-ultrix) + use=dec3100;; + + old) + use=dos-go32;; + + *86*-freebsd*) + use=FreeBSD;; + + hp3*-*hpux*) + use=hp300;; + + hp3*-*-*bsd*) + use=hp300-bsd;; + + hppa*-*hpux*) + use=hp800;; + + mips-sgi-irix) + case $system in + IRIX5*) + use=irix5;; + IRIX6*) + use=irix6;; + IRIX3*) + use=sgi4d;; + esac ;; + + + m68k-apple-aux*) + use=mac2;; + + old) + use=mp386;; + + *86-ncr-sysv4) + use=ncr;; + + *3-986-*netbsd*) + use=NetBSD;; + + old) + use=NeXT;; + + old) + use=NeXT30-m68k;; + + *86-*nextstep*) + use=NeXT32-i386;; + + *m68*-*nextstep*) + use=NeXT32-m68k;; + + *rs6000-*-aix4*) + use=rios;; + + *rs6000-*-aix3*) + use=rios-aix3;; + + old) + use=rt_aix;; + + old) + use=sgi;; + + sparc-sun-solaris*) + use=solaris;; + + i?86-pc-solaris*) + use=solaris-i386;; + + old) + use=sun2r3;; + + old) + use=sun3;; + + m68*-sunos*) + use=sun3-os4;; + + old) + use=sun386i;; + + sparc*sunos*) + use=sun4;; + + *86-sequent-dynix) + use=symmetry;; + + u370*aix) + use=u370_aix;; + + old) + use=vax;; + + i*mingw*) + if test "$use_common_binary" = "yes"; then + host=i386-pc-mingw32 + PROCESSOR_FLAGS="-march=i386 " + echo "The host is canonicalised to $host" + fi + use=mingw;; + + i*cygwin*) + if $CC -v 2>&1 | fgrep ming > /dev/null ; + then use=mingw + else use=gnuwin95 + fi;; + + *openbsd*) + # 'ld -Z' means disable W^X + TLDFLAGS="$TLDFLAGS -Z" + use=FreeBSD;; + +esac + + + +echo enable_machine=$enable_machine +if test "x$enable_machine" != "x" ; then + use=$enable_machine +fi + +def_dlopen="no" +def_statsysbfd="no" +def_custreloc="yes" +#def_statsysbfd="yes" +#def_custreloc="no" +def_locbfd="no" +def_oldgmp="no" +def_pic="no"; +def_static="no"; +def_debug="no"; +case $use in + *kfreebsd) + ln -snf linux.defs h/$use.defs;; + *gnu) + ln -snf linux.defs h/$use.defs;; + *linux) + ln -snf linux.defs h/$use.defs; + case $use in +# def_static -- Function descriptors are currently realized at runtime in a non-reproducible fashion +# on these architectures -- CM + powerpc*) +# if test "$host_cpu" = "powerpc64" ; then def_dlopen="yes" ; def_custreloc="no" ; fi + ;; + ia64*) + def_dlopen="yes" ; def_custreloc="no" ;; + hppa*) + def_pic="yes" ;; +# def_dlopen="yes" ; def_custreloc="no" ; def_pic="yes" ;; + esac;; +esac + +# Check whether --enable-dlopen was given. +if test "${enable_dlopen+set}" = set; then : + enableval=$enable_dlopen; +else + enable_dlopen="$def_dlopen" +fi + +# Check whether --enable-statsysbfd was given. +if test "${enable_statsysbfd+set}" = set; then : + enableval=$enable_statsysbfd; +else + enable_statsysbfd="$def_statsysbfd" +fi + +# Check whether --enable-dynsysbfd was given. +if test "${enable_dynsysbfd+set}" = set; then : + enableval=$enable_dynsysbfd; +else + enable_dynsysbfd="no" +fi + +#AC_ARG_ENABLE(locbfd, +# [ --enable-locbfd uses a static bfd library built from this source tree for loading and relocationing object files ] +# ,,enable_locbfd="$def_locbfd") +# Check whether --enable-custreloc was given. +if test "${enable_custreloc+set}" = set; then : + enableval=$enable_custreloc; +else + enable_custreloc="$def_custreloc" +fi + +# Check whether --enable-debug was given. +if test "${enable_debug+set}" = set; then : + enableval=$enable_debug; +else + enable_debug="$def_debug" +fi + +# Check whether --enable-gprof was given. +if test "${enable_gprof+set}" = set; then : + enableval=$enable_gprof; +else + enable_gprof="no" +fi + +# Check whether --enable-static was given. +if test "${enable_static+set}" = set; then : + enableval=$enable_static; enable_static=$enableval +else + enable_static="$def_static" +fi + +# Check whether --enable-pic was given. +if test "${enable_pic+set}" = set; then : + enableval=$enable_pic; +else + enable_pic="$def_pic" +fi + + +# Check whether --enable-oldgmp was given. +if test "${enable_oldgmp+set}" = set; then : + enableval=$enable_oldgmp; +else + enable_oldgmp="$def_oldgmp" +fi + + +# Check whether --enable-dynsysgmp was given. +if test "${enable_dynsysgmp+set}" = set; then : + enableval=$enable_dynsysgmp; +else + enable_dynsysgmp="yes" +fi + + +load_opt="0" +if test "$enable_dlopen" = "yes" ; then + load_opt=1 +fi +if test "$enable_statsysbfd" = "yes" ; then + case $load_opt in + 0) load_opt=1;; + 1) load_opt=2;; + esac +fi +if test "$enable_dynsysbfd" = "yes" ; then + case $load_opt in + 0) load_opt=1;; + 1) load_opt=2;; + 2) load_opt=3;; + esac +fi +if test "$enable_locbfd" = "yes" ; then + case $load_opt in + 0) load_opt=1;; + 1) load_opt=2;; + 2) load_opt=3;; + 3) load_opt=4;; + esac +fi +if test "$enable_custreloc" = "yes" ; then + case $load_opt in + 0) load_opt=1;; + 1) load_opt=2;; + 2) load_opt=3;; + 3) load_opt=4;; + 4) load_opt=5;; + esac +fi + +if test "$load_opt" != "1" ; then + echo "Exactly one loader option must be chosen: dlopen=$enable_dlopen statsysbfd=$enable_statsysbfd dynsysbfd=$enable_dynsysbfd locbfd=$enable_locbfd custreloc=$enable_custreloc" + exit 1 +fi + +TLDFLAGS="" +if test "$enable_static" = "yes" ; then + TLDFLAGS="-static -Wl,-zmuldefs $TLDFLAGS"; #FIXME should be in unixport/makefile + +$as_echo "#define STATIC_LINKING 1" >>confdefs.h + +fi +case $use in + *gnuwin*) + TLDFLAGS="$TLDFLAGS -Wl,--stack,8000000";; +esac + +## finally warn if we did not find a recognized machine.s +## +#if test "$use" = "unknown" ; then +#types=`echo h/*.defs` | sed -e "s:h/::g" -e "s:\.defs:g"` +#echo got canonical=$canonical, but was not recognized. +#echo Unable to guess type to use. Try one of +#exit(1) +#fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: use=$use" >&5 +$as_echo "use=$use" >&6; } + + +# +# System programs +# + +# We set the default CFLAGS below, and don't want the autoconf default +# CM 20040106 +if test "$CFLAGS" = "" ; then + CFLAGS=" " +fi +if test "$LDFLAGS" = "" ; then + LDFLAGS=" " +fi + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu +if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args. +set dummy ${ac_tool_prefix}gcc; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_CC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="${ac_tool_prefix}gcc" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 +$as_echo "$CC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + +fi +if test -z "$ac_cv_prog_CC"; then + ac_ct_CC=$CC + # Extract the first word of "gcc", so it can be a program name with args. +set dummy gcc; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_ac_ct_CC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$ac_ct_CC"; then + ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_CC="gcc" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_CC=$ac_cv_prog_ac_ct_CC +if test -n "$ac_ct_CC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 +$as_echo "$ac_ct_CC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + if test "x$ac_ct_CC" = x; then + CC="" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + CC=$ac_ct_CC + fi +else + CC="$ac_cv_prog_CC" +fi + +if test -z "$CC"; then + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args. +set dummy ${ac_tool_prefix}cc; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_CC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="${ac_tool_prefix}cc" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 +$as_echo "$CC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + fi +fi +if test -z "$CC"; then + # Extract the first word of "cc", so it can be a program name with args. +set dummy cc; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_CC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else + ac_prog_rejected=no +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + if test "$as_dir/$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then + ac_prog_rejected=yes + continue + fi + ac_cv_prog_CC="cc" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +if test $ac_prog_rejected = yes; then + # We found a bogon in the path, so make sure we never use it. + set dummy $ac_cv_prog_CC + shift + if test $# != 0; then + # We chose a different compiler from the bogus one. + # However, it has the same basename, so the bogon will be chosen + # first if we set CC to just the basename; use the full file name. + shift + ac_cv_prog_CC="$as_dir/$ac_word${1+' '}$@" + fi +fi +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 +$as_echo "$CC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + +fi +if test -z "$CC"; then + if test -n "$ac_tool_prefix"; then + for ac_prog in cl.exe + do + # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. +set dummy $ac_tool_prefix$ac_prog; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_CC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="$ac_tool_prefix$ac_prog" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 +$as_echo "$CC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + test -n "$CC" && break + done +fi +if test -z "$CC"; then + ac_ct_CC=$CC + for ac_prog in cl.exe +do + # Extract the first word of "$ac_prog", so it can be a program name with args. +set dummy $ac_prog; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_ac_ct_CC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$ac_ct_CC"; then + ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_CC="$ac_prog" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_CC=$ac_cv_prog_ac_ct_CC +if test -n "$ac_ct_CC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 +$as_echo "$ac_ct_CC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + test -n "$ac_ct_CC" && break +done + + if test "x$ac_ct_CC" = x; then + CC="" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + CC=$ac_ct_CC + fi +fi + +fi + + +test -z "$CC" && { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "no acceptable C compiler found in \$PATH +See \`config.log' for more details" "$LINENO" 5; } + +# Provide some information about the compiler. +$as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5 +set X $ac_compile +ac_compiler=$2 +for ac_option in --version -v -V -qversion; do + { { ac_try="$ac_compiler $ac_option >&5" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_compiler $ac_option >&5") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + sed '10a\ +... rest of stderr output deleted ... + 10q' conftest.err >conftest.er1 + cat conftest.er1 >&5 + fi + rm -f conftest.er1 conftest.err + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } +done + +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +ac_clean_files_save=$ac_clean_files +ac_clean_files="$ac_clean_files a.out a.out.dSYM a.exe b.out" +# Try to create an executable without -o first, disregard a.out. +# It will help us diagnose broken compilers, and finding out an intuition +# of exeext. +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the C compiler works" >&5 +$as_echo_n "checking whether the C compiler works... " >&6; } +ac_link_default=`$as_echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'` + +# The possible output files: +ac_files="a.out conftest.exe conftest a.exe a_out.exe b.out conftest.*" + +ac_rmfiles= +for ac_file in $ac_files +do + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; + * ) ac_rmfiles="$ac_rmfiles $ac_file";; + esac +done +rm -f $ac_rmfiles + +if { { ac_try="$ac_link_default" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_link_default") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; then : + # Autoconf-2.13 could set the ac_cv_exeext variable to `no'. +# So ignore a value of `no', otherwise this would lead to `EXEEXT = no' +# in a Makefile. We should not override ac_cv_exeext if it was cached, +# so that the user can short-circuit this test for compilers unknown to +# Autoconf. +for ac_file in $ac_files '' +do + test -f "$ac_file" || continue + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) + ;; + [ab].out ) + # We found the default executable, but exeext='' is most + # certainly right. + break;; + *.* ) + if test "${ac_cv_exeext+set}" = set && test "$ac_cv_exeext" != no; + then :; else + ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` + fi + # We set ac_cv_exeext here because the later test for it is not + # safe: cross compilers may not add the suffix if given an `-o' + # argument, so we may need to know it at that point already. + # Even if this section looks crufty: it has the advantage of + # actually working. + break;; + * ) + break;; + esac +done +test "$ac_cv_exeext" = no && ac_cv_exeext= + +else + ac_file='' +fi +if test -z "$ac_file"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +$as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error 77 "C compiler cannot create executables +See \`config.log' for more details" "$LINENO" 5; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler default output file name" >&5 +$as_echo_n "checking for C compiler default output file name... " >&6; } +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5 +$as_echo "$ac_file" >&6; } +ac_exeext=$ac_cv_exeext + +rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out +ac_clean_files=$ac_clean_files_save +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5 +$as_echo_n "checking for suffix of executables... " >&6; } +if { { ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_link") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; then : + # If both `conftest.exe' and `conftest' are `present' (well, observable) +# catch `conftest.exe'. For instance with Cygwin, `ls conftest' will +# work properly (i.e., refer to `conftest.exe'), while it won't with +# `rm'. +for ac_file in conftest.exe conftest conftest.*; do + test -f "$ac_file" || continue + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; + *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` + break;; + * ) break;; + esac +done +else + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot compute suffix of executables: cannot compile and link +See \`config.log' for more details" "$LINENO" 5; } +fi +rm -f conftest conftest$ac_cv_exeext +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5 +$as_echo "$ac_cv_exeext" >&6; } + +rm -f conftest.$ac_ext +EXEEXT=$ac_cv_exeext +ac_exeext=$EXEEXT +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +int +main () +{ +FILE *f = fopen ("conftest.out", "w"); + return ferror (f) || fclose (f) != 0; + + ; + return 0; +} +_ACEOF +ac_clean_files="$ac_clean_files conftest.out" +# Check that the compiler produces executables we can run. If not, either +# the compiler is broken, or we cross compile. +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5 +$as_echo_n "checking whether we are cross compiling... " >&6; } +if test "$cross_compiling" != yes; then + { { ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_link") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } + if { ac_try='./conftest$ac_cv_exeext' + { { case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_try") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; }; then + cross_compiling=no + else + if test "$cross_compiling" = maybe; then + cross_compiling=yes + else + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run C compiled programs. +If you meant to cross compile, use \`--host'. +See \`config.log' for more details" "$LINENO" 5; } + fi + fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5 +$as_echo "$cross_compiling" >&6; } + +rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out +ac_clean_files=$ac_clean_files_save +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5 +$as_echo_n "checking for suffix of object files... " >&6; } +if ${ac_cv_objext+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +rm -f conftest.o conftest.obj +if { { ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_compile") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; then : + for ac_file in conftest.o conftest.obj conftest.*; do + test -f "$ac_file" || continue; + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM ) ;; + *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'` + break;; + esac +done +else + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot compute suffix of object files: cannot compile +See \`config.log' for more details" "$LINENO" 5; } +fi +rm -f conftest.$ac_cv_objext conftest.$ac_ext +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5 +$as_echo "$ac_cv_objext" >&6; } +OBJEXT=$ac_cv_objext +ac_objext=$OBJEXT +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU C compiler" >&5 +$as_echo_n "checking whether we are using the GNU C compiler... " >&6; } +if ${ac_cv_c_compiler_gnu+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ +#ifndef __GNUC__ + choke me +#endif + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_compiler_gnu=yes +else + ac_compiler_gnu=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +ac_cv_c_compiler_gnu=$ac_compiler_gnu + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5 +$as_echo "$ac_cv_c_compiler_gnu" >&6; } +if test $ac_compiler_gnu = yes; then + GCC=yes +else + GCC= +fi +ac_test_CFLAGS=${CFLAGS+set} +ac_save_CFLAGS=$CFLAGS +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5 +$as_echo_n "checking whether $CC accepts -g... " >&6; } +if ${ac_cv_prog_cc_g+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_save_c_werror_flag=$ac_c_werror_flag + ac_c_werror_flag=yes + ac_cv_prog_cc_g=no + CFLAGS="-g" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_cv_prog_cc_g=yes +else + CFLAGS="" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + +else + ac_c_werror_flag=$ac_save_c_werror_flag + CFLAGS="-g" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_cv_prog_cc_g=yes +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + ac_c_werror_flag=$ac_save_c_werror_flag +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5 +$as_echo "$ac_cv_prog_cc_g" >&6; } +if test "$ac_test_CFLAGS" = set; then + CFLAGS=$ac_save_CFLAGS +elif test $ac_cv_prog_cc_g = yes; then + if test "$GCC" = yes; then + CFLAGS="-g -O2" + else + CFLAGS="-g" + fi +else + if test "$GCC" = yes; then + CFLAGS="-O2" + else + CFLAGS= + fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $CC option to accept ISO C89" >&5 +$as_echo_n "checking for $CC option to accept ISO C89... " >&6; } +if ${ac_cv_prog_cc_c89+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_cv_prog_cc_c89=no +ac_save_CC=$CC +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +#include +struct stat; +/* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */ +struct buf { int x; }; +FILE * (*rcsopen) (struct buf *, struct stat *, int); +static char *e (p, i) + char **p; + int i; +{ + return p[i]; +} +static char *f (char * (*g) (char **, int), char **p, ...) +{ + char *s; + va_list v; + va_start (v,p); + s = g (p, va_arg (v,int)); + va_end (v); + return s; +} + +/* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has + function prototypes and stuff, but not '\xHH' hex character constants. + These don't provoke an error unfortunately, instead are silently treated + as 'x'. The following induces an error, until -std is added to get + proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an + array size at least. It's necessary to write '\x00'==0 to get something + that's true only with -std. */ +int osf4_cc_array ['\x00' == 0 ? 1 : -1]; + +/* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters + inside strings and character constants. */ +#define FOO(x) 'x' +int xlc6_cc_array[FOO(a) == 'x' ? 1 : -1]; + +int test (int i, double x); +struct s1 {int (*f) (int a);}; +struct s2 {int (*f) (double a);}; +int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int); +int argc; +char **argv; +int +main () +{ +return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]; + ; + return 0; +} +_ACEOF +for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std \ + -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" +do + CC="$ac_save_CC $ac_arg" + if ac_fn_c_try_compile "$LINENO"; then : + ac_cv_prog_cc_c89=$ac_arg +fi +rm -f core conftest.err conftest.$ac_objext + test "x$ac_cv_prog_cc_c89" != "xno" && break +done +rm -f conftest.$ac_ext +CC=$ac_save_CC + +fi +# AC_CACHE_VAL +case "x$ac_cv_prog_cc_c89" in + x) + { $as_echo "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 +$as_echo "none needed" >&6; } ;; + xno) + { $as_echo "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 +$as_echo "unsupported" >&6; } ;; + *) + CC="$CC $ac_cv_prog_cc_c89" + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5 +$as_echo "$ac_cv_prog_cc_c89" >&6; } ;; +esac +if test "x$ac_cv_prog_cc_c89" != xno; then : + +fi + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking how to run the C preprocessor" >&5 +$as_echo_n "checking how to run the C preprocessor... " >&6; } +# On Suns, sometimes $CPP names a directory. +if test -n "$CPP" && test -d "$CPP"; then + CPP= +fi +if test -z "$CPP"; then + if ${ac_cv_prog_CPP+:} false; then : + $as_echo_n "(cached) " >&6 +else + # Double quotes because CPP needs to be expanded + for CPP in "$CC -E" "$CC -E -traditional-cpp" "/lib/cpp" + do + ac_preproc_ok=false +for ac_c_preproc_warn_flag in '' yes +do + # Use a header file that comes with gcc, so configuring glibc + # with a fresh cross-compiler works. + # Prefer to if __STDC__ is defined, since + # exists even on freestanding compilers. + # On the NeXT, cc -E runs the code through the compiler's parser, + # not just through cpp. "Syntax error" is here to catch this case. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#ifdef __STDC__ +# include +#else +# include +#endif + Syntax error +_ACEOF +if ac_fn_c_try_cpp "$LINENO"; then : + +else + # Broken: fails on valid input. +continue +fi +rm -f conftest.err conftest.i conftest.$ac_ext + + # OK, works on sane cases. Now check whether nonexistent headers + # can be detected and how. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +_ACEOF +if ac_fn_c_try_cpp "$LINENO"; then : + # Broken: success on invalid input. +continue +else + # Passes both tests. +ac_preproc_ok=: +break +fi +rm -f conftest.err conftest.i conftest.$ac_ext + +done +# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. +rm -f conftest.i conftest.err conftest.$ac_ext +if $ac_preproc_ok; then : + break +fi + + done + ac_cv_prog_CPP=$CPP + +fi + CPP=$ac_cv_prog_CPP +else + ac_cv_prog_CPP=$CPP +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $CPP" >&5 +$as_echo "$CPP" >&6; } +ac_preproc_ok=false +for ac_c_preproc_warn_flag in '' yes +do + # Use a header file that comes with gcc, so configuring glibc + # with a fresh cross-compiler works. + # Prefer to if __STDC__ is defined, since + # exists even on freestanding compilers. + # On the NeXT, cc -E runs the code through the compiler's parser, + # not just through cpp. "Syntax error" is here to catch this case. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#ifdef __STDC__ +# include +#else +# include +#endif + Syntax error +_ACEOF +if ac_fn_c_try_cpp "$LINENO"; then : + +else + # Broken: fails on valid input. +continue +fi +rm -f conftest.err conftest.i conftest.$ac_ext + + # OK, works on sane cases. Now check whether nonexistent headers + # can be detected and how. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +_ACEOF +if ac_fn_c_try_cpp "$LINENO"; then : + # Broken: success on invalid input. +continue +else + # Passes both tests. +ac_preproc_ok=: +break +fi +rm -f conftest.err conftest.i conftest.$ac_ext + +done +# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. +rm -f conftest.i conftest.err conftest.$ac_ext +if $ac_preproc_ok; then : + +else + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "C preprocessor \"$CPP\" fails sanity check +See \`config.log' for more details" "$LINENO" 5; } +fi + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + + + +# can only test for numbers -- CM +# if test "${GCC}" -eq "yes" ; then +#if [[ "${GCC}" = "yes" ]] ; then +# Allog for environment variable overrides on compiler selection -- CM +#GCC=$CC +#else +#GCC="" +#fi +# subst GCC not only under 386-linux, but where available -- CM + +if test "$GCC" = "yes" ; then + + TCFLAGS="-Wall -fsigned-char" + + #FIXME -Wno-unused-but-set-variable when time + TMPF=-Wno-unused-but-set-variable + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for CFLAG $TMPF" >&5 +$as_echo_n "checking for CFLAG $TMPF... " >&6; } + CFLAGS_ORI=$CFLAGS + CFLAGS="$CFLAGS $TMPF" + +if test "$cross_compiling" = yes; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +int main() {return 0;} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + TCFLAGS="$TCFLAGS $TMPF";{ $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + CFLAGS=$CFLAGS_ORI + +else + TCFLAGS="-fsigned-char" +fi +if test "$GCC" = "yes" ; then + TCFLAGS="$TCFLAGS -pipe" + case $use in + *mingw*|*gnuwin*) +# echo "WARNING: Remove -fno-zero-initialized-in-bss from makedefs if gcc less than 3.3.1." +# echo " It is otherwise needed for the Unexec stuff to work." +# if test "$enable_debug" = "yes" ; then TCFLAGS="$TCFLAGS -gstabs" ; fi + TCFLAGS="$TCFLAGS -fno-zero-initialized-in-bss -mms-bitfields";; + esac +fi +#if test -f /proc/sys/kernel/exec-shield ; then +# exec_stat=`cat /proc/sys/kernel/exec-shield` +# if test "$exec_stat" != "0" ; then +# # CFLAGS here to hopefully cover the DBEGIN routine below +# CFLAGS="$CFLAGS -Wa,--execstack" +# fi +#fi + +TO3FLAGS="" +TO2FLAGS="" + +#TFPFLAG="-fomit-frame-pointer" +# FIXME -- remove when mingw compiler issues are fixed +case "$use" in + *mingw*) + TFPFLAG="";; + m68k*)#FIXME gcc 4.x bug workaround + TFPFLAG="";; + *) + TFPFLAG="-fomit-frame-pointer";; +esac + +for ac_prog in gawk nawk awk +do + # Extract the first word of "$ac_prog", so it can be a program name with args. +set dummy $ac_prog; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_AWK+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$AWK"; then + ac_cv_prog_AWK="$AWK" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_AWK="$ac_prog" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +AWK=$ac_cv_prog_AWK +if test -n "$AWK"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $AWK" >&5 +$as_echo "$AWK" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + test -n "$AWK" && break +done + + +# Work around system/gprof mips/hppa hang +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking working gprof" >&5 +$as_echo_n "checking working gprof... " >&6; } +old_enable_gprof=$enable_gprof +case $use in + powerpc*) if test "$host_cpu" = "powerpc64le" ; then enable_gprof="no"; fi;; + sh4*) enable_gprof="no";; + ia64*) enable_gprof="no";; +# mips*) enable_gprof="no";; + hppa*) enable_gprof="no";; + arm*) enable_gprof="no";;#FIXME mcount compiled as a 24/22 bit reloc even with -mlong-calls, marginally accessible + *gnu) enable_gprof="no";; +esac +if test "$enable_gprof" = "$old_enable_gprof" ; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: ok" >&5 +$as_echo "ok" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: disabled" >&5 +$as_echo "disabled" >&6; } +fi + +if test "$enable_gprof" = "yes" ; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for text start" >&5 +$as_echo_n "checking for text start... " >&6; } + echo 'int main () {return(0);}' >foo.c + $CC foo.c -o foo + GCL_GPROF_START=`nm foo | $AWK '/ *[TD] *__*start$/ {print $NF}'` # D for ppc64 -- FIXME custreloc + rm -f foo.c foo + if test "$GCL_GPROF_START" != "" ; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $GCL_GPROF_START" >&5 +$as_echo "$GCL_GPROF_START" >&6; } + +cat >>confdefs.h <<_ACEOF +#define GCL_GPROF_START $GCL_GPROF_START +_ACEOF + + case "$use" in + arm*) + #FIXME report and remove this when done + { $as_echo "$as_me:${as_lineno-$LINENO}: result: Reducing optimization on profiling arm build to workaround gcc bug" >&5 +$as_echo "Reducing optimization on profiling arm build to workaround gcc bug" >&6; } + enable_debug=yes;; + esac + TCFLAGS="$TCFLAGS -pg"; + TLIBS="$TLIBS -pg"; + TFPFLAG="" + +$as_echo "#define GCL_GPROF 1" >>confdefs.h + + else + enable_gprof="no"; + fi +fi + +if $CC -v 2>&1 | tail -1 | grep "gcc version 4.6.1" >/dev/null ; then + case "$use" in + arm*) + #FIXME report and remove this when done + { $as_echo "$as_me:${as_lineno-$LINENO}: result: Reducing optimization on arm build to workaround gcc 4.6 bug" >&5 +$as_echo "Reducing optimization on arm build to workaround gcc 4.6 bug" >&6; } + enable_debug=yes;; + esac +fi + + +if test "$enable_debug" = "yes" ; then + TCFLAGS="$TCFLAGS -g" + # for subconfigurations + CFLAGS="$CFLAGS -g" +else + TO3FLAGS="-O3 $TFPFLAG" + TO2FLAGS="-O" +fi + +# gcc on ppc cannot compile our new_init.c with full opts --CM +TONIFLAGS="" +case $use in + powerpc*macosx) + TCFLAGS="$TCFLAGS -mlongcall";; + *linux) + case $use in +# amd64*) # stack-boundary option does not work +# TCFLAGS="$TCFLAGS -m64 -mpreferred-stack-boundary=8";; + alpha*) + TCFLAGS="$TCFLAGS -mieee" + if test "$enable_debug" != "yes" ; then TO3FLAGS="-O0" ; fi #FIXME needed asof gcc 4.8.1 + ;; +# m68k*) +# TCFLAGS="$TCFLAGS -ffloat-store";; + aarch64*) + TLIBS="$TLIBS -lgcc_s";; + hppa*) + TCFLAGS="$TCFLAGS -mlong-calls " + TLIBS="$TLIBS -lgcc_s" # workaround hppa __moddi3 local func symbols with default linker flags + if test "$enable_debug" != "yes" ; then TO3FLAGS="-O2" ; TFPFLAG=""; fi #FIXME needed asof gcc 4.8.1 +# TCFLAGS="$TCFLAGS -ffunction-sections" +# if test "$enable_debug" != "yes" ; then TO3FLAGS="-O $TFPFLAG" ; fi +# if test "$enable_debug" != "yes" ; then TO2FLAGS="-O" ; fi + ;; + mips*) +# if test "$enable_debug" != "yes" ; then TO3FLAGS="-O0" ; fi #FIXME needed asof gcc 4.6.2 + ;; + ia64*) + if test "$enable_debug" != "yes" ; then TO3FLAGS="-O" ; fi #FIXME needed asof gcc 4.8.1 + ;; + arm*) + TCFLAGS="$TCFLAGS -mlong-calls -fdollars-in-identifiers -g " +# if test "$enable_debug" != "yes" ; then TO3FLAGS="-O" ; fi #FIXME needed asof gcc 4.6.2 +# if test "$enable_debug" != "yes" ; then TO2FLAGS="-O" ; fi + ;; + powerpc*) + TCFLAGS="$TCFLAGS -mlongcall" + ;; +# if $CC -v 2>&1 | grep -q "gcc version 3.2" ; then +# echo Reducing optimization for buggy gcc-3.2 +# if test "$enable_debug" != "yes" ; then TONIFLAGS="-O $TFPFLAG" ; fi +# fi; +# echo Probing for longcall +# if ! $CC -v 2>&1 | $AWK '/^gcc version / {split($3,A,".");if (A[[1]]+0>3 || (A[[1]]+0>=3 && A[[2]]+0>=3)) exit 1;}'; then +# echo Enabling longcall on gcc 3.3 or later +# TCFLAGS="$TCFLAGS -mlongcall" +# echo Reducing optimization for buggy gcc 3.3 or later +# if test "$enable_debug" != "yes" ; then TONIFLAGS="-O $TFPFLAG" ; fi +# fi;; + esac;; +esac +if test "$enable_pic" = "yes" ; then + TCFLAGS="$TCFLAGS -fPIC" +fi + +FDEBUG=`echo $CFLAGS | tr ' ' '\012' |grep "^\-g$"|tr '\012' ' '` +#CFLAGS=`echo $CFLAGS | tr ' ' '\012' |grep -v "^\-g$"` +FOMITF=`echo $CFLAGS | tr ' ' '\012' |grep "^\-fomit-frame-pointer$"|tr '\012' ' '` +CFLAGS=`echo $CFLAGS | tr ' ' '\012' |grep -v "^\-fomit-frame-pointer$"|tr '\012' ' '` +FOOPT3=`echo $CFLAGS | tr ' ' '\012' |grep "^\-O3$"|tr '\012' ' '` +CFLAGS=`echo $CFLAGS | tr ' ' '\012' |grep -v "^\-O3$"|tr '\012' ' '` +FOOPT2=`echo $CFLAGS | tr ' ' '\012' |grep "^\-O2$"|tr '\012' ' '` +CFLAGS=`echo $CFLAGS | tr ' ' '\012' |grep -v "^\-O2$"|tr '\012' ' '` +FOOPT1=`echo $CFLAGS | tr ' ' '\012' |grep "^\-O1$"|tr '\012' ' '` +TMPF=`echo $CFLAGS | tr ' ' '\012' |grep "^\-O$"|tr '\012' ' '` +FOOPT1="$FOOPT1$TMPF" +CFLAGS=`echo $CFLAGS | tr ' ' '\012' |grep -v "^\-O1$"|grep -v "^\-O$"|tr '\012' ' '` +FOOPT0=`echo $CFLAGS | tr ' ' '\012' |grep "^\-O0$"|tr '\012' ' '` +CFLAGS=`echo $CFLAGS | tr ' ' '\012' |grep -v "^\-O0$"|tr '\012' ' '` + +if test "$FOOPT0" != "" ; then + TO3FLAGS=`echo $TO3FLAGS | sed 's,\-O[123 ],-O0 ,g' | sed 's,\-O$,-O0 ,g'` + TO2FLAGS=`echo $TO2FLAGS | sed 's,\-O[123 ],-O0 ,g' | sed 's,\-O$,-O0 ,g'` +else +if test "$FOOPT1" != "" ; then + TO3FLAGS=`echo $TO3FLAGS | sed 's,\-O[2-3],-O1,g'` + TO2FLAGS=`echo $TO2FLAGS | sed 's,\-O[2-3],-O1,g'` +else +if test "$FOOPT2" != "" ; then + TO3FLAGS=`echo "$TO3FLAGS" | sed 's,\-O3,-O2,g'` + TO2FLAGS=`echo "$TO2FLAGS" | sed 's,\-O3,-O2,g'` +fi +fi +fi + +if test "$FDEBUG" != "" ; then + TO3FLAGS=`echo $TO3FLAGS | sed 's,\-fomit-frame-pointer,,g'` + TO2FLAGS=`echo $TO2FLAGS | sed 's,\-fomit-frame-pointer,,g'` +fi + +if test "$FOMITF" != "" ; then + TO3FLAGS="$TO3FLAGS $FOMITF" +fi + +# Step 1: set the variable "system" to hold the name and version number +# for the system. This can usually be done via the "uname" command, but +# there are a few systems, like Next, where this doesn't work. + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking system version (for dynamic loading)" >&5 +$as_echo_n "checking system version (for dynamic loading)... " >&6; } +if machine=`uname -m` ; then true; else machine=unknown ; fi + +for ac_prog in makeinfo +do + # Extract the first word of "$ac_prog", so it can be a program name with args. +set dummy $ac_prog; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_MAKEINFO+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$MAKEINFO"; then + ac_cv_prog_MAKEINFO="$MAKEINFO" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_MAKEINFO="$ac_prog" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +MAKEINFO=$ac_cv_prog_MAKEINFO +if test -n "$MAKEINFO"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $MAKEINFO" >&5 +$as_echo "$MAKEINFO" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + test -n "$MAKEINFO" && break +done +test -n "$MAKEINFO" || MAKEINFO=""false"" + + + +if test -f /usr/lib/NextStep/software_version; then + system=NEXTSTEP-`${AWK} '/3/,/3/' /usr/lib/NextStep/software_version` +else + system=`uname -s`-`uname -r` + if test "$?" -ne 0 ; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: unknown (can't find uname command)" >&5 +$as_echo "unknown (can't find uname command)" >&6; } + system=unknown + else + # Special check for weird MP-RAS system (uname returns weird + # results, and the version is kept in special file). + + if test -r /etc/.relid -a "X`uname -n`" = "X`uname -s`" ; then + system="MP-RAS-`${AWK} '{print $3}' '/etc/.relid'`" + fi + if test "`uname -s`" = "AIX" ; then + system=AIX-`uname -v`.`uname -r` + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $system" >&5 +$as_echo "$system" >&6; } + fi +fi + +case $use in + *macosx) + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for grep that handles long lines and -e" >&5 +$as_echo_n "checking for grep that handles long lines and -e... " >&6; } +if ${ac_cv_path_GREP+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -z "$GREP"; then + ac_path_GREP_found=false + # Loop through the user's path and test for each of PROGNAME-LIST + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_prog in grep ggrep; do + for ac_exec_ext in '' $ac_executable_extensions; do + ac_path_GREP="$as_dir/$ac_prog$ac_exec_ext" + as_fn_executable_p "$ac_path_GREP" || continue +# Check for GNU ac_path_GREP and select it if it is found. + # Check for GNU $ac_path_GREP +case `"$ac_path_GREP" --version 2>&1` in +*GNU*) + ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_found=:;; +*) + ac_count=0 + $as_echo_n 0123456789 >"conftest.in" + while : + do + cat "conftest.in" "conftest.in" >"conftest.tmp" + mv "conftest.tmp" "conftest.in" + cp "conftest.in" "conftest.nl" + $as_echo 'GREP' >> "conftest.nl" + "$ac_path_GREP" -e 'GREP$' -e '-(cannot match)-' < "conftest.nl" >"conftest.out" 2>/dev/null || break + diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break + as_fn_arith $ac_count + 1 && ac_count=$as_val + if test $ac_count -gt ${ac_path_GREP_max-0}; then + # Best one so far, save it but keep looking for a better one + ac_cv_path_GREP="$ac_path_GREP" + ac_path_GREP_max=$ac_count + fi + # 10*(2^10) chars as input seems more than enough + test $ac_count -gt 10 && break + done + rm -f conftest.in conftest.tmp conftest.nl conftest.out;; +esac + + $ac_path_GREP_found && break 3 + done + done + done +IFS=$as_save_IFS + if test -z "$ac_cv_path_GREP"; then + as_fn_error $? "no acceptable grep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 + fi +else + ac_cv_path_GREP=$GREP +fi + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_GREP" >&5 +$as_echo "$ac_cv_path_GREP" >&6; } + GREP="$ac_cv_path_GREP" + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for egrep" >&5 +$as_echo_n "checking for egrep... " >&6; } +if ${ac_cv_path_EGREP+:} false; then : + $as_echo_n "(cached) " >&6 +else + if echo a | $GREP -E '(a|b)' >/dev/null 2>&1 + then ac_cv_path_EGREP="$GREP -E" + else + if test -z "$EGREP"; then + ac_path_EGREP_found=false + # Loop through the user's path and test for each of PROGNAME-LIST + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_prog in egrep; do + for ac_exec_ext in '' $ac_executable_extensions; do + ac_path_EGREP="$as_dir/$ac_prog$ac_exec_ext" + as_fn_executable_p "$ac_path_EGREP" || continue +# Check for GNU ac_path_EGREP and select it if it is found. + # Check for GNU $ac_path_EGREP +case `"$ac_path_EGREP" --version 2>&1` in +*GNU*) + ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_found=:;; +*) + ac_count=0 + $as_echo_n 0123456789 >"conftest.in" + while : + do + cat "conftest.in" "conftest.in" >"conftest.tmp" + mv "conftest.tmp" "conftest.in" + cp "conftest.in" "conftest.nl" + $as_echo 'EGREP' >> "conftest.nl" + "$ac_path_EGREP" 'EGREP$' < "conftest.nl" >"conftest.out" 2>/dev/null || break + diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break + as_fn_arith $ac_count + 1 && ac_count=$as_val + if test $ac_count -gt ${ac_path_EGREP_max-0}; then + # Best one so far, save it but keep looking for a better one + ac_cv_path_EGREP="$ac_path_EGREP" + ac_path_EGREP_max=$ac_count + fi + # 10*(2^10) chars as input seems more than enough + test $ac_count -gt 10 && break + done + rm -f conftest.in conftest.tmp conftest.nl conftest.out;; +esac + + $ac_path_EGREP_found && break 3 + done + done + done +IFS=$as_save_IFS + if test -z "$ac_cv_path_EGREP"; then + as_fn_error $? "no acceptable egrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 + fi +else + ac_cv_path_EGREP=$EGREP +fi + + fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_EGREP" >&5 +$as_echo "$ac_cv_path_EGREP" >&6; } + EGREP="$ac_cv_path_EGREP" + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for ANSI C header files" >&5 +$as_echo_n "checking for ANSI C header files... " >&6; } +if ${ac_cv_header_stdc+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +#include +#include +#include + +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_cv_header_stdc=yes +else + ac_cv_header_stdc=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + +if test $ac_cv_header_stdc = yes; then + # SunOS 4.x string.h does not declare mem*, contrary to ANSI. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "memchr" >/dev/null 2>&1; then : + +else + ac_cv_header_stdc=no +fi +rm -f conftest* + +fi + +if test $ac_cv_header_stdc = yes; then + # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "free" >/dev/null 2>&1; then : + +else + ac_cv_header_stdc=no +fi +rm -f conftest* + +fi + +if test $ac_cv_header_stdc = yes; then + # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. + if test "$cross_compiling" = yes; then : + : +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +#include +#if ((' ' & 0x0FF) == 0x020) +# define ISLOWER(c) ('a' <= (c) && (c) <= 'z') +# define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) +#else +# define ISLOWER(c) \ + (('a' <= (c) && (c) <= 'i') \ + || ('j' <= (c) && (c) <= 'r') \ + || ('s' <= (c) && (c) <= 'z')) +# define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c)) +#endif + +#define XOR(e, f) (((e) && !(f)) || (!(e) && (f))) +int +main () +{ + int i; + for (i = 0; i < 256; i++) + if (XOR (islower (i), ISLOWER (i)) + || toupper (i) != TOUPPER (i)) + return 2; + return 0; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + +else + ac_cv_header_stdc=no +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + +fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_header_stdc" >&5 +$as_echo "$ac_cv_header_stdc" >&6; } +if test $ac_cv_header_stdc = yes; then + +$as_echo "#define STDC_HEADERS 1" >>confdefs.h + +fi + +# On IRIX 5.3, sys/types and inttypes.h are conflicting. +for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \ + inttypes.h stdint.h unistd.h +do : + as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` +ac_fn_c_check_header_compile "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default +" +if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : + cat >>confdefs.h <<_ACEOF +#define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 +_ACEOF + +fi + +done + + +for ac_header in malloc/malloc.h +do : + ac_fn_c_check_header_mongrel "$LINENO" "malloc/malloc.h" "ac_cv_header_malloc_malloc_h" "$ac_includes_default" +if test "x$ac_cv_header_malloc_malloc_h" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_MALLOC_MALLOC_H 1 +_ACEOF + +else + as_fn_error $? "need malloc.h on macosx" "$LINENO" 5 +fi + +done + + ac_fn_c_check_member "$LINENO" "struct _malloc_zone_t" "memalign" "ac_cv_member_struct__malloc_zone_t_memalign" " + #include + +" +if test "x$ac_cv_member_struct__malloc_zone_t_memalign" = xyes; then : + +$as_echo "#define HAVE_MALLOC_ZONE_MEMALIGN 1" >>confdefs.h + +fi + + + ;; +esac + + +for ac_header in setjmp.h +do : + ac_fn_c_check_header_mongrel "$LINENO" "setjmp.h" "ac_cv_header_setjmp_h" "$ac_includes_default" +if test "x$ac_cv_header_setjmp_h" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_SETJMP_H 1 +_ACEOF + { $as_echo "$as_me:${as_lineno-$LINENO}: checking sizeof jmp_buf" >&5 +$as_echo_n "checking sizeof jmp_buf... " >&6; } + if test "$cross_compiling" = yes; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #include + #include + int main() { + FILE *fp=fopen("conftest1","w"); + fprintf(fp,"%lu\n",sizeof(jmp_buf)); + fclose(fp); + return 0; + } +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + sizeof_jmp_buf=`cat conftest1` + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $sizeof_jmp_buf" >&5 +$as_echo "$sizeof_jmp_buf" >&6; } + +cat >>confdefs.h <<_ACEOF +#define SIZEOF_JMP_BUF $sizeof_jmp_buf +_ACEOF + +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + +fi + +done + + +# sysconf + +for ac_header in unistd.h +do : + ac_fn_c_check_header_mongrel "$LINENO" "unistd.h" "ac_cv_header_unistd_h" "$ac_includes_default" +if test "x$ac_cv_header_unistd_h" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_UNISTD_H 1 +_ACEOF + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sysconf in -lc" >&5 +$as_echo_n "checking for sysconf in -lc... " >&6; } +if ${ac_cv_lib_c_sysconf+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lc $LIBS" + +# ac_fn_c_try_link LINENO +# ----------------------- +# Try to link conftest.$ac_ext, and return whether this succeeded. +ac_fn_c_try_link () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + rm -f conftest.$ac_objext conftest$ac_exeext + if { { ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_link") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + grep -v '^ *+' conftest.err >conftest.er1 + cat conftest.er1 >&5 + mv -f conftest.er1 conftest.err + fi + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest$ac_exeext && { + test "$cross_compiling" = yes || + test -x conftest$ac_exeext + }; then : + ac_retval=0 +else + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=1 +fi + # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information + # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would + # interfere with the next link command; also delete a directory that is + # left behind by Apple's compiler. We do this before executing the actions. + rm -rf conftest.dSYM conftest_ipa8_conftest.oo + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + +} # ac_fn_c_try_link +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char sysconf (); +int +main () +{ +return sysconf (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_c_sysconf=yes +else + ac_cv_lib_c_sysconf=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_c_sysconf" >&5 +$as_echo "$ac_cv_lib_c_sysconf" >&6; } +if test "x$ac_cv_lib_c_sysconf" = xyes; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: checking _SC_CLK_TCK" >&5 +$as_echo_n "checking _SC_CLK_TCK... " >&6; } + if test "$cross_compiling" = yes; then : + hz=0 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include + #include + int + main() { + FILE *fp=fopen("conftest1","w"); + fprintf(fp,"%lu\n",sysconf(_SC_CLK_TCK)); + fclose(fp); + return 0; + } +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + hz=`cat conftest1` + +cat >>confdefs.h <<_ACEOF +#define HZ $hz +_ACEOF + + +else + hz=0 +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $hz" >&5 +$as_echo "$hz" >&6; } + +fi + +fi + +done + + + +#MY_SUBDIRS= + +# +# GMP +# + +rm -f makedefsafter + +MP_INCLUDE="" +if test $use_gmp = yes ; then + + PATCHED_SYMBOLS="" + if test "$enable_dynsysgmp" = "yes" ; then + for ac_header in gmp.h +do : + ac_fn_c_check_header_mongrel "$LINENO" "gmp.h" "ac_cv_header_gmp_h" "$ac_includes_default" +if test "x$ac_cv_header_gmp_h" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_GMP_H 1 +_ACEOF + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for __gmpz_init in -lgmp" >&5 +$as_echo_n "checking for __gmpz_init in -lgmp... " >&6; } +if ${ac_cv_lib_gmp___gmpz_init+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lgmp $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char __gmpz_init (); +int +main () +{ +return __gmpz_init (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_gmp___gmpz_init=yes +else + ac_cv_lib_gmp___gmpz_init=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_gmp___gmpz_init" >&5 +$as_echo "$ac_cv_lib_gmp___gmpz_init" >&6; } +if test "x$ac_cv_lib_gmp___gmpz_init" = xyes; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: checking \"for external gmp version\"" >&5 +$as_echo_n "checking \"for external gmp version\"... " >&6; } + if test "$cross_compiling" = yes; then : + echo "Cannot use dynamic gmp lib" +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include + int main() { + #if __GNU_MP_VERSION > 3 + return 0; + #else + return -1; + #endif + } +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + # MPFILES=$GMPDIR/mpn/mul_n.o +# PATCHED_SYMBOLS=__gmpn_toom3_mul_n + MPFILES= + PATCHED_SYMBOLS= +# if test "$use" = "m68k-linux" ; then +# MPFILES="$MPFILES $GMPDIR/mpn/lshift.o $GMPDIR/mpn/rshift.o" +# PATCHED_SYMBOLS="$PATCHED_SYMBOLS __gmpn_lshift __gmpn_rshift" +# fi + TLIBS="$TLIBS -lgmp" + echo "#include \"gmp.h\"" >foo.c + echo "int main() {return 0;}" >>foo.c + MP_INCLUDE=`cpp foo.c | $AWK '/(\/|\\\\)gmp.h/ {if (!i) print $3;i=1}' | tr -d '"'` + rm -f foo.c +else + echo "Cannot use dynamic gmp lib" +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + +else + echo "Cannot use dynamic gmp lib" +fi + +else + echo "Cannot use dynamic gmp lib" +fi + +done + +fi + +NEED_LOCAL_GMP='' +if test "$MP_INCLUDE" = "" ; then + NEED_LOCAL_GMP=1; +fi +if test "$PATCHED_SYMBOLS" != "" ; then + NEED_LOCAL_GMP=1; +fi + +if test "$NEED_LOCAL_GMP" != "" ; then + + GMPDIR=gmp4 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking use_gmp=yes, doing configure in gmp directory" >&5 +$as_echo_n "checking use_gmp=yes, doing configure in gmp directory... " >&6; } + echo + echo "#" + echo "#" + echo "# -------------------" + echo "# Subconfigure of GMP" + echo "#" + echo "#" + + if test "$use_common_binary" = "yes"; then + cd $GMPDIR && ./configure --build=$host && cd .. + else + cd $GMPDIR && ./configure && cd .. + fi + #MY_SUBDIRS="$MY_SUBDIRS $GMPDIR" + + echo "#" + echo "#" + echo "#" + echo "# Subconfigure of GMP done" + echo "# ------------------------" + echo "#" + + if test "$MP_INCLUDE" = "" ; then + cp $GMPDIR/gmp.h h/gmp.h + MP_INCLUDE=h/gmp.h + MPFILES=gmp_all + fi + +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking \"for leading underscore in object symbols\"" >&5 +$as_echo_n "checking \"for leading underscore in object symbols\"... " >&6; } +cat>foo.c < +#include +int main() {FILE *f;double d=0.0;getc(f);cos(d);return 0;} +EOFF +$CC -c foo.c -o foo.o +if nm foo.o |grep " U " | grep "_cos" >/dev/null || nm foo.o |grep " U " | grep " _getc" >/dev/null ; then + LEADING_UNDERSCORE=1 + +$as_echo "#define LEADING_UNDERSCORE 1" >>confdefs.h + + { $as_echo "$as_me:${as_lineno-$LINENO}: result: \"yes\"" >&5 +$as_echo "\"yes\"" >&6; } +else + LEADING_UNDERSCORE="" + { $as_echo "$as_me:${as_lineno-$LINENO}: result: \"no\"" >&5 +$as_echo "\"no\"" >&6; } +fi + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking \"for GNU ld option -Map\"" >&5 +$as_echo_n "checking \"for GNU ld option -Map\"... " >&6; } +touch map +$CC -o foo -Wl,-Map map foo.o >/dev/null 2>&1 +if test `cat map | wc -l` != "0" ; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: \"yes\"" >&5 +$as_echo "\"yes\"" >&6; } + +$as_echo "#define HAVE_GNU_LD 1" >>confdefs.h + + GNU_LD=1 +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: \"no\"" >&5 +$as_echo "\"no\"" >&6; } + GNU_LD= +fi +rm -f foo.c foo.o foo map + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for size of gmp limbs" >&5 +$as_echo_n "checking for size of gmp limbs... " >&6; } +if test "$cross_compiling" = yes; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #include + #include "$MP_INCLUDE" + +int +main () +{ + + FILE *fp=fopen("conftest1","w"); + fprintf(fp,"%u",sizeof(mp_limb_t)); + fclose(fp); + return 0; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + mpsize=`cat conftest1` +else + as_fn_error $? "Cannot determine mpsize" "$LINENO" 5 +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + +cat >>confdefs.h <<_ACEOF +#define MP_LIMB_BYTES $mpsize +_ACEOF + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $mpsize" >&5 +$as_echo "$mpsize" >&6; } + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking _SHORT_LIMB" >&5 +$as_echo_n "checking _SHORT_LIMB... " >&6; } +if test "$cross_compiling" = yes; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #include + #include "$MP_INCLUDE" + +int +main () +{ + + #ifdef _SHORT_LIMB + return 0; + #else + return 1; + #endif + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + +$as_echo "#define __SHORT_LIMB 1" >>confdefs.h + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking _LONG_LONG_LIMB" >&5 +$as_echo_n "checking _LONG_LONG_LIMB... " >&6; } +if test "$cross_compiling" = yes; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #include + #include "$MP_INCLUDE" + +int +main () +{ + + #ifdef _LONG_LONG_LIMB + return 0; + #else + return 1; + #endif + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + +$as_echo "#define __LONG_LONG_LIMB 1" >>confdefs.h + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + + GMP=1 + +$as_echo "#define GMP 1" >>confdefs.h + + + + echo > makedefsafter + echo "MPFILES=$MPFILES" >> makedefsafter + echo "PATCHED_SYMBOLS=$PATCHED_SYMBOLS" >> makedefsafter + echo >> makedefsafter +fi + + +# +# X windows +# + +if test "$enable_xgcl" = "yes" ; then + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for X" >&5 +$as_echo_n "checking for X... " >&6; } + + +# Check whether --with-x was given. +if test "${with_x+set}" = set; then : + withval=$with_x; +fi + +# $have_x is `yes', `no', `disabled', or empty when we do not yet know. +if test "x$with_x" = xno; then + # The user explicitly disabled X. + have_x=disabled +else + case $x_includes,$x_libraries in #( + *\'*) as_fn_error $? "cannot use X directory names containing '" "$LINENO" 5;; #( + *,NONE | NONE,*) if ${ac_cv_have_x+:} false; then : + $as_echo_n "(cached) " >&6 +else + # One or both of the vars are not set, and there is no cached value. +ac_x_includes=no ac_x_libraries=no +rm -f -r conftest.dir +if mkdir conftest.dir; then + cd conftest.dir + cat >Imakefile <<'_ACEOF' +incroot: + @echo incroot='${INCROOT}' +usrlibdir: + @echo usrlibdir='${USRLIBDIR}' +libdir: + @echo libdir='${LIBDIR}' +_ACEOF + if (export CC; ${XMKMF-xmkmf}) >/dev/null 2>/dev/null && test -f Makefile; then + # GNU make sometimes prints "make[1]: Entering ...", which would confuse us. + for ac_var in incroot usrlibdir libdir; do + eval "ac_im_$ac_var=\`\${MAKE-make} $ac_var 2>/dev/null | sed -n 's/^$ac_var=//p'\`" + done + # Open Windows xmkmf reportedly sets LIBDIR instead of USRLIBDIR. + for ac_extension in a so sl dylib la dll; do + if test ! -f "$ac_im_usrlibdir/libX11.$ac_extension" && + test -f "$ac_im_libdir/libX11.$ac_extension"; then + ac_im_usrlibdir=$ac_im_libdir; break + fi + done + # Screen out bogus values from the imake configuration. They are + # bogus both because they are the default anyway, and because + # using them would break gcc on systems where it needs fixed includes. + case $ac_im_incroot in + /usr/include) ac_x_includes= ;; + *) test -f "$ac_im_incroot/X11/Xos.h" && ac_x_includes=$ac_im_incroot;; + esac + case $ac_im_usrlibdir in + /usr/lib | /usr/lib64 | /lib | /lib64) ;; + *) test -d "$ac_im_usrlibdir" && ac_x_libraries=$ac_im_usrlibdir ;; + esac + fi + cd .. + rm -f -r conftest.dir +fi + +# Standard set of common directories for X headers. +# Check X11 before X11Rn because it is often a symlink to the current release. +ac_x_header_dirs=' +/usr/X11/include +/usr/X11R7/include +/usr/X11R6/include +/usr/X11R5/include +/usr/X11R4/include + +/usr/include/X11 +/usr/include/X11R7 +/usr/include/X11R6 +/usr/include/X11R5 +/usr/include/X11R4 + +/usr/local/X11/include +/usr/local/X11R7/include +/usr/local/X11R6/include +/usr/local/X11R5/include +/usr/local/X11R4/include + +/usr/local/include/X11 +/usr/local/include/X11R7 +/usr/local/include/X11R6 +/usr/local/include/X11R5 +/usr/local/include/X11R4 + +/usr/X386/include +/usr/x386/include +/usr/XFree86/include/X11 + +/usr/include +/usr/local/include +/usr/unsupported/include +/usr/athena/include +/usr/local/x11r5/include +/usr/lpp/Xamples/include + +/usr/openwin/include +/usr/openwin/share/include' + +if test "$ac_x_includes" = no; then + # Guess where to find include files, by looking for Xlib.h. + # First, try using that file with no special directory specified. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +_ACEOF +if ac_fn_c_try_cpp "$LINENO"; then : + # We can compile using X headers with no special include directory. +ac_x_includes= +else + for ac_dir in $ac_x_header_dirs; do + if test -r "$ac_dir/X11/Xlib.h"; then + ac_x_includes=$ac_dir + break + fi +done +fi +rm -f conftest.err conftest.i conftest.$ac_ext +fi # $ac_x_includes = no + +if test "$ac_x_libraries" = no; then + # Check for the libraries. + # See if we find them without any special options. + # Don't add to $LIBS permanently. + ac_save_LIBS=$LIBS + LIBS="-lX11 $LIBS" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +int +main () +{ +XrmInitialize () + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + LIBS=$ac_save_LIBS +# We can link X programs with no special library path. +ac_x_libraries= +else + LIBS=$ac_save_LIBS +for ac_dir in `$as_echo "$ac_x_includes $ac_x_header_dirs" | sed s/include/lib/g` +do + # Don't even attempt the hair of trying to link an X program! + for ac_extension in a so sl dylib la dll; do + if test -r "$ac_dir/libX11.$ac_extension"; then + ac_x_libraries=$ac_dir + break 2 + fi + done +done +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi # $ac_x_libraries = no + +case $ac_x_includes,$ac_x_libraries in #( + no,* | *,no | *\'*) + # Didn't find X, or a directory has "'" in its name. + ac_cv_have_x="have_x=no";; #( + *) + # Record where we found X for the cache. + ac_cv_have_x="have_x=yes\ + ac_x_includes='$ac_x_includes'\ + ac_x_libraries='$ac_x_libraries'" +esac +fi +;; #( + *) have_x=yes;; + esac + eval "$ac_cv_have_x" +fi # $with_x != no + +if test "$have_x" != yes; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $have_x" >&5 +$as_echo "$have_x" >&6; } + no_x=yes +else + # If each of the values was on the command line, it overrides each guess. + test "x$x_includes" = xNONE && x_includes=$ac_x_includes + test "x$x_libraries" = xNONE && x_libraries=$ac_x_libraries + # Update the cache value to reflect the command line values. + ac_cv_have_x="have_x=yes\ + ac_x_includes='$x_includes'\ + ac_x_libraries='$x_libraries'" + { $as_echo "$as_me:${as_lineno-$LINENO}: result: libraries $x_libraries, headers $x_includes" >&5 +$as_echo "libraries $x_libraries, headers $x_includes" >&6; } +fi + +# AC_PATH_XTRA +# echo $X_CFLAGS +# echo $X_LIBS +# echo $X_EXTRA_LIBS +# echo $X_PRE_LIBS + + miss=0 +# AC_CHECK_LIB(Xmu,main,X_LIBS="$X_LIBS",miss=1,$X_LIBS)#FIXME remove these +# AC_CHECK_LIB(Xt,main,X_LIBS="$X_LIBS",miss=1,$X_LIBS) +# AC_CHECK_LIB(Xext,main,X_LIBS="$X_LIBS",miss=1,$X_LIBS) +# AC_CHECK_LIB(Xaw,main,X_LIBS="$X_LIBS",miss=1,$X_LIBS)#until here + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for main in -lX11" >&5 +$as_echo_n "checking for main in -lX11... " >&6; } +if ${ac_cv_lib_X11_main+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lX11 $X_LIBS $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +int +main () +{ +return main (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_X11_main=yes +else + ac_cv_lib_X11_main=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_X11_main" >&5 +$as_echo "$ac_cv_lib_X11_main" >&6; } +if test "x$ac_cv_lib_X11_main" = xyes; then : + X_LIBS="$X_LIBS -lX11" +else + miss=1 +fi + + + if test "$miss" = "1" ; then + X_CFLAGS= + X_LIBS= + X_EXTRA_LIBS= + X_PRE_LIBS= + echo missing x libraries -- cannot compile xgcl + else + +$as_echo "#define HAVE_XGCL 1" >>confdefs.h + + fi +fi + + + + + +# +# Dynamic loading +# + +if test "$enable_dlopen" = "yes" ; then + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for dlopen in -ldl" >&5 +$as_echo_n "checking for dlopen in -ldl... " >&6; } +if ${ac_cv_lib_dl_dlopen+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-ldl $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char dlopen (); +int +main () +{ +return dlopen (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_dl_dlopen=yes +else + ac_cv_lib_dl_dlopen=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dl_dlopen" >&5 +$as_echo "$ac_cv_lib_dl_dlopen" >&6; } +if test "x$ac_cv_lib_dl_dlopen" = xyes; then : + have_dl=1 +else + have_dl=0 +fi + + if test "$have_dl" = "0" ; then + echo "Cannot find dlopen in -dl" + exit 1 + fi + + TLIBS="$TLIBS -ldl -rdynamic" + TCFLAGS="-fPIC $TCFLAGS" + +$as_echo "#define USE_DLOPEN 1" >>confdefs.h + +fi + +if test "$enable_statsysbfd" = "yes" || test "$enable_dynsysbfd" = "yes" ; then + for ac_header in bfd.h +do : + ac_fn_c_check_header_mongrel "$LINENO" "bfd.h" "ac_cv_header_bfd_h" "$ac_includes_default" +if test "x$ac_cv_header_bfd_h" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_BFD_H 1 +_ACEOF + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for bfd_init in -lbfd" >&5 +$as_echo_n "checking for bfd_init in -lbfd... " >&6; } +if ${ac_cv_lib_bfd_bfd_init+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lbfd -liberty $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char bfd_init (); +int +main () +{ +return bfd_init (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_bfd_bfd_init=yes +else + ac_cv_lib_bfd_bfd_init=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_bfd_bfd_init" >&5 +$as_echo "$ac_cv_lib_bfd_bfd_init" >&6; } +if test "x$ac_cv_lib_bfd_bfd_init" = xyes; then : + # + # Old binutils appear to need CONST defined to const + # + { $as_echo "$as_me:${as_lineno-$LINENO}: checking if need to define CONST for bfd" >&5 +$as_echo_n "checking if need to define CONST for bfd... " >&6; } + if test "$cross_compiling" = yes; then : + as_fn_error $? "cannot use bfd" "$LINENO" 5 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#define IN_GCC + #include + int main() { symbol_info t; return 0;} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +else + if test "$cross_compiling" = yes; then : + as_fn_error $? "cannot use bfd" "$LINENO" 5 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#define CONST const + #define IN_GCC + #include + int main() {symbol_info t; return 0;} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } + +$as_echo "#define NEED_CONST 1" >>confdefs.h + +else + as_fn_error $? "cannot use bfd" "$LINENO" 5 +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + +fi + +fi + +done + + + +$as_echo "#define HAVE_LIBBFD 1" >>confdefs.h + + +# +# BFD boolean syntax +# + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for useable bfd_boolean" >&5 +$as_echo_n "checking for useable bfd_boolean... " >&6; } + if test "$cross_compiling" = yes; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #define IN_GCC + #include + bfd_boolean foo() {return FALSE;} + +int +main () +{ +return 0; + ; + return 0; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } + +$as_echo "#define HAVE_BFD_BOOLEAN 1" >>confdefs.h + +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + +# +# bfd_link_info.output_bfd minimal configure change check +# + + ac_fn_c_check_member "$LINENO" "struct bfd_link_info" "output_bfd" "ac_cv_member_struct_bfd_link_info_output_bfd" " + #include + #include + +" +if test "x$ac_cv_member_struct_bfd_link_info_output_bfd" = xyes; then : + +$as_echo "#define HAVE_OUTPUT_BFD 1" >>confdefs.h + +fi + + + +# +# FIXME: Need to workaround mingw before this point -- CM +# + if test "$enable_statsysbfd" = "yes" && ! $CC -v 2>&1 | fgrep ming > /dev/null ; then + echo 'int main() {bfd_init();bfd_openr("/dev/null",0);return 0;}' >foo.c + MP=`$CC -Wl,-M -static -o foo foo.c -lbfd -liberty -ldl 2>&1 | grep -v : | tr '()' '\012\012' | $AWK '{print $NF}' | sort | uniq` + rm -f foo.c foo + if echo $MP | tr ' ' '\012' | grep libbfd.a >/dev/null; then + LIBBFD="`echo $MP | tr ' ' '\012' | grep libbfd.a | $AWK '{i=split($1,A,"/");for (j=1;j<=i;j++) if (j>1 && A[j]=="..") {j--;i-=2;for (k=j;k<=i;k++) A[k]=A[k+2];j--;}} END {for (j=1;j<=i;j++) printf("%s%s",A[j],j!=i ? "/" : "")}'`" + else + as_fn_error $? "cannot locate external libbfd.a" "$LINENO" 5 + fi + if echo $MP | tr ' ' '\012' | grep libiberty.a >/dev/null ; then + LIBIBERTY="`echo $MP | tr ' ' '\012' | grep libiberty.a | $AWK '{i=split($1,A,"/");for (j=1;j<=i;j++) if (j>1 && A[j]=="..") {j--;i-=2;for (k=j;k<=i;k++) A[k]=A[k+2];j--;}} END {for (j=1;j<=i;j++) printf("%s%s",A[j],j!=i ? "/" : "")}'`" + else + as_fn_error $? "cannot locate external libiberty.a" "$LINENO" 5 + fi + BUILD_BFD=copy_bfd + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for inflate in -lz" >&5 +$as_echo_n "checking for inflate in -lz... " >&6; } +if ${ac_cv_lib_z_inflate+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lz $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char inflate (); +int +main () +{ +return inflate (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_z_inflate=yes +else + ac_cv_lib_z_inflate=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_z_inflate" >&5 +$as_echo "$ac_cv_lib_z_inflate" >&6; } +if test "x$ac_cv_lib_z_inflate" = xyes; then : + TLIBS="$TLIBS -lz" +else + as_fn_error $? "Need zlib for bfd linking" "$LINENO" 5 +fi + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for dlsym in -ldl" >&5 +$as_echo_n "checking for dlsym in -ldl... " >&6; } +if ${ac_cv_lib_dl_dlsym+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-ldl $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char dlsym (); +int +main () +{ +return dlsym (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_dl_dlsym=yes +else + ac_cv_lib_dl_dlsym=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dl_dlsym" >&5 +$as_echo "$ac_cv_lib_dl_dlsym" >&6; } +if test "x$ac_cv_lib_dl_dlsym" = xyes; then : + TLIBS="$TLIBS -ldl" +else + as_fn_error $? "Need libdl for bfd linking" "$LINENO" 5 +fi + + + + + + else + TLIBS="$TLIBS -lbfd -liberty -ldl" + fi +fi + +if test "$enable_locbfd" = "yes" ; then + + # check for gettext. It is part of glibc, but others + # need GNU gettext separately. +# AC_CHECK_HEADERS(libintl.h, true, +# AC_MSG_ERROR(libintl.h (gettext) not found)) +# AC_SEARCH_LIBS(dgettext, intl, true, AC_MSG_ERROR(gettext library not found)) + + echo "#" + echo "#" + echo "# -------------------------" + echo "# Subconfigure of LIBINTL" + echo "#" + echo "#" + cd binutils/intl && chmod +x configure && ./configure --disable-nls && cd ../.. +# MY_SUBDIRS="$MY_SUBDIRS binutils/libiberty " + echo "#" + echo "#" + echo "#" + echo "# Subconfigure of LIBINTL done" + echo "# ------------------------------" + echo "#" + echo "#" + echo "#" + echo "# -------------------------" + echo "# Subconfigure of LIBIBERTY" + echo "#" + echo "#" + cd binutils/libiberty && chmod +x configure && ./configure --disable-nls && cd ../.. +# MY_SUBDIRS="$MY_SUBDIRS binutils/libiberty " + echo "#" + echo "#" + echo "#" + echo "# Subconfigure of LIBIBERTY done" + echo "# ------------------------------" + echo "#" + echo "#" + echo "#" + echo "# -------------------" + echo "# Subconfigure of BFD" + echo "#" + echo "#" + cd binutils/bfd && chmod +x configure && ./configure --with-included-gettext --disable-nls && cd ../.. +# MY_SUBDIRS="$MY_SUBDIRS binutils/bfd " + echo "#" + echo "#" + echo "#" + echo "# Subconfigure of BFD done" + echo "# ------------------------" + echo "#" +# TLIBS="$TLIBS `pwd`/binutils/bfd/libbfd.a `pwd`/binutils/libiberty/libiberty.a" + +$as_echo "#define HAVE_LIBBFD 1" >>confdefs.h + + BUILD_BFD="h/bfd.h h/bfdlink.h h/ansidecl.h h/symcat.h" + +fi + + +if test "$enable_xdr" = "yes" ; then + ac_fn_c_check_func "$LINENO" "xdr_double" "ac_cv_func_xdr_double" +if test "x$ac_cv_func_xdr_double" = xyes; then : + +$as_echo "#define HAVE_XDR 1" >>confdefs.h + +else + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for xdr_double in -ltirpc" >&5 +$as_echo_n "checking for xdr_double in -ltirpc... " >&6; } +if ${ac_cv_lib_tirpc_xdr_double+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-ltirpc $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char xdr_double (); +int +main () +{ +return xdr_double (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_tirpc_xdr_double=yes +else + ac_cv_lib_tirpc_xdr_double=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_tirpc_xdr_double" >&5 +$as_echo "$ac_cv_lib_tirpc_xdr_double" >&6; } +if test "x$ac_cv_lib_tirpc_xdr_double" = xyes; then : + +$as_echo "#define HAVE_XDR 1" >>confdefs.h + TLIBS="$TLIBS -ltirpc" +else + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for xdr_double in -lrpc" >&5 +$as_echo_n "checking for xdr_double in -lrpc... " >&6; } +if ${ac_cv_lib_rpc_xdr_double+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lrpc $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char xdr_double (); +int +main () +{ +return xdr_double (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_rpc_xdr_double=yes +else + ac_cv_lib_rpc_xdr_double=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_rpc_xdr_double" >&5 +$as_echo "$ac_cv_lib_rpc_xdr_double" >&6; } +if test "x$ac_cv_lib_rpc_xdr_double" = xyes; then : + +$as_echo "#define HAVE_XDR 1" >>confdefs.h + TLIBS="$TLIBS -lrpc" +else + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for xdr_double in -loncrpc" >&5 +$as_echo_n "checking for xdr_double in -loncrpc... " >&6; } +if ${ac_cv_lib_oncrpc_xdr_double+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-loncrpc $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char xdr_double (); +int +main () +{ +return xdr_double (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_oncrpc_xdr_double=yes +else + ac_cv_lib_oncrpc_xdr_double=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_oncrpc_xdr_double" >&5 +$as_echo "$ac_cv_lib_oncrpc_xdr_double" >&6; } +if test "x$ac_cv_lib_oncrpc_xdr_double" = xyes; then : + +$as_echo "#define HAVE_XDR 1" >>confdefs.h + TLIBS="$TLIBS -loncrpc" +fi + +fi + +fi + +fi + +fi + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking __builtin_clzl" >&5 +$as_echo_n "checking __builtin_clzl... " >&6; } +if test "$cross_compiling" = yes; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #include + #include + int main() { + unsigned long u; + long j; + if (__builtin_clzl(0)!=sizeof(long)*8) + return -1; + for (u=1,j=sizeof(long)*8-1;j>=0;j--,u<<=1) + if (__builtin_clzl(u)!=j) + return -1; + return 0; + } +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } + +$as_echo "#define HAVE_CLZL 1" >>confdefs.h + +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking __builtin_ctzl" >&5 +$as_echo_n "checking __builtin_ctzl... " >&6; } +if test "$cross_compiling" = yes; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #include + #include + int main() { + unsigned long u; + long j; + if (__builtin_ctzl(0)!=sizeof(long)*8) + return -1; + for (u=1,j=0;j&5 +$as_echo "yes" >&6; } + +$as_echo "#define HAVE_CTZL 1" >>confdefs.h + +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + + +case $use in + sh4*) ;; #FIXME, these exceptions needed as of gcc 4.7 + hppa*) ;; #FIXME + powerpc*) ;; #FIXME + alpha*) ;; #FIXME + ia64*) ;; #FIXME + *) + { $as_echo "$as_me:${as_lineno-$LINENO}: checking __builtin___clear_cache" >&5 +$as_echo_n "checking __builtin___clear_cache... " >&6; } + if test "$cross_compiling" = yes; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +int +main () +{ + + void *v,*ve; + __builtin___clear_cache(v,ve); + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + +$as_echo "#define HAVE_BUILTIN_CLEAR_CACHE 1" >>confdefs.h + + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi +;; +esac + +#AC_CONFIG_SUBDIRS($MY_SUBDIRS) + +# Find where Data begins. This is used by the storage allocation +# mechanism, in the PAGE macro. This offset is subtracted from +# addresses, in calculating a page for an address in the heap. + +# The cast to long int works around a bug in the HP C Compiler +# version HP92453-01 B.11.11.23709.GP, which incorrectly rejects +# declarations like `int a3[[(sizeof (unsigned char)) >= 0]];'. +# This bug is HP SR number 8606223364. +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking size of long" >&5 +$as_echo_n "checking size of long... " >&6; } +if ${ac_cv_sizeof_long+:} false; then : + $as_echo_n "(cached) " >&6 +else + if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (long))" "ac_cv_sizeof_long" "$ac_includes_default"; then : + +else + if test "$ac_cv_type_long" = yes; then + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error 77 "cannot compute sizeof (long) +See \`config.log' for more details" "$LINENO" 5; } + else + ac_cv_sizeof_long=0 + fi +fi + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_long" >&5 +$as_echo "$ac_cv_sizeof_long" >&6; } + + + +cat >>confdefs.h <<_ACEOF +#define SIZEOF_LONG $ac_cv_sizeof_long +_ACEOF + + + +#### Memory areas and alignment + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for byte order" >&5 +$as_echo_n "checking for byte order... " >&6; } +if test "$cross_compiling" = yes; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + +int +main () +{ + + + /* Are we little or big endian? Adapted from Harbison&Steele. */ + union {long l;char c[sizeof(long)];} u; + u.l = 1; + return u.c[sizeof(long)-1] ? 1 : 0; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + + { $as_echo "$as_me:${as_lineno-$LINENO}: result: little" >&5 +$as_echo "little" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: big" >&5 +$as_echo "big" >&6; } + +$as_echo "#define WORDS_BIGENDIAN 1" >>confdefs.h + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for word order" >&5 +$as_echo_n "checking for word order... " >&6; } +if test "$cross_compiling" = yes; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + +int +main () +{ + + /* Are we little or big endian? Adapted from Harbison&Steele. */ + union {double d;int l[sizeof(double)/sizeof(int)];} u; + u.d = 1.0; + return u.l[sizeof(double)/sizeof(int)-1] ? 0 : 1; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: little" >&5 +$as_echo "little" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: big" >&5 +$as_echo "big" >&6; } + +$as_echo "#define DOUBLE_BIGENDIAN 1" >>confdefs.h + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + + +# pagewidth +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for pagewidth" >&5 +$as_echo_n "checking for pagewidth... " >&6; } +case $use in + mips*) min_pagewidth=14;; + *) min_pagewidth=12;; +esac +if test "$cross_compiling" = yes; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #include + #include + #ifdef __CYGWIN__ + #define getpagesize() 4096 + #endif + +int +main () +{ + + size_t i=getpagesize(),j; + FILE *fp=fopen("conftest1","w"); + for (j=0;i>>=1;j++); + j=j<$min_pagewidth ? $min_pagewidth : j; + fprintf(fp,"%u",j); + return 0; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + PAGEWIDTH=`cat conftest1` +else + PAGEWIDTH=0 +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $PAGEWIDTH" >&5 +$as_echo "$PAGEWIDTH" >&6; } + +cat >>confdefs.h <<_ACEOF +#define PAGEWIDTH $PAGEWIDTH +_ACEOF + + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for required object alignment" >&5 +$as_echo_n "checking for required object alignment... " >&6; } +if test "$cross_compiling" = yes; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #include + #define EXTER + #include "$MP_INCLUDE" + #include "./h/enum.h" + #define OBJ_ALIGN + #include "./h/type.h" + #include "./h/lu.h" + #include "./h/object.h" + +int +main () +{ + + unsigned long i; + FILE *fp=fopen("conftest1","w"); + for (i=1;i && NOT_OBJECT_ALIGNED(i); i<<=1); + if (!i) return -1; + fprintf(fp,"%lu",i); + fclose(fp); + return 0; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + obj_align=`cat conftest1` + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $obj_align" >&5 +$as_echo "$obj_align" >&6; } + +cat >>confdefs.h <<_ACEOF +#define OBJ_ALIGNMENT $obj_align +_ACEOF + +else + as_fn_error $? "Cannot find object alignent" "$LINENO" 5 +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for C extension variable alignment" >&5 +$as_echo_n "checking for C extension variable alignment... " >&6; } +if test "$cross_compiling" = yes; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ + + char *v __attribute__ ((aligned ($obj_align))); + return 0; + ; + return 0; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + obj_align="__attribute__ ((aligned ($obj_align)))" +else + as_fn_error $? "Need alignment attributes" "$LINENO" 5 +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $obj_align" >&5 +$as_echo "$obj_align" >&6; } + +cat >>confdefs.h <<_ACEOF +#define OBJ_ALIGN $obj_align +_ACEOF + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for C extension noreturn function attribute" >&5 +$as_echo_n "checking for C extension noreturn function attribute... " >&6; } +if test "$cross_compiling" = yes; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ + + extern int v() __attribute__ ((noreturn)); + return 0; + ; + return 0; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + no_return="__attribute__ ((noreturn))" +else + no_return= +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $no_return" >&5 +$as_echo "$no_return" >&6; } + +cat >>confdefs.h <<_ACEOF +#define NO_RETURN $no_return +_ACEOF + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking sizeof struct contblock" >&5 +$as_echo_n "checking sizeof struct contblock... " >&6; } + +# work around MSYS pwd result incompatibility +if test "$use" = "mingw" ; then +if test "$cross_compiling" = yes; then : + echo Cannot find sizeof struct contblock;exit 1 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include + #define EXTER + #include "$MP_INCLUDE" + #include "h/enum.h" + #include "h/type.h" + #include "h/lu.h" + #include "h/object.h" + int main(int argc,char **argv,char **envp) { + FILE *f=fopen("conftest1","w"); + fprintf(f,"%u",sizeof(struct contblock)); + fclose(f); + return 0; + } +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + sizeof_contblock=`cat conftest1` +else + echo Cannot find sizeof struct contblock;exit 1 +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + +else +if test "$cross_compiling" = yes; then : + echo Cannot find sizeof struct contblock;exit 1 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include + #define EXTER + #include "$MP_INCLUDE" + #include "`pwd`/h/enum.h" + #include "`pwd`/h/type.h" + #include "`pwd`/h/lu.h" + #include "`pwd`/h/object.h" + int main(int argc,char **argv,char **envp) { + FILE *f=fopen("conftest1","w"); + fprintf(f,"%u",sizeof(struct contblock)); + fclose(f); + return 0; + } +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + sizeof_contblock=`cat conftest1` +else + echo Cannot find sizeof struct contblock;exit 1 +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $sizeof_contblock" >&5 +$as_echo "$sizeof_contblock" >&6; } + +cat >>confdefs.h <<_ACEOF +#define SIZEOF_CONTBLOCK $sizeof_contblock +_ACEOF + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for sbrk" >&5 +$as_echo_n "checking for sbrk... " >&6; } +HAVE_SBRK="" +if test "$cross_compiling" = yes; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no: WARNING you must be able to emulate sbrk: as on mingw or macosx" >&5 +$as_echo "no: WARNING you must be able to emulate sbrk: as on mingw or macosx" >&6; } +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include + #include + int main() { + FILE *f; + if (!(f=fopen("conftest1","w"))) + return -1; + fprintf(f,"%u",sbrk(0)); + return 0; + } +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + HAVE_SBRK=1 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no: WARNING you must be able to emulate sbrk: as on mingw or macosx" >&5 +$as_echo "no: WARNING you must be able to emulate sbrk: as on mingw or macosx" >&6; } +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + +if test "$use" = "386-macosx" ; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: emulating sbrk for mac" >&5 +$as_echo "emulating sbrk for mac" >&6; }; + HAVE_SBRK=0 +fi + +if test "$HAVE_SBRK" = "1" ; then + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ADDR_NO_RANDOMIZE constant" >&5 +$as_echo_n "checking for ADDR_NO_RANDOMIZE constant... " >&6; } + if test "$cross_compiling" = yes; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #include + #include + +int +main () +{ + + FILE *f; + if (!(f=fopen("conftest1","w"))) return -1; + fprintf(f,"%x",ADDR_NO_RANDOMIZE); + return 0; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + ADDR_NO_RANDOMIZE=`cat conftest1` + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes $ADDR_NO_RANDOMIZE" >&5 +$as_echo "yes $ADDR_NO_RANDOMIZE" >&6; } +else + ADDR_NO_RANDOMIZE=0 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no assuming 0x40000" >&5 +$as_echo "no assuming 0x40000" >&6; } + +cat >>confdefs.h <<_ACEOF +#define ADDR_NO_RANDOMIZE 0x40000 +_ACEOF + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ADDR_COMPAT_LAYOUT constant" >&5 +$as_echo_n "checking for ADDR_COMPAT_LAYOUT constant... " >&6; } + if test "$cross_compiling" = yes; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #include + #include + +int +main () +{ + + FILE *f; + if (!(f=fopen("conftest1","w"))) return -1; + fprintf(f,"%x",ADDR_COMPAT_LAYOUT); + return 0; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + ADDR_COMPAT_LAYOUT=`cat conftest1` + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes $ADDR_COMPAT_LAYOUT" >&5 +$as_echo "yes $ADDR_COMPAT_LAYOUT" >&6; } +else + ADDR_COMPAT_LAYOUT=0 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } + +cat >>confdefs.h <<_ACEOF +#define ADDR_COMPAT_LAYOUT 0 +_ACEOF + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ADDR_LIMIT_3GB constant" >&5 +$as_echo_n "checking for ADDR_LIMIT_3GB constant... " >&6; } + if test "$cross_compiling" = yes; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #include + #include + +int +main () +{ + + FILE *f; + if (!(f=fopen("conftest1","w"))) return -1; + fprintf(f,"%x",ADDR_LIMIT_3GB); + return 0; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + ADDR_LIMIT_3GB=`cat conftest1` + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes $ADDR_LIMIT_3GB" >&5 +$as_echo "yes $ADDR_LIMIT_3GB" >&6; } +else + ADDR_LIMIT_3GB=0 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } + +cat >>confdefs.h <<_ACEOF +#define ADDR_LIMIT_3GB 0 +_ACEOF + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for personality(ADDR_NO_RANDOMIZE) support" >&5 +$as_echo_n "checking for personality(ADDR_NO_RANDOMIZE) support... " >&6; } + if test "$cross_compiling" = yes; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #include + #include + void gprof_cleanup() {}; + int main(int argc,char **argv,char **envp) { + #include "h/unrandomize.h" + return 0;} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } + +$as_echo "#define CAN_UNRANDOMIZE_SBRK 1" >>confdefs.h + +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking that sbrk is (now) non-random" >&5 +$as_echo_n "checking that sbrk is (now) non-random... " >&6; } + if test "$cross_compiling" = yes; then : + SBRK=0 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include + #include + void gprof_cleanup() {}; + int main(int argc,char * argv[],char * envp[]) { + FILE *f; + #ifdef CAN_UNRANDOMIZE_SBRK + #include "h/unrandomize.h" + #endif + if (!(f=fopen("conftest1","w"))) return -1; + fprintf(f,"%u",sbrk(0)); + return 0;} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + SBRK=`cat conftest1` +else + SBRK=0 +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + if test "$SBRK" = "0" ; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: cannot trap sbrk" >&5 +$as_echo "cannot trap sbrk" >&6; } + exit 1 + fi + if test "$cross_compiling" = yes; then : + SBRK1=0 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include + #include + void gprof_cleanup() {}; + int main(int argc,char * argv[],char * envp[]) { + FILE *f; + #ifdef CAN_UNRANDOMIZE_SBRK + #include "h/unrandomize.h" + #endif + if (!(f=fopen("conftest1","w"))) return -1; + fprintf(f,"%u",sbrk(0)); + return 0;} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + SBRK1=`cat conftest1` +else + SBRK1=0 +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + if test "$SBRK1" = "0" ; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: cannot trap sbrk" >&5 +$as_echo "cannot trap sbrk" >&6; } + exit 1 + fi + if test "$SBRK" = "$SBRK1" ; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } + else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } + echo "Cannot build with randomized sbrk. Your options:" + echo " - upgrade to a kernel/libc that knows about personality(ADDR_NO_RANDOMIZE)" + echo " - recompile your kernel with CONFIG_COMPAT_BRK (if it has that option)" + echo " - run sysctl kernel.randomize_va_space=0 before using gcl" + exit 1 + fi +fi + + + + + + + + + + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking CSTACK_ADDRESS" >&5 +$as_echo_n "checking CSTACK_ADDRESS... " >&6; } +if test "$cross_compiling" = yes; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #include + #include + void * + foo() { + int i; + return (void *)&i; + } + + void gprof_cleanup() {}; + int main(int argc,char **argv,char **envp) { + void *v ; + FILE *fp = fopen("conftest1","w"); + unsigned long i,j; + + #ifdef CAN_UNRANDOMIZE_SBRK + #include "h/unrandomize.h" + #endif + j=1; + j<<=$PAGEWIDTH; + j<<=16; + i=(unsigned long)&v; + if (foo()>i) i-=j; + j--; + i+=j; + i&=~j; + fprintf(fp,"0x%lx",i-1); + fclose(fp); + return 0; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + cstack_address=`cat conftest1` +else + cstack_address=0 +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + +cat >>confdefs.h <<_ACEOF +#define CSTACK_ADDRESS $cstack_address +_ACEOF + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $cstack_address" >&5 +$as_echo "$cstack_address" >&6; } + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking cstack bits" >&5 +$as_echo_n "checking cstack bits... " >&6; } +if test "$cross_compiling" = yes; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #include + #include + void * + foo() { + int i; + return (void *)&i; + } + + void gprof_cleanup() {}; + int main(int argc,char **argv,char **envp) { + void *v ; + FILE *fp = fopen("conftest1","w"); + unsigned long i,j; + + #ifdef CAN_UNRANDOMIZE_SBRK + #include "h/unrandomize.h" + #endif + j=1; + j<<=$PAGEWIDTH; + j<<=16; + i=(unsigned long)&v; + if (foo()>i) i-=j; + j--; + i+=j; + i&=~j; + for (j=0;(i>>j)!=(i>>(sizeof(long)*8-1));j++); + fprintf(fp,"%d",j); + fclose(fp); + return 0; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + cstack_bits=`cat conftest1` +else + cstack_bits=0 +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + +cat >>confdefs.h <<_ACEOF +#define CSTACK_BITS $cstack_bits +_ACEOF + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $cstack_bits" >&5 +$as_echo "$cstack_bits" >&6; } + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking NEG_CSTACK_ADDRESS" >&5 +$as_echo_n "checking NEG_CSTACK_ADDRESS... " >&6; } +if test "$cross_compiling" = yes; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #include + #include + void gprof_cleanup() {}; + int main(int argc,char **argv,char **envp) { + #ifdef CAN_UNRANDOMIZE_SBRK + #include "h/unrandomize.h" + #endif + return (long)$cstack_address<0 ? 0 : -1; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } + neg_cstack_address=1 + +$as_echo "#define NEG_CSTACK_ADDRESS 1" >>confdefs.h + +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } + neg_cstack_address=0 +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking finding CSTACK_ALIGNMENT" >&5 +$as_echo_n "checking finding CSTACK_ALIGNMENT... " >&6; } +if test "$cross_compiling" = yes; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #include + #include + void gprof_cleanup() {}; + int main(int argc,char **argv,char **envp) { + void *b,*c; + FILE *fp = fopen("conftest1","w"); + long n; + #ifdef CAN_UNRANDOMIZE_SBRK + #include "h/unrandomize.h" + #endif + b=alloca(sizeof(b)); + c=alloca(sizeof(c)); + n=b>c ? b-c : c-b; + n=n>sizeof(c) ? n : 1; + fprintf(fp,"%ld",n); + fclose(fp); + return 0; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + cstack_alignment=`cat conftest1` +else + cstack_alignment=0 +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + +cat >>confdefs.h <<_ACEOF +#define CSTACK_ALIGNMENT $cstack_alignment +_ACEOF + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $cstack_alignment" >&5 +$as_echo "$cstack_alignment" >&6; } + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking CSTACK_DIRECTION" >&5 +$as_echo_n "checking CSTACK_DIRECTION... " >&6; } +if test "$cross_compiling" = yes; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #include + #include + void * + foo(void) { + int i; + return (void *)&i; + } + + void gprof_cleanup() {}; + int main(int argc,char **argv,char **envp) { + char *b; + FILE *fp = fopen("conftest1","w"); + #ifdef CAN_UNRANDOMIZE_SBRK + #include "h/unrandomize.h" + #endif + fprintf(fp,"%d",((long) &b) > ((long) foo()) ? -1 : 1); + fclose(fp); + return 0; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + cstack_direction=`cat conftest1` +else + cstack_direction=0 +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + +cat >>confdefs.h <<_ACEOF +#define CSTACK_DIRECTION $cstack_direction +_ACEOF + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $cstack_direction" >&5 +$as_echo "$cstack_direction" >&6; } + + + + +if test "$use" != "386-gnu" ; then #hurd can push .data below C stack, but sbrk(0) remains above, foiling unexec + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking finding default linker script" >&5 +$as_echo_n "checking finding default linker script... " >&6; } + touch unixport/gcl.script + echo "int main() {return 0;}" >foo.c + $CC -Wl,--verbose foo.c -o foo 2>&1 | \ + $AWK '/\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=/ {i=1-i;next} {if (i) print}' >gcl.script + rm -rf foo.c foo + + if test "`cat gcl.script | wc -l`" != "0" ; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: got it" >&5 +$as_echo "got it" >&6; } + { $as_echo "$as_me:${as_lineno-$LINENO}: trying to adjust text start" >&5 +$as_echo "$as_me: trying to adjust text start" >&6;} + cp gcl.script gcl.script.def + + n=-1; + k=0; + lim=`$AWK 'END {printf("%d\n",m*8-2)}' m=$ac_cv_sizeof_long`; + max=0; + min=$lim; + while test $n -lt $lim ; do + j=`$AWK 'END {for (i=j=0;j<=n;j++) i=i ? i*2 : 1;printf("%x\n",3*i)}' n=$n gcl.script +# diff -u gcl.script.def gcl.script + echo "int main() {return 0;}" >foo.c + if ( $CC -Wl,-T gcl.script foo.c -o foo && ./foo ) >/dev/null 2>&1 ; then + if test $n -lt $min ; then min=$n; fi; + if test $n -gt $max; then max=$n; fi; + elif test $max -gt 0 ; then + break; + fi; + n=`$AWK 'END {print n+1}' n=$n &5 +$as_echo "$as_me: min log text start $min" >&6;} + { $as_echo "$as_me:${as_lineno-$LINENO}: max log text start $max" >&5 +$as_echo "$as_me: max log text start $max" >&6;} + + if test $neg_cstack_address -eq 1 ; then #FIXME test this + if test $cstack_bits -lt $max ; then + max=$cstack_bits; + { $as_echo "$as_me:${as_lineno-$LINENO}: max log text start reduced to $max considering c stack address" >&5 +$as_echo "$as_me: max log text start reduced to $max considering c stack address" >&6;} + fi + fi + + j=-1; + low_shft=""; + if test $min -le $max ; then + if test $max -ge $enable_fastimmfix && test "$enable_immfix" = "yes" ; then + j=`$AWK 'END {for (i=j=0;j<=n;j++) i=i ? i*2 : 1;printf("%x\n",3*i)}' n=$max &5 +$as_echo "$as_me: raising log text to $j for a $max bit wide low immfix table" >&6;} + else + j=`$AWK 'END {for (i=j=0;j<=n;j++) i=i ? i*2 : 1;printf("%x\n",3*i)}' n=$min &5 +$as_echo "$as_me: lowering log text to $j to maximize data area" >&6;} + fi + fi + + if test "$low_shft" != "" ; then + +cat >>confdefs.h <<_ACEOF +#define LOW_SHFT $low_shft +_ACEOF + + +cat >>confdefs.h <<_ACEOF +#define OBJNULL (object)0x$j +_ACEOF + + else + +cat >>confdefs.h <<_ACEOF +#define OBJNULL NULL +_ACEOF + + fi + +# echo $j; + { $as_echo "$as_me:${as_lineno-$LINENO}: checking our linker script" >&5 +$as_echo_n "checking our linker script... " >&6; } + if test "$j" -ne "-1" ; then + cat gcl.script.def | $AWK '/SIZEOF_HEADERS/ {gsub("0x[0-9]*","0x" j,$0);} {print}' j=$j >gcl.script + { $as_echo "$as_me:${as_lineno-$LINENO}: result: done" >&5 +$as_echo "done" >&6; } + rm -f gcl.script.def + LDFLAGS="$LDFLAGS -Wl,-T gcl.script " + cp gcl.script unixport + else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: none found or not needed" >&5 +$as_echo "none found or not needed" >&6; } + rm -f gcl.script gcl.script.def + fi + rm -rf foo.c foo + else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: not found" >&5 +$as_echo "not found" >&6; } + fi + +else + + +cat >>confdefs.h <<_ACEOF +#define OBJNULL NULL +_ACEOF + + +fi + + + + + + + + + + + + + + +mem_top=0 +mem_range=0 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking mem top" >&5 +$as_echo_n "checking mem top... " >&6; } +if test "$cross_compiling" = yes; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #include + +int +main () +{ + + void *v; + unsigned long i,j,k,l,m; + FILE *fp = fopen("conftest1","w"); + + for (i=2,k=1;i;k=i,i<<=1); + l=$cstack_address; + l=$cstack_direction==1 ? (l>=1,i|=j); + if (j<(k>>3)) i=0; + j=1; + j<<=$PAGEWIDTH; + j<<=4; + j--; + i+=j; + i&=~j; + fprintf(fp,"0x%lx",i); + fclose(fp); + return 0; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + mem_top=`cat conftest1` +else + mem_top="0x0" +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $mem_top" >&5 +$as_echo "$mem_top" >&6; } +if test "$mem_top" != "0x0" ; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking finding upper mem half range" >&5 +$as_echo_n "checking finding upper mem half range... " >&6; } + if test "$cross_compiling" = yes; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #include + +int +main () +{ + + unsigned long j; + FILE *fp = fopen("conftest1","w"); + + for (j=1;j && !(j& $mem_top);j<<=1); + fprintf(fp,"0x%lx",j>>1); + fclose(fp); + return 0; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + mem_range=`cat conftest1` +else + mem_range="0x0" +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $mem_range" >&5 +$as_echo "$mem_range" >&6; } + if test "$mem_range" != "0x0" ; then + +cat >>confdefs.h <<_ACEOF +#define MEM_TOP $mem_top +_ACEOF + + +cat >>confdefs.h <<_ACEOF +#define MEM_RANGE $mem_range +_ACEOF + + fi +fi + +if test "$enable_immfix" = "yes" ; then + if test "$mem_top" != "0x0" ; then + if test "$mem_range" != "0x0" ; then + +cat >>confdefs.h <<_ACEOF +#define IM_FIX_BASE $mem_top +_ACEOF + + +cat >>confdefs.h <<_ACEOF +#define IM_FIX_LIM $mem_range +_ACEOF + + fi + fi +fi + + + + +# On systems with execshield, brk is randomized. We need to catch +# this and restore the traditional behavior here + + + + + + + + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking sizeof long long int" >&5 +$as_echo_n "checking sizeof long long int... " >&6; } +if test "$cross_compiling" = yes; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #include + +int +main () +{ + + if (sizeof(long long int) == 2*sizeof(long)) return 0; + return 1; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + +$as_echo "#define HAVE_LONG_LONG 1" >>confdefs.h + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + + + + +for ac_header in dirent.h +do : + ac_fn_c_check_header_mongrel "$LINENO" "dirent.h" "ac_cv_header_dirent_h" "$ac_includes_default" +if test "x$ac_cv_header_dirent_h" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_DIRENT_H 1 +_ACEOF + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for d_type" >&5 +$as_echo_n "checking for d_type... " >&6; } + if test "$cross_compiling" = yes; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #include + +int +main () +{ + + struct dirent d; + return d.d_type=0; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } +$as_echo "#define HAVE_D_TYPE 1" >>confdefs.h + +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + +fi + +done + + +# readline +# Check whether --enable-readline was given. +if test "${enable_readline+set}" = set; then : + enableval=$enable_readline; +else + enable_readline="yes" +fi + + +# ansi lisp +# Check whether --enable-ansi was given. +if test "${enable_ansi+set}" = set; then : + enableval=$enable_ansi; +else + enable_ansi="no" +fi + + +if test "$enable_ansi" = "yes" ; then + SYSTEM=ansi_gcl + +$as_echo "#define ANSI_COMMON_LISP 1" >>confdefs.h + + CLSTANDARD=ANSI +else + SYSTEM=gcl + CLSTANDARD=CLtL1 +fi + +FLISP="saved_$SYSTEM" + + + + +# Maximum number of pages + + + +# Check if Posix compliant getcwd exists, if not we'll use getwd. +for ac_func in getcwd +do : + ac_fn_c_check_func "$LINENO" "getcwd" "ac_cv_func_getcwd" +if test "x$ac_cv_func_getcwd" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_GETCWD 1 +_ACEOF + +fi +done + +for ac_func in getwd +do : + ac_fn_c_check_func "$LINENO" "getwd" "ac_cv_func_getwd" +if test "x$ac_cv_func_getwd" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_GETWD 1 +_ACEOF + +fi +done + +ac_fn_c_check_func "$LINENO" "uname" "ac_cv_func_uname" +if test "x$ac_cv_func_uname" = xyes; then : + +else + +$as_echo "#define NO_UNAME 1" >>confdefs.h + +fi + +ac_fn_c_check_func "$LINENO" "gettimeofday" "ac_cv_func_gettimeofday" +if test "x$ac_cv_func_gettimeofday" = xyes; then : + +else + $as_echo "#define NO_GETTOD 1" >>confdefs.h + +fi + + + +for ac_header in sys/ioctl.h +do : + ac_fn_c_check_header_mongrel "$LINENO" "sys/ioctl.h" "ac_cv_header_sys_ioctl_h" "$ac_includes_default" +if test "x$ac_cv_header_sys_ioctl_h" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_SYS_IOCTL_H 1 +_ACEOF + +fi + +done + + +# OpenBSD has elf_abi.h instead of elf.h +for ac_header in elf.h elf_abi.h +do : + as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` +ac_fn_c_check_header_mongrel "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default" +if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : + cat >>confdefs.h <<_ACEOF +#define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 +_ACEOF + +fi + +done + + +for ac_header in sys/sockio.h +do : + ac_fn_c_check_header_mongrel "$LINENO" "sys/sockio.h" "ac_cv_header_sys_sockio_h" "$ac_includes_default" +if test "x$ac_cv_header_sys_sockio_h" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_SYS_SOCKIO_H 1 +_ACEOF + +fi + +done + + + +#-------------------------------------------------------------------- +# The code below deals with several issues related to gettimeofday: +# 1. Some systems don't provide a gettimeofday function at all +# (set NO_GETTOD if this is the case). +# 2. SGI systems don't use the BSD form of the gettimeofday function, +# but they have a BSDgettimeofday function that can be used instead. +# 3. See if gettimeofday is declared in the header file. +# if not, set the GETTOD_NOT_DECLARED flag so that tclPort.h can +# declare it. +#-------------------------------------------------------------------- + +ac_fn_c_check_func "$LINENO" "BSDgettimeofday" "ac_cv_func_BSDgettimeofday" +if test "x$ac_cv_func_BSDgettimeofday" = xyes; then : + +$as_echo "#define HAVE_BSDGETTIMEOFDAY 1" >>confdefs.h + +else + ac_fn_c_check_func "$LINENO" "gettimeofday" "ac_cv_func_gettimeofday" +if test "x$ac_cv_func_gettimeofday" = xyes; then : + +else + +$as_echo "#define NO_GETTOD 1" >>confdefs.h + +fi + +fi + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for gettimeofday declaration" >&5 +$as_echo_n "checking for gettimeofday declaration... " >&6; } + +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "gettimeofday" >/dev/null 2>&1; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: present" >&5 +$as_echo "present" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: missing" >&5 +$as_echo "missing" >&6; } + +$as_echo "#define GETTOD_NOT_DECLARED 1" >>confdefs.h + +fi +rm -f conftest* + + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for sin in -lm" >&5 +$as_echo_n "checking for sin in -lm... " >&6; } +if ${ac_cv_lib_m_sin+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lm $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char sin (); +int +main () +{ +return sin (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_m_sin=yes +else + ac_cv_lib_m_sin=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_m_sin" >&5 +$as_echo "$ac_cv_lib_m_sin" >&6; } +if test "x$ac_cv_lib_m_sin" = xyes; then : + LIBS="${LIBS} -lm" +else + true +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for main in -lmingwex" >&5 +$as_echo_n "checking for main in -lmingwex... " >&6; } +if ${ac_cv_lib_mingwex_main+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lmingwex $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +int +main () +{ +return main (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_mingwex_main=yes +else + ac_cv_lib_mingwex_main=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_mingwex_main" >&5 +$as_echo "$ac_cv_lib_mingwex_main" >&6; } +if test "x$ac_cv_lib_mingwex_main" = xyes; then : + LIBS="${LIBS} -lmingwex" +else + true +fi + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for buggy maximum sscanf length" >&5 +$as_echo_n "checking for buggy maximum sscanf length... " >&6; } +if test "$cross_compiling" = yes; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + + #include + +int +main () +{ + + char *s= "2.7182818284590452353602874713526624977572470936999595749669676277240766303535475945713821785251664274274663919320030599218174135966290435729003342952605956307381323286279434907632338298807531952510190115738341879307021540891499348841675092447614606680822648001684774118537423454424371075390777449920695517027618386062613313845830007520449338265602976067371132007093287091274437470472306969772093101416928368190255151086574637721112523897844250569536967707854499699679468644549059879316368892300987931277361782154249992295763514822082698951936680331825288693984964651058209392398294887933203625094431173012381970684161404"; + int n, m; + double f; + char *endptr; + FILE *fp=fopen("conftest1","w"); + + n=sscanf(s,"%lf%n",&f,&m); + fprintf(fp,"%d",m); + fclose(fp); + return s[m]; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: none" >&5 +$as_echo "none" >&6; } +else + buggy_maximum_sscanf_length=`cat conftest1` + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $buggy_maximum_sscanf_length" >&5 +$as_echo "$buggy_maximum_sscanf_length" >&6; } + +cat >>confdefs.h <<_ACEOF +#define BUGGY_MAXIMUM_SSCANF_LENGTH $buggy_maximum_sscanf_length +_ACEOF + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + + +EXTRA_LOBJS= +if test "$try_japi" = "yes" ; then + for ac_header in japi.h +do : + ac_fn_c_check_header_mongrel "$LINENO" "japi.h" "ac_cv_header_japi_h" "$ac_includes_default" +if test "x$ac_cv_header_japi_h" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_JAPI_H 1 +_ACEOF + $as_echo "#define HAVE_JAPI_H 1" >>confdefs.h + + EXTRA_LOBJS="${EXTRA_LOBJS} gcl_japi.o" + LIBS="${LIBS} -ljapi -lwsock32" +fi + +done + +fi + +# Should really find a way to check for prototypes, but this +# basically works for now. CM +# +for ac_header in math.h +do : + ac_fn_c_check_header_mongrel "$LINENO" "math.h" "ac_cv_header_math_h" "$ac_includes_default" +if test "x$ac_cv_header_math_h" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_MATH_H 1 +_ACEOF + +$as_echo "#define HAVE_MATH_H 1" >>confdefs.h + +fi + +done + +for ac_header in complex.h +do : + ac_fn_c_check_header_mongrel "$LINENO" "complex.h" "ac_cv_header_complex_h" "$ac_includes_default" +if test "x$ac_cv_header_complex_h" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_COMPLEX_H 1 +_ACEOF + +$as_echo "#define HAVE_COMPLEX_H 1" >>confdefs.h + +fi + +done + + +# +# For DBL_MAX et. al. on (only) certain Linux arches, apparently CM +# +for ac_header in values.h +do : + ac_fn_c_check_header_mongrel "$LINENO" "values.h" "ac_cv_header_values_h" "$ac_includes_default" +if test "x$ac_cv_header_values_h" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_VALUES_H 1 +_ACEOF + +$as_echo "#define HAVE_VALUES_H 1" >>confdefs.h + +fi + +done + + +# +# Sparc solaris keeps this in float.h, rework either/or with values.h later +# +for ac_header in float.h +do : + ac_fn_c_check_header_mongrel "$LINENO" "float.h" "ac_cv_header_float_h" "$ac_includes_default" +if test "x$ac_cv_header_float_h" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_FLOAT_H 1 +_ACEOF + +$as_echo "#define HAVE_FLOAT_H 1" >>confdefs.h + +fi + +done + + +# +# The second alternative is for solaris. This needs to be +# a more comprehensive later, i.e. checking that the fpclass +# test makes sense. CM +# +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for isnormal" >&5 +$as_echo_n "checking for isnormal... " >&6; } +if test "$cross_compiling" = yes; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #define _GNU_SOURCE + #include + +int +main () +{ + + float f; + return isnormal(f) || !isnormal(f) ? 0 : 1; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + +$as_echo "#define HAVE_ISNORMAL 1" >>confdefs.h + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for fpclass in ieeefp.h" >&5 +$as_echo_n "checking for fpclass in ieeefp.h... " >&6; } + if test "$cross_compiling" = yes; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #include + +int +main () +{ + + float f; + return fpclass(f)>=FP_NZERO || fpclass(f)>confdefs.h + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for isfinite" >&5 +$as_echo_n "checking for isfinite... " >&6; } +if test "$cross_compiling" = yes; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #define _GNU_SOURCE + #include + +int +main () +{ + + float f; + return isfinite(f) || !isfinite(f) ? 0 : 1; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + +$as_echo "#define HAVE_ISFINITE 1" >>confdefs.h + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for finite()" >&5 +$as_echo_n "checking for finite()... " >&6; } + if test "$cross_compiling" = yes; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #include + #include + +int +main () +{ + + float f; + return finite(f) || !finite(f) ? 0 : 1; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + +$as_echo "#define HAVE_FINITE 1" >>confdefs.h + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } +else + as_fn_error $? "no" "$LINENO" 5 +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + + + +#-------------------------------------------------------------------- +# Check for the existence of the -lsocket and -lnsl libraries. +# The order here is important, so that they end up in the right +# order in the command line generated by make. Here are some +# special considerations: +# 1. Use "connect" and "accept" to check for -lsocket, and +# "gethostbyname" to check for -lnsl. +# 2. Use each function name only once: can't redo a check because +# autoconf caches the results of the last check and won't redo it. +# 3. Use -lnsl and -lsocket only if they supply procedures that +# aren't already present in the normal libraries. This is because +# IRIX 5.2 has libraries, but they aren't needed and they're +# bogus: they goof up name resolution if used. +# 4. On some SVR4 systems, can't use -lsocket without -lnsl too. +# To get around this problem, check for both libraries together +# if -lsocket doesn't work by itself. +#-------------------------------------------------------------------- +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for sockets" >&5 +$as_echo_n "checking for sockets... " >&6; } +tcl_checkBoth=0 +ac_fn_c_check_func "$LINENO" "connect" "ac_cv_func_connect" +if test "x$ac_cv_func_connect" = xyes; then : + tcl_checkSocket=0 +else + tcl_checkSocket=1 +fi + +if test "$tcl_checkSocket" = 1; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for main in -lsocket" >&5 +$as_echo_n "checking for main in -lsocket... " >&6; } +if ${ac_cv_lib_socket_main+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lsocket $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +int +main () +{ +return main (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_socket_main=yes +else + ac_cv_lib_socket_main=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_socket_main" >&5 +$as_echo "$ac_cv_lib_socket_main" >&6; } +if test "x$ac_cv_lib_socket_main" = xyes; then : + TLIBS="$TLIBS -lsocket" +else + tcl_checkBoth=1 +fi + +fi + + +if test "$tcl_checkBoth" = 1; then + tk_oldLibs=$TLIBS + TLIBS="$TLIBS -lsocket -lnsl" + ac_fn_c_check_func "$LINENO" "accept" "ac_cv_func_accept" +if test "x$ac_cv_func_accept" = xyes; then : + tcl_checkNsl=0 +else + TLIBS=$tk_oldLibs +fi + +fi +ac_fn_c_check_func "$LINENO" "gethostbyname" "ac_cv_func_gethostbyname" +if test "x$ac_cv_func_gethostbyname" = xyes; then : + +else + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for main in -lnsl" >&5 +$as_echo_n "checking for main in -lnsl... " >&6; } +if ${ac_cv_lib_nsl_main+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lnsl $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +int +main () +{ +return main (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_nsl_main=yes +else + ac_cv_lib_nsl_main=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_nsl_main" >&5 +$as_echo "$ac_cv_lib_nsl_main" >&6; } +if test "x$ac_cv_lib_nsl_main" = xyes; then : + TLIBS="$TLIBS -lnsl" +fi + +fi + + +RL_OBJS="" +RL_LIB="" +if test "$enable_readline" = "yes" ; then + for ac_header in readline/readline.h +do : + ac_fn_c_check_header_mongrel "$LINENO" "readline/readline.h" "ac_cv_header_readline_readline_h" "$ac_includes_default" +if test "x$ac_cv_header_readline_readline_h" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_READLINE_READLINE_H 1 +_ACEOF + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for rl_initialize in -lreadline" >&5 +$as_echo_n "checking for rl_initialize in -lreadline... " >&6; } +if ${ac_cv_lib_readline_rl_initialize+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lreadline $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char rl_initialize (); +int +main () +{ +return rl_initialize (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_readline_rl_initialize=yes +else + ac_cv_lib_readline_rl_initialize=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_readline_rl_initialize" >&5 +$as_echo "$ac_cv_lib_readline_rl_initialize" >&6; } +if test "x$ac_cv_lib_readline_rl_initialize" = xyes; then : + +$as_echo "#define HAVE_READLINE 1" >>confdefs.h + + TLIBS="$TLIBS -lreadline" #some machines don't link this, e.g. Slackware + RL_OBJS=gcl_readline.o +# Readline support now initialized automatically when compiled in, this lisp +# object no longer needed -- 20040102 CM +# RL_LIB=lsp/gcl_readline.o + +fi + +fi + +done + + +# These tests discover differences between readline 4.1 and 4.3 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for rl_completion_matches in -lreadline" >&5 +$as_echo_n "checking for rl_completion_matches in -lreadline... " >&6; } +if ${ac_cv_lib_readline_rl_completion_matches+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lreadline $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char rl_completion_matches (); +int +main () +{ +return rl_completion_matches (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_readline_rl_completion_matches=yes +else + ac_cv_lib_readline_rl_completion_matches=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_readline_rl_completion_matches" >&5 +$as_echo "$ac_cv_lib_readline_rl_completion_matches" >&6; } +if test "x$ac_cv_lib_readline_rl_completion_matches" = xyes; then : + +$as_echo "#define HAVE_DECL_RL_COMPLETION_MATCHES 1" >>confdefs.h + + +$as_echo "#define HAVE_RL_COMPENTRY_FUNC_T 1" >>confdefs.h + +fi + +fi + + + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking For network code for nsocket.c" >&5 +$as_echo_n "checking For network code for nsocket.c... " >&6; } +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +#include +#include +#include + +#include +#include +#include + +/************* for the sockets ******************/ +#include /* struct sockaddr, SOCK_STREAM, ... */ +#ifndef NO_UNAME +# include /* uname system call. */ +#endif +#include /* struct in_addr, struct sockaddr_in */ +#include /* inet_ntoa() */ +#include /* gethostbyname() */ + +int +main () +{ + connect(0,(struct sockaddr *)0,0); + gethostbyname("jil"); + socket(AF_INET, SOCK_STREAM, 0); + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + +$as_echo "#define HAVE_NSOCKET 1" >>confdefs.h + + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking check for listen using fcntl" >&5 +$as_echo_n "checking check for listen using fcntl... " >&6; } +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +#include + +int +main () +{ +FILE *fp=fopen("configure.in","r"); + int orig; + orig = fcntl(fileno(fp), F_GETFL); + if (! (orig & O_NONBLOCK )) return 0; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + +$as_echo "#define LISTEN_USE_FCNTL 1" >>confdefs.h + + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + + + + +ac_fn_c_check_func "$LINENO" "profil" "ac_cv_func_profil" +if test "x$ac_cv_func_profil" = xyes; then : + +else + +$as_echo "#define NO_PROFILE 1" >>confdefs.h + +fi + + +ac_fn_c_check_func "$LINENO" "setenv" "ac_cv_func_setenv" +if test "x$ac_cv_func_setenv" = xyes; then : + +$as_echo "#define HAVE_SETENV 1" >>confdefs.h + +else + no_setenv=1 +fi + + +if test "$no_setenv" = "1" ; then +ac_fn_c_check_func "$LINENO" "putenv" "ac_cv_func_putenv" +if test "x$ac_cv_func_putenv" = xyes; then : + +$as_echo "#define HAVE_PUTENV 1" >>confdefs.h + +fi + + +fi + +ac_fn_c_check_func "$LINENO" "_cleanup" "ac_cv_func__cleanup" +if test "x$ac_cv_func__cleanup" = xyes; then : + +$as_echo "#define USE_CLEANUP 1" >>confdefs.h + +fi + + +gcl_ok=no + + + + + + +# if test "x$enable_machine" = "x" ; then +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking FIONBIO vs. O_NONBLOCK for nonblocking I/O" >&5 +$as_echo_n "checking FIONBIO vs. O_NONBLOCK for nonblocking I/O... " >&6; } + +case $system in + OSF*) + +$as_echo "#define USE_FIONBIO 1" >>confdefs.h + + { $as_echo "$as_me:${as_lineno-$LINENO}: result: FIONBIO" >&5 +$as_echo "FIONBIO" >&6; } + ;; + SunOS-4*) + +$as_echo "#define USE_FIONBIO 1" >>confdefs.h + + { $as_echo "$as_me:${as_lineno-$LINENO}: result: FIONBIO" >&5 +$as_echo "FIONBIO" >&6; } + ;; + ULTRIX-4.*) + +$as_echo "#define USE_FIONBIO 1" >>confdefs.h + + { $as_echo "$as_me:${as_lineno-$LINENO}: result: FIONBIO" >&5 +$as_echo "FIONBIO" >&6; } + ;; + *) + { $as_echo "$as_me:${as_lineno-$LINENO}: result: O_NONBLOCK" >&5 +$as_echo "O_NONBLOCK" >&6; } + ;; +esac + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking check for SV_ONSTACK" >&5 +$as_echo_n "checking check for SV_ONSTACK... " >&6; } +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +int joe=SV_ONSTACK; + +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + +$as_echo "#define HAVE_SV_ONSTACK 1" >>confdefs.h + + + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking check for SIGSYS" >&5 +$as_echo_n "checking check for SIGSYS... " >&6; } +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +int joe=SIGSYS; + +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + +$as_echo "#define HAVE_SIGSYS 1" >>confdefs.h + + + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking check for SIGEMT" >&5 +$as_echo_n "checking check for SIGEMT... " >&6; } +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +int joe=SIGEMT; + +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + +$as_echo "#define HAVE_SIGEMT 1" >>confdefs.h + + + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + +for ac_func in sigaltstack +do : + ac_fn_c_check_func "$LINENO" "sigaltstack" "ac_cv_func_sigaltstack" +if test "x$ac_cv_func_sigaltstack" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_SIGALTSTACK 1 +_ACEOF + +fi +done + +for ac_func in feenableexcept +do : + ac_fn_c_check_func "$LINENO" "feenableexcept" "ac_cv_func_feenableexcept" +if test "x$ac_cv_func_feenableexcept" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_FEENABLEEXCEPT 1 +_ACEOF + +fi +done + + +for ac_header in dis-asm.h +do : + ac_fn_c_check_header_mongrel "$LINENO" "dis-asm.h" "ac_cv_header_dis_asm_h" "$ac_includes_default" +if test "x$ac_cv_header_dis_asm_h" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_DIS_ASM_H 1 +_ACEOF + MLIBS=$LIBS + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for init_disassemble_info in -lopcodes" >&5 +$as_echo_n "checking for init_disassemble_info in -lopcodes... " >&6; } +if ${ac_cv_lib_opcodes_init_disassemble_info+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lopcodes $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char init_disassemble_info (); +int +main () +{ +return init_disassemble_info (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_opcodes_init_disassemble_info=yes +else + ac_cv_lib_opcodes_init_disassemble_info=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_opcodes_init_disassemble_info" >&5 +$as_echo "$ac_cv_lib_opcodes_init_disassemble_info" >&6; } +if test "x$ac_cv_lib_opcodes_init_disassemble_info" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_LIBOPCODES 1 +_ACEOF + + LIBS="-lopcodes $LIBS" + +fi + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for dlopen in -ldl" >&5 +$as_echo_n "checking for dlopen in -ldl... " >&6; } +if ${ac_cv_lib_dl_dlopen+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-ldl $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char dlopen (); +int +main () +{ +return dlopen (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_dl_dlopen=yes +else + ac_cv_lib_dl_dlopen=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dl_dlopen" >&5 +$as_echo "$ac_cv_lib_dl_dlopen" >&6; } +if test "x$ac_cv_lib_dl_dlopen" = xyes; then : + #opcodes changes too quickly to link directly + for ac_func in print_insn_i386 +do : + ac_fn_c_check_func "$LINENO" "print_insn_i386" "ac_cv_func_print_insn_i386" +if test "x$ac_cv_func_print_insn_i386" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_PRINT_INSN_I386 1 +_ACEOF + LIBS="$MLIBS -ldl" +fi +done + +fi + +fi + +done + + +#if test $use = "386-linux" ; then + for ac_header in asm/sigcontext.h +do : + ac_fn_c_check_header_mongrel "$LINENO" "asm/sigcontext.h" "ac_cv_header_asm_sigcontext_h" "$ac_includes_default" +if test "x$ac_cv_header_asm_sigcontext_h" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_ASM_SIGCONTEXT_H 1 +_ACEOF + +fi + +done + + for ac_header in asm/signal.h +do : + ac_fn_c_check_header_mongrel "$LINENO" "asm/signal.h" "ac_cv_header_asm_signal_h" "$ac_includes_default" +if test "x$ac_cv_header_asm_signal_h" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_ASM_SIGNAL_H 1 +_ACEOF + +fi + +done + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sigcontext..." >&5 +$as_echo_n "checking for sigcontext...... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include + +int +main () +{ + + struct sigcontext foo; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + + sigcontext_works=1; + +$as_echo "#define SIGNAL_H_HAS_SIGCONTEXT 1" >>confdefs.h + + { $as_echo "$as_me:${as_lineno-$LINENO}: result: sigcontext in signal.h" >&5 +$as_echo "sigcontext in signal.h" >&6; } + +else + sigcontext_works=0; + { $as_echo "$as_me:${as_lineno-$LINENO}: result: sigcontext NOT in signal.h" >&5 +$as_echo "sigcontext NOT in signal.h" >&6; } + +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + if test "$sigcontext_works" = 0 ; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sigcontext..." >&5 +$as_echo_n "checking for sigcontext...... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include + #ifdef HAVE_ASM_SIGCONTEXT_H + #include + #endif + #ifdef HAVE_ASM_SIGNAL_H + #include + #endif + +int +main () +{ + + struct sigcontext foo; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + + +$as_echo "#define HAVE_SIGCONTEXT 1" >>confdefs.h + + { $as_echo "$as_me:${as_lineno-$LINENO}: result: sigcontext in asm files" >&5 +$as_echo "sigcontext in asm files" >&6; } + +else + + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no sigcontext found" >&5 +$as_echo "no sigcontext found" >&6; } + +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + + + fi +# echo 'foo() {}' > conftest1.c +# $CC -S conftest1.c +# use_underscore=0 +# if fgrep _foo conftest1.s ; then use_underscore=1 ; fi +# if test $use_underscore = 0 ; then +# MPI_FILE=mpi-386_no_under.o +# else +# MPI_FILE=mpi-386d.o +# fi +# AC_SUBST(MPI_FILE) +# GCC=$CC +# if test -x /usr/bin/i386-glibc20-linux-gcc ; then +# GCC=/usr/bin/i386-glibc20-linux-gcc +# fi +# AC_SUBST(GCC) + +#fi + +# Extract the first word of "emacs", so it can be a program name with args. +set dummy emacs; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_path_EMACS+:} false; then : + $as_echo_n "(cached) " >&6 +else + case $EMACS in + [\\/]* | ?:[\\/]*) + ac_cv_path_EMACS="$EMACS" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_path_EMACS="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +EMACS=$ac_cv_path_EMACS +if test -n "$EMACS"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $EMACS" >&5 +$as_echo "$EMACS" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + + +# check for where the emacs site lisp directory is. +rm -f conftest.el +cat >> conftest.el <&5 +$as_echo_n "checking emacs site lisp directory... " >&6; } +if [ "$EMACS_SITE_LISP" = "unknown" ] ; then + if [ "$EMACS" != "" ] ; then + EMACS_SITE_LISP=`$EMACS -q -batch --no-site-file -l conftest.el 2>&1 | sed -e /Loading/d | sed -e /load/d |sed -e /Warning:/d` + else + EMACS_SITE_LISP="" + fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $EMACS_SITE_LISP" >&5 +$as_echo "$EMACS_SITE_LISP" >&6; } + + +# check for where the emacs site lisp default.el is +rm -f conftest.el +cat >> conftest.el <&5 +$as_echo_n "checking emacs default.el... " >&6; } +if [ "$EMACS" != "" ] ; then + EMACS_DEFAULT_EL=`$EMACS -q -batch --no-site-file -l conftest.el 2>&1 | sed -e /Loading/d | sed -e /load/d |sed -e /Warning:/d` +else + EMACS_DEFAULT_EL="" +fi +if test -f "${EMACS_DEFAULT_EL}" ; then true;else + if test -d $EMACS_SITE_LISP ; then + EMACS_DEFAULT_EL=${EMACS_SITE_LISP}/default.el + fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $EMACS_DEFAULT_EL" >&5 +$as_echo "$EMACS_DEFAULT_EL" >&6; } + + + + +# check for where the emacs site lisp info/dir is +rm -f conftest.el +cat >> conftest.el <&5 +$as_echo_n "checking emacs info/dir... " >&6; } +if test "$use" = "mingw" ; then + INFO_DIR=\$\(prefix\)/lib/gcl-$VERSION/info/ +else + if [ "$EMACS" != "" ] && [ "$INFO_DIR" = "unknown" ] ; then + INFO_DIR=`$EMACS -q -batch --no-site-file -l conftest.el 2>&1 | sed -e /Loading/d | sed -e /load/d |sed -e /Warning:/d` + fi +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $INFO_DIR" >&5 +$as_echo "$INFO_DIR" >&6; } + + +if test "$enable_tcltk" = "yes" ; then + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for tcl/tk" >&5 +$as_echo_n "checking for tcl/tk... " >&6; } + + if test -d "${TCL_CONFIG_PREFIX}" ; then true ; else + + # Extract the first word of "tclsh", so it can be a program name with args. +set dummy tclsh; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_TCLSH+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$TCLSH"; then + ac_cv_prog_TCLSH="$TCLSH" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_TCLSH="tclsh" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + test -z "$ac_cv_prog_TCLSH" && ac_cv_prog_TCLSH="${TCLSH}" +fi +fi +TCLSH=$ac_cv_prog_TCLSH +if test -n "$TCLSH"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $TCLSH" >&5 +$as_echo "$TCLSH" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + + if test "${TCLSH}" = "" ; then true ; else + + rm -f conftest.tcl + cat >> conftest.tcl <&5 +$as_echo_n "checking for main in -llieee... " >&6; } +if ${ac_cv_lib_lieee_main+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-llieee $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + +int +main () +{ +return main (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_lieee_main=yes +else + ac_cv_lib_lieee_main=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_lieee_main" >&5 +$as_echo "$ac_cv_lib_lieee_main" >&6; } +if test "x$ac_cv_lib_lieee_main" = xyes; then : + have_ieee=1 +else + have_ieee=0 +fi + + if test "$have_ieee" = "0" ; then + TCL_LIBS=`echo ${TCL_LIBS} | sed -e "s:-lieee::g" ` + fi + if test "$have_dl" = "0" ; then + TCL_LIBS=`echo ${TCL_LIBS} | sed -e "s:-ldl::g"` + fi + TCL_STUB_LIBS="" + fi + +fi + + + + + + + + + + + + + + + + + + + + + +if test -d "${TK_CONFIG_PREFIX}" ; then +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: using TK_VERSION=${TK_VERSION} in ${TK_CONFIG_PREFIX}" >&5 +$as_echo "using TK_VERSION=${TK_VERSION} in ${TK_CONFIG_PREFIX}" >&6; } +else +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: not found" >&5 +$as_echo "not found" >&6; } +fi + +NOTIFY=$enable_notify + + + + + +# for sgbc the mprotect capabilities. + +# the time handling for unixtime, add timezone +for ac_header in sys/mman.h +do : + ac_fn_c_check_header_mongrel "$LINENO" "sys/mman.h" "ac_cv_header_sys_mman_h" "$ac_includes_default" +if test "x$ac_cv_header_sys_mman_h" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_SYS_MMAN_H 1 +_ACEOF + for ac_func in mprotect +do : + ac_fn_c_check_func "$LINENO" "mprotect" "ac_cv_func_mprotect" +if test "x$ac_cv_func_mprotect" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_MPROTECT 1 +_ACEOF + +fi +done + +fi + +done + +for ac_header in alloca.h +do : + ac_fn_c_check_header_mongrel "$LINENO" "alloca.h" "ac_cv_header_alloca_h" "$ac_includes_default" +if test "x$ac_cv_header_alloca_h" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_ALLOCA_H 1 +_ACEOF + +fi + +done + +ac_fn_c_check_type "$LINENO" "size_t" "ac_cv_type_size_t" "$ac_includes_default" +if test "x$ac_cv_type_size_t" = xyes; then : + +else + +cat >>confdefs.h <<_ACEOF +#define size_t unsigned int +_ACEOF + +fi + +# The Ultrix 4.2 mips builtin alloca declared by alloca.h only works +# for constant arguments. Useless! +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for working alloca.h" >&5 +$as_echo_n "checking for working alloca.h... " >&6; } +if ${ac_cv_working_alloca_h+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +int +main () +{ +char *p = (char *) alloca (2 * sizeof (int)); + if (p) return 0; + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_working_alloca_h=yes +else + ac_cv_working_alloca_h=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_working_alloca_h" >&5 +$as_echo "$ac_cv_working_alloca_h" >&6; } +if test $ac_cv_working_alloca_h = yes; then + +$as_echo "#define HAVE_ALLOCA_H 1" >>confdefs.h + +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for alloca" >&5 +$as_echo_n "checking for alloca... " >&6; } +if ${ac_cv_func_alloca_works+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#ifdef __GNUC__ +# define alloca __builtin_alloca +#else +# ifdef _MSC_VER +# include +# define alloca _alloca +# else +# ifdef HAVE_ALLOCA_H +# include +# else +# ifdef _AIX + #pragma alloca +# else +# ifndef alloca /* predefined by HP cc +Olibcalls */ +void *alloca (size_t); +# endif +# endif +# endif +# endif +#endif + +int +main () +{ +char *p = (char *) alloca (1); + if (p) return 0; + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_func_alloca_works=yes +else + ac_cv_func_alloca_works=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_func_alloca_works" >&5 +$as_echo "$ac_cv_func_alloca_works" >&6; } + +if test $ac_cv_func_alloca_works = yes; then + +$as_echo "#define HAVE_ALLOCA 1" >>confdefs.h + +else + # The SVR3 libPW and SVR4 libucb both contain incompatible functions +# that cause trouble. Some versions do not even contain alloca or +# contain a buggy version. If you still want to use their alloca, +# use ar to extract alloca.o from them instead of compiling alloca.c. + +ALLOCA=\${LIBOBJDIR}alloca.$ac_objext + +$as_echo "#define C_ALLOCA 1" >>confdefs.h + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether \`alloca.c' needs Cray hooks" >&5 +$as_echo_n "checking whether \`alloca.c' needs Cray hooks... " >&6; } +if ${ac_cv_os_cray+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#if defined CRAY && ! defined CRAY2 +webecray +#else +wenotbecray +#endif + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "webecray" >/dev/null 2>&1; then : + ac_cv_os_cray=yes +else + ac_cv_os_cray=no +fi +rm -f conftest* + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_os_cray" >&5 +$as_echo "$ac_cv_os_cray" >&6; } +if test $ac_cv_os_cray = yes; then + for ac_func in _getb67 GETB67 getb67; do + as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` +ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var" +if eval test \"x\$"$as_ac_var"\" = x"yes"; then : + +cat >>confdefs.h <<_ACEOF +#define CRAY_STACKSEG_END $ac_func +_ACEOF + + break +fi + + done +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking stack direction for C alloca" >&5 +$as_echo_n "checking stack direction for C alloca... " >&6; } +if ${ac_cv_c_stack_direction+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test "$cross_compiling" = yes; then : + ac_cv_c_stack_direction=0 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$ac_includes_default +int +find_stack_direction (int *addr, int depth) +{ + int dir, dummy = 0; + if (! addr) + addr = &dummy; + *addr = addr < &dummy ? 1 : addr == &dummy ? 0 : -1; + dir = depth ? find_stack_direction (addr, depth - 1) : 0; + return dir + dummy; +} + +int +main (int argc, char **argv) +{ + return find_stack_direction (0, argc + !argv + 20) < 0; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + ac_cv_c_stack_direction=1 +else + ac_cv_c_stack_direction=-1 +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_stack_direction" >&5 +$as_echo "$ac_cv_c_stack_direction" >&6; } +cat >>confdefs.h <<_ACEOF +#define STACK_DIRECTION $ac_cv_c_stack_direction +_ACEOF + + +fi + + +# alloca + +# dlopen etc +# idea make it so you do something dlopen(libX.so,RTLD_GLOBAL) +# then dlload("foo.o") a lisp file can refer to things in libX.so +# + +# what machine this is, and include then a machine specific hdr. +# and machine specific defs. + +# check bzero, + +# check getcwd, getwd etc.. + + + + +# check socket stuff.. + +# getrlimit + +# fionread or block + +# redhat/cygnus released for some reason a buggy version of gcc, +# which no one else released. Catch that here. + +LDFLAGS="`echo $LDFLAGS | sed 's,gcl.script,../unixport/gcl.script,g'`" + +LIBS="$X_PRE_LIBS $X_LIBS $X_EXTRA_LIBS $TLDFLAGS $LIBS $TLIBS" + +FINAL_CFLAGS="$CFLAGS $CPPFLAGS $X_CFLAGS $TCFLAGS $PROCESSOR_FLAGS" + +# Work around bug with gcc on ppc -- CM +NIFLAGS="$CFLAGS $CPPFLAGS $TCFLAGS $TONIFLAGS $PROCESSOR_FLAGS -I\$(GCLDIR)/o" + +CFLAGS="$CFLAGS $CPPFLAGS $TCFLAGS $TO3FLAGS $PROCESSOR_FLAGS -I\$(GCLDIR)/o" + +O3FLAGS=$TO3FLAGS + +O2FLAGS=$TO2FLAGS + + + + + + + +if test -f h/$use.defs ; then + + + ac_config_files="$ac_config_files makedefc windows/gcl.iss windows/sysdir.bat windows/install.lsp" + +cat >confcache <<\_ACEOF +# This file is a shell script that caches the results of configure +# tests run on this system so they can be shared between configure +# scripts and configure runs, see configure's option --config-cache. +# It is not useful on other systems. If it contains results you don't +# want to keep, you may remove or edit it. +# +# config.status only pays attention to the cache file if you give it +# the --recheck option to rerun configure. +# +# `ac_cv_env_foo' variables (set or unset) will be overridden when +# loading this file, other *unset* `ac_cv_foo' will be assigned the +# following values. + +_ACEOF + +# The following way of writing the cache mishandles newlines in values, +# but we know of no workaround that is simple, portable, and efficient. +# So, we kill variables containing newlines. +# Ultrix sh set writes to stderr and can't be redirected directly, +# and sets the high bit in the cache file unless we assign to the vars. +( + for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do + eval ac_val=\$$ac_var + case $ac_val in #( + *${as_nl}*) + case $ac_var in #( + *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 +$as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; + esac + case $ac_var in #( + _ | IFS | as_nl) ;; #( + BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( + *) { eval $ac_var=; unset $ac_var;} ;; + esac ;; + esac + done + + (set) 2>&1 | + case $as_nl`(ac_space=' '; set) 2>&1` in #( + *${as_nl}ac_space=\ *) + # `set' does not quote correctly, so add quotes: double-quote + # substitution turns \\\\ into \\, and sed turns \\ into \. + sed -n \ + "s/'/'\\\\''/g; + s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" + ;; #( + *) + # `set' quotes correctly as required by POSIX, so do not add quotes. + sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" + ;; + esac | + sort +) | + sed ' + /^ac_cv_env_/b end + t clear + :clear + s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/ + t end + s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ + :end' >>confcache +if diff "$cache_file" confcache >/dev/null 2>&1; then :; else + if test -w "$cache_file"; then + if test "x$cache_file" != "x/dev/null"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 +$as_echo "$as_me: updating cache $cache_file" >&6;} + if test ! -f "$cache_file" || test -h "$cache_file"; then + cat confcache >"$cache_file" + else + case $cache_file in #( + */* | ?:*) + mv -f confcache "$cache_file"$$ && + mv -f "$cache_file"$$ "$cache_file" ;; #( + *) + mv -f confcache "$cache_file" ;; + esac + fi + fi + else + { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 +$as_echo "$as_me: not updating unwritable cache $cache_file" >&6;} + fi +fi +rm -f confcache + +test "x$prefix" = xNONE && prefix=$ac_default_prefix +# Let make expand exec_prefix. +test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' + +DEFS=-DHAVE_CONFIG_H + +ac_libobjs= +ac_ltlibobjs= +U= +for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue + # 1. Remove the extension, and $U if already installed. + ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' + ac_i=`$as_echo "$ac_i" | sed "$ac_script"` + # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR + # will be set to the directory where LIBOBJS objects are built. + as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" + as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' +done +LIBOBJS=$ac_libobjs + +LTLIBOBJS=$ac_ltlibobjs + + + +: "${CONFIG_STATUS=./config.status}" +ac_write_fail=0 +ac_clean_files_save=$ac_clean_files +ac_clean_files="$ac_clean_files $CONFIG_STATUS" +{ $as_echo "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 +$as_echo "$as_me: creating $CONFIG_STATUS" >&6;} +as_write_fail=0 +cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 +#! $SHELL +# Generated by $as_me. +# Run this file to recreate the current configuration. +# Compiler output produced by configure, useful for debugging +# configure, is in config.log if it exists. + +debug=false +ac_cs_recheck=false +ac_cs_silent=false + +SHELL=\${CONFIG_SHELL-$SHELL} +export SHELL +_ASEOF +cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 +## -------------------- ## +## M4sh Initialization. ## +## -------------------- ## + +# Be more Bourne compatible +DUALCASE=1; export DUALCASE # for MKS sh +if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : + emulate sh + NULLCMD=: + # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which + # is contrary to our usage. Disable this feature. + alias -g '${1+"$@"}'='"$@"' + setopt NO_GLOB_SUBST +else + case `(set -o) 2>/dev/null` in #( + *posix*) : + set -o posix ;; #( + *) : + ;; +esac +fi + + +as_nl=' +' +export as_nl +# Printing a long string crashes Solaris 7 /usr/bin/printf. +as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' +as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo +as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo +# Prefer a ksh shell builtin over an external printf program on Solaris, +# but without wasting forks for bash or zsh. +if test -z "$BASH_VERSION$ZSH_VERSION" \ + && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then + as_echo='print -r --' + as_echo_n='print -rn --' +elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then + as_echo='printf %s\n' + as_echo_n='printf %s' +else + if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then + as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' + as_echo_n='/usr/ucb/echo -n' + else + as_echo_body='eval expr "X$1" : "X\\(.*\\)"' + as_echo_n_body='eval + arg=$1; + case $arg in #( + *"$as_nl"*) + expr "X$arg" : "X\\(.*\\)$as_nl"; + arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; + esac; + expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" + ' + export as_echo_n_body + as_echo_n='sh -c $as_echo_n_body as_echo' + fi + export as_echo_body + as_echo='sh -c $as_echo_body as_echo' +fi + +# The user is always right. +if test "${PATH_SEPARATOR+set}" != set; then + PATH_SEPARATOR=: + (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { + (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || + PATH_SEPARATOR=';' + } +fi + + +# IFS +# We need space, tab and new line, in precisely that order. Quoting is +# there to prevent editors from complaining about space-tab. +# (If _AS_PATH_WALK were called with IFS unset, it would disable word +# splitting by setting IFS to empty value.) +IFS=" "" $as_nl" + +# Find who we are. Look in the path if we contain no directory separator. +as_myself= +case $0 in #(( + *[\\/]* ) as_myself=$0 ;; + *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break + done +IFS=$as_save_IFS + + ;; +esac +# We did not find ourselves, most probably we were run as `sh COMMAND' +# in which case we are not to be found in the path. +if test "x$as_myself" = x; then + as_myself=$0 +fi +if test ! -f "$as_myself"; then + $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 + exit 1 +fi + +# Unset variables that we do not need and which cause bugs (e.g. in +# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" +# suppresses any "Segmentation fault" message there. '((' could +# trigger a bug in pdksh 5.2.14. +for as_var in BASH_ENV ENV MAIL MAILPATH +do eval test x\${$as_var+set} = xset \ + && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : +done +PS1='$ ' +PS2='> ' +PS4='+ ' + +# NLS nuisances. +LC_ALL=C +export LC_ALL +LANGUAGE=C +export LANGUAGE + +# CDPATH. +(unset CDPATH) >/dev/null 2>&1 && unset CDPATH + + +# as_fn_error STATUS ERROR [LINENO LOG_FD] +# ---------------------------------------- +# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are +# provided, also output the error to LOG_FD, referencing LINENO. Then exit the +# script with STATUS, using 1 if that was 0. +as_fn_error () +{ + as_status=$1; test $as_status -eq 0 && as_status=1 + if test "$4"; then + as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 + fi + $as_echo "$as_me: error: $2" >&2 + as_fn_exit $as_status +} # as_fn_error + + +# as_fn_set_status STATUS +# ----------------------- +# Set $? to STATUS, without forking. +as_fn_set_status () +{ + return $1 +} # as_fn_set_status + +# as_fn_exit STATUS +# ----------------- +# Exit the shell with STATUS, even in a "trap 0" or "set -e" context. +as_fn_exit () +{ + set +e + as_fn_set_status $1 + exit $1 +} # as_fn_exit + +# as_fn_unset VAR +# --------------- +# Portably unset VAR. +as_fn_unset () +{ + { eval $1=; unset $1;} +} +as_unset=as_fn_unset +# as_fn_append VAR VALUE +# ---------------------- +# Append the text in VALUE to the end of the definition contained in VAR. Take +# advantage of any shell optimizations that allow amortized linear growth over +# repeated appends, instead of the typical quadratic growth present in naive +# implementations. +if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : + eval 'as_fn_append () + { + eval $1+=\$2 + }' +else + as_fn_append () + { + eval $1=\$$1\$2 + } +fi # as_fn_append + +# as_fn_arith ARG... +# ------------------ +# Perform arithmetic evaluation on the ARGs, and store the result in the +# global $as_val. Take advantage of shells that can avoid forks. The arguments +# must be portable across $(()) and expr. +if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : + eval 'as_fn_arith () + { + as_val=$(( $* )) + }' +else + as_fn_arith () + { + as_val=`expr "$@" || test $? -eq 1` + } +fi # as_fn_arith + + +if expr a : '\(a\)' >/dev/null 2>&1 && + test "X`expr 00001 : '.*\(...\)'`" = X001; then + as_expr=expr +else + as_expr=false +fi + +if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then + as_basename=basename +else + as_basename=false +fi + +if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then + as_dirname=dirname +else + as_dirname=false +fi + +as_me=`$as_basename -- "$0" || +$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ + X"$0" : 'X\(//\)$' \| \ + X"$0" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X/"$0" | + sed '/^.*\/\([^/][^/]*\)\/*$/{ + s//\1/ + q + } + /^X\/\(\/\/\)$/{ + s//\1/ + q + } + /^X\/\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + +# Avoid depending upon Character Ranges. +as_cr_letters='abcdefghijklmnopqrstuvwxyz' +as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' +as_cr_Letters=$as_cr_letters$as_cr_LETTERS +as_cr_digits='0123456789' +as_cr_alnum=$as_cr_Letters$as_cr_digits + +ECHO_C= ECHO_N= ECHO_T= +case `echo -n x` in #((((( +-n*) + case `echo 'xy\c'` in + *c*) ECHO_T=' ';; # ECHO_T is single tab character. + xy) ECHO_C='\c';; + *) echo `echo ksh88 bug on AIX 6.1` > /dev/null + ECHO_T=' ';; + esac;; +*) + ECHO_N='-n';; +esac + +rm -f conf$$ conf$$.exe conf$$.file +if test -d conf$$.dir; then + rm -f conf$$.dir/conf$$.file +else + rm -f conf$$.dir + mkdir conf$$.dir 2>/dev/null +fi +if (echo >conf$$.file) 2>/dev/null; then + if ln -s conf$$.file conf$$ 2>/dev/null; then + as_ln_s='ln -s' + # ... but there are two gotchas: + # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. + # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. + # In both cases, we have to default to `cp -pR'. + ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || + as_ln_s='cp -pR' + elif ln conf$$.file conf$$ 2>/dev/null; then + as_ln_s=ln + else + as_ln_s='cp -pR' + fi +else + as_ln_s='cp -pR' +fi +rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file +rmdir conf$$.dir 2>/dev/null + + +# as_fn_mkdir_p +# ------------- +# Create "$as_dir" as a directory, including parents if necessary. +as_fn_mkdir_p () +{ + + case $as_dir in #( + -*) as_dir=./$as_dir;; + esac + test -d "$as_dir" || eval $as_mkdir_p || { + as_dirs= + while :; do + case $as_dir in #( + *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( + *) as_qdir=$as_dir;; + esac + as_dirs="'$as_qdir' $as_dirs" + as_dir=`$as_dirname -- "$as_dir" || +$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_dir" : 'X\(//\)[^/]' \| \ + X"$as_dir" : 'X\(//\)$' \| \ + X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X"$as_dir" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + test -d "$as_dir" && break + done + test -z "$as_dirs" || eval "mkdir $as_dirs" + } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" + + +} # as_fn_mkdir_p +if mkdir -p . 2>/dev/null; then + as_mkdir_p='mkdir -p "$as_dir"' +else + test -d ./-p && rmdir ./-p + as_mkdir_p=false +fi + + +# as_fn_executable_p FILE +# ----------------------- +# Test if FILE is an executable regular file. +as_fn_executable_p () +{ + test -f "$1" && test -x "$1" +} # as_fn_executable_p +as_test_x='test -x' +as_executable_p=as_fn_executable_p + +# Sed expression to map a string onto a valid CPP name. +as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" + +# Sed expression to map a string onto a valid variable name. +as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" + + +exec 6>&1 +## ----------------------------------- ## +## Main body of $CONFIG_STATUS script. ## +## ----------------------------------- ## +_ASEOF +test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +# Save the log message, to keep $0 and so on meaningful, and to +# report actual input values of CONFIG_FILES etc. instead of their +# values after options handling. +ac_log=" +This file was extended by $as_me, which was +generated by GNU Autoconf 2.69. Invocation command line was + + CONFIG_FILES = $CONFIG_FILES + CONFIG_HEADERS = $CONFIG_HEADERS + CONFIG_LINKS = $CONFIG_LINKS + CONFIG_COMMANDS = $CONFIG_COMMANDS + $ $0 $@ + +on `(hostname || uname -n) 2>/dev/null | sed 1q` +" + +_ACEOF + +case $ac_config_files in *" +"*) set x $ac_config_files; shift; ac_config_files=$*;; +esac + +case $ac_config_headers in *" +"*) set x $ac_config_headers; shift; ac_config_headers=$*;; +esac + + +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +# Files that config.status was made for. +config_files="$ac_config_files" +config_headers="$ac_config_headers" + +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +ac_cs_usage="\ +\`$as_me' instantiates files and other configuration actions +from templates according to the current configuration. Unless the files +and actions are specified as TAGs, all are instantiated by default. + +Usage: $0 [OPTION]... [TAG]... + + -h, --help print this help, then exit + -V, --version print version number and configuration settings, then exit + --config print configuration, then exit + -q, --quiet, --silent + do not print progress messages + -d, --debug don't remove temporary files + --recheck update $as_me by reconfiguring in the same conditions + --file=FILE[:TEMPLATE] + instantiate the configuration file FILE + --header=FILE[:TEMPLATE] + instantiate the configuration header FILE + +Configuration files: +$config_files + +Configuration headers: +$config_headers + +Report bugs to the package provider." + +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" +ac_cs_version="\\ +config.status +configured by $0, generated by GNU Autoconf 2.69, + with options \\"\$ac_cs_config\\" + +Copyright (C) 2012 Free Software Foundation, Inc. +This config.status script is free software; the Free Software Foundation +gives unlimited permission to copy, distribute and modify it." + +ac_pwd='$ac_pwd' +srcdir='$srcdir' +test -n "\$AWK" || AWK=awk +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +# The default lists apply if the user does not specify any file. +ac_need_defaults=: +while test $# != 0 +do + case $1 in + --*=?*) + ac_option=`expr "X$1" : 'X\([^=]*\)='` + ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` + ac_shift=: + ;; + --*=) + ac_option=`expr "X$1" : 'X\([^=]*\)='` + ac_optarg= + ac_shift=: + ;; + *) + ac_option=$1 + ac_optarg=$2 + ac_shift=shift + ;; + esac + + case $ac_option in + # Handling of the options. + -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) + ac_cs_recheck=: ;; + --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) + $as_echo "$ac_cs_version"; exit ;; + --config | --confi | --conf | --con | --co | --c ) + $as_echo "$ac_cs_config"; exit ;; + --debug | --debu | --deb | --de | --d | -d ) + debug=: ;; + --file | --fil | --fi | --f ) + $ac_shift + case $ac_optarg in + *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; + '') as_fn_error $? "missing file argument" ;; + esac + as_fn_append CONFIG_FILES " '$ac_optarg'" + ac_need_defaults=false;; + --header | --heade | --head | --hea ) + $ac_shift + case $ac_optarg in + *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; + esac + as_fn_append CONFIG_HEADERS " '$ac_optarg'" + ac_need_defaults=false;; + --he | --h) + # Conflict between --help and --header + as_fn_error $? "ambiguous option: \`$1' +Try \`$0 --help' for more information.";; + --help | --hel | -h ) + $as_echo "$ac_cs_usage"; exit ;; + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil | --si | --s) + ac_cs_silent=: ;; + + # This is an error. + -*) as_fn_error $? "unrecognized option: \`$1' +Try \`$0 --help' for more information." ;; + + *) as_fn_append ac_config_targets " $1" + ac_need_defaults=false ;; + + esac + shift +done + +ac_configure_extra_args= + +if $ac_cs_silent; then + exec 6>/dev/null + ac_configure_extra_args="$ac_configure_extra_args --silent" +fi + +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +if \$ac_cs_recheck; then + set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion + shift + \$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6 + CONFIG_SHELL='$SHELL' + export CONFIG_SHELL + exec "\$@" +fi + +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +exec 5>>config.log +{ + echo + sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX +## Running $as_me. ## +_ASBOX + $as_echo "$ac_log" +} >&5 + +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 + +# Handling of arguments. +for ac_config_target in $ac_config_targets +do + case $ac_config_target in + "h/gclincl.h") CONFIG_HEADERS="$CONFIG_HEADERS h/gclincl.h" ;; + "makedefc") CONFIG_FILES="$CONFIG_FILES makedefc" ;; + "windows/gcl.iss") CONFIG_FILES="$CONFIG_FILES windows/gcl.iss" ;; + "windows/sysdir.bat") CONFIG_FILES="$CONFIG_FILES windows/sysdir.bat" ;; + "windows/install.lsp") CONFIG_FILES="$CONFIG_FILES windows/install.lsp" ;; + + *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; + esac +done + + +# If the user did not use the arguments to specify the items to instantiate, +# then the envvar interface is used. Set only those that are not. +# We use the long form for the default assignment because of an extremely +# bizarre bug on SunOS 4.1.3. +if $ac_need_defaults; then + test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files + test "${CONFIG_HEADERS+set}" = set || CONFIG_HEADERS=$config_headers +fi + +# Have a temporary directory for convenience. Make it in the build tree +# simply because there is no reason against having it here, and in addition, +# creating and moving files from /tmp can sometimes cause problems. +# Hook for its removal unless debugging. +# Note that there is a small window in which the directory will not be cleaned: +# after its creation but before its name has been assigned to `$tmp'. +$debug || +{ + tmp= ac_tmp= + trap 'exit_status=$? + : "${ac_tmp:=$tmp}" + { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status +' 0 + trap 'as_fn_exit 1' 1 2 13 15 +} +# Create a (secure) tmp directory for tmp files. + +{ + tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && + test -d "$tmp" +} || +{ + tmp=./conf$$-$RANDOM + (umask 077 && mkdir "$tmp") +} || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 +ac_tmp=$tmp + +# Set up the scripts for CONFIG_FILES section. +# No need to generate them if there are no CONFIG_FILES. +# This happens for instance with `./config.status config.h'. +if test -n "$CONFIG_FILES"; then + + +ac_cr=`echo X | tr X '\015'` +# On cygwin, bash can eat \r inside `` if the user requested igncr. +# But we know of no other shell where ac_cr would be empty at this +# point, so we can use a bashism as a fallback. +if test "x$ac_cr" = x; then + eval ac_cr=\$\'\\r\' +fi +ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` +if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then + ac_cs_awk_cr='\\r' +else + ac_cs_awk_cr=$ac_cr +fi + +echo 'BEGIN {' >"$ac_tmp/subs1.awk" && +_ACEOF + + +{ + echo "cat >conf$$subs.awk <<_ACEOF" && + echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && + echo "_ACEOF" +} >conf$$subs.sh || + as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 +ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` +ac_delim='%!_!# ' +for ac_last_try in false false false false false :; do + . ./conf$$subs.sh || + as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 + + ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` + if test $ac_delim_n = $ac_delim_num; then + break + elif $ac_last_try; then + as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 + else + ac_delim="$ac_delim!$ac_delim _$ac_delim!! " + fi +done +rm -f conf$$subs.sh + +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && +_ACEOF +sed -n ' +h +s/^/S["/; s/!.*/"]=/ +p +g +s/^[^!]*!// +:repl +t repl +s/'"$ac_delim"'$// +t delim +:nl +h +s/\(.\{148\}\)..*/\1/ +t more1 +s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ +p +n +b repl +:more1 +s/["\\]/\\&/g; s/^/"/; s/$/"\\/ +p +g +s/.\{148\}// +t nl +:delim +h +s/\(.\{148\}\)..*/\1/ +t more2 +s/["\\]/\\&/g; s/^/"/; s/$/"/ +p +b +:more2 +s/["\\]/\\&/g; s/^/"/; s/$/"\\/ +p +g +s/.\{148\}// +t delim +' >$CONFIG_STATUS || ac_write_fail=1 +rm -f conf$$subs.awk +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +_ACAWK +cat >>"\$ac_tmp/subs1.awk" <<_ACAWK && + for (key in S) S_is_set[key] = 1 + FS = "" + +} +{ + line = $ 0 + nfields = split(line, field, "@") + substed = 0 + len = length(field[1]) + for (i = 2; i < nfields; i++) { + key = field[i] + keylen = length(key) + if (S_is_set[key]) { + value = S[key] + line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) + len += length(value) + length(field[++i]) + substed = 1 + } else + len += 1 + keylen + } + + print line +} + +_ACAWK +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then + sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" +else + cat +fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ + || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 +_ACEOF + +# VPATH may cause trouble with some makes, so we remove sole $(srcdir), +# ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and +# trailing colons and then remove the whole line if VPATH becomes empty +# (actually we leave an empty line to preserve line numbers). +if test "x$srcdir" = x.; then + ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ +h +s/// +s/^/:/ +s/[ ]*$/:/ +s/:\$(srcdir):/:/g +s/:\${srcdir}:/:/g +s/:@srcdir@:/:/g +s/^:*// +s/:*$// +x +s/\(=[ ]*\).*/\1/ +G +s/\n// +s/^[^=]*=[ ]*$// +}' +fi + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +fi # test -n "$CONFIG_FILES" + +# Set up the scripts for CONFIG_HEADERS section. +# No need to generate them if there are no CONFIG_HEADERS. +# This happens for instance with `./config.status Makefile'. +if test -n "$CONFIG_HEADERS"; then +cat >"$ac_tmp/defines.awk" <<\_ACAWK || +BEGIN { +_ACEOF + +# Transform confdefs.h into an awk script `defines.awk', embedded as +# here-document in config.status, that substitutes the proper values into +# config.h.in to produce config.h. + +# Create a delimiter string that does not exist in confdefs.h, to ease +# handling of long lines. +ac_delim='%!_!# ' +for ac_last_try in false false :; do + ac_tt=`sed -n "/$ac_delim/p" confdefs.h` + if test -z "$ac_tt"; then + break + elif $ac_last_try; then + as_fn_error $? "could not make $CONFIG_HEADERS" "$LINENO" 5 + else + ac_delim="$ac_delim!$ac_delim _$ac_delim!! " + fi +done + +# For the awk script, D is an array of macro values keyed by name, +# likewise P contains macro parameters if any. Preserve backslash +# newline sequences. + +ac_word_re=[_$as_cr_Letters][_$as_cr_alnum]* +sed -n ' +s/.\{148\}/&'"$ac_delim"'/g +t rset +:rset +s/^[ ]*#[ ]*define[ ][ ]*/ / +t def +d +:def +s/\\$// +t bsnl +s/["\\]/\\&/g +s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\ +D["\1"]=" \3"/p +s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2"/p +d +:bsnl +s/["\\]/\\&/g +s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\ +D["\1"]=" \3\\\\\\n"\\/p +t cont +s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2\\\\\\n"\\/p +t cont +d +:cont +n +s/.\{148\}/&'"$ac_delim"'/g +t clear +:clear +s/\\$// +t bsnlc +s/["\\]/\\&/g; s/^/"/; s/$/"/p +d +:bsnlc +s/["\\]/\\&/g; s/^/"/; s/$/\\\\\\n"\\/p +b cont +' >$CONFIG_STATUS || ac_write_fail=1 + +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 + for (key in D) D_is_set[key] = 1 + FS = "" +} +/^[\t ]*#[\t ]*(define|undef)[\t ]+$ac_word_re([\t (]|\$)/ { + line = \$ 0 + split(line, arg, " ") + if (arg[1] == "#") { + defundef = arg[2] + mac1 = arg[3] + } else { + defundef = substr(arg[1], 2) + mac1 = arg[2] + } + split(mac1, mac2, "(") #) + macro = mac2[1] + prefix = substr(line, 1, index(line, defundef) - 1) + if (D_is_set[macro]) { + # Preserve the white space surrounding the "#". + print prefix "define", macro P[macro] D[macro] + next + } else { + # Replace #undef with comments. This is necessary, for example, + # in the case of _POSIX_SOURCE, which is predefined and required + # on some systems where configure will not decide to define it. + if (defundef == "undef") { + print "/*", prefix defundef, macro, "*/" + next + } + } +} +{ print } +_ACAWK +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 + as_fn_error $? "could not setup config headers machinery" "$LINENO" 5 +fi # test -n "$CONFIG_HEADERS" + + +eval set X " :F $CONFIG_FILES :H $CONFIG_HEADERS " +shift +for ac_tag +do + case $ac_tag in + :[FHLC]) ac_mode=$ac_tag; continue;; + esac + case $ac_mode$ac_tag in + :[FHL]*:*);; + :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; + :[FH]-) ac_tag=-:-;; + :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; + esac + ac_save_IFS=$IFS + IFS=: + set x $ac_tag + IFS=$ac_save_IFS + shift + ac_file=$1 + shift + + case $ac_mode in + :L) ac_source=$1;; + :[FH]) + ac_file_inputs= + for ac_f + do + case $ac_f in + -) ac_f="$ac_tmp/stdin";; + *) # Look for the file first in the build tree, then in the source tree + # (if the path is not absolute). The absolute path cannot be DOS-style, + # because $ac_f cannot contain `:'. + test -f "$ac_f" || + case $ac_f in + [\\/$]*) false;; + *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; + esac || + as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; + esac + case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac + as_fn_append ac_file_inputs " '$ac_f'" + done + + # Let's still pretend it is `configure' which instantiates (i.e., don't + # use $as_me), people would be surprised to read: + # /* config.h. Generated by config.status. */ + configure_input='Generated from '` + $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' + `' by configure.' + if test x"$ac_file" != x-; then + configure_input="$ac_file. $configure_input" + { $as_echo "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 +$as_echo "$as_me: creating $ac_file" >&6;} + fi + # Neutralize special characters interpreted by sed in replacement strings. + case $configure_input in #( + *\&* | *\|* | *\\* ) + ac_sed_conf_input=`$as_echo "$configure_input" | + sed 's/[\\\\&|]/\\\\&/g'`;; #( + *) ac_sed_conf_input=$configure_input;; + esac + + case $ac_tag in + *:-:* | *:-) cat >"$ac_tmp/stdin" \ + || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; + esac + ;; + esac + + ac_dir=`$as_dirname -- "$ac_file" || +$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$ac_file" : 'X\(//\)[^/]' \| \ + X"$ac_file" : 'X\(//\)$' \| \ + X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X"$ac_file" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + as_dir="$ac_dir"; as_fn_mkdir_p + ac_builddir=. + +case "$ac_dir" in +.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; +*) + ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` + # A ".." for each directory in $ac_dir_suffix. + ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` + case $ac_top_builddir_sub in + "") ac_top_builddir_sub=. ac_top_build_prefix= ;; + *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; + esac ;; +esac +ac_abs_top_builddir=$ac_pwd +ac_abs_builddir=$ac_pwd$ac_dir_suffix +# for backward compatibility: +ac_top_builddir=$ac_top_build_prefix + +case $srcdir in + .) # We are building in place. + ac_srcdir=. + ac_top_srcdir=$ac_top_builddir_sub + ac_abs_top_srcdir=$ac_pwd ;; + [\\/]* | ?:[\\/]* ) # Absolute name. + ac_srcdir=$srcdir$ac_dir_suffix; + ac_top_srcdir=$srcdir + ac_abs_top_srcdir=$srcdir ;; + *) # Relative name. + ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix + ac_top_srcdir=$ac_top_build_prefix$srcdir + ac_abs_top_srcdir=$ac_pwd/$srcdir ;; +esac +ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix + + + case $ac_mode in + :F) + # + # CONFIG_FILE + # + +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +# If the template does not know about datarootdir, expand it. +# FIXME: This hack should be removed a few years after 2.60. +ac_datarootdir_hack=; ac_datarootdir_seen= +ac_sed_dataroot=' +/datarootdir/ { + p + q +} +/@datadir@/p +/@docdir@/p +/@infodir@/p +/@localedir@/p +/@mandir@/p' +case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in +*datarootdir*) ac_datarootdir_seen=yes;; +*@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 +$as_echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 + ac_datarootdir_hack=' + s&@datadir@&$datadir&g + s&@docdir@&$docdir&g + s&@infodir@&$infodir&g + s&@localedir@&$localedir&g + s&@mandir@&$mandir&g + s&\\\${datarootdir}&$datarootdir&g' ;; +esac +_ACEOF + +# Neutralize VPATH when `$srcdir' = `.'. +# Shell code in configure.ac might set extrasub. +# FIXME: do we really want to maintain this feature? +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +ac_sed_extra="$ac_vpsub +$extrasub +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +:t +/@[a-zA-Z_][a-zA-Z_0-9]*@/!b +s|@configure_input@|$ac_sed_conf_input|;t t +s&@top_builddir@&$ac_top_builddir_sub&;t t +s&@top_build_prefix@&$ac_top_build_prefix&;t t +s&@srcdir@&$ac_srcdir&;t t +s&@abs_srcdir@&$ac_abs_srcdir&;t t +s&@top_srcdir@&$ac_top_srcdir&;t t +s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t +s&@builddir@&$ac_builddir&;t t +s&@abs_builddir@&$ac_abs_builddir&;t t +s&@abs_top_builddir@&$ac_abs_top_builddir&;t t +$ac_datarootdir_hack +" +eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ + >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 + +test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && + { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && + { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ + "$ac_tmp/out"`; test -z "$ac_out"; } && + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' +which seems to be undefined. Please make sure it is defined" >&5 +$as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' +which seems to be undefined. Please make sure it is defined" >&2;} + + rm -f "$ac_tmp/stdin" + case $ac_file in + -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; + *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; + esac \ + || as_fn_error $? "could not create $ac_file" "$LINENO" 5 + ;; + :H) + # + # CONFIG_HEADER + # + if test x"$ac_file" != x-; then + { + $as_echo "/* $configure_input */" \ + && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" + } >"$ac_tmp/config.h" \ + || as_fn_error $? "could not create $ac_file" "$LINENO" 5 + if diff "$ac_file" "$ac_tmp/config.h" >/dev/null 2>&1; then + { $as_echo "$as_me:${as_lineno-$LINENO}: $ac_file is unchanged" >&5 +$as_echo "$as_me: $ac_file is unchanged" >&6;} + else + rm -f "$ac_file" + mv "$ac_tmp/config.h" "$ac_file" \ + || as_fn_error $? "could not create $ac_file" "$LINENO" 5 + fi + else + $as_echo "/* $configure_input */" \ + && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" \ + || as_fn_error $? "could not create -" "$LINENO" 5 + fi + ;; + + + esac + +done # for ac_tag + + +as_fn_exit 0 +_ACEOF +ac_clean_files=$ac_clean_files_save + +test $ac_write_fail = 0 || + as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5 + + +# configure is writing to config.log, and then calls config.status. +# config.status does its own redirection, appending to config.log. +# Unfortunately, on DOS this fails, as config.log is still kept open +# by configure, so config.status won't be able to write to it; its +# output is simply discarded. So we exec the FD to /dev/null, +# effectively closing config.log, so it can be properly (re)opened and +# appended to by config.status. When coming back to configure, we +# need to make the FD available again. +if test "$no_create" != yes; then + ac_cs_success=: + ac_config_status_args= + test "$silent" = yes && + ac_config_status_args="$ac_config_status_args --quiet" + exec 5>/dev/null + $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false + exec 5>>config.log + # Use ||, not &&, to avoid exiting from the if with $? = 1, which + # would make configure fail if this is the last instruction. + $ac_cs_success || as_fn_exit 1 +fi +if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 +$as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} +fi + + echo makedefc + cat makedefc + + echo add-defs1 $use + CC=$CC ./add-defs1 $use + +else + echo "Unable to guess machine type" + echo use configure --enable-machine=XXX, for XXX such that h/XXX.defs exists, ie in h/*.defs +fi diff --git a/configure-new.ac b/configure-new.ac new file mode 100644 index 0000000..760224b --- /dev/null +++ b/configure-new.ac @@ -0,0 +1,1040 @@ +AC_INIT() +AC_CONFIG_HEADER(h/gclincl.h) +# some parts of this configure script are taken from the tcl configure.in + +# Step 1: set the variable "system" to hold the name and version number +# for the system. This can usually be done via the "uname" command, but +# there are a few systems, like Next, where this doesn't work. + + +AC_MSG_CHECKING([system version (for dynamic loading)]) +if machine=`uname -m` ; then true; else machine=unknown ; fi + +AC_CHECK_PROGS(AWK,gawk nawk awk,"") + +AC_CHECK_PROGS(MAKEINFO,makeinfo,"false") +AC_SUBST(MAKEINFO) + +if test -f /usr/lib/NextStep/software_version; then + system=NEXTSTEP-`${AWK} '/3/,/3/' /usr/lib/NextStep/software_version` +else + system=`uname -s`-`uname -r` + if test "$?" -ne 0 ; then + AC_MSG_RESULT([unknown (can't find uname command)]) + system=unknown + else + # Special check for weird MP-RAS system (uname returns weird + # results, and the version is kept in special file). + + if test -r /etc/.relid -a "X`uname -n`" = "X`uname -s`" ; then + system=MP-RAS-`${AWK} '{print $3}' /etc/.relid'` + fi + if test "`uname -s`" = "AIX" ; then + system=AIX-`uname -v`.`uname -r` + fi + AC_MSG_RESULT($system) + fi +fi + +# Find where Data begins. This is used by the storage allocation +# mechanism, in the PAGE macro. This offset is subtracted from +# addresses, in calculating a page for an address in the heap. + +AC_PROG_CC +# can only test for numbers -- CM +# if test "${GCC}" -eq "yes" ; then +if [[ "${GCC}" = "yes" ]] ; then +# Allog for environment variable overrides on compiler selection -- CM +GCC=$CC +else +GCC="" +fi +# subst GCC not only under 386-linux, but where available -- CM +AC_SUBST(GCC) +AC_CHECK_SIZEOF(long *,0) +AC_CHECK_HEADERS(endian.h, + AC_MSG_CHECKING("endianness") + AC_TRY_RUN([#include + int main() { return BYTE_ORDER == __LITTLE_ENDIAN ? 0 : 1;}], + AC_DEFINE(LITTLE_END) AC_MSG_RESULT(little), + AC_MSG_RESULT(big),AC_MSG_RESULT(big))) +AC_SUBST(LITTLE_END) + +AC_MSG_CHECKING("finding DBEGIN") +AC_TRY_RUN([#include + #include +main() +{ + char *b = (void *) malloc(1000); + FILE *fp = fopen("conftest1","w"); + fprintf(fp,"0x%lx",((unsigned long) b) & ~(unsigned long)0xffffff); + fclose(fp); + return 0; +}],dbegin=`cat conftest1`,dbegin=0,dbegin=0) +AC_DEFINE_UNQUOTED(DBEGIN,$dbegin \ +/* where data begins */ +) +AC_MSG_RESULT(got $dbegin) + + +AC_MSG_CHECKING("finding CSTACK_ADDRESS") +AC_TRY_RUN([#include +main() +{ + char *b ; + FILE *fp = fopen("conftest1","w"); + fprintf(fp,"%d",((int) &b)); + fclose(fp); + return 0; +}],cstack_address=`cat conftest1`,cstack_address=0,cstack_address=0) +AC_DEFINE_UNQUOTED(CSTACK_ADDRESS,$cstack_address \ +) +AC_MSG_RESULT(got $cstack_address) + + + +AC_MSG_CHECKING("sizeof long long int") +AC_TRY_RUN([#include +main() +{ + if (sizeof(long long int) == 2*sizeof(long)) return 0; + return 1; +} +],[AC_DEFINE(HAVE_LONG_LONG) +AC_MSG_RESULT(yes)], +AC_MSG_RESULT(no), +AC_MSG_RESULT(no) +) + +AC_SUBST(HAVE_LONG_LONG) + +# readline +AC_ARG_ENABLE(readline, + [--enable-readine enables command line completion via the readline library ],, + enable_readline="yes") + +# ansi lisp +AC_ARG_ENABLE(ansi,[--enable-ansi builds a large gcl aiming for ansi compliance, + --disable-ansi builds the smaller traditional CLtL1 image],,enable_ansi="no") + +if test "$enable_ansi" = "yes" ; then + FLISP=saved_ansi_gcl; +else + FLISP=saved_gcl +fi + +AC_SUBST(FLISP) + +# pagewidth +AC_MSG_CHECKING(for pagewidth) +AC_TRY_RUN([#include + #include +int main() {size_t i=getpagesize(),j; + FILE *fp=fopen("conftest1","w"); + for (j=0;i>>=1;j++); + fprintf(fp,"%u",j); + return 0;}],PAGEWIDTH=`cat conftest1`,PAGEWIDTH=0,PAGEWIDTH=0) +AC_MSG_RESULT($PAGEWIDTH) +AC_DEFINE_UNQUOTED(PAGEWIDTH,$PAGEWIDTH) +AC_SUBST(PAGEWIDTH) + +# bfd probe + +AC_ARG_ENABLE(bfd, + [ --disable-bfd prevents gcl from using libbfd.a for fast object loading and symbol table lookups ] ,, + enable_bfd="yes") + + +# Maximum number of pages + +help="--enable-maxpage=XXXX will compile in a page table of size XXX (default ${default_maxpage})" +AC_ARG_ENABLE(maxpage,[ --enable-maxpage=XXXX will compile in a page table of size XXX (eg '--enable-maxpage=64*1024' would give 64K pages allowing 256 MB if pages are 4K each)] , +[AC_DEFINE_UNQUOTED(MAXPAGE,$enable_maxpage)] +) + +AC_ARG_ENABLE(vssize,[ --enable-vssize=XXXX will compile in a value stack of size XXX] , +[AC_DEFINE_UNQUOTED(VSSIZE,$enable_vssize)] +) + +AC_ARG_ENABLE(machine,[ --enable-machine=XXXX will force the use of one of the definitions in h/XXXX.defs] , +[enable_machine=$enableval],[enable_machine=""]) + +AC_ARG_ENABLE(gmp,[ --enable-gmp=no will disable use of GMP gnu multiprecision arithmetic, (default is =yes)] , +[use_gmp=$enableval],[use_gmp="yes"]) + +AC_ARG_ENABLE(notify,[ --enable-notify=no will disable the automatic notification of gcl maintainers of successful builds/problems] , +[enable_notify=$enableval],[enable_notify="yes"]) + +AC_ARG_ENABLE(tkconfig,[ --enable-tkconfig=XXXX will force the use of a TK_CONFIG_PREFIX=XXXXX as place to look for tkConfig.sh and tclConfig.sh ] , +[TK_CONFIG_PREFIX=$enableval],[TK_CONFIG_PREFIX="unknown"]) + + +AC_ARG_ENABLE(tclconfig,[ --enable-tclconfig=XXXX will force the use of a TCL_CONFIG_PREFIX=XXXXX as place to look for tclConfig.sh and tclConfig.sh ] , +[TCL_CONFIG_PREFIX=$enableval],[TCL_CONFIG_PREFIX="unknown"]) + + +AC_ARG_ENABLE(infodir,[ --enable-infodir=XXXX will force the use of a INFO_DIR=XXXXX as place to look for info ] , +[INFO_DIR=$enableval],[INFO_DIR="unknown"]) + + + + +# Check if Posix compliant getcwd exists, if not we'll use getwd. +AC_CHECK_FUNCS(getcwd) +AC_CHECK_FUNCS(getwd) +AC_CHECK_FUNC(uname, , AC_DEFINE(NO_UNAME)) +AC_CHECK_FUNC(gettimeofday, , AC_DEFINE(NO_GETTOD)) + + +AC_CHECK_HEADERS(sys/ioctl.h) + + +#-------------------------------------------------------------------- +# The code below deals with several issues related to gettimeofday: +# 1. Some systems don't provide a gettimeofday function at all +# (set NO_GETTOD if this is the case). +# 2. SGI systems don't use the BSD form of the gettimeofday function, +# but they have a BSDgettimeofday function that can be used instead. +# 3. See if gettimeofday is declared in the header file. +# if not, set the GETTOD_NOT_DECLARED flag so that tclPort.h can +# declare it. +#-------------------------------------------------------------------- + +AC_CHECK_FUNC([BSDgettimeofday], + [AC_DEFINE(HAVE_BSDGETTIMEOFDAY)], + [AC_CHECK_FUNC([gettimeofday], , + [AC_DEFINE([NO_GETTOD])])]) + +AC_MSG_CHECKING([for gettimeofday declaration]) + +AC_EGREP_HEADER([gettimeofday], + [sys/time.h], + [AC_MSG_RESULT([present])], + [AC_MSG_RESULT([missing]) + AC_DEFINE(GETTOD_NOT_DECLARED)]) + + +AC_CHECK_LIB(m,sin,LIBS="${LIBS} -lm",true) +AC_CHECK_LIB(mingwex,main,LIBS="${LIBS} -lmingwex",true) + +# Should really find a way to check for prototypes, but this +# basically works for now. CM +# +AC_CHECK_HEADERS(math.h,AC_DEFINE(NEED_MATH_H)) + +# +# The second alternative is for solaris. This needs to be +# a more comprehensive later, i.e. checking that the fpclass +# test makes sense. CM +# +AC_MSG_CHECKING([for isnormal]) +AC_TRY_RUN([#define _GNU_SOURCE + #include + int main() { + float f; + return isnormal(f) || !isnormal(f) ? 0 : 1; + }], + AC_DEFINE(HAVE_ISNORMAL) AC_MSG_RESULT(yes), + AC_MSG_CHECKING([for fpclass in ieeefp.h]) + AC_TRY_RUN([#include + int main() { + float f; + return fpclass(f)>=FP_NZERO || fpclass(f) + int main() { + float f; + return isfinite(f) || !isfinite(f) ? 0 : 1; + }], + AC_DEFINE(HAVE_ISFINITE) AC_MSG_RESULT(yes), + AC_MSG_CHECKING([for finite()]) + AC_TRY_RUN([#include + int main() { + float f; + return finite(f) || !finite(f) ? 0 : 1; + }], + AC_DEFINE(HAVE_FINITE) AC_MSG_RESULT(yes), + HAVE_FINITE=0 AC_MSG_RESULT(no),HAVE_FINITE=0 AC_MSG_RESULT(no)) + ,HAVE_ISFINITE=0 AC_MSG_RESULT(no),HAVE_ISFINITE=0 AC_MSG_RESULT(no)) + + + +#-------------------------------------------------------------------- +# Check for the existence of the -lsocket and -lnsl libraries. +# The order here is important, so that they end up in the right +# order in the command line generated by make. Here are some +# special considerations: +# 1. Use "connect" and "accept" to check for -lsocket, and +# "gethostbyname" to check for -lnsl. +# 2. Use each function name only once: can't redo a check because +# autoconf caches the results of the last check and won't redo it. +# 3. Use -lnsl and -lsocket only if they supply procedures that +# aren't already present in the normal libraries. This is because +# IRIX 5.2 has libraries, but they aren't needed and they're +# bogus: they goof up name resolution if used. +# 4. On some SVR4 systems, can't use -lsocket without -lnsl too. +# To get around this problem, check for both libraries together +# if -lsocket doesn't work by itself. +#-------------------------------------------------------------------- +AC_MSG_CHECKING([for sockets]) +tcl_checkBoth=0 +AC_CHECK_FUNC(connect, tcl_checkSocket=0, tcl_checkSocket=1) +if test "$tcl_checkSocket" = 1; then + AC_CHECK_LIB(socket, main, LIBS="$LIBS -lsocket", tcl_checkBoth=1) +fi + + +if test "$tcl_checkBoth" = 1; then + tk_oldLibs=$LIBS + LIBS="$LIBS -lsocket -lnsl" + AC_CHECK_FUNC(accept, tcl_checkNsl=0, [LIBS=$tk_oldLibs]) +fi +AC_CHECK_FUNC(gethostbyname, , AC_CHECK_LIB(nsl, main, [LIBS="$LIBS -lnsl"])) + +if test "$enable_readline" = "yes" ; then + AC_CHECK_LIB([readline], + [main], + [AC_DEFINE(HAVE_READLINE) + LIBS="$LIBS -lreadline -lncurses" + RL_OBJS=readline.o + RL_LIB=lsp/readline.o],, + [-lncurses]) +fi + +if test "$enable_bfd" = "yes" ; then + AC_CHECK_HEADER(bfd.h, + AC_CHECK_LIB(bfd,bfd_init, + if $CC -v 2>&1 | fgrep ming > /dev/null ; then + BFDLIB="-lbfd" + IBRLIB="-liberty" + else + echo 'int main() {bfd_init();bfd_openr("/dev/null",0);return 0;}' >foo.c + MP=`$GCC [[ -Wl,-M ]] -static -o foo foo.c -lbfd -liberty 2>&1 | tr '()' '\012\012' | $AWK '{print $NF}' | sort | uniq` + rm -f foo.c foo + BFDLIB=`echo $MP | tr ' ' '\012' | grep libbfd.a` + IBRLIB=`echo $MP | tr ' ' '\012' | grep libiberty.a` + fi +# +# Old binutils appear to need CONST defined to const +# + AC_MSG_CHECKING(if need to define CONST for bfd) + AC_TRY_RUN([#define IN_GCC + #include + int main() { symbol_info t; return 0;}], + AC_MSG_RESULT(no) + AC_DEFINE(HAVE_LIBBFD) + LIBS="$LIBS $BFDLIB $IBRLIB", + AC_TRY_RUN([#define IN_GCC + #include + #define CONST const + int main() {symbol_info t; return 0;}], + AC_MSG_RESULT(yes) + AC_DEFINE(NEED_CONST) + AC_DEFINE(HAVE_LIBBFD) + LIBS="$LIBS $BFDLIB $IBRLIB", + AC_MSG_RESULT(cannot use bfd),AC_MSG_RESULT(cannot use bfd)), + AC_MSG_RESULT(cannot use bfd)) + + ,,-liberty)) +fi + +AC_SUBST(LIBS) +AC_SUBST(RL_OBJS) +AC_SUBST(RL_LIB) + +AC_MSG_CHECKING(For network code for nsocket.c) +AC_TRY_LINK([ +#include +#include +#include + +#include +#include +#include + +/************* for the sockets ******************/ +#include /* struct sockaddr, SOCK_STREAM, ... */ +#ifndef NO_UNAME +# include /* uname system call. */ +#endif +#include /* struct in_addr, struct sockaddr_in */ +#include /* inet_ntoa() */ +#include /* gethostbyname() */ +],[ connect(0,(struct sockaddr *)0,0); + gethostbyname("jil"); + socket(AF_INET, SOCK_STREAM, 0); + ], +[AC_DEFINE(HAVE_NSOCKET) + AC_MSG_RESULT(yes)], +AC_MSG_RESULT(no)) + + +AC_MSG_CHECKING(check for listen using fcntl) +AC_TRY_COMPILE([#include +#include +], +[FILE *fp=fopen("configure.in","r"); + int orig; + orig = fcntl(fileno(fp), F_GETFL); + if (! (orig & O_NONBLOCK )) return 0; +], +[AC_DEFINE(LISTEN_USE_FCNTL) + AC_MSG_RESULT(yes)], +AC_MSG_RESULT(no)) + + + + +AC_CHECK_FUNC(profil, ,[AC_DEFINE(NO_PROFILE)]) +AC_SUBST(NO_PROFILE) +AC_CHECK_FUNC(setenv,[AC_DEFINE(HAVE_SETENV)],no_setenv=1 ) +AC_SUBST(HAVE_SETENV) +if test "$no_setenv" = "1" ; then +AC_CHECK_FUNC(putenv,[AC_DEFINE(HAVE_PUTENV)],) +AC_SUBST(HAVE_PUTENV) +fi + +AC_CHECK_FUNC(_cleanup, [AC_DEFINE(USE_CLEANUP)],) +AC_SUBST(USE_CLEANUP) +gcl_ok=no + +AC_HEADER_EGREP(LITTLE_ENDIAN, ctype.h, gcl_ok=yes, gcl_ok=noo) +if test $gcl_ok = yes ; then +AC_DEFINE(ENDIAN_ALREADY_DEFINED) +fi + +AC_SUBST(ENDIAN_ALREADY_DEFINED) + + + + +# if test "x$enable_machine" = "x" ; then +AC_MSG_CHECKING([FIONBIO vs. O_NONBLOCK for nonblocking I/O]) + +case $system in + OSF*) + AC_DEFINE(USE_FIONBIO) + AC_MSG_RESULT(FIONBIO) + ;; + SunOS-4*) + AC_DEFINE(USE_FIONBIO) + AC_MSG_RESULT(FIONBIO) + ;; + ULTRIX-4.*) + AC_DEFINE(USE_FIONBIO) + AC_MSG_RESULT(FIONBIO) + ;; + *) + AC_MSG_RESULT(O_NONBLOCK) + ;; +esac + + +AC_CANONICAL_HOST +canonical=$host +## host=CPU-COMPANY-SYSTEM +AC_MSG_RESULT(host=$host) + +use=unknown + +case $canonical in + older) + use=386-bsd;; + + *86-*-linux*) + use=386-linux; ln -snf linux.defs h/$use.defs;; + + m68k-*-linux*) + use=m68k-linux; ln -snf linux.defs h/$use.defs;; + + alpha*-*-linux*) + use=alpha-linux; ln -snf linux.defs h/$use.defs;; + + mips-*-linux*) + use=mips-linux; ln -snf linux.defs h/$use.defs;; + + mipsel-*-linux*) + use=mipsel-linux; ln -snf linux.defs h/$use.defs;; + + sparc*-*-linux*) + use=sparc-linux; ln -snf linux.defs h/$use.defs;; + + arm*-*-linux*) + use=arm-linux; ln -snf linux.defs h/$use.defs;; + + s390-*-linux*) + use=s390-linux; ln -snf linux.defs h/$use.defs;; + + ia64-*-linux*) + use=ia64-linux; ln -snf linux.defs h/$use.defs;; + + hppa-*-linux*) + use=hppa-linux; ln -snf linux.defs h/$use.defs;; + + powerpc-*-linux*) + use=powerpc-linux; ln -snf linux.defs h/$use.defs;; + + alpha-dec-osf) + use=alpha-osf1;; + + mips-dec-ultrix) + use=dec3100;; + + old) + use=dos-go32;; + + *86*-freebsd) + use=FreeBSD;; + + hp3*-*hpux*) + use=hp300;; + + hp3*-*-*bsd*) + use=hp300-bsd;; + + hppa*-*hpux*) + use=hp800;; + + mips-sgi-irix) + case $system in + IRIX5*) + use=irix5;; + IRIX6*) + use=irix6;; + IRIX3*) + use=sgi4d;; + esac ;; + + + m68k-apple-aux*) + use=mac2;; + + old) + use=mp386;; + + *86-ncr-sysv4) + use=ncr;; + + *[3-9]86-*netbsd*) + use=NetBSD;; + + old) + use=NeXT;; + + old) + use=NeXT30-m68k;; + + *86-*nextstep*) + use=NeXT32-i386;; + + *m68*-*nextstep*) + use=NeXT32-m68k;; + + *rs6000-*-aix4*) + use=rios;; + + *rs6000-*-aix3*) + use=rios-aix3;; + + old) + use=rt_aix;; + + old) + use=sgi;; + + sparc-sun-solaris*) + use=solaris;; + + i?86-pc-solaris*) + use=solaris-i386;; + + sparc-*-linux*) + use=sparc-linux;; + + old) + use=sun2r3;; + + old) + use=sun3;; + + m68*-sunos*) + use=sun3-os4;; + + old) + use=sun386i;; + + sparc*sunos*) + use=sun4;; + + *86-sequent-dynix) + use=symmetry;; + + u370*aix) + use=u370_aix;; + + old) + use=vax;; + + i*cygwin*) + if $CC -v 2>&1 | fgrep ming > /dev/null ; + then use=mingw + else use=gnuwin95 + fi;; + + +esac +AC_MSG_CHECKING(check for SV_ONSTACK) +AC_TRY_COMPILE([#include +int joe=SV_ONSTACK; +], +[], +[AC_DEFINE(HAVE_SV_ONSTACK) + AC_SUBST(HAVE_SV_ONSTACK) + AC_MSG_RESULT(yes)], +AC_MSG_RESULT(no)) + + +AC_MSG_CHECKING(check for SIGSYS) +AC_TRY_COMPILE([#include +int joe=SIGSYS; +], +[], +[AC_DEFINE(HAVE_SIGSYS) + AC_SUBST(HAVE_SIGSYS) + AC_MSG_RESULT(yes)], +AC_MSG_RESULT(no)) + + +AC_MSG_CHECKING(check for SIGEMT) +AC_TRY_COMPILE([#include +int joe=SIGEMT; +], +[], +[AC_DEFINE(HAVE_SIGEMT) + AC_SUBST(HAVE_SIGEMT) + AC_MSG_RESULT(yes)], +AC_MSG_RESULT(no)) + + + + +#if test $use = "386-linux" ; then + AC_CHECK_HEADERS(asm/sigcontext.h) + AC_CHECK_HEADERS(asm/signal.h) + AC_TRY_COMPILE([#include + long code; + ], + [ + void *p = ((void *)(((struct sigcontext_struct *)(&code)))); + ], + [ + sigcontext_struct_works=1; + AC_DEFINE(SIGNAL_H_HAS_SIGCONTEXT) + AC_MSG_RESULT("sigcontext in signal.h") + ], + + [sigcontext_struct_works=0; + AC_MSG_RESULT("sigcontext NOT in signal.h")] + ) + if test "$sigcontext_struct_works" = 0 ; then + AC_TRY_COMPILE([#include + #ifdef HAVE_ASM_SIGCONTEXT_H + #include + #endif + #ifdef HAVE_ASM_SIGNAL_H + #include + #endif + long code; + ], + [ + void *p = ((void *)(((struct sigcontext *)(&code)))); + ], + [ + sigcontext_works=1 ; + AC_DEFINE(HAVE_SIGCONTEXT) + AC_MSG_RESULT("use struct sigcontext") + ], + [ + sigcontext_works=0 ; + ]) + + + fi +# echo 'foo() {}' > conftest1.c +# $CC -S conftest1.c +# use_underscore=0 +# if fgrep _foo conftest1.s ; then use_underscore=1 ; fi +# if test $use_underscore = 0 ; then +# MPI_FILE=mpi-386_no_under.o +# else +# MPI_FILE=mpi-386d.o +# fi +# AC_SUBST(MPI_FILE) +# GCC=$CC +# if test -x /usr/bin/i386-glibc20-linux-gcc ; then +# GCC=/usr/bin/i386-glibc20-linux-gcc +# fi +# AC_SUBST(GCC) + +#fi + +AC_PATH_PROG(EMACS,emacs) + + +# check for where the emacs site lisp directory is. +rm -f conftest.el +cat >> conftest.el <&1 | sed -e /Loading/d | sed -e /load/d ` +else + EMACS_SITE_LISP="" +fi +AC_MSG_RESULT($EMACS_SITE_LISP) +AC_SUBST(EMACS_SITE_LISP) + +# check for where the emacs site lisp default.el is +rm -f conftest.el +cat >> conftest.el <&1 | sed -e /Loading/d | sed -e /load/d ` +else + EMACS_DEFAULT_EL="" +fi +if test -f "${EMACS_DEFAULT_EL}" ; then true;else + if test -d "$EMACS_SITE_LISP" ; then + EMACS_DEFAULT_EL=${EMACS_SITE_LISP}/default.el + fi +fi +AC_MSG_RESULT($EMACS_DEFAULT_EL) +AC_SUBST(EMACS_DEFAULT_EL) + + + +# check for where the emacs site lisp info/dir is +rm -f conftest.el +cat >> conftest.el <&1 | sed -e /Loading/d | sed -e /load/d ` +fi +if test -f "${INFO_DIR}dir" ; then true;else +if test -f /usr/info/dir ; then + INFO_DIR=/usr/info/ +else true; +fi +fi +AC_MSG_RESULT($INFO_DIR) +AC_SUBST(INFO_DIR) + +AC_MSG_CHECKING([for tcl/tk]) + + +if test -d "${TCL_CONFIG_PREFIX}" ; then true ; else +rm -f conftest.tcl +cat >> conftest.tcl <> conftest.tcl <&1 | ${AWK} '/"source / {if (i++) next;sub("/[[^/]]*$","",$2);print $2}'` +fi + +fi +fi +#AC_MSG_CHECKING(TK_CONFIG_PREFIX=${TK_CONFIG_PREFIX}) +if test -f ${TK_CONFIG_PREFIX}/tkConfig.sh ; then . ${TK_CONFIG_PREFIX}/tkConfig.sh ; fi + +if test -d ${TK_CONFIG_PREFIX}/tk${TK_VERSION} ; then + TK_LIBRARY=${TK_CONFIG_PREFIX}/tk${TK_VERSION} + else + if test -d ${TK_CONFIG_PREFIX}/../tk${TK_VERSION} ; then + TK_LIBRARY=${TK_CONFIG_PREFIX}/../tk${TK_VERSION} + fi +fi +if test -d ${TK_CONFIG_PREFIX}/tcl${TCL_VERSION} ; then + TCL_LIBRARY=${TK_CONFIG_PREFIX}/tcl${TCL_VERSION} + else + if test -d ${TK_CONFIG_PREFIX}/../tcl${TCL_VERSION} ; then + TCL_LIBRARY=${TK_CONFIG_PREFIX}/../tcl${TCL_VERSION} + fi +fi +if test -f ${TK_CONFIG_PREFIX}/../include/tk.h ; then + TK_INCLUDE=-I${TK_CONFIG_PREFIX}/../include + else + if test -f /usr/include/tcl${TCL_VERSION}/tk.h ; then + TK_INCLUDE=-I/usr/include/tcl${TCL_VERSION} + fi +fi +if test -f ${TCL_CONFIG_PREFIX}/../include/tcl.h ; then + TCL_INCLUDE=-I${TCL_CONFIG_PREFIX}/../include + else + if test -f /usr/include/tcl${TCL_VERSION}/tcl.h ; then + TCL_INCLUDE=-I/usr/include/tcl${TCL_VERSION} + fi +fi +AC_CHECK_LIB(lieee,main,have_ieee=1,have_ieee=0) +if test "$have_ieee" = "0" ; then + TCL_LIBS=`echo ${TCL_LIBS} | sed -e "s:-lieee::g" ` +fi +AC_CHECK_LIB(dl,dlopen,have_dl=1,have_dl=0) +if test "$have_dl" = "0" ; then + TCL_LIBS=`echo ${TCL_LIBS} | sed -e "s:-ldl::g"` +fi + +AC_SUBST(TK_CONFIG_PREFIX) +AC_SUBST(TK_LIBRARY) +AC_SUBST(TCL_LIBRARY) +AC_SUBST(TK_XINCLUDES) +AC_SUBST(TK_INCLUDE) +AC_SUBST(TCL_INCLUDE) +AC_SUBST(TK_LIB_SPEC) +AC_SUBST(TK_BUILD_LIB_SPEC) +AC_SUBST(TK_XLIBSW) +AC_SUBST(TK_XINCLUDES) +AC_SUBST(TCL_LIB_SPEC) +AC_SUBST(TCL_DL_LIBS) +AC_SUBST(TCL_LIBS) + + + + + + +if test -d "${TK_CONFIG_PREFIX}" ; then +AC_MSG_RESULT([using TK_VERSION=${TK_VERSION} in ${TK_CONFIG_PREFIX}]) +else +AC_MSG_RESULT([not found]) +fi + +NOTIFY=$enable_notify +AC_SUBST(NOTIFY) + + + + + +echo enable_machine=$enable_machine +if test "x$enable_machine" != "x" ; then + use=$enable_machine +fi + +## finally warn if we did not find a recognized machine.s +## +#if test "$use" = "unknown" ; then +#types=`echo h/*.defs` | sed -e "s:h/::g" -e "s:\.defs:g"` +#echo got canonical=$canonical, but was not recognized. +#echo Unable to guess type to use. Try one of +#exit(1) +#fi + +AC_MSG_RESULT(use=$use) + + + + +# for sgbc the mprotect capabilities. + +# the time handling for unixtime, add timezone + +AC_MSG_CHECKING([alloca]) +AC_TRY_RUN([int main() { exit(alloca(500) != NULL ? 0 : 1);}], + ,gcl_ok=yes, gcl_ok=no,gcl_ok=no) +if test $gcl_ok = yes ; then + AC_MSG_RESULT(yes) + AC_DEFINE(HAVE_ALLOCA) +else + AC_TRY_RUN([#include + int main() { exit(alloca(500) != NULL ? 0 : 1)}], + ,gcl_ok=yes, gcl_ok=no,gcl_ok=no) + if test $gcl_ok = yes ; then + AC_MSG_RESULT(yes) + AC_DEFINE(HAVE_ALLOCA) + AC_DEFINE(NEED_ALLOCA_H) + fi +fi +if test $gcl_ok = no ; then AC_MSG_RESULT(no) ; fi + + + + + + + + + + +# alloca + +# dlopen etc +# idea make it so you do something dlopen(libX.so,RTLD_GLOBAL) +# then dlload("foo.o") a lisp file can refer to things in libX.so +# + +# what machine this is, and include then a machine specific hdr. +# and machine specific defs. + +# check bzero, + +# check getcwd, getwd etc.. + + + + +# check socket stuff.. + +# getrlimit + +# fionread or block + +rm -f makedefsafter + +MP_INLCUDE="" +if test $use_gmp = yes ; then + AC_MSG_CHECKING([use_gmp=yes, doing configure in gmp directory]) + case "${canonical}" in +# i[[5-9]]86* | pentium* | k6* | athlon*) +# (cd gmp ; ./configure --target=i486) ;; + *) + (cd gmp ; ./configure) ;; + esac + [[ "`ls -1 gmp/mpn/add_n.* 2>/dev/null`" != "" ]] || cp gmp/mpn/generic/*.c gmp/mpn/ + AC_MSG_CHECKING("for size of gmp limbs") + AC_TRY_RUN([#include + #include "h/gmp.h" + + int main() { + FILE *fp=fopen("conftest1","w"); + fprintf(fp,"%u",sizeof(mp_limb_t)); + fclose(fp); + return 0; +}],mpsize=`cat conftest1`,mpsize=0,mpsize=0) + if test "$mpsize" = "0" ; then + echo "Cannot determine mpsize" + exit 1 + fi + AC_DEFINE_UNQUOTED(MP_LIMB_BYTES,$mpsize) + AC_MSG_RESULT($mpsize) + GMP=1 + AC_DEFINE(GMP) + AC_SUBST(GMP) + MP_INCLUDE=h/gmp.h + echo > makedefsafter + echo 'MPFILES=${GMP_DIR}libgmp.a' >> makedefsafter + echo >> makedefsafter +fi +AC_SUBST(MP_INCLUDE) + +# redhat/cygnus released for some reason a buggy version of gcc, +# which no one else released. Catch that here. +AC_MSG_CHECKING([Checking for buggy gcc version from redhat]) +if 2>&1 $CC -v | fgrep "gcc version 2.96" > /dev/null + then + BROKEN_O4_OPT=1 + AC_DEFINE(BROKEN_O4_OPT) + AC_SUBST(BROKEN_O4_OPT) + echo ODIR_DEBUG=-O >> makedefsafter + echo >> makedefsafter + AC_MSG_RESULT([yes .. turning off -O4]) + else + AC_MSG_RESULT([no]) +fi + + +if test -f h/$use.defs ; then + + AC_SUBST(use) + AC_OUTPUT(makedefc) + echo makedefc + cat makedefc + + echo add-defs1 $use + CC=$CC ./add-defs1 $use + +else + echo "Unable to guess machine type" + echo use configure --enable-machine=XXX, for XXX such that h/XXX.defs exists, ie in h/*.defs +fi diff --git a/configure.in b/configure.in new file mode 100644 index 0000000..855ae25 --- /dev/null +++ b/configure.in @@ -0,0 +1,2827 @@ +AC_INIT() +AC_PREREQ([2.61]) +AC_CONFIG_HEADER(h/gclincl.h) + +VERSION=`cat majvers`.`cat minvers` +AC_SUBST(VERSION) + +# some parts of this configure script are taken from the tcl configure.in + +# +# Arguments +# + +dnl help="--enable-maxpage=XXXX will compile in a page table of size XXX (default ${default_maxpage})" + +dnl AC_RUN_IFELSE([AC_LANG_PROGRAM([[ +dnl #include +dnl #include +dnl ]],[[ +dnl FILE *fp=fopen("conftest1","w"); +dnl fprintf(fp,"%u",262144*( SIZEOF_LONG >>2)/(1<<($PAGEWIDTH-12))); +dnl return 0;]])],[def_maxpage=`cat conftest1`],[def_maxpage=262144]) + +dnl AC_ARG_ENABLE(maxpage, +dnl [ --enable-maxpage=XXXX will compile in a page table of size XXX +dnl (eg '--enable-maxpage=64*1024' would produce +dnl 64K pages allowing 256 MB if pages are 4K each)], +dnl ,enable_maxpage=$def_maxpage) + +AC_ARG_ENABLE(widecons,[use a three word cons with simplified typing],[AC_DEFINE([WIDE_CONS],[1],[three word cons])]) + + +AC_ARG_ENABLE(safecdr,[protect cdr from immfix and speed up type processing],,[enable_safecdr="no"]) +if test "$enable_safecdr" = "yes" ; then + AC_DEFINE([USE_SAFE_CDR],[1],[protect cdr from immfix and speed up type processing]) +fi +AC_ARG_ENABLE(safecdrdbg,[debug safecdr code],[AC_DEFINE([DEBUG_SAFE_CDR],[1],[debug safecdr code])]) + +AC_ARG_ENABLE([prelink],[--enable-prelink will insist that the produced images may be prelinked],[PRELINK_CHECK=t],[PRELINK_CHECK=]) + +AC_ARG_ENABLE([fastimmfix],[--enable-fastimmfix=XXXX will reject low immediate fixnums unless 1<=2) print A[[2]]}'` +AC_DEFINE_UNQUOTED(HOST_CPU,"`echo $host_cpu | awk '{print toupper($0)}'`",[Host cpu]) +AC_DEFINE_UNQUOTED(HOST_KERNEL,"`echo $my_host_kernel | awk '{print toupper($0)}'`",[Host kernel]) +if test "$my_host_system" != "" ; then + AC_DEFINE_UNQUOTED(HOST_SYSTEM,"`echo $my_host_system | awk '{print toupper($0)}'`",[Host system]) +fi +## host=CPU-COMPANY-SYSTEM +AC_MSG_RESULT(host=$host) + +PROCESSOR_FLAGS=${PROCESSOR_FLAGS:-""} + +use=unknown +TLDFLAGS="" +case $canonical in + older) + use=386-bsd;; + + sh4*linux*) + use=sh4-linux;; + + *x86_64*linux*) + use=amd64-linux;; + + *x86_64*kfreebsd*) + use=amd64-kfreebsd;; + + *86*linux*) + use=386-linux;; + + *86*kfreebsd*) + use=386-kfreebsd;; + + *86*gnu*) + use=386-gnu;; + +# m6800 not working with gcc-3.2 + m68k*linux*) + if test "$use_common_binary" = "yes"; then + host=m68020-unknown-linux-gnu + echo "The host is canonicalised to $host" + fi + use=m68k-linux;; + + alpha*linux*) + use=alpha-linux;; + + mips*linux*) + use=mips-linux;; + + mipsel*linux*) + use=mipsel-linux;; + + sparc*linux*) + use=sparc-linux;; + + aarch64*linux*) + use=aarch64-linux;; + + arm*linux*) + use=arm-linux;; + + s390*linux*) + use=s390-linux;; + + ia64*linux*) + use=ia64-linux;; + + hppa*linux*) + use=hppa-linux;; + + powerpc*linux*) + use=powerpc-linux;; + + powerpc-*-darwin*) + use=powerpc-macosx;; + + *86*darwin*) + use=386-macosx + if test "$build_cpu" = "x86_64" ; then + CFLAGS="-m64 $CFLAGS"; + LDFLAGS="-m64 -Wl,-headerpad,72 $LDFLAGS"; + else + CFLAGS="-m32 $CFLAGS"; + LDFLAGS="-m32 -Wl,-headerpad,56 $LDFLAGS"; + fi;; + + alpha-dec-osf) + use=alpha-osf1;; + + mips-dec-ultrix) + use=dec3100;; + + old) + use=dos-go32;; + + *86*-freebsd*) + use=FreeBSD;; + + hp3*-*hpux*) + use=hp300;; + + hp3*-*-*bsd*) + use=hp300-bsd;; + + hppa*-*hpux*) + use=hp800;; + + mips-sgi-irix) + case $system in + IRIX5*) + use=irix5;; + IRIX6*) + use=irix6;; + IRIX3*) + use=sgi4d;; + esac ;; + + + m68k-apple-aux*) + use=mac2;; + + old) + use=mp386;; + + *86-ncr-sysv4) + use=ncr;; + + *[3-9]86-*netbsd*) + use=NetBSD;; + + old) + use=NeXT;; + + old) + use=NeXT30-m68k;; + + *86-*nextstep*) + use=NeXT32-i386;; + + *m68*-*nextstep*) + use=NeXT32-m68k;; + + *rs6000-*-aix4*) + use=rios;; + + *rs6000-*-aix3*) + use=rios-aix3;; + + old) + use=rt_aix;; + + old) + use=sgi;; + + sparc-sun-solaris*) + use=solaris;; + + i?86-pc-solaris*) + use=solaris-i386;; + + old) + use=sun2r3;; + + old) + use=sun3;; + + m68*-sunos*) + use=sun3-os4;; + + old) + use=sun386i;; + + sparc*sunos*) + use=sun4;; + + *86-sequent-dynix) + use=symmetry;; + + u370*aix) + use=u370_aix;; + + old) + use=vax;; + + i*mingw*) + if test "$use_common_binary" = "yes"; then + host=i386-pc-mingw32 + PROCESSOR_FLAGS="-march=i386 " + echo "The host is canonicalised to $host" + fi + use=mingw;; + + i*cygwin*) + if $CC -v 2>&1 | fgrep ming > /dev/null ; + then use=mingw + else use=gnuwin95 + fi;; + + *openbsd*) + # 'ld -Z' means disable W^X + TLDFLAGS="$TLDFLAGS -Z" + use=FreeBSD;; + +esac + +AC_SUBST(PROCESSOR_FLAGS) + +echo enable_machine=$enable_machine +if test "x$enable_machine" != "x" ; then + use=$enable_machine +fi + +def_dlopen="no" +def_statsysbfd="no" +def_custreloc="yes" +#def_statsysbfd="yes" +#def_custreloc="no" +def_locbfd="no" +def_oldgmp="no" +def_pic="no"; +def_static="no"; +def_debug="no"; +case $use in + *kfreebsd) + ln -snf linux.defs h/$use.defs;; + *gnu) + ln -snf linux.defs h/$use.defs;; + *linux) + ln -snf linux.defs h/$use.defs; + case $use in +# def_static -- Function descriptors are currently realized at runtime in a non-reproducible fashion +# on these architectures -- CM + powerpc*) +# if test "$host_cpu" = "powerpc64" ; then def_dlopen="yes" ; def_custreloc="no" ; fi + ;; + ia64*) + def_dlopen="yes" ; def_custreloc="no" ;; + hppa*) + def_pic="yes" ;; +# def_dlopen="yes" ; def_custreloc="no" ; def_pic="yes" ;; + esac;; +esac + +AC_ARG_ENABLE(dlopen, + [ --enable-dlopen uses dlopen for loading objects, which can then not be retained in saved images ] + ,,enable_dlopen="$def_dlopen") +AC_ARG_ENABLE(statsysbfd, + [ --enable-statsysbfd uses a static sytem bfd library for loading and relocationing object files ] + ,,enable_statsysbfd="$def_statsysbfd") +AC_ARG_ENABLE(dynsysbfd, + [ --enable-dynsysbfd uses a dynamic shared sytem bfd library for loading and relocationing object files ] + ,,enable_dynsysbfd="no") +#AC_ARG_ENABLE(locbfd, +# [ --enable-locbfd uses a static bfd library built from this source tree for loading and relocationing object files ] +# ,,enable_locbfd="$def_locbfd") +AC_ARG_ENABLE(custreloc, + [ --enable-custreloc uses custom gcl code if available for loading and relocationing object files ] + ,,enable_custreloc="$def_custreloc") +AC_ARG_ENABLE(debug, + [ --enable-debug builds gcl with -g in CFLAGS to enable running under gdb ] + ,,enable_debug="$def_debug") +AC_ARG_ENABLE(gprof, + [ --enable-gprof builds gcl with -pg in CFLAGS to enable profiling with gprof ] + ,,enable_gprof="no") +AC_ARG_ENABLE(static,[ --enable-static will link your GCL against static as opposed to shared system libraries ] , + [enable_static=$enableval],[enable_static="$def_static"]) +AC_ARG_ENABLE(pic, + [ --enable-pic builds gcl with -fPIC in CFLAGS ] + ,,enable_pic="$def_pic") + +AC_ARG_ENABLE(oldgmp, + [ --enable-oldgmp will link against gmp2 instead of gmp3 ] + ,,enable_oldgmp="$def_oldgmp") + +AC_ARG_ENABLE(dynsysgmp, + [ --enable-dynsysgmp will link against the system libgmp3 overriding certain functions with patched versions from the local source ] + ,,enable_dynsysgmp="yes") + +load_opt="0" +if test "$enable_dlopen" = "yes" ; then + load_opt=1 +fi +if test "$enable_statsysbfd" = "yes" ; then + case $load_opt in + 0) load_opt=1;; + 1) load_opt=2;; + esac +fi +if test "$enable_dynsysbfd" = "yes" ; then + case $load_opt in + 0) load_opt=1;; + 1) load_opt=2;; + 2) load_opt=3;; + esac +fi +if test "$enable_locbfd" = "yes" ; then + case $load_opt in + 0) load_opt=1;; + 1) load_opt=2;; + 2) load_opt=3;; + 3) load_opt=4;; + esac +fi +if test "$enable_custreloc" = "yes" ; then + case $load_opt in + 0) load_opt=1;; + 1) load_opt=2;; + 2) load_opt=3;; + 3) load_opt=4;; + 4) load_opt=5;; + esac +fi + +if test "$load_opt" != "1" ; then + echo "Exactly one loader option must be chosen: dlopen=$enable_dlopen statsysbfd=$enable_statsysbfd dynsysbfd=$enable_dynsysbfd locbfd=$enable_locbfd custreloc=$enable_custreloc" + exit 1 +fi + +TLDFLAGS="" +if test "$enable_static" = "yes" ; then + TLDFLAGS="-static -Wl,-zmuldefs $TLDFLAGS"; #FIXME should be in unixport/makefile + AC_DEFINE(STATIC_LINKING,1,[staticly linked images]) +fi +case $use in + *gnuwin*) + TLDFLAGS="$TLDFLAGS -Wl,--stack,8000000";; +esac + +## finally warn if we did not find a recognized machine.s +## +#if test "$use" = "unknown" ; then +#types=`echo h/*.defs` | sed -e "s:h/::g" -e "s:\.defs:g"` +#echo got canonical=$canonical, but was not recognized. +#echo Unable to guess type to use. Try one of +#exit(1) +#fi + +AC_MSG_RESULT([use=$use]) + + +# +# System programs +# + +# We set the default CFLAGS below, and don't want the autoconf default +# CM 20040106 +if test "$CFLAGS" = "" ; then + CFLAGS=" " +fi +if test "$LDFLAGS" = "" ; then + LDFLAGS=" " +fi + +AC_PROG_CC +AC_PROG_CPP +AC_SUBST(CC) + + +# can only test for numbers -- CM +# if test "${GCC}" -eq "yes" ; then +#if [[ "${GCC}" = "yes" ]] ; then +# Allog for environment variable overrides on compiler selection -- CM +#GCC=$CC +#else +#GCC="" +#fi +# subst GCC not only under 386-linux, but where available -- CM + +if test "$GCC" = "yes" ; then + + TCFLAGS="-Wall -fsigned-char" + + #FIXME -Wno-unused-but-set-variable when time + TMPF=-Wno-unused-but-set-variable + AC_MSG_CHECKING([for CFLAG $TMPF]) + CFLAGS_ORI=$CFLAGS + CFLAGS="$CFLAGS $TMPF" + AC_TRY_RUN([int main() {return 0;}],TCFLAGS="$TCFLAGS $TMPF";AC_MSG_RESULT(yes),AC_MSG_RESULT(no),AC_MSG_RESULT(no)) + CFLAGS=$CFLAGS_ORI + +else + TCFLAGS="-fsigned-char" +fi +if test "$GCC" = "yes" ; then + TCFLAGS="$TCFLAGS -pipe" + case $use in + *mingw*|*gnuwin*) +# echo "WARNING: Remove -fno-zero-initialized-in-bss from makedefs if gcc less than 3.3.1." +# echo " It is otherwise needed for the Unexec stuff to work." +# if test "$enable_debug" = "yes" ; then TCFLAGS="$TCFLAGS -gstabs" ; fi + TCFLAGS="$TCFLAGS -fno-zero-initialized-in-bss -mms-bitfields";; + esac +fi +#if test -f /proc/sys/kernel/exec-shield ; then +# exec_stat=`cat /proc/sys/kernel/exec-shield` +# if test "$exec_stat" != "0" ; then +# # CFLAGS here to hopefully cover the DBEGIN routine below +# CFLAGS="$CFLAGS -Wa,--execstack" +# fi +#fi + +TO3FLAGS="" +TO2FLAGS="" + +#TFPFLAG="-fomit-frame-pointer" +# FIXME -- remove when mingw compiler issues are fixed +case "$use" in + *mingw*) + TFPFLAG="";; + m68k*)#FIXME gcc 4.x bug workaround + TFPFLAG="";; + *) + TFPFLAG="-fomit-frame-pointer";; +esac + +AC_CHECK_PROGS(AWK,[gawk nawk awk]) + +# Work around system/gprof mips/hppa hang +AC_MSG_CHECKING([working gprof]) +old_enable_gprof=$enable_gprof +case $use in + powerpc*) if test "$host_cpu" = "powerpc64le" ; then enable_gprof="no"; fi;; + sh4*) enable_gprof="no";; + ia64*) enable_gprof="no";; +# mips*) enable_gprof="no";; + hppa*) enable_gprof="no";; + arm*) enable_gprof="no";;#FIXME mcount compiled as a 24/22 bit reloc even with -mlong-calls, marginally accessible + *gnu) enable_gprof="no";; +esac +if test "$enable_gprof" = "$old_enable_gprof" ; then + AC_MSG_RESULT([ok]) +else + AC_MSG_RESULT([disabled]) +fi + +if test "$enable_gprof" = "yes" ; then + AC_MSG_CHECKING(for text start) + echo 'int main () {return(0);}' >foo.c + $CC foo.c -o foo + GCL_GPROF_START=`nm foo | $AWK '/ *[[TD]] *__*start$/ {print $NF}'` # D for ppc64 -- FIXME custreloc + rm -f foo.c foo + if test "$GCL_GPROF_START" != "" ; then + AC_MSG_RESULT($GCL_GPROF_START) + AC_DEFINE_UNQUOTED(GCL_GPROF_START,$GCL_GPROF_START,[starting address for gprof]) + case "$use" in + arm*) + #FIXME report and remove this when done + AC_MSG_RESULT(Reducing optimization on profiling arm build to workaround gcc bug) + enable_debug=yes;; + esac + TCFLAGS="$TCFLAGS -pg"; + TLIBS="$TLIBS -pg"; + TFPFLAG="" + AC_DEFINE(GCL_GPROF,1,[use gprof profiling]) + else + enable_gprof="no"; + fi +fi + +if $CC -v 2>&1 | tail -1 | grep "gcc version 4.6.1" >/dev/null ; then + case "$use" in + arm*) + #FIXME report and remove this when done + AC_MSG_RESULT(Reducing optimization on arm build to workaround gcc 4.6 bug) + enable_debug=yes;; + esac +fi + + +if test "$enable_debug" = "yes" ; then + TCFLAGS="$TCFLAGS -g" + # for subconfigurations + CFLAGS="$CFLAGS -g" +else + TO3FLAGS="-O3 $TFPFLAG" + TO2FLAGS="-O" +fi + +# gcc on ppc cannot compile our new_init.c with full opts --CM +TONIFLAGS="" +case $use in + powerpc*macosx) + TCFLAGS="$TCFLAGS -mlongcall";; + *linux) + case $use in +# amd64*) # stack-boundary option does not work +# TCFLAGS="$TCFLAGS -m64 -mpreferred-stack-boundary=8";; + alpha*) + TCFLAGS="$TCFLAGS -mieee" + if test "$enable_debug" != "yes" ; then TO3FLAGS="-O0" ; fi #FIXME needed asof gcc 4.8.1 + ;; +# m68k*) +# TCFLAGS="$TCFLAGS -ffloat-store";; + aarch64*) + TLIBS="$TLIBS -lgcc_s";; + hppa*) + TCFLAGS="$TCFLAGS -mlong-calls " + TLIBS="$TLIBS -lgcc_s" # workaround hppa __moddi3 local func symbols with default linker flags + if test "$enable_debug" != "yes" ; then TO3FLAGS="-O2" ; TFPFLAG=""; fi #FIXME needed asof gcc 4.8.1 +# TCFLAGS="$TCFLAGS -ffunction-sections" +# if test "$enable_debug" != "yes" ; then TO3FLAGS="-O $TFPFLAG" ; fi +# if test "$enable_debug" != "yes" ; then TO2FLAGS="-O" ; fi + ;; + mips*) +# if test "$enable_debug" != "yes" ; then TO3FLAGS="-O0" ; fi #FIXME needed asof gcc 4.6.2 + ;; + ia64*) + if test "$enable_debug" != "yes" ; then TO3FLAGS="-O" ; fi #FIXME needed asof gcc 4.8.1 + ;; + arm*) + TCFLAGS="$TCFLAGS -mlong-calls -fdollars-in-identifiers -g " +# if test "$enable_debug" != "yes" ; then TO3FLAGS="-O" ; fi #FIXME needed asof gcc 4.6.2 +# if test "$enable_debug" != "yes" ; then TO2FLAGS="-O" ; fi + ;; + powerpc*) + TCFLAGS="$TCFLAGS -mlongcall" + ;; +# if $CC -v 2>&1 | grep -q "gcc version 3.2" ; then +# echo Reducing optimization for buggy gcc-3.2 +# if test "$enable_debug" != "yes" ; then TONIFLAGS="-O $TFPFLAG" ; fi +# fi; +# echo Probing for longcall +# if ! $CC -v 2>&1 | $AWK '/^gcc version / {split($3,A,".");if (A[[1]]+0>3 || (A[[1]]+0>=3 && A[[2]]+0>=3)) exit 1;}'; then +# echo Enabling longcall on gcc 3.3 or later +# TCFLAGS="$TCFLAGS -mlongcall" +# echo Reducing optimization for buggy gcc 3.3 or later +# if test "$enable_debug" != "yes" ; then TONIFLAGS="-O $TFPFLAG" ; fi +# fi;; + esac;; +esac +if test "$enable_pic" = "yes" ; then + TCFLAGS="$TCFLAGS -fPIC" +fi + +FDEBUG=`echo $CFLAGS | tr ' ' '\012' |grep "^\-g$"|tr '\012' ' '` +#CFLAGS=`echo $CFLAGS | tr ' ' '\012' |grep -v "^\-g$"` +FOMITF=`echo $CFLAGS | tr ' ' '\012' |grep "^\-fomit-frame-pointer$"|tr '\012' ' '` +CFLAGS=`echo $CFLAGS | tr ' ' '\012' |grep -v "^\-fomit-frame-pointer$"|tr '\012' ' '` +FOOPT3=`echo $CFLAGS | tr ' ' '\012' |grep "^\-O3$"|tr '\012' ' '` +CFLAGS=`echo $CFLAGS | tr ' ' '\012' |grep -v "^\-O3$"|tr '\012' ' '` +FOOPT2=`echo $CFLAGS | tr ' ' '\012' |grep "^\-O2$"|tr '\012' ' '` +CFLAGS=`echo $CFLAGS | tr ' ' '\012' |grep -v "^\-O2$"|tr '\012' ' '` +FOOPT1=`echo $CFLAGS | tr ' ' '\012' |grep "^\-O1$"|tr '\012' ' '` +TMPF=`echo $CFLAGS | tr ' ' '\012' |grep "^\-O$"|tr '\012' ' '` +FOOPT1="$FOOPT1$TMPF" +CFLAGS=`echo $CFLAGS | tr ' ' '\012' |grep -v "^\-O1$"|grep -v "^\-O$"|tr '\012' ' '` +FOOPT0=`echo $CFLAGS | tr ' ' '\012' |grep "^\-O0$"|tr '\012' ' '` +CFLAGS=`echo $CFLAGS | tr ' ' '\012' |grep -v "^\-O0$"|tr '\012' ' '` + +if test "$FOOPT0" != "" ; then + TO3FLAGS=`echo $TO3FLAGS | sed 's,\-O[[123 ]],-O0 ,g' | sed 's,\-O$,-O0 ,g'` + TO2FLAGS=`echo $TO2FLAGS | sed 's,\-O[[123 ]],-O0 ,g' | sed 's,\-O$,-O0 ,g'` +else +if test "$FOOPT1" != "" ; then + TO3FLAGS=`echo $TO3FLAGS | sed 's,\-O[[2-3]],-O1,g'` + TO2FLAGS=`echo $TO2FLAGS | sed 's,\-O[[2-3]],-O1,g'` +else +if test "$FOOPT2" != "" ; then + TO3FLAGS=`echo "$TO3FLAGS" | sed 's,\-O3,-O2,g'` + TO2FLAGS=`echo "$TO2FLAGS" | sed 's,\-O3,-O2,g'` +fi +fi +fi + +if test "$FDEBUG" != "" ; then + TO3FLAGS=`echo $TO3FLAGS | sed 's,\-fomit-frame-pointer,,g'` + TO2FLAGS=`echo $TO2FLAGS | sed 's,\-fomit-frame-pointer,,g'` +fi + +if test "$FOMITF" != "" ; then + TO3FLAGS="$TO3FLAGS $FOMITF" +fi + +# Step 1: set the variable "system" to hold the name and version number +# for the system. This can usually be done via the "uname" command, but +# there are a few systems, like Next, where this doesn't work. + +AC_MSG_CHECKING([system version (for dynamic loading)]) +if machine=`uname -m` ; then true; else machine=unknown ; fi + +AC_CHECK_PROGS(MAKEINFO,makeinfo,"false") +AC_SUBST(MAKEINFO) + +if test -f /usr/lib/NextStep/software_version; then + system=NEXTSTEP-`${AWK} '/3/,/3/' /usr/lib/NextStep/software_version` +else + system=`uname -s`-`uname -r` + if test "$?" -ne 0 ; then + AC_MSG_RESULT([unknown (can't find uname command)]) + system=unknown + else + # Special check for weird MP-RAS system (uname returns weird + # results, and the version is kept in special file). + + if test -r /etc/.relid -a "X`uname -n`" = "X`uname -s`" ; then + system="MP-RAS-`${AWK} '{print $3}' '/etc/.relid'`" + fi + if test "`uname -s`" = "AIX" ; then + system=AIX-`uname -v`.`uname -r` + fi + AC_MSG_RESULT($system) + fi +fi + +case $use in + *macosx) + AC_CHECK_HEADERS(malloc/malloc.h,,[AC_MSG_ERROR([need malloc.h on macosx])]) + AC_CHECK_MEMBER([struct _malloc_zone_t.memalign], + AC_DEFINE(HAVE_MALLOC_ZONE_MEMALIGN,1,[memalign element present]), [], + [ + #include + ]) + AC_SUBST(HAVE_MALLOC_ZONE_MEMALIGN) + ;; +esac + + +AC_CHECK_HEADERS(setjmp.h, + AC_MSG_CHECKING([sizeof jmp_buf]) + AC_RUN_IFELSE([ + AC_LANG_SOURCE([[ + #include + #include + int main() { + FILE *fp=fopen("conftest1","w"); + fprintf(fp,"%lu\n",sizeof(jmp_buf)); + fclose(fp); + return 0; + }]])], + [sizeof_jmp_buf=`cat conftest1` + AC_MSG_RESULT($sizeof_jmp_buf) + AC_DEFINE_UNQUOTED(SIZEOF_JMP_BUF,$sizeof_jmp_buf,[sizeof jmp_buf])], + [AC_MSG_RESULT(no)])) + +# sysconf + +AC_CHECK_HEADERS(unistd.h, + AC_CHECK_LIB(c,sysconf, + AC_MSG_CHECKING(_SC_CLK_TCK) + AC_TRY_RUN([#include + #include + int + main() { + FILE *fp=fopen("conftest1","w"); + fprintf(fp,"%lu\n",sysconf(_SC_CLK_TCK)); + fclose(fp); + return 0; + }], + hz=`cat conftest1` + AC_DEFINE_UNQUOTED(HZ,$hz,[time system constant]) + ,hz=0,hz=0) + [AC_MSG_RESULT($hz)] + dnl AC_MSG_CHECKING(_SC_PHYS_PAGES) + dnl AC_RUN_IFELSE([ + dnl AC_LANG_SOURCE([[ + dnl #include + dnl #include + dnl int main() { + dnl FILE *fp=fopen("conftest1","w"); + dnl fprintf(fp,"%lu\n",sysconf(_SC_PHYS_PAGES)); + dnl fclose(fp); + dnl return 0; + dnl }]])], + dnl [phys=`cat conftest1` + dnl AC_MSG_RESULT($phys) + dnl AC_DEFINE(HAVE_SYSCONF_PHYS_PAGES,$phys,[probe runtime phys pages for gc performance])], + dnl [AC_MSG_RESULT(no)]) + )) + + +#MY_SUBDIRS= + +# +# GMP +# + +rm -f makedefsafter + +MP_INCLUDE="" +if test $use_gmp = yes ; then + + PATCHED_SYMBOLS="" + if test "$enable_dynsysgmp" = "yes" ; then + AC_CHECK_HEADERS(gmp.h, + AC_CHECK_LIB(gmp,__gmpz_init, + AC_MSG_CHECKING("for external gmp version") + AC_TRY_RUN([#include + int main() { + #if __GNU_MP_VERSION > 3 + return 0; + #else + return -1; + #endif + }], +# MPFILES=$GMPDIR/mpn/mul_n.o +# PATCHED_SYMBOLS=__gmpn_toom3_mul_n + MPFILES= + PATCHED_SYMBOLS= +# if test "$use" = "m68k-linux" ; then +# MPFILES="$MPFILES $GMPDIR/mpn/lshift.o $GMPDIR/mpn/rshift.o" +# PATCHED_SYMBOLS="$PATCHED_SYMBOLS __gmpn_lshift __gmpn_rshift" +# fi + TLIBS="$TLIBS -lgmp" + echo "#include \"gmp.h\"" >foo.c + echo "int main() {return 0;}" >>foo.c + MP_INCLUDE=`cpp foo.c | $AWK '/(\/|\\\\)gmp.h/ {if (!i) print $3;i=1}' | tr -d '"'` + rm -f foo.c, + echo "Cannot use dynamic gmp lib" , echo "Cannot use dynamic gmp lib" ), + echo "Cannot use dynamic gmp lib" ,), + echo "Cannot use dynamic gmp lib" ,) +fi + +NEED_LOCAL_GMP='' +if test "$MP_INCLUDE" = "" ; then + NEED_LOCAL_GMP=1; +fi +if test "$PATCHED_SYMBOLS" != "" ; then + NEED_LOCAL_GMP=1; +fi + +if test "$NEED_LOCAL_GMP" != "" ; then + + GMPDIR=gmp4 + AC_MSG_CHECKING([use_gmp=yes, doing configure in gmp directory]) + echo + echo "#" + echo "#" + echo "# -------------------" + echo "# Subconfigure of GMP" + echo "#" + echo "#" + + if test "$use_common_binary" = "yes"; then + cd $GMPDIR && ./configure --build=$host && cd .. + else + cd $GMPDIR && ./configure && cd .. + fi + #MY_SUBDIRS="$MY_SUBDIRS $GMPDIR" + + echo "#" + echo "#" + echo "#" + echo "# Subconfigure of GMP done" + echo "# ------------------------" + echo "#" + + if test "$MP_INCLUDE" = "" ; then + cp $GMPDIR/gmp.h h/gmp.h + MP_INCLUDE=h/gmp.h + MPFILES=gmp_all + fi + +fi + +AC_MSG_CHECKING("for leading underscore in object symbols") +cat>foo.c < +#include +int main() {FILE *f;double d=0.0;getc(f);cos(d);return 0;} +EOFF +$CC -c foo.c -o foo.o +if nm foo.o |grep " U " | grep "_cos" >/dev/null || nm foo.o |grep " U " | grep " _getc" >/dev/null ; then + LEADING_UNDERSCORE=1 + AC_DEFINE(LEADING_UNDERSCORE,1,[symbol name mangling convention]) + AC_MSG_RESULT("yes") +else + LEADING_UNDERSCORE="" + AC_MSG_RESULT("no") +fi + + +AC_MSG_CHECKING("for GNU ld option -Map") +touch map +$CC -o foo [ -Wl,-Map ] map foo.o >/dev/null 2>&1 +if test `cat map | wc -l` != "0" ; then + AC_MSG_RESULT("yes") + AC_DEFINE(HAVE_GNU_LD,1,[gnu linker present]) + GNU_LD=1 +else + AC_MSG_RESULT("no") + GNU_LD= +fi +rm -f foo.c foo.o foo map + +AC_MSG_CHECKING([for size of gmp limbs]) +AC_RUN_IFELSE([AC_LANG_PROGRAM([[ + #include + #include "$MP_INCLUDE" + ]],[[ + FILE *fp=fopen("conftest1","w"); + fprintf(fp,"%u",sizeof(mp_limb_t)); + fclose(fp); + return 0; + ]])],[mpsize=`cat conftest1`],[AC_MSG_ERROR([Cannot determine mpsize])]) +AC_DEFINE_UNQUOTED(MP_LIMB_BYTES,$mpsize,[sizeof mp_limb in gmp library]) +AC_MSG_RESULT($mpsize) + +AC_MSG_CHECKING([_SHORT_LIMB]) +AC_RUN_IFELSE([AC_LANG_PROGRAM([[ + #include + #include "$MP_INCLUDE" + ]],[[ + #ifdef _SHORT_LIMB + return 0; + #else + return 1; + #endif + ]])],[AC_DEFINE(__SHORT_LIMB,1,[short gmp3 limbs]) AC_MSG_RESULT(yes)],[AC_MSG_RESULT(no)]) + +AC_MSG_CHECKING([_LONG_LONG_LIMB]) +AC_RUN_IFELSE([AC_LANG_PROGRAM([[ + #include + #include "$MP_INCLUDE" + ]],[[ + #ifdef _LONG_LONG_LIMB + return 0; + #else + return 1; + #endif + ]])],[AC_DEFINE(__LONG_LONG_LIMB,1,[long gmp3 limbs]) AC_MSG_RESULT(yes)],[AC_MSG_RESULT(no)]) + + GMP=1 + AC_DEFINE(GMP,1,[using gmp]) + AC_SUBST(GMP) + AC_SUBST(GMPDIR) + echo > makedefsafter + echo "MPFILES=$MPFILES" >> makedefsafter + echo "PATCHED_SYMBOLS=$PATCHED_SYMBOLS" >> makedefsafter + echo >> makedefsafter +fi + + +# +# X windows +# + +if test "$enable_xgcl" = "yes" ; then + + AC_PATH_X +# AC_PATH_XTRA +# echo $X_CFLAGS +# echo $X_LIBS +# echo $X_EXTRA_LIBS +# echo $X_PRE_LIBS + + miss=0 +# AC_CHECK_LIB(Xmu,main,X_LIBS="$X_LIBS",miss=1,$X_LIBS)#FIXME remove these +# AC_CHECK_LIB(Xt,main,X_LIBS="$X_LIBS",miss=1,$X_LIBS) +# AC_CHECK_LIB(Xext,main,X_LIBS="$X_LIBS",miss=1,$X_LIBS) +# AC_CHECK_LIB(Xaw,main,X_LIBS="$X_LIBS",miss=1,$X_LIBS)#until here + AC_CHECK_LIB(X11,main,X_LIBS="$X_LIBS -lX11",miss=1,$X_LIBS) + + if test "$miss" = "1" ; then + X_CFLAGS= + X_LIBS= + X_EXTRA_LIBS= + X_PRE_LIBS= + echo missing x libraries -- cannot compile xgcl + else + AC_DEFINE(HAVE_XGCL,1,[using xgcl]) + fi +fi + + +AC_SUBST(X_LIBS) +AC_SUBST(X_CFLAGS) + +# +# Dynamic loading +# + +if test "$enable_dlopen" = "yes" ; then + + AC_CHECK_LIB(dl,dlopen,have_dl=1,have_dl=0) + if test "$have_dl" = "0" ; then + echo "Cannot find dlopen in -dl" + exit 1 + fi +dnl AC_SEARCH_LIBS(dlopen, dl, have_dl=1, AC_ERROR(dlopen not found)) +dnl LIBS and TLIBS - why not merged from the beginning? + + TLIBS="$TLIBS -ldl -rdynamic" + TCFLAGS="-fPIC $TCFLAGS" +dnl TLIBS="$TLIBS -rdynamic" + AC_DEFINE(USE_DLOPEN,1,[link compiled objects via libdl]) +fi + +if test "$enable_statsysbfd" = "yes" || test "$enable_dynsysbfd" = "yes" ; then + AC_CHECK_HEADERS(bfd.h, + AC_CHECK_LIB(bfd,bfd_init, + # + # Old binutils appear to need CONST defined to const + # + AC_MSG_CHECKING(if need to define CONST for bfd) + AC_TRY_RUN([#define IN_GCC + #include + int main() { symbol_info t; return 0;}], + AC_MSG_RESULT(no), + AC_TRY_RUN([#define CONST const + #define IN_GCC + #include + int main() {symbol_info t; return 0;}], + AC_MSG_RESULT(yes) + AC_DEFINE(NEED_CONST,1,[binutils requires CONST definition]), + AC_MSG_ERROR([cannot use bfd]), + AC_MSG_ERROR([cannot use bfd])), + AC_MSG_ERROR([cannot use bfd])) + ,,-liberty)) + + AC_DEFINE(HAVE_LIBBFD,1,[use libbfd]) + +# +# BFD boolean syntax +# + + AC_MSG_CHECKING(for useable bfd_boolean) + AC_RUN_IFELSE([AC_LANG_PROGRAM([[ + #define IN_GCC + #include + bfd_boolean foo() {return FALSE;} + ]],[[return 0;]])], + [AC_MSG_RESULT(yes) + AC_DEFINE(HAVE_BFD_BOOLEAN,1,[bfd_boolean defined])], + [AC_MSG_RESULT(no)]) + +# +# bfd_link_info.output_bfd minimal configure change check +# + + AC_CHECK_MEMBER([struct bfd_link_info.output_bfd], + AC_DEFINE(HAVE_OUTPUT_BFD,1,[output_bfd element present]), [], + [ + #include + #include + ]) + AC_SUBST(HAVE_OUTPUT_BFD) + +# +# FIXME: Need to workaround mingw before this point -- CM +# + if test "$enable_statsysbfd" = "yes" && ! $CC -v 2>&1 | fgrep ming > /dev/null ; then + echo 'int main() {bfd_init();bfd_openr("/dev/null",0);return 0;}' >foo.c + MP=`$CC [ -Wl,-M ] -static -o foo foo.c -lbfd -liberty -ldl 2>&1 | grep -v : | tr '()' '\012\012' | $AWK '{print $NF}' | sort | uniq` + rm -f foo.c foo + if echo $MP | tr ' ' '\012' | grep libbfd.a >/dev/null; then + LIBBFD="`echo $MP | tr ' ' '\012' | grep libbfd.a | $AWK '{i=split($1,A,"/");for (j=1;j<=i;j++) if (j>1 && A[[j]]=="..") {j--;i-=2;for (k=j;k<=i;k++) A[[k]]=A[[k+2]];j--;}} END {for (j=1;j<=i;j++) printf("%s%s",A[[j]],j!=i ? "/" : "")}'`" + else + AC_MSG_ERROR([cannot locate external libbfd.a]) + fi + if echo $MP | tr ' ' '\012' | grep libiberty.a >/dev/null ; then + LIBIBERTY="`echo $MP | tr ' ' '\012' | grep libiberty.a | $AWK '{i=split($1,A,"/");for (j=1;j<=i;j++) if (j>1 && A[[j]]=="..") {j--;i-=2;for (k=j;k<=i;k++) A[[k]]=A[[k+2]];j--;}} END {for (j=1;j<=i;j++) printf("%s%s",A[[j]],j!=i ? "/" : "")}'`" + else + AC_MSG_ERROR([cannot locate external libiberty.a]) + fi + BUILD_BFD=copy_bfd + AC_CHECK_LIB(z,inflate, + [TLIBS="$TLIBS -lz"], + AC_MSG_ERROR([Need zlib for bfd linking]),[]) + AC_CHECK_LIB(dl,dlsym, + [TLIBS="$TLIBS -ldl"], + AC_MSG_ERROR([Need libdl for bfd linking]),[]) + AC_SUBST(BUILD_BFD) + AC_SUBST(LIBBFD) + AC_SUBST(LIBIBERTY) + + else + TLIBS="$TLIBS -lbfd -liberty -ldl" + fi +fi + +if test "$enable_locbfd" = "yes" ; then + + # check for gettext. It is part of glibc, but others + # need GNU gettext separately. +# AC_CHECK_HEADERS(libintl.h, true, +# AC_MSG_ERROR(libintl.h (gettext) not found)) +# AC_SEARCH_LIBS(dgettext, intl, true, AC_MSG_ERROR(gettext library not found)) + + echo "#" + echo "#" + echo "# -------------------------" + echo "# Subconfigure of LIBINTL" + echo "#" + echo "#" + cd binutils/intl && chmod +x configure && ./configure --disable-nls && cd ../.. +# MY_SUBDIRS="$MY_SUBDIRS binutils/libiberty " + echo "#" + echo "#" + echo "#" + echo "# Subconfigure of LIBINTL done" + echo "# ------------------------------" + echo "#" + echo "#" + echo "#" + echo "# -------------------------" + echo "# Subconfigure of LIBIBERTY" + echo "#" + echo "#" + cd binutils/libiberty && chmod +x configure && ./configure --disable-nls && cd ../.. +# MY_SUBDIRS="$MY_SUBDIRS binutils/libiberty " + echo "#" + echo "#" + echo "#" + echo "# Subconfigure of LIBIBERTY done" + echo "# ------------------------------" + echo "#" + echo "#" + echo "#" + echo "# -------------------" + echo "# Subconfigure of BFD" + echo "#" + echo "#" + cd binutils/bfd && chmod +x configure && ./configure --with-included-gettext --disable-nls && cd ../.. +# MY_SUBDIRS="$MY_SUBDIRS binutils/bfd " + echo "#" + echo "#" + echo "#" + echo "# Subconfigure of BFD done" + echo "# ------------------------" + echo "#" +# TLIBS="$TLIBS `pwd`/binutils/bfd/libbfd.a `pwd`/binutils/libiberty/libiberty.a" + AC_DEFINE(HAVE_LIBBFD,1,[use libbfd]) + BUILD_BFD="h/bfd.h h/bfdlink.h h/ansidecl.h h/symcat.h" + AC_SUBST(BUILD_BFD) +fi + + +if test "$enable_xdr" = "yes" ; then + AC_CHECK_FUNC(xdr_double,AC_DEFINE(HAVE_XDR,1,[have xdr extensions]), + AC_CHECK_LIB(tirpc,xdr_double,AC_DEFINE(HAVE_XDR,1,[have xdr extensions]) TLIBS="$TLIBS -ltirpc", + AC_CHECK_LIB(rpc,xdr_double,AC_DEFINE(HAVE_XDR,1,[have xdr extensions]) TLIBS="$TLIBS -lrpc", + AC_CHECK_LIB(oncrpc,xdr_double,AC_DEFINE(HAVE_XDR,1,[have xdr extensions]) TLIBS="$TLIBS -loncrpc")))) +fi + + +AC_MSG_CHECKING([__builtin_clzl]) +AC_RUN_IFELSE([AC_LANG_SOURCE([[ + #include + #include + int main() { + unsigned long u; + long j; + if (__builtin_clzl(0)!=sizeof(long)*8) + return -1; + for (u=1,j=sizeof(long)*8-1;j>=0;j--,u<<=1) + if (__builtin_clzl(u)!=j) + return -1; + return 0; + }]])],[AC_MSG_RESULT([yes]) + AC_DEFINE(HAVE_CLZL,[1],[clzl instruction])], + [AC_MSG_RESULT([no])]) + +AC_MSG_CHECKING([__builtin_ctzl]) +AC_RUN_IFELSE([AC_LANG_SOURCE([[ + #include + #include + int main() { + unsigned long u; + long j; + if (__builtin_ctzl(0)!=sizeof(long)*8) + return -1; + for (u=1,j=0;j + #include + #ifdef __CYGWIN__ + #define getpagesize() 4096 + #endif + ]],[[ + size_t i=getpagesize(),j; + FILE *fp=fopen("conftest1","w"); + for (j=0;i>>=1;j++); + j=j<$min_pagewidth ? $min_pagewidth : j; + fprintf(fp,"%u",j); + return 0; + ]])], + [PAGEWIDTH=`cat conftest1`], + [PAGEWIDTH=0]) +AC_MSG_RESULT($PAGEWIDTH) +AC_DEFINE_UNQUOTED(PAGEWIDTH,$PAGEWIDTH,[system pagewidth]) +AC_SUBST(PAGEWIDTH) + +AC_MSG_CHECKING([for required object alignment]) +AC_RUN_IFELSE([AC_LANG_PROGRAM([[ + #include + #define EXTER + #include "$MP_INCLUDE" + #include "./h/enum.h" + #define OBJ_ALIGN + #include "./h/type.h" + #include "./h/lu.h" + #include "./h/object.h" + ]],[[ + unsigned long i; + FILE *fp=fopen("conftest1","w"); + for (i=1;i && NOT_OBJECT_ALIGNED(i); i<<=1); + if (!i) return -1; + fprintf(fp,"%lu",i); + fclose(fp); + return 0; + ]])], + [obj_align=`cat conftest1` + AC_MSG_RESULT($obj_align) + AC_DEFINE_UNQUOTED(OBJ_ALIGNMENT,$obj_align,[needed object alignment in bytes])], + [AC_MSG_ERROR([Cannot find object alignent])]) + +AC_MSG_CHECKING([for C extension variable alignment]) +AC_RUN_IFELSE([AC_LANG_PROGRAM([[]],[[ + char *v __attribute__ ((aligned ($obj_align))); + return 0;]])],[obj_align="__attribute__ ((aligned ($obj_align)))"],[AC_MSG_ERROR([Need alignment attributes])]) +AC_MSG_RESULT($obj_align) +AC_DEFINE_UNQUOTED(OBJ_ALIGN,$obj_align,[can use C extension for object alignment]) + +AC_MSG_CHECKING([for C extension noreturn function attribute]) +AC_RUN_IFELSE([AC_LANG_PROGRAM([[]],[[ + extern int v() __attribute__ ((noreturn)); + return 0;]])],[no_return="__attribute__ ((noreturn))"],[no_return=]) +AC_MSG_RESULT($no_return) +AC_DEFINE_UNQUOTED(NO_RETURN,$no_return,[can use C extension for functions that do not return]) + +AC_MSG_CHECKING(sizeof struct contblock) + +# work around MSYS pwd result incompatibility +if test "$use" = "mingw" ; then +AC_TRY_RUN([#include + #define EXTER + #include "$MP_INCLUDE" + #include "h/enum.h" + #include "h/type.h" + #include "h/lu.h" + #include "h/object.h" + int main(int argc,char **argv,char **envp) { + FILE *f=fopen("conftest1","w"); + fprintf(f,"%u",sizeof(struct contblock)); + fclose(f); + return 0; + }],sizeof_contblock=`cat conftest1`, + echo Cannot find sizeof struct contblock;exit 1, + echo Cannot find sizeof struct contblock;exit 1) +else +AC_TRY_RUN([#include + #define EXTER + #include "$MP_INCLUDE" + #include "`pwd`/h/enum.h" + #include "`pwd`/h/type.h" + #include "`pwd`/h/lu.h" + #include "`pwd`/h/object.h" + int main(int argc,char **argv,char **envp) { + FILE *f=fopen("conftest1","w"); + fprintf(f,"%u",sizeof(struct contblock)); + fclose(f); + return 0; + }],sizeof_contblock=`cat conftest1`, + echo Cannot find sizeof struct contblock;exit 1, + echo Cannot find sizeof struct contblock;exit 1) +fi +AC_MSG_RESULT($sizeof_contblock) +AC_DEFINE_UNQUOTED(SIZEOF_CONTBLOCK,$sizeof_contblock,[sizeof linked list for contiguous pages]) + +AC_MSG_CHECKING([for sbrk]) +HAVE_SBRK="" +AC_TRY_RUN([#include + #include + int main() { + FILE *f; + if (!(f=fopen("conftest1","w"))) + return -1; + fprintf(f,"%u",sbrk(0)); + return 0; + }], + HAVE_SBRK=1 + AC_MSG_RESULT(yes), + AC_MSG_RESULT([no: WARNING you must be able to emulate sbrk: as on mingw or macosx]), + AC_MSG_RESULT([no: WARNING you must be able to emulate sbrk: as on mingw or macosx])) + +if test "$use" = "386-macosx" ; then + AC_MSG_RESULT(emulating sbrk for mac); + HAVE_SBRK=0 +fi + +if test "$HAVE_SBRK" = "1" ; then + + AC_MSG_CHECKING([for ADDR_NO_RANDOMIZE constant]) + AC_RUN_IFELSE([ + AC_LANG_PROGRAM([[ + #include + #include + ]],[[ + FILE *f; + if (!(f=fopen("conftest1","w"))) return -1; + fprintf(f,"%x",ADDR_NO_RANDOMIZE); + return 0; + ]])], + [ADDR_NO_RANDOMIZE=`cat conftest1` + AC_MSG_RESULT([yes $ADDR_NO_RANDOMIZE])], + [ADDR_NO_RANDOMIZE=0 + AC_MSG_RESULT([no assuming 0x40000]) + AC_DEFINE_UNQUOTED(ADDR_NO_RANDOMIZE,0x40000,[punt guess for no randomize value])]) + + AC_MSG_CHECKING([for ADDR_COMPAT_LAYOUT constant]) + AC_RUN_IFELSE([ + AC_LANG_PROGRAM([[ + #include + #include + ]],[[ + FILE *f; + if (!(f=fopen("conftest1","w"))) return -1; + fprintf(f,"%x",ADDR_COMPAT_LAYOUT); + return 0; + ]])], + [ADDR_COMPAT_LAYOUT=`cat conftest1` + AC_MSG_RESULT([yes $ADDR_COMPAT_LAYOUT])], + [ADDR_COMPAT_LAYOUT=0 + AC_MSG_RESULT([no])] + AC_DEFINE_UNQUOTED(ADDR_COMPAT_LAYOUT,0,[constant to reserve upper 3Gb for C stack])) + + AC_MSG_CHECKING([for ADDR_LIMIT_3GB constant]) + AC_RUN_IFELSE([ + AC_LANG_PROGRAM([[ + #include + #include + ]],[[ + FILE *f; + if (!(f=fopen("conftest1","w"))) return -1; + fprintf(f,"%x",ADDR_LIMIT_3GB); + return 0; + ]])], + [ADDR_LIMIT_3GB=`cat conftest1` + AC_MSG_RESULT([yes $ADDR_LIMIT_3GB])], + [ADDR_LIMIT_3GB=0 + AC_MSG_RESULT([no])] + AC_DEFINE_UNQUOTED(ADDR_LIMIT_3GB,0,[only 3Gb of address space])) + + AC_MSG_CHECKING([for personality(ADDR_NO_RANDOMIZE) support]) + AC_RUN_IFELSE([ + AC_LANG_SOURCE([[ + #include + #include + void gprof_cleanup() {}; + int main(int argc,char **argv,char **envp) { + #include "h/unrandomize.h" + return 0;}]])], + [AC_MSG_RESULT(yes) + AC_DEFINE(CAN_UNRANDOMIZE_SBRK,1,[can prevent sbrk from returning random values])], + [AC_MSG_RESULT(no)]) + + AC_MSG_CHECKING([that sbrk is (now) non-random]) + AC_TRY_RUN([#include + #include + void gprof_cleanup() {}; + int main(int argc,char * argv[],char * envp[]) { + FILE *f; + #ifdef CAN_UNRANDOMIZE_SBRK + #include "h/unrandomize.h" + #endif + if (!(f=fopen("conftest1","w"))) return -1; + fprintf(f,"%u",sbrk(0)); + return 0;}],SBRK=`cat conftest1`,SBRK=0,SBRK=0) + if test "$SBRK" = "0" ; then + AC_MSG_RESULT(cannot trap sbrk) + exit 1 + fi + AC_TRY_RUN([#include + #include + void gprof_cleanup() {}; + int main(int argc,char * argv[],char * envp[]) { + FILE *f; + #ifdef CAN_UNRANDOMIZE_SBRK + #include "h/unrandomize.h" + #endif + if (!(f=fopen("conftest1","w"))) return -1; + fprintf(f,"%u",sbrk(0)); + return 0;}],SBRK1=`cat conftest1`,SBRK1=0,SBRK1=0) + if test "$SBRK1" = "0" ; then + AC_MSG_RESULT(cannot trap sbrk) + exit 1 + fi + if test "$SBRK" = "$SBRK1" ; then + AC_MSG_RESULT(yes) + else + AC_MSG_RESULT(no) + echo "Cannot build with randomized sbrk. Your options:" + echo " - upgrade to a kernel/libc that knows about personality(ADDR_NO_RANDOMIZE)" + echo " - recompile your kernel with CONFIG_COMPAT_BRK (if it has that option)" + echo " - run sysctl kernel.randomize_va_space=0 before using gcl" + exit 1 + fi +fi + +dnl AC_MSG_CHECKING(DBEGIN) +dnl AC_RUN_IFELSE([AC_LANG_SOURCE([[ +dnl #include +dnl #include +dnl #include +dnl void gprof_cleanup() {}; + +dnl int main(int argc,char **argv,char **envp) { + +dnl void *b; +dnl FILE *fp; + +dnl #ifdef CAN_UNRANDOMIZE_SBRK +dnl #include "h/unrandomize.h" +dnl #endif + +dnl fp = fopen("conftest1","w"); + +dnl #ifdef _WIN32 +dnl fprintf ( fp,"0x%lx", 0x3000000 ); /* Windows custom allocation from this point up */ +dnl #else +dnl #if defined (__APPLE__) && defined (__MACH__) +dnl fprintf(fp,"0x0"); +dnl #else +dnl b = sbrk(0); +dnl fprintf(fp,"0x%lx",((unsigned long) b) & ~(unsigned long)((1< +dnl #include +dnl ]],[[ +dnl FILE *fp=fopen("conftest1","w"); +dnl fprintf(fp,"%u",262144*( SIZEOF_LONG >>2)/(1<<($PAGEWIDTH-12))); +dnl return 0;]])],[def_maxpage=`cat conftest1`],[def_maxpage=262144]) + +dnl AC_ARG_ENABLE(maxpage, +dnl [ --enable-maxpage=XXXX will compile in a page table of size XXX +dnl (eg '--enable-maxpage=64*1024' would produce +dnl 64K pages allowing 256 MB if pages are 4K each)], +dnl ,enable_maxpage=$def_maxpage) + + +AC_MSG_CHECKING(CSTACK_ADDRESS) +AC_RUN_IFELSE([AC_LANG_SOURCE([[ + #include + #include + void * + foo() { + int i; + return (void *)&i; + } + + void gprof_cleanup() {}; + int main(int argc,char **argv,char **envp) { + void *v ; + FILE *fp = fopen("conftest1","w"); + unsigned long i,j; + + #ifdef CAN_UNRANDOMIZE_SBRK + #include "h/unrandomize.h" + #endif + j=1; + j<<=$PAGEWIDTH; + j<<=16; + i=(unsigned long)&v; + if (foo()>i) i-=j; + j--; + i+=j; + i&=~j; + fprintf(fp,"0x%lx",i-1); + fclose(fp); + return 0; +}]])],[cstack_address=`cat conftest1`],[cstack_address=0]) +AC_DEFINE_UNQUOTED(CSTACK_ADDRESS,$cstack_address,[starting C stack address]) +AC_MSG_RESULT($cstack_address) + +AC_MSG_CHECKING([cstack bits]) +AC_RUN_IFELSE([AC_LANG_SOURCE([[ + #include + #include + void * + foo() { + int i; + return (void *)&i; + } + + void gprof_cleanup() {}; + int main(int argc,char **argv,char **envp) { + void *v ; + FILE *fp = fopen("conftest1","w"); + unsigned long i,j; + + #ifdef CAN_UNRANDOMIZE_SBRK + #include "h/unrandomize.h" + #endif + j=1; + j<<=$PAGEWIDTH; + j<<=16; + i=(unsigned long)&v; + if (foo()>i) i-=j; + j--; + i+=j; + i&=~j; + for (j=0;(i>>j)!=(i>>(sizeof(long)*8-1));j++); + fprintf(fp,"%d",j); + fclose(fp); + return 0; +}]])],[cstack_bits=`cat conftest1`],[cstack_bits=0]) +AC_DEFINE_UNQUOTED(CSTACK_BITS,$cstack_bits,[log starting C stack address]) +AC_MSG_RESULT($cstack_bits) + +AC_MSG_CHECKING(NEG_CSTACK_ADDRESS) +AC_RUN_IFELSE([AC_LANG_SOURCE([[ + #include + #include + void gprof_cleanup() {}; + int main(int argc,char **argv,char **envp) { + #ifdef CAN_UNRANDOMIZE_SBRK + #include "h/unrandomize.h" + #endif + return (long)$cstack_address<0 ? 0 : -1; +}]])],[AC_MSG_RESULT(yes) + neg_cstack_address=1 + AC_DEFINE(NEG_CSTACK_ADDRESS,1,[C stack address is negative])], + [AC_MSG_RESULT(no) + neg_cstack_address=0]) + + +AC_MSG_CHECKING([finding CSTACK_ALIGNMENT]) +AC_RUN_IFELSE([AC_LANG_SOURCE([[ + #include + #include + void gprof_cleanup() {}; + int main(int argc,char **argv,char **envp) { + void *b,*c; + FILE *fp = fopen("conftest1","w"); + long n; + #ifdef CAN_UNRANDOMIZE_SBRK + #include "h/unrandomize.h" + #endif + b=alloca(sizeof(b)); + c=alloca(sizeof(c)); + n=b>c ? b-c : c-b; + n=n>sizeof(c) ? n : 1; + fprintf(fp,"%ld",n); + fclose(fp); + return 0; +}]])],[cstack_alignment=`cat conftest1`],[cstack_alignment=0]) +AC_DEFINE_UNQUOTED(CSTACK_ALIGNMENT,$cstack_alignment,[C stack alignment]) +AC_MSG_RESULT($cstack_alignment) + +AC_MSG_CHECKING(CSTACK_DIRECTION) +AC_RUN_IFELSE([AC_LANG_SOURCE([[ + #include + #include + void * + foo(void) { + int i; + return (void *)&i; + } + + void gprof_cleanup() {}; + int main(int argc,char **argv,char **envp) { + char *b; + FILE *fp = fopen("conftest1","w"); + #ifdef CAN_UNRANDOMIZE_SBRK + #include "h/unrandomize.h" + #endif + fprintf(fp,"%d",((long) &b) > ((long) foo()) ? -1 : 1); + fclose(fp); + return 0; +}]])],[cstack_direction=`cat conftest1`],[cstack_direction=0]) +AC_DEFINE_UNQUOTED(CSTACK_DIRECTION,$cstack_direction,[whether C stack grows up or down]) +AC_MSG_RESULT($cstack_direction) + + +dnl AC_MSG_CHECKING(for shared library/C stack ceiling to heap) +dnl if test "$use" = "mingw" ; then +dnl heap_ceiling=2000000000 +dnl else +dnl if test "$use" = "solaris-i386" ; then +dnl heap_ceiling=0x0 +dnl else +dnl if test "$enable_static" = "yes" ; then +dnl heap_ceiling=0x0 +dnl else +dnl if ! test -x `which ldd` && ! test -f /proc/self/maps ; then +dnl heap_ceiling=0x0 +dnl else +dnl if test -f /proc/self/maps ; then +dnl heap_ceiling=0x`/bin/cat /proc/self/maps | grep "/lib.*/ld-" | cut -f1 -d- | head -1` +dnl else +dnl if test "`which ldd`" = "" ; then +dnl heap_ceiling=0x0 +dnl else +dnl #echo -e "#include \n int main() {printf(\"foo\");return 0;}" >foo.c +dnl #$CC foo.c -o foo +dnl AAWK=`which awk` +dnl # | grep -v ld-kfreebsd needed on some strange bsd amd64 boxes +dnl heap_ceiling=`ldd $AAWK | tail -n 1 | $AWK '{print $NF}' | tr -d '()'` +dnl fi +dnl fi +dnl AC_RUN_IFELSE([AC_LANG_PROGRAM([[ +dnl #include +dnl ]],[[ +dnl FILE *fp=fopen("conftest1","w"); +dnl unsigned long h=$heap_ceiling,d=$dbegin,c=$cstack_address; +dnl h=hd && cfoo.c +dnl else +dnl echo "int main() {return !($heap_ceiling && (unsigned long)$dbegin < (unsigned long)$cstack_address);}" >foo.c +dnl fi +dnl $CC foo.c -o foo +dnl if ./foo ; then + +if test "$use" != "386-gnu" ; then #hurd can push .data below C stack, but sbrk(0) remains above, foiling unexec + + AC_MSG_CHECKING([finding default linker script]) + touch unixport/gcl.script + echo "int main() {return 0;}" >foo.c + $CC -Wl,--verbose foo.c -o foo 2>&1 | \ + $AWK '/\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=/ {i=1-i;next} {if (i) print}' >gcl.script + rm -rf foo.c foo + + if test "`cat gcl.script | wc -l`" != "0" ; then + AC_MSG_RESULT(got it) + AC_MSG_NOTICE([trying to adjust text start]) + cp gcl.script gcl.script.def + + n=-1; + k=0; + lim=`$AWK 'END {printf("%d\n",m*8-2)}' m=$ac_cv_sizeof_long`; + max=0; + min=$lim; + while test $n -lt $lim ; do + j=`$AWK 'END {for (i=j=0;j<=n;j++) i=i ? i*2 : 1;printf("%x\n",3*i)}' n=$n gcl.script +# diff -u gcl.script.def gcl.script + echo "int main() {return 0;}" >foo.c + if ( $CC -Wl,-T gcl.script foo.c -o foo && ./foo ) >/dev/null 2>&1 ; then + if test $n -lt $min ; then min=$n; fi; + if test $n -gt $max; then max=$n; fi; + elif test $max -gt 0 ; then + break; + fi; + n=`$AWK 'END {print n+1}' n=$n gcl.script + AC_MSG_RESULT([done]) + rm -f gcl.script.def + LDFLAGS="$LDFLAGS -Wl,-T gcl.script " + cp gcl.script unixport + else + AC_MSG_RESULT([none found or not needed]) + rm -f gcl.script gcl.script.def + fi + rm -rf foo.c foo + else + AC_MSG_RESULT([not found]) + fi + +else + + AC_DEFINE_UNQUOTED(OBJNULL,NULL,[lowest address non-object]) + +fi + + dnl old_LDFLAGS="$LDFLAGS" + dnl LDFLAGS="$LDFLAGS $TLDFLAGS" + dnl AC_MSG_CHECKING([revised DBEGIN]) + dnl AC_RUN_IFELSE([AC_LANG_SOURCE([[ + dnl #include + dnl #include + dnl #include + + dnl int main(int argc,char **argv,char **envp) { + + dnl void *b; + dnl FILE *fp; + + dnl #ifdef CAN_UNRANDOMIZE_SBRK + dnl #include "h/unrandomize.h" + dnl #endif + dnl fp = fopen("conftest1","w"); + + dnl #ifdef _WIN32 + dnl fprintf ( fp,"0x%lx", 0x1a000000 ); /* Windows custom allocation from this point up */ + dnl #else + dnl #if defined (__APPLE__) && defined (__MACH__) + dnl fprintf(fp,"((unsigned long)get_dbegin())"); + dnl #else + dnl b = sbrk(0); + dnl fprintf(fp,"0x%lx",((unsigned long) b) & ~(unsigned long)0xffffff); + dnl #endif + dnl #endif + dnl fclose(fp); + dnl return 0;}]])],[dbegin=`cat conftest1`],[dbegin=0]) + dnl AC_MSG_RESULT($dbegin) + dnl LDFLAGS="$old_LDFLAGS" +dnl fi +dnl dnl AC_DEFINE_UNQUOTED(DBEGIN,$dbegin,[down-rounded beginning address of lisp data]) +dnl rm -rf foo* + +dnl AC_MSG_CHECKING(for maxpage revision) +dnl AC_RUN_IFELSE([AC_LANG_PROGRAM([[ +dnl #include +dnl ]],[[ +dnl char *b; +dnl unsigned long i,j; +dnl FILE *fp = fopen("conftest1","w"); +dnl j=((unsigned long)$enable_maxpage <<$PAGEWIDTH) + $dbegin; +dnl j=$heap_ceiling && j>$heap_ceiling ? $heap_ceiling : j; +dnl j-=$dbegin; +dnl /* for (i=1;i<<1 && i<=j;i<<=1); */ +dnl /* if (i>j) i>>=1; */ +dnl i=j; +dnl fprintf(fp,"%ld",i>>$PAGEWIDTH); +dnl fclose(fp); +dnl return 0; +dnl ]])],[tmp_maxpage=`cat conftest1`],[tmp_maxpage=0]) +dnl if test "$tmp_maxpage" != "$enable_maxpage" ; then +dnl enable_maxpage=$tmp_maxpage +dnl AC_MSG_RESULT($enable_maxpage) +dnl else +dnl AC_MSG_RESULT($enable_maxpage is OK) +dnl fi +dnl AC_DEFINE_UNQUOTED(MAXPAGE,$enable_maxpage,[maximum number of pages to be allocated]) + +dnl AC_MSG_CHECKING(for C stack size floor from heap) +dnl AC_RUN_IFELSE([AC_LANG_PROGRAM([[ +dnl #include +dnl ]],[[ +dnl char *b; +dnl FILE *fp = fopen("conftest1","w"); +dnl unsigned long j,k; + +dnl j=$cstack_address + $cstack_direction * $enable_cssize; +dnl k=($dbegin + ((unsigned long)$enable_maxpage << $PAGEWIDTH)); +dnl j=abs(j-$cstack_address)!=$enable_cssize || (j +dnl ]],[[ +dnl char *b; +dnl FILE *fp = fopen("conftest1","w"); +dnl unsigned long j,k; + +dnl j=$cstack_address + $cstack_direction * $enable_cssize; +dnl if ($cstack_direction>0) { +dnl k=$cstack_address + ((-(unsigned long)$cstack_address)>>1); +dnl j=j<$cstack_address || j > k ? k : j; +dnl j=$cstack_address < $dbegin && j > $dbegin ? $dbegin : j; +dnl } +dnl j-=$cstack_address; +dnl j*=$cstack_direction; +dnl fprintf(fp,"%lu",j); +dnl fclose(fp); +dnl return 0; +dnl ]])],[tmp_cssize=`cat conftest1`],[tmp_cssize=0]) +dnl if test "$tmp_cssize" != "$enable_cssize" ; then +dnl enable_cssize=$tmp_cssize; +dnl AC_MSG_RESULT($enable_cssize) +dnl else +dnl AC_MSG_RESULT($enable_cssize is OK) +dnl fi + +dnl AC_MSG_CHECKING(for C stack size limit from address wrap) +dnl AC_RUN_IFELSE([AC_LANG_PROGRAM([[ +dnl #include +dnl ]],[[ +dnl char *b; +dnl FILE *fp = fopen("conftest1","w"); +dnl unsigned long j,k; + +dnl j=-$cstack_address * $cstack_direction; +dnl j=j>$enable_cssize ? $enable_cssize : j; +dnl fprintf(fp,"%lu",j); +dnl fclose(fp); +dnl return 0; +dnl ]])],[tmp_cssize=`cat conftest1`],[tmp_cssize=0]) +dnl if test "$tmp_cssize" != "$enable_cssize" ; then +dnl enable_cssize=$tmp_cssize; +dnl AC_MSG_RESULT($enable_cssize) +dnl else +dnl AC_MSG_RESULT($enable_cssize is OK) +dnl fi +dnl AC_DEFINE_UNQUOTED(CSSIZE,$enable_cssize,[maximum C stack size]) + +dnl AC_MSG_CHECKING(for fast NULL_OR_ON_CSTACK macro) +dnl AC_RUN_IFELSE([AC_LANG_PROGRAM([[ +dnl #include +dnl ]],[[ +dnl return ((long)$dbegin>=0 && +dnl ((long)$dbegin+(long)($enable_maxpage<<$PAGEWIDTH)) >=0 && +dnl ((long)$cstack_address<0)) ? 0 : 1; +dnl ]])],[tmp_fnocm=yes],[tmp_fnocm=no]) +dnl if test "$tmp_fnocm" = "yes" ; then +dnl AC_MSG_RESULT(yes) +dnl AC_DEFINE(USE_FAST_NULL_OR_ON_CSTACK_MACRO,1,[whether one instruction heap address check can be used]) +dnl else +dnl AC_MSG_RESULT(no) +dnl fi + +mem_top=0 +mem_range=0 +AC_MSG_CHECKING(mem top) +AC_RUN_IFELSE([AC_LANG_PROGRAM([[ + #include + ]],[[ + void *v; + unsigned long i,j,k,l,m; + FILE *fp = fopen("conftest1","w"); + + for (i=2,k=1;i;k=i,i<<=1); + l=$cstack_address; + l=$cstack_direction==1 ? (l>=1,i|=j); + if (j<(k>>3)) i=0; + j=1; + j<<=$PAGEWIDTH; + j<<=4; + j--; + i+=j; + i&=~j; + fprintf(fp,"0x%lx",i); + fclose(fp); + return 0; +]])],[mem_top=`cat conftest1`],[mem_top="0x0"]) +AC_MSG_RESULT($mem_top) +if test "$mem_top" != "0x0" ; then + AC_MSG_CHECKING(finding upper mem half range) + AC_RUN_IFELSE([AC_LANG_PROGRAM([[ + #include + ]],[[ + unsigned long j; + FILE *fp = fopen("conftest1","w"); + + for (j=1;j && !(j& $mem_top);j<<=1); + fprintf(fp,"0x%lx",j>>1); + fclose(fp); + return 0; + ]])],[mem_range=`cat conftest1`],[mem_range="0x0"]) + AC_MSG_RESULT($mem_range) + if test "$mem_range" != "0x0" ; then + AC_DEFINE_UNQUOTED(MEM_TOP,$mem_top,[beginning address for immediate fixnum range]) + AC_DEFINE_UNQUOTED(MEM_RANGE,$mem_range,[size of immediate fixnum address space]) + fi +fi + +if test "$enable_immfix" = "yes" ; then + if test "$mem_top" != "0x0" ; then + if test "$mem_range" != "0x0" ; then + AC_DEFINE_UNQUOTED(IM_FIX_BASE,$mem_top,[beginning address for immediate fixnum range]) + AC_DEFINE_UNQUOTED(IM_FIX_LIM,$mem_range,[size of immediate fixnum address space]) + fi + fi +fi + + +dnl AC_MSG_CHECKING(for word order) +dnl AC_TRY_RUN([int main () { +dnl /* Are we little or big endian? Adapted from Harbison&Steele. */ +dnl union +dnl { +dnl double d; +dnl int l[sizeof(double)/sizeof(int)]; +dnl } u; +dnl u.d = 1.0; +dnl return u.l[sizeof(double)/sizeof(int)-1] ? 0 : 1; +dnl }],AC_MSG_RESULT(little) +dnl AC_DEFINE(LITTLE_END), +dnl AC_MSG_RESULT(big), +dnl AC_MSG_RESULT([WARNING: ASSUMING LITTLE ENDIAN FOR CROSS COMPILING !!!] +dnl AC_DEFINE(LITTLE_END))) +dnl AC_SUBST(LITTLE_END) + + +# On systems with execshield, brk is randomized. We need to catch +# this and restore the traditional behavior here + +dnl old_LDFLAGS="$LDFLAGS" +dnl LDFLAGS="$TLDFLAGS" +dnl AC_MSG_CHECKING("finding DBEGIN") +dnl AC_TRY_RUN([#include +dnl #include + +dnl void gprof_cleanup() {}; +dnl int +dnl main(int argc,char * argv[],char *envp[]) +dnl { +dnl char *b,*b1; +dnl FILE *fp; + +dnl #ifdef CAN_UNRANDOMIZE_SBRK +dnl #include "h/unrandomize.h" +dnl #endif +dnl b = (void *) malloc(1000); +dnl fp = fopen("conftest1","w"); + +dnl #ifdef _WIN32 +dnl fprintf(fp,"_dbegin"); +dnl #else +dnl #if defined (__APPLE__) && defined (__MACH__) +dnl fprintf(fp,"mach_mapstart"); +dnl #else +dnl b1=((unsigned long) b) & ~(unsigned long)0xffffff;b=(void *)b1<(void *)&b1 && (void *)b>(void *)&b ? ((unsigned long) b) & ~(unsigned long)((1< +dnl main() +dnl { +dnl char *b ; +dnl FILE *fp = fopen("conftest1","w"); +dnl fprintf(fp,"%ld",((long) &b)); +dnl fclose(fp); +dnl return 0; +dnl }],cstack_address=`cat conftest1`,cstack_address=0,cstack_address=0) +dnl AC_DEFINE_UNQUOTED(CSTACK_ADDRESS,$cstack_address \ +dnl ) +dnl AC_MSG_RESULT(got $cstack_address) + + + +AC_MSG_CHECKING([sizeof long long int]) +AC_RUN_IFELSE([AC_LANG_PROGRAM([[ + #include + ]],[[ + if (sizeof(long long int) == 2*sizeof(long)) return 0; + return 1; +]])],[AC_DEFINE(HAVE_LONG_LONG,1,[long long is available]) AC_MSG_RESULT(yes)], + [AC_MSG_RESULT(no)]) + +AC_SUBST(HAVE_LONG_LONG) + + +AC_CHECK_HEADERS(dirent.h, + AC_MSG_CHECKING([for d_type]) + AC_RUN_IFELSE([AC_LANG_PROGRAM([[ + #include + ]],[[ + struct dirent d; + return d.d_type=0; + ]])], + [AC_MSG_RESULT([yes]) AC_DEFINE(HAVE_D_TYPE,1,[have struct dirent d_type field])], + AC_MSG_RESULT([no]),AC_MSG_RESULT([no]))) + +# readline +AC_ARG_ENABLE(readline, + [--enable-readline enables command line completion via the readline library ],, + enable_readline="yes") + +# ansi lisp +AC_ARG_ENABLE(ansi,[--enable-ansi builds a large gcl aiming for ansi compliance, + --disable-ansi builds the smaller traditional CLtL1 image],,enable_ansi="no") + +if test "$enable_ansi" = "yes" ; then + SYSTEM=ansi_gcl + AC_DEFINE(ANSI_COMMON_LISP,1,[compile ansi compliant image]) + CLSTANDARD=ANSI +else + SYSTEM=gcl + CLSTANDARD=CLtL1 +fi + +FLISP="saved_$SYSTEM" +AC_SUBST(FLISP) +AC_SUBST(SYSTEM) +AC_SUBST(CLSTANDARD) + +# Maximum number of pages + + + +# Check if Posix compliant getcwd exists, if not we'll use getwd. +AC_CHECK_FUNCS(getcwd) +AC_CHECK_FUNCS(getwd) +AC_CHECK_FUNC(uname, , AC_DEFINE(NO_UNAME,1,[no uname call])) +AC_CHECK_FUNC(gettimeofday, , AC_DEFINE(NO_GETTOD)) + + +AC_CHECK_HEADERS(sys/ioctl.h) + +# OpenBSD has elf_abi.h instead of elf.h +AC_CHECK_HEADERS(elf.h elf_abi.h) + +AC_CHECK_HEADERS(sys/sockio.h) + + +#-------------------------------------------------------------------- +# The code below deals with several issues related to gettimeofday: +# 1. Some systems don't provide a gettimeofday function at all +# (set NO_GETTOD if this is the case). +# 2. SGI systems don't use the BSD form of the gettimeofday function, +# but they have a BSDgettimeofday function that can be used instead. +# 3. See if gettimeofday is declared in the header file. +# if not, set the GETTOD_NOT_DECLARED flag so that tclPort.h can +# declare it. +#-------------------------------------------------------------------- + +AC_CHECK_FUNC([BSDgettimeofday], + [AC_DEFINE(HAVE_BSDGETTIMEOFDAY,1,[have bsdgettimeofday])], + [AC_CHECK_FUNC([gettimeofday], , + [AC_DEFINE([NO_GETTOD],1,[no gettimeofday call])])]) + +AC_MSG_CHECKING([for gettimeofday declaration]) + +AC_EGREP_HEADER([gettimeofday], + [sys/time.h], + [AC_MSG_RESULT([present])], + [AC_MSG_RESULT([missing]) + AC_DEFINE(GETTOD_NOT_DECLARED,1,[No gettimeofday call -- fixme])]) + + +AC_CHECK_LIB(m,sin,LIBS="${LIBS} -lm",true) +AC_CHECK_LIB(mingwex,main,LIBS="${LIBS} -lmingwex",true) + +AC_MSG_CHECKING([for buggy maximum sscanf length]) +AC_RUN_IFELSE([ + AC_LANG_PROGRAM([[ + #include + ]],[[ + char *s= "2.7182818284590452353602874713526624977572470936999595749669676277240766303535475945713821785251664274274663919320030599218174135966290435729003342952605956307381323286279434907632338298807531952510190115738341879307021540891499348841675092447614606680822648001684774118537423454424371075390777449920695517027618386062613313845830007520449338265602976067371132007093287091274437470472306969772093101416928368190255151086574637721112523897844250569536967707854499699679468644549059879316368892300987931277361782154249992295763514822082698951936680331825288693984964651058209392398294887933203625094431173012381970684161404"; + int n, m; + double f; + char *endptr; + FILE *fp=fopen("conftest1","w"); + + n=sscanf(s,"%lf%n",&f,&m); + fprintf(fp,"%d",m); + fclose(fp); + return s[m]; + ]])], + [AC_MSG_RESULT([none])], + [buggy_maximum_sscanf_length=`cat conftest1` + AC_MSG_RESULT([$buggy_maximum_sscanf_length]) + AC_DEFINE_UNQUOTED(BUGGY_MAXIMUM_SSCANF_LENGTH,$buggy_maximum_sscanf_length,[sscanf terminates prematurely (Windows XP)])]) + + +EXTRA_LOBJS= +if test "$try_japi" = "yes" ; then + AC_CHECK_HEADERS(japi.h,[AC_DEFINE(HAVE_JAPI_H) + EXTRA_LOBJS="${EXTRA_LOBJS} gcl_japi.o" + LIBS="${LIBS} -ljapi -lwsock32"] ) +fi +dnl if test "$use" = "mingw" ; then +dnl if test "$try_xdr" = "yes" ; then +dnl AC_CHECK_HEADERS(rpc/rpc.h,[AC_DEFINE(HAVE_XDR) +dnl LIBS="${LIBS} -loncrpc"] ) +dnl fi +dnl else +dnl if test "$try_xdr" = "yes" ; then +dnl AC_CHECK_HEADERS(rpc/rpc.h,[AC_DEFINE(HAVE_XDR) +dnl LIBS="${LIBS} -lrpc"] ) +dnl fi +dnl fi + +# Should really find a way to check for prototypes, but this +# basically works for now. CM +# +AC_CHECK_HEADERS(math.h,AC_DEFINE(HAVE_MATH_H,1,[have math.h])) +AC_CHECK_HEADERS(complex.h,AC_DEFINE(HAVE_COMPLEX_H,1,[have complex.h])) + +# +# For DBL_MAX et. al. on (only) certain Linux arches, apparently CM +# +AC_CHECK_HEADERS(values.h,AC_DEFINE(HAVE_VALUES_H,1,[have values.h])) + +# +# Sparc solaris keeps this in float.h, rework either/or with values.h later +# +AC_CHECK_HEADERS(float.h,AC_DEFINE(HAVE_FLOAT_H,1,[have float.h])) + +# +# The second alternative is for solaris. This needs to be +# a more comprehensive later, i.e. checking that the fpclass +# test makes sense. CM +# +AC_MSG_CHECKING([for isnormal]) +AC_RUN_IFELSE([AC_LANG_PROGRAM([[ + #define _GNU_SOURCE + #include + ]],[[ + float f; + return isnormal(f) || !isnormal(f) ? 0 : 1; + ]])], + [AC_DEFINE(HAVE_ISNORMAL,1,[Have isnormal function]) AC_MSG_RESULT(yes)], + [AC_MSG_CHECKING([for fpclass in ieeefp.h]) + AC_RUN_IFELSE([AC_LANG_PROGRAM([[ + #include + ]],[[ + float f; + return fpclass(f)>=FP_NZERO || fpclass(f) + ]],[[ + float f; + return isfinite(f) || !isfinite(f) ? 0 : 1; + ]])],[AC_DEFINE(HAVE_ISFINITE,1,[Have isfinite function]) AC_MSG_RESULT(yes)], + [AC_MSG_CHECKING([for finite()]) + AC_RUN_IFELSE([AC_LANG_PROGRAM([[ + #include + #include + ]],[[ + float f; + return finite(f) || !finite(f) ? 0 : 1; + ]])],[AC_DEFINE(HAVE_FINITE,1,[Have finite function]) AC_MSG_RESULT(yes)], + [AC_MSG_ERROR(no)])]) + +dnl AC_MSG_CHECKING([for INFINITY]) +dnl AC_RUN_IFELSE([AC_LANG_PROGRAM([[ +dnl #define _GNU_SOURCE +dnl #include +dnl ]],[[ +dnl double d=INFINITY; +dnl return 0; +dnl ]])],[AC_MSG_RESULT(yes)], +dnl [AC_MSG_CHECKING([for builtin_inf()]) +dnl AC_RUN_IFELSE([AC_LANG_PROGRAM([[ +dnl #include +dnl #include +dnl ]],[[ +dnl double d=__builtin_inf(); +dnl return 0; +dnl ]])],[AC_DEFINE_UNQUOTED(INFINITY,__builtin_inf(),[Have builtin_inf]) AC_MSG_RESULT(yes)], +dnl [AC_MSG_ERROR(no)])]) + +dnl AC_MSG_CHECKING([for NAN]) +dnl AC_RUN_IFELSE([AC_LANG_PROGRAM([[ +dnl #define _GNU_SOURCE +dnl #include +dnl ]],[[ +dnl double d=NAN; +dnl return 0; +dnl ]])],[AC_MSG_RESULT(yes)], +dnl [AC_MSG_CHECKING([for builtin_nan()]) +dnl AC_RUN_IFELSE([AC_LANG_PROGRAM([[ +dnl #include +dnl #include +dnl ]],[[ +dnl double d=__builtin_nan("0x0"); +dnl return 0; +dnl ]])],[AC_DEFINE_UNQUOTED(NAN,__builtin_nan("0x0"),[Have builtin_nan]) AC_MSG_RESULT(yes)], +dnl [AC_MSG_ERROR(no)])]) + +#-------------------------------------------------------------------- +# Check for the existence of the -lsocket and -lnsl libraries. +# The order here is important, so that they end up in the right +# order in the command line generated by make. Here are some +# special considerations: +# 1. Use "connect" and "accept" to check for -lsocket, and +# "gethostbyname" to check for -lnsl. +# 2. Use each function name only once: can't redo a check because +# autoconf caches the results of the last check and won't redo it. +# 3. Use -lnsl and -lsocket only if they supply procedures that +# aren't already present in the normal libraries. This is because +# IRIX 5.2 has libraries, but they aren't needed and they're +# bogus: they goof up name resolution if used. +# 4. On some SVR4 systems, can't use -lsocket without -lnsl too. +# To get around this problem, check for both libraries together +# if -lsocket doesn't work by itself. +#-------------------------------------------------------------------- +AC_MSG_CHECKING([for sockets]) +tcl_checkBoth=0 +AC_CHECK_FUNC(connect, tcl_checkSocket=0, tcl_checkSocket=1) +if test "$tcl_checkSocket" = 1; then + AC_CHECK_LIB(socket, main, TLIBS="$TLIBS -lsocket", tcl_checkBoth=1) +fi + + +if test "$tcl_checkBoth" = 1; then + tk_oldLibs=$TLIBS + TLIBS="$TLIBS -lsocket -lnsl" + AC_CHECK_FUNC(accept, tcl_checkNsl=0, [TLIBS=$tk_oldLibs]) +fi +AC_CHECK_FUNC(gethostbyname, , AC_CHECK_LIB(nsl, main, [TLIBS="$TLIBS -lnsl"])) + +RL_OBJS="" +RL_LIB="" +if test "$enable_readline" = "yes" ; then + AC_CHECK_HEADERS(readline/readline.h, + AC_CHECK_LIB(readline,rl_initialize, + AC_DEFINE(HAVE_READLINE,1,[have readline library]) + TLIBS="$TLIBS -lreadline" #some machines don't link this, e.g. Slackware + RL_OBJS=gcl_readline.o +# Readline support now initialized automatically when compiled in, this lisp +# object no longer needed -- 20040102 CM +# RL_LIB=lsp/gcl_readline.o + )) + +# These tests discover differences between readline 4.1 and 4.3 + AC_CHECK_LIB(readline,rl_completion_matches, + AC_DEFINE(HAVE_DECL_RL_COMPLETION_MATCHES,1,[have readline completion matches]) + AC_DEFINE(HAVE_RL_COMPENTRY_FUNC_T,1,[have readline completion matches]),,) +fi + +AC_SUBST(RL_OBJS) +AC_SUBST(RL_LIB) + +AC_MSG_CHECKING(For network code for nsocket.c) +AC_TRY_LINK([ +#include +#include +#include + +#include +#include +#include + +/************* for the sockets ******************/ +#include /* struct sockaddr, SOCK_STREAM, ... */ +#ifndef NO_UNAME +# include /* uname system call. */ +#endif +#include /* struct in_addr, struct sockaddr_in */ +#include /* inet_ntoa() */ +#include /* gethostbyname() */ +],[ connect(0,(struct sockaddr *)0,0); + gethostbyname("jil"); + socket(AF_INET, SOCK_STREAM, 0); + ], +[AC_DEFINE(HAVE_NSOCKET,1,[can use nsocket library]) + AC_MSG_RESULT(yes)], +AC_MSG_RESULT(no)) + + +AC_MSG_CHECKING(check for listen using fcntl) +AC_TRY_COMPILE([#include +#include +], +[FILE *fp=fopen("configure.in","r"); + int orig; + orig = fcntl(fileno(fp), F_GETFL); + if (! (orig & O_NONBLOCK )) return 0; +], +[AC_DEFINE(LISTEN_USE_FCNTL,1,[can use fcntl for listen function]) + AC_MSG_RESULT(yes)], +AC_MSG_RESULT(no)) + + + + +AC_CHECK_FUNC(profil, ,[AC_DEFINE(NO_PROFILE,1,[no profil system call])]) +AC_SUBST(NO_PROFILE) +AC_CHECK_FUNC(setenv,[AC_DEFINE(HAVE_SETENV,1,[have setenv call])],no_setenv=1 ) +AC_SUBST(HAVE_SETENV) +if test "$no_setenv" = "1" ; then +AC_CHECK_FUNC(putenv,[AC_DEFINE(HAVE_PUTENV,1,[have putenv call])],) +AC_SUBST(HAVE_PUTENV) +fi + +AC_CHECK_FUNC(_cleanup, [AC_DEFINE(USE_CLEANUP,1,[have _cleanup function])],) +AC_SUBST(USE_CLEANUP) +gcl_ok=no + +dnl AC_HEADER_EGREP(LITTLE_ENDIAN, ctype.h, gcl_ok=yes, gcl_ok=noo) +dnl if test $gcl_ok = yes ; then +dnl AC_DEFINE(ENDIAN_ALREADY_DEFINED) +dnl fi + +dnl AC_SUBST(ENDIAN_ALREADY_DEFINED) + + + + +# if test "x$enable_machine" = "x" ; then +AC_MSG_CHECKING([FIONBIO vs. O_NONBLOCK for nonblocking I/O]) + +case $system in + OSF*) + AC_DEFINE(USE_FIONBIO,1,[use fionbio for non-blocking io]) + AC_MSG_RESULT(FIONBIO) + ;; + SunOS-4*) + AC_DEFINE(USE_FIONBIO,1,[use fionbio for non-blocking io]) + AC_MSG_RESULT(FIONBIO) + ;; + ULTRIX-4.*) + AC_DEFINE(USE_FIONBIO,1,[use fionbio for non-blocking io]) + AC_MSG_RESULT(FIONBIO) + ;; + *) + AC_MSG_RESULT(O_NONBLOCK) + ;; +esac + + +AC_MSG_CHECKING(check for SV_ONSTACK) +AC_TRY_COMPILE([#include +int joe=SV_ONSTACK; +], +[], +[AC_DEFINE(HAVE_SV_ONSTACK,1,[have sv_onstack]) + AC_SUBST(HAVE_SV_ONSTACK) + AC_MSG_RESULT(yes)], +AC_MSG_RESULT(no)) + +AC_MSG_CHECKING(check for SIGSYS) +AC_TRY_COMPILE([#include +int joe=SIGSYS; +], +[], +[AC_DEFINE(HAVE_SIGSYS,1,[have SIGSYS signal]) + AC_SUBST(HAVE_SIGSYS) + AC_MSG_RESULT(yes)], +AC_MSG_RESULT(no)) + + +AC_MSG_CHECKING(check for SIGEMT) +AC_TRY_COMPILE([#include +int joe=SIGEMT; +], +[], +[AC_DEFINE(HAVE_SIGEMT,1,[have SIGEMT signal]) + AC_SUBST(HAVE_SIGEMT) + AC_MSG_RESULT(yes)], +AC_MSG_RESULT(no)) + +AC_CHECK_FUNCS(sigaltstack) +AC_CHECK_FUNCS(feenableexcept) + +AC_CHECK_HEADERS(dis-asm.h, + MLIBS=$LIBS + AC_CHECK_LIB(opcodes,init_disassemble_info) + AC_CHECK_LIB(dl,dlopen,#opcodes changes too quickly to link directly + AC_CHECK_FUNCS(print_insn_i386,LIBS="$MLIBS -ldl"))) + +#if test $use = "386-linux" ; then + AC_CHECK_HEADERS(asm/sigcontext.h) + AC_CHECK_HEADERS(asm/signal.h) + AC_MSG_CHECKING([for sigcontext...]) + AC_TRY_COMPILE([#include + ], + [ + struct sigcontext foo; + ], + [ + sigcontext_works=1; + AC_DEFINE(SIGNAL_H_HAS_SIGCONTEXT,1,[have sigcontext in signal.h]) + AC_MSG_RESULT(sigcontext in signal.h) + ], + + [sigcontext_works=0; + AC_MSG_RESULT(sigcontext NOT in signal.h)] + ) + if test "$sigcontext_works" = 0 ; then + AC_MSG_CHECKING([for sigcontext...]) + AC_TRY_COMPILE([#include + #ifdef HAVE_ASM_SIGCONTEXT_H + #include + #endif + #ifdef HAVE_ASM_SIGNAL_H + #include + #endif + ], + [ + struct sigcontext foo; + ], + [ + AC_DEFINE(HAVE_SIGCONTEXT,1,[have sigcontext]) + AC_MSG_RESULT(sigcontext in asm files) + ], + [ + AC_MSG_RESULT(no sigcontext found) + ]) + + + fi +# echo 'foo() {}' > conftest1.c +# $CC -S conftest1.c +# use_underscore=0 +# if fgrep _foo conftest1.s ; then use_underscore=1 ; fi +# if test $use_underscore = 0 ; then +# MPI_FILE=mpi-386_no_under.o +# else +# MPI_FILE=mpi-386d.o +# fi +# AC_SUBST(MPI_FILE) +# GCC=$CC +# if test -x /usr/bin/i386-glibc20-linux-gcc ; then +# GCC=/usr/bin/i386-glibc20-linux-gcc +# fi +# AC_SUBST(GCC) + +#fi + +AC_PATH_PROG(EMACS,emacs) + + +# check for where the emacs site lisp directory is. +rm -f conftest.el +cat >> conftest.el <&1 | sed -e /Loading/d | sed -e /load/d |sed -e /Warning:/d` + else + EMACS_SITE_LISP="" + fi +fi +AC_MSG_RESULT($EMACS_SITE_LISP) +AC_SUBST(EMACS_SITE_LISP) + +# check for where the emacs site lisp default.el is +rm -f conftest.el +cat >> conftest.el <&1 | sed -e /Loading/d | sed -e /load/d |sed -e /Warning:/d` +else + EMACS_DEFAULT_EL="" +fi +if test -f "${EMACS_DEFAULT_EL}" ; then true;else + if test -d $EMACS_SITE_LISP ; then + EMACS_DEFAULT_EL=${EMACS_SITE_LISP}/default.el + fi +fi +AC_MSG_RESULT($EMACS_DEFAULT_EL) +AC_SUBST(EMACS_DEFAULT_EL) + + + +# check for where the emacs site lisp info/dir is +rm -f conftest.el +cat >> conftest.el <&1 | sed -e /Loading/d | sed -e /load/d |sed -e /Warning:/d` + fi +fi + +AC_MSG_RESULT($INFO_DIR) +AC_SUBST(INFO_DIR) + +if test "$enable_tcltk" = "yes" ; then + + AC_MSG_CHECKING([for tcl/tk]) + + if test -d "${TCL_CONFIG_PREFIX}" ; then true ; else + + AC_CHECK_PROG(TCLSH,tclsh,tclsh,${TCLSH}) + + if test "${TCLSH}" = "" ; then true ; else + + rm -f conftest.tcl + cat >> conftest.tcl <&1 $CC -v | fgrep "gcc version 2.96" > /dev/null +dnl then +dnl BROKEN_O4_OPT=1 +dnl AC_DEFINE(BROKEN_O4_OPT) +dnl AC_SUBST(BROKEN_O4_OPT) +dnl echo ODIR_DEBUG=-O >> makedefsafter +dnl echo >> makedefsafter +dnl AC_MSG_RESULT([yes .. turning off -O4]) +dnl else +dnl AC_MSG_RESULT([no]) +dnl fi + +LDFLAGS="`echo $LDFLAGS | sed 's,gcl.script,../unixport/gcl.script,g'`" +AC_SUBST(LDFLAGS) +LIBS="$X_PRE_LIBS $X_LIBS $X_EXTRA_LIBS $TLDFLAGS $LIBS $TLIBS" +AC_SUBST(LIBS) +FINAL_CFLAGS="$CFLAGS $CPPFLAGS $X_CFLAGS $TCFLAGS $PROCESSOR_FLAGS" +AC_SUBST(FINAL_CFLAGS) +# Work around bug with gcc on ppc -- CM +NIFLAGS="$CFLAGS $CPPFLAGS $TCFLAGS $TONIFLAGS $PROCESSOR_FLAGS -I\$(GCLDIR)/o" +AC_SUBST(NIFLAGS) +CFLAGS="$CFLAGS $CPPFLAGS $TCFLAGS $TO3FLAGS $PROCESSOR_FLAGS -I\$(GCLDIR)/o" +AC_SUBST(CFLAGS) +O3FLAGS=$TO3FLAGS +AC_SUBST(O3FLAGS) +O2FLAGS=$TO2FLAGS +AC_SUBST(O2FLAGS) + +AC_SUBST(PRELINK_CHECK) + +AC_SUBST(EXTRA_LOBJS) +AC_SUBST(LEADING_UNDERSCORE) +AC_SUBST(GNU_LD) +if test -f h/$use.defs ; then + + AC_SUBST(use) + AC_OUTPUT(makedefc windows/gcl.iss windows/sysdir.bat windows/install.lsp ) + echo makedefc + cat makedefc + + echo add-defs1 $use + CC=$CC ./add-defs1 $use + +else + echo "Unable to guess machine type" + echo use configure --enable-machine=XXX, for XXX such that h/XXX.defs exists, ie in h/*.defs +fi diff --git a/debian/README.Debian b/debian/README.Debian new file mode 100644 index 0000000..8174975 --- /dev/null +++ b/debian/README.Debian @@ -0,0 +1,28 @@ +The Debian package gcl +---------------------- + +GCL is one of the oldest free common lisp systems still in use. Several +production systems have used it for over a decade. The common lisp +standard in effect when GCL was first released is known as "Common Lisp, +the Language" (CLtL1) after a book by Steele of the same name providing +this specification. Subsequently, a much expanded standard was adopted by +the American National Standards Institute (ANSI), which is still +considered the definitive common lisp language specification to this day. + +Debian GCL now installs both the small 'traditional' lisp image +designed to conform to a pre-ANSI Lisp standard, and an experimental +ANSI image. Please note that ANSI support in GCL is still +preliminary. On an ansi-test suite written by a GCL developer, GCL +fails on a little under 3 percent of the tests. Details can be found +in /usr/share/doc/gcl/test_results.gz. + +To toggle the use of the ANSI image, set the environment variable +GCL_ANSI to any non-empty string. + +New in 2.6.2 +------------ + +Please see the RELEASE-2.6.2.html file for release note information, +regression testing, and sample benchmarks. + + -- Camm Maguire , Wed Dec 14 18:55:19 2005 diff --git a/debian/changelog b/debian/changelog new file mode 100644 index 0000000..9561eb9 --- /dev/null +++ b/debian/changelog @@ -0,0 +1,3231 @@ +gcl (2.6.10-31) unstable; urgency=medium + + * dpkg-buildflags trial + + -- Camm Maguire Tue, 22 Jul 2014 20:06:10 +0000 + +gcl (2.6.10-30) unstable; urgency=medium + + * fix offsets ppc + + -- Camm Maguire Tue, 22 Jul 2014 17:12:27 +0000 + +gcl (2.6.10-29) unstable; urgency=medium + + * fix unexec file offsets + + -- Camm Maguire Tue, 22 Jul 2014 15:36:45 +0000 + +gcl (2.6.10-28) unstable; urgency=high + + * enable prelink + + -- Camm Maguire Fri, 18 Jul 2014 19:24:38 +0000 + +gcl (2.6.10-27) unstable; urgency=high + + * protect closure calls from gc + + -- Camm Maguire Wed, 16 Jul 2014 16:15:33 +0000 + +gcl (2.6.10-26) unstable; urgency=high + + * Bug fix: "packages should not build-depend on binutils-dev", thanks to + Matthias Klose (Closes: #754840). Please note that gcl has long + depended on binutils-dev for good reason -- happily it is no longer + necessary + + -- Camm Maguire Tue, 15 Jul 2014 16:04:04 +0000 + +gcl (2.6.10-25) unstable; urgency=high + + * rebuild to get gcc fixes on i386 + + -- Camm Maguire Fri, 11 Jul 2014 03:14:45 +0000 + +gcl (2.6.10-24) unstable; urgency=high + + * try default gcc 4.9 + * access libopcodes without link dependency via dlopen + * Bug fix: "please switch to emacs24", thanks to Gabriele Giacone + (Closes: #754012). + + -- Camm Maguire Wed, 09 Jul 2014 17:34:21 +0000 + +gcl (2.6.10-23) unstable; urgency=high + + * rebuild latest binutils + + -- Camm Maguire Sat, 05 Jul 2014 23:19:27 +0000 + +gcl (2.6.10-22) unstable; urgency=high + + * gcc-4.8 on i386, 4.9 has bugs at present + + -- Camm Maguire Fri, 04 Jul 2014 01:36:06 +0000 + +gcl (2.6.10-21) unstable; urgency=high + + * 2.6.11pre test 20 + + -- Camm Maguire Mon, 30 Jun 2014 22:43:27 +0000 + +gcl (2.6.10-20) unstable; urgency=high + + * 2.6.11pre test 19 + + -- Camm Maguire Sun, 29 Jun 2014 17:59:59 +0000 + +gcl (2.6.10-19) unstable; urgency=high + + * 2.6.11pre test 18 + + -- Camm Maguire Sun, 29 Jun 2014 16:00:07 +0000 + +gcl (2.6.10-18) unstable; urgency=high + + * 2.6.11pre test 17 + + -- Camm Maguire Sat, 28 Jun 2014 16:57:54 +0000 + +gcl (2.6.10-17) unstable; urgency=high + + * 2.6.11pre test 16 + + -- Camm Maguire Thu, 26 Jun 2014 18:06:42 +0000 + +gcl (2.6.10-16) unstable; urgency=high + + * 2.6.11pre test 15 + + -- Camm Maguire Wed, 18 Jun 2014 17:37:36 +0000 + +gcl (2.6.10-15) unstable; urgency=high + + * 2.6.11pre test 14 + + -- Camm Maguire Tue, 17 Jun 2014 00:39:35 +0000 + +gcl (2.6.10-14) unstable; urgency=high + + * 2.6.11pre test 13 + + -- Camm Maguire Sat, 14 Jun 2014 13:43:57 +0000 + +gcl (2.6.10-13) unstable; urgency=high + + * 2.6.11pre test 12 + + -- Camm Maguire Tue, 20 May 2014 16:00:22 +0000 + +gcl (2.6.10-12) unstable; urgency=high + + * 2.6.11pre test 11 + + -- Camm Maguire Fri, 16 May 2014 17:41:33 +0000 + +gcl (2.6.10-11) unstable; urgency=high + + * 2.6.11pre test 10 + + -- Camm Maguire Fri, 16 May 2014 13:18:07 +0000 + +gcl (2.6.10-10) unstable; urgency=high + + * 2.6.11pre test 9 + + -- Camm Maguire Wed, 07 May 2014 17:10:30 +0000 + +gcl (2.6.10-9) unstable; urgency=high + + * 2.6.11pre test 8 + + -- Camm Maguire Fri, 25 Apr 2014 19:53:10 +0000 + +gcl (2.6.10-8) unstable; urgency=high + + * 2.6.11pre test 7 + + -- Camm Maguire Mon, 21 Apr 2014 14:09:37 +0000 + +gcl (2.6.10-7) unstable; urgency=high + + * 2.6.11pre test 6 + + -- Camm Maguire Sat, 19 Apr 2014 17:52:17 +0000 + +gcl (2.6.10-6) unstable; urgency=high + + * 2.6.11pre test 5 + + -- Camm Maguire Fri, 18 Apr 2014 15:06:09 +0000 + +gcl (2.6.10-5) unstable; urgency=high + + * 2.6.11pre test 4 + + -- Camm Maguire Tue, 15 Apr 2014 20:30:13 +0000 + +gcl (2.6.10-4) unstable; urgency=high + + * 2.6.11pre test 3 + * Bug fix: "debian/rules uses DEB_BUILD_* macros instead of DEB_HOST_* + macros", thanks to Matthias Klose (Closes: #743520). + + -- Camm Maguire Wed, 09 Apr 2014 13:15:32 +0000 + +gcl (2.6.10-3) unstable; urgency=high + + * 2.6.11pre test 2 + + -- Camm Maguire Thu, 03 Apr 2014 14:24:23 +0000 + +gcl (2.6.10-2) unstable; urgency=high + + * 2.6.11pre test 1 + * Bug fix: "FTBFS: gcl_readline.d:472:39: error: 'CPPFunction' + undeclared (first use in this function)", thanks to David Suárez + (Closes: #741819). + + -- Camm Maguire Mon, 24 Mar 2014 15:47:01 +0000 + +gcl (2.6.10-1) unstable; urgency=high + + * New upstream release + + -- Camm Maguire Wed, 13 Nov 2013 18:39:19 +0000 + +gcl (2.6.9-17) unstable; urgency=high + + * 2.6.10pre test 17 + + -- Camm Maguire Mon, 11 Nov 2013 19:41:45 +0000 + +gcl (2.6.9-16) unstable; urgency=high + + * 2.6.10pre test 16 + * Bug fix: "gcl 2.6.7+dfsga-20 needs 1 GB disk space on amd64", thanks + to Edi Meier (Closes: #714507). + * Bug fix: "[INTL:ja] New Japanese translation", thanks to victory + (Closes: #718925). + + -- Camm Maguire Sat, 09 Nov 2013 13:34:32 +0000 + +gcl (2.6.9-15) unstable; urgency=high + + * 2.6.10pre test 15 + + -- Camm Maguire Sat, 02 Nov 2013 22:21:16 +0000 + +gcl (2.6.9-14) unstable; urgency=high + + * 2.6.10pre test 14 + + -- Camm Maguire Wed, 23 Oct 2013 17:44:14 +0000 + +gcl (2.6.9-13) unstable; urgency=high + + * environment allocation unrandomize.h + + -- Camm Maguire Mon, 21 Oct 2013 00:20:16 +0000 + +gcl (2.6.9-12) unstable; urgency=high + + * 2.6.10pre test 13 + + -- Camm Maguire Fri, 18 Oct 2013 14:18:17 +0000 + +gcl (2.6.9-11) unstable; urgency=high + + * 2.6.10pre test 12, s390, mingw cleanup, make_bignum bug fix + + -- Camm Maguire Tue, 15 Oct 2013 23:32:09 +0000 + +gcl (2.6.9-10) unstable; urgency=high + + * fast-fixnums + + -- Camm Maguire Fri, 11 Oct 2013 15:05:58 +0000 + +gcl (2.6.9-9) unstable; urgency=high + + * 2.6.10pre test 10 and 11 + + -- Camm Maguire Wed, 02 Oct 2013 19:12:36 +0000 + +gcl (2.6.9-8) unstable; urgency=high + + * 2.6.10pre test 8 and 9 + + -- Camm Maguire Tue, 01 Oct 2013 21:00:19 +0000 + +gcl (2.6.9-7) unstable; urgency=high + + * 2.6.10pre test 6 and 7 + + -- Camm Maguire Mon, 30 Sep 2013 19:34:38 +0000 + +gcl (2.6.9-6) unstable; urgency=high + + * 2.6.10pre test 5 + + -- Camm Maguire Tue, 24 Sep 2013 17:03:24 +0000 + +gcl (2.6.9-5) unstable; urgency=high + + * 2.6.10pre test 4 + + -- Camm Maguire Mon, 23 Sep 2013 19:27:36 +0000 + +gcl (2.6.9-4) unstable; urgency=high + + * 2.6.10pre test 3 + + -- Camm Maguire Mon, 23 Sep 2013 16:30:09 +0000 + +gcl (2.6.9-3) unstable; urgency=high + + * 2.6.10pre test 2 + + -- Camm Maguire Sun, 22 Sep 2013 03:27:10 +0000 + +gcl (2.6.9-2) unstable; urgency=high + + * 2.6.10pre test + + -- Camm Maguire Sat, 21 Sep 2013 04:14:55 +0000 + +gcl (2.6.9-1) unstable; urgency=high + + * New upstream release + + -- Camm Maguire Wed, 28 Aug 2013 16:49:18 +0000 + +gcl (2.6.7+dfsga-40) unstable; urgency=high + + * fix allocate functions + + -- Camm Maguire Tue, 06 Aug 2013 22:36:37 +0000 + +gcl (2.6.7+dfsga-39) unstable; urgency=high + + * lower initial contiguous and relblock allocations, set *ihs-top* + properly on startup, protect memory->cfd.cfd_start initialization from + gc + + -- Camm Maguire Mon, 05 Aug 2013 17:38:22 +0000 + +gcl (2.6.7+dfsga-38) unstable; urgency=high + + * robustify near oom handling to fix axiom compile of EXPEXPAN on mips + + -- Camm Maguire Fri, 02 Aug 2013 16:25:16 +0000 + +gcl (2.6.7+dfsga-37) unstable; urgency=high + + * ppc64 gprof fix + + -- Camm Maguire Fri, 26 Jul 2013 23:40:14 +0000 + +gcl (2.6.7+dfsga-36) unstable; urgency=high + + * min_pagewidth=14 on mips + + -- Camm Maguire Fri, 26 Jul 2013 02:20:56 +0000 + +gcl (2.6.7+dfsga-35) unstable; urgency=high + + * latest gcc on all platforms, no gprof ppc64, -O1 ia64, -O0 alpha + + -- Camm Maguire Thu, 25 Jul 2013 14:42:48 +0000 + +gcl (2.6.7+dfsga-34) unstable; urgency=high + + * sgc link_array mark fix;rb_end across save fix;more stable gcc on older arches + + -- Camm Maguire Tue, 23 Jul 2013 17:11:23 +0000 + +gcl (2.6.7+dfsga-33) unstable; urgency=high + + * fix mark_link_array for marked sLAlink_arrayA->s.s_dbind + + -- Camm Maguire Mon, 22 Jul 2013 19:00:43 +0000 + +gcl (2.6.7+dfsga-32) unstable; urgency=high + + * protect mark_link_array in sgc + + -- Camm Maguire Sat, 20 Jul 2013 00:16:07 +0000 + +gcl (2.6.7+dfsga-31) unstable; urgency=high + + * properly clean link array on gc + + -- Camm Maguire Fri, 19 Jul 2013 20:34:34 +0000 + +gcl (2.6.7+dfsga-30) unstable; urgency=high + + * fix gcl.script compiler::link, darwin compile warnings + + -- Camm Maguire Mon, 15 Jul 2013 20:35:03 +0000 + +gcl (2.6.7+dfsga-29) unstable; urgency=high + + * fix compiler::link in presence of gcl.script + + -- Camm Maguire Mon, 15 Jul 2013 16:23:33 +0000 + +gcl (2.6.7+dfsga-28) unstable; urgency=high + + * install unixport/gcl.script + + -- Camm Maguire Sat, 13 Jul 2013 18:42:28 +0000 + +gcl (2.6.7+dfsga-27) unstable; urgency=high + + * workaround for ia64 and hurd brk issues + + -- Camm Maguire Fri, 12 Jul 2013 21:44:54 +0000 + +gcl (2.6.7+dfsga-26) unstable; urgency=high + + * -- command line support, map-shared in unexec + + -- Camm Maguire Fri, 12 Jul 2013 00:52:35 +0000 + +gcl (2.6.7+dfsga-25) unstable; urgency=high + + * alpha, mips, 68k + + -- Camm Maguire Wed, 10 Jul 2013 18:29:37 +0000 + +gcl (2.6.7+dfsga-24) unstable; urgency=high + + * sgc and reloc fixes + + -- Camm Maguire Mon, 08 Jul 2013 13:56:33 +0000 + +gcl (2.6.7+dfsga-23) unstable; urgency=high + + * fix for maxima on kfbsd and sparc + + -- Camm Maguire Wed, 03 Jul 2013 19:19:16 +0000 + +gcl (2.6.7+dfsga-22) unstable; urgency=high + + * fix stack definition issues on i386 + + -- Camm Maguire Tue, 02 Jul 2013 18:27:54 +0000 + +gcl (2.6.7+dfsga-21) unstable; urgency=high + + * near out of memory robustification + + -- Camm Maguire Tue, 02 Jul 2013 15:32:58 +0000 + +gcl (2.6.7+dfsga-20) unstable; urgency=high + + * fix 3GB workaround for gprof + + -- Camm Maguire Fri, 21 Jun 2013 11:09:01 -0400 + +gcl (2.6.7+dfsga-19) unstable; urgency=high + + * work around 3GB personality/alloca/malloc bug + + -- Camm Maguire Fri, 21 Jun 2013 02:46:49 +0000 + +gcl (2.6.7+dfsga-18) unstable; urgency=high + + * alpha NULL_OR_ON_C_STACK, attempt to get 32 immfix space with + ADDR_LIMIT_3GB|ADDR_COMPAT_LAYOUT personality, clean compile with no + immfix + + -- Camm Maguire Thu, 20 Jun 2013 20:24:29 +0000 + +gcl (2.6.7+dfsga-17) unstable; urgency=high + + * small optimizations, #= nil fix + + -- Camm Maguire Wed, 19 Jun 2013 16:23:27 +0000 + +gcl (2.6.7+dfsga-16) unstable; urgency=high + + * no linker script on hurd;fix OBJ_ALIGN + + -- Camm Maguire Thu, 13 Jun 2013 15:35:00 +0000 + +gcl (2.6.7+dfsga-15) unstable; urgency=high + + * ia64 fix + + -- Camm Maguire Thu, 13 Jun 2013 02:38:47 +0000 + +gcl (2.6.7+dfsga-14) unstable; urgency=high + + * eliminate maxpage/dbegin, restore windows and macosx builds + + -- Camm Maguire Wed, 12 Jun 2013 21:42:29 +0000 + +gcl (2.6.7+dfsga-13) unstable; urgency=low + + * ia64/hurd/s390 and SGC + + -- Camm Maguire Sun, 09 Jun 2013 00:23:51 +0000 + +gcl (2.6.7+dfsga-12) unstable; urgency=low + + * ia64/hurd/s390 + + -- Camm Maguire Sat, 08 Jun 2013 15:24:46 +0000 + +gcl (2.6.7+dfsga-11) unstable; urgency=high + + * 2.6.9 test + + -- Camm Maguire Fri, 07 Jun 2013 21:46:41 +0000 + +gcl (2.6.7+dfsga-10) unstable; urgency=high + + * output mips make bug text to stderr + + -- Camm Maguire Sat, 25 May 2013 12:24:35 +0000 + +gcl (2.6.7+dfsga-9) unstable; urgency=high + + * mips make bug workaround + + -- Camm Maguire Wed, 22 May 2013 14:23:43 +0000 + +gcl (2.6.7+dfsga-8) unstable; urgency=high + + * revert doubled default maxpage + * export *read-eval* + + -- Camm Maguire Tue, 21 May 2013 14:42:05 +0000 + +gcl (2.6.7+dfsga-7) unstable; urgency=high + + * export ansi symbols + + -- Camm Maguire Sat, 11 May 2013 21:36:56 +0000 + +gcl (2.6.7+dfsga-6) unstable; urgency=high + + * fast hash-equal in compiler + + -- Camm Maguire Sat, 11 May 2013 19:11:42 +0000 + +gcl (2.6.7+dfsga-5) unstable; urgency=high + + * Bug fix: "FTBFS: cp: cannot stat + 'debian/tmp/usr/share/info/gcl-si.info': No such file or + directory", thanks to Lucas Nussbaum (Closes: #707490). + + -- Camm Maguire Fri, 10 May 2013 18:09:14 +0000 + +gcl (2.6.7+dfsga-4) unstable; urgency=high + + * sgc-on fix with latest gcc + + -- Camm Maguire Tue, 23 Apr 2013 18:45:11 +0000 + +gcl (2.6.7+dfsga-3) unstable; urgency=high + + * hash depth bug fix + * new s390 reloc + + -- Camm Maguire Thu, 24 Jan 2013 19:46:30 +0000 + +gcl (2.6.7+dfsga-2) unstable; urgency=high + + * more arm relocs supported;check default timezone dynamically;follow + bash ~ semantics in user-homedir-pathname + + -- Camm Maguire Mon, 21 Jan 2013 18:41:06 +0000 + +gcl (2.6.7+dfsga-1) unstable; urgency=high + + * Acknowledge Non-maintainer upload. + (thanks David Prévot ) + * Remove unused and non DFSG-compliant gmp3/gmp.* from source. + (Closes: #695721) + * Show translated debconf templates, thanks to Denis Barbier for the + analysis and the proposed fixes. (Closes: #691946) + * trim excess digits from printed floats + + -- Camm Maguire Tue, 15 Jan 2013 20:46:25 +0000 + +gcl (2.6.7-108) unstable; urgency=high + + * Depend on emacs23 | emacsen to allow wheezy propagation + + -- Camm Maguire Mon, 08 Oct 2012 18:08:36 +0000 + +gcl (2.6.7-107) unstable; urgency=high + + * mode 644 on ucf newfile + + -- Camm Maguire Wed, 03 Oct 2012 20:38:43 +0000 + +gcl (2.6.7-106) unstable; urgency=high + + * Bug fix: "modifies conffiles (policy 10.7.3): /etc/default/gcl", + thanks to Andreas Beckmann (Closes: #688201). + + -- Camm Maguire Wed, 03 Oct 2012 16:52:10 +0000 + +gcl (2.6.7-105) unstable; urgency=high + + * restore #DEBHELPER# to postinst and postrm scripts + + -- Camm Maguire Mon, 01 Oct 2012 17:31:43 +0000 + +gcl (2.6.7-104) unstable; urgency=high + + * Bug fix: "modifies conffiles (policy 10.7.3): /etc/default/gcl", + thanks to Andreas Beckmann (Closes: #688201). + + -- Camm Maguire Mon, 01 Oct 2012 15:32:52 +0000 + +gcl (2.6.7-103) unstable; urgency=high + + * sfaslelf.c: FIX_HIDDEN_SYMBOLS + + -- Camm Maguire Wed, 22 Aug 2012 15:13:12 +0000 + +gcl (2.6.7-102) unstable; urgency=high + + * Fix hash key distribution bug, bitvector equal bug + * distinguish car position in equal-hash of lists + + -- Camm Maguire Mon, 20 Aug 2012 17:33:26 +0000 + +gcl (2.6.7-101) unstable; urgency=high + + * add alpha, ppc, ppc64, and ia64 to __builtin__clear_cache exception + list as per gcc maintainers + * lintian cleanups + + -- Camm Maguire Sat, 05 May 2012 23:18:56 +0000 + +gcl (2.6.7-100) unstable; urgency=high + + * nil case keylist support + * Bug fix: "[INTL:da] Danish translation of the debconf templates gcl", + thanks to Joe Dalton (Closes: #666528). + + -- Camm Maguire Fri, 20 Apr 2012 02:25:26 +0000 + +gcl (2.6.7-99) unstable; urgency=low + + * case default error checking + + -- Camm Maguire Fri, 23 Mar 2012 14:14:44 +0000 + +gcl (2.6.7-98) unstable; urgency=low + + * restore traditional make-sequence,make-array, and coerce, and + optimize replace, as 2.6.8 compiler is still too weak re: inlines + + -- Camm Maguire Fri, 20 Jan 2012 19:55:45 +0000 + +gcl (2.6.7-97) unstable; urgency=low + + * evade __builtin___clear_cache on hppa + * make-array;make-sequence;replace;coerce + + -- Camm Maguire Fri, 20 Jan 2012 05:13:22 +0000 + +gcl (2.6.7-96) unstable; urgency=low + + * better XDR detection; no __builtin_clear_cache on sh4 + + -- Camm Maguire Wed, 18 Jan 2012 01:32:43 +0000 + +gcl (2.6.7-95) unstable; urgency=low + + * clear_cache after mprotect + + -- Camm Maguire Tue, 17 Jan 2012 03:54:56 +0000 + +gcl (2.6.7-94) unstable; urgency=low + + * optimize unwind at O0 to workaround gcc bug; centralize on + __builtin__clear_cache when available;arm_thm_call reloc support + + -- Camm Maguire Mon, 16 Jan 2012 20:10:07 +0000 + +gcl (2.6.7-93) unstable; urgency=low + + * remove C_GC_OFFSET for sparc64 + * remove ncurses dependency for readline + * Bug fix: "FTBFS: dpkg-buildpackage: error: dpkg-source -b gcl-2.6.7 + gave error exit status 2", thanks to Didier Raboud (Closes: #643131). + * Bug fix: "drops readline support if rebuilt", thanks to Sven Joachim + (Closes: #646735). + * lower opts on sparc64 asof gcc 4.6.1 + + -- Camm Maguire Wed, 11 Jan 2012 21:04:23 +0000 + +gcl (2.6.7-92) unstable; urgency=low + + * remove gprof on arm as mcount calls are 24/22bit -- marginally + accessible + + -- Camm Maguire Sat, 07 Jan 2012 02:42:06 +0000 + +gcl (2.6.7-91) unstable; urgency=low + + * s390x reloc support + * lower C optimization on ia64, arm and mips for now + + -- Camm Maguire Thu, 05 Jan 2012 17:30:01 +0000 + +gcl (2.6.7-90) unstable; urgency=low + + * libtirpc check for newest glibc + * read_preserving_whitespace fix + * armhf reloc support + * s390x support + * try C_GC_OFFSET for sparc64 + + -- Camm Maguire Wed, 04 Jan 2012 19:51:13 +0000 + +gcl (2.6.7-89) unstable; urgency=low + + * support new mips relocs + * lower opt to work around gcc 4.6 bug on arm + + -- Camm Maguire Wed, 11 May 2011 20:06:04 +0000 + +gcl (2.6.7-88) unstable; urgency=low + + * Bug fix: "FTBFS: gcl_arraylib.c:4:42: error: 'VV' undeclared + (first use in this function)", thanks to Lucas Nussbaum (Closes: + #625032). + + -- Camm Maguire Mon, 09 May 2011 16:00:21 +0000 + +gcl (2.6.7-87) unstable; urgency=low + + * mips reloc fix;configure default dlopen fix;clean rules and makefiles + + -- Camm Maguire Fri, 05 Nov 2010 13:29:05 +0000 + +gcl (2.6.7-86) unstable; urgency=low + + * remove binutils subdir, configure and make changes + + -- Camm Maguire Thu, 04 Nov 2010 17:55:48 +0000 + +gcl (2.6.7-85) unstable; urgency=low + + * fix mips relocs for non-static clines + + -- Camm Maguire Tue, 02 Nov 2010 13:56:40 +0000 + +gcl (2.6.7-84) unstable; urgency=low + + * better mips relocs, fix link on mingw32 + + -- Camm Maguire Sat, 30 Oct 2010 00:07:39 +0000 + +gcl (2.6.7-83) unstable; urgency=low + + * fix alpha stubs; fix sparc64 typo; print armhf relocs + + -- Camm Maguire Thu, 28 Oct 2010 13:43:16 +0000 + +gcl (2.6.7-82) unstable; urgency=low + + * mips64 fixes + + -- Camm Maguire Tue, 26 Oct 2010 18:20:04 +0000 + +gcl (2.6.7-81) unstable; urgency=low + + * sparc64;mips64 + + -- Camm Maguire Tue, 26 Oct 2010 03:33:52 +0000 + +gcl (2.6.7-80) unstable; urgency=low + + * alpha stubs; sgc mips kernel bug test; mips GPREL32 reloc + + -- Camm Maguire Mon, 25 Oct 2010 19:52:51 +0000 + +gcl (2.6.7-79) unstable; urgency=low + + * mips ld_bind_now, disable sgc workaround mips SIGBUS bug + + -- Camm Maguire Wed, 20 Oct 2010 15:31:59 +0000 + +gcl (2.6.7-78) unstable; urgency=low + + * mips local got relocs + + -- Camm Maguire Tue, 12 Oct 2010 17:15:35 +0000 + +gcl (2.6.7-77) unstable; urgency=low + + * workaround gcc alpha bug + * fix alpha reloc + + -- Camm Maguire Fri, 01 Oct 2010 21:25:11 +0000 + +gcl (2.6.7-76) unstable; urgency=low + + * fix page_multiple usage for runtime pagesize variance and stable mipsel builds + * sparc64 support + + -- Camm Maguire Fri, 01 Oct 2010 19:18:47 +0000 + +gcl (2.6.7-75) unstable; urgency=low + + * fix alpha bug + + -- Camm Maguire Tue, 28 Sep 2010 20:23:21 +0000 + +gcl (2.6.7-74) unstable; urgency=low + + * fix alpha relocs for axiom + + -- Camm Maguire Tue, 28 Sep 2010 16:07:38 +0000 + +gcl (2.6.7-73) unstable; urgency=low + + * sparc reloc updates + * fast-link fix + + -- Camm Maguire Fri, 24 Sep 2010 19:23:16 +0000 + +gcl (2.6.7-72) unstable; urgency=low + + * remove unused symbols from gcl_cmpopt.lsp + * reloc updates + * clear gcc warning + * default tilde expansion to HOME env in absence of passwd + * configure typo fix + + -- Camm Maguire Wed, 22 Sep 2010 19:32:52 +0000 + +gcl (2.6.7-71) unstable; urgency=low + + * print sparc64 relocs + + -- Camm Maguire Sat, 28 Aug 2010 14:50:00 +0000 + +gcl (2.6.7-70) unstable; urgency=low + + * sparc64/m68k + + -- Camm Maguire Fri, 27 Aug 2010 16:54:11 +0000 + +gcl (2.6.7-69) unstable; urgency=low + + * Bug fix: "non-standard gcc/g++ used for build (gcc-4.3)", thanks to + Matthias Klose (Closes: #594280). + + -- Camm Maguire Thu, 26 Aug 2010 19:08:39 +0000 + +gcl (2.6.7-68) unstable; urgency=low + + * ppc/mips elf reloc fixes + + -- Camm Maguire Mon, 23 Aug 2010 20:54:30 +0000 + +gcl (2.6.7-67) unstable; urgency=low + + * Fix compiler::link ansi combo + + -- Camm Maguire Sat, 21 Aug 2010 02:05:37 +0000 + +gcl (2.6.7-66) unstable; urgency=low + + * ppc autobuild fix + * Bug fix: "FTBFS: sfasli.c:139: error: invalid initializer", thanks to + Lucas Nussbaum (Closes: #593037). + * Bug fix: "FTBFS on powerpc: Error: The function TK::GET-AUTOLOADS is + undefined.", thanks to Mehdi Dogguy (Closes: #593191). + + -- Camm Maguire Fri, 20 Aug 2010 01:25:09 +0000 + +gcl (2.6.7-65) unstable; urgency=low + + * autobuilder fixes + + -- Camm Maguire Sat, 14 Aug 2010 11:30:46 +0000 + +gcl (2.6.7-64) unstable; urgency=low + + * configure fix + + -- Camm Maguire Fri, 13 Aug 2010 23:26:07 +0000 + +gcl (2.6.7-63) unstable; urgency=low + + * macosx support, ppc, i386 and x86_64 -- sfaslmacho.c + * windows/wine support -- sfaslcoff.c + * better custreloc support obviating my_plt -- sfaslelf.c + * debian default custreloc build where supported, all but ia64 and hppa + * fix mingw/wine path issues + + -- Camm Maguire Fri, 13 Aug 2010 16:08:49 +0000 + +gcl (2.6.7-62) unstable; urgency=high + + * more stable sgc detection via h/tsgc.h + * fix plt.h bug on hppa + * sublis1-inline fix for acl2 + + -- Camm Maguire Mon, 26 Jul 2010 16:03:54 +0000 + +gcl (2.6.7-61) unstable; urgency=high + + * mac osx support + * fix undef sgc bug in cmpinclude.h + + -- Camm Maguire Tue, 20 Jul 2010 14:50:19 +0000 + +gcl (2.6.7-60) unstable; urgency=high + + * fix sh4 support + + -- Camm Maguire Thu, 29 Apr 2010 18:09:04 +0000 + +gcl (2.6.7-59) unstable; urgency=high + + * fix hurd support + + -- Camm Maguire Fri, 23 Apr 2010 17:12:54 +0000 + +gcl (2.6.7-58) unstable; urgency=high + + * hurd support + * sh4 support + + -- Camm Maguire Fri, 23 Apr 2010 05:09:29 +0000 + +gcl (2.6.7-57) unstable; urgency=high + + * static function pointer wrapper for gcl_gmp_allocfun, stabilizing gmp + on hppa/ia64 + + -- Camm Maguire Mon, 12 Apr 2010 22:28:41 +0000 + +gcl (2.6.7-56) unstable; urgency=high + + * __builtin___clear_cache on arm + * gcc-4.3 on alpha + + -- Camm Maguire Thu, 28 Jan 2010 00:32:16 +0000 + +gcl (2.6.7-55) unstable; urgency=low + + * SGC fix, debian override fix, xgcl update + * SGC fix for relocatable and contiguous gmp storage + * configure fix for arm and hppa + + -- Camm Maguire Tue, 26 Jan 2010 19:43:08 +0000 + +gcl (2.6.7-54) unstable; urgency=low + + * robustify user_match, unrandomize, read-char-no-hang for sockets + * SA_SIGINFO for 386-linux + * if cmpinclude.h is not available, use *cmpinclude-string* in compiler-pass2 + + -- Camm Maguire Wed, 20 Jan 2010 19:02:28 +0000 + +gcl (2.6.7-53) unstable; urgency=low + + * revert round ratio to nearest + + -- Camm Maguire Tue, 05 Jan 2010 03:06:59 +0000 + +gcl (2.6.7-52) unstable; urgency=low + + * SIGINFO for kfreebsd-386 + + -- Camm Maguire Mon, 04 Jan 2010 17:49:05 +0000 + +gcl (2.6.7-51) unstable; urgency=low + + * user_match exscapes once only + + -- Camm Maguire Sun, 03 Jan 2010 05:31:20 +0000 + +gcl (2.6.7-50) unstable; urgency=low + + * gcc 4.4 warning cleanups + + -- Camm Maguire Thu, 31 Dec 2009 20:43:39 +0000 + +gcl (2.6.7-49) unstable; urgency=low + + * Bug fix: "/bin/sh: line 6: /bin/gcl: Permission denied", thanks to + Nobuhiro Iwamatsu (Closes: #561554). + + -- Camm Maguire Wed, 30 Dec 2009 23:04:39 +0000 + +gcl (2.6.7-48) unstable; urgency=low + + * round to nearest in ratio to double + + -- Camm Maguire Wed, 16 Dec 2009 15:01:55 +0000 + +gcl (2.6.7-47) unstable; urgency=low + + * Bug fix: "configure: error: Need zlib for bfd linking", thanks to + Cyril Brulebois (Closes: #560761). + * Bug fix: "Disfunctional maintainer address", thanks to Joerg Jaspert + (Closes: #560752). + + -- Camm Maguire Mon, 14 Dec 2009 19:06:45 +0000 + +gcl (2.6.7-46) unstable; urgency=low + + * support newer binutils with output_bfd element + * Fix 64bit interrupt bug + * reader error fix + * Ensure plt entries are not blank + * plt table reading fix + * Bug fix: "FTBFS: current binutils static libs need -lz", thanks to + Daniel Schepler (Closes: #521929). + * Bug fix: "replacing libreadline5-dev build dependency with + libreadline-dev", thanks to Matthias Klose (Closes: #553761). + * Bug fix: "crash after ctrl-C", thanks to Miroslaw Kwasniak (Closes: + #519903). + * Bug fix: "FTBFS with binutils-gold", thanks to Peter Fritzsche + (Closes: #554418). -ldl added to bfd linker args + * Bug fix: "[INTL:es] Spanish debconf template translation for gcl", + thanks to Francisco Javier Cuadrado (Closes: #508728). + * Bug fix: "[INTL:it] Italian translation", thanks to Vincenzo + Campanella (Closes: #560364). + * gcc error/warning cleanups + * fix plt table awk + + -- Camm Maguire Fri, 11 Dec 2009 17:45:14 +0000 + +gcl (2.6.7-45) unstable; urgency=high + + * proper word order detection macro, fixes armel + + -- Camm Maguire Mon, 01 Sep 2008 13:48:16 +0000 + +gcl (2.6.7-44) unstable; urgency=high + + * backoff on arm opts + * more careful handling of GCL_GPROF_START + + -- Camm Maguire Sat, 23 Aug 2008 21:28:52 +0000 + +gcl (2.6.7-43) unstable; urgency=low + + * redo unrandomize.h to enable compilation under -O2 -- FIXME; Closes: 494153 + + -- Camm Maguire Wed, 20 Aug 2008 21:18:43 +0000 + +gcl (2.6.7-42) unstable; urgency=low + + * more div/rem symbols for alpha + + -- Camm Maguire Sun, 03 Aug 2008 11:18:51 +0000 + +gcl (2.6.7-41) unstable; urgency=low + + * more div/rem symbols for arm and hppa + + -- Camm Maguire Sat, 02 Aug 2008 00:36:07 +0000 + +gcl (2.6.7-40) unstable; urgency=low + + * default gcc with pic enabled on mips/mipsel + + -- Camm Maguire Fri, 01 Aug 2008 13:28:00 -0400 + +gcl (2.6.7-39) unstable; urgency=high + + * gcc 4.2 for mips/mipsel for now + * __divdi3 et. al. symbols for ia64 and arm + * clean some compiler warnings + + -- Camm Maguire Fri, 01 Aug 2008 12:53:07 -0400 + +gcl (2.6.7-38) unstable; urgency=low + + * No infinite unrandomization loops + + -- Camm Maguire Thu, 31 Jul 2008 15:18:37 -0400 + +gcl (2.6.7-37) unstable; urgency=low + + * Non-maintainer upload to fix pending l10n issues + * Debconf templates and debian/control reviewed by the debian-l10n- + english team as part of the Smith review project. Closes: #457025 + * [Debconf translation updates] + - Portuguese. Closes: #457576 + - Czech. Closes: #457677 + - French. Closes: #458120 + - Finnish. Closes: #458255 + - Galician. Closes: #458529 + - Vietnamese. Closes: #459008 + - Russian. Closes: #459308 + - Dutch. Closes: #459541 + - German. Closes: #459887 + * [Lintian] Correct FSF address in debian/copyright + * [Lintian] Remove extra whitespaces at the end of + debian/in.gcl-doc.doc-base.tk + * [Lintian] Correct section in doc-base documents from Apps/Programming + to Programming + * Accept NMU + * Bug fix: "[INTL:sv] po-debconf file for gcl", thanks to Martin Ågren + (Closes: #492241). + * Bug fix: "gcl: FTBFS [amd64]: cannot trap sbrk", thanks to Daniel + Schepler (Closes: #487435). Modified and applied personality handling + patch. + * Bug fix: "gcl: Builds broken package with gcc-4.3", thanks to Daniel + Schepler (Closes: #467474). Added sincos to plttest.c + + -- Camm Maguire Thu, 31 Jul 2008 15:18:15 -0400 + +gcl (2.6.7-36) unstable; urgency=low + + * statsysbfd in Debian, incoporating modules into libgcl.a for + compiler::link support + + -- Camm Maguire Fri, 30 Nov 2007 12:03:31 -0500 + +gcl (2.6.7-35) unstable; urgency=low + + * drop gcc-3.4 on arm, Closes: #440421 + * Depend on emacs22 | emacsen, Closes: #440190 + * debconf translations Closes: #410683, Closes: #419736, Closes: #423706, Closes: #441408 + + -- Camm Maguire Fri, 23 Nov 2007 10:25:23 -0500 + +gcl (2.6.7-34) unstable; urgency=low + + * add read-byte,read-sequence,write-byte,write-sequence support + * fix some float parsing inaccuracies + * support GNU_HASH sections, Closes: #426135 + * safety 2 for certain low level functions in gcl_listlib.lsp, CLoses: + #415266 + + -- Camm Maguire Wed, 4 Jul 2007 16:23:25 -0400 + +gcl (2.6.7-33) unstable; urgency=low + + * Fix leading underscore behavior of my_plt + * add sqrt to plttest.c + * disable-nls added to the binutils subconfigures to avoid msgfmt + dependency + * remove -lintl from powerpc-macosx.defs + * update to make-user-init from cvs head to support hol88, fix link on + mingw + * solaris-i386 support + * fix read-char-no-hang on mingw + * fast compile without wrap-literals + * sigaltstack support + * fix cerror + + -- Camm Maguire Wed, 16 May 2007 12:45:40 -0400 + +gcl (2.6.7-32) unstable; urgency=low + + * static function pointers for hppa + + -- Camm Maguire Sun, 29 Oct 2006 02:15:13 -0500 + +gcl (2.6.7-31) unstable; urgency=low + + * no C optimization on hppa, gcc 4.x on hppa + * update cs.po, Closes: #389211 + + -- Camm Maguire Fri, 27 Oct 2006 13:06:55 -0400 + +gcl (2.6.7-30) unstable; urgency=low + + * make sure *tmp-dir* is set + * makeinfo is optional + + -- Camm Maguire Wed, 25 Oct 2006 17:37:54 -0400 + +gcl (2.6.7-29) unstable; urgency=low + + * Fix build issues on hppa and m68k + + -- Camm Maguire Sat, 21 Oct 2006 15:10:41 -0400 + +gcl (2.6.7-28) unstable; urgency=low + + * si::gettimeofday function for HOL88 build;macosx fixes + + -- Camm Maguire Wed, 18 Oct 2006 13:21:26 -0400 + +gcl (2.6.7-27) unstable; urgency=low + + * unrestricted gcc for alpha + * more default stack space + + -- Camm Maguire Tue, 17 Oct 2006 16:33:43 -0400 + +gcl (2.6.7-26) unstable; urgency=low + + * Fix large float read bug in c1constant-value + + -- Camm Maguire Mon, 16 Oct 2006 12:41:03 -0400 + +gcl (2.6.7-25) unstable; urgency=low + + * build-dep on gcc3.4 where appropriate + * Newer standards + + -- Camm Maguire Thu, 12 Oct 2006 09:37:08 -0400 + +gcl (2.6.7-24) unstable; urgency=low + + * build-dep on gcc3.4 where appropriate + * Newer standards + + -- Camm Maguire Thu, 12 Oct 2006 02:22:04 -0400 + +gcl (2.6.7-23) unstable; urgency=low + + * backoff to gcc-3.4 on alpha,arm,hppa, and m68k + + -- Camm Maguire Wed, 11 Oct 2006 10:16:59 -0400 + +gcl (2.6.7-22) unstable; urgency=low + + * HAVE_SYS_SOCKIO_H for solaris + * autolocbfd for solaris + * no -Wall when no gcc + * no -fomit-frame-pointer on m68k + * no profiling on mips + * $(AWK) instead of awk + * si::stat function + * fix 'the boolean type coersion error + * no varargs on cygwin + * while eval macro + * gensym counter fixes + * xgcl updates + + + -- Camm Maguire Fri, 15 Sep 2006 13:48:28 -0400 + +gcl (2.6.7-21) unstable; urgency=low + + * Fix socket write error + + -- Camm Maguire Wed, 6 Sep 2006 09:59:50 -0400 + +gcl (2.6.7-20) unstable; urgency=low + + * fix ia64 build + + -- Camm Maguire Thu, 31 Aug 2006 15:14:18 -0400 + +gcl (2.6.7-19) unstable; urgency=low + + * xgcl upgrade + * parse_number from cvs head with *read-base* fixes + * fix object_to_string + * install xgcl-2/sysdef.lisp + * fix info dir and emacs site lisp dir installation + * New xgcl readme + * Remove bashism from debian/rules, Closes: #376806, Closes: #385176. + * Fix dwdoc doc-base error, Closes: #385126 + + -- Camm Maguire Wed, 30 Aug 2006 12:13:46 -0400 + +gcl (2.6.7-18) unstable; urgency=low + + * remove emacs build dependency + * synch xgcl-2 with Novak edits + * fix build errors + * Remove power of two limit to MAXPAGE;fix X lib paths + * configure cleanup + * delete-file works on directories;build xgcl the old way;latest xgcl + from Gordon Novak + + -- Camm Maguire Wed, 23 Aug 2006 14:19:51 -0400 + +gcl (2.6.7-17) unstable; urgency=low + + * Bug fix: "gcl: [INTL:sv] Swedish debconf templates translation", + thanks to Daniel Nylander (Closes: #343695). + * Bug fix: "gcl: French debconf templates translation update", thanks to + Sylvain Archenault (Closes: #344629). + * clean xgcl-2/gmon.out + * cleanup latest gcc type-punning warnings + * defentry C proclamations and xgcl cleanup + + -- Camm Maguire Mon, 26 Jun 2006 16:45:09 +0000 + +gcl (2.6.7-16) unstable; urgency=high + + * Add missing build dependencies, omit html generation to avoid non-free + dependencies, CLoses: #372574. + + -- Camm Maguire Mon, 19 Jun 2006 14:05:59 +0000 + +gcl (2.6.7-15) unstable; urgency=low + + * Use internal gettext for bfd + * Restore xgcl2 + * Set compiler::*tmp-dir* at runtime + * report tmp-dir setting with system-banner to enable clean -eval - + batch operation; fix listen on socket streams; use (abs (getpid)) in + tmp names for Windows + * fix configure unbalanced quotes + * support for bignums in nth et.al. + * Fix branch cut of atanh + * Fix typep on simple-arrays + * prevent nested free errors + * revert atanh branch cut change + * Fix function documentation wrapping by compile + * cond evalmacro from cvs head + * Fix fixnum declarations in new smallnthcdr/bignthcdr + * fix simple-array typep + * updates for lsp/sys-proclaim + * xgcl integration + + -- Camm Maguire Fri, 9 Jun 2006 17:52:22 +0000 + +gcl (2.6.7-14) unstable; urgency=low + + * Add mount declaration to plt.c + + -- Camm Maguire Sun, 18 Dec 2005 12:56:51 +0000 + +gcl (2.6.7-13) unstable; urgency=low + + * Add feof to plttest.c for macosx + * plt related fixes for macosx + * fix configure + * Cleanup LEADING_UNDERSCORE case in plt.c et.al for macosx et.al. + * pass devices if present in compiler::get-temp-dir, fix disassemble + for new gazonk name pattern + + -- Camm Maguire Sat, 17 Dec 2005 15:22:40 +0000 + +gcl (2.6.7-12) unstable; urgency=low + + * Fix read-char-no-hang + * Strip emacs warnings when finding site-lisp directory + * mach-o update for latest binutils + * Latext bfd mach-o support from Aurelien + * revert to locbfd default on ppc-macosx + * More ppc macosx fixes from Aurelien + * revert a few macosx changes + * default to void * prototype on my_sbrk for latest macosx pending + Aureliens #ifdef + * Fix plt.h parsing on macosx + * Fix leading_underscore detection on mac + * macosx name mangling fixes + * multi-process safe gazonk names in compiler::*tmp-dir* + * Add underscore-mangled setjmp calls to plttest.c for macosx + * Fix POTFILES.in, Closes: #336207. + * Update templates, Closes: #324636 + * New French and Swedish translations, Closes: #333654, Closes: #336757. + + -- Camm Maguire Wed, 14 Dec 2005 18:52:49 +0000 + +gcl (2.6.7-11) unstable; urgency=low + + * Remove gcc-3.3 for arm in debian/rules + * make default maxpage depend on SIZEOF_LONG and PAGEWIDTH in a sane + fashion + + -- Camm Maguire Thu, 20 Oct 2005 00:08:37 +0000 + +gcl (2.6.7-10) unstable; urgency=low + + * Fix long-call gcc configure bug for ppc, add fdollars in + identifiers on arm + * remove gcc restrictions on arm + * revert 64bit coersion (gmp_big.c, maybe_replace_big) and replace with + code in siLnani (main.c) to get addresses from bignums. 2.7.0 will + have 64bit fixnums on 64bit machines, but this should not be + backported to 2.6.x + + -- Camm Maguire Wed, 12 Oct 2005 23:11:12 +0000 + +gcl (2.6.7-9) unstable; urgency=low + + * 64bit fixnum fasd data format fix from cvs head + + -- Camm Maguire Wed, 5 Oct 2005 18:49:50 +0000 + +gcl (2.6.7-8) unstable; urgency=low + + * Fix 64bit fixnum coersion bug using code from cvs HEAD + + -- Camm Maguire Fri, 30 Sep 2005 22:14:38 +0000 + +gcl (2.6.7-7) unstable; urgency=high + + * Scan .o file for init name when using dlopen + * Set init name using .o file instead of source file by default + * wrap-literals function from cvs head to allow optimizations using + compile or compile-file + * ADDR_NO_RANDOMIZE fix + + -- Camm Maguire Thu, 29 Sep 2005 17:50:56 +0000 + +gcl (2.6.7-6) unstable; urgency=high + + * Build bfd snapshot locally, Closes: #318681 + + -- Camm Maguire Tue, 20 Sep 2005 17:53:17 +0000 + +gcl (2.6.7-5) unstable; urgency=high + + * gcc-3.3 for arm + + -- Camm Maguire Thu, 15 Sep 2005 20:33:00 +0000 + +gcl (2.6.7-4) unstable; urgency=high + + * gcc 3.4 on arm to work around reserved '$' identifiers. + * gcl: French translation update + * French translation added, Closes: #325214 + * Czech translation added, Closes: #325869 + + -- Camm Maguire Thu, 15 Sep 2005 13:45:11 +0000 + +gcl (2.6.7-3) unstable; urgency=low + + * static wraper for compiled_regexp for ia64 + + -- Camm Maguire Sat, 10 Sep 2005 11:26:37 +0000 + +gcl (2.6.7-2) unstable; urgency=high + + * rebuild against libgmp3c2, Closes: #323765 + * 2.6.7 fixes all gcc 4.0 issues. Closes: #323979 + + -- Camm Maguire Wed, 24 Aug 2005 00:44:48 +0000 + +gcl (2.6.7-1) unstable; urgency=high + + * Fix (listen) with readline on + * fix control-d with readline + * libreadline5 support for Debian + * Support for pre-compiled regexps and new texinfo format + * Reenable run-process + * Push function 'accept into lisp, use select for 'listen on socket + streams + * New Upstream release version + * Native-reloc feature + * Add daemon capabilities to server sockets, document socket and + accept + * Some gcl-tk fixes + * Update wrapt-literals strategy to be consistent with CVS head -- + wrap evreything but symbols and integers, don't wrap when keeping + the gazonk files for linking in different images, this is really a + compile-file operation + * gcltk demo cleanups + * Probe-file, open_stream, and the like fail on directories + * Resolve symlinks in truename + * Place prototypes for defcfun in header files + * Support for unique init names for compiler::link and the like + * libreadline5 for Debian + * remove _o from init-names + * gcc-4.0 fixups + * Bug fix: "gcl: depends on binutils-dev <<= 2.1.5-999), so + uninstallable in unstable", thanks to Steve Langasek (Closes: + #318681). Rebuild with new release to autocompute this dep + * Bug fix: "gcl: Please switch to po-debconf", thanks to Lucas Wall + (Closes: #295930). Apply po-debconf patch + * Newer standards + + -- Camm Maguire Thu, 11 Aug 2005 15:00:26 +0000 + +gcl (2.6.6-1) unstable; urgency=high + + * New upstream release + * Allow .data section to be first in executable, as on solaris. Also + allow for new bfd section size semantics + * Don't try to write map file when not using GNU ld. Also allow + compile-file to process pathnames with whitespace on Windows + * Fix corner case fixnum arithmetic on 64bit machines + * Rework gmp_wrappers semantics for older gcc + * Explicitly mprotect loaded code pages PROT_EXEC on x86 Linux, as FC3 + now requires it. + * lisp-implementation-version is GCL + * Reader extension patch allowing for foo::(bar foobar) semantics + * a shell script variable fix in "unixport/makefile" for MSYS + * __MINGW32__ malloc initialisation fix in "o/alloc.c" + * Windows file/directory fixes in "o/unixfsys.c" + * MinGW32 -march in configure - removes deprecation warnings + * MinGW32 directory fix - "o/mingfile.c". + * Allow for sysconf to determine clock granularity at compile time to + fix time errors on the Itanium + * Disable SGC on macosx until the sgc/save problem can be fixed. + * Fix fixnum print bug on 64bit + * Fix nil types in room report + * 64bit fixes to fixnum_add and fixnum_sub + * Fix Mac SGC/save bug, at least in part + + -- Camm Maguire Sun, 16 Jan 2005 02:28:50 +0000 + +gcl (2.6.5-1) unstable; urgency=high + + * New gmp_wrappers.{c,h} files that prevent all GBC within gmp, + obviating the need for gmp patches and a local gmp configure. FIXME + -- extend to all gmp functions in a systematic way, and write header + information for future use in the compiler, making sure that plt.c + carries the needed gmp symbols at this point + * Build support for gmp_wrappers + * Support for gmp_wrappers in alloc_relblock/alloc_contblock;Support + for GCL_GPROF_START define in gprof functions + * dynsysgmp on by default; configure backs off to local gmp configure + and build automatically if needed either because gmp not present or + patched symbols are needed; autodetect and set the _start symbol + when using gprof + * Fix (setf (get ...) ...) return bug when interpreted + * Fix overwrite end of sgc_type_map bug + * Versioned depends on binutils-dev manually installed by Debian build + process + * New upstream release + * Proper binutils dependency for Debian + * head -1l -> head -n 1 for freebsd + * Cleanup gmp_wrapper code, check for in-place calls as write in one + step is not guaranteed in gmp according to its developers + * Rebuild against binutils 2.15, Closes: #266253, Closes: #263983 + + -- Camm Maguire Tue, 17 Aug 2004 18:22:27 +0000 + +gcl (2.6.4-1) unstable; urgency=high + + * New upstream release + * Make disassemble work when original system directory is gone + * New debian/support files for debconf image default selection support + * More descriptive compiled C function names for use in gprof when + profiling is compiled in + * Compiler fix for proclaimed vararg functions + * Allow sharp numbers to be bignums + * lintian fix in string-match + * Prototype for alloca for lint + * Improve gprof support + * Improve sgc page allocation which optimize-maximum-pages is in + effect and the hole is overrun + * Build a profiling set of images as well for Debian, toggle between + all four by default via debconf + * reset-sys-paths lisp function for moving image installation + directories, show profiling support in banner if present + * Fix typo in sys docs + * reset sys paths on installation + + -- Camm Maguire Thu, 5 Aug 2004 22:48:56 +0000 + +gcl (2.6.3-1) unstable; urgency=high + + * Correctly parse gcc version strings in gmp3 subconfigure on arm + * Fix variable capture error in dotimes macro + * Better sed separator for LI-CC in unixport/makefile + * Fix segfault in string-match + * vs_top=sup -> (reset-top) where possible in compiler. FIXME: a few + items of a different form which need to set *sup-used* too. + * Correct room report to show proper percentages when sgc is on + * Read in RELOC environment variable if set as default in debian/rules + * Remove local bfd libraries from libs variables as their objects are + incorporated into libgcl and as the source directory may not be + available at runtime + * Remove pcl/pcl_gazonk*lsp build-generated files from source + + -- Camm Maguire Thu, 15 Jul 2004 14:26:44 -0400 + +gcl (2.6.2-3) unstable; urgency=low + + * Fix value stack leak in rare compiled call sequence + + -- Camm Maguire Tue, 13 Jul 2004 10:17:02 -0400 + +gcl (2.6.2-2) unstable; urgency=low + + * New upstream point release + + -- Camm Maguire Tue, 13 Jul 2004 10:08:53 -0400 + +gcl (2.6.2-1) unstable; urgency=low + + * gcc-3.4 support + * Proper isnormal default courtesy of Magnus Henoch + * gclclean makefile target and other small makefile changes + * Proper check for C stack array body address in gbc.c and sgbc.c + * New upstream release + * acconfig.h update for isnormal default + * Fix bug in setting elements (si::aset) of 0 rank arrays uncovered by + the random tester + * No -fomit-frame-pointer on mingw + * Backport minimal ansi-test patches from HEAD to enable running of + the random tester + * installed tcl/tk patch for mingw + * Fix banner license detection code in lsp/gcl_mislib.lsp as + 8features* entries are now keywords + * o/makefile changes to work around trailing slash -I arguments gcc + bug on mingw + * Patch to mingwin.c:fix_filename to close long standing 'maxima + ignore-errors filename corruption' bug on mingw + * Check for too large rank supplied to make-array1 + * Fix potential stack overwrite bug in quick_call_sfun/eval.c + * Add -mprferred-stack-boundary=8 on amd64, as constant integers used + in a call must be retrievable with va_arg(,fixnum) + * Revert preferred-stack-boundary option on amd64 as it does not play + well with external libraries, also eliminate -m64 to allow for user + settings. Cast fixnum constant C arguments in gcl_cmploc.lsp + explicitly to (long) to ensure they can be extracted via + va_arg(,fixnum) + * reenable SA_SIGINFO on amd64 to restore SGC there + * Include elf.h in FreeBSD.h + * Allow for elf_abi.h in FreeBSD.h + * Add README.openbsd file + * readme.mingw updates + * solaris.h updates for custreloc option + * Close possibility of malloc failure due to intervening gbc arising + from the misordering of allocation calls + * C_GC_OFFSET is 2 on m68k-linux + * Add release notes, remove gcl document presumably based on dpANS for + now + * Fixup bad extern declaration of signals_handled in usig.c + + -- Camm Maguire Fri, 25 Jun 2004 22:43:52 +0000 + +gcl (2.6.1-39) unstable; urgency=high + + * Fix segfault in referencing (sgc_)type_map out of bounds which can + occurr when C stack is below heap, as on alpha. + * Cleanup compiler warnings on bcmp.c bzero.c and bcopy.c + * Clean up compiler warning in file.d + * Ensure set TLDFLAGS are used in finding DBEGIN in copnfigure.in, for + OpenBSD + + -- Camm Maguire Fri, 7 May 2004 21:50:03 +0000 + +gcl (2.6.1-38) unstable; urgency=low + + * Make *features* entries keywords -- add canonical host cpu and + kernel-system to *features*, disable h files specific + ADDITIONAL_FEATURES macro in main.c + * Fix merge-pathanames bug in concatenating default and supplied + directory lists + * Minor pathname and *features* fixes + * Fix recently introduced configure.in syntax bug + * Minor patches to support big gcl images -- all page integers must be + long ints, need stack space limits that scale with MAXPAGES at least + to allow free_map stack array in sgc_start. FIXME -- right now can + handle situations where page numbers are ints, but npage*PAGESIZE is + a long, need to handle npage >MAX_INT later. This is to support the + 'billion cons element acl2 image' requested by a gcl user + * Revert winnt features and debugging aids in configure.in + * OpenBSD support, gcc warning cleanups for long page integers + + -- Camm Maguire Mon, 3 May 2004 21:34:57 +0000 + +gcl (2.6.1-37) unstable; urgency=high + + * mprotect pages PROT_EXEC as CLEAR_CACHE step on amd64-linux + * Prevent recursive malloc calls for OpenBSD error reporting + * Push dummy 0 time for child runtime on windows to be compatible with + other platforms for now + * Make sure pages are mprotected PROT_EXEC for amd64 support + + -- Camm Maguire Tue, 13 Apr 2004 21:00:22 +0000 + +gcl (2.6.1-36) unstable; urgency=low + + * Improve optimize-maximum-pages algorithm + + -- Camm Maguire Tue, 6 Apr 2004 03:23:40 +0000 + +gcl (2.6.1-35) unstable; urgency=low + + * Fix sigcontext autodetection on sparc + + -- Camm Maguire Sun, 4 Apr 2004 19:26:48 +0000 + +gcl (2.6.1-34) unstable; urgency=low + + * Fix GNU_LD autodetection in configure.in + * Eliminate C_INCLUDE_PATH from shell script wrapper + * Use lisp rather than 'system touch' to make empty map file in + compiler::link + * fix small bug when info is passed bad second argument + * Don't try to open map file if doesn't stat (macosx) + * Add earlier forgotten branch patch to sfaslbfd.c for macosx + * Backport new eval-when keyword support from 2.7 to run random tester + * Perhormance improvement to gcl_seqlib.lsp -- no inner loop over + bignums + * Proper contblock/relblock determination when expanding string + streams + * Proper string type determination for *link-array* + * .ini files depend on plt.h + * plttest.c cannot depend on include.h + * Address longstanding FIXmE in gensym, so that two strings are not + allocated for each gensym + * Fix rare infinite loop bug in array.c + * Import si::info into 'user + * , -> # as sed separator + * Minro warning removals and fixups + * Binary searches through ordered arrays of referred and changed + variables for dramatic compiler performance improvement in the large + case -- support declarations and thereby optimizations of the form + (declare ((vector t) foo)), etc. + * Better 'time macro + * rebuild pcl_gaz* files + * cleanup room report and give more space to modern large heaps + * room report formatting + * Properly gensymmed time macro + * Allow for white space chars in compiled filenames + * Autodetect and work around sbrk randomization, e.g. on Fedora 1 + * Probe for sbrk before probing for randomized sbrk + * Openbsd changes -- maximize data seg resource if possible, avoid + mallocing error message when allocation routines fails + * Fix sigcontext configure tests + * Rename loop-finish -> sloop-finish in sloop package so that sloop + and ansi loop can be used simultaneously + * Handle arguments which are zero in LCM + * Fix typo in configure.in + * Improved dotimes macro which avoids unnecessary fixnum garbage + generation + * Backport of ignorable declaration keyword for new dotimes macro + * si::*OPTIMIZE-MAXIMUM-PAGES* support + * rebuild pcl generated lisp files + + -- Camm Maguire Sat, 3 Apr 2004 19:27:18 +0000 + +gcl (2.6.1-33) unstable; urgency=low + + * Remove extraneous symbols from plt.h, autodetect and correct for + leading underscore in object symbols + * complete readline version detection commit + * Backport support for new eval-when keywords + * Autodetect GNU ld and add -Wl,-Map only when appropriate + + -- Camm Maguire Wed, 10 Mar 2004 22:51:44 +0000 + +gcl (2.6.1-32) unstable; urgency=low + + * Try to automatically determine the form used for the explicitly + compiled in external function addresses in plt.c + * No need to explicitly write cr-lf on windows + * Autodetection of machine on FreeBSD + * Updated defs and h files for FreeBSD courtesy of Mark Murray + * Minor ifdefs needed for FreeBSD + * Refer to exported non-static C stub of fSmake_vector1 in plt.c + (needed on ia64) + * Readline 4.1/4.3 configure magic + + -- Camm Maguire Tue, 9 Mar 2004 01:58:43 +0000 + +gcl (2.6.1-31) unstable; urgency=low + + * Adjustments to vs_top reset logic to clear (hopefully last) + remaining bug found by the random-tester + * Allow args-info-referred-vars to match replaced vars, clearing bug + report submitted by Matt Kauffman + * Rework plt code yet again to be compatible with compiler::link for + axiom, and mingw32 + + -- Camm Maguire Mon, 8 Mar 2004 12:16:46 +0000 + +gcl (2.6.1-30) unstable; urgency=low + + * Fix rsym generated symbol tables for 64 bit platforms + * Make sure 'unwind' in frame.c does nt go below frs_org + * Do not define symbols with no value, either in bfd/rsym, or in + plt.c. Generates a clear and explicit error of an undefined symbol + when we've missed an address + * Define the external symbols known to be written at present in plt.c + * fix some more compiler errors found by the random tester -- all + related to proper unwinding of temporary reductions of vs_top from + te local supremum + + -- Camm Maguire Sat, 6 Mar 2004 02:05:59 +0000 + +gcl (2.6.1-29) unstable; urgency=low + + * Remove implicit dependency on gawk, optimize plt.c a little + + -- Camm Maguire Wed, 3 Mar 2004 16:08:30 +0000 + +gcl (2.6.1-28) unstable; urgency=low + + * make sure bfd fasload initializes dum.sm.sm_object1 for + read_fasl_vector + * When a tagbody contains ccb reference tags, and hence i itself + marked ccb, mark all the clb tags therein ccb too, as the tagbody + environment will be consed in c2tagbody-ccb. FIXME -- review this + logic carefully + * fix typoe in o/sfaslbfd.c + * Add code to unwind redefinitions of the stack supremum in c2expr-top + (used in c2multiple-value-prog1 and c2multiple-value-call in + evaluating arguments) on non-local exit + * Use new temporarry variables holding lisp stack supremum for lint + * Eliminate extraneous warning message when allocating fewer pages + than already allocated + * Rework internal plt symbol address capture + * Cleanup sfaslelf compiler warning + + -- Camm Maguire Wed, 3 Mar 2004 00:27:08 +0000 + +gcl (2.6.1-27) unstable; urgency=low + + * Modify default banner slightly + * Homebrew plt-like mechanism for ensuring that valid internal + addresses exist to which undefined symbols in compiled lisp objects + referring to external shared libraries can be relocated + * Make configure demand gettext when choosing --enable-locbfd + * Make sure references to ldb1, a stub conventionally optimized away, + can be resonled when optimization is turned off + * completion_matches -> rl_completion_matches in gcl_readline.d, + which is what is exported in the headers + + -- Camm Maguire Fri, 27 Feb 2004 23:50:49 +0000 + +gcl (2.6.1-26) unstable; urgency=low + + * Rework compiler::*ld-libs*, compiler::link, and unixport/makefile to + accomodate mingw need for firstfile.o and lastfile.o + * Remove incompatible -fomit-frame-pointer when compiling with -pg + profiling + * Load sys-proclaim.lisp files forimproved linking and smaller object + size across the board, install same for use with compiler::link + * Use pathnames instead of strings in compiler::link, also in image + init files, for Windows + * small mod to unixport/makefile re filtering of firstfile and + lastfile + * Backport zero divisor error cnditions from HEAD for + floor,ceiling,truncate + * Default to debug mode on hppa to work around gcc compiler + optimization bugs + * Add missing m4 and automake files in binutils directory to enable + automake and autoconf here + * Add mach-o specific files from cvs head to local bfd tree + * Add bfd/po makefiles + * Macosx defaults in configure.in + * bfd make and configure file changes to handle mach-o backend + * *gcl-version* -> *gcl-minor-version*,*gcl-extra-version* + * Support for more informative banner reading features list + * Support for both sigbus and sigsegv in sgbc.c as is customary in .h + files + * mach-o compatible changes in sfaslbfd.c + * Support for new debugging section names in sfaslelf.c + * powerpc-macosx h and defs files from cvs head + + -- Camm Maguire Wed, 25 Feb 2004 23:08:59 +0000 + +gcl (2.6.1-25) unstable; urgency=low + + * rl_putc_em a carriage return after invoking readline to ensure the + prompt in rl_putc_em_line is cleared. + * use standard sgc fault recovery element for hppa as recommended by + hppa kernel experts + * Store banner in si::*system-banner* for possible modification + in compatibly licensed programs + * exit with -1 when standard in ends in lisp debug mode + * Backport macosx files from cvs HEAD + * Document system return codes + + -- Camm Maguire Fri, 13 Feb 2004 20:44:54 +0000 + +gcl (2.6.1-24) unstable; urgency=low + + * Revert unixport/makefile link order fix for windows, breaks + compiler::link, find another way + * runtime SGC fault recovery test + * Protect read/fread in case SGC is enabled with safe (restartable) + versions + * SGC on for arm and hppa + * remove fast-link workaround now fixed for windows + * Backport HEAD makefile changes to clean .{c,h,data} files and + new_decl.h, remove said from repository (generated files) + + -- Camm Maguire Thu, 12 Feb 2004 05:56:29 +0000 + +gcl (2.6.1-23) unstable; urgency=low + + * Remove calls to init-readline with new automatic readline setup + + -- Camm Maguire Tue, 27 Jan 2004 20:27:20 +0000 + +gcl (2.6.1-22) unstable; urgency=low + + * Build depend on emacs21 | emacsen + + -- Camm Maguire Fri, 23 Jan 2004 22:01:15 +0000 + +gcl (2.6.1-21) unstable; urgency=low + + * Automatic readline initialization + * Add watch file + * Prevent circular error loops + * Prevent automatic optimization added to CFLAGS by autoconf + * Rework documentation installation in and outside of Debian + * Support user deined predicates at an elementary level in the form + '(satisfies foop) in gcl_predlib.lsp + * Install binary gcd algorithm for ~10% performance increase + * Rescale some default allocation parameters -- bignum allocation by + relblocks by default, default growth parameters are 1 (min), + 0.1*MAXPAGE (max), 0.5 (increase), 0.3 (percent free), holepage is + 4*MAXPAGE/1024, INIT_HOLEPAGE, INIT_NRBPAGE and RB_GETA scale + accordingly + * Clean windows/sysdir.bat + * Check for zero args in new gcd code + * Default hole is maxpages/10, holesize configure option added + * Fix syntax errors in older reloaction code: sfaslelf.c + + -- Camm Maguire Fri, 16 Jan 2004 16:57:50 +0000 + +gcl (2.6.1-20) unstable; urgency=low + + * Fix gcl-doc doc-base files + + -- Camm Maguire Tue, 30 Dec 2003 22:30:39 +0000 + +gcl (2.6.1-19) unstable; urgency=low + + * Fix bug in compiler::c2labels in which *ccb-vs* was missing a ocal + rebind + * Remove duplicate tags from compiled C switch statements + * Minor merges for DARWIN support + * Path to configure to make --enable-emacsdir work + * Check for readline/readline.h header before configuring for readline + * Improve system bfd library location detection + * Make sure external gmp lib is compatible via __GNU_MP_VERSION, else + backoff to local gmp build; prepend externally defined CFLAGS into + output CFLAGS, FINAL_CFLAGS, and NIFLAGS + * Remove --enable-gmp configure option; gmp is required for GCL + * Use --enable-emacsdir in debian/rules, make sure --enable-emacsdir + and --enable-infodir work when arg contains ${prefix} + * Fix typo in chap-6.texi + * Make sure to export SGC define from config.h to cmpinclude.h -- Now + that we used optimized structures in the compiler, we need at least + the definition of SGC_TOUCH there to prevent GBC errors. FIXME -- + handle header dependencies more robustly. Thanks to Robert Boyer + for the report + * Improve SGC define extraction for cmpinclude.h + * Fix variable reference errors which were occurring for compiled + local functions defined within closure-generating or other + environment stack pushing functions when safety is set to 3 (thanks + Paul Dietz for the report.). When constructing local functions and + closures within a 'mother' function, *ccb-vs* will hold the number + of closure environments stacked at the point of each closure + creation or call to a local function. This value is stored as the + cadr of a list pushed onto *local-funs*, and is read when writing + out the C code for the local function or closure, where it is used + to initialize *ccb-vs* and *initial-ccb-vs* for subsequent + processing. The latter is used as the reference point when + addressing variables in wt-ccb-vs, as the former could be still + further incremented within the closure or local function itself. + Local functions as opposed to closures do not increment *ccb-vs* and + do not push the environment. When a local function is defined + within a closure-generating flet/labels, or a tagbody or block which + pushes the environment, the value of *ccb-vs* written to the list + corresponding to the local function can be erroneously incremented + beyond the *initial-ccb-vs* value established before any environment + pushing operations were processed. It is this latter value which is + appropriate for use in wt-ccb-vs, as the local functions, unlike the + closures, receive an environment level with the mother generating + function. We therefore push *initial-ccb-vs* onto the end the list + pushed onto *local-funs* only when defining a local function, and use + it to initialize an added optional variable initialize-ccb-vs in + t3local-fun and t3local-dcfun, which default to the original ccb-vs. + We then bind *initial-ccb-vs* to this new optional parameter instead + of the former *ccb-vs, which was only appropriate for closures. + * Put in rudimentary logic for the selection of stack vs. heap storage + for bignums depending on the frame context. FIXME, this logic is + too conservative at present. SETQ_II and SETQ_IO take an additional + parameter which is malloc when *unwind-exit* is bound and contains + 'frame and alloca otherwise. New macro bignum-expansion-storage. + FIXME, ensure that IDECL does not need similar modification. + * Cleanup a few compiler warnings in the compiler + * Cleanup compiler warning in alloc.c + * Eliminate unneeded transformatio of contniguous pages to other pages + on save-system. + * malloc -> gcl_gmp_alloc in recent setjmp frame protected bignum + allocation + * Add -Wa,--execstack if on an exec-shield enabled system, can be + explicitly added otherwise by setting the CFLAGS variable before the + configure step + * Better execstack flag handling in configure + * Allow for commas in CFLAGS in sed command writing *cc* + * Preliminary gprof profiling support + * Rework html documentation generation and installation, Closes: + #221774 + * Remove parentheses from setf class-name info node in chap-7.texi + + -- Camm Maguire Tue, 30 Dec 2003 16:26:45 +0000 + +gcl (2.6.1-18) unstable; urgency=low + + * Portability patches to makefiles to support non-GNU grep (no -q), + and non-bash sh, C_INCLUDE_PATH=...;export C_INCLUDE_PATH + * copy the global *info* parameter in c1flet and c1labels to prevent + accumulation of old data -- FIXME -- make sure there are no other + copies required, and eventually replace this global parameter with + local variables + * Turn on some optimization on hppa, -O only + * Make all C defined functions installed into lisp static functions to + work around dynamic function descriptors on ia64, Closes: #217484, + Closes: #204789, (STATIC_FUNCTION_POINTERS define in config.h) + + -- Camm Maguire Thu, 6 Nov 2003 15:40:25 +0000 + +gcl (2.6.1-17) unstable; urgency=low + + * Repair weak symbol addition to the bfd symbol table in sfasli.c + * Be more thorough about adding fun-info to call-local info in + gcl_cmpflet.lsp, accompanying simplifications in gcl_cmpeval.lsp + (call-global lists have info updated by args already in (c1args args + info)), small changes in add-info in gcl_cmpinline.lsp, FIXME -- + study rational for *info* special variable in certain places as + opposed to more common copy-info + + -- Camm Maguire Thu, 30 Oct 2003 20:03:22 -0500 + +gcl (2.6.1-16) unstable; urgency=low + + * Fix sh syntax in debian/gcl.sh + * init_or_load1 -> gcl_init_or_load1 in xgcl-2/sysinit.lsp + * Load weak symbols as well as undefined symbols in + bfd_build_symbol_table, for the purposes of the static build + possibility + * Map t and nil stream indicators properly in optimized compiled + references to read_char1 and read_byte1 (in read.d) + + -- Camm Maguire Thu, 23 Oct 2003 16:43:15 +0000 + +gcl (2.6.1-15) unstable; urgency=low + + * Remove imod/ifloor functions in cmpaux.c and directly inline their + fixed equivalents in gcl_cmpopt.lsp + + -- Camm Maguire Mon, 13 Oct 2003 15:04:24 +0000 + +gcl (2.6.1-14) unstable; urgency=low + + * generate less garbage in add-info (gcl_cmpinline.lsp), enabling + maxima compile to complete in a finite time :-) + + -- Camm Maguire Fri, 10 Oct 2003 22:14:04 +0000 + +gcl (2.6.1-13) unstable; urgency=low + + * Fix compiler optimization bug in gcl_cmpopt.lsp -- missing parens + around inliner for max and min + * collect info structures for local functions in flet and labels + processing (gcl_cmpflet.lsp), and pass upwards to call-local and + call-global (gcl_cmpeval.lsp) to fix certain inlining bugs in via + more proper operation of args-info-changed-vars (gcl_cmpinline.lsp, + inline-args, gcl_cmplet.lsp, c2let) + * Fix an obviou int overflow in ifloor (o/cmpaux.c), handle more + proper fixnum/integer determination from declarations later + + -- Camm Maguire Fri, 10 Oct 2003 02:34:11 +0000 + +gcl (2.6.1-12) unstable; urgency=low + + * Restore mpz_to_mpz{1} in gmp_big.c, can be written by compiler + * tk8.4 patches + * Prevent destructive modification of bignum arguments in log_op/mp_op + in gmp_big.c + * Make sure to push stack variables onto newly allocated C variable + when inlining args and args cause side effects, in inline-args, + gcl_cmpinline.lsp + * Fix bug related to gcc-3.3 fixes in set_exponent in num_co.c + * Remove pcl_methods.c patch. as is apparently no longer needed, TODO + -- make sure VOL modifier is inserted where needed to prevent + longjmp clobbers + + -- Camm Maguire Thu, 2 Oct 2003 14:26:43 +0000 + +gcl (2.6.1-11) unstable; urgency=low + + * Add compilation step of compiling all lsp and cmpnew .lsp files from + an interpreted only saved_pre_gcl before the creation of saved_gcl - + - this enables us to use full optimization on these files while + getting the STREF constants right on 32bit and 64bit + * remove 'attic' from comment in gcl_loop.lsp + * configure changes for sizeof(struct contblock) detection + + -- Camm Maguire Wed, 24 Sep 2003 16:09:44 +0000 + +gcl (2.6.1-10) unstable; urgency=low + + * Mac OSX GET_FULL_PATH_SELF + * Preliminary subtypep checking for 'satisfies + * preliminary 'satisfies support in subtypep, more predicate type + pairs and reverse checking + * small compiler change to remove unused C variables from optimized + compiled macros + * Optional compiler init file is called gcl_cmpinit + * fasdmacros.lsp -> gcl_fasdmacros.lsp + * All cmpinit.lsp files named gcl_cmpinit.lsp; allow full lisp + optimization in all directories + * collectfn -> gcl_collectfn in lsp/gcl_auto.lsp + * collectfn -> gcl_collectfn in cmpnew/gcl_make-fn.lsp + * Make sure makefiles can generate sys-proclaim.lsp, regenerate these + files and recompile from lsp + * Rebuild with opts enabled + * Iterate sys-proclaim/rebuild generation once more + * Iterate sys-proclaim/rebuild for pcl and clcs + + -- Camm Maguire Tue, 23 Sep 2003 19:33:27 +0000 + +gcl (2.6.1-9) unstable; urgency=low + + * Close streams in fasldlsym.c + + -- Camm Maguire Tue, 16 Sep 2003 14:57:20 +0000 + +gcl (2.6.1-8) unstable; urgency=low + + * Add processor flag variable to flags in configure.in + * Autoadd full path to kcl_self to enable save-system when user moves + executable and calls without script wrapper + * Add special variables si::*collect-binary-modules* and si::*binary- + modules* as a facility for discovering the list of fasloaded objects + preceding a save-system is required for a subsequent compiler::link + * Add collectfn.lsp to distro + * Rename some files and init_ functions to eliminate namespace + conflicts when building images with compiler::link + * Enable compressed info reading + * Make sure no opt flags are set when enable debug is specified + * Use NIFlAGS to compile new_init with lower opts on ppc to work + around gcc bug, restore full opts to other files + + -- Camm Maguire Sun, 14 Sep 2003 02:18:28 +0000 + +gcl (2.6.1-7) unstable; urgency=low + + * Fix permissions bug in temporary gzipped file handling + * Propagate control changes correctly with package extension + * Newer standards + + -- Camm Maguire Tue, 9 Sep 2003 17:06:56 +0000 + +gcl (2.6.1-6) unstable; urgency=low + + * Remove build-dependency on autoconf as a temporary work around to + Debian autoconf's dependency bug on emacsen-common + + -- Camm Maguire Tue, 9 Sep 2003 15:29:06 +0000 + +gcl (2.6.1-5) unstable; urgency=low + + * Redefine temporary files in elisp/makefile + + -- Camm Maguire Mon, 8 Sep 2003 21:49:09 +0000 + +gcl (2.6.1-4) unstable; urgency=low + + * Fix to sfasli.c to avoid defining symbols in other than *UND* + sections + * Remove some 64 bit warnings + * Turn off def_static on ia64 for now -- its broken + + -- Camm Maguire Sat, 6 Sep 2003 17:22:10 +0000 + +gcl (2.6.1-3) unstable; urgency=low + + * Fix static detection fr ia64; contblock size detection on arm + * Fix gcc verion checking in gmp3 subconfigure, esp. for arm + * Escape all sgc code with #ifdef SGC + + -- Camm Maguire Fri, 5 Sep 2003 21:32:47 +0000 + +gcl (2.6.1-2) unstable; urgency=low + + * Add windows/install.lsp to clean target + * Add in macosx files to stable and cvs head + * Fix bad debelper postinst, Closes: #208765 + + -- Camm Maguire Fri, 5 Sep 2003 13:15:11 +0000 + +gcl (2.6.1-1) unstable; urgency=low + + * New upstream release + * Type-punning warning fixes + * small_fixnum overflow fixes + * off by one fix in cerror + * Fix compiler error which had not recognized defpackage as a package + operation + * Fix tkl.lisp call to open-named-socket + * Make values-list and nreconc signal errors when they should on + dotted lists. + * Avoid use of windows.h types as macros. + * New config.{sub,guess} + * Windows installer updates from CVS HEAD + * fix potential longjmp clobber in read.d;add some windows files to + main makefile clean target; + * Darwin revealed fixes to usig.c and unixtime.c + * Fix gbc time calculation in case of recursive gbc calls + * Run patch_sharp in LSharp_exclamation_reader to handle new case of + defpackage ops at head of fasl vector, required for maxima build + * Special symbol Dotnil has ordinary list Cnil for plist and hpack + * Small fixes for profiling support + * Restore pp() function for debugging; print out undefined symbol + names + * Small patch for fix xgcl demo (thanks Michael Koehne) + * Better bfd symbol table strategy + * Fix bfd table symbol counting for combined_table profiling + * amd64 linux support + * O6 -> O3 + * static linking on ia64 to work around current mechanism for runtime + generated function descriptors + * enable-static configure option + * Fix debian/gcl-doc.docs for latest texinfo file splitting policy, + Closes: #206017 + * Fix typo in o/sfasli.c + * Rework debian package structure to handle stable and cvs packages + simultaneously + * Add gazonk*.lsp to clean target + * syntax fix to lsp/gprof.hc + * Add support for SGC contblock pages + * Fixes to debian/rules + * Remove unused definitions of Vcs + * Increase default maxpages and stack sizes + * Maintain a persisten *system-directory* binding + * Push installed /h directory onto -I flags on cc command line + * Escape old in-package behavior with #ifdef ANSI_COMMON_LISP + * define HAVE_XDR in linux.h + * reduce resolution of contblock mark_table in gbc.c to match new + minimum granularity introduced via CPTR_ALIGN + * Remove exit function in main.c + + -- Camm Maguire Thu, 4 Sep 2003 02:20:52 +0000 + +gcl (2.5.3-2) unstable; urgency=low + + * gcc-3.3 all platforms + + -- Camm Maguire Mon, 7 Jul 2003 16:10:25 +0000 + +gcl (2.5.3-1) unstable; urgency=low + + * New upstream release + * Restore object_to_float and object_to_double, cmpaux.c, Closes: #195470. + * Remove obsolete functiion multiply-bignum-stack from documentation, + si-defs.texi + * Unstatic object_to_float, object_to_double + + -- Camm Maguire Mon, 2 Jun 2003 12:38:03 -0400 + +gcl (2.5.2-1) unstable; urgency=low + + * New upstream release + * Cleanup xdrfuns.c for Axiom + * Reenable xgcl build + + -- Camm Maguire Thu, 20 Mar 2003 09:15:54 -0500 + +gcl (2.5.1-1) unstable; urgency=high + + * some optimization now on hppa + * Add RELEASE-2.5.1 file + * Add dedication notice to the memory of W. Schelter + + -- Camm Maguire Sun, 2 Mar 2003 10:20:26 -0500 + +gcl (2.5.0.cvs20020625-80) unstable; urgency=low + + * enable japi configure flag, defaults to no + * enable -mlongcall on ppc when using gcc 3.3 or higher + * int -> fixnum in DEFUN function arguments for safety -- ensures + pointers and integers passed by lisp are of same size + * MYmake_fixnum macro simplification + * ufixnum typedef + * Prototypes for cmod et.al. -- restoring maxima build on ia64 + * Fix unaligned access message on ia64 generated by DFLT_aet_fix + * Integer va_arg uses fixnum + * Define __*i3 symbols used by GCL, supplied by libc, and written into + some GCL compiled objects, restores ARM build with ANSI image + * num_log.c miscompilation on ia64 apparently fixed, Closes: #156291 + * Ensure cmpinclude.h up to date in main makefile + + -- Camm Maguire Sat, 1 Mar 2003 17:33:29 -0500 + +gcl (2.5.0.cvs20020625-79) unstable; urgency=low + + * Fix Debian package install bug + + -- Camm Maguire Thu, 27 Feb 2003 23:17:55 -0500 + +gcl (2.5.0.cvs20020625-78) unstable; urgency=low + + * Add config.log config.status and config.cache to clean target + * Remove xgcl-2/debian directory + * Update clcs/sys-proclaim.lisp + + -- Camm Maguire Thu, 27 Feb 2003 18:48:38 -0500 + +gcl (2.5.0.cvs20020625-77) unstable; urgency=low + + * Lintian cleanups + * Don't strip libansi_gcl.a, need .data at end of .o, as with libgcl.a + * Take newlines out of doc string for init-cmp-anon + * Cleanup gcc-3.2 compiler warning + * 64 bit STREF fixes + * pcl and clcs need to have C rebuilt afresh, as 64 bit machines write + different STREF offsets into the C files + * Rework Debian package build a bit + * README.Debian explaining the toggling of the ANSI image + * Typo in debian/rules + * Remove debian/gcl.conffiles + + -- Camm Maguire Thu, 27 Feb 2003 15:56:11 -0500 + +gcl (2.5.0.cvs20020625-76) unstable; urgency=low + + * Debian Priority is optional + * Configure lowest common denominator on m68k to m68020 -- gcc-3.2 + can't handle m68000 -- no __mulsi3 + * Fix bit array bug + * Add upgraded-array-element-type + * Misc typep and subtypep fixes + * Proper error handling in certain array.c functions + * First needs exactly one arg + * Proper error handlin in LAST + * bit array allocation fixes in num_log.c + * eliminate Iapply_fun_n1 + * Dummy system find-class in traditional image, overwritten by pcl + version in ANSI + * Invalid variable is a program error, not a symbol is a type error + * Attempt at uninterned symbol support as slot names + * defstruct changes for ANSI conc-name handling + * Rework ansi build to follow existing pattern for traditional image, + enabling preliminary ansi support on dlopen systems + * Fix broken mingw probe in main makefile + * Rename pcl and clcs files to avoid init name conflict on dlopen + systems + * sys-proclaim for clcs + * Compiler goto indentation + * Compiler pointer cast in call_or_link_closure + * *keep-gaz* compiler variable to save anonymously generated lisp + * si::init-cmp-anon function to initialize anonymously generated and + compiled lisp from .text section of running executable + * Debian/rules builds and ships both images + * Check for small fixnum in make_fixnum macro + * Pass real integers to array functions to minimize fixnum garbage + * Larger SHARP_EQ_CONTEXT_SIZE in read.d + * Shadowing-import instead of import dummy symbols into common-lisp in + ansi_cl.lisp + * Rework object definition in makefiles + * Remove old gmp directory + * Remove old tests directory + * Reinsert JAPI configuration + * Spruce up clean target + * Use saved_gcl to recompile cmpnew files + * Toggle ansi image with GCL_ANSI environment variable + * Version 2.5.1 + + -- Camm Maguire Wed, 26 Feb 2003 21:31:04 -0500 + +gcl (2.5.0.cvs20020625-75) unstable; urgency=low + + * Export truename for dlopen systems + + -- Camm Maguire Fri, 14 Feb 2003 23:31:15 -0500 + +gcl (2.5.0.cvs20020625-74) unstable; urgency=low + + * Remove duplicates in apropos a la clisp + * Use static where possible, remove unused functions, decrease global + symbol count by about 1/3 (~ 600 global functions) + * Inline optimize cmod,cplus,ctimes and cdifference like maxima + * eliminate make-pure-array from lfun_list.lsp, not defined + * Prototypes for all possible compiler generated function calls + * relative symlink for cmpinclude.h in Debian package + + -- Camm Maguire Fri, 14 Feb 2003 20:17:31 -0500 + +gcl (2.5.0.cvs20020625-73) unstable; urgency=low + + * typep fixes for class types + * m68k Build-depend on gcc-2.95 as a temporary work around to bug + 179807 + * gcc-3.2 warning cleanups + * bfd_boolean syntax support for newer binutils + * gcc-3.2 on powerpc can't yet handle -O2 and higher + * Reenable gcc-3.2 for m68k and do some guesswork in configure + + -- Camm Maguire Mon, 10 Feb 2003 13:47:00 -0500 + +gcl (2.5.0.cvs20020625-72) unstable; urgency=high + + * Fix to siLbit_array_op for 0 dimension arrays + * Fixed aref of short-float vector + * nconc can take dotted lists + * tailp returns t if first arg is nil + * Repair nconc and tailp fixes + * varargs->stdarg for gcc 3.3 and higher + + -- Camm Maguire Sun, 9 Feb 2003 16:57:33 -0500 + +gcl (2.5.0.cvs20020625-71) unstable; urgency=high + + * ansi changes to sloop.lsp and conditions.lisp to fix symbol tests + * :definition-before-pcl -> definition-before-pcl + * Allow spaces in pathnames + * Significant fixes to gmp_num_log.c affecting bitwise ops on bignums + * Fix test segfault arising from faulty structure-type-included-type- + name in gcl-low.lisp ; Thanks Peter + * aref1 -> row-major-aref + * Fixes to certain numerical functions to handle denormalized floating + point numbers + * Number of argument check in IapplyVector + * Print offset bit vectors correctly + * Correct precision for formatting short and long doubles + * Added si::modf + * Do not trigger error in IapplyVector if max args is zero + * Fixes to with-package-iterator to cleanup compiler warnings + * :invalid-variable is a type error + * No max arg checking if &key or &rest present + * proper defun declarations in listlib.lsp + * class specifiers in typep, subtypep and coerce + * Corrections to allow-other-key processing in bind.c + * eval sfuns with argument error checking (in one place) + * copy-structure takes only one arg + * si::classp, si::class-of, and si::class-precedence-list overwritten + by pcl analogs when compiling ansi + * recompiled core lsp and compiler files + * restore dvi and html doc build for non-mingw + + -- Camm Maguire Fri, 24 Jan 2003 13:55:11 -0500 + +gcl (2.5.0.cvs20020625-70) unstable; urgency=high + + * loop fixes + * configure fixes + * :common-lisp in *features* + * :definition-before-clcs -> definition-before-clcs + * protect against sgc segfault within fread in fasdump.c -- fixes m68k + acl2 build + * SGC for s390 + + -- Camm Maguire Thu, 5 Dec 2002 08:02:17 -0500 + +gcl (2.5.0.cvs20020625-69) unstable; urgency=high + + * eval fix + * \-mlong-calls for arm + + -- Camm Maguire Mon, 25 Nov 2002 08:35:27 -0500 + +gcl (2.5.0.cvs20020625-68) unstable; urgency=high + + * enable emacsdir configure option + * reordered configure X lib detection for solaris + * redo integer declarations for gmp bignums to avoid compiler warnings + * Clear large and negative count errors for remove/delete + * Loop error fixes + * cache flush with page granularity on m68k + + -- Camm Maguire Thu, 21 Nov 2002 17:44:30 -0500 + +gcl (2.5.0.cvs20020625-67) unstable; urgency=high + + * Align cache flushes for powerpc and m68k on 32 byte boundaries, + should fix acl2 build + * Removed diagnostic SIGILL trapping in cmpaux.c + + -- Camm Maguire Tue, 12 Nov 2002 23:25:49 -0500 + +gcl (2.5.0.cvs20020625-66) unstable; urgency=high + + * Fix SIGILL trap in cmpaux.c + + -- Camm Maguire Mon, 11 Nov 2002 11:14:07 -0500 + +gcl (2.5.0.cvs20020625-65) unstable; urgency=high + + * Miscellaneous Freebsd patches + * non-recursive with-package-iterator + * map-into fill-pointer fixes + * changes to the user-init mechanism for portable acl2 build + + -- Camm Maguire Sun, 10 Nov 2002 12:33:59 -0500 + +gcl (2.5.0.cvs20020625-64) unstable; urgency=low + + * Fix epsilon calculations again to reenable arm build + + -- Camm Maguire Fri, 1 Nov 2002 07:08:33 -0500 + +gcl (2.5.0.cvs20020625-63) unstable; urgency=low + + * Add versioned dependency on the gcc used to build gcl + + -- Camm Maguire Tue, 29 Oct 2002 16:20:22 -0500 + +gcl (2.5.0.cvs20020625-62) unstable; urgency=low + + * with-package-iterator modifications + * with-package-iterator uses labels to correctly provide for recursion + * Fix doc directory problem with install target in info/makefile + * Fix info dir setting in configure + * Priority extra + + -- Camm Maguire Mon, 28 Oct 2002 23:45:07 -0500 + +gcl (2.5.0.cvs20020625-61) unstable; urgency=low + + * Placeholder support for optional condition in find-restart + * defpackage error on importing non-existent symbols + * working with-package-iterator macro + * various package errors reported as :package-error + * Destructuring-bind fixes + * delete-package error fix + * pcl functions use pcl-destructuring-bind for now -- fix later + * Trigger error if function calls use too many 'values' + * Maximum values increased to 50 + * Enable previously failing tests in multiple-value-{setq,prog1}.lsp + * prototype for system_time_zone_helper + * Initial changes for solaris support + * make -> $(MAKE) in makefiles + * Incorporated main GCL (ANSI) Lisp Documentation in distribution + + -- Camm Maguire Mon, 28 Oct 2002 04:31:33 -0500 + +gcl (2.5.0.cvs20020625-60) unstable; urgency=low + + * Still better acosh, courtesy of Barton Willis + * Better epsilon contant determination in ieee case + * Implicit tagbody in do-symbols and do-all-symbols + * Better epsilon handling in ieee case + * Add setf (values ... support + * invalid-function errors are type errors + * ecase and ccase take t and otherwise clauses + * ECASE/CCASE test fixes + * setf values fixes to use setf instead of setq when target value is + not a symbol + * ETYPECASE/CTYPECASE can take t and otherwise + * Backout of restart-clusters export + * fix handler.lisp + * Fix to bfd/GBC interaction + + -- Camm Maguire Wed, 23 Oct 2002 08:38:08 -0400 + +gcl (2.5.0.cvs20020625-59) unstable; urgency=low + + * wrong number of arguments, keyword errors in lambda list bindings, + are program errors + * acosh fix at -1.0 + * New config.sub and config.guess files and automatic updates in + binutils, gmp, and gmp3 subdirs + + -- Camm Maguire Wed, 16 Oct 2002 11:38:56 -0400 + +gcl (2.5.0.cvs20020625-58) unstable; urgency=low + + * GENSYM fixes + * add complement and constantly + * import certain symbols into common-lisp package + * Fix makefile bug in install target + * Prepend instead of overwrite C_INCLUDE_PATH in shell wrapper + * More shell variable fixes in main makefile + * Corrected order of push and pushnew + * Set bfd_error appropriately + * Report function for package-error in condition-definitions.lisp;fix + internal-package-error deinition and handling;export *restart- + clusters* to user error code specified in handler-case;package-error + error formatting changes;dummy optional argument added to compute- + restarts (for now);Paul Dietz patch to defpackage.lsp fixing several + tests (thanks);export/unexport error handling fixes + * Recompile c,h and data files + * Fix number of argument errors in debug.lsp;documentation support for + packages in defpackage.lsp and module.lsp;do-symbols loops over + inherited symbols too in packlib.lsp + * Reworked EXTRAS variable handling in unixport/makefile + * Build-depend on autotools-dev and automatic update of config.sub and + config.guess;newer config.sub and config.guess in cvs tree; Closes: + #164526 + * Remove stray comments in package.d + * elt errors of type type error + * bad-sequence limit returns type error + + -- Camm Maguire Tue, 15 Oct 2002 15:39:19 -0400 + +gcl (2.5.0.cvs20020625-57) unstable; urgency=low + + * Capitalization changes to names of special characters;graphic-char-p + fix + * fix shadowing of existing symbols in package.d + * (simple-)base-string not a subtype of (simple-)vector + * add package-error condition(preliminary);hash conditions only by the + error name, not the format string;pass error types for both + correctable and non-correctable situations;eliminate duplicate + loading of clcs/package.lisp;Allow t doc-types in documentation + (returning nil) for now;fix final type errors in predlib.lsp + (regarding base-string);other error functions to pass continuable + errors (needs cleaning up);package designators can be + characters;delete-package added;make-package doesn't :use lisp by + default;in-package returns error if package does not exist instead + of making the package(relatively big change -- need to address + instances of in-package in .lsp code);call make-package on relevant + packages in init_gcl.lsp.in and pcl/sys-package.lisp; + * \-ffunction-sections for hppa with no-optimization -- enables first + maxima build here + * separate lisp variables to specify optimization flags for level 2 + and 3 + * symbol-name throws a type error on bad input + * tk8.2 -> tk8.3 + * Fix bug in main makefile + * Newlines at end of test files + + -- Camm Maguire Wed, 9 Oct 2002 15:04:41 -0400 + +gcl (2.5.0.cvs20020625-56) unstable; urgency=high + + * ansi-test corrections; extra-libs option to LINK function; LINK doc + change; subtypep and string changes to pass more tests + * Add method-combination and structure-object symbols for ansi;remove + unused variables in debug.lsp;remove in-package system from + defstruct.lsp;make-keyword and defmacro temporary function + placeholders in destructuring_bind.lsp;predlib changes to fix ansi- + test type errors;break-call takes 2 args (sys-proclaim.lisp);char + and char-set protected by string dimension not fillpointer in + string.d;fix bug in string.d:member_char for vector types;redefine + slot reader and writer functions in pcl/impl/gcl/gcl-low.lisp + + -- Camm Maguire Sat, 5 Oct 2002 14:33:46 -0400 + +gcl (2.5.0.cvs20020625-55) unstable; urgency=high + + * Add LINK documentation to info pages + * 0 length last support + * make-sequence error check for 'null type and non-zero size + * Dotted-list support in member + * Reworked dotnil definitions and support macros + * add compile-file-pathname + * setup C_INCLUDE_PATH env variable in gcl shell wrapper + * POSITIVE-FIXNUM variable type,simple-error->type error where + indicated by various ansi tests, eq->eql in ldiff and tailp;proper + lists only in member et. al. + * rev keyword for member1 to reverse test arguments + * specific-error function to pass a given type of error from lisp + * set-exclusive-or preserves order of test arguments + * type-errors where appropriate in make-sequence + * nil keys accepted in remove/delete et.al. + * Reworked linking command line to ensure that certain symbols are + resolved in libgcl.a as opposed to certain system libraries, e.g. + gmp + * new gmp for m68k;no -ffloat-store for m68k a requested by user due + to performance impact (will alter test results in maxima + accordingly) + * libgclp.a for objects to be overriden by the C library if necessary + * readably support + * boolean type + * Missing ansi type support + * subtype code for boolean + * add missing ansi types as known types + * other preliminary subtype code for missing ansi types + * rework result-type check in make-sequence + * :element-type support in make-string (preliminary) + * (char ignores fill-pointer + * remove -O4 from debian/rules + + -- Camm Maguire Thu, 3 Oct 2002 01:52:45 -0400 + +gcl (2.5.0.cvs20020625-54) unstable; urgency=high + + * Fix delete et. al. :from-end error; typo in gbc.c + * character and string-char equal in type hierarchy + * concatenate/make-sequence fixes + * merge takes nil key argument + * make-sequence checks size against result type + * install endp macro for dotted list support + + -- Camm Maguire Tue, 24 Sep 2002 14:57:44 -0400 + +gcl (2.5.0.cvs20020625-53) unstable; urgency=high + + * Sleep with (in principle) microsecond precision + * nth-value macro added + * \-ffloat\-store and warning cleanups for m68k + * Compile hppa with debugging, will get a build but a broken one, ok + for now, Closes: #159591 + + -- Camm Maguire Fri, 20 Sep 2002 09:48:35 -0400 + +gcl (2.5.0.cvs20020625-52) unstable; urgency=high + + * Fixed gcc version bug in debian/rules + + -- Camm Maguire Thu, 12 Sep 2002 18:00:50 -0400 + +gcl (2.5.0.cvs20020625-51) unstable; urgency=high + + * static gmp for m68k + + -- Camm Maguire Thu, 12 Sep 2002 09:33:03 -0400 + +gcl (2.5.0.cvs20020625-50) unstable; urgency=high + + * Reworked static gmp target for new libgcl.a;gcc-3.2 for + hppa,ia64,and arm;libgmp2-dev for m68k;no rsym with + dynsysbfd;build_symbol_table earlier to shrink table size; + + -- Camm Maguire Thu, 12 Sep 2002 00:39:17 -0400 + +gcl (2.5.0.cvs20020625-49) unstable; urgency=high + + * Use old gmp for m68k until can pin down test failure with gmp3 + + -- Camm Maguire Tue, 10 Sep 2002 00:36:10 -0400 + +gcl (2.5.0.cvs20020625-48) unstable; urgency=high + + * Rework build and install so that custom images can be made without + the source tree, even when using dlopen + + -- Camm Maguire Mon, 9 Sep 2002 23:26:47 -0400 + +gcl (2.5.0.cvs20020625-47) unstable; urgency=high + + * Install cmpinclude.h in system include directory + + -- Camm Maguire Thu, 29 Aug 2002 23:31:55 -0400 + +gcl (2.5.0.cvs20020625-46) unstable; urgency=high + + * Keep a *much* smaller piece of gmp.h in cmpinclude.h, reducing image + size by almost 100k + * Check for _SHORT_LIMB and _LONG_LONG_LIMB in configure + * Remove build specific include directories from compile command in + final executable + * Include local regexp.h explicitly in cmpinclude.h, to eliminate + intereference with system regexp.h, and to fix bug in which gcl + compilation depended on existing build directories + * Correctly add directory paths to extra gmp file targets in + unixport/makefile for m68k + + -- Camm Maguire Thu, 29 Aug 2002 21:56:28 -0400 + +gcl (2.5.0.cvs20020625-45) unstable; urgency=high + + * Fix typo in rshift target for m68k + + -- Camm Maguire Wed, 28 Aug 2002 18:02:00 -0400 + +gcl (2.5.0.cvs20020625-44) unstable; urgency=high + + * Handle second argument to last; treat dotted lists correctly in + ldiff et. al., tailp fix + * optional key argument for assoc-if et.al.;eval getf deflt if in setf + * Fix infinite loop in assoc-if et.al. + * X_LIBS and X_CFLAGS determination in configure script + + -- Camm Maguire Wed, 21 Aug 2002 18:22:37 -0400 + +gcl (2.5.0.cvs20020625-43) unstable; urgency=high + + * Larger ihs stack;fix array-total-size-limit;check negative + fillp;allow #P + * don't make common_lisp package when not configuring with --enable- + ansi + * Patch gmp3/mpn/m68k/{l,r}shift.asm, restore gmp3 to m68k build + * Dynamic libgmp support, overriding with patched functions from local + source where necessary + + -- Camm Maguire Sun, 18 Aug 2002 12:10:55 -0400 + +gcl (2.5.0.cvs20020625-42) unstable; urgency=high + + * copy ansidecl.h and symcat.h in h/ for local bfd builds + * localize bfd.h includes to sfaslbfd.c + * take bfd/po out of the build loop + * import xgcl-2, but don't build by default + * oldgmp configure option, and made default for m68k as temporary + workaround + + -- Camm Maguire Mon, 12 Aug 2002 23:49:09 -0400 + +gcl (2.5.0.cvs20020625-41) unstable; urgency=high + + * Minor rules revision for i164 + + -- Camm Maguire Sun, 11 Aug 2002 13:49:03 -0400 + +gcl (2.5.0.cvs20020625-40) unstable; urgency=high + + * revamp CONST configure test for certain bfd versions + + -- Camm Maguire Sun, 11 Aug 2002 12:31:35 -0400 + +gcl (2.5.0.cvs20020625-39) unstable; urgency=high + + * gcc-3.1 for ia64 fixes a compilation bug in num_co.c for -O3 and + higher -- code takes address of a variable kept in a register + * compile num_log.c with -O only on ia64 to work around compiler bug + + -- Camm Maguire Sun, 11 Aug 2002 08:53:03 -0400 + +gcl (2.5.0.cvs20020625-38) unstable; urgency=high + + * check for long c statck addresses, fixing NULL_OR_ON_C_STACK macro + for ia64 + * Remove error in clean target + + -- Camm Maguire Sat, 10 Aug 2002 13:20:08 -0400 + +gcl (2.5.0.cvs20020625-37) unstable; urgency=high + + * Replace tmpnam and mktemp with less dangerous mkstemp + + -- Camm Maguire Fri, 9 Aug 2002 19:45:52 -0400 + +gcl (2.5.0.cvs20020625-36) unstable; urgency=high + + * Fix rsym compilation when not using bfd + + -- Camm Maguire Fri, 9 Aug 2002 19:10:16 -0400 + +gcl (2.5.0.cvs20020625-35) unstable; urgency=high + + * Don't build bfd/po subdir + * Build-depend on automake and gettext + + -- Camm Maguire Fri, 9 Aug 2002 14:36:58 -0400 + +gcl (2.5.0.cvs20020625-34) unstable; urgency=high + + * fix zero length array support + * reverse configure order for bfd and libiberty + + -- Camm Maguire Fri, 9 Aug 2002 11:52:38 -0400 + +gcl (2.5.0.cvs20020625-33) unstable; urgency=high + + * chmod +x for subconfigures + * dlopen for appropriate arches in debian/rules + * add custreloc configure option + + -- Camm Maguire Fri, 9 Aug 2002 10:16:55 -0400 + +gcl (2.5.0.cvs20020625-32) unstable; urgency=high + + * Local bfd build option to prepare for arch-specific patches + * Try default gmp3 build on m68k + * Fix merge-pathnames + + -- Camm Maguire Fri, 9 Aug 2002 00:13:16 -0400 + +gcl (2.5.0.cvs20020625-31) unstable; urgency=high + + * #undef bool in object.h for some gcc-3.1 installations + * New number_tan implementation using real tan, so optimized compiled + code will find symbol in -lm + + -- Camm Maguire Tue, 6 Aug 2002 18:37:52 -0400 + +gcl (2.5.0.cvs20020625-30) unstable; urgency=high + + * fix bug in cmpif.lsp and recompile compiler + * \-O6 \-fomit\-frame\-pointer for Linux, speed gain of ~ 10% + * clean saved_gcl_pcl + + -- Camm Maguire Mon, 5 Aug 2002 16:34:33 -0400 + +gcl (2.5.0.cvs20020625-29) unstable; urgency=high + + * Back out of hppa assembler register flush for hppa, apparently issue + is cleared by long/object function declaration fix + * Remove ansi2knr.1 man page, Closes: #155067 + * hppa still has gc leak, possibly due to faulty setjmp. Try Lamont + Jones' latest assembler to flush regs + + -- Camm Maguire Fri, 2 Aug 2002 20:50:21 -0400 + +gcl (2.5.0.cvs20020625-28) unstable; urgency=high + + * SGC support for alpha + * generic gmp3 build for m68k + * compiler changes to declare all functions as returning object, with + functions that actually return long being cast appropriately + * back out of m68k hack in eval.c and funlink.c + + -- Camm Maguire Fri, 2 Aug 2002 18:22:04 -0400 + +gcl (2.5.0.cvs20020625-27) unstable; urgency=high + + * Use generic lshift.c in gmp3 for m68k + * use SGC for ia64 + * m68k workaround, cast (object(*)()) to (long(*)()) in funlink.c and + eval.c + * GBC register spiil asm for hppa + * fix hash_equal declaration error in hash.d + + -- Camm Maguire Thu, 1 Aug 2002 18:12:49 -0400 + +gcl (2.5.0.cvs20020625-26) unstable; urgency=high + + * Remove extra load of tkl.o in install target of main makefile + * gcc-3.1 for hppa + * Remove gcc version spec for m68k + * \-fPIC for hppa, needed for dlopen + * cleanup gcc 3.1 warning in funlink.c + * cc instead of ld for -shared linking in fasldlsym.c (needed for + hppa) + + -- Camm Maguire Wed, 31 Jul 2002 18:46:54 -0400 + +gcl (2.5.0.cvs20020625-25) unstable; urgency=high + + * Move chmod +x gmp3/* into debian/rules + * Remove gclm.bat from Debian package + * Build-Depend on autoconf, Closes: #154909 + + -- Camm Maguire Wed, 31 Jul 2002 09:44:20 -0400 + +gcl (2.5.0.cvs20020625-24) unstable; urgency=high + + * chmod +x gmp3/configure + + -- Camm Maguire Wed, 31 Jul 2002 07:55:17 -0400 + +gcl (2.5.0.cvs20020625-23) unstable; urgency=high + + * 64bit SGC support + * SGC on by default for sparc-linux and mips(el)-linux + * Optimized logxor funtion + * Check for MP_LIMB_SIZE in fasdump.c, for 64bit support + * gbc fix for ia64 + * gmp3 import for ia64 + * system bzero, bcmp, and bcopy function prototypes + + -- Camm Maguire Tue, 30 Jul 2002 23:11:58 -0400 + +gcl (2.5.0.cvs20020625-22) unstable; urgency=high + + * ElfW macros in rsym*.c for 64bit + * Allow for 8 byte gmp mp_limbs + + -- Camm Maguire Thu, 25 Jul 2002 18:52:37 -0400 + +gcl (2.5.0.cvs20020625-21) unstable; urgency=high + + * Support for dlopen object loading where bfd is not yet working -- + ./configure --enable-dlopen + + -- Camm Maguire Thu, 25 Jul 2002 15:08:05 -0400 + +gcl (2.5.0.cvs20020625-20) unstable; urgency=high + + * Cleanups for --disable-bfd option + + -- Camm Maguire Wed, 24 Jul 2002 15:05:28 -0400 + +gcl (2.5.0.cvs20020625-19) unstable; urgency=high + + * 64bit fixes + + -- Camm Maguire Wed, 24 Jul 2002 12:16:42 -0400 + +gcl (2.5.0.cvs20020625-18) unstable; urgency=high + + * misc. lintian cleanups, mostly for 64 bit + + -- Camm Maguire Tue, 23 Jul 2002 23:35:03 -0400 + +gcl (2.5.0.cvs20020625-17) unstable; urgency=high + + * Fixed typeo in error.c preventing arm compilation + + -- Camm Maguire Mon, 22 Jul 2002 17:18:18 -0400 + +gcl (2.5.0.cvs20020625-16) unstable; urgency=high + + * Fix bad on_stack_list_vector args + + -- Camm Maguire Mon, 22 Jul 2002 16:10:16 -0400 + +gcl (2.5.0.cvs20020625-15) unstable; urgency=high + + * More lint changes for sundry arches + * Fixed bug in Iapply_ap + + -- Camm Maguire Sat, 20 Jul 2002 23:40:33 -0400 + +gcl (2.5.0.cvs20020625-14) unstable; urgency=high + + * include stdarg.h when defining _GNU_SOURCE + + -- Camm Maguire Sat, 20 Jul 2002 18:47:43 -0400 + +gcl (2.5.0.cvs20020625-13) unstable; urgency=high + + * Proper va_dcl declarations + + -- Camm Maguire Sat, 20 Jul 2002 10:40:02 -0400 + +gcl (2.5.0.cvs20020625-12) unstable; urgency=high + + * cvs updates for missing ptrdiff_t + + -- Camm Maguire Sat, 20 Jul 2002 08:41:37 -0400 + +gcl (2.5.0.cvs20020625-11) unstable; urgency=high + + * cvs changes to compile cleanly with -Wall + + -- Camm Maguire Sat, 20 Jul 2002 02:59:33 -0400 + +gcl (2.5.0.cvs20020625-10) unstable; urgency=high + + * Architecture any, though still have some issues + + -- Camm Maguire Fri, 12 Jul 2002 19:02:09 -0400 + +gcl (2.5.0.cvs20020625-9) unstable; urgency=high + + * cvs commits for 64bit support + + -- Camm Maguire Fri, 12 Jul 2002 18:01:21 -0400 + +gcl (2.5.0.cvs20020625-8) unstable; urgency=high + + * NULL_OR_ON_C_STACK macro correction for m68k + + -- Camm Maguire Fri, 12 Jul 2002 14:37:48 -0400 + +gcl (2.5.0.cvs20020625-7) unstable; urgency=high + + * arm is bigendian + + -- Camm Maguire Wed, 10 Jul 2002 18:04:22 -0400 + +gcl (2.5.0.cvs20020625-6) unstable; urgency=high + + * cvs updates for arm build + + -- Camm Maguire Tue, 9 Jul 2002 16:09:26 -0400 + +gcl (2.5.0.cvs20020625-5) unstable; urgency=high + + * CC environment variable setting in debian/rules to aid in porting + * gcc 2.95 for m68k + + -- Camm Maguire Sat, 6 Jul 2002 23:00:23 -0400 + +gcl (2.5.0.cvs20020625-4) unstable; urgency=high + + * gcc 3.0 for arm + * cachectl header for m68k + + -- Camm Maguire Mon, 1 Jul 2002 15:47:53 -0400 + +gcl (2.5.0.cvs20020625-3) unstable; urgency=high + + * Better libbfd detection for arm/alpha + + -- Camm Maguire Wed, 26 Jun 2002 17:27:21 -0400 + +gcl (2.5.0.cvs20020625-2) unstable; urgency=high + + * s390 support + + -- Camm Maguire Tue, 25 Jun 2002 21:25:35 -0400 + +gcl (2.5.0.cvs20020625-1) unstable; urgency=high + + * CVS updates, new s390 arch + + -- Camm Maguire Tue, 25 Jun 2002 19:26:36 -0400 + +gcl (2.5.0.cvs20020610-2) unstable; urgency=high + + * cvs updates + + -- Camm Maguire Thu, 13 Jun 2002 08:42:32 -0400 + +gcl (2.5.0.cvs20020610-1) unstable; urgency=high + + * cvs updates + + -- Camm Maguire Wed, 12 Jun 2002 23:04:57 -0400 + +gcl (2.5.0.cvs20020523-2) unstable; urgency=high + + * configure updates for better tk detection + + -- Camm Maguire Fri, 24 May 2002 18:50:22 -0400 + +gcl (2.5.0.cvs20020523-1) unstable; urgency=high + + * New upstream release + + -- Camm Maguire Fri, 24 May 2002 18:50:22 -0400 + +gcl (2.5.0.cvs20020429-1) unstable; urgency=high + + * Build-Depend on tk8.2-dev, Closes: #144330 + * New cvs updates + * Added sparc to arch list, Closes: #143465 + + -- Camm Maguire Mon, 29 Apr 2002 23:07:36 -0400 + +gcl (2.5.0.cvs20020219-2) unstable; urgency=medium + + * flavor ->debian-emacs-flavor in emacsen-startup + + -- Camm Maguire Mon, 4 Mar 2002 14:29:59 -0500 + +gcl (2.5.0.cvs20020219-1) unstable; urgency=medium + + * Updated package descriptions, Closes: #134402 + * Static linking of libbfd, Closes: #134647 + * Gcl currently only available on i386, arm and m68k as specified in + the Architecture control field, Closes: #133912 + + -- Camm Maguire Tue, 19 Feb 2002 12:04:29 -0500 + +gcl (2.5.0.cvs-3) unstable; urgency=medium + + * Build-depend on texi2html, Closes: #133699 + + -- Camm Maguire Wed, 13 Feb 2002 16:22:35 -0500 + +gcl (2.5.0.cvs-2) unstable; urgency=medium + + * Put in versioned dependency on binutils for libbfd support, rebuilt + with latest binutils, Closes: #133004 + + -- Camm Maguire Tue, 12 Feb 2002 13:19:12 -0500 + +gcl (2.5.0.cvs-1) unstable; urgency=medium + + * Latest patches from CVS, enabling libbfd relocations, among other + things + * /etc/emacs/site-start.d/50gcl.el as conffile, Closes: #132137 + * limited arm and m68k support + + -- Camm Maguire Mon, 4 Feb 2002 09:32:29 -0500 + +gcl (2.5.0-1) unstable; urgency=medium + + * New maintainer + * New upstream release + * New release so far builds only on i386, Closes: #116070, Closes: + #123371 + * New release so far builds only on i386, Closes: #115041 + * Gcl must currently use its own copy of gmp, as the upstream version + of gmp uses malloc, which interferes with gcl's garbage collection + and relocation scheme. The change from malloc to alloca has been + suggested to upstream gmp developers. Closes: #108910 + * Tcl/Tk support now in. Closes: #113197 + + -- Camm Maguire Fri, 21 Dec 2001 00:03:43 -0500 + +gcl (2.4.0-3) unstable; urgency=medium + + * Make gcl use libgmp3 package. (closes: #108910) + * Remove tk support. (closes: #108909) + * Fix stupid missing dependency line. (closes: #108907, #108908) + * Removed readme.mingw from the debian package, this package is not compiled under + mingw (windows gcc port). + * Close ITA bug. (closes: #112312) + + -- Baruch Even Sat, 22 Sep 2001 00:27:14 +0300 + +gcl (2.4.0-2) unstable; urgency=low + + * Change tclsh Build-Depends to tcl8.0 because apt is broken. (closes: #99261) + + -- JP Sugarbroad Wed, 30 May 2001 14:34:53 -0500 + +gcl (2.4.0-1) unstable; urgency=low + + * New upstream release + + -- JP Sugarbroad Sun, 13 May 2001 20:31:01 -0500 + +gcl (2.3.7+beta3-3) unstable; urgency=low + + * Move gcl-doc to section doc (closes: #78666) + + -- JP Sugarbroad Sun, 13 May 2001 20:26:28 -0500 + +gcl (2.3.7+beta3-2) unstable; urgency=low + + * Remove alpha from arch list + * Move tcl/tk from Depends to Suggests + + -- JP Sugarbroad Fri, 4 May 2001 16:24:11 -0500 + +gcl (2.3.7+beta3-1) unstable; urgency=low + + * New maintainer + * Repackaged with debhelper (closes: #42045, #86097, #91475, #91478) + * New upstream release (closes: #59577, #71096) + * Added sparc+alpha, removed m68k (closes: #87407) + + -- JP Sugarbroad Mon, 30 Apr 2001 19:07:49 -0500 + +gcl (2.2.1-6) unstable; urgency=low + + * Disable stripping of "saved_gcl" binary. (#45778) + + -- Steve Dunham Fri, 24 Sep 1999 14:39:15 -0400 + +gcl (2.2.1-5) unstable; urgency=low + + * Fix m68k build + + -- Steve Dunham Tue, 6 Jul 1999 09:45:09 -0400 + +gcl (2.2.1-4) unstable; urgency=low + + * Fix bug #31718 + + -- Steve Dunham Fri, 2 Jul 1999 11:11:12 -0400 + +gcl (2.2.1-3) unstable; urgency=low + + * Add m68k patches + + -- Steve Dunham Wed, 16 Dec 1998 14:25:46 -0500 + +gcl (2.2.1-2) unstable; urgency=low + + * Compile against libc6. New maintainer. + + -- Steve Dunham Wed, 5 Nov 1997 10:09:12 -0500 + +gcl (2.2.1-1) unstable; urgency=low + + * New upstream release; suggests tcl76, tk42. + * gcl-doc contains gcl-si and gcl-tk info pages. + * debian/rules: clean target removes temporary files from h and o + subdirectories (bug #5984). + + -- Karl Sackett Fri, 3 Jan 1997 10:16:40 -0600 + +gcl (2.2-5) unstable; urgency=low + + * Converted package to 2.1.1.0 standard. + * Stripped gcltkaux (bug #5074). + * gcl-si and gcl-tk info pages converted to HTML. + + -- Karl Sackett Tue, 5 Nov 1996 13:30:30 -0600 + +2.2-4 + * add-defs: patched locates for tk.tcl, init.tcl + * gcl-tk/tkAppInit.c: patched for tk4.1 support + * gcl-tk/tkMain.c: patched for tk4.1 support +2.2-3 + * Debian support files now partily architecture independent. + There are, however, no add-defs files except for 386-linux. + * Rebuilt package to correct corrupted upload problem. +2.2-2 + * Removed tk support from distribution. This was written to + use tk-3.6 and doesn't support tk-4.0 or tk-4.1. I am not aware + of any plans to upgrade the code. (Closes bug #2865) +2.2-1 + * Added Debian support files + * h/386-linux.defs: set OFLAG = -O2 + * h/386-linux.h: undid patch that swaped signal.h for sigcontext.h diff --git a/debian/compat b/debian/compat new file mode 100644 index 0000000..7ed6ff8 --- /dev/null +++ b/debian/compat @@ -0,0 +1 @@ +5 diff --git a/debian/control b/debian/control new file mode 100644 index 0000000..7cf8eb6 --- /dev/null +++ b/debian/control @@ -0,0 +1,39 @@ +Source: gcl +Section: lisp +Priority: optional +Maintainer: Camm Maguire +Homepage: http://gnu.org/software/gcl +Build-Depends: debhelper (>= 5 ), libreadline-dev, m4, tk8.6-dev, libgmp-dev, autotools-dev, libxmu-dev, libxaw7-dev, po-debconf, zlib1g-dev +Standards-Version: 3.9.5 + +Package: gcl +Architecture: any +Depends: ${shlibs:Depends}, ${misc:Depends}, ${gcc}, debconf (>= 1.2.0), emacs24 | emacsen, ucf +Breaks: emacsen-common (<< 2.0.0) +Suggests: gcl-doc +Description: GNU Common Lisp compiler + GNU Common Lisp (GCL) is a Common Lisp compiler and interpreter + implemented in C, and complying mostly with the standard set + forth in the book "Common Lisp, the Language I". It attempts + to strike a useful middle ground in performance and portability + from its design around C. + . + This package contains the Lisp system itself. Documentation + is provided in the gcl-doc package. + +Package: gcl-doc +Section: doc +Architecture: all +Conflicts: gclinfo +Replaces: gclinfo +Depends: dpkg (>= 1.15.4) | install-info, ${misc:Depends} +Description: Documentation for GNU Common Lisp + GNU Common Lisp (GCL) is a Common Lisp compiler and interpreter + implemented in C, and complying mostly with the standard set + forth in the book "Common Lisp, the Language I". It attempts + to strike a useful middle ground in performance and portability + from its design around C. + . + This package contains Documentation in info format of both the + system internals, as well as the graphical interface currently + implemented in Tcl/Tk. diff --git a/debian/control. b/debian/control. new file mode 100644 index 0000000..7cf8eb6 --- /dev/null +++ b/debian/control. @@ -0,0 +1,39 @@ +Source: gcl +Section: lisp +Priority: optional +Maintainer: Camm Maguire +Homepage: http://gnu.org/software/gcl +Build-Depends: debhelper (>= 5 ), libreadline-dev, m4, tk8.6-dev, libgmp-dev, autotools-dev, libxmu-dev, libxaw7-dev, po-debconf, zlib1g-dev +Standards-Version: 3.9.5 + +Package: gcl +Architecture: any +Depends: ${shlibs:Depends}, ${misc:Depends}, ${gcc}, debconf (>= 1.2.0), emacs24 | emacsen, ucf +Breaks: emacsen-common (<< 2.0.0) +Suggests: gcl-doc +Description: GNU Common Lisp compiler + GNU Common Lisp (GCL) is a Common Lisp compiler and interpreter + implemented in C, and complying mostly with the standard set + forth in the book "Common Lisp, the Language I". It attempts + to strike a useful middle ground in performance and portability + from its design around C. + . + This package contains the Lisp system itself. Documentation + is provided in the gcl-doc package. + +Package: gcl-doc +Section: doc +Architecture: all +Conflicts: gclinfo +Replaces: gclinfo +Depends: dpkg (>= 1.15.4) | install-info, ${misc:Depends} +Description: Documentation for GNU Common Lisp + GNU Common Lisp (GCL) is a Common Lisp compiler and interpreter + implemented in C, and complying mostly with the standard set + forth in the book "Common Lisp, the Language I". It attempts + to strike a useful middle ground in performance and portability + from its design around C. + . + This package contains Documentation in info format of both the + system internals, as well as the graphical interface currently + implemented in Tcl/Tk. diff --git a/debian/control.cvs b/debian/control.cvs new file mode 100644 index 0000000..9b44298 --- /dev/null +++ b/debian/control.cvs @@ -0,0 +1,39 @@ +Source: gclcvs +Section: lisp +Priority: optional +Maintainer: Camm Maguire +Homepage: http://gnu.org/software/gcl +Build-Depends: debhelper (>= 5 ), libreadline-dev, m4, tk8.6-dev, libgmp-dev, autotools-dev, libxmu-dev, libxaw7-dev, po-debconf, zlib1g-dev +Standards-Version: 3.9.5 + +Package: gclcvs +Architecture: any +Depends: ${shlibs:Depends}, ${misc:Depends}, ${gcc}, debconf (>= 1.2.0), emacs24 | emacsen, ucf +Breaks: emacsen-common (<< 2.0.0) +Suggests: gclcvs-doc +Description: GNU Common Lisp compiler, CVS snapshot + GNU Common Lisp (GCL) is a Common Lisp compiler and interpreter + implemented in C, and complying mostly with the standard set + forth in the book "Common Lisp, the Language I". It attempts + to strike a useful middle ground in performance and portability + from its design around C. + . + This package contains the Lisp system itself. Documentation + is provided in the gclcvs-doc package. + +Package: gclcvs-doc +Section: doc +Architecture: all +Conflicts: gclinfo +Replaces: gclinfo +Depends: dpkg (>= 1.15.4) | install-info, ${misc:Depends} +Description: Documentation for GNU Common Lisp, CVS snapshot + GNU Common Lisp (GCL) is a Common Lisp compiler and interpreter + implemented in C, and complying mostly with the standard set + forth in the book "Common Lisp, the Language I". It attempts + to strike a useful middle ground in performance and portability + from its design around C. + . + This package contains Documentation in info format of both the + system internals, as well as the graphical interface currently + implemented in Tcl/Tk. diff --git a/debian/copyright b/debian/copyright new file mode 100644 index 0000000..c58a983 --- /dev/null +++ b/debian/copyright @@ -0,0 +1,65 @@ +This package was debianized by JP Sugarbroad on +Mon, 30 Apr 2001 19:07:49 -0500. + +It was downloaded from http://savannah.gnu.org/projects/gcl + +Upstream Author: Bill Schelter + +Copyright: + + This package is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + This package is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this package; if not, write to the Free + Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA + 02110-1301, USA. + +On Debian GNU/Linux systems, the complete text of the GNU Lesser General +Public License can be found in `/usr/share/common-licenses/LGPL-2'. + +The source under xgcl-2 is + +Copyright (c) 1995 Gordon S. Novak Jr., Hiep Huu Nguyen, William F. Schelter, +and The University of Texas at Austin. + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 1, or (at your option) +any later version. + +and + +;;********************************************************** +;;Copyright 1987 by Digital Equipment Corporation, Maynard, Massachusetts, +;;and the Massachusetts Institute of Technology, Cambridge, Massachusetts. + +;; All Rights Reserved + +;;Permission to use, copy, modify, and distribute this software and its +;;documentation for any purpose and without fee is hereby granted, +;;provided that the above copyright notice appear in all copies and that +;;both that copyright notice and this permission notice appear in +;;supporting documentation, and that the names of Digital or MIT not be +;;used in advertising or publicity pertaining to distribution of the +;;software without specific, written prior permission. + +;;DIGITAL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING +;;ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL +;;DIGITAL BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR +;;ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, +;;WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, +;;ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS +;;SOFTWARE. + +;;***************************************************************** + +On Debian GNU/Linux systems, the complete text of the GNU General +Public License can be found in `/usr/share/common-licenses/GPL-1'. diff --git a/debian/gcl.lintian-overrides b/debian/gcl.lintian-overrides new file mode 100644 index 0000000..df94ce9 --- /dev/null +++ b/debian/gcl.lintian-overrides @@ -0,0 +1,2 @@ +gcl: unstripped-binary-or-object +gcl: binary-compiled-with-profiling-enabled diff --git a/debian/gcl.sh b/debian/gcl.sh new file mode 100755 index 0000000..9ea8018 --- /dev/null +++ b/debian/gcl.sh @@ -0,0 +1,28 @@ +#!/bin/sh + +EXT=@EXT@ +VERS=@VERS@ + +. /etc/default/gcl$EXT +if ! set | grep -q -w GCL_ANSI ; then GCL_ANSI=$DEFAULT_GCL_ANSI ; fi +if ! set | grep -q -w GCL_PROF ; then GCL_PROF=$DEFAULT_GCL_PROF ; fi + +if [ "$GCL_PROF" = "" ] ; then + DIR=/usr/lib/gcl-$VERS ; +else + DIR=/usr/lib/gcl-$VERS-prof ; +fi + +if [ "$GCL_ANSI" = "" ] ; then + EXE=saved_gcl; +else + EXE=saved_ansi_gcl; +fi +SYS=$DIR/unixport + +exec $SYS/$EXE -dir $SYS/ -libdir $DIR/ \ + -eval '(setq si::*allow-gzipped-file* t)' \ + -eval '(setq si::*tk-library* "/usr/lib/tk@TKVERS@")' \ + "$@" + +# other options: -load /tmp/foo.o -load jo.lsp -eval "(joe 3)" diff --git a/debian/gcl.templates b/debian/gcl.templates new file mode 100644 index 0000000..3bc069d --- /dev/null +++ b/debian/gcl.templates @@ -0,0 +1,38 @@ +# These templates have been reviewed by the debian-l10n-english +# team +# +# If modifications/additions/rewording are needed, please ask +# debian-l10n-english@lists.debian.org for advice. +# +# Even minor modifications require translation updates and such +# changes should be coordinated with translators and reviewers. + +Template: gcl@EXT@/default_gcl_ansi +Type: boolean +_Description: Use the work-in-progress ANSI build by default? + GCL is in the process of providing an ANSI compliant image in addition to + its traditional CLtL1 image still in production use. + . + Please see the README.Debian file for a brief description of these terms. + Choosing this option will determine which image will be used by default + when executing 'gcl@EXT@'. + . + This setting may be overridden by setting the GCL_ANSI + environment variable to any non-empty string for the ANSI build, and to + the empty string for the CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The + currently enforced build flavor will be reported in the initial startup + banner. + +Template: gcl@EXT@/default_gcl_prof +Type: boolean +_Description: Use the profiling build by default? + GCL has optional support for profiling via gprof. + . + Please see the documentation for si::gprof-start and si::gprof-quit + for details. As this build is slower than builds without gprof + support, it is not recommended for final production use. + . + Set the GCL_PROF environment variable to the empty string for more + optimized builds, or any non-empty string for profiling support; e.g. + GCL_PROF=t gcl@EXT@. If profiling is enabled, this will be reported + in the initial startup banner. diff --git a/debian/in.gcl-doc.README.Debian b/debian/in.gcl-doc.README.Debian new file mode 100644 index 0000000..b8d01a6 --- /dev/null +++ b/debian/in.gcl-doc.README.Debian @@ -0,0 +1,9 @@ +New in 2.6.2 +------------ + +The gcl.texi files and the resulting html, info, and pdf outputs have +been removed pending an enquiry into the copyright and license status +of the dpANS documents upon which they are presumably based. + + + -- Camm Maguire , Fri, 9 May 2014 19:08:59 +0000 diff --git a/debian/in.gcl-doc.doc-base.si b/debian/in.gcl-doc.doc-base.si new file mode 100644 index 0000000..faa0bc6 --- /dev/null +++ b/debian/in.gcl-doc.doc-base.si @@ -0,0 +1,12 @@ +Document: gcl@EXT@-si-doc +Title: GNU Common Lisp Documentation -- System Internals +Author: W. Schelter +Abstract: Documentation on GCL-specific Lisp system functions +Section: Programming + +Format: PDF +Files: /usr/share/doc/gcl@EXT@-doc/gcl-si*.pdf.gz /usr/share/doc/gcl@EXT@-doc/gcl-si*.pdf.gz + +Format: HTML +Index: /usr/share/doc/gcl@EXT@-doc/gcl-si/index.html +Files: /usr/share/doc/gcl@EXT@-doc/gcl-si/*.html diff --git a/debian/in.gcl-doc.doc-base.tk b/debian/in.gcl-doc.doc-base.tk new file mode 100644 index 0000000..23d74ee --- /dev/null +++ b/debian/in.gcl-doc.doc-base.tk @@ -0,0 +1,12 @@ +Document: gcl@EXT@-tk-doc +Title: GNU Common Lisp Tk Interface Documentation +Author: W. Schelter +Abstract: Documentation for Graphical Interface to GCL using TCL/Tk +Section: Programming + +Format: PDF +Files: /usr/share/doc/gcl@EXT@-doc/gcl-tk*.pdf.gz /usr/share/doc/gcl@EXT@-doc/gcl-tk*.pdf.gz + +Format: HTML +Index: /usr/share/doc/gcl@EXT@-doc/gcl-tk/index.html +Files: /usr/share/doc/gcl@EXT@-doc/gcl-tk/*.html diff --git a/debian/in.gcl-doc.doc-base.xgcl b/debian/in.gcl-doc.doc-base.xgcl new file mode 100644 index 0000000..a78b27b --- /dev/null +++ b/debian/in.gcl-doc.doc-base.xgcl @@ -0,0 +1,15 @@ +Document: gcl@EXT@-xgcl-doc +Title: GNU Common Lisp Documentation -- System Internals +Author: W. Schelter +Abstract: Documentation on GCL-specific Lisp system functions +Section: Programming + +Format: Text +Files: /usr/share/doc/gcl@EXT@-doc/dwdoc.tex.gz + +Format: PDF +Files: /usr/share/doc/gcl@EXT@-doc/dwdoc.pdf.gz + +Format: HTML +Index: /usr/share/doc/gcl@EXT@-doc/dwdoc/dwdoc1.html +Files: /usr/share/doc/gcl@EXT@-doc/dwdoc/*.html diff --git a/debian/in.gcl-doc.docs b/debian/in.gcl-doc.docs new file mode 100644 index 0000000..2757ff2 --- /dev/null +++ b/debian/in.gcl-doc.docs @@ -0,0 +1,3 @@ +faq +readme +readme.xgcl diff --git a/debian/in.gcl-doc.info b/debian/in.gcl-doc.info new file mode 100644 index 0000000..cedf3f1 --- /dev/null +++ b/debian/in.gcl-doc.info @@ -0,0 +1,4 @@ +debian/tmp/usr/share/info/gcl@EXT@-si.info +debian/tmp/usr/share/info/gcl@EXT@-tk.info +debian/tmp/usr/share/info/gcl@EXT@-tk.info-1 +debian/tmp/usr/share/info/gcl@EXT@-tk.info-2 diff --git a/debian/in.gcl-doc.install b/debian/in.gcl-doc.install new file mode 100644 index 0000000..8e31d17 --- /dev/null +++ b/debian/in.gcl-doc.install @@ -0,0 +1 @@ +debian/tmp/usr/share/doc/gcl@EXT@-doc diff --git a/debian/in.gcl.config b/debian/in.gcl.config new file mode 100644 index 0000000..0d960b1 --- /dev/null +++ b/debian/in.gcl.config @@ -0,0 +1,19 @@ +#!/bin/sh +CONFIGFILE=/etc/default/gcl@EXT@ +set -e +. /usr/share/debconf/confmodule + +# Load config file, if it exists. +if [ -e $CONFIGFILE ]; then + . $CONFIGFILE || true + + # Store values from config file into + # debconf db. + db_set gcl@EXT@/default_gcl_ansi $DEFAULT_GCL_ANSI + db_set gcl@EXT@/default_gcl_prof $DEFAULT_GCL_PROF +fi + +# Ask questions. +db_input medium gcl@EXT@/default_gcl_ansi || true +db_input medium gcl@EXT@/default_gcl_prof || true +db_go || true diff --git a/debian/in.gcl.docs b/debian/in.gcl.docs new file mode 100644 index 0000000..b50c945 --- /dev/null +++ b/debian/in.gcl.docs @@ -0,0 +1,2 @@ +ansi-tests/test_results +RELEASE-2.6.2.html diff --git a/debian/in.gcl.emacsen-compat b/debian/in.gcl.emacsen-compat new file mode 100644 index 0000000..573541a --- /dev/null +++ b/debian/in.gcl.emacsen-compat @@ -0,0 +1 @@ +0 diff --git a/debian/in.gcl.emacsen-install b/debian/in.gcl.emacsen-install new file mode 100644 index 0000000..ed97209 --- /dev/null +++ b/debian/in.gcl.emacsen-install @@ -0,0 +1,46 @@ +#! /bin/sh -e +# /usr/lib/emacsen-common/packages/install/#PACKAGE# + +# Written by Jim Van Zandt , borrowing heavily +# from the install scripts for gettext by Santiago Vila +# and octave by Dirk Eddelbuettel . + +FLAVOR=$1 +PACKAGE=gcl@EXT@ + +if [ ${FLAVOR} = emacs ]; then exit 0; fi + +echo install/${PACKAGE}: Handling install for emacsen flavor ${FLAVOR} + +#FLAVORTEST=`echo $FLAVOR | cut -c-6` +#if [ ${FLAVORTEST} = xemacs ] ; then +# SITEFLAG="-no-site-file" +#else +# SITEFLAG="--no-site-file" +#fi +FLAGS="${SITEFLAG} -q -batch -l path.el -f batch-byte-compile" + +ELDIR=/usr/share/emacs/site-lisp/${PACKAGE} +ELCDIR=/usr/share/${FLAVOR}/site-lisp/${PACKAGE} + +# Install-info-altdir does not actually exist. +# Maybe somebody will write it. +if test -x /usr/sbin/install-info-altdir; then + echo install/${PACKAGE}: install Info links for ${FLAVOR} + install-info-altdir --quiet --section "" "" --dirname=${FLAVOR} /usr/info/${PACKAGE}.info.gz +fi + +install -m 755 -d ${ELCDIR} +cd ${ELDIR} +FILES=`echo *.el` +cp ${FILES} ${ELCDIR} +cd ${ELCDIR} + +cat << EOF > path.el +(setq load-path (cons "." load-path) byte-compile-warnings nil) +EOF +${FLAVOR} ${FLAGS} ${FILES} +rm -f *.el path.el + +exit 0 + diff --git a/debian/in.gcl.emacsen-remove b/debian/in.gcl.emacsen-remove new file mode 100644 index 0000000..699eca1 --- /dev/null +++ b/debian/in.gcl.emacsen-remove @@ -0,0 +1,15 @@ +#!/bin/sh -e +# /usr/lib/emacsen-common/packages/remove/#PACKAGE# + +FLAVOR=$1 +PACKAGE=gcl@EXT@ + +if [ ${FLAVOR} != emacs ]; then + if test -x /usr/sbin/install-info-altdir; then + echo remove/${PACKAGE}: removing Info links for ${FLAVOR} + install-info-altdir --quiet --remove --dirname=${FLAVOR} /usr/info/#PACKAGE#.info.gz + fi + + echo remove/${PACKAGE}: purging byte-compiled files for ${FLAVOR} + rm -rf /usr/share/${FLAVOR}/site-lisp/${PACKAGE} +fi diff --git a/debian/in.gcl.emacsen-startup b/debian/in.gcl.emacsen-startup new file mode 100644 index 0000000..e64d9a8 --- /dev/null +++ b/debian/in.gcl.emacsen-startup @@ -0,0 +1,19 @@ +;; -*-emacs-lisp-*- +;; +;; Emacs startup file for the Debian GNU/Linux #PACKAGE# package +;; +;; Originally contributed by Nils Naumann +;; Modified by Dirk Eddelbuettel +;; Adapted for dh-make by Jim Van Zandt + +;; The #PACKAGE# package follows the Debian/GNU Linux 'emacsen' policy and +;; byte-compiles its elisp files for each 'emacs flavor' (emacs19, +;; xemacs19, emacs20, xemacs20...). The compiled code is then +;; installed in a subdirectory of the respective site-lisp directory. +;; We have to add this to the load-path: +(setq load-path (cons (concat "/usr/share/" + (symbol-name debian-emacs-flavor) + "/site-lisp/gcl@EXT@") load-path)) + +(autoload 'run@EXT@ "gcl@EXT@" "" t) +(autoload 'dbl@EXT@ "dbl@EXT@" "" t) diff --git a/debian/in.gcl.install b/debian/in.gcl.install new file mode 100644 index 0000000..731600b --- /dev/null +++ b/debian/in.gcl.install @@ -0,0 +1,3 @@ +debian/tmp/usr/lib +debian/tmp/usr/bin +debian/tmp/usr/share/emacs diff --git a/debian/in.gcl.manpages b/debian/in.gcl.manpages new file mode 100644 index 0000000..0b22534 --- /dev/null +++ b/debian/in.gcl.manpages @@ -0,0 +1 @@ +debian/tmp/usr/share/man/man1/gcl@EXT@.1 diff --git a/debian/in.gcl.postinst b/debian/in.gcl.postinst new file mode 100644 index 0000000..c787588 --- /dev/null +++ b/debian/in.gcl.postinst @@ -0,0 +1,40 @@ +#!/bin/sh +case "$1" in + configure) + + CONFIGFILE=$(tempfile -m 644) + set -e + . /usr/share/debconf/confmodule + + if [ "$1" = "configure" ] || [ "$1" = "reconfigure" ] ; then + + db_get gcl@EXT@/default_gcl_ansi + + if [ "$RET" = "true" ] ; then + DEFAULT_GCL_ANSI=t + else + DEFAULT_GCL_ANSI= + fi + + db_get gcl@EXT@/default_gcl_prof + + if [ "$RET" = "true" ] ; then + DEFAULT_GCL_PROF=y + else + DEFAULT_GCL_PROF= + fi + + echo "DEFAULT_GCL_ANSI=$DEFAULT_GCL_ANSI" >> $CONFIGFILE + echo "DEFAULT_GCL_PROF=$DEFAULT_GCL_PROF" >> $CONFIGFILE + + fi + + ucf --debconf-ok $CONFIGFILE /etc/default/gcl@EXT@ + ucfr gcl@EXT@ /etc/default/gcl@EXT@ + +# chmod 644 /etc/default/gcl@EXT@ + +esac + +#DEBHELPER# + diff --git a/debian/in.gcl.postrm b/debian/in.gcl.postrm new file mode 100644 index 0000000..a36b240 --- /dev/null +++ b/debian/in.gcl.postrm @@ -0,0 +1,18 @@ +case "$1" in + purge) + for ext in '~' '%' .bak .ucf-new .ucf-old .ucf-dist; do + rm -f /etc/default/gcl@EXT@$ext + done + + rm -f /etc/default/gcl@EXT@ + + if which ucf >/dev/null; then + ucf --purge /etc/default/gcl@EXT@ + fi + if which ucfr >/dev/null; then + ucfr --purge gcl@EXT@ /etc/default/gcl@EXT@ + fi + ;; +esac + +#DEBHELPER# diff --git a/debian/old.in.gcl-doc.doc-base.main b/debian/old.in.gcl-doc.doc-base.main new file mode 100644 index 0000000..2d6f3d1 --- /dev/null +++ b/debian/old.in.gcl-doc.doc-base.main @@ -0,0 +1,12 @@ +Document: gcl@EXT@-doc +Title: GNU Common Lisp Documentation +Author: W. Schelter +Abstract: A Common Lisp compiler and interpreter based on C +Section: Apps/Programming + +Format: DVI +Files: /usr/share/doc/gcl@EXT@-doc/gcl.dvi.gz /usr/share/doc/gcl@EXT@-doc/gcl.dvi + +Format: HTML +Index: /usr/share/doc/gcl@EXT@-doc/gcl/index.html +Files: /usr/share/doc/gcl@EXT@-doc/gcl/*.html diff --git a/debian/po/POTFILES.in b/debian/po/POTFILES.in new file mode 100644 index 0000000..3f9d3e6 --- /dev/null +++ b/debian/po/POTFILES.in @@ -0,0 +1 @@ +[type: gettext/rfc822deb] gcl.templates diff --git a/debian/po/cs.po b/debian/po/cs.po new file mode 100644 index 0000000..98002a1 --- /dev/null +++ b/debian/po/cs.po @@ -0,0 +1,139 @@ +# +# Translators, if you are not familiar with the PO format, gettext +# documentation is worth reading, especially sections dedicated to +# this format, e.g. by running: +# info -n '(gettext)PO Files' +# info -n '(gettext)Header Entry' +# +# Some information specific to po-debconf are available at +# /usr/share/doc/po-debconf/README-trans +# or http://www.debian.org/intl/l10n/po-debconf/README-trans +# +# Developers do not need to manually edit POT or PO files. +# +msgid "" +msgstr "" +"Project-Id-Version: gcl\n" +"Report-Msgid-Bugs-To: gcl@packages.debian.org\n" +"POT-Creation-Date: 2012-12-30 11:53-0400\n" +"PO-Revision-Date: 2007-12-24 13:21+0100\n" +"Last-Translator: Miroslav Kure \n" +"Language-Team: Czech \n" +"Language: cs\n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=UTF-8\n" +"Content-Transfer-Encoding: 8bit\n" + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "Use the work-in-progress ANSI build by default?" +msgstr "Používat implicitně ANSI verzi (stále ve vývoji)?" + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"GCL is in the process of providing an ANSI compliant image in addition to " +"its traditional CLtL1 image still in production use." +msgstr "" +"GCL se nachází ve fázi, kdy kromě tradičního obrazu CLtL1 (který se stále " +"používá) poskytuje i obraz kompatibilní s ANSI." + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"Please see the README.Debian file for a brief description of these terms. " +"Choosing this option will determine which image will be used by default when " +"executing 'gcl@EXT@'." +msgstr "" +"Pro stručný popis těchto termínů si prosím přečtěte soubor README.Debian. " +"Touto odpovědí určujete, který obraz se spustí po zadání „gcl@EXT@“. " + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"This setting may be overridden by setting the GCL_ANSI environment variable " +"to any non-empty string for the ANSI build, and to the empty string for the " +"CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " +"will be reported in the initial startup banner." +msgstr "" +"Toto nastavení můžete přebít nastavením proměnné prostředí GCL_ANSI na " +"neprázdný řetězec (použije ANSI verzi) nebo na prázdnou hodnotu (použije " +"CLtL1 verzi). Například GCL_ANSI=t gcl@EXT@. Aktuálně použitá verze se " +"zobrazí na úvodní obrazovce." + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "Use the profiling build by default?" +msgstr "Používat implicitně profilování?" + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "GCL has optional support for profiling via gprof." +msgstr "GCL nyní podporuje profilování přes gprof." + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "" +"Please see the documentation for si::gprof-start and si::gprof-quit for " +"details. As this build is slower than builds without gprof support, it is " +"not recommended for final production use." +msgstr "" +"Podrobnosti naleznete v dokumentaci si::gprof-start a si::gprof-quit. Tato " +"verze je pomalejší než verze bez podpory gprof, tudíž ji nedoporučujeme pro " +"koncové produkční nasazení." + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "" +"Set the GCL_PROF environment variable to the empty string for more optimized " +"builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " +"gcl@EXT@. If profiling is enabled, this will be reported in the initial " +"startup banner." +msgstr "" +"Toto nastavení můžete přebít nastavením proměnné prostředí GCL_PROF na " +"neprázdný řetězec (zapne profilování) nebo na prázdnou hodnotu (povolí lepší " +"optimalizace). Například GCL_PROF=t gcl@EXT@. Pokud je profilování zapnuto, " +"dozvíte se o tom z úvodní obrazovky." + +#~ msgid "" +#~ "GCL is one of the oldest free common lisp systems still in use. Several " +#~ "production systems have used it for over a decade. The common lisp " +#~ "standard in effect when GCL was first released is known as \"Common Lisp, " +#~ "the Language\" (CLtL1) after a book by Steele of the same name providing " +#~ "this specification. Subsequently, a much expanded standard was adopted " +#~ "by the American National Standards Institute (ANSI), which is still " +#~ "considered the definitive common lisp language specification to this " +#~ "day. GCL is in the process of providing an ANSI compliant image in " +#~ "addition to its traditional CLtL1 image still in production use. Setting " +#~ "this variable will determine which image you will use by default on " +#~ "executing 'gcl'. You can locally override this choice by setting the " +#~ "GCL_ANSI environment variable to any non-empty string for the ANSI build, " +#~ "and to the empty string for the CLtL1 build, e.g. GCL_ANSI=t gcl. You " +#~ "may be interested in reviewing the ANSI test results sketching the level " +#~ "of compliance achieved thus far in /usr/share/doc/gcl/test_results.gz. " +#~ "The flavor of the build in force will be reported in the initial startup " +#~ "banner." +#~ msgstr "" +#~ "GCL je jedním z nejstarších svobodných systémů common lispu, který se " +#~ "dosud používá. Několik produkčních systémů jej používá déle než dekádu. " +#~ "Při prvním vydání GCL byl v platnosti standard common lispu známý jako " +#~ "\"Common Lisp, the Language\" (CLtL1) pojmenovaný podle Steelovy knihy " +#~ "stejného jména, která tento standard definovala. Americkým národním " +#~ "institutem pro standardizaci (ANSI) pak byl přijat podstatně rozšířený " +#~ "standard, který se do dneÅ¡ní doby považuje za konečnou specifikaci common " +#~ "lispu. Kromě tradičního CLtL1 se GCL snaží nabídnout i verzi odpovídající " +#~ "ANSI standardu. Nastavením této proměnné určíte, jakým způsobem se má " +#~ "binárka 'gcl' chovat. Lokálně můžete toto nastavení přepsat nastavením " +#~ "proměnné prostředí GCL_ANSI na neprázdný řetězec (zapne ANSI chování) " +#~ "nebo na prázdnou hodnotu (zapne CLtL1 chování). Například GCL_ANSI-t gcl. " +#~ "Aktuálně vybraný standard bude zobrazen v úvodní obrazovce prostředí. " +#~ "Zajímavé může být porovnání dosud dosažené shody s ANSI standardem v " +#~ "souboru /usr/share/doc/gcl/test_results.gz." diff --git a/debian/po/da.po b/debian/po/da.po new file mode 100644 index 0000000..11d3fc6 --- /dev/null +++ b/debian/po/da.po @@ -0,0 +1,97 @@ +# Danish translation gcl. +# Copyright (C) 2012 gcl & nedenstÃ¥ende oversættere. +# This file is distributed under the same license as the gcl package. +# Joe Hansen (joedalton2@yahoo.dk), 2012. +# +msgid "" +msgstr "" +"Project-Id-Version: gcl\n" +"Report-Msgid-Bugs-To: gcl@packages.debian.org\n" +"POT-Creation-Date: 2012-12-30 11:53-0400\n" +"PO-Revision-Date: 2012-03-31 12:42+0000\n" +"Last-Translator: Joe Hansen \n" +"Language-Team: Danish \n" +"Language: da\n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=UTF-8\n" +"Content-Transfer-Encoding: 8bit\n" + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "Use the work-in-progress ANSI build by default?" +msgstr "Brug den foreløbige ANSI bygget som standard?" + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"GCL is in the process of providing an ANSI compliant image in addition to " +"its traditional CLtL1 image still in production use." +msgstr "" +"GCL er i gang med at tilbyde et ANSI-overholdende aftryk udover det " +"traditionelle CLtL1-aftryk som stadig er i produktionsbrug." + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"Please see the README.Debian file for a brief description of these terms. " +"Choosing this option will determine which image will be used by default when " +"executing 'gcl@EXT@'." +msgstr "" +"Se venligst filen README.Debian for en kort beskrivelse af disse termer. " +"Valg af denne indstilling vil bestemme hvilket aftryk som vil blive brugt " +"som standard, nÃ¥r der køres »gcl@EXT@«." + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"This setting may be overridden by setting the GCL_ANSI environment variable " +"to any non-empty string for the ANSI build, and to the empty string for the " +"CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " +"will be reported in the initial startup banner." +msgstr "" +"Denne indstilling kan overskrives ved at angive miljøvariablen GCL_ANSI til " +"enhver streng der ikke er tom for ANSI-bygningen, og til den tomme streng " +"for CLtL1-bygningen, f.eks. GCL_ANSI=t gcl@EXT@. Den aktuelt tvungne " +"byggevariant vil blive rapporteret i det oprindelige opstartsbanner." + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "Use the profiling build by default?" +msgstr "Brug profileringen bygget som standard?" + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "GCL has optional support for profiling via gprof." +msgstr "GCL har valgfri understøttelse for profilering via gprof." + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "" +"Please see the documentation for si::gprof-start and si::gprof-quit for " +"details. As this build is slower than builds without gprof support, it is " +"not recommended for final production use." +msgstr "" +"Se venligst dokumentationen for si::gprof-start og si::gprof-quit for " +"detaljer. Da denne bygning er langsommere end bygninger uden gprof-" +"understøttelse, sÃ¥ anbefales den ikke for endelig produktionsbrug." + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "" +"Set the GCL_PROF environment variable to the empty string for more optimized " +"builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " +"gcl@EXT@. If profiling is enabled, this will be reported in the initial " +"startup banner." +msgstr "" +"Angiv miljøvariablen GCL_PROF til den tomme streng for bedre optimerede " +"bygninger, eller enhver streng der ikke er tom for " +"profileringsunderstøttelse; f.eks. GCL_PROF=t gcl@EXT@. Hvis profilering er " +"aktiveret, vil denne blive rapporteret i det oprindelige opstartsbanner." diff --git a/debian/po/de.po b/debian/po/de.po new file mode 100644 index 0000000..e8b0ff3 --- /dev/null +++ b/debian/po/de.po @@ -0,0 +1,139 @@ +# Translation of gcl debconf templates to German +# Copyright (C) Stefan Bauer , 2007. +# Copyright (C) Helge Kreutzmann , 2007, 2008. +# This file is distributed under the same license as the gcl package. +# +msgid "" +msgstr "" +"Project-Id-Version: gcl 2.6.7-36\n" +"Report-Msgid-Bugs-To: gcl@packages.debian.org\n" +"POT-Creation-Date: 2012-12-30 11:53-0400\n" +"PO-Revision-Date: 2008-01-09 11:49+0100\n" +"Last-Translator: Stefan Bauer \n" +"Language-Team: de \n" +"Language: \n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=ISO-8859-15\n" +"Content-Transfer-Encoding: 8bit\n" + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "Use the work-in-progress ANSI build by default?" +msgstr "Verwende standardmäßig den sich in Arbeit befindlichen ANSI-Build?" + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"GCL is in the process of providing an ANSI compliant image in addition to " +"its traditional CLtL1 image still in production use." +msgstr "" +"GCL ist derzeit dabei, zusätzlich zu dem noch im Einsatz befindlichen " +"traditionellen CLtL1-Image ein ANSI-konformes Image bereitzustellen." + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"Please see the README.Debian file for a brief description of these terms. " +"Choosing this option will determine which image will be used by default when " +"executing 'gcl@EXT@'." +msgstr "" +"Bitte lesen Sie die Datei README.Debian für eine kurze Beschreibung dieser " +"Begriffe. Die Wahl dieser Option bestimmen, welches Image standardmäßig " +"verwendet wird, wenn »gcl@EXT@« ausgeführt wird." + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"This setting may be overridden by setting the GCL_ANSI environment variable " +"to any non-empty string for the ANSI build, and to the empty string for the " +"CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " +"will be reported in the initial startup banner." +msgstr "" +"Diese Einstellung kann mit der Umgebungsvariablen GCL_ANSI überschrieben " +"werden. Jede nicht-leere Zeichenkette führt zur ANSI-Erstellung, und die " +"leere Zeichenkette führt zum CLtL1-Bau, z.B. GCL_ANSI=t gcl@EXT@. In der " +"Startmeldung wird die derzeit erzwungene Bauart berichtet." + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "Use the profiling build by default?" +msgstr "Verwende standardmäßig den Profiling-Build?" + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "GCL has optional support for profiling via gprof." +msgstr "GCL besitzt optionale Unterstützung für Profiling mittels Gprof." + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "" +"Please see the documentation for si::gprof-start and si::gprof-quit for " +"details. As this build is slower than builds without gprof support, it is " +"not recommended for final production use." +msgstr "" +"Bitte lesen Sie die Dokumentation für si::gprof-start und si::gprof-quit für " +"Details. Da ein solches Programm langsamer ist als ein Programm ohne Gprof-" +"Unterstützung, wird dies für den Produktiveinsatz nicht empfohlen." + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "" +"Set the GCL_PROF environment variable to the empty string for more optimized " +"builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " +"gcl@EXT@. If profiling is enabled, this will be reported in the initial " +"startup banner." +msgstr "" +"Setzen Sie die Umgebungsvariable GCL_PROF auf die leere Zeichenkette, um ein " +"optimiertes Programm zu erhalten oder auf irgendeine nicht-leere " +"Zeichenkette, für Profiling-Unterstützung; z.B. GCL_PROF=t gcl@EXT@. Falls " +"Profiling aktiviert ist, wird dies in der Startmeldung angezeigt." + +#~ msgid "" +#~ "GCL is in the process of providing an ANSI compliant image in addition to " +#~ "its traditional CLtL1 image still in production use. Please see the " +#~ "README.Debian file for a brief description of these terms. Setting this " +#~ "variable will determine which image you will use by default on executing " +#~ "'gcl@EXT@'. You can locally override this choice by setting the GCL_ANSI " +#~ "environment variable to any non-empty string for the ANSI build, and to " +#~ "the empty string for the CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The " +#~ "flavor of the build in force will be reported in the initial startup " +#~ "banner." +#~ msgstr "" +#~ "GCL arbeitet neben dem traditionellen CLtL1-Image für den " +#~ "Produktiveinsatz zusätzlich an der Bereitstellung eines kompatiblen ANSI-" +#~ "Images. Bitte beachten Sie die README.Debian-Datei für eine kurze " +#~ "Beschreibung dieses Themas. Durch diese Variable definieren Sie, welches " +#~ "Image voreingestellt bei der Ausführung von »gcl@EXT@« verwendet wird. " +#~ "Diese Auswahl kann lokal, durch einen nicht leeren Wert in der " +#~ "Umgebungsvariable »GCL_ANSI« für den ANSI-Build, bzw. einen leeren Wert " +#~ "für den CLtL1-Build, z.B. GCL_ANSI=t gcl@EXT@ definiert werden. Es " +#~ "erfolgt eine Meldung über die aktive Erstellung im einführenden Start-" +#~ "Banner." + +#~ msgid "" +#~ "GCL now has optional support for profiling via gprof. Please see the " +#~ "documentation for si::gprof-start and si::gprof-quit for details. As this " +#~ "build is slower than builds without gprof support, it is not recommended " +#~ "for final production use. You can locally override the default choice " +#~ "made here by setting the GCL_PROF environment variable to any non-empty " +#~ "string for profiling support, and to the empty string for the more " +#~ "optimized builds, e.g. GCL_PROF=t gcl@EXT@. If profiling is enabled, " +#~ "this will be reported in the initial startup banner." +#~ msgstr "" +#~ "GCL besitzt optionale Unterstützung für Profiling mit gprof. Bitte lesen " +#~ "Sie hierzu die Dokumentation von si::gprof-start und si::gprof-quit für " +#~ "weiterführende Informationen. Da dieser Build langsamer ist als ohne " +#~ "gprof-Unterstützung, wird dieser Weg nicht für den endgültig produktiven " +#~ "Einsatz empfohlen. Sie können die hier gemachten Angaben lokal über die " +#~ "GCL_PROF-Umgebungsvariable durch einen beliebigen Wert ändern, bzw. durch " +#~ "einen leeren Wert für das weitaus anpassungsfähigere Build, z.B. " +#~ "GCL_PROF=t gcl@EXT@. Falls Profiling aktiviert ist, erfolgt eine Meldung " +#~ "im einführenden Start-Banner." diff --git a/debian/po/es.po b/debian/po/es.po new file mode 100644 index 0000000..e4cb113 --- /dev/null +++ b/debian/po/es.po @@ -0,0 +1,209 @@ +# gcl po-debconf translation to Spanish +# Copyright (C) 2005, 2007, 2008 Software in the Public Interest +# This file is distributed under the same license as the gcl package. +# +# Changes: +# - Initial translation +# César Gómez Martín , 2005 +# +# - Updates +# Rudy Godoy Guillén , 2007 +# Francisco Javier Cuadrado , 2008 +# +# Traductores, si no conoce el formato PO, merece la pena leer la +# documentación de gettext, especialmente las secciones dedicadas a este +# formato, por ejemplo ejecutando: +# +# info -n '(gettext)PO Files' +# info -n '(gettext)Header Entry' +# +# Equipo de traducción al español, por favor, lean antes de traducir +# los siguientes documentos: +# +# - El proyecto de traducción de Debian al español +# http://www.debian.org/intl/spanish/ +# especialmente las notas de traducción en +# http://www.debian.org/intl/spanish/notas +# +# - La guía de traducción de po's de debconf: +# /usr/share/doc/po-debconf/README-trans +# o http://www.debian.org/intl/l10n/po-debconf/README-trans +# +msgid "" +msgstr "" +"Project-Id-Version: gcl 2.6.7-45\n" +"Report-Msgid-Bugs-To: gcl@packages.debian.org\n" +"POT-Creation-Date: 2012-12-30 11:53-0400\n" +"PO-Revision-Date: 2008-12-04 20:00+0100\n" +"Last-Translator: Francisco Javier Cuadrado \n" +"Language-Team: Debian l10n spanish \n" +"Language: \n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=utf-8\n" +"Content-Transfer-Encoding: 8bit\n" +"X-Poedit-Language: Spanish\n" +"X-Poedit-Country: SPAIN\n" +"X-Poedit-SourceCharset: utf-8\n" + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "Use the work-in-progress ANSI build by default?" +msgstr "" +"¿Utilizar la generación ANSI todavía en desarrollo de manera predeterminada?" + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"GCL is in the process of providing an ANSI compliant image in addition to " +"its traditional CLtL1 image still in production use." +msgstr "" +"GL está en el proceso de proporcionar una imagen ANSI, además de su imagen " +"CLtL1 tradicional que todavía se usa." + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"Please see the README.Debian file for a brief description of these terms. " +"Choosing this option will determine which image will be used by default when " +"executing 'gcl@EXT@'." +msgstr "" +"Por favor, véase el archivo README.Debian para una descripción corta de " +"estos términos. Eligiendo esta opción determinará que imagen se usará de " +"manera predeterminada al ejecutar «gcl@EXT@»." + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"This setting may be overridden by setting the GCL_ANSI environment variable " +"to any non-empty string for the ANSI build, and to the empty string for the " +"CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " +"will be reported in the initial startup banner." +msgstr "" +"Esta configuración se puede sobrescribir cambiando la variable de entorno " +"GCL_ANSI a cualquier cadena de caracteres no vacía para la generación ANSI, " +"y a una cadena de caracteres vacía para la generación CLtL1, por ejemplo: " +"«GCL_ANSI=t gcl@EXT@». El actual tipo de generación se mostrará en la " +"información inicial del arranque." + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "Use the profiling build by default?" +msgstr "¿Utilizar la generación con «profiling» de manera predeterminada?" + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "GCL has optional support for profiling via gprof." +msgstr "GCL permite usar «profiling», de manera opcional, mediante gprof." + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "" +"Please see the documentation for si::gprof-start and si::gprof-quit for " +"details. As this build is slower than builds without gprof support, it is " +"not recommended for final production use." +msgstr "" +"Por favor, véase la documentación para los detalles de «si::gprof-start» y " +"«si::gprof-quit». Ya que esta generación es más lenta que sin el uso de " +"gprof, no se recomienda para su uso final." + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "" +"Set the GCL_PROF environment variable to the empty string for more optimized " +"builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " +"gcl@EXT@. If profiling is enabled, this will be reported in the initial " +"startup banner." +msgstr "" +"Cambie el valor de la variable de entorno GCL_PROF a una cadena de " +"caracteres vacía para generación más optimizadas, o a una cadena de " +"caracteres no vacía para usar el «profiling», por ejemplo: «GCL_PROF=t " +"gcl@EXT@». Si el «profiling» está activado, se mostrará en la información " +"inicial del arranque." + +#~ msgid "" +#~ "GCL is in the process of providing an ANSI compliant image in addition to " +#~ "its traditional CLtL1 image still in production use. Please see the " +#~ "README.Debian file for a brief description of these terms. Setting this " +#~ "variable will determine which image you will use by default on executing " +#~ "'gcl@EXT@'. You can locally override this choice by setting the GCL_ANSI " +#~ "environment variable to any non-empty string for the ANSI build, and to " +#~ "the empty string for the CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The " +#~ "flavor of the build in force will be reported in the initial startup " +#~ "banner." +#~ msgstr "" +#~ "GCL está en proceso de incorporar una imagen compatible con ANSI en " +#~ "adición a su imagen CLtL1 tradicional que todavía se usa en producción. " +#~ "Por favor, véase el fichero README de Debian para una breve descripción " +#~ "acerca de estos términos. El definir esta variable determinará qué imagen " +#~ "utilizar de manera predeterminada cuando ejecute «gcl@EXT@».\n" +#~ "Puede anular esta elección localmente definiendo la variable de entorno " +#~ "GCL_ANSI a una cadena no vacía para la compilación ANSI, y a una vacía " +#~ "para la compilación CLtL1, ejemplo: GCL_ANSI=t gcl@EXT@. La versión de la " +#~ "compilación se indicará en el anuncio inicial de arranque." + +#~ msgid "" +#~ "GCL now has optional support for profiling via gprof. Please see the " +#~ "documentation for si::gprof-start and si::gprof-quit for details. As this " +#~ "build is slower than builds without gprof support, it is not recommended " +#~ "for final production use. You can locally override the default choice " +#~ "made here by setting the GCL_PROF environment variable to any non-empty " +#~ "string for profiling support, and to the empty string for the more " +#~ "optimized builds, e.g. GCL_PROF=t gcl@EXT@. If profiling is enabled, " +#~ "this will be reported in the initial startup banner." +#~ msgstr "" +#~ "Ahora GCL tiene soporte opcional para perfilado a través de gprof. Por " +#~ "favor, mire la documentación de «si::gprof-start» y de «si::gprof-quit» y " +#~ "«si::gprof-quit» si desea más detalles. Dado que esta compilación es más " +#~ "lenta que otras sin soporte para gprof, no se recomienda usarlo en " +#~ "producción. Puede anular esta elección de forma local mediante el " +#~ "establecimiento de la variable de entorno GCL_PROF a cualquier cadena no " +#~ "vacía para soporte de perfiles, y a la cadena vacía para los paquetes más " +#~ "optimizados, es decir GCL_PROF=t gcl. Si el perfilado está activo se " +#~ "indicará en el anuncio inicial de arranque." + +#~ msgid "" +#~ "GCL is one of the oldest free common lisp systems still in use. Several " +#~ "production systems have used it for over a decade. The common lisp " +#~ "standard in effect when GCL was first released is known as \"Common Lisp, " +#~ "the Language\" (CLtL1) after a book by Steele of the same name providing " +#~ "this specification. Subsequently, a much expanded standard was adopted " +#~ "by the American National Standards Institute (ANSI), which is still " +#~ "considered the definitive common lisp language specification to this " +#~ "day. GCL is in the process of providing an ANSI compliant image in " +#~ "addition to its traditional CLtL1 image still in production use. Setting " +#~ "this variable will determine which image you will use by default on " +#~ "executing 'gcl'. You can locally override this choice by setting the " +#~ "GCL_ANSI environment variable to any non-empty string for the ANSI build, " +#~ "and to the empty string for the CLtL1 build, e.g. GCL_ANSI=t gcl. You " +#~ "may be interested in reviewing the ANSI test results sketching the level " +#~ "of compliance achieved thus far in /usr/share/doc/gcl/test_results.gz. " +#~ "The flavor of the build in force will be reported in the initial startup " +#~ "banner." +#~ msgstr "" +#~ "GCL es uno de los sistemas libres de «common lisp» más antiguos que " +#~ "todavía se usan. Varios sistemas en producción han estado usándolo " +#~ "durante más de una década. Cuando GCL se liberó por primera vez, el " +#~ "estándar «common lisp» se conocía como «Common Lisp, the " +#~ "Language» (CLtL1) después de un libro escrito por Steele que llevaba el " +#~ "mismo nombre y que proporcionaba esta especificación. Posteriormente se " +#~ "adoptó en el Instituto Nacional de Estándares Americano (ANSI) un " +#~ "estándar más extendido, que todavía se considera la especificación " +#~ "definitiva del lenguaje «common lisp» hasta hoy. GCL está en el proceso " +#~ "de proporcionar una imagen conforme a ANSI además de su imagen CltL1 " +#~ "tradicional que todavía se usa en producción. Al establecer esta variable " +#~ "se determinará la imagen por omisión que usará al ejecutar «gcl». Puede " +#~ "anular esta elección de forma local mediante el establecimiento de la " +#~ "variable de entorno GCL_ANSI a cualquier cadena no vacía para el paquete " +#~ "ANSI, y a la cadena vacía para el paquete CLtL1, i.e. GCL_ANSI=t gcl. " +#~ "Quizás esté interesado en revisar los resultados de las pruebas ANSI " +#~ "describiendo el nivel de conformidad logrado hasta ahora en /usr/share/" +#~ "doc/gcl/test_results.gz. Se informará del tipo de paquete usado en el " +#~ "anuncio inicial de arranque." diff --git a/debian/po/fi.po b/debian/po/fi.po new file mode 100644 index 0000000..e9dc116 --- /dev/null +++ b/debian/po/fi.po @@ -0,0 +1,95 @@ +msgid "" +msgstr "" +"Project-Id-Version: gcl\n" +"Report-Msgid-Bugs-To: gcl@packages.debian.org\n" +"POT-Creation-Date: 2012-12-30 11:53-0400\n" +"PO-Revision-Date: 2007-12-29 23:28+0200\n" +"Last-Translator: Esko Arajärvi \n" +"Language-Team: Finnish \n" +"Language: fi\n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=UTF-8\n" +"Content-Transfer-Encoding: 8bit\n" +"X-Poedit-Language: Finnish\n" +"X-Poedit-Country: Finland\n" + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "Use the work-in-progress ANSI build by default?" +msgstr "Käytetäänkö kehitettävää ANSI-käännöstä oletuksena?" + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"GCL is in the process of providing an ANSI compliant image in addition to " +"its traditional CLtL1 image still in production use." +msgstr "" +"GCL:n on tarkoitus tarjota ANSI-yhteensopiva kuva perinteisen, vielä " +"tuotantokäytössä olevan CLtL1-kuvan lisäksi." + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"Please see the README.Debian file for a brief description of these terms. " +"Choosing this option will determine which image will be used by default when " +"executing 'gcl@EXT@'." +msgstr "" +"Tiedostosta README.Debian löytyy (englanniksi) näiden termien lyhyet " +"kuvaukset. Tämä valinta vaikuttaa siihen mitä kuvaa käytetään oletuksena " +"ajettaessa ”gcl@EXT@”." + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"This setting may be overridden by setting the GCL_ANSI environment variable " +"to any non-empty string for the ANSI build, and to the empty string for the " +"CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " +"will be reported in the initial startup banner." +msgstr "" +"Tämä asetus voidaan ohittaa asettamalla GCL_ANSI-ympäristömuuttuja. Jos " +"muuttujan arvo on mikä tahansa ei-tyhjä merkkijono, käytetään ANSI-" +"käännöstä, ja jos muuttujan arvo on tyhjä merkkijono, käytetään CLtL1-" +"käännöstä. Esimerkiksi: GCL_ANSI=t gcl@EXT@. Käytetty pakotettu käännöstapa " +"raportoidaan käynnistysruudussa." + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "Use the profiling build by default?" +msgstr "Käytetäänkö profilointia oletuksena?" + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "GCL has optional support for profiling via gprof." +msgstr "GCL tukee valinnaisesti profilointia gprofin avulla." + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "" +"Please see the documentation for si::gprof-start and si::gprof-quit for " +"details. As this build is slower than builds without gprof support, it is " +"not recommended for final production use." +msgstr "" +"Katso yksityiskohdat (englanniksi) dokumentaatiosta kohdista si::gprof-start " +"ja si::gprof-quit. Koska tämä käännös on hitaampi kuin käännökset ilman " +"gprof-tukea, tätä ei suositella tuotantokäyttöön." + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "" +"Set the GCL_PROF environment variable to the empty string for more optimized " +"builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " +"gcl@EXT@. If profiling is enabled, this will be reported in the initial " +"startup banner." +msgstr "" +"Aseta GCL_PROF-ympäristömuuttuja tyhjäksi merkkijonoksi käyttääksesi " +"optimoidumpia käännöksiä ja miksi tahansa ei-tyhjäksi merkkijonoksi " +"käyttääksesi profilointia. Esimerkiksi: GCL_PROF=t gcl@EXT@. Jos profilointi " +"on aktivoituna, se raportoidaan käynnistysruudussa." diff --git a/debian/po/fr.po b/debian/po/fr.po new file mode 100644 index 0000000..b21eac8 --- /dev/null +++ b/debian/po/fr.po @@ -0,0 +1,141 @@ +# Translation of gcl debconf templates to French +# Copyright (C) 2007 Sylvain Archenault +# This file is distributed under the same license as the iodine package. +# +# Sylvain Archenault , 2007. +msgid "" +msgstr "" +"Project-Id-Version: gcl 2.6.7-1\n" +"Report-Msgid-Bugs-To: gcl@packages.debian.org\n" +"POT-Creation-Date: 2012-12-30 11:53-0400\n" +"PO-Revision-Date: 2007-12-23 13:03+0100\n" +"Last-Translator: Sylvain Archenault \n" +"Language-Team: French \n" +"Language: fr\n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=ISO-8859-15\n" +"Content-Transfer-Encoding: 8bit\n" + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "Use the work-in-progress ANSI build by default?" +msgstr "Faut-il utiliser la compilation ANSI par défaut ?" + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"GCL is in the process of providing an ANSI compliant image in addition to " +"its traditional CLtL1 image still in production use." +msgstr "" +"GCL est en passe de fournir une image respectant la norme ANSI en plus de " +"l'image traditionnelle CLtL1, toujours utilisée en production." + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"Please see the README.Debian file for a brief description of these terms. " +"Choosing this option will determine which image will be used by default when " +"executing 'gcl@EXT@'." +msgstr "" +"Veuillez lire le fichier README.Debian pour une brève description de ces " +"termes. Le choix de cette option déterminera quelle image sera utilisée par " +"défaut en exécutant « gcl@EXT@ »." + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"This setting may be overridden by setting the GCL_ANSI environment variable " +"to any non-empty string for the ANSI build, and to the empty string for the " +"CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " +"will be reported in the initial startup banner." +msgstr "" +"Ce réglage peut être changé en affectant à la variable d'environnement " +"GCL_ANSI une chaîne non vide pour la compilation ANSI, et une chaîne vide " +"pour la compilation CLtL1, par exemple GCL_ANSI=t gcl@EXT@. Le type de " +"compilation sera affiché dans le bandeau de démarrage." + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "Use the profiling build by default?" +msgstr "Faut-il utiliser le profilage par défaut ?" + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "GCL has optional support for profiling via gprof." +msgstr "GCL permet optionnellement la gestion du profilage via gprof." + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "" +"Please see the documentation for si::gprof-start and si::gprof-quit for " +"details. As this build is slower than builds without gprof support, it is " +"not recommended for final production use." +msgstr "" +"Veuillez vous reporter à la documentation de « si::gprof-start » et « si::" +"gprof-quit » pour plus de détails. Comme cet exécutable est plus lent que " +"les exécutables sans la gestion de gprof, il n'est pas recommandé de " +"l'utiliser en production." + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "" +"Set the GCL_PROF environment variable to the empty string for more optimized " +"builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " +"gcl@EXT@. If profiling is enabled, this will be reported in the initial " +"startup banner." +msgstr "" +"Veuillez affecter une chaîne vide à la variable d'environnement GCL_PROF " +"pour des compilations optimisées, ou une chaîne non vide pour avoir la " +"gestion du profilage; par exemple GCL_PROF=t gcl@EXT@. Si le profilage est " +"activé, cela sera affiché dans le bandeau de démarrage." + +#~ msgid "" +#~ "GCL is in the process of providing an ANSI compliant image in addition to " +#~ "its traditional CLtL1 image still in production use. Please see the " +#~ "README.Debian file for a brief description of these terms. Setting this " +#~ "variable will determine which image you will use by default on executing " +#~ "'gcl@EXT@'. You can locally override this choice by setting the GCL_ANSI " +#~ "environment variable to any non-empty string for the ANSI build, and to " +#~ "the empty string for the CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The " +#~ "flavor of the build in force will be reported in the initial startup " +#~ "banner." +#~ msgstr "" +#~ "GCL a pour but de fournir une image conforme à la définition de " +#~ "l'ANSI en plus de son image traditionnelle CLtL1 qui est toujours " +#~ "utilisée en production. Veuillez consulter le fichier README.Debian " +#~ "pour plus d'informations sur ces normes. Ce choix déterminera quelle " +#~ "norme vous allez utiliser par défaut lors de l'exécution de " +#~ "« gcl@EXT@ ». Vous pouvez localement modifier ce choix en " +#~ "affectant une chaîne non vide à la variable d'environnement GCL_ANSI " +#~ "pour une compilation respectant la norme définie par l'ANSI, et une " +#~ "chaîne vide pour une compilation en accord avec la norme CLtL1, par " +#~ "exemple GCL_ANSI=t gcl@EXT@. Le type de compilation sera affiché dans " +#~ "le bandeau de démarrage." + +#~ msgid "" +#~ "GCL now has optional support for profiling via gprof. Please see the " +#~ "documentation for si::gprof-start and si::gprof-quit for details. As this " +#~ "build is slower than builds without gprof support, it is not recommended " +#~ "for final production use. You can locally override the default choice " +#~ "made here by setting the GCL_PROF environment variable to any non-empty " +#~ "string for profiling support, and to the empty string for the more " +#~ "optimized builds, e.g. GCL_PROF=t gcl@EXT@. If profiling is enabled, " +#~ "this will be reported in the initial startup banner." +#~ msgstr "" +#~ "GCL gÚre désormais le profilage via gprof. Veuillez consulter la " +#~ "documentation de si::gprof-start et de si::gprof-quit pour plus " +#~ "d'informations. La construction produite avec cette option est plus lente " +#~ "que la construction classique. Par conséquent il n'est pas recommandé " +#~ "de l'utiliser en production. Vous pouvez localement modifier ce choix en " +#~ "affectant à la variable d'environnement GCL_PROF, une chaîne non vide " +#~ "pour activer le profilage, ou une chaîne vide pour une compilation " +#~ "optimisée, par exemple GCL_PROF=t gcl@EXT@. Si le profilage est " +#~ "activé, cela sera affiché dans le bandeau de démarrage." diff --git a/debian/po/gl.po b/debian/po/gl.po new file mode 100644 index 0000000..951ca9f --- /dev/null +++ b/debian/po/gl.po @@ -0,0 +1,138 @@ +# Galician translation of gclcvs's debconf templates +# This file is distributed under the same license as the gclcvs package. +# Jacobo Tarrio , 2007. +# +msgid "" +msgstr "" +"Project-Id-Version: gclcvs\n" +"Report-Msgid-Bugs-To: gcl@packages.debian.org\n" +"POT-Creation-Date: 2012-12-30 11:53-0400\n" +"PO-Revision-Date: 2008-01-01 13:38+0000\n" +"Last-Translator: Jacobo Tarrio \n" +"Language-Team: Galician \n" +"Language: gl\n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=UTF-8\n" +"Content-Transfer-Encoding: 8bit\n" + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "Use the work-in-progress ANSI build by default?" +msgstr "¿Empregar por defecto a versión ANSI que se está a facer?" + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"GCL is in the process of providing an ANSI compliant image in addition to " +"its traditional CLtL1 image still in production use." +msgstr "" +"Estase a traballar para que GCL forneza unha imaxe ANSI ademáis da imaxe " +"CLtL1 que aínda se emprega en produción." + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"Please see the README.Debian file for a brief description of these terms. " +"Choosing this option will determine which image will be used by default when " +"executing 'gcl@EXT@'." +msgstr "" +"Consulte o ficheiro README.Debian para ver unha descrición breve deses " +"termos. Ao establecer esa variable ha determinar a imaxe que ha empregar por " +"defecto ao executar \"gcl@EXT@\"." + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"This setting may be overridden by setting the GCL_ANSI environment variable " +"to any non-empty string for the ANSI build, and to the empty string for the " +"CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " +"will be reported in the initial startup banner." +msgstr "" +"Pode empregar a outra imaxe establecendo a variable de ambiente GCL_ANSI a " +"calquera cadea non baleira para empregar a versión ANSI, e á cadea baleira " +"para empregar a versión CLtL1; por exemplo, GCL_ANSI=t gcl@EXT@. Hase " +"informar da versión en uso no cartel que aparece ao iniciar o programa." + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "Use the profiling build by default?" +msgstr "¿Empregar por defecto a versión con cronometrado?" + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "GCL has optional support for profiling via gprof." +msgstr "GCL agora ten soporte opcional de cronometrado mediante gprof." + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "" +"Please see the documentation for si::gprof-start and si::gprof-quit for " +"details. As this build is slower than builds without gprof support, it is " +"not recommended for final production use." +msgstr "" +"Consulte a documentación de si::gprof-start e si::gprof-quit para máis " +"detalles. Xa que esta versión é máis lenta que as que non teñen soporte de " +"gprof, non se recomenda que a empregue para o uso en produción." + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "" +"Set the GCL_PROF environment variable to the empty string for more optimized " +"builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " +"gcl@EXT@. If profiling is enabled, this will be reported in the initial " +"startup banner." +msgstr "" +"Pode empregar unha versión distinta á seleccionada establecendo a variable " +"de ambiente GCL_PROF a calquera cadea non baleira para empregar o soporte de " +"cronometrado, ou á cadea baleira para as versións máis optimizadas; por " +"exemplo, GCL_PROF=t gcl@EXT@. Se está activado o cronometrado, hase informar " +"diso no cartel que aparece ao iniciar o programa." + +#~ msgid "" +#~ "GCL is in the process of providing an ANSI compliant image in addition to " +#~ "its traditional CLtL1 image still in production use. Please see the " +#~ "README.Debian file for a brief description of these terms. Setting this " +#~ "variable will determine which image you will use by default on executing " +#~ "'gcl@EXT@'. You can locally override this choice by setting the GCL_ANSI " +#~ "environment variable to any non-empty string for the ANSI build, and to " +#~ "the empty string for the CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The " +#~ "flavor of the build in force will be reported in the initial startup " +#~ "banner." +#~ msgstr "" +#~ "Estase a traballar para que GCL forneza unha imaxe ANSI ademáis da imaxe " +#~ "CLtL1 que aínda se emprega en produción. Consulte o ficheiro README." +#~ "Debian para ver unha descrición breve deses termos. Ao estabrecer esa " +#~ "variable ha determinar a imaxe que ha empregar por defecto ao executar " +#~ "\"gcl@EXT@\". Pode empregar a outra imaxe estabrecendo a variable de " +#~ "ambiente GCL_ANSI a calquera cadea non baleira para empregar a versión " +#~ "ANSI, e á cadea baleira para empregar a versión CLtL1; por exemplo, " +#~ "GCL_ANSI=t gcl@EXT@. Hase informar da versión en uso no cartel que " +#~ "aparece ao iniciar o programa." + +#~ msgid "" +#~ "GCL now has optional support for profiling via gprof. Please see the " +#~ "documentation for si::gprof-start and si::gprof-quit for details. As this " +#~ "build is slower than builds without gprof support, it is not recommended " +#~ "for final production use. You can locally override the default choice " +#~ "made here by setting the GCL_PROF environment variable to any non-empty " +#~ "string for profiling support, and to the empty string for the more " +#~ "optimized builds, e.g. GCL_PROF=t gcl@EXT@. If profiling is enabled, " +#~ "this will be reported in the initial startup banner." +#~ msgstr "" +#~ "GCL agora ten soporte opcional de cronometrado mediante gprof. Consulte a " +#~ "documentación de si::gprof-start e si::gprof-quit para máis detalles. Xa " +#~ "que esta versión é máis lenta que as que non teñen soporte de gprof, non " +#~ "se recomenda que a empregue para o uso en produción. Pode empregar unha " +#~ "versión distinta á seleccionada estabrecendo a variable de ambiente " +#~ "GCL_PROF a calquera cadea non baleira para empregar o soporte de " +#~ "cronometrado, ou á cadea baleira para as versións máis optimizadas; por " +#~ "exemplo, GCL_PROF=t gcl@EXT@. Se está activado o cronometrado, hase " +#~ "informar diso no cartel que aparece ao iniciar o programa." diff --git a/debian/po/it.po b/debian/po/it.po new file mode 100644 index 0000000..a488561 --- /dev/null +++ b/debian/po/it.po @@ -0,0 +1,102 @@ +# ITALIAN TRANSLATION OF GCL'S PO-DEBCONF FILE. +# COPYRIGHT (C) 2009 THE GCL'S COPYRIGHT HOLDER +# This file is distributed under the same license as the gcl package. +# +# Vincenzo Campanella , 2009. +# +msgid "" +msgstr "" +"Project-Id-Version: gcl\n" +"Report-Msgid-Bugs-To: gcl@packages.debian.org\n" +"POT-Creation-Date: 2012-12-30 11:53-0400\n" +"PO-Revision-Date: 2009-11-29 08:39+0100\n" +"Last-Translator: Vincenzo Campanella \n" +"Language-Team: Italian \n" +"Language: it\n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=UTF-8\n" +"Content-Transfer-Encoding: 8bit\n" + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "Use the work-in-progress ANSI build by default?" +msgstr "" +"Usare in modo predefinito la compilazione ANSI, che è in fase di " +"approntamento?" + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"GCL is in the process of providing an ANSI compliant image in addition to " +"its traditional CLtL1 image still in production use." +msgstr "" +"Accanto all'immagine tradizionale CLtL1, in uso in realtà produttive, GCL " +"sta preparando un'immagine conforme ad ANSI." + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"Please see the README.Debian file for a brief description of these terms. " +"Choosing this option will determine which image will be used by default when " +"executing 'gcl@EXT@'." +msgstr "" +"Per maggiori informazioni consultare il file «README.Debian». La scelta di " +"questa opzione determinerà quale immagine verrà utilizzata in modo " +"predefinito durante l'esecuzione di «gcl@EXT@»." + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"This setting may be overridden by setting the GCL_ANSI environment variable " +"to any non-empty string for the ANSI build, and to the empty string for the " +"CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " +"will be reported in the initial startup banner." +msgstr "" +"Questa impostazione può essere sovrascritta impostando la variabile " +"d'ambiente «GCL_ANSI» con una stringa non vuota per la compilazione ANSI e " +"con una stringa vuota per la compilazione CLtL1, per esempio: «GCL_ANSI=t " +"gcl@EXT@». Il tipo di compilazione attualmente in uso viene mostrato nella " +"schermata di avvio." + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "Use the profiling build by default?" +msgstr "Usare il profiling in modo predefinito?" + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "GCL has optional support for profiling via gprof." +msgstr "GCL possiede un supporto opzionale per il profiling tramite gprof." + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "" +"Please see the documentation for si::gprof-start and si::gprof-quit for " +"details. As this build is slower than builds without gprof support, it is " +"not recommended for final production use." +msgstr "" +"Per maggiori dettagli consultare la documentazione per «si::gprof-start» e " +"«si::gprof-quit». Poiché questa compilazione è più lenta, rispetto a quella " +"senza supporto per gprof, non è raccomandata per un utilizzo in realtà " +"produttive." + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "" +"Set the GCL_PROF environment variable to the empty string for more optimized " +"builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " +"gcl@EXT@. If profiling is enabled, this will be reported in the initial " +"startup banner." +msgstr "" +"Per compilazioni ottimizzate impostare la variabile d'ambiente «GCL_PROF» a " +"una stringa vuota, oppure per impostare il supporto al profiling impostarla " +"a una stringa non vuota, per esempio «GCL_PROF=t gcl@EXT@». La schermata " +"d'avvio indicherà se il profiling è abilitato." diff --git a/debian/po/ja.po b/debian/po/ja.po new file mode 100644 index 0000000..169782b --- /dev/null +++ b/debian/po/ja.po @@ -0,0 +1,96 @@ +# SOME DESCRIPTIVE TITLE. +# Copyright (C) YEAR THE PACKAGE'S COPYRIGHT HOLDER +# This file is distributed under the same license as the gcl package. +# victory , 2013. +# +msgid "" +msgstr "" +"Project-Id-Version: gcl\n" +"Report-Msgid-Bugs-To: gcl@packages.debian.org\n" +"POT-Creation-Date: 2013-07-27 14:28+0000\n" +"PO-Revision-Date: 2013-07-27 23:28+0900\n" +"Last-Translator: victory \n" +"Language-Team: Japanese \n" +"Language: ja\n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=UTF-8\n" +"Content-Transfer-Encoding: 8bit\n" + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "Use the work-in-progress ANSI build by default?" +msgstr "未完成の ANSI ビルドをデフォルトで使用しますか?" + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"GCL is in the process of providing an ANSI compliant image in addition to " +"its traditional CLtL1 image still in production use." +msgstr "" +"GCL は未だに生産利用されている従来の CLtL1 イメージに加えて ANSI 準拠のイメー" +"ジを提供する過程にあります。" + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"Please see the README.Debian file for a brief description of these terms. " +"Choosing this option will determine which image will be used by default when " +"executing 'gcl@EXT@'." +msgstr "" +"用語については README.Debian ファイルに簡単な説明があります。このオプションの" +"選択「gcl@EXT@」を実行するときにどのイメージをデフォルトで利用するのか決定する" +"ことになります。" + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"This setting may be overridden by setting the GCL_ANSI environment variable " +"to any non-empty string for the ANSI build, and to the empty string for the " +"CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " +"will be reported in the initial startup banner." +msgstr "" +"この設定は、GCL_ANSI 環境変数に ANSI ビルドでは空白ではない任意の文字列、" +"CLtL1 ビルドでは空白文字列をセットすることで上書きできます。例えば GCL_ANSI=t " +"gcl@EXT@。現在実行しているビルドの種類は初期の開始時バナーで報告されます。" + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "Use the profiling build by default?" +msgstr "デフォルトで profiling ビルドを使いますか?" + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "GCL has optional support for profiling via gprof." +msgstr "" +"GCL にはオプションで gprof 経由の profiling サポートがあります。" + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "" +"Please see the documentation for si::gprof-start and si::gprof-quit for " +"details. As this build is slower than builds without gprof support, it is " +"not recommended for final production use." +msgstr "" +"詳細については si::gprof-start や si::gprof-quit の文書を見てください。このビ" +"ルドは gprof サポートのないビルドより遅いため、最終的な生産利用にはお勧めしま" +"せん。" + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "" +"Set the GCL_PROF environment variable to the empty string for more optimized " +"builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " +"gcl@EXT@. If profiling is enabled, this will be reported in the initial " +"startup banner." +msgstr "" +"ビルドをもっと最適化する場合は GCL_PROF 環境変数に空白文字列を、profiling をサ" +"ポートさせる場合は空白ではない任意の文字列をセットしてください。例えば GCL_" +"PROF=t gcl@EXT@。profiling が有効な場合、初期の開始時バナーで報告されます。" diff --git a/debian/po/nl.po b/debian/po/nl.po new file mode 100644 index 0000000..c46d99f --- /dev/null +++ b/debian/po/nl.po @@ -0,0 +1,101 @@ +# SOME DESCRIPTIVE TITLE. +# Copyright (C) YEAR THE PACKAGE'S COPYRIGHT HOLDER +# This file is distributed under the same license as the PACKAGE package. +# FIRST AUTHOR , YEAR. +# +msgid "" +msgstr "" +"Project-Id-Version: gcl\n" +"Report-Msgid-Bugs-To: gcl@packages.debian.org\n" +"POT-Creation-Date: 2012-12-30 11:53-0400\n" +"PO-Revision-Date: 2008-01-01 21:15+0100\n" +"Last-Translator: Bart Cornelis \n" +"Language-Team: debian-l10n-dutch \n" +"Language: \n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=utf-8\n" +"Content-Transfer-Encoding: 8bit\n" +"X-Poedit-Language: Dutch\n" + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "Use the work-in-progress ANSI build by default?" +msgstr "Wilt u standaard de in-ontwikkeling-zijnde ansi-compilatie gebruiken?" + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"GCL is in the process of providing an ANSI compliant image in addition to " +"its traditional CLtL1 image still in production use." +msgstr "" +"GCL is bezig om, aanvullend op het traditionele CLtL1-compilatie dat nog " +"steeds in gebruik is, een aan ANSI voldoend compilatie te voorzien." + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"Please see the README.Debian file for a brief description of these terms. " +"Choosing this option will determine which image will be used by default when " +"executing 'gcl@EXT@'." +msgstr "" +"Meer informatie hierover vindt u in het bestand /usr/share/doc/gcl/README." +"Debian . Deze optie bepaalt welk compilatie standaard gebruikt wordt wanneer " +"u 'gcl@EXT@' uitvoert. " + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"This setting may be overridden by setting the GCL_ANSI environment variable " +"to any non-empty string for the ANSI build, and to the empty string for the " +"CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " +"will be reported in the initial startup banner." +msgstr "" +"Deze instelling kan altijd overstegen worden door de omgevingsvariabele " +"GCL_ANSI in te stellen op een niet-lege string om de ANSI-compilatie te " +"bekomen, en op een lege string om de CLtL1-compilatie te bekomen (bv. " +"GCL_ANSI=t gcl@EXT@). De momenteel afgedwongen compilatie-soort wordt " +"weergegeven in de initiële opstartbanier." + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "Use the profiling build by default?" +msgstr "" +"Wilt u standaard een compilatie met ondersteuning voor profilering gebruiken?" + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "GCL has optional support for profiling via gprof." +msgstr "GCL heeft optionele ondersteuning voor profilering via gprof." + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "" +"Please see the documentation for si::gprof-start and si::gprof-quit for " +"details. As this build is slower than builds without gprof support, it is " +"not recommended for final production use." +msgstr "" +"Meer informatie vindt u in de documentatie voor si::gprof-start en si::gprof-" +"quit . Aangezien compilaties met gprof-ondersteuning trager zijn dan deze " +"zonder is dit niet aan te raden voor productie-gebruik." + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "" +"Set the GCL_PROF environment variable to the empty string for more optimized " +"builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " +"gcl@EXT@. If profiling is enabled, this will be reported in the initial " +"startup banner." +msgstr "" +"Om een geoptimaliseerde compilatie te verkrijgen stelt u de " +"omgevingsvariabele GCL_PROF in op een lege string, of op een niet-lege " +"string als u profilering wilt ondersteunen (bv. GCL_PROF=t gcl@EXT@). Als " +"profilering geactiveerd is wordt dit weergegeven in de initiële " +"opstartbanier ." diff --git a/debian/po/pt.po b/debian/po/pt.po new file mode 100644 index 0000000..fb8b56b --- /dev/null +++ b/debian/po/pt.po @@ -0,0 +1,99 @@ +# translation of gcl debconf to Portuguese +# Copyright (C) 2007 Américo Monteiro +# This file is distributed under the same license as the gcl package. +# +# Américo Monteiro , 2007. +msgid "" +msgstr "" +"Project-Id-Version: gcl 2.6.7-36\n" +"Report-Msgid-Bugs-To: gcl@packages.debian.org\n" +"POT-Creation-Date: 2012-12-30 11:53-0400\n" +"PO-Revision-Date: 2007-12-23 16:44+0000\n" +"Last-Translator: Américo Monteiro \n" +"Language-Team: Portuguese \n" +"Language: pt\n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=UTF-8\n" +"Content-Transfer-Encoding: 8bit\n" +"X-Generator: KBabel 1.11.4\n" + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "Use the work-in-progress ANSI build by default?" +msgstr "Usar a compilação 'ainda em desenvolvimento' ANSI por prédefinição? " + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"GCL is in the process of providing an ANSI compliant image in addition to " +"its traditional CLtL1 image still in production use." +msgstr "" +"GCL está no processo de disponibilizar uma imagem compatível com ANSI como " +"adição à sua imagem tradicional CLtL1 ainda em utilização de produção." + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"Please see the README.Debian file for a brief description of these terms. " +"Choosing this option will determine which image will be used by default when " +"executing 'gcl@EXT@'." +msgstr "" +"Por favor veja o ficheiro README.Debian para uma breve descrição destes " +"termos. Escolher esta opção irá determinar qual imagem será usada por " +"prédefinição ao executar 'gcl@EXT@'." + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"This setting may be overridden by setting the GCL_ANSI environment variable " +"to any non-empty string for the ANSI build, and to the empty string for the " +"CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " +"will be reported in the initial startup banner." +msgstr "" +"Esta opção pode ser sobreposta ao regular a variável de ambiente GCL_ANSI " +"para qualquer string não-vazia para a compilação ANSI, e para uma string " +"vazia para a compilação CLtL1, como por exemplo GCL_ANSI=t gcl@EXT@. O tipo " +"de compilação actualmente imposto será reportado no banner inicial de " +"arranque." + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "Use the profiling build by default?" +msgstr "Usar, como pré-definição, a compilação com 'profiling'?" + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "GCL has optional support for profiling via gprof." +msgstr "O GCL tem suporte opcional para 'profiling' via gprof." + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "" +"Please see the documentation for si::gprof-start and si::gprof-quit for " +"details. As this build is slower than builds without gprof support, it is " +"not recommended for final production use." +msgstr "" +"Por favor veja a documentação de si::gprof-start e si::gprof-quit para mais " +"detalhes. Como esta compilação é mais lenta do que as compilações sem o " +"suporte para gprof, não é recomendada para utilização de produção final." + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "" +"Set the GCL_PROF environment variable to the empty string for more optimized " +"builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " +"gcl@EXT@. If profiling is enabled, this will be reported in the initial " +"startup banner." +msgstr "" +"Regule a variável de ambiente GCL_PROF para uma string vazia para mais " +"compilações optimizadas, ou para qualquer string não-vazia para suporte de " +"'profiling'; como por exemplo GCL_PROF=t gcl@EXT@. Se o 'profiling' estiver " +"activo, isto será reportado no banner inicial de arranque." diff --git a/debian/po/ru.po b/debian/po/ru.po new file mode 100644 index 0000000..dfd56cb --- /dev/null +++ b/debian/po/ru.po @@ -0,0 +1,100 @@ +# translation of ru.po to Russian +# Copyright (C) YEAR THE PACKAGE'S COPYRIGHT HOLDER +# This file is distributed under the same license as the PACKAGE package. +# +# Yuri Kozlov , 2008. +msgid "" +msgstr "" +"Project-Id-Version: 2.6.7-36\n" +"Report-Msgid-Bugs-To: gcl@packages.debian.org\n" +"POT-Creation-Date: 2012-12-30 11:53-0400\n" +"PO-Revision-Date: 2008-01-03 10:22+0300\n" +"Last-Translator: Yuri Kozlov \n" +"Language-Team: Russian \n" +"Language: ru\n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=UTF-8\n" +"Content-Transfer-Encoding: 8bit\n" +"X-Generator: KBabel 1.11.4\n" +"Plural-Forms: nplurals=3; plural=(n%10==1 && n%100!=11 ? 0 : n%10>=2 && n" +"%10<=4 && (n%100<10 || n%100>=20) ? 1 : 2);\n" + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "Use the work-in-progress ANSI build by default?" +msgstr "Использовать разрабатываемую ANSI сборку по умолчанию?" + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"GCL is in the process of providing an ANSI compliant image in addition to " +"its traditional CLtL1 image still in production use." +msgstr "" +"Помимо обычного образа CLtL1, используемого в повсеместной работе, GCL имеет " +"практически готовый образ, соответствующий ANSI." + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"Please see the README.Debian file for a brief description of these terms. " +"Choosing this option will determine which image will be used by default when " +"executing 'gcl@EXT@'." +msgstr "" +"Краткое описание приведено в файле README.Debian. Данным выбором " +"определяется, какой из образов будет использован по умолчанию при выполнении " +"'gcl@EXT@'." + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"This setting may be overridden by setting the GCL_ANSI environment variable " +"to any non-empty string for the ANSI build, and to the empty string for the " +"CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " +"will be reported in the initial startup banner." +msgstr "" +"Эта настройка может быть переопределена установкой переменной окружения " +"GCL_ANSI в непустое значение для ANSI сборки, а пустым значением выбирается " +"CLtL1 сборка, например GCL_ANSI=t gcl@EXT@. Текущий используемый тип сборки " +"будет показан при первом запуске." + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "Use the profiling build by default?" +msgstr "Использовать по умолчанию профилируемую сборку?" + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "GCL has optional support for profiling via gprof." +msgstr "GCL поддерживает необязательное профилирование через gprof." + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "" +"Please see the documentation for si::gprof-start and si::gprof-quit for " +"details. As this build is slower than builds without gprof support, it is " +"not recommended for final production use." +msgstr "" +"Подробней об этом смотрите в документации на si::gprof-start и si::gprof-" +"quit. Так как данная сборка работает медленнее чем без поддержки gprof, её " +"не рекомендуется использовать в реальной работе." + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "" +"Set the GCL_PROF environment variable to the empty string for more optimized " +"builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " +"gcl@EXT@. If profiling is enabled, this will be reported in the initial " +"startup banner." +msgstr "" +"Задание переменной окружения GCL_PROF пустого значения включает более " +"оптимизированную сборку, а любое непустое -- поддержку профилирования; " +"например GCL_PROF=t gcl@EXT@. Если профилирование включено, то об этом будет " +"написано при первом запуске." diff --git a/debian/po/sv.po b/debian/po/sv.po new file mode 100644 index 0000000..6a3a93f --- /dev/null +++ b/debian/po/sv.po @@ -0,0 +1,106 @@ +# translation of gcl_2.6.7-36.1_sv.po to Swedish +# Translators, if you are not familiar with the PO format, gettext +# documentation is worth reading, especially sections dedicated to +# this format, e.g. by running: +# info -n '(gettext)PO Files' +# info -n '(gettext)Header Entry' +# Some information specific to po-debconf are available at +# /usr/share/doc/po-debconf/README-trans +# or http://www.debian.org/intl/l10n/po-debconf/README-trans +# Developers do not need to manually edit POT or PO files. +# +# Martin Ågren , 2008. +msgid "" +msgstr "" +"Project-Id-Version: gcl_2.6.7-36.1_sv\n" +"Report-Msgid-Bugs-To: gcl@packages.debian.org\n" +"POT-Creation-Date: 2012-12-30 11:53-0400\n" +"PO-Revision-Date: 2008-07-24 18:21+0200\n" +"Last-Translator: Martin Ågren \n" +"Language-Team: Swedish \n" +"Language: sv\n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=ISO-8859-1\n" +"Content-Transfer-Encoding: 8bit\n" +"X-Generator: KBabel 1.11.4\n" +"Plural-Forms: nplurals=2; plural=(n != 1);\n" + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "Use the work-in-progress ANSI build by default?" +msgstr "Använd det ännu inte färdiga ANSI-bygget som standard?" + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"GCL is in the process of providing an ANSI compliant image in addition to " +"its traditional CLtL1 image still in production use." +msgstr "" +"GCL arbetar på att tillhandahålla en ANSI-godkänd bild förutom dess " +"traditionella CLtL1-bild som fortfarande används i produktionsmiljön." + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"Please see the README.Debian file for a brief description of these terms. " +"Choosing this option will determine which image will be used by default when " +"executing 'gcl@EXT@'." +msgstr "" +"Se README.Debian-filen för en översiktlig beskrivning av dessa termer. När " +"du väljer det här alternativet avgörs vilken bild som kommer användas som " +"standard när 'gcl@EXT@' körs." + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"This setting may be overridden by setting the GCL_ANSI environment variable " +"to any non-empty string for the ANSI build, and to the empty string for the " +"CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " +"will be reported in the initial startup banner." +msgstr "" +"Denna inställning kan överskridas genom att sätta miljövariabeln GCL_ANSI " +"till en icke-tom sträng för ANSI-bygget, och till den tomma strängen för " +"CLtL1-bygget, t. ex. GCL_ANSI=t gcl@EXT@. Det bygge som för tillfället " +"används kommer anges i uppstartsutskriften." + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "Use the profiling build by default?" +msgstr "Använd profileringsbygget som standard?" + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "GCL has optional support for profiling via gprof." +msgstr "GCL har valfritt stöd för profilering via gprof." + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "" +"Please see the documentation for si::gprof-start and si::gprof-quit for " +"details. As this build is slower than builds without gprof support, it is " +"not recommended for final production use." +msgstr "" +"Se dokumentationen för si::gprof-start och si::gprof-quit för detaljer. " +"Eftersom detta bygge är långsammare än byggen utan stöd för gprof, " +"rekommenderas det inte för slutlig användning i produktionsmiljö." + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "" +"Set the GCL_PROF environment variable to the empty string for more optimized " +"builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " +"gcl@EXT@. If profiling is enabled, this will be reported in the initial " +"startup banner." +msgstr "" +"Sätt miljövariabeln GCL_PROF till den tomma strängen för mer optimiserade " +"byggen, eller en icke-tom sträng för profileringsstöd; t. ex. GCL_PROF=t " +"gcl@EXT@. Om profilering är aktiverad, kommer denna rapporteras i den " +"ursprungliga uppstartsutskriften." diff --git a/debian/po/templates.pot b/debian/po/templates.pot new file mode 100644 index 0000000..86276ce --- /dev/null +++ b/debian/po/templates.pot @@ -0,0 +1,82 @@ +# SOME DESCRIPTIVE TITLE. +# Copyright (C) YEAR THE PACKAGE'S COPYRIGHT HOLDER +# This file is distributed under the same license as the PACKAGE package. +# FIRST AUTHOR , YEAR. +# +#, fuzzy +msgid "" +msgstr "" +"Project-Id-Version: gcl\n" +"Report-Msgid-Bugs-To: gcl@packages.debian.org\n" +"POT-Creation-Date: 2012-12-30 11:53-0400\n" +"PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n" +"Last-Translator: FULL NAME \n" +"Language-Team: LANGUAGE \n" +"Language: \n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=CHARSET\n" +"Content-Transfer-Encoding: 8bit\n" + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "Use the work-in-progress ANSI build by default?" +msgstr "" + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"GCL is in the process of providing an ANSI compliant image in addition to " +"its traditional CLtL1 image still in production use." +msgstr "" + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"Please see the README.Debian file for a brief description of these terms. " +"Choosing this option will determine which image will be used by default when " +"executing 'gcl@EXT@'." +msgstr "" + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"This setting may be overridden by setting the GCL_ANSI environment variable " +"to any non-empty string for the ANSI build, and to the empty string for the " +"CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " +"will be reported in the initial startup banner." +msgstr "" + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "Use the profiling build by default?" +msgstr "" + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "GCL has optional support for profiling via gprof." +msgstr "" + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "" +"Please see the documentation for si::gprof-start and si::gprof-quit for " +"details. As this build is slower than builds without gprof support, it is " +"not recommended for final production use." +msgstr "" + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "" +"Set the GCL_PROF environment variable to the empty string for more optimized " +"builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " +"gcl@EXT@. If profiling is enabled, this will be reported in the initial " +"startup banner." +msgstr "" diff --git a/debian/po/vi.po b/debian/po/vi.po new file mode 100644 index 0000000..d1fa6de --- /dev/null +++ b/debian/po/vi.po @@ -0,0 +1,98 @@ +# Vietnamese translation for GCL. +# Copyright © 2007 Free Software Foundation, Inc. +# Clytie Siddall , 2007 +# +msgid "" +msgstr "" +"Project-Id-Version: gcl 2.6.7-36\n" +"Report-Msgid-Bugs-To: gcl@packages.debian.org\n" +"POT-Creation-Date: 2012-12-30 11:53-0400\n" +"PO-Revision-Date: 2008-01-04 16:27+1030\n" +"Last-Translator: Clytie Siddall \n" +"Language-Team: Vietnamese \n" +"Language: vi\n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=UTF-8\n" +"Content-Transfer-Encoding: 8bit\n" +"Plural-Forms: nplurals=1; plural=0;\n" +"X-Generator: LocFactoryEditor 1.7b1\n" + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "Use the work-in-progress ANSI build by default?" +msgstr "Dùng bản xây dá»±ng đang phát triển ANSI theo mặc định không?" + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"GCL is in the process of providing an ANSI compliant image in addition to " +"its traditional CLtL1 image still in production use." +msgstr "" +"GCL đang phát triển chức năng cung cấp ảnh tùy theo ANSI thêm vào ảnh CLtL1 " +"truyền thống vẫn còn được sá»­ dụng trong trường hợp sản xuất." + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"Please see the README.Debian file for a brief description of these terms. " +"Choosing this option will determine which image will be used by default when " +"executing 'gcl@EXT@'." +msgstr "" +"Xem tài liệu Đọc Đi (README.Debian) để tìm mô tả ngắn về các thuật ngữ này. " +"Bật tùy chọn này thì xác định ảnh nào cần dùng theo mặc định khi thá»±c hiện " +"lệnh « gcl@EXT@ »." + +#. Type: boolean +#. Description +#: ../gcl.templates:2001 +msgid "" +"This setting may be overridden by setting the GCL_ANSI environment variable " +"to any non-empty string for the ANSI build, and to the empty string for the " +"CLtL1 build, e.g. GCL_ANSI=t gcl@EXT@. The currently enforced build flavor " +"will be reported in the initial startup banner." +msgstr "" +"Vẫn còn có thể ghi đè lên thiết lập này bằng cách đặt biến môi trường « " +"GCL_ANSI » thành bắt cứ chuỗi không rỗng cho bản xây dá»±ng ANSI, và cho chuỗi " +"rỗng cho bản xây dá»±ng CLtL1, v.d. « GCL_ANSI=t gcl@EXT@ ». Kiểu bản xây dá»±ng " +"hiện thời được chọn sẽ được thông báo trên băng cờ khởi chạy đầu tiên." + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "Use the profiling build by default?" +msgstr "Dùng bản xây dá»±ng đo hiệu năng sá»­ dụng theo mặc định không?" + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "GCL has optional support for profiling via gprof." +msgstr "GCL có hỗ trợ tùy chọn để đo hiệu năng sá»­ dụng thông qua gprof." + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "" +"Please see the documentation for si::gprof-start and si::gprof-quit for " +"details. As this build is slower than builds without gprof support, it is " +"not recommended for final production use." +msgstr "" +"Xem tài liệu hướng dẫn về « si::gprof-start » và « si::gprof-quit » để tìm " +"chi tiết. Vì bản xây dá»±ng này chạy chậm hÆ¡n các bản xây dá»±ng không hỗ trợ " +"gprof, không khuyên bạn sá»­ dụng nó trong trường hợp sản xuất cuối cùng." + +#. Type: boolean +#. Description +#: ../gcl.templates:3001 +msgid "" +"Set the GCL_PROF environment variable to the empty string for more optimized " +"builds, or any non-empty string for profiling support; e.g. GCL_PROF=t " +"gcl@EXT@. If profiling is enabled, this will be reported in the initial " +"startup banner." +msgstr "" +"Đặt biến môi trường « GCL_PROF » thành chuỗi rỗng cho các bản xây dá»±ng tối " +"Æ°u hÆ¡n, hoặc cho bất cứ chuỗi không rỗng nào để hỗ trợ chức năng đo hiệu " +"năng sá»­ dụng, v.d. « GCL_PROF=t gcl@EXT@ ». Hiệu lá»±c chức năng đo hiệu năng " +"sá»­ dụng thì nó được thông báo trên băng cờ khởi chạy đầu tiên." diff --git a/debian/rules b/debian/rules new file mode 100755 index 0000000..0697af4 --- /dev/null +++ b/debian/rules @@ -0,0 +1,268 @@ +#!/usr/bin/make -f +# Sample debian/rules that uses debhelper. +# GNU copyright 1997 by Joey Hess. +# +# This version is for a hypothetical package that builds an +# architecture-dependant package, as well as an architecture-independent +# package. + +# Uncomment this to turn on verbose mode. +#export DH_VERBOSE=1 + +# This is the debhelper compatability version to use. +ARCHT:=$(shell dpkg-architecture -qDEB_HOST_ARCH) + +MCC:=gcc +# ifeq ($(ARCHT),alpha) +# MCC:=gcc-4.6 +# endif +# ifeq ($(ARCHT),mips) +# MCC:=gcc-4.6 +# endif +# ifeq ($(ARCHT),mipsel) +# MCC:=gcc-4.6 +# endif +# ifeq ($(ARCHT),ia64) +# MCC:=gcc-4.6 +# endif +# ifeq ($(ARCHT),armel) +# MCC:=gcc-4.6 +# endif +# ifeq ($(ARCHT),armhf) +# MCC:=gcc-4.6 +# endif + +#RELOC=locbfd +#RELOC?=statsysbfd +RELOC?=custreloc +ifeq ($(ARCHT),ia64) +RELOC=dlopen +endif +# ifeq ($(ARCHT),ppc64) +# RELOC=dlopen +# endif +#ifeq ($(ARCHT),hppa) +#RELOC=dlopen +#endif + +GMP?= + +DEBUG= + +#ifeq ($(ARCHT),hppa) +#DEBUG=--enable-debug +#endif + +VERS=$(shell echo $$(cat majvers).$$(cat minvers)) +#EXT:=cvs + +CFG:=$(addsuffix /config.,.)# gmp4/configfsf. +# Bug in autoconf dependency on emacsen-common workaround +#CFGS:=$(addsuffix .ori,configure $(addsuffix guess,$(CFG)) $(addsuffix sub,$(CFG))) +CFGS:=$(addsuffix .ori,$(addsuffix guess,$(CFG)) $(addsuffix sub,$(CFG))) + +$(filter %.guess.ori,$(CFGS)): %.ori: /usr/share/misc/config.guess % + ! [ -e $* ] || [ -e $@ ] || cp $* $@ + [ $$($< -t | tr -d '-') -le $$(./$* -t | tr -d '-') ] || cp $< $* + touch $@ + +$(filter %.sub.ori,$(CFGS)): %.ori: /usr/share/misc/config.sub % + ! [ -e $* ] || [ -e $@ ] || cp $* $@ + [ $$($< -t | tr -d '-') -le $$(./$* -t | tr -d '-') ] || cp $< $* + touch $@ + +configure.ori: %.ori: configure.in + ! [ -e $* ] || [ -e $@ ] || cp $* $@ + cd $(@D) && autoconf + touch $@ + +configure-%-stamp: $(CFGS) + + dh_testdir + + ! [ -e unixport/saved_pre_gcl ] || $(MAKE) clean + +# chmod -R +x gmp4/* + + [ "$*" != "ansi" ] || FLAGS="--enable-ansi" ; \ + [ "$*" != "gprof" ] || FLAGS="--enable-gprof" ; \ + [ "$*" != "ansi-gprof" ] || FLAGS="--enable-ansi --enable-gprof" ; \ + eval `dpkg-buildflags --export=sh |sed -e 's,-O2,,g' -e 's,-g,,g'` && CC=$(MCC) ./configure \ + --host=$$(dpkg-architecture -qDEB_HOST_GNU_TYPE) \ + --disable-statsysbfd \ + --disable-custreloc \ + --disable-dlopen \ + --enable-prelink \ + --enable-$(RELOC) \ + $(GMP) \ + $(DEBUG) \ + $$FLAGS \ + --prefix=/usr \ + --mandir=\$${prefix}/share/man \ + --enable-infodir=\$${prefix}/share/info \ + --enable-emacsdir=\$${prefix}/share/emacs/site-lisp + + touch $@ + + +build-%-stamp: configure-%-stamp + dh_testdir + + $(MAKE) + + rm -rf debian/$* + mkdir -p debian/$* + $(MAKE) install DESTDIR=$$(pwd)/debian/$* + [ "$(findstring gprof,$*)" = "" ] || (\ + tmp=debian/$*; old=/usr/lib/gcl-$(VERS); new=$$old-prof;\ + if [ "$(findstring ansi,$*)" = "" ] ; then i=saved_gcl ; else i=saved_ansi_gcl ; fi;\ + mv $$tmp/$$old $$tmp/$$new ;\ + echo "(reset-sys-paths \"$$new/\")(si::save-system \"debian/tmp-image\")" | $$tmp/$$new/unixport/$$i &&\ + mv debian/tmp-image $$tmp/$$new/unixport/$$i;) + + touch $@ + +bclean-stamp: + $(MAKE) clean + touch $@ + +ansi-tests/test_results: build-ansi-stamp + $(MAKE) $@ + +build: build-arch build-indep +build-arch: build-stamp +build-indep: build-stamp +build-stamp: build-gprof-stamp build-ansi-gprof-stamp build-trad-stamp build-ansi-stamp ansi-tests/test_results + touch $@ + +debian/control.rm: + rm -f `echo $@ | sed 's,\.rm$$,,1'` + +debian/control: debian/control.rm + cp debian/control.$(EXT) debian/control + +clean: debian/control debian/gcl.templates + dh_testdir + dh_testroot + rm -f *stamp + debconf-updatepo + + $(MAKE) clean + + dh_clean + rm -rf debian/gprof debian/ansi-gprof debian/trad debian/ansi $(INS) debian/substvars debian.upstream + rm -rf *stamp + for i in $(CFGS) ; do ! [ -e $$i ] || mv $$i $${i%.ori} ; done + +INS:=$(shell for i in debian/in.* ; do echo $$i | sed 's,in.,,1' ; done |sed "s,gcl,gcl$(EXT),g") + +$(INS): debian/gcl$(EXT)% : debian/in.gcl% + cat $< | sed 's,@EXT@,$(EXT),g' >$@ + +install: install-stamp +install-stamp: build-stamp debian/control $(INS) + dh_testdir + dh_testroot + dh_clean -k + dh_installdirs + + mkdir -p debian/tmp + cp -a debian/ansi/* debian/tmp/ + cp -a debian/trad/* debian/tmp/ + cp -a debian/gprof/* debian/tmp/ + cp -a debian/ansi-gprof/* debian/tmp/ + + mv debian/tmp/usr/share/emacs/site-lisp debian/tmp/usr/share/emacs/foo + mkdir -p debian/tmp/usr/share/emacs/site-lisp + mv debian/tmp/usr/share/emacs/foo debian/tmp/usr/share/emacs/site-lisp/gcl$(EXT) + + cat debian/tmp/usr/share/emacs/site-lisp/gcl$(EXT)/gcl.el |\ + sed "s,(provide 'gcl),(provide 'gcl$(EXT)),1" >tmp &&\ + mv tmp debian/tmp/usr/share/emacs/site-lisp/gcl$(EXT)/gcl$(EXT).el + [ "$(EXT)" = "" ] || rm debian/tmp/usr/share/emacs/site-lisp/gcl$(EXT)/gcl.el + + cat debian/tmp/usr/share/emacs/site-lisp/gcl$(EXT)/dbl.el |\ + sed "s,(provide 'dbl),(provide 'dbl$(EXT)),1" >tmp &&\ + mv tmp debian/tmp/usr/share/emacs/site-lisp/gcl$(EXT)/dbl$(EXT).el + [ "$(EXT)" = "" ] || rm debian/tmp/usr/share/emacs/site-lisp/gcl$(EXT)/dbl.el + + [ "$(EXT)" = "" ] || \ + for i in debian/tmp/usr/share/info/*.info*; do \ + mv $$i $$(echo $$i | sed "s,gcl,gcl$(EXT),g"); done + + mv debian/tmp/usr/share/doc debian/tmp/usr/share/foo + mkdir -p debian/tmp/usr/share/doc/gcl-doc + mv debian/tmp/usr/share/foo/* debian/tmp/usr/share/doc/gcl-doc + rmdir debian/tmp/usr/share/foo + + [ "$(EXT)" = "" ] || \ + mv debian/tmp/usr/share/doc/gcl-doc debian/tmp/usr/share/doc/gcl$(EXT)-doc + + [ "$(EXT)" = "" ] || \ + (cat debian/tmp/usr/share/man/man1/gcl.1 |sed -e 's, gcl , gcl$(EXT) ,g' 's, GCL , GCL$(EXT) ,g' >debian/foo && \ + mv debian/foo debian/tmp/usr/share/man/man1/gcl$(EXT).1) + + cat debian/tmp/usr/lib/gcl-$(VERS)/gcl-tk/demos/index.lsp | \ + sed "s,$$(pwd)/debian/tmp,,1" >debian/foo + mv debian/foo debian/tmp/usr/lib/gcl-$(VERS)/gcl-tk/demos/index.lsp + + rm -f debian/tmp/usr/bin/*.exe debian/tmp/usr/bin/*.bat + + find debian/tmp -type f -name "*.lsp" -exec chmod ugo-x {} \; + find debian/tmp -type f -name "*.lisp" -exec chmod ugo-x {} \; + find debian/tmp -type f -name "*.el" -exec chmod ugo-x {} \; + find debian/tmp -type f -name "*.tcl" -exec chmod ugo-x {} \; + + rm -f debian/tmp/usr/bin/gcl + TKVERS=$$(cat bin/gcl | grep /tk | head -1l | sed "s,.*/tk\([0-9.]*\)\").*,\1,1"); \ + cat debian/gcl.sh | sed -e "s,@EXT@,$(EXT),g" \ + -e "s,@VERS@,$(VERS),g" \ + -e "s,@TKVERS@,$$TKVERS,g" >debian/tmp/usr/bin/gcl$(EXT) + chmod 0755 debian/tmp/usr/bin/gcl$(EXT) + + rm -rf debian/tmp/usr/lib/gcl-$(VERS)/info + + dh_install + + touch $@ + +# Build architecture-independent files here. +# Pass -i to all debhelper commands in this target to reduce clutter. +binary-indep: build install + dh_testdir -i + dh_testroot -i + dh_installdocs -i + dh_installinfo -i + dh_installchangelogs ChangeLog -i + dh_link -i + dh_compress -i + dh_fixperms -i + dh_installdeb -i + dh_gencontrol -i + dh_md5sums -i + dh_builddeb -i + +binary-arch: build install #debian/substvars + dh_testdir -a + dh_testroot -a + dh_installdocs -a -XRELEASE-2.6.2.html + dh_installemacsen -a + dh_installman -a + dh_installdebconf -a + sed -i -e 's,@EXT@,$(EXT),g' debian/gcl$(EXT)/DEBIAN/templates + dh_installchangelogs ChangeLog -a + dh_strip -a -Xlibgcl -Xlibansi_gcl \ + -Xgcl-$(VERS)-prof/unixport/saved_gcl -Xgcl-$(VERS)-prof/unixport/saved_ansi_gcl + dh_lintian -a + dh_link -a + dh_compress -a + dh_fixperms -a + dh_installdeb -a + dh_shlibdeps -a + dh_gencontrol -a -u"-Vgcc=$(MCC)" + dh_md5sums -a + dh_builddeb -a + +binary: binary-indep binary-arch +.PHONY: build clean binary-indep binary-arch binary install configure +.PRECIOUS: configure-trad-stamp configure-ansi-stamp configure-gprof-stamp configure-ansi-gprof-stamp diff --git a/debian/source/format b/debian/source/format new file mode 100644 index 0000000..163aaf8 --- /dev/null +++ b/debian/source/format @@ -0,0 +1 @@ +3.0 (quilt) diff --git a/debian/source/include-binaries b/debian/source/include-binaries new file mode 100644 index 0000000..0fe3009 --- /dev/null +++ b/debian/source/include-binaries @@ -0,0 +1,3 @@ +info/gcl-si.pdf +info/gcl-tk.pdf +xgcl-2/dwdoc.pdf diff --git a/debian/texi.awk b/debian/texi.awk new file mode 100755 index 0000000..ccf9cdb --- /dev/null +++ b/debian/texi.awk @@ -0,0 +1,27 @@ +#!/usr/bin/awk -f + +/^@defun/ { + a=split($0,A,"("); + b=split($0,B,")"); + if (a==b) + print ; + else { + i=1; + c=$0; + } + next; +} +{ + if (i) { + sub("^ *",""); + c=c " " $0; + a=split(c,A,"("); + b=split(c,B,")"); + if (a==b) { + print c; + c=""; + i=0; + } + } else + print; +} diff --git a/debian/upstream/signing-key.asc b/debian/upstream/signing-key.asc new file mode 100644 index 0000000..741d314 --- /dev/null +++ b/debian/upstream/signing-key.asc @@ -0,0 +1,88 @@ +-----BEGIN PGP PUBLIC KEY BLOCK----- +Version: GnuPG v1 + +mQGiBD1mWk0RBADdQYIiaNJJOHAZdBpzOBm31v5AlQa1jjYx1W6zKd+ECqZVdonw +e+CP/qpVCUXRYmQ3v/ZYpINtcRR2IckTQCs4fvYUAuQir2cpKmRqImnGhzFJ1pd9 +Rf2aqPspycMx9IlqKkeY1LwNahitQ93YwyCT1HUCTB0hIuNMtFNte18DpwCgwbYP +bBuLYCG/8g+MqoG7SBhN4hkEANafxrX2EEwUCpQlKGkw4P18wCinbs7tjgXwL7SK +WV9qpIDkUEnW2cnzfDBrNW24LtHt0qMsGa8sCJW30ZPUv0sebsyzVTJR0O5g6Lpi +zlznB1LtmbkDdd79R4Qrs01k+2OK2K0r54xnOlL+ZZQFamP3jvTZAKxyUGI2Fiqu +1O7OA/4xp5/WNyuIUWUho+nfhp0sakzAiC1aBHLtAvhL470sBm3xojM6w3vicTT2 +7rnzS1teeUnCOMK+CUzzITXHrnljCkyg8d6QqtlWJCc4T6tTYJNOuWte3AckYDaF +4HhJbwNamrDGKQJ0kYOqtquz5WE8EjkxwglRQSrGanxMXnCsB7QgQ2FtbSBNYWd1 +aXJlIDxjYW1tQGVuaGFuY2VkLmNvbT6IXwQTEQIAFwUCPWZaTQULBwoDBAMVAwID +FgIBAheAABIJEHMxtcBX8EXcB2VHUEcAAQFCkQCeL84DKju0u23VHI2a9S3CZwpw +cEMAn03Jgjje37YEbLCnfh/JN4zhcUeFiQCVAwUQPXktv1RjAAQhp2rpAQEynwP5 +AZT5Fmlc6FbnVeusUNz1jtEKysdFc7TBFZSdWK2ftjuQiiiYgLOSM6kLpc6DJxLU +0gc6FmQCme1G3wnQFpi5GXFlYcW5mfe3V5/0Paxcc/CijULb4IRU41KO3tTy7wpY +NARRB5I+MeLT39bpqljO0b7PRETncVnXgkm5PEJGV3C0HkNhbW0gTWFndWlyZSA8 +Y2FtbUBkZWJpYW4ub3JnPohgBBMRAgAgBQJJmevSAhsjBgsJCAcDAgQVAggDBBYC +AwECHgECF4AACgkQczG1wFfwRdxZywCeLfMYW3CQAi8e0C8NAauuIpZJx+wAoJAW +eBe0arj/lrwecpn26l63nC5KuQENBD1mWk4QBADRBvXyQ0uxFCkac7ZVSuwEJrbw +NdhS3ossQi+gm8aDPSokKFASs75SLNQMfIRhyToGcyplP75OYaMxvyih7DFGBLoB +kzCuhBJ09VgLC0BiuJAtEI5orQf9sNt7CwBEG2KZ/X4oHXmKitgP0F4xff9XociT +ZusPI90z9yg2treJ4wADBQP/aDZ839IYpwL6ZDZ8faVtgMz65lKaFkLzi/2pHWao +SEWYiGcLozizNt+w+qcyMGUDNkDMtTY0Y9cbC8Dn7r/0/CZW1UQ2D3fSeAfsgxEE +PnYYFiFr0Xyi+oDu7fkcV9wQdqLZ6OvR0SZqoJwLdmJqjTzz1TJTOfdTcSV/+POJ +qCuITgQYEQIABgUCPWZaTgASCRBzMbXAV/BF3AdlR1BHAAEBn/kAn2saGr0hmMfO +Nn4j36onyp18oNqYAKCTJZU26kWZcORo+FbyOMQ3+Yd8EZkBogQ6A9NcEQQAiUvw +61oHv/VZvl8uo5hTAaka2HEfECf5aMvG7N1ytUXzKTldnyEBGiqOdbLtF1wL2SUV +rdhX0VhH0fi19K2graTGqSQYzdA7uIIOQHOAZ5py5mKQr9zFkKyf5W4RKAbTIUAS +uTlSy1NiyKPMXdBlu0f5rkl/m5KODlf1nVtDposAoPuMTY9/D/cOqzB4fmEQ6gMG +M2/PA/9nHj4Mow5EkvSLsuAkn/mpI0Rv+ly1pmKJtbsJZIs1PWk/J47TRVigUgft +LOlfYMAHXwfF6svodOKF0eOaBjeZmyu1KnDDy9EWWhZwdoT08AD664/bbN1goNzE +XFlfD83yPWa1VrPNME2fq6jdY/WKZB5+viKu7yaMGGwQfjg9EwP/QCbz4cZvUiF5 +SmlI3u8+wgThk3DXnL9L3GlOASacET6wRFX6C3HYnRBTB0EypYJoUPIj7rt/Ptyl +CRHQtMUuSouyq/Smj5ybw8kvGRRH4SgfoghjL+q+sVGwIZiUQXu+g96vSSBuQTE2 +x8iZ8mXpPud7jjMc98CfjiB9/ujnqK+0MEVyaWMgU2hhcmtleSA8c2hhcmtleUBz +dXBlcmsucGh5c2ljcy5zdW55c2IuZWR1PohfBBMRAgAXBQI6A9NcBQsHCgMEAxUD +AgMWAgECF4AAEgkQclUlAyIk+rwHZUdQRwABAcGdAJ45RrdVItJxXhDiCWeXpHKq +DfkBIQCg97TpqcIbuDGD1r8gkSb6ErXA+4SJAJUDBRA6L65Bj/xAXv1aZ80BAVlU +A/oD8wBcQeTD3HzeBcK6SVygQZlQS2g8v7H4G91Fu9yTESbDdYLjmybniGwTgS7q +0/RbQDRCmh+fyBD38CmB2B23VdpXRYaChDeKTP+Lvg+mQn9zdMFkERD2/W40+TID +1g7lafk3XDe+dOX59Ie0qeCXcccsv8OfhJwoEwHKPC9ZeIhGBBARAgAGBQI87l/I +AAoJEHIxQb2lt4IBM5MAnj9wqSGdaLTfHAQb7xk36abh0vboAJwIGkIMfE7HkvbX +9nXqefmNfrns3IhGBBARAgAGBQI9eSPnAAoJEHMxtcBX8EXcnq8An2DneOdg2qBr +xF5ZBzEfGBcZHMbCAJ0Z+QKVo1/XQUVcHbGrHo+kF4IfmrQhRXJpYyBTaGFya2V5 +IDxzaGFya2V5QGRlYmlhbi5vcmc+iF8EExECABcFAjo5dzoFCwcKAwQDFQMCAxYC +AQIXgAASCRByVSUDIiT6vAdlR1BHAAEBo0MAoKXjeu7EYrx9uSrlC6rQHavvmq1u +AJsFXSfzM+lgT5lO9a3K0/N+Wr4ZRIhGBBARAgAGBQI87l/fAAoJEHIxQb2lt4IB +8BgAn3ZJz4t/JBnRhEB2I0BA5CiIxKtAAKCf5FHs+3/1vYmhtAX3ouSWyN0jFIhG +BBARAgAGBQI9eSPtAAoJEHMxtcBX8EXci7YAnRnwG8BddR4vdcvNGewRxCxweOrz +AKCgcm8lYWrd0Ubz4/CtelbxA16yV7kBDQQ6A9NrEAQAyXOKw6Zg+VjOiw10ZKtP +mQNmkEA5qUcGgcXKIPwwZ8sMZLzsqzdSM6UVwlN/1D/kH9U5Lkh1LqUxQ+NVC5Qm +bGV+Wq52I9id/lpYycfxNkjURk/wXnOdFCY55pJiS2851DiCBpNC/ClFZZe1Yhdd +HhUFnJrGRjaKTMoKI3sWUDsAAwYEAIuBP5eMx8I4qzVrt9tgDEx9LZZyd18jqC42 +FcMesLMdUi/UKOzrSr/tQ/eiOVMai/RUMmtoyvJzm6bt4UsO54Ynhhul4ySreB4h +4TA7C9vKYTvPmZ5hsOAmguhtvkGOiN+7cXUa35xpL1dbBjelJR8cSFJtAQn2PKkJ +JeS6N4LHiE4EGBECAAYFAjoD02sAEgkQclUlAyIk+rwHZUdQRwABAS1yAJwO6YAP +f1tU5MvrXRbHC52/dn82kgCgkxPi+HiFgqOc1FCfMByu9ZvzwGaZAaIEPKkVqhEE +AMqWl8BYusXdZEt7EE7gDfTtYgCCREiy3B2jTERJ4DXP0hPQDxBOQh6AW0JCtcxT +vuNOZnAlMqXKPvV4tc55dSYTBYW6U2ySN+xrHi9GvS9k5JjpsZdstS5MVkTppOS0 +nTEBw8KofAHBfFpwisCsz38P5ehLnbpm1M7WNXGxmvDTAKDFxuwQL9S8gRUhXIS3 +kAOkDW2eTwP+I5Xil4aIAUnw/JVUaP7wRGUYnFnIisgPftZ+k+R/RfirSlnpPMZr +cqC8JpR0Zm2jQ7jSzTdjj4yFM0PTdUg3mUo5IANd31XshDO7utppX8QBQ9c9PYml +PSVZTRLiDT50HB4rjsoLTlYQOMsFxG4v9v6ybKCvhmZRvD1J97Q5EEsD/3V+Kor5 +8j72RZwrjTspT7roljxyly5D/p6dqiNFLOHjjfuj3SYah7TAlAxtb7CFGsPdNJJf +jZvb//IzZw7XNG1EU9+PaV6mbTZNbrXavbKrIkz6AnLB9GDFE1oDWv7c2b5v5HVv +SO/hakFEDcgxSPzkMVkc7wGOq+6kClG8z2DMtC1CcmlhbiBSIEZ1cnJ5IChUcnVz +dCBObyBPbmUpIDxmYnJpYW5AbmFjLm5ldD6IZQQTEQIAHQUCPKkVqgUJBaOagAUL +BwoDBAMVAwIDFgIBAheAABIJEHIxQb2lt4IBB2VHUEcAAQHvmwCfV6KEnp4tIKHz +dZwBGsqnlKSBkpcAmgNdv300le8RtsGdhsDCRT6cUl1TiEYEEBECAAYFAjzqw3EA +CgkQclUlAyIk+rw0sgCg6jCNQKL71DqAifPm6o07tkkYoc0An3duMoIdm9g2qV2d +OSOpJn63WXKoiEYEEBECAAYFAj15JjIACgkQczG1wFfwRdyRHQCeK2xhxX1ccxDG +DzMYZKivG5uUdBoAnRJ62vbPCyQ1I9ihAf1nzygCdxrytC1CcmlhbiBSIEZ1cnJ5 +IChUcnVzdCBObyBPbmUpIDxiZnVycnlAbmFjLm5ldD6IZQQTEQIAHQUCPUsJiQUJ +BaOagAULBwoDBAMVAwIDFgIBAheAABIJEHIxQb2lt4IBB2VHUEcAAQHzcACfeVya +lc6NRe3Kle9aX9AXxljfdnUAniXqub/sS6WetxJwKrivk3WhyQnEiEYEEBECAAYF +Aj15JjgACgkQczG1wFfwRdxRyACgv7su7KfZvI07M31IcMtS0PHL4L4AoL5wr/os +n198CXGT8C5eXCRBVa8zuQENBDypFbgQBAC3VMeu+Qsa4IlZzzvFeB9sbnIr7e6P +TWuTR3EUnOzEd/h5k/bDdLW11uDnXyhbMSOXzGJaB9HbW5NXUuHIzTEwDzP+/hSJ +HNhc3YXREOs4YMrexeTgKEE3RFJ/ulTJ2EvTVdb7+uwKEMctKC+xaK/cIiRZt8Fg +Da1KjYBnpr5DvwADBQP5AaCubKcP0z202ys6EuvY/xIgYxJ95x/ermkV91cur7e1 +J9NqLOdbgj/yLcco9T92IBMm7zAnzDEtPC7UaqvrtuISvWc+z48Lk19AN7JOOH+g +2oIvspF4Gj2RVc7vijh7gMav5tIflZxqNi2U/QFYqgVTnE0facclV3w2IpMPUpyI +VAQYEQIADAUCPKkVuAUJBaOagAASCRByMUG9pbeCAQdlR1BHAAEB+GUAn0etwV2m +fUKduxyMlCzpoCtLBzy3AJ99bcVPGhgGkpMktMMRlLjPXiLgGA== +=tBlv +-----END PGP PUBLIC KEY BLOCK----- diff --git a/debian/watch b/debian/watch new file mode 100644 index 0000000..4daeb72 --- /dev/null +++ b/debian/watch @@ -0,0 +1,2 @@ +version=2 +options=pasv,pgpsigurlmangle=s/$/.sig/ ftp://ftp.gnu.org/pub/gnu/gcl gcl-([0-9.]*).tar.gz debian uupdate diff --git a/doc/bignum b/doc/bignum new file mode 100644 index 0000000..8a98dc1 --- /dev/null +++ b/doc/bignum @@ -0,0 +1,60 @@ + + +A directory mp was added to hold the new multi precision arithmetic +code. The layout and a fair amount of code in the mp directory is an +enhanced version of gpari version 34. The gpari c code was rewritten +to be more efficient, and gcc assembler macros were added to allow +inlining of operations not possible to do in C. On a 68K machine, +this allows the C version to be as efficient as the very carefully +written assembler in the gpari distribution. For the main machines, +an assembler file (produced by gcc) based on this new method, is +included. This is for sites which do not have gcc, or do not +wish to compile the whole system with gcc. + +Bignum arithmetic is much faster now. Many changes were made to +cmpnew also, to add 'integer' as a new type. It differs from +variables of other types, in that storage is associated to each such +variable, and assignments mean copying the storage. This allows a +function which does a good deal of bignum arithmetic, to do very +little consing in the heap. An example is the computation of PI-INV +in scratchpad, which calculates the inverse of pi to a prescribed +number of bits accuracy. That function is now about 20 times faster, +and no longer causes garbage collection. In versions of AKCL where +HAVE_ALLOCA is defined, the temporary storage growth is on the C +stack, although this often not so critical (for example it makes +virtually no difference in the PI-INV example, since in spite of the +many operations, only one storage allocation takes place. + +Below is the actual code for PI-INV + +On a sun3/280 (cli.com) + +Here is the comparison of lucid and akcl before and after +on that pi-inv. Times are in seconds with multiples of the +akcl time in parentheses. + +On a sun3/280 (cli.com) + +pi-inv akcl-566 franz lucid old kcl/akcl +---------------------------------------- +10000 3.3 9.2(2.8 X) 15.3 (4.6X) 92.7 (29.5 X) +20000 12.7 31.0(2.4 X) 62.2 (4.9X) 580.0 (45.5 X) + + +(defun pi-inv (bits &aux (m 0)) + (declare (integer bits m)) + (let* ((n (+ bits (integer-length bits) 11)) + (tt (truncate (ash 1 n) 882)) + (d (* 4 882 882)) + (s 0)) + (declare (integer s d tt n)) + (do ((i 2 (+ i 2)) + (j 1123 (+ j 21460))) + ((zerop tt) (cons s (- (+ n 2)))) + (declare (integer i j)) + (setq s (+ s (* j tt)) + m (- (* (- i 1) (- (* 2 i) 1) (- (* 2 i) 3))) + tt (truncate (* m tt) (* d (the integer (expt i 3)))))))) + + + diff --git a/doc/c-gc b/doc/c-gc new file mode 100644 index 0000000..1b980dc --- /dev/null +++ b/doc/c-gc @@ -0,0 +1,39 @@ + +We have implemented garbage collection of the c stack. +Thus any new cons or other data type, may be safely left +on the c stack or in a register, without fear of lossage +due to garbage collection. This enables us to write smaller +faster code. We have implemented a scheme for putting +frequently used variables, and those inside loops, into registers. +For example the compiled sloop.lsp file now has text size +48704, but had text size 53120 or 1.09 times larger. + +If functions are proclaimed to be of fixed number of args, +the code is also substantially better. For example if you +have the code: + +(proclaim '(function memb (t t) t)) +(defun memb (a b) + (sloop for v on b when (eq (car v) a) do (return v))) + + + +If we consider calls where a is the 4'th element of b, +then memb runs two times faster than before: On a sun 3-50 +19.6 seconds for 1,000,000 iterations, as opposed to 39.6 seconds +without the new modifications to c-gc and the compiler. + + +(defun try (n a b) (sloop for i below n do (memb a b))) + +Currently if the variable compiler::*c-gc* is not nil, +the compiler outputs code under the assumption that c-gc is working. +Very bad results would occur if such object code were loaded into a +kcl which did not examine the c stack. Also if you are wishing +to produce C code for use in an implementation without c-gc +you should set *c-gc* to nil. + + + + + diff --git a/doc/c-gc.doc b/doc/c-gc.doc new file mode 100644 index 0000000..7872d9a --- /dev/null +++ b/doc/c-gc.doc @@ -0,0 +1,32 @@ + +We have implemented garbage collection of the c stack. +Thus any new cons or other data type, may be safely left +on the c stack or in a register, without fear of lossage +due to garbage collection. This enables us to write smaller +faster code. We have implemented a scheme for putting +frequently used variables, and those inside loops, into registers. +For example the compiled sloop.lsp file now has text size +48704, but had text size 53120 or 1.09 times larger. + +If functions are proclaimed to be of fixed number of args, +the code is also substantially better. For example if you +have the code: + +(proclaim '(function memb (t t) t)) +(defun memb (a b) + (sloop for v on b when (eq (car v) a) do (return v))) + + + +If we consider calls where a is the 4'th element of b, +then memb runs two times faster than before: On a sun 3-50 +19.6 seconds for 1,000,000 iterations, as opposed to 39.6 seconds +without the new modifications to c-gc and the compiler. + + +(defun try (n a b) (sloop for i below n do (memb a b))) + +Currently if the variable compiler::*c-gc* is not nil, +the compiler outputs code under the assumption that c-gc is working. + + diff --git a/doc/compile-file-handling-of-top-level-forms b/doc/compile-file-handling-of-top-level-forms new file mode 100644 index 0000000..7609dc6 --- /dev/null +++ b/doc/compile-file-handling-of-top-level-forms @@ -0,0 +1,222 @@ +Forum: Compiler +Issue: COMPILE-FILE-HANDLING-OF-TOP-LEVEL-FORMS +References: CLtL pages 66-70, 143 +Category: CLARIFICATION +Edit history: V1, 07 Oct 1987 Sandra Loosemore + V2, 15 Oct 1987 Sandra Loosemore + V3, 15 Jan 1988 Sandra Loosemore + V4, 06 May 1988 Sandra Loosemore + V5, 20 May 1988 Sandra Loosemore + V6, 09 Jun 1988 Sandra Loosemore + V7, 16 Dec 1988 Sandra Loosemore + (Comments from Pitman, change DEFCONSTANT, etc.) + V8, 31 Dec 1988 Sandra Loosemore + (CLOS additions, etc.) + V9, 23 Jan 1989 Sandra Loosemore + (remove the CLOS additions again) +Status: Proposal CLARIFY passed Jan 89 + + +Problem Description: + +Standard programming practices assume that, when calls to defining +macros such as DEFMACRO and DEFVAR are processed by COMPILE-FILE, +certain side-effects occur that affect how subsequent forms in the +file are compiled. However, these side-effects are not mentioned in +CLtL, except for a passing mention that macro definitions must be +``seen'' by the compiler before it can compile calls to those macros +correctly. In order to write portable programs, users must know +exactly which defining macros have compile-time side-effects and what +those side-effects are. + +Inter-file compilation dependencies are distinct from, and not +addressed by, this issue. + + +Proposal: COMPILE-FILE-HANDLING-OF-TOP-LEVEL-FORMS:CLARIFY + +(1) Clarify that defining macros such as DEFMACRO or DEFVAR, appearing + within a file being processed by COMPILE-FILE, normally have + compile-time side effects which affect how subsequent forms in the + same file are compiled. A convenient model for explaining how these + side effects happen is that the defining macro expands into one or + more EVAL-WHEN forms, and that the calls which cause the compile-time + side effects to happen appear in the body of an (EVAL-WHEN (COMPILE) + ...) form. + +(2) The affected defining macros and their specific side effects are + as follows. In each case, it is identified what users must do to + ensure that their programs are conforming, and what compilers must do + in order to correctly process a conforming program. + + DEFTYPE: Users must ensure that the body of a DEFTYPE form is + evaluable at compile time if the type is referenced in subsequent type + declarations. The compiler must ensure that the DEFTYPE'd type + specifier is recognized in subsequent type declarations. If the + expansion of a type specifier is not defined fully at compile time + (perhaps because it expands into an unknown type specifier or a + SATISFIES of a named function that isn't defined in the compile-time + environment), an implementation may ignore any references to this type + in declarations and/or signal a warning. + + DEFMACRO, DEFINE-MODIFY-MACRO: The compiler must store macro + definitions at compile time, so that occurrences of the macro later on + in the file can be expanded correctly. Users must ensure that the + body of the macro is evaluable at compile time if it is referenced + within the file being compiled. + + DEFUN: DEFUN is not required to perform any compile-time side effects. + In particular, DEFUN does not make the function definition available + at compile time. An implementation may choose to store information + about the function for the purposes of compile-time error-checking + (such as checking the number of arguments on calls), or to enable the + function to be expanded inline. + + DEFVAR, DEFPARAMETER: The compiler must recognize that the variables + named by these forms have been proclaimed special. However, it must + not evaluate the initial value form or SETQ the variable at compile + time. + + DEFCONSTANT: The compiler must recognize that the symbol names a + constant. An implementation may choose to evaluate the value-form at + compile time, load time, or both. Therefore users must ensure that + the value-form is evaluable at compile time (regardless of whether or + not references to the constant appear in the file) and that it always + evaluates to the same value. + + DEFSETF, DEFINE-SETF-METHOD: The compiler must make SETF methods + available so that it may be used to expand calls to SETF later on in + the file. Users must ensure that the body of DEFINE-SETF-METHOD and + the complex form of DEFSETF are evaluable at compile time if the + corresponding place is referred to in a subsequent SETF in the same + file. The compiler must make these SETF methods available to + compile-time calls to GET-SETF-METHOD when its environment argument is + a value received as the &ENVIRONMENT parameter of a macro. + + DEFSTRUCT: The compiler must make the structure type name recognized + as a valid type name in subsequent declarations (as for DEFTYPE) and + make the structure slot accessors known to SETF. In addition, the + compiler must save enough information about the structure type so that + further DEFSTRUCT definitions can :INCLUDE a structure type defined + earlier in the file being compiled. The functions which DEFSTRUCT + generates are not defined in the compile time environment, although + the compiler may save enough information about the functions to code + subsequent calls inline. The #S reader syntax may or may not be + available at compile time. + + DEFINE-CONDITION: The rules are essentially the same as those for + DEFSTRUCT; the compiler must make the condition type recognizable as a + valid type name, and it must be possible to reference the condition + type as the parent-type of another condition type in a subsequent + DEFINE-CONDITION in the file being compiled. + + DEFPACKAGE: All of the actions normally performed by this macro at load + time must also be performed at compile time. + + +(3) The compile-time side effects may cause information about the + definition to be stored differently than if the defining macro had + been processed in the "normal" way (either interpretively or by loading + the compiled file). + + In particular, the information stored by the defining macros at + compile time may or may not be available to the interpreter (either + during or after compilation), or during subsequent calls to COMPILE or + COMPILE-FILE. For example, the following code is nonportable because + it assumes that the compiler stores the macro definition of FOO where + it is available to the interpreter: + + (defmacro foo (x) `(car ,x)) + (eval-when (eval compile load) + (print (foo '(a b c)))) + + A portable way to do the same thing would be to include the macro + definition inside the EVAL-WHEN: + + (eval-when (eval compile load) + (defmacro foo (x) `(car ,x)) + (print (foo '(a b c)))) + + + +Rationale: + +The proposal generally reflects standard programming practices. The +primary purpose of the proposal is to make an explicit statement that +CL supports the behavior that most programmers expect and many +implementations already provide. + +The primary point of controversy on this issue has been the treatment +of the initial value form by DEFCONSTANT, where there is considerable +variance between implementations. The effect of the current wording is +to legitimize all of the variants. + + +Current Practice: + +Many (probably most) Common Lisp implementations, including VaxLisp +and Lucid Lisp, are already largely in conformance. + +In VaxLisp, macro definitions that occur as a side effect of compiling +a DEFMACRO form are available to the compiler (even on subsequent +calls to COMPILE or COMPILE-FILE), but are not available to the +interpreter (even within the file being compiled). + +By default, Kyoto Common Lisp evaluates *all* top level forms as they +are compiled, which is clearly in violation of the behavior specified +on p 69-70 of CLtL. There is a flag to disable the compile-time +evaluation, but then macros such as DEFMACRO, DEFVAR, etc. do not make +their definitions available at compile-time either. + + +Cost to implementors: + +The intent of the proposal is specifically not to require the compiler +to have special knowledge about each of these macros. In +implementations whose compilers do not treat these macros as special +forms, it should be fairly straightforward to use EVAL-WHENs in their +expansions to obtain the desired compile-time side effects. + + +Cost to users: + +Since CLtL does not specify whether and what compile-time side-effects +happen, any user code which relies on them is, strictly speaking, +nonportable. In practice, however, most programmers already expect +most of the behavior described in this proposal and will not find it +to be an incompatible change. + + +Benefits: + +Adoption of the proposal will provide more definite guidelines on how +to write programs that will compile correctly under all CL +implementations. + + +Discussion: + +Reaction to a preliminary version of this proposal on the common-lisp +mailing list was overwhelmingly positive. More than one person +responded with comments to the effect of "but doesn't CLtL already +*say* that somewhere?!?" Others have since expressed a more lukewarm +approval. + +It has been suggested that this proposal should also include PROCLAIM. +However, since PROCLAIM is not a macro, its compile-time side effects +cannot be handled using the EVAL-WHEN mechanism. A separate proposal +seems more appropriate. + +Item (3) allows for significant deviations between implementations. +While there is some sentiment to the effect that the compiler should +store definitions in a manner identical to that of the interpreter, +other people believe strongly that compiler side-effects should be +completely invisible to the interpreter. The author is of the opinion +that since this is a controversial issue, further attempts to restrict +this behavior should be considered as separate proposals. + +It should be noted that user-written code-analysis programs must +generally treat these defining macros as special forms and perform +similar "compile-time" actions in order to correctly process +conforming programs. + diff --git a/doc/contributors b/doc/contributors new file mode 100644 index 0000000..ce5c067 --- /dev/null +++ b/doc/contributors @@ -0,0 +1,41 @@ + +sgi port was done by Eric Raible raible@orville.nas.nasa.gov + +thanks to Blewett (blewett@cinnamon.att.com) for +help in the initial stage of the sun4 port. + +Thanks to gabor@vuse.vanderbilt.edu for a good deal of work on the hp port. + +Thanks to riley@att.com for several suggestions, fixes and bug reports. + +Thanks to andrew@COMP.VUW.AC.NZ for several suggestions and help with hp bsd. + +Thanks to Doug Katzman for parts of the Iris 4D port. + +Thanks to pierson@encore.com for an encore port [which I unfortunately +did not integrate yet]. + +Thanks for Mike Sundt at washington, for updates on the vax port. + +Thanks to Richard Harris harrisr@turing.cs.rpi.edu for many bug +reports and fixes, as well as error handling code (available from him), +and for work on pcl. + +Thanks to BABECOOL for the gpari code. + +gene@corwin.CCS.Northeastern.EDU (gene cooperman) several bugs and bug fixes. + +Thanks to luke tierney luke@umnstat.stat.umn.edu for a bug fix. + +tomwe@comm.mot.com (Thomas Weigert) for the mac2 port to aux. + +Thanks to Noritake Yonezawa for NeXT port (yone@vcdew25.lsi.tmg.nec.CO.JP) + +Thanks to Rami Charif rcharif@math.utexas.edu for much of the work on the dos port + +Thanks to Bob Boyer boyer@cs.utexas.edu for innumerable suggestions and encouragement + +Thanks to Matteo Frigo who did work on an early linux port. + +Thanks to Bill Metzenthen for linux elf work (billm@jacobi.maths.monash.edu.au) + diff --git a/doc/debug b/doc/debug new file mode 100644 index 0000000..3ce0acb --- /dev/null +++ b/doc/debug @@ -0,0 +1,28 @@ +New Debugging Features: + +Search-stack: +(:s "cal") or (:s 'cal) searches the stack for a frame whose function or +special form has a name containing "cal", moves there to display the local +data. + +Break-locals: +:bl displays the args and locals of the current function. +(:bl 4) does this for 4 functions. + +(si:loc i) accesses the local(i): slot. +the *print-level* and *print-depth* are bound to si::*debug-print-level* + +Recall that kcl permits movement to previous frame (:p) and next frame (:n). +These also take numeric args eg. (:p 7) moves up 7 frames. + +If functions are interpreted, the arg values are displayed together +with their names. If the functions are using the C stack (ie proclaimed +functions), very little information is available. + + +Note you must have space < 3 in your optimize proclamation, in order for +the local variable names to be saved by the compiler. + +To Do: add setf method for si:loc. +add restart capability from various spots on the stack. + diff --git a/doc/enhancements b/doc/enhancements new file mode 100644 index 0000000..fa9036e --- /dev/null +++ b/doc/enhancements @@ -0,0 +1,146 @@ + + +@chapter Loading Object Code + +We will outline some of the features of the object loader, by William +Schelter. + +When you do @code{(load "foo.o")} the output from the C compiler, +must be loaded into static space in the running KCL, and references +to external symbols must be resolved. Originally KCL used the +loader from the underlying lisp system, calling it in a subshell, +to produce yet another file, which had the correct references +to externals. This was then read into kcl. The data vector (a lisp +readable vector at the end of the object file) was also read into KCL. + +Unfortunately some operating systems (such as System V) do not supply +a loader capable of doing this relocation, and in any event it is fairly +slow. Also there was no possiblity of incrementally adding new external +C symbols to an already running lisp, and then having future files refer +to them. For example you might have a function @code{search1} written +in C, which you wished to access directly in subsequently loaded files. +This was not possible since the loader only knew about the addresses +of the external symbols in the original saved image. + +The new scheme builds a list of the external symbols into a table +called @code{c_table}. This table is built by examining the current image. +It will be built automatically with the first call to load. Subsequent +calls just use this table. Of course there is the additional benefit, +that it is easy to add additional symbols to the table. + +For example if you have a file @file{try.c} which looks like + +@code@{init_code() +add_symbols(joe,&joe,pete,&pete,NULL); +@} + +joe(x) +object x +@{...@} + +pete() +@{...@} +} + +then joe and pete will be added to the symbol table of the current kcl. +You may refer to them as external variables in subsequent files, and +these files will load correctly, referencing these variables. It is an error +apply add_symbol twice, to the same variable. + +The loading of files has speeded up considerably, so that a small file +with only a few small functions in it, can be loaded in less than .05 seconds. + + +@chapter Metering and Profiling + +KCL utilities have been added, by W. Schelter, to allow one to +determine the percentage of time spent in individual functions. + +Usage involves deciding which block of code one wishes to profile, +that is to say what address range, and then allocating an appropriate +size @code{*profile-array*}. For example in the Sun version, if you +have loaded a few object files, then if you wish to meter all of kcl +and the files which you loaded you could allocate a 1 megabyte array. +This would give a roughly 2 to one reduction relative to the code +address range. Note that the loader prints out the address at which +code is loaded. There is also a function @code{si@:function-start +(fun)} which returns the start address of a compiled function. + +In the above example after loading the file lsp/profile.o you +could do +@code{(si:set-up-profile 1000000)} + +This allocates the 1 megabyte array, and also reads in the c symbol +table, if this has not already been done. It also gets the addresses +of all compiled function objects currently in the image, and keeps +them in a table. This table is called @code{combined_table} at the C +level. The function @code{si:set-up-combined (size-of-table)} sets up +a combined table for the lisp and C functions. This function is +called by the previous @code{si:set-up-profile} function, with a +default size-of-table of 6000. + +Now to turn profiling on you do @code{(si::prof 0 90)}. This will +start metering all addresses in the range of 0 (the first arg) to +1,000,000 * (256/90), where 90 is the second arg. To display the data +collected so far you can invoke @code{si::display-profile} with no +arguments. In order to clear the profile array you run +@code{(si::clear)}. A call of @(si::prof 500000 256) would +profile the code in the address range of 500,000 to 1,500,000. +You may switch the profiler off by specifying a 0 mapping, +ie @code{si::prof 0 0)}. It can then be restarted by supplying +a nonzero second argument. Of course if you start up again +with a scale different from the previous one, +without clearing the profile array, you will have gibberish. + +The argument list to the last call of @{si::prof} is stored in the +variable @code{si::*current-profile*}. + +Unless one is using a one to one mapping of the profile array +to the code, there is a possibility of quantization errors. +There is also the possibility of overflowing a slot in the profile +array, if the mapping is very coarse, or if the interval being measured +is very long. + +@code{ + 0.08% ( 9): _eql + 15.26% ( 1822): _equal + 0.01% ( 1): _Fquote + 0.01% ( 1): SET + 0.04% ( 5): _parse_key + 0.01% ( 1): _Fcond +... + 0.50% ( 60): RELIEVE-HYPS1 + 0.03% ( 4): REMAINDER + 0.01% ( 1): REMOVE-*2*IFS + 0.03% ( 3): REMOVE-TRIVIAL-EQUATIONS + 4.35% ( 520): REWRITE + 0.47% ( 56): REWRITE-CAR-V&C-APPLY$ +...} + +is a sample of the output. The first column represents percentage of +total time spent with the program counter in the range starting at +this function, up to the next named function. The second column is the +actual number of times that a profile interrupt landed in this section +of the code. Note the default display is by address, and as mentioned +before, one should beware of overlaps, in a coarse mapping. Functions +for which there were no ticks, are not displayed. + +Note we did not sort the output, since we wished to leave it in address +order. It is possible (because of roundoff if the second arg to prof +is small) that some calls could be credited to the adjacent function. +This could be spotted more easily if the order is by address. +It is trivial to sort the table by ticks in gnu emacs using the command +sort-columns. Have the point set at the beginning of column, in the first line +and the mark at the end of the column in the last line. + +Unfortunately the System V loader likes to separate the original C +functions of KCL, from those incrementally loaded, by about 2 megabytes. +This makes it awkward to meter both ranges simultaneously without using +a very large profile array. It is probably reasonable to rewrite the +basic interrupt call, to handle such an address configuration. This +has not yet been done. Of course you can always make two runs, and combine +the information for the two ranges. + + + + diff --git a/doc/fast-link b/doc/fast-link new file mode 100644 index 0000000..42cf627 --- /dev/null +++ b/doc/fast-link @@ -0,0 +1,158 @@ + Description of Fast Link option for KCL + +Author: Bill Schelter + +When we refer to times of function calls, without other qualification, +we will be referring to the simplest possible function of no args +returning nil: (defun foo () nil). This provides a good general indication +of the timing of all functions. + +The original KCL function calling system, distinguishes between +functions defined in the same file, proclaimed functions, as well as +having different calling mechanisms for different safety levels. + +Some disadvantages were that calling across files always took at least +50mu, in spite of proclamations or safety. Function calls inside a file +either were fast (10 mu (or 3mu for proclaimed)) at safety 0 but incapable +of being traced or redefined, or else as slow as cross file compilation. + +We wished to have a scheme which would allow tracing and redefinition, +of all calls, as well very fast calling. + +In order to do this we set up links in the calls, and these are modified +at the first call to the function, if the function is compiled. Recompiling +tracing, or redefining, undoes the link. +(use-fast-links t) turns this feature on, and it is on by default. +An argument of nil turns it off, so that all calls go through the function +symbol. + + +Some timings on the fast link compiling provided in this version of kcl. + +FILEA: +(proclaim '(optimize (safety 0))) + +(proclaim '(function blue() t)) +(proclaim '(function blue1 (t) t)) +(proclaim '(function blue2 (t t) t)) +(proclaim '(function blue-same-file() t)) + +(defun test-blue (n) + (sloop for i below n do (blue))) + +(defun test-blue1 (n) + (sloop for i below n do (blue1 nil))) + +(defun test-blue2 (n) + (sloop for i below n do (blue2 nil nil))) + +(defun test-blue-same-file (n) + (sloop for i below n do (blue-same-file))) + +FILEB: + +(defun blue () nil) +(defun blue1 (x)x nil) +(defun blue2 (x y) x y Compile and load FILEA then FILEB. + +Timings: We timed the invocation of blue,blue1, and blue2 +by executing the loops in fileA. We subtracted the time for +one empty loop iteration (2.7mu). + + +Call New Old + +(blue) 3.03 60.5 +(blue1 x) 4.1 62.2 +(blue2 x y) 5.1 64.3 +(blue-same-file) 3.03 2.73 + +As can be seen all calls of blue are substantially speeded up, except +for the calls in the same file, which are slightly slowed down. There +is however the advantage, that the calls in the same file can now be +traced or redefined. Also it is conceivable that the program might +want to change a definition dynamically. It is no longer necessary to +recompile the whole file. They are handled in exactly the same manner +as the non local calls. + +Since most software projects consist of more than one file, and +since it is customary to move key routines to a basic files at +the beginning of the system, we feel the importance of having fast +calls across files is important. For example in MAXIMA, there are +380 calls to ptimes, with naturally the large majority being in files +other than the basic definition. It is useful if the other calls +can be made faster too. Also when debugging some chunk of MAXIMA +code, it is useful to be able to trace ptimes, without having to load +in new definitions and recompile. + +Disadvantages: The link table data takes up approximately 10 words, +independent of the number of calls in a file to that function. + + + +Space: +I made a file with + + +(defun try (a b) a b + (foos a b)(foos a b)(foos a b)(foos a b)(foos a b) + (foos a b)(foos a b)(foos a b)(foos a b)(foos a b) + (foos a b)(foos a b)(foos a b)(foos a b)(foos a b) + (foos a b)(foos a b)(foos a b)(foos a b)(foos a b) + (foos a b)(foos a b)(foos a b)(foos a b)(foos a b) + ) +I compared the size with various settings of *fast-link-compile* +and with proclaiming foos. +DIFF means the size above the case with all calls to FOOS removed. + +text data bss dec DIFF FLC proclaimed Case SAMEFILE +1076 0 28 1104 836 nil nil I nil +1308 0 32 1340 892 nil nil Ia t +1296 4 28 1328 1060 t nil II nil +1436 4 32 1472 1056 t nil IIa t +684 4 28 716 448 t t III nil +244 0 24 268 0 t ; calls removed. IV nil +384 0 32 416 0 nil ;cals removed V t + + + +The reason II is bigger than I is that the vs_top and vs_base settings +are being performed in the file, in exactly the same manner as if the +definition for foos were in the file. FLC=nil with definition of foos +in the same file would also be higher. Should probably have a type +of proclamation which would favor the case I call in cases where speed +is irrelevant. But then why not go with III.. + + +Appendix: +Notes: +1)Empty loop takes 2.70 seconds for 1,000,000 iterations. +2)blue-same-file or blue + +>(time (test-blue 1000000)) +real time : 5.750 secs +run time : 5.733 secs +NIL + +>(trace blue) +(BLUE) + +>(test-blue 2) + 1> (BLUE) + <1 (BLUE NIL) + 1> (BLUE) + <1 (BLUE NIL) +NIL + +>(trace blue-same-file) +(BLUE-SAME-FILE) + +>(test-blue-same-file 2) + 1> (BLUE-SAME-FILE) + <1 (BLUE-SAME-FILE NIL) + 1> (BLUE-SAME-FILE) + <1 (BLUE-SAME-FILE NIL) +NIL + + + diff --git a/doc/format b/doc/format new file mode 100644 index 0000000..c7b528f --- /dev/null +++ b/doc/format @@ -0,0 +1,44 @@ + +We have added a user extensible feature to the common lisp +function format. + +For some applications, for example in maxima, it is very desirable +to be able to define a new control character, so that + +(format t "~%The polynomial ~m is not zero" polynomial) + +would work. It is desirable to extend format itself, since then +calls to the error and other functions which use format will work +correctly. For example: + +(error "~%The polynomial ~m is not zero" polynomial) + + +For an application to do this we would evaluate the following: + +(setf (get 'si::*indent-formatted-output* (char-code #\m)) 'maxima-print) + +(defun maxima-print (item stream colon atsign &rest l) + colon atsign l ;ignoring these + (internal-maxima-print item stream)) + +Note this extension is case sensitive, so that to have this apply to +capital M as well, the property for (char-code #\M) must be added as +well. + +A call with "~:m" would make colon=1 and atsign=0. +A call with "~@m" would make colon=0 and atsign=1. + +To Do: +The &rest l is currently unused, a future addition will probably +store into l the current column of the format output stream. + +This also implies that new print functions should return what they think is +the new column. Since I believe that 98% of the current calls to format +do not use column information in an important way, this is probably not worth +the additional hair involved. + +Numeric args are not passed. + + + \ No newline at end of file diff --git a/doc/funcall-comp b/doc/funcall-comp new file mode 100644 index 0000000..2841af1 --- /dev/null +++ b/doc/funcall-comp @@ -0,0 +1,35 @@ + +In AKCL version 1.78 I observe the following times + +(defun joe () nil) +(setq cfun #'joe) +(setq symbol 'joe) +after compilation (on a sun3/280) + +Form AKCL 1.78 KCL +(joe) 6.1 7.7 +(funcall cfun) 9.5 14.0 +(funcall symbol) 13.7 17.8 +(joe1) 2.1 2.5 + +times are in microseconds per call. +joe1 is the same as joe but with (proclaim '(function joe1 () t)) +The functions were in the same file, although this would not make +a difference for AKCL. + +A typical timing loop is +(defun foo1 (x n) (sloop for i below n do (funcall x))) +(defun foo2 ( n) (sloop for i below n do (joe))) +(defun foo3 ( n) (sloop for i below n do (joe1))) + +(time (foo1 #'joe 100000)) +(time (foo1 'joe 100000)) +(time (foo2 100000)) + +Note: An AKCL version >= 1.78 will be released in a few days +when I finish checking over the 8 and 16 bit arrays which have been +added. + + + + diff --git a/doc/funcall.lsp b/doc/funcall.lsp new file mode 100644 index 0000000..32ebbe9 --- /dev/null +++ b/doc/funcall.lsp @@ -0,0 +1,81 @@ + +I have been trying to improve funcall so that functions of a fixed +number of args can be funcalled with almost the same speed as +they can be called if the name is laid down in the file. Basically +I have made functions with a fixed number of args, first class +compiled-function objects, and removed the si::cdefn property stuff. +It is no longer necessary to have a global version of the function, +since one can now use the C stack version anywhere. I have made +compiled function objects slightly smaller, but with more information. +So the number of args and there types is encoded in these C functions. +It will soon be possible to do fast cross file calling of functions +with mixed fixnum and general args and one return value. + +After these changes: + +A comparison of calling a fixed arg function of 1 argument: +(the second time for KCL is for when the function is in a separate file). + + LUCID AKCL KCL +funcall 8.3 3.54 18.8 (funcall x nil) where x = #'foo +Direct call 7.44 2.78 3.16(23.4) (foo nil) + +(proclaim '(function foo (t) t)) +(defun line1 (x n) (sloop for i below n with y do (setq y (funcall x nil)))) +(defun line2 (n) (sloop for i below n with y do (setq y (foo nil)))) +(defun foo (x) x nil) + +It is able to detect that only one value from the funcall is desired, +because of the setq. In general the following macro can be used to inform +the compiler of this. + +(defmacro vfuncall (x &rest args) + `(the (values t) (funcall ,x ,@ args))) + +We can not lay down the new funcall code if multiple values might be desired: +(defun joe (x) (funcall x nil)) +will have its number of values returned depend on x. + +(defun joe (x) (the (values t) (funcall x nil))) +or +(defun joe (x) (setq x (funcall x nil))) + +would allow it however. + +Unfortunately GCL is much slower if the function to be funcalled does +not happen to be a compiled function which was compiled while +proclaimed with a fixed number of args and one value. Still there are +a number of critical applications where it is useful to have a very +fast funcall. I have no useful heuristic at the moment for 'guessing' +which kind of funcall I should lay down: One optimized for C stack or +one optimized for Lisp stack. I can only detect when it is safe to +lay down a C stack one. However if the function in question uses the +lisp stack, and is called via the C stack, the call will be twice as +slow as it used to be. This is very unfortunate! At the cost of +space I could avoid this, but the new funcall takes up less space than +the old one and I hate to lay down two types in the code just in +case.... The check as to type is being laid down, but a trick is +used to keep space different minimal. + +SPACE: + +I have also noted some size differences (as reported by size *.o) +where the amounts are the 'dec' = decimal representation of +text+data+bss in the object file. This is what gets loaded. +There is still room for improvement here. Most of the difference +is due to the fact that functions of fixed args only need one +entry now. + + +Before: After: +31340 basis.o 28348 +76584 code-1-a.o 63212 +94136 code-b-d.o 79136 +93372 code-e-m.o 75384 +125172 code-n-r.o 10524 +77148 code-s-z.o 61840 +15620 events.o 14504 +4036 genfact.o 3464 +27908 io.o 24544 +9132 ppr.o 8340 +42668 sloop.o 40484 diff --git a/doc/makefile b/doc/makefile new file mode 100644 index 0000000..980ebc3 --- /dev/null +++ b/doc/makefile @@ -0,0 +1,9 @@ +# a facility for displaying DOC files and completing on them +# requires gnu emacs, to be in the search path + +# A directory on peoples search path. + + +ELISP=gcl.el dbl.el ansi-doc.el lisp-complete.el sshell.el + +-include ../makedefs diff --git a/doc/multiple-values b/doc/multiple-values new file mode 100644 index 0000000..ef2e0fb --- /dev/null +++ b/doc/multiple-values @@ -0,0 +1,94 @@ + +Proclaimed functions of a fixed number of args are much more +efficient. It is still possible to pass multiple values +efficiently (but not quite with the CL semantics) + +Here are two examples, one using ordinary multiple-value-setq +and the other our-multiple-value-setq. +For 1,000,000 calls: + +Type : CL 2 values our 2 values 1 value +Time : 7.9 sec 3.5 2.35 +name : foo-mv foo-our-mv foo +Uses : multiple-value-setq our-multiple-value-setq Only 1 value passed. + +(defun foo-mv (n) + (let (x y) + (sloop for i below n + do (multiple-value-setq(x y) (goo-mv))))) + +(defun goo-mv () (values 1 2)) + + +And then an equivalent one: +(proclaim '(function foo-our-mv (t) t)) +(proclaim '(function goo-our-mv () t)) +(defun foo-our-mv (n) + (let (x y) + (sloop for i below n + do (our-multiple-value-setq (x y) (goo-our-mv))) + (list x y))) + +(defun goo-our-mv () (our-values 1 2)) + +The times: +>(time (foo-our-mv 1000000)) +real time : 3.617 secs +run time : 3.583 secs +(1 2) +>(time (foo-mv 1000000)) +real time : 8.033 secs +run time : 7.800 secs +(1 2) + +Here are the our-mv macros: + +(use-package "SLOOP") + + +(defmacro our-values (a &rest l) + (or (< (length l) (length *vals*)) (error "too many values")) + `(prog1 ,a ,@ (sloop for v in l + for u in *vals* + collect `(setq ,u ,v)))) + +(defmacro our-multiple-value-setq ((x &rest l) form) + (or (< (length l) (length *vals*)) (error "too many values")) + `(prog1 (setq ,x ,form) + ,@ (sloop for w in *vals* + for v in l + collect `(setq ,v ,w)))) + +(defvar *vals* + '(*val1* *val2* *val3* *val4* *val5* *val6* *val7* *val8* *val9* *val10*)) + + +(defvar *val1* nil) +(defvar *val2* nil) +(defvar *val3* nil) +(defvar *val4* nil) +(defvar *val5* nil) +(defvar *val6* nil) +(defvar *val7* nil) +(defvar *val8* nil) +(defvar *val9* nil) +(defvar *val10* nil) + +;; Note that this method does not penalize ordinary calls at all. +;; It is not the same as the common lisp multiple values in general: +;; 1) The information on how many values are being passed is not +;; recorded [ unless of course that number is one of the values ! ] +;; 2) If you ask for more values than were specified you will get +;; a random value. Common lisp values would say you get nil. +;; Now it is true that it would be possible to make AKCL pass multiple +;; values more efficiently, but this is really a large overhaul of the +;; system. There are lots of system functions, hand coded using the +;; old scheme. I have been thinking about ways to do this for the +;; last little while, but have not settled on anything. + +Bill + + + + + diff --git a/doc/profile b/doc/profile new file mode 100644 index 0000000..5dae63e --- /dev/null +++ b/doc/profile @@ -0,0 +1,45 @@ + +We have added a facility for determining the proportional amount of +time spent executing compiled lisp defined functions, as well as +internal c defined functions. + +This system works under Unix BSD or System V. + +To use this code load the file lsp/profile.o. + +SET-UP-PROFILE &optional (array-size 100000)(max-funs 6000) + + +must be called to allocate space for storing the profile information +as it is collected, and also to build a list of the functions from +the symbol table of the executable (defaults to "saved_kcl"). + +Once this has been done a call to + +PROF (start scale) + +START will correspond to the beginning of the profile array, and +the SCALE will mean that 256 bytes of code correspond to SCALE bytes in the +profile array. + +Thus if the profile array is 1,000,000 bytes long and the code segment is +5 megabytes long you can profile the whole thing using a scale of 50 +Note that long runs may result in overflow, and so an understating of the +time in a function. + +With a scale of 128 a sample loop overflowed some slots at 6,000,000 +times through the loop. + +There is very little slowdown in execution during profiling. No special +compilation is necessary. + +To display the result do + +(si::display-profile) + +To turn off profiling use (si::prof 0 0). + +(si::clear-profile) +clears the profile array for a new run. + + diff --git a/dos/dostimes.c b/dos/dostimes.c new file mode 100755 index 0000000..31ee839 --- /dev/null +++ b/dos/dostimes.c @@ -0,0 +1,19 @@ +#include +#include + +#ifdef __ZTC__ +#define HZ 100 +#endif + +times(x) +struct tms *x; +{ int hz; +struct rusage ru; +getrusage(RUSAGE_SELF,&ru); +hz = ru.ru_utime.tv_sec * HZ + + (ru.ru_utime.tv_usec *HZ)/1000000; +x->tms_utime = hz; +x->tms_stime = hz; +return 0; +} + diff --git a/dos/dum_dos.c b/dos/dum_dos.c new file mode 100755 index 0000000..8826f64 --- /dev/null +++ b/dos/dum_dos.c @@ -0,0 +1,9 @@ +#define DUM(a) int a(int n) { printf("dummy " #a " call %d\n",n); return 0;} +DUM(profil) +/* DUM(alarm) */ +DUM(getpid) +DUM(getuid) +DUM(popen) +DUM(pclose) +DUM(getpwuid) +DUM(getpwnam) diff --git a/dos/makefile b/dos/makefile new file mode 100644 index 0000000..4c9fb79 --- /dev/null +++ b/dos/makefile @@ -0,0 +1,27 @@ +.SUFFIXES: .o .c + +HDIR = ../h + +OFLAG = -O +ODIR = . + +-include ../makedefs + +DOS_ODIR=. + +CFLAGS = -I. -I$(HDIR) $(ODIR_DEBUG) + +.s.o: + $(CC) -c $(OFLAG) $(CFLAGS) $*.c + +.c.o: + $(CC) -c $(OFLAG) $(CFLAGS) $*.c + +OBJS = $(EXX_DOS) + +all: $(OBJS) + +clean: + rm -f $(OBJS) + + diff --git a/dos/read.s b/dos/read.s new file mode 100755 index 0000000..533a033 --- /dev/null +++ b/dos/read.s @@ -0,0 +1,41 @@ +/* This is file READ.S */ +/* +** Copyright (C) 1991 DJ Delorie, 24 Kirsten Ave, Rochester NH 03867-2954 +** +** This file is distributed under the terms listed in the document +** "copying.dj", available from DJ Delorie at the address above. +** A copy of "copying.dj" should accompany this file; if not, a copy +** should be available from where this file was obtained. This file +** may not be distributed without a verbatim copy of "copying.dj". +** +** This file is distributed WITHOUT ANY WARRANTY; without even the implied +** warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +*/ + + .text + .globl _read +_read: + pushl %eax + movl $0,%eax + cmp 8(%esp),%eax /* Is it stdin */ + jne NotStdin + cmp _interrupt_flag,%eax /* Any SIGINT Interrupt pending ? */ + je NoInterrupt + call _sigalrm +NoInterrupt: +NotStdin: + popl %eax + + pushl %ebx + pushl %esi + pushl %edi + movl 16(%esp),%ebx + movl 20(%esp),%edx + movl 24(%esp),%ecx + movb $0x3f,%ah + int $0x21 + popl %edi + popl %esi + popl %ebx + jb syscall_error + ret diff --git a/dos/readme b/dos/readme new file mode 100755 index 0000000..6221eac --- /dev/null +++ b/dos/readme @@ -0,0 +1,7 @@ + +This is the remnants of the port of akcl to dos under djgpp (version 1.06) +Unfortunately djgpp has changed and so it is not so straightforward to +make gcl work .. I would be happy if someone else does it! + +Bill Schelter + diff --git a/dos/sigman.s b/dos/sigman.s new file mode 100755 index 0000000..b5755e8 --- /dev/null +++ b/dos/sigman.s @@ -0,0 +1,49 @@ + + .globl _SignalManager +_SignalManager: + pushl %ebp + movl %esp,%ebp + /*------------------------------------------------------------------- + ** Save all registers + **-----------------------------------------------------------------*/ + pushl %eax + pushl %ebx + pushl %ecx + pushl %edx + pushl %esi + pushl %edi + pushf + pushl %es + pushl %ds +/* pushl %ss*/ + pushl %fs + pushl %gs + /*-----------------------------------------------------------------*/ + + movl 4(%ebp), %eax + shl $2, %eax + movl _SignalTable(%eax), %ebx + call %ebx + + /*------------------------------------------------------------------- + ** Restore registers + **-----------------------------------------------------------------*/ + popl %gs + popl %fs +/* popl %ss*/ + popl %ds + popl %es + popf + popl %edi + popl %esi + popl %edx + popl %ecx + popl %ebx + popl %eax + /*------------------------------------------------------------------*/ + + popl %ebp + add $4, %esp + + ret /* resume program */ + diff --git a/dos/signal.c b/dos/signal.c new file mode 100755 index 0000000..b3855eb --- /dev/null +++ b/dos/signal.c @@ -0,0 +1,109 @@ +/* This is file signal.c +** +** Copyright (C) 1992 Rami EL CHARIF and William SCHELTER +** rcharif@ma.utexas.edu wfs@cs.utexas.edu +** +** Signal package for djgpp versions 1.05, 1.06 +** version 0.0 alpha 03/30/1992 +** +** Send your comments or bugs report to +** rcharif@ma.utexas.edu or wfs@cs.utexas.edu +** +** This file is distributed WITHOUT ANY WARRANTY; without even the implied +** warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +*/ + +#include +#include +#include + +unsigned long SignalTable[_NSIG + 1] = { + (unsigned long)SIG_DFL, /* SIGHUP */ + (unsigned long)SIG_DFL, /* SIGINT +*/ + (unsigned long)SIG_DFL, /* SIGQUIT */ + (unsigned long)SIG_DFL, /* SIGILL */ + (unsigned long)SIG_DFL, /* SIGABRT */ + (unsigned long)SIG_DFL, /* SIGTRAP */ + (unsigned long)SIG_DFL, /* SIGIOT */ + (unsigned long)SIG_DFL, /* SIGEMT */ + (unsigned long)SIG_DFL, /* SIGFPE */ + (unsigned long)SIG_DFL, /* SIGKILL */ + (unsigned long)SIG_DFL, /* SIGBUS */ + (unsigned long)SIG_DFL, /* SIGSEGV +*/ + (unsigned long)SIG_DFL, /* SIGSYS */ + (unsigned long)SIG_DFL, /* SIGPIPE */ + (unsigned long)SIG_DFL, /* SIGALRM */ + (unsigned long)SIG_DFL, /* SIGTERM */ + (unsigned long)SIG_DFL, /* SIGURG */ + (unsigned long)SIG_DFL, /* SIGSTOP */ + (unsigned long)SIG_DFL, /* SIGTSTP */ + (unsigned long)SIG_DFL, /* SIGCONT */ + (unsigned long)SIG_DFL, /* SIGCHLD */ + (unsigned long)SIG_DFL, /* SIGCLD */ + (unsigned long)SIG_DFL, /* SIGTTIN */ + (unsigned long)SIG_DFL, /* SIGTTOU */ + (unsigned long)SIG_DFL, /* SIGIO */ + (unsigned long)SIG_DFL, /* SIGPOLL */ + (unsigned long)SIG_DFL, /* SIGXCPU */ + (unsigned long)SIG_DFL, /* SIGXFSZ */ + (unsigned long)SIG_DFL, /* SIGVTALRM */ + (unsigned long)SIG_DFL, /* SIGPROF */ + (unsigned long)SIG_DFL, /* SIGWINCH */ + (unsigned long)SIG_DFL, /* SIGUSR1 */ + (unsigned long)SIG_DFL /* SIGUSR2 */ + }; + +SignalHandler signal(int sig, SignalHandler action) +{ + extern void SignalManager(); + union REGS in, out; + SignalHandler hsigOld; + + in.h.ah = 1; + in.h.al = sig; + SignalTable[sig] = in.x.dx = (long)action; + in.x.cx = (long)SignalManager; + int86(0xfa, &in, &out); + hsigOld = (SignalHandler)out.x.dx; + return hsigOld; +} + +void SigInst() +{ + union REGS in, out; + extern void SignalManager(); + + in.h.ah = 0; + in.h.al = 0; + in.x.dx = (long)SignalManager; + +#ifdef DEBUG_SIG + printf("\nSignal Manager = %ld, %lx", in.x.dx, in.x.dx); +#endif + + int86(0xfa, &in, &out); + +} + +#ifndef NO_SIG_ALARM +unsigned int alarm(int culSeconds) +{ + + union REGS in, out; + + if (!culSeconds) { + in.h.ah = 3; /* Reset alarm */ + int86(0xfa, &in, &out); + } + else { + in.h.ah = 2; + in.x.dx = culSeconds; + int86(0xfa, &in, &out); + } + return in.x.cx; +} +#else +unsigned int alarm(int n) +{ return 0; } +#endif + diff --git a/dos/signal.h b/dos/signal.h new file mode 100755 index 0000000..87e252e --- /dev/null +++ b/dos/signal.h @@ -0,0 +1,137 @@ +/* This is file signal.h */ +/* This file may have been modified by DJ Delorie (Jan 1991). If so, +** these modifications are Coyright (C) 1991 DJ Delorie, 24 Kirsten Ave, +** Rochester NH, 03867-2954, USA. +*/ + +/* This may look like C code, but it is really -*- C++ -*- */ +/* +Copyright (C) 1989 Free Software Foundation + written by Doug Lea (dl@rocky.oswego.edu) + +This file is part of GNU CC. + +GNU CC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY. No author or distributor +accepts responsibility to anyone for the consequences of using it +or for whether it serves any particular purpose or works at all, +unless he says so in writing. Refer to the GNU CC General Public +License for full details. + +Everyone is granted permission to copy, modify and redistribute +GNU CC, but only under the conditions described in the +GNU CC General Public License. A copy of this license is +supposed to have been given to you along with GNU CC so you +can know your rights and responsibilities. It should be in a +file named COPYING. Among other things, the copyright notice +and this notice must be preserved on all copies. +*/ + +#ifndef _signal_h +#pragma once + + +#ifdef __cplusplus +extern "C" { +#endif + +/* This #define KERNEL hack gets around bad function prototypes on most */ +/* systems. If not, you need to do some real work... */ +/******************* +* #define KERNEL +* #include +* #undef KERNEL +********************/ + +#ifndef _signal_h +#define _signal_h 1 +#endif + +/* The Interviews folks call this SignalHandler. Might as well conform. */ +/* Beware: some systems think that SignalHandler returns int. */ +typedef void (*SignalHandler) (); + +extern SignalHandler signal(int sig, SignalHandler action); +extern SignalHandler sigset(int sig, SignalHandler action); +extern SignalHandler ssignal(int sig, SignalHandler action); +extern int gsignal (int sig); +extern int kill (int pid, int sig); + +#ifndef hpux /* Interviews folks claim that hpux doesn't like these */ +struct sigvec; +extern int sigsetmask(int mask); +extern int sigblock(int mask); +extern int sigpause(int mask); +extern int sigvec(int sig, struct sigvec* v, struct sigvec* prev); +#endif + +/* The Interviews version also has these ... */ + +#define SignalBad ((SignalHandler)-1) +#define SignalDefault ((SignalHandler)0) +#define SignalIgnore ((SignalHandler)1) + +#ifdef __cplusplus +} +#endif +#define _SIGNAL_H +/** #include **/ +#ifdef _SIGNAL_H + +/* This file defines the fake signal functions and signal + number constants for 4.2 or 4.3 BSD-derived Unix system. */ + +#define SIG_DFL 0 +#if 0 +/*#ifndef SIG_DFL*/ +/* Fake signal functions. + These lines MUST be split! m4 will not change them otherwise. */ +#define SIG_ERR /* Error return. */ \ + ((void EXFUN((*), (int sig))) -1) +#define SIG_DFL /* Default action. */ \ + ((void EXFUN((*), (int sig))) 0) +#define SIG_IGN /* Ignore signal. */ \ + ((void EXFUN((*), (int sig))) 1) + +#endif +/* Signals. */ +#define SIGHUP 1 /* Hangup (POSIX). */ +#define SIGINT 2 /* Interrupt (ANSI). */ +#define SIGQUIT 3 /* Quit (POSIX). */ +#define SIGILL 4 /* Illegal instruction (ANSI). */ +#define SIGABRT SIGIOT /* Abort (ANSI). */ +#define SIGTRAP 5 /* Trace trap (POSIX). */ +#define SIGIOT 6 /* IOT trap (4.2 BSD). */ +#define SIGEMT 7 /* EMT trap (4.2 BSD). */ +#define SIGFPE 8 /* Floating-point exception (ANSI). */ +#define SIGKILL 9 /* Kill, unblockable (POSIX). */ +#define SIGBUS 10 /* Bus error (4.2 BSD). */ +#define SIGSEGV 11 /* Segmentation violation (ANSI). */ +#define SIGSYS 12 /* Bad argument to system call (4.2 BSD)*/ +#define SIGPIPE 13 /* Broken pipe (POSIX). */ +#define SIGALRM 14 /* Alarm clock (POSIX). */ +#define SIGTERM 15 /* Termination (ANSI). */ +#define SIGURG 16 /* Urgent condition on socket (4.2 BSD).*/ +#define SIGSTOP 17 /* Stop, unblockable (POSIX). */ +#define SIGTSTP 18 /* Keyboard stop (POSIX). */ +#define SIGCONT 19 /* Continue (POSIX). */ +#define SIGCHLD 20 /* Child status has changed (POSIX). */ +#define SIGCLD SIGCHLD /* Same as SIGCHLD (System V). */ +#define SIGTTIN 21 /* Background read from tty (POSIX). */ +#define SIGTTOU 22 /* Background write to tty (POSIX). */ +#define SIGIO 23 /* I/O now possible (4.2 BSD). */ +#define SIGPOLL SIGIO /* Same as SIGIO? (SVID). */ +#define SIGXCPU 24 /* CPU limit exceeded (4.2 BSD). */ +#define SIGXFSZ 25 /* File size limit exceeded (4.2 BSD). */ +#define SIGVTALRM 26 /* Virtual alarm clock (4.2 BSD). */ +#define SIGPROF 27 /* Profiling alarm clock (4.2 BSD). */ +#define SIGWINCH 28 /* Window size change (4.3 BSD, Sun). */ +#define SIGUSR1 30 /* User-defined signal 1 (POSIX). */ +#define SIGUSR2 31 /* User-defined signal 2 (POSIX). */ + +#endif /* included. */ + +#define _NSIG 32 /* Biggest signal number + 1. */ + +#endif + diff --git a/elisp/add-default.el b/elisp/add-default.el new file mode 100644 index 0000000..f4742ba --- /dev/null +++ b/elisp/add-default.el @@ -0,0 +1,4 @@ + +;;;BEGIN gcl addition +(autoload 'dbl "dbl" "Make a debugger to run lisp, maxima and or gdb in" t) +;;;END gcl addition diff --git a/elisp/ansi-doc.el b/elisp/ansi-doc.el new file mode 100755 index 0000000..2db99ec --- /dev/null +++ b/elisp/ansi-doc.el @@ -0,0 +1,92 @@ +;; Copyright William F. Schelter. 1994 +;; Licensed by GNU public license. + +;; This file contains function find-ansi-doc which finds documentation in the +;; standard common lisp ansi documentation (1350 pages!), and puts it on +;; the screen at the correct page using xdvi. If there is more than one +;; reference it successively finds them. You need dpANS2/*.dvi +;; dpANS2/index.idx from parcftp.xerox.com (13.1.64.94) You also need +;; xdvi. You may gzip the .dvi files and it will unzip them into tmp +;; as needed. + + +(defvar ansi-doc-dir "/usr/local/doc/dpANS2") +(defvar ansi-doc-alist nil) + +(defun create-index-el-from-index-idx () + (interactive) + (let (tem) + (cond ((not ansi-doc-alist) + (setq tem (concat ansi-doc-dir "/index.el")) + (or (file-exists-p tem) + (progn + (shell-command + (concat "echo '(setq ansi-doc-alist (quote (( ' > " tem)) + (shell-command + (concat "cat " ansi-doc-dir "/index.idx " + "| sed " + " -e 's/\\!9\\([A-Z]\\):\\([^\\!]*\\)\\!\\!/)(\"\\2\" \\1/g' " + " -e 's:{$\\\\spLT \\$}:<:g' " + " -e 's:{$\\\\spGT $}:>:g' " + " -e 's:\\\\&:\\&:g' " + " -e 's:\\([0-9]\\),:\\1:g'" + " -e 's:\\([A0-9][0-9]*\\)--\\([0-9][0-9]*\\):(\\1 . \\2):g'" + " | sort -r " + " >> " tem)) + (shell-command (concat "echo '))))' >> " tem)))) + + )))) +(defun maybe-gzip-to-tmp (file &optional dir) + "If file exists with .gz added to it, then unzip it to /tmp and +return that file otherwise return file" + (let (tmp-file) + (cond ((file-exists-p (concat file ".gz")) + (setq tmp-file + (file-name-nondirectory file)) + (or (file-exists-p tmp-file) + (progn (message "gzipping %s in /tmp for future use" file) + (shell-command (concat "gzip -dc < " file ".gz > " + tmp-file )))) + tmp-file) + (t file)))) + +(defun find-ansi-doc () + "Find the documentation in the ansi draft on a particular function +or topic. If there are several pieces of documentation then go through +them successively. Requires copying the " + (interactive ) + (let (x tem name lis first chap tmp-chap) + (or ansi-doc-alist + (progn + (create-index-el-from-index-idx ) + (load (concat ansi-doc-dir "/index.el")))) + (setq name (completing-read "Doc on: " ansi-doc-alist nil t)) + (progn (setq ans nil) (setq lis ansi-doc-alist) + (while lis + (cond ((equal (car (car lis)) name) + (setq ans (append ans (cdr (cdr (car lis))))))) + (setq lis (cdr lis))) + ) + (setq tem ans) + (if (cdr tem) (setq first "First") (setq first "")) + (while tem + (setq x (car tem)) + (setq chap (concat ansi-doc-dir + (downcase (format "/chap-%s.dvi" (car x))))) + (setq chap (maybe-gzip-to-tmp chap)) + (message "%s Doc in Chapter %s page %s) %s .." first (car x) (cdr x)) + (if (cdr tem) (setq first "Next") (setq next "Final")) + (shell-command (concat "xdvi -expert -xoffset .2 -yoffset -.2 " + " -paper 7.2x8.5 " + " -display " + (or x-display-name ":0") + " -geometry -2-2 +" (+ (cdr x) 2)" " + chap + )) + (setq tem (cdr tem)) + + ) + ) + (message nil) + + ) diff --git a/elisp/dbl.el b/elisp/dbl.el new file mode 100755 index 0000000..9d91a57 --- /dev/null +++ b/elisp/dbl.el @@ -0,0 +1,685 @@ +;; Run gcl,maxima,gdb etc under Emacs all possibly all in one buffer. +;; +;; This file is part of GNU Emacs. +;; Copyright (C) 1998 William F. Schelter + +;; GNU Emacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY. No author or distributor accepts responsibility +;; to anyone for the consequences of using it or for whether it serves +;; any particular purpose or works at all, unless he says so in writing. +;; Refer to the GNU Emacs General Public License for full details. + +;; Everyone is granted permission to copy, modify and redistribute GNU +;; Emacs, but only under the conditions described in the GNU Emacs +;; General Public License. A copy of this license is supposed to have +;; been given to you along with GNU Emacs so you can know your rights and +;; responsibilities. It should be in a file named COPYING. Among other +;; things, the copyright notice and this notice must be preserved on all +;; copies. + +;; Description of DBL interface: + +;; A facility is provided for the simultaneous display of the source code +;; in one window, while using dbl to step through a function in the +;; other. A small arrow in the source window, indicates the current +;; line. + +;; Starting up: + +;; In order to use this facility, invoke the command DBL to obtain a +;; shell window with the appropriate command bindings. You will be asked +;; for the name of a file to run. Dbl will be invoked on this file, in a +;; window named *dbl-foo* if the file is foo. + +;; M-s steps by one line, and redisplays the source file and line. + +;; You may easily create additional commands and bindings to interact +;; with the display. For example to put the dbl command next on \M-n +;; (def-dbl :next "\M-n") + +;; This causes the emacs command dbl-next to be defined, and runs +;; dbl-display-frame after the command. + +;; dbl-display-frame is the basic display function. It tries to display +;; in the other window, the file and line corresponding to the current +;; position in the dbl window. For example after a dbl-step, it would +;; display the line corresponding to the position for the last step. Or +;; if you have done a backtrace in the dbl buffer, and move the cursor +;; into one of the frames, it would display the position corresponding to +;; that frame. + +;; dbl-display-frame is invoked automatically when a filename-and-line-number +;; appears in the output. + + +(require 'sshell) +(require 'smart-complete) +(define-key sshell-mode-map "\ep" 'smart-complete) +(define-key sshell-mode-map "\M-p" 'smart-complete) +(require 'gcl) +(autoload 'maxima-mode "maxima-mode" "Major mode for editing maxima code and interacting with debugger" t) +(autoload 'gcl-mode "gcl" "Major mode for editing maxima code and interacting with debugger" t) +(or (rassoc 'maxima-mode auto-mode-alist) +(setq auto-mode-alist (cons '("\\.ma?[cx]\\'" . maxima-mode) auto-mode-alist)) +) +(or (rassoc 'gcl-mode auto-mode-alist) +(setq auto-mode-alist (cons '("\\.li?sp\\'" . gcl-mode) auto-mode-alist)) +) + +(defvar dbl-prompt-pattern + "\\(^\\|\n\\)[^ >]*[>$)%#:][>]*[ ]*" + ; "(^|\n)\\[^ >]*[>$)%#:][>]*[ ]*+" + "A regexp to recognize the prompt for dbl or dbl+.") +; + +(defvar downcase-filenames-for-dbl + (string-match "nt[45]" system-configuration) + "Force the case to be lower when sending a break command" + ) + +(defvar dbl-subshell-switches + (list "bash" (if (string-match "nt[45]" system-configuration) '("--noediting" "-i") '("-i")) + ) + "Alternating list of regexp for the shell name, and list of switches to pass" + ) + +(defvar dbl-filter-accumulator nil) +(defvar dbl-mode-map nil + "Keymap for dbl-mode.") + +(if dbl-mode-map + nil + (setq dbl-mode-map (copy-keymap sshell-mode-map)) + (define-key dbl-mode-map "\C-cl" 'dbl-find-and-display-line) + ) + +(define-key ctl-x-map " " 'dbl-break) +;(define-key ctl-x-map "&" 'send-dbl-command) + +;;Of course you may use `def-dbl' with any other dbl command, including +;;user defined ones. + +(defmacro def-dbl (name key &optional doc) + (let* ((fun (intern (format "dbl-%s" (read name)))) + ) + (list 'progn + (list 'defun fun '(arg) + (or doc "") + '(interactive "p") + (list 'dbl-call name 'arg)) + (list 'define-key 'dbl-mode-map key (list 'quote fun))))) + +(def-dbl ":step %p" "\M-s" "Step one source line with display") +(def-dbl ":step %p" "\C-c\C-s" "Step one source line with display") +(def-dbl ":stepi %p" "\C-c\t" "Step one instruction with display") +(def-dbl ":next %p" "\M-n" "Step one source line (skip functions)") +(def-dbl ":next %p" "\C-c\C-n" "Step one source line (skip functions)") +(def-dbl ":r" "\M-c" "Continue with display") + +(def-dbl ":finish" "\C-c\C-f" "Finish executing current function") +(def-dbl ":up %p" "\C-cu" "Go up N stack frames (numeric arg) with display") +(def-dbl ":down %p" "\C-cd" "Go down N stack frames (numeric arg) with display") + + +(defun dbl-mode () + "Major mode for interacting with an inferior Lisp or Maxima process. +It is like an ordinary shell, except that it understands certain special +redisplay commands sent by the process, such as redisplay a source file +in the other window, positioning a little arrow `==>', at a certain +line, typically the line where you are stopped in the debugger. + +It uses completion based on the form of your current prompt, allowing +you to keep separate the commands you type at the debugger level and +the lisp or maxima level. + +The source files should be viewed using gcl mode for lisp, and maxima-mode +for maxima. + + +\\{dbl-mode-map} + +\\[dbl-display-frame] displays in the other window +the last line referred to in the dbl buffer. + +\\[dbl-:step] and \\[dbl-:next] in the dbl window, +call dbl to step and next and then update the other window +with the current file and position. +o +If you are in a source file, you may select a point to break +at, by doing \\[dbl-break]. + +Commands: +Many commands are inherited from shell mode. +Additionally we have: + +\\[dbl-display-frame] display frames file in other window +\\[dbl-:step] advance one line in program +\\[dbl-:next] advance one line in program (skip over calls). +\\[send-dbl-command] used for special printing of an arg at the current point. +C-x SPACE sets break point at current line. + +You may also enter keyword break commands. + +:a show-break-variables +:b simple-backtrace +:bds break-bds +:bl break-locals +:blocks break-blocks +:break insert a break point here +:bs break-backward-search-stack +:bt dbl-backtrace +:c break-current +:delete (lambda (&rest l) (iterate-over-bkpts l delete) (values)) +:disable [n1 .. nk] disable break points. [see :info :bkpt] +:down [n] move n frames down +:enable [n1 n2 ..nk] enable break points +:env describe-environment +:fr [n] show this frame +:fs break-forward-search-stack +:functions break-functions +:go break-go +:h break-help +:help break-help +:ihs ihs-backtrace +:info :bkpt show break points. +:loc loc +:m break-message +:n break-next +:next step-next +:p break-previous +:q break-quit +:r resume +:resume (lambda () resume) +:s search-stack +:step step-into +:t throw-macsyma-top +:up move up one frame +:vs break-vs + +" + (interactive) + (kill-all-local-variables) + (setq major-mode 'dbl-mode) + (setq mode-name "Inferior Dbl") + (setq mode-line-process '(": %s")) + (use-local-map dbl-mode-map) + (make-local-variable 'last-input-start) + (setq last-input-start (make-marker)) + (make-local-variable 'last-input-end) + (setq last-input-end (make-marker)) + (make-local-variable 'dbl-last-frame) + (setq dbl-last-frame nil) + (make-local-variable 'dbl-last-frame-displayed-p) + (setq dbl-last-frame-displayed-p t) + (make-local-variable 'dbl-delete-prompt-marker) + (setq dbl-delete-prompt-marker nil) + (make-local-variable 'dbl-filter-accumulator) + (setq dbl-filter-accumulator nil) + (make-local-variable 'shell-prompt-pattern) + (setq shell-prompt-pattern dbl-prompt-pattern) + (run-hooks 'sshell-mode-hook 'dbl-mode-hook)) + +(defvar current-dbl-buffer nil) + +(defvar dbl-command-name (if (file-exists-p "/bin/bash") "/bin/bash" + "/bin/sh") + "Pathname for executing dbl.") + + +(defun dbl (p) + + "Makes a dbl buffer, suitable for running an inferior + gcl. You are prompted for a name for the buffer. After the shell + starts you should start up your lisp program (eg gcl). The bufferd + has special keybindings for stepping and viewing sources. Enter the + debug loop with (si::dbl) or :dbl in a debug loop. " + + (interactive "p") + + (let ( tem + (dir default-directory) + ;; important for winnt version of emacs + (binary-process-input t) + (binary-process-output nil) + switches + (name (concat "dbl" (if (equal p 1) "" p) "")) + ) + + (switch-to-buffer (concat "*" name "*")) + (or (bolp) (newline)) + (insert "Current directory is " default-directory "\n") + (let ((tem dbl-subshell-switches) switches) + (while tem + (cond ((string-match (car tem) dbl-command-name) + (setq switches (nth 1 tem)) (setq tem nil)) + (t (setq tem (nthcdr 2 tem))))) + (apply 'make-sshell name dbl-command-name nil switches)) + (dbl-mode) + (make-local-variable 'sshell-prompt-pattern) + (setq sshell-prompt-pattern dbl-prompt-pattern) + (goto-char (point-min)) + (insert " +Welcome to DBL a Debugger for Lisp, Maxima, Gdb and others. + +You start your program as usually would in a shell. For Lisp and +Maxima the debugger commands begin with a ':', and there is +completion. Typing ':' should list all the commands. In GCL these +are typed when in the debugger, and in Maxima they may be typed at any +time. To see the wonderful benefits of this mode, type C-h m. + +Note you may also use this mode to run gdb. In fact I often debug +MAXIMA over GCL using gdb, thus having three debuggers at once. +To run gdb and enable the automatic line display, you must supply +the `--fullname' keyword as in: + + gdb your-file --fullname +") + (goto-char (point-max)) + (set-process-filter (get-buffer-process (current-buffer)) 'dbl-filter) + (set-process-sentinel (get-buffer-process (current-buffer)) 'dbl-sentinel) + (dbl-set-buffer))) + +(defun dbl-set-buffer () + (cond ((eq major-mode 'dbl-mode) + (setq current-dbl-buffer (current-buffer))))) + +;; This function is responsible for inserting output from DBL +;; into the buffer. +;; Aside from inserting the text, it notices and deletes +;; each filename-and-line-number; +;; that DBL prints to identify the selected frame. +;; It records the filename and line number, and maybe displays that file. +(defun dbl-filter (proc string) + (let ((inhibit-quit t)) + (set-buffer (process-buffer proc)) + (goto-char (point-max)) + (insert string) + (goto-char (point-max)) + )) + + +(defun dbl-filter (proc string) + (let ((inhibit-quit t)) + (if dbl-filter-accumulator + (dbl-filter-accumulate-marker proc + (concat dbl-filter-accumulator string)) + (dbl-filter-scan-input proc string)) + )) + + +(defun dbl-filter-accumulate-marker (proc string) + (setq dbl-filter-accumulator nil) + (if (> (length string) 1) + (if (= (aref string 1) ?\032) + (let ((end (string-match "\n" string))) + (if end + (progn + (setq me string) + (cond ((string-match + "\032\032\\([A-Za-z]?:?[^:]*\\):\\([0-9]*\\):[^\n]+\n" + string) + (setq dbl-last-frame + (cons + (match-string 1 string) + (string-to-int (match-string 2 string)))) + + (cond ((equal (cdr dbl-last-frame) 0) + ;(message "got 0") + ;(sit-for 1) + (setq overlay-arrow-position nil) + (setq dbl-last-frame nil) + ) + (t (setq dbl-last-frame-displayed-p nil)) + ))) + + (dbl-filter-scan-input proc + (substring string (1+ end)))) + (setq dbl-filter-accumulator string))) + (dbl-filter-insert proc "\032") + (dbl-filter-scan-input proc (substring string 1))) + (setq dbl-filter-accumulator string))) + +(defun dbl-filter-scan-input (proc string) + (if (equal string "") + (setq dbl-filter-accumulator nil) + (let ((start (string-match "\032" string))) + (if start + (progn + ;; to do fix this so that if dbl-last-frame + ;; changed, then set the current text property.. + ;; + (dbl-filter-insert proc (substring string 0 start)) + + (dbl-filter-accumulate-marker proc + (substring string start)) + ) + (dbl-filter-insert proc string))))) + +(defun dbl-filter-insert (proc string) + (let (moving + output-after-point + (old-buffer (current-buffer)) + start) + (set-buffer (process-buffer proc)) + ;; test to see if we will move the point. We want that the + ;; window-point of the buffer, should be equal to process-mark. + (setq moving (>= (window-point (get-buffer-window (process-buffer proc))) + (- (process-mark proc) 0))) + (setq output-after-point (< (point) (process-mark proc))) + (unwind-protect + (save-excursion + ;; Insert the text, moving the process-marker. + (goto-char (process-mark proc)) + (setq start (point)) + (insert string) + (set-marker (process-mark proc) (point)) + ; (setq bill (cons (list 'hi (process-mark proc) (marker-position (process-mark proc)) (point)) bill)) + (dbl-maybe-delete-prompt) + ;; Check for a filename-and-line number. + (dbl-display-frame + ;; Don't display the specified file + ;; unless (1) point is at or after the position where output appears + ;; and (2) this buffer is on the screen. + (or output-after-point + (not (get-buffer-window (current-buffer)))) + ;; Display a file only when a new filename-and-line-number appears. + t) + ) + (if moving + (set-window-point + (get-buffer-window (process-buffer proc)) + (process-mark proc))) + (set-buffer old-buffer)) + )) + +(defun dbl-sentinel (proc msg) + (cond ((null (buffer-name (process-buffer proc))) + ;; buffer killed + ;; Stop displaying an arrow in a source file. + (setq overlay-arrow-position nil) + (set-process-buffer proc nil)) + ((memq (process-status proc) '(signal exit)) + ;; Stop displaying an arrow in a source file. + (setq overlay-arrow-position nil) + ;; Fix the mode line. + (setq mode-line-process + (concat ": " + (symbol-name (process-status proc)))) + (let* ((obuf (current-buffer))) + ;; save-excursion isn't the right thing if + ;; process-buffer is current-buffer + (unwind-protect + (progn + ;; Write something in *compilation* and hack its mode line, + (set-buffer (process-buffer proc)) + ;; Force mode line redisplay soon + (set-buffer-modified-p (buffer-modified-p)) + (if (eobp) + (insert ?\n mode-name " " msg) + (save-excursion + (goto-char (point-max)) + (insert ?\n mode-name " " msg))) + ;; If buffer and mode line will show that the process + ;; is dead, we can delete it now. Otherwise it + ;; will stay around until M-x list-processes. + (delete-process proc)) + ;; Restore old buffer, but don't restore old point + ;; if obuf is the dbl buffer. + (set-buffer obuf)))))) + + +(defun dbl-refresh () + "Fix up a possibly garbled display, and redraw the arrow." + (interactive) + (redraw-display) + (dbl-display-frame)) + +(defun dbl-display-frame (&optional nodisplay noauto) + "Find, obey and delete the last filename-and-line marker from DBL. +The marker looks like \\032\\032FILENAME:LINE:CHARPOS\\n. +Obeying it means displaying in another window the specified file and line." + (interactive) + (dbl-set-buffer) + (and dbl-last-frame (not nodisplay) + (or (not dbl-last-frame-displayed-p) (not noauto)) + (progn (dbl-display-line (car dbl-last-frame) (cdr dbl-last-frame)) + (setq dbl-last-frame-displayed-p t)))) + + +;; Make sure the file named TRUE-FILE is in a buffer that appears on the screen +;; and that its line LINE is visible. +;; Put the overlay-arrow on the line LINE in that buffer. + + + +(defun dbl-find-file (file) + (cond ((file-exists-p file) + (find-file-noselect file)) + ((get-buffer file)) + (t (find-file-noselect file)))) + +(defvar dbl-dirs nil) + +(defun search-path (file dirs) + (let ((paths (symbol-value dirs)) + true-file) + (cond ((file-exists-p file) (setq true-file file)) + (t + (while paths + (let ((tem (expand-file-name file (or (car paths) default-directory)))) + (if (file-exists-p tem) (setq true-file tem)) + (setq paths (cdr paths)))))) + + (cond (true-file) + (t (setq paths (symbol-value dirs)) + (set dirs + (append paths + (list (file-name-directory + (read-file-name + (format "%s = %s, add path :" dirs paths)))))) + (search-path file dirs))))) + + +(defun dbl-find-line () + "If the current buffer has a process, then look first for a file-line +property, and if none, then search for a regexp. +If a non process buffer, just return current file and line number. +" + (interactive) + (save-excursion + (end-of-line) + (cond ((get-buffer-process (current-buffer)) + (cond + ((save-excursion + (beginning-of-line) + (get-text-property (point) 'file-line))) + ((progn (end-of-line) (re-search-backward " \\([^: ]+\\):\\([0-9]+\\)" 300 nil)) + (setq file (buffer-substring (match-beginning 1) (match-end 1))) + (setq line (buffer-substring (match-beginning 2) (match-end 2))) + (setq line (read line)) + (and (integerp line) + (setq file (search-path file 'dbl-dirs)) + (list file line))))) + (t (list (buffer-file-name) (+ 1 (count-lines (point)))))))) + +(defun dbl-find-and-display-line () + (interactive) + (let ((res (dbl-find-line))) + (and res (apply 'dbl-display-line res)))) + +(defun dbl-display-line (true-file line) + (let* ((buffer (dbl-find-file true-file)) + (window (display-buffer buffer t)) + (pos)) + (save-excursion + (set-buffer buffer) + (save-restriction + (widen) + (goto-line line) + (setq pos (point)) + (setq overlay-arrow-string "=>") + (or overlay-arrow-position + (setq overlay-arrow-position (make-marker))) + (set-marker overlay-arrow-position (point) (current-buffer))) + (cond ((or (< pos (point-min)) (> pos (point-max))) + (widen) + (goto-char pos)))) + (set-window-point window overlay-arrow-position))) + +(defvar dbl-gdb-command-alist '((":step %p" . "step %p") + (":next %p" . "next %p") + (":stepi" . "stepi %p") + (":r" . "r") + (":finish" . "finish") + (":up %p" . "up %p") + ( ":down %p" . "down %p"))) + +(defun dbl-call (command numeric) + "Invoke dbl COMMAND displaying source in other window." + (interactive) + (save-excursion + (goto-char (point-max)) + (beginning-of-line) + (let (com) + (cond ((or (looking-at "(gdb") + (member major-mode '(c-mode c++-mode))) + (if (setq com (assoc command dbl-gdb-command-alist)) + (setq command (cdr com)))))) + + + ;; to do put in hook here to recognize whether at + ;; maxima or lisp level. + + (setq command (dbl-subtitute-% command numeric)) + (goto-char (point-max)) + (setq dbl-delete-prompt-marker (point-marker)) + (dbl-set-buffer) + (send-string (get-buffer-process current-dbl-buffer) + (concat command "\n")))) + +(defun dbl-subtitute-% (command n) + (let* (result + (in-dbl (get-buffer-process (current-buffer))) + file-line + ) + (cond ((string-match "%[fl]" command) + (cond (in-dbl (setq file-line (dbl-find-line))) + (t (setq file-line + (list (buffer-file-name) + (+ 1 (count-lines + (point))))))))) + (while (and command (string-match "\\([^%]*\\)%\\([adeflp]\\)" command)) + (let ((letter (string-to-char (substring command (match-beginning 2)))) + subst) + (cond ((eq letter ?p) + (setq subst (if n (int-to-string n) ""))) + ((eq letter ?f) + (setq subst (or (car file-line) "unknown-file"))) + ((eq letter ?l) + (setq subst (if (cadr file-line) + (int-to-string (cadr file-line)) + "unknown-line"))) + ((eq letter ?a) + (setq subst (dbl-read-address)))) + (setq result (concat result + (substring command (match-beginning 1) (match-end 1)) + subst))) + (setq command (substring command (match-end 2)))) + (concat result command))) + + + +(defun dbl-maybe-delete-prompt () + (if (and dbl-delete-prompt-marker + (> (point-max) (marker-position dbl-delete-prompt-marker))) + (let (start) + (goto-char dbl-delete-prompt-marker) + (setq start (point)) + (beginning-of-line) + (delete-region (point) start) + (setq dbl-delete-prompt-marker nil)))) + +(defun dbl-break () + "Set DBL breakpoint at this source line." + (interactive) + (cond ((eq major-mode 'lisp-mode) + (save-excursion + (end-of-line) + (let (name + at where) + (setq where (point)) + (mark-defun) + (search-forward "(def") + (forward-sexp 2) + (setq at (point)) + (forward-sexp -1) + (setq name (buffer-substring (point) at)) + (beginning-of-line) + (setq name (format "(si::break-function '%s %s t)" name (count-lines 1 where))) + (other-window 1) + (if (get-buffer-process (current-buffer)) + (setq current-dbl-buffer (current-buffer))) + (message name) + (send-string (get-buffer-process current-dbl-buffer) + (concat name "\n")) + (other-window 1) + ))) + (t + + (let ((file-name (file-name-nondirectory buffer-file-name)) + (line (save-restriction + (widen) + (1+ (count-lines 1 (point)))))) + (and downcase-filenames-for-dbl + (setq file-name (downcase file-name))) + (send-string (get-buffer-process current-dbl-buffer) + (concat "break " file-name ":" line "\n")))))) + + +(defun dbl-read-address() + "Return a string containing the core-address found in the buffer at point." + (save-excursion + (let ((pt (dot)) found begin) + (setq found (if (search-backward "0x" (- pt 7) t)(dot))) + (cond (found (forward-char 2)(setq result + (buffer-substring found + (progn (re-search-forward "[^0-9a-f]") + (forward-char -1) + (dot))))) + (t (setq begin (progn (re-search-backward "[^0-9]") (forward-char 1) + (dot))) + (forward-char 1) + (re-search-forward "[^0-9]") + (forward-char -1) + (buffer-substring begin (dot))))))) + + +(defvar dbl-commands nil + "List of strings or functions used by send-dbl-command. +It is for customization by you.") + +(defun send-dbl-command (arg) + + "This command reads the number where the cursor is positioned. It + then inserts this ADDR at the end of the dbl buffer. A numeric arg + selects the ARG'th member COMMAND of the list dbl-print-command. If + COMMAND is a string, (format COMMAND ADDR) is inserted, otherwise + (funcall COMMAND ADDR) is inserted. eg. \"p (rtx)%s->fld[0].rtint\" + is a possible string to be a member of dbl-commands. " + + + (interactive "P") + (let (comm addr) + (if arg (setq comm (nth arg dbl-commands))) + (setq addr (dbl-read-address)) + (if (eq (current-buffer) current-dbl-buffer) + (set-mark (point))) + (cond (comm + (setq comm + (if (stringp comm) (format comm addr) (funcall comm addr)))) + (t (setq comm addr))) + (switch-to-buffer current-dbl-buffer) + (goto-char (dot-max)) + (insert-string comm))) + +(provide 'dbl) diff --git a/elisp/doc-to-texi.el b/elisp/doc-to-texi.el new file mode 100755 index 0000000..f540fab --- /dev/null +++ b/elisp/doc-to-texi.el @@ -0,0 +1,126 @@ + +(load "../gcl-tk/convert.el") +;(let ((i 2000)) (while (> i 0) (do-one) (setq i (- i 1)))) + +(defun get-match (i) (buffer-substring (match-beginning i) (match-end i))) +(defun list-matches (l) + (let (ans) + (while l + (setq ans (cons (get-match (car l)) ans))) + (nreverse ans))) +(defun do-one () + (interactive) + + () + (beginning-of-line) + (re-search-forward "" nil t) + (let ((beg (point)) + def + (end (save-excursion (re-search-forward "" nil t) (point)))) + (cond ((looking-at "F\\([^\n]+\\)\n\\([^\n]+\\) in \\([A-Z_a-z]+\\) package[:]?[\n ]\\(Args\\|Syntax\\): ") + (let ((fun (get-match 1)) + (type (get-match 2)) + (package (get-match 3)) + args body) + (goto-char (match-end 0)) + (cond ((equal (get-match 4) "Syntax") + (setq args "") + (beginning-of-line)) + (t + (setq args + (progn (let ((beg (point))) + (forward-sexp 1) + (buffer-substring beg (point))))))) + + (setq body (buffer-substring (point) (- end 1))) + (delete-region beg end ) + (save-excursion + (get-buffer-create package) + (set-buffer package) + (goto-char (point-max)) + (insert + (if (equal type "Function") + (setq def "@defun") + (concat (setq def "@deffn") " {" type "}")) + " " + fun " " args "\nPackage:" package "\n" + body) + (insert "\n@end " (substring def 1) "\n") + ))) + ((looking-at "V\\([^\n]+\\)\n\\([^\n]+\\) in \\([A-Z_a-z]+\\) package:\n") + (let ((fun (get-match 1)) + (type (get-match 2)) + (package (get-match 3)) + args body) + (goto-char (match-end 0)) + (setq body (buffer-substring (point) (- end 1))) + (delete-region beg end ) + (save-excursion + (get-buffer-create package) + (set-buffer package) + (goto-char (point-max)) + (insert (if (string-match "^\\*" fun) + (setq def "@defvar") + (concat (setq def "@defvr")" {Constant}")) + " " + fun " " "\nPackage:" package "\n" + body ) + (insert "\n@end " (substring def 1) "\n"))))))) + + +(defun do-some () + (interactive) + (while (re-search-forward "{Constant}" nil t) + (let* ((tem (read-char )) + (u + (cdr (assoc tem + '((?s . "{Special Variable}") + (?d . "{Declaration}")))))) + (if u (replace-match u))))) + +(setq b-alist '((?n . "number.texi") + (?s . "sequence.texi") + (?c . "character.texi") + (?l . "list.texi") + (?i . "io.texi") + (?a . "internal.texi") + (?f . "form.texi") + (?C . "compile.texi") + (?S . "symbol.texi") + (?t . "system.texi") + (?d . "structure.texi") + (?I . "iteration.texi") + (?u . "user-interface.texi") + (?d . "doc.texi") + (?b . "type.texi") + )) +(defun try1 () + (interactive) + (while (re-search-forward "\n@def" nil t) + (let ((beg (match-beginning 0)) me tem + (end (save-excursion (re-search-forward "\n@end def[a-z]+" nil t) + (point)))) + (sit-for 0 300) + (setq tem (read-char )) + (cond ((setq tem (cdr (assoc tem b-alist))) + (setq me (buffer-substring beg end)) + (delete-region beg end) + (forward-char -2) + (save-excursion + (get-buffer-create tem) + (set-buffer tem) + (goto-char (point-max)) + (insert me "\n"))))))) + + + +(setq xall (mapcar 'cdr b-alist)) + +;(let ((all xall)) (while all (set-buffer (car all)) (write-file (car all)) (setq all (cdr all)))) +;(let ((all xall)) (while all (find-file (car all)) (setq all (cdr all)))) +(let ((all xall) x) (while all (set-buffer (car all)) (goto-char (point-min)) (insert "@node " (setq x (capitalize (car all))) "\n@chapter "x"\n") (write-file (car all)) (set-buffer "gcl-si.texi")(goto-char (point-max)) (insert "\\n@include " (car all) "\n") (setq all (cdr all)))) + + +(let ((all xall) x) (while all (switch-to-buffer (car all)) (goto-char (point-min)) (insert "@node " (setq x (capitalize (car all))) "\n@chapter "x"\n") (save-buffer) (set-buffer "gcl-si.texi")(goto-char (point-max)) (insert "\\n@include " (car all) "\n") (setq all (cdr all)))) + +(let ((all xall) x) (while all (switch-to-buffer (car all)) (goto-char (point-min)) (insert "@node " (setq x (capitalize (car all))) "\n@chapter "x"\n") (save-buffer) (set-buffer "gcl-si.texi")(goto-char (point-max)) (insert "\\n@include " (car all) "\n") (setq all (cdr all)))) diff --git a/elisp/gcl.el b/elisp/gcl.el new file mode 100755 index 0000000..92305c9 --- /dev/null +++ b/elisp/gcl.el @@ -0,0 +1,375 @@ +;; Copyright William F. Schelter. 1994 +;; Licensed by GNU public license. + +;; You should copy isp-complete.el to the emacs/lisp directory. + +;; Some commands and macros for dealing with lisp +;; M-X run : run gcl or another lisp +;; m-c-x ; evaluate defun in the other window or in the last lisp which you were using. +;; m-c-x ; with a numeric arg : compile the current defun in the other window +;; m-c-d ; disassemble in other window. +;; M-x macroexpand-next : macro expand the next sexp in other window. +;; C-h d Find documentation on symbol where the cursor is. +;; C-h / Find documentation on all strings containing a given string. +;; M-p complete the current input by looking back through the buffer to see what was last typed +;; using this prompt and this beginning. Useful in shell, in lisp, in gdb,... + + +(setq lisp-mode-hook 'remote-lisp) + +(autoload 'lisp-complete "lisp-complete" nil t) +(autoload 'smart-complete "smart-complete" nil t) + +;(global-set-key "p" 'lisp-complete) +(global-set-key "p" 'smart-complete) + +(defun remote-lisp (&rest l) + (and (boundp 'lisp-mode-map) + lisp-mode-map + (progn + (define-key lisp-mode-map "\e\C-d" 'lisp-send-disassemble) + (define-key lisp-mode-map "\e\C-x" 'lisp-send-defun-compile) + (make-local-variable 'lisp-package) + (setq lisp-package nil) + (and (boundp 'remote-lisp-hook) (funcall remote-lisp-hook)) + ))) + + +(defvar search-back-for-lisp-package-p nil) + +;; look at the beginning of buffer to try to find an in package statement +(defun get-buffer-package () + + "Returns what it thinks is the lisp package for the current buffer. +It caches this information in the local variable `lisp-package'. It +obtains the information from searching for the first in-package from +the beginning of the file. Since in common lisp, there is only +supposed to be one such statement, it should be able to determine +this. By setting lisp-package to t, you may disable its search. This +will also disable the automatic inclusion of an in-package statement +in the tmp-lisp-file, used for sending forms to the current +lisp-process." + + (cond ((eq lisp-package t) nil) + (search-back-for-lisp-package-p + (save-excursion + (cond ((re-search-backward "^[ \t]*(in-package " nil t) + (goto-char (match-end 0)) + (read (current-buffer)))))) + (lisp-package lisp-package) + (t + (setq + lisp-package + (let (found success) + (save-excursion + (goto-char (point-min)) + (while (not found) + (if (and (setq success (search-forward "(in-package " 1000 t)) + (not (save-excursion + (beginning-of-line) + (looking-at "[ \t]*;")))) + (setq found (read (current-buffer)))) + (if (>= (point) 980) (setq found t)) + (or success (setq found t)) + )) + found))))) + + +(defun run (arg) + "Run an inferior Lisp process, input and output via buffer *lisp*." + (interactive "sEnter name of file to run: ") + (require 'sshell) + ;; in emacs 19 uncomment: + ;;(require 'inf-lisp) + (setq lisp-mode-hook 'remote-lisp) + (switch-to-buffer (make-sshell (concat arg "-lisp") arg nil "-i")) + (make-local-variable 'shell-prompt-pattern) + (setq sshell-prompt-pattern "^[^#%)>]*[#%)>]+ *") + (cond ((or (string-match "maxima" arg) (string-match "affine" arg) + (save-excursion (sleep-for 2) + (re-search-backward "maxima" + (max 1 (- (point) 300)) + t))) + (require 'maxima-mode) + (inferior-maxima-mode) + (goto-char (point-max)) + ) + (t + (if (boundp 'inferior-lisp-mode) + (inferior-lisp-mode) + (funcall lisp-mode-hook)) + ))) + +(defun lisp-send-disassemble (arg) + (interactive "P") + (if arg + ( lisp-send-defun-compile "disassemble-h") + ( lisp-send-defun-compile "disassemble")) + ) + +(defvar time-to-throw-away nil) +(defvar telnet-new-line "") + +(defun lisp-send-defun-compile (arg) + + "Send the current defun (or other form) to the lisp-process. If there +is a numeric arg, the form (compile function-name) is also sent. The +value of lisp-process will be the process of the other exposed window (if +there is one) or else the global value of lisp-process. If the +...received message is not received, probably either the reading of +the form caused an error. If the process does not have telnet in +its name, then we write a tmp file and load it. +If :sdebug is in *features*, then si::nload is used instead of +ordinary load, in order to record line information for debugging. + +The value of `lisp-package' if non nil, will be used in putting an +in-package statement at the front of the tmp file to be loaded. +`lisp-package' is determined automatically on a per file basis, +by get-buffer-package. +" + + (interactive "P") + (other-window 1) + (let* ((proc (or (get-buffer-process (current-buffer)) lisp-process)) + def beg + (this-lisp-process proc) + (lisp-buffer (process-buffer this-lisp-process)) + fun) + (other-window 1) + (save-excursion + (end-of-defun) + (let ((end (dot)) (buffer (current-buffer)) + (proc (get-process this-lisp-process))) + (setq lisp-process proc) + (beginning-of-defun) + (save-excursion + (cond ((and arg (looking-at "(def")) (setq def t)) + (t (setq arg nil))) + (cond (def (forward-char 2)(forward-sexp 1) + (setq fun (read buffer)) + (setq fun (prin1-to-string fun)) + (message (format + "For the lisp-process %s: %s" + (prin1-to-string this-lisp-process) fun))))) + (cond ((equal (char-after (1- end)) ?\n) + (setq end (1- end)) )) + (setq beg (dot)) + (my-send-region this-lisp-process beg end) + )) + + + (send-string this-lisp-process + (concat ";;end of form" "\n" telnet-new-line)) + (cond (arg + (if (numberp arg) (setq arg "compile")) + (send-string this-lisp-process (concat "(" arg "'" fun ")" + telnet-new-line)))) + (and time-to-throw-away + (string-match "telnet"(buffer-name (process-buffer proc))) + (dump-output proc time-to-throw-away)) + (cond (nil ;(get-buffer-window lisp-buffer) + (select-window (get-buffer-window lisp-buffer)) + (goto-char (point-max))) + (t nil)))) + +(fset 'lisp-eval-defun (symbol-function 'lisp-send-defun-compile)) + +(defvar telnet-new-line "") +(defvar tmp-lisp-file (concat "/tmp/" (user-login-name) ".lsp")) + +(defun get-buffer-clear (name) + (let ((cb (current-buffer)) + (buf (get-buffer-create name))) + (set-buffer buf) + (erase-buffer) + (set-buffer cb) + buf)) + +(defmacro my-with-output-to-temp-buffer (name &rest body) + (append (list + 'let + (list (list 'standard-output (list 'get-buffer-clear name)))) + body)) + + +(defun my-send-region (proc beg end) + (cond ((or (string-match "telnet" (process-name proc))) + (send-region proc beg end)) + (t + (let ((package (get-buffer-package))) + (save-excursion + (my-with-output-to-temp-buffer "*tmp-gcl*" + (if (and package (not (eq package t))) + (prin1 (list 'in-package package))) + (princ ";!(:line ") + (prin1 + (let ((na (buffer-file-name (current-buffer)))) + (if na (expand-file-name na) + (buffer-name (current-buffer)))) + ) + (princ (- (count-lines (point-min) (+ beg 5)) 1)) + (princ ")\n") + (set-buffer "*tmp-gcl*") + (write-region (point-min) (point-max) tmp-lisp-file nil nil))) + (write-region beg end tmp-lisp-file t nil) + (message "sending ..") + (send-string + proc + (concat "(lisp::let ((*load-verbose* nil)) (#+sdebug si::nload #-sdebug load \"" + tmp-lisp-file + "\")#+gcl(setq si::*no-prompt* t)(values))\n ") + ) + (message (format "PACKAGE: %s ..done" + (if (or (not package) (eq package t)) + "none" + package))) + + + )))) + +(defun dump-output (proc seconds) + "dump output for PROCESS for SECONDS or to \";;end of form\"" + (let ((prev-filter (process-filter proc)) (already-waited 0)) + (unwind-protect (progn (set-process-filter proc 'dump-filter) + (while (< already-waited seconds) + (sleep-for 1)(setq already-waited + (1+ already-waited)))) + (set-process-filter proc prev-filter)))) + + + +(defun dump-filter (proc string) +; (setq she (cons string she)) + (let ((ind (string-match ";;end of form" string))) + (cond (ind (setq string (substring + string + (+ ind (length + ";;end of form")))) + + (message "... received.") + (setq already-waited 1000) + (set-process-filter proc prev-filter) + (cond (prev-filter (funcall prev-filter proc string)) + (t string))) + (t "")))) + + +;;(process-filter (get-process "lisp")) +(defun macroexpand-next () + "macroexpand current form" + (interactive) + (save-excursion + (let ((beg (point))) + (forward-sexp ) + (message "sending macro") + + (let* ((current-lisp-process + (or (get-buffer-process (current-buffer)) + (prog2 (other-window 1) + (get-buffer-process (current-buffer)) + (other-window 1))))) + (send-string current-lisp-process "(macroexpand '") + (send-region current-lisp-process beg (point) ) + (send-string current-lisp-process ")\n"))))) + +(defun delete-comment-char (arg) + (while (and (> arg 0) (looking-at comment-start)) (delete-char 1) + (setq arg (1- arg)))) + +(defun mark-long-comment () + (interactive) + (let ((at (point))) + (beginning-of-line) + (while(and (not (eobp)) + (or (looking-at comment-start) + ;(looking-at "[ ]*\n") + )) + (forward-line 1)) + (set-mark (point)) + (goto-char at) + (while(and (not (bobp)) + (or (looking-at comment-start) + ;(looking-at "[ ]*\n") + )) + (forward-line -1)) + (or (bobp )(forward-line 1)))) + + +(defun fill-long-comment () + (interactive) + (mark-long-comment) + (let ((beg (min (dot) (mark))) + (end (max (dot) (mark))) (n 0)m) + (narrow-to-region beg end) + (goto-char (point-min)) + (while (looking-at ";") + (forward-char 1)) + (setq n (- (point) beg)) + (goto-char (point-min)) + (while (not (eobp)) + (setq m n) + (while (> m 0) + (cond ((looking-at ";") + (delete-char 1) + (cond ((looking-at " ")(delete-char 1)(setq m 0))) + (setq m (- m 1))) + (t (setq m 0)))) + (forward-line 1)) + (fill-region (dot-min) (dot-max)) + (goto-char (point-min)) + (while (not (eobp)) + (cond ((looking-at "\n") + nil) + (t(insert ";; "))) + (forward-line 1)) + (goto-char (point-min)) + (set-mark (point-max)) + (widen))) + +(defun comment-region (arg) + "Comments the region, with a numeric arg deletes up to arg comment +characters from the beginning of each line in the region. The region stays, +so a second comment-region adds another comment character" + (interactive "P") + (save-excursion + (let ((beg (dot)) + (ok t)(end (mark))) + (comment-region1 beg end arg)))) + +(defun comment-region1 (beg end arg) + (let ((ok t)) + (cond((> beg end) + (let ((oth end)) + (setq end beg beg oth)))) + (narrow-to-region beg end) + (goto-char beg) + (unwind-protect + (while ok + (cond (arg + (delete-comment-char arg)) + (t (insert-string comment-start))) + (if (< end (dot)) (setq ok nil) + (if (search-forward "\n" end t) nil (setq ok nil))) ) + (widen)))) + +(defun trace-expression () + (interactive) + (save-excursion + (forward-sexp ) + (let ((end (point))) + (forward-sexp -1) + (other-window 1) + (let* ((proc (get-buffer-process (current-buffer))) + (current-lisp-process (or proc lisp-process))) + (other-window 1) + (message "Tracing: %s" (buffer-substring (point) end)) + (send-string current-lisp-process "(trace ") + (send-region current-lisp-process (point) end) + (send-string current-lisp-process ")\n"))))) + +(defun gcl-mode () + (interactive) + (lisp-mode) + ) + +(provide 'gcl) \ No newline at end of file diff --git a/elisp/makefile b/elisp/makefile new file mode 100644 index 0000000..6ee4b3f --- /dev/null +++ b/elisp/makefile @@ -0,0 +1,18 @@ + + +-include ../makedefs + +install: + mkdir -p $(DESTDIR)$(EMACS_SITE_LISP) + cp *.el $(DESTDIR)$(EMACS_SITE_LISP) + if [ "$(EMACS_DEFAULT_EL)" != "" ] ; then \ + if test -f "$(DESTDIR)${EMACS_DEFAULT_EL}" ; then \ + cat $(DESTDIR)${EMACS_DEFAULT_EL} | sed -e '/BEGIN gcl/,/END gcl/d' > $(DESTDIR)$(EMACS_SITE_LISP)/temp_emacs_default ; \ + mv $(DESTDIR)${EMACS_DEFAULT_EL} $(DESTDIR)${EMACS_DEFAULT_EL}.prev ; \ + rm -f $(DESTDIR)${EMACS_DEFAULT_EL}c ; \ + cat add-default.el >> $(DESTDIR)$(EMACS_SITE_LISP)/temp_emacs_default ; cp $(DESTDIR)$(EMACS_SITE_LISP)/temp_emacs_default $(DESTDIR)${EMACS_DEFAULT_EL} ; \ + rm -f $(DESTDIR)$(EMACS_SITE_LISP)/temp_emacs_default ; else \ + cp add-default.el $(DESTDIR)${EMACS_DEFAULT_EL} ; fi ; \ + chmod a+r $(DESTDIR)${EMACS_DEFAULT_EL} ; fi + + diff --git a/elisp/man1-to-texi.el b/elisp/man1-to-texi.el new file mode 100755 index 0000000..258ad20 --- /dev/null +++ b/elisp/man1-to-texi.el @@ -0,0 +1,414 @@ +;;;;if you are in a buffer which has a man page you can try +;; M-x doit, to do an at least partial conversion of tcl tk man pages to +;; texinfo + +;; file for converting the tcl/tk man pages to texinfo and suitable for gcl/tk +; .bp begin new page +; .br break output line here +; .sp n insert n spacing lines +; .ls n (line spacing) n=1 single, n=2 double space +; .na no alignment of right margin +; .ce n center next n lines +; .ul n underline next n lines +; .sz +n add n to point size +; +; Requests +; Request Cause If no Explanation +; Break Argument +; +; .B t no t=n.t.l.* Text is in bold font. +; .BI t no t=n.t.l. Join words, alternating bold +; and italic. +; .BR t no t=n.t.l. Join words, alternating bold +; and roman. +; .DT no .5i 1i... Restore default tabs. +; .HP i yes i=p.i.* Begin paragraph with hanging +; indent. Set prevailing indent to i. +; .I t no t=n.t.l. Text is italic. +; .IB t no t=n.t.l. Join words, alternating italic +; and bold. +; +; .IP x i yes x="" Same as .TP with tag x. +; .IR t no t=n.t.l. Join words, alternating italic +; and roman. +; .IX t no - Index macro, for Sun internal +; use. +; .LP yes - Begin left-aligned paragraph. +; Set prevailing indent to .5i. +; .PD d no d=.4v Set vertical distance between +; paragraphs. +; .PP yes - Same as .LP. +; .RE yes - End of relative indent. +; Restores prevailing indent. +; .RB t no t=n.t.l. Join words, alternating roman +; and bold. +; .RI t no t=n.t.l. Join words, alternating roman +; and italic. +; .RS i yes i=p.i. Start relative indent, +; increase indent by i. Sets prevailing indent to +; .5i for nested indents. +; .SB t no - Reduce size of text by 1 +; point, make text boldface. +; .SH t yes - Section Heading. +; .SM t no t=n.t.l. Reduce size of text by 1 +; point. +; .SS t yes t=n.t.l. Section Subheading. +; .TH n s d f m +; yes - Begin reference page n, of +; section s; d is the date of the most +; recent change. If present, f +; is the left page footer; m is the +; main page (center) header. +; Sets prevailing indent and tabs to .5i. +; .TP i yes i=p.i. Begin indented paragraph, with +; the tag given on the next text +; line. Set prevailing indent +; to i. +; +; .TX t p no - Resolve the title abbreviation +; t; join to punctuation mark (or text) p. * +; n.t.l. = next text line; p.i. = prevailing +; indent +; .HS name section [date [version]] +; Replacement for .TH in other man pages. See below for valid +; section names. +; +; .AP type name in/out [indent] +; Start paragraph describing an argument to a library procedure. +; type is type of argument (int, etc.), in/out is either "in", "out", +; or "in/out" to describe whether procedure reads or modifies arg, +; and indent is equivalent to second arg of .IP (shouldn't ever be +; needed; use .AS below instead) +; +; .AS [type [name]] +; Give maximum sizes of arguments for setting tab stops. Type and +; name are examples of largest possible arguments that will be passed +; to .AP later. If args are omitted, default tab stops are used. +; +; .BS +; Start box enclosure. From here until next .BE, everything will be +; enclosed in one large box. +; +; .BE +; End of box enclosure. +; +; .VS +; Begin vertical sidebar, for use in marking newly-changed parts +; of man pages. +; +; .VE +; End of vertical sidebar. +; +; .DS +; Begin an indented unfilled display. +; +; .DE +; End of indented unfilled display. +; + +(defun do-replace (lis &optional not-in-string) + (let (x case-fold-search) + (while lis + (setq x (car lis)) (setq lis (cdr lis)) + (goto-char (point-min)) + (message "doing %s " x) + (while (re-search-forward (nth 0 x) nil t) + (and not-in-string + (progn (forward-char -1) + (not (in-a-string)))) + (let ((f (nth 1 x))) + (cond ((stringp f) + (replace-match f t)) + (t (let ((i 0) ans) + (while (match-beginning i) + (setq ans (cons (buffer-substring + (match-beginning i) + (match-end i)) ans)) + (setq i (+ i 1))) + (setq ans (nreverse ans)) + (goto-char (match-beginning 0)) + (delete-region (match-beginning 0) + (match-end 0)) + (apply f ans))))))))) + + + + +(defun doit () + (interactive) + (texinfo-mode) + (goto-char (point-min)) + (do-replace '(("@" "@@") + ("^[.]VS\n" "") + ("^[.]VE\n" "") + )) + (goto-char (point-min)) + (insert "@setfilename foo.info") + (insert "\n") + (do-tables) +; (do-nf) + (do-replace + '( + (".SH \"SEE ALSO\"\n\\([^\n]*\\)" "@xref{\\1}") + ("^[.]SH NAME" "") + ("^'[\\]\"[^\n]*\n" "") + ("^'[/]\"[^\n]*\n" "") + ("^[.]so[^\n]+\n" "") + ("[.]HS \\([^ \n]+\\)\\([^\n]*\\)\n" + "@node \\1\n@subsection \\1\n") + ("^[.]VS\n" "") + ("^[.]VE\n" "") + (".nf\nName:\t\\([^\n]*\\)\nClass:\t\\([^\n]*\\)\nCommand-Line Switch:\t\\([^\n]*\\)\n.fi\n" do-keyword) + ("Name:\t\\([^\n]*\\)\nClass:\t\\([^\n]*\\)\nCommand-Line Switch:\t\\([^\n]*\\)\n" do-keyword) + ("Name:\t\\([^\n]*\\)\n" "@*@w{ Name: @code{\\1}}\n") + ("Class:\t\\([^\n]*\\)\n" "@*@w{ Class: @code{\\1}}\n") + ("Command-Line Switch:\t\\([^\n]*\\)\n" "@*@w{ Keyword: @code{\\1}}\n") + ("[\\]-\\([a-z]\\)" ":\\1") + ("^[.]nf\n" "@example\n") + ("^[.]fi\n" "@end example\n") + ("^[.]ta[^\n]*\n" do-ta) + ("^[.]IP\n" "\n") + ("[\\]f\\([A-Z]\\)\\([^\\\n]*\\)[\\]f" + do-font) + ("^\\([^\n]+\\)\n[.]br" "@*@w{\\1}@*") + ("^[.]SH \\([^\n]*\\)" + (lambda (a0 a1) + (insert "@unnumberedsubsec " (capitalize a1)))) + ("[\\]fR" "") + + ("^[.]BS" "@cartouche") + ("^[.]BE" "@end cartouche") + ("^[.]sp \\([0-9]\\)" "@sp \\1") + ("^[.]sp" "@sp 1") + ("^[.]LP\n" "\n\n") + ("^[.][LP]P" "") + ("^[.]DS[^\n]*\n" "\n@example\n") + ("^[.]DE[^\n]*\n" "@end example\n\n") + ("^[.]DS[^\n]*\n" "\n@example\n") + ("^[.]DE[^\n]*\n" "@end example\n\n") + ("^[.]RS\n" "") ; relative indent increased.. + ("^[.]rE\n" "") + ("^[\\]&\\([^\n]*\\)\n" "@*@w{ \\1}\n") +; ("Command-Line Switch" "Keyword") + ("pathName }@b{\\([a-z]\\)" "pathName }@b{:\\1") + ("[\\]0" " ") + ("%\\([a-z#]\\)\\([^a-zA-Z0-9%]\\)" "|%\\1|\\2") + ("^[.]TP[^\n]*\n" "@item ") + )) + (add-keywords) + ) + +(defun do-font (ign a b) + (let ((ch (assoc (aref a 0) + '((?R . "@r{") + (?I . "@i{") + (?B . "@b{"))))) + (cond (ch (insert (cdr ch) b "}\\f") + (forward-char -2) + ) + (t (error "unknown leter %s" a))))) + +(defun do-keyword (ign name class key) + (insert "@table \n@item @code{"key "}" + "\n@flushright\nName=@code{\""name"\"} Class=@code{\""class "\"}\n" + "@end flushright\n@sp 1\n") + (save-excursion + (cond ((re-search-forward "[.]LP\\|[.]BE\\|[.]SH" nil t) + (beginning-of-line) + (insert "@end table\n"))))) + + + + +(defun try () + (interactive) + (if (get-buffer "foo.texi") + (kill-buffer (get-buffer "foo.texi"))) + + (if (get-buffer "foo.info") + (kill-buffer (get-buffer "foo.info"))) + + (find-file "foo.n") + (toggle-read-only 0) + (doit) + (write-file "foo.texi") + (makeinfo-buffer )) + +(defun foo () + (re-search-forward "\n\\|\\([\\]f[a-zA-Z]\\)" nil t) + (list (match-beginning 0) (match-beginning 1) (match-beginning 2))) + +(defun list-current-line () + (beginning-of-line) + (let (ans at-end (beg (point))) + (save-excursion + (while (not at-end) + (re-search-forward "\n\\|\\([\\]f[a-zA-Z]\\)" nil t) + (if (match-beginning 1) (replace-match "") + (setq at-end t)))) + (setq at-end nil) + (beginning-of-line) + (while (not at-end) + (re-search-forward "[\t\n]" nil t) + (let ((x (buffer-substring beg (- (point) 1)))) + (or (equal x "") + (setq ans (cons x ans)))) + + (setq beg (point)) + (setq at-end (equal (char-after (- (point) 1)) ?\n))) + (nreverse ans) + )) + +(defun do-ta (a0) + (let ((beg (point)) + items (vec (make-vector 10 0)) i (tot 0) surplus) + (while (not (looking-at "[.][LDI]")) + (cond ((looking-at "[.]")(forward-line 1)) + (t + (setq items (cons (list-current-line) items)) + (let ((tem (car items)) + (i 0)) + (while tem + (aset vec i (max (real-length (car tem)) (aref vec i))) + (setq i (+ i 1)) + (setq tem (cdr tem))) + )))) +; (message "%s" (list beg (point))) +; (sit-for 1) + + (delete-region beg (point)) +; (forward-line -2) +; (message "%s" vec) +; (sit-for 2) + (setq items (nreverse items)) + (setq i 0) + (while (< i (length vec)) (setq tot (+ (aref vec i) tot)) (setq i (+ i 1))) + (setq surplus (/ (- 70 tot) (+ 1 (length (car items))))) + (while items + (setq tem (car items)) + (setq i 0) + (let (ans x) + (insert "") + (while tem + (insert (tex-center (car tem) (+ (aref vec i) surplus) 'left + (real-length (car tem)))) + (setq tem (cdr tem)) (setq i (+ i 1))) + (insert "\n")) + (setq items (cdr items))) + ) + ) + + + + + + + +(defun real-length (item) + (let* ((n (length item)) (m (- n 1)) (start 0)) + (while (setq start (string-match "[\\]f" item start)) + (setq n (- n 3)) + (if (< start m) (setq start (+ start 1)))) + n)) + + +(defun do-tables () + (goto-char (point-min)) + (while (re-search-forward "^[.]TP" nil t) + (beginning-of-line) + (insert "\n@table @asis\n") + (forward-line 2) + (re-search-forward "^[.]\\(LP\\|BE\\|SH\\)" nil t) + (beginning-of-line) + (insert "@end table\n") + )) +(defun do-nf () + (goto-char (point-min)) + (while (re-search-forward "^[.]nf" nil t) + (forward-line 1) (beginning-of-line) + (while (not (looking-at "[.]fi")) + (insert "@w{" ) (end-of-line) (insert "}") + (forward-line 1) (beginning-of-line)))) + +(defun add-keywords () + (let ((tem tk-control-options)x lis l y) + (while tem + (setq l (car tem)) + (setq tem (cdr tem)) + (setq x (symbol-name (car l ))) + (setq lis (car (cdr l))) + (while lis + (cond ((atom lis) (setq lis nil)) + (t (setq y (symbol-name (car lis))) + (do-replace (list (list (concat x " "y "") + (concat x " :"y "") + ))))) + (setq lis (cdr lis)))))) + +(setq tk-control-options + '((after fixnum) + (exit fixnum) + (lower window) + (place pathName (-anchor -bordermode -height + -in -relheight -relwidth + -relx -rely -width -x -y)) + (send interpreter ) + ;(TKVARS "invalid command name \"tkvars\"") + (winfo (atom atomname cells children class containing + depth exists fpixels geometry height id + interps ismapped name parent pathname pixels + reqheight reqwidth rgb rootx rooty screen + screencells screendepth screenheight screenmmheight + screenmmwidth screenvisual screenwidth toplevel + visual vrootheight vrootwidth vrootx vrooty width x y) ) + (focus (default none) ) + (option (add clear get readfile)) + (raise pathname) + (tk colormodel) + (tkwait ( variable visible window) ) + (wm (aspect client command deiconify focusmodel frame geometry grid group iconbitmap iconify iconmask iconname iconposition iconwindow maxsize minsize overrideredirect positionfrom protocol sizefrom state title trace transient withdraw)) + (destroy window) + (grab (current release set status)) + (pack window (-after, -anchor, -before, -expand, -fill, -in, -ipadx, -ipady, -padx, -pady, -side) argggg) + (selection (clear get handle own)) + (tkerror "") + (update (idletasks)) + )) + +(setq tk-widget-options + '( + (button (activate configure deactivate flash invoke)) + (listbox ( configure curselection delete get insert nearest + scan select size xview yview)) + (scale ( configure get set)) + (canvas ( addtag bbox bind canvasx canvasy configure coords + create dchars delete dtag find focus gettags + icursor index insert itemconfigure lower move + postscript raise scale scan select type xview yview)) + (menu ( activate add configure delete disable enable + entryconfigure index invoke post unpost yposition)) + (scrollbar ( configure get set)) + (checkbutton + ( activate configure deactivate deselect flash + invoke select toggle)) + (menubutton + ( activate configure deactivate)) + (text ( compare configure debug delete get index insert + mark scan tag yview)) + (entry ( configure delete get icursor index insert scan select view)) + (message ( configure)) + (frame ( configure)) + (label ( configure)) + (radiobutton + ( activate configure deactivate deselect flash invoke select)) + (toplevel ( configure)) + )) + +(setq manual-sections + '(after bind button canvas checkbutton destroy entry exit focus foo frame grab label lbSingSel listbox lower menu menubar menubutton message option options pack-old pack place radiobutton raise scale scrollbar selection send text tk tkerror tkvars tkwait toplevel update winfo wm)) + +;(setq widgets (sort (mapcar 'car tk-widget-options) 'string-lessp)) +;(let ((m manual-sections)(tem widgets)) (while tem (setq manual-sections (delete (car tem) manual-sections))(setq tem (cdr tem)))) + + + diff --git a/elisp/readme b/elisp/readme new file mode 100755 index 0000000..c7c29fd --- /dev/null +++ b/elisp/readme @@ -0,0 +1,7 @@ + +dbl.el: mode for source level debugging lisp much like the authors gdb.el +gcl.el: mode for interacting with gcl +sshell.el: old fashioned shell mode, used by dbl.el. +lisp-complete.el: a history mechanism based on the prompt. + + diff --git a/elisp/smart-complete.el b/elisp/smart-complete.el new file mode 100644 index 0000000..b8b88f2 --- /dev/null +++ b/elisp/smart-complete.el @@ -0,0 +1,154 @@ +;; This file is part of GNU Emacs. +;; Copyright (C) 1998 William F. Schelter + +;; GNU Emacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY. No author or distributor accepts responsibility +;; to anyone for the consequences of using it or for whether it serves +;; any particular purpose or works at all, unless he says so in writing. +;; Refer to the GNU Emacs General Public License for full details. + +;; Everyone is granted permission to copy, modify and redistribute GNU +;; Emacs, but only under the conditions described in the GNU Emacs +;; General Public License. A copy of this license is supposed to have +;; been given to you along with GNU Emacs so you can know your rights and +;; responsibilities. It should be in a file named COPYING. Among other +;; things, the copyright notice and this notice must be preserved on all +;; copies. + + + +;; By Bill Schelter wfs@math.utexas.edu + +;; Completion on forms in the buffer. Does either a line or an sexp. +;; Uses the current prompt and the beginning of what you have typed. +;; Thus If the buffer contained + +;; (dbm:3) load("jo" +;; (C11) lo("ji") +;; (gdb) last +;; maxima>>4 +;; /home/bil# ls +;; then if you are at a prompt +;; "(C15) l" would match lo("ji") only, not "last", not "ls" nor load(" +;; and the commands with the (gdb) prompt would only match ones +;; starting with (gdb) .. + + +;; also if the command is a lisp sexp and this would be longer than the +;; current line, it grabs the whole thing. sometimes we have different +;; prompts, for different programs and we dont want to confuse the input +;; from one with input for another. Generally the prompt matches a +;; previous prompt, with numbers matching any number, and if there are +;; '/' then match anything up to a shell prompt terminator. Note it does +;; this without additional consing or building up huge lists of inputs. + + +(if (boundp 'comint-mode-map) + (define-key comint-mode-map "\ep" 'smart-complete) + ) + +(if (boundp 'sshell-mode-map) + (define-key sshell-mode-map "\ep" 'smart-complete) + (define-key sshell-mode-map "\M-p" 'smart-complete) + ) + +(defun get-match-n (i ) + (buffer-substring (match-beginning i) (match-end i))) + +(defun smart-complete () + "Begin to type the command and then type M-p. You will be + offered in the minibuffer a succession of choices, which + you can say 'n' to to get the next one, or 'y' or 'space' + to grab the current one. + + Thus to get the last command starting with 'li' you type + liM-py +" + (interactive ) + (let ((point (point)) new str tem prompt) + (save-excursion + (beginning-of-line) + (cond ((looking-at sshell-prompt-pattern) + (setq prompt (get-match-n 0)) + (setq str (buffer-substring (match-end 0) point))) + (t (error "Your prompt on this line does not match sshell-prompt-pattern"))) + + (setq new (smart-complete2 prompt str)) + ) + (cond (new + (delete-region (setq tem (- point (length str))) point) + (goto-char tem) + (insert new))))) + +(defun smart-complete2 (prompt str) + (let ((pt (point)) found + (pat (concat (regexp-for-this-prompt prompt) + "\\(" (regexp-quote str) "\\)" )) + offered (not-yet t) + ) + (setq bill pat) + (while (and not-yet + (re-search-backward pat nil t)) + (goto-char (match-beginning 1)) + (setq at (match-beginning 1)) + (goto-char at) + (setq this (buffer-substring at + (save-excursion (end-of-line) (point)))) + (or (member this offered) + (equal this str) + (progn (setq offered (cons this offered)) + ;; do this so the display does not shift... + (goto-char pt) + (setq not-yet + (not (y-or-n-p (concat "Use: " this " ")))))) + (cond (not-yet (goto-char at) (beginning-of-line) (forward-char -1)) + (t (setq found + (save-excursion + (buffer-substring + at + (progn (goto-char at) + (max (save-excursion + (end-of-line) (point)) + (save-excursion + (forward-sexp 1)(point))) + ))))))) + (or found (message "No more matches")) + found + )) + + +;; return a regexp for this prompt but with numbers replaced. + +(defun split-string-gcl (s bag) + (cond ((equal (length s) 0) '("")) + ((string-match bag s) + (if (= (match-beginning 0) 0) + (cons "" (split-string-gcl (substring s (match-end 0)) bag)) + (cons (substring s 0 (match-beginning 0)) + (split-string-gcl (substring s (match-end 0)) bag)))) + (t (cons s nil)))) + +;; Return a regexp which matches the current prompt, and which +;; allows things like +;; "/foo/bar# " to match "any# " +;; "(C12) " to match "(C1002) " but not (gdb) nor "(D12) " +;; if the prompt appears to be a pathname (ie has /) then +;; allow any beginning, otherwise numbers match numbers... +(defun regexp-for-this-prompt (prompt ) + (let ((wild (cond ((string-match "/" prompt) "[^ >#%()]+") + (t "[0-9]+")))) + (let ((tem (split-string-gcl prompt wild)) (ans "")) + (while tem + (setq ans (concat ans (regexp-quote (car tem)))) + (cond ((cdr tem) (setq ans (concat ans wild)))) + (setq tem (cdr tem))) + ans))) + + +(provide 'smart-complete) + + + + + + diff --git a/elisp/sshell.el b/elisp/sshell.el new file mode 100755 index 0000000..c80f9bf --- /dev/null +++ b/elisp/sshell.el @@ -0,0 +1,379 @@ + +;; Run subshell under Emacs +;; Copyright (C) 1985, 1986, 1987, 1988 Free Software Foundation, Inc. +;; Modifications by William Schelter +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 1, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +;; The following is a "simple shell" much like the one in version 18 +;; of emacs. Unfortunately cmint breaks most code which tries to use +;; the shell mode, and is rather complex. + +;; This mode uses a better completion mechanism (smart-complete.el), +;; in that it should +;; find the input you really want with your typing less keystrokes, +;; and easier keystrokes to type + + + + + +(defvar last-input-start nil + "In a sshell-mode buffer, marker for start of last unit of input.") +(defvar last-input-end nil + "In a sshell-mode buffer, marker for end of last unit of input.") + +(defvar sshell-mode-map nil) + +(defvar sshell-directory-stack nil + "List of directories saved by pushd in this buffer's sshell.") + +(defvar sshell-popd-regexp "popd" + "*Regexp to match subsshell commands equivalent to popd.") + +(defvar sshell-pushd-regexp "pushd" + "*Regexp to match subsshell commands equivalent to pushd.") + +(defvar sshell-cd-regexp "cd" + "*Regexp to match subsshell commands equivalent to cd.") + +(defvar explicit-sshell-file-name nil + "*If non-nil, is file name to use for explicitly requested inferior sshell.") + + +;In loaddefs.el now. +(defconst sshell-prompt-pattern + "\\(^\\|\n\\)[^ >]*[>$)%#:][>]*[ ]*" + "*Regexp used by Newline command to match subsshell prompts. +Anything from beginning of line up to the end of what this pattern matches +is deemed to be prompt, and is not reexecuted.") + +(defun sshell-mode () + "Major mode for interacting with an inferior sshell. +Sshell name is same as buffer name, sans the asterisks. +Return at end of buffer sends line as input. +Return not at end copies rest of line to end and sends it. + +The following commands imitate the usual Unix interrupt and +editing control characters: +\\{sshell-mode-map} + +Entry to this mode calls the value of sshell-mode-hook with no args, +if that value is non-nil. + +cd, pushd and popd commands given to the sshell are watched +by Emacs to keep this buffer's default directory +the same as the sshell's working directory. +Variables sshell-cd-regexp, sshell-pushd-regexp and sshell-popd-regexp +are used to match these command names. + +You can send text to the sshell (or its subjobs) from other buffers +using the commands process-send-region, process-send-string +and lisp-send-defun." + (interactive) + (kill-all-local-variables) + (setq major-mode 'sshell-mode) + (setq mode-name "Sshell") + (setq mode-line-process '(": %s")) + (use-local-map sshell-mode-map) + (make-local-variable 'sshell-directory-stack) + (setq sshell-directory-stack nil) + (make-local-variable 'last-input-start) + (setq last-input-start (make-marker)) + (make-local-variable 'last-input-end) + (setq last-input-end (make-marker)) + (run-hooks 'sshell-mode-hook)) + +(if sshell-mode-map + nil + (setq sshell-mode-map (make-sparse-keymap)) + (define-key sshell-mode-map "\t" 'sshell-complete-filename) + (define-key sshell-mode-map "\C-m" 'sshell-send-input) + (define-key sshell-mode-map "\C-c\C-d" 'sshell-send-eof) + (define-key sshell-mode-map "\C-c\C-u" 'kill-sshell-input) + (define-key sshell-mode-map "\C-c\C-w" 'backward-kill-word) + (define-key sshell-mode-map "\C-c\C-c" 'interrupt-sshell-subjob) + (define-key sshell-mode-map "\C-c\C-z" 'stop-sshell-subjob) + (define-key sshell-mode-map "\C-c\C-\\" 'quit-sshell-subjob) + (define-key sshell-mode-map "\C-c\C-o" 'kill-output-from-sshell) + (define-key sshell-mode-map "\C-c\C-r" 'show-output-from-sshell) + (define-key sshell-mode-map "\C-c\C-y" 'copy-last-sshell-input)) + + +(defun sshell-complete-filename () + (interactive) + (let* ((p (point)) tem beg + (ff + (save-excursion + (skip-chars-backward "[a-z---_0-9$/A-Z~#.]") + (buffer-substring (setq beg (point)) p)))) + (setq dir (or (file-name-directory ff) default-directory)) + (setq file (file-name-nondirectory ff)) + (cond ((and (setq tem (file-name-completion (or file "") dir)) + (not (equal tem file))) + (cond ((eq tem t)) + (t + (delete-region beg p) + (insert (concat dir tem))))) + (t + (let ((lis (file-name-all-completions file dir))) + (with-output-to-temp-buffer "*completions*" + (display-completion-list lis)) + ))))) + +(defvar explicit-csh-args + (if (eq system-type 'hpux) + ;; -T persuades HP's csh not to think it is smarter + ;; than us about what terminal modes to use. + '("-i" "-T") + '("-i")) + "Args passed to inferior sshell by M-x sshell, if the sshell is csh. +Value is a list of strings, which may be nil.") + + +(defun sshell () + "Run an inferior sshell, with I/O through buffer *sshell*. +If buffer exists but sshell process is not running, make new sshell. +Program used comes from variable explicit-sshell-file-name, + or (if that is nil) from the ESHELL environment variable, + or else from SHELL if there is no ESHELL. +If a file ~/.emacs_SHELLNAME exists, it is given as initial input + (Note that this may lose due to a timing error if the sshell + discards input when it starts up.) +The buffer is put in sshell-mode, giving commands for sending input +and controlling the subjobs of the sshell. See sshell-mode. +See also variable sshell-prompt-pattern. + +The sshell file name (sans directories) is used to make a symbol name +such as `explicit-csh-arguments'. If that symbol is a variable, +its value is used as a list of arguments when invoking the sshell. +Otherwise, one argument `-i' is passed to the sshell. + +Note that many people's .cshrc files unconditionally clear the prompt. +If yours does, you will probably want to change it." + (interactive) + (let* ((prog (or explicit-sshell-file-name + (getenv "ESHELL") + (getenv "SHELL") + "/bin/sh")) + (name (file-name-nondirectory prog))) + (switch-to-buffer + (apply 'make-sshell "shell" prog + (if (file-exists-p (concat "~/.emacs_" name)) + (concat "~/.emacs_" name)) + (let ((symbol (intern-soft (concat "explicit-" name "-args")))) + (if (and symbol (boundp symbol)) + (symbol-value symbol) + '("-i"))))))) + +(defun make-sshell (name program &optional startfile &rest switches) + (let ((buffer (get-buffer-create (concat "*" name "*"))) + proc status size) + (setq proc (get-buffer-process buffer)) + (if proc (setq status (process-status proc))) + (save-excursion + (set-buffer buffer) + ;; (setq size (buffer-size)) + (if (memq status '(run stop)) + nil + (if proc (delete-process proc)) + (setq proc (apply 'start-process name buffer + (or program explicit-sshell-file-name + (getenv "ESHELL") + (getenv "SHELL") + "/bin/sh") + switches)) + + (cond (startfile + ;;This is guaranteed to wait long enough + ;;but has bad results if the sshell does not prompt at all + ;; (while (= size (buffer-size)) + ;; (sleep-for 1)) + ;;I hope 1 second is enough! + (sleep-for 1) + (goto-char (point-max)) + (insert-file-contents startfile) + (setq startfile (buffer-substring (point) (point-max))) + (delete-region (point) (point-max)) + (process-send-string proc startfile))) + (setq name (process-name proc))) + (goto-char (point-max)) + (set-marker (process-mark proc) (point)) + (sshell-mode)) + buffer)) + +(defvar sshell-set-directory-error-hook 'ignore + "Function called with no arguments when sshell-send-input +recognizes a change-directory command but gets an error +trying to change Emacs's default directory.") + +(defun sshell-send-input () + "Send input to subsshell. +At end of buffer, sends all text after last output + as input to the subsshell, including a newline inserted at the end. +When not at end, copies current line to the end of the buffer and sends it, +after first attempting to discard any prompt at the beginning of the line +by matching the regexp that is the value of sshell-prompt-pattern if possible. +This regexp should start with \"^\"." + (interactive) + (or (get-buffer-process (current-buffer)) + (error "Current buffer has no process")) + (end-of-line) + (if (eobp) + (progn + (move-marker last-input-start + (process-mark (get-buffer-process (current-buffer)))) + (insert ?\n) + (move-marker last-input-end (point))) + (beginning-of-line) + ;; Exclude the sshell prompt, if any. + (re-search-forward sshell-prompt-pattern + (save-excursion (end-of-line) (point)) + t) + (let ((copy (buffer-substring (point) + (progn (forward-line 1) (point))))) + (goto-char (point-max)) + (move-marker last-input-start (point)) + (insert copy) + (move-marker last-input-end (point)))) + ;; Even if we get an error trying to hack the working directory, + ;; still send the input to the subsshell. + (condition-case () + (save-excursion + (goto-char last-input-start) + (sshell-set-directory)) + (error (funcall sshell-set-directory-error-hook))) + (let ((process (get-buffer-process (current-buffer))) + (s (buffer-substring last-input-start last-input-end)) + ) + ;; avoid sending emacs's idea of what an international character + ;; set string is to a subprocess.. + (if (fboundp 'string-make-unibyte) + (setq s (string-make-unibyte s))) + (process-send-string process s) + (set-marker (process-mark process) (point)))) + +;;; If this code changes (sshell-send-input and sshell-set-directory), +;;; the customization tutorial in +;;; info/customizing-tutorial must also change, since it explains this +;;; code. Please let marick@gswd-vms.arpa know of any changes you +;;; make. + + +(defun sshell-set-directory () + (cond ((and (looking-at sshell-popd-regexp) + (memq (char-after (match-end 0)) '(?\; ?\n))) + (if sshell-directory-stack + (progn + (cd (car sshell-directory-stack)) + (setq sshell-directory-stack (cdr sshell-directory-stack))))) + ((looking-at sshell-pushd-regexp) + (cond ((memq (char-after (match-end 0)) '(?\; ?\n)) + (if sshell-directory-stack + (let ((old default-directory)) + (cd (car sshell-directory-stack)) + (setq sshell-directory-stack + (cons old (cdr sshell-directory-stack)))))) + ((memq (char-after (match-end 0)) '(?\ ?\t)) + (let (dir) + (skip-chars-forward "^ ") + (skip-chars-forward " \t") + (if (file-directory-p + (setq dir + (expand-file-name + (substitute-in-file-name + (buffer-substring + (point) + (progn + (skip-chars-forward "^\n \t;") + (point))))))) + (progn + (setq sshell-directory-stack + (cons default-directory sshell-directory-stack)) + (cd dir))))))) + ((looking-at sshell-cd-regexp) + (cond ((memq (char-after (match-end 0)) '(?\; ?\n)) + (cd (getenv "HOME"))) + ((memq (char-after (match-end 0)) '(?\ ?\t)) + (let (dir) + (forward-char 3) + (skip-chars-forward " \t") + (if (file-directory-p + (setq dir + (expand-file-name + (substitute-in-file-name + (buffer-substring + (point) + (progn + (skip-chars-forward "^\n \t;") + (point))))))) + (cd dir)))))))) + +(defun sshell-send-eof () + "Send eof to subsshell (or to the program running under it)." + (interactive) + (process-send-eof)) + +(defun kill-output-from-sshell () + "Kill all output from sshell since last input." + (interactive) + (goto-char (point-max)) + (beginning-of-line) + (kill-region last-input-end (point)) + (insert "*** output flushed ***\n") + (goto-char (point-max))) + +(defun show-output-from-sshell () + "Display start of this batch of sshell output at top of window. +Also put cursor there." + (interactive) + (set-window-start (selected-window) last-input-end) + (goto-char last-input-end)) + +(defun copy-last-sshell-input () + "Copy previous sshell input, sans newline, and insert before point." + (interactive) + (insert (buffer-substring last-input-end last-input-start)) + (delete-char -1)) + +(defun interrupt-sshell-subjob () + "Interrupt this sshell's current subjob." + (interactive) + (interrupt-process nil t)) + +(defun kill-sshell-subjob () + "Send kill signal to this sshell's current subjob." + (interactive) + (kill-process nil t)) + +(defun quit-sshell-subjob () + "Send quit signal to this sshell's current subjob." + (interactive) + (quit-process nil t)) + +(defun stop-sshell-subjob () + "Stop this sshell's current subjob." + (interactive) + (stop-process nil t)) + +(defun kill-sshell-input () + "Kill all text since last stuff output by the sshell or its subjobs." + (interactive) + (kill-region (process-mark (get-buffer-process (current-buffer))) + (point))) +(require 'smart-complete) + +(provide 'sshell) \ No newline at end of file diff --git a/eval.html b/eval.html new file mode 100755 index 0000000..042cde5 --- /dev/null +++ b/eval.html @@ -0,0 +1,106 @@ + + +Tcl Evaluator-In-A-Page + + + + + + +

Tcl Evaluator-in-a-Page

+

[Sun Home | Tcl +Plugin | Demos]

+

+

+

+Below is a little evaluator for Tcl commands. Type any valid Tcl command +in and see the result immediately. Check out our quick tour of the +Tcl syntax. For example, to create a new +button, type the following: +

+button .b -text hello -background red
+pack .b
+
When you're done with the button, type: +
+destroy .b
+
and it's gone. You may also want to use the puts +command to output results from within loops. For example: +
+foreach proc [info procs] {
+    puts "$proc [info args $proc]"
+}
+
+
+ +

+ +

+To learn more about Tcl, read either Brent +Welch'sor John Ousterhout's +Tcl books. Many more Tcl and Tk resources are available here. + + +

Source:

+

+

+

+Here is the source for the evaluator application: +

+
+# A frame, scrollbar, and text
+frame .eval
+set _t [text .eval.t -width 40 -height 15 -yscrollcommand {.eval.s set}]
+scrollbar .eval.s -command {.eval.t yview}
+pack .eval.s -side left -fill y
+pack .eval.t -side right -fill both -expand true
+pack .eval -fill both -expand true
+
+# Insert the prompt and initialize the limit mark
+.eval.t insert insert "Tcl eval log\n"
+set prompt "tcl> "
+.eval.t insert insert $prompt
+.eval.t mark set limit insert
+.eval.t mark gravity limit left
+focus .eval.t
+
+# Keybindings that limit input and eval things
+bind .eval.t <Return> { _Eval .eval.t ; break }
+bind .eval.t <Any-Key> {
+	if [%W compare insert < limit] {
+		%W mark set insert end
+	}
+}
+bindtags .eval.t {.eval.t Text all}
+
+proc _Eval { t } {
+	global prompt
+	set command [$t get limit end]
+	if [info complete $command] {
+		$t insert insert \n
+		set err [catch {uplevel #0 $command} result]
+		if {[string length $result] > 0} {
+		    $t insert insert $result\n
+		}
+		$t insert insert $prompt
+		$t see insert
+		$t mark set limit insert
+		return
+	} else {
+		$t insert insert \n
+	}
+}
+proc puts {args} {
+    if {[string match -nonewline* $args]} {
+	set args [lrange $args 1 end]
+	set nonewline 1
+    }
+    .eval.t insert end [lindex $args end]	;# Ignore file specifier
+    if ![info exists nonewline] {
+	.eval.t insert end \n
+    }
+}
+
+ + + + diff --git a/eval.tcl b/eval.tcl new file mode 100755 index 0000000..85ef6c3 --- /dev/null +++ b/eval.tcl @@ -0,0 +1,79 @@ +# A frame, scrollbar, and text +frame .eval +set _t [text .eval.t -width 40 -height 15 -yscrollcommand {.eval.s set}] +scrollbar .eval.s -command {.eval.t yview} +pack .eval.s -side left -fill y +pack .eval.t -side right -fill both -expand true +pack .eval -fill both -expand true + +# Insert the prompt and initialize the limit mark +.eval.t insert insert "Tcl eval log\n" +set prompt "tcl> " +.eval.t insert insert $prompt +.eval.t mark set limit insert +.eval.t mark gravity limit left +focus .eval.t + +# Keybindings that limit input and eval things +bind .eval.t { _Eval .eval.t ; break } +bind .eval.t { + if [%W compare insert < limit] { + %W mark set insert end + } +} +bind .eval.t { + if {[%W tag nextrange sel 1.0 end] != ""} { + %W delete sel.first sel.last + } elseif [%W compare insert > limit] { + %W delete insert-1c + %W see insert + } + break +} +bindtags .eval.t {.eval.t Text all} + +proc _Eval { t } { + global prompt + set command [$t get limit end] + if [info complete $command] { + $t insert insert \n + $t mark set limit insert + set err [catch {uplevel #0 $command} result] + if {[string length $result] > 0} { + $t insert insert $result\n + } + $t insert insert $prompt + $t see insert + $t mark set limit insert + return + } else { + $t insert insert \n + } +} + +rename puts putsSystem +proc puts args { + if {[llength $args] > 3} { + error "invalid arguments" + } + set newline "\n" + if {[string match "-nonewline" [lindex $args 0]]} { + set newline "" + set args [lreplace $args 0 0] + } + if {[llength $args] == 1} { + set chan stdout + set string [lindex $args 0]$newline + } else { + set chan [lindex $args 0] + set string [lindex $args 1]$newline + } + if [regexp (stdout|stderr) $chan] { + .eval.t mark gravity limit right + .eval.t insert limit $string + .eval.t see limit + .eval.t mark gravity limit left + } else { + putsSystem -nonewline $chan $string + } +} diff --git a/faq b/faq new file mode 100755 index 0000000..2d00d24 --- /dev/null +++ b/faq @@ -0,0 +1,85 @@ + +october 22, 1995 + +=============== +Question: +On my dec alpha-osf1 and irix 5 can i save an image with compiled functions? + +Answer: + +These two systems use the o/fasldlsym.c module, which uses the system +call dl_open to do the loading of object files, from dynamic +libraries. While this provides fast loading of .o files into a +running image we do not know where those objects are located, or how +to save an image once they are loaded. So in short the answer is NO, +not at the moment.. These unixes no longer support the simple old 'ld +-A' option which let one build a .o and read it into memory where one +wanted. + +If you have a large system with a lot of preinitialization code, you COULD build +an image in the same manner the actual lisp itself is built. Ie essentially +add more files to the main link. si::save-system does work, it just wont work +after you dynamically load in .o files. + +I do this for the build of maxima (in version >= maxima-5.1). Look at +the files maxima-5.1/src/{makefile,sysinit.lsp}. Basically you need +to compile your files with the :system-p t flag, so that an init +function for each file based on the file name is produced. Then you +have to arrange for those init functions to be called at startup, then +you save as is done in building the lisp. + +============= +Question: +Are tcl 7.4 and tk 4.0 compatible with gcl 2.2. + +Answer: Not really. Some things will work but others wont. The demos +in the demos directory certainly wont all work, they are based on tk +3.6. They presumably could be rewritten based on their newer +counterparts. I do not know of what other changes are necessary... +In some sense the separation between gcl and tcl/tk is fairly complete +so in PRINCIPLE the changes required should only be those to user +code, caused by changes to the tk library. One would need to add +perhaps some new calls to def-widget, eg in tkl.lisp adding + +(def-widget listbox) + +if 'listbox' were a new widget type. + +(def-control send) +(def-control raise) + +if 'send' or 'control' were new functions.. + +Also one should update the gcl-tk info stuff from the using +gcl-2.2/elisp/man1-to-texi.el you can also use + +You can use gcl-2.2/gcl-tk/convert.el as a start on using emacs to +convert other (tcl/tk 4.0) code to lisp, to have their new demos in lisp +for testing purposes. + +============ +Question: Is there a port to mach 10 on the mac. + +Answer: +Not yet. This would be good.. Emacs is ported there. I dont know if it +saves itself however...i had heard it does not. I believe they are using the +macintosh native executable format.... + +=========== + + + + + + + + + + + + + + + + + diff --git a/gcl-tk/comm.c b/gcl-tk/comm.c new file mode 100755 index 0000000..0613390 --- /dev/null +++ b/gcl-tk/comm.c @@ -0,0 +1,283 @@ + +#include + + +#ifndef NO_DEFUN +#ifndef DEFUN +#define DEFUN(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,doc) ret fname +#endif +#endif + + +#ifndef HZ +#define HZ 60 +#endif + +#ifndef SET_TIMEVAL +#define SET_TIMEVAL(t,timeout) \ + t.tv_sec = timeout/HZ; t.tv_usec = (int) ((timeout%HZ)*(1000000.0)/HZ) +#endif + + +DEFUN_NEW("CHECK-FD-FOR-INPUT",object,fScheck_fd_for_input, + SI,2,2,NONE,OI,IO,OO,OO,(fixnum fd,fixnum timeout), + +"Check FD a file descriptor for data to read, waiting TIMEOUT clicks \ +for data to become available. Here there are \ +INTERNAL-TIME-UNITS-PER-SECOND in one second. Return is 1 if data \ +available on FD, 0 if timeout reached and -1 if failed.") +{ + fd_set inp; + int n; + struct timeval t; + + SET_TIMEVAL(t,timeout); + FD_ZERO(&inp); + FD_SET(fd, &inp); + n = select(fd + 1, &inp, NULL, NULL, &t); + if (n < 0) + return make_fixnum1(-1); + else if (FD_ISSET(fd, &inp)) + return make_fixnum1(1); + else + return make_fixnum1(0); +} +#ifdef STATIC_FUNCTION_POINTERS +object +fScheck_fd_for_input(fixnum fd,fixnum timeout) { + return FFN(fScheck_fd_for_input)(fd,timeout); +} +#endif + + + +#define MAX_PACKET 1000 +#define MUST_CONFIRM 2000 +#define OUR_SOCK_MAGIC 0206 + + +/* Each write and read will be of a packet including information about + how many we have read and written. + Sometimes we must read more messages, in order to check whether + the one being sent has info about bytes_received. + */ + + + + +struct connection_state * +setup_connection_state(fd) +{ struct connection_state * res; + res = (void *)malloc(sizeof(struct connection_state)); + bzero(res,sizeof(struct connection_state)); + res->fd = fd; + res->read_buffer_size = READ_BUFF_SIZE; + res->read_buffer = (void *)malloc(READ_BUFF_SIZE); + res->valid_data = res->read_buffer; + res->max_allowed_in_pipe = MAX_ALLOWED_IN_PIPE; + res->write_timeout = 30* 100; + return res; +} + +/* P is supposed to start with a hdr and run N bytes. */ +static void +scan_headers(sfd) + struct connection_state *sfd; +{ struct our_header *hdr; + char *p = sfd->valid_data + sfd->next_packet_offset; + int n = sfd->valid_data_size - sfd->next_packet_offset; + int length,received; + while (n >= HDR_SIZE) + { hdr = (void *)p; + if (hdr->magic != OUR_SOCK_MAGIC) + abort(); + GET_2BYTES(&hdr->received, received); + STORE_2BYTES(&hdr->received, 0); + sfd->bytes_sent_not_received -= received; + GET_2BYTES(&hdr->length, length); + p += length; + n -= length; + } +} + +static int +write1(struct connection_state *,const char *,int); + + +static void +send_confirmation(struct connection_state *sfd) +{ write1(sfd,0,0); +} + + +/* read from SFD to buffer P M bytes. Allow TIMEOUT + delay while waiting for data to arrive. + return number of bytes actually read. + The data arrives on the pipe packetized, but is unpacketized + by this function. It gets info about bytes that have + been received by the other process, and updates info in the state. + +*/ + +static int +read1(sfd,p,m,timeout) +struct connection_state* sfd; +char *p; +int timeout; +int m; +{ int nread=0; + int wanted = m; + int length; + struct our_header *hdr; + if (wanted == 0) + goto READ_SOME; + TRY_PACKET: + if (sfd->next_packet_offset > 0) + { int mm = (sfd->next_packet_offset >= wanted ? wanted : + sfd->next_packet_offset); + { bcopy(sfd->valid_data,p,mm); + p += mm; + sfd->valid_data+= mm; + sfd->valid_data_size -= mm; + sfd->next_packet_offset -= mm; + + } + wanted -= mm; + if (0 == wanted) return m; + + } + /* at beginning of a packet */ + + if (sfd->valid_data_size >= HDR_SIZE) + { hdr = (void *) sfd->valid_data; + GET_2BYTES(&hdr->length,length); + } + else goto READ_SOME; + if (length > sfd->valid_data_size) + goto READ_SOME; + /* we have a full packet available */ + {int mm = (wanted <= length - HDR_SIZE ? wanted : length - HDR_SIZE); + /* mm = amount to copy */ + { bcopy(sfd->valid_data+HDR_SIZE,p,mm); + p += mm; + sfd->valid_data+= (mm +HDR_SIZE); + sfd->valid_data_size -= (mm +HDR_SIZE); + sfd->next_packet_offset = length - (mm + HDR_SIZE); + wanted -= mm; + } + if (0 == wanted) return m; + goto TRY_PACKET; + } + + READ_SOME: + if (sfd->read_buffer_size - sfd->valid_data_size < MAX_PACKET) + { char *tmp ; + tmp = (void *) malloc(2* sfd->read_buffer_size); + if (tmp == 0) error("out of free space"); + bcopy(sfd->valid_data,tmp,sfd->valid_data_size); + free(sfd->read_buffer); + sfd->valid_data = sfd->read_buffer = tmp; + sfd->read_buffer_size *= 2; + } + if(sfd->read_buffer_size - (sfd->valid_data - sfd->read_buffer) < MAX_PACKET) + { bcopy(sfd->valid_data,sfd->read_buffer,sfd->valid_data_size); + sfd->valid_data=sfd->read_buffer;} + /* there is at least a packet size of space available */ + if ((fix(FFN(fScheck_fd_for_input)(sfd->fd,sfd->write_timeout))>0)); + again: + {char *start = sfd->valid_data+sfd->valid_data_size; + nread = SAFE_READ(sfd->fd,start, + sfd->read_buffer_size - (start - sfd->read_buffer)); + } + if (nread<0) + {if (errno == EAGAIN) goto again; + return -1;} + if (nread == 0) + { + return 0; + } + sfd->total_bytes_received += nread; + sfd->bytes_received_not_confirmed += nread; + sfd->valid_data_size += nread; + if(sfd->bytes_received_not_confirmed > MUST_CONFIRM) + send_confirmation(sfd); + scan_headers(sfd); + goto TRY_PACKET; + } + + +/* send BYTES chars from buffer P to CONNECTION. + They are packaged up with a hdr */ + +static void +write_timeout_error(char *); + +static void +connection_failure(char *); + +int +write1(sfd,p,bytes) + struct connection_state *sfd; + const char *p; + int bytes; +{ + int bs; + int to_send = bytes; + BEGIN: + bs = sfd->bytes_sent_not_received; + if (bs > sfd->max_allowed_in_pipe) + {read1(sfd,0,0,sfd->write_timeout); + if (bs > sfd->bytes_sent_not_received) + goto BEGIN; + write_timeout_error(""); + } + {struct our_header *hdr; + char buf[MAX_PACKET]; + int n_to_send = + (bytes > MAX_PACKET -HDR_SIZE ? MAX_PACKET : bytes+HDR_SIZE); + hdr = (void *) buf; + STORE_2BYTES(&hdr->length, n_to_send); + hdr->magic = OUR_SOCK_MAGIC; + STORE_2BYTES(&hdr->received, sfd->bytes_received_not_confirmed); + sfd->bytes_received_not_confirmed =0; + sfd->bytes_sent_not_received += n_to_send; + bcopy(p, buf+HDR_SIZE,n_to_send - HDR_SIZE); + + AGAIN: + { int n = write(sfd->fd,buf,n_to_send); + if (n == n_to_send); + else if (n < 0) + { if (errno == EAGAIN) + { goto AGAIN; + } + else connection_failure(""); + } + else abort(); + } + p += (n_to_send -HDR_SIZE); + bytes -= (n_to_send -HDR_SIZE); + if (bytes==0) return to_send; + goto BEGIN; + } + +} + +DEFUN_NEW("CLEAR-CONNECTION",object,fSclear_connection,SI,1,1,NONE,OI,OO,OO,OO,(fixnum fd), + "Read on FD until nothing left to read. Return number of bytes read") +{char buffer[0x1000]; + int n=0; + while (fix(FFN(fScheck_fd_for_input)(fd,0))) + { n+=read(fd,buffer,sizeof(buffer)); + } + + return make_fixnum1(n); +} +#ifdef STATIC_FUNCTION_POINTERS +object +fSclear_connection(fixnum fd) { + return FFN(fSclear_connection)(fd); +} +#endif + + + diff --git a/gcl-tk/convert.el b/gcl-tk/convert.el new file mode 100755 index 0000000..db8ccf3 --- /dev/null +++ b/gcl-tk/convert.el @@ -0,0 +1,246 @@ + +(defun try () + (interactive) + (goto-char (point-min)) + (if (looking-at "#") (insert ";;")) + (grab-variables) + (goto-char (point-min)) + + (do-replacements '(("\n\\([ \t]*\\)#" "\n\\1;;") + ("catch {destroy $w}" + "(if (winfo :exists w) (destroy w))") + ("\\[tk colormodel [$]w\\] == \"color\"" + "equal (tk :colormodel w) \"color\"") + )) + (goto-char (point-min)) + (replace-proc) + (goto-char (point-min)) + (replace-if) + (goto-char (point-min)) + + (separate-lines) + (goto-char (point-min)) + (replace-keywords) + (do-replacements '(("@[$]tk_library\\([^ \t\n]+\\)" + "\"@\" : *tk-library* : \"\\1\""))) + (goto-char (point-min)) + + (replace-$-in-string) + (goto-char (point-min)) + (do-replacements *replacements*) + (goto-char (point-min)) + (do-replacements '(( "[$]\\([a-z0-9A-Z]+\\)\\([)} \n]\\)" "\\1\\2"))) + (do-replacements + '(( " \\([0-9][0-9.]*[cmpi]\\)" " \"\\1\"") + ("\\(:create\\|:tag\\|:add\\|:scan\\:select\\:mark\\) \\([a-z]\\)" + "\\1 :\\2") +; (":add \\([a-z]\\)" ":add '\\1") + + )) + + (do-replacements '(("\\([ \t]\\)[.]\\([a-z0-9A-Z.]*\\)" "\\1'.\\2") + ("'[.] " "'|.| ") + ("((conc " "(funcall (conc ")) + t) + ) + +(defun grab-variables () + (let (tem) + (setq the-variables nil) + (while (re-search-forward "[$]\\([a-zA-Z0-9]+\\)" nil t) + (setq tem (buffer-substring (match-beginning 1) (match-end 1))) + (or (member tem the-variables) + (setq the-variables (cons tem the-variables)))))) + +(defun separate-lines () + (interactive) + (while (re-search-forward "\n[ \t]*[^;#() \n]" nil t) + (forward-char -1) + (cond ((or (looking-at "}") + (looking-at "for"))) + (t + ; (forward-sexp -1) + (insert "(") + (re-search-forward "[^\\]\n" nil t) + (forward-char -1)(insert ")") + )))) + +(defun replace-keywords () + (interactive) + (while (re-search-forward "\\([ \t]\\)-\\([a-zA-Z]\\)" nil t) + (replace-match "\\1:\\2") + (forward-sexp 1) + (skip-chars-forward " ") + (cond ((looking-at "[a-z]") + (insert "\"")(forward-sexp 1) + (insert "\"")))) + (goto-char (point-min)) + (while (re-search-forward "(\\([^ ]+\\)" nil t) + (let ((tem (buffer-substring (match-beginning 1)(match-end 0)))) +; (message (princ tem)) (sit-for 1) + (cond ((equal tem "defun")(forward-line 1)(beginning-of-line)) + ((member tem '("defun" "set"))) + (t + (skip-chars-forward " ") + (cond ((looking-at "[a-z]") + (insert ":")))))))) + + +(defvar the-variables nil) + + +(defun replace-$-in-string () + (interactive) + (let (tem beg (end (make-marker ))) + (while + (re-search-forward "\\([^\\]\\)[$]\\([a-zA-Z0-9]+\\)" nil t) + (forward-char -1) + (cond ((in-a-string) + (goto-char this-string-began ) + (setq beg (point)) + (insert "(tk-conc ") + (setq beg (point)) + (forward-sexp 1) + (set-marker end (point)) + (insert ")") + (goto-char beg) + (while + (re-search-forward "\\([^\\]\\)[$]\\([a-zA-Z0-9]+\\)" end t) + (replace-match "\\1\" \\2 \"")) + (goto-char (- beg 2)) + (while (re-search-forward " \"\"" end t) + (replace-match "")) + (set-marker end nil) + )) + + ))) + + + + + + + +(defun change-{-to-paren () + (interactive) + (let (end) + (cond ((search-forward "{" nil t) + (forward-char -1) + (let ((p (point))) + (forward-sexp 1) + (delete-region (- (point) 1)(point)) + (insert ")") + (setq end (point)) + (goto-char p) + (delete-region p (+ p 1)) + (insert "(")) + (goto-char end) + t)))) + + +(defun in-a-string () + (interactive) + (save-excursion + (save-match-data + (let ((p (point)) (c 0)) + (beginning-of-line) + (while (re-search-forward "[^\\]\"" p t) + (setq this-string-began (+ 1 (match-beginning 0))) + (setq c (+ c 1))) + (eql 1 (mod c 2)))))) + + +(defun replace-proc () + (interactive) + (while (re-search-forward "[ \t\n]\\(proc\\) " nil t) + (goto-char (match-beginning 1)) + (delete-region (match-beginning 1) + (match-end 0)) + (insert "(defun ") + (forward-sexp 1) + (skip-chars-forward " \n\t") + (cond + ((looking-at "{{") + (change-{-to-paren) + (forward-sexp -1) + (forward-char 1) + (insert "&optional ") + (change-{-to-paren)) + ((looking-at "{") + (change-{-to-paren))) + (change-{-to-paren) + (forward-sexp -1) + (delete-char 1))) + +(defun replace-if () + (interactive) + (while (re-search-forward "[ \t\n]\\(if\\) " nil t) + (goto-char (match-beginning 1)) + (delete-region (match-beginning 1) + (match-end 0)) + (insert "(if ") + (skip-chars-forward " \n\t") + (cond + ((looking-at "{") + (change-{-to-paren))) + (skip-chars-forward " \n\t") + (cond + ((looking-at "{") + (change-{-to-paren) + (save-excursion + (forward-sexp -1) + (forward-char 1) (insert "progn ")))) + (skip-chars-forward " \n\t") + (cond + ((looking-at "else") + (replace-match ";;else \n") + (skip-chars-forward " \n\t") + (cond + ((looking-at "{") + (change-{-to-paren) + (save-excursion + (forward-sexp -1) + (forward-char 1) (insert "progn ")))) + (insert ")") + )))) + +(setq *replacements* + '( + ("[$]\\([a-zA-Z0-9]+\\)[.][$]\\([a-zA-Z0-9]+\\)[.]\\([a-z0-9A-Z.]+\\)" + "(conc \\1 '|.| \\2 '.\\3)") + ("[$]\\([a-zA-Z0-9]+\\)[.][$]\\([a-zA-Z0-9)]+\\)" + "(conc \\1 '|.| \\2)") + ("[$]\\([a-zA-Z0-9]+\\)[.]\\([a-z0-9A-Z.)]+\\)" "(conc \\1 '.\\2\)") + ("\\(<[a-z0-9A-Z---]+>\\)" "\"\\1\"") + ("[[]expr \\([a-z$A-Z0-9]+\\)\\([ ]*[+---*][ ]*\\)\\([a-z$A-Z0-9]+\\)\\]" + "(\\2 \\1 \\3)") + ("[[]expr \\([a-z$A-Z0-9]+\\)\\]" "\\1") + ("($\\([a-z0-9A-Z]+\\)[.]\\([a-z0-9A-Z.]+\\)" "(funcall (conc \\1 '.\\2)") + ("($\\([a-z0-9A-Z]+\\)" "(funcall \\1") + ("[[]$\\([a-z0-9A-Z]+\\)\\([^]]+\\)\\]" "(funcall \\1\\2)") + ("[{]$\\([a-z0-9A-Z]+\\)\\([^}]+\\)\\}" "(funcall \\1\\2)") + ("[\\]\n" "\n") + ("\n\\([ \t]*\\)#" "\n\\1;") + ("(set " "(setq ") + ("tk_menuBar" "tk-menu-bar") + ("@\\([$a-zA-Z0-9]+\\),\\([$a-zA-Z0-9]+\\)" "(aT \\1 \\2)") + ("\\(:variable\\)[ ]+\"\\([a-zA-Z0-9]+\\)\"" "\\1 '\\2") + ("\\(:textvariable\\)[ ]+\"\\([a-zA-Z0-9]+\\)\"" "\\1 '\\2") + (":font -" ":font :") + (":create \\([a-z]+\\)" ":create \"\\1\"") + )) + + +(defun do-replacements (lis &optional not-in-string) + (let (x) + (while lis + (setq x (car lis)) (setq lis (cdr lis)) + (goto-char (point-min)) + (while (re-search-forward (nth 0 x) nil t) + (and not-in-string + (progn (forward-char -1) + (not (in-a-string)))) + (replace-match (nth 1 x) t))))) + + + diff --git a/gcl-tk/decode.tcl b/gcl-tk/decode.tcl new file mode 100644 index 0000000..66b696d --- /dev/null +++ b/gcl-tk/decode.tcl @@ -0,0 +1,321 @@ +# this file contains the protocol for receiving connections from GCL and +# other lisps [or other languages] +# The communication is via a socket, and the data is packaged up into +# packets, which we track letting the other side know how much is actually +# received. This protocol is to prevent problems with flooding a +# communications channel. The sender knows how many bytes are in the pipe. +# the outer wrapper is +# { char magic; +# unsigned short length; /* including the header */ +# unsigned short received; /* incremental number of bytes received at the +# other end of the channel */ +# + +# (MAGIC1 MAGIC2 TYPE FLAG BODY-LENGTH NIL NIL MSG-INDEX NIL NIL) + + + +set GclMTypes { m_not_used + m_create_command + m_reply + m_call + m_tcl_command + m_tcl_command_wait_response + m_tcl_clear_connection + m_tcl_link_text_variable + m_set_lisp_loc + m_tcl_set_text_variable + m_tcl_unlink_text_variable} + + +proc GclDecodeMsg { msg } { + +# char magic1; \06 +# char magic2; 'A' +# char type; m_* +# unsigned char flag; +# unsigned char size[3]; /* of body */ +# unsigned char msg_id[3]; +# char body[1]; + + global GclMTypes + if { [string match "\06A*" $msg] } { + binary scan [string range $msg 2 end] ccsc type flag bodyLo bodyHi + set bodyLength [expr ($bodyLo & 0xffff)+ ($bodyHi >> 16)] + set index [msgIndex $msg] + set ans "xMsg-id=$index, type= [lindex $GclMTypes $type], length=$bodyLength, body=[string range $msg 10 [expr 10 + $bodyLength-1]]" + } else {set ans "invalidmsg:<$msg>" } +} + +#proc GclmsgIndex { msg } { +# binary scan [string range $msg 7 9] sc indLo indHi +# set index [expr ($indLo & 0xffff)+ ($indHi >> 16)] +# return $index +#} + +proc Gclget3Bytes { s } { + binary scan $s "sc" lo hi + return [expr { ($lo & 0xffff) + ($hi << 16) }] +} + +proc GclMake3Bytes { n } { + return [ string range [binary format i $n] 0 2] +} + +proc debugSend { msg } { + puts stderr $msg + flush stderr +} +proc GclAnswerSocket { host port pid } { + global GclSock GclPdata GclPacket + set sock [socket $host $port] + setupPacket $sock + fconfigure $sock -blocking 0 -translation {binary binary} + # debugSend fconfigure:$sock:[fconfigure $sock] + set GclSock $sock + catch { unset GclPdata(data,$sock) } + fileevent $sock readable "GclReadAndAct1 $sock" + set GclPdata(pid,$sock) $pid + return $sock +} + +proc setupPacket { sock } { + global GclPacket + # data including 5 byte headers + set GclPacket(indata,$sock) "" + set GclPacket(received,$sock) 0 + set GclPacket(sent_not_received,$sock) 0 + # the data after stripping headers + set GclPacket(outdata,$sock) "" +} + + +proc GclRead1 { sock } { + global GclPacket + upvar #0 GclPacket(indata,$sock) indata + set recd 0 + append indata [read $sock] + set ll 0 + while { [set l [string length $indata]] >= 5 } { + binary scan $indata "css" magic length received + # debugSend "magic=$magic,length=$length,received:=$received,indata=$indata" + # -122 = signedchar(0206) + if { $magic != -122 } { + error "bad magic" + } + # debugSend "test: $l >= $length + 5" + if { $l >= $length } { + append GclPacket(outdata,$sock) [string range $indata 5 [expr $length -1]] + set indata [string range $indata $length end] + incr recd $received + incr ll $length + } else { break + } + + } + incr GclPacket(received,$sock) $ll + if { $recd } { + incr GclPacket(sent_not_received,$sock) -$recd + } + if { $GclPacket(received,$sock) > 1500 } { + sendReceiveConfirmation $sock + } + set res $GclPacket(outdata,$sock) + set GclPacket(outdata,$sock) "" + # debugSend "GclRead1--><$res>" + return $res +} + + +proc sendReceiveConfirmation { sock } { + GclWrite1 $sock "" +} + +proc GclWrite1 { sock data } { + global GclPacket + # debugSend "entering GclWrite1" + set length [expr 5 + [string length $data]] + set hdr \206[binary format ss $length $GclPacket(received,$sock)] + # debugSend "hdr=$hdr, [array get GclPacket *]" + set GclPacket(received,$sock) 0 + incr GclPacket(sent_not_received,$sock) $length + #debugSend "GclWrite1:<$hdr$data>" + puts -nonewline $sock $hdr$data + flush $sock +} + +proc GclReadAndAct1 { sock } { + global GclPdata GclMTypes + upvar #0 GclPdata(data,$sock) msg + set read [GclRead1 $sock] + + if { [string length $read] == 0 } { + if { [eof $sock] } { + # debugSend "exitting since $sock is closed" + exit 1 + } + return "" + + } + + append msg $read + while { [set l [string length $msg]] >= 10 } { + #debugSend "msg=<$msg>" + #debugSend [GclDecodeMsg $msg] + binary scan $msg sccsc magic type flag bodyLo bodyHi + if { $magic != 16646 } { + error "bad magic:[string range $msg 0 1]" + } + set bodyLength [expr ($bodyLo & 0xffff)+ ($bodyHi >> 16)] + if { $l >= 10+$bodyLength } { + set toeval [list [lindex $GclMTypes $type] $msg [string range $msg 10 [expr 10 + $bodyLength-1]]] + set msg [string range $msg [expr 10 + $bodyLength] end] + #debugSend toeval=$toeval + if { [catch { eval $toeval } err] } { + puts stderr "error in [lindex $toeval 0] [string range [lindex $toeval 1 ] 0 13]... [lindex $toeval 2]: $err" + flush stderr + } + } + } +} + + + + +proc GclGetCString {s } { + return [string range $s 0 [expr [string first \0 $s] -1]] +} + +set GclSockMsgId 0 + +proc sock_write_str {typeflag text } { + global GclSock GclSockMsgId + set msg "\06A$typeflag[GclMake3Bytes [string length $text]][GclMake3Bytes [incr GclSockMsgId]]$text" + #debugSend sending:[GclDecodeMsg $msg] + GclWrite1 $GclSock $msg + +} + +proc GclGenericCommand { n arg } { + global GclSock + # 2 == [lsearch $GclMTypes m_reply] + sock_write_str "\3\0" "[GclMake3Bytes $n]$arg" + signalParent $GclSock +} + +proc GclGenericCommandStringify { n arglist lis } { + global GclSock + set i 0 + set ans "[GclMake3Bytes $n](" + foreach v $lis { + if { "s" == "[string range $arglist $i $i]" } { + append ans " \"" $v "\"" + } else { append ans " " $v + } + } + append ans ")" + sock_write_str "\3\0" $ans + signalParent $GclSock +} + + +proc m_create_command { msg body } { + #debugSend "in m_create_command" + set n [Gclget3Bytes $body] + set arglist [GclGetCString [string range $body 3 end]] +# "debugSend callback_$n:args=\$args ; GclGenericCommandStringify $n $arglist \$args" \ + + if { "$arglist" == "" } { + proc callback_$n { { arg1 "" } } "GclGenericCommand $n \$arg1" + } else { + proc callback_$n { args } "GclGenericCommandStringify $n $arglist \$args" + } + +} + + +proc m_tcl_command { msg body } { + + set body [string trimright $body "\0"] + # set body [GclGetCString $body] + # set fail [catch { eval $body } res] + # set fail [catch { eval $body } res] + eval $body + # set com "update idletasks" + #after cancel $com + #after 5 $com + # update idletasks + # puts stderr "doing $body" ; flush stderr + # debugSend "in eval of <$body>: fail=$fail,res=<$res>" +} + +proc m_tcl_command_wait_response { msg body } { + global GclSock + set body [string trimright $body "\0"] +# set body [GclGetCString $body] + set fail [catch { eval $body } res] + # 2 == [lsearch $GclMTypes m_reply] + sock_write_str "\2\0" "$fail[string range $msg 7 9]$res" + # debugSend " signalParent $GclSock" + # no need to signal other side is waiting. + # signalParent $GclSock +} + +proc m_tcl_clear_connection { msg body } { + global GclSock + flush $GclSock + set GclPdata($GclSock,data) "" +} + +proc m_tcl_set_text_variable { msg body } { + set n [string first \0 $body] + set [string range $body 0 [expr $n -1]] [string range $body [expr $n+1] end] +} + +proc m_tcl_link_text_variable { msg body } { + global GclPdata + set i [Gclget3Bytes $body] + set name [string range $body 3 end] + uplevel #0 trace variable wu $name "GclTellLispVarChanged $i" +} + +proc signalParent1 {sock } { + global GclPdata GclPacket + if { $GclPacket(sent_not_received,$sock) } { + exec kill -s SIGUSR1 $GclPdata(pid,$sock) & + } +} + + +proc signalParent {sock } { + global delay + set com "signalParent1 $sock" + after cancel $com + after 5 $com +} + + +proc GclTellLispVarChanged { i name1 name2 op } { + global GclPdata + upvar #0 $name1 val + # 8 == [lsearch $GclMTypes m_set_lisp_loc] + sock_write_str \8\0 "[GclMake3Bytes $i]$val" + signalParent $GclSock + +} + +proc m_tcl_unlink_text_variable { msg body } { + set i [Gclget3Bytes $body] + set name [string range $body 3 end] + trace vdelete $name wu "GclTellLispVarChanged $i" +} + + + + + + + + + + diff --git a/gcl-tk/demos-4.1/items.lisp b/gcl-tk/demos-4.1/items.lisp new file mode 100755 index 0000000..a9d8b6e --- /dev/null +++ b/gcl-tk/demos-4.1/items.lisp @@ -0,0 +1,305 @@ +;;# items.lisp -- This demo has been converted for tk4.1 from the +;; corresponding tcl demo program. +;; +;; This demonstration script creates a canvas that displays the +;; canvas item types. +;; +;; @(#) :items.tcl 1.5 95/10/04 15:00:39 + +(defun positionwindow (w) + (wm :geometry w "+60+25") +) +(setq w '.items) +(if (winfo :exists w) (destroy w)) +(toplevel w) +(wm :title w "Canvas Item Demonstration") +(wm :iconname w "Items") +(positionWindow w) +(setq c (conc w '.frame.c)) +(setq font :Adobe-times-medium-r-normal--*-180* ) +(label (conc w '.msg) :font font :wraplength "5i" :justify "left" :text "This window contains a canvas widget with examples of the various kinds of items supported by canvases. The following operations are supported:\n Button-1 drag:\tmoves item under pointer.\n Button-2 drag:\trepositions view.\n Button-3 drag:\tstrokes out area.\n Ctrl+f:\t\tprints items under area.") +(pack (conc w '.msg) :side "top") + +(frame (conc w '.buttons)) +(pack (conc w '.buttons) :side "bottom" :expand "y" :fill "x" :pady "2m") +(button (conc w '.buttons.dismiss) :text "Dismiss" :command (tk-conc "destroy " w)) +(button (conc w '.buttons.code) :text "See Code" :command (tk-conc "showCode " w)) +(pack (conc w '.buttons.dismiss) (conc w '.buttons.code) :side "left" :expand 1) + +(frame (conc w '.frame)) +(pack (conc w '.frame) :side "top" :fill "both" :expand "yes") + +(canvas c :scrollregion "0c 0c 30c 24c" :width "15c" :height "10c" + :relief "sunken" :borderwidth 2 + :xscrollcommand (tk-conc w ".frame.hscroll set") + :yscrollcommand (tk-conc w ".frame.vscroll set")) +(scrollbar (conc w '.frame.vscroll) :command (tk-conc c " yview")) +(scrollbar (conc w '.frame.hscroll) :orient "horiz" :command (tk-conc c " xview")) +(pack (conc w '.frame.hscroll) :side "bottom" :fill "x") +(pack (conc w '.frame.vscroll) :side "right" :fill "y") +(pack c :in (conc w '.frame) :expand "yes" :fill "both") + +;; Display a 3x3 rectangular grid. + +(funcall c :create "rect" "0c" "0c" "30c" "24c" :width 2) +(funcall c :create "line" "0c" "8c" "30c" "8c" :width 2) +(funcall c :create "line" "0c" "16c" "30c" "16c" :width 2) +(funcall c :create "line" "10c" "0c" "10c" "24c" :width 2) +(funcall c :create "line" "20c" "0c" "20c" "24c" :width 2) + +(setq font1 :Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*) +(setq font2 :Adobe-Helvetica-Bold-R-Normal--*-240-*-*-*-*-*-*) +(if (> (winfo :depth c :return 'number) 1) (progn + (setq blue "DeepSkyBlue3") + (setq red "red") + (setq bisque "bisque3") + (setq green "SeaGreen3") +) ;;else + (progn + (setq blue "black") + (setq red "black") + (setq bisque "black") + (setq green "black") +)) + +;; Set up demos within each of the areas of the grid. + +(funcall c :create "text" "5c" '.2c :text "Lines" :anchor "n") +(funcall c :create "line" "1c" "1c" "3c" "1c" "1c" "4c" "3c" "4c" :width "2m" :fill blue + :cap "butt" :join "miter" :tags "item") +(funcall c :create "line" "4.67c" "1c" "4.67c" "4c" :arrow "last" :tags "item") +(funcall c :create "line" "6.33c" "1c" "6.33c" "4c" :arrow "both" :tags "item") +(funcall c :create "line" "5c" "6c" "9c" "6c" "9c" "1c" "8c" "1c" "8c" "4.8c" "8.8c" "4.8c" "8.8c" "1.2c" + "8.2c" "1.2c" "8.2c" "4.6c" "8.6c" "4.6c" "8.6c" "1.4c" "8.4c" "1.4c" "8.4c" "4.4c" + :width 3 :fill red :tags "item") +(funcall c :create "line" "1c" "5c" "7c" "5c" "7c" "7c" "9c" "7c" :width '.5c + :stipple "@" : *tk-library* : "/demos/images/gray25.bmp" + :arrow "both" :arrowshape "15 15 7" :tags "item") +(funcall c :create "line" "1c" "7c" "1.75c" "5.8c" "2.5c" "7c" "3.25c" "5.8c" "4c" "7c" :width '.5c + :cap "round" :join "round" :tags "item") + +(funcall c :create "text" "15c" '.2c :text "Curves (smoothed :lines)" :anchor "n") +(funcall c :create "line" "11c" "4c" "11.5c" "1c" "13.5c" "1c" "14c" "4c" :smooth "on" + :fill blue :tags "item") +(funcall c :create "line" "15.5c" "1c" "19.5c" "1.5c" "15.5c" "4.5c" "19.5c" "4c" :smooth "on" + :arrow "both" :width 3 :tags "item") +(funcall c :create "line" "12c" "6c" "13.5c" "4.5c" "16.5c" "7.5c" "18c" "6c" + "16.5c" "4.5c" "13.5c" "7.5c" "12c" "6c" :smooth "on" :width "3m" :cap "round" + :stipple "@" : *tk-library* : "/demos/images/gray25.bmp" :fill red :tags "item") + +(funcall c :create "text" "25c" '.2c :text "Polygons" :anchor "n") +(funcall c :create "polygon" "21c" "1.0c" "22.5c" "1.75c" "24c" "1.0c" "23.25c" "2.5c" + "24c" "4.0c" "22.5c" "3.25c" "21c" "4.0c" "21.75c" "2.5c" :fill green + :outline "black" :width 4 :tags "item") +(funcall c :create "polygon" "25c" "4c" "25c" "4c" "25c" "1c" "26c" "1c" "27c" "4c" "28c" "1c" + "29c" "1c" "29c" "4c" "29c" "4c" :fill red :smooth "on" :tags "item") +(funcall c :create "polygon" "22c" "4.5c" "25c" "4.5c" "25c" "6.75c" "28c" "6.75c" + "28c" "5.25c" "24c" "5.25c" "24c" "6.0c" "26c" "6c" "26c" "7.5c" "22c" "7.5c" + :stipple "@" : *tk-library* : "/demos/images/gray25.bmp" + :outline "black" :tags "item") + +(funcall c :create "text" "5c" "8.2c" :text "Rectangles" :anchor "n") +(funcall c :create "rectangle" "1c" "9.5c" "4c" "12.5c" :outline red :width "3m" :tags "item") +(funcall c :create "rectangle" "0.5c" "13.5c" "4.5c" "15.5c" :fill green :tags "item") +(funcall c :create "rectangle" "6c" "10c" "9c" "15c" :outline "" + :stipple "@" : *tk-library* : "/demos/images/gray25.bmp" :fill blue :tags "item") + +(funcall c :create "text" "15c" "8.2c" :text "Ovals" :anchor "n") +(funcall c :create "oval" "11c" "9.5c" "14c" "12.5c" :outline red :width "3m" :tags "item") +(funcall c :create "oval" "10.5c" "13.5c" "14.5c" "15.5c" :fill green :tags "item") +(funcall c :create "oval" "16c" "10c" "19c" "15c" :outline "" + :stipple "@" : *tk-library* : "/demos/images/gray25.bmp" :fill blue :tags "item") + +(funcall c :create "text" "25c" "8.2c" :text "Text" :anchor "n") +(funcall c :create "rectangle" "22.4c" "8.9c" "22.6c" "9.1c") +(funcall c :create "text" "22.5c" "9c" :anchor "n" :font font1 :width "4c" + :text "A short string of text, word-wrapped, justified left, and anchored north (at :the top). The rectangles show the anchor points for each piece of text." :tags "item") +(funcall c :create "rectangle" "25.4c" "10.9c" "25.6c" "11.1c") +(funcall c :create "text" "25.5c" "11c" :anchor "w" :font font1 :fill blue + :text "Several lines,\n each centered\nindividually,\nand all anchored\nat the left edge." + :justify "center" :tags "item") +(funcall c :create "rectangle" "24.9c" "13.9c" "25.1c" "14.1c") +(funcall c :create "text" "25c" "14c" :font font2 :anchor "c" :fill red :stipple "gray50" + :text "Stippled characters" :tags "item") + +(funcall c :create "text" "5c" "16.2c" :text "Arcs" :anchor "n") +(funcall c :create "arc" "0.5c" "17c" "7c" "20c" :fill green :outline "black" + :start 45 :extent 270 :style "pieslice" :tags "item") +(funcall c :create "arc" "6.5c" "17c" "9.5c" "20c" :width "4m" :style "arc" + :outline blue :start -135 :extent 270 + :outlinestipple "@" : *tk-library* : "/demos/images/gray25.bmp" :tags "item") +(funcall c :create "arc" "0.5c" "20c" "9.5c" "24c" :width "4m" :style "pieslice" + :fill "" :outline red :start 225 :extent -90 :tags "item") +(funcall c :create "arc" "5.5c" "20.5c" "9.5c" "23.5c" :width "4m" :style "chord" + :fill blue :outline "" :start 45 :extent 270 :tags "item") + +(funcall c :create "text" "15c" "16.2c" :text "Bitmaps" :anchor "n") +(funcall c :create "bitmap" "13c" "20c" :bitmap "@" : *tk-library* : "/demos/images/face.bmp" :tags "item") +(funcall c :create "bitmap" "17c" "18.5c" + :bitmap "@" : *tk-library* : "/demos/images/noletter.bmp" :tags "item") +(funcall c :create "bitmap" "17c" "21.5c" + :bitmap "@" : *tk-library* : "/demos/images/letters.bmp" :tags "item") + +(funcall c :create "text" "25c" "16.2c" :text "Windows" :anchor "n") +(button (conc c '.button) :text "Press Me" :command `(butpress ',c "red")) +(funcall c :create "window" "21c" "18c" :window (conc c '.button) :anchor "nw" :tags "item") +(entry (conc c '.entry) :width 20 :relief "sunken") +(funcall (conc c '.entry) :insert "end" "Edit this text") +(funcall c :create "window" "21c" "21c" :window (conc c '.entry) :anchor "nw" :tags "item") +(scale (conc c '.scale) :from 0 :to 100 :length "6c" :sliderlength '.4c + :width '.5c :tickinterval 0) +(funcall c :create "window" "28.5c" "17.5c" :window (conc c '.scale) :anchor "n" :tags "item") +(funcall c :create "text" "21c" "17.9c" :text "Button": :anchor "sw") +(funcall c :create "text" "21c" "20.9c" :text "Entry": :anchor "sw") +(funcall c :create "text" "28.5c" "17.4c" :text "Scale": :anchor "s") + +;; Set up event bindings for canvas: + +(funcall c :bind "item" "" `(itemEnter ',c)) +(funcall c :bind "item" "" `(itemLeave ',c)) +(bind c "<2>" (tk-conc c " scan mark %x %y")) +(bind c "" (tk-conc c " scan dragto %x %y")) +(bind c "<3>" `(itemMark ',c |%x| |%y|)) +(bind c "" `(itemStroke ',c |%x| |%y|)) +(bind c "" `(itemsUnderArea ',c)) +(bind c "<1>" `(itemStartDrag ',c |%x| |%y|)) +(bind c "" `(itemDrag ',c |%x| |%y|)) +(focus c) + +;; Utility procedures for highlighting the item under the pointer: + + +(defvar *restorecmd* nil) + +(defun itemEnter (c &aux type bg) + ; (global :*restorecmd*) + (let ((current (funcall c :find "withtag" "current" :return 'string))) + (if (equal current "") (return-from itementer nil)) + (itemleave nil) + + (setq type (funcall c :type current :return 'string)) + (if (equal type "window") + (progn + (itemLeave nil) + (return-from itemEnter nil))) + (if (equal type "bitmap") + (progn + (setq bg (nth 4 + (funcall c :itemconf current :background + :return 'list-strings))) + (push `(,c :itemconfig ',current :background ',bg) *restorecmd*) + (funcall c :itemconfig current :background "SteelBlue2") + (return-from itemEnter nil))) + (setq fill (nth 4 (funcall c :itemconfig current :fill + :return 'list-strings))) + (if (or (member type '("rectangle" "oval" "arg") :test 'equal) + (equal fill "")) + (progn + (setq outline (nth 4 (funcall c :itemconfig current :outline :return 'list-strings))) + (push `(,c :itemconfig ',current :outline ',outline) *restorecmd*) + (funcall c :itemconfig current :outline "SteelBlue2")) + (progn + (push `(,c :itemconfig ',current :fill ,fill) *restorecmd*) + (funcall c :itemconfig current :fill "SteelBlue2"))) + ) + ) + +(defun itemLeave (c) +; (global :*restorecmd*) + (let ((tem *restorecmd*)) + (setq *restorecmd* nil) + (dolist (v tem) + (eval v)))) + + +;; Utility procedures for stroking out a rectangle and printing what's +;; underneath the rectangle's area. + +(defun itemMark (c x y) +; (global :areaX1 areaY1) + (setq areaX1 (funcall c :canvasx x :return 'string)) + (setq areaY1 (funcall c :canvasy y :return 'string)) + (funcall c :delete "area") +) + +(defun itemStroke (c x y ) + (declare (special areaX1 areaY1 areaX2 areaY2)) + (or *recursive* + (let ((*recursive* t)) + (setq x (funcall c :canvasx x :return 'string)) + (setq y (funcall c :canvasy y :return 'string)) + (progn + (setq areaX2 x) + (setq areaY2 y) + ;; this next return 'stringis simply for TIMING!!! + ;; to make it wait for the result before going into subsequent!! + (funcall c :delete "area" :return 'string) + (funcall c :addtag "area" "withtag" + (funcall c :create "rect" areaX1 areaY1 x y + :outline "black" :return 'string)) + + )))) + +(defun itemsUnderArea (c) +; (global :areaX1 areaY1 areaX2 areaY2) + (setq area (funcall c :find "withtag" "area" :return 'string)) + (setq me c) + (setq items "") + (dolist (i + (funcall c :find "enclosed" areaX1 areaY1 areaX2 areaY2 + :return 'list-strings)) + (if (search "item" (funcall c :gettags i :return 'string)) + (setq items (tk-conc items " " i)))) + (print (tk-conc "Items enclosed by area: " items)) + (setq items "") + (dolist (i + (funcall c :find "overlapping" areaX1 areaY1 areaX2 areaY2 + :return 'list-strings)) + (if (search "item" (funcall c :gettags i :return 'string)) + (setq items (tk-conc items " " i)))) + (print (tk-conc "Items overlapping area: " items)) + (terpri) + (force-output) +) + +(setq areaX1 0) +(setq areaY1 0) +(setq areaX2 0) +(setq areaY2 0) + +;; Utility procedures to support dragging of items. + +(defun itemStartDrag (c x y) +; (global :lastX lastY) + (setq lastX (funcall c :canvasx x :return 'number)) + (setq lastY (funcall c :canvasy y :return 'number)) +) + +(defun itemDrag (c x y) +; (global :lastX lastY) + (setq x (funcall c :canvasx x :return 'number)) + (setq y (funcall c :canvasy y :return 'number)) + (funcall c :move "current" (- x lastX) (- y lastY)) + (setq lastX x) + (setq lastY y) +) + +(defvar *recursive* nil) +(defun itemDrag (c x y) +; (global :lastX lastY) + (cond (*recursive* ) + (t (let ((*recursive* t)) + (setq x (funcall c :canvasx x :return 'number)) + (setq y (funcall c :canvasy y :return 'number)) + (funcall c :move "current" (- x lastX) (- y lastY)) + (setq lastX x) + (setq lastY y))))) + +;; Procedure that's invoked when the button embedded in the canvas +;; is invoked. + +(defun butPress (w color) + (setq i (funcall w :create "text" "25c" "18.1c" :text "Ouch!!" + :fill color :anchor "n" :return 'string)) + (after 500 (tk-conc w " delete " i)) +) diff --git a/gcl-tk/demos-4.2/widget b/gcl-tk/demos-4.2/widget new file mode 100755 index 0000000..2ee3341 --- /dev/null +++ b/gcl-tk/demos-4.2/widget @@ -0,0 +1,376 @@ +#!/bin/sh +# the next line restarts using wish \ +exec wish4.2 "$0" "$@" + +# widget -- +# This script demonstrates the various widgets provided by Tk, +# along with many of the features of the Tk toolkit. This file +# only contains code to generate the main window for the +# application, which invokes individual demonstrations. The +# code for the actual demonstrations is contained in separate +# ".tcl" files is this directory, which are sourced by this script +# as needed. +# +# SCCS: @(#) widget 1.21 96/10/04 17:09:34 + +eval destroy [winfo child .] +wm title . "Widget Demonstration" + +#---------------------------------------------------------------- +# The code below create the main window, consisting of a menu bar +# and a text widget that explains how to use the program, plus lists +# all of the demos as hypertext items. +#---------------------------------------------------------------- + +set font -*-Helvetica-Medium-R-Normal--*-140-*-*-*-*-*-* +frame .menuBar +pack .menuBar -side top -fill x +menubutton .menuBar.file -text File -menu .menuBar.file.m -underline 0 +menu .menuBar.file.m +.menuBar.file.m add command -label "About ... " -command "aboutBox" \ + -underline 0 -accelerator "" +.menuBar.file.m add sep +.menuBar.file.m add command -label "Quit" -command "exit" -underline 0 +pack .menuBar.file -side left +bind . aboutBox + +frame .textFrame +scrollbar .s -orient vertical -command {.t yview} -highlightthickness 0 \ + -takefocus 1 +pack .s -in .textFrame -side right -fill y -padx 1 +text .t -yscrollcommand {.s set} -wrap word -width 60 -height 30 -font $font \ + -setgrid 1 -highlightthickness 0 -padx 4 -pady 2 -takefocus 0 +pack .t -in .textFrame -expand y -fill both -padx 1 +pack .textFrame -expand yes -fill both -padx 1 -pady 2 + +frame .statusBar +label .statusBar.lab -text " " -relief sunken -bd 1 \ + -font -*-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -anchor w +label .statusBar.foo -width 8 -relief sunken -bd 1 \ + -font -*-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -anchor w +pack .statusBar.lab -side left -padx 2 -expand yes -fill both +pack .statusBar.foo -side left -padx 2 +pack .statusBar -side top -fill x -pady 2 + +# Create a bunch of tags to use in the text widget, such as those for +# section titles and demo descriptions. Also define the bindings for +# tags. + +.t tag configure title -font -*-Helvetica-Bold-R-Normal--*-180-*-*-*-*-*-* + +# We put some "space" characters to the left and right of each demo description +# so that the descriptions are highlighted only when the mouse cursor +# is right over them (but not when the cursor is to their left or right) +# +.t tag configure demospace -lmargin1 1c -lmargin2 1c + + +if {[winfo depth .] == 1} { + .t tag configure demo -lmargin1 1c -lmargin2 1c \ + -underline 1 + .t tag configure visited -lmargin1 1c -lmargin2 1c \ + -underline 1 + .t tag configure hot -background black -foreground white +} else { + .t tag configure demo -lmargin1 1c -lmargin2 1c \ + -foreground blue -underline 1 + .t tag configure visited -lmargin1 1c -lmargin2 1c \ + -foreground #303080 -underline 1 + .t tag configure hot -foreground red -underline 1 +} +.t tag bind demo { + invoke [.t index {@%x,%y}] +} +set lastLine "" +.t tag bind demo { + set lastLine [.t index {@%x,%y linestart}] + .t tag add hot "$lastLine +1 chars" "$lastLine lineend -1 chars" + .t config -cursor hand2 + showStatus [.t index {@%x,%y}] +} +.t tag bind demo { + .t tag remove hot 1.0 end + .t config -cursor xterm + .statusBar.lab config -text "" +} +.t tag bind demo { + set newLine [.t index {@%x,%y linestart}] + if {[string compare $newLine $lastLine] != 0} { + .t tag remove hot 1.0 end + set lastLine $newLine + + set tags [.t tag names {@%x,%y}] + set i [lsearch -glob $tags demo-*] + if {$i >= 0} { + .t tag add hot "$lastLine +1 chars" "$lastLine lineend -1 chars" + } + } + showStatus [.t index {@%x,%y}] +} + +# Create the text for the text widget. + +.t insert end "Tk Widget Demonstrations\n" title +.t insert end { +This application provides a front end for several short scripts that demonstrate what you can do with Tk widgets. Each of the numbered lines below describes a demonstration; you can click on it to invoke the demonstration. Once the demonstration window appears, you can click the "See Code" button to see the Tcl/Tk code that created the demonstration. If you wish, you can edit the code and click the "Rerun Demo" button in the code window to reinvoke the demonstration with the modified code. + +} +.t insert end "Labels, buttons, checkbuttons, and radiobuttons" title +.t insert end " \n " {demospace} +.t insert end "1. Labels (text and bitmaps)." {demo demo-label} +.t insert end " \n " {demospace} +.t insert end "2. Buttons." {demo demo-button} +.t insert end " \n " {demospace} +.t insert end "3. Checkbuttons (select any of a group)." {demo demo-check} +.t insert end " \n " {demospace} +.t insert end "4. Radiobuttons (select one of a group)." {demo demo-radio} +.t insert end " \n " {demospace} +.t insert end "5. A 15-puzzle game made out of buttons." {demo demo-puzzle} +.t insert end " \n " {demospace} +.t insert end "6. Iconic buttons that use bitmaps." {demo demo-icon} +.t insert end " \n " {demospace} +.t insert end "7. Two labels displaying images." {demo demo-image1} +.t insert end " \n " {demospace} +.t insert end "8. A simple user interface for viewing images." \ + {demo demo-image2} +.t insert end " \n " {demospace} + +.t insert end \n {} "Listboxes" title +.t insert end " \n " {demospace} +.t insert end "1. 50 states." {demo demo-states} +.t insert end " \n " {demospace} +.t insert end "2. Colors: change the color scheme for the application." \ + {demo demo-colors} +.t insert end " \n " {demospace} +.t insert end "3. A collection of famous sayings." {demo demo-sayings} +.t insert end " \n " {demospace} + +.t insert end \n {} "Entries" title +.t insert end " \n " {demospace} +.t insert end "1. Without scrollbars." {demo demo-entry1} +.t insert end " \n " {demospace} +.t insert end "2. With scrollbars." {demo demo-entry2} +.t insert end " \n " {demospace} +.t insert end "3. Simple Rolodex-like form." {demo demo-form} +.t insert end " \n " {demospace} + +.t insert end \n {} "Text" title +.t insert end " \n " {demospace} +.t insert end "1. Basic editable text." {demo demo-text} +.t insert end " \n " {demospace} +.t insert end "2. Text display styles." {demo demo-style} +.t insert end " \n " {demospace} +.t insert end "3. Hypertext (tag bindings)." {demo demo-bind} +.t insert end " \n " {demospace} +.t insert end "4. A text widget with embedded windows." {demo demo-twind} +.t insert end " \n " {demospace} +.t insert end "5. A search tool built with a text widget." {demo demo-search} +.t insert end " \n " {demospace} + +.t insert end \n {} "Canvases" title +.t insert end " \n " {demospace} +.t insert end "1. The canvas item types." {demo demo-items} +.t insert end " \n " {demospace} +.t insert end "2. A simple 2-D plot." {demo demo-plot} +.t insert end " \n " {demospace} +.t insert end "3. Text items in canvases." {demo demo-ctext} +.t insert end " \n " {demospace} +.t insert end "4. An editor for arrowheads on canvas lines." {demo demo-arrow} +.t insert end " \n " {demospace} +.t insert end "5. A ruler with adjustable tab stops." {demo demo-ruler} +.t insert end " \n " {demospace} +.t insert end "6. A building floor plan." {demo demo-floor} +.t insert end " \n " {demospace} +.t insert end "7. A simple scrollable canvas." {demo demo-cscroll} +.t insert end " \n " {demospace} + +.t insert end \n {} "Scales" title +.t insert end " \n " {demospace} +.t insert end "1. Vertical scale." {demo demo-vscale} +.t insert end " \n " {demospace} +.t insert end "2. Horizontal scale." {demo demo-hscale} +.t insert end " \n " {demospace} + +.t insert end \n {} "Menus" title +.t insert end " \n " {demospace} +.t insert end "1. A window containing several menus and cascades." \ + {demo demo-menu} +.t insert end " \n " {demospace} + +.t insert end \n {} "Common Dialogs" title +.t insert end " \n " {demospace} +.t insert end "1. Message boxes." {demo demo-msgbox} +.t insert end " \n " {demospace} +.t insert end "2. File selection dialog." {demo demo-filebox} +.t insert end " \n " {demospace} +.t insert end "3. Color picker." {demo demo-clrpick} +.t insert end " \n " {demospace} + +.t insert end \n {} "Miscellaneous" title +.t insert end " \n " {demospace} +.t insert end "1. The built-in bitmaps." {demo demo-bitmap} +.t insert end " \n " {demospace} +.t insert end "2. A dialog box with a local grab." {demo demo-dialog1} +.t insert end " \n " {demospace} +.t insert end "3. A dialog box with a global grab." {demo demo-dialog2} +.t insert end " \n " {demospace} + +.t configure -state disabled +focus .s + +# positionWindow -- +# This procedure is invoked by most of the demos to position a +# new demo window. +# +# Arguments: +# w - The name of the window to position. + +proc positionWindow w { + wm geometry $w +300+300 +} + +# showVars -- +# Displays the values of one or more variables in a window, and +# updates the display whenever any of the variables changes. +# +# Arguments: +# w - Name of new window to create for display. +# args - Any number of names of variables. + +proc showVars {w args} { + catch {destroy $w} + toplevel $w + wm title $w "Variable values" + label $w.title -text "Variable values:" -width 20 -anchor center \ + -font -Adobe-helvetica-medium-r-normal--*-180-*-*-*-*-*-* + pack $w.title -side top -fill x + set len 1 + foreach i $args { + if {[string length $i] > $len} { + set len [string length $i] + } + } + foreach i $args { + frame $w.$i + label $w.$i.name -text "$i: " -width [expr $len + 2] -anchor w + label $w.$i.value -textvar $i -anchor w + pack $w.$i.name -side left + pack $w.$i.value -side left -expand 1 -fill x + pack $w.$i -side top -anchor w -fill x + } + button $w.ok -text OK -command "destroy $w" + pack $w.ok -side bottom -pady 2 +} + +# invoke -- +# This procedure is called when the user clicks on a demo description. +# It is responsible for invoking the demonstration. +# +# Arguments: +# index - The index of the character that the user clicked on. + +proc invoke index { + global tk_library + set tags [.t tag names $index] + set i [lsearch -glob $tags demo-*] + if {$i < 0} { + return + } + set cursor [.t cget -cursor] + .t configure -cursor watch + update + set demo [string range [lindex $tags $i] 5 end] + uplevel [list source [file join $tk_library demos $demo.tcl]] + update + .t configure -cursor $cursor + + .t tag add visited "$index linestart +1 chars" "$index lineend -1 chars" +} + +# showStatus -- +# +# Show the name of the demo program in the status bar. This procedure +# is called when the user moves the cursor over a demo description. +# +proc showStatus index { + global tk_library + set tags [.t tag names $index] + set i [lsearch -glob $tags demo-*] + set cursor [.t cget -cursor] + if {$i < 0} { + .statusBar.lab config -text " " + set newcursor xterm + } else { + set demo [string range [lindex $tags $i] 5 end] + .statusBar.lab config -text "Run the \"$demo\" sample program" + set newcursor hand2 + } + if [string compare $cursor $newcursor] { + .t config -cursor $newcursor + } +} + + +# showCode -- +# This procedure creates a toplevel window that displays the code for +# a demonstration and allows it to be edited and reinvoked. +# +# Arguments: +# w - The name of the demonstration's window, which can be +# used to derive the name of the file containing its code. + +proc showCode w { + global tk_library + set file [string range $w 1 end].tcl + if ![winfo exists .code] { + toplevel .code + frame .code.buttons + pack .code.buttons -side bottom -fill x + button .code.buttons.dismiss -text Dismiss -command "destroy .code" + button .code.buttons.rerun -text "Rerun Demo" -command { + eval [.code.text get 1.0 end] + } + pack .code.buttons.dismiss .code.buttons.rerun -side left \ + -expand 1 -pady 2 + frame .code.frame + pack .code.frame -expand yes -fill both -padx 1 -pady 1 + text .code.text -height 40 -wrap word\ + -xscrollcommand ".code.xscroll set" \ + -yscrollcommand ".code.yscroll set" \ + -setgrid 1 -highlightthickness 0 -pady 2 -padx 3 + scrollbar .code.xscroll -command ".code.text xview" \ + -highlightthickness 0 -orient horizontal + scrollbar .code.yscroll -command ".code.text yview" \ + -highlightthickness 0 -orient vertical + + grid .code.text -in .code.frame -padx 1 -pady 1 \ + -row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news + grid .code.yscroll -in .code.frame -padx 1 -pady 1 \ + -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news +# grid .code.xscroll -in .code.frame -padx 1 -pady 1 \ +# -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news + grid rowconfig .code.frame 0 -weight 1 -minsize 0 + grid columnconfig .code.frame 0 -weight 1 -minsize 0 + } else { + wm deiconify .code + raise .code + } + wm title .code "Demo code: [file join $tk_library demos $file]" + wm iconname .code $file + set id [open [file join $tk_library demos $file]] + .code.text delete 1.0 end + .code.text insert 1.0 [read $id] + .code.text mark set insert 1.0 + close $id +} + +# aboutBox -- +# +# Pops up a message box with an "about" message +# +proc aboutBox {} { + tk_messageBox -icon info -type ok -title "About Widget Demo" -message \ +"Tk widget demonstration\n\n\ +Copyright (c) 1996 Sun Microsystems, Inc." +} + diff --git a/gcl-tk/demos-4.2/widget.lisp b/gcl-tk/demos-4.2/widget.lisp new file mode 100755 index 0000000..33123a5 --- /dev/null +++ b/gcl-tk/demos-4.2/widget.lisp @@ -0,0 +1,385 @@ +;;#!/bin/sh +;; the next line restarts using wish +;(exec :wish4.2 (tk-conc 0) "$@") +(in-package "TK") +;; widget -- +;; This script demonstrates the various widgets provided by Tk, +;; along with many of the features of the Tk toolkit. This file +;; only contains code to generate the main window for the +;; application, which invokes individual demonstrations. The +;; code for the actual demonstrations is contained in separate +;; ".tcl" files is this directory, which are sourced by this script +;; as needed. +;; +;; SCCS: @(#) :widget 1.21 96/10/04 17:09:34 + +(apply 'destroy (winfo :child '|.| :return 'list)) +(wm :title '|.| "Widget Demonstration") + +;;---------------------------------------------------------------- +;; The code below create the main window, consisting of a menu bar +;; and a text widget that explains how to use the program, plus lists +;; all of the demos as hypertext items. +;;---------------------------------------------------------------- + +(setq font '-*-Helvetica-Medium-R-Normal--*-140-*-*-*-*-*-*) +(frame '.menuBar) +(pack '.menuBar :side "top" :fill "x") +(menubutton '.menuBar.file :text "File" :menu '.menuBar.file.m :underline 0) +(menu '.menuBar.file.m) +(.menuBar.file.m :add :command :label "About '... " :command "aboutBox" + :underline 0 :accelerator "") +(.menuBar.file.m :add :sep) +(.menuBar.file.m :add :command :label "Quit" :command "exit" :underline 0) +(pack '.menuBar.file :side "left") +(bind '|.| "" 'aboutBox) + +(frame '.textFrame) +(scrollbar '.s :orient "vertical" :command '(.t :yview) :highlightthickness 0 + :takefocus 1) +(pack '.s :in '.textFrame :side "right" :fill "y" :padx 1) +(text '.t :yscrollcommand '(.s :set) :wrap "word" :width 60 :height 30 :font font + :setgrid 1 :highlightthickness 0 :padx 4 :pady 2 :takefocus 0) +(pack '.t :in '.textFrame :expand "y" :fill "both" :padx 1) +(pack '.textFrame :expand "yes" :fill "both" :padx 1 :pady 2) + +(frame '.statusBar) +(label '.statusBar.lab :text " " :relief "sunken" :bd 1 + :font :*-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* :anchor "w") +(label '.statusBar.foo :width 8 :relief "sunken" :bd 1 + :font :*-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* :anchor "w") +(pack '.statusBar.lab :side "left" :padx 2 :expand "yes" :fill "both") +(pack '.statusBar.foo :side "left" :padx 2) +(pack '.statusBar :side "top" :fill "x" :pady 2) + +;; Create a bunch of tags to use in the text widget, such as those for +;; section titles and demo descriptions. Also define the bindings for +;; tags. + +(.t :tag :configure "title" :font :*-Helvetica-Bold-R-Normal--*-180-*-*-*-*-*-*) + +;; We put some "space" characters to the left and right of each demo description +;; so that the descriptions are highlighted only when the mouse cursor +;; is right over them (but :not when the cursor is to their left or right) +;; +(.t :tag :configure "demospace" :lmargin1 "1c" :lmargin2 "1c") + + +(if (equal (winfo :depth '|.| :return 'number) 1) (progn + (.t :tag :configure "demo" :lmargin1 "1c" :lmargin2 "1c" + :underline 1) + (.t :tag :configure "visited" :lmargin1 "1c" :lmargin2 "1c" + :underline 1) + (.t :tag :configure "hot" :background "black" :foreground "white") + ) ;;else + (progn + (.t :tag :configure "demo" :lmargin1 "1c" :lmargin2 "1c" + :foreground "blue" :underline 1) + (.t :tag :configure "visited" :lmargin1 "1c" :lmargin2 "1c" + :foreground "#303080" :underline 1) + (.t :tag :configure "hot" :foreground "red" :underline 1) +)) +(.t :tag :bind "demo" "" + '(invoke (.t index "@%x,%y")) +) + +(setq lastLine "") +(.t :tag :bind "demo" "" '(progn + (setq lastLine (.t :index "@" : |%x| :"," : |%y| "linestart" :return 'number)) + (.t :tag :add "hot" (tk-conc lastLine " +1 chars") (tk-conc lastLine " lineend -1 chars")) + (.t :config :cursor "hand2") + (showStatus (.t :index "@" : |%x| :"," : |%y| :return 'number)) + )) + +(.t :tag :bind "demo" "" '(progn + (.t :tag :remove "hot" 1.0 end) + (.t :config :cursor "xterm") + (.statusBar.lab :config :text "") +) +(.t :tag :bind "demo" "" '(progn + (setq newLine [.t index {@%x,%y linestart}]) + (if ([string :compare newLine $lastLine] != 0) (progn + (.t :tag :remove "hot" 1.0 end) + (setq lastLine newLine) + + (setq tags [.t tag names {@%x,%y}]) + (setq i [lsearch :glob tags "demo-*"]) + (if (funcall i >= 0) {) + (.t :tag :add "hot" (tk-conc lastLine " +1 chars") (tk-conc lastLine " lineend -1 chars")) + ) + ) + (showStatus (.t :index "@%x,%y" :return 'number)) +)) + +;; Create the text for the text widget. + +(.t :insert end "Tk Widget Demonstrations\n" title) +(.t :insert end {) +(This :application provides a front end for several short scripts that demonstrate what you can do with Tk widgets. Each of the numbered lines below describes a demonstration; you can click on it to invoke the demonstration. Once the demonstration window appears, you can click the "See Code" button to see the Tcl/Tk code that created the demonstration. (if :you wish, you can edit the code and click the "Rerun Demo" button in the code window to reinvoke the demonstration with the modified code.) + +} +(setq *newline* " + ") +(.t :insert :end "Labels, buttons, checkbuttons, and radiobuttons" "title") +(.t :insert :end *newline* "demospace") +(.t :insert :end "1. Labels (text :and bitmaps)." "demo demo-label") +(.t :insert :end " \n " "demospace") +(.t :insert :end "2. Buttons." "demo demo-label") +(.t :insert :end *newline* "demospace") +(.t :insert :end "3. Checkbuttons (select :any of a group)." "demo demo-check") +(.t :insert :end *newline* "demospace") +(.t :insert :end "4. Radiobuttons (select :one of a group).""demo demo-radio") +(.t :insert :end *newline* "demospace") +(.t :insert :end "5. A 15-puzzle game made out of buttons.""demo demo-puzzle") +(.t :insert :end *newline* "demospace") +(.t :insert :end "6. Iconic buttons that use bitmaps." "demo demo-icon") +(.t :insert :end *newline* "demospace") +(.t :insert :end "7. Two labels displaying images." "demo demo-image1") +(.t :insert :end *newline* "demospace") +(.t :insert :end "8. A simple user interface for viewing images." + "demo demo-image2") +(.t :insert :end *newline* "demospace") + +(.t :insert :end *newline* : "Listboxes" "title") +(.t :insert :end *newline* "demospace") +(.t :insert :end "1. 50 states." "demo demo-states") +(.t :insert :end *newline* "demospace") +(.t :insert :end "2. Colors: change the color scheme for the application." + "demo demo-colors") +(.t :insert :end *newline* "demospace") +(.t :insert :end "3. A collection of famous sayings." "demo demo-sayings") +(.t :insert :end *newline* "demospace") + +(.t :insert :end *newline* : "Entries" "title") +(.t :insert :end *newline* "demospace") +(.t :insert :end "1. Without scrollbars." "demo demo-entry1") +(.t :insert :end *newline* "demospace") +(.t :insert :end "2. With scrollbars." "demo demo-entry2") +(.t :insert :end *newline* "demospace") +(.t :insert :end "3. Simple Rolodex-like form." "demo demo-form") +(.t :insert :end *newline* "demospace") + +(.t :insert :end *newline* : "Text" "title") +(.t :insert :end *newline* "demospace") +(.t :insert :end "1. Basic editable text." "demo demo-text") +(.t :insert :end *newline* "demospace") +(.t :insert :end "2. Text display styles." "demo demo-style") +(.t :insert :end *newline* "demospace") +(.t :insert :end "3. Hypertext (tag :bindings)." "demo demo-bind") +(.t :insert :end *newline* "demospace") +(.t :insert :end "4. A text widget with embedded windows." "demo demo-twind") +(.t :insert :end *newline* "demospace") +(.t :insert :end "5. A search tool built with a text widget." "demo demo-search") +(.t :insert :end *newline* "demospace") + +(.t :insert :end *newline* : "Canvases" "title") +(.t :insert :end *newline* "demospace") +(.t :insert :end "1. The canvas item types." "demo demo-items") +(.t :insert :end *newline* "demospace") +(.t :insert :end "2. A simple 2-D plot." "demo demo-plot") +(.t :insert :end *newline* "demospace") +(.t :insert :end "3. Text items in canvases." "demo demo-ctext") +(.t :insert :end *newline* "demospace") +(.t :insert :end "4. An editor for arrowheads on canvas lines." "demo demo-arrow") +(.t :insert :end *newline* "demospace") +(.t :insert :end "5. A ruler with adjustable tab stops." "demo demo-ruler") +(.t :insert :end *newline* "demospace") +(.t :insert :end "6. A building floor plan." "demo demo-floor") +(.t :insert :end *newline* "demospace") +(.t :insert :end "7. A simple scrollable canvas." "demo demo-cscroll") +(.t :insert :end *newline* "demospace") + +(.t :insert :end *newline* : "Scales" "title") +(.t :insert :end *newline* "demospace") +(.t :insert :end "1. Vertical scale." "demo demo-vscale") +(.t :insert :end *newline* "demospace") +(.t :insert :end "2. Horizontal scale." "demo demo-hscale") +(.t :insert :end *newline* "demospace") + +(.t :insert :end *newline* : "Menus" "title") +(.t :insert :end *newline* "demospace") +(.t :insert :end "1. A window containing several menus and cascades." + (demo demo-menu)) +(.t :insert :end *newline* "demospace") + +(.t :insert :end *newline* : "Common Dialogs" "title") +(.t :insert :end *newline* "demospace") +(.t :insert :end "1. Message boxes." "demo demo-msgbox") +(.t :insert :end *newline* "demospace") +(.t :insert :end "2. File selection dialog." "demo demo-filebox") +(.t :insert :end *newline* "demospace") +(.t :insert :end "3. Color picker." "demo demo-clrpick") +(.t :insert :end *newline* "demospace") + +(.t :insert :end *newline* : "Miscellaneous" "title") +(.t :insert :end *newline* "demospace") +(.t :insert :end "1. The built-in bitmaps." "demo demo-bitmap") +(.t :insert :end *newline* "demospace") +(.t :insert :end "2. A dialog box with a local grab." "demo demo-dialog1") +(.t :insert :end *newline* "demospace") +(.t :insert :end "3. A dialog box with a global grab." "demo demo-dialog2") +(.t :insert :end *newline* "demospace") + +(.t :configure :state "disabled") +(focus '.s) + +;; positionWindow -- +;; This procedure is invoked by most of the demos to position a +;; new demo window. +;; +;; Arguments: +;; w - The name of the window to position. + +(defun positionWindow w + (wm :geometry w +300+300) +) + +;; showVars -- +;; Displays the values of one or more variables in a window, and +;; updates the display whenever any of the variables changes. +;; +;; Arguments: +;; w - Name of new window to create for display. +;; args - Any number of names of variables. + +(defun showVars (w args) + (if (winfo :exists w) (destroy :w)) + (toplevel w) + (wm :title w "Variable values") + (label (conc w '."title") :text "Variable values:" :width 20 :anchor "center" + :font :Adobe-helvetica-medium-r-normal--*-180-*-*-*-*-*-*) + (pack (conc w '."title") :side "top" :fill "x") + (setq len 1) + foreach i args { +( (if ([string :length $i] > len) (progn ) + (setq len [string length $i]) +( )) + } + foreach i args { + (frame (conc w '|.| i)) + (label (conc w '|.| i '.name) :text (tk-conc i ": ") :width ( + len 2) :anchor "w") + (label (conc w '|.| i '.value) :textvar i :anchor "w") + (pack (conc w '|.| i '.name) :side "left") + (pack (conc w '|.| i '.value) :side "left" :expand 1 :fill "x") + (pack (conc w '|.| i) :side "top" :anchor "w" :fill "x") + } + (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) + (pack (conc w '.ok) :side "bottom" :pady 2) +) + +;; invoke -- +;; This procedure is called when the user clicks on a demo description. +;; It is responsible for invoking the demonstration. +;; +;; Arguments: +;; index - The index of the character that the user clicked on. + +(defun invoke index + (global :tk_library) + (setq tags [.t tag names $index]) + (setq i [lsearch :glob tags demo-*]) + (if (funcall i < 0) (progn + (return) + ) + (setq cursor [.t cget :cursor]) + (.t :configure :cursor "watch") + (update) + (setq demo [string range [lindex tags $i] 5 end]) + (uplevel [list source [file join $tk_library demos (conc demo '.tcl)]]) + (update) + (.t :configure :cursor cursor) + + (.t :tag :add visited (tk-conc index " linestart +1 chars") (tk-conc index " lineend -1 chars")) +) + +;; showStatus -- +;; +;; Show the name of the demo program in the status bar. This procedure +;; is called when the user moves the cursor over a demo description. +;; +(defun showStatus (index ) + ;(global :tk_library) +; (setq index (round index)) + (setq tags (.t :tag "names" index :return 'string)) + (setq i (lsearch "-glob" tags "demo-*" :return 'number)) + (setq cursor (.t :cget :cursor :return 'string)) + (if (< i 0) (progn + (.statusBar.lab :config :text " ") + (setq newcursor "xterm") + ) ;;else + (progn + (setq demo + (string :range (lindex tags i :return 'string) 5 "end" + :return 'string)) + (.statusBar.lab :config :text (tk-conc "Run the \"" demo "\" sample program")) + (setq newcursor "hand2") + )) + (if (string :compare cursor newcursor :return 'boolean) + (.t :config :cursor newcursor) + ) +) + + +;; showCode -- +;; This procedure creates a toplevel window that displays the code for +;; a demonstration and allows it to be edited and reinvoked. +;; +;; Arguments: +;; w - The name of the demonstration's window, which can be +;; used to derive the name of the file containing its code. + +(defun showCode w + (global :tk_library) + (setq file [string range w 1 end].tcl) + (if ![winfo exists '.code] { + (toplevel '.code) + (frame '.code.buttons) + (pack '.code.buttons :side "bottom" :fill "x") + (button '.code.buttons.dismiss :text "Dismiss" :command "destroy '.code") + (button '.code.buttons.rerun :text "Rerun Demo" :command {) + (eval [.code.text get 1.0 end]) + } + (pack '.code.buttons.dismiss '.code.buttons.rerun :side "left" + :expand 1 :pady 2) + (frame '.code.frame) + (pack '.code.frame :expand "yes" :fill "both" :padx 1 :pady 1) + (text '.code.text :height 40 :wrap "word +" :xscrollcommand ".code.xscroll set" + :yscrollcommand ".code.yscroll set" + :setgrid 1 :highlightthickness 0 :pady 2 :padx 3) + (scrollbar '.code.xscroll :command ".code.text xview" + :highlightthickness 0 :orient "horizontal") + (scrollbar '.code.yscroll :command ".code.text yview" + :highlightthickness 0 :orient "vertical") + + (grid '.code.text :in '.code.frame :padx 1 :pady 1 + :row 0 :column 0 :rowspan 1 :columnspan 1 :sticky "news") + (grid '.code.yscroll :in '.code.frame :padx 1 :pady 1 + :row 0 :column 1 :rowspan 1 :columnspan 1 :sticky "news") +;; grid '.code.xscroll :in '.code.frame :padx 1 :pady 1 +;; :row 1 :column 0 :rowspan 1 :columnspan 1 :sticky "news" + (grid :rowconfig '.code.frame 0 :weight 1 :minsize 0) + (grid :columnconfig '.code.frame 0 :weight 1 :minsize 0) + } else { + (wm :deiconify '.code) + (raise '.code) + } + (wm :title '.code (tk-conc "Demo code: [file join " tk "_library demos " file "]")) + (wm :iconname '.code file) + (setq id [open [file join $tk_library demos $file]]) + (.code.text :delete 1.0 end) + (.code.text :insert 1.0 [read $id]) + (.code.text :mark set insert 1.0) + (close id) +) + +;; aboutBox -- +;; +;; Pops up a message box with an "about" message +;; +(defun aboutBox () + (tk_messageBox :icon "info" :type "ok" :title "About Widget Demo" :message +"Tk widget demonstration\\n\\n +Copyright (c) 1996 Sun Microsystems, Inc.") +) + diff --git a/gcl-tk/demos/gc-monitor.lisp b/gcl-tk/demos/gc-monitor.lisp new file mode 100755 index 0000000..f5dda63 --- /dev/null +++ b/gcl-tk/demos/gc-monitor.lisp @@ -0,0 +1,158 @@ + +;; bug in aix c compiler on optimize?? +#+aix3 (eval-when (compile) (proclaim '(optimize (speed 0)))) + +(in-package "TK") + +(defvar *gc-monitor-types* + '(cons fixnum string si::relocatable-blocks stream)) + +(defvar *special-type-background* "red") + +(defun make-one-graph (top type) + (let* ((f (conc top '.type type))) + (setf (get type 'frame) f) + (setf (get type 'canvas) (conc top '.canvas type)) + (frame f ) + (canvas (get type 'canvas) :relief "sunken" :width "8c" :height ".4c") + (label (conc f '.data)) + (button (conc f '.label) :text (string-capitalize (symbol-name type)) + :background "gray90" + :command `(draw-status ',type t)) + (pack (conc f '.label) (conc f '.data) :side "left" :anchor "w" :padx "4m") + (pack f :side "top" :anchor "w" :padx "1c") + (pack (get type 'canvas) :side "top" :expand 1 :pady "2m") + )) + +(defvar *prev-special-type* nil) + +(defvar *time-to-stay-on-type* 0) + + +(defvar *values-array* (make-array 20 :fill-pointer 0)) +(defun push-multiple-values (&rest l) + (declare (:dynamic-extent l)) + (dolist (v l) (vector-push-extend v *values-array*))) + +(defun draw-status (special-type &optional clicked) + (setf (fill-pointer *values-array*) 0) + (let ((max-size 0) (ar *values-array*) (i 0) (width 7.0s0) + (ht ".15c")) + (declare (fixnum max-size) (short-float width)(type (array (t)) ar)) + (dolist (v *gc-monitor-types*) + (let ((fp (fill-pointer *values-array*)) + ) + (multiple-value-call 'push-multiple-values (si::allocated v)) + (setq max-size (max max-size (aref ar (the fixnum (+ fp 1))))))) + ; (nfree npages maxpage nppage gccount nused) + (dolist (v *gc-monitor-types*) + (let* ((nfree (aref ar i)) + (npages (aref ar (setq i(+ i 1)))) + (nppage (aref ar (setq i(+ i 2)))) + (gccount (aref ar (setq i (+ i 1)))) + (nused (aref ar (setq i (+ i 1)))) + (wid (/ (the short-float(* npages width)) max-size)) + (f (get v 'frame)) + (tot (* npages nppage)) + (width-used (the short-float + (/ (the short-float + (* wid (the fixnum + (- tot + (the fixnum nfree))))) + tot)))) + (declare (fixnum nppage npages tot) + (short-float wid)) + (setq i (+ i 1)) + (funcall (get v 'canvas) :delete "graph") + (funcall (get v 'canvas) :create "line" + 0 ht + width-used : "c" ht + :width "3m" :tag "graph" :fill "red") + (funcall (get v 'canvas) :create "line" + width-used : "c" ht + wid : "c" ht + :width "3m" :tag "graph" :fill "aquamarine4" ) + (funcall (conc f '.data) :configure :text + gccount : " gc's for ": npages : + " pages (used=" : nused : ")") + (cond ((eql special-type v) + (cond + (clicked + (let ((n (* max-size 2))) + (.gc.amount :configure :length "8c" + :label "Allocate: " : (or special-type "") + :tickinterval (truncate n 4) :to n) + (.gc.amount :set npages) + + ))))))) + (set-label-background *prev-special-type* "pink") + + (setq *prev-special-type* special-type) + (set-label-background special-type *special-type-background*) + ) + ) + + + +(defun do-allocation () + (when *prev-special-type* + (allocate *prev-special-type* + (.gc.amount :get :return 'number) + t) + (draw-status *prev-special-type*))) + +(defun set-label-background (type colour) + (and (get type 'frame) + (let ((label (conc (get type 'frame) '.label))) + (funcall label :configure :background colour)))) + + +(defun mkgcmonitor() + (let (si::*after-gbc-hook*) + (toplevel '.gc) + (wm :title '.gc "GC Monitor") + (wm :title '.gc "GC") + (or (> (read-from-string (winfo :depth '.gc)) 1) + (setq *special-type-background* "white")) + (message '.gc.msg :font :Adobe-times-medium-r-normal--*-180* :aspect 400 + :text + "GC monitor displays after each garbage collection the amount of space used (red) and free (green) of the types in the list *gc-monitor-types*. Clicking on a type makes its size appear on the scale at the bottom, and double clicking on the scale causes actual allocation!") + (pack '.gc.msg :side "top") + (dolist (v *gc-monitor-types*) + (make-one-graph '.gc v) + ) + (.gc :configure :borderwidth 4 :relief "ridge") + ;; it is important to create the frame first, so that + ;; it is earlier... and the others will show. + (frame '.gc.ff) + (button '.gc.ok :text "QUIT" + :command `(progn (setq si::*after-gbc-hook* nil) + (destroy '.gc))) + + (scale '.gc.amount :label "Amount :" :width ".3c" + :orient "horizontal" :to 100) + (pack '.gc.amount) + (button '.gc.reset :text "RESET Number Used" + :command '(progn (dolist (v *gc-monitor-types*) + (set-label-background v "gray90")) + (si::reset-number-used) + (draw-status *prev-special-type*))) + (button '.gc.update :text "Update" + :command '(draw-status *prev-special-type*)) + + (pack '.gc.ok '.gc.reset '.gc.update :expand 1 :fill "x" + :in '.gc.ff :padx 3 :pady 2 :side 'left) + + (pack '.gc.ff :expand 1 :fill "x") + (bind '.gc.amount "" + 'do-allocation) + + + + (draw-status nil)) + (setq si::*after-gbc-hook* 'draw-status) + ) + + + + \ No newline at end of file diff --git a/gcl-tk/demos/mkArrow.tcl b/gcl-tk/demos/mkArrow.tcl new file mode 100755 index 0000000..ea6ece8 --- /dev/null +++ b/gcl-tk/demos/mkArrow.tcl @@ -0,0 +1,203 @@ +# mkArrow w +# +# Create a top-level window containing a canvas demonstration that +# allows the user to experiment with arrow shapes. +# +# Arguments: +# w - Name to use for new top-level window. + +# This file implements a canvas widget that displays a large line with +# an arrowhead and allows the shape of the arrowhead to be edited +# interactively. The only procedure that should be invoked from outside +# the file is the first one, which creates the canvas. + +proc mkArrow {{w .arrow}} { + global tk_library + upvar #0 demo_arrowInfo v + catch {destroy $w} + toplevel $w + dpos $w + wm title $w "Arrowhead Editor Demonstration" + wm iconname $w "Arrow" + set c $w.c + + frame $w.frame1 -relief raised -bd 2 + canvas $c -width 500 -height 350 -relief raised + button $w.ok -text "OK" -command "destroy $w" + pack $w.frame1 -side top -fill both + pack $w.ok -side bottom -pady 5 + pack $c -expand yes -fill both + message $w.frame1.m -font -Adobe-Times-Medium-R-Normal-*-180-* -aspect 300 \ + -text "This widget allows you to experiment with different widths and arrowhead shapes for lines in canvases. To change the line width or the shape of the arrowhead, drag any of the three boxes attached to the oversized arrow. The arrows on the right give examples at normal scale. The text at the bottom shows the configuration options as you'd enter them for a line." + pack $w.frame1.m + + set v(a) 8 + set v(b) 10 + set v(c) 3 + set v(width) 2 + set v(motionProc) arrowMoveNull + set v(x1) 40 + set v(x2) 350 + set v(y) 150 + set v(smallTips) {5 5 2} + set v(count) 0 + if {[winfo depth $c] > 1} { + set v(bigLineStyle) "-fill SkyBlue1" + set v(boxStyle) "-fill {} -outline black -width 1" + set v(activeStyle) "-fill red -outline black -width 1" + } else { + set v(bigLineStyle) "-fill black -stipple @$tk_library/demos/bitmaps/grey.25" + set v(boxStyle) "-fill {} -outline black -width 1" + set v(activeStyle) "-fill black -outline black -width 1" + } + arrowSetup $c + $c bind box "$c itemconfigure current $v(activeStyle)" + $c bind box "$c itemconfigure current $v(boxStyle)" + $c bind box1 <1> {set demo_arrowInfo(motionProc) arrowMove1} + $c bind box2 <1> {set demo_arrowInfo(motionProc) arrowMove2} + $c bind box3 <1> {set demo_arrowInfo(motionProc) arrowMove3} + $c bind box "\$demo_arrowInfo(motionProc) $c %x %y" + bind $c "arrowSetup $c" +} + +# The procedure below completely regenerates all the text and graphics +# in the canvas window. It's called when the canvas is initially created, +# and also whenever any of the parameters of the arrow head are changed +# interactively. The argument is the name of the canvas widget to be +# regenerated, and also the name of a global variable containing the +# parameters for the display. + +proc arrowSetup c { + upvar #0 demo_arrowInfo v + $c delete all + + # Create the arrow and outline. + + eval "$c create line $v(x1) $v(y) $v(x2) $v(y) -width [expr 10*$v(width)] \ + -arrowshape {[expr 10*$v(a)] [expr 10*$v(b)] [expr 10*$v(c)]} \ + -arrow last $v(bigLineStyle)" + set xtip [expr $v(x2)-10*$v(b)] + set deltaY [expr 10*$v(c)+5*$v(width)] + $c create line $v(x2) $v(y) $xtip [expr $v(y)+$deltaY] \ + [expr $v(x2)-10*$v(a)] $v(y) $xtip [expr $v(y)-$deltaY] \ + $v(x2) $v(y) -width 2 -capstyle round -joinstyle round + + # Create the boxes for reshaping the line and arrowhead. + + eval "$c create rect [expr $v(x2)-10*$v(a)-5] [expr $v(y)-5] \ + [expr $v(x2)-10*$v(a)+5] [expr $v(y)+5] $v(boxStyle) \ + -tags {box1 box}" + eval "$c create rect [expr $xtip-5] [expr $v(y)-$deltaY-5] \ + [expr $xtip+5] [expr $v(y)-$deltaY+5] $v(boxStyle) \ + -tags {box2 box}" + eval "$c create rect [expr $v(x1)-5] [expr $v(y)-5*$v(width)-5] \ + [expr $v(x1)+5] [expr $v(y)-5*$v(width)+5] $v(boxStyle) \ + -tags {box3 box}" + + # Create three arrows in actual size with the same parameters + + $c create line [expr $v(x2)+50] 0 [expr $v(x2)+50] 1000 \ + -width 2 + set tmp [expr $v(x2)+100] + $c create line $tmp [expr $v(y)-125] $tmp [expr $v(y)-75] \ + -width $v(width) \ + -arrow both -arrowshape "$v(a) $v(b) $v(c)" + $c create line [expr $tmp-25] $v(y) [expr $tmp+25] $v(y) \ + -width $v(width) \ + -arrow both -arrowshape "$v(a) $v(b) $v(c)" + $c create line [expr $tmp-25] [expr $v(y)+75] [expr $tmp+25] \ + [expr $v(y)+125] -width $v(width) \ + -arrow both -arrowshape "$v(a) $v(b) $v(c)" + + # Create a bunch of other arrows and text items showing the + # current dimensions. + + set tmp [expr $v(x2)+10] + $c create line $tmp [expr $v(y)-5*$v(width)] \ + $tmp [expr $v(y)-$deltaY] \ + -arrow both -arrowshape $v(smallTips) + $c create text [expr $v(x2)+15] [expr $v(y)-$deltaY+5*$v(c)] \ + -text $v(c) -anchor w + set tmp [expr $v(x1)-10] + $c create line $tmp [expr $v(y)-5*$v(width)] \ + $tmp [expr $v(y)+5*$v(width)] \ + -arrow both -arrowshape $v(smallTips) + $c create text [expr $v(x1)-15] $v(y) -text $v(width) -anchor e + set tmp [expr $v(y)+5*$v(width)+10*$v(c)+10] + $c create line [expr $v(x2)-10*$v(a)] $tmp $v(x2) $tmp \ + -arrow both -arrowshape $v(smallTips) + $c create text [expr $v(x2)-5*$v(a)] [expr $tmp+5] \ + -text $v(a) -anchor n + set tmp [expr $tmp+25] + $c create line [expr $v(x2)-10*$v(b)] $tmp $v(x2) $tmp \ + -arrow both -arrowshape $v(smallTips) + $c create text [expr $v(x2)-5*$v(b)] [expr $tmp+5] \ + -text $v(b) -anchor n + + $c create text $v(x1) 310 -text "-width $v(width)" \ + -anchor w -font -Adobe-Helvetica-Medium-R-Normal-*-180-* + $c create text $v(x1) 330 -text "-arrowshape {$v(a) $v(b) $v(c)}" \ + -anchor w -font -Adobe-Helvetica-Medium-R-Normal-*-180-* + + incr v(count) +} + +# The procedures below are called in response to mouse motion for one +# of the three items used to change the line width and arrowhead shape. +# Each procedure updates one or more of the controlling parameters +# for the line and arrowhead, and recreates the display if that is +# needed. The arguments are the name of the canvas widget, and the +# x and y positions of the mouse within the widget. + +proc arrowMove1 {c x y} { + upvar #0 demo_arrowInfo v + set newA [expr ($v(x2)+5-[$c canvasx $x])/10] + if {$newA < 1} { + set newA 1 + } + if {$newA > 25} { + set newA 25 + } + if {$newA != $v(a)} { + $c move box1 [expr 10*($v(a)-$newA)] 0 + set v(a) $newA + } +} + +proc arrowMove2 {c x y} { + upvar #0 demo_arrowInfo v + set newB [expr ($v(x2)+5-[$c canvasx $x])/10] + if {$newB < 1} { + set newB 1 + } + if {$newB > 25} { + set newB 25 + } + set newC [expr ($v(y)+5-[$c canvasy $y]-5*$v(width))/10] + if {$newC < 1} { + set newC 1 + } + if {$newC > 20} { + set newC 20 + } + if {($newB != $v(b)) || ($newC != $v(c))} { + $c move box2 [expr 10*($v(b)-$newB)] [expr 10*($v(c)-$newC)] + set v(b) $newB + set v(c) $newC + } +} + +proc arrowMove3 {c x y} { + upvar #0 demo_arrowInfo v + set newWidth [expr ($v(y)+5-[$c canvasy $y])/5] + if {$newWidth < 1} { + set newWidth 1 + } + if {$newWidth > 20} { + set newWidth 20 + } + if {$newWidth != $v(width)} { + $c move box3 0 [expr 5*($v(width)-$newWidth)] + set v(width) $newWidth + } +} diff --git a/gcl-tk/demos/mkBasic.lisp b/gcl-tk/demos/mkBasic.lisp new file mode 100755 index 0000000..4a87fce --- /dev/null +++ b/gcl-tk/demos/mkBasic.lisp @@ -0,0 +1,69 @@ +;;# mkBasic w +;; +;; Create a top-level window that displays a basic text widget. +;; +;; Arguments: +;; w - Name to use for new top-level window. + +(in-package "TK") +(defvar *basic-message* " +This window is a text widget. It displays one or more lines of text +and allows you to edit the text. Here is a summary of the things you +can do to a text widget: + +1. Scrolling. Use the scrollbar to adjust the view in the text window. + +2. Scanning. Press mouse button 2 in the text window and drag up or down. +This will drag the text at high speed to allow you to scan its contents. + +3. Insert text. Press mouse button 1 to set the insertion cursor, then +type text. What you type will be added to the widget. You can backspace +over what you've typed using either the backspace key, the delete key, +or Control+h. + +4. Select. Press mouse button 1 and drag to select a range of characters. +Once you've released the button, you can adjust the selection by pressing +button 1 with the shift key down. This will reset the end of the +selection nearest the mouse cursor and you can drag that end of the +selection by dragging the mouse before releasing the mouse button. +You can double-click to select whole words, or triple-click to select +whole lines. + +5. Delete. To delete text, select the characters you'd like to delete +and type Control+d. + +6. Copy the selection. To copy the selection either from this window +or from any other window or application, select what you want, click +button 1 to set the insertion cursor, then type Control+v to copy the +selection to the point of the insertion cursor. + +7. Resize the window. This widget has been configured with the \"setGrid\" +option on, so that if you resize the window it will always resize to an +even number of characters high and wide. Also, if you make the window +narrow you can see that long lines automatically wrap around onto +additional lines so that all the information is always visible. + +When you're finished with this demonstration, press the \"OK\" button +below.") + + +(defun mkBasic (&optional (w '.basic)) + (if (winfo :exists w :return 'boolean) (destroy w)) + (toplevel w) + (dpos w) + (wm :title w "Text Demonstration - Basic Facilities") + (wm :iconname w "Text Basics") + (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) + (scrollbar (conc w '.s) :relief "flat" :command (tk-conc w ".t yview")) + (text (conc w '.t) :relief "raised" :bd 2 :yscrollcommand + (tk-conc w ".s set") :setgrid "true") + + (pack (conc w '.ok) :side 'bottom :fill "x") + (pack (conc w '.s) :side 'right :fill "y") + (pack (conc w '.t) :expand 'yes :fill 'both) + (funcall (conc w '.t) :insert 0.0 *basic-message*) + (funcall (conc w '.t) :mark 'set 'insert 0.0) + (bind w "" (tk-conc "focus " w ".t")) +) + + diff --git a/gcl-tk/demos/mkBasic.tcl b/gcl-tk/demos/mkBasic.tcl new file mode 100755 index 0000000..28a13af --- /dev/null +++ b/gcl-tk/demos/mkBasic.tcl @@ -0,0 +1,61 @@ +# mkBasic w +# +# Create a top-level window that displays a basic text widget. +# +# Arguments: +# w - Name to use for new top-level window. + +proc mkBasic {{w .basic}} { + catch {destroy $w} + toplevel $w + dpos $w + wm title $w "Text Demonstration - Basic Facilities" + wm iconname $w "Text Basics" + button $w.ok -text OK -command "destroy $w" + text $w.t -relief raised -bd 2 -yscrollcommand "$w.s set" -setgrid true + scrollbar $w.s -relief flat -command "$w.t yview" + pack $w.ok -side bottom -fill x + pack $w.s -side right -fill y + pack $w.t -expand yes -fill both + $w.t insert 0.0 {\ +This window is a text widget. It displays one or more lines of text +and allows you to edit the text. Here is a summary of the things you +can do to a text widget: + +1. Scrolling. Use the scrollbar to adjust the view in the text window. + +2. Scanning. Press mouse button 2 in the text window and drag up or down. +This will drag the text at high speed to allow you to scan its contents. + +3. Insert text. Press mouse button 1 to set the insertion cursor, then +type text. What you type will be added to the widget. You can backspace +over what you've typed using either the backspace key, the delete key, +or Control+h. + +4. Select. Press mouse button 1 and drag to select a range of characters. +Once you've released the button, you can adjust the selection by pressing +button 1 with the shift key down. This will reset the end of the +selection nearest the mouse cursor and you can drag that end of the +selection by dragging the mouse before releasing the mouse button. +You can double-click to select whole words, or triple-click to select +whole lines. + +5. Delete. To delete text, select the characters you'd like to delete +and type Control+d. + +6. Copy the selection. To copy the selection either from this window +or from any other window or application, select what you want, click +button 1 to set the insertion cursor, then type Control+v to copy the +selection to the point of the insertion cursor. + +7. Resize the window. This widget has been configured with the "setGrid" +option on, so that if you resize the window it will always resize to an +even number of characters high and wide. Also, if you make the window +narrow you can see that long lines automatically wrap around onto +additional lines so that all the information is always visible. + +When you're finished with this demonstration, press the "OK" button +below.} + $w.t mark set insert 0.0 + bind $w "focus $w.t" +} diff --git a/gcl-tk/demos/mkBitmaps.tcl b/gcl-tk/demos/mkBitmaps.tcl new file mode 100755 index 0000000..f8994a6 --- /dev/null +++ b/gcl-tk/demos/mkBitmaps.tcl @@ -0,0 +1,46 @@ +# mkBitmaps w +# +# Create a top-level window that displays all of Tk's built-in bitmaps. +# +# Arguments: +# w - Name to use for new top-level window. + +proc mkBitmaps {{w .bitmaps}} { + global tk_library + catch {destroy $w} + toplevel $w + dpos $w + wm title $w "Bitmap Demonstration" + wm iconname $w "Bitmaps" + message $w.msg -font -Adobe-times-medium-r-normal--*-180* -width 4i \ + -text "This window displays all of Tk's built-in bitmaps, along with the names you can use for them in Tcl scripts. Click the \"OK\" button when you've seen enough." + frame $w.frame + bitmapRow $w.frame.0 error gray25 gray50 hourglass + bitmapRow $w.frame.1 info question questhead warning + button $w.ok -text OK -command "destroy $w" + pack $w.msg -side top -anchor center + pack $w.frame -side top -expand yes -fill both + pack $w.ok -side bottom -fill both +} + +# The procedure below creates a new row of bitmaps in a window. Its +# arguments are: +# +# w - The window that is to contain the row. +# args - The names of one or more bitmaps, which will be displayed +# in a new row across the bottom of w along with their +# names. + +proc bitmapRow {w args} { + frame $w + pack $w -side top -fill both + set i 0 + foreach bitmap $args { + frame $w.$i + pack $w.$i -side left -fill both -pady .25c -padx .25c + label $w.$i.bitmap -bitmap $bitmap + label $w.$i.label -text $bitmap -width 9 + pack $w.$i.label $w.$i.bitmap -side bottom + incr i + } +} diff --git a/gcl-tk/demos/mkButton.tcl b/gcl-tk/demos/mkButton.tcl new file mode 100755 index 0000000..e112b8f --- /dev/null +++ b/gcl-tk/demos/mkButton.tcl @@ -0,0 +1,33 @@ +# mkButton w +# +# Create a top-level window that displays a bunch of buttons. +# +# Arguments: +# w - Name to use for new top-level window. + +proc mkButton {{w .b1}} { + catch {destroy $w} + toplevel $w + dpos $w + wm title $w "Button Demonstration" + wm iconname $w "Buttons" + message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ + -text "Four buttons are displayed below. If you click on a button, it will change the background of the button area to the color indicated in the button. Click the \"OK\" button when you've seen enough." + frame $w.frame -borderwidth 10 + button $w.ok -text OK -command "destroy $w" + + pack $w.msg -side top -fill both + pack $w.frame -side top -expand yes -fill both + pack $w.ok -side bottom -fill both + + button $w.frame.b1 -text "Peach Puff" \ + -command "$w.frame config -bg PeachPuff1" + button $w.frame.b2 -text "Light Blue" \ + -command "$w.frame config -bg LightBlue1" + button $w.frame.b3 -text "Sea Green" \ + -command "$w.frame config -bg SeaGreen2" + button $w.frame.b4 -text "Yellow" \ + -command "$w.frame config -bg Yellow1" + pack $w.frame.b1 $w.frame.b2 $w.frame.b3 $w.frame.b4 -side top \ + -expand yes -pady 2 +} diff --git a/gcl-tk/demos/mkCanvText.lisp b/gcl-tk/demos/mkCanvText.lisp new file mode 100755 index 0000000..dda7351 --- /dev/null +++ b/gcl-tk/demos/mkCanvText.lisp @@ -0,0 +1,110 @@ +;;# mkCanvText w +;; +;; Create a top-level window containing a canvas displaying a text +;; string and allowing the string to be edited and re-anchored. +;; +;; Arguments: +;; w - Name to use for new top-level window. +(in-package "TK") +(defun mkCanvText ({w .ctext}) + (catch {destroy w}) + (toplevel w) + (dpos w) + (wm :title w "Canvas Text Demonstration") + (wm :iconname w "Text") + (setq c (conc w '.c)) + + (message (conc w '.msg) :font -Adobe-Times-Medium-R-Normal-*-180-* :width 420 + :relief "raised" :bd 2 :text "This window displays a string of text to demonstrate the text facilities of canvas widgets. You can point, click, and type. You can also select and then delete with Control-d. You can copy the selection with Control-v. You can click in the boxes to adjust the position of the text relative to its positioning point or change its justification.") + (canvas c :relief "raised" :width 500 :height 400) + (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) + (pack (conc w '.msg) :side "top" :fill "both") + (pack (conc w '.c) :side "top" :expand "yes" :fill "both") + (pack (conc w '.ok) :side "bottom" :pady 5 :anchor "center") + + (setq font :Adobe-helvetica-medium-r-*-240-*) + + (funcall c :create rectangle 245 195 255 205 :outline "black" :fill "red") + + ;; First, create the text item and give it bindings so it can be edited. + + (funcall c :addtag text withtag (funcall c create text 250 200 :text "This is just a string of text to demonstrate the text facilities of canvas widgets. You can point, click, and type. You can also select and then delete with Control-d." :width 440 :anchor "n" :font font :justify "left")) + (funcall c :bind text "<1>" (textB1Press c |%x| |%y|)) + (funcall c :bind text "" (textB1Move c %x %y)) + (funcall c :bind text "" (tk-conc c " select adjust current @%x,%y")) + (funcall c :bind text "" (funcall 'textB1Move c |%x| |%y|)) + (funcall c :bind text "" (tk-conc c " insert text insert %A")) + (funcall c :bind text "" (tk-conc c " insert text insert %A")) + (funcall c :bind text "" (tk-conc c " insert text insert \\n")) + (funcall c :bind text "" (funcall 'textBs c)) + (funcall c :bind text "" (funcall 'textBs c)) + (funcall c :bind text "" (tk-conc c " dchars text sel.first sel.last")) + (funcall c :bind text "" (tk-conc c " insert text insert \[selection get\]")) + + ;; Next, create some items that allow the text's anchor position + ;; to be edited. + + (setq x 50) + (setq y 50) + (setq color LightSkyBlue1) + (mkTextConfig c x y :anchor "se" color) + (mkTextConfig c (+ x 30) y :anchor "s" color) + (mkTextConfig c (+ x 60) y :anchor "sw" color) + (mkTextConfig c x (+ y 30) :anchor "e" color) + (mkTextConfig c (+ x 30) (+ y 30) :anchor "center" color) + (mkTextConfig c (+ x 60) (+ y 30) :anchor "w" color) + (mkTextConfig c x (+ y 60) :anchor "ne" color) + (mkTextConfig c (+ x 30) (+ y 60) :anchor "n" color) + (mkTextConfig c (+ x 60) (+ y 60) :anchor "nw" color) + (setq item (funcall c create rect (+ x 40) (+ y 40) (+ x 50) (+ y 50) + :outline "black" :fill "red")) + (funcall c :bind item "<1>" (tk-conc c " itemconf text :anchor ")center"") + (funcall c :create text (+ x 45) (- y 5) :text "{Text Position}" :anchor "s" + :font -Adobe-times-medium-r-normal--*-240-* :fill "brown") + + ;; Lastly, create some items that allow the text's justification to be + ;; changed. + + (setq x 350) + (setq y 50) + (setq color SeaGreen2) + (mkTextConfig c x y :justify "left" color) + (mkTextConfig c (+ x 30) y :justify "center" color) + (mkTextConfig c (+ x 60) y :justify "right" color) + (funcall c :create text (+ x 45) (- y 5) :text "Justification" :anchor "s" + :font -Adobe-times-medium-r-normal--*-240-* :fill "brown") + + (funcall c :bind config "" (tk-conc "textEnter " c)) + (funcall c :bind config "" (tk-conc c " itemconf current :fill \$textConfigFill")) +) + +(defun mkTextConfig (w x y option value color) + (setq item (funcall w create rect x y (+ x 30) (+ y 30) + :outline "black" :fill color :width 1)) + (funcall w :bind item "<1>" (tk-conc w " itemconf text " option " " value)) + (funcall w :addtag "config" "withtag" item) +) + +(setq textConfigFill "") + +(defun textEnter (w) + (global :textConfigFill) + (setq textConfigFill [lindex (funcall w :itemconfig "current" :fill) 4]) + (funcall w :itemconfig "current" :fill "black") +) + +(defun textB1Press (w x y) + (funcall w :icursor "current" (aT x y)) + (funcall w :focus "current") + (focus w) + (funcall w :select "from" "current" (aT x y)) +) + +(defun textB1Move (w x y) + (funcall w :select "to current" (aT x y)) +) + +(defun textBs (w &aux char) + (setq char (atoi (funcall w :index "text" "insert")) - 1) + (if (>= char 0) (funcall w :dchar "text" char)) +) diff --git a/gcl-tk/demos/mkCanvText.tcl b/gcl-tk/demos/mkCanvText.tcl new file mode 100755 index 0000000..4bd28b1 --- /dev/null +++ b/gcl-tk/demos/mkCanvText.tcl @@ -0,0 +1,110 @@ +# mkCanvText w +# +# Create a top-level window containing a canvas displaying a text +# string and allowing the string to be edited and re-anchored. +# +# Arguments: +# w - Name to use for new top-level window. + +proc mkCanvText {{w .ctext}} { + catch {destroy $w} + toplevel $w + dpos $w + wm title $w "Canvas Text Demonstration" + wm iconname $w "Text" + set c $w.c + + message $w.msg -font -Adobe-Times-Medium-R-Normal-*-180-* -width 420 \ + -relief raised -bd 2 -text "This window displays a string of text to demonstrate the text facilities of canvas widgets. You can point, click, and type. You can also select and then delete with Control-d. You can copy the selection with Control-v. You can click in the boxes to adjust the position of the text relative to its positioning point or change its justification." + canvas $c -relief raised -width 500 -height 400 + button $w.ok -text "OK" -command "destroy $w" + pack $w.msg -side top -fill both + pack $w.c -side top -expand yes -fill both + pack $w.ok -side bottom -pady 5 -anchor center + + set font -Adobe-helvetica-medium-r-*-240-* + + $c create rectangle 245 195 255 205 -outline black -fill red + + # First, create the text item and give it bindings so it can be edited. + + $c addtag text withtag [$c create text 250 200 -text "This is just a string of text to demonstrate the text facilities of canvas widgets. You can point, click, and type. You can also select and then delete with Control-d." -width 440 -anchor n -font $font -justify left] + $c bind text <1> "textB1Press $c %x %y" + $c bind text "textB1Move $c %x %y" + $c bind text "$c select adjust current @%x,%y" + $c bind text "textB1Move $c %x %y" + $c bind text "$c insert text insert %A" + $c bind text "$c insert text insert %A" + $c bind text "$c insert text insert \\n" + $c bind text "textBs $c" + $c bind text "textBs $c" + $c bind text "$c dchars text sel.first sel.last" + $c bind text "$c insert text insert \[selection get\]" + + # Next, create some items that allow the text's anchor position + # to be edited. + + set x 50 + set y 50 + set color LightSkyBlue1 + mkTextConfig $c $x $y -anchor se $color + mkTextConfig $c [expr $x+30] [expr $y] -anchor s $color + mkTextConfig $c [expr $x+60] [expr $y] -anchor sw $color + mkTextConfig $c [expr $x] [expr $y+30] -anchor e $color + mkTextConfig $c [expr $x+30] [expr $y+30] -anchor center $color + mkTextConfig $c [expr $x+60] [expr $y+30] -anchor w $color + mkTextConfig $c [expr $x] [expr $y+60] -anchor ne $color + mkTextConfig $c [expr $x+30] [expr $y+60] -anchor n $color + mkTextConfig $c [expr $x+60] [expr $y+60] -anchor nw $color + set item [$c create rect [expr $x+40] [expr $y+40] [expr $x+50] [expr $y+50] \ + -outline black -fill red] + $c bind $item <1> "$c itemconf text -anchor center" + $c create text [expr $x+45] [expr $y-5] -text {Text Position} -anchor s \ + -font -Adobe-times-medium-r-normal--*-240-* -fill brown + + # Lastly, create some items that allow the text's justification to be + # changed. + + set x 350 + set y 50 + set color SeaGreen2 + mkTextConfig $c $x $y -justify left $color + mkTextConfig $c [expr $x+30] [expr $y] -justify center $color + mkTextConfig $c [expr $x+60] [expr $y] -justify right $color + $c create text [expr $x+45] [expr $y-5] -text {Justification} -anchor s \ + -font -Adobe-times-medium-r-normal--*-240-* -fill brown + + $c bind config "textEnter $c" + $c bind config "$c itemconf current -fill \$textConfigFill" +} + +proc mkTextConfig {w x y option value color} { + set item [$w create rect [expr $x] [expr $y] [expr $x+30] [expr $y+30] \ + -outline black -fill $color -width 1] + $w bind $item <1> "$w itemconf text $option $value" + $w addtag config withtag $item +} + +set textConfigFill {} + +proc textEnter {w} { + global textConfigFill + set textConfigFill [lindex [$w itemconfig current -fill] 4] + $w itemconfig current -fill black +} + +proc textB1Press {w x y} { + $w icursor current @$x,$y + $w focus current + focus $w + $w select from current @$x,$y +} + +proc textB1Move {w x y} { + $w select to current @$x,$y +} + +proc textBs {w} { + set char [expr {[$w index text insert] - 1}] + if {$char >= 0} {$w dchar text $char} +} diff --git a/gcl-tk/demos/mkCheck.tcl b/gcl-tk/demos/mkCheck.tcl new file mode 100755 index 0000000..42451ce --- /dev/null +++ b/gcl-tk/demos/mkCheck.tcl @@ -0,0 +1,33 @@ +# mkCheck w +# +# Create a top-level window that displays a bunch of check buttons. +# +# Arguments: +# w - Name to use for new top-level window. + +proc mkCheck {{w .c1}} { + catch {destroy $w} + toplevel $w + dpos $w + wm title $w "Checkbutton demonstration" + wm iconname $w "Checkbuttons" + message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ + -text "Three checkbuttons are displayed below. If you click on a button, it will toggle the button's selection state and set a Tcl variable to a value indicating the state of the checkbutton. Click the \"See Variables\" button to see the current values of the variables. Click the \"OK\" button when you've seen enough." + frame $w.frame -borderwidth 10 + frame $w.frame2 + + pack $w.msg -side top -fill both + pack $w.frame -side top -expand yes -fill both + pack $w.frame2 -side bottom -fill both + + checkbutton $w.frame.b1 -text "Wipers OK" -variable wipers -relief flat + checkbutton $w.frame.b2 -text "Brakes OK" -variable brakes -relief flat + checkbutton $w.frame.b3 -text "Driver Sober" -variable sober -relief flat + pack $w.frame.b1 $w.frame.b2 $w.frame.b3 -side top -pady 2 -expand yes \ + -anchor w + + button $w.frame2.ok -text OK -command "destroy $w" + button $w.frame2.vars -text "See Variables" \ + -command "showVars $w.dialog wipers brakes sober" + pack $w.frame2.ok $w.frame2.vars -side left -expand yes -fill both +} diff --git a/gcl-tk/demos/mkDialog.tcl b/gcl-tk/demos/mkDialog.tcl new file mode 100755 index 0000000..ce34202 --- /dev/null +++ b/gcl-tk/demos/mkDialog.tcl @@ -0,0 +1,63 @@ +# mkDialog w msgArgs list list ... +# +# Create a dialog box with a message and any number of buttons at +# the bottom. +# +# Arguments: +# w - Name to use for new top-level window. +# msgArgs - List of arguments to use when creating the message of the +# dialog box (e.g. text, justifcation, etc.) +# list - A two-element list that describes one of the buttons that +# will appear at the bottom of the dialog. The first element +# gives the text to be displayed in the button and the second +# gives the command to be invoked when the button is invoked. + +proc mkDialog {w msgArgs args} { + catch {destroy $w} + toplevel $w -class Dialog + wm title $w "Dialog box" + wm iconname $w "Dialog" + + # Create two frames in the main window. The top frame will hold the + # message and the bottom one will hold the buttons. Arrange them + # one above the other, with any extra vertical space split between + # them. + + frame $w.top -relief raised -border 1 + frame $w.bot -relief raised -border 1 + pack $w.top $w.bot -side top -fill both -expand yes + + # Create the message widget and arrange for it to be centered in the + # top frame. + + eval message $w.top.msg -justify center \ + -font -Adobe-times-medium-r-normal--*-180* $msgArgs + pack $w.top.msg -side top -expand yes -padx 3 -pady 3 + + # Create as many buttons as needed and arrange them from left to right + # in the bottom frame. Embed the left button in an additional sunken + # frame to indicate that it is the default button, and arrange for that + # button to be invoked as the default action for clicks and returns in + # the dialog. + + if {[llength $args] > 0} { + set arg [lindex $args 0] + frame $w.bot.0 -relief sunken -border 1 + pack $w.bot.0 -side left -expand yes -padx 10 -pady 10 + button $w.bot.0.button -text [lindex $arg 0] \ + -command "[lindex $arg 1]; destroy $w" + pack $w.bot.0.button -expand yes -padx 6 -pady 6 + bind $w "[lindex $arg 1]; destroy $w" + focus $w + + set i 1 + foreach arg [lrange $args 1 end] { + button $w.bot.$i -text [lindex $arg 0] \ + -command "[lindex $arg 1]; destroy $w" + pack $w.bot.$i -side left -expand yes -padx 10 + set i [expr $i+1] + } + } + bind $w [list focus $w] + focus $w +} diff --git a/gcl-tk/demos/mkEntry.lisp b/gcl-tk/demos/mkEntry.lisp new file mode 100755 index 0000000..8fee802 --- /dev/null +++ b/gcl-tk/demos/mkEntry.lisp @@ -0,0 +1,30 @@ +;;# mkEntry w +;; +;; Create a top-level window that displays a bunch of entries. +;; +;; Arguments: +;; w - Name to use for new top-level window. + +(in-package "TK") +(defun mkEntry (&optional (w '.e1)) + (if (winfo :exists w :return 'boolean) (destroy w)) + (toplevel w) + (dpos w) + (wm :title w "Entry Demonstration") + (wm :iconname w "Entries") + (message (conc w '.msg) :font :Adobe-times-medium-r-normal--*-180* :aspect 200 + :text "Three different entries are displayed below. You can add characters by pointing, clicking and typing. The usual emacs control characters control editing. Thus control-b back a char, control-f forward a char, control-a begin line, control-k kill rest of line, control-y yank. For entries that are too large to fit in the window all at once, you can scan through the entries by dragging with mouse button 2 pressed. Click the \"OK\" button when you've seen enough.") + (frame (conc w '.frame) :borderwidth 10) + (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) + (pack (conc w '.msg) (conc w '.frame) (conc w '.ok) :side "top" :fill "both") + + (entry (conc w '.frame.e1) :relief "sunken") + (entry (conc w '.frame.e2) :relief "sunken") + (entry (conc w '.frame.e3) :relief "sunken") + (pack (conc w '.frame.e1) (conc w '.frame.e2) (conc w '.frame.e3) :side "top" :pady 5 :fill "x") + + (funcall (conc w '.frame.e1) :insert 0 "Initial value") + (funcall (conc w '.frame.e2) :insert "end" "This entry contains a long value, much too long ") + (funcall (conc w '.frame.e2) :insert "end" "to fit in the window at one time, so long in fact ") + (funcall (conc w '.frame.e2) :insert "end" "that you'll have to scan or scroll to see the end.") +) diff --git a/gcl-tk/demos/mkEntry.tcl b/gcl-tk/demos/mkEntry.tcl new file mode 100755 index 0000000..da0266c --- /dev/null +++ b/gcl-tk/demos/mkEntry.tcl @@ -0,0 +1,29 @@ +# mkEntry w +# +# Create a top-level window that displays a bunch of entries. +# +# Arguments: +# w - Name to use for new top-level window. + +proc mkEntry {{w .e1}} { + catch {destroy $w} + toplevel $w + dpos $w + wm title $w "Entry Demonstration" + wm iconname $w "Entries" + message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 200 \ + -text "Three different entries are displayed below. You can add characters by pointing, clicking and typing. You can delete by selecting and typing Control-d. Backspace, Control-h, and Delete may be typed to erase the character just before the insertion point, Control-W erases the word just before the insertion point, and Control-u clears the entry. For entries that are too large to fit in the window all at once, you can scan through the entries by dragging with mouse button 2 pressed. Click the \"OK\" button when you've seen enough." + frame $w.frame -borderwidth 10 + button $w.ok -text OK -command "destroy $w" + pack $w.msg $w.frame $w.ok -side top -fill both + + entry $w.frame.e1 -relief sunken + entry $w.frame.e2 -relief sunken + entry $w.frame.e3 -relief sunken + pack $w.frame.e1 $w.frame.e2 $w.frame.e3 -side top -pady 5 -fill x + + $w.frame.e1 insert 0 "Initial value" + $w.frame.e2 insert end "This entry contains a long value, much too long " + $w.frame.e2 insert end "to fit in the window at one time, so long in fact " + $w.frame.e2 insert end "that you'll have to scan or scroll to see the end." +} diff --git a/gcl-tk/demos/mkEntry2.lisp b/gcl-tk/demos/mkEntry2.lisp new file mode 100755 index 0000000..82ab8ba --- /dev/null +++ b/gcl-tk/demos/mkEntry2.lisp @@ -0,0 +1,39 @@ +;;# mkEntry2 - +;; +;; Create a top-level window that displays a bunch of entries with +;; scrollbars. +;; +;; Arguments: +;; w - Name to use for new top-level window. +(IN-package "TK") +(defun mkEntry2 (&optional (w '.e2)) + (if (winfo :exists w :return 'boolean) (destroy w)) + (toplevel w) + (dpos w) + (wm :title w "Entry Demonstration") + (wm :iconname w "Entries") + (message (conc w '.msg) :font :Adobe-times-medium-r-normal--*-180* :aspect 200 + :text "Three different entries are displayed below, with a scrollbar for each entry. You can add characters by pointing, clicking and typing. You can delete by selecting and typing Control-d. Backspace, Control-h, and Delete may be typed to erase the character just before the insertion point, Control-W erases the word just before the insertion point, and Control-u clears the entry. For entries that are too large to fit in the window all at once, you can scan through the entries using the scrollbars, or by dragging with mouse button 2 pressed. Click the \"OK\" button when you've seen enough.") + (frame (conc w '.frame) :borderwidth 10) + (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) + (pack (conc w '.msg) (conc w '.frame) (conc w '.ok) :side "top" :fill "both") + + (entry (conc w '.frame.e1) :relief "sunken" :xscrollcommand (tk-conc w ".frame.s1 set")) + (scrollbar (conc w '.frame.s1) :relief "sunken" :orient "horiz" :command + (tk-conc w ".frame.e1 xview")) + (frame (conc w '.frame.f1) :width 20 :height 10) + (entry (conc w '.frame.e2) :relief "sunken" :xscrollcommand (tk-conc w ".frame.s2 set")) + (scrollbar (conc w '.frame.s2) :relief "sunken" :orient "horiz" :command + (tk-conc w ".frame.e2 xview")) + (frame (conc w '.frame.f2) :width 20 :height 10) + (entry (conc w '.frame.e3) :relief "sunken" :xscrollcommand (tk-conc w ".frame.s3 set")) + (scrollbar (conc w '.frame.s3) :relief "sunken" :orient "horiz" :command + (tk-conc w ".frame.e3 xview")) + (pack (conc w '.frame.e1) (conc w '.frame.s1) (conc w '.frame.f1) (conc w '.frame.e2) (conc w '.frame.s2) + (conc w '.frame.f2) (conc w '.frame.e3) (conc w '.frame.s3) :side "top" :fill "x") + + (funcall (conc w '.frame.e1) :insert 0 "Initial value") + (funcall (conc w '.frame.e2) :insert 'end "This entry contains a long value, much too long ") + (funcall (conc w '.frame.e2) :insert 'end "to fit in the window at one time, so long in fact ") + (funcall (conc w '.frame.e2) :insert 'end "that you'll have to scan or scroll to see the end.") +) diff --git a/gcl-tk/demos/mkEntry2.tcl b/gcl-tk/demos/mkEntry2.tcl new file mode 100755 index 0000000..306c410 --- /dev/null +++ b/gcl-tk/demos/mkEntry2.tcl @@ -0,0 +1,39 @@ +# mkEntry2 - +# +# Create a top-level window that displays a bunch of entries with +# scrollbars. +# +# Arguments: +# w - Name to use for new top-level window. + +proc mkEntry2 {{w .e2}} { + catch {destroy $w} + toplevel $w + dpos $w + wm title $w "Entry Demonstration" + wm iconname $w "Entries" + message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 200 \ + -text "Three different entries are displayed below, with a scrollbar for each entry. You can add characters by pointing, clicking and typing. You can delete by selecting and typing Control-d. Backspace, Control-h, and Delete may be typed to erase the character just before the insertion point, Control-W erases the word just before the insertion point, and Control-u clears the entry. For entries that are too large to fit in the window all at once, you can scan through the entries using the scrollbars, or by dragging with mouse button 2 pressed. Click the \"OK\" button when you've seen enough." + frame $w.frame -borderwidth 10 + button $w.ok -text OK -command "destroy $w" + pack $w.msg $w.frame $w.ok -side top -fill both + + entry $w.frame.e1 -relief sunken -xscrollcommand "$w.frame.s1 set" + scrollbar $w.frame.s1 -relief sunken -orient horiz -command \ + "$w.frame.e1 xview" + frame $w.frame.f1 + entry $w.frame.e2 -relief sunken -xscrollcommand "$w.frame.s2 set" + scrollbar $w.frame.s2 -relief sunken -orient horiz -command \ + "$w.frame.e2 xview" + frame $w.frame.f2 + entry $w.frame.e3 -relief sunken -xscrollcommand "$w.frame.s3 set" + scrollbar $w.frame.s3 -relief sunken -orient horiz -command \ + "$w.frame.e3 xview" + pack $w.frame.e1 $w.frame.s1 $w.frame.f1 $w.frame.e2 $w.frame.s2 \ + $w.frame.f2 $w.frame.e3 $w.frame.s3 -side top -fill x + + $w.frame.e1 insert 0 "Initial value" + $w.frame.e2 insert end "This entry contains a long value, much too long " + $w.frame.e2 insert end "to fit in the window at one time, so long in fact " + $w.frame.e2 insert end "that you'll have to scan or scroll to see the end." +} diff --git a/gcl-tk/demos/mkFloor.tcl b/gcl-tk/demos/mkFloor.tcl new file mode 100755 index 0000000..b033087 --- /dev/null +++ b/gcl-tk/demos/mkFloor.tcl @@ -0,0 +1,1276 @@ +# mkFloor w +# +# Create a top-level window containing a canvas that displays the +# floorplan for DEC's Western Research Laboratory. +# +# Arguments: +# w - Name to use for new top-level window. + +proc mkFloor {{w .cfloor}} { + global c tk_library currentRoom colors + catch {destroy $w} + toplevel $w +# dpos $w + wm title $w "Floorplan Canvas Demonstration" + wm iconname $w "Floorplan" + wm minsize $w 100 100 + set c $w.frame2.c + + message $w.msg -font *-Times-Medium-R-Normal-*-180-* -width 800 \ + -relief raised -bd 2 -text "This window contains a canvas widget showing the floorplan of Digital Equipment Corporation's Western Research Laboratory. It has three levels. At any given time one of the levels is active, meaning that you can see its room structure. To activate a level, click the left mouse button anywhere on it. As the mouse moves over the active level, the room under the mouse lights up and its room number appears in the \"Room:\" entry. You can also type a room number in the entry and the room will light up." + frame $w.frame2 -relief raised -bd 2 + button $w.ok -text "OK" -command "destroy $w" + pack $w.msg -side top -fill both + pack $w.frame2 -side top -fill both -expand yes + pack $w.ok -side bottom -pady 5 + + scrollbar $w.frame2.vscroll -relief sunken -command "$c yview" + scrollbar $w.frame2.hscroll -orient horiz -relief sunken -command "$c xview" + canvas $c -width 900 -height 500 -xscrollcommand "$w.frame2.hscroll set" \ + -yscrollcommand "$w.frame2.vscroll set" + pack $w.frame2.hscroll -side bottom -fill x + pack $w.frame2.vscroll -side right -fill y + pack $c -in $w.frame2 -expand yes -fill both + + # Create an entry for displaying and typing in current room. + + entry $c.entry -width 10 -relief sunken -bd 2 -textvariable currentRoom + + # Choose colors, then fill in the floorplan. + + if {[winfo depth $c] > 1} { + set colors(bg1) #c0a3db55dc28 + set colors(outline1) #70207f868000 + set colors(bg2) #aeb8c6eec7ad + set colors(outline2) #59b466056666 + set colors(bg3) #9cfab288b333 + set colors(outline3) #43474c834ccd + set colors(offices) Black + set colors(active) #dae0f278f332 + } else { + set colors(bg1) white + set colors(outline1) black + set colors(bg2) white + set colors(outline2) black + set colors(bg3) white + set colors(outline3) black + set colors(offices) Black + set colors(active) black + } + floorDisplay $c 3 + + # Set up event bindings for canvas: + + $c bind floor1 <1> "floorDisplay $c 1" + $c bind floor2 <1> "floorDisplay $c 2" + $c bind floor3 <1> "floorDisplay $c 3" + $c bind room \ + "set currentRoom \$floorLabels(\[$c find withtag current\]) + update idletasks" + $c bind room {set currentRoom ""} + bind $c <2> "$c scan mark %x %y" + bind $c "$c scan dragto %x %y" + bind $c "unset currentRoom" + bind $c "focus $c.entry" + set currentRoom "" + trace variable currentRoom w "roomChanged $c" +} + +set activeFloor "" + +# The following procedure recreates the floorplan display in the canvas +# given by "w". The floor given by "active" (1, 2, or 3) is displayed +# on top, with office structure visible. + +proc floorDisplay {w active} { + global floorLabels floorItems colors activeFloor + + if {$activeFloor == $active} { + return + } + + $w delete all + set activeFloor $active + + # First go through the three floors, displaying the backgrounds for + # each floor. + + bg1 $w $colors(bg1) $colors(outline1) + bg2 $w $colors(bg2) $colors(outline2) + bg3 $w $colors(bg3) $colors(outline3) + + # Raise the background for the active floor so that it's on top. + + $w raise floor$active + + # Create a dummy item just to mark this point in the display list, + # so we can insert highlights here. + + $w create rect 0 100 1 101 -fill {} -outline {} -tags marker + + # Add the walls and labels for the active floor, along with + # transparent polygons that define the rooms on the floor. + # Make sure that the room polygons are on top. + + catch {unset floorLabels} + catch {unset floorItems} + fg$active $w $colors(offices) + $w raise room + + # Offset the floors diagonally from each other. + + $w move floor1 2c 2c + $w move floor2 1c 1c + + # Create items for the room entry and its label. + + $w create window 600 100 -anchor w -window $w.entry + $w create text 600 100 -anchor e -text "Room: " + $w config -scrollregion [$w bbox all] +} + +# This procedure is invoked whenever the currentRoom variable changes. +# It highlights the current room and unhighlights any previous room. + +proc roomChanged {w args} { + global currentRoom floorItems colors + $w delete highlight + if [catch {set item $floorItems($currentRoom)}] { + return + } + set new [eval \ + "$w create polygon [$w coords $item] -fill $colors(active) \ + -tags highlight"] + $w raise $new marker +} + +# The following procedures are invoked to instantiate various portions +# of the building floorplan. The bodies of these procedures were +# generated automatically from database files describing the building. + +proc bg1 {w fill outline} { + $w create poly 347 80 349 82 351 84 353 85 363 92 375 99 386 104 \ + 386 129 398 129 398 162 484 162 484 129 559 129 559 133 725 \ + 133 725 129 802 129 802 389 644 389 644 391 559 391 559 327 \ + 508 327 508 311 484 311 484 278 395 278 395 288 400 288 404 \ + 288 409 290 413 292 418 297 421 302 422 309 421 318 417 325 \ + 411 330 405 332 397 333 344 333 340 334 336 336 335 338 332 \ + 342 331 347 332 351 334 354 336 357 341 359 340 360 335 363 \ + 331 365 326 366 304 366 304 355 258 355 258 387 60 387 60 391 \ + 0 391 0 337 3 337 3 114 8 114 8 25 30 25 30 5 93 5 98 5 104 7 \ + 110 10 116 16 119 20 122 28 123 32 123 68 220 68 220 34 221 \ + 22 223 17 227 13 231 8 236 4 242 2 246 0 260 0 283 1 300 5 \ + 321 14 335 22 348 25 365 29 363 39 358 48 352 56 337 70 \ + 344 76 347 80 \ + -tags {floor1 bg} -fill $fill + $w create line 386 129 398 129 -fill $outline -tags {floor1 bg} + $w create line 258 355 258 387 -fill $outline -tags {floor1 bg} + $w create line 60 387 60 391 -fill $outline -tags {floor1 bg} + $w create line 0 337 0 391 -fill $outline -tags {floor1 bg} + $w create line 60 391 0 391 -fill $outline -tags {floor1 bg} + $w create line 3 114 3 337 -fill $outline -tags {floor1 bg} + $w create line 258 387 60 387 -fill $outline -tags {floor1 bg} + $w create line 484 162 398 162 -fill $outline -tags {floor1 bg} + $w create line 398 162 398 129 -fill $outline -tags {floor1 bg} + $w create line 484 278 484 311 -fill $outline -tags {floor1 bg} + $w create line 484 311 508 311 -fill $outline -tags {floor1 bg} + $w create line 508 327 508 311 -fill $outline -tags {floor1 bg} + $w create line 559 327 508 327 -fill $outline -tags {floor1 bg} + $w create line 644 391 559 391 -fill $outline -tags {floor1 bg} + $w create line 644 389 644 391 -fill $outline -tags {floor1 bg} + $w create line 559 129 484 129 -fill $outline -tags {floor1 bg} + $w create line 484 162 484 129 -fill $outline -tags {floor1 bg} + $w create line 725 133 559 133 -fill $outline -tags {floor1 bg} + $w create line 559 129 559 133 -fill $outline -tags {floor1 bg} + $w create line 725 129 802 129 -fill $outline -tags {floor1 bg} + $w create line 802 389 802 129 -fill $outline -tags {floor1 bg} + $w create line 3 337 0 337 -fill $outline -tags {floor1 bg} + $w create line 559 391 559 327 -fill $outline -tags {floor1 bg} + $w create line 802 389 644 389 -fill $outline -tags {floor1 bg} + $w create line 725 133 725 129 -fill $outline -tags {floor1 bg} + $w create line 8 25 8 114 -fill $outline -tags {floor1 bg} + $w create line 8 114 3 114 -fill $outline -tags {floor1 bg} + $w create line 30 25 8 25 -fill $outline -tags {floor1 bg} + $w create line 484 278 395 278 -fill $outline -tags {floor1 bg} + $w create line 30 25 30 5 -fill $outline -tags {floor1 bg} + $w create line 93 5 30 5 -fill $outline -tags {floor1 bg} + $w create line 98 5 93 5 -fill $outline -tags {floor1 bg} + $w create line 104 7 98 5 -fill $outline -tags {floor1 bg} + $w create line 110 10 104 7 -fill $outline -tags {floor1 bg} + $w create line 116 16 110 10 -fill $outline -tags {floor1 bg} + $w create line 119 20 116 16 -fill $outline -tags {floor1 bg} + $w create line 122 28 119 20 -fill $outline -tags {floor1 bg} + $w create line 123 32 122 28 -fill $outline -tags {floor1 bg} + $w create line 123 68 123 32 -fill $outline -tags {floor1 bg} + $w create line 220 68 123 68 -fill $outline -tags {floor1 bg} + $w create line 386 129 386 104 -fill $outline -tags {floor1 bg} + $w create line 386 104 375 99 -fill $outline -tags {floor1 bg} + $w create line 375 99 363 92 -fill $outline -tags {floor1 bg} + $w create line 353 85 363 92 -fill $outline -tags {floor1 bg} + $w create line 220 68 220 34 -fill $outline -tags {floor1 bg} + $w create line 337 70 352 56 -fill $outline -tags {floor1 bg} + $w create line 352 56 358 48 -fill $outline -tags {floor1 bg} + $w create line 358 48 363 39 -fill $outline -tags {floor1 bg} + $w create line 363 39 365 29 -fill $outline -tags {floor1 bg} + $w create line 365 29 348 25 -fill $outline -tags {floor1 bg} + $w create line 348 25 335 22 -fill $outline -tags {floor1 bg} + $w create line 335 22 321 14 -fill $outline -tags {floor1 bg} + $w create line 321 14 300 5 -fill $outline -tags {floor1 bg} + $w create line 300 5 283 1 -fill $outline -tags {floor1 bg} + $w create line 283 1 260 0 -fill $outline -tags {floor1 bg} + $w create line 260 0 246 0 -fill $outline -tags {floor1 bg} + $w create line 246 0 242 2 -fill $outline -tags {floor1 bg} + $w create line 242 2 236 4 -fill $outline -tags {floor1 bg} + $w create line 236 4 231 8 -fill $outline -tags {floor1 bg} + $w create line 231 8 227 13 -fill $outline -tags {floor1 bg} + $w create line 223 17 227 13 -fill $outline -tags {floor1 bg} + $w create line 221 22 223 17 -fill $outline -tags {floor1 bg} + $w create line 220 34 221 22 -fill $outline -tags {floor1 bg} + $w create line 340 360 335 363 -fill $outline -tags {floor1 bg} + $w create line 335 363 331 365 -fill $outline -tags {floor1 bg} + $w create line 331 365 326 366 -fill $outline -tags {floor1 bg} + $w create line 326 366 304 366 -fill $outline -tags {floor1 bg} + $w create line 304 355 304 366 -fill $outline -tags {floor1 bg} + $w create line 395 288 400 288 -fill $outline -tags {floor1 bg} + $w create line 404 288 400 288 -fill $outline -tags {floor1 bg} + $w create line 409 290 404 288 -fill $outline -tags {floor1 bg} + $w create line 413 292 409 290 -fill $outline -tags {floor1 bg} + $w create line 418 297 413 292 -fill $outline -tags {floor1 bg} + $w create line 421 302 418 297 -fill $outline -tags {floor1 bg} + $w create line 422 309 421 302 -fill $outline -tags {floor1 bg} + $w create line 421 318 422 309 -fill $outline -tags {floor1 bg} + $w create line 421 318 417 325 -fill $outline -tags {floor1 bg} + $w create line 417 325 411 330 -fill $outline -tags {floor1 bg} + $w create line 411 330 405 332 -fill $outline -tags {floor1 bg} + $w create line 405 332 397 333 -fill $outline -tags {floor1 bg} + $w create line 397 333 344 333 -fill $outline -tags {floor1 bg} + $w create line 344 333 340 334 -fill $outline -tags {floor1 bg} + $w create line 340 334 336 336 -fill $outline -tags {floor1 bg} + $w create line 336 336 335 338 -fill $outline -tags {floor1 bg} + $w create line 335 338 332 342 -fill $outline -tags {floor1 bg} + $w create line 331 347 332 342 -fill $outline -tags {floor1 bg} + $w create line 332 351 331 347 -fill $outline -tags {floor1 bg} + $w create line 334 354 332 351 -fill $outline -tags {floor1 bg} + $w create line 336 357 334 354 -fill $outline -tags {floor1 bg} + $w create line 341 359 336 357 -fill $outline -tags {floor1 bg} + $w create line 341 359 340 360 -fill $outline -tags {floor1 bg} + $w create line 395 288 395 278 -fill $outline -tags {floor1 bg} + $w create line 304 355 258 355 -fill $outline -tags {floor1 bg} + $w create line 347 80 344 76 -fill $outline -tags {floor1 bg} + $w create line 344 76 337 70 -fill $outline -tags {floor1 bg} + $w create line 349 82 347 80 -fill $outline -tags {floor1 bg} + $w create line 351 84 349 82 -fill $outline -tags {floor1 bg} + $w create line 353 85 351 84 -fill $outline -tags {floor1 bg} +} + +proc bg2 {w fill outline} { + $w create poly 559 129 484 129 484 162 398 162 398 129 315 129 \ + 315 133 176 133 176 129 96 129 96 133 3 133 3 339 0 339 0 391 \ + 60 391 60 387 258 387 258 329 350 329 350 311 395 311 395 280 \ + 484 280 484 311 508 311 508 327 558 327 558 391 644 391 644 \ + 367 802 367 802 129 725 129 725 133 559 133 559 129 \ + -tags {floor2 bg} -fill $fill + $w create line 350 311 350 329 -fill $outline -tags {floor2 bg} + $w create line 398 129 398 162 -fill $outline -tags {floor2 bg} + $w create line 802 367 802 129 -fill $outline -tags {floor2 bg} + $w create line 802 129 725 129 -fill $outline -tags {floor2 bg} + $w create line 725 133 725 129 -fill $outline -tags {floor2 bg} + $w create line 559 129 559 133 -fill $outline -tags {floor2 bg} + $w create line 559 133 725 133 -fill $outline -tags {floor2 bg} + $w create line 484 162 484 129 -fill $outline -tags {floor2 bg} + $w create line 559 129 484 129 -fill $outline -tags {floor2 bg} + $w create line 802 367 644 367 -fill $outline -tags {floor2 bg} + $w create line 644 367 644 391 -fill $outline -tags {floor2 bg} + $w create line 644 391 558 391 -fill $outline -tags {floor2 bg} + $w create line 558 327 558 391 -fill $outline -tags {floor2 bg} + $w create line 558 327 508 327 -fill $outline -tags {floor2 bg} + $w create line 508 327 508 311 -fill $outline -tags {floor2 bg} + $w create line 484 311 508 311 -fill $outline -tags {floor2 bg} + $w create line 484 280 484 311 -fill $outline -tags {floor2 bg} + $w create line 398 162 484 162 -fill $outline -tags {floor2 bg} + $w create line 484 280 395 280 -fill $outline -tags {floor2 bg} + $w create line 395 280 395 311 -fill $outline -tags {floor2 bg} + $w create line 258 387 60 387 -fill $outline -tags {floor2 bg} + $w create line 3 133 3 339 -fill $outline -tags {floor2 bg} + $w create line 3 339 0 339 -fill $outline -tags {floor2 bg} + $w create line 60 391 0 391 -fill $outline -tags {floor2 bg} + $w create line 0 339 0 391 -fill $outline -tags {floor2 bg} + $w create line 60 387 60 391 -fill $outline -tags {floor2 bg} + $w create line 258 329 258 387 -fill $outline -tags {floor2 bg} + $w create line 350 329 258 329 -fill $outline -tags {floor2 bg} + $w create line 395 311 350 311 -fill $outline -tags {floor2 bg} + $w create line 398 129 315 129 -fill $outline -tags {floor2 bg} + $w create line 176 133 315 133 -fill $outline -tags {floor2 bg} + $w create line 176 129 96 129 -fill $outline -tags {floor2 bg} + $w create line 3 133 96 133 -fill $outline -tags {floor2 bg} + $w create line 315 133 315 129 -fill $outline -tags {floor2 bg} + $w create line 176 133 176 129 -fill $outline -tags {floor2 bg} + $w create line 96 133 96 129 -fill $outline -tags {floor2 bg} +} + +proc bg3 {w fill outline} { + $w create poly 159 300 107 300 107 248 159 248 159 129 96 129 96 \ + 133 21 133 21 331 0 331 0 391 60 391 60 370 159 370 159 300 \ + -tags {floor3 bg} -fill $fill + $w create poly 258 370 258 329 350 329 350 311 399 311 399 129 \ + 315 129 315 133 176 133 176 129 159 129 159 370 258 370 \ + -tags {floor3 bg} -fill $fill + $w create line 96 133 96 129 -fill $outline -tags {floor3 bg} + $w create line 176 129 96 129 -fill $outline -tags {floor3 bg} + $w create line 176 129 176 133 -fill $outline -tags {floor3 bg} + $w create line 315 133 176 133 -fill $outline -tags {floor3 bg} + $w create line 315 133 315 129 -fill $outline -tags {floor3 bg} + $w create line 399 129 315 129 -fill $outline -tags {floor3 bg} + $w create line 399 311 399 129 -fill $outline -tags {floor3 bg} + $w create line 399 311 350 311 -fill $outline -tags {floor3 bg} + $w create line 350 329 350 311 -fill $outline -tags {floor3 bg} + $w create line 350 329 258 329 -fill $outline -tags {floor3 bg} + $w create line 258 370 258 329 -fill $outline -tags {floor3 bg} + $w create line 60 370 258 370 -fill $outline -tags {floor3 bg} + $w create line 60 370 60 391 -fill $outline -tags {floor3 bg} + $w create line 60 391 0 391 -fill $outline -tags {floor3 bg} + $w create line 0 391 0 331 -fill $outline -tags {floor3 bg} + $w create line 21 331 0 331 -fill $outline -tags {floor3 bg} + $w create line 21 331 21 133 -fill $outline -tags {floor3 bg} + $w create line 96 133 21 133 -fill $outline -tags {floor3 bg} + $w create line 107 300 159 300 159 248 107 248 107 300 \ + -fill $outline -tags {floor3 bg} +} + +proc fg1 {w color} { + global floorLabels floorItems + set i [$w create polygon 375 246 375 172 341 172 341 246 -fill {} -tags {floor1 room}] + set floorLabels($i) 101 + set {floorItems(101)} $i + $w create text 358 209 -text 101 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 307 240 339 240 339 206 307 206 -fill {} -tags {floor1 room}] + set floorLabels($i) {Pub Lift1} + set {floorItems(Pub Lift1)} $i + $w create text 323 223 -text {Pub Lift1} -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 339 205 307 205 307 171 339 171 -fill {} -tags {floor1 room}] + set floorLabels($i) {Priv Lift1} + set {floorItems(Priv Lift1)} $i + $w create text 323 188 -text {Priv Lift1} -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 42 389 42 337 1 337 1 389 -fill {} -tags {floor1 room}] + set floorLabels($i) 110 + set {floorItems(110)} $i + $w create text 21.5 363 -text 110 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 59 389 59 385 90 385 90 337 44 337 44 389 -fill {} -tags {floor1 room}] + set floorLabels($i) 109 + set {floorItems(109)} $i + $w create text 67 363 -text 109 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 51 300 51 253 6 253 6 300 -fill {} -tags {floor1 room}] + set floorLabels($i) 111 + set {floorItems(111)} $i + $w create text 28.5 276.5 -text 111 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 98 248 98 309 79 309 79 248 -fill {} -tags {floor1 room}] + set floorLabels($i) 117B + set {floorItems(117B)} $i + $w create text 88.5 278.5 -text 117B -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 51 251 51 204 6 204 6 251 -fill {} -tags {floor1 room}] + set floorLabels($i) 112 + set {floorItems(112)} $i + $w create text 28.5 227.5 -text 112 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 6 156 51 156 51 203 6 203 -fill {} -tags {floor1 room}] + set floorLabels($i) 113 + set {floorItems(113)} $i + $w create text 28.5 179.5 -text 113 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 85 169 79 169 79 192 85 192 -fill {} -tags {floor1 room}] + set floorLabels($i) 117A + set {floorItems(117A)} $i + $w create text 82 180.5 -text 117A -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 77 302 77 168 53 168 53 302 -fill {} -tags {floor1 room}] + set floorLabels($i) 117 + set {floorItems(117)} $i + $w create text 65 235 -text 117 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 51 155 51 115 6 115 6 155 -fill {} -tags {floor1 room}] + set floorLabels($i) 114 + set {floorItems(114)} $i + $w create text 28.5 135 -text 114 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 95 115 53 115 53 168 95 168 -fill {} -tags {floor1 room}] + set floorLabels($i) 115 + set {floorItems(115)} $i + $w create text 74 141.5 -text 115 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 87 113 87 27 10 27 10 113 -fill {} -tags {floor1 room}] + set floorLabels($i) 116 + set {floorItems(116)} $i + $w create text 48.5 70 -text 116 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 89 91 128 91 128 113 89 113 -fill {} -tags {floor1 room}] + set floorLabels($i) 118 + set {floorItems(118)} $i + $w create text 108.5 102 -text 118 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 178 128 178 132 216 132 216 91 163 91 163 112 149 112 149 128 -fill {} -tags {floor1 room}] + set floorLabels($i) 120 + set {floorItems(120)} $i + $w create text 189.5 111.5 -text 120 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 79 193 87 193 87 169 136 169 136 192 156 192 156 169 175 169 175 246 79 246 -fill {} -tags {floor1 room}] + set floorLabels($i) 122 + set {floorItems(122)} $i + $w create text 131 207.5 -text 122 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 138 169 154 169 154 191 138 191 -fill {} -tags {floor1 room}] + set floorLabels($i) 121 + set {floorItems(121)} $i + $w create text 146 180 -text 121 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 99 300 126 300 126 309 99 309 -fill {} -tags {floor1 room}] + set floorLabels($i) 106A + set {floorItems(106A)} $i + $w create text 112.5 304.5 -text 106A -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 128 299 128 309 150 309 150 248 99 248 99 299 -fill {} -tags {floor1 room}] + set floorLabels($i) 105 + set {floorItems(105)} $i + $w create text 124.5 278.5 -text 105 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 174 309 174 300 152 300 152 309 -fill {} -tags {floor1 room}] + set floorLabels($i) 106B + set {floorItems(106B)} $i + $w create text 163 304.5 -text 106B -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 176 299 176 309 216 309 216 248 152 248 152 299 -fill {} -tags {floor1 room}] + set floorLabels($i) 104 + set {floorItems(104)} $i + $w create text 184 278.5 -text 104 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 138 385 138 337 91 337 91 385 -fill {} -tags {floor1 room}] + set floorLabels($i) 108 + set {floorItems(108)} $i + $w create text 114.5 361 -text 108 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 256 337 140 337 140 385 256 385 -fill {} -tags {floor1 room}] + set floorLabels($i) 107 + set {floorItems(107)} $i + $w create text 198 361 -text 107 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 300 353 300 329 260 329 260 353 -fill {} -tags {floor1 room}] + set floorLabels($i) Smoking + set {floorItems(Smoking)} $i + $w create text 280 341 -text Smoking -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 314 135 314 170 306 170 306 246 177 246 177 135 -fill {} -tags {floor1 room}] + set floorLabels($i) 123 + set {floorItems(123)} $i + $w create text 245.5 190.5 -text 123 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 217 248 301 248 301 326 257 326 257 310 217 310 -fill {} -tags {floor1 room}] + set floorLabels($i) 103 + set {floorItems(103)} $i + $w create text 259 287 -text 103 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 396 188 377 188 377 169 316 169 316 131 396 131 -fill {} -tags {floor1 room}] + set floorLabels($i) 124 + set {floorItems(124)} $i + $w create text 356 150 -text 124 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 397 226 407 226 407 189 377 189 377 246 397 246 -fill {} -tags {floor1 room}] + set floorLabels($i) 125 + set {floorItems(125)} $i + $w create text 392 217.5 -text 125 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 399 187 409 187 409 207 474 207 474 164 399 164 -fill {} -tags {floor1 room}] + set floorLabels($i) 126 + set {floorItems(126)} $i + $w create text 436.5 185.5 -text 126 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 409 209 409 229 399 229 399 253 486 253 486 239 474 239 474 209 -fill {} -tags {floor1 room}] + set floorLabels($i) 127 + set {floorItems(127)} $i + $w create text 436.5 231 -text 127 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 501 164 501 174 495 174 495 188 490 188 490 204 476 204 476 164 -fill {} -tags {floor1 room}] + set floorLabels($i) MShower + set {floorItems(MShower)} $i + $w create text 488.5 184 -text MShower -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 497 176 513 176 513 204 492 204 492 190 497 190 -fill {} -tags {floor1 room}] + set floorLabels($i) Closet + set {floorItems(Closet)} $i + $w create text 502.5 190 -text Closet -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 476 237 476 206 513 206 513 254 488 254 488 237 -fill {} -tags {floor1 room}] + set floorLabels($i) WShower + set {floorItems(WShower)} $i + $w create text 494.5 230 -text WShower -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 486 131 558 131 558 135 724 135 724 166 697 166 697 275 553 275 531 254 515 254 515 174 503 174 503 161 486 161 -fill {} -tags {floor1 room}] + set floorLabels($i) 130 + set {floorItems(130)} $i + $w create text 638.5 205 -text 130 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 308 242 339 242 339 248 342 248 342 246 397 246 397 276 393 276 393 309 300 309 300 248 308 248 -fill {} -tags {floor1 room}] + set floorLabels($i) 102 + set {floorItems(102)} $i + $w create text 367.5 278.5 -text 102 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 397 255 486 255 486 276 397 276 -fill {} -tags {floor1 room}] + set floorLabels($i) 128 + set {floorItems(128)} $i + $w create text 441.5 265.5 -text 128 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 510 309 486 309 486 255 530 255 552 277 561 277 561 325 510 325 -fill {} -tags {floor1 room}] + set floorLabels($i) 129 + set {floorItems(129)} $i + $w create text 535.5 293 -text 129 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 696 281 740 281 740 387 642 387 642 389 561 389 561 277 696 277 -fill {} -tags {floor1 room}] + set floorLabels($i) 133 + set {floorItems(133)} $i + $w create text 628.5 335 -text 133 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 742 387 742 281 800 281 800 387 -fill {} -tags {floor1 room}] + set floorLabels($i) 132 + set {floorItems(132)} $i + $w create text 771 334 -text 132 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 800 168 800 280 699 280 699 168 -fill {} -tags {floor1 room}] + set floorLabels($i) 134 + set {floorItems(134)} $i + $w create text 749.5 224 -text 134 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 726 131 726 166 800 166 800 131 -fill {} -tags {floor1 room}] + set floorLabels($i) 135 + set {floorItems(135)} $i + $w create text 763 148.5 -text 135 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 340 360 335 363 331 365 326 366 304 366 304 312 396 312 396 288 400 288 404 288 409 290 413 292 418 297 421 302 422 309 421 318 417 325 411 330 405 332 397 333 344 333 340 334 336 336 335 338 332 342 331 347 332 351 334 354 336 357 341 359 -fill {} -tags {floor1 room}] + set floorLabels($i) {Ramona Stair} + set {floorItems(Ramona Stair)} $i + $w create text 368 323 -text {Ramona Stair} -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 30 23 30 5 93 5 98 5 104 7 110 10 116 16 119 20 122 28 123 32 123 68 220 68 220 87 90 87 90 23 -fill {} -tags {floor1 room}] + set floorLabels($i) {University Stair} + set {floorItems(University Stair)} $i + $w create text 155 77.5 -text {University Stair} -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 282 37 295 40 312 49 323 56 337 70 352 56 358 48 363 39 365 29 348 25 335 22 321 14 300 5 283 1 260 0 246 0 242 2 236 4 231 8 227 13 223 17 221 22 220 34 260 34 -fill {} -tags {floor1 room}] + set floorLabels($i) {Plaza Stair} + set {floorItems(Plaza Stair)} $i + $w create text 317.5 28.5 -text {Plaza Stair} -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 220 34 260 34 282 37 295 40 312 49 323 56 337 70 350 83 365 94 377 100 386 104 386 128 220 128 -fill {} -tags {floor1 room}] + set floorLabels($i) {Plaza Deck} + set {floorItems(Plaza Deck)} $i + $w create text 303 81 -text {Plaza Deck} -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 257 336 77 336 6 336 6 301 77 301 77 310 257 310 -fill {} -tags {floor1 room}] + set floorLabels($i) 106 + set {floorItems(106)} $i + $w create text 131.5 318.5 -text 106 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 146 110 162 110 162 91 130 91 130 115 95 115 95 128 114 128 114 151 157 151 157 153 112 153 112 130 97 130 97 168 175 168 175 131 146 131 -fill {} -tags {floor1 room}] + set floorLabels($i) 119 + set {floorItems(119)} $i + $w create text 143.5 133 -text 119 -fill $color -anchor c -tags {floor1 label} + $w create line 155 191 155 189 -fill $color -tags {floor1 wall} + $w create line 155 177 155 169 -fill $color -tags {floor1 wall} + $w create line 96 129 96 169 -fill $color -tags {floor1 wall} + $w create line 78 169 176 169 -fill $color -tags {floor1 wall} + $w create line 176 247 176 129 -fill $color -tags {floor1 wall} + $w create line 340 206 307 206 -fill $color -tags {floor1 wall} + $w create line 340 187 340 170 -fill $color -tags {floor1 wall} + $w create line 340 210 340 201 -fill $color -tags {floor1 wall} + $w create line 340 247 340 224 -fill $color -tags {floor1 wall} + $w create line 340 241 307 241 -fill $color -tags {floor1 wall} + $w create line 376 246 376 170 -fill $color -tags {floor1 wall} + $w create line 307 247 307 170 -fill $color -tags {floor1 wall} + $w create line 376 170 307 170 -fill $color -tags {floor1 wall} + $w create line 315 129 315 170 -fill $color -tags {floor1 wall} + $w create line 147 129 176 129 -fill $color -tags {floor1 wall} + $w create line 202 133 176 133 -fill $color -tags {floor1 wall} + $w create line 398 129 315 129 -fill $color -tags {floor1 wall} + $w create line 258 352 258 387 -fill $color -tags {floor1 wall} + $w create line 60 387 60 391 -fill $color -tags {floor1 wall} + $w create line 0 337 0 391 -fill $color -tags {floor1 wall} + $w create line 60 391 0 391 -fill $color -tags {floor1 wall} + $w create line 3 114 3 337 -fill $color -tags {floor1 wall} + $w create line 258 387 60 387 -fill $color -tags {floor1 wall} + $w create line 52 237 52 273 -fill $color -tags {floor1 wall} + $w create line 52 189 52 225 -fill $color -tags {floor1 wall} + $w create line 52 140 52 177 -fill $color -tags {floor1 wall} + $w create line 395 306 395 311 -fill $color -tags {floor1 wall} + $w create line 531 254 398 254 -fill $color -tags {floor1 wall} + $w create line 475 178 475 238 -fill $color -tags {floor1 wall} + $w create line 502 162 398 162 -fill $color -tags {floor1 wall} + $w create line 398 129 398 188 -fill $color -tags {floor1 wall} + $w create line 383 188 376 188 -fill $color -tags {floor1 wall} + $w create line 408 188 408 194 -fill $color -tags {floor1 wall} + $w create line 398 227 398 254 -fill $color -tags {floor1 wall} + $w create line 408 227 398 227 -fill $color -tags {floor1 wall} + $w create line 408 222 408 227 -fill $color -tags {floor1 wall} + $w create line 408 206 408 210 -fill $color -tags {floor1 wall} + $w create line 408 208 475 208 -fill $color -tags {floor1 wall} + $w create line 484 278 484 311 -fill $color -tags {floor1 wall} + $w create line 484 311 508 311 -fill $color -tags {floor1 wall} + $w create line 508 327 508 311 -fill $color -tags {floor1 wall} + $w create line 559 327 508 327 -fill $color -tags {floor1 wall} + $w create line 644 391 559 391 -fill $color -tags {floor1 wall} + $w create line 644 389 644 391 -fill $color -tags {floor1 wall} + $w create line 514 205 475 205 -fill $color -tags {floor1 wall} + $w create line 496 189 496 187 -fill $color -tags {floor1 wall} + $w create line 559 129 484 129 -fill $color -tags {floor1 wall} + $w create line 484 162 484 129 -fill $color -tags {floor1 wall} + $w create line 725 133 559 133 -fill $color -tags {floor1 wall} + $w create line 559 129 559 133 -fill $color -tags {floor1 wall} + $w create line 725 149 725 167 -fill $color -tags {floor1 wall} + $w create line 725 129 802 129 -fill $color -tags {floor1 wall} + $w create line 802 389 802 129 -fill $color -tags {floor1 wall} + $w create line 739 167 802 167 -fill $color -tags {floor1 wall} + $w create line 396 188 408 188 -fill $color -tags {floor1 wall} + $w create line 0 337 9 337 -fill $color -tags {floor1 wall} + $w create line 58 337 21 337 -fill $color -tags {floor1 wall} + $w create line 43 391 43 337 -fill $color -tags {floor1 wall} + $w create line 105 337 75 337 -fill $color -tags {floor1 wall} + $w create line 91 387 91 337 -fill $color -tags {floor1 wall} + $w create line 154 337 117 337 -fill $color -tags {floor1 wall} + $w create line 139 387 139 337 -fill $color -tags {floor1 wall} + $w create line 227 337 166 337 -fill $color -tags {floor1 wall} + $w create line 258 337 251 337 -fill $color -tags {floor1 wall} + $w create line 258 328 302 328 -fill $color -tags {floor1 wall} + $w create line 302 355 302 311 -fill $color -tags {floor1 wall} + $w create line 395 311 302 311 -fill $color -tags {floor1 wall} + $w create line 484 278 395 278 -fill $color -tags {floor1 wall} + $w create line 395 294 395 278 -fill $color -tags {floor1 wall} + $w create line 473 278 473 275 -fill $color -tags {floor1 wall} + $w create line 473 256 473 254 -fill $color -tags {floor1 wall} + $w create line 533 257 531 254 -fill $color -tags {floor1 wall} + $w create line 553 276 551 274 -fill $color -tags {floor1 wall} + $w create line 698 276 553 276 -fill $color -tags {floor1 wall} + $w create line 559 391 559 327 -fill $color -tags {floor1 wall} + $w create line 802 389 644 389 -fill $color -tags {floor1 wall} + $w create line 741 314 741 389 -fill $color -tags {floor1 wall} + $w create line 698 280 698 167 -fill $color -tags {floor1 wall} + $w create line 707 280 698 280 -fill $color -tags {floor1 wall} + $w create line 802 280 731 280 -fill $color -tags {floor1 wall} + $w create line 741 280 741 302 -fill $color -tags {floor1 wall} + $w create line 698 167 727 167 -fill $color -tags {floor1 wall} + $w create line 725 137 725 129 -fill $color -tags {floor1 wall} + $w create line 514 254 514 175 -fill $color -tags {floor1 wall} + $w create line 496 175 514 175 -fill $color -tags {floor1 wall} + $w create line 502 175 502 162 -fill $color -tags {floor1 wall} + $w create line 475 166 475 162 -fill $color -tags {floor1 wall} + $w create line 496 176 496 175 -fill $color -tags {floor1 wall} + $w create line 491 189 496 189 -fill $color -tags {floor1 wall} + $w create line 491 205 491 189 -fill $color -tags {floor1 wall} + $w create line 487 238 475 238 -fill $color -tags {floor1 wall} + $w create line 487 240 487 238 -fill $color -tags {floor1 wall} + $w create line 487 252 487 254 -fill $color -tags {floor1 wall} + $w create line 315 133 304 133 -fill $color -tags {floor1 wall} + $w create line 256 133 280 133 -fill $color -tags {floor1 wall} + $w create line 78 247 270 247 -fill $color -tags {floor1 wall} + $w create line 307 247 294 247 -fill $color -tags {floor1 wall} + $w create line 214 133 232 133 -fill $color -tags {floor1 wall} + $w create line 217 247 217 266 -fill $color -tags {floor1 wall} + $w create line 217 309 217 291 -fill $color -tags {floor1 wall} + $w create line 217 309 172 309 -fill $color -tags {floor1 wall} + $w create line 154 309 148 309 -fill $color -tags {floor1 wall} + $w create line 175 300 175 309 -fill $color -tags {floor1 wall} + $w create line 151 300 175 300 -fill $color -tags {floor1 wall} + $w create line 151 247 151 309 -fill $color -tags {floor1 wall} + $w create line 78 237 78 265 -fill $color -tags {floor1 wall} + $w create line 78 286 78 309 -fill $color -tags {floor1 wall} + $w create line 106 309 78 309 -fill $color -tags {floor1 wall} + $w create line 130 309 125 309 -fill $color -tags {floor1 wall} + $w create line 99 309 99 247 -fill $color -tags {floor1 wall} + $w create line 127 299 99 299 -fill $color -tags {floor1 wall} + $w create line 127 309 127 299 -fill $color -tags {floor1 wall} + $w create line 155 191 137 191 -fill $color -tags {floor1 wall} + $w create line 137 169 137 191 -fill $color -tags {floor1 wall} + $w create line 78 171 78 169 -fill $color -tags {floor1 wall} + $w create line 78 190 78 218 -fill $color -tags {floor1 wall} + $w create line 86 192 86 169 -fill $color -tags {floor1 wall} + $w create line 86 192 78 192 -fill $color -tags {floor1 wall} + $w create line 52 301 3 301 -fill $color -tags {floor1 wall} + $w create line 52 286 52 301 -fill $color -tags {floor1 wall} + $w create line 52 252 3 252 -fill $color -tags {floor1 wall} + $w create line 52 203 3 203 -fill $color -tags {floor1 wall} + $w create line 3 156 52 156 -fill $color -tags {floor1 wall} + $w create line 8 25 8 114 -fill $color -tags {floor1 wall} + $w create line 63 114 3 114 -fill $color -tags {floor1 wall} + $w create line 75 114 97 114 -fill $color -tags {floor1 wall} + $w create line 108 114 129 114 -fill $color -tags {floor1 wall} + $w create line 129 114 129 89 -fill $color -tags {floor1 wall} + $w create line 52 114 52 128 -fill $color -tags {floor1 wall} + $w create line 132 89 88 89 -fill $color -tags {floor1 wall} + $w create line 88 25 88 89 -fill $color -tags {floor1 wall} + $w create line 88 114 88 89 -fill $color -tags {floor1 wall} + $w create line 218 89 144 89 -fill $color -tags {floor1 wall} + $w create line 147 111 147 129 -fill $color -tags {floor1 wall} + $w create line 162 111 147 111 -fill $color -tags {floor1 wall} + $w create line 162 109 162 111 -fill $color -tags {floor1 wall} + $w create line 162 96 162 89 -fill $color -tags {floor1 wall} + $w create line 218 89 218 94 -fill $color -tags {floor1 wall} + $w create line 218 89 218 119 -fill $color -tags {floor1 wall} + $w create line 8 25 88 25 -fill $color -tags {floor1 wall} + $w create line 258 337 258 328 -fill $color -tags {floor1 wall} + $w create line 113 129 96 129 -fill $color -tags {floor1 wall} + $w create line 302 355 258 355 -fill $color -tags {floor1 wall} + $w create line 386 104 386 129 -fill $color -tags {floor1 wall} + $w create line 377 100 386 104 -fill $color -tags {floor1 wall} + $w create line 365 94 377 100 -fill $color -tags {floor1 wall} + $w create line 350 83 365 94 -fill $color -tags {floor1 wall} + $w create line 337 70 350 83 -fill $color -tags {floor1 wall} + $w create line 337 70 323 56 -fill $color -tags {floor1 wall} + $w create line 312 49 323 56 -fill $color -tags {floor1 wall} + $w create line 295 40 312 49 -fill $color -tags {floor1 wall} + $w create line 282 37 295 40 -fill $color -tags {floor1 wall} + $w create line 260 34 282 37 -fill $color -tags {floor1 wall} + $w create line 253 34 260 34 -fill $color -tags {floor1 wall} + $w create line 386 128 386 104 -fill $color -tags {floor1 wall} + $w create line 113 152 156 152 -fill $color -tags {floor1 wall} + $w create line 113 152 156 152 -fill $color -tags {floor1 wall} + $w create line 113 152 113 129 -fill $color -tags {floor1 wall} +} + +proc fg2 {w color} { + global floorLabels floorItems + set i [$w create polygon 748 188 755 188 755 205 758 205 758 222 800 222 800 168 748 168 -fill {} -tags {floor2 room}] + set floorLabels($i) 238 + set {floorItems(238)} $i + $w create text 774 195 -text 238 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 726 188 746 188 746 166 800 166 800 131 726 131 -fill {} -tags {floor2 room}] + set floorLabels($i) 237 + set {floorItems(237)} $i + $w create text 763 148.5 -text 237 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 497 187 497 204 559 204 559 324 641 324 643 324 643 291 641 291 641 205 696 205 696 291 694 291 694 314 715 314 715 291 715 205 755 205 755 190 724 190 724 187 -fill {} -tags {floor2 room}] + set floorLabels($i) 246 + set {floorItems(246)} $i + $w create text 600 264 -text 246 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 694 279 643 279 643 314 694 314 -fill {} -tags {floor2 room}] + set floorLabels($i) 247 + set {floorItems(247)} $i + $w create text 668.5 296.5 -text 247 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 232 250 308 250 308 242 339 242 339 246 397 246 397 255 476 255 476 250 482 250 559 250 559 274 482 274 482 278 396 278 396 274 232 274 -fill {} -tags {floor2 room}] + set floorLabels($i) 202 + set {floorItems(202)} $i + $w create text 285.5 260 -text 202 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 53 228 53 338 176 338 233 338 233 196 306 196 306 180 175 180 175 169 156 169 156 196 176 196 176 228 -fill {} -tags {floor2 room}] + set floorLabels($i) 206 + set {floorItems(206)} $i + $w create text 143 267 -text 206 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 51 277 6 277 6 338 51 338 -fill {} -tags {floor2 room}] + set floorLabels($i) 212 + set {floorItems(212)} $i + $w create text 28.5 307.5 -text 212 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 557 276 486 276 486 309 510 309 510 325 557 325 -fill {} -tags {floor2 room}] + set floorLabels($i) 245 + set {floorItems(245)} $i + $w create text 521.5 300.5 -text 245 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 560 389 599 389 599 326 560 326 -fill {} -tags {floor2 room}] + set floorLabels($i) 244 + set {floorItems(244)} $i + $w create text 579.5 357.5 -text 244 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 601 389 601 326 643 326 643 389 -fill {} -tags {floor2 room}] + set floorLabels($i) 243 + set {floorItems(243)} $i + $w create text 622 357.5 -text 243 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 688 316 645 316 645 365 688 365 -fill {} -tags {floor2 room}] + set floorLabels($i) 242 + set {floorItems(242)} $i + $w create text 666.5 340.5 -text 242 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 802 367 759 367 759 226 802 226 -fill {} -tags {floor2 room}] + set floorLabels($i) {Barbecue Deck} + set {floorItems(Barbecue Deck)} $i + $w create text 780.5 296.5 -text {Barbecue Deck} -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 755 262 755 314 717 314 717 262 -fill {} -tags {floor2 room}] + set floorLabels($i) 240 + set {floorItems(240)} $i + $w create text 736 288 -text 240 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 755 316 689 316 689 365 755 365 -fill {} -tags {floor2 room}] + set floorLabels($i) 241 + set {floorItems(241)} $i + $w create text 722 340.5 -text 241 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 755 206 717 206 717 261 755 261 -fill {} -tags {floor2 room}] + set floorLabels($i) 239 + set {floorItems(239)} $i + $w create text 736 233.5 -text 239 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 695 277 643 277 643 206 695 206 -fill {} -tags {floor2 room}] + set floorLabels($i) 248 + set {floorItems(248)} $i + $w create text 669 241.5 -text 248 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 676 135 676 185 724 185 724 135 -fill {} -tags {floor2 room}] + set floorLabels($i) 236 + set {floorItems(236)} $i + $w create text 700 160 -text 236 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 675 135 635 135 635 145 628 145 628 185 675 185 -fill {} -tags {floor2 room}] + set floorLabels($i) 235 + set {floorItems(235)} $i + $w create text 651.5 160 -text 235 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 626 143 633 143 633 135 572 135 572 143 579 143 579 185 626 185 -fill {} -tags {floor2 room}] + set floorLabels($i) 234 + set {floorItems(234)} $i + $w create text 606 160 -text 234 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 557 135 571 135 571 145 578 145 578 185 527 185 527 131 557 131 -fill {} -tags {floor2 room}] + set floorLabels($i) 233 + set {floorItems(233)} $i + $w create text 552.5 158 -text 233 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 476 249 557 249 557 205 476 205 -fill {} -tags {floor2 room}] + set floorLabels($i) 230 + set {floorItems(230)} $i + $w create text 516.5 227 -text 230 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 476 164 486 164 486 131 525 131 525 185 476 185 -fill {} -tags {floor2 room}] + set floorLabels($i) 232 + set {floorItems(232)} $i + $w create text 500.5 158 -text 232 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 476 186 495 186 495 204 476 204 -fill {} -tags {floor2 room}] + set floorLabels($i) 229 + set {floorItems(229)} $i + $w create text 485.5 195 -text 229 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 474 207 409 207 409 187 399 187 399 164 474 164 -fill {} -tags {floor2 room}] + set floorLabels($i) 227 + set {floorItems(227)} $i + $w create text 436.5 185.5 -text 227 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 399 228 399 253 474 253 474 209 409 209 409 228 -fill {} -tags {floor2 room}] + set floorLabels($i) 228 + set {floorItems(228)} $i + $w create text 436.5 231 -text 228 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 397 246 397 226 407 226 407 189 377 189 377 246 -fill {} -tags {floor2 room}] + set floorLabels($i) 226 + set {floorItems(226)} $i + $w create text 392 217.5 -text 226 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 377 169 316 169 316 131 397 131 397 188 377 188 -fill {} -tags {floor2 room}] + set floorLabels($i) 225 + set {floorItems(225)} $i + $w create text 356.5 150 -text 225 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 234 198 306 198 306 249 234 249 -fill {} -tags {floor2 room}] + set floorLabels($i) 224 + set {floorItems(224)} $i + $w create text 270 223.5 -text 224 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 270 179 306 179 306 170 314 170 314 135 270 135 -fill {} -tags {floor2 room}] + set floorLabels($i) 223 + set {floorItems(223)} $i + $w create text 292 157 -text 223 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 268 179 221 179 221 135 268 135 -fill {} -tags {floor2 room}] + set floorLabels($i) 222 + set {floorItems(222)} $i + $w create text 244.5 157 -text 222 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 177 179 219 179 219 135 177 135 -fill {} -tags {floor2 room}] + set floorLabels($i) 221 + set {floorItems(221)} $i + $w create text 198 157 -text 221 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 299 327 349 327 349 284 341 284 341 276 299 276 -fill {} -tags {floor2 room}] + set floorLabels($i) 204 + set {floorItems(204)} $i + $w create text 324 301.5 -text 204 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 234 276 297 276 297 327 257 327 257 338 234 338 -fill {} -tags {floor2 room}] + set floorLabels($i) 205 + set {floorItems(205)} $i + $w create text 265.5 307 -text 205 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 256 385 256 340 212 340 212 385 -fill {} -tags {floor2 room}] + set floorLabels($i) 207 + set {floorItems(207)} $i + $w create text 234 362.5 -text 207 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 210 340 164 340 164 385 210 385 -fill {} -tags {floor2 room}] + set floorLabels($i) 208 + set {floorItems(208)} $i + $w create text 187 362.5 -text 208 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 115 340 162 340 162 385 115 385 -fill {} -tags {floor2 room}] + set floorLabels($i) 209 + set {floorItems(209)} $i + $w create text 138.5 362.5 -text 209 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 89 228 89 156 53 156 53 228 -fill {} -tags {floor2 room}] + set floorLabels($i) 217 + set {floorItems(217)} $i + $w create text 71 192 -text 217 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 89 169 97 169 97 190 89 190 -fill {} -tags {floor2 room}] + set floorLabels($i) 217A + set {floorItems(217A)} $i + $w create text 93 179.5 -text 217A -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 89 156 89 168 95 168 95 135 53 135 53 156 -fill {} -tags {floor2 room}] + set floorLabels($i) 216 + set {floorItems(216)} $i + $w create text 71 145.5 -text 216 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 51 179 51 135 6 135 6 179 -fill {} -tags {floor2 room}] + set floorLabels($i) 215 + set {floorItems(215)} $i + $w create text 28.5 157 -text 215 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 51 227 6 227 6 180 51 180 -fill {} -tags {floor2 room}] + set floorLabels($i) 214 + set {floorItems(214)} $i + $w create text 28.5 203.5 -text 214 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 51 275 6 275 6 229 51 229 -fill {} -tags {floor2 room}] + set floorLabels($i) 213 + set {floorItems(213)} $i + $w create text 28.5 252 -text 213 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 114 340 67 340 67 385 114 385 -fill {} -tags {floor2 room}] + set floorLabels($i) 210 + set {floorItems(210)} $i + $w create text 90.5 362.5 -text 210 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 59 389 59 385 65 385 65 340 1 340 1 389 -fill {} -tags {floor2 room}] + set floorLabels($i) 211 + set {floorItems(211)} $i + $w create text 33 364.5 -text 211 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 393 309 350 309 350 282 342 282 342 276 393 276 -fill {} -tags {floor2 room}] + set floorLabels($i) 203 + set {floorItems(203)} $i + $w create text 367.5 292.5 -text 203 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 99 191 91 191 91 226 174 226 174 198 154 198 154 192 109 192 109 169 99 169 -fill {} -tags {floor2 room}] + set floorLabels($i) 220 + set {floorItems(220)} $i + $w create text 132.5 208.5 -text 220 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 339 205 307 205 307 171 339 171 -fill {} -tags {floor2 room}] + set floorLabels($i) {Priv Lift2} + set {floorItems(Priv Lift2)} $i + $w create text 323 188 -text {Priv Lift2} -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 307 240 339 240 339 206 307 206 -fill {} -tags {floor2 room}] + set floorLabels($i) {Pub Lift 2} + set {floorItems(Pub Lift 2)} $i + $w create text 323 223 -text {Pub Lift 2} -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 175 168 97 168 97 131 175 131 -fill {} -tags {floor2 room}] + set floorLabels($i) 218 + set {floorItems(218)} $i + $w create text 136 149.5 -text 218 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 154 191 111 191 111 169 154 169 -fill {} -tags {floor2 room}] + set floorLabels($i) 219 + set {floorItems(219)} $i + $w create text 132.5 180 -text 219 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 375 246 375 172 341 172 341 246 -fill {} -tags {floor2 room}] + set floorLabels($i) 201 + set {floorItems(201)} $i + $w create text 358 209 -text 201 -fill $color -anchor c -tags {floor2 label} + $w create line 641 186 678 186 -fill $color -tags {floor2 wall} + $w create line 757 350 757 367 -fill $color -tags {floor2 wall} + $w create line 634 133 634 144 -fill $color -tags {floor2 wall} + $w create line 634 144 627 144 -fill $color -tags {floor2 wall} + $w create line 572 133 572 144 -fill $color -tags {floor2 wall} + $w create line 572 144 579 144 -fill $color -tags {floor2 wall} + $w create line 398 129 398 162 -fill $color -tags {floor2 wall} + $w create line 174 197 175 197 -fill $color -tags {floor2 wall} + $w create line 175 197 175 227 -fill $color -tags {floor2 wall} + $w create line 757 206 757 221 -fill $color -tags {floor2 wall} + $w create line 396 188 408 188 -fill $color -tags {floor2 wall} + $w create line 727 189 725 189 -fill $color -tags {floor2 wall} + $w create line 747 167 802 167 -fill $color -tags {floor2 wall} + $w create line 747 167 747 189 -fill $color -tags {floor2 wall} + $w create line 755 189 739 189 -fill $color -tags {floor2 wall} + $w create line 769 224 757 224 -fill $color -tags {floor2 wall} + $w create line 802 224 802 129 -fill $color -tags {floor2 wall} + $w create line 802 129 725 129 -fill $color -tags {floor2 wall} + $w create line 725 189 725 129 -fill $color -tags {floor2 wall} + $w create line 725 186 690 186 -fill $color -tags {floor2 wall} + $w create line 676 133 676 186 -fill $color -tags {floor2 wall} + $w create line 627 144 627 186 -fill $color -tags {floor2 wall} + $w create line 629 186 593 186 -fill $color -tags {floor2 wall} + $w create line 579 144 579 186 -fill $color -tags {floor2 wall} + $w create line 559 129 559 133 -fill $color -tags {floor2 wall} + $w create line 725 133 559 133 -fill $color -tags {floor2 wall} + $w create line 484 162 484 129 -fill $color -tags {floor2 wall} + $w create line 559 129 484 129 -fill $color -tags {floor2 wall} + $w create line 526 129 526 186 -fill $color -tags {floor2 wall} + $w create line 540 186 581 186 -fill $color -tags {floor2 wall} + $w create line 528 186 523 186 -fill $color -tags {floor2 wall} + $w create line 511 186 475 186 -fill $color -tags {floor2 wall} + $w create line 496 190 496 186 -fill $color -tags {floor2 wall} + $w create line 496 205 496 202 -fill $color -tags {floor2 wall} + $w create line 475 205 527 205 -fill $color -tags {floor2 wall} + $w create line 558 205 539 205 -fill $color -tags {floor2 wall} + $w create line 558 205 558 249 -fill $color -tags {floor2 wall} + $w create line 558 249 475 249 -fill $color -tags {floor2 wall} + $w create line 662 206 642 206 -fill $color -tags {floor2 wall} + $w create line 695 206 675 206 -fill $color -tags {floor2 wall} + $w create line 695 278 642 278 -fill $color -tags {floor2 wall} + $w create line 642 291 642 206 -fill $color -tags {floor2 wall} + $w create line 695 291 695 206 -fill $color -tags {floor2 wall} + $w create line 716 208 716 206 -fill $color -tags {floor2 wall} + $w create line 757 206 716 206 -fill $color -tags {floor2 wall} + $w create line 757 221 757 224 -fill $color -tags {floor2 wall} + $w create line 793 224 802 224 -fill $color -tags {floor2 wall} + $w create line 757 262 716 262 -fill $color -tags {floor2 wall} + $w create line 716 220 716 264 -fill $color -tags {floor2 wall} + $w create line 716 315 716 276 -fill $color -tags {floor2 wall} + $w create line 757 315 703 315 -fill $color -tags {floor2 wall} + $w create line 757 325 757 224 -fill $color -tags {floor2 wall} + $w create line 757 367 644 367 -fill $color -tags {floor2 wall} + $w create line 689 367 689 315 -fill $color -tags {floor2 wall} + $w create line 647 315 644 315 -fill $color -tags {floor2 wall} + $w create line 659 315 691 315 -fill $color -tags {floor2 wall} + $w create line 600 325 600 391 -fill $color -tags {floor2 wall} + $w create line 627 325 644 325 -fill $color -tags {floor2 wall} + $w create line 644 391 644 315 -fill $color -tags {floor2 wall} + $w create line 615 325 575 325 -fill $color -tags {floor2 wall} + $w create line 644 391 558 391 -fill $color -tags {floor2 wall} + $w create line 563 325 558 325 -fill $color -tags {floor2 wall} + $w create line 558 391 558 314 -fill $color -tags {floor2 wall} + $w create line 558 327 508 327 -fill $color -tags {floor2 wall} + $w create line 558 275 484 275 -fill $color -tags {floor2 wall} + $w create line 558 302 558 275 -fill $color -tags {floor2 wall} + $w create line 508 327 508 311 -fill $color -tags {floor2 wall} + $w create line 484 311 508 311 -fill $color -tags {floor2 wall} + $w create line 484 275 484 311 -fill $color -tags {floor2 wall} + $w create line 475 208 408 208 -fill $color -tags {floor2 wall} + $w create line 408 206 408 210 -fill $color -tags {floor2 wall} + $w create line 408 222 408 227 -fill $color -tags {floor2 wall} + $w create line 408 227 398 227 -fill $color -tags {floor2 wall} + $w create line 398 227 398 254 -fill $color -tags {floor2 wall} + $w create line 408 188 408 194 -fill $color -tags {floor2 wall} + $w create line 383 188 376 188 -fill $color -tags {floor2 wall} + $w create line 398 188 398 162 -fill $color -tags {floor2 wall} + $w create line 398 162 484 162 -fill $color -tags {floor2 wall} + $w create line 475 162 475 254 -fill $color -tags {floor2 wall} + $w create line 398 254 475 254 -fill $color -tags {floor2 wall} + $w create line 484 280 395 280 -fill $color -tags {floor2 wall} + $w create line 395 311 395 275 -fill $color -tags {floor2 wall} + $w create line 307 197 293 197 -fill $color -tags {floor2 wall} + $w create line 278 197 233 197 -fill $color -tags {floor2 wall} + $w create line 233 197 233 249 -fill $color -tags {floor2 wall} + $w create line 307 179 284 179 -fill $color -tags {floor2 wall} + $w create line 233 249 278 249 -fill $color -tags {floor2 wall} + $w create line 269 179 269 133 -fill $color -tags {floor2 wall} + $w create line 220 179 220 133 -fill $color -tags {floor2 wall} + $w create line 155 191 110 191 -fill $color -tags {floor2 wall} + $w create line 90 190 98 190 -fill $color -tags {floor2 wall} + $w create line 98 169 98 190 -fill $color -tags {floor2 wall} + $w create line 52 133 52 165 -fill $color -tags {floor2 wall} + $w create line 52 214 52 177 -fill $color -tags {floor2 wall} + $w create line 52 226 52 262 -fill $color -tags {floor2 wall} + $w create line 52 274 52 276 -fill $color -tags {floor2 wall} + $w create line 234 275 234 339 -fill $color -tags {floor2 wall} + $w create line 226 339 258 339 -fill $color -tags {floor2 wall} + $w create line 211 387 211 339 -fill $color -tags {floor2 wall} + $w create line 214 339 177 339 -fill $color -tags {floor2 wall} + $w create line 258 387 60 387 -fill $color -tags {floor2 wall} + $w create line 3 133 3 339 -fill $color -tags {floor2 wall} + $w create line 165 339 129 339 -fill $color -tags {floor2 wall} + $w create line 117 339 80 339 -fill $color -tags {floor2 wall} + $w create line 68 339 59 339 -fill $color -tags {floor2 wall} + $w create line 0 339 46 339 -fill $color -tags {floor2 wall} + $w create line 60 391 0 391 -fill $color -tags {floor2 wall} + $w create line 0 339 0 391 -fill $color -tags {floor2 wall} + $w create line 60 387 60 391 -fill $color -tags {floor2 wall} + $w create line 258 329 258 387 -fill $color -tags {floor2 wall} + $w create line 350 329 258 329 -fill $color -tags {floor2 wall} + $w create line 395 311 350 311 -fill $color -tags {floor2 wall} + $w create line 398 129 315 129 -fill $color -tags {floor2 wall} + $w create line 176 133 315 133 -fill $color -tags {floor2 wall} + $w create line 176 129 96 129 -fill $color -tags {floor2 wall} + $w create line 3 133 96 133 -fill $color -tags {floor2 wall} + $w create line 66 387 66 339 -fill $color -tags {floor2 wall} + $w create line 115 387 115 339 -fill $color -tags {floor2 wall} + $w create line 163 387 163 339 -fill $color -tags {floor2 wall} + $w create line 234 275 276 275 -fill $color -tags {floor2 wall} + $w create line 288 275 309 275 -fill $color -tags {floor2 wall} + $w create line 298 275 298 329 -fill $color -tags {floor2 wall} + $w create line 341 283 350 283 -fill $color -tags {floor2 wall} + $w create line 321 275 341 275 -fill $color -tags {floor2 wall} + $w create line 375 275 395 275 -fill $color -tags {floor2 wall} + $w create line 315 129 315 170 -fill $color -tags {floor2 wall} + $w create line 376 170 307 170 -fill $color -tags {floor2 wall} + $w create line 307 250 307 170 -fill $color -tags {floor2 wall} + $w create line 376 245 376 170 -fill $color -tags {floor2 wall} + $w create line 340 241 307 241 -fill $color -tags {floor2 wall} + $w create line 340 245 340 224 -fill $color -tags {floor2 wall} + $w create line 340 210 340 201 -fill $color -tags {floor2 wall} + $w create line 340 187 340 170 -fill $color -tags {floor2 wall} + $w create line 340 206 307 206 -fill $color -tags {floor2 wall} + $w create line 293 250 307 250 -fill $color -tags {floor2 wall} + $w create line 271 179 238 179 -fill $color -tags {floor2 wall} + $w create line 226 179 195 179 -fill $color -tags {floor2 wall} + $w create line 176 129 176 179 -fill $color -tags {floor2 wall} + $w create line 182 179 176 179 -fill $color -tags {floor2 wall} + $w create line 174 169 176 169 -fill $color -tags {floor2 wall} + $w create line 162 169 90 169 -fill $color -tags {floor2 wall} + $w create line 96 169 96 129 -fill $color -tags {floor2 wall} + $w create line 175 227 90 227 -fill $color -tags {floor2 wall} + $w create line 90 190 90 227 -fill $color -tags {floor2 wall} + $w create line 52 179 3 179 -fill $color -tags {floor2 wall} + $w create line 52 228 3 228 -fill $color -tags {floor2 wall} + $w create line 52 276 3 276 -fill $color -tags {floor2 wall} + $w create line 155 177 155 169 -fill $color -tags {floor2 wall} + $w create line 110 191 110 169 -fill $color -tags {floor2 wall} + $w create line 155 189 155 197 -fill $color -tags {floor2 wall} + $w create line 350 283 350 329 -fill $color -tags {floor2 wall} + $w create line 162 197 155 197 -fill $color -tags {floor2 wall} + $w create line 341 275 341 283 -fill $color -tags {floor2 wall} +} + +proc fg3 {w color} { + global floorLabels floorItems + set i [$w create polygon 89 228 89 180 70 180 70 228 -fill {} -tags {floor3 room}] + set floorLabels($i) 316 + set {floorItems(316)} $i + $w create text 79.5 204 -text 316 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 115 368 162 368 162 323 115 323 -fill {} -tags {floor3 room}] + set floorLabels($i) 309 + set {floorItems(309)} $i + $w create text 138.5 345.5 -text 309 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 164 323 164 368 211 368 211 323 -fill {} -tags {floor3 room}] + set floorLabels($i) 308 + set {floorItems(308)} $i + $w create text 187.5 345.5 -text 308 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 256 368 212 368 212 323 256 323 -fill {} -tags {floor3 room}] + set floorLabels($i) 307 + set {floorItems(307)} $i + $w create text 234 345.5 -text 307 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 244 276 297 276 297 327 260 327 260 321 244 321 -fill {} -tags {floor3 room}] + set floorLabels($i) 305 + set {floorItems(305)} $i + $w create text 270.5 301.5 -text 305 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 251 219 251 203 244 203 244 219 -fill {} -tags {floor3 room}] + set floorLabels($i) 324B + set {floorItems(324B)} $i + $w create text 247.5 211 -text 324B -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 251 249 244 249 244 232 251 232 -fill {} -tags {floor3 room}] + set floorLabels($i) 324A + set {floorItems(324A)} $i + $w create text 247.5 240.5 -text 324A -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 223 135 223 179 177 179 177 135 -fill {} -tags {floor3 room}] + set floorLabels($i) 320 + set {floorItems(320)} $i + $w create text 200 157 -text 320 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 114 368 114 323 67 323 67 368 -fill {} -tags {floor3 room}] + set floorLabels($i) 310 + set {floorItems(310)} $i + $w create text 90.5 345.5 -text 310 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 23 277 23 321 68 321 68 277 -fill {} -tags {floor3 room}] + set floorLabels($i) 312 + set {floorItems(312)} $i + $w create text 45.5 299 -text 312 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 23 229 68 229 68 275 23 275 -fill {} -tags {floor3 room}] + set floorLabels($i) 313 + set {floorItems(313)} $i + $w create text 45.5 252 -text 313 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 68 227 23 227 23 180 68 180 -fill {} -tags {floor3 room}] + set floorLabels($i) 314 + set {floorItems(314)} $i + $w create text 45.5 203.5 -text 314 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 95 179 95 135 23 135 23 179 -fill {} -tags {floor3 room}] + set floorLabels($i) 315 + set {floorItems(315)} $i + $w create text 59 157 -text 315 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 99 226 99 204 91 204 91 226 -fill {} -tags {floor3 room}] + set floorLabels($i) 316B + set {floorItems(316B)} $i + $w create text 95 215 -text 316B -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 91 202 99 202 99 180 91 180 -fill {} -tags {floor3 room}] + set floorLabels($i) 316A + set {floorItems(316A)} $i + $w create text 95 191 -text 316A -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 97 169 109 169 109 192 154 192 154 198 174 198 174 226 101 226 101 179 97 179 -fill {} -tags {floor3 room}] + set floorLabels($i) 319 + set {floorItems(319)} $i + $w create text 141.5 209 -text 319 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 65 368 58 368 58 389 1 389 1 333 23 333 23 323 65 323 -fill {} -tags {floor3 room}] + set floorLabels($i) 311 + set {floorItems(311)} $i + $w create text 29.5 361 -text 311 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 154 191 111 191 111 169 154 169 -fill {} -tags {floor3 room}] + set floorLabels($i) 318 + set {floorItems(318)} $i + $w create text 132.5 180 -text 318 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 175 168 97 168 97 131 175 131 -fill {} -tags {floor3 room}] + set floorLabels($i) 317 + set {floorItems(317)} $i + $w create text 136 149.5 -text 317 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 274 194 274 221 306 221 306 194 -fill {} -tags {floor3 room}] + set floorLabels($i) 323 + set {floorItems(323)} $i + $w create text 290 207.5 -text 323 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 306 222 274 222 274 249 306 249 -fill {} -tags {floor3 room}] + set floorLabels($i) 325 + set {floorItems(325)} $i + $w create text 290 235.5 -text 325 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 263 179 224 179 224 135 263 135 -fill {} -tags {floor3 room}] + set floorLabels($i) 321 + set {floorItems(321)} $i + $w create text 243.5 157 -text 321 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 314 169 306 169 306 192 273 192 264 181 264 135 314 135 -fill {} -tags {floor3 room}] + set floorLabels($i) 322 + set {floorItems(322)} $i + $w create text 293.5 163.5 -text 322 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 307 240 339 240 339 206 307 206 -fill {} -tags {floor3 room}] + set floorLabels($i) {Pub Lift3} + set {floorItems(Pub Lift3)} $i + $w create text 323 223 -text {Pub Lift3} -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 339 205 307 205 307 171 339 171 -fill {} -tags {floor3 room}] + set floorLabels($i) {Priv Lift3} + set {floorItems(Priv Lift3)} $i + $w create text 323 188 -text {Priv Lift3} -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 350 284 376 284 376 276 397 276 397 309 350 309 -fill {} -tags {floor3 room}] + set floorLabels($i) 303 + set {floorItems(303)} $i + $w create text 373.5 292.5 -text 303 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 272 203 272 249 252 249 252 230 244 230 244 221 252 221 252 203 -fill {} -tags {floor3 room}] + set floorLabels($i) 324 + set {floorItems(324)} $i + $w create text 262 226 -text 324 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 299 276 299 327 349 327 349 284 341 284 341 276 -fill {} -tags {floor3 room}] + set floorLabels($i) 304 + set {floorItems(304)} $i + $w create text 324 301.5 -text 304 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 375 246 375 172 341 172 341 246 -fill {} -tags {floor3 room}] + set floorLabels($i) 301 + set {floorItems(301)} $i + $w create text 358 209 -text 301 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 397 246 377 246 377 185 397 185 -fill {} -tags {floor3 room}] + set floorLabels($i) 327 + set {floorItems(327)} $i + $w create text 387 215.5 -text 327 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 316 131 316 169 377 169 377 185 397 185 397 131 -fill {} -tags {floor3 room}] + set floorLabels($i) 326 + set {floorItems(326)} $i + $w create text 356.5 150 -text 326 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 308 251 242 251 242 274 342 274 342 282 375 282 375 274 397 274 397 248 339 248 339 242 308 242 -fill {} -tags {floor3 room}] + set floorLabels($i) 302 + set {floorItems(302)} $i + $w create text 319.5 261 -text 302 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 70 321 242 321 242 200 259 200 259 203 272 203 272 193 263 180 242 180 175 180 175 169 156 169 156 196 177 196 177 228 107 228 70 228 70 275 107 275 107 248 160 248 160 301 107 301 107 275 70 275 -fill {} -tags {floor3 room}] + set floorLabels($i) 306 + set {floorItems(306)} $i + $w create text 200.5 284.5 -text 306 -fill $color -anchor c -tags {floor3 label} + $w create line 341 275 341 283 -fill $color -tags {floor3 wall} + $w create line 162 197 155 197 -fill $color -tags {floor3 wall} + $w create line 396 247 399 247 -fill $color -tags {floor3 wall} + $w create line 399 129 399 311 -fill $color -tags {floor3 wall} + $w create line 258 202 243 202 -fill $color -tags {floor3 wall} + $w create line 350 283 350 329 -fill $color -tags {floor3 wall} + $w create line 251 231 243 231 -fill $color -tags {floor3 wall} + $w create line 243 220 251 220 -fill $color -tags {floor3 wall} + $w create line 243 250 243 202 -fill $color -tags {floor3 wall} + $w create line 155 197 155 190 -fill $color -tags {floor3 wall} + $w create line 110 192 110 169 -fill $color -tags {floor3 wall} + $w create line 155 192 110 192 -fill $color -tags {floor3 wall} + $w create line 155 177 155 169 -fill $color -tags {floor3 wall} + $w create line 176 197 176 227 -fill $color -tags {floor3 wall} + $w create line 69 280 69 274 -fill $color -tags {floor3 wall} + $w create line 21 276 69 276 -fill $color -tags {floor3 wall} + $w create line 69 262 69 226 -fill $color -tags {floor3 wall} + $w create line 21 228 69 228 -fill $color -tags {floor3 wall} + $w create line 21 179 75 179 -fill $color -tags {floor3 wall} + $w create line 69 179 69 214 -fill $color -tags {floor3 wall} + $w create line 90 220 90 227 -fill $color -tags {floor3 wall} + $w create line 90 204 90 202 -fill $color -tags {floor3 wall} + $w create line 90 203 100 203 -fill $color -tags {floor3 wall} + $w create line 90 187 90 179 -fill $color -tags {floor3 wall} + $w create line 90 227 176 227 -fill $color -tags {floor3 wall} + $w create line 100 179 100 227 -fill $color -tags {floor3 wall} + $w create line 100 179 87 179 -fill $color -tags {floor3 wall} + $w create line 96 179 96 129 -fill $color -tags {floor3 wall} + $w create line 162 169 96 169 -fill $color -tags {floor3 wall} + $w create line 173 169 176 169 -fill $color -tags {floor3 wall} + $w create line 182 179 176 179 -fill $color -tags {floor3 wall} + $w create line 176 129 176 179 -fill $color -tags {floor3 wall} + $w create line 195 179 226 179 -fill $color -tags {floor3 wall} + $w create line 224 133 224 179 -fill $color -tags {floor3 wall} + $w create line 264 179 264 133 -fill $color -tags {floor3 wall} + $w create line 238 179 264 179 -fill $color -tags {floor3 wall} + $w create line 273 207 273 193 -fill $color -tags {floor3 wall} + $w create line 273 235 273 250 -fill $color -tags {floor3 wall} + $w create line 273 224 273 219 -fill $color -tags {floor3 wall} + $w create line 273 193 307 193 -fill $color -tags {floor3 wall} + $w create line 273 222 307 222 -fill $color -tags {floor3 wall} + $w create line 273 250 307 250 -fill $color -tags {floor3 wall} + $w create line 384 247 376 247 -fill $color -tags {floor3 wall} + $w create line 340 206 307 206 -fill $color -tags {floor3 wall} + $w create line 340 187 340 170 -fill $color -tags {floor3 wall} + $w create line 340 210 340 201 -fill $color -tags {floor3 wall} + $w create line 340 247 340 224 -fill $color -tags {floor3 wall} + $w create line 340 241 307 241 -fill $color -tags {floor3 wall} + $w create line 376 247 376 170 -fill $color -tags {floor3 wall} + $w create line 307 250 307 170 -fill $color -tags {floor3 wall} + $w create line 376 170 307 170 -fill $color -tags {floor3 wall} + $w create line 315 129 315 170 -fill $color -tags {floor3 wall} + $w create line 376 283 366 283 -fill $color -tags {floor3 wall} + $w create line 376 283 376 275 -fill $color -tags {floor3 wall} + $w create line 399 275 376 275 -fill $color -tags {floor3 wall} + $w create line 341 275 320 275 -fill $color -tags {floor3 wall} + $w create line 341 283 350 283 -fill $color -tags {floor3 wall} + $w create line 298 275 298 329 -fill $color -tags {floor3 wall} + $w create line 308 275 298 275 -fill $color -tags {floor3 wall} + $w create line 243 322 243 275 -fill $color -tags {floor3 wall} + $w create line 243 275 284 275 -fill $color -tags {floor3 wall} + $w create line 258 322 226 322 -fill $color -tags {floor3 wall} + $w create line 212 370 212 322 -fill $color -tags {floor3 wall} + $w create line 214 322 177 322 -fill $color -tags {floor3 wall} + $w create line 163 370 163 322 -fill $color -tags {floor3 wall} + $w create line 165 322 129 322 -fill $color -tags {floor3 wall} + $w create line 84 322 117 322 -fill $color -tags {floor3 wall} + $w create line 71 322 64 322 -fill $color -tags {floor3 wall} + $w create line 115 322 115 370 -fill $color -tags {floor3 wall} + $w create line 66 322 66 370 -fill $color -tags {floor3 wall} + $w create line 52 322 21 322 -fill $color -tags {floor3 wall} + $w create line 21 331 0 331 -fill $color -tags {floor3 wall} + $w create line 21 331 21 133 -fill $color -tags {floor3 wall} + $w create line 96 133 21 133 -fill $color -tags {floor3 wall} + $w create line 176 129 96 129 -fill $color -tags {floor3 wall} + $w create line 315 133 176 133 -fill $color -tags {floor3 wall} + $w create line 315 129 399 129 -fill $color -tags {floor3 wall} + $w create line 399 311 350 311 -fill $color -tags {floor3 wall} + $w create line 350 329 258 329 -fill $color -tags {floor3 wall} + $w create line 258 322 258 370 -fill $color -tags {floor3 wall} + $w create line 60 370 258 370 -fill $color -tags {floor3 wall} + $w create line 60 370 60 391 -fill $color -tags {floor3 wall} + $w create line 0 391 0 331 -fill $color -tags {floor3 wall} + $w create line 60 391 0 391 -fill $color -tags {floor3 wall} + $w create line 307 250 307 242 -fill $color -tags {floor3 wall} + $w create line 273 250 307 250 -fill $color -tags {floor3 wall} + $w create line 258 250 243 250 -fill $color -tags {floor3 wall} +} diff --git a/gcl-tk/demos/mkForm.lisp b/gcl-tk/demos/mkForm.lisp new file mode 100755 index 0000000..54576e9 --- /dev/null +++ b/gcl-tk/demos/mkForm.lisp @@ -0,0 +1,54 @@ +;;# mkForm w +;; +;; Create a top-level window that displays a bunch of entries with +;; tabs set up to move between them. +;; +;; Arguments: +;; w - Name to use for new top-level window. + +(in-package "TK") +(defvar *tablist*) + +(defun mkForm (&optional (w '.form)) + (setq *tablist* nil) + (if (winfo :exists w :return 'boolean) (destroy w)) + (toplevel w) + (dpos w) + (wm :title w "Form Demonstration") + (wm :iconname w "Form") + (message (conc w '.msg) :font :Adobe-times-medium-r-normal--*-180* :width "4i" + :text "This window contains a simple form where you can type in the various entries and use tabs to move circularly between the entries. Click the \"OK\" button or type return when you're done.") + (dolist (i '(f1 f2 f3 f4 f5)) + (frame (conc w '|.| i) :bd "1m") + (entry (conc w '|.| i '.entry) :relief "sunken" :width 40) + (bind (conc w '|.| i '.entry) "" '(Tab *tabList*)) + (bind (conc w '|.| i '.entry) "" `(destroy ',w)) + (label (conc w '|.| i '.label)) + (pack (conc w '|.| i '.entry) :side "right") + (pack (conc w '|.| i '.label) :side "left") + (push (conc i '.entry) *tablist*)) + (setq *tablist* (nreverse *tablist*)) + (funcall (conc w '.f1.label) :config :text "Name: ") + (funcall (conc w '.f2.label) :config :text "Address: ") + (funcall (conc w '.f5.label) :config :text "Phone: ") + (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) + (pack (conc w '.msg) (conc w '.f1) (conc w '.f2) (conc w '.f3) + (conc w '.f4) (conc w '.f5) (conc w '.ok) :side "top" :fill "x") + +) + +;; The procedure below is invoked in response to tabs in the entry +;; windows. It moves the focus to the next window in the tab list. +;; Arguments: +;; +;; list - Ordered list of windows to receive focus + +(defun Tab (list) + (setq i (position (focus :return t) list)) + (cond ((null i) (setq i 0)) + (t (incf i) + (if (>= i (length list) ) + (setq i 0)))) + (focus (nth i list )) +) + diff --git a/gcl-tk/demos/mkForm.tcl b/gcl-tk/demos/mkForm.tcl new file mode 100755 index 0000000..a8971f0 --- /dev/null +++ b/gcl-tk/demos/mkForm.tcl @@ -0,0 +1,52 @@ +# mkForm w +# +# Create a top-level window that displays a bunch of entries with +# tabs set up to move between them. +# +# Arguments: +# w - Name to use for new top-level window. + +proc mkForm {{w .form}} { + global tabList + catch {destroy $w} + toplevel $w + dpos $w + wm title $w "Form Demonstration" + wm iconname $w "Form" + message $w.msg -font -Adobe-times-medium-r-normal--*-180* -width 4i \ + -text "This window contains a simple form where you can type in the various entries and use tabs to move circularly between the entries. Click the \"OK\" button or type return when you're done." + foreach i {f1 f2 f3 f4 f5} { + frame $w.$i -bd 1m + entry $w.$i.entry -relief sunken -width 40 + bind $w.$i.entry "Tab \$tabList" + bind $w.$i.entry "destroy $w" + label $w.$i.label + pack $w.$i.entry -side right + pack $w.$i.label -side left + } + $w.f1.label config -text Name: + $w.f2.label config -text Address: + $w.f5.label config -text Phone: + button $w.ok -text OK -command "destroy $w" + pack $w.msg $w.f1 $w.f2 $w.f3 $w.f4 $w.f5 $w.ok -side top -fill x + set tabList "$w.f1.entry $w.f2.entry $w.f3.entry $w.f4.entry $w.f5.entry" +} + +# The procedure below is invoked in response to tabs in the entry +# windows. It moves the focus to the next window in the tab list. +# Arguments: +# +# list - Ordered list of windows to receive focus + +proc Tab {list} { + set i [lsearch $list [focus]] + if {$i < 0} { + set i 0 + } else { + incr i + if {$i >= [llength $list]} { + set i 0 + } + } + focus [lindex $list $i] +} diff --git a/gcl-tk/demos/mkHScale.lisp b/gcl-tk/demos/mkHScale.lisp new file mode 100755 index 0000000..579edce --- /dev/null +++ b/gcl-tk/demos/mkHScale.lisp @@ -0,0 +1,38 @@ +;;# mkHScale w +;; +;; Create a top-level window that displays a horizontal scale. +;; +;; Arguments: +;; w - Name to use for new top-level window. + +(in-package "TK") + +(defun mkHScale (&optional (w '.scale2)) + (if (winfo :exists w :return 'boolean) (destroy w)) + (toplevel w) + (dpos w) + (wm :title w "Horizontal Scale Demonstration") + (wm :iconname w "Scale") + (message (conc w '.msg) :font :Adobe-times-medium-r-normal--*-180* :aspect 300 + :text "A bar and a horizontal scale are displayed below. (if :you click or drag mouse button 1 in the scale, you can change the width of the bar. Click the \"OK\" button when you're finished.") + (frame (conc w '.frame) :borderwidth 10) + (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) + (pack (conc w '.msg) (conc w '.frame) (conc w '.ok) :side "top" :fill "x") + + (frame (conc w '.frame.top) :borderwidth 15) + (scale (conc w '.frame.scale) :orient "horizontal" :length 280 :from 0 :to 250 + :command (tk-conc "setWidth " w ".frame.top.inner") :tickinterval 50 + :bg "Bisque1") + (frame (conc w '.frame.top.inner) :width 20 :height 40 :relief "raised" :borderwidth 2 + :bg "SteelBlue1") + (pack (conc w '.frame.top) :side "top" :expand "yes" :anchor "sw") + (pack (conc w '.frame.scale) :side "bottom" :expand "yes" :anchor "nw") + + + (pack (conc w '.frame.top.inner) :expand "yes" :anchor "sw") + (funcall (conc w '.frame.scale) :set 20) +) + +(defun setWidth (w width) + (funcall w :config :width ${width} :height 40) +) diff --git a/gcl-tk/demos/mkHScale.tcl b/gcl-tk/demos/mkHScale.tcl new file mode 100755 index 0000000..f481cb9 --- /dev/null +++ b/gcl-tk/demos/mkHScale.tcl @@ -0,0 +1,35 @@ +# mkHScale w +# +# Create a top-level window that displays a horizontal scale. +# +# Arguments: +# w - Name to use for new top-level window. + +proc mkHScale {{w .scale2}} { + catch {destroy $w} + toplevel $w + dpos $w + wm title $w "Horizontal Scale Demonstration" + wm iconname $w "Scale" + message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ + -text "A bar and a horizontal scale are displayed below. If you click or drag mouse button 1 in the scale, you can change the width of the bar. Click the \"OK\" button when you're finished." + frame $w.frame -borderwidth 10 + button $w.ok -text OK -command "destroy $w" + pack $w.msg $w.frame $w.ok -side top -fill x + + frame $w.frame.top -borderwidth 15 + scale $w.frame.scale -orient horizontal -length 280 -from 0 -to 250 \ + -command "setWidth $w.frame.top.inner" -tickinterval 50 \ + -bg Bisque1 + pack $w.frame.top -side top -expand yes -anchor sw + pack $w.frame.scale -side bottom -expand yes -anchor nw + + frame $w.frame.top.inner -relief raised -borderwidth 2 \ + -bg SteelBlue1 + pack $w.frame.top.inner -expand yes -anchor sw + $w.frame.scale set 20 +} + +proc setWidth {w width} { + $w config -width $width +} diff --git a/gcl-tk/demos/mkIcon.tcl b/gcl-tk/demos/mkIcon.tcl new file mode 100755 index 0000000..2e10494 --- /dev/null +++ b/gcl-tk/demos/mkIcon.tcl @@ -0,0 +1,48 @@ +# mkIcon w +# +# Create a top-level window that displays a bunch of iconic +# buttons. +# +# Arguments: +# w - Name to use for new top-level window. + +proc mkIcon {{w .icon}} { + global tk_library + catch {destroy $w} + toplevel $w + dpos $w + wm title $w "Iconic Button Demonstration" + wm iconname $w "Icons" + label $w.msg -wraplength 5i -justify left -text "This window shows three ways of using bitmaps or images in radiobuttons and checkbuttons. On the left are two radiobuttons, each of which displays a bitmap and an indicator. In the middle is a checkbutton that displays a different image depending on whether it is selected or not. On the right is a checkbutton that displays a single bitmap but changes its background color to indicate whether or not it is selected." +pack $w.msg -side top +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +pack $w.buttons.dismiss -side left -expand 1 + +image create bitmap flagup \ + -file [file join $tk_library demos images flagup.bmp] \ + -maskfile [file join $tk_library demos images flagup.bmp] +image create bitmap flagdown \ + -file [file join $tk_library demos images flagdown.bmp] \ + -maskfile [file join $tk_library demos images flagdown.bmp] +frame $w.frame -borderwidth 10 +pack $w.frame -side top + +checkbutton $w.frame.b1 -image flagdown -selectimage flagup \ + -indicatoron 0 +$w.frame.b1 configure -selectcolor [$w.frame.b1 cget -background] +checkbutton $w.frame.b2 \ + -bitmap @[file join $tk_library demos images letters.bmp] \ + -indicatoron 0 -selectcolor SeaGreen1 +frame $w.frame.left +pack $w.frame.left $w.frame.b1 $w.frame.b2 -side left -expand yes -padx 5m + +radiobutton $w.frame.left.b3 \ + -bitmap @[file join $tk_library demos images letters.bmp] \ + -variable letters -value full +radiobutton $w.frame.left.b4 \ + -bitmap @[file join $tk_library demos images noletter.bmp] \ + -variable letters -value empty +pack $w.frame.left.b3 $w.frame.left.b4 -side top -expand yes +} diff --git a/gcl-tk/demos/mkItems.lisp b/gcl-tk/demos/mkItems.lisp new file mode 100755 index 0000000..5a4598b --- /dev/null +++ b/gcl-tk/demos/mkItems.lisp @@ -0,0 +1,358 @@ +;;# mkItems w +;; +;; Create a top-level window containing a canvas that displays the +;; various item types and allows them to be selected and moved. This +;; demo can be used to test out the point-hit and rectangle-hit code +;; for items. +;; +;; Arguments: +;; w - Name to use for new top-level window. +(in-package "TK") +(defvar *color-display* nil) +(defun mkItems (&optional (w '.citems)) + (declare (special c tk_library)) + (if (winfo :exists w :return 'boolean) + (destroy w)) + (if (winfo :exists w :return 'boolean) (destroy w)) + (toplevel w) + (dpos w) + (wm :title w "Canvas Item Demonstration") + (wm :iconname w "Items") + (wm :minsize w 100 100) + (setq c (conc w '.frame2.c)) + + (message (conc w '.msg) :font :Adobe-Times-Medium-R-Normal--*-180-* :width "13c" + :bd 2 :relief "raised" :text #u"This window contains a canvas widget with examples of the various kinds of items supported by canvases. The following operations are supported:\n Button-1 drag:\tmoves item under pointer.\n Button-2 drag:\trepositions view.\n Button-3 drag:\tstrokes out area.\n Ctrl+f:\t\tprints items under area.") + (frame (conc w '.frame2) :relief "raised" :bd 2) + (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) + (pack (conc w '.msg) :side "top" :fill "x") + (pack (conc w '.frame2) :side "top" :fill "both" :expand "yes") + (pack (conc w '.ok) :side "bottom" :pady 5 :anchor "center") + + (scrollbar (conc w '.frame2.vscroll) :relief "sunken" :command (tk-conc c " yview")) + (scrollbar (conc w '.frame2.hscroll) :orient "horiz" :relief "sunken" :command (tk-conc c " xview")) + (canvas c :scrollregion "0c 0c 30c 24c" :width "15c" :height "10c" + :relief "sunken" :borderwidth 2 + :xscrollcommand (tk-conc w ".frame2.hscroll set") :yscrollcommand (tk-conc w ".frame2.vscroll set")) + (pack (conc w '.frame2.hscroll) :side "bottom" :fill "x") + (pack (conc w '.frame2.vscroll) :side "right" :fill "y") + (pack c :in (conc w '.frame2) :expand "yes" :fill "both") + + ;; Display a 3x3 rectangular grid. + + (funcall c :create "rect" "0c" "0c" "30c" "24c" :width 2) + (funcall c :create "line" "0c" "8c" "30c" "8c" :width 2) + (funcall c :create "line" "0c" "16c" "30c" "16c" :width 2) + (funcall c :create "line" "10c" "0c" "10c" "24c" :width 2) + (funcall c :create "line" "20c" "0c" "20c" "24c" :width 2) + + (setq font1 :Adobe-Helvetica-Medium-R-Normal--*-120-*) + (setq font2 :Adobe-Helvetica-Bold-R-Normal--*-240-*) + (if (> (winfo :depth c :return 'number) 1) + (progn + (setq *color-display* t) + (setq blue "DeepSkyBlue3") + (setq red "red") + (setq bisque "bisque3") + (setq green "SeaGreen3")) + (progn + (setq blue "black") + (setq red "black") + (setq bisque "black") + (setq green "black"))) + + ;; Set up demos within each of the areas of the grid. + + (funcall c :create "text" "5c" ".2c" :text "Lines" :anchor "n") + (funcall c :create "line" "1c" "1c" "3c" "1c" "1c" "4c" "3c" "4c" :width "2m" :fill blue + :cap "butt" :join "miter" :tags "item") + (funcall c :create "line" "4.67c" "1c" "4.67c" "4c" :arrow "last" :tags "item") + (funcall c :create "line" "6.33c" "1c" "6.33c" "4c" :arrow "both" :tags "item") + (funcall c :create "line" + "5c" "6c" "9c" "6c" "9c" "1c" "8c" "1c" "8c" "4.8c" "8.8c" "4.8c" "8.8c" "1.2c" + "8.2c" "1.2c" "8.2c" "4.6c" "8.6c" "4.6c" "8.6c" "1.4c" "8.4c" "1.4c" "8.4c" "4.4c" :fill "red" + :width 3 :tags "item") + (funcall c :create "line" "1c" "5c" "7c" "5c" "7c" "7c" "9c" "7c" + :width ".5c" + :stipple "@" : *tk-library* : "/demos/images/gray25.bmp" + :arrow "both" :arrowshape "15 15 7" :tags "item") + (funcall c :create "line" "1c" "7c" "1.75c" "5.8c" "2.5c" "7c" "3.25c" + "5.8c" "4c" "7c" :width ".5c" + :cap "round" :join "round" :tags "item") + + (funcall c :create "text" "15c" ".2c" :text "Curves (smoothed :lines)" :anchor "n") + (funcall c :create "line" "11c" "4c" "11.5c" "1c" "13.5c" "1c" "14c" + "4c" :smooth "on" + :fill blue :tags "item") + (funcall c :create "line" "15.5c" "1c" "19.5c" "1.5c" "15.5c" "4.5c" + "19.5c" "4c" :smooth "on" + :arrow "both" :width 3 :tags "item") + (funcall c :create "line" "12c" "6c" "13.5c" "4.5c" "16.5c" "7.5c" "18c" "6c" + "16.5c" "4.5c" "13.5c" "7.5c" "12c" "6c" :smooth "on" :width "3m" :cap "round" + :stipple "@" : *tk-library* : "/demos/images/gray25.bmp" :fill red :tags "item") + + (funcall c :create "text" '25c ".2c" :text "Polygons" :anchor "n") + (funcall c :create "polygon" "21c" "1.0c" "22.5c" "1.75c" "24c" "1.0c" + "23.25c" "2.5c" + "24c" "4.0c" "22.5c" "3.25c" "21c" "4.0c" "21.75c" "2.5c" + :fill green :tags + "item") + (funcall c :create "polygon" "25c" "4c" "25c" "4c" "25c" "1c" "26c" "1c" "27c" "4c" "28c" "1c" + "29c" "1c" "29c" "4c" "29c" "4c" :fill red :smooth "on" :tags "item") + (funcall c :create "polygon" "22c" "4.5c" "25c" "4.5c" "25c" "6.75c" "28c" "6.75c" + "28c" "5.25c" "24c" "5.25c" "24c" "6.0c" "26c" "6c" "26c" "7.5c" "22c" "7.5c" + :stipple "@" : *tk-library* : "/demos/images/gray25.bmp" :tags "item") + + (funcall c :create "text" "5c" "8.2c" :text "Rectangles" :anchor "n") + (funcall c :create "rectangle" "1c" "9.5c" "4c" "12.5c" :outline red :width "3m" :tags "item") + (funcall c :create "rectangle" "0.5c" "13.5c" "4.5c" "15.5c" :fill green :tags "item") + (funcall c :create "rectangle" "6c" "10c" "9c" "15c" :outline "" + :stipple "@" : *tk-library* : "/demos/images/gray25.bmp" :fill blue :tags "item") + + (funcall c :create "text" "15c" "8.2c" :text "Ovals" :anchor "n") + (funcall c :create "oval" "11c" "9.5c" "14c" "12.5c" :outline red :width "3m" :tags "item") + (funcall c :create "oval" "10.5c" "13.5c" "14.5c" "15.5c" :fill green :tags "item") + (funcall c :create "oval" "16c" "10c" "19c" "15c" :outline "" + :stipple "@" : *tk-library* : "/demos/images/gray25.bmp" :fill blue :tags "item") + + (funcall c :create "text" "25c" "8.2c" :text "Text" :anchor "n") + (funcall c :create "rectangle" "22.4c" "8.9c" "22.6c" "9.1c") + (funcall c :create "text" "22.5c" "9c" :anchor "n" :font font1 :width "4c" + :text "A short string of text, word-wrapped, justified left, and anchored north (at :the top). The rectangles show the anchor points for each piece of text." :tags "item") + (funcall c :create "rectangle" "25.4c" "10.9c" "25.6c" "11.1c") + (funcall c :create "text" "25.5c" "11c" :anchor "w" :font font1 :fill blue + :text #u"Several lines,\n each centered\nindividually,\nand all anchored\nat the left edge." + :justify "center" :tags "item") + (funcall c :create "rectangle" "24.9c" "13.9c" "25.1c" "14.1c") + (funcall c :create "text" "25c" "14c" :font font2 :anchor "c" :fill red + :stipple "@" : *tk-library* : "/demos/images/gray25.bmp" + :text "Stippled characters" :tags "item") + + (funcall c :create "text" "5c" "16.2c" :text "Arcs" :anchor "n") + (funcall c :create "arc" "0.5c" "17c" "7c" "20c" :fill green :outline "black" + :start 45 :extent 270 :style "pieslice" :tags "item") + (funcall c :create "arc" "6.5c" "17c" "9.5c" "20c" :width "4m" :style "arc" + :fill blue :start -135 :extent 270 + :stipple "@" : *tk-library* : "/demos/images/gray25.bmp" :tags "item") + (funcall c :create "arc" "0.5c" "20c" "9.5c" "24c" :width "4m" :style "pieslice" + :fill "" :outline red :start 225 :extent -90 :tags "item") + (funcall c :create "arc" "5.5c" "20.5c" "9.5c" "23.5c" :width "4m" :style "chord" + :fill blue :outline "" :start 45 :extent 270 :tags "item") + + (funcall c :create "text" "15c" "16.2c" :text "Bitmaps" :anchor "n") + (funcall c :create "bitmap" "13c" "20c" :bitmap "@" : *tk-library* : "/demos/images/face.bmp" :tags "item") + (funcall c :create "bitmap" "17c" "18.5c" + :bitmap "@" : *tk-library* : "/demos/images/noletter.bmp" :tags "item") + (funcall c :create "bitmap" "17c" "21.5c" + :bitmap "@" : *tk-library* : "/demos/images/letters.bmp" :tags "item") + + (funcall c :create "text" "25c" "16.2c" :text "Windows" :anchor "n") + (button (conc c '.button) :text "Press Me" :command `(butPress ',c ',red)) + (funcall c :create "window" "21c" "18c" :window (conc c '.button) :anchor "nw" :tags "item") + (bind "Entry" "" '(emacs-move %W %A )) + (bind "Entry" "" "") + (entry (conc c '.entry) :width 20 :relief "sunken") + (funcall (conc c '.entry) :insert "end" "Edit this text") + (funcall c :create "window" "21c" "21c" :window (conc c '.entry) :anchor "nw" :tags "item") + (scale (conc c '.scale) :from 0 :to 100 :length "6c" :sliderlength '.4c + :width ".5c" :tickinterval 0) + (funcall c :create "window" "28.5c" "17.5c" :window (conc c '.scale) :anchor "n" :tags "item") + (funcall c :create "text" "21c" "17.9c" :text "Button" :anchor "sw") + (funcall c :create "text" "21c" "20.9c" :text "Entry" :anchor "sw") + (funcall c :create "text" "28.5c" "17.4c" :text "Scale" :anchor "s") + + ;; Set up event bindings for canvas: + + (funcall c :bind "item" "" `(itemEnter ',c)) + (funcall c :bind "item" "" `(itemLeave ',c)) + (bind c "<2>" (tk-conc c " scan mark %x %y")) + (bind c "" (tk-conc c " scan dragto %x %y")) + (bind c "<3>" `(itemMark ',c |%x| |%y|)) + (bind c "" `(itemStroke ',c |%x| |%y|)) + (bind c "" `(itemsUnderArea ',c)) + (bind c "<1>" `(itemStartDrag ',c |%x| |%y|)) + (bind c "" `(itemDrag ',c |%x| |%y|)) + (bind w "" `(focus ',c)) +) + +;; Utility procedures for highlighting the item under the pointer: + +(defvar *restorecmd* nil) + +(defun itemEnter (c &aux type bg) + ; (global :*restorecmd*) + (let ((current (funcall c :find "withtag" "current" :return 'string))) + (if (equal current "") (return-from itementer nil)) + (itemleave nil) + (if (not *color-display*) + (progn + (itemLeave nil) + (return-from itementer nil))) + (setq type (funcall c :type current :return 'string)) + (if (equal type "window") + (progn + (itemLeave nil) + (return-from itemEnter nil))) + (if (equal type "bitmap") + (progn + (setq bg (nth 4 + (funcall c :itemconf current :background + :return 'list-strings))) + (push `(,c :itemconfig ',current :background ',bg) *restorecmd*) + (funcall c :itemconfig current :background "SteelBlue2") + (return-from itemEnter nil))) + (setq fill (nth 4 (funcall c :itemconfig current :fill + :return 'list-strings))) + (if (or (member type '("rectangle" "oval" "arg") :test 'equal) + (equal fill "")) + (progn + (setq outline (nth 4 (funcall c :itemconfig current :outline :return 'list-strings))) + (push `(,c :itemconfig ',current :outline ',outline) *restorecmd*) + (funcall c :itemconfig current :outline "SteelBlue2")) + (progn + (push `(,c :itemconfig ',current :fill ,fill) *restorecmd*) + (funcall c :itemconfig current :fill "SteelBlue2"))) + ) + ) + +(defun itemLeave (c) +; (global :*restorecmd*) + (let ((tem *restorecmd*)) + (setq *restorecmd* nil) + (dolist (v tem) + (eval v)))) + + +;; Utility procedures for stroking out a rectangle and printing what's +;; underneath the rectangle's area. + +(defun itemMark (c x y) +; (global :areaX1 areaY1) + (setq areaX1 (funcall c :canvasx x :return 'string)) + (setq areaY1 (funcall c :canvasy y :return 'string)) + (funcall c :delete "area") +) + +(defun itemStroke (c x y ) + (declare (special areaX1 areaY1 areaX2 areaY2)) + (or *recursive* + (let ((*recursive* t)) + (setq x (funcall c :canvasx x :return 'string)) + (setq y (funcall c :canvasy y :return 'string)) + (progn + (setq areaX2 x) + (setq areaY2 y) + ;; this next return 'stringis simply for TIMING!!! + ;; to make it wait for the result before going into subsequent!! + (funcall c :delete "area" :return 'string) + (funcall c :addtag "area" "withtag" + (funcall c :create "rect" areaX1 areaY1 x y + :outline "black" :return 'string)) + + )))) + +(defun itemsUnderArea (c) +; (global :areaX1 areaY1 areaX2 areaY2) + (setq area (funcall c :find "withtag" "area" :return 'string)) + (setq me c) + (setq items "") + (dolist (i + (funcall c :find "enclosed" areaX1 areaY1 areaX2 areaY2 + :return 'list-strings)) + (if (search "item" (funcall c :gettags i :return 'string)) + (setq items (tk-conc items " " i)))) + (print (tk-conc "Items enclosed by area: " items)) + (setq items "") + (dolist (i + (funcall c :find "overlapping" areaX1 areaY1 areaX2 areaY2 + :return 'list-strings)) + (if (search "item" (funcall c :gettags i :return 'string)) + (setq items (tk-conc items " " i)))) + (print (tk-conc "Items overlapping area: " items)) + (terpri) + (force-output) +) + +(setq areaX1 0) +(setq areaY1 0) +(setq areaX2 0) +(setq areaY2 0) + +;; Utility procedures to support dragging of items. + +(defvar *lastX* 0) +(defvar *lastY* 0) + + +(defun itemStartDrag (c x y) +; (global :*lastX* *lastY*) + (setq *lastX* (funcall c :canvasx x :return 'number)) + (setq *lastY* (funcall c :canvasy y :return 'number)) +) + +(defun itemDrag (c x y) +; (global :*lastX* *lastY*) + (setq x (funcall c :canvasx x :return 'number)) + (setq y (funcall c :canvasy y :return 'number)) + (funcall c :move "current" (- x *lastX*) (- y *lastY*)) + (setq *lastX* x) + (setq *lastY* y) +) + +(defvar *recursive* nil) +(defun itemDrag (c x y) +; (global :*lastX* *lastY*) + (cond (*recursive* ) + (t (let ((*recursive* t)) + (setq x (funcall c :canvasx x :return 'number)) + (setq y (funcall c :canvasy y :return 'number)) + (funcall c :move "current" (- x *lastX*) (- y *lastY*)) + (setq *lastX* x) + (setq *lastY* y))))) + +;; Procedure that's invoked when the button embedded in the "canvas" +;; is invoked. + +(defun butPress (w color) + (setq i (funcall w :create "text" "25c" "18.1c" :text "Ouch!!" + :fill color :anchor "n" :return 'string)) + (after 500 (tk-conc w " delete " i)) +) + +(defvar *last-kill* "") +;(bind ".citems.frame2.c.entry" "" '(emacs-move %W %A )) +(defun emacs-move (a key) + (let* ((win a) + ;; if this window is from tcl it is not yet a lisp function. + ;; steal it... build it into coerce-result... + (foo (or (fboundp win) (setf (symbol-function win) + (make-widget-instance win nil)))) + (pos (funcall win :index "insert" :return 'number)) + char + new) + (setq new + (case (setq char (aref key 0)) + (#\^B (max 0 (- pos 1))) + (#\^F (max 0 (+ pos 1))) + (#\^A 0) + (#\^E "end"))) +; (print (list a char key)) + (cond (new + (funcall win :icursor new)) + ((eql char #\^D) + (funcall win :delete pos )) + ((or (eql char #\^K) + (eql char #\v)) + (setq *last-kill* (subseq (funcall win :get :return 'string) pos)) + (funcall win :delete pos "end" )) + ((eql char #\^Y) + (funcall win :insert pos *last-kill*)) + (t (funcall win :insert pos key))))) + + + + + + + + diff --git a/gcl-tk/demos/mkItems.tcl b/gcl-tk/demos/mkItems.tcl new file mode 100755 index 0000000..7719347 --- /dev/null +++ b/gcl-tk/demos/mkItems.tcl @@ -0,0 +1,271 @@ +# mkItems w +# +# Create a top-level window containing a canvas that displays the +# various item types and allows them to be selected and moved. This +# demo can be used to test out the point-hit and rectangle-hit code +# for items. +# +# Arguments: +# w - Name to use for new top-level window. + +proc mkItems {{w .citems}} { + global c tk_library + catch {destroy $w} + toplevel $w + dpos $w + wm title $w "Canvas Item Demonstration" + wm iconname $w "Items" + wm minsize $w 100 100 + set c $w.frame2.c + + message $w.msg -font -Adobe-Times-Medium-R-Normal--*-180-* -width 13c \ + -bd 2 -relief raised -text "This window contains a canvas widget with examples of the various kinds of items supported by canvases. The following operations are supported:\n Button-1 drag:\tmoves item under pointer.\n Button-2 drag:\trepositions view.\n Button-3 drag:\tstrokes out area.\n Ctrl+f:\t\tprints items under area." + frame $w.frame2 -relief raised -bd 2 + button $w.ok -text "OK" -command "destroy $w" + pack $w.msg -side top -fill x + pack $w.frame2 -side top -fill both -expand yes + pack $w.ok -side bottom -pady 5 -anchor center + + canvas $c -scrollregion {0c 0c 30c 24c} -width 15c -height 10c \ + -xscroll "$w.frame2.hscroll set" -yscroll "$w.frame2.vscroll set" + scrollbar $w.frame2.vscroll -relief sunken -command "$c yview" + scrollbar $w.frame2.hscroll -orient horiz -relief sunken -command "$c xview" + pack $w.frame2.hscroll -side bottom -fill x + pack $w.frame2.vscroll -side right -fill y + pack $c -in $w.frame2 -expand yes -fill both + + # Display a 3x3 rectangular grid. + + $c create rect 0c 0c 30c 24c -width 2 + $c create line 0c 8c 30c 8c -width 2 + $c create line 0c 16c 30c 16c -width 2 + $c create line 10c 0c 10c 24c -width 2 + $c create line 20c 0c 20c 24c -width 2 + + set font1 -Adobe-Helvetica-Medium-R-Normal--*-120-* + set font2 -Adobe-Helvetica-Bold-R-Normal--*-240-* + if {[winfo depth $c] > 1} { + set blue DeepSkyBlue3 + set red red + set bisque bisque3 + set green SeaGreen3 + } else { + set blue black + set red black + set bisque black + set green black + } + + # Set up demos within each of the areas of the grid. + + $c create text 5c .2c -text Lines -anchor n + $c create line 1c 1c 3c 1c 1c 4c 3c 4c -width 2m -fill $blue \ + -cap butt -join miter -tags item + $c create line 4.67c 1c 4.67c 4c -arrow last -tags item + $c create line 6.33c 1c 6.33c 4c -arrow both -tags item + $c create line 5c 6c 9c 6c 9c 1c 8c 1c 8c 4.8c 8.8c 4.8c 8.8c 1.2c \ + 8.2c 1.2c 8.2c 4.6c 8.6c 4.6c 8.6c 1.4c 8.4c 1.4c 8.4c 4.4c \ + -width 3 -fill $red -tags item + $c create line 1c 5c 7c 5c 7c 7c 9c 7c -width .5c \ + -stipple @$tk_library/demos/bitmaps/grey.25 \ + -arrow both -arrowshape {15 15 7} -tags item + $c create line 1c 7c 1.75c 5.8c 2.5c 7c 3.25c 5.8c 4c 7c -width .5c \ + -cap round -join round -tags item + + $c create text 15c .2c -text "Curves (smoothed lines)" -anchor n + $c create line 11c 4c 11.5c 1c 13.5c 1c 14c 4c -smooth on \ + -fill $blue -tags item + $c create line 15.5c 1c 19.5c 1.5c 15.5c 4.5c 19.5c 4c -smooth on \ + -arrow both -width 3 -tags item + $c create line 12c 6c 13.5c 4.5c 16.5c 7.5c 18c 6c \ + 16.5c 4.5c 13.5c 7.5c 12c 6c -smooth on -width 3m -cap round \ + -stipple @$tk_library/demos/bitmaps/grey.25 -fill $red -tags item + + $c create text 25c .2c -text Polygons -anchor n + $c create polygon 21c 1.0c 22.5c 1.75c 24c 1.0c 23.25c 2.5c \ + 24c 4.0c 22.5c 3.25c 21c 4.0c 21.75c 2.5c -fill $green -tags item + $c create polygon 25c 4c 25c 4c 25c 1c 26c 1c 27c 4c 28c 1c \ + 29c 1c 29c 4c 29c 4c -fill $red -smooth on -tags item + $c create polygon 22c 4.5c 25c 4.5c 25c 6.75c 28c 6.75c \ + 28c 5.25c 24c 5.25c 24c 6.0c 26c 6c 26c 7.5c 22c 7.5c \ + -stipple @$tk_library/demos/bitmaps/grey.25 -tags item + + $c create text 5c 8.2c -text Rectangles -anchor n + $c create rectangle 1c 9.5c 4c 12.5c -outline $red -width 3m -tags item + $c create rectangle 0.5c 13.5c 4.5c 15.5c -fill $green -tags item + $c create rectangle 6c 10c 9c 15c -outline {} \ + -stipple @$tk_library/demos/bitmaps/grey.25 -fill $blue -tags item + + $c create text 15c 8.2c -text Ovals -anchor n + $c create oval 11c 9.5c 14c 12.5c -outline $red -width 3m -tags item + $c create oval 10.5c 13.5c 14.5c 15.5c -fill $green -tags item + $c create oval 16c 10c 19c 15c -outline {} \ + -stipple @$tk_library/demos/bitmaps/grey.25 -fill $blue -tags item + + $c create text 25c 8.2c -text Text -anchor n + $c create rectangle 22.4c 8.9c 22.6c 9.1c + $c create text 22.5c 9c -anchor n -font $font1 -width 4c \ + -text "A short string of text, word-wrapped, justified left, and anchored north (at the top). The rectangles show the anchor points for each piece of text." -tags item + $c create rectangle 25.4c 10.9c 25.6c 11.1c + $c create text 25.5c 11c -anchor w -font $font1 -fill $blue \ + -text "Several lines,\n each centered\nindividually,\nand all anchored\nat the left edge." \ + -justify center -tags item + $c create rectangle 24.9c 13.9c 25.1c 14.1c + $c create text 25c 14c -font $font2 -anchor c -fill $red \ + -stipple @$tk_library/demos/bitmaps/grey.5 \ + -text "Stippled characters" -tags item + + $c create text 5c 16.2c -text Arcs -anchor n + $c create arc 0.5c 17c 7c 20c -fill $green -outline black \ + -start 45 -extent 270 -style pieslice -tags item + $c create arc 6.5c 17c 9.5c 20c -width 4m -style arc \ + -fill $blue -start -135 -extent 270 \ + -stipple @$tk_library/demos/bitmaps/grey.25 -tags item + $c create arc 0.5c 20c 9.5c 24c -width 4m -style pieslice \ + -fill {} -outline $red -start 225 -extent -90 -tags item + $c create arc 5.5c 20.5c 9.5c 23.5c -width 4m -style chord \ + -fill $blue -outline {} -start 45 -extent 270 -tags item + + $c create text 15c 16.2c -text Bitmaps -anchor n + $c create bitmap 13c 20c -bitmap @$tk_library/demos/bitmaps/face -tags item + $c create bitmap 17c 18.5c \ + -bitmap @$tk_library/demos/bitmaps/noletters -tags item + $c create bitmap 17c 21.5c \ + -bitmap @$tk_library/demos/bitmaps/letters -tags item + + $c create text 25c 16.2c -text Windows -anchor n + button $c.button -text "Press Me" -command "butPress $c $red" + $c create window 21c 18c -window $c.button -anchor nw -tags item + entry $c.entry -width 20 -relief sunken + $c.entry insert end "Edit this text" + $c create window 21c 21c -window $c.entry -anchor nw -tags item + scale $c.scale -from 0 -to 100 -length 6c -sliderlength .4c \ + -width .5c -tickinterval 0 + $c create window 28.5c 17.5c -window $c.scale -anchor n -tags item + $c create text 21c 17.9c -text Button: -anchor sw + $c create text 21c 20.9c -text Entry: -anchor sw + $c create text 28.5c 17.4c -text Scale: -anchor s + + # Set up event bindings for canvas: + + $c bind item "itemEnter $c" + $c bind item "itemLeave $c" + bind $c <2> "$c scan mark %x %y" + bind $c "$c scan dragto %x %y" + bind $c <3> "itemMark $c %x %y" + bind $c "itemStroke $c %x %y" + bind $c "itemsUnderArea $c" + bind $c <1> "itemStartDrag $c %x %y" + bind $c "itemDrag $c %x %y" + bind $w "focus $c" +} + +# Utility procedures for highlighting the item under the pointer: + +proc itemEnter {c} { + global restoreCmd + + if {[winfo depth $c] <= 1} { + set restoreCmd {} + return + } + set type [$c type current] + if {$type == "window"} { + set restoreCmd {} + return + } + if {$type == "bitmap"} { + set bg [lindex [$c itemconf current -background] 4] + set restoreCmd [list $c itemconfig current -background $bg] + $c itemconfig current -background SteelBlue2 + return + } + set fill [lindex [$c itemconfig current -fill] 4] + if {(($type == "rectangle") || ($type == "oval") || ($type == "arc")) + && ($fill == "")} { + set outline [lindex [$c itemconfig current -outline] 4] + set restoreCmd "$c itemconfig current -outline $outline" + $c itemconfig current -outline SteelBlue2 + } else { + set restoreCmd "$c itemconfig current -fill $fill" + $c itemconfig current -fill SteelBlue2 + } +} + +proc itemLeave {c} { + global restoreCmd + + eval $restoreCmd +} + +# Utility procedures for stroking out a rectangle and printing what's +# underneath the rectangle's area. + +proc itemMark {c x y} { + global areaX1 areaY1 + set areaX1 [$c canvasx $x] + set areaY1 [$c canvasy $y] + $c delete area +} + +proc itemStroke {c x y} { + global areaX1 areaY1 areaX2 areaY2 + set x [$c canvasx $x] + set y [$c canvasy $y] + if {($areaX1 != $x) && ($areaY1 != $y)} { + $c delete area + $c addtag area withtag [$c create rect $areaX1 $areaY1 $x $y \ + -outline black] + set areaX2 $x + set areaY2 $y + } +} + +proc itemsUnderArea {c} { + global areaX1 areaY1 areaX2 areaY2 + set area [$c find withtag area] + set items "" + foreach i [$c find enclosed $areaX1 $areaY1 $areaX2 $areaY2] { + if {[lsearch [$c gettags $i] item] != -1} { + lappend items $i + } + } + puts stdout "Items enclosed by area: $items" + set items "" + foreach i [$c find overlapping $areaX1 $areaY1 $areaX2 $areaY2] { + if {[lsearch [$c gettags $i] item] != -1} { + lappend items $i + } + } + puts stdout "Items overlapping area: $items" +} + +set areaX1 0 +set areaY1 0 +set areaX2 0 +set areaY2 0 + +# Utility procedures to support dragging of items. + +proc itemStartDrag {c x y} { + global lastX lastY + set lastX [$c canvasx $x] + set lastY [$c canvasy $y] +} + +proc itemDrag {c x y} { + global lastX lastY + set x [$c canvasx $x] + set y [$c canvasy $y] + $c move current [expr $x-$lastX] [expr $y-$lastY] + set lastX $x + set lastY $y +} + +# Procedure that's invoked when the button embedded in the canvas +# is invoked. + +proc butPress {w color} { + set i [$w create text 25c 18.1c -text "Ouch!!" -fill $color -anchor n] + after 500 "$w delete $i" +} diff --git a/gcl-tk/demos/mkLabel.lisp b/gcl-tk/demos/mkLabel.lisp new file mode 100755 index 0000000..e1c63b4 --- /dev/null +++ b/gcl-tk/demos/mkLabel.lisp @@ -0,0 +1,35 @@ +;;# mkLabel w +;; +;; Create a top-level window that displays a bunch of labels. +;; +;; Arguments: +;; w - Name to use for new top-level window. + +(in-package "TK") +(defun mkLabel (&optional (w '.l1)) +; (global :tk_library) + (if (winfo :exists w :return 'boolean) (destroy w)) + (toplevel w) + (dpos w) + (wm :title w "Label Demonstration") + (wm :iconname w "Labels") + (message (conc w '.msg) :font :Adobe-times-medium-r-normal--*-180* :aspect 300 + :text "Five labels are displayed below: three textual ones on the left, and a bitmap label and a text label on the right. Labels are pretty boring because you can't do anything with them. Click the \"OK\" button when you've seen enough.") + (frame (conc w '.left)) + (frame (conc w '.right)) + (button (conc w '.ok) :text "OK" :command `(destroy ',w)) + (pack (conc w '.msg) :side "top") + (pack (conc w '.ok) :side "bottom" :fill "x") + (pack (conc w '.left) (conc w '.right) :side "left" :expand "yes" :padx 10 :pady 10 :fill "both") + + (label (conc w '.left.l1) :text "First label") + (label (conc w '.left.l2) :text "Second label, raised just for fun" :relief "raised") + (label (conc w '.left.l3) :text "Third label, sunken" :relief "sunken") + (pack (conc w '.left.l1) (conc w '.left.l2) (conc w '.left.l3) + :side "top" :expand "yes" :pady 2 :anchor "w") + + (label (conc w '.right.bitmap) :bitmap "@": *tk-library* : "/demos/images/face" + :borderwidth 2 :relief "sunken") + (label (conc w '.right.caption) :text "Tcl/Tk Proprietor") + (pack (conc w '.right.bitmap) (conc w '.right.caption) :side "top") +) diff --git a/gcl-tk/demos/mkLabel.tcl b/gcl-tk/demos/mkLabel.tcl new file mode 100755 index 0000000..f73f1c6 --- /dev/null +++ b/gcl-tk/demos/mkLabel.tcl @@ -0,0 +1,34 @@ +# mkLabel w +# +# Create a top-level window that displays a bunch of labels. +# +# Arguments: +# w - Name to use for new top-level window. + +proc mkLabel {{w .l1}} { + global tk_library + catch {destroy $w} + toplevel $w + dpos $w + wm title $w "Label Demonstration" + wm iconname $w "Labels" + message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ + -text "Five labels are displayed below: three textual ones on the left, and a bitmap label and a text label on the right. Labels are pretty boring because you can't do anything with them. Click the \"OK\" button when you've seen enough." + frame $w.left + frame $w.right + button $w.ok -text OK -command "destroy $w" + pack $w.msg -side top + pack $w.ok -side bottom -fill x + pack $w.left $w.right -side left -expand yes -padx 10 -pady 10 -fill both + + label $w.left.l1 -text "First label" + label $w.left.l2 -text "Second label, raised just for fun" -relief raised + label $w.left.l3 -text "Third label, sunken" -relief sunken + pack $w.left.l1 $w.left.l2 $w.left.l3 \ + -side top -expand yes -pady 2 -anchor w + + label $w.right.bitmap -bitmap @$tk_library/demos/images/face.bmp \ + -borderwidth 2 -relief sunken + label $w.right.caption -text "Tcl/Tk Proprietor" + pack $w.right.bitmap $w.right.caption -side top +} diff --git a/gcl-tk/demos/mkListbox.lisp b/gcl-tk/demos/mkListbox.lisp new file mode 100755 index 0000000..821235d --- /dev/null +++ b/gcl-tk/demos/mkListbox.lisp @@ -0,0 +1,42 @@ +(in-package "TK") + +(defun mklistbox (&optional (w '.listbox)) + (toplevel w ) + (dpos w) + (wm :title w "Listbox Demonstration (50 states)") + (wm :iconname w "Listbox") + (wm :minsize w 1 1) + (message (conc w '.msg) :font :Adobe-times-medium-r-normal--*-180* :aspect 300 + :text "A listbox containing the 50 states is displayed below, along with a scrollbar. You can scan the list either using the scrollbar or by dragging in the listbox window with button 2 pressed. Click the OK button when you've seen enough.") + (frame (conc w '.frame) :borderwidth 10) + (button (conc w '.ok) :text "OK" :command `(destroy ',w)) + (pack (conc w '.frame) :side "top" :expand "yes" :fill "y") + (pack (conc w '.ok) :side "bottom" :fill "x") + (scrollbar (conc w '.frame '.scroll) :relief "sunken" :command + (tk-conc w ".frame.list yview")) + (listbox (conc w '.frame.list) :yscroll (tk-conc w ".frame.scroll set") + :relief "sunken" + :setgrid 1) + (pack (conc w '.frame.scroll) :side "right" :fill "y") + (pack (conc w '.frame.list) :side "left" :expand "yes" :fill "both") + (funcall (conc w '.frame.list) + :insert 0 + "Alabama" "Alaska" "Arizona" "Arkansas" "California" + "Colorado" "Connecticut" "Delaware" "Florida" "Georgia" "Hawaii" "Idaho" "Illinois" + "Indiana" "Iowa" "Kansas" "Kentucky" "Louisiana" "Maine" "Maryland" + "Massachusetts" "Michigan" "Minnesota" "Mississippi" "Missouri" + "Montana" "Nebraska" "Nevada" "New Hampshire" "New Jersey" "New Mexico" + "New York" "North Carolina" "North Dakota" + "Ohio" "Oklahoma" "Oregon" "Pennsylvania" "Rhode Island" + "South Carolina" "South Dakota" + "Tennessee" "Texas" "Utah" "Vermont" "Virginia" "Washington" + "West Virginia" "Wisconsin" "Wyoming") + w) + + + + + + + + diff --git a/gcl-tk/demos/mkListbox.tcl b/gcl-tk/demos/mkListbox.tcl new file mode 100755 index 0000000..a116170 --- /dev/null +++ b/gcl-tk/demos/mkListbox.tcl @@ -0,0 +1,41 @@ +# mkListbox w +# +# Create a top-level window that displays a listbox with the names of the +# 50 states. +# +# Arguments: +# w - Name to use for new top-level window. + +proc mkListbox {{w .l1}} { + catch {destroy $w} + toplevel $w + dpos $w + wm title $w "Listbox Demonstration (50 states)" + wm iconname $w "Listbox" + wm minsize $w 1 1 + + message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ + -text "A listbox containing the 50 states is displayed below, along with a scrollbar. You can scan the list either using the scrollbar or by dragging in the listbox window with button 2 pressed. Click the \"OK\" button when you've seen enough." + frame $w.frame -borderwidth 10 + button $w.ok -text OK -command "destroy $w" + pack $w.msg -side top + pack $w.frame -side top -expand yes -fill y + pack $w.ok -side bottom -fill x + + scrollbar $w.frame.scroll -relief sunken -command "$w.frame.list yview" + listbox $w.frame.list -yscroll "$w.frame.scroll set" -relief sunken \ + -setgrid 1 + pack $w.frame.scroll -side right -fill y + pack $w.frame.list -side left -expand yes -fill both + + $w.frame.list insert 0 Alabama Alaska Arizona Arkansas California \ + Colorado Connecticut Delaware Florida Georgia Hawaii Idaho Illinois \ + Indiana Iowa Kansas Kentucky Louisiana Maine Maryland \ + Massachusetts Michigan Minnesota Mississippi Missouri \ + Montana Nebraska Nevada "New Hampshire" "New Jersey" "New Mexico" \ + "New York" "North Carolina" "North Dakota" \ + Ohio Oklahoma Oregon Pennsylvania "Rhode Island" \ + "South Carolina" "South Dakota" \ + Tennessee Texas Utah Vermont Virginia Washington \ + "West Virginia" Wisconsin Wyoming +} diff --git a/gcl-tk/demos/mkListbox2.tcl b/gcl-tk/demos/mkListbox2.tcl new file mode 100755 index 0000000..008ea17 --- /dev/null +++ b/gcl-tk/demos/mkListbox2.tcl @@ -0,0 +1,95 @@ +# mkListbox2 w +# +# Create a top-level window containing a listbox showing a bunch of +# colors from the X color database. +# +# Arguments: +# w - Name to use for new top-level window. + +proc mkListbox2 {{w .l2}} { + catch {destroy $w} + toplevel $w + dpos $w + wm title $w "Listbox Demonstration (colors)" + wm iconname $w "Listbox" + wm minsize $w 1 1 + + message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ + -text "A listbox containing several color values is displayed below, along with a scrollbar. You can scan the list either using the scrollbar or by dragging in the listbox window with button 2 pressed. If you double-click button 1 on a color, then the background for the window will be changed to that color. Click the \"OK\" button when you've seen enough." + frame $w.frame -borderwidth 10 + button $w.ok -text OK -command "destroy $w" + pack $w.msg -side top + pack $w.ok -side bottom -fill x + pack $w.frame -side top -expand yes -fill y + + scrollbar $w.frame.scroll -relief sunken -command "$w.frame.list yview" + listbox $w.frame.list -yscroll "$w.frame.scroll set" -relief sunken \ + -setgrid 1 + pack $w.frame.list $w.frame.scroll -side left -fill y + + $w.frame.list insert 0 snow1 snow2 snow3 snow4 seashell1 seashell2 \ + seashell3 seashell4 AntiqueWhite1 AntiqueWhite2 AntiqueWhite3 \ + AntiqueWhite4 bisque1 bisque2 bisque3 bisque4 PeachPuff1 \ + PeachPuff2 PeachPuff3 PeachPuff4 NavajoWhite1 NavajoWhite2 \ + NavajoWhite3 NavajoWhite4 LemonChiffon1 LemonChiffon2 \ + LemonChiffon3 LemonChiffon4 cornsilk1 cornsilk2 cornsilk3 \ + cornsilk4 ivory1 ivory2 ivory3 ivory4 honeydew1 honeydew2 \ + honeydew3 honeydew4 LavenderBlush1 LavenderBlush2 \ + LavenderBlush3 LavenderBlush4 MistyRose1 MistyRose2 \ + MistyRose3 MistyRose4 azure1 azure2 azure3 azure4 \ + SlateBlue1 SlateBlue2 SlateBlue3 SlateBlue4 RoyalBlue1 \ + RoyalBlue2 RoyalBlue3 RoyalBlue4 blue1 blue2 blue3 blue4 \ + DodgerBlue1 DodgerBlue2 DodgerBlue3 DodgerBlue4 SteelBlue1 \ + SteelBlue2 SteelBlue3 SteelBlue4 DeepSkyBlue1 DeepSkyBlue2 \ + DeepSkyBlue3 DeepSkyBlue4 SkyBlue1 SkyBlue2 SkyBlue3 \ + SkyBlue4 LightSkyBlue1 LightSkyBlue2 LightSkyBlue3 \ + LightSkyBlue4 SlateGray1 SlateGray2 SlateGray3 SlateGray4 \ + LightSteelBlue1 LightSteelBlue2 LightSteelBlue3 \ + LightSteelBlue4 LightBlue1 LightBlue2 LightBlue3 \ + LightBlue4 LightCyan1 LightCyan2 LightCyan3 LightCyan4 \ + PaleTurquoise1 PaleTurquoise2 PaleTurquoise3 PaleTurquoise4 \ + CadetBlue1 CadetBlue2 CadetBlue3 CadetBlue4 turquoise1 \ + turquoise2 turquoise3 turquoise4 cyan1 cyan2 cyan3 cyan4 \ + DarkSlateGray1 DarkSlateGray2 DarkSlateGray3 \ + DarkSlateGray4 aquamarine1 aquamarine2 aquamarine3 \ + aquamarine4 DarkSeaGreen1 DarkSeaGreen2 DarkSeaGreen3 \ + DarkSeaGreen4 SeaGreen1 SeaGreen2 SeaGreen3 SeaGreen4 \ + PaleGreen1 PaleGreen2 PaleGreen3 PaleGreen4 SpringGreen1 \ + SpringGreen2 SpringGreen3 SpringGreen4 green1 green2 \ + green3 green4 chartreuse1 chartreuse2 chartreuse3 \ + chartreuse4 OliveDrab1 OliveDrab2 OliveDrab3 OliveDrab4 \ + DarkOliveGreen1 DarkOliveGreen2 DarkOliveGreen3 \ + DarkOliveGreen4 khaki1 khaki2 khaki3 khaki4 \ + LightGoldenrod1 LightGoldenrod2 LightGoldenrod3 \ + LightGoldenrod4 LightYellow1 LightYellow2 LightYellow3 \ + LightYellow4 yellow1 yellow2 yellow3 yellow4 gold1 gold2 \ + gold3 gold4 goldenrod1 goldenrod2 goldenrod3 goldenrod4 \ + DarkGoldenrod1 DarkGoldenrod2 DarkGoldenrod3 DarkGoldenrod4 \ + RosyBrown1 RosyBrown2 RosyBrown3 RosyBrown4 IndianRed1 \ + IndianRed2 IndianRed3 IndianRed4 sienna1 sienna2 sienna3 \ + sienna4 burlywood1 burlywood2 burlywood3 burlywood4 wheat1 \ + wheat2 wheat3 wheat4 tan1 tan2 tan3 tan4 chocolate1 \ + chocolate2 chocolate3 chocolate4 firebrick1 firebrick2 \ + firebrick3 firebrick4 brown1 brown2 brown3 brown4 salmon1 \ + salmon2 salmon3 salmon4 LightSalmon1 LightSalmon2 \ + LightSalmon3 LightSalmon4 orange1 orange2 orange3 orange4 \ + DarkOrange1 DarkOrange2 DarkOrange3 DarkOrange4 coral1 \ + coral2 coral3 coral4 tomato1 tomato2 tomato3 tomato4 \ + OrangeRed1 OrangeRed2 OrangeRed3 OrangeRed4 red1 red2 red3 \ + red4 DeepPink1 DeepPink2 DeepPink3 DeepPink4 HotPink1 \ + HotPink2 HotPink3 HotPink4 pink1 pink2 pink3 pink4 \ + LightPink1 LightPink2 LightPink3 LightPink4 PaleVioletRed1 \ + PaleVioletRed2 PaleVioletRed3 PaleVioletRed4 maroon1 \ + maroon2 maroon3 maroon4 VioletRed1 VioletRed2 VioletRed3 \ + VioletRed4 magenta1 magenta2 magenta3 magenta4 orchid1 \ + orchid2 orchid3 orchid4 plum1 plum2 plum3 plum4 \ + MediumOrchid1 MediumOrchid2 MediumOrchid3 MediumOrchid4 \ + DarkOrchid1 DarkOrchid2 DarkOrchid3 DarkOrchid4 purple1 \ + purple2 purple3 purple4 MediumPurple1 MediumPurple2 \ + MediumPurple3 MediumPurple4 thistle1 thistle2 thistle3 \ + thistle4 + bind $w.frame.list \ + "$w config -bg \[lindex \[selection get\] 0\] + $w.frame config -bg \[lindex \[selection get\] 0\] + $w.msg config -bg \[lindex \[selection get\] 0\]" +} diff --git a/gcl-tk/demos/mkListbox3.tcl b/gcl-tk/demos/mkListbox3.tcl new file mode 100755 index 0000000..7d8b9eb --- /dev/null +++ b/gcl-tk/demos/mkListbox3.tcl @@ -0,0 +1,34 @@ +# mkListbox3 w +# +# Create a top-level window containing a listbox with a bunch of well-known +# sayings. The listbox can be scrolled or scanned in two dimensions. +# +# Arguments: +# w - Name to use for new top-level window. + +proc mkListbox3 {{w .l3}} { + catch {destroy $w} + toplevel $w + dpos $w + wm title $w "Listbox Demonstration (well-known sayings)" + wm iconname $w "Listbox" + wm minsize $w 1 1 + message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ + -text "The listbox below contains a collection of well-known sayings. You can scan the list using either of the scrollbars or by dragging in the listbox window with button 2 pressed. Click the \"OK\" button when you're done." + frame $w.frame -borderwidth 10 + button $w.ok -text OK -command "destroy $w" + pack $w.msg -side top + pack $w.ok -side bottom -fill x + pack $w.frame -side top -expand yes -fill y + + scrollbar $w.frame.yscroll -relief sunken -command "$w.frame.list yview" + scrollbar $w.frame.xscroll -relief sunken -orient horizontal \ + -command "$w.frame.list xview" + listbox $w.frame.list -width 20 -height 10 -yscroll "$w.frame.yscroll set" \ + -xscroll "$w.frame.xscroll set" -relief sunken -setgrid 1 + pack $w.frame.yscroll -side right -fill y + pack $w.frame.xscroll -side bottom -fill x + pack $w.frame.list -expand yes -fill y + + $w.frame.list insert 0 "Waste not, want not" "Early to bed and early to rise makes a man healthy, wealthy, and wise" "Ask not what your country can do for you, ask what you can do for your country" "I shall return" "NOT" "A picture is worth a thousand words" "User interfaces are hard to build" "Thou shalt not steal" "A penny for your thoughts" "Fool me once, shame on you; fool me twice, shame on me" "Every cloud has a silver lining" "Where there's smoke there's fire" "It takes one to know one" "Curiosity killed the cat" "Take this job and shove it" "Up a creek without a paddle" "I'm mad as hell and I'm not going to take it any more" "An apple a day keeps the doctor away" "Don't look a gift horse in the mouth" +} diff --git a/gcl-tk/demos/mkPlot.lisp b/gcl-tk/demos/mkPlot.lisp new file mode 100755 index 0000000..01c58a6 --- /dev/null +++ b/gcl-tk/demos/mkPlot.lisp @@ -0,0 +1,81 @@ +(in-package "TK") +;;# mkPlot w +;; +;; Create a top-level window containing a canvas displaying a simple +;; graph with data points that can be moved interactively. +;; +;; Arguments: +;; w - Name to use for new top-level window. + +(defun mkPlot ( &optional (w '.plot ) &aux c font x y item) + (toplevel w ) + (dpos w) + (wm :title w "Plot Demonstration " : w) + (wm :iconname w "Plot") + (setq c (conc w '.c)) + + (message (conc w '.msg) :font :Adobe-Times-Medium-R-Normal-*-180-* :width 400 + :bd 2 :relief "raised" :text "This window displays a canvas widget containing a simple 2-dimensional plot. You can doctor the data by dragging any of the points with mouse button 1.") + (canvas c :relief "raised" :width 450 :height 300) + (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) + (pack (conc w '.msg) (conc w '.c) :side "top" :fill "x") + (pack (conc w '.ok) :side "bottom" :pady 5) + + (setq font :Adobe-helvetica-medium-r-*-180-*) + + (funcall c :create "line" 100 250 400 250 :width 2) + (funcall c :create "line" 100 250 100 50 :width 2) + (funcall c :create "text" 225 20 :text "A Simple Plot" :font font :fill "brown") + + (sloop for i to 10 do + (setq x (+ 100 (* i 30))) + (funcall c :create "line" x 250 x 245 :width 2) + (funcall c :create "text" x 254 :text (* 10 i) :anchor "n" :font font)) + + (sloop for i to 5 do + (setq y (- 250 (* i 40))) + (funcall c :create "line" 100 y 105 y :width 2) + (funcall c :create "text" 96 y :text (* i 50) : ".0" :anchor "e" :font font)) + + (sloop for point in '((12 56) (20 94) (33 98) (32 120) (61 180) + (75 160) (98 223)) + do + (setq x (+ 100 (* 3 (nth 0 point)))) + (setq y (- 250 (truncate (* 4 (nth 1 point)) 5))) + (setq item (funcall c :create "oval" (- x 6) (- y 6) + (+ x 6) (+ y 6) :width 1 :outline "black" + :fill "SkyBlue2" :return 'string )) + (funcall c :addtag "point" "withtag" item) + ) + + + (funcall c :bind "point" "" c : " itemconfig current -fill red") + (funcall c :bind "point" "" c : " itemconfig current -fill SkyBlue2") + (funcall c :bind "point" "<1>" `(plotdown ',c |%x| |%y|)) + (funcall c :bind "point" "" c : " dtag selected") + (bind c "" `(plotmove ',c |%x| |%y|)) +) + +(defvar plotlastX 0) +(defvar plotlastY 0) + +(defun plotDown (w x y) + (funcall w :dtag "selected") + (funcall w :addtag "selected" "withtag" "current") + (funcall w :raise "current") + (setq plotlastY y) + (setq plotlastX x) +) + +(defun plotMove (w x y &aux ) + (let ((oldx plotlastX) + (oldy plotlastY)) + ;; Note plotmove may be called recursively... since + ;; the funcall may call something which calls this. + ;; so we must set the global plotlastx before the funcall.. + (setq plotlastx x) + (setq plotlastY y) + (funcall w :move "selected" (- x oldx) (- y oldy)) + ) + ) + diff --git a/gcl-tk/demos/mkPlot.tcl b/gcl-tk/demos/mkPlot.tcl new file mode 100755 index 0000000..6cecea6 --- /dev/null +++ b/gcl-tk/demos/mkPlot.tcl @@ -0,0 +1,75 @@ +# mkPlot w +# +# Create a top-level window containing a canvas displaying a simple +# graph with data points that can be moved interactively. +# +# Arguments: +# w - Name to use for new top-level window. + +proc mkPlot {{w .plot}} { + catch {destroy $w} + toplevel $w + dpos $w + wm title $w "Plot Demonstration" + wm iconname $w "Plot" + set c $w.c + + message $w.msg -font -Adobe-Times-Medium-R-Normal-*-180-* -width 400 \ + -bd 2 -relief raised -text "This window displays a canvas widget containing a simple 2-dimensional plot. You can doctor the data by dragging any of the points with mouse button 1." + canvas $c -relief raised -width 450 -height 300 + button $w.ok -text "OK" -command "destroy $w" + pack $w.msg $w.c -side top -fill x + pack $w.ok -side bottom -pady 5 + + set font -Adobe-helvetica-medium-r-*-180-* + + $c create line 100 250 400 250 -width 2 + $c create line 100 250 100 50 -width 2 + $c create text 225 20 -text "A Simple Plot" -font $font -fill brown + + for {set i 0} {$i <= 10} {incr i} { + set x [expr {100 + ($i*30)}] + $c create line $x 250 $x 245 -width 2 + $c create text $x 254 -text [expr 10*$i] -anchor n -font $font + } + for {set i 0} {$i <= 5} {incr i} { + set y [expr {250 - ($i*40)}] + $c create line 100 $y 105 $y -width 2 + $c create text 96 $y -text [expr $i*50].0 -anchor e -font $font + } + + foreach point {{12 56} {20 94} {33 98} {32 120} {61 180} + {75 160} {98 223}} { + set x [expr {100 + (3*[lindex $point 0])}] + set y [expr {250 - (4*[lindex $point 1])/5}] + set item [$c create oval [expr $x-6] [expr $y-6] \ + [expr $x+6] [expr $y+6] -width 1 -outline black \ + -fill SkyBlue2] + $c addtag point withtag $item + } + + $c bind point "$c itemconfig current -fill red" + $c bind point "$c itemconfig current -fill SkyBlue2" + $c bind point <1> "plotDown $c %x %y" + $c bind point "$c dtag selected" + bind $c "plotMove $c %x %y" +} + +set plot(lastX) 0 +set plot(lastY) 0 + +proc plotDown {w x y} { + global plot + $w dtag selected + $w addtag selected withtag current + $w raise current + set plot(lastX) $x + set plot(lastY) $y +} + +proc plotMove {w x y} { + global plot + $w move selected [expr $x-$plot(lastX)] [expr $y-$plot(lastY)] + set plot(lastX) $x + set plot(lastY) $y +} diff --git a/gcl-tk/demos/mkPuzzle.tcl b/gcl-tk/demos/mkPuzzle.tcl new file mode 100755 index 0000000..1e8d226 --- /dev/null +++ b/gcl-tk/demos/mkPuzzle.tcl @@ -0,0 +1,59 @@ +# mkPuzzle w +# +# Create a top-level window containing a 15-puzzle game. +# +# Arguments: +# w - Name to use for new top-level window. + +proc mkPuzzle {{w .p1}} { + global xpos ypos + catch {destroy $w} + toplevel $w + dpos $w + wm title $w "15-Puzzle Demonstration" + wm iconname $w "15-Puzzle" + + message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ + -text "A 15-puzzle appears below as a collection of buttons. Click on any of the pieces next to the space, and that piece will slide over the space. Continue this until the pieces are arranged in numerical order from upper-left to lower-right. Click the \"OK\" button when you've finished playing." + frame $w.frame -width 120 -height 120 -borderwidth 2 -relief sunken \ + -bg Bisque3 + button $w.ok -text OK -command "destroy $w" + pack $w.msg -side top + pack $w.frame -side top -padx 5 -pady 5 + pack $w.ok -side bottom -fill x + + set order {3 1 6 2 5 7 15 13 4 11 8 9 14 10 12} + for {set i 0} {$i < 15} {set i [expr $i+1]} { + set num [lindex $order $i] + set xpos($num) [expr ($i%4)*.25] + set ypos($num) [expr ($i/4)*.25] + button $w.frame.$num -relief raised -text $num \ + -command "puzzle.switch $w $num" + place $w.frame.$num -relx $xpos($num) -rely $ypos($num) \ + -relwidth .25 -relheight .25 + } + set xpos(space) .75 + set ypos(space) .75 +} + +# Procedure invoked by buttons in the puzzle to resize the puzzle entries: + +proc puzzle.switch {w num} { + global xpos ypos + if {(($ypos($num) >= ($ypos(space) - .01)) + && ($ypos($num) <= ($ypos(space) + .01)) + && ($xpos($num) >= ($xpos(space) - .26)) + && ($xpos($num) <= ($xpos(space) + .26))) + || (($xpos($num) >= ($xpos(space) - .01)) + && ($xpos($num) <= ($xpos(space) + .01)) + && ($ypos($num) >= ($ypos(space) - .26)) + && ($ypos($num) <= ($ypos(space) + .26)))} { + set tmp $xpos(space) + set xpos(space) $xpos($num) + set xpos($num) $tmp + set tmp $ypos(space) + set ypos(space) $ypos($num) + set ypos($num) $tmp + place $w.frame.$num -relx $xpos($num) -rely $ypos($num) + } +} diff --git a/gcl-tk/demos/mkRadio.lisp b/gcl-tk/demos/mkRadio.lisp new file mode 100755 index 0000000..8f5a4ce --- /dev/null +++ b/gcl-tk/demos/mkRadio.lisp @@ -0,0 +1,61 @@ +(in-package "TK") +;;# mkRadio w +;; +;; Create a top-level window that displays a bunch of radio buttons. +;; +;; Arguments: +;; w - Name to use for new top-level window. + +(defun mkRadio (&optional (w '.r1)) + (if (winfo :exists w :return 'boolean) (destroy w)) + (toplevel w) + (dpos w) + (wm :title w "Radiobutton Demonstration") + (wm :iconname w "Radiobuttons") + (message (conc w '.msg) :font :Adobe-times-medium-r-normal--*-180* :aspect 300 + :text "Two groups of radiobuttons are displayed below. If you click on a button then the button will become selected exclusively among all the buttons in its group. A Tcl variable is associated with each group to indicate which of the group's buttons is selected. Click the \"See Variables\" button to see the current values of the variables. Click the \"OK\" button when you've seen enough.") + (frame (conc w '.frame) :borderwidth 10) + (frame (conc w '.frame2)) + (pack (conc w '.msg) :side "top") + (pack (conc w '.msg) :side "top") + (pack (conc w '.frame) :side "top" :fill "x" :pady 10) + (pack (conc w '.frame2) :side "bottom" :fill "x") + + (frame (conc w '.frame.left)) + (frame (conc w '.frame.right)) + (pack (conc w '.frame.left) (conc w '.frame.right) :side "left" :expand "yes") + + (radiobutton (conc w '.frame.left.b1) :text "Point Size 10" :variable 'size + :relief "flat" :value 10) + (radiobutton (conc w '.frame.left.b2) :text "Point Size 12" :variable 'size + :relief "flat" :value 12) + (radiobutton (conc w '.frame.left.b3) :text "Point Size 18" :variable 'size + :relief "flat" :value 18) + (radiobutton (conc w '.frame.left.b4) :text "Point Size 24" :variable 'size + :relief "flat" :value 24) + (pack (conc w '.frame.left.b1) (conc w '.frame.left.b2) (conc w '.frame.left.b3) (conc w '.frame.left.b4) + :side "top" :pady 2 :anchor "w") + + (radiobutton (conc w '.frame.right.b1) :text "Red" :variable 'color + :relief "flat" :value "red") + (radiobutton (conc w '.frame.right.b2) :text "Green" :variable 'color + :relief "flat" :value "green") + (radiobutton (conc w '.frame.right.b3) :text "Blue" :variable 'color + :relief "flat" :value "blue") + (radiobutton (conc w '.frame.right.b4) :text "Yellow" :variable 'color + :relief "flat" :value "yellow") + (radiobutton (conc w '.frame.right.b5) :text "Orange" :variable 'color + :relief "flat" :value "orange") + (radiobutton (conc w '.frame.right.b6) :text "Purple" :variable 'color + :relief "flat" :value "purple") + (pack (conc w '.frame.right.b1) (conc w '.frame.right.b2) (conc w '.frame.right.b3) + (conc w '.frame.right.b4) (conc w '.frame.right.b5) (conc w '.frame.right.b6) + :side "top" :pady 2 :anchor "w") + + (button (conc w '.frame2.ok) :text "OK" :command (tk-conc "destroy " w) :width 12) + (button (conc w '.frame2.vars) :text "See Variables" :width 12 + :command `(showvars (conc ',w '.dialog) '(size color))) + (pack (conc w '.frame2.ok) (conc w '.frame2.vars) :side "left" :expand "yes" :fill "x") +) + + diff --git a/gcl-tk/demos/mkRadio.tcl b/gcl-tk/demos/mkRadio.tcl new file mode 100755 index 0000000..0087fef --- /dev/null +++ b/gcl-tk/demos/mkRadio.tcl @@ -0,0 +1,58 @@ +# mkRadio w +# +# Create a top-level window that displays a bunch of radio buttons. +# +# Arguments: +# w - Name to use for new top-level window. + +proc mkRadio {{w .r1}} { + catch {destroy $w} + toplevel $w + dpos $w + wm title $w "Radiobutton Demonstration" + wm iconname $w "Radiobuttons" + message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ + -text "Two groups of radiobuttons are displayed below. If you click on a button then the button will become selected exclusively among all the buttons in its group. A Tcl variable is associated with each group to indicate which of the group's buttons is selected. Click the \"See Variables\" button to see the current values of the variables. Click the \"OK\" button when you've seen enough." + frame $w.frame -borderwidth 10 + frame $w.frame2 + pack $w.msg -side top + pack $w.msg -side top + pack $w.frame -side top -fill x -pady 10 + pack $w.frame2 -side bottom -fill x + + frame $w.frame.left + frame $w.frame.right + pack $w.frame.left $w.frame.right -side left -expand yes + + radiobutton $w.frame.left.b1 -text "Point Size 10" -variable size \ + -relief flat -value 10 + radiobutton $w.frame.left.b2 -text "Point Size 12" -variable size \ + -relief flat -value 12 + radiobutton $w.frame.left.b3 -text "Point Size 18" -variable size \ + -relief flat -value 18 + radiobutton $w.frame.left.b4 -text "Point Size 24" -variable size \ + -relief flat -value 24 + pack $w.frame.left.b1 $w.frame.left.b2 $w.frame.left.b3 $w.frame.left.b4 \ + -side top -pady 2 -anchor w + + radiobutton $w.frame.right.b1 -text "Red" -variable color \ + -relief flat -value red + radiobutton $w.frame.right.b2 -text "Green" -variable color \ + -relief flat -value green + radiobutton $w.frame.right.b3 -text "Blue" -variable color \ + -relief flat -value blue + radiobutton $w.frame.right.b4 -text "Yellow" -variable color \ + -relief flat -value yellow + radiobutton $w.frame.right.b5 -text "Orange" -variable color \ + -relief flat -value orange + radiobutton $w.frame.right.b6 -text "Purple" -variable color \ + -relief flat -value purple + pack $w.frame.right.b1 $w.frame.right.b2 $w.frame.right.b3 \ + $w.frame.right.b4 $w.frame.right.b5 $w.frame.right.b6 \ + -side top -pady 2 -anchor w + + button $w.frame2.ok -text OK -command "destroy $w" -width 12 + button $w.frame2.vars -text "See Variables" -width 12\ + -command "showVars $w.dialog size color" + pack $w.frame2.ok $w.frame2.vars -side left -expand yes -fill x +} diff --git a/gcl-tk/demos/mkRuler.lisp b/gcl-tk/demos/mkRuler.lisp new file mode 100755 index 0000000..33bbb04 --- /dev/null +++ b/gcl-tk/demos/mkRuler.lisp @@ -0,0 +1,140 @@ +;;# mkRuler w +;; +;; Create a canvas demonstration consisting of a ruler. +;; +;; Arguments: +;; w - Name to use for new top-level window. +;; This file implements a canvas widget that displays a ruler with tab stops +;; that can be set individually. The only procedure that should be invoked +;; from outside the file is the first one, which creates the canvas. + +(in-package "TK") + +(defun mkRuler (&optional (w '.ruler)) + (if (winfo :exists w :return 'boolean) (destroy w)) + (toplevel w) + (dpos w) + (wm :title w "Ruler Demonstration") + (wm :iconname w "Ruler") + (setq c (conc w '.c)) + + (message (conc w '.msg) :font :Adobe-Times-Medium-R-Normal-*-180-* :width "13c" + :relief "raised" :bd 2 :text "This canvas widget shows a mock-up of a ruler. You can create tab stops by dragging them out of the well to the right of the ruler. You can also drag existing tab stops. (if :you drag a tab stop far enough up or down so that it turns dim, it will be deleted when you release the mouse button.") + (canvas c :width "14.8c" :height "2.5c" :relief "raised") + (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) + (pack (conc w '.msg) (conc w '.c) :side "top" :fill "x") + (pack (conc w '.ok) :side "bottom" :pady 5) + (setf *v* (gensym)) + (setf (get *v* 'grid) '.25c) + (setf (get *v* 'left) (winfo :fpixels c "1c" :return t)) + (setf (get *v* 'right) (winfo :fpixels c "13c" :return t)) + (setf (get *v* 'top) (winfo :fpixels c "1c" :return t)) + (setf (get *v* 'bottom) (winfo :fpixels c "1.5c" :return t)) + (setf (get *v* 'size) (winfo :fpixels c '.2c :return t)) + (setf (get *v* 'normalStyle) '(:fill "black")) + (if (> (read-from-string (winfo :depth c)) 1) + (progn + (setf (get *v* 'activeStyle) '(:fill "red" :stipple "")) + (setf (get *v* 'deleteStyle) + `(:stipple "@" : ,*tk-library* :"/demos/bitmaps/grey.25" + :fill "red")) + );;else + (progn + (setf (get *v* 'activeStyle) '(:fill "black" :stipple "" )) + (setf (get *v* 'deleteStyle) + `(:stipple "@" : ,*tk-library* : "/demos/bitmaps/grey.25" + :fill "black")) + )) + + (funcall c :create "line" "1c" "0.5c" "1c" "1c" "13c" "1c" "13c" "0.5c" :width 1) + (dotimes + (i 12) + (let (( x (+ i 1))) + (funcall c :create "line" x :"c" "1c" x :"c" "0.6c" :width 1) + (funcall c :create "line" x :".25c" "1c" x :".25c" "0.8c" :width 1) + (funcall c :create "line" x :".5c" "1c" x :".5c" "0.7c" :width 1) + (funcall c :create "line" x :".75c" "1c" x :".75c" "0.8c" :width 1) + (funcall c :create "text" x :".15c" '.75c :text i :anchor "sw") + )) + (funcall c :addtag "well" "withtag" + (funcall c :create "rect" "13.2c" "1c" "13.8c" "0.5c" + :outline "black" :fill + (nth 4 (funcall c :config :background + :return 'list-strings)))) + (funcall c :addtag "well" "withtag" + (rulerMkTab c (winfo :pixels c "13.5c" :return t) + (winfo :pixels c '.65c :return t))) + + (funcall c :bind "well" "<1>" `(rulerNewTab ',c |%x| |%y|)) + (funcall c :bind "tab" "<1>" `(demo_selectTab ',c |%x| |%y|)) + (bind c "" `(rulerMoveTab ',c |%x| |%y|)) + (bind c "" `(rulerReleaseTab ',c)) +) + +(defun rulerMkTab (c x y) + + (funcall c :create "polygon" x y (+ x (get *v* 'size)) + (+ y (get *v* 'size)) + (- x (get *v* 'size)) + (+ y (get *v* 'size)) + :return 'string + ) + +) + +(defun rulerNewTab (c x y) + + (funcall c :addtag "active" "withtag" (rulerMkTab c x y)) + (funcall c :addtag "tab" "withtag" "active") + (setf (get *v* 'x) x) + (setf (get *v* 'y) y) + (rulerMoveTab c x y) +) +(defvar *recursive* nil) +;; prevent recursive calls +(defun rulerMoveTab (c x y &aux cx cy (*recursive* *recursive*) ) + (cond (*recursive* (return-from rulerMoveTab)) + (t (setq *recursive* t))) + (if (equal (funcall c :find "withtag" "active" :return 'string) "") + (return-from rulerMoveTab nil)) + (setq cx (funcall c :canvasx x (get *v* 'grid) :return t)) + (setq cy (funcall c :canvasy y :return t)) + (if (< cx (get *v* 'left))(setq cx (get *v* 'left))) + (if (> cx (get *v* 'right))(setq cx (get *v* 'right))) + + (if (and (>= cy (get *v* 'top)) (<= cy (get *v* 'bottom))) + (progn + (setq cy (+ 2 (get *v* 'top))) + (apply c :itemconf "active" (get *v* 'activestyle))) + + (progn + (setq cy (- cy (get *v* 'size) 2)) + (apply c :itemconf "active"(get *v* 'deletestyle))) + ) + (funcall c :move "active" (- cx (get *v* 'x)) + (- cy (get *v* 'y)) ) + (setf (get *v* 'x) cx) + (setf (get *v* 'y) cy) + ) + +(defun demo_selectTab (c x y) + + (setf (get *v* 'x) (funcall c :canvasx x (get *v* 'grid) :return t)) + (setf (get *v* 'y) (+ 2 (get *v* 'top))) + (funcall c :addtag "active" "withtag" "current") + (apply c :itemconf "active" (get *v* 'activeStyle)) + (funcall c :raise "active") +) + +(defun rulerReleaseTab (c ) + + (if (equal (funcall c :find "withtag" "active" :return 'string) + "") (return-from rulerReleaseTab nil)) + + (if (not (eql (get *v* 'y) (+ 2 (get *v* 'top)))) + (funcall c :delete "active") + (progn + (apply c :itemconf "active" (get *v* 'normalStyle)) + (funcall c :dtag "active") + ) +)) diff --git a/gcl-tk/demos/mkRuler.tcl b/gcl-tk/demos/mkRuler.tcl new file mode 100755 index 0000000..da861f8 --- /dev/null +++ b/gcl-tk/demos/mkRuler.tcl @@ -0,0 +1,125 @@ +# mkRuler w +# +# Create a canvas demonstration consisting of a ruler. +# +# Arguments: +# w - Name to use for new top-level window. +# This file implements a canvas widget that displays a ruler with tab stops +# that can be set individually. The only procedure that should be invoked +# from outside the file is the first one, which creates the canvas. + +proc mkRuler {{w .ruler}} { + global tk_library + upvar #0 demo_rulerInfo v + catch {destroy $w} + toplevel $w + dpos $w + wm title $w "Ruler Demonstration" + wm iconname $w "Ruler" + set c $w.c + + message $w.msg -font -Adobe-Times-Medium-R-Normal-*-180-* -width 13c \ + -relief raised -bd 2 -text "This canvas widget shows a mock-up of a ruler. You can create tab stops by dragging them out of the well to the right of the ruler. You can also drag existing tab stops. If you drag a tab stop far enough up or down so that it turns dim, it will be deleted when you release the mouse button." + canvas $c -width 14.8c -height 2.5c -relief raised + button $w.ok -text "OK" -command "destroy $w" + pack $w.msg $w.c -side top -fill x + pack $w.ok -side bottom -pady 5 + + set v(grid) .25c + set v(left) [winfo fpixels $c 1c] + set v(right) [winfo fpixels $c 13c] + set v(top) [winfo fpixels $c 1c] + set v(bottom) [winfo fpixels $c 1.5c] + set v(size) [winfo fpixels $c .2c] + set v(normalStyle) "-fill black" + if {[winfo depth $c] > 1} { + set v(activeStyle) "-fill red -stipple {}" + set v(deleteStyle) "-stipple @$tk_library/demos/bitmaps/grey.25 \ + -fill red" + } else { + set v(activeStyle) "-fill black -stipple {}" + set v(deleteStyle) "-stipple @$tk_library/demos/bitmaps/grey.25 \ + -fill black" + } + + $c create line 1c 0.5c 1c 1c 13c 1c 13c 0.5c -width 1 + for {set i 0} {$i < 12} {incr i} { + set x [expr $i+1] + $c create line ${x}c 1c ${x}c 0.6c -width 1 + $c create line $x.25c 1c $x.25c 0.8c -width 1 + $c create line $x.5c 1c $x.5c 0.7c -width 1 + $c create line $x.75c 1c $x.75c 0.8c -width 1 + $c create text $x.15c .75c -text $i -anchor sw + } + $c addtag well withtag [$c create rect 13.2c 1c 13.8c 0.5c \ + -outline black -fill [lindex [$c config -bg] 4]] + $c addtag well withtag [rulerMkTab $c [winfo pixels $c 13.5c] \ + [winfo pixels $c .65c]] + + $c bind well <1> "rulerNewTab $c %x %y" + $c bind tab <1> "demo_selectTab $c %x %y" + bind $c "rulerMoveTab $c %x %y" + bind $c "rulerReleaseTab $c" +} + +proc rulerMkTab {c x y} { + upvar #0 demo_rulerInfo v + $c create polygon $x $y [expr $x+$v(size)] [expr $y+$v(size)] \ + [expr $x-$v(size)] [expr $y+$v(size)] +} + +proc rulerNewTab {c x y} { + upvar #0 demo_rulerInfo v + $c addtag active withtag [rulerMkTab $c $x $y] + $c addtag tab withtag active + set v(x) $x + set v(y) $y + rulerMoveTab $c $x $y +} + +proc rulerMoveTab {c x y} { + upvar #0 demo_rulerInfo v + if {[$c find withtag active] == ""} { + return + } + set cx [$c canvasx $x $v(grid)] + set cy [$c canvasy $y] + if {$cx < $v(left)} { + set cx $v(left) + } + if {$cx > $v(right)} { + set cx $v(right) + } + if {($cy >= $v(top)) && ($cy <= $v(bottom))} { + set cy [expr $v(top)+2] + eval "$c itemconf active $v(activeStyle)" + } else { + set cy [expr $cy-$v(size)-2] + eval "$c itemconf active $v(deleteStyle)" + } + $c move active [expr $cx-$v(x)] [expr $cy-$v(y)] + set v(x) $cx + set v(y) $cy +} + +proc demo_selectTab {c x y} { + upvar #0 demo_rulerInfo v + set v(x) [$c canvasx $x $v(grid)] + set v(y) [expr $v(top)+2] + $c addtag active withtag current + eval "$c itemconf active $v(activeStyle)" + $c raise active +} + +proc rulerReleaseTab c { + upvar #0 demo_rulerInfo v + if {[$c find withtag active] == {}} { + return + } + if {$v(y) != [expr $v(top)+2]} { + $c delete active + } else { + eval "$c itemconf active $v(normalStyle)" + $c dtag active + } +} diff --git a/gcl-tk/demos/mkScroll.tcl b/gcl-tk/demos/mkScroll.tcl new file mode 100755 index 0000000..f125db4 --- /dev/null +++ b/gcl-tk/demos/mkScroll.tcl @@ -0,0 +1,84 @@ +# mkScroll w +# +# Create a top-level window containing a simple canvas that can +# be scrolled in two dimensions. +# +# Arguments: +# w - Name to use for new top-level window. + +proc mkScroll {{w .cscroll}} { + catch {destroy $w} + toplevel $w + dpos $w + wm title $w "Scrollable Canvas Demonstration" + wm iconname $w "Canvas" + wm minsize $w 100 100 + set c $w.frame.c + + message $w.msg -font -Adobe-Times-Medium-R-Normal-*-180-* -aspect 300 \ + -relief raised -bd 2 -text "This window displays a canvas widget that can be scrolled either using the scrollbars or by dragging with button 2 in the canvas. If you click button 1 on one of the rectangles, its indices will be printed on stdout." + frame $w.frame -relief raised -bd 2 + button $w.ok -text "OK" -command "destroy $w" + pack $w.msg -side top -fill x + pack $w.ok -side bottom -pady 5 + pack $w.frame -side top -expand yes -fill both + + canvas $c -scrollregion {-10c -10c 50c 20c} \ + -xscrollcommand "$w.frame.hscroll set" -yscrollcommand "$w.frame.vscroll set" + scrollbar $w.frame.vscroll -relief sunken -command "$c yview" + scrollbar $w.frame.hscroll -orient horiz -relief sunken -command "$c xview" + pack $w.frame.vscroll -side right -fill y + pack $w.frame.hscroll -side bottom -fill x + pack $c -expand yes -fill both + + set bg [lindex [$c config -bg] 4] + for {set i 0} {$i < 20} {incr i} { + set x [expr {-10 + 3*$i}] + for {set j 0; set y -10} {$j < 10} {incr j; incr y 3} { + $c create rect ${x}c ${y}c [expr $x+2]c [expr $y+2]c \ + -outline black -fill $bg -tags rect + $c create text [expr $x+1]c [expr $y+1]c -text "$i,$j" \ + -anchor center -tags text + } + } + + $c bind all "scrollEnter $c" + $c bind all "scrollLeave $c" + $c bind all <1> "scrollButton $c" + bind $c <2> "$c scan mark %x %y" + bind $c "$c scan dragto %x %y" +} + +proc scrollEnter canvas { + global oldFill + set id [$canvas find withtag current] + if {[lsearch [$canvas gettags current] text] >= 0} { + set id [expr $id-1] + } + set oldFill [lindex [$canvas itemconfig $id -fill] 4] + if {[winfo depth $canvas] > 1} { + $canvas itemconfigure $id -fill SeaGreen1 + } else { + $canvas itemconfigure $id -fill black + $canvas itemconfigure [expr $id+1] -fill white + } +} + +proc scrollLeave canvas { + global oldFill + set id [$canvas find withtag current] + if {[lsearch [$canvas gettags current] text] >= 0} { + set id [expr $id-1] + } + $canvas itemconfigure $id -fill $oldFill + $canvas itemconfigure [expr $id+1] -fill black +} + +proc scrollButton canvas { + global oldFill + set id [$canvas find withtag current] + if {[lsearch [$canvas gettags current] text] < 0} { + set id [expr $id+1] + } + puts stdout "You buttoned at [lindex [$canvas itemconf $id -text] 4]" +} diff --git a/gcl-tk/demos/mkSearch.lisp b/gcl-tk/demos/mkSearch.lisp new file mode 100755 index 0000000..dcb46a7 --- /dev/null +++ b/gcl-tk/demos/mkSearch.lisp @@ -0,0 +1,135 @@ +;;# mkTextSearch w +(in-package "TK") + +;; +;; Create a top-level window containing a text widget that allows you +;; to load a file and highlight all instances of a given string. +;; +;; Arguments: +;; w - Name to use for new top-level window. + +(defun mkTextSearch (&optional (w '.search) &aux (textwin (conc w '.t))) + (if (winfo :exists w :return 'boolean) (destroy w)) + (toplevel w) + (dpos w) + (wm :title w "Text Demonstration - Search and Highlight") + (wm :iconname w "Text Search") + + (frame (conc w '.file)) + (label (conc w '.file.label) :text "File name:" :width 13 :anchor "w") + (entry (conc w '.file.entry) :width 40 :relief "sunken" :bd 2 + :textvariable 'fileName) + (button (conc w '.file.button) :text "Load File" + :command `(TextLoadFile ',textwin fileName)) + (pack (conc w '.file.label) (conc w '.file.entry) :side "left") + (pack (conc w '.file.button) :side "left" :pady 5 :padx 10) + (bind (conc w '.file.entry) "" + `(progn + (TextLoadFile ',textwin fileName) + (focus (conc ',w '.string.entry)))) + (frame (conc w '.string)) + (label (conc w '.string.label) :text "Search string:" :width 13 :anchor "w") + (entry (conc w '.string.entry) :width 40 :relief "sunken" :bd 2 + :textvariable 'searchString) + (button (conc w '.string.button) :text "Highlight" + :command `(TextSearch ',textwin searchString "search")) + (pack (conc w '.string.label) (conc w '.string.entry) :side "left") + (pack (conc w '.string.button) :side "left" :pady 5 :padx 10) + (bind (conc w '.string.entry) "" `(TextSearch + ',textwin searchString "search")) + + (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) + (text textwin :relief "raised" :bd 2 :yscrollcommand (tk-conc w ".s set") + :setgrid "true") + (scrollbar (conc w '.s) :relief "flat" :command (tk-conc w ".t yview")) + (pack (conc w '.file) (conc w '.string) :side "top" :fill "x") + (pack (conc w '.ok) :side "bottom" :fill "x") + (pack (conc w '.s) :side "right" :fill "y") + (pack textwin :expand "yes" :fill "both") + + ;; Set up display styles for text highlighting. + (let* (com + (bg (if (> (read-from-string (winfo :depth w)) 1) + "SeaGreen4" "black")) + on + + (fun #'(lambda () + (when (myerrorset + (progn (funcall textwin + :tag + :configure "search" + :background (if on bg "") + :foreground (if on "white" "")) + t)) + (setq on (not on)) + (myerrorset (after 500 com)) + )))) + (setq com (tcl-create-command fun nil nil)) + (setq bil fun) + (funcall fun )) + (funcall textwin :insert 0.0 + " +This window demonstrates how to use the tagging facilities in text +widgets to implement a searching mechanism. First, type a file name +in the top entry, then type or click on \"Load File\". Then +type a string in the lower entry and type or click on +\"Load File\". This will cause all of the instances of the string to +be tagged with the tag \"search\", and it will arrange for the tag's +display attributes to change to make all of the strings blink. +" +) + (funcall textwin :mark :set 'insert 0.0) + (bind w "" (tk-conc "focus " w ".file.entry")) +) +(setq fileName "") +(setq searchString "") + +;; The utility procedure below loads a file into a text widget, +;; discarding the previous contents of the widget. Tags for the +;; old widget are not affected, however. +;; Arguments: +;; +;; w - The window into which to load the file. Must be a +;; text widget. +;; file - The name of the file to load. Must be readable. + +(defun TextLoadFile (w file) + (with-open-file + (st file) + (let ((ar (make-array 3000 :element-type 'string-char :fill-pointer 0)) + (n (file-length st)) + m) + (funcall w :delete "1.0" 'end) + (while (> n 0) + (setq m (min (array-total-size ar) n)) + (setq n (- n m)) + (si::fread ar 0 m st) + (setf (fill-pointer ar) m) + (funcall w :insert 'end ar))))) + + + +;; The utility procedure below searches for all instances of a +;; given string in a text widget and applies a given tag to each +;; instance found. +;; Arguments: +;; +;; w - The window in which to search. Must be a text widget. +;; string - The string to search for. The search is done using +;; exact matching only; no special characters. +;; tag - Tag to apply to each instance of a matching string. + +(defun TextSearch (w string tag) + (funcall w :tag :remove 'search 0.0 'end) + (let ((mark "mine") + (m (length string))) + (funcall w :mark :set "mine" "0.0") + (while (funcall w :compare mark '< 'end :return 'boolean) + (let ((s (funcall w :get mark mark : " + 3000 chars" :return 'string)) + (n 0) tem) + (while (setq tem (search string s :start2 n)) + (funcall w :tag :add 'search + mark : " + " : tem : " chars" + mark : " + " : (setq n (+ tem m)) : " chars")) + (funcall w :mark :set mark mark : " + " : (- 3000 m) : " chars"))))) + diff --git a/gcl-tk/demos/mkSearch.tcl b/gcl-tk/demos/mkSearch.tcl new file mode 100755 index 0000000..fc4772f --- /dev/null +++ b/gcl-tk/demos/mkSearch.tcl @@ -0,0 +1,140 @@ +# mkTextSearch w +# +# Create a top-level window containing a text widget that allows you +# to load a file and highlight all instances of a given string. +# +# Arguments: +# w - Name to use for new top-level window. + +proc mkTextSearch {{w .search}} { + catch {destroy $w} + toplevel $w + dpos $w + wm title $w "Text Demonstration - Search and Highlight" + wm iconname $w "Text Search" + + frame $w.file + label $w.file.label -text "File name:" -width 13 -anchor w + entry $w.file.entry -width 40 -relief sunken -bd 2 -textvariable fileName + button $w.file.button -text "Load File" \ + -command "TextLoadFile $w.t \$fileName" + pack $w.file.label $w.file.entry -side left + pack $w.file.button -side left -pady 5 -padx 10 + bind $w.file.entry " + TextLoadFile $w.t \$fileName + focus $w.string.entry + " + + frame $w.string + label $w.string.label -text "Search string:" -width 13 -anchor w + entry $w.string.entry -width 40 -relief sunken -bd 2 \ + -textvariable searchString + button $w.string.button -text "Highlight" \ + -command "TextSearch $w.t \$searchString search" + pack $w.string.label $w.string.entry -side left + pack $w.string.button -side left -pady 5 -padx 10 + bind $w.string.entry "TextSearch $w.t \$searchString search" + + button $w.ok -text OK -command "destroy $w" + text $w.t -relief raised -bd 2 -yscrollcommand "$w.s set" -setgrid true + scrollbar $w.s -relief flat -command "$w.t yview" + pack $w.file $w.string -side top -fill x + pack $w.ok -side bottom -fill x + pack $w.s -side right -fill y + pack $w.t -expand yes -fill both + + # Set up display styles for text highlighting. + + if {[winfo depth $w] > 1} { + TextToggle "$w.t tag configure search -background \ + SeaGreen4 -foreground white" 800 "$w.t tag configure \ + search -background {} -foreground {}" 200 + } else { + TextToggle "$w.t tag configure search -background \ + black -foreground white" 800 "$w.t tag configure \ + search -background {} -foreground {}" 200 + } + $w.t insert 0.0 {\ +This window demonstrates how to use the tagging facilities in text +widgets to implement a searching mechanism. First, type a file name +in the top entry, then type or click on "Load File". Then +type a string in the lower entry and type or click on +"Load File". This will cause all of the instances of the string to +be tagged with the tag "search", and it will arrange for the tag's +display attributes to change to make all of the strings blink. +} + $w.t mark set insert 0.0 + bind $w "focus $w.file.entry" +} +set fileName "" +set searchString "" + +# The utility procedure below loads a file into a text widget, +# discarding the previous contents of the widget. Tags for the +# old widget are not affected, however. +# Arguments: +# +# w - The window into which to load the file. Must be a +# text widget. +# file - The name of the file to load. Must be readable. + +proc TextLoadFile {w file} { + set f [open $file] + $w delete 1.0 end + while {![eof $f]} { + $w insert end [read $f 10000] + } + close $f +} + +# The utility procedure below searches for all instances of a +# given string in a text widget and applies a given tag to each +# instance found. +# Arguments: +# +# w - The window in which to search. Must be a text widget. +# string - The string to search for. The search is done using +# exact matching only; no special characters. +# tag - Tag to apply to each instance of a matching string. + +proc TextSearch {w string tag} { + $w tag remove search 0.0 end + scan [$w index end] %d numLines + set l [string length $string] + for {set i 1} {$i <= $numLines} {incr i} { + if {[string first $string [$w get $i.0 $i.1000]] == -1} { + continue + } + set line [$w get $i.0 $i.1000] + set offset 0 + while 1 { + set index [string first $string $line] + if {$index < 0} { + break + } + incr offset $index + $w tag add $tag $i.[expr $offset] $i.[expr $offset+$l] + incr offset $l + set line [string range $line [expr $index+$l] 1000] + } + } +} + +# The procedure below is invoked repeatedly to invoke two commands +# at periodic intervals. It normally reschedules itself after each +# execution but if an error occurs (e.g. because the window was +# deleted) then it doesn't reschedule itself. +# Arguments: +# +# cmd1 - Command to execute when procedure is called. +# sleep1 - Ms to sleep after executing cmd1 before executing cmd2. +# cmd2 - Command to execute in the *next* invocation of this +# procedure. +# sleep2 - Ms to sleep after executing cmd2 before executing cmd1 again. + +proc TextToggle {cmd1 sleep1 cmd2 sleep2} { + catch { + eval $cmd1 + after $sleep1 [list TextToggle $cmd2 $sleep2 $cmd1 $sleep1] + } +} diff --git a/gcl-tk/demos/mkStyles.lisp b/gcl-tk/demos/mkStyles.lisp new file mode 100755 index 0000000..6a62bb7 --- /dev/null +++ b/gcl-tk/demos/mkStyles.lisp @@ -0,0 +1,135 @@ +;;# mkStyles w +;; +;; Create a top-level window with a text widget that demonstrates the +;; various display styles that are available in texts. +;; +;; Arguments: +;; w - Name to use for new top-level window. + +(in-package "TK") +(defun mkStyles (&optional (w '.styles) &aux (textwin (conc w '.t)) ) + (if (winfo :exists w :return 'boolean) (destroy w)) + (toplevel w) + (dpos w) + (wm :title w "Text Demonstration - Display Styles") + (wm :iconname w "Text Styles") + + (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) + (scrollbar (conc w '.s) :relief "flat" :command (tk-conc w ".t yview")) + (text textwin :relief "raised" :bd 2 :yscrollcommand (tk-conc w ".s set") :setgrid "true" + :width 70 :height 28) + (pack (conc w '.ok) :side "bottom" :fill "x") + (pack (conc w '.s) :side "right" :fill "y") + (pack textwin :expand "yes" :fill "both") + + ;; Set up display styles + + (funcall textwin :tag :configure 'bold :font :Adobe-Courier-Bold-O-Normal-*-120-*) + (funcall textwin :tag :configure 'big :font :Adobe-Courier-Bold-R-Normal-*-140-*) + (funcall textwin :tag :configure 'verybig :font :Adobe-Helvetica-Bold-R-Normal-*-240-*) + (if (> (read-from-string (winfo :depth w)) 1) + (progn + (funcall textwin :tag :configure 'color1 :background "#eed5b7") + (funcall textwin :tag :configure 'color2 :foreground "red") + (funcall textwin :tag :configure 'raised :background "#eed5b7" + :relief "raised" + :borderwidth 1) + (funcall textwin :tag :configure 'sunken :background "#eed5b7" + :relief "sunken" + :borderwidth 1) + ) ;;else + (progn + (funcall textwin :tag :configure 'color1 :background "black" :foreground "white") + (funcall textwin :tag :configure 'color2 :background "black" :foreground "white") + (funcall textwin :tag :configure 'raised :background "white" :relief "raised" + :borderwidth 1) + (funcall textwin :tag :configure 'sunken :background "white" :relief "sunken" + :borderwidth 1) + )) + (funcall textwin :tag :configure 'bgstipple :background "black" :borderwidth 0 + :bgstipple "gray25") + (funcall textwin :tag :configure 'fgstipple :fgstipple "gray50") + (funcall textwin :tag :configure 'underline :underline "on") + + (funcall textwin :insert 0.0 " +Text widgets like this one allow you to display information in a +variety of styles. Display styles are controlled using a mechanism +called " ) + (insertWithTags textwin "tags" 'bold) + (insertWithTags textwin ". Tags are just textual names that you can apply to one +or more ranges of characters within a text widget. You can configure +tags with various display styles. (if :you do this, then the tagged +characters will be displayed with the styles you chose. The +available display styles are: +" +) + (insertWithTags textwin " +1. Font." 'big) + (insertWithTags textwin " You can choose any X font, ") + (insertWithTags textwin "large" "verybig") + (insertWithTags textwin " or ") + (insertWithTags textwin "small. +") + + (insertWithTags textwin " +2. Color." 'big) + (insertWithTags textwin " You can change either the ") + (insertWithTags textwin "background" "color1") + (insertWithTags textwin " or ") + (insertWithTags textwin "foreground" "color2") + (insertWithTags textwin " +color, or ") + (insertWithTags textwin "both" "color1" "color2") + (insertWithTags textwin ". +") + + (insertWithTags textwin " +3. Stippling." 'big) + (insertWithTags textwin " You can cause either the ") + (insertWithTags textwin "background" 'bgstipple) + (insertWithTags textwin " or ") + (insertWithTags textwin "foreground" 'fgstipple) + (insertWithTags textwin " +information to be drawn with a stipple fill instead of a solid fill. +") + (insertWithTags textwin " +4. Underlining." 'big) + (insertWithTags textwin " You can ") + (insertWithTags textwin "underline" "underline") + (insertWithTags textwin " ranges of text. +") + (insertWithTags textwin " +5. 3-D effects." 'big) + (insertWithTags textwin +" You can arrange for the background to be drawn +with a border that makes characters appear either ") + (insertWithTags textwin "raised" "raised") + (insertWithTags textwin " or ") + (insertWithTags textwin "sunken" "sunken") + (insertWithTags textwin ". +") + (insertWithTags textwin " +6. Yet to come." 'big) + (insertWithTags textwin +" More display effects will be coming soon, such +as the ability to change line justification and perhaps line spacing.") + (funcall textwin :mark :set 'insert 0.0) + (bind w "" (tk-conc "focus " w ".t")) +) + +;; The procedure below inserts text into a given text widget and +;; applies one or more tags to that text. The arguments are: +;; +;; w Window in which to insert +;; text Text to insert (it's :inserted at the "insert" mark) +;; args One or more tags to apply to text. (if :this is empty +;; then all tags are removed from the text. + + +(defun insertWithTags (w text &rest args) + (let (( start (funcall w :index 'insert :return 'string))) + (funcall w :insert 'insert text) + (dolist (v (funcall w :tag :names start :return 'list-strings)) + (funcall w :tag :remove v start 'insert)) + (dolist (i args) + (funcall w :tag :add i start 'insert)))) diff --git a/gcl-tk/demos/mkStyles.tcl b/gcl-tk/demos/mkStyles.tcl new file mode 100755 index 0000000..04c08f5 --- /dev/null +++ b/gcl-tk/demos/mkStyles.tcl @@ -0,0 +1,128 @@ +# mkStyles w +# +# Create a top-level window with a text widget that demonstrates the +# various display styles that are available in texts. +# +# Arguments: +# w - Name to use for new top-level window. + +proc mkStyles {{w .styles}} { + catch {destroy $w} + toplevel $w + dpos $w + wm title $w "Text Demonstration - Display Styles" + wm iconname $w "Text Styles" + + button $w.ok -text OK -command "destroy $w" + text $w.t -relief raised -bd 2 -yscrollcommand "$w.s set" -setgrid true \ + -width 70 -height 28 + scrollbar $w.s -relief flat -command "$w.t yview" + pack $w.ok -side bottom -fill x + pack $w.s -side right -fill y + pack $w.t -expand yes -fill both + + # Set up display styles + + $w.t tag configure bold -font -Adobe-Courier-Bold-O-Normal-*-120-* + $w.t tag configure big -font -Adobe-Courier-Bold-R-Normal-*-140-* + $w.t tag configure verybig -font -Adobe-Helvetica-Bold-R-Normal-*-240-* + if {[winfo depth $w] > 1} { + $w.t tag configure color1 -background #eed5b7 + $w.t tag configure color2 -foreground red + $w.t tag configure raised -background #eed5b7 -relief raised \ + -borderwidth 1 + $w.t tag configure sunken -background #eed5b7 -relief sunken \ + -borderwidth 1 + } else { + $w.t tag configure color1 -background black -foreground white + $w.t tag configure color2 -background black -foreground white + $w.t tag configure raised -background white -relief raised \ + -borderwidth 1 + $w.t tag configure sunken -background white -relief sunken \ + -borderwidth 1 + } + $w.t tag configure bgstipple -background black -borderwidth 0 \ + -bgstipple gray25 + $w.t tag configure fgstipple -fgstipple gray50 + $w.t tag configure underline -underline on + + $w.t insert 0.0 {\ +Text widgets like this one allow you to display information in a +variety of styles. Display styles are controlled using a mechanism +called } + insertWithTags $w.t tags bold + insertWithTags $w.t {. Tags are just textual names that you can apply to one +or more ranges of characters within a text widget. You can configure +tags with various display styles. If you do this, then the tagged +characters will be displayed with the styles you chose. The +available display styles are: +} + insertWithTags $w.t { +1. Font.} big + insertWithTags $w.t { You can choose any X font, } + insertWithTags $w.t large verybig + insertWithTags $w.t { or } + insertWithTags $w.t {small. +} + insertWithTags $w.t { +2. Color.} big + insertWithTags $w.t { You can change either the } + insertWithTags $w.t background color1 + insertWithTags $w.t { or } + insertWithTags $w.t foreground color2 + insertWithTags $w.t { +color, or } + insertWithTags $w.t both color1 color2 + insertWithTags $w.t {. +} + insertWithTags $w.t { +3. Stippling.} big + insertWithTags $w.t { You can cause either the } + insertWithTags $w.t background bgstipple + insertWithTags $w.t { or } + insertWithTags $w.t foreground fgstipple + insertWithTags $w.t { +information to be drawn with a stipple fill instead of a solid fill. +} + insertWithTags $w.t { +4. Underlining.} big + insertWithTags $w.t { You can } + insertWithTags $w.t underline underline + insertWithTags $w.t { ranges of text. +} + insertWithTags $w.t { +5. 3-D effects.} big + insertWithTags $w.t { You can arrange for the background to be drawn +with a border that makes characters appear either } + insertWithTags $w.t raised raised + insertWithTags $w.t { or } + insertWithTags $w.t sunken sunken + insertWithTags $w.t {. +} + insertWithTags $w.t { +6. Yet to come.} big + insertWithTags $w.t { More display effects will be coming soon, such +as the ability to change line justification and perhaps line spacing.} + + $w.t mark set insert 0.0 + bind $w "focus $w.t" +} + +# The procedure below inserts text into a given text widget and +# applies one or more tags to that text. The arguments are: +# +# w Window in which to insert +# text Text to insert (it's inserted at the "insert" mark) +# args One or more tags to apply to text. If this is empty +# then all tags are removed from the text. + +proc insertWithTags {w text args} { + set start [$w index insert] + $w insert insert $text + foreach tag [$w tag names $start] { + $w tag remove $tag $start insert + } + foreach i $args { + $w tag add $i $start insert + } +} diff --git a/gcl-tk/demos/mkTear.tcl b/gcl-tk/demos/mkTear.tcl new file mode 100755 index 0000000..5ba01ae --- /dev/null +++ b/gcl-tk/demos/mkTear.tcl @@ -0,0 +1,19 @@ +# mkTear w +# +# Create a top-level window that displays a help message on tear-off +# menus. +# +# Arguments: +# w - Name to use for new top-level window. + +proc mkTear {{w .t1}} { + catch {destroy $w} + toplevel $w + dpos $w + wm title $w "Information On Tear-Off Menus" + wm iconname $w "Info" + message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 250 \ + -text "To tear off a menu, press mouse button 2 over the menubutton for the menu, then drag the menu with button 2 held down. You can reposition a torn-off menu by pressing button 2 on it and dragging again. To unpost the menu, click mouse button 1 over the menu's menubutton. Click the \"OK\" button when you're finished with this window." + button $w.ok -text OK -command "destroy $w" + pack $w.msg $w.ok -pady 5 +} diff --git a/gcl-tk/demos/mkTextBind.lisp b/gcl-tk/demos/mkTextBind.lisp new file mode 100755 index 0000000..19d7cf7 --- /dev/null +++ b/gcl-tk/demos/mkTextBind.lisp @@ -0,0 +1,108 @@ +;;# mkTextBind w +;; +;; Create a top-level window that illustrates how you can bind +;; Tcl commands to regions of text in a text widget. +;; +;; Arguments: +;; w - Name to use for new top-level window. + +(in-package "TK") +(defun mkTextBind (&optional (w '.bindings) &aux bold normal + (textwin (conc w '.t ) )) + (if (winfo :exists w :return 'boolean) (destroy w)) + (toplevel w) + (dpos w) + (wm :title w "Text Demonstration - Tag Bindings") + (wm :iconname w "Text Bindings") + (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) + (scrollbar (conc w '.s) :relief "flat" :command (tk-conc w ".t yview")) + (text textwin :relief "raised" :bd 2 :yscrollcommand + (tk-conc w ".s set") :setgrid "true" + :width 60 :height 28 + :font "-Adobe-Helvetica-Bold-R-Normal-*-120-*") + + (pack (conc w '.ok) :side "bottom" :fill "x") + (pack (conc w '.s) :side "right" :fill "y") + (pack textwin :expand "yes" :fill "both") + + ;; Set up display styles + + (if (> (read-from-string (winfo :depth w)) 1) + (progn + (setq bold '(:foreground "red")) + (setq normal '(:foreground "")) + );;else + (progn + (setq bold '(:foreground "white" :background "black")) + (setq normal '(:foreground "" :background "")) + )) + (funcall textwin :insert 0.0 +"The same tag mechanism that controls display styles in text +widgets can also be used to associate Tcl commands with regions +of text, so that mouse or keyboard actions on the text cause +particular Tcl commands to be invoked. For example, in the +text below the descriptions of the canvas demonstrations have +been tagged. When you move the mouse over a demo description +the description lights up, and when you press button 3 over a +description then that particular demonstration is invoked. + +This demo package contains a number of demonstrations of Tk's +canvas widgets. Here are brief descriptions of some of the +demonstrations that are available: +" +) + (let ((blank-lines (format nil "~2%"))) + (insertWithTags textwin +"1. Samples of all the different types of items that can be +created in canvas widgets." "d1") + (insertWithTags textwin blank-lines) + (insertWithTags textwin +"2. A simple two-dimensional plot that allows you to adjust +the :positions of the data points." "d2") + (insertWithTags textwin blank-lines) + (insertWithTags textwin +"3. Anchoring and justification modes for text items." "d3") + (insertWithTags textwin blank-lines) + (insertWithTags textwin +"4. An editor for arrow-head shapes for line items." "d4") + (insertWithTags textwin blank-lines) + (insertWithTags textwin +"5. A ruler with facilities for editing tab stops." "d5") + (insertWithTags textwin blank-lines) + (insertWithTags textwin +"6. A grid that demonstrates how canvases can be scrolled." "d6")) + + (dolist (tag '("d1" "d2" "d3" "d4" "d5" "d6")) + (funcall textwin :tag :bind tag "" + `(,textwin :tag :configure ,tag ,@bold)) + (funcall textwin :tag :bind tag "" + `(,textwin :tag :configure ,tag ,@normal)) + ) + (funcall textwin :tag :bind "d1" "<3>" 'mkItems) + (funcall textwin :tag :bind "d2" "<3>" 'mkPlot) + (funcall textwin :tag :bind "d3" "<3>" "mkCanvText") + (funcall textwin :tag :bind "d4" "<3>" "mkArrow") + (funcall textwin :tag :bind "d5" "<3>" 'mkRuler) + (funcall textwin :tag :bind "d6" "<3>" "mkScroll") + + (funcall textwin :mark 'set 'insert 0.0) + (bind w "" (tk-conc "focus " w ".t")) +) + +;; The procedure below inserts text into a given text widget and +;; applies one or more tags to that text. The arguments are: +;; +;; w Window in which to insert +;; text Text to insert (it's :inserted at the "insert" mark) +;; args One or more tags to apply to text. (if :this is empty +;; then all tags are removed from the text. + +(defun insertWithTags (w text &rest args) + (let (( start (funcall w :index 'insert :return 'string))) + (funcall w :insert 'insert text) + (dolist (v (funcall w :tag "names" start :return 'list-strings)) + (funcall w :tag 'remove v start "insert")) + (dolist (i args) + (funcall w :tag 'add i start 'insert)))) + + diff --git a/gcl-tk/demos/mkTextBind.tcl b/gcl-tk/demos/mkTextBind.tcl new file mode 100755 index 0000000..368d768 --- /dev/null +++ b/gcl-tk/demos/mkTextBind.tcl @@ -0,0 +1,100 @@ +# mkTextBind w +# +# Create a top-level window that illustrates how you can bind +# Tcl commands to regions of text in a text widget. +# +# Arguments: +# w - Name to use for new top-level window. + +proc mkTextBind {{w .bindings}} { + catch {destroy $w} + toplevel $w + dpos $w + wm title $w "Text Demonstration - Tag Bindings" + wm iconname $w "Text Bindings" + button $w.ok -text OK -command "destroy $w" + text $w.t -relief raised -bd 2 -yscrollcommand "$w.s set" -setgrid true \ + -width 60 -height 28 \ + -font "-Adobe-Helvetica-Bold-R-Normal-*-120-*" + scrollbar $w.s -relief flat -command "$w.t yview" + pack $w.ok -side bottom -fill x + pack $w.s -side right -fill y + pack $w.t -expand yes -fill both + + # Set up display styles + + if {[winfo depth $w] > 1} { + set bold "-foreground red" + set normal "-foreground {}" + } else { + set bold "-foreground white -background black" + set normal "-foreground {} -background {}" + } + $w.t insert 0.0 {\ +The same tag mechanism that controls display styles in text +widgets can also be used to associate Tcl commands with regions +of text, so that mouse or keyboard actions on the text cause +particular Tcl commands to be invoked. For example, in the +text below the descriptions of the canvas demonstrations have +been tagged. When you move the mouse over a demo description +the description lights up, and when you press button 3 over a +description then that particular demonstration is invoked. + +This demo package contains a number of demonstrations of Tk's +canvas widgets. Here are brief descriptions of some of the +demonstrations that are available: + +} + insertWithTags $w.t \ +{1. Samples of all the different types of items that can be +created in canvas widgets.} d1 + insertWithTags $w.t \n\n + insertWithTags $w.t \ +{2. A simple two-dimensional plot that allows you to adjust +the positions of the data points.} d2 + insertWithTags $w.t \n\n + insertWithTags $w.t \ +{3. Anchoring and justification modes for text items.} d3 + insertWithTags $w.t \n\n + insertWithTags $w.t \ +{4. An editor for arrow-head shapes for line items.} d4 + insertWithTags $w.t \n\n + insertWithTags $w.t \ +{5. A ruler with facilities for editing tab stops.} d5 + insertWithTags $w.t \n\n + insertWithTags $w.t \ +{6. A grid that demonstrates how canvases can be scrolled.} d6 + + foreach tag {d1 d2 d3 d4 d5 d6} { + $w.t tag bind $tag "$w.t tag configure $tag $bold" + $w.t tag bind $tag "$w.t tag configure $tag $normal" + } + $w.t tag bind d1 <3> mkItems + $w.t tag bind d2 <3> mkPlot + $w.t tag bind d3 <3> mkCanvText + $w.t tag bind d4 <3> mkArrow + $w.t tag bind d5 <3> mkRuler + $w.t tag bind d6 <3> mkScroll + + $w.t mark set insert 0.0 + bind $w "focus $w.t" +} + +# The procedure below inserts text into a given text widget and +# applies one or more tags to that text. The arguments are: +# +# w Window in which to insert +# text Text to insert (it's inserted at the "insert" mark) +# args One or more tags to apply to text. If this is empty +# then all tags are removed from the text. + +proc insertWithTags {w text args} { + set start [$w index insert] + $w insert insert $text + foreach tag [$w tag names $start] { + $w tag remove $tag $start insert + } + foreach i $args { + $w tag add $i $start insert + } +} diff --git a/gcl-tk/demos/mkVScale.lisp b/gcl-tk/demos/mkVScale.lisp new file mode 100755 index 0000000..e47d031 --- /dev/null +++ b/gcl-tk/demos/mkVScale.lisp @@ -0,0 +1,40 @@ +(in-package "TK") +;;# mkVScale w +;; +;; Create a top-level window that displays a vertical scale. +;; +;; Arguments: +;; w - Name to use for new top-level window. + +(defun mkVScale (&optional (w '.vscale )) +; (catch {destroy w}) + (toplevel w) + (dpos w) + (wm :title w "Vertical Scale Demonstration") + (wm :iconname w "Scale") + (message (conc w '.msg) :font :Adobe-times-medium-r-normal--*-180* :aspect 300 + :text "A bar and a vertical scale are displayed below. If you click or drag mouse button 1 in the scale, you can change the height of the bar. Click the OK button when you're finished.") + (frame (conc w '.frame) :borderwidth 10) + (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) + (pack (conc w '.msg) (conc w '.frame) (conc w '.ok)) + + (scale (conc w '.frame.scale) :orient "vertical" :length 280 :from 0 :to 250 + :command #'(lambda (height) + ; (print height) + (setHeight (conc w '.frame.right.inner) height)) + :tickinterval 50 + :bg "Bisque1") + (frame (conc w '.frame.right) :borderwidth 15) + (frame (conc w '.frame.right.inner) :width 40 :height 20 :relief "raised" + :borderwidth 2 :bg "SteelBlue1") + (pack (conc w '.frame.scale) :side "left" :anchor "ne") + (pack (conc w '.frame.right) :side "left" :anchor "nw") + (funcall (conc w '.frame.scale) :set 20) + + + (pack (conc w '.frame.right.inner) :expand "yes" :anchor "nw") +) + +(defun setHeight (w height) + (funcall w :config :width 40 :height height) +) diff --git a/gcl-tk/demos/mkVScale.tcl b/gcl-tk/demos/mkVScale.tcl new file mode 100755 index 0000000..1889a9b --- /dev/null +++ b/gcl-tk/demos/mkVScale.tcl @@ -0,0 +1,35 @@ +# mkVScale w +# +# Create a top-level window that displays a vertical scale. +# +# Arguments: +# w - Name to use for new top-level window. + +proc mkVScale {{w .scale1}} { + catch {destroy $w} + toplevel $w + dpos $w + wm title $w "Vertical Scale Demonstration" + wm iconname $w "Scale" + message $w.msg -font -Adobe-times-medium-r-normal--*-180* -aspect 300 \ + -text "A bar and a vertical scale are displayed below. If you click or drag mouse button 1 in the scale, you can change the height of the bar. Click the \"OK\" button when you're finished." + frame $w.frame -borderwidth 10 + button $w.ok -text OK -command "destroy $w" + pack $w.msg $w.frame $w.ok + + scale $w.frame.scale -orient vertical -length 280 -from 0 -to 250 \ + -command "setHeight $w.frame.right.inner" -tickinterval 50 \ + -bg Bisque1 + frame $w.frame.right -borderwidth 15 + pack $w.frame.scale -side left -anchor ne + pack $w.frame.right -side left -anchor nw + $w.frame.scale set 20 + + frame $w.frame.right.inner -width 40 -height 20 -relief raised \ + -borderwidth 2 -bg SteelBlue1 + pack $w.frame.right.inner -expand yes -anchor nw +} + +proc setHeight {w height} { + $w config -height $height +} diff --git a/gcl-tk/demos/mkdialog.lisp b/gcl-tk/demos/mkdialog.lisp new file mode 100755 index 0000000..5fd6284 --- /dev/null +++ b/gcl-tk/demos/mkdialog.lisp @@ -0,0 +1,64 @@ +;;# mkDialog w msgArgs list list '... +(in-package "TK") +;; +;; Create a dialog box with a message and any number of buttons at +;; the bottom. +;; +;; Arguments: +;; w - Name to use for new top-level window. +;; msgArgs - List of arguments to use when creating the message of the +;; dialog box (e.g. :text, justifcation, etc.) +;; list - A two-element list that describes one of the buttons that +;; will appear at the bottom of the dialog. The first element +;; gives the text to be displayed in the button and the second +;; gives the command to be invoked when the button is invoked. + +(defun mkDialog (w msgArgs &rest args) + (if (winfo :exists w :return 'boolean) (destroy w)) + (toplevel w :class "Dialog") + (wm :title w "Dialog box") + (wm :iconname w "Dialog") + + ;; Create two frames in the main window. The top frame will hold the + ;; message and the bottom one will hold the buttons. Arrange them + ;; one above the other, with any extra vertical space split between + ;; them. + + (frame (conc w '.top) :relief "raised" :border 1) + (frame (conc w '.bot) :relief "raised" :border 1) + (pack (conc w '.top) (conc w '.bot) :side "top" :fill "both" :expand "yes") + + ;; Create the message widget and arrange for it to be centered in the + ;; top frame. + + (apply 'message (conc w '.top.msg) :justify "center" + :font :Adobe-times-medium-r-normal--*-180* msgArgs) + (pack (conc w '.top.msg) :side "top" :expand "yes" :padx 3 :pady 3) + + ;; Create as many buttons as needed and arrange them from left to right + ;; in the bottom frame. Embed the left button in an additional sunken + ;; frame to indicate that it is the default button, and arrange for that + ;; button to be invoked as the default action for clicks and returns in + ;; the dialog. + + (if (> (length args) 0) + (let ((i 1) arg) + (setq arg (nth 0 args)) + (frame (conc w '.bot.0) :relief "sunken" :border 1) + (pack (conc w '.bot.0) :side "left" :expand "yes" :padx 10 :pady 10) + (button (conc w '.bot.0.button) :text (nth 0 arg) + :command `(progn ,(nth 1 arg)(destroy ',w))) + (pack (conc w '.bot.0.button) :expand "yes" :padx 6 :pady 6) + (bind w "" `(progn ,(nth 1 arg)(destroy ',w))) + (focus w) + (dolist (arg (cdr args)) + (setq i (+ i 1)) + (button (conc w '.bot. i) :text (nth 0 arg) + :command `(progn ,(nth 1 arg)(destroy ',w))) + (pack (conc w '.bot. i) :side "left" :expand "yes" :padx 10) + + ) + )) + (bind w "" `(focus ',w)) + (focus w) +) diff --git a/gcl-tk/demos/nqthm-stack.lisp b/gcl-tk/demos/nqthm-stack.lisp new file mode 100755 index 0000000..436eceb --- /dev/null +++ b/gcl-tk/demos/nqthm-stack.lisp @@ -0,0 +1,61 @@ +(in-package "TK") +;; turn on history; +;(MAINTAIN-REWRITE-PATH t) + + +(defun nqthm-stack (&optional (w '.nqthm)) + (toplevel w) + (dpos w) + (wm :title w "Nqthm Stack Frames") + (wm :iconname w "Nqthm Stack") + (wm :minsize w 1 1) + (message (conc w '.msg) :font :Adobe-times-medium-r-normal--*-180* :aspect 300 + :text "A listbox containing the 50 states is displayed below, along with a scrollbar. You can scan the list either using the scrollbar or by dragging in the listbox window with button 2 pressed. Click the OK button when you've seen enough.") + (frame (conc w '.frame) :borderwidth 10) + (button (conc w '.ok) :text "OK" :command `(destroy ',w)) + (button (conc w '.redo) :text "Show Frames" :command + `(show-frames)) + (checkbutton (conc w '.rew) :text "Maintain Frames" + :variable '(boolean user::do-frames) + :command '(user::MAINTAIN-REWRITE-PATH user::do-frames)) + (pack (conc w '.frame) :side "top" :expand "yes" :fill "y") + (pack (conc w '.rew)(conc w '.redo) (conc w '.ok) :side "bottom" :fill "x") + (scrollbar (conc w '.frame '.scroll) :relief "sunken" + :command + (tk-conc w ".frame.list yview")) + (listbox (conc w '.frame.list) :yscroll (tk-conc w ".frame.scroll set") + :relief "sunken" + :setgrid 1) + (pack (conc w '.frame.scroll) :side "right" :fill "y") + (pack (conc w '.frame.list) :side "left" :expand "yes" :fill "both") + (setq *list-box* (conc w '.frame.list))) + +(in-package "USER") + +(defun tk::show-frames() + (funcall tk::*list-box* :delete 0 "end") + (apply tk::*list-box* :insert 0 + (sloop::sloop for i below user::REWRITE-PATH-STK-PTR + do (setq tem (aref user::REWRITE-PATH-STK i)) + (setq tem + (display-rewrite-path-token + (nth 0 tem) + (nth 3 tem))) + (cond ((consp tem) (setq tem (format nil "~a" tem)))) + collect tem))) + + + +(defun display-rewrite-path-token (prog term) + (case prog + (ADD-EQUATIONS-TO-POT-LST + (access linear-lemma name term)) + (REWRITE-WITH-LEMMAS + (access rewrite-rule name term)) + ((REWRITE REWRITE-WITH-LINEAR) + (ffn-symb term)) + ((SET-SIMPLIFY-CLAUSE-POT-LST SIMPLIFY-CLAUSE) + "clause") + (t (er hard (prog term) + |Unexpected| |prog| |in| |call| |of| display-rewrite-path-token + |on| (!ppr prog nil) |and| (!ppr term (quote |.|)))))) \ No newline at end of file diff --git a/gcl-tk/demos/showVars.lisp b/gcl-tk/demos/showVars.lisp new file mode 100755 index 0000000..d3f84a7 --- /dev/null +++ b/gcl-tk/demos/showVars.lisp @@ -0,0 +1,28 @@ +(in-package "TK") +;;# showVars w var var var '... +;; +;; Create a top-level window that displays a bunch of global variable values +;; and keeps the display up-to-date even when the variables change value +;; +;; Arguments: +;; w - Name to use for new top-level window. +;; var - Name of variable to monitor. + +(defun showVars (w args) + (if (winfo :exists w :return 'boolean) (destroy w)) + (toplevel w) + (wm :title w "Variable values") + (label (conc w '.title) :text "Variable values:" :width 20 :anchor "center" + :font :Adobe-helvetica-medium-r-normal--*-180*) + (pack (conc w '.title) :side "top" :fill "x") + (dolist (i args) + (frame (conc w '|.| i)) + (label (conc w '|.| i '.name) :text (tk-conc i ": ")) + (label (conc w '|.| i '.value) :textvariable + (list (or (get i 'text-variable-type) t) i)) + (pack (conc w '|.| i '.name) (conc w '|.| i '.value) :side "left") + (pack (conc w '|.| i) :side "top" :anchor "w") + ) + (button (conc w '.ok) :text "OK" :command (tk-conc "destroy " w)) + (pack (conc w '.ok) :side "bottom" :pady 2) +) diff --git a/gcl-tk/demos/showVars.tcl b/gcl-tk/demos/showVars.tcl new file mode 100755 index 0000000..69b4f92 --- /dev/null +++ b/gcl-tk/demos/showVars.tcl @@ -0,0 +1,26 @@ +# showVars w var var var ... +# +# Create a top-level window that displays a bunch of global variable values +# and keeps the display up-to-date even when the variables change value +# +# Arguments: +# w - Name to use for new top-level window. +# var - Name of variable to monitor. + +proc showVars {w args} { + catch {destroy $w} + toplevel $w + wm title $w "Variable values" + label $w.title -text "Variable values:" -width 20 -anchor center \ + -font -Adobe-helvetica-medium-r-normal--*-180* + pack $w.title -side top -fill x + foreach i $args { + frame $w.$i + label $w.$i.name -text "$i: " + label $w.$i.value -textvar $i + pack $w.$i.name $w.$i.value -side left + pack $w.$i -side top -anchor w + } + button $w.ok -text OK -command "destroy $w" + pack $w.ok -side bottom -pady 2 +} diff --git a/gcl-tk/demos/tclIndex b/gcl-tk/demos/tclIndex new file mode 100755 index 0000000..c90e20a --- /dev/null +++ b/gcl-tk/demos/tclIndex @@ -0,0 +1,83 @@ +# Tcl autoload index file, version 2.0 +# This file is generated by the "auto_mkindex" command +# and sourced to set up indexing information for one or +# more commands. Typically each line is a command that +# sets an element in the auto_index array, where the +# element name is the name of a command and the value is +# a script that loads the command. + +set auto_index(mkCheck) [list source [file join $dir mkCheck.tcl]] +set auto_index(mkListbox2) [list source [file join $dir mkListbox2.tcl]] +set auto_index(mkLabel) [list source [file join $dir mkLabel.tcl]] +set auto_index(mkListbox3) [list source [file join $dir mkListbox3.tcl]] +set auto_index(mkPuzzle) [list source [file join $dir mkPuzzle.tcl]] +set auto_index(puzzle.switch) [list source [file join $dir mkPuzzle.tcl]] +set auto_index(mkArrow) [list source [file join $dir mkArrow.tcl]] +set auto_index(arrowSetup) [list source [file join $dir mkArrow.tcl]] +set auto_index(arrowMove1) [list source [file join $dir mkArrow.tcl]] +set auto_index(arrowMove2) [list source [file join $dir mkArrow.tcl]] +set auto_index(arrowMove3) [list source [file join $dir mkArrow.tcl]] +set auto_index(mkBasic) [list source [file join $dir mkBasic.tcl]] +set auto_index(mkBitmaps) [list source [file join $dir mkBitmaps.tcl]] +set auto_index(bitmapRow) [list source [file join $dir mkBitmaps.tcl]] +set auto_index(mkButton) [list source [file join $dir mkButton.tcl]] +set auto_index(mkCanvText) [list source [file join $dir mkCanvText.tcl]] +set auto_index(mkTextConfig) [list source [file join $dir mkCanvText.tcl]] +set auto_index(textEnter) [list source [file join $dir mkCanvText.tcl]] +set auto_index(textB1Press) [list source [file join $dir mkCanvText.tcl]] +set auto_index(textB1Move) [list source [file join $dir mkCanvText.tcl]] +set auto_index(textBs) [list source [file join $dir mkCanvText.tcl]] +set auto_index(mkDialog) [list source [file join $dir mkDialog.tcl]] +set auto_index(mkEntry) [list source [file join $dir mkEntry.tcl]] +set auto_index(mkEntry2) [list source [file join $dir mkEntry2.tcl]] +set auto_index(mkFloor) [list source [file join $dir mkFloor.tcl]] +set auto_index(floorDisplay) [list source [file join $dir mkFloor.tcl]] +set auto_index(roomChanged) [list source [file join $dir mkFloor.tcl]] +set auto_index(bg1) [list source [file join $dir mkFloor.tcl]] +set auto_index(bg2) [list source [file join $dir mkFloor.tcl]] +set auto_index(bg3) [list source [file join $dir mkFloor.tcl]] +set auto_index(fg1) [list source [file join $dir mkFloor.tcl]] +set auto_index(fg2) [list source [file join $dir mkFloor.tcl]] +set auto_index(fg3) [list source [file join $dir mkFloor.tcl]] +set auto_index(mkForm) [list source [file join $dir mkForm.tcl]] +set auto_index(Tab) [list source [file join $dir mkForm.tcl]] +set auto_index(mkHScale) [list source [file join $dir mkHScale.tcl]] +set auto_index(setWidth) [list source [file join $dir mkHScale.tcl]] +set auto_index(mkIcon) [list source [file join $dir mkIcon.tcl]] +set auto_index(iconCmd) [list source [file join $dir mkIcon.tcl]] +set auto_index(mkItems) [list source [file join $dir mkItems.tcl]] +set auto_index(itemEnter) [list source [file join $dir mkItems.tcl]] +set auto_index(itemLeave) [list source [file join $dir mkItems.tcl]] +set auto_index(itemMark) [list source [file join $dir mkItems.tcl]] +set auto_index(itemStroke) [list source [file join $dir mkItems.tcl]] +set auto_index(itemsUnderArea) [list source [file join $dir mkItems.tcl]] +set auto_index(itemStartDrag) [list source [file join $dir mkItems.tcl]] +set auto_index(itemDrag) [list source [file join $dir mkItems.tcl]] +set auto_index(butPress) [list source [file join $dir mkItems.tcl]] +set auto_index(mkListbox) [list source [file join $dir mkListbox.tcl]] +set auto_index(mkPlot) [list source [file join $dir mkPlot.tcl]] +set auto_index(plotDown) [list source [file join $dir mkPlot.tcl]] +set auto_index(plotMove) [list source [file join $dir mkPlot.tcl]] +set auto_index(mkRadio) [list source [file join $dir mkRadio.tcl]] +set auto_index(mkRuler) [list source [file join $dir mkRuler.tcl]] +set auto_index(rulerMkTab) [list source [file join $dir mkRuler.tcl]] +set auto_index(rulerNewTab) [list source [file join $dir mkRuler.tcl]] +set auto_index(rulerMoveTab) [list source [file join $dir mkRuler.tcl]] +set auto_index(demo_selectTab) [list source [file join $dir mkRuler.tcl]] +set auto_index(rulerReleaseTab) [list source [file join $dir mkRuler.tcl]] +set auto_index(mkScroll) [list source [file join $dir mkScroll.tcl]] +set auto_index(scrollEnter) [list source [file join $dir mkScroll.tcl]] +set auto_index(scrollLeave) [list source [file join $dir mkScroll.tcl]] +set auto_index(scrollButton) [list source [file join $dir mkScroll.tcl]] +set auto_index(mkTextSearch) [list source [file join $dir mkSearch.tcl]] +set auto_index(TextLoadFile) [list source [file join $dir mkSearch.tcl]] +set auto_index(TextSearch) [list source [file join $dir mkSearch.tcl]] +set auto_index(TextToggle) [list source [file join $dir mkSearch.tcl]] +set auto_index(mkStyles) [list source [file join $dir mkStyles.tcl]] +set auto_index(insertWithTags) [list source [file join $dir mkStyles.tcl]] +set auto_index(mkTear) [list source [file join $dir mkTear.tcl]] +set auto_index(mkTextBind) [list source [file join $dir mkTextBind.tcl]] +set auto_index(insertWithTags) [list source [file join $dir mkTextBind.tcl]] +set auto_index(mkVScale) [list source [file join $dir mkVScale.tcl]] +set auto_index(setHeight) [list source [file join $dir mkVScale.tcl]] +set auto_index(showVars) [list source [file join $dir showVars.tcl]] diff --git a/gcl-tk/demos/widget.lisp b/gcl-tk/demos/widget.lisp new file mode 100755 index 0000000..a785686 --- /dev/null +++ b/gcl-tk/demos/widget.lisp @@ -0,0 +1,220 @@ + +(in-package "TK") +;; +;; This "script" demonstrates the various widgets provided by Tk, +;; along with many of the features of the Tk toolkit. This file +;; only contains code to generate the main window for the +;; application, which invokes individual demonstrations. The +;; code for the actual demonstrations is contained in separate +;; ".tcl" files is this directory, which are auto-loaded by Tcl +;; when they are needed. To find the code for a particular +;; demo, look below for the procedure that's invoked by its menu +;; entry, then grep for the file that contains the procedure +;; definition. + +(tk-do (concatenate 'string + "set auto_path \"" *tk-library* "/demos " "$auto_path\"")) + +;; add teh current path to the auto_path so that we find the +;; .tcl demos for older demos not in new releases.. +(tk-do (concatenate 'string + "lappend auto_path [file dirname " (namestring (truename si::*load-pathname*)) "]")) + + +;(setq si::*load-path* (cons (tk-conc si::*lib-directory* "gcl-tk/demos/") si::*load-path*)) +(load (merge-pathnames "index.lsp" si::*load-pathname*)) + +(wm :title '|.| "Widget Demonstration") + +;;------------------------------------------------------- +;; The code below create the main window, consisting of a +;; menu bar and a message explaining the basic operation +;; of the program. +;;------------------------------------------------------- + +(frame '.menu :relief "raised" :borderwidth 1) +(message '.msg :font :Adobe-times-medium-r-normal--*-180* :relief "raised" :width 500 +:borderwidth 1 :text "This application demonstrates the widgets provided by the GCL Tk toolkit. The menus above are organized by widget type: each menu contains one or more demonstrations of a particular type of widget. To invoke a demonstration, press mouse button 1 over one of the menu buttons above, drag the mouse to the desired entry in the menu, then release the mouse button.) +(To exit this demonstration, invoke the \"Quit\" entry in the \"Misc\" menu.") + +(pack '.menu :side "top" :fill "x") +(pack '.msg :side "bottom" :expand "yes" :fill "both") + +;;------------------------------------------------------- +;; The code below creates all the menus, which invoke procedures +;; to create particular demonstrations of various widgets. +;;------------------------------------------------------- + +(menubutton '.menu.button :text "Labels/Buttons" :menu '.menu.button.m + :underline 7) +(menu '.menu.button.m) +(.menu.button.m :add 'command :label "Labels" :command "mkLabel" :underline 0) +(.menu.button.m :add 'command :label "Buttons" :command "mkButton" :underline 0) +(.menu.button.m :add 'command :label "Checkbuttons" :command "mkCheck" + :underline 0) +(.menu.button.m :add 'command :label "Radiobuttons" :command 'mkRadio + :underline 0) +(.menu.button.m :add 'command :label "15-puzzle" :command "mkPuzzle" :underline 0) +(.menu.button.m :add 'command :label "Iconic buttons" :command "mkIcon" + :underline 0) + +(menubutton '.menu.listbox :text "Listboxes" :menu '.menu.listbox.m + :underline 0) +(menu '.menu.listbox.m) +(.menu.listbox.m :add 'command :label "States" :command 'mkListbox :underline 0) +(.menu.listbox.m :add 'command :label "Colors" :command "mkListbox2" :underline 0) +(.menu.listbox.m :add 'command :label "Well-known sayings" :command "mkListbox3" + :underline 0) + +(menubutton '.menu.entry :text "Entries" :menu '.menu.entry.m + :underline 0) +(menu '.menu.entry.m) +(.menu.entry.m :add 'command :label "Without scrollbars" :command 'mkentry + :underline 4) +(.menu.entry.m :add 'command :label "With scrollbars" :command 'mkEntry2 + :underline 0) +(.menu.entry.m :add 'command :label "Simple form" :command 'mkForm + :underline 0) + +(menubutton '.menu.text :text "Text" :menu '.menu.text.m :underline 0) +(menu '.menu.text.m) +(.menu.text.m :add 'command :label "Basic text" :command 'mkBasic + :underline 0) +(.menu.text.m :add 'command :label "Display styles" :command 'mkStyles + :underline 0) +(.menu.text.m :add 'command :label "Command bindings" :command 'mkTextBind + :underline 0) +(.menu.text.m :add 'command :label "Search" :command "mkTextSearch" + :underline 0) + +(menubutton '.menu.scroll :text "Scrollbars" :menu '.menu.scroll.m + :underline 0) +(menu '.menu.scroll.m) +(.menu.scroll.m :add 'command :label "Vertical" :command "mkListbox2" :underline 0) +(.menu.scroll.m :add 'command :label "Horizontal" :command "mkEntry2" :underline 0) + +(menubutton '.menu.scale :text "Scales" :menu '.menu.scale.m :underline 2) +(menu '.menu.scale.m) +(.menu.scale.m :add 'command :label "Vertical" :command 'mkVScale :underline 0) +(.menu.scale.m :add 'command :label "Horizontal" :command 'mkHScale :underline 0) + +(menubutton '.menu.canvas :text "Canvases" :menu '.menu.canvas.m + :underline 0) +(menu '.menu.canvas.m) +(.menu.canvas.m :add 'command :label "Item types" :command 'mkItems :underline 0) +(.menu.canvas.m :add 'command :label "2-D plot" :command 'mkPlot :underline 0) +(.menu.canvas.m :add 'command :label "Text" :command "mkCanvText" :underline 0) +(.menu.canvas.m :add 'command :label "Arrow shapes" :command "mkArrow" :underline 0) +(.menu.canvas.m :add 'command :label "Ruler" :command 'mkRuler :underline 0) +(.menu.canvas.m :add 'command :label "Scrollable canvas" :command "mkScroll" + :underline 0) +(.menu.canvas.m :add 'command :label "Floor plan" :command "mkFloor" + :underline 0) + +(menubutton '.menu.menu :text "Menus" :menu '.menu.menu.m :underline 0) +(menu '.menu.menu.m) +(.menu.menu.m :add 'command :label "Print hello" :command '(print "Hello") + :accelerator "Control+a" :underline 6) +(bind '|.| "" '(print "Hello")) +(.menu.menu.m :add 'command :label "Print goodbye" :command + '(print "Goodbye") :accelerator "Control+b" :underline 6) +(bind '|.| "" '(format t "Goodbye")) +(.menu.menu.m :add 'command :label "Light blue background" + :command '(.msg :configure :bg "LightBlue1") :underline 0) +(.menu.menu.m :add 'command :label "Info on tear-off menus" :command "mkTear" + :underline 0) +(.menu.menu.m :add 'cascade :label "Check buttons" :menu '.menu.menu.m.check + :underline 0) +(.menu.menu.m :add 'cascade :label "Radio buttons" :menu '.menu.menu.m.radio + :underline 0) +(.menu.menu.m :add 'command :bitmap "@": *tk-library* :"/demos/bitmaps/pattern" + :command ' + (mkDialog '.pattern '(:text "The menu entry you invoked displays a bitmap rather than a text string. Other than this, it is just like any other menu entry." :aspect 250 ))) + + +(menu '.menu.menu.m.check) +(.menu.menu.m.check :add 'check :label "Oil checked" :variable 'oil) +(.menu.menu.m.check :add 'check :label "Transmission checked" :variable 'trans) +(.menu.menu.m.check :add 'check :label "Brakes checked" :variable 'brakes) +(.menu.menu.m.check :add 'check :label "Lights checked" :variable 'lights) +(.menu.menu.m.check :add 'separator) +(.menu.menu.m.check :add 'command :label "Show current values" + :command '(showVars '.menu.menu.dialog '(oil trans brakes lights))) +(.menu.menu.m.check :invoke 1) +(.menu.menu.m.check :invoke 3) + +(menu '.menu.menu.m.radio) +(.menu.menu.m.radio :add 'radio :label "10 point" :variable 'pointSize :value 10) +(.menu.menu.m.radio :add 'radio :label "14 point" :variable 'pointSize :value 14) +(.menu.menu.m.radio :add 'radio :label "18 point" :variable 'pointSize :value 18) +(.menu.menu.m.radio :add 'radio :label "24 point" :variable 'pointSize :value 24) +(.menu.menu.m.radio :add 'radio :label "32 point" :variable 'pointSize :value 32) +(.menu.menu.m.radio :add 'sep) +(.menu.menu.m.radio :add 'radio :label "Roman" :variable 'style :value "roman") +(.menu.menu.m.radio :add 'radio :label "Bold" :variable 'style :value "bold") +(.menu.menu.m.radio :add 'radio :label "Italic" :variable 'style :value "italic") +(.menu.menu.m.radio :add 'sep) +(.menu.menu.m.radio :add 'command :label "Show current values" :command + '(showVars '.menu.menu.dialog '(pointSize style))) +(.menu.menu.m.radio :invoke 1) +(.menu.menu.m.radio :invoke 7) + +(menubutton '.menu.misc :text "Misc" :menu '.menu.misc.m :underline 1) +(menu '.menu.misc.m) +(.menu.misc.m :add 'command :label "Modal dialog (local grab)" :command ' + (progn + (mkDialog '.modal '(:text "This dialog box is a modal one. It uses Tk's \"grab\" command to create a \"local grab\" on the dialog box. The grab prevents any pointer related events from getting to any other windows in the application. If you press the \"OK\" button below (or hit the Return key) then the dialog box will go away and things will return to normal." :aspect 250 :justify "left") '("OK" nil) '("Hi" (print "hi"))) + (wm :geometry '.modal "+10+10") + (tk-wait-til-exists '.modal) + ; (tkwait :visibility '.modal) + (grab '.modal) + (tkwait :window '.modal) + ) + :underline 0) +(.menu.misc.m + :add 'command :label "Modal dialog (global grab)" + :command + '(progn + (mkDialog '.modal '(:text "This is another modal dialog box. However, in this case a \"global grab\" is used, which locks up the display so you can't talk to any windows in any applications anywhere, except for the dialog. If you press the \"OK\" button below (or hit the Return key) then the dialog box will go away and things will return to normal." :aspect 250 :justify "left") '("OK" nil) '("Hi" (print "hi1"))) + + (wm :geometry '.modal "+10+10") + (tk-wait-til-exists '.modal) + ;(tkwait :visibility '.modal) + (grab :set :global '.modal) + (tkwait :window '.modal) + ) + :underline 0) +(.menu.misc.m :add 'command :label "Built-in bitmaps" :command "mkBitmaps" + :underline 0) +(.menu.misc.m :add 'command :label "GC monitor" + :command 'mkgcmonitor :underline 0) +(.menu.misc.m :add 'command :label "Quit" :command "destroy ." :underline 0) + +(pack '.menu.button '.menu.listbox '.menu.entry '.menu.text '.menu.scroll + '.menu.scale '.menu.canvas '.menu.menu '.menu.misc :side "left") + +;; Set up for keyboard-based menu traversal + +(bind '|.| "" + '(progn + (if (and (equal |%d| "NotifyVirtual") + (equal |%m| "NotifyNormal")) + (focus '.menu) + ))) + +;; make the meta key do traversal bindings +(bind '.menu "" "tk_traverseToMenu %W %A") + +(tk-menu-bar '.menu '.menu.button '.menu.listbox '.menu.entry '.menu.text + '.menu.scroll '.menu.scale '.menu.canvas '.menu.menu '.menu.misc) + +;; Position a dialog box at a reasonable place on the screen. + +(defun dpos (w) + (wm :geometry w "+60+25") +) + +;; some of the widgets are tcl and need this. +(tk-do "proc dpos w { + wm geometry $w +300+300 +}") diff --git a/gcl-tk/dir.sed b/gcl-tk/dir.sed new file mode 100755 index 0000000..5b3a2db --- /dev/null +++ b/gcl-tk/dir.sed @@ -0,0 +1,3 @@ +/DIR=/a\ +DIR=/home/wfs/gcl-2.0/gcl-tk +/DIR=/d diff --git a/gcl-tk/gcl-1.tcl b/gcl-tk/gcl-1.tcl new file mode 100755 index 0000000..9fc32bb --- /dev/null +++ b/gcl-tk/gcl-1.tcl @@ -0,0 +1,39 @@ + +set LongestMatchPossible 3000 + +proc MarkRegexps { w regexp tag tags {start 0.0} {end end}} { + upvar #0 LongestMatchPossible longest + $w mark set MaRe $start + set found 0 + while {[$w compare MaRe < $end]} { + set began MaRe + set text [$w get MaRe "MaRe + [expr 10 * $longest] chars"] + set limit [expr 9 * $longest] + set begin 0 + set last "-1 -1" + while {[regexp -indices $regexp $text all j1 j2 j3 j4 j5 j6 j7 j8 \ + j9 ]} { + incr found + set i 1 + set endmatch [lindex $all 1] + $w tag add $tag "MaRe + [expr $begin + [lindex $all 0]] chars" \ + "MaRe + [expr $begin + [lindex $all 1]] chars" + foreach ta $tags { + set all [set j$i] + incr i + if { $all != "-1 -1" } { +# puts stdout "ta=$ta taa=[set $ta]" +# puts stdout "found $endmatch: `[string range $text [lindex $all 0] [lindex $all 1]]'" + $w tag add $ta "MaRe + [expr $begin + [lindex $all 0]] chars" \ + "MaRe + [expr $begin + [lindex $all 1]] chars" } + } +# puts stdout "found $endmatch: `[string range $text [expr $endmatch - 10] \ +[expr $endmatch + 4]]'" + set text [string range $text $endmatch end] + incr begin $endmatch + if {[expr $begin >= $limit]} { set limit $begin ;break} + } + $w mark set MaRe "MaRe + $limit chars" +} +# puts stdout "found $found matches" +} diff --git a/gcl-tk/gcl.tcl b/gcl-tk/gcl.tcl new file mode 100755 index 0000000..4a081ad --- /dev/null +++ b/gcl-tk/gcl.tcl @@ -0,0 +1,55 @@ + +# some extensions for gcl +# of course these could be in lisp, but keeping them on the +# tk side of the pipe can cut down overhead. for large things +# like getting a file + +proc TextLoadFile {w file} { + set f [open $file] + $w delete 1.0 end + while {![eof $f]} { + $w insert end [read $f 10000] + } + close $f +} + +proc insertWithTags {w text args} { + set start [$w index insert] + $w insert insert $text + foreach tag [$w tag names $start] { + $w tag remove $tag $start insert + } + foreach i $args { + $w tag add $i $start insert + } +} +# in WINDOW if TAG is set at INDEX then return the range +# of indices for which tag is set including index. + +proc get_tag_range {w tag index} { + set i 1 + set index [$w index $index] + set range "" + set ok 0 +# puts stdout $index + foreach v [$w tag names $index] { if {$v == $tag} {set ok 1}} + while $ok { + set range [$w tag nextrange $tag "$index -$i chars" "$index +1 char"] + if {[llength $range ] >= 2} { break;} + if {[$w compare "$index - $i chars" <= "0.0 + 1 chars" ]} { break;} + set i [expr $i + 1] + } + return $range +} + +proc MultipleTagAdd {win tag start l} { + set prev -1 + foreach v $l { puts stdout $v + if { "$prev" == "-1" } { + set prev $v + } else { + $win tag add $tag "$start + $prev chars" "$start + $v chars" + set prev -1 +}}} + + diff --git a/gcl-tk/gcl_cmpinit.lsp b/gcl-tk/gcl_cmpinit.lsp new file mode 100755 index 0000000..4bb83bd --- /dev/null +++ b/gcl-tk/gcl_cmpinit.lsp @@ -0,0 +1 @@ +(load "tk-package.lsp") \ No newline at end of file diff --git a/gcl-tk/gcl_guisl.h b/gcl-tk/gcl_guisl.h new file mode 100755 index 0000000..5794d47 --- /dev/null +++ b/gcl-tk/gcl_guisl.h @@ -0,0 +1,9 @@ + +static L1(); +static L2(); +static char * VVi[2]={ +#define Cdata VV[1] +(char *)(L1), +(char *)(L2) +}; +#define VV ((object *)VVi) diff --git a/gcl-tk/gcltksrv.bat b/gcl-tk/gcltksrv.bat new file mode 100755 index 0000000..ffee8d0 --- /dev/null +++ b/gcl-tk/gcltksrv.bat @@ -0,0 +1,8 @@ +set GCL_TK_DIR=c:/cvs/gcl/gcl-tk +set TCL_LIBRARY=c:/lang/tcl/lib/tcl8.3 +set TK_LIBRARY=c:/lang/tcl/lib/tcl8.3 +start %GCL_TK_DIR%/gcltkaux %1 %2 %3 + + + + diff --git a/gcl-tk/gcltksrv.in b/gcl-tk/gcltksrv.in new file mode 100755 index 0000000..072f295 --- /dev/null +++ b/gcl-tk/gcltksrv.in @@ -0,0 +1,31 @@ +#!/bin/sh +# where to find bitmaps, +# and the class bindings in /usr/local/lib/tk/tk.tcl +GCL_TK_DIR=/home/wfs/gcl-2.0/gcl-tk +TK_XLIB_DIR=/usr/local/X11R6/lib +if [ -d "${TK_XLIB_DIR}" ] ; then + export LD_LIBRARY_PATH + LD_LIBRARY_PATH=${LD_LIBRARY_PATH}:${TK_XLIB_DIR} +fi + +#check to see if TK_LIBRARY set in users environment ok.. +if [ -f ${TK_LIBRARY}/tk.tcl ] ;then true; +else +TK_LIBRARY=/var/X11/lib/X11/tk + if [ -f ${TK_LIBRARY}/tk.tcl ] ;then export TK_LIBRARY ; fi +export TK_LIBRARY +fi +if [ -f ${TCL_LIBRARY}/init.tcl ] ;then true; +else +TCL_LIBRARY=/usr/local/lib/tcl + if [ -f ${TCL_LIBRARY}/init.tcl ] ; then export TCL_LIBRARY ; fi +fi +if [ $# -ge 4 ] ;then +DISPLAY=$4 ; +export DISPLAY; +fi +exec ${GCL_TK_DIR}/gcltkaux $1 $2 $3 + + + + diff --git a/gcl-tk/gcltksrv.in.interp b/gcl-tk/gcltksrv.in.interp new file mode 100755 index 0000000..e45d8ff --- /dev/null +++ b/gcl-tk/gcltksrv.in.interp @@ -0,0 +1,15 @@ +#!/bin/sh +# comment \ +export GCL_TK_DIR ; \ +GCL_TK_DIR=/d2/wfs/gcl-2.3/gcl-tk +#comment \ +export DISPLAY; DISPLAY=$4 ; exec wish "$0" "$@" +set host [lindex $argv 0] +set port [lindex $argv 1] +set pid [lindex $argv 2] +source $env(GCL_TK_DIR)/decode.tcl +GclAnswerSocket $host $port $pid + + + + diff --git a/gcl-tk/gcltksrv.prev b/gcl-tk/gcltksrv.prev new file mode 100755 index 0000000..9ca8fe8 --- /dev/null +++ b/gcl-tk/gcltksrv.prev @@ -0,0 +1,22 @@ +#!/bin/sh +# where to find bitmaps, +# and the class bindings in /usr/local/lib/tk/tk.tcl +TK_LIBRARY=/var/X11/lib/X11/tk +DIR=/d19/staff/wfs/ngcl-2.0/gcl-tk +TK_LIBRARY=/public/lib/tk +DIR=/d19/staff/wfs/ngcl-2.0/gcl-tk +#put correct dir +if [ -f ${TK_LIBRARY}/tk.tcl ] ; then true; +else +TK_LIBRARY=/usr/local/lib/tk +export TK_LIBRARY +fi +if [ $# -ge 4 ] ;then +DISPLAY=$4 ; +export DISPLAY; +fi +exec ${DIR}/gcltkaux $1 $2 $3 + + + + diff --git a/gcl-tk/guis.c b/gcl-tk/guis.c new file mode 100755 index 0000000..74e6bbd --- /dev/null +++ b/gcl-tk/guis.c @@ -0,0 +1,509 @@ +/* + Copyright (C) 1994 Rami el Charif, W. Schelter + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#define IN_GUIS + +#include +#include +#include +#ifdef __cplusplus +extern "C" { +#endif + +#include + +#ifndef _WIN32 +# include +# ifdef PLATFORM_NEXT +# include +# include +# else +# include +# include +# endif +#endif + +/* #include */ + +#include + +#ifndef _WIN32 +#include +#endif + +#include +#include +#include +#ifdef __cplusplus +#ifdef PLATFORM_NEXT +extern unsigned long inet_addr( char *cp ); +extern char *inet_ntoa ( struct in_addr in ); +#endif +} +#endif +#ifdef PLATFORM_LINUX +#include +#endif +#include + +#ifdef __svr4__ +#include +#endif + +#ifdef PLATFORM_NEXT /* somehow, this is getting lost... */ +#undef bzero +#define bzero(b,len) memset(b,0,len) +#endif + + +#include "guis.h" + +#ifndef TRUE +#define TRUE (1) +#define FALSE (0) +#endif + +FILE *pstreamDebug; +int fDebugSockets; + +/* #ifdef PLATFORM_SUNOS */ +/* static void notice_input( ); */ +/* #else */ +/* static void notice_input(); */ +/* #endif */ + +int hdl = -1; + +void TkX_Wish (); + +pid_t parent; + +int debug; + +#ifdef _WIN32 + +#include +#include + +/* Keep track of socket initialisations */ +int w32_socket_initialisations = 0; + +WSADATA WSAData; + + +/* Use threads instead of fork() */ +/* Struct to hold args for thread. */ +typedef struct _TAS { + char **argv; + int argc; + int rv; + int delay; +} TAS; + +#endif + +#include "comm.c" + +#ifdef _WIN32 + +#define SET_SESSION_ID() 0 + +UINT WINAPI tf1 ( void *tain ) +{ + TAS *ta = (TAS *) tain; + UINT rv = 0; + if (SET_SESSION_ID() == -1) { + fprintf ( stderr, "tf: Error - set session id failed : %d\n", errno ); + } + if ( w32_socket_init() >= 0 ) { + dsfd = sock_connect_to_name ( ta->argv[1], atoi ( ta->argv[2] ), 0); + if ( dsfd ) { + fprintf ( stderr, "connected to %s %s\n", ta->argv[1], ta->argv[2] ); + TkX_Wish ( ta->argc, ta->argv ); + fprintf ( stderr, "Wish shell done\n" ); + sock_close_connection ( dsfd ); + ta->rv = 0; + } else { + fprintf ( stderr, + "Error: Can't connect to socket host=%s, port=%s, errno=%d\n", + ta->argv[1], ta->argv[2], errno ); + fflush ( stderr ); + ta->rv = -1; + } + w32_socket_exit(); + } else { + fprintf ( stderr, "tf: Can't initialise sockets - w32_socket_init failed.\n" ); + } + _endthreadex ( 0 ); + return ( 0 ); +} + +int w32_socket_init(void) +{ + int rv = 0; + if (w32_socket_initialisations++) { + rv = 0; + } else { + if (WSAStartup(0x0101, &WSAData)) { + w32_socket_initialisations = 0; + fprintf ( stderr, "WSAStartup failed\n" ); + WSACleanup(); + rv = -1; + } + } + + return rv; +} + +int w32_socket_exit(void) +{ + int rv = 0; + + if ( w32_socket_initialisations == 0 || + --w32_socket_initialisations > 0 ) { + rv = 0; + } else { + rv = WSACleanup(); + } + + return rv; +} + +#endif + + +/* Start up our Graphical User Interface connecting to + NETWORK-ADDRESS on PORT to process PID. If fourth + argument WAITING causes debugging flags to be turned + on and also causes a wait in a loop for WAITING seconds + (giving a human debugger time to attach to the forked process). + */ + +#ifdef SGC +int sgc_enabled=0; +#endif + +int delay; +int main(argc, argv,envp) +int argc; +char *argv[]; +char *envp[]; +{ + int rv = 0; + { + int i = argc; + pstreamDebug = stderr; + while (--i > 3) { + if (strcmp(argv[i],"-delay")==0) + { delay = atoi(argv[i+1]);} + if (strcmp(argv[i],"-debug")==0) + {debug = 1; fDebugSockets = -1;} + } + } + + if (argc >= 4) { + +#ifdef _WIN32 + UINT dwThreadID; + HANDLE hThread; + TAS targs; + void *pTA = (void *) &targs; + targs.argv = argv; + targs.argc = argc; + targs.rv = 0; + targs.delay = delay; + + hThread = (HANDLE) _beginthreadex ( + NULL, + 0, + tf1, + pTA, + 0, + &dwThreadID + ); + if ( 0 == hThread ) { + dfprintf ( stderr, "Error: Couldn't create thread.\n" ); + rv = -1; + } + if ( WAIT_OBJECT_0 != WaitForSingleObject ( hThread, INFINITE ) ) { + dfprintf ( stderr, "Error: Couldn't wait for thread to exit.\n" ); + rv = -1; + } + CloseHandle ( hThread ); + +#else /* _WIN32 */ + pid_t p; + + parent = atoi(argv[3]); + dfprintf(stderr,"guis, parent is : %d\n", parent); + +#ifdef MUST_USE_VFORK + p = vfork(); +#else + p = fork(); +#endif + dfprintf(stderr, "guis, vfork returned : %d\n", p); + + if (p == -1) + { + dfprintf(stderr, "Error !!! vfork failed %d\n", errno); + + return -1; + } + else if (p) + { + dfprintf(stderr, "guis,vforked child : %d\n", p); + + _exit(p); + /* + return p; + */ + } + else + { + +#ifndef SET_SESSION_ID +#if defined(__svr4__) || defined(ATT) +#define SET_SESSION_ID() setsid() +#else +#ifdef BSD +#define SET_SESSION_ID() (setpgrp() ? -1 : 0) +#endif +#endif +#endif + + if (SET_SESSION_ID() == -1) + { dfprintf(stderr, "Error !!! setsid failed : %d\n", errno); + } + + + dsfd = sock_connect_to_name(argv[1], atoi(argv[2]), 0); + if (dsfd) { + dfprintf(stderr, "connected to %s %s" + , argv[1], argv[2]); + /* give chance for someone to attach with gdb and + to set waiting to 0 */ + while (-- delay >=0) sleep(1); + { + TkX_Wish(argc, argv); + } + + dfprintf(stderr, "Wish shell done\n"); + + sock_close_connection(dsfd); + return 0; + } else { + dfprintf(stderr, + "Error !!! Can't connect to socket host=%s, port=%s, errno=%d\n" + , argv[1], argv[2], errno); + fflush(stderr); + return -1; + } + } +#endif /* _WIN32 */ + } else { + int i; + fprintf ( stderr, "gcltkaux: Error - expecting more arguments, but found:\n" ); + fflush(stderr); + for ( i = 0; ifd ); + free(sfd->read_buffer); + free(sfd); + +} + + +/* #ifdef PLATFORM_SUNOS */ +/* static void */ +/* notice_input( int sig, int code, struct sigcontext *s, char *a ) */ +/* #else */ +/* static void */ +/* notice_input( sig ) */ +/* int sig; */ +/* #endif */ +/* { */ +/* signal( SIGIO, notice_input ); */ +/* dfprintf(stderr, "\nNoticed input!\n" ); */ + +/* } */ + +static int message_id; + +int +sock_write_str2( sfd, type, hdr, + hdrsize,text, length ) + +struct connection_state *sfd; +enum mtype type; + char *hdr; +int hdrsize; +const char *text; +int length; + +{ + char buf[0x1000]; + char *p = buf; + int m; + int n_written; + struct message_header *msg; + msg = (struct message_header *) buf; + + if (length == 0) + length = strlen(text); + m = length + hdrsize; + + msg->magic1=MAGIC1; + msg->magic2=MAGIC2; + msg->type = type; + msg->flag = 0; + STORE_3BYTES(msg->size,m); + STORE_3BYTES(msg->msg_id,message_id); + message_id++; + p = buf + MESSAGE_HEADER_SIZE; + bcopy(hdr,p,hdrsize); + p+= hdrsize; + + if (sizeof(buf) >= (length + hdrsize + MESSAGE_HEADER_SIZE)) + { bcopy(text,p,length); + n_written = write1(sfd,buf,(length + hdrsize + MESSAGE_HEADER_SIZE)); + } + else + { n_written = write1(sfd,buf, hdrsize + MESSAGE_HEADER_SIZE); + n_written += write1(sfd, text, length); + } + + if (n_written != (length + hdrsize + MESSAGE_HEADER_SIZE)) + {perror("sock_write_str: Did not write full message"); + return -1;} + return n_written; + +} + + +#define READ_BUF_STRING_AVAIL 1 +#define READ_BUF_DATA_ON_PORT 2 + + + +#define DEFAULT_TIMEOUT_FOR_TK_READ (100 * HZ) + + + +struct message_header * +guiParseMsg1(sfd,buf,bufleng) + char *buf; +int bufleng; +struct connection_state *sfd; +{ int m; + int body_length; + int tot; + struct message_header *msg; + msg = (struct message_header *) buf; + m= read1(sfd,msg,MESSAGE_HEADER_SIZE,DEFAULT_TIMEOUT_FOR_TK_READ); + if (m == MESSAGE_HEADER_SIZE) + { + if ( msg->magic1!=MAGIC1 + || msg->magic2!=MAGIC2) + { fprintf(stderr,"bad magic..flushing buffers"); + while(read1(sfd,buf,bufleng,0) > 0); + return 0;} + GET_3BYTES(msg->size,body_length); + tot = body_length+MESSAGE_HEADER_SIZE; + if (tot >= bufleng) + {msg = (void *)malloc(tot+1); + bcopy(buf,msg,MESSAGE_HEADER_SIZE);} + m = read1(sfd,&(msg->body), + body_length,DEFAULT_TIMEOUT_FOR_TK_READ); + if (m == body_length) + { return msg;}} + if (m < 0) exit(1); + { static int bad_read_allowed=4; + if (bad_read_allowed-- < 0) exit(1); + } + + dfprintf(stderr,"reading from lisp timed out or not enough read"); + return 0; +} + +void +error(s) + char *s; +{ fprintf(stderr,"%s",s); abort(); +} + +void +write_timeout_error(s) + char *s; +{ fprintf(stderr,"write timeout: %s",s); abort(); +} +void +connection_failure(s) + char *s; +{ fprintf(stderr,"connection_failure:%s",s); abort(); +} + +object +make_fixnum1(long i) { + + static union lispunion lu; + + lu.FIX.FIXVAL=i; + return &lu; + +} diff --git a/gcl-tk/guis.h b/gcl-tk/guis.h new file mode 100755 index 0000000..6627ae0 --- /dev/null +++ b/gcl-tk/guis.h @@ -0,0 +1,99 @@ +#ifndef _GUIS_H_ +#define _GUIS_H_ + +#include + +#define NO_PRELINK_UNEXEC_DIVERSION +#include "include.h" + +#ifdef NeXT +typedef int pid_t; +#endif + +#ifndef _ANSI_ARGS_ +#ifdef __STDC__ +#define _ANSI_ARGS_(x) x +#else +#define _ANSI_ARGS_(x) () +#endif +#endif + +#define STRING_HEADER_FORMAT "%4.4d" +#define CB_STRING_HEADER (5) +/* +#define GET_STRING_SIZE_FROM_HEADER(__buf, __plgth) \ +sscanf(__buf, STRING_HEADER_FORMAT, __plgth); +*/ + +/* sscanf is braindead on SunOS */ +#define GET_STRING_SIZE_FROM_HEADER(__buf, __plgth) \ +{\ + __buf[CB_STRING_HEADER - 1] = 0;\ + *__plgth = atoi(__buf);\ + __buf[4] = '';\ +} + +/* need to have opportunity to collapse message to reduce trafic */ +#define MSG_STRAIGHT_TCL_CMD 0 +#define MSG_CREATE_COMMAND 1 +/* +#define MSG_ +*/ + +typedef struct _guiMsg { + + pid_t pidSender; + int vMajor; + int vMinor; + int idx; + int fSignal; + int fAck; + int IdMsg; + char *szData; + char *szMsg; + +} guiMsg; + +#define MSG_IDX(__p) (__p->idx) +#define MSG_COMMAND(__p) (__p->IdMsg) +#define MSG_NEED_ACK(__p) (__p->fAck) +#define MSG_NEED_SIGNAL_PARENT(__p) (__p->fSignal) +#define MSG_TCL_STR(__p) (__p->szData) +#define MSG_DATA_STR(__p) (__p->szData) +/* +#define MSG_(__p) (__p->) +*/ + +#include "sheader.h" +struct message_header * guiParseMsg1(); + + +extern pid_t parent; + +struct connection_state * +sock_connect_to_name(); +void sock_close_connection( ); +int sock_read_str(); + +guiMsg *guiParseMsg(); +void guiFreeMsg(); + +void +guiCreateThenBindCallback(); +int guiBindCallback(); + +#endif + +int +sock_write_str2(struct connection_state *,enum mtype, char *, + int,const char *,int); + + +object +fSclear_connection(fixnum); + + +object +fScheck_fd_for_input(fixnum,fixnum); + +#define SI_makefun(a_,b_,c_) diff --git a/gcl-tk/helpers.lisp b/gcl-tk/helpers.lisp new file mode 100755 index 0000000..c90c5b9 --- /dev/null +++ b/gcl-tk/helpers.lisp @@ -0,0 +1,21 @@ + +(in-package "TK") + +(setq controls '( + after exit lower place send tkvars winfo focus option raise tk tkwait wm destroy grab pack selection tkerror update tk_listboxSingleSelect)) + +(setq widgets '( + button listbox scale canvas menu scrollbar checkbutton menubutton text entry message frame label radiobutton toplevel )) + + +(defun get-options (com) + (let ((tem (funcall com "jo" :return 'string)) + (cond ((equal (subseq tem 0 (length s)) + s) + (setq tem (subseq tem (length s))) + (setq tem (substitute #\space #\, tem)) + (setq tem (list-string tem)) + (setq tem (delete "or" tem :test 'equal)) + + (mapcar #'(lambda (x) (intern (string-upcase x) :keyword)) tem) + )))) diff --git a/gcl-tk/index.lsp b/gcl-tk/index.lsp new file mode 100755 index 0000000..a95a71c --- /dev/null +++ b/gcl-tk/index.lsp @@ -0,0 +1,55 @@ + +(in-package "TK") +(AUTOLOAD 'FILE-TO-STRING '|info|) +(AUTOLOAD 'ATOI '|info|) +(AUTOLOAD 'INFO-GET-TAGS '|info|) +(AUTOLOAD 'RE-QUOTE-STRING '|info|) +(AUTOLOAD 'GET-MATCH '|info|) +(AUTOLOAD 'GET-NODES '|info|) +(AUTOLOAD 'GET-INDEX-NODE '|info|) +(AUTOLOAD 'NODES-FROM-INDEX '|info|) +(AUTOLOAD 'GET-NODE-INDEX '|info|) +(AUTOLOAD 'ALL-MATCHES '|info|) +(AUTOLOAD 'NODE-OFFSET '|info|) +(AUTOLOAD 'SETUP-INFO '|info|) +(AUTOLOAD 'GET-INFO-CHOICES '|info|) +(AUTOLOAD 'ADD-FILE '|info|) +(AUTOLOAD 'INFO-ERROR '|info|) +(AUTOLOAD 'INFO-GET-FILE '|info|) +(AUTOLOAD 'WAITING '|info|) +(AUTOLOAD 'END-WAITING '|info|) +(AUTOLOAD 'INFO-SUBFILE '|info|) +(AUTOLOAD 'INFO-NODE-FROM-POSITION '|info|) +(AUTOLOAD 'SHOW-INFO '|info|) +(AUTOLOAD 'INFO-AUX '|info|) +(AUTOLOAD 'INFO-SEARCH '|info|) +(AUTOLOAD 'IDESCRIBE '|info|) +(AUTOLOAD 'INFO '|info|) +(AUTOLOAD 'DEFAULT-INFO-HOTLIST '|info|) +(AUTOLOAD 'ADD-TO-HOTLIST '|info|) +(AUTOLOAD 'LIST-MATCHES '|info|) +(AUTOLOAD 'SIMPLE-LISTBOX '|tinfo|) +(AUTOLOAD 'INSERT-STANDARD-LISTBOX '|tinfo|) +(AUTOLOAD 'LISTBOX-MOVE '|tinfo|) +(AUTOLOAD 'NEW-WINDOW '|tinfo|) +(AUTOLOAD 'INSERT-INFO-CHOICES '|tinfo|) +(AUTOLOAD 'OFFER-CHOICES '|tinfo|) +(AUTOLOAD 'GET-INFO-APROPOS '|tinfo|) +(AUTOLOAD 'SHOW-INFO-KEY '|tinfo|) +(AUTOLOAD 'MKINFO '|tinfo|) +(AUTOLOAD 'INFO-TEXT-SEARCH '|tinfo|) +(AUTOLOAD 'PRINT-NODE '|tinfo|) +(AUTOLOAD 'INFO-SHOW-HISTORY '|tinfo|) +(AUTOLOAD 'SHOW-THIS-NODE '|tinfo|) +(AUTOLOAD 'SCROLL-SET-FIX-XREF-CLOSURE '|tinfo|) +(AUTOLOAD 'FIX-XREF '|tinfo|) +(AUTOLOAD 'INSERT-FONTIFIED '|tinfo|) +(AUTOLOAD 'SECTION-HEADER '|tinfo|) +(AUTOLOAD 'INSERT-STRING '|tinfo|) +(AUTOLOAD 'INSERT-STRING-WITH-REGEXP '|tinfo|) +(AUTOLOAD 'COUNT-CHAR '|tinfo|) +(AUTOLOAD 'START-OF-ITH-LINE '|tinfo|) +(AUTOLOAD 'INDEX-TO-POSITION '|tinfo|) + +(SETQ SYSTEM::*LOAD-PATH* + (APPEND '("/usr/local/gcl-2.2/gcl-tk/") SYSTEM::*LOAD-PATH*)) \ No newline at end of file diff --git a/gcl-tk/intrs.h b/gcl-tk/intrs.h new file mode 100755 index 0000000..e69de29 diff --git a/gcl-tk/makefile b/gcl-tk/makefile new file mode 100644 index 0000000..0535541 --- /dev/null +++ b/gcl-tk/makefile @@ -0,0 +1,76 @@ + +.SUFFIXES: +.SUFFIXES: .o .lsp .lisp .c + +CC=cc +LD_ORDINARY_CC=${CC} +GCLTKCC=${CC} +# Need libX11.a and libtcl.a, machine.defs may say where.. + +CC = gcc +HDIR = ../h +ODIR = ../o + +GCLIB = ../o/gcllib.a + + +-include ../makedefs + + +CFLAGS1=$(CFLAGS) -I../o -I../h ${TK_INCLUDE} ${TCL_INCLUDE} ${TK_XINCLUDES} + + +all: gcltksrv tkl.o tinfo.o demos/gc-monitor.o gcltkaux + (cd demos ; \ + echo '(load "../tkl.o")(TK::GET-AUTOLOADS (directory "*.lisp"))' | ../../unixport/$(FLISP)) + +.lisp.o: + echo "(compile-file \"$*.lisp\" :c-file nil :c-debug nil)" | ../unixport/$(FLISP) + +.lsp.o: + echo "(compile-file \"$*.lsp\" :c-file nil :c-debug nil)" | ../unixport/$(FLISP) + + + +GUIOS = guis.o tkAppInit.o tkMain.o + +clean:: + rm -f ${GUIOS} $(OFILES) gcltkaux gcltksrv *.o */*.o demos/index.lsp *.fn demos/*.fn + +.c.o: + $(GCLTKCC) -c $(CFLAGS1) ${ODIR_DEBUG} $*.c + + +# for some reason -lieee is on various linux systems in the list of requireds.. + +gcltkaux: $(GUIOS) + $(LD_ORDINARY_CC) $(GUIOS) $(LDFLAGS) -o gcltkaux ${TK_LIB_SPEC} ${TCL_LIB_SPEC} + +gcltksrv: makefile + cat gcltksrv.in | sed -e "s!TK_LIBRARY=.*!TK_LIBRARY=${TK_LIBRARY}!g" \ + -e "s!TCL_LIBRARY=.*!TCL_LIBRARY=${TCL_LIBRARY}!g" \ + -e "s!TK_XLIB_DIR=.*!TK_XLIB_DIR=${TK_XLIB_DIR}!g" \ + -e "s!GCL_TK_DIR=.*!GCL_TK_DIR=${GCLDIR}/gcl-tk!g" > gcltksrv + chmod a+x gcltksrv + +gcltksrv.interp: makefile + cat gcltksrv.in.interp | sed -e "s!TK_LIBRARY=.*!TK_LIBRARY=${TK_LIBRARY}!g" \ + -e "s!TK_XLIB_DIR=.*!TK_XLIB_DIR=${TK_XLIB_DIR}!g" \ + -e "s!TCL_LIBRARY=.*!TCL_LIBRARY=${TCL_LIBRARY}!g" \ + -e "s!GCL_TK_DIR=.*!GCL_TK_DIR=${GCLDIR}/gcl-tk!g" > gcltksrv.interp + chmod a+x gcltksrv.interp + +INTERESTING=*.lsp *.lisp tk*.c guis.c sockets.c comm.c Makefile demos/*.lisp *.h + +tar: + tar cvf - ${INTERESTING} | gzip -c > /u/wfs/sock-`date +%y%m%d`.tgz +tags: + etags *.lsp *.lisp tk*.c guis.c sockets.c guis.h our_io.c + +tkAppInit.o : tkAppInit.c +tkMain.o : tkMain.c +tkXAppInit.o : tkXAppInit.c +tkXshell.o : tkXshell.c +guis.o : guis.c guis.h comm.c sheader.h +sockets.c: our_io.c sheader.h +socketsl.o: socketsl.lisp sockets.c diff --git a/gcl-tk/makefile.prev b/gcl-tk/makefile.prev new file mode 100644 index 0000000..07fff6f --- /dev/null +++ b/gcl-tk/makefile.prev @@ -0,0 +1,129 @@ + +.SUFFIXES: +.SUFFIXES: .o .lsp .lisp .c + +CC=cc +LD_ORDINARY_CC=${CC} +# Need libX11.a and libtcl.a, machine.defs may say where.. + +CC = gcc +HDIR = ../h +ODIR = ../o + +GCLIB = ../o/gcllib.a + +# begin makedefs + +# use=386-linux + +LIBS= -lm + + + +GCLDIR=/d2/wfs/gcl-2.3 +SHELL=/bin/sh +MACHINE=386-linux +TK_CONFIG_PREFIX="/usr/lib" +TCL_CONFIG_PREFIX="/usr/lib" +#could not find dir so using: +INFO_DIR="unknown" +TK_INCLUDE="-I/usr/include" +TK_VERSION=4.1 +TCL_VERSION=7.5 +TK_LIB_SPEC=-L/usr/lib -ltk +TK_LIBRARY=/usr/lib/tk4.1 +TCL_LIBRARY=/usr/lib/tcl7.5 +TK_BUILD_LIB_SPEC=-L/usr/src/tk4.1/unix -ltk +TK_XLIBSW=-L/usr/X11R6/lib -lX11 +TK_XLIB_DIR=/usr/X11R6/lib +TK_XINCLUDES=# no special path needed +TCL_LIB_SPEC=-L/usr/lib -ltcl +TCL_DL_LIBS=-ldl +TCL_LIBS=-ldl -lieee -lm +HAVE_X11=-DHAVE_X11 + +# Machine dependent makefile definitions for intel 386,486 running linux + +LBINDIR=/usr/local/bin + +OFLAG = -O +LIBS = -lm + +ODIR_DEBUG= -O4 + +# This CC string will be used for compilation of the system, +# and also in the compiler::*cc* variable for later compilation of +# lisp files. +# (the -pipe is just since our file system is slow..) +CC = gcc -pipe -fwritable-strings -DVOL=volatile -I$(GCLDIR)/o -fsigned-char +LDCC=${CC} +# note for linuxaout on an elf machine add -b i486-linuxaout +# CC = gcc -pipe -fwritable-strings -DVOL=volatile -I$(GCLDIR)/o -fsigned-char -b i486-linuxaout + +# Enable the fastloading mechanism which does not use ld -A +# requires c/rel_.. machine dependent code. + +RSYM = rsym +SFASL = $(ODIR)/sfasl.o + + +MPFILES= $(MPDIR)/mpi-386d.o $(MPDIR)/libmport.a + + +# When using SFASL it is good to have (si::build-symbol-table) +INITFORM=(si::build-symbol-table) + +# Use symbolic links +SYMB=-s + +LIBFILES=bsearch.o + +# the make to use for saved_kcp the profiler. +KCP=kcp-bsd +# end makedefs + +CFLAGS1=$(CFLAGS) -I../o -I../h ${TK_INCLUDE} ${TK_XINCLUDES} + +all: gcltkaux tkl.o tinfo.o gcltksrv demos/gc-monitor.o + +.lisp.o: + echo "(compile-file \"$*.lisp\" :c-file nil :c-debug nil)" | ../unixport/saved_gcl + +.lsp.o: + echo "(compile-file \"$*.lsp\" :c-file t :c-debug t)" | ../unixport/saved_gcl + + + +GUIOS = guis.o tkAppInit.o tkMain.o + +clean:: + rm -f ${GUIOS} $(OFILES) gcltkaux gcltksrv *.o */*.o + +.c.o: + $(CC) -c $(CFLAGS1) ${ODIR_DEBUG} $*.c + + +gcltkaux: $(GUIOS) + $(LD_ORDINARY_CC) $(GUIOS) -o gcltkaux ${TK_LIB_SPEC} ${TK_BUILD_LIB_SPEC} ${TK_XLIBSW} ${TK_XINCLUDES} ${TCL_LIB_SPEC} ${TCL_DL_LIBS} ${TCL_LIBS} ${LIBS} ${GCLIB} + +gcltksrv: makefile + cat gcltksrv.in | sed -e "s:TK_LIBRARY=.*:TK_LIBRARY=${TK_LIBRARY}:g" \ + -e "s:TK_XLIB_DIR=.*:TK_XLIB_DIR=${TK_XLIB_DIR}:g" \ + -e "s:GCL_TK_DIR=.*:GCL_TK_DIR=${GCLDIR}/gcl-tk:g" > gcltksrv + chmod a+x gcltksrv + +INTERESTING=*.lsp *.lisp tk*.c guis.c sockets.c comm.c Makefile demos/*.lisp *.h + +tar: + tar cvf - ${INTERESTING} | gzip -c > /u/wfs/sock-`date +%y%m%d`.tgz +tags: + etags *.lsp *.lisp tk*.c guis.c sockets.c guis.h our_io.c + +tkAppInit.o : tkAppInit.c +tkMain.o : tkMain.c +tkXAppInit.o : tkXAppInit.c +tkXshell.o : tkXshell.c +guis.o : guis.c guis.h comm.c sheader.h +sockets.c: our_io.c sheader.h +socketsl.o: socketsl.lisp sockets.c + diff --git a/gcl-tk/ngcltksrv b/gcl-tk/ngcltksrv new file mode 100755 index 0000000..7c2438a --- /dev/null +++ b/gcl-tk/ngcltksrv @@ -0,0 +1,12 @@ +#!/bin/sh +#comment \ +export DISPLAY=$4 ; host=$1;port=$2 ;pid=$3 ; exec wish "$0" "$@" +set host [lindex $argv 0] +set port [lindex $argv 1] +set pid [lindex $argv 2] +source /home/wfs/gcl-2.3/gcl-tk/decode.tcl +GclAnswerSocket $host $port $pid + + + + diff --git a/gcl-tk/our_io.c b/gcl-tk/our_io.c new file mode 100755 index 0000000..8300f3a --- /dev/null +++ b/gcl-tk/our_io.c @@ -0,0 +1,109 @@ + +#include + + +#ifndef NO_DEFUN +#ifndef DEFUN +#define DEFUN(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,doc) ret fname +#endif +#endif + + +#ifndef HZ +#define HZ 60 +#endif + +#ifndef SET_TIMEVAL +#define SET_TIMEVAL(t,timeout) \ + t.tv_sec = timeout/HZ; t.tv_usec = (int) ((timeout%HZ)*(1000000.0)/HZ) +#endif + + +DEFUN("CHECK-FD-FOR-INPUT",int,fScheck_fd_for_input, + SI,0,0,NONE,II,IO,OO,OO, + +"Check FD a file descriptor for data to read, waiting TIMEOUT clicks \ +for data to become available. Here there are \ +INTERNAL-TIME-UNITS-PER-SECOND in one second. Return is 1 if data \ +available on FD, 0 if timeout reached and -1 if failed.") + + (fd,timeout) +int fd; +int timeout; +{ + fd_set inp; + int n; + struct timeval t; + + SET_TIMEVAL(t,timeout); + FD_ZERO(&inp); + FD_SET(fd, &inp); + n = select(fd + 1, &inp, NULL, NULL, &t); + if (n < 0) + return -1; + else if (FD_ISSET(fd, &inp)) + return 1; + else + return 0; +} + + +/* read from FD into BUF, M bytes allowing TIMEOUT if necessary. + return number of bytes read. + + */ +our_read(fd,buf,m,timeout) + int fd,m,timeout; + char *buf; +{ int r,tot=0; + char *p = buf; + while(tot < m && (fScheck_fd_for_input(fd,timeout)>0)) + { r = read(fd,p,m); + if (r == 0) return tot; + if (r == -1) + { if (errno != EAGAIN) + return -1;} + else { + tot += r; + p += r; + }} + return tot; +} + +/* write to FD file descriptor from BUF sending NBYTES. */ + +our_write(fd,buf,nbytes) + char *buf; + int fd,nbytes; + +{ int result = 0; + int m; + int n = nbytes; + char *p=buf; + while (n>0) + { m=write(fd,p,n); + if (m< 0) + { perror("write failed:"); + return -1;} + if (m==0) + { fprintf(stderr, + "write failed? 0 bytes written nbytes %d [%s] lost:", + n,p + ); + return result; + } + + p+= m; + n-= m; + result+= m; + } + if (n>0) + { perror("Could not write all data:"); + return result; + } + /* should not happen */ + if (result!= nbytes) abort(); + return result; +} + + diff --git a/gcl-tk/sheader.h b/gcl-tk/sheader.h new file mode 100755 index 0000000..7aaa15a --- /dev/null +++ b/gcl-tk/sheader.h @@ -0,0 +1,112 @@ + +#define MAGIC1 '' +#define MAGIC2 'A' + + +/* SIZE in BYTES 10+N + magic1 1 + magic2 1 + type (id) 1 the TYPE of message. callback, command, etc...[an enum!] + flag 1 things like, do acknowledge, etc. + size of actual_body 3 N Use PUSH_LONG to store, POP_LONG to read + msg_index 3 counter inc'd on each message sent, PUSH_SHORT to write.. + actual_body N data +*/ + +enum mtype { + m_not_used, + m_create_command, + m_reply, + m_call, + m_tcl_command, + m_tcl_command_wait_response, + m_tcl_clear_connection, /* clear tk connection and command buff */ + m_tcl_link_text_variable, + m_set_lisp_loc, + m_tcl_set_text_variable, + m_tcl_unlink_text_variable +}; + +struct message_header { + char magic1; + char magic2; + char type; + unsigned char flag; + unsigned char size[3]; + unsigned char msg_id[3]; + char body[1]; +}; + +#ifndef SIGNAL_PARENT_WAITING_RESPONSE +#define SIGNAL_PARENT_WAITING_RESPONSE 1 +#endif + + + + +#define BYTE_S 8 +#define BYTE_MASK (~(~0 << BYTE_S)) + +#define GET_3BYTES(p,ans) do{ unsigned char* __p = (unsigned char *) p; \ + ans = BYTE_MASK&(*__p++); \ + ans += (BYTE_MASK&((*__p++)))<<1*BYTE_S; \ + ans += (BYTE_MASK&((*__p++)))<<2*BYTE_S;} while(0) + +#define GET_2BYTES(p,ans) do{ unsigned char* __p = (unsigned char *) p; \ + ans = BYTE_MASK&(*__p++); \ + ans += (BYTE_MASK&((*__p++)))<<1*BYTE_S; \ + } while(0) + + +/* store an unsigned int n into the character pointer so that + low order byte occurs first */ + +#define STORE_2BYTES(p,n) do{ unsigned char* __p = (unsigned char *) p; \ + *__p++ = (n & BYTE_MASK);\ + *__p++ = ((n >> BYTE_S) & BYTE_MASK); \ + }\ + while (0) + +#define STORE_3BYTES(p,n) do{ unsigned char* __p = (unsigned char *) p; \ + *__p++ = (n & BYTE_MASK);\ + *__p++ = ((n >> BYTE_S) & BYTE_MASK); \ + *__p++ = ((n >> (2*BYTE_S)) & BYTE_MASK);}\ + while (0) +#define MESSAGE_HEADER_SIZE 10 + + +#define HDR_SIZE 5 +struct our_header +{ unsigned char magic; + unsigned char length[2]; /* length of packet including HDR_SIZE */ + unsigned char received[2]; /* tell other side about how many bytes received. + incrementally */ +}; + +struct connection_state +{ int fd; + int total_bytes_sent; + int total_bytes_received; + int bytes_sent_not_received; + int bytes_received_not_confirmed; + int next_packet_offset; /* offset from valid_data for start of next packet*/ + char *read_buffer; + int read_buffer_size; + char *valid_data; + int valid_data_size; + int max_allowed_in_pipe; + int write_timeout; +}; + +#define MAX_ALLOWED_IN_PIPE PAGESIZE +#define READ_BUFF_SIZE (PAGESIZE<<1) + +extern struct connection_state *dsfd; + +#define fScheck_dsfd_for_input(sf,timeout) \ + (sf->valid_data_size > 0 ? make_fixnum1(1) : fScheck_fd_for_input(sf->fd,timeout)) + +#define OBJ_TO_CONNECTION_STATE(x) \ + ((struct connection_state *)(void *)((x)->ust.ust_self)) + +struct connection_state * setup_connection_state(); diff --git a/gcl-tk/socketsl.lisp b/gcl-tk/socketsl.lisp new file mode 100755 index 0000000..1d6a66a --- /dev/null +++ b/gcl-tk/socketsl.lisp @@ -0,0 +1,31 @@ +(in-package "SI") + + + +; (clines "#define our_read_with_offset(fd,buffer,offset,nbytes,timeout) our_read(fd,&((buffer)->ust.ust_self[offset]),nbytes,timeout)") +;;(defun our-read-with-offset (fd buffer offset bytes-to-read timeout) +;; (return bytes read) +;(defentry our-read-with-offset (int object int int int) (int "our_read_with_offset")) +(clines "#define our_write_object(fd,buffer,nbytes) our_write(fd,buffer->ust.ust_self,nbytes)") +;; (defun our-write (fd buffer nbytes) (return bytes-written)) + +(defentry our-write (int object int ) (int "our_write_object")) +(defentry print-to-string1 (object object object) (object print_to_string1)) + +(clines "#define reset_string_input_stream1(strm,string,start,end) reset_string_input_stream(strm,string,fix(start),fix(end))") +(defentry reset-string-input-stream (object object object object) (object "reset_string_input_stream1")) + + +;(clines "#define symbol_value_any(x) ((x)->s.s_dbind)") +;(defentry symbol-value-any (object) (object symbol_value_any)) + +;(clines "#define get_signals_allowed() signals_allowed") +;(defentry signals-allowed () (int "get_signals_allowed")) +;(defentry install_default_signals ()(int "install_default_signals")) + +;(defentry unblock-signal (int) (int "unblock_signal")) + + +(defentry getpid () (int "getpid")) + + diff --git a/gcl-tk/socks.h b/gcl-tk/socks.h new file mode 100755 index 0000000..53a14e0 --- /dev/null +++ b/gcl-tk/socks.h @@ -0,0 +1,31 @@ +#ifndef _H_SOCKS +#define _H_SOCKS + +#include "obj.h" + +obj sock_open_named_socket( obj name, bool async ); +void sock_close_named_socket( obj named_socket ); + +obj sock_connect_to_name( obj host_id, obj name, bool async ); +obj sock_accept_connection( obj named_socket, bool async ); + +obj sock_hostname_to_hostid( obj hostname, obj *aliases ); +obj sock_hostid_to_hostname( obj hostid, obj *aliases ); +bool sock_hostid_eq( obj hostid1, obj hostid2 ); + +/* items is a list of objects returned from + sock_open_named_socket, sock_connect_to_name, + or sock_accept_connection with async = YES +*/ + +obj sock_collect_data( obj items ); + +void sock_write( obj connection, const char *text, UINT_32 length ); + +/* sock_read should return 0 on EOF */ + +UINT_32 sock_read( obj connection, char *buffer, UINT_32 max_len ); +void sock_close_connection( obj connection ); + +#endif /* _H_SOCKS */ + diff --git a/gcl-tk/sysdep-sunos.h b/gcl-tk/sysdep-sunos.h new file mode 100755 index 0000000..8174785 --- /dev/null +++ b/gcl-tk/sysdep-sunos.h @@ -0,0 +1,9 @@ +#ifndef _SYSDEP_SUNOS_H_ +#define _SYSDEP_SUNOS_H_ + +#include + +#define memmove(d,s,c) bcopy(s,d,c) +#define strerror(err) (perror(err),0) + +#endif diff --git a/gcl-tk/tinfo.lsp b/gcl-tk/tinfo.lsp new file mode 100755 index 0000000..41e205c --- /dev/null +++ b/gcl-tk/tinfo.lsp @@ -0,0 +1,588 @@ +;; Copyright (C) 1994 W. Schelter + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; + +(in-package "TK") + + + +(eval-when (compile eval) +(defmacro f (op x y) + `(the ,(if (get op 'compiler::predicate) 't 'fixnum) + (,op (the fixnum ,x) (the fixnum ,y)))) +(defmacro while (test &body body) + `(sloop while ,test do ,@ body)) + +(or (boundp '*info-window*) + (si::aload "info")) +) +(defun simple-listbox (w) + (let ((listbox (conc w '.frame.list)) + (scrollbar(conc w '.frame.scroll))) + (frame (conc w '.frame)) + (scrollbar scrollbar :relief "sunken" :command + (tk-conc w ".frame.list yview")) + (listbox listbox :yscroll (tk-conc w ".frame.scroll set") + :relief "sunken" + :setgrid 1) + (pack scrollbar :side "right" :fill "y") + (pack listbox :side "left" :expand "yes" :fill "both")) + (conc w '.frame)) + + +(defun insert-standard-listbox (w lis &aux print-entry) + (funcall w :delete 0 'end) + (setf (get w 'list) lis) + (setq print-entry (get w 'print-entry)) + (dolist (v lis) + (funcall w :insert 'end + (if print-entry (funcall print-entry v) v)))) + +(defun listbox-move (win key |%y|) + |%y| + (let ((amt (cdr (assoc key '(("Up" . -1) + ("Down" . 1) + ("Next" . 10) + ("Prior" . -10)) + :test 'equal)))) + (cond (amt + (funcall win :yview + (+ (funcall win :nearest 0 :return 'number) amt)))))) + +(defun new-window (name &aux tem) + (cond ((not (fboundp name)) name) + ((winfo :exists name :return 'boolean) + (let ((i 2)) + (while (winfo :exists (setq tem (conc name i )) :return 'boolean) + (setq i (+ i 1))) + tem)) + (t name))) + + +(defun insert-info-choices (listbox list &aux file position-pattern prev) + (funcall listbox :delete 0 'end) + (sloop for i from 0 for name in list + do (setq file nil position-pattern nil) + (progn ;decode name + (cond ((and (consp name) (consp (cdr name))) + (setq file (cadr name) + name (car name)))) + (cond ((consp name) + (setq position-pattern (car name) name (cdr name))))) + (funcall listbox :insert 'end + (format nil "~@[~a :~]~@[(~a)~]~a." + position-pattern + (if (eq file prev) nil (setq prev file)) name))) + (setf (get listbox 'list)list)) + +(defun offer-choices (list info-dirs &optional (w (new-window '.info)) + &aux listbox) + (toplevel w) + (simple-listbox w) + (setq listbox (conc w '.frame.list)) + (insert-info-choices listbox list) + (bind listbox "" + #'(lambda () + (show-info + (nth (atoi (funcall listbox :curselection :return 'string) + 0) + (get listbox 'list))))) + (button (conc w '.ok) :text "Quit " :command `(destroy ',w)) + (frame (conc w '.apro)) + (label(conc w '.apro.label) :text "Apropos: ") + (entry (conc w '.apro.entry) :relief "sunken") + (pack (conc w '.apro.label) (conc w '.apro.entry) :side "left" + :expand "yes") + (pack + (conc w '.frame) (conc w '.ok) + (conc w '.apro) :side "top" :fill "both") + (bind (conc w '.apro.entry) "" + #'(lambda() + (insert-info-choices + listbox + (info-aux (funcall (conc w '.apro.entry) + :get :return 'string) + info-dirs) + ))) + (bind w "" `(focus ',(conc w '.apro.entry))) + w +) + + +(defun get-info-apropos (win file type) + (cond ((and win + (winfo :exists win :return 'boolean)) + (let ((old (get win 'info-data))) + (unless (eq old *current-info-data*) + (setf (get win 'info-data) *current-info-data*) + (funcall (conc win '.frame.list) :delete 0 'end)) + (raise win) + (focus win) + win)) + (t (offer-choices file type nil)))) +(defun show-info-key (win key) + (let ((node (get win 'node)) name) + (or node (info-error "No Node?")) + (setq name (if + (f >= (string-match + (si::string-concatenate key + #u":[ \t]+([^\n\t,]+)[\n\t,]") + (node string node) + (node header node) + (node begin node)) + 0) + (get-match (node string node) 1))) + (if name (show-info name nil)))) +(defun mkinfo (&optional (w '.info_text) &aux textwin menu + ) + (if (winfo :exists w :return 'boolean) (destroy w)) + (toplevel w) + (wm :title w "Info Text Window") + (wm :iconname w "Info") + (frame (setq menu (conc w '.menu )):relief "raised" :borderwidth 1) + (setq textwin (conc w '.t)) + (pack menu :side "top" :fill "x") + (button (conc menu '.quit) :text "Quit" :command + `(destroy ',w)) + + (menubutton (conc menu '.file) :text "File" :relief 'raised + :menu (conc menu '.File '.m) :underline 0) + (menu (conc menu '.file '.m)) + (funcall (conc menu '.file '.m) + :add 'command + :label "Hotlist" + :command '(show-info (tk-conc "("(default-info-hotlist) + ")") + nil)) + (funcall (conc menu '.file '.m) + :add 'command + :label "Add to Hotlist" + :command `(add-to-hotlist ',textwin)) + (funcall (conc menu '.file '.m) + :add 'command + :label "Top Dir" + :command `(show-info "(dir)" nil)) + + (button (conc menu '.next) :text "Next" :relief 'raised + :command `(show-info-key ',textwin "Next")) + (button (conc menu '.prev) :text "Previous" :relief 'raised + :command `(show-info-key ',textwin "Prev")) + (button (conc menu '.up) :text "Up" :relief 'raised + :command `(show-info-key ',textwin "Up")) + (button (conc menu '.info) :text "Info" :relief 'raised + :command `(if (winfo :exists ".info") + (raise '.info) + (offer-choices nil si::*default-info-files*) + )) + (button (conc menu '.last) :text "Last" :relief 'raised + :command `(info-show-history ',textwin 'last)) + (button (conc menu '.history) :text "History" :relief 'raised + :command `(info-show-history ',textwin 'history)) + + (pack (conc menu '.file) + (conc menu '.quit) (conc menu '.next) (conc menu '.prev) + (conc menu '.up) (conc menu '.prev) + (conc menu '.last) (conc menu '.history) (conc menu '.info) + :side "left") +; (entry (conc menu '.entry) :relief "sunken") +; (pack (conc menu '.entry) :expand "yes" :fill "x") + +; (pack (conc menu '.next) +; :side "left") + + + (bind w "" `(focus ',menu)) + +; (tk-menu-bar menu (conc menu '.next) ) +; (bind menu "" "tk_traverseToMenu %W %A") + (scrollbar (conc w '.s) :relief "flat" :command (tk-conc w ".t yview")) + (text textwin :relief "raised" :bd 2 + :setgrid "true" + :state 'disabled) + (funcall textwin :configure + :yscrollcommand + (scroll-set-fix-xref-closure + textwin + (conc w '.s)) + ) + + (bind menu "" `(show-info-key ',textwin "Next")) + (bind menu "" `(show-info-key ',textwin "Up")) + (bind menu "" `(show-info-key ',textwin "Prev")) + (bind menu "" (nth 4(funcall (conc menu '.last) + :configure :command :return + 'list-strings))) + +;; SEARCHING: this needs to be speeded up and fixed. +; (bind (conc menu '.entry) "" +; `(info-text-search ',textwin ',menu %W %A %K)) +; (bind (conc menu '.entry) "" +; `(info-text-search ',textwin ',menu %W %A %K)) + +; (bind menu "" #'(lambda () (focus (menu '.entry)))) + + + + + (pack (conc w '.s) :side 'right :fill "y") + (pack textwin :expand 'yes :fill 'both) + (funcall textwin :mark 'set 'insert 0.0) + (funcall textwin :tag :configure 'bold + :font :Adobe-Courier-Bold-O-Normal-*-120-*) + (funcall textwin :tag :configure 'big :font + :Adobe-Courier-Bold-R-Normal-*-140-*) + (funcall textwin :tag :configure 'verybig :font + :Adobe-Helvetica-Bold-R-Normal-*-240-*) + (funcall textwin :tag :configure 'xref + :font :Adobe-Courier-Bold-O-Normal-*-120-* ) + (funcall textwin :tag :configure 'current_xref + :underline 1 ) + (funcall textwin :tag :bind 'xref "" + "eval [concat %W { tag add current_xref } [get_tag_range %W xref @%x,%y]]") + + (funcall textwin :tag :bind 'xref "" + "%W tag remove current_xref 0.0 end") + (funcall textwin :tag :bind 'xref "<3>" + `(show-this-node ',textwin |%x| |%y|)) + (focus menu) +;; (bind w "" (tk-conc "focus " w ".t")) + ) + + +(defun info-text-search (textwin menu entry a k &aux again + (node (get textwin 'node))) + (or node (tk-error "cant find node index")) +; (print (list entry a k )) + (cond ((equal k "Delete") + (let ((n (funcall entry :index 'insert :return 'number))) + (funcall entry :delete (- n 1)))) + ((>= (string-match "Control" k) 0)) + ((equal a "") (setq again 1)) + ((>= (string-match "[^-]" a) 0) + (funcall entry :insert 'insert a) (setq again 0)) + (t (focus menu) )) + (or again (return-from info-text-search nil)) + (print (list 'begin-search entry a k )) + + (let* ( + (ind (funcall textwin :index 'current :return 'string)) + (pos (index-to-position ind + (node string node) + (node begin node) + (node end node) + + )) + (where + (info-search (funcall entry :get :return 'string) + (+ again (node-offset node) pos)))) + ;; to do mark region in reverse video... + (cond ((>= where 0) + (let ((node (info-node-from-position where))) + (print-node node (- where (node-offset node))))) + (t (funcall entry :flash ))))) + +(defvar *last-history* nil) +(defun print-node (node initial-offset &aux last) +; "print text from node possibly positioning window at initial-offset +;from beginning of node" + + (setq last (list node initial-offset)) + (let ((text '.info_text) textwin tem) + (or (winfo :exists text :return 'boolean) + (mkinfo text)) + (setq + textwin (conc text '.t)) + (funcall textwin :configure :state 'normal) + (cond ((get textwin 'no-record-history) + (remprop textwin 'no-record-history)) + ((setq tem (get textwin 'node)) + (setq *last-history* nil) + (push + (format nil #u"* ~a:\t(~a)~a.\tat:~a" + (node name tem) + (node file tem) + (node name tem) + (funcall textwin :index "@0,0" :return 'string) + ) + (get textwin 'history)))) + (setf (get textwin 'node) node) + (funcall textwin :delete 0.0 'end) + (funcall textwin :mark :set 'insert "1.0") + (cond ((> initial-offset 0) + ;; insert something to separate the beginning of what + ;; we want to show and what goes before. + (funcall textwin :insert "0.0" #u"\n") + (funcall textwin :mark :set 'display_at 'end) + (funcall textwin :mark :set 'insert 'end) + (funcall textwin :yview 'display_at) + (insert-fontified textwin (node string node) + (+ (node begin node) initial-offset) + (node end node)) + (funcall textwin :mark :set 'insert "0.0") + (insert-fontified textwin (node string node) + (node begin node) + (+ (node begin node) initial-offset)) +) + (t + (insert-fontified textwin (node string node) + (node begin node) + (node end node)))) + (funcall textwin :configure :state 'disabled) + (raise text) + textwin + )) + + + +(defun info-show-history (win type) + (let ((his (get win 'history))) + (cond ((stringp type) + (if (f >= (string-match #u":\t([^\t]+)[.]\tat:([0-9.]+)" type) 0) + (let ((pos (get-match type 2)) + (w (show-info (get-match type 1) nil))) + (setf (get win 'no-record-history) t) + (or (equal "1.0" pos) + (funcall w :yview pos))))) + ((eq type 'last) + (info-show-history win (if *last-history* + (pop *last-history*) + (progn (setq *last-history* + (get win 'history)) + (pop *last-history*))))) + ((eq type 'history) + (let* ((w '.info_history) + (listbox (conc w '.frame.list))) + (cond ((winfo :exists w :return 'boolean)) + (t + (toplevel w) + (simple-listbox w) + (button (conc w '.quit) :text "Quit" :command + `(destroy ',w)) + (pack (conc w '.frame) (conc w '.quit) + :expand "yes" :fill 'both) + )) + (insert-standard-listbox listbox his) + (raise w) + (bind listbox "" `(info-show-history + ',listbox + (car (selection :get + :return + 'list-strings))))))))) + + + +(defun show-this-node (textwin x y) + (let ((inds (get_tag_range textwin 'xref "@": x :",": y :return + 'list-strings))) + (cond ((and inds (listp inds) (eql (length inds) 2)) + (show-info (nsubstitute #\space #\newline + (apply textwin :get :return 'string inds)) + nil)) + (t (print inds))))) + +(defun scroll-set-fix-xref-closure (wint wins &aux prev) + #'(lambda (&rest l) + (or (equal l prev) + (progn (setq prev l) + (fix-xref wint) + (apply wins :set l))))) + + +(defvar *recursive* nil) + +;(defun fix-xref-faster (win &aux (all'(" ")) tem) +; (unless +; *recursive* +; (let* ((*recursive* t) s +; (pat #u"\n\\* ([^:\n]+)::|\n\\* [^:\n]+:[ \t]*(\\([^,\n\t]+\\)[^,.\n\t]*)[^\n]?|\n\\* [^:\n]+:[ \t]*([^,(.\n\t]+)[^\n]?") +; (beg (funcall win :index "@0,0 linestart -1 char" :return 'string)) +; (end (funcall win :index "@0,1000 lineend" :return 'string))) +; (cond ((or (f >= (string-match "possible_xref" +; (funcall win :tag :names beg :return 'string)) 0) +; (not (equal "" +; (setq tem (funcall win :tag :nextrange "possible_xref" beg end +; :return 'string))))) +; (if tem (setq beg (car (list-string tem)))) +; (let ((s (funcall win :get beg end :return 'string)) +; (j 0) i) +; (with-tk-command +; (pp "MultipleTagAdd" no_quote) +; (pp win normal) +; (pp "xref" normal) +; (pp beg normal) +; (pp "{" no_quote) +; (while (f >= (string-match pat s j) 0) +; (setq i (if (f >= (match-beginning 1) 0) 1 2)) +; (pp (match-beginning i) no_quote) +; (pp (match-end i) no_quote) +; (setq j (match-end 0)) +; ) +; (pp "}" no_quote) +; (send-tcl-cmd *tk-connection* tk-command nil))) +; (funcall win :tag :remove "possible_xref" beg end) +; ))))) + +(defun fix-xref (win &aux tem) + (unless + *recursive* + (let* ((*recursive* t) + (pat #u"\n\\* ([^:\n]+)::|\n\\* [^:\n]+:[ \t]*(\\([^,\n\t]+\\)[^,.\n\t]*)[^\n]?|\n\\* [^:\n]+:[ \t]*([^,(.\n\t]+)[^\n]?") + (beg (funcall win :index "@0,0 linestart -1 char" :return 'string)) + (end (funcall win :index "@0,1000 lineend" :return 'string))) + (cond ((or (f >= (string-match "possible_xref" + (funcall win :tag :names beg :return 'string)) 0) + (not (equal "" + (setq tem (funcall win :tag :nextrange + "possible_xref" beg end + :return 'string))))) + (if tem (setq beg (car (list-string tem)))) + (let ((s (funcall win :get beg end :return 'string)) + (j 0) i) + (while (f >= (string-match pat s j) 0) + (setq i + (if (f >= (match-beginning 1) 0) 1 + (if (f >= (match-beginning 2) 0) 2 + 3))) + (funcall win :tag :add "xref" + beg : "+" : (match-beginning i) : " chars" + beg : "+" : (match-end i) : " chars") + (setq j (match-end 0)))) + (funcall win :tag :remove "possible_xref" beg end) + ))))) + +(defun insert-fontified (window string beg end) + "set fonts in WINDOW for string with " +; (waiting window) +; (print (list beg end)) + (insert-string-with-regexp + window string beg end + #u"\n([^\n]+)\n[.=_*-][.=*_-]+\n|\\*Note ([^:]+)::" + '((1 section-header) + (2 "xref") + )) + (funcall window :tag :add "possible_xref" "0.0" "end") + (fix-xref window) + (end-waiting window) + ) + +(defun section-header (win string lis &aux (i (car lis))) + (let ((mark 'insert)) + (insert-string win string (match-beginning 0) + (match-end i)) + (funcall win :insert mark #u"\n") + (funcall win :tag :add + (cdr (assoc (aref string (f + (match-end i) 2)) + '((#\= . "verybig") + (#\_ . "big") + (#\- . "big") + (#\. . "bold") + (#\* . "bold") + ))) + "insert - " : (f - (match-end i) (f + (match-beginning i ) -1 )) + : " chars" + "insert -1 chars") + ;;make index count be same.. + (let ((n (f - (f - (match-end 0) + (match-end i)) 1))) + (declare (fixnum n)) + (if (>= n 0) + (funcall win :insert mark (make-string n ))) + ))) + + +(defun insert-string (win string beg end) + (and (> end beg) + (let ((ar (make-array (- end beg) :element-type 'string-char + :displaced-to string :displaced-index-offset beg))) + (funcall win :insert 'insert ar)))) + +(defun insert-string-with-regexp (win string beg end regexp reg-actions + &aux (i 0) temi + (*window* win) *match-data*) + (declare (special *window* *match-data*)) + (declare (fixnum beg end i)) + (while (f >= (string-match regexp string beg end) 0) + (setq i 1) + (setq temi nil) + (loop (or (< i 10) (return nil)) + (cond ((f >= (match-beginning i) 0) + (setq temi (assoc i reg-actions)) + (return nil))) + (setq i (+ i 1))) + (cond ;(t nil) + ((functionp (second temi)) + (insert-string win string beg (match-beginning 0)) + (funcall (second temi) win string temi)) + ((stringp (second temi)) + (insert-string win string beg (match-end 0)) + (dolist + (v (cdr temi)) + (funcall win :tag :add v + "insert -" : (f - (match-end 0) (match-beginning i)) : " chars" + "insert -" :(f - (match-end 0) (match-end i)): " chars" + + ) + )) + (t (info-error "bad regexp prop"))) + (setq beg (match-end 0)) + (or (<= beg end) (error "hi")) + ) + (insert-string win string beg end)) + +(defun count-char (ch string beg end &aux (count 0)) +; "Count the occurrences of CH in STRING from BEG to END" + (declare (character ch)) + (declare (string string)) + (declare (fixnum beg end count)) + (while (< beg end) + (if (eql (aref string beg) ch) (incf count)) + (incf beg)) + count) + +(defun start-of-ith-line (count string beg &optional (end -1)) + (declare (string string)) + (declare (fixnum beg end count)) + (if (< end 0) (setq end (length string))) + (cond ((eql count 1) beg) + (t (decf count) + (while (< beg end) + (if (eql (aref string beg) #\newline) + (progn (decf count) + (incf beg) + (if (<= count 0) (return-from start-of-ith-line beg))) + (incf beg))) + beg))) + +(defun index-to-position (index string beg &optional (end -1) &aux (count 0)) +; "Find INDEX of form \"line.char\" in STRING with 0.0 at BEG and +; up to END. Result is a fixnum string index" + (declare (string string index)) + (declare (fixnum beg end count)) + (if (< end 0) (setq end (length string))) + (let* ((line (atoi index 0)) + (charpos (atoi index (+ 1 (position #\. index))))) + (declare (fixnum line charpos)) + (setq count (start-of-ith-line line string beg end)) + (print (list count charpos)) + (+ count charpos))) + + + +;;; Local Variables: *** +;;; mode:lisp *** +;;; version-control:t *** +;;; comment-column:0 *** +;;; comment-start: ";;; " *** +;;; End: *** + diff --git a/gcl-tk/tk-package.lsp b/gcl-tk/tk-package.lsp new file mode 100755 index 0000000..de8cff4 --- /dev/null +++ b/gcl-tk/tk-package.lsp @@ -0,0 +1,33 @@ +(in-package "TK" :use '("LISP" "SLOOP")) +(in-package "SI") +(import '( +string begin end header name + info-subfile + file tags +end-waiting +si::match-beginning si::idescribe + si::setup-info + si::autoload + si::idescribe + si::*default-info-files* + si::*info-paths* + si::*info-window* + si::info + si::get-match + si::print-node + si::offer-choices + si::match-end si::string-match + si::*case-fold-search* + si::*current-info-data* + si::info-data + si::node + si::info-aux + si::info-error + si::*tk-library* + si::*tk-connection* + si::show-info + si::tkconnect + si::*match-data*) + "TK") + + diff --git a/gcl-tk/tkAppInit.c b/gcl-tk/tkAppInit.c new file mode 100755 index 0000000..976a383 --- /dev/null +++ b/gcl-tk/tkAppInit.c @@ -0,0 +1,112 @@ +/* + * tkAppInit.c -- + * + * Provides a default version of the Tcl_AppInit procedure for + * use in wish and similar Tk-based applications. + * + * Copyright (c) 1993 The Regents of the University of California. + * All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR + * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT + * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF + * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO + * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + */ + +/* #ifndef lint */ +/* static char rcsid[] = "/usr/home/gah/repository/blt/tkAppInit.c,v 1.3 1994/04/02 04:37:26 gah Exp SPRITE (Berkeley) $Revision"; */ +/* #endif */ + +#include "tk.h" + +/* + * The following variable is a special hack that allows applications + * to be linked using the procedure "main" from the Tk library. The + * variable generates a reference to "main", which causes main to + * be brought in from the library (and all of Tk and Tcl with it). + */ + +extern int main(); +int *tclDummyMainPtr = (int *) main; + +/* + *---------------------------------------------------------------------- + * + * Tcl_AppInit -- + * + * This procedure performs application-specific initialization. + * Most applications, especially those that incorporate additional + * packages, will have their own version of this procedure. + * + * Results: + * Returns a standard Tcl completion code, and leaves an error + * message in interp->result if an error occurs. + * + * Side effects: + * Depends on the startup script. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_AppInit(interp) + Tcl_Interp *interp; /* Interpreter for application. */ +{ + Tk_Window mmain; +/* + extern int Blt_Init _ANSI_ARGS_((Tcl_Interp *interp)); +*/ + mmain = Tk_MainWindow(interp); + + /* + * Call the init procedures for included packages. Each call should + * look like this: + * + * if (Mod_Init(interp) == TCL_ERROR) { + * return TCL_ERROR; + * } + * + * where "Mod" is the name of the module. + */ +/* + if (Blt_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } +*/ + if (Tcl_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + if (Tk_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + + /* + * Call Tcl_CreateCommand for application-specific commands, if + * they weren't already created by the init procedures called above. + */ + + /* + * Specify a user-specific startup file to invoke if the application + * is run interactively. Typically the startup file is "~/.apprc" + * where "app" is the name of the application. If this line is deleted + * then no user-specific startup file will be run under any conditions. + */ + + /* for version tk 3.5: + tcl_RcFileName = "~/.wishrc"; + */ + Tcl_SetVar(interp, "tcl_rcFileName", "~/.wishrc", TCL_GLOBAL_ONLY); + return TCL_OK; +} diff --git a/gcl-tk/tkMain.c b/gcl-tk/tkMain.c new file mode 100755 index 0000000..4081161 --- /dev/null +++ b/gcl-tk/tkMain.c @@ -0,0 +1,712 @@ +/* + * main.c -- + * + * This file contains the main program for "wish", a windowing + * shell based on Tk and Tcl. It also provides a template that + * can be used as the basis for main programs for other Tk + * applications. + * + * Copyright (c) 1990-1993 The Regents of the University of California. + * All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR + * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT + * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF + * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO + * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + */ + +/* #ifndef lint */ +/* static char rcsid[] = "$Header$ SPRITE (Berkeley)"; */ +/* #endif */ + +#include +#include +#include +#include +#include + + + +#if (TK_MINOR_VERSION==0 && TK_MAJOR_VERSION==4) +#define TkCreateMainWindow Tk_CreateMainWindow +#endif +#if TCL_MAJOR_VERSION >= 8 +#define INTERP_RESULT(interp) Tcl_GetStringResult(interp) +#else +#define INTERP_RESULT(interp) (interp)->result +#endif + + +/*-------------------------------------------------------------------*/ +#include +#include +#include +#include + +int writable_malloc=0; /*FIXME, don't wrap fopen here, exclude notcomp.h or equivalent */ + +#include "guis.h" +struct connection_state *dsfd; +/*-------------------------------------------------------------------*/ + +/* + * Declarations for various library procedures and variables (don't want + * to include tkInt.h or tkConfig.h here, because people might copy this + * file out of the Tk source directory to make their own modified versions). + */ + +/* extern void exit _ANSI_ARGS_((int status)); */ +extern int isatty _ANSI_ARGS_((int fd)); +/* +extern int read _ANSI_ARGS_((int fd, char *buf, size_t size)); +*/ +extern char * strrchr _ANSI_ARGS_((CONST char *string, int c)); + +/* + * Global variables used by the main program: + */ + +/* static Tk_Window mainWindow; The main window for the application. If + * NULL then the application no longer + * exists. */ +static Tcl_Interp *interp; /* Interpreter for this application. */ +char *tcl_RcFileName; /* Name of a user-specific startup script + * to source if the application is being run + * interactively (e.g. "~/.wishrc"). Set + * by Tcl_AppInit. NULL means don't source + * anything ever. */ +static Tcl_DString command; /* Used to assemble lines of terminal input + * into Tcl commands. */ +static int tty; /* Non-zero means standard input is a + * terminal-like device. Zero means it's + * a file. */ +static char errorExitCmd[] = "exit 1"; + +/* + * Command-line options: + */ + +static int synchronize = 0; +static char *fileName = NULL; +static char *name = NULL; +static char *display = NULL; +static char *geometry = NULL; +int debug = 0; + +static void guiCreateCommand _ANSI_ARGS_((int idLispObject, int iSlot , char *arglist)); + +void +dfprintf(FILE *fp,char *s,...) { + + va_list args; + + if (debug) { + va_start(args,s); + fprintf(fp,"\nguis:"); + vfprintf(fp,s,args); + fflush(fp); + va_end(args); + } +} + +#define CMD_SIZE 4000 +#define SIGNAL_ERROR TCL_signal_error + +static void +TCL_signal_error(x) + char *x; +{char buf[300] ; + sprintf(buf,"error %s",x); + Tcl_Eval(interp,buf); + dfprintf(stderr,x); +} + + + +static Tk_ArgvInfo argTable[] = { + {"-file", TK_ARGV_STRING, (char *) NULL, (char *) &fileName, + "File from which to read commands"}, + {"-geometry", TK_ARGV_STRING, (char *) NULL, (char *) &geometry, + "Initial geometry for window"}, + {"-display", TK_ARGV_STRING, (char *) NULL, (char *) &display, + "Display to use"}, + {"-name", TK_ARGV_STRING, (char *) NULL, (char *) &name, + "Name to use for application"}, + {"-sync", TK_ARGV_CONSTANT, (char *) 1, (char *) &synchronize, + "Use synchronous mode for display server"}, + {(char *) NULL, TK_ARGV_END, (char *) NULL, (char *) NULL, + (char *) NULL} +}; + +/* + * Declaration for Tcl command procedure to create demo widget. This + * procedure is only invoked if SQUARE_DEMO is defined. + */ + +extern int SquareCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char *argv[])); + +/* + * Forward declarations for procedures defined later in this file: + */ + +static void StdinProc _ANSI_ARGS_((ClientData clientData, + int mask)); + +/* + *---------------------------------------------------------------------- + * + * main -- + * + * Main program for Wish. + * + * Results: + * None. This procedure never returns (it exits the process when + * it's done + * + * Side effects: + * This procedure initializes the wish world and then starts + * interpreting commands; almost anything could happen, depending + * on the script being interpreted. + * + *---------------------------------------------------------------------- + */ +/* +int +main(argc, argv) +*/ + +/* FIXME, should come in from tk header or not be called */ +EXTERN Tk_Window TkCreateMainWindow _ANSI_ARGS_((Tcl_Interp * interp, + char * screenName, char * baseName)); + +void +TkX_Wish (argc, argv) + int argc; /* Number of arguments. */ + char **argv; /* Array of argument strings. */ +{ + char *args, *p; + const char *msg; + char buf[20]; + int code; + + interp = Tcl_CreateInterp(); +#ifdef TCL_MEM_DEBUG + Tcl_InitMemory(interp); +#endif + + /* + * Parse command-line arguments. + */ + + if (Tk_ParseArgv(interp, (Tk_Window) NULL, &argc, (const char **)argv, argTable, 0) + != TCL_OK) { + fprintf(stderr, "%s\n", INTERP_RESULT(interp)); + exit(1); + } + if (name == NULL) { + if (fileName != NULL) { + p = fileName; + } else { + p = argv[0]; + } + name = strrchr(p, '/'); + if (name != NULL) { + name++; + } else { + name = p; + } + } + + /* + * If a display was specified, put it into the DISPLAY + * environment variable so that it will be available for + * any sub-processes created by us. + */ + + if (display != NULL) { + Tcl_SetVar2(interp, "env", "DISPLAY", display, TCL_GLOBAL_ONLY); + } + + /* + * Initialize the Tk application. + */ + +/* mainWindow = TkCreateMainWindow(interp, display, name/\* , "Tk" *\/); */ +/* if (mainWindow == NULL) { */ +/* fprintf(stderr, "%s\n", INTERP_RESULT(interp)); */ +/* exit(1); */ +/* } */ +/* #ifndef __MINGW32__ */ +/* if (synchronize) { */ +/* XSynchronize(Tk_Display(mainWindow), True); */ +/* } */ +/* #endif */ +/* Tk_GeometryRequest(mainWindow, 200, 200); */ +/* Tk_UnmapWindow(mainWindow); */ + + /* + * Make command-line arguments available in the Tcl variables "argc" + * and "argv". Also set the "geometry" variable from the geometry + * specified on the command line. + */ + + args = Tcl_Merge(argc-1, (const char **)argv+1); + Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY); + ckfree(args); + sprintf(buf, "%d", argc-1); + Tcl_SetVar(interp, "argc", buf, TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "argv0", (fileName != NULL) ? fileName : argv[0], + TCL_GLOBAL_ONLY); + if (geometry != NULL) { + Tcl_SetVar(interp, "geometry", geometry, TCL_GLOBAL_ONLY); + } + + /* + * Set the "tcl_interactive" variable. + */ + + tty = isatty(dsfd->fd); + Tcl_SetVar(interp, "tcl_interactive", + ((fileName == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY); + + /* + * Add a few application-specific commands to the application's + * interpreter. + */ + +/* #ifdef SQUARE_DEMO */ +/* Tcl_CreateCommand(interp, "square", SquareCmd, (ClientData) mainWindow, */ +/* (void (*)()) NULL); */ +/* #endif */ + + /* + * Invoke application-specific initialization. + */ + + if (Tcl_AppInit(interp) != TCL_OK) { + fprintf(stderr, "Tcl_AppInit failed: %s\n", INTERP_RESULT(interp)); + } + + /* + * Set the geometry of the main window, if requested. + */ + + if (geometry != NULL) { + code = Tcl_VarEval(interp, "wm geometry . ", geometry, (char *) NULL); + if (code != TCL_OK) { + fprintf(stderr, "%s\n", INTERP_RESULT(interp)); + } + } + + /* + * Invoke the script specified on the command line, if any. + */ + + if (fileName != NULL) { + code = Tcl_VarEval(interp, "source ", fileName, (char *) NULL); + if (code != TCL_OK) { + goto error; + } + tty = 0; + } else { + /* + * Commands will come from standard input, so set up an event + * handler for standard input. If the input device is aEvaluate the + * .rc file, if one has been specified, set up an event handler + * for standard input, and print a prompt if the input + * device is a terminal. + */ + + if (tcl_RcFileName != NULL) { + Tcl_DString buffer; + char *fullName; + FILE *f; + + fullName = Tcl_TildeSubst(interp, tcl_RcFileName, &buffer); + if (fullName == NULL) { + fprintf(stderr, "%s\n", INTERP_RESULT(interp)); + } else { + f = fopen(fullName, "r"); + if (f != NULL) { + code = Tcl_EvalFile(interp, fullName); + if (code != TCL_OK) { + fprintf(stderr, "%s\n", INTERP_RESULT(interp)); + } + fclose(f); + } + } + Tcl_DStringFree(&buffer); + } + + dfprintf(stderr, "guis : Creating file handler for %d\n", dsfd->fd); +#ifndef __MINGW32__ + Tk_CreateFileHandler(dsfd->fd, TK_READABLE, StdinProc, (ClientData) 0); +#endif + } + fflush(stdout); + Tcl_DStringInit(&command); + + /* + * Loop infinitely, waiting for commands to execute. When there + * are no windows left, Tk_MainLoop returns and we exit. + */ + + Tk_MainLoop(); + + /* + * Don't exit directly, but rather invoke the Tcl "exit" command. + * This gives the application the opportunity to redefine "exit" + * to do additional cleanup. + */ + + Tcl_Eval(interp, "exit"); + exit(1); + +error: + msg = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); + if (msg == NULL) { + msg = INTERP_RESULT(interp); + } + dfprintf(stderr, "%s\n", msg); + Tcl_Eval(interp, errorExitCmd); + return; /* Needed only to prevent compiler warnings. */ +} + +static char *being_set_by_lisp; + +static char * +tell_lisp_var_changed( + clientData, + interp, + name1, + name2, + flags) + + ClientData clientData; + Tcl_Interp *interp; + char *name1; + char *name2; + int flags; + +{ + + if (being_set_by_lisp == 0) + { const char *val = Tcl_GetVar2(interp,name1,name2, TCL_GLOBAL_ONLY); + char buf[3]; + STORE_3BYTES(buf,(long) clientData); + if(sock_write_str2(dsfd, m_set_lisp_loc, buf, 3 , + val, strlen(val)) + < 0) + { /* what do we want to do if the write failed */} +#ifndef __MINGW32__ + if (parent > 0) kill(parent, SIGUSR1); +#endif + } + else + /* avoid going back to lisp if it is lisp that is doing the setting! */ + if (strcmp(being_set_by_lisp,name1)) + { fprintf(stderr,"recursive setting of vars %s??",name1);} + /* normal */ + return 0; +} + + +/* + *---------------------------------------------------------------------- + * + * StdinProc -- + * + * This procedure is invoked by the event dispatcher whenever + * standard input becomes readable. It grabs the next line of + * input characters, adds them to a command being assembled, and + * executes the command if it's complete. + * + * Results: + * None. + * + * Side effects: + * Could be almost arbitrary, depending on the command that's + * typed. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +StdinProc(clientData, mask) + ClientData clientData; /* Not used. */ + int mask; /* Not used. */ +{ + int fNotDone; + char *cmd; + int code, count; + struct message_header *msg; + char buf[0x4000]; + msg = (struct message_header *) buf; + + /* + * Disable the stdin file handler while evaluating the command; + * otherwise if the command re-enters the event loop we might + * process commands from stdin before the current command is + * finished. Among other things, this will trash the text of the + * command being evaluated. + */ + dfprintf(stderr, "\nguis : Disabling file handler for %d\n", dsfd->fd); + +/* Tk_CreateFileHandler(dsfd->fd, 0, StdinProc, (ClientData) 0); */ + + do + { + + msg = guiParseMsg1(dsfd,buf,sizeof(buf)); + + if (msg == NULL) + { + /*dfprintf(stderr, "Yoo !!! Empty command\n"); */ + if (debug)perror("zero message"); +#ifndef __MINGW32__ + Tk_CreateFileHandler(dsfd->fd, TK_READABLE, StdinProc, (ClientData) 0); +#endif + return; + } + + /* Need to switch to table lookup */ + switch (msg->type){ + case m_create_command: + { + int iSlot; + GET_3BYTES(msg->body,iSlot); + guiCreateCommand(0, iSlot, &(msg->body[3])); + } + break; + case m_tcl_command : + case m_tcl_command_wait_response: + count = strlen(msg->body); + cmd = Tcl_DStringAppend(&command, msg->body, count); + + code = Tcl_RecordAndEval(interp, cmd, 0); + + if (msg->type == m_tcl_command_wait_response + || code) + { + char buf[4]; + char *p = buf, *string; + /*header */ + *p++ = (code ? '1' : '0'); + bcopy(msg->msg_id,p,3); + /* end header */ + string = (char *)INTERP_RESULT(interp); + if(sock_write_str2(dsfd, m_reply, buf, 4, string, strlen(string)) + < 0) + { /* what do we want to do if the write failed */} + + if (msg->type == m_tcl_command_wait_response) + { /* parent is waiting so dong signal */ ;} +#ifndef __MINGW32__ + else + if (parent> 0)kill(parent, SIGUSR1); +#endif + } + + Tcl_DStringFree(&command); + break; + case m_tcl_clear_connection: + /* we are stuck... */ + { + Tcl_DStringInit(&command); + Tcl_DStringFree(&command); + fSclear_connection(dsfd->fd); + } + break; + case m_tcl_set_text_variable: + { int n = strlen(msg->body); + if(being_set_by_lisp) fprintf(stderr,"recursive set?"); + /* avoid a trace on this set!! */ + + being_set_by_lisp = msg->body; + Tcl_SetVar2(interp,msg->body,0,msg->body+n+1, + TCL_GLOBAL_ONLY); + being_set_by_lisp = 0; + } + break; + + case m_tcl_link_text_variable: + {long i; + GET_3BYTES(msg->body,i); + Tcl_TraceVar2(interp,msg->body+3 ,0, + TCL_TRACE_WRITES + | TCL_TRACE_UNSETS + | TCL_GLOBAL_ONLY + , tell_lisp_var_changed, (ClientData) i); + } + break; + + case m_tcl_unlink_text_variable: + {long i; + GET_3BYTES(msg->body,i); + Tcl_UntraceVar2(interp,msg->body+3 ,0, + TCL_TRACE_WRITES + | TCL_TRACE_UNSETS + | TCL_GLOBAL_ONLY + , tell_lisp_var_changed, (ClientData) i); + } + break; + + default : + dfprintf(stderr, "Error !!! Unknown command %d\n" + , msg->type); + } + fNotDone = fix(fScheck_dsfd_for_input(dsfd,0)); + + if (fNotDone > 0) + { + dfprintf(stderr, "\nguis : in StdinProc, not done, executed %s" + , msg->body); + + } + } while (fNotDone > 0); + + + /* Tk_CreateFileHandler(dsfd->fd, TK_READABLE, StdinProc, (ClientData) 0); */ + if ((void *)msg != (void *) buf) + free ((void *) msg); +} + +/* ----------------------------------------------------------------- */ +typedef struct _ClientDataLispObject { + int id; + int iSlot; + char *arglist; +} ClientDataLispObject; + +static int +TclGenericCommandProcedure( clientData, + pinterp, + argc, argv) + ClientData clientData; + Tcl_Interp *pinterp; + int argc; + char *argv[]; +{ + char szCmd[CMD_SIZE]; + ClientDataLispObject *pcdlo = (ClientDataLispObject *)clientData; + int cb=0; + char *q = szCmd; + char *p = pcdlo->arglist; + + STORE_3BYTES(q,(pcdlo->iSlot)); + q += 3; + if (p == 0) + { char *arg = (argc > 1 ? argv[1] : ""); + int m = strlen(arg); + if (m > CMD_SIZE -50) + SIGNAL_ERROR("too big command"); + bcopy(arg,q,m); + q += m ;} + else + { int i,n; + *q++ = '('; + n = strlen(p); + for (i=1; i< argc; i++) + { if (i < n && p[i]=='s') { *q++ = '"';} + strcpy(q,argv[i]); + q+= strlen(argv[i]); + if (i < n && p[i]=='s') { *q++ = '"';} + } + *q++ = ')'; + } + *q = 0; + + dfprintf(stderr, "TclGenericCommandProcedure : %s\n" + , szCmd + ); + + if (sock_write_str2(dsfd,m_call, "",0, szCmd, q-szCmd) == -1) + { + dfprintf(stderr, + "Error\t(TclGenericCommandProcedure) !!!\n\tFailed to write [%s] to socket %d (%d) cb=%d\n" + , szCmd, dsfd->fd, errno, cb); + + } +#ifndef __MINGW32__ + if (parent > 0)kill(parent, SIGUSR1); +#endif + return TCL_OK; +} + + + +static void +guiCreateCommand( idLispObject, iSlot , arglist) + int idLispObject; int iSlot ; char *arglist; +{ + char szNameCmdProc[2000],*c; + ClientDataLispObject *pcdlo; + + sprintf(szNameCmdProc, "callback_%d",iSlot); + + pcdlo = (ClientDataLispObject *)malloc(sizeof(ClientDataLispObject)); + pcdlo->id = idLispObject; + pcdlo->iSlot = iSlot; + if (arglist[0] == 0) + { pcdlo->arglist = 0;} + else + {c= malloc(strlen(arglist)+1); + strcpy(c,arglist); + pcdlo->arglist = c;} + Tcl_CreateCommand(interp + , szNameCmdProc, TclGenericCommandProcedure + , (ClientData *)pcdlo, free); + dfprintf(stderr, "TCL creating callback : %s\n", szNameCmdProc); + +/* guiBindCallback(szNameCmdProc, szTclObject, szModifier,arglist); */ +} + +/* +int +guiBindCallback(char *szNameCmdProc, char *szTclObject, char *szModifier,char* arglist) +{ + int code; + char szCmd[2000]; + + sprintf(szCmd, "bind %s %s {%s %s}" + , szTclObject + , szModifier + , szNameCmdProc + , (arglist ? arglist : "") + ); + dfprintf(stderr, "TCL BIND : %s\n", szCmd); + + code = Tcl_Eval(interp, szCmd); + if (code != TCL_OK) + { + dfprintf(stderr, "TCL Error int bind : %s\n", INTERP_RESULT(interp)); + + } + return code; +} +*/ +/* static void */ +/* guiDeleteCallback(szCallback) */ +/* char *szCallback; */ +/* { */ +/* dfprintf(stderr, "Tcl Deleting command : %s\n", szCallback); */ + +/* Tcl_DeleteCommand(interp, szCallback); */ +/* } */ + +/* */ + diff --git a/gcl-tk/tkXAppInit.c b/gcl-tk/tkXAppInit.c new file mode 100755 index 0000000..cc4743a --- /dev/null +++ b/gcl-tk/tkXAppInit.c @@ -0,0 +1,131 @@ +/* + * tkXAppInit.c -- + * + * Provides a default version of the Tcl_AppInit procedure for use with + * applications built with Extended Tcl and Tk. This is based on the + * the UCB Tk file tkAppInit.c + * + *----------------------------------------------------------------------------- + * Copyright 1991-1993 Karl Lehenbauer and Mark Diekhans. + * + * Permission to use, copy, modify, and distribute this software and its + * documentation for any purpose and without fee is hereby granted, provided + * that the above copyright notice appear in all copies. Karl Lehenbauer and + * Mark Diekhans make no representations about the suitability of this + * software for any purpose. It is provided "as is" without express or + * implied warranty. + *----------------------------------------------------------------------------- + * $Id$ + *----------------------------------------------------------------------------- + * Copyright (c) 1993 The Regents of the University of California. + * All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR + * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT + * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF + * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO + * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + */ + +#ifndef lint +static char rcsid[] = "$Header$ SPRITE (Berkeley)"; +#endif /* not lint */ + +#include "tclExtend.h" +#include "tk.h" +#include + +/* + * The following variable is a special hack that allows applications + * to be linked using the procedure "main" from the Tk library. The + * variable generates a reference to "main", which causes main to + * be brought in from the library (and all of Tk and Tcl with it). + */ + +EXTERN int main _ANSI_ARGS_((int argc, + char **argv)); +int *tclDummyMainPtr = (int *) main; + +/* + * The following variable is a special hack that insures the tcl + * version of matherr() is used when linking against shared libraries + * Only define if matherr is used on this system. + */ + +#if defined(DOMAIN) && defined(SING) +EXTERN int matherr _ANSI_ARGS_((struct exception *)); +int *tclDummyMathPtr = (int *) matherr; +#endif + + +/* + *---------------------------------------------------------------------- + * + * Tcl_AppInit -- + * + * This procedure performs application-specific initialization. + * Most applications, especially those that incorporate additional + * packages, will have their own version of this procedure. + * + * Results: + * Returns a standard Tcl completion code, and leaves an error + * message in interp->result if an error occurs. + * + * Side effects: + * Depends on the startup script. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_AppInit(interp) + Tcl_Interp *interp; /* Interpreter for application. */ +{ + Tk_Window main; + + main = Tk_MainWindow(interp); + + /* + * Call the init procedures for included packages. Each call should + * look like this: + * + * if (Mod_Init(interp) == TCL_ERROR) { + * return TCL_ERROR; + * } + * + * where "Mod" is the name of the module. + */ + + if (TclX_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + if (TkX_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + + /* + * Call Tcl_CreateCommand for application-specific commands, if + * they weren't already created by the init procedures called above. + */ + + /* + * Specify a user-specific startup file to invoke if the application + * is run interactively. Typically the startup file is "~/.apprc" + * where "app" is the name of the application. If this line is deleted + * then no user-specific startup file will be run under any conditions. + */ + + tcl_RcFileName = "~/.tclrc"; + return TCL_OK; +} diff --git a/gcl-tk/tkXshell.c b/gcl-tk/tkXshell.c new file mode 100755 index 0000000..4ba1202 --- /dev/null +++ b/gcl-tk/tkXshell.c @@ -0,0 +1,445 @@ +/* + * tkXshell.c + * + * Version of Tk main that is modified to build a wish shell with the Extended + * Tcl command set and libraries. This makes it easier to use a different + * main. + *----------------------------------------------------------------------------- + * Copyright 1991-1993 Karl Lehenbauer and Mark Diekhans. + * + * Permission to use, copy, modify, and distribute this software and its + * documentation for any purpose and without fee is hereby granted, provided + * that the above copyright notice appear in all copies. Karl Lehenbauer and + * Mark Diekhans make no representations about the suitability of this + * software for any purpose. It is provided "as is" without express or + * implied warranty. + *----------------------------------------------------------------------------- + * $Id$ + *----------------------------------------------------------------------------- + */ + +/* + * main.c -- + * + * This file contains the main program for "wish", a windowing + * shell based on Tk and Tcl. It also provides a template that + * can be used as the basis for main programs for other Tk + * applications. + * + * Copyright (c) 1990-1993 The Regents of the University of California. + * All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR + * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT + * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF + * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO + * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + */ + +#ifdef __cplusplus +# include "tcl++.h" +# include +#else +# include "tclExtend.h" +#endif + +#include "tk.h" + +/*-------------------------------------------------------------------*/ +#include +#include +#include + +int sock_write( int connection, const char *text, int length ); +int sock_read( int connection, char *buffer, int max_len ); + +extern int hdl; +extern pid_t parent; +/*-------------------------------------------------------------------*/ + +/* + * Declarations for various library procedures and variables (don't want + * to include tkInt.h or tkConfig.h here, because people might copy this + * file out of the Tk source directory to make their own modified versions). + */ + +extern void exit _ANSI_ARGS_((int status)); +extern int isatty _ANSI_ARGS_((int fd)); +/* +extern int read _ANSI_ARGS_((int fd, char *buf, size_t size)); +*/ +extern char * strrchr _ANSI_ARGS_((CONST char *string, int c)); + +/* + * Global variables used by the main program: + */ + +static Tk_Window mainWindow; /* The main window for the application. If + * NULL then the application no longer + * exists. */ +static Tcl_Interp *interp; /* Interpreter for this application. */ +char *tcl_RcFileName ; /* Name of a user-specific startup script + * to source if the application is being run + * interactively (e.g. "~/.wishrc"). Set + * by Tcl_AppInit. NULL means don't source + * anything ever. */ +static Tcl_DString command; /* Used to assemble lines of terminal input + * into Tcl commands. */ +static int gotPartial = 0; /* Partial command in buffer. */ +static int tty; /* Non-zero means standard input is a + * terminal-like device. Zero means it's + * a file. */ +static char exitCmd[] = "exit"; +static char errorExitCmd[] = "exit 1"; + +/* + * Command-line options: + */ + +static int synchronize = 0; +static char *fileName = NULL; +static char *name = NULL; +static char *display = NULL; +static char *geometry = NULL; + +static Tk_ArgvInfo argTable[] = { + {"-file", TK_ARGV_STRING, (char *) NULL, (char *) &fileName, + "File from which to read commands"}, + {"-geometry", TK_ARGV_STRING, (char *) NULL, (char *) &geometry, + "Initial geometry for window"}, + {"-display", TK_ARGV_STRING, (char *) NULL, (char *) &display, + "Display to use"}, + {"-name", TK_ARGV_STRING, (char *) NULL, (char *) &name, + "Name to use for application"}, + {"-sync", TK_ARGV_CONSTANT, (char *) 1, (char *) &synchronize, + "Use synchronous mode for display server"}, + {(char *) NULL, TK_ARGV_END, (char *) NULL, (char *) NULL, + (char *) NULL} +}; + +/* + * Forward declarations for procedures defined later in this file: + */ + +static void StdinProc _ANSI_ARGS_((ClientData clientData, + int mask)); +static void SignalProc _ANSI_ARGS_((int signalNum)); + +/* + *---------------------------------------------------------------------- + * + * TkX_Wish -- + * + * Main program for Wish. + * + * Results: + * None. This procedure never returns (it exits the process when + * it's done + * + * Side effects: + * This procedure initializes the wish world and then starts + * interpreting commands; almost anything could happen, depending + * on the script being interpreted. + * + *---------------------------------------------------------------------- + */ + +void +TkX_Wish (argc, argv) + int argc; /* Number of arguments. */ + char **argv; /* Array of argument strings. */ +{ + char *args, *p, *msg; + char buf[20]; + int code; + + interp = Tcl_CreateInterp(); +#ifdef TCL_MEM_DEBUG + Tcl_InitMemory(interp); +#endif + + /* + * Parse command-line arguments. + */ + + if (Tk_ParseArgv(interp, (Tk_Window) NULL, &argc, argv, argTable, 0) + != TCL_OK) { + fprintf(stderr, "%s\n", interp->result); + exit(1); + } + if (name == NULL) { + if (fileName != NULL) { + p = fileName; + } else { + p = argv[0]; + } + name = strrchr(p, '/'); + if (name != NULL) { + name++; + } else { + name = p; + } + } + + /* + * If a display was specified, put it into the DISPLAY + * environment variable so that it will be available for + * any sub-processes created by us. + */ + + if (display != NULL) { + Tcl_SetVar2(interp, "env", "DISPLAY", display, TCL_GLOBAL_ONLY); + } + + /* + * Set the "tcl_interactive" variable. + */ + tty = isatty(hdl); + Tcl_SetVar(interp, "tcl_interactive", + ((fileName == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY); + + tty = isatty(hdl); + + /* + * Initialize the Tk application. + */ + + mainWindow = Tk_CreateMainWindow(interp, display, name, "Tk"); + if (mainWindow == NULL) { + fprintf(stderr, "%s\n", interp->result); + exit(1); + } + Tk_SetClass(mainWindow, "Tk"); + if (synchronize) { + XSynchronize(Tk_Display(mainWindow), True); + } + Tk_GeometryRequest(mainWindow, 200, 200); + + /* + * Make command-line arguments available in the Tcl variables "argc" + * and "argv". Also set the "geometry" variable from the geometry + * specified on the command line. + */ + + args = Tcl_Merge(argc-1, argv+1); + Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY); + ckfree(args); + sprintf(buf, "%d", argc-1); + Tcl_SetVar(interp, "argc", buf, TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "argv0", (fileName != NULL) ? fileName : argv[0], + TCL_GLOBAL_ONLY); + if (geometry != NULL) { + Tcl_SetVar(interp, "geometry", geometry, TCL_GLOBAL_ONLY); + } + + /* + * Invoke application-specific initialization. + */ + + if (Tcl_AppInit(interp) != TCL_OK) { + TclX_ErrorExit (interp, 255); + } + + /* + * Set the geometry of the main window, if requested. + */ + + if (geometry != NULL) { + code = Tcl_VarEval(interp, "wm geometry . ", geometry, (char *) NULL); + if (code != TCL_OK) { + fprintf(stderr, "%s\n", interp->result); + } + } + + /* + * Invoke the script specified on the command line, if any. + */ + + if (fileName != NULL) { + code = Tcl_VarEval(interp, "source ", fileName, (char *) NULL); + if (code != TCL_OK) { + goto error; + } + tty = 0; + } else { + TclX_EvalRCFile (interp); + + /* + * Commands will come from standard input. Set up a handler + * to receive those characters and print a prompt if the input + * device is a terminal. + */ + tclErrorSignalProc = SignalProc; + Tk_CreateFileHandler(hdl, TK_READABLE, StdinProc, (ClientData) 0); + if (tty) { + TclX_OutputPrompt (interp, 1); + } + } + tclSignalBackgroundError = Tk_BackgroundError; + + fflush(stdout); + Tcl_DStringInit(&command); + + /* + * Loop infinitely, waiting for commands to execute. When there + * are no windows left, Tk_MainLoop returns and we exit. + */ + + Tk_MainLoop(); + + /* + * Don't exit directly, but rather invoke the Tcl "exit" command. + * This gives the application the opportunity to redefine "exit" + * to do additional cleanup. + */ + + Tcl_GlobalEval(interp, exitCmd); + exit(1); + +error: + msg = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); + if (msg == NULL) { + msg = interp->result; + } + fprintf(stderr, "%s\n", msg); + Tcl_GlobalEval(interp, errorExitCmd); + exit (1); +} + +/* + *---------------------------------------------------------------------- + * + * SignalProc -- + * + * Function called on a signal generating an error to clear the stdin + * buffer. + *---------------------------------------------------------------------- + */ + +static void +SignalProc (signalNum) + int signalNum; +{ + tclGotErrorSignal = 0; + Tcl_DStringFree (&command); + gotPartial = 0; + if (tty) { + fputc ('\n', stdout); + TclX_OutputPrompt (interp, !gotPartial); + } +} + +/* + *---------------------------------------------------------------------- + * + * StdinProc -- + * + * This procedure is invoked by the event dispatcher whenever + * standard input becomes readable. It grabs the next line of + * input characters, adds them to a command being assembled, and + * executes the command if it's complete. + * + * Results: + * None. + * + * Side effects: + * Could be almost arbitrary, depending on the command that's + * typed. + * + *---------------------------------------------------------------------- + */ + +#define BUFFER_SIZE 4000 + +static void +StdinProc(clientData, mask) + ClientData clientData; /* Not used. */ + int mask; /* Not used. */ +{ + char input[BUFFER_SIZE+1]; + char *cmd; + int code, count; + + count = read(hdl, input, BUFFER_SIZE); + if (count <= 0) + { + if (!gotPartial) + { + if (tty) + { + Tcl_VarEval(interp, "exit", (char *) NULL); + exit(1); + } + else + { + Tk_DeleteFileHandler(hdl); + } + return; + } + else + { + count = 0; + } + } + cmd = Tcl_DStringAppend(&command, input, count); + + fprintf(stderr, "TK command : %s\n", cmd); + fflush(stderr); + + if (count != 0) + { + if ((input[count-1] != '\n') && (input[count-1] != ';')) + { + gotPartial = 1; + goto exitPoint; + } + if (!Tcl_CommandComplete(cmd)) + { + fprintf(stderr, "Partial command\n", cmd); + fflush(stderr); + + gotPartial = 1; + goto exitPoint; + } + } + gotPartial = 0; + +/* +* Disable the stdin file handler; otherwise if the command +* re-enters the event loop we might process commands from +* stdin before the current command is finished. Among other +* things, this will trash the text of the command being evaluated. +*/ + + Tk_CreateFileHandler(hdl, 0, StdinProc, (ClientData) 0); + code = Tcl_RecordAndEval(interp, cmd, 0); + Tk_CreateFileHandler(hdl, TK_READABLE, StdinProc, (ClientData) 0); + if (tty) + TclX_PrintResult (interp, code, cmd); + else + { + char buf[1024]; + sprintf(buf, "%d %s", code, interp->result); + sock_write(hdl, buf, strlen(buf)); + kill(parent, SIGUSR1); + } + Tcl_DStringFree(&command); + + exitPoint: + if (tty) + { + TclX_OutputPrompt (interp, !gotPartial); + } +} + diff --git a/gcl-tk/tkl.lisp b/gcl-tk/tkl.lisp new file mode 100755 index 0000000..3d4e78e --- /dev/null +++ b/gcl-tk/tkl.lisp @@ -0,0 +1,1555 @@ +;; Copyright (C) 1994 W. Schelter + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; + + + +(eval-when (load eval compile) +(in-package "TK") +) + +(eval-when (compile) +(proclaim '(ftype (function (t fixnum fixnum) fixnum) set-message-header + get-number-string)) +(proclaim '(ftype (function (t t fixnum) t) store-circle)) +(proclaim '(ftype (function (t fixnum) t) get-circle)) +(proclaim '(ftype (function (t fixnum fixnum fixnum) fixnum) + push-number-string)) +) + +(defvar *tk-package* (find-package "TK")) + +(eval-when (compile eval load) + +(defconstant *header* '(magic1 magic2 type flag body-length nil nil msg-index nil nil)) + +;;enum print_arglist_codes {..}; +(defvar *print-arglist-codes* + '( + normal + no_leading_space + join_follows + end_join + begin_join + begin_join_no_leading_space + no_quote + no_quote_no_leading_space + no_quote_downcase + no_quotes_and_no_leading_space + + )) + +(defconstant *mtypes* + '( m_not_used + m_create_command + m_reply + m_call + m_tcl_command + m_tcl_command_wait_response + m_tcl_clear_connection + m_tcl_link_text_variable + m_set_lisp_loc + m_tcl_set_text_variable + m_tcl_unlink_text_variable + m_lisp_eval + m_lisp_eval_wait_response + )) + +(defconstant *magic1* #\) +(defconstant *magic2* #\A) + + +(defvar *some-fixnums* (make-array 3 :element-type 'fixnum)) +(defmacro msg-index () `(the fixnum + (aref (the (array fixnum) *some-fixnums*) 0))) +;;; (defmacro safe-car (x) +;;; (cond ((symbolp x) `(if (consp ,x) (car ,x) (if (null ,x) nil +;;; (not-a-cons ,x)))) +;;; (t (let ((sym (gensym))) +;;; `(let ((,sym ,x)) +;;; (safe-car ,sym)))))) +;;; (defmacro safe-cdr (x) +;;; (cond ((symbolp x) `(if (consp ,x) (cdr ,x) (if (null ,x) nil +;;; (not-a-cons ,x)))) +;;; (t (let ((sym (gensym))) +;;; `(let ((,sym ,x)) +;;; (safe-cdr ,sym)))))) + + +(defun desetq-consp-check (val) + (or (consp val) (error "~a is not a cons" val))) + +(defun desetq1 (form val) + (cond ((symbolp form) + (cond (form ;(push form *desetq-binds*) + `(setf ,form ,val)))) + ((consp form) + `(progn + (desetq-consp-check ,val) + ,(desetq1 (car form) `(car ,val)) + ,@ (if (consp (cdr form)) + (list(desetq1 (cdr form) `(cdr ,val))) + (and (cdr form) `((setf ,(cdr form) (cdr ,val))))))) + (t (error "")))) + +(defmacro desetq (form val) + (cond ((atom val) (desetq1 form val)) + (t (let ((value (gensym))) + `(let ((,value ,val)) , (desetq1 form value)))))) +(defmacro while (test &body body) + `(sloop while ,test do ,@ body)) + +) + +(defmacro nth-value (n form) + `(multiple-value-bind ,(make-list (+ n 1) :initial-element 'a) ,form a)) + +(defvar *tk-command* nil) + +(defvar *debugging* nil) +(defvar *break-on-errors* nil) + +(defvar *tk-connection* nil ) + +;; array of functions to be invoked from lisp. +(defvar *call-backs* (make-array 20 :fill-pointer 0 :adjustable t )) + +;;array of message half read. Ie read header but not body. +(defvar *pending* nil) + +;;circular array for replies,requests esp for debugging +;; replies is used for getting replies. +(defvar *replies* (make-array (expt 2 7)) "circle of replies to requests in *requests*") + +;; these are strings +(defvar *requests* (make-array (expt 2 7))) + +;; these are lisp forms +(defvar *request-forms* (make-array 40)) + + +(defvar *read-buffer* (make-array 400 :element-type 'standard-char + :fill-pointer 0 :static t)) + +(defvar *text-variable-locations* + (make-array 10 :fill-pointer 0 :adjustable t)) + + + + +(defmacro pos (flag lis) + (or + (member flag (symbol-value lis)) + (error "~a is not in ~a" flag lis)) + (position flag (symbol-value lis))) + + + + + +;;; (defun p1 (a &aux tem) +;;; ;;Used for putting A into a string for sending a command to TK +;;; (cond +;;; ((and (symbolp a) (setq tem (get a 'tk-print))) +;;; (format *tk-command* tem)) +;;; ((keywordp a) +;;; (format *tk-command* "-~(~a~)" a)) +;;; ((numberp a) +;;; (format *tk-command* "~a" a)) +;;; ((stringp a) +;;; (format *tk-command* "\"~a\"" a)) +;;; ((and (consp a)(eq (car a) 'a)) +;;; (format *tk-command* "~a" (cdr a))) +;;; ((and (consp a)(eq (car a) 'd)) +;;; (format *tk-command* "~(~a~)" (cdr a))) +;;; ((and (symbolp a) +;;; (eql (aref (symbol-name a) 0) +;;; #\.)) +;;; (format *tk-command* "~(~a~)" a)) +;;; (t (error "unrecognized term ~s" a)))) + + +(defvar *command-strings* + (sloop for i below 2 collect + (make-array 200 :element-type 'standard-char :fill-pointer 0 :adjustable t))) + +(defvar *string-streams* (list (make-string-input-stream "") (make-string-input-stream ""))) + +(defmacro with-tk-command (&body body) + `(let (tk-command (*command-strings* *command-strings*)) + (declare (type string tk-command)) + (setq tk-command (grab-tk-command)) + ,@ body)) + +(defun grab-tk-command( &aux x) + ;; keep a list of available *command-strings* and grab one + (cond + ((cdr *command-strings*)) + (t + (setq x (list (make-array 70 + :element-type 'standard-char + :fill-pointer 0 :adjustable t)) + ) + (or *command-strings* (error "how??")) + + (setq *command-strings* (nconc *command-strings* x)))) + (let ((x (car *command-strings*))) + (setq *command-strings* (cdr *command-strings*)) + (setf (fill-pointer x ) #.(length *header*)) + x + )) + +(defun print-to-string (str x code) + (cond ((consp x) + (cond ((eq (car x) 'a) + (setq x (cdr x) + code (pos no_quote *print-arglist-codes*))) + ((eq (car x) 'd) + (setq x (cdr x) + code (pos no_quote_downcase *print-arglist-codes*))) + (t (error "bad arg ~a" x))))) + (while (null (si::print-to-string1 str x code)) + (cond ((typep x 'bignum) + (setq x (format nil "~a" x))) + (t (setq str (adjust-array str + (the fixnum + (+ (the fixnum + (array-total-size str)) + (the fixnum + (+ + (if (stringp x) + (length (the string x)) + 0) + 70)))) + :fill-pointer (fill-pointer str) + :element-type 'string-char))))) + str) + +(defmacro pp (x code) + (let ((u `(pos ,code *print-arglist-codes*))) + `(print-to-string tk-command ,x ,u))) + +(defun print-arglist (to-string l &aux v in-join x) +;; (sloop for v in l do (p :| | v)) + (while l + (setq v (cdr l)) + (setq x (car l)) + (cond + ((eql (car v) ': ) + (print-to-string to-string x + (if in-join + (pos join_follows *print-arglist-codes*) + (pos begin_join *print-arglist-codes*))) + (setq in-join t) + (setq v (cdr v))) + (in-join + (print-to-string to-string x (pos end_join *print-arglist-codes*)) + (setq in-join nil)) + (t;; code == (pos normal *print-arglist-codes*) + (print-to-string to-string x (pos normal *print-arglist-codes*)))) + + (setq l v) + )) + +(defmacro p (&rest l) + `(progn ,@ (sloop for v in l collect `(p1 ,v)))) + +(defvar *send-and-wait* nil "If not nil, then wait for answer and check result") + +(defun tk-call (fun &rest l &aux result-type) + (with-tk-command + (pp fun no_leading_space) + (setq result-type (prescan-arglist l nil nil)) + (print-arglist tk-command l) + (cond (result-type + (call-with-result-type tk-command result-type)) + (t (send-tcl-cmd *tk-connection* tk-command nil) + (values))))) + +(defun tk-do (str &rest l &aux ) + (with-tk-command + (pp str no_quotes_and_no_leading_space) + ;; leading keyword printed without '-' at beginning. + (while l + (pp (car l) no_quotes_and_no_leading_space) + (setq l (cdr l))) + (call-with-result-type tk-command 'string))) + +(defun tk-do-no-wait (str &aux (n (length str))) + (with-tk-command + (si::copy-array-portion str tk-command 0 #.(length *header*) n) + (setf (fill-pointer tk-command) (the fixnum (+ n #.(length *header*)))) + (let () + (send-tcl-cmd *tk-connection* tk-command nil)))) + +(defun send-tcl-cmd (c str send-and-wait ) + ;(notice-text-variables) + (or send-and-wait (setq send-and-wait *send-and-wait*)) + ; (setq send-and-wait t) + (vector-push-extend (code-char 0) str) + (let ((msg-id (set-message-header str + (if send-and-wait + (pos m_tcl_command_wait_response *mtypes*) + (pos m_tcl_command *mtypes*)) + (the fixnum + (- (length str) + #.(length *header*)))))) + + (cond (send-and-wait + (if *debugging* + (store-circle *requests* (subseq str #.(length *header*)) + msg-id)) + (store-circle *replies* nil msg-id) + (execute-tcl-cmd c str)) + (t (store-circle *requests* nil msg-id) + (write-to-connection c str))))) + + +(defun send-tcl-create-command (c str) + (vector-push-extend (code-char 0) str) + (set-message-header str (pos m_create_command *mtypes*) + (- (length str) #.(length *header*))) + (write-to-connection c str)) + +(defun write-to-connection (con string &aux tem) + (let* ((*sigusr1* t) + ;; dont let us get interrupted while writing!! + (n (length string)) + (fd (caar con)) + (m 0)) + (declare (Fixnum n m)) + (or con (error "Trying to write to non open connection ")) + (if *debugging* (describe-message string)) + (or (typep fd 'string) + (error "~a is not a connection" con)) + (setq m (si::our-write fd string n)) + (or (eql m n) (error "Failed to write ~a bytes to file descriptor ~a" n fd)) + (setq tem *sigusr1*) + ;; a signal at this instruction would not be noticed...since it + ;; would set *sigusr1* to :received but that would be too late for tem + ;; since the old value will be popped off the binding stack at the next 'paren' + ) + (cond ((eq tem :received) + (read-and-act nil))) + t) + + +(defun coerce-string (a) + (cond ((stringp a) a) + ((fixnump a) (format nil "~a" a)) + ((numberp a) (format nil "~,2f" (float a))) + ((keywordp a) + (format nil "-~(~a~)" a)) + ((symbolp a) + (format nil "~(~a~)" a)) + (t (error "bad type")))) +;;2 decimals + +(defun my-conc (a b) + (setq a (coerce-string a)) + (setq b (coerce-string b)) + (concatenate 'string a b )) + +;; In an arglist 'a : b' <==> (tk-conc a b) +;; eg: 1 : "b" <==> "1b" +; "c" : "b" <==> "cb" +; 'a : "b" <==> "ab" +; '.a : '.b <==> ".a.b" +; ':ab : "b" <==> "abb" + +;;Convenience for concatenating symbols, strings, numbers +;; (tk-conc '.joe.bill ".frame.list yview " 3) ==> ".joe.bill.frame.list yview 3" +(defun tk-conc (&rest l) + (declare (:dynamic-extent l)) + (let ((tk-command + (make-array 30 :element-type 'standard-char + :fill-pointer 0 :adjustable t))) + (cond ((null l)) + (t (pp (car l) no_quote_no_leading_space))) + (setq l (cdr l)) + (while (cdr l) + (pp (car l) join_follows) (setq l (cdr l))) + (and l (pp (car l) no_quote_no_leading_space)) + tk-command + )) + + +;;; (defun verify-list (l) +;;; (loop +;;; (cond ((null l)(return t)) +;;; ((consp l) (setq l (cdr l))) +;;; (t (error "not a true list ~s"l))))) + +;;; (defun prescan-arglist (l pathname name-caller &aux result-type) +;;; (let ((v l) tem prev a b c) +;;; (verify-list l) +;;; (sloop while v +;;; do +;;; (cond +;;; ((keywordp (car v)) +;;; (setq a (car v)) +;;; (setq c (cdr v)) +;;; (setq b (car c) c (cadr c)) +;;; (cond ((eq a :bind) +;;; (cond ((setq tem (cdddr v)) +;;; (or (eq (cadr tem) ': ) +;;; (setf (car tem) +;;; (tcl-create-command (car tem) +;;; nil +;;; t)))))) +;;; ((eq c ': )) +;;; ((member a'(:yscroll :command +;;; :xscroll +;;; :yscrollcommand +;;; :xscrollcommand +;;; :scrollcommand +;;; )) +;;; (cond ((setq tem (cdr v)) +;;; (setf (car tem) +;;; (tcl-create-command (car tem) +;;; (or (get a 'command-arg) + +;;; (get name-caller +;;; 'command-arg)) +;;; nil))))) +;;; ((eq (car v) :return) +;;; (setf result-type (cadr v)) +;;; (cond (prev +;;; (setf (cdr prev) (cddr v))) +;;; (t (setf (car v) '(a . "")) +;;; (setf (cdr v) (cddr v))))) +;;; ((eq (car v) :textvariable) +;;; (setf (second v) (link-variable b 'string))) +;;; ((member (car v) '(:value :onvalue :offvalue)) +;;; (let* ((va (get pathname 'variable)) +;;; (type (get va 'linked-variable-type)) +;;; (fun (cdr (get type +;;; 'coercion-functions)))) +;;; (or va +;;; (error +;;; "Must specify :variable before :value so that we know the type")) +;;; (or fun (error "No coercion-functions for type ~s" type)) +;;; (setf (cadr v) (funcall fun b)))) +;;; ((eq (car v) :variable) +;;; (let ((va (second v)) +;;; (type (cond ((eql name-caller 'checkbutton) 'boolean) +;;; (t 'string)))) +;;; (cond ((consp va) +;;; (desetq (type va) va) +;;; (or (symbolp va) +;;; (error "should be :variable (type symbol)")))) +;;; (setf (get pathname 'variable) va) +;;; (setf (second v) +;;; (link-variable va type)))) +;;; ))) +;;; (setq prev v) +;;; (setq v (cdr v)) +;;; )) +;;; result-type +;;; ) + + +(defun prescan-arglist (l pathname name-caller &aux result-type) + (let ((v l) tem prev a ) +; (verify-list l) ; unnecessary all are from &rest args. +; If pathname supplied, then this should be an alternating list +;; of keywords and values..... + (sloop while v + do (setq a (car v)) + (cond + ((keywordp a) + (cond + ((eq (car v) :return) + (setf result-type (cadr v)) + (cond (prev + (setf (cdr prev) (cddr v))) + (t (setf (car v) '(a . "")) + (setf (cdr v) (cddr v))))) + ((setq tem (get a 'prescan-function)) + (funcall tem a v pathname name-caller))))) + (setq prev v) + (setq v (cdr v))) + result-type)) + +(eval-when (compile eval load) +(defun set-prescan-function (fun &rest l) + (dolist (v l) (setf (get v 'prescan-function) fun))) +) + + +(set-prescan-function 'prescan-bind :bind) +(defun prescan-bind + (x v pathname name-caller &aux tem) + name-caller pathname x + (cond ((setq tem (cdddr v)) + (or + (keywordp (car tem)) + (eq (cadr tem) ': ) + (setf (car tem) + (tcl-create-command (car tem) + nil + t)))))) + +(set-prescan-function 'prescan-command :yscroll :command + :postcommand + :xscroll + :yscrollcommand + :xscrollcommand + :scrollcommand) + +(defun prescan-command (x v pathname name-caller &aux tem arg) + x pathname + (setq arg (cond (( member v '(:xscroll + :yscrollcommand + :xscrollcommand + :scrollcommand)) + + 'aaaa) + ((get name-caller 'command-arg)))) + (cond ((setq tem (cdr v)) + (cond ((eq (car tem) :return ) :return) + (t + (setf (car tem) + (tcl-create-command (car tem) arg nil))))))) + +(defun prescan-value (a v pathname name-caller) + a name-caller + (let* ((va (get pathname ':variable)) + (type (get va 'linked-variable-type)) + (fun (cdr (get type + 'coercion-functions)))) + (or va + (error + "Must specify :variable before :value so that we know the type")) + (or fun (error "No coercion-functions for type ~s" type)) + (setq v (cdr v)) + (if v + (setf (car v) (funcall fun (car v)))))) + +(set-prescan-function 'prescan-value :value :onvalue :offvalue) + +(set-prescan-function + #'(lambda (a v pathname name-caller) + a + (let ((va (second v)) + (type (cond ((eql name-caller 'checkbutton) 'boolean) + (t 'string)))) + (cond ((consp va) + (desetq (type va) va) + (or (symbolp va) + (error "should be :variable (type symbol)")))) + (cond (va + (setf (get pathname a) va) + (setf (second v) + (link-variable va type)))))) + :variable :textvariable) + +(defun make-widget-instance (pathname widget) + ;; ??make these not wait for response unless user is doing debugging.. + (or (symbolp pathname) (error "must give a symbol")) + #'(lambda ( &rest l &aux result-type (option (car l))) + (declare (:dynamic-extent l)) + (setq result-type (prescan-arglist l pathname widget)) + (if (and *break-on-errors* (not result-type)) + (store-circle *request-forms* + (cons pathname (copy-list l)) + (msg-index))) + (with-tk-command + (pp pathname no_leading_space) + ;; the leading keyword gets printed with no leading - + (or (keywordp option) + (error "First arg to ~s must be an option keyword not ~s" + pathname option )) + (pp option no_quote) + (setq l (cdr l)) + ;(print (car l)) + (cond ((and (keywordp (car l)) + (not (eq option :configure)) + (not (eq option :config)) + (not (eq option :itemconfig)) + (not (eq option :cget)) + (not (eq option :postscript)) + ) + (pp (car l) no_quote) + (setq l (cdr l)))) + (print-arglist tk-command l) + (cond (result-type + (call-with-result-type tk-command result-type)) + (t (send-tcl-cmd *tk-connection* tk-command nil) + (values)))))) + +(defmacro def-widget (widget &key (command-arg 'sssss)) + `(eval-when (compile eval load) + (setf (get ',widget 'command-arg) ',command-arg) + (defun ,widget (pathname &rest l)(declare (:dynamic-extent l)) + (widget-function ',widget pathname l)))) + + +;; comand-arg "asaa" means pass second arg back as string, and others not quoted + ;; ??make these always wait for response + ;; since creating a window failure is likely to cause many failures. +(defun widget-function (widget pathname l ) + (or (symbolp pathname) + (error "First arg to ~s must be a symbol not ~s" widget pathname)) + (if *break-on-errors* + (store-circle *request-forms* (cons pathname (copy-list l)) + (msg-index))) + (prescan-arglist l pathname widget) + (with-tk-command + (pp widget no_leading_space) + (pp pathname normal) + (print-arglist tk-command l ) + (multiple-value-bind (res success) + (send-tcl-cmd *tk-connection* tk-command t) + (if success + (setf (symbol-function pathname) + (make-widget-instance pathname widget)) + (error + "Cant define ~(~a~) pathnamed ~(~a~): ~a" + widget pathname res))) + pathname)) +(def-widget button) +(def-widget listbox) +(def-widget scale :command-arg a) +(def-widget canvas) +(def-widget menu) +(def-widget scrollbar) +(def-widget checkbutton) +(def-widget menubutton) +(def-widget text) +(def-widget entry) +(def-widget message) +(def-widget frame) +(def-widget label) +(def-widget |image create photo|) +(def-widget |image create bitmap|) +(def-widget radiobutton) +(def-widget toplevel) + +(defmacro def-control (name &key print-name before) + (cond ((null print-name )(setq print-name name)) + (t (setq print-name (cons 'a print-name)))) + `(defun ,name (&rest l) + ,@ (if before `((,before ',print-name l))) + (control-function ',print-name l))) + +(defun call-with-result-type (tk-command result-type) + (multiple-value-bind + (res suc) + (send-tcl-cmd *tk-connection* tk-command t) + (values (if result-type (coerce-result res result-type) res) + suc))) + +(defun control-function (name l &aux result-type) + ;(store-circle *request-forms* (cons name l) (msg-index)) + (setq result-type (prescan-arglist l nil name)) + (with-tk-command + (pp name normal) + ;; leading keyword printed without '-' at beginning. + (cond ((keywordp (car l)) + (pp (car l) no_quote) + (setq l (cdr l)))) + (print-arglist tk-command l) + (call-with-result-type tk-command result-type))) + + +(dolist (v + '( |%%| |%#| |%a| |%b| |%c| |%d| |%f| |%h| |%k| |%m| |%o| |%p| |%s| |%t| + |%v| |%w| |%x| |%y| |%A| |%B| |%D| |%E| |%K| |%N| |%R| |%S| |%T| |%W| |%X| |%Y|)) + (progn (setf (get v 'event-symbol) + (symbol-name v)) + (or (member v '(|%d| |%m| |%p| |%K| ;|%W| + |%A|)) + (setf (get v 'event-symbol) + (cons (get v 'event-symbol) 'fixnum ))))) + +(defvar *percent-symbols-used* nil) +(defun get-per-cent-symbols (expr) + (cond ((atom expr) + (and (symbolp expr) (get expr 'event-symbol) + (pushnew expr *percent-symbols-used*))) + (t (get-per-cent-symbols (car expr)) + (setq expr (cdr expr)) + (get-per-cent-symbols expr)))) + + +(defun reserve-call-back ( &aux ind) + (setq ind (fill-pointer *call-backs*)) + (vector-push-extend nil *call-backs* ) + ind) + +;; The command arg: +;; For bind windowSpec SEQUENCE COMMAND +;; COMMAND is called when the event SEQUENCE occurs to windowSpec. +;; If COMMAND is a symbol or satisfies (functionp COMMAND), then +;; it will be funcalled. The number of args supplied in this +;; case is determined by the widget... for example a COMMAND for the +;; scale widget will be supplied exactly 1 argument. +;; If COMMAND is a string then this will be passed to the graphics +;; interpreter with no change, +;; This allows invoking of builtin functionality, without bothering the lisp process. +;; If COMMAND is a lisp expression to eval, and it may reference +;; details of the event via the % constructs eg: %K refers to the keysym +;; of the key pressed (case of BIND only). A function whose body is the +;; form, will actually be constructed which takes as args all the % variables +;; actually appearing in the form. The body of the function will be the form. +;; Thus (print (list |%w| %W) would turn into #'(lambda(|%w| %W) (print (list |%w| %W))) +;; and when invoked it would be supplied with the correct args. + +(defvar *arglist* nil) +(defun tcl-create-command (command arg-data allow-percent-data) + (with-tk-command + (cond ((or (null command) (equal command "")) + (return-from tcl-create-command "")) + ((stringp command) + (return-from tcl-create-command command))) + (let (*percent-symbols-used* tem ans name ind) + (setq ind (reserve-call-back)) + (setq name (format nil "callback_~d" ind)) + ;; install in tk the knowledge that callback_ind will call back to here. + ;; and tell it arg types expected. + ;; the percent commands are handled differently + (push-number-string tk-command ind #.(length *header*) 3) + (setf (fill-pointer tk-command) #.(+ (length *header*) 3)) + (if arg-data (pp arg-data no_leading_space)) + (send-tcl-create-command *tk-connection* tk-command) + (if (and arg-data allow-percent-data) (error "arg data and percent data not allowed")) + (cond ((or (symbolp command) + (functionp command))) + (allow-percent-data + (get-per-cent-symbols command) + (and *percent-symbols-used* (setq ans "")) + (sloop for v in *percent-symbols-used* + do (setq tem (get v 'event-symbol)) + (cond ((stringp tem) + (setq ans (format nil "~a \"~a\"" ans tem))) + ((eql (cdr tem) 'fixnum) + (setq ans (format nil "~a ~a" ans (car tem)))) + (t (error "bad arg")))) + (if ans (setq ans (concatenate 'string "{(" ans ")}"))) + (setq command `(lambda ,*percent-symbols-used* + ,command)) + (if ans (setq name (concatenate 'string "{"name " " ans"}")))) + (t (setq command `(lambda (&rest *arglist*) ,command)))) + (setf (aref *call-backs* ind) command) + ;; the command must NOT appear as "{[...]}" or it will be eval'd. + (cons 'a name) + ))) + +(defun bind (window-spec &optional sequence command type) + "command may be a function name, or an expression which + may involve occurrences of elements of *percent-symbols* + The expression will be evaluated in an enviroment in which + each of the % symbols is bound to the value of the corresponding + event value obtained from TK." + (cond ((equal sequence :return) + (setq sequence nil) + (setq command nil))) + (cond ((equal command :return) + (or (eq type 'string) + (tkerror "bind only returns type string")) + (setq command nil)) + (command + (setq command (tcl-create-command command nil t)))) + (with-tk-command + (pp 'bind no_leading_space) + (pp window-spec normal) + (and sequence (pp sequence normal)) + (and command (pp command normal)) + (send-tcl-cmd *tk-connection* tk-command (or (null sequence)(null command))))) + +(defmacro tk-connection-fd (x) `(caar ,x)) + +(def-control after) +(def-control exit) +(def-control lower) +(def-control place) +(def-control send) +(def-control tkvars) +(def-control winfo) +(def-control focus) +(def-control option) +(def-control raise) +(def-control tk) +;; problem on waiting. Waiting for dialog to kill self +;; wont work because the wait blocks even messages which go +;; to say to kill... +;; must use +;; (grab :set :global .fo) +;; and sometimes the gcltkaux gets blocked and cant accept input when +;; in grabbed state... +(def-control tkwait) +(def-control wm) +(def-control destroy :before destroy-aux) +(def-control grab) +(def-control pack) +(def-control selection) +(def-control tkerror) +(def-control update) +(def-control tk-listbox-single-select :print-name "tk_listboxSingleSelect") +(def-control tk-menu-bar :print-name "tk_menuBar") +(def-control tk-dialog :print-name "tk_dialog") +(def-control get_tag_range) + +(def-control lsearch) +(def-control lindex) + + +(defun tk-wait-til-exists (win) + (tk-do (tk-conc "if ([winfo exists " win " ]) { } else {tkwait visibility " win "}"))) + +(defun destroy-aux (name l) + name + (dolist (v l) + (cond ((stringp v)) + ((symbolp v) + (dolist (prop '(:variable :textvariable)) + (remprop v prop)) + (fmakunbound v) + ) + (t (error "not a pathname : ~s" v)))) + + ) + +(defvar *default-timeout* (* 100 internal-time-units-per-second)) + +(defun execute-tcl-cmd (connection cmd) + (let (id tem (time *default-timeout*)) + (declare (fixnum time)) + (setq id (get-number-string cmd (pos msg-index *header*) 3)) + (store-circle *replies* nil id) + (write-to-connection connection cmd) + (loop + (cond ((setq tem (get-circle *replies* id)) + (cond ((or (car tem) (null *break-on-errors*)) + (return-from execute-tcl-cmd (values (cdr tem) (car tem)))) + (t (cerror "Type :r to continue" "Cmd failed: ~a : ~a " + (subseq cmd (length *header*) + (- (length cmd) 1) + ) + (cdr tem)) + (return (cdr tem)) + )))) + (cond ((> (si::check-state-input + (tk-connection-fd connection) 10) 0) + (read-and-act id) + )) + (setq time (- time 10)) + (cond ((< time 0) + (cerror ":r resumes waiting for *default-timeout*" + "Did not get a reply for cmd ~a" cmd) + (setq time *default-timeout*) + ))))) + +(defun push-number-string (string number ind bytes ) + (declare (fixnum ind number bytes)) + ;; a number #xabcdef is stored "" where is (code-char #xef) + (declare (string string)) + (declare (fixnum number bytes )) + (sloop while (>= bytes 1) do + (setf (aref string ind) + (the character (code-char + (the fixnum(logand number 255))))) + (setq ind (+ ind 1)) + (setq bytes (- bytes 1)) +; (setq number (* number 256)) + (setq number (ash number -8)) + nil)) + +(defun get-number-string (string start bytes &aux (number 0)) + ;; a number #xabcdef is stored "" where is (code-char #xef) + (declare (string string)) + (declare (fixnum number bytes start)) + (setq start (+ start (the fixnum (- bytes 1)))) + (sloop while (>= bytes 1) do + (setq number (+ number (char-code (aref string start)))) + (setq start (- start 1) bytes (- bytes 1)) + (cond ((> bytes 0) (setq number (ash number 8))) + (t (return number))))) + + +(defun quit () (tkdisconnect) (bye)) + +(defun debugging (x) + (setq *debugging* x)) + +(defmacro dformat (&rest l) + `(if *debugging* (dformat1 ,@l))) +(defun dformat1 (&rest l) + (declare (:dynamic-extent l)) + (format *debug-io* "~%Lisp:") + (apply 'format *debug-io* l)) + +(defvar *sigusr1* nil) +;;??NOTE NOTE we need to make it so that if doing code inside an interrupt, +;;then we do NOT do a gc for relocatable. This will kill US. +;;One hack would be that if relocatable is low or cant be grown.. then +;;we just set a flag which says run our sigusr1 code at the next cons... +;;and dont do anything here. Actually we can always grow relocatable via sbrk, +;;so i think it is ok.....??...... + +(defun system::sigusr1-interrupt (x) + x + (cond (*sigusr1* + (setq *sigusr1* :received)) + (*tk-connection* + (let ((*sigusr1* t)) + (dformat "Received SIGUSR1. ~a" + (if (> (si::check-state-input + (tk-connection-fd *tk-connection*) 0) 0) "" + "No Data left there.")) + ;; we put 4 here to wait for a bit just in case + ;; data comes + (si::check-state-input + (tk-connection-fd *tk-connection*) 4 ) + (read-and-act nil))))) +(setf (symbol-function 'si::SIGIO-INTERRUPT) (symbol-function 'si::sigusr1-interrupt)) + + +(defun store-circle (ar reply id) + (declare (type (array t) ar) + (fixnum id)) + (setf (aref ar (the fixnum (mod id (length ar)))) reply)) + +(defun get-circle (ar id) + (declare (type (array t) ar) + (fixnum id)) + (aref ar (the fixnum (mod id (length ar))))) + +(defun decode-response (str &aux reply-from ) + (setq reply-from (get-number-string str + #.(+ 1 (length *header*)) + 3)) + (values + (subseq str #.(+ 4 (length *header*))) + (eql (aref str #.(+ 1 (length *header*))) #\0) + reply-from + (get-circle *requests* reply-from))) + +(defun describe-message (vec) + + (let ((body-length (get-number-string vec (pos body-length *header*) 3)) + (msg-index (get-number-string vec (pos msg-index *header*) 3)) + (mtype (nth (char-code (aref vec (pos type *header*))) *mtypes*)) + success from-id requ + ) + (format t "~%Msg-id=~a, type=~a, leng=~a, " msg-index mtype body-length) + (case mtype + (m_reply + (setq from-id (get-number-string vec #.(+ 1 (length *header*)) + 3)) + (setq success (eql (aref vec #.(+ 0 (length *header*))) + #\0)) + (setq requ (get-circle *requests* from-id)) + (format t "result-code=~a[bod:~s](form msg ~a)[hdr:~s]" + success + (subseq vec #.(+ 4 (length *header*))) + from-id + (subseq vec 0 (length *header*)) + ) + ) + ((m_create_command m_call + m_lisp_eval + m_lisp_eval_wait_response) + (let ((islot (get-number-string vec #.(+ 0 (length *header*)) 3))) + (format t "islot=~a(callback_~a), arglist=~s" islot islot + (subseq vec #.(+ 3 (length *header*)))))) + ((m_tcl_command m_tcl_command_wait_response + M_TCL_CLEAR_CONNECTION + ) + (format t "body=[~a]" (subseq vec (length *header*)) )) + ((m_tcl_set_text_variable) + (let* ((bod (subseq vec (length *header*))) + (end (position (code-char 0) bod)) + (var (subseq bod 0 end))) + (format t "name=~s,val=[~a],body=" var (subseq bod (+ 1 end) + (- (length bod) 1)) + bod))) + ((m_tcl_link_text_variable + m_tcl_unlink_text_variable + m_set_lisp_loc) + + (let (var (islot (get-number-string vec #.(+ 0 (length *header*)) 3))) + (format t "array_slot=~a,name=~s,type=~s body=[~a]" islot + (setq var (aref *text-variable-locations* islot)) + (get var 'linked-variable-type) + (subseq vec #.(+ 3 (length *header*)))))) + + (otherwise (error "unknown message type ~a [~s]" mtype vec ))))) + +(defun clear-tk-connection () + ;; flush both sides of connection and discard any partial command. + (cond + (*tk-connection* + (si::clear-connection-state (car (car *tk-connection*))) + (setq *pending* nil) + (with-tk-command + (set-message-header tk-command (pos m_tcl_clear_connection *mtypes*) 0) + (write-to-connection *tk-connection* tk-command)) + ))) + +(defun read-tk-message (ar connection timeout &aux + (n-read 0)) + (declare (fixnum timeout n-read) + (string ar)) + (cond (*pending* + (read-message-body *pending* connection timeout))) + + (setq n-read(si::our-read-with-offset (tk-connection-fd connection) + ar 0 #.(length *header*) timeout)) + (setq *pending* ar) + (cond ((not (eql n-read #.(length *header*))) + (cond ((< n-read 0) + (tkdisconnect) + (cerror ":r to resume " + "Read got an error, have closed connection")) + (t (error "Bad tk message")))) + (t + (or (and + (eql (aref ar (pos magic1 *header*)) *magic1*) + (eql (aref ar (pos magic2 *header*)) *magic2*)) + (error "Bad magic")) + (read-message-body ar connection timeout)))) + +(defun read-message-body (ar connection timeout &aux (m 0) (n-read 0)) + (declare (fixnum m n-read)) + (setq m (get-number-string ar (pos body-length *header*) 3)) + (or (>= (array-total-size ar) (the fixnum (+ m #.(length *header*)))) + (setq ar (adjust-array ar (the fixnum (+ m 40))))) + (cond (*pending* + (setq n-read (si::our-read-with-offset (tk-connection-fd connection) + ar + #.(length *header*) m timeout)) + (setq *pending* nil) + (or (eql n-read m) + (error "Failed to read ~a bytes" m)) + (setf (fill-pointer ar) (the fixnum (+ m #.(length *header*)))))) + (if *debugging* (describe-message ar)) + ar) + +(defun tkdisconnect () + (cond (*tk-connection* + (si::close-sd (caar *tk-connection*)) + (si::close-fd (cadr *tk-connection*)))) + (setq *sigusr1* t);; disable it... + (setq *pending* nil) + (setf *tk-connection* nil) + + ) + +(defun read-and-act (id) + id + (when + *tk-connection* + (let* ((*sigusr1* t) tem fun string) + (with-tk-command + (tagbody + TOP + (or (> (si::check-state-input + (tk-connection-fd *tk-connection*) 0) 0) + (return-from read-and-act)) + (setq string (read-tk-message tk-command *tk-connection* *default-timeout*)) + + (let ((type (char-code (aref string (pos type *header*)))) + from-id success) + (case + type + (#.(pos m_reply *mtypes*) + (setq from-id (get-number-string tk-command #.(+ 1 (length *header*)) + 3)) + (setq success (eql (aref tk-command #.(+ 0 (length *header*))) + #\0)) + (cond ((and (not success) + *break-on-errors* + (not (get-circle *requests* from-id))) + (cerror + ":r to resume ignoring" + "request ~s failed: ~s" + (or (get-circle *request-forms* from-id) "") + (subseq tk-command #.(+ 4 (length *header*)))))) + + (store-circle *replies* + (cons success + (if (eql (length tk-command) #.(+ 4 (length *header*))) "" + (subseq tk-command #.(+ 4 (length *header*))))) + from-id)) + (#.(pos m_call *mtypes*) + ;; Can play a game of if read-and-act called with request-id: + ;; When we send a request which waits for an m_reply, we note + ;; at SEND time, the last message id received from tk. We + ;; dont process any funcall's with lower id than this id, + ;; until after we get the m_reply back from tk. + (let ((islot + (get-number-string tk-command #.(+ 0 (length *header*))3)) + (n (length tk-command))) + (declare (fixnum islot n)) + (setq tem (our-read-from-string tk-command + #.(+ 0 (length *header*)3))) + (or (< islot (length *call-backs*)) + (error "out of bounds call back??")) + (setq fun (aref (the (array t) *call-backs*) islot)) + (cond ((equal n #.(+ 3 (length *header*))) + (funcall fun)) + (t + (setq tem (our-read-from-string + tk-command + #.(+ 3(length *header*)))) + (cond ((null tem) (funcall fun)) + ((consp tem) (apply fun tem)) + (t (error "bad m_call message "))))))) + (#.(pos m_set_lisp_loc *mtypes*) + (let* ((lisp-var-id (get-number-string tk-command #.(+ 0 (length *header*)) + 3)) + (var (aref *text-variable-locations* lisp-var-id)) + (type (get var 'linked-variable-type)) + val) + (setq val (coerce-result (subseq tk-command #.(+ 3 (length *header*))) type)) + (setf (aref *text-variable-locations* (the fixnum + ( + lisp-var-id 1))) + val) + (set var val))) + (otherwise (format t "Unknown response back ~a" tk-command))) + + (if (eql *sigusr1* :received) + (dformat "<>")) + (go TOP) + )))))) + +(defun our-read-from-string (string start) + (let* ((s (car *string-streams*)) + (*string-streams* (cdr *string-streams*))) + (or s (setq s (make-string-input-stream ""))) + (si::reset-string-input-stream s string start (length string)) + (read s nil nil))) + + +(defun atoi (string) + (if (numberp string) string + (our-read-from-string string 0))) + + +(defun conc (a b &rest l &aux tem) + (declare (:dynamic-extent l)) + (sloop + do + (or (symbolp a) (error "not a symbol ~s" a)) +; (or (symbolp b) (error "not a symbol ~s" b)) + (cond ((setq tem (get a b))) + (t (setf (get a b) + (setq tem (intern (format nil "~a~a" a b) + *tk-package* + ))))) + while l + do + (setq a tem b (car l) l (cdr l))) + tem) + + + + +(defun dpos (x) (wm :geometry x "+60+25")) + +(defun string-list (x) + (let ((tk-command + (make-array 30 :element-type 'standard-char :fill-pointer 0 :adjustable t))) + (string-list1 tk-command x) + tk-command)) + +(defun string-list1 (tk-command l &aux x) + ;; turn a list into a tk list + (desetq (x . l) l) + (pp x no_leading_space) + (while l + (desetq (x . l) l) + (cond ((atom x) + (pp x normal)) + ((consp x) + (pp "{" no_quote) + (string-list1 tk-command x) + (pp '} no_leading_space))))) + +(defun list-string (x &aux + (brace-level 0) + skipping (ch #\space) + (n (length x)) + ) + (declare (Fixnum brace-level n) + (string x) + (character ch)) + (if (eql n 0) (return-from list-string nil)) + (sloop for i below n + with beg = 0 and ans + do (setq ch (aref x i)) + (cond + ((eql ch #\space) + (cond (skipping nil) + ((eql brace-level 0) + (if (> i beg) + (setq ans (cons (subseq x beg i) ans))) + + (setq beg (+ i 1)) + ))) + (t (cond (skipping (setq skipping nil) + (setq beg i))) + (case ch + (#\{ (cond ((eql brace-level 0) + (setq beg (+ i 1)))) + (incf brace-level)) + (#\} (cond ((eql brace-level 1) + (setq ans (cons (subseq x beg i) ans)) + (setq skipping t))) + (incf brace-level -1))))) + finally + (unless skipping + (setq ans (cons (subseq x beg i) ans))) + (return (nreverse ans)) + )) + +;; unless keyword :integer-value, :string-value, :list-strings, :list-forms +;; (foo :return 'list) "ab 2 3" --> (ab 2 3) +;; (foo :return 'list-strings) "ab 2 3" --> ("ab" "2" "3") ;;ie +;; (foo :return 'string) "ab 2 3" --> "ab 2 3" +;; (foo :return 't) "ab 2 3" --> AB +;; (foo :return 'boolean) "1" --> t + + +(defun coerce-result (string key) + (case key + (list (our-read-from-string (tk-conc "("string ")") 0)) + (string string) + (number (our-read-from-string string 0)) + ((t) (our-read-from-string string 0)) + (t (let ((funs (get key 'coercion-functions))) + (cond ((null funs) + (error "Undefined coercion for type ~s" key))) + (funcall (car funs) string))))) + +;;convert "2c" into screen units or points or something... + )) + +;; If loc is suitable for handing to setf, then +;; (setf loc (coerce-result val type) +;; (radio-button + +(defvar *unbound-var* "") + +(defun link-variable (var type) + (let* ((i 0) + (ar *text-variable-locations*) + (n (length ar)) + tem + ) + (declare (fixnum i n) + (type (array (t)) ar)) + (cond ((stringp var) + (return-from link-variable var)) + ((symbolp var)) + ((and (consp var) + (consp (cdr var))) + (setq type (car var)) + (setq var (cadr var)))) + (or (and (symbolp type) + (get type 'coercion-functions)) + (error "Need coercion functions for type ~s" type)) + (or (symbolp var) (error "illegal text variable ~s" var)) + (setq tem (get var 'linked-variable-type)) + (unless (if (and tem (not (eq tem type))) + (format t "~%;;Warning: ~s had type ~s, is being changed to type ~s" + var tem type + ))) + (setf (get var 'linked-variable-type) type) + (while (< i n) + (cond ((eq (aref ar i) var) + (return-from link-variable var)) + ((null (aref ar i)) + (return nil)) + (t (setq i (+ i 2))))) +;; i is positioned at the write place + (cond ((= i n) + (vector-push-extend nil ar) + (vector-push-extend nil ar))) + (setf (aref ar i) var) + (setf (aref ar (the fixnum (+ i 1))) + (if (boundp var) + (symbol-value var) + *unbound-var*)) + (with-tk-command + (push-number-string tk-command i #.(length *header*) 3) + (setf (fill-pointer tk-command) #. (+ 3 (length *header*))) + (pp var no_quotes_and_no_leading_space) + (vector-push-extend (code-char 0) tk-command) + (set-message-header tk-command (pos m_tcl_link_text_variable *mtypes*) + (- (length tk-command) #.(length *header*))) + (write-to-connection *tk-connection* tk-command))) + (notice-text-variables) + var) + +(defun unlink-variable (var ) + (let* ((i 0) + (ar *text-variable-locations*) + (n (length ar)) + + ) + (declare (fixnum i n) + (type (array (t)) ar)) + (while (< i n) + (cond ((eq (aref ar i) var) + (setf (aref ar i) nil) + (setf (aref ar (+ i 1)) nil) + (return nil) + ) + (t (setq i (+ i 2))))) + + (cond ((< i n) + (with-tk-command + (push-number-string tk-command i #.(length *header*) 3) + (setf (fill-pointer tk-command) #. (+ 3 (length *header*))) + (pp var no_quotes_and_no_leading_space) + (vector-push-extend (code-char 0) tk-command) + (set-message-header tk-command (pos m_tcl_unlink_text_variable *mtypes*) + (- (length tk-command) #.(length *header*))) + (write-to-connection *tk-connection* tk-command)) + var)))) + +(defun notice-text-variables () + (let* ((i 0) + (ar *text-variable-locations*) + (n (length ar)) + tem var type + ) + (declare (fixnum i n) + (type (array (t)) ar)) + (tagbody + (while (< i n) + (unless (or (not (boundp (setq var (aref ar i)))) + (eq (setq tem (symbol-value var)) + (aref ar (the fixnum (+ i 1))))) + (setf (aref ar (the fixnum (+ i 1))) tem) + (setq type (get var 'linked-variable-type)) + (with-tk-command + ;(push-number-string tk-command i #.(length *header*) 3) + ;(setf (fill-pointer tk-command) #. (+ 3 (length *header*))) + (pp var no_quote_no_leading_space) + (vector-push (code-char 0) tk-command ) + (case type + (string (or (stringp tem) (go error))) + (number (or (numberp tem) (go error))) + ((t) (setq tem (format nil "~s" tem ))) + (t + (let ((funs (get type 'coercion-functions))) + (or funs (error "no writer for type ~a" type)) + (setq tem (funcall (cdr funs) tem))))) + (pp tem no_quotes_and_no_leading_space) + (vector-push (code-char 0) tk-command ) + (set-message-header tk-command (pos m_tcl_set_text_variable *mtypes*) + (- (length tk-command) #.(length *header*))) + (write-to-connection *tk-connection* tk-command))) + (setq i (+ i 2))) + (return-from notice-text-variables) + error + (error "~s has value ~s which is not of type ~s" (aref ar i) + tem type) + ))) +(defmacro setk (&rest l) + `(prog1 (setf ,@ l) + (notice-text-variables))) + +(setf (get 'boolean 'coercion-functions) + (cons #'(lambda (x &aux (ch (aref x 0))) + (cond ((eql ch #\0) nil) + ((eql ch #\1) t) + (t (error "non boolean value ~s" x)))) + #'(lambda (x) (if x "1" "0")))) + +(setf (get 't 'coercion-functions) + (cons #'(lambda (x) (our-read-from-string x 0)) + #'(lambda (x) (format nil "~s" x)))) + +(setf (get 'string 'coercion-functions) + (cons #'(lambda (x) + (cond ((stringp x) x) + (t (format nil "~s" x)))) + 'identity)) + + +(setf (get 'list-strings 'coercion-functions) + (cons 'list-string 'list-to-string)) +(defun list-to-string (l &aux (x l) v (start t)) + (with-tk-command + (while x + (cond ((consp x) + (setq v (car x))) + (t (error "Not a true list ~s" l))) + (cond (start (pp v no_leading_space) (setq start nil)) + (t (pp v normal))) + (setf x (cdr x))) + (subseq tk-command #.(length *header*)))) + + + +(defvar *tk-library* nil) +(defun tkconnect (&key host can-rsh gcltksrv (display (si::getenv "DISPLAY")) + (args "") + &aux hostid (loopback "127.0.0.1")) + (if *tk-connection* (tkdisconnect)) + (or display (error "DISPLAY not set")) + (or *tk-library* (setq *tk-library* (si::getenv "TK_LIBRARY"))) + (or gcltksrv + (setq gcltksrv + (cond (host "gcltksrv") + ((si::getenv "GCL_TK_SERVER")) + ((probe-file (tk-conc si::*lib-directory* "/gcl-tk/gcltksrv"))) + ((probe-file (tk-conc si::*lib-directory* "gcl-tk/gcltksrv"))) + (t (error "Must setenv GCL_TK_SERVER "))))) + (let ((pid (if host -1 (si::getpid))) + (tk-socket (si::open-named-socket 0)) + ) + (cond ((not host) (setq hostid loopback)) + (host (setq hostid (si::hostname-to-hostid (si::gethostname))))) + (or hostid (error "Can't find my address")) + (setq tk-socket (si::open-named-socket 0)) + (if (pathnamep gcltksrv) (setq gcltksrv (namestring gcltksrv))) + (let ((command + (tk-conc gcltksrv " " hostid " " + (cdr tk-socket) " " + pid " " display " " + args + ))) + (print command) + (cond ((not host) (system command)) + (can-rsh + (system (tk-conc "rsh " host " " command + " < /dev/null &"))) + (t (format t "Waiting for you to invoke GCL_TK_SERVER, +on ~a as in: ~s~%" host command ))) + (let ((ar *text-variable-locations*)) + (declare (type (array (t)) ar)) + (sloop for i below (length ar) by 2 + do (remprop (aref ar i) 'linked-variable-type))) + (setf (fill-pointer *text-variable-locations*) 0) + (setf (fill-pointer *call-backs*) 0) + + (setq *tk-connection* (si::accept-socket-connection tk-socket )) + (if (eql pid -1) + (si::SET-SIGIO-FOR-FD (car (car *tk-connection*)))) + (setf *sigusr1* nil) + (tk-do (tk-conc "source " si::*lib-directory* "gcl-tk/gcl.tcl")) + ))) + + + +(defun children (win) + (let ((ans (list-string (winfo :children win)))) + (cond ((null ans) win) + (t (cons win (mapcar 'children ans)))))) + + +;; read nth item from a string in + + + +(defun nth-a (n string &optional (separator #\space) &aux (j 0) (i 0) + (lim (length string)) ans) + (declare (fixnum j n i lim)) + (while (< i lim) + (cond ((eql j n) + (setq ans (our-read-from-string string i)) + (setq i lim)) + ((eql (aref string i) separator) + (setq j (+ j 1)))) + (setq i (+ i 1))) + ans) + + + +(defun set-message-header(vec mtype body-length &aux (m (msg-index)) ) + (declare (fixnum mtype body-length m) + (string vec) ) + (setf (aref vec (pos magic1 *header*)) *magic1*) + (setf (aref vec (pos magic2 *header*)) *magic2*) +; (setf (aref vec (pos flag *header*)) (code-char (make-flag flags))) + (setf (aref vec (pos type *header*)) (code-char mtype)) + (push-number-string vec body-length (pos body-length *header*) 3) + (push-number-string vec m (pos msg-index *header*) 3) + (setf (msg-index) (the fixnum (+ m 1))) + m) + +(defun get-autoloads (&optional (lis (directory "*.lisp")) ( out "index.lsp") + &aux *paths* + ) + (declare (special *paths*)) + (with-open-file + (st out :direction :output) + (format st "~%(in-package ~s)" (package-name *package*)) + (dolist (v lis) (get-file-autoloads v st)) + (format st "~%(in-package ~s)" (package-name *package*)) + (format st "~2%~s" `(setq si::*load-path* (append ',*paths* si::*load-path*))) + + )) + + + +(defun get-file-autoloads (file &optional (out t) + &aux (eof '(nil)) + (*package* *package*) + saw-package + name ) + (declare (special *paths*)) + (setq name (pathname-name (pathname file))) + (with-open-file + (st file) + (if (boundp '*paths*) + (pushnew (namestring (make-pathname :directory + (pathname-directory + (truename st)))) + *paths* :test 'equal)) + (sloop for tem = (read st nil eof) + while (not (eq tem eof)) + do (cond ((and (consp tem) (eq (car tem) 'defun)) + (or saw-package + (format t "~%;;Warning:(in ~a) a defun not preceded by package declaration" file)) + (format out "~%(~s '~s '|~a|)" + 'si::autoload + (second tem) name)) + ((and (consp tem) (eq (car tem) 'in-package)) + (setq saw-package t) + (or (equal (find-package (second tem)) *package*) + (format out "~%~s" tem)) + (eval tem)) + )))) + +;; execute form return values as usual unless error +;; occurs in which case if symbol set-var is supplied, set it +;; to the tag, returning the tag. +(defmacro myerrorset (form &optional set-var) + `(let ((*break-enable* nil)(*debug-io* si::*null-io*) + (*error-output* si::*null-io*)) + (multiple-value-call 'error-set-help ',set-var + (si::error-set ,form)))) + +(defun error-set-help (var tag &rest l) + (cond (tag (if var (set var tag))) ;; got an error + (t (apply 'values l)))) + +;;; Local Variables: *** +;;; mode:lisp *** +;;; version-control:t *** +;;; comment-column:0 *** +;;; comment-start: ";;; " *** +;;; End: *** + + + + + diff --git a/gcl-tk/tktst.c b/gcl-tk/tktst.c new file mode 100755 index 0000000..745ef36 --- /dev/null +++ b/gcl-tk/tktst.c @@ -0,0 +1,231 @@ +/*-*-c++-*-*/ + +#include +#include +#include +#include + +Tcl_Interp *tcliMain; /* Main and only tcl interpreter instance */ + +static Tk_Window mainWindow; /* The main window for the application. If + * NULL then the application no longer + * exists. */ + +static int tty; /* Non-zero means standard input is a + * terminal-like device. Zero means it's + * a file. */ + +static int synchronize = 1; +static char *szname = "TCL/TK-Scheme"; +static char *szdisplay = NULL; /* "unix:0.0"; */ + +static Tcl_DString command; /* Used to assemble lines of terminal input + * into Tcl commands. */ +static int gotPartial = 0; /* Partial command in buffer. */ + +static char exitCmd[] = "exit"; +static char errorExitCmd[] = "destroy ."; + +extern int isatty _ANSI_ARGS_((int fd)); +/* +int __TclX_AppInit(Tcl_Interp *interp) { return TCL_OK; } +*/ +/* + *---------------------------------------------------------------------- + * + * StdinProc -- + * + * This procedure is invoked by the event dispatcher whenever + * standard input becomes readable. It grabs the next line of + * input characters, adds them to a command being assembled, and + * executes the command if it's complete. + * + * Results: + * None. + * + * Side effects: + * Could be almost arbitrary, depending on the command that's + * typed. + * + *---------------------------------------------------------------------- + */ + +static void +StdinProc(ClientData clientData, int mask) +{ +#define BUFFER_SIZE 4000 + char input[BUFFER_SIZE+1]; + char *cmd; + int code, count; + + count = read(fileno(stdin), input, BUFFER_SIZE); + if (count <= 0) { + if (!gotPartial) { + if (tty) { + Tcl_VarEval(tcliMain, "exit", (char *) NULL); + exit(1); + } + else { + Tk_DeleteFileHandler(0); + } + return; + } + else { + count = 0; + } + } + cmd = Tcl_DStringAppend(&command, input, count); + if (count != 0) { + if ((input[count-1] != '\n') && (input[count-1] != ';')) { + gotPartial = 1; + goto exitPoint; + } + if (!Tcl_CommandComplete(cmd)) { + gotPartial = 1; + goto exitPoint; + } + } + gotPartial = 0; + + /* + * Disable the stdin file handler; otherwise if the command + * re-enters the event loop we might process commands from + * stdin before the current command is finished. Among other + * things, this will trash the text of the command being evaluated. + */ + + Tk_CreateFileHandler(0, 0, StdinProc, (ClientData) 0); + code = Tcl_RecordAndEval(tcliMain, cmd, 0); + Tk_CreateFileHandler(0, TK_READABLE, StdinProc, (ClientData) 0); + if (tty) + TclX_PrintResult (tcliMain, code, cmd); + Tcl_DStringFree(&command); + + exitPoint: + if (tty) { + TclX_OutputPrompt (tcliMain, !gotPartial); + } +} + +/* + *---------------------------------------------------------------------- + * + * SignalProc -- + * + * Function called on a signal generating an error to clear the stdin + * buffer. + *---------------------------------------------------------------------- + */ +static void +SignalProc (int signalNum) +{ + tclGotErrorSignal = 0; + Tcl_DStringFree (&command); + gotPartial = 0; + if (tty) { + fputc ('\n', stdout); + TclX_OutputPrompt (tcliMain, !gotPartial); + } +} + +char *TclTkInit() +{ + tcliMain = Tcl_CreateInterp(); + + mainWindow = Tk_CreateMainWindow(tcliMain, szdisplay, szname, "Tk"); + if (mainWindow == NULL) + fprintf(stderr, "Unable to create mainWindow : %s\n", tcliMain->result); + + Tk_SetClass(mainWindow, "Tk"); + if (synchronize) + XSynchronize(Tk_Display(mainWindow), True); + + Tk_GeometryRequest(mainWindow, 200, 200); + /* + if (__TclX_AppInit(tcliMain) != TCL_OK) + TclX_ErrorExit (tcliMain, 255); + */ + Tcl_AppInit(tcliMain); + + return "."; +} + +void TclTkMainLoop() +{ + /* + * Set the "tcl_interactive" variable. + */ + tty = isatty(0); + Tcl_SetVar(tcliMain, "tcl_interactive", + tty ? "1" : "0", TCL_GLOBAL_ONLY); +/* + TclX_EvalRCFile (tcliMain); +*/ + /* + * Commands will come from standard input. Set up a handler + * to receive those characters and print a prompt if the input + * device is a terminal. + */ + tclErrorSignalProc = SignalProc; + Tk_CreateFileHandler(0, TK_READABLE, StdinProc, (ClientData) 0); + if (tty) + TclX_OutputPrompt (tcliMain, 1); + + Tk_MainLoop(); + Tcl_GlobalEval(tcliMain, exitCmd); + +} + +main() +{ + TclTkInit(); + TclTkMainLoop(); +} + +int +Tcl_AppInit(interp) + Tcl_Interp *interp; /* Interpreter for application. */ +{ + Tk_Window main; + + main = Tk_MainWindow(interp); + + /* + * Call the init procedures for included packages. Each call should + * look like this: + * + * if (Mod_Init(interp) == TCL_ERROR) { + * return TCL_ERROR; + * } + * + * where "Mod" is the name of the module. + */ + + if (Tcl_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + if (Tk_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + + if (TclX_Init(interp) == TCL_ERROR) + return TCL_ERROR; + + if (TkX_Init(interp) == TCL_ERROR) + return TCL_ERROR; + + /* + * Call Tcl_CreateCommand for application-specific commands, if + * they weren't already created by the init procedures called above. + */ + + /* + * Specify a user-specific startup file to invoke if the application + * is run interactively. Typically the startup file is "~/.apprc" + * where "app" is the name of the application. If this line is deleted + * then no user-specific startup file will be run under any conditions. + */ + + tcl_RcFileName = "~/.wishrc"; + return TCL_OK; +} diff --git a/gcl.ico b/gcl.ico new file mode 100644 index 0000000000000000000000000000000000000000..e7f6e515796060935a3b9f6d4aebb42097fbb6f5 GIT binary patch literal 23502 zcmeHO2UJzZ(;tf15KyuAuCc^kqhiGfQPHT0Vv8EF#aI9f1fLpIEMP_KV%K0pj7EtK z#V974*h`EiwisiHB8KeUZ)We^`|f+Z2k74<=X@ut`*wF`cIG#;161ULf}E+^&7!X~7D zR!PcZ8|#%D0#rpCs1m#|lUS? zDOo1(;E)i5P$c%^({;iLYGN9vQIf{1ZL^4Xm`ag-yoCm&sam}?dCs4yD%#2pFEo|O zn#AWtFTzA%_1T4})~Lk5Mhv=q@t03x`v zQ^JTpo4S*&kQ8Bp+9dx%?Zthuo#N{q8KR1(Q8Oha49lc2Ax6!lH1eCQ&ZcHc5*3}X zsdgt)N{TneK)SC|A~kWfg&i!|NnB{vn25@g6?-rj9(h>3ZfHr<*fC!={mh`w@C}$58FD&9sH!{3+6F3zOj1;dhO%E2+bWKU#a=8#!T@=JLXd#BWI+5Nsct)gH zBt*4P)V8g=N~2$G^$Ifv=Xh|CuexlJGs-NU7Rjdv`{oqUN*2>!~ii|Nj7HO7#;i~DtRnoys=4tx=6l`f#i;%u;%@BJ9!c_Hy zX*z;K)U8CLYYiH8&5E{Q+p7CdNJ_E>N~0%cb>R!@QWthiNh^M3+SLynEIHt{H)p7Gib6gz< z4ZeAM(#EVq+6+>pqSuE2-D>OG8G|{(K+>w@qFIfZk3*m4Z*IyO;gn-2X;k*KS{0HP zW|;euhGi0;(bmw^tI30X^?D{1o0|+0)mdVX`yc)9ihzu}<#`GZX_TDRLi{@5FJ(+4 z^A~`?LWRMCzBaycq1upC96j6ooz5_p4&X z;j2=mVNSIw5LK=`%&S=gVwyC8RZSYhnsQ}fbGdS`rutj3y;dzqC|@4-SF8xTYSn~o zwcmz>`t@ON!$z>XNmDrRPBZwbd2=|CGbbF&l?#rzxxwi?dEl&*Bb;}3hO_zH;4-#< z%$E-?xOu=S#Bd(-)xt&K8v61J`hC;c32tKl+c{m}0kz%S;ePJi@H^(G4i4}f^B*~K zz;n!hIy!=aGU-mv@Y2Nv6r!WwFHu%O`!CTBb9IHE3KoPrn198XDrkq5ED0woRDka) zSBB)ORp1Kxc)oEHc!0E(Exlk$yLK?s_dQsI<%%|KAf|0Qi0;@CB0lT|GyVNxPQQK- z^?rAV@$-X~AAA5?+qQ-ESl@yFElA&j^wlet!-nO{Vau|muzl%L*t2{o#Ky+Lw(Z;C zs|_1q$BrEkzk4_APDp?Q`}afQ*I&c2xsi|@6$vT3;vp&NC>%R>98MoQ1}9IRgwrXf z;p}&3;llazaO3P*xP0LPT)KD(u3o(g*Dqg&8#jK0pMU-t^Dl7w_HDR#=Pum2dk^m4 zy9bXRJ%%Swo`g6G5=`3VW5 z4LIsdv0|d=t_lVPwR4p&+kc9sf|1DYYL;m~#sWY>T==x|4IFbj6lw1||WuQD>v#WUIgRXcz?}ulO?qy0t zpOVF4fU6sX;5B@^k7U9&t3 zf~i;um|Ln8MB!O&KAx>MIOl+Mu6f}LJbQeJeRt=~4Lk8nvJTH5Yw_H%4s(3LLa-0x zu(Jf7yRgsPvSqSRJ8d7d4HlTUDaRW`6~_E3g##1Ybwe;%bO4WaLos)?(V>l_6TE^jhe)%D@Axry@Na=Z=E;PsF2mdO}+95|C7>5`0&^I$SDW5zbbr23IgfCu-LP z1s!gRPE?gnf8MTeD&X z#N*j)_3BlyX4Psum#u~Ev1?%S=8do|E)L?iZiOA&w!$8)@7TT*cJ0~;@$m_euqOfb z?~I27@$vBG-o3DI-#$p(e*h8_6X6Ke70+?seG6y5{SMBaISc2{;~DP4MYwqRB3#CN;X^#jJ%;DcpF`S)B$`z$qsED@eIvy#W=#8FKfH_qYs z)K-VoHW4VXgnleiKrP$)lj~P5KFAc*%EP-rw7Ek>L?K(sIsfAf(o@!NuHI?5gImrb zdXL!r&un#gpvEHo=$V*hKKVxK!Hr%sEdREf={#M|RIRgY-YtikJIvSBQ)O_;s->%5 zw`JvKUC&__qNa$|5vG9CPS<0ke`R0@b<(Cm=`GBJqEY5FyxhHycUm7JnT^eJS zZ*tNCNcz@rQ-sMoQJ1C4!HH)1Xdkx<_3!HJ?raq!^5 zy`(Xz11btODj;gAw?REsBZ4RP-;a!=ooEq_PPRgSBE#f~@IQ&-$$qMymG5sdZUE^$ zRI=fB1)bwRGTC^YFuCBGz;$}u>wU)O9nDk1)nMvt9 zFHO8mFizI2QiRFnn$Z5B;+(8xi67ljo&AY+t`*ig0;-Yrs~bYIfrZrPdB#&u_ZeWV z#%_CQMgK0t>~d`~><2}^zsY7r1nytEQ_CjE|A%5S?sT7upDsXI%nsrgzg2L?hE>`O z5cdV(?wQBKandrg$EH*q>PJaBtMMg>(CMp%IQi+M3OiSb6q8#C2 zR^`^pmHF`l`}u(-OZfR~>Y7)(S^n;ii?ipC(7UU7bKRaWDsdV~kA0hx0=xj$0bW)?a_A7xQbke&IViy(e&_J2;8*7W(rQ`n91` zCky-7O|)e^?xnq8Yu{-~eWYD>*v*YUw6aE9@cr@Q`7YG?!isnL3(FY1K$)OH11;?C z@8B);NAKEYVW04v`Vimu8RCD%)s6!!0--$xvsE&Qf_5{I=v)IL(YIL%*vE;g3qyB-T{MtNK7a|^E7Xjj*` znONc&#?gAVB}X)??ckN0w9k~q?1fqGGm~lKu}WP4{Qu2tjM=|kKZWykO_fS~-QYod zW>^@X6&A);jt%6=J$vwP%2nWdkpGM2n9F%B=7IIR$!41!baG~KOQP9*u{Dalf#xS= znrgBx+PkjbU~?j7vQzaMuv7pAV@4Q6#{E_yn=)tFc6C)Qqd)p-UbTfL)g<>P*~a%_ zgh5Z|QGRh?AUC0odum)>D;|m1*M#f(>)W?2^ec+GPfCNjXkU$k1wXJ)-&gY2X#eTcr~FfsiG?j+#)C?g5Z4MXaA4y-+<3Eso_wFDC%=(1 zr@mGx7IJ*Jg9Ce5v?z|lDj@(eLdDOr-u zE?k&J7AsEkLmwY~JRBW4$LriW#Pmt0PMp4DTefT&U$tgUw&IbRs@_o(PC0mYu+sUR z=6ZZj6)Zw_^|r-)!1E_BTUPKtMJ(jR)vH%Xm99@T4Ek-gN&d#;XZ+)GWqGWP@zwn` z$G`$lZ^ZY46l;l=pR7}9^v_m%(ekAX-$Zdv{$Ocq{%aV>E}MkwHMB-e7TmN68xR%6 z@LVOvkL*yQ@y0|LWX`}>CDmV)6Z|FR$_V{(evwVe)Fxbb-r%8hhPH~Yz4i}}AM+z0 z_2+y0^kcW5JfVIfkyTlzQnr^>!8>ZSVI6PT_M5jzcC*=EGWR8a!|)o-xwAO4@d2I% z8QqJ>B<;zz7AubDtxWCTMt(Tv8r7?@FZb<}-F5s#z_TLXjxi%YD2Hv_NaRfM68{v& z=YrNp`YUy4ZT6kJJ6jYR%WmJlFUE^-Qxb!XCFvRG_deNHc<$U{ENkb^#V%a`G0X8^ zx^1hFCtLQ$zr%^t$Y(qL3;s&v z&qj=RCgxDYQ>tJgix+dlnTsu``L^WI#nC2SDR2PK6Mv|_b|j~c!rSjQirWJ z`5`mO$vTzx+6$0(I!#;|#rR)9<00kC+q}MIN1v3jXHW7GzrZ(alh}KC;=@NQvTr{w zt_i9i*}^aNS=*EJtjfJjo6^0Y+!OWqW!29X|8?%Y{qde1&nEue-@v`Q)#HGFyh+a~ zYGdw?S$|G}f6HZ^Y{l+BntAR16S1K6LVJkJhV?`1j;=N0dZS@6(!_HKqFd{bdy*}l z)NkF#7Tp$2;-u23AL}|++B@*<$3FIOQ+m{@rMz3bIPuMoWhy&#U%aaoX93)X<@o`t;+jBh>~fdTPW(bz_$EAuF2Tmo6>F{sVjm@OPxxyUhN1CpO>VYd(v3k|2un=`j^fhCQGu2-y{)X}W z6X$JnH#en!=mh1k_8vjQAm%#WH0k*1{z)dIUy>$E$usJ?`r?Jsuv-r{P#puY?&N-A z#Ge^W@~D*lVyUmYG3ZxG)Zd^ze#Ov2t6$eLQ6XPlDN-VOJ zF_vv(Nj&R(6lpCnxAO1KXRchuA3c4pTKk)RPu#xEeQe;c#$~Tf{%F3lmR;Xx`|dsv zv8MP~W%59VRxfQ5HLg9Lkxn|jh7V=WUo-xMAAJ+^zqzxM;@zM=>o9sO5072VHXhik z9K3X1`R3=Jpzu|QB;9(v$AK&5INn<_><0tMt;D?J928<2UoV za-K7{z-)}Wtn2Zo=aL;d(DOD%K6D>ClwG)dS;k6~nqP*fo2vxN+%nfRxa{}eAE`Pt zmXxP%lyT=~6{?7D1t``c$2vN(rxmNnw!VI?=Rf%(XvWz(UXe#Qhf1GsmAd zuc9<-rYN)yP_{M20BstwO^nt!b&yv0jda3|nb)jRl}*sruZ){9meLO@v%-&j1@8|? zj^T3+e)7o^fnVB{F{4t_WND9Qi%#(vHz5dN0)Osg-aiSqEsW9!Yo5TX^&!mEUR0@) z;)(S|Uy64K7C3ETd0qTlwrpW3XU^~;TQ;*_wfJWjzlN33yS)b0tFs1vUHN+hK4x|O zd$TpW^?L)mYmxk*q|E_inPnffr{0&JdH$Tfj}q(Ch@a}#8F7m}h~8CIZrz5jJ${s? z;Qy3XBqs7$yeD41V8LtY`TE*bo}l59_%bWcpy4WM77a zvgEFQB5oYV5TDnx87o)W>Sj~FHhz5Vks}Ph$I5p6$D!=}gNHKRQ>1Px<@`oq)Q9zI z*+%Sd7$XI*)#BQ|2Zd=t-5t)F^d)p)6%Xre!@<-T^aNkV?lM9NPhd-vphM6dOu0njre8TSknAiS+F3Vf9@Q1&wlC|{yD!=yp-6x z#2mzLX4jyucl|o?%lM7R>!yx9dYE-)e-C0q(AS1Nd$OJrCbChB7qX#|^Z59P26OFF{8v>CP0K`$l^r|uN4Y+ce9wE_+2dvjo&5by+t4DYn2`LR?=VAu1)thN?**unDMzOyq)~|-06)RU!T&Kuy=HjB;eiggYHuZTUnZ75)zl|u2`gUKwOd-yY zZlOnw>NnurMSXVjChQtxC+n{g2Pw<(+t$q(&rcWP-+gFnR&zkK10v>%b0W&?>r2{` zrPL+cRNA6RzT_F#gt3pL+oBoQ3Sq+iU#Zlso4DQ~ZhfAw{ox$@sA?sBZD2nglhkk2 zMYbf}o?Xd*WB3aeWKC!-s<@Ruu?*d|o%JhRf*(@xX1Y%Qb^M6&a+4-X_wL=5L4}Ga wOVJm6A1>ldVT3dGDi6YI)6`HOC3aYf(oPw z{6Lf~`rStkuAZ(Q4z4e+iru~gl2+DwK)nU}ozDNh14IS<{yF}s!~Ur|^(P0i-`8l) z{3%iWEeV|eQ#u1Y_cxvR^W4Fof+k4V&JL(~4&=0du2B7RB|A0k-z%a(4Hf7KkpI^` z5`V7T`kz<+w0R7aL74JfZaW|Ic`w2Cjn6 z!hr1e7z6`+_$>WC=^70>eQ*zr|3_gre`{P<}A}iMtXY2i)P(c7HPg4C!0KvZ#HNb^5Cu!+Uoj!9G;IaR#qyn9w{;$gOASxOv z>Jv04PSVkyI!R4022?Up(_CW~IeAyt@&dQpD^XgO`0P?;9^Q+3->t;N-Cy^s(D5bc z@6PR6dq`aRP!__kn)uj8?MIHMB4S4xn*c^|6^tA@X~>y zop)GD-q*H~`p-L=KoHQu;{T?UcbC30oVa5? zi%%XTnc@kNBhRH%F9yNI#cL|JXF53)Q}f!btIF3Di`Xfk7s7Hqs|wl|uJ`@C)&8RI zaIB5_YH#H>ILCRiQaf*-{81gMsFCZm|D1uh`o7a>z!NjvXYJIb#>}?Vdk)G7`a;evuL}>LH3RtD(oF?3H=J_~yPqD#<0>C_kC^N?mEtxS zdW)a0k}l$Kwm!N+qSM3P&KdHM&9cUpZyvY{_0@${*1!Ga zdMs-~K;lL0iE?w{sr(-N(pFCBZW-t%WCzg`DEHzpb#}q!YV^^Se}zV&(7`qb^V4(7V}5?t9UEaamV$2h~+D-pWkFa8oCw^SZ(sHXL zzP0MipyME(n*|nyZ68Nm6lO0wp$I-T(I&Gji*8n((e8vLdBx#9Hl4v{lIw^YDm0Q7 z@8x)a+)IvsGwi-wdZ(x{!}OeD(WZxX#={vms)<|3}Q zMUp1Y&po2sZSSA+VBepnfF9L%xym-Q?zr)7%O=eGD9lc{uQnDLSyKggN>ww%5_+8> zYpzBzWbLG-8fEo6?s&I0AIM`0=pIaJ+pYV#Ezhm}AiMN*hq$)|`(I@$q}=OkmW?QV z`;cO@$DYtg#E`YeDr*0MY>0Klr!eGV?MkU{ys(>a>2fERc5!K&cE&=@jvJ&ATjTF~ zJXpH5%GTw0?W>(3c-Q%M<$HiBzY2@U-$wlM4fXT0AqgeQQb2}aVbUaneu=kFBWjNI zi>$(EssN5hosobaSx1_f^@&kH_VZTy3G3_DsG!fjw*t_GYgL1!i68;kD3fBLky**d zts^OCjjmH3upUElY0$$}mW-@YWO}0hj>qTnph|JpD?x&6>ppexho45g<*VI2YHYjJ z_2)&S-Co_$hDU{+-=~1m!?XQpR9{vD10AiHW9?m+Z>4dtWz<;gWpt2H)b{We+kRhL z<^dwX9J`6y&zgPT$ptXrZT8%_)8`+S&MnrWK0O}mH#N;K-m`9eIRg9TVg$YM6O++& z>xK%8b%Lrg?Na`lCULgr;+Lezp-OW7N)=B@P*@JW>49q==-1Tlq^Jc6*{@3hJu$8p zKZ|*XKK<;d-ZzZwdYF-uY`xXhQAq(k?A-FmZ)sRRQaa~tItEQoo6c!D;e#e!^tdjM zYF-rCfwRTHXOMY*kTzs(g?~Ou?=X}4qkqpO`TOg&P2;|8C9&3K9Fd@PIYNr}rH71K zYx!b|BMXnd7tQ7(r>&uxDRNk6)J*kL)L!_(E0W$+*G)C)*q0YApSCq*$Kbj0roVn2 zCCLTJQ9!>apzogpk`_HYo@!iCzeBp=NG&`CKS;H`c4cN(V146Ox!c)yc(U`_7+a=b z2^eA7xJm(OsQSA=_7G#Eun{A*1EUQ?Ba@bca*@-C9 zhL_-{{>UvzaScMeTbwCM=fE*#ob0WQa7kDQums|YZr*7)X7z5T9D?$+mk5L4sn+gAhNmGvk!e4WpO z4_`Li_r_q!&Qugok$#{n@5cnT52w#_>Sg2oAUl?THn=p;VLI}tJ2^Pwlm4)*?TBQW z`)V0__2;-X=K{4)Wr_Dnz>|^_XIeyfUTUP@r1bA7e)WV*W?q`&Pbu3qeIYh2r&c_i zo`V%S(xZTmTNhG&acm|Gt=)xVcRn64mi;MWd31ac1mRx0UPt8tYQ?Jsf;=-DW!g`|MYy2c2;%S@D5b>tDxyU;2(b(+v6V56$y+|9oTk5-5 zF6qu?>Z2UO?A$Hs;xXYAnaP>6Q_p?-KW+=Z#Js?)+&nhpCQMxkc;E$HVe}y<+LI)v zM-Q|rk^QB`SZCKYPN~ z&1YN>9LQ%FROWS;tnavSCUo2sU6|WPFTpz?8+kA1OS}U;Yr+#4r#_h8UA#k7GS8=g z#K#FSgx40>2gq8*U!N(UpQk9GcaURya-HdxZ@tk_ug2w15QX9w>&DIn!Qw%+3bW(+ z072&FC4<62!*nv13nXI~R~m7~u&A6CG>ajJoKRLkn*4}$QtTBP>&x?V(XbNIj@~gk zRG%_%@EGy4kT-ul_y6UAGXB>#`D;PY{jnsds6dqe4;WhsfUAEo_KANJHE>2v1LOcE zr1_mr(w_X2Xld!_PSMfPo<4o%41mS|Gf`1fQ=gaD^)Eu6#z>AC&rcrF!l$4OuGLLu|YH^sZY>Sf&RhR0ImPM_CGQ9 z34k;JW7E=61K9}=suR>qG@z3J$iAyfd%+R_*({>**>o5GV%#~gOIEwQ?yvXwRK)cY zK9pH|{E$!;NX#jhWPNPo**q|Ria+G^88-INBsKNi3d2Ez>l~N`>~EZH>-8r2FV_A) zKy7JFV+Y@ecLmk$W2?tEWVB2i{UTEfYdXf)aDuY;o;dlxP5V^)b7CF;7n4(;1csBA z<`gxx%fDv9-IKZi#k6j(;zhGdcUivo&+#Z<)U$Hm6XO+Ed3`BCpYMZp*$+C80f~9l z5Z1?ufCa+F&M&FPAzFKDU|yMW^>xC6}l#8ryJ5e`>ySWzQhbYp>N1zp?PPZq$O)V5atX zK6&19;Vo+rl{L&@wW{?Fug760#_$mN2 z;QNm2INLXl>-f{|xB35iZHW-AU`4x#LEc^9HN#xeMGd+OZ>!en4PLsvMbTFO*KKtd zVU)iAmFOqD^ai(w4qT)(%BqJdgOn$=2TNEphe=a~G$N>|j%xfjGV4^In-#=Ol0ED(7dmz%Dy!aY%P$0-Q+a~(pPKp@pto!oHvMYP(`4sX(1kMCFP%yJE}xJJz0T9{P(ZP9>Vw(ByU5lQ5HgM#qqYR;Jo6q> z+b~?oaRFQP`hpJba$0@k5KIi*MSg{!IZ~m3Krtx&qGM(7PA+VwJ_G=c$k$Ns8N{V0 z7ReQ%5~nQ7YLZ(6QqtCj;>iU#I~LN%p)6&dUog`_M*uSjjJ+e*EF&9rsY%gP1mhSq zafOk%C_can@2d6s)W>-5*6lu2?@`3c-cQB~j&h>P;*})Gue+O@YMlCtxX%6a;Q$Pt zpnx(WD4@cxz2rG>$bklUiDZurZwFvvqT1#TKDuei1^`itqht>R7C)u2;WVK}0nrw* z?~jFxJn3)X;hGh+$=PBk_M-dMk04Vw_V%o^^K7S*B)cn+xMRrj$GWQ{frU#YdVKjj zFA&}dUv>nG_^&`lzIs_#tt&rDxt4tL=T}?W<5MV^6B4vlNJBl?6 zC%r-ohYy1@J`i|1n$of!V7D_QEUx>-_L`TmFjtn7G2H$_rBduXuJ(^Sff8s>!F23O38(I8~J%n`?&Rjq2uyv!+Q1?*PFJi3XYf0&9ZPO7rjOO z!|oMd*ovsJ$Ys|!n6S&6+04M{kGL077sKQxL$y9$rhvRo@oUL~%ko9A>!r_F6OW0j-s zzVpydpLifI87xYmn`|1xyV}9N=~NzouBh(KT^U6SCj~(^XXTxnuzM)T({c(Zi~Q{*$op>r@6x(1?AuidRN!>_K?;X3{YeLajac7@AGhW6Qb3=07@J!Bk|`kK zit7q#1)`$Y@7eP>f4E|7GDdcA)X|@?%-ir`I7^i=e8cA$_Dg1ys93OwXtXD-zSV=R zNCLETGm<2}!j8_A0y&g&w)DG(U z8KKv=75(=Ut_n<=(Xq(H`j}K6|@vnHBdN{oYBK&1%3ULw4t3^9kzTlQp5_&A z#OA}QTu5S!Bo=G3B`!P{SjHDiD4?Wb*qY6US?peu02dM= z+Xvv&I@lTJrBoV+@a|{44s3mN%)fu*Q6O1=eEF)$R7elZ<9i@IflghQ2gXH1G!x70* zcV4)tXm8(+BcdGp_9Os`6W7)7-(U9~XkBo!aNFz?-njWw}OP`;XYUWwK;VrQg) zXx_l}p@d+PhSdr+x>h$|u=V+J~OJX~BJr&!n}1{V;7#NLetXtCj6o>f>ud{bQ8tRkND zu%ni8>TQPOGfn|ARMxajadi(YjaaTiLd0QrAYzr&g?<~|K4i;xGQPJ~5@RZ8MhQ_4 z$E~auW4ak%bBqv=TzMl2jZcw&o38eCkkY+le|eEM**FCa{D9PrK&@vo(c8bZ^S{cv z81WP8h82#lOb>$nOlxh6`DD5&@T%a-O?}P+r_W*OMJGfzIilYQpriY}8cN3S4~M^b z;)|_$8CCj@LV5(cUXYxK(SQ;NuORmIMVS{raZMBdQdqJUpZE2OFkKgTaey`DP3M6PI> ziHctZCqvRLuz;9Jo$*T8c!1#$UK&N@E^+9*_~Bys7&Q^_;l^q4l53AT2h;7Z6(5F6 znw8>t4vF|cMc004H|(2Fxtu(GTJLUj1Nyo3Gftj5+VzZ0Pbqbsiqa4Yk zL64fo+T`Ulbw~w9MhHEX(f3nby`v1@!^yU*q{69cB?CBpO~t1Rmy_=8JuB$35;Qf^pdRHLsdFxvf zdp4z~xk}XanZYm#NUEZHE%68TD4n?F(_xFfUE~qK`C#O_S#J(&P)@WUqh*%qryh@` z6cwWSY(0UlY+>A=URD#+N(J_#9)gON?^(*kZe;>&ZCF*6wmpB=)S+vXRaEGaYJV3%T6LRiBq(TO)ns~dCM^xiSngOm$fbo_7z|I8b4^s`^`P= z9;`Ltl54(#idOKmR!-~pzs-%+C$BVVKrCgg;yCiI5{E8+&%nchQynD=7Y=`rpM2 zvMH`@qrLIvfEU5!QO_r8Z<1$v)phKGc}98sr6K6FD1yKSN4&s2_z%TQASHvCVzqW)lmf@)_HdIthM)k5%(@EZ0saB=a;M@ z<_+{aFY%>(7r1(-R1GtEJdf(#!F9lJ-3nqD`~#JC3Md(4y3yzzmDyN?`eO3jvye)# zy{J0N>*}!1x9}}@`9ztX;jOV>^}baI{XS^bJ_j(|_Xa%&jhzdomaea{O;OjE z)Ct(1iBbts3zPQTJ&)$njd%~aq9ZoU|8pw;9}DQ;p+kLytZ+7oz96Ddol61fVI-!{ z35Nyfxwm_lD!I5m#0s>$>4_TOazrD3K?_&P&?DLba*8Ny z<^oh#6dLar&^@n=Y#@46LCvpiO>otgg&yPQo~aB939G)Xo3p~DlRdPtr*Hz8o95+! z-(^^SM;vNVnl0aO^KFN>gH(1^OkY-Oc&GSuUE!{0E`$5z0SW#Q_ARFrmK5N_nR}a! zsy%3L0=(G{IYGSMs{sA+w*(1N2MvTt z6L&sqT*WjYqPQT8KVE#Ujx%Ht7^^upI!yHnDx7fZS8245BMEfw1oT=eg!gXU&Z`Q` zqVY|nfc&^{;3V~x_mES>l@%Q^@-rM<7i*t>;80CZ-MVcjXQRPU{S3^d?gCYz z)1F0AXw%e0My=QW)zn*j23JfYd3M<8)6S`jxQ7NGNv)EKH)EcLx;d3CztENz=TaopVvO8yV~nXKtY9y`nTq&@SJfz=XMc}tz{wX&Z=Iwu0kehZ0yb1B?ACay zL;_baCYyBMo36(WcJ)|H20d}*5Bu)J_#WUDPjAx>n0(~?^Gt2-{QZbdfdVIQ9kwMw$*GiFUKOj z>1W_u4GXF_1r43rbg$>0nW&o4UK0Gr_hLaA`ggG`!ZKm$WOHINhX3Qr70;;1LDJ>B z{mHL8VS&HiWvh%mH<>`5dF}9ks(IAeGPlKEICw``Ycs!G7VaR?KQK4ukx{EmodKVs zGdVB0Ob(RCt)N7qHaL_K7LhJI`Dmmv(yxoe6G_|O%@23Q5ghq!atyiFkJ)D@f+6pr;L1~g2Odcz226wt}lXGs;L6q-dz znTLDeA#f|ndTpEea#;aS*vb8^tC|v+!oiEu37#|63T$1puP)0v95{hUS+x<&A@qI7Wm}>;lM67^ZcU0}8Da-2 ze-@=tuHH{aPS{0kY{f>qt+=PUJEVbPdd+g8TkZ8 z%^%fS#Xml_NsDT0S`mV+@bD2UF%!58KUrrGS%KXz9!&2)*jw{vG!P8~+c{Pl6AFqp zeU0u;W)|XneP1fp1ce-AA;<8u#Ip*aS4sv9 z545HdGj1OI1*k@7&O})>Gdr(`n%YGH0XS!wraE_r+kt<*?0voNH0ARVWm@m41HP*x#5cOW4tM}KhP2u<%n)b5>xq|<>)$pN zuuamT__Nx+hp$JZNk86_NFJ~#jqvmPN{r!af#DSjAGZ_&BZr(sAL7}$z@ciYfhQcV zgeJZfb*C%f&Jm?oeRE}6QGT%X_Vo)FX3nultRxIzB%OU*8(IaUKfKimp~AO09!y7u z%WDNQArQh5LEv%MV}V12t!=c#g_OW6sxe&*$M<)tuv#K(RZ@tl$!sD%eNF9XOs0dv|s_t_^VV zeFBl$*UU0+-;xv~F&#lJ1lR{#Zk5<5WiQ;Pfb!xIYm*%ZqX`mriV;h5so$4)!TJsp z2cOgP%$yL|2qDi6zuPE*7m+O2&Bh2PX%=oosJ3HHf6vbfENzW`ny0F?!`laznnPt0 z`~6m2rErMuQR184ca@i;R$^j;B+`^S*c4Ay=x&O2da=hoPe>(mYahX_y`RfTsfBAZ z7-zE)R$o8`Ja(*b+GW3`@Hb|q%ZXn))c>I8 z@>tT=V-}2U<{dKc&ev!)I!mh*^88WZf2sT7e`M1z!Z(ha9AMulpz%`ya^v&N)aVYq z_CUPK^jVac`#P>u!qxMSjxw~*SzEJ<@{t|cYPHrUZ_piQY{^|N3p+2m$W`7BlR6~z zb~Wv4Q$Vk2>NI#OIAjd7`17xk4OKo;KzBUJZnJLpU-S8mdCBxO%63*Xu&> z*e8L1>Ii_R4-S8{%_QghaelFwhO(9N#S6zPg12Gx;;{l97y#i*`SpMP{4s4oXK=G? z;IiimZ^9`Y7vxMEYd+4T6>!IPVdACE3-=yC9)OR<5A8VbM4%D8Eoy1e)?SUvM!k4J zce1KNaLF?2RtMP8GF0uj9J1b35AFIE7nwP4+Yx~b+}|~;-b|O7B(b&E8f|si-%f*?nkat zOMNMi(us}IsBt5V!xjt}EZz2zpiX}pNH}q0ATFYYgGxH8vv%{F=$esWeohB_j81z4 zt=;_Q^h1k$_T#Oi!7gXg*UbkPk86v)WmWf(Nz(AK2(BkXMucDSzHc#*u-Vw>ZUJ%y zh#^(zEV_ICfCAdJ-HevJqr$Jh%>?h!h$6j}ob0^z?zD|J*O?O((9?0NL)Y{8Wt}?L zkv)GPIxp#5=8`wq3_gfVB}mhanO82w$WIELZ_CwSqq;jQOV4HWr@>nEebMLOe}i#i>+XOHiH*<_yO-I|TYhAaEaXUK!K}lYcb2 zuD32WQ^)2QzT1tqTqBxk3MBcEESy)syZT$mMRIEfcaUFim;&050xG3}Ww382Qu(pI zz|A!AvGzgl4|d7}oPDW`0B*0fr2$SgCA1Et5Vxe&(|rL2KIpED-Vu9xa>A8tJTXk3t6z1!CgK7=8+<*vcX%wYf>}uey>NxTRX|k2%vy zRX~^hqIq>Aedb4>FD_7v@ji6$cy!A=abL7}{QG5(SjfDhx&`3%m5yn? z^X7>?`xHb-Y?@KSF;$Uc^enSEb_p(+svv5;yY=Rk@O$}&#s1cttaERQ5had|kCcjx z(bI1tg+l!d?=(%r>sU;|L-j@MhNLk<>4W+lb4)^(Cw%u?J8PU%=ym?HE{{VH~a(q+U%aes$=OskGw{RSnPNUL9Jv@G+I|q19{M7zX3%8V>Me2N$l&a z5JexQ9>RTF7zsGnWgh0^BN_Dg^dCLd?it|5k)8*>JZyP*rFSsXr+k6~4!>>hK&VCb z5qAJI19pnNpHsGryzgWpztnRF*lpksPrYLG^Z75w43|+^pC2=+?;Re934DJt2#geN z33VN@-vMv_da2BOD;szHq7KkG$5)B{C4ng!8bIg8(UIXe6h`|emqUHUP$h}>mfns| zazxJjIZc{ zS;vfO3~>8aWO58Xh(7bO@)b7=1@w&81Wqd-pnNspjkIjf@bHGtr5qs)culi&hi@V4 z8Rpf=HP*Ql>EQYw*q=IG-5)K82Aomn4io&> z+QTtpW*jxyy|)X91q5RAaC)a@p5T;QRoBMMX5OSdMD9I`2;f*@+TzNAOSj1=1?9tP zkp)0hNn~s`d9!eRQQ=AC7U{kZ6S)(<8Ca5m-MsxLX7+Huy^$+uY74_YL6FP;^~0UZ z9rBFym52sL{oxp~*Rfga!rJ#M6c8#Q7dEyVgnEcM$d|eBVnLP_9knjZ)2gZ+=Y~uD#%{B2+i3n^6Kc;drIkb$j9* zEnUIB=LT$g;=TSu-uLvAK_AeKesBk;*nIgiPXSjSjcu4s0Ifp!xUXlhf6nF9osL_} z&;Z7()E(vL)_&WPK2NVc;k(9U|BO8-Nij+HhiuFg5S#H|$vK23Iet;U;!o(6ns0h8 z=WkXykyaaoS(o7gi$A84V-@^?Ym#T@qq_)NyAX7(G=1PNh>0Cm~Bw@=02 zxMvV360u?^(-|g@uTMaeJ?swKuUm9FYvjk~E|6QXSrm{O5cJXqL&gYn#COFIOsX)> z5Hg=iV}V7=W++GDENlR|=)rho5zLJPz7-qL${msnm7M4l#kbO`)t5{owJJ`j+z zf-Sbp0b|tx`w2A2f(CZ_tcatwH##xf{Wk#uSRseP|J7^@1=R7j8F2F^0RBa5@{QOj zSda146thlTNlFujyh65l2862sH1@k&NSuf-Y)RAtQw(dp3R!i?FM)jQ+bWAEsoI`_vI z0^{3c5;o+VD@6{?qX6?|FqW6l3n+{Xhd`6eif2h`EC!(KhwN*-IBH@Q4$} z39F;1?~xH5xx+i|FO1kPznR}`hC#D5!ZG0p8N4cbZt|>&Z~?Js>E$I^pujt%JzW92 z{XsAg4CqypTv^eRVA|`ImrE|5L55tcLOPp2HDV+*HD6My4|swJj;q?PB|Nh`+q)eY z&EC5maQw{HWfI3Y53V7Kc+T$dqaRT_)TMG&cuTNn1ZCH z%Yvxpta72WfXJy-E+tcMgifMC8k<{G#v%{XjEzIk$K&v2)EzTFR9Ed$sw>^)OmA|) zI8TYPe~f&(QtdODT;XZTk!|; z2FoViO$eo5Npmn#Kd%t zV*l{cunoRUvvb zX=QybboOfWBl<^0|JY$;MgQ!Q2~4GcWU_IgGb+TlSWd}uylhpbnS4!tU+mM{%@X7J zPl8N%pBxH_=}e{}>9hq`gmrq6P{ppr?!7Je;!Mj=DK<-&?Ef5(JBQJJ4H=Hbpm@0H zaPTNBB53#@znU2^D9{q<{k1-v6tMU^pIp8ki(Q}J(5KODEOieux!5p>U`$x~=xv9@ z;C+>_MT*#_O(_52%2!x2!Ctq3cCNLVab0EL6uHtZ&_c=4KjVdAs9gZCZR94|!?ib$ z@fJ?MUD8AEf!*AJiy6z#L4d{dw_g|CZS(ET>PMrQ8yo#d96 zzY|u-I!J!nKgKQfhEHAsb( zSHYv&O!+w=ag5x$#79tB*xT*0? zkI9@ofLq1{xps-TXjZr4OH8v+_7i(3v=^wz&i@;rPuS8x7{ksF3k)?rE&ml+bvMCD z_*_I(g&UvTwvt zGhU3HV%j9*S_wK?7!~l#CgdRm@cn#~DkCaf$}v{Q@n3}$QQ0rslUsp_Z{Cjm3wXq< zH@epjBXsxe%{E6kLNPvRI9I$yX49{6Kn%wyMqkOkAhr`f2X9ve{7C+aA4O+jxn4(vz#*9r+zbaU8kvFlAUOsKLy>AM!2wCl9FY_qASyt$On9PiFl9hiz4DS{$=^8!gIF zpM)Elw!?byu(4D15DDS;e@&kFwRk<=J&$%0WE_b9TRq#YDBVe+fD|okAw00}DwPn0 z$r>doP9D;Q3(lMb)#m)OmtLz@MFQ zh~32sFE8aMmhi3QLoJMN)qgtocy^Yiy4rHmfyAPCQm6f8R{wh71Et_4s>96QRVc7E zCm3x7)hXlq6nEgn2U}KN09Qp5A_Ao{2pijf7)M9E8p`l^M&+1(t08Of*q6Rn2K>bZ zKZ^iBcJm}8eam>wDoC2gVx{M!@S!~Q%-KO=gJX~8;kMZOz=*~i%mA}r#cqTIompU#EStl%z;X~rs2bpCOUYe643S==It35q)|t>At4IB& zfA`PyqXPrwj8rvOYnlN<``Of0g`dee@QgswSUYu<(O> z5zJx7>gbC^#I>D{2VeuFbgdzhLu8Uopd`aGoU^(EaWia>%SZ6o6bm4j9x1ZlD}9`O zG1bC%$a4K0EWr!5Zi`2eAF`GMCRQqZ8K!6EhC7REb~s%_Y#O$tM)B(4iolDR7Wh;h zVg?uBZ%nF(iQ(UEtt=sso(Db+n1-#gw$t7(--Bcm_ns*vf4ZDuo1xISc_W@}{g>7e zIqz)R(dWNT0dY(KNzXK@C-$2P`yt^0QLOmTRp-D~aqb8(KPe!<66zT*4=JDbGuH|# z4F}w!?*hEv6t-_8nKm-@f6*w0VH$SBF4d$~x6-%>6$c2ONo@Mk(ynTgkv_OQUa6o=(5sfH9=gp}lQB~1_q5IxE3=f!Z_mTil@2``aLmbTroV%?WMbNm zcpuU(!|2Y8*fNbL5(yLcQn%zRgSL->6NVy(ld1hg8KFr5qq7 z{9+HpNf+)`CSY~zT*qTYo?Kt=YJ2-h%I@m99;0+2H>Do+U=KODa_nK)2ae}V^Br*! zEq=&q2AloMh&jnR0MEGKhJA41%V2q&Pfr>GvE>y|cBp798dah=GkiTx<-nvR&Yh`X zagNGvaneYhAn<(sp`%T7M0w{sl-oFgS_24bnzx4A&-br<=L}<-@oJXQ+~GlUBwJjw zp;F0N-Qfmy!nGVs!qf+`JROqwT&vd)?C-`+-Un@ul$Ym}9>&vsbrGK#Y?tM=5j97PuYve3(B??GV?GT&*TM=yHmnW^Ze#HHp)gH>5r-c_&K-GlU z2mLJFnz^nH)8#>VTS1brJkNmGS$N3eG{AqRNGM>vX!L9J4_#=FfE_fs&;FHsy zH2r6G;}gZ_?$R|&>M*PE%r&W#vfrFe@;NiT_xMs1YK{D~&kHHyln^1_eWq>U(GdUS z-0KO+6qN>9!Hlr`A)NQ&SA`cBS1VE_{N_T~Y8K-nj@tVO+PFfjeX1~VZW%7(hkE?t zN%*^i%bE9fAAd2bNzN6_Jv4vJMJ-=0sh{GWx~v6}+Ii94XWi%M=2%LSUSNZJss%L| zlOHetR^Jn^TduFSg{*b_pmk^B?8u8T%;R`2)*Uwld?Oq9L5LLHsT1PccP=H^KJQnH zi1HoI;QYDR!O>oePo0Gw2R8BXfIDhBP(~sBXA0*GB)s{y*V4ggym-?#6igrI6d&ZX zq|I=HYdTCT7g6E3cT(-gcgTO@UOD_A44O=-mglI~)NMlU|@zr8qR0_Rv zRx-z1DHZa+u5-;YE0HQ_hvh;sq=n5!5qOzrJZBiEH7V5G>)q$QKj5*rT!ktpYAg;) z+-GQwOG&smK*kV5C?J|m=GHCRoT%e!8-+F|lB6P|KPD7ZZ|Z9|j-4l5X!rgQ_cvT( zxm2wbd0mb^QPj%*GQNVjV786Gj%{kLHnRR!7q{}>p`@Ed^FH3q@&Sa*c2FfBqD z4J>;Grgdkql@A$TKj|B?P}x^`I`Qk83(q-nG3AA33 zZju-4vZ%@YBi!ePY~DM(9xiy5C8O$b6<)fUrtBWC=(lcp%&!!pwhu`tdFA_c`%We6 zI8?2I({i$zpTh=^?ELa3783Vk#60FKuP*zQ*W5Sky~RQ2I(Pv`AQgYeUOw4Ffb4Dp z5j*g}`7IXBla(DR`xX+ zu+sh6%Z>!GMMglVSqQB@Sh?ZCn7UZ0F_O|j|FXEdMon+0_VvXGabD)@r>OfYRs_Pq z%+*Ey&^uf2R@=(2_q+L?P*sVTiq?HDMb~$&MvtvZ=0CUo-QG~p**A|`-oREp3=+V? zvHCi;w&(rIjrVKfj9ZQp>YqE_t-T|&gg@S07iC-nHxSClITs+-4$HE0XzVW#33aDS z<1cdm|QlRVBhAd9AiaJemq)C7h%3Yu($?53}mTafGLYtt?`~+ z%k>tI44JLj>j|1y?kYGaCSg2K*CVcm+~eGORkeg`Y3UyeA8S-iRtksF$2lafqi%OK zCIuXJNTfLO+(hqNwPIk)O~ggkC5`yTa%aEg>y_P3f`xti?o}S))SK<=LD%6CK6GQt zD5D9yi(;E$0I&=Hi^41*&v#|Fvc?Kkn9$J_5SNasb9;~;pdNVrn(j170rIYrvDIKkiS1Ww7U@3 z?!MFxN{V0tot@xum)WtIX3*j2)}Q^2jZrS(B2i(dA!68bIbofJbsjE+{S<@+!!>=_ zi!rjc?_w-QzlMw;^C+NhR^brYfnP!!Re}3P3jz&(5S>N9gkm#h?Ki6BMVKpLlZ&+p zlbO_dZxxF66pG(U;xckfxP;j00s+BLRqhwYH8Nl$pOemxd&r0L%6di`_#61JDxU3> z+O0#o-V9CEJjE~-?i8@%Iz}p_uWpk`dp9`)F~zJ9nS(-yyrC%mDjn)uipn<5Fa{03 z(~QeAdx&fMS;{1}#gs?=LF|2ssus3>Tn1+^Eqv7!@7VH3E(<3RU**Oa^(fku_6hw+ ziJrbklaPGzCcSc*=1hC;lFWhh7mX<1U^S2zW zCubjHph<^}5gi4WTh7fz9|2zoSmUO0h;lv6{N#6s9 z!0AtI^iKjt)!wvqOHYnuZz9XdhCoO$6Y|X4ho#;xCVX&b=QxPG(hT`kv-R$K#GzrD zc@2Cfo_L3B-)PZFy3!PR1Pxz4^wyan%ZyE8-J+)C8&IjrfkBSICOlw&2Cl1DQ7WxT z{1&l^rtJZw*+Ba!p#Rqxq?5veQ=k&CGC}a<0 z|WVgeSP087?KAzQ~PxDljN%L34_|V|D%&H4~M#Y|0k6eC8Q)7%hY7a)+)>- z3=)$))X0*^mL;;yh(gF%Lb6P?{o%kglKjIi* zLt&pLah;EE8SB)lK$Ls?oe$(_H*{z(TQp&xe&Y0Ey;3W_TrV3InBgwLTs?jgF*M%B4ibWT3WcMio z-Y$OlGu)3fPq|r~pQ|NSUUqvHSy{n{B#BCUS-hM*f(*)2()Jan@w)ekHm@LV@|`&I zj4zfYaW0SbEYJwDh1T)W|JENK7?eF#_IeVN7s+~??*7)_pTEtY0$*H%fQZLP&wz-9 zf};c`)>H3?n*w7mV(G)QuwaUxfXj^acKIA;Tn^0<2cl1}wU&DlPd#zm>WMsbFK`E1(N_um-G&)mM+k0EuW22%45e3UF@8RUoF9^| zc3#w24Y%>h4lq^^Hy5=KKNRptG?SW$3*Fy#cJw)ngJ46_fWORs$~!udvpQ-^DK))#9&IC;Pd* zws*33Pkjg7V1!DwAtzjF4feoQ_w8%q6N1!`TTiq~_iVOkPPPMnplwJ$6fN`tpxpi_0LnDF-dAsuCwzlMI;+j_%KH4d1 zdTk^L54mi-zj#+&#Fg-0$SwMI09z zZ$&8iY;w4gXVcyE(f<7DE+B`7V|QIBx%zueN%mV^NW-9mUe3|wTX9Qv>&3uzEu3v_ z?srRnls`}{?7$1_9l(!s2V*>Far?aWR7Ii-y8Vhy8R7JP>$y2e5!YM(d*j8H9;s}3 zdA`C^wA(Qvwo_EwZjBc_d`N7)dH=mmo^=_iWzCfF#YbynYAxTc-^=z#z)vOy{Wksn zB^p?QCc~GzZ`Rt#CPsFlnqWRF)<07*9h8)rPQLyl8?5>73~~if^DYp5wx5hTVo!=I z^S{W@gWZ{tT-Iy#PwC)$3dir+}g$B+YyEqxBvH)$v{_~G+pB6az>7+fr zx!#k*W&4Mezbce;rc2tdZLz+<(AJ543ZmVzJFS5b<$H~nWnFD~(a1`lPj!nY$s^aw zYmcReck`j%I^g<`Xou&Gh)g+;oJC|Vqv(5A5aa;6MSjtA)yss=SDx<0k;ZB<1~vJ;$1aV zCn4#*M-@?S==JGNss2nQt5)Cm08PP(XkSN?DXMRqkAX^s%DxcKQ4me6?!Xk+uW7Kj z5!5R!s&~Hnq|qJDgjpQPK99VW9j<#MhlwtlT%?9%7j6*}-sc~hRyZF#aP@C#`}<~> zv+-0GzwuOIAOqm6tkPuI@sy5;Mla}BQCh1kvogp-yDBG5o3V<`#1@^rn@tg6RN|le zEiy3g16wM=JMy+qE&UEL;bki#rA)pPCchMN`2`XA_HAaQq-?{+@Uht?9|-cUF#OYp z+`-++eoPm-bs3hbK8qfxvd4!<0RMuVBH}y3r0!UCu)ZxZJ2CvDm;C}yiwx5T&>B1=OXxly>yt@8P+!#)4}SO+OZ_Wdz+h<{6%L>%rmB6D*Cjv0t-q;OzwXV= z%)Y%c?}~MTA(2OLS4_U<9}eL>99=ATeDeN-har-ha1U~)(8T?!xZ$<;e65e8 zsGA&%4K&FPe8T&QF`XO|Gt=+n9^Q^iGeEDD<~TXb)yfJb zuM%w61!lh|^s91g5q}x6Jif^h#7owm#YuU?LZ^!6eruM0WJ}>#q;8t_epks#EkolZ zyC&86(O@X!-1{LPyjH{%$>7|Ga>_pLfu1Ta+1!Q;CNd`$c!tdS42CHYKWT?Zj%xUV z4D1r&6)W#UEr14uFj|j>mfq)zYeNDzt^q80Ifvk_ea2X14{X2ISi$jvZ5*Nv=OY?5 zuk^wNlVxcgU+mj7`=EW$W$2=8o?aK)+&ZNE(`o({oGjydN)|k2mL06lQO%q5%!pfJ zs@OOmrS>o<5h-CMjO1hYUFB7HVU{g73i3wRI)e4@Gz=cN+PRkUVO>3c;jXIWlWl>1 z_-|AU0506;w!>(bApLe_yg*_CC5fDKy{%Y_MKi}?lYgF*fA1wg?{3MaY~Lquf9axF z>od+JNYZ>vs?ANC!-lToyPTLUJ_tR2FXE|tsyvD6?YI>971SuOU4(xT)(sh}KA>f9e0%0(A zVTB?a!^oUULzVI5ItKYX%xIa1GMdN8M#=i;4a&t&94pT2mV&w; zihl@Qg?ess$egzP(L$W@mB{&lKm`m3oCfFE?K?$5aUB0B0=sqY0@h@Be^5P@0YAK` z%^dGZDbt0XcgS=t9LQHSZLn%b#ZBRn-l&&Z77 z`;nbM--S_5jp`fHta~B3K&W1>sjFu3q(2UIQT+6Tp@~E&@5A;!nHy+JYE!RD((R-b z*XJ$cTh3Ier8OO)>9kWI*&D^%`tek!S)Te9-7q0-znXY@kRqe8)LCEYuub##KJnL0 zPuwsrzRK@EWH$wyox8uvWYpR8*M0Q~zug{X{>)GH(Gu|EY6fxuapUl0BOygD9sZU^ zDHSY$0BoO1cg^!Tvy!_j03lZ72)}e%V;Unw6o6IxxwlCmP^&>|rTX@@;}^a@P>1ib zxuHjLaS4&0eHbD))&EjU(L90C(*E7D_VEw=%RY^lSBElVroN1wPLkTsYM0!ygE0Zy z(P8p1WWuRj*_*NbvXMfX{v*v;b(-WICYjj=9s(2EV8S4pacRz7?h@tN^xU4N9RDsZ z1@HV#j^p=xZ>bclcpcDR$PgInz*P3BaIttcGPAivE4Wm(7kH7VM;y)8)9PyW487~j zl*PJm$>MJ}NG~oroqqM)b*^;HfgnAVaQ4RS%+{R&xSx5XY8BS*+Ry^7#x!cibR)h( z#EyJ<3%R|2HdA6;r#dDbmE9OL!uM2wvT<2?Jh`ES)Aj}mAml04;~ zHatSKtCtbEz#H#V?D{jn81|^JT{eDEg?FZ98dtw{Za_QfB3z&jJyZ0|32hONv>r;| zC{dTcL0e7uBz2Vll$ao{NgV7U-*@@Fy_TN>>K;#$L$*8K;O}^O*-&xhP;l>o%p8=z zjjWw!)G0{X`5xw|Ik~yI@b>$;tboaP?&VSM=8NsufSI|!lK+s%yz5xYx#*0}8JbS( z)4sDE%XEaHBVmL9S< zd`;w=Zwq-{q?nWMF~Q^ zML|pf^F;?S_Vo1pBre58SKzRQLCsOSO%7om?AN)xH3S=3rdk_5l)3@b-$>oz=9d(Dm&eizZjV1aY>X@X)vA+RaJ zj@Ifi!16*6M97j#J`2zx$wI+weQyHg95I%<$+2e!+YVt*|IhNU6Eq)~kM&Y0OKNzu z2=x&`mt+@u(0HFg2kZxkyoD9mA`tjFzoy@F8^Z^x*g-&5i6bPC9zo**s> zZdDgEa|mX#l;x)V2ugBOxi^Ilf8%BM`Ow7ceeQNc?Rf#6>p(zmi}~_>#UThDYk$a7 z`+IANG+Gn61?^T>LbOzDlarnMg%Z*E=&D0osMbmhJ<>97 z&iC3k#y1i^EYBb1w_ddl(|U6-aR#k-#|nJQ-nTV}qhbXBY zy~$D6ITYD1u399&PTA-!%2n_)Fw&j_Z70;qXx`D<09*U;KsyLJK$T_I@eRV-0$)!R zOFS!PCxtYAnqEW1)sM5=ZS9x!CEIqTVeg`{c5gwa<}mzhcT>HAtWEN>%agUi2;11X zgq^#<<#J`(_N9vLD=Xs?ewkf&0k|5+h-x1LDl~VD?ES#?DQnoGl99Y<-+_Ac;Ub3A zJH#*8wO=g=Fp01!;8L+m@Izieu~EOS+XM5(5JUKC!HS-?(w_CVtF{%m@HS6=gb#*d z=(K@P$hJjzgHM-nJ(?bWc@(ulN6A0w(L@jtumvo7A&jYTd3Z-0J;4$+tS~$+WTXDDcvmC#x^oztCOmJaV&NW5QK&{54TDX z*r_WEN_z4V9OmpFV~)Az`AHqb{XW@$3ExWOha;*%rb`7j?=M{;>(B#d+Go9&qj$;e zw{(jQK5zTrM8|1v7o(4NT@fT+>T-Q7E&Wz|MhP~QO9AZ_H1R=Faf!fVVW|O&hB!(F2SZN-I@UZ zb0Xt2ny^<&XU_Y9KT}A+X-`Y?_-z)&wjx1)GNPYQ4e^mGvfReV}_>((rnLT&Bz1KNCCX=Xs`h zZb3gsiD7w?^%LSF<7hm2u5-PR+H_`g@*KD&0MX}q@L*!rRtzPm_XW{W^_?(r)ebbO zRCY;P26EU&8H^AOIp}v@5U&;`I#ozNzFI#UDR^(JKuOz>D0oTEm8-|aD0a|k*D_t< zShrtb-Q#tkqRh@DwwVVA8n7O%0@Gl_WZb~p(!yG2Dq8u{-4Lt8qmcuI1`i-NH#vCB zhFFJj8>@8Nih1fFcAn56Scwf|kH8Wts!*+jtb@fBy?8-elLBmwGH@+>aLLdqvOmb( zkw4YuqO-8^ehH3T;E?){lKgi$loKQB!6wYbmi9v%MW?i`6A1gow2Kp zSgPcjZP9;E=?a!2&t8fdtLUF82^aag_d_U1>1txM_hW593B8zxs}^(%Z4h(^zQ-Bc z!h88M&o_h$(P_6{Ij{1V79-_XyRr4rraz()^Vz_55h|<|!Vc>Kia`ig0Wds)wbl0Z zk_})ljJc!f`drBQcH`gRd2Vi`Mn-jNYSGWmrk$O$t*z)AAJj88{{H>@`uc`@ zdeXnX`S|#fiHYkP8}RP$ih+Ub>g)gi_vz^9V|h6<0000MbVXQnQ*UN;cVTj60B31t zGH`BZATlm8E;Tu~t{(sZAOJ~3K~#9!?R{-S;z+YL6M})nVAKdm1Ob<+FlIeeOl=`I-{uICTUud*p^alg@ zQ!c*@@H3@SDf-CQ))~CKz;_3w0sdxL7XDuDm)fuG_Dd-mpPcj4-{2$jb+Gud1KdQZ zT!!`G2mZlFfqx7J!y$+3pB}JZ0t&p)G-aB%%;71Q28ditj=#;n`F~5R<9`7xS_HW1 z6-PT7yKQUNf*+QJNLquz;49CyG61aC$pjWi)@bkUS~P}06TSlf`7y5A81%)DJl~hW z;#ko#@R*iW#xaD4-`(AvOxlyz*=#a_-{EfZ&*D|;4+xg>%L^f29+rWjj)$)R z-~?8jOjcI-!2Bcu^r*wNCyT!QKLZv{I~c-FK-^F|;AeSwJe&YXv&j&Ug0Xvketdj9 zS>4d5(1OoeT<9#EeK;AyWaZ;Yc{b^GCqRka?(xb3f0;jGBvcSDyYS!7 z&(E99YPH&Ic4^Fx#Up(PF2MvP)K0svuhx05w}{q&1!(%Jn7{e=`T1-h3cGxC#h7up z1ufs_{4auqlY%+#&lc0EZQDT*jfWa?2cU0(thI+PWl)9iZ~fks z7Ev}AfnPnGKes%G`RDU_r`oHYgH#Fz8N|;GTF-j1-yS)@yW8zF1#7;?TbYlu(+ikx zc>I33Z?$ItRKBj&R8_Cl+)&qbSq%7BJqsgLRaMip2I4heEEdaNr`S2~%;=HO1KW6} zQsgRuiR+h#uu!Qzng)5bu4r}DXSHk=rxxqfYRs2BO{q(O*St8I_lmvFya#eGrXQ4q zZ}ZY`_xn?c)i;Nx0sM**J^LKX0^$sJ>rlOaB16CG$uwwRKqn)Q}UExQ5-FLz?!{I zwJFdVyn)uo#SnuI@SfYRun9#|bx$=N$Cq#qjYcDS206k@GQ)aZlKi^sDUO|4+>b`{ z(W2O!<1=+*=32L~U|=C!0!QH$q^}N8$r59(i=gw_eLo_H=fS$Z!yL^6xbBy^(Gu9V z$oCAJ=JUgIzm{G)ffnMI*vgPYcsQe8vzM(=Yq5k!gRg>h6?FVpG3=MDa(gxfrqVo# z0T^ygmSGdV?8we4Sj1qu9_si|z!pfqX)AZ%x?hfPJIL`!!3{~|g4hN}ffj);GS&$3 zr|bi7CBw%7tjpl13k30C{+rhQeQUIAEl_(!EW*JmzvNim^)`m#s*dbw`J4Mo_^Soq z#jm2S=XCrhut1CK0>J}TS6R(*Lgq*+$b=*}R3F7dULPndMh%1r_KJV<)62`t`;w zed%=wQmBFi_-n)QOeSl!Aajzr%;hd~02eSB-aO$z`k6;w0Rp;DDcD4EwpDuIQoX;`H^pVfd!$ z=&lAUaF!J!?}j*J-)q3<4CLKR=H%q^p2Jm*H(fd|&4NbQFgAvakETfW)6LUUCX>mD zZ+0TR^-o}x`#IZJLemXFS2i5iG(8h_NexNfkh5zF9)@Xv{P_Ts35wY9Wi6OK-H7cV z39F>HN*j_soZFHTf<9!X>Y0Eu*bihVCip5^0t|>FNsTOsDDao-NKC=`Pck`>#wDo6 zh#CV3C3B6?l{PqEW`@BeAmP>C)z#I_Q-(hn!Tfcw${1#p+SaR`S3IX4TfNT?St(py zO{0e@c2GSW<3m|!Ht_rfytno=U+4Dj)9Wyx#?6(Oe_8C2B*Oe<3#3qL=$oJSnCG}k z;q3J6Y!C3_UqsfbqIKA=wEha#ZVAux+PMHIt~QwTRj`N$m z-8b+Z`#rnfs0)$)?EGp&vVlwD`6J#c@AiVa&x~zg$;`ffzP>(1xNZ=w(GpneAHV|2 zwENaHuehPfSg3v-EG0NSJ(~&|a!G{UfD?*Q!K7RQZKdd5N}esDYUhkK`2eAh$` zoPSd8PnqhHZe0gUHgq+A^t^NU{ETqn_rN|B=T+kPuYm>rRk>p~>XH+J9}Vi~i=z<& zYdv4%Q#~OK7e%ffCNI`59)McblqrtsIg!`-Sz2>@p#$Xm z31esH`5DoA%HU%m$A1~D_OLt(6vfHcUD%55epzRQo>q81 zz74;^Rh)AjE&nswc56ZI@2uMkG{>v66eot@WfhM0kB$H?d@Nus`WDFH*EtK+m15}N z!a4OiItyO~i+NgbM2`iEE9Ur_Wlhl81t(jRq>!9XVedW*7E^0!YII+w4K?(#+rTpO zKYstdMYwiA66ss5r2uR2HO>Ncr8k&osJ?@q^jE=x=XHZ0Kt)c(6G6n;#A^44ZD3xN z=^m?@&KJQ_Lr@YxjU5to+BZ>SVk@Su>Z$o)32*%8&z~O%7k{dM2Me$Q6Ier+-FHmw z%VOw-l3D-3pKFg;p0ifD*`HW|l_YzzABK+LEa&qIz9A|3AH*fVyGRXGTirQY4VIn| zHl-DQ{rZJy!IuuN{{<`%jh9mCb&5gq`a?M;{3lmZVP~cfF`}HU)xbN&z=oMFc#n0R zHQ1(;DurP!9Nz-ZA0k?yR$9y6yxE)#yX_uemD)T+b2^5*6a~tLOot4*1G*ZP@x#r} zhmOh|w{Ub6@$O{~BJ0lXwBf0)>80lf$L#Lm?het~KO(ShGAm$x$|)^bFBVuR38Ra( zMH;5TddMOSvSH z&^VNWU<{)Ge+Pj9VG0Dml3F+2O|Y0Do7(snpcQTA z5}Yki!KF^1Xl}|Sfp|*BLllQNs>U>p$N~fkff`$M5P=oo&WU$#p1`)v7mGl1O{VH8 zPLw@;TzPnSK-LmqaWU+C0W63U%DKE^Y#hBfsvA0f4P?Xwu?xlpSn%Qk7JayQD2#(p zl}r~fG}2(1vgrnQ_+&qkwLlI>qhfEiYuSq9=z3aV>tIeKU<#Mzi6RB02XkE$_$%%2 z$*RsAFNmliwqBezfDX);Q=d27{I_q92M-q1GK&g!8^D1EFHB>e2lGM~1 zMAWV(1>?#A9}ka}N|1Mfx6HJ2?CUkh%isO_aVrEdbJA)R!4{f2D2LSNYwq~q+hYX; zk%L9dj{XM46`$5wARZDb>NTt!S@K=fR4zjGPyw(iFi`q0Kmj}eT6hdB$(vw-o~aR7 zf{uGPCzs&HpHG=)cwos=dk53#HCTR(!cwUmR4PQ5$A@uV!vmr;Sj_c3zra-xft9&m z0=7%Wc6(Gnf3e1rLE9ptI13lu@9kaZs) z#5%ALa&Nc=tWXNgg4p~sgw#)$OIvZ7R0E=?IV(5-uns`M|M<2sD{NEaBkY0-nK#uA2q91QlIC z4MER_T>tcR(wd`k-*6V?8XiM~m`Hh`2uKQNDujx7_s^eS0YpZ4lYs|-3~$G9DHk|M zW8=F-4xcVF`E;1$IudZL$G!t+0S$YgUSQxb&eH}7yu`X-y!xZz%~@c)pRoW zg$g%iwBtMB0wP%WaG-wE&Z5j@)eFJaf<^&|zdhnIoFWv*!AiHpS`ruypo)hl{XiMl z!38U5-Go+rx-2N+7O+^&2;DIUi%ac_6n44F`WRT4diYYBs$hphXGPW{H7|h-K2~7! z6+v(0Dt^$hvvYX3^KAQdim*6m_T?PZJLzvBvAJM;# zM369!DDwP#T2K%ta_tKRaPZJKK0x-pxQKWcefU68)1JPLcXK{6);Cn|=p;w64%x!v zH!q~OfMvBI%n8jLOp~KnvGFkffzoZT>TPI(P{Z9lBA&Jfu9QYJ}&SFn3rVzVdasKSHOIv z#T-I$088RhxMB$j(; zo2Q$rtFyh+=jTIWuG?F%U)-&@P0nypMFa}C2kE1hh6^#|_XE`JU=Aa!Vv3wiuclXa z!M+B9?7#|y)~`E0_+cJDp4z(szhnzoA;gxh6iMN)#C>m#@YwznV1agjwWe-p*3zeU zphjJ%!Yve<5$*-hkt|&k;KlCA3H(5~KpJT?h!@a*KeCnx6&?Iu+F_m5JU@LrEV*9c zfZIWSD8N|-zK5)P1Jr=EuJ-l>TKm5VE+OX;u&_o3Y-ZXS^#Ccbh2KaDFIJ=wZ6U|% zqseS&GtWW0rxh=_Kfu1hHyWsQVVzqtY#gf0$t7kp++SWIU^g5s;I19i_2g8Lau$0A zLI$9*q%`Hh!-`g^&?*9}Yx){egy`{v^tdMO-AB0iAnyGM0Rk$;=~l2z=9ydyzok6V zdA0jFum*k5CEFJXYZ4a^&R9S8(T?!jtqfk)iID@mGEaiJz?ne2;O`w_1@_MH{`Vd) zz8Zd74Ds-(@J%pQq^`N-B1KLxivt%B^gwEmu-_t3`}0sFgotWN->KnoqKB6uB zz2=c(T=*HV`a@u>EKBPW@Bp*pco%o#;E0?6+yrL);ApiFu9FNGMdB_R&vf^DI^E-+ zZv~2{qeP@)Hl_v#BqY%)5mv;!uuKb=KzaaNr^H-8kHp||&UqblB1Ge<6IfIBJ(m~@ zDIWW;NnH3Du&f-&hNq^%GDD9u7FQ+QK=b4D6Q1C-#B4|yuo>J7G8f@RgRB@C%o{v^ zpE5f4avEu{r0<9ovTx)waf)z)-~!7LUqT2wXI_+YVqPKVS9t{_E`2)TGEW{KeCP8c zSSz-$J9{%XYb#joKruk#q%8_Q1YPp|TXYD7%iua3EWuZTvvQp92-exD7}v0cz3CNb zou}M=3w$iRM9{WeX$9ZD$E%1ViZg!Aj7dSo`Mg+M09-^6B1go%1G9iN{Gn+0@AL?xPa%vN`&__v6PGWzeHGc{k^82YAc+VI@yeA!k zznZ~>Al!G5&c^X1-NQpuzLNtX>f~NtW%va%ri)Tp1R%!I%3X4|P7L&l!Pw+3TSdDe zd#+SVU#_AQe&;mbW(z-7yHjfSt#WBvuRBg-OD>sNBT1(tp!ibYX_{~R<+j}qWh2XY z;@=H=Nnp{I(|ign=7MvQ^*vPY-%$!zt{yOMqpZ9tRgTPN-Db7gnG4Nzf^HWLbc#=M zWNj9K=7T?_r~F0cd$BE~)0yX$xN!1Ou!ikYsSJKYV>_RCHCjU~!o_2nvFkk9_HDGn zu)$hYfMb?q z3(aya@0ya_NC)Z?m-EV&xbU50zfG{(?NYxq%7YrAKdDWtq)Vbj#1Vg>Y~CxT{WBAY z>H0Q_3F`OUWiHUtrvboOB6Gs-BiZmrLQ}!|K)F)T#dsEDQ&H zPYb~L;r=K%q|2iNCuu@hC#x<{J1y1&TCR;JFhetaOP?@k-LfuF{t3FH}CYS=efM6%B*IX zTkJ?WE{qnK4BszT%OppB^~w1o$iL}PKr;+N{tUU)GoM~j3}j2@QLb?pZyiA&|`)d>_myKdsio?ZkPs(Ic`=c z-vf%;e#dvQ_e*|5MPMa`yMWe=iZheJOIw?}yAT(K;4FH2I`MWaz*@VhSPG9cW~{$} z^#c0cR?>;8z7smWso@&mzfo)(U(4CbS|;FD&rg2a7teWrP-FNDMNO2Oq&@eenX^7P6CZNo7G_HC|~zAsc>`@AD&#{v4*_GA5(QE z^vQbE#zWlQez#QaTh^dF>6d0@3t8>>c-HME1-w+d3!2BW8)2Hm!OqA`+!sctGuN>c zeh#dD$r^154|Fh$OvdA~Z<~kKQ^^n4D|WVkr8*5s34Y(+ievQCy;H!rrl$}6JP863 zI&X*qk>muk+MTr9gVONDdTp16<6oW zt8XVqZUbxB-<{UCfmJgdlhP>o)lp1xFlv(P|IKwUoCe77Z*ho;uB^>uwk2bTg;Gu8 z=MA*Viob{&t8BHcetCjbk1vzs0ak?1W|QOd1T2mf09nfA)2ZCzzEHR(7aJZa=FCq% z4wg0Sw{6!=Z5kpFli#y(`H0gfG7#6RwY37G?OrMKSRqae2G+7QC#(ADo9NK51&I_M z{ai`LL)RUYRB7-!osM3)!WvFyi2z3B;KO0x+U?s)I?F~j(2tV?9)?6jKTD*LQXD?m zUIn=OHPGDDCcs1?SmP)`XGIESv*x5yi_%wH5V_t(chSgNAcbBUEEy9{R$ZW`W+;2(i#R0&!Sa~7?N$fDijRO|DddN8ScGGB z(P?HiMakRK-0OK29IJViIu$f|?ffzIa{)x_Y1ap0sjNd`Is{V}t1H~&71;YX6)CW+ zJ_Mg?Z3|dN3>N3!L!PM+CF|}=1U=0pdWD9AP zi0qTWE}n_NlX#};Dk|VLs-8D{MP3TN(l=rPF`JaWL!dlV9l^jhAY`aw~7MBR_+AvqyVfyZKT;BeP-dI@h=x#$*-kd z2LLOS_(|+qW(zP5R&io8F1yZ{5%-OdRmt--h&rbyqY*f+bU0XT9+&MpxP^M!xd!Jr zSaD4@GT1%`RvW+y<+K<{7zzup)=o9ROyPl2>+ zSj;yFEN<4(5(pV7g4sJS4~M9?S*S*4#Fw*JOb{w{H?Z+;3G37Wu5+-3;IgH_(g9~} zoOVqjDcl5W8*-WC4y+7d`RPr72kCRL))vVTR`cbub${}7gIDPV&2wt0^CR6|_5FVy zo?%T>xaHd3H<^^)3TA(IcCjfG=IYh}WdW99WJ4^_&ofQ2>GBop)aRXZy!WihTXGx> z-xNo3$$g=4O_Dwnsm^V0a29}-RnrIjSpdt&1I%O_xJau-nxcqe_;ho1cKRH+K1o~LMXm>lwFa;}f6GmA4Ggh1PU&~_fo51ZhR61y%FM|34fSlu zvq>d8={2xiEP}f1xXu=^n74LD8VAuu-pt{6GTdy~HrVKG7lSo?0nRegVrY62fTc+B zMcdD)mIN592Xfc~*20T)TY<3NP`9429wd?LUZ4S3o}0e555qKASl9)o$^xt$Da<-i ze+CH9CCNtyV@lzSpDFSt2q(J9)KHbum$%IOzNxZq_!S!lJF}!&+a&J07d6J)1Z&W? zY{ixRw*unv_XG4RkCJVmhXY`VyUuB#nG#dY6;1)gWa=zpeeQJtSl}{lIVknO`Nbr* zm4glLFfN)Mtjpj0yvD$MhFCRtczu0FDHnKiRJ0o|We%sUtvDlnd|0dUKsyCdK=T|1 zzmuGFkKwl@Hcz_1BnsYw_%n3g1WOtpV6cNE!88r9A|vvimy1#E@^WeijnIG%7%K|Z zi!)upCyjjOD==2f+fwl$OQy#FtyTU7GqUWQThl<%)95xN7qH6PJ3Q|RAL=r9A84Ve zH~cN}JRO!DU_$dByiezqX;d71el9wBVo$!AWzCxBlQ`hyJ#*HPsKpDu zUEJM)&LRgslgp8x1%BzWxR~0Qu>!Ki8d}2kh6!O|IOYLHQuSeLAg(MOR)vxQ4&C?w zqe#w!z$_r_=Q$g6khkq@UjlY193^Q+nauqZ7*ulPY-)Z3qL6qLaJ<>8ZE7!gZ#*6o zOhj|qHP@j(Wm-C4DyBS^f#JzPl<|*#U}wIp-cN&k9n`F;g)7BipioVd)m$k$5)r;X zfCbvuOSe0bLSKfskBwm!o*aN#|E*=l#zH=yZOP*@K@fx6eV(hy(~|B%I!sAsX|St& zcr5?`4>CzaK~zH1m6>b0*=)8}tI41yY7ouV8>xnEp^^ z5Wz$jXm`oc{Y@T|7t>-Q`#$zE3K^xh2ZcfqF$1lve-KQ1> zdwWlqF3yROc2o{T^w;i3LCOXTS?G_aFX0I8h zs-dSSd>;keN|0}W_=Pn?cipV60#d%3m~7^FAu}W%xUSv_;g!F~QW{voV?r$R1^%kn z6<1L-SC!Cl@f=A__mfc3dl*xaGNs9jnhMSEnWVdEa8YJGQ)U#0BPgnhZNFm35_M1y zGWTF9TD<)jW}^s6T=BEY7UgEW1(pUhfz7xYo?yAO7ftgF!_6{mlw}ym-eCd)3r+AI zg72#*RNU#X6<<$RuF9sXt65#oVy89cOHP9^U)Hh0*~NxkDV+tx7>hzjI#r}(%0O|k zNK#8*68qRlK{BY(B1Qqc<(OVuJAp$F4x*=fOfsSLRnfSNH^p1!EUTOg8%&pokF~Eh zyU-2lF(ylXh{i2G5=rh%r+KgLe7Q{vcypMHsxc)TKV0zYDLSwQ6@PUYez~zwT==fL zhgkZ6=}S4$QH!nsR>A69!$~Jld>1vXnpVIc?%d()q3ed83%I)!89!E5i?*q7PT#^R zAMQB=-kho;R#-g!5P^l9b+s*(>62hNT5x(rX~IeWG0s{mV6}(kCRV~bhF+JXhWX{q zFg!X@RXoX}WUI%=ByEh&!4_cNRp-mZ2z?{O6p}HP{XZtfvBE24W zHjEu-bT}A;)ddZ2jRFl6Y$!L_*LS01+d>GaCCv@Syc#3AtwAdatbLMK)bPtaZ6pj0 zBp3Lqa)9ORcX3Yh-l6OLGgz)~pC&mh*o{dv7+M8u0&>^|)(WxSvGMiRPo{zTh&h@Y zDXjR6lmeLh+_DI(e7OOT;npCy&jVjoc)^Oe2-&$tDKz|l1}oS(5g!X(p_YG2k_j;EnpIR>CAg7iPulK5JS zsx28`ogXL(zA^SMIG~z*yu9UU0ate3`*O3(r2oW^BPsym{l{+N)^=-R*q@ZUyXSM* zhbz}YYzeRUDgU$ffRW#vTXBt zW9T-{gokeB+u z%UQsLDxPKOuoDJ>V}&{sJc<@IafU-Agy6NztHt7SnpYgzsmq3m9>4P@SSAdJ5lw7A zgHU1jf&(sst9-S0bBVokboFnEDsS2iGc;Mv3$P}g=KU#d-jmiCYhVqJXVuPP-nz8w z*lZq;xrGby4p^Q?&Bh@f(?I?}G#;pLOw>yxDp`(*wCG?qF@Uw4;?0G_8%~GmTi0ZM zPxWNF>h&ao>XG+)SjP&pfx&U8netbM$FKl$d~xv*#RShQY2RtECbMR>xEujmfvTz! z1hS6)H_n1BfZB1r8pt0YMeQy`lO5vc{nf^nbl%d)o_3FBB>YwGPB)7`({E!tmk&|`@{1%p+(*8PFAcyD0 zQ7)I6+WETX)_|ISRqzftRWjJWf&l3uZnBfKaX5_|t@h@#YPH!bE*AIq8K8;mxgPfS zW^aqROq~VEwW`F;y6)mOkfJf^J+|2Nj5n>^-xa*%nPKpa6Jo{LNg9x?<&*+iU92CX zyRB0@&=pT+cn13(SelEiO$r3kg=o-raktX(;xNGqgVOU!^?cTx0|Vcm08Ii3U%RlS zGh5Q6%yUC<+Yl)1>9W!*NEGE$#EId#Q}eQ47Q?JzFuVe&2+lf6GLnkC(7d!-Z^-4a z3HoG&=?iDq_Bb%L8b|9*iUrgN*zn3=p~8oUcUx-Wk3_sagdF z2G)XAP7m$EILPN&7Hc>?zKpA5^GKiiNmU+2!?9Svd9R>oc78aJn?~a>&KHZuc*`hk z8{Bz|q;Ms1WVUvmMPQ*lY=S~rq99V=1Z>IigO*F`cg14V>*?Vl#!0kIqs~pgjg3YCP(=<)VJn$fp_m*TZONIO!ZKStp+WyzrV_~DB*JumJVf$kyJeI z9PQuo&MOxWA0I-6#Qi(tWa({SO^%z$TFd)fhNs5xo*X}@UC~`UC&KiQw0eqxikWHy zs>}Guk>2NZOtAtou*gz!9F;&J!J zh#N6Qmg9M?b7=}JLMz$_mA3Omc?T1q(%s5p2}lAb(KjvX+;k`^bwq7G9XK{c!62d4 zLqUX{O@X&)mD`n7E`+TB&b_-x))4*1j^ZBf5mpElG8UimipvD=>hp`^6}4J=3#{k^ zQHPdi5uZgFNrO$Wurv*1q}rR4AR=#_M*VkaCx4RVqPaOte?)H+>Npb@HC<7MfgIlr z77U7aa9}Aak%ZJ1HfJCXJ`z2VXpLVRyWmU2Ov~G?h<7k7s2~hIIGB=iD{s7VOO03l zd}jQPY`zgX3Ear-_LW5s7+!C}dFt?4bXO1(*b?u;>55GC z0VVubIa-%bvv`}k7?75809IX5iirPhunsB)v`eg`0pXq5DLza$Jf^o9ht=^A1ncDCL?~*}4cV5pnHh{Gu!I zjy^&wo{vie_QARS)HsdSh_At_)gc!ppeM9M6DiRsWo41m^b*+j=RQ$ZP4ObuXu9eO`1H)59XEU%(R3(-^BQuM8HVh?<7C{)iUggrO0w!P}?Yb6OOWS3X8eE4;TR@fLq%Y(hw# z2tPG)(IRusS1WI6&Gg@RKQ$Uf>;%vgO*yEG$z{~`Wp(hzh`0bHfQgzTE`LdSbbq_N zPrAGb5AIO3O39^Hfh`D9a9Z@@w_~nks|)Xqw-F({RywbIaI{)t5z$gg8*y2wZaNexRK^8eyQ_Dl|pG<-Z=+1JJBK$Sr9ZD>s@Ae@?un7xbjl* z5|J1=mBYm+!;W{K8T1X_dZb6~r;bcJp zSIS+5_4hfy&A}6bs~X|8SaQVTAvS?oi*wO!Y{hTeaHuDuUsQ*Bh!k<-d@TMlqR&OW zM`#z5^>?9W-q{IfF4A4dU)aZF+oCJ;H=}~(Z zF6<+6ES?u9quBa`qa#K&exG{s!t1}k@FVgakK?UGYtNIBEYlQ&suBi?bo}+5?Sd*X zTzr-Je0>$Z4{lzMV@hmVSd_$wz+$X)Uir|VPj(ZBXIr7udz+z$h|pUvn_8=$5?ysl zA9%BUn!yt22Jfyg_)86CG{bwPaPMw)bst}Sf$jhF_$S;M=SpW zSpO%RD804b*VirmWqgD)|F6aH|0~Yf=rWypz)b(Y<9|*J{|nZC$A7{4PmlixtKdea TV0*c#00000NkvXXu0mjfKTrFX literal 0 HcmV?d00001 diff --git a/gcl1.jpg b/gcl1.jpg new file mode 100755 index 0000000000000000000000000000000000000000..a5ff7653035c29b5aca38124520710d114b0602e GIT binary patch literal 17006 zcmbum2Ut_h_BR@e6s4*NA`m(v3ep6mL`9mEC`FnO=}o0chXh3F5Slb8A|So@uF`ui zQUwA5q$ae4lpB4|ch3LZ=lkw+pL-|Sv-ix}Gg;Ht{MK3%;wgU+dI2(ON!nF$Uf50rq~7i2~2<90FaSB|GNLBq5slo{>G%}PafsP zzbUeRQbJ6BQx{3){t4uN%N_qsr~|}oZAp|@q?qb&4%xqQvQyLkog+b_kO53c@&9^9 z`ftvi|K$9w^Nf@R09;7z_}>PK%|GP-Es6O5hxWJ4|MbA0wvyUO{@|bMU;RN#$^~3{ zPKy5YK_KapB0ZAsI;6)-_W^7GGUESkGzb78RfktL++J=DZ{OOy;kNYQerWA%X~X^R zF)HAeA`KF855Vx30I()iN~&xg@E$-%LqkJLLq|(X$9(DHC1w^zIyy!cwkuayu3TYb zru!TIb^9mre~-!NFI}Q%pl4!WV7kh{z;N|X#BlYWBFz79DjA)8c0FL3m|7E zqhKZ@E&?b4G{jCa5Q)nRWPbyR;Xi?bGz%#&P*Ky+Uc5w_WB*Mg1CUevFCr6wjFOCk zoRa(kH5JVT3OY#=k(q*$=d$>PhtDjo@VW*`P+g77u6)GD&!YR?Qc}w8-Iy}9K)l|; z%Au9J^tCTl!Gezy^sQBXRuxLj{ZR9 zrojt!>jVCh3FLC^#<7vdu1_FKze2w-6VR+z*Xv>;VcntAcLQc;ow=B;V8CYsU$M2v zr>rHjt`ZLCTrLjo#?1kqQUQ|Mu|3Xq$jK8t<5A>@WE11F&VDJ0NM{RszgJdt4{Oq^(Uu#(BX#jQf;9DZFSmda?5Gc(WVA>hyZF$kcXYW z{7Pu5pu3=~r4u-dzugmfI)GFH%2baK0ql(zx>_akrAs)B6Y*fY9nf+~{iZFhDb_SzxX7*=zl0(*XdRRuq7PxsaS1orAQ zgq)PQ8&$Un_pWv&vwbJ%ADkO@b%4N($F2UFE4&ZeGE5Zha5n1}90xm9x8jp88hLpfJuM+{)hvE*s0Unhz zZQ}>Z%lk+3Tfm`mTLh%YV8+S8k7^^N#`}P~))d=yET64+5>uY_Db94?z0{{_E^T~O zv1WWi=QIGQQ$$D`?n!3Q@w?qv(C=x(wnna-3}mI_+adyF7$2c%!d6^g5dmxgPr7$u zI-T&}ruc0lU@E4FQ2o)nw=0J$jeQ(q>?5$R)K3Jc@3ucI^P6Fy3+ELwQh-NnLkp*@ zE?6}Aj$D%;K^qeR56#c=@ASLjYVzow#b_|oFxlj9spFO#St=64Cu<2U$f%gw6L$DE zUb-!oBG~;~wEz)-*)GSv=N=tNwN3A`KCg72SR)w&K3<{%KGX9>Q1jJ(T0M@6;&|Sk+;) zDMxpc^kuS17Z2kGV_8L^uN({Krf_Ada+v#hl=DPY57frve1<-OaFZ#6k%iv@9er6)*7WUXyKY1i zk*8>ww`k>%FA;g$GrBaXa#)dN zxhStvGWBTFq$lRK|M*gT%o+=s5UeTXKQIW6_ZR^QK8%a{I8 zCtl9Q0DxmP)nd=m8;#O!xi%!ci_UClVI<+&Wi0FJRJ}Thu(pcd@!R>FsSS1)TH9(Y z%(D4u=X$Mm3O(&JA1re1V|-w9(M~{V*2@pS|C%o=2}Bn%1Z^c zlDrNgKvg6lXYrS76PLmA2=qffTD6=A=$*mmE#O~l!L8=-&7R%MH&>ii173Wsy7X?g zr?V`Mo~a7c<|iicuvbO(%!2tD{Mzp|X3nfz*sWuCp*#-}v{OlQzD>*AfC(*&BH_0~ zGak4F(lA}bN)LrfkD5G;en^dCYTf4znfo!Z{HQT%zwpe^2y)`vr+9J?#yh&+CTkIM zcOYu8)8()mau?VNTp|K!UsW1cKyLdDEYZU~;OsJfkqZi`4UNkirF5ckp31@H4rS#F zD|g&Cg7>Z#C--*pMCOF@^l? zj#bm>+jb6-xmG?}AF>b1=`JTMxPvMhsOFynZm_Q{B$I3GJvl9^C@O3H^pJ~^{FM0$}GIlGMz7w?hWc&ZOW2z<@TBElb^RTK}omHVIDTb(uo4FQk=|Np${=l^|&`13FN{zosM{;MC5 zkpYPRACU6{5(xbVIg|f8P>`M|C`mC1=~4a(7pN}$4OCRr)HKx8RJ61gFOm@Ue+M!O z3W^Jq7ig)dXz4G~UZiLIgPa*j_?r~|b))+y_21?Go%#nk`;*x4 z1f8!+#AQ>n{DWLqB(GT>@VmV`6i}AZi~mw(<^DtZu~0%z^*vU7>$e@_t2Bbav=`Z~ zzfV+A&8>MpVQ`ZjwTAwKo^3oneEbJN{~rLfth$lCcUVe6L+|Y7nXsIOv4c-|YGGsF z&n?WY`%g?9eIwF}n)>IqvHu`#iVLLfq@tvupm_anu>bJFGZM#Cu0e4U*_8)ZzmKi( zJz~+dbUT#fmr{OrEnZLHi&fPRYWH#J)yKiC`Uxbxg6+ECJr#B#>$e6nsGRDKo5B-o z==X`aHUG`B>iEdMt+KgUEgvv}UxF_&50VuZRSY|CSyVjT00 zY$4qs#1WE0cr;FHrZJrh|&E#3Ll?tKi0d2BYeW^g6<-TfNZXxL_ng#GO7$xc*OxThS7t5CqV-V z|4KKbk5AJ|3kz>doDYgm|4P0chY3k<8}uv_E7wec^~piM+F5OI3h60}rWVdQx(4Y9 z>_U14dDB8>J)i{$m!D@QP2{IyzqXlPm1 zWfoC-o9b5bHhW!0p7L=t_-Wn5%jMHk-CW^%NW>#5RbA$VwAUTMf>s?df@%%q&2li+9V=V)+&5y;tQ$NFe2c?z%frL5g<Nc`fAzv93MKVxyww;K8iH5zLv)hD?feLlv%mY*!&X@A7j+oh@A=K+l8s z<5_4ni|;5OGwx^qc5CjCVkH^#@*p99*^h!io{^D9?u!{vAOg}v*?Ilp$j_=5e)c{8;_DpZrHDM1D0z zQ&p@oMT0!Y?!iWk5$(5Gv4M=7pN;3BXNvc}2woRYiv>l0-(Y;!JSBy<6$z|yaY|~q z+V>?ZKn87n$9nz9s{cO6rKMcYQ5dr-MH{T}7;HlX{L-AuD5H8odYA7%$a^u!QLed?87tbXp{gnu(|YC(7|+H)N#n4xaN)gc!RezRTe zmQ1q;|GjaZY)J%s%dha0qPT6Y&~s?50NJ^qyrXnFc)zT?_;+=mN15YH)6`(|fGf=P z&R{g!!8m+K3n~05PH4G#ll`?Qr_^JYA9pEoAB3F)G%4+yZ{5U@#pUybC0|vpe4rM@ zR+>1VIptw?aYJP2ihj#j*@{ATQ$?nx!_~9m$Nj2Lt|ZcT#`@RUPj0zvf3ZkoP6vx~ z^DC(?zl7?;h8+l2K94qLbkOUanZBrH?)b%_PRFFJiA48{wC{+3+wbzL>6SMGJ`aTj zCC>m)l#g)`fs=d!1wLbrDM=f^?!O2iY^yc&oQbu`Gj1erLlR+FW55W)Q%eebj%nAAj_Sfi~IAY+2AE8ue26|}e2q?eDXitSYf zjMr%HiKOq>_~t~?yw|=CtbkJNWF4^W&^R?~3g$~uX20VItL#w>Rjdn(!+>}|-2{() z7AaWkXohw_{no^ zcTuHswV!iZk|PNW;&iSON@1w5>ap|6^*g>3k49@iVy26&o%ioVw?@2pvW`d?jego( zeObejR$6XrHhblpT7%v}ce}1fT2yK;01@|*K5$j$QFEgrSaW(D3GXslkKvSL6Wk#C z(RKarW=8}N$Nnt@F(iYBoE+(@bV4-NGIA51jW`!!$}W#ODZS>gtDb=5sJxLe&NoL) zG41$BKiKdytXCE33H9+%q;76$TiKz;T@;!lzdt-d#in!E({HS>K7E%6uo2^F!~jd2 z?zg9SXf8UNPwv%bSn0+N!HUfLC%}@KdwUv69iMm8Um=Bi`&Ik4A$c`TFYdp1))7L^ z6qd~vL9sw?8teS8efiJM1u=pROF^xcHYFX~o~Nz1~pa=xXt7h0X;K0fpH5S?4o02YCkZNyosUBBcKc zydQv$CHN2l_nOXXNXYUjec<&k0R}Bk{{oi39Rnr;hVMabAwCeJW>m?kHde%dYP(zT z^_QlY^s_VH@RJP)acC##*TfD&a&u+wDOby5Rl9bMws=^vSe05M z)(0`7P&yiR-O0pjcnFgcI_7(?K-B6Hdu~*MF;oaP>;!!Yi-9S6%!~NoUyJlssH~qe z(Hl-jp4LZ!kkucF087acKR>-S$1skZ`rqe}3fM30+4jE04>4{m3J8SKS`BD6k~G&) z&mFQfJ#QUl^~0ac4_`Cs{C0JWrOdMY{49nUKP9v|gsjHGuIP38Jb?7X`qvXKwN_$8 zyJUGCO~PqlX^ML1?_t9M$Lr3DL+-b&rUh&EGuGRM*xDLUs^tRXk2SBDSkOxZP=6J- zpUk35pgefXmi>3@AOF{^$IXyNXp(g0W({2O!+3#E9!!w?J|RDQ{b+1hu;~n~ zf^phrA)8-=S3!(o^Q|SWOLS^eIJM@1rSo>&Mc6MtP7AoBQ;v5Kev(l*4(A3Oq}~E{ z`iBq!e1NYVvOQa#hsus6I|UJDvt#-fuPyxhXp@8L#pMTc)D{K!x>|d*wDGN_8Q26&G=TXtEVT34ZilV2Z+hp zPHrDp+(IZBO(4FMw#2|v(}{qKwyTOkxfCwoE_4YIaA0;4%wHziL$<&T(k^dAU5)P? zu^18{FTNU5)bpcN)zYywz1zxLgSuglaod;SI}s49TFv#0YwW#URK_}4hb-m*_0i)7 z7cyPrMi*b#EjC1WgnDR!jTAR7#_e)=IQNe7kuAsQ5DlW+JBOQwFOJ#;%JW90vP5@K zA<|1AIc3)_JR(a+h2NVQpW1ZdPlAVVSN|Tur7`NCm}RY$-$-oa5i4qBP% z>U5Glt&>wHJ}@#!2>ne2oN=Dh!hbG`g{ROuRxuhAUXtJ%y!i}%2;>IdvduX1vMj22 zC_VV@CZ9y_A`8s;V8CT1)4}DNu_&YcN#>{O3Jz>~FqbS^Xpd84k9>ePc;M9o85tg< z;~1X)teu#jV-EPVIMyT&gv>dFeb@Qy-pd|7PKI;@#o1SHveU=pP;0)P#P>O;SNd;M zzNEnkr%ImKar)Xi4>HbfNi82ZPlprEHKTg45{cm97s@+U_mh%+@^rYH;o+|R!qh)q zR~g(*7O!dZp9vi(UfOLN@&o6b1Z!iWh2_~3!Bezenn%o)nrP-tvxu(*NJ{|d#dtZN zW$A@UyVwJva2$iJr~jF>?8s5*eD%<|RUUg;*VLM#s}{~uHgt~S2#8u9a;yGE7h15N znFI{823l)iLY)!&yqJVxnHV}H({W@w&2l}zy_N=H=&XF=%Td z-HkjypMq@}-DOAi_ox@kOT%63X%0p$@$#H~w)_d1uEN(Z>mb@4EW7CL#>kSfbpikg zz%1FG@=Mzt{j`PZ*SuY?;%scz{kRvhPK`iSia7VC9q0hNeN+NhHKAu}9 zB|N8n9HhoeZ_~dfJXb!0AHh;U!}6%iO{~=Ea67H^(AxU@)`0<7a{L0NAp6Wb{ap!P zeCYZ!@re18gAOgaOyP}kO!uW-Wyn-*LTRLk$X2USiA5da_d(#4r;7}CMzY+HVfC7l zkF{hr-&=|ud?*n>Me7N+wHWKsUIkzE_RhOc?QTluN8i|j*2TqCk3Xa`ZSIE5dD1YB zeulPG1FO^Q@v6FKGYhLupkG7tB(ru?%x&d zO#{XX$VoU&n)dUXZ))F{_7Q2~e*mi>OR!%eId)jzbEx=TgwYL!$oAL=DvpR1Osx-l zR}Jeaq6F1;1&*oL_mj)G<1asr$*B6as$Q9eAsO0-Qjg52CQ$H4P2!8cpQ?Ewg>yic zO|BT-q2*N6m1`h8&B?J7+hw(Pfs+flx3n%&cb$UI=>2#l5sIamN-0-39vo*Kf^o}V zLE~*mo)5^6JW&PlS1*5^5>r1P&%JuMeq&^djF(&t`$;qKj)KN0pk~n ztw6j4s7ust@!_T~Ym!~-+p|lCl9@)y_4bgYs=)#+%D>}i1xa82c$(A(4t-iVVcXnR z*B-biN{vfM+ADH0Q_DU>9-W69f=_v_j@teA)X%uXz_^4Lf20UWyQw>L+Uo&0{FoXR`; zwrc7W3HaWXbN#O#q}tJ|r(U zXc<_+`<4h0ic@$kRLG-BCx0<`_meiLdRDwwJykvWJd>5=-~9D`E^R@t3(lqRG(}wg zdVg3>OSBs*Km`+E<<2oW1%CGFw0A&|w3&ZKN2STECq*K9ZA3gaeov(xk}Yq0Ua;mq zmnzBfbYB{G^u8Nql@6Z;y;kZX0?5p}a3c0VzK)zD*<(K)XG8tRL@j91z*sMQ@T zx?c$hkW=s;)}V>8o*C+%-agzsupUX+>bb(V7gnEx@f=AXRh>mJoVlYdEfG#PYQ!`LK78$&N>!(B zDne$QELEfL2ScTx|(g#6>p*U-pB>qU0$0wZZjnUF2EfaZ9VPQE7=DM8Zc2-zd@Wihl(Rw zqct-v8TW1*A>ZN(AkTdm`@*cQ3}^Fxpo{OFzhJ;(2@a%SyfXlx3yV^Tw^x)L$jSi5 zUSsYSRlwU_r+^(f`>Ei{8NAUwx1OdKml|BtzU+0WfK8ckD6f^l7k1+!xqbk zF-r2FAQ+2*wnKpHtw8K&3~;iCpdDJ1g$frt8YKcEG^NEby;+!^$oDpIH2GNg4cM1O zk{68wmQ(}V4o1Lq;b&~;8YIh8JQ1MHc$OdUl=Z1SF1ag8$+OmX23EX4a+XxU?%0#c zQ1=qPS`nzs$6@{a?Gwrb;lMuReqVlU{n?M1^7GX-Lg7n-$rwqeV~oRVwIhC>tNo|i zT8#35iBQVh0eWZEkIrvfRTMQvDx%&!rZbFXxH?|sXWPSIv>upFAKbUrtfrh*eSBqN zo3A6DD)%G?`k( z$lZ}lW0WR;WAFSa#QMaRYjE6h+=7Mf88es1V3ynsp~2kiniZb6dZoN?es%PB!wK)? zlrOngoOr2qP^6%fIu>U(phzU}OyXSCecR$^!$=N`4%9vNC>U?Fzn`2ijVsPpM2z7$ zid5f@gk3&o?d5uOIZRX8JfrG?R6n?+r4eyc_vUY!O?m6W+`iNyM8RXVsJBvi54u>L zfoSL0%LehW`|YnNC8M%PYIBknT9JEy<=rRB_(-w-o@25jMhM;2Ora_tL)30*n&f6i z*zS8OD)7h%rmtM0tQ}KXGHd#Te*%}y;VY1T#o(B`_(dGadY2J8mI<40g5NOUmQ$O+ z5@vqypRst#pu8+B6F-3EqPlhHn+!O42+6N=R?M0>ON){0 zCnqQbuV)>Y?ZW#!W!6^%NNNTVkP6f%0v?>THuv3kE_G#IGl|O>g&HJ~Fl({$#X3ZO zh`KCVtX`qsmN!JP@PUN3K!)ng2BV_CX4ZD%6lp=Xm=fGr(Ub%uf{xGr(C8E1$x+|yFCnLSC!O=C}EL;{NVqa1&VL_mo)t*}Yl{Jj-)BWoM<^|lBGh7l`Ydh~-+ z6QVzQ)G^j*PA+IcD7l4{&ZsRokg6(kJA%VORZD9Gs(>hYy?U4MOCe%Q1GtfVq$KNx zn0AZg2(ao#7X!(}obz^3DFE`UV!Tx4jfY6sZuW_T(M^zwQ<7!3o7Mw&!E`gvdag)t z!m|W>tMItf$EGJTeW%#x(Ro|!0--F`<9B$fYoFDBzeq`yc~s^bbK8o8lA2otf#WQn zww~UWaFhrz=C=+&-9w3C20??svGybr!^GRREAB|s1Lt=cgdB@*L+YP-_C2HSD!YRD z!GLbLL45GZ#5PGMV%d3Cw5yfY2iM8G0fPv1`hVfa{TSxN#?2Nx=B3=+?hfASdqm~N z%+Xi=NvBwk{@(SCz8Z@^62JOXkwT^Fm_I`L#+|En`752`kM44O5k51mIae04cdXiW z`@lmPc7wPpOv?qnOD1dvA6aRvIxhE~Y&vbio7v6z88gd{_6MAK zF!jST_Qi}zZ<`}$CwGUfA92I+=^qTY`lXG#>2!Nx?@eoWLhj zxgmxu+uq*5lD;TC>Gh-W7iNQt=Eg?Nm6%E)g*sh{dp^ngx4m;B$eCE!0s(t~r{`B) zBt38SNtwDWXv@SEA2FmZoP+WYj&OGALpV9=b=aAhXAe@|>RWij)+!&tzg3S2@Ks_g z0Npuqzdg#usXnyn|3w8WhIySslO1@Fua)AO3wh??LbLiz=ciy*CVj|F=f9p8;xuWg zw9CMdYi$nkBfU!xQU1EFTra0>C!LwRB6UI|D0a+$0n?D;yGo8-G+v)DFsHq&gG)Or z31$UTK$LfEYo*Q4i%96tMeC_WL}NNX9+| zZ~8hX-%&JP1?ZClMxI4Ien9bcL6)4_WlfL#2985OE(HHc=m-}Q$b{* zQ_Ww+IE(uj_Fk)kD-YZgdN#$x*;XI$kd3d4=K<^|l5$ma6NIPD!9@+5g28RTX4^y&?So3V4T#H^#fM#{q@`k99&2{TzstE0gcmW$jcDKR z=FrEp2+6dOG#hQT>+58&D;5651Uk-gj8ZqQ1zh}$2Z-j|&N?4E3`kf9N`qaclqdQ1 zy@t0iTA}Y?!%uwTU%QV?*U|IXD>UcL&+{5u2z0&S2dR4u-0G*(Y?e*7(SSkM}H#j`Z9`@e2|_3mD5YIl4iDaBOIDo+6(UFaBI5Db1}_#^#`_;J%TgjTO>Nx-kq?N6X=Bs z&wEl^+U=HlDsnLv^Av9}59=yDyOI13bBW*%L5Yk!y5v`WR}&F!@`ihB$pXH;HF%<# zD@L~bdg01S+OEu-E%#S8KS*3dgsOJi&#rpz+b-mU*#-WNIs``1gLlO8ULR-3KdXy4 z`GLB0F5Gid>`tz6wuj>Mm;IcwWx>BSnQ*anjL3p4;W(&3MjavmUA!J+2H;2*z-)52RP*Yp}IC+xo)c`NLN;$z&+$G5%3)tCr; zb_*b<-Q@$O9mt?(h}qkaS-uY7Zv_77WlTG;Ivkqmd26oF(}2?`P$|9onq<5sMXEH~ z)dM?gUxSgpu9Qx)2X99Df|FmhYOFrJbuBR9`qu1Wlq)kwV0pqpUA>{Axev0h8XQCn>z+?t!bGugMvU%v;5c?qh1tcz+Q9RT}`D>rJK&eRw-QQE8sV%7i4?91$&Z{ z!1qNTST{lI+7YhxQU`rh;cd0GsErREv<=OpN9WC<&xTk1jI2FBe=e4|?84z9AItc? zihWU4yn`+wjFU19$Zc+bgp1f`CVt_h(AJKYHF*Hiwbo&SN%;rA^3yaR6oZb&@y>l> zBgF%@=-p|!4c*;`*^euosZ?Eg+0Oq5fET2^nYs5zMv5aL&`M`GHqk9sy;NDk~jXU(9(EL?}4d<0! z5Xorp-K!2HKQBb7-2-N3M8k_|x)|nR<2zVGIpHXT9;z(@fje9nOfa_s!_%f)}+xbjyD7 z+|vABorKW7_FqF0ZaeC|^f_t#xW|F#+Wrs?g1L#v!UJ_qRWCA(EqJWF|D4jObV!~q z#T9{V>i5%@2dAB!Y>3E<$eK7cH!fO5+|0R)ov8v@hPhqv z&`1dIv5!wC5ip7OAi;c)1#Fa%h@50RD9M>3%y3x&+e>hpZ~eVytQv;+w&|Mtp-^;v zoT$o7Ld#Sk#_fS)pN-4b6(XRVUdx%#rvnK#NG5A>6FwFyy-0Q6Rrx z-Z5hkGz&H?0ri90VotTE#Qd>y{&U(1d36aT%4Bs-O$|2&`k1gPPoG{cQsUF;k%x9p zZ%aRw7f~Au7bk7X08f|fbyrnp0_RB4`sig()=8zMasNKf z@lyUmxfcJD(A9R_2I~eh?i&t;7Rr_>&c(=G8E7)2*T+Ateo=v0kcWS^%k8|a_BXTgHCmPkA5 zp)`kG;su;e$59(;CSD-S;pQ4BEP6jw%GDvL^&k~$>&Y-cmG}FAkre|8?|Lm zUbjm#psn`{(9}qKaF3ysXz@l>hR9+)2pg6|9Eo0bDhn4Yz-jQptL6WvP1eEvbn5jhB z#yKMbB%Tzs+Onoais7tnnAHefv_yc2)ctmQwDmmGFHYRZc7PSBrn5^YZ^FWVfAzQm z>^QQ*P;`lfQ}i7UEiO*sr@D@h2kVpT-K1s=-Nk+Q{MmG3b+d32&9NrMwlA%CflfNcaj~gr?_%dGja5hb?nl=mAd~bEh2V=w9B{Z7VmuQM&1Vgfn7A$CW-srH$HzMFvNjiXrCTMnIB@pah;W< zOrvAdIGU(8NY;=$>yIJ}v>Ec=sDHNKTTv^($OvGf(8F`x7R6bq?J3Y6A|NQK?tZ!5 z+guo>7Gv9GzP+47?{3GX-PxkETyJX)E2+2AdPyrow0E172n9Wshos3 zNdPl%T?Sc|jl;fy>)d+1e~Mdip(RmazHjf@{ThC= zP!!sKA}x6|BjRh*y^n(B0W3xJdGyL=FFa$EkjP(>G7rCGmfw6&@_KfVjKQtNCt2Vf zLWD_rbMG#VM>>|#1<5z+GqDHa^-1FtoB)r%ox-+$cz65xLHSD={yr6_i{l}~l^JzUj?t0H&%-Wx8ipDa> z)bBI$?Fv;YX6;g`TTdM(03JWK`5|-9v&^pbqXX1$rpD8-`redzX6}pj7+csEPQxQ8 zSPJ$_epc}(Y=Y2JY`=_71f}^h8B`>wlL>=$J7vHpR*YEQDVQ3f^AGT>VAN_Snb)o4 z>PeFnfjg~xTKQrV!0>T`ghEnNh=4DOkRzxT3^8~PT1>`+c2wY)5#Y!Q5dc&oNs9)O zf3>IqHpW$s1ql!V3F12>Pdem?r1>7haH}IY1ZbmvW4dsoxLo1ImeoKSea+qZJ0D}~ zeZCw1=CN|1YCL=Jj9Y<-$Ap4-V?8DG!B%w7r6;tqTD>p zi^}O?7}f<(Uz{EjW#G(x>Yl>Hd9&MrOimvnECyD}NLxS2kN!uvqQ!9QYU?kSKV>C0 zEd}L2=0|fSZk71FWM?o;$}Xl6$}hd4V6_l6eNq>-U9-WreFN@|_s?7=P`8cuRLDcP z{6i{rRuZuB<%XCla`Rs}@+9GxNk&59zcQ)qk?&M)ZEilPs>=9I`7}85jmj%XtrZWq zz?GMKG>C_Y=Pxx$a{156u0O}v+GG(QJ6-wIkzWc5`__7H$FGF(pHc%2OTOoHx*^kD zzqu!dQEV79Waa2o1*C)^uB^Hj?__pmas-Q-g&{zu=u;e1`>#)VyPW*zpa*n0 z_g8xZxC5O-m^U7l_LXy=j0kM%YP&N3^5U!WVEl0T9Es`~=#~mhIsdEMq9B-|@_xVK zR_X`1(ec+>rR$qSfC}a_ckv}T$j8?2Co!rwdn#O4(tB#sByaX8z(TF|HX-grKwwr) z#rID_wl-1{nF_EOiW#8)7c$_K*bv=XR&K_B4(aLJe2h9Bcllr+iQnnjDL5shrhXYk zOpSz4yvhHJ^HM<8EKS+BlI%KjslMorur0XCKL<(GLNadpm`t?2 zUcS$BR2Sqs(fvMc(!%NXQvUdlF5(~Ocb?awdvx7WN-^4s;ATf~wd@&Ai$2ZpPaNHB zd)+9gZPNXuH1o?Zn72A%TTgrTqRj3^obm8Uxka>wocL>{)^WVb3HT-KSAIfeHYZmD zN1AJmI`+^9_5?VFTfnXuRFhm%X?psrm$+DstuNc;T%nHlS6yXO2cP zSxFq<9tH)C+kxB5gK9quh%XMwL~usbMmPXpe}yc@ZJP9c zBg`|1oYqQ8Qrm4y;+d2P${XfRwE-17F@w}-_7rl^doDRxUUZVC&ANpB%)|^qIP|QN zKp`^+vBhpAe}mTdHG2{0t-L+o0MRID7~|>qndGHAbi84uci!Lh{dglQRX%-73j4yu z)o7J^t@ZHD>@MER32`W$Y7=`zy#+tER1`m>a{q!6^-E<+2`}WV=9!4cTJ>f=cq#&$r#y;fu&Jl)Y?17H}F`ccjzPXIOa*P*U8WHeu-8Sy6 zjzL=$<>Z$TQ2WDKc+4jzUnI+%(g>nktHL*DaT40ziuIaZJ`;10PFV}CrRhj{-9ylU z+F|1N+rh3JSsZ323qN&EX6nX&E_6Exv}}$wWqG`$8TNd3SDHs{=;X!q!)DczyhbU{Ye|VI=iQ6h)x;%m@#$( zN)~7A-YzLXM>&DNG2xWq*L|`I z-{p@j3DTXF3C!{_KkXUXbOXE)V%%4cG(rQKtpgnrv$B@a@m%(igIS-TRw2_Cf}hqy z%r1emi%2JLCv`fIl1e_v*N*vu@UZBB%DhQI&dzvbh6yL|);eah@@ zpcXcyw|R9N&hb3sS;Ux!s)))ITPdr)WsMmr`Pk&!n>Q~5owpmP*Ow0lqXj9lZo9_h zpF?}VyVQ<7Rm~u!G6>?AIy(6#JSvPa*T2@!ZCsf>p4q-2r{V@#W*UGzRA{9nArWE6 z=f)rJKSG+ONty~F7blPULb<>V3dL7wEXzYQKDV-GHImltAD47Ne|k`tky2}J>7>rZ z=^P4fh?viQuSNjJ=Eg(1>#K5f_bCmNBmmxxg7-;%FKY0t+Q^U8HRNWq+OwSGYgzns?_Ue!6C$6ydAs!2NtYB}me)SFSaQ;)F z7`1nb-y0mO8P}2r3H8HDP}E|2_+7Ymok_6HT~&}SLPz$LF~Qoyr#(yTsOPv%7Ht?e zIHA!!bU|Y?0u;i?pxA*}kWT%F+S2blkZKIa-X*CMYzlu0iVfQm{M#ph)1=1VT7qC~ zNe6#`6Tm;Evi^|T?2hX|q9pK^WI-|%z(cuKP->(@97>Qa_-|)|!Qe7#5cEs@U~NH3 z6SJ^9l8m*&k{o@vHk>hbzysMc*S$-Bvj+*a_At?}bTswZoIfVcESM-_>1+!7#C7BN z29t9!klri&V^?UmNv^2ReJ6(N`ybP0A8Eban&)S?hCH`V%8a@x{DdyynT`ILa0KwL z`?ZXqnQ^)q(J6 z4U8^noLf5fzH6+SWPQBJcs_Jyk+-UI2P9%i`FtT@c3d_!DFfql(N!rBs45jB2>XiR zqVXndGUi;mVV9(29>P@fKse$~{CDfPK=O%;SFT2h-h83Y9Fdpo>2xbr#VNuZR^nrM zE@p?C!FMJaVj(Zsl-+Pc>$8KqT6fOTC1W*%o(X#vJ<9o$y zfQuHE**>p_Xub;jWHzsNH6vu7x6NKBN3|-Ww&gOy11|?u=!x>@q-MqE}9_raxDYst=c%# zvRfbg*sRYDx}GA{Yu|`1jG! Ne{_QXH%a2p{|iL@$p8QV literal 0 HcmV?d00001 diff --git a/gcl2.jpg b/gcl2.jpg new file mode 100644 index 0000000000000000000000000000000000000000..9952256c274f4baa3b78803e1ff9b872ac6e284d GIT binary patch literal 5737 zcmbW4cUV(Tm&b4DAc{!nB}$}7L^{%_wY%p&=guE9&&>Ip`@J(~C_|Jf;5th}~9_msY%XQ%3slBp_yHX4W&TJZI1HNM91TB>jIjN*%z?1o(lj(t?Bm z8g>vZJBZQxrKhK(qmK5c_5*b6 z^cOBk-DBX;w`LS}0ZYG%PGf?q7S(eabZ=a~Y2zBi%)-UZ!^qPshPQj?bBy=_6{hto4bdnm$#2^@as2kLqgwSV`Agt6B0jsOiItl z%*w`p$;mA)DJ7Maf32we-q6_8+|t_C-qYLHKQK5nJo0;bW_E6VVR31Bb8CBNcW?jT zko=bm1knB)i~9aI*#F>Sr*hHI(b3W|{^bJEcu}2}osRyJ6vKsk`i#~t9KzDCn82#h zX+`zS(3=JuoHnlAEL@jmev54WMf(@o{|+qZ|3&s+VE@fE0QmO zEdTO6OSeX{Zb;fB#+6G|Itu?2dcwG?XyB@E`m7hP5Th4V<^Mic^)9axteJ$vlCwr- ze2v(L;lpE$Q54|bA>Yh(k7Ppw8)uI*AGe3+fN)I%E^(%xgE4-L%*`#F@k z-+ybz`BH!&e`OJ&(y6Jzw+<@ovX*l9BTm)7kruruK%V|G8>ac&Bi(`g_5Ad&L3*2- zRq-LdD_It@a*C{;=2mnRz$f>mY*EcwNkiAEwQx73v zk>0J^afxFntI`r~bNBPyIDyRzupwfY z=SfjY)jg^+8R|`%$6u(KIp=qs|7E=LE(M??dn1%k_4Ng8ziOc9B)>4O^ya4l zmNB${?AW&|OL)2By(T$lE*$mD%!^oQoT2aFcX~&%ASiL2E7Gp)R()1(^kc?#6XOz# z6z}B+gS4B57O}d&oL2Ma92Tk)FK0Y?jnvikC(Wvim{Nf46Auc2`E=}iMm ziq_?Zn=H)fwvzuTCy9~|6ORxS;1olwUEjvMSLXkzKJ7gfvA0+q&W`aL*J{bP-|auf z+x~th;$`eVxuKi2kJTF{dVXJ${Aa4n^s4ZCy$h}n8KfOe&P1K8R6wrvr@SFw!4Bhp zT};P{1ON7I-Ovd+$BSgqkJqm8*vvmwY-ZaCUVce7GWwF!@-f*=QRIQ8F#>liy{0vz z61tRKn)DpoCOLHY^y^Uv`;JgPnPp2m?A_X$(Db}%66zdMi(e$N;!BQWE5XEAaG1=+ zcs(OHL{hfEw4VZ424R8Afebnp5v|c5`JD?_5a7964jGRhN=I-h_GdYFtx0rSz@D*B zT~RSakjLm)Hvh#5|!p-GE3|#f6a=V|BA=k z-2PP`gU$`9#Oo?k?M6nicQ=#=1$`kF5k)Axov-_{dZy9T+6PnJsXunwFno!NkLQ!a+qu(>kQZa2NWRa~VatLGXM?q&b+Sfd|PdTgbL9>)H>e`Z&pd>Mn7 z&FN|1{;`el(t>i^yo_;0k)|I$?r~iUNPC<5MgP4>w;4=Z^*b7M$365p1Q}F<{u3=O zzuZh}Xh=%ml6U*8QB>bP+M!!}O5dec)XzKQ*FT6Vr>~o@UeILy0sB=N+Sy-VcD$Q> zRSag>cOzU<=Rx3q3YPZMCjK3Fg9S(DYyJw1*K_>Q1b)cln6Pko*(b~AnWv9n*iET6 z8=uRAx|_5}g~@mG>@`kK%t2S(p@?CooYrGU1!vYw!CAL87t5WA zYa0zg3|Wwqjmh8Uw-hKqNS2rr8S-~l+cwqx-gPCmJiD=6W-XEIXvZD-hAetT5sUKP z4>!IKwDr3S47F0{*I$ z_ySw>Q|l&Qc?*Qp!poBB?XmC1=xRksmEiH@F=(Jn=aPWQ95LLCErBGHf8A4>G+@4j z2K$kQZ5Q|z2OBM**&jqAL{VIK0pqp>>;m`wz7J1FG=uw3trn0wBj`UEu`f91}a(_DpdL*omSZ7WS<{oOkE;A0#wM z=61volc`X~dO&7RlWqbo$43Yl+yNDQ{Yt5sJ39VIwbvhbzTl z!UE#sQLgnR<=0XP(`h=Z6E$HbK5R;z{$0Kn;srb>G7|ljFBtQUSDH}6Efr0kPi8!4 z{RS_Xx@56v6KcmPz`5rrxlcnbkH|X>h>iS)oW>FxFa>z!adK0C(X%dox>)(r1+%I111q6}?Mr|9+SpBD*;C+o8fs`Q|$* zf!z$ae>~+S@-zgkjD(FKTIO%YI+a%`2wrQIh=8SG&*#eL4(PqP*TmPH@05n(=6ln9 zG6qY|AP5DrxuVKqs)VKDW-~ZFJDM0I@&@Wln%pW)8!>EXYvVPGPQznvs6$tY`-x+= zc4$_(mH>9qSNe1CK~MP1^*2c-4JN67OeB3j7T{r!DpeF#T!3O?MJXRNVrHcX>? zZGDXOQDdi4r#vJDwt)9aP>=4k94g@$OVOcLdrirvt7KW?M}BK!=EM}n1w)<%NUWALt0!HW&&KcPbj%De8a%+U}Wd);f%n~yk42l7W zN?n;waLa^z5ab<^pc!7mvXC#_0kX_~=M+I-8@}{H8lb+|! zW)vVNyl`JBWC6Qp?X5OpKR*;Apnj=Rs@VB{E$!=rU;+kxP`Th}2h)@6J*C~R-JEtz z%<@7BCU=^@vs2F8)Dw(Noa zJ@+uNafbq^)Q$J1k4=ALR4WIrbIwJf6Xj;X!w323(SuPlQeF7y<_f1T_3ua2`ZqGLUQ3a6z>Ov@-gdO6aa~%0B6)1ag(JKpcZoCi+PNn*C1DfZyiy9 zDWSQq`bpc7bl&CWgT!k%J#XcoEP*wTUuwDfyDhRUSpM+37ilrUVHhc`_}PTZ8%>P+ z<1thVzaMcHA<_AQXxqZa?|90eG9vQx$5S1~s&kW}t;Ce{c-QP~eFL4F7P8OOGtp}9 zYkt-3#@IrMx~ZVs4A@-^?}3n#y3h4hmIlwU){r%XzyEumH}g0z>q`;K6PlrG4Z%A~ zuvUV)(L@y_eacOOrxnkL^035A#V=-N{T z%e(MK@Sm&okqziDF$9Y0=y2#F&MF4_O0vmo&mo@sb%ebUw>#%xWeJ?{35$|>sl#2w zru!n%?3*Gr8SF~~S)ZxfaTqGF+T>wk)_K!8;;2r^PzH8Y*`p-%AT~`g!INBlB^KDi zx9n^EuBC06L87b>y6D(P)ds@V&$G*>afUwm7`~5%k*zseNhWflF{m)JMqX64|B-cJ^+ohU|QT z>+NT>c=R84y%wjJFCwoR=^wroCFGkJKdbV((_wx_oY0VEH(HTNMdW?nBa){eue!1YfoE*S$z9bYK7UjR%<4z#X~>qC!Pau7 z7oe}gK6)lOJaBn*zV5txj>(NXMu9dTp}g{WRV(_!DKJ}3aP(U+Xd$T#8@u2~y?U=- zbBw9ln7tHnQGci4$=71jF3wn&Oql&#&Wo^d{@zAo{DxM6hHaabnz5pW4&PltC?wwZ zY0|~hKWZnhRVoZur^?ien{6)VU#b0;;+N#OGis97V}`4;>~XMFaV4syzluyCwx~$8 znlENXZw+c$XS``PDSy(-iFsR^Mlx;zUl@Kk(0Eb6Xlu9*d^%6n{#OZdDtMSf_ye)K z1zqNFuTkqjoG5qnV625nMPm01K}rnWo~X$h@COFYK1#6}xhJ+35QiIDIKpN5>h4hk z6WbG}0G?r-okuCoClQzmvi?cbg%oF46c^pzJ^ z98zhp;{S4nIEJJrY6Dc+UX+W*S?Crut(%CavP}0}TG8cNRItlR59ERBKdb|n>VY)X zQ4XmLJaN0(C&_22LWJ+RQ&-p|^HEn0``apaLDF&@QkiO~ZN}=7LHAwu(DQ~tpq^wn M0M>^C7|QT}08Bw60ssI2 literal 0 HcmV?d00001 diff --git a/gmp.patch b/gmp.patch new file mode 100644 index 0000000..f4106d9 --- /dev/null +++ b/gmp.patch @@ -0,0 +1,19 @@ +diff -ruN ../libgmp3-4.0.1/mpn/generic/mul_n.c gmp/mpn/generic/mul_n.c +--- ../libgmp3-4.0.1/mpn/generic/mul_n.c Thu Jun 28 19:04:08 2001 ++++ gmp/mpn/generic/mul_n.c Sun Jul 28 14:01:36 2002 +@@ -1144,9 +1144,15 @@ + * multiplication will take much longer than malloc()/free(). */ + mp_limb_t wsLen, *ws; + wsLen = MPN_TOOM3_MUL_N_TSIZE (n); ++#ifdef BAD_ALLOCA + ws = __GMP_ALLOCATE_FUNC_LIMBS ((size_t) wsLen); ++#else ++ ws = TMP_ALLOC ((size_t) wsLen * sizeof(mp_limb_t)); ++#endif + mpn_toom3_mul_n (p, a, b, n, ws); ++#ifdef BAD_ALLOCA + __GMP_FREE_FUNC_LIMBS (ws, (size_t) wsLen); ++#endif + } + #if WANT_FFT || TUNE_PROGRAM_BUILD + else diff --git a/gmp4/.gdbinit b/gmp4/.gdbinit new file mode 100644 index 0000000..473d74f --- /dev/null +++ b/gmp4/.gdbinit @@ -0,0 +1,43 @@ +# Copyright 1999 Free Software Foundation, Inc. +# +# This file is part of the GNU MP Library. +# +# The GNU MP Library is free software; you can redistribute it and/or modify +# it under the terms of either: +# +# * the GNU Lesser General Public License as published by the Free +# Software Foundation; either version 3 of the License, or (at your +# option) any later version. +# +# or +# +# * the GNU General Public License as published by the Free Software +# Foundation; either version 2 of the License, or (at your option) any +# later version. +# +# or both in parallel, as here. +# +# The GNU MP Library is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +# for more details. +# +# You should have received copies of the GNU General Public License and the +# GNU Lesser General Public License along with the GNU MP Library. If not, +# see https://www.gnu.org/licenses/. + + +define pz +set __gmpz_dump ($) +end + +define pq +set __gmpz_dump ($->_mp_num) +echo / +set __gmpz_dump ($->_mp_den) +end + +define pf +set __gmpf_dump ($) +end + diff --git a/gmp4/.pc/.quilt_patches b/gmp4/.pc/.quilt_patches new file mode 100644 index 0000000..6857a8d --- /dev/null +++ b/gmp4/.pc/.quilt_patches @@ -0,0 +1 @@ +debian/patches diff --git a/gmp4/.pc/.quilt_series b/gmp4/.pc/.quilt_series new file mode 100644 index 0000000..c206706 --- /dev/null +++ b/gmp4/.pc/.quilt_series @@ -0,0 +1 @@ +series diff --git a/gmp4/.pc/.version b/gmp4/.pc/.version new file mode 100644 index 0000000..0cfbf08 --- /dev/null +++ b/gmp4/.pc/.version @@ -0,0 +1 @@ +2 diff --git a/gmp4/.pc/4a6d258b467f.patch/mpn/powerpc64/mode64/gcd_1.asm b/gmp4/.pc/4a6d258b467f.patch/mpn/powerpc64/mode64/gcd_1.asm new file mode 100644 index 0000000..8762bbb --- /dev/null +++ b/gmp4/.pc/4a6d258b467f.patch/mpn/powerpc64/mode64/gcd_1.asm @@ -0,0 +1,122 @@ +dnl PowerPC-64 mpn_gcd_1. + +dnl Copyright 2000-2002, 2005, 2009, 2011-2013 Free Software Foundation, Inc. + +dnl This file is part of the GNU MP Library. +dnl +dnl The GNU MP Library is free software; you can redistribute it and/or modify +dnl it under the terms of either: +dnl +dnl * the GNU Lesser General Public License as published by the Free +dnl Software Foundation; either version 3 of the License, or (at your +dnl option) any later version. +dnl +dnl or +dnl +dnl * the GNU General Public License as published by the Free Software +dnl Foundation; either version 2 of the License, or (at your option) any +dnl later version. +dnl +dnl or both in parallel, as here. +dnl +dnl The GNU MP Library is distributed in the hope that it will be useful, but +dnl WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +dnl or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +dnl for more details. +dnl +dnl You should have received copies of the GNU General Public License and the +dnl GNU Lesser General Public License along with the GNU MP Library. If not, +dnl see https://www.gnu.org/licenses/. + +include(`../config.m4') + +C cycles/bit (approx) +C POWER3/PPC630 ? +C POWER4/PPC970 8.5 +C POWER5 ? +C POWER6 10.1 +C POWER7 9.4 +C Numbers measured with: speed -CD -s16-64 -t48 mpn_gcd_1 + +C INPUT PARAMETERS +define(`up', `r3') +define(`n', `r4') +define(`v0', `r5') + +EXTERN_FUNC(mpn_mod_1) +EXTERN_FUNC(mpn_modexact_1c_odd) + +ASM_START() +PROLOGUE(mpn_gcd_1,toc) + mflr r0 + std r30, -16(r1) + std r31, -8(r1) + std r0, 16(r1) + stdu r1, -128(r1) + + ld r7, 0(up) C U low limb + or r0, r5, r7 C x | y + + neg r6, r0 + and r6, r6, r0 + cntlzd r31, r6 C common twos + subfic r31, r31, 63 + + neg r6, r5 + and r6, r6, r5 + cntlzd r8, r6 + subfic r8, r8, 63 + srd r5, r5, r8 + mr r30, r5 C v0 saved + + cmpdi r4, BMOD_1_TO_MOD_1_THRESHOLD + blt L(bmod) + CALL( mpn_mod_1) + b L(reduced) +L(bmod): + li r6, 0 + CALL( mpn_modexact_1c_odd) +L(reduced): + +define(`mask', `r0')dnl +define(`a1', `r4')dnl +define(`a2', `r5')dnl +define(`d1', `r6')dnl +define(`d2', `r7')dnl +define(`cnt', `r9')dnl + + neg. r6, r3 + and r6, r6, r3 + cntlzd cnt, r6 + subfic cnt, cnt, 63 + li r12, 63 + bne L(mid) + b L(end) + + ALIGN(16) +L(top): + and a1, r10, mask C d - a + andc a2, r11, mask C a - d + and d1, r3, mask C a + andc d2, r30, mask C d + or r3, a1, a2 C new a + subf cnt, cnt, r12 + or r30, d1, d2 C new d +L(mid): srd r3, r3, cnt + sub. r10, r30, r3 C r10 = d - a + subc r11, r3, r30 C r11 = a - d + neg r8, r10 + and r8, r8, r10 + subfe mask, mask, mask + cntlzd cnt, r8 + bne L(top) + +L(end): sld r3, r30, r31 + + addi r1, r1, 128 + ld r0, 16(r1) + ld r30, -16(r1) + ld r31, -8(r1) + mtlr r0 + blr +EPILOGUE() diff --git a/gmp4/.pc/applied-patches b/gmp4/.pc/applied-patches new file mode 100644 index 0000000..be365ca --- /dev/null +++ b/gmp4/.pc/applied-patches @@ -0,0 +1,2 @@ +arm-asm-nothumb.patch +4a6d258b467f.patch diff --git a/gmp4/.pc/arm-asm-nothumb.patch/mpn/generic/div_qr_1n_pi1.c b/gmp4/.pc/arm-asm-nothumb.patch/mpn/generic/div_qr_1n_pi1.c new file mode 100644 index 0000000..229ee09 --- /dev/null +++ b/gmp4/.pc/arm-asm-nothumb.patch/mpn/generic/div_qr_1n_pi1.c @@ -0,0 +1,277 @@ +/* mpn_div_qr_1n_pi1 + + Contributed to the GNU project by Niels Möller + + THIS FILE CONTAINS INTERNAL FUNCTIONS WITH MUTABLE INTERFACES. IT IS ONLY + SAFE TO REACH THEM THROUGH DOCUMENTED INTERFACES. IN FACT, IT IS ALMOST + GUARANTEED THAT THEY'LL CHANGE OR DISAPPEAR IN A FUTURE GNU MP RELEASE. + + +Copyright 2013 Free Software Foundation, Inc. + +This file is part of the GNU MP Library. + +The GNU MP Library is free software; you can redistribute it and/or modify +it under the terms of either: + + * the GNU Lesser General Public License as published by the Free + Software Foundation; either version 3 of the License, or (at your + option) any later version. + +or + + * the GNU General Public License as published by the Free Software + Foundation; either version 2 of the License, or (at your option) any + later version. + +or both in parallel, as here. + +The GNU MP Library is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received copies of the GNU General Public License and the +GNU Lesser General Public License along with the GNU MP Library. If not, +see https://www.gnu.org/licenses/. */ + +#include "gmp.h" +#include "gmp-impl.h" +#include "longlong.h" + +#if GMP_NAIL_BITS > 0 +#error Nail bits not supported +#endif + +#ifndef DIV_QR_1N_METHOD +#define DIV_QR_1N_METHOD 2 +#endif + +/* FIXME: Duplicated in mod_1_1.c. Move to gmp-impl.h */ + +#if defined (__GNUC__) + +#if HAVE_HOST_CPU_FAMILY_x86 && W_TYPE_SIZE == 32 +#define add_mssaaaa(m, s1, s0, a1, a0, b1, b0) \ + __asm__ ( "add %6, %k2\n\t" \ + "adc %4, %k1\n\t" \ + "sbb %k0, %k0" \ + : "=r" (m), "=r" (s1), "=&r" (s0) \ + : "1" ((USItype)(a1)), "g" ((USItype)(b1)), \ + "%2" ((USItype)(a0)), "g" ((USItype)(b0))) +#endif + +#if HAVE_HOST_CPU_FAMILY_x86_64 && W_TYPE_SIZE == 64 +#define add_mssaaaa(m, s1, s0, a1, a0, b1, b0) \ + __asm__ ( "add %6, %q2\n\t" \ + "adc %4, %q1\n\t" \ + "sbb %q0, %q0" \ + : "=r" (m), "=r" (s1), "=&r" (s0) \ + : "1" ((UDItype)(a1)), "rme" ((UDItype)(b1)), \ + "%2" ((UDItype)(a0)), "rme" ((UDItype)(b0))) +#endif + +#if defined (__sparc__) && W_TYPE_SIZE == 32 +#define add_mssaaaa(m, sh, sl, ah, al, bh, bl) \ + __asm__ ( "addcc %r5, %6, %2\n\t" \ + "addxcc %r3, %4, %1\n\t" \ + "subx %%g0, %%g0, %0" \ + : "=r" (m), "=r" (sh), "=&r" (sl) \ + : "rJ" (ah), "rI" (bh), "%rJ" (al), "rI" (bl) \ + __CLOBBER_CC) +#endif + +#if defined (__sparc__) && W_TYPE_SIZE == 64 +#define add_mssaaaa(m, sh, sl, ah, al, bh, bl) \ + __asm__ ( "addcc %r5, %6, %2\n\t" \ + "addccc %r7, %8, %%g0\n\t" \ + "addccc %r3, %4, %1\n\t" \ + "clr %0\n\t" \ + "movcs %%xcc, -1, %0" \ + : "=r" (m), "=r" (sh), "=&r" (sl) \ + : "rJ" (ah), "rI" (bh), "%rJ" (al), "rI" (bl), \ + "rJ" ((al) >> 32), "rI" ((bl) >> 32) \ + __CLOBBER_CC) +#if __VIS__ >= 0x300 +#undef add_mssaaaa +#define add_mssaaaa(m, sh, sl, ah, al, bh, bl) \ + __asm__ ( "addcc %r5, %6, %2\n\t" \ + "addxccc %r3, %4, %1\n\t" \ + "clr %0\n\t" \ + "movcs %%xcc, -1, %0" \ + : "=r" (m), "=r" (sh), "=&r" (sl) \ + : "rJ" (ah), "rI" (bh), "%rJ" (al), "rI" (bl) \ + __CLOBBER_CC) +#endif +#endif + +#if HAVE_HOST_CPU_FAMILY_powerpc && !defined (_LONG_LONG_LIMB) +/* This works fine for 32-bit and 64-bit limbs, except for 64-bit limbs with a + processor running in 32-bit mode, since the carry flag then gets the 32-bit + carry. */ +#define add_mssaaaa(m, s1, s0, a1, a0, b1, b0) \ + __asm__ ( "add%I6c %2, %5, %6\n\t" \ + "adde %1, %3, %4\n\t" \ + "subfe %0, %0, %0\n\t" \ + "nor %0, %0, %0" \ + : "=r" (m), "=r" (s1), "=&r" (s0) \ + : "r" (a1), "r" (b1), "%r" (a0), "rI" (b0)) +#endif + +#if defined (__s390x__) && W_TYPE_SIZE == 64 +#define add_mssaaaa(m, s1, s0, a1, a0, b1, b0) \ + __asm__ ( "algr %2, %6\n\t" \ + "alcgr %1, %4\n\t" \ + "lghi %0, 0\n\t" \ + "alcgr %0, %0\n\t" \ + "lcgr %0, %0" \ + : "=r" (m), "=r" (s1), "=&r" (s0) \ + : "1" ((UDItype)(a1)), "r" ((UDItype)(b1)), \ + "%2" ((UDItype)(a0)), "r" ((UDItype)(b0)) __CLOBBER_CC) +#endif + +#if defined (__arm__) && W_TYPE_SIZE == 32 +#define add_mssaaaa(m, sh, sl, ah, al, bh, bl) \ + __asm__ ( "adds %2, %5, %6\n\t" \ + "adcs %1, %3, %4\n\t" \ + "movcc %0, #0\n\t" \ + "movcs %0, #-1" \ + : "=r" (m), "=r" (sh), "=&r" (sl) \ + : "r" (ah), "rI" (bh), "%r" (al), "rI" (bl) __CLOBBER_CC) +#endif +#endif /* defined (__GNUC__) */ + +#ifndef add_mssaaaa +#define add_mssaaaa(m, s1, s0, a1, a0, b1, b0) \ + do { \ + UWtype __s0, __s1, __c0, __c1; \ + __s0 = (a0) + (b0); \ + __s1 = (a1) + (b1); \ + __c0 = __s0 < (a0); \ + __c1 = __s1 < (a1); \ + (s0) = __s0; \ + __s1 = __s1 + __c0; \ + (s1) = __s1; \ + (m) = - (__c1 + (__s1 < __c0)); \ + } while (0) +#endif + +#if DIV_QR_1N_METHOD == 1 + +/* Divides (uh B^n + {up, n}) by d, storing the quotient at {qp, n}. + Requires that uh < d. */ +mp_limb_t +mpn_div_qr_1n_pi1 (mp_ptr qp, mp_srcptr up, mp_size_t n, mp_limb_t uh, + mp_limb_t d, mp_limb_t dinv) +{ + ASSERT (n > 0); + ASSERT (uh < d); + ASSERT (d & GMP_NUMB_HIGHBIT); + ASSERT (MPN_SAME_OR_SEPARATE_P (qp, up, n)); + + do + { + mp_limb_t q, ul; + + ul = up[--n]; + udiv_qrnnd_preinv (q, uh, uh, ul, d, dinv); + qp[n] = q; + } + while (n > 0); + + return uh; +} + +#elif DIV_QR_1N_METHOD == 2 + +mp_limb_t +mpn_div_qr_1n_pi1 (mp_ptr qp, mp_srcptr up, mp_size_t n, mp_limb_t u1, + mp_limb_t d, mp_limb_t dinv) +{ + mp_limb_t B2; + mp_limb_t u0, u2; + mp_limb_t q0, q1; + mp_limb_t p0, p1; + mp_limb_t t; + mp_size_t j; + + ASSERT (d & GMP_LIMB_HIGHBIT); + ASSERT (n > 0); + ASSERT (u1 < d); + + if (n == 1) + { + udiv_qrnnd_preinv (qp[0], u1, u1, up[0], d, dinv); + return u1; + } + + /* FIXME: Could be precomputed */ + B2 = -d*dinv; + + umul_ppmm (q1, q0, dinv, u1); + umul_ppmm (p1, p0, B2, u1); + q1 += u1; + ASSERT (q1 >= u1); + u0 = up[n-1]; /* Early read, to allow qp == up. */ + qp[n-1] = q1; + + add_mssaaaa (u2, u1, u0, u0, up[n-2], p1, p0); + + /* FIXME: Keep q1 in a variable between iterations, to reduce number + of memory accesses. */ + for (j = n-2; j-- > 0; ) + { + mp_limb_t q2, cy; + + /* Additions for the q update: + * +-------+ + * |u1 * v | + * +---+---+ + * | u1| + * +---+---+ + * | 1 | v | (conditional on u2) + * +---+---+ + * | 1 | (conditional on u0 + u2 B2 carry) + * +---+ + * + | q0| + * -+---+---+---+ + * | q2| q1| q0| + * +---+---+---+ + */ + umul_ppmm (p1, t, u1, dinv); + add_ssaaaa (q2, q1, -u2, u2 & dinv, CNST_LIMB(0), u1); + add_ssaaaa (q2, q1, q2, q1, CNST_LIMB(0), p1); + add_ssaaaa (q2, q1, q2, q1, CNST_LIMB(0), q0); + q0 = t; + + umul_ppmm (p1, p0, u1, B2); + ADDC_LIMB (cy, u0, u0, u2 & B2); + u0 -= (-cy) & d; + + /* Final q update */ + add_ssaaaa (q2, q1, q2, q1, CNST_LIMB(0), cy); + qp[j+1] = q1; + MPN_INCR_U (qp+j+2, n-j-2, q2); + + add_mssaaaa (u2, u1, u0, u0, up[j], p1, p0); + } + + q1 = (u2 > 0); + u1 -= (-q1) & d; + + t = (u1 >= d); + q1 += t; + u1 -= (-t) & d; + + udiv_qrnnd_preinv (t, u0, u1, u0, d, dinv); + add_ssaaaa (q1, q0, q1, q0, CNST_LIMB(0), t); + + MPN_INCR_U (qp+1, n-1, q1); + + qp[0] = q0; + return u0; +} + +#else +#error Unknown DIV_QR_1N_METHOD +#endif diff --git a/gmp4/AUTHORS b/gmp4/AUTHORS new file mode 100644 index 0000000..fbe298d --- /dev/null +++ b/gmp4/AUTHORS @@ -0,0 +1,100 @@ +Authors of GNU MP (in chronological order of initial contribution) + +Torbjörn Granlund Main author + +John Amanatides Original version of mpz/pprime_p.c + +Paul Zimmermann mpn/generic/mul_fft.c, now defunct dc_divrem_n.c, + rootrem.c, old mpz/powm.c, old toom3 code. + +Ken Weber Now defunct mpn/generic/bdivmod.c, old mpn/generic/gcd.c + +Bennet Yee Previous versions of mpz/jacobi.c mpz/legendre.c + +Andreas Schwab mpn/m68k/lshift.asm, mpn/m68k/rshift.asm + +Robert Harley Old mpn/generic/mul_n.c, previous versions of files in + mpn/arm + +Linus Nordberg Random number framework, original autoconfery + +Kent Boortz MacOS 9 port, now defunct. + +Kevin Ryde Most x86 assembly, new autoconfery, and countless other + things (please see the GMP manual for complete list) + +Gerardo Ballabio gmpxx.h and C++ istream input + +Pedro Gimeno Mersenne Twister random generator, other random number + revisions + +Jason Moxham Previous versions of mpz/fac_ui.c and gen-fac_ui.c + +Niels Möller gen-jacobitab.c, + mpn/generic/hgcd2.c, hgcd.c, hgcd_step.c, + hgcd_appr.c, hgcd_matrix.c, hgcd_reduce.c, + gcd.c, gcdext.c, matrix22_mul.c, + gcdext_1.c, gcd_subdiv_step.c, gcd_lehmer.c, + gcdext_subdiv_step.c, gcdext_lehmer.c, + jacobi_2.c, jacbase.c, hgcd_jacobi.c, hgcd2_jacobi.c + matrix22_mul1_inverse_vector.c, + toom_interpolate_7pts, mulmod_bnm1.c, dcpi1_bdiv_qr.c, + dcpi1_bdiv_q.c, sbpi1_bdiv_qr.c, sbpi1_bdiv_q.c, + sec_invert.c, + toom_eval_dgr3_pm1.c, toom_eval_dgr3_pm2.c, + toom_eval_pm1.c, toom_eval_pm2.c, toom_eval_pm2exp.c, + divexact.c, mod_1_1.c, div_qr_2.c, + div_qr_2n_pi1.c, div_qr_2u_pi1.c, broot.c, + brootinv.c, + mpn/x86/k7/invert_limb.asm, mod_1_1.asm, + mpn/x86_64/invert_limb.asm, + invert_limb_table.asm, mod_1_1.asm, + div_qr_2n_pi1.asm, div_qr_2u_pi1.asm, + mpn/x86_64/core2/aorsmul_1.asm, + mpz/nextprime.c, divexact.c, gcd.c, gcdext.c, + jacobi.c, combit.c, mini-gmp/mini-gmp.c. + +Marco Bodrato mpn/generic/toom44_mul.c, toom4_sqr.c, toom53_mul.c, + toom62_mul.c, toom43_mul.c, toom52_mul.c, toom54_mul.c, + toom_interpolate_6pts.c, toom_couple_handling.c, + toom63_mul.c, toom_interpolate_8pts.c, + toom6h_mul.c, toom6_sqr.c, toom_interpolate_12pts.c, + toom8h_mul.c, toom8_sqr.c, toom_interpolate_16pts.c, + mulmod_bnm1.c, sqrmod_bnm1.c, nussbaumer_mul.c, + toom_eval_pm2.c, toom_eval_pm2rexp.c, + mullo_n.c, invert.c, invertappr.c; + mpz/fac_ui.c, 2fac_ui.c, mfac_uiui.c, oddfac_1.c, + primorial_ui.c, prodlimbs.c, goetgheluck_bin_uiui.c. + +David Harvey mpn/generic/add_err1_n.c, add_err2_n.c, + add_err3_n.c, sub_err1_n.c, sub_err2_n.c, + sub_err3_n.c, mulmid_basecase.c, mulmid_n.c, + toom42_mulmid.c, + mpn/x86_64/mul_basecase.asm, aors_err1_n.asm, + aors_err2_n.asm, aors_err3_n.asm, + mulmid_basecase.asm, + mpn/x86_64/core2/aors_err1_n.asm. + +Martin Boij mpn/generic/perfpow.c + +Marc Glisse gmpxx.h improvements + +David Miller mpn/sparc32/ultrasparct1/{addmul_1,mul_1,submul_1}.asm + mpn/sparc64/ultrasparct3/{mul_1,addmul_1,submul_1}.asm + mpn/sparc64/ultrasparct3/{add_n,sub_n}.asm + mpn/sparc64/ultrasparct3/{popcount,hamdist}.asm + mpn/sparc64/ultrasparct3/cnd_aors_n.asm + mpn/sparc64/{rshift,lshift,lshiftc}.asm + mpn/sparc64/tabselect.asm + +Mark Sofroniou mpn/generic/mul_fft.c type cleanup. + +Ulrich Weigand Changes to support powerpc64le: + configure.ac, mpn/powerpc64/{elf,aix,darwin}.m4, + mpn/powerpc32/{darwin,elf}.m4, + mpn/powerpc64/mode64/{dive_1,divrem_1,divrem_2}.asm, + mpn/powerpc64/mode64/{gcd_1,invert_limb,mode1o}.asm, + mpn/powerpc64/mode64/{mod_1_1,mod_1_4}.asm, + mpn/powerpc64/mode64/p7/gcd_1.asm, + mpn/powerpc64/p6/{lshift,lshiftc,rshift}.asm, + mpn/powerpc64/vmx/popcount.asm. diff --git a/gmp4/COPYING b/gmp4/COPYING new file mode 100644 index 0000000..94a9ed0 --- /dev/null +++ b/gmp4/COPYING @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/gmp4/COPYING.LESSERv3 b/gmp4/COPYING.LESSERv3 new file mode 100644 index 0000000..fc8a5de --- /dev/null +++ b/gmp4/COPYING.LESSERv3 @@ -0,0 +1,165 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + + This version of the GNU Lesser General Public License incorporates +the terms and conditions of version 3 of the GNU General Public +License, supplemented by the additional permissions listed below. + + 0. Additional Definitions. + + As used herein, "this License" refers to version 3 of the GNU Lesser +General Public License, and the "GNU GPL" refers to version 3 of the GNU +General Public License. + + "The Library" refers to a covered work governed by this License, +other than an Application or a Combined Work as defined below. + + An "Application" is any work that makes use of an interface provided +by the Library, but which is not otherwise based on the Library. +Defining a subclass of a class defined by the Library is deemed a mode +of using an interface provided by the Library. + + A "Combined Work" is a work produced by combining or linking an +Application with the Library. The particular version of the Library +with which the Combined Work was made is also called the "Linked +Version". + + The "Minimal Corresponding Source" for a Combined Work means the +Corresponding Source for the Combined Work, excluding any source code +for portions of the Combined Work that, considered in isolation, are +based on the Application, and not on the Linked Version. + + The "Corresponding Application Code" for a Combined Work means the +object code and/or source code for the Application, including any data +and utility programs needed for reproducing the Combined Work from the +Application, but excluding the System Libraries of the Combined Work. + + 1. Exception to Section 3 of the GNU GPL. + + You may convey a covered work under sections 3 and 4 of this License +without being bound by section 3 of the GNU GPL. + + 2. Conveying Modified Versions. + + If you modify a copy of the Library, and, in your modifications, a +facility refers to a function or data to be supplied by an Application +that uses the facility (other than as an argument passed when the +facility is invoked), then you may convey a copy of the modified +version: + + a) under this License, provided that you make a good faith effort to + ensure that, in the event an Application does not supply the + function or data, the facility still operates, and performs + whatever part of its purpose remains meaningful, or + + b) under the GNU GPL, with none of the additional permissions of + this License applicable to that copy. + + 3. Object Code Incorporating Material from Library Header Files. + + The object code form of an Application may incorporate material from +a header file that is part of the Library. You may convey such object +code under terms of your choice, provided that, if the incorporated +material is not limited to numerical parameters, data structure +layouts and accessors, or small macros, inline functions and templates +(ten or fewer lines in length), you do both of the following: + + a) Give prominent notice with each copy of the object code that the + Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the object code with a copy of the GNU GPL and this license + document. + + 4. Combined Works. + + You may convey a Combined Work under terms of your choice that, +taken together, effectively do not restrict modification of the +portions of the Library contained in the Combined Work and reverse +engineering for debugging such modifications, if you also do each of +the following: + + a) Give prominent notice with each copy of the Combined Work that + the Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the Combined Work with a copy of the GNU GPL and this license + document. + + c) For a Combined Work that displays copyright notices during + execution, include the copyright notice for the Library among + these notices, as well as a reference directing the user to the + copies of the GNU GPL and this license document. + + d) Do one of the following: + + 0) Convey the Minimal Corresponding Source under the terms of this + License, and the Corresponding Application Code in a form + suitable for, and under terms that permit, the user to + recombine or relink the Application with a modified version of + the Linked Version to produce a modified Combined Work, in the + manner specified by section 6 of the GNU GPL for conveying + Corresponding Source. + + 1) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (a) uses at run time + a copy of the Library already present on the user's computer + system, and (b) will operate properly with a modified version + of the Library that is interface-compatible with the Linked + Version. + + e) Provide Installation Information, but only if you would otherwise + be required to provide such information under section 6 of the + GNU GPL, and only to the extent that such information is + necessary to install and execute a modified version of the + Combined Work produced by recombining or relinking the + Application with a modified version of the Linked Version. (If + you use option 4d0, the Installation Information must accompany + the Minimal Corresponding Source and Corresponding Application + Code. If you use option 4d1, you must provide the Installation + Information in the manner specified by section 6 of the GNU GPL + for conveying Corresponding Source.) + + 5. Combined Libraries. + + You may place library facilities that are a work based on the +Library side by side in a single library together with other library +facilities that are not Applications and are not covered by this +License, and convey such a combined library under terms of your +choice, if you do both of the following: + + a) Accompany the combined library with a copy of the same work based + on the Library, uncombined with any other library facilities, + conveyed under the terms of this License. + + b) Give prominent notice with the combined library that part of it + is a work based on the Library, and explaining where to find the + accompanying uncombined form of the same work. + + 6. Revised Versions of the GNU Lesser General Public License. + + The Free Software Foundation may publish revised and/or new versions +of the GNU Lesser General Public License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. + + Each version is given a distinguishing version number. If the +Library as you received it specifies that a certain numbered version +of the GNU Lesser General Public License "or any later version" +applies to it, you have the option of following the terms and +conditions either of that published version or of any later version +published by the Free Software Foundation. If the Library as you +received it does not specify a version number of the GNU Lesser +General Public License, you may choose any version of the GNU Lesser +General Public License ever published by the Free Software Foundation. + + If the Library as you received it specifies that a proxy can decide +whether future versions of the GNU Lesser General Public License shall +apply, that proxy's public statement of acceptance of any version is +permanent authorization for you to choose that version for the +Library. diff --git a/gmp4/COPYINGv2 b/gmp4/COPYINGv2 new file mode 100644 index 0000000..d159169 --- /dev/null +++ b/gmp4/COPYINGv2 @@ -0,0 +1,339 @@ + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Lesser General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License along + with this program; if not, write to the Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) year name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. diff --git a/gmp4/COPYINGv3 b/gmp4/COPYINGv3 new file mode 100644 index 0000000..2a00065 --- /dev/null +++ b/gmp4/COPYINGv3 @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/gmp4/ChangeLog b/gmp4/ChangeLog new file mode 100644 index 0000000..540c025 --- /dev/null +++ b/gmp4/ChangeLog @@ -0,0 +1,32941 @@ +2014-03-24 Torbjorn Granlund + + * Version 6.0.0 released. + + * mpn: Update countless gmp-mparam.h files. + +2014-03-22 Torbjorn Granlund + + * Makefile.am (LIBGMP_LT_*, LIBGMPXX_LT_*): Bump version info. + * gmp-h.in: Bump version. + +2014-03-17 Torbjorn Granlund + + * configure.ac: Remove clipper, i960, ns32k, pyr, a29k, z8000. + * mpn/clipper: Remove directory and all its files. + * mpn/i960: Likewise. + * mpn/ns32k: Likewise. + * mpn/pyr: Likewise. + * mpn/a29k: Likewise. + * mpn/z8000: Likewise. + * mpn/Makefile.am (TARG_DIST): Purge removed directories. + * doc/gmp.texi: Remove special mentions of removed architectures. + +2014-03-12 Marco Bodrato + + * mini-gmp/mini-gmp.c (mpz_probab_prime_p): Micro-optimisation. + +2014-03-12 Torbjorn Granlund + + * mpn/x86/bd2/gmp-mparam.h: New file. + * mpn/x86_64/bd2/gmp-mparam.h: New file. + +2014-03-06 Niels Möller + + * tests/mpz/t-pprime_p.c (check_composites): New function. + (check_primes): New function. + (main): Call them. Also use TESTS_REPS. + + * mini-gmp/mini-gmp.c (gmp_millerrabin): New internal function. + (mpz_probab_prime_p): New function. + * mini-gmp/mini-gmp.h (mpz_probab_prime_p): Declare it. + * mini-gmp/tests/t-pprime_p.c: New test program. + * mini-gmp/tests/Makefile (CHECK_PROGRAMS): Added t-pprime_p. + +2014-03-03 Niels Möller + + * mini-gmp/mini-gmp.c (mpz_congruent_p): New function. + * mini-gmp/mini-gmp.h: Declare it. + * mini-gmp/tests/t-cong.c: New file, based on tests/mpz/t-cong.c. + * mini-gmp/tests/Makefile (CHECK_PROGRAMS): Added t-cong. + + * mini-gmp/tests/testutils.c (dump): New function. Deleted static + functions in other files. + (mpz_set_str_or_abort): Moved function here, from... + * mini-gmp/tests/t-cmp_d.c: ... old location. + + * mini-gmp/tests/t-reuse.c (dump3): Renamed, from ... + (dump): ...old name. + +2014-03-01 Niels Möller + + * mpn/generic/sec_powm.c (mpn_sec_powm): Clarify comment and + asserts. + +2014-02-28 Torbjorn Granlund + + * mpn/x86_64/fat/fat.c (fake_cpuid): Handle id 7, make bold claims. + +2014-02-27 Torbjorn Granlund + + * mpn/x86_64/fat/fat_entry.asm: Zero ecx for the benefit of new BMI2 + feature test. + + * mpn/x86_64/fat/fat.c (__gmpn_cpuvec_init): Run CPUVEC_SETUP_coreihwl + conditionally on BMI2 availability. + + * config.guess: Revert "coreihwl" to "coreisbr" if cpuid indicates that + BMI2 is missing. + (x86 cpuid, 2 variants): Zero ecx for the benefit of new BMI2 feature + test. + +2014-02-21 Marco Bodrato + + * mini-gmp/mini-gmp.c (mpn_sqrtrem): New function. + * mini-gmp/mini-gmp.h: Declare it. + * mini-gmp/tests/t-sqrt.c: Test it. + +2014-02-17 Niels Möller + + * mpn/generic/div_qr_1.c (mpn_div_qr_1): Revert yesterday's fix. + Hopefully no longer needed. + + * mpn/s390_64/gmp-mparam.h (DIV_QR_1_NORM_THRESHOLD): Up to 1. + * mpn/s390_64/z10/gmp-mparam.h (DIV_QR_1_NORM_THRESHOLD): Up to 1. + + * tune/tuneup.c (tune_div_qr_1): Ensure DIV_QR_1_NORM_THRESHOLD, + DIV_QR_1_UNNORM_THRESHOLD >= 1. + +2014-02-16 Marco Bodrato + + * mpn/generic/div_qr_1.c: Disallow DIV_QR_1_NORM_THRESHOLD==0. + +2014-02-15 Torbjorn Granlund + + * tests/mpn/t-div.c: Fix typo. + +2014-02-15 Marco Bodrato + + * doc/gmp.texi (mpz_roinit_n, MPZ_ROINIT_N): Document that + at least a readable limb is required. + * mini-gmp/mini-gmp.c (mpz_div_qr): init + set = init_set . + +2014-02-14 Niels Möller + + * doc/gmp.texi (Low-level Functions): Update docs for + mpn_sec_powm, to specify that left-over exponent bits must be + zero. + +2014-02-11 Niels Möller + + * Makefile.am (EXTRA_DIST): Distribute COPYING.LESSERv3, + COPYINGv2, and COPYINGv3. + + * doc/gmp.texi (Low-level Functions): Updated mpn_sec_powm docs. + + * mpn/generic/sec_powm.c (mpn_sec_powm): Replaced exponent limb + count argument by bit count. Don't leak high exponent bits, and + drop the requirement that the most significant exponent limb is + non-zero. + (mpn_sec_powm_itch): Analogous interface change. + * gmp-h.in: Updated prototypes. + * mpz/powm_sec.c (mpz_powm_sec): Update mpn_sec_powm* calls. + * tune/tuneup.c (tune_powm_sec): Likewise. Also deleted code + fiddling with the high exponent bits. + +2014-02-10 Marco Bodrato + + * mini-gmp/tests/t-limbs.c: New test for mpz_limbs_*. + * mini-gmp/tests/Makefile (CHECK_PROGRAMS): Add it. + +2014-02-09 Niels Möller + + * tune/tuneup.c (tune_powm_sec): Avoid timing of the nonsensical + parameters nbits = 1, winsize = 2. Decrement tabulated values, to + better match the > comparison when the table is used. + + * mpn/generic/sec_powm.c (win_size): Comment why we always get + win_size(eb) <= eb. Make the table const. + (mpn_sec_powm): Deleted handling of winsize > initial ebi. For + now, replaced with an ASSERT_ALWAYS. + +2014-02-08 Marco Bodrato + + * mini-gmp/mini-gmp.c (mpz_realloc2, mpz_limbs_read, mpz_limbs_modify + mpz_limbs_write, mpz_limbs_finish, mpz_roinit_n): New functions. + (mpn_perfect_square_p): New function. + * mini-gmp/mini-gmp.h: Declare them. + + * mini-gmp/tests/t-mul.c: Use roinit and limbs_read to test mpn. + * mini-gmp/tests/t-sqrt.c: Test also mpn_perfect_square_p. + +2014-02-08 Niels Möller + + * mpn/generic/sec_invert.c (mpn_cnd_neg_itch): #if:ed out unused + function. + + * mpn/generic/sec_div.c: Simplified code for the normalized case. + + * tests/mpn/t-div.c (main): Test mpn_sec_div_qr and mpn_sec_div_r + with normalized d. + +2014-02-04 Niels Möller + + * doc/gmp.texi (Low-level Functions): Document mpn_sec_add_1 and + mpn_sec_sub_1. + +2014-02-03 Marco Bodrato + + * mini-gmp/mini-gmp.c (mpn_rootrem): Allow NULL argument. + + * mini-gmp/mini-gmp.c (mpn_zero): New function. + (mpz_perfect_square_p): New function. + * mini-gmp/mini-gmp.h: Declare them. + + * mini-gmp/tests/t-sqrt.c: Test mpz_perfect_square_p. + * mini-gmp/tests/t-root.c: Test also 1-th root, allow perfect powers. + +2014-01-29 Torbjorn Granlund + + * doc/gmp.texi (Floating-point Functions): Revise. + +2014-01-29 Niels Möller + + * README: Don't refer to specific COPYING* files, instead refer to + manual for details. + + * COPYING.LIB: Renamed, to... + * COPYING.LESSERv3: ... new name. + * COPYING: Renamed, to... + * COPYINGv3: ... new name. + * COPYINGv2: New file, GPLv2. + + * doc/gmp.texi (Copying): Document dual licensing. + +2014-01-27 Torbjorn Granlund + + * Update library files license to use LGPL3+ and GPL2+. + +2014-01-27 Marco Bodrato + + * tests/mpn/t-aors_1.c: Check sec_aors_1 red zones (not smart). + + * mpn/generic/sec_aors_1.c: Mark the 2nd argument as const. + * gmp-h.in (mpn_sec_add_1, mpn_sec_sub_1): Likewise. + +2014-01-24 Torbjorn Granlund + + * mpn/x86_64/fat/fat.c (fake_cpuid_table): Use proper steamroller and + excavator values. + + * config.guess: Amend last AMD change. + + * mpn/s390_64/lshift.asm: Align loop. + * mpn/s390_64/rshift.asm: Likewise. + * mpn/s390_64/lshiftc.asm: Likewise. + * mpn/s390_64: Add z10 cycle numbers. + +2014-01-23 Marco Bodrato + + * printf/repl-vsnprintf.c: Feed case 'z' in switch (type) with case 'z' + in switch (fchar). + + * mini-gmp/tests/t-aorsmul.c: New file, test for mpz_{add,sub}mul{,_ui} + * mini-gmp/tests/Makefile: Add t-aorsmul. + +2014-01-21 Marco Bodrato + + * acinclude.m4 (GMP_FUNC_VSNPRINTF): Get rid of varargs. + +2014-01-20 Torbjorn Granlund + + * mpn/x86_64/fat/fat.c (__gmpn_cpuvec_init): Fix duplicate entries for + AMD "jaguar". + + * demos/expr: Get rid of varargs code and references. + +2014-01-19 Torbjorn Granlund + + * config.guess: Add new AMD CPUs (piledriver, steamroller, excavator, + jaguar). + * config.sub: Corresponding updates. + * configure.ac: Likewise. + * acinclude.m4 (X86_64_PATTERN): Likewise. + * mpn/x86_64/fat/fat.c: Likewise. + + * Rename mpn_sec_minvert => mpn_sec_invert, many files affected. + * mpn/generic/sec_invert.c: New name for sec_minvert.c. + + * doc/gmp.texi: Undocument mpz_array_init. + + * acinclude.m4 (GMP_C_STDARG): Comment out. + * configure.ac: Suppress GMP_C_STDARG invocation. + + * Get rid of varargs code and references, many file affected. + + * Use mpq_t in favour of MP_RAT, many mpq files affected. + + * Get rid of BYTES_PER_MP_LIMB, most files affected. + + * mpz/iset.c: Avoid overflow in allocation computation. + * mpz/mul.c: Likewise. + * mpf/init.c: Likewise. + * mpf/init2.c: Likewise. + * mpf/iset.c: Likewise. + * mpf/iset_d.c: Likewise. + * mpf/iset_si.c: Likewise. + * mpf/iset_str.c: Likewise. + * mpf/iset_ui.c: Likewise. + + * mpz/array_init.c: Avoid two overflow scenarios in allocation + computation. + + * mpn/s390_64/z10/gmp-mparam.h: New file. + + * mpz/clears.c: Call __gmp_free_func ourselves instead of via + mpz_clears. + * mpf/clears.c: Analogous change. + * mpq/clears.c: Analogous change. + + * mpz/clear.c: Add cast to avoid overflow of (later ignored) argument. + * mpf/clear.c: Likewise. + +2014-01-19 Marco Bodrato + + * mini-gmp/mini-gmp.c (mpn_popcount): New function. + (mpz_popcount): Use it. + (mpz_addmul_ui, mpz_addmul, mpz_submul_ui, mpz_submul): Added. + * mini-gmp/mini-gmp.h: Declare them. + +2014-01-18 Niels Möller + + * tests/mpn/t-aors_1.c: Test also mpn_sec_add_1 and mpn_sec_sub_1. + + * tests/mpn/t-minvert.c (main): Pass smallest allowed bit_size + argument to mpn_sec_minvert. + +2014-01-18 Marc Glisse + + * doc/gmp.texi (C++ Interface Limitations): Warn against C++11 auto. + +2014-01-18 Marco Bodrato + + * tests/t-parity.c: Use 1UL to generate unsigned constants. + * tests/t-constants.c: Disable a non portable (unneeded) check. + +2014-01-18 Niels Möller + + * mpn/generic/sec_aors_1.c (mpn_sec_add_1, mpn_sec_sub_1): New + file. + + * mpn/generic/sec_minvert.c (mpn_sec_add_1_itch, mpn_sec_add_1): + Deleted static definitions. + (mpn_cnd_swap): Use volatile. + + * configure.ac (gmp_mpn_functions): sec_add_1 and sec_sub_1. + (GMP_MULFUNC_CHOICES): Set up for sec_aors_1. + +2014-01-16 Niels Möller + + * tune/common.c (speed_mpn_sec_minvert): New function. + * tune/speed.h: Declare it. + (SPEED_ROUTINE_MPN_SEC_MINVERT): New macro. + * tune/speed.c (routine): Added mpn_sec_minvert. + + * mini-gmp/mini-gmp.c (mp_bits_per_limb): New const value. + * mini-gmp/mini-gmp.h: Declare it. + +2014-01-12 Marc Glisse + + * demos/expr/expr.h: Add extern "C" for C++. + +2014-01-11 Torbjorn Granlund + + * doc/gmp.texi (Notes for Particular Systems): Add items about old + NetBSD and current FreeBSD m4 problems. Add item about FreeBSD's + broken limits.h. + +2014-01-05 Marco Bodrato + + * gmp-impl.h: Declare all _itch functions using ATTRIBUTE_CONST. + +2014-01-05 Torbjorn Granlund + + * configure.ac (alpha): Set extra_functions conditionally. + + * gmp-h.in (mpn_sec_minvert): Remove formal parameters. + + * doc/gmp.texi: Improve doc for several functions. + + * mpn/generic/sec_tabselect.c: Declare input arg using 'const'. + * gmp-h.in: Analogous change. + + * gmp-h.in: Declare all itch functions using __GMP_ATTRIBUTE_PURE. + * gmp-impl.h: Likewise. + +2014-01-05 Marco Bodrato + + * tests/mpn/t-minvert.c: Always compare with mpz_invert results, + add red zone to scratch. + * tests/mpn/t-sizeinbase.c: New test. + * tests/mpn/Makefile.am (check_PROGRAMS): Added t-sizeinbase.c . + * tests/mpn/t-div.c: Use mpn_sec_div_*_itch(). + + * mpn/generic/pow_1.c: Micro-optimisation. + +2014-01-04 Torbjorn Granlund + + * acinclude.m4 (GMP_PROG_M4): Avoid hex output, since case varies. + +2014-01-03 Torbjorn Granlund + + * config.guess: Support newer haswell, broadwell, silvermont. + * mpn/x86_64/fat/fat.c (__gmpn_cpuvec_init): Likewise. + + * acinclude.m4 (GMP_PROG_M4): Check that eval's radix argument work. + + * mpz/invert.c: Rely on gcdext for all operands, removing faulty + special case. + * tests/mpz/t-invert.c: Enforce correct behaviour for |mod| = 1. + +2014-01-02 Niels Möller + + * doc/gmp.texi (Low-level Functions): Document mpn_sizeinbase. + + Enable previously unused mpn_sizeinbase function. + * configure.ac (gmp_mpn_functions): Added sizeinbase. + * gmp-h.in (mpn_sizeinbase): New prototype. + +2014-01-02 Marc Glisse + + * gmp-impl.h: Always include . + * tests/mpn/t-get_d.c: Remove comment about + + * gmp-h.in (__GMP_USHRT_MAX): Use the promoted type. + * gmp-impl.h (USHRT_HIGHBIT, SHRT_MIN, SHRT_MAX): Likewise. + * tests/t-constants.c: Adapt printf strings. + * tests/t-gmpmax.c: Likewise. + + * tests/mpn/t-hgcd_appr.c (hgcd_appr_valid_p): Add parentheses. + +2014-01-01 Torbjorn Granlund + + * doc/gmp.texi (Low-level Functions for cryptography): Update interface + for mpn_sec_div_qr and fix typos in mpn_sec_minvert text. + + * mpn/generic/sec_div.c: Rewrite to make mpn_sec_div_qr return high + quotient limb. + * gmp-h.in (mpn_sec_div_qr): Update declaration. + * tests/mpn/t-div.c: Adapt. + +2013-12-31 Niels Möller + + * doc/gmp.texi (Low-level Functions for cryptography): Document + mpn_sec_minvert. + +2013-12-30 Marc Glisse + + * doc/gmp.texi (C++ interface internals): Break long line. + +2013-12-30 Torbjorn Granlund + + * doc/gmp.texi (Low-level Functions for cryptography): New section. + +2013-12-29 Niels Möller + + * tests/mpn/Makefile.am (check_PROGRAMS): Added t-minvert. + * tests/mpn/t-minvert.c: New file. + + * configure.ac (gmp_mpn_functions): Added sec_minvert. + * gmp-h.in (mpn_sec_minvert, mpn_sec_minvert_itch): New + declarations. + * mpn/generic/sec_minvert.c (mpn_sec_minvert) + (mpn_sec_minvert_itch): New functions. + (mpn_sec_add_1, mpn_cnd_neg, mpn_cnd_swap, mpn_sec_eq_ui): New + helper functions. + +2013-12-28 Torbjorn Granlund + + * mpn/generic/sec_powm.c: Fix an ASSERT. + + * gmp-h.in (mpn_sec_mul, mpn_sec_mul_itch): New declarations. + * gmp-h.in (mpn_sec_sqr, mpn_sec_sqr_itch): Likewise. + * mpn/generic/sec_mul.c: New file. + * mpn/generic/sec_sqr.c: New file. + + * gmp-h.in (mpn_sec_powm, mpn_sec_powm_itch): New declarations. + * gmp-h.in (mpn_sec_div_qr, mpn_sec_div_qr_itch): Likewise. + * gmp-h.in (mpn_sec_div_r, mpn_sec_div_r_itch): Likewise. + * gmp-impl: Remove declarations of above functions. + + * configure.ac (gmp_mpn_functions): Add sec_mul and sec_sqr. + +2013-12-26 Marco Bodrato + + * Update many file's encoding to UTF-8. + * doc/tasks.html: Update accordingly. + * doc/projects.html: Likewise. + +2013-12-26 Torbjorn Granlund + + * configure.ac: Rename mpn_blah_sec to mpn_sec_blah. + * gmp-impl.h: Corresponding changes. + * mpn/asm-defs.m4: Corresponding changes. + * tune/Makefile.am: Corresponding changes. + * tune/common.c: Corresponding changes. + * tune/speed.c: Corresponding changes. + * tune/speed.h: Corresponding changes. + * tune/tuneup.c: Corresponding changes. + * mpz/powm_sec.c: Update calls. + * tests/mpn/t-div.c: Likewise. + + * mpn/generic/sec_powm.c: New name for mpn/generic/powm_sec.c. + * mpn/generic/sec_div.c: New name for mpn/generic/sb_div_sec.c. + * mpn/generic/sec_pi1_div.c: New name for mpn/generic/sbpi1_div_sec.c. + * mpn/generic/sec_tabselect.c: New name for mpn/generic/tabselect.c. + + * mpn/alpha/sec_tabselect.asm: New name for tabselect.asm. + * mpn/arm/neon/sec_tabselect.asm: New name for tabselect.asm. + * mpn/arm/sec_tabselect.asm: New name for tabselect.asm. + * mpn/ia64/sec_tabselect.asm: New name for tabselect.asm + * mpn/powerpc32/sec_tabselect.asm: New name for tabselect.asm + * mpn/powerpc64/sec_tabselect.asm: New name for tabselect.asm + * mpn/sparc64/sec_tabselect.asm: New name for tabselect.asm + * mpn/x86/mmx/sec_tabselect.asm: New name for tabselect.asm + * mpn/x86/sec_tabselect.asm: New name for tabselect.asm + * mpn/x86_64/bd1/sec_tabselect.asm: New name for tabselect.asm + * mpn/x86_64/core2/sec_tabselect.asm: New name for tabselect.asm + * mpn/x86_64/coreinhm/sec_tabselect.asm: New name for tabselect.asm + * mpn/x86_64/coreisbr/sec_tabselect.asm: New name for tabselect.asm + * mpn/x86_64/fastsse/sec_tabselect.asm: New name for tabselect.asm + * mpn/x86_64/k10/sec_tabselect.asm: New name for tabselect.asm + * mpn/x86_64/pentium4/sec_tabselect.asm: New name for tabselect.asm + * mpn/x86_64/sec_tabselect.asm: New name for tabselect.asm + +2013-12-25 Torbjorn Granlund + + * mpz/powm_sec.c: Handle 0^e mod m specially. + * mpn/generic/powm_sec.c: ASSERT that the base is non-zero. + +2013-12-23 Torbjorn Granlund + + * mpn/generic/powm_sec.c (redcify): Use passed scratch instead of + locally allocated. + (mpn_powm_sec_itch): Accommodate mpn_sb_div_r_sec's scratch needs. + +2013-12-20 Mark Sofroniou + + * mpn/generic/mul_fft.c: Major overhaul of types. + +2013-12-18 Torbjorn Granlund + + * doc/gmp.texi (Low-level Functions): Rewrite mpn_set_str docs. + +2013-12-14 Ulrich Weigand + + * mpn/powerpc32/darwin.m4: Allow (and ignore) optional + 'toc' parameter to PROLOGUE_cpu. + * mpn/powerpc32/elf.m4: Likewise. + +2013-12-09 Ulrich Weigand + + * configure.ac: Check for ELFv2 ABI on PowerPC. + * mpn/powerpc64/elf.m4: Set assembler ABI version for ELFv2 + and use appropriate PROLOGUE_cpu/EPILOGUE_cpu sequences. + Support optional 'toc' parameter to PROLOGUE_cpu. + * mpn/powerpc64/aix.m4: Allow (and ignore) optional + 'toc' parameter to PROLOGUE_cpu. + * mpn/powerpc64/darwin.m4: Likewise. + + * mpn/powerpc64/mode64/dive_1.asm (mpn_divexact_1): Add 'toc' + parameter to PROLOGUE. + * mpn/powerpc64/mode64/divrem_1.asm (mpn_divrem_1): Likewise. + * mpn/powerpc64/mode64/divrem_2.asm (mpn_divrem_2): Likewise. + * mpn/powerpc64/mode64/gcd_1.asm (mpn_gcd_1): Likewise. + * mpn/powerpc64/mode64/invert_limb.asm (mpn_invert_limb): Likewise. + * mpn/powerpc64/mode64/mod_1_1.asm (mpn_mod_1_1p_cps): Likewise. + * mpn/powerpc64/mode64/mod_1_4.asm (mpn_mod_1s_4p_cps): Likewise. + * mpn/powerpc64/mode64/mode1o.asm (mpn_modexact_1c_odd): Likewise. + * mpn/powerpc64/mode64/p7/gcd_1.asm (mpn_gcd_1): Likewise. + * mpn/powerpc64/p6/lshift.asm (mpn_lshift): Likewise. + * mpn/powerpc64/p6/lshiftc.asm (mpn_lshiftc): Likewise. + * mpn/powerpc64/p6/rshift.asm (mpn_rshift): Likewise. + * mpn/powerpc64/vmx/popcount.asm (mpn_popcount): Likewise. + +2013-12-07 Niels Möller + + * configfsf.sub: Updated to version 2013-10-01, from gnulib. + * configfsf.guess: Updated to version 2013-11-29, from gnulib. + +2013-12-03 Torbjorn Granlund + + * mpn/generic/div_qr_1.c: Make constant args asm inlines become limbs. + * mpn/generic/div_qr_1n_pi1.c: Likewise. + * mpn/generic/div_qr_2.c: Likewise. + * mpn/generic/div_qr_2.c: Likewise. + * mpn/generic/mod_1_1.c: Likewise. + * mpn/generic/mod_1_2.c: Likewise. + * mpn/generic/mod_1_3.c: Likewise. + * mpn/generic/mod_1_4.c: Likewise. + * mpn/generic/mulmid_basecase.c: Likewise. + * mpn/generic/mulmod_bnm1.c: Likewise. + * mpn/generic/sqrmod_bnm1.c: Likewise. + * mpn/sparc64/divrem_1.c: Likewise. + * mpn/sparc64/mod_1_4.c: Likewise. + + * mpn/generic/toom_interpolate_7pts.c (BINVERT_15): Fix typo. + +2013-11-11 Torbjorn Granlund + + * mpn/x86_64/dos64.m4 (CALL): Provide to override default. + +2013-11-08 Torbjorn Granlund + + * mpn/x86_64/x86_64-defs.m4 (CALL): Swap PIC test and macro defn. + + * mpn/generic/div_qr_2.c: Test HAVE_HOST_CPU_FAMILY_x86, not i386. + + * doc/gmp.texi: Update many URLs. + +2013-11-04 Torbjorn Granlund + + * configure.ac: Set symbol OPENBSD for x86-openbsd hosts. + * mpn/x86_64/fat/fat_entry.asm (PRETEND_PIC): New name for + PIC_OR_DARWIN. + (PRETEND_PIC): Set also for OPENBSD. + +2013-10-29 Torbjorn Granlund + + * printf/doprnt.c (__gmp_doprnt): Use memcpy instead of strcpy. + +2013-10-24 Torbjorn Granlund + + * mpn/generic/div_qr_1u_pi2.c: New file. + * mpn/generic/div_qr_1n_pi2.c: New file. + +2013-10-24 Niels Möller + + * mpn/x86_64/div_qr_1n_pi1.asm: Bugfixes, for case n == 1 and + in-place operation. + * mpn/x86_64/k8/div_qr_1n_pi1.asm: Likewise. + + * mpn/generic/div_qr_1n_pi1.c (mpn_div_qr_1n_pi1): Bug fixes, + off-by-one MPN_INCR_U, and support for in-place operation. + +2013-10-24 Torbjorn Granlund + + * mpn/x86/fat/fat.c (fake_cpuid_table): Add Haswell. + +2013-10-23 Torbjorn Granlund + + * mpn/x86_64/x86_64-defs.m4 (oplist): New define, data from `regnum'. + (regnum): Use x86_lookup, feed oplist. + +2013-10-22 Niels Möller + + * tests/devel/try.c: Support mpn_div_qr_1n_pi1. + + * mpn/x86_64/k8/div_qr_1n_pi1.asm: Moved the below k10 file here. + Applied tweak from Torbjörn to get it to run well on k8. + + * mpn/x86_64/k10/div_qr_1n_pi1.asm: New file (renamed above). + Differs from generic x86_64 version by using cmov. + + * mpn/x86_64/div_qr_1n_pi1.asm: Reordered arguments to second mul. + Deleted misleading cycle annotations. + +2013-10-21 Niels Möller + + * configure.ac: Add HAVE_NATIVE_mpn_div_qr_1n_pi1 to config.in. + + * mpn/generic/div_qr_1n_pi1.c (mpn_div_qr_1n_pi1): Fix typos + affecting ASSERT. + +2013-10-20 Niels Möller + + * mpn/x86_64/div_qr_1n_pi1.asm: New file. + + * tune/div_qr_1_tune.c (__gmpn_div_qr_1n_pi1): Check + div_qr_1n_pi1_method only when !HAVE_NATIVE_mpn_div_qr_1n_pi1. + + * mpn/asm-defs.m4 (define_mpn): Add div_qr_1n_pi1. + + * tune/common.c (speed_mpn_div_qr_1): New function, replacing... + (speed_mpn_div_qr_1n, speed_mpn_div_qr_1u): ... deleted functions + (speed_mpn_div_qr_1n_pi1, speed_mpn_div_qr_1n_pi1_1) + (speed_mpn_div_qr_1n_pi1_2): New functions. + * gmp-impl.h [TUNE_PROGRAM_BUILD]: Declare div_qr_1-related tuning + variables. + * tune/tuneup.c (speed_mpn_div_qr_1_tune, tune_div_qr_1): New + functions. + (div_qr_1n_pi1_method, div_qr_1_norm_threshold) + (div_qr_1_unnorm_threshold): New globals. + * tune/speed.c (routine): Replaced mpn_div_qr_1n and mpn_div_qr_1u + by mpn_div_qr_1, requiring ".r" parameter. Added mpn_div_qr_1n_pi1 + and variants. + * tune/speed.h (SPEED_ROUTINE_MPN_DIV_QR_1): Use the "r" parameter + as divisor. + * tune/div_qr_1n_pi1_2.c: New file. + * tune/div_qr_1n_pi1_1.c: New file. + * tune/div_qr_1_tune.c: New file. + * tune/Makefile.am (libspeed_la_SOURCES): Added div_qr_1n_pi1_1.c, + div_qr_1n_pi1_2.c, and div_qr_1_tune.c. + + * tune/speed.c (routine): Added mpn_div_qr_1n and mpn_div_qr_1u. + * tune/speed.h (SPEED_ROUTINE_MPN_DIV_QR_1): New macro. + (speed_mpn_div_qr_1n, speed_mpn_div_qr_1u): Declare. + * tune/common.c (speed_mpn_div_qr_1n, speed_mpn_div_qr_1u): New + functions. + + * gmp-impl.h (mpn_div_qr_1n_pi1): Declare function. + * gmp-h.in (mpn_div_qr_1): Declare function. + * configure.ac (gmp_mpn_functions): Added div_qr_1 and + div_qr_1n_pi1. + * mpn/generic/div_qr_1.c (mpn_div_qr_1): New file and function. + * mpn/generic/div_qr_1n_pi1.c (mpn_div_qr_1n_pi1): New file and + function. + * tests/mpn/t-div.c (main): Test mpn_div_qr_1. + +2013-10-17 Torbjorn Granlund + + * configure.ac (alpha): Pass -mieee via gcc_cflags_maybe. + +2013-10-16 Torbjorn Granlund + + * config.guess: Let AMD64 cpuid bit override pessimistic cpu guesses. + + * mpn/alpha/unicos.m4 (DATASTART): Accept optional align parameter. + * mpn/alpha/divrem_2.asm: Use provided gp mechanisms. + * mpn/alpha/default.m4 (PROLOGUE): Provide "..ng" post-gp label. + * mpn/alpha/invert_limb.asm: Align table to 8-byte boundary. Make code + work if table is not fully aligned. Properly test for BWX. + +2013-10-15 Torbjorn Granlund + + * mpn/alpha/default.m4 (DATASTART): Use RODATA instead of DATA; + accept optional align parameter. + * mpn/alpha/invert_limb.asm: Align table. + * mpn/alpha/ev5/diveby3.asm: Likewise. + +2013-10-11 Torbjorn Granlund + + * mpn/x86/k7/mod_1_1.asm: Use 'subl' form to avoid ambiguity. + * mpn/x86/k7/mod_1_4.asm: Likewise. + + * configure.ac (X86_64_PATTERN): Append "cc" to cclist_64 and + cclist_x32. + +2013-10-08 Torbjorn Granlund + Marc Glisse + + * tests/mpf/reuse.c (main): Compare addresses instead of names. + Use larger numbers for exponents. + +2013-10-08 Marc Glisse + + * doc/mdate-sh, doc/texinfo.tex, install-sh, missing, ylwrap: Remove. + * .bootstrap: Use autoreconf (and in particular automake -a). + + * gmp-h.in: Remove __need_size_t. Include , not . + + * tests/mpf/reuse.c (main): Use small numbers as exponents. + +2013-10-05 Torbjorn Granlund + + * mpn/x86_64/atom/aorsmul_1.asm: Slight tweak. + + * doc/gmp.texi (ABI and ISA): Document x32. + + * mpn/sparc64/ultrasparct3/dive_1.asm: Use our register names. + +2013-09-24 Torbjorn Granlund + + * mpn/x86_64/atom/redc_1.asm: New file. + +2013-09-23 Torbjorn Granlund + + * mpn/x86_64/bobcat/redc_1.asm: Make the code for 1 <= n <= 3 work. + +2013-09-22 Torbjorn Granlund + + * mpn/x86_64/coreisbr/redc_1.asm: Slightly tweak basecase code. + + * mpn/x86_64/core2/redc_1.asm: New file. + + * mpn/x86_64/bobcat/redc_1.asm: New file. + +2013-09-21 Torbjorn Granlund + + * mpn/x86_64/coreinhm/redc_1.asm: New file. + +2013-09-21 Marc Glisse + + * tests/mpn/t-mulmid.c: Cast arguments of printf to int to match %d. + * tests/rand/t-urbui.c: Use 1UL for unsigned constant. + * mpn/generic/get_str.c: Avoid temporarily pointing outside an array. + +2013-09-20 Torbjorn Granlund + + * mpn/x86_64/coreisbr/redc_1.asm: New file. + + * mpn/x86_64/k8/redc_1.asm: Complete rewrite. + + * mpn/x86_64/coreisbr/mullo_basecase.asm: Postpone pushes, short- + circuit a branch. + * mpn/x86_64/coreihwl/mullo_basecase.asm: Short-circuit a branch. + + * mpn/x86_64/core2/mullo_basecase.asm: New file. + +2013-09-19 Torbjorn Granlund + + * mpn/x86_64/fastsse/copyi-palignr.asm: Allocate more stack under DOS. + +2013-09-18 Torbjorn Granlund + + * mpn/x86_64/core2/mul_basecase.asm: New file. + * mpn/x86_64/core2/sqr_basecase.asm: New file. + + * mpn/x86_64/coreihwl/mullo_basecase.asm: New file. + * mpn/x86_64/coreisbr/mullo_basecase.asm: New file. + +2013-09-16 Torbjorn Granlund + + * mpn/x86_64/fastsse/copyi-palignr.asm: Preserve xmm6-xmm8 under DOS. + +2013-09-15 Torbjorn Granlund + + * mpn/x86_64/tabselect.asm: Use R8 for bit testing. + + * mpn/x86_64/coreihwl/mul_basecase.asm: Replace mul_1 code. + + * mpn/x86_64/coreisbr/aorsmul_1.asm: Rewrite. + +2013-09-12 Torbjorn Granlund + + * mpn/ia64/gcd_1.asm: Use dep for combining table base and low bits. + + * mpn/x86_64/fastsse/com-palignr.asm: Implement temp fix to properly + handle overlap. + +2013-09-10 Torbjorn Granlund + + * mpn/x86_64/fastsse/copyi-palignr.asm: Rewrite rp != up (mod 16) code + to make it handle any allowed overlap. + +2013-09-09 Torbjorn Granlund + + * mpn/x86_64/atom/com.asm: New file, grabbing fastsse code. + + * mpn/x86_64/bd1/copyi.asm: New file, grabbing fastsse code. + * mpn/x86_64/bd1/copyd.asm: Likewise. + * mpn/x86_64/bd1/com.asm: Likewise. + + * mpn/x86_64/fastavx/copyi.asm: New file. + * mpn/x86_64/fastavx/copyd.asm: New file. + +2013-09-05 Torbjorn Granlund + + * mpn/x86_64/coreihwl/aorsmul_1.asm: Streamline. + +2013-09-04 Torbjorn Granlund + + * mpn/x86_64/coreihwl/sqr_basecase.asm: Implement larger "corner". + Misc tuning. + +2013-09-03 Torbjorn Granlund + + * mpn/x86_64/coreihwl/redc_1.asm: New file. + + * mpn/x86_64/x86_64-defs.m4 (mulx): Handle negative offsets. + +2013-08-31 Torbjorn Granlund + + * mpn/x86_64/coreisbr/sqr_basecase.asm: New file. + + * mpn/x86_64/sqr_diag_addlsh1.asm: New file. + +2013-08-30 Torbjorn Granlund + + * mpn/x86_64/fat/mul_basecase.c: New file. + * mpn/x86_64/fat/sqr_basecase.c: New file. + * mpn/x86_64/fat/mullo_basecase.c: New file. + * mpn/x86_64/fat/redc_1.c: New file. + +2013-08-29 Torbjorn Granlund + + * mpn/x86_64/k8/mul_basecase.asm: Move top-level basecase file to k8 + subdir. + * mpn/x86_64/k8/sqr_basecase.asm: Likewise. + * mpn/x86_64/k8/redc_1.asm: Likewise. + * mpn/x86_64/k8/mullo_basecase.asm: Likewise. + * mpn/x86_64/k8/mulmid_basecase.asm: Likewise. + + * mpn/ia64/aors_n.asm: Clean up some bundlings. + + * mpn/x86_64/fat/fat.c (__gmpn_cpuvec_init): Support Haswell. + (fake_cpuid_table): Likewise. + + * configure.ac (x86): Remove any mulx paths. Let bwl path = hwl path. + (fat_path): Add coreihwl. + + * mpn/x86_64/coreihwl/aorsmul_1.asm: Move from `mulx' directory, use + mulx() macro. + * mpn/x86_64/coreihwl/mul_1.asm: Likewise. + * mpn/x86_64/coreihwl/mul_2.asm: Likewise. + * mpn/x86_64/coreihwl/mul_basecase.asm: Likewise. + * mpn/x86_64/coreihwl/sqr_basecase.asm: Likewise. + + * mpn/x86_64/x86_64-defs.m4 (mulx): New macro. + (regnum, regnumh, ix): Supporting macros. + +2013-08-28 Torbjorn Granlund + + * mpn/x86_64/coreisbr/divrem_1.asm: New file. + +2013-08-23 Torbjorn Granlund + + * mpn/x86_64/fastsse/com-palignr.asm: New file, closely based on + copyi-palignr.asm. + + * mpn/x86_64/fastsse/copyi.asm Use "test R8(reg)" instead of "bt". + * mpn/x86_64/fastsse/copyd-palignr.asm: Likewise. + * mpn/x86_64/fastsse/copyi-palignr.asm: Likewise. + * mpn/x86_64/fastsse/lshift-movdqu2.asm: Likewise. + * mpn/x86_64/fastsse/lshiftc-movdqu2.asm: Likewise. + * mpn/x86_64/fastsse/rshift-movdqu2.asm: Likewise. + * mpn/x86_64/fastsse/tabselect.asm: Likewise. + + * mpn/sparc64/ultrasparct3/sqr_diag_addlsh1.asm: New file. + + * mpn/alpha/aorslsh2_n.asm: New file. + * mpn/alpha/aorslsh1_n.asm: Rewrite. + * mpn/alpha/ev6/aorslsh1_n.asm: New file. + +2013-08-21 Torbjorn Granlund + + * mpn/alpha/sqr_diag_addlsh1.asm: New file. + * mpn/alpha/sqr_diagonal.asm: Remove. + * mpn/alpha/ev6/sqr_diagonal.asm: Remove. + +2013-08-20 Torbjorn Granlund + + * mpn/powerpc32/sqr_diag_addlsh1.asm: New file. + * mpn/powerpc32/sqr_diagonal.asm: Remove. + +2013-08-15 Torbjorn Granlund + + * mpn/x86_64/coreihwl/mulx/sqr_basecase.asm: New file. + +2013-08-05 Torbjorn Granlund + + * mpn/x86_64/coreisbr/aors_n.asm: Complete rewrite. + +2013-08-04 Torbjorn Granlund + + * mpn/x86_64/coreihwl/mulx/mul_basecase.asm: New file. + + * mpn/x86_64/bd1/mul_2.asm: New file. + + * mpn/x86_64/coreihwl/gmp-mparam.h: New file. + +2013-08-03 Torbjorn Granlund + + * mpn/x86_64/coreihwl/mulx/mul_2.asm: New file. + * mpn/x86_64/coreihwl/mulx/addmul_2.asm: New file. + + * mpn/x86_64/coreinhm/aorsmul_1.asm: New file. + + * mpn/x86_64/coreisbr/mul_basecase.asm: Save some O(n) and O(1) cycles. + + * mpn/x86_64/coreisbr/mul_2.asm: New file. + +2013-08-02 Torbjorn Granlund + + * mpn/x86_64/coreisbr/addmul_2.asm: Complete rewrite. + +2013-08-01 Torbjorn Granlund + + * mpn/x86_64/bd1/mul_basecase.asm: New file. + + * mpn/x86_64/coreisbr/mul_basecase.asm: New file. + + * mpn/x86_64/coreihwl/aorsmul_1.asm: New file. + +2013-07-31 Torbjorn Granlund + + * mpn/x86_64/atom/mul_2.asm: New file. + * mpn/x86_64/atom/addmul_2.asm: New file. + * mpn/x86_64/atom/mul_1.asm: New file. + * mpn/x86_64/atom/aorsmul_1.asm: New file. + + * mpn/x86_64/coreihwl/mul_1.asm: New file. + + * configure.ac (x86): Add Haswell-specific path. + + * configure.in (fat_functions): Add cnd_add_n, cnd_sub_n.. + * gmp-impl.h (struct cpuvec_t): Add fields for new fat functions. + * gmp-impl.h: Adjust corresponding declarations. + + * mpn/x86_64/x86_64-defs.m4 (CPUVEC_FUNCS_LIST): Add new fat functions. + * mpn/x86/x86-defs.m4 (CPUVEC_FUNCS_LIST): Likewise. + * mpn/x86_64/fat/fat.c (__gmpn_cpuvec): Likewise. + * mpn/x86/fat/fat.c (__gmpn_cpuvec): Likewise. + +2013-07-30 Torbjorn Granlund + + * mpn/x86_64/coreisbr/popcount.asm: New file. + +2013-07-23 Torbjorn Granlund + + * mpn/x86_64/bobcat/aors_n.asm: New file. + + * mpn/x86_64/pentium4/aorslshC_n.asm: Remove a spurious emms insn. + + * mpn/x86_64/bd1/aorrlsh1_n.asm: New file. + * mpn/x86_64/bd1/sublsh1_n.asm: New file. + +2013-07-22 Torbjorn Granlund + + * mpn/powerpc64/mode64/mod_1_1.asm: Handle little-endian mode. + * mpn/powerpc64/mode64/mod_1_4.asm: Likewise. + +2013-07-16 Torbjorn Granlund + + * doc/gmp.texi: Declare countless of function arguments as 'const'. + +2013-07-15 Torbjorn Granlund + + * mpn/x86_64/core2/aors_n.asm: Rewrite. + + * mpn/generic/sb_div_sec.c: Compute inverse as floor(B^2/(dh+1)), per + Niels' suggestion. + * mpn/generic/sbpi1_div_sec.c: Remove inverse rounding-up code. + +2013-07-14 Torbjorn Granlund + + * mpn/powerpc64/mode64/divrem_1.asm: Remove explicit nop after CALL. + * mpn/powerpc64/mode64/divrem_2.asm: Likewise. + * mpn/powerpc64/mode64/mod_1_1.asm: Likewise. + * mpn/powerpc64/mode64/mod_1_4.asm: Likewise. + +2013-07-13 Torbjorn Granlund + + * mpn/x86/atom/cnd_add_n.asm: New file. + * mpn/x86/atom/cnd_sub_n.asm: New file.o + +2013-07-12 Torbjorn Granlund + + * mpn/generic/sbpi1_div_sec.c: Partial rewrite. + +2013-07-11 Torbjorn Granlund + + * mpn/x86_64/cnd_aors_n.asm: Tweak for better speed on K8, bobcat, bd1, + NHM, Atom. + +2013-07-05 Torbjorn Granlund + + * mpn/powerpc64/p7/copyi.asm: Handle n = 0. + * mpn/powerpc64/p7/copyd.asm: Likewise. + +2013-07-04 Torbjorn Granlund + + * mpn/powerpc64/mode64/p7/aormul_2.asm: New file. + + * mpn/powerpc64/darwin.m4 (EXTRA_REGISTER): New define. + * mpn/powerpc64/aix.m4: New define (actually undefine). + * mpn/powerpc64/elf.m4: Likewise. + +2013-07-03 Torbjorn Granlund + + * mpn/powerpc64/com.asm: Rewrite. + + * mpn/powerpc64/p7/copyi.asm: New file. + * mpn/powerpc64/p7/copyd.asm: New file. + +2013-07-02 Torbjorn Granlund + + * mpn/powerpc64/mode64/gcd_1.asm: New file. + * mpn/powerpc64/mode64/p7/gcd_1.asm: New file. + +2013-07-01 Torbjorn Granlund + + * configure.ac: Comment out AC_PROG_F77. + + * mpn/powerpc64/mode64/rsh1add_n.asm: Remove. + * mpn/powerpc64/mode64/rsh1sub_n.asm: Remove. + * mpn/powerpc64/mode64/rsh1aors_n.asm: New file, code not based on + removed files. + +2013-06-28 Marc Glisse + + * cxx/ismpf.cc: Use GMP_DECIMAL_POINT. + * cxx/osmpf.cc: Likewise. + * tests/cxx/t-locale.cc: Likewise. + +2013-06-28 Torbjorn Granlund + + * mpn/powerpc64/mode64/p7/aorsorrlshC_n.asm: New file. + * mpn/powerpc64/mode64/p7/aorsorrlsh1_n.asm: New file. + * mpn/powerpc64/mode64/p7/aorsorrlsh2_n.asm: New file. + + * mpn/powerpc64/mode64/aorsorrlshC_n.asm: Use alias regname. + +2013-06-27 Torbjorn Granlund + + * mpn/powerpc64/mode64/p7/aors_n.asm: New file. + +2013-06-22 Torbjorn Granlund + + * aorslshC_n.asm, aorslsh2_n.asm, aorslsh1_n.asm: Remove. + * aorsorrlshC_n.asm, aorsorrlsh1_n.asm, aorsorrlsh2_n.asm: New files. + +2013-06-19 Torbjorn Granlund + + * mpn/powerpc64/p6/lshift.asm: Rewrite switching-into-loop code. + * mpn/powerpc64/p6/rshift.asm: Likewise. + * mpn/powerpc64/p6/lshiftc.asm: Likewise. + +2013-06-17 Torbjorn Granlund + + * mpn/powerpc64/p6/lshift.asm: Fix typo in label reference. + For 32-bit mode, zero extend `n' argument and split retval. + * mpn/powerpc64/p6/rshift.asm: Likewise. + * mpn/powerpc64/p6/lshiftc.asm: Likewise. + +2013-06-10 Torbjorn Granlund + + * mpn/generic/mu_div_q.c: Remove obsolete comment. + +2013-06-09 Marc Glisse + + * mpn/generic/get_d.c (mpn_get_d): Avoid signed overflow. + * mpz/kronzs.c (mpz_kronecker_si): Use ABS_CAST. + +2013-05-31 Torbjorn Granlund + + * mpn/generic/mu_div_q.c: Call mpn_mu_divappr_q for entire division, + never just for tail. (This fixes performance issues at the expense of + memory needs.) + +2013-05-26 Torbjorn Granlund + + * configure.ac (*sparc*-*-*): Major overhaul. + +2013-05-22 Torbjorn Granlund + + * doc/gmp.texi (Reporting Bugs): Ask for configure's output. + + * mpn/ia64/divrem_2.asm: Don't clobber f16-f18. + +2013-05-20 Torbjorn Granlund + + * mpn/arm/udiv.asm: Change spacing to work around binutils bug. + +2013-05-16 Torbjorn Granlund + + * Makefile.am (LIBGMP_LT_*, LIBGMPXX_LT_*): Bump version info. + + * tests/misc.c (tests_hardware_getround, tests_hardware_setround): + Avoid assembly dependency unless WANT_ASSEMBLY. + + * configure.ac (WANT_ASSEMBLY): Conditionally define. + +2013-05-14 Torbjorn Granlund + + * configure.ac (arm1156): Don't fall back to plain v6 compiler option. + +2013-05-11 Torbjorn Granlund + + * mpn/x86_64/coreisbr/mul_1.asm: Handle n = 1 for DOS64. Streamline. + * mpn/x86_64/coreisbr/aorsmul_1.asm: Streamline. + +2013-05-10 Torbjorn Granlund + + * mpn/x86_64/coreisbr/aorsmul_1.asm: Fix, then enable DOS64 support. + * mpn/x86_64/coreisbr/mul_1.asm: Enable DOS64 support. + + * mpn/x86/p6/mmx/gmp-mparam.h: Set down SQR_TOOM2_THRESHOLD to parent + directory value. + +2013-05-09 Torbjorn Granlund + + * configure.ac (--enable-fake-cpuid): New option. + * mpn/x86_64/fat/fat.c (WANT_FAKE_CPUID): Remove defaulting. + * mpn/x86/fat/fat.c (WANT_FAKE_CPUID): Likewise. + + * mpn/x86_64/bd1/mul_1.asm: Fix typo. + +2013-05-07 Torbjorn Granlund + + * mpn/x86_64/fat/fat.c (fake_cpuid): Handle 0x80000001 request. + (fake_cpuid_available): Remove unused function. + + * mpn/generic/mod_1_1.c: Cast constant udiv_rnnd_preinv arguments. + * mpn/generic/mod_1_2.c: Likewise. + * mpn/generic/mod_1_3.c: Likewise. + * mpn/generic/mod_1_4.c: Likewise. + * mpn/generic/divrem_2.c: Likewise. + +2013-05-06 Torbjorn Granlund + + * config.guess (power*): Handle all ppc970 variants. + +2013-05-03 David S. Miller + + * tune/common.c (speed_mpn_addlsh1_n, speed_mpn_sublsh1_n, + speed_mpn_rsblsh1_n, speed_mpn_addlsh2_n, speed_mpn_sublsh2_n, + speed_mpn_rsblsh2_n): Don't define if these routines are macros. + * tune/speed.c (routine): Likewise don't table if they are macros. + + * mpn/sparc64/ultrasparct3/addmul_1.asm: Add T4 and T3 timings. + * mpn/sparc64/ultrasparct3/aormul_4.asm: Likewise. + * mpn/sparc64/ultrasparct3/aorslsh_n.asm: Likewise. + * mpn/sparc64/ultrasparct3/cnd_aors_n.asm: Likewise. + * mpn/sparc64/ultrasparct3/submul_1.asm: Likewise. + +2013-05-03 Torbjorn Granlund + + * mpn/sparc64/ultrasparct3/aorslsh_n.asm: Invoke INITCY where it has + effect. + + * gmp-impl.h: Amend last change. + * tests/devel/try.c (choice_array): Don't try to table addlsh1_n etc if + a macro. + +2013-05-02 Torbjorn Granlund + + * mpn/arm/copyd.asm: Suppress dead pointer update. + * mpn/arm/copyi.asm: Likewise. + * mpn/arm/neon/logops_n.asm: Likewise. + * mpn/arm/neon/tabselect.asm: Likewise. + * mpn/arm/rshift.asm: Likewise. + * mpn/arm/tabselect.asm: Likewise. + * mpn/arm/v6/dive_1.asm: Likewise + * mpn/arm/v7a/cora15/neon/copyi.asm: Likewise. + + * mpn/arm/v7a/cora15/neon/com.asm: New file. + +2013-05-01 Torbjorn Granlund + + * mpn/sparc64/ultrasparct3/aormul_4.asm: New file. + + * configure.ac (GMP_MULFUNC_CHOICES): Support mul_3 + addmul_3 and + mul_4 + addmul_4. + + * mpn/sparc64/ultrasparct3/aormul_2.asm: Optimise lead-in code. + + * mpn/sparc64/ultrasparct3/missing.m4 (addxccc): Allow g2 as input. + (umulxhi): Save and restore o7 to allow it as in/out parameter. + +2013-04-29 Torbjorn Granlund + + * mpn/arm/v7a/cora15/cnd_aors_n.asm: New file, was mis-named. + + * mpn/sparc64/ultrasparct3/addmul_1.asm: Rewrite. + + * mpn/sparc64/ultrasparct3/submul_1.asm: Rewrite. + + * mpn/sparc64/ultrasparct3/cnd_aors_n.asm: New file. + + * gmp-impl.h: Override mpn_addlsh1_n, mpn_addlsh2_n, mpn_sublsh1_n, etc + with mpn_addlsh_n, etc when !HAVE_NATIVE the former but HAVE_NATIVE the + latter. + + * mpn/sparc64/ultrasparct3/aorslsh_n.asm: New file. + + * configure.ac (sparc-*-*): Recognise t5 along with t3 and t4. + Remove sparc64/ultrasparct1 from path_64 for T3, T3, and T5. + +2013-04-27 Mike Frysinger + + * configure.ac (arm*-*-*): Set up path also for plainest CPU variants. + +2013-04-27 Torbjorn Granlund + + * mpn/arm/v6/popham.asm: New file. + + * mpn/arm/v7a/cora15/cnd-aors_n.asm: New file. + +2013-04-25 Torbjorn Granlund + + * mpn/arm/mod_34lsub1.asm: Clear carry smarter. + + * mpn/arm/v7a/cora15/logops_n.asm: Conditionally suppress conditionally + used code. + + * mpn/arm/v7a/cora15/submul_1.asm: New file. + +2013-04-24 Torbjorn Granlund + + * mpn/arm/v7a/cora15/com.asm: New file. + + * mpn/arm/v7a/cora15/logops_n.asm: New file. + +2013-04-19 Torbjorn Granlund + + * mpn/arm/v7a/cora15/aors_n.asm: New file. + + * mpn/arm/v7a/cora15/addmul_1.asm: Rewrite. + +2013-04-18 Torbjorn Granlund + + * mpn/alpha/tabselect.asm: New file. + +2013-04-17 Torbjorn Granlund + + * mpn/powerpc32/tabselect.asm: New file. + + * longlong.h (arm64 count_trailing_zeros): New. + + * mpn/arm64/invert_limb.asm: New file. + + * mpn/generic/dive_1.c: Rewrite to use Hensel division also for + size = 1. + + * mpn/generic/mod_1_1.c (add_mssaaaa): Provide VIS3 variant. + + * configure.ac: Remove "missing" from extra_functions_64 for coreibwl. + + * mpn/sparc64/ultrasparct3/mul_1.asm: Decrease loop alignment. + * mpn/sparc64/ultrasparct3/aormul_2.asm: Likewise. + +2013-04-16 Torbjorn Granlund + + * mpn/alpha/invert_limb.asm: Generate table. + * mpn/powerpc64/mode64/invert_limb.asm: Likewise. + * mpn/s390_64/invert_limb.asm: Likewise. + * mpn/sparc64/ultrasparct3/invert_limb.asm: Likewise. + * mpn/x86_64/invert_limb_table.asm: Likewise. + +2013-04-15 David S. Miller + + * mpn/sparc32/sparc-defs.m4 (LEA64): New macro. + * mpn/sparc64/gcd_1.asm: Use it. + * mpn/sparc64/ultrasparct3/dive_1.asm: Likewise. + * mpn/sparc64/ultrasparct3/invert_limb.asm: Likewise. + * mpn/sparc64/ultrasparct3/mode1o.asm: Likewise. + + * mpn/sparc64/gcd_1.asm: Use RODATA, TYPE, and SIZE. + +2013-04-15 Torbjorn Granlund + + * mpn/sparc64/ultrasparct3/invert_limb.asm: Avoid addend for GOT entry, + it is not portable. + + * mpn/sparc64/tabselect.asm: New file. + + * mpn/x86/mmx/tabselect.asm: New file. + * configure.ac (x86): Add x86/mmx to path for relevant CPUs. + + * mpn/sparc64/gcd_1.asm: Use rdpc for PIC. + * mpn/sparc64/ultrasparct3/mode1o.asm: Use rdpc for PIC. + * mpn/sparc64/ultrasparct3/dive_1.asm: Use rdpc for PIC. + * mpn/sparc64/ultrasparct3/invert_limb.asm: Handle PIC, use rdpc. + + * Revert remaining parts of recent sparc LEA changes. + +2013-04-14 David S. Miller + + * mpn/sparc32/v9/sqr_diagonal.asm: Revert LEA and INT32 changes. + * mpn/sparc64/gcd_1.asm: Likewise. + +2013-04-13 Torbjorn Granlund + + * mpn/x86_64/bd1/tabselect.asm: New file. + * mpn/x86_64/coreisbr/tabselect.asm: New file. + * mpn/x86_64/k10/tabselect.asm: New file. + * mpn/x86_64/coreinhm/tabselect.asm: New file. + * mpn/x86_64/core2/tabselect.asm: New file. + * mpn/x86_64/pentium4/tabselect.asm: New file. + + * mpn/x86_64/fastsse/tabselect.asm: New file. + * mpn/arm/neon/tabselect.asm: Rewrite. + * mpn/arm/tabselect.asm: Rewrite. + * mpn/powerpc64/tabselect.asm: Rewrite. + * mpn/x86_64/tabselect.asm: Rewrite. + + * tune/speed.h (SPEED_ROUTINE_MPN_TABSELECT): Implement special code, + making .r argument be table width. + +2013-04-11 David S. Miller + + * mpn/sparc32/sparc-defs.m4 (LEA): Remove unused local label. + (LEA_LEAF): Likewise. + +2013-04-11 Niels Möller + + * mpn/arm/v6/submul_1.asm: New file, using the corresponding + addmul_1 loop + complement trick. + +2013-04-10 David S. Miller + + * acinclude.m4 (GMP_ASM_SPARC_GOTDATA, + GMP_ASM_SPARC_SHARED_THUNKS): New feature tests. + * configure.ac: Call GMP_ASM_SPARC_GOTDATA and + GMP_ASM_SPARC_SHARED_THUNKS on sparc. + * mpn/sparc32/sparc-defs.m4 (LEA, LEA_LEAF, LEA_THUNK): New macros. + * mpn/sparc32/udiv.asm: Convert over to LEA, LEA_LEAF, and LEA_THUNK. + * mpn/sparc32/v8/addmul_1.asm: Likewise. + * mpn/sparc32/v8/mul_1.asm: Likewise. + * mpn/sparc32/v8/supersparc/udiv.asm: Likewise. + * mpn/sparc32/v8/udiv.asm: Likewise. + * mpn/sparc64/gcd_1.asm: Likewise. + * mpn/sparc64/ultrasparct3/dive_1.asm: Likewise. + * mpn/sparc64/ultrasparct3/invert_limb.asm: Likewise. + * mpn/sparc64/ultrasparct3/mode1o.asm: Likewise. + * mpn/sparc32/v9/sqr_diagonal.asm: Likewise and use INT32. + +2013-04-09 Torbjorn Granlund + + * longlong.h (sparc64): Test __VIS__ instead of __sparc_vis3. + + * config.guess (sparc*): Invoke set_cc_for_build to get $dummy. + +2013-04-08 Torbjorn Granlund + + * config.guess: Rework tmp file names, make sure to remove tmp files. + + * mpn/arm/dive_1.asm: Rewrite count-trailing-zeros code, using private + table. + + * mpn/arm: Canonicalise arm assembly to use old style "mov ... lsl" for + shift ops. + +2013-04-07 Torbjorn Granlund + + * mpn/sparc64/ultrasparct3/mod_34lsub1.asm: New file. + + * longlong.h (sparc64): Define umul_ppmm, add_ssaaaa, and + count_leading_zeros conditionally under the symbol __sparc_vis3. + + * mpn/arm/dive_1.asm: New file. + * mpn/arm/v6/dive_1.asm: New file. + + * mpn/arm/v6t2/mode1o.asm: Make trivial change to avoid v6t2... + * mpn/arm/v6/mode1o.asm: ...instruction, move file accordingly. + + * mpn/powerpc64/mode64/invert_limb.asm: Put all multiplies low-limb first. + +2013-04-04 David S. Miller + + * mpn/sparc64/ultrasparct3/add_n.asm: Rewrite. + * mpn/sparc64/ultrasparct3/sub_n.asm: Rewrite. + + * mpn/sparc64/ultrasparct3/invert_limb.asm: Align table. + +2013-04-04 Torbjorn Granlund + + * mpn/sparc32/sparc-defs.m4: Provide dummy lzcnt. + + * tests/mpn/logic.c: Seed using RANDS, then use mpz_rrandomb. + + * tests/mpn/t-div.c (random_word): Remove. Let callers invoke urandom. + + * mpn/sparc64/ultrasparct3/mul_1.asm: Rewrite. + + * mpn/sparc64/ultrasparct3/bdiv_dbm1c.asm: New file. + * mpn/sparc64/ultrasparct3/dive_1.asm: New file. + * mpn/sparc64/ultrasparct3/invert_limb.asm: New file. + * mpn/sparc64/ultrasparct3/mod_1_4.asm: New file. + * mpn/sparc64/ultrasparct3/mode1o.asm: New file. + +2013-04-03 Torbjorn Granlund + + * mpn/sparc64/ultrasparct3/aormul_2.asm: Reschedule for better speed. + +2013-04-02 Torbjorn Granlund + + * mpn/sparc64/ultrasparct3/missing.m4: Misc tweaks. + (lzcnt): New. + * mpn/sparc64/ultrasparct3/missing.asm (__gmpn_lzcnt): New function. + + * mpn/sparc32/sparc-defs.m4: Put FAKE_T3 stuff here... + * mpn/sparc64/ultrasparct3/aormul_2.asm: ...moved from here. + + * mpn/sparc64/ultrasparc1234/lshift.asm: Remove. + * mpn/sparc64/ultrasparc1234/rshift.asm: Remove. + +2013-04-01 Torbjorn Granlund + + * mpn/sparc64/ultrasparct3/missing.m4 (umulxhi): Don't clobber retaddr, + allowing use in functions that does not do save/restore. + + * mpn/sparc64/gcd_1.asm: Tweak for tighter loop. + +2013-03-31 David S. Miller + + * mpn/sparc64/lshift.asm: New file. + * mpn/sparc64/rshift.asm: New file. + * mpn/sparc64/lshiftc.asm: New file. + +2013-03-31 Torbjorn Granlund + + * mpn/sparc64/ultrasparct1/lshift.asm: Remove. + * mpn/sparc64/ultrasparct1/rshift.asm: Remove. + * mpn/sparc64/ultrasparct1/lshiftc.asm: Remove. + +2013-03-29 Torbjorn Granlund + + * mpn/sparc64/ultrasparct3/aormul_2.asm: Always do mulx before umulxhi. + +2013-03-28 Torbjorn Granlund + + * mpn/sparc64/mod_1_4.c (mpn_mod_1s_4p): Make precomputed arg 'const'. + (mpn_mod_1s_4p_cps): Update from generic code. + +2013-03-27 Torbjorn Granlund + + * mpn/generic/trialdiv.c: Make variables 'const' to match tables. + + * mpn/generic/mod_1_1.c (mpn_mod_1_1p): Make precomputed arg 'const'. + * mpn/generic/mod_1_2.c (mpn_mod_1s_2p): Likewise. + * mpn/generic/mod_1_3.c (mpn_mod_1s_3p): Likewise. + * mpn/generic/mod_1_4.c (mpn_mod_1s_4p): Likewise. + * gmp-impl.h: Update prototypes. + + * mpn/x86_64/mulx/aorsmul_1.asm: New file. + * mpn/x86_64/mulx/addmul_1.asm: Remove. + +2013-03-26 Niels Möller + + Make mpn_cnd_add_n and mpn_cnd_sub_n public. + * doc/gmp.texi (Low-level Functions): Document mpn_cnd_add_n and + mpn_cnd_sub_n. + * gmp-h.in (mpn_cnd_add_n, mpn_cnd_sub_n): Moved prototypes + here... + * gmp-impl.h: ... from here. + +2013-03-26 Torbjorn Granlund + + * mpn/x86/pentium4/sse2/cnd_add_n.asm: New file. + * mpn/x86/pentium4/sse2/cnd_sub_n.asm: New file. + * mpn/x86/cnd_aors_n.asm: New file. + +2013-03-25 David S. Miller + + * mpn/sparc64/ultrasparct3/hamdist.asm: New file. + * mpn/sparc64/ultrasparct3/popcount.asm: New file. + +2013-03-25 Torbjorn Granlund + + * mpn/ia64/aorsorrlshC_n.asm: Generalised from aorslshC_n.asm. + * mpn/ia64/aorsorrlsh1_n.asm: Generalised from aorslsh1_n.asm. + * mpn/ia64/aorsorrlsh2_n.asm: Generalised from aorslsh2_n.asm. + +2013-03-24 Torbjorn Granlund + + * mpn/arm/v7a/cora15/neon/aorsorrlshC_n.asm: New file. + * mpn/arm/v7a/cora15/neon/aorsorrlsh2_n.asm: New file. + * mpn/arm/v7a/cora15/neon/aorsorrlsh1_n.asm: New file. + * mpn/arm/v7a/cora15/neon/rsh1aors_n.asm: New file. + + * configure.ac (GMP_MULFUNC_CHOICES): Support add+sub+rsb lsh files. + + * tests/refmpn.c (refmpn_addlsh_nc, refmpn_sublsh_nc): Remove silly + assert of mp_limb being non-negative. + +2013-03-21 Torbjorn Granlund + + * mpn/arm/neon/lshiftc.asm: New file. + + * mpn/arm/v6/sqr_basecase.asm: Trim 'sqr_diag_addlsh1' loop. + + * gen-trialdivtab.c: Output just raw data, remove actual variables. + * mpn/generic/trialdiv.c: Put variables from gen-trialdivtab.c here, + and make them 'const'. + +2013-03-20 Torbjorn Granlund + + * config.guess: Rework arm CPU recognition. + * config.sub: Corresponding updates. + * configure.ac: Likewise. + + * mpn/x86_64/mulx/adx/addmul_1.asm: Let FAKE_MULXADX be off by default. + + * mpn/arm/v7a/cora15/neon/copyi.asm: Move from "..". + * mpn/arm/v7a/cora15/neon/copyd.asm: Likewise. + + * config.guess: Tack on "neon" for appropriate arm CPUs. + * configure.ac (arm*-*-*): Recognise neon suffix for a8, a9, and a15. + +2013-03-19 Marco Bodrato + + * mpf/fits_u.h: Accept numbers truncating to zero before checking the + sign. + * tests/mpf/t-fits.c: Check new edges. + +2013-03-19 Torbjorn Granlund + + * tests/arm32check.c: Get printing of clobbered register right. + + * mpn/arm/neon/popcount.asm: New file. + * mpn/arm/neon/hamdist.asm: New file. + + * tests/Makefile.am (EXTRA_libtests_la_SOURCES): Add arm32call.asm and + arm32check.c. + +2013-03-18 Torbjorn Granlund + + * configure.ac (arm*-*-*): Define CALLING_CONVENTIONS_OBJS. + + * tests/arm32call.asm: New file. + * tests/arm32check.c: New file. + + * mpn/arm/arm-defs.m4 (LEA): Rewrite to properly handle repeated use. + (EPILOGUE_cpu): Define. + + * mpn/arm/v6/addmul_3.asm: Make code work for PIC. + + * tests/x86call.asm: Modernise asm syntax. + * tests/amd64call.asm: Likewise. + + * mpn/x86/darwin.m4 (m4append): Move definition from here... + * mpn/asm-defs.m4: ...to here. + +2013-03-18 Marco Bodrato + + * doc/gmp.texi (--enable-fat): No quote in concept index. + + * mpf/swap.c: Reduce the number of variables. + +2012-03-17 Marc Glisse + + * tests/cxx/t-do-exceptions-work-at-all-with-this-compiler.cc: New file. + * tests/cxx/Makefile.am: Add new file. Reorder the tests. + +2013-03-17 Torbjorn Granlund + + * mpn/generic/mul_fft.c: Use TMP_BALLOC*, but combine several areas. + + * mpz/powm_ui.c (mod): Use TMP_BALLOC in mu code. + + * mpn/arm/v6/addmul_3.asm: New file. + + * mpn/arm/v7a/cora15/copyd.asm: Tweak. + + * mpn/arm64/copyi.asm: New file. + * mpn/arm64/copyd.asm: New file. + +2013-03-16 Torbjorn Granlund + + * mpn/arm/v6/addmul_2.asm: Tweak for better A9 performance. + +2013-03-14 Torbjorn Granlund + + * mpn/ia64/cnd_aors_n.asm: New file. + + * mpn/arm64/cnd_aors_n.asm: New file. + + * mpn/arm64/aors_n.asm (ADDSUB): Remove unused definition. + + * mpn/ia64/aors_n.asm: Remove a redundant ASM_START. + + * mpn/arm/cnd_aors_n.asm: Avoid ARM conditional insn execution. + + * mpn/x86_64/missing.asm: Move from mulx/adx since we cannot currently + prune missing.asm from path. + * mpn/x86_64/mulx/adx/missing-call.m4: Likewise. + * mpn/x86_64/mulx/adx/missing-inline.m4: Likewise. + * mpn/x86_64/mulx/adx/addmul_1.asm: Update hardwired path. + +2013-03-13 Marco Bodrato + + * mpz/cong_2exp.c: Write loops in a cleaner way. + * mini-gmp/mini-gmp.c: Likewise. + * gmp-impl.h (mpz_zero_p): Likewise. + +2013-03-12 Niels Möller + + New names mpn_cnd_add_n and mpn_cnd_sub_n. + * mpn/generic/cnd_add_n.c (mpn_cnd_add_n): Renamed file and + function, from addcnd.c:mpn_addcnd_n. + * mpn/generic/cnd_sub_n.c (mpn_cnd_sub_n): Renamed, from + subcnd.c:mpn_subcnd_n. + * mpn/arm/cnd_aors_n.asm: Renamed file, from aorscnd.asm, and + renamed functions. + * mpn/x86_64/cnd_aors_n.asm: Analogous renaming. + * mpn/powerpc64/mode64/cnd_aors_n.asm: Analogous renaming. + * gmp-impl.h (mpn_cnd_add_n, mpn_cnd_add_n): Updated prototypes + with new names. + * configure.ac: Updated for new names. + * tests/refmpn.c (refmpn_cnd_add_n): Renamed, from refmpn_addcnd_n. + (refmpn_cnd_sub_n): Renamed, from refmpn_subcnd_n. + * tests/tests.h (refmpn_cnd_add_n, refmpn_cnd_sub_n): Updated + prototypes with new names. + * tune/common.c (speed_mpn_cnd_add_n): Renamed, from + speed_mpn_addcnd_n, call mpn_cnd_add_n. + (speed_mpn_cnd_sub_n): Renamed, from speed_mpn_subcnd_n, call + mpn_cnd_sub_n. + * tune/speed.h (speed_mpn_cnd_add_n, speed_mpn_cnd_sub_n): Updated + prototypes with new names. + * tune/speed.c (routine): Updated list with new names. + * tests/devel/try.c: Updated for new mpn_cnd_* names. + * mpn/generic/sbpi1_div_sec.c: Likewise. + * mpn/generic/powm_sec.c: Likewise. + +2013-03-12 Torbjorn Granlund + + * configure.ac: Add "missing" to extra_functions_64 for coreibwl. + + * mpn/x86_64/mulx/adx/addmul_1.asm: Simplify. Make FAKE_MULXADX the + default awaiting proper qemu behaviour. + +2013-03-11 Torbjorn Granlund + + * mpn/x86_64/aorscnd_n.asm: Read 32 bits for 'n' arguments on DOS64. + + * tests/mpz/t-powm_ui.c: Test larger arguments. General cleanup. + + * mpz/powm_ui.c (mod): Adhere to mpn_mu_div_qr's overlap requirements. + +2013-03-10 Niels Möller + + * mpn/generic/sbpi1_div_sec.c: Update calls of mpn_addcnd_n and + mpn_subcnd_n. + * mpn/generic/powm_sec.c (MPN_REDC_1_SEC, MPN_REDC_2_SEC) + (mpn_powm_sec): Update calls of mpn_subcnd_n. + + * tests/tests.h (refmpn_addcnd_n, refmpn_subcnd_n): Update + declarations. + * tests/refmpn.c (refmpn_addcnd_n, refmpn_subcnd_n): Similar + reorder of arguments. + * tests/devel/try.c (call): Pass condition first, for + TYPE_ADDCND_N and TYPE_SUBCND_N. + + * tune/common.c (speed_mpn_addcnd_n, speed_mpn_subcnd_n): Update + to pass condition as first argument. + + * gmp-impl.h (mpn_addcnd_n, mpn_subcnd_n): Updated declarations. + + * mpn/generic/addcnd_n.c (mpn_addcnd_n): Reordered arguments, make + condition the first argument. + * mpn/generic/subcnd_n.c (mpn_subcnd_n): Likewise. + * mpn/arm/aorscnd_n.asm: Likewise. + * mpn/x86_64/aorscnd_n.asm: Likewise. + * mpn/powerpc64/mode64/aorscnd_n.asm: Likewise. + +2013-03-10 Torbjorn Granlund + + * mpn/x86_64/mulx/adx/missing.asm: Simulate some mulx/adx insns. + * mpn/x86_64/mulx/adx/missing-call.m4: Call variant. + * mpn/x86_64/mulx/adx/missing-inline.m4: Inline variant. + + * mpn/sparc64/ultrasparct3/missing.asm: Simulate some v9-2011 insns. + * mpn/sparc64/ultrasparct3/missing.m4: Inline or invoke missing.asm for + v9-2011 insn. + + * configure.ac: Strip `haswell' from paths for now. + + * mpn/x86_64/mulx/addmul_1.asm: New. + * mpn/x86_64/mulx/mul_1.asm: Rewrite file from `haswell' subdir. + * mpn/x86_64/mulx/adx/addmul_1.asm: Likewise. + * mpn/x86_64/haswell: Remove. + + * mpn/arm/v7a/cora15/mul_1.asm: New file. + * mpn/arm/v7a/cora15/addmul_1.asm: New file. + +2013-03-09 Marco Bodrato + + * tests/mpz/t-cong_2exp.c: Improve coverage. + +2013-03-09 Torbjorn Granlund + + * mpn/sparc64/ultrasparc1234/add_n.asm: Use g5 instead of g4. + * mpn/sparc64/ultrasparc1234/sub_n.asm: Likewise. + + * mpn/sparc64/ultrasparct3/aormul_2.asm: Fix a typo. + +2013-03-07 Torbjorn Granlund + + * mpn/arm/v7a/cora9/gmp-mparam.h: New file. + + * configure.ac (GMP_MULFUNC_CHOICES): Support mul_2 + addmul_2. + + * mpn/sparc64/ultrasparct3/aormul_2.asm: New file. + + * mpn/sparc64/ultrasparct3/submul_1.asm: Optimise out two carry + propagating adds. + +2013-03-06 David Miller + + * config.guess: Recognize UltraSparc T4 under Linux. + * configure.ac: Add sparc64/ultrasparct3 to path_64 when T3 or T4. + Append -xarch=v8plusd or -xarch=v9d to command line, as needed. + * mpn/sparc64/ultrasparct3/mul_1.asm: New file. + * mpn/sparc64/ultrasparct3/addmul_1.asm: New file. + * mpn/sparc64/ultrasparct3/submul_1.asm: New file. + * mpn/sparc64/ultrasparct3/add_n.asm: New file. + * mpn/sparc64/ultrasparct3/sub_n.asm: New file. + + * mpn/sparc32/ultrasparct1/mul_1.asm: Unroll main loop one time, add + T2/T3/T4 timings. + * mpn/sparc32/ultrasparct1/addmul_1.asm: Likewise. + * mpn/sparc32/ultrasparct1/submul_1.asm: Likewise. + +2013-03-04 Torbjorn Granlund + + * mpn/arm/neon/lorrshift.asm: New file. + +2013-03-03 Torbjorn Granlund + + * mpn/arm/v7a/cora15/copyd.asm: New file. + * mpn/arm/v7a/cora15/copyi.asm: New file. + + * mpn/arm64/logops_n.asm: New file. + * mpn/arm64/gcd_1.asm: New file. + * mpn/arm64/aorsmul_1.asm: New file. + * mpn/arm64/addmul_1.asm: Remove. + * mpn/arm64/aors_n.asm: Complete rewrite. + + * mpn/arm/tabselect.asm: New file. + * mpn/arm/neon/tabselect.asm: New file. + + * mpn/arm/copyi.asm: Software pipeline. + * mpn/arm/copyd.asm: Likewise. + + * config.guess: Rework tmp file handling to resemble configfsf.guess's. + +2013-03-03 Niels Möller + + * doc/gmp.texi (Integer Special Functions): Document + mpz_limbs_read, mpz_limbs_write, mpz_limbs_modify, + mpz_limbs_finish, mpz_roinit_n and MPZ_ROINIT_N. + + * mpz/roinit_n.c (mpz_roinit_n): Normalize the input. + +2013-02-27 Niels Möller + + * tune/common.c (speed_measure): Increase repetition count if we + get a zero measurement. + +2013-02-27 Marco Bodrato + + * mini-gmp/mini-gmp.c (mpz_div_q_2exp): Adjust only if needed. + (mpn_common_scan): New service function to unify scan loops. + (mpz_scan0, mpz_scan1): Simplify by using mpn_common_scan. + (mpz_make_odd): Simplify, assume in-place operation on positive. + (mpn_scan0, mpn_scan1): New functions. + * mini-gmp/mini-gmp.h (mpn_scan0, mpn_scan1): New declarations. + * mini-gmp/tests/t-scan.c: Test also mpn_scan0 and mpn_scan1. + +2013-02-26 Niels Möller + + * tests/mpz/t-limbs.c (check_roinit): Test MPZ_ROINIT_N only if + compiler supports c99. + +2013-02-25 Niels Möller + + * mini-gmp/tests/t-double.c (testmain): Declare double variables + as volatile, to drop extended precision. + + * mini-gmp/tests/testutils.c (testfree): New function. Use it + everywhere where test programs deallocate storage allocated via + the mini-gmp allocation functions, including uses of mpz_get_str + for various test failure messages. + + * mpz/limbs_finish.c (mpz_limbs_finish): New file and function. + * mpz/limbs_modify.c (mpz_limbs_modify): New file and function. + * mpz/limbs_read.c (mpz_limbs_read): New file and function. + * mpz/limbs_write.c (mpz_limbs_write): New file and function. + * mpz/roinit_n.c (mpz_roinit_n): New file and function. + * gmp-h.in: Declare new functions. + (MPZ_ROINIT_N): New macro. + * mpz/Makefile.am (libmpz_la_SOURCES): Added new files. + * Makefile.am (MPZ_OBJECTS): Added new object files. + + * tests/mpz/t-limbs.c: New testcase. + * tests/mpz/Makefile.am (check_PROGRAMS): Added t-limbs. + +2013-02-22 Torbjorn Granlund + + * configure.ac: Fix typo in adx/mulx path stripping code. + * config.sub: Match coreibwl. + +2013-02-20 Niels Möller + + * tests/mpq/t-get_d.c (check_random): Rewrote to make test less + dependent on float operations. Fixes problem with m68k-linux and + extended float precision. + +2013-02-20 Torbjorn Granlund + + * mpn/x86_64/haswell/mulx/adx/addmul_1.asm: New file. + + * configure.ac: Support coreibwl. Use proper name for ADX extension. + * acinclude.m4 (GMP_ASM_X86_ADX): Rename from GMP_ASM_X86_ADOX. + + * tests/tests.h (TESTS_REPS): Keep count >= 1. + +2013-02-19 Marco Bodrato + + * mini-gmp/mini-gmp.c: Move asserts to work-around a compiler bug. + (mpz_export): Reorder branches. + (mpz_mul_ui): Avoid temporary allocation (mpn_mul_1 can work in-place). + + * mini-gmp/tests/t-reuse.c: Fix typo causing the same negation + condition to be applied to all operands. (See 2013-02-03, Torbjorn) + +2013-02-17 Marco Bodrato + + * gmpxx.h (mpq_class, mpf_class) [init_ui, init_si, assign_si]: + Optimise _si using _ui for positive arguments. + (__gmp_hypot_function): Use _mul_ui to square an ui, abs for si. + + * mini-gmp/mini-gmp.c (mpz_mul): Read sizes just once. + (mpn_set_str_other): Remove a redundant variable. + (mpz_abs_add): Use SWAP once, to order sizes. + (mpz_mul_ui): Micro-optimisation. + (mpz_rootrem): Use _init2 before _setbit. + (mpz_set_str): Optimise-out a variable. + (mpz_import): Normalise only if needed. + (mpn_div_qr_1): Speed-up the d=1 case, delaying a branch. + + * rand/randmts.c: Use init2, as size of variables is known in advance. + (mangle_seed): Get a single argument. + + * mpz/remove.c: Delay allocation in the generic case; use swap + instead of set. + * mpn/generic/remove.c: Delay (possibly smaller) allocation. + +2013-02-17 Marc Glisse + + * cxx/osdoprnti.cc: Use and rather than + and (revert 2002-12-21). + + * tests/cxx/Makefile.am: Link with libm. + * tests/cxx/t-ops2.cc: Comment about more tests. Use rather + than and using namespace. Don't include . + + * gmpxx.h (__GMPXX_BITS_TO_LIMBS, __GMPQ_NUM_DBL_LIMBS, + __GMPQ_DEN_DBL_LIMBS, __GMPXX_TMPQ_D): New macros. + (__gmp_binary_plus, __gmp_binary_minus, __gmp_binary_multiplies, + __gmp_binary_divides, __gmp_binary_equal, __gmp_binary_less, + __gmp_cmp_function): Use __GMPXX_TMPQ_D. + * tests/cxx/t-ops2.cc: Test __GMPXX_TMPQ_D on DBL_MIN, DBL_MAX. + + * gmpxx.h (__gmp_binary_multiplies, __gmp_binary_divides): Use + __GMPXX_CONSTANT_TRUE. + +2013-02-16 Marc Glisse + + * gmpxx.h: Include . + +2013-02-16 Torbjorn Granlund + + * mpn/Makefile.am (TARG_DIST): Add arm64. + + * mpn/x86_64/x86_64-defs.m4 (PROTECT): Emit '.hidden' instead of + '.protected" to please Sun's assembler, but also for semantic reasons. + +2013-02-15 Torbjorn Granlund + + * configure.ac (arm64*-*-*): Match this. + + * mpn/arm64/aors_n.asm: New file. + * mpn/arm64/addmul_1.asm: New file. + * mpn/arm64/mul_1.asm: New file. + +2013-02-15 Marc Glisse + + * gmpxx.h (__GMPXX_DEFINE_ARITHMETIC_CONSTRUCTORS, + __GMPXX_DEFINE_ARITHMETIC_ASSIGNMENTS): New macros. + (mpz_class, mpq_class, mpf_class) [init_ui, init_si, init_d, + assign_ui, assign_si, assign_d]: New functions. + (__gmp_expr::__gmp_expr, __gmp_expr::operator=): Replace with macros. + (__GMPXX_CONSTANT_TRUE): New macro. + +2013-02-15 Marco Bodrato + + * gmp-impl.h (NEG_CAST, ABS_CAST): Use __GMP_CAST. + * mpz/fits_s.h: Use NEG_CAST. + +2013-02-14 Marc Glisse + + * gmpxx.h (__gmp_binary_greater): Forward to __gmp_binary_less. + (__gmp_binary_equal): Forward to itself after swapping operands. + +2013-02-14 Marco Bodrato + + * mp_dv_tab.c (__gmp_digit_value_tab): Remove a line of unused values. + * mpf/set_str.c: Update offset accordingly. + * mpz/inp_str.c: Likewise. + * mpz/set_str.c: Likewise. + + * gmp-h.in (mpq_cmp_ui): Optimise comparison with 1/1. + * tests/mpq/t-cmp_ui.c: Test special comparisons: 0/1, 1/1. + + * mpz/clrbit.c: Reorganise branches. + * mpz/setbit.c: Likewise. + * mpz/combit.c: Same micro-optimisations as in set/clr. + + * mpz/aors_ui.h: No realloc if size was zero. + * mpz/ior.c: Use macros: MPZ_REALLOC and MPN_INCR_U. + + * gmp-impl.h (NEG_CAST): New macro, used by ABS_CAST. + * mpq/cmp_si.c: Use NEG_CAST. + * mpz/cmp_si.c: Reorganise branches. + +2013-02-13 Torbjorn Granlund + + * acinclude.m4 (GMP_ASM_X86_MULX, GMP_ASM_X86_ADOX): New feature tests. + * configure.ac: Use new feature tests. + + * mpn/x86_64/haswell/mulx/mul_1.asm: File moved to cope with older + assemblers. + * configure.ac: Update haswell path to include "mulx". + +2013-02-12 Torbjorn Granlund + + * configure.ac: Recognise haswell. + * config.guess: Recognise haswell. + * config.sub: Match haswell. + + * mpn/x86_64/haswell/mul_1.asm: New file, mainly for testing HNI. + +2013-02-12 Marco Bodrato + + * gmp-impl.h (MPZ_PROVOKE_REALLOC): Remove unused macro. + * gen-fac.c (gen_consts): Remove obsolete code, use swap instead of set. + * mini-gmp/mini-gmp.c (fac_ui, bin_uiui): Use shorter and faster code. + + * mpn/generic/mulmod_bnm1.c: Reorganise branches. + * mini-gmp/mini-gmp.c: Reduce branches. + + * mpz/bin_ui.c: Avoid a copy when n < 0. + * mpz/mfac_uiui.c: Reduce memory usage. + * mpz/primorial_ui.c: Use MPZ_NEWALLOC. + + * mpz/import.c: Use BITS_TO_LIMBS and MPZ_NEWALLOC. + * mpz/inp_raw.c: Likewise. + * mpz/rrandomb.c: Likewise. + * mpz/urandomb.c: Likewise. + * mpn/generic/random2.c: Likewise. + + * mpn/generic/brootinv.c: Micro-optimisation. + + * mpf/set_str.c: Don't chech base==0 when base is strictly positive. + +2013-02-10 Torbjorn Granlund + + * Version 5.1.1 released. + +2013-02-07 Marco Bodrato + + * tune/speed.h (SPEED_ROUTINE_MPN_MUL): Use operands from struct s. + * tune/README: Document new parameter syntax mpn_mul.<#> . + +2013-02-06 Niels Möller + + * tests/mpz/t-jac.c (check_large_quotients): Rewrote. Now uses a + more efficient method for generating the test inputs. + +2013-02-05 Torbjorn Granlund + + * tests/mpn/t-div.c: Limit random dbits to avoid an infinite loop. + +2013-02-03 Torbjorn Granlund + + * tests/mpz/reuse.c: Fix typo causing the same negation condition to be + applied to all operands. Fix condition for when to invoke mpz_remove. + Make different-size random operands. + +2013-02-02 Marco Bodrato + + * mpz/remove.c: Correct the sign in case of reuse. + +2013-02-01 Torbjorn Granlund + + * gmp-impl.h (DIGITS_IN_BASE_PER_LIMB): Add a cast. + (LIMBS_PER_DIGIT_IN_BASE): Likewise. + + * tests/refmpn.c (refmpn_mul): Use toom6h instead of toom44 for the + largest operands. + +2013-01-31 Torbjorn Granlund + + * mpn/generic/toom44_mul.c: Revert last change in favour of a simple + change (thanks Marco!). + * mpn/generic/toom4_sqr.c: Likewise. + +2013-01-30 Torbjorn Granlund + + * mpn/generic/toom44_mul.c (MAYBE_mul_toom44): Take toom6h and toom8h + into account, using new macro MUL_NEXTALG_THRESHOLD. + * mpn/generic/toom4_sqr.c (MAYBE_sqr_toom4): Likewise. + +2013-01-26 Marco Bodrato + + * mpz/remove.c: init+set=init_set, cast before shifting. + + * mpz/cmp_si.c: Use ABS_CAST. + +2013-01-26 Torbjorn Granlund + + * tests/mpn/logic.c: Set things up to always test library logops, not + gmp-impl.h's inlined variants. Test also mpn_com. + + * tests/mpn/t-mod_1.c: Test also mpn_mod_1s_3p. + + * mpn/generic/mod_1_3.c: Swap some lines to make it similar to mod_4.c. + + * tests/mpz/reuse.c: Fix typo in last change. + +2013-01-23 Marco Bodrato + + * mini-gmp/mini-gmp.c (mpz_cmpabs_d, mpz_cmp_d): Simplify. + (mpz_set_str): Behaviour more adherent to the real GMP. + + * mini-gmp/tests/t-str.c: Cast size_t to unsigned long, for printf. + * mini-gmp/tests/t-import.c: Likewise. + * mini-gmp/tests/t-comb.c: Remove an unused var. + * mini-gmp/tests/t-div.c: Remove unused args passed to fprintf. + * mini-gmp/tests/t-double.c: Use float immediates with float vars. + +2013-01-22 Torbjorn Granlund + + * Makefile.am (LIBGMP_LT_*, LIBGMPXX_LT_*): Bump version info. + * gmp-h.in: Bump version. + + * tests/mpz/reuse.c: Delete always zero 'failures' and code depending + on it. Replace rotating progress with real measure. + + * Makefile.am (check-mini-gmp): Fix typo in last change. + +2013-01-22 Niels Möller + + * mini-gmp/mini-gmp.c (mpz_cmp_d): Simplified, just sort out + signs, then call mpz_cmpabs_d. + + * mini-gmp/tests/testutils.h: Include stdio.h and stdlib.h. + (numberof): New define. + + * mini-gmp/tests/t-cmp_d.c: New file, copied from + tests/mpz/t-cmp_d.c with minor changes. + * mini-gmp/tests/Makefile (CHECK_PROGRAMS): Added t-cmp_d, + + * mini-gmp/mini-gmp.c (mpz_cmpabs_d): New function. + * mini-gmp/mini-gmp.h: Declare it. + +2013-01-21 Niels Möller + + * mini-gmp/tests/t-str.c (testmain): Test mpz_out_str, using + the tmpfile function for i/o. + +2013-01-20 Torbjorn Granlund + + * Makefile.am (check-mini-gmp): Set also DYLD_LIBRARY_PATH for the + benefit of Darwin. + + * tests/mpn/t-div.c: Test mpn_sb_div_qr_sec and mpn_sb_div_r_sec. + (main): Separate divisor into normalised (dnp) and unnormalised (dup), + pass appropriate variant to each function. + (main): Make negative `test' index value mean divisor bits, for better + small operands coverage. + (main): Put random junk at qp[] instead of zeroing. + + * tests/mpz/t-remove.c: Back out last change which left `divisor_size' + uninitialised; achieve change's aim with a parameter tweak. + +2013-01-20 Marco Bodrato + + * mini-gmp/tests/testutils.c (testhalves): New function, test default + memory functions. + * mini-gmp/tests/testutils.h (testhalves): Declare it + * mini-gmp/tests/t-logops.c: Use testhalves. + + * mini-gmp/mini-gmp.c (mpz_init_set_str): New function. + * mini-gmp/mini-gmp.h (mpz_init_set_str): Declare it. + * mini-gmp/tests/t-str.c: Test mpz_init_set_str. + +2013-01-20 Torbjorn Granlund + + * tests/memory.c (PTRLIMB): New macro, used for conformant casting. + +2013-01-19 Marco Bodrato + + * mini-gmp/tests/t-double.c (testmain): Get the current free + function using mp_get_memory_functions. + * mini-gmp/tests/t-str.c (testmain): Likewise. + + * mini-gmp/tests/testutils.h (tu_free): Remove declaration. + + * mini-gmp/tests/testutils.c (block_check, tu_free): Mark static. + + * tests/mpz/t-set_str.c: Check also failing conditions. + + * tests/mpz/t-remove.c: Test removal of 1. + +2013-01-18 Niels Möller + + * mini-gmp/tests/t-str.c (test_small): New function, exercising + parsing of whitespace and base prefixes. + (testmain): Call it. + + * mini-gmp/tests/t-gcd.c (gcdext_valid_p): Fixed memory leak. + + * mini-gmp/tests/t-double.c (testmain): Call tu_free rather than + free, for storage allocated by mpz_get_str. + * mini-gmp/tests/t-str.c (testmain): Likewise. + + * mini-gmp/tests/testutils.c (block_init, block_check): New + functions. + (tu_alloc, tu_realloc, tu_free): New functions. + (main): Use mp_set_memory_functions. + * mini-gmp/tests/testutils.h (tu_free): Declare. + + * mini-gmp/tests/testutils.h: New file, declarations for test + programs. + + * mini-gmp/tests/testutils.c (main): New file, with shared main + function for all the test programs. Also includes mini-gmp.c. + Calls testmain after initialization. All other test programs + updated to define testmain rather than main. + +2013-01-18 Marco Bodrato + + * mini-gmp/tests/t-signed.c: Slightly larger coverage. + * mini-gmp/tests/t-double.c: Test also mpz_init_set_d. + +2013-01-18 Torbjorn Granlund + + * mpn/generic/set_str.c (normalization_steps): Eliminate set-but-unused + variable. + + * mini-gmp/tests/t-div.c: Test mpz_divisible_p and mpz_divisible_ui_p. + + * tests/tests.h (TESTS_REPS): Fix printf argument type clashes. + + * mini-gmp/tests/t-div.c: Test also mpz_mod, mpz_mod_ui. Compare + mpz_divisible_p just to ceil, to save time. + + * mini-gmp/mini-gmp.c: Prefix some names with GMP_. + +2013-01-16 Marco Bodrato + + * mini-gmp/tests/t-double.c: Test mpz_cmp_d. + * mini-gmp/mini-gmp.c (mpz_cmp_d): Correct multiword comparison. + + * mini-gmp/mini-gmp.c (mpz_set_str): Handle the empty string. + * mini-gmp/tests/t-str.c: Test base <= 0. + +2013-01-15 Niels Möller + + * mini-gmp/tests/t-str.c (main): Use x->_mp_d rather than x[0]._mp_d. + * mini-gmp/tests/t-invert.c (main): Likewise. + + * mini-gmp/tests/t-mul.c (main): Test mpn_mul_n and mpn_sqr. + + * mini-gmp/tests/hex-random.h (enum hex_random_op): New value + OP_SQR. + + * mini-gmp/tests/mini-random.c (mini_random_op3): Renamed, from... + (mini_random_op): ... old name. Updated callers. + (mini_random_op2): New function. + + * mini-gmp/tests/hex-random.c (hex_random_op3): Renamed, from... + (hex_random_op): ... old name. Updated callers. + (hex_random_op2): New function. + +2013-01-15 Marco Bodrato + + * mini-gmp/tests/t-logops.c: Improve popcount/hamdist testing. + * mini-gmp/tests/t-signed.c: Test more cases. + +2013-01-15 Torbjorn Granlund + + From Mike Frysinger: + * configure.ac: Add x32 ABI for x86_64. + +2013-01-14 Niels Möller + + * mini-gmp/tests/t-str.c (main): Added tests for mpn_get_str and + mpn_set_str. + +2013-01-14 Marco Bodrato + + * doc/gmp.texi (gmp_version): Remove "was used" repetition. + (Upward compatibility): Mention mpn_bdivmod, GMP 4 -> GMP 5. + +2013-01-13 Marc Glisse + + * doc/gmp.texi: Let mpn_sqrtrem reference mpn_perfect_square_p instead + of mpz_perfect_square_p. + +2013-01-11 Marco Bodrato + + * mini-gmp/tests/t-comb.c: New test program, testing both + mpz_fac_ui and mpz_bin_uiui. + * mini-gmp/tests/Makefile (CHECK_PROGRAMS): Added t-comb. + + * mini-gmp/mini-gmp.c (mpz_mul_si): Simplify. + (mpz_mul_ui, mpz_mul, mpz_div_qr): Replace init+REALLOC with init2. + + * mini-gmp/mini-gmp.c (NEG_CAST): New macro. + (mpz_mul_si, mpz_set_si, mpz_cmp_si): Use NEG_CAST. + + * mini-gmp/mini-gmp.c (mpz_set_si, mpz_cmp_si): Simplify by using + the _ui variant. + + * mini-gmp/tests/t-root.c: Use mpz_ui_pow_ui, when base fits an ui. + + * mini-gmp/tests/t-mul.c: Test also mpz_mul_si. + * mini-gmp/tests/t-sub.c: Test also mpz_ui_sub. + + * mini-gmp/mini-gmp.c (mpz_fits_slong_p): Correct range. + * mini-gmp/tests/t-signed.c: New test program, for get/set/cmp_si. + * mini-gmp/tests/Makefile (CHECK_PROGRAMS): Added t-signed. + + * mini-gmp/mini-gmp.c (mpz_hamdist): Handle different sizes. + * mini-gmp/tests/t-logops.c: Test also popcount and hamdist. + +2013-01-10 Marco Bodrato + + * mpz/export.c: Less restrictive ASSERTs. + * mini-gmp/mini-gmp.c (mpz_export, mpz_import): Likewise. + * mini-gmp/tests/t-import.c: Test also size=0 or count=0. + +2013-01-10 Torbjorn Granlund + + * mini-gmp/tests/t-import.c (main): Don't drop off function end. + + * Makefile.am (check-mini-gmp): Set LD_LIBRARY_PATH to allow testing + with dynamic main GMP build. + +2013-01-09 Marco Bodrato + + * mini-gmp/mini-gmp.c (mpz_export): Support op=0 countp=NULL. + +2013-01-08 Niels Möller + + * mini-gmp/tests/t-import.c: New test program, testing both + mpz_import and mpz_export. + * mini-gmp/tests/Makefile (CHECK_PROGRAMS): Added t-import. + + * mini-gmp/tests/mini-random.c (mini_rrandomb_export): New + function. + * mini-gmp/tests/mini-random.h: Declare it. + * mini-gmp/tests/hex-random.c (hex_rrandomb_export): New function. + * mini-gmp/tests/hex-random.h: Declare it. + + * mini-gmp/mini-gmp.c (mpz_export): Compute accurate word count up + front, to avoid generating any high zero words. + +2013-01-07 Marco Bodrato + + * mini-gmp/README: Document base limitation for conversions. + * mini-gmp/mini-gmp.c (mpz_set_str): Remove goto. + (mpz_import, mpz_export): Correctly use order/endianness. + +2013-01-05 Torbjorn Granlund + + * longlong.h (aarch64): Make add_ssaaaa and sub_ddmmss actually work. + +2013-01-04 Marco Bodrato + + From shuax: + * mini-gmp/mini-gmp.c (mpz_import): Reset limb after storing it. + +2013-01-04 Torbjorn Granlund + + From Marko Lindqvist: + * configure.ac: Use AC_CONFIG_HEADERS instead of the obsolete + AM_CONFIG_HEADER. + +2013-01-02 Marco Bodrato + + * tests/mpz/bit.c: Wider testing for mpz_combit. + * tests/mpz/logic.c: Check the -2^n case. + + * mpz/ior.c: Fixed an allocation bug in the -2^n case. + +2012-12-31 Torbjorn Granlund + + * mpn/generic/get_d.c: Minor reorg, add vax D code. + + * gmp-impl.h (double_extract): New union type for vax D floats. + + * tests/mpq/t-get_d.c (check_random): Limit exponents on vax. + +2012-12-30 Marco Bodrato + + * tests/mpz/bit.c (check_clr_extend): Check _set shrink. + +2012-12-29 Torbjorn Granlund + + * demos/calc/calc.c: Remove generated file from repo. + * demos/calc/calc.h: Likewise. + * demos/calc/calclex.c: Likewise. + +2012-12-27 Torbjorn Granlund + + * mpn/generic/get_d.c: Complete rewrite of non-IEEE code. + + * tests/mpq/t-get_d.c (main): Suppress check_random for vax. + +2012-12-25 Torbjorn Granlund + + * mpn/x86_64/bdiv_q_1.asm: Use LEA for binvert_limb_table. + +2012-12-23 Torbjorn Granlund + + * tests/mpz/t-get_d.c (check_onebit): Decrease vax limit to avoid + overflow in last, unused 'want' value. + + * config.guess: Recognise AMD family 22 as a future bobcat. + +2012-12-21 Torbjorn Granlund + + * configure.ac: Rename configure.in. + +2012-12-17 Torbjorn Granlund + + * Version 5.1.0 released. + + * configure.in (none-*-*): Allow this again, but print a warning. + +2012-12-17 Marco Bodrato + + * mpz/n_pow_ui.c: Fix typos in an ASSERT. + +2012-12-16 Torbjorn Granlund + + * mpn/generic/mu_div_qr.c (mpn_preinv_mu_div_qr): Explicitly use + MPN_COPY_INCR for slightly overlapping copy. + +2012-12-15 Marco Bodrato + + * tests/mpn/toom-sqr-shared.h: Skip ALLOCs if the test is skipped. + +2012-12-13 Torbjorn Granlund + + * mpn/x86_64/dos64.m4 (PIC): Move definition early. + (JMPENT): Remove PIC variant. + + * mpn/x86_64/darwin.m4 (JUMPTABSECT): Define to .text, instead of + something sensible. + +2012-12-12 Torbjorn Granlund + + * mpn/x86_64/x86_64-defs.m4 (JMPENT): New macro. + * mpn/x86_64/dos64.m4: Likewise. + * mpn/x86_64/darwin.m4: Likewise. + * mpn/x86_64/mod_34lsub1.asm: Use JMPENT to properly support PIC. + * mpn/x86_64/mullo_basecase.asm: Likewise. + * mpn/x86_64/sqr_basecase.asm: Likewise. + +2012-12-11 Torbjorn Granlund + + * mpn/x86_64/mod_34lsub1.asm: Try different jump table for the benefit + of broken Apple linkers. + +2012-12-09 Torbjorn Granlund + + * configure.in: Make GMP_NONSTD_ABI ABI specific. + +2012-12-08 Torbjorn Granlund + + * Makefile.am (LIBGMP_LT_*, LIBGMPXX_LT_*): Bump version info. + * gmp-h.in: Bump version. + +2012-12-06 Marco Bodrato + + * tests/mpq/reuse.c: New test (adapted from mpf/reuse.c). + * tests/mpq/Makefile.am (check_PROGRAMS): Add reuse. + + * mpz/abs.c: Use NEWALLOC. + * mpz/neg.c: Likewise. + * mpz/com.c: Reduce branches. + +2012-12-05 Niels Möller + + * mpn/generic/brootinv.c (mpn_brootinv): Make valgrind happier, at + the cost of a redundant MPN_ZERO. + + * mpz/jacobi.c (mpz_jacobi): Check for asize == 0 or bsize == 0 + before using the low limbs. + +2012-12-05 Torbjorn Granlund + + * mpn/generic/set_str.c (mpn_dc_set_str): Work around a valgrind issue. + + * mpz/powm_ui.c: Don't assume >= 2 limbs in mod argument. + + * tests/tests.h (TESTS_REPS): Handle float GMP_CHECK_REPFACTOR. + + * longlong.h: Refine cpp test for vax. + * tests/mpn/t-get_d.c: Likewise. + * tests/mpz/t-get_d.c: Likewise. + * tests/mpz/t-cmp_d.c: Likewise. + * tests/mpz/t-get_d.c: Likewise. + * tests/mpq/t-get_d.c: Likewise. + * tests/mpf/t-get_d.c: Likewise. + +2012-11-30 Torbjorn Granlund + + * gen-fac.c (gen_consts): Correct printf types. + + * mpn/arm/v7a/cora15/gmp-mparam.h: New file. + + * configure.in (arm*-*-*): New compiler optional "tune". Pass value for + selected processors. Add more specific path components. + +2012-11-29 Torbjorn Granlund + + From Andoni Morales Alastruey: + * longlong.h: Conditionalise ARM asm on !__thumb__. + +2012-11-28 Torbjorn Granlund + + * config.guess (arm*-*-*): Support specific ARM processors. + * config.sub: Match arm CPUs. + * configure.in (arm*-*-*): Likewise. + + * mpz/powm.c: Move new_b out since it lives on through b. + + * configure.in (arm*-*-*): Pass -marm to deal with compilers defaulting + to thumb code. + +2012-11-26 Torbjorn Granlund + + * tests/cxx/t-ops2.cc (checkz): Reduce huge numbers to avoid vax + overflow. + +2012-11-25 Torbjorn Granlund + + * mpn/generic/get_d.c: Reinsert non-IEEE code. + + * mpn/vax/add_n.asm: New file. + * mpn/vax/add_n.s: Remove. + * mpn/vax/addmul_1.asm: New file. + * mpn/vax/addmul_1.s: Remove. + * mpn/vax/lshift.asm: New file. + * mpn/vax/lshift.s: Remove. + * mpn/vax/mul_1.asm: New file. + * mpn/vax/mul_1.s: Remove. + * mpn/vax/rshift.asm: New file. + * mpn/vax/rshift.s: Remove. + * mpn/vax/sub_n.asm: New file. + * mpn/vax/sub_n.s: Remove. + * mpn/vax/submul_1.asm: New file. + * mpn/vax/submul_1.s: Remove. + + * mpn/vax/elf.m4: New file. + * configure.in (vax*-*-*elf*): New case, grabbing vax/elf.m4. + + * tests/mpn/t-get_d.c (check_onebit): Get vax bounds right. + (main): Switch off check_rand for vax. + +2012-11-22 Niels Möller + + * mini-gmp/tests/run-tests: Copied latest version from GNU Nettle. + Minor fix to the use of $EMULATOR, and proper copyright notice. + +2012-11-16 Torbjorn Granlund + + * mpn/generic/powm_sec.c (redcify): Use mpn_sb_div_r_sec. + + * mpn/generic/sb_div_sec.c: New file. + * mpn/generic/sbpi1_div_sec.c: New file. + * configure.in (gmp_mpn_functions): Add new files. + * gmp-impl.h: Declare new functions. + +2012-11-12 Torbjorn Granlund + + * longlong.h: Add ARM64 support. + * longlong.h: Add AVR support. + + * mpn/powerpc64/mode64/divrem_1.asm: Tune, simplify. + + * mpq/md_2exp.c: Use MPN_COPY_INCR, not MPN_COPY_DECR. + * tests/mpq/t-md_2exp.c (check_random): New function. + +2012-11-10 Torbjorn Granlund + + * mpn/generic/remove.c (mpn_bdiv_qr_wrap): Make static. + +2012-11-04 Torbjorn Granlund + + * mpz/powm_ui.c: Rewrite. + +2012-11-01 Niels Möller + + * mpn/generic/brootinv.c (mpn_brootinv): Input size in limbs + rather than bits. Use single-precision iterations for the first + limb. + * mpn/generic/perfpow.c (is_kth_power): Update mpn_brootinv call. + * tests/mpn/t-brootinv.c (main): Likewise. + * tune/speed.h (SPEED_ROUTINE_MPN_BROOTINV): Likewise. + * gmp-impl.h (mpn_brootinv): Updated prototype. + + * mpn/generic/hgcd2.c (mpn_hgcd2): Removed redundant loop exit + tests in the single-precision loop. + + * mpz/combit.c (mpz_combit): Rewrite, optimizing for the common + case. + +2012-10-31 Niels Möller + + * tests/mpn/Makefile.am (check_PROGRAMS): Added t-brootinv. + * tests/mpn/t-brootinv.c: New file + + * mpn/generic/broot.c (mpn_broot_invm1): Avoid a mullo_n in the + loop, and do powering as a plain mpn_sqr followed by mpn_powlo. + + * tune/speed.c (routine): Added mpn_broot, mpn_broot_invm1, + mpn_brootinv. + + * tune/common.c (speed_mpn_broot, speed_mpn_broot_invm1) + (speed_mpn_brootinv): New functions. + * tune/speed.h (SPEED_ROUTINE_MPN_BROOT) + (SPEED_ROUTINE_MPN_BROOTINV): New macros. + + * mpn/generic/broot.c (mpn_broot_invm1): Made non-static (mainly + for benchmarking). + * gmp-impl.h (mpn_broot_invm1): Declare it. + +2012-10-28 Torbjorn Granlund + + * configure.in (gmp_mpn_functions): Add new files. + * gmp-impl.h: Declare new functions. + * mpn/generic/perfpow.c: Overhaul. + (binv_root, binv_sqroot): Remove. + * mpn/generic/brootinv.c: New file, code from overhauled binv_root. + * mpn/generic/bsqrtinv.c: New file, code from overhauled binv_sqroot. + * mpn/generic/bsqrt.c: New file. + + * tests/mpn/t-broot.c: Add a forgotten TMP_MARK. + +2012-10-28 Niels Möller + + * mpn/generic/broot.c (mpn_broot): New file and function. + * configure.in (gmp_mpn_functions): Add broot. + * gmp-impl.h (mpn_broot): Declare. + * tests/mpn/t-broot.c: New testcase. + * tests/mpn/Makefile.am (check_PROGRAMS): Added t-broot. + +2012-10-27 Torbjorn Granlund + + * mpn/generic/remove.c: Get remainder allocation right. + +2012-10-25 Torbjorn Granlund + + * longlong.h: De-support old POWER asm syntax. + + * tests/mpz/t-remove.c: Run more tests, but use a tad smaller operands. + + * mpn/generic/remove.c (mpn_bdiv_qr_wrap): New function. + (mpn_remove): Call mpn_bdiv_qr_wrap. + * mpz/remove.c: Enable suppressed mpn_remove call. + +2012-10-17 Torbjorn Granlund + + * mpz/powm_ui.c (mpz_powm_ui): Deflect to mpz_powm for large exponent. + +2012-09-10 Torbjorn Granlund + + * demos/factorize.c: Rewrite no more current form. Implement Lucas + prime proving, and make its use the default. + * demos/primes.h: New file. + +2012-08-24 Torbjorn Granlund + + * demos/factorize.c: Overhaul. + +2012-08-06 Marco Bodrato + + * doc/gmp.texi (mpn_neg): Correctly document returned type. + + * gmp-impl.h (_mpz_newalloc, log_n_max): mark with inline (spotted by Niels). + +2012-07-28 Marc Glisse + + * gmpxx.h (std::common_type): New partial specializations with builtin + types. + * tests/cxx/t-cxx11.cc: Test it. + +2012-07-21 Torbjorn Granlund + + * mpn/powerpc32/vmx/mod_34lsub1.asm: Fix r0 clobbering issue with + "large" code affecting elf+darwin PIC. + +2012-07-21 Marc Glisse + + * gmpxx.h (__GMPXX_CONSTANT): Disable for g++-3.4. + +2012-06-26 Torbjorn Granlund + + * Makefile.am (LIBMP_LT_*): Remove these. + +2012-06-26 Marc Glisse + + * Makefile.am (LIBGMP_LT_*, LIBGMPXX_LT_*): Update comment for 5.1.0. + +2012-06-24 Marco Bodrato + + * configure.in (CALLING_CONVENTIONS_OBJS): Disable any use of + assembly code with the --disable-assembly option. + * mpz/oddfac_1.c: Use the ASSERT_CODE macro. + * gen-trialdivtab.c (mpz_log2): Use mpz_sizeinbase (., 2). + + * gmp-impl.h (MPN_SIZEINBASE_16): Replace with MPN_SIZEINBASE_2EXP + from mpz/export.c . + * mpz/export.c (MPN_SIZEINBASE_2EXP): Removed. + * mpn/generic/sizeinbase.c: Use MPN_SIZEINBASE. + + * mpz/nextprime.c: Use MPN_SIZEINBASE_2EXP to count bits. + * mpn/generic/perfpow.c: Likewise. + * mpn/generic/rootrem.c: Likewise. + * mpz/get_d_2exp.c: Likewise. + * mpn/generic/powm_sec.c: Likewise, nailify. + * mpn/generic/powlo.c: Likewise. + * mpn/generic/powm.c: Likewise. + + * mini-gmp/mini-gmp.c (mpz_div_r_2exp, mpz_div_q_2exp): Improve + adjustment condition. + +2012-06-23 Marc Glisse + + * gmpxx.h (numeric_limits): Make content public. + * cxx/limits.cc: New file, proper declarations. + * Makefile.am: List new file. + * cxx/Makefile.am: Likewise. + * cxx/t-misc.cc: Add minimal test for numeric_limits. + +2012-06-09 Marc Glisse + + * gmpxx.h (__gmp_resolve_expr::srcptr_type): New typedef. + (__gmp_temp): Wrapper for mp*_class, the constructor copies the + precision of its second argument for mpf_t. + (__gmp_expr::eval(p, prec)): Remove. + (__gmp_expr::eval(p)): Use __gmp_temp. + (__gmp_set_expr): Never pass prec to eval(). + +2012-06-08 Marco Bodrato + + * gmp-impl.h (__GMP_WITHIN_CONFIGURE): Use the same #if as in gmp-h.in. + (MPN_NORMALIZE_NOT_ZERO): Tighter ASSERT. + (MPZ_NEWALLOC): New macro. + * mpq: Use the new macro when possible. + * mpz/bin_uiui.c: Likewise. + * mpz/oddfac_1.c: Likewise. + * mpz/prodlimbs.c: Likewise. + + * mini-gmp/mini-gmp.c (mpz_realloc): remove a branch. + +2012-06-04 Torbjorn Granlund + + * mpn/powerpc64/aix.m4 (ASM_START): Claim machine type "any". + +2012-06-03 Niels Möller + + * mpn/generic/gcdext.c (mpn_gcdext): Deleted code for handling + impossible case u1 == 0, Simplified test for unlikely case u0 == 0. + +2012-06-02 Torbjorn Granlund + + * mpn/arm/lshiftc.asm: New file. + +2012-06-01 Torbjorn Granlund + + * mpn/arm/aorslsh1_n.asm: Use cmp/cmn instead of subs/adds in more + places. + + * mpz/get_str.c: Don't strip leading zeros since current mpn_get_str + won't generate any. Misc streamlining. + * mpz/out_str.c: Analogous changes. + + * tests/mpz/io.c: Use a wider range of bases. + + * tests/mpz/t-cong.c (check_random): Rewrite random generation for + exponentially distributed operand sizes. + +2012-06-01 Marco Bodrato + + * mpq: Use more macros and MPZ_REALLOC return value when possible. + + * gmp-impl.h (LIMBS): Removed, was an alias for PTR. + * mpz/combit.c: Use PTR and CNST_LIMB. + + * tests/mpn/t-bdiv.c: Test also mpn_bdiv_qr. + * mpn/generic/bdiv_qr.c: Add an ASSERT. + + * mpn/generic/remove.c: Add a zero limb to use bdiv_qr... + +2012-05-31 Marc Glisse + + * gmpxx.h (mpq_class::mpq_class): Handle mpq_class(0,1). + * tests/cxx/t-constr.cc: Test it. + +2012-05-30 Torbjorn Granlund + + * mpn/x86_64 (FUNC_ENTRY): New name for DOS64_ENTRY. + * mpn/x86_64 (FUNC_EXIT): New name for DOS64_EXIT. + +2012-05-29 Marco Bodrato + + * mpz/remove.c: Optimise branches. + + * mpn/generic/toom6h_mul.c: less branches in the LIKELY balanced path. + * mpn/generic/toom8h_mul.c: Likewise. + +2012-05-29 Torbjorn Granlund + + * mpn/arm/v5/mod_1_1.asm: New file. + +2012-05-28 Niels Möller + + * mpn/generic/gcdext.c (compute_v): Simplified carry handling a + bit, reduced stated scratch need from 2n+1 to 2n. Also comment and + ASSERT improvements. + +2012-05-27 Torbjorn Granlund + + * config.guess: Add new x86 CPUs. + * mpn/x86/fat/fat.c: Likewise. + * mpn/x86_64/fat/fat.c: Likewise. + +2012-05-27 Marco Bodrato + + * mpn/x86_64/fat/fat.c: abort iff longmode-capable-bit is turned off. + + * mpn/generic/toom8h_mul.c: mark UNLIKELY branches. + +2012-05-26 Torbjorn Granlund + + * mpz: Use MPZ_REALLOC return value when possible. + +2012-05-25 Marco Bodrato + + * mini-gmp/tests/t-div.c: Test all _qr, _q, _r variants. + * mini-gmp/tests/t-lcm.c: Test the _ui variant. + + * mini-gmp/mini-gmp.c (mpz_mod, mpz_mod_ui): New functions. + * mini-gmp/mini-gmp.h (mpz_mod, mpz_mod_ui): Prototypes. + + * mpz/scan1.c: Simplify, and add a shortcut for scan1(z, 0). + +2012-05-24 Torbjorn Granlund + + * mpz/n_pow_ui.c: Cast non-limb count_leading_zeros argument. + +2012-05-24 Marco Bodrato + + * mpz/remove.c: Support negative divisor. + * tests/mpz/t-remove.c: Test negative divisor. + +2012-05-23 Torbjorn Granlund + + * tests/mpz/reuse.c: Major rewrite. + +2012-05-23 Marco Bodrato + + * mpz/sqrt.c: Further simplify. + * mpz/sqrtrem.c: Likewise. + + * Mark failing branches with UNLIKELY. Many files affected. + +2012-05-22 Torbjorn Granlund + + * mpz/sqrt.c: Allocate less for overlapping operands, simplify. + * mpz/sqrtrem.c: Likewise. + +2012-05-21 Marco Bodrato + + * mpn/generic/toom8_sqr.c: Reduce branches for recursion. + * mpn/generic/toom8h_mul.c: Likewise. + + * tests/mpn/t-toom8h.c: Don't use GMP_NUMB_BITS when not yet defined. + +2012-05-20 Torbjorn Granlund + + * tests/mpz/t-gcd.c: Rewrite. + +2012-05-19 Torbjorn Granlund + + * tests/mpz/t-gcd.c: Generate larger operands for better gcd code + coverage; distribute size exponentially. + +2012-05-17 Marco Bodrato + + * mpf/pow_ui.c: Simplify. + * tests/mpf/reuse.c (dsi_func): Exercise pow_ui. + + * tests/mpf/t-set_ui.c (check_data): LONG_HIGHBIT -> ULONG_HIGHBIT. + * tests/mpf/t-set.c (check_random): New check, both set and init_set. + + * tests/cxx/t-ops.cc (check_mpq): Check squaring. + * tests/mpq/t-equal.c (check_various): Check different den-size. + + * mpn/generic/mullo_n.c: Disable MAYBE_ if WANT_FAT_BINARY. + * mpz/cmpabs_d.c: Remove an unused branch. + + * tests/mpz/t-get_d_2exp.c (check_zero): New check. + * tests/mpz/t-inp_str.c: A few more cases. + * tests/mpz/t-cmp_d.c: More bases and symbols, a few cases. + + * mpz/rootrem.c: Correctly handle odd roots of negatives. + * tests/mpz/t-root.c: Test it. + +2012-05-16 Torbjorn Granlund + + * tests/mpf/t-eq.c (check_random): New function, meat from old main(). + (check_data): New function. + +2012-05-13 Torbjorn Granlund + + * mpn/arm/rsh1aors_n.asm: New file. + * mpn/arm/v5/mod_1_2.asm: New file. + +2012-05-11 Marc Glisse + + * gmpxx.h (explicit operator bool): New functions. + * tests/cxx/t-cxx11.cc: Test the above. + +2012-05-10 Marco Bodrato + + * gmp-impl.h (__gmpn_cpuvec_initialized): Was __gmpn_cpuvec.initialized + * mpn/x86/fat/fat.c: Use separated _initialized variable. + * mpn/x86_64/fat/fat.c: Likewise. + * tests/mpn/t-fat.c: Likewise. + + * mpn/generic/toom2_sqr.c: Override global __gmpn_cpuvec_initialized. + * mpn/generic/toom22_mul.c: Likewise. + * mpn/generic/toom3_sqr.c: Likewise. + * mpn/generic/toom33_mul.c: Likewise. + +2012-05-09 Marco Bodrato + + * mini-gmp/mini-gmp.c: merge mpz_rootrem and mpz_sqrtrem. + + * mpn/generic/sqrtrem.c (invsqrttab): Reduce size removing common byte. + + * mpz/bin_uiui.c (mul3, mul4, mul8): Remove unneeded shifts. + (MAXFACS): Redefine, using the shared (safer) log_n_max. + +2012-05-08 Torbjorn Granlund + + * mpn/minithres/gmp-mparam.h (REDC_1_TO_REDC_N_THRESHOLD): Up to 9, for + coherency with ASSERT in mpn/generic/redc_n.c. + +2012-05-07 Marco Bodrato + + * mpn/minithres/gmp-mparam.h: Updated TOOM6 and FAC_DSC. + * tests/mpn/toom-sqr-shared.h: Don't test if no range. + + * mpz/oddfac_1.c: Add ASSERTs to warn about small threshold. + * tune/tuneup.c: Update minimal threshold for FAC_DSC. + +2012-05-06 Torbjorn Granlund + + * mpn/arm/v6/sqr_basecase.asm: Simplify n=4 code. + +2012-05-05 Marco Bodrato + + * mpn/generic/invert.c: Mark a branch UNLIKELY. + * tune/tuneup.c (tune_fac_u): Update DSC_THRESHOLD minimum. + * gmp-impl.h (FAC_???_THRESHOLD): Update default values. + (ABOVE_THRESHOLD): New definition with __builtin_constant_p. + + * mpn/generic/toom22_mul.c: Disable MAYBE_ if WANT_FAT_BINARY. + * mpn/generic/toom33_mul.c: Likewise. + * mpn/generic/toom2_sqr.c: Likewise. + * mpn/generic/toom3_sqr.c: Likewise. + +2012-05-04 Torbjorn Granlund + + * tune/tuneup.c: Measure POWM_SEC_TABLE after the REDC thresholds. + +2012-05-03 Torbjorn Granlund + + * mpn/generic/powm_sec.c: Use redc_2. + (INNERLOOP): Use this mechanism, like plain powm.c. + (WANT_CACHE_SECURITY): Remove, feature now unconditional. + +2012-05-02 Torbjorn Granlund + + * mpz/bin_uiui.c: Make use of CNST_LIMB. + +2012-05-02 Marco Bodrato + + * mpz/mfac_uiui.c: Support limb != ui. + +2012-05-02 Torbjorn Granlund + + * mpn/arm/logops_n.asm: Work around register clobbering issue. + + * mpn/arm/aorscnd_n.asm: New file. + +2012-05-01 Torbjorn Granlund + + * configure.in: Put arm dirs in path in proper prio order. + + * mpn/arm/logops_n.asm: New file. + + * mpz/2fac_ui.c: Fix assumed typo. + + * mpn/arm/v6/gmp-mparam.h: New file. + + * mpn/arm/v5/gcd_1.asm: Hack for undefined BMOD_1_TO_MOD_1_THRESHOLD. + * mpn/arm/v6t2/gcd_1.asm: Likewise. + +2012-04-30 Torbjorn Granlund + + * mpn/arm/v6/sqr_basecase.asm: New file. + +2012-04-30 Marco Bodrato + + * mpn/generic/comb_tables.c: New file. + * configure.in: Add it. + * gen-fac.c: Define table limits. + * gmp-impl.h: Declare tables. + (log_n_max): New static function. + * mpz/2fac_ui.c: Use shared tables. + * mpz/bin_uiui.c: Likewise. + * mpz/oddfac_1.c: Likewise. + * mpz/primorial_ui.c: Likewise. + + * mpz/mfac_uiui.c: New file. + * Makefile.am: Compile it. + * mpz/Makefile.am (libmpz_la_SOURCES): Add mpz_mfac_uiui.c + * gmp-h.in (mpz_mfac_uiui): Declare. + + * tests/mpz/t-mfac_uiui.c: New file. + * tests/mpz/Makefile.am: Run it. + + * doc/gmp.texi: Document mpz_mfac_uiui, collapsing with other factorial functions. + + * tests/mpz/t-lcm.c: Test zero too. + + * mpz/prodlimbs.c: Simplify threshold (should be tuned, not guessed). + +2012-04-29 Torbjorn Granlund + + * mpn/arm/aors_n.asm: Tune for more stable performance. + + * mpn/arm/aorslsh1_n.asm: New file. + + * mpn/arm/mod_34lsub1.asm: New file. + + * mpn/arm/v6t2/divrem_1.asm: New file. + +2012-04-28 Torbjorn Granlund + + * mpn/thumb/add_n.asm: New file. + * mpn/thumb/sub_n.asm: New file. + * mpn/thumb/add_n.s: Remove broken code. + * mpn/thumb/sub_n.s: Likewise. + + * mpn/arm/v6/addmul_1.asm: Rewrite for stable speed, smaller size. + * mpn/arm/v6/mul_1.asm: Likewise. + +2012-04-27 Torbjorn Granlund + + * configure.in: Search arm/v6t2 for arm7. + + * mpn/arm/v5/gcd_1.asm: New file. + * mpn/arm/v6t2/gcd_1.asm: New file. + + * mpn/arm/mode1o.asm: New file. + * mpn/arm/v6t2/mode1o.asm: New file. + + * mpn/arm/arm-defs.m4 (LEA): New define. + * mpn/arm/invert_limb.asm: Use LEA. + +2012-04-26 Marco Bodrato + + * mpz/bin_uiui.c (bc_bin_uiui): Nail support. + * tests/cxx/t-ops2.cc: Test 0/3. + * oddfac_1.c: assume n > 26. + * tests/mpz/t-jac.c (mpn_jacobi_n): Enlarge tested sizes. + +2012-04-24 Torbjorn Granlund + + * mpn/arm/v6/addmul_2.asm: New file. + * mpn/arm/v6/mul_2.asm: New file. + +2012-04-23 Torbjorn Granlund + + * mpn/arm/aorsmul_1.asm: Tweak loop control for a 6% speed increase. + +2012-04-22 Torbjorn Granlund + + * configure.in: Recognise ARM sub-architectures. + + * configfsf.guess: Update to current FSF version. + * configfsf.sub: Likewise. + + * mpn/arm/bdiv_dbm1c.asm: New file. + + * mpn/arm/v6/mul_1.asm: New file. + * mpn/arm/v6/addmul_1.asm: New file. + +2012-04-22 Marco Bodrato + + * gen-fac.c: Renamed, was gen-fac_ui.c . + * Makefile.am: Renamed gen-fac.c and fac_table.h . + * gmp-impl.h: #include "fac_table.h". + * mpz/oddfac_1.c: Use generated constant. + * mpz/bin_ui.c: Small optimisations. + + * tune/common.c (speed_mpz_bin_ui): New function. + * tune/speed.h: Declare it. + * tune/speed.c: Use it. + +2012-04-21 Torbjorn Granlund + + * mpn/arm/mul_1.asm: Cleanup. + * mpn/arm/copyi.asm: Cleanup, assume allocate-on-write cache. + * mpn/arm/copyd.asm: Likewise. + + * mpn/arm/add_n.asm: Delete. + * mpn/arm/sub_n.asm: Delete. + * mpn/arm/aors_n.asm: New file, made from old files. + + * mpn/arm/addmul_1.asm: Delete. + * mpn/arm/submul_1.asm: Delete. + * mpn/arm/aorsmul_1.asm: New file, made from old files. + + * mpn/arm/com.asm: New file. + * mpn/arm/lshift.asm: New file. + * mpn/arm/rshift.asm: New file. + +2012-04-20 Torbjorn Granlund + + * tests/mpq/io.c: New file. + * tests/mpq/Makefile.am: Run it. + + * mpz/clrbit.c: Simplify along the lines of setbit.c. + +2012-04-20 Marco Bodrato + + * mpz/setbit.c: Simplify. + + * gmp-impl.h (LOG2C): Define. + * mpz/fac_ui.c (LOG2C): Remove. + * mpz/2fac_ui.c (LOG2C): Remove. + * mpz/oddfac_1.c (LOG2C): Remove. + * mpn/generic/binvert.c (LOG2C): Remove. + * mpn/generic/invertappr.c (LOG2C): Remove. + + * mpz/bin_uiui.c (mpz_goetgheluck_bin_uiui): Move declarations, + and assume that n and k are not small. + +2012-04-19 Torbjorn Granlund + + * tests/mpz/Makefile.am (check_PROGRAMS): Add t-remove. + + * tests/mpz/t-remove.c: Clear out mpz variables. + + * tests/mpz/t-cong.c (check_random): Use much larger numbers. + (check_data): Check congruences mod 0. + + * tests/mpz/t-divis.c: Test divisibility by zero. + + * tests/mpz/reuse.c: Test mpz_mod. + + * mpz/setbit.c: Remove dead code. Use CNST_LIMB. + * mpz/clrbit.c: Use CNST_LIMB. + +2012-04-19 Marco Bodrato + + * primesieve.c: New file, with functions from mpz/oddfac_1.c . + * mpz/oddfac_1.c (bitwise_primesieve): Re-moved. + * Makefile.am (libgmp_la_SOURCES): Add primesieve.c . + * gmp-impl.h (gmp_primesieve): Declare. + + * mpz/bin_uiui.c (mpz_goetgheluck_bin_uiui): New, factor-based + implementation. + * tests/mpz/t-bin.c: Extend tests, to cover _goetgheluck. + + * mpz/primorial_ui.c: New file. + * mpz/Makefile.am (libmpz_la_SOURCES): Add mpz/primorial_ui.c + * Makefile.am (MPZ_OBJECTS): Add mpz/primorial_ui$U.lo + * gmp-h.in (mpz_primorial_ui): Declare. + * tests/mpz/t-primorial_ui.c: New test for the new function. + * tests/mpz/Makefile.am (check_PROGRAMS): Add t-primorial_ui. + * doc/gmp.texi: Short documentation for the new function. + +2012-04-17 Torbjorn Granlund + + * mpn/x86_64/coreisbr/aorsmul_1.asm: Fix some DOS64 issues. + * mpn/x86_64/coreisbr/mul_1.asm: Likewise. + + * mpn/x86_64/fastsse/lshiftc-movdqu2.asm: Adhere to DOS64 register + partitioning rules. + + * mpn/x86_64/fastsse/copyi-palignr.asm: Implement temporary workaround + to overlap issue. + +2012-04-17 Marco Bodrato + + * mpz/bin_uiui.c: Support small limbs (fallback on bin_ui). + + * tests/mpn/toom-sqr-shared.h: Use a restricted range. + * tests/mpn/t-toom2-sqr.c: Specify correct range. + * tests/mpn/t-toom3-sqr.c: Likewise. + * tests/mpn/t-toom4-sqr.c: Likewise. + * tests/mpn/t-toom6-sqr.c: Likewise. + * tests/mpn/t-toom8-sqr.c: Likewise, but extended. + * tests/mpn/Makefile.am (check_PROGRAMS): Add t-toom?-sqr tests. + + * mpn/generic/sbpi1_bdiv_q.c: Move ASSERTs, to support qp = np. + +2012-04-17 Torbjorn Granlund + + * mpn/x86_64/copyd.asm: Rewrite. + * mpn/x86_64/copyi.asm: Rewrite. + +2012-04-16 Torbjorn Granlund + + * mpn/x86_64/fastsse/lshift-movdqu2.asm: Add DOS entry/exit sequences. + * mpn/x86_64/fastsse/rshift-movdqu2.asm: Likewise. + * mpn/x86_64/fastsse/lshiftc-movdqu2.asm: Likewise. + + * mpn/x86_64/x86_64-defs.m4 (palignr): New macro. + (x86_opcode_regxmm, x86_opcode_regxmm_list): New, made from x86 mmx + counterparts. + (x86_lookup): Copy from x86/x86-defs.m4. + * mpn/x86_64/fastsse/copyd-palignr.asm: Use palignr macro. + * mpn/x86_64/fastsse/copyi-palignr.asm: Likewise. + +2012-04-15 Marco Bodrato + + * tests/mpz/t-bin.c: Add more tests on small values. + * mpz/bin_uiui.c (mpz_bdiv_bin_uiui): Smaller temporary areas. + +2012-04-15 Torbjorn Granlund + + * mpn/x86_64/fastsse/copyd-palignr.asm: New file. + * mpn/x86_64/fastsse/copyi-palignr.asm: New file. + * mpn/x86_64/core2/copyd.asm: New file. + * mpn/x86_64/core2/copyi.asm: New file. + * mpn/x86_64/nano/copyd.asm: New file. + * mpn/x86_64/nano/copyi.asm: New file. + * mpn/x86_64/atom/copyd.asm: New file. + * mpn/x86_64/atom/copyi.asm: New file. + +2012-04-13 Marco Bodrato + + * mpz/bin_uiui.c: Rewrite (some parts are Torbjorn's). + * gen-fac_ui.c: Generate new constants for bin_uiui. + + * mini-gmp/mini-gmp.h (mpz_fac_ui, mpz_bin_uiui): New definitions. + * mini-gmp/mini-gmp.c (mpz_fac_ui, mpz_bin_uiui): Trivial + implementation. + + * tests/mpz/t-fac_ui.c: Check Wilson's theorem on a big value. + + * mpn/generic/invert.c: Remove support for scratch == NULL. + * tune/speed.h (SPEED_ROUTINE_MPN_MUPI_DIV_QR): Allocate scratch + space for mpn_invert. + + * mpz/mul_i.h: Small clean-up. + + * tests/mpn/toom-sqr-shared.h: New file. + * tests/mpn/t-toom2-sqr.c: New file. + * tests/mpn/t-toom3-sqr.c: New file. + * tests/mpn/t-toom4-sqr.c: New file. + * tests/mpn/t-toom6-sqr.c: New file. + * tests/mpn/t-toom8-sqr.c: New file. + * tests/mpn/Makefile.am (EXTRA_DIST): Add toom-sqr-shared.h . + + * mpn/generic/toom62_mul.c: Use add_n, sub_n, when possible. + +2012-04-12 Torbjorn Granlund + + * mpn/x86_64/fastsse/lshift-movdqu2.asm: New file. + * mpn/x86_64/fastsse/rshift-movdqu2.asm: New file. + * mpn/x86_64/fastsse/lshiftc-movdqu2.asm: New file. + * mpn/x86_64/coreisbr/lshift.asm: New file. + * mpn/x86_64/coreisbr/rshift.asm: New file. + * mpn/x86_64/coreisbr/lshiftc.asm: New file. + * mpn/x86_64/k10/lshift.asm: New file. + * mpn/x86_64/k10/rshift.asm: New file. + * mpn/x86_64/k10/lshiftc.asm: New file. + + * mpn/x86_64/fastsse/lshift.asm: Simplify to very basic form. + +2012-04-11 Niels Möller + + * Makefile.am (check-mini-gmp): Pass -I../.. in EXTRA_CFLAGS, to + locate gmp.h. + +2012-04-11 Marco Bodrato + + * mini-gmp/mini-gmp.h (mpz_root, mpz_rootrem): define (correctly). + * mini-gmp/mini-gmp.c (mpz_rootrem): Extended code from _root. + (mpz_root): Use mpz_rootrem. + (mpz_mul_ui): Correctly handle negative operands. + + * mini-gmp/tests/Makefile (CHECK_PROGRAMS): add t-root. + * mini-gmp/tests/t-root.c: New file. + * mini-gmp/tests/t-reuse.c: Enable root{,rem} tests. + +2012-04-10 Marco Bodrato + + * gen-fac_ui.c (mpz_root): Remove. + * mini-gmp/mini-gmp.c (mpz_root): New, support negative operands. + * mini-gmp/mini-gmp.h (mpz_root): define. + (mpz_out_str): Test also __STDIO_LOADED (for VMS). + * mpz/2fac_ui.c: Cosmetic change. + +2012-04-07 Torbjorn Granlund + + * mpn/ia64/gcd_1.asm: Rewrite inner loop to use ctz table. + +2012-04-05 Torbjorn Granlund + + * mpn/powerpc64/p7/popcount.asm: Properly extend arg n for mode32. + * mpn/powerpc64/p7/hamdist.asm: Likewise. + +2012-04-04 Torbjorn Granlund + + * mpn/powerpc64/p7/popcount.asm: New file. + * mpn/powerpc64/p7/hamdist.asm: New file. + + * longlong.h (ARM count_leading_zeros): Enable for more arch versions. + + * mpn/x86_64/gcd_1.asm: Make room for DOS64 regparm shadow area. + * mpn/x86_64/core2/gcd_1.asm: Likewise. + +2012-04-03 Torbjorn Granlund + + * mpn/x86_64/coreisbr/aorrlsh_n.asm: Make it actually work for DOS64. + +2012-04-02 Marco Bodrato + + * mpz/oddfac_1.c: Initialize size for ASSERT. + +2012-04-02 Torbjorn Granlund + + * gmp-h.in (_GMP_H_HAVE_FILE): Test also __STDIO_LOADED (for VMS). + + * gmp-impl.h (doprnt_format_t, etc): Remove bogus __GMP_DECLSPECs. + +2012-03-30 Marco Bodrato + + * mpn/x86_64/sqr_basecase.asm: Speed-up for small cases. + +2012-03-29 Torbjorn Granlund + + * mpn/sparc64/gcd_1.asm: New file. + +2012-03-27 Torbjorn Granlund + + * config.guess: Fix typo in coreisbr recognition. + +2012-03-26 Marco Bodrato + + * mpn/x86_64/gcd_1.asm: Reduce latency. + * mpn/x86_64/mul_basecase.asm: Save one jump. + + * mpz/iset_ui.c: Don't realloc. + +2012-03-20 Marco Bodrato + + * mp_clz_tab.c: Add __clz_tab[128]. + * longlong.h (count_trailing_zeros): Use it in pure C variant. + +2012-03-20 Torbjorn Granlund + + * configure.in (x86 fat_path): Add many missing directories. + * mpn/x86/fat/fat.c (__gmpn_cpuvec_init): Rewrite. + (fake_cpuid_table): Add many more CPUs. + + * mpn/x86_64/fat/fat.c (__gmpn_cpuvec_init): Minor spacing cleanup. + +2012-03-19 Torbjorn Granlund + + * mpn/x86/x86-defs.m4 (CALL, PIC_WITH_EBX): New macros. + * mpn/x86/darwin.m4: Likewise. + * mpn/x86/k7/gcd_1.asm: Use new macros to support PIC. + * mpn/x86/p6/gcd_1.asm: Likewise. + +2012-03-19 Marco Bodrato + + * gen-fac_ui.c: Generate more constants (possible mini-mpz_root). + * mpz/oddfac_1.c: Improve ASSERTs. + (log_n_max): Use precomputed table. + + * longlong.h (_PROTO): Remove. + +2012-03-18 Torbjorn Granlund + + * longlong.h (count_trailing_zeros): Write better pure C default + variant. + + * mpn/x86/p6/gcd_1.asm: Remove forgotten x86_64 reference. + + * mpn/x86/p6/gmp-mparam.h: Update, to get BMOD_1_TO_MOD_1_THRESHOLD + defined for fat binaries. + +2012-03-17 Torbjorn Granlund + + * mpn/x86/k7/gcd_1.asm: Rewrite. + * mpn/x86/p6/gcd_1.asm: New file. + + * mpn/x86_64/core2/gcd_1.asm: Conditionally suppress reduction calls. + * mpn/x86_64/gcd_1.asm: Rewrite. + +2012-03-15 Torbjorn Granlund + + * mpn/generic/gcd_1.c: Parameterise zerotab code. + + * mpn/x86_64/nano/gcd_1.asm: New file, grabbing core2 asm file. + + * mpn/x86_64/core2/gcd_1.asm: Speed up loop code, simplify non-loop + code. + +2012-03-13 Torbjorn Granlund + + * mpn/x86_64/core2/gcd_1.asm: Add hack to support fat builds. + + * mpn/x86_64/core2/gcd_1.asm: Shorten critical path. + +2012-03-12 Torbjorn Granlund + + * mpn/x86_64/core2/gcd_1.asm: New file. + * mpn/x86_64/k10/gcd_1.asm: New file, grabbing core2 asm file. + * mpn/x86_64/bd1/gcd_1.asm: Likewise. + + * mpn/x86_64/bobcat/sqr_basecase.asm: New file. + * mpn/x86_64/bobcat/mul_basecase.asm: Minor tuning. + +2012-03-10 Torbjorn Granlund + + * configure.in (fat_functions): Add addlsh1_n, addlsh2_n, addmul_2, + mullo_basecase, redc_1, redc_2, sublsh1_n. + + * gmp-impl.h (struct cpuvec_t): Add fields for new fat functions. + * gmp-impl.h: Adjust corresponding declarations. + + * mpn/generic/redc_2.c (mpn_addmul_2): Make static. + + * mpn/x86_64/fat/fat_entry.asm (FAT_INIT): Expand before fat_init to + reduce branch offsets. Pass plain 0,1,3... in %al since we'd else run + out of 8-bit range. + + * mpn/x86_64/fat/fat_entry.asm (fat_init): Scale passed index value. + * mpn/x86/fat/fat_entry.asm (fat_init): Use movzbl for expanding index + value. + + * mpn/x86_64/x86_64-defs.m4 (CPUVEC_FUNCS_LIST): Add new fat functions. + * mpn/x86/x86-defs.m4 (CPUVEC_FUNCS_LIST): Likewise. + * mpn/x86_64/fat/fat.c (__gmpn_cpuvec): Likewise. + * mpn/x86/fat/fat.c (__gmpn_cpuvec): Likewise. + + * mpn/x86_64/fat/redc_2.c: New file. + * mpn/x86/fat/mullo_basecase.c: New file. + * mpn/x86/fat/redc_1.c: New file. + * mpn/x86/fat/redc_2.c: New file. + + * tests/mpn/t-fat.c: Test mullo_basecase. + +2012-03-08 Torbjorn Granlund + + * mpn/x86_64/coreisbr/addmul_2.asm: Port to DOS64. + +2012-02-29 Marc Glisse + + * gmpxx.h: Ignore partial C++11 support in g++-4.6. + * tests/cxx/t-cxx11.cc: Likewise. + + * gmpxx.h (operator""): New functions. + * tests/cxx/t-cxx11.cc: Test the above. + * doc/gmp.texi: Document the above. + +2012-03-08 Marco Bodrato + + * acinclude.m4 (GMP_H_ANSI): Remove. + * configure.in: Don't use GMP_H_ANSI. + * gmp-h.in (__GMP_HAVE_PROTOTYPES): Remove. + +2012-03-08 Torbjorn Granlund + + * mpn/x86_64/fat/fat.c (fake_cpuid_table): Recognise "bulldozer". + (__gmpn_cpuvec_init): Overhaul to match configure.in. + + * configure.in: Adjust bulldozer path_64. + +2012-03-07 Torbjorn Granlund + + * configure.in (x86_64 fat_path): List recently added AMD directories. + + * mpn/x86_64/bobcat/copyi.asm: New file. + * mpn/x86_64/bobcat/copyd.asm: New file. + + * config.guess: Handle AMD 11h correctly. + + * tune/tuneup.c (tune_redc): Better handle situation where redc_2 is + never faster. + +2012-03-06 Torbjorn Granlund + + * mpn/x86_64/bobcat/mul_basecase.asm: New file. + +2012-03-04 Torbjorn Granlund + + * mpn/x86_64/bobcat/mul_1.asm: New file. + * mpn/x86_64/bobcat/aorsmul_1.asm: New file. + +2012-03-04 Marco Bodrato + + * mpz/invert.c: Remove mod 0 branch. + * tests/mpz/t-invert.c: Avoid testing mod 0. + * doc/gmp.texi (mpz_invert): Specify mod 0 is not handled. + + * gmp-h.in (__gmp_signed, __gmp_const): Remove. + (__GMP_HAVE_TOKEN_PASTE, __GMP_HAVE_CONST): Remove. + * gmp-impl.h: Strip __GMP_HAVE_TOKEN_PASTE and __GMP_HAVE_CONST. + * demos/expr/: Strip __gmp_const usage from all files. + + * tests/mpz/t-powm.c (allsizes_seen): Require unsigned*. + +2012-03-03 Torbjorn Granlund + + * mpn/x86_64/k8/gmp-mparam.h: New file. + * mpn/x86_64/k10/gmp-mparam.h: New file. + + * mpn/generic/hgcd_step.c (mpn_hgcd_step): Remove unused variables. + * mpn/generic/hgcd_jacobi.c (hgcd_jacobi_step): Likewise. + * mpn/generic/hgcd_reduce.c (hgcd_matrix_apply): Likewise. + * mpn/generic/mu_bdiv_qr.c: Likewise. + * mpz/jacobi.c: Likewise. + * mpz/mod.c: Likewise. + + * mpn/generic/toom42_mul.c: Remove unread variable. + * mpn/generic/set_str.c (mpn_set_str_compute_powtab): Likewise. + * mpn/generic/rootrem.c (mpn_rootrem_internal): Likewise. + * tests/refmpn.c (refmpn_mul): Likewise. + * mpn/generic/hgcd_appr.c (mpn_hgcd_appr): Propagate mask computation + into ASSERT, remove variable. + + * gmp-h.in (__GMP_PROTO): Remove. + * Strip __GMP_PROTO usage from all files. + * Strip prototype parameter names from all files. + +2012-03-01 Marco Bodrato + + * doc/gmp.texi (mpz_invert): Correctly document result range. + * tests/mpz/t-invert.c: Small range correction. + +2012-03-01 Torbjorn Granlund + + * mpn/x86_64/mullo_basecase.asm: New file. + +2012-02-29 Marc Glisse + + * gmpxx.h (std::numeric_limits): New partial specialization. + +2012-02-29 Niels Möller + + * mini-gmp/tests/t-reuse.c: New test case, based on + tests/mpz/reuse.c. + + * mini-gmp/mini-gmp.c (mpz_cdiv_r_ui): New function. + (mpz_fdiv_r_ui): New function. + (mpz_tdiv_r_ui): New function. + (mpz_powm_ui): New function. + (mpz_pow_ui): New function. + (mpz_ui_pow_ui): Use mpz_pow_ui. + (mpz_gcdext): Fixed input/output overlap, for the case of one + input being zero. + (mpz_sqrtrem): Fix for the case r NULL, U zero. + + * Makefile.am (check-mini-gmp): Use $(MAKE). + (clean-mini-gmp): New target. + (clean-local, distclean-local): New automake targets. Depend on + clean-mini-gmp. + +2012-02-28 Niels Möller + + * Makefile.am (check-mini-gmp): New target, for running the + mini-gmp testsuite. + + * mini-gmp/tests/Makefile (srcdir, MINI_GMP_DIR): New make + variables. These can be overridden when using a separate build + directory. + (EXTRA_CFLAGS): Renamed, was OPTFLAGS. + + * mini-gmp/mini-gmp.c (mpz_abs_add): Don't cache limb pointers + over MPZ_REALLOC, since that breaks in-place operation. Bug + spotted by Torbjörn. + (mpz_and, mpz_ior, mpz_xor): Likewise. + (mpz_cmp): Fixed comparison of negative numbers. + +2012-02-27 Torbjorn Granlund + + * mpn/x86_64/fastsse/lshiftc.asm: New file. + * mpn/x86_64/fastsse/com.asm: New file. + + * mpn/x86_64/bd1/popcount.asm: New file. + * mpn/x86_64/bd1/hamdist.asm: New file. + + * mpn/x86_64/fastsse/copyi.asm: New file. + * mpn/x86_64/fastsse/copyd.asm: New file. + * mpn/x86_64/fastsse/lshift.asm: New file. + +2012-02-26 Torbjorn Granlund + + * mpn/x86_64/coreisbr/addmul_2.asm: New file. + + * tests/devel/try.c (param_init): Don't require addmul_N to handle + overlap. + + * mpn/x86_64/bd1/mul_1.asm: New file. + * mpn/x86_64/bd1/aorsmul_1.asm: New file. + +2012-02-26 Marco Bodrato + + * mpz/2fac_ui.c: New file: implements n!!. + * Makefile.am (MPZ_OBJECTS): Add mpz/2fac_ui. + * gmp-h.in: Declare mpz_2fac_ui. + * tests/mpz/t-fac.c: Test mpz_2fac_ui. + * doc/gmp.texi: Document mpz_2fac_ui. + * mpz/Makefile.am (libmpz_la_SOURCES): Add 2fac_ui.c. + + * mpz/oddfac_1.c (mpz_oddfac_1): Use umul_ppmm when size = 2. + +2012-02-26 Niels Möller + + * mini-gmp: New subdirectory. For use by GMP bootstrap, and as a + fallback for applications needing bignums but not high + performance. + + * bootstrap.c: New file, replacing dumbmp.c. Uses mini-gmp for the + standard GMP functions, and then defines the few functions + particular for the bootstrap. + * dumbmp.c: Deleted file. A few functions moved to bootstrap.c. + + * gen-bases.c: Include bootstrap.c, not dumbmp.c. + * gen-fac_ui.c: Likewise. + * gen-trialdivtab.c: Likewise. + * gen-fib.c: Include bootstrap.c, not dumbmp.c. Use assert rather + than ASSERT. Deleted casts of xmalloc return value. + * gen-psqr.c: Likewise. + (COLLAPSE_ELEMENT): Use memmove rather than mem_copyi. + + * Makefile.am: Replaced all uses of dumbmp.c by bootstrap.c. + (EXTRA_DIST, dist-hook): Arrange for distribution of the mini-gmp + files. + +2012-02-24 Marco Bodrato + + * mpz/invert.c: Use ABSIZ, MPZ_EQUAL_1_P. + * mpz/abs.c: Collapse MPZ_REALLOC(x,.) and PTR(x). + * mpz/aors_ui.h: Likewise. + * mpz/com.c: Likewise. + * mpz/neg.c: Likewise. + + * mpz/invert.c: Reply "no-inverse" when modulus is zero. + * tests/mpz/t-invert.c: Add more checks. + * doc/gmp.texi (mpz_invert): Inverse can not be zero. + +2012-02-24 Torbjorn Granlund + + * tests/mpn/logic.c: New file. + * tests/mpn/Makefile.am (check_PROGRAMS): Add logic. + + * tests/mpz/t-invert.c: New file. + * tests/mpz/Makefile.am (check_PROGRAMS): Add t-invert. + +2012-02-24 Marc Glisse + + * tests/mpq/t-cmp.c: Move NUM and DEN macros... + * tests/mpq/t-cmp_ui.c: Likewise... + * gmp-impl.h: ... to here. + + * mpq/abs.c: Use NUM, DEN, SIZ, ALLOC, PTR, MPZ_REALLOC. + * mpq/aors.c: Likewise. + * mpq/canonicalize.c: Likewise. + * mpq/clear.c: Likewise. + * mpq/cmp.c: Likewise. + * mpq/cmp_si.c: Likewise. + * mpq/cmp_ui.c: Likewise. + * mpq/div.c: Likewise. + * mpq/equal.c: Likewise. + * mpq/get_d.c: Likewise. + * mpq/get_den.c: Likewise. + * mpq/get_num.c: Likewise. + * mpq/get_str.c: Likewise. + * mpq/init.c: Likewise. + * mpq/inp_str.c: Likewise. + * mpq/inv.c: Likewise. + * mpq/md_2exp.c: Likewise. + * mpq/mul.c: Likewise. + * mpq/neg.c: Likewise. + * mpq/set.c: Likewise. + * mpq/set_d.c: Likewise. + * mpq/set_den.c: Likewise. + * mpq/set_f.c: Likewise. + * mpq/set_num.c: Likewise. + * mpq/set_si.c: Likewise. + * mpq/set_str.c: Likewise. + * mpq/set_ui.c: Likewise. + * mpq/set_z.c: Likewise. + * mpq/swap.c: Likewise. + + * tests/mpq/t-inv.c: New test file. + * tests/mpq/Makefile.am: Add the above. + + * gmpxx.h (__gmp_set_expr): Use mpq_set_z. + + * mpq/md_2exp.c: Collapse MPZ_REALLOC(x,.) and PTR(x). + * mpq/set_d.c: Likewise. + * mpq/set_f.c: Likewise. + +2012-02-24 Niels Möller + + * mpn/x86_64/core2/aorsmul_1.asm: Added mpn_addmul_1c and + mpn_submul_1c entry points. + +2012-02-23 Marc Glisse + + * mpz/abs.c: Use ALLOC, SIZ, ABSIZ, PTR, MPZ_REALLOC. + * mpz/aors_ui.h: Likewise. + * mpz/array_init.c: Likewise. + * mpz/cdiv_q.c: Likewise. + * mpz/cdiv_qr.c: Likewise. + * mpz/cdiv_r.c: Likewise. + * mpz/clear.c: Likewise. + * mpz/clrbit.c: Likewise. + * mpz/cmp_si.c: Likewise. + * mpz/com.c: Likewise. + * mpz/fdiv_q.c: Likewise. + * mpz/fdiv_qr.c: Likewise. + * mpz/fdiv_r.c: Likewise. + * mpz/get_si.c: Likewise. + * mpz/get_str.c: Likewise. + * mpz/init.c: Likewise. + * mpz/inp_str.c: Likewise. + * mpz/iset.c: Likewise. + * mpz/iset_d.c: Likewise. + * mpz/iset_si.c: Likewise. + * mpz/iset_str.c: Likewise. + * mpz/iset_ui.c: Likewise. + * mpz/mod.c: Likewise. + * mpz/neg.c: Likewise. + * mpz/out_str.c: Likewise. + * mpz/random2.c: Likewise. + * mpz/set_si.c: Likewise. + * mpz/set_str.c: Likewise. + * mpz/set_ui.c: Likewise. + * mpz/setbit.c: Likewise. + * mpz/sqrt.c: Likewise. + * mpz/swap.c: Likewise. + * mpz/tdiv_r_2exp.c: Likewise. + + * tests/cxx/t-ops.cc: Test mpz_abs reallocation. + +2012-02-23 Torbjorn Granlund + + * mpn/x86_64/core2/rsh1aors_n.asm: Complete rewrite. + * mpn/x86_64/coreisbr/rsh1aors_n.asm: Move old core2 code here. + + * mpn/x86_64/redc_1.asm: Make it work for DOS64 (broken in last edit). + +2012-02-20 Marco Bodrato + + * mpn/generic/toom_interpolate_8pts.c: Compute carry iif non-trivial. + + * mpz/gcdext.c: Adapt to relaxed mpn_gcdext's input requirements. + + * mpz/and.c: Use mpn_ logic everywhere. Reduce branches. + * mpz/ior.c: Likewise. + * mpz/xor.c: Likewise. + +2012-02-20 Torbjorn Granlund + + * mpn/x86_64/coreisbr/mul_1.asm: New file. + + * mpn/x86_64/coreisbr/aorsmul_1.asm: New file. + + * mpn/x86_64/mod_34lsub1.asm: Avoid ",pt" branch hint since many + assemblers don't support it. + +2012-02-19 Torbjorn Granlund + + * mpn/generic/redc_1.c: Put back mpn_add_n call, return its carry. + Reintroduce previously removed RP argument. + * mpn/x86_64/redc_1.asm: Likewise. + + * mpn/generic/redc_2.c: Remove mpn_sub_n call, return carry from + mpn_add_n call. + + * gmp-impl.h (mpn_redc_1, mpn_redc_2): Now return an mp_limb_t. + + * tune/speed.h (SPEED_ROUTINE_REDC_1): Adopt to pass RP argument. + + * tests/refmpn.c (refmpn_redc_1): Adopt to new redc_1 interface. + + * mpn/generic/powm.c (MPN_REDC_1): Pass rp parameter to mpn_redc_1. + * mpn/generic/powm_sec.c (MPN_REDC_1_SEC): Likewise. + * mpn/generic/powm.c (MPN_REDC_2): New macro, use for mpn_redc_2. + +2012-02-18 Marc Glisse + + * gmpxx.h (std::common_type): New partial specialization in C++11. + * tests/cxx/t-cxx11.cc: Test it. + + * gmpxx.h: Don't declare long double functions that are never defined. + + * gmpxx.h (__gmp_binary_expr): Let things happen in place: q=q*q+z*z + becomes tmp=z*z, q=q*q, q+=tmp. + * tests/cxx/t-binary.cc: More variable reuse tests. + +2012-02-17 Marc Glisse + + * gmp-h.in (__GMP_WITHIN_GMP): Test with #ifdef instead of #if, for + the benefit of applications using gcc -Wundef. + (__GMP_WITHIN_GMPXX): Likewise. + +2012-02-16 Marc Glisse + + * gmpxx.h (__gmp_binary_expr): Let things happen in place: e=a*b-c*d + becomes tmp=c*d, e=a*b, e-=tmp. + * tests/cxx/t-binary.cc: More variable reuse tests. + +2012-02-15 Niels Möller + + * tune/tuneup.c (mul_toom43_to_toom54_threshold): New global. + (tune_mul): Added tuning of MUL_TOOM43_TO_TOOM54_THRESHOLD. + * tune/speed.h (SPEED_ROUTINE_MPN_TOOM43_FOR_TOOM54_MUL): New macro. + (SPEED_ROUTINE_MPN_TOOM54_FOR_TOOM43_MUL): New macro. + Prototypes for corresponding functions. + * tune/common.c (speed_mpn_toom43_for_toom54_mul): New function. + (speed_mpn_toom54_for_toom43_mul): New function. + + * gmp-impl.h (MPN_TOOM43_MUL_MINSIZE): Corrected constant. + (MPN_TOOM53_MUL_MINSIZE): Likewise. + (MPN_TOOM54_MUL_MINSIZE): New constant. + (mpn_toom54_mul): Added prototype. + (MUL_TOOM43_TO_TOOM54_THRESHOLD): New threshold. Default value and + tuning setup. + +2012-02-14 Niels Möller + + * mpn/generic/toom54_mul.c: New file, originally contributed by + Marco. + * gmp-impl.h (mpn_toom54_mul_itch): New function. + * configure.in (gmp_mpn_functions): Added toom54_mul. + * tests/mpn/t-toom54.c: New file. + * tests/mpn/Makefile.am (check_PROGRAMS): Added t-toom54. + +2012-02-13 Niels Möller + + * configure.in: Display summary of options. + +2012-02-11 Torbjorn Granlund + + * tests/tests.h (TESTS_REPS): Print any non-standard repetitions. + +2012-02-11 Marco Bodrato + + * doc/gmp.texi (Factorial): Shortly describe current algorithm. + (Multiplication Algorithms): Add Toom[68]'n'half, (too) shortly. + * gmp-impl.h (ASSERT_ALWAYS): Consider failures UNLIKELY. + +2012-02-10 Niels Möller + + * tests/mpz/t-gcd.c (gcdext_valid_p): Enforce slightly stricter + bound for cofactors. + + * mpn/generic/gcdext_lehmer.c (mpn_gcdext_hook): Corrected + handling of unlikely (maybe impossible?) case u1n < un. Related to + the 2012-02-05 bugfix of gcdext_subdiv_step.c in the gmp-5.0 repo. + +2012-02-09 Marco Bodrato + + * gmp-impl.h (mpn_toom3*_itch): Support any recursion depth. + * tests/refmpn.c (refmpn_mul): Restore tight allocations. + + * mpz/oddfac_1.c (mpz_oddfac_1): Get ready for n!! + * gmp-impl.h (mpz_oddfac_1): Update signature. + * mpz/fac_ui.c (mpz_fac_ui): Update call to mpz_oddfac_1. + +2012-02-09 Marc Glisse + + * gmp-impl.h (ABS_CAST): New macro. + * mpf/cmp_si.c: Use ABS_CAST. + * mpf/get_si.c: Use ABS_CAST. + * mpf/iset_si.c: Use ABS_CAST. + * mpf/set_si.c: Use ABS_CAST. + * mpq/set_si.c: Use ABS_CAST. + * mpz/cmp_si.c: Use ABS_CAST. + * mpz/get_si.c: Use ABS_CAST. + * mpz/iset_si.c: Use ABS_CAST. + * mpz/mul_i.h: Use ABS_CAST. + * mpz/set_si.c: Use ABS_CAST. + +2012-02-08 Torbjorn Granlund + + * mpn/powerpc32/divrem_2.asm: Fix off-by-one condition in invert_limb + code. + +2012-02-08 Niels Möller + + * doc/gmp.texi (mpz_gcdext): Clarified corner cases in cofactor + canonicalization. + +2012-02-07 Niels Möller + + * mpn/generic/gcdext.c (mpn_gcdext): Fixed assert, related to the + special case A = (2k+1) G, B = 2 G. Fix copied from gmp-5.0 repo. + +2012-02-06 Niels Möller + + * mpn/generic/hgcd_matrix.c (hgcd_matrix_update_q): Fixed carry + handling bug. Fix copied from gmp-5.0 repo, where the function is + found in hgcd.c. + + * tests/mpz/t-gcd.c (main): Use mpz_rrandomb for test operands, + not mpz_urandomb. Change copied from gmp-5.0 repo. + * tests/mpn/t-hgcd.c (main): Likewise. + +2012-02-04 Marco Bodrato + + * tests/refmpn.c (refmpn_mul): More conservative allocations. + +2012-02-03 Torbjorn Granlund + + * mpn/x86_64/bd1/gmp-mparam.h: New file. + + * longlong.h (udiv_qrnnd from sdiv_qrnnd): Declare udiv_w_sdiv. + + * mpn/generic/udiv_w_sdiv.c: Use c89 function header. + +2012-02-03 Marco Bodrato + + * mpz/fac_ui.c: mpz_oddfac_1 removed, with many related functions. + * mpz/oddfac_1.c: New file, mpz_oddfac_1 implementation. + * gmp-impl.h: mpz_oddfac_1 declaration. + * Makefile.am (MPZ_OBJECTS): add mpz/oddfac_1$U.lo . + * mpz/Makefile.am (libmpz_la_SOURCES): add oddfac_1.c . + * tune/Makefile.am (fac_ui.c): include mpz/oddfac_1.c . + +2012-02-02 Marco Bodrato + + * mpn/generic/toom_interpolate_16pts.c: Correct an unlikely 32-bit bug. + +2012-02-02 Torbjorn Granlund + + * mpn/generic/toom63_mul.c: Allow s+t==n by adjusting an ASSERT. + * mpn/generic/toom_interpolate_8pts.c: Perform final incr iff s+t!=n. + + * tests/mpn/t-toom6h.c (MIN_BN): Make more consistent with ASSERT in + tested function. + +2012-02-01 Torbjorn Granlund + + * tests/mpn/t-mul.c: New file. + * tests/mpn/Makefile.am: Compile it. + +2012-02-01 Marc Glisse + + * gmpxx.h: Remove check for g++ older than 2.91. + +2012-02-01 Niels Möller + + * mpn/generic/mul.c: Added diagram on where toom functions can be + called. + +2012-02-01 Marc Glisse + + * gmpxx.h (__gmp_unary_expr): Make the constructor explicit. + (__gmp_expr(__gmp_expr&&)): New move constructors. + (__gmp_expr::operator=(__gmp_expr&&)): New move assignments. + (swap): Mark as noexcept. + (__GMPXX_USE_CXX11): New macro. + (__GMPXX_NOEXCEPT): New macro. + * tests/cxx/t-cxx11.cc: New file. + * tests/cxx/Makefile.am: Added t-cxx11. + +2012-01-31 Torbjorn Granlund + + * mpn/generic/powm_sec.c (SQR_BASECASE_LIM): New name for + SQR_BASECASE_MAX. + (SQR_BASECASE_LIM, fat variant): Define to read __gmpn_cpuvec. + (SQR_BASECASE_LIM, native variant): Define to SQR_TOOM2_THRESHOLD + straight, without arithmetic. + (mpn_local_sqr): Use BELOW_THRESHOLD as per Marco's suggestion. + +2012-01-30 Torbjorn Granlund + + * tests/mpz/t-powm.c: Ensure all sizes are seen. + +2012-01-30 Marc Glisse + + * gmpxx.h (__gmp_binary_expr): Let things happen in place: d=a+b+c + when d != c. + * tests/cxx/t-binary.cc: Test variable reuse: c=a+b+c. + +2012-01-28 Marc Glisse + + * gmpxx.h: Don't compute -LONG_MIN. + + * doc/gmp.texi (gmp_randclass::get_z_bits): Use mp_bitcnt_t. + * gmpxx.h: Replace unsigned long with mp_bitcnt_t. + +2012-01-27 Torbjorn Granlund + + * Upgrade to libtool 2.4.2. + +2012-01-26 Marco Bodrato + + * tests/mpz/t-fac_ui.c: Increase default test cases. + + * mpz/prodlimbs.c: New file, mpz_prodlimbs implementation. + * gmp-impl.h: mpz_prodlimbs declaration. + * Makefile.am (MPZ_OBJECTS): add mpz/prodlimbs$U.lo . + * mpz/Makefile.am (libmpz_la_SOURCES): add prodlimbs.c . + (fac_ui.h): remove target (moved up one directory). + * mpz/fac_ui.c: mpz_prodlimbs removed, micro-optimisations. + +2012-01-25 Torbjorn Granlund + + * tune/tuneup.c: Remove unused tuneup variables. + +2012-01-20 Marco Bodrato + + * mpz/fac_ui.c: Reduce branches in basecases. + +2012-01-18 Marc Glisse + + * doc/gmp.texi (mpf_class::mpf_class): Use mp_bitcnt_t. + +2012-01-17 Torbjorn Granlund + + * configure.in: Add ultrasparc T4 support. + + * demos/isprime.c (main): Run 25 millerrabin tests. + +2012-01-16 Marco Bodrato + + * mpz/fac_ui.c (SIEVE_SEED): Define value for small limb size. + (mpz_oddswing_1): Reduce the number of divisions. + (mpz_oddfac_1): Reduce memory usage. + * mpn/minithres/gmp-mparam.h: Correct minimum for FAC_DSC_. + * tune/tuneup.c (tune_fac_ui): Likewise. + +2012-01-15 Niels Möller + + * mpz/scan0.c (mpz_scan0): Use ~(mp_bitcnt_t) 0, rather than + ULONG_MAX, when returning "infinity". + * mpz/scan1.c (mpz_scan1): Likewise. + +2012-01-12 Torbjorn Granlund + + * tests/t-popc.c: Test longer bit strings. + +2012-01-12 Marco Bodrato + + * mpz/divexact.c: Tight realloc, delayed if variables are reused. + * mpz/lcm.c: Smaller temp space, avoid goto. + * gmp-impl.h (popc_limb): avoid double & (for 8-bits limb). + +2012-01-10 Marco Bodrato + + * mpn/minithres/gmp-mparam.h: New FAC_ODD_ and FAC_DSC_ thresholds. + * tune/tuneup.c (tune_fac_ui): Correct minimum for FAC_DSC_. + +2012-01-07 Torbjorn Granlund + + * mpz/mul_2exp.c: Rewrite. + * mpz/tdiv_q_2exp.c: Rewrite. + +2012-01-05 Marco Bodrato + + * gen-fac_ui.c: Remove currently unused constants; add new odd + double factorial table. + * mpz/fac_ui.c (RECURSIVE_PROD_THRESHOLD): Increase default. + (mpz_oddfac_1): New function: a merge of _bc_odd and _dsc_odd. + (mpz_prodlimbs): More in-place computations. + + * tune/tuneup.c (tune_fac_ui): min_is_always for FAC_ODD_. + +2012-01-02 Marco Bodrato + + * tune/tuneup.c (tune_fac_ui): Compute FAC_DSC before FAC_ODD. + +2011-12-31 Torbjorn Granlund + + * Makefile.am (fac_ui.h): Put file in top-level dir, not in mpz. + +2011-12-31 Marco Bodrato + + * tune/Makefile.am (fac_ui.c): New target. + (nodist_tuneup_SOURCES,CLEANFILES): Add fac_ui.c. + * tune/tuneup.c (mpz_fac_ui_tune): Declare prototype. + (fac_odd_threshold,fac_dsc_threshold): New global variables. + (speed_mpz_fac_ui_tune,tune_fac_ui): New functions. + (all): Call tune_fac_ui. + * gmp-impl.h (FAC_ODD_THRESHOLD,FAC_DSC_THRESHOLD): + New thresholds: default values, and setup for tuning. + (FAC_DSC_THRESHOLD_LIMIT): Define (when tuning). + * mpz/fac_ui.c (FAC_ODD_THRESHOLD,FAC_DSC_THRESHOLD): + Default values removed. + +2011-12-30 Torbjorn Granlund + + * mpz/hamdist.c: Fix typo in a return statement. + + * mpn/generic/powm_sec.c (SQR_BASECASE_MAX): Set safely from + SQR_TOOM2_THRESHOLD. + +2011-12-17 Torbjorn Granlund + + * tests/mpz/t-perfpow.c: Decrease default # of tests. + +2011-12-16 Torbjorn Granlund + + * tests/refmpn.c (AORS_1): Fix typo in variable type. + +2011-12-10 Torbjorn Granlund + + * mpn/generic/sbpi1_bdiv_q.c: Delay quotient limb stores in order to + allow quotient and dividend to completely overlap. + * mpn/generic/sbpi1_bdiv_qr.c: Likewise. + +2011-12-10 Marco Bodrato + + * mpz/fac_ui.c: fac_bc_ui inlined in fac_ui. + +2011-12-08 Torbjorn Granlund + + * mpn/generic/powm_sec.c: Handle fat binaries better. + + * mpz/fac_ui.c (mpz_bc_fac_1): Fix typo in allocation size. + + * mpn/x86/fat/com.c: New file. + + * mpn/x86_64/pentium4/aors_n.asm: Make it actually work for DOS64. + * mpn/x86_64/pentium4/rsh1aors_n.asm: Conditionalise jump on DOS64 + to avoid overhead for standard ABIs. + + * mpn/x86_64/gcd_1.asm: Support DOS64. + +2011-12-07 Torbjorn Granlund + + * configure.in: Fix typo making HAVE_NATIVE_mpn_X fail for fat + functions. + + * mpn/x86_64/fat/fat.c (__gmpn_cpuvec_init): Add a missing break. + +2011-12-07 Marco Bodrato + + * gen-fac_ui.c: Generate two more tables: odd factorial, swing. + + * mpz/fac_ui.c: Rewrite. + +2011-12-06 Niels Möller + + * mpn/generic/hgcd.c (mpn_hgcd): Use hgcd_reduce for first + recursive call. + +2011-12-06 Torbjorn Granlund + + * tune/mod_1_1-1.c: Redefine the mpn_ functions, not __gmpn_ (for the + benefit of fat builds). + * tune/mod_1_1-2.c: Likewise. + +2011-12-05 Torbjorn Granlund + + * mpn/x86/fat/lshiftc.c: New file. + * mpn/x86/fat/mod_1_1.c: New file. + * mpn/x86/fat/mod_1_2.c: New file. + * mpn/x86/fat/mod_1_4.c: New file. + + * mpn/x86/fat/diveby3.c: Remove no longer fat function. + * mpn/x86_64/fat/diveby3.c: Likewise. + + * mpn/x86_64/fat/gcd_1.c: Remove since always provided as asm. + * mpn/x86_64/fat/mode1o.c: Likewise. + + * configure.in (fat_functions): Update to more relevant function set. + Add special handling for mod_1_N_cps functions. + * gmp-impl.h (struct cpuvec_t) : Corresponding changes. Also add + vrious declarations for new functions. + * mpn/x86/x86-defs.m4 (CPUVEC_FUNCS_LIST): Corresponding changes. + * mpn/x86_64/x86_64-defs.m4 (CPUVEC_FUNCS_LIST): Corresponding changes. + * mpn/x86/fat/fat.c (__gmpn_cpuvec): Corresponding changes. + * mpn/x86_64/fat/fat.c (__gmpn_cpuvec): Corresponding changes. + + * mpn/x86_64: Port most remaining x86_64 files to DOS64. + + * mpn/x86_64/coreisbr/aors_n.asm: Add forgotten DOS64_EXIT. + + * mpn/x86_64/x86_64-defs.m4 (LEA): Handle non-PIC code. + * mpn/x86_64/darwin.m4 (LEA): Likewise. + +2011-12-04 Torbjorn Granlund + + * mpn/x86_64/fat/fat.c (MAKE_FMS): Rewrite to handle modern CPUs. + * mpn/x86/fat/fat.c (MAKE_FMS): Likewise. + + * mpn/x86_64/darwin.m4 (PROTECT): Define to potentially useful value. + +2011-12-02 Torbjorn Granlund + + * mpn/x86_64/invert_limb_table.asm: Use PROTECT. + * mpn/x86_64/invert_limb.asm: Likewise. + + * mpn/x86_64/darwin.m4 (PROTECT, IFELF): New defines. + * mpn/x86_64/dos64.m4 (PROTECT, IFELF): New defines. + * mpn/x86_64/x86_64-defs.m4 (PROTECT, IFELF): New defines. + +2011-12-01 Torbjorn Granlund + + * mpn/x86_64/fat/fat.c: Copy fake cpuid code from x86/fat/fat.c. + + * mpn/x86_64 (STD64, IFSTD): New names for ELF64, IFELF (since these + denote all standard calling conventions). + + * mpn/x86_64: Add DOS64 ABI support to more files. + + * mpn/x86_64/mod_1_1.asm: Finish DOS64 support. + * mpn/x86_64/mod_1_2.asm: Likewise. + * mpn/x86_64/mod_1_4.asm: Likewise. + + * configure.in: Add GMP_NONSTD_ABI also for fat builds. + + * mpn/x86_64/fat/fat_entry.asm: Rewrite to support DOS64. + + * mpn/x86_64/dos64.m4 (IFDOS, IFSTD): New defines. + * mpn/x86_64/x86_64-defs (IFDOS, IFSTD): New defines. + + * mpn/x86_64/dive_1.asm: Add DOS64 ABI support. + * mpn/x86_64/mode1o.asm: Likewise. + + * mpn/x86_64/mod_34lsub1.asm: Enable for DOS64. + + * mpn/x86_64/invert_limb.asm: Wrap .protected decl. + + * gmp-impl.h (DECL_divexact_1): Fix typo in return type. + + * mpn/x86_64/dos64.m4 (LEA): New define. + (PIC): Define. + +2011-11-29 Torbjorn Granlund + + * mpn/x86_64: Add DOS64 ABI support to most files. + +2011-11-28 Torbjorn Granlund + + * mpn/x86_64/mul_basecase.asm: Support ABI DOS64. + * mpn/x86_64/sqr_basecase.asm: Support ABI DOS64. + * mpn/x86_64/aorsmul_1.asm: Support ABI DOS64. + * mpn/x86_64/mul_1.asm: Support ABI DOS64. + + * mpn/x86_64/x86_64-defs.m4 (DOS64_ENTRY, DOS64_EXIT): New, empty defs. + + * mpn/x86_64/dos64.m4: New file. + + * mpn/asm-defs.m4 (ABI_SUPPORT): New dummy macro. + + * configure.in (64-bit mingw/cygwin): Define HOST_DOS64,GMP_NONSTD_ABI. + No longer clear out path_64. + (mpn code selection loop): Handle GMP_NONSTD_ABI. + + * mpn/generic/udiv_w_sdiv.c: Use CNST_LIMB for some constants. + +2011-11-25 Torbjorn Granlund + + * x86/*: Many new gmp-mparam.h file for 64-bit CPUs in 32-bit mode. + + * configure.in: Overhaul x86/x86_64 support, merging three case + statements into one. + +2011-11-24 Torbjorn Granlund + + * doc/gmp.texi (Formatted Output Strings): Clarify rules for mpf_t + precision. + + * mpn/powerpc32/p7/gmp-mparam.h: New file. + + * tune/tuneup.c (tune_mu_div, tune_mu_bdiv): Up min_size to karatsuba's + threshold. + +2011-11-22 Torbjorn Granlund + + * mpn/powerpc64/mode64/p6/aorsmul_1.asm: New file. + + * configure.in: Don't fail fat builds under 64-bit DOS. + + * mpn/powerpc64/mode64/aors_n.asm: Align loop for slightly better + power5 performance. + +2011-11-21 Torbjorn Granlund + + * gmp-h.in (__GNU_MP_RELEASE): Renamed from typo name. + +2011-11-20 Torbjorn Granlund + + * configure.in: Split x86 CPUs into more subtypes for more accurate + passing of gcc flags. + + * mpn/powerpc32/p3-p7/aors_n.asm: New file. + + * configure.in: Pass -m32 for powerpc64 with abi=32, using via _maybe + mechanism. + + * configure.in: Support powerpc32/p3-p7 directory for affected CPUs. + +2011-11-17 Torbjorn Granlund + + * tune/speed.c (routine): Add mpn_tabselect. + * tune/common.c (speed_mpn_tabselect): New function. + * tune/speed.h (SPEED_ROUTINE_MPN_COPY_CALL): New macro, made from + old SPEED_ROUTINE_MPN_COPY. + (SPEED_ROUTINE_MPN_COPY): Just invoke SPEED_ROUTINE_MPN_COPY_CALL. + (SPEED_ROUTINE_MPN_TABSELECT): New macro. + +2011-11-17 Niels Möller + + * tune/tuneup.c (tune_hgcd_appr): Increase stop_since_change. + +2011-11-16 Torbjorn Granlund + + * mpn/powerpc32/tabselect.asm: New file. + + * mpn/powerpc64/mode64/aorscnd_n.asm: New file. + +2011-11-15 Niels Möller + + * tune/speed.h (speed_mpn_hgcd_appr_lehmer): New prototype. + (mpn_hgcd_lehmer_itch): Likewise. + (mpn_hgcd_appr_lehmer): Likewise. + (mpn_hgcd_appr_lehmer_itch): Likewise. + (MPN_HGCD_LEHMER_ITCH): Deleted macro. + + * tune/speed.c (routine): Added mpn_hgcd_appr_lehmer. + + * tune/common.c (speed_mpn_hgcd_lehmer): Use mpn_hgcd_lehmer_itch + rather than similarly named macro. + (speed_mpn_hgcd_appr_lehmer): New function. + + * tune/Makefile.am (libspeed_la_SOURCES): Added + hgcd_appr_lehmer.c. + + * tune/hgcd_appr_lehmer.c: New file. + + * tune/tuneup.c (tune_hgcd_appr): Increased min_size to 50; some + machines got small thresholds which appear to be bogus. + +2011-11-15 Torbjorn Granlund + + * mpn/generic/powm_sec.c (mpn_local_sqr): Remove forgotten TMP_* calls. + (redcify): Likewise. + (mpn_powm_sec): Likewise. + + * mpn/generic/powm_sec.c (mpn_powm_sec): Rework scratch usage + (mpn_powm_sec_itch): Rewrite. + + * mpn/generic/powm_sec.c (mpn_powm_sec): Use mpn_tabselect also in + initialisation. + + * configure.in: Amend 2011-11-03 gcc_cflags change. + + * mpn/powerpc64/tabselect.asm: New file. + * mpn/x86_64/tabselect.asm: New file. + * mpn/x86/tabselect.asm: New file. + * mpn/ia64/tabselect.asm: New file. + + * mpn/asm-defs.m4 (define_mpn): Add tabselect. + + * configure.in (gmp_mpn_functions): Add tabselect. + (HAVE_NATIVE): Add entries for addncd_n, subcnd_n, tabselect. + + * mpn/generic/powm_sec.c: Remove mpn_tabselect implementation. + * mpn/generic/tabselect.c: New file with removed code. + +2011-11-13 Torbjorn Granlund + + * tune/Makefile.am (TUNE_MPN_SRCS_BASIC): Add powm_sec.c. + + * mpn/generic/powm_sec.c (win_size): Use POWM_SEC_TABLE + (POWM_SEC_TABLE): Define default. + + * tune/tuneup.c (tune_powm_sec): New function computing POWM_SEC_TABLE. + (all): Call new function. + + * mpn/generic/powm_sec.c (win_size): Define only when + TUNE_PROGRAM_BUILD is not set. + +2011-11-13 Niels Möller + + * tune/tuneup.c (tune_hgcd_appr): Use default min_size. + (tune_hgcd_reduce): Increase max_size and step_factor, to 7000 + and 0.04, respectively. + +2011-11-11 Torbjorn Granlund + + * mpn/powerpc64/mode64/sqr_diag_addlsh1.asm: Remove. + +2011-11-11 Niels Möller + + * tune/hgcd_reduce_2.c: New file. + * tune/hgcd_reduce_1.c: New file. + + * tune/tuneup.c (hgcd_appr_threshold): New threshold variable. + (hgcd_reduce_threshold): Likewise. + (tune_hgcd_appr): New function. + (tune_hgcd_reduce): New function. + (all): Call tune_hgcd_appr and tune_hgcd_reduce. + + * tune/speed.h (speed_mpn_hgcd_reduce): Declaration. + (speed_mpn_hgcd_reduce_[12]): Likewise. + (mpn_hgcd_reduce_[12]): Likewise. + (SPEED_ROUTINE_MPN_HGCD_REDUCE_CALL): New macro. + + * tune/speed.c (routine): Added mpn_hgcd_reduce, + mpn_hgcd_reduce_1, and mpn_hgcd_reduce_2. + + * tune/common.c (speed_mpn_hgcd_reduce): New function. + (speed_mpn_hgcd_reduce_[12]): Likewise. + + * tune/Makefile.am (libspeed_la_SOURCES): Added hgcd_reduce_1.c + hgcd_reduce_2.c. + (TUNE_MPN_SRCS_BASIC): Added hgcd_appr.c and hgcd_reduce.c. + + * mpn/generic/hgcd_appr.c (submul, hgcd_matrix_apply): Deleted + functions, earlier copied to hgcd_reduce.c. + (mpn_hgcd_appr): Use hgcd_reduce. + +2011-11-09 Torbjorn Granlund + + * mpn/powerpc64/mode64/sqr_basecase.asm: New file. + + * mpn/x86_64/aorscnd_n.asm: New file. + + * tune/speed.c (routine): Add measuring of mpn_addcnd_n, mpn_subcnd_n. + * tune/common.c (speed_mpn_addcnd_n,speed_mpn_subcnd_n): New functions. + * tune/speed.h: Declare them. + + * tests/devel/try.c: Add tests for mpn_addcnd_n and mpn_subcnd_n. + * tests/refmpn.c (refmpn_addcnd_n, refmpn_subcnd_n): New functions. + * tests/tests.h: Declare them. + + * configure.in (gmp_mpn_functions): Add addcnd_n and subcnd_n. + +2011-11-07 Torbjorn Granlund + + * mpn/generic/redc_1.c: Just reduce U operand using Hensel norm, but + not fully canonically; leave add_n and conditional sub_n to caller. + Therefore omit R argument. + + * mpn/generic/redc_1_sec.c: Remove. + + * gmp-impl.h (mpn_redc_1): Update declaration. + (mpn_redc_1_sec): Remove declaration. + + * configure.in (gmp_mpn_functions): Remove redc_1. + + * mpn/x86_64/redc_1.asm: Adopt to new defined functionality/interface. + * tune/speed.h (SPEED_ROUTINE_REDC_1): Likewise. + + * tests/refmpn.c (refmpn_redc_1): Likewise; also call refmpn_addmul_1 + instead of mpn_addmul_1. + + * mpn/generic/powm.c (MPN_REDC_1): New macro, use for mpn_redc_1. + * mpn/generic/powm_sec.c (MPN_REDC_1_SEC): New macro, use for + mpn_redc_1_sec. + +2011-11-03 Torbjorn Granlund + + * dumbmp.c (mpz_sub): Abort for non-handled case. + + * mpn/powerpc64/mode64/lshiftc.asm: Move file from here... + * mpn/powerpc64/lshiftc.asm: ...to here, with trivial modifications. + + * configure.in: Pass -m32 in more cases, using _maybe mechanism. + Inherit default gcc_cflags in more places. + + * mpn/powerpc64/mode64/p7/gmp-mparam.h: New file. + +2011-11-02 Torbjorn Granlund + + * mpn/s390_64/invert_limb.asm: Slight optimisation. + + * configure.in (s390): Set gcc_32_cflags_maybe. + + * mpn/s390_32/gmp-mparam.h: Put in proper data. + * mpn/s390_32/esame/gmp-mparam.h: New file. + + * mpn/x86_64/bobcat/gmp-mparam.h: New file. + + * mpn/s390_32/lshift.asm: New file. + * mpn/s390_32/rshift.asm: New file. + * mpn/s390_32/lshiftc.asm: New file. + +2011-10-31 Torbjorn Granlund + + * mpn/powerpc64/sqr_diagonal.asm: Move from here... + * mpn/powerpc64/mode32/sqr_diagonal.asm: ...to here. + + * mpn/powerpc64/mode64/sqr_diag_addlsh1.asm: New file. + + * mpn/s390_64/sqr_basecase.asm: Rewrite sqr_diag_addlsh1 code. + * mpn/s390_32/esame/sqr_basecase.asm: Likewise. + +2011-10-29 Torbjorn Granlund + + * mpn/s390_64/lshift.asm: Complete rewrite. + * mpn/s390_64/rshift.asm: Likewise. + + * mpn/s390_64/lshiftc.asm: New file. + +2011-10-28 Torbjorn Granlund + + * mpn/s390_32/esame/aors_n.asm: New file, with rewritten add/sub code. + +2011-10-27 Torbjorn Granlund + + From Per Olofsson: + * gmp-impl.h (BSWAP_LIMB): Rename variable to avoid BSWAP_LIMB_FETCH + clash. + + * mpn/s390_32/esame/mul_basecase.asm: New file. + + * mpn/s390_32/esame/sqr_basecase.asm: New file. + + * mpn/s390_32/logops_n.asm: New file. + + * mpn/s390_64/logops_n.asm: Fix rp=up code. Remove a leftover insn. + +2011-10-26 Niels Möller + + * gmp-impl.h (mpn_hgcd_reduce, mpn_hgcd_reduce_itch): Added + prototypes. + (HGCD_APPR_THRESHOLD): Set up threshold for tuning. + (HGCD_REDUCE_THRESHOLD): Likewise. + + * configure.in (gmp_mpn_functions): Added hgcd_reduce. + + * mpn/generic/hgcd_reduce.c: New file. + +2011-10-24 Torbjorn Granlund + + * mpn/x86_64/sqr_basecase.asm: Put intermediate result into R, don't + allocate any stack space. + +2011-10-23 Torbjorn Granlund + + * mpn/s390_64/logops_n.asm: Use nc, oc, xc when possible. + + * tune/common.c (speed_mpn_and_n, speed_mpn_andn_n, etc): + Pass correct input args. + + * mpn/s390_64/mod_34lsub1.asm: Use llgfr for zero extensions. + + * mpn/s390_64/mul_basecase.asm: New file. + + * mpn/s390_64/sqr_basecase.asm: New file. + * mpn/s390_64/sqr_diag_addlsh1.asm: Removed, lives on in sqr_basecase. + + * mpn/s390_64/bdiv_dbm1c.asm: Shave off 1 c/l. + + * mpn/s390_64/aorrlsh1_n.asm: New file, developed from aorslsh1_n.asm. + * mpn/s390_64/sublsh1_n.asm: New file. + * mpn/s390_64/aorslsh1_n.asm: Remove file. + +2011-10-22 Torbjorn Granlund + + * mpn/s390_64/logops_n.asm: New file. + + * mpn/s390_64/aors_n.asm: New file, with rewritten add/sub code. + +2011-10-20 Torbjorn Granlund + + * tune/speed.h (SPEED_ROUTINE_MPN_SQR_DIAL_ADDLSH1_CALL): New macro. + * tune/common.c (speed_mpn_sqr_diag_addlsh1): New function. + * tune/speed.c (routine): Measure mpn_sqr_diag_addlsh1. + + * mpn/s390_64/sqr_diag_addlsh1.asm: Rewrite like s390_32/esame code. + + * mpn/s390_32/esame/sqr_diag_addlsh1.asm: Save just needed registers. + +2011-10-19 Torbjorn Granlund + + * mpn/s390_32/esame/add_n.asm: Rewrite, similar to s390_64 code. + * mpn/s390_32/esame/add_n.asm: Likewise. + +2011-10-17 Torbjorn Granlund + + * mpn/s390_32/esame/aorslsh1_n.asm: New file. + +2011-10-16 Torbjorn Granlund + + * mpn/s390_32/esame/sqr_diag_addlsh1.asm: New file. + + * mpn/s390_32/copyi.asm: New file. + * mpn/s390_32/copyd.asm: New file. + + * mpn/s390_64/copyd.asm: Optimise. + + * mpn/s390_64/copyi.asm: Rewrite along the lines of glibc memcpy. + + * mpn/s390_64/aorslsh1_n.asm: New file. + + * mpn/s390_64/mod_34lsub1.asm: New file. + + * mpn/s390_64/sqr_diag_addlsh1.asm: New file. + +2011-10-15 Torbjorn Granlund + + * configure.in (s390): Rewrite support to handle known CPUs. + * config.guess: Recognise s390 CPUs. + * config.sub: Match s390 CPUs. + * acinclude.m4 (S390_PATTERN, S390X_PATTERN): New defines. + +2011-10-14 Torbjorn Granlund + + From Per Olofsson: + * mpn/generic/popham.c: Add __GMP_NOTHROW to make it match gmp.h. + * mpn/generic/gcd_1.c: Separate declarations and initialisers for the + benefit of C++. + + * configure.in: AC_DEFINE HAVE_HOST_CPU_s390_zarch. + * longlong.h (s390): Use it. + (s390 umul_ppmm): Fix typo in pure C variant. + +2011-10-13 Torbjorn Granlund + + * longlong.h (s390): Put back an accidentally deleted #else. + + * configure.in (s390): Unset extra_functions for s390x. + +2011-10-12 Torbjorn Granlund + + * mpn/s390_64/lshift.asm: Reduce register usage. + * mpn/s390_64/rshift.asm: Likewise. + + * longlong.h (s390 umul_ppmm): With new-enough gcc, avoid asm. + + From Andreas Krebbel: + * longlong.h (s390 umul_ppmm): Support 32-bit limbs with gcc using + 64-bit registers. + (s390 udiv_qrnnd): Likewise. + +2011-10-11 Torbjorn Granlund + + * configure.in (s390x): Pass -mzarch to gcc in 32-bit mode. + + * longlong.h (s390x): Add __CLOBBER_CC for relevant asm patterns. + * mpn/generic/mod_1_1.c (s390x add_mssaaaa): Likewise. + + * mpn/s390_64/copyd.asm: New file. + +2011-10-10 Niels Möller + + * mpn/generic/hgcd_appr.c: Deleted debugging code. + + * tests/mpn/t-hgcd_appr.c (main): Added -v flag. + (hgcd_appr_valid_p): Increased margin of non-minimality for + divide-and-conquer algorithm. Display bit counts only if + -v is used. + + * mpn/generic/hgcd_appr.c (submul): New (static) function. + (hgcd_matrix_apply): New function. + (mpn_hgcd_appr_itch): Account for divide-and-conquer algorithm. + (mpn_hgcd_appr): Implemented divide-and-conquer. + +2011-10-10 Torbjorn Granlund + + * mpn/generic/mod_1_1.c (add_mssaaaa): Add s390x variant. Put arm code + inside __GNUC__. + + * tune/time.c (STCK): Use proper memory constraint. + + From Marco Trudel: + * tests/mpz/t-scan.c (check_ref): Fix loop end bound. + +2011-10-10 Niels Möller + + * gmp-impl.h: (HGCD_APPR_THRESHOLD): New threshold. + + * mpn/generic/hgcd_appr.c (mpn_hgcd_appr): Interface change. + Destroy inputs, let caller make working copies if needed. + (mpn_hgcd_appr_itch): Reduced scratch need. + * gmp-impl.h: Updated mpn_hgcd_appr prototype. + * tests/mpn/t-hgcd_appr.c (one_test): Make working copies for + hgcd_appr. + * tune/common.c (speed_mpn_hgcd_appr): Use SPEED_ROUTINE_MPN_HGCD_CALL. + * tune/speed.h (SPEED_ROUTINE_MPN_HGCD_APPR_CALL): Deleted. + +2011-10-09 Torbjorn Granlund + + * mpn/s390_64/copyi.asm: New file. + * mpn/s390_64/lshift.asm: New file. + * mpn/s390_64/rshift.asm: New file. + + * mpn/s390_64/add_n.asm: Rewrite using lmg/stmg. + * mpn/s390_64/sub_n.asm: Likewise. + + * mpn/s390_64/invert_limb.asm: Save a callee-saves register less. + + * tune/time.c (getrusage_backwards_p): Properly cast printed values. + + * longlong.h (s390x): Put back UDItype casts to make gcc reloading use + right more for constants. + (s390x count_leading_zeros): Disable until we support z10 specifically. + (s390x add_ssaaaa): Remove algsi/slgsi until we support z10. + +2011-10-09 Niels Möller + + * mpn/generic/hgcd_matrix.c (mpn_hgcd_matrix_adjust): Declare + matrix argument const. + +2011-10-08 Niels Möller + + * tests/mpn/t-hgcd_appr.c (hgcd_appr_valid_p): Adjusted the + allowed margin of non-minimality for hgcd_appr. + + * mpn/generic/hgcd_appr.c (mpn_hgcd_appr): Fixed handling of + extra_bits, starting at zero, to ensure that we don't produce too + small remainders. Added a final reduction loop when we we + otherwise terminate with extra_bits > 0, to make the returned + remainders closer to minimal. + +2011-10-07 Torbjorn Granlund + + * longlong.h (s390): Add 32-bit zarch umul_ppmm and udiv_qrnnd. + (s390): Overhaul 32-bit and 64-bit code. + +2011-10-07 Niels Möller + + * tune/speed.h (speed_mpn_hgcd_appr): New prototype. + (SPEED_ROUTINE_MPN_HGCD_APPR_CALL): New macro. + * tune/common.c (speed_mpn_hgcd_appr): New function. + * tune/speed.c (routine): Added mpn_hgcd_appr. + + * tests/mpn/t-hgcd_appr.c: New file. + * tests/mpn/Makefile.am (check_PROGRAMS): Added t-hgcd_appr. + + * configure.in (gmp_mpn_functions): Added hgcd_step and hgcd_appr. + + * gmp-impl.h: Added prototypes for mpn_hgcd_step, + mpn_hgcd_appr_itch and mpn_hgcd_appr. + + * mpn/generic/hgcd_appr.c: New file. + + * mpn/generic/hgcd_step.c: New file, extracted from hgcd.c. + (mpn_hgcd_step): Renamed, from... + * mpn/generic/hgcd.c (hgcd_step): ...old name. Renamed and moved + to hgcd_step.c. + (hgcd_hook): Also moved to hgcd_step.c. + (mpn_hgcd): Updated for hgcd_step renaming. + +2011-10-06 Torbjorn Granlund + + * mpn/s390_64/invert_limb.asm: New file. + +2011-10-04 Torbjorn Granlund + + * mpn/s390_64/submul_1.asm: New file. + * mpn/s390_32/esame/submul_1.asm: New file. + + * mpn/generic/mulmid.c (mpn_mulmid): Move a TMP_DECL to block start. + + * mpn/Makefile.am (TARG_DIST): Add s390_32 and s390_64, remove s390 and + z8000x. + + * doc/gmp.texi (Custom Allocation): Rephrase a paragraph. + + * demos/factorize.c: Run 25 Miller-Rabin tests. + + * mpz/nextprime.c: Run 25 mpz_millerrabin tests (was 10). + +2011-10-03 Torbjorn Granlund + + * configure.in: Support s390x. + + * longlong.h: Add support for 64-bit s390x. + + * mpn/s390_64: New directory. + * mpn/s390_64/add_n.asm: New file. + * mpn/s390_64/sub_n.asm: New file. + * mpn/s390_64/mul_1.asm: New file. + * mpn/s390_64/addmul_1.asm: New file. + * mpn/s390_64/bdiv_dbm1c.asm: New file. + * mpn/s390_64/gmp-mparam.h: New file, taken from x86_64. + + * mpn/s390_32: Directory renamed from mpn/s390. + * mpn/s390_32/gmp-mparam.h: New file, taken from x86_64. + * mpn/s390_32/esame/add_n.asm: New file. + * mpn/s390_32/esame/sub_n.asm: New file. + * mpn/s390_32/esame/mul_1.asm: New file. + * mpn/s390_32/esame/addmul_1.asm: New file. + * mpn/s390_32/esame/bdiv_dbm1c.asm: New file. + +2011-10-03 Niels Möller + + * tests/mpn/Makefile.am (check_PROGRAMS): Added t-mulmid. + * tests/mpn/t-mulmid.c: New file. + + mulmid-related assembly for x86_64, from David Harvey: + * mpn/asm-defs.m4 (define_mpn): Added [add,sub]_err[1,2,3]_n and + mulmid_basecase. Also use m4_not_for_expansion on the + corresponding OPERATION_* symbols. + * mpn/x86_64/aors_err1_n.asm: New file. + * mpn/x86_64/aors_err2_n.asm: Likewise. + * mpn/x86_64/aors_err3_n.asm: Likewise. + * mpn/x86_64/mulmid_basecase.asm: Likewise. + * mpn/x86_64/core2/aors_err1_n.asm: Likewise. + * mpn/x86_64/gmp-mparam.h (MULMID_TOOM42_THRESHOLD): New value. + * mpn/x86_64/core2/gmp-mparam.h (MULMID_TOOM42_THRESHOLD): Likewise. + + Tuning of mulmid, from David Harvey: + * tune/Makefile.am (TUNE_MPN_SRCS_BASIC): Added mulmid.c + mulmid_n.c toom42_mulmid.c. + * tune/speed.h: Prototypes for mulmid-related functions. + (struct speed_params): Increased max number of sources to 5. + (SPEED_ROUTINE_MPN_BINARY_ERR_N_CALL): New macro. + (SPEED_ROUTINE_MPN_BINARY_ERR1_N): Likewise. + (SPEED_ROUTINE_MPN_BINARY_ERR2_N): Likewise. + (SPEED_ROUTINE_MPN_BINARY_ERR3_N): Likewise. + (SPEED_ROUTINE_MPN_MULMID): Likewise. + (SPEED_ROUTINE_MPN_MULMID_N): Likewise. + (SPEED_ROUTINE_MPN_TOOM42_MULMID): Likewise. + * tune/common.c (mpn_[add,sub]_err[1,2,3]_n): New functions. + (speed_mpn_mulmid_basecase): New function. + (speed_mpn_mulmid): New function. + (speed_mpn_mulmid_n): New function. + (speed_mpn_toom42_mulmid): New function. + * tune/speed.c (routine): Added mpn_[add,sub]_err[1,2,3]_n, + mpn_mulmid_basecase, mpn_toom42_mulmid, mpn_mulmid_n, and + mpn_mulmid. + * tune/tuneup.c (mulmid_toom42_threshold): New threshold variable. + (tune_mulmid): New function. + (all): Call tune_mulmid. + + Testing of mulmid, from David Harvey: + * tests/refmpn.c (AORS_ERR1_N): New macro. + (refmpn_add_err1_n, refmpn_sub_err1_n): New functions. + (AORS_ERR2_N): New macro. + (refmpn_add_err2_n, refmpn_sub_err2_n): New functions. + (AORS_ERR3_N): New macro. + (refmpn_add_err3_n, refmpn_sub_err3_n): New functions. + (refmpn_mulmid_basecase): New function. + (refmpn_toom42_mulmid): New function, wrapper for + refmpn_mulmid_basecase. + (refmpn_mulmid_n): Likewise. + (refmpn_mulmid): Likewise. + * tests/tests.h: Prototypes for new functions. + * tests/devel/try.c (NUM_SOURCES): Increased to 5. + (struct try_t): Use NUM_SOURCES and NUM_DESTS constants. + (SIZE_4, SIZE_6, SIZE_DIFF_PLUS_3, SIZE_ODD): New constants. + (OVERLAP_NOT_DST2): New flag. + (param_init): New mulmid-related operation types. + (mpn_toom42_mulmid_fun): New function. + (choice_array): Added mulmid-related entries. + (overlap_array): Extended for larger NUM_SOURCES. + (OVERLAP_COUNT): Handle OVERLAP_NOT_DST2. + (call): Support mulmid-related functions. + (pointer_setup): Handle SIZE_4, SIZE_6, and SIZE_DIFF_PLUS_3. + (SIZE_ITERATION): Handle SIZE_ODD. + (SIZE2_FIRST): Handle SIZE_CEIL_HALF. + (SIZE2_LAST): Likewise. + + Implementation of mulmid, from David Harvey: + * mpn/generic/add_err1_n.c (mpn_add_err1_n): New file and function. + * mpn/generic/add_err2_n.c (mpn_add_err2_n): Likewise. + * mpn/generic/add_err3_n.c (mpn_add_err3_n): Likewise. + * mpn/generic/sub_err1_n.c (mpn_sub_err1_n): Likewise. + * mpn/generic/sub_err2_n.c (mpn_sub_err2_n): Likewise. + * mpn/generic/sub_err3_n.c (mpn_sub_err3_n): Likewise. + * mpn/generic/mulmid_basecase.c (mpn_mulmid_basecase): Likewise. + * mpn/generic/mulmid_n.c (mpn_mulmid_n): Likewise. + * mpn/generic/toom42_mulmid.c (mpn_toom42_mulmid): Likewise. + * configure.in (gmp_mpn_functions): Added mulmid-related + functions. + (GMP_MULFUNC_CHOICES): Handle aors_err1_n, aors_err2_n, and + aors_err3_n. + * gmp-impl.h: Added prototypes for mulmid functions. + (MPN_TOOM42_MULMID_MINSIZE): New constant. + (MULMID_TOOM42_THRESHOLD): New threshold. + (mpn_toom42_mulmid_itch): New macro. + +2011-10-03 Niels Möller + + * tune/tune-gcd-p.c (main): Fixed broken loop conditions. + +2011-09-26 Torbjorn Granlund + + * mpn/sh/sh2/submul_1.asm: Make this old submul_1 implementation + actually compute intended function. + + * longlong.h (SH): Recognise predefs for all SH processors as defined + by current gcc versions. + +2011-09-25 Torbjorn Granlund + + * mpn/sh: Migrate files to '.asm'. + * configure.in: Recognise sh3 and sh4. + +2011-09-21 Marc Glisse + + * gmpxx.h (mpz_class::swap): New function. + (mpq_class::swap): Likewise. + (mpf_class::swap): Likewise. + (swap): New function. + * tests/cxx/t-assign.cc: Test the above. + * doc/gmp.texi (swap): Document the above. + +2011-08-21 Marc Glisse + + * tests/cxx/t-ops2.cc: check mul-div by 2. + + * gmpxx.h (__GMPXX_CONSTANT): New macro (__builtin_constant_p). + (__gmp_binary_lshift): Move before multiplication. Optimize x << 0. + (__gmp_binary_rshift): Move before division. Optimize x >> 0. + (__gmp_binary_plus): Optimize x + 0. Rewrite rational + integer. + (__gmp_binary_minus): Optimize x - 0 and 0 - x. + Rewrite rational - integer. + (__gmp_binary_multiplies): Optimize x * 2^n. + (__gmp_binary_divides): Optimize x / 2^n. + (__gmp_binary_*): Deduplicate code for symmetric operations. + +2011-08-18 Torbjorn Granlund + + * printf/doprntf.c (__gmp_doprnt_mpf): For DOPRNT_CONV_FIXED, ask for + one more digit. + +2011-08-17 Torbjorn Granlund + + * mpf/sub.c: Fix typo in copy condition. Delay an allocation. + +2011-08-12 Torbjorn Granlund + + * gmp-impl.h (LIMBS_PER_DIGIT_IN_BASE): Fix typo. + +2011-08-10 Torbjorn Granlund + + * gmp-impl.h (DIGITS_IN_BASEGT2_FROM_BITS): New. + (DIGITS_IN_BASE_FROM_BITS): Compute more accurate result. + (MPN_SIZEINBASE): Use DIGITS_IN_BASEGT2_FROM_BITS. + + * tests/rand/t-lc2exp.c (check_bigc): Call abort after reporting error. + +2011-08-09 Torbjorn Granlund + + * mpz/out_str.c (mpz_out_str): Reinsert accidentally deleted str_size + adjustment. + + * gmp-impl.h (DIGITS_IN_BASE_FROM_BITS): Simplify, also avoiding + overflow for base 2. + +2011-08-07 Torbjorn Granlund + + * gmp-impl.h (struct bases): Add log2b and logb2 field, remove + chars_per_limb_exactly field. + (DIGITS_IN_BASE_FROM_BITS): New. + (DIGITS_IN_BASE_PER_LIMB): New. + (LIMBS_PER_DIGIT_IN_BASE): New. + * gen-bases.c: Generate log2b and logb2 fields; do not generate + chars_per_limb_exactly field. + * mpf/get_str.c mpf/out_str.c mpf/set_str.c mpn/generic/get_str.c + mpn/generic/sizeinbase.c mpq/get_str.c mpz/inp_str.c mpz/out_str.c + mpz/set_str.c printf/doprntf.c tune/speed.h tune/tuneup.c: + Use new macros. + +2011-08-04 Torbjorn Granlund + + * dumbmp.c (mpz_root): Reinsert accidentally removed line. + +2011-08-03 Torbjorn Granlund + + * dumbmp.c (mpz_tdiv_qr): Correctly handle dividend value being equal + to divisor value. + (mpz_root): Create reasonable starting approximation. + (mpz_sqrt): New function. + (mpz_mul_2exp): Add faster block shifting code, disabled for now. + +2011-07-15 Torbjorn Granlund + + * mpn/arm/invert_limb.asm: Swap around some registers to silence 'as' + warnings. + +2011-07-14 Torbjorn Granlund + + * mpn/generic/dcpi1_bdiv_q.c (mpn_dcpi1_bdiv_q): Get mpn_sub_1 size + argument right. + +2011-07-04 Torbjorn Granlund + + * tests/misc/t-locale.c: Disable test for mingw. + + * configure.in (x86_64 *-*-mingw*): Handle also cygwin here; clear out + extra_functions_64. + +2011-07-02 Torbjorn Granlund + + * config.guess: Don't print newline in x86 cpuid function. + Rewrite x86-64 cpu recognition asm code to work under Windoze. + +2011-06-16 Torbjorn Granlund + + * acinclude.m4 (GMP_ASM_RODATA): Fix typo in 2011-04-20 change. + + * configure.in: Surround tr ranges with [] for portability. + +2011-05-25 Niels Möller + + * tune/tune-gcd-p.c (search): New function to search for minimum. + (main): Replaced slow linear search. + +2011-05-24 Niels Möller + + * tune/Makefile.am (EXTRA_PROGRAMS): Added tune-gcd-p. Also added + related automake variables. + + * mpn/Makefile.am (tune-gcd-p): Deleted target. + + * tune/tune-gcd-p.c: New file, extracted from mpn/generic/gcd.c + and updated. + * mpn/generic/gcd.c: Deleted the corresponding code, including + main function. + +2011-05-23 Niels Möller + + * mpz/jacobi.c (mpz_jacobi): Simplified by swapping operands when + needed, to get asize >= bsize. Use the reciprocity law generalized + to work when one operand is even. + +2011-05-22 Niels Möller + + * mpz/jacobi.c (mpz_jacobi): Another bugfix for the asize == 1 + case. Sometimes, powers of two in b were taken into account twice. + +2011-05-21 Niels Möller + + * mpz/jacobi.c (mpz_jacobi): The handling of asize == 1 was + broken. Rewrote it. + + * tests/mpz/t-jac.c (mpz_nextprime_step): Sanity check that prime + candidate and step has no common factor. + (check_data): Added some test cases related to the asize == 1 case + in mpz_jacobi. + +2011-05-20 Niels Möller + + * gmp-impl.h: Jacobi-related prototypes. + + * configure.in (gmp_mpn_functions): Added jacobi_2, jacobi, + hgcd2_jacobi, hgcd_jacobi, and removed jacobi_lehmer. + + * mpz/jacobi.c (STRIP_TWOS): Deleted macro. + (mpz_jacobi): Partially rewritten, to no longer makes the A + operand odd. Use new mpn_jacobi_n. + + * mpn/generic/jacobi_lehmer.c: Deleted file. + + * mpn/generic/jacobi.c (mpn_jacobi_n): New subquadratic jacobi + implementation. Supersedes jacobi_lehmer.c. + + * mpn/generic/hgcd_jacobi.c (mpn_hgcd_jacobi): New file and + function. A copy of mpn_hgcd, using mpn_hgcd2_jacobi, and with calls to + mpn_jacobi_update when appropriate. + + * mpn/generic/jacobi_2.c (mpn_jacobi_2): New file. Extracted from + jacobi_lehmer.c. + * mpn/generic/hgcd2_jacobi.c (mpn_hgcd2_jacobi): Likewise. + + * mpn/generic/hgcd.c (hgcd_hook): Avoid using NULL. + +2011-05-19 Niels Möller + + * tune/hgcd_lehmer.c (__gmpn_hgcd_itch): Don't rename symbols for + the functions moved to hgcd_matrix.c. + + * configure.in (gmp_mpn_functions): Added hgcd_matrix. + + * mpn/generic/hgcd.c (hgcd_matrix_update_1): Deleted. Several other + helper functions moved to hgcd_matrix.c, see below. + (hgcd_hook): New function. + (hgcd_step): Simplified, using mpn_gcd_subdiv_step and hgcd_hook. + + * mpn/generic/hgcd_matrix.c: New file. + (mpn_hgcd_matrix_init): Moved here, from hgcd.c. + (mpn_hgcd_matrix_update_q): Likewise. + (mpn_hgcd_matrix_mul_1): Likewise. + (mpn_hgcd_matrix_mul): Likewise. + (mpn_hgcd_matrix_adjust): Likewise. + + * mpn/generic/gcd_subdiv_step.c (mpn_gcd_subdiv_step): New + argument s, for use by hgcd. + * gmp-impl.h (mpn_gcd_subdiv_step): Update declaration. + + * mpn/generic/gcd.c (mpn_gcd): Pass s = 0 to mpn_gcd_subdiv_step. + * mpn/generic/gcdext.c (mpn_gcdext): Likewise. Also added an ASSERT. + * mpn/generic/gcdext_lehmer.c (mpn_gcdext_lehmer_n): Likewise. + (mpn_gcdext_hook): Added some ASSERTs. + * mpn/generic/jacobi_lehmer.c (mpn_jacobi_lehmer): Likewise. + +2011-05-17 Niels Möller + + * doc/gmp.texi (mpn_gcd, mpn_gcdext): Document input requirements: + Must have un >= vn > 0, and V normalized. + * mpn/generic/gcdext.c (mpn_gcdext): Added ASSERT for input + normalization. + * mpn/generic/gcd.c (mpn_gcd): Added ASSERTs for input + requirements. + +2011-05-15 Marc Glisse + + * gmpxx.h (operator<<): Dedup. + * tests/cxx/t-iostream.cc: Test on compound types. + + * gmpxx.h (__gmp_binary_expr): Let things happen in place: c=(a+b)/2. + +2011-05-10 Marc Glisse + + * gmpxx.h (__gmp_unary_expr): Let things happen in place: c=-(a+b). + (operator>>): Clean the commenting out. + * tests/cxx/t-iostream.cc: New file. + * tests/cxx/Makefile.am: Added t-iostream. + +2011-05-10 Niels Möller + + * doc/gmp.texi (mpz_gcd): Document that gcd(0,0) = 0. + (mpz_gcdext): Document range for cofactors. + +2011-05-09 Niels Möller + + * mpz/gcdext.c (mpz_gcdext): Increased sp allocation to bsize+1 limbs. + * doc/gmp.texi (mpn_gcdext): Fixed documentation of allocation + requirements; one extra limb is still needed for S. + +2011-05-09 Torbjorn Granlund + + * mpn/x86/fat/gmp-mparam.h (BMOD_1_TO_MOD_1_THRESHOLD): Define. + * mpn/x86_64/fat/gmp-mparam.h (BMOD_1_TO_MOD_1_THRESHOLD): Define. + +2011-05-08 Marc Glisse + + * gmpxx.h: Replace unsigned long with mp_bitcnt_t in many places. + * doc/gmp.texi: Likewise. + +2011-05-06 Marc Glisse + + * gmpxx.h (mpz_class): Make constructor from mp[qf]_class explicit. + (mpq_class): Make constructor from mpf_class explicit. + * doc/gmp.texi: Document the above. + * NEWS: Likewise, and mention the EOF istream fix. + * tests/cxx/t-mix.cc: New file. + * tests/cxx/Makefile.am: Added t-mix. + + * tests/cxx/t-assign.cc: Minor tweak. + * tests/cxx/t-misc.cc: Likewise. + + * gmpxx.h (__gmp_resolve_temp): Remove. + (__gmp_set_expr): Remove some overloads. + (mpq_class): mpz_init_set the numerator and denominator instead of + mpq_init + mpq_set. + (mpz_class): Dedup the string constructors. + (mpq_class): Likewise. + + * tests/cxx/t-ops3.cc: New file. + * tests/cxx/Makefile.am: Added t-ops3. + +2011-05-05 Torbjorn Granlund + + * mpz/gcdext.c: Correct sgn computation. + Use MPZ_REALLOC. + +2011-05-05 Marc Glisse + + * mpn/x86_64/fat/fat.c: Update for Sandy Bridge. + * config.guess: warning to keep it in sync with fat.c. + +2011-05-05 Torbjorn Granlund + + * mpn/x86_64/fat/fat_entry.asm (PIC_OR_DARWIN): New symbol. Use it to + work around Darwin problems. + +2011-05-04 Niels Möller + + * mpz/gcdext.c (mpz_gcdext): Reduced temporary allocations. Use + mpz_divexact when computing the second cofactor. + +2011-05-03 David Harvey + + * configure.in: make invert_limb_table work correctly with + --disable-assembly (from Niels Möller) + +2011-05-02 Marc Glisse + + * .bootstrap: libtoolize doesn't need -c. + + * configfsf.guess: Update to version of 2011-02-02. + * configfsf.sub: Update to version of 2011-03-23. + +2011-05-02 Niels Möller + + * mpz/gcdext.c (mpz_gcdext): Don't allocate extra limbs at the end + of mpn_gcdext parameters. + + * doc/gmp.texi (mpn_gcdext): Updated doc. + +2011-05-01 Niels Möller + + * mpn/generic/div_qr_2u_pi1.c (mpn_div_qr_2u_pi1): Fixed ASSERT. + +2011-04-30 Marc Glisse + + * gmp-h.in (mpz_cdiv_q_2exp): Use mp_bitcnt_t to match the definition + and the documentation. + (mpz_remove): Likewise. + (mpf_eq): Likewise. + + * ltmain.sh: Remove. + * .bootstrap: Let libtoolize generate ltmain.sh. + + * tests/cxx/t-ops2.cc: Add a couple tests. + * tests/cxx/t-rand.cc: Likewise. + + * doc/gmp.texi (mpf_urandomb): Explicit the fact that it does not + change the precision. + + * gmp-h.in (__GMP_EXTERN_INLINE): Recent g++ uses gnu_inline. + +2011-04-28 Torbjorn Granlund + + * configure.in (x86_64): Support bobcat specifically. + (x86): Match bobcat and bulldozer, handle like k10. + +2011-04-28 David Harvey + + * README.HG: update autotools version numbers. + +2011-04-27 Torbjorn Granlund + + * tune/speed.h (speed_cyclecounter): Always use PIC variant when + compiled with Apple's GCC. + + * mpn/x86/darwin.m4 (LEA): Complete rewrite. + (m4append): New macro. + +2011-04-26 Torbjorn Granlund + + * mpn/sparc32/sparc-defs.m4 (changecom): Don't redefine '!' as it + interferes with expressions. + +2011-04-20 Torbjorn Granlund + + * acinclude.m4 (GMP_ASM_RODATA): Make 'foo' larger to avoid clang + problems. + +2011-04-12 Niels Möller + + * mpn/x86_64/invert_limb.asm [PIC]: Declare mpn_invert_limb_table + as .protected. + +2011-04-11 Torbjorn Granlund + + * mpn/x86/k7/invert_limb.asm: Use deflit for Darwin bug workaround. + Undo 2011-03-28 change. + + * mpn/asm-defs.m4 (define_mpn): Use deflit. + +2011-04-10 Niels Möller + + * mpn/asm-defs.m4 (define_mpn): Added invert_limb_table. + + * configure.in: Add invert_limb_table to extra_functions_64 on + x86_64. + + * mpn/x86_64/invert_limb.asm: Changed references from approx_tab + mpn_invert_limb_table. + + * mpn/x86_64/invert_limb_table.asm (mpn_invert_limb_table): New + file. Extracted approximation table from invert_limb.asm, renamed + and made global. + +2011-03-30 Niels Möller + + * mpn/x86_64/div_qr_2u_pi1.asm: New file. + + * configure.in (gmp_mpn_functions): Add div_qr_2u_pi1. + + * gmp-impl.h (mpn_div_qr_2u_pi1): Declare. + + * mpn/generic/div_qr_2u_pi1.c (mpn_div_qr_2u_pi1): Moved to + separate file, from... + * mpn/generic/div_qr_2.c: ... old location. + + * mpn/generic/div_qr_2n_pi1.c: Renamed file, from... + * mpn/generic/div_qr_2_pi1_norm.c: ...old name. + * mpn/x86_64/div_qr_2n_pi1.asm: Renamed file, from... + * mpn/x86_64/div_qr_2_pi1_norm.asm: ...old name. + + * gmp-impl.h (mpn_div_qr_2n_pi1): Use new name in declaration. + * tune/speed.h (speed_mpn_div_qr_2n): Likewise. + (speed_mpn_div_qr_2u): Likewise. + + * tune/tuneup.c (tune_div_qr_2): Use new name speed_mpn_div_qr_2n. + + * tune/speed.c (routine): Use new names mpn_div_qr_2n and + mpn_div_qr_2u, also on the command line. + + * tune/common.c (speed_mpn_div_qr_2n): Renamed, from... + (speed_mpn_div_qr_2_norm): ... old name. + (speed_mpn_div_qr_2u): Renamed, from... + (speed_mpn_div_qr_2_unnorm): ... old name. + + * mpn/generic/div_qr_2_pi1_norm.c (mpn_div_qr_2n_pi1): Renamed, + from... + (mpn_div_qr_2_pi1_norm): ...old name. + * mpn/x86_64/div_qr_2_pi1_norm.asm: Likewise. + + * mpn/generic/div_qr_2.c (mpn_div_qr_2n_pi2): Renamed, from... + (mpn_div_qr_2_pi2_norm): ... old name. + (mpn_div_qr_2u_pi1): Renamed, from... + (mpn_div_qr_2_pi1_unnorm): ... old name. + (mpn_div_qr_2): Call functions using new names. + + * mpn/asm-defs.m4: Renamed div_qr_2-functions to new names. + +2011-03-29 Niels Möller + + * mpn/x86_64/div_qr_2_pi1_norm.asm: Updated to use a separate rp + argument. + + * gmp-impl.h (mpn_div_qr_2_pi1_norm): Updated declaration. + * gmp-h.in (mpn_div_qr_2): Likewise. + + * tests/mpn/t-div.c (main): Adapted to new mpn_div_qr2 interface. + * tune/speed.h (SPEED_ROUTINE_MPN_DIV_QR_2): Likewise. + + * mpn/generic/div_qr_2.c (mpn_div_qr_2_pi2_norm): Added rp + argument. Don't clobber the input dividend. + (mpn_div_qr_2_pi1_unnorm): Likewise. + (mpn_div_qr_2): Likewise. + * mpn/generic/div_qr_2_pi1_norm.c (mpn_div_qr_2_pi1_norm): Likewise. + +2011-03-29 Niels Möller + + * mpn/x86/k7/invert_limb.asm: Use mov rather than push and pop. + Earlier load of divisor from stack. + +2011-03-28 Torbjorn Granlund + + * mpn/x86/k7/invert_limb.asm: Protect movzwl register parameters from + being interpreted as m4 macro parameters. + +2011-03-22 Niels Möller + + * mpn/x86_64/div_qr_2_pi1_norm.asm: Copied optimized inner loop + from divrem_2.asm. + + * mpn/x86_64/div_qr_2_pi1_norm.asm: First working, but poorly + optimized, implementation. + + * mpn/asm-defs.m4 (define_mpn): Added div_qr_2_pi[12]_*norm. + + * mpn/generic/div_qr_2_pi1_norm.c (mpn_div_qr_2_pi1_norm): Moved + to separate file, from... + * mpn/generic/div_qr_2.c: ... old location. + + * gmp-impl.h (mpn_div_qr_2_pi1_norm): Declare. + + * configure.in (gmp_mpn_functions): Added div_qr_2_pi1_norm. + +2011-03-22 Torbjorn Granlund + + * configure.in (powerpc): Reinsert lost AIX cpu_path 32-bit handling. + Reinsert lost linux/bsd cpu_path handling. + + * mpn/generic/mod_1_1.c: Disable powerpc asm for _LONG_LONG_LIMB. + * mpn/generic/div_qr_2.c: Likewise. + + * mpn/generic/div_qr_2.c: Use asm just for gcc. + Make powerpc add_sssaaaa work for 32-bit case, and use less strict + constraints. + +2011-03-21 Niels Möller + + * tune/tuneup.c (div_qr_2_pi2_threshold): New global variable. + (tune_div_qr_2): New function. + (all): Call tune_div_qr_2. + + * tune/Makefile.am (TUNE_MPN_SRCS_BASIC): Added div_qr_2.c. + + * gmp-impl.h (DIV_QR_2_PI2_THRESHOLD): Setup for tuning. + + New 4/2 division loop, based on Torbjörn's work: + * mpn/generic/div_qr_2.c (add_sssaaaa, add_csaac): New macros. + (udiv_qr_4by2): New macro. + (invert_4by2): New function. + (mpn_div_qr_2_pi2_norm): New function. + (DIV_QR_2_PI2_THRESHOLD): New threshold. + (mpn_div_qr_2_pi1_norm): Renamed, from... + (mpn_div_qr_2_norm): ... old name. + (mpn_div_qr_2_pi1_unnorm): Renamed, from... + (mpn_div_qr_2_unnorm): ... old name. + (mpn_div_qr_2): Use mpn_div_qr_2_pi2_norm for large enough + normalized divisors. + + * gmp-impl.h (udiv_qr_3by2): Avoid a copy. + +2011-03-21 Torbjorn Granlund + + * configure.in (hppa): Under linux, treat 64-bit processors as if they + were 32-bit processors. + + * mpn/generic/addcnd_n.c: New file. + * mpn/asm-defs.m4 (define_mpn): Add addcnd_n and subcnd_n. + * configure.in (gmp_mpn_functions): Add addcnd_n. + * gmp-impl.h (mpn_addcnd_n): Declare. + + * mpn/generic/subcnd_n.c: Combine nails and non-nails functions. + + * gmp-impl.h (invert_pi1): Prepend _ to local variables, protect + parameters within () where necessary. + + * mpn/asm-defs.m4 (define_mpn): Add div_qr_2. + * configure.in (gmp_mpn_functions): Reinsert mercurial-bug-removed + line. + +2011-03-20 Torbjorn Granlund + + * configure.in (powerpc): Add cpu_path for all three ABIs. + Rename "aix64" to "mode64" for consistency. + +2011-03-16 Marc Glisse + + * gmpxx.h (__gmp_binary_not_equal): Remove, use !__gmp_binary_equal. + (__gmp_binary_less_equal): Remove, use !__gmp_binary_greater. + (__gmp_binary_greater_equal): Remove, use !__gmp_binary_less. + * tests/cxx/t-ops2.cc: Typo. + +2011-03-20 Niels Möller + + * tune/common.c (speed_mpn_div_qr_2_norm): New function. + (speed_mpn_div_qr_2_unnorm): New function. + * tune/speed.c (routine): Recognize above functions. + * tune/speed.h: Declarations for above functions. + (SPEED_ROUTINE_MPN_DIV_QR_2): New macro. + + * tests/mpn/t-div.c (main): Added tests for mpn_divrem_2 and + mpn_div_qr_2. + + * mpn/generic/div_qr_2.c (mpn_div_qr_2): New file and function. + Intended to eventually replace divrem_2. + * configure.in (gmp_mpn_functions): Add div_qr_2. + +2011-03-16 Marc Glisse + + * gmpxx.h (__gmp_set_expr): Remove broken declarations. + +2011-03-19 Torbjorn Granlund + + * mpz/fac_ui.c (mpz_fac_ui): Use MPZ_REALLOC for standard, conditional + reallocation. + +2011-03-19 Niels Möller + + * mpn/generic/divrem_2.c (mpn_divrem_2): Fixed comment and assert + regarding q and n overlap. + +2011-03-16 Marc Glisse + + * gmpxx.h (__mpz_set_ui_safe): New inline function. + (__mpz_set_si_safe): Likewise. + (__GMPXX_TMPZ_UI): Use the new function. + (__GMPXX_TMPZ_SI): Likewise. + (__GMPXX_TMPQ_UI): Likewise. + (__GMPXX_TMPQ_SI): Likewise. + * tests/cxx/t-ops2.cc: test converting 0 to stack mpq_t. + +2011-03-15 Marc Glisse + + * gmpxx.h (__GMPXX_TMPQ_UI): New macro. + (__GMPXX_TMPQ_SI): New macro. + (struct __gmp_binary_multiplies): Rewrite, using the new macros. + (struct __gmp_binary_divides): Likewise. + + * gmpxx.h (__GMPZ_ULI_LIMBS): Rewrite. + * tests/cxx/t-ops2.cc: test converting ULONG_MIN to stack mpq_t. + +2011-03-15 Marco Bodrato + + * mpn/generic/toom_interpolate_16pts.c: Remove ambiguity. + +2011-03-14 Torbjorn Granlund + + * tune/tuneup.c (tune_mul): Set tuning min size considering print skew. + + * doc/gmp.texi: Make reference to "Formatted I/O" chapters from type + specific I/O sections. + + * mpn/alpha/add_n.asm: Add _nc entry point. + * mpn/alpha/sub_n.asm: Likewise. + * mpn/mips64/add_n.asm: Likewise. + * mpn/mips64/sub_n.asm: Likewise. + * mpn/sparc64/ultrasparc1234/add_n.asm: Likewise. + * mpn/sparc64/ultrasparc1234/sub_n: Likewise. + +2011-03-13 Marc Glisse + + * tests/cxx/t-ops2.cc: New file. + * tests/cxx/Makefile.am: Added t-ops2. + +2011-03-13 Torbjorn Granlund + + * mpn/generic/toom32_mul.c (mpn_toom32_mul): Make 'hi' be limb-sized + for better code. + + * gmp-impl.h (MPN_IORD_U): Handle x86_64 as well as x86_32. Generate + no code for incrementing by constant 0. + +2011-03-12 Marc Glisse + + * gmpxx.h: Rename __GMPXX_TMP_* to __GMPXX_TMPZ_*. Use in more places. + +2011-03-12 Torbjorn Granlund + + * mpn/powerpc64/rshift.asm: Accept/return values correctly also for + 32-bit ABI. + * mpn/powerpc64/lshift.asm: Likewise. + + * tune/powerpc.asm: Use powerpc syntax, not power syntax. + + * tune/common.c (speed_udiv_qrnnd_preinv1, etc): Remove. + * tune/speed.c (routine): Remove udiv_qrnnd_preinv1, etc. + +2011-03-12 Marc Glisse + + * tests/cxx/t-istream.cc: Restrict mpq test in t-istream -s. + + * gmpxx.h: Remove leftover #undefs. + +2011-03-11 Torbjorn Granlund + + * gmp-impl.h (udiv_qrnnd_preinv1, udiv_qrnnd_preinv2, + udiv_qrnnd_preinv2gen): Remove obsolete macros. + (udiv_qrnnd_preinv): New name for udiv_qrnnd_preinv3. + +2011-03-11 Marco Bodrato + + * gmp-impl.h: Declare many mpn_{sub,add}lsh*_n_ip[12] functions/macros. + * mpn/generic/toom_interpolate_5pts.c: Use mpn_sublsh1_n_ip1. + + * tests/devel/try.c: Tests for {add,sub}lsh*_n_ip[12]. + * tests/refmpn.c: New reference for mpn_{add,sub}lsh*_n_ip[12]. + * tests/tests.h: Declarations for reference functions above. + + * tune/common.c: New speed_mpn_{add,sub}lsh*_n_ip[12] functions. + * tune/speed.h: Prototypes for functions above. + * tune/speed.c: Support for mpn_{add,sub}lsh*_n_ip[12]. + + * mpn/x86/k7/sublsh1_n.asm: Replaced generic sublsh1 code with faster _ip1. + * mpn/x86/atom/sublsh1_n.asm: Changed PROLOGUE accordingly. + + * configure.in: Define HAVE_NATIVE_mpn_addlsh*_n*_ip[12]. + * mpn/asm-defs.m4: Declare mpn_addlsh*_n*_ip[12]. + +2011-03-10 Marc Glisse + + * tests/cxx/t-istream.cc: Explicit conversion to streampos. + +2011-03-10 Torbjorn Granlund + + * mpn/x86/atom/sse2/mul_basecase.asm: Suppress wind-down rp updates. + + * Move new aorrlsh_n.asm to new k8 dir. Revert + mpn/x86_64/aorrlsh_n.asm. + * configure.in: Setup path for new k8 directory. + +2011-03-10 Marco Bodrato + + * mpn/x86/pentium4/sse2/bdiv_dbm1c.asm: New file, was in atom. + * mpn/x86/atom/sse2/bdiv_dbm1c.asm: Grab file above. + +2011-03-09 Torbjorn Granlund + + * mpn/x86_64/aorrlsh_n.asm: Complete rewrite. + + * mpn/x86_64/core2/aorrlsh_n.asm: New file, grabbing another asm file. + +2011-03-09 Marc Glisse + + * tests/cxx/t-ostream.cc: Use bool instead of int. + * tests/cxx/t-istream.cc: Likewise. + * tests/cxx/t-misc.cc: Likewise. + + * cxx/ismpznw.cc: Don't clear eofbit. + * cxx/ismpq.cc: Likewise. + * cxx/ismpf.cc: Likewise. + * tests/cxx/t-istream.cc: Test accordingly. + +2011-03-09 Marco Bodrato + + * mpn/x86/atom/sse2/bdiv_dbm1c.asm: New file. + +2011-03-09 Marc Glisse + + * doc/gmp.texi: Remove void return type from constructors. Document + explicit constructors. Document mpf_class::mpf_class(mpf_t). + +2011-03-07 Marco Bodrato + + * mpn/x86/atom/sse2/sqr_basecase.asm: Postponed pushes. Cleaned + outer loop exit. + +2011-03-07 Torbjorn Granlund + + * mpn/x86_64/gcd_1.asm: Workaround Oracle assembler bug. + + * mpn/x86/atom/sse2/mul_basecase.asm: Replace addmul_1 loops. + Tweak outer loop rp updates. + +2011-03-06 Torbjorn Granlund + + * mpn/x86/atom/sse2/sqr_basecase.asm: New file. + +2011-03-05 Torbjorn Granlund + + * mpn/x86_64/bdiv_dbm1c.asm: Write proper feed-in code. + +2011-03-04 Torbjorn Granlund + + * mpn/x86_64/addmul_2.asm: Rewrite for linear performance. + +2011-03-03 Torbjorn Granlund + + * mpn/generic/mod_1_1.c (add_mssaaaa): Canonicalise layout. Add arm + variant. Enable sparc64 code and powerpc code (the latter for 32-bit + and 64-bit). + + * mpn/generic/sqrtrem.c (mpn_dc_sqrtrem): Use mpn_addlsh1_n. + + * gmp-impl.h (mpn_addlsh_nc, mpn_rsblsh_nc): Declare. + * mpn/asm-defs.m4: Likewise. + + * mpn/x86_64/coreisbr/aorrlsh_n.asm: Disable mpn_rsblsh_n due to + carry-in issues. + * mpn/x86_64/coreinhm/aorrlsh_n.asm: Likewise. + * mpn/x86_64/coreisbr/aorrlsh2_n.asm: Likewise. + +2011-03-03 Niels Möller + + * mpn/generic/mod_1_1.c (add_mssaaaa): For x86 and x86_64, treat m + as in output operand only. Added sparc32 implementation. Also + added #if:ed out attempts at sparc64 and powerpc64. + + * tune/tuneup.c (tune_mod_1): Record result of MOD_1_1P_METHOD + measurement for use by mpn_mod_1_tune. And omit measurement if + mpn_mod_1_1p is native assembly code. + + * mpn/generic/mod_1.c (mpn_mod_1_1p) [TUNE_PROGRAM_BUILD]: Macro + to check mod_1_1p_method and call the right function. + (mpn_mod_1_1p_cps) [TUNE_PROGRAM_BUILD]: Likewise. + + * gmp-impl.h (MOD_1_1P_METHOD) [TUNE_PROGRAM_BUILD]: Define macro. + (mod_1_1p_method) [TUNE_PROGRAM_BUILD]: Declare variable. + +2011-03-02 Torbjorn Granlund + + * mpn/x86_64/coreinhm/aorrlsh_n.asm: New file. + * mpn/x86_64/coreisbr/aorrlsh_n.asm: New file. + +2011-03-01 Niels Möller + + * mpn/x86_64/mod_1_1.asm (mpn_mod_1_1p_cps): Eliminated a neg and + two mov instructions. + + * mpn/x86/k7/mod_1_1.asm (mpn_mod_1_1p_cps): Simplified + computation, analogous to recent x86_64/mod_1_1.asm changes. + (mpn_mod_1_1p): Corresponding changes. Don't shift b. + + * mpn/sparc64/mod_1_4.c (mpn_mod_1s_4p_cps): Use udiv_rnnd_preinv + rather than udiv_rnd_preinv. + (mpn_mod_1s_4p): Likewise. + +2011-03-01 Torbjorn Granlund + + * mpn/x86/pentium4/sse2/mul_1.asm: Swap entry insns to share more code + between entry points. + * mpn/x86/pentium4/sse2/addmul_1.asm: Likewise. + + * mpz/divegcd.c: Rewrite, as per Marc Glisse's suggestion. Also fix + problem with passing a longlong limb to a _ui function. + + * gmp-impl.h (udiv_qrnnd_preinv3): Cast truth value to mask's type. + (udiv_rnnd_preinv): Likewise. + * mpn/generic/mod_1_1.c (mpn_mod_1_1p): Likewise. + +2011-02-28 Niels Möller + + * mpn/generic/mod_1_1.c (add_mssaaaa): Typo fix, define + add_mssaaaa, not add_sssaaaa. + + * tune/tuneup.c (tune_mod_1): Measure mpn_mod_1_1_1 and + mpn_mod_1_1_2, to set MOD_1_1P_METHOD. + + * tune/speed.c (routine): Added mpn_mod_1_1_1 and mpn_mod_1_1_2. + + * tune/speed.h: Declare speed_mpn_mod_1_1_1, speed_mpn_mod_1_1_2, + mpn_mod_1_1p_1, mpn_mod_1_1p_2, mpn_mod_1_1p_cps_1, and + mpn_mod_1_1p_cps_2. + + * tune/common.c (speed_mpn_mod_1_1_1): New function. + (speed_mpn_mod_1_1_2): New function. + + * tune/Makefile.am (libspeed_la_SOURCES): Added mod_1_1-1.c + mod_1_1-2.c. + + * tune/mod_1_1-1.c: New file. + * tune/mod_1_1-2.c: New file. + + * mpn/generic/mod_1_1.c: Implemented an algorithm with fewer + multiplications, configured via MOD_1_1P_METHOD. + + * mpn/x86_64/mod_1_1.asm (mpn_mod_1_1p_cps): Simplified + computation of B2modb, use B^2 mod (normalized b). + (mpn_mod_1_1p): Corresponding changes. Don't shift b. + + * mpn/generic/mod_1_1.c (mpn_mod_1_1p_cps): Use udiv_rnnd_preinv rather + than udiv_rnd_preinv. + (mpn_mod_1_1p): Likewise. + * mpn/generic/mod_1_4.c: Analogous changes. + * mpn/generic/mod_1_3.c: Analogous changes. + * mpn/generic/mod_1_2.c: Analogous changes. + * mpn/generic/mod_1.c: Analogous changes. + * mpn/generic/pre_mod_1.c: Analogous changes. + + * gmp-impl.h (udiv_qrnnd_preinv3): Eliminated unpredictable branch + using masking logic. Further optimization of the nl == constant 0 + case, similar to udiv_rnd_preinv. + (udiv_rnnd_preinv): Likewise. + (udiv_rnd_preinv): Deleted, use udiv_rnnd_preinv with nl == 0 + instead. + + * tests/mpn/t-divrem_1.c (check_data): Added testcase to exercise + the nl == constant 0 special case in udiv_qrnnd_preinv3. + +2011-02-28 Torbjorn Granlund + + * mpn/generic/rootrem.c (mpn_rootrem): Combine two similar scalar + divisions. Misc minor cleanup. + + * mpn/x86/atom/sse2/aorsmul_1.asm: Shorten software pipeline. + + * mpn/x86/atom/mul_basecase.asm: Remove file no longer used. + + * mpn/generic/rootrem.c (mpn_rootrem_internal): Delay O(log(U)) + allocations until they are known to be needed. + +2011-02-27 Marco Bodrato + + * mpn/x86/atom/sse2/mul_1.asm: New code. + +2011-02-27 Niels Möller + + * gmp-impl.h (udiv_rnnd_preinv): New macro. + +2011-02-27 Torbjorn Granlund + + * mpn/x86/atom/sse2/mul_basecase.asm: New file. + +2011-02-26 Marco Bodrato + + * mpn/x86/atom/sse2/aorsmul_1.asm: Optimise non-loop code. + +2011-02-26 Torbjorn Granlund + + * mpn/powerpc64/mode64/aorsmul_1.asm: Add MULFUNC_PROLOGUE. + * mpn/m68k/mc68020/aorsmul_1.asm: Likewise. + + * mpn/powerpc64/mode64/aorsmul_1.asm: Add missing MULFUNC_PROLOGUE. + * mpn/m68k/mc68020/aorsmul_1.asm: Likewise. + +2011-02-25 Torbjorn Granlund + + * mpn/x86/atom/sse2/aorsmul_1.asm: New file. + * mpn/x86/atom/aorsmul_1.asm: File removed. + +2011-02-25 Marco Bodrato + + * mpn/x86/atom/sse2/divrem_1.asm: New file (was in x86/atom). + * mpn/x86/atom/sse2/mul_1.asm: Likewise. + * mpn/x86/atom/sse2/popcount.asm: Likewise. + * mpn/x86/atom/divrem_1.asm: ReMoved (in sse2/ now). + * mpn/x86/atom/mul_1.asm: Likewise. + * mpn/x86/atom/popcount.asm: Likewise. + + * configure.in: Set up mmx path for atom. + * mpn/x86/atom/mmx/copyd.asm: New file (was in x86/atom). + * mpn/x86/atom/mmx/copyi.asm: Likewise. + * mpn/x86/atom/mmx/hamdist.asm: Likewise. + * mpn/x86/atom/copyd.asm: ReMoved (in mmx/ now). + * mpn/x86/atom/copyi.asm: Likewise. + * mpn/x86/atom/hamdist.asm: Likewise. + +2011-02-24 Torbjorn Granlund + + * mpn/x86/atom/sse2/mod_1_1.asm: New file. + * mpn/x86/atom/sse2/mod_1_4.asm: New file. + * configure.in: Set up sse2 path for atom. + + * mpn/x86/p6/sse2/mod_1_1.asm: New file. + * mpn/x86/p6/sse2/mod_1_4.asm: Fix typo in MULFUNC_PROLOGUE. + +2011-02-24 Niels Möller + + * mpn/x86/k7/mod_1_1.asm (mpn_mod_1_1p): Rewrite using the same + algorithm as the x86_64 version. + +2011-02-23 Marco Bodrato + + * mpn/x86/atom/logops_n.asm: New file (same loop as aors_n). + +2011-02-23 Niels Möller + + * mpn/x86_64/mod_1_1.asm (mpn_mod_1_1p): Shaved off one + instruction and one register in the inner loop. Rearranged + registers slightly, and no longer needs the callee-save register + %r12. + +2011-02-22 Torbjorn Granlund + + * configure.in: Export SHLD_SLOW and SHRD_SLOW to config.m4, also + fixing typo in exporting code. + + * mpn/x86_64/nano/gmp-mparam.h (SHLD_SLOW, SHRD_SLOW): Define. + * mpn/x86_64/atom/gmp-mparam.h (SHLD_SLOW, SHRD_SLOW): Define. + +2011-02-22 Niels Möller + + * mpn/x86_64/mod_1_1.asm (mpn_mod_1_1p): Rewrite. + +2011-02-22 Marco Bodrato + + * mpn/x86/atom/lshiftc.asm: New file (a copy of lshift.asm with a handful of neg added). + +2011-02-21 Torbjorn Granlund + + * mpn/x86/aors_n.asm: Move _nc entry to after main code. Align loop + and _n entry for claimed performance. Normalise mnemonic usage. + + * mpn/x86/atom/aorrlsh1_n.asm: New file (code from rsblsh_1, slightly + slower for addlsh_1 for large operands, but much faster for small). + * mpn/x86/atom/addlsh1_n.asm: Remove. + * mpn/x86/atom/rsblsh1_n.asm: Remove. + +2011-02-20 Marc Glisse + + * mpq/aors.c: Rewrite to remove redundant division. + +2011-02-20 Torbjorn Granlund + + * mpn/x86/atom/lshift.asm: New file. + * mpn/x86/atom/rshift.asm: Normalise mnemonic usage. + + * gmp-impl.h (mpn_divexact_by7): Relax inclusion condition. + + * mpz/divegcd.c (mpz_divexact_by5): New conditionally enabled function. + (mpz_divexact_by3): Wrap inside appropriate conditions. + (mpz_divexact_gcd): Rewrite. + + * mpn/x86/bdiv_dbm1c.asm: Save a jump. + +2011-02-20 Marco Bodrato + + * mpn/x86/atom/aorslshC_n.asm: New file. + * mpn/x86/atom/sublsh2_n.asm: New file. + + * mpn/x86/atom/aors_n.asm: New code. + * mpn/x86/atom/rshift.asm: Atom64 code adapted to 32-bit. + * mpn/x86/atom/lshift.asm: Likewise. + +2011-02-19 Torbjorn Granlund + + * mpn/x86_64/atom/rsh1aors_n.asm: New file. + + * mpn/x86_64/atom/lshift.asm: New file. + * mpn/x86_64/atom/rshift.asm: New file. + * mpn/x86_64/atom/lshiftc.asm: New file. + +2011-02-17 Marco Bodrato + + * mpn/x86/atom/aorsmul_1.asm: Small improvements for small sizes. + * mpn/x86/atom/aorrlshC_n.asm: Tiny size improvements. + +2011-02-16 Torbjorn Granlund + + * configure.in: Fix k8/k10 32-bit path setup problem. + +2011-02-16 Marco Bodrato + + * mpn/x86/atom/aorsmul_1.asm: Revive an old k7/aorsmul. + +2011-02-14 Marco Bodrato + + * gmp-impl.h (mpn_sublsh_n): Declare. + * mpn/asm-defs.m4: Likewise. + + * mpn/x86/atom/aorrlshC_n.asm: New file (was k7). + * mpn/x86/k7/aorrlshC_n.asm: ReMoved. + * mpn/x86/atom/aorrlsh2_n.asm: Grab atom/aorrlshC_n.asm. + * mpn/x86/atom/rsblsh1_n.asm: Grab atom/aorrlshC_n.asm. + +2011-02-13 Torbjorn Granlund + + * mpn/x86_64/atom/aorrlsh2_n.asm: New file. + +2011-02-12 Torbjorn Granlund + + * mpn/x86_64/aorrlsh_n.asm: Minor tweaks, update c/l numbers. + + * mpn/x86_64/atom/sublsh1_n.asm: New file. + + * mpn/x86_64/atom/aorrlsh1_n.asm: New file. + +2011-02-11 Torbjorn Granlund + + * mpn/powerpc64/mode64/mod_1_1.asm: Fix Darwin syntax issues. + +2011-02-10 Torbjorn Granlund + + * mpn/powerpc64/mode64/mod_1_4.asm: Tune away a cycle for 970. + +2011-02-11 Marco Bodrato + + * mpn/x86/k7/addlsh1_n.asm: Faster core loop (Torbjorn's). + + * configure.in: Add HAVE_NATIVE_{add,sub,rsb}lsh{,1,2}_nc. + * tests/tests.h: refmpn_{add,sub,rsb}lsh{,1,2}_nc prototypes. + * tests/refmpn.c: New refmpn_{add,sub,rsb}lsh{,1,2}_nc. + * tests/devel/try.c: Tests for mpn_{add,sub,rsb}lsh{,1,2}_nc. + + * mpn/x86/k7/aorrlshC_n.asm: New file. + * mpn/x86/atom/aorrlsh2_n.asm: Grab k7/aorrlshC_n.asm. + * mpn/x86/atom/rsblsh1_n.asm: Grab k7/aorrlshC_n.asm. + +2011-02-06 Marco Bodrato + + * mpn/x86/k7/addlsh1_n.asm: New file. + * mpn/x86/k7/sublsh1_n.asm: New file. + * mpn/x86/atom/addlsh1_n.asm: Grab k7/addlsh1_n.asm. + * mpn/x86/atom/sublsh1_n.asm: Grab k7/sublsh1_n.asm. + +2011-02-05 Torbjorn Granlund + + * gmp-impl.h (mpn_addlsh1_nc, mpn_addlsh2_nc, mpn_sublsh1_nc, + mpn_sublsh2_nc, mpn_rsblsh1_nc, mpn_rsblsh2_nc): Declare. + * mpn/asm-defs.m4: Likewise. + + * mpn/x86_64/coreisbr/aorrlshC_n.asm: New file. + * mpn/x86_64/coreisbr/aorrlsh1_n.asm: New file. + * mpn/x86_64/coreisbr/aorrlsh2_n.asm: New file. + + * mpn/x86_64/coreisbr/aors_n.asm: New file, based on old + atom/aors_n.asm. + * mpn/x86_64/atom/aors_n.asm: Grab coreisbr/aors_n.asm. + +2011-02-05 Marco Bodrato + + * gmp-impl.h (mpn_toom6_mul_n_itch): Handle threshold == zero. + (mpn_toom8_mul_n_itch): Likewise. + (MPN_TOOM6H_MIN, MPN_TOOM8H_MIN): Define. + * tests/mpn/t-toom6h.c: No tests below MPN_TOOM6H_MIN. + * tests/mpn/t-toom8h.c: No tests below MPN_TOOM8H_MIN. + + * mpz/lucnum_ui.c: Use mpn_addlsh2_n. + +2011-02-04 Torbjorn Granlund + + * mpn/x86_64/atom/rsh1aors_n.asm: Add a MULFUNC_PROLOGUE. + * mpn/x86_64/atom/dive_1.asm: Likewise. + * mpn/x86_64/atom/popcount.asm: Likewise. + * mpn/x86_64/core2/popcount.asm: Likewise. + * mpn/x86_64/coreinhm/hamdist.asm: Likewise. + * mpn/x86_64/coreinhm/popcount.asm: Likewise. + * mpn/x86_64/nano/popcount.asm: Likewise. + * mpn/x86_64/pentium4/popcount.asm: Likewise. + +2011-02-04 Marco Bodrato + + * mpn/x86/atom/mode1o.asm: New file, grabbing another asm file. + * mpn/x86/atom/mul_1.asm: Claim mul_1c. + +2011-02-02 Niels Möller + + * tune/speed.h (SPEED_ROUTINE_MPN_HGCD_CALL): Fixed one + speed_operand_dst call. + +2011-02-01 Torbjorn Granlund + + * tune/speed.h (struct speed_params): Allow for 4 dst operands. + * tune/common.c (TOLERANCE): Increase from 0.5% to 1%. + + * tune/speed.h (SPEED_ROUTINE_MPN_HGCD_CALL): New macro, mainly based + on old speed_mpn_hgcd, but with speed_operand_src calls (as suggested + by Niels). + * tune/common.c (speed_mpn_hgcd): Invoke SPEED_ROUTINE_MPN_HGCD_CALL. + (speed_mpn_hgcd_lehmer): Likewise. + + * configure.in: Set up 32-bit x86 paths for new corei* CPU strings. + +2011-01-31 Torbjorn Granlund + + * config.guess: Recognise new Intel processors. + + * config.guess: Support 'coreinhm' and 'coreisbr'. + * config.sub: Likewise. + * configure.in: Likewise. + +2011-01-30 Torbjorn Granlund + + * configure.in: Support x86/geode. + * mpn/x86/geode/gmp-mparam.h: New file. + +2011-01-29 Marco Bodrato + + * mpn/x86/atom/addlsh1_n.asm: Removed. + * mpn/x86/atom/rsh1add_n.asm: Likewise. + +2011-01-28 Torbjorn Granlund + + * mpn/alpha/ev6/slot.pl: Add some missing insns. + +2011-01-28 Marco Bodrato + + * mpn/x86/atom/copyd.asm: New file, grabbing another asm file. + * mpn/x86/atom/copyi.asm: Likewise. + * mpn/x86/atom/aors_n.asm: Likewise. + * mpn/x86/atom/addlsh1_n.asm: Likewise. + * mpn/x86/atom/aorsmul_1.asm: Likewise. + * mpn/x86/atom/bdiv_q_1.asm: Likewise. + * mpn/x86/atom/dive_1.asm: Likewise. + * mpn/x86/atom/divrem_1.asm: Likewise. + * mpn/x86/atom/hamdist.asm: Likewise. + * mpn/x86/atom/logops_n.asm: Likewise. + * mpn/x86/atom/lshift.asm: Likewise. + * mpn/x86/atom/mod_34lsub1.asm: Likewise. + * mpn/x86/atom/mul_1.asm: Likewise. + * mpn/x86/atom/mul_basecase.asm: Likewise. + * mpn/x86/atom/popcount.asm: Likewise. + * mpn/x86/atom/rsh1add_n.asm: Likewise. + * mpn/x86/atom/rshift.asm: Likewise. + * mpn/x86/atom/sqr_basecase.asm: Likewise. + +2011-01-27 Torbjorn Granlund + + * mpn/x86_64/atom/rsh1aors_n.asm: New file, grabbing another asm file. + * mpn/x86_64/atom/popcount.asm: Likewise. + * mpn/x86_64/atom/dive_1.asm: Likewise. + * mpn/x86_64/nano/popcount.asm: Likewise. + +2011-01-26 Torbjorn Granlund + + * mpn/alpha/invert_limb.asm: Complete rewrite. + +2011-01-25 Torbjorn Granlund + + * mpn/powerpc32/invert_limb.asm: New file. + +2011-01-25 Marco Bodrato + + * mpn/x86/pentium4/sse2/bdiv_q_1.asm: New file. + * mpn/x86/k7/bdiv_q_1.asm: New file. + +2011-01-24 Torbjorn Granlund + + * tune/tuneup.c (tune_mul_n, tune_sqr): Loop, re-measuring thresholds + until no tiny ranges remain. + +2011-01-23 Torbjorn Granlund + + * mpn/ia64/mul_2.asm: Tweak to 1.5 c/l, less overhead. + + * mpn/ia64/addmul_2.asm: Rewrite, adding mpn_addmul_2s entry point. + +2011-01-22 Torbjorn Granlund + + * mpn/ia64/aors_n.asm: Fix some incorrect bundle types. + + * mpn/ia64/sqr_diagonal.asm: Remove. + + * mpn/ia64/sqr_diag_addlsh1.asm: New file. + + * mpn/ia64/ia64-defs.m4: Define some shorter convenience mnemonics. + + * mpn/generic/sqr_basecase.c (MPN_SQR_DIAG_ADDLSH1): New macro, using + new function mpn_sqr_diag_addlsh1 or defining its equivalent. + + * gmp-impl.h (mpn_addmul_2s): Declare. + (mpn_sqr_diag_addlsh1): Declare. + * mpn/asm-defs.m4 (define_mpn): Add addmul_2s and sqr_diag_addlsh1. + + * configure.in: Add HAVE_NATIVEs for mpn_sqr_diag_addlsh1 and + mpn_addmul_2s. + (gmp_mpn_functions_optional): Add sqr_diag_addlsh1. + +2011-01-21 Marco Bodrato + + * tests/devel/try.c: Initial support for mpn_bdiv_q_1. + * mpn/x86/pentium/bdiv_q_1.asm: New file. + * mpn/x86/p6/bdiv_q_1.asm: New file. + +2011-01-20 Torbjorn Granlund + + * tune/speed.c (run_gnuplot): Update to current gnuplot syntax. + + * mpn/powerpc64/mode64/aorsmul_1.asm: Trim away 0.5 c/l for submul_1 + for POWER5. + +2011-01-19 Torbjorn Granlund + + * mpn/x86_64/core2/rsh1aors_n.asm: New file. + +2011-01-18 Marco Bodrato + + * mpn/x86/bdiv_q_1.asm: New file (same core alg. as dive_1). + +2011-01-15 Marco Bodrato + + * mpn/generic/divexact.c: Avoid COPY if not needed. + +2011-01-14 Torbjorn Granlund + + * gmp-impl.h (struct cpuvec_t): Add field bmod_1_to_mod_1_threshold. + * configure.in (fat_thresholds): Add BMOD_1_TO_MOD_1_THRESHOLD. + +2011-01-13 Marco Bodrato + + * mpz/mul.c: Remove redundant size computation. + +2011-01-08 Torbjorn Granlund + + * tests/devel/try.c (types enum): Add TYPE_MUL_5 and TYPE_MUL_6. + (param_init): Support new types. + (choice_array): Support testing of mpn_mul_5 and mpn_mul_6. + (call): Support new routines. + + * tests/refmpn.c (refmpn_mul_5, refmpn_mul_6): New functions. + * tests/tests.h (refmpn_mul_5, refmpn_mul_6): Declare. + Remove parameter names from some other functions. + + * gmp-impl.h (mpn_mul_5, mpn_mul_6): Declare. + * mpn/asm-defs.m4: Likewise, also declare mpn_addmul_5, mpn_addmul_6, + mpn_addmul_7, and mpn_addmul_8. + + * configure.in (gmp_mpn_functions_optional): Add mul_5 and mul_6. + + * tune/speed.c (routine): Add measuring of mpn_mul_5 and mpn_mul_6. + * tune/common.c (speed_mpn_mul_5, speed_mpn_mul_6): New functions. + * tune/speed.h: Declare new functions. + +2011-01-03 Marco Bodrato + + * mpz/aors.h: Remove #ifdef BERKELEY_MP, and cleanup. + * mpz/cmp.c: Likewise. + * mpz/gcd.c: Likewise. + * mpz/mul.c: Likewise. + * mpz/powm.c: Likewise. + * mpz/set.c: Likewise. + * mpz/sqrtrem.c: Likewise. + * mpz/tdiv_qr.c: Likewise. + +2010-12-28 Torbjorn Granlund + + * mpn/minithres/gmp-mparam.h: Update with several recent thresholds. + +2010-12-19 Torbjorn Granlund + + * mpn/x86/k7/mod_1_1.asm: Canonicalise cmov forms. + * mpn/x86/k7/mod_1_4.asm: Likewise. + * mpn/x86/pentium4/sse2/mod_1_1.asm: Likewise. + * mpn/x86/pentium4/sse2/mod_1_4.asm: Likewise. + * mpn/x86_64/core2/divrem_1.asm: Likewise. + * mpn/x86_64/divrem_1.asm: Likewise. + * mpn/x86_64/mod_1_1.asm: Likewise. + * mpn/x86_64/mod_1_2.asm: Likewise. + * mpn/x86_64/mod_1_4.asm: Likewise. + + * mpn/x86/k7/gcd_1.asm: Rewrite. Remove slow 'div' loop. Call + mpn_mod_1 for operands with mode than BMOD_1_TO_MOD_1_THRESHOLD limbs. + Misc cleanups. + +2010-12-18 Torbjorn Granlund + + * mpn/x86_64/gcd_1.asm: Call mpn_mod_1 for operands with mode than + BMOD_1_TO_MOD_1_THRESHOLD limbs. + + * configure.in: Generalise code for putting THRESHOLDs in config.m4. + Add BMOD_1_TO_MOD_1_THRESHOLD to list. + + * mpn/x86_64/core2/divrem_1.asm: Tweak slightly, correct cycle counts. + + * mpn/x86_64/addmul_2.asm: Remove constant index. + * mpn/x86_64/lshiftc.asm: Likewise. + * mpn/x86_64/pentium4/lshift.asm: Likewise. + * mpn/x86_64/pentium4/lshiftc.asm: Likewise. + * mpn/x86_64/pentium4/rshift.asm: Likewise. + +2010-12-16 Torbjorn Granlund + + * mpn/x86_64/mod_34lsub1.asm: Complete rewrite. + * mpn/x86_64/pentium4/mod_34lsub1.asm: New file, old + mpn/x86_64/mod_34lsub1.asm. + +2010-12-15 Torbjorn Granlund + + * mpn/powerpc64/vmx/popcount.asm: Rewrite to use vperm count table. + +2010-12-14 Torbjorn Granlund + + * mp-h.in: Remove. + * configure.in: Remove mp-h.in from AC_OUTPUT invocation. + +2010-12-13 Torbjorn Granlund + + * mpz/mod.c: Rewrite. + + * mpn/x86_64/corei/popcount.asm: New file. + * mpn/x86_64/corei/hamdist.asm: New file. + + * mpn/x86_64/k10/hamdist.asm: New file. + + * configure.in: Amend last change for lame /bin/sh. + +2010-12-12 Torbjorn Granlund + + * configure.in: Comment out M4=m4-not-needed. + + * mpn/x86_64/k10/popcount.asm: New file. + * configure.in: Setup special path for k10 and later AMD CPUs. + Remove special x86_64'k8' path, since directory is non-existent. + +2010-12-11 Torbjorn Granlund + + * mpn/sparc32/ultrasparct1: New directory. + * mpn/sparc32/ultrasparct1/add_n.asm: New file. + * mpn/sparc32/ultrasparct1/sub_n.asm: New file. + * mpn/sparc32/ultrasparct1/mul_1.asm: New file. + * mpn/sparc32/ultrasparct1/addmul_1.asm: New file. + * mpn/sparc32/ultrasparct1/submul_1.asm: New file. + * mpn/sparc32/ultrasparct1/sqr_diagonal.asm: New file. + + * config.guess: Support Ultrasparc T2 and T3. + * config.sub: Likewise. + * configure.in: Likewise. + + * config.guess: Generalise BSD Sparc recognition by allowing any + caps (needed for OpenBSD which spells things innovatively). + +2010-12-01 Torbjorn Granlund + + * config.guess: Match new AMD processors, allow finer distinctions + among old ones. + * acinclude.m4 (X86_64_PATTERN): Likewise. + * config.sub: Likewise. + * configure.in: Rudimentarily support new AMD processors. + + * configure.in (--enable_assembly): New option. + (target none-*-*): Disable, give error. + +2010-11-29 Torbjorn Granlund + + * mpn/x86/x86-defs.m4 (LEA): Support non-PIC code. + * mpn/x86/darwin.m4 (LEA): Likewise. + + * tests/amd64call.asm: Rewrite for code size, and to match calls and + returns. + + * tests/x86call.asm: Rewrite for code size, to support PIC, and to + match calls and returns. + * tests/x86check.c: Rewrite. + +2010-11-22 Torbjorn Granlund + + * mpz/get_str.c: Make all bases either work or return an error. + * mpz/out_str.c: Likewise. + * mpq/get_str.c: Likewise. + * mpf/get_str.c: Likewise. + +2010-11-14 Torbjorn Granlund + + * tests/misc/t-printf.c: Add explicit casts for type conversions. + * mpn/generic/toom62_mul.c: Likewise. + +2010-11-13 Torbjorn Granlund + + * mpn/generic/get_d.c: Misc cleanup. Fail with a syntax error for + non-IEEE fp formats. + + * tests/devel/try.c (malloc_region): Add explicit casts for type + conversions. + + * acinclude.m4 (GMP_ASM_RODATA): Make test code snippet C++ compatible. + (GMP_C_DOUBLE_FORMAT): Likewise. + (GMP_FUNC_VSNPRINTF): Likewise. + + * config.guess (x86): Make test C snippet C++ compatible. + +2010-11-12 Torbjorn Granlund + + * Makefile.am: Remove mpbsd. + * configure.in: Remove mpbsd. + * doc/configuration: Remove mpbsd mentions. + * doc/gmp.texi: Remove mpbsd docs. + * tests/Makefile.am: Remove mpbsd. + * libmp.sym: Remove. + * mpbsd: Remove directory and files. + * tests/mpbsd: Remove directory and files. + +2010-11-11 Torbjorn Granlund + + * mpn/x86_64/atom/aors_n.asm: Don't rely on ZF after 'bt' insn. + Use 64-bit 'test' to support operands of 2^32 limbs and more. + + * rand: New directory, move rand*.c and randmt.h here. + * rand/Makefile.am: New file. + * Makefile.am (SUBDIRS): Add rand. + (RANDOM_OBJECTS): New variable. + (libgmp_la_SOURCES): Remove random objects. + (libgmp_la_DEPENDENCIES): Add RANDOM_OBJECTS. + * configure.in (AC_OUTPUT): Add rand/Makefile. + + * ansi2knr.1: File removed. + * ansi2knr.c: File removed. + +2010-11-10 Torbjorn Granlund + + Make it possible to compile GMP with g++: + + * gmp-impl.h: Declare __gmp_digit_value_tab here. + * mpbsd/min.c: ...not here. + * mpbsd/xtom.c: ...nor here. + * mpf/set_str.c: ...nor here. + * mpz/inp_str.c: ...nor here. + * mpz/set_str.c: ...nor here. + + * mpn/generic/toom43_mul.c: Add casts for logical operations on enums. + * mpn/generic/toom44_mul.c: Likewise. + * mpn/generic/toom4_sqr.c: Likewise. + * mpn/generic/toom52_mul.c: Likewise. + * mpn/generic/toom53_mul.c: Likewise. + * mpn/generic/toom62_mul.c: Likewise. + + * mpz/clrbit.c: Clean up typing using MPZ_REALLOC. + * mpz/setbit.c: Likewise. + + * mpz/powm.c: Avoid variable name 'new'. + + * randlc2x.c: Add explicit casts for type conversions. + * tests/misc/t-printf.c: Likewise. + * tests/misc/t-scanf.c: Likewise. + * tests/misc.c: Likewise. + * tests/mpz/convert.c: Likewise. + * tests/refmpn.c: Likewise. + + * tests/tests.h: Unconditionally use for now. + + * tests/memory.c: Include "tests.h. + + * mp_get_fns.c: Add a __GMP_NOTHROW for coherency with prototype. + * mp_set_fns.c: Likewise. + * mpf/cmp.c: Likewise. + * mpf/cmp_si.c: Likewise. + * mpf/cmp_ui.c: Likewise. + * mpf/fits_s.h: Likewise. + * mpf/fits_u.h: Likewise. + * mpf/get_dfl_prec.c: Likewise. + * mpf/get_prc.c: Likewise. + * mpf/get_si.c: Likewise. + * mpf/get_ui.c: Likewise. + * mpf/int_p.c: Likewise. + * mpf/set_dfl_prec.c: Likewise. + * mpf/set_prc_raw.c: Likewise. + * mpf/size.c: Likewise. + * mpf/swap.c: Likewise. + * mpq/equal.c: Likewise. + * mpq/swap.c: Likewise. + * mpz/cmp.c: Likewise. + * mpz/cmp_si.c: Likewise. + * mpz/cmp_ui.c: Likewise. + * mpz/cmpabs.c: Likewise. + * mpz/cmpabs_ui.c: Likewise. + * mpz/cong_2exp.c: Likewise. + * mpz/divis_2exp.c: Likewise. + * mpz/fits_s.h: Likewise. + * mpz/get_si.c: Likewise. + * mpz/hamdist.c: Likewise. + * mpz/scan0.c: Likewise. + * mpz/scan1.c: Likewise. + * mpz/sizeinbase.c: Likewise. + * mpz/swap.c: Likewise. + * mpz/tstbit.c: Likewise. + * tal-reent.c: Likewise. + +2010-11-09 Torbjorn Granlund + + * configure.in: Get rid of K&R support. + * Makefile.am: Likewise. + * mpn/Makefile.am: Likewise. + * doc/configuration: Update docs wrt K&R support. + * doc/gmp.texi: Likewise. + + * configure.in (AC_INIT): Amend bug reporting address with manual + reference. + +2010-11-06 Torbjorn Granlund + + * config.guess: If cpuid says we have 32bit-only x86 but + configfsf.guess return x86_64, return the latter. + + * mpn/x86_64/aors_n.asm: Rewrite not to rely on ZF after 'bt' insn. + +2010-10-09 Torbjorn Granlund + + * mpn/generic/trialdiv.c: Update documentation. + +2010-10-04 Torbjorn Granlund + + * mpn/x86_64/gcd_1.asm: Use m4_lshift to avoid << operator. + * mpn/x86_64/aorrlshC_n.asm: Likewise. + * mpn/x86_64/pentium4/aorslshC_n.asm: Likewise. + * mpn/x86/k7/gcd_1.asm: Likewise. + +2010-08-20 Niels Möller + + Suggested by Ozkan Sezer: + * configure.in: If $M4 is already set in the environment, don't + touch it. Fixed the case that no assembler files are used, and + GMP_PROG_M4 is omitted. + +2010-08-08 Torbjorn Granlund + + * mpn/x86_64/fat/fat.c: Recognise many more processors. + +2010-06-30 Torbjorn Granlund + + * mpn/x86_64/divrem_2.asm: Tune. + +2010-06-19 Niels Möller + + * tune/speed.h (SPEED_ROUTINE_MPN_MOD_1_1): Pass normalized + divisor to the benchmarked function. + +2010-06-15 Torbjorn Granlund + + * mpn/x86_64/mod_1_1.asm (mpn_mod_1_1p_cps): Rewrite. + * mpn/x86_64/mod_1_2.asm (mpn_mod_1s_2p_cps): Rewrite. + * mpn/x86_64/mod_1_4.asm (mpn_mod_1s_4p_cps): Rewrite. + + * gmp-impl.h (udiv_rnd_preinv): Simplify. + + * mpn/x86/k7/mod_1_1.asm: New file. + * mpn/x86/pentium4/sse2/mod_1_1.asm (mpn_mod_1_1p_cps): Rewrite. + * mpn/x86/k7/mod_1_4.asm (mpn_mod_1s_4p_cps): Rewrite. + * mpn/x86/pentium4/sse2/mod_1_4.asm (mpn_mod_1s_4p_cps): Rewrite. + + * mpn/generic/mod_1_1.c (mpn_mod_1_1p_cps): Store results as they are + computed. + * mpn/generic/mod_1_2.c (mpn_mod_1s_2p_cps): Likewise. + * mpn/generic/mod_1_4.c (mpn_mod_1s_4p_cps): Likewise. + + * mpn/x86/k7/invert_limb.asm: Moved from mpn/x86/invert_limb.asm. + +2010-06-15 Niels Möller + + * tests/mpn/Makefile.am (check_PROGRAMS): Added t-mod_1. + * tests/mpn/t-mod_1.c: New file. + +2010-05-25 Torbjorn Granlund + + * mpn/generic/mu_div_qr.c (mpn_preinv_mu_div_qr_itch): Trim out space + for inverse, since that is passed in already. + +2010-05-24 Torbjorn Granlund + + * mpn/generic/mu_div_qr.c (mpn_preinv_mu_div_qr_itch): New function. + * gmp-impl.h: Declare it. + * tune/common.c (speed_mpn_mupi_div_qr): Use new itch function. + * tune/speed.h (SPEED_ROUTINE_MPN_MUPI_DIV_QR): Pass parameters right + for new itch function. + + * mpn/powerpc32/lshiftc.asm: New file. + +2010-05-22 Torbjorn Granlund + + * tune/tuneup.c (tune_mod_1): Revert to version of 2010-05-06. + +2010-05-17 Torbjorn Granlund + + * configure.in (ia64): Get 32-bit sizeof test right. + + * tune/tuneup.c (tune_mod_1): Undo unintensional change to tuning of + PREINV_MOD_1_TO_MOD_1_THRESHOLD. + +2010-05-16 Torbjorn Granlund + + * mpn/sparc64/mod_1.c: Rewrite. + * mpn/sparc64/sparc64.h (umul_ppmm_s): New macro. + * mpn/sparc64/mod_1_4.c: New file. + + * mpn/generic/divrem_1.c: Minor cleanup. + * mpn/generic/mod_1.c: Likewise. + * mpn/generic/mod_1_1.c: Likewise. + * mpn/generic/mod_1_2.c: Likewise. + * mpn/generic/mod_1_3.c: Likewise. + * mpn/generic/mod_1_4.c: Likewise. + + * configure.in (ia64-hpux): Do sizeof tests for 32-bit and 64-bit ABI. + + * tune/tuneup.c (tune_mod_1): Completely finish MOD_1_N tuning before + tuning MOD_1U_TO_MOD_1_1_THRESHOLD. + +2010-05-14 Torbjorn Granlund + + * mpn/generic/redc_2.c: Use asm code just for GNU C. + +2010-05-13 Torbjorn Granlund + + * mpn/sparc64/ultrasparc1234: New directory. Move all code that uses + floating-point into this directory. + * configure.in: Point to ultrasparc1234 for appropriate CPUs. + + * mpn/sparc64/ultrasparct1/add_n.asm: New file. + * mpn/sparc64/ultrasparct1/addlsh2_n.asm: New file. + * mpn/sparc64/ultrasparct1/addmul_1.asm: New file. + * mpn/sparc64/ultrasparct1/lshift.asm: New file. + * mpn/sparc64/ultrasparct1/mul_1.asm: New file. + * mpn/sparc64/ultrasparct1/rsblsh2_n.asm: New file. + * mpn/sparc64/ultrasparct1/rshift.asm: New file. + * mpn/sparc64/ultrasparct1/sublsh1_n.asm: New file. + * mpn/sparc64/ultrasparct1/sublshC_n.asm: New file. + * mpn/sparc64/ultrasparct1/addlsh1_n.asm: New file. + * mpn/sparc64/ultrasparct1/addlshC_n.asm: New file. + * mpn/sparc64/ultrasparct1/lshiftc.asm: New file. + * mpn/sparc64/ultrasparct1/rsblsh1_n.asm: New file. + * mpn/sparc64/ultrasparct1/rsblshC_n.asm: New file. + * mpn/sparc64/ultrasparct1/sub_n.asm: New file. + * mpn/sparc64/ultrasparct1/sublsh2_n.asm: New file. + * mpn/sparc64/ultrasparct1/submul_1.asm: New file. + * mpn/sparc64/ultrasparct1/gmp-mparam.h: New file. + + * configure.in: Give ultrasparct1 and ultrasparct2 special code path. + + * mpn/x86_64/pentium4/gmp-mparam.h: Disable mpn_addlsh_n, mpn_rsblsh_n. + +2010-05-12 Niels Möller + + * mpz/jacobi.c (mpz_jacobi): Fixed off-by-one error in use of + scratch space. + + * tune/common.c (speed_mpz_powm_sec): New function. + * tune/speed.h: Declare speed_mpz_powm_sec. + * tune/speed.c (routine): Added speed_mpz_powm_sec. + + * tune/common.c (speed_mpn_addlsh_n, speed_mpn_sublsh_n) + (speed_mpn_rsblsh_n): New functions. + * tune/speed.h: Declare new functions. + * tune/speed.c (routine): Add new functions. + +2010-05-12 Torbjorn Granlund + + * mpn/x86_64/mod_1_4.asm: Tune for more processors. + + * mpn/x86_64/pentium4/lshiftc.asm: New file. + +2010-05-11 Niels Möller + + * mpz/jacobi.c (mpz_jacobi): Deleted old implementation. + Reorganized new implementation, to handle small inputs efficiently. + + * tests/mpz/t-jac.c (check_large_quotients): Reduced test sizes. + (check_data): One more input pair related to a fixed bug. + (main): Enable check_large_quotients. + +2010-05-10 Torbjorn Granlund + + * mpn/x86_64/aorrlsh2_n.asm: Fix typo. + +2010-05-09 Torbjorn Granlund + + * mpn/x86_64/aorrlshC_n.asm: New file based on aorrlsh2_n.asm. + * mpn/x86_64/aorrlsh2_n.asm: Now just include aorrlshC_n.asm. + * mpn/x86_64/core2/aorrlsh1_n.asm: New file, include ../aorrlshC_n.asm. + * mpn/x86_64/core2/aorrlsh2_n.asm: Likewise. + + * mpn/x86_64/core2/sublshC_n.asm: New file based on aorslsh1_n.asm. + * mpn/x86_64/core2/aorslsh1_n.asm: Remove. + * mpn/x86_64/core2/sublsh1_n.asm: Just include sublshC_n.asm. + * mpn/x86_64/core2/sublsh2_n.asm: Likewise. + +2010-05-08 Torbjorn Granlund + + * mpn/x86_64/atom/gmp-mparam.h: Disable mpn_rsh1add_n, mpn_rsh1sub_n. + + * mpn/x86_64/pentium4/aorslshC_n.asm: New file based on aorslsh1_n.asm. + * mpn/x86_64/pentium4/aorslsh1_n.asm: Now just include aorslshC_n.asm. + * mpn/x86_64/pentium4/aorslsh2_n.asm: New file. + +2010-05-07 Torbjorn Granlund + + * mpn/sparc64: Support operands of >= 2^32 limbs. + + * mpn/sparc64/lshiftc.asm: New file. + + * mpn/ia64/divrem_2.asm: Complete rewrite. + +2010-05-06 Torbjorn Granlund + + * tune/tuneup.c (all): Don't call tune_divrem_2. + + * mpn/generic/divrem_2.c: Complete rewrite. + + * tune/tuneup.c (tune_mod_1): Fix typo. + +2010-05-05 Torbjorn Granlund + + * mpn/x86_64/mod_1_1.asm (mpn_mod_1_1p): Use macro register names. + (mpn_mod_1_1p_cps): Rewrite. + + * mpn/generic/mod_1_1.c (mpn_mod_1_1p_cps): Micro-optimise. + + * longlong.h: Undo 2009-03-01 change for powerpc64, it gives poor code. + + * mpn/x86/pentium4/sse2/mod_1_1.asm: New file. + + * mpn/powerpc64/mode64/mod_1_1.asm: New file. + + * tune/tuneup.c (tune_mod_1): Use more typical divisor, for the benefit + of machines with early-out multipliers. + +2010-05-04 Torbjorn Granlund + + * tune/tuneup.c (tune_mod_1): Fix typo. + + * mpn/generic/mod_1_1.c: Undo last change. + * mpn/x86_64/mod_1_1.asm: Likewise. + +2010-05-03 Niels Möller + + * mpn/generic/jacobi_lehmer.c (jacobi_hook): New function. + (mpn_jacobi_subdiv_step): Deleted function. + (mpn_jacobi_lehmer): Use general mpn_gcd_subdiv_step. + + * mpn/generic/gcd_subdiv_step.c (mpn_gcd_subdiv_step): Reorganized + to use a single hook function. + * mpn/generic/gcdext.c (mpn_gcdext): Adapted to new hook + interface. + * mpn/generic/gcdext_lehmer.c (mpn_gcdext_hook): New unified hook + function. + * mpn/generic/gcd.c (gcd_hook): Renamed from gcd_done, and adapted + to new hook interface. + * gmp-impl.h (gcd_subdiv_step_hook): New typedef, now a function + type, not a struct. + (mpn_gcdext_hook): Declare. + +2010-05-03 Torbjorn Granlund + + * mpn/generic/mod_1_1.c: Avoid multiply for 2 limb feed-in. + * mpn/generic/mod_1_2.c: Likewise. + * mpn/generic/mod_1_3.c: Likewise. + * mpn/generic/mod_1_4.c: Likewise. + * mpn/x86_64/mod_1_1.asm: Likewise. + * mpn/x86_64/mod_1_2.asm: Likewise. + * mpn/x86_64/mod_1_4.asm: Likewise. + * mpn/x86/k7/mod_1_4.asm: Likewise. + * mpn/x86/pentium4/sse2/mod_1_4.asm: Likewise. + * mpn/alpha/ev6/mod_1_4.asm: Likewise. + + * tune/tuneup.c (tune_mod_1): Measure MOD_1_1_TO_MOD_1_2_THRESHOLD and + MOD_1_2_TO_MOD_1_4_THRESHOLD before MOD_1U_TO_MOD_1_1_THRESHOLD for + correctness. + + * mpn/powerpc64/sqr_diagonal.asm: Complete rewrite. + + * mpn/powerpc64/mode64/mod_1_4.asm: New file. + +2010-05-02 Torbjorn Granlund + + * config.guess: Recognise power7. + + * configure.in: Major overhaul of powerpc support. + + * mpn/powerpc64/p6/lshift.asm: New file. + * mpn/powerpc64/p6/lshiftc.asm: Likewise. + * mpn/powerpc64/p6/rshift.asm: Likewise. + +2010-04-30 Torbjorn Granlund + + * configure.in (powerpc64): Support CPU specific mode-less subdirs. + + * mpn/powerpc64/aix.m4 (PROLOGUE_cpu): Use "named csect" making + requested alignment actually honoured. + +2010-04-30 Niels Möller + + * mpn/generic/jacobi_lehmer.c (mpn_jacobi_2): Fixed handling of + the case bl == 1. Fixed missing application of reciprocity. + +2010-04-29 Niels Möller + + * configure.in (gmp_mpn_functions): Deleted gcdext_subdiv_step. + + * mpn/generic/gcdext.c (mpn_gcdext): Use new generalized + mpn_gcd_subdiv_step. + + * mpn/generic/gcdext_lehmer.c (gcdext_update): New function. + (gcdext_done): New function. + (gcdext_hook): New const hook struct. + (mpn_gcdext_lehmer_n): Use new generalized mpn_gcd_subdiv_step. + + * mpn/generic/gcd.c (gcd_done): New function. + (gcd_hook): New const hook struct. + (mpn_gcd): Adapted to new mpn_gcd_subdiv_step interface. + + * mpn/generic/gcd_subdiv_step.c (mpn_gcd_subdiv_step): Reorganized + function. Added hook function pointers to the argument list, so + the same function can be used for gcd, gcdext, and jacobi. + + * gmp-impl.h (struct gcd_subdiv_step_hook): New struct. + (mpn_gcdext_subdiv_step): Deleted prototype. + (struct gcdext_ctx): New struct. + (gcdext_hook): Declare const struct. + (mpn_gcd_subdiv_step): Updated prototype. + + * mpn/generic/gcdext_subdiv_step.c: Deleted file. + +2010-04-28 Torbjorn Granlund + + * mpn/powerpc64/lshift.asm: Rewrite. + * mpn/powerpc64/rshift.asm: Likewise. + * mpn/powerpc64/mode64/lshiftc.asm: New file. + + * mpn/powerpc64/aix.m4: Align functions to 32-byte boundary. + * mpn/powerpc64/darwin.m4: Likewise. + * mpn/powerpc64/elf.m4: Likewise. + +2010-04-28 Niels Möller + + * tests/mpz/t-jac.c (check_data): Added some more test cases. + + * mpn/generic/jacobi_lehmer.c (mpn_jacobi_2): Bugfix, count + trailing zeros, not leading. + +2010-04-27 Torbjorn Granlund + + * mpn/powerpc64/mode64/p6/mul_basecase.asm: New file. + +2010-04-23 Niels Möller + + * gmp-impl.h (MPN_GCD_LEHMER_N_ITCH): Deleted. + (mpn_gcd_lehmer_n): Deleted declaration. + + * mpn/generic/gcd.c (gcd_2): Moved from gcd_lehmer.c. + (mpn_gcd): Inlined the code from mpn_gcd_lehmer_n. Also use + MPN_GCD_SUBDIV_STEP_ITCH rather than MPN_GCD_LEHMER_N_ITCH. + +2010-04-22 Torbjorn Granlund + + * mpn/powerpc64/mode64/bdiv_dbm1c.asm: Swap multiply insns to make them + consecutive, for the benefit of POWER6. + + * mpn/powerpc64/mode64/p6/gmp-mparam.h: New file. + +2010-04-21 Torbjorn Granlund + + * mpn/generic/gcd_lehmer.c: Deleted file. + + * mpn/powerpc64/mode64/divrem_1.asm: Swap multiply insns to make them + consecutive, for the benefit of POWER6. + * mpn/powerpc64/mode64/dive_1.asm: Likewise. + * mpn/powerpc64/mode64/divrem_2.asm: Likewise. + * mpn/powerpc64/mode64/mul_1.asm: Likewise. + * mpn/powerpc64/mode64/aorsmul_1.asm: Likewise. + + * mpn/powerpc64/mode64/aorslshC_n.asm: Swap ldx operands as a temporary + workaround for POWER6 pipeline glitch. + +2010-04-19 Niels Möller + + * mpz/jacobi.c (mpz_jacobi): New implementation using + mpn_jacobi_lehmer. Currently #if:ed out. + + * mpn/generic/jacbase.c (mpn_jacobi_base) + [JACOBI_BASE_METHOD < 4]: Support inputs with a >= b. + + * gmp-impl.h (mpn_jacobi_lehmer): Added prototype. + (jacobi_table): Declare. + (mpn_jacobi_init): New inline function. + (mpn_jacobi_finish): Likewise. + (mpn_jacobi_update): Likewise. + + * mpn/generic/jacobi_lehmer.c (mpn_jacobi_lehmer): New file, new + function. + + * configure.in (gmp_mpn_functions): Added jacobi_lehmer. + +2010-04-14 Niels Möller + + * configure.in (gmp_mpn_functions): Added + matrix22_mul1_inverse_vector. + * mpn/Makefile.am (nodist_EXTRA_libmpn_la_SOURCES): Added + matrix22_mul1_inverse_vector.c. + + * gmp-impl.h (mpn_matrix22_mul1_inverse_vector): Updated for + rename of mpn_matrix22_mul1_inverse_vector. + * mpn/generic/gcd_lehmer.c (mpn_gcd_lehmer_n): Likewise. + * mpn/generic/gcdext_lehmer.c (mpn_gcdext_lehmer_n): Likewise. + * mpn/generic/hgcd.c (hgcd_step): Likewise. + + * mpn/generic/matrix22_mul1_inverse_vector.c + (mpn_matrix22_mul1_inverse_vector): New file, function moved and + renamed... + * mpn/generic/hgcd2.c (mpn_hgcd_mul_matrix1_inverse_vector): + ...from here. + +2010-04-12 Torbjorn Granlund + + * tests/mpn/t-toom6h.c (SIZE_LOG): Define. + * tests/mpn/t-toom8h.c (SIZE_LOG): Likewise. + +2010-04-10 Torbjorn Granlund + + * mpn/ia64/lorrshift.asm: Rewrite feed-in and wind-down code. + + * mpn/ia64/aorslsh1_n.asm: Adapt to new aorslsh1_n. + * mpn/ia64/aorslsh1_n.asm: Likewise. + + * mpn/ia64/aors_n.asm: Complete rewrite. + * mpn/ia64/aorslsh1_n.asm: Likewise. + + * mpn/ia64/add_n_sub_n.asm: Misc cleanups. Add slotting comments. + + * mpn/ia64/lshiftc.asm: New file. + + * mpn/x86_64/pentium4/gmp-mparam.h: No longer disable rsh1add_n and + rsh1sub_n; instead disable rsblsh1_n, addlsh2_n, rsblsh2_n. + + * mpn/x86/divrem_2.asm: Use "orb" instead of "or" to work around + Solaris assembler bug. + * mpn/x86_64/mpn/x86_64/divrem_2.asm: Likewise. + + * mpn/x86/aors_n.asm: Use operand-less shift-by-1 insn form. + * mpn/x86/pentium/aors_n.asm: Likewise. + * mpn/x86_64/invert_limb.asm: Likewise. + + * mpn/x86_64/pentium4/aors_n.asm: Let non-nc code fall into nc code. + + * mpn/x86_64/pentium4/rsh1aors_n.asm: New file. + +2010-03-25 Torbjorn Granlund + + * mpn/ia64/add_n_sub_n.asm: New file. + + * mpn/generic/toom33_mul.c: Fix mpn_add_n_sub_n usage. + * mpn/generic/toom3_sqr.c: Likewise. + * mpn/generic/toom63_mul.c: Likewise. + + * mpn/generic/add_n_sub_n.c: Renamed from addsub_n.c. + +2010-03-23 Torbjorn Granlund + + * mpn/x86_64/divrem_2.asm: Use mpn_invert_limb instead of div insn. + + * mpn/ia64/aorslshC_n.asm: New file, generalised from last iteration of + aorslsh1_n.asm. + * mpn/ia64/aorslsh1_n.asm: Use aorslshC_n.asm. + * mpn/ia64/aorslsh1_n.asm: New file, use aorslshC_n.asm. + +2010-03-20 Torbjorn Granlund + + * mpn/powerpc64/mode64/invert_limb.asm: Rewrite to exploit cancellation + in the Newton iteration. + +2010-03-20 Marco Bodrato + + * mpn/generic/toom_interpolate_8pts.c: Use mpn_sublsh2_n. + +2010-03-20 Torbjorn Granlund + + * mpn/powerpc64/mode64/aorslshC_n.asm: New file, generalised from + last iteration of aorslsh1_n.asm. + * mpn/powerpc64/mode64/aorslsh1_n.asm: Use aorslshC_n.asm. + * mpn/powerpc64/mode64/aorslsh1_n.asm: New file, use aorslshC_n.asm. + +2010-03-19 Torbjorn Granlund + + * mpn/x86_64/nano/dive_1.asm: New file. + + * mpn/x86_64/divrem_1.asm: Avoid shld since it is slow on several CPU + types. Unconditionally provide code for normalised and unnormalised + divisors. Cleanup labels. + + * mpn/x86_64/core2/divrem_1.asm: Remove special code for normalised + divisors. Cleanup labels. + + * mpn/generic/toom_interpolate_6pts.c: Call mpn_sublsh2_n and + mpn_sublsh_n with correct args. + + * tests/devel/try.c: Use enum for TYPE_*. + + * tests/devel/try.c: Test mpn_sublsh2_n. + * tests/refmpn.c (refmpn_sublsh2_n): New function. + * tests/tests.h (refmpn_sublsh2_n): Declare. + + * mpn/powerpc64/mode64/aorslsh1_n.asm: New file, with faster + mpn_addlsh1_n and mpn_sublsh1_n. + * mpn/powerpc64/mode64/addlsh1_n.asm: Delete. + * mpn/powerpc64/mode64/sublsh1_n.asm: Delete. + +2010-03-18 Torbjorn Granlund + + * configure.in (*-*-aix): Define gcc_32_cflags_maybe, ar_32_flags and + nm_32_flags. + + * mpn/x86/pentium4/sse2/addlsh1_n.asm: Tune for slightly better speed. + Misc cleanups. Add cycle table. + + * mpn/x86_64/copyi.asm: Update cycle table. + * mpn/x86_64/copyd.asm: Likewise. + * mpn/x86_64/rsh1aors_n.asm: Likewise. + * mpn/x86_64/dive_1.asm: Likewise. + + * mpn/x86/pentium4/sse2/add_n.asm: Misc cleanups. Add cycle table. + * mpn/x86/pentium4/sse2/sub_n.asm: Likewise. + +2010-03-16 Torbjorn Granlund + + * mpn/x86_64/divrem_1.asm: Use mpn_invert_limb instead of div insn. + * mpn/x86_64/core2/divrem_1.asm: Likewise. + + * tune/speed.c (routine): Add FLAG_R_OPTIONAL for many binops. + +2010-03-15 Torbjorn Granlund + + * mpn/alpha/ev6/mod_1_4.asm (mpn_mod_1s_4p_cps): Rewrite. + + * mpn/ia64/aors_n.asm: Insert explicitly typed nops to trigger intended + bundling. + * mpn/ia64/aorslsh1_n.asm: Likewise. + * mpn/ia64/dive_1.asm: Likewise. + +2010-03-13 Torbjorn Granlund + + * mpn/x86/pentium4/sse2/submul_1.asm: Rewrite. + + * mpn/powerpc64/mode64/aorsmul_1.asm: New file, faster than old code + for both mpn_addmul_1 and mpn_submul_1. + * mpn/powerpc64/mode64/addmul_1.asm: Remove. + * mpn/powerpc64/mode64/submul_1.asm: Remove. + +2010-03-11 Niels Möller + + * mpn/generic/gcd_lehmer.c (gcd_2): Use sub_ddmmss. + + * mpn/generic/jacbase.c (mpn_jacobi_base): Reorganized the + JACOBI_BASE_METHOD 4 slightly. Now requires that b > 1. + +2010-03-10 Torbjorn Granlund + + * mpn/x86_64/divrem_1.asm: Make fraction code take documented # of + cycles. Annotate code for more CPUs. Misc cleanups. + * mpn/x86_64/core2/divrem_1.asm: Annotate code for more CPUs. + + * mpn/alpha/ev6/mod_1_4.asm: New file. + + * mpn/ia64/mod_34lsub1.asm: New file. + + * doc/gmp.texi (Language Bindings): Update Python site, add Ruby. + +2010-03-10 Niels Möller + + * tune/tuneup.c (tune_jacobi_base): Consider mpn_jacobi_base_4. + * tune/speed.c (routine): Added mpn_jacobi_base_4. + * tune/common.c (speed_mpn_jacobi_base_4): New function. + * tune/speed.h (speed_mpn_jacobi_base_4): Declare it. + * tune/Makefile.am (libspeed_la_SOURCES): Added jacbase4.c. + * tune/jacbase4.c: New file. + + * mpn/generic/jacbase.c (mpn_jacobi_base): New function, for + JACOBI_BASE_METHOD 4. + +2010-03-09 Niels Möller + + * tests/mpz/t-jac.c (check_large_quotients): Also generate inputs + with large quotients and a large gcd. + +2010-03-09 Marco Bodrato + + * tests/mpz/t-bin.c (randomwalk): New test-generator function. + +2010-03-07 Torbjorn Granlund + + * tune/speed.c (routine): Force r argument for several mod_1 calls. + +2010-03-06 Torbjorn Granlund + + * mpn/x86_64/divrem_1.asm: Disable SPECIAL_CODE_FOR_NORMALIZED_DIVISOR. + Misc clean up. + + * mpn/x86_64/mod_1_1.asm: New file. + * mpn/x86_64/mod_1_2.asm: New file. + * mpn/x86_64/mod_1_4.asm: Update cycle counts. + + * tests/tests.h (TESTS_REPS): Fix typo. + +2010-03-03 Torbjorn Granlund + + * mpn/x86_64/core2/divrem_1.asm: New file. + +2010-02-26 Niels Möller + + * tune/speed.c (routine): Added udiv_qrnnd_preinv3. + + * tune/common.c (speed_udiv_qrnnd_preinv3): New function. + * tune/speed.h: Added prototype for it. + +2010-02-26 Niels Möller + + * tests/mpz/t-jac.c (check_large_quotients): New test. Currently + disabled, since it's quite slow. + (mpz_nextprime_step): New function. + +2010-02-26 Torbjorn Granlund + + * mpn/pa64/aors_n.asm: Fix typo in last change. + +2010-02-25 Niels Möller + + * tests/mpz/t-jac.c (ref_jacobi): New reference implementation, + using factorization and legendre symbols computed by powm. + + * tests/devel/try.c (param_init, call): Don't pass negative values + for the second argument to mpz_jacobi and refmpz_jacobi. + + * tests/refmpz.c (refmpz_jacobi): Require that b is odd and positive. + + * tests/devel/try.c (param_init): Support mpz_legendre. + (choice_array): Added mpz_kronecker (apparently forgotten) and + mpz_legendre. + (call): Added TYPE_MPZ_LEGENDRE. + (try_one): Added support for DATA_SRC1_ODD_PRIME. + + * tests/refmpz.c (refmpz_legendre): Rewrote using powm. + +2010-02-25 Torbjorn Granlund + + * config.guess: Make "corei" default for unrecognised Intel P6 CPUs. + + * tests/mpz/t-perfpow.c (check_random): Use mp_limb_t type for limb + variables. + + * tests/mpn/t-toom6h.c (COUNT): Define. + * tests/mpn/t-toom8h.c (COUNT): Define. + + * tests/mpn/t-div.c: Cast a switch index to placate HP's cc. + * tests/mpn/t-bdiv.c: Likewise. + + * mpn/pa64/aors_n.asm: Fix support of the 2.0n ABI. + +2010-02-24 Marco Bodrato + + * tests/mpz/t-bin.c (data): Replace (2k,k), tested by twos (). + * tests/mpf/t-inp_str.c (data): Test also "+" in the exponent. + +2010-02-23 Torbjorn Granlund + + * mpn/generic/mod_1_3.c: Cast a switch index to placate HP's cc. + + * mpn/generic/sqrtrem.c: Use CNST_LIMB. + +2010-02-20 Niels Möller + + * tune/speed.h (mpn_gcd_accel): Deleted prototype. + (mpn_hgcd_lehmer): New prototype. + (MPN_HGCD_LEHMER_ITCH): New macro (previously in gmp-impl.h). + + * tune/Makefile.am (libspeed_la_SOURCES): Added hgcd_lehmer.c. + * tune/hgcd_lehmer.c: New file. + * tune/gcd_accel.c: Deleted obsolete file. + + * gmp-impl.h (MPN_HGCD_LEHMER_ITCH): Deleted macro. + + * mpn/generic/hgcd.c (mpn_hgcd_lehmer): Deleted function, + (mpn_hgcd): Don't call mpn_hgcd_lehmer, instead use inlined loop + around hgcd_step. + (mpn_hgcd_itch): Substitute n for MPN_HGCD_LEHMER_ITCH (n). + +2010-02-19 Niels Möller + + * Makefile.am (mpn/jacobitab.h): Added the rules needed to + generate this file. + + * gen-jacobitab.c: New file. + +2010-02-19 Torbjorn Granlund + + * mpn/generic/powm.c: Honour SQR_BASECASE_THRESHOLD in innerloop + expansions. + +2010-02-16 Niels Möller + + * tune/time.c (cgt_works_p): Added rudimentary sanity check for + clock_gettime working. + +2010-02-15 Niels Möller + + * tune/time.c (speed_time_init): Make use of cycle counter + configurable, via the speed_option_cycles_broken flag. + * tune/common.c (speed_option_cycles_broken): New global variable. + (speed_option_set): Recognize option "cycles-broken". + + * tune/time.c (cycles_works_p): Deleted hack to disable cycle + counter on linux. Needs to be replaced by something more + selective. + +2010-02-11 Niels Möller + + * tune/time.c (speed_time_init): Fix speed_time_string when using + clock_gettime. + (cycles_works_p): On linux, don't use the cycle counter. + + * tune/Makefile.am: Add $(TUNE_LIBS) when linking programs. + + * configure.in: Check if -lrt is needed for clock_gettime, and if + so, add that flag to TUNE_LIBS. + +2010-02-07 Torbjorn Granlund + + * tune/tuneup.c (tune_redc): Set min_size and min_is_always when + measuring REDC_1_TO_REDC_2_THRESHOLD. + (tune_mod_1): Set min_size for PREINV_MOD_1_TO_MOD_1_THRESHOLD. + + * mpn/x86_64/aorrlsh_n.asm (cnt): Fix a typo. + * mpn/x86_64/lshsub_n.asm: Likewise. + +2010-02-05 Torbjorn Granlund + + * Version 5.0.1 released. + + * mpn/generic/powm.c: Use rp target area for power table computation in + order to use less scratch. + + * mpn/generic/binvert.c (mpn_binvert_itch): Enable more economical + mpn_mulmod_bnm1_itch call. + + * mpn/generic/mu_div_qr.c: Remove always true #if. + * mpn/generic/mu_divappr_q.c: Likewise. + * mpn/generic/mu_bdiv_q.c: Likewise. + * mpn/generic/mu_bdiv_qr.c: Likewise. + +2010-02-01 Torbjorn Granlund + + * Makefile.am (LIBGMP_LT_*, LIBGMPXX_LT_*, LIBMP_LT_*): + Bump version info. + + * mpn/powerpc64/mode64/gmp-mparam.h: Remove {MUL,SQR}_FFT_TABLE2. + * mpn/x86/p6/gmp-mparam.h: Likewise. + * mpn/x86/p6/mmx/gmp-mparam.h: Likewise. + * mpn/generic/mul_fft.c: Don't depend on FFT_TABLE2, it was broken. + +2010-01-29 Torbjorn Granlund + + * mpn/generic/mul_fft.c (mpn_mul_fft_internal): Remove arguments n, m, + k and rec; add argument sqr. Don't call mpn_mul_fft_decompose here, + instead do that in all callers. + (mpn_mul_fft): Trim allocation when squaring, and use TMP_ALLOC*, not + explicit alloc/free. + (mpn_fft_div_2exp_modF): Avoid a scalar division. + (mpn_fft_mul_modF_K): Replace some multiplies by K with shifting by k. + (mpn_fft_mul_2exp_modF): Make function more symmetrical. + +2010-01-27 Torbjorn Granlund + + * mpn/generic/mu_div_q.c (mpn_mu_div_q_itch): Rewrite. + * mpn/generic/mu_div_qr.c (mpn_mu_div_qr_itch): Re-enable + better mulmod itch estimate. + * mpn/generic/mu_divappr_q.c (mpn_mu_divappr_q_itch): Likewise. + * mpn/generic/mu_bdiv_qr.c (mpn_mu_bdiv_qr_itch): Likewise. + * mpn/generic/mu_bdiv_q.c (mpn_mu_bdiv_q_itch): Likewise. + +2010-01-27 Marco Bodrato + + * mpn/generic/mu_div_qr.c (mpn_mu_div_qr_itch): Disabled guessed + estimate, enabled a conservative one. + * mpn/generic/mu_divappr_q.c (mpn_mu_divappr_q_itch): Likewise. + * mpn/generic/mu_bdiv_qr.c (mpn_mu_bdiv_qr_itch): Likewise. + * mpn/generic/mu_bdiv_q.c (mpn_mu_bdiv_q_itch): Likewise. + +2010-01-26 Marco Bodrato + + * mpn/generic/mulmod_bnm1.c (mpn_mulmod_bnm1): Partial rewrite to + reduce memory usage. + * mpn/generic/sqrmod_bnm1.c (mpn_sqrmod_bnm1): Likewise. + (mpn_sqrmod_bnm1_next_size): New function. + + * gmp-impl.h (mpn_mulmod_bnm1_itch): Accepts 3 parameters now. + (mpn_sqrmod_bnm1_itch): New inline function. + (mpn_sqrmod_bnm1_next_size): Declaration and mangling. + * mpn/generic/nussbaumer_mul.c: Use the new functions. + + * mpn/generic/invertappr.c (mpn_ni_invertappr): Use new syntax for + mpn_mulmod_bnm1_itch. + * mpn/generic/mu_divappr_q.c (mpn_mu_divappr_q_itch): Likewise. + * mpn/generic/mu_bdiv_qr.c (mpn_mu_bdiv_qr_itch): Likewise. + * mpn/generic/mu_bdiv_q.c (mpn_mu_bdiv_q_itch): Likewise. + * mpn/generic/mu_div_qr.c (mpn_mu_div_qr_itch): Likewise. + * mpn/generic/binvert.c (mpn_binvert_itch): Likewise. + * tune/speed.h (SPEED_ROUTINE_MPN_MULMOD_BNM1_CALL): Likewise. + (SPEED_ROUTINE_MPN_MULMOD_BNM1_ROUNDED): Likewise. + + * tests/mpn/t-sqrmod_bnm1.c, tests/mpn/t-mulmod_bnm1.c: Test + reduced memory usage. + +2010-01-25 Torbjorn Granlund + + * tune/tuneup.c (INSERT_FFTTAB): New macro, like old insertion code but + also inserting a sentinel. + (fftmes): Use INSERT_FFTTAB for inserting new measurements. + Limit k range to best_k - 4 ... best_k + 4. + +2010-01-23 Torbjorn Granlund + + * gmp-h.in (__GNU_MP_VERSION_PATCHLEVEL): Bump. + (__GMP_MP_RELEASE): New macro. + + * mpf/div.c: Rewrite to use mpn_div_q. + +2010-01-21 Torbjorn Granlund + + * Add FFT_TABLE3 tables for a basic set of machines. + + * configure.in: Use -mtune=nocona for 64-bit pentium4. + + * config.guess: Recognise many more Intel processors. + + * tune/common.c: Whitespace cleanup. + (speed_mpn_matrix22_mul): Rewrite. + +2010-01-21 Niels Möller + + * mpn/generic/nussbaumer_mul.c (mpn_nussbaumer_mul): Take + advantage of new mpn_mulmod_bnm1 interface, to reduce allocation. + + * tests/mpn/t-mulmod_bnm1.c (ref_mulmod_bnm1, main): Adapted to + mpn_mulmod_bnm1 interface change. + + * mpn/generic/mulmod_bnm1.c (mpn_mulmod_bnm1): Interface change, + in case an + bn < rn, only write an + bn output limbs. New input + requirement, an + bn > rn/2. + * mpn/generic/sqrmod_bnm1.c (mpn_sqrmod_bnm1): Corresponding + changes. + +2010-01-19 Torbjorn Granlund + + * tune/tuneup.c (fftmes): Round up initial n according to initial k. + Limit k to 24 in loop. Remove an obsolete always-true condition. + Remove a redundant trace printout. + +2010-01-18 Torbjorn Granlund + + * tune/tuneup.c (fftmes): New function + (fft): Rewrite. + (mpn_mul_fft_lcm): New function, copied from mpn/generic/mul_fft.c. + (fftfill): New function, code taken from mul_fft.c (mpn_mul_fft). + (cached_measure): New function. + + * gmp-impl.h (struct fft_table_nk): Moved from mul_fft.c. + (MUL_FFT_TABLE3, SQR_FFT_TABLE3): Provide dummy versions for tuneup + builds. + (FFT_TABLE3_SIZE): Increase value for tuneup builds. + + * mpn/generic/mul_fft.c: Handle a new FFT threshold table type ("3"). + Misc cleanups to old table type code. + +2010-01-16 Torbjorn Granlund + + * mpn/x86_64/darwin.m4: Fix typo in last change. + +2010-01-15 Torbjorn Granlund + + * gmp-h.in (__GMP_EXTERN_INLINE): Remove "extern" for newer Sun C. + + * gmp-impl.h (GMP_LIMB_BYTES): New define. + + * mpn/x86_64/darwin.m4 (LEA): New define. + + * mpn/x86/invert_limb.asm (approx_tab): Use DEF_OBJECT. + Rename and globalise it to work around Mac OS bug. + + With Philip McLaughlin: + * mpn/x86_64/gcd_1.asm (ctz_table): Don't use local prefix, but + use DEF_OBJECT...END_OBJECT. + Keep stack pointer at ABI mandated alignment over call. + +2010-01-12 Torbjorn Granlund + + * tune/speed.c (routine): Remove obsolete mpn_dc_tdiv_qr and + mpn_dc_div_qr_n. + * tune/common.c (speed_mpn_dc_tdiv_qr, speed_mpn_dcpi1_div_qr_n): + Remove now unused functions. + * tune/speed.h (SPEED_ROUTINE_MPN_DC_DIVREM_N, + SPEED_ROUTINE_MPN_DC_DIVREM_SB, SPEED_ROUTINE_MPN_DC_TDIV_QR): Remove + now unused macros. + + * mpn/x86_64/fat/fat_entry.asm (mpn_cpuid_available): Remove function. + + * ltmain.sh: Upgrade from 1.5.24 to 2.2.6b. + * ylwrap: New file. + * .bootstrap: Remove explicit versions. + + * doc/gmp.texi (Block-wise Barrett Division): New node. + + * mpn/generic/powm.c: Change some #if to plain 'if' to avoid fat build + problems. + +2010-01-11 Torbjorn Granlund + + * tune/speed.h (SPEED_ROUTINE_MPN_PI1_DIV): Accept arguments for size + restrictions. + * tune/common.c (speed_mpn_sbpi1_div_qr, speed_mpn_dcpi1_div_qr, + (speed_mpn_sbpi1_divappr_q, speed_mpn_dcpi1_divappr_q): Pass size + limits for SPEED_ROUTINE_MPN_PI1_DIV. + + * tune/speed.c (routine): Allow .r argument for mpn_sbpi1_divappr_q and + mpn_dcpi1_divappr_q. + +2010-01-08 Torbjorn Granlund + + * Version 5.0.0 released. + + * mpn/generic/div_q.c: Handle mpn_*_divappr_q returning high limb + everywhere. + +2010-01-07 Torbjorn Granlund + + * Update MUL_FFT_TABLE2 and SQR_FFT_TABLE2 for many machines. + + * mpn/generic/mu_div_q.c: Account for divisor truncation error as well + as mpn_mu_divappr_q's error. + + * mpn/generic/mu_div_q.c: Handle mpn_preinv_mu_divappr_q returning a + high limb. + + * tests/mpn/t-bdiv.c: Move a random call for debugability. + * tests/mpn/t-div.c: Likewise. + + * mpn/generic/mu_divappr_q.c: Rewrite quotient round-up code. + + * mpn/generic/mu_div_qr.c: Handle carry-out from a carry propagation + subtract. + * mpn/generic/mu_divappr_q.c: Likewise. + + * mpn/generic/mu_divappr_q.c + (mpn_preinv_mu_divappr_q, mpn_mu_divappr_q): Declare dividend constant. + * gmp-impl.h: Likewise. + + * perfpow.c (mpn_perfect_power_p): Call mpn_divexact instead of + mpn_bdiv_q (with too little scratch space!). + + From Niels Möller: + * tests/mpn/t-div.c (check_one): Get rid of the poorly managed variable + tn. + + * mpn/minithres/gmp-mparam.h: Add all lately defined thresholds. + + * mpn/generic/div_q.c: Use SB division for small quotients as well as + small divisors. Fix typo in itch call. + +2010-01-06 Niels Möller + + * tests/mpn/t-div.c (check_one): Checking based on multiplication, + refmpn_mul, rather than refmpn_tdiv_qr. + +2010-01-06 Marco Bodrato + + * mpn/generic/toom8h_mul.c: Avoid overflows of mp_size_t. + +2010-01-06 Torbjorn Granlund + + * gmp-h.in (__GNU_MP__): Bump. + (__GNU_MP_VERSION,__GNU_MP_VERSION_MINOR,__GNU_MP_VERSION_PATCHLEVEL): + Bump version info. + * mp-h.in (__GNU_MP__): Bump. + * Makefile.am (LIBGMP_LT_*, LIBGMPXX_LT_*, LIBMP_LT_*): + Bump version info. + + * doc/gmp.texi: Rewrite mpn_gcdext text. Remove some out-of-date + text in Algorithms chapter. + + * mpn/generic/div_q.c: Properly handle np=scratch. Fix critical typo + in final adjustment code. Misc cleanups. + + * mpn/generic/rootrem.c: Use mpn_div_q. + * mpz/tdiv_q.c: Likewise. + + * tests/mpn/t-div.c: Test mpn_div_q. + (SIZE_LOG): Up to 17. + + * mpn/generic/div_q.c: New file. + * configure.in (gmp_mpn_functions): Add div_q. + + * mpn/generic/mu_div_q.c: Actually declare dividend constant. + +2010-01-04 Torbjorn Granlund + + * tune/tuneup.c (fft): Separate tuning of modf and full products. + (struct fft_param_t): New field, mul_modf_function. + (tune_fft_sqr): Fix typo. + (tune_fft_mul, tune_fft_sqr): Initialise mul_modf_function field. + * tune/common.c (speed_mpn_fft_mul, speed_mpn_fft_sqr): New functions. + + * tune/speed.h (SPEED_ROUTINE_MPN_MULMOD_BNM1_ROUNDED): Clean up. + + * mpn/generic/mul.c: Simplify rational expression. + + * gmp-impl.h: Cleanup threshold variables; remove obsolete ones and + make all possibly needed definitions for existing ones. + * tune/tuneup.c (tune_mul): Write fractions-compensated values to + threshold variables. + +2010-01-03 Marco Bodrato + + * tune/common.c, tune/speed.c, tune/speed.h: Support measuring + mpn_toom43_mul. + + * mpn/generic/toom_interpolate_6pts.c: Small reorganisation. + +2010-01-03 Torbjorn Granlund + + * gmp-impl.h (MUL_TO_MULMOD_BNM1_FOR_2NXN_THRESHOLD): Default to + INV_MULMOD_BNM1_THRESHOLD/2 instead. + + * gmp-impl.h (INV_APPR_THRESHOLD, INV_MULMOD_BNM1_THRESHOLD): Default + here... + * mpn/generic/invert.c, mpn/generic/invertappr.c: ...not here. + + * tests/mpn/t-div.c: Rewrite operand generation code. + +2010-01-02 Torbjorn Granlund + + * gmp-impl.h (MUL_TO_MULMOD_BNM1_FOR_2NXN_THRESHOLD): Default to + INV_MULMOD_BNM1_THRESHOLD. + +2010-01-02 Marco Bodrato + + * mpn/generic/dcpi1_div_q.c: Handle divappr approximation problem more + efficiently. + * mpn/generic/mu_div_q.c: Likewise. + + * mpn/generic/invert.c: Remove duplicated code. + +2010-01-01 Torbjorn Granlund + + * gmp-impl.h (MUL_TO_MULMOD_BNM1_FOR_2NXN_THRESHOLD): Default to 0. + + * mpn/generic/mu_div_qr.c: Rewrite to use mpn_mulmod_bnm1. Clean up + scratch usage. Improve itch functions. + * mpn/generic/mu_divappr_q.c: Likewise. + * mpn/generic/mu_bdiv_qr.c: Likewise. + * mpn/generic/mu_div_q.c: Likewise. + + * mpn/generic/dcpi1_bdiv_qr.c: Add parameter ASSERTs. + * mpn/generic/dcpi1_bdiv_q.c: Likewise. + + * tests/mpn/t-bdiv.c: Replace with unit testing code, based on t-div.c. + Increase COUNT to 500. + + * tests/mpn/t-div.c: Avoid generating too small test operands. + Move SB suppression limit downwards. Increase COUNT to 200. + +2009-12-31 Torbjorn Granlund + + * mpn/generic/tdiv_qr.c: Handle numerator/remainder overlap in MU case. + + * tests/tests.h (TESTS_REPS): New macro. + * tests/mpz/dive.c: Use larger operands, decrease default reps, use + TESTS_REPS. + * tests/mpz/convert.c: Likewise. + * tests/mpz/t-sqrtrem.c: Likewise. + * tests/mpz/reuse: Likewise. + * tests/mpz/t-root.c: Likewise. + * tests/mpz/t-tdiv.c: Likewise. + * tests/mpz/t-gcd.c: Likewise. + * tests/mpz/t-powm.c: Likewise. + +2009-12-31 Marco Bodrato + + * mpn/generic/toom8_sqr.c (SQR_TOOM8_MAX): Avoid overflow. + * mpn/generic/toom6_sqr.c (SQR_TOOM6_MAX): Likewise. + + * mpn/generic/mulmod_bnm1.c: Don't mention MISUSE any more, + simply consider UNLIKELY any unexpected size. + +2009-12-31 Torbjorn Granlund + + * tune/tuneup.c (speed_mpn_sbordcpi1_div_qr): New function. + (tune_mu_div): Use it. + +2009-12-30 Torbjorn Granlund + + * tune/tuneup.c (tune_mu_bdiv, tune_dc_bdiv, tune_mu_div) + (tune_dc_div): Clear global s.r to make speed functions do 2n/n. + + * tune/speed.c (routine): New entries for mpn_mu_div_qr and + mpn_mupi_div_qr. Allow .r parameter for mpn_sbpi1_div_qr, + mpn_dcpi1_div_qr. + * tune/speed.h (SPEED_ROUTINE_MPN_PI1_DIV, SPEED_ROUTINE_MPN_MU_DIV_QR) + (SPEED_ROUTINE_MPN_MUPI_DIV_QR): Handle .r parameter. + + * tests/mpz/t-tdiv.c: Increase operands size again. + + * mpn/generic/tdiv_qr.c: Attempt to choose between DC and MU cleverer. + + * mpn/generic/tdiv_qr.c: Don't overwrite rp with unnecessary temporary + alloc. + +2009-12-29 Torbjorn Granlund + + * tune/tuneup.c (tune_mu_div): Tune MUPI_DIV_QR_THRESHOLD. + * tune/speed.h (struct speed_params): Allow 3 source operands. + (SPEED_ROUTINE_MPN_MUPI_DIV_QR): New macro. + * tune/common.c (speed_mpn_mupi_div_qr): New function. + + * mpn/generic/tdiv_qr.c: Call mpn_mu_div_qr. + + * tests/mpz/t-tdiv.c: Use larger test operands. + + * mpn/generic/mu_div_qr.c (mpn_mu_div_qr2): Remove code for dn==1. + + * mpz/mul.c: Call mpn_sqr directly. Use PTR,SIZ,ALLOC. + + * tune/tuneup.c (tune_mu_div): Set min_size to 6, DC functions require + this. + + * tests/mpn/t-div.c: Call mu_div functions with operands that generate + a high quotient limb. + + * mpn/generic/mu_div_qr.c: Rewrite to return a high quotient limb, + to let dividend argument be constant, and as a general cleanup. + * mpn/generic/mu_divappr_q.c: Likewise. + * mpn/generic/mu_div_q.c: Likewise. + * gmp-impl.h: Update declarations of changed functions. + + * mpn/generic/invertappr.c (mpn_invertappr): Allocate scratch space + when caller passed NULL. + +2009-12-28 Torbjorn Granlund + + * mpn/generic/toom_couple_handling.c: Prefix name with mpn_. + * gmp-impl.h: Likewise. + * mpn/generic/toom63_mul.c: Likewise. + * mpn/generic/toom6_sqr.c: Likewise. + * mpn/generic/toom6h_mul.c: Likewise. + * mpn/generic/toom8_sqr.c: Likewise. + * mpn/generic/toom8h_mul.c: Likewise. + + * configure.in (gmp_mpn_functions_optional) Move "com" from here... + (gmp_mpn_functions): ...to here. + * mpn/generic/com.c: New file. + * (mpn_com): New name for mpn_com_n. Make public. + * (mpn_neg): Analogous changes. + + * tune/tuneup.c (tune_mu_div, tune_mu_bdiv): Set step_factor. + + * tune/common.c, tune/speed.c, tune/speed.h: Support measuring + mpn_lshiftc. + + * tests/devel/try.c: Test mpn_lshiftc. + * tests/refmpn.c (refmpn_com): New function. + (refmpn_lshiftc): Likewise. + + * configure.in (gmp_mpn_functions_optional) Move lshiftc from here... + (gmp_mpn_functions): ...to here. + * mpn/generic/lshiftc.c: New file. + * mpn/x86_64/lshiftc.asm: New file. + * mpn/x86_64/core2/lshiftc.asm: New file. + * mpn/generic/mul_fft.c (mpn_lshiftc): Remove. + + * mpn/x86_64/core2/lshift.asm: Tweak for better Core iN performance. + * mpn/x86_64/core2/rshift.asm: Likewise. + +2009-12-27 Marco Bodrato + + * mpn/generic/mul.c: Use toom6h and toom8h for almost balanced. + + * mpn/generic/mullo_n.c (mpn_dc_mullo_n): New ratio, to be used in + Toom-8 range. + +2009-12-27 Torbjorn Granlund + + * (mpn_sqr): New name for mpn_sqr_n. Many files affected. + + * tune/tuneup.c (tune_mullo): Up step_factor for MULLO_MUL_N_THRESHOLD. + (tune_invertappr, tune_invert, tune_binvert): Let max_size default. + + * tune/tuneup.c (tune_mu_div, tune_mu_bdiv) New functions. + * tune/speed.h (SPEED_ROUTINE_MPN_MU_DIV_Q): New macro. + (SPEED_ROUTINE_MPN_MU_DIV_QR): Likewise. + (SPEED_ROUTINE_MPN_MU_BDIV_Q): Likewise. + (SPEED_ROUTINE_MPN_MU_BDIV_QR): Likewise. + * tune/Makefile.am (TUNE_MPN_SRCS_BASIC): Add bdiv_q.c and bdiv_qr.c. + * tune/common.c (speed_mpn_mu_div_qr): New function. + (speed_mpn_mu_divappr_q): Likewise. + (speed_mpn_mu_div_q): Likewise. + (speed_mpn_mu_bdiv_q): Likewise. + (speed_mpn_mu_bdiv_qr): Likewise. + + * mpn/*/gmp-mparam.h: Fix incorrect MOD_1U_TO_MOD_1_1_THRESHOLD 0 + values. + + * gmp-impl.h (MODEXACT_1_ODD_THRESHOLD): Remove. + (BMOD_1_TO_MOD_1_THRESHOLD): New parameter, with the reverse meaning of + MODEXACT_1_ODD_THRESHOLD. + (MPN_MOD_OR_MODEXACT_1_ODD): Use BMOD_1_TO_MOD_1_THRESHOLD. + * mpn/generic/divis.c, mpz/{cong.c,cong_ui.c,divis_ui.c}: Likewise. + * tune/tuneup.c (tune_modexact_1_odd): Tune BMOD_1_TO_MOD_1_THRESHOLD; + Do not assume native mpn_modexact_1_odd is faster than mpn_mod_1. + (tuned_speed_mpn_mod_1): Remove variable. + (tune_mod_1): Fix thinkos. Suppress printing of "always" etc. + (all): Measure for divrem_1, mod_1, divexact_1, etc first, since Toom + depends on some of them. + + * mpn/generic/toom22_mul.c (TOOM22_MUL_REC): New name for + TOOM22_MUL_MN_REC. + +2009-12-26 Niels Möller + + * tests/mpn/t-toom32.c (MIN_AN, MIN_BN, MAX_BN): Relax + requirements a bit. + + * mpn/generic/toom32_mul.c (mpn_toom32_mul): Relax requirement on + input sizes, to support s+t>=n (used to be s+t>=n+2). Keep high + limbs of the evaluated values in scalar variables. + + * mpn/generic/sbpi1_divappr_q.c (mpn_sbpi1_divappr_q): Remove + unused variables. + + * mpn/generic/toom32_mul.c (mpn_toom32_mul): Fixed left-over use + of mpn_addsub_n which should be mpn_add_n_sub_n. + +2009-12-26 Marco Bodrato + + * tune/Makefile.am (TUNE_MPN_SRCS_BASIC): Add new toom files (spotted by Torbjorn). + + * gmp-impl.h (mpn_toom6_sqr_itch): Rename to mpn_toom6_mul_n_itch and redefine. + (mpn_toom8_sqr_itch): Rename to mpn_toom8_mul_n_itch and redefine. + * mpn/generic/mul_n.c: Use renamed _itch macros. + +2009-12-25 Niels Möller + + * tests/mpn/t-toom32.c (MIN_AN, MIN_BN, MAX_BN): Tightened requirements. + * gmp-impl.h (mpn_toom32_mul_itch): Updated. Less scratch needed + by toom32 itself, and also the pointwise multiplications are + currently mpn_mul_n with no supplied scratch. + * mpn/generic/toom32_mul.c (mpn_toom32_mul): Reorganized + interpolation to use less scratch space. No longer supports the + most extreme size ratios. + +2009-12-25 Torbjorn Granlund + + * tune/tuneup.c (tune_preinv_mod_1): Purge. + (tune_mod_1): Use speed_mpn_mod_1_tune for + PREINV_MOD_1_TO_MOD_1_THRESHOLD + + * mpn/generic/dcpi1_divappr_q.c: Handle 2n/n properly. Don't use full + precision in mpn_sbpi1_divappr_q call. Misc cleanup. + + * tune/tuneup.c (tune_mod_1): Add a check_size for + PREINV_MOD_1_TO_MOD_1_THRESHOLD. + +2009-12-24 Torbjorn Granlund + + * tune/mod_1_div.c (MOD_1N_TO_MOD_1_1_THRESHOLD, + (MOD_1U_TO_MOD_1_1_THRESHOLD): Set. + * tune/mod_1_inv.c (MOD_1N_TO_MOD_1_1_THRESHOLD, + (MOD_1U_TO_MOD_1_1_THRESHOLD): Set. + + * gmp-impl.h (USE_PREINV_MOD_1): Remove. + (MPN_MOD_OR_PREINV_MOD_1): Define to choose functions dynamically in + terms of PREINV_MOD_1_TO_MOD_1_THRESHOLD (used to choose statically + using USE_PREINV_MOD_1). + * mpn/generic/perfsqr.c (PERFSQR_MOD_PP): Corresponding updates. + + * tune/tuneup.c (tune_mod_1): Rewrite. + * gmp-impl.h (MOD_1N_TO_MOD_1_1_THRESHOLD): New. + (MOD_1U_TO_MOD_1_1_THRESHOLD): New name for MOD_1_1_THRESHOLD. + (MOD_1_1_TO_MOD_1_2_THRESHOLD): Mew name for MOD_1_2_THRESHOLD. + (MOD_1_2_TO_MOD_1_4_THRESHOLD): New name for MOD_1_4_THRESHOLD. + * mpn/generic/mod_1.c: Corresponding updates. + +2009-12-24 Marco Bodrato + + * mpn/generic/mul_n.c: Use also toom6h and toom8h. + * mpn/generic/sqr_n.c: Use also toom6 and toom8. + * gmp-impl.h: Initial support for tuning of Toom-6half and Toom-8half. + * tune/tuneup.c: Tune Toom-6half and Toom-8half thresholds. + +2009-12-24 Torbjorn Granlund + + * mpn/generic/mod_1_4.c: Get ASSERT right. + * mpn/generic/mod_1_3.c: Likewise. + * mpn/generic/mod_1_2.c: Likewise. + + * mpn/generic/powm_sec.c: Use SQR_TOOM2_THRESHOLD as limit for a native + mpn_sqr_basecase, not TUNE_SQR_TOOM2_MAX. + +2009-12-23 Marco Bodrato + + * tune/common.c, tune/speed.c, tune/speed.h: Support for measuring + mpn_toom8h_mul and mpn_toom8_sqr speed. + + * mpn/generic/toom_eval_pm2exp.c: Fix ASSERTs. + + * mpn/generic/toom8h_mul.c: New file. + * mpn/generic/toom8_sqr.c: New file. + * mpn/generic/toom_interpolate_16pts.c: New file. + * gmp-impl.h: Provide corresponding declarations. + * configure.in (gmp_mpn_functions): List toom_interpolate_16pts, + toom8h_mul, and toom8h_sqr. + * tests/mpn/t-toom8h.c: New test program. + + * mpn/generic/toom6_sqr.c: New file, was part of toom6h_mul. + * mpn/generic/toom6h_mul.c: Removed _sqr. + + * mpn/generic/mulmod_bnm1.c: Nailify CRT. + * mpn/generic/sqrmod_bnm1.c: Likewise. + + * mpn/generic/mullo_n.c: Split dc_mullo_n function; + ALLOC memory at once. + + * mpn/Makefile.am (nodist_EXTRA_libmpn_la_SOURCES): Update. + + * mpn/generic/toom6h_mul.c: Add prefix to toom_interpolate_12pts. + * mpn/generic/toom_interpolate_12pts.c: Likewise. + + * mpn/generic/invertappr.c (mpn_bc_invertappr): Use mpn_divrem_2. + * mpn/generic/invert.c: Faster basecase, use mpn_sbpi1_div_q. + + * mpn/generic/toom_eval_pm2exp.c: Assert support for degree 3. + * mpn/generic/toom6h_mul.c: Avoid obsolete _itch function. + +2009-12-23 Torbjorn Granlund + + * tune/common.c, tune/speed.c, tune/speed.h: Support for measuring + mpn_mod_1_1p, mpn_mod_1s_2p, mpn_mod_1s_3p, mpn_mod_1s_4p. + + * tests/mpz/t-powm.c: Test mpz_powm_sec. + + * mpz/powm_sec.c: New file. + * gmp-h.in: Declare it. + * Makefile.am, mpz/Makefile.am: Compile it. + * doc/gmp.texi: Document it. + + * mpn/generic/powm_sec.c (mpn_powm_sec_itch): New function. + (mpn_powm_sec): Use passed scratch, no local allocation. + Allow exp argument = 1. + (win_size): Start loop from 1. + + * mpn/generic/powm.c (win_size): Start loop from 1. + +2009-12-22 Torbjorn Granlund + + * tests/mpn/t-div.c: New file. + * tests/mpn/Makefile.am: Compile it. + + * mpn/generic/mu_divappr_q.c: Handle quotient overflow. + + * mpn/generic/mu_div_q.c (mpn_mu_div_q_itch): New function. + +2009-12-22 Niels Möller + + * mpn/generic/sbpi1_div_q.c: Use udiv_qr_3by2. Intended to change + nothing after preprocessing. + + * mpn/generic/sbpi1_divappr_q.c: For the last call to udiv_qr_3by2, + avoid using memory locations as output parameters, and revert to + explicitly copying n1 and n0 to memory. + + * gmp-impl.h (udiv_qr_3by2): Tweaked to expand to precisely the + same code as was used before the introduction of this macro. + Eliminated some local variables, instead do multiple updates to + the output parameters. + +2009-12-22 Torbjorn Granlund + + * tests/mpn/t-toom6h.c (MIN_AN): Set to MUL_TOOM6H_THRESHOLD to avoid + invalid recursive sizes. + + * tests/mpn/t-bdiv.c: Get itch function calls right. + + * mpn/generic/mu_bdiv_q.c (mpn_mu_bdiv_q_itch): Rewrite. + * mpn/generic/mu_bdiv_qr.c (mpn_mu_bdiv_qr_itch): Simplify. + + * mpn/generic/bdiv_qr.c (mpn_bdiv_qr): Simplify, don't allocate. + (mpn_bdiv_qr_itch): Conditionalise on MU_BDIV_QR_THRESHOLD. + +2009-12-18 Niels Möller + + * tests/mpn/t-bdiv.c: Add red-zones. + +2009-12-21 Torbjorn Granlund + + * mpn/generic/sbpi1_div_q.c: Fix fixup code to work for qn = 0. + + * mpn/generic/dcpi1_divappr_q.c: Handle qn = 1 and qn = 2 for initial + quotient block (code block copied from dcpi1_div_qr.c). + + * mpn/generic/dcpi1_div_qr.c: Rewrite singular case giving q limb of + GMP_NUMB_MAX. Remove an impossible qn = 0 case. + + * mpn/generic/dcpi1_bdiv_q.c: Remove a spurious mpn_sub_1. + + * mpn/generic/mul.c: Put back call to mpn_mul_n. + + * tune/tuneup.c (all): Call tune_mulmod_bnm1 before tuning fft due to + dependency on mulmod_bnm1 from both mul_fft_mul and from mullo_n. + + * mpn/generic/dcpi1_divappr_q.c: ASSERT that dn >= 6 and nn > dn. + * mpn/generic/dcpi1_div_q.c: ASSERT that dn >= 6 and nn-dn >= 3. + * mpn/generic/dcpi1_div_qr.c: ASSERT that dn >= 6 and nn-dn >= 3. + + * mpn/generic/bdiv_q_1.c (mpn_pi1_bdiv_q_1): Renamed from + mpn_bdiv_q_1_pi1. + * All references changed. + + * configure.in: Add --enable-old-fft-full. + * tune/speed.c (routine): Conditionalise mpn_mul_fft_full references on + WANT_OLD_FFT_FULL. + * tune/common.c (speed_mpn_mul_fft_full) + (speed_mpn_mul_fft_full_sqr): Likewise. + * mpn/generic/mul_fft.c (mpn_mul_fft_full): Include iff + WANT_OLD_FFT_FULL. + +2009-12-21 Marco Bodrato + + * gmp-impl.h (mpn_toom6h_mul_itch): New inline function. + (MUL_TOOM6H_THRESHOLD): Default value. + (SQR_TOOM6_THRESHOLD): Default value. + * mpn/generic/toom6h_mul.c: Remove definitions moved to gmp-impl.h. + * tune/common.c, tune/speed.c, tune/speed.h: Support for measuring + mpn_toom6h_mul and mpn_toom6_sqr speed. + + * mpn/generic/toom63_mul.c: Remove unused TMP_*. + + * mpn/generic/toom_eval_pm2rexp.c: New file. + * gmp-impl.h: Provide corresponding declaration. + * configure.in (gmp_mpn_functions): List toom_eval_pm2rexp. + * mpn/generic/toom6h_mul.c: Use shared toom_eval_pm2rexp. + + * mpn/generic/toom_couple_handling.c: New file, helper function + for high degree Toom. + * gmp-impl.h: Provide corresponding declaration. + * configure.in (gmp_mpn_functions): List toom_couple_handling. + * mpn/generic/toom6h_mul.c: Use shared toom_couple_handling. + * mpn/generic/toom63_mul.c: Likewise. + + * mpn/generic/toom6h_mul.c: New file. + * mpn/generic/toom_interpolate_12pts.c: New file. + * gmp-impl.h: Provide corresponding declarations. + * configure.in (gmp_mpn_functions): List toom_interpolate_12pts, + toom6h_mul. + * tests/mpn/t-toom6h.c: New test program. + + * tests/mpn/t-mulmod_bnm1.c (ref_mulmod_bnm1): Use ref_mul. + * tests/mpn/t-sqrmod_bnm1.c (ref_sqrmod_bnm1): Likewise. + +2009-12-20 Marco Bodrato + + * mpn/generic/mulmod_bnm1.c (mpn_mulmod_bnm1): New CRT. + * mpn/generic/sqrmod_bnm1.c (mpn_sqrmod_bnm1): Likewise. + +2009-12-20 Torbjorn Granlund + + * Change all bit counts for bignums to use mp_bitcnt_t. + + * mpn/generic/bdivmod.c: File removed. All references purged. + + * mpn/generic/mul_fft.c (mpn_mul_fft_full): Disable. + + * gmp-impl.h: Define mpn_fft_mul as an alias for mpn_nussbaumer_mul. + * mpn/generic/mul.c: Refer mpn_fft_mul. + * mpn/generic/mul_n.c: Likewise. + * mpn/generic/sqr_n.c: Likewise. + * mpn/generic/mullo_n.c: Likewise. + + * mpn/generic/mul.c: Loop also over mpn_nussbaumer_mul, as suggested by + Marco. Use TMP_SALLOC_LIMBS in more places. Clean up ws allocation. + +2009-12-19 Marco Bodrato + + * mpn/generic/toom_interpolate_8pts.c: Nailify. + +2009-12-19 Torbjorn Granlund + + * mpn/generic/mul.c: Major rewrite. Use toom43, toom53, toom63. + Call mpn_nussbaumer_mul for largest operands. + + * tune/speed.h (SPEED_ROUTINE_MPN_TOOM32_FOR_TOOM43_MUL): New macro. + (SPEED_ROUTINE_MPN_TOOM43_FOR_TOOM32_MUL): New macro. + (SPEED_ROUTINE_MPN_TOOM32_FOR_TOOM53_MUL): New macro. + (SPEED_ROUTINE_MPN_TOOM53_FOR_TOOM32_MUL): New macro. + (SPEED_ROUTINE_MPN_TOOM42_FOR_TOOM53_MUL): New macro. + (SPEED_ROUTINE_MPN_TOOM53_FOR_TOOM42_MUL): New macro. + * tune/common.c (speed_mpn_toom63_mul): New function. + (speed_mpn_toom32_for_toom43_mul): New function. + (speed_mpn_toom43_for_toom32_mul): New function. + (speed_mpn_toom32_for_toom53_mul): New function. + (speed_mpn_toom53_for_toom32_mul): New function. + (speed_mpn_toom42_for_toom53_mul): New function. + (speed_mpn_toom53_for_toom42_mul): New function. + * tune/tuneup.c (tune_mul_n): New name for old tune_mul. + (tune_sqr_n): New name for old tune_sqr. + (tune_mul): New function, for unbalanced multiplication. + * gmp-impl.h: Provide declarations for corresponding threshold vars. + + * gmp-impl.h (mpn_rsh1add_nc, mpn_rsh1sub_nc): Declare. + * mpn/asm-defs.m4: Likewise. + * configure.in: Add corresponding HAVE_NATIVEs. + * mpn/x86_64/rsh1aors_n.asm: Add _nc entry point. + +2009-12-18 Niels Möller + + * mpz/divexact.c: Rewrite to use mpn_divexact. + + * mpn/generic/bdiv_q_1.c (mpn_bdiv_q_1): Deleted some unused + variables. + + * mpn/generic/toom52_mul.c (mpn_toom52_mul) + [HAVE_NATIVE_mpn_add_n_sub_n]: Moved declaration of cy to avoid a + compiler warning. + + * gmp-impl.h (gmp_pi1_t): Eliminated inv21 member. + (invert_pi1): ...and don't store it here. + + * mpn/generic/toom63_mul.c (mpn_toom63_mul): Simplified + calculation of block size n. + * gmp-impl.h (mpn_toom63_mul_itch): Likewise. + + * mpn/generic/toom_eval_pm2exp.c (mpn_toom_eval_pm2exp): Fixed + output asserts. + +2009-12-18 Torbjorn Granlund + + * tests/mpn/t-toom63.c: New test program. + +2009-12-18 Marco Bodrato + + * mpn/generic/invert.c: Nailify. + * mpn/generic/invertappr.c: Nailify. + * mpn/generic/mulmod_bnm1.c: Nailify. + * mpn/generic/sqrmod_bnm1.c: Nailify. + + * tests/mpn/t-invert.c: New test program. + + * mpn/generic/toom63_mul.c: New file. + * mpn/generic/toom_interpolate_8pts.c: New file. + * gmp-impl.h: Provide corresponding declarations. + * configure.in (gmp_mpn_functions): List toom_interpolate_8pts and + toom63_mul. + +2009-12-17 Torbjorn Granlund + + * mpn/generic/mul.c: Move allocation of ws to where it is used. + Identify toom22, 32, 42, in that order (in two places). Use midline + between toom22, 32, 42. + * mpn/generic/toom22_mul.c (TOOM22_MUL_MN_REC): Call also + mpn_toom32_mul. + + * doc/gmp.texi: Update References section. Update Contributors + section. Misc updates. + + * gmp-impl.h: Renew default values for all THRESHOLDs. + +2009-12-17 Niels Möller + + * mpn/generic/divexact.c (mpn_divexact): Don't require that the + dividend is normalized. Use MPN_DIVREM_OR_PREINV_DIVREM_1. When + shifting, allocate and process only the low qn+1 limbs. Eliminated + code for the impossible case nn < qn. + + * mpn/generic/dcpi1_div_qr.c (mpn_dcpi1_div_qr): Added some input + asserts. + + * mpn/generic/dcpi1_div_qr.c (mpn_dcpi1_div_qr): In the case that + the initial quotient block is a single limb, use 3/2 division, + thereby eliminating the only use of gmp_pi1_t->inv21. + +2009-12-17 Marco Bodrato + + * mpn/generic/invert.c: Added some comment. + * mpn/generic/invertappr.c: Slightly better threshold handling. + * gmp-impl.h (INV_NEWTON_THRESHOLD): Default to 200. + + * mpn/generic/nussbaumer_mul.c: New file. + * configure.in (gmp_mpn_functions): Add nussbaumer_mul. + * tune/Makefile.am (TUNE_MPN_SRCS_BASIC): Add nussbaumer_mul. + * gmp-impl.h (mpn_nussbaumer_mul): Added prototype and name-mangling. + * tune/speed.h (speed_mpn_nussbaumer_mul): Declare function. + * tune/common.c (speed_mpn_nussbaumer_mul): New function. + * tune/speed.c (routine): Add speed_mpn_nussbaumer_mul. + + * mpn/generic/sqrmod_bnm1.c: New file. + * configure.in (gmp_mpn_functions): Add sqrmod_bnm1. + * tune/Makefile.am (TUNE_MPN_SRCS_BASIC): Add sqrmod_bnm1. + * gmp-impl.h (mpn_sqrmod_bnm1): Added prototype and name-mangling. + (SQRMOD_BNM1_THRESHOLD): support for the new threshold. + * tune/speed.h (speed_mpn_sqrmod_bnm1): Declare function. + * tune/common.c (speed_mpn_sqrmod_bnm1): New function. + * tune/speed.c (routine): Add speed_mpn_sqrmod_bnm1. + * tests/mpn/t-mulmod_bnm1.c: Attribution. + * tests/mpn/t-sqrmod_bnm1.c: New test file. + * tests/mpn/Makefile.am (check_PROGRAMS): Add t-sqrmod_bnm1. + + * tune/tuneup.c: Tune SQRMOD_BNM1_THRESHOLD. + + * mpn/generic/nussbaumer_mul.c (mpn_nussbaumer_mul): Mimic fft_mul, + use squaring if operands coincide. + * tune/speed.h (speed_mpn_nussbaumer_mul_sqr): Declare function. + * tune/common.c (speed_mpn_nussbaumer_mul_sqr): New function. + * tune/speed.c (routine): Add speed_mpn_nussbaumer_mul_sqr. + +2009-12-17 Torbjorn Granlund + + * mpn/generic/bdiv_q.c (mpn_bdiv_q_itch): Rewrite. + +2009-12-16 Torbjorn Granlund + + * tests/mpn/t-bdiv.c (bdiv_q_valid_p, bdiv_qr_valid_p): Call refmpn_mul + instead of refmpn_mul_basecase. + * tests/mpn/toom-shared.h: Likewise. + * tests/refmpn.c (refmpn_mullo_n,refmpn_sqr,refmpn_mul_any): Likewise. + + * minithres/gmp-mparam.h: Add new thresholds, trim old values. + + * mpn/generic/powm.c: Use mp_bitcnt_t for bit counts. + Handle REDC_1_TO_REDC_N_THRESHOLD < MUL_TOOM22_THRESHOLD in + non-WANT_REDC_2 INNERLOOP expansion code. + * mpn/generic/powm_sec.c: Use mp_bitcnt_t for bit counts. + +2009-12-16 Niels Möller + + * tests/mpz/t-gcd.c (main): Added test case to exercise the + unlikely u0 == u1 case in mpn_gcdext_lehmer_n. + + * mpn/generic/gcdext_lehmer.c (mpn_gcdext_lehmer_n): Get ASSERT + right. + +2009-12-16 Torbjorn Granlund + + * tests/mpz/t-mul.c: Misc cleanups. + (mul_basecase): Remove. + (ref_mpn_mul): Remove. + * tests/refmpn.c (refmpn_mul): New function, mainly from t-mul.c's + ref_mpn_mul. + (refmpn_mullo_n): Add a missing free. + + * tune/speed.c (routine): Measure speed_mpn_{sb,dc}pi1_div_qr, + mpn_{sb,dc}pi1_divappr_q, mpn_{sb,dc}pi1_bdiv_qr, and + mpn_{sb,dc}pi1_bdiv_q. + + * mpn/generic/invertappr.c: New file, meat from invert.c. + * mpn/generic/invert.c: Leave just mpn_invert.c. + * configure.in (gmp_mpn_functions): Add invertappr. + * tune/Makefile.am (TUNE_MPN_SRCS_BASIC): Add invertappr.c. + * gmp-impl.h (mpn_invert_itch, mpn_invertappr_itch): New macros. + +2009-12-15 Torbjorn Granlund + + * mpn/generic/gcdext_subdiv_step.c: Get an ASSERT right. + +2009-12-15 Niels Möller + + * mpn/generic/sbpi1_div_qr.c (mpn_sbpi1_div_qr): A very small step + towards nail support. + +2009-12-15 Marco Bodrato + + * gmp-impl.h (mpn_ni_invertappr): Added prototype and name-mangling. + * mpn/generic/mulmod_bnm1.c: Comment representation of class [0]. + +2009-12-14 Niels Möller + + * mpn/generic/sbpi1_divappr_q.c (mpn_sbpi1_divappr_q): Use + udiv_qr_3by2. + +2009-12-14 Torbjorn Granlund + + * tune/tuneup.c (tune_binvert): Remove BINV_MULMOD_BNM1_THRESHOLD + tuning, it was always zero and caused BINV_NEWTON_THRESHOLD to be + wrong (as pointed out by Marco). + * (BINV_MULMOD_BNM1_THRESHOLD): Clean from other files too. + +2009-12-14 Marco Bodrato + + * mpn/generic/invert.c: Improved comments. + (mpn_bc_invertappr): Conditionally re-enable mpn_dcpi1_divappr_q. + +2009-12-14 Niels Möller + + * gmp-impl.h (udiv_qr_3by2): Fix typo in argument list. + +2009-12-13 Niels Möller + + * gmp-impl.h (udiv_qr_3by2): New macro. + * mpn/generic/sbpi1_div_qr.c (mpn_sbpi1_div_qr): Use udiv_qr_3by2. + +2009-12-13 Torbjorn Granlund + + * mpn/generic/dcpi1_divappr_q.c (mpn_dcpi1_divappr_q): Avoid a buffer + overrun. + + * mpn/generic/mul_fft.c (mpn_mul_fft_full): Handle carry-out from 2nd + mpn_mul_fft, add an ASSERT for the 1st mpn_mul_fft. Replace some + comments on cc's range with ASSERTs. + + * mpn/generic/gcdext.c (compute_v): Normalise tp[] after mpn_mul. + + * mpz/powm.c: Rework buffer handling. + +2009-12-13 Niels Möller + + * tests/mpn/toom-shared.h (main): Use refmpn_mul_basecase to check + results (slow!). Iteration counts of all toom tests reduced + considerably. + +2009-12-13 Marco Bodrato + + * mpn/generic/invert.c (mpn_invertapp): Split in _bc and _ni. + (mpn_bc_invertappr): New function, the basecase. + (mpn_ni_invertapp): New function, Newton iteration. + (mpn_invert): Use mpn_ni_invertapp. + * tune/tuneup.c (tune_invert): Min for INV_APPR_THRESHOLD. + (tune_invertappr): Min for INV_NEWTON_THRESHOLD. + + * tune/speed.h (SPEED_ROUTINE_MPN_NI_INVERTAPPR): New macro. + (speed_mpn_ni_invertappr): Declare function. + * tune/common.c (speed_mpn_ni_invertappr): New function. + * tune/speed.c (routine): Add speed_mpn_ni_invertappr. + + * tune/tuneup.c (tune_invertappr): Use speed_mpn_ni_invertappr to + tune INV_MULMOD_BNM1_THRESHOLD. + +2009-12-12 Torbjorn Granlund + + * mpn/generic/mu_bdiv_qr.c (mpn_mu_bdiv_qr_itch): Rewrite. + +2009-12-12 Marco Bodrato + + * tests/mpn/t-mulmod_bnm1.c (main): Disable B^n+1 stressing test + for odd sizes. + + * mpn/generic/invert.c: Complete rewrite. Uses Newton iterations. + * gmp-impl.h (mpn_invertappr): Added prototype and name-mangling. + (mpn_invertappr_itch): Added prototype and name-mangling. + (INV_APPR_THRESHOLD): Support for a new tunable const. + * tune/speed.h (SPEED_ROUTINE_MPN_INVERTAPPR): New macro. + (speed_mpn_invertappr): Declare function. + * tune/common.c (speed_mpn_invertappr): New function. + * tune/speed.c (routine): Add speed_mpn_invertappr. + * tune/tuneup.c (tune_invertappr): New function: was tune_invert. + (tune_invert): Now tune only INV_APPR_THRESHOLD. + (all): Enable call to tune_invert and tune_invertappr. + +2009-12-11 Torbjorn Granlund + + * mpn/generic/binvert.c: Use mpn_mulmod_bnm1 instead of FFT wrapping. + Old, evidently broken wrapping code removed. + * tune/tuneup.c (tune_binvert): Tune BINV_MULMOD_BNM1_THRESHOLD. + * gmp-impl.h: Provide declarations for corresponding threshold var. + + * tests/mpn/t-bdiv.c (COUNT): Decrease to keep run time reasonable. + + * tune/tuneup.c (tune_invert): Tune INV_MULMOD_BNM1_THRESHOLD. + * gmp-impl.h: Provide declarations for corresponding threshold var. + + * tests/mpn/t-mulmod_bnm1.c: Avoid a division by zero. + + * configure.in: Set up different paths for different 64-bit sparc + processors. + * mpn/sparc64/ultrasparc34/gmp-mparam.h: New file. + +2009-12-10 Torbjorn Granlund + + * mpn/*/gmp-mparam.h: Regenerate many of these files. + +2009-12-10 Niels Möller + + * gmp-impl.h (mpn_divexact): Removed scratch pointer from + prototype. + * mpn/generic/gcdext.c (divexact): Deleted, moved to... + * mpn/generic/divexact.c (mpn_divexact): New implementation (moved + from gcdext.c). The bidirectional divexact is kept but #if:ed out. + Interface change, since the new code doesn't take a scratch + argument. + + * tests/mpn/t-mulmod_bnm1.c (main): Ensure that an >= bn. Lowered + MIN_N to 1. Various fixes to handle n == 1 properly. + + * mpn/generic/mulmod_bnm1.c (mpn_mulmod_bnm1): Small interface + change, require an >= bn. + + * mpn/generic/mulmod_bnm1.c (mpn_mulmod_bnm1): Fixed non-recursive + case to not write beyond end of result area. + +2009-12-09 Torbjorn Granlund + + * tune/speed.h (SPEED_ROUTINE_MPN_MULMOD_BNM1_CALL): New macro, made + from now deleted SPEED_ROUTINE_MPN_MULMOD_BNM1. + * tune/common.c (speed_mpn_bc_mulmod_bnm1): New function. + (speed_mpn_mulmod_bnm1): Use SPEED_ROUTINE_MPN_MULMOD_BNM1_CALL. + * tune/speed.c (routine): Add mpn_bc_mulmod_bnm1. + + * mpn/generic/mulmod_bnm1.c (mpn_mulmod_bnm1_next_size): Rewrite. + + * tune/tuneup.c (tune_mulmod_bnm1): Rewrite. + +2009-12-08 Marco Bodrato + + * mpn/generic/mulmod_bnm1.c (mpn_bc_mulmod_bnm1, + mpn_bc_mulmod_bnp1): Added a parameter for scratch area, possibly + same as result area (as suggested by Niels Möller). + (mpn_mulmod_bnm1): Calls changed accordingly. + +2009-12-08 Niels Möller + + * mpn/generic/gcdext_1.c (mpn_gcdext_1) [GCDEXT_1_USE_BINARY]: Use + table lookup for count_trailing_zeros. Binary algorithm still + disabled by default. + + * mpn/generic/gcdext.c (divexact): Local definition of divexact, + using mpn_bdiv_q. + (compute_v): Use it. + + * tests/mpn/Makefile.am (check_PROGRAMS): Added t-bdiv. + + * tests/mpn/t-bdiv.c: New file. + + * mpn/generic/bdiv_q.c (mpn_bdiv_q): Fixed bad quotient length, + should have qn == nn. + + * mpn/generic/bdiv_qr.c (mpn_bdiv_qr): Pass correct nn length to + the lower-level functions. + +2009-12-08 Torbjorn Granlund + + * tune/speed.h (SPEED_ROUTINE_MPN_MULMOD_BNM1_ROUNDED): New define. + * tune/common.c (speed_mpn_mulmod_bnm1_rounded): New function. + * tune/speed.c (routine): Add mpn_mulmod_bnm1_rounded for measuring + mpn_mulmod_bnm1 at recommended sizes. + + * mpn/generic/mulmod_bnm1.c (mpn_mulmod_bnm1_next_size): Rewrite. + (mpn_bc_mulmod_bnm1): Use mpn_add_n instead of mpn_add. + + * tune/speed.c (routine): Add mpn_invert. + + * tune/tuneup.c (tune_invert): New function. + * tune/speed.h (SPEED_ROUTINE_MPN_INVERT): New macro. + * tune/common.c (speed_mpn_invert): New function. + * gmp-impl.h: Provide declarations for corresponding threshold var. + * tune/Makefile.am (TUNE_MPN_SRCS_BASIC): Add invert.c. + +2009-12-08 Marco Bodrato + + * tests/devel/try.c: Test mpn_addlsh2_n and mpn_{add,sub}lsh_n; + mpn_rsblsh_n now tests all shift values. + * tests/refmpn.c (refmpn_addlsh_n, refmpn_sublsh_n): New functions. + (refmpn_addlsh1_n): Use generic refmpn_addlsh_n. + (refmpn_sublsh1_n): Use generic refmpn_sublsh_n. + (refmpn_addlsh2_n): New function. + * tests/tests.h: Declare new functions. + +2009-12-06 Torbjorn Granlund + + * tune/tuneup.c (tune_mulmod_bnm1): Up min_size to 12. + + * Globally: Rename *mullow* to *mullo*, *MULLOW* to *MULLO*. + + * configure.in: Don't include ev5 directory for ev6* and ev7. Misc + alpha path cleanups. + * mpn/alpha/add_n.asm: Replaced by mpn/alpha/ev5/add_n.asm. + * mpn/alpha/sub_n.asm: Replaced by mpn/alpha/ev5/sub_n.asm. + * mpn/alpha/lshift.asm: Replaced by mpn/alpha/ev5/lshift.asm. + * mpn/alpha/rshift.asm: Replaced by mpn/alpha/ev5/rshift.asm. + * mpn/alpha/com_n.asm: New, moved from mpn/alpha/ev5/rshift.asm. + * mpn/alpha/ev5/diveby3.asm: New, moved from mpn/alpha/diveby3.asm. + + * mpn/powerpc64/mode64/diveby3.asm: Remove, it is slower than + mpn_bdiv_dbm1c on all hardware. + + * mpn/generic/powm_sec.c: Rework logic for mpn_sqr_basecase size limit. + + * gmp-impl.h (mpn_redc_1_sec): Declare. + * configure.in (gmp_mpn_functions): Add redc_1_sec. + +2009-12-06 Marco Bodrato + + * tests/devel/try.c (try_one): DATA_SRC0_HIGHBIT sets the high bit. + +2009-12-05 Marco Bodrato + + * mpn/generic/toom_eval_dgr3_pm1.c: Change return value: 0 or ~0. + * mpn/generic/toom_eval_dgr3_pm2.c: Likewise. + * mpn/generic/toom_eval_pm1.c: Likewise. + * mpn/generic/toom_eval_pm2exp.c: Likewise. + * mpn/generic/toom_eval_pm2.c: Rewrite to use mpn_addlsh2_n. + + * mpn/generic/toom_interpolate_5pts.c: Param sa is a flag, not a sign. + + * mpn/generic/toom33_mul.c: Adapt to changes above. + * mpn/generic/toom3_sqr.c: Likewise. + * mpn/generic/toom42_mul.c: Likewise. + * mpn/generic/toom43_mul.c: Reduce branches. + * mpn/generic/toom44_mul.c: Likewise. + * mpn/generic/toom53_mul.c: Likewise. + * mpn/generic/toom62_mul.c: Likewise. + + * mpn/generic/toom52_mul.c: Use toom_eval_ functions. + + * mpn/generic/toom4_sqr.c: Avoid C99 construct. + * mpn/generic/toom_interpolate_7pts.c: Likewise. + +2009-12-05 Torbjorn Granlund + + * mpn/generic/redc_1_sec.c: New file. + * mpn/generic/powm_sec.c: Use redc_1_sec. Use dummy full subtract + instead of mpn_cmp since the latter leaks to the side channel. + (mpn_local_sqr_n): New function, with associated macros. + (mpn_powm_sec): Use mpn_local_sqr_n. + + * configure.in (HAVE_NATIVE): Add missing functions, then sort. + +2009-12-04 Torbjorn Granlund + + * tune/tuneup.c (tune_dc_div): Up min_size to 6. + (tune_mod_1): Set MOD_1_1_THRESHOLD min_size to 2. + + * tune/speed.h: Negate "binvert"-type inverses, as required. + + * mpn/generic/redc_1.c: Add ASSERTs. + * mpn/generic/redc_2.c: Likewise. + + * mpn/generic/sbpi1_bdiv_q.c: Simplify loops, indexing. + +2009-12-03 Yann Droneaud + + * acinclude.m4 ([long long reliability test 1]): Add a "static" for C99 + inline semantics compatibility. + +2009-12-03 Torbjorn Granlund + + * configure.in: Move intptr_t test into common AC_CHECK_TYPES. + + * mpn/generic/gcdext.c: Add a TMP_FREE. + +2009-12-03 Niels Möller + + * mpn/generic/gcdext_1.c (mpn_gcdext_1) [GCDEXT_1_USE_BINARY]: + Added various masking tricks. + + * mpn/generic/gcdext_1.c (mpn_gcdext_1) [GCDEXT_1_USE_BINARY]: + Reimplemented binary gcdext, with proper canonicalization. + + * mpn/generic/gcdext_lehmer.c (mpn_gcdext_lehmer_n): Handle v == 0 + from mpn_gcdext_1. + * mpn/generic/gcdext_1.c (mpn_gcdext_1): Allow inputs with a < b, + assertions fixed accordingly. + +2009-12-03 Torbjorn Granlund + + * tune/tuneup.c: Tune DC_DIVAPPR_Q_THRESHOLD. Rewrite + DC_DIV_QR_THRESHOLD tuning code. + (tune_dc_div): Rewrite. + * tune/speed.h (SPEED_ROUTINE_MPN_PI1_DIV): New macro. + * tune/common.c (speed_mpn_sbpi1_div_qr, speed_mpn_dcpi1_div_qr, + speed_mpn_sbpi1_divappr_q, speed_mpn_sbpi1_bdiv_qr): New functions. + * gmp-impl.h: Provide declarations for corresponding threshold vars. + * tune/Makefile.am (TUNE_MPN_SRCS_BASIC): Add dcpi1_divappr_q.c. + + * tune/tuneup.c (tune_binvert): Up max_size. + +2009-12-02 Marco Bodrato + + * tests/devel/try.c: Test mpn_rsblsh2_n and mpn_rsblsh_n. + * tests/refmpn.c (refmpn_rsblsh_n, refmpn_rsblsh2_n): New functions. + (refmpn_rsblsh1_n): Use generic refmpn_rsblsh_n. + * tests/tests.h: Declare new functions. + +2009-12-03 Niels Möller + + * mpn/generic/gcdext_subdiv_step.c (mpn_gcdext_subdiv_step): + Select the right cofactor in the cases A == B or A == 2B. + + * mpn/generic/gcdext_lehmer.c (mpn_gcdext_lehmer_n): Deleted + handling of ap[0] == 0 and bp[0] == 0; these cases don't happen. + Select the right cofactor in the case ap[0] == bp[0]. + * mpn/generic/gcdext.c (mpn_gcdext): Analogous changes. + +2009-12-02 Niels Möller + + * gmp-h.in (mpn_gcdext_1): Updated prototype. + * mpn/generic/gcdext_lehmer.c (mpn_gcdext_lehmer_n): Updated for + signed cofactors from gcdext_1. + * mpn/generic/gcdext_1.c (mpn_gcdext_1): Use Euclid's algorithm, + and return signed cofactors. + +2009-12-02 Torbjorn Granlund + + * doc/gmp.texi (Low-level Functions): Document mpn_sqr_n. + + * tune/speed.c (routine): Add mpn_binvert. + + * tune/tuneup.c: Tune BINV_NEWTON_THRESHOLD. + (tune_binvert): New function. + * tune/speed.h (SPEED_ROUTINE_MPN_BINVERT): New macro. + * tune/common.c (speed_mpn_binvert): New function. + * gmp-impl.h: Provide declarations for corresponding threshold var. + * tune/Makefile.am (TUNE_MPN_SRCS_BASIC): Add binvert.c. + + * tune/tuneup.c: Tune DC_BDIV_QR_THRESHOLD and DC_BDIV_Q_THRESHOLD. + (tune_dc_bdiv): New function. + (tune_dc_div): New name for tune_dc. + * tune/speed.h (SPEED_ROUTINE_MPN_PI1_BDIV_QR, + SPEED_ROUTINE_MPN_PI1_BDIV_Q): New macros. + * tune/common.c (speed_mpn_sbpi1_bdiv_qr, speed_mpn_dcpi1_bdiv_qr, + speed_mpn_sbpi1_bdiv_q, speed_mpn_dcpi1_bdiv_q): New functions. + * gmp-impl.h: Provide declarations for corresponding threshold vars. + * tune/Makefile.am (TUNE_MPN_SRCS_BASIC): Add dcpi1_bdiv_qr.c and + dcpi1_bdiv_q.c. + +2009-12-01 Marco Bodrato + + * mpn/generic/toom53_mul.c: Removed double computation of vinf. + + * mpn/x86_64/aorrlsh_n.asm: Correct return value for rsblsh_n. + * mpn/asm-defs.m4 (define_mpn): Add rsblsh_n. + * gmp-impl.h (mpn_rsblsh_n): Added prototype and name-mangling. + + * mpn/generic/fib2_ui.c: Reduce the amount of temporary storage. + Use mpn_rsblsh_n. + +2009-12-01 Torbjorn Granlund + + * mpn/generic/redc_n.c: Rework temp allocation. + + * mpn/generic/dcpi1_bdiv_qr.c (mpn_dcpi1_bdiv_qr_n_itch): Add pi1 also + to this function. + + * mpn/generic/dcpi1_bdiv_q.c: Get the mpn_sbpi1_bdiv_q call right. + Misc cleanups. + + * tune/speed.c (routine): Fix typo in last change. + Add mpn_redc_2. + + * tune/speed.h (SPEED_ROUTINE_REDC_N): Set min size properly. + +2009-12-01 Niels Möller + + * tune/speed.c (routine): Added mpn_toom42_mul and mpn_redc_n. + * tune/speed.h (SPEED_ROUTINE_MPN_TOOM42_MUL): New macro. + (speed_mpn_toom42_mul): Declare function. + * tune/common.c (speed_mpn_toom42_mul): New function. + * gmp-impl.h (MPN_TOOM42_MUL_MINSIZE): New constant. + +2009-11-30 Marco Bodrato + + * mpn/generic/fib2_ui.c: Use mpn_rsblsh2_n. + +2009-11-29 Torbjorn Granlund + + * mpn/x86_64/pentium4/gmp-mparam.h + (HAVE_NATIVE_mpn_addlsh1_n, HAVE_NATIVE_mpn_sublsh1_n): Don't undef. + + * Makefile.am (EXTRA_DIST): Remove macos. + +2009-11-28 Torbjorn Granlund + + * tune/tuneup.c (tune_redc): Set min_size to 16 for redc_n tuning. + + * mpn/x86_64/sqr_basecase.asm (SQR_TOOM2_THRESHOLD_MAX): Avoid quoting + to allow configure.in parse it more easily. Trim from 120 to 80. + +2009-11-28 Marco Bodrato + + * mpn/generic/mulmod_bnm1.c: Basecases made simpler, this also corrects + a bug affecting previous version. + +2009-11-28 Torbjorn Granlund + + * configure.in: Handle atom also in 32-bit mode. + * mpn/x86/atom/gmp-mparam.h: New file. + + * gmp-impl.h (MULMOD_BNM1_THRESHOLD): Default. + + * mpn/generic/redc_n.c: Use mpn_mulmod_bnm1 instead of mpn_mul_n. + + * Use TMP_ALLOC_LIMBS consistently. + * Finish renaming BITS_PER_MP_LIMB to GMP_LIMB_BITS. + + * macos: Remove entire directory. + +2009-11-27 Torbjorn Granlund + + * mpn/x86_64/corei/gmp-mparam.h: New file. + * mpn/x86_64/core2/gmp-mparam.h: Now for just core2. + * mpn/powerpc64/mode64/p3/gmp-mparam.h: New file. + * mpn/powerpc64/mode64/p4/gmp-mparam.h: New file. + * mpn/powerpc64/mode64/p5/gmp-mparam.h: New file. + + * config.guess: Return "corei" for core i7 and core i5. + * config.sub: Recognise "corei". + * acinclude.m4 (X86_64_PATTERN): Add corei. + * configure.in (powerpc): Set up more CPU-specific paths. + (x86): Handle corei. + + * mpz/powm.c: Allow input operand overlap also when exponent = 1. + Misc cleanups. + +2009-11-26 Marco Bodrato + + * tests/mpn/t-mulmod_bnm1.c: New test file. + * tests/mpn/Makefile.am (check_PROGRAMS): Add t-mulmod_bnm1. + + * mpn/generic/mullow_n.c: Comments on Mulders' trick implementation. + +2009-11-26 Torbjorn Granlund + + * mpn/generic/powm.c: Make comments reflect current code state. + + * tests/devel/try.c: Make mpn_mullow_n testing actually work. + +2009-11-25 Torbjorn Granlund + + * mpz/powm.c: Clean up unused defs. + +2009-11-24 Torbjorn Granlund + + * tune/tuneup.c (tune_redc): Rewrite. + * mpn/generic/powm.c: Use REDC_1_TO_REDC_2_THRESHOLD, + REDC_1_TO_REDC_N_THRESHOLD, and REDC_2_TO_REDC_N_THRESHOLD. + Get rid of previous REDC params, including LOCAL_REDC_N_THRESHOLD. + (WANT_REDC_2): Define. + * gmp-impl.h: Corresponding changes. + +2009-11-23 Torbjorn Granlund + + * mpn/generic/powm.c: Fix typo. + Define LOCAL_REDC_N_THRESHOLD, use in REDC_2_THRESHOLD... + REDC_N_THRESHOLD chain. + +2009-11-22 Torbjorn Granlund + + * tune/tuneup.c (tune_mullow): Set min_size to 1. + + * mpn/generic/powm_sec.c: Use just mpn_mul_basecase and + mpn_sqr_basecase for multiplication and squaring. + + * tune/tuneup.c: Tune REDC_2_THRESHOLD and REDC_N_THRESHOLD. + (tune_redc): New function. + (tune_powm): Remove function. + * tune/speed.h (SPEED_ROUTINE_REDC_2, SPEED_ROUTINE_REDC_N): New. + * tune/common.c (speed_mpn_redc_2, speed_mpn_redc_n): New. + + * mpz/powm.c: Complete rewrite. Use mpn_powm and mpn_powlo. + * mpn/generic/powm.c: Rewrite. + * mpn/generic/redc_n.c: New file. + * configure.in (gmp_mpn_functions): Add redc_n. + * gmp-impl.h (REDC_2_THRESHOLD, REDC_N_THRESHOLD): Default, and define + for tuneup. + +2009-11-21 Marco Bodrato + + * mpn/generic/mullow_n.c: Disable Mulders' trick for small operands, + use fft for bigger ones. + * tests/mpn/t-mullo.c: New test file. + +2009-11-22 Torbjorn Granlund + + * tune/tuneup.c (tune_mullow): Rewrite. + +2009-11-21 Marco Bodrato + + * gmp-impl.h: Removed unused macros (CACHED_ABOVE_THRESHOLD and + CACHED_BELOW_THRESHOLD). + + * mpn/generic/mullow_n.c: Use Mulders' trick. + * tune/tuneup.c (tune_mullow): MULLOW_MUL_N_THRESHOLD range of + search depends on FFT tuning; + (all): Anticipate tune_fft_{mul,sqr}. + + * tune/speed.c (routine): Add entry related to mpn_mulmod_bnm1. + +2009-11-19 Niels Möller + + * mpn/generic/toom_eval_dgr3_pm2.c (mpn_toom_eval_dgr3_pm2) + [HAVE_NATIVE_mpn_add_n_sub_n]: Fixed typo in mpn_add_n_sub_n call + (spotted by Marco Bodrato). + * mpn/generic/toom_eval_pm2.c (mpn_toom_eval_pm2): Likewise. + * mpn/generic/toom_eval_pm2exp.c (mpn_toom_eval_pm2exp): Likewise. + + * mpn/generic/toom_eval_pm2.c (mpn_toom_eval_pm2) [HAVE_NATIVE_mpn_addlsh_n]: + Fixed missing declaration. + + * mpn/asm-defs.m4 (define_mpn): Add addlsh_n. + * gmp-impl.h (mpn_addlsh_n): Added prototype and name-mangling. + +2009-11-19 Niels Möller + + * mpn/generic/toom_eval_pm2.c (mpn_toom_eval_pm2): New file. + * mpn/generic/toom53_mul.c (mpn_toom53_mul): Use mpn_toom_eval_pm2. + * mpn/generic/toom62_mul.c (mpn_toom62_mul): Likewise. + * configure.in (gmp_mpn_functions): Added toom_eval_dgr3_pm2. + +2009-11-18 Torbjorn Granlund + + * gmp-impl.h (mpn_and_n, etc): Adapt to now-public logic functions. + + * config.guess: Recognise VIA nano. + * config.sub: Likewise. + * configure.in: Generalise x86_64 support; recognise VIA nano. + +2009-11-16 Torbjorn Granlund + + * tune/speed.c (routine): Add measurement of mpn_addlsh2_n, + mpn_sublsh2_n, mpn_rsblsh2_n. + * tune/common.c: Add speed routines for lsh2 functions. + + * mpn/generic/divis.c: Use MU_BDIV_QR_THRESHOLD. + + * configure.in (gmp_mpn_functions_optional): Add *lsh_n functions. + + * mpn/generic/toom_eval_pm2exp.c: Make HAVE_NATIVE_mpn_addlsh_n code + work. + + * mpn/x86_64/aorrlsh2_n.asm: Optimise inner loop. + + * configure.in (gmp_mpn_functions_optional): Remove copyi,copyd, they + are now in gmp_mpn_functions. Analogously move logical functions. + +2009-11-16 Marco Bodrato + + * mpn/generic/toom53_mul.c: Use addlsh2 for evaluation (and fix typo). + * mpn/generic/toom_eval_dgr3_pm2.c: Likewise (affects toom44 and 43). + + * mpn/asm-defs.m4: Fix comments for op_lsh2 new functions. + * gmp-impl.h: Likewise. + * tests/mpz/t-fac_ui.c: Fix a comment. + +2009-11-15 Torbjorn Granlund + + * mpn/x86_64/aorrlsh2_n.asm: New file. + * configure.in: Add support for addlsh2_n, sublsh2_n, and rsblsh2_n, + including mulfuncs. + * gmp-impl.h (mpn_addlsh2_n, mpn_sublsh2_n, mpn_rsblsh2_n): Declare. + * mpn/asm-defs.m4: Likewise. + + * mpn/generic/copyi.c: New file. + * mpn/generic/copyd.c: Likewise. + * mpn/generic/zero.c: Likewise. + * gmp-h.in: Declare new functions. + * configure.in (gmp_mpn_functions): Add new functions. + +2009-11-15 Marco Bodrato + + * mpn/generic/mulmod_bnm1.c (mpn_mulmod_bnm1_next_size): fix typo + + * mpn/generic/toom33_mul.c: Use rsblsh1 for evaluation. + * mpn/generic/toom3_sqr.c: Likewise. + +2009-11-14 Torbjorn Granlund + + * mpn/generic/toom52_mul.c: Use mpn_addlsh1_n. + + * mpn/generic/toom52_mul.c: Toggle the right flag bit in an + HAVE_NATIVE_mpn_add_n_sub_n arm. + + * tests/mpz/t-remove.c: New file. + + * mpn/generic/remove.c: Major overhaul. Add parameter 'cap'. + + * mpn/generic/binvert.c: Fix typo in last change. + + * mpn/generic/bdiv_qr.c: Make it actually work. Also use passed-in + scratch space. + + * mpn/generic/mu_bdiv_qr.c: Reset FFT parameters for each call. + +2009-11-12 Torbjorn Granlund + + * mpn/x86/k7/gcd_1.asm (MASK): Compute from MAXSHIFT. + +2009-11-11 Torbjorn Granlund + + * mpn/generic/binvert.c: Simplify, fix comments. + + * tests/devel/try.c: Test mpn_invert and mpn_binvert. + + * tests/refmpn.c (refmpn_invert, refmpn_binvert): New functions. + * tests/tests.h: Declare new functions. + +2009-11-10 Torbjorn Granlund + + * configure.in: Supply compiler options for atom in 32-bit mode. + + * acinclude.m4 (X86_64_PATTERN): New. + * configure.in: Setup and use X86_64_PATTERN. + + * mpn/x86_64/fat/fat.c: New file. + * mpn/x86_64/fat/fat_entry.asm: New file. + * mpn/x86_64/fat: Copy C placeholder files from mpn/x86/fat. + * mpn/x86_64/x86_64-defs.m4 (CPUVEC_FUNCS_LIST): New, copied from + mpn/x86/x86-defs.m4. + * configure.in: Move down x86 fat setup code until after ABI has been + determined; generalise to handle x86_64. + +2009-11-09 Torbjorn Granlund + + * mpn/x86/fat/mod_1.c: New file. + + * acinclude.m4 (GMP_C_FOR_BUILD_ANSI): Avoid poor quoting. + +2009-11-08 Torbjorn Granlund + + * gmp-impl.h (MPN_LOGOPS_N_INLINE): Rewrite, update interface. Callers + updated. + * mpn/generic/logops_n.c: New file. + * doc/gmp.texi (Low-level Functions): Document logical mpn functions. + +2009-11-07 Torbjorn Granlund + + * tune/speed.h (SPEED_ROUTINE_MPN_MULMOD_BNM1): Adapt to new + mpn_mulmod_bnm1 interface. + +2009-11-07 Marco Bodrato + + * mpn/generic/mulmod_bnm1.c: New interface, with size + specified for all operands in mpn_mulmod_bnm1. + * gmp-impl.h: Changed mpn_mulmod_bnm1 prototype. + +2009-11-05 Torbjorn Granlund + + * mpn/x86/k7/gcd_1.asm: Actually use div-reduced value. + Mnemonic cleanup. + + * mpn/x86_64/gcd_1.asm: New file. + +2009-11-03 Torbjorn Granlund + + * tune/Makefile.am (TUNE_MPN_SRCS_BASIC): Add sqr_n.c. + +2009-11-03 Marco Bodrato + + * mpn/generic/toom_interpolate_6pts.c: removed an addmul_1 and cleanup. + +2009-11-02 Torbjorn Granlund + + * configure.in (gmp_mpn_functions): Remove obsolete functions + dc_divrem_n and sb_divrem_mn. + * gmp-impl.h: Misc cleanup. + (mpn_sb_divrem_mn, mpn_dc_divrem_n): Remove. + (DIV_DC_THRESHOLD): Remove. + * mpn/generic/dc_divrem_n.c: Remove. + * mpn/generic/sb_divrem_mn.c: Remove. + * mpn/generic/tdiv_qr.c: Use DC_DIV_QR_THRESHOLD, not DIV_DC_THRESHOLD. + + * tests/devel/try.c: Replace mpn_sb_divrem_mn by mpn_sbpi1_div_qr. + * tests/refmpn.c (refmpn_sb_div_qr): New name for refmpn_sb_divrem_mn. + + * tune/Makefile.am (libspeed_la_SOURCES): Remove sb_div.c and sb_inv.c. + (TUNE_MPN_SRCS_BASIC): Remove sb_divrem_mn.c. + * tune/common.c (speed_mpn_dcpi1_div_qr_n): New function. + Remove mpn_sb_divrem_mn related functions. + * tune/speed.c (routine): Remove entries related to mpn_dc_divrem and + mpn_sb_divrem. + (routine): New entry for mpn_dc_div_qr_n. + * tune/speed.h (SPEED_ROUTINE_MPN_DC_DIVREM_CALL): Compute inverse + needed by pi1 calls. + (SPEED_ROUTINE_MPN_SB_DIVREM_M3): Remove. + * tune/tuneup.c (tune_sb_preinv): Remove. + (tune_dc): Update to measure DC_DIV_QR_THRESHOLD. + + * mpn/generic/sb_divappr_q.c: Remove. + +2009-11-01 Torbjorn Granlund + + * gmp-impl.h: Misc minor cleanups. + +2009-10-31 Torbjorn Granlund + + * gmp-impl.h (toom itch functions): Simplify, make some into macros. + (MPN_KARA_MUL_N_TSIZE, MPN_KARA_SQR_N_TSIZE): Remove. + * mpn/generic/mul_n.c (mpn_toom3_mul_n, mpn_toom3_sqr_n): Remove. + * mpn/generic/mul_n.c (mpn_sqr_n): Move from here... + * mpn/generic/sqr_n.c: ...to this new file. + * configure.in (gmp_mpn_functions): Add sqr_n. + + * Globally change + MUL_TOOM3_THRESHOLD => MUL_TOOM33_THRESHOLD, + MUL_KARATSUBA_THRESHOLD => MUL_TOOM22_THRESHOLD, + SQR_KARATSUBA_THRESHOLD => SQR_TOOM2_THRESHOLD, + and associated names analogously. + +2009-10-31 Niels Möller + + * mpn/generic/toom_interpolate_7pts.c: Changed evaluation points, + replacing -1/2 by -2. + * mpn/generic/toom44_mul.c: Updated to use new evaluation points, + and use mpn_toom_eval_dgr3_pm2. + * mpn/generic/toom4_sqr.c (mpn_toom4_sqr): Likewise. + * mpn/generic/toom53_mul.c (mpn_toom53_mul): Updated to use new + evaluation points, and use mpn_toom_eval_pm1 and + mpn_toom_eval_pm2exp. + * mpn/generic/toom62_mul.c (mpn_toom62_mul): Likewise. + + * mpn/generic/toom_eval_pm2exp.c: New file. + * mpn/generic/toom_eval_pm1.c: New file. + + * mpn/generic/toom43_mul.c (mpn_toom43_mul): Use + mpn_toom_eval_dgr3_pm2. + +2009-10-30 Torbjorn Granlund + + * tune/Makefile.am (TUNE_MPN_SRCS_BASIC): Add toom2* and toom3* files. + +2009-10-30 Niels Möller + + * configure.in (gmp_mpn_functions): Added toom_eval_dgr3_pm2. + * gmp-impl.h: Added prototype for mpn_toom_eval_dgr3_pm2. + * mpn/generic/toom_eval_dgr3_pm2.c: New file. + +2009-10-29 Niels Möller + + * mpn/generic/toom43_mul.c (mpn_toom43_mul): Use + mpn_toom_eval_dgr3_pm1. + * mpn/generic/toom42_mul.c (mpn_toom42_mul): Likewise. + +2009-10-29 Torbjorn Granlund + + * mpn/generic/mulmod_bnm1.c: Replace some add_1 by INCR. + + * gmp-impl.h (mpn_mulmod_bnm1_itch): New macro. + + * mpn/generic/mulmod_bnm1.c (mpn_mulmod_bnm1): Call mpn_mul_fft. + (mpn_mulmod_bnm1_next_size): Adopt to SS FFT. + + * mpn/generic/mul_fft.c (mpn_mul_fft): Make it return high limb. + (mpn_mul_fft_internal): Likewise. + + * mpn/generic/mulmod_bnm1.c: New file, by Niels Möller. + * configure.in (gmp_mpn_functions): Add mulmod_bnm1. + * gmp-impl.h: Add related declarations. + * tune/tuneup.c: Tune MULMOD_BNM1_THRESHOLD. + * tune/speed.h (SPEED_ROUTINE_MPN_MULMOD_BNM1): New macro. + * tune/common.c (speed_mpn_mulmod_bnm1): New function. + * Makefile.am (TUNE_MPN_SRCS_BASIC): Add mulmod_bnm1.c. + + * gmp-impl.h (mpn_kara_mul_n, mpn_kara_sqr_n): Remove declarations. + * tune/common.c: Remove/rename kara functions. + * tune/speed.h: Likewise. + + * tests/devel/try.c: Clean up usage of %p printf arguments. + + * gmp-impl.h: Update MUL/SQR MINSIZE macros to reflect new function + names and limitations + * tune/tuneup.c: Use updated macro names. + * tune/speed.h: Likewise. + * tests/devel/try.c: Test new mul/sqr functions, remove old tests. + +2009-10-29 Niels Möller + + * tune/speed.c: Added support for mpn_toom4_sqr, + + * tune/speed.h (SPEED_ROUTINE_MPN_TOOM4_SQR): New macro. + (SPEED_ROUTINE_MPN_KARA_MUL_N): Deleted. + (SPEED_ROUTINE_MPN_TOOM3_MUL_N): Deleted. + (SPEED_ROUTINE_MPN_TOOM2_SQR): Use mpn_toom2_sqr_itch. + + * gmp-impl.h (mpn_toom3_mul_n, mpn_toom3_sqr_n): Remove + declarations. + (mpn_toom2_sqr_itch): Add margin for recursive calls. + +2009-10-28 Niels Möller + + * mpn/generic/mul_n.c (mpn_kara_mul_n): Deleted old Karatsuba + implementation. + (mpn_kara_sqr_n): Likewise deleted. + + * mpn/generic/mul_n.c (mpn_sqr_n): Use mpn_toom2_sqr and + mpn_toom3_sqr, not the old implementations. + + * gmp-impl.h (MPN_TOOM3_MUL_N_TSIZE): Deleted, replaced by + mpn_toom33_mul_itch. + (MPN_TOOM3_SQR_N_TSIZE): Deleted, replaced by + mpn_toom3_sqr_itch. + (mpn_toom33_mul_itch): Needs more scratch. + (mpn_toom3_sqr_itch): Likewise. + * tune/speed.h (SPEED_ROUTINE_MPN_TOOM3_MUL_N): Use + mpn_toom33_mul_itch. + (SPEED_ROUTINE_MPN_TOOM3_SQR_N): Use mpn_toom3_sqr_itch. + * mpn/generic/mul_n.c (mpn_mul_n): Use mpn_toom33_mul_itch. + (mpn_sqr_n): Use mpn_toom3_sqr_itch. + + * mpn/generic/toom33_mul.c (mpn_toom33_mul): Avoid TMP_ALLOC. Needs + some more supplied scratch instead. + * mpn/generic/toom3_sqr.c (mpn_toom3_sqr): Likewise. + +2009-10-26 Torbjorn Granlund + + * gmp-impl.h (invert_pi1): Streamline, as suggested by Niels. + +2009-10-24 Torbjorn Granlund + + * mpn/generic/bdiv_q.c: Update to call new functions. + * mpn/generic/bdiv_qr.c: Likewise. + * mpn/generic/binvert.c: Likewise. + * mpn/generic/divexact.c: Likewise. + * mpn/generic/divis.c: Likewise. + * mpn/generic/perfpow.c: Likewise. + * mpn/generic/tdiv_qr.c: Likewise. + * mpn/generic/dcpi1_bdiv_q.c: New file. + * mpn/generic/dcpi1_bdiv_qr.c: New file. + * mpn/generic/dcpi1_div_q.c: New file. + * mpn/generic/dcpi1_div_qr.c: New file. + * mpn/generic/dcpi1_divappr_q.c: New file. + * mpn/generic/sbpi1_bdiv_q.c: New file. + * mpn/generic/sbpi1_bdiv_qr.c: New file. + * mpn/generic/sbpi1_div_q.c: New file. + * mpn/generic/sbpi1_div_qr.c: New file. + * mpn/generic/sbpi1_divappr_q.c: New file. + * mpn/generic/dc_bdiv_q.c: Removed. + * mpn/generic/dc_bdiv_qr.c: Removed. + * mpn/generic/dc_div_q.c: Removed. + * mpn/generic/dc_div_qr.c: Removed. + * mpn/generic/dc_divappr_q.c: Removed. + * mpn/generic/sb_bdiv_q.c: Removed. + * mpn/generic/sb_bdiv_qr.c: Removed. + * mpn/generic/sb_div_q.c: Removed. + * mpn/generic/sb_div_qr.c: Removed. + + * configure.in (gmp_mpn_functions): Add new division functions, remove + obsolete division functions. + + * gmp-impl.h: Add declarations of new division functions, remove + corresponding obsolete declarations. + (gmp_pi1_t, gmp_pi2_t): New types. + (invert_pi1): New macro for computing 2/1 and 3/2 inverses. + +2009-10-23 Niels Möller + + * gmp-impl.h (mpn_toom62_mul_itch): New function. + + * tests/mpn/t-toom53.c: New test program. + * tests/mpn/t-toom62.c: New test program. + +2009-10-23 Torbjorn Granlund + + * mpn/generic/get_d.c: Fix code handling denorms for 64-bit machines. + * tests/mpf/t-get_d.c (test_denorms): New function. + +2009-10-23 Niels Möller + + * mpn/generic/toom52_mul.c (mpn_toom52_mul): Use supplied scratch + space, not TMP_ALLOC. Interface change, now requires input sizes + such that s + t >= 5. + + * gmp-impl.h (mpn_toom52_mul_itch): New function. + + * tests/mpn/t-toom52.c: New test program. + +2009-10-22 Torbjorn Granlund + + * mpn/x86_64/sqr_basecase.asm: Tune for speed and a 7% size decrease. + +2009-10-22 Niels Möller + + * tests/mpn/t-toom44.c: New test program. + * tests/mpn/t-toom33.c: New test program. + + * tests/mpn/toom-shared.h (main): Reorganized input generation. + Users are now supposed to define macros MAX_AN, MIN_BN and MAX_BN. + Updated existing toom test programs. + +2009-10-22 Torbjorn Granlund + + * tests/devel/try.c: Fix typos in last change. + +2009-10-21 Torbjorn Granlund + + * mpn/asm-defs.m4 (define_mpn): Add mullow_basecase. + + * tests/devel/try.c: Test mpn_mullow_n. + + * tests/refmpn.c (refmpn_mullow_n): New function. + * tests/tests.h: Declare it. + +2009-10-21 Niels Möller + + * tests/mpn/toom-shared.h (main): Check for writes outside of the + product or scratch area. + + * gmp-impl.h (mpn_toom43_mul_itch): New function. + + * mpn/generic/toom43_mul.c (mpn_toom43_mul): Use supplied scratch + space, not TMP_ALLOC. Interface change, now requires input sizes + such that s + t >= 5. + +2009-10-20 Niels Möller + + * tests/mpn/toom-shared.h (MIN_BLOCK): New constant, which can be + overridden by users. Needed by t-toom42 and t-toom43. + + * tests/mpn/Makefile.am (check_PROGRAMS): Added t-toom32, + t-toom42 and t-toom43. + * tests/mpn/t-toom43.c: New test program. + * tests/mpn/t-toom42.c: New test program. + * tests/mpn/t-toom32.c: New test program. + + * tests/mpn/Makefile.am (check_PROGRAMS): Added t-toom22. + * tests/mpn/t-toom22.c: New test file. + * tests/mpn/toom-shared.h: New file. Test framework for Toom + functions. + +2009-10-14 Niels Möller + + * mpn/generic/hgcd.c (mpn_hgcd_itch): Thanks to the new + mpn_matrix22_mul_strassen, the scratch need is reduced by 16%. + +2009-10-14 Marco Bodrato + + * mpn/generic/matrix22_mul.c (mpn_matrix22_mul_strassen): New + Strassen-like algorithm, to reduce the amount of temporary + storage. + (mpn_matrix22_mul_itch): Updated to reflect the reduced storage + need. + +2009-10-03 Torbjorn Granlund + + * Rename mpn_addsub_n to mpn_add_n_sub_n. + +2009-10-01 Torbjorn Granlund + + * mpn/generic/tdiv_qr.c: Call mpn_divrem_1 and mpn_dc_div_qr instead of + old functions. + + * mpn/generic/mul_n.c: Call toom22 and toom33 instead of old functions. + + * mpn/generic/toom42_mul.c (TOOM42_MUL_N_REC): Renamed from + TOOM22_MUL_N_REC. Unconditionally call the generic mpn_mul_n. + * mpn/generic/toom32_mul.c: Analogous changes. + +2009-09-28 Niels Möller + + * mpn/x86_64/invert_limb.asm: Rewrite. Exploit cancellation in the + Newton iteration. + +2009-09-27 Niels Möller + + * mpn/x86/invert_limb.asm: Reduce register usage. Eliminated $1 + arguments to add, sub and shift. + +2009-09-25 Niels Möller + + * mpn/x86/invert_limb.asm: New file. + +2009-09-24 Torbjorn Granlund + + * mpn/generic/toom33_mul.c: Use new toom functions for all recursive + products. + * mpn/generic/toom3_sqr.c: Likewise. + * mpn/generic/toom44_mul.c: Likewise. + * mpn/generic/toom4_sqr.c: Likewise. + + * mpn/generic/add_n.c: Relax operand overlap ASSERTs. + * mpn/generic/sub_n.c: Likewise. + +2009-09-15 Torbjorn Granlund + + Suggested by Uwe Mueller: + * printf/doprnt.c: Use "%ld" for exponent printing. + * printf/doprntf.c (__gmp_doprnt_mpf): Make expval "long". + +2009-09-14 Torbjorn Granlund + + * configure.in: Handle mingw64. + * gmp-impl.h (gmp_intptr_t): Declare. + * tests/amd64check.c (calling_conventions_values): Use CNST_LIMB. + * tests/memory.c: Use gmp_intptr_t; print pointers using C90 "%p". + * tests/misc.c: Use gmp_intptr_t. + * tests/mpq/t-get_str.c: Print pointers using C90 "%p". + +2009-08-12 Torbjorn Granlund + + * mpn/generic/mod_1_1.c (mpn_mod_1_1p_cps): Remove silly ASSERT code. + + * mpn/asm-defs.m4 (define_mpn): Remove mod_1s_1p, add mod_1_1p. + + * mpn/arm/invert_limb.asm: Complete rewrite. + + * longlong.h: Document LONGLONG_STANDALONE and NO_ASM. + +2009-08-05 Torbjorn Granlund + + * tests/mpz/dive_ui.c (check_random): Avoid zero divisors. + +2009-07-31 Torbjorn Granlund + + * mpn/generic/mod_1_1.c: Tweak to handle any modulus (possibility + pointed out by Per Austrin). + (mpn_mod_1_1p): Renamed from mpn_mod_1s_1p. + (mpn_mod_1_1p_cps): Renamed from mpn_mod_1s_1p_cps. + *mpn/generic/mod_1.c (mpn_mod_1): Reorganise to call mpn_mod_1_1p for + any modulus. + +2009-07-28 Torbjorn Granlund + + * configure.in: Pass arch for x86 also in 64-bit mode. + +2009-07-26 Torbjorn Granlund + + * config.guess (_cpuid): Recognise more Intel "Core" processors. + +2009-07-13 Torbjorn Granlund + + * mpf/eq.c: Rewrite. + + * tests/mpf/t-eq.c: New test. + +2009-07-06 Torbjorn Granlund + + * gmp-impl.h (__mp_bases): Remove this alias. + + * mpf/get_str.c: Use less overflow prone expression for computing limb + allocation. + * mpz/inp_str.c: Likewise. + * mpf/set_str.c: Likewise. + * mpz/set_str.c: Likewise. + +2009-07-03 Niels Möller + + * mpn/generic/gcd_1.c (mpn_gcd_1): Use masking tricks to reduce + the number of branches in the loop. + +2009-06-28 Torbjorn Granlund + + * demos/factorize.c (factor_using_pollard_rho): Rewrite. + + * mpz/clears.c: New file. + * mpq/clears.c: New file. + * mpf/clears.c: New file. + * gmp-h.in (mpz_clears, mpq_clears, mpf_clears): Declare. + * mpz/Makefile.am: Add clears.c. + * mpq/Makefile.am: Add clears.c. + * mpf/Makefile.am: Add clears.c. + * Makefile.am: Add these also to respective OBJECTS variables. + * doc/gmp.texi: Document inits function and clears functions. + +2009-06-20 Torbjorn Granlund + + * mp-h.in (mp_bitcnt_t): Declare here too. + +2009-06-19 Torbjorn Granlund + + * mpq/inits.c: New file. + * mpf/inits.c: New file. + * gmp-h.in (mpz_inits, mpq_inits, mpf_inits): Declare . + + * mpn/generic/remove.c: New file. + * configure.in (gmp_mpn_functions): Add remove. + * gmp-impl.h (mpn_remove): Declare. + + * gmp-h.in (mp_bitcnt_t): New basic type. + * mpn/generic/perfpow.c (mp_bitcnt_t): Remove private definition. + + * mpn/generic/bdiv_qr.c: Make it actually work. + + * mpn/x86_64/core2/aorsmul_1.asm: Rewrite to use shorter pipeline and + to need fewer registers. + +2009-06-17 Torbjorn Granlund + + * mpn/x86_64/rsh1aors_n.asm: New file. + * mpn/x86_64/rsh1add_n.asm: Remove. + * mpn/x86_64/rsh1sub_n.asm: Remove. + + * mpz/inits.c: New file. + + * gen-trialdivtab.c: Wrap limb constants into CNST_LIMB. + + With Martin Boij: + * mpn/generic/perfpow.c (binv_root, binv_sqroot): Change from being + recursive to being iterative. + (mpn_perfect_power_p): Reorganise temp memory usage to avoid a buffer + overrun. Trim allocation of next and prev. Never create oversize + products in the multiplicity binary search. + + * mpn/generic/dc_div_q.c: Add missing TMP_FREE. + +2009-06-16 Torbjorn Granlund + + Revert: + * mpn/generic/perfpow.c (perfpow): Test exponents up to ub, inclusive. + +2009-06-16 Martin Boij + + * mpn/generic/perfpow.c (logs): Use more conservative table. + +2009-06-15 Torbjorn Granlund + + * mpn/pa64/aors_n.asm: New file. + * mpn/pa64/add_n.asm: Remove. + * mpn/pa64/sub_n.asm: Remove. + + * mpn/generic/perfpow.c (perfpow): Test exponents up to ub, inclusive. + +2009-06-14 Torbjorn Granlund + + * mpn/x86_64/bdiv_q_1.asm: Optimise away a mov insn. + * mpn/x86_64/dive_1.asm: Likewise. + + * mpn/generic/perfpow.c (binv_root): Use mpn_bdiv_q_1, not + mpn_divexact_itch for 2-adic division. + (all functions): Micro optimise. + + * Makefile.am (libmp_la_SOURCES): Add nextprime.c. + +2009-06-13 Torbjorn Granlund + + * gmp-h.in (mpn_perfect_power_p): Declare. + * configure.in (gmp_mpn_functions): Add perfpow. + * mpz/perfpow.c: Now trivial, simply calls mpn_perfect_power_p. + +2009-06-13 Martin Boij + + * mpn/generic/perfpow.c: New file. + * tests/mpz/t-perfpow.c: Rewrite. + +2009-06-12 Torbjorn Granlund + + * mpn/generic/bdiv_qr.c: New file. + * mpn/generic/bdiv_q.c: New file. + * configure.in (gmp_mpn_functions): Add bdiv_qr and bdiv_q. + * gmp-impl.h: Declare new functions. + + * nextprime.c: New file. + * gmp-impl.h (gmp_primesieve_t, gmp_init_primesieve, gmp_nextprime): + Declare. + * Makefile.am (libgmp_la_SOURCES): Add nextprime.c. + +2009-06-11 Torbjorn Granlund + + * mpn/generic/trialdiv.c: New file. + * gen-trialdivtab.c: New file. + * configure.in (gmp_mpn_functions): Add trialdiv. + * gmp-impl.h (mpn_trialdiv): Declare + * Makefile.am: Add rules for gen-trialdivtab and trialdiv. + + * longlong.h (arm count_leading_zeros): Define for armv5. + + * gmp-impl.h: Move down toom itch functions to after we've #defined + all THRESHOLDs. + + * dumbmp.c (isprime): Replace with slightly less inefficient code. + (mpz_tdiv_r): New function. + +2009-06-11 Niels Möller + + Support for mpn_toom32_mul in speed: + * tune/speed.c (routine): Added mpn_toom32_mul. + * tune/speed.h (SPEED_ROUTINE_MPN_TOOM32_MUL): New macro. + * tune/common.c (speed_mpn_toom32_mul): New function. + + * gmp-impl.h (mpn_toom32_mul_itch): Count scratch space needed + for the calls to mpn_toom22_mul. + (ABOVE_THRESHOLD): Moved this and related macros so it can be used + by mpn_toom32_mul_itch. + (mpn_toom22_mul_itch): Count scratch space for recursive calls. + +2009-06-11 Torbjorn Granlund + + * mpn/x86/k7/mod_1_4.asm: New file, mainly for k7, but perhaps useful + also for k6 and non-sse p6. + +2009-06-10 Torbjorn Granlund + + * mpn/x86_64/mod_1_4.asm: Minor size reducing tweaks. + + * mpn/x86/mod_1.asm: Remove obsolete file. + * mpn/x86/k7/mmx/mod_1.asm: Likewise. + * mpn/x86/pentium4/sse2/mod_1.asm: Likewise. + * mpn/x86/p6/mod_1.asm: Likewise. + * mpn/x86/pentium/mod_1.asm: Likewise. + +2009-06-08 Niels Möller + + * mpn/generic/toom4_sqr.c (mpn_toom4_sqr): Reorganized, to reduce + the need for scratch space, and get rid of TMP_ALLOC. Also use + mpn_toom_eval_dgr3_pm1. + + * mpn/generic/toom_interpolate_6pts.c (mpn_toom_interpolate_6pts): + Stricter ASSERTs based on maximum size of polynomial coefficients. + Improved comments on the signedness of intermediate values. + +2009-06-07 Torbjorn Granlund + + * mpn/generic/toom2_sqr.c: Make it actually work. + + * mpn/generic/toom3_sqr.c: Reduce local scratch space. + +2009-06-05 Torbjorn Granlund + + * mpn/generic/mul_fft.c (FFT_TABLE2_SIZE): Default to 200. + (MUL_FFT_TABLE2_SIZE, SQR_FFT_TABLE2_SIZE): Let these decide + FFT_TABLE2_SIZE if they are defined. + (struct nk): Use bit field. + +2009-06-05 Niels Möller + + * mpn/generic/toom44_mul.c (mpn_toom44_mult): Use + mpn_toom_eval_dgr3_pm1. + + * mpn/generic/toom_eval_dgr3_pm1.c: New file. + + * mpn/generic/toom_interpolate_7pts.c (mpn_toom_interpolate_7pts): + Minor cleanup, use mpn_add rather than mpn_add_n + MPN_INCR_U. + + * mpn/generic/toom44_mul.c (mpn_toom44_mul): Reorganized, to + reduce the need for scratch space, and get rid of TMP_ALLOC. + +2009-06-05 Torbjorn Granlund + + * mpn/generic/toom_interpolate_7pts.c: Fall back mpn_divexact_byN to + mpn_bdiv_q_1_pi1, if the latter is NATIVE. + +2009-06-04 Torbjorn Granlund + + * mpn/x86_64/bdiv_q_1.asm: New file. + + * configure.in (HAVE_NATIVE): Add recently added functions. + (GMP_MULFUNC_CHOICES): Handle addlsh_n, sublsh_n, rsblsh_n. + + * tune/common.c (speed_mpn_bdiv_q_1, speed_mpn_bdiv_q_1_pi1): + New functions. + * tune/speed.c (routine): Add mpn_bdiv_q_1 and mpn_bdiv_q_1_pi1. + * tune/speed.h (SPEED_ROUTINE_MPN_BDIV_Q_1_PI1): New #define. + (SPEED_ROUTINE_MPN_BDIV_Q_1): Mew #define. + + * configure.in (gmp_mpn_functions): Add bdiv_q_1. + * mpn/generic/bdiv_q_1.c: New file. + * mpn/asm-defs.m4 (define_mpn): Add mpn_bdiv_q_1 and mpn_bdiv_q_1_pi1. + * gmp-impl.h (mpn_bdiv_q_1, mpn_bdiv_q_1_pi1): Declare. + + * mpn/x86_64/lshift.asm: Cleanup. + * mpn/x86_64/rshift.asm: Cleanup. + + * mpn/x86_64/addlsh1_n.asm: Removed. + * mpn/x86_64/aorrlsh1_n.asm: Generalised addlsh1_n.asm to handle + addlsh1_n and rsblsh1_n functionality. + + * tests/refmpn.c (refmpn_rsblsh1_n): New function. + * tests/devel/try.c: Test mpn_rsblsh1_n. + * tests/tests.h: Declare refmpn_rsblsh1_n. + * tune/common.c (speed_mpn_rsblsh1_n): New function. + * tune/speed.c (routine): Add mpn_rsblsh1_n. + * tune/speed.h (mpn_rsblsh1_n): Declare. + + * configure.in (gmp_mpn_functions_optional): Add rsblsh1_n. + (GMP_MULFUNC_CHOICES): Handle rsblsh1_n defined with a mulfunc. + * mpn/asm-defs.m4 (define_mpn): Add rsblsh1_n. + * gmp-impl.h (mpn_rsblsh1_n): Declare. + + * mpn/generic/toom32_mul.c: Consistently use TOOM22_MUL_N_REC. + +2009-06-03 Marco Bodrato + + * mpn/generic/toom43_mul.c: New file. + * mpn/generic/toom52_mul.c: New file. + * mpn/generic/toom_interpolate_6pts.c: New file. + +2009-06-03 Torbjorn Granlund + + * configure.in (gmp_mpn_functions): Add toom43_mul, toom52_mul, and + toom_interpolate_6pts, but also some previously forgotten functions. + * mpn/Makefile.am (nodist_EXTRA_libmpn_la_SOURCES): Likewise. + * gmp-impl.h: Declare new functions. Sort toom function declarations. + + * gmp-impl.h: Rename toom4_* flags enum to toom7_*. Relevant C files + updated. + + * mpn/generic/toom_interpolate_7pts (divexact_2exp): Remove. + +2009-06-02 Torbjorn Granlund + + * demos/factorize.c: Add -q command line option. + +2009-06-02 Marco Bodrato + + * mpn/generic/toom_interpolate_7pts.c: Streamline, resulting in speed + improvements. + + * mpn/generic/toom_interpolate_5pts.c: Likewise, but also completely + do away with explicit scratch space. + * gmp-impl.h (mpn_toom_interpolate_5pts): Update prototype. + + * mpn/generic/mul_n.c (mpn_toom3_sqr_n, mpn_toom3_mul_n): + Update toom_interpolate_5pts call without scratch space parameter. + * mpn/generic/toom3_sqr.c: Likewise. + * mpn/generic/toom42_mul.c: Likewise. + * mpn/generic/toom33_mul.c: Likewise. + + * mpn/generic/toom33_mul.c: Reduce local scratch space. + * mpn/generic/toom32_mul.c: Rewrite to not use local scratch space. + +2009-06-02 Torbjorn Granlund + + * mpn/generic/toom22_mul.c (TOOM22_MUL_MN_REC): New macro, use it for + oo point. + +2009-06-01 Torbjorn Granlund + + * mpn/generic/mul.c: Loop to avoid excessive recursion in toom33 and + toom44 slicing code. + + * mpz/remove.c: Correctly handle multiplicity that does not fit an int. + + * Makefile.am (dist-hook): Check library version consistency. + + * mpn/generic/mul.c: Rewrite. + +2009-05-29 Torbjorn Granlund + + * tests/mpz/t-divis.c (check_random): Create huge test operands. + + * mpn/generic/toom44_mul.c: Allocate temp space using one TMP_ALLOC + call, not multiple TMP_SALLOC. + * mpn/generic/toom4_sqr.c: Likewise. + + * gmp-impl.h (mpn_toom22_mul_itch): Replace totally wrong code. + + * mpn/generic/mullow_n.c: Relax overlap requirement implied by ASSERT. + + * mpn/generic/divis.c: Rewrite. + + * gmp-impl.h (mpn_mu_bdiv_qr): Now returns mp_limb_t. + (mpn_toom2_sqr_itch): Simplify. + + * mpn/generic/mu_bdiv_qr.c: Implement properly. + +2009-05-27 Torbjorn Granlund + + * mpn/generic/mod_1_1.c: Add proper ASSERT functionality cps function. + * mpn/generic/mod_1_2.c: Likewise. + * mpn/generic/mod_1_3.c: Likewise. + * mpn/generic/mod_1_4.c: Likewise. + + * tune: Add speed measuring of toom22, toom33, and toom44. + + * mpn/generic/toom22_mul.c: Handle potentially unbalanced coefficient + product better. + +2009-05-26 Torbjorn Granlund + + * tests/mpz/t-mul.c (ref_mpn_mul): Use mpn_toom44_mul in FFT range for + better huge-operands performance. + +2009-05-24 Torbjorn Granlund + + * acinclude.m4 (GMP_ASM_LSYM_PREFIX): Try "$L" too, before "$". + +2009-05-23 Torbjorn Granlund + + * gmp-impl.h (mpn_mod_1s_1p,mpn_mod_1s_2p,mpn_mod_1s_3p,mpn_mod_1s_4p): + Declare using __GMP_ATTRIBUTE_PURE. + + * tune/tuneup.c (tune_mod_1): Specify check_size for measuring mod_1_N + functions. + (one): Remove redundant size loop exit condition. + +2009-05-20 Torbjorn Granlund + + * mpn/x86/pentium4/sse2/mod_1_4.asm: New file. + * mpn/x86/p6/sse2/mod_1_4.asm: New file (grabbing pentium4 code). + +2009-05-18 Torbjorn Granlund + + * gmp-h.in (__GNU_MP_VERSION_MINOR): Bump to 4. + (__GNU_MP_VERSION_PATCHLEVEL): Set to -1. + + * mpn/x86_64/mod_1_4.asm: New file. + + * mpn/asm-defs.m4: Correct names for mod_1_N functions. + Add defines for corresponding cps functions. + + * mpn/generic/mod_1_2.c: Support any sizes > 1. + * mpn/generic/mod_1_3.c: Likewise. + * mpn/generic/mod_1_4.c: Likewise. + +2009-05-12 Torbjorn Granlund + + * Version 4.3.1 released. + +2009-05-11 Torbjorn Granlund + + * gmp-h.in (__GNU_MP_VERSION_MINOR): Bump. + + * Makefile.am (LIBGMP_LT_*, LIBGMPXX_LT_*, LIBMP_LT_*): + Bump version info. + +2009-05-09 Torbjorn Granlund + + * tests/mpz: Add MPZ_CHECK_FORMAT to many tests. + +2009-05-07 Torbjorn Granlund + + * mpn/x86/pentium4/sse2/mul_basecase.asm: Avoid L(ret), "ret" is + defined in x86-defs.m4. + +2009-05-06 Torbjorn Granlund + + * mpn/x86/p6/aors_n.asm: Use L() for labels. + * mpn/x86/pentium4/sse2/addmul_1.asm: Likewise. + * mpn/x86/pentium4/sse2/mul_1.asm: Likewise. + * mpn/x86/pentium4/sse2/mul_basecase.asm: Likewise. + * mpn/x86/pentium4/sse2/sqr_basecase.asm: Likewise. + * mpn/x86_64/lshift.asm: Likewise. + * mpn/x86_64/rshift.asm: Likewise. + + * tests/cxx/t-locale.cc (point_string): Declare as extern "C" to + placate compilers that mangle variable names. + +2009-05-04 Torbjorn Granlund + + * tests/mpz/t-gcd.c: Generate operands that are multiple of each other. + +2009-05-01 Torbjorn Granlund + + * gmp-h.in (__GMP_EXTERN_INLINE): Support for more systems. + (gmp_randinit_set): Add missing __GMP_DECLSPEC. + +2009-04-28 Torbjorn Granlund + + * mpn/generic/neg_n.c: New file. + * configure.in (gmp_mpn_functions): Add neg_n. + * mpn/asm-defs.m4 (define_mpn): Add neg_n. + * mpn/Makefile.am (nodist_EXTRA_libmpn_la_SOURCES): Add neg_n.c. + * gmp-h.in: Handle mpn_neg_n properly. + + * mpn/generic/toom_interpolate_7pts.c (divexact_2exp): Nailify. + + * mpn/generic/gcdext.c: Change some MPN_NORMALIZE to + MPN_NORMALIZE_NOT_ZERO. + * mpn/generic/gcdext_lehmer.c: Likewise. + Add a MPN_NORMALIZE_NOT_ZERO. + + * mpn/generic/binvert.c: Remove own mpn_neg_n. + + * tests/mpz/t-gcd.c: Add some MPZ_CHECK_FORMAT calls. + +2009-04-27 Torbjorn Granlund + + * mpn/Makefile.am (TARG_DIST): Add minithres. + + * mpn/generic/bdiv_dbm1c.c: Handle nails. + +2009-04-26 Torbjorn Granlund + + * config.guess: Recognise more POWER processor types. + +2009-04-25 Torbjorn Granlund + + * mpn/x86/pentium4/sse2/popcount.asm: Work around Apple reloc bug. + * mpn/x86/darwin.m4: Define symbol "DARWIN". + +2009-04-19 Torbjorn Granlund + + * mpn/generic/powm.c (mpn_redc_n): Use ASSERT_ALWAYS, not abort(). + * mpn/generic/powm_sec.c: Likewise. + + * mpn/powerpc64/aix.m4 (EXTERN_FUNC): New define. Add dummy variants + for other m4 files. + * mpn/powerpc64/mode64/divrem_1.asm: Use EXTERN_FUNC. + * mpn/powerpc64/mode64/divrem_1.asm: Likewise. + +2009-04-16 Torbjorn Granlund + + * mpn/x86_64/x86_64-defs.m4 (JUMPTABSECT): New define. + * mpn/x86_64/darwin.m4: Likewise. + * mpn/x86_64/sqr_basecase.asm: Rework switch code using JUMPTABSECT. + + * tune/common.c (speed_mpn_hgcd, speed_mpn_hgcd_lehmer): + Remove an unused variable. + + * mpn/x86/x86-defs.m4 (LEA): Get SIZE arguments right. + +2009-04-14 Torbjorn Granlund + + * Version 4.3.0 released. + + * scanf/doscan.c (__gmp_doscan): Pad 3-operand scanf call with dummy + argument. + * scanf/sscanffuns.c (scan): Disable vsscanf variant for now. + +2009-04-13 Torbjorn Granlund + + * scanf/sscanffuns.c (scan): Rewrite to use stdarg. + + * tests/mpz/t-root.c: Rewrite. Add unconditional gcc 4.3.2 tests. + +2009-04-09 Torbjorn Granlund + + * mpn/generic/powm.c: New file. + * mpn/generic/powlo.c: New file. + * mpn/generic/powm_sec.c: New file. + * configure.in (gmp_mpn_functions): List new functions. + +2009-04-08 Torbjorn Granlund + + * mpz/urandomm.c: Amend last fix. + +2009-04-06 Torbjorn Granlund + + * configure.in: Support Sun cc for x86_64. + + * mpz/urandomm.c: Handle operand overlap. + +2009-03-11 Torbjorn Granlund + + * configure.in (powerpc): Brave removing -Wa,-mppc64, in the hope that + GCC now passes the proper options. + +2009-03-09 Torbjorn Granlund + + * mpn/x86_64/divrem_1.asm: Add a nop to save a cycle in unnormalised + case. + +2009-03-05 Torbjorn Granlund + + * ia64/gmp-mparam.h, arm/gmp-mparam.h, x86/p6/mmx/gmp-mparam.h, + pa32/hppa2_0/gmp-mparam.h sparc32/v9/gmp-mparam.h: Update. + +2009-03-03 Torbjorn Granlund + + * mpn/ia64/bdiv_dbm1c.asm: Accept/return carry. + +2009-03-02 Torbjorn Granlund + + * configure.in (64-bit sparc/solaris): Pass -xO3, not -O3 to solaris + system compiler. + +2009-03-01 Torbjorn Granlund + + * longlong.h (mips, powerpc): Provide assembly-free umul_ppmm for newer + gcc. + +2009-02-04 Torbjorn Granlund + + * mpn/generic/redc_2.c: Remove code for testing and timing. Update + to current FSF header. + * mpn/generic/redc_1.c: Update to current FSF header. + +2009-01-21 Torbjorn Granlund + + * mpz/powm.c (redc): Remove. + (mpz_powm): Use mpn_redc_1 instead of redc. + + * tests/mpz/t-powm.c: Rewrite reference code. + +2009-01-18 Torbjorn Granlund + + * tests/mpz: Increase reps for many tests. + + * mpn/generic/rootrem.c (mpn_rootrem_internal): Use MPN_DECR_U instead of + mpn_sub_1 (works around gcc 4.3 bugs and is also faster). + +2009-01-16 Torbjorn Granlund + + * tests/tests.h: Declare refmpn_divrem_2. + +2009-01-15 Torbjorn Granlund + + * mpz/perfpow.c: Add TMP_FREE before every return statement. + + * mpn/generic/rootrem.c (mpn_rootrem_internal): Add a missing TMP_FREE. + + * configure.in (gcc_cflags, gcc_64_cflags): Revert from -O3 to -O2, + the change was accidental and cause too much miscompilation. + +2009-01-14 Torbjorn Granlund + + * tune/tuneup.c (tune_mod_1): Run MOD_1_x_THRESHOLD tests also when + longlong.h specified UDIV_PREINV_ALWAYS. + + * mpn/generic/mod_1.c (mpn_mod_1): Properly check for normalisation + divisor. + +2009-01-13 Torbjorn Granlund + + * tune/tuneup.c (tune_mod_1): Tune for MOD_1_1_THRESHOLD, + MOD_1_2_THRESHOLD, and MOD_1_4_THRESHOLD. + + * mpn/generic/mod_1.c: Rewrite. + * mpn/generic/mod_1_1.c: New file. + * mpn/generic/mod_1_2.c: New file. + * mpn/generic/mod_1_3.c: New file. + * mpn/generic/mod_1_4.c: New file. + * configure.in (gmp_mpn_functions): Add mod_1_*. + * mpn/asm-defs.m4 (define_mpn): Add mod_1_*. + * mpn/Makefile.am (nodist_EXTRA_libmpn_la_SOURCES): Add mod_1_*.c. + * gmp-impl.h: Declare new mpn_mod_1s_* functions and associated + THRESHOLD macros. + (udiv_rnd_preinv): New macro. + +2009-01-12 Torbjorn Granlund + + * tune/tuneup.c (tune_gcd_dc,tune_gcdext_dc): Lower step_factor to 0.1. + +2009-01-08 Torbjorn Granlund + + * tests/mpz/t-nextprime.c: New test file. + * tests/mpz/Makefile.am (check_PROGRAMS): Add t-nextprime. + + From Niels Möller: + * mpz/nextprime.c: Handle large prime gaps by limiting incr. + +2009-01-04 Torbjorn Granlund + + * mpz/and.c, mpz/ior.c, mpz/xor.c: Re-read only necessary source + pointers after reallocation. Misc cleanup. + + * gmp-impl.h (MPN_TOOM44_MAX_N): New define, replaces MPN_TOOM3_MAX_N. + + * mpn/x86/fat/diveby3.c: New file. + +2008-12-30 Niels Möller + + * doc/gmp.texi (Greatest Common Divisor Algorithms): Updated + section on GCD algorithms. + +2008-12-29 Torbjorn Granlund + + * doc/gmp.texi (Multiplication Algorithms): Add descriptions of Toom-4 + and unbalanced multiplication. + (Radix to Binary): Add warning that text is outdated, + (Contributors): Fix typos. + + * mpn/generic/toom*.c: Use coherent MAYBE_ macros for trimming + unreachable recursive functions. + * gmp-impl.h: Update toom itch functions. + + * mpn/x86_64/sqr_basecase.asm: Slightly increase stack allocation, to + placate tuneup. + +2008-12-28 Torbjorn Granlund + + * mpn/x86_64/pentium4/aors_n.asm: Tune prologue code. + + * mpn/x86_64/pentium4/aorslsh1_n.asm: New file. + + * mpn/x86_64/darwin.m4: Define symbol "DARWIN". + * mpn/x86_64/invert_limb.asm: Work around darwin quirks. + + * mpn/x86_64/sqr_basecase.asm: Further optimize, support Darwin. + + * mpn/x86_64/invert_limb.asm: New file. + +2008-12-27 Torbjorn Granlund + + * mpn/x86_64/core2/aorslsh1_n.asm: New file. + +2008-12-26 Torbjorn Granlund + + * mpz/perfpow.c: Handle negative arguments properly. + * tests/mpz/t-perfpow.c: New file. + * tests/mpz/Makefile.am (check_PROGRAMS): Add t-perfpow. + +2008-12-23 Torbjorn Granlund + + * tests/mpz/t-mul.c (dump_abort): Improve error message. + + * gcd.c gcd_subdiv_step.c gcdext.c gcdext_subdiv_step.c: + Remove private mpn_zero_p. + + * tune/tuneup.c (tune_mul): Tune for MUL_TOOM44_THRESHOLD. + (tune_sqr): Tune for SQR_TOOM4_THRESHOLD. + + * tune/Makefile.am (TUNE_MPN_SRCS_BASIC): Add toom44_mul.c and + toom4_sqr.c. + + * configure.in (gmp_mpn_functions): Toom function updates. + + * Rename mpn/mul_toomMN.c to mpn/toomMN_mul.c. Function names changed + accordingly. + + * mpn/toomMN_mul.c: Add scratch parameter. Do recursive multiplies + properly. Misc tuning. Remove CHECK and TIMING code. + + * mpn/toom2_sqr.c, mpn/toom3_sqr.c, mpn/toom4_sqr.c: New files. + + * gmp-impl.h (mpn_toomMN_mul_itch): Several new functions. + (mpn_zero_p): New functions. + Add various TOOM4/TOOM44 related parameters. + Update mpn_toomMN_mul prototypes. + + * mpn/generic/mul_n.c (mpn_mul_n): Call mpn_toom44_mul. Use TMP_BALLOC + instead of malloc. + (mpn_sqr_n): Analogous changes. + + * mpn/generic/mul.c: Update unbalanced toom code to pass scratch space. + +2008-12-21 Torbjorn Granlund + + * mpz/nextprime.c: Add TMP_SDECL/MARK/FREE. + +2008-12-20 Torbjorn Granlund + + * mpn/generic/sqrtrem.c (mpn_sqrtrem1): Rewrite, improve interface. + (invsqrttab): New table, remove table approx_tab. + (mpn_sqrtrem2): Optimize, update mpn_sqrtrem1 call. + (mpn_sqrtrem): Update mpn_sqrtrem1 call. + +2008-12-18 Torbjorn Granlund + + * mpz/nextprime.c: Run 10 mpz_millerrabin tests (was 5). + Give credit to authors. + + * mpn/x86_64/redc_1.asm: Align stack as mandated by ABI. + + * mpn/x86_64/divrem_2.asm: Add some comments. + + * mpn/x86_64/darwin.m4: New file. + * configure.in: Use x86_64/darwin.m4. + +2008-12-15 Torbjorn Granlund + + * doc/projects.html: Remove GCD and division projects, update text on + multiplication. + + * doc/tasks.html: Add a caution about that the file is somewhat + outdated. + +2008-12-14 Torbjorn Granlund + + * mpn/alpha/ev6/aorsmul_1.asm: New file (same code for mpn_addmul_1, + much improved for mpn_submul_1). + * mpn/alpha/ev6/addmul_1: File removed. + * mpn/alpha/ev6/submul_1: File removed. + +2008-12-09 Torbjorn Granlund + + From David Harvey: + * mpn/x86_64/mul_basecase.asm: Further tweaks for code size and speed. + + * mpn/powerpc64/mode64/divrem_1.asm: Rewrite. + + * mpn/powerpc64/mode64/mul_basecase.asm: New file. + +2008-12-08 Torbjorn Granlund + + * mpn/powerpc64/mode64/gmp-mparam.h: New file. + + * gmp-impl.h: Additional cleanups. + (mpn_set_str_compute_powtab): New prototype. + (mpn_powm, mpn_powlo): New prototypes. + + * mpz/pow_ui.c: Handle some small exponents locally. + +2008-12-07 Torbjorn Granlund + + * mpn/generic/set_str.c: Remove prototypes (they are in gmp-impl.h). + + * tune/set_strs.c, tune/set_strb.c: Make prototypes effective by moving + the #define mpn_set_str* before including gmp-impl.h. + + * All files: Change _PROTO => __GMP_PROTO. + + * tune/speed.c (routine): Remove non-working choice mpn_set_str_subquad. + * tune/common.c (speed_mpn_dc_set_str): Remove, it is broken. + + * mpn/generic/toom_interpolate_7pts.c (divexact_2exp): Make this static, + and inline it. + + * gmp-impl.h: Major cleanup. + (Remove formal parameter names. Use __GMP_PROTO consistently. Move + __GMP_PROTO and __MPN use to adjacent lines for declared function. + Fix typos. Remove code inside #if 0.) + + * configure.in (gmp_mpn_functions): Add mul_toom33. Reformat. + +2008-12-05 Torbjorn Granlund + + * mpn/generic/redc_1.c: New file. + * mpn/generic/redc_2.c: New file. + + * configure.in (gmp_mpn_functions): List redc_1 and redc_2. + (HAVE_NATIVE): Likewise. + + * tune/common.c (speed_mpn_redc_1): Renamed from speed_redc. + * tune/speed.c (routine): Remove "redc", and "mpn_redc_1". + * tune/speed.h (SPEED_ROUTINE_REDC_1): Renamed from SPEED_ROUTINE_REDC. + Updated call. + * tune/tuneup.c (tune_powm): Update redc call. + +2008-12-04 Torbjorn Granlund + + * mpn/x86_64/sqr_basecase.asm: Inline a combined diagonal product code + and addlsh1 loop. Misc cleanup. + +2008-12-02 Torbjorn Granlund + + * mpn/x86_64/sqr_basecase.asm: New file. + +2008-11-30 Torbjorn Granlund + + * mpn/generic/sqr_basecase.c: Fix typo in mpn_addmul_2s variant. + +2008-11-28 Torbjorn Granlund + + * mpn/x86_64/redc_1.asm: Rewrite. + +2008-11-27 Torbjorn Granlund + + * tests/refmpn.c (refmpn_redc_1): New function. + +2008-11-25 Torbjorn Granlund + + * mpn/x86/k7/aorsmul_1.asm: Actually handle mpn_submul_1. + +2008-11-23 Torbjorn Granlund + + * mpn/x86_64/divrem_1.asm: Rewrite. + + * alpha/divrem_2.asm: New file. + * powerpc32/divrem_2.asm: New file. + * powerpc64/mode64/divrem_2.asm: New file. + * x86/divrem_2.asm: New file. + * x86_64/divrem_2.asm: New file. + * tests/refmpn.c (refmpn_divrem_2): New function. + +2008-11-22 Torbjorn Granlund + + * mpn/x86/k7/mul_1.asm: Rewrite for smaller size and better speed. + * mpn/x86/k7/aorsmul_1.asm: Likewise. + + * acinclude.m4 (GMP_VERSION): Include last component even when zero. + +2008-11-21 Torbjorn Granlund + + * mpn/x86_64/README: Rewrite. + + * tests/devel/try.c (malloc_region, mprotect_maybe): Add casts for + printf type correctness. + + * gmp-h.in (__GNU_MP_VERSION_MINOR): Bump. + + * Makefile.am (LIBGMP_LT_*, LIBGMPXX_LT_*, LIBMP_LT_*): + Bump version info. + +2008-11-20 Torbjorn Granlund + + * gmp-impl.h: Rename modlimb_invert to binvert_limb. + * tune/speed.h: Likewise. + * tune/modlinv.c: Likewise. + * tune/common.c: Likewise. + * tests/t-modlinv.c: Likewise. + * tests/t-constants.c: Likewise. + * mpn/sparc64/mode1o.c: Likewise. + * mpn/alpha/dive_1.c: Likewise. + * mpn/sparc64/dive_1.c: Likewise. + * mpn/generic/mode1o.c: Likewise. + * mpn/generic/dive_1.c: Likewise. + * mpn/generic/bdivmod.c: Likewise. + * mpn/alpha/mode1o.asm: Likewise. + * mpn/asm-defs.m4: Likewise. + * mpn/ia64/mode1o.asm: Likewise. + * mpn/powerpc32/README: Likewise. + * mpn/powerpc32/mode1o.asm: Likewise. + * mpn/powerpc64/mode64/dive_1.asm: Likewise. + * mpn/powerpc64/mode64/mode1o.asm: Likewise. + * mpn/x86/dive_1.asm: Likewise. + * mpn/x86/k6/mmx/dive_1.asm: Likewise. + * mpn/x86/k6/mode1o.asm: Likewise. + * mpn/x86/k7/dive_1.asm: Likewise. + * mpn/x86/k7/mode1o.asm: Likewise. + * mpn/x86/p6/dive_1.asm: Likewise. + * mpn/x86/p6/mode1o.asm: Likewise. + * mpn/x86/pentium/dive_1.asm: Likewise. + * mpn/x86/pentium/mode1o.asm: Likewise. + * mpn/x86/pentium4/sse2/dive_1.asm: Likewise. + * mpn/x86/pentium4/sse2/mode1o.asm: Likewise. + * mpn/x86_64/dive_1.asm: Likewise. + * mpn/x86_64/mode1o.asm: Likewise. + + * mpn/x86_64/aors_n.asm: Replace with slightly faster, more alignment + neutral loop. + +2008-11-18 Torbjorn Granlund + + * configure.in: Remove gcd_finda related declarations. + * gmp-impl.h (mpn_gcd_finda): Remove declaration. + * mpn/Makefile.am (nodist_EXTRA_libmpn_la_SOURCES): Remove gcd_finda. + * mpn/asm-defs.m4: Remove define_mpn(gcd_finda). + * mpn/x86/k6/gcd_finda.asm: Remove file. + * tests/devel/try.c (param_init): Remove mpn_gcd_finda. + (choice_array): Remove mpn_gcd_finda. + * tests/mpn/t-instrument.c (check): Remove testing of mpn_gcd_finda. + * tests/refmpn.c (refmpn_gcd_finda): Remove. + * tests/tests.h (refmpn_gcd_finda): Remove declaration. + * tune/common.c (speed_mpn_gcd_finda): Remove. + * tune/gcd_finda_gen.c: Remove file. + * tune/speed.h (speed_mpn_gcd_finda): Remove declaration. + * tune/speed.c (routine): Remove mpn_gcd_finda entry. + + * tests/mpz/t-powm.c: Print test number when failing a test. + + * mpn/x86_64/redc_1.asm (CALL): Move from here... + * mpn/x86_64/x86_64-defs.m4: ...to here. + + * gmp-impl.h (mpn_jacobi_base): Remove parameter names. + +2008-11-11 Torbjorn Granlund + + * tests/mpf/t-conv.c: Add some specific tests, supplementing the random + tests. + +2008-11-09 Torbjorn Granlund + + * mpf/set_str.c: Default 'base' before letting exp_base inherit it. + + * tests/cxx/t-prec.cc: Use the right precision for all float constants. + +2008-11-08 Torbjorn Granlund + + * doc/gmp.texi (Float Comparison): Update mpf_eq documentation. + + * mpf/eq.c: Compare the right number of bits. + +2008-11-02 Torbjorn Granlund + + Undo, it made testing too slow: + * tests/mpz/t-mul.c: Use slower geometric progression for operand + sizes. + + * mpn/x86/k7/mod_34lsub1.asm: Use movzb for masking low 8 bits. + +2008-10-31 Niels Möller + + * mpn/generic/hgcd2.c (div1): New function (taken from old gcdext + implementation) + (mpn_hgcd2): Use single precision for the second half of the work. + +2008-10-30 Torbjorn Granlund + + * mpn/x86/p6/sse2/gmp-mparam.h: New file. + +2008-10-29 Torbjorn Granlund + + * configure.in (x86 fat_path): Add "x86/p6/sse2". + + * mpn/x86/fat/fat.c (__gmpn_cpuvec_init): Recognize sse2 capable p6 + (pentiumm, core2). + + * mpn/x86/p6/sse2/mul_1.asm: New file. + * mpn/x86/p6/sse2/addmul_1.asm: New file. + * mpn/x86/p6/sse2/submul_1.asm: New file. + * mpn/x86/p6/sse2/mul_basecase.asm: New file. + * mpn/x86/p6/sse2/sqr_basecase.asm: New file. + * mpn/x86/p6/sse2/popcount.asm: New file. + + * mpn/x86/fat/fat.c (__gmpn_cpuvec_init): Handle "extended" fields for + model and family. + +2008-10-28 Torbjorn Granlund + + From Mickael Gastineau: + * gmp-h.in (gmp_urandomm_ui, gmp_urandomb_ui): Add __GMP_DECLSPEC. + +2008-10-27 Torbjorn Granlund + + * gmp-h.in (mpn_gcdext_1): Remove bogus __GMP_ATTRIBUTE_PURE. + +2008-10-27 Niels Möller + + * tune/common.c (speed_mpn_hgcd): Call mpn_hgcd_matrix_init once + for each call to mpn_hgcd. + (speed_mpn_hgcd_lehmer): Likewise. + +2008-10-26 Torbjorn Granlund + + * configure.in: Point to p6/sse2 for pentiumm and core2. + + * gmp-impl.h (mpn_add_nc, mpn_sub_nc): Move these macros to after fat + definitions. + + * tune/common.c, tune/speed.c, tune/speed.h: + Add speed measurement of mpn_bdiv_dbm1c. + +2008-10-24 Torbjorn Granlund + + * mpn/x86_64/gmp-mparam.h (MUL_FFT_TABLE2, SQR_FFT_TABLE2): Extend. + + * mpz/nextprime.c: Move declarations to function beginning. + +2008-10-23 Niels Möller + + * gmp-impl.h (DECL_gcdext_1): Deleted. + +2008-10-22 Torbjorn Granlund + + * mpn/x86_64/atom/aors_n.asm: New file. + * mpn/x86_64/atom/gmp-mparam.h: New file. + +2008-10-21 Torbjorn Granlund + + With Neils Möller: + * mpz/nextprime.c: Rewrite. + + * tests/devel/try.c (main): Use strtol for 's' and 'S' optargs. + + * mpn/x86_64/pentium4/rshift.asm: Misc cleanups. + * mpn/x86_64/pentium4/lshift.asm: Likewise. + + * mpn/x86_64/pentium4/aors_n.asm: Use fewer registers. + + * configure.in: Set up specific path for x86_64/atom. + +2008-10-21 Niels Möller + + * mpn/Makefile.am (nodist_EXTRA_libmpn_la_SOURCES): Removed + qstack.c. + * mpn/generic/qstack.c: Deleted obsolete file. + +2008-10-20 Torbjorn Granlund + + * mpn/x86_64/core2/aorsmul_1.asm: New file. + +2008-10-19 Torbjorn Granlund + + * mpn/x86_64/aors_n.asm: Remove redundant MULFUNC_PROLOGUE. + + * gmp-impl.h (popc_limb): Remove redundant checks of GMP_LIMB_BITS + inside several of these macros. + +2008-10-17 Torbjorn Granlund + + * tests/mpz/t-mul.c: Use slower geometric progression for operand + sizes. Do every other tests for same size operands. + +2008-10-15 Torbjorn Granlund + + * mpn/x86_64/mul_basecase.asm: Simplify addressing in epilogue. + + * mpn/mips64/divrem_1.asm: Remove file, it is n32-only, and uses an old + algorithm. + + * config.guess, config.sub, configure.in: Support Intel Atom processor. + +2008-10-10 Torbjorn Granlund + + * mpq/mul.c: Fix typo in last change. + +2008-10-09 Torbjorn Granlund + + * tests/refmpn.c (refmpn_sb_divrem_mn): Work around a gcc bug. + +2008-10-08 Torbjorn Granlund + + * mpq/mul.c: Use TMP_ALLOC. Cleanup. + * mpq/div.c: Likewise. + + * mpn/x86_64/mul_basecase.asm: Use lea directly for loading entry point + addresses. + +2008-10-09 Niels Möller + + * mpn/x86/k7/gmp-mparam.h: Updated GCD-related values. + +2008-10-05 Torbjorn Granlund + + * mpn/generic/mul_fft.c (mpn_mul_fft_internal): Do store + mpn_fft_norm_modF return value, if (rec). + +2008-10-04 Torbjorn Granlund + + * mpn/x86_64/aorsmul_1.asm: Replace with faster code. + * mpn/x86_64/mul_1.asm: Likewise. + * mpn/x86_64/addmul_2.asm: Likewise. + * mpn/x86_64/mul_2.asm: Likewise. + * mpn/x86_64/mul_basecase.asm: Likewise. + +2008-10-02 Torbjorn Granlund + + * mpn/minithres/gmp-mparam.h: Update FFT values. + +2008-10-02 Niels Möller + + * hgcd.c (mpn_hgcd_matrix_mul): Fixed normalization bug. + +2008-09-24 Torbjorn Granlund + + * configure.in: Handle --enable-minithres. + * mpn/minithres/gmp-mparam.h: Update all values. + +2008-09-22 Torbjorn Granlund + + * tune/speed.c (routine): New entry for mpn_mul. + * tune/speed.h (SPEED_ROUTINE_MPN_MUL): Renamed from + SPEED_ROUTINE_MPN_MUL_BASECASE. + (speed_mpn_mul): Renamed from speed_mpn_mul_basecase. + (SPEED_ROUTINE_MPN_MUL): Allocate our own memory of xp operand. + + * tune/common.c: Corresponding changes. + +2008-09-22 Niels Möller + + * mpn/generic/gcdext.c (hgcd_mul_matrix_vector): New function, + replaces addmul2_n. Needs less copying. + (mpn_gcdext): Use hgcd_mul_matrix_vector. Updated for interface + change in mpn_gcdext_subdiv_step + + * mpn/generic/hgcd.c (hgcd_matrix_mul_1): Rewritten to use + mpn_hgcd_mul_matrix1_vector. + (hgcd_step): Updated for interface change in + mpn_hgcd_mul_matrix1_inverse_vector. + + * mpn/generic/gcdext_lehmer.c (mpn_gcdext_lehmer_n): Updated for + interface changes in mpn_hgcd_mul_matrix1_vector, + mpn_hgcd_mul_matrix1_inverse_vector and mpn_gcdext_subdiv_step. + + * mpn/generic/gcd_lehmer.c (mpn_gcd_lehmer_n): Updated for + interface change in mpn_hgcd_mul_matrix1_inverse_vector. + + * mpn/generic/gcdext_subdiv_step.c (mpn_gcdext_subdiv_step): Use + separate scratch arguments for the quotient and for the cofactor + update. + + * mpn/generic/hgcd2.c (mpn_hgcd_mul_matrix1_vector): Interface + change. Store first element in rp and leave ap unmodified. No + additional scratch space or copying needed. Callers that require + modification in place still need to copy one of the inputs. + (mpn_hgcd_mul_matrix1_inverse_vector): Likewise. + +2008-09-22 Niels Möller + + * mpn/generic/hgcd.c (hgcd_matrix_mul_1): Use mpn_addaddmul_1msb0. + * mpn/generic/hgcd2.c (mpn_hgcd_mul_matrix1_vector): Likewise. + + * mpn/generic/gcd.c: Use libspeed for timing measurements. + + * gmp-impl.h: Declare mpn_addaddmul_1msb0. + * mpn/asm-defs.m4: Added addaddmul_1msb0. + * mpn/x86_64/addaddmul_1msb0.asm: New file. + * configure.in (gmp_mpn_functions_optional): Added + addaddmul_1msb0. + (HAVE_NATIVE): List addaddmul_1msb0. + +2008-09-21 Torbjorn Granlund + + * mpn/generic/get_str.c (GET_STR_DC_THRESHOLD): Remove default. + (GET_STR_PRECOMPUTE_THRESHOLD): Likewise. + Misc code cleanups. + + * gmp-impl.h (mpn_dc_set_str_itch): Allocate GMP_LIMB_BITS more limbs. + + Revert: + * mpn/generic/set_str.c: + (mpn_dc_set_str): Remove impossible case, replace by an ASSERT. + +2008-09-18 Torbjorn Granlund + + * mpn/alpha/ev6/gmp-mparam.h (DIVEXACT_BY3_METHOD): Define. + + * mpn/ia64/diveby3.asm: Remove. + * mpn/x86/diveby3.asm: Remove. + * mpn/x86/k6/diveby3.asm: Remove. + * mpn/x86/k7/diveby3.asm: Remove. + * mpn/x86/p6/diveby3.asm: Remove. + * mpn/x86/pentium/diveby3.asm: Remove. + * mpn/x86_64/diveby3.asm: Remove. + * mpn/x86/pentium4/sse2/diveby3.asm: Remove. + + * configure.in (HAVE_NATIVE): List divexact_by3c. + + * gmp-impl.h (mpn_divexact_by3c): Override gmp-h.in's definition. + (DIVEXACT_BY3_METHOD): Don't default to 0 if + HAVE_NATIVE_mpn_divexact_by3c. + +2008-09-18 Niels Möller + + * mpn/generic/gcd.c (main): Added code for tuning of CHOOSE_P. + + * mpn/generic/hgcd.c (mpn_hgcd_matrix_mul): Assert that inputs are + normalized. + +2008-09-17 Niels Möller + + * mpn/generic/gcdext.c (mpn_gcdext): p = n/5 caused a + slowdown for large inputs. As a compromise, use p = n/2 for the + first iteration, and p = n/3 for the rest. Handle the first + iteration specially, since the initial u0 and u1 are trivial. + + * mpn/x86_64/gmp-mparam.h (GCDEXT_DC_THRESHOLD): Reduced threshold + from 409 to 390. + + * mpn/generic/gcdext.c (CHOOSE_P): New macro. Use p = n/5. + (mpn_gcdext): Use CHOOSE_P, and generalized the calculation of + scratch space. + + * tune/tuneup.c (tune_hgcd): Use default step factor. + + * mpn/x86_64/gmp-mparam.h: (GCD_DC_THRESHOLD): Reduced from 493 to + 412. + + * mpn/generic/gcd.c (CHOOSE_P): New macro, to determine the + split when calling hgcd. Use p = 2n/3, as that seems better than + the more obvious split p = n/2. + (mpn_gcd): Use CHOOSE_P, and generalized the calculation of + scratch space. + +2008-09-16 Torbjorn Granlund + + * mpn/generic/toom_interpolate_7pts.c: Use new mpn_divexact_byN + functions. + + * gmp-impl.h (mpn_divexact_by3, mpn_divexact_by5, mpn_divexact_by7, + mpn_divexact_by9, mpn_divexact_by11, mpn_divexact_by13, + mpn_divexact_by15): New macros, defined in terms of mpn_bdiv_dbm1. + + * configure.in (gmp_mpn_functions): List bdiv_dbm1c. + (HAVE_NATIVE): Likewise. + * mpn/asm-defs.m4: Define bdiv_dbm1c. + * gmp-impl.h (mpn_bdiv_dbm1c): Declare. + (mpn_bdiv_dbm1): New macro. + * mpn/generic/bdiv_dbm1c.c: New file. + * mpn/alpha/bdiv_dbm1c.asm: New file. + * mpn/ia64/bdiv_dbm1c.asm: New file. + * mpn/powerpc32/bdiv_dbm1c.asm: New file. + * mpn/powerpc64/mode64/bdiv_dbm1c.asm: New file. + * mpn/x86/bdiv_dbm1c.asm: New file. + * mpn/x86_64/bdiv_dbm1c.asm: New file. + + * mpn/generic/diveby3.c: Add mpn_bdiv_dbm1c based function. + Choose function depending on DIVEXACT_BY3_METHOD. + * gmp-impl.h (DIVEXACT_BY3_METHOD): Provide default. + +2008-09-16 Niels Möller + + * mpn/generic/hgcd.c (mpn_hgcd_addmul2_n): Moved function to + gcdext.c, where it is used. + * mpn/generic/gcdext.c (addmul2_n): Moved and renamed, was + mpn_hgcd_addmul2_n. Made static. Deleted input normalization. + Deleted rn argument. + (mpn_gcdext): Updated calls to addmul2_n, and added assertions. + + * gmp-impl.h (MPN_HGCD_MATRIX_INIT_ITCH): Increased storage by 4 limbs. + (MPN_HGCD_LEHMER_ITCH): Reduced storage by one limb. + (MPN_GCD_SUBDIV_STEP_ITCH): Likewise. + (MPN_GCD_LEHMER_N_ITCH): Likewise. + + * mpn/generic/hgcd.c (mpn_hgcd_matrix_init): Use two extra limbs. + (hgcd_step): Use overlapping arguments to mpn_tdiv_qr. + (mpn_hgcd_matrix_mul): Deleted normalization code. Tighter bounds + for the element size of the product. Needs two extra limbs of + storage for the elements. + (mpn_hgcd_itch): Updated storage calculation. + + * mpn/generic/gcd_subdiv_step.c (mpn_gcd_subdiv_step): Use + overlapping arguments to mpn_tdiv_qr. Use mpn_zero_p. + + * mpn/generic/gcd.c (mpn_gcd): Use mpn_zero_p. + +2008-09-15 Niels Möller + + * mpn/generic/hgcd.c (mpn_hgcd_matrix_init): Updated for deleted + tp pointer. + (hgcd_matrix_update_q): Likewise. + (mpn_hgcd_matrix_mul): Likewise. + (mpn_hgcd_itch): Updated calculation of scratch space. + + * gmp-impl.h (struct hgcd_matrix): Deleted tp pointer. + (MPN_HGCD_MATRIX_INIT_ITCH): Reduced storage. + (mpn_hgcd_step, MPN_HGCD_STEP_ITCH): Deleted declarations. + +2008-09-15 Niels Möller + + * mpn/x86_64/gmp-mparam.h (MATRIX22_STRASSEN_THRESHOLD): New + threshold. + + * mpn/generic/hgcd.c (mpn_hgcd_matrix_mul): Use mpn_matrix22_mul. + (mpn_hgcd_itch): Updated calculation of scratch space. Use + count_leading_zeros to get the recursion depth. + + * mpn/generic/gcd.c (mpn_gcd): Fixed calculation of scratch space, + and use mpn_hgcd_itch. + +2008-09-15 Niels Möller + + * tune/tuneup.c (tune_matrix22_mul): New function. + (all): Use it. + + * tune/common.c (speed_mpn_matrix22_mul): New function. + + * tune/Makefile.am (TUNE_MPN_SRCS_BASIC): Added matrix22_mul.c. + + * tests/mpn/t-matrix22.c: Use MATRIX22_STRASSEN_THRESHOLD to + select sizes for tests. + + * gmp-impl.h (MATRIX22_STRASSEN_THRESHOLD): New threshold + + * configure.in (gmp_mpn_functions): Added matrix22_mul. + * gmp-impl.h: Added declarations for mpn_matrix22_mul and related + functions. + + * mpn/Makefile.am (nodist_EXTRA_libmpn_la_SOURCES): Added + matrix22_mul.c. + * tests/mpn/Makefile.am (check_PROGRAMS): Added t-matrix22. + + * tests/mpn/t-matrix22.c: New file. + * mpn/generic/matrix22_mul.c: New file. + +2008-09-11 Niels Möller + + * tune/tuneup.c: Updated tuning of gcdext. + + * mpn/x86_64/gmp-mparam.h (GCDEXT_DC_THRESHOLD): Reduced threshold + from 713 to 409. + +2008-09-11 Niels Möller + + * gmp-impl.h: Updated for gcdext changes. + (GCDEXT_DC_THRESHOLD): New constant, renamed from + GCDEXT_SCHOENHAGE_THRESHOLD. + + * mpn/generic/gcdext.c (compute_v): Accept non-normalized a and b + as inputs. + (mpn_gcdext): Rewrote and simplified. Now uses the new mpn_hgcd + interface. + + * mpn/generic/hgcd.c (mpn_hgcd_addmul2_n): Renamed from addmul2_n + and made non-static. Changed interface to take non-normalized + inputs, and only two size arguments. + (mpn_hgcd_matrix_mul): Simplified using new mpn_hgcd_addmul2_n. + + * mpn/generic/gcdext_lehmer.c (mpn_gcdext_lehmer_itch): Deleted + function. + (mpn_gcdext_lehmer_n): Renamed from mpn_gcd_lehmer. Now takes + inputs of equal size. Moved the code for the division step to a + separate function... + * mpn/generic/gcdext_subdiv_step.c (mpn_gcdext_subdiv_step): New + file, new function. + + * configure.in (gmp_mpn_functions): Added gcdext_subdiv_step. + +2008-09-10 Torbjorn Granlund + + * tests/devel/anymul_1.c: Include . + + * gmp-h.in: Unconditionally include . + +2008-09-10 Niels Möller + + * tune/common.c: #if:ed out speed_mpn_gcd_binary and + speed_mpn_gcd_accel. + * tune/speed.c (routine): #if:ed out mpn_gcd_binary, mpn_gcd_accel + and find_a. + * tune/Makefile.am (libspeed_la_SOURCES): Removed gcd_bin.c + gcd_accel.c gcd_finda_gen.c. + * tune/tuneup.c: Enable tuning of GCD_DC_THRESHOLD. + + * mpn/generic/gcd.c (mpn_gcd): Rewrote and simplified. Now uses + the new mpn_hgcd interface. + + * */gmp-mparam.h: Renamed GCD_SCHOENHAGE_THRESHOLD to + GCD_DC_THRESHOLD. + + * mpn/generic/gcd_lehmer.c (mpn_gcd_lehmer_n): Renamed (was + mpn_gcd_lehmer). Now takes inputs of equal size. + + * mpn/generic/gcd_lehmer.c (mpn_gcd_lehmer): Reintroduced gcd_2, + to get better performance for small inputs. + + * mpn/generic/hgcd.c: Don't hardcode small HGCD_THRESHOLD. + * mpn/x86_64/gmp-mparam.h (HGCD_THRESHOLD): Reduced from 145 to + 120. + * */gmp-mparam.h: Renamed HGCD_SCHOENHAGE_THRESHOLD to + HGCD_THRESHOLD. + +2008-09-09 Torbjorn Granlund + + * doc/gmp.texi: Fix a typo and clarify mpn_gcdext docs. + +2008-09-09 Niels Möller + + * tune/common.c (speed_mpn_hgcd, speed_mpn_hgcd_lehmer): Adapted + to new hgcd interface. + + * gmp-impl.h (MPN_HGCD_LEHMER_ITCH): New macro. + + * hgcd.c (mpn_hgcd_lehmer): Renamed function, from hgcd_base. Made + non-static. + + * gcd_lehmer.c (mpn_gcd_lehmer): Use hgcd2 also for n == 2. + + * gcdext_lehmer.c (mpn_gcdext_lehmer): Simplified code for + division step. Added proper book-keeping of swaps, which affect + the sign of the returned cofactor. + + * tests/mpz/t-gcd.c (one_test): Display co-factor when mpn_gcdext + fails. + + * gcd_lehmer.c (mpn_gcd_lehmer): At end of loop, need to handle + the special case n == 1 correctly. + + * gcd_subdiv_step.c (mpn_gcd_subdiv_step): Simplified function. + The special cancellation logic is not needed here. + +2008-09-08 Torbjorn Granlund + + * mpn/generic/invert.c: Add working but slow code. + + * mpn/x86_64/x86_64-defs.m4 (R32, R8): New macros. + + * mpn/ia64/submul_1.asm: Move some labels for broader assembler + compatibility. + + * gmp-impl.h (mpn_mul_3, mpn_mul_4): Declare. + * tests/tests.h (refmpn_mul_3, refmpn_mul_4): Declare. + * tests/try.c (param_init): Set things up for mpn_mul_3 and mpn_mul_4. + (choice_array): Likewise. + (call): Likewise. + * mpn/Makefile.am (nodist_EXTRA_libmpn_la_SOURCES): + Add mul_3.c and mul_4. + * mpn/asm-defs.m4: Define mul_3 and mul_4. + * tests/refmpn.c (refmpn_mul_N): New function. + (refmpn_mul_2): Remove old definition, call refmpn_mul_N. + (refmpn_mul_3, refmpn_mul_4): New functions. + * tune/common.c (speed_mpn_mul_3, speed_mpn_mul_4): New functions. + * tune/speed.h (speed_mpn_mul_3, speed_mpn_mul_4): Declare. + * tune/speed.c (routine): New entries for mpn_mul_2 and mpn_mul_3. + + * ltmain.sh: Update to libtool 1.5.24. + + * mpn/generic/mul_toom22.c: Compute s and t more cleverly. + +2008-09-08 Niels Möller + + * tests/mpn/t-hgcd.c: Updated tests. Rewrite of hgcd_ref. + + * mpn/generic/gcdext_lehmer.c (mpn_gcdext_lehmer_itch): New function. + (mpn_gcdext_lehmer): Various bugfixes. + + * gcdext.c (mpn_gcdext): Allocate scratch space for gcdext_lehmer. + + * mpn/generic/gcd_lehmer.c (gcd_2): ASSERT that inputs are odd. + (mpn_gcd_lehmer): Added tp argument, for scratch space. Make both + arguments odd before calling gcd_2. + + * mpn/generic/hgcd.c (mpn_hgcd): Allow the trivial case n <= 2, + and return 0 immediately. + + * gmp-impl.h (MPN_EXTRACT_NUMB): New macro. + + * configure.in (gmp_mpn_functions): Added gcdext_lehmer. + +2008-09-05 Torbjorn Granlund + + * mpn/generic/toom_interpolate_7pts.c: Use mpn_divexact_by3c instead of + divexact_odd. + + * doc/texinfo.tex: Update to 2007-06-29.13. + + * doc/gmp.texi: Update GMP site URL. Fix some typos. + + * demos/pexpr.c (main): Allow bases up to 62. + + * gmp-impl.h: Remove formal parameter names from function prototypes. + + * config.guess: Recognize recent AMD and Itanium CPUs. + Default X86 CPU recognition to configfsf.guess' value. + + * configure.in: Handle core2 separately from athlon64. + +2008-09-05 Niels Möller + + * */Makefile.in, configure, aclocal.m4, config.in: Removed files + from repository. They're instead generated by automake and + autoconf before distribution. + +2008-08-25 Torbjorn Granlund + + * mpf/set_str.c: Allocate mantissa space based on mantissa size, + not on destination variable space. + * mpf/set_str.c: Accept unary plus before exponent. + +2008-08-06 Torbjorn Granlund + + * mpn/generic/mul_toom22.c: Add statistics gathering functionality, + triggered by cpp predef STAT. + + From David Harvey: + * mpn/generic/mul_toom22.c: Decrease scratch space usage. + +2008-08-02 Torbjorn Granlund + + * tests/misc/t-scanf.c: Avoid negative arguments to _ui functions. + * tests/misc/t-printf.c: Likewise. + + * acinclude.m4 (X86_PATTERN): Add geode. + + * acinclude.m4 (CL_AS_NOEXECSTACK): Avoid -q flag to grep. + +2008-08-01 Torbjorn Granlund + + * acinclude.m4 (CL_AS_NOEXECSTACK): New. + * configure.in: Use CL_AS_NOEXECSTACK. + * mpn/Makeasm.am: Use ASM_FLAGS (defined by CL_AS_NOEXECSTACK). + + * gmpxx.h (__GMP_DBL_LIMBS): Use DBL_MAX_EXP instead of + std::numeric_limits::max_exponent for better portability. + +2008-07-29 Torbjorn Granlund + + * gmpxx.h (__GMP_DBL_LIMBS): New #define. + (__GMP_ULI_LIMBS): New #define. + (__GMPXX_TMP_UI): New macro. + (__GMPXX_TMP_SI): New macro. + (__GMPXX_TMP_D): New macro. + (struct __gmp_binary_and): Rewrite, using the new macros. + (struct __gmp_binary_ior): Likewise. + (struct __gmp_binary_xor): Likewise. + +2008-07-28 Torbjorn Granlund + + * tests/cxx/t-binary.cc: Add some tests for logical operations. + +2008-07-24 Torbjorn Granlund + + * gmpxx.h: Use __GMPZ_* instead of __GMPZZ_* for bitwise ops, remove + __GMPZZ_*. + Remove repeated #undefs. + (__gmp_alloc_cstring): Declare freefunc as extern "C". + +2008-07-23 Torbjorn Granlund + + * gmp-h.in (__GMP_CC): New define, undocumented for now. + (__GMP_CFLAGS): Likewise. + +2008-07-21 Torbjorn Granlund + + * tests/amd64check.c: Fix a printf type clash. + + * mpz/realloc.c: Amend last fix. + + * gmp-h.in: Include for C++. + * gmp-h.in: Handle new gcc 4.3 inline semantics defaults. + + * configfsf.guess: Update to version of 2008-04-14. + * configfsf.sub: Update to version of 2008-06-16. + + * configure.in: Separate core2 and athlon64 flags handling. + +2008-06-19 Torbjorn Granlund + + * config.guess: Recognize pentiumm and AMD geode. + * config.sub: Likewise. + * configure.in: Likewise. + +2008-06-02 Torbjorn Granlund + + * configure.in: Disallow odd nails sizes. + * configure.in: Inherit default gcc_cflags/gcc_64_cflags everywhere. + +2008-05-23 Torbjorn Granlund + + * mpz/init2.c: Rewrite to avoid internal overflow and to detect mpz_t + overflow. + * mpz/realloc2.c: Likewise. + * mpz/realloc.c: Detect mpz_t overflow. + +2008-05-22 Torbjorn Granlund + + * configure.in (sparc): Remove -fast, it causes documented + miscompilation. + + * config.guess: Properly handle the "extended" variants of x86 cpuid. + +2008-05-09 Torbjorn Granlund + + * gmp-impl.h (mpn_mul_fft): Now void. + (udiv_qrnnd_preinv3): Special case for constant (nl). + +2008-05-08 Torbjorn Granlund + + * mpn/generic/mul_fft.c: Clean up types in TRACE (printf (...)). + (TRACE): Redefine to allow command line control. + (mpn_mul_fft_internal): Now void, remove return value. + (mpn_mul_fft): Likewise. + (MPN_FFT_TABLE2_SIZE): Up size fro 256 to 512. + (mpn_fft_fft): Call mpn_fft_mul_2exp_modF just once instead of twice, + then add/subtract result. Get rid of temp allocation as a result. + Remove some redundant CNST_LIMB. + (mpn_fft_fftinv): Analogous changes. + (mpn_fft_sub_modF): Re-enable, now needed by mpn_fft_fft and + mpn_fft_fftinv. + +2008-03-10 Torbjorn Granlund + + * tests/mpz/t-mul.c (main): Let GMP_CHECK_FFT mean largest allowed + power-of-2 of test operands. + +2008-02-28 Torbjorn Granlund + + * tests/cxx/t-binary.cc (check_mpz): Expect floor rounding for right + shift. + +2008-02-27 Torbjorn Granlund + + * mpz/mul_i.h: Check sml's size (not the signed small_mult). + + * longlong.h (umul_ppmm) [alpha]: Define using __builtin_alpha_umulh + when possible. + + * longlong.h (count_trailing_zeros): Force destination register mode. + + * gmpxx.h (struct __gmp_binary_rshift): Use floor rounding, not + truncation. + + * gmpxx.h (__gmp_binary_and, __gmp_binary_ior, __gmp_binary_xor): + Add variants with unsigned long int argument. + + * config.sub: Recog geode. + * config.guess: Likewise. + * acinclude.m4 (X86_PATTERN): Likewise. + +2008-02-10 Torbjorn Granlund + + * mpn/x86/p6/aors_n.asm: Use Zdisp to work around GNU as bug. + * mpn/x86/x86-defs.m4 (Zdisp): Add more instructions. + +2008-02-08 Torbjorn Granlund + + * mpn/x86_64/aors_n.asm: New file. + * mpn/x86_64/add_n.asm: Delete. + * mpn/x86_64/sub_n.asm: Delete. + +2008-02-07 Torbjorn Granlund + + * mpn/x86/k6/mmx/dive_1.asm: Fix typo in last change. + +2007-12-10 Torbjorn Granlund + + * mpf/set_str.c (mpf_set_str): Write own code for converting the + exponent, avoids strtol base < 36 limitation. + +2007-10-28 Torbjorn Granlund + + * gmp-impl.h (mpn_dc_get_str_itch): New macro. + (mpn_dc_get_str_powtab_alloc): New macro. + (struct powers): Add field "shift". + + * mpn/generic/get_str.c: Compute powers without low zero limbs; all + functions modified. Correct temporary allocation. Misc cleanups. + + * mpn/generic/set_str.c: Compute powers without low zero limbs; all + functions modified. + (mpn_dc_set_str): Remove impossible case, replace by an ASSERT. + +2007-10-26 Torbjorn Granlund + + * mpn/generic/set_str.c: Remove default thresholds, not in gmp-impl.h. + (mpn_dc_set_str): Insert ASSERT_ALWAYS in a presumably dead code arm. + +2007-10-22 Torbjorn Granlund + + * gmp-impl.h (mpn_add_nc): Define as inline function, unless NATIVE. + (mpn_sub_nc): Likewise. + +2007-10-17 Torbjorn Granlund + + * tests/misc/t-printf.c: Fix a printf type clash. + * tests/mpq/t-get_str.c: Likewise. + * tests/mpz/t-import.c: Likewise. + + * acinclude.m4: Conditionally disable some tests when compiled by a C++ + compiler. + + * gmp-impl.h (udiv_qrnnd_preinv3): Remove an unused variable. + + * mpn/generic/hgcd.c: Add some WANT_ASSERTs to shut up warnings. + +2007-10-08 Torbjorn Granlund + + * mpn/powerpc64/elf.m4 (LEAL): Define as an alias for LEA. + * mpn/powerpc32/darwin.m4 (LEAL): Likewise. + * mpn/powerpc64/aix.m4: Likewise. + + * mpn/powerpc64/vmx/popcount.asm: Use LEAL. + + * mpn/powerpc64/darwin.m4 (LEAL): New name for LEA, since it is only + usable for local symbols. + (LEA): Replace with code for external references. + + * mpn/powerpc32/vmx/mod_34lsub1.asm: Use LEAL. + +2007-10-07 Torbjorn Granlund + + * mpn/x86/dive_1.asm: Use LEA, remove explicit movl_eip_*. + * mpn/x86/k6/mode1o.asm: Likewise. + * mpn/x86/k6/mmx/dive_1.asm: Likewise. + * mpn/x86/k7/dive_1.asm: Likewise. + * mpn/x86/k7/mode1o.asm: Likewise. + * mpn/x86/p6/dive_1.asm: Likewise. + * mpn/x86/p6/mode1o.asm: Likewise. + * mpn/x86/pentium4/sse2/dive_1.asm: Likewise. + * mpn/x86/pentium4/sse2/mode1o.asm: Likewise. + * mpn/x86/pentium4/sse2/popcount.asm: Likewise. + + * mpn/x86/p6/aors_n.asm: Table cycle counts. + + * mpn/x86/k7/mod_34lsub1.asm: Fix over-optimistic cycle count claims. + + * mpn/x86/x86-defs.m4 (DEF_OBJECT, END_OBJECT): New define's. + + * mpn/x86/darwin.m4 (LEA): Put also movl_eip_XX into EPILOGUE_cpu. + Expect target register to have prepended %. + + * mpn/x86_64/add_n.asm: Use L() for labels. + * mpn/x86_64/addlsh1_n.asm: Likewise. + * mpn/x86_64/addmul_2.asm: Likewise. + * mpn/x86_64/aorrlsh_n.asm: Likewise. + * mpn/x86_64/aorsmul_1.asm: Likewise. + * mpn/x86_64/com_n.asm: Likewise. + * mpn/x86_64/copyd.asm: Likewise. + * mpn/x86_64/copyi.asm: Likewise. + * mpn/x86_64/diveby3.asm: Likewise. + * mpn/x86_64/logops_n.asm: Likewise. + * mpn/x86_64/lshsub_n.asm: Likewise. + * mpn/x86_64/mul_1.asm: Likewise. + * mpn/x86_64/mul_2.asm: Likewise. + * mpn/x86_64/mul_basecase.asm: Likewise. + * mpn/x86_64/popham.asm: Likewise. + * mpn/x86_64/redc_1.asm: Likewise. + * mpn/x86_64/rsh1add_n.asm: Likewise. + * mpn/x86_64/rsh1sub_n.asm: Likewise. + * mpn/x86_64/rshift.asm: Likewise. + * mpn/x86_64/sub_n.asm: Likewise. + * mpn/x86_64/sublsh1_n.asm Likewise. + * mpn/x86_64/pentium4/aors_n.asm: Likewise. + * mpn/x86_64/pentium4/lshift.asm: Likewise. + * mpn/x86_64/pentium4/rshift.asm: Likewise. + + * mpn/x86_64/x86_64-defs.m4: New file, defining LEA, DEF_OBJECT, and + END_OBJECT. + + * mpn/generic/mul.c: Put TMP_DECL as last decl. + +2007-10-06 Torbjorn Granlund + + * mpn/x86/pentium4/sse2/popcount.asm: New file. + +2007-09-26 Torbjorn Granlund + + * mpz/get_str.c: Cast a char index to int to shut up compilers. + + * mpn/generic/dc_div_qr.c: Pass dummy scratch argument to mpn_invert. + * mpn/generic/dc_divappr_q.c: Likewise. + * mpn/generic/mu_div_qr.c: Likewise. + * mpn/generic/mu_divappr_q.c: Likewise. + * mpn/generic/mu_div_q.c: Likewise. + * mpn/generic/divexact.c: Likewise. + + * mpn/generic/invert.c: New file, placeholder for now. + +2007-09-24 Torbjorn Granlund + + * mpn/generic/toom_interpolate_5pts.c: New file, contents from + mpn/generic/mul_n.c + * mpn/generic/mul_n.c (mpn_toom3_interpolate): Function removed. + + * mpn/generic/toom_interpolate_7pts.c: New file. + + * mpn/x86/k7/mmx/popham.asm: Table cycle counts. + + * mpn/x86/k6/README: Update URLs. + + * mpn/powerpc32/README: Update URL's, company names. + + * mpn/generic/get_d.c: Complete rewrite. + + * mpn/generic/mul_toom33.c: New file. + + * mpn/generic/mul_toom22.c: Make orthogonal with other toomXY files. + * mpn/generic/mul_toom32.c: Likewise. + * mpn/generic/mul_toom42.c: Likewise. + + * mpn/alpha/invert_limb.asm: Update cycle counts. Fix a comment typo. + + * mpf/get_str.c: Include stdlib.h, not stdio.h for NULL. + + * doc/gmp.texi: Fix a typo. + + * memory.c (__gmp_default_allocate, __gmp_default_reallocate): + Cast size operands in error fprintf's. + + * longlong.h (sub_ddmmss) [powerpc 64]: Add more variants for constant + args. + + * gmp-impl.h (udiv_qrnnd_preinv3): New define. + * gmp-impl.h (ULONG_PARITY): Exclude masquerading __INTEL_COMPILER from + ia64 asm. + + * gmp-h.in (mpn_neg_n): New function. + +2007-09-18 Torbjorn Granlund + + * demos/pexpr.c (main): Add -v option. + (enum op_t): New tag TIMING. + (mpz_eval_expr): Execute TIMING. + (fns): Add TIMING entry. + + * gmp-impl.h: Add decls and THRESHOLDs for new toom multiplication + functions and division functions. + +2007-09-10 Torbjorn Granlund + + * mpn/powerpc32/addlsh1_n.asm: Use L() for labels. + * mpn/powerpc32/sublsh1_n.asm: Likewise. + +2007-09-09 Torbjorn Granlund + + * mpn/x86/x86-defs.m4 (LEA): New define. + * mpn/x86/darwin.m4: New file, for now just defining LEA. + * configure.in: Pick up x86/darwin.m4. + * mpn/x86/*: Use LEA for PIC references. + + * configure.in: For X86/32, treat core2 like pentium3. + +2007-09-06 Torbjorn Granlund + + * tests/amd64check.c (calling_conventions_values): Put constants, + dynamic values in this array (was in scalars). + (calling_conventions_check): Corresponding changes. + * tests/amd64call.asm: Rewrite to be PIC, smaller, using amd64check.c's + array. + +2007-09-04 Torbjorn Granlund + + * mpn/x86/pentium4/sse2/mul_basecase.asm: Misc cleanups. + * mpn/x86/pentium4/sse2/sqr_basecase.asm: Likewise. + + * mpn/x86_64/mod_34lsub1.asm: Optimize loop, reduce code size. + + * tests/amd64call.asm: Remove bogus no-op moves. + +2007-09-03 Torbjorn Granlund + + From Richard Guenther: + * gmp-h.in (__GMP_EXTERN_INLINE): Declare conditionally on + __GNUC_STDC_INLINE__. + + * tests/cxx/t-locale.cc: #include , for abort. + + * mpn/x86_64/core2/popcount.asm: New file. + * mpn/x86_64/pentium4/popcount.asm: New file. + + * mpn/x86_64/addmul_2.asm: New file. + * mpn/x86_64/mul_2.asm: New file. + + * mpn/x86_64/aorsmul_1.asm: Use 32-bit mov for zeroing registers + (saves space). + +2007-09-01 Torbjorn Granlund + + * configure.in: Handle athlon64, core2, and pentium4 separately for + 64-bit ABI. + + * config.sub: Recog athlon64, core2, and opteron. + + * config.guess: Do two x86 variants, for 32-bit ABI and 64-bit ABI. + Return "athlon64" and "core2", not x86_64. + +2007-08-31 Torbjorn Granlund + + From Patrick Pelissier: + * gmp-h.in: Don't refer to FILE from C++ unless we've seen FILE. + +2007-08-30 Torbjorn Granlund + + * demos/isprime.c: Include string.h for strcmp. + + * demos/factorize.c (main): Declare to int. + +2007-06-22 Torbjorn Granlund + + * mpn/x86_64/pentium4/lshift.asm: Minor tuning. + * mpn/x86_64/pentium4/rshift.asm: Likewise. + +2007-05-30 Torbjorn Granlund + + * mpn/powerpc64/mode64/aors_n.asm: Add _nc entry points. + +2007-05-22 Torbjorn Granlund + + * tests/memory.c: Cast calls to new mem* calls to avoid unaligned ops. + +2007-05-16 Torbjorn Granlund + + * tests/mpz/convert.c: Tweak operand sizes for best coverage. + + * tests/memory.c: Add red zones around allocations. + +2007-05-15 Torbjorn Granlund + + * mpn/ia64/mul_1.asm: Make mul_1c entry point actually work. + + * mpn/generic/set_str.c (mpn_dc_set_str): Avoid calling mpn_add_n when + ln == 0. + + * tests/mpz/convert.c (string_urandomb): New function. + (main): Use it by enabling ifdef'ed out code. + +2007-04-30 Torbjorn Granlund + + * mpn/x86_64/mul_basecase.asm: Complete rewrite. + + * mpn/x86_64/copyi.asm: Use short shift-by-one form. Misc cleanups. + * mpn/x86_64/copyi.asm: Likewise. + * mpn/x86_64/popham.asm: Likewise. + + * mpn/x86_64/aorsmul_1.asm: Cleanup formatting. + +2007-04-25 Torbjorn Granlund + + * mpz/divexact.c: Handle undefined case of |N| < |D| to avoid segfaults. + +2007-02-24 Torbjorn Granlund + + * doc/gmp.texi (Toom 3-Way Multiplication): Fix typo. + (mpz_scan0, mpz_scan1): Fix typos. + (Float Internals): Rewrite paragraph about struct types. + +2007-02-12 Torbjorn Granlund + + * mpn/x86/pentium4/sse2/sqr_basecase.asm: Complete rewrite (except + diagonal code). + +2007-02-05 Torbjorn Granlund + + * mpn/generic/mul_fft.c (mpn_fft_fft): New name for mpn_fft_fft_sqr, + old mpn_fft_fft removed. + (mpn_mul_fft_internal): Call mpn_fft_fft separately for each operand. + (mpn_fft_add_modF): Rewrite to avoid random branches. + (mpn_fft_sub_modF): Likewise. + + * mpn/x86/pentium4/sse2/addmul_1.asm: Complete rewrite. + * mpn/x86/pentium4/sse2/mul_1.asm: Complete rewrite. + * mpn/x86/pentium4/sse2/mul_basecase.asm: Complete rewrite, based on + new addmul and mul code. + +2007-01-31 Torbjorn Granlund + + * mpn/generic/get_str.c (mpn_sb_get_str): Get loop count for frac + development right. + + * mpn/powerpc32/vmx/mod_34lsub1.asm: New file. + + * mpn/powerpc32/aors_n.asm: New file, complete rewrite. + * mpn/powerpc32/add_n.asm: Remove. + * mpn/powerpc32/sub_n.asm: Remove. + +2007-01-25 Torbjorn Granlund + + * mpn/x86_64/core2/aors_n.asm: Add _nc entry points, minor cleanups. + + * mpn/x86_64/core2/lshift.asm: Rewrite. + * mpn/x86_64/core2/rshift.asm: Rewrite. + + * mpn/x86_64/pentium4/lshift.asm: Swap some loop insns for a small + speedup. + * mpn/x86_64/pentium4/rshift.asm: New file, based on lshift.asm. + + * mpn/x86_64/pentium4/gmp-mparam.h: New file. + + * mpn/x86_64/pentium4/aors_n.asm: Complete rewrite of add/subtract + code. + * mpn/x86_64/pentium4/add_n.asm: Remove. + * mpn/x86_64/pentium4/sub_n.asm: Remove. + +2007-01-20 Torbjorn Granlund + + * mpn/x86_64/lshift.asm: Add special case for cnt=1. + +2007-01-19 Torbjorn Granlund + + * mpn/x86_64/aorsmul_1.asm: New file, written from scratch, finally at + 3.0 c/l on K8 (addmul_1 was 3.3; submul_1 was 3.5). + * mpn/x86_64/addmul_1.asm: Remove. + * mpn/x86_64/submul_1.asm: Remove. + +2006-12-29 Torbjorn Granlund + + * randmt.c (__gmp_randclear_mt): Initialize ALLOC field, like in + __gmp_randinit_mt_noseed. + (__gmp_randclear_mt, __gmp_randinit_mt_noseed): Make similar functions + look similar. + (__gmp_randclear_mt): Pass actually allocated size. + + * mpn/Makefile.am (nodist_EXTRA_libmpn_la_SOURCES): Add mul_toom22.c, + mul_toom32.c, mul_toom42.c. + + * configure.in: Recognize athlon64 and core2 as alternatives to x86_64. + Provide special settings for core2. + + * configure.in (gmp_mpn_functions): Add mul_toom22, mul_toom32, + mul_toom42. + + * mpn/generic/mul_toom22.c: New file. + * mpn/generic/mul.c: Use mpn_mul_toom22. Trim cutoff points between + the mpn_mul_toomN2 functions. Handle balanced operands at function + entry. + +2006-12-29 Marco Bodrato + + * mpn/generic/mul_n.c: Rewrite interpolation code. + +2006-12-28 Torbjorn Granlund + + * mpn/generic/mul_toom32.c: New file. + * mpn/generic/mul_toom42.c: New file. + * mpn/generic/mul.c: Use mpn_mul_toom32 and mpn_mul_toom42 for + unbalanced operands. + +2006-12-17 Torbjorn Granlund + + * mpn/x86_64/aorrlsh_n.asm: New file. + * mpn/x86_64/lshsub_n.asm: New file. + + * mpn/x86_64/core2/aors_n.asm: New file. + * mpn/x86_64/core2/lshift.asm: New file. + * mpn/x86_64/core2/rshift.asm: New file. + + * mpn/x86/p6/aors_n.asm: Replace K7 grabbing code with P6 specific + code. + + * mpn/x86/p6/lshsub_n.asm: New file. + +2006-11-23 Torbjorn Granlund + + * tune/speed.h (SPEED_ROUTINE_MPN_MUL_BASECASE): Allocate space for xp + locally, s->xp might be insufficient. + +2006-11-22 Torbjorn Granlund + + * randmt.c (__gmp_randinit_mt_noseed): Initialize ALLOC field of result + param. + +2006-11-06 Torbjorn Granlund + + * tune/set_strp.c: New file. + +2006-11-04 Torbjorn Granlund + + * extract-dbl.c: Rewrite to handle nails better, and for general + optimization. + + * mpz/bin_uiui.c: Simplify. + + * longlong.h (umul_ppmm) [mmix]: New. + + * tune/tuneup.c, tune/common.c, tune/speed.c, tune/speed.h, + tune/set_strb.c, tune/set_strs.c: Add tuning and speed measurements + of separate SET_STR_DC_THRESHOLD and SET_STR_PRECOMPUTE_THRESHOLD. + Add tuning and speed measurement of mpn_addsub_n. + +2006-10-31 Torbjorn Granlund + + * gmpxx.h: Remove ternary stuff, it is hardly an optimization and it + writes to destination before reading all source operands. + +2006-10-25 Torbjorn Granlund + + * mpn/generic/set_str.c: Complete rewrite. + * mpn/generic/get_str.c: Likewise. + + * gmp-impl.h (struct powers, powers_t): New types. + Restructure GET_STR_* and SET_STR_* thresholds. + +2006-09-21 Torbjorn Granlund + + * mpn/generic/rootrem.c: Remove some redundant casts. + +2006-07-12 Torbjorn Granlund + + * mpn/alpha/ev6/nails/addmul_2.asm: Make it run at claimed speed. + * mpn/alpha/ev6/nails/addmul_4.asm: Likewise. + + * mpf/get_str.c: Avoid copying result when not needed. Misc cleanups. + + * tests/amd64call.asm: Use jmp instead of jmpq to placate Solaris. + +2006-06-30 Torbjorn Granlund + + * configure.in (powerpc-*): Remove repeated path component. + +2006-06-15 Torbjorn Granlund + + * configure.in: (ia64-*-linux*): Don't use -O3. + +2006-06-14 Torbjorn Granlund + + * mpq/get_str.c: Fix upper base limit boundary in an ASSERT. + + * tests/refmpn.c (refmpn_sb_divrem_mn): Use ASSERT_CARRY for add-back. + +2006-05-31 Torbjorn Granlund + + * tests/mpz/t-set_d.c (check_data): Add more data points. + + * mpz/set_d.c: Handle negative return values from __gmp_extract_double. + +2006-05-17 Torbjorn Granlund + + * configure.in: Clear out gcc_cflags_cpu and gcc_cflags_arch for a fat + build. + +2006-05-16 Torbjorn Granlund + + * demos/primes.c (find_primes): Increase mpz_probab_prime_p cnt to 10. + + * mpn/generic/addsub_n.c: Fix criteria form when to call _nc functions. + +2006-05-12 Torbjorn Granlund + + * config.guess: Recognize more ppc processor types. + +2006-05-11 Torbjorn Granlund + + * tune/speed.c (usage): Update URL for gnuplot and quickplot. + +2006-05-10 Torbjorn Granlund + + * configure.in (powerpc-*-*): Pass -maltivec to assembler for + appropriate CPUs. + +2006-05-08 Torbjorn Granlund + + * mpn/powerpc32/aix.m4 (LEA): Remove [RW] attribute. + +2006-05-03 Torbjorn Granlund + + * mpn/powerpc64/vmx/popcount.asm: Conditionally zero extend n. + +2006-04-27 Torbjorn Granlund + + * mpz/divexact.c: Call mpz_tdiv_q for large operands. + + * configure.in (powerpc-*-darwin): Remove -fast, it affects PIC. + +2006-04-26 Torbjorn Granlund + + * config.guess: Try to recognize Ultrasparc T1 (as ultrasparct1). + * config.sub: Handle ultrasparct1. + +2006-04-25 Torbjorn Granlund + + * mpn/sparc64/gmp-mparam.h: Retune, without separation of GNUC and + non-GNUC data. + +2006-04-20 Torbjorn Granlund + + * tests/mpz/convert.c: Increase operands range. + +2006-04-19 Torbjorn Granlund + + * configure.in: Support powerpc eABI. + * mpn/powerpc32/eabi.m4: New file. + + * configure.in: Support powerpc *bsd. + * mpn/powerpc64/elf.m4: New name for mpn/powerpc64/linux64.m4. + * mpn/powerpc32/elf.m4: New name for mpn/powerpc32/linux.m4. + + * mpn/powerpc64/linux64.m4 (ASM_END): Quote TOC_ENTRY. + +2006-04-18 Torbjorn Granlund + + * configure.in (gmp_mpn_functions_optional): Add lshiftc. + (HAVE_NATIVE): Add lshiftc. + + * mpn/powerpc64/mode64/invert_limb.asm: Use LEA, not LDSYM. + * mpn/powerpc64/mode64/mode1o.asm: Likewise. + * mpn/powerpc64/mode64/dive_1.asm: Likewise. + + * mpn/powerpc64/linux64.m4 (TOC_ENTRY): Define to empty. + * mpn/powerpc64/aix.m4 (TOC_ENTRY): Likewise. + * mpn/powerpc32/aix.m4 (TOC_ENTRY): Likewise. + + * mpn/powerpc32/aix.m4 (EXTERN): New, copied form powerpc64/aix.m4. + * mpn/powerpc32/mode1o.asm: Use EXTERN. + * mpn/powerpc32/linux.m4 (EXTERN): Provide dummy definition. + * mpn/powerpc32/darwin.m4 (EXTERN): Likewise. + +2006-04-13 Torbjorn Granlund + + * mpn/generic/mul_fft.c: Use new thresholds mechanism if MUL_FFT_TABLE2 + is defined. + (mpn_lshiftc): New name for mpn_lshift_com (for consistency with some + stuff already in 4.1.4. + (mpn_fft_mul_2exp_modF): Reorganize initial operand reductions to avoid + divisions. + + * tests/devel/try.c (choice_array): Add mpn_addsub_n[c]. + +2006-04-11 Torbjorn Granlund + + * aclocal.m4: Regenerate with patched libtool. + + * mpn/asm-defs.m4 (ASM_END): Provide (empty) default. + +2006-04-08 Torbjorn Granlund + + * configure.in (gmp_mpn_functions_optional): Add addsub. + + * gmpxx.h: Remove missed MPFR references. + + * gmp-impl.h (LIMBS_PER_DOUBLE): Adjust formula to not be pessimistic. + + * gmp-impl.h (TMP_*, WANT_TMP_DEBUG): Don't expect marker argument; + define TMP_SALLOC and TMP_BALLOC. + + * mpn/minithres/gmp-mparam.h: New file. + + * tests/mpz/t-io_raw.c: Fix printf type/arg mismatches. + * tests/mpz/t-export.c: Likewise. + * tests/mpz/io.c: Likewise. + * tests/t-constants.c: Likewise. + + * mpn/ia64/popcount.asm: Append "cond.dptk" to conditional branches to + placate icc. + * mpn/ia64/hamdist.asm: Likewise. + * mpn/ia64/lorrshift.asm: Likewise. + * mpn/ia64/dive_1.asm: Likewise. + +2006-04-05 Torbjorn Granlund + + * tal-notreent.c (__gmp_tmp_mark): Add "struct" tag for tmp_marker. + (__gmp_tmp_free): Likewise. + + * mpn/generic/mul_fft.c: Optimize many scalar divisions and mod + operations into masks and shifts. + (mpn_fft_mul_modF_K): Fix a spurious ASSERT_NOCARRY. + +2006-03-26 Torbjorn Granlund + + * Version 4.2 released. + + * mpn/powerpc64/aix.m4 (LEA): Renamed from LDSYM. + * mpn/powerpc64/darwin.m4: Likewise. + * mpn/powerpc64/linux64.m4: Likewise. + * mpn/powerpc64/vmx/popcount.asm: Use LEA, not LDSYM. + +2006-03-23 Torbjorn Granlund + + * gmp-impl.h: (class gmp_allocated_string): Prefix strlen with std::. + + * gmpxx.h (__GMP_DEFINE_TERNARY_EXPR2): Remove for now. + (struct __gmp_ternary_addmul2): Likewise. + (struct __gmp_ternary_submul2): Likewise. + + * gmpxx.h: #include . + (struct __gmp_alloc_cstring): Prefix strlen with std::. + + * mpn/x86/pentium/com_n.asm: Add TEXT and ALIGN. + * mpn/x86/pentium/copyi.asm: Likewise. + * mpn/x86/pentium/copyd.asm: Likewise. + +2006-03-22 Torbjorn Granlund + + * gmp-h.in: Add a "using std::FILE" for C++. + (_GMP_H_HAVE_FILE): Check also _ISO_STDIO_ISO_H. + + * gmpxx.h: Remove mpfr code. + * tests/cxx: Likewise. + + * gmp-impl.h (FORCE_DOUBLE): Rename a tempvar to avoid a clash with + GNU/Linux public include file. + + * configure.in (powerpc64, darwin): New optional, gcc_cflags_subtype. + Grab powerpc32/darwin.m4 for ABI=mode32. + + * configure.in: Use host_cpu whenever just the cpu type is needed. + +2006-03-08 Torbjorn Granlund + + * mpz/get_si.c: Fix a typo. + + * tests/mpq/t-get_d.c (check_random): Improve random generation for + nails. + +2006-02-28 Torbjorn Granlund + + * tests/mpq/t-get_d.c (check_random): New function. + (main): Call check_random. + + * mpq/set_d.c: Make choices based on LIMBS_PER_DOUBLE, not + BITS_PER_MP_LIMB. Make it work for LIMBS_PER_DOUBLE == 4. + Use MPZ_REALLOC. + + * mpz/set_d.c: Make it work for LIMBS_PER_DOUBLE == 4. + + * extract-dbl.c: Make it work for LIMBS_PER_DOUBLE > 3. + +2006-02-27 Torbjorn Granlund + + * mpz/cmp_d.c: Declare `i'. + * mpz/cmpabs_d.c: Likewise. + +2006-02-23 Torbjorn Granlund + + * mpn/powerpc32/vmx/copyd.asm: Set right VRSAVE bits. + * mpn/powerpc32/vmx/copyi.asm: Likewise. + +2006-02-22 Torbjorn Granlund + + * mpn/powerpc32/vmx/logops_n.asm: New file. + + * mpn/powerpc32/diveby3.asm: Rewrite. + +2006-02-21 Torbjorn Granlund + + * mpn/powerpc32/vmx/copyi.asm: New file. + * mpn/powerpc32/vmx/copyd.asm: New file. + +2006-02-17 Torbjorn Granlund + + * mpn/alpha/ev6/nails/aors_n.asm (CYSH): Import proper setting from + deleted mpn_sub_n. + +2006-02-16 Torbjorn Granlund + + * mpn/alpha/ev6/addmul_1.asm: Correct slotting comments. + +2006-02-15 Torbjorn Granlund + + * tests/devel/anymul_1.c: Copy error reporting code from addmul_N.c. + + * tests/devel/addmul_N.c: New file. + * tests/devel/mul_N.c: New file. + + * mpn/alpha/default.m4 (PROLOGUE_cpu): Align functions at 16-byte + boundary. + + * mpn/alpha/ev6/nails/aors_n.asm: New file. + * mpn/alpha/ev6/nails/add_n.asm: Remove. + * mpn/alpha/ev6/nails/sub_n.asm: Remove. + + * mpn/alpha/ev6/nails/addmul_1.asm: Rewrite. + * mpn/alpha/ev6/nails/submul_1.asm: Likewise. + * mpn/alpha/ev6/nails/mul_1.asm: Likewise. + + * mpn/alpha/ev6/nails/addmul_2.asm: Use L() for labels. + * mpn/alpha/ev6/nails/addmul_3.asm: Use L() for labels. + * mpn/alpha/ev6/nails/addmul_4.asm: Use L() for labels. + +2006-02-13 Torbjorn Granlund + + * mpn/powerpc32/diveby3.asm: Trivially reorder loop insns to save + 1 c/l. + + * mpn/x86_64/dive_1.asm: Use movabsq to support large model non-PIC. + + * mpn/x86_64/rsh1add_n.asm: Replace high register with rbx. + * mpn/x86_64/rsh1sub_n.asm: Likewise. + +2006-02-10 Torbjorn Granlund + + * mpn/powerpc64/sqr_diagonal.asm: Software pipeline. + + * mpn/powerpc64/vmx/popcount.asm: Add prefetching. + +2006-02-07 Torbjorn Granlund + + * mpn/powerpc64/mode64/diveby3.asm: Rewrite. + +2006-02-04 Torbjorn Granlund + + * mpn/powerpc64/vmx/popcount.asm: Remove mpn_hamdist partial code. + Move compare for huge n so that it is always executed. + +2006-02-03 Torbjorn Granlund + + * mpn/powerpc32/linux.m4 (LEA): Add support for PIC. + + * configure.in (powerpc): New optional, gcc_cflags_subtype. + + * mpn/x86_64/pentium4/add_n.asm: New file. + * mpn/x86_64/pentium4/sub_n.asm: New file. + * mpn/x86_64/pentium4/lshift.asm: New file. + + * mpn/powerpc64/linux64.m4 (PROLOGUE_cpu): Align function start to + 16-multiple. + * mpn/powerpc64/aix.m4: Likewise. + * mpn/powerpc64/darwin.m4: Likewise. + + * mpn/powerpc64/copyi.asm: Align loop to 16-multiple. + * mpn/powerpc64/copyd.asm: Likewise + + * configure.in (powerpc): Add vmx to relevant paths. + + * mpn/powerpc64/linux64.m4 (DEF_OBJECT): Accept 2nd argument, for + alignment. + * mpn/powerpc64/aix.m4: Likewise. + * mpn/powerpc64/darwin.m4: Likewise. + + * mpn/powerpc32/linux.m4 (DEF_OBJECT, END_OBJECT): New macros, + inherited from powerpc64 versions. + * mpn/powerpc32/aix.m4: Likewise. + * mpn/powerpc32/darwin.m4: Likewise. + + * mpn/powerpc64/vmx/popcount.asm: New file, for ppc32 and ppc64. + * mpn/powerpc32/vmx/popcount.asm: New file, grabbing above file. + +2006-01-22 Torbjorn Granlund + + * configure.in: Generalize OS-dependent patterns for powerpcs. + +2006-01-20 Torbjorn Granlund + + * mpn/x86_64/popham.asm: Optimize. + + * config.guess: Recognize power4 and up under linux-gnu. + * config.sub: Generalize power recognition code. + * acinclude.m4 (POWERPC64_PATTERN): Add 64-bit powerpc processors. + * configure.in: Recognize powerpc processors masquerading as power + processors. + +2006-01-19 Torbjorn Granlund + + * mpn/x86_64/logops_n.asm: Rewrite for more stable speed and smaller + code. + * mpn/x86_64/com_n.asm: Likewise. + +2006-01-18 Torbjorn Granlund + + * mpn/x86_64/addlsh1_n.asm: Rewrite to use indexed addressing. + * mpn/x86_64/sublsh1_n.asm: Likewise. + +2006-01-17 Torbjorn Granlund + + * mpn/generic/diveby3.c: Use GMP standard parameter names. Nailify + alternative code. Use restrict for params. + + * configure.in: Recognize andn_n as not needing nailification. + + * tests/mpq/t-equal.c (check_various): Disable a test that gives common + factors for GMP_NUMB_BITS == 62. + +2006-01-16 Torbjorn Granlund + + * mpn/generic/get_str.c (mpn_sb_get_str): Fix digit count computation, + was inaccurate for nails. + +2006-01-15 Torbjorn Granlund + + * mpn/x86_64/mode1o.asm: Remove unneeded carry register zeroing. + +2006-01-08 Torbjorn Granlund + + * mpn/alpha/ev6/sqr_diagonal.asm: New file. + +2006-01-06 Torbjorn Granlund + + * mpn/powerpc64/mode64/mod_34lsub1.asm: Tune to 1.5 c/l. + + * mpn/generic/mullow_n.c (MUL_BASECASE_ALLOC): New #define. + (mpn_mullow_n): Use it. + + * mpn/powerpc64/mode64/dive_1.asm: Use EXTERN. + * mpn/powerpc64/mode64/mode1o.asm: Likewise. + + * mpn/powerpc64/aix.m4 (EXTERN): Define to import symbol. + (LDSYM): Remove [RW] attribute. + * mpn/powerpc64/linux64.m4 (EXTERN): Dummy definition. + * mpn/powerpc64/darwin.m4 (EXTERN): Likewise. + +2006-01-05 Torbjorn Granlund + + * mpn/powerpc64/mode64/mode1o.asm: New file. + + * mpn/powerpc64/mode64/dive_1.asm: Use L() for labels. Invoke ASM_END. + + * mpn/powerpc64/mode64/invert_limb.asm: Invoke ASM_END. + + * mpn/powerpc64/linux64.m4: Move toc entry generation from direct at + DEF_OBJECT to delayed via LDSYM, define ASM_END to output it. + * mpn/powerpc64/aix.m4: Likewise. + * mpn/powerpc64/darwin.m4: Define a dummy ASM_END. + + * mpn/powerpc64/mode64/addmul_1.asm: Add POWER5 timings. + * mpn/powerpc64/mode64/mul_1.asm: Likewise. + + * mpn/powerpc64/mode64/submul_1.asm: Tweak to save 1.5 c/l for POWER5. + +2006-01-04 Torbjorn Granlund + + * mpn/powerpc64/mode64/dive_1.asm: New file. + + * mpn/powerpc64/mode64/invert_limb.asm: Add missing ASM_START. + + * mpn/powerpc64/mode64/addmul_1.asm: Fix a comment typo. + + * mpn/x86_64/diveby3.asm: Rewrite. + +2006-01-03 Torbjorn Granlund + + * configure.in: Update bugs reporting address. + + * mpn/powerpc64/mode64/diveby3.asm: Trim a cycle off of POWER4 timing. + Misc cleanup. + +2006-01-02 Torbjorn Granlund + + * mpn/powerpc64/linux64.m4 (CALL): New macro. + * mpn/powerpc64/aix.m4: Likewise. + * mpn/powerpc64/darwin.m4: Likewise, also define macro "DARWIN". + +2005-12-28 Torbjorn Granlund + + * mpn/powerpc64/mode64/mod_34lsub1.asm: New file. + +2005-12-26 Torbjorn Granlund + + * mpn/x86_64/mod_34lsub1.asm: New file. + +2005-12-20 Torbjorn Granlund + + * mpn/x86_64/submul_1.asm: Save a push/pop by not using register r12. + Use addq instead of leaq for pointer updates; schedule them. (These + changes shaves one cycle of overhead and 0.25 c/l.) + +2005-12-18 Torbjorn Granlund + + * mpf/ui_div.c: Implement workaround for GCC bug triggered on alpha. + * mpf/set_q.c: Likewise. + +2005-12-16 Torbjorn Granlund + + * mpn/generic/tdiv_qr.c: Remove statement with no effect. + Rename dead variable to `dummy'. + +2005-12-15 Torbjorn Granlund + + * demos/pexpr.c (setup_error_handler): Add a missing ";". + +2005-11-27 Torbjorn Granlund + + * mpn/generic/mul.c: Crudely call mpn_mul_fft_full before checking + for unbalanced operands. + + * mpn/generic/mul_fft.c: Remove many scalar divisions. + (mpn_mul_fft_lcm): Simplify. + (mpn_mul_fft_decompose): Rewrite to handle arbitrarily unbalanced + operands. + +2005-11-22 Torbjorn Granlund + + * configure.in: Properly recognize all 32-bit Solaris releases. + +2005-11-10 Torbjorn Granlund + + * mpn/generic/mul_fft.c: Inline mpn_fft_mul_2exp_modF, + mpn_fft_add_modF and mpn_fft_normalize. + +2005-11-02 Torbjorn Granlund + + * tests/mpz/reuse.c: Increase operand size, decrease # of reps. + + * mpz/rootrem.c: Adapt to new mpn_rootrem. + * mpz/root.c: Likewise. + + * tests/mpz/reuse.c: Test mpz_rootrem. + + With Paul Zimmermann: + * mpn/generic/rootrem.c: Complete rewrite. + +2005-10-31 Torbjorn Granlund + + * mpz/pprime_p.c (mpz_probab_prime_p): Considerably limit trial + dividing. + + * mpz/perfpow.c (mpz_perfect_power_p): Use mpz_divisible_ui_p instead + of mpz_tdiv_ui. + + * mpz/divegcd.c: Correct probability number for GCD == 1. + + * mpn/x86_64/mul_basecase.asm: Remove an obsolete comment. + + * mpn/x86: Add cycle counts for array of x86 processors. + + * mpn/x86/k7/mod_34lsub1.asm: Remove spurious mentions of ebp. + + * mpn/powerpc32: Add POWER5 timings. + + * mpn/powerpc32/README: Describe global reference variations. + + * mpn/ia64/divrem_2.asm: Add some comments. + + * mpn/ia64/divrem_1.asm: Reformat. + + * mpn/ia64/addmul_2.asm: Correct a comment on slotting. + * mpn/ia64/logops_n.asm: Likewise. + + * mpn/ia64/addmul_1.asm: Remove a redundant preg mutex decl. + + * mpn/generic/dive_1.c: Whitespace cleanup. + + * mpn/alpha/ev6/nails/addmul_1.asm: Correct comments on slotting. + * mpn/alpha/ev6/nails/addmul_2.asm: Likewise. + * mpn/alpha/ev6/nails/addmul_4.asm: Likewise. + + * mpf/out_str.c: List some allocation improvement ideas. + + * doc/gmp.texi: Update many URLs and email addresses. + + * gmp-h.in (_GMP_H_HAVE_FILE): Check also _STDIO_H_INCLUDED. + +2005-10-26 Torbjorn Granlund + + * tune/tuneup.c (tune_mullow): Update param.max_size for each threshold + measurement. + + * configure.in (POWERPC64_PATTERN/*-*-darwin*): Set + SPEED_CYCLECOUNTER_OBJ_mode64 and cyclecounter_size_mode64. + (POWERPC64_PATTERN/*-*-linux*): Likewise. + +2005-10-03 Torbjorn Granlund + + * demos/factorize.c (factor_using_division_2kp): Honor verbose flag. + (factor_using_pollard_rho): Divide out new factor before it's + clobbered. Don't stop factoring after a composite factor was found. + +2005-09-17 Torbjorn Granlund + + * demos/pexpr.c (fns): Add factorial keywords. + +2005-08-16 Torbjorn Granlund + + * tune/Makefile.am (EXTRA_DIST): Change "amd64" => "x86_64". + * mpn/Makefile.am (TARG_DIST): Change "amd64" => "x86_64". + +2005-08-15 Torbjorn Granlund + + * configure.in: Change "amd64" => "x86_64". + +2005-06-13 Torbjorn Granlund + + * mpn/generic/pre_mod_1.c: Canonicalize variable names. + + * mpn/generic/divrem.c: Rate qxn test as UNLIKELY. + + * mpn/generic/gcdext.c (sanity_check_row): Invoke TMP_MARK. + + * tune/tuneup.c (tune_mullow): Fix all max_size fields. + + * gmp-impl.h (SQR_TOOM3_THRESHOLD_LIMIT): New #define. + * tune/tuneup.c (tune_sqr): Use SQR_TOOM3_THRESHOLD_LIMIT. + (sqr_toom3_threshold): Initialize from SQR_TOOM3_THRESHOLD_LIMIT. + + * mpn/generic/mul_n.c (mpn_sqr_n): Use SQR_TOOM3_THRESHOLD_LIMIT. + + * gmp-impl.h (mpn_nand_n, mpn_iorn_n, mpn_nior_n, mpn_xnor_n): + Handle nails. + +2005-06-13 Niels Möller + + * mpn/generic/gcdext.c (gcdext_schoenhage): Check for the + (unlikely) case that one of the hgcd/euclid steps results in two + remainders of one limb each. Then use gcdext_1. + +2005-06-12 Torbjorn Granlund + + * mpn/alpha/ev6/sub_n.asm: Analogous changes as to add_n.asm last. + +2005-06-11 Torbjorn Granlund + + * mpn/alpha/ev6/add_n.asm: Rewrite inner loop to load later. + Add mpn_add_nc entry. + + * mpn/alpha/ev6/addmul_1.asm: Remove redundant initial loads. + +2005-06-09 Torbjorn Granlund + + * mpn/ia64/dive_1.asm: Fix issues with HP-UX. + +2005-06-08 Torbjorn Granlund + + * mpn/ia64/diveby3.asm: Update TODO list. + + * mpn/ia64/mode1o.asm: Fix comment typos. + + * mpn/ia64/dive_1.asm: New file. + +2005-06-07 Torbjorn Granlund + + * mpn/ia64/mode1o.asm: Add prefetching. + + * mpn/generic/dive_1.c: Use variable h for upper umul_ppmm result. + +2005-06-06 Torbjorn Granlund + + * mpn/ia64/hamdist.asm: Complete rewrite. + * mpn/ia64/popcount.asm: Rewrite to use multi-pronged feed-in. + + * mpn/ia64/aors_n.asm: Rewrite feed-in code. + * mpn/ia64/rsh1aors_n.asm: Likewise. + * mpn/ia64/aorslsh1_n.asm: Likewise. + * mpn/ia64/lorrshift.asm: Likewise. + +2005-06-04 Torbjorn Granlund + + * tests/devel/try.c (choice_array): Exclude mpn_preinv_mod_1 unless + USE_PREINV_MOD_1. + (choice_array): Exclude mpn_sqr_basecase if SQR_KARATSUBA_THRESHOLD + is zero. + +2005-06-03 Torbjorn Granlund + + * mpn/alpha/ev6/addmul_1.asm: Prefix all labels with "$". + * mpn/alpha/ev6/mul_1.asm: Likewise. + +2005-06-02 Torbjorn Granlund + + * tests/refmpn.c (refmpn_divmod_1c_workaround): Implement workaround + to gcc 3.4.x bug triggered on powerpc64 with 32-bit ABI. + +2005-06-01 Torbjorn Granlund + + * tests/devel/try.c (main): Fix a typo. + +2005-05-31 Torbjorn Granlund + + * mpn/alpha/ev6/addmul_1.asm: Rewrite for L1 cache, add prefetch. + +2005-05-30 Torbjorn Granlund + + * tests/misc.c (tests_rand_start): Mask random seed to 32 bits. + +2005-05-29 Torbjorn Granlund + + * mpn/powerpc64/mode32/mul_1.asm: Handle BROKEN_LONGLONG_PARAM. + * mpn/powerpc64/mode32/addmul_1.asm: Likewise. + * mpn/powerpc64/mode32/submul_1.asm: Likewise. + + * mpn/powerpc32/mode1o.asm: Rewrite to actually work. + + * mpn/powerpc32/aix.m4 (LEA): New macro. + (ASM_END): New macro. + + * mpn/powerpc32/linux.m4: New file. + * mpn/powerpc32/darwin.m4: New file. + * configure.in: Use linux.m4 and darwin.m4. + (powerpc64-linux-gnu): Add support for mode32. + +2005-05-25 Torbjorn Granlund + + * mpn/generic/mullow_n.c: Remove FIXME mentioning fixed flaw. + + * tests/mpz/t-cmp_d.c (check_one): Fix printf fmt string typo. + + * demos/isprime.c: #include stdlib.h. + * tests/rand/t-urbui.c: Likewise. + * tests/rand/t-urmui.c: Likewise. + + * tests/mpz/t-popcount.c (check_random): Remove spurious printf arg. + + * mpn/ia64/lorrshift.asm: Cleanup code layout. + * mpn/ia64/popcount.asm: Likewise. + +2005-05-24 Torbjorn Granlund + + * tests/devel/try.c (param_init) [TYPE_GET_STR]: Set retval field. + (compare): Handle SIZE_GET_STR as SIZE_RETVAL. + + * tests/refmpn.c (refmpn_get_str): Rewrite to make it work. + +2005-05-23 Torbjorn Granlund + + * mpn/amd64/add_n.asm: Add mpn_add_nc entry point. + * mpn/amd64/sub_n.asm: Add mpn_sub_nc entry point. + + * longlong.h (many places): Remove lvalue casts. + + * gmp-impl.h (MPF_SIGNIFICANT_DIGITS): Cast prec to avoid overflow + for > 4G digits. + + * mpn/alpha/ev6/add_n.asm: Prefetch using ldl. + * mpn/alpha/ev6/sub_n.asm: Likewise. + + * mpn/alpha/ev6/slot.pl (optable): Recognize negq and ldl. + + * mpn/ia64/aors_n.asm: Prefetch using lfetch. + * mpn/ia64/lorrshift.asm: Likewise. + * mpn/ia64/popcount.asm: Likewise. + * mpn/ia64/diveby3.asm: Likewise. + +2005-05-22 Torbjorn Granlund + + * mpn/alpha/ev67/popcount.asm: Prefetch. + * mpn/alpha/ev67/hamdist.asm: Prefetch. + + * longlong.h (add_ssaaaa) [x86]: Remove lvalue casts. + (sub_ddmmss) [x86]: Likewise. + + * tests/devel/try.c (param_init) [TYPE_MPZ_JACOBI]: Add DATA_SRC1_ODD. + (param_init) [TYPE_MPZ_KRONECKER]: Clear inherited DATA_SRC1_ODD. + (param_init) [TYPE_DIVEXACT_1]: Use symbolic name DIVISOR_LIMB. + +2005-05-21 Torbjorn Granlund + + * tests/devel/try.c (param_init) [TYPE_MPZ_JACOBI]: Initialize divisor + field according to UDIV_NEEDS_NORMALIZATION. + + * mpz/mul_i.h: Remove left-over TMP_XXXX marker arguments. + +2005-05-20 Torbjorn Granlund + + * mpn/x86/pentium4/sse2/addmul_1.asm (mpn_addmul_1c): Put carry in + proper register. + + * mpn/generic/sqr_basecase.c (mpn_sqr_basecase, addmul_2 version): + Avoid accesses out-of-bound in MPN_SQR_DIAGONAL applicate code. + +2005-05-19 Torbjorn Granlund + + * mpn/alpha/diveby3.asm: Make it actually work. + + * gmp-impl.h (MULLOW_BASECASE_THRESHOLD_LIMIT): New #define. + * mpn/generic/mullow_n.c: Use fixed stack allocation for the smallest + operands; use TMP_S* allocation for medium operands. + + * gmp-impl.h: Remove nested TUNE_PROGRAM_BUILD test. + +2005-05-18 Torbjorn Granlund + + * mpn/generic/mul_n.c: Make squaring and multiplication code more + similar. Use TMP_S* functions. + + * gmp-impl.h (TMP_DECL, TMP_MARK, TMP_FREE): Get rid of argument. + (TMP_SALLOC): New macro for "small" allocations. + (TMP_BALLOC): New macro for "big" allocations. + (TMP_SDECL, TMP_SMARK, TMP_SFREE): New macros for functions that use + just TMP_SALLOC. + (WANT_TMP_ALLOCA): Make default functions choose alloca or reentrant + functions, depending on size. + + * *.c: Remove TMP_XXXX marker arguments. + + * acinclude.m4 (WANT_TMP): Want tal-reent.lo also for alloca case. + +2005-05-16 Torbjorn Granlund + + * mpn/ia64/gmp-mparam.h: Further extend FFT tables. + +2005-05-15 Torbjorn Granlund + + * gmp-impl.h (udiv_qrnnd_preinv2): Pull an add into add_ssaaaa. + (udiv_qrnnd_preinv2gen): Likewise. + +2005-05-14 Torbjorn Granlund + + * longlong.h (add_ssaaaa) [x86_64]: Restrict allowed immediate + operands. + * (sub_ddmmss) [x86_64]: Likewise. + +2005-05-02 Torbjorn Granlund + + * acinclude.m4 (GMP_HPC_HPPA_2_0): Make gmp_tmp_v1 sed pattern handle + version numbers like B.11.X.32509-32512.GP. + + * mpn/m68k/aors_n.asm: Correct MULFUNC_PROLOGUE. + + * mpn/powerpc64/mode64/aors_n.asm: Add a MULFUNC_PROLOGUE. + + * mpf/inp_str.c: Use plain int for mpf_set_str return value (works + around gcc 4 bug). + + * acinclude.m4 (GMP_ASM_POWERPC_PIC_ALWAYS): Handle darwin's assembly + syntax. + (long long reliability test 1): New GMP_PROG_CC_WORKS_PART test. + (long long reliability test 2): New GMP_PROG_CC_WORKS_PART test. + + * configure.in: Add mode64 support for darwin. Use darwin.m4. + Add cflags_opt flags for mode32 darwin. + + * mpn/powerpc64: Use L() for all asm files. + + * mpn/asm-defs.m4 (PIC_ALWAYS): Define PIC just iff PIC_ALWAYS = "yes". + + * mpn/powerpc64/darwin.m4: New file. + + * mpn/powerpc64/linux64.m4: Remove TOCREF, add LDSYM. + Rework DEF_OBJECT to need just one argument. + * mpn/powerpc64/aix.m4: Likewise. + + * mpn/powerpc64/mode64/invert_limb.asm: Load approx_tab address with + LDSYM. Optimize somewhat. Remove 2nd DEF_OBJECT operand. + +2005-05-01 Torbjorn Granlund + + * mpn/generic/popham.c: Compute final summation differently for 64-bit. + + * tests/mpz/t-popcount.c (check_random): New function. + (main): Call it. + +2005-04-28 Torbjorn Granlund + + * mpn/amd64/add_n.asm: Use r9 instead of rbx to save push/pop. + * mpn/amd64/sub_n.asm: Likewise. + +2005-04-09 Torbjorn Granlund + + * mpn/powerpc64/copyi.asm: If HAVE_ABI_mode32, ignore upper 32 bits of + mp_size_t argument. + * mpn/powerpc64/copyd.asm: Likewise. + * mpn/powerpc64/sqr_diagonal.asm: Likewise. + * mpn/powerpc64/lshift.asm: Likewise. + * mpn/powerpc64/rshift.asm: Likewise. + * mpn/powerpc64/logops_n.asm: Likewise. + * mpn/powerpc64/com_n.asm: Likewise. + +2005-04-08 Torbjorn Granlund + + * mpn/generic/rootrem.c: Allocate PP_ALLOC limbs also for qp. + +2005-04-07 Torbjorn Granlund + + * mpn/powerpc32/add_n.asm: Add nc entry point. + * mpn/powerpc32/sub_n.asm: Likewise. + + * mpn/amd64/*.asm: Add Prescott/Nocona cycle/limb numbers. + + * mpn/alpha/add_n.asm: Add correct cycle/limb numbers. + * mpn/alpha/sub_n.asm: Likewise. + * mpn/alpha/ev5/add_n.asm: Likewise. + * mpn/alpha/ev5/sub_n.asm: Likewise. + +2005-03-31 Torbjorn Granlund + + * mpn/x86/k7/gmp-mparam.h: Fix typo in last change. + +2005-03-19 Torbjorn Granlund + + * mpn/amd64/gmp-mparam.h: Update. + + * mpn/alpha/gmp-mparam.h: Update. + * mpn/alpha/ev5/gmp-mparam.h: Update. + * mpn/alpha/ev6/gmp-mparam.h: Update. + + * mpn/ia64/gmp-mparam.h: Update. + + * mpn/x86/p6/mmx/gmp-mparam.h: Update. + * mpn/x86/pentium4/sse2/gmp-mparam.h: Update. + * mpn/x86/k7/gmp-mparam.h: Update. + + * tests/mpz/t-gcd.c (main): Honor command line reps argument. + + * tune/speed.h (SPEED_ROUTINE_MPN_GCD_CALL): Simplify and correct code + for generating test operands. + +2005-03-17 Niels Möller + + * mpn/generic/hgcd.c (qstack_adjust): New argument d, saying how much + to adjust the top quotient. + (hgcd_adjust): The quotient can be off by either 1 or 2. + +2005-03-16 Torbjorn Granlund + + * tests/mpz/t-gcd.c (MAX_SCHOENHAGE_THRESHOLD): Set to largest of + gcd,gcdext thresholds. + +2005-03-15 Niels Möller + + * mpn/generic/gcdext.c (gcdext_schoenhage): When calling gcdext_lehmer, + reuse all temporary limb storage, including the storage used for the + qstack. + +2005-03-09 Torbjorn Granlund + + * mpn/amd64/logops_n.asm: Add MULFUNC_PROLOGUE. + +2005-03-05 Torbjorn Granlund + + * mpn/amd64/gmp-mparam.h: Extend MUL_FFT_TABLE and SQR_FFT_TABLE. + * mpn/ia64/gmp-mparam.h: Likewise. + +2005-02-17 Torbjorn Granlund + + * mpn/ia64/divrem_1.asm: Add preinv entry point. + +2005-01-13 Torbjorn Granlund + + * gmp-impl.h (MPN_SIZEINBASE): Count bits in type size_t. + (MPN_SIZEINBASE_16): Likewise. + +2004-12-17 Torbjorn Granlund + + * tune/speed.c (run_gnuplot): Use lines, not linespoints. + Output a reset gnuplot command initially. + +2004-12-04 Torbjorn Granlund + + * mpn/generic/random2.c (gmp_rrandomb): Rework again. + * mpz/rrandomb.c (gmp_rrandomb): Likewise. + + * mpn/amd64/redc_1.asm: Call via PLT when PIC. + +2004-11-29 Torbjorn Granlund + + * mpn/amd64/divrem_1.asm: Add preinv entry point. + * mpn/amd64/gmp-mparam.h: Set USE_PREINV_DIVREM_1 to 1. + +2004-11-24 Torbjorn Granlund + + * mpn/alpha/diveby3.asm: Use correct prefetch instruction. + +2004-11-19 Torbjorn Granlund + + * mpn/alpha/diveby3.asm: Add ",gp" glue in PROLOGUE. + Add r31 dummy operand to `br' instruction. + +2004-11-17 Torbjorn Granlund + + * mpn/powerpc64/mode64/addmul_1.asm: Rewrite. + * mpn/powerpc64/mode64/mul_1.asm: Rewrite. + + * configure.in: Invoke AC_C_RESTRICT. + +2004-11-16 Torbjorn Granlund + + * mpn/alpha/diveby3.asm: New file. + +2004-11-13 Torbjorn Granlund + + * mpn/amd64/popham.asm: New file. + +2004-11-12 Torbjorn Granlund + + * mpn/amd64/add_n.asm: Correct cycle count. + * mpn/amd64/sub_n.asm: Likewise. + + * mpn/amd64/dive_1.asm: Speed divisors with many factors of 2. + +2004-11-11 Torbjorn Granlund + + * mpn/amd64/dive_1.asm: New file. + +2004-11-10 Torbjorn Granlund + + * mpn/generic/popham.c: Add comment. + +2004-11-09 Torbjorn Granlund + + * mpn/amd64/com_n.asm: New file. + + * mpn/amd64/logops_n.asm: New file. + +2004-11-08 Torbjorn Granlund + + * mpn/powerpc64/com_n.asm: New file. + +2004-11-05 Torbjorn Granlund + + * mpn/amd64/diveby3.asm: New file. + + * config.guess: Strip any PPC string in /proc/cpuinfo. + Recognize 970 in that code. + +2004-11-01 Torbjorn Granlund + + * mpn/amd64/mul_basecase.asm: New file. + + * mpn/amd64/redc_1.asm: New file. + +2004-10-25 Torbjorn Granlund + + * mpn/powerpc64/mode64/addlsh1_n.asm: Correct cycle counts. + + * mpn/powerpc64/README: Update POWER5/PPC970 pipeline information. + + * mpn/generic/mul_basecase.c (MAX_LEFT): Add comment. + + * doc/gmp.texi: Consistently use "x86" denotation. + (Assembler SIMD Instructions): Mention SSE2 usage. + + * demos/pexpr.c (main): Handle "negative" base in mpz_sizeinbase call. + +2004-10-18 Torbjorn Granlund + + * mpn/powerpc64/mode64/submul_1.asm: Shave 2 cycles/limb with new carry + inversion trick. + +2004-10-16 Torbjorn Granlund + + * configure.in: Support icc under x86. + (ia64-*-linux*): Pass -no-gcc to icc. + +2004-10-15 Torbjorn Granlund + + * longlong.h (ia64 umul_ppmm): Add version for icc. + + * configure.in: Support icc under ia64-*-linux*. + + * acinclude.m4: New "compiler works" test for icc 8.1 bug. + (GMP_PROG_CC_IS_GNU): Don't let Intel's icc fool us it is GCC. + +2004-10-14 Torbjorn Granlund + + * mpn/generic/gcdext.c: Add a few missing TMP_MARK. + +2004-10-14 Torbjorn Granlund + + * acinclude.m4 (GMP_ASM_W32): Try also "data4". + + * mpn/ia64/logops_n.asm: Don't use naked "br", rejected by Intel + assembler. + * mpn/ia64/aors_n.asm: Likewise. + + * mpn/ia64/divrem_2.asm: Add ".prologue". + + * mpn/ia64/hamdist.asm: Put alloc first in bundle, enforced by the + Intel assembler. + + * longlong.h: Exclude masquerading __INTEL_COMPILER from ia64 asm. + * gmp-impl.h: Likewise. + +2004-10-12 Torbjorn Granlund + + * mpn/ia64/mul_2.asm: Rewrite function entry code, write new code for + n=2. + * mpn/ia64/addmul_2.asm: Likewise. + + * tests/devel/try.c: Handle mpn_mul_2 like mpn_addmul_2. + + * tune/speed.c (routine): Make R parameter optional for mpn_mul_2. + +2004-10-11 Torbjorn Granlund + + * mpn/sparc64/addmul_1.asm: Update a comment. + + * tests/devel/aors_n.c: #include tests.h. + * tests/devel/anymul_1.c: Likewise. + * tests/devel/shift.c: Likewise. + * tests/devel/copy.c: Likewise. + + * tests/devel/aors_n.c: Handle also mpn_addlsh1_n, mpn_sublsh1_n, + mpn_rsh1add_n, and mpn_rsh1sub_n. + + * mpn/ia64/submul_1.asm: Add TODO item. + + * mpn/ia64/aors_n.asm: Rewrite function entry code (again). + * mpn/ia64/aorslsh1_n.asm: Likewise. + * mpn/ia64/logops_n.asm: Likewise. + + * mpn/ia64/rsh1aors_n.asm: Tune function entry and feed-in code. + * mpn/ia64/lorrshift.asm: Likewise. Remove several spurious loads. + + * tests/devel/Makefile.am (EXTRA_PROGRAMS): Updates for yesterday's + file removals and additions. + +2004-10-10 Torbjorn Granlund + + * mpn/ia64/copyi.asm: Tune function entry code. + * mpn/ia64/copyd.asm: Likewise. + + * mpn/ia64/logops_n.asm: Tune function entry and feed-in code for speed + and size. + * mpn/ia64/aors_n.asm: Likewise. + + * mpn/powerpc64/logops_n.asm: Correct cycles counts. + * mpn/powerpc64/mode64/aors_n.asm: Likewise. + + * tests/devel/copy.c: Handle both MPN_COPY_INCR and MPN_COPY_DECR. + + * tests/devel/logops_n.c: New file, handle all logical operations. + + * tests/devel/anymul_1.c: New file, handle mpn_mul_1, mpn_addmul_1, and + mpn_submul_1 + * tests/devel/mul_1.c: Remove. + * tests/devel/addmul_1.c: Remove. + * tests/devel/submul_1.c: Remove. + + * tests/devel/shift.c: New file, handle mpn_lshift and mpn_rshift. + * tests/devel/lshift.c: Remove. + * tests/devel/rshift.c: Remove. + + * tests/devel/aors_n.c: New file, handle mpn_add_n and mpn_sub_n. + * tests/devel/add_n.c: Remove. + * tests/devel/sub_n.c: Remove. + +2004-10-09 Torbjorn Granlund + + * mpn/powerpc64/linux64.m4: Define DEF_OBJECT, END_OBJECT, and TOCREF. + * mpn/powerpc64/aix.m4: Likewise. + * mpn/powerpc64/mode64/invert_limb.asm: Use DEF_OBJECT, END_OBJECT, and + TOCREF for approx_tab. + + * mpn/amd64/mul_1.asm: Add mpn_mul_1c entry point. + +2004-10-08 Torbjorn Granlund + + * mpn/powerpc64/copyi.asm: New file. + * mpn/powerpc64/copyd.asm: New file. + * gmp-h.in: Remove PPC MPN_COPY variants. + * gmp-impl.h: Likewise. + + * mpn/powerpc64/logops_n.asm: New file. + + * mpn/powerpc64/mode64/invert_limb.asm: New file. + +2004-10-07 Torbjorn Granlund + + * mpn/powerpc64/mode64/aors_n.asm: New file, optimized for POWER4 and + its derivatives. + * mpn/powerpc64/mode64/add_n.asm: Delete. + * mpn/powerpc64/mode64/sub_n.asm: Delete. + + * configfsf.guess: Patch HP-UX code to accommodate HP compiler's new + inability to read from stdin. + + * mpn/powerpc64/mode64/addsub_n.asm: Remove accidentally added file. + +2004-10-02 Torbjorn Granlund + + * mpn/amd64/README: Update for new developments, fix typos. + + * mpn/amd64/mul_1.asm: Tweak addressing (3.25 => 3.0 cycles/limb). + + * mpn/amd64/addmul_1.asm: Remove unreachable code block. + +2004-09-30 Torbjorn Granlund + + * mpn/amd64/addmul_1.asm: Rewrite, now 3.25 cycles/limb. + + * mpn/ia64/addmul_1.asm: Slightly enhance cross-jumping for code + density. + * mpn/ia64/mul_1.asm: Analogous changes. + +2004-09-29 Torbjorn Granlund + + * gmp-impl.h (x86 ULONG_PARITY): Work around GCC change of "q" register + flag. + +2004-09-28 Torbjorn Granlund + + * mpn/ia64/divrem_1.asm: Add cycle counts to loop. + + * mpn/ia64/divrem_2.asm: New file. + +2004-09-28 Paul Zimmermann + + * mpn/generic/mul_fft.c (mpn_mul_fft): Fix a bug in the choice of the + recursive fft parameters. + +2004-09-20 Torbjorn Granlund + + * tests/misc.c (tests_rand_start): Default to strtoul for re-seeding. + + * tests/mpz/t-mul.c (ref_mpn_mul): Fudge tmp allocation for toom3. + +2004-09-19 Torbjorn Granlund + + * tests/misc.c (tests_rand_start): Shift tv_usec for better seeding. + +2004-09-18 Torbjorn Granlund + + * tests/misc.c (tests_rand_start): Invoke fflush after printing seed. + + * tests/mpz/t-mul.c (main): Check environment for GMP_CHECK_FFT, run + extra FFT tests if set. + (ref_mpn_mul): Use library code for kara and toom, but skewded so that + we never use the same algorithm that we're testing. + (mul_kara): Delete. + (debug_mp): Print just one line of large numbers. + (ref_mpn_mul): Rework usage of tp temporary space. + +2004-09-15 Torbjorn Granlund + + * mpn/ia64/mul_2.asm: For HAVE_ABI_32, convert vp. + * mpn/ia64/addmul_2.asm: Likewise. + +2004-09-13 Torbjorn Granlund + + * mpn/ia64/invert_limb.asm: Rewrite. + + * mpn/ia64/logops_n.asm: Insert some more stops. + +2004-09-12 Torbjorn Granlund + + * mpn/ia64/gmp-mparam.h: Update. + * mpn/amd64/gmp-mparam.h: Update. + + * mpn/ia64/sqr_diagonal.asm: Shave off a few cycles. + +2004-09-11 Torbjorn Granlund + + * mpn/ia64/mul_2.asm: New file. + * mpn/ia64/addmul_2.asm: New file. + + * mpn/ia64/addmul_1.asm: Tune a cycle from prologue. + + * mpn/ia64/lorrshift.asm: Insert stops after several branches. + * mpn/ia64/aorslsh1_n.asm: Likewise. + * mpn/ia64/rsh1aors_n.asm: Likewise. + + * mpn/generic/sqr_basecase.c: In variant for HAVE_NATIVE_mpn_addmul_2, + accumulate carry also for when HAVE_NATIVE_mpn_addlsh1_n. + +2004-09-07 Torbjorn Granlund + + * mpn/ia64/submul_1.asm: Rewrite. + + * mpn/ia64/addmul_1.asm: Format to placate HP-UX assembler. + * mpn/ia64/mul_1.asm: Likewise. + +2004-09-02 Torbjorn Granlund + + * mpn/ia64/mul_1.asm: Optimize feed-in code. + * mpn/ia64/addmul_1.asm: Rewrite feed-in code. + +2004-08-29 Torbjorn Granlund + + * tests/mpz/t-sizeinbase.c: Disable mpz_fake_bits and check_sample. + +2004-07-16 Torbjorn Granlund + + * mpn/ia64/addmul_1.asm: Format to placate HP-UX assembler. + +2004-06-17 Kevin Ryde + + * doc/gmp.texi: Use @. when sentence ends with a capital, for good + spacing in tex. + (Language Bindings): Add gmp-d, reported by Ben Hinkle. Update SWI + Prolog URL, reported by Jan Wielemaker. + +2004-06-09 Torbjorn Granlund + + * configure.in: Handle --enable-fat. Use that to enable x86 fat + builds, remove magic meaning of i386-*-*. + +2004-06-03 Kevin Ryde + + * gmp-impl.h (memset): Use a local char* pointer, in case parameter is + something else (eg. tune/common.c). Reported by Emmanuel Thomé. + +2004-06-01 Kevin Ryde + + * config.guess (i?86-*-*): Avoid "Illegal instruction" message which + goes to stdout on 80386 freebsd4.9. + +2004-05-23 Niels Möller + + * mpn/generic/gcdext.c (gcdext_1_u): New function. + (mpn_gcdext): Use it. + +2004-05-23 Torbjorn Granlund + + * mpn/generic/gcdext.c (gcdext_1_odd): Use masking to avoid jumps. + +2004-05-22 Torbjorn Granlund + + * mpn/x86/pentium4/sse2/addmul_1.asm: Add Prescott cycle numbers. + + * mpn/amd64/divrem_1.asm: Shave a cycle from fraction development code. + + * mpn/powerpc32/lshift.asm: Add more cycle numbers. + * mpn/powerpc32/rshift.asm: Likewise. + + * mpn/ia64/addmul_1.asm: Reformat. + +2004-05-21 Torbjorn Granlund + + * gmp-impl.h (mpn_mullow_n, mpn_mullow_basecase): Declare. + + * tune/Makefile.am: Compile gcdext.c. + + * gmp-impl.h (GET_STR_THRESHOLD_LIMIT): Lower outrageous value to 150. + (GCDEXT_SCHOENHAGE_THRESHOLD): Set reasonable default. Override when + TUNE_PROGRAM_BUILD. + (GCDEXT_THRESHOLD): Remove. + + * tune/tuneup.c (gcdext_schoenhage_threshold): New variable. + (gcdext_threshold): Remove variable. + (tune_gcd_schoenhage): Lower step_factor to 0.1. + (tune_gcdext_schoenhage): New function, based on tune_gcd_schoenhage. + (tune_gcdext): Remove function. + (all): Corresponding changes. + +2004-05-21 Niels Möller + + * mpn/generic/gcdext.c: Complete rewrite. Uses fast Lehmer code for + small operands, and Schoenhage code for large operands. + + * tune/speed.h (SPEED_ROUTINE_MPN_GCD_CALL): Ensure first operand is + not smaller than 2nd operand. + +2004-05-17 Kevin Ryde + + * gmp-h.in (mpz_get_ui): Use #if instead of plain if, and for nails + use ?: same as normal case, to avoid warnings from Borland C++ 6.0. + Reported by delta trinity. + +2004-05-15 Kevin Ryde + + * tune/time.c (getrusage_backwards_p): New function + (speed_time_init): Use it to exclude broken netbsd1.4.1 getrusage. + * configure.in (m68*-*-netbsd1.4*): Remove code pretending getrusage + doesn't exist. + * tune/README (NetBSD 1.4.1 m68k): Update notes. + + * configure.in (mips*-*-* ABI=n32): Remove gcc_n32_ldflags and + cc_n32_ldflags, libtool knows to put the linker in n32 mode. + +2004-05-15 Torbjorn Granlund + + * config.guess (powerpc*-*-*): Add more processor types to mfpvr code. + * configure.in: Generalize powerpc subtype matching code. + + * mpz/fac_ui.c: Misc cleanups, spelling corrections. + +2004-05-14 Kevin Ryde + + * mpf/sub.c: When one operand cancels high limbs of the other, strip + high zeros on the balance before truncating to destination precision. + Truncating first loses accuracy and can lead to a result 0 despite + operands being not equal. Reported by John Abbott. + Also, ensure exponent is zero when result is zero, for instance if + operands are exactly equal. + * tests/mpf/t-sub.c (check_data): New function, exercising these. + +2004-05-12 Kevin Ryde + + * configure.in (AC_PROG_RANLIB): New macro, supposedly required by + automake, though it doesn't complain. + + * demos/expr/Makefile.am (ARFLAGS): Add a default setting, to + workaround an automake bug. + +2004-05-10 Kevin Ryde + + * */Makefile.in, install-sh, aclocal.m4: Update to automake 1.8.4. + + * doc/gmp.texi (Demonstration Programs): Add a remark about expression + evaluation in the main gmp library. + + * demos/expr/exprfa.c (mpf_expr_a): Correction to mpX_init, use + mpf_init2 to follow requested precision. + * demos/expr/exprza.c, demos/expr/exprqa.c: Use wrappers for mpX_init, + to make parameters match. + + * demos/expr/run-expr.c: Don't use getopt, to avoid needing configury + for optarg declaration. Remove TRY macro, rename foo and bar to var_a + and var_b, for clarity. + * demos/expr/expr-impl.h: Don't use expr-config.h. + * configure.in (demos/expr/expr-config.h): Remove. + * demos/expr/expr-config.in: Remove file. + +2004-05-08 Kevin Ryde + + * doc/configuration (Configure): Update for current automake not + copying acinclude.m4 into aclocal.m4. + + * configure.in, Makefile.am, doc/gmp.texi, doc/configuration, + tests/cxx/Makefile.am, demos/expr/Makefile.am, demos/expr/README, + demos/expr/expr.c, demos/expr/expr.h, demos/expr/expr-config-h.in, + demos/expr/expr-impl.h, demos/expr/run-expr.c, demos/expr/t-expr.c: + MPFR now published separately, remove various bits. + * mpfr/*, tests/cxx/t-headfr.cc, demos/expr/exprfr.c, + demos/expr/exprfra.c: Remove. + +2004-05-07 Kevin Ryde + + * tests/cxx/Makefile.am (TESTS_ENVIRONMENT): Amend c++ shared library + path hack, on k62-unknown-dragonfly1.0 /usr/bin/make runs its commands + "set -e", so we need an "|| true" in case there's nothing to copy (for + instance in a static build). + +2004-05-06 Kevin Ryde + + * mpn/alpha/mode1o.c: Remove, in favour of ... + * mpn/alpha/mode1o.asm: New file. + * mpn/alpha/alpha-defs.m4 (bwx_available_p): New macro. + + * tune/amd64.asm: Save rbx in r10 rather than on the stack. + + * configure.in (x86_64-*-*): Try also "-march=k8 -mno-sse2", in case + we're in ABI=32 on an old OS not supporting xmm regs. + (GMP_GCC_PENTIUM4_SSE2, GMP_OS_X86_XMM): Run these tests under + -march=k8 too, and not under ABI=64. + + * doc/gmp.texi (Converting Integers): For mpz_get_d, note truncation + and overflows. For mpz_get_d_2exp note truncation, note result if + OP==0, and cross reference libc frexp. + (Rational Conversions): For mpq_get_d, note truncation and overflows. + (Converting Floats): For mpf_get_d, note truncation and overflows. + For mpf_get_d_2exp, note truncation, note result if OP==0. + (Assembler Code Organisation): Note nails subdirectories. + Clarification of get_d_2exp OP==0 reported by Sylvain Pion. + +2004-05-05 Torbjorn Granlund + + * mpn/generic/mullow_n.c, mpn/generic/mullow_basecase.c: New files + (mainly by Niels Möller). + * configure.in, mpn/Makefile.am: Add them. + + * gmp-impl.h (MULLOW_BASECASE_THRESHOLD, MULLOW_DC_THRESHOLD, + MULLOW_MUL_N_THRESHOLD): Override for TUNE_PROGRAM_BUILD. + + * tune/Makefile.am: Compile mullow_n.c. + * tune/common.c (speed_mpn_mullow_n, speed_mpn_mullow_basecase): + New functions. + * tune/speed.c (routine): Add entries for mpn_mullow_n and + mpn_mullow_basecase. + * tune/speed.h (SPEED_ROUTINE_MPN_MULLOW_N_CALL, + SPEED_ROUTINE_MPN_MULLOW_BASECASE): New #defines. + * tune/tuneup.c (tune_mullow): New function. + + * gmp-impl.h (invert_limb): Compute branch-freely. + +2004-05-02 Kevin Ryde + + * mpn/amd64/mode1o.asm: Use movabsq to support large model non-PIC. + Use 32-bit insns to save code bytes, and to save a couple of cycles on + the initial setup multiplies. + +2004-05-01 Kevin Ryde + + * doc/gmp.texi (References): Update gcc online docs url to + gcc.gnu.org. + + * configure.in (mips*-*-irix[6789]*): Correction to m4 quoting of this + pattern. (Believe the mips64*-*-* part also used picks up all current + irix6 tuples anyway.) Reported by Rainer Orth. + +2004-04-30 Kevin Ryde + + * acinclude.m4 (GMP_PROG_CC_X86_GOT_EAX_EMITTED, + GMP_ASM_X86_GOT_EAX_OK): New macros. + (GMP_PROG_CC_WORKS): Use them to detect an old gas bug tickled by + recent gcc. Reported by David Newman. + + * doc/gmp.texi (Reentrancy): Note also gmp_randinit_default as an + alternative to gmp_randinit. + +2004-04-29 Torbjorn Granlund + + * configfsf.guess: Update to 2004-03-12. + * configfsf.sub: Likewise. + +2004-04-27 Torbjorn Granlund + + * mpz/rrandomb.c (gmp_rrandomb): Rework to avoid extra limb allocation + and to generate even numbers. + * mpn/generic/random2.c (gmp_rrandomb): Likewise. + +2004-04-25 Kevin Ryde + + * gmp-impl.h (FORCE_DOUBLE): Don't use an asm with a match constraint + on a memory output, apparently not supported and provokes a warning + from gcc 3.4. + +2004-04-24 Kevin Ryde + + * longlong.h (count_leading_zeros_gcc_clz, + count_trailing_zeros_gcc_ctz): New macros. + (count_leading_zeros, count_trailing_zeros) [x86]: Use them on gcc + 3.4. + + * configure.in (x86-*-* gcc_cflags_cpu): Give a -mtune at the start of + each option list, for use by gcc 3.4 to avoid deprecation warnings + about -mcpu. + + * mpz/aorsmul.c, mpz/aorsmul_i.c, mpz/cfdiv_q_2exp.c, + mpz/cfdiv_r_2exp.c, mpq/aors.c, mpf/ceilfloor.c: Give REGPARM_ATTR() + on function definition too, as demanded by gcc 3.4. + +2004-04-22 Kevin Ryde + + * tests/rand/t-lc2exp.c (check_bigc1): New test. + + * doc/fdl.texi: Tweak @appendixsubsec -> @appendixsec to match our + preference for this in an @appendix, and because texi2pdf doesn't + support @appendixsubsec directly within an @appendix. + +2004-04-20 Kevin Ryde + + * doc/texinfo.tex: Update to 2004-04-07.08 from texinfo 4.7. + * doc/gmp.texi, mpfr/mpfr.texi (@copying): Don't put a line break in + @ref within @copying, recent texinfo.tex doesn't like that. + + * demos/perl/GMP.xs (static_functable): Treat cygwin the same as mingw + DLLs. + + * */Makefile.in, install-sh: Update to automake 1.8.3. + * ltmain.sh, aclocal.m4, configure: Update to libtool 1.5.6. + + * gmp-impl.h (LIMB_HIGHBIT_TO_MASK): Use a compile-time constant + expression, rather than a configure test. + * acinclude.m4, configure.in (GMP_C_RIGHT_SHIFT): Remove, no longer + needed. + * tests/t-hightomask.c: New file. + * tests/Makefile.am (check_PROGRAMS): Add it. + + * macos/configure (parse_top_configure): Look for PACKAGE_NAME and + PACKAGE_VERSION now used by autoconf. + (what_objects): Only demand 9 object files, as for instance occurs in + the scanf directory. + (asm files): Transform labels L(foo) -> Lfoo. Take func name from + PROLOGUE to support empty "EPILOGUE()". Recognise and substitute + register name "define()"s. + * macos/Makefile.in (CmnObjs): Add tal-notreent.o. + +2004-04-19 Torbjorn Granlund + + * tune/speed.h (SPEED_ROUTINE_MPN_ROOTREM): New #define. + (speed_mpn_rootrem): Declare. + * tune/common.c (speed_mpn_rootrem): New function. + * tune/speed.c (routine): Add entry for mpn_rootrem. + +2004-04-16 Kevin Ryde + + * doc/fdl.texi: Update from FSF, just fixing a couple of typos. + + * macos/configure, macos/Makefile.in: Add printf and scanf directories. + + * tests/mpz/t-gcd.c (check_data): New function, exercising K6 + gcd_finda bug. + +2004-04-14 Kevin Ryde + + * doc/gmp.texi (Reentrancy, Random State Initialization): Note + gmp_randinit use of gmp_errno is not thread safe. Reported by Vincent + Lefèvre. + + * doc/gmp.texi (Random State Initialization): Add index entries for + gmp_errno and constants. + + * mpn/m68k/README: Update _SHORT_LIMB -> __GMP_SHORT_LIMB. + + * configure.in (--enable-mpbsd): Typo Berkley -> Berkeley in help msg. + +2004-04-12 Kevin Ryde + + * demos/perl/GMP.xs (static_functable): New macro, use it for all + function tables, to support mingw DLL builds. + * demos/perl/INSTALL (NOTES FOR PARTICULAR SYSTEMS): Remove note on + DLLs, should be ok now. + + * demos/perl/sample.pl: Print the module and library versions in use. + + * demos/perl/GMP.pm, Makefile.PL (VERSION): Set to '2.00'. + * demos/perl/GMP.pm (COPYRIGHT): New in the doc section. + + * Makefile.am: Note 4.1.3 libtool versioning info, and REVISION policy. + + * tal-debug.c: Add for abort. + +2004-04-07 Torbjorn Granlund + + * tests/refmpf.c (refmpf_add_ulp): Adjust exponent when needed. + + * mpn/generic/random2.c: Rewrite (clone mpz/rrandomb.c). + +2004-04-07 Kevin Ryde + + * mpn/x86/k6/gcd_finda.asm: Correction jbe -> jb in initial setups. + Zero flag is wrong here, it relects only the high limb of the compare, + leading to n1>=n2 not satisfied and wrong results. cp[1]==0x7FFFFFFF + with cp[0]>=0x80000001 provokes this. + + * doc/gmp.texi (BSD Compatible Functions): Note "pow" name clash under + the pow function description too. + (Language Bindings): Add XEmacs (betas at this stage). Reported by + Jerry James. + + * tests/refmpn.c (refmpn_mod2): Correction to ASSERTs, r==a is allowed. + + * gen-psqr.c (generate_mod): Cast mpz_invert_ui_2exp args, for K&R. + * gen-bases.c, gen-fib.c, gen-psqr.c: For mpz_out_str, use stdout + instead of 0, in case a K&R treats int and FILE* params differently. + +2004-04-04 Kevin Ryde + + * gmp-impl.h (BSWAP_LIMB) [amd64]: New macro. + (FORCE_DOUBLE): Use this for amd64 too. + + * tests/amd64check.c, tests/amd64call.asm: New files, derived in part + from x86check.c and x86call.asm. + * tests/Makefile.am (EXTRA_libtests_la_SOURCES): Add them. + * configure.in (x86_64-*-* ABI=64): Use them. + +2004-04-03 Kevin Ryde + + * mpn/amd64/mode1o.asm: New file. + * mpn/amd64/amd64-defs.m4 (ASSERT): New macro. + + * mpn/x86/k7/mmx/divrem_1.asm, mpn/x86/pentium4/sse2/divrem_1.asm: Add + note on how "dr" part of algorithm is handled. + + * mpn/x86/k7/dive_1.asm, mpn/x86/k7/mod_34lsub1.asm, + mpn/x86/k7/mode1o.asm: Note Hammer (32-bit mode) speeds. + +2004-03-31 Kevin Ryde + + * doc/gmp.texi (Language Bindings): Add GOO, MLGMP and Numerix. + + * mpf/mul_2exp.c, mpf/div_2exp.c: Rate u==0 as UNLIKELY. + +2004-03-28 Torbjorn Granlund + + * mpn/amd64/divrem_1.asm: Trim a few cycles. + +2004-03-27 Torbjorn Granlund + + * mpn/amd64/sublsh1_n.asm: Fix typo. + + * mpn/generic/divrem_1.c: Fix typo. + + * mpn/generic/sqr_basecase.c: Fix typo. + + * mpn/amd64/divrem_1.asm: New file. + +2004-03-20 Kevin Ryde + + * longlong.h (power, powerpc): Add comments on how we select this code. + + * gmp-h.in (mpz_get_ui): Use ?: instead of mask style, gcc treats the + two identically but ?: is a bit clearer. + + * insert-dbl.c: Remove file, no longer used, scaling is now integrated + in mpn_get_d. + * Makefile.am (libgmp_la_SOURCES): Remove insert-dbl.c. + * gmp-impl.h (__gmp_scale2): Remove prototype. + +2004-03-17 Kevin Ryde + + * mpn/x86/fat/fat.c (__gmpn_cpuvec_init, fake_cpuid_table): Add x86_64. + + * mpq/get_d.c: Use mpn_tdiv_qr, demand den>0 per canonical form. + +2004-03-16 Torbjorn Granlund + + * mpn/generic/sqr_basecase.c: Add versions using mpn_addmul_2 and + mpn_addmul_2s. + +2004-03-14 Kevin Ryde + + * mpf/mul_ui.c: Incorporate carry from low limbs, for exactness. + * tests/mpf/t-mul_ui.c: New file. + * tests/mpf/Makefile.am (check_PROGRAMS): Add it. + + * mpf/div.c: Use mpn_tdiv_qr. Use just one TMP_ALLOC. Use full + divisor, since truncating can lose accuracy. + * tests/mpf/t-div.c: New file. + * tests/mpf/Makefile.am (check_PROGRAMS): Add it. + + * tests/mpf/t-set_q.c, tests/mpf/t-ui_div.c (check_various): Amend + bogus 99/4 test. + * tests/mpf/t-ui_div.c (check_rand): Exercise r==v overlap. + + * tests/refmpf.c, tests/tests.h (refmpf_set_overlap): New function. + + * mpf/cmp_si.c [nails]: Correction, cast vval in exp comparisons, for + when vval=-0x800..00 and limb==longlong. + + * mpf/cmp_si.c [nails]: Correction, return usign instead of 1 when + uexp==2 but value bigger than an mp_limb_t. + * tests/mpf/t-cmp_si.c (check_data): Add test cases. + + * tests/trace.c (mpf_trace): Use ABS(mp_trace_base) to allow for + negative bases used for upper case hex in integer traces. + +2004-03-12 Torbjorn Granlund + + * mpn/generic/sb_divrem_mn.c: Correct header comment. + +2004-03-11 Kevin Ryde + + * aclocal.m4, configure, ltmain.sh: Downgrade to libtool 1.5, version + 1.5.2 doesn't remove .libs/*.a files when rebuilding, which is bad for + development when changing contents or with duplicate named files like + we have. + + Revert this, ie restore AR_FLAGS=cq: + * acinclude.m4 (GMP_PROG_AR): Remove AR_FLAGS=cq, libtool 1.5.2 now + does this itself on detecting duplicate object filenames in piecewise + linking mode. + + * randbui.c, randmui.c [longlong+nails]: Correction to conditionals + for second limb. + + * mpz/aors_ui.h, mpz/cdiv_q_ui.c, mpz/cdiv_qr_ui.c, mpz/cdiv_r_ui.c, + mpz/cdiv_ui.c, mpz/fdiv_q_ui.c, mpz/fdiv_qr_ui.c, mpz/fdiv_r_ui.c, + mpz/fdiv_ui.c, mpz/gcd_ui.c, mpz/iset_ui.c, mpz/lcm_ui.c, + mpz/set_ui.c, mpz/tdiv_q_ui.c, mpz/tdiv_qr_ui.c, mpz/tdiv_r_ui.c, + mpz/tdiv_ui.c, mpz/ui_sub.c, mpf/div_ui.c, mpf/mul_ui.c + [longlong+nails]: Amend #if to avoid warnings about shift amount. + +2004-03-07 Kevin Ryde + + * mpf/reldiff.c: Use rprec+ysize limbs for d, to ensure accurate + result. Inline mpf_abs(d,d) and mpf_cmp_ui(x,0), and rate the latter + UNLIKELY. + + * mpf/ui_div.c: Use mpn_tdiv_qr. Use just one TMP_ALLOC. Use full + divisor, since truncating can lose accuracy. + * tests/mpf/t-ui_div.c: New file. + * tests/mpf/Makefile.am (check_PROGRAMS): Add it. + + * mpf/set_q.c: Expand TMP_ALLOC_LIMBS_2, to make conditional clearer + and avoid 1 limb alloc when not wanted. + + * gmp-impl.h (WANT_TMP_DEBUG): Define to 0 if not defined. + (TMP_ALLOC_LIMBS_2): Use "if" within macro rather than "#if", for less + preprocessor conditionals. + + * mpf/mul_2exp.c, mpf/div_2exp.c: Add some comments. + + * tests/refmpn.c (refmpn_sb_divrem_mn, refmpn_tdiv_qr): Nailify. + +2004-03-04 Kevin Ryde + + * gen-psqr.c (print): Add CNST_LIMB in PERFSQR_MOD_TEST, for benefit + of K&R. + * tests/mpn/t-perfsqr.c (PERFSQR_MOD_1): Use CNST_LIMB for K&R. + + * doc/configuration (Configure): Remove mkinstalldirs, no longer used. + + * acinclude.m4 (GMP_PROG_AR): Remove AR_FLAGS=cq, libtool 1.5.2 now + does this itself on detecting duplicate object filenames in piecewise + linking mode. + + * configure.in (hppa2.0*-*-*): Test sizeof(long) == 4 or 8 to verify + ABI=2.0n versus ABI=2.0w. In particular this lets CC=cc_bundled + correctly fall back to ABI=2.0n (we don't automatically add CC=+DD64 + to that compiler, currently). + + * doc/gmp.texi (Reentrancy): Note C++ mpf_class constructors using + global default precision. + (Random State Miscellaneous): Describe gmp_urandomb_ui as giving N + bits. + (C++ Interface Floats): Describe operator= copying the value, not the + precision, and what this can mean about copy constructor versus + default constructor plus assignment. + + * mpf/set_q.c: Use mpn_tdiv_qr rather than mpn_divrem, so no shifting. + Don't truncate the divisor, it can make the result inaccurate. + * tests/mpf/t-set_q.c: New file. + * tests/mpf/Makefile.am (check_PROGRAMS): Add it. + + * mpf/set.c: Use MPN_COPY_INCR, in case r==u and ABSIZ(u) > PREC(r)+1. + No actual bug here, because MPN_COPY has thusfar been an alias for + MPN_COPY_INCR, only an ASSERT failure. + * tests/mpf/t-set.c: New file. + * tests/mpf/Makefile.am (check_PROGRAMS): Add it. + + * mpf/set.c, mpf/iset.c: Do MPN_COPY last, for possible tail call. + + * mpf/set_d.c: Rate d==0 as UNLIKELY. Store size before extract call, + to shorten lifespan of "negative". + + * mpf/init.c, mpf/init2.c, mpf/iset_d.c, mpf/iset_si.c, + mpf/iset_str.c, mpf/iset_ui.c: Store prec before alloc call, for one + less live quantity across that call. + * mpf/init.c, mpf/init2.c, mpf/iset_str.c: Store size and exp before + alloc call, to overlap with other operations. + + * tests/refmpf.c, tests/tests.h (refmpf_fill, refmpf_normalize, + refmpf_validate, refmpf_validate_division): New functions. + + * tests/refmpn.c, tests/tests.h (refmpn_copy_extend, + refmpn_lshift_or_copy_any, refmpn_rshift_or_copy_any): New functions. + + * tal-debug.c: Add for strcmp. + + * tests/cxx/t-istream.cc (check_mpz, check_mpq, check_mpf): Use size_t + for loop index, to quieten g++ warning. + +2004-03-02 Kevin Ryde + + * tests/mpn/t-hgcd.c: Use __GMP_PROTO on prototypes. + +2004-03-01 Torbjorn Granlund + + With Karl Hasselström: + * mpn/generic/dc_divrem_n.c (mpn_dc_div_2_by_1): New function, with + meat from old mpn_dc_divrem_n. Accept scratch parameter. Rewrite to + avoid a recursive call. + (mpn_dc_div_3_by_2): New function, with meat from old + mpn_dc_div_3_halves_by_2. Accept scratch parameter. + (mpn_dc_divrem_n): Now just allocate scratch space and call new + mpn_dc_div_2_by_1. + +2004-02-29 Kevin Ryde + + * longlong.h (count_leading_zeros) [alpha gcc]: New version, inlining + mpn/alpha/cntlz.asm cmpbge technique. + + * aclocal.m4, configure, install-sh, missing, ltmain.sh, + */Makefile.in: Update to automake 1.8.2 and libtool 1.5.2. + + * doc/gmp.texi (C++ Interface Integers): Note / and % rounding follows + C99 / and %. + (Exact Remainder): Index entries for divisibility testing algorithm. + + * tune/time.c (speed_endtime): Return 0.0 for negative time measured. + Revise usage comments for clarity. + * tune/common.c (speed_measure): Recognise speed_endtime 0.0 for + failed measurement. + + * tests/mpn/t-get_d.c (check_rand): Correction to nhigh_mask setup. + +2004-02-27 Torbjorn Granlund + + * tune/tuneup.c (tune_dc, tune_set_str): Up param.step_factor. + + * tests/mpz/t-gcd.c: Decrease # of tests to 50. + +2004-02-27 Kevin Ryde + + * tests/devel/try.c: Add a comment that this is not for Cray systems. + + * mpf/set_q.c: Don't support den(q)<0, demand canonical form in the + usual way. + +2004-02-24 Torbjorn Granlund + + From Kevin: + * mpn/generic/mul_fft.c (mpn_fft_add_modF): Loop until normalization + criterion met. + +2004-02-22 Kevin Ryde + + * acinclude.m4 (GMP_PROG_CC_WORKS, GMP_OS_X86_XMM, GMP_PROG_CXX_WORKS): + Remove files that might look like compiler output, so our "||" + alternatives are not fooled. + + * acinclude.m4 (GMP_PROG_CC_WORKS): Add test for lshift_com code + mis-compiled by certain IA-64 HP cc at +O3. + + * gmp-impl.h (USE_LEADING_REGPARM): Disable under prof or gprof, for + the benefit of freebsd where .mcount clobbers registers. Spotted by + Torbjorn. + * configure.in (WANT_PROFILING_PROF, WANT_PROFILING_GPROF): New + AC_DEFINEs. + +2004-02-21 Kevin Ryde + + * configure.in (sparc64-*-*bsd*): Amend -m32 setup for ABI=32, so it's + not used in ABI=64 on the BSD systems. + +2004-02-18 Niels Möller + + * tests/mpz/t-gcd.c (gcdext_valid_p): New function. + (ref_mpz_gcd): Deleted function. + (one_test): Rearranged to call mpz_gcdext first, so that the + returned value can be validated. + (main): Don't use ref_mpz_gcd. + +2004-02-18 Torbjorn Granlund + + * gmp-impl.h (MPN_TOOM3_MAX_N): Move to !WANT_FFT section. + + * tests/mpz/t-mul.c: Exclude special huge operands unless WANT_FFT. + + * mpz/rrandomb.c (gmp_rrandomb): Rewrite. + + * mpn/generic/mul_n.c (mpn_toom3_sqr_n): Remove write-only variable c5. + +2004-02-18 Kevin Ryde + + * mpf/iset_si.c, mpf/iset_ui.c, mpf/set_si.c, mpf/set_ui.c [nails]: + Always store second limb, to avoid a conditional. + + * tests/mpf/t-get_ui.c: New file. + * tests/mpf/Makefile.am (check_PROGRAMS): Add it. + * tests/mpf/t-get_si.c (check_limbdata): Further tests. + * gmp-impl.h (MP_EXP_T_MAX, MP_EXP_T_MIN): New defines. + + * mpf/get_ui.c, mpf/get_si.c: Remove size==0 test, it's covered by + other conditions. Attempt greater clarity by expressing conditions as + based on available data range. + * mpf/get_si.c [nails]: Correction, don't bail on exp > abs_size, + since may still have second limb above radix point available. + * mpf/get_ui.c: Nailify. + +2004-02-16 Kevin Ryde + + * mpz/scan0.c, mpz/scan1.c: Use count_trailing_zeros, instead of + count_leading_zeros on limb&-limb. + + * mpf/sqrt.c: Use "/ 2" for exp, avoiding C undefined behaviour on + ">>" of negatives. Correction to comment, exp is rounded upwards. + SIZ(r) always prec now, no need for tsize expression. Store EXP(r) + and SIZ(r) where calculated to reduce variable lifespans. Make tsize + mp_size_t not mp_exp_t, though of course those are currently the same. + + * gmp-h.in (GMP_ERROR_ALLOCATE, GMP_ERROR_BAD_STRING, + GMP_ERROR_UNUSED_ERROR): Remove, never used or documented, and we + don't want to use globals for communicating error information. + + * mpz/gcd_ui.c [nails]: Correction, actually return a value. + + * mpn/generic/addmul_1.c, mpn/generic/submul_1.c [nails==1]: Add code. + +2004-02-15 Kevin Ryde + + * tests/mpz/t-jac.c (check_data): Remove unnecessary variable + "answer". + +2004-02-14 Torbjorn Granlund + + * mpn/ia64/aors_n.asm: Break a group with a RAW conflict. + +2004-02-14 Kevin Ryde + + * acinclude.m4 (GMP_C_RIGHT_SHIFT): Note that it's "long"s which we're + concerned about. + + * mpn/generic/mul_n.c: Add some remarks about toom3 high zero + stripping. + + * mpn/generic/scan0.c, mpn/generic/scan1.c: Remove design issue + remarks. What to do about going outside `up' space is a problem, but + anything to address it would be an incompatible change. + +2004-02-12 Torbjorn Granlund + + * tests/mpn/t-hgcd.c: Remove unused variables. + + * mpn/ia64/hamdist.asm: Remove bundling incompatible with HP-UX + assembler. Misc HP-UX changes. + * mpn/ia64/gcd_1.asm: Add some syntax to placid the HP-UX assembler. + +2004-02-11 Kevin Ryde + + * longlong.h (power, powerpc): Use HAVE_HOST_CPU_FAMILY_power and + HAVE_HOST_CPU_FAMILY_powerpc rather than various cpp defines. + + * gmp-impl.h: Add remarks about limits.h and Cray etc. + + * mpn/ia64/mul_1.asm: Don't put .pred directives on labelled lines, + hpux 11.23 assembler doesn't like that. + * mpn/ia64/README: Add a note on this. + + * dumbmp.c (mpz_mul): Set ALLOC(r) for new data block used. Reported + by Jason Moxham. + + * mpn/pa32/README, mpn/pa64/README (REFERENCES): New sections. + +2004-02-10 Torbjorn Granlund + + * tests/mpz/t-gcd.c: Decrease # of tests run. + + * mpn/*/gmp-mparam.h: Add HGCD values, update TOOM values. + +2004-02-01 Torbjorn Granlund + + From Kevin: + * config.guess: Recognize AMD's hammer processors, return x86_64. + +2004-01-31 Niels Möller + + * mpn/generic/hgcd.c (mpn_cmp_sum3): Declare static. + +2004-01-25 Niels Möller + + * tests/mpn/Makefile.am (check_PROGRAMS): Add t-hgcd. + + * mpn/generic/hgcd.c (hgcd_jebelean): Simplify, use mpn_cmp_sum3. + (mpn_cmp_sum3): New function. + (mpn_diff_smaller_p): Remove. + (hgcd_final, hgcd_jebelean, hgcd_small_1, hgcd_small_2, euclid_step): + Remove tp,talloc arguments. Callers changed. + +2004-01-25 Torbjorn Granlund + + * tune/tuneup.c (all): Reenable calls of tune_gcd_schoenhage and + tune_hgcd. + + * mpn/generic/gcd.c: Reenable Schoenhage code. + + With Niels Möller: + * mpn/generic/hgcd.c: Add const and inline to several functions. + (qstack_push_start qstack_push_end qstack_push_quotient): Remove. + (euclid_step): Insert removed functions here. + (hgcd_adjust): Simplify, don't handle d != 1. + (qstack_adjust): Corresponding changes. + (mpn_hgcd2_lehmer_step): Remove redundant tests for bh against zero. + (hgcd_start_row_p): Tweak. + (hgcd_final): Shorten life of ralloc. + +2004-01-24 Kevin Ryde + + * tests/mpf/t-sqrt.c (check_rand1): Further diagnostic printouts. + + * mpn/generic/sqrtrem.c (mpn_sqrtrem): Add ASSERT_MPN. + (mpn_dc_sqrtrem): Add casts for K&R. + + * mpf/sqrt_ui.c: Nailify. + + * mpf/set_z.c: Do MPN_COPY last, for possible tail call. + + * doc/gmp.texi (Miscellaneous Float Functions): For mpf_random2, note + exponent is in limbs. + + * mpn/ia64/README: Add remark about concentrating on itanium-2. + +2004-01-22 Kevin Ryde + + * mpf/sqrt.c: Change tsize calculation to get prec limbs result + always, previously got prec+1 when exp was odd. + * tests/mpf/t-sqrt.c (check_rand1): New function, code from main. + (check_rand2): New function. + + * mpf/sqrt_ui.c: Change rsize calculation to get prec limbs result, + previously got prec+1. + * tests/mpf/t-sqrt_ui.c: New file. + * tests/mpf/Makefile.am (check_PROGRAMS): Add it. + + * tests/refmpf.c, tests/tests.h (refmpf_add_ulp, + refmpf_set_prec_limbs): New functions. + + * mpz/get_d_2exp.c, mpf/get_d_2exp.c: Remove x86+m68k force to double, + mpn_get_d now does this. Remove res==1.0 check for round upwards, + mpn_get_d now rounds towards zero. Move exp store to make mpn_get_d a + tail call. + + * configure.in (x86-*-*): Use ABI=32 rather than ABI=standard. + Use gcc -m32 when available, to force mode on bi-arch amd64 gcc. + * configure.in, acinclude.m4 (x86_64-*-*): Merge into plain x86 setups + as ABI=64. Support ABI=32, using athlon code. Use gcc -mcpu=k8, + -march=k8. + (amd64-*-*): Remove pattern, config.sub only gives x86_64. + * doc/gmp.texi (ABI and ISA): Add x86_64 dual ABIs. + + * mpn/amd64/README: Add reference to ABI spec. + +2004-01-17 Niels Möller + + * mpn/generic/hgcd.c (hgcd_adjust): Backed out mpn_addlsh1_n + change for now. + + * mpn/generic/hgcd.c (hgcd_adjust): Fixed calls of mpn_addlsh1_n. + +2004-01-17 Kevin Ryde + + * tune/README: Remove open/mpn versions of toom3, no longer exist. + * tune/powerpc64.asm: Remove unused L(again). + * tune/time.c (mftb): Note single mftb possible for powerpc64. + + * mpn/generic/mode1o.c: Use "c + + * mpn/generic/hgcd.c (mpn_diff_smaller_p): Use MPN_DECR_U. + (hgcd_adjust): Use mpn_addlsh1_n when available. + +2004-01-16 Kevin Ryde + + * configure.in (powerpc64-*-linux*): Try gcc64. Try -m64 with + "cflags_maybe" to get it used in all probing. Add sizeof-long-8 test + to check the mode is right if -m64 is not applicable. + +2004-01-15 Kevin Ryde + + * configure.in (--with-readline=detect): Check for readline/readline.h + and readline/history.h. Report result of detection. + +2004-01-14 Niels Möller + + * tune/speed.c (routine): Disabled speed_mpn_hgcd_lehmer. + * tune/common.c (speed_mpn_hgcd_lehmer): Disabled function. + + * mpn/generic/hgcd.c (mpn_hgcd_lehmer_itch, mpn_hgcd_lehmer) + (mpn_hgcd_equal): Deleted functions. + + * mpn/generic/gcd.c (hgcd_start_row_p): Deleted function. + (gcd_schoenhage): Deleted assertion code using mpn_hgcd_lehmer. + + * mpn/generic/hgcd.c (hgcd_final): Fixed ASSERT typos. + (mpn_hgcd): To use Lehmer's algorithm, call hgcd_final directly, + not mpn_hgcd_lehmer. + + * mpn/generic/gcd.c (gcd_schoenhage): Updated for changes to + mpn_hgcd and mpn_hgcd_fix. (Schoenhage code is still disabled). + + * gmp-impl.h (mpn_hgcd_fix): Updated prototype. + + * mpn/generic/hgcd.c (mpn_hgcd_fix): Replaced a bunch of arguments + by a pointer const struct hgcd_row *s. Updated callers. + + * mpn/generic/hgcd.c (hgcd_start_row_p): Use const for the input. + Moved function definition before hgcd_jebelean. + (hgcd_jebelean): Interface change, analogous to hgcd2. + (mpn_hgcd_fix): Normalize v. Require that v > 0. + (hgcd_adjust): Fix bug in carry update. + (mpn_hgcd): Reorganized again, to adapt to mpn_hgcd/hgcd_jebelean + now sometimes returning 1. Reintroduced hgcd_adjust. + + * mpn/generic/hgcd.c (hgcd_final): Streamlined logic for the first + hgcd2 call. + + * mpn/generic/hgcd2.c (mpn_hgcd2): Interface change. Return 1 + instead of 2, in the no progress case r0=A, r1=B. + + * mpn/generic/hgcd.c (hgcd_adjust): Changed arguments and return + value. Now takes a struct hgcd_row * and the uv size, and returns + updated uvsize. + (hgcd_final): Special handling of the case hgcd2 returning 1. Now + uses hgcd_adjust, instead of a full Euclid division. + +2004-01-13 Niels Möller + + * mpn/generic/hgcd.c (euclid_step, hgcd_case0): Merged into a + single function euclid_step. + (mpn_hgcd): Reorganized the logic for the second recursive call. + Avoid unnecessary Euclid steps. + + * tests/mpn/t-hgcd.c (hgcd_values): One more test value. + + * tests/mpn/t-hgcd.c (hgcd_values): Added values that trigged the + hgcd_jebelean bug. + + * mpn/generic/hgcd.c (hgcd_jebelean): Fixed off by one error. + (mpn_hgcd): Simplified the logic for the first recursive call. Now + it uses only the correct values from the recursive call, and + doesn't do tricks with hgcd_adjust (hgcd_adjust will probably be + reintroduced later, though). + + * tests/mpn/t-hgcd.c (mpz_mpn_equal, hgcd_ref_equal) + (hgcd_ref_init, hgcd_ref_clear): New functions. + (hgcd_ref): Reference implementation of hgcd, using mpz. + (one_test): Use hgcd_ref. Don't use mpn_hgcd_lehmer. + (main): Skip one_step if both input values are zero. + +2004-01-12 Niels Möller + + * mpn/generic/hgcd.c (hgcd_final): Rewritten, now uses Lehmer + steps instead of a division loop. + (mpn_hgcd_lehmer): Deleted old Lehmer code, instead just + initialize and then call hgcd_final. + + * tests/tests.h: Added refmpn_free_limbs prototype. + * tests/refmpn.c (refmpn_free_limbs): New function. + + * tests/mpn/t-hgcd.c: Try the same kind of random inputs as for + mpz/t-gcd. + +2004-01-11 Niels Möller + + * mpn/generic/hgcd.c (mpn_hgcd_lehmer): Rewritten, after some more + analysis of the size reduction for one Lehmer step. + + * tests/mpn/t-hgcd.c: New file. + +2004-01-11 Torbjorn Granlund + + With Niels Möller: + * mpn/generic/hgcd.c (hgcd_normalize): Fix ASSERTs. + (hgcd_mul): Normalize R[1].uvp[1]. Add some more ASSERTs. + (hgcd_update_uv): Streamline. ASSERT that input and output is + normalized. + +2004-01-11 Kevin Ryde + + * mpn/alpha/ev6/slot.pl: New file, derived in part from + mpn/x86/k6/cross.pl. + + * mpn/alpha/alpha-defs.m4 (ASSERT): New macro. + + * mpn/asm-defs.m4 (m4_ifdef): New macro, avoiding OSF 4.0 m4 bug. + (m4_assert_defined): Use it. + + * mpn/alpha/default.m4, mpn/alpha/unicos.m4 (LDGP): New macro. + * mpn/alpha/ev67/gcd_1.asm: Use it to re-establish gp after jsr. + + * configure.in, demos/calc/Makefile.am: Use -lcurses or -lncurses with + readline, when available. + + * longlong.h (sub_ddmmss) [generic]: Use alal, since the former can be done without waiting for __x, + helping superscalar chips, in particular alpha ev5 and ev6. + + * longlong.h (sub_ddmmss) [ia64]: New macro. + + * tests/t-sub.c: New file. + * tests/Makefile.am (check_PROGRAMS): Add it. + * tests/refmpn.c, tests/tests.h (refmpn_sub_ddmmss): New function. + +2004-01-09 Kevin Ryde + + * mpn/x86/p6/mod_34lsub1.asm: New file, derived in part from + mpn/x86/mod_34lsub1.asm. + + * configure.in (IA64_PATTERN): Use -mtune on gcc 3.4. + +2004-01-07 Kevin Ryde + + * gmp-h.in, mp-h.in (__GMP_SHORT_LIMB): Renamed from _SHORT_LIMB, to + keep in our namespace. (Not actually used anywhere currently.) + Reported by Patrick Pelissier. + + * mp-h.in: Use "! defined (__GMP_WITHIN_CONFIGURE)" in the same style + as gmp-h.in (though mp-h.in is not actually used during configure). + + * mp-h.in (__GMP_DECLSPEC_EXPORT, __GMP_DECLSPEC_IMPORT) [__GNUC__]: + Use __dllexport__ and __dllimport__ to keep out of application + namespace. Same previously done in gmp-h.in. + +2004-01-06 Kevin Ryde + + * configfsf.sub, configfsf.guess: Update to 2004-01-05. + * configure.in (amd64-*-* | x86_64-*-*): Update comments on what + configfsf.sub does. + +2004-01-04 Kevin Ryde + + * mpn/alpha/README (REFERENCES): Add tru64 assembly manuals. + (ASSEMBLY RULES): Note what gcc says about !literal! etc. + +2004-01-03 Kevin Ryde + + * mpn/alpha/ev67/gcd_1.asm: New file. + + * mpn/x86/pentium4/sse2/rsh1add_n.asm: New file, derived in part from + mpn/x86/pentium4/sse2/addlsh1_n.asm. + + * mpn/x86/p6/p3mmx/popham.asm: Note measured speeds. + + * mpn/ia64/hamdist.asm: Correction to inputs vs locals in alloc (makes + no difference to the generated code). Corrections to a couple of + comments. + + * mpn/x86/pentium4/sse2/addlsh1_n.asm (PARAM_CARRY): Remove macro, not + used, no such parameter. + + * mpn/generic/gcd.c: Use for NULL. + + * doc/gmp.texi (Single Limb Division): Correction to tex expression + for (1/2)x1. And minor wording tweaks elsewhere. + + * gmp-impl.h (mpn_rsh1add_n, mpn_rsh1sub_n): Correction to comments + about how carries returned. + + * longlong.h (umul_ppmm) [generic]: Add comments about squaring + (dropped from tasks list) + +2003-12-31 Kevin Ryde + + * demos/perl/GMP.xs (scan0, scan1): Return ~0 for not-found. + * demos/perl/GMP.pm: Describe this, remove the note about ULONG_MAX + being the same as ~0 (which is not true in old perl). + * demos/perl/test.pl: Update tests. + * demos/perl/typemap (gmp_UV): New type. + + * demos/perl/test.pl (fits_slong_p): Comment out uv_max test, it won't + necessarily exceed a long. + + * demos/perl/GMP.pm: Add a remark about get_str to the bugs section. + + * mpn/generic/sqrtrem.c, mpz/fac_ui.c, tests/mpf/reuse.c: Add casts + for K&R. + * tests/mpf/t-muldiv.c: Make ulimb, vlimb into ulongs, which is how + they're used, for the benefit of K&R calling. + + * doc/gmp.texi (Square Root Algorithm): Add a summary of the algorithm. + And add further index entries in various places. + + * mpz/lucnum_ui.c, mpz/lucnum2_ui.c: Use mpn_addlsh1_n when available. + + * gmp-impl.h, mpn/generic/mul_n.c (mpn_addlsh1_n, mpn_sublsh1_n, + mpn_rsh1add_n, mpn_rsh1sub_n): Move descriptions to gmp-impl.h with + the prototypes, for ease of locating. + +2003-12-30 Torbjorn Granlund + + * tune/tuneup.c (all): Disable calls of tune_gcd_schoenhage and + tune_hgcd for now. + +2003-12-29 Torbjorn Granlund + + * tests/mpz/t-gcd.c: Rewrite, based on suggestions by Kevin. + + * mpn/ia64/mul_1.asm: Amend TODO list. + + * mpn/sparc64/README: Remove mpn_Xmul_2, done. + Add blurb about L1 cache conflicts. + + * mpn/generic/gcd.c: Disable Schoenhage code for now. + +2003-12-29 Kevin Ryde + + * mpn/generic/mul_fft.c, mpz/root.c, mpq/cmp_ui.c: Add casts for K&R. + +2003-12-27 Kevin Ryde + + * tests/mpz/t-mul.c (mul_kara, mul_basecase): Use __GMP_PROTO. + + * mpn/generic/gcd.c (NHGCD_SWAP4_2, NHGCD_SWAP3_LEFT), + mpn/generic/hgcd.c (HGCD_SWAP4_LEFT, HGCD_SWAP4_RIGHT, HGCD_SWAP4_2, + HGCD_SWAP3_LEFT): Aggregate initializers for automatics is an + ANSI-ism, avoid. + + * Makefile.am (AUTOMAKE_OPTIONS): Restore this, giving no directory on + ansi2knr to avoid a circular build rule. + * configure.in (AM_INIT_AUTOMAKE): Note options also in Makefile.am. + + * configure.in (cflags_maybe): Don't loop adding cflags_maybe if the + user has set CFLAGS. + +2003-12-24 Torbjorn Granlund + + * mpn/generic/gcd.c (gcd_schoenhage_itch): Avoid unary "+". + (mpn_gcd): Allocate scratch space on heap for gcd_schoenhage. + (mpn_gcd): Don't invoke MPN_NORMALIZE on input operands. + +2003-12-23 Kevin Ryde + + * configure.in (*sparc*-*-*): Test sizeof(long)==4 or 8 for ABIs, to + get the right mode when the user sets the CFLAGS. + (testlist): Introduce "any__testlist" to apply to all compilers. + + * demos/perl/typemap (MPZ_ASSUME, MPQ_ASSUME, MPF_ASSUME): Remove + output rules, these are only meant for inputs. + (MPZ_MUTATE): Remove, not used since changes for magic. + + * demos/perl/GMP.xs (mpz_class_hv, mpq_class_hv, mpf_class_hv): New + variables, initialized in BOOT. + * demos/perl/GMP.xs, demos/perl/typemap: Use them and explicit + sv_bless, to save a gv_stashpv for every new object. + +2003-12-22 Kevin Ryde + + * mpn/alpha/mode1o.c, mpn/alpha/dive_1.c: Moved from ev5/mode1o.c and + ev5/dive_1.c, these are good for ev4, and would like them in a generic + alpha build. + +2003-12-21 Kevin Ryde + + * doc/gmp.texi (Integer Logic and Bit Fiddling): Say "bitwise" in + mpz_and, mpz_ior and mpz_xor, to avoid any confusion with what C means + by "logical". Reported by Rüdiger Schütz. + + * gmp-h.in (_GMP_H_HAVE_FILE): Note why defined(EOF) is not good. + +2003-12-20 Torbjorn Granlund + + * mpn/generic/hgcd.c (mpn_diff_smaller_p): Use mpn_cmp instead of + mpn_sub_n where possible. Use mp_size_t for relevant variables. + +2003-12-20 Kevin Ryde + + * tune/speed.h (SPEED_TMP_ALLOC_LIMBS): Correction to last change, + don't want "- 1" on the TMP_ALLOC_LIMBS. + + * demos/expr/expr.h: Test #ifdef MPFR_VERSION_MAJOR for when mpfr.h is + included, not GMP_RNDZ which is now an enum. + + * demos/expr/exprfra.c (e_mpfr_ulong_p): Use mpfr_integer_p and + mpfr_fits_ulong_p. + (e_mpfr_get_ui_fits): Use mpfr_get_ui. + + * mpfr/*: Update to mpfr cvs head 2003-12-20. + + * configure, config.in: Update to autoconf 2.59. + * */Makefile.in, configure, aclocal.m4, ansi2knr.c, install-sh, + doc/mdate-sh: Update to automake 1.8. + + * mkinstalldirs: Remove, not required by automake 1.8. + * doc/gmp.texi (Build Options): HTML is a usual target in automake 1.8. + + * configure.in (AC_PREREQ): Require autoconf 2.59. + (AM_INIT_AUTOMAKE): Require automake 1.8. + (AC_C_INLINE): Use rather than GMP_C_INLINE, now has #ifndef + __cplusplus we want. + (gettimeofday): Use AC_CHECK_FUNCS rather than our workaround code, + autoconf now ok. + + * acinclude.m4 (GMP_C_INLINE): Remove. + (GMP_H_EXTERN_INLINE): Use AC_C_INLINE. + (GMP_PROG_AR): Comment on automake $ARFLAGS. + +2003-12-19 Niels Möller + + * mpn/generic/hgcd.c (mpn_diff_smaller_p): Rewrote function. Tried + to explain how it works. + (slow_diff_smaller_p, wrap_mpn_diff_smaller_p) [WANT_ASSERT]: Use + CPP to wrap assertion checks around all calls to + mpn_diff_smaller_p. + + * mpn/generic/hgcd.c (mpn_addmul2_n_1) [nails]: Fixed carry handling. + + * mpn/generic/hgcd.c (mpn_diff_smaller_p) [nails]: Use + GMP_NUMB_MAX, not MP_LIMB_T_MAX. + (mpn_hgcd_itch): Improved size calculation. + (mpn_hgcd_max_recursion): Moved function from qstack.c. Should to + be recompiled when HGCD_SCHOENHAGE_THRESHOLD is tuned. + + * mpn/generic/qstack.c (mpn_hgcd_max_recursion): ... moved from + here. + +2003-12-19 Torbjorn Granlund + + * tests/mpf/t-get_d.c: Print message before aborting. + + * mpn/generic/hgcd2.c (mpn_hgcd2): Substitute always-zero variable + with 0. Remove bogus comment. + + * mpn/generic/get_d.c: Make ONE_LIMB case actually work for nails. + +2003-12-18 Niels Möller + + * mpn/generic/hgcd.c (hgcd_update_r): Assert that the output r2 is + smaller than the input r1. + +2003-12-18 Torbjorn Granlund + + * mpz/get_d.c: Don't include longlong.h. + + * tests/mpz/t-mul.c (ref_mpn_mul): Handle un == vn specially, to avoid + a dummy r/w outside of allocated area. + +2003-12-18 Kevin Ryde + + * mpn/alpha/unicos.m4 (ALIGN): Add comments on what GCC does. + + * configure.in (fat setups), acinclude.m4 (GMP_INIT): Obscure + include() from automake 1.8 aclocal. + * acinclude.m4: Quote names in AC_DEFUN, for automake 1.8 aclocal. + +2003-12-17 Niels Möller + + * tune/common.c (speed_mpn_hgcd, speed_mpn_hgcd_lehmer) [nails]: + Enabled code also for GMP_NAIL_BITS > 0. + * tune/speed.c [nails]: Enable speed_mpn_hgcd and + speed_mpn_hgcd_lehmer. + * tune/tuneup.c (tune_hgcd) [nails]: Likewise. + + * mpn/generic/gcd.c [nails]: Use Schönhage's algorithm also for + GMP_NAIL_BITS > 0. + + * mpn/generic/hgcd.c [nails]: Enable the code for GMP_NAIL_BITS > 0. + (MPN_EXTRACT_LIMB) [nails]: Handle nails. + (__gmpn_hgcd_sanity): Allocate temporaries on the heap, not on the + stack. Also check that r[i] >= r[i+1]. + (mpn_hgcd2_lehmer_step) [nails]: Handle nails. + (mpn_hgcd_lehmer): When we temporarily have r3 > r2, avoid + trigging that assert in __gmpn_hgcd_sanity. + (mpn_hgcd): Likewise. + + * mpn/generic/hgcd2.c (div2) [nails]: Alternative nail-aware + version. + (SUB_2): New macro of Kevin's, which reduces do sub_ddmmss in the + non-nail case. + (HGCD2_STEP): Use SUB_2, not sub_ddmmss. Added alternative version + for K&R compilers. + (mpn_hgcd2) [nails]: Use SUB_2, not sub_ddmmss. New nail-aware + code for checking Jebelean's condition. + +2003-12-13 Kevin Ryde + + * mpq/get_d.c: Amend comments per mpn_get_d change. + (limb2dbl): Remove, no longer used. + + * gmp-impl.h (DIVREM_1_NORM_THRESHOLD etc) [nails]: Correction to + comments, MP_SIZE_T_MAX means preinv never. + + * gmp-impl.h (DIVEXACT_1_THRESHOLD, MODEXACT_1_ODD_THRESHOLD) [nails]: + Remove overrides, divexact_1 and modexact_1 have been nailified. + + * mpz/inp_str.c (mpz_inp_str_nowhite): Use ASSERT_ALWAYS for EOF value + requirement. + + * tests/refmpn.c (refmpn_rsh1add_n, refmpn_rsh1sub_n): Parens around + GMP_NUMB_BITS - 1 with ">>", to quieten gcc -Wall. + * tests/t-constants.c (main), tests/t-count_zeros.c (check_clz), + tests/t-modlinv.c (one), tests/mpz/t-jac.c (try_si_zi), + tests/mpq/t-get_d.c (check_onebit): : Correction to printfs. + * tests/mpn/t-fat.c: Add for memcpy. + * tests/mpz/t-scan.c (check_ref): Remove unused variable "isigned". + * tests/mpq/t-get_d.c (check_onebit): Remove unused variable "limit". + * tests/mpf/t-set_si.c, tests/mpf/t-set_ui.c (check_data): Braces for + initializers. + * tests/devel/try.c (mpn_divexact_by3_fun, mpn_modexact_1_odd_fun): + Correction to return values. + + * doc/gmp.texi (Miscellaneous Integer Functions): Note mpz_sizeinbase + can be used to locate the most significant bit. Reword a bit for + clarity. + +2003-12-12 Niels Möller + + * mpn/generic/hgcd.c (__gmpn_hgcd_sanity): Fixed stack buffer + overrun. + * mpn/generic/hgcd.c: Improved comments. + +2003-12-11 Torbjorn Granlund + + * gmp-impl.h: Change asm => __asm__, tabify. + * mpz/get_d_2exp.c: Likewise. + * mpf/get_d_2exp.c: Likewise. + + * tests/cxx/t-ops.cc: #if .. #endif out tests that cause ambiguities. + +2003-12-10 Torbjorn Granlund + + * tests/mpz/t-gcd.c: Generate operands with sizes as a geometric + progression, to allow for larger operands and less varying timing. + + * tune/tuneup.c (tune_gcd_schoenhage): Set param.step_factor. + (tune_hgcd): Likewise. + +2003-12-10 Kevin Ryde + + * demos/perl/test.pl: Should be $] for perl version in old perl. + + * configure.in (sparc64-*-*): Single block of gcc configs for all + systems, on unknown systems try both ABI 32 and 64. + + * configure.in (LIBGMP_LDFLAGS, LIBGMPXX_LDFLAGS): New AC_SUBSTs with + options to generate .def files with windows DLLs. + * Makefile.am (libgmp_la_LDFLAGS, libgmpxx_la_LDFLAGS): Use them. + + * mpn/generic/gcd.c: Use ABOVE_THRESHOLD / BELOW_THRESHOLD, to follow + convention and cooperate with tune/tuneup.c. + + * tune/tuneup.c (tune_gcd_schoenhage): Increase max_size to 3000, side + default 1000 is approx the crossover point on athlon. + + * tune/common.c, tune/speed.c, tune/speed.h, tune/speed-ext.c, + tune/tuneup.c (SPEED_TMP_ALLOC_LIMBS): Take variable as parameter + rather than returning a value, avoids alloca in a function call. + * tune/common.c, tune/speed.h (speed_tmp_alloc_adjust): Remove, now + inline in SPEED_TMP_ALLOC_LIMBS, and using ptr-NULL for alignment + extraction. + + * gmpxx.h (__gmp_binary_equal, __gmp_binary_not_equal, + __gmp_binary_less, __gmp_binary_less_equal, __gmp_binary_greater, + __gmp_binary_greater_equal, __gmp_cmp_function): Use mpfr_cmp_si and + mpfr_cmp_d. + * tests/cxx/t-ops.cc: Exercise this. + + * demos/perl/Makefile.PL: Don't install sample.pl and test2.pl. + + * demos/perl/GMP.xs (use_sv): Prefer PV over IV or NV to avoid any + rounding. + * demos/perl/test.pl: Exercise this. + + * demos/perl/GMP/Mpf.pm (overload_string): Corrections to $# usage. + * demos/perl/test.pl: Exercise this. + +2003-12-08 Kevin Ryde + + * demos/perl/GMP.pm: Correction to canonicalize example. + + * demos/perl/GMP.xs: New type check scheme, support magic scalars, + support UV when available. Remove some unused local variables. + (coerce_long): Check range of double. + (get_d_2exp): Remove stray printf. + + * demos/perl/test.pl: Exercise magic, rearrange to make it clearer + what's being tested. + +2003-12-07 Kevin Ryde + + * mpn/generic/hgcd.c (mpn_hgcd): Use BELOW_THRESHOLD, to follow the + convention of N for strtol. + + * tests/misc/t-scanf.c (test_sscanf_eof_ok): New function. + (check_misc): Use it to suppress tests broken by libc. + And should be EOF rather than -1 in various places. + +2003-12-06 Torbjorn Granlund + + * tune/common.c (speed_mpn_hgcd, speed_mpn_hgcd_lehmer): + Move SPEED_TMP_ALLOC_LIMBS invocations out from calls. + + * mpn/generic/get_str.c (mpn_get_str, POW2_P case): + Don't append extra '\0' byte. + +2003-12-05 Niels Möller + + * tune/common.c (speed_mpn_hgcd_lehmer, speed_mpn_hgcd): + Updated for the renaming hgcd_sanity -> ASSERT_HGCD. + + * mpn/generic/gcd.c (gcd_schoenhage): TMP_DECL must be the final + declaration in the declaration section of a block. + + * tune/speed.h (mpn_gcd_accel): Added prototype. + +2003-12-05 Torbjorn Granlund + + * randmt.c (__gmp_mt_recalc_buffer): Put parens around "&" expressions + inside "!=". + + * mpf/get_str.c: Remove unused variable "fracn". + +2003-12-03 Kevin Ryde + + * configure.in, Makefile.am (LIBGMP_LDFLAGS, LIBGMPXX_LDFLAGS): New + AC_SUBSTs, use them to create .def files with Windows DLLs. + * doc/gmp.texi (Notes for Particular Systems): Update notes on mingw + DLL with MS C. + + * mpz/export.c: Allow NULL for countp. + * doc/gmp.texi (Integer Import and Export): Describe this. + Suggested by Jack Lloyd. + + * mpn/x86/p6/aors_n.asm: New file, grabbing the K7 code. + Superiority of this reported by Patrick Pelissier. + +2003-11-30 Kevin Ryde + + * mpn/alpha/ev67/popcount.asm, mpn/alpha/ev67/hamdist.asm: New files. + + * mpn/alpha/ev67: New directory. + * configure.in (alphaev67, alphaev68, alphaev7*): Use it. + + * doc/gmp.texi (GMPrefu, GMPpxrefu): Change back to plain ref and + pxref, remove macros. + (GMPreftopu, GMPpxreftopu): Remove URL parameter, rename to GMPreftop + and GMPpxreftop. + (Debugging): Remove debauch, seems to have disappeared. + (Language Bindings): Corrections to URLs for CLN, Omni F77, Pike. + +2003-11-29 Kevin Ryde + + * demos/perl/GMP/Mpf.pm (overload_string): Use $OFMT to avoid warnings + about $#. + + * demos/perl/GMP.xs (fits_slong_p): Use LONG_MAX+1 to avoid possible + rounding of 0x7F..FF in a double on 64-bit systems. + + * configure.in (ppc601-*-*): Remove this case, it never matched + anything, the name adopted is powerpc601. + (powerpc601-*-*): Use gcc -mcpu=601, xlc -qarch=601. + + * configure.in: Introduce ${cc}_cflags_maybe, used if they work. + (*sparc*-*-*) [ABI=32]: Add gcc_cflags_maybe=-m32 to force that mode. + + * doc/gmp.texi (Introduction to GMP): Add AMD64 to optimizations list. + (Build Options): Add cpu types alphaev7 and amd64. Update texinfo + html cross reference. + +2003-11-28 Niels Möller + + * tune/tuneup.c (tune_hgcd): Disable if GMP_NAIL_BITS > 0. + * tune/speed.c (routine): Likewise. + * tune/common.c (speed_mpn_hgcd, speed_mpn_hgcd_lehmer): Likewise. + + * mpn/generic/gcd.c, mpn/generic/hgcd.c, mpn/generic/hgcd2.c + [GMP_NAIL_BITS]: Disabled new code if we have nails. + + * mpn/generic/gcd.c (MPN_LEQ_P): Copied macro definition (needed + for compilation with --enable-assert). + + * tune/tuneup.c (hgcd_schoenhage_threshold, + gcd_schoenhage_threshold): New variables. + (tune_hgcd, tune_gcd_schoenhage): New functions. + (all): Call tune_hgcd and tune_gcd_schoenhage. + + * tune/common.c (speed_mpn_hgcd, speed_mpn_hgcd_lehmer) + (speed_mpn_gcd_accel): New functions. + * tune/speed.c (routine): Added mpn_hgcd, mpn_hgcd_lehmer and + mpn_gcd _accel. + * tune/speed.h: Added corresponding prototypes. + + * tune/gcd_accel.c: New file. + + * tune/gcd_bin.c (GCD_SCHOENHAGE_THRESHOLD): Set to MP_SIZE_T_MAX. + + * tune/Makefile.am (libspeed_la_SOURCES): Added gcd_accel.c. + (TUNE_MPN_SRCS_BASIC): Added hgcd.c. + + * mpn/x86/k7/gmp-mparam.h (HGCD_SCHOENHAGE_THRESHOLD) + (GCD_SCHOENHAGE_THRESHOLD): Tuned values. + + * mpn/generic/gcd.c (mpn_gcd, gcd_binary_odd): Renamed the + old mpn_gcd function (which implements accelerated binary gcd) to + gcd_binary_odd. + (gcd_binary): New function, with the additional book keeping + needed when using gcd_binary_odd to compute the gcd of non-odd + numbers. + (hgcd_tdiv): New function. + (gcd_lehmer): New function, currently #if:ed out. + (hgcd_start_row_p): New function, duplicated from hgcd.c. + (gcd_schoenhage_itch): New function. + (gcd_schoenhage): New function. + (mpn_gcd): New advertised gcd function, which calls + mpn_gcd_binary_odd or mpn_gcd_schoenhage, depending on the size of + the input. + + * mpn/generic/hgcd.c (mpn_hgcd2_lehmer_step): Renamed function + (was lehmer_step), and made non-static. Updated callers. + + * gmp-impl.h (GCD_LEHMER_THRESHOLD): #if:ed out this macro. + (mpn_hgcd2_lehmer_step): Added prototype. + +2003-11-27 Niels Möller + + * tests/mpz/t-gcd.c (gcd_values): Moved definition, so that we + don't need to forward declare the array. + +2003-11-26 Niels Möller + + * mpn/generic/hgcd.c (mpn_hgcd2_fix): Deleted duplicate definition + (the function belongs to hgcd2.c). + +2003-11-26 Torbjorn Granlund + + * tests/mpz/t-gcd.c: Generate random operands up to 32767 bits; + decrease # of test to 1000. + (gcd_values): Remove oversize test case. + +2003-11-26 Niels Möller + + * gmp-impl.h: Added name mangling for hgcd-related functions. Also + use __GMP_PROTO. + (MPN_LEQ_P, MPN_EXTRACT_LIMB): Moved macros to hgcd.c. + * mpn/generic/hgcd.c, mpn/generic/hgcd2.c, mpn/generic/qstack.c: + Adapted to name changes. + + * tests/mpz/t-gcd.c (main): Added some tests with non-random + input. + +2003-11-25 Niels Möller + + * gmp-impl.h (MPN_LEQ_P, MPN_EXTRACT_LIMB): New macros. + (struct qstack, struct hgcd2_row, struct hgcd2, struct hgcd_row) + (struct hgcd): New structs. Also added prototypes for new hgcd, + hgcd2, qstack and gcd functions. + + * configure.in (gmp_mpn_functions): Added hgcd2, hgcd and qstack. + + * mpn/Makefile.am (nodist_EXTRA_libmpn_la_SOURCES): Added hgcd2.c, + hgcd.c and qstack.c. + + * mpn/generic/hgcd.c, mpn/generic/hgcd2.c, mpn/generic/qstack.c: + New files, needed for the sub-quadratic gcd. + +2003-11-25 Kevin Ryde + + * doc/gmp.texi (Language Bindings): Add Axiom. + +2003-11-22 Kevin Ryde + + * mpn/alpha/README: More notes on assembler syntax variations. + + * mpn/alpha/alpha-defs.m4, mpn/alpha/unicos.m4 (unop): Should be ldq_u + not bis, and move to alpha-defs.m4 since it can be happily used + everywhere. + + * mpn/alpha/alpha-defs.m4, mpn/alpha/default.m4, mpn/alpha/unicos.m4 + (bigend): Move to alpha-defs.m4 and base it on HAVE_LIMB_BIG_ENDIAN or + HAVE_LIMB_LITTLE_ENDIAN, so as not to hard code system endianness. + + * mpn/alpha/alpha-defs.m4: New file. + * configure.in (alpha*-*-*): Use it. + +2003-11-21 Kevin Ryde + + * mpfr/*: Update to mpfr-2-0-2-branch 2003-11-21. + + * mpn/alpha/ev5/com_n.asm: Change "not" to "ornot r31", since "not" + isn't recognised by on Cray Unicos. Add missing "gp" to PROLOGUE. + * mpn/alpha/README: Add a note on "not". + +2003-11-19 Torbjorn Granlund + + * mpn/alpha/aorslsh1_n.asm: Slightly rework feed-in code, avoiding + spurious reads beyond operand limits. + + * mpn/alpha/ev5/com_n.asm: Add ASM_START/ASM_END. + + * mpn/generic/mul_fft.c (mpn_fft_zero_p): Remove unused function. + (mpn_lshift_com): Make static, nailify properly. + +2003-11-19 Kevin Ryde + + * mpn/generic/diveby3.c: Use a "q" variable to make it clearer what + the code is doing. + + * mpn/powerpc32/750/lshift.asm, mpn/powerpc32/750/rshift.asm: New + files. + + * mpn/alpha/ev5/com_n.asm: New file. + + * doc/gmp.texi (Assembler Functional Units, Assembler Writing Guide): + New sections by Torbjorn, tweaked by me. + +2003-11-17 Torbjorn Granlund + + * mpn/powerpc32: Add power4/powerpc970 cycle counts. + Use cmpwi instead of cmpi to placate darwin. + +2003-11-15 Kevin Ryde + + * config.guess: Add comments on MacOS "machine" command. + + * tests/devel/try.c (main): Use gmp_randinit_default explicitly on + __gmp_rands, since RANDS doesn't allow seeding. + + * doc/gmp.texi (Assigning Integers): Remove notes on possible change + to disallow whitespace, this would be an incompatible change and + really can't be made. + (Toom 3-Way Multiplication): Updates for Paul's new code. + + * mpn/generic/mul_n.c (toom3_interpolate, mpn_toom3_mul_n): Put + if/else braces around whole of #if code, for readability. + + * tests/refmpn.c (refmpn_addlsh1_n, refmpn_sublsh1_n, + refmpn_rsh1add_n, refmpn_rsh1sub_n): Add ASSERTs for operand overlaps + etc. + + * mpfr/*: Update to mpfr-2-0-2-branch 2003-11-15. + +2003-11-14 Torbjorn Granlund + + * mpn/alpha/aorslsh1_n.asm: Use Cray-friendly syntax for "br". + +2003-11-13 Torbjorn Granlund + + * mpn/alpha/aorslsh1_n.asm: New file. + +2003-11-12 Kevin Ryde + + * acinclude.m4 (GMP_PROG_CC_WORKS): Add case provoking AIX power2 + assembler, test code by Torbjorn. + * configure.in (power*-*-*): Add a comment about -mcpu=rios2 fallback. + + * tune/speed.c (main): Use gmp_randinit_default explicitly on + __gmp_rands, since RANDS doesn't allow seeding. + + * mpfr/*: Update to mpfr-2-0-2-branch 2003-11-12. + + * gmp-impl.h, randmt.h (__gmp_randinit_mt_noseed): Move prototype to + gmp-impl.h, for use by RANDS. + + * mpn/Makeasm.am (.s, .S, .asm): Quote $< in test -f, per automake. + (.obj): Use test -f and $(CYGPATH_W) as per automake. + +2003-11-11 Kevin Ryde + + * configure.in: Make umul and udiv standard-optional objects, rather + than under various extra_functions. + + * mpn/pa32/hppa1_1/pa7100/add_n.asm, + mpn/pa32/hppa1_1/pa7100/addmul_1.asm, + mpn/pa32/hppa1_1/pa7100/lshift.asm, + mpn/pa32/hppa1_1/pa7100/rshift.asm, + mpn/pa32/hppa1_1/pa7100/sub_n.asm, + mpn/pa32/hppa1_1/pa7100/submul_1.asm: Use LDEF for labels. + + * mpf/set_str.c: Don't use memcmp for decimal point testing, just a + loop is enough and avoids any chance of memcmp reading past the end of + the given string. + + * randmts.c, randmt.h: New files. + * Makefile.am (libgmp_la_SOURCES): Add them. + * randmt.c: Move seeding to randmts.c, common defines in randmt.h. + * gmp-impl.h (RANDS): Use __gmp_randinit_mt_noseed. + * tests/misc.c (tests_rand_start): Use gmp_randinit_default + explicitly, not RANDS. + + * mpn/ia64/ia64-defs.m4 (PROLOGUE_cpu): Use 32-byte alignment, for the + benefit of itanium 2. + * mpn/ia64/gcd_1.asm: Remove own .align 32. + + * mpn/ia64/ia64-defs.m4 (ALIGN): New define, using IA64_ALIGN_OK. + * mpn/ia64/hamdist.asm: Use ALIGN instead of .align. + + * acinclude.m4 (GMP_ASM_IA64_ALIGN_OK): New macro. + * configure.in (IA64_PATTERN): Use it. + * mpn/ia64/README: Add notes on gas big endian align problem. + +2003-11-10 Torbjorn Granlund + + * mpn/ia64/mul_1.asm: Rewrite. + +2003-11-08 Torbjorn Granlund + + * mpn/x86/aors_n.asm: Align loop to a multiple of 16. Also align + M4_function_n to a multiple of 16, to minimize alignment padding. + Update P6 cycle counts reflecting improvements with new alignment. + +2003-11-07 Kevin Ryde + + * gmp-impl.h (HAVE_HOST_CPU_alpha_CIX): New define. + (ULONG_PARITY, popc_limb): Use it, to pick up ev7 as well as 67 and 68. + * longlong.h (count_leading_zeros, count_trailing_zeros): Ditto. + + * doc/gmp.texi (Notes for Package Builds): Add notes on multi-ABI + system packaging. + (ABI and ISA): Add GNU/Linux ABI=64. + (Binary GCD): Add notes on 1x1 GCD algorithms. + + * mpn/alpha/README: Add some literature references. + + * mpn/ia64/mode1o.asm: Various corrections to initial checkin. + * mpn/ia64/ia64-defs.m4 (ASSERT): Correction to arg quoting. + +2003-11-05 Torbjorn Granlund + + * mpn/powerpc64/linux64.m4: New file. + * configure.in (POWERPC64_PATTERN): Handle *-*-linux*. + Use linux64.m4. + + * mpn/ia64/logops_n.asm: New file. + +2003-11-05 Kevin Ryde + + * tune/freq.c (freq_sysctl_hw_model): Relax to just look for "%u MHz", + for the benefit of sparc cypress under netbsd 1.6.1. + + * mpfr/*: Update to mpfr-2-0-2-branch 2003-11-05. + + * mpn/alpha/ev5/dive_1.c: New file. + + * configure.in (x86_64-*-*): Accept together with amd64-*-*. + + * tune/speed.c: Check range of -x,-y,-w,-W alignment specifiers. + * tune/speed.h (CACHE_LINE_SIZE): Amend comments. + +2003-11-04 Torbjorn Granlund + + * tune/speed.c: Fix typo in testing HAVE_NATIVE_mpn_modexact_1_odd. + +2003-11-03 Kevin Ryde + + * mpn/ia64/hamdist.asm: New file. + * mpn/ia64/mode1o.asm: New file. + * mpn/ia64/ia64-defs.m4 (ASSERT): New macro. + + * tests/mpz/t-set_d.c (check_2n_plus_1): New test. + +2003-11-01 Kevin Ryde + + * mpz/fac_ui.c (BSWAP_ULONG) [limb==2*long]: Remove this case, it + provokes code gen problems on HP cc. + (BSWAP_ULONG) [generic]: Rename __dst variable to avoid conflicts with + BITREV_ULONG. + Fix by Jason Moxham. + + * mpn/powerpc32/mode1o.asm: Use 16-bit i*i for early out, no need to + truncate divisor. Amend stated 750/7400 speeds, and note operands + that give the extremes. + + * mpz/set_d.c: Don't use a special case for d < MP_BASE_AS_DOUBLE, gcc + 3.3 -mpowerpc64 on darwin gets ulonglong->double casts wrong. + + * mpn/generic/diveby3.c: Show a better style carry handling in the + alternative pipelined sample code. + + Revert this, the longlong.h macros need -mpowerpc64: + * acinclude.m4 (GMP_GCC_POWERPC64): New macro. + * configure.in (powerpc64-*-darwin*): Use it to exclude -mpowerpc64 + when bad. + +2003-10-31 Torbjorn Granlund + + * mpn/powerpc64/mode64/submul_1.asm: Move an instruction to save a + cycle on POWER4. + + * mpn/powerpc64/mode64/divrem_1.asm: Fix several syntax problems + revealed on Mac OS X. + + * mpn/powerpc64/mode64/*.asm: Add cycle counts for POWER4. + + * mpn/powerpc64/sqr_diagonal.asm: Rewrite to save a cycle on POWER4. + +2003-10-31 Kevin Ryde + + * mpfr/*: Update to mpfr-2-0-2-branch 2003-10-31. + + * mpn/powerpc64/README: Add subdirectory organisation notes. + + * tests/mpn/t-get_d.c: Don't use limits.h, LONG_MIN is wrong on gcc + 2.95 with -mcpu=ultrasparc. + + * acinclude.m4 (GMP_GCC_POWERPC64): New macro. + * configure.in (powerpc64-*-darwin*): Use it to exclude -mpowerpc64 + when bad. + + * configure.in (powerpc64-*-darwin*) [ABI=mode32]: Use gcc -mcpu flags. + + * mpn/ia64/divrem_1.asm, mpn/ia64/gcd_1.asm: Use "C" for comments. + * mpn/ia64/README, mpn/ia64/ia64-defs.m4: Note this. + + * mpn/ia64/ia64-defs.m4: Renamed from default.m4, per other defs files. + * configure.in (IA64_PATTERN): Update GMP_INCLUDE_MPN. + + * doc/gmp.texi (Notes for Particular Systems): Remove m68k ABI notes + for -mshort and PalmOS, now works. + (References): Correction, GMP Square Root proof already there, just + wanting URL from RRRR 4475. + +2003-10-29 Kevin Ryde + + * configure.in (sparc*-*-*): Use gcc -m32 when that option works, to + force 32-bit mode on dual 32/64 configurations like GNU/Linux. + (sparc64-*-linux*): Add support for ABI=64. + + * mpn/generic/pre_divrem_1.c: In fraction part, use CNST_LIMB(0) with + udiv_qrnnd_preinv to avoid warning about shift > type. + + * mpfr/*: Update to mpfr-2-0-2-branch 2003-10-29. + + * tests/cxx/t-istream.cc: Avoid tellg() checks if putback() doesn't + update that, avoids certain g++ 2.96 problems. + + * tests/mpn/t-fat.c: New file. + * tests/mpn/Makefile.am (check_PROGRAMS): Add it. + + * configure.in (CPUVEC_INSTALL, ITERATE_FAT_THRESHOLDS): New macros + for fat.h. + * mpn/x86/fat/fat.c (__gmpn_cpuvec_init): Use CPUVEC_INSTALL instead + of memcpy. Correction to location of "initialized" set. Improve + various comments. + +2003-10-27 Torbjorn Granlund + + * mpn/sparc64/mul_1.asm: Change addcc => add in a few places. + * mpn/sparc64/addmul_1.asm: Likewise. + + * mpn/sparc32/v9/mul_1.asm: Apply cross-jumping. + * mpn/sparc32/v9/addmul_1.asm: Likewise. + * mpn/sparc32/v9/submul_1.asm: Likewise. + * mpn/sparc32/v9/sqr_diagonal.asm: Likewise. + +2003-10-27 Kevin Ryde + + * tests/cxx/t-misc.cc: Don't use , on g++ 2.95.4 (debian 3.0) + -mcpu=ultrasparc LONG_MIN is wrong and kills the compile. + + * tests/cxx/t-istream.cc: Correction to tellg tests, don't assume + streampos is zero based. + + * configure.in (HAVE_HOST_CPU_FAMILY_alpha): New define for config.h. + * mpn/generic/get_d.c: Use it instead of __alpha for alpha workaround, + since Cray cc doesn't define __alpha. + + * mpn/x86/README: Revise PIC coding notes a bit, add gcc visibility + attribute. + +2003-10-25 Kevin Ryde + + * mpn/ia64/gcd_1.asm: New file. + + * tune/many.pl: Allow for PROLOGUE(fun,...), as used on alpha. + + * doc/gmp.texi (C++ Formatted Input): Describe base indicator handling. + + * tests/cxx/t-istream.cc: New file. + * tests/cxx/Makefile.am: Add it. + + * cxx/ismpznw.cc: New file, integer input without whitespace ... + * cxx/ismpz.cc: ... from here. + * gmp-impl.h (__gmpz_operator_in_nowhite): Add prototype. + * cxx/ismpq.cc: Rewrite using mpz input routines. Change to accept a + separate base indicator on numerator and denominator. Fix base + indicator case where "123/0456" would stop at "123/0". + * Makefile.am, cxx/Makefile.am: Add cxx/ismpznw.cc. + + * tests/mpz/t-set_d.c: New file, derived from tests/mpz/t-set_si.c + * tests/mpz/Makefile.am (check_PROGRAMS): Add it. + + * mpn/m68k/lshift.asm, mpn/m68k/rshift.asm: Support 16-bit int and + stack alignment. + * mpn/m68k/README: Add notes on this. + * configure.in (SIZEOF_UNSIGNED): New define in config.m4. + * mpn/m68k/m68k-defs.m4 (m68k_definsn): Add cmpw, movew. + Reported by Patrick Pelissier. + + * mpn/m68k/t-m68k-defs.pl: Don't use -> with hashes, to avoid + deprecation warnings from perl 5.8. + + * configure.in (viac3-*-*): Use just x86/pentium in $path not x86/p6. + If gcc is to be believed the old C3s don't have cmov. + + * Makefile.am: Amend comments about not building from libtool + convenience libraries. + + * mpn/asm-defs.m4 (PROLOGUE): Use m4_file_seen, for correct filename + in missing EPILOGUE error messages. + (m4_file_seen): Amend comments about where used. + + * Makefile.am (CXX_OBJECTS): Remove $U, C++ files are not subject to + ansi2knr rules. + + * gmp-h.in (mpn_divmod_1): Use __GMP_CAST, to avoid warnings in + applications using g++ -Wold-style-cast. + + * mpn/z8000/README: New file. + +2003-10-22 Kevin Ryde + + * mpn/generic/get_d.c (CONST_1024, CONST_NEG_1023, + CONST_NEG_1022_SUB_53): Replace ALPHA_WORKAROUND with a non-gcc-ism, + and use on Cray Unicos alpha too, which has the same problem. + + * configure.in (powerpc64-*-darwin*): Make ABI=32 available as the + final fallback, remove mode64 until we know how it will work. + + * doc/gmp.texi (Build Options): Add powerpc970 to available CPUs. + (ABI and ISA): Add mode32 for Darwin. + + * configure.in (gettimeofday): Use an explicit AC_TRY_LINK, to avoid + known autoconf 2.57 problems with gettimeofday in AC_CHECK_FUNCS on + HP-UX. + + * configure.in (powerpc*-*-*): Use ABI=32 instead of ABI=standard for + the default 32-bit ABI. Fixes powerpc64-*-aix* which is documented as + choices "aix64 32" but had "aix64 standard". + + * mpfr/*: Update to mpfr-2-0-2-branch 2003-10-22. + + * doc/gmp.texi (Notes for Particular Systems): Note m68k gcc -mshort + and PalmOS calling conventions not supported. Reported by Patrick + Pelissier. + (References): Add Paul Zimmermann's Inria 4475 paper. + +2003-10-21 Torbjorn Granlund + + * mpn/ia64/submul_1.asm: Slightly reschedule loop to accommodate + Itanium 2 getf.sig latency. + +2003-10-21 Kevin Ryde + + * tests/mpn/t-instrument.c: Add mpn_addlsh1_n, mpn_rsh1add_n, + mpn_rsh1sub_n, mpn_sub_nc, mpn_sublsh1_n. Typo in mpn_preinv_divrem_1 + conditional. + +2003-10-20 Torbjorn Granlund + + * mpn/powerpc64/mode32/add_n.asm: New file. + * mpn/powerpc64/mode32/sub_n.asm: New file. + * mpn/powerpc64/mode32/mul_1.asm: New file. + * mpn/powerpc64/mode32/addmul_1.asm: New file. + * mpn/powerpc64/mode32/submul_1.asm: New file. + +2003-10-19 Torbjorn Granlund + + * longlong.h (AMD64): __x86_64__ => __amd64__. + (64-bit powerpc): Only define carry-dependent macros if + !_LONG_LONG_LIMB. + + * acinclude.m4 (POWERPC64_PATTERN): Add powerpc970-*-*. + + * configure.in (POWERPC64_PATTERN): Handle *-*-darwin*. + (POWERPC64_PATTERN, *-*-aix*): Prepend powerpc64/mode64 to path_aix64. + + * mpn/powerpc64/mode64/mul_1.asm: Change cal => addi. + * mpn/powerpc64/mode64/addmul_1.asm: Likewise. + * mpn/powerpc64/mode64/submul_1.asm: Likewise. + * mpn/powerpc64/sqr_diagonal.asm: Likewise. + + * mpn/powerpc64/mode64/mul_1.asm: Move from "..". + * mpn/powerpc64/mode64/addmul_1.asm: Likewise. + * mpn/powerpc64/mode64/submul_1.asm: Likewise. + * mpn/powerpc64/mode64/divrem_1.asm: Likewise. + * mpn/powerpc64/mode64/rsh1sub_n.asm: Likewise. + * mpn/powerpc64/mode64/add_n.asm: Likewise. + * mpn/powerpc64/mode64/addsub_n.asm: Likewise. + * mpn/powerpc64/mode64/sub_n.asm: Likewise. + * mpn/powerpc64/mode64/addlsh1_n.asm: Likewise. + * mpn/powerpc64/mode64/diveby3.asm: Likewise. + * mpn/powerpc64/mode64/rsh1add_n.asm: Likewise. + * mpn/powerpc64/mode64/sublsh1_n.asm: Likewise. + + * mpn/powerpc64/lshift.asm: Handle mode32 ABI. + * mpn/powerpc64/rshift.asm: Likewise. + * mpn/powerpc64/umul.asm: Likewise. + + * tune/powerpc64.asm: Make it actually work. + +2003-10-19 Kevin Ryde + + * mpn/generic/get_d.c: Add a workaround for alpha gcc signed constant + comparison bug. + + * gmpxx.h (gmp_randclass gmp_randinit_lc_2exp_size constructor): Throw + std::length_error if size is too big. + * tests/cxx/t-rand.cc (check_randinit): Exercise this. + + * mpn/x86/pentium4/sse2/addlsh1_n.asm: New file, derived in part from + mpn/x86/pentium4/sse2/add_n.asm. + + * doc/gmp.texi (C++ Interface Integers, C++ Interface Rationals, C++ + Interface Floats): Note std::invalid_argument exception for invalid + strings to constructors and operator=. + (C++ Interface Random Numbers): Note std::length_error exception for + size too big in gmp_randinit_lc_2exp_size. + +2003-10-18 Kevin Ryde + + * mpfr/*: Update to mpfr-2-0-2-branch 2003-10-18. + + * gmpxx.h (mpz_class, mpq_class, mpf_class, mpfr_class constructors + and operator= taking string or char*): Throw std::invalid_argument if + string cannot be converted. + * tests/cxx/t-constr.cc, tests/cxx/t-assign.cc: Exercise this. + + * cxx/ismpz.cc, cxx/ismpq.cc, cxx/ismpf.cc: Use istream std::locale + ctype facet for isspace when available. Only accept space at the + start of the input, same as g++ libstdc++. Use ASSERT_NOCARRY to + check result of mpz_set_str etc. + * cxx/ismpf.cc: Don't accept "@" for exponent indicator. + + * tune/speed.c, tune/speed.h, tune/common.c, tune/Makefile.am: Remove + _open and _mpn variants of mpn_toom3_mul_n, only one style now. + * tune/mul_n_open.c, tune/mul_n_mpn.c: Remove files. + + * gmp-impl.h (LIMB_HIGHBIT_TO_MASK): New macro. + (udiv_qrnnd_preinv2, udiv_qrnnd_preinv2gen): Use it. + + * tests/mpz/t-import.c, tests/mpz/t-export.c: Use octal for character + constants, hex is an ANSI-ism. + + * mpn/alpha/ev5/mode1o.c: Corrections to ASSERTs, as per + mpn/generic/mode1o.c. + + * mpn/generic/diveby3.c: Add commented out alternative code and notes + for taking the multiply off the dependent chain. Amend/clarify some + of the other comments. + + * configure.in (powerpc970-*-*): Use gcc -mcpu=970 when available. + (powerpc7400-*-*): Fallback on gcc -mcpu=750 if -mcpu=7400 not + available. + + * doc/gmp.texi (C++ Formatted Input): Note locale digit grouping not + supported. + (C++ Formatted Input, C++ Formatted Output): Cross reference class + interface on overloading. + + * mpn/m68k/README: Add various ideas from doc/tasks.html. + + * mpn/m88k/README: New file. + +2003-10-16 Torbjorn Granlund + + * config.sub: Recognize powerpc970. + +2003-10-15 Torbjorn Granlund + + * config.guess: Recognize powerpc970 under MacOS. + +2003-10-15 Kevin Ryde + + * configure.in, acinclude.m4 (GMP_C_RIGHT_SHIFT): New test. + * gmp-impl.h (LIMB_HIGHBIT_TO_MASK): New macro. + (udiv_qrnnd_preinv2, udiv_qrnnd_preinv2gen): Use it. + + * mpn/amd64/amd64-defs.m4: New file, with a non-aligning PROLOGUE. + * configure.in (amd64-*-*): Use it. + * mpn/amd64/addlsh1_n.asm: Add ALIGN(16). + + * mpfr/*: Update to mpfr cvs 2003-10-15. + + * mpn/generic/get_d.c: Rewrite, simplifying and truncating towards + zero unconditionally. + * tests/mpn/t-get_d.c: Add various further tests. + * gmp-impl.h (FORCE_DOUBLE): New macro. + + * gmp-h.in (__mpz_struct): Add comment on __mpz_struct getting into + C++ mangled function names. + + * doc/gmp.texi (Build Options): Update notes for new doc subdir. + (Low-level Functions): Note mpn functions don't check for zero limbs + etc, it's up to an application to strip. + + * doc/configuration (Configure): mdate-sh now in doc subdir, add + generated fat.h. + +2003-10-14 Torbjorn Granlund + + * mpn/ia64/lorrshift.asm: Rewrite. + + * mpn/ia64/diveby3.asm: Remove explicit bundling; add branch hints. + +2003-10-13 Torbjorn Granlund + + * mpn/ia64/diveby3.asm: New file. + +2003-10-13 Kevin Ryde + + * mpn/powerpc32/mod_34lsub1.asm: New file. + + * mpn/powerpc32/diveby3.asm, mpn/powerpc64/diveby3.asm: src[] in + second operand of mullw, to allow possible early-out, which the + 0xAA..AB inverse cannot give. This improvement noticed by Torbjorn. + + * acinclude.m4 (GMP_ASM_LSYM_PREFIX): Print to config.log whether + local label is purely temporary or appears in object files, for + development purposes. + + * doc/gmp.texi, doc/fdl.texi, doc/texinfo.tex, doc/mdate-sh: Moved + from top-level. + * doc/Makefile.am: New file. + * configure.in (AC_OUTPUT): Add doc/Makefile. + * Makefile.am (SUBDIRS): Move doc subdirectory from EXTRA_DIST. + (info_TEXINFOS, gmp_TEXINFOS): Moved to doc/Makefile.am. + * mpfr/Makefile.am (mpfr_TEXINFOS): fdl.texi now in doc subdir. + (TEXINFO_TEX): texinfo.tex now in doc subdir. + (AM_MAKEINFOFLAGS): Set -I to doc subdir. + + * mpz/and.c: For positive/positive, use mpn_and_n, rate a realloc as + UNLIKELY. + + * mpn/generic/mul_n.c (mpn_toom3_mul_n, mpn_toom3_sqr_n): Don't test + for high zero limbs. + +2003-10-12 Torbjorn Granlund + + * mpn/powerpc64/diveby3.asm: New file (trivial edits of + powerpc32/diveby3.asm). + + * mpn/powerpc32/diveby3.asm: Update cycle counts with more processors. + * mpn/powerpc32/sqr_diagonal.asm: Likewise. + + * mpn/pa64/add_n.asm: Correct PA8500 cycle counts. + * mpn/pa64/sub_n.asm: Likewise. + + * mpn/m68k/aors_n.asm (INPUT PARAMETERS): Fix typo. + * mpn/m68k/lshift.asm: Likewise. + * mpn/m68k/rshift.asm: Likewise. + + * mpn/m68k/README: Correct an URL; add some STATUS comments. + + * mpn/ia64/aorslsh1_n.asm: Avoid shrp when shl/shr works just as well. + + * mpn/powerpc32/addlsh1_n.asm: New file. + * mpn/powerpc32/sublsh1_n.asm: New file. + +2003-10-12 Kevin Ryde + + * mpn/sparc64/divrem_1.c, mpn/sparc64/mod_1.c: New files. + * mpn/sparc64/sparc64.h (HALF_ENDIAN_ADJ, count_leading_zeros_32, + invert_half_limb, udiv_qrnnd_half_preinv): New macros. + + * gmp-impl.h (udiv_qrnnd_preinv2): Use a ? : for getting the n1 bit, + so as not to depend on signed right shifts being arithmetic. + + * mpn/powerpc32/diveby3.asm: New file. + + * mpn/generic/divrem_1.c: Use CNST_LIMB(0) to avoid warnings from + udiv_qrnnd_preinv about shift count when int + + * mpn/ia64/rsh1aors_n.asm: New file. + + * mpn/asm-defs.m4: Handle rsh1aors_n. + + * configure.in (tmp_mulfunc): Handle rsh1aors_n. + +2003-10-11 Kevin Ryde + + * mpn/x86/pentium4/sse2/diveby3.asm: Remove non-PIC RODATA memory + access for 0xAAAAAAAB constant. + + * gmp-impl.h (popc_limb, ULONG_PARITY) [ev67, ev68]: Add gcc asm + versions using ctpop. + + * mpn/x86/k6/aorsmul_1.asm: Tweak some comments, remove M4_description + and M4_desc_retval used only in comments. + + * mpn/x86/k6/mul_basecase.asm: Add comment on using mpn_mul_1. + +2003-10-09 Torbjorn Granlund + + * mpn/powerpc64/addlsh1_n.asm: Tweak for 0.25 c/l better loop speed. + * mpn/powerpc64/sublsh1_n.asm: Likewise. + +2003-10-09 Kevin Ryde + + * mpfr/*: Update to mpfr cvs 2003-10-09. + + * tests/devel/try.c (_SC_PAGESIZE): Define from _SC_PAGE_SIZE on + systems which use that, eg. hpux 9. + +2003-10-07 Kevin Ryde + + * tune/freq.c (freq_sysctl_hw_model): Correction to last sscanf change. + + * configure.in: Check for psp_iticksperclktick in struct pst_processor. + * tune/freq.c (freq_pstat_getprocessor): Use this. + + * tests/devel/try.c (divisor_array): Add a couple of half-limb values. + + * acinclude.m4 (GMP_PROG_CC_WORKS): Correction to last change, need to + set result "yes" when cross compiling. + +2003-10-06 Torbjorn Granlund + + * mpn/generic/mul_n.c: Use __GMPN_ADD_1/_GMPN_SUB_1 instead of + mpn_add_1 and mpn_sub_1. + + * mpn/pa64/aorslsh1_n.asm: Schedule register save and restore code. + +2003-10-05 Torbjorn Granlund + + * mpn/pa64/mul_1.asm: Misc comment cleanups. + * mpn/pa64/addmul_1.asm: Likewise. + * mpn/pa64/submul_1.asm: Likewise. + + * mpn/pa64/README: Correct cycle counts. + + * mpn/pa64/aorslsh1_n.asm: New file. + +2003-10-04 Kevin Ryde + + * tune/freq.c (freq_sysctl_hw_model, freq_sunos_sysinfo, + freq_sco_etchw, freq_bsd_dmesg, freq_irix_hinv): Demand matching of + MHz etc at end of sscanf format string. In particular need this for + freq_bsd_dmesg on i486-pc-freebsd4.7 to avoid the 486 cpu being used + for the frequency. + + * tests/misc.c, tests/tests.h (tests_setjmp_sigfpe, + tests_sigfpe_handler, tests_sigfpe_done, tests_sigfpe_target, + tests_dbl_mant_bits): New. + + * configure.in (viac3*-*-*): Add gcc VIA c3 options. + + * mpfr/*: Update to mpfr cvs 2003-10-04. + + * tests/refmpn.c (refmpn_addlsh1_n, refmpn_sublsh1_n, + refmpn_rsh1add_n, refmpn_rsh1sub_n): Add ASSERTs for operand overlaps. + * tests/tests.h (refmpn_addlsh1_n, refmpn_sublsh1_n, refmpn_rsh1add_n, + refmpn_rsh1sub_n): Add prototypes. + + * tests/devel/try.c, tune/many.pl: Add mpn_addlsh1_n, mpn_sublsh1_n, + mpn_rsh1add_n, mpn_rsh1sub_n. + +2003-10-03 Torbjorn Granlund + + * tests/refmpn.c (refmpn_addlsh1_n, refmpn_sublsh1_n, refmpn_rsh1add_n, + refmpn_rsh1sub_n): New functions. + +2003-10-03 Paul Zimmermann + + * mpn/generic/mul_n.c (toom3_interpolate): Use mpn_add_1/mpn_sub_1 + instead of MPN_INCR_/MPN_DECR_U. + +2003-10-02 Torbjorn Granlund + + * configure.in (ia64*-*-hpux*): Fall back to +O1, not +O. + +2003-10-02 Kevin Ryde + + * configure.in (ia64*-*-hpux*): For cc, let +O optimization level + fallback if +O3 doesn't work. + + * acinclude.m4 (GMP_PROG_CC_WORKS): Add a test of __builtin_alloca + when available, to pick up Itanium HP-UX cc internal errors in +O2. + Provoking code by Torbjorn. + +2003-10-01 Torbjorn Granlund + + * mpn/ia64/gmp-mparam.h: Retune. + + * mpn/asm-defs.m4: Handle aorslsh1_n. + + * configure.in (tmp_mulfunc): Handle aorslsh1_n. + + * mpn/ia64/aorslsh1_n.asm: New file. + + * mpn/ia64/aors_n.asm: New file, complete rewrite of mpn_add_n and + mpn_sub_n. + * mpn/ia64/add_n.asm: Replace by aors_n.asm. + * mpn/ia64/sub_n.asm: Replace by aors_n.asm. + +2003-10-01 Kevin Ryde + + * acinclude.m4 (GMP_C_DOUBLE_FORMAT): Make bad ARM last byte into a + separate case and consider it non-IEEE, since it looks like this is + due to some sort of restricted or incorrect software floats. + + * demos/calc/Makefile.am: Use automake yacc/lex support, seems fine in + separate objdir now. + + * cxx/dummy.cc: Moved from top-level dummy.cc. + * Makefile.am (libgmpxx_la_SOURCES): Update to cxx/dummy.cc, + correction to comment about this. + +2003-09-30 Torbjorn Granlund + + * demos/pexpr.c: Correct documentation of -split. + (TIME): Remove cast of result to double. + (main): Change timing variables to int. + (main): #ifdef LIMIT_RESOURCE_USAGE, don't convert numbers of more than + 100000 digits. + +2003-09-28 Torbjorn Granlund + + * mpn/*/*.asm: Clean up spacing, tabify. + + * mpn/alpha/rshift.asm: Table cycle counts. + * mpn/alpha/lshift.asm: Likewise. + * mpn/alpha/ev5/rshift.asm: Likewise. + * mpn/alpha/ev5/lshift.asm: Likewise. + * mpn/alpha/ev6/add_n.asm: Likewise. + * mpn/alpha/ev6/sub_n.asm: Likewise. + + * mpn/ia64/lorrshift.asm: Amend comments about performance. + + * mpn/pa64/mul_1.asm: Fix comment typo. + * mpn/pa64/addmul_1.asm: Likewise. + * mpn/pa64/submul_1.asm: Likewise. + + * mpn/amd64/addlsh1_n.asm: Save/restore carry using two insn to break + recurrency. Add remarks about possible further speedup. + * mpn/amd64/sublsh1_n.asm: Likewise. + + * mpn/amd64/rsh1add_n.asm: Add remarks about possible further speedup. + * mpn/amd64/rsh1sub_n.asm: Likewise. + +2003-09-27 Torbjorn Granlund + + * mpn/powerpc64/README: Update with POWER4/PPC970 pipeline info. + + * mpn/powerpc64/rsh1add_n.asm: New file. + * mpn/powerpc64/rsh1sub_n.asm: New file. + * mpn/powerpc64/rshift.asm: Rewrite. + * mpn/powerpc64/lshift.asm: Rewrite. + +2003-09-26 Torbjorn Granlund + + * mpn/powerpc64/addlsh1_n.asm: New file. + * mpn/powerpc64/sublsh1_n.asm: New file. + +2003-09-25 Torbjorn Granlund + + * tune/common.c (speed_mpn_addlsh1_n, speed_mpn_sublsh1_n, + speed_mpn_rsh1add_n, speed_mpn_rsh1sub_n): Conditionalize on + corresponding HAVE_NATIVE_*. + +2003-09-25 Kevin Ryde + + * mpz/combit.c: Use GMP_NUMB_BITS not BITS_PER_MP_LIMB. + + * demos/expr/exprfr.c: Allow for mpfr_inf_p, mpfr_nan_p and + mpfr_number_p merely returning non-zero, rather than 1 or 0. + + * demos/expr/exprfr.c, demos/expr/t-expr.c: Add erf, integer_p, zeta. + + * demos/expr/Makefile.am (LDADD): Update comments on $(LIBM). + +2003-09-24 Torbjorn Granlund + + * tune/speed.c (routine): Add entries for mpn_addlsh1_n, mpn_sublsh1_n, + mpn_rsh1add_n, and mpn_rsh1sub_n. + + * tune/speed.h: Declare speed_mpn_addlsh1_n, speed_mpn_sublsh1_n, + speed_mpn_rsh1add_n, and speed_mpn_rsh1sub_n. + + * tune/common.c (speed_mpn_addlsh1_n, speed_mpn_sublsh1_n, + speed_mpn_rsh1add_n, speed_mpn_rsh1sub_n): New functions. + + * gmp-impl.h: Declare mpn_addlsh1_n, mpn_sublsh1_n, mpn_rsh1add_n, and + mpn_rsh1sub_n. + + * mpn/asm-defs.m4: Add define_mpn's for addlsh1_n, sublsh1_n, + rsh1add_n, and rsh1sub_n. + + * mpn/powerpc64/*.asm: Add cycle counts in consistent style. Misc + styling edits. + + * mpn/amd64/gmp-mparam.h: Retune. + + * configure.in: Add #undefs for HAVE_NATIVE_mpn_addlsh1_n, + HAVE_NATIVE_mpn_sublsh1_n, HAVE_NATIVE_mpn_rsh1add_n, + HAVE_NATIVE_mpn_rsh1sub_n. + (gmp_mpn_functions_optional): List addlsh1_n, sublsh1_n, rsh1add_n, + and rsh1sub_n. + + * mpn/amd64/addlsh1_n.asm: New file. + * mpn/amd64/sublsh1_n.asm: New file. + * mpn/amd64/rsh1add_n.asm: New file. + * mpn/amd64/rsh1sub_n.asm: New file. + +2003-09-24 Kevin Ryde + + * mpfr/*: Update to mpfr cvs 2003-09-24. + + * acinclude.m4 (GMP_C_DOUBLE_FORMAT): Remove conftest* temporary files. + +2003-09-23 Torbjorn Granlund + + * gmp-impl.h (MUL_TOOM3_THRESHOLD, SQR_TOOM3_THRESHOLD): Now 128. + +2003-09-23 Kevin Ryde + + * gmp-h.in (gmp_randinit_set): Use __gmp_const rather than const. + +2003-09-22 Torbjorn Granlund + + * tune/mul_n_mpn.c: (__gmpn_sqr_n): New #define. + * tune/mul_n_open.c (__gmpn_sqr_n): New #define. + + * mpn/generic/mul.c (mpn_sqr_n): Move from here... + * mpn/generic/mul_n.c (mpn_sqr_n): ...to here. + (mpn_sqr_n): Allocate workspace for toom3 using TMP_* mechanism except + for very large operands when !WANT_FFT. + + * mpn/generic/mul_n.c: Add a missing ";". Misc comment fixes. + + * mpn/generic/mul.c: Remove spurious #include . + + * mpn/x86/k7/gmp-mparam.h: Retune. + + * mpn/generic/mul_n.c (mpn_mul_n): Allocate workspace for toom3 using + TMP_* mechanism except for very large operands when !WANT_FFT. + + * gmp-impl.h (MPN_TOOM3_MUL_N_TSIZE, MPN_TOOM3_SQR_N_TSIZE): + Define conditionally on WANT_FFT and HAVE_NATIVE_mpn_sublsh1_n. + (MPN_TOOM3_MAX_N): New #define. + + * mpn/amd64/gmp-mparam.h: Retune. + + * mpn/Makefile.am (TARG_DIST): Add amd64. + + * mpn/generic/sqr_basecase.c: Use mpn_addlsh1_n when available. + + * mpn/generic/mul_n.c: Use proper form for HAVE_NATIVE macros. + +2003-09-22 Kevin Ryde + + * mpfr/*: Update to mpfr cvs 2003-09-22. + +2003-09-21 Kevin Ryde + + * mpn/x86/pentium4/sse2/gmp-mparam.h (USE_PREINV_DIVREM_1, + USE_PREINV_MOD_1): Set to 1 for new asm versions. + + * mpfr/*: Update to mpfr cvs 2003-09-21. + +2003-09-21 Paul Zimmermann + + * mpn/generic/mul_n.c (mpn_toom3_mul_n): Conditionally use + mpn_sublsh1_n, mpn_rsh1add_n and mpn_rsh1sub_n, in addition to + mpn_addlsh1_n. Avoid all copying, at the expense of some additional + workspace. + + * gmp-impl.h (MPN_TOOM3_MUL_N_TSIZE, MPN_TOOM3_SQR_N_TSIZE): Accommodate + latest toom3 code. + +2003-09-19 Kevin Ryde + + * mpn/x86/pentium4/sse2/divrem_1.asm, mpn/x86/pentium4/sse2/mod_1.asm: + New files. + +2003-09-16 Kevin Ryde + + * tune/speed.c (run_one): Don't scale the -1.0 not-available return. + Print "n/a" for times not-available. + +2003-09-13 Paul Zimmermann + + * mpn/generic/mul_n.c (toom3_interpolate): New function. + (mpn_toom3_mul_n, mpn_toom3_sqr_n): Call toom3_interpolate. + +2003-09-12 Torbjorn Granlund + + * mpn/generic/mul_n.c (mpn_toom3_mul_n, mpn_toom3_sqr_n): Remove unused + variables. + (mpn_toom3_mul_n, mpn_toom3_sqr_n): Use offset `+ 1', not `+ 2' in last + MPN_DECR_U calls. + +2003-09-12 Paul Zimmermann + + * mpn/generic/mul_n.c (mpn_toom3_mul_n, mpn_toom3_sqr_n): Rewrite. + +2003-09-12 Torbjorn Granlund + + * gmp-impl.h (MPN_KARA_MUL_N_TSIZE, MPN_KARA_SQR_N_TSIZE): Reformulate + to use the same form as MPN_TOOM3_MUL_N_TSIZE. + (MPN_TOOM3_MUL_N_TSIZE, MPN_TOOM3_SQR_N_TSIZE): Update for new Toom3 + code requirements. + * mpn/generic/mul_n.c (evaluate3, interpolate3, add2Times): Remove. + (USE_MORE_MPN): Remove. + +2003-08-31 Kevin Ryde + + * mpfr/*: Update to mpfr cvs 2003-08-31. + +2003-08-30 Kevin Ryde + + * mpfr/*: Update to mpfr cvs 2003-08-30. + +2003-08-29 Torbjorn Granlund + + * mpn/amd64/copyi.asm: New file. + * mpn/amd64/copyd.asm: New file. + * mpn/amd64/README: New file. + +2003-08-28 Torbjorn Granlund + + * mpn/amd64/lshift.asm: New file. + * mpn/amd64/rshift.asm: New file. + * mpn/amd64/gmp-mparam.h: Retune. + +2003-08-23 Kevin Ryde + + * tune/freq.c (freq_getsysinfo): Correction to speed_cycletime value + established. + + * mpz/rootrem.c, gmp-h.in, gmp.texi (mpz_rootrem): Don't return + exactness indication, can get that from testing the remainder. + + * mpn/x86/k7/aors_n.asm, mpn/x86/k7/mmx/copyi.asm: Amend to comments + about loads and stores and what speed should be possible. + +2003-08-22 Torbjorn Granlund + + * mpn/amd64/add_n.asm: New file. + * mpn/amd64/sub_n.asm: New file. + * mpn/amd64/mul_1.asm: New file. + * mpn/amd64/addmul_1.asm: New file. + * mpn/amd64/submul_1.asm: New file. + +2003-08-19 Kevin Ryde + + * longlong.h (add_ssaaaa, sub_ddmmss) [hppa 64]: Move down into main + __GNUC__ block. Exclude for _LONG_LONG_LIMB (ie. ABI=2.0n) since + these forms are only for ABI=2.0w. + + * longlong.h (count_leading_zeros) [__mcpu32__]: Check __mcpu32__ to + avoid bfffo on GCC 3.4 in CPU32 mode. Reported by Bernardo Innocenti. + + * longlong.h (count_trailing_zeros) [x86_64]: Use "%q0" to force + 64-bit register destination. Pointed out by Torbjorn. + + * mpz/combit.c: Correction to carry handling when extending a + negative, and use __GMPN_ADD_1. Correction to complement limb for a + negative when there's a non-zero low limb. + * tests/mpz/bit.c (check_clr_extend, check_com_negs): Exercise these. + + * demos/perl/GMP.xs, demos/perl/GMP.pm, demos/perl/test.pl: Add + get_d_2exp. + * demos/perl/GMP.xs, demos/perl/GMP.pm, demos/perl/GMP/Rand.pm, + demos/perl/test.pl: Add gmp_urandomb_ui, gmp_urandomm_ui. + (GMP::Rand::randstate): Accept a randstate object to copy. + * demos/perl/GMP.xs, demos/perl/GMP.pm, demos/perl/GMP/Mpz.pm, + demos/perl/test.pl: Add combit, rootrem. + +2003-08-19 Torbjorn Granlund + + * tune/Makefile.am (EXTRA_DIST): Add amd64.asm. + +2003-08-17 Kevin Ryde + + * gmpxx.h [__MPFR_H]: Include full for inlines. + * tests/cxx/t-headfr.cc: New file, exercising this. + * tests/cxx/Makefile.am: Add it. + + * tests/cxx/t-constr.cc: Include config.h for WANT_MPFR. + + * gmpxx.h: Correction to temp variable type in mpf -> mpfr assignment. + Reported by Derrick Bass. + * tests/cxx/t-assign.cc (check_mpfr): Exercise this. + + * configure.in (WANT_MPFR): AC_DEFINE this, for the benefit of + tests/cxx/t-*.cc. (Was always meant to have been defined.) + * tests/cxx/Makefile.am (INCLUDES): Add -I$(top_srcdir)/mpfr. + + * gmpxx.h: __gmp_default_rounding_mode -> __gmpfr_default_rounding_mode + (struct __gmp_hypot_function): Correction to mpfr_hypot addition. + * tests/cxx/t-misc.cc (check_mpfr_hypot): Corrections to mpfr/long + tests. + +2003-08-16 Torbjorn Granlund + + * configure.in (amd64): New. + + * mpn/amd64/gmp-mparam.h: New file. + + * tune/amd64.asm: New file, derived in part from tune/pentium.asm. + +2003-08-15 Kevin Ryde + + * tune/freq.c (freq_irix_hinv): Reinstate, for the benefit of IRIX 6.2. + (freq_attr_get_invent): Conditionalize on INFO_LBL_DETAIL_INVENT too. + +2003-08-14 Kevin Ryde + + * mpq/get_d.c: Use mpn_get_d. + * tests/mpq/t-get_d.c (check_onebit): New test. + + * gmp.texi (Notes for Particular Systems): Under x86 cpu types, note + i386 is a fat binary, remove pentium4 recommendation since i386 is now + quite reasonable for p4. + (Notes for Particular Systems): Under Windows DLLs, remove caveat + about --enable-cxx now ok, update .lib creation for new libtool, + remove .exp not needed for MS C. + (Notes for Package Builds): i386 is a fat binary. + (Reentrancy): Remove SCO ctype.h note, don't want to list every system + misfeature, and was quite possibly for non-threading mode anyway. + (Autoconf): Remove notes on gmp 2 detection, too old to want to + encourage anyone to use. + (Karatsuba Multiplication): Correction to threshold increase/decrease + for a and b terms. Reported by Richard Brent and Paul Zimmermann. + Also add various further index entries. + + * tune/freq.c (freq_attr_get_invent): New function. + (freq_irix_hinv): Remove, in favour or freq_attr_get_invent. + * configure.in (AC_CHECK_FUNCS): Add attr_get. + (AC_CHECK_HEADERS): Add invent.h, sys/attributes.h, sys/iograph.h. + +2003-08-03 Kevin Ryde + + * tune/tuneup.c (tune_mul): Use MUL_KARATSUBA_THRESHOLD_LIMIT. + +2003-08-02 Kevin Ryde + + * mpn/asm-defs.m4: Tweak some comments, add hpux11 to m4wrap 0xFF + problem systems. + + * configure.in (*-*-sco3.2v5*): Remove lt_cv_archive_cmds_need_lc=no, + since libtool no longer uses it. This was a workaround fixing ctype.h + in SCO 5 shared libraries; not sure if libtool now gets it right on + its own, let's hope so. + + * configure.in, acinclude.m4 (GMP_PROG_HOST_CC): Remove, libtool no + longer demands HOST_CC. + + * configure.in: When C or C++ compiler not found, refer user to + config.log. + + * configure.in (i386-*-*): Turn i386 into a fat binary build. + * mpn/x86/fat/fat.c, mpn/x86/fat/fat_entry.asm, + mpn/x86/fat/gmp-mparam.h, mpn/x86/fat/gcd_1.c, mpn/x86/fat/mode1o.c: + New files. + * gmp-impl.h (struct cpuvec_t) [x86 fat]: New structure. + * longlong.h (COUNT_LEADING_ZEROS_NEED_CLZ_TAB) [x86 fat]: Define. + * mpn/asm-defs.m4 (foreach): New macro. + * mpn/x86/x86-defs.m4 (CPUVEC_FUNCS_LIST): New define. + * mpn/x86/sqr_basecase.asm: New file, primarily as a fallback for fat + binaries. + * mpn/x86/p6/gmp-mparam.h, mpn/x86/p6/mmx/gmp-mparam.h: Add comments + about fat binary SQR_KARATSUBA_THRESHOLD for p6 and p6/mmx. + + * configure.in: Add various supports for fat binaries, via fat_path, + fat_functions and fat_thresholds variables. + * acinclude.m4 (GMP_STRIP_PATH): Mung $fat_path too. + (GMP_FAT_SUFFIX, GMP_REMOVE_FROM_LIST): New macros. + * gmp-impl.h: Add various supports for fat binaries. + (DECL_add_n etc): New macros. + (mpn_mul_basecase etc): Define only if not already defined. + * mpn/asm-defs.m4 (m4_config_gmp_mparam): Mention fat binary. + (MPN): Use m4_unquote, for the benefit of fat binary name expansion. + * doc/configuration: Notes on fat binaries. + * gmp-impl.h (MUL_TOOM3_THRESHOLD_LIMIT): Define always. + (MUL_KARATSUBA_THRESHOLD_LIMIT): New define. + * mpn/generic/mul.c, mpn/generic/mul_n.c: Use these. + * tune/divrem1div.c, tune/divrem1inv.c, tune/mod_1_div.c, + tune/mod_1_inv.c: Define OPERATION_divrem_1 and OPERATION_mod_1, to + tell fat.h what's being done. + + * config.guess (alpha-*-*): Update comments on what configfsf.guess + does and doesn't do for us. + +2003-07-31 Kevin Ryde + + * config.guess: Remove $dummy.o files everywhere, in case vendor + compilers produce that even when not asked. + + * demos/perl/GMP.xs (class_or_croak): Rename "class" parameter to + avoid C++ keyword. + (coerce_ulong, coerce_long): Move croaks to stop g++ 3.3 complaining + about uninitialized variables. + + * demos/perl/INSTALL: Add notes on building with a DLL. + + * longlong.h (count_trailing_zeros) [x86_64]: Ensure bsfq destination + is a 64-bit register. Diagnosed by Francois G. Dorais. + +2003-07-31 Torbjorn Granlund + + * longlong.h [ppc]: Remove nested test for vxworks. + +2003-07-24 Kevin Ryde + + * gmpxx.h (struct __gmp_binary_multiplies): Use mpz_mul_si for + mpz*long and long*mpz. + * tests/cxx/t-ops.cc (check_mpz): Exercise mpz*long and mpz*ulong. + + * cxx/ismpf.cc: Use std::locale decimal point when available. Expect + localeconv available always. + * tests/cxx/t-locale.cc: Enable check_input tests. + + * gmpxx.h (struct __gmp_hypot_function): Use mpfr_hypot. + * tests/cxx/t-misc.cc (check_mpfr_hypot): New tests. + + * tests/cxx/t-assign.cc, tests/cxx/t-binary.cc, tests/cxx/t-ops.cc, + tests/cxx/t-prec.cc, tests/cxx/t-ternary.cc, tests/cxx/t-unary.cc: + Include config.h for WANT_MPFR. + + * tests/mpz/bit.c (check_single): Correction to a diagnostic print. + +2003-07-24 Niels Möller + + * mpz/combit.c: New file. + * Makefile.am, mpz/Makefile.am: Add it. + * gmp-h.in (mpz_combit): Add prototype. + * tests/mpz/bit.c (check_single): Exercise mpz_combit. + +2003-07-16 Kevin Ryde + + * mpn/generic/get_d.c: Correction to infinity handling for large exp. + +2003-07-14 Kevin Ryde + + * mpz/get_d.c, mpz/get_d_2exp.c, mpf/get_d.c, mpf/get_d_2exp.c: Use + mpn_get_d. + + * mpn/generic/get_d.c: New file, based on mpz/get_d.c and insert-dbl.c. + * configure.in, mpn/Makefile.am: Add it. + * gmp-impl.h (mpn_get_d): Add prototype. + + * tests/mpn/t-get_d.c: New file. + * tests/mpn/Makefile.am: Add it. + + * tests/mpz/t-get_d_2exp.c (check_onebit, check_round): Test negatives. + (check_onebit): Add a few more bit sizes. + + * tests/misc.c, tests/tests.h (tests_isinf): New function. + +2003-07-12 Kevin Ryde + + * configure.in (GMP_PROG_CXX_WORKS): Include $CPPFLAGS, same as + automake does in the actual build. + + * acinclude.m4 (GMP_PROG_CXX_WORKS): In the namespace test, declare + namespace before trying to use. In std iostream test, provoke a + failure from Compaq C++ in pre-standard mode. + +2003-07-08 Kevin Ryde + + * acinclude.m4 (GMP_PROG_CC_WORKS): Use separate compiles for various + known problems, and indicate to the user the reason for rejecting. + (GMP_PROG_CXX_WORKS): Ditto, and insist on being able to execute each + compiled program. + +2003-07-05 Kevin Ryde + + * config.sub: Add comments to our alias transformations. + + * configfsf.sub, configfsf.guess: Update to 2003-07-04. + + * acinclude.m4 (GMP_PROG_CC_WORKS, GMP_PROG_CC_WORKS_LONGLONG): Show + failing program in config.log, per other autoconf tests. + + * configure.in (i786-*-*): Recognise as pentium4, per configfsf.sub. + +2003-06-28 Kevin Ryde + + * mpz/get_d_2exp.c, mpf/get_d_2exp.c: Avoid res==1.0 when floats round + upwards. + + * tests/mpz/t-get_d_2exp.c: New file. + * tests/mpz/Makefile.am (check_PROGRAMS): Add it. + * tests/mpf/t-get_d_2exp.c: New file. + * tests/mpf/Makefile.am (check_PROGRAMS): Add it. + * tests/x86call.asm, test/tests.h (x86_fldcw, x86_fstcw): New + functions. + * tests/misc.c, tests/tests.h (tests_hardware_getround, + tests_hardware_setround): New functions. + +2003-06-25 Kevin Ryde + + * mpn/sparc64/dive_1.c: New file. + + * mpn/sparc64/sparc64.h: New file. + * mpn/sparc64/mode1o.c: Remove things now in sparc64.h. + + * mpfr/*: Update to mpfr cvs 2003-06-25. + + * acinclude.m4 (GMP_PROG_CC_WORKS): In last change provoking gnupro + gcc, don't use ANSI style function definition. + +2003-06-22 Kevin Ryde + + * mpn/pa32/hppa1_1/udiv.asm: Remove .proc, .entry, .exit and .procend, + handled by PROLOGUE and EPILOGUE. Comment out .callinfo, per other + asm files. + + * gmpxx.h (mpz_class __gmp_binary_divides, __gmp_binary_modulus): Fix + long/mpz and long%mpz for dividend==LONG_MIN divisor==-LONG_MIN. + (mpz_class __gmp_binary_modulus): Fix mpz%long for negative dividend. + * tests/cxx/t-ops.cc (check_mpz): Add test cases for these, merging + operator/ and operator% sections for clarity. + +2003-06-21 Kevin Ryde + + * mpfr/*: Update to mpfr cvs 2003-06-21. + + * acinclude.m4 (GMP_PROG_CC_WORKS): Add code by Torbjorn provoking an + ICE from gcc 2.9-gnupro-99r1 under -O2 -mcpu=ev6. + * configure.in (alpha*-*-* gcc_cflags_cpu): Fallback on -mcpu=ev56 for + this compiler. + + * gmpxx.h (get_d): Remove comments about long double, double is + correct for get_d, a future long double form would be get_ld. + +2003-06-19 Kevin Ryde + + * mpfr/*: Update to mpfr cvs 2003-06-19. + + * mpn/generic/dive_1.c: Share src[0] fetch among all cases. No need + for separate final umul_ppmm in even case, make it part of the loop. + + * mpz/get_d_2exp.c, mpq/set_si.c, mpq/set_ui.c: Nailify. + + * mpf/iset_si.c: Rewrite using mpf/set_si.c code, in particular this + nailifies it. + * tests/mpf/t-set_si.c: Nailify tests. + + * mpf/iset_ui.c: Nailify, as per mpf/set_ui.c + * tests/mpf/t-set_ui.c: New file. + * tests/mpf/Makefile.am (check_PROGRAMS): Add it. + +2003-06-15 Kevin Ryde + + * mpfr/*: Update to mpfr cvs 2003-06-15. + + * mpn/x86/k6/mode1o.asm: Remove a bogus ASSERT. + +2003-06-12 Kevin Ryde + + * configure.in (--enable-assert): Emit WANT_ASSERT to config.m4. + * mpn/powerpc32/powerpc-defs.m4, mpn/x86/x86-defs.m4 (ASSERT): Check + WANT_ASSERT is defined. + + * mpn/sparc32/v9/udiv.asm: Amend heading, this file is for sparc v9. + + * tests/cxx/Makefile.am (TESTS_ENVIRONMENT): In libtool openbsd hack, + discard error messages from cp, for the benefit of --disable-shared or + systems not using names libgmp.so.*. + + * tests/devel/try.c (try_one): When overlapping, copy source data + after filling dst. Previously probably used only DEADVAL in + overlapping cases. + +2003-06-11 Torbjorn Granlund + + * mpf/random2.c: Rewrite. Ignore sign of exp parameter. + +2003-06-10 Kevin Ryde + + * mpn/sparc64/mode1o.c: New file. + +2003-06-09 Torbjorn Granlund + + * mpn/powerpc32/lshift.asm: Add more cycle counts. + * mpn/powerpc32/rshift.asm: Add more cycle counts. + + * mpn/ia64/addmul_1.asm: Reformat comments for 80 columns. + + * gmp-impl.h (udiv_qrnnd_preinv1): New name for udiv_qrnnd_preinv. + (udiv_qrnnd_preinv2): New name for udiv_qrnnd_preinv2norm. + (udiv_qrnnd_preinv): New #define, making udiv_qrnnd_preinv2 + the default. + * tune/speed.c: Corresponding changes. + * tune/speed.h: Likewise. + * tune/common.c: Likewise. + + * mpf/get_str.c: Simplify `off' computation. + + * longlong.h: Tabify. + +2003-06-09 Kevin Ryde + + * gmp.texi (ABI and ISA): FreeBSD has sparc64 too, just say "BSD" to + cover all flavours. + * configure.in: Ditto in some comments. + + * mpfr/*: Update to mpfr cvs 2003-06-09. + + * tests/cxx/Makefile.am (LDADD): Add -L$(top_builddir)/$(LIBS), for + the benefit of gcc 3.2 on itanium2-hp-hpux11.22. + + * tune/many.pl (mul_2): Add speed routine settings. + (MAKEFILE): Close when done, for the benefit of development hackery. + +2003-06-08 Kevin Ryde + + * mpfr/*: Update to mpfr cvs 2003-06-08. + + * mpn/x86/x86-defs.m4 (femms): Remove fallback to emms. + (cmovCC, psadbw): Remove simulated versions. + (cmov_available_p, psadbw_available_p): Remove. + This trickery was only ever for development purposes on machines + without those instructions. Removing it simplifies gmp and in + particular avoids complications for fat binary builds. Development + can be done with a wrapper around "as" if really needed. + + * mpn/x86/divrem_1.asm: Don't use loop_or_decljnz, now K6 has its own + mpn/x86/k6/divrem_1.asm. Amend K6 comments now moved to there. + * mpn/x86/x86-defs.m4 (loop_or_decljnz): Remove, no longer used. + + * mpn/x86/k6/divrem_1.asm: New file, derived from mpn/x86/divrem_1.asm. + + * mpn/x86/k6/pre_mod_1.asm: Remove comments now in mpn/x86/mod_1.asm. + + * mpn/x86/mod_1.asm: Put mpn_mod_1c after mpn_mod_1 for better branch + prediction. Put done_zero at end for less wastage in alignment. Use + decl+jnz unconditionally since in fact it's ok on k6. Amend comments. + +2003-06-07 Kevin Ryde + + * mpn/generic/mode1o.c: Fix ASSERTs on return value. + + * gmp.texi (Build Options): Add viac3 and viac32 cpu types. + (ABI and ISA): Note on sparcv9 ABI=32 vs ABI=64 speed. More indexing. + + * configfsf.guess, configfsf.sub: Update to 2003-06-06. + * config.guess: Remove $RANDOM hack supporting netbsd 1.4, not needed + by new configfsf.guess. + +2003-06-06 Torbjorn Granlund + + * mpn/ia64/submul_1.asm: Add branch over .align block. + +2003-06-05 Torbjorn Granlund + + * longlong.h (add_ssaaaa) [pa64]: Output zero operand as register 0. + Allow more immediate operands. + (sub_ddmmss) [pa64]: Likewise. + (add_ssaaaa) [pa32]: Likewise. + (sub_ddmmss) [pa32]: Likewise. + + * mpn/pa64: Change ".level 2.0W" to ".level 2.0w" to please + picky GNU assembler. + +2003-06-05 Kevin Ryde + + * gmp.texi (Integer Special Functions): In mpz_array_init, fix type + shown for integer_array and give an example use. + +2003-06-04 Torbjorn Granlund + + * mpf/set_str.c (mpf_set_str): Work around gcc 2 bug triggered on + alpha. + +2003-06-03 Kevin Ryde + + * mpn/x86/pentium/README: Add 7 c/l mmx mul_1, tweak wordings. + + * acinclude.m4 (GMP_C_DOUBLE_FORMAT): Use octal char constants in test + program, hex is not supported by K&R. + +2003-06-02 Torbjorn Granlund + + * mpn/mips64/divrem_1.asm: New file. + +2003-06-01 Torbjorn Granlund + + * mpn/powerpc32/lshift.asm: Reformat code. + * mpn/powerpc32/rshift.asm: Reformat code. + +2003-05-30 Kevin Ryde + + * tests/misc.c (tests_start): Set stdout and stderr to unbuffered, to + avoid any chance of losing output on segv etc. + +2003-05-28 Torbjorn Granlund + + * mpf/get_str.c: Move label `done' to match TMP_MARK and TMP_FREE. + Remove redundant variable prec. + +2003-05-26 Torbjorn Granlund + + * tests/mpz/convert.c: Test bases up to 62. + + * tests/mpf/t-conv.c: Test bases up to 62. + + * demos/pexpr.c: Don't iterate to get accurate timing. + + * mpf/set_str.c (mpn_pow_1_highpart): Cleanup. + + * mp_dv_tab.c: Fix typo. + + * mpf/get_str.c: Rewrite (now sub-quadratic). + +2003-05-22 Kevin Ryde + + * tests/mpn/t-divrem_1.c: New file. + * tests/mpn/Makefile.am: Add it. + +2003-05-22 Torbjorn Granlund + + * config.sub: Recognize viac3* processors. + +2003-05-20 Torbjorn Granlund + + * mpn/sparc64/addmul_2.asm: New file. + +2003-05-19 Torbjorn Granlund + + * configure.in: Recognize alphaev7* as alphaev67. + + * config.guess: Recognize viac3* processors. + * configure.in: Set up path for viac3* processors. + * acinclude.m4 (X86_PATTERN): Include viac3* processors. + +2003-05-19 Kevin Ryde + + * tune/freq.c (freq_pstat_getprocessor): New function. + (freq_all): Use it. + * configure.in (AC_CHECK_HEADERS): Add sys/pstat.h. + (AC_CHECK_FUNCS): Add pstat_getprocessor. + +2003-05-15 Kevin Ryde + + * mpn/generic/mul_fft.c (mpn_mul_fft_decompose): Remove "inline", + since the code is a bit too big. gcc doesn't actually inline when + alloca (TMP_ALLOC) is used anyway. + +2003-05-13 Kevin Ryde + + * gmp.texi (Notes for Particular Systems): Libtool directory is .libs + not _libs for mingw dll. Reported by Andreas Fabri. + +2003-05-07 Kevin Ryde + + * acinclude.m4 (GMP_PROG_CC_WORKS): Add code to generate sse2/xmm code + from gcc -march=pentium4, to check the assembler supports that. + (GMP_GCC_PENTIUM4_SSE2, GMP_OS_X86_XMM): New macros. + * configure.in (pentium4-*-*): Use them to see if gcc -march=pentium4 + (with sse2) is ok. + +2003-05-06 Kevin Ryde + + * mpz/com.c: Rate size==0 as UNLIKELY, fix comment to mpn_add_1. + + * tune/freq.c (): Include only when needed for + getsysinfo(), to avoid a problem with this file on AIX 5.1. + +2003-05-03 Torbjorn Granlund + + * mpf/set_str.c: Do not ignore supposedly superfluous digits (in part + reverting last change). + +2003-05-03 Kevin Ryde + + * gmp.texi: Use @code for files in @cindex entries, it looks nicer + than @file. + + * Makefile.am: Note gmp 4.1.1 and 4.1.2 version info. + + * configure.in, acinclude.m4 (GMP_CRAY_OPTIONS): New macro for Cray + system setups, letting AC_REQUIRE do its job instead of a hard coded + AC_PROG_EGREP. + + * config.guess: Amend fake RANDOM to avoid ". configfsf.guess" which + segfaults on Debian "ash" 0.4.16. + +2003-05-01 Kevin Ryde + + * configure.in (AC_CHECK_FUNCS): Add getsysinfo. + (AC_CHECK_HEADERS): Add sys/sysinfo.h and machine/hal_sysinfo.h. + * tune/freq.c (freq_getsysinfo): New function. + (freq_all): Use it. + (freq_sysctlbyname_i586_freq, freq_sysctlbyname_tsc_freq, + freq_sysctl_hw_cpufrequency, freq_sysctl_hw_model): Set + speed_cycletime before trying to print it, when verbose. + +2003-04-28 Torbjorn Granlund + + * mpf/set_str.c: Major overhaul. + (mpn_pow_1_highpart): New helper function, meat extracted from + mpf_set_str. + +2003-04-24 Kevin Ryde + + * acinclude.m4 (GMP_GCC_ARM_UMODSI): Quote result string against m4. + + * configure, ltmain.sh, aclocal.m4: Update to libtool 1.5. + + * longlong.h (add_ssaaaa) [all]: Remove first "%" commutative in each, + since gcc only supports one per asm. + + * printf/doprnt.c: Add M for mp_limb_t. + * tests/misc/t-printf.c: Exercise this. + + * tests/mpz/t-cmp_d.c: Test infinities. + * tests/mpf/t-cmp_d.c: New file. + * tests/mpf/Makefile.am: Add it. + + * mpz/cmp_d.c, mpz/cmpabs_d.c, mpf/cmp_d.c: NaN invalid, Inf bigger + than any value. + * mpz/set_d.c, mpq/set_d.c, mpf/set_d.c: Nan or Inf invalid. + + * configure.in (AC_CHECK_FUNCS): Add raise. + * invalid.c: New file. + * Makefile.am: Add it. + * gmp-impl.h (__gmp_invalid_operation): Add prototype. + (DOUBLE_NAN_INF_ACTION): New macro. + + * tests/trace.c, tests/tests.h (d_trace): New function. + * tests/misc.c, tests/tests.h (tests_infinity_d): New function. + * tests/misc.c (mpz_erandomb, mpz_errandomb): Use gmp_urandomm_ui. + + * tune/tuneup.c, tune/common.c, tests/devel/try.c: Cast various + mp_size_t values for printf %ld in case mp_size_t==int. Use + gmp_printf for mp_limb_t values. + + * gmp.texi (Nomenclature and Types): Add mp_exp_t, mp_size_t, + gmp_randstate_t. Note ulong for bit counts and size_t for byte + counts. Don't bother with @noindent. + (Debugging): New valgrind is getting MMX/SSE. + (Integer Comparisons): mpz_cmp_d and mpz_cmpabs_d on NaNs and Infs. + (Float Comparison): mpf_cmp_d behaviour on NaNs and Infs. + (Low-level Functions): Note with mpn_hamdist what hamming distance is. + (Formatted Output Strings): Add type M. + (Internals): Remove remarks on ulong bits and size_t bytes. Move int + field remarks to ... + (Integer Internals, Float Internals): ... here. + +2003-04-19 Kevin Ryde + + * configure.in (*sparc*-*-* ABI=32): Add umul to extra_functions. + + * mpn/x86/p6/mul_basecase.asm: New file. + +2003-04-18 Kevin Ryde + + * configure.in (m68060-*-*): Fallback to gcc -m68000 when -m68060 not + available, and don't use mpn/m68k/mc68020 asm routines. (Avoids 32x32 + mul and 64/32 div which trap to the kernel on 68060. Advice by + Richard Zidlicky.) + * mpn/m68k/README: Update notes on directory usage. + + * tests/cxx/Makefile.am (TESTS_ENVIRONMENT): Add a hack to let the + test programs run with a shared libgmpxx on openbsd 3.2. + + * gmp.texi (Language Bindings): Add Guile. + +2003-04-12 Kevin Ryde + + * configure.in (cygwin*, mingw*, pw32*, os2*): Add + -Wl,--export-all-symbols to GMP_LDFLAGS, no longer the default in + latest mingw and libtool. + + * acinclude.m4 (GMP_ASM_COFF_TYPE): New macro. + * configure.in (x86s): Use it. + * mpn/x86/x86-defs.m4 (COFF_TYPE): New macro. + (PROLOGUE_cpu): Use it, for the benefit of mingw DLLs. + + * gmp-impl.h (mpn_copyi, mpn_copyd): Add __GMP_DECLSPEC. + + * gmp.texi (Known Build Problems): Remove windows test program .exe + repeated built, fixed by new libtool. Remove MacOS C++ shared library + creation, fixed by new libtool. + (Notes for Package Builds, Known Build Problems): Remove DESTDIR notes + on libgmpxx, fixed in new libtool. + +2003-04-10 Torbjorn Granlund + + * configure.in: Match turbosparc. + * config.guess: Recognize turbosparc (just for *bsd for now). + +2003-04-09 Kevin Ryde + + * mpf/mul_ui.c [nails]: Call mpf_mul to handle v > GMP_NUMB_MAX. + + * tests/mpz/t-mul.c (main): Don't try FFT sizes when FFT disabled via + MP_SIZE_T_MAX, eg. for nails. + + * tests/cxx/t-ternary.cc: Split up tests to help compile speed and + memory usage. + + * tests/devel/try.c: Print seed under -R, add -E to reseed, use ulong + for seed not uint. + + * gmp.texi: Add @: after various abbreviations, more index entries. + (leftarrow): New macro, for non-tex. + (Random State Initialization): Remove commented gmp_randinit_lc, not + going to be implemented. + (Random Number Algorithms): New section. + (References): Add Matsumoto and Nishimura on Mersenne Twister, add + Bertot, Magaud and Zimmermann on GMP Square Root. + +2003-04-06 Kevin Ryde + + * tests/mpz/t-gcd_ui.c: New file. + * tests/mpz/Makefile.am: Add it. + + * mpz/gcd_ui.c: Correction to return value on longlong limb systems, + limb might not fit a ulong. + +2003-04-04 Kevin Ryde + + * configure, aclocal.m4, ltmain.sh: Update to libtool cvs snapshot + 2003-04-02. + +2003-04-02 Kevin Ryde + + * configure.in (*-*-cygwin*): No longer force lt_cv_sys_max_cmd_len, + libtool has addressed this now. + (AC_PROVIDE_AC_LIBTOOL_WIN32_DLL): Remove this, libtool _LT_AC_LOCK + no longer needs it. + + * acinclude.m4 (GMP_PROG_AR): Also set ac_cv_prog_AR and + ac_cv_prog_ac_ct_AR when adding flags to AR, so they're not lost by + libtool's call to AC_CHECK_TOOL. + +2003-04-01 Kevin Ryde + + * configure, aclocal.m4, ltmain.sh: Update to libtool cvs snapshot + 2003-03-31. + + * configure.in (AC_PROG_F77): Add a dummy AC_PROVIDE to stop libtool + running F77 probes. + + * randlc2x.c (gmp_rand_lc_struct): Add comments about what exactly is + in each field. + (randseed_lc): Rename seedp to seedz to avoid confusion with seedp in + the lc function. Suggested by Pedro Gimeno. + (gmp_randinit_lc_2exp): Use __GMP_ALLOCATE_FUNC_TYPE. No need for + "+1" in mpz_init2 of _mp_seed. Don't bother with mpz_init2 for _mp_a. + +2003-03-29 Kevin Ryde + + * configure.in (m68k-*-*): Use -O2, no longer need to fallback to -O. + * acinclude.m4 (GMP_GCC_M68K_OPTIMIZE): Remove macro. + + * configure.in (AC_CHECK_TYPES): Add notes on why tested. + + * gmp.texi (GMPrefu, GMPpxrefu, GMPreftopu, GMPpxreftopu): New macros, + use them for all external references to get URLs into HTML output. + (Random State Initialization): Add gmp_randinit_set. + (Random State Miscellaneous): New section. + +2003-03-29 Kevin Ryde + + * randbui.c, randmui.c: New files. + * Makefile.am: Add them. + * gmp-h.in (gmp_urandomb_ui, gmp_urandomm_ui): Add prototypes. + * tests/rand/t-urbui.c, tests/rand/t-urmui.c: New files. + * tests/rand/Makefile.am: Add them. + + * gmp-impl.h (gmp_randstate_srcptr): New typedef. + (gmp_randfnptr_t): Add randiset_fn. + * randiset.c: New file. + * Makefile.am: Add it. + * gmp-h.in (gmp_randinit_set): Add prototype. + * randlc2x.c, randmt.c: Add gmp_randinit_set support. + * tests/rand/t-iset.c: New file. + * tests/rand/Makefile.am: Add it. + + * tests/misc.c, tests/tests.h (call_rand_algs): New function. + +2003-03-27 Kevin Ryde + + * mpz/bin_uiui.c: Use plain "*" for kacc products rather than + umul_ppmm since high not needed, except for an ASSERT now amended. + +2003-03-26 Kevin Ryde + + * demos/expr/exprfr.c (cbrt, cmpabs, exp2, gamma, nextabove, + nextbelow, nexttoward): New functions. + * demos/expr/t-expr.c: Exercise these. + + * mpfr/*: Update to mpfr cvs 2003-03-26. + + * gmp-impl.h (MPZ_REALLOC): Use UNLIKELY, to expect no realloc. + + * tune/time.c (cycles_works_p): Scope variables down to relevant part + to avoid warnings about unused. + + * configfsf.guess, configfsf.sub: Update to 2003-02-22. + * config.guess: Fake a $RANDOM variable when running configfsf.guess, + to workaround a problem on m68k NetBSD 1.4.1. + + * mpz/fac_ui.c: Remove unused variable "z1". + + * tune/freq.c (freq_irix_hinv): Allow "Processor 0" line from IRIX 6.5. + +2003-03-24 Torbjorn Granlund + + * randlc2x.c (randget_lc): Remove write-only variable rn. + * mpf/eq.c: Remove write-only variable usign. + * gen-psqr.c (main): Remove write-only variable numb_bits. + +2003-03-17 Torbjorn Granlund + + * Makefile.am (libgmp_la_SOURCES): Add mp_dv_tab.c. + (libmp_la_SOURCES): Add mp_dv_tab.c. + + * mpn/alpha/invert_limb.asm: Add a few comments. + + * mp_dv_tab.c: New file, defining __gmp_digit_value_tab. + + * mpz/set_str.c: Get rid of function digit_value_in_base and use table + __gmp_digit_value_tab instead. + * mpz/inp_str.c: Likewise. + * mpf/set_str.c: Likewise. + * mpbsd/min.c: Likewise. + * mpbsd/xtom.c: Likewise. + + * mpz/set_str.c: Allow bases <= 62. Return error for invalid bases. + * mpz/inp_str.c: Likewise. + * mpf/set_str.c: Likewise. + * mpz/out_str.c: Likewise. + * mpz/get_str.c: Likewise. + * mpf/get_str.c: Likewise. + + * mpz/inp_str.c: Restructure to allocate more string space just + before needed. + * mpbsd/min.c: Likewise. + + * longlong.h (__udiv_qrnnd_c): Remove redundant casts. + (32-bit sparc): Test HAVE_HOST_CPU_supersparc in addition to various + sparc_v8 spellings. + +2003-03-17 Kevin Ryde + + * mpfr/*: Update to mpfr cvs 2003-03-17. + +2003-03-15 Kevin Ryde + + * Makefile.am (EXTRA_libgmp_la_SOURCES): Use this for TMP_ALLOC + sources, instead of a libdummy.la. + +2003-03-16 Torbjorn Granlund + + * config.guess: Recognize supersparc and microsparc for *BSD systems. + Generalize some superscalar recognition patterns. + +2003-03-14 Torbjorn Granlund + + * mpn/sparc64/udiv.asm: New file. + +2003-03-13 Torbjorn Granlund + + * mpn/sparc64: Table cycle counts. Update some comments. + + * mpn/powerpc64/divrem_1.asm: New file. + +2003-03-10 Torbjorn Granlund + + * mpn/generic/mul.c (mpn_mul): Don't blindly expect + MUL_KARATSUBA_THRESHOLD to be a constant. + +2003-03-07 Torbjorn Granlund + + * mpn/generic/mul.c (mpn_mul): New operand splitting code for + avoiding cache misses when un >> MUL_KARATSUBA_THRESHOLD > vn. + (MUL_BASECASE_MAX_UN): New #define, default to 500 for now. + +2003-03-07 Kevin Ryde + + * Makefile.am: Put gmp.h and mp.h under $(exec_prefix)/include. + * gmp.texi (Build Options): Add notes on this. + Reported by Vincent Lefèvre. + +2003-03-06 Kevin Ryde + + * configure.in (alpha*-*-* gcc): Add asm option before testing -mcpu, + for the benefit of gcc 2.9-gnupro-99r1 on alphaev68-dec-osf5.1 which + doesn't otherwise put the assembler in the right mode for -mcpu=ev6. + +2003-03-05 Torbjorn Granlund + + * mpn/powerpc32/powerpc-defs.m4: Set up renaming for v registers. + + * mpz/powm.c (redc): Instead of repeated mpn_incr_u invocations, + accumulate carries and add at the end. + (mpz_powm): Trim tp allocation, now as redc doesn't need carry guard. + +2003-02-25 Torbjorn Granlund + + * mpn/x86/pentium4/copyd.asm: Correct header comment. + + * mpn/arm/addmul_1.asm: Correct cycle counts. + * mpn/arm/submul_1.asm: Likewise. + +2003-02-20 Kevin Ryde + + * demos/factorize.c (factor_using_pollard_rho): Test k>0 to avoid + infinite loop if k=0 and gcd!=1 reveals a factor. Reported by John + Pongsajapan. + + * gmp.texi, fdl.texi: Update to FDL version 1.2. + +2003-02-18 Torbjorn Granlund + + * mpn/arm/mul_1.asm: Fix typo introduced in last change. + +2003-02-17 Torbjorn Granlund + + * mpn/ia64/gmp-mparam.h: Retune. + + * mpn/sparc64/copyi.asm: Add some header comments. + * mpn/sparc64/copyd.asm: Likewise. + + * mpn/arm/mul_1.asm: Put vl operand last for umull/umlal. + Add some header comments. + * mpn/arm/addmul_1.asm: Rewrite. + * mpn/arm/submul_1.asm: Rewrite. + * mpn/arm/gmp-mparam.h: Retune. + +2003-02-16 Torbjorn Granlund + + * mpn/arm/copyi.asm: New file. + * mpn/arm/copyd.asm: New file. + +2003-02-16 Kevin Ryde + + * acinclude.m4 (GMP_C_DOUBLE_FORMAT): Tolerate incorrect last data + byte seen on an arm system. + +2003-02-15 Torbjorn Granlund + + * mpn/arm/gmp-mparam.h: Retune. + +2003-02-13 Torbjorn Granlund + + * mpn/powerpc32/750/com_n.asm: Add more cycle counts. + +2003-02-13 Kevin Ryde + + * configure.in (AC_PREREQ): Bump to 2.57. + + * configure.in, acinclude.m4 (GMP_GCC_WA_OLDAS): New macro, applying + -Wa,-oldas only when necessary. + + * configure.in (powerpc*-*-*): Don't use -Wa,-mppc with gcc, it + overrides options recent gcc adds for -mcpu, making generated code + fail to assemble. + + * tune/tuneup.c (mpn_fft_table): Remove definition, it's in mul_fft.c. + +2003-02-12 Torbjorn Granlund + + * mpn/x86/pentium4/sse2/gmp-mparam.h: Retune. + * mpn/x86/k7/gmp-mparam.h: Retune. + * mpn/x86/k6/gmp-mparam.h: Retune. + * mpn/x86/p6/gmp-mparam.h: Retune. + * mpn/x86/p6/mmx/gmp-mparam.h: Retune. + + * tests/mpz/t-mul.c (main): Rewrite FFT testing code. + +2003-02-10 Torbjorn Granlund + + * config.guess: Recognize "power2" systems. + + * mpn/powerpc64/gmp-mparam.h: Fix indentation. + * mpn/power/gmp-mparam.h: Retune. + * mpn/alpha/ev6/nails/gmp-mparam.h: Retune. + * mpn/sparc64/gmp-mparam.h: Retune. + * mpn/pa64/gmp-mparam.h: Retune. + * mpn/sparc32/v8/supersparc/gmp-mparam.h: Retune. + * mpn/sparc32/v8/gmp-mparam.h: Retune. + * mpn/mips64/gmp-mparam.h: Retune. + * mpn/alpha/ev6/gmp-mparam.h: Retune. + * mpn/powerpc32/gmp-mparam.h: Retune. + * mpn/powerpc32/750/gmp-mparam.h: Retune. + * mpn/alpha/ev5/gmp-mparam.h: Retune. + * mpn/m68k/gmp-mparam.h: Retune. + * mpn/cray/gmp-mparam.h: Set GET_STR_PRECOMPUTE_THRESHOLD. + + * configure.in: Undo this, problem doesn't happen any more: + (mips64*-*-*): Pass just -O1 to cc, to work around compiler bug. + +2003-02-03 Kevin Ryde + + * gmp-impl.h (MPN_NORMALIZE, MPN_NORMALIZE_NOT_ZERO): Add parens + around macro parameters. Reported by Jason Moxham. + +2003-02-01 Kevin Ryde + + * gmp.texi (Low-level Functions): No overlap permitted by mpn_mul_n. + Reported by Jason Moxham. + (Formatted Input Strings): Correction to strtoul cross reference + formatting. + (BSD Compatible Functions): Add index entry for MINT. + +2003-01-29 Torbjorn Granlund + + * gmp-impl.h (mpn_mul_fft): Now returns int. + +2003-01-29 Paul Zimmermann + + * mpn/generic/mul_fft.c: Major rewrite. + +2003-01-25 Kevin Ryde + + * config.guess (powerpc*-*-*): Remove $dummy.core file when mfpvr + fails on NetBSD. + (trap): Remove $dummy.core on abnormal termination too. + + * mpfr/*: Update to mpfr cvs 2003-01-25. + +2003-01-24 Torbjorn Granlund + + * mpn/ia64/README: Update cycle counts to match current code. + +2003-01-18 Kevin Ryde + + * mpfr/*: Update to mpfr cvs 2003-01-18. + +2003-01-17 Torbjorn Granlund + + * gmp.texi: Canonicalize URLs. + +2003-01-15 Kevin Ryde + + * gmp.texi (Notes for Particular Systems): Add hardware floating point + precision mode. + + * mpfr/*, configure, aclocal.m4, config.in: Update to mpfr cvs + 2003-01-15. + +2003-01-11 Kevin Ryde + + * mpfr/*: Update to mpfr cvs 2003-01-11. + +2003-01-09 Kevin Ryde + + * mpfr/get_str.c: Update to mpfr cvs 2003-01-09. + + * doc/configuration: Various updates. + +2003-01-06 Torbjorn Granlund + + * mpn/alpha/copyi.asm: Avoid `nop' mnemonic, unsupported on Cray. + * mpn/alpha/copyd.asm: Likewise. + +2003-01-05 Kevin Ryde + + * demos/expr/t-expr.c (check_r): Tolerate mpfr_set_str new return + value. + + * configure, aclocal.m4 (*-*-osf4*, *-*-osf5*): Regenerate with + libtool patch to avoid bash printf option problem when building shared + libraries with cxx. + + * configure.in (pentium4-*-*): Use "-march=pentium4 -mno-sse2" since + sse2 causes buggy code from gcc 3.2.1 and is only supported on new + enough kernels. + + * acinclude.m4 (GMP_PROG_NM): Add some notes about failures, per + report by Krzysztof Kozminski. + + * gmp-h.in (mpz_mdivmod_ui, mpz_mmod_ui): Add parens around "r". + + * gmp-h.in (__GMP_CAST): New macro, clean to g++ -Wold-style-cast. + (GMP_NUMB_MASK, mpz_cmp_si, mpq_cmp_si, mpz_odd_p, mpn_divexact_by3, + mpn_divmod): Use it. Reported by Krzysztof Kozminski. + (mpz_odd_p): No need for the outermost cast to "int". + * tests/cxx/t-cast.cc: New file. + * tests/cxx/Makefile.am: Add it. + +2003-01-04 Kevin Ryde + + * mpfr/set_str.c: Update to mpfr cvs 2003-01-04. + + * demos/expr/exprfra.c (e_mpfr_number): Tolerate recent mpfr_set_str + returning count of characters accepted. + +2003-01-03 Torbjorn Granlund + + * mpn/alpha/copyi.asm: New file. + * mpn/alpha/copyd.asm: New file. + +2003-01-03 Kevin Ryde + + * demos/expr/t-expr.c: Use __gmpfr on some mpfr internals that have + changed. + + * mpfr/*, aclocal.m4, config.in, configure: Update to mpfr cvs + 2003-01-03. + + * gmp.texi (Introduction to GMP): Mention release announcements + mailing list, and put home page and ftp before mailing lists. + +2002-12-28 Torbjorn Granlund + + * mpn/generic/mul_fft.c (mpn_fft_next_size): Simplify. + +2002-12-28 Kevin Ryde + + * acinclude.m4 (M68K_PATTERN): New macro. + (GMP_GCC_M68K_OPTIMIZE): Use it to avoid m6811 and friends. + * configure.in: Ditto. + + * tests/mpz/t-import.c, tests/mpz/t-export.c: Use '\xHH' to avoid + warnings about char overflows. + * acinclude.m4 (GMP_C_DOUBLE_FORMAT): Ditto. + +2002-12-28 Pedro Gimeno + + * randmt.c (randseed_mt, default_state): Fix off-by-one bug on padding. + (randseed_mt): Add ASSERT checking result of mpz_export. + +2002-12-24 Kevin Ryde + + * gmp.texi (Integer Import and Export): Clarify treatment of signs, + reported by Kent Boortz. + + * randmt.c: Use gmp_uint_least32_t. + (randseed_mt): Add nails to mpz_export in case mt[i] more than 32 bits. + + * gmp-impl.h (gmp_uint_least32_t): New typedef, replacing GMP_UINT32. + * configure.in (AC_CHECK_TYPES): Add uint_least32_t. + (AC_CHECK_SIZEOF): Add unsigned short. + +2002-12-22 Kevin Ryde + + * gmp-impl.h (ULONG_PARITY) [generic C]: Mask result to a single bit. + (ULONG_PARITY) [_CRAY, __ia64]: New macros. + * tests/t-parity.c: New test. + * tests/Makefile.am (check_PROGRAMS): Add it. + + * longlong.h (count_trailing_zeros) [ia64]: New macro. + + * tests/t-count_zeros.c (check_various): Remove unused variable "n". + + * mpn/x86/README: Revise notes on PIC, PLT and GOT. + + * demos/perl/GMP.xs, demos/perl/GMP.pm, demos/perl/test.pl: Add "mt" + to GMP::Rand::randstate. + +2002-12-22 Pedro Gimeno + + * randmt.c (randseed_mt): Fix bug that might cause the generator to + return all zeros with certain seeds. Fix WARM_UP==0 case. + (gmp_randinit_mt): Initialize to a known state by default. + (randget_mt): Remove check for uninitialized buffer: no longer needed. + (recalc_buffer): Use ?: instead of two-element array. + + * tests/rand/t-mt.c: New test. + * tests/rand/Makefile.am (check_PROGRAMS): Add it. + +2002-12-21 Kevin Ryde + + * cxx/osdoprnti.cc: Use and rather than + and . No need for . + + * demos/expr/expr.c, demos/expr/exprfa.c, demos/expr/exprfra.c, + demos/expr/exprza.c: Use mp_get_memory_functions, not + __gmp_allocate_func etc. + * demos/expr/t-expr.c: Don't use gmp-impl.h. + (numberof): New macro. + + * gmp-h.in, gmp-impl.h (__gmp_allocate_func, __gmp_reallocate_func, + __gmp_free_func): Move declarations to gmp-impl.h + + * mp_get_fns.c: New file. + * Makefile.am (libgmp_la_SOURCES, libmp_la_SOURCES): Add it. + * gmp-h.in (mp_get_memory_functions): Add prototype. + * gmp.texi (Custom Allocation): Add mp_get_memory_functions, refer to + "free" not "deallocate" function. + * gmpxx.h (struct __gmp_alloc_cstring): Use mp_get_memory_functions, + not __gmp_free_func. + + * gmp-impl.h [__cplusplus]: Add for strlen. + (gmp_allocated_string): Hold length in a field. + * cxx/osdoprnti.cc, cxx/osmpf.cc: Use this. + +2002-12-20 Torbjorn Granlund + + * tests/mpz/t-perfsqr.c (check_sqrt): Print more variables upon + failure. + + * mpn/generic/rootrem.c: In Newton loop, pad qp with leading zero. + +2002-12-19 Torbjorn Granlund + + * mpn/generic/rootrem.c: Allocate 1.585 (log2(3)) times more space + for pp temporary to allow for worst case overestimate of root. + Add some asserts. + + * tests/mpz/t-root.c: Generalize and speed up. + +2002-12-19 Kevin Ryde + + * tests/cxx/t-rand.cc (check_randinit): Add gmp_randinit_mt test. + + * gmp-h.in: Don't bother trying to support Compaq C++ in pre-standard + I/O mode. + * gmp.texi (Notes for Particular Systems): Compaq C++ must be used in + "standard" iostream mode. + +2002-12-18 Torbjorn Granlund + + * mpn/alpha/mod_34lsub1.asm: Add code for big-endian, using existing + little-endian code only if HAVE_LIMB_LITTLE_ENDIAN is defined. + +2002-12-18 Kevin Ryde + + * configure.in (HAVE_LIMB_BIG_ENDIAN, HAVE_LIMB_LITTLE_ENDIAN): New + defines in config.m4. + +2002-12-17 Torbjorn Granlund + + * printf/printffuns.c (gmp_fprintf_reps): Make it actually work + for padding > 256. + +2002-12-17 Kevin Ryde + + * tune/freq.c: Add for memcmp. + + * mpz/pprime_p.c: Use MPN_MOD_OR_MODEXACT_1_ODD. + + * gmp.texi (Formatted Output Strings): %a and %A are C99 not glibc. + (Formatted Input Strings): Type "l" is for double too. Hex floats are + accepted for mpf_t. + (Formatted Input Functions): Describe tightened parse rule, clarify + return value a bit. + + * scanf/doscan.c: Add hex floats, tighten matching to follow C99, for + instance "0x" is no longer acceptable to "%Zi". + Rename "invalid" label to avoid "invalid" variable, SunOS cc doesn't + like them the same. + * tests/misc/t-scanf.c: Update tests. + * tests/misc/t-locale.c (check_input): Don't let "0x" appear from fake + decimal point. + + * config.guess (sparc*-*-*): Look at BSD sysctl hw.model to recognise + ultrasparcs. + + * mpfr/tests/dummy.c: New file. + * mpfr/tests/Makefile.am (libfrtests_a_SOURCES): Add it. + +2002-12-14 Kevin Ryde + + * mpbsd/Makefile.am (nodist_libmpbsd_la_SOURCES): Move these mpz + sources to libmpbsd_la_SOURCES directly, automake 1.7.2 now gets the + ansi2knr setups right for sources in other directories. + + * mpfr/tests/Makefile.am: Add libfrtests.a in preparation for new mpfr. + +2002-12-13 Kevin Ryde + + * mpfr/Makefile.am (mpfr_TEXINFOS, AM_MAKEINFOFLAGS): Allow for + fdl.texi in recent mpfr. + + * configure.in (AC_PROG_EGREP): Ensure this is run outside the Cray + conditional AC_EGREP_CPP. + + * configure.in (alpha*-*-*): Use gcc -Wa,-oldas if it works, to avoid + problems with new compaq "as" on OSF 5.1. + + * mpn/Makefile.am (EXTRA_DIST): Remove Makeasm.am, automake 1.7.2 does + it automatically. + + * acinclude.m4 (AC_LANG_FUNC_LINK_TRY(C)): Remove this hack, fixed by + autoconf 2.57. + + * configure.in (AC_CONFIG_LIBOBJ_DIR): Set to mpfr, for the benefit of + new mpfr using LIBOBJ. + + * configure.in: (AM_INIT_AUTOMAKE): Use "gnu no-dependencies + $(top_builddir)/ansi2knr". + * */Makefile.am (AUTOMAKE_OPTIONS): Remove, now in configure.in. + + * configure, config.in, INSTALL.autoconf: Update to autoconf 2.57. + * */Makefile.in, configure, aclocal.m4, install-sh, mkinstalldirs: + Update to automake 1.7.2. + + * gmp.texi (Build Options): Add hppa64 to cpu types. + (ABI and ISA): Add gcc to hppa 2.0. + (Debugging): Add maximum debuggability config options. + (Language Bindings): Add Arithmos, reported by Johan Vervloet. + (Formatted Output Strings): 128 bits is about 40 digits, ll is only + for long long not long double. + (Formatted Input Strings): ll is only for long long not long double. + + * mpz/divis.c, mpz/divis_ui.c, mpz/cong.c, mpz/cong_ui.c: Allow d=0, + under the rule n==c mod d iff exists q satisfying n=c+q*d. + * gmp.texi (Integer Division): Describe this. + Suggested by Jason Moxham. + +2002-12-13 Pedro Gimeno + + * randlc2x.c (lc): Remove check for seedn < an, which is now + superfluous. Add ASSERT to ensure it's correct. Add ASSERT to check + precondition of __GMPN_ADD. + (gmp_randinit_lc_2exp): Avoid reallocation by allocating one extra bit + for both seed and a. Simplify seedn < p->_cn case. + + * tests/rand/t-lc2exp.c (check_bigs): Test negative seeds. + +2002-12-12 Torbjorn Granlund + + * mpn/pa32/pa-defs.m4 (PROLOGUE_cpu): Zap spurious argument to `.proc'. + Add empty `.callinfo'. + +2002-12-11 Torbjorn Granlund + + * mpn/x86/pentium4/sse2/addmul_1.asm: Don't reuse `ret' symbol for a + label. + +2002-12-11 Kevin Ryde + + * configure.in (hppa*-*-*): Don't use gcc -mpa-risc-2-0 in ABI=1.0. + + * mpn/pa32/pa-defs.m4: New file, arranging for .proc/.procend. + * configure.in (hppa*-*-*): Use it. + + * printf/doprnt.c: Comments on "ll" versus "L". + + * tests/mpz/t-div_2exp.c: Reduce tests, especially the random ones. + +2002-12-11 Torbjorn Granlund + + * mpz/get_d.c (limb2dbl): New macro for conversion to `double'. + Define it to something non-trivial for 64-bit hppa. + * mpq/get_d.c: Likewise. + * mpf/get_d.c: Likewise. + + * mpn/x86/pentium4/sse2/addmul_1.asm: Unroll to save one c/l. + +2002-12-09 Kevin Ryde + + * tune/Makefile.am: Don't use -static under --disable-static, it tends + not to work. + * configure.in (ENABLE_STATIC): New AM_CONDITIONAL. + + * gmp-h.in: Use instead of with Compaq C++ in + pre-standard I/O mode. + + * tests/mpz/t-jac.c, tests/mpz/t-scan.c: Reduce tests. + +2002-12-08 Kevin Ryde + + * configure.in (*-*-ultrix*): Remove forcible --disable-shared, + believe this was a generic problem with libtool, now gone. + +2002-12-08 Torbjorn Granlund + + * gmp-impl.h (USE_LEADING_REGPARM): Disable for PIC code generation. + +2002-12-07 Torbjorn Granlund + + * tests/cxx/t-misc.cc (check_mpq): Use 0/1 for canonical 0 in + mpq_cmp_ui calls. + + * configure.in (hppa2.0*-*-*): Pass +O2 instead of +O3 to work around + compiler bug with mpfr/tests/tdiv. + +2002-12-07 Kevin Ryde + + * configure.in (hppa2.0*-*-* ABI=2.0n): Make -mpa-risc-2-0 optional. + New hppa-level-2.0 test using GMP_HPPA_LEVEL_20 to detect assembler + support for 2.0n. + * acinclude.m4 (GMP_PROG_CC_WORKS): Add code that provokes an error + from gcc -mpa-risc-2-0 if the assembler doesn't know 2.0 instructions. + (GMP_HPPA_LEVEL_20): New macro. + +2002-12-07 Pedro Gimeno + + * gmp-impl.h (gmp_randfnptr_t.randseed_fn) Return void. + (LIMBS_PER_ULONG, MPN_SET_UI): New macros. + (MPZ_FAKE_UI): Rename couple of parameters. + + * randlc2x.c (gmp_rand_lc_struct): _mp_c and _mp_c_limbs replaced + with mpn style _cp and _cn. All callers changed. + (randseed_lc): Fix limbs(seed) > bits_to_limbs(m2exp) case. + Remove return value. + (gmp_randinit_lc_2exp): Attempt to avoid redundant reallocation. + + * randmt.c (mangle_seed): New function by Kevin. + (randseed_mt): Use it instead of mpz_powm, for performance. Remove + return value. Remove commented out code (an inferior alternative to + mpz_export). + + * randsdui.c (gmp_randseed_ui): Use MPZ_FAKE_UI. + + * tests/rand/t-lc2exp.c (check_bigm, check_bigs): New tests. + * tests/rand/t-urndmm.c: Add L to constants in calls, for K&R. + +2002-12-06 Torbjorn Granlund + + * configure.in: Remove -g. + (hppa*-*-*): Pass -Wl,+vnocompatwarnings with +DA2.0. + +2002-12-05 Torbjorn Granlund + + * mpn/pa64/sqr_diagonal.asm: Remove .entry, .proc, .procend. + * mpn/pa64/udiv.asm: Likewise. + +2002-12-05 Kevin Ryde + + * mpn/pa64/sub_n.asm: Remove space in "sub, db" which gas objects to. + * mpn/pa64/*.asm, tune/hppa2.asm: Use ".level 2.0" for 2.0n, since gas + doesn't like ".level 2.0N". + + * configure.in (hppa*-*-*): Group path and flags choices, for clarity. + (hppa1.0*-*-*): Use gcc -mpa-risc-1-0 when available. + (hppa2.0*-*-*): Ditto -mpa-risc-2-0. + (*-*-hpux*): Exclude ABI=2.0w for hpux[1-9] and hpux10, rather than + the converse of allowing it for hpux1[1-9]; ie. list the bad systems + rather than try to guess the good systems. + (hppa2.0*-*-*) [ABI=2.0n ABI=2.0w]: Add gcc to likely compilers. + (hppa*-*-*) [gcc]: Test sizeof(long) to differentiate a 32-bit or + 64-bit build of the compiler. + (hppa64-*-*): Add this as equivalent to hppa2.0-*-*. + * acinclude.m4 (GMP_C_TEST_SIZEOF): New macro. + + * tests/tests.h (ostringstream::str): Must null-terminate + ostrstream::str() for the string constructor. + +2002-12-04 Torbjorn Granlund + + * mpn/pa32/hppa1_1/udiv.asm: Don't wrap symbol to INT64 in L() stuff. + + * longlong.h (mpn_udiv_qrnnd_r based udiv_qrnnd): Fix typo. + + * mpn/powerpc32/powerpc-defs.m4: Define float registers with `f' + prefix. + +2002-12-04 Kevin Ryde + + * gmp.texi (Floating-point Functions): Note the mantissa is binary and + decimal fractions cannot be represented exactly. Suggested by Serge + Winitzki. + (Known Build Problems): Note libtool stripping options when linking. + Reported by Vincent Lefevre. + + * acinclude.m4 (GMP_ASM_LABEL_SUFFIX): Don't make an empty result a + failure, that's a valid result. + (GMP_ASM_GLOBL): Establish this from the host cpu type. + (IA64_PATTERN): New macro. + (GMP_PROG_EXEEXT_FOR_BUILD, GMP_C_FOR_BUILD_ANSI, + GMP_CHECK_LIBM_FOR_BUILD): Remove temporary files created. + * configure.in: Use IA64_PATTERN. + +2002-12-03 Torbjorn Granlund + + * tune/hppa.asm: Use config.m4. + * tune/hppa2.asm: Likewise. + * tune/hppa2w.asm: Likewise. + + * mpn/pa64: Use LDEF. + +2002-12-03 Kevin Ryde + + * INSTALL: Use return rather than exit in the example programs. + Suggested by Richard Dawe. + + * gmp.texi (Build Options): Move non-unix notes to ... + (Notes for Particular Systems): ... here. Mention MS Interix, + reported by Paul Leyland. + (C++ Interface Random Numbers): Add gmp_randinit_mt to examples. + + * acinclude.m4 (GMP_ASM_LABEL_SUFFIX): Must test empty suffix first, + for the benefit of hppa hp-ux. + (GMP_ASM_UNDERSCORE): Grep the output of "nm" instead of trying to + construct an asm file, and in case of failure fallback on no + underscore and a warning. + + * longlong.h (count_leading_zeros, count_trailing_zeros) [ev67, ev68]: + Restrict __asm__ ctlz and cttz to __GNUC__. + + * gen-psqr.c (HAVE_CONST, const): New macros. + + * tests/cxx/t-rand.cc (check_randinit): Add gmp_randinit_mt. + +2002-12-02 Torbjorn Granlund + + * gmp-impl.h: Split popc_limb again, combined version gives too many + compiler warnings. + +2002-12-01 Torbjorn Granlund + + * mpn/generic/gcdext.c (div1): Disable unused function. + + * mpz/root.c: Don't include stdlib.h or longlong.h. + * mpz/rootrem.c: Likewise. + + * extract-dbl.c: abort => ASSERT_ALWAYS. + * mpz/set_d.c: Likewise. + * mpn/generic/tdiv_qr.c: Likewise. + + * gen-psqr.c (f_cmp_fraction, f_cmp_divisor): Change parameter to + `const void *', to match qsort spec. + +2002-12-01 Kevin Ryde + + * gmp.texi (Integer Division): Fix a couple of @math's for tex. + Use @dots in more places. + + * tests/cxx/t-locale.cc: Test non std::locale systems too. + * tests/cxx/clocale.c: New file, reinstating what was localeconv.c, + and subverting nl_langinfo too. + * tests/cxx/Makefile.am (t_locale_SOURCES): Add it. + + * tests/tests.h (ostringstream, istringstream): Provide fakes of these + if not available. + * tests/cxx/t-locale.cc, tests/cxx/t-ostream.cc: Remove . + * configure.in (AC_CHECK_HEADERS) [C++]: Add . + +2002-11-30 Torbjorn Granlund + + * printf/doprnt.c (__gmp_doprnt): Comment out a `break' to shut up + compiler warnings. + + * mpn/ia64/invert_limb.asm: Add `many' hints to return insns. + + * mpn/ia64/divrem_1.asm: Allocate more local registers; put b0 in + one of them. + + * mpn/ia64/popcount.asm: Properly restore register ar.lc. + + * longlong.h (umul_ppmm) [ia64]: Form both product parts in asm. + + * mpz/bin_uiui.c: Cast umul_ppmm operands. + + * scanf/doscan.c (gmpscan): Remove unused label store_get_digits. + + * gmp-impl.h: #undef MIN and MAX before #defining. + + * mpn/ia64/copyi.asm: Add `;' after bundle declarators. + * mpn/ia64/copyd.asm: Likewise. + + * mpn/ia64/divrem_1.asm: Add some syntax to placid the HP-UX assembler. + +2002-11-30 Kevin Ryde + + * configure.in (AC_CHECK_HEADERS): Add nl_types.h. + * tests/misc/t-locale.c: Use this, for nl_item on netbsd 1.4.1. + +2002-11-29 Torbjorn Granlund + + * tests/devel/addmul_1.c: Provide prototype for mpn_print. + (OPS): Account for function overhead. + * tests/devel/{submul_1.c,mul_1.c,add_n.c,sub_n.c}: Likewise. + + * mpn/ia64/addmul_1.asm: Rewrite. + +2002-11-28 Torbjorn Granlund + + * mpn/ia64/sqr_diagonal.asm: Don't allocate any registers. + + * mpn/ia64/submul_1.asm: Adapt to Itanium 2. + + * mpn/ia64/mul_1.asm: Fix typo in HAVE_ABI_32 code. + + * mpn/ia64/add_n.asm: Rewrite. + * mpn/ia64/sub_n.asm: Rewrite. + +2002-11-28 Kevin Ryde + + * mpn/Makefile.am (nodist_EXTRA_libmpn_la_SOURCES): Use this rather + than libdummy. + * tests/Makefile.am (EXTRA_libtests_la_SOURCES): Use this for + x86call.asm and x86check.c rather than libdummy. + +2002-11-27 Torbjorn Granlund + + * tests/mpz/t-mul.c: Implement reference Karatsuba multiplication. + Rewrite testing scheme to run fewer really huge tests. + +2002-11-26 Torbjorn Granlund + + * tests: Decrease repetition count for some of the slowest tests. + + * mpn/ia64/divrem_1.asm: New file. + +2002-11-25 Torbjorn Granlund + + * mpfr/tests/tdiv.c: Decrease number of performed tests. + +2002-11-23 Torbjorn Granlund + + * mpn/ia64/mul_1.asm: Rewrite. + +2002-11-23 Kevin Ryde + + * mpn/ia64/README: Add some references. + + * gmp.texi (Build Options): Add itanium and itanium2, mention DocBook + and XML from makeinfo, add texinfo top level cross reference. + (Integer Division): Try to clarify 2exp functions a bit. + (C++ Interface Floats): Giving bad string to constructor is undefined. + (C++ Interface Integers, C++ Interface Rationals): Ditto, and show + default base in prototype, not the description. + + * config.sub, config.guess, configure.in (itanium, itanium2): New cpu + types. + + * tests/misc/t-printf.c, tests/misc/t-scanf.c (check_misc): Suppress + %zd test on glibc prior to 2.1, it's not supported. + +2002-11-22 Torbjorn Granlund + + * mpn/ia64/copyi.asm: Optimize for Itanium 2. + * mpn/ia64/copyd.asm: Likewise. + +2002-11-20 Torbjorn Granlund + + * mpn/ia64/sqr_diagonal.asm: New file. + + * mpn/ia64/submul_1.asm: Handle vl == 0 specially. + +2002-11-20 Kevin Ryde + + * tests/cxx/t-locale.cc: Test with locales imbued into stream, use + , eliminated some C-isms. istream tests disabled, not yet + locale-ized. + * tests/cxx/Makefile.am (t_locale_SOURCES): Remove localeconv.c. + * tests/cxx/localeconv.c: Remove file. + + * configure.in (AC_CHECK_TYPES) [C++]: Add std::locale. + * printf/doprntf.c: Add decimal point parameter, remove localeconv use. + * gmp-impl.h (__gmp_doprnt_mpf): Update prototype, bump symbol to + __gmp_doprnt_mpf2 to protect old libgmpxx. + * cxx/osmpf.cc: Use this with ostream locale decimal_point facet. + * printf/doprnt.c: Ditto, with GMP_DECIMAL_POINT. + + * gmp-h.in: More comments on __declspec for windows DLLs. + + * mpf/set_str.c, scanf/doscan.c: Cast through "unsigned char" for + decimal point string, same as input chars. + + * configure.in (AC_CHECK_HEADERS): Add langinfo.h. + (AC_CHECK_FUNCS): Add nl_langinfo. + * gmp-impl.h (GMP_DECIMAL_POINT): New macro. + * mpf/out_str.c, mpf/set_str.c, scanf/doscan.c: Use it, and don't + bother with special code for non-locale systems. + * tests/misc/t-locale.c: Subvert nl_langinfo too. + + * configure.in, acinclude.m4 (GMP_ASM_X86_GOT_UNDERSCORE): New macro. + * mpn/x86/x86-defs.m4 (_GLOBAL_OFFSET_TABLE_): New macro, inserting + extra underscore for OpenBSD. + * mpn/x86/README (_GLOBAL_OFFSET_TABLE_): Update notes. + Reported by Christian Weisgerber. + + * tests/cxx/t-rand.cc (check_randinit): New function, collecting up + constructor tests. + + * tests/cxx/t-ostream.cc: Use instead of , use + compare instead of strcmp. + + * gmpxx.h (__gmp_randinit_lc_2exp_size_t): Return type is int. + +2002-11-18 Kevin Ryde + + * tune/speed.c (r_string): Use CNST_LIMB with bits, spotted by + Torbjorn. + +2002-11-19 Torbjorn Granlund + + * mpn/ia64/mul_1.asm: Remove redundant cmp from prologue code. + Streamline prologue. + * mpn/ia64/addmul_1.asm: Likewise. + * mpn/ia64/submul_1.asm: New file. + * mpn/ia64/submul_1.c: Remove. + +2002-11-17 Torbjorn Granlund + + * mpn/generic/popham.c: New file, using new faster algorithm. + * mpn/generic/popcount.c: Remove. + * mpn/generic/hamdist.c: Remove. + + * mpn/ia64/addmul_1.asm: Don't clobber callee-saves register f16. + * mpn/ia64/mul_1.asm: Likewise. + + * mpn/ia64/addmul_1.asm: Add pred.rel declarations. Resolve RAW + hazards for condition code registers, duplicating code as needed. Add + prediction to all branches. + * mpn/ia64/mul_1.asm: Likewise. + * mpn/ia64/add_n.asm: Likewise. + * mpn/ia64/sub_n.asm: Likewise. + * mpn/ia64/copyi.asm: Likewise. + * mpn/ia64/copyd.asm: Likewise. + + * mpn/generic/random2.c: Add a cast to silence some compilers. + +2002-11-16 Torbjorn Granlund + + * mpz/powm.c: Cap allocation by limiting k to 10 (512 precomputed + values). + +2002-11-16 Kevin Ryde + + * configure.in, gmp.texi: Remove powerpc64 ABI=32L, doesn't work and + is unlikely to ever do so. + * configure.in: Allow ABI=32 for powerpc64. + Reported by David Edelsohn. + +2002-11-14 Kevin Ryde + + * mpn/Makefile.am (nodist_libdummy_la_SOURCES): Add addmul_2.c + addmul_3.c addmul_4.c addmul_5.c addmul_6.c addmul_7.c addmul_8.c. + + * gmp-h.in (__GMP_DECLSPEC_EXPORT, __GMP_DECLSPEC_IMPORT) [__GNUC__]: + Use __dllexport__ and __dllimport__ to keep out of application + namespace. + +2002-11-14 Gerardo Ballabio + + * gmpxx.h (__gmp_randinit_default_t, __gmp_randinit_lc_2exp_t, + __gmp_randinit_lc_2exp_size_t): Use extern "C" { typedef ... }, for + the benefit of g++ prior to 3.2. + +2002-11-12 Kevin Ryde + + * gmpxx.h (gmp_randclass constructors): Patch from Roberto Bagnara to + use extern "C" on C function pointer arguments. + +2002-11-09 Kevin Ryde + + * configure.in, Makefile.am, printf/Makefile.am, + printf/repl-vsnprintf.c: Handle vsnprintf replacement with C + conditionals. + + * acinclude.m4 (AC_LANG_FUNC_LINK_TRY(C)): Workaround troubles recent + HP cc +O3 causes for AC_CHECK_FUNCS. + + * gmp.texi (Notes for Particular Systems): Add Sparc app regs. + (Debugging): Note gcc -fstack options to detect overflow. + (Formatted Output Strings, Formatted Input Strings): Format strings + are not multibyte. + +2002-11-06 Torbjorn Granlund + + * mpn/generic/tdiv_qr.c: Remove a bogus assert. + +2002-11-05 Torbjorn Granlund + + * mpn/generic/tdiv_qr.c: Remove two dead mpn_divrem_2 calls. + +2002-11-04 Kevin Ryde + + * acinclude.m4 (GMP_C_INLINE): Don't define "inline" for C++. + + * demos/expr/expr-impl.h (stdarg.h): Test __DECC same as gmp.h. + + * mpbsd/mtox.c, printf/obprintf.c, printf/obvprintf.c, + scanf/vsscanf.c, demos/expr/expr.c, demos/expr/exprf.c, + demos/expr/exprfa.c, demos/expr/exprfr.c, demos/expr/exprq.c, + demos/expr/exprz.c, demos/expr/exprza.c: Add for strlen and + memcpy. + +2002-11-02 Kevin Ryde + + * longlong.h: Test __x86_64__ not __x86_64. Reported by Andreas + Jaeger. + + * mpz/import.c, mpz/export.c: Use char* subtract from NULL to get + pointer alignment, for the benefit of Cray vector systems. + + * cxx/ismpf.cc: Use . + * tests/cxx/t-locale.cc: No need to conditionalize . + + * scanf/doscan.c: Don't use isascii, rely on C99 ctype.h. + + * gmp.texi (Build Options): Describe CC_FOR_BUILD, cross reference + texinfo manual. + (ABI and ISA): Add powerpc620 and powerpc630 to powerpc64, add NetBSD + and OpenBSD sparc64. + (Notes for Package Builds): Cross reference libtool manual. + (Notes for Particular Systems): Add OpenBSD to non-MMX versions of gas. + (Known Build Problems): Add MacOS X C++ shared libraries. + +2002-10-31 Kevin Ryde + + * gmp-impl.h, tune/speed.c, tune/speed.h, tune/common.c, tune/many.pl, + tests/devel/try.c, tests/tests.h, tests/refmpn.c (mpn_addmul_5, + mpn_addmul_6, mpn_addmul_7, mpn_addmul_8): Add testing and measuring. + * configure.in (config.in): Add #undefs of HAVE_NATIVE_mpn_addmul_5, + HAVE_NATIVE_mpn_addmul_6, HAVE_NATIVE_mpn_addmul_7, + HAVE_NATIVE_mpn_addmul_8. + (gmp_mpn_functions_optional): Add addmul_5 addmul_6 addmul_7 addmul_8. + + * tests/devel/try.c (ASSERT_CARRY): Remove, now in gmp-impl.h + (try_one): Do dest setups after sources, for benefit of + dst0_from_src1. + +2002-11-01 Torbjorn Granlund + + * mpn/generic/tdiv_qr.c: Avoid quadratic behaviour for + sub-division when numerator is more than twice the size of the + denominator. Simplify loop logic for the same case. Clean up a + few comments. + +2002-10-29 Torbjorn Granlund + + * configure.in (*-cray-unicos*): Pass -hnofastmd again. + +2002-10-25 Torbjorn Granlund + + * tests/tadd.c: Disable test of denorms. + +2002-10-23 Linus Nordberg + + * gmp.texi (Introduction to GMP): Update section about mailing + lists. + +2002-10-23 Kevin Ryde + + * gmp-h.in (__GMP_ATTRIBUTE_PURE): Suppress this when + __GMP_NO_ATTRIBUTE_CONST_PURE is defined. + * gmp-impl.h (ATTRIBUTE_CONST): Ditto. + * tune/common.c: Use __GMP_NO_ATTRIBUTE_CONST_PURE. + + * tune/speed.h, tune/many.pl: Remove ATTRIBUTEs from prototypes. + * tune/speed.h: Remove various "dummy" variables attempting to keep + "pure" calls live, no longer necessary. They weren't sufficient for + recent MacOS cc anyway. + +2002-10-21 Torbjorn Granlund + + * mpn/cray/ieee/addmul_1.c: Handle overlap as in mul_1.c. + * mpn/cray/ieee/submul_1.c: Likewise. + +2002-10-19 Kevin Ryde + + * configure.in (sparcv9 etc -*-*bsd*): Add support for NetBSD and + OpenBSD sparc64. Reported by Christian Weisgerber. + (AC_CHECK_HEADERS): Add sys/param.h for sys/sysctl.h on *BSD. + + * demos/calc/calc.y: Change ={ to {, needed for bison 1.50. + + * longlong.h (count_leading_zeros, count_trailing_zeros) [x86_64]: + Should be UDItype. + + * mpz/set_str.c, mpf/set_str.c, mpbsd/xtom.c, scanf/sscanffuns.c: Cast + chars through "unsigned char" to zero extend, required by C99 ctype.h. + +2002-10-18 Torbjorn Granlund + + * tests/mpz/t-root.c: Test also mpz_rootrem. + + * mpn/generic/rootrem.c: Avoid overflow problem when n is huge. + + * mpz/root.c: Avoid overflow problems in allocation computation; also + simplify it. Misc cleanups. + + * mpz/rootrem.c: New file. + * Makefile.am, mpz/Makefile.am, gmp-h.in: Add them. + +2002-10-17 Torbjorn Granlund + + * gmp-impl.h (popc_limb): Combine variants. + +2002-10-14 Kevin Ryde + + * configure.in (AC_CHECK_HEADERS): Add sys/time.h for sys/resource.h + test, needed by SunOS, and next autoconf will insist headers actually + compile. + +2002-10-08 Kevin Ryde + + * tune/time.c (speed_time_init): Allow for Cray times() apparently + being a cycle counter. + + * dumbmp.c (mpz_get_str): Fix buf size allocation. + + * tests/trace.c, tests/tests.h (mp_limb_trace): New function. + + * tune/speed-ext.c (SPEED_EXTRA_PROTOS): Use __GMP_PROTO. + * tests/devel/try.c (malloc_region): Add a cast for SunOS cc. + + * configure.in (AC_CHECK_FUNCS): Add strerror. + (AC_CHECK_DECLS): Add sys_errlist, sys_nerr. + * tune/time.c, tests/devel/try.c: Use them. + +2002-10-05 Kevin Ryde + + * configure.in (AC_CHECK_HEADERS): Test float.h, not in SunOS cc. + * printf/repl-vsnprintf.c: Use this. + + * configure.in (*sparc*-*-*): Collect up various options for clarity, + use gcc -mcpu=supersparc and ultrasparc3, use cc -xchip, don't use + -xtarget=native, use cc configs with acc, merge SunOS bundled cc and + SunPRO cc configs. + + * gmp-impl.h (gmp_randfnptr_t): Use __GMP_PROTO. + (MPZ_REALLOC): Cast _mpz_realloc return value to mp_ptr, for the + benefit of SunOS cc which requires pointers of the same type on the + two legs of a ?:. + + * dumbmp.c (mpz_realloc): Add a cast to avoid a warning from SunOS cc. + + * acinclude.m4: Allow for i960 b.out default cc output. + + * gmp.texi (Random State Initialization): Add gmp_randinit_mt. + (Perfect Square Algorithm): Describe new mpn_mod_34lsub1 use. + (Factorial Algorithm): Describe Jason's new code. + (Binomial Coefficients Algorithm): Ideas about improvements + moved to doc/projects.html. + (Contributors): Add Jason Moxham and Pedro Gimeno. + +2002-10-03 Kevin Ryde + + * gen-psqr.c: New file. + * Makefile.am, mpn/Makefile.am: Use it to generate mpn/perfsqr.h. + * mpn/generic/perfsqr.c: Use generated data, put mod 256 data into + limbs to save space, use mpn_mod_34lsub1 when good. + * tests/mpn/t-perfsqr.c: New file. + * tests/mpn/Makefile.am (check_PROGRAMS): Add it. + * tests/mpz/t-perfsqr.c (check_modulo): New test. + (check_sqrt): New function holding current tests. + + * configure.in (AC_INIT): Modernize to package name and version here + rather than AM_INIT_AUTOMAKE, add bug report email. + (AC_CONFIG_SRCDIR): New macro. + + * gmp-impl.h (ROUND_UP_MULTIPLE): Fix for non-power-of-2 moduli (not + normal in current uses), clarify the comments a bit. + +2002-09-30 Kevin Ryde + + * mpn/Makeasm.am (.s.lo): Add --tag=CC for the benefit of CCAS!=CC, + same as .S.lo and .asm.lo. + + * Makefile.am (gen-fac_ui, gen-fib, gen-bases): Quote source files in + test -f stuff to avoid Sun make rewriting them. + +2002-09-28 Kevin Ryde + + * tests/devel/try.c, tune/speed.c: Avoid strings longer than C99 + guarantees. + + * tests/refmpn.c, tests/tests.h (refmpn_zero_extend, refmpn_normalize, + refmpn_sqrtrem): New functions. + * tests/devel/try.c (TYPE_SQRTREM): Use refmpn_sqrtrem. + (compare): Correction to tr->dst_size subscripting. + + * dumbmp.c: Add several new functions, allow for initial n + + * dumbmp.c (mpz_pow_ui, mpz_addmul_ui, mpz_root): New functions. + * gen-fac_ui.c: New file. + * mpz/fac_ui.c: Rewrite. + +2002-09-26 Kevin Ryde + + * tests/cxx/localeconv.c: New file, split from t-locale.cc. + * tests/cxx/t-locale.cc: Use it. + * tests/cxx/Makefile.am (t_locale_SOURCES): Add it. + + * tests/cxx/Makefile.am: Updates for Gerardo's new test programs. + +2002-09-26 Gerardo Ballabio + + * gmpxx.h (__gmp_cmp_function): Bug fixes in double/mpq and + double/mpfr comparisons. + + * tests/cxx/t-assign.cc, tests/cxx/t-binary.cc, tests/cxx/t-constr.cc, + tests/cxx/t-ternary.cc, tests/cxx/t-unary.cc: Revise and add various + tests, including some for mpfr, some split from t-expr.cc. + * tests/cxx/t-locale.cc: Modernize include files. + * tests/cxx/t-ostream.cc: Modernize include files, use cout rather + than printf for diagnostics. + * tests/cxx/t-misc.cc, tests/cxx/t-rand.cc: New file, split from + t-allfuns.cc. + * tests/cxx/t-ops.cc: New file, some split from t-allfuns.cc. + * tests/cxx/t-prec.cc: New file. + * tests/cxx/t-allfuns.cc, tests/cxx/t-expr.cc: Remove files. + +2002-09-25 Torbjorn Granlund + + * configure.in (*-cray-unicos*): Remove -hscalar0, it causes too much + performance loss. Let's trust Cray to fix their compilers. + +2002-09-24 Torbjorn Granlund + + * mpn/powerpc32/add_n.asm: Rewrite. + * mpn/powerpc32/sub_n.asm: Rewrite. + +2002-09-24 Pedro Gimeno + + * randlc2x.c: Prepare for nails by changing type of _mp_c to mpz_t, + make _mp_seed fixed-size, disallow SIZ(a)==0 to optimize comparisons + for mpn_mul. + * gmp-impl.h (MPZ_FAKE_UI): New macro. + + * randmt.c: Some constants made long for K&R compliance; remove UL at + the end of other constants; use mp_size_t where appropriate; use + mpz_export to split the seed. + + * gmp-impl.h: Remove type cast in RNG_FNPTR and RNG_STATE, to allow + them to be used as lvalues. + * randclr.c, randlc2x.c, randmt.c, randsd.c: All callers changed. + + * mpz/urandomm.c: Replace mpn_cmp with MPN_CMP. + + * tests/rand/gen.c: Get rid of gmp_errno. + +2002-09-24 Kevin Ryde + + * gmp.texi (Custom Allocation): Keep allocate_function etc out of the + function index by using @deftypevr. + More index entries. + +2002-09-24 Gerardo Ballabio + + * gmpxx.h (mpfr_class constructors from strings): Precision was set + incorrectly, fixed. + +2002-09-23 Torbjorn Granlund + + * mpf/urandomb.c: Don't crash for overlarge nbits argument. + Let nbits==0 mean to fill number with random bits. + +2002-09-21 Torbjorn Granlund + + * mpn/alpha/mod_34lsub1.asm: Add r31 dummy operand to `br' instruction. + +2002-09-20 Gerardo Ballabio + + * gmpxx.h (__gmp_binary_equal, __gmp_binary_not_equal): Fix broken + mpq/double functions. + +2002-09-18 Torbjorn Granlund + + * randmt.c (randget_mt): Fix typo. + +2002-09-18 Kevin Ryde + + * gmp-impl.h (_gmp_rand): Avoid evaluating "state" more than once, for + the benefit places calling it with RANDS. + + * randmt.c (randseed_mt): Use mpz_init for mod and seed1, for safety. + + * tune/tuneup.c (sqr_karatsuba_threshold): Initialize to + TUNE_SQR_KARATSUBA_MAX so mpn_sqr_n works for randmt initialization. + + * gmp.texi (Integer Comparisons): Remove mention of non-existent + mpz_cmpabs_si, reported by Conrad Curry. + + * tune/speed.c, tune/speed.h, tune/common.c: Add gmp_randseed, + gmp_randseed_ui and mpz_urandomb. + +2002-09-18 Pedro Gimeno + + * tests/rand/gen.c: Add mt, remove lc and bbs. + + * Makefile.am (libgmp_la_SOURCES): Add randmt.c, remove randlc.c and + randraw.c. + + * randmt.c: New file. + * gmp-h.in (gmp_randinit_mt): Add prototype. + * randdef.c: Use gmp_randinit_mt. + + * gmp-impl.h (RNG_FNPTR, RNG_STATE): New macros. + (gmp_randfnptr_t): New structure. + (_gmp_rand): Now a macro not a function. + * gmp-h.in (__gmp_randata_lc): Remove, now internal to randlc2x.c. + (__gmp_randstate_struct): Revise comments on field usage. + * randsd.c, randclr.c: Use function pointer scheme. + * randsdui.c: Use gmp_randseed. + * randraw.c: Remove file. + * randlc2x.c: Collect up lc_2exp related code from randsd.c, randclr.c + and randraw.c, use function pointer scheme, integrate seed==0/a==0 + into main case and fix case where bits(a) < m2exp. + + * randlc.c: Remove file, never documented and never worked. + * gmp-h.in (gmp_randinit_lc): Remove prototype. + +2002-09-16 Torbjorn Granlund + + * mpn/alpha/mod_34lsub1.asm: New file. + +2002-09-16 Kevin Ryde + + * configure.in, acinclude.m4 (GMP_C_RESTRICT): Remove this, not + currently used, and #define restrict upsets Microsoft C headers on + win64. Reported by David Librik. + + * configure.in (x86): Add gcc 3.2 -march and -mcpu flags, remove some + unnecessary -march=i486 fallbacks. + + * gmp.texi (Notes for Particular Systems): Note cl /MD is required for + Microsoft C and MINGW to cooperate on I/O. Explained by David Librik. + (Language Bindings): Add linbox. + * gmp.texi (Language Bindings): + +2002-09-12 Kevin Ryde + + * mpz/aorsmul_i.c: Allow for w==x overlap with nails. Test + BITS_PER_ULONG > GMP_NUMB_BITS rather than GMP_NAIL_BITS != 0. + * tests/mpz/t-aorsmul.c: Test this. + + * tune/common.c: mpn_mod_34lsub1 only exists for GMP_NUMB_BITS%4==0 + * tune/speed.c: Add mpn_mod_34lsub1. + +2002-09-10 Pedro Gimeno + + * rand.c: Remove old disabled BBS code. + * mpf/urandomb.c: Use BITS_TO_LIMBS. + +2002-09-10 Kevin Ryde + + * gmp.texi (Multiplication Algorithms): FFT is now enabled by default. + +2002-09-10 Pedro Gimeno + + * mpz/urandomm.c: Use mpn level functions, avoid an infinite loop if + _gmp_rand forever returns all "1" bits. + * tests/rand/t-urndmm.c: New file + * tests/rand/Makefile.am (check_PROGRAMS): Add it. + + * gmp-impl.h (BITS_TO_LIMBS): New macro. + * mpz/urandomb.c: Use it, and use MPZ_REALLOC. + +2002-09-08 Kevin Ryde + + * acinclude.m4 (GMP_GCC_WA_MCPU): New macro. + * configure.in (alpha*-*-*): Use it to avoid -Wa,-mev67 if gas isn't + new enough to know ev67. Reported by David Bremner. + +2002-07-30 Gerardo Ballabio + + * gmpxx.h (__gmpz_value etc): Remove, use mpz_t etc instead. + (__gmp_expr): Reorganise specializations, use __gmp_expr not + mpz_class etc. + (mpfr evals): Remove mode parameter, was always + __gmp_default_rounding_mode anyway. + +2002-09-07 Kevin Ryde + + * gmp-h.in, mp-h.in: Use #ifdef for tests, for the benefit of + applications using gcc -Wundef. + + * longlong.h: Define COUNT_LEADING_ZEROS_NEED_CLZ_TAB for all alphas, + since mpn/alpha/cntlz.asm always goes into libgmp.so, even for ev67 + and ev68 which don't need it. Reported by David Bremner. + + * gmp.texi (Demonstration Programs): New section, expanding on what + was under "Build Options". + (Converting Floats): Don't need \ for _ in @var within @math. + Add and amend various index entries. + + * demos/qcn.c: Add -p prime limit option. + +2002-08-30 Kevin Ryde + + * mpz/pprime_p.c: Handle small negatives with isprime, in particular + must do so for n==-2. + * tests/mpz/t-pprime_p.c: New file. + * tests/mpz/Makefile.am: Add it. + +2002-08-26 Torbjorn Granlund + + * gmp.texi (Converting Floats): Fix typo in mpf_get_d_2exp docs, + reported by Paul Zimmermann. + +2002-08-26 Kevin Ryde + + * configure.in: Echo the ABI being tried for the compilers. + (powerpc*-*-*): Use powerpc64/aix.m4 for ABI=aix64 too. + (AC_CHECK_FUNCS): Add strtol, for tests/rand/gen.c. + +2002-08-24 Kevin Ryde + + * configure.in (HAVE_HOST_CPU_, HAVE_HOST_CPU_FAMILY_, HAVE_NATIVE_): + Setup templates for these using AH_VERBATIM rather than acconfig.h, + preferred by latest autoconf. Prune lists to just things used. + * acconfig.h: Remove file. + + * mpn/powerpc32/mode1o.asm: Forgot ASM_START. + + * tune/time.c (have_cgt_id): Renamed from HAVE_CGT_ID so avoid + confusion with autoconf outputs, and turn it into a "const" variable. + +2002-08-23 Torbjorn Granlund + + * configure.in: Choose powerpc32/aix.m4 or powerpc64/aix.m4 based on + ABI, not configuration triple. + + * mpz/pprime_p.c: Partially undo last change--handle small and + negative numbers in the same test. + +2002-08-22 Kevin Ryde + + * gmp-impl.h (MUL_FFT_THRESHOLD, SQR_FFT_THRESHOLD): Note + mpn/generic/mul_fft.c is not nails-capable, and don't bother setting + other FFT data for nails. + + * configfsf.guess: Update to 2002-08-19. + * configfsf.sub: Update to 2002-08-20. + + * config.guess (powerpc*-*-*): Use a { } construct to suppress SIGILL + message on AIX. + +2002-08-20 Kevin Ryde + + * gmp.texi (Build Options): Add ia64 under cpu types. + (ABI and ISA): Describe IRIX 6 ABI=o32. + (Notes for Particular Systems): Remove -march=pentiumpro, now ok. + (Known Build Problems): Binutils 2.12 is ok for libgmp.a. + (Emacs): New section. + (Language Bindings): Update MLton URL, reported by Stephen Weeks. + (Prime Testing Algorithm): New section. + Don't put a blank line after @item in @table since it can make a page + break between the heading and the entry. + Misc tweaks elsewhere, in particular more index entries. + + * mpz/millerrabin.c: Need x to be size+1 for change to urandomm. + + * gmp-impl.h: Comments on the use of __GMP_DECLSPEC. + + * tune/time.c (freq_measure_mftb_one): Use struct_timeval, for the + benefit of mingw. + + * tests/refmpn.c, tests/tests.h (ref_addc_limb, ref_subc_limb): + Renamed from add and sub, following gmp-impl.h ADDC_LIMB and SUBC_LIMB. + +2002-08-17 Kevin Ryde + + * mpn/powerpc32/mode1o.asm: New file. + * configure.in, acinclude.m4 (GMP_ASM_POWERPC_PIC_ALWAYS): New macro. + * mpn/asm-defs.m4: Use it to help setting up PIC. + + * configure.in (AC_PREREQ): Bump to 2.53. + + * mpn/powerpc32/powerpc-defs.m4 (ASSERT): New macro. + (PROLOGUE_cpu): New macro, giving ALIGN(4) not 8. + +2002-08-16 Torbjorn Granlund + + * mpn/m68k/lshift.asm: Fix typo in !scale_available_p code. + * mpn/m68k/rshift.asm: Likewise. + +2002-08-16 Kevin Ryde + + * configure.in (--enable-profiling=instrument): New option. + * gmp.texi (Profiling): Describe it. + * mpn/x86/x86-defs.m4 (PROLOGUE_cpu, call_instrument, ret_internal): + Add support. + (call_mcount): Share PIC setups with call_instrument. + * mpn/x86/*.asm: Use ret_internal. + * mpn/asm-defs.m4 (m4_unquote): New macro. + * tests/mpn/t-instrument.c: New file. + * tests/mpn/Makefile.am: Add it. + + * mpn/alpha/umul.asm: Add ASM_END. + +2002-08-12 Kevin Ryde + + * mpz/pprime_p.c: Fake up a local mpz_t to take abs(n), rather than + using mpz_init etc. + + * mpz/millerrabin.c: Use mpz_urandomm for uniform selection of x, + reported by Jason Moxham. Exclude x==n-1, ie. -1 mod n. Use + gmp_randinit_default. + + * mpn/alpha/umul.asm: Use "r" registers, for the benefit of Unicos. + + * tests/devel/try.c: Add mpn_copyi and mpn_copyd. + +2002-08-09 Kevin Ryde + + * Makefile.am: Remove configure.lineno from DISTCLEANFILES and gmp.tmp + from MOSTLYCLEANFILES, automake does these itself now. + + * */Makefile.in, aclocal.m4, configure, install-sh, missing, + mkinstalldirs: Update to automake 1.6.3. + + * mpn/ia64/README: Some notes on assembler syntax. + + * mpn/ia64/add_n.asm, mpn/ia64/sub_n.asm: Add .body. + * mpn/ia64/add_n.asm, mpn/ia64/addmul_1.asm, mpn/ia64/mul_1.asm, + mpn/ia64/sub_n.asm: Position .save ar.lc just before relevant + instruction. + * mpn/ia64/addmul_1.asm, mpn/ia64/mul_1.asm: Add .save ar.pfs and pr. + * mpn/ia64/copyd.asm, mpn/ia64/copyi.asm: Correction to .body position. + * mpn/ia64/lorrshift.asm: Add .prologue stuff. + + * configure.in (*-*-unicos*): Remove forcible --disable-shared, + libtool gets this right itself now. + +2002-08-07 Kevin Ryde + + * mpn/x86/pentium/mmx/hamdist.asm: New file, adapted from + mpn/x86/pentium/mmx/popham.asm. + * mpn/x86/pentium/mmx/popham.asm: Remove file, not faster than plain + mpn/x86/pentium/popcount.asm for the popcount. + + * mpn/alpha/umul.asm: Use PROLOGUE/EPILOGUE, rename it mpn_umul_ppmm. + * configure.in (alpha*-*-*): Add umul to extra_functions. + + * mpz/remove.c: Make src==0 return 0, not do DIVIDE_BY_ZERO. + +2002-08-05 Torbjorn Granlund + + * acconfig.h: Remove spurious undefs for mpn_divrem_newton and + mpn_divrem_classic. + +2002-08-05 Kevin Ryde + + * tests/refmpn.c, tests/tests.h, tests/misc/t-printf.c, + tests/mpf/t-trunc.c, tests/mpn/t-mp_bases.c, tests/mpn/t-scan.c, + tests/mpq/t-cmp_ui.c, tests/mpz/bit.c, tests/mpz/t-aorsmul.c, + tests/mpz/t-powm_ui.c tests/mpz/t-root.c, tests/mpz/t-scan.c: More + care with long and mp_size_t parameters, for the benefit of K&R. + + * demos/perl/GMP.pm, demos/perl/GMP.xs, demos/perl/GMP/Mpz.pm, + demos/perl/test.pl: Add mpz_import and mpz_export. + * demos/perl/GMP.pm: Remove "preliminary" warning. + + * mpn/lisp/gmpasm-mode.el: Set add-log-current-defun-header-regexp to + pick up m4 defines etc. + + * Makefile.am (libgmpxx_la_DEPENDENCIES): libgmp.la should be here, + not libgmpxx_la_LIBADD, for the benefit of "make -j2". + + * mpn/ia64/*.asm [hpux ABI=32]: Extend 32-bit operands to 64-bits, not + optimal and might not be sufficient, but seems to work. + +2002-08-03 Kevin Ryde + + * gmp.texi (Profiling): Use a table and expand for clarity. + (Integer Special Functions): New section for mpz_array_init, + _mpz_realloc, mpz_getlimbn and mpz_size, to discourage their use. + + * configure.in (*-*-msdosdjgpp*): Remove forcible --disable-shared, + libtool gets this right itself now. + +2002-07-30 Kevin Ryde + + * mpn/powerpc32/lshift.asm, mpn/powerpc32/rshift.asm: Lose final mr, + and make final stwu into an stw. + + * gmp.texi (Known Build Problems): An easier workaround for DESTDIR, + using LD_LIBRARY_PATH. + (C++ Interface MPFR): Remove mpfrxx.h. + + * mpfrxx.h: Remove file. + * Makefile.am: Remove mpfrxx.h. + * tests/cxx/Makefile.am: Add Gerardo's new test programs. + +2002-07-30 Gerardo Ballabio + + * gmpxx.h: Use mpz_addmul etc for ternary a+b*c etc. Reorganise some + macros for maintainability. Merge mpfrxx.h. + * tests/cxx/t-constr.cc, tests/cxx/t-expr.cc: Various updates. + * tests/cxx/t-assign.cc, tests/cxx/t-binary.cc, + tests/cxx/t-ternary.cc, tests/cxx/t-unary.cc: New files. + +2002-07-27 Kevin Ryde + + * longlong.h (count_trailing_zeros) [ia64 __GNUC__]: Don't use + __builtin_ffs for now, doesn't seem to work. + + * configure.in: Establish CONFIG_SHELL to avoid a problem with + AC_LIBTOOL_SYS_MAX_CMD_LEN on ia64-*-hpux*. + + * tune/speed.h (SPEED_ROUTINE_MPN_GCD_FINDA): Don't let calls to + mpn_gcd_finda go dead. + + * mpn/generic/tdiv_qr.c: Inline mpn_rshift and MPN_COPY of 2 limbs. + +2002-07-24 Kevin Ryde + + * demos/primes.c: Use __GMP_PROTO and don't use signed, for the + benefit of K&R. + + * demos/calc/calclex.l: Add for strcmp. + + * mpn/ia64/invert_limb.asm: Use .rodata which works on ia64-*-hpux* + and should be standard, rather than worrying about RODATA. + + * gmp.texi (Function Classes): Add cross references. + (Integer Import and Export): Fix return value grouping. + + * mpn/lisp/gmpasm-mode.el (gmpasm-comment-start-regexp): Add // for + ia64. Add notes on what the various styles are for. + + * mpn/ia64/default.m4 (ASM_START): Define to empty, not dnl, so as not + to kill text on the same line. + (EPILOGUE_cpu): Force a newline after "#", so as not to suppress macro + expansion in the rest of the EPILOGUE line. + +2002-07-21 Kevin Ryde + + * tune/speed.h: Fix some missing _PROTOs. + + * Makefile.am (DISTCLEANFILES): Add configure.lineno. + + * acinclude.m4 (GMP_C_DOUBLE_FORMAT): Define + HAVE_DOUBLE_IEEE_BIG_ENDIAN and HAVE_DOUBLE_IEEE_LITTLE_ENDIAN in + config.m4 too. + * mpn/ia64/invert_limb.asm: Add big-endian data. + + * tests/mpz/t-jac.c (try_si_zi): Correction to "a" parameter type. + +2002-07-20 Kevin Ryde + + * mpz/bin_ui.c, mpz/jacobi.c, mpz/pprime_p.c, mpn/generic/divis.c: + More care with long and mp_size_t parameters, for the benefit of K&R. + + * gmp-impl.h (invert_limb): Use parens around macro arguments. + (mpn_invert_limb): Give prototype and define unconditionally. + + * gmp-impl.h (CACHED_ABOVE_THRESHOLD, CACHED_BELOW_THRESHOLD): New + macros. + * mpn/generic/sb_divrem_mn.c: Use them to help gcc let preinv code go + dead when not wanted. + +2002-07-17 Kevin Ryde + + * tests/refmpz.c (refmpz_hamdist): Ensure mp_size_t parameters are + that type, for the benefit of hpux ia64 bundled cc ABI=64. + + * configure.in (ia64*-*-hpux*): Need +DD64 in cc_64_cppflags to get + the right headers for ansi2knr. + + * acinclude.m4 (GMP_TRY_ASSEMBLE, GMP_ASM_UNDERSCORE): Use $CPPFLAGS + with $CCAS and when linking, as done by the makefiles. + (GMP_ASM_X86_MMX, GMP_ASM_X86_SSE2): Show $CPPFLAGS in diagnostics. + + * gmp-impl.h (ieee_double_extract): Setup using HAVE_DOUBLE_IEEE_*. + (GMP_UINT32): New define, 32 bit type for ieee_double_extract. + * configure.in: Add AC_CHECK_SIZEOF unsigned. + * configure.in, acinclude.m4 (GMP_IMPL_H_IEEE_FLOATS): Remove. + (GMP_C_DOUBLE_FORMAT): Instead warn about unknown float here. + + * configure.in, acinclude.m4 (GMP_C_SIZES): Remove. + * acinclude.m4 (GMP_INCLUDE_GMP_H_BITS_PER_MP_LIMB): Remove this + scheme, not required. + * configure.in (unsigned long, mp_limb_t): Run AC_CHECK_SIZEOF for + these unconditionally, check mp_limb_t against gmp-mparam.h values. + * gmp-impl.h (BYTES_PER_MP_LIMB, BITS_PER_MP_LIMB): Define based on + SIZEOF_MP_LIMB_T if not provided by gmp-mparam.h. + (BITS_PER_ULONG): Define here now. + + * gmp.texi (ABI and ISA): Add HP-UX IA-64 choices. + (Random State Initialization): Typo in m2exp described for + gmp_randinit_lc_2exp_size. + (Formatted Output Functions): Clarify gmp_obstack_printf a bit. + (Formatted Input Strings): Typo in %n summary. + + * mpz/inp_raw.c (NTOH_LIMB_FETCH): Use simple generic default, since + endianness detection is now cross-compile friendly. + * mpz/out_raw.c (HTON_LIMB_STORE): Ditto. + + * mpz/fib_ui.c: Nailify. + * mpz/random.c: Nailify. + + * mpfr/acinclude.m4 (MPFR_CONFIGS): Patch by Vincent for an apparent + float rounding gremlin on powerpc. + +2002-07-15 Kevin Ryde + + * Makefile.am (PRINTF_OBJECTS): Avoid ending in a backslash, hpux ia64 + make doesn't like that. + + * mpn/ia64/*.asm: Add .sptk to unconditional branches, add ";" after + .mib etc, for the benefit of hpux. + + * configure.in (ia64*-*-*): Use ABI=64 on non-HPUX systems, for + consistency. + + * gmp-impl.h (ieee_double_extract): Test __sparc__, used by gcc 3.1. + Reported by nix@esperi.demon.co.uk. + * mpfr/mpfr-math.h (_MPFR_NAN_BYTES etc): Ditto. + +2002-07-13 Kevin Ryde + + * mpn/powerpc32/rshift.asm: Rewrite, transformed from lshift.asm. + + * tune/tuneup.c (DIVEXACT_1_THRESHOLD, MODEXACT_1_ODD_THRESHOLD): + Always zero for native mpn_divexact_1, mpn_modexact_1_odd. + + * gmp-h.in (__GMP_EXTERN_INLINE): Don't use this during configure, + ie. __GMP_WITHIN_CONFIGURE, to avoid needing dependent routines. + * acinclude.m4 (GMP_H_EXTERN_INLINE): Consequent changes. + + * gmp-impl.h, mpn/asm-defs.m4 (mpn_addmul_2, mpn_addmul_3, + mpn_addmul_4): Add prototypes and defines. + + * gmp.texi (Number Theoretic Functions): Clarify return value. + Reported by Peter Keller. + +2002-07-10 Kevin Ryde + + * configure.in, acinclude.m4 (GMP_PROG_LEX): Remove this in favour of + AM_PROG_LEX, now ok when lex is missing. + + * longlong.h (count_leading_zeros) [pentiummmx]: Don't use __clz_tab + variant under LONGLONG_STANDALONE. + (count_trailing_zeros) [ia64 __GNUC__]: Use __builtin_ffs. + + * gmp-impl.h (popc_limb): Add an ia64 asm version. + (DItype): Use HAVE_LONG_LONG to choose long long, avoiding _LONGLONG + which is in gcc but means something unrelated in MS Visual C 7.0. + Reported by David Librik. + + * mpz/divexact.c: Add an ASSERT that den divides num. + + * mpn/asm-defs.m4 (LDEF): New macro. + (INT32, INT64): Use it. + * mpn/pa32/*.asm: Use it. + * mpn/pa32/README: Update notes on labels. + + * tests/refmpn.c, tests/tests.h, tests/t-bswap.c (ref_bswap_limb): + Renamed from refmpn_bswap_limb. + * tests/t-bswap.c: Add tests_start/tests_end for randomization. + + * tests/refmpn.c, tests/tests.h (ref_popc_limb): New function. + * tests/t-popc.c: New file. + * tests/Makefile.am: Add it. + + * mpn/ia64/invert_limb.asm: Use RODATA since ".section .rodata" is not + accepted by ia64-*-hpux*. + + * acinclude.m4 (GMP_ASM_BYTE): New macro. + (GMP_ASM_ALIGN_LOG, GMP_ASM_W32): Use it. + (GMP_ASM_LABEL_SUFFIX): Use test compiles, not $host. + (GMP_ASM_GLOBL): Ditto, and add .global for ia64-*-hpux*. + (GMP_ASM_GLOBL_ATTR): Use GMP_ASM_GLOBL result, not $host. + (GMP_ASM_LSYM_PREFIX): Allow any "a-z" nm symbol code, add ".text" to + test program, required by ia64-*-hpux*. + (GMP_ASM_LABEL_SUFFIX): Make LABEL_SUFFIX just the value, not a "$1:", + the former being how it's currently being used in fact. + + * configure.in, acinclude.m4 (GMP_PROG_CC_WORKS_LONGLONG): New macro. + * configure.in (ia64-*-hpux*): Add 32 and 64 bit ABI modes. + +2002-07-06 Kevin Ryde + + * tests/cxx/t-allfuns.cc: New file. + * tests/cxx/Makefile.am: Add it. + + * mpz/clrbit.c, mpz/setbit.c: Only MPN_NORMALIZE if high limb changes + to zero. Use _mpz_realloc return value. + + * gmp.texi (Build Options, C++ Formatted Output, C++ Formatted Input): + Cross reference to Headers and Libraries for libgmpxx stuff. + (Low-level Functions): mpn_divexact_by3 result based on GMP_NUMB_BITS. + mpn_set_str takes "unsigned char *", reported by Mark Sofroniou. + (C++ Interface General): Describe linking with libgmpxx and libgmp. + +2002-07-01 Kevin Ryde + + * tune/tuneup.c, gmp-impl.h: Eliminate the array of thresholds in + one(), tune just one at a time and let the callers hand dependencies. + Eliminate the second_start_min hack, handle SQR_KARATSUBA_THRESHOLD + oddities in tune_sqr() instead. + + * mpn/pa64/umul.asm, mpn/pa64/udiv.asm, mpn/asm-defs.m4, acconfig.h, + longlong.h, tune/speed.c, tune/speed.h, tune/common.c, tune/many.pl, + tests/devel/try.c: Introduce mpn_umul_ppmm_r and mpn_udiv_qrnnd_r + rather than having variant parameter order for mpn_umul_ppmm and + mpn_udiv_qrnnd on pa64. + + * gmp-h.in (mpz_export): Remove a spurious parameter name. + * gmp-impl.h (mpn_rootrem): Use __MPN. + +2002-06-29 Kevin Ryde + + * longlong.h (udiv_qrnnd) [hppa32]: Remove mpn_udiv_qrnnd version, the + general mechanism for that suffices. + + * mpf/inp_str.c: Fix returned count of chars read, reported by Paul + Zimmermann. Also fix a memory leak for invalid input. + * tests/mpf/t-inp_str.c: New file. + * tests/mpf/Makefile.am (check_PROGRAMS): Add it. + + * tests/devel/try.c (mpn_mod_34lsub1): Only exists for + GMP_NUMB_BITS%4==0. + (SIZE2_FIRST): Respect option_firstsize2 for "fraction" case. + + * mpn/generic/diveby3.c: Further nailifications. + * gmp-impl.h (MODLIMB_INVERSE_3): Allow for GMP_NUMB_BITS odd. + (GMP_NUMB_CEIL_MAX_DIV3, GMP_NUMB_CEIL_2MAX_DIV3): New constants. + * tests/t-constants.c: Check them. + + * gmp-h.in (__GMP_CRAY_Pragma): New macro. + (__GMPN_COPY_REST): Use it. + * gmp-impl.h (CRAY_Pragma): Use it. + +2002-06-25 Kevin Ryde + + * mpz/import.c, mpz/export.c: Cast data pointer through "char *" in + alignment tests, for the benefit of Cray vector systems. + + * configure.in (x86-*-*): Remove -march=pentiumpro check, seems ok + with current code. + * acinclude.m4 (GMP_GCC_MARCH_PENTIUMPRO, GMP_GCC_VERSION_GE): Remove + macros, no longer needed + + * acinclude.m4 (GMP_ASM_RODATA): Remove temporary files. + + * configure.in (GMP_ASM_GLOBL_ATTR): Reposition to avoid duplication + through AC_REQUIRE. + +2002-06-23 Kevin Ryde + + * tests/mpz/t-fib_ui.c (check_fib_table): Check table values, not just + that they're non-zero. + + * acinclude.m4 (GMP_GCC_ARM_UMODSI): Match bad "gcc --version" output + exactly, rather than parsing it with GMP_GCC_VERSION_GE. + (GMP_ASM_UNDERSCORE): Use GLOBL_ATTR. + + * mpn/pa32/udiv.asm, mpn/pa32/hppa1_1/udiv.asm, mpn/pa64/udiv.asm: + Renamed from udiv_qrnnd.asm, for consistency with other udiv's. + * mpn/pa64/umul.asm: Renamed from umul_ppmm.asm likewise. + * configure.in (hppa*-*-*): Update extra_functions. + (NAILS_SUPPORT): Remove umul_ppmm, udiv_qrnnd, udiv_fp, udiv_nfp from + nails-neutral list, no longer needed. + + * gmp-h.in (__DECC): Add notes on testing this for ANSI-ness. + (__GMP_EXTERN_INLINE): Add static __inline for DEC C. + (mpz_mod_ui): Move up to main section, it's still documented. + +2002-06-22 Kevin Ryde + + * mpz/jacobi.c, mpz/kronsz.c, mpz/kronuz.c, mpz/kronzs.c, + mpz/kronzu.c: Allow for odd GMP_NUMB_BITS, tweak a few variable setups. + * gmp-impl.h (JACOBI_STRIP_LOW_ZEROS): New macro. + + * mpn/generic/mod_34lsub1.c: Nailify. + * tests/devel/try.c (CNST_34LSUB1): Nailify. + * gmp-impl.h (ADDC_LIMB): New macro. + + * gmpxx.h (mpf_class::get_str): Make exponent mp_exp_t&, default + base=10 and ndigits=0. + (mpz_class::set_str, mpq_class::set_str, mpf_class::set_str): Add + versions accepting "const char *". + * mpfrxx.h (mpfr_class::get_str, mpfr_class::set_str): Ditto, and + uncommenting set_str and operator=. + * gmp.texi (C++ Interface Integers, C++ Interface Rationals) + (C++ Interface Floats): Update. + + * gmp-impl.h (modlimb_invert): Merge the <=64bits and general versions. + (const, signed): Move to near top of file, fixes --enable-alloca=debug + on K&R. + + * gen-fib.c: New file, derived from mainline in mpn/generic/fib2_ui.c. + * dumbmp.c (mpz_init_set_ui): New function. + * Makefile.am, mpn/Makefile.am: Generate fib_table.h, mpn/fib_table.c. + * gmp-impl.h: Use fib_table.h, add __GMP_DECLSPEC to __gmp_fib_table + (for the benefit of tests/mpz/t-fib_ui.c). + * mpn/generic/fib2_ui.c: Remove __gmp_fib_table and generating code. + + * Makefile.am: Add mp.h to BUILT_SOURCES, distclean all BUILT_SOURCES, + use += more. + + * acinclude.m4 (GMP_ASM_M68K_INSTRUCTION, GMP_ASM_M68K_BRANCHES): + Don't let "unknown" get into the cache variables. + (GMP_ASM_TEXT): See what assembles, don't hard-code hpux and aix. + (GMP_PROG_EXEEXT_FOR_BUILD): Add ,ff8 for RISC OS, per autoconf cvs. + (GMP_PROG_CPP_FOR_BUILD): Restructure per AC_PROG_CPP, print correct + result if CPP_FOR_BUILD overrides the cache variable. + (GMP_PROG_CC_FOR_BUILD_WORKS): New macro split from + GMP_PROG_CC_FOR_BUILD. Allow for "conftest" default compiler output. + * configure.in, acinclude.m4 (GMP_PROG_HOST_CC): Reinstate this, + separating HOST_CC establishment from GMP_PROG_CC_FOR_BUILD. + + * configure.in (mpn_objs_in_libgmp): Move mpn/mp_bases.lo ... + * Makefile.am (MPN_OBJECTS): ... to here, add $U, and arrange + MPN_OBJECTS to be common between libgmp and libmp. + +2002-06-20 Torbjorn Granlund + + * mpn/generic/mul_n.c (TOOM3_MUL_REC, TOOM3_SQR_REC): Don't check if + basecase is to be invoked when *_TOOM3_THRESHOLD is more than 3 times + the corresponding *_THRESHOLD. + +2002-06-20 Kevin Ryde + + * mpn/ia64/submul_1.c: Add missing TMP_DECL, TMP_MARK, TMP_FREE. + Reported by Paul Zimmermann. + + * configure.in, acinclude.m4 (AC_DEFINE): Make templates read "Define + to 1", for clarity as per autoconf. + * acinclude.m4 (GMP_OPTION_ALLOCA): Group WANT_TMP templates. + +2002-06-20 Gerardo Ballabio + + * gmpxx.h, mpfrxx.h: Remove mpz_classref, let mpq_class::get_num and + mpq_class::get_den return mpz_class& as per the documentation. + Reported by Roberto Bagnara. + +2002-06-18 Kevin Ryde + + * tests/rand/t-lc2exp.c: New file. + * tests/rand/Makefile.am: Add it, and use tests/libtests.la. + + * randraw.c (lc): Pad seed==0 case with zero limbs, return same + (m2exp+1)/2 bits as normal, right shift "c" result as normal. + + * configure.in: Don't bother with line numbers in some diagnostics. + (*-*-mingw*): Use -mno-cygwin if it works, suggested by delta trinity. + + * tests/mpz/Makefile.am, tests/mpq/Makefile.am, + tests/misc/Makefile.am, (CLEANFILES): Set to *.tmp for test program + temporaries, to get t-scanf.tmp and reduce future maintenance. + +2002-06-16 Torbjorn Granlund + + * mpn/generic/get_str.c (mpn_dc_get_str): Pass scratch memory area in + new `tmp' parameter. Trim allocation needs by reusing input parameter. + +2002-06-15 Torbjorn Granlund + + * mpn/sparc32/v9/udiv.asm: New file. + +2002-06-15 Kevin Ryde + + * acinclude.m4 (GMP_GCC_VERSION_GE): Correction to recognising mingw + gcc 3.1 version number. Reported by Jim Fougeron. + + * configure.in (AC_PROVIDE_AC_LIBTOOL_WIN32_DLL): New define, to make + AC_LIBTOOL_WIN32_DLL work with autoconf 2.53. + + * acinclude.m4 (GMP_C_SIZES): Establish BITS_PER_MP_LIMB as a value, + not an expression, for the benefit of the gen-bases invocation. + + * config.guess (CC_FOR_BUILD): Try c99, same as configfsf.guess. + +2002-06-15 Paul Zimmermann + + * mpfr/set_q.c: Allow for 1 bit numerator or denominator. + +2002-06-14 Kevin Ryde + + * configure.in (AC_C_BIGENDIAN): Use new style action parameters. + + * randlc2x.c: Allow for a<0, allow for c>=2^m2exp. + * randraw.c (lc): Allow for a==0. + + * mpn/sparc32/udiv.asm: Renamed from udiv_fp.asm. Don't know if float + is the best way for v7, but it's what configure has chosen since gmp 3. + * configure.in (*sparc*-*-* ABI=32): extra_functions="udiv" for all, + in particular sparc32/v8/udiv.asm is faster (on ultrasparc2) than + udiv_fp previously used for v9 chips. + + * gen-bases.c: New file, derived from mpn/mp_bases.c. + * dumbmp.c: New file, mostly by Torbjorn, some by me. + * configure.in, acinclude.m4 (GMP_PROG_CC_FOR_BUILD, + GMP_PROG_CPP_FOR_BUILD, GMP_PROG_EXEEXT_FOR_BUILD, + GMP_C_FOR_BUILD_ANSI, GMP_CHECK_LIBM_FOR_BUILD): New macros. + (GMP_PROG_HOST_CC): Remove, superceded by GMP_PROG_CC_FOR_BUILD. + * Makefile.am: Run gen-bases to create mp_bases.h and mpn/mp_bases.c. + * gmp-impl.h: Use mp_bases.h. + * mpn/mp_bases.c: Remove file. + * mpn/Makefile.am: mp_bases.c now in nodist_libmpn_la_SOURCES. + + * tests/mpz/t-cmp_d.c (check_one_2exp): Use volatile to force to + double, fixes gcc 3.1 with -O4. Reported by Michael Lee. + * configure.in (AC_C_VOLATILE): New macro. + + * tests/misc/t-scanf.c: (fromstring_gmp_fscanf): Add missing va_end. + Don't mix varargs and fixed args functions, not good on x86_64. + Reported by Marcus Meissner. + + * Makefile.am (EXTRA_DIST): Remove mpfr/README, now in mpfr/Makefile.in + + * configure, config.in, INSTALL.autoconf: Update to autoconf 2.53. + * */Makefile.in, install-sh, mdate-sh, missing, aclocal.m4, configure: + Update to automake 1.6.1. + * configfsf.guess, configfsf.sub: Update to 2002-05-29. + +2002-06-12 Kevin Ryde + + * acinclude.m4 (GMP_GCC_VERSION_GE): Recognise mingw gcc 3.1 version. + (GMP_PROG_CC_WORKS): Allow for a_out.exe, as per autoconf. + (GMP_GCC_NO_CPP_PRECOMP, GMP_ASM_UNDERSCORE): Ditto, plus a.exe. + +2002-06-09 Torbjorn Granlund + + * randraw.c (lc): Remove broken ASSERT_ALWAYS. + + * mpn/x86: Update gmp-mparam.h files with current measures *_THRESHOLD + values. + * mpn/x86/p6/mmx/gmp-mparam.h: New file. + +2002-06-09 Kevin Ryde + + * mpn/x86/*/gmp-mparam.h (USE_PREINV_DIVREM_1): Add tuned settings. + + * acconfig.h (HAVE_NATIVE_mpn_preinv_divrem_1): New template. + + * tests/refmpn.c, tests/tests.h (refmpn_chars_per_limb, + refmpn_big_base): New functions. + * tests/mpn/t-mp_bases.c: Use them, and don't test big_base_inverted + unless it's being used. + + * gmp.texi (Notes for Particular Systems): Using Microsoft C with DLLs. + (Known Build Problems): Notes on MacOS and GCC. + (Integer Logic and Bit Fiddling): Use ULONG_MAX for maximum ulong. + (Low-level Functions): mpn_get_str accepts base==256. + (Formatted Output Functions): Note output is not atomic. + (Internals): Note mp_size_t for limb counts. + + * mp-h.in, gmp-h.in (mp_ptr, mp_srcptr, mp_size_t, mp_exp_t): Remove + these types from mp.h, not needed. + + * mpfr/tests/tadd.c, mpfr/tests/tmul.c (check): Apply a hack to the + parameter order to make sparc gcc 2.95.2 happy. + + * doc/configuration: Notes on bootstrapping. + +2002-06-08 Kevin Ryde + + * mpfr/tests/tsqrt.c, mpfr/tests/tsqrt_ui.c: Suppress tests if sqrt is + not affected by mpfr_set_machine_rnd_mode. + + * mpfr/mul_2si.c: Workaround a mips gcc 2.95.3 bug under -O2 -mabi=n32. + + * configure.in (alphev56): Fix to use ev5 path. + +2002-06-06 Kevin Ryde + + * gmp-h.in: Use __gmp_const not const, in a number of places. + + * configure.in (sparc): Use ABI=32 instead of ABI=standard on v7 and + v8, for consistency with v9 choices. + (sparc64): Restrict GMP_ASM_SPARC_REGISTER to ABI=64. + (x86): Move MMX $path munging to before printout. + (CCAS): Move upward to support this. + + * gmp-impl.h (modlimb_invert): Merge macros for specific limb sizes, + add a version for arbitrary limb size, use GMP_NUMB_BITS. + (modlimb_invert, MODLIMB_INVERSE_3): Fix comments to say GMP_NUMB_BITS. + + * gmp-h.in (__GMP_LIKELY, __GMP_UNLIKELY): New macros. + (mpz_getlimbn, mpz_perfect_square_p, mpz_popcount): Use them, make the + fetch or mpn call likely, unconditionally calculate the alternative so + as to avoid an "else" clause. + * gmp-impl.h (LIKELY, UNLIKELY): Aliases. + + * configure.in, mpfr/tests/Makefile.am: Add $LIBM to $LIBS for + MPFR_CONFIGS so it detects fesetround, and let it go through to + $MPFR_LIBS. + * mpfr/rnd_mode.c: Use gmp-impl.h to get MPFR_HAVE_FESETROUND. + + * tests/mpz/t-sizeinbase.c: Disable fake bits test, such pointer + setups are bogus and have been seen failing on hppa. + + * tests/misc.c, tests/refmpz.c, tests.tests.h, tests/mpz/t-cong.c: + Rename mpz_flipbit to refmpz_combit and move from misc.c to refmpz.c. + +2002-06-05 Torbjorn Granlund + + * tests/mpz/t-powm_ui.c Print proper routine name in error message. + +2002-06-03 Kevin Ryde + + * tune/time.c, tune/freq.c, tune/speed.h: Add powerpc mftb support. + (FREQ_MEASURE_ONE): Move to speed.h, fix tv_sec factor. + (freq_measure): Use for mftb measuring too. + * tune/powerpc.asm, tune/powerpc64.asm: New files. + * configure.in, tune/Makefile.am: Add them. + + * gmp-impl.h (popc_limb): Add versions for Cray and fallback for + arbitrary limb size. + + * mpn/sparc32/sparc-defs.m4: New file. + * configure.in (sparc*-*-*): Use it. + * acinclude.m4 (GMP_ASM_SPARC_REGISTER): New macro. + * configure.in (sparc64): Use it. Also, use -Wc,-m64 for linking. + * mpn/sparc64/add_n.asm, mpn/sparc64/addmul_1.asm, + mpn/sparc64/copyd.asm, mpn/sparc64/copyi.asm, mpn/sparc64/lshift.asm, + mpn/sparc64/mul_1.asm, mpn/sparc64/rshift.asm, + mpn/sparc64/sqr_diagonal.asm, mpn/sparc64/sub_n.asm, + mpn/sparc64/submul_1.asm: Use REGISTER for .register. + +2002-06-01 Kevin Ryde + + * mpz/powm_ui.c: Fix for result range in certain circumstances. + + * mpn/x86/k6/diveby3.asm: Speedup to 10 c/l, same as divexact_1. + Anomaly pointed out by Alexander Kruppa. + +2002-05-31 Torbjorn Granlund + + * mpz/export.c: Cast pointer via `unsigned long' when checking + alignment to avoid compiler warnings. + +2002-05-29 Kevin Ryde + + * gmp-impl.h (BSWAP_LIMB): Versions for m68k, powerpc, and arbitrary + limb size. + * configure.in, acconfig.h (HAVE_HOST_CPU_FAMILY_m68k): New define. + +2002-05-27 Torbjorn Granlund + + * mpn/generic/mul_basecase.c: Improve MAX_LEFT handling, returning + when possible. Add code for mpn_addmul_5 and mpn_addmul_6. + +2002-05-25 Kevin Ryde + + * tune/tuneup.c: Misc nailifications, and disable preinv thresholds + with nails. + * tune/speed.h: Use GMP_NUMB_HIGHBIT with mpn_sb_divrem_mn and + mpn_divrem_2. + * mpz/powm.c (redc): Nailify q. + + * tests/mpn/t-scan.c: Reduce the amount of testing, to go faster. + +2002-05-23 Torbjorn Granlund + + * Version 4.1 released. + + * mpn/alpha/ev6/nails/gmp-mparam.h: New file. + + * tests/devel/add_n.c (refmpn_add_n): Nailify. + * tests/devel/sub_n.c (refmpn_sub_n): Nailify. + * tests/devel/addmul_1.c (refmpn_addmul_1): Nailify. + * tests/devel/submul_1.c (refmpn_submul_1): Nailify. + + * mpn/alpha/ev6/nails/add_n.asm: New file. + * mpn/alpha/ev6/nails/sub_n.asm: New file. + * mpn/alpha/ev6/nails/mul_1.asm: New file. + * mpn/alpha/ev6/nails/submul_1.asm: New file. + +2002-05-22 Torbjorn Granlund + + * mpn/alpha/ev6/nails/addmul_1.asm: New file. + + * mpz/inp_str.c (mpz_inp_str_nowhite): Nailify. + + * mpn/generic/mul_basecase.c: Update pointers before conditional + MAX_LEFT break statements. + +2002-05-21 Torbjorn Granlund + + * tests/mpz/t-gcd.c: Test mpz_gcd_ui. + + * mpz/lcm_ui.c: Nailify. + + * mpz/gcd_ui.c: Nailify. Make it work as documented, allowing + NULL to be passed for result parameter. Fix gcd(0,0) case. + + * mpz/set_str.c: Nailify. + + * randlc2x.c (gmp_randinit_lc_2exp): Nailify. + + From Jakub Jelinek: + * longlong.h (add_ssaaaa,sub_ddmmss) [64-bit sparc]: + Make it actually work. + +2002-05-18 Torbjorn Granlund + + * mpf/ui_div.c: Shut up compiler warning. + + * mpn/generic/mul_basecase.c: Use mpn_addmul_2, mpn_addmul_3, and + mpn_addmul_4, as available. + + * mpn/alpha/ev6/nails/addmul_2.asm: Adjust NAILS_SUPPORT decls. + * mpn/alpha/ev6/nails/addmul_3.asm: Likewise + * mpn/alpha/ev6/nails/addmul_4.asm: Likewise. + + * configure.in (*-cray-unicos*): Back again to -hscalar0. + (gmp_mpn_functions_optional): Add mul_3, mul_4, addmul_2, addmul_3, + and addmul_4. + * acconfig.h: Add #undefs for new optional mpn functions. + +2002-05-18 Kevin Ryde + + * gmp.texi (Integer Import and Export): Mention Cray unfilled words. + + * mpz/set_d.c, mpq/set_d.c: Use LIMBS_PER_DOUBLE for the output of + __gmp_extract_double. Reported by Henrik Johansson. + +2002-05-17 Torbjorn Granlund + + * mpn/alpha/ev6/nails/addmul_2.asm: New file. + * mpn/alpha/ev6/nails/addmul_3.asm: New file. + * mpn/alpha/ev6/nails/addmul_4.asm: New file. + + * mpn/generic/dump.c: Rewrite and nailify. + +2002-05-16 Kevin Ryde + + * mpfr/Makefile.am (EXTRA_DIST): Add BUGS file. + +2002-05-15 Torbjorn Granlund + + * configure.in (*-cray-unicos*): Remove -hscalar0, add -hnofastmd + as workaround for compiler bug. + (mips64*-*-*): Pass just -O1 to cc, to work around compiler bug. + +2002-05-14 Torbjorn Granlund + + * configure.in (*-cray-unicos*): Pass -hscalar0 to work around + compiler bug for mpz/import.c. + +2002-05-11 Torbjorn Granlund + + * mpz/import.c: Cast pointer via `unsigned long' when checking + alignment to avoid compiler warnings. + + * mpn/generic/rootrem.c: Adjust allocation of qp temporary area. + +2002-05-09 Kevin Ryde + + * mpz/import.c: Corrections to size store, special case tests, and + general case ACCUMULATE. + * tests/mpz/t-import.c, tests/mpz/t-export.c: More test data. + +2002-05-09 Torbjorn Granlund + + * mpn/generic/rootrem.c: Use temp space for root, copy value in place + before returning. + * mpz/root.c: Don't allocate extra limb for root value. + * mpz/perfpow.c: Undo last change. + +2002-05-08 Torbjorn Granlund + + * gmp-impl.h (powerpc BSWAP_LIMB_FETCH): Rename local variable to make + it not clash with caller. + + * mpn/generic/rootrem.c: New file. + * configure.in (gmp_mpn_functions): Add rootrem and pow_1. + * mpn/Makefile.am (nodist_libdummy_la_SOURCES): Add rootrem.c and + pow_1.c + * gmp-impl.h (mpn_rootrem): Add declaration. + * mpz/perfpow.c: Amend allocations for mpn_rootrem requirements. + * mpz/root.c: Rewrite to use mpn_rootrem. + +2002-05-08 Kevin Ryde + + * gmp-impl.h (MUL_KARATSUBA_THRESHOLD etc): Remove forced nail values. + + * mpf/fits_u.h, mpf/fits_s.h, tests/mpf/t-fits.c: Ignore fraction + part, making the code match the documentation. + + * gmpxx.h (struct __gmp_binary_minus): Use mpz_ui_sub. + +2002-05-07 Kevin Ryde + + * mpn/powerpc32/README: New file. + + * mpz/root.c: Use unsigned long with mpz_sub_ui not mp_limb_t. + + * tune/README: Misc updates including sparc32/v9 smoothness, low res + timebase, and mpn_add_n operand overlaps. + * tune/many.pl: Add udiv.asm support. + + * gmp.texi (Build Options): A couple of --build better as --host. + (Known Build Problems, Notes for Package Builds): Add DESTDIR problem. + (Compatibility with older versions): Compatible with 4.x versions. + (Converting Integers): Remove mpz_get_ui + mpz_tdiv_q_2exp decompose. + (Integer Import and Export): New section. + (Miscellaneous Integer Functions): Clarify mpz_sizeinbase returns 1 + for operand of 0. + (Language Bindings): Add GNU Pascal. + (Low-level Functions): Add GMP_NUMB_MAX. + + * tests/mpz/t-import.c, tests/mpz/t-export.c, tests/mpz/t-get_d.c: + New tests. + * tests/mpz/Makefile.am: Add them. + + * mpz/import.c, mpz/export.c: New files. + * Makefile.am, mpz/Makefile.am, gmp-h.in: Add them. + + * gmp-h.in, gmp-impl.h (GMP_NUMB_MAX): Move to gmp.h. + * gmp-impl.h (CNST_LIMB): Add cast to mp_limb_t to ensure unsigned. + (CRAY_Pragma, MPN_REVERSE, MPN_BSWAP, MPN_BSWAP_REVERSE, + ASSERT_ALWAYS_LIMB, ASSERT_ALWAYS_MPN): New macros. + (MPZ_CHECK_FORMAT): Use ASSERT_ALWAYS_MPN. + +2002-05-07 Torbjorn Granlund + + * mpz/aors_ui.h: Nailify. + + * tests/mpz/t-addsub.c: New file. + * tests/mpz/Makefile.am (check_PROGRAMS): Add t-addsub. + + * mpz/ui_sub.c: New file. + * mpz/Makefile.am (libmpz_la_SOURCES): Add ui_sub.c. + * Makefile.am (MPZ_OBJECTS): Ditto. + * gmp-h.in (mpz_ui_sub): Add declaration. + + * gmp-impl.h (MPZ_REALLOC): Rewrite to allow the use of _mpz_realloc + return value. + + * gmp-h.in (mpn_pow_1): Add declaration. + + * mpn/generic/pow_1.c: Handle exp <= 1. Reverse rp/tp parity scheme + for bn == 1 arm. + + * Rename MP_LIMB_T_HIGHBIT => GMP_LIMB_HIGHBIT. + +2002-05-06 Torbjorn Granlund + + * demos/pexpr.c (main): Don't call mpz_sizeinbase with negative base. + + * randraw.c (lc): Remove an unused variable. + + * mpn/generic/get_str.c: Clarify an algorithm description. + + * tests/mpf/t-trunc.c: Nailify. + * tests/mpf/t-set_si.c: Disable for nails. + + * mpf/cmp_si.c: Nailify. + * mpf/cmp_ui.c: Nailify. + * mpf/div.c: Nailify. + * mpf/div_2exp.c: Nailify. + * mpf/div_ui.c: Nailify. + * mpf/eq.c: Nailify. + * mpf/get_d.c: Nailify. + * mpf/get_d_2exp.c: Nailify. + * mpf/get_si.c: Nailify. + * mpf/get_str.c: Nailify. + * mpf/get_ui.c: Nailify. + * mpf/mul_2exp.c: Nailify. + * mpf/random2.c: Nailify. + * mpf/set_q.c: Nailify. + * mpf/set_si.c: Nailify. + * mpf/set_str.c: Nailify. + * mpf/set_ui.c: Nailify. + * mpf/sub.c: Nailify. + * mpf/ui_div.c: Nailify. + * mpf/ui_sub.c: Nailify. + * mpf/urandomb.c: Nailify. + + * gmp-impl.h (__GMPF_BITS_TO_PREC, __GMPF_PREC_TO_BITS): Nailify. + + * mpz/get_si.c: Misc variable name changes. + + * mpf/fits_u.h: Rewrite - nailify. + * mpf/fits_s.h: Likewise. + + * mpz/mod.c: Disambiguate if-statement with extra {}. + + * mpf/int_p.c: Fix type of size variables. + * mpf/get_ui: Likewise. + * mpf/get_si: Likewise. + * mpq/equal.c: Likewise. + * mpq/get_d.c: Likewise. + * mpz/cmp_d.c: Likewise. + * mpz/cmpabs_d.c: Likewise. + * mpz/divis_2exp.c: Likewise. + * mpz/kronuz.c: Likewise. + * mpz/kronzu.c: Likewise. + * mpz/kronzs.c: Likewise. + * mpz/kronsz.c: Likewise. + * mpz/scan0.c: Likewise. + * mpz/scan1.c: Likewise. + * mpz/tstbit.c: Likewise. + * mpz/cong_2exp.c: Likewise. + * mpz/divis.c: Likewise. + +2002-05-04 Torbjorn Granlund + + * mpn/generic/gcd.c: Additional nailify changes. + +2002-05-04 Kevin Ryde + + * gmp-h.in (__GNU_MP_VERSION): Set to 4.1. + * Makefile.am (-version-info): Bump for new release. + +2002-04-30 Torbjorn Granlund + + * mpn/generic/divrem_1.c: Additional nailify changes. + * mpn/generic/mod_1.c: Likewise. + + * tests/mpq/t-get_d.c: Print floats with all 16 digits. + + * mpq/get_d.c: Nailify. + + * tests/mpq/t-set_f.c: Disable for nails. + + * mpz/get_d.c: Nailify. + + * gmp-impl.h (LIMBS_PER_DOUBLE, MP_BASE_AS_DOUBLE): Nailify. + + * gmp-h.in (__GMPZ_FITS_UTYPE_P): Cast maxval to before shifting it. + + * extract-dbl.c: Nailify. + +2002-04-29 Torbjorn Granlund + + * mpq/md_2exp.c (mord_2exp): Nailify. + + * mpq/cmp_ui.c: Nailify. + + * mpq/cmp.c (mpq_cmp): Nailify. + + * mpn/generic/gcd.c: Nailify. GNUify code layout. + + * mpn/generic/gcdext.c: Nailify. Misc changes. + + * tests/mpz/t-sqrtrem.c: Let argv[1] mean # of repetitions. + * tests/mpz/t-gcd.c: Likewise. + + * mpz/gcd.c: Nailify. + + * mpn/generic/random.c: Nailify. + + * gmp-impl.h (modlimb_invert): Nailify. + +2002-04-27 Torbjorn Granlund + + * mpn/generic/gcdext.c (div2): Remove qh parameter. + (mpn_gcdext): Streamline double-limb code. + Move GCDEXT_THRESHOLD check to after initial division. + +2002-04-27 Kevin Ryde + + * gmp-impl.h (JACOBI_MOD_OR_MODEXACT_1_ODD): Allow for odd + GMP_NUMB_BITS. + + * tune/time.c (sgi_works_p): Allow for 64-bit counter, and fix + SGI_CYCLECNTR_SIZE handling. + + * demos/expr/exprfr.c: Add nan and inf constants. + * demos/expr/t-expr.c: Exercise them. + +2002-04-26 Torbjorn Granlund + + * mpz/cmp_ui.c: Fix overflow conditions for nails. + + * gmp-h.in (mpz_get_ui): Fix typo from last change. + + * mpz/n_pow_ui.c: Adjust allocation for nails. + (GMP_NUMB_HALFMAX): Renamed from MP_LIMB_T_HALFMAX. + Fix umul_ppmm invocation for for nails. + +2002-04-24 Torbjorn Granlund + + * mpn/generic/gcdext.c: Simplify by using mpn_tdiv_qr instead of + mpn_divmod. + +2002-04-24 Kevin Ryde + + * configure.in (*-*-cygwin*): Give a sensible default command line + limit, to avoid blowups reported by Jim Fougeron on windows 9x. + (--enable-nails): Make the default 2, since mp_bases has data for that. + + * mpfr/mpfr-math.h (__mpfr_nan): Use a "double" for the bytes, to + avoid a mis-conversion on alpha gcc 3.0.2. + (_MPFR_INFP_BYTES, _MPFR_INFM_BYTES): Should be a zero mantissa. + +2002-04-23 Torbjorn Granlund + + * mpz/dive_ui.c: Fix typo. + + * mpz/fits_s.h: Rewrite. + + * mpz/jacobi.c: Nailify. + * mpz/kronuz.c: Additional nailify changes. + * mpz/kronsz.c: Likewise. + +2002-04-23 Kevin Ryde + + * demos/expr/Makefile.am (LDADD): Add $(LIBM) for the benefit of mpfr. + + * mpz/divis_ui.c, mpz/cong_ui.c: Nailify. + * mpn/generic/bdivmod.c, mpz/divexact.c, mpz/dive_ui.c: Nailify. + * mpn/generic/sb_divrem_mn.c, mpn/generic/divrem.c, + mpn/generic/divrem_2.c: Nailify ASSERTs. + * mpn/x86/k6/mmx/logops_n.asm, mpn/x86/k6/mmx/com_n.asm: Nailify. + * mpz/inp_raw.c, mpz/out_raw.c: Nailify. + * mpz/kronzu.c, mpz/kronuz.c, mpz/kronzs.c, mpz/kronsz.c: Nailify. + * mpn/generic/divis.c, mpz/cong.c, mpz/cong_2exp.c: Nailify. + * gmp-impl.h (NEG_MOD): Nailify. + + * gmp-impl.h, mpn/mp_bases.c: Add back GMP_NUMB_BITS==30 bases data. + + * mpfr/get_d.c: Patch from Paul to avoid problem with constant folding + in gcc on OSF. + + * mpn/lisp/gmpasm-mode.el: Remove mention of defunct LF macro. + +2002-04-22 Torbjorn Granlund + + * demos/pexpr.c: Handle "binomial" operator. + + * mpz/cmp_ui.c: Move assignments of `up' out of conditionals. + + * mpn/generic/gcdext.c: Fix fencepost error in STAT code. + + * gmp-impl.h (mpn_com_n): Nailify. + + * tests/mpz/t-cdiv_ui.c: New file. + * tests/mpz/Makefile.am (check_PROGRAMS): Add t-cdiv_ui. + * mpz/cdiv_qr_ui.c: Nailify. + * mpz/cdiv_q_ui.c: Nailify. + * mpz/cdiv_r_ui.c: Nailify. + * mpz/cdiv_ui.c: Nailify. + + * tests/misc/t-printf.c (CHECK_N): Add cast to allow `char' to be an + unsigned type. + * tests/misc/t-scanf.c: Likewise. + + * mpz/mul_i.h: Rework nails code to handle parameter overlap. + + * tests/mpz/t-set_f.c: Disable for nails. + +2002-04-21 Torbjorn Granlund + + * mpz/set_si.c: Add cast to support LONG_LONG_LIMB. + * mpz/iset_si.c: Likewise. + + * mpz/bin_ui.c: Nailify. + * mpz/bin_uiui.c: Nailify. + + * mpz/cmpabs_ui.c: Nailify. + + * tests/mpz/t-aorsmul.c: Nailify. + * mpz/aorsmul_i.c (mpz_addmul_ui, mpz_submul_ui): Nailify better. + +2002-04-20 Torbjorn Granlund + + * tests/mpz/t-fdiv_ui.c: Check mpz_fdiv_ui. + * tests/mpz/t-tdiv_ui.c: Check mpz_tdiv_ui. + + * mpz/tdiv_ui.c: Rewrite nails code. + * mpz/fdiv_ui.c: Nailify. + + * tests/mpz/t-tdiv_ui.c: Check returned remainders. + * tests/mpz/t-fdiv_ui.c: Merge in recent t-tdiv_ui changes. + + * mpz/tdiv_q_ui.c: Remove spurious TMP_* calls. + + * mpz/fdiv_qr_ui.c: Nailify. + * mpz/fdiv_q_ui.c: Nailify. + * mpz/fdiv_r_ui.c: Nailify. + + * mpz/get_si.c: Misc nailify changes to shut up compiler warnings. + + * mpz/ui_pow_ui.c: Fix typo in last change. + +2002-04-20 Kevin Ryde + + * tests/misc/t-printf.c, tests/misc/t-scanf.c: Check all %n types. + + * mpn/x86/k7/mmx/divrem_1.asm, mpn/x86/p6/mmx/divrem_1.asm + (mpn_preinv_divrem_1): New entrypoint. + (mpn_divrem_1): Avoid a branch when testing high + + * tests/mpz/t-scan.c: Nailify. + + * mpz/tdiv_qr_ui.c: Nailify. + * mpz/tdiv_q_ui.c: Nailify. + * mpz/tdiv_r_ui.c: Nailify. + * mpz/tdiv_ui.c: Nailify. + + * mpz/cmp_ui.c: Nailify. + + * mpz/ui_pow_ui.c: Misc nailify changes to shut up compiler warnings. + + * mpz/scan0.c: Nailify. + * mpz/scan1.c: Nailify. + + * tests/mpz/t-sizeinbase.c (mpz_fake_bits): Nailify. + +2002-04-18 Torbjorn Granlund + + * mpz/aorsmul_i.c: Nailify. + + * mpz/cmp_si.c: Nailify (botched). + + * mpz/ui_pow_ui.c: Nailify. + + * gmp-h.in (__GMPZ_FITS_UTYPE_P): Nailify. + + * mpz/fits_s.h: Nailify. + + * tests/mpz/bit.c (check_tstbit): Nailify. + + From Paul Zimmermann: + * mpn/generic/sqrtrem.c: Nailify. + + * mpz/n_pow_ui.c: Nailify. + + * mpz/cfdiv_r_2exp.c: Nailify. + + * randraw.c (lc): Undo: Let mpn_rshift put result in place to avoid + extra MPN_COPY. + +2002-04-17 Torbjorn Granlund + + * mpz/clrbit.c: Add two GMP_NUMB_MASK masks after addition. + + * mpn/generic/random2.c (LOGBITS_PER_BLOCK): Decrease to 4. + + * gmp-impl.h (nail DIV_DC_THRESHOLD): Decrease to 50 to allow fast + division. + + * mpn/generic/random2.c: Nailify. + + * mpz/fac_ui.c: Nailify. + + * mpz/mul_i.h: #if ... #endif code block to shut up gcc warnings. + + * mpn/generic/sqrtrem.c: Adopt to GNU coding standards. + (mpn_dc_sqrtrem): New name for mpn_dq_sqrtrem. + Partial nailification. + + * configure.in: As a temporary hack, clear extra_functions for nails + builds. + + * gmp-h.in (mpz_get_ui): #if ... #endif else code block to shut up gcc + warnings. + +2002-04-17 Kevin Ryde + + * texinfo.tex: Update to 2002-03-26.08 per texinfo 4.2. + * gmp.texi: Must have @top in @ifnottex (or @contents doesn't come out + in one run). + + * mpn/generic/scan0.c, mpn/generic/scan1.c: Nailify. + + * tests/mpn/t-scan.c: New file. + * tests/mpn/Makefile.am (check_PROGRAMS): Add it. + + * tests/refmpn.c, tests/tests.h (refmpn_tstbit): Use unsigned long for + bit index. + (refmpn_setbit, refmpn_clrbit, refmpn_scan0, refmpn_scan1): New + functions. + + * mpfr/cmp_ui.c (mpfr_cmp_si_2exp): Fix b==0 i!=0 case. + +2002-04-17 Gerardo Ballabio + + * gmpxx.h, mpfrxx.h: Remove mpfr_class bool combinations, remove + mpfr_class::get_str2, use mp_rnd_t for rounding modes, use + 8*sizeof(double) for mpfr_t's holding doubles. + +2002-04-17 Torbjorn Granlund + + * mpz/powm.c: Nailify. + * mpz/powm_ui.c: Nailify. + +2002-04-16 Torbjorn Granlund + + * mpz/hamdist.c: Nailify. + * tests/misc.c (urandom): Nailify. + + * mpz/get_si.c: Nailify. + * gmp-h.in (mpz_get_ui): Nailify. Streamline (and probably upset + memory checkers). + + * gmp-impl.h (mp_bases[10] values): Add versions for GMP_NUMB_BITS + being 28, 60, and 63. + * mpn/mp_bases.c: Add tables for GMP_NUMB_BITS being 28, 60, and 63. + + * mpz/iset_si.c: Nailify. + * mpz/iset_ui.c: Nailify + + * tests/mpz/convert.c (main): Print test number in error message. + + * mpn/generic/get_str.c (mpn_sb_get_str): Shift up `frac' into nails + field after bignum division. + +2002-04-16 Kevin Ryde + + * gmp-h.in, gmp-impl.h (GMP_NAIL_MASK): Move to gmp.h. + + * gmp.texi: Use @documentdescription and @copying, per texinfo 4.2. + (Low-level Functions): Clarify mpn_gcd overlap requirements, rewrite + mpn_set_str description, add nails section. + (C++ Interface General): Remove bool from types that mix with classes. + (Language Bindings): Add STklos, GNU Smalltalk, Regina. + (Binary to Radix, Radix to Binary): Describe new code. + (Assembler Cache Handling): More notes, mostly by Torbjorn. + + * macos/configure (%vars): Remove __GMP from substitutions, per change + to main configure. + + * mpn/generic/dive_1.c: Nailify. + * mpn/generic/mode1o.c: Nailify, remove bogus ASSERT in commented-out + alternate implementation. + * gmp-impl.h (SUBC_LIMB): New macro. + + * tests/devel/try.c (validate_divexact_1): Correction to compare. + (udiv_qrnnd): New testing. + (SHIFT_LIMIT): Nailify. + (-b): New option, remove spurious "H" from getopt string. + + * mpz/clrbit.c: Nailify. + * tests/mpz/t-hamdist.c: Nailify. + * gmp-impl.h (MPN_FIB2_SIZE): Nailify. + (PP): Nailify conditionals. + * tests/mpz/t-fib_ui.c (MPZ_FIB_SIZE_FLOAT): Nailify. + + * configure.in, acinclude.m4: Establish GMP_NAIL_BITS and + GMP_LIMB_BITS for gmp-h.in configure tests. + + * mpfr/*, configure.in: Update to final mpfr 2.0.1. + * mpfr/acinclude.m4 (MPFR_CONFIGS): Use $host, not uname stuff. + * mpfr/tests/tout_str.c: Patch from Paul for denorm fprintf tests. + +2002-04-15 Torbjorn Granlund + + * mpn/generic/divrem_1.c (EXTRACT): Remove. + + * tests/mpz/t-tdiv_ui.c (dump_abort): Accept argument for error string. + + * mpz/rrandomb.c: Nailify. Needs further work. + + * mpn/generic/mod_1.c: Nailify. + + * gmp-impl.h: Set various *_THRESHOLD values to be used for nails to + avoid not yet qualified algorithms. + (MPZ_CHECK_FORMAT): Check that nail part is zero. + + * tests/mpz/t-mul.c (main): Test squaring even for huge operands. + (base_mul): Nailify. + (dump_abort): Accept argument for error string. Print product + difference. + + * mpn/generic/set_str.c: Nailify. + + * gmp-h.in (__GMPN_ADD, __GMPN_SUB): Nailify. + +2002-04-14 Torbjorn Granlund + + * randraw.c (lc): Return non-nonsense return value for seed=0 case. + Check for m2exp being non-zero early; remove all other tests of m2exp. + Remove redundant MPN_ZERO call. + Let mpn_rshift put result in place to avoid extra MPN_COPY. + Remove confusing comment before function `lc' describing BBS algorithm. + Misc simplification and cleanups. + Nailify. Needs further work. + + * mpz/set_si.c: Nailify. + * mpz/set_ui.c: Nailify. + * mpz/mul_i.h: Nailify. + + * tests/mpz/t-mul_i.c: Actually test _ui routines. Add some more test + values. + + * mpn/generic/mul_n.c: Finish nailifying toom3 code. + +2002-04-13 Kevin Ryde + + * mpfr/*: Update to another new mpfr 2.0.1. + * configure.in, Makefile.am, mpfr/Makefile.am, mpfr/tests/Makefile.am: + Use MPFR_CONFIGS macro, establish separate MPFR_CFLAGS for mpfr build. + + * mpfr/tests/Makefile.am: Correction to convenience rule for libmpfr.a. + +2002-04-11 Kevin Ryde + + * mpfr/set_q.c: gmp-impl.h before mpfr.h to avoid _PROTO redefine. + + * mpfr/*, configure.in: Update to new mpfr 2.0.1. + + * tests/refmpn.c (refmpn_udiv_qrnnd, refmpn_divmod_1c_workaround): + Fixes for nails. + + * tests/t-constants.c (MODLIMB_INVERSE_3): Nailify tests. + (MP_BASES_BIG_BASE_INVERTED_10, MP_BASES_NORMALIZATION_STEPS_10): Only + check these under USE_PREINV_DIVREM_1. + * tests/t-modlinv.c: Nailify tests. + +2002-04-11 Gerardo Ballabio + + * gmpxx.h: Remove bool combinations, remove mpf_class::get_str2, only + need now. + +2002-04-11 Torbjorn Granlund + + * mpn/generic/diveby3.c: Nailify. + * gmp-impl.h (MODLIMB_INVERSE_3): Nailify. + + * mpn/generic/mul_n.c: Nailify Toom3 code. + +2002-04-10 Kevin Ryde + + * gmp-impl.h (MPN_KARA_MUL_N_MINSIZE, MPN_KARA_SQR_N_MINSIZE): Set to + 3, as needed by nails case. + + * mpn/generic/addmul_1.c, mpn/generic/submul_1.c [nails]: Fix vl + assert, add rp,n and up,n asserts. + + * mpfr/Makefile.am: Add new mpfr-math.h, install mpf2mpfr.h. + +2002-04-10 Torbjorn Granlund + + * mpn/generic/divrem_1.c: Nailify. Update mp_size_t variables to use + `n' suffix instead of `size' suffix. + * mpn/generic/divrem_2.c: Likewise. + * mpn/generic/sb_divrem_mn.c: Nailify. + * mpn/generic/tdiv_qr.c: Nailify. + (SHL): Remove silly macro. + + * mpn/generic/mul_n.c (mpn_kara_mul_n): Replace open-coded increment by + mpn_incr_u call. Handle nails in ws[n] increment. + * mpn/generic/mul_n.c (mpn_kara_sqr_n): Likewise. + + * gmp-h.in (GMP_NUMB_MASK): New #define. + (__GMPN_AORS_1): Add version for nails. + + * gmp-impl.h (GMP_NUMB_MASK): Comment out, now in gmp.h. + (mpn_incr_u): Don't assume `incr' is non-zero. + (mpn_decr_u): Similarly. + +2002-04-09 Kevin Ryde + + * mpfr/*, configure.in: Update to mpfr 2.0.1. + + * tests/refmpn.c (refmpn_mul_1c, lshift_make): Corrections for nails. + * tssts/refmpn.c, tests/tests.h (refmpn_cmp_allowzero): New function. + + * mpn/generic/mul_1.c [nails]: Fix vl assert, add {up,n} assert. + + * mpn/pa32/hppa1_1/pa7100/addmul_1.asm, + mpn/pa32/hppa1_1/pa7100/submul_1.asm: Rename "size" define, to avoid + ELF .size directive. Reported by LaMont Jones. + + * tests/mpz/t-set_si.c: Add nails support. + +2002-04-05 Torbjorn Granlund + + * gmp-impl.h: Replace nail mpn_incr_u, mpn_decr_u with faster versions. + (mp_bases[10] values): Check GMP_NUMB_BITS instead of BITS_PER_MP_LIMB. + Add GMP_NUMB_BITS == 30 version. + (__gmp_doprnt, etc): Remove parameter names. + + * mpn/generic/mul_n.c: Nailify Karatsuba code. + * mpn/generic/get_str.c: Nailify. + * mpn/generic/sqr_basecase.c: Nailify. + * mpn/generic/lshift.c: Nailify. + * mpn/generic/rshift.c: Likewise. + * mpn/generic/add_n.c: Nailify. Revamp non-nail code. + * mpn/generic/sub_n.c: Likewise. + * mpn/generic/mul_1.c: Likewise. + * mpn/generic/addmul_1.c: Likewise. + * mpn/generic/submul_1.c: Likewise. + +2002-04-02 Kevin Ryde + + * gmp-impl.h (BSWAP_LIMB_FETCH, BSWAP_LIMB_STORE) [powerpc]: + Corrections to constraints, and restrict to bigendian. + +2002-03-31 Kevin Ryde + + * tests/mpz/dive.c: Better diagnostics. + + * tests/devel/try.c (mpn_get_str, mpn_umul_ppmm_r): New tests. + + * tests/misc.c, tests/tests.h (byte_diff_lowest, byte_diff_highest): + New functions. + + * tests/t-bswap.c: New file. + * tests/Makefile.am (check_PROGRAMS): Add it. + + * tests/mpn/t-aors_1.c, tests/mpn/t-iord_u.c: Add nails support. + + * gmp-impl.h (MPN_IORD_U) [x86]: Eliminate unnecessary jiord and iord, + rename "n" to incr per generic versions, restrict to nails==0. + (mpn_incr_u, mpn_decr_u): Add nails support. + (GMP_NAIL_LOWBIT, GMP_NUMB_MAX): New macros. + + * tests/trace.c, tests/tests.h (byte_trace, byte_tracen): New + functions. + * tests/trace.c: Handle NULL operands. + + * tests/refmpn.c, tests/devel/try.c, tune/speed.c: Add preliminary + nail support. + + * tests/refmpn.c, test/tests.h (byte_overlap_p, refmpn_equal_anynail, + refmpn_umul_ppmm_r, refmpn_udiv_qrnnd_r, refmpn_get_str, + refmpn_bswap_limb, refmpn_random, refmpn_random2, refmpn_bswap_limb): + New functions. + + * gmp-impl.h, tests/refmpn.c (ASSERT_LIMB): Renamed from + ASSERT_MP_LIMB_T. + + * mpn/x86/*/*.asm, mpn/powerpc32/*/*.asm, mpn/powerpc64/*/*.asm: Put + speeds after the copyright notice, so as to keep that clear. + +2002-03-29 Kevin Ryde + + * configure.in (powerpc*-*-aix*): Correction to xlc -qarch selection, + for 32-bit mode. + +2002-03-28 Torbjorn Granlund + + * mpn: Fix spacing in many files. + + * mpn/generic/aorsmul_1.c: Split into addmul_1.c and submul_1.c. + * mpn/generic/aors_n.c: Split into add_n.c and sub_n.c. + + * mpn/pa64/add_n.asm: Trim another 0.125 cycle/limb. Fix a comment. + * mpn/pa64/sub_n.asm: Likewise. + + * mpn/pa64/mul_1.asm: Change comclr, comb to proper forms cmpclr, cmpb. + * mpn/pa64/addmul_1.asm: Likewise. + * mpn/pa64/submul_1.asm: Likewise. + +2002-03-28 Kevin Ryde + + * gmp.texi (Converting Integers): Fix type of exp in mpz_get_d_2exp, + reported by epl@unimelb.edu.au. + (References): Update Burnikel and Ziegler URL, reported by Keith + Briggs. + + * gmp-h.in, mp-h.in, configure.in, acinclude.m4: Remove __GMP from + AC_SUBSTs, since autoconf says leading "_" in makefile variables is + not portable. + + * demos/expr/run-expr.c: Declare optarg, optind, opterr if necessary. + * configure.in, demos/expr/expr-config-h.in: Configs for this. + +2002-03-27 Torbjorn Granlund + + * mpn/Makefile.am (TARG_DIST): Remove pa64w and hppa, add pa32. + + * configure.in (path_20w): Remove pa64w. + + * mpn/pa64/udiv_qrnnd.asm: Tweak for PA8000 performance comparative to + that on PA8500. + +2002-03-26 Torbjorn Granlund + + * mpn/pa32: New name for mpn/hppa. + * configure.in: Corresponding changes. + + * mpn/pa64/umul_ppmm.asm: New file, generalized for both 2.0N and 2.0W. + * mpn/pa64/umul_ppmm.S: Remove. + + * mpn/pa64/udiv_qrnnd.asm: Generalize for both 2.0N and 2.0W. + * mpn/pa64w/udiv_qrnnd.asm: Remove. + +2002-03-26 Kevin Ryde + + * mpfr/tests/tdiv.c, mpfr/tests/tui_div.c: Don't depend on nan and inf + handling in "double", for the benefit of alpha. + + * configure (hppa2.0w): Set path to "pa64w pa64". + + * acinclude.m4, configure.in (GMP_C_INLINE): New macro. + * acinclude.m4 (GMP_H_EXTERN_INLINE): Use it, and fix "yes" handling. + +2002-03-25 Torbjorn Granlund + + * mpn/pa64w/add_n.s: Remove. + * mpn/pa64w/sub_n.s: Remove. + * mpn/pa64w/lshift.s: Remove. + * mpn/pa64w/rshift.s: Remove. + * mpn/pa64w/mul_1.S: Remove. + * mpn/pa64w/addmul_1.S: Remove. + * mpn/pa64w/submul_1.S: Remove. + * mpn/pa64w/sqr_diagonal.asm: Remove. + + * mpn/pa64/mul_1.asm: New file with twice faster code; generalized + for both 2.0N and 2.0W. + * mpn/pa64/submul_1.asm: Likewise. + * mpn/pa64/mul_1.S: Remove. + * mpn/pa64/submul_1.S: Remove. + + * mpn/pa64/sqr_diagonal.asm: Generalize for both 2.0N and 2.0W. + + * mpn/pa64/add_n.asm: New file, generalized for both 2.0N and 2.0W. + * mpn/pa64/sub_n.asm: Likewise. + * mpn/pa64/lshift.asm: Likewise. + * mpn/pa64/rshift.asm: Likewise. + * mpn/pa64/add_n.s: Remove. + * mpn/pa64/sub_n.s: Remove. + * mpn/pa64/lshift.s: Remove. + * mpn/pa64/rshift.s: Remove. + +2002-03-24 Kevin Ryde + + * gmp-impl.h (BSWAP_LIMB_FETCH, BSWAP_LIMB_STORE): New macros. + * mpz/inp_raw.c, mpz/out_raw.c: Use them. + * acconfig.h (HAVE_HOST_CPU): Add some powerpc types. + + * mpn/powerpc32/750/com_n.asm: New file. + + * mpfr/tests/tout_str.c: Disable random tests, since they fail on + alphaev56-unknown-freebsd4.1 and do nothing by default. + + * mpfr/tests/tsqrt.c: Don't depend on nan, inf or -0 in "double", for + the benefit of alpha. + * mpfr/sqrt.c: Clear nan flag on -0. + + * demos/factorize.c: Use mpn_random() instead of random(), to avoid + portability problems. + + * demos/isprime.c (print_usage_and_exit): Declare as "void" to avoid + warnings. + + * demos/pexpr.c (setup_error_handler): Corrections to sigstack code. + + * demos/calc/calc.y: Add some `;'s to make bison 1.34 happy. + +2002-03-23 Torbjorn Granlund + + * mpn/pa64/addmul_1.asm: New file with twice faster code; generalized + for both 2.0N and 2.0W. + +2002-03-22 Kevin Ryde + + * tune/time.c: Add SGI hardware counter measuring method, change some + abort()s into ASSERT_FAIL()s. + + * configure.in (AC_CHECK_HEADERS): Add fcntl.h and sys/syssgi.h. + (AC_CHECK_FUNCS): Add syssgi. + + * configure.in, mpfr/Makefile.am, mpfr/tests/Makefile.am: Use + -mieee-with-inexact or -ieee_with_inexact for mpfr on alpha, so + denorms work. + + * mpfr/isinteger.c: Fix a memory leak. + +2002-03-21 Torbjorn Granlund + + * tune/speed.c (struct choice_t): Make `r' an mp_limb_t. + +2002-03-21 Kevin Ryde + + * configure.in (HAVE_LIMB_BIG_ENDIAN, HAVE_LIMB_LITTLE_ENDIAN): Use an + AH_VERBATIM and better explanation. + * acinclude.m4 (GMP_C_DOUBLE_FORMAT): Similarly for the HAVE_DOUBLE + constants. + + * gmp.texi (Number Theoretic Functions): Clarify sign of GCD returned + by mpz_gcdext. + + * demos/pexpr.c, demos/pexpr-config-h.in, configure.in: Use an + autoconf test for stack_t. + + * configure.in, gmp-h.in, mp-h.in, macos/configure, tests/mpz/reuse.c, + tests/mpf/reuse.c: Use __GMP_LIBGMP_DLL to enable windows declspec, + don't require _WIN32 (etc), remove __GMP_LIBGMP_SHARED and + __GMP_LIBGMP_STATIC. + + * gmp-impl.h (mp_bases): Add __GMP_DECLSPEC, for the benefit of + tests/t-constants.c. + + * tune/many.pl, tune/speed.h: Remove suffix hack for back.asm. + +2002-03-21 Paul Zimmermann + + * mpfr/sin_cos.c (mpfr_sin_cos): New file. + * mpfr/mpfr.h, mpfr/mpfr.texi, mpfr/Makefile.am: Add it. + * mpfr/tan.c: Fix sign in 2nd and 4th quadrants. + + * mpfr/log10.c: Fix hangs on certain inputs. + +2002-03-20 Torbjorn Granlund + + * demos/pexpr.c (setup_error_handler): Declare `s', the first + sigaltstack parameter, using `stack_t' just on AIX. + +2002-03-19 Torbjorn Granlund + + * mpn/powerpc32/mul_1.asm: Use free caller-saves registers instead + of the callee-saves r30 and r31. + +2002-03-19 Kevin Ryde + + * tune/freq.c (freq_proc_cpuinfo): Recognise powerpc "clock", where + previously got the wrong result from "bogomips". + + * mpn/powerpc32/add_n.asm, mpn/powerpc32/sub_n.asm: Rewrite, faster on + 750, and smaller too. + * mpn/powerpc32/*.asm: Use L(), add some measured speeds. + + * longlong.h (count_trailing_zeros) [vax]: Add a version using ffs, + but commented out. + +2002-03-17 Kevin Ryde + + * tune/speed.c, tune/speed.h, tune/common.c, many.pl: Use optional + ".r" to specify operand overlaps for mpn_add_n, mpn_sub_n and logops. + Remove mpn_add_n_inplace and mpn_add_n_self. + * tune/many.pl: Fix MULFUNC_PROLOGUE parsing. + + * gmp.texi (Known Build Problems): Note `make' problem with long + libgmp.la dependencies list. + + * printf/doprnt.c, scanf/doscan.c (%zn): Remove test of non-existent + HAVE_SIZE_T, just use size_t unconditionally. + * printf/doprnt.c (%zd etc): Fix 'z' type parsing. + * tests/misc/t-printf.c, tests/misc/t-scanf.c: More tests. + + * configure.in: Use AC_COPYRIGHT. + Add m4_pattern_allow(GMP_MPARAM_H_SUGGEST). + + * tune/Makefile.am (libdummy.la): Remove this, sqr_basecase.c already + gets an ansi2knr rule from nodist_tuneup_SOURCES. + + * longlong.h (count_leading_zeros) [pentiumpro gcc<3]: Test + HAVE_HOST_CPU_i686 too. + + * mpz/out_raw.c (HTON_LIMB_STORE): Fix a typo in big endian #if. + +2002-03-14 Kevin Ryde + + * mpn/x86/pentium/com_n.asm, mpn/x86/pentium/logops_n.asm, + mpn/x86/k6/mmx/com_n.asm: Add nails support. + + * texinfo.tex: Update to 2002-03-01.06 (per texinfo 4.1). + * gmp.texi (@ma): Remove, @math does this now. + + * mpfr/tests/reuse.c: Clear op1 and op2 flags only in their respective + outer loops. + + * configure.in (--enable-cxx): Correction to the default stated in the + help string. + (power*-*-aix*, not powerpc): Use aix.m4, don't run + GMP_ASM_POWERPC_R_REGISTERS or use powerpc-defs.m4. + +2002-03-13 Torbjorn Granlund + + * mpn/sparc32/gmp-mparam.h: New file. + +2002-03-13 Kevin Ryde + + * demos/expr/exprfr.c: More mpfr functions, corrections to agm, cos, + sin, rename log2 constant to loge2 to make room for log2 function. + * demos/expr/t-expr.c: More tests. + + * mpz/inp_raw.c (NTOH_LIMB_FETCH) [generic 16bit]: Remove spurious "+". + + * mpfr/acos.c: Avoid a memory leak for certain operands. + + * acinclude.m4, configure.in (GMP_C_DOUBLE_FORMAT): New macro. + + * acinclude.m4 (GMP_HPC_HPPA_2_0, GMP_ASM_UNDERSCORE, + GMP_ASM_ALIGN_LOG, GMP_ASM_LSYM_PREFIX, GMP_ASM_W32, GMP_ASM_X86_MMX): + Change ac_objext to OBJEXT, which is the documented variable. + + * config.guess (powerpc*-*-*): Use #ifdef on constants POWER_630 etc + in the AIX test, since old versions don't have them all. + +2002-03-11 Kevin Ryde + + * configure.in (LIBC211): New AC_DEFINE, for mpfr. + + * configure.in (mips*-*-*): Support ABI=o32 on irix 6, allow gcc 2.7.2 + to fall back on it, but detect it doesn't work with gcc 2.95. Use + single mips-defs.m4 for both mips32 and mips64. + * acinclude.m4 (GMP_GCC_MIPS_O32): New macro. + * mpn/mips32/mips-defs.m4: Renamed from mips.m4. + * mpn/mips64/mips.m4: Remove (was a copy of mips32/mips.m4). + + * mpn/powerpc32/750: New directory. + * configure.in (powerpc740, powerpc750, powerpc7400): Use it. + * mpn/powerpc32/750/gmp-mparam.h: New file. + + * config.sub, gmp.texi (ultrasparc1): Remove this, just use plain + "ultrasparc". + +2002-03-10 Kevin Ryde + + * mpfr: Update to 20020301, except internal_ceil_exp2.c, + internal_ceil_log2.c, internal_floor_log2.c renamed to i_ceil_exp2.c, + i_ceil_log2.c, i_floor_log2.c to be unique in DOS 8.3. And sqrtrem.c + removed since no longer required. + * mpfr/mpfr.texi: Fix some formatting. + * mpfr/tests/reuse.c: Patch by Paul to fix test4 variable handling. + * mpfr/sinh.c: Patch by Paul to fix err calculation when t==0. + * mpfr/tests/tget_d.c: Disable until portability of rnd_mode.c can be + sorted out. + + * configure.in (powerpc*-*-*): Separate gcc and xlc cpu flags setups + for clarity. + + * longlong.h (count_leading_zeros, count_trailing_zeros) [x86_64]: New + macros. + +2002-03-07 Kevin Ryde + + * gmp.texi (Build Options): Note all the ultrasparcs accepted. + (Language Bindings): Add Math::BigInt::GMP. + + * config.sub (ultrasparc2i): New cpu type. + * config.guess (sparc-*-*, sparc64-*-*): Add some exact CPU detection. + +2002-03-05 Kevin Ryde + + * longlong.h (count_leading_zeros, count_trailing_zeros) [alphaev67, + alphaev68]: Use ctlz and cttz insns (as per gcc longlong.h). + (count_leading_zeros) [sparclite]: Fix parameter order (as per gcc + longlong.h). + * acconfig.h (HAVE_HOST_CPU_alphaev68): New define. + + * config.guess [i?86-*-*]: Suppress error messages if compiler not + found or test program won't run. + [rs6000-*-*, powerpc-*-*]: Force code alignment for mfpvr test. + +2002-03-04 Torbjorn Granlund + + * mpn/generic/pow_1.c: New file. + +2002-03-03 Kevin Ryde + + * gmp.texi (Build Options): Note compiler must be able to fully link, + add alphapca57 and alphaev68, give a clearer example of MPN_PATH + (Debugging): Add notes on valgrind. + (C++ Formatted Output): Clarify mpf showbase handling, in particular + note "00.4" in octal. + + * printf/doprntf.c: Do a showbase on octal float fractions, for + instance "00.4" where previously it gave "0.4". + * tests/cxx/t-ostream.cc: Update. + + * gmp-h.in, mp-h.in (__GMP_DECLSPEC, __GMP_DECLSPEC_XX): Test + __WIN32__ for Borland C, reported by "delta trinity". + + * gmp-h.in, mp-h.in: Use for size_t under C++, suggested by + Hans Aberg some time ago. + * gmp-h.in (): Move to top of file for clarity. + + * Makefile.am (libgmpxx_la_SOURCES): Use dummy.cc to force C++. + (CXX_OBJECTS): Add osfuns$U.lo. + * dummy.cc: New file. + * cxx/Makefile.am (INCLUDES): Use __GMP_WITHIN_GMPXX. + (libcxx_la_SOURCES): Add osfuns.cc. + * gmp-h.in (__GMP_DECLSPEC_XX): New define, use it on libgmpxx funs. + * gmp-impl.h: Add __GMP_DECLSPEC to libgmp functions used by libgmpxx. + + * longlong.h (COUNT_TRAILING_ZEROS_TIME): Remove, no longer used. + + * gmp-impl.h (MPN_SIZEINBASE, MPN_SIZEINBASE_16): Correction to + __totbits for nails. + + * gmp-impl.h (JACOBI_LS0): Test size before limb, to pacify valgrind. + (JACOBI_0LS): Ditto, and fix parens around arguments. + + * mpn/x86/x86-defs.m4 (call_mcount): Add a counter to make data labels + unique, since simplified L() scheme no longer gives that effect. + (notl_or_xorl_GMP_NUMB_MASK): New macro. + Add m4_assert_numargs in a few places. + + * configure.in (*sparc*): Fix cycle counter setups for ABI=64. + +2002-02-28 Torbjorn Granlund + + * mpn/vax/gmp-mparam.h: New file. + +2002-02-28 Kevin Ryde + + * gmp-h.in (gmp_errno, gmp_version): Move into extern "C" block, + reported by librik@panix.com. + + * gmp-h.in, mp-h.in (__GMP_DECLSPEC_EXPORT, __GMP_DECLSPEC_IMPORT): + Use __declspec(dllexport) and __declspec(dllimport) on Borland. + * gmp-h.in (_GMP_H_HAVE_FILE): Test __STDIO_H for Borland. + Reported by "delta trinity". + + * gmp-impl.h (va_copy): Fall back on memcpy, not "=". + + * mpn/generic/pre_mod_1.c: Add a comment about obsolescence. + + * tune/time.c (MICROSECONDS_P): Don't trust time differences of 1 + microsecond. + + * tests/cxx/t-ostream.cc: Use "const char *" not just "char *" for + test data strings, avoids warnings on Sun CC. + +2002-02-27 Torbjorn Granlund + + * configure.in: For sparc under solaris2.[7-9], pass -fsimple=1 to + disable some crazy -fast optimizations. + +2002-02-25 Torbjorn Granlund + + * configure.in: For sparc under solaris2.[7-9], pass -fns=no to enable + denorm handling under -fast. + +2002-02-25 Kevin Ryde + + * configure.in (alpha*-*-*): Rearrange -mcpu selection for gcc, + provide an ev67 -> ev6 fallback. Fix -arch,-tune selection for DEC C. + Allow ~ for space in optional options lists. + + * tune/tuneup.c (tune_preinv_divrem_1): Compare against an assembler + mpn_divrem_1 if it exists, not the generic C mpn_divrem_1_div. + (tune_preinv_mod_1): Ditto with mpn_mod_1. + + * tune/time.c (DIFF_SECS_ROUTINE): Eliminate the unused "type" + parameter, try to make the code a bit clearer. + + * tune/freq.c: Reduce the period measured for cycles versus + gettimeofday, add cycles versus microsecond getrusage. + + * mpz/array_init.c: "i" should be mp_size_t, noticed by E. Khong. + +2002-02-24 Torbjorn Granlund + + * configure.in: For sparc under solaris2.[7-9], pass -fast instead of + other optimization options. + +2002-02-23 Kevin Ryde + + * mpn/asm-defs.m4 (GMP_NUMB_MASK): New macro. + (PROLOGUE, EPILOGUE): Relax quoting for the benefit of tune/many.pl + when GSYM_PREFIX non-empty. + + * tune/time.c, tune/speed.h (speed_time_init): Include clock tick + period in speed_time_string. + * tune/time.c, configure.in (clock_gettime): New measuring method. + + * tune/many.pl: Add -DHAVE_NATIVE_mpn_foo to C objects, to avoid + conflicts with a macro version in gmp-impl.h, eg. mpn_com_n. + +2002-02-22 Torbjorn Granlund + + * demos/pexpr.c: Increase RLIMIT_STACK to 4Mibyte. + +2002-02-22 Kevin Ryde + + * tune/tuneup.c: Don't confuse gcc with mipspro cc in diagnostic. + +2002-02-20 Torbjorn Granlund + + * configure.in (mips*-*-irix[6789]*]): Set `extra_functions_n32', not + `extra_functions'. + + * printf/doprnt.c: Conditionally include inttypes.h. + * printf/repl-vsnprintf.c: Likewise. + * scanf/doscan.c: Likewise. + +2002-02-20 Kevin Ryde + + * mpn/x86/k7/mmx/com_n.asm: New file. + + * mpz/n_pow_ui.c (SWAP_RP_TP): Use ASSERT_CODE on ralloc and talloc, + to ensure they needn't live past the initial allocs in a normal build. + + * mpn/generic/mod_34lsub1.c: Note this is for internal use. + +2002-02-19 Torbjorn Granlund + + * Clean up *_THRESHOLD names. Many files affected. + + * mpn/mips32: Asm-ify 32-bit mips code. + Move files from `mips2' to `mips32' directory. + * mpn/mips64: Move files from `mips3' to `mips64' directory. + * configure.in: Change `mips2' => `mips32' and `mips3' => `mips64'. + +2002-02-19 Kevin Ryde + + * acinclude.m4, configure.in (GMP_PROG_LEX): New macro. + + * tune/tuneup.c (one): Start next threshold at a max of previous ones, + in order to get a good starting point for TOOM3_SQR_THRESHOLD if + KARATSUBA_SQR_THRESHOLD is 0 (ie. using mpn_mul_basecase only). + + * configure.in, tune/tuneup.c (GMP_MPARAM_H_SUGGEST): New AC_DEFINE + replacing GMP_MPARAM_H_FILENAME. Suggest a new file in a cpu specific + subdirectory rather than mpn/generic. + + * acinclude.m4 (POWERPC64_PATTERN): New macro. + * configure.in (powerpc*-*-*): Use it. + (powerpc*-*-*): Use umul in 32L and aix64. + (mips*-*-*): Use umul, 32 and 64 bit versions. + +2002-02-18 Torbjorn Granlund + + * longlong.h: Add basic x86-64 support. + +2002-02-17 Torbjorn Granlund + + * demos/pexpr.c: Support `-X' for upper case hex, make `-x' output + lower case hex. + + * mpn/mips2/umul.s: Make it actually work. + * mpn/mips3/umul.asm: New file. + + * mpn/mips2/gmp-mparam.h: New file. + +2002-02-16 Torbjorn Granlund + + * mpn/generic/get_str.c (mpn_sb_get_str): Round frac upwards after + umul_ppmm calls. + +2002-02-16 Kevin Ryde + + * config.guess (alpha-*-*): Do alpha exact cpu probes on any system, + and only if configfsf.guess gives a plain "alpha". + + * acinclude.m4 (GMP_PROG_CC_WORKS): Detect a gcc 3.0.3 powerpc64 + linker invocation problem. + +2002-02-15 Torbjorn Granlund + + * mpn/generic/get_str.c (mpn_sb_get_str): For base 10, develop initial + digits using umul_ppmm, then switch to plain multiplication. + + * config.guess: Rewrite Alpha subtype detection code for *bsd systems. + +2002-02-15 Kevin Ryde + + * gmp.texi (Build Options): Note powerpc exact cpu types. + (Debugging): Advertise DEBUG in memory.c. + + * config.sub, config.guess: Add some powerpc exact cpus. + * configure.in: Add configs for them. + + * memory.c [__NeXT__]: Remove unused #define of "static". + (__gmp_default_allocate, __gmp_default_reallocate): Print size if + allocation fails, don't use perror. + + * gmp-h.in: g++ 3 demands __GMP_NOTHROW is before other attributes. + +2002-02-14 Torbjorn Granlund + + * mpn/alpha/mul_1.asm: Fix typo preventing build on T3E systems. + +2002-02-14 Kevin Ryde + + * tune/tuneup.c (tune_set_str): Increase max_size, for the benefit of + alpha. + + * macos/README: Bug reports to bug-gmp@gnu.org, clarify MacOS X a bit. + + * mpn/generic/gcdext.c [WANT_GCDEXT_ONE_STEP]: Add missing TMP_FREE. + + * tune/speed.c, tune/tuneup.c: Allow for speed_cycletime of 0.0 in + some diagnostic printouts. + * tune/time.c (speed_cycletime): Note can be 0.0. + +2002-02-12 Torbjorn Granlund + + * mpn/alpha/mul_1.asm: Add mpn_mul_1c entry. + + * mpn/pa64w/sqr_diagonal.asm: Use L() for labels. + +2002-02-11 Torbjorn Granlund + + * mpn/generic/get_str.c (mpn_sb_get_str): Change declaration of rp to + accommodate tuneup compiles. + +2002-02-11 Kevin Ryde + + * mpn/alpha/default.m4, mpn/alpha/unicos.m4 (PROLOGUE_cpu): Add + noalign option. + * mpn/alpha/default.m4 (PROLOGUE_cpu): use ALIGN instead of ".align". + + * gmp.texi (Debugging): Notes on Checker. + (Other Multiplication): Move note on float FFTs to here. + (Assembler Floating Point): New text and revisions by Torbjorn, + picture formatting by me. + Simplify tex pictures elsewhere a bit, share heights, eliminate some + gaps at line joins. + +2002-02-11 Torbjorn Granlund + + * mpn/generic/get_str.c (mpn_sb_get_str): Rewrite to generate fraction + limbs and use multiplication for digit development. Trim allocation of + buf. Get rid of code for !USE_MULTILIMB. + +2002-02-10 Torbjorn Granlund + + * mpn/generic/set_str.c (mpn_set_str): Undo this: + Change invocations of mpn_add_1 to instead use mpn_incr_u. + + * tests/mpz/convert.c: Free str only after it is used in error message. + + * mpn/generic/get_str.c (mpn_sb_get_str): Combine tail code for base 10 + and generic bases. + + * mpn/mp_bases.c: Add entries for base 256. Remove __ prefix from + table name. + * gmp-impl.h (__mp_bases): Remove superfluous mp_ part of name, making + it __gmpn_bases instead of __gmpn_mp_bases. + (mp_bases): New #define. + * tune/speed.h (SPEED_ROUTINE_MPN_SET_STR): Allow bases up to 256. + (SPEED_ROUTINE_MPN_GET_STR): Likewise. + +2002-02-09 Torbjorn Granlund + + * mpn/generic/set_str.c (mpn_set_str): Use mpn_mul_1c if available. + Change invocations of mpn_add_1 to instead use mpn_incr_u. + +2002-02-09 Kevin Ryde + + * mpz/array_init.c, mpz/cfdiv_q_2exp.c, mpz/cfdiv_r_2exp.c, + mpz/cong_2exp.c, mpz/divis_2exp.c, mpz/hamdist.c, mpz/init2.c, + mpz/mul_2exp.c, mpz/realloc2.c, mpz/scan0.c, mpz/scan1.c, + mpz/setbit.c, mpz/tdiv_q_2exp.c, mpz/tdiv_r_2exp.c, mpz/tstbit.c, + mpz/urandomb.c: Use GMP_NUMB_BITS. + + * mpz/iset_str.c [__CHECKER__]: Store a dummy value to the low limb to + stop it appearing uninitialized. + + * gmp-h.in (__GMP_NOTHROW): New macro. + (mp_set_memory_functions, mpz_cmp, mpz_cmp_si, mpz_cmp_ui, mpz_cmpabs, + mpz_cmpabs_ui, mpz_congruent_2exp_p, mpz_divisible_2exp_p, + mpz_fits_sint_p, mpz_fits_slong_p, mpz_fits_sshort_p, mpz_fits_uint_p, + mpz_fits_ulong_p, mpz_fits_ushort_p, mpz_get_si, mpz_get_ui, + mpz_getlimbn, mpz_hamdist, mpz_popcount, mpz_scan0, mpz_scan1, + mpz_size, mpz_sizeinbase, mpz_swap, mpz_tstbit, mpq_equal, mpq_swap, + mpf_cmp, mpf_cmp_si, mpf_cmp_ui, mpf_fits_sint_p, mpf_fits_slong_p, + mpf_fits_sshort_p, mpf_fits_uint_p, mpf_fits_ulong_p, + mpf_fits_ushort_p, mpf_get_default_prec, mpf_get_prec, mpf_get_si, + mpf_get_ui, mpf_integer_p, mpf_set_default_prec, mpf_set_prec_raw, + mpf_size, mpf_swap, mpn_add_1, mpn_cmp, mpn_hamdist, mpn_popcount, + mpn_sub_1): Use it. + + * gmp-impl.h (MPN_SIZEINBASE, MPN_SIZEINBASE_16): New macros from + mpn_sizeinbase, and use GMP_NUMB_BITS. + * mpz/get_str.c, mpz/sizeinbase.c, mpbsd/mout.c, tune/speed.h: Use + MPN_SIZEINBASE. + * mpbsd/mtox.c: Use MPN_SIZEINBASE_16. + + * configure.in, mpn/Makefile.am, gmp-impl.h (mpn_sizeinbase): Remove. + * mpn/generic/sizeinbase.c: Remove file. + + * gmp-impl.h (MPN_GET_STR_SIZE): Remove. + * tests/mpn/t-g_str_size.c: Remove file. + * tests/mpn/Makefile.am: Update. + + * Makefile.am (dist-hook): Don't distribute cvs merge ".#" files. + +2002-02-08 Torbjorn Granlund + + * configure.in: Override extra_functions for all sparcv8 systems, not + just supersparc. + +2002-02-06 Kevin Ryde + + * tune/tuneup.c (tune_mul, tune_sqr): Disable FFTs until tuned. + * tune/speed.h (SPEED_ROUTINE_MPN_SET_STR): Fix memory clobber in + destination cache priming. + + * printf/doprnt.c: Fix parsing of %s and %p conversions. + * tests/misc/t-printf.c (check_misc): Add some tests. + +2002-02-03 Torbjorn Granlund + + * mpn/sparc32/v8/udiv.asm: New file, from v8/supersparc. + + * mpn/generic/set_str.c: Rename indigits_per_limb => chars_per_limb. + Remove redundant chars_per_limb. Reverse 4 loops in basecase code for + speed. Use MP_BASES_CHARS_PER_LIMB_10. + +2002-02-03 Kevin Ryde + + * acinclude.m4 (GMP_PROG_NM): Ensure -B or -p get used when doing a + cross compile with the native nm, helps OSF for instance. + (GMP_ASM_LSYM_PREFIX): Remove ".byte 0" for the benefit of irix 6, + allow "N" from nm for OSF, allow for "t" for other systems, but prefer + no mention of the symbol at all. + + * tune/tuneup.c (print_define_remark): New function. + Turn some "#if"s into plain "if"s. + + * tune/tuneup.c, gmp-impl.h, tune/Makefile.am + (GET_STR_BASECASE_THRESHOLD, GET_STR_PRECOMPUTE_THRESHOLD): Tune these. + * mpn/generic/get_str.c [TUNE_PROGRAM_BUILD]: Cope with non-constant + GET_STR_PRECOMPUTE_THRESHOLD. + +2002-02-02 Torbjorn Granlund + + * mpn/generic/get_str.c (mpn_get_str): Fix typo in a declaration. + +2002-02-02 Kevin Ryde + + * mpn/generic/set_str.c: Use MP_PTR_SWAP and POW2_P, add __GMP_PROTO + to convert_blocks prototype, disable SET_STR_BLOCK_SIZE sanity check. + + * tune/set_strb.c, tune/set_strs.c: New files. + * tune/speed.h, tune/speed.c, tune/common.c,tune/Makefile.am: Add them. + * tune/tuneup.c: Tune SET_STR_THRESHOLD. + (DEFAULT_MAX_SIZE): Renamed from MAX_SIZE, allow any param.max_size[]. + +2002-02-01 Torbjorn Granlund + + * tests/mpz/convert.c: Increase operand size. Add (yet disabled) code + for testing with random strings. + + * mpn/generic/get_str.c (mpn_get_str): Rewrite to become sub-quadratic. + (mpn_dc_get_str, mpn_sb_get_str): New functions. + +2002-01-31 Kevin Ryde + + * gmpxx.h (cmp): Renamed from "compare". + + * configure.in (AC_C_BIGENDIAN): Don't abort when cross compiling. + (PROLOGUE): Allow new style optional second parameter when grepping. + + * acinclude.m4 (GMP_HPC_HPPA_2_0, GMP_ASM_UNDERSCORE, + GMP_ASM_ALIGN_LOG, GMP_ASM_LSYM_PREFIX, GMP_ASM_W32, GMP_ASM_X86_MMX): + Use $ac_objext for object filenames. + (GMP_ASM_UNDERSCORE): Use CCAS to assemble. + + * demos/pexpr-config-h.in: New file. + * configure.in: Generate demos/pexpr-config.h. + (AC_CHECK_FUNCS): Add clock, cputime, setrlimit, sigaction, + sigaltstack, sigstack. + * acinclude.m4 (GMP_SUBST_CHECK_FUNCS, GMP_SUBST_CHECK_HEADERS): New + macros. + * demos/pexpr.c: Use pexpr-config.h, not various #ifdefs. + (setup_error_handler): Use signal if sigaction not available, allow + for SIGBUS missing on mingw. + (main): Use time() for random seed if gettimeofday not available. + (cleanup_and_exit): Move SIGFPE out of LIMIT_RESOURCE_USAGE. + +2002-01-30 Torbjorn Granlund + + * mpn/generic/set_str.c: Rewrite to become sub-quadratic. + (convert_blocks): New function. + +2002-01-30 Kevin Ryde + + * gmp-impl.h (GMP_NUMB_MASK, GMP_NAIL_MASK, GMP_NUMB_HIGHBIT, + ASSERT_MPN, ASSERT_MP_LIMB_T): New macros. + + * mpn/generic/fib2_ui.c: Use GMP_NUMB_BITS, simplify the data + generator program, share __gmp_fib_table initializers between bit + sizes, cope with bit sizes other than those specifically setup. + * gmp-impl.h (FIB_TABLE_LIMIT, FIB_TABLE_LUCNUM_LIMIT): Corresponding + rearrangement of conditionals. + * tests/mpz/t-fib_ui.c (check_fib_table): New test. + +2002-01-28 Kevin Ryde + + * mpz/set_si.c, mpz/iset_si.c: Store to _mp_d[0] unconditionally, use + an expression for _mp_size. + + * mpz/init.c, mpz/init2.c, mpz/iset.c, mpq/init.c [__CHECKER__]: Store + dummy values to low limbs to stop them appearing uninitialized. + +2002-01-26 Kevin Ryde + + * mpfr/mpfr-test.h (MAX, MIN, ABS): Use instead a patch from Paul and + Vincent. + +2002-01-24 Kevin Ryde + + * configure.in: Extra quoting to get argument help messages right. + + * gmp.texi (Efficiency): Suggest hex or octal for input and output. + (Formatted Output Strings): Mention "*" for width and precision. + + * mpn/generic/sizeinbase.c: New file, adapted from mpz/sizeinbase.c. + Use POW2_P, use __mp_bases[base].big_base for log2(base). + * configure.in, mpn/Makefile.am: Add it. + * gmp-impl.h: Add prototype. + * mpz/sizeinbase.c, tune/speed.h, mpn/generic/get_str.c, + mpz/get_str.c, mpbsd/mout.c, mpbsd/mtox.c: Use it. + * mpz/get_str.c: Write directly to user buffer, skip at most one + leading zero, eliminate special case for x==0. + * mpbsd/mtox.c: Allocate exact result space at the start, eliminate + special case for x==0. + * mpbsd/mout.c: Only need to skip one high zero with mpn_sizeinbase. + + * configure.in (--enable-nails): New option. + (GMP_NAIL_BITS, GMP_LIMB_BITS, GMP_NUMB_BITS): New defines for gmp.h + and config.m4. + * gmp-h.in: Add templates. + + * mpfr/mpfr-test.h (MAX, MIN, ABS): Use #ifndef to avoid a redefine + error on AIX xlc. + +2002-01-23 Torbjorn Granlund + + * mpn/generic/get_str.c: Correct type of `out_len'. + +2002-01-22 Kevin Ryde + + * mpn/generic/pre_divrem_1.c: Corrections to some ASSERTs. + + * mpfr/mul_ui.c: Don't call mpn_lshift with 0 shift. + + * mpfr/mpz_set_fr.c: Produce correct mpz_t for f==0. + +2002-01-21 Torbjorn Granlund + + * longlong.h (32-bit powerpc add_ssaaaa): Remove spurious commutative + declaration. + (64-bit powerpc add_ssaaaa): Likewise. + +2002-01-20 Kevin Ryde + + * acinclude.m4 (GMP_FUNC_VSNPRINTF): Use %n to better detect sparc + solaris 2.7 problems. + +2002-01-19 Torbjorn Granlund + + * demos/pexpr.c (mpz_eval_expr): Optimize s^rhs for -1 <= s <= 1. + (cleanup_and_exit): Improve error message wording. + +2002-01-19 Kevin Ryde + + * mpfr/mpfr.h (_PROTO): Use __GMP_PROTO, for compatibility with + gmp-impl.h. + +2002-01-17 Torbjorn Granlund + + * mpfr/mpfr-test.h: Test "__hpux", not "hpux". Mask off mrand48 + return value to 31 bits to work around sloppy mpfr #include practices. + + * mpfr/tests/*.c: Use #include "", not <>, for gmp.h and mpfr.h. + Make sure to #include mpfr-test.h from all files that use random(). + +2002-01-17 Kevin Ryde + + * gmp-impl.h (__GMP_REALLOCATE_FUNC_MAYBE_TYPE): New macro. + * gmp-impl.h, mpz/get_str.c, mpz/out_raw.c, mpq/get_str.c, + mpq/set_str.c, mpf/get_str.c, printf/asprntffuns.c, printf/doprnt.c, + printf/repl-vsnprintf.c, printf/snprntffuns.c, scanf/doscan.c, + mpbsd/mtox.c: Some fixes to compile as C++. + + * mpn/generic/jacbase.c (JACOBI_BASE_METHOD): New tuned parameter, + replacing COUNT_TRAILING_ZEROS_TIME test. Add a third method too. + * tune/speed.c, tune/speed.h, tune/common.c, tune/Makefile.am: Add + measuring of mpn_jacobi_base methods. + * tune/jacbase1.c, tune/jacbase2.c, tune/jacbase3.c: New files. + * tune/tuneup.c (JACOBI_BASE_METHOD): Tune this. + * mpn/x86/*/gmp-mparam.h (COUNT_TRAILING_ZEROS_TIME): Remove macro. + + * gmp-h.in: Use __gmp prefix on variables in inlines. + + * gmp-impl.h (MPN_COPY_INCR, MPN_COPY_DECR): Remove __i, unused. + + * mpn/generic/mul_fft.c: Use HAVE_NATIVE_mpn_addsub_n, not ADDSUB. + Use CNST_LIMB for some constants. + +2002-01-15 Kevin Ryde + + * tests/mpbsd/Makefile.am: Add a convenience rule for ../libtests.la. + + * printf/Makefile.am: libdummy.la should be in EXTRA_LTLIBRARIES. + + * mpf/out_str.c: Use MPF_SIGNIFICANT_DIGITS, so mpf_out_str and + mpf_get_str give the same for ndigits==0. + + * mpfr/exceptions.c (mpfr_set_emin, mpfr_set_emax): Work around a + powerpc64 gcc 3.0 -O2 bug. + + * tests/memory.c, tests/tests.h (tests_memory_validate): New function. + +2002-01-14 Kevin Ryde + + * mpn/generic/sb_divrem_mn.c, mpn/generic/divrem_1.c, + mpn/generic/divrem_2.c, mpn/generic/mod_1.c: Don't use UMUL_TIME and + UDIV_TIME, just default to preinv. + * gmp-impl.h (USE_PREINV_DIVREM_1, USE_PREINV_MOD_1): Ditto. + (DIVEXACT_1_THRESHOLD, MODEXACT_1_ODD_THRESHOLD): Don't use UMUL_TIME + and UDIV_TIME, make default thresholds 0. + (UDIV_NORM_PREINV_TIME, UDIV_UNNORM_PREINV_TIME): Remove macros. + * mpn/x86/*/gmp-mparam.h (UMUL_TIME, UDIV_TIME, + UDIV_NORM_PREINV_TIME): Remove macros. + + * gmp.texi (Headers and Libraries): New section, being the header + notes from "GMP Basics" and some new stuff. + (Parameter Conventions): Notes on "const" parameters. + (Formatted Output Strings): Add type N, tweak some wording. + + * tests/refmpn.c (refmpn_divmod_1c): Avoid a bug in i386 gcc 3.0. + +2002-01-12 Kevin Ryde + + * mpz/root.c: Add , for abort(). + + * mpfr/tests/Makefile.am (AUTOMAKE_OPTIONS): Add ansi2knr. + * mpfr/mpfr.h, mpfr/mpfr-tests.h, reuse.c, tadd.c, tadd_ui.c, tagm.c, + tatan.c, tcmp2.c, tcos.c, tdiv.c, tdiv_ui.c, teq.c, texp.c, + tget_str.c, thyperbolic.c, tlog.c, tmul.c, tout_str.c, tpow.c, + trandom.c, tset_z.c, tsin.c, tsqrt.c, tsqrt_ui.c, tsub_ui.c, ttan.c, + tui_div.c: Fixes for K&R. + + * tests/misc/t-scanf.c (check_misc, check_misc): + + * tests/mpz/t-inp_str.c, tests/mpq/t-inp_str.c, tests/misc/t-scanf.c: + Avoid strings in ASSERT, not enjoyed by K&R. + * gmp-impl.h (ASSERT): Note this. + + * tests/tests.h (refmpn_mod_34lsub1): Add __GMP_PROTO. + + * mpbsd/Makefile.am: Avoid an automake problem with ansi2knr and + sources in a different directory. + + * printf/repl-vsnprintf.c: Test HAVE_LONG_DOUBLE for long double. + + * mpn/Makefile.am (nodist_libdummy_la_SOURCES): Add mod_34lsub1.c, + mul_2.c, pre_divrem_1.c. + + * gmp-h.in, gmp-impl.h (mpn_add_nc, mpn_addmul_1c, mpn_addsub_n, + mpn_addsub_nc, mpn_divrem_1c, mpn_dump, mpn_mod_1c, mpn_mul_1c, + mpn_mul_basecase, mpn_sqr_n, mpn_sqr_basecase, mpn_sub_nc, + mpn_submul_1c): Move to gmp-impl.h, since they're undocumented. + + * gmp-impl.h (mpn_reciprocal): Remove, unused. + + * tune/many.pl (cntlz, cnttz): Use new SPEED_ROUTINE_COUNT_ZEROS. + +2002-01-11 Kevin Ryde + + * mpn/hppa/*.asm, mpn/pa64/*.asm, mpn/pa64w/*.asm: Use L(). + +2002-01-08 Kevin Ryde + + * mpn/asm-defs.m4 (PROLOGUE, EPILOGUE): New scheme, optional function + name to EPILOGUE, check for missing or wrong function name EPILOGUE. + * mpn/alpha/unicos.m4, mpn/alpha/default.m4, mpn/m68k/m68k-defs.m4, + mpn/mips3/mips.m4, mpn/ia64/default.m4, mpn/powerpc32/aix.m4, + mpn/powerpc64/aix.m4, mpn/x86/x86-defs.m4: Consequent updates, add a + few more asserts. + * mpn/alpha/unicos.m4, mpn/alpha/default.m4, mpn/alpha/cntlz.asm, + mpn/alpha/invert_limb.asm (PROLOGUE_GP): Change to an optional "gp" + parameter on plain PROLOGUE. + + * gmp.texi (Low-level Functions): mpn_get_str doesn't clobber an extra + limb, and doesn't clobber at all for power of 2 bases. + (Language Bindings): Add python gmpy. + + * mpz/get_str.c: Determine realloc size arithmetically. + + * mpbsd/mtox.c: Size memory block returned to actual space needed. + * gmp.texi (BSD Compatible Functions): Describe this. + + * mpz/get_str.c: Don't copy mpn_get_str input for power of 2 bases. + * mpbsd/mtox.c: Ditto, and as a side effect avoid a memory leak from a + missing TMP_FREE. + + * mpz/get_str.c, mpbsd/mout.c: No longer need for +1 limb for + mpn_get_str clobber. + + * gmp-impl.h (MPN_GET_STR_SIZE): New macro. + * mpn/generic/get_str.c, mpz/get_str.c, mpbsd/mout.c, mpbsd/mtox.c, + tune/speed.h: Use it. + * tests/mpn/t-g_str_size.c: New test. + * tests/mpn/Makefile.am: Add it. + + * gmp-impl.h (POW2_P): New macro. + * mpn/generic/get_str.c, tests/misc.c: Use it. + + * printf/doprnt.c: Add "N" for mpn, share some code between N, Q and Z. + * tests/misc/t-printf.c: Add tests. + * gmp-impl.h (ASSERT_CODE): New macro. + + * tests/mpbsd/t-mtox.c: New test. + * tests/mpbsd/Makefile.am: Add it. + (allfuns_LDADD): Don't link against libgmp when testing everything in + libmp can link. + +2002-01-07 Torbjorn Granlund + + * gmp-impl.h (MPN_COPY_INCR, MPN_COPY_DECR): Rewrite generic versions. + +2002-01-06 Kevin Ryde + + * mpn/generic/pre_divrem_1.c: Don't support size==0. + * tests/devel/try.c: Update. + + * mpn/generic/get_str.c: Add special case for base==10. + * gmp-impl.h (MP_BASES_CHARS_PER_LIMB_10, MP_BASES_BIG_BASE_10, + MP_BASES_BIG_BASE_INVERTED_10, MP_BASES_NORMALIZATION_STEPS_10): New + constants. + * tests/t-constants.c: Add checks. + * mpn/mp_bases.c [GENERATE_TABLE]: Print defines for gmp-impl.h, print + all standard bits-per-limb by default. + + * demos/pexpr.c, demos/expr/expr.h, demos/expr/expr-impl.h: Use + __GMP_PROTO. + + * gmp-h.in (mpn_divexact_by3c): Remove variables from prototype, to + keep out of application namespace. + +2002-01-04 Torbjorn Granlund + + * gmp-impl.h: Move _PROTO declaration to before its first usages. + +2002-01-04 Kevin Ryde + + * gmp-h.in, mp-h.in, tests/tests.h: Rename _PROTO to __GMP_PROTO, and + don't use #ifndef just define it ourselves. + * gmp-impl.h: Provide _PROTO as an alias for __GMP_PROTO, to avoid big + edits internally, for the moment. + +2002-01-03 Torbjorn Granlund + + * tune/speed.c (usage): Insert "\n\" into a string. + +2001-12-30 Torbjorn Granlund + + * mpn/pa64/udiv_qrnnd.c: Remove file. + * mpn/pa64w/udiv_qrnnd.c: Remove file. + + * gmp-impl.h (MPN_IORD_U): Change formatting (labels in pos 0, insns + indented by tab). + (MPN_INCR_U): Use "addl $1,foo; jc", not "incl foo; jz". + + * gmp-impl.h (udiv_qrnnd_preinv): Use plain subtract, not sub_ddmmss, + in one more case. + +2001-12-30 Kevin Ryde + + * mpn/generic/get_str.c (udiv_qrnd_unnorm): New macro. + Use "do while" for dig_per_u loop since it's non-zero. + * acconfig.h (HAVE_HOST_CPU_m68k etc): Add templates. + + * mpn/generic/mul_basecase.c, mpz/mul.c, mpz/n_pow_ui.c, + mpn/x86/pentium/mul_2.asm, tests/devel/try.c, tests/tests.h, + tests/refmpn.c, tune/speed.c, tune/speed.h, tune/common.c, + tune/many.pl (mpn_mul_2): New parameter style. + * gmp-impl.h (mpn_mul_2): Add prototype. + * configure.in (gmp_mpn_functions_optional): Add mul_2. + + * longlong.h (__vxworks__): Remove from powerpc tests, not correct, + not on its own at least. + + * tune/speed.c: Add "aas" to specify 0xAA..AA data. + + * tune/tuneup.c (print_define_end): Indicate "never" and "always". + +2001-12-29 Torbjorn Granlund + + * mpq/set_d.c: ANSI-fy. + * mpz/invert.c: Use PTR and SIZ (cosmetic change). + + * mpz/cong.c: Rename `xor' to `sign' to avoid C++ reserved word. + +2001-12-28 Torbjorn Granlund + + * mpn/sparc64/sqr_diagonal.asm: New file. + +2001-12-28 Kevin Ryde + + * mpn/generic/get_str.c: Avoid one mpn_divrem_1 by running main loop + only until msize==1. + + * tune/tuneup.c: Break up all() for clarity. + (USE_PREINV_DIVREM_1, USE_PREINV_MOD_1): Compare against plain + division udiv_qrnnd, not the tuned and possibly preinv version. + + * tune/freq.c: Split sysctl and sysctlbyname probes into separate + functions, shorten some identifiers, put descriptions inside + functions, define functions unconditionally and do nothing if + requisites not available. + + * mpz/inp_raw.c: Avoid a gcc 3.0 powerpc64 bug on AIX. + + * acinclude.m4, configure.in (GMP_C_RESTRICT): New macro. + + * mpfr/sin.c: Patch from Paul to fix sign of sin(3pi/2). + + * demos/calc/calc.y: Improve some error messages. + +2001-12-28 Torbjorn Granlund + + * mpn/sparc64/mul_1.asm: Rename r72 -> r80. + * mpn/sparc64/addmul_1.asm: Likewise. + +2001-12-27 Torbjorn Granlund + + * mpn/generic/tdiv_qr.c: Misc formatting cleanups. + For switch case 2, replace `dn' with its value (2). + +2001-12-25 Torbjorn Granlund + + * tests/devel/mul_1.c: Add FIXED_XLIMB. + * tests/devel/addmul_1.c: Likewise. + * tests/devel/submul_1.c: Likewise. + + * tests/devel/add_n.c: Improve error message. + Accept command line argument for # of tests. + * tests/devel/sub_n.c: Likewise. + + * tests/devel/: Remove CLOCK settings. + + * mpn/sparc32/v9/mul_1.asm: Rewrite. + * mpn/sparc32/v9/addmul_1.asm: Rewrite. + * mpn/sparc32/v9/submul_1.asm: Rewrite. + +2001-12-24 Torbjorn Granlund + + * mpn/sparc64/mul_1.asm: Get rid of global constant 0.0 (L(noll)). + * mpn/sparc64/addmul_1.asm: Likewise. + +2001-12-23 Torbjorn Granlund + + * mpn/generic/get_str.c: Move final ASSERT to just before zero fill + loop. + +2001-12-22 Torbjorn Granlund + + * mpn/generic/get_str.c: Move ASSERTs out of loops. Split digit + generation code into two loops, saving a test of msize in the loop. + +2001-12-22 Kevin Ryde + + * mpn/x86/x86-defs.m4, mpn/x86/*/*.asm: Remove L / LF scheme putting + function name in local labels. + + * mpn/generic/get_str.c: Use mpn_preinv_divrem_1, add a couple of + ASSERTs. + + * mpn/generic/pre_divrem_1.c: New file. + * configure.in (gmp_mpn_functions): Add it. + * gmp-impl.h (mpn_preinv_divrem_1): Add prototype. + (USE_PREINV_DIVREM_1, MPN_DIVREM_OR_PREINV_DIVREM_1): New macros. + * tests/devel/try.c, tune/speed.c, tune/speed.h, tune/common.c, + tune/many.pl, tune/Makefile.am (mpn_preinv_divrem_1): Add testing and + measuring. + * tune/tuneup.c: Determine USE_PREINV_DIVREM_1. + * tune/pre_divrem_1.c: New file. + * tests/refmpn.c, tests/tests.h (refmpn_preinv_divrem_1): New function. + + * tests/mpz/t-io_raw.c: New file. + * tests/mpz/Makefile.am (check_PROGRAMS): Add it. + + * mpz/inp_raw.c, mpz/out_raw.c: Rewrite. + * acinclude.m4, configure.in (AC_C_BIGENDIAN): New test. + * gmp-impl.h (BSWAP_LIMB): New macro. + + * acinclude.m4 (GMP_PROG_CC_WORKS): For a native compile, demand + executables will run, per AC_PROG_CC. This detects ABI=64 is unusable + in a native sparc solaris 7 build with the kernel in 32-bit mode. + * gmp.texi (ABI and ISA): Add notes on this, add an example configure + setting an ABI. + + * tune/tuneup.c, configure.in: Print the gmp-mparam.h filename. + * tune/tuneup.c: Print the CPU frequency. + + * tune/time.c, tune/speed.h: Add s390 "stck" method, flatten + conditionals in speed_time_init a bit, use have_* variables to let + some code go dead in speed_starttime and speed_endtime. + + * tune/freq.c (speed_cpu_frequency_irix_hinv): New function. + + * Makefile.am, configure.in: Restore mpfr. + + * configure.in: Add --with-readline, AC_PROG_YACC and AM_PROG_LEX. + * demos/calc/calc.y, demos/calc/calclex.l: Add readline support, add + lucnum function. + * demos/calc/Makefile.am: Add calcread.c, calc-common.h, use $(YACC), + $(LEX) and $(LEXLIB). + * demos/calc/calcread.c, demos/calc/calc-common.h, + demos/calc/calc-config-h.in, demos/calc/README: New files. + + * configure.in: Put demos/expr configs in expr-config.h. + * demos/expr/expr-config-h.in: New file. + * demos/expr/expr-impl.h: Renamed from expr-impl-h.in, get configs + from expr-config.h. + * demos/expr/Makefile.am: Update. + + * demos/expr/exprfr.c: Use mpfr_sin and mpfr_cos, remove some spurious + returns. + +2001-12-20 Torbjorn Granlund + + * mpn/sparc64/mul_1.asm: Trim an instruction. + * mpn/sparc64/addmul_1.asm: Likewise. + + * mpn/ia64/add_n.asm: Rewrite. + * mpn/ia64/sub_n.asm: Rewrite. + +2001-12-19 Torbjorn Granlund + + * mpn/ia64/mul_1.asm: Rewrite. + * mpn/ia64/addmul_1.asm: Rewrite. + * mpn/ia64/submul_1.c: Use TMP_ALLOC_LIMBS. + + * tests/devel/mul_1.c: Improve error message. + Accept command line argument for # of tests. + * tests/devel/addmul_1.c: Likewise. + * tests/devel/submul_1.c: Likewise. + +2001-12-18 Torbjorn Granlund + + * mpn/mips3/mul_1.asm: Add NOPs to save a cycle on R1x000. + +2001-12-18 Kevin Ryde + + * gmpxx.h (gmp_randclass): Don't allow copy constructors or "=", + implementation by Gerardo. + + * gmp-h.in (operator<<, operator>>): Remove parameter names from + prototypes, to keep out of user namespace. + + * acinclude.m4 (GMP_FUNC_VSNPRINTF): Let the test program work as C++. + +2001-12-16 Torbjorn Granlund + + * mpn/sparc64/mul_1.asm: Rewrite. + * mpn/sparc64/addmul_1.asm: Rewrite. + * mpn/sparc64/submul_1.asm: Rewrite. + + * mpn/sparc64/addmul1h.asm: Remove. + * mpn/sparc64/submul1h.asm: Remove. + * mpn/sparc64/mul1h.asm: Remove. + +2001-12-15 Kevin Ryde + + * gmp-h.in (mpn_add, mpn_add_1, mpn_cmp, mpn_sub, mpn_sub_1): Follow + __GMP_INLINE_PROTOTYPES for whether to give prototype with inline. + + * configure.in (i686*-*-*, pentiumpro-*-*, pentium[23]-*-*, + athlon-*-*, pentium4-*-*): Fall back on -march=pentium if + -march=pentiumpro or higher is not good (eg. solaris cmov). + +2001-12-12 Torbjorn Granlund + + * gmp-impl.h (MPN_ZERO): Rewrite generic version to be similar to + powerpc version. + +2001-12-12 Kevin Ryde + + * acinclude.m4 (GMP_PROG_CC_WORKS): Detect cmov problems with gcc + -march=pentiumpro on solaris 2.8. + + * tune/common.c, tune/speed.h: Allow for commas in count_leading_zeros + and count_trailing_zeros macros. + + * demos/expr/Makefile.am: Distribute exprfr.c and exprfra.c. + + * tune/Makefile.am (speed_ext_SOURCES): Should be speed-ext.c. + +2001-12-10 Torbjorn Granlund + + * mpn/s390/addmul_1.asm: New file. + * mpn/s390/submul_1.asm: New file. + * mpn/s390/mul_1.asm: New file. + * mpn/s390/gmp-mparam.h: Update. + +2001-12-07 Kevin Ryde + + * gmp-h.in, mp-h.in, gmp-impl.h: __GMP_DECLSPEC at start of + prototypes, for the benefit of Microsoft C. + + * gmp.texi (Introduction to GMP): Mention ABI and ISA section. + (Known Build Problems): Recommend GNU sed on solaris 2.6. + (Assigning Integers): Direct feedback to bug-gmp. + (References): Typo Knuth vol 2 is from 1998. + + * gmpxx.h (gmp_randclass): Add initializers for gmp_randinit_default + and gmp_randinit_lc_2exp_size. + gmp.texi (C++ Interface Random Numbers): Describe them. + + * tests/misc/t-locale.c, tests/cxx/t-locale.cc: Ensure mpf_clear is + done when the localconv override doesn't work. Reported by Mike + Jetzer. + + * printf/doprnti.c: Don't showbase on a zero mpq denominator. + * tests/misc/t-printf.c, tests/cxx/t-ostream.c: Add test cases. + +2001-12-04 Kevin Ryde + + * gmp.texi (Known Build Problems): Update to gmp_randinit_lc_2exp_size + for the sparc solaris 2.7 problem. + (Reentrancy): SCO ctype.h affects all text-based input functions. + (Formatted Output Strings): Correction to the mpf example. + (Single Limb Division): Correction, should be q-1 not q+1. + (Extended GCD): Clarify why single-limb is inferior. + (Raw Output Internals): Clarify size is twos complement, note limb + order means _mp_d doesn't get directly read or written. + (Contributors): Clarify mpz_jacobi. + And a couple of formatting tweaks elsewhere. + + * tests/cxx/t-headers.cc: New file. + * tests/cxx/Makefile.am: Add it. + + * gmpxx.h: Add , needed by mpf_class::get_str2. + + * gmp-h.in (mpq_inp_str, mpn_hamdist): Add __GMP_DECLSPEC. + +2001-12-01 Torbjorn Granlund + + * Version 4.0 released. + + * mpfr/README: Replace contents with explanation of why mpfr is gone. + +2001-12-01 Kevin Ryde + + * Makefile.am, configure.in: Temporarily remove mpfr, just leave a + README. + + * mpn/Makefile.am (EXTRA_DIST): Add Makeasm.am. + +2001-11-30 Gerardo Ballabio + + * tests/cxx/t-constr.cc, tests/cxx/t-expr.cc: New files. + * tests/cxx/Makefile.am (check_PROGRAMS): Add them. + +2001-11-30 Kevin Ryde + + * mpfr: Update to 2001-11-16. Patch TMP handling of agm.c and sqrt.c, + use plain mpn_sqrtrem in sqrt.c, separate .c files for floor and ceil, + disable an expression style assert in add1.c. + + * mpn/s370: Rename to s390. + * configure.in (s3[6-9]0*-*-*): Update. + * mpn/Makefile.am (TARG_DIST): Add s390. + + * mpz/fits_s.c, mpf/fits_s.c, mpf/fits_u.c: Remove files, unused since + change to .h style. + +2001-11-29 Torbjorn Granlund + + * gmp-h.in: Declare mpz_get_d_2exp and mpf_get_d_2exp. + * Makefile.am: Add mpz/get_d_2exp$U.lo and mpf/get_d_2exp$U.lo. + * mpf/Makefile.am: Add get_d_2exp.c. + * mpz/Makefile.am: Add get_d_2exp.c. + +2001-11-29 Kevin Ryde + + * mpn/*/gmp-mparam.h: Update measured thresholds. + * mpn/s370/gmp-mparam.h: New file. + + * mpz/millerrabin.c: Mark for internal use only, for now. + * gmp.texi (Number Theoretic Functions): Remove documentation. + +2001-11-28 Torbjorn Granlund + + * mpf/get_d_2exp.c: New file. + * mpz/get_d_2exp.c: New file. + + * mpz/realloc2.c: Fix typo. Make more similar to mpz_realloc. + * mpz/realloc.c: Use __GMP_REALLOCATE_FUNC_LIMBS. + +2001-11-27 Gerardo Ballabio + + * gmpxx.h, mpfrxx.h: Various updates and improvements. + +2001-11-27 Kevin Ryde + + * gmp.texi (Useful Macros and Constants): Add gmp_version, add @findex + for mp_bits_per_limb. + + * demos/perl/GMP.pm, demos/perl/GMP.xs: Use new style gmp_randinit's. + * demos/perl/test.pl: Update for this, and for mpz_perfect_power_p + handling of 0 and 1. + +2001-11-26 Torbjorn Granlund + + * mpz/realloc.c: Clear variable when decreasing allocation to less than + needed. Misc updates. + +2001-11-25 Kevin Ryde + + * tests/misc/t-locale.c: Avoid printf in the normal case, since the + replacement localeconv breaks it on SunOS 4. + + * gmp.texi (Build Options, Notes for Package Builds): Note libgmpxx + depends on libgmp from same GMP version. + + * acinclude.m4, configure.in (GMP_FUNC_SSCANF_WRITABLE_INPUT): New + test. + * scanf/sscanf.c, scanf/vsscanf.c: Use it to ensure sscanf input is + writable, if necessary. + + * tests/misc/t-scanf.c: Ensure sscanf arguments are writable, always. + * configure.in (AC_CHECK_DECLS): Remove sscanf, no longer required. + + * configure.in (none-*-*): Fix default CFLAGS setups. + + * doc/configuration: Misc updates. + +2001-11-23 Kevin Ryde + + * mpz/init2.c, mpz/realloc2.c: New files. + * Makefile.am, mpz/Makefile.am: Add them. + * gmp-h.in: Add prototypes. + * gmp.texi (Efficiency): Mention these instead of _mpz_realloc. + (Initializing Integers): Add documentation, reword other parts. + +2001-11-22 Torbjorn Granlund + + * mpn/cray/ieee/addmul_1.c: Fix logic for more_carries scalar loop. + * mpn/cray/ieee/submul_1.c: Likewise. + +2001-11-20 Kevin Ryde + + * gmp.texi (Known Build Problems): Note an out of memory on DJGPP. + (Function Classes): Update function counts. + Misc tweaks elsewhere. + + * configure.in (AC_CHECK_DECLS): Add sscanf. + * tests/misc/t-scanf.c: Use it, for the benefit of SunOS 4. + + * tal-debug.c, gmp-impl.h: More checks of TMP_DECL/TMP_MARK/TMP_FREE + consistency. + + * mpfr/Makefile.am (AR): Explicit AR=@AR@ to override automake + default, necessary for powerpc64 ABI=aix64. + +2001-11-18 Torbjorn Granlund + + * mpz/powm.c: Move TMP_MARK to before any TMP_ALLOCs. + +2001-11-18 Kevin Ryde + + * configure.in (--enable-fft): Make this the default. + * gmp.texi (Build Options): Update. + + * Makefile.am (libmp_la_DEPENDENCIES): Revise mpz objects needed by + new mpz/powm.c. + + * gmp.texi (Random State Initialization): Add gmp_randinit_default and + gmp_randinit_lc_2exp_size, mark gmp_randinit as obsolete. + (Random State Seeding): New section, taken from "Random State + Initialization" and "Random Number Functions". + + * configure.in (AC_CHECK_DECLS): Add fgetc, fscanf, ungetc. + * scanf/fscanffuns.c: Use these, for the benefit of SunOS 4. + + * gmp-impl.h, gmp-h.in (__gmp_default_fp_limb_precision): Move back to + gmp-impl.h now not required for inlined mpf. + + * randlc2s.c (gmp_randinit_lc_2exp_size): New file, the size-based LC + selection from rand.c. + * rand.c (gmp_randinit): Use it. + * randdef.c (gmp_randinit_default): New file. + * gmp-impl.h (RANDS): Use it. + (ASSERT_CARRY): New macro. + * gmp-h.in (gmp_randinit_default, gmp_randinit_lc_2exp_size: Add + prototypes. + * Makefile.am (libgmp_la_SOURCES): Add randdef.c and randlc2s.c. + + * printf/asprntffuns.c: Include config.h before using its defines. + + * gmp-impl.h: Move C++ to top of file to avoid the memset + redefine upsetting configure tests. Remove since + in gmp.h suffices. + +2001-11-16 Kevin Ryde + + * gmp.texi (Integer Exponentiation): mpz_powm supports negative + exponents. + (Assigning Floats, I/O of Floats, C++ Formatted Output, C++ Formatted + Input): Decimal point follows locale. + (Formatted Output Strings): %n accepts any type. + (Formatted Input Strings): New section. + (Formatted Input Functions): New section. + (C++ Class Interface): Corrections and clarifications suggested by + Gerardo. + + * scanf/doscan.c, scanf/fscanf.c, scanf/fscanffuns.c, scanf/scanf.c, + scanf/sscanf.c, scanf/sscanffuns.c, scanf/vfscanf.c, scanf/vscanf.c, + scanf/vsscanf.c, scanf/Makefile.am, tests/misc/t-scanf.c: New files. + * gmp-h.in, gmp-impl.h, Makefile.am, configure.in: Consequent + additions. + + * tests/misc: New directory. + * tests/misc/Makefile.am: New file. + * tests/misc/t-locale.c: New file. + * tests/misc/t-printf.c: Moved from tests/printf. + * tests/printf: Remove directory. + * configure.in, tests/Makefile.am: Update. + + * tests/cxx/t-locale.cc: New file. + * tests/cxx/Makefile.am: Add it. + + * mpf/set_str.c, cxx/ismpf.cc: Use localeconv for the decimal point. + + * acinclude.m4 (GMP_ASM_X86_MCOUNT): Update to $lt_prog_compiler_pic + for current libtool, recognise non-PIC style mcount in windows DLLs. + + * gmp-impl.h (__gmp_replacement_vsnprintf): Add prototype. + + * gmp-impl.h (__gmp_rands, __gmp_rands_initialized, + modlimb_invert_table): Add __GMP_DECLSPEC for the benefit of test + programs using them from a windows DLL. + * longlong.h (__clz_tab): Ditto. + + * mpn/x86/t-zdisp2.pl: New file. + + * mpn/x86/pentium4/README: New file. + +2001-11-15 Torbjorn Granlund + + * mpz/powm.c (HANDLE_NEGATIVE_EXPONENT): #define to 1. + * tests/mpz/reuse.c (main): Use mpz_invert to avoid undefined mpz_powm + cases. + +2001-11-14 Torbjorn Granlund + + * mpz/powm_ui.c: Rewrite along the lines of mpz/powm.c (except still no + redc). + * mpz/powm.c: Adjust for negative b, after exponentiation done. Add + (still disabled) code for handling negative exponents. Misc cleanups. + +2001-11-14 Kevin Ryde + + * mpf/out_str.c: Use localeconv for the decimal point. + + * tests/misc.c (tests_rand_end): Use time() if gettimeofday() not + available (eg. on mingw). + +2001-11-11 Kevin Ryde + + * gmp-h.in: Remove parameter names from prototypes, to keep out of + application namespace. + +2001-11-08 Kevin Ryde + + * acinclude.m4 (GMP_GCC_VERSION_GE): Fix sed regexps to work on + Solaris 8. + + * printf/doprnt.c: Support %n of all types, per glibc. + + * gmp-h.in, gmp-impl.h, mpf/abs.c, mpf/neg.c, mpf/get_prc.c, + mpf/get_dfl_prec.c, mpf/set_dfl_prec.c, mpf/set_prc_raw.c, + mpf/set_si.c, mpf/set_ui.c, mpf/size.c: Revert mpf inlining, in order + to leave open the possibility of keeping binary compatibility if mpf + becomes mpfr. + + * mpn/x86/k7/mmx/lshift.asm, mpn/x86/k7/mmx/rshift.asm: Use Zdisp to + force code size for computed jumps. + * mpn/x86/k6/mod_34lsub1.asm, mpn/x86/k6/k62mmx/copyd.asm: Use Zdisp + to force good code alignment. + * mpn/x86/x86-defs.m4 (Zdisp): More instructions. + + * mpn/x86/pentium/sqr_basecase.asm, mpn/x86/k7/mmx/mod_1.asm, + mpn/x86/k7/mmx/popham.asm: Remove some unnecessary "0" address offsets. + + * mpq/set_si.c, mpq/set_ui.c: Set _mp_den._mp_size correctly if den==0. + +2001-11-07 Torbjorn Granlund + + * mpn/hppa/hppa1_1/udiv_qrnnd.asm: Work around gas bug. + + * mpn/asm-defs.m4 (PROLOGUE): Change alignment to 8 (probably a good + idea in general; required for hppa/hppa1_1/udiv_qrnnd.asm). + +2001-11-06 Torbjorn Granlund + + * gmp-impl.h (MPN_COPY_INCR): Prepend local variable by `__'. + (MPN_COPY_DECR): Likewise. + +2001-11-05 Torbjorn Granlund + + * mpz/powm.c: Call mpn functions, not mpz functions, for computation + mod m. Streamline allocations to use a mixture of stack allocation and + heap allocation. Add currently disabled phi(m) exponent reduction + code. Misc optimizations and cleanups. + +2001-11-05 Kevin Ryde + + * mpq/inp_str.c: Remove unused variable "ret". + + * mpn/x86/k7/sqr_basecase.asm: Fix a 0(%edi) to use Zdisp, so the + computed jumps hit the right spot on old gas. + + * mpq/canonicalize.c: DIVIDE_BY_ZERO if denominator is zero. + + * mpn/lisp/gmpasm-mode.el (comment-start-skip): Correction to the way + the first \( \) pair is setup. + (gmpasm-font-lock-keywords): Don't fontify the space before a "#" etc. + Misc tweaks to some comments. + +2001-11-03 Torbjorn Granlund + + * tests/refmpn.c (refmpn_overlap_p): Reverse return values. + +2001-11-02 Kevin Ryde + + * tune/many.pl: Setup CFLAGS_PIC and ASMFLAGS_PIC, since that's no + longer done by configure. + + * mpn/x86/pentium4/mmx/popham.asm: New file. + + * mpn/x86/x86-defs.m4 (psadbw): New macro. + * mpn/x86/k7/mmx/popham.asm: Use it. + + * tests/refmpn.c (refmpn_overlap_p): New function, independent of + MPN_OVERLAP_P. + +2001-10-31 Torbjorn Granlund + + * tests/mpz/t-powm.c: Print proper error message when finding + discrepancy. + +2001-10-31 Kevin Ryde + + * mpn/x86/pentium/mod_34lsub1.asm: New file. + * mpn/x86/k7/mod_34lsub1.asm: New file. + * mpn/x86/mod_34lsub1.asm: New file. + +2001-10-30 Kevin Ryde + + * tests/printf/t-printf.c (check_misc): Add checks from the glibc docs. + (check_vasprintf, check_vsnprintf): Run these unconditionally. + + * gmp-impl.h (ASSERT_MPQ_CANONICAL): New macro. + * mpq/cmp.c, mpq/cmp_si.c, mpq/cmp_ui.c, mpq/equal.c: Add ASSERTs for + canonical inputs, where correctness depends on it. + + * mpn/lisp/gmpasm-mode.el (comment-start-skip): Add "dnl". + +2001-10-27 Torbjorn Granlund + + * demos/pexpr.c: Remove some unused variables. + (main): Allocate more buffer space to accommodate minus sign. + +2001-10-27 Kevin Ryde + + * gmp-impl.h, mpn/asm-defs.m4, configure.in, tune/speed.h, + tune/speed.c, tune/common.c, tune/many.pl, tests/devel/try.c: Add + mpn_mod_34lsub1. + * tests/refmpn.c, tests/tests.h (refmpn_mod_34lsub1): New function. + + * mpn/generic/mod_34lsub1.c: New file. + * mpn/x86/k6/mod_34lsub1.asm: New file. + * mpn/x86/pentium4/sse2/mod_34lsub1.asm: New file. + * mpn/x86/x86-defs.m4 (Zdisp): Add another instruction. + + * gmp-h.in, gmpxx.h: Use not whole . + + * gmp.texi (Known Build Problems): Add note on test programs with + Windows DLLs. + +2001-10-26 Kevin Ryde + + * tests/mpq/t-get_d.c: Limit the size of "eps" for vax. + + * gmp.texi (maybepagebreak): New macro, use it in a few places. + (Notes for Particular Systems): C++ Windows DLLs are not supported. + (Known Build Problems): Note sparc solaris 2.7 gcc 2.95.2 shared + library problems. + (Autoconf): Tweak version numbers shown. + (Integer Roots): mpz_perfect_square_p and mpz_perfect_power_p consider + 0 and 1 perfect powers, mpz_perfect_power_p accepts negatives. + (Number Theoretic Functions): Add mpz_millerrabin, combined with a + reworded mpz_probab_prime_p. + (Formatted Output Strings): Misc clarifications. + (Formatted Output Functions): gmp_asprintf, gmp_vasprintf, + gmp_snprintf, gmp_vsnprintf always available. + (C++ Formatted Output): Misc rewordings. + (Formatted Input): New chapter. + (C++ Class Interface): New chapter, by Gerardo and me. + (Language Bindings): Update GMP++ now in GMP. + (C++ Interface Internals): New section, by Gerardo and me. + + * printf/repl-vsnprintf.c: New file. + * configure.in, acinclude.m4, Makefile.am, printf/Makefile.am: Use it + if libc vsnprintf missing or bad. + * configure.in (AC_CHECK_FUNCS): Add strnlen. + + * printf/snprntffuns.c, printf/vasprintf.c: Use + __gmp_replacement_vsnprintf if libc vsnprintf not available. + * printf/asprintf.c, printf/snprintf.c, printf/vasprintf.c, + printf/vsnprintf.c: Provide these functions unconditionally. + * acinclude.m4 (GMP_FUNC_VSNPRINTF): Remove warning about omissions + when vsnprintf not available. + +2001-10-24 Kevin Ryde + + * configure, aclocal.m4: Regenerate with a libtool patch for a stray + quote in AC_LIBTOOL_PROG_LD_SHLIBS under mingw and cygwin. + + * gmp-impl.h (modlimb_invert): More comments. + + * printf/doprnt.c, printf/doprnti.c: Use the precision field to print + leading zeros. + * tests/printf/t-printf.c: Test this. + * cxx/osdoprnti.cc, gmp-impl.h: Ignore precision in operator<<. + + * tune/speed.c, tune/speed.h, tune/common.c: Add mpn_mul_1_inplace. + +2001-10-23 Torbjorn Granlund + + * mpz/pprime_p.c (mpz_millerrabin): Remove function and its descendant. + + * mpz/millerrabin.c: New file with code from pprime.c. + * mpz/Makefile.am: Compile millerrabin.c. + * Makefile.am (MPZ_OBJECTS): Ditto. + * gmp-h.in: Declare mpz_millerrabin. + +2001-10-22 Torbjorn Granlund + + * tests/mpz/t-perfsqr.c: New file. + * tests/mpz/Makefile.am (check_PROGRAMS): Add it. + + * demos/factorize.c (factor): Check for number to factor == 0. + (main): When invoked without arguments, read from stdin. + + * mpz/perfpow.c: Add code to handle negative perfect powers ((-b)^odd). + Treat 0 and 1 as perfect powers. + + * mpn/sparc32/v9/sqr_diagonal.asm: Jump past .align. + +2001-10-21 Torbjorn Granlund + + * mpn/generic/perfsqr.c (sq_res_0x100): Remove bogus final `,'. + (mpn_perfect_square_p): Suppress superfluous `&1' in sq_res_0x100 test. + (mpn_perfect_square_p, O(n) test): Improve comments. Combine remainder + tests for some small primes. Don't share code for different limb + sizes. Use single `if' with many `||' for better code density. + +2001-10-22 Kevin Ryde + + * demos/perl/GMP.xs (mutate_mpz, tmp_mpf_grow): Make these "static". + + * mpn/x86/pentium/popcount.asm, mpn/x86/pentium/hamdist.asm + (mpn_popcount_table): Use GSYM_PREFIX. + +2001-10-19 Kevin Ryde + + * mpn/x86/*.asm: Add some measured speeds on various x86s. + + * tests/mpz/reuse.c, tests/mpf/reuse.c: Disable tests when using a + windows DLL, because certain global variable usages won't compile. + + * configure.in (AC_CHECK_FUNCS): Add alarm. + * tests/spinner.c: Conditionalize alarm and SIGALRM availability, for + the benefit of mingw32. + + * acinclude.m4 (GMP_ASM_TYPE, GMP_ASM_SIZE): Suppress .type and .size + on COFF. + + * acinclude.m4 (GMP_PROG_HOST_CC): New macro. + * configure.in: Use it for windows DLL cross-compiles. + * aclocal.m4, configure: Regenerate with libtool patch to hold HOST_CC + in the generated libtool script. + + * aclocal.m4, configure: Regenerate with libtool patch to suppress + warnings when probing command line limit on FreeBSD. + + * demos/qcn.c (M_PI): Define if not already provided, helps mingw32. + +2001-10-17 Kevin Ryde + + * printf/doprnt.c: Use for intmax_t. + + * longlong.h: Recognise __sparcv8 for gcc on Solaris. Reported by + Mark Mentovai . + + * gmp-impl.h (gmp_allocated_string): No need for inline on member funs. + +2001-10-16 Kevin Ryde + + * gmp.texi (Debugging): Add mpatrol. + (Integer Comparisons, Comparing Rationals, Float Comparison): Index + entries for sign tests. + (I/O of Floats): Clarify mpf_out_str exponent is in decimal. + (C++ Formatted Output): mpf_t operator<< exponent now in decimal. + (FFT Multiplication): Use an ascii art sigma. + (Contributors): Add Gerardo Ballabio. + + * cxx/osfuns.cc (__gmp_doprnt_params_from_ios): Always give mpf_t + exponent in decimal, irrespective of ios::hex or ios::oct. + * tests/cxx/t-ostream.cc (check_mpf): Update. + + * printf/doprnt.c: Support %lln and %hhn. + + * mpn/x86/pentium4/sse2/submul_1.asm: Use a psubq to negate the + initial carry (helps the submul_1c case), and improve the comments. + +2001-10-11 Kevin Ryde + + * acinclude.m4, configure.in (GMP_IMPL_H_IEEE_FLOATS): New macro. + + * ltmain.sh: Send some rm errors to /dev/null, helps during compiles + on Solaris 2.7 and HP-UX 10. + + * tal-notreent.c: Renamed from stack-alloc.c. + * Makefile.am, acinclude.m4, gmp-impl.h: Update. + + * gmp-h.in: Don't give both prototypes and inlines, except on gcc. + + * gmp-h.in, gmp-impl.h: Use #includes to get necessary standard + classes, add std:: to prototypes. + * cxx/*.cc, tests/cxx/t-ostream.cc: Add "use namespace std". + * acinclude.m4 (GMP_PROG_CXX_WORKS): Ditto. + + * tests/*/Makefile.in, mpfr/tests/Makefile.in: Regenerate with + automake patch to avoid Ultrix problem with empty $(TESTS). + + * */Makefile.in: Regenerate with automake patch to only rm *_.c in + "make clean" when ansi2knr actually in use, helps DOS 8.3. + + * Makefile.in: Regenerate with automake patch to fix stamp-h + numbering, avoiding an unnecessary config.status run. + +2001-10-09 Torbjorn Granlund + + * mpn/hppa/hppa1_1/udiv_qrnnd.asm: Use L macros for labels. + Quote L reloc operator. + + * gmp-impl.h: Declare class string. + + * mpn/asm-defs.m4 (INT32, INT64): Quote $1 to prevent further + expansion. + + * mpn/alpha/ev6/mul_1.asm: New file. + +2001-10-09 Kevin Ryde + + * gmp.texi (Introduction to GMP): Add pentium 4 to optimized CPUs. + (Build Options): Note macos directory. + (Notes for Package Builds): GMP 4 series binary compatible with 3. + (Known Build Problems): Remove $* and ansi2knr note, now fixed, except + possibly under --host=none. + (Formatted Output Strings): Remove -1 prec for all digits. + + * mpz/add.c, mpz/sub.c: Don't use mpz path on #include (helps macos). + * mpbsd/Makefile.am (INCLUDES): Add -I$(top_srcdir)/mpz. + + * printf/doprnt.c, tests/printf/t-printf.c: Remove support for %.*Fe + prec -1 meaning all digits. + + * acinclude.m4 (GMP_PROG_AR): Override libtool, use AR_FLAGS="cq". + (GMP_HPC_HPPA_2_0): Print version string to config.log. + + * Makefile.am (AUTOMAKE_OPTIONS): Remove check-news (permission notice + in NEWS file is too big). + (dist-hook): Don't distribute numbered or unnumbered emacs backups. + + * Makefile.am, cxx/Makefile.am: Updates for Gerardo's stuff. + +2001-10-09 Gerardo Ballabio + + * cxx/isfuns.cc: New file. + * gmp-impl.h: Add prototypes. + * cxx/ismpf.cc, cxx/ismpq.cc, cxx/ismpz.cc: New files. + * gmp-h.in: Add prototypes. + * gmpxx.h, mpfrxx.h: New files. + +2001-10-08 Kevin Ryde + + * configure.in (with_tags): Establish a default based on --enable-cxx. + + * aclocal.m4: Regenerate with libtool patches for sed char range to + help Cray, LTCC quotes and +Z warnings grep to help HP-UX. + + * gmp-impl.h (doprnt_format_t, doprnt_memory_t, doprnt_reps_t, + doprnt_final_t): Use _PROTO. + +2001-10-05 Torbjorn Granlund + + * mpn/asm-defs.m4 (INT32, INT64): Use LABEL_SUFFIX. + + * mpn/hppa: Convert files to `.asm'. + +2001-10-05 Kevin Ryde + + * mpn/Makeasm.am (.S files): Revert to separate CPP and CCAS, use + cpp-ccas, and only pass CPPFLAGS to CPP, not whole CFLAGS. + * mpn/cpp-ccas: New file. + * mpn/Makefile.am (EXTRA_DIST): Add it. + + * tune/common.c, tune/speed.h: Change SPEED_ROUTINE_MPN_COPY_CALL uses + to SPEED_ROUTINE_MPN_COPY or new SPEED_ROUTINE_MPN_COPY_BYTES. Avoids + macro expansion problems on Cray. + + * configure.in (AC_PROG_CXXCPP): Add this, to make libtool happier. + +2001-10-04 Torbjorn Granlund + + * mpz/rrandomb.c (gmp_rrandomb): Change bit_pos to be 0-based (was + 1-based); shift 2 (was 1) when making bit mask. These two changes + avoid undefined shift counts. + (gmp_rrandomb): Avoid most calls to _gmp_rand by caching random values. + + * mpn/generic/random2.c: Changes for mirroring mpz/rrandomb.c. + +2001-10-04 Kevin Ryde + + * gmp.texi (Build Options): Add --enable-cxx. + (Notes for Particular Systems): Mention pentium4 performance and SSE2. + (Known Build Problems): Remove vax jsobgtr note, no longer needed. + (Converting Floats): Tweak mpf_get_str description. + (Low-level Functions): Correction to mpn_gcdext destination space + requirements. + (C++ Formatted Output): New section. + (Language Bindings): Add ALP + (Contributors): Add Paul Zimmermann's square root, update my things. + + * acinclude.m4 (GMP_PROG_CC_IS_GNU, GMP_PROG_CXX_WORKS): Send compiler + errors to config.log. + + * mpq/Makefile.am (INCLUDES): Remove -DOPERATION_$*, not needed. + + * mpn/x86/*.asm: Change references to old README.family to just README. + + * mpz/README: Remove file, now adequately covered in the manual. + +2001-10-03 Torbjorn Granlund + + * mpn/x86/pentium4/copyi.asm: New file. + * mpn/x86/pentium4/copyd.asm: New file. + + * gmp-impl.h: Implement separate MPN_COPY_INCR and MPN_COPY_DECR + macros for CRAY systems. + (CRAY _MPN_COPY): Delete. + +2001-10-02 Kevin Ryde + + * tests/mpz/t-popcount.c (check_data): Use "~ (unsigned long) 0" to + avoid compiler warnings on sco. + + * mpbsd/Makefile.am: Compile mpz files directly, no copying. + Use mpz/add.c and mpz/sub.c rather than mpz/aors.c. + (INCLUDES): Remove -DOPERATION_$*, no longer needed (by mpz). + + * mpz/aors.h: Renamed from mpz/aors.c. + * mpz/add.c, mpz/sub.c: New files, using mpz/aors.h. + * mpz/aors_ui.h: Renamed from mpz/aors_ui.c. + * mpz/add_ui.c, mpz/sub_ui.c: New files, using mpz/aors_ui.h. + * mpz/fits_s.h: Renamed and adapted from mpz/fits_s.c. + * mpz/fits_sshort.c, mpz/fits_sint.c, mpz/fits_slong.c: New files. + * mpz/mul_i.h: Renamed from mpz/mul_siui.c. + * mpz/mul_ui.c, mpz/mul_ui.c: New files, using mpz/mul_i.h. + * mpz/Makefile.am: Consequent updates. + (INCLUDES): Remove -DOPERATION_$*. + + * mpf/fits_s.h: Renamed and adapted from mpf/fits_s.c. + * mpf/fits_sshort.c, mpf/fits_sint.c, mpf/fits_slong.c: New files. + * mpf/fits_u.h: Renamed and adapted from mpf/fits_u.c. + * mpf/fits_ushort.c, mpf/fits_uint.c, mpf/fits_ulong.c: New files. + * mpf/Makefile.am: Consequent updates. + (INCLUDES): Remove -DOPERATION_$*. + + * cxx/osfuns.cc (__gmp_doprnt_params_from_ios): Don't use ios::hex etc + as cases in a switch, they're not constant in g++ 3.0. + + * mpn/Makeasm.am (.s.o, .s.obj, .S.o, .S.obj, .asm.o, .asm.obj): + Locate source file with test -f the same as automake. + (.S): Let CCAS do the preprocessing, and run libtool for .S.lo. + (.asm.lo): Run libtool via m4-ccas to get new style foo.lo right. + (COMPILE_FLAGS): Add $(DEFAULT_INCLUDES), per new automake. + * mpn/m4-ccas: New file. + * mpn/Makefile.am (EXTRA_DIST): Add it. + * mpn/asm-defs.m4: Add m4_not_for_expansion(`DLL_EXPORT'). + * mpn/x86/x86-defs.m4: Undefine PIC if DLL_EXPORT is set. + * configure.in (CFLAGS_PIC, ASMFLAGS_PIC): Remove, no longer needed. + + * acinclude.m4 (GMP_FUNC_VSNPRINTF): Warn what's omitted when + vsnprintf not available. + + * mpn/underscore.h: Remove file, not used since m68k converted to asm. + * mpn/Makefile.am (EXTRA_DIST): Remove it. + + * tests/refmpz.c: Add , for free(). + +2001-10-01 Torbjorn Granlund + + * mpn/x86/pentium4/sse2/submul_1.asm: Apply some algebraic + simplifications. + * mpn/x86/pentium4/sse2/addmul_1.asm: Comment. + +2001-10-01 Kevin Ryde + + * configure.in (--enable-cxx): New option for C++ support. + Add cxx and tests/cxx subdirectories. + * ltmain.sh, aclocal.m4: Update to libtool 2001-09-30. + + * cxx/Makefile.am, cxx/Makefile.in, cxx/osdoprnti.cc, cxx/osfuns.cc, + cxx/osmpf.cc, cxx/osmpq.cc, cxx/osmpz.cc: New files. + * Makefile.am: Add them, in new libgmpxx. + * gmp-h.in, gmp-impl.h: Prototypes and support. + * tests/cxx/Makefile.am, tests/cxx/Makefile.in, + tests/cxx/t-ostream.cc: New files. + + * tune/speed.h (SPEED_ROUTINE_MPN_GCD_CALL, + SPEED_ROUTINE_MPN_GCDEXT_ONE): mpn_gcdext needs size+1 for + destinations. Found by Torbjorn. + + * gmp-h.in (__GNU_MP__, __GNU_MP_VERSION): Bump to 4.0. + * mp-h.in (__GNU_MP__): Ditto. + * gmp.texi, Makefile.am, compat.c: Amend version 3.2 to 4.0. + + * acinclude.m4 (GMP_PROG_CXX_WORKS): New macro. + (GMP_PROG_CC_WORKS): Write "conftest" test program, not a.out. + + * gmp-impl.h (struct gmp_asprintf_t): Moved from printf/vasprintf.c. + (GMP_ASPRINTF_T_INIT): New macro. + (GMP_ASPRINTF_T_NEED): New macro, adapted from vasprintf.c NEED(). + * printf/vasprintf.c: Use these. + + * printf/asprntffuns.c: New file. + * printf/Makefile.am, Makefile.am: Add it. + * printf/asprntffuns.c, printf/vasprintf.c, gmp-impl.h + (__gmp_asprintf_memory, __gmp_asprintf_reps, __gmp_asprintf_final): + Move to asprntffuns.c, rename to __gmp and make global, remove + spurious formal parameters from __gmp_asprintf_final. + + * configure.in (j90-*-*, sv1-*-*): Don't duplicate $path in $add_path. + (*-*-mingw*): Don't assemble with -DPIC (as per cygwin). + + * printf/snprntffuns.c (gmp_snprintf_final): Remove spurious formal + parameters. + + * tune/tuneup.c (POWM_THRESHOLD): Reduce stop_factor to 1.1 to help + Cray vector systems. + + * tests/misc.c (tests_rand_start): Print GMP_CHECK_RANDOMIZE=NN to + facilitate cut and paste when re-running. + * tests/mpz/t-inp_str.c (check_data): Add more diagnostic prints. + +2001-09-30 Kent Boortz + + * macos/configure, macos/Makefile.in, macos/README: Updates for gmp 4. + * gmp-h.in (_GMP_H_HAVE_FILE): Recognise Apple MPW. + +2001-09-30 Torbjorn Granlund + + * mpn/cray/ieee/submul_1.c: Rewrite. Streamline multiplications; + use `majority' logic. + +2001-09-27 Torbjorn Granlund + + * gmp-h.in (__GMPN_AORS_1): Rewrite to work around Cray compiler bug. + +2001-09-26 Torbjorn Granlund + + * mpn/x86/pentium4/sse2/gmp-mparam.h: New file. + +2001-09-26 Kevin Ryde + + * mpn/x86/pentium4/sse2/dive_1.asm: New file. + * mpn/x86/pentium4/sse2/submul_1.asm: New file. + * mpn/x86/pentium4/sse2/sqr_basecase.asm: New file. + + * mpn/x86/pentium/copyi.asm: New file, based on past work by Torbjorn. + * mpn/x86/pentium/copyi.asm: New file, ditto. + * mpn/x86/pentium/com_n.asm: Rewrite, ditto. + + * printf/snprntffuns.c (gmp_snprintf_format): Copy va_list in case + vsnprintf trashes it. + * printf/vasprintf.c (gmp_asprintf_format): Ditto. + * gmp-impl.h, doprnt.c (va_copy): Move to gmp-impl.h. + + * tests/mpz/t-cmp_d.c (check_low_z_one): Patch by Torbjorn for vax + limited float range. + +2001-09-23 Torbjorn Granlund + + * mpn/vax/lshift.s: Change `jsob*' to `sob*'. + * mpn/vax/rshift.s: Likewise. + +2001-09-23 Kevin Ryde + + * mpn/x86/pentium4/sse2/mul_basecase.asm: Some simple but real code. + + * printf/doprnt.c: Use va_copy for va_list variables, copy function + parameter in case it's call-by-reference. + + * tune/freq.c (speed_cpu_frequency_bsd_dmesg): New function. + (speed_cpu_frequency_table): Use it. + + * tune/many.pl (popcount, hamdist): Fix declared return value. + (sb_divrem_mn): Remove a spurious duplicate entry. + (CLEAN): Add tmp-$objbase.c when using that for .h files. + (macro_speed): Give a default for .h files. + Add ATTRIBUTE_CONST or __GMP_ATTRIBUTE_PURE as appropriate. + + * tune/speed.h (SPEED_ROUTINE_MPN_MOD_CALL, + SPEED_ROUTINE_MPN_PREINV_MOD_1, SPEED_ROUTINE_MPN_POPCOUNT, + SPEED_ROUTINE_MPN_HAMDIST, SPEED_ROUTINE_MPN_GCD_1N, + SPEED_ROUTINE_MPN_GCD_1_CALL, SPEED_ROUTINE_MPZ_JACOBI): Use return + values so gcc 3 won't discard calls to pure or const functions. + (mpn_mod_1_div, mpn_mod_1_inv): Add __GMP_ATTRIBUTE_PURE. + +2001-09-22 Torbjorn Granlund + + * mpn/x86/pentium4/sse2/mul_basecase.asm: New file, placeholder + for real code, hiding the default x86 mul_basecase.asm. + +2001-09-22 Kevin Ryde + + * configure.in (AC_PREREQ): Bump to 2.52. + (m4_pattern_forbid, m4_pattern_allow): New calls, forbid GMP_. + (AC_CHECK_HEADERS): Remove sys/types.h, already done by autoconf. + * acinclude.m4, configure.in (GMP_GCC_NO_CPP_PRECOMP): New macro. + + * tests/devel/try.c (TYPE_PREINV_MOD_1): Don't run size==0. + (malloc_region): Need fd=-1 for mmap MAP_ANON on BSD. + +2001-09-20 Torbjorn Granlund + + * mpz/cong.c (mpz_congruent_p): Fix one-limb c + + * mpn/x86/pentium4/sse2/diveby3.asm: New file. + * mpn/x86/pentium4/sse2/mode1o.asm: New file. + +2001-09-16 Kevin Ryde + + * printf/doprnt.c: '#' means showpoint and showtrailing for %e, %f, %g. + * tests/printf/t-printf.c (check_f): More test cases. + +2001-09-15 Torbjorn Granlund + + * gmp-h.in (__GMPN_AORS_1): Remove param TEST, add OP and CB. + Postpone zeroing of (cout). + (__GMPN_ADD_1, __GMPN_SUB_1): Corresponding changes. + +2001-09-14 Kevin Ryde + + * ChangeLog: Merge in tests/rand/ChangeLog. + * tests/rand/ChangeLog: Remove file. + + * printf/doprnt.c: Fix handling of a plain format after a GMP one; no + need to protect against negative precision internally. + * tests/printf/t-printf.c (check_misc): More checks. + +2001-09-12 Torbjorn Granlund + + * mpn/cray/ieee/invert_limb.c: Add a PROLOGUE in a comment to have + HAVE_NATIVE_... defined. + +2001-09-11 Kevin Ryde + + * configure.in, gmp-h.in (__GMP_HAVE_HOST_CPU_FAMILY_power, + __GMP_HAVE_HOST_CPU_FAMILY_powerpc): New AC_SUBSTs. + * gmp-h.in (__GMPN_COPY_INCR): Use them to select the power/powerpc + code, rather than preprocessor defines. + + * acinclude.m4, configure.in (GMP_H_ANSI): New macro. + + * gmp-h.in (__GMP_EXTERN_INLINE): Add a definition for SCO 8 cc. + + * gmp-h.in, version.c (gmp_version): Make the pointer "const" as well + as the string. + + * acinclude.m4, configure.in (GMP_PROG_CC_IS_XLC): Recognise xlc when + invoked under another name (cc, xlc128, etc). + * acinclude.m4 (GMP_PROG_CC_IS_GCC): Print a message when recognised. + +2001-09-11 Torbjorn Granlund + + * gmp-h.in: Let __DECC mean __GMP_HAVE_CONST, etc. + * mp-h.in: Likewise. + +2001-09-10 Torbjorn Granlund + + * mpn/x86/pentium4/mmx/lshift.asm: New file. + * mpn/x86/pentium4/mmx/rshift.asm: New file. + + * tests/mpn/t-iord_u.c (check_incr_data): Work around HP compiler bug. + (check_decr_data): Likewise. + +2001-09-08 Kevin Ryde + + * gmp.texi (Integer Logic and Bit Fiddling): Update mpz_hamdist + behaviour, clarify mpz_popcount a touch. + (Language Bindings): Add mlton, fix alphabetical order. + (Single Limb Division): Describe 2 or 1/2 limbs at a time style. + + * configure.in (AC_CHECK_FUNCS): Add mmap. + * tests/devel/try.c (malloc_region): Use mmap if available. + + * tests/refmpz.c, tests/tests.h (refmpz_hamdist): New function. + * tests/mpz/t-hamdist.c: New file. + * tests/mpz/Makefile.am: Add it. + + * mpz/hamdist.c: Support neg/neg operands. + + * macos/Makefile.in: Remove dual compile of mpq/aors.c and + mpn/generic/popham.c. + + * gmp-impl.h (popc_limb): New macro, adapted from mpn/generic/popham.c. + For 64-bits reuse 0x33...33 constant. + * mpn/generic/popcount.c, mpn/generic/hamdist.c: Split from popham.c, + use popc_limb macro, remove unused "i", don't bother with "register" + qualifiers. + * mpn/generic/popham.c: Remove file. + + * ltmain.sh, configure, aclocal.m4: Update to libtool 1.4.1, with one + ltdll.c generation patch. + * doc/configuration: Misc updates, note libtool patch used. + + * mpn/x86/pentium4/sse2/mul_1.asm: Use pointer increments not indexed + addressing, to get 4.0 c/l flat. + + * tests/mpq/t-cmp_si.c (check_data): Use ULONG_MAX for denominators. + + * tests/misc.c (mpz_negrandom): Use given rstate, not RANDS. + +2001-09-07 Torbjorn Granlund + + * mpn/x86/pentium4/sse2/addmul_1.asm: New file. + +2001-09-04 Kevin Ryde + + * tune/freq.c: Define a HAVE for each speed_cpu_frequency routine to + avoid duplicating conditionals. + (speed_cpu_frequency_sco_etchw): New function. + (speed_cpu_frequency_table): Use it. + * tune/README: Mention SCO openunix 8 /etc/hw. + + * mpz/fib_ui.c: Use ?: to avoid a gcc 3 bug on powerpc64. + Store back a carry for limb + + * configure.in (m68k-*-*): Let m68k mean 68000, not 68020. + * gmp.texi (Notes for Particular Systems): Update. + + * gmp-impl.h (union ieee_double_extract) [m68k]: Use longs, since int + might be only 16 bits. + + * tests/mpq/t-aors.c: New file. + * tests/mpq/Makefile.am: Add it. + + * tests/refmpq.c: New file. + * tests/Makefile.am: Add it. + * tests/tests.h: Add prototypes. + + * mpq/aors.c: Share object code for mpq_add and mpq_sub. + * Makefile.am, mpq/Makefile.am: Single mpq/aors.lo now. + + * tests/devel/try.c (TYPE_SUBMUL_1): Use correct reference routine. + +2001-08-30 Kevin Ryde + + * mpn/x86/x86-defs.m4 (cmov_available_p): Add pentium4. + + * gmp-h.in: Put #define renamings with prototypes. + Remove commented out #defines of gmp-impl.h things. + (mpn_invert_limb): Remove #define, already in gmp-impl.h. + (mpn_lshiftc, mpn_rshiftc): Remove #defines, unused. + (mpn_addsub_nc): Add prototype to #define. + +2001-08-28 Kevin Ryde + + * gmp.texi: Switch to GFDL. + (Top): Arrange copyright and conditions to appear here too. For + clarity have all this before the miscellaneous macro definitions. + (Copying): Refer to COPYING.LIB file, mention plain GPL2 in demo + programs. + (Contributors, References): Use @appendix rather than @unnumbered. + (GNU Free Documentation License): New appendix. + (@contents): Move to start of document, use only for tex (not html). + (Debugging): Add leakbug. + (Build Options): Add pentium4. + (I/O of Rationals): Add mpq_inp_str. + + * fdl.texi: New file, with two @appendix directive tweaks. + * Makefile.am (gmp_TEXINFOS): Add it. + + * tests/mpz/io.c: Check mpz_inp_str return against ftell, send error + messages just to stdout. + + * mpz/inp_str.c, gmp-impl.h (__gmpz_inp_str_nowhite): New function, + and share a __gmp_free_func call. + * mpq/inp_str.c: New file. + * Makefile.am, mpq/Makefile.am: Add it. + * tests/mpq/t-inp_str.c: New file. + * tests/mpq/Makefile.am (check_PROGRAMS): Add it. + + * configure.in, acconfig.h (HAVE_HOST_CPU_FAMILY_power, + HAVE_HOST_CPU_FAMILY_powerpc, HAVE_HOST_CPU_FAMILY_x86): AC_DEFINEs + for processor families. + * gmp-impl.h: Use them, rather than cpp defines. + + * demos/Makefile.am (primes_LDADD): Use $(LIBM), for log(). + + * tune/many.pl, tune/Makefile.am: Fix some from clean and distclean. + +2001-08-26 Kevin Ryde + + * tests/devel/try.c (ARRAY_ITERATION): Make types match on "?:" legs. + (TYPE_MPZ_JACOBI, TYPE_MPZ_KRONECKER): Remove some superseded code. + + * tests/printf/t-printf.c (check_plain): Don't compare "all digits" + precision against plain printf. + + * tune/Makefile.am: Eliminate empty TUNE_MPZ_SRCS. + + * configure, config.in, INSTALL.autoconf: Update to autoconf 2.52. + * */Makefile.in, mdate-sh, missing, aclocal.m4, configure: Update to + automake 1.5. + * configfsf.guess, configfsf.sub: Update to 2001-08-23. + +2001-08-24 Torbjorn Granlund + + * demos/primes.c: Complete rewrite. + +2001-08-24 Kevin Ryde + + * longlong.h: Test __ppc__ for apple darwin cc, reported by Jon + Becker. Also test __POWERPC__, PPC and __vxworks__. + + * tune/speed.h (speed_cyclecounter) [x86]: Don't clobber ebx in PIC. + +2001-08-22 Kevin Ryde + + * configure.in (x86 mmx): Correction to mmx path stripping. + +2001-08-17 Kevin Ryde + + * configure.in, acinclude.m4, Makefile.am, printf/Makefile.am, + tests/printf/Makefile.am, gmp-h.in, gmp-impl.h, gmp.texi: Remove C++ + support, for the time being. + * printf/doprntfx.cc, doprntix.cc, osfuns.cc, osmpf.cc, osmpq.cc, + osmpz.cc, tests/printf/t-ostream.cc: Remove files. + + * printf/doprnt.c, printf/doprntf.c, gmp-impl.h: Use a single + __gmp_doprnt_mpf, rather than a separate ndigits calculation. + * printf/doprnt.c, printf/doprntf.c, gmp-impl.h, gmp.texi, + tests/printf/t-printf.c: Let empty or -1 prec mean all digits for mpf. + * printf/doprnt.c, tests/printf/t-printf.c: Accept h or l in %n; let + negative "*" style width mean left justify. + + * gmp-impl.h, mpf/get_str.c (MPF_SIGNIFICANT_DIGITS): New macro, + extracted from mpf/get_str.c. + + * libmp.sym: New file. + * Makefile.am (libmp_la_LDFLAGS): Use it. + (DISTCLEANFILES): Remove asm-syntax.h, no longer generated. + Remove some comments about "make check". + + * demos/perl/GMP.pm, GMP.xs, GMP/Mpf.pm: Add printf and sprintf, + change get_str to string/exponent for floats, remove separate + mpf_get_str. + * demos/perl/GMP/Mpf.pm (overload_string): Use $# (default "%.g"). + * demos/perl/typemap: Fix some duplicate string entries. + * demos/perl/test.pl: Update tests, split overloaded constants into ... + * demos/perl/test2.pl: ... this new file. + * demos/perl/Makefile.PL (clean): Add test.tmp. + +2001-08-16 Kevin Ryde + + * printf/snprntffuns.c (gmp_snprintf_format): Correction to bufsize-1 + return value handling. + + * demos/calc/calc.y: Reposition "%{" so copyright notice gets into + generated files. + + * INSTALL: Use gmp_printf. + +2001-08-14 Kevin Ryde + + * mpz/inp_str.c: Fix return value (was 1 too big). + * tests/mpz/t-inp_str.c: New file. + * tests/mpz/Makefile.am: Add it. + + * mpn/x86/pentium4/sse2/add_n.asm: New file. + * mpn/x86/pentium4/sse2/sub_n.asm: New file. + * mpn/x86/pentium4/sse2/mul_1.asm: New file. + +2001-08-12 Kevin Ryde + + * printf/sprintffuns.c, printf/doprntf.c: Don't use sprintf return + value (it's a pointer on SunOS 4). + + * acinclude.m4 (GMP_ASM_X86_SSE2, GMP_STRIP_PATH): New macros. + * configure.in: Add pentium4 support. + * mpn/x86/pentium4, mpn/x86/pentium4/mmx, mpn/x86/pentium4/sse2: New + directories. + * mpn/x86/README: Update. + +2001-08-10 Torbjorn Granlund + + * demos/pexpr.c (setup_error_handler): Catch also SIGABRT. + +2001-07-31 Kevin Ryde + + * tests/refmpn.c (refmpn_mul_1c): Allow low to high overlaps. + + * gmp-h.in, gmp-impl.h (_gmp_rand): Move prototype to gmp-impl.h. + + * tune/Makefile.am (EXTRA_DIST): Add many.pl. + +2001-07-28 Kevin Ryde + + * gmp.texi (Random Number Functions): Old rand functions no longer use + the C library. + + * configure.in, acinclude.m4 (GMP_FUNC_VSNPRINTF): New macro. + + * mpn/generic/get_str.c: Add an ASSERT for high limb non-zero. + +2001-07-24 Kevin Ryde + + * gmp.texi (Build Options): Add --enable-cxx. + (Converting Floats): Note mpf_get_str only generates accurately + representable digits. + (Low-level Functions): Note mpn_get_str requires non-zero high limb. + (Formatted Output): New chapter. + (Multiplication Algorithms): Use @quotation with @multitable. + (Toom-Cook 3-Way Multiplication): Ditto. + + * tests/memory.c (tests_free_nosize): New function. + * tests/tests.h (tests_allocate etc): Add prototypes. + + * tests/printf: New directory. + * tests/printf/Makefile.am, t-printf.c, t-ostream.cc: New files. + * configure.in, tests/Makefile.am: Add them. + + * configure.in, acinclude.m4 (GMP_PROG_CXX): New macro. + * configure.in (--enable-cxx): New option. + (AC_CHECK_HEADERS): Add locale.h and sys/types.h, remove unistd.h. + (AC_CHECK_TYPES): Add intmax_t, long double, long long, ptrdiff_t, + quad_t. + (AC_CHECK_FUNCS): Add localeconv, memset, obstack_vprintf, snprintf, + strchr, vsnprintf. + (AC_CHECK_DECLS): Add vfprintf. + + * gmp-h.in, gmp-impl.h: Additions for gmp_printf etc. + + * printf: New directory. + * printf/Makefile.am, asprintf.c, doprnt.c, doprntf.c, doprntfx.cc, + doprnti.c, doprntix.cc, fprintf.c, obprintf.c, obprntffuns.c, + obvprintf.c, osfuns.cc, osmpf.cc, osmpq.cc, osmpz.cc, printf.c, + printffuns.c, snprintf.c, snprntffuns.c, sprintf.c, sprintffuns.c, + vasprintf.c, vfprintf.c, vprintf.c, vsnprintf.c, vsprintf.c: New + files. + * configure.in, Makefile.am: Add them. + + * configure.in (HAVE_INLINE): Remove AC_DEFINE, unused. + (AC_CHECK_TYPES): Don't test for void, assume it always exists. + + * gmp-impl.h (__GMP_REALLOCATE_FUNC_MAYBE): New macro. + * mpz/get_str.c, mpq/get_str.c, mpf/get_str.c: Use it. + + * gmp-impl.h (mpn_fib2_ui): Use __MPN. + (MPN_COPY_DECR): Fix an ASSERT. + (CAST_TO_VOID): Remove macro. + + * gmp-h.in (mpq_out_str): Give #define even without prototype. + (mpz_cmp_d, mpz_cmpabs_d): Corrections to #defines. + + * tests/devel/try.c: Add mpn_add and mpn_sub, don't use CAST_TO_VOID. + +2001-07-23 Torbjorn Granlund + + * config.guess: Recognize pentium4. + * config.sub: Recognize pentium4. + +2001-07-17 Kevin Ryde + + * gmp-h.in (__GMPN_AORS_1): Remove x86 and gcc versions, leave just + one version. + (__GMPN_ADD, __GMPN_SUB): New macros, rewrite of mpn_add and mpn_sub. + (mpn_add, mpn_sub): Use them. + (__GMPN_COPY_REST): New macro. + + * gmp-h.in, gmp-impl.h, acinclude.m4: Remove __GMP_ASM_L and + __GMP_LSYM_PREFIX, revert to ASM_L in gmp-impl.h and AC_DEFINE of + LSYM_PREFIX. + +2001-07-11 Kevin Ryde + + * gmp-h.in (__GMPN_ADD_1 etc) [x86]: Don't use this on egcs 2.91. + + * mpz/fits_uint.c, fits_ulong.c, mpz/fits_ushort.c: Split up fits_u.c. + * mpz/fits_u.c: Remove file. + * mpz/Makefile.am, macos/Makefile.in: Update. + + * tests/refmpn.c,tests.h (refmpn_copy): New function. + * tests/devel/try.c (TYPE_ZERO): No return value from call. + (TYPE_MODEXACT_1_ODD, TYPE_MODEXACT_1C_ODD): Share call with + TYPE_MOD_1 and TYPE_MOD_1C. + (MPN_COPY, __GMPN_COPY, __GMPN_COPY_INCR): Add testing. + +2001-07-10 Kevin Ryde + + * gmp-h.in (__GMPN_COPY): Add form to help gcc on power and powerpc. + * gmp-impl.h (MPN_COPY_INCR, MPN_COPY_DECR, MPN_ZERO): Ditto. + * mpn/powerpc64/copyi.asm, mpn/powerpc64/copyd.asm: Remove files. + + * mpz/tdiv_ui.c: Eliminate some local variables (seems to save code on + i386 gcc 2.95.x), remove a bogus comment about quotient. + + * errno.c, gmp-impl.h (__gmp_exception, __gmp_divide_by_zero, + __gmp_sqrt_of_negative): New functions. + * gmp-impl.h (GMP_ERROR, DIVIDE_BY_ZERO, SQRT_OF_NEGATIVE): Use them. + + * randclr.c, randraw.c: Use ASSERT(0) for unrecognised algorithms. + +2001-07-07 Kevin Ryde + + * configure.in (powerpc*-*-*): Use -no-cpp-precomp for Darwin. + + * tests/mpbsd/t-itom.c: Renamed from t-misc.c. + * tests/mpbsd/t-misc.c: Remove file. + * tests/mpbsd/Makefile.am: Update. + + * tests/mpf/t-set_si.c,t-cmp_si.c,t-gsprec.c: Split from t-misc.c. + * tests/mpf/t-misc.c: Remove file. + * tests/mpf/Makefile.am: Update. + + * tests/mpz/t-oddeven.c,t-set_si.c,t-cmp_si.c: Split from t-misc.c. + * tests/mpz/t-misc.c: Remove file. + * tests/mpz/Makefile.am: Update. + + * stack-alloc.c: Add some alignment ASSERTs. + + * gmp-impl.h (MPN_NORMALIZE): Add notes on x86 repe/scasl slow. + + * tests/devel/try.c (MPN_ZERO): Add testing. + * tune/speed.c,speed.h,common.c,many.pl (MPN_ZERO): Add measuring. + + * mpn/x86/divrem_1.asm: Update a remark about gcc and "loop". + + * tests/mpq/t-cmp_si.c: New file. + * tests/mpq/Makefile.am: Add it. + + * tests/misc.c,tests.h (mpq_set_str_or_abort): New function. + + * mpq/cmp_si.c: New file. + * Makefile.am, mpq/Makefile.am: Add it. + * gmp-h.in (mpq_cmp_si): Add prototype. + * gmp.texi (Comparing Rationals): Add doco. + + * gmp-h.in (_GMP_H_HAVE_FILE): Add _FILE_DEFINED for microsoft, add + notes on what symbols are for what systems. + +2001-07-06 Torbjorn Granlund + + * longlong.h (ibm032 umul_ppmm): Fix typo. + * longlong.h (sparclite sdiv_qrnnd): Fix typo. + +2001-07-03 Kevin Ryde + + * mpz/bin_ui.c (DIVIDE): Use MPN_DIVREM_OR_DIVEXACT_1. + * mpz/bin_uiui.c (MULDIV): Ditto, and use local variables for size and + pointer. + + * acinclude.m4 (GMP_INCLUDE_GMP_H): New macro, use it everywhere gmp.h + is wanted at configure time. + * acinclude.m4, configure.in (GMP_H_EXTERN_INLINE, GMP_H_HAVE_FILE): + New macros. + + * gmp-h.in (__GMP_EXTERN_INLINE): Set to "inline" for C++. + (mpn_add, mpn_sub): Use new style __GMP_EXTERN_INLINE. + * gmp-h.in, mp-h.in, gmp-impl.h (_EXTERN_INLINE): Remove, unused. + * mpn/generic/add.c, mpn/generic/sub.c: New files. + * mpn/generic/inlines.c: Remove file. + * configure.in, mpn/Makefile.am: Update. + + * gmp.texi (GMP Basics): Note the need for stdio.h to get FILE + prototypes. + +2001-07-01 Kevin Ryde + + * gmp.texi (Build Options, Reentrancy): Updates for new + --enable-alloca behaviour. + (Debugging): Describe --enable-alloca=debug. + (Miscellaneous Integer Functions): Note mpz_sizeinbase ignores signs. + (Low-level Functions): Give a formula for mpn_gcdext cofactor. + (Factorial Algorithm): New section. + (Binomial Coefficients Algorithm): New section. + Misc tweaks elsewhere. + + * mpf/set_prc.c: Merge the two truncation conditionals, misc cleanups, + no functional changes. + + * mpn/*/gmp-mparam.h (DIVEXACT_1_THRESHOLD): Add tuned values. + * gmp-impl.h (DIVEXACT_1_THRESHOLD): Make the default 0 when + 2*UMUL_TIME < UDIV_TIME. + + * mpn/x86/p6/dive_1.asm: New file. + + * mpn/x86/dive_1.asm: New file. + * mpn/x86/gmp-mparam.h (DIVEXACT_1_THRESHOLD): Use it always. + + * tests/refmpn.c, tests.h (refmpn_zero): New function. + * tests/devel/try.c: Use it. + + * tests/refmpn.c (refmpn_sb_divrem_mn): Use refmpn_cmp, not mpn_cmp. + + * tests/mpf/t-get_d.c (main): Use || not |. + + * tests/misc.c, tests/t-modlinv.c, tests/mpq/t-get_str.c, + tests/mpf/reuse.c: Add string.h. + +2001-06-29 Kevin Ryde + + * tune/speed.h (SPEED_ROUTINE_MPN_FIB2_UI, + SPEED_ROUTINE_COUNT_ZEROS_C): Corrections to TMP block handling. + + * gmp-impl.h (MPN_TOOM3_MUL_N_MINSIZE, MPN_TOOM3_SQR_N_MINSIZE): + Corrections to these to account for adding tD into E. + (MPN_INCR_U, MPN_DECR_U) [WANT_ASSERT]: Add size + assertions, since mpn_add_1 and mpn_sub_1 from gmp.h don't get them. + (MPN_DIVREM_OR_DIVEXACT_1): Add an assert of no remainder. + + * assert.c: Add stdlib.h for abort prototype. + * tests/spinner.c, trace.c, t-constants.c, t-count_zeros.c, + t-gmpmax.c, t-modlinv.c: Ditto. + * tests/mpz/t-bin.c, t-cmp.c, t-get_si.c, t-misc.c, t-popcount.c, + t-set_str.c, t-sizeinbase.c: Ditto. + * tests/mpq/t-equal.c, t-get_str.c, t-set_f.c, t-set_str.c: Ditto. + * tests/mpf/t-fits.c, t-get_d.c, t-get_si.c, t-int_p.c, t-misc.c, + t-trunc.c: Ditto. + * tests/mpbsd/allfuns.c, t-misc.c: Ditto. + + * mpn/generic/mul_n.c, mpz/cfdiv_r_2exp.c: Use MPN_INCR_U rather than + mpn_incr_u. + + * tests/devel/try.c (TYPE_SB_DIVREM_MN): More fixes for calling method. + + * mpn/x86/k6/cross.pl: More insn exceptions. + +2001-06-23 Kevin Ryde + + * gmp-h.in (__GMPN_ADD_1, __GMPN_SUB_1) [i386]: Fix some asm output + constraints. + + * gmp-impl.h (modlimb_invert): Mask after shifting, so mask constant + fits a signed byte. + + * tests/devel/try.c (TYPE_SB_DIVREM_MN): Fix initial fill of quotient + with garbage. + +2001-06-20 Kevin Ryde + + * config.guess (rs6000-*-aix4* | powerpc-*-aix4*): Suppress error + messages if $CC_FOR_BUILD or program don't work. + + * mpz/sqrt.c,sqrtrem.c: Special case for op==0, to avoid TMP_ALLOC(0). + * tests/refmpf.c (refmpf_add, refmpf_sub): Avoid TMP_ALLOC(0). + + * tests/mpn/t-aors_1.c: New file. + * tests/mpn/Makefile.am: Add it. + + * gmp-h.in (__GMPN_ADD_1, __GMPN_SUB_1): New macros, rewrite of + mpn_add_1 and mpn_sub_1, better code for src==dst and/or n==1, + separate versions for gcc x86, gcc generic, and non-gcc. + (mpn_add_1, mpn_sub_1): Use them. + (mpn_add, mpn_sub): Ditto, to get inlines on all compilers. + (extern "C") [__cplusplus]: Let this encompass the extern inlines too. + * mpn/generic/add_1.c,sub_1.c: New files, force code from gmp.h. + * configure.in, mpn/Makefile.am: Add them. + + * acinclude.m4 (GMP_ASM_LSYM_PREFIX): AC_SUBST __GMP_LSYM_PREFIX + rather than AC_DEFINE LSYM_PREFIX. + * gmp-h.in (__GMP_LSYM_PREFIX): New substitution. + (__GMP_ASM_L): New macro. + * gmp-impl.h (ASM_L): Use it. + + * acinclude.m4, configure.in (GMP_C_ATTRIBUTE_MALLOC): New macro. + * gmp-impl.h: Use it for all the malloc based TMP_ALLOCs. + + * stack-alloc.h: Remove file. + * tal-reent.c: New file. + * Makefile.am: Update. + + * acinclude.m4, configure.in (GMP_OPTION_ALLOCA): New macro, add + malloc-reentrant method, use stack-alloc.c as malloc-notreentrant, + make "reentrant" the default. + * gmp-impl.h (__TMP_ALIGN): Moved from stack-alloc.c, use a union to + determine the value, and demand only 4 bytes align on 32-bit systems. + * gmp-impl.h (WANT_TMP_NOTREENTRANT): Move global parts of + stack-alloc.h to here, allow non power-of-2 __TMP_ALIGN in TMP_ALLOC. + * gmp-impl.h: Extend extern "C" to TMP_ALLOC declarations. + * stack-alloc.c (tmp_stack): Move private parts of stack-alloc.h to + here, use gmp-impl.h. + + * gmp-impl.h (TMP_ALLOC_LIMBS_2): New macro. + * mpz/fib_ui.c, mpz/jacobi.c, mpq/cmp.c, mpn/generic/fib2_ui.c: Use it. + + * mpfr/exp2.c: Patch by Paul to match TMP_MARK and TMP_FREE in loop. + * mpfr/sqrt.c: Scope nested TMP_DECL into nested { } block, patch by + Paul, tweaked by me. + * mpfr/agm.c: Ditto, and add a final TMP_FREE(marker2). + + * gmp-h.in (mpn_cmp): Add __GMP_ATTRIBUTE_PURE. + + * INSTALL: Clarify "make install", tweak formatting a bit. + +2001-06-17 Kevin Ryde + + * configure.in, Makefile.am, gmp-impl.h: Add a debugging TMP_ALLOC, + selected with --enable-alloca=debug. + * tal-debug.c: New file. + * configure.in, Makefile.am: Compile stack-alloc.c only for + --disable-alloca. + * assert.c (__gmp_assert_header): New function, split from + __gmp_assert_fail. + + * mpz/lcm.c: Don't TMP_MARK and then just return. Remove unnecessary + _mpz_realloc prototype. + + * mpn/generic/mul.c (mpn_sqr_n): Use __gmp_allocate_func for toom3 + temporary workspace. + +2001-06-15 Kevin Ryde + + * tests/mpz/t-set_f.c: New file. + * tests/mpz/Makefile.am (check_PROGRAMS): Add it. + + * mpz/set_f.c: Share MPN_COPY between pad and trunc cases, do exp<=0 + test earlier, store SIZ(w) earlier. + + * tests/t-count_zeros.c: New file. + * tests/t-gmpmax.c: New file. + * tests/Makefile.am (check_PROGRAMS): Add them. + + * mp_clz_tab.c: Compile the table only if longlong.h says it's needed; + add an internal-use-only comment. + * tune/common.c: Force a __clz_tab for convenience when testing. + + * mpn/x86/pentium/gmp-mparam.h, mpn/x86/pentium/mmx/gmp-mparam.h: Add + COUNT_LEADING_ZEROS_NEED_CLZ_TAB, for mod_1.asm. + + * longlong.h (count_leading_zeros) [pentium]: Decide to go with float + method for p54. + (count_leading_zeros) [alpha]: Add COUNT_LEADING_ZEROS_NEED_CLZ_TAB. + (__clz_tab): Provide a prototype only if it's needed. + + * tests/trace.c (mpz_trace): Don't use = on structures. + (mpn_trace): Set _mp_alloc when creating mpz. + +2001-06-12 Kevin Ryde + + * mpn/x86/divrem_1.asm: Amend some comments about P5 speed. + + * tune/README: Clarify reconfigure on gmp-mparam.h update. + + * mpn/x86/p6/copyd.asm: New file. + * mpn/x86/p6/README: Update copyd and mod_1. + * mpn/x86/copyd.asm: Amend some comments. + + * gmp-impl.h (__builtin_constant_p): Add dummy for non-gcc. + (mpn_incr_u, mpn_decr_u): Recognise incr==1 at compile time in the + generic code on gcc. + + * gmp-impl.h (ASSERT_ZERO_P, ASSERT_MPN_NONZERO_P): New macros. + * mpn/generic/gcd_1.c, mpn/generic/mul_fft.c: Use them. + * mpz/get_d.c: Add a private mpn_zero_p. + * mpfr/trunc.c: Use own mpn_zero_p. + * tune/speed.h (SPEED_ROUTINE_MPN_GCD_1N): Use refmpn_zero_p. + * gmp-impl.h (mpn_zero_p): Remove, no longer needed. + + * gmp-h.in, gmp-impl.h: Move MPN_CMP to gmp.h as __GMPN_CMP, leave an + MPN_CMP alias in gmp-impl.h. + * gmp-h.in (mpn_cmp): Add an inline version. + * mpn/generic/cmp.c: Use __GMP_FORCE_mpn_cmp to get code from gmp.h. + + * acinclude.m4 (GMP_C_ATTRIBUTE_MODE): New macro. + * configure.in: Call it. + * gmp-impl.h (SItype etc): Use it. + + * randraw.c (lc): Change mpn_mul_basecase->mpn_mul, + mpn_incr_u->MPN_INCR_U, abort->ASSERT_ALWAYS(0). + + * longlong.h (count_leading_zeros) [pentiumpro]: Work around a partial + register stall on gcc < 3. + + * gmp.texi (Introduction to GMP): Add IA-64. + (Notes for Particular Systems): i386 means generic x86. + + * tests/t-modlinv.c: Use tests_start and tests_end. + +2001-06-10 Kevin Ryde + + * gmp.texi (Number Theoretic Functions): mpz_jacobi only defined for b + odd. Separate the jacobi/legendre/kronecker descriptions. + (Low-level Functions): Document mpn_mul_1 "incr" overlaps. + (Language Bindings): New chapter. + + * mpz/jacobi.c: Don't retaining old behaviour of mpz_jacobi on even b + (it wasn't documented in 3.1.1). + * mpz/jacobi.c, gmp-h.in (mpz_kronecker, mpz_legendre): Remove + separate entrypoints, just #define to mpz_jacobi. + * compat.c (__gmpz_legendre): Add compatibility entrypoint. + + * mpn/generic/mul_1.c: Allow "incr" style overlaps. + * tests/devel/try.c (param_init): Test this. + + * mpf/mul_ui.c: Do size==0 test earlier. + +2001-06-08 Kevin Ryde + + * gmp-impl.h (ULONG_HIGHBIT, UINT_HIGHBIT, USHRT_HIGHBIT): Cast + ULONG_MAX etc to unsigned long etc before attempting to right shift. + + * acinclude.m4 (GMP_ASM_LSYM_PREFIX): Add an AC_DEFINE of LSYM_PREFIX. + * gmp-impl.h (ASM_L): New macro. + (mpn_incr_u, mpn_decr_u, MPN_INCR_U, MPN_DECR_U): Add i386 optimized + versions. + + * mpn/hppa/*.s,S,asm: Use .label so the code works with gas on hppa + GNU/Linux too, reported by LaMont Jones . + * mpn/hppa/README: Add some notes on this. + * acinclude.m4 (GMP_ASM_LABEL_SUFFIX): Ditto. + + * mpn/Makefile.am (nodist_libdummy_la_SOURCES): Add dive_1.c, + fib2_ui.c. + + * tests/mpn/t-iord_u.c: New file. + * tests/mpn/Makefile.am (check_PROGRAMS): Add it. + + * configure.in (mips*-*-irix[6789]*): Make ABI=n32 the default, same + as in gmp 3.1. + * gmp.texi (ABI and ISA): Update. + + * gmp.texi (Build Options): Misc tweaks. + (Notes for Particular Systems): Describe windows DLL handling. + (Known Build Problems): DJGPP needs bash 2.04. + (Number Theoretic Functions): mpz_invert returns 0<=r + + * configure.in, gmp-h.in, mp-h.in: Add support for windows DLLs. + +2001-05-26 Kevin Ryde + + * gmp.texi (ABI and ISA, Reentrancy): Minor tweaks + (Notes for Package Builds): Note gmp.h is a generated file. + (Notes for Particular Systems): -march=pentiumpro is used for gcc + 2.95.4 and up. + (Assembler Loop Unrolling): Mention non power-of-2 unrolling. + (Internals): New chapter. + * mpf/README: Remove file. + + * demos/expr/README: Miscellaneous rewordings. + + * demos/perl: New directory. + * demos/Makefile.am: Add it. + * demos/perl/INSTALL, Makefile.PL, GMP.pm, GMP.xs, typemap, + GMP/Mpz.pm, GMP/Mpq.pm, GMP/mpf.pm, GMP/Rand.pm, sample.pl, test.pl: + New files. + + * configure, aclocal.m4: Update to autoconf 2.50. + + * configure, aclocal.m4, ltmain.sh: Update to libtool 1.4. + + * configure, aclocal.m4, missing, ansi2knr.c, */Makefile.in: Update to + automake 1.4f. + * Makefile.am: Conditionalize mpfr in $(SUBDIRS) to handle mpfr.info. + * mpfr/Makefile.am (INFO_DEPS): Remove previous mpfr.info handling. + * mpn/Makefile.am (GENERIC_SOURCES): Remove this, just put mp_bases.c + in libmpn_la_SOURCES. + * tests/Makefile.am (tests.h): Move from EXTRA_HEADERS to + libtests_la_SOURCES. + * ltconfig: Remove file, no longer needed. + + * Makefile.am (gmp-impl.h, longlong.h, stack-alloc.h): Move from + EXTRA_DIST to libgmp_la_SOURCES, so they get included in TAGS. + * tests/rand/Makefile.am (gmpstat.h): Move to libstat_la_SOURCES + similarly. + + * config.guess (68k-*-*): Use $SHELL not "sh", tweak some comments. + + * mpfr/mpfr.texi (Introduction to MPFR): Tweak table formatting, note + non-free programs must be able to be re-linked. + +2001-05-20 Kevin Ryde + + * mpn/powerpc64/addmul_1.asm, mpn/powerpc64/mul_1.asm, + mpn/powerpc64/submul_1.asm: Add carry-in entrypoints. + +2001-05-17 Kevin Ryde + + * gmp.texi (ge): Fix definition for info. + (Notes for Particular Systems): Mention 68k dragonball and cpu32. + (Efficiency): Add static linking, more about in-place operations, + describe mpq+/-integer using addmul. + (Reporting Bugs): A couple of words about self-contained reports. + (Floating-point Functions): Note exponent limitations of mpf_get_str + and mpf_set_str. + (Initializing Floats): Clarify mpf_get_prec, mpf_set_prec and + mpf_set_prec_raw a bit. + (Float Comparison): Note current mpf_eq deficiencies. + + * gmp-h.in (__GMP_HAVE_CONST, __GMP_HAVE_PROTOTYPES, + __GMP_HAVE_TOKEN_PASTE): Merge GNU ansidecl.h tests for ANSI compilers. + * demos/expr/expr-impl-h.in: Ditto. + + * gmp-impl.h (BITS_PER_MP_LIMB): Define from __GMP_BITS_PER_MP_LIMB if + not already in gmp-mparam.h. + * tests/t-constants.c (BITS_PER_MP_LIMB, __GMP_BITS_PER_MP_LIMB): + Check these are the same. + + * gmp-h.in (mpf_get_default_prec, mpf_get_prec, mpf_set_default_prec, + mpf_set_prec_raw): Provide "extern inline" versions, use __GMPF on the + macros. + * mpf/get_dfl_prc.c, mpf/get_prc.c, mpf/set_dfl_prc.c, + mpf/set_prc_raw.c: Get code from gmp.h using __GMP_FORCE. + + * gmp-h.in, gmp-impl.h (__gmp_default_fp_limb_precision): Move from + gmp-impl.h to gmp-h.in. + (__GMPF_BITS_TO_PREC, __GMPF_PREC_TO_BITS): Ditto, and use __GMPF + prefix and add a couple of casts. + * gmp-h.in (__GMP_MAX): New macro. + * mpf/init2.c mpf/set_prc.c: Update for __GMPF prefix. + + * gmp-h.in (__GMP_BITS_PER_MP_LIMB): New templated define. + * acinclude.m4 (GMP_C_SIZES): Add AC_SUBST __GMP_BITS_PER_MP_LIMB, + remove AC_DEFINE BITS_PER_MP_LIMB. + +2001-05-13 Kevin Ryde + + * gmp-h.in, gmp.texi, Makefile.am, mpz/Makefile.am, tests/mpz/t-pow.c: + Remove mpz_si_pow_ui, pending full si support. + * mpz/si_pow_ui.c: Remove file. + +2001-05-11 Kevin Ryde + + * mpn/x86/pentium/dive_1.asm: New file. + + * mpn/powerpc32/umul.asm: Use r on registers. + * mpn/powerpc64/umul.asm: New file. + * configure.in (powerpc*-*-*): Enable umul in extra_functions. + + * tests/refmpn.c, tests/tests.h (refmpn_umul_ppmm): Use same arguments + as normal mpn_umul_ppmm. + (refmpn_mul_1c): Update. + * tests/devel/try.c, tune/many.pl: Add some umul_ppmm testing support. + + * mpn/x86/k6/mmx/popham.asm, mpn/x86/k7/mmx/popham.asm: Don't support + size==0. + * mpn/x86/pentium/popcount.asm, mpn/x86/pentium/hamdist.asm: Ditto, + and shave a couple of cycles from the PIC entry code. + + * mpz/mul.c: Use mpn_mul_1 for size==1 and mpn_mul_2 (if available) + for size==2, to avoid copying; do vsize==0 test earlier. + + * mpf/sub.c: Test r!=u before calling mpf_set. + * mpf/add.c: Ditto, and share mpf_set between usize==0 and vsize==0. + + * mpn/generic/tdiv_qr.c, mpq/get_d.c, mpf/div.c, mpf/set_q.c, + mpf/set_str.c, mpf/ui_div.c: Test for high bit set, not for + count_leading_zeros zero. + + * acinclude.m4 (GMP_PROG_AR, GMP_PROG_NM): Print a message if extra + flags are added. + + * tests/mpz/t-mul_i.c: New file. + * tests/mpz/Makefile.am: Add it. + + * mpz/mul_siui.c (mpz_mul_si): Fix for -0x80..00 on long long limb. + + * gmp-h.in (mpf_set_si, mpf_set_ui): Revert last change, set exp to 0 + when n==0. + * mpf/ceilfloor.c, mpf/trunc.c: Fix exp to 0 when setting r to 0. + * gmp-impl.h (MPF_CHECK_FORMAT): Check exp==0 when size==0. + +2001-05-07 Kevin Ryde + + * gmp-h.in (mpf_set_si, mpf_set_ui): Don't bother setting _mp_exp to 0 + when n==0 (use 1 unconditionally). + * tests/mpf/t-misc.c (check_mpf_set_si): Don't demand anything of + _mp_exp when _mp_size is zero. + + * mpn/x86/README: Note gas _GLOBAL_OFFSET_TABLE_ with leal problem. + + * gmp-h.in (mpz_fits_uint_p, mpz_fits_ulong_p, mpz_fits_ushort_p): + Provide these as "extern inline"s. + (__GMP_UINT_MAX, __GMP_ULONG_MAX, __GMP_USHRT_MAX): New macros. + (mpz_popcount): Use __GMP_ULONG_MAX. + * gmp-impl.h (UINT_MAX, ULONG_MAX, USHRT_MAX): Use __GMP_U*_MAX, if + not already defined. + * mpz/fits_u.c: Use the code from gmp.h. + +2001-05-06 Kevin Ryde + + * mpn/x86/k7/dive_1.asm: New file. + * mpn/x86/k7/gcd_1.asm: New file. + * mpn/asm-defs.m4 (m4_count_trailing_zeros): New macro. + + * gmp-h.in (mpz_get_ui, mpz_getlimbn, mpz_set_q, mpz_perfect_square_p, + mpz_popcount, mpz_size, mpf_set_ui, mpf_set_si, mpf_size): Provide + these as "extern inlines". + Use just one big extern "C" block. + * mpz/getlimbn.c, mpz/get_ui.c, mpz/perfsqr.c, mpz/popcount.c + mpz/set_q.c, mpz/size.c, mpf/set_si.c, mpf/set_ui.c, mpf/size.c: Use + __GMP_FORCE to get code from gmp.h. + +2001-05-03 Kevin Ryde + + * extract-dbl.c: Add ASSERT d>=0. + + * gmp.texi (Efficiency): Add mpz_addmul etc for mpz+=integer, add + mpz_neg etc in-place. + (Integer Arithmetic): Add mpz_addmul, mpz_submul, mpz_submul_ui. + (Initializing Rationals): Add mpq_set_str. + (Low-level Functions): mpn_set_str requires strsize >= 1. + + * gmp-h.in (__GMP_EXTERN_INLINE, __GMP_ABS): New macros. + (mpz_abs, mpq_abs, mpf_abs, mpz_neg, mpq_neg, mpf_neg): Provide inline + versions. + * mpz/abs.c, mpq/abs.c, mpf/abs.c, mpz/neg.c, mpq/neg.c, mpf/neg.c: + Add suitable __GMP_FORCE to turn off inline versions. + + * tests/mpz/t-aorsmul.c,t-cmp_d.c,t-popcount,t-set_str.c: New files. + * tests/mpz/Makefile.am: Add them. + + * mpz/aorsmul_i.c: New file, rewrite of addmul_ui.c. Add + mpz_submul_ui entrypoint, share more code between some of the + conditionals, use mpn_mul_1c if available. + * mpz/addmul_ui.c: Remove file. + * mpz/aorsmul.c: New file. + * Makefile.am, mpz/Makefile.am: Update. + * gmp-h.in (mpz_addmul, mpz_submul, mpz_submul_ui): Add prototypes. + * gmp-impl.h (mpz_aorsmul_1): Add prototype. + + * tests/mpq/t-set_str.c: New file. + * tests/mpq/Makefile.am: Add it. + + * mpq/set_str.c: New file. + * Makefile.am, mpq/Makefile.am: Add it. + * gmp-h.in (mpq_set_str): Add prototype. + + * mpz/set_str.c: Fix for trailing white space on zero, eg. "0 ". + * mpn/generic/set_str.c: Add ASSERT str_len >= 1. + + * gmp-h.in, gmp-impl.h (mpn_incr_u, mpn_decr_u): Move to gmp-impl.h. + * gmp-impl.h (MPN_INCR_U, MPN_DECR_U): New macros. + +2001-04-30 Kevin Ryde + + * tests/mpz/t-lcm.c: New file. + * tests/mpz/Makefile.am (check_PROGRAMS): Add it. + + * mpz/lcm.c: Add one limb special case. + + * mpz/lcm_ui.c: New file. + * Makefile.am, mpz/Makefile.am: Add it. + * gmp-h.in (mpz_lcm_ui): Add prototype. + * gmp.texi (Number Theoretic Functions): Add mpz_lcm_ui, document lcm + now always positive. + + * mp-h.in (mp_size_t, mp_exp_t): Fix typedefs to match gmp-h.in. + + * gmp-h.in (mpn_add_1, mpn_add, mpn_sub_1, mpn_sub): Remove K&R + function defines (ansi2knr will handle mpn/inline.c, and just ansi is + enough for gcc extern inline). + + * gmp-h.in (__GMP_HAVE_TOKEN_PASTE): New macro. + (__MPN): Use it. + * gmp-impl.h (CNST_LIMB): Ditto. + + * gmp-h.in, mp-h.in (__gmp_const, __gmp_signed, _PROTO, __MPN): Use + ANSI forms on Microsoft C. + (__GMP_HAVE_CONST): New define. + * gmp-impl.h (const, signed): Use it. + + * demos/expr/expr-impl-h.in (): Use this with Microsoft C. + (HAVE_STDARG): New define. + * demos/expr/expr.c,exprz.c,exprq.c,exprf.c,exprfr.c: Use it. + + * acinclude.m4 (GMP_C_STDARG): New macro. + * configure.in: Call it. + * rand.c: Use it. + + * configure.in (AC_PROG_CC_STDC): New test. + +2001-04-25 Kevin Ryde + + * mpn/x86/k6/mmx/dive_1.asm: New file. + * mpn/x86/x86-defs.m4 (Zdisp): Two more insns. + + * mpn/x86/pentium/mul_2.asm: New file. + * mpn/asm-defs.m4: Add define_mpn(mul_2). + * acconfig.h (HAVE_NATIVE_mpn_divexact_1, mul_2): Add templates. + + * configure.in (ABI): Use AC_ARG_VAR. + + * tests/devel/try.c: Run reference function when validate fails. + + * mpq/get_str.c: Fixes for negative bases. + * tests/mpq/t-get_str.c: Check negative bases. + * tests/misc.c,tests.h (__gmp_allocate_strdup, strtoupper): New + functions. + +2001-04-24 Torbjorn Granlund + + * mpz/lcm.c (mpz_lcm): Make result always positive. + + * gmp-h.in (mpz_inp_binary, mpz_out_binary): Remove declarations. + +2001-04-22 Kevin Ryde + + * mpn/powerpc64/addsub_n.asm: Use config.m4 not asm-syntax.m4. + + * mpz/cmp_d.c, mpz/cmpabs_d.c: New files. + * Makefile.am, mpz/Makefile.am: Add them. + * mpf/cmp_d.c, mpf/get_dfl_prec.c: New files. + * Makefile.am, mpf/Makefile.am: Add them. + * gmp-h.in (mpz_cmp_d, mpz_cmpabs_d, mpf_cmp_d, mpf_get_default_prec): + Add prototypes. + * gmp.texi: Add documentation. + + * mpf/set_prc.c: Avoid a realloc call if already the right precision. + + * gmp-impl.h (MPF_BITS_TO_PREC, MPF_PREC_TO_BITS): New macros. + * mpf/get_prc.c, init2.c, set_dfl_prec.c, set_prc.c, set_prc_raw.c: + Use them. + +2001-04-20 Kevin Ryde + + * tests/devel/try.c: Don't test size==0 on mpn_popcount and + mpn_hamdist; add testing for mpn_divexact_1; print some limb values + with mpn_trace not printf. + + * mpz/popcount.c, mpz/hamdist.c: Don't pass size==0 to mpn_popcount + and mpn_hamdist. + * mpn/generic/popham.c: Don't support size==0. + + * config.guess (m68k-*-*): Detect m68010, return m68360 for cpu32, + cleanup the nesting a bit. + + * gmp.texi (Integer Division): Fix mpz_congruent_2exp_p "c" type. + (Integer Division): Add mpz_divexact_ui. + (Number Theoretic Functions): Fix mpz_nextprime return type. + (Exact Remainder): Divisibility tests now implemented. + And more index entries in a few places. + + * tests/mpz/dive_ui.c: New file. + * tests/mpz/Makefile.am (check_PROGRAMS): Add it. + + * mpz/dive_ui.c: New file. + * Makefile.am, mpz/Makefile.am: Add it. + * gmp-h.in (mpz_divexact_ui): Add prototype. + + * tune/many.pl, tune/speed.h: Add special mpn_back_to_back for + development. + + * gmp-impl.h (MPN_DIVREM_OR_DIVEXACT_1): New macro. + * mpz/divexact.c: Use it. + + * gmp-impl.h (DIVEXACT_1_THRESHOLD): New threshold. + * tune/tuneup.c: Tune it. + + * tune/speed.c,speed.h,common.c,many.pl: Add measuring of + mpn_divexact_1, mpn_copyi, mpn_copyd. + + * mpn/generic/dive_1.c: New file. + * configure.in (gmp_mpn_functions): Add it. + * gmp-impl.h (mpn_divexact_1): Add prototype. + * mpn/asm-defs.m4: Add define_mpn(divexact_1). + + * tests/mpn: New directory. + * tests/Makefile.am: Add it. + * tests/mpn/Makefile.am: New file. + * configure.in (AC_OUTPUT): Add it. + * tests/mpn/t-asmtype.c: New file. + + * configure, config.in: Update to autoconf 2.49d. + + * configure.in, gmp-h.in, mp-h.in, demos/expr/expr-impl-h.in: Revert + to generating gmp.h, mp.h and expr-impl.h with AC_OUTPUT and AC_SUBST. + + * configure.in (m68*-*-*): Oops, m683?2 is 68000, m68360 is cpu32. + * mpn/m68k/m68k-defs.m4 (scale_available_p): Ditto. + + * configure.in (underscore, asm_align): Remove these variables, unused. + (GMP_ASM_*): Sort by AC_REQUIREs, to avoid duplication. + * acinclude.m4 (GMP_ASM_UNDERSCORE, GMP_ASM_ALIGN_LOG): Remove support + for actions, no longer needed. + +2001-04-17 Kevin Ryde + + * config.guess (m68k-*-*): Look for cpu in linux kernel /proc/cpuinfo. + + * acinclude.m4 (GMP_GCC_MARCH_PENTIUMPRO): The -mpentiumpro problem is + fixed in 2.95.4, so test for that. + (GMP_ASM_TYPE): Amend some comments. + + * tune/freq.c (speed_cpu_frequency_sysctl): Avoid having unused + variables on GNU/Linux. + + * mpn/asm-defs.m4 (m4_instruction_wrapper): Fix a quoting problem if + the name of the file is a macro. + +2001-04-15 Kevin Ryde + + * mpn/powerpc64/*.asm: Add speeds on ppc630. + + * acconfig.h: Add dummy templates for _LONG_LONG_LIMB and HAVE_MPFR. + * configure.in: Ensure config.in is the last AM_CONFIG_HEADER, + which autoheader requires. + + * mpn/x86/pentium/popcount.asm: New file. + * mpn/x86/pentium/hamdist.asm: New file. + + * mpn/asm-defs.m4: (m4_popcount): New macro. + Amend a few comments elsewhere. + + * acinclude.m4 (GMP_ASM_RODATA): If possible, grep compiler output for + the right directive. + + * tune/speed.c: Print clock speed in MHz, not cycle time. + + * configure.in (AC_CHECK_HEADERS): Check for sys/processor.h. + * tune/freq.c (speed_cpu_frequency_processor_info): Require + to exist, to differentiate the different + processor_info on Darwin. + (speed_cpu_frequency_sysctlbyname): Remove hw.model test which is in + speed_cpu_frequency_sysctl. + (speed_cpu_frequency_sysctl): Add hw.cpufrequency for Darwin. + + * gmp-impl.h (MPN_LOGOPS_N_INLINE, mpn_and_n ... mpn_xnor_n): Use a + single expression argument for the different operations, necessary for + the Darwin "smart" preprocessor. + + * mpn/m68k/t-m68k-defs.pl: Allow white space in m4_definsn and + m4_defbranch. + + * tune/many.pl: Change RM_TMP_S to RM_TMP to match mpn/Makeasm.am, + avoid a possibly undefined array in a diagnostic, add more renaming to + hamdist. + +2001-04-13 Kevin Ryde + + * ltmain.sh, aclocal.m4, configure, config.in: Update to libtool 1.3d. + * configure.in: Change ac_ to lt_ in lt_cv_archive_cmds_need_lc and + lt_cv_proc_cc_pic. + + * config.guess (m68*-*-*): Detect exact cpu with BSD sysctl hw.model, + detect 68000/68010 with trapf, detect 68302 with bfffo. + +2001-04-11 Kevin Ryde + + * acinclude.m4 (GMP_ASM_M68K_INSTRUCTION, GMP_ASM_M68K_ADDRESSING, + GMP_ASM_M68K_BRANCHES): New macros. + * configure.in: Use them, remove old 68k configs, use mc68020 udiv and + umul. + + * mpn/m68k/m68k-defs.m4: New file. + * mpn/m68k/t-m68k-defs.pl: New file. + * mpn/m68k/*.asm: New files, converted from .S. Merge add_n and sub_n + to aors_n, ditto mc68020 addmul_1 and submul_1 to aorsmul_1. No + object code changes (except .type and .size now used on NetBSD 1.4). + * mpn/m68k/README: New file. + * mpn/m68k/*.S, */*.S, syntax.h: Remove files. + + * configure.in (m68*-*-netbsd1.4*): Pretend getrusage doesn't exist. + * tune/README: Update. + + * configure.in (powerpc*-*-*): For the benefit of Darwin 1.3, add cc + to cclist, make gcc_cflags -Wa,-mppc optional. + +2001-04-06 Kevin Ryde + + * mpn/lisp/gmpasm-mode.el (gmpasm-comment-start-regexp): Add | for 68k. + (gmpasm-mode-syntax-table): Add to comments. + + * tests/mpz/reuse.c (dsi_div_func_names): Add names for cdiv_[qr]_2exp. + +2001-04-04 Kevin Ryde + + * acinclude.m4 (GMP_M4_M4WRAP_SPURIOUS): Fix test so as to actually + detect the problem, add notes on m68k netbsd 1.4.1. + + * gmp.texi (Compatibility with older versions): Note libmp + compatibility. + +2001-04-03 Kevin Ryde + + * tests/mpz/reuse.c: Add mpz_cdiv_q_2exp and mpz_cdiv_r_2exp. + + * tests/mpz/t-pow.c: Drag in refmpn.o when testing mpz_pow_ui etc with + refmpn_mul_2. + + * tune/speed.c,speed.h,common.c,many.pl: Add measuring of mpn_com_n + and mpn_mul_2. + * tests/devel/try.c: Add testing of mpn_mul_2, and a + DATA_MULTIPLE_DIVISOR attribute. + + * gmp.texi (Build Options): List more m68k's. + (Build Options): Add cross reference to tex2html. + (Notes for Particular Systems): Add m68k means 68020 or up. + (Rational Conversions): New section, with mpq_get_d, mpq_set_d and + mpq_set_f from Miscellaneous, and new mpq_set_str. + (Applying Integer Functions): Move mpq_get_num, mpq_get_den, + mpq_set_num and mpq_set_den from Misc. + (Miscellaneous Rational Functions): Remove section. + (Custom Allocation): Partial rewrite for various clarifications. + (References): Improve line breaks near URLs. + + * acinclude.m4 (GMP_GCC_M68K_OPTIMIZE): New macro. + * configure.in (m68*-*-*): Use it to run gcc 2.95.x at -O not -O2. + (m680?0-*-*, m683?2-*-*, m68360-*-*): Add optional gcc -m options. + + * tests/mpz/t-cmp.c: New file. + * tests/mpz/t-sizeinbase.c: New file. + * tests/mpz/Makefile.am: Add them. + + * gmp-impl.h (MPN_CMP): New macro. + * mpz/cmp.c,cmpabs.c: Use it, and minor cleanups too. + + * tests/mpq/t-equal.c: New file. + * tests/mpq/t-get_str.c: New file. + * tests/mpq/Makefile.am: Add them. + + * mpq/get_str.c: New file. + * Makefile.am, mpq/Makefile.am: Add it. + * gmp-h.in (mpq_get_str): Add prototype. + + * mpq/equal.c: Rewrite using inline compare loops. + + * tests/refmpn.c,tests.h (refmpn_mul_2): Fix parameter order. + * mpz/n_pow_ui.c: Fix mpn_mul_2 calls parameter order. + +2001-03-29 Kevin Ryde + + * tests/mpf/t-trunc.c: New file. + * tests/mpf/Makefile.am (check_PROGRAMS): Add it. + * gmp-impl.h (MPF_CHECK_FORMAT): New macro. + + * mpf/trunc.c: New file, rewrite of integer.c, preserve prec+1 in + copy, don't copy if unnecessary. + * mpf/ceilfloor.c: New file likewise, and use common subroutine for + ceil and floor. + * mpf/integer.c: Remove file. + * Makefile.am, mpf/Makefile.am, macos/Makefile.in: Update. + + * acinclude.m4 (GMP_GCC_VERSION_GE): New macro. + (GMP_GCC_MARCH_PENTIUMPRO): Use it, remove CCBASE parameter (don't + bother checking it's gcc). + (GMP_GCC_ARM_UMODSI): New macro. + * configure.in (GMP_GCC_MARCH_PENTIUMPRO): Update parameters. + (arm*-*-*): Use GMP_GCC_ARM_UMODSI. + * gmp.texi (Notes for Particular Systems): Add arm gcc requirements. + +2001-03-28 Kevin Ryde + + * gmp.texi (Converting Integers): Document mpz_getlimbn using absolute + value and giving zero for N out of range, move to end of section. + + * tests/refmpn.c (refmpn_tdiv_qr): Use refmpn_divmod_1 rather than + refmpn_divrem_1. + * tests/tests.h: Add some prototypes that were missing. + + * mpz/tdiv_q_ui.c: Remove a comment that belonged to mpz_tdiv_r_ui. + +2001-03-26 Torbjorn Granlund + + * mpn/generic/gcdext.c: Handle carry overflow after m*n multiply code + in both arms. Partially combine multiply arms. + +2001-03-24 Kevin Ryde + + * longlong.h: Add comments to P5 count_leading_zeros. + + * demos/expr/exprz.c,t-expr.c,README: Add congruent_p and divisible_p. + +2001-03-23 Kevin Ryde + + * gmp.texi (GMPceil, GMPfloor, ge, le): New macros. + (Integer Division, mpn_cmp, mpn_sqrtrem, Algorithms): Use them. + (mpn_bdivmod): Refer to mp_bits_per_limb, not BITS_PER_MP_LIMB, and + improve formatting a bit. + (mpn_lshift, mpn_rshift): Clarify the return values, and use {rp,n} + for the destination. + Miscellaneous minor rewordings in a few places. + + * mpn/arm/arm-defs.m4: New file. + * configure.in (arm*-*-*): Use it. + * mpn/arm/*.asm: Use changecom and registers from arm-defs.m4, use L() + for local labels. + + * mpn/x86/k6/mmx/com_n.asm: Relax code alignment (same speed). + + * gmp-h.in (__GMP_ATTRIBUTE_PURE): Use __pure__ to avoid application + namespace. + + * gmp-impl.h (ABS): Add parens around argument. + +2001-03-20 Kevin Ryde + + * acinclude.m4 (GMP_PROG_M4): Use AC_ARG_VAR on $M4. + + * acinclude.m4 (GMP_M4_M4WRAP_SPURIOUS): New macro. + * configure.in: Use it. + * mpn/asm-defs.m4: Ditto. + +2001-03-18 Kevin Ryde + + * mpn/x86/pentium/logops_n.asm: New file. + + * mpn/x86/k6/k62mmx/copyd.asm: Rewrite, smaller and simpler, faster on + small sizes, slower on big sizes (about half the time). + * mpn/x86/k6/k62mmx/copyi.asm: Remove file, in favour of generic x86. + * mpn/x86/copyi.asm: Add some comments. + * mpn/x86/k6/README: Update. + + * mpn/x86/k6/gcd_1.asm: New file. + + * gmp-impl.h (NEG_MOD): Fix type of __dnorm. + + * acinclude.m4 (GMP_C_SIZES): Fix use of __GMP_WITHIN_CONFIGURE. + +2001-03-15 Kevin Ryde + + * gmp.texi (GMPabs): New macro. + (Float Comparison - mpf_reldiff): Use it. + (Integer Comparisons - mpz_cmpabs): Ditto, puts "abs" in info. + (Reentrancy): Update notes on old random functions. + (Karatsuba Multiplication): Better characterize the effect of basecase + speedups on the thresholds, pointed out by Torbjorn. + + * tune/README: Notes on the 1x1 div threshold for mpn_gcd_1. + + * tests/misc.c (mpz_pow2abs_p, mpz_flipbit, mpz_errandomb, + mpz_errandomb_nonzero, mpz_negrandom): New functions. + (mpz_erandomb, mpz_erandomb_nonzero): Use urandom(). + * tests/spinner.c (spinner_wanted, spinner_tick): Make global. + * tests/tests.h: Update prototypes. + + * tests/mpz/t-cong.c, tests/mpz/t-cong_2exp.c: New files. + * tests/mpz/Makefile.am (check_PROGRAMS): Add them. + + * mpz/cong.c, mpz/cong_2exp.c, mpz/cong_ui.c: New files. + * Makefile.am, mpz/Makefile.am: Add them. + * gmp-impl.h (NEG_MOD): New macro. + * gmp-h.in (mpz_congruent_p, mpz_congruent_2exp_p, + mpz_congruent_ui_p): Add prototypes. + * gmp.texi (Integer Division, Efficiency): Add documentation. + + * mpq/aors.c: No need for ABS on denominator sizes. + + * gmp-impl.h (mpn_divisible_p): Use __MPN. + + * gmp-impl.h (LOW_ZEROS_MASK): New macro. + * mpz/divis_ui.c, mpn/generic/divis.c: Use it. + + * mpz/setbit.c: Fix normalization for case of a negative ending up + with a zero high limb. + * tests/mpz/bit.c (check_single): New test for this problem. + + * configure.in (none-*-*): Fix cclist for default ABI=long. + +2001-03-10 Kevin Ryde + + * mpz/cfdiv_q_2exp.c: Don't scan for non-zero limbs if they don't + matter to the rounding. + + * mpz/get_ui.c: Fetch _mp_d[0] unconditionally, so the code can come + out branch-free. + +2001-03-08 Kevin Ryde + + * tests/devel/try.c (param_init): Fix reference functions for and_n + and nand_n. + + * tune/speed.c, tests/devel/try.c: Seed RANDS, not srandom etc. + * configure.in (AC_CHECK_FUNCS): Remove srand48 and srandom. + * macos/configure (coptions): Remove random/srandom, now unnecessary. + + * configure.in (gmp.h, mp.h, demos/expr/expr-impl.h): Generate using + AM_CONFIG_HEADER. + (_LONG_LONG_LIMB, HAVE_MPFR): Change to AC_DEFINEs. + * gmp-h.in, mp-h.in, demos/expr/expr-impl-h.in: Change to #undef's. + * acinclude.m4 (GMP_FUNC_ALLOCA, GMP_C_SIZES): Use gmp-h.in, not gmp.h. + * Makefile.am (EXTRA_DIST): Remove gmp-h.in and mp-h.in, now done + automatically. + * acinclude.m4 (GMP_FUNC_ALLOCA), gmp-impl.h: Set and use + __GMP_WITHIN_CONFIGURE rather than GMP_FUNC_ALLOCA_TEST. + + * mpf/random2.c: Use _gmp_rand and RANDS instead of random() for the + exponent, ensures full range of values too. + + * tests/mpz/t-div_2exp.c (check_various): Start with d based on i, but + don't let it go negative. + + * tune/tuneup.c (KARATSUBA_MUL_THRESHOLD): Limit probing to + TOOM3_MUL_THRESHOLD_LIMIT, the size of the workspace in mul_n.c. + Use a -1 with this too, so size + + * mpn/cray/cfp/mul_1.c: Don't call mpn_add_n with size 0. + * mpn/cray/cfp/addmul_1.c: Likewise. + * mpn/cray/cfp/submul_1.c: Don't call mpn_sub_n with size 0. + + * tests/mpz/t-div_2exp.c (check_various): Start 2nd d loop from 0 + (avoid problems with Cray compilers). + +2001-03-06 Torbjorn Granlund + + * mpn/cray/ieee/submul_1.c: Don't call mpn_sub_n with size 0. + + * mpn/cray/ieee/mul_basecase.c: New file. + * mpn/cray/ieee/sqr_basecase.c: New file, derived from mul_basecase.c. + +2001-03-06 Kevin Ryde + + * tests/devel/try.c (pointer_setup): Allow dst_size == SIZE_SIZE2 for + the benefit of mpn_tdiv_qr. + + * tune/tuneup.c (all): Start karatsuba probing at size==4, for the + benefit of cray t90 ieee which has speed oddities at size==2. + + * gmp-impl.h (USE_LEADING_REGPARM): Use __GMP_GNUC_PREREQ. + Use __GMP_ATTRIBUTE_PURE and ATTRIBUTE_CONST in a few places. + + * gmp-h.in (__GMP_GNUC_PREREQ) New macro. + (__GMP_ATTRIBUTE_PURE): New macro, use it in many places. + + * gmp-impl.h, gmp-h.in (mpn_jacobi_base): Move prototype to + gmp-impl.h, use ATTRIBUTE_CONST. + + * tune/speed.h (speed_cyclecounter): Inline asm version for i386. + + * mpz/cfdiv_r_2exp.c (cfdiv_r_2exp): Only reread "up" after second + realloc, first is under w!=u. + +2001-03-05 Torbjorn Granlund + + * mpn/cray/sub_n.c: Rewrite using `majority' logic. + + * mpz/cfdiv_r_2exp.c (cfdiv_r_2exp): Reread `up' after realloc of w. + + * mpn/cray/ieee/mul_1.c: Rewrite. Streamline multiplications; + use `majority' logic. + * mpn/cray/ieee/addmul_1.c: Likewise. + + * mpn/cray/add_n.c: Rewrite using `majority' logic. + +2001-03-04 Torbjorn Granlund + + * longlong.h (CRAY udiv_qrnnd): No longer conditional on CRAYMPP. + (64-bit hppa add_ssaaaa): New. + (64-bit hppa sub_ddmmss): New. + + * mpn/cray/ieee/invert_limb.c: New file. + + * gmp-impl.h (RANDS): Add a `,0' to make it compile on more compilers. + +2001-03-03 Kevin Ryde + + * mpz/n_pow_ui.c (ULONG_PARITY): Move to gmp-impl.h. + * gmp-impl.h (ULONG_PARITY): i386 part from n_pow_ui.c, new generic + form by Torbjorn. + + * tests/mpz/t-div_2exp.c: New file, rewrite of t-2exp.c. + * tests/mpz/t-2exp.c: Remove file. + * tests/mpz/Makefile.am (check_PROGRAMS): Update. + + * gmp-h.in (mpz_cdiv_q_2exp, mpz_cdiv_q_2exp): Add prototypes. + * gmp.texi (Integer Division): Add mpz_cdiv_q_2exp and mpz_cdiv_q_2exp. + + * mpz/cfdiv_q_2exp.c: New file, partial rewrite of fdiv_q_2exp.c, add + mpz_cdiv_q_2exp entrypoint. + * mpz/cfdiv_r_2exp.c: New file, rewrite of fdiv_r_2exp.c, use all mpn, + add mpz_cdiv_r_2exp entrypoint. + * mpz/fdiv_q_2exp.c, mpz/fdiv_r_2exp.c: Remove files. + * mpz/Makefile.am (libmpz_la_SOURCES): Update. + * Makefile.am (MPZ_OBJECTS): Ditto. + + * gmp-impl.h (USE_LEADING_REGPARM): Use __i386__ same as longlong.h + (REGPARM_2_1, REGPARM_3_1, REGPARM_ATTR): New macros. + * mpz/jacobi.c (jac_or_kron): Use them. + + * configure.in (HAVE_ABI_$ABI): Re-enable this for config.m4, with + dots changed to underscores (necessary for hppa). + + * tests/mpz/t-divis.c, tests/mpz/t-divis_2exp.c: New files. + * tests/mpz/Makefile.am (check_PROGRAMS): Add them. + + * gmp-h.in (mpz_divisible_p, mpz_divisible_ui_p, + mpz_divisible_2exp_p): Add prototypes. + * gmp.texi (Integer Division): Add mpz_divisible_p. + (Efficiency): Add remarks about divisibility testing. + + * mpz/divis.c, mpz/divis_ui.c, mpz/divis_2exp.c: New files. + * mpz/Makefile.am (libmpz_la_SOURCES): Add them. + * Makefile.am (MPZ_OBJECTS): Ditto. + + * mpn/generic/divis.c: New file. + * configure.in (gmp_mpn_functions): Add it. + * mpn/Makefile.am (nodist_libdummy_la_SOURCES): Ditto. + * gmp-impl.h (mpn_divisible_p): Add prototype. + + * urandom.h: Remove file. + * Makefile.am (EXTRA_DIST): Remove it. + + * tests/mpz/convert.c, dive.c, io.c, logic.c, reuse.c, t-2exp.c, + t-fdiv.c, t-fdiv_ui.c, t-gcd.c, t-jac.c, t-mul.c, t-pow.c, + t-powm.c, t-powm_ui.c, t-root.c, t-sqrtrem.c, t-tdiv.c, + t-tdiv_ui.c: Use RANDS, initialized by tests_rand_start. + + * tests/mpz/t-pow.c: New file, being t-pow_ui renamed and with some + further tests added. + * tests/mpz/t-pow_ui.c: Remove file. + * tests/mpz/Makefile.am (check_PROGRAMS): Update. + + * tests/t-modlinv.c: Don't use urandom.h. + * tests/mpz/bit.c, tests/mpz/t-scan.c: Ditto. + * tests/mpq/t-cmp.c, tests/mpq/t-cmp_ui.c, tests/mpq/t-get_d.c: Ditto. + * tests/mpf/reuse.c, t-add.c, t-conv.c, t-dm2exp.c, t-muldiv.c, + t-sqrt.c, t-sub.c: Ditto. + + * tests/misc.c (tests_rand_start, tests_rand_end): New functions. + (tests_start, tests_end): Use them. + (urandom): New function. + * tests/tests.h: Add prototypes. + + * mpz/random.c: Rewrite using mpz_urandomb and RANDS. + * mpn/generic/random.c: Rewrite using _gmp_rand and RANDS. + * mpn/generic/random2.c: Use RANDS not random() etc. + + * gmp-impl.h (__gmp_rands, __gmp_rands_initialized): Add externs. + (gmp_randstate_ptr): New typedef. + (RANDS, RANDS_CLEAR): New macros. + + * rands.c: New file. + * Makefile.am (libgmp_la_SOURCES): Add it. + + * configure.in (mpn_objs_in_libmp): New AC_SUBST. + * Makefile.am (libmp_la_DEPENDENCIES): Use it. + +2001-03-02 Torbjorn Granlund + + * mpn/pa64/udiv_qrnnd.asm: New file. + +2001-03-01 Kevin Ryde + + * mpbsd/rpow.c: New file. + * mpbsd/Makefile.am (libmpbsd_la_SOURCES): Add it + (nodist_libmpbsd_la_SOURCES): Remove pow_ui.c. + * Makefile.am (MPBSD_OBJECTS): Add rpow.lo, remove pow_ui.lo. + (libmp_la_DEPENDENCIES): Add mpz/n_pow_ui.lo. + + * mpz/ui_pow_ui.c: Rewrite using mpz_n_pow_ui. + * mpz/pow_ui.c: Ditto, and no longer provide rpow for mpbsd. + + * mpz/n_pow_ui.c: New file, rewrite of pow_ui.c and ui_pow_ui.c. Use + less temporary memory, strip factors of 2 from the base, use mpn_mul_2 + if available. + * mpz/si_pow_ui.c: New file. + * mpz/Makefile.am (libmpz_la_SOURCES): Add them. + * Makefile.am (MPZ_OBJECTS): Ditto. + * gmp-impl.h (mpz_n_pow_ui): Add prototype. + * gmp-h.in (mpz_si_pow_ui): Add prototype. + * gmp.texi (Integer Exponentiation): Add mpz_si_pow_ui. + + * acinclude.m4 (GMP_C_SIZES): Add BITS_PER_ULONG. + Correction to mp_limb_t working check. + * configure.in (limb_chosen): New variable. + * tests/t-constants.c (BITS_PER_ULONG): Check this value. + Add some reminders about tests that fail on Cray. + + * tests/refmpn.c (refmpn_mul_2): New function. + * tests/refmpz.c (refmpz_pow_ui): Copied from tests/mpz/t-pow_ui.c + * tests/tests.h: Add prototypes. + + * configure.in (none-*-*): Add ABI=longlong. + * doc/configuration (Long long limb testing): Describe it. + + * gmp.texi (Low-level Functions): Move some commented out remarks ... + * mpn/generic/mul_basecase.c: ... to here. + + * mpn/x86/README: Note "%=" as an alternative to "1:" in __asm__. + + * tests/trace.c (mp_trace_start): Print "bin" for binary. + + * mpn/generic/dump.c: Add a couple of casts to keep gcc quiet. + + * gmp-h.in (mpn_incr_u, mpn_decr_u): Add parens around arguments. + + * mpbsd/mout.c, mpbsd/mtox.c (num_to_text): Remove unused variable. + + * mpfr/set_d.c (mpfr_get_d2): Declare "q" for 64-bit limbs. + +2001-02-28 Torbjorn Granlund + + * mpn/pa64w/udiv_qrnnd.asm: Tune. + +2001-02-27 Torbjorn Granlund + + * mpn/pa64w/udiv_qrnnd.asm: New file. + +2001-02-26 Torbjorn Granlund + + * longlong.h (arm): Optimize sub_ddmmss by testing for constant + operands. + * mpn/arm/invert_limb.asm: New file. + +2001-02-24 Torbjorn Granlund + + * mpn/generic/lshift.c: Rewrite. + * mpn/generic/rshift.c: Rewrite. + + * longlong.h: Use UWtype for external interfaces that expect mp_limb_t. + + * longlong.h (arm): #define invert_limb. + + * mpn/arm: Make labels have local scope. + + * configure.in (arm*-*-*): Set extra_functions. + * longlong.h (arm): #define udiv_qrnnd. + * mpn/arm/udiv.asm: New file. + +2001-02-24 Kevin Ryde + + * tune/many.pl: Add mpn_count_leading_zeros, mpn_count_trailing_zeros + and mpn_invert_limb. Add count_leading_zeros, count_trailing_zeros + from a .h file. Correction to modexact_1_odd prototype. Support + ansi2knr. + * tune/speed.h, tune/common.c: Consequent changes. + + * demos/expr/*: Make a few more functions available in expressions, + create only libexpr.a, misc minor updates. + + * mpn/Makeasm.am: Add some comments about suffix ordering. + + * tests/refmpn.c (rshift_make, lshift_make): No need to compare + unsigned to zero. + + * mpq/mul.c: Detect and optimize squaring. + +2001-02-23 Torbjorn Granlund + + * mpn/mips3: Convert files to `.asm'. + + * mpn/arm: Convert files to `.asm'. Misc cleanups. + * mpn/arm/submul_1.asm: New file. + +2001-02-21 Kevin Ryde + + * tune/tuneup.c (all): Only one compiler print should match, no need + for #undef PRINTED_COMPILER. + + * mpfr/mpfr.h (mpfr_sgn): Use mpfr_cmp_ui (patch from Paul). + + * mpz/fib_ui.c: Update some remarks about alternative algorithms. + * gmp.texi (Fibonacci Numbers Algorithm): Ditto. + (Assigning Floats): Clarify mpf_swap swaps the precisions too. + (Low-level Functions): Try to be clearer about negative cofactors. + +2001-02-21 Torbjorn Granlund + + * mpn/sparc64/copyi.asm: Streamline for small operands. + * mpn/sparc64/add_n.asm: Likewise. + * mpn/sparc64/sub_n.asm: Likewise. + + * mpn/sparc64/copyd.asm: New file. + +2001-02-20 Torbjorn Granlund + + * mpn/sparc64/lshift.asm: Rewrite. + * mpn/sparc64/rshift.asm: Rewrite. + +2001-02-19 Torbjorn Granlund + + * mpn/sparc64/add_n.asm: Rewrite using `majority' logic. + * mpn/sparc64/sub_n.asm: Likewise. + + * tune/tuneup.c (all): Recognise DECC and MIPSpro compilers. + + * mpn/pa64/sqr_diagonal.asm: Use PROLOGUE/EPILOGUE. + * mpn/pa642/sqr_diagonal.asm: Likewise. + + * configure.in (HAVE_ABI_$abi): Disable for now. + + * mpn/asm-defs.m4 (PROLOGUE): Use LABEL_SUFFIX. + + * acinclude.m4 (GMP_ASM_ATTR): New check, for hppa oddities. + +2001-02-18 Torbjorn Granlund + + * mpn/hppa/hppa1_1/gmp-mparam.h: New file. + * mpn/hppa/hppa2_0/gmp-mparam.h: New file. + + * mpn/pa64/sqr_diagonal.asm: New file. + * mpn/pa64w/sqr_diagonal.asm: New file. + * mpn/hppa/hppa1_1/sqr_diagonal.asm: New file. + * mpn/hppa/hppa2_0/sqr_diagonal.asm: New file. + + * mpn/sparc32/v9/add_n.asm: Use `fitod' instead of `fxtod' for dummy + FA-pipeline insns. + * mpn/sparc32/v9/sub_n.asm: Likewise. + +2001-02-18 Kevin Ryde + + * gmp.texi (Known Build Problems): Notes on make, $* and K&R, misc + tweaks elsewhere. + (Low-level Functions): Use {} notation in mpn_sqrtrem. + (Basecase Multiplication): Mention BASECASE_SQR_THRESHOLD. + + * mpfr/isnan.c (mpfr_number_p): Infinity is not a number. + * mpfr/out_str.c: Pass strlen+1 for the block size to free. + * mpfr/get_str.c: Correction for realloc to strlen+1. + + * acinclude.m4 (GMP_C_SIZES): Generate an error if mp_limb_t doesn't + seem to work for some reason. + +2001-02-16 Torbjorn Granlund + + * mpn/sparc32/v9/gmp-mparam.h: Retune. + + * mpn/sparc32/v9/add_n.asm: New file. + * mpn/sparc32/v9/sub_n.asm: New file. + + * mpn/sparc32/v9/mul_1.asm: Tune function entry. + * mpn/sparc32/v9/addmul_1.asm: Likewise. + * mpn/sparc32/v9/submul_1.asm: Likewise. + + * mpn/sparc32/v9/sqr_diagonal.asm: New file. + +2001-02-16 Kevin Ryde + + * configure.in: Fix flags selection when $CC is a compiler known to us. + + * demos/expr/exprfr.c (e_mpfr_cos, e_mpfr_sin): mpfr_sin_cos now + allows NULL for one parameter. + + * mpfr/*: Update to 20010215. + * mpfr/trunc.c: Use -DOPERATION scheme, and gmp mpn_zero_p. + * mpfr/sqrt.c: Use plain mpn_sqrtrem, not mpn_sqrtrem_new. + * mpfr/sqrtrem.c: Remove file. + * mpfr/Makefile.am (libmpfr_a_SOURCES): Add isnan.c and set_ui.c, + remove sqrtrem.c and srandom.h. + + * configfsf.guess: Update to 2001-02-13. + * configfsf.sub: Update to 2001-02-16. + * config.sub (j90, t90): Remove special handing, configfsf.sub now ok. + + * Makefile.am (MPF_OBJECTS): Add a couple of missing $U's. + + * tune/tuneup.c: Identify compiler used (GCC and Sun C so far). + +2001-02-15 Torbjorn Granlund + + * mpn/sparc32/v9/mul_1.asm: Change `ld' to `lduw' and `st' to `stw'. + * mpn/sparc32/v9/addmul_1.asm: Likewise. + * mpn/sparc32/v9/submul_1.asm: Likewise. + +2001-02-14 Torbjorn Granlund + + * mpn/mips3/mips.m4: New file. + * configure.in (mips*-*-irix[6789]*): Use mips3/mips.m4. + + * mpn/powerpc64/sqr_diagonal.asm: New file. + + * mpn/mips3/sqr_diagonal.asm: New file. + +2001-02-12 Torbjorn Granlund + + * mpn/powerpc32/sqr_diagonal.asm: New file. + + * mpn/generic/sqr_basecase.c: Remove declaration of mpn_sqr_diagonal. + Fix typo in header comment. + +2001-02-12 Kevin Ryde + + * mpn/generic/mul.c, mpn/generic/mul_n.c, gmp-impl.h: Use + mpn_mul_basecase for squaring below new BASECASE_SQR_THRESHOLD. + * tune/tuneup.c gmp-impl.h: Tune BASECASE_SQR_THRESHOLD. + + * Makefile.am (libgmp.la, libmp.la): Revert change to build from + mpn/libmpn.la etc, go back to explicitly listed objects. + + * configure.in: Recognise sparc64-*-*, not just sparc64-*-linux*. + +2001-02-11 Torbjorn Granlund + + * mpn/asm-defs.m4 (sqr_diagonal): New define_mpn. + + * mpn/alpha/sqr_diagonal.asm: New file. + +2001-02-11 Kevin Ryde + + * gmp.texi (Low-level Functions): Note mpn_get_str clobbers its input + plus 1 extra limb. + + * mpfr/add.c,agm.c,exp2.c,exp3.c,generic.c,log2.c,pi.c,print_raw.c, + set_d.c,sin_cos.c,sqrtrem.c,sub.c: Apply some tweaks for K&R. + * tests/mpz/reuse.c, tests/mpq/t-md_2exp.c, demos/pexpr.c, + demos/expr/t-expr.c: Ditto. + + * configure.in (HAVE_ABI_$abi): New define in config.m4. + + * gmp-impl.h (mpn_sqr_diagonal): Add prototype and define. + * tune/speed.c,speed.h,common.c,many.pl: Add measuring of + mpn_sqr_diagonal. + + * gmp.texi, acinclude.m4: Mention x86 solaris 2.7 has the reg->reg + movq bug the same as 2.6. + + * mpfr/Makefile.am (EXTRA_DIST): Add mpfr-test.h and mpf2mpfr.h. + + * mpn/x86/README: Merge contents of README.family. + * mpn/x86/README.family: Remove file. + + * mpn/Makefile.am (nodist_libdummy_la_SOURCES): Add mode1o, gcd_finda, + invert_limb, sqr_diagonal; remove mod_1_rs; sort alphabetically. + +2001-02-10 Torbjorn Granlund + + * configure.in (gmp_mpn_functions_optional): List sqr_diagonal. + + * mpn/powerpc32/aix.m4: Use unnamed csects. + * mpn/powerpc64/aix.m4: Likewise. + + * acconfig.h: Add #undef of mpn_sqr_diagonal. + Remove lots of spacing. + + * configure.in (syntax testing section): Match power* instead of + powerpc*. + * mpn/power: Convert files to `.asm'. + Prefix umul_ppmm and sdiv_qrnnd. + Update some comments. + +2001-02-09 Kevin Ryde + + * acconfig.h: Add HAVE_NATIVE_mpn_modexact_1_odd and + HAVE_NATIVE_mpn_modexact_1c_odd. + + * configure.in (CCAS): Don't override a user selection. + + * mpq/cmp_ui.c: DIVIDE_BY_ZERO if den2==0. + +2001-02-08 Torbjorn Granlund + + * mpn/generic/sqr_basecase.c: Use mpn_sqr_diagonal when appropriate. + +2001-02-07 Kevin Ryde + + * gmp.texi (Low-level Functions): mpn_preinv_mod_1 now undocumented. + + * mpn/generic/random2.c (myrandom): Use rand() on mingw. + + * mpn/alpha/gmp-mparam.h: Update tuned parameters. + +2001-02-05 Torbjorn Granlund + + * mpn/alpha/ev6/gmp-mparam.h: Retune. + +2001-02-05 Kevin Ryde + + * Makefile.am (libgmp, libmp): Construct from mpn/libmpn.la etc rather + than explicitly listed objects. + + * urandom.h: Use rand() on mingw. + + * mpn/powerpc64/lshift.asm,addsub_n.asm: Use r1 not 1. + +2001-02-04 Torbjorn Granlund + + * mpn/ia64/copyi.asm: New file. + * mpn/ia64/copyd.asm: New file. + +2001-02-04 Kevin Ryde + + * mpn/alpha/ev5/gmp-mparam.h, mpn/mips3/gmp-mparam.h, + mpn/powerpc32/gmp-mparam.h, mpn/powerpc64/gmp-mparam.h, + mpn/sparc64/gmp-mparam.h, mpn/x86/*/gmp-mparam.h: + Update tuned parameters. + + * mpn/x86/i486: New directory. + * configure.in (i486-*-*): Use it. + * mpn/x86/i486/gmp-mparam.h: New file. + + * mpn/x86/pentium/mode1o.asm: New file. + * mpn/x86/p6/mode1o.asm: New file. + + * tune/many.pl: Use $(ASMFLAGS_PIC) and $(CFLAGS_PIC). + + * gmp.texi (Integer Division): Another rewording of 2exp divisions. + +2001-02-03 Torbjorn Granlund + + * mpn/arm/gmp-mparam.h: Tune. + + * mpn/ia64/popcount.asm: Put a `;;' break at end of main loop. + + * configure.in (arm*-*-*): Set gcc_cflags in order to pass + $fomit_frame_pointer. + + * tests/mpz/t-mul.c (base_mul): Remove an unused variable. + +2001-02-02 Torbjorn Granlund + + * demos/pexpr.c (TIME): New macro. + (main): Use TIME--print timing more accurately. + (setup_error_handler): Increase RLIMIT_DATA to 16 Mibyte. + + * longlong.h (arm): Add __CLOBBER_CC to add_ssaaaa and sub_ddmmss. + +2001-02-02 Kevin Ryde + + * configure.in: Don't remove gmp-mparam.h and mpn source links under + --no-create since in that case they're not re-created. + + * demos/expr: New directory. + * Makefile.am (SUBDIRS, allprogs): Add it. + * demos/expr/README, Makefile.am, expr.c, exprv.c, exprz.c, exprza.c, + exprq.c, exprqa.c, exprfa.c, exprf.c, exprfr.c, exprfra.c, expr.h, + expr-impl-h.in, run-expr.c, t-expr.c: New files. + * configure.in: Generate demos/expr/Makefile & demos/expr/expr-impl.h. + + * Makefile.am: Remove mpfr from main libgmp. + * mpfr/Makefile.am: Build and install separate libmpfr.a. + * mpfr/*: Update to mpfr 2001. + + * gmp-h.in (__GNU_MP_VERSION_MINOR): Bump to 2. + * Makefile.am (libtool -version-info): Bump appropriately. + * NEWS: Updates. + + * tune/divrem1div.c, tune/divrem1inv.c, tune/divrem2div.c, + tune/divrem2inv.c: Renamed from divrem_1_div.c, divrem_1_inv.c, + divrem_2_div.c, divrem_2_inv.c, to be unique in DOS 8.3 filenames. + * tune/Makefile.am (libspeed_la_SOURCES): Update. + + * mpn/x86/*/README, mpn/x86/README.family: Misc updates. + * tune/README: Misc updates. + * doc/configuration: Misc updates. + + * mpn/x86/pentium/mmx/gmp-mparam.h: Change UDIV_PREINV_TIME to + UDIV_NORM_PREINV_TIME. + + * mpz/pprime_p.c: Use ASSERT_ALWAYS instead of abort. + + * rand.c (__gmp_rand_lc_scheme): Add "const". + (struct __gmp_rand_lc_scheme_struct): Make astr "const char *". + + * demos/calc/calc.y, demos/calc/calclex.l: Add kron function. + + * tests/devel/try.c: Partial rewrite, new scheme of function types, + allow result validation functions, add sqrtrem and jacobi testing. + * tune/many.pl: Corresponding updates. + * tests/devel/Makefile.am: Add a convenience rule for libtests.la. + + * tests/refmpz.c: New file. + * tests/Makefile.am: Add it. + * tests/misc.c (mpz_erandomb, mpz_erandomb_nonzero): New functions. + * tests/tests.h: Add prototypes. + + * mpn/x86/k6/cross.pl: Add a couple more exceptions. + + * gmp.texi: Don't use @nicode{'\0'}, it doesn't come out right in tex. + (Introduction to GMP): Mention Cray vector systems. + (Build Options): Describe --enable-mpfr, refer to its manual. Add + Crays under supported CPUs. + (Debugging): Add notes on source file paths. + (Autoconf): New section. + (Assigning Integers): Note truncation by mpz_set_d, mpz_set_q and + mpz_set_f. + (Converting Integers): Note the size mpz_get_str allocates. + (Floating-point Functions): Rewrite introduction, clarifying some + points about precision handling. + (Converting Floats): Note the size mpf_get_str allocates, and that it + gives an empty string for zero. Add mpf_get_si and mpf_get_ui. + (Float Comparison): Give the formula mpf_reldiff calculates. + (Miscellaneous Float Functions): Add mpf_integer_p and mpf_fits_*_p. + (Random Number Functions): Misc rewordings for clarity. + (Random State Initialization): Ditto. + (Custom Allocation): Remove note on deallocate_function called with 0, + misc rewording and clarifications. + (Exact Remainder): New section. + (Binary GCD): A few words on initial reduction using division. + (Accelerated GCD): Refer to exact remainder section. + (Extended GCD): Extra remarks on single versus double selection. + (Jacobi Symbol): Update for mpz/jacobi.c rewrite and modexact_1_odd. + (Modular Powering Algorithm): Refer to exact remainder section. + (Assembler SIMD Instructions): Update remarks on MMX. + (Contributors): Amend to "Divide and Conquer" division. + (References): Tweak some formatting. Add "Proof of GMP Fast Division + and Square Root Implementations" by Paul Zimmermann. + +2001-01-31 Torbjorn Granlund + + * configure.in: Don't ever pass -mips3; let ABI flags imply ISA. + +2001-01-31 Kevin Ryde + + * tune/time.c: Remove unnecessary longlong.h. + (speed_endtime): Add some extra diagnostics. + + * tests/mpz/t-fdiv_ui.c, tests/mpz/t-tdiv_ui.c: Use unsigned long for + the divisor, not mp_limb_t. + * tests/mpz/t-jac.c (try_base): Use %llu for long long limb. + * tests/trace.c: Add for strlen. + + * tune/freq.c (speed_cpu_frequency_proc_cpuinfo): Ignore "cycle + frequency" of 0, allow "BogoMIPS" as well as "bogomips". + + * macos/Makefile.in: Add mpf/fits_s.c and mpf/fits_u.c objects. + +2001-01-30 Torbjorn Granlund + + * longlong.h: Add add_ssaaaa and sub_ddmmss for 64-bit sparc. + +2001-01-29 Torbjorn Granlund + + * mpn/powerpc64/addmul_1.asm: Prefix registers with an `r'. + * mpn/powerpc64/submul_1.asm: Likewise. + * mpn/powerpc64/mul_1.asm: Likewise. + + * configure.in (alpha*-*-*): Amend last change to handle pca*. + +2001-01-29 Kevin Ryde + + * tune/speed.h (SPEED_ROUTINE_INVERT_LIMB_CALL): Don't let the + compiler optimize everything away. + + * tune/speed.c, tune/speed.h, tune/common.c, tune/Makefile.am: Measure + operator_div, operator_mod, mpn_divrem_2_div, mpn_divrem_2_inv, + mpn_sb_divrem_m3, mpn_sb_divrem_m3_div, mpn_sb_divrem_m3_inv, + mpn_dc_divrem_sb_div, mpn_dc_divrem_sb_inv. + * tune/divrem_2_div.c, tune/divrem_2_inv.c, tune/sb_div.c, + tune/sb_inv.c: New files. + + * tune/tuneup.c, gmp-impl.h, tune/speed.h, tune/common.c, + tune/Makefile.am: Tune SB_PREINV_THRESHOLD and DIVREM_2_THRESHOLD. + + * mpn/generic/divrem_2.c: Use new DIVREM_2_THRESHOLD. + * mpn/generic/sb_divrem_mn.c: Use new SB_PREINV_THRESHOLD. + + * mpn/x86/p6/mmx/lshift.asm, mpn/x86/p6/mmx/rshift.asm: New files, + just m4 include()ing the P55 code. + * configure.in (pentium[23]-*-*): Remove x86/pentium/mmx from path. + +2001-01-27 Kevin Ryde + + * configure.in (AC_CHECK_FUNCS): Add srand48. + * tune/speed.c: Use this test. + + * acinclude.m4 (GMP_GCC_MARCH_PENTIUMPRO): Allow "egcs-" prefix on gcc + --version, warn if the format is unrecognised. + (GMP_COMPARE_GE): Guard against empty $1 not only on last arg. + (GMP_INIT, GMP_FINISH, GMP_PROG_M4): Obscure or eliminate literal + "dnl"s since autoconf thinks they indicate faulty macros. + + * mpz/get_str.c, mpf/get_str.c: Make allocated string block exactly + strlen(str)+1 bytes. + * mpz/dump.c, mpf/dump.c, tests/mpz/convert.c: Use this size when + freeing. + * tests/mpf/t-conv.c: Ditto, and ensure x==0 is exercised. + + * tests/mpz/t-fits.c: New file. + * tests/mpz/Makefile.am: Add it. + + * tests/mpf/t-fits.c: New file. + * tests/mpf/t-get_si.c: New file. + * tests/mpf/t-int.c: New file. + * tests/mpf/Makefile.am: Add them. + + * mpf/fits_s.c: New file. + * mpf/fits_u.c: New file. + * mpf/get_si.c: New file. + * mpf/get_ui.c: New file. + * mpf/int_p.c: New file. + * Makefile.am, mpf/Makefile.am: Add them. + * gmp-h.in (mpf_fits_*_p, mpf_get_si, mpf_get_ui, mpf_integer_p): Add + prototypes. + + * tests/memory.c (tests_allocate, tests_reallocate): Guard against + size==0. + + * tests/mpz/*.c, tests/mpq/*.c, tests/mpf/*.c: Uses tests_start and + tests_end. + + * gmp-impl.h (USE_LEADING_REGPARM): Fix conditionals. + +2001-01-23 Kevin Ryde + + * configure.in, mpn/Makeasm.am (ASMFLAGS_PIC): New substitution, + allowing -DPIC to be suppressed on cygwin. + (CFLAGS_PIC): New substitution, use it and $(CCAS) directly, rather + than $(LIBTOOL), avoiding a problem with FreeBSD 2.2.8. + + * mpn/x86/k6/mode1o.asm, mpn/x86/k7/mode1o.asm: Remove an unnecessary + +[.-L(here)] from _GLOBAL_OFFSET_TABLE_, avoids a segv from gas 1.92.3. + * mpn/x86/README.family: Add notes on the problem. + +2001-01-20 Torbjorn Granlund + + * configure.in (alpha*-*-*): Default `flavour' to ev4. + +2001-01-19 Kevin Ryde + + * assert.c, gmp-impl.h (__gmp_assert_fail): Change return type to + void, since it's no longer used in expressions. + + * mpn/x86/addsub_n.S: Remove file, since it doesn't work and it upsets + tune/many.pl. + + * mpz/jacobi.c: Rewrite, but still binary algorithm; accept zero and + negative denominators; merge mpz_jacobi and mpz_legendre, add + mpz_kronecker; use mpn directly, add special cases for size==1. + * gmp.texi (Number Theoretic Functions): Update. + * gmp-h.in (mpz_kronecker): Add prototype. + * gmp-impl.h (USE_LEADING_REGPARM): New macro. + * tests/mpz/t-jac.c: Test mpz_kronecker. + * mpz/legendre.c: Remove file. + * Makefile.am, mpz/Makefile.am: Update. + + * longlong.h (alpha count_leading_zeros): Use __attribute__ ((const)) + when possible, add parameter to prototype. + (ia64 udiv_qrnnd): Use for all compilers, not just gcc. + (pentium count_trailing_zeros): Use count_leading_zeros. + + * acinclude.m4 (GMP_C_ATTRIBUTE_CONST, GMP_C_ATTRIBUTE_NORETURN): New + macros. + * configure.in: Use them. + * gmp-impl.h (ATTRIBUTE_CONST, ATTRIBUTE_NORETURN): New macros. + (mpn_invert_limb): Add ATTRIBUTE_CONST. + (__gmp_assert_fail): Add ATTRIBUTE_NORETURN. + +2001-01-18 Kevin Ryde + + * gmp-h.in, gmp-impl.h (__gmp_allocate_func, __gmp_reallocate_func, + __gmp_free_func): Move prototypes from gmp-impl.h to gmp-h.in, for the + benefit of gmp++.h. + + * gmp-impl.h, tests/misc.c, tests/tests.h: Move MPZ_SET_STR_OR_ABORT + and MPF_SET_STR_OR_ABORT to mpz_set_str_or_abort and + mpf_set_str_or_abort in libtests. + * tests/mpz/convert.c, tests/mpz/t-bin.c, tests/mpz/t-get_si.c, + tests/mpz/t-jac.c, tests/mpz/t-misc.c, tests/mpq/t-md_2exp.c, + tests/mpq/t-set_f.c, tests/mpf/t-conv.c, tests/mpf/t-misc.c: Update. + + * mpn/generic/sqrtrem.c: Use MPN_COPY_INCR (for when rp==NULL). + + * tests/mpz/reuse.c: Only run mpz_divexact_gcd on positive divisors. + +2001-01-18 Torbjorn Granlund + + * demos/pexpr.c (main): Accept -vml option. + (fns): List `hamdist', `pow', `nextprime'. + (mpz_eval_expr): Return -1 for `popc' of negative. + (mpz_eval_expr): Handle `hamdist', `pow', `nextprime'. + +2001-01-15 Kevin Ryde + + * mpn/alpha/ev5/mode1o.c: New file. + + * tune/freq.c (speed_cpu_frequency_measure): Check cycles_works_p + before running speed_cyclecounter. + * tune/speed.h (cycles_works_p): Add prototype. + +2001-01-13 Torbjorn Granlund + + * tests/rand/t-rand.c (farr): Fix typo. + (zarr): Fix typo. + +2001-01-12 Kevin Ryde + + * mpz/kronsz.c: Don't depend on right shifting a negative. + + * mpn/x86/gmp-mparam.h: New file. + + * mpn/x86/pentium/mmx/mul_1.asm: New file. + +2001-01-11 Torbjorn Granlund + + * mpz/kronsz.c: Temporary workaround for Cray right shift oddities. + Explicitly compare against zero in tests. + +2001-01-10 Kevin Ryde + + * mpz/kronzs.c: Don't depend on right shifting a negative. + +2001-01-09 Torbjorn Granlund + + * tests/t-constants.c: Disable some undefined tests. + (CHECK_MAX_S): Remove workaround for gcc 2.95.2 bug recently added. + +2001-01-09 Kevin Ryde + + * tests/t-constants.c: Add more diagnostics. + (CHECK_MAX_S): Fix for gcc 2.95.2 -mpowerpc64 -maix64. + + * mpn/x86/k6/mode1o.asm: New file. + * mpn/x86/k7/mode1o.asm: New file. + + * mpn/asm-defs.m4 (modexact_1_odd, modexact_1c_odd): New define_mpn's. + (__clz_tab, modlimb_invert_table, PROLOGUE, EPILOGUE): Add asserts for + GSYM_PREFIX. + * mpn/x86/x86-defs.m4 (Zdisp): Add a movzbl. + + * tests/mpz/t-jac.c (check_a_zero): New test. + (check_squares_zi): Fix to use (a^2/b), not (a*b/b); revert last + change avoiding a,b=0, both are fine. + (try_2den): Don't use mpz_kronecker_ui for the expected answer. + (try_*): Call abort rather than exit. + + * mpz/kronzu.c, mpz/kronzs.c: Fix for a=0. + + * tune/tuneup.c (USE_PREINV_MOD_1): Fix to use new DATA_HIGH_LT_R. + +2001-01-08 Torbjorn Granlund + + * urandom.h: Amend 2000-11-21 change to also handle cygwin. + +2001-01-08 Kevin Ryde + + * tune/many.pl: Updates for move to tests/devel, add modexact_1_odd, + don't assume C files can't have carry-in entrypoints, remove + $(TRY_TESTS_OBJS) now in libtests. + + * tests/devel/try.c, tests/refmpn.c, tests/tests.h: Remove + mpn_mod_1_rshift testing. + + * tune/tuneup.c (fft_step_size): Test for overflow using the actual + mp_size_t, don't use BITS_PER_INT. + + * tune/speed.c (r_string): "r" is a limb, use BITS_PER_MP_LIMB and + change LONG_ONES to LIMB_ONES. + * tune/time.c (M_2POWU): Use INT_MAX rather than BITS_PER_INT. + + * extract-dbl.c (BITS_PER_PART): Use BITS_PER_MP_LIMB not + BITS_PER_LONGINT. + + * mpz/inp_raw.c, mpz/out_raw.c: Add private defines of BITS_PER_CHAR. + * mpz/fac_ui.c, tests/mpz/t-fac_ui.c: Don't use BITS_PER_LONGINT. + * tests/mpz/t-get_si.c: Don't use BITS_PER_LONGINT, do the LONG_MAX + tests with some explicit code. + + * mpn/*/gmp-mparam.h, acinclude.m4, tests/t-constants.c + (BITS_PER_LONGINT, BITS_PER_INT, BITS_PER_SHORTINT, BITS_PER_CHAR): + Remove defines, remove probings, remove tests. + + * tune/tuneup.c (MODEXACT_1_ODD_THRESHOLD): Add tuning. + + * tune/speed.c,speed.h,common.c: Add measuring of mpn_modexact_1_odd, + mpn_gcd_finda, and an "N" form for mpn_gcd_1. + + * tests/mpz/t-jac.c (check_squares_zi): Ensure random a,b != 0. + +2001-01-07 Kevin Ryde + + * configure.in (gmp_mpn_functions): Add mode1o, remove mod_1_rs. + + * mpn/generic/mod_1_rs.c: Remove file, no longer needed. + * gmp-h.in (mpn_mod_1_rshift): Remove prototype and define. + + * mpq/set_f.c: Use MPN_STRIP_LOW_ZEROS_NOT_ZERO. + + * mpz/kronzu.c, mpz/kronzs.c, mpz/kronuz.c, mpz/kronsz.c: Use + mpn_modexact_1_odd, new style MPN_STRIP_LOW_ZEROS_NOT_ZERO, and new + JACOBI macros. Various rearrangements supporting all this. + + * mpn/generic/gcd_1.c: Use mpn_modexact_1_odd, reduce u%v if u much + bigger than v when size==1, some rearrangements supporting this. + + * gmp-impl.h (JACOBI_*): More macros, add some casts to "int". + (MPN_STRIP_LOW_ZEROS_NOT_ZERO): Add a "low" parameter. + (mpn_modexact_1_odd, mpn_modexact_1c_odd): Add prototype and defines. + (MODEXACT_1_ODD_THRESHOLD): New threshold. + (MPN_MOD_OR_MODEXACT_1_ODD, JACOBI_MOD_OR_MODEXACT_1_ODD): New macros. + + * mpn/generic/mode1o.c: New file. + + * tests/mpz/reuse.c: Add testing of mpz_divexact_gcd. + * tests/mpz/t-fac_ui.c: Use libtests for memory leak checking. + * tests/mpz/t-fib_ui.c: Add a usage comment. + + * tests/mpz/bit.c: Use libtests. + * tests/mpz/t-scan.c: Remove unused subroutines. + * tests/devel/try.c: Use libtests, define PROT_NONE if the system + doesn't. + + * tests/spinner.c, tests/x86check.c: Use tests.h. + * tests/trace.c: Use tests.h, add mpf_trace. + * tests/refmpn.c: Use tests.h, add refmpn_malloc_limbs_aligned, + refmpn_tstbit, refmpn_neg. + + * tune/common.c, tune/speed.h: Update for functions moved to + tests/misc.c. + + * tune/Makefile.am, tests/mpz/Makefile.am, tests/mpq/Makefile.am, + tests/mpf/Makefile.am: Use tests/libtests.la. + + * configure.in (AC_OUTPUT): Update for new directories. + (x86 CALLING_CONVENTIONS_OBJS): Use .lo for libtests.la, allow + ansi2knr on x86check.c. + + * tests/Makefile.am: Establish new libtests.la convenience library, + add mpz, mpq, mpf, mpbsd subdirectories. + * tests/tests.h: New file. + * mpn/tests/ref.h,try.h: Remove files, now in tests.h. + + * tests/mpf/ref.c: Move to tests/refmpf.c, rename functions to refmpf. + * tests/mpf/t-add.c, tests/mpf/t-sub.c: Use libtests. + * tests/mpf/Makefile.am: Update. + + * tests/memory.c: New file. + * tests/misc.c: New file, a few subroutines from the test programs. + + * mpz/tests, mpq/tests, mpf/tests, mpbsd/tests: Move directories to + tests/mpz etc. + * mpz/Makefile.am, mpq/Makefile.am, mpf/Makefile.am, mpbsd/Makefile.am + (SUBDIRS): Remove. + + * tests/devel: New directory. + * mpn/tests/*.c: Move programs to tests/devel. + * mpn/tests/Makefile.am, mpn/tests/README: Move to tests/devel, update. + + * mpn/tests/ref.c: Move to tests/refmpn.c. + * mpn/tests/spinner.c,trace.c,x86call.asm,x86check.c: Move to tests + directory. + + * tests/t-constants.c: Add checks of HIGHBIT, MAX and MIN constants, + simplify ANSI vs K&R stringizing, use correct printf format types, do + all tests before aborting. + +2001-01-05 Torbjorn Granlund + + * mpn/cray/ieee/gmp-mparam.h: Retune. + +2001-01-05 Kevin Ryde + + * configure.in (mp.h): Only create this under --enable-mpbsd. + + * demos/calc: New subdirectory, move demos/calc* to it. + * demos/calc/Makefile.am: New file, split from demos/Makefile.am. + * demos/Makefile.am: Update. + * configure.in (AC_OUTPUT): Add demos/calc/Makefile. + + * tests/t-constants.c (CALC_BITS_PER_TYPE etc): Use a run-time test + for how many bits work in a give type, don't assume bits==8*sizeof. + +2001-01-04 Kevin Ryde + + * mpz/fits_s.c, mpz/fits_u.c: New files, split from fits.c, use plain + UINT_MAX etc, not MPZ_FITS_UTYPE_SDT etc. + * mpz/fits.c: Remove file. + * mpz/Makefile.am, macos/Makefile.in: Update. + + * gmp-impl.h (UNSIGNED_TYPE_MAX etc): Remove these generic forms. + (MPZ_FITS_[SU]TYPE_SDT): Remove these. + (UINT_MAX etc): Provide a full set of defaults. + * gmp-h.in (__GMP_MP_SIZE_T_INT): New define. + + * mpz/tests/t-scan.c: New file. + * mpz/tests/Makefile.am (check_PROGRAMS): Add it. + + * mpz/scan0.c, mpz/scan1.c: Rewrite, don't read beyond allocated + memory, support negatives, return ULONG_MAX for no bit found. + * gmp.texi (Integer Logic and Bit Fiddling): Update. + +2001-01-03 Torbjorn Granlund + + * mpz/tests/dive.c: Generate test operands using new random functions. + * mpz/tests/io.c: Likewise. + * mpz/tests/logic.c: Likewise. + * mpz/tests/t-2exp.c: Likewise. + + * stack-alloc.c (__gmp_tmp_alloc): Round `now' to required alignment. + + * stack-alloc.h (__TMP_ALIGN): Append `L'. + + * gmp-impl.h: For Cray, #include limits.h. + (LONG_MIN): New #define. + (ULONG_HIGHBIT): #define in terms of ULONG_MAX. + (LONG_HIGHBIT): #define as LONG_MIN. + (USHRT_MAX): New name for USHORT_MAX. + (SHRT_MAX): New name for SHORT_MAX. + (SHRT_MIN): New #define. + (USHORT_HIGHBIT,SHORT_HIGHBIT): Removed. + + * mpbsd/tests/t-misc.c (check_itom [data]): *SHORT* => *SHRT*; + remove code disabling a test for Cray. + + * tests/t-constants.c (CHECK_CONSTANT): Cast parameters to long. + + * mpn/generic/mul_n.c (mpn_kara_sqr_n): Remove unused variable `t'. + (mpn_kara_mul_n): Likewise. + + * mpz/fac_ui.c (MPZ_SET_1_NZ): Actually use `__z'. + + * mpz/tests/t-jac.c + (main, check_squares_zi): Generate test operands using new random + functions. + + All changes below on this date for enabling `make; make check' + with C++ compilers: + + * mpz/tests/t-pow_ui.c (debug_mp, ref_mpz_pow_ui): Provide prototypes. + + * mpz/tests/t-mul.c (debug_mp, base_mul, ref_mpz_mul): + Provide prototypes. + (dump_abort): Provide prototype and declare properly for C++. + + * mpz/tests/t-jac.c: #include stdlib.h and sys/time.h. + + * mpz/tests/t-fdiv.c + (dump_abort): Provide prototype and declare properly for C++. + (debug_mp): Provide prototype. + * mpz/tests/t-fdiv_ui.c: Likewise. + * mpz/tests/t-gcd.c: Likewise. + * mpz/tests/t-powm.c: Likewise. + * mpz/tests/t-powm_ui.c: Likewise. + * mpz/tests/t-sqrtrem.c: Likewise. + * mpz/tests/t-tdiv_ui.c: Likewise. + * mpz/tests/t-tdiv.c: Likewise. + + * mpz/tests/t-2exp.c: #include stdlib.h and sys/time.h. + Remove #include of longlong.h. + + * mpz/tests/io.c: #include config.h, stdlib.h, sys/time.h, and + conditionally unistd.h. + + * mpz/tests/dive.c: #include stdlib.h and sys/time.h. + (dump_abort): Provide prototype and declare properly for C++. + (debug_mp): Provide prototype. + * mpz/tests/logic.c: Likewise. + + * mpz/tests/convert.c (debug_mp): Provide prototype. + * mpz/tests/t-root.c (debug_mp): Likewise. + + * mpz/tests/bit.c: #include stdlib.h and sys/time.h. + + * mpq/tests/t-get_d.c: #include stdlib.h and sys/time.h. + (dump): Provide prototype and declare properly for C++. + + * mpq/tests/t-cmp_ui.c: #include stdio.h, stdlib.h and sys/time.h. + (ref_mpq_cmp_ui): Declare properly for C++. + + * mpq/tests/t-cmp.c: #include stdlib.h and sys/time.h. + (ref_mpq_cmp): Declare properly for C++. + (dump): Delete unused function. + + * mpf/random2.c (myrandom): New function. + (mpf_random2): Use it. + + * mpn/generic/random2.c: #include stdlib.h (for random/mrand48). + (myrandom): New function. + (mpn_random2): Use it. + + * mpf/tests/t-add.c: #include stdlib.h and sys/time.h. + (oo): Remove unused function. + * mpf/tests/t-conv.c: Likewise. + * mpf/tests/t-sub.c: Likewise. + * mpf/tests/t-dm2exp.c: Likewise. + * mpf/tests/t-muldiv.c: Likewise. + * mpf/tests/t-sqrt.c: Likewise. + + * mpf/tests/reuse.c: #include stdlib.h and sys/time.h. + Use PROTO on some typedefs. + (oo): Remove function. + (dump_abort): Call mpf_dump instead of oo. + + * mpf/set_str.c: #include stdlib.h (for strtol). + + * mpf/random2.c: #include stdlib.h (for random/mrand48). + * mpn/alpha/udiv_arnnd: File deleted. + + * Remove K&R function headers. + +2001-01-02 Torbjorn Granlund + + * mpn/generic/mul.c: Clean up spacing and indentation. + + * mpn/generic/mul_fft.c (mpn_fft_add_modF): Use mpn_decr_u. + Clean up spacing and indentation. + + * extract-dbl.c: Generalize to handle smaller limb sizes. + +2001-01-01 Torbjorn Granlund + + * mpbsd/mout.c: Output newline after "0". + +2000-12-31 Torbjorn Granlund + + * ltmain.sh: Remove space between `#!' and `$SHELL' when generating + `libtool'. + + * mpbsd/tests/t-misc.c (check_itom): Exclude test for all Cray + vector systems. Correct comment. + +2000-12-31 Kevin Ryde + + * gmp.texi (ABI and ISA): New enough gcc needed for mips n32 etc, gcc + 2.95 needed for sparc 64-bit ABI, gcc 2.8 needed for -mv8plus. + + * configure.in ([cjt]90,sv1-cray-unicos*): Preserve user specified + MPN_PATH, amend test program indenting. + (none-*-*): Add -DNO_ASM to gcc to disable longlong.h asm macros in + generic C. + + * config.sub (j90, t90): Preserve these, don't let configfsf.sub turn + them into c90. + + * config.guess (m68k-*-nextstep*,m68k-*-openstep*): Don't transform + m68k to m68020, since m68k is already interpreted as 68020. + +2000-12-30 Kevin Ryde + + * mpq/neg.c: Rewrite, use mpn, avoid denominator copy if unnecessary. + + * mpz/tstbit.c: Rewrite, slightly simplified. + * mpz/tests/bit.c (check_tstbit): New test, and add a couple more + diagnostics elsewhere. + + * configure.in (x86 gcc_cflags_cpu): Add -m486 for gcc 2.7.2. + (ccbase): Only use a known compiler in eval statements (avoids + problems with non-symbol characters). + (ccbase): Use GMP_PROG_CC_IS_GNU to identify gcc installed under a + different name. + (cclist): Use same style $abi as other variables. + + * acinclude.m4 (GMP_PROG_CC_IS_GNU): New macro. + (GMP_GCC_MARCH_PENTIUMPRO): Use $ccbase to identify gcc. + (GMP_ASM_TYPE): Define TYPE to empty, not "dnl", when no .type needed. + (GMP_ASM_SIZE): Ditto for SIZE, which ensures EPILOGUE on the last + line of a file doesn't leave a tab and no newline. + (GMP_ASM_UNDERSCORE): Add a prototype for C++. + + * configure.in (sys/mman.h, mprotect): New tests. + * mpn/tests/try.c: Use them, and HAVE_UNISTD_H too. + + * configure.in (getopt.h): Remove test. + * tune/speed.c, mpn/tests/try.c (getopt.h): Remove include, since + plain getopt() is in . + + * configure.in, gmp-h.in (mips*-*-irix6*): Set limb_n32=longlong + rather than using _ABIN32. + +2000-12-29 Torbjorn Granlund + + * mpz/tests/reuse.c: Rename dump_abort => dump. + * mpz/tests/reuse.c: Generate operands using gmp_rand*. + * mpz/tests/convert.c: Likewise. + + * configure.in: Detect T90-ieee systems; move Cray path + selection to after AC_PROG_CC. Invoke AC_PROG_CPP. + * mpn/cray/cfp: New directory. Move cfp specific files here. + * mpn/cray/cfp/mulwwc90.s: New file. + * mpn/cray/cfp/mulwwj90.s: New file. + * mpn/cray/mulww.s: Delete. + +2000-12-27 Torbjorn Granlund + + * mpn/cray/ieee/mul_1.c: New file. + * mpn/cray/ieee/addmul_1.c: New file. + * mpn/cray/ieee/submul_1.c: New file. + * mpn/cray/ieee/gmp-mparam.h: New file. + + * mpn/cray/gmp-mparam.h: Disable UMUL_TIME and UDIV_TIME. + + * mpn/cray/hamdist.c: New file. + * mpn/cray/popcount.c: New file. + * mpn/cray/rshift.c: New file. + * mpn/cray/lshift.c: New file. + + * longlong.h: Add count_leading_zeros for _CRAY. + Reorganize _CRAY stuff. + +2000-12-24 Kevin Ryde + + * configure.in (alpha*-cray-unicos*): Disable SPEED_CYCLECOUNTER_OBJ, + as tune/alpha.asm doesn't suit. + + * mpn/generic/sqrtrem.c, mpz/pow_ui.c, mpz/powm_ui.c, mpf/get_str.c, + mpf/set_str.c: Use mpn_sqr_n when applicable, not mpn_mul_n. + +2000-12-23 Torbjorn Granlund + + * mpn/generic/mul_fft.c: Reformat. + (mpn_fft_neg_modF): Remove. + (mpn_fft_mul_2exp_modF): Inline mpn_fft_neg_modF. + + * mpn/cray/gmp-mparam.h: Retune. + + * configure.in (*-cray-unicos*): Pass `-O3 -htask0'. + (vax*-*-*): Fix typo. + + * mpn/cray/mul_1.c: Use dynamic arrays, get rid of TMP_*. + * mpn/cray/addmul_1.c: Likewise. + * mpn/cray/submul_1.c: Likewise. + * mpn/cray/add_n.c: Likewise. + * mpn/cray/sub_n.c: Likewise. + + * configure.in (default cc_cflags,cc_64_cflags): Remove -g/add -O. + (mips*-*-irix[6789]*]): Remove -g from cc_*_cflags. + +2000-12-22 Torbjorn Granlund + + * mpn/generic/mul_n.c: Delete K&R function headers. + + * mpn/generic/mul_n.c (mpn_kara_mul_n): Clean up type confusion + between mp_limb_t and mp_size_t. + (mpn_kara_sqr_n): Likewise. + + * mpn/generic/mul_n.c (mpn_kara_mul_n): Use mpn_incr_u. + (mpn_kara_sqr_n): Likewise. + + * mpn/generic/mul_n.c (mpn_kara_mul_n): Change handling of `sign' + to work around GCC 2.8.1 MIPS bug. + + * configure.in (implied alpha*-cray-unicos*): Remove -g from cc_cflags. + +2000-12-21 Torbjorn Granlund + + * mpn/alpha/invert_limb.asm: Simplify a bit. + Add handling of bigend systems. + * mpn/alpha/unicos.m4: Define `bigend'. + * mpn/alpha/default.m4: Define `bigend' (to expand to nothing). + + * tests/t-constants.c (CHECK_CONSTANT): Print using %lx. + + * mpn/alpha/gmp-mparam.h: Remove sizes for plain C types. + * mpn/alpha/ev5/gmp-mparam.h: Likewise. + * mpn/alpha/ev6/gmp-mparam.h: Likewise. + + * mpn/alpha/unicos.m4: Define LEA. + * mpn/alpha/default.m4: Likewise. + * mpn/alpha/invert_limb.asm: Use LEA for loading symbolic addresses. + * mpn/alpha/cntlz.asm: Likewise. + + * mpn/alpha/cntlz.asm: Don't use `ldbu', use slightly slower + `ldq_u' + `extbl' instead. + + * mpn/alpha/unicos.m4: Define EXTERN. + * mpn/alpha/default.m4: Define EXTERN (to expand to nothing). + * mpn/alpha/cntlz.asm: Declare __clz_tab usign `EXTERN' (for the + benefit of Unicos). + +2000-12-21 Kevin Ryde + + * mpn/alpha/unicos.m4 (GSYM_PREFIX): Define for the benefit of + __clz_tab. + +2000-12-20 Torbjorn Granlund + + * longlong.h: Add udiv_qrnnd and count_leading_zeros for _CRAYMPP + systems. + +2000-12-19 Torbjorn Granlund + + * configure.in (*sparc*-*-*): Remove -g from cc_cflags and acc_cflags. + + * mpn/generic/sqrtrem.c (mpn_sqrtrem): Separate `limb' values from + `size' values. + + * configure.in (*-cray-unicos*): Add `-Wa,-B' to cc_cflags. + + * demos/pexpr.c (rstate): New variable. + (main): Initialize rstate. + (enum op_t): Add RANDOM. + (fns): Add field for RANDOM. + (mpz_eval_expr): Handle RANDOM. + +2000-12-19 Kevin Ryde + + * mpn/generic/sqrtrem.c: Rewrite by Paul Zimmermann, based on his + Karatsuba Square Root algorithm. + * gmp.texi (Square Root Algorithm): Update. + + * tune/many.pl: New file. + + * mpn/tests/try.c,ref.[ch] (mpn_preinv_mod_1, mpn_sb_divrem_mn, + mpn_tdiv_qr, mpn_gcd_finda, mpn_kara_mul_n, mpn_kara_sqr_n, + mpn_toom3_mul_n, mpn_toom3_sqr_n): Add testing. + * mpn/tests/ref.c: Cast some "0"s in function calls. + + * mpn/x86/k7/mmx/mod_1.asm: Add preinv_mod_1 entrypoint, remove extra + variable for loop termination. + + * mpn/x86/p6/mmx/mod_1.asm: Remove file, in favour of the following. + * mpn/x86/p6/mod_1.asm: New file. + + * mpn/x86/pentium/mod_1.asm: New file. + +2000-12-18 Torbjorn Granlund + + * configure.in (mips*-*-irix[6789]*): Pass options to compiler using + `-Wc'. + +2000-12-18 Kevin Ryde + + * mpn/x86/k6/pre_mod_1.asm: New file. + + * tune/tuneup.c (USE_PREINV_MOD_1): Tune this, rearrange mpn_divrem_1 + and mpn_mod_1 handling in support of it. + * tune/Makefile.am: Consequent changes to divrem_1.c and mod_1.c. + + * gmp-impl.h (USE_PREINV_MOD_1, MPN_MOD_OR_PREINV_MOD_1): New macros. + * mpn/generic/perfsqr.c, mpz/pprime_p.c: Use MPN_MOD_OR_PREINV_MOD_1. + + * configure.in: Let an asm mod_1 provide a preinv_mod_1 entrypoint. + + * mpn/alpha/default.m4: Remove some newlines, add some asserts. + (r0 etc, f0 etc): Use defreg and deflit. + (PROLOGUE, PROLOGUE_GP, EPILOGUE): Use GSYM_PREFIX. + * mpn/alpha/unicos.m4: Remove some newlines, add some asserts. + * mpn/alpha/invert_limb.asm: Remove unused second DATASTART parameter. + * mpn/alpha/cntlz.asm: Use mpn_count_leading_zeros and __clz_tab. + + * mpn/asm-defs.m4 (changecom): Comments on portability. + (__clz_tab, modlimb_invert_table): New macros, matching gmp-impl.h. + (count_leading_zeros, count_trailing_zeros): New define_mpn's. + (PROLOGUE etc): Comments on usage, add some asserts. + (OPERATION_[lr]shift): Use m4_not_for_expansion, for the benefit of + lorrshift multifunc. + + * mpn/Makeasm.am (RM_TMP): New variable controlling tmp-*.s + removal, for development purposes. + + * mpz/fac_ui.c: Fix for long long limb by using mpn_mul_1 not + mpz_mul_ui, and note some possible enhancements. + + * mpz/tests/t-fac_ui.c: New test. + * mpz/tests/Makefile.am (check_PROGRAMS): Add it. + * macos/Makefile.in: Ditto, and add t-fib_ui too. + + * mpn/generic/[lr]shift.c: Remove some DEBUG code adequately covered + by new parameter ASSERTs. + + * longlong.h (count_trailing_zeros): Assert x!=0. + + * doc/configuration: Updates for new configure things, add some notes + on test setups. + +2000-12-16 Torbjorn Granlund + + * configure.in (*-*-aix): Pass -qmaxmem=20000 to xlc also for 64-bit + compiles. + * configure.in: Disable shared libs for *-*-ultrix*. + +2000-12-15 Torbjorn Granlund + + * configure.in (powerpc*-*-*): Pass -Wa,-mppc when using gcc. + + * gmp-impl.h (_EXTERN_INLINE): #define different for GCC and other + compilers. + + * gmp-h.in (__gmp_inline): Remove. + * mp-h.in: Likewise. + * mpn/generic/gcd.c: Use `inline' instead of `__gmp_inline'. + + * configure.in (mips*-*-irix[6789]*): Define *_ldflags. + +2000-12-14 Torbjorn Granlund + + * mpn/generic/pre_mod_1.c: Use proper type for udiv_qrnnd + parameter `dummy'. + + * mpn/generic/divrem_1.c: Use explicit `!= 0' in if statement. + * mpn/generic/mod_1.c: Likewise. + +2000-12-14 Kevin Ryde + + * config.guess (mips-*-irix[6789]*): Transform to mips64. + (m68k-*-nextstep* | m68k-*-openstep*): Transform to m68020. + +2000-12-13 Torbjorn Granlund + + * tests/t-constants.c (main): Conditionalize use of PP_INVERTED. + + * mpn/mp_bases.c: Handle 4-bit limbs. + (main): Add code for generating tables. + + * mpn/generic/popham.c: Handle limb bitsizes of 4, 8, 16. + Suffix all 32-bit constant with `L'. + Use CNST_LIMB for 64-bit constants. + +2000-12-13 Kevin Ryde + + * gmp-impl.h (FIB_THRESHOLD): Defaults for 4,8,16 bits per limb, and + an arbitrary fallback default. + (modlimb_invert): Add efficient code for 8,16 (or 4) bits per limb. + + * configure.in (mips3, mips64): Don't bother with o32 (mips2 32-bit + limb) on IRIX 6. + + * Makefile.am (SUBDIRS): Put "tests" first so tests/t-constants.c is + run first, to pick up any limb size mismatch. + + * tune/tuneup.c (DIVREM_1, MOD_1): Fix result values, were off by 1. + + * mpz/fib_ui.c (table1, table2): Add data for 4,8,16 bits per limb. + +2000-12-12 Torbjorn Granlund + + * gmp-impl.h (LIMBS_PER_DOUBLE): Define for any limb bitsize. + +2000-12-11 Torbjorn Granlund + + * mpn/mp_bases.c: Add tables for 8-bit and 16-bit limbs. + Round existing `double' values properly. + + * gmp-h.in (__gmp_randstate_struct): Prefix field names with _mp_ + to keep out of user name space. + (__gmp_randata_lc): Likewise. + * randclr.c, randlc.c, randlc2x.c, randraw.c, randsd.c, randsdui.c: + Corresponding changes. + + * gmp-impl.h (PP): #define for machines with BITS_PER_MP_LIMB + of 2, 4, 8, and 16. + (PP_FIRST_OMITTED): New, define for various BITS_PER_MP_LIMB. + (PP_MASK): Remove. + (PP_MAXPRIME): Remove. + + * mpn/generic/perfsqr.c: Generalize PP handling for machines with + limbs of < 32 bits. Allow PP_INVERTED to be undefined. + * mpz/pprime_p.c: Likewise. + +2000-12-10 Torbjorn Granlund + + * mpn/generic/mul_1.c: Declare parameters in C89 style. + +2000-12-10 Kevin Ryde + + * tune/Makefile.am (speed_LDFLAGS, speed_ext_LDFLAGS, tune_LDFLAGS): + Don't use -all-static, as gcc 2.95.2 on i386 solaris 8 doesn't like + it. + + * configure.in (mips3,mips64): Add ABI=64, name the others ABI=n32 and + ABI=o32. + * mpn/mips3/gmp-mparam.h (BITS_PER_LONGINT): Remove #define and let + configure determine it, since it varies with ABI=64 or ABI=n32. + * gmp.texi (ABI and ISA): Update. + (mpz_mod_ui): Remark that it's identical to mpz_fdiv_r_ui. + (mpn_divexact_by3): Qualify a statement needing mp_bits_per_limb even. + + * mul_fft.c (mpn_fft_mul_modF_K etc): Patch by Paul Zimmermann to fix + results in certain cases of recursing into a further FFT. + +2000-12-09 Torbjorn Granlund + + * mpz/cmpabs.c: Remove unused variable. + * mpz/rrandomb.c: Likewise. + * mpz/xor.c: Likewise. + +2000-12-07 Torbjorn Granlund + + * mpn/generic/gcdext.c: Handle double carry when computing s1. + Merge two code blocks for computing s0 and s1. + +2000-12-07 Kevin Ryde + + * configure.in (hppa*-*-*): Remove -Aa -D_HPUX_SOURCE from + cc_cflags/cppflags, and instead let AM_C_PROTOTYPES add it, or -Ae, + whichever works. + + * configure.in (*-*-aix[34]*): Disable shared by default, but let + the user override that, if desired. + * gmp.texi (Notes for Particular Systems): Update. + +2000-12-06 Torbjorn Granlund + + * mpq/cmp_ui.c: Streamline. + +2000-12-06 Kevin Ryde + + * tune/divrem_1_div.c,divrem_1_inv.c,mod_1_div.c,mod_1_inv.c, + gcdext_double.c: New files for measuring. + * tune/Makefile.am (libspeed_la_SOURCES): Add them. + * tune/speed.c,speed.h,common.c: Add measuring of them. + (mpn_preinv_mod_1, mpz_jacobi, mpz_powm_ui): Add measuring. + + * speed.c (getopt_long): Don't use this, just plain getopt. + * configure.in (getopt_long): Remove test. + + * gmp-impl.h (MPN_KARA_MUL_N_TSIZE, MPN_KARA_MUL_N_MINSIZE, + MPN_TOOM3_MUL_N_TSIZE, MPN_TOOM3_MUL_N_MINSIZE): New macros, and + assume toom3 square tsize was meant to be the same as the mul (both + are overestimates). + * tune/tuneup.c, mpn/generic/mul.c, mpn/generic/mul_n.c: Use them. + * mpn/generic/mul_n.c (mpn_toom3_sqr_n): Fix an ASSERT to use + TOOM3_SQR_THRESHOLD not TOOM3_MUL_THRESHOLD, add a few that might + be more realistic size checks. + * tune/speed.h (SPEED_ROUTINE_MPN_MUL_N_TSPACE etc): Use minsize. + + * mpn/generic/divrem_1.c: Partial rewrite, merge fractional part + calculation, skip a divide step in more cases, introduce + DIVREM_1_NORM_THRESHOLD and DIVREM_1_UNNORM_THRESHOLD. + * mpn/generic/mod_1.c: Partial rewrite, skip a divide step in more + cases, introduce MOD_1_NORM_THRESHOLD, MOD_1_UNNORM_THRESHOLD. + * longlong.h (UDIV_PREINV_ALWAYS): New define, set for alpha and ia64. + * tune/tuneup.c (DIVREM_1_NORM_THRESHOLD, DIVREM_1_UNNORM_THRESHOLD, + MOD_1_NORM_THRESHOLD, MOD_1_UNNORM_THRESHOLD): Tune these. + * gmp-impl.h [TUNE_PROGRAM_BUILD]: Support for this. + * tune/Makefile.am (TUNE_MPN_SRCS): Add divrem_1.c and mod_1.c. + + * gmp-impl.h (UDIV_NORM_PREINV_TIME): Renamed from UDIV_PREINV_TIME. + * mpn/generic/perfsqr.c, mpn/generic/sb_divrem_mn.c, + mpn/x86/*/gmp-mparam.h: Ditto. + * gmp-impl.h (UDIV_UNNORM_PREINV_TIME): New define. + + * configure.in (AC_C_INLINE, HAVE_INLINE): New test and define. + * gmp-impl.h (inline): Remove, use config.h. + (_EXTERN_INLINE): Redefine based on HAVE_INLINE. + (mpn_zero_p): Use HAVE_INLINE. + + * acinclude.m4 (GMP_PROG_AR, GMP_PROG_NM): Don't add flags to a user + selected $AR or $NM. + + * tune/tuneup.c (all): Print how long the tuning took. + + * configure.in (AM_C_PROTOTYPES): Use this, not GMP_ANSI2KNR. + * acinclude.m4 (GMP_ANSI2KNR): Remove. + + * Makefile.am (gmp.h, mp.h): In DISTCLEANFILES not CLEANFILES. + + * gmp-h.in (mpn_divmod, mpn_divmod_1, mpn_divexact_by3): Cast some + zeros, for the benefit of K&R if long!=int. + + * mpn/lisp/gmpasm-mode.el (gmpasm-comment-start-regexp): Add "*" for + the benefit of cray. + + * compat.c (mpn_divexact_by3, mpn_divmod_1): Return types should be + mp_limb_t, not int, and need an actual "return". + +2000-12-05 Torbjorn Granlund + + * mpn/sparc32/v8/supersparc/gmp-mparam.h: Retune. + * mpn/alpha/gmp-mparam.h: Tune for 21064. + + * longlong.h: Reformat to avoid newlines within strings. + + * gmp-impl.h (inline): Disable if GCC has defined __STRICT_ANSI__. + + * configure.in: Do a `mkdir tune' before creating tune/sqr_basecase.c. + + * Makefile.am: Treat mp.h analogously to gmp.h. + + configure.in (*-*-aix): Pass -qmaxmem=20000 to xlc. + + * mp-h.in: Renamed from mp.h. + Add #define for _LONG_LONG_LIMB. + Move some other fixes from gmp-h.in. + * mp.h: Removed. + * configure.in: Generate mp.h from mp-h.in like we handle + gmp-h.in/gmp.h. + +2000-12-04 Torbjorn Granlund + + * acinclude.m4: Fix typo testing for bad HP compiler. + +2000-12-03 Torbjorn Granlund + + * mpbsd/tests/t-misc.c (check_itom): Exclude some tests for Cray + CFP systems. + + * longlong.h (CRAYIEEE umul_ppmm): New. + + * mpn/cray/gmp-mparam.h (BITS_PER_SHORTINT): 32 => 64. + (*_THRESHOLD): Tune. + + * configure.in: Disable shared libs for *-*-unicos*. + +2000-12-03 Kevin Ryde + + * configure.in, tune/Makefile.am: Create tune/sqr_basecase.c during + configure, and use it unconditionally in $(nodist_tuneup_SOURCES). + Fixes a problem with sqr_basecase.lo under --disable-static. + +2000-12-01 Torbjorn Granlund + + * mpf/tests/t-get_d.c (LOW_BOUND,HIGH_BOUND): #define for non-IEEE + Cray systems. + + * gmp-impl.h (union ieee_double_extract): Test for _CRAYIEEE. + +2000-11-30 Torbjorn Granlund + + * mpz/tests/t-mul.c (base_mul): Fix re-evaluation problems in macro + invocations. + (ref_mpz_mul): New name from mpz_refmul. Make static. + (base_mul): New name for _mpn_mul_classic. + +2000-11-30 Kevin Ryde + + * configure.in: Rewrite of CC/CFLAGS selection scheme, introduce a + notion of ABI, merge compiler and mpn path selection, add flags + selection for AR and NM, let CC without CFLAGS work. + (AC_PROG_CC): Use this, not GMP_SELECT_CC. + * acinclude.m4 (GMP_PROG_CC_WORKS): Don't use AC_TRY_COMPILE, combine + cc/cflags parameter. + (GMP_PROG_CC_FIND, GMP_CHECK_CC_64BIT, GMP_PROG_CC_SELECT): Remove. + * gmp.texi (Installing GMP): Updates for new scheme. + + * configure.in (AC_CANONICAL_HOST): Use this and $host, not $target. + * acinclude.m4, acconfig.h, longlong.h, mpn/x86/x86-defs.m4, + mpn/x86/k7/mmx/popham.asm: Ditto, renaming HAVE_TARGET_CPU to + HAVE_HOST_CPU. + * gmp.texi (Build Options, and elsewhere): Update. + + * acinclude.m4 (GMP_COMPARE_GE): New macro. + (GMP_GCC_MARCH_PENTIUMPRO): Use it, add CC parameter, check for GCC. + (GMP_HPC_HPPA_2_0): New macro, adapted from GMP_CHECK_CC_64BIT. + + * acinclude.m4 (GMP_PROG_AR): New macro, using AC_CHECK_TOOL, adding + GMP flags. + * configure.in: Use it + + * gmp-h.in: Renamed from gmp.h. + (@define_LONG_LONG_LIMB@): Placeholder for instantiation. + (__GNU_MP__): Bump to 3. + * acinclude.m4 (GMP_VERSION): Get version from gmp-h.in. + * configure.in: Create gmp.h from gmp-h.in to set _LONG_LONG_LIMB. + * gmp.texi.h (ABI and ISA): Mention this. + * acconfig.h (_LONG_LONG_LIMB): Remove undef. + * Makefile.am: Distribute gmp-h.in, not gmp.h. + + * configure.in (AC_PROG_CPP, AC_PROG_INSTALL, AC_PROG_LN_S): Remove, + dragged in by other macros. + (gmp_asm_syntax_testing): Renamed from gmp_no_asm_syntax_testing. + (AC_EXEEXT, AC_OBJEXT): Remove, done automatically by libtool. + * configure.in, acinclude.m4: Remove "" from "`foo`", being + unnecessary and not portable. + + * configure.in (GMP_LDFLAGS): New AC_SUBST flags for libtool link. + (powerpc64*-*-aix*): Use for -Wc,-maix to fix shared library creation, + but can't build shared and static at the same time. + * Makefile.am (libgmp_la_LDFLAGS, libmp_la_LDFLAGS): Use + $(GMP_LDFLAGS). + * gmp.texi (Notes for Particular Systems): Update AIX problem + + * configure.in (AC_CONFIG_LINKS): Use where needed, not via gmp_links. + (gmp_srclinks): Build up as needed, not via gmp_links. + + * acinclude.m4 (GMP_INIT): Do CONFIG_TOP_SRCDIR and asm-defs.m4 here. + * configure.in (asm-defs.m4): Consequent changes. + + * acinclude.m4 (GMP_INCLUDE_MPN): Using include_mpn(), replacing + GMP_INCLUDE and GMP_SINCLUDE. + * configure.in (gmp_m4postinc): Remove this scheme, use + GMP_INCLUDE_MPN instead. + + * configure.in (*-*-sco3.2v5*): Force ac_cv_archive_cmds_need_lc=no, + until libtool does this itself. + * gmp.texi (Known Build Problems): Remove SCO -lc problem. + + * configure, INSTALL.autoconf, etc: Update to autoconf 2000-11-29. + * acinclude.m4 (GMP_C_SIZES): Use AC_CHECK_SIZEOF. + * gmp.texi (Known Build Problems): Remove version.c sed/config.h + problem, fixed. + + * ltmain.sh, aclocal.m4: Update to libtool 2000-11-25. + * ltconfig: No longer required, but leave an empty dummy for automake. + * gmp.texi (Known Build Problems): Remove SunOS native ar ranlib + problem, fixed. + + * */Makefile.in, aclocal.m4: Update to automake 2000-11-25. + * mpbsd/tests/Makefile.am, mpfr/tests/Makefile.am (check_PROGRAMS): + Remove dummy, no longer required. + * mpbsd/tests/dummy.c, mpfr/tests/dummy.c: Remove files. + * depcomp: Remove file, no longer required (with no-dependencies). + + * texinfo.tex: Update to 2000-11-09. + * gmp.texi (Build Options): Mention PDF from gmp.texi. + * Makefile.am (MOSTLYCLEANFILES): Add gmp.tmp, from new texinfo.tex. + + * gmp.texi (Build Options): List alphaev56, alphapca56, alphaev67, + hppa2.0n and power among supported CPUs. + +2000-11-30 Torbjorn Granlund + + * mpz/tests/t-mul.c: Increase max operand size from 2^17 bits + to 2^19 bits. Misc cleanups. + +2000-11-26 Kevin Ryde + + * tune/tuneup.c (FIB_THRESHOLD): Cope better with different speeds of + odd and even sizes. + + * longlong.h (alpha): Use udiv_qrnnd and count_leading_zeros on all + compilers, not just gcc. + + * pre_mod_1.c: Use conditional subtract to always skip a division. + (UMUL_TIME, UDIV_TIME): Remove defaults, now in longlong.h. + +2000-11-22 Torbjorn Granlund + + * mpn/pa64w/gmp-mparam.h: Retune. + * mpn/pa64/gmp-mparam.h: Retune. + * mpn/sparc64/gmp-mparam.h: Retune. + +2000-11-22 Kevin Ryde + + * gmp-impl.h (ABOVE_THRESHOLD, BELOW_THRESHOLD): New macros. + * mpn/generic/gcdext.c: Use them. + + * mpn/generic/gcdext.c [WANT_GCDEXT_ONE_STEP]: Force only one step. + * tune/gcdextos.c, tune/gcdextod.c: New files, one step gcdext, single + and double. + * tune/Makefile.am (libspeed_la_SOURCES): Add them. + (TUNE_MPN_SRCS): Remove gcdext.c. + * tune/speed.h, tune/common.c, tune/speed.c: Add measuring. + * tune/tuneup.c: Use for GCDEXT_THRESHOLD, plus check if double limb + is ever better. Should be more accurate, and hopefully faster. + + * tune/gcdext_single.c: New file, gcdext forced to single limbs. + * tune/Makefile.am: Add it. + * tune/speed.h, tune/common.c, tune/speed.c: Add measuring, and of + invert_limb. + + * tune/speed.h (speed_params r): Use mp_limb_t, not long. + * tune/speed.h, tune/common.c: Don't "switch" on "r". + * tune/speed.c (r_string): Accept limb sized constants. + (choice scale): Add a scale factor (eg. "2.33*mpn_add_n"). + * tune/common.c (SPEED_ROUTINE_UDIV_QRNND_A): Default r to + __mp_bases[10].big_base, being a full limb value. + + * configure.in (alphapca56*-*-*): Use ev5 mpn path. + (am29000*-*-*): Remove this, leave the canonical a29k. + (z8k*-*-*, z8kx*-*-*): Changed from z8000, since z8k is canonical. + (gmp_mpn_functions_optional): Add invert_limb, use for alpha and ia64. + + * configure.in (alloca): Accept yes/no/detect, generate an error if + "yes" but not available. + * gmp.texi (Build Options): Update. + + * acinclude.m4 (GMP_TRY_ASSEMBLE): Make conftest.out available. + (GMP_ASM_ALIGN_FILL_0x90): Use it. + + * acinclude.m4 (GMP_ASM_X86_MMX) [*-*-solaris*]: Check for solaris + 2.6 "as" movq bug. + * gmp.texi (Notes for Particular Systems): Update x86 MMX note. + +2000-11-21 Torbjorn Granlund + + * tune/Makefile.am (EXTRA_DIST): List hppa2w.asm. + + * tune/hppa2.asm: Change level directive to "2.0n". + * tune/hppa2w.asm: New file. + * configure.in [SPEED_CYCLECOUNTER_OBJS switch]: Separate out hppa2.0w. + + * mpn/pa64/gmp-mparam.h (BITS_PER_LONGINT): 64 => 32. + +2000-11-21 Kevin Ryde + + * urandom.h (random): No prototype if glibc stdlib.h has already + provided it (avoids an int32_t/long conflict). + + * tune/Makefile.am (LDFLAGS): Use -all-static. + (speed-dynamic): Dynamic linked version of speed.c. + * tune/README: Update. + + * mpn/generic/gcd.c (find_a): Use native version if available. + * acconfig.h (HAVE_NATIVE_mpn_gcd_finda): Add #undef. + * gmp-impl.h (mpn_gcd_finda): Add prototype and define. + * mpn/asm-defs.m4 (mpn_gcd_finda): New define_mpn. + * tune/gcd_finda_gen.c: #undef any HAVE_NATIVE_mpn_gcd_finda. + * configure.in (gmp_mpn_functions_optional): Add gcd_finda. + * mpn/x86/k6/gcd_finda.asm: New file. + + * tune/tuneup.c (POWM_THRESHOLD): Slightly bigger size steps. + + * gmp-impl.h (__GMP_IMPL_H__): Protect against multiple inclusion. + * tune/gcd_bin.c, tune/powm_mod.c, tune/powm_redc.c: Use #undef after + gmp-impl.h to force thresholds. + * tune/tuneup.c (print_define, fft): No need for #ifndefs on + thresholds any more. + +2000-11-20 Torbjorn Granlund + + * mpz/tests/t-powm.c: Analogous changes as made 2000-11-12 to t-mul.c. + * mpz/tests/t-powm_ui.c: Likewise. + * mpz/tests/t-pow_ui.c: Likewise. + * mpz/tests/t-root.c: Likewise. + + * configure.in [compiler switch]: Pass "-Aa -D_HPUX_SOURCE" to cc for + all hppa versions. + + * mpn/hppa/hppa1_1/udiv_qrnnd.S: Reference data using PC relative + addressing (was r19 relative addressing). + +2000-11-18 Torbjorn Granlund + + * rand.c: (__gmp_rand_lc_scheme): Convert strings to hexadecimal. + (gmp_randinit): Expect strings in hexadecimal. + +2000-11-18 Kevin Ryde + + * configfsf.guess, configfsf.sub: Update to 2000-11-16. + * config.guess (alpha*-*-openbsd*): Do exact cpu detection. + +2000-11-14 Torbjorn Granlund + + * mpz/tests/t-fdiv.c: Analogous changes as made 2000-11-12 to t-mul.c. + * mpz/tests/t-tdiv_ui.c: Likewise. + * mpz/tests/t-fdiv_ui.c: Likewise. + * mpz/tests/t-sqrtrem.c: Likewise. + * mpz/tests/t-gcd.c: Likewise. + +2000-11-13 Kevin Ryde + + * mpn/Makeasm.am: New file, splitting out assembler rules. + * mpn/Makefile.am, tune/Makefile.am: Use it. + + * mpn/Makefile.am (@CPP@): Remove this, automake already gives it. + + * configure.in (AC_CHECK_LIBM): New test, and AC_SUBST it. + * Makefile.am (MPFR_LIBADD_OPTION): Use it. + * demos/Makefile.am (qcn_LDADD): Ditto. + * tune/Makefile.am (libspeed_la_LIBADD): Ditto. + * tests/rand/Makefile.am (libstat_la_LIBADD): Ditto. + + * tune/time.c (timeval_diff_secs): Better calculation. + (read_real_time): New measuring method for AIX power/powerpc. + (speed_endtime): Protect against negative times. + * tune/common.c (speed_measure): Protect against big reps. + * tune/freq.c (speed_cpu_frequency_measure_one): Better timeval diff. + * tune/speed.h (TIMEVAL_DIFF_SEC,USEC): Remove macros. + * configure.in: (sys/systemcfg.h, read_real_time): New tests. + +2000-11-13 Torbjorn Granlund + + * mpz/tests/t-mul.c: Remove #include urandom.h. + * mpz/tests/t-tdiv.c: Likewise. + + * configure.in [SPEED_CYCLECOUNTER_OBJS switch]: + Declare hppa.asm as just 32 bits (cyclecounter_size=1). + +2000-11-12 Torbjorn Granlund + + * mpz/tests/t-mul.c + (main): Generate random numbers using gmp_rand* functions. + (main): Distribute random numbers non-uniformly. + (main): Seed by current time if GMP_CHECK_RANDOMIZE is set. + (_mpn_mul_classic): Streamline. + * mpz/tests/t-tdiv.c: Analogous changes. + + * demos/pexpr.c (HAVE_sigaltstack): Fix typo in testing for _UNICOS. + Also test for __hpux. + +2000-11-11 Torbjorn Granlund + + * mpn/alpha/ev5/gmp-mparam.h: Retune. + + * mpn/alpha/ev6/gmp-mparam.h: Retune. + + * mpn/alpha/ev6/add_n.asm: Misc cleanups. + + * mpn/alpha/ev6/sub_n.asm: New file. + +2000-11-10 Torbjorn Granlund + + * configure.in [path switch] (alphaev6*-*-*): Add alpha/ev5 to path. + + * mpn/alpha/ev6/add_n.asm: New file. + +2000-11-10 Kevin Ryde + + * mpz/powm.c (redc): Make global under WANT_REDC_GLOBAL. + * tune/powm_mod.c, tune/powm_redc.c: New files. + * tune/Makefile.am (libspeed_la_SOURCES): Add them. + * tune/*: Add measuring of redc, mpz_mod, mpz_powm_mod, mpz_powm_redc. + + * tune/tuneup.c (POWM_THRESHOLD): Determine from redc and mpz_mod. + * tune/Makefile.am (TUNE_MPZ_SRCS): Remove powm. + +2000-11-10 Torbjorn Granlund + + * mpn/mips3/gmp-mparam.h: Retune. + + * configure.in (os_64bit): Rename to check_64bit_compiler. + +2000-11-09 Torbjorn Granlund + + * configure.in [SPEED_CYCLECOUNTER_OBJS switch]: Choose hppa/hppa2 code + depending on $CC64. + +2000-11-09 Kevin Ryde + + * mpn/x86/pentium/mul_1.asm: Unroll 2x, saving 1 c/l when in L1. + Add 1c entrypoint. + * mpn/x86/pentium/aorsmul_1.asm: Add 1c entrypoints, shave a couple + of cycles at entry and exit. + + * configure.in (power1,2,2sc): Support these as synonyms for plain + power. + + * acinclude.m4 (GMP_ASM_X86_SHLDL_CL): GMP_DEFINE WANT_SHLDL_CL here. + (GMP_ASM_X86_MMX, GMP_ASM_X86_SHLDL_CL): Add X86 into the names. + * configure.in: Consequent changes. + + * gmp.texi (Notes for Particular Systems): Remarks about power/powerpc. + (Reentrancy): Remarks about simultaneous writing. + (Reporting Bugs): Ask for configfsf.guess. + +2000-11-08 Kevin Ryde + + * acinclude.m4 (GMP_FUNC_ALLOCA): New macro. + * configure.in: Use it. + * gmp-impl.h (alloca): Conditionals and setups as per autoconf + (should make alloca available on more non-gcc compilers). + + * acinclude.m4: Misc reformatting, simplify some quoting. + (GMP_ASM_UNDERSCORE, GMP_ASM_X86_MCOUNT): Use $CC $CFLAGS $CPPFLAGS. + (GMP_ASM_UNDERSCORE, GMP_ASM_ALIGN_FILL_0x90, GMP_ASM_RODATA): Put + AC_REQUIREs outside AC_CACHE_CHECK. + (GMP_C_SIZES): Use $srcdir/gmp.h, not -I; use $CPPFLAGS. + (GMP_ASM_UNDERSCORE): Use "gmp_compile" variable, and only rm + conftes1* conftes2*. + (GMP_PROG_NM): New macro, require it in appropriate GMP_ASM_*. + (GMP_TRY_ASSEMBLE): New macro, use it in various GMP_ASM_*. + * configure.in: Use GMP_PROG_NM. + + * mpn/tests/spinner.c (spinner_signal): Use RETSIGTYPE. + (spinner_init): Force output to unbuffered. + + * mpn/x86/README.family: Notes about GOT table and imul, misc updates. + * mpn/x86/k7/diveby3.asm: Change to 3 operands for immediate imul. + * mpn/x86/k6/diveby3.asm: Ditto. + +2000-11-06 Torbjorn Granlund + + * urandom.h: Simplify and make it work properly for 64-bit + machines also in environments without `random'. + +2000-11-04 Torbjorn Granlund + + * configure.in [path switch]: Don't match rs6000-*-*, in + particular don't assume POWER. + + * tune/tuneup.c (fft): Remove usleep calls. + + * config.guess: Don't pass "$@" when it is known to be empty. + + * Makefile.am (EXTRA_DIST): List configfsf.guess and configfsf.sub. + +2000-11-04 Kevin Ryde + + * configfsf.guess, configfsf.sub: Moved from config.guess and + config.sub. + * config.guess, config.sub: New files, wrappers around around + configfsf versions. + * configfsf.guess: Update to FSF 2000-10-23. + * configfsf.sub: Update to FSF 2000-10-25. + + * acinclude.m4 (GMP_ASM_POWERPC_R_REGISTERS): New macro. + * mpn/powerpc32/powerpc-defs.m4: New file, regmap.m4 r0 etc macros + conditionalized by GMP_ASM_POWERPC_R_REGISTERS. + * mpn/powerpc32/regmap.m4: Remove file. + * configure.in (powerpc*-*-*): Use all this. + + * mpz/divegcd.c: New file, providing mpz_divexact_gcd. + * Makefile.am, mpz/Makefile.am: Add it. + * gmp-impl.h (mpz_divexact_gcd): Add prototype. + * mpq/aors.c,canonicalize.c,div.c,mul.c: Use it. + + * longlong.h [pentium] (count_leading_zeros): New macro. + (__clz_tab): Always provide prototype. + * acconfig.h (HAVE_TARGET_CPU_): Add x86s. + + * tune/speed.[ch],common.c (count_leading_zeros, + count_trailing_zeros, __udiv_qrnnd_c): Add measuring. + + * configure.in (X86_PATTERN): Move from here ... + * acinclude.m4 (X86_PATTERN): ... to here. + (GMP_ASM_RODATA): Use it. + + * configure.in (srandom): New test. + * mpn/tests/try.c: Use it. + * tune/speed.c: Ditto, and conditionalize getrusage and headers. + +2000-11-02 Kevin Ryde + + * mpn/Makefile.am (nodist_libdummy_la_SOURCES): Add udiv_qrnnd.c + and udiv_w_sdiv.c. + + * mpn/generic/mul_n.c (mpn_kara_sqr_n): Remove a duplicate + subtract at the evaluate stage. + +2000-11-01 Torbjorn Granlund + + * configure.in [compiler switch] (sparc64-*-linux*): Spell + gmp_xoptcflags_gcc properly, and pass same options as for other + sparcv9 configs. + + * tune/speed.h (SPEED_ROUTINE_MPN_GET_STR): Fix type of wsize. + +2000-10-31 Torbjorn Granlund + + * configure.in [compiler switch] (sparc64-*-linux*): Remove -mvis + from gmp_xoptflags_gcc, this might not be an ultrasparc. + Remove -m32 from gmp_cflags_gcc; add -Wa,-xarch=v8plus. + +2000-10-29 Torbjorn Granlund + + * mpn/ia64/lorrshift.asm: New file. + + * configure.in: New mulfunc `lorrshift' for lshift and rshift. + +2000-10-29 Kevin Ryde + + * mpn/generic/mul_n.c (mpn_kara_sqr_n): Delete code performing + superfluous mpn_sub_n calls. + + * configure.in (found_asm, M4): Account for SPEED_CYCLECOUNTER_OBJ, + for the benefit of targets whose only .asm is a cycle counter. + + * tune/tuneup.c (fft): Remove bogus usleep calls. + +2000-10-28 Torbjorn Granlund + + * mpn/ia64/invert_limb.asm: Get return value for 0x800...00 right. + + * tune/Makefile.am (EXTRA_DIST): Add ia64.asm. + + * tune/ia64.asm: Fix typo. + + * add_n.asm addmul_1.asm mul_1.asm popcount.asm sub_n.asm: + Preserve ar.lc as required by ABI. + * longlong.h (ia64 udiv_qrnnd): New. + + * configure.in [path switch] (ia64*-*-*): Set extra_functions. + * mpn/ia64/invert_limb.asm: New file. + +2000-10-27 Torbjorn Granlund + + * configure.in [compiler switch]: + Get rid of c89 for all hppa flavours--it is an evil compiler! + + * tune/speed.h (SPEED_ROUTINE_MPN_SET_STR): Fix type of xp. + (SPEED_ROUTINE_MPN_GET_STR): Fix type of wp. + +2000-10-27 Kevin Ryde + + * gmp.texi (Fibonacci Number Algorithm): New section. + + * mpz/tests/t-fib_ui.c: New file. + * mpz/tests/Makefile.am (check_PROGRAMS): Add it. + + * mpz/fib_ui.c: Rewrite, same formulas but using mpn functions and + some lookup tables, much faster at small to moderate sizes. + * gmp-impl.h (MPZ_FIB_SIZE): New macro. + (FIB_THRESHOLD): Establish default here. + * tune/tuneup.c (FIB_THRESHOLD): Start search after the new table + data. + + * mpn/x86/x86-defs.m4 (mcount_movl_GOT_ebx): Rename from movl_GOT_ebx, + and don't use GSYM_PREFIX with _GLOBAL_OFFSET_TABLE_. + + * tune/freq.c (speed_cpu_frequency_measure): New test comparing + gettimeofday and speed_cyclecounter, should cover many systems. + +2000-10-27 Torbjorn Granlund + + * mpn/ia64/gmp-mparam.h: Retune. + +2000-10-26 Torbjorn Granlund + + * longlong.h (ia64): Set UMUL_TIME and UDIV_TIME. + + * mpn/ia64/submul_1.c: Fix typo. + +2000-10-25 Kevin Ryde + + * tune/freq.c (speed_cpu_frequency_sysctl): New test, supporting + hw.model for BSD flavours. + * configure.in (sysctl, sys/param.h): New tests. + +2000-10-24 Torbjorn Granlund + + * tune/freq.c: Explicitly #include config.h before other include files. + + * mpz/tests/reuse.c (FAIL2): New #define. + (main): Use FAIL2. Now this test properly returns non-zero exit + status when it fails. + + * mpn/powerpc32/gmp-mparam.h: Retune. + * mpn/powerpc64/gmp-mparam.h: Retune. + +2000-10-24 Kevin Ryde + + * mpn/x86/k6/cross.pl: Support 8 and 16 byte code alignment. + + * mpq/aors.c, mpq/canonicalize.c: Skip two mpz_divexact calls if + gcd gives 1, which should be 60% of the time. + * gmp-impl.h (MPZ_EQUAL_1_P): New macro. + * mpq/mul.c, mpq/div.c: Use it, and a new DIV_OR_SET. + + * tune/tuneup.c (xp_block, yp_block): Initialize these with random + data. Fixes GCD_ACCEL and GCDEXT thresholds, and latest POWM. + +2000-10-23 Torbjorn Granlund + + * configure.in [SPEED_CYCLECOUNTER_OBJS switch]: Add ia64 case. + + * mpn/ia64/gmp-mparam.h: Fill in some parameters. + + * mpn/ia64/submul_1.c: New file. + + * tune/ia64.asm: New file. + + * gmp-impl.h (union ieee_double_extract): Handle ia64. + + * mpn/mp_bases.c: Decrease chars_per_bit_exactly for entry 1 to + work around buggy ia64-linux. + + * longlong.h (ia64 umul_ppmm): Update register flags to match new GCC. + +2000-10-22 Torbjorn Granlund + + * mpn/alpha/ev6/gmp-mparam.h (DC_THRESHOLD): Update. + * mpn/alpha/ev6/submul_1.asm: New file. + +2000-10-22 Kevin Ryde + + * tune/gcd_bin.c: New file. + * tune/gcd_finda_gen.c: New file. + * tune/Makefile.am (libspeed_la_SOURCES): Add them. + * tune/speed.[ch],common.c (mpn_gcd_binary, find_a): Add measuring. + + * * (__gmp_allocate_func etc): Rename from _mp_allocate_func etc. + (__gmp_default_allocate etc): Rename from _mp_default_allocate etc. + * gmp-impl.h (__GMP_REALLOCATE_FUNC_TYPE, + __GMP_REALLOCATE_FUNC_LIMBS): New macros. + + * gmp-impl.h (DC_THRESHOLD): Establish default here, set to 3*KARA + since that's the measured average. + * mpn/generic/dc_divrem_n.c, mpn/generic/tdiv_qr.c (DC_THRESHOLD): + Remove default. + +2000-10-21 Torbjorn Granlund + + * mpn/Makefile.am (TARG_DIST): Add ia64. + +2000-10-21 Kevin Ryde + + * *: Change BZ -> DC. + * mpn/generic/dc_divrem_n.c: Renamed from bz_divrem_n.c. + + * doc/multiplication: Remove file, now in the manual. + * doc/assembly_code: Ditto. + * tune/README: Remove some parts now in the manual. + + * gmp.texi (@m etc): Add and use some new macros. + (Integer Division - mpz_[cft]div_*): Merge descriptions, for brevity + and to emphasise similarities. + (Low-Level Functions - mpn_[lr]shift): Specify count as 1 to + mp_bits_per_limb-1. + (Algorithms): New chapter. + (References): Add some papers. + + * mpn/generic/mul_n.c (mpn_toom3_mul_n, mpn_toom3_sqr_n): Remove some + unused variables. + * mpn/generic/mul_fft.c (mpn_fft_best_k): Ditto. + + * tune/freq.c: New file, split from time.c. + * tune/time.c: Rewrite, now more automated. + * configure.in, tune/*: Consequent changes. + +2000-10-20 Torbjorn Granlund + + * mpn/ia64/default.m4: New file. + * configure.in [config.m4 switch] (ia64*-*-*): Use ia64/default.m4. + + * mpn/ia64/mul_1.asm: New file. + * mpn/ia64/addmul_1.asm: New file. + * mpn/ia64/add_n.asm: New file. + * mpn/ia64/sub_n.asm: New file. + * mpn/ia64/popcount.asm: New file. + * mpn/ia64/README: New file. + + * mpn/alpha/cntlz.asm: Override `.set noat' from ASM_START. + + * configure.in (HAVE_TARGET_CPU_*): Support hppa1.0, hppa1.1, hppa2.0 + by sed'ing the period into `_'. + + * acconfig.h: Add #undefs for hppa targets. + + * longlong.h (udiv_qrnnd): Fix typo in last change. + + * mpz/tstbit.c: Rewrite (partly to work around GCC 2.95.2 HPPA bug). + + * configure.in [path switch]: + (hppa2.0*-*-*): For non-CC64 case, update path. + + * configure.in [compiler switch]: + (hppa2.0w-*-*): Match with same regexp in both places. + (hppa*-*-*): New case. + (all hppa alternatives): Don't inherit default gmp_cflags_cc, + gmp_cflags_c89. + +2000-10-18 Torbjorn Granlund + + * configure.in (alpha*-*-*): Define gmp_xoptcflags_gcc like for + alpha*-*-osf*. + + * longlong.h (x86 udiv_qrnnd): Change `d' => `dx' to avoid K&R C + stringification. + +2000-10-15 Kevin Ryde + + * doc/configuration: Updates. + + * demos/calc.y: Remove some comments. + +2000-10-14 Kevin Ryde + + * gmp.texi (Parameter Conventions, Memory Management): New sections + split from "Variable Conventions". + (Efficiency, Debugging, Profiling): New sections in "GMP Basics". + (Reentrancy): Some rewording, add note on standard I/O. + (Build options): Add --enable-assert and --enable-profiling. + + * configure.in (--enable-profiling): New option. + * acinclude.m4 (GMP_ASM_X86_MCOUNT): New macro, finding how to profile. + * mpn/x86/x86-defs.m4 (PROLOGUE_cpu, call_mcount): Profiling support. + + * acinclude.m4, configure.in (GMP_ASM_*): Rename from GMP_CHECK_ASM_*, + to follow autoconf conventions. + + * configure.in: Run GMP_CHECK_ASM tests only if needed. + * acinclude.m4 (GMP_CHECK_ASM_MMX): Don't use GMP_CHECK_ASM_TEXT. + + * mpn/x86/x86-defs.m4 (ASSERT): Allow no condition, to just emit code. + +2000-10-13 Kevin Ryde + + * mpq/md_2exp.c: New file. + * mpq/Makefile.am (libmpq_la_SOURCES): Add it. + * Makefile.am (MPQ_OBJECTS): Ditto. + * gmp.h (mpq_mul_2exp, mpq_div_2exp): Add prototypes. + * gmp.texi (Rational Arithmetic): Add documentation. + + * mpq/tests/t-md_2exp.c: New file. + * mpq/tests/Makefile.am (check_PROGRAMS): Add it. + + * mpn/generic/perfsqr.c: Add/amend some comments. + + * gmp.texi (Known Build Problems): Note VERSION problem with old + sed, do some minor rewording. + (Build Options): Add cygwin and djgpp URLs, mention INSTALL.autoconf, + mention HTML. + (Getting the Latest Version of GMP): Move this ... + (Introduction to GMP): ... to here. + (Compatibility with older versions): Just refer to 2.x and 3.x, not + every minor version. + (Initializing Integers): Note restrictions on mpz_array_init'ed + variables. + (Integer Logic and Bit Fiddling): Note bits are numbered from 0. + + * INSTALL.autoconf: New file. + * Makefile.am (EXTRA_DIST): Add it. + + * tune/Makefile.am, tune/tuneup.c, configure.in, gmp-impl.h: New + scheme for recompiled objects used by tune program. Don't use + libgmptune.a, make better use of libtool, work with ansi2knr. + + * tune/speed.h,common.c (SPEED_ROUTINE_MPZ_POWM): Use s->yp and + s->xp_block, make exponent a fixed size. + +2000-10-07 Torbjorn Granlund + + * mpn/mips3/gmp-mparam.h: Retune. + + * mpn/generic/mul_n.c (USE_MORE_MPN): Revert last change. + +2000-10-06 Torbjorn Granlund + + * mpn/mips3/add_n.s: Decrease carry recurrence from 4 to 3 cycles. + * mpn/mips3/sub_n.s: Likewise. + +2000-10-04 Torbjorn Granlund + + * configure.in (sparc64-*-linux*): Set path according to CC64. + +2000-10-04 Kevin Ryde + + * acinclude.m4 (GMP_CHECK_ASM_UNDERSCORE): Use LABEL_SUFFIX, not a + hard-coded ":". + + * config.sub: Don't demand "86" in CPU name for SCO. + + * configure.in (supersparc-*-*): Remove -DSUPERSPARC. + * longlong.h: Use HAVE_TARGET_CPU_supersparc. + + * configure.in (HAVE_TARGET_CPU_*): AC_DEFINE from $target_cpu. + * acconfig.h: Add #undefs, but only for targets of interest. + +2000-10-03 Torbjorn Granlund + + * mpn/alpha/cntlz.asm: Rewrite. + + * mp_clz_tab.c (__clz_tab): Half table size to 128 entires. + * longlong.h (count_leading_zeros): Demand just 128 entries from + __clz_tab. + + * configure.in (mips-sgi-irix6.*): Pass -mips3 in addition to options + for n32 ABI. + + * longlong.h: Move NO_ASM test around all assembly code. + From gcc: + * longlong.h (count_leading_zeros): Sparclite scan instruction was + being invoked incorrectly. + Replace __mc68332__ with __mcpu32__. + Add ARC support. + +2000-10-02 Torbjorn Granlund + + * mpn/mips3/gmp-mparam.h: Retune for both gcc and cc. + + * mpn/generic/mul_n.c (USE_MORE_MPN): Remove exception for __mips. + (interpolate3): Cast mp_limb_t variables to mp_limb_signed_t + when testing sign bit. + + * mpn/alpha/ev6/gmp-mparam.h: Retune. + * mpn/powerpc32/gmp-mparam.h: Retune. + * mpn/powerpc64/gmp-mparam.h: Retune. + * mpn/x86/pentium/gmp-mparam.h: Retune. + * mpn/x86/pentium/mmx/gmp-mparam.h: Retune. + * mpn/sparc32/v9/gmp-mparam.h: Retune. + * mpn/x86/k6/gmp-mparam.h: Retune. + * mpn/x86/p6/gmp-mparam.h: Retune. + * mpn/x86/k7/gmp-mparam.h: Retune. + * mpn/sparc64/gmp-mparam.h: Retune. + + * mpn/m68k/gmp-mparam.h: New file. + * mpn/alpha/ev5/gmp-mparam.h: New file. + + * gmp-impl.h (default MPN_COPY): Remove final `;'. + + * tune/time.c (speed_endtime): Rewrite. + + * tune/speed.h (SPEED_ROUTINE_MPZ_POWM): Set base to a large value, + not 2. + + * demos/pexpr.c (setup_error_handler): Fix typo. + + * mpz/powm.c (redc): New function, based on old mpz_redc. Don't + multiply here. + (mpz_redc): Remove. + (mpz_powm): Major changes, partially reverting to mpn calls. + Multiply before calling redc. + (mpz_powm): Use TMP_ allocation. + (mpz_powm): Refine calculation of k (width of exponent window). + (mpz_powm): Cast constants to mp_limb_t before left shifting. + + * longlong.h: Use ia64 count_leading_zeros just when __GNUC__. + +2000-09-29 Kevin Ryde + + * acinclude.m4 (GMP_C_SIZES): New macro. + * configure.in: Use it. + * acconfig.in (BYTES_PER_MP_LIMB etc): Add #undefs. + * mpn/generic/gmp-mparam.h (BYTES_PER_MP_LIMB etc): Remove #defines. + * gmp.texi (Known Build Problems): Remove 64-bit generic C + gmp-mparam.h problem, now fixed. + + * configure.in: Only run GMP_PROG_M4 if it's actually needed. + +2000-09-27 Torbjorn Granlund + + * demos/pexpr.c: Clean up code for systems not supporting + sigaltstack. Handle old Linux without sigaltstack. Properly + disable all stuff related to sigaltstack under Unicos. + + * mpn/alpha/ev6/addmul_1.asm: Use explicit offset for all load and + store insns. Helps old gas. + + * longlong.h (count_leading_zeros): Define for ia64. + +2000-09-27 Paul Zimmermann + + * mpn/generic/bz_divrem_n.c: Fix qhl handling, simplify. + +2000-09-27 Kevin Ryde + + * mpn/Makefile.in (.SUFFIXES): Regenerate with patched automake to + get .s before .c, which is needed to override ansi2knr .c rules. + + * gmp.texi (mpn_sqrtrem): Fix r2p==NULL return value description + to match the code (change by Torbjorn). + (mpn_gcd, mpn_gcdext, mpn_sqrtrem, mpn_tdiv_qr): Note most + significant limbs must be non-zero. + (mpn_gcd, mpn_gcdext, mpn_sqrtrem): Clarify destination size + requirements. + (mpn_gcd_1): Clarify value must be non-zero, not just size. + + * gmp-impl.h (mpn_zero_p): New inline function. + * mpn/generic/inlines.c: Add gmp-impl.h. + * mpf/integer.c, mpz/get_d.c, mpn/generic/mul_fft.c: Use it. + + * mpn/generic/gcd.c: Use MPN_COPY_INCR not MPN_COPY. + * mpf/add_ui.c: Ditto. + * mpf/add.c: Ditto, and fix test to skip copy. + +2000-09-26 Kevin Ryde + + * gmp-impl.h, longlong.h, mpn/generic/*.c: Add ASSERTs for various + parameter restrictions. + + * gmp-impl.h (UDIV_PREINV_TIME): New macro. + * mpn/generic/sb_divrem_mn.c: Use it. + * mpn/generic/perfsqr.c: Ditto. + * mpn/x86/*/gmp-mparam.h (UDIV_PREINV_TIME): Add values. + + * macos/Makefile.in: Add mpz/tests/t-get_si.c, mpf/tests/t-set_f.c, + and new multi-function mpz and mpq files. + +2000-09-25 Kevin Ryde + + * randlc.c, randlc2x.c, randsd.c, mpz/urandomb.c, mpz/urandomm.c: + Use mpz_ptr and mpz_srcptr for parameters. + * gmp.h (gmp_randinit_lc, gmp_randinit_lc_2exp, gmp_randseed, + mpz_urandomb, mpz_urandomm): Corresponding change to prototypes. + * randsdui.c: Remove wrong K&R parameters part. + +2000-09-12 Kevin Ryde + + * gmp-impl.h (mpn_tdiv_qr): Move prototype from here ... + * gmp.h (mpn_tdiv_qr): ... to here. + + * gmp.texi (Miscellaneous Rational Functions): Comment-out and + move version 1 compatibility note to "Compatibility" section. + (Rational Number Functions): Ditto for canonicalization note. + +2000-09-10 Kevin Ryde + + * mpn/x86/pentium/com_n.asm: New file. + + * gmp.texi (Rational Arithmetic): Add mpq_abs. + (Miscellaneous Rational Functions): Merge and simplify descriptions of + mpq_get_num, mpq_get_den, mpq_set_num, mpq_set_den. + + * mpq/abs.c: New file. + * mpq/Makefile.am (libmpq_la_SOURCES): Add it. + * Makefile.am (MPQ_OBJECTS): Add it. + * gmp.h (mpq_abs): Add prototype. + + * mpq/set_den.c: Don't discard sign when copying, this makes the + code match the manual. + +2000-09-07 Torbjorn Granlund + + * tune/alpha.asm: Rewrite to actually work right. + +2000-09-07 Kevin Ryde + + * tune/common.c,speed.[ch]: Add measuring of mpn_sqrtrem, + mpn_get_str, mpn_set_str. + * tune/README: Various updates. + +2000-09-06 Torbjorn Granlund + + * mpz/fits.c: Correct type of `data'. + +2000-09-06 Kevin Ryde + + * gmp.texi (Build Options): Clarify where to find CFLAGS. + (Known Build Problems): Note SCO -lc problem. + + * tune/speed.h (SPEED_ROUTINE_MPN_GCD_CALL): Fix for sizes > 512 limbs. + + * doc/multiplication: Corrections and additions suggested by Paul. + + * tune/modlinv.c: New file with alternate modlimb_inverts. + * tune/Makefile.am, tune/speed.[ch]: Add measuring of them. + * tune/speed.c (FLAG_NODATA): New attribute, use for mpz_bin_uiui, + mpz_fib_ui, mpz_fac_ui. + + * mpn/x86/t-zdisp.sh: New file. + + * tests/t-modlinv.c: New file. + * tests/Makefile.am (check_PROGRAMS): Add it. + + * mpq/tests/t-set_f.c: New file. + * mpq/tests/Makefile.am (check_PROGRAMS): Add it. + + * gmp-impl.h (MPQ_CHECK_FORMAT): New macro. + * mpq/tests/t-get_d.c: Use it. + + * mpq/set_f.c: New file. + * mpq/Makefile.am (libmpq_la_SOURCES): Add it. + * Makefile.am (MPQ_OBJECTS): Ditto. + * gmp.h: Add prototype. + * gmp.texi (Miscellaneous Rational Functions): Document mpq_set_f, + correct return type of mpq_set_d. + +2000-09-03 Kevin Ryde + + * mpz/aors_ui.c: New file merging add_ui.c and sub_ui.c, no object + code changes. + * mpz/add_ui.c, mpz/sub_ui.c: Remove files. + * mpz/Makefile.am: Update. + + * gmp-impl.h (MPZ_FITS_STYPE_SDT, MPZ_FITS_UTYPE_SDT): New macros. + * mpz/fits.c: New file merging six separate fits*.c. + * mpz/fits_sshort_p.c, fits_sint_p.c, fits_slong_p.c, fits_ushort_p.c, + fits_uint_p.c, fits_ulong_p.c: Remove files + * mpz/Makefile.am: Use new fits.c, change object names from + fits_*_p.lo to fits_*.lo to avoid SunOS 4 native "ar" warnings. + * Makefile.am (MPZ_OBJECTS): Change from fits_*_p.lo to fits_*.lo. + + * acinclude.m4 (GMP_CHECK_ASM_RODATA): New macro, defining RODATA. + * configure.in: Use it. + * mpn/x86/k[67]/mmx/popham.asm: Use it. + + * mpn/x86/*/*.asm: Use "TEXT" not ".text". + +2000-09-02 Kevin Ryde + + * mpq/aors.c: New file merging add.c and sub.c, no object code changes. + * mpq/add.c, mpq/sub.c: Remove files. + * mpq/Makefile.am: Update. + + * mpz/aors.c: New file merging add.c and sub.c, no object code changes. + * mpz/add.c, mpz/sub.c: Remove files. + * mpz/Makefile.am, mpbsd/Makefile.am: Update. + + * configure.in: Re-apply "PROLOGUE.*" regexp change for the + benefit of alpha PROLOGUE_GP, lost in path search reorganisation. + + * mpn/x86/x86-defs.m4 (jadcl0, cmov_simulate, ASSERT, + movl_text_address): Don't use "1:" style labels. + (Zdisp): Rearrange a bit, switch to all hex. + * mpn/x86/README.family: Note SCO "as" doesn't support "1:" style + local labels, misc rewordings. + +2000-08-29 Torbjorn Granlund + + * demos/primes.c: Include string.h. + + * config.guess (x86 variant recog code): Remove dummy*.o files + generated by some compilers. + +2000-08-28 Kevin Ryde + + * acinclude.m4 (GMP_CHECK_ASM_ALIGN_FILL_0x90): Fix Solaris 2.8 + warning message suppression, add notes about SCO. + + * Makefile.am (MPZ_OBJECTS etc): Move some comments. + +2000-08-25 Kevin Ryde + + * mpz/pprime_p.c (mpz_millerrabin): Fix a TMP_FREE. + + * gmp.texi (Copying): Refer to Lesser not Library GPL. + (GMP and Reentrancy): Note stack-alloc.c is not reentrant, and + that SCO is potentially not reentrant. + + * acinclude.m4 (GMP_CHECK_ASM_UNDERSCORE): Test by attempting to + link with or without an underscore. + * gmp.texi (Known Build Problems): Remove SunOS 4 native grep + GSYM_PREFIX problem, now fixed. + + * gmp-impl.h (MODLIMB_INVERSE_3): New constant. + * mpn/generic/diveby3.c: Use it instead of own INVERSE_3. + * mpn/generic/mul_n.c: Ditto. + * tests/t-constants.c: Check it, and PP_INVERTED too. + + * acinclude.m4 (GMP_GCC_MARCH_PENTIUMPRO): New macro. + * configure.in [p6 and athlon] (gmp_optcflags_gcc): Use it to + possibly add -march=pentiumpro. + + * gmp-impl.h (MPZ_SET_STR_OR_ABORT, MPF_SET_STR_OR_ABORT): New macros. + * mpz/tests/t-bin.c, mpz/tests/t-get_si.c, mpz/tests/t-jac.c, + mpz/tests/t-misc.c: Use them. + * mpf/tests/t-conv.c, mpf/tests/t-misc.c: Ditto. + * mpz/tests/convert.c: Ditto and amend diagnostics slightly. + * mpz/tests/t-misc.c (check_mpz_set_si): Remove a superfluous init. + * mpz/tests/io.c: Differentiate between I/O and data conversion errors. + + * mpn/generic/aors_n.c: New file merging add_n and sub_n, no + object code changes. + * mpn/generic/add_n.c: Remove file. + * mpn/generic/sub_n.c: Remove file. + + * mpn/generic/aorsmul_1.c: New file merging addmul_1 and submul_1, + no object code changes. + * mpn/generic/addmul_1.c: Remove file. + * mpn/generic/submul_1.c: Remove file. + + * mpn/generic/popham.c: New file merging popcount and hamdist, no + object code changes. + * mpn/generic/popcount.c: Remove file. + * mpn/generic/hamdist.c: Remove file. + +2000-08-24 Torbjorn Granlund + + * gmp-impl.h (mpn_com_n): Fix typo. + +2000-08-23 Torbjorn Granlund + + * demos/primes.c (main): Don't call mpz_probab_prime_p for numbers + that are known to be prime after sieving. + (main): Declare and initialize max_s_prime_squared. + (MAX_S_PRIME): Increase. + (ST_SIZE): Increase. + +2000-08-23 Kevin Ryde + + * gmp-impl.h (ASSERT_ALWAYS): Change to statement style. + (JACOBI_TWO_U_BIT1): Remove ASSERT. + (MPZ_CHECK_FORMAT): Use ASSERT_ALWAYS as a statement. + +2000-08-21 Torbjorn Granlund + + * gmp-impl.h (ASSERT): Use do..while for dummy version. + + * mpf/get_str.c: Don't set n_digits from digits_computed_so_far + when the converted operand becomes zero. Misc cleanups. + +2000-08-21 Kevin Ryde + + * mpz/fdiv_r_2exp.c, mpz/lcm.c, mpz/urandomm.c: Add missing + TMP_MARK/FREE, avoiding memory leak when using stack-alloc.c. + +2000-08-20 Kevin Ryde + + * mpz/set.c [BERKELEY_MP] (move): Add conditionals to build as + "move" for libmp. + * mpbsd/Makefile.am: Use mpz/set.c, not move.c. + * Makefile.am (MPBSD_OBJECTS): Corresponding change. + * mpbsd/move.c: Remove file. + + * mpn/Makefile.am, mpz/Makefile.am, mpq/Makefile.am, mpf/Makefile.am, + mpbsd/Makefile.am (-DOPERATION_foo): Use "foo" even for ansi2knr + "foo_" objects. Do this with the makefiles to keep the sources + cleaner. + * mpz/mul_siui.c, mpf/integer.c: Revert to plain OPERATION_* forms. + + * mpn/lisp/gmpasm-mode.el (gmpasm-remove-from-list): Renamed from + gmpasm-delete-from-list, because it's non-destructive. + (gmpasm-font-lock-keywords): Add some more keywords. + +2000-08-16 Kevin Ryde + + * tune/mul_n_mpn.c, tune/mul_n_open.c: New files, being forced + open-coded and mpn #includes of mpn/generic/mul_n.c. + * tune/*: Add measuring of them. + * tune/speed.c: Print command line into *.gnuplot file. + + * mpn/generic/mul_n.c (USE_MORE_MPN): Change to #if not #ifdef for + using the value, add #ifndef for providing the default. + * mpn/sparc64/gmp-mparam.h (USE_MORE_MPN): Add #ifndef. + + * tests/t-constants.c: New file. + * tests/Makefile.am (check_PROGRAMS): Add it. + + * mpz/get_si.c: Use LONG_MAX, not BITS_PER_MP_LIMB, so the result + doesn't depend on limb size when outside the range of a long + (though such results are not actually documented). + * mpz/tests/t-get_si.c: New file. + * mpz/tests/Makefile.am (check_PROGRAMS): Add it. + + * mpn/tests/try.c (call): Cast popcount and hamdist calls, + for the benefit of long long limb. + +2000-08-15 Kevin Ryde + + * mp.h (mp_set_memory_functions): Add missing #define. + * mpbsd/tests/allfuns.c (mp_set_memory_functions): Verify its + existence. + + * mpf/tests/t-misc.c (check_mpf_getset_prec): New test, verifying + reverted behaviour of mpf_get_prec. + + * mpn/tests/ref.c (refmpn_strip_twos): Use refmpn_copyi, not + MPN_COPY_INCR. + + * mpz/mul_siui.c, mpf/integer.c: Recognise OPERATION_*_ forms + produced under ansi2knr. + + * configure.in (mpn_objects, mpn_objs_in_libgmp): Add $U to .c + objects when ansi2knr in use. + + * mpn/Makefile.am (AUTOMAKE_OPTIONS): Enable ansi2knr. + (libdummy.la): Add this, not built, to create ansi2knr style rules + for all potential .c files. + * mpz/Makefile.am, mpq/Makefile.am, mpf/Makefile.am, mpfr/Makefile.am, + mpbsd/Makefile.am, mpq/tests/Makefile.am, tests/Makefile.am + (AUTOMAKE_OPTIONS): Enable ansi2knr (now everywhere). + * Makefile.am (MPZ_OBJECTS, MPQ_OBJECTS, MPF_OBJECTS, MPFR_OBJECTS, + MPBSD_OBJECTS, libmp_la_DEPENDENCIES): Add $U to all .lo filenames. + +2000-08-03 Torbjorn Granlund + + * mpn/alpha/ev6/addmul_1.asm: Correct number of cycles to 3.5/28. + +2000-08-02 Torbjorn Granlund + + * Version 3.1 released. + + * gmp.texi: Rephrase mpf_urandomb documentation. + + * mpn/alpha/ev6: New directory with ev6/21264 optimized code. + * mpn/alpha/ev6/addmul_1.asm: New file. + * mpn/alpha/ev6/gmp-mparam.h: New file. + +2000-08-02 Kevin Ryde + + * demos/factorize.c (random): Don't use "inline". + + * mpfr/log.c, mpfr/mul_ui.c, mpfr/round.c, mpfr/set.c, mpfr/set_d.c: + Corrections to K&R parts. + + * Makefile.am (EXTRA_HEADERS): Omit $(MPFR_HEADERS_OPTION). + * mpfr/Makefile.am (EXTRA_DIST): Add mpfr.h. + + * gmp.texi (Known Build Problems): Note problem stripping libgmp.a. + +2000-08-02 Kent Boortz + + * mpfr: Integrated experimental version of mpfr-0.4. + * configure.in: Changes for option --enable-mpfr. + * Makefile.am: Changes for option --enable-mpfr. + +2000-08-01 Torbjorn Granlund + + * mpn/generic/popcount.c: Disable SPARC v9 popc_limb pattern. + * mpn/generic/hamdist.c: Likewise. + +2000-08-01 Kevin Ryde + + * mpn/tests/try.c (try_init): Account for ALIGNMENTS when sizing + source and dest regions. + +2000-07-31 Torbjorn Granlund + + * mpf/get_str.c: Develop three extra digits, not just one. + +2000-07-31 Kevin Ryde + + * gmp.texi (References): Add URL for invariant division. + +2000-07-30 Kevin Ryde + + * tune/time.c (speed_cpu_frequency_proc_cpuinfo): Add support for + alpha linux "cycle frequency". + + * mpn/sparc64/gmp-mparam.h: Re-run tune program for FFT thresholds. + +2000-07-29 Kevin Ryde + + * gmp.texi (ABI and ISA): Add sparc64-*-linux*. + * configure.in [sparc64-*-linux*] (gmp_cflags64_gcc): Same flags + as under solaris. + + * configure.in (--enable-fft): New option, default "no". + * gmp.texi (Build Options): Describe it. + * mpn/generic/mul.c, mpn/generic/mul_n.c [WANT_FFT]: Use it. + * tune/tuneup.c [WANT_FFT]: By default don't probe FFTs if not enabled. + * NEWS: Multiplication optionally using FFT. + + * tune/README: Notes on FFT and GCD thresholds, other minor updates. + + * Makefile.am: Expunge the macos generated files update stuff. + +2000-07-28 Kevin Ryde + + * mpn/x86/*/gmp-mparam.h: Add some FFT thresholds. + +2000-07-28 Kent Boortz + + * macos/Asm*, macos/CmnObj, macos/Mp*: Delete directories. + * macos/Makefile: Delete file. + * macos/Makefile.cw: Delete file. + * macos/config.h: Delete file. + * macos/Asm/*.s: Delete files. + * macos/configure: Create target directories. Don't transform + '(C)' to '(;)' in a 'dnl' line comment in .asm file. + * Makefile.am: Delete macos targets. + * macos/README: Reflect that we reverted back to a build + process that require ""macos/configure" to run on MacOS. + This imply that MacPerl is needed for a build in MacOS. + +2000-07-27 Kevin Ryde + + * mpn/generic/mul_fft.c: New file, by Paul Zimmermann, minor mods + applied. + * configure.in (gmp_mpn_functions): Add it. + * mpn/generic/mul.c, mpn/generic/mul_n.c: Use it. + * doc/multiplication: Describe it (briefly). + + * gmp-impl.h (FFT_MUL_THRESHOLD etc): New thresholds. + (mpn_fft_best_k, mpn_fft_next_size, mpn_mul_fft, mpn_mul_fft_full): + New functions. + (numberof, TMP_ALLOC_TYPE etc, _MP_ALLOCATE_FUNC_TYPE etc, + UNSIGNED_TYPE_MAX etc): New macros. + + * tune/*: Add FFT threshold tuning and speed measuring. + * tune/common.c: Avoid huge macro expansions for umul and udiv. + + * mpz/tests/t-bin.c, mpz/tests/t-jac.c, mpz/tests/t-misc.c, + mpbsd/tests/t-misc.c, mpf/tests/t-misc.c, mpn/tests/try.c, + mpn/tests/spinner.c: Use new gmp-impl.h macros. + + * demos/Makefile.am (BUILT_SOURCES): Don't need calc.c etc under this. + +2000-07-27 Torbjorn Granlund + + * mpn/ia64/gmp-mparam.h: New file. + +2000-07-26 Torbjorn Granlund + + * demos/isprime.c: Handle any number of arguments and print + classification for each. Add `-q' option for old behaviour. + +2000-07-26 Kevin Ryde + + * gmp.texi (Build Options): Mention djgpp stack size. + (Notes for Package Builds): New section. + (Compatibility with older versions): Update for 3.1, add mpf_get_prec. + + * demos/factorize.c [__GLIBC__]: Don't declare random() under glibc. + + * gmp.h (gmp_version): Add prototype and define. + + * Makefile.am: Keep macos directory generated files up-to-date + during development and on a "make dist". + +2000-07-25 Torbjorn Granlund + + * mpn/hppa/gmp-mparam.h: Update threshold values from new `tune' run. + + * mpn/pa64/gmp-mparam.h: Fill in values from `make tune' run. + * mpn/pa64w/gmp-mparam.h: Likewise. + * mpn/mips3/gmp-mparam.h: Likewise. + + * tune/hppa2.asm: Fix typo in .level directive. + + * configure.in: Add sparc64-*-linux* support (from Jakub Jelinek). + * configure: Regenerate. + + * mpn/sparc64/rshift.asm: Use %g5 instead of volatile stack frame area + for return value (from Jakub Jelinek). + * mpn/sparc64/lshift.asm: Likewise. + + * mpf/get_prc.c: Revert Aug 8, 1996 change. + + * version.c: No longer static. + + * mpn/pa64/gmp-mparam.h: Only #define *_THRESHOLD if not already + defined. + * mpn/pa64w/gmp-mparam.h: Likewise. + * mpn/arm/gmp-mparam.h: Likewise. + * mpn/mips3/gmp-mparam.h: Likewise. + +2000-07-25 Kevin Ryde + + * INSTALL: It's "info -f ./gmp.info" to be sure of hitting the + gmp.info in the current directory. + + * Makefile.am (libmp_la_DEPENDENCIES): Add mpz/cmp.lo, for last + mpz/powm.c fix. + + * mpn/sparc64/addmul1h.asm, mpn/sparc64/submul1h.asm: Renamed from + addmul_1h.asm, submul_1h.asm to avoid name conflicts on an 8.3 + filesystem. + * mpn/sparc64/addmul_1.asm, mpn/sparc64/submul_1.asm, + mpn/sparc64/mul_1.asm: Update include_mpn()s. + +2000-07-24 Torbjorn Granlund + + * Update header of all files previously under the Library GPL + to instead be under the Lesser GPL. + + * COPYING.LIB: Now Lesser GPL. + * demos/primes.c: Change license to GPL (was Library GPL). + * demos/isprime.c: Change license to GPL (was Library GPL). + + * gmp.h (error code enum): Add GMP_ERROR_BAD_STRING (currently unused). + + * mpz/tests/t-mul.c: Default SIZE to a function of TOOM3_MUL_THRESHOLD. + Improve error messages. Decrease reps. + +2000-07-22 Kevin Ryde + + * tune/speed.h: Decrease the amount of data used for gcd and powm + measuring, to make the tune go a bit faster. + +2000-07-21 Kent Boortz + + * macos/Asm*, macos/CmnObj, macos/Mp*: Directories no longer created + from configure script, now part of dist. + * macos/Makefile + * macos/Makefile.cw + * macos/config.h + * macos/Asm/*.s + New files and directories that is the output from configure. This way + no Perl installation is required to build on MacOS, just MPW. + * macos/configure: Added prefix '__g' to exported assembler labels. + Changed to handle new m4 syntax instead of the old cpp syntax in asm. + * macos/Makefile.in: Corrected 'clean' target, added 'distclean' + and 'maintainer_clean'. Added "mpn/mp_bases.c" to build. + * macos/README: Reflect the new build process without configure. + Corrected the file structure for Apple MPW installation. + +2000-07-21 Torbjorn Granlund + + * mpf/tests/t-muldiv.c: Relax error limit. Make precision depend + on SIZE. Misc changes. + + * configure: Regenerate. + +2000-07-20 Kent Boortz + + * macos/Makefile.in: Removed hard coded targets, added special + targets found in Makefile.am files. + * macos/configure: Generate targets from top configure script and + Makefile.am files. Made script runnable from Unix for testing. + * macos/README: Notes about search paths for includes, contributed + by Marco Bambini. + * configure.in: Added comment about lines that the "macos/configure" + script depend on. + +2000-07-20 Torbjorn Granlund + + * mpz/powm.c (mpz_powm): After final mpz_redc call, subtract `mod' + from result if it is greater than `mod'. + +2000-07-19 Torbjorn Granlund + + * mpn/hppa/gmp-mparam.h: Fill in values from `make tune' run. + * mpn/alpha/gmp-mparam.h: Likewise. + * mpn/powerpc32/gmp-mparam.h: Likewise. + + * tune/hppa.asm: New file. + * tune/hppa2.asm: New file. + * configure.in (SPEED_CYCLECOUNTER_OBJS): Set for hppa2*-*-* and + hppa*-*-*. + * tune/Makefile.am (EXTRA_DIST): Add hppa.asm and hppa2.asm. + + * tune/speed.h (SPEED_ROUTINE_MPN_BZ_DIVREM_CALL): Declare `marker'; + invoke TMP_FREE. + + * mpn/hppa/hppa1_1/udiv_qrnnd.S: Use "%" instead of "'" for + reloc/symbol delimiter. + +2000-07-16 Torbjorn Granlund + + * mpn/powerpc64/gmp-mparam.h: Update with output from tune utility. + * mpn/powerpc64/copyi.asm: New file. + * mpn/powerpc64/copyd.asm: New file. + +2000-07-16 Kevin Ryde + + * tune/*: Add measuring for umul_ppmm and udiv_qrnnd. + +2000-07-14 Kevin Ryde + + * mpn/x86/k6/k62mmx: New directory. + * configure.in (k6[23]*-*-*): Use it. + * mpn/x86/k6/k62mmx/copyi.asm, mpn/x86/k6/k62mmx/copyd.asm: Move from + mmx directory, improve code alignment a bit. + * mpn/x86/k6/k62mmx/lshift.asm, mpn/x86/k6/k62mmx/rshift.asm: Ditto, + and improve addressing modes for pre-CXT cores. + * mpn/x86/x86-defs.m4 (Zdisp): Add an instruction. + * mpn/x86/k6/mmx/lshift.asm, mpn/x86/k6/mmx/rshift.asm: New files, + suiting plain K6. + * mpn/x86/README, mpn/x86/k6/README: Updates. + * mpn/x86/k6/mmx/*.asm: Update some comments. + + * mpn/tests/Makefile.am: Use $(MAKE) in .asm rules, not "m". + * tune/Makefile.am: Use $(EXEEXT) and libtool --config objdir, for + the benefit of djgpp. + + * */Makefile.in: Regenerate with patched automake that adds + $(EXEEXT) to EXTRA_PROGRAMS. + + * mpn/tests/try.c: Add #ifdef to SIGBUS, for the benefit of djgpp. + * config.guess: Recognise pc:*:*:* as an x86, for djgpp. + + * configure: Regenerate with patched autoconf to fix temp file + ".hdr" which is invalid on a DOS 8.3 filesystem, and to fix two + sed substitutes that clobbered a ":" in $srcdir (eg. a DOS drive + spec). + + * mpz/tests/io.c: Use one fp opened "w+", since separately opened + input and output doesn't work on MS-DOS 6.21. + + * tests/rand/Makefile.am (allprogs): Pseudo-target to build everything. + (CLEANFILES): Add EXTRA_PROGRAMS and EXTRA_LTLIBRARIES. + (manual-test, manual-bigtest): Add $(EXEEXT) to dependencies. + + * tests/rand/*/Makefile.in: Regenerate with patched automake that adds + $(EXEEXT) to EXTRA_PROGRAMS. + +2000-07-13 Torbjorn Granlund + + * mpz/tests/t-root.c: Also test mpz_perfect_power_p. + Generate `nth' so that there will be fewer trivial values. + + * mpz/root.c: Reverse return value in tests for detecting root of +1 + and -1. + + * mpz/perfpow.c: Use TMP_ALLOC interface. + +2000-07-12 Torbjorn Granlund + + * mpz/perfpow.c (primes): Make it const. + +2000-07-06 Kevin Ryde + + * mpn/x86/k6/cross.pl: New file. + + * mpn/x86/*/gmp-mparam.h: Updates to thresholds, conditionalize + all _TIME defines. + * mpn/x86/pentium/mmx/gmp-mparam.h: New file. + * mpn/sparc64/gmp-mparam.h: Update thresholds. + * mpn/sparc32/v9/gmp-mparam.h: Ditto. + +2000-07-04 Kevin Ryde + + * NEWS: Updates. + * mpn/x86/*/README: Miscellaneous updates. + + * tune/speed-ext.c: New file. + * tune/Makefile.am: Add it. + * tune/README: Updates. + * tune/speed.h (SPEED_ROUTINE_MPN_DIVREM_2): Bug fixes. + + * demos/calc.y,calclex.l: New files. + * demos/calc.c,calc.h,calclex.c: New files, generated from .y and .l. + * demos/Makefile.am: Add them. + + * gmp.h (mpq_swap, mpf_swap): Add prototypes and defines. + +2000-07-01 Kevin Ryde + + * gmp.texi (ABI and ISA): New section, bringing together ABI notes. + (Build Options): Add MPN_PATH, various updates. + (Build Options): Add note on setting CFLAGS when setting CC. + (Notes for Particular Systems): Add -march=pentiumpro problem. + (Known Build Problems): Note on gmp-mparam.h for 64-bit generic C. + (GMP Variable Conventions): Add some info on user defined functions. + (Reporting Bugs): Minor rewording. + + * configure.in (MPN_PATH): Renamed from mpn_path. + + * gmp-impl.h (ULONG_MAX,ULONG_HIGHBIT,...,SHORT_MAX): New defines. + * mp[zf]/tests/t-misc.c: Use them. + + * mpbsd/tests/t-misc.c: New file. + * mpbsd/tests/Makefile.am: Add it. + + * Makefile.am (LIBGMP_LT_*, LIBMP_LT_*): Bump version info. + * gmp.h (__GNU_MP_VERSION_*): Bump to 3.1. + + * mpf/tests/Makefile.am (AUTOMAKE_OPTIONS): Add ansi2knr. + + * Makefile.am (libmp_la_SOURCES): Add mp_set_fns.c, accidentally + omitted in gmp 3.0.x. + * gmp.texi (Custom Allocation): Note this is available in mpbsd, + and some minor rewording. + +2000-06-30 Torbjorn Granlund + + * demos/factorize.c (random): New function, defined conditionally. + (factor_using_pollard_rho): Use it, not mrand48. + + * mpn/cray/README: New file. + +2000-06-30 Kevin Ryde + + * mpn/x86/pentium/aorsmul_1.asm: Add MULFUNC_PROLOGUE. + + * mpz/tests/t-jac.c: Test limbs on mpn_jacobi_base, not just ulongs. + + * gmp-impl.h, mpn/tests/try.c, mpn/tests/spinner.c, tune/speed.c: + Use config.h unconditionally, not under HAVE_CONFIG_H. + + * demos/pexpr.c [__DJGPP__]: Patch by Richard Dawe to not use + setup_error_handler on djgpp. + + * tune/*: Locate data to help direct-mapped caches, add measuring + of mpz_init/clear, mpz_add and mpz_bin_uiui, various cleanups. + * configure.in (AC_CHECK_FUNCS): Add popen. + +2000-06-29 Torbjorn Granlund + + * mpf/mul_2exp.c: Streamline criterion for whether to use mpn_lshift or + mpn_rshift. Increase precision when exp is a multiple of + BITS_PER_MP_LIMB primarily to make exp==0 be a noop. + * mpf/div_2exp.c: Analogous changes. + + * mpf/tests/t-dm2exp.c: Set u randomly in loop. Perform more + mpf_mul_2exp testing. + + * configure.in: Recognize cray vector processors with a broad `*'; + move after alpha* not to match that. + +2000-06-28 Kevin Ryde + + * mpz/tests/io.c: Use a disk file, not a pipe, switch to ansi2knr + style, switch from MP_INT to mpz_t, add a couple of error checks. + * mpz/tests/Makefile.am (CLEANFILES): Add io.tmp, in case io.c fails. + +2000-06-27 Torbjorn Granlund + + * mpf/tests/t-get_d.c: Be more lax about relative error, to handle Cray + floating point format. + + * mpq/tests/t-get_d.c: Decrease default reps to 1000. + + * mpf/tests/t-conv.c: Correct type of `bexp'. + + * configure.in (cray vector machines): Don't inherit gmp_cflags_cc. + + * tune/Makefile.am (EXTRA_DIST): Delete sparc64.asm. + + * configure.in (cray vector machines): Set extra_functions. + + * mpn/cray/mulww.f: New file with vectorizing cray code. + * mpn/cray/mulww.s: Generated from mulww.f. + * mpn/cray/mul_1.c: New file. + * mpn/cray/addmul_1.c: New file. + * mpn/cray/submul_1.c: New file. + * mpn/cray/add_n.c: New file. + * mpn/cray/sub_n.c: New file. + +2000-06-26 Kevin Ryde + + * acinclude.m4 (GMP_CHECK_ASM_ALIGN_FILL_0x90): Fix so it actually + detects solaris 2.6, and also suppress warning on solaris 2.8. + * configure.in (SPEED_CYCLECOUNTER): Remove spurious "athlon" from + sparc case. + + * mpn/lisp/gmpasm-mode.el: Move keymap to the top of the docstring. + +2000-06-21 Kevin Ryde + + * mpn/generic/mul_n.c (mpn_kara_mul_n, mpn_kara_sqr_n): Use + mp_size_t for n2. + (mpn_toom3_mul_n, mpn_toom3_sqr_n): Use mp_size_t for size + parameters and "l" variables. + * gmp-impl.h (mpn_toom3_mul_n, mpn_toom3_sqr_n): Update prototypes. + + * mpbsd/itom.c, mpbsd/sdiv.c: Add casts for correct handling of + -0x80...00 on systems with sizeof(short)==sizeof(int). + + * mpz/tests/t-misc.c: Move "bin" test from here ... + * mpz/tests/t-bin.c: ... to here, and add a new (2k,k) test too. + * mpz/tests/Makefile.am (check_PROGRAMS): Add t-bin. + + * mpz/bin_ui.c [_LONG_LONG_LIMB]: Use mpn_divrem_1, since kacc is + a limb not a ulong. + * mpz/bin_uiui.c [_LONG_LONG_LIMB]: Ditto, and use mpn_mul_1 too, + since nacc is a limb. + + * mpf/tests/t-misc.c (check_mpf_set_si, check_mpf_cmp_si): + New file, testing mpf_set_si, mpf_init_set_si, and mpf_cmp_si. + * mpf/tests/Makefile.am (check_PROGRAMS): Add it. + + * mpz/tests/t-misc.c (check_mpz_set_si, check_mpz_cmp_si): + New tests, for mpz_set_si, mpz_init_set_si, and mpz_cmp_si. + + * mpz/set_si.c, mpz/iset_si.c, mpz/cmp_si.c [_LONG_LONG_LIMB]: Fix + handling of -0x80..00. + * mpf/set_si.c, mpf/iset_si.c, mpf/cmp_si.c [_LONG_LONG_LIMB]: Ditto. + +2000-06-19 Torbjorn Granlund + + * demos/primes.c: Properly handle arguments `m +n'. + +2000-06-17 Torbjorn Granlund + + * config.sub: Recognize k5 and k6 with common pattern. + + * mpq/tests/t-get_d.c: Also test mpq_set_d. Misc improvements. + + * mpq/set_d.c: Special case 0.0. Don't call mpn_rshift with 0 count. + Allocate correct amount of memory for numerator. Delete spurious + ASSERT_ALWAYS(1). + +2000-06-17 Kevin Ryde + + * mpz/perfsqr.c: Fix so that zero is considered a perfect square. + (Was wrongly calling mpn_perfect_square_p with size==0.) + +2000-06-16 Kevin Ryde + + * configure.in: Set k5*-*-* to use basic i386 code until there's + something specific. Add path=x86 as a default for x86s. + + * acinclude.m4 (GMP_CHECK_ASM_ALIGN_LOG): Generate + ALIGN_LOGARITHMIC setting, not a full ALIGN definition. + (GMP_CHECK_ASM_ALIGN_FILL_0x90): New test. + * configure.in [x86-*-*]: Use GMP_CHECK_ASM_ALIGN_FILL_0x90. + * mpn/asm-defs.m4 (ALIGN): New macro. + * mpn/x86/x86-defs.m4 (ALIGN): Remove supplementary definition. + + * tune/*: Plain "unsigned" for speed_cyclecounter. + * configure.in: Use tune/sparcv9.asm for 32 and 64 bit modes. + * tune/sparc64.asm: Remove file. + +2000-06-15 Torbjorn Granlund + + * mpn/x86/k7/mmx/copyi.asm: Use `testb' instead of `test'. + * mpn/x86/k7/mmx/copyd.asm: Likewise. + + * mpn/x86/k7/mmx/lshift.asm: Avoid using `~' (Solaris as problems). + * mpn/x86/k7/mmx/rshift.asm: Likewise. + * mpn/x86/k6/aors_n.asm: Likewise. + * mpn/x86/k7/aors_n.asm: Likewise. + * mpn/x86/k7/mul_basecase.asm: Likewise. + +2000-06-13 Torbjorn Granlund + + * tune/sparcv9.asm: Tune, deleting two instructions. + + * tune/alpha.asm: Update to unified speed_cyclecounter. + +2000-06-11 Kevin Ryde + + * mpz/tests/reuse.c (FAIL): Add a K&R version. + Use _PROTO on some typedefs. + * mpz/tests/t-misc.c: Add gmp-impl.h for "const". + + * configure.in: Rework mpn multi-function and optional files. + Names standardized, no need for explicit declarations, all picked + up in one $path traversal. + * doc/configuration: Updates. + + * tests/rand/t-rand.c (main): Change "usage" to work with K&R. + +2000-06-10 Kevin Ryde + + * mpn/x86/pentium/mmx/popham.asm, mpn/x86/p6/mmx/popham.asm, + mpn/x86/p6/p3mmx/popham.asm, mpn/x86/p6/diveby3.asm: Add + MULFUNC_PROLOGUE for correct HAVE_NATIVE_* matching. + + * mpn/x86/x86-defs.m4 (cmov_bytes_tttn): Use eval() on expressions. + (cmov_available_p): Switch to list CPUs which do have cmov. + * mpn/x86/p6/sqr_basecase.asm, mpn/x86/k6/sqr_basecase.asm, + mpn/x86/k7/sqr_basecase.asm: Use eval() for multiplication. + * mpn/x86/README.family: Various updates. + +2000-06-09 Kevin Ryde + + * mpbsd/tests/allfuns.c (main): Call exit() instead of doing return. + + * doc/tasks.html, doc/projects.html: Moved from projects directory. + * doc/multiplication: New file. + * Makefile.am (EXTRA_DIST): Remove projects, add doc. + + * Makefile.am (libgmp_la_LIBADD, libmp_la_LIBADD): Remove + unnecessary -lm. + * INSTALL: Remove -lm from instructions. + * demos/Makefile.am (qcn_LDADD): Add -lm. + + * tune/*: Add measuring for mpn_divrem_2 and modlimb_invert, + improve addsub_n. Switch to unified speed_cyclecounter. + * configure.in: Update configs for speed_cyclecounter. + + * gmp-impl.h (MP_LIMB_T_MAX, MP_LIMB_T_HIGHBIT): New macros. + * mpn/generic/diveby3.c, mpn/generic/mul_n.c, mpn/generic/gcd.c, + tune/speed.c, mpn/tests/ref.c: Use them. + + * mpn/tests/spinner.c: Remove setitimer, just alarm is enough. + * configure.in (AC_CHECK_FUNCS): Remove setitimer. + * mpn/tests/x86call.asm: Start with junk in %eax, %ecx, %edx. + * mpn/tests/ref.[ch] (refmpn_addsub_nc): New function. + * mpn/tests/try.c: Add some support for mpn_addsub_nc. + * mpn/tests/Makefile.am (EXTRA_PROGRAMS): Remove addsub_n and + addsub_n_2 which don't currently build. + * mpn/tests/copy.c: Test MPN_COPY_INCR, not __gmpn_copy. + + * tests/rand/Makefile.am (libstat_la_LIBADD): Add -lm, no longer on + libgmp.la. + (findlc_LDADD): Use libstat.la. + (AUTOMAKE_OPTIONS): Use ansi2knr. + +2000-06-08 Torbjorn Granlund + + * configure.in (alpha*-*-osf*): Default `flavour' to ev6 for ev6 and + higher. + (alpha*-*-*): Likewise. + (alpha*-*-osf*: gmp_optcflags_cc): Move -arch/-tune flags from + gmp_xoptcflags_gcc. + + * mpn/Makefile.am (TARG_DIST): Add pa64w. + + * longlong.h: Wrap 64-bit hppa code in #ifndef LONGLONG_STANDALONE. + +2000-06-07 Torbjorn Granlund + + * mpz/remove.c: Fail for `src' being zero. + + * mpz/tests/reuse.c: Test more functions. + (FAIL): New define. + + * mpz/tests/t-powm.c: Loop during operand generation while they + are mathematically ill-defined (used to just skip such tests). + + * mpz/powm.c (mpz_redc): Clean up argument declarations. + + * configure.in (gmp_cflags64_gcc): Don't add bogus -mWHAT option. + (sparcv9-*-solaris2.[7-9]], gmp_cflags64_gcc): + Inherit from previous gmp_cflags64_gcc; pass `-m64 -mptr64'. + (ia64*-*-*): New. + + * mpn/generic/dump.c: Make it work when an mp_limb_t is not `long'. + + * mpf/set_prc.c: MPN_COPY => MPN_COPY_INCR. + +2000-06-06 Torbjorn Granlund + + * mpn/generic/mul_n.c (mpn_toom3_mul_n, mpn_toom3_sqr_n): + Use mpn_incr_u for final carry propagation. + + * mpz/tests/t-gcd.c: Add calls to mpz_gcdext with argument t == NULL. + + * mpz/tests/reuse.c: Major rewrite; test many more functions. + + * mpz/powm_ui.c: When exp is 0, change res assign order in order + to handle argument overlap. + * mpz/powm.c: When exp is 0, change res assign order in order + to handle argument overlap. Handle negative exp and mod arguments. + + * mpz/gcdext.c: Rework code after mpn_gcdext call to handle + argument overlap. + + * mpz/fdiv_qr.c: Read dividend->_mp_size before calling mpz_tdiv_qr + in order to handle argument overlap. + * mpz/cdiv_qr.c: Likewise. + + * mpf/tests/reuse.c: Fix typo that effectively disabled `dis_funcs' + tests. Clean up test for mpf_ui_div. + +2000-06-06 Kevin Ryde + + * mpn/x86/p6/sqr_basecase.asm: New file. + * mpn/x86/mod_1.asm: Avoid one conditional jump. + * mpn/x86/p6/gmp-mparam.h: Update thresholds, #ifndef UMUL_TIME + and UDIV_TIME, add COUNT_TRAILING_ZEROS_TIME. + + * mp_minv_tab.c: New file. + * Makefile.am (libgmp_la_SOURCES, libmp_la_SOURCES): Add it. + * gmp-impl.h (modlimb_invert): New macro. + * mpz/powm.c: Remove mpz_dmprepare, use modlimb_invert instead. + * mpn/generic/bdivmod.c: Use modlimb_invert instead of a loop. + * mpn/generic/gcd.c: Inline two small mpn_bdivmod calls, use + MPN_COPY_INCR not MPN_COPY in one place. + +2000-06-05 Torbjorn Granlund + + * mpf/tests/reuse.c (dsi_funcs): Add mpf_mul_2exp and mpf_div_2exp. + (main): Clean up test for mpf_div_ui. + + * mpf/mul_2exp.c: Correct criterion for whether to use mpn_lshift or + mpn_rshift. MPN_COPY => MPN_COPY_INCR. Coerce the two assignments to + r->_mp_size. + + * mpf/div_2exp.c: Use mpn_rshift instead of mpn_lshift when overlap + so requires. MPN_COPY => MPN_COPY_INCR. + + * mpf/tests/t-dm2exp.c: Correct type of res_prec. + +2000-06-04 Kevin Ryde + + * mpz/bin_uiui.c: Fix result for n==0 and n==k. + * mpz/bin_ui.c: Fix result for k>n, add support for n<0. + * gmp.texi (Number Theoretic Functions): Update mpz_bin_ui to + note n<0 is supported. + + * mpz/tests/t-misc.c: New file. + * mpz/tests/Makefile.am (check_PROGRAMS): Add it. + +2000-05-31 Kevin Ryde + + * tune/speed.* (FLAG_R_OPTIONAL): New option for routines, use on + mpn_gcd_1 and mpn_mul_basecase. + * tune/README: Update. + + * tune/alpha.asm: New file, by Torbjorn. + * tune/Makefile.am (EXTRA_DIST): Add it. + * configure.in (alpha*-*-*): Use it. + +2000-05-31 Linus Nordberg + + * doc/configuration: New file. + +2000-05-30 Torbjorn Granlund + + * mpn/generic/mul_basecase.c: Call mpn_mul_2 and mpn_addmul_2 + if available. Don't include longlong.h. + + * doc/isa_abi_headache: New file. + +2000-05-30 Linus Nordberg + + * configure.in (NM): Use AC_PROG_NM rather than AC_CHECK_TOOL to + find `nm'. (AC_PROG_NM comes with Libtool and is needed to get + the `-B' option (BSD compatible output) included in $NM.) + (AR): Use AC_CHECK_PROG rather than AC_CHECK_TOOL to find `ar'. + (Now that NM isn't a cross compilation tool, don't give the + impression that we know how to cross compile.) + (CCAS): Remove spurious comment. + + * gmp.texi (Notes for Particular Systems): Remove comment about + using GNU `nm' on AIX since system nm now works. + +2000-05-29 Torbjorn Granlund + + * mpn/power/mul_1.s: Remove [PR] from first word in function + descriptor. + * mpn/power/addmul_1.s: Likewise. + * mpn/power/submul_1.s: Likewise. + +2000-05-28 Kevin Ryde + + * configure.in, tune/*: Change pentium rdtsc cycle scheme to + HAVE_SPEED_CYCLECOUNTER and SPEED_CYCLECOUNTER_OBJS. + * tune/pentium.asm: Renamed and converted from rdtsc.asm. + * tune/sparcv9.asm: New file, by Torbjorn. + * tune/sparc64.asm: New file. + * tune/tuneup.c: Put a limit on gcdext search. + + * gmp.h (mp_set_memory_functions): Add extern "C". + * mp.h (__GNU_MP__): Bump to "3". + * mpz/add.c,mul.c,powm.c,sub.c,sqrtrem.c,tdiv_qr.c [BERKELEY_MP]: + Include mp.h for mpbsd compile. + * mpz/gcd.c: Ditto, and remove _mpz_realloc declaration. + + * gmp.texi (Integer Functions): Flatten @subsections into @sections. + (Floating-point Functions): Ditto. + (Integer Random Numbers): Split from miscellaneous as a sep section. + (Installing GMP): Make nodes for the sections. + Add more "@cindex"s. + (Known Build Problems): Remove SunOS get_d problem, believed fixed. + (Notes for Particular Systems): Remove HPPA note since now PIC. + (References): URL for Jebelean. + +2000-05-27 Torbjorn Granlund + + * mpn/pa64w: New directory, contents based on corresponding mpn/pa64 + files. + * configure.in (hppa2.0w-*-*): New. + * mpz/tests/io.c (_INCLUDE_POSIX_SOURCE): Define when __hpux before + including stdio.h. + * gmp-impl.h: Always define DItype and UDItype. + +2000-05-27 Kevin Ryde + + * tune/common.c (speed_measure): Correction to array sorting, + better diagnostic when measuring fails. + * tune/time.c: Add microsecond accurate getrusage method. + + * tune/time.c (speed_cpu_frequency_processor_info): New function. + * configure.in (AC_CHECK_FUNCS): Add processor_info. + +2000-05-26 Linus Nordberg + + * gmp.texi (Installing GMP): Shared libraries work for AIX < 4.3 + if using GNU nm. + +2000-05-26 Torbjorn Granlund + + * tune/tuneup.c (SIGNED_TYPE_MAX): Shift `-1' instead of `1' to + avoid signed overflow. + + * demos/pexpr.c (setup_error_handler): Don't call sigaltstack on + Unicos. + +2000-05-25 Torbjorn Granlund + + * insert-dbl.c: Work around GCC 2.8 bug. + * extract-dbl.c: Likewise. + + * config.sub: Allow i586, i686, i786 again. + + * config.guess: Use X86CPU for lots more systems. + +2000-05-25 Linus Nordberg + + * mpbsd/tests/dummy.c (main): Call exit() instead of doing return + (some old SysV machines don't get this correct, I've heard.) + +2000-05-25 Kevin Ryde + + * mpf/iset_str.c: Initialize _mp_size and _mp_exp to 0, in case no + digits in string, so it's the same as a separate init and set_str. + +2000-05-24 Torbjorn Granlund + + * mpz/tests/reuse.c: Use mpz_random2 instead of mpz_random. + + * mpz/divexact.c: Read pointers after reallocation. + Compare `quot' and `den' instead of `qp' and `dp' in overlap check. + Use MPN_COPY_INCR for copying from `np'. + + (*-*-aix4.[3-9]*): Disable shared libs just for problematic AIX + versions. + * configure.in (*-cray-unicos*): Disable asm syntax checking; set + compiler explicitly. + * configure.in (hppa*-*-*): Remove code disabling shared libs. + +2000-05-24 Linus Nordberg + + * acinclude.m4 (GMP_PROG_CC_WORKS): Don't report progress to user + when doing the AIX specific test to avoid "nested output". + +2000-05-22 Kevin Ryde + + * mp.h (_PROTO): Copy from gmp.h, use on prototypes. + Add extern "C" too. + * mpbsd/tests/Makefile.am (AUTOMAKE_OPTIONS): Enable ansi2knr. + * mpbsd/tests/allfuns.c: Don't execute mout, just link to it. + (main): ANSI style definition. + + * gmp-impl.h (MP_BASE_AS_DOUBLE): Change the expression to + something that works on SunOS native cc. Seems to fix the + mp*_get_d problems. + + * mpn/tests/ref.c (refmpn_strip_twos): Use MPN_COPY_INCR. + * mpn/tests/Makefile.am: Let .asm.o rules work with absolute $srcdir. + +2000-05-21 Kevin Ryde + + * mpn/x86/k7/sqr_basecase.asm: Replace file with K7 specific code. + * mpn/x86/k7/README: Update. + * mpn/x86/k7/gmp-mparam.h: Tune thresholds. + (COUNT_TRAILING_ZEROS_TIME): New define. + * mpn/x86/k6/gmp-mparam.h: Ditto. + + * mpn/x86/pentium/mmx/popham.asm: New file (include_mpn of K6 version). + * mpn/x86/p6/diveby3.asm: New file (include_mpn of P5 version). + * mpn/x86/p6/mmx/popham.asm: New file (include_mpn of K6 version). + * mpn/x86/p6/p3mmx/popham.asm: New file (include_mpn of K7 version). + * configure.in (pentium3-*-*): Add p3mmx to $path. + + * gmp.texi (Integer Arithmetic): Clarify mpz_jacobi op2; add + mpz_*_kronecker_*. + (Miscellaneous Integer Functions): Add mpz_odd_p and mpz_even_p. + (Low-level Functions): Put mpn_divmod_1 with mpn_divrem_1 and note + it's now a macro. + (References): Add Henri Cohen. + + * gmp.h (mpn_addmul_1c, mpn_divrem_1c, mpn_mod_1c, mpn_mul_1c, + mpn_submul_1c): Add prototypes. + (mpz_odd_p, mpz_even_p): New macros. + + * mpn/asm-defs.m4 (m4wrap_prepend): New macro. + (m4_error): Use it. + (m4_not_for_expansion): Corrections to OPERATION symbols. + More comments about variations between m4 versions. + * mpn/x86/x86-defs.m4 (PROLOGUE): Use m4wrap_prepend (fixes error + exit under BSD m4, previously m4_error printed the message but the + exit code was 0). + + * gmp.h (mpn_divmod_1): Change to a macro calling mpn_divrem_1. + * mpn/generic/divrem_1.c: Move divmod_1.c code to here, make it + static and call it __gmpn_divmod_1_internal. + * mpn/generic/divmod_1.c: Remove file. + * configure.in (gmp_mpn_functions): Remove divmod_1. + * mpn/asm-defs.m4 (define_mpn): Remove divmod_1 and divmod_1c. + * compat.c (mpn_divmod_1): Add compatibility function. + * tune/*: Remove mpn_divmod_1 measuring (leave just divrem_1). + + * acconfig.h (HAVE_NATIVE_mpn_*): Add some missing carry-in + variants, remove divmod_1. + + * mpn/x86/diveby3.asm: Use imul, update comments. + + * demos/qcn.c: New file. + * demos/Makefile.am (EXTRA_PROGRAMS): Add it. + + * mpz/tests/t-jac.c: New file. + * mpz/tests/Makefile.am (check_PROGRAMS): Add it. Enable ansi2knr. + + * mpz/kronsz.c: New file. + * mpz/kronuz.c: New file. + * mpz/kronzs.c: New file. + * mpz/kronzu.c: New file. + * mpz/Makefile.am (libmpz_la_SOURCES): Add them. + * Makefile.am (MPZ_OBJECTS): Add them. + * gmp-impl.h (JACOBI_*, MPN_STRIP_LOW_ZEROS_NOT_ZERO): New macros. + * gmp.h (mpz_*_kronecker_*): New defines and prototypes. + + * mpn/generic/jacbase.c: New file. + * mpn/generic/mod_1_rs.c: New file. + * configure.in (gmp_mpn_functions): Add them. + * gmp.h (mpn_jacobi_base, mpn_mod_1_rshift): New defines and + prototypes. + * longlong.h (COUNT_TRAILING_ZEROS_TIME): New define. + * mpn/tests/ref.c (refmpn_mod_1_rshift): New function. + * mpn/tests/try.c: Add mpn_mod_1_rshift. + * tune/*: Add measuring for mpn_jacobi_base. + + * acinclude.m4 (GMP_FINISH): Add ifdefs to allow multiple + inclusion of config.m4. + (GMP_PROG_M4): Put "good" message through to config.log. + + * mpz/powm.c: Use a POWM_THRESHOLD for where redc stops. + * tune/*: Add mpz_powm measuring, and tune POWM_THRESHOLD. + * gmp-impl.h [TUNE_PROGRAM_BUILD] (POWM_THRESHOLD): Conditional + redefinition for use when tuning. + + * mpz/powm_ui.c: Use DIVIDE_BY_ZERO. + + * mpz/iset_str.c: Initialize _mp_size to 0, in case no digits in + string; this makes it the same as a separate init and set_str. + +2000-05-20 Kevin Ryde + + * mpn/asm-defs.m4: Note &,|,^ aren't bitwise in BSD m4 eval(). + * mpn/x86/k6/sqr_basecase.asm: Use "%" not "&" in m4 eval()s. + + * mpn/x86/x86-defs.m4 (Zdisp): Yet more instruction forms. + +2000-05-19 Linus Nordberg + + * acinclude.m4 (GMP_CHECK_CC_64BIT): Don't use shell variable + `ac_compile' for our own compile command string since other + Autoconf macros may depend on it. + +2000-05-19 Kevin Ryde + + * mpn/generic/mul_n.c (mpn_toom3_mul_n, mpn_toom3_sqr_n): Fix + carry propagation in final coefficient additions. + +2000-05-18 Linus Nordberg + + * configure.in: Set NM before looking for compiler since + GMP_CHECK_CC_64BIT needs it. + + * acinclude.m4 (GMP_CHECK_CC_64BIT): Don't execute on target. + (GMP_PROG_CC_FIND): Before checking if the compiler knows how to + produce 64-bit code, verify that it works at all. The background + is that /usr/ucb/cc on Solaris 7 successfully compiles in 64-bit + mode but fails when doing final link. + (GMP_PROG_CC_WORKS): Report to user what's happening. + +2000-05-17 Linus Nordberg + + * config.guess: Use X86CPU for x86 Cygwin. + +2000-05-16 Kevin Ryde + + * mpn/x86/p6/mmx/divrem_1.asm: New file. + * mpn/x86/p6/mmx/mod_1.asm: New file. + * mpn/x86/p6/README: Update. + * mpn/x86/divrem_1.asm: Update comments. + * mpn/x86/mod_1.asm: Ditto. + +2000-05-14 Kevin Ryde + + * tune/speed.h: Run gcd functions on a set of data. + + * mpn/tests/try.c: New file. + * mpn/tests/try.h: New file. + * mpn/tests/spinner.c: New file. + * mpn/tests/trace.c: New file. + * mpn/tests/x86call.asm: New file. + * mpn/tests/x86check.c: New file. + * mpn/tests/ref.c (refmpn_hamdist): Allow size==0. + (refmpn_gcd): New function, and other additions supporting it. + * mpn/tests/ref.h: More prototypes. + * mpn/tests/Makefile.am: Add try program, use ansi2knr. + + * mpn/x86/k7/mmx/popham.asm: New file. + * mpn/x86/k6/mmx/popham.asm: New file. + * mpn/x86/k6/sqr_basecase.asm: Unroll the addmul, for approx 1.3x + speedup above 15 limbs. + * mpn/x86/k7/README: Update. + * mpn/x86/k6/README: Update, and add notes on plain K6 and pre-CXT + K6-2 problems. + * configure.in (k6*-*-*, athlon-*-*): Add popham. + + * mpn/x86/pentium/diveby3.asm: New file. + * mpn/x86/pentium/README: Update. + + * gmp.texi (Installing GMP): Add note on bad OpenBSD 2.6 m4. + (Reporting Bugs): Ask for config.m4 if asm file related. + (I/O of Rationals): New section, add mpq_out_str. + (References): Add url for on-line gcc manuals. + A few node and menu updates. + + * INSTALL: Better command line argument checking for test progs. + Change MP -> GMP. + + * configure.in (WANT_ASSERT, USE_STACK_ALLOC, HAVE_PENTIUM_RDTSC): + Put descriptions here, not in acconfig.h. + (CALLING_CONVENTIONS_OBJS): New AC_SUBST (for mpn/tests/try). + (HAVE_CALLING_CONVENTIONS): New AC_DEFINE. + (AC_CHECK_HEADERS): Add sys/time.h. + (AC_CHECK_FUNCS): Add getpagesize, setitimer. + (KARATSUBA_SQR_THRESHOLD): Strip trailing comments from the + #define when passing through to config.m4. + * acconfig.h (PACKAGE, VERSION, WANT_ASSERT, USE_STACK_ALLOC, + HAVE_PENTIUM_RDTSC): No need for #undefs, autoheader gets them + from configure.in. + + * acinclude.m4 (GMP_PROG_M4): Check for broken OpenBSD 2.6 m4 + eval(), put messages into config.log. + * mpn/asm-defs.m4: Add notes and test for OpenBSD 2.6 m4. + + * mpq/out_str.c: New file. + * mpq/Makefile.am (libmpq_la_SOURCES): Add it. + * Makefile.am (MPQ_OBJECTS): Ditto. + * gmp.h (mpq_out_str): New define and prototype. + +2000-05-12 Kevin Ryde + + * configure.in (CONFIG_TOP_SRCDIR): Fix to use $srcdir not + $top_srcdir (which doesn't exist). + * acinclude.m4 (GMP_C_ANSI2KNR): Fix setting U=_. + * gmp-impl.h (mpn_com_n, MPN_LOGOPS_N_INLINE): Fix missing "do" + (not currently used, probably no ill effect anyway). + +2000-05-11 Torbjorn Granlund + + * randraw.c (lc): Major overhaul (pending rewrite). + (_gmp_rand): Rewrite. + +2000-05-08 Torbjorn Granlund + + * mpz/tests/convert.c: Call free via _mp_free_func. + * mpf/tests/t-conv.c: Likewise. + + * memory.c: Add code enabled for DEBUG that adds special patterns + around allocated blocks. + +2000-05-05 Linus Nordberg + + * gmp.texi (Miscellaneous Float Functions): Correct parameter list + for mpf_urandomb(). + + * configure.in: Invoke AC_REVISION. + +2000-05-05 Kevin Ryde + + * gmp.texi: Use @dircategory and @direntry. + (Installing GMP): Clarification for --target, updates on SunOS + problems. + (Integer Arithmetic): Add mpz_mul_si. + (Initializing Rationals): Add mpq_swap. + (Assigning Floats): Add mpf_swap. + (Low-level Functions): Add mpn_divexact_by3c, and details of what + the calculation actually gives. + (Low-level Functions): Note extra space needed by mpn_gcdext, + clarify the details a bit. + + * compat.c: New file, entry points for upward binary compatibility. + (mpn_divexact_by3): Compatibility function. + * Makefile.am (libgmp_la_SOURCES): Add compat.c. + + * mpn/tests/ref.c: Rearrange macros for ansi2knr. + (div1): Renamed from div to avoid library function. + (refmpn_divexact_by3c, refmpn_gcd_1, refmpn_popcount, + refmpn_hamdist): New functions. + * mpn/tests/ref.h: Add extern "C", add new prototypes. + + * gmp.h (gmp_randinit, etc): Add extern "C". + (_mpq_cmp_ui): Fix prototype name from mpq_cmp_ui. + (mpn_divexact_by3): Now a macro calling mpn_divexact_by3c. + (mpn_divexact_by3c): New prototype and define. + + * mpn/x86/diveby3.asm: Change to mpn_divexact_by3c. + * mpn/x86/k6/diveby3.asm: Ditto. + * mpn/generic/diveby3.c: Ditto. + * mpn/asm-defs.m4: Ditto on the define_mpn. + * acconfig.h (HAVE_NATIVE_mpn_divexact_by3c): New define. + + * mpq/swap.c: New file, derived from mpz/swap.c. + * mpf/swap.c: Ditto. + * mpq/Makefile.am: Add swap.c. + * mpf/Makefile.am: Ditto. + * Makefile.am: Add two new "swap.lo"s. + + * mpn/x86/k6/mmx/com_n.asm: Fix an addressing bug (fortunately + this code hasn't been used anywhere yet). + + * mpn/x86/k7/mmx/divrem_1.asm: New file. + * mpn/x86/k7/mmx/mod_1.asm: New file. + * mpn/x86/k7/diveby3.asm: New file. + * mpn/x86/k7/README: Update. + + * mpn/x86/k7/aorsmul_1.asm: Use new cmovCC, no object code change. + * mpn/x86/k7/mul_basecase.asm: Ditto. + * mpn/x86/p6/aorsmul_1.asm: Ditto. + + * mpn/x86/x86-defs.m4 (defframe_empty_if_zero): Eval the argument. + (cmovCC): New macros, replacing individual cmovCC_reg_reg forms. + (Zdisp): Recognise more instructions. + (shldl,etc): Use m4_instruction_wrapper(). + (ASSERT, movl_text_address): New macros. + + * mpn/asm-defs.m4: Add remarks on SunOS /usr/bin/m4 and new + OpenBSD m4. + (m4_assert_numargs_internal_check): Remove a spurious parameter. + (m4_empty_if_zero): Eval the argument. + (m4_assert, m4_assert_numargs_range, m4_config_gmp_mparam, + m4_instruction_wrapper): New macros. + +2000-05-04 Linus Nordberg + + * gmp.texi (Reporting Bugs): Be explicit about output from running + a command. + +2000-05-02 Torbjorn Granlund + + * mpn/generic/bz_divrem_n.c (mpn_bz_divrem_n): Handle non-zero return + from first mpn_bz_div_3_halves_by_2 call. + (mpn_bz_divrem_aux): Likewise. + +2000-04-30 Kevin Ryde + + * tune/* (GCD_ACCEL_THRESHOLD, GCDEXT_THRESHOLD): Tune these. + + * mpn/generic/gcdext.c (GCDEXT_THRESHOLD): Rename from THRESHOLD, + use with >=, adjust default to 17 accordingly. + Use new *_SWAP macros. + + * mpn/generic/gcd.c (GCD_ACCEL_THRESHOLD): Rename from + ACCEL_THRESHOLD, use with >=, adjust default to 5 accordingly. + Use new *_SWAP macros. + + * mpf/get_str.c, mpf/set_str.c, mpf/sub.c, mpz/add.c, mpz/ior.c, + mpz/and.c, mpz/sub.c, mpz/xor.c, mpz/ui_pow_ui.c, + mpn/generic/mul.c: Use new *_SWAP macros. + + * stack-alloc.h: Add extern "C" around prototypes. + + * gmp-impl.h: (MP_PTR_SWAP, etc): New macros. + (_mp_allocate_func, etc): Use _PROTO. + [TUNE_PROGRAM_BUILD]: More changes in tune program build part. + +2000-04-28 Torbjorn Granlund + + * mpn/pa64/add_n.s: Add `,entry' to export directive. + * mpn/pa64/addmul_1.S, mpn/pa64/lshift.s, mpn/pa64/mul_1.S, + mpn/pa64/rshift.s, mpn/pa64/sub_n.s, mpn/pa64/submul_1.S, + mpn/pa64/umul_ppmm.S: Likewise. + * mpn/hppa/hppa1_1/udiv_qrnnd.S: New name for udiv_qrnnd.s. + Add PIC support. + +2000-04-29 Kevin Ryde + + * gmp-impl.h [TUNE_PROGRAM_BUILD] (TOOM3_MUL_THRESHOLD_LIMIT): New + define. + * mpn/generic/mul_n.c [TUNE_PROGRAM_BUILD] (mpn_mul_n): Use + TOOM3_MUL_THRESHOLD_LIMIT, not a hard coded 500. + + * memory.c: Use for malloc etc, and use _PROTO. + * stack-alloc.c: Don't use C++ reserved word "this". + * urandom.h: Put extern "C" around prototypes. + * mpz/powm.c: Switch a couple of parameters to "const", which they + are, to satisfy g++. + + * randraw.c, stack-alloc.c, mpbsd/mout.c, mpbsd/mtox.c: Add casts to + help g++. + + * stack-alloc.c: Provide dual ANSI/K&R function definitions. + * mpz/addmul_ui.c,get_d.c,inp_str.c,perfpow.c,powm.c,pprime_p.c, + rrandomb.c,set_str.c,ui_pow_ui.c: Ditto. + * mpf/integer.c,set_str.c: Ditto. + * mpbsd/min.c,xtom.c: Ditto. + * mpn/generic/bz_divrem_n.c,dump.c,gcd_1.c,get_str.c,hamdist.c, + popcount.c,random.c,random2.c,set_str.c: Ditto. + + * rand.c: Use for NULL. + * mpz/gcd_ui.c,gcdext.c,mul.c,perfpow.c,powm_ui.c,root.c,sqrt.c, + sqrtrem.c: Ditto + * mpf/sqrt.c,sqrt_ui.c: Ditto. + * mpn/generic/perfsqr.c,sqrtrem.c: Ditto. + + * gmp-impl.h (NULL, malloc, realloc, free): Don't define/declare. + (extern "C"): Add around function prototypes. + (mpn_kara_mul_n, mpn_kara_sqr_n, mpn_toom3_mul_n, mpn_toom3_sqr_n): + Add prototypes. + [TUNE_PROGRAM_BUILD] (FIB_THRESHOLD): Add necessary redefinitions for + use by tune program. + * mpn/generic/mul_n.c: Remove mpn_toom3_mul_n prototype. + + * acinclude.m4 (GMP_C_ANSI2KNR): New macro. + (GMP_CHECK_ASM_MMX, GMP_CHECK_ASM_SHLDL_CL): Fix to use + $gmp_cv_check_asm_text which is what GMP_CHECK_ASM_TEXT sets. + * configure.in (GMP_C_ANSI2KNR): Use this instead of AM_C_PROTOTYPES, + for reasons described with its definition. + + * demos/Makefile.am (ansi2knr): Use $(top_builddir) nor $(top_srcdir). + + * mpz/fib_ui.c (FIB_THRESHOLD): Rename from FIB_THRES, for consistency. + (FIB_THRESHOLD): Conditionalize so gmp-mparam.h can define a value. + (mpz_fib_bigcase): Use >= FIB_THRESHOLD, same as main mpz_fib_ui. + * tune/tuneup.c,Makefile.am (FIB_THRESHOLD): Tune this. + + * configure.in (*-*-aix* gmp_m4postinc): Fix setting (don't overwrite + a value just stored). + +2000-04-26 Kevin Ryde + + * mpn/sparc32/udiv_fp.asm: Use mpn_udiv_qrnnd macro. + * mpn/sparc32/udiv_nfp.asm: Ditto. + * mpn/sparc32/v8/supersparc/udiv.asm: Ditto. + * mpn/sparc32/umul.asm: Name the function mpn_umul_ppmm. + * mpn/sparc32/v8/umul.asm: Ditto. + * mpn/powerpc32/umul.asm: Ditto. + + * mpn/x86/syntax.h: Remove file, since now unused. + + * configure.in (x86): Remove -DBROKEN_ALIGN and -DOLD_GAS + previously used by .S files. + (x86 extra_functions): Add udiv and umul. + (GMP_PROG_M4): Use this instead of AC_CHECK_PROG(M4,m4,...) + (HAVE_NATIVE_*): Loosen up the regexp to "PROLOGUE.*" so as to + accept PROLOGUE_GP on alpha. + + * acconfig.h (HAVE_NATIVE_mpn_umul_ppmm, udiv_qrnnd, invert_limb): + New template defines. + * mpn/asm-defs.m4 (mpn_umul_ppmm, mpn_udiv_qrnnd): New define_mpn()s. + * longlong.h (umul_ppmm, udiv_qrnnd): Use a library version if + it's available and an asm macro isn't. + * gmp-impl.h (invert_limb): Ditto. + + * gmp-impl.h (ASSERT_NOREALLOC): Not a good idea, remove it. + + * acinclude.m4 (GMP_PROG_M4): New macro. + +2000-04-25 Linus Nordberg + + * gmp.texi (Random State Initialization): Correct arguments to + `gmp_randinit'. + + * acinclude.m4 (GMP_VERSION): Change `eval' --> `m4_eval'. Fix + from Kevin. + * aclocal.m4: Regenerate. + +2000-04-25 Kevin Ryde + + * mpn/x86/aors_n.asm: Remove parentheses around an immediate that + Solaris "as" doesn't like, change by Torbjorn. + +2000-04-24 Kevin Ryde + + * configure.in (AC_CHECK_FUNCS): Add strtoul. + + * mpn/generic/mul_n.c [TUNE_PROGRAM_BUILD] (mpn_mul_n): Bigger + array for karatsuba temporary space for tune program build. + (mpn_toom3_sqr_n) Remove an unused variable. + + * demos/Makefile.am (AUTOMAKE_OPTIONS): Add ansi2knr. + Add "allprogs:" pseudo-target. + * demos/factorize.c, demos/isprime.c: Switch to ANSI functions, + rely on ansi2knr. + + * gmp.texi (Getting the Latest Version of GMP): Add reference to + ftp.gnu.org mirrors list. + * INSTALL: Add arg count check to example programs. + + * mpn/x86/*/*.asm: Convert to FORTRAN ... or rather to + FORTRAN-style "C" commenting to support Solaris "as". + * mpn/x86/x86-defs.m4: Ditto, and add another Zdisp insn. + * mpn/asm-defs.m4 (C): Update comments. + * mpn/x86/README.family: Add a note on commenting, remove + description of .S files. + + * mpn/sparc64/addmul_1.asm, mul_1.asm, submul_1.asm: Use + include_mpn(). + +2000-04-23 Torbjorn Granlund + + * config.sub: Merge with FSF version of April 23. + + * mpn/powerpc32: Use dnl/C instead of `#' for comments. + + * config.guess: Get "model" limit between pentium 2 and pentium3 right. + Get rid of code determining `_' prefix; use double labels instead. + * config.guess: Partially merge with FSF version of April 22. + (Don't bring over NetBSD changes for now.) + +2000-04-23 Kevin Ryde + + * tune/Makefile.am, tune/README, tune/common.c, tune/rdtsc.asm, + tune/speed.c, tune/speed.h, tune/time.c, tune/tuneup.c: New files. + * tune/Makefile.in: New file, generated from Makefile.am. + + * gmp-impl.h (ASSERT_NOREALLOC,TMP_ALLOC_LIMBS): New macros. + [TUNE_PROGRAM_BUILD] Further mods for tune program builds. + + * mpz/Makefile.am: Add -DOPERATION_$* for new mul_siui.c. + Add rules to build mul_si and mul_ui from a common mul_siui.c. + * mpz/mul_siui.c: New file, derived from and replacing mul_ui.c. + * gmp.h (mpz_mul_si): New prototype and define. + + * mpn/tests/*.c [__i386__] (CLOCK): Don't use floating point in + CLOCK because cpp can't handle floats in #if's (TIMES is derived + from CLOCK by default). + + * mpn/asm-defs.m4 (include_mpn): New macro. + (m4_assert_numargs) Changes to implementation. + + * mpf/Makefile.am: Add -DOPERATION_$* for new integer.c. + Remove explicit rules for floor.o etc. + * mpf/integer.c: Use OPERATION_$* for floor/ceil/trunc. + + * mpn/Makefile.am: Put "tests" in SUBDIRS. + * mpn/tests/Makefile.am: New file providing rules to build test + programs, nothing done in a "make all" or "make check" though. + * mpn/tests/README: New file. + + * acconfig.h (HAVE_PENTIUM_RDTSC): New define. + + * configure.in (x86): Rearrange target cases. + Add mulfunc aors_n and aorsmul_1 for x86 and pentium (now all x86s). + Remove asm-syntax.h generation not needed. + Remove now unused family=x86. + (sparc) Remove unused family=sparc. + (HAVE_PENTIUM_RDTSC) New AC_DEFINE and AM_CONDITIONAL. + (AM_C_PROTOTYPES) New test, supporting ansi2knr. + (AC_CHECK_HEADERS) Add getopt.h, unistd.h and sys/sysctl.h for + tune progs. + (AC_CHECK_FUNCS) Add getopt_long, sysconf and sysctlbyname for + tune progs. + (config.m4 CONFIG_TOP_SRCDIR) Renamed from CONFIG_SRCDIR. + (config.m4 asm-defs.m4) Use CONFIG_TOP_SRCDIR and include(). + (gmp_m4postinc) Use include_mpn(). + (gmp_links) Omit asm-defs.m4/asm.m4 and gmp_m4postinc's. + (MULFUNC_PROLOGUE) Fix regexps so all functions get AC_DEFINE'd. + (PROLOGUE) Ditto (native copyi and copyd were unused in gmp 3). + (KARATSUBA_SQR_THRESHOLD) Copy from gmp-mparam.h into config.m4. + (AC_OUTPUT) Add tune/Makefile, mpn/tests/Makefile. + + * Makefile.am (AUTOMAKE_OPTIONS): Add ansi2knr. + (SUBDIRS): Add tune, reorder directories. + (MPZ_OBJECTS): Add mpz/mul_si.lo. + (libmp_la_SOURCES): Use this for top-level objects, not .lo's. + * ansi2knr.c, ansi2knr.1: New files, provided by automake. + + * mpn/x86/aors_n.asm: Convert add_n.S and sub_n.S to a + multi-function aors_n.asm, no object code change. + * mpn/x86/pentium/aors_n.asm: Ditto. + * mpn/x86/aorsmul_1.asm: Ditto for addmul/submul. + * mpn/x86/pentium/aorsmul_1.asm: Ditto. + + * mpn/x86/lshift.asm, mpn/x86/mul_1.asm, mpn/x86/mul_basecase.asm, + mpn/x86/rshift.asm: Convert from .S, no object code change. + * mpn/x86/pentium/lshift.asm, mpn/x86/pentium/mul_1.asm, + mpn/x86/pentium/mul_basecase.asm, mpn/x86/pentium/rshift.asm: Ditto. + + * gmp.texi (Reporting Bugs): Itemize the list of things to include. + (Miscellaneous Float Functions): Correct typo in mpf_ceil etc + argument types. + Change @ifinfo -> @ifnottex for benefit of makeinfo --html. + Remove unnecessary @iftex's around @tex. + +2000-04-22 Torbjorn Granlund + + * config.guess: Generalize x86 cpu determination code. + Now works on Solaris. + + * mpz/nextprime.c: Rewrite still disabled code. + + * configure.in: Specifically match freebsd[3-9]. + +2000-04-21 Torbjorn Granlund + + * rand.c: Call mpz_clear for otherwise leaking mpz_t. + + * mpz/pprime_p.c (mpz_probab_prime_p): Merge handling of negative + n into code for handling small positive n. Merge variables m and n. + After dividing, simply call mpz_millerrabin. + (isprime): Local variables now use attribute `long'. + (mpz_millerrabin): New static function, based on code from + mpz_probab_prime_p. + (millerrabin): Now simple workhorse for mpz_millerrabin. + +2000-04-19 Torbjorn Granlund + + * gmp-impl.h: Fix parenthesis error in test for __APPLE_CC__. + +2000-04-18 Linus Nordberg + + * NEWS: Add info about shared libraries. Remove reference to + gmp_randinit_lc. + +2000-04-17 Torbjorn Granlund + + * Version 3.0 released. + + * mpn/arm/add_n.S: New version from Robert Harley. + * mpn/arm/addmul_1.S: Likewise. + * mpn/arm/mul_1.S: Likewise. + * mpn/arm/sub_n.S: Likewise. + + * gmp.h (__GNU_MP_VERSION_PATCHLEVEL): Now 0. + +2000-04-17 Linus Nordberg + + * configure.in (hppa2.0*-*-*): Pass `+O3' to cc/c89 in 64-bit mode + to avoid compiler bug. + (ns32k*-*-*): Fix typo in path. Change by Kevin. + (alpha*-*-osf*): New case. Pass assembly flags for architecture + to gcc. + (alpha*-*-*): Don't bother searching for cc. + * configure: Regenerate. + + * Makefile.am (EXTRA_DIST): Add `macos', `.gdbinit'. + * Makefile.in: Regenerate. + * mpn/Makefile.am (EXTRA_DIST): Add `m88k', `lisp'. + * mpn/Makefile.in: Regenerate. + +2000-04-16 Kevin Ryde + + * README: Updates, and don't duplicate the example in INSTALL. + * INSTALL: Minor updates. + * gmp.texi (Installing MP): Minor edits, restore CC/CFLAGS description. + +2000-04-16 Linus Nordberg + + * configure.in (*-*-cygwin*): Select BSD_SYNTAX to avoid + .type/.size in PROLOGUE for ELF_SYNTAX. Override ALIGN definition + from x86/syntax.h. + (gmp_xoptcflags_${CC}): New set of variables, indicating + ``exclusive optional cflags''. + (most sparcs): Use gmp_xoptcflags instead of gmp_optcflags to + ensure that we pass CPU type to older gcc. + (CFLAGS): CFLAGS on the command line was spoiled. + * configure: Regenerate. + +2000-04-16 Linus Nordberg + + * configure.in: Invoke AC_PROG_LIBTOOL directly. + + * acinclude.m4 (GMP_PROG_CC_FIND): Quote source variable when + setting CC64 and CFLAGS64. + (GMP_PROG_CC_SELECT): Cache result. + (GMP_PROG_LIBTOOL): Remove. + + * aclocal.m4: Regenerate. + * configure: Regenerate. + +2000-04-16 Linus Nordberg + + * tests/rand/t-rand.c (main): Add non-ANSI function declaration. + Don't use `const'. + +2000-04-16 Torbjorn Granlund + + * mpn/generic/dump.c: Suppress output of leading zeros. + + * mpz/inp_str.c: Fix memory leakage. + + * mpz/tests/reuse.c (dss_func_division): Add a final 1. + + * longlong.h (alpha count_leading_zeros): Wrap in __MPN. + * mpn/alpha/cntlz.asm: Use __gmpn prefix (by means of __MPN). + + * longlong.h (__umul_ppmm, __udiv_qrnnd): Wrap in __MPN. + * mpn/alpha/udiv_qrnnd.S: Use __gmpn prefix. + * mpn/hppa/udiv_qrnnd.s: Likewise. + * mpn/hppa/hppa1_1/udiv_qrnnd.s: Likewise. + * mpn/pa64/udiv_qrnnd.c: Likewise (by means of __MPN). + * mpn/pa64/umul_ppmm.S: Likewise. + * mpn/sparc32/udiv_fp.asm: Likewise (by means of MPN). + * mpn/sparc32/udiv_nfp.asm: Likewise (by means of MPN). + * mpn/sparc32/v8/supersparc/udiv.asm: Likewise (by means of MPN). + + * mpn/generic/tdiv_qr.c: Work around gcc 2.7.2.3 i386 register handling + bug. + + * mpn/generic/tdiv_qr.c: Use udiv_qrnnd instead of mpn_divrem_1 + when computing appropriate quotient; mpn_divrem_1 writes too + many quotient limbs. + + * mpn/asm-defs.m4: invert_normalized_limb => invert_limb. + * mpn/alpha/invert_limb.asm: mpn_invert_normalized_limb => + mpn_invert_limb. + * gmp.h: Likewise. + * gmp-impl.h (alpha specific): invert_normalized_limb => invert_limb; + wrap with __MPN. + * longlong.h (alpha udiv_qrnnd): Likewise. + +2000-04-16 Kevin Ryde + + * gmp.h (mp_set_memory_functions,mp_bits_per_limb,gmp_errno): Add + #defines so the library symbols are __gmp_*. + * errno.c: Include gmp.h. + * gmp-impl.h (_mp_allocate_func,etc): Add #defines to __gmp_*. + (__clz_tab): New #define to __MPN(clz_tab). + * stack-alloc.c (__gmp_allocate_func,etc): Change from _mp_*. + + * Makefile.am (libmp_la_DEPENDENCIES): Add some mpz files needed + for new mpz_powm (pow in libmp). + (EXTRA_DIST): Add projects directory. + + * mpn/*: Change __mpn to __gmpn. + * gmp.h (__MPN): Ditto. + * stack_alloc.c,stack-alloc.h: Change __tmp to __gmp_tmp. + + * mpn/generic/sb_divrem_mn.c (mpn_sb_divrem_mn): Avoid gcc 2.7.2.3 + i386 register handling bug (same as previously in mpn_divrem_classic). + + * mpn/generic/divrem.c: Now contains mpn_divrem, which is not an + internal function, so remove warning comment. + + * gmp.texi (Compatibility with Version 2.0.x): Source level only. + +2000-04-16 Linus Nordberg + + * configure.in (hppa1.0*): Prefer c89 to cc. + * configure: Regenerate. + +2000-04-15 Linus Nordberg + + * configure.in: If `mpn_path' is set by user on configure command + line, use that as path. + * configure: Regenerate. + +2000-04-15 Linus Nordberg + + * configure.in (hppa2.0*): Use path "hppa/hppa1_1 hppa" if no + 64-bit compiler was found. + * configure: Regenerate. + +2000-04-15 Linus Nordberg + + * configure.in: Honor `CC' and `CFLAGS' set by user on configure + command line. + * acinclude.m4: (GMP_PROG_CC_SELECT): Set CFLAGS if not set already. + * aclocal.m4: Regenerate. + * configure: Regenerate. + +2000-04-15 Linus Nordberg + + * acinclude.m4 (GMP_PROG_CC_FIND): Remove debug output. Remove + commented out code. + * aclocal.m4: Regenerate. + * configure: Regenerate. + + * configure.in: Make all `-mcpu' options to gcc optional. + * configure: Regenerate. + + * tests/rand/Makefile.am: Don't do anything for target 'all'. + * tests/rand/Makefile.in: Regenerate. + +2000-04-15 Kevin Ryde + + * README: Small updates. + * NEWS: Add some things about 3.0. + + * mpz/Makefile.am (EXTRA_DIST): Remove dmincl.c. + + * Makefile.am: Use -version-info on libraries, not -release. + + * mpz/tdiv_qr.c: Add mdiv function header #ifdef BERKELEY_MP. + * mpbsd/Makefile.am: Use mpz/tdiv_qr.c, not mdiv.c. + * Makefile.am (MPBSD_OBJECTS): Change mdiv.lo to tdiv_qr.lo. + (libmp_la_DEPENDENCIES): Add mp_clz_tab.lo. + * mpbsd/mdiv.c: Remove file. + + * config/mt-linux,mt-m68k,mt-m88110,mt-ppc,mt-ppc64-aix,mt-pwr, + mt-sprc8-gcc,mt-sprc9-gcc,mt-supspc-gcc,mt-vax,mt-x86, + mpn/config/mt-pa2hpux,mt-sprc9,t-oldgas,t-ppc-aix,t-pwr-aix: + Remove configure fragments not used since change to autoconf. + + * mpn/generic/bz_divrem_n.c,sb_divrem_mn.c: Add comment that + internal functions are changeable and shouldn't be used directly. + +2000-04-15 Linus Nordberg + + * configure.in: Remove debug output. + * configure: Regenerate. + +2000-04-15 Torbjorn Granlund + + * mpn/generic/tdiv_qr.c: Don't use alloca directly. + + * mpz/tdiv_qr.c: Fix typo. + * mpz/tdiv_r.c: Fix typo. + * mpz/tdiv_q.c: Fix typo. + + * configure.in: Disable -march=pentiumpro due to apparent compiler + problems. + + * mpz/powm.c: Replace with new code from Paul Zimmermann. + + * mpz/tdiv_q.c: Remove debug code. + + * mpn/generic/divrem.c: Remove C++ style `//' commented-out code. + * mpn/generic/sb_divrem_mn.c: Likewise. + +2000-04-14 Torbjorn Granlund + + * mpz/cdiv_q.c: Change temp allocation for new requirements of + mpz_tdiv_qr. + * mpz/fdiv_q.c: Likewise. + + * mpn/sparc64/gmp-mparam.h: Set up parameters for TOOM3. + + * mpz/dmincl.c: Delete file. + * mpz/tdiv_qr.c: Rewrite using mpn_tdiv_qr. + * mpz/tdiv_r.c: Likewise. + * mpz/tdiv_q.c: Likewise. + + * mpn/generic/tdiv_qr.c: New file. + * mpn/generic/bz_divrem_n.c: New file. + * mpn/generic/sb_divrem_mn.c: New file. + + * gmp-impl.h (MPZ_REALLOC): New macro. + (mpn_sb_divrem_mn): Declare. + (mpn_bz_divrem_n): Declare. + (mpn_tdiv_qr): Declare. + + * configure.in (gmp_mpn_functions): Delete divrem_newt and divrem_1n; + add tdiv_qr, bz_divrem_n, and sb_divrem_mn. + * mpn/generic/divrem_newt.c: Delete file. + * mpn/generic/divrem_1n.c: Delete file. + + * gmp.h (mpn_divrem_newton): Remove declaration. + (mpn_divrem_classic): Remove declaration. + + * gmp.h (mpn_divrem): Remove function definition. + * mpn/generic/divrem.c: Replace mpn_divrem_classic with a + mpn_divrem wrapper. + +2000-04-14 Kevin Ryde + + * mpf/dump.c, mpz/dump.c, mpn/generic/dump.c, + mpn/generic/divrem.c, mpn/generic/divrem_1n.c, + mpn/generic/divrem_2.c, mpn/generic/divrem_newt.c, + mpn/generic/mul.c, mpn/generic/mul_basecase.c, + mpn/generic/mul_n.c, mpn/generic/sqr_basecase.c, + mpn/generic/udiv_w_sdiv.c: Add comment that internal functions are + changeable and shouldn't be used directly. + + * mpq/div.c: Use DIVIDE_BY_ZERO (previously didn't get an + exception on zero divisor). + + * mpf/tests/t-get_d.c, mpz/tests/reuse.c: Add K&R function + definitions. + * mpz/tests/t-2exp.c: Don't use ANSI-ism 2ul. + + * gmp.texi (Installing MP): Build problem notes for GSYM_PREFIX + and ranlib on native SunOS. + Particular systems notes about AIX and HPPA shared libraries + disabled. + (MP Basics): Add that undocumented things shouldn't be used. + (Introduction to MP): Add to CPUs listed. + + * acinclude.m4 (GMP_CHECK_ASM_UNDERSCORE): Don't depend on C + having "void". + +2000-04-13 Linus Nordberg + + * mpn/pa64/udiv_qrnnd.c (__udiv_qrnnd64): Add K&R function + definition. + + * configure.in: Disable shared libraries for hppa*. + (mips-sgi-irix6.*): Fix flags for 64-bit gcc. + (hppa2.0*-*-*): Prefer c89 to cc. + * configure: Regenerate. + + * gmp.h (gmp_randalg_t): Remove comma after last element. + + * tests/rand/t-rand.c: Add copyright notice. + +2000-04-13 Kevin Ryde + + * mpn/generic/mul_n.c, mpn/generic/gcdext.c, mpz/nextprime.c, + mpz/remove.c, mpz/root.c: Add K&R function definitions. + * mpz/rrandomb.c: Fix typo in K&R part. + * stack-alloc.c: Add K&R style function pointer declarations. + + * mpz/root.c: Use SQRT_OF_NEGATIVE on even roots of negatives. + Use DIVIDE_BY_ZERO on a "zero'th" root. + + * configure: Regenerate with autoconf backpatched to fix --srcdir + absolute path wildcards that bash doesn't like, change by Linus. + + * gmp.texi (Integer Arithmetic): Document mpz_nextprime. + (Miscellaneous Integer Functions): Fix mpz_fits_* formatting. + (Installing MP): Comment-out CC and CFLAGS description. + +2000-04-13 Linus Nordberg + + * rand.c (gmp_randinit): Don't combine va_alist with ordinary + arguments for non STDC. + +2000-04-13 Torbjorn Granlund + + * mpz/nextprime.c: Use proper names of new random types and functions. + + * mpz/rrandomb.c: New file. + * mpz/Makefile.am: List it. + * mpz/Makefile.in: Regenerate. + * Makefile.am: Here too. + * Makefile.in: Regenerate. + * gmp.h: Declare mpz_rrandomb. + +2000-04-12 Linus Nordberg + + * Makefile.am, demos/Makefile.am, mpbsd/Makefile.am, + mpbsd/tests/Makefile.am, mpf/Makefile.am, mpf/tests/Makefile.am, + mpn/Makefile.am, mpq/Makefile.am, mpq/tests/Makefile.am, + mpz/Makefile.am, mpz/tests/Makefile.am, tests/Makefile.am, + tests/rand/Makefile.am (AUTOMAKE_OPTIONS): Add 'no-dependencies'. + + * Makefile.in, demos/Makefile.in, mpbsd/Makefile.in, + mpbsd/tests/Makefile.in, mpf/Makefile.in, mpf/tests/Makefile.in, + mpn/Makefile.in, mpq/Makefile.in, mpq/tests/Makefile.in, + mpz/Makefile.in, mpz/tests/Makefile.in, tests/Makefile.in, + tests/rand/Makefile.in: Regenerate. + +2000-04-12 Linus Nordberg + + * randlc.c (gmp_randinit_lc): Disable function. + * gmp.texi (Random State Initialization): Remove gmp_randinit_lc. + + * acinclude.m4 (GMP_CHECK_CC_64BIT): Compiling an empty main + successfully with `-n32' will have to suffice on irix6. + * aclocal.m4: Regenerate. + + * configure.in (sparc): Don't pass -D_LONG_LONG_LIMB to compiler. + (mips-sgi-irix6.*): Use compiler option `-n32' rather than `-64' + for 64-bit `cc'. Add options for gcc. + * configure: Regenerate. + + * mpf/urandomb.c (mpf_urandomb): Add third parameter 'nbits'. If + 'nbits' doesn't make even limbs, shift up result before + normalizing. + + * gmp.h (mpf_urandomb): Add parameter to prototype. + + * mpf/urandom.c: Rename file to ... + * mpf/urandomb.c: ... this. + * Makefile.am (MPF_OBJECTS): Change urandom.lo --> urandomb.lo. + * Makefile.in: Regenerate. + * mpf/Makefile.am (libmpf_la_SOURCES): Change urandom.c --> urandomb.c. + * mpf/Makefile.in: Regenerate. + + * config.in: Regenerate for HAVE_DECL_OPTARG. + + * randraw.c (_gmp_rand): Fix bug with _LONG_LONG_LIMB. + (lc): Change return type. + Use one temporary storage instead of two. + Handle seed of size 0. + Avoid modulus operation in some cases. + Abort if M is not a power of 2. + Fix bug with 64-bit limbs. + Fix bug with small seed, small A and large M. + + * tests/rand/gen.c (main): Include gmp.h. Remove macros MIN, MAX. Add + option '-q'. Don't demand argument N. Change parameters in call + to mpf_urandomb. + + * tests/rand/t-rand.c: New file for testing random number generation. + + * tests/rand/Makefile.am: Run t-rand for 'make check'. + (test, bigtest): Rename to manual-test, manual-bigtest. + * tests/rand/Makefile.in: Regenerate. + +2000-04-12 Kevin Ryde + + * gmp-impl.h: Include config.h before TMP_ALLOC, so + --disable-alloca works. + + * mpbsd/Makefile.am: Don't recompile top-level sources here. + * Makefile.am (libmp_la_DEPENDENCIES): Put objects here instead, + add errno.lo and stack-alloc.lo. + + * mpn/asm-defs.m4: Add a test and message for the unsuitable SunOS m4. + * gmp.texi (Installing MP): Update note on SunOS m4 failure. + + * acconfig.h: Add copyright notice using @TOP@. + + * stack-alloc.c: Use _mp_allocate_func, not malloc. + * gmp.texi (Installing MP): Note this under --disable-alloca. + + * gmp.texi (Comparison Functions): mpz_cmp_abs => mpz_cmpabs. + (Integer Arithmetic): mpz_prime_p not yet implemented, comment out. + (Float Arithmetic): mpf_pow_ui now implemented, uncomment-out. + (Miscellaneous Float Functions): Add mpf_ceil, mpf_floor, mpf_trunc. + (Low-level Functions): Add mpn_random2, with mpn_random. + + * mpn/m68k/mc68020/udiv.S: Rename from udiv.s. + * mpn/m68k/mc68020/umul.S: Ditto. + + * mpn/alpha/umul.asm: Rename from umul.s, remove .file and + compiler identifiers. + + * mpn/powerpc32/syntax.h: Removed, no longer used. + + * mpn/a29k/udiv.s: Remove .file and compiler identifiers. + * mpn/a29k/umul.s: Ditto. + + * mpn/tests/ref.c: Use WANT_ASSERT. + * mpn/tests/ref.h: Use _PROTO. + + * mpbsd/configure.in: Removed, no longer required. + + * mpf/div.c: Use DIVIDE_BY_ZERO. + * mpf/div_ui.c: Ditto. + * mpf/ui_div.c: Ditto. + * mpq/inv.c: Ditto. + * mpf/sqrt.c: Use SQRT_OF_NEGATIVE. + * mpz/sqrt.c: Ditto. + * mpz/sqrtrem.c: Ditto. + + * gmp-impl.h (GMP_ERROR,SQRT_OF_NEGATIVE): New macros. + (DIVIDE_BY_ZERO): Use GMP_ERROR. + (__mp_bases): #define to __MPN(mp_bases). + +2000-04-11 Linus Nordberg + + * tests/rand/stat.c (main): Initialize `l1runs' at declaration. + +2000-04-11 Kevin Ryde + + * mpz/fib_ui.c: Add K&R function definitions. + + * mpbsd/tests/Makefile.am (TESTS): Add a dummy test to avoid a + shell problem with an empty "for tst in $(TESTS) ; ...". + * mpbsd/tests/dummy.c: New file. + +2000-04-10 Torbjorn Granlund + + * mpz/bin_uiui.c: Delete several unused variables. + Add copyright notice. + * mpz/bin_ui.c: Add copyright notice. + + * longlong.h: Declare __count_leading_zeros for alpha. + +2000-04-10 Linus Nordberg + + * rand.c (gmp_randinit): Change parameter list to (rstate, alg, ...). + * gmp.h: Change prototype accordingly. + * mpz/pprime_p.c (millerrabin): Change call accordingly. + + * configure.in: Check for `optarg'. + * configure: Regenerate. + + * mpn/Makefile.am: Remove incorrect comment. + * mpn/Makefile.in: Regenerate. + + * gmp.h: Rename most of the random number functions, structs and some + of the struct members. + * rand.c (gmp_randinit): Likewise. + * randclr.c (gmp_randclear): Likewise. + * randlc.c (gmp_randinit_lc): Likewise. + * randlc2x.c (gmp_randinit_lc_2exp): Likewise. + * randraw.c (lc): Likewise. + (_gmp_rand_getraw): Likewise. + * randsd.c (gmp_randseed): Likewise. + * randsdui.c (gmp_randseed_ui): Likewise. + * gmp.texi: Likewise. + + * gmp.texi: Use three hyphens for a dash. + (Low-level Functions): Remove documentation for gmp_rand_getraw. + (Random Number Functions): Add info on where to find documentation + on the random number functions. + + * tests/rand/Makefile.am (test, bigtest): Quote argument to grep. + * tests/rand/Makefile.in: Regenerate. + + * tests/rand/gen.c: Declare optarg, optind, opterr if not already + declared. + (main): Use new names for the random stuff. + (main): Don't use strtoul() if we don't have it. Use strtol() + instead, if we have it. Otherwise, use atoi(). + (main): Use srandom/srandomdev for __FreeBSD__ only. + (main): Use new parameter order to gmp_randinit(). + + * tests/rand/stat.c: Declare optarg, optind, opterr if not already + declared. + +2000-04-10 Torbjorn Granlund + + * mpz/pprime_p.c: Pass 0L for mpz_scan1. mpz_mmod => mpz_mod. + (millerrabin): Use new random interface. + (millerrabin): ... and don't forget to call gmp_randclear. + + * mpz/nextprime.c: New file. + * gmp.h: Declare mpz_nextprime. + * mpz/Makefile.am: List nextprime.c. + * mpz/Makefile.in: Regenerate. + * Makefile.am: List mpz/nextprime.lo. + * Makefile.in: Regenerate. + +2000-04-10 Kevin Ryde + + * move-if-change, mpz/tests/move-if-change, mpq/tests/move-if-change, + mpf/tests/move-if-change: Remove, no longer used. + + * Makefile.am (SUBDIRS): Add tests, demos, mpbsd. + (libmp.la): New target, conditional on WANT_MPBSD. + (libgmp_la_LIBADD): Add -lm. + (AUTOMAKE_OPTIONS): Add check-news. + (include_HEADERS): Setup to install gmp.h and possibly mp.h. + (DISTCLEANFILES): Add generated files. + (check): Remove explicit target (now uses check-recursive). + + * configure.in: Use AM_CONFIG_HEADER. + Add --enable-mpbsd setting automake conditional WANT_MPBSD. + Output demos/Makefile, mpbsd/Makefile and mpbsd/tests/Makefile. + + * mpz/Makefile.am: Add SUBDIRS=tests, shorten INCLUDES since now + using AM_CONFIG_HEADER. + * mpq/Makefile.am: Ditto. + * mpf/Makefile.am: Ditto, and add DISTCLEANFILES. + * mpn/Makefile.am: Shorten INCLUDES, amend some comments. + * mpz/tests/Makefile.am: Use TESTS and $(top_builddir). + * mpf/tests/Makefile.am: Ditto. + * mpq/tests/Makefile.am: Ditto. + * demos/Makefile.am: New file. + + * mpbsd/Makefile.am: New file, derived from old mpbsd/Makefile.in. + * mpbsd/Makefile.in: Now generated from Makefile.am. + * mpbsd/realloc.c: Removed, use mpz/realloc.c instead. + * mpbsd/tests/Makefile.am: New file. + * mpbsd/tests/Makefile.in: New file, generated from Makefile.am. + * mpbsd/tests/allfuns.c: New file. + + * gmp.texi (Top): Use @ifnottex, to help makeinfo --html. + (Installing MP): Describe --enable-mpbsd and demo programs. + + * tests/rand/statlib.c: mpz_cmp_abs => mpz_cmpabs. + + * tests/rand/Makefile.am (LDADD): Don't need -lm (now in libgmp.la). + (EXTRA_PROGRAMS): Not noinst_PROGRAMS. + (INCLUDES): Shorten to -I$(top_srcdir) now using AM_CONFIG_HEADER. + +2000-04-09 Torbjorn Granlund + + * mpz/urandomm.c: Get type of count right. + Simplify computation of nbits. + +2000-04-08 Torbjorn Granlund + + * mpz/urandomb.c: Fix reallocation condition. + Simplify size computation. + +2000-04-08 Linus Nordberg + + * acinclude.m4 (GMP_CHECK_CC_64BIT): Add special handling for + HPUX. + (GMP_CHECK_ASM_W32): Ditto. + * aclocal.m4: Regenerate. + + * mpn/Makefile.am: Use $(CCAS) for assembling. + (.asm.obj): Add rule. + * mpn/Makefile.in: Regenerate. + + * gmp.texi (Miscellaneous Integer Functions): Fix typos. + + * configure.in: Never pass `-h' to grep. + (mips-sgi-irix6.[2-9]*): Try to find 64-bit compiler. + (hppa1.0*-*-*): New flag for cc. + (hppa2.0*-*-*): Try to find 64-bit compiler. Chose path, set + CCAS. + * configure: Regenerate. + +2000-04-08 Torbjorn Granlund + + * mpz/bin_ui.c: Don't depend on ANSI C features. + * mpz/bin_uiui.c: Likewise. + + * Makefile.am (MPZ_OBJECTS): mpz/cmp_abs* => mpz/cmpabs*. + (MPQ_OBJECTS): Add mpq/set_d.lo. + (MPZ_OBJECTS): Add mpz/fits*.lo. + * Makefile.in: Regenerate. + + * mpz/cmpabs.c: New name for mpz/cmp_abs.c. + * mpz/cmpabs_ui.c: New name for mpz/cmp_abs_ui.c. + * mpz/Makefile.am: Corresponding changes. + * mpz/Makefile.in: Regenerate. + * gmp.h: mpz_cmp_abs* => mpz_cmpabs*. + + * mpz/addmul_ui.c (mpn_neg1): Don't depend on ANSI C features. + + * mpz/invert.c: Use TMP_MARK since we invoke MPZ_TMP_INIT. + + * gmp.h (mpq_set_d): Declare correctly. + (mpz_root): Use _PROTO. + (mpz_remove): Use _PROTO. + (mpf_pow_iu): Use _PROTO. + + * mpn/asm-defs.m4 (MPN_PREFIX): Revert previous change. + * gmp.h (__MPN): Revert previous change. + + * mpz/perfpow.c: De-ANSI-fy. Add copyright notice. + + * mpz/set_d.c: Misc cleanups. + + * mpq/set_d: New file. + * gmp.h: Declare mpq_set_d. + * mpq/Makefile.am: List set_d.c. + * mpq/Makefile.in: Regenerate. + +2000-04-07 Torbjorn Granlund + + * mpz/fits_sint_p.c: New file. + * mpz/fits_slong_p.c: New file. + * mpz/fits_sshort_p.c: New file. + * mpz/fits_uint_p.c: New file. + * mpz/fits_ulong_p.c: New file. + * mpz/fits_ushort_p.c: New file. + * gmp.h: Declare mpz_fits_*. + * mpz/Makefile.am: List fits_* files. + * mpz/Makefile.in: Regenerate. + +2000-04-06 Kevin Ryde + + * gmp.texi (Installing MP): Add known build problem SunOS 4.1.4 m4 + failure. + + * mpn/x86/pentium/gmp-mparam.h: Tune thresholds. + * mpn/x86/p6/gmp-mparam.h: Ditto. + * mpn/x86/k6/gmp-mparam.h: Tune thresholds, add UMUL_TIME, UDIV_TIME. + * mpn/x86/k7/gmp-mparam.h: Tune thresholds, amend UMUL_TIME. + + * mpn/generic/mul_n.c (mpn_kara_mul_n): Add an ASSERT. + (mpn_kara_sqr_n): Add an ASSERT, use KARATSUBA_SQR_THRESHOLD. + (mpn_toom3_sqr_n): Eliminate second evaluate3. + + * gmp-impl.h (mpn_com_n,MPN_LOGOPS_N_INLINE): Don't allow size==0. + (tune_mul_threshold,tune_sqr_threshold): Conditionalize + declarations on TUNE_PROGRAM_BUILD. + + * mpn/generic/sqr_basecase.c: Add an assert. + +2000-04-05 Torbjorn Granlund + + * gmp.h, mpn/asm-defs.m4: List the same functions for __MPN, but + leave some commented out. + + * gmp-impl.h (MPN_LOGOPS_N_INLINE): Optimize. + (mpn_com_n): Optimize. + + * gmp.h (__MPN): Make it use __gmpn instead of __mpn for consistency. + * mpn/asm-defs.m4 (MPN_PREFIX): Likewise. + + * gmp.h (GMP_ERROR_ALLOCATE): New errcode. + + * gmp-impl.h (MPN_MUL_N_RECURSE): Delete. + (MPN_SQR_RECURSE): Delete. + + * gmp-impl.h (TARGET_REGISTER_STARVED): New define. + + * gmp-impl.h (mpn_kara_sqr_n): Remap with __MPN. + (mpn_toom3_sqr_n): Likewise. + (mpn_kara_mul_n): Likewise. + (mpn_toom3_mul_n): Likewise. + (mpn_reciprocal): Likewise. + + * gmp-impl.h (__gmpn_mul_n): Remove declaration. + (__gmpn_sqr): Likewise. + * gmp.h (mpn_sqr_n): Declare/remap. + * mpn/generic/mul.c (mpn_sqr_n): New name for mpn_sqr. + + * gmp.h (mpn_udiv_w_sdiv): Move __MPN remap from here... + * gmp-impl.h: ...to here. + +2000-04-05 Linus Nordberg + + * gmp.texi (Top): Add `Random Number Functions' to menu. + (Introduction to MP): Fix typo. + (MP Basics): Create menu for all sections. Move `Random Number + Functions' to its own chapter. Add nodes for all sections. + (Function Classes): Mention random generation functions under + miscellaneous. + (Miscellaneous Integer Functions): Update mpz_urandomb, + mpz_urandomm. + (Low-level Functions): Remove mpn_rawrandom. + (Random State Initialization): Update. + + * mpf/urandom.c (mpf_urandomb): Remove SIZE parameter. Normalize + result correctly. + + * gmp.h (mpf_urandomb): Remove SIZE parameter. + + * randraw.c (gmp_rand_getraw): Handle the case where (1) the LC + scheme doesn't generate even limbs and (2) more than one LC + invocation is necessary to produce the requested number of bits. + +2000-04-05 Torbjorn Granlund + + * mpn/generic/mul_n.c (INVERSE_3): New name for THIRD, define for + any BITS_PER_MP_LIMB. + (MP_LIMB_T_MAX): New. + (mpn_divexact3_n): Remove. + (interpolate3): Use mpn_divexact_by3 instead of mpn_divexact3_n. + +2000-04-05 Kevin Ryde + + * gmp-impl.h (KARATSUBA_MUL_THRESHOLD<2): Remove cpp test. + (tune_mul_threshold,tune_sqr_threshold): Add declarations, used in + development only. + + * mpn/x86/k7/sqr_basecase.asm: New file, only a copy of k6 for now. + +2000-04-04 Torbjorn Granlund + + * gmp-impl.h (TOOM3_MUL_THRESHOLD): Provide default. + (TOOM3_SQR_THRESHOLD): Provide default. + + * mpn/generic/mul_n.c: Rewrite (mostly by Robert Harley). + * mpn/generic/mul.c: Rewrite (mostly by Robert Harley). + + * configure.in (sparcv9 64-bit OS): Set extra_functions. + +2000-04-04 Linus Nordberg + + * mpn/generic/rawrandom.c: Remove file and replace with randraw.c + on top level. + (mpn_rawrandom): Rename to gmp_rand_getraw. + + * randraw.c: New file; essentially a copy of + mpn/generic/rawrandom.c. + (gmp_rand_getraw): New function (formerly known as mpn_rawrandom). + + * mpz/urandomb.c (mpz_urandomb): Change mpn_rawrandom --> + gmp_rand_getraw. + * mpz/urandomm.c (mpz_urandomb): Ditto. + * mpf/urandom.c (mpf_urandomb): Ditto. + + * gmp.h (gmp_rand_getraw): Add function prototype. + (mpn_rawrandom): Remove function prototype. + + * Makefile.am (libgmp_la_SOURCES): Add randraw.c. + * Makefile.in: Regenerate. + + * configure.in (gmp_mpn_functions): Remove rawrandom. + * configure: Regenerate. + +2000-04-04 Linus Nordberg + + * gmp.h (GMP_ERROR enum): Remove comma after last enumeration + since the AIX compiler (xlc) doesn't like that. + + * randlc.c (gmp_rand_init_lc): Allocate enough space for seed to + hold any upcoming seed. + * randlc2x.c (gmp_rand_init_lc_2exp): Likewise. + + * mpn/generic/rawrandom.c: Remove debugging code. + (mpn_lc): Don't reallocate seed. + + * mpz/urandomm.c (mpz_urandomm): Implement function. + + * mpz/urandomb.c (mpz_urandomb): Fix typo in function definition. + +2000-04-04 Kevin Ryde + + * make.bat: Removed (no longer works, no longer supported). + * mpn/msdos/asm-syntax.h: Removed (was used only by make.bat). + +2000-04-03 Torbjorn Granlund + + * mpn/generic/brandom.c: New file, replacing random2. + +2000-04-02 Torbjorn Granlund + + * mpn/sparc32/v9/submul_1.asm: Change some carry-form instructions + into their plain counterparts. + + * mpn/sparc64/copyi.asm: Avoid executing ALIGN. + + * mpn/sparc64/mul_1.asm: Handle overlap of rp/sp. + * mpn/sparc64/addmul_1.asm: Likewise. + * mpn/sparc64/submul_1.asm: Likewise. + +2000-04-01 Linus Nordberg + + * gmp.h: Fix function prototypes for randomization functions. + (__gmp_rand_lc_scheme_struct): Replace `m' with `m2exp'. Remove + unused `bits'. + (__gmp_rand_data_lc): Add `m2exp' as another way of representing + the modulus. + (__gmp_rand_state_struct): Remove unused `size'. + + * rand.c (__gmp_rand_scheme): Use better multipliers. Remove test + schemes. Replace `m' with `m2exp'. + (gmp_rand_init): Change parameters and return type. Use `m2exp' + instead of `m'. Set `gmp_errno' on error. Disable BBS algorithm. + + * randlc.c (gmp_rand_init_lc): Don't use malloc(). Change + parameters. + + * randclr.c (gmp_rand_clear): Don't use free(). Disable BBS + algorithm. Set `gmp_errno' on error. + + * randlc2x.c (gmp_rand_init_lc_2exp): New function. + * randsd.c (gmp_rand_seed): New function. + * randsdui.c (gmp_rand_seed_ui): New function. + * randlcui.c: Remove unused file. + + * mpn/generic/rawrandom.c (mpn_rawrandom): Rewrite. + (mpn_lc): New static function. + + * mpz/urandomb.c (mpz_urandomb): Use ABSIZ() instead of SIZ() for + determining size of ROP. + + * mpf/urandom.c (mpf_urandomb): Add third parameter, nbits. (Not + used yet!) + Change parameter order to mpn_rawrandom(). + + * Makefile.am (libgmp_la_SOURCES): Add errno.c, randlc2x.c, + randsd.c, randsdui.c. Remove randui.c. + (MPZ_OBJECTS): Rename urandom.lo --> urandomb.lo. Add urandomm.lo. + * Makefile.in: Regenerate. + + * mpz/Makefile.am (libmpz_la_SOURCES): Change urandom.c --> + urandomb.c. Add urandomm.c. + * mpz/Makefile.in: Regenerate. + + * tests/rand/Makefile.am (noinst_PROGRAMS): Change findcl --> findlc. + Add gen.static. + * tests/rand/Makefile.in: Regenerate. + + * tests/rand/gen.c (main): Add mpz_urandomm. Add command line options + `-C', `-m', extend `-a'. Use *mp*_*rand*() with new parameters. Call + gmp_rand_seed(). + +2000-04-01 Kevin Ryde + + * acinclude.m4 (GMP_CHECK_ASM_DATA): Plain .data for hpux. + * configure.in (CCAS): No CFLAGS, they're added when it's used. + (CONFIG_SRCDIR): New define for config.m4. + * mpn/sparc64/addmul_1.asm: Use it for an include(). + * mpn/sparc64/submul_1.asm: Ditto. + * mpn/sparc64/mul_1.asm: Ditto. + +2000-03-31 Linus Nordberg + + * mpz/urandom.c: Rename to... + * mpz/urandomb.c: ...this. + + * mpz/urandomb.c (mpz_urandomb): Change operand order in call to + mpn_rawrandom(). Use ABSIZ() instead of SIZ() when checking size + of ROP. + + * mpz/urandomm.c: New file. + +2000-03-31 Kevin Ryde + + * acinclude.m4 (GMP_CHECK_ASM_MMX): Give a warning when mmx code + will be omitted. + +2000-03-30 Torbjorn Granlund + + * mpn/sparc64/mul_1h.asm: New file. + * mpn/sparc64/addmul_1h.asm: New file. + * mpn/sparc64/submul_1h.asm: New file. + * mpn/sparc64/mul_1.asm: Rewrite. + * mpn/sparc64/addmul_1.asm: Rewrite. + * mpn/sparc64/submul_1.asm: Rewrite. + +2000-03-28 Torbjorn Granlund + + * mpn/sparc32/v9/mul_1.asm: Fix typo in branch prediction. + * mpn/sparc32/v9/addmul_1.asm: Likewise. + * mpn/sparc32/v9/submul_1.asm: Likewise. + +2000-03-25 Kevin Ryde + + * mpn/lisp/gmpasm-mode.el: Fix some comment detection, use custom, + fontify more keywords, turn into a standalone mode. + + * stamp-vti: New file, generated together with version.texi. + + * acinclude.m4 (GMP_VERSION,GMP_HEADER_GETVAL): New macros. + * configure.in (AM_INIT_AUTOMAKE): Use GMP_VERSION. + +2000-03-24 Kevin Ryde + + * INSTALL: Updates for new configure system. + + * configure.in: Add gmp_optcflags_gcc for the x86s, setting -mcpu + and -march. + +2000-03-23 Torbjorn Granlund + + * demos/pexpr.c (mpz_eval_expr): Properly initialize rhs/lhs + for ROOT. + +2000-03-23 Kevin Ryde + + * config.guess (i?86:*:*:*): Use uname -m if detection program fails. + + * mpn/x86/README: Remove remarks on the now implemented MMX shifts. + * mpn/x86/k6/README: Add speed of mpn_divexact_by3, update mpn_mul_1. + + * gmp.texi (Installing MP): Corrections to target CPUs. + + * version.c: Use VERSION from config.h, add copyright comment, + restore "const" somehow lost. + + * configure.in (a29k*-*-*): Fix directory name. + +2000-03-22 Torbjorn Granlund + + * demos/pexpr.c (op_t): Add ROOT. + (fns): Add ROOT. + (mpz_eval_expr): Add ROOT. + + * mpz/root.c: Handle roots of negative numbers. + Fix other border cases. + Fix rare memory leakage. + + * errno.c: New file. + +2000-03-21 Torbjorn Granlund + + * gmp.h (error number enum): New anonymous enum. + (gmp_errno): New. + + * gmp.h (__GNU_MP_VERSION, __GNU_MP_VERSION_MINOR): Bump for GMP 3.0. + +2000-03-20 Torbjorn Granlund + + * mpn/alpha/unicos.m4 (FLOAT64): New define. + * mpn/alpha/default.m4 (FLOAT64): New define. + * mpn/alpha/invert_limb.asm (C36): Use FLOAT64. + +2000-03-21 Kevin Ryde + + * mpn/x86/k6/diveby3.asm: Tiny speedup. + + * acinclude.m4 (GMP_CHECK_ASM_SHLDL_CL): New macro. + * configure.in: Use it, set WANT_SHLDL_CL in config.m4. + * mpn/x86/x86-defs.m4 (shldl,shrdl,shldw,shrdw): New macros, using + WANT_SHLDL_CL. + * mpn/x86/k6/mmx/lshift.asm: Use shldl macro. + * mpn/x86/k7/mmx/lshift.asm: Ditto. + * mpn/x86/pentium/mmx/lshift.asm: Ditto. + * mpn/x86/k6/mmx/rshift.asm: Use shrdl macro. + * mpn/x86/k7/mmx/rshift.asm: Ditto. + * mpn/x86/pentium/mmx/rshift.asm: Ditto. + * mpn/x86/README.family: Add a note about this. + +2000-03-20 Linus Nordberg + + * mpn/generic/rawrandom.c (mpn_rawrandom): Handle seed value of 0 + correctly. + + * configure.in: Fix detection of alpha flavour. + Set compiler options for `sparcv8'. + * configure: Regenerate. + + * rand.c (__gmp_rand_scheme): Clean up some. Use slightly better + multipliers. + + * configure.in (AC_OUTPUT): Add tests/Makefile and + tests/rand/Makefile. + + * acinclude.m4 (AC_CANONICAL_BUILD): Define to + `_AC_CANONICAL_BUILD' to deal with incompatibilities between + Autoconf and Libtool. + (AC_CHECK_TOOL_PREFIX): Likewise. + + * Makefile.am (EXTRA_DIST): Add directory `tests'. + + * mkinstalldirs: Update (Automake 2000-03-17). + * ltconfig: Update (Libtool 2000-03-17). + * ltmain.sh: Ditto. + + * configure: Regenerate with new autoconf/-make/libtool suite. + * aclocal.m4: Ditto. + * config.in: Ditto. + * all Makefile.in's: Ditto. + +2000-03-20 Torbjorn Granlund + + * demos/pexpr.c (main): Don't allow `-N' for base, require `-bN'. + + * mpn/alpha/unicos.m4 (cvttqc): New define. + * mpn/alpha/invert_limb.asm: Use new define for cvttqc. + +2000-03-19 Kevin Ryde + + * mpn/x86/k6/sqr_basecase.asm: Tiny amendments for 3x3 case. + + * gmp.texi: Use @include version.texi. + Use @email and @uref. + (Installing MP): Rewrite for new configure. + (Low-level Functions): Add mpn_divexact_by3. + + * configure.in (--enable-alloca): New option. + * acconfig.h (USE_STACK_ALLOC): For --disable-alloca. + +2000-03-18 Kent Boortz + + * macos: New directory with macos port files. + +2000-03-17 Torbjorn Granlund + + * gmp-impl.h (union ieee_double_extract): Check _CRAYMPP. + + * mpn/asm-defs.m4 (invert_normalized_limb): Define. + + * mpn/alpha: Translate `.s' files to `.asm'. + + * configure: Regenerate. + + * mpn/alpha/invert_limb.asm: Replace dash in file name with underscore. + * configure.in: Corresponding change. + + * configure.in: Assign special "path" for alphaev6. + + * mpn/alpha/unicos.m4: New file. + * configure.in (alpha*-cray-unicos*): [This part of the change + commited 2000-03-13 by linus] + * mpn/alpha/default.m4: New file. + * configure.in (alpha*-*-*): Use it. + +2000-03-17 Kevin Ryde + + * mpn/x86/pentium/rshift.S: Use plain rcrl (not rcrl $1) for + shift-by-1 case, significant speedup. + * mpn/x86/pentium/README: Add shift-by-1 speed. + +2000-03-16 Torbjorn Granlund + + * config.guess: Handle Cray T3D/E. + +2000-03-15 Kevin Ryde + + * mpn/generic/diveby3.c: New file. + * mpn/x86/diveby3.asm: New file. + * mpn/x86/k6/diveby3.asm: New file. + * gmp.h (mpn_divexact_by3): Prototype and define. + * mpn/asm-defs.m4: define_mpn(divexact_by3). + * configure.in (gmp_mpn_functions): Add diveby3. + + * mpn/x86/pentium/sqr_basecase.asm: A few better addressing modes. + + * configure.in: Add AC_C_STRINGIZE and AC_CHECK_TYPES((void)). + * gmp-impl.h (ASSERT): Use them. + + * mpn/x86/k7/mmx/lshift.asm: New file. + * mpn/x86/k7/mmx/rshift.asm: Rewrite simple loop and return value + handling, add some pictures. + +2000-03-14 Torbjorn Granlund + + * mpn/sparc32/v8/mul_1.asm: Make PIC actually work. + * mpn/sparc32/v8/addmul_1.asm: Likewise. + + * mpn/sparc32/v8/mul_1.asm: Use m4 ifdef, not cpp #if. + * mpn/sparc32/v8/addmul_1.asm: Likewise. + + * mpn/asm-defs.m4 (C): New define for comments. + * mpn/sparc32: Start comments with `C'. + + * config.guess: Remove `SunOS 6' handling. + Recognize sun4m and sun4d architectures under old SunOS. + +2000-03-14 Linus Nordberg + + * configure.in (gmp_srclinks): Set to list of links created by + configure. + * configure: Regenerate. + + * Makefile.am (libgmp_la_LDFLAGS): Set version info. + (DISTCLEANFILES): Include @gmp_srclinks@. + * Makefile.in: Regenerate. + +2000-03-13 Linus Nordberg + + * configure.in: Remove some changequote's by quoting the strings + containing `[]'. + Add support for `alpha*-cray-unicos*'. + AC_DEFINE `_LONG_LONG_LIMB' instead of passing it in CFLAGS. + Conditionalize the assembler syntax checks. + * configure: Regenerate. + * config.in: Regenerate. + + * acinclude.m4 (GMP_PROG_CCAS): Remove macro. + * aclocal.m4: Regenerate. + +2000-03-13 Kevin Ryde + + * mpn/x86/p6/README: New file. + + * mpn/x86/k6/mul_1.asm: Rewrite, smaller and slightly faster. + + * mpn/lisp/gmpasm-mode.el: Rewrite assembler comment detection and + handling. + + * configure.in: Separate mmx directories for each x86 flavour. + * configure: Regenerate. + +2000-03-12 Kevin Ryde + + * mpn/x86/x86-defs.m4 (ALIGN): Supplement definition from + config.m4 so as to pad with nops not zeros on old gas. + + * mpn/x86/k7/mmx/copyd.asm: Use plain emms (femms is just an alias + for emms now). + * mpn/x86/k7/mmx/copyi.asm: Ditto. + * mpn/x86/k7/mmx/rshift.asm: Ditto. + * mpn/x86/x86-defs.m4: Amend comments. + + * mpn/x86/mod_1.asm: Add comments on speeds. + + * mpn/x86/pentium/mmx/lshift.asm: New file. + * mpn/x86/pentium/mmx/rshift.asm: New file. + * mpn/x86/pentium/README: Add speeds of various routines. + +2000-03-10 Linus Nordberg + + * configure.in: Reorganize. + Use AC_CHECK_TOOL to find `ar'. + Add post-includes `regmap.m4' and `aix.m4' for AIX targets. + asm-syntax.h is not needed for PPC or sparc anymore. + (powerpc64-*-aix*): Compiler is always 64-bit. Use `-q64 + -qtune=pwr3' to xlc and `-maix64 -mpowerpc64' to gcc. Pass `-X + 64' to `ar' and `nm'. + (pentiummmx): Use GMP_CHECK_ASM_MMX and avoid MMX assembly path if + assembler is not MMX capable. + (pentium[23]): Likewise. + (athlon): Likewise. + (k6*): Likewise. + * configure: Regenerate. + + * acinclude.m4 (GMP_PROG_CC_WORKS): New macro. + (GMP_PROG_CC_FIND): Use GMP_PROG_CC_WORKS instead of + AC_TRY_COMPILER. Make sure that the *first* working 32-bit + compiler is used if no 64-bit compiler is found. + (GMP_CHECK_ASM_MMX): New macro. + * aclocal.m4: Regenerate. + + * Makefile.in: Regenerate. (CC_TEST removed.) + * mpf/Makefile.in: Likewise. + * mpn/Makefile.in: Likewise. + * mpq/Makefile.in: Likewise. + * mpz/Makefile.in: Likewise. + * mpf/tests/Makefile.in: Likewise. + * mpq/tests/Makefile.in: Likewise. + * mpz/tests/Makefile.in: Likewise. + + * acconfig.h (_LONG_LONG_LIMB): Add. + + * gmp-impl.h: Include config.h only if HAVE_CONFIG_H is defined. + +2000-03-09 Kevin Ryde + + * mpn/x86/pentium/mul_basecase.S: Small speedup by avoiding an AGI. + + * mpn/x86/k7/mmx/copyd.asm: Tiny speedup by avoiding popl. + * mpn/x86/k7/mmx/copyi.asm: Ditto. + * mpn/x86/k7/mul_basecase.asm: Ditto. + +2000-03-07 Torbjorn Granlund + + * config.guess: Better recognize POWER/PowerPC processor type. + +2000-03-07 Kevin Ryde + + * mpn/generic/addsub_n.c: Use HAVE_NATIVE_* now in config.h. + + * mpn/asm-defs.m4: Add comments about SysV m4. + (m4_log2): Don't use <<. + (m4_lshift,m4_rshift): New macros. + +2000-03-06 Torbjorn Granlund + + * mpn/powerpc32/regmap.m4: Map cr0 => `0', etc. + +2000-03-06 Kevin Ryde + + * mpn/tests/ref.c (refmpn_divexact_by3): New function. + * mpn/tests/ref.h: Prototype. + + * acconfig.h (WANT_ASSERT): New define. + * configure.in (--enable-assert): Turn on WANT_ASSERT. + * assert.c: New file. + * Makefile.am: Add to build. + * gmp-impl.h (ASSERT): New macro. + (ASSERT_NOCARRY) Renamed from assert_nocarry. + (MPZ_CHECK_FORMAT): Use ASSERT_ALWAYS. + * mpn/tests/ref.c: Use ASSERT. + * mpf/get_str.c: Use ASSERT_ALWAYS. + * mpf/set_str.c: Remove old assert macro. + + * mpn/x86/x86-defs.m4 (cmovnz_ebx_ecx): New macro. + * mpn/x86/p6/aorsmul_1.asm: Use cmov. + + * mpn/x86/lshift.S: Use %dl with testb, not %edx. No object code + change, testb was still getting generated. + * mpn/x86/rshift.S: Ditto. + +2000-03-03 Torbjorn Granlund + + * longlong.h: Add IA-64 support. + + * mpn/powerpc32: Misc cleanups. + * mpn/powerpc32/aix.m4: New file (mainly by Linus). + * mpn/powerpc64/aix.m4: New file (mainly by Linus). + * mpn/powerpc64: Translate `.S' files to `.asm'. + + * configure.in: Fix tyops. + * configure: Regenerate. + +2000-03-02 Torbjorn Granlund + + * mpn/powerpc32/regmap.m4: New file. + * mpn/powerpc32: Translate `.S' files to `.asm'. + * configure.in: Use mpn/powerpc32/regmap.m4 for powerpc targets + except some weird ones. + +2000-03-03 Kevin Ryde + + * mpn/lisp/gmpasm-mode.el: Suppress postscript comment prefixes in + filladapt. + + * mpn/x86/pentium/sqr_basecase.asm: New file. + * mpn/x86/pentium/gmp-mparam.h (KARATSUBA_SQR_THRESHOLD): Update. + + * configure.in: Add --enable-assert, enable k6 logops functions. + + * mpn/x86/k6/mmx/copyi.asm: Use m4 for divide, not as. + * mpn/x86/k6/mmx/copyd.asm: Ditto. + * mpn/x86/README.family: Add a note on this. + +2000-03-02 Kevin Ryde + + * mpn/x86/k6/aors_n.asm: Don't use stosl. + * mpn/x86/copyi.asm: Use cld to clear direction flag. + * mpn/x86/divrem_1.asm: Ditto. + * mpn/x86/README.family: Add a note on this. + + * mpn/x86/k6/mmx/copyi.asm: Rewrite. + * mpn/x86/k6/mmx/copyd.asm: New file. + * mpn/x86/k6/README: Update, and small amendments. + + * mpn/x86/x86-defs.m4 (Zdisp): New macro. + * mpn/asm-defs.m4 (m4_stringequal_p): New macro. + + * mpn/x86/p6/aorsmul_1.asm: Use Zdisp to force zero displacements. + * mpn/x86/k6/aorsmul_1.asm: Ditto. + * mpn/x86/k6/mul_1.asm: Ditto. + * mpn/x86/k6/mul_basecase.asm: Ditto. + * mpn/x86/k7/aors_n.asm: Ditto. + * mpn/x86/k7/aorsmul_1.asm: Ditto. + * mpn/x86/k7/mul_1.asm: Ditto. + * mpn/x86/k7/mul_basecase.asm: Ditto. + * mpn/x86/README.family: Add a note on this. + +2000-02-27 Kevin Ryde + + * mpn/generic/divrem.c (mpn_divrem_classic): Patch to avoid gcc + 2.7.2.3 i386 register handling bug. + + * mpn/x86/k6/aors_n.asm: Rewrite. + * mpn/x86/k6/mmx/lshift.asm: Rewrite. + * mpn/x86/k6/mmx/rshift.asm: Rewrite. + * mpn/x86/k6/README: Update. + + * mpn/x86/k7/mmx/copyd.asm: Support size==0. + * mpn/x86/k7/mmx/copyi.asm: Ditto. + * mpn/x86/k6/mmx/copyi.asm: Ditto. + * gmp-impl.h: Comment size==0 allowed in MPN_COPY_INCR and + MPN_COPY_DECR. + * configure.in: Enable x86 copyi, copyd; add k6 com_n. + +2000-02-25 Torbjorn Granlund + + * demos/pexpr.c (power): Move factorial handing code from `factor' + to `power'. + + * demos/factorize.c (factor_using_pollard_rho): Move resetting of `c' + to before checking for a non-zero gcd. + +2000-02-25 Kevin Ryde + + * mpn/asm-defs.m4 (MULFUNC_PROLOGUE): New macro by Linus. + * mpn/x86/k6/aors_n.asm: Use MULFUNC_PROLOGUE. + * mpn/x86/k6/aorsmul_1.asm: Ditto. + * mpn/x86/k7/aors_n.asm: Ditto. + * mpn/x86/k7/aorsmul_1.asm: Ditto. + * mpn/x86/p6/aorsmul_1.asm: Ditto. + + * mpn/tests/ref.c (refmpn_copyi,refmpn_copyd): Allow size==0. + + * gmp-impl.h: Move mpn_and_n, mpn_andn_n, mpn_com_n, mpn_ior_n, + mpn_iorn_n, mpn_nand_n, mpn_nior_n, mpn_xor_n and mpn_xorn_n here + from gmp.h. Use HAVE_NATIVE_mpn_* to make these functions or + inlines. + + * gmp-impl.h: Move mpn_copyd, mpn_copyi here from gmp.h. + * gmp-impl.h (MPN_COPY_INCR): Use mpn_copyi if available. + * gmp-impl.h (MPN_COPY_DECR): Use mpn_copyd if available. + + * mpn/x86/k6/mmx/com_n.asm: Moved into mmx subdirectory. + * mpn/x86/k6/mmx/copyi.asm: Ditto. + * mpn/x86/k6/mmx/lshift.asm: Ditto. + * mpn/x86/k6/mmx/rshift.asm: Ditto. + * mpn/x86/k7/mmx/rshift.asm: Ditto. + * mpn/x86/k6/mmx/logops_n.asm: New file. + * configure.in (k6*-*-*): Add logops_n.asm. + * mpn/x86/k6/README: Update. + + * mpn/x86/k7/mmx/copyi.asm: New file. + * mpn/x86/k7/mmx/copyd.asm: New file. + * mpn/x86/k7/README: Update. + +2000-02-24 Kevin Ryde + + * mpn/x86/x86-defs.m4 (femms): Generate emms if 3dnow not available. + * mpn/x86/x86-defs.m4 (FRAME_popl): New macro. + + * Makefile.am: Add info_TEXINFOS = gmp.texi + + * mpn/x86/divrem_1.asm: Moved from mpn/x86/k6, allow size==0, + conditionalize loop versus decl/jnz. + * mpn/x86/mod_1.asm: Ditto. + * mpn/x86/divmod_1.asm: Removed. + * gmp.texi (mpn_divrem_1,mpn_mod_1): Add that size==0 is allowed. + * mpn/tests/ref.c (refmpn_divrem_1c,etc): Allow size==0. + + * mpn/x86/k6/aors_n.asm: Avoid gas 1.92.3 leal displacement + expression problem. + * mpn/x86/k6/aorsmul_1.asm: Ditto. + * mpn/x86/k6/mul_1.asm: Ditto. + * mpn/x86/k6/mul_basecase.asm: Ditto + * mpn/x86/k7/aors_n.asm: Ditto. + * mpn/x86/k7/aorsmul_1.asm: Ditto. + * mpn/x86/k7/mul_1.asm: Ditto. + * mpn/x86/k7/mul_basecase.asm: Ditto. + * mpn/x86/k7/rshift.asm: Ditto. + * mpn/x86/p6/aorsmul_1.asm: Ditto. + * mpn/x86/README.family: Describe problem. + +2000-02-24 Linus Nordberg + + * acinclude.m4 (GMP_CHECK_ASM_LSYM_PREFIX): Add dummy symbol to + testcase to avoid nm failure. Try nm before piping to grep. + + * acconfig.h: Undef HAVE_NATIVE_func for every mpn function found + in gmp.h. + + * configure.in: Invoke AC_CONFIG_HEADERS. + Don't invoke AM_CONFIG_HEADER; it makes autoconf confused. + Dig out entry points declared in assembly code and AC_DEFINE proper + HAVE_NATIVE_func. + + * mpn/asm-defs.m4 (MULFUNC_PROLOGUE): New macro. + + * mpn/x86/p6/aorsmul_1.asm: Use MULFUNC_PROLOGUE. + * mpn/x86/k6/aors_n.asm: Likewise. + + * Makefile.am (EXTRA_DIST): Add config.in; needed when we don't + use AM_CONFIG_HEADER in configure.in. + + * mpn/Makefile.am (INCLUDES): Add `-I..' for config.h and + gmp-mparam.h. + * mpf/Makefile.am: Likewise. + * mpq/Makefile.am: Likewise. + * mpz/Makefile.am: Likewise. + + * mpf/tests/Makefile.am (INCLUDES): Add `-I../..' for config.h and + gmp-mparam.h. + * mpq/tests/Makefile.am: Likewise. + * mpz/tests/Makefile.am: Likewise. + + * configure: Regenerate. + * aclocal.m4: Regenerate. + * config.in: Regenerate. + * Makefile.in: Regenerate. + * mpf/Makefile.in: Regenerate. + * mpn/Makefile.in: Regenerate. + * mpq/Makefile.in: Regenerate. + * mpz/Makefile.in: Regenerate. + * mpf/tests/Makefile.in: Regenerate. + * mpq/tests/Makefile.in: Regenerate. + * mpz/tests/Makefile.in: Regenerate. + +2000-02-23 Kevin Ryde + + * mpn/x86/addmul_1.S: Amend comments, this code no longer used by + PentiumPro. + * mpn/x86/submul_1.S: Ditto. + + * mpn/x86/k6/com_n.asm: Rewrite, smaller but same speed. + + * mpn/x86/addmul_1.S: Add PROLOGUE and EPILOGUE to get .type and + .size for ELF. Rename #define size to n to avoid .size. + * mpn/x86/lshift.S: Ditto. + * mpn/x86/mul_1.S: Ditto. + * mpn/x86/mul_basecase.S: Ditto. + * mpn/x86/rshift.S: Ditto. + * mpn/x86/submul_1.S: Ditto. + * mpn/x86/udiv.S: Ditto. + * mpn/x86/umul.S: Ditto. + * mpn/x86/pentium/add_n.S: Ditto. + * mpn/x86/pentium/addmul_1.S: Ditto. + * mpn/x86/pentium/lshift.S: Ditto. + * mpn/x86/pentium/mul_1.S: Ditto. + * mpn/x86/pentium/mul_basecase.S: Ditto. + * mpn/x86/pentium/rshift.S: Ditto. + * mpn/x86/pentium/sub_n.S: Ditto. + * mpn/x86/pentium/submul_1.S: Ditto. + +2000-02-22 Linus Nordberg + + * acinclude.m4 (GMP_INIT): Use temporary file cnfm4p.tmp for + post-defines. + (GMP_FINISH): Ditto. + (GMP_DEFINE): Add third optional argument specifying location in + outfile. + (GMP_DEFINE_RAW): New macro. + * aclocal.m4: Regenerate. + + * configure.in: Add `HAVE_TARGET_CPU_$target_cpu' using + GMP_DEFINE_RAW. + * configure: Regenerate. + + * mpz/tests/Makefile.am: New test t-root. + * mpz/tests/Makefile.in: Regenerate. + +2000-02-22 Torbjorn Granlund + + * mpz/root.c: Complete rewrite; still primitive, but at least correct. + * mpz/tests/t-root.c: New test. + +2000-02-22 Kevin Ryde + + * mpn/x86/k7/mul_basecase.asm: New file. + * mpn/x86/k7/README: Add mpn_mul_basecase speed. + * mpn/x86/k7/gmp-mparam.h: New file. + + * mpn/x86/x86-defs.m4 (loop_or_decljnz,cmov_bytes): New macros. + * mpn/asm-defs.m4 (m4_ifdef_anyof_p): New macro. + + * mpn/x86/k6/aorsmul_1.asm: New file. + * mpn/x86/k6/addmul_1.S: Removed (was a copy of pentium version). + * mpn/x86/k6/submul_1.S: Removed (was a copy of pentium version). + + * mpn/x86/p6/aorsmul_1.asm: Use OPERATION_addmul_1 and + OPERATION_submul_1. + * mpn/x86/k6/aors_n.asm: Use OPERATION_add_n and OPERATION_sub_n. + * configure.in: Declare multi-function files for k6 and p6. + + * configure.in: Add HAVE_TARGET_CPU_$target_cpu for config.m4. + * mpn/asm-defs.m4 (define_not_for_expansion): New macro. + + * mpn/generic/divrem_1n.c (__gmpn_divrem_1n): New file, split from + mpn/generic/divrem_1.c. + * mpn/generic/divrem_1.c: Ditto. + * configure.in (gmp_mpn_functions): Ditto. + +2000-02-21 Torbjorn Granlund + + * gmp.h: Undo 1996-10-06 NeXT change, it was clearly improperly + written. + +2000-02-21 Linus Nordberg + + * configure.in: Link /mpn/asm-defs.m4 to mpn/asm.m4. + * configure: Regenerate. + +2000-02-21 Linus Nordberg + + * mpn/x86/k7/aorsmul_1.asm: Change OPERATION_ADDMUL --> + OPERATION_addmul_1. Change OPERATION_SUBMUL --> + OPERATION_submul_1. + + * mpn/x86/k7/aors_n.asm: Change OPERATION_ADD --> OPERATION_add_n. + Change OPERATION_SUB --> OPERATION_sub_n. + + * mpn/Makefile.am: Pass -DOPERATION_$* to preprocessors. + * mpn/Makefile.in: Regenerate. + + * configure.in: Symlink mpn/asm-defs.m4 to build-dir/mpn. Link + multi-function files to mpn/.asm and remove function + name from `gmp_mpn_functions'. + * configure: Regenerate. + + * acinclude.m4 (GMP_FINISH): Tell user what we're doing. + * aclocal.m4: Regenerate. + +2000-02-21 Kevin Ryde + + * gmp-impl.h: Rename __gmpn_mul_basecase to mpn_mul_basecase and + __gmpn_sqr_basecase to mpn_sqr_basecase, remove __gmpn prototypes. + * mpn/x86/mul_basecase.S: Ditto. + * mpn/x86/pentium/mul_basecase.S: Ditto. + + * configure.in (gmp_m4postinc): Use x86-defs.m4 on athlon-*-* too. + +2000-02-20 Kevin Ryde + + * acinclude.m4 (GSYM_PREFIX): Drop $1, change by Linus. + * mpn/asm-defs.m4 (PROLOGUE,EPILOGUE): Use GSYM_PREFIX as a + string, change by Linus. + * mpn/x86/x86-defs.m4: Use GSYM_PREFIX as a string. + + * mpn/x86/k6/gmp-mparam.h: New file. + * mpn/asm-defs.m4 (m4_warning): New macro. + + * mpn/x86/README: Amendments per new code and directories. + * mpn/x86/README.family: New file. + * mpn/x86/k6/README: New file. + * mpn/x86/k7/README: New file. + + * mpn/generic/mul_n.c: Rename __gmpn_mul_basecase to + mpn_mul_basecase and __gmpn_sqr_basecase to mpn_sqr_basecase. + * mpn/generic/mul_basecase.c: Ditto. + * mpn/generic/sqr_basecase.c: Ditto. + * mpn/generic/mul.c: Ditto. + +2000-02-19 Linus Nordberg + + * configure.in: Don't try to symlink more than one multi-func + file. + * configure: Regenerate. + +2000-02-18 Linus Nordberg + + * acinclude.m4 (GMP_CHECK_ASM_UNDERSCORE): GMP_DEFINE + `GSYM_PREFIX'. Run ACTIONs even when value is found in cache. + (GMP_CHECK_ASM_ALIGN_LOG): GMP_DEFINE `ALIGN'. Run ACTIONs even + when value is found in cache. + * aclocal.m4: Regenerate. + + * configure.in: Don't define GSYM_PREFIX or ALIGN. + Add mechanism for multi-function files. + * configure: Regenerate. + +2000-02-18 Kevin Ryde + + * configure.in (gmp_m4postinc): Enable x86-defs.m4. + * mpn/x86/k7/mul_1.asm: Fix include. + * mpn/x86/k6/mul_basecase.S: Removed (copy of the pentium version). + * mpn/x86/k6/mul_basecase.asm: New file. + * mpn/x86/k6/sqr_basecase.asm: New file. + * mpn/x86/k6/com_n.asm: New file. + * mpn/x86/k6/copyi.asm: New file. + * gmp.texi (Low-level Functions): Clarify mpn overlaps permitted. + * gmp-impl.h (MPN_OVERLAP_P): New macro. + * gmp-impl.h (assert_nocarry): New macro. + * mpn/tests/ref.c: New file, based in part on other mpn/tests/*.c. + * mpn/tests/ref.h: New file. + +2000-02-17 Linus Nordberg + + * Makefile.am (dist-hook): Don't include any emacs backup files + (*.~*) in dist. + * Makefile.in: Regenerate. + +2000-02-17 Torbjorn Granlund + + * mpn/sparc32/v9/mul_1.asm: Use `rd' to get current PC; get rid of + getpc function. + * mpn/sparc32/v9/addmul_1.asm: Likewise. + * mpn/sparc32/v9/submul_1.asm: Likewise. + +2000-02-17 Kevin Ryde + + * gmp.h: Add prototypes and defines for mpn_and_n, mpn_andn_n, + mpn_com_n, mpn_copyd, mpn_copyi, mpn_ior_n, mpn_iorn_n, + mpn_mul_basecase, mpn_nand_n, mpn_nior_n, mpn_sqr_basecase, + mpn_xor_n, mpn_xorn_n. + + * mpn/asm-defs.m4: Many additions making up initial version. + * mpn/asm-defs.m4 (L): Use defn(`LSYM_PREFIX'). + * mpn/x86/x86-defs.m4: New file. + * mpn/x86/k6/aors_n.asm: New file. + * mpn/x86/k6/divmod_1.asm: New file. + * mpn/x86/k6/divrem_1.asm: New file. + * mpn/x86/k6/lshift.S: Removed (was a copy of the pentium version). + * mpn/x86/k6/lshift.asm: New file. + * mpn/x86/k6/mod_1.asm: New file. + * mpn/x86/k6/mul_1.S: Removed (was a copy of the pentium version). + * mpn/x86/k6/mul_1.asm: New file. + * mpn/x86/k6/rshift.S: Removed (was a copy of the pentium version). + * mpn/x86/k6/rshift.asm: New file. + * mpn/x86/k7/aors_n.asm: New file. + * mpn/x86/k7/aorsmul_1.asm: New file. + * mpn/x86/k7/mul_1.asm: New file. + * mpn/x86/k7/rshift.asm: New file. + * mpn/x86/p6/aorsmul_1.asm: New file. + * mpn/x86/copyi.asm: New file. + * mpn/x86/copyd.asm: New file. + * mpn/lisp/gmpasm-mode.el: New file. + +2000-02-16 Torbjorn Granlund + + * mpn/sparc32/v9/mul_1.asm: Conditionalize for PIC. + * mpn/sparc32/v9/addmul_1.asm: Likewise. + * mpn/sparc32/v9/submul_1.asm: Likewise. + * mpn/sparc32/v8/supersparc/udiv.asm: Likewise. + * mpn/sparc32/udiv_fp.asm: Likewise. + +2000-02-16 Linus Nordberg + + * configure.in: Add mechanism for including target specific + m4-files in config.m4. + * configure: Regenerate. + + * acinclude.m4 (GMP_PROG_CCAS): Begin assembly lines (except + labels) with a tab character. HP-UX demands it. + (GMP_CHECK_ASM_SIZE): Ditto. + (GMP_CHECK_ASM_LSYM_PREFIX): Ditto. + (GMP_CHECK_ASM_LABEL_SUFFIX): Set to empty string for HP-UX. + (GMP_CHECK_ASM_GLOBL): Change `.xport' --> `.export'. + * aclocal.m4: Regenerate. + +2000-02-16 Linus Nordberg + + * acinclude.m4 (GMP_CHECK_ASM_LSYM_PREFIX): Define LSYM_PREFIX as + the prefix only, no argument. + * aclocal.m4: Regenerate. + * configure: Regenerate. + + * mpn/asm-defs.m4 (L): No argument to LSYM_PREFIX. + +2000-02-15 Linus Nordberg + + * acinclude.m4: Prefix all temporary shell variables with + `gmp_tmp_'. + (GMP_PROG_CC_FIND): Use defaults if no arguments are passed. + Quote use of arguments. + (GMP_PROG_CCAS): New macro. + (GMP_INIT): New macro. + (GMP_FINISH): New macro. + (GMP_INCLUDE): New macro. + (GMP_SINCLUDE): New macro. + (GMP_DEFINE): New macro. + (GMP_CHECK_ASM_LABEL_SUFFIX): New macro. + (GMP_CHECK_ASM_TEXT): New macro. + (GMP_CHECK_ASM_DATA): New macro. + (GMP_CHECK_ASM_GLOBL): New macro. + (GMP_CHECK_ASM_TYPE): New macro. + (GMP_CHECK_ASM_SIZE): New macro. + (GMP_CHECK_ASM_LSYM_PREFIX): New macro. + (GMP_CHECK_ASM_W32): New macro. + * aclocal.m4: Regenerate. + + * configure.in: Find m4 and nm for target. + Use new macros to create config.m4. + Prefix all temporary shell variables with `tmp_'. + Pass `-X 64' to nm for 64-bit PPC target with 64-bit compiler. + * configure: Regenerate. + + * Makefile.am (dist-hook): *Really* remove all CVS dirs in + dist. + * Makefile.in: Regenerate. + + * mpn/Makefile.am: Add target for building .lo and .o from + .asm. + Pass -DPIC to preprocessor (CPP/m4) when building .lo. + Build .o a second time for target .lo, without -DPIC to + preprocessor. + (SUFFIX): Add `.asm'. + (EXTRA_DIST): Add asm-defs.m4. + * mpn/Makefile.in: Regenerate. + + * mpf/Makefile.in: Regenerate. + * mpf/tests/Makefile.in: Regenerate. + * mpq/Makefile.in: Regenerate. + * mpq/tests/Makefile.in: Regenerate. + * mpz/Makefile.in: Regenerate. + * mpz/tests/Makefile.in: Regenerate. + +2000-02-15 Torbjorn Granlund + + * mpn/sparc32/udiv_fp.asm: Change `RODATA' to `DATA'. + * mpn/sparc32/v8/supersparc/udiv.asm: Likewise. + * mpn/sparc32/v9/addmul_1.asm: Likewise. + * mpn/sparc32/v9/submul_1.asm: Likewise. + * mpn/sparc32/v9/mul_1.asm: Likewise. + + * mpn/sparc32/add_n.asm: Rename `size' -> `n'. + * mpn/sparc32/sub_n.asm: Likewise. + + * sparc32: Rename `.s' and `.S' files to `.asm'. + * sparc64: Rename `.s' and `.S' files to `.asm'. + +2000-02-11 Torbjorn Granlund + + * config.sub: Adopt to new config.guess sparc naming conventions. + + * config.guess (sun4u:SunOS:5.*:*): Change `sparc9' to `sparcv9'. + * config.guess (sun4m:SunOS:5.*:*): Change to sun4[md]:SunOS:5.*:* and + change `sparc8' to `sparcv8'. + + * mpn/x86/add_n.S: Use PROLOGUE/EPILOGUE. + * mpn/x86/sub_n.S: Likewise. + + * mpn/x86/syntax.h (PROLOGUE): New name for PROLOG. + * mpn/x86/syntax.h (EPILOGUE): New name for EPILOG. + +2000-02-11 Linus Nordberg + + * configure.in: Better path for 64-bit sparc without 64-bit cc. + Change sparc8 --> sparcv8. + Change sparc9 --> sparcv9. + * configure: Regenerate. + +2000-02-10 Linus Nordberg + + * configure.in: Use Autoconf. + * Makefile.am: New file. + + * AUTHORS: New file. + * COPYING: New file. + * acinclude.m4: New file. + * acconfig.h: New file. + + * configure: Generate. + * Makefile.in: Generate. + * aclocal.m4: Generate. + * config.in: Generate. + + * install.sh: Remove. + * install-sh: New file from Automake. + * missing: New file from Automake. + * ltconfig: New file from Libtool. + * ltmain.sh: New file from Libtool. + + * mpf/Makefile.am: New file. + * mpf/Makefile.in: Generate. + * mpf/configure.in: Remove. + * mpf/tests/Makefile.am: New file. + * mpf/tests/Makefile.in: Generate. + * mpf/tests/configure.in: Remove. + + * mpn/Makefile.am: New file. + * mpn/Makefile.in: Generate. + * mpn/configure.in: Remove. + + * mpq/Makefile.am: New file. + * mpq/Makefile.in: Generate. + * mpq/configure.in: Remove. + * mpq/tests/Makefile.am: New file. + * mpq/tests/Makefile.in: Generate. + * mpq/tests/configure.in: Remove. + + * mpz/Makefile.am: New file. + * mpz/Makefile.in: Generate. + * mpz/configure.in: Remove. + * mpz/tests/Makefile.am: New file. + * mpz/tests/Makefile.in: Generate. + * mpz/tests/configure.in: Remove. + +2000-02-10 Torbjorn Granlund + + * mpn/x86/add_n.S: Don't use label L0 twice. + * mpn/x86/sub_n.S: Likewise. + +2000-01-20 Linus Nordberg + + * demos/pexpr.c: Don't use setup_error_handler() in windoze. + +2000-01-19 Torbjorn Granlund + + * demos/pexpr.c (sigaltstack): #define to sigstack for AIX. + (setup_error_handler): Don't write to ss_size and ss_flags + on AIX. + +2000-01-11 Torbjorn Granlund + + * mpn/configure.in (hppa2.0*-*-*): Move assignment of + target_makefile_frag to where it belongs. + +1999-12-21 Torbjorn Granlund + + * longlong.h (v9 umul_ppmm): New #define. + (v9 udiv_qrnnd): New #define. + +1999-12-14 Torbjorn Granlund + + * mpn/generic/divmod_1.c: Use invert_limb. + * mpn/generic/mod_1.c: Use invert_limb. + + * gmp-impl.h (invert_limb): Put definition here. + * mpn/generic/divrem.c (invert_limb): Delete definition. + * mpn/generic/divrem_2.c (invert_limb): Delete definition. + + * gmp.h (mpn_divrem): Inhibit for non-gcc. + But declare (undo 1999-11-22 change). + + * gmp-impl.h (DItype,UDItype): Do these also if _LONG_LONG_LIMB. + + * longlong.h: Move 64-bit hppa code out of __GNUC__ conditional. + + * stack-alloc.c (HSIZ): New #define. + (__tmp_alloc): Use HSIZ instead of sizeof(tmp_stack). + +1999-12-10 Torbjorn Granlund + + * config.sub: Clean up handling of x86 CPUs: Properly recognize + Amd CPUs as unique entities. Use manufacturer's names of + processors ("pentium", etc); still match ambiguous names like + "i586", "i686", "p6" but be conservative in interpreting them. + + * configure.in: Recognize x86 CPU types known by config.guess. + * mpn/configure.in: Likewise. Add x86/mmx path component as + appropriate. + (athlon-*-*): Fix typo. + + * config.guess: Update x86 recog code to initially match + more than just i386. + Call K6-2 and K6-III for "k62" and "k63" respectively. + + * config.guess: Recognize x86 CPU types. + Update code for FreeBSD, NetBSD, OpenBSD, Linux. + +1999-12-08 Torbjorn Granlund + + * mpf/pow_ui.c: Avoid final squaring in loop. + +1999-12-07 Torbjorn Granlund + + * gmp-impl.h (udiv_qrnnd_preinv2gen): Prefix local variables with `_'. + (udiv_qrnnd_preinv2norm): Likewise. + From Kevin Ryde: + (HAVE_ALLOCA): #define also if defined (alloca). + +1999-12-04 Torbjorn Granlund + + * mpn/tests/add_n.c: Set OPS from CLOCK. + * mpn/tests/sub_n.c: Likewise. + * mpn/tests/mul_1.c: Likewise. + * mpn/tests/addmul_1.c: Likewise. + * mpn/tests/submul_1.c: Likewise. + + * mpn/tests/lshift.c: Update from add_n.c. + * mpn/tests/rshift.c: Likewise. + +1999-12-03 Torbjorn Granlund + + * mpn/powerpc64/copy.S: New file. + +1999-12-02 Torbjorn Granlund + + * mpn/sparc64/copy.s: New file. + + * mpn/tests/copy.c: New file. + + * mpn/configure.in: Recognize more Amd CPUs; Set special paths for + k7 CPU. + + * configure.in: Recognize Amd x86 CPUs. + + * mpz/fdiv_r_2exp.c: In rounding code, read in->_mp_size before + writing to res->_mp_size. + + * mpn/powerpc64/*.S: Clean up assembly syntax, add function headers. + * mpn/powerpc64/gmp-mparam.h: (KARATSUBA_MUL_THRESHOLD): #define. + (KARATSUBA_SQR_THRESHOLD): #define. + + * mpn/tests/add_n.c (main): Only print test number if TIMES==1 + and not printing. + (main): Don't run reference code if NOCHECK. + * mpn/tests/sub_n.c: Likewise. + * mpn/tests/mul_1.c: Likewise. + * mpn/tests/addmul_1.c: Likewise. + * mpn/tests/submul_1.c: Likewise. + + * mpn/tests/lshift.c: (main): Only print test number if TIMES==1 + and not printing. + * mpn/tests/rshift.c: Likewise. + +1999-11-22 Torbjorn Granlund + + * gmp.h (mpz_init_set_str): Declare using __gmp_const. + (mpz_set_str): Likewise. + (mpf_init_set_str): Likewise. + (mpf_set_str): Likewise. + (mpn_set_str): Likewise. + (__gmp_0): Likewise. + (mpn_divrem): Remove separate declaration; it's defined later in + this file. + + * gmp.h: Replace "defined (__STD__)' by (__STDC__-0) in + expressions involving more than one term, to handle Sun's compiler + that most helpfully sets __STDC__ to 0. + * gmp-impl.h: Likewise. + * longlong.h: Likewise. + +1999-11-21 Torbjorn Granlund + + * mpn/sparc64/gmp-mparam.h (KARATSUBA_MUL_THRESHOLD): #define. + (KARATSUBA_SQR_THRESHOLD): #define. + + * mpn/sparc64/lshift.s: Compensate stack references for odd stack ptr. + * mpn/sparc64/rshift.s: Likewise. + + * mpn/sparc64/addmul_1.s: Propagate carry properly. + * mpn/sparc64/submul_1.s: Likewise. + + * mpn/sparc64/sub_n.s: Rewrite. + + * mpn/sparc64/sub_n.s: Get operand order for main subcc right + (before scrapping this code for new code). + +1999-11-20 Torbjorn Granlund + + * mpn/sparc64/add_n.s: Rewrite. + +1999-11-17 Torbjorn Granlund + + * mpn/x86/syntax.h (PROLOG): New #define. + (EPILOG): New #define. + + * gmp.h (mpn_addsub_n): Declare. + * gmp.h (mpn_add_nc): Declare. + * gmp.h (mpn_sub_nc): Declare. + * mpn/powerpc64/addsub_n.S: New file. + +1999-11-17 Torbjorn Granlund + + * mpn/alpha/gmp-mparam.h + (KARATSUBA_MUL_THRESHOLD): Only #define #ifndef. + (KARATSUBA_SQR_THRESHOLD): Likewise. + +1999-11-14 Torbjorn Granlund + + * mpn/x86/mul_1.S: Unroll and optimize for P6 and K7. + +1999-11-09 Torbjorn Granlund + + * mpn/x86/p6/gmp-mparam.h + (KARATSUBA_MUL_THRESHOLD): Only #define #ifndef. + (KARATSUBA_SQR_THRESHOLD): Likewise. + +1999-11-05 Torbjorn Granlund + + * mpn/generic/addsub_n.c: New file. + +1999-11-02 Torbjorn Granlund + + * config.guess: Handle alpha:FreeBSD with alpha:NetBSD. + + * configure.in (vax*-*-*): New case. + * config/mt-vax: New file. + * mpn/vax/add_n.s: Rewrite. + * mpn/vax/sub_n.s: Rewrite. + +1999-10-31 Torbjorn Granlund + + * mpn/vax/rshift.s: New file. + * mpn/vax/lshift.s: New file. + +1999-10-29 Torbjorn Granlund + + * config.sub: Handle k5 and k6. + * mpn/configure.in: Recognize k6. + + * mpf/tests/t-get_d.c (LOW_BOUND, HIGH_BOUND): New #defines. + (main): Tighten error bounds to 14 digits. + + * longlong.h (default umul_ppmm, when smul_ppmm exists): + Rename __m0 => __xm0, __m1 => __xm1. + (default smul_ppmm): Likewise. + +1999-10-11 Torbjorn Granlund + + * config.guess: Reverse the test for POWER vs PowerPC. + * config.guess (sun4m:SunOS:5.*:*): New case. + * config.guess (sun4u:SunOS:5.*:*): New case. + +1999-09-29 Torbjorn Granlund + + * mpn/generic/divrem_2.c: Clean up comments. + +1999-09-23 Torbjorn Granlund + + * mpz/tests/Makefile.in: Use move-if-change when generating binaries. + * mpf/tests/Makefile.in: Likewise. + * mpq/tests/Makefile.in: Likewise. + * mpz/tests/move-if-change: New file. + * mpf/tests/move-if-change: New file. + * mpq/tests/move-if-change: New file. + + * gmp.h (mpn_incr_u): New macro (from mpn/generic/mul_n.c). + (mpn_decr_u): New macro. + + * mpn/generic/mul_n.c (mpn_incr): Delete. + * mpn/generic/mul_n.c: Update usages mpn_incr => mpn_incr_u. + * mpn/generic/divrem_newt.c: Use mpn_incr_u and mpn_decr_u instead of + mpn_add_1 and mpn_sub_1. + * mpn/generic/sqrtrem.c: Likewise. + * mpz/cdiv_q_ui.c: Likewise. + * mpz/cdiv_qr_ui.c: Likewise. + * mpz/fdiv_q_ui.c: Likewise. + * mpz/fdiv_qr_ui.c: Likewise. + + * mpn/generic/sqrtrem.c: Start single-limb Newton iteration from 18 + bits. + +1999-07-27 Torbjorn Granlund + + * mpn/generic/divrem_1.c (__gmpn_divrem_1n): New function. + + * mpn/generic/divrem_2.c: New file, code from divrem.c, `case 2:'. + * mpn/Makefile.in: Compile divrem_2.c. + * make.bat: Compile divrem_2.c. + * mpn/configure.in (functions): Add divrem_2. + * gmp.h: Declare mpn_divrem_2. + + * mpn/generic/divrem.c: Delete special cases, handle just divisors + of more than 2 limbs. + * gmp.h (mpn_divrem): Call mpn_divrem_1, mpn_divrem_2, as appropriate. + + * mpn/generic/divrem.c: Rework variable usage for better register + allocation. + +1999-07-26 Torbjorn Granlund + + * mpn/alpha/ev5/add_n.s: Rewrite for better ev6 speed. + * mpn/alpha/ev5/sub_n.s: Likewise. + +1999-07-21 Torbjorn Granlund + + * longlong.h (alpha): Define umul_ppmm for cc. + + * gmp-impl.h (DItype, UDItype): Define for non-gcc if _LONGLONG is + defined. + +1999-07-15 Torbjorn Granlund + + * longlong.h (powerpc64 count_leading_zeros): Fix typo. + (powerpc64 add_ssaaaa): Fix typos. + (powerpc64 sub_ddmmss): Fix typos. + +1999-07-14 Torbjorn Granlund + + * mpz/tests/Makefile.in: Pass XCFLAGS when linking. + * mpf/tests/Makefile.in: Likewise. + * mpq/tests/Makefile.in: Likewise. + * mpn/Makefile.in (.S.o): Pass XCFLAGS. + + * longlong.h: Add support for 64-bit PowerPC. + * config.sub: Handle "powerpc64". + * configure.in: Likewise. + * mpn/configure.in: Suppress use of config/t-ppc-aix for now, + it seems compiler passes proper options. + * mpn/powerpc64/*.S: New files. + + * Makefile.in (FLAGS_TO_PASS): Pass "AR=$(AR)". + +1999-07-07 Torbjorn Granlund + + * demos/pexpr.c (factor): Change alloca call to a malloc/free pair. + + * mpn/powerpc32/syntax.h: Add #define's for crN. + + * gmp.h (gmp_rand_algorithm): Remove spurious `,'. + +1999-07-05 Torbjorn Granlund + + * mpn/generic/divrem_1.c: Normalize divisor when needed. + +1999-07-02 Torbjorn Granlund + + * mpn/configure.in (powerpc*-apple-mach): New configuration. + * mpn/powerpc32/*: Add support for apple-macho syntax. + * mpn/powerpc32/syntax.h: New file. + * gmp-impl.h: Don't use `__attribute__' syntax for Apple's perversion + of GCC. + +1999-05-26 Linus Nordberg + + * rand.c (gmp_rand_init): Fix typo. + + * mpn/generic/rawrandom.c (mpn_rawrandom): Count bits, not limbs, + to keep track of how many rounds to do in loop. Clean up + temporary allocation. Update `seedsize' inside loop. Mask off + the correct number of bits from final result. Init `mcopyp' even + when not normalizing `m'. + + * randlc.c (gmp_rand_init_lc): Fix typo (don't call + mpz_init_set_ui()). + + * mpn/generic/rawrandom.c (mpn_rawrandom): Set SIZ(s->seed) when + reallocating. + + * tests/rand/Makefile (test, bigtest): Add 33-bit tests. + + * tests/rand/gen.c (main): Set precision of variable passed to + mpf_urandomb(). Add option `-p'. + +1999-05-25 Linus Nordberg + + * randcm.c: Remove. + * randcmui.c: Remove. + * Makefile.in: Remove randcm and randcmui. + * make.bat: Ditto. + * gmp-impl.h: Remove prototypes for __gmp_rand_init_common() and + __gmp_rand_init_common_ui(). + * randlc.c (gmp_rand_init_lc): Don't call + __gmp_rand_init_common(). + + * randlcui.c (gmp_rand_init_lc_ui): Don't call + __gmp_rand_init_common_ui(). + + * gmp.h (__gmp_rand_state_struct): Remove unused member `maxval'. + * randclr.c (gmp_rand_clear): Remove reference to s->maxval. + * randcm.c (__gmp_rand_init_common): Ditto + + * mpn/generic/rawrandom.c (mpn_rawrandom): Don't calculate nlimbs + twice. + + * gmp.h (__gmp_rand_dist): Remove. + +1999-05-24 Linus Nordberg + + * mpn/generic/rawrandom.c: Clean up comments. + + * gmp.texi: Add documentation for random number generation. + +1999-05-21 Linus Nordberg + + * gmp.h: Typedef `gmp_rand_state' as an array with one element. + Change prototypes accordingly. + * gmp-impl.h: Change prototypes using `gmp_rand_state'. + * rand.c (gmp_rand_init): Take `gmp_rand_state' as argument + instead of a pointer to a `gmp_rand_state'. + * mpf/urandom.c (mpf_urandomb): Ditto. + * mpz/urandom.c (mpz_urandomb): Ditto. + * mpn/generic/rawrandom.c (mpn_rawrandom): Ditto. + * randcmui.c (__gmp_rand_init_common_ui): Ditto. + * randlc.c (gmp_rand_init_lc): Ditto. + * randlcui.c (gmp_rand_init_lc_ui): Ditto. + * randui.c (gmp_rand_init_ui): Ditto. + * randcm.c (__gmp_rand_init_common): Ditto. + * randclr.c (gmp_rand_clear): Ditto. + + * tests/rand/gen.c (main): Pass `s' to rand-funcs instead of address + of `s'. + +1999-05-20 Linus Nordberg + + * Makefile.in: Rename randi.c --> rand.c, randi_lc.c --> randlc.c, + randicom.c --> randcm.c. Add randui.c, randcmui.c, randlcui.c. + * make.bat: Ditto. + + * gmp.h: Add prototypes for gmp_rand_init_ui() and + gmp_rand_init_lc_ui(). + * gmp-impl.h: Add prototypes for __gmp_rand_init_common() and + __gmp_rand_init_common_ui(). + + * randlc.c, randcm.c, randclr.c, rand.c: Change #include of + to "gmp.h". + * randclr.c: Include stdlib.h for free(). + * rand.c: Include gmp-impl.h. + +1999-05-12 Torbjorn Granlund + + * mpn/configure.in: Put generic m68k alternative last. + +1999-05-04 Torbjorn Granlund + + * demos/pexpr.c (setup_error_handler): Use sigemptyset to create + empty set (for portability). + (fns): Fix typo '#if #if'. + (mpz_eval_expr): Implement FERMAT and MERSENNE. + + * demos/pexpr.c: Cast longjmp argument via long to silent warnings on + 64-bit hosts. + +1999-05-03 Torbjorn Granlund + + * demos/pexpr.c: Add #defines for GMP 1.x and 2.0 compatibility. + + * demos/pexpr.c (setup_error_handler): New function; take signal + handler setup code from main(), with major modifications to use modern + signal interface. + (main): Remove signal handler setup code; call setup_error_handler. + +1999-04-29 Linus Nordberg + + * tests/rand/findcl.c (main): Add option '-i' for interval factor. + Separate v and merit lose figures. Add '-v' for version. + +1999-04-28 Linus Nordberg + + * tests/rand/statlib.c: Change debugging stuff. + + * tests/rand/gmpstat.h: Add debug values definitions. + + * tests/rand/findcl.c (main): Print low and high merit on startup. + Print version string on startup. Catch SEGV and HUP. Add option -d + for debug. Fix bug making test for v too hard. + (sh_status): New function. + (sh_status): Flush stdout. Add RCSID. + +1999-04-27 Linus Nordberg + + * tests/rand/Makefile (clean): Add target. + +1999-04-27 Linus Nordberg + + * tests/rand/stat.c: Include gmpstat.h. + Add global int g_debug. + + * tests/rand/spect.c: Include . + + * tests/rand/findcl.c (main): Input is `m', not all factors of `m'. + Print only the very first matching multiplier. Include . + Flush stdout. Print "done." when done. + + * tests/rand/spect.c: Move everything but main() to statlib.c. + + * tests/rand/findcl.c: New file. + + * tests/rand/gmpstat.h: New file. + + * tests/rand/statlib.c (merit, merit_u, f_floor, vz_dot, + spectral_test): New functions. + +1999-04-27 Torbjorn Granlund + + * mpn/configure.in: Fix typo, "sparc-*)" was "sparc)". + +1999-04-21 Torbjorn Granlund + + * config.sub: Recognize ev6. + +1999-04-12 Linus Nordberg + + * urandom.c: Split up into randclr.c, randi.c, randi_lc.c, + randicom.c. + * randclr.c, randi.c, randi_lc.c, randicom.c: New files. + * Makefile.in: Remove urandom. Add randclr, randi, randi_lc, + randicom. + * make.bat: Ditto + +1999-03-31 Torbjorn Granlund + + * configure.in (sparc9-*-solaris2.[789]*, etc): New alternative. + * mpn/configure.in: Use mt-sprc9 also for ultrasparc*-*-solaris2*. + +1999-03-30 Linus Nordberg + + * urandom.c (__gmp_rand_scheme): Change NULL->0. + Include "gmp.h" instead of . + +1999-03-29 Linus Nordberg + + * gmp.h (__gmp_rand_data_lc): Now holds a, c, m instead of scheme + struct. + (__gmp_rand_lc_scheme_struct): Remove mpz_t's `a' and `m'. + + * tests/rand/stat.c (f_freq): Don't print 2nd level results if doing + 1st level. + + * tests/rand/gen.c (main): Set default algorithm to mpz_urandomb. + (main): Add option -c. + +1999-03-24 Linus Nordberg + + * tests/rand/Makefile (GMPINC): Rename to GMPH. + (GMPH): Add gmp-mparam.h. + (CFLAGS): Add -I$(GMPLIBDIR)/mpn + +1999-03-23 Linus Nordberg + + * Makefile.in: Compile top-dir/urandom.c. + * make.bat: Ditto. + + * mpn/Makefile.in: Compile rawrandom.c. + * make.bat: Ditto. + + * mpn/configure.in (functions): Add rawrandom. + + * gmp.h (__gmp_rand_scheme_struct): Rename to + __gmp_rand_lc_scheme_struct. + (__gmp_rand_data_lc): Remove member 'n'. Allocate a + __gmp_rand_lc_scheme_struct instead of a pointer to one. + Add prototype for gmp_rand_init_lc(), mpn_rawrandom(). + New prototype for mpz_urandomb(). + + * urandom.c: New file. + (__gmp_rand_init_common): New function. + (gmp_rand_init_lc): New function. + (gmp_rand_init): Don't init data_lc->n. Call gmp_rand_init_lc() + and __gmp_rand_init_common(). + (gmp_rand_clear): Remove reference to data_lc->n. + + * mpz/urandom.c (gmp_rand_init, gmp_rand_clear): Move to new file + urandom.c in top-dir. + (mpz_urandomb): Add function parameter nbits. Call mpn_rawrandom(). + + * mpf/urandom.c (mpf_urandomb): Call mpn_rawrandom(). + + * mpn/generic/rawrandom.c: New file. + (mpn_rawrandom): New function. + +1999-03-17 Torbjorn Granlund + + * extract-dbl.c: When packing result, adjust exp when sc == 0. + + * mpf/tests/t-get_d.c: New file. + * mpf/tests/Makefile.in: Compile t-get_d.c. + +1999-03-16 Linus Nordberg + + * mpz/urandom.c (__gmp_rand_scheme): Add extra braces around the + mpz_t members. + + * make.bat: Compile mpz/urandom.c and mpf/urandom.c + + * tests/rand/statlib.c (ks_table): Use mpf_pow_ui() and exp(). + + * tests/rand/gen.c: Include unistd.h for getopt. + +1999-03-15 Linus Nordberg + + * mpz/urandom.c (gmp_rand_init): New function. + (gmp_rand_clear): New function. + (mpz_urandomb): New function. + + * mpz/Makefile.in: Compile urandom.c + + * mpf/urandom.c (mpf_urandomb): New function. + + * mpf/Makefile.in: Compile urandom.c. + + * gmp.h (__gmp_rand_state_struct, __gmp_rand_scheme_struct): New + structs for randomization functions. + (gmp_rand_dist, gmp_rand_alogrithm): New enums for randomization + functions. + (mpz_urandomb, mpf_urandomb): Add prototype. + (gmp_rand_init, gmp_rand_clear): Add prototype. + + * tests/rand/gen.c, stat.c, statlib.c, statlib.h: New files. + * tests/rand/Makefile, tests/rand/ChangeLog: New files. + +1999-03-15 Torbjorn Granlund + + * .gdbinit: New file. + + * mpz/dump.c: New file. + * mpz/Makefile.in: Compile dump.c. + * make.bat: Likewise. + * gmp.h (mpz_dump): Declare. + +1999-03-14 Torbjorn Granlund + + * mpz/tests/reuse.c: Also test mpz_invert and mpz_divexact. + + * mpz/tests/convert.c: Update to GMP 2 variable syntax. + +1999-03-13 Torbjorn Granlund + + * mpf/README: New file. + * mpz/README: New file. + + * mpf/pow_ui.c: New file. + * mpf/Makefile.in: Compile pow_ui.c. + * make.bat: Likewise. + * gmp.h (mpf_pow_ui): Declare. + +1999-03-12 Torbjorn Granlund + + * mpn/configure.in: Stage 1 of rewrite. + * mpn/underscore.h: New name for bsd.h. + * mpn/sysv.h: Deleted. + + * mpn/m68k/*: Don't include sysdep.h. + + * mpn/pa64/README: New file. + +1999-03-11 Torbjorn Granlund + + * mpn/powerpc32/add_n.S: Add support for both AIX and ELF syntax. + Renamed from `.s'. + * mpn/powerpc32/sub_n.S: Likewise. + * mpn/powerpc32/lshift.S: Likewise. + * mpn/powerpc32/rshift.S: Likewise. + * mpn/powerpc32/mul_1.S: Likewise. + * mpn/powerpc32/addmul_1.S: Likewise. + * mpn/powerpc32/submul_1.S: Likewise. + + * mpn/powerpc32/umul.S: New file. + * mpn/sparc32/v8/umul.S: New file. + * mpn/sparc32/umul.S: New file. + * mpn/x86/umul.S: New file. + * mpn/x86/udiv.S: New file. + + * mpn/Makefile.in (mul_basecase.o): Delete rule. + +1999-02-22 Torbjorn Granlund + + * configure.in (hppa2.0*-*-*): Force use of GCC. + + * extract-dbl.c: Handle IEEE denormalized numbrs. Clean up. + +1998-12-02 Torbjorn Granlund + + * mpn/Makefile.in (CCAS): New macro. + (.s.o): Use CCAS. + (.S.o): Likewise. + + * mpn/Makefile.in (mul_basecase.o): Add dependency. + (sqr_basecase.o): Likewise. + (mod_1.o): Likewise. + + * demos/pexpr.c (cputime): Test also __hpux. + (cleanup_and_exit): Check SIGXCPU only #ifdef LIMIT_RESOURCE_USAGE. + + * mpz/tests/t-2exp.c: Use urandom, not random. + + * mpn/configure.in (arm*-*-*): New alternative. + +1998-11-30 Torbjorn Granlund + + * gmp-impl.h (union ieee_double_extract): Special case for + little-endian arm. + (LIMBS): Alias for PTR. + +1998-11-26 Torbjorn Granlund + + * longlong.h (m68000 umul_ppmm): Use `muluw', not `mulu'. + (m68k stuff): Clean up; add coldfire support. + +1998-11-23 Torbjorn Granlund + + * mpn/mips3/gmp-mparam.h (KARATSUBA_MUL_THRESHOLD): #define. + (KARATSUBA_SQR_THRESHOLD): #define. + + * mpn/sparc32/v9/README: New file. + +1998-11-20 Torbjorn Granlund + + * mpn/x86/README: New file. + + * mpn/arm/gmp-mparam.h: New file. + * mpn/pa64/gmp-mparam.h: New file. + * mpn/hppa/gmp-mparam.h: New file. + * mpn/x86/pentium/gmp-mparam.h: New file. + * mpn/sparc32/v9/gmp-mparam.h: New file. + * mpn/powerpc32/gmp-mparam.h: New file. + * mpn/x86/p6/gmp-mparam.h: New file. + + * mpn/alpha/gmp-mparam.h (KARATSUBA_MUL_THRESHOLD): #define. + (KARATSUBA_SQR_THRESHOLD): #define. + + * mpn/configure.in: Point to x86/p6 when appropriate. + + * mpn/power/umul.s: New file. + * mpn/power/sdiv.s: New file. + * mpn/pa64/addmul_1.S: New file. + * mpn/pa64/submul_1.S: New file. + * mpn/pa64/mul_1.S: New file. + * mpn/pa64/udiv_qrnnd.c: New file. + * mpn/pa64/umul_ppmm.S: New file. + * mpn/mips2/umul.s: New file. + * mpn/m68k/mc68020/umul.s: New file. + * mpn/m68k/mc68020/udiv.s: New file. + * mpn/hppa/hppa1_1/umul.s: New file. + * mpn/alpha/umul.s: New file. + * mpn/a29k/udiv.s: New file. + * mpn/a29k/umul.s: New file. + +1998-11-17 Torbjorn Granlund + + * mpn/x86/mul_basecase.S: New file for non-pentiums. + * mpn/x86/mul_basecase.S: Move to mpn/x86/pentium. + +1998-11-16 Torbjorn Granlund + + * make.bat: Compile mul_basecase.c and sqr_basecase.c. + +1998-11-10 Torbjorn Granlund + + * mpz/invert.c: Defer writing to parameter `invert' until + end. + +1998-11-03 Torbjorn Granlund + + * mpn/pa64/udiv_qrnnd.c: Handle more border cases. + +1998-10-29 Torbjorn Granlund + + * insert-dbl.c: Special case biased exponents < 1; Get boundary for + Inf right. + + * longlong.h (COUNT_LEADING_ZEROS_NEED_CLZ_TAB): New #define. + +1998-10-28 Torbjorn Granlund + + * mpn/powerpc32/submul_1.s: Rewrite, optimizing for PPC604. + * mpn/powerpc32/addmul_1.s: Likewise. + * mpn/powerpc32/lshift.s: Likewise. + +1998-10-23 Torbjorn Granlund + + * config/mt-sprc9-gcc (XCFLAGS): Add -Wa,-xarch=v8plus. + + * mpn/sparc32/v9/submul_1.s: New file. + +1998-10-21 Torbjorn Granlund + + * mpn/config/mt-pa2hpux: New file. + * mpn/configure.in (hppa2.0*-*-*): Use new 64-bit code. + + * config.sub: Recognize hppa2.0 as CPU type. + + * longlong.h (64-bit hppa): Add umul_ppmm and udiv_qrnnd. + * mpn/pa64/mul_1.S: New file. + * mpn/pa64/addmul_1.S: New file. + * mpn/pa64/submul_1.S: New file. + * mpn/pa64/umul_ppmm.S: New file. + * mpn/pa64/udiv_qrnnd.c: New file. + +1998-10-20 Torbjorn Granlund + + * mpz/pprime_p.c: Pass 1L, not 1, to mpz_cmp_ui. + + * mpz/fdiv_q_2exp.c: Cast `long' argument to `mp_limb_t' for mpn calls. + * mpz/gcd_ui.c: Likewise. + * mpz/add_ui.c: Likewise. + * mpz/sub_ui.c: Likewise. + +1998-10-19 Torbjorn Granlund + + * mpn/generic/bdivmod.c: Avoid using switch statement with mp_limb_t + index. + +1998-10-17 Torbjorn Granlund + + * mpn/sparc32/v9/mul_1.s: Misc cleanups. + * mpn/sparc32/v9/addmul_1.s: Misc cleanups. + +1998-10-16 Torbjorn Granlund + + * mpn/tests/{add,sub,}mul_1.c: Print xlimb using mpn_print. + + * mpz/tests/t-powm.c (SIZE): Increase to 50. + (EXP_SIZE): New parameter; use it for computing exp_size. + +1998-10-15 Torbjorn Granlund + + * mpn/generic/divrem_newt.c: Use TMP_ALLOC interface. + + * mpn/generic/sqrtrem.c: Check BITS_PER_MP_LIMB before defining + assembly variants of SQRT. + +1998-10-14 Torbjorn Granlund + + * mpn/tests: Clean up timing routines. Don't include longlong.h + where it is not needed. + (mpn_print): Handle printing when _LONG_LONG_LIMB. + * mpn/tests/{add,sub,}mul_1.c: Generate xlimb with mpn_random2 + and do it whether TIMES != 1 or not. + + * mpn/generic/mul_n.c: Delay assignment of `sign' for lower + register pressure. + + * mpn/sparc32/v9/mul_1.s: New file. + + * config/mt-sprc9-gcc: New file. + * configure.in: Use it. + + * mpn/configure.in: Use sparc64 for Solaris 2.7 and later with a + sparc v9 CPU. + * mpn/configure.in: Use sparc32/v9 for Solaris 2.6 or earlier with + a sparc v9 CPU. + + * mpf/sub.c: In initial code for ediff == 0, limit precision + before jumping to `normalize'. + +1998-10-13 Torbjorn Granlund + + * mpn/hppa/hppa2_0/add_n.s: New file. + * mpn/hppa/hppa2_0/sub_n.s: New file. + * mpn/configure.in: Handle hppa2.0 (32-bit code for now). + + * config.guess: Update from egcs 1.1. + (9000/[3478]??:HP-UX:*:*): Properly return 2.0 for all known 2.0 + machines. + +1998-10-07 Torbjorn Granlund + + * mpz/root.c (mpz_root): New file. + * mpz/Makefile.in: Compile it. + * make.bat: Likewise. + * gmp.h (mpz_root): Declare. + + * mpz/perfpow.c: New file. + * mpz/Makefile.in: Compile it. + * make.bat: Likewise. + * gmp.h (mpz_perfect_power_p): Declare. + + * mpz/remove.c: New file. + * mpz/Makefile.in: Compile it. + * make.bat: Likewise. + * gmp.h (mpz_remove): Declare. + + * mpz/bin_ui.c: New file. + * mpz/Makefile.in: Compile it. + * make.bat: Likewise. + * gmp.h (mpz_bin_ui): Declare. + + * mpz/bin_uiui.c: New file. + * mpz/Makefile.in: Compile it. + * make.bat: Likewise. + * gmp.h (mpz_bin_uiui): Declare. + +1998-09-16 Torbjorn Granlund + + * longlong.h: Test for __powerpc__ in addition to _ARCH_PPC. + +Sat Sep 5 17:22:28 1998 Torbjorn Granlund + + * mpf/cmp_si.c: Compare most significant mantissa limb before + trying to deduce anything from the limb count. + * mpf/cmp_ui.c: Likewise. + +Tue Aug 18 10:24:39 1998 Torbjorn Granlund + + * mpz/pprime_p.c (mpz_probab_prime_p): Add new code block + for doing more dividing. + +Sat Aug 15 18:43:17 1998 Torbjorn Granlund + + * mpn/generic/divrem_newt.c: New name for divrem_newton.c. + * mpn/Makefile.in: Corresponding changes. + * mpn/configure.in: Likewise. + +Wed Aug 12 23:07:09 1998 Torbjorn Granlund + + * config.guess: Handle powerpc for NetBSD. + +Tue Jul 28 23:10:55 1998 Torbjorn Granlund + + * mpz/fib_ui.c: New file. + * mpz/Makefile.in: Compile it. + * make.bat: Likewise. + * gmp.h (mpz_fib_ui): Declare. + +Wed Jun 17 22:52:58 1998 Torbjorn Granlund + + * make.bat: Fix typo, `asm-synt.h' => `asm-syntax.h'. + +Wed Jun 3 11:27:32 1998 Torbjorn Granlund + + * config/mt-pwr: New file. + * config/mt-ppc: New file. + * configure.in: Use the new files. + +Tue Jun 2 13:04:17 1998 Torbjorn Granlund + + * mpn/sparc32/v9/addmul_1.s: New file. + * mpn/config/mt-sprc9: New file. + * mpn/configure.in: Use mt-sprc9. + +Tue May 26 11:24:18 1998 Torbjorn Granlund + + * demos/factorize.c (factor_using_pollard_rho): Pass correct + parameters in recursive calls; join the two recursion arms. + + * mpf/set_q.c: Set result sign. + When normalizing the numerator, don't allow it to increase in size + beyond prec. + +Tue May 19 17:28:14 1998 Torbjorn Granlund + + * demos/factorize.c (factor_using_division): Call fflush + also for the factor 2. + +Mon May 18 15:51:01 1998 Torbjorn Granlund + + * make.bat: Pass -fomit-frame-pointer. Do not pass -g. + +Tue May 5 01:42:50 1998 Torbjorn Granlund + + * mpz/Makefile.in (LOCAL_CC): Remove definition. + + * gmp.h: Get rid of GMP_SMALL stuff. + * mpz/Makefile.in: Likewise. + * mpq/Makefile.in: Likewise. + * mpf/Makefile.in: Likewise. + + * mpz/invert.c: Fix typo in comment. + +Mon May 4 23:05:32 1998 Torbjorn Granlund + + * mpn/generic/sqrtrem.c: Check that __arch64__ is not defined + before defining sparc SQRT. + +Mon Apr 20 19:16:17 1998 Torbjorn Granlund + + * mpn/generic/gcdext.c: Allow gp to be NULL. + +1998-04-03 Torbjorn Granlund + + * mpn/configure.in: Recognize `alphaev5*', not `alphaev5'. + + * config.guess: Handle CPU variants for NetBSD. + +Mon Mar 16 13:07:54 1998 Torbjorn Granlund + + * mpz/pprime_p.c: Use mpn_mod_1/mpn_preinv_mod_1 for computing mod PP, + not mpz_tdiv_r_ui (which expects an `unsigned long'). + (mpz_probab_prime_p): Change type of `r' to mp_limb_t. + +Thu Mar 12 17:19:04 1998 Torbjorn Granlund + + * gmp.h (mpf_ceil, mpf_floor, mpf_trunc): Add declarations. + + * config.guess: Update from FSF version. + * config.sub: Likewise. + + * config.guess: Add special handling of alpha-*-NetBSD. + +Wed Mar 11 00:55:34 1998 Torbjorn Granlund + + * mpz/inp_str.c: Update from set_str.c. + Properly increment `nread' when skipping minus sign. + + * mpz/set_str.c: Check for empty string after having skipped + leading zeros. + +Mon Mar 9 19:28:00 1998 Torbjorn Granlund + + * mpz/set_str.c: Skip leading zeros. + +Wed Mar 4 19:29:16 1998 Torbjorn Granlund + + * gmp.h (mpz_cmp_si): Cast argument before calling mpz_cmp_ui. + + * demos/factorize.c: Rewrite. + +1998-02-04 Torbjorn Granlund + + * configure.in (i[3456]86* etc): Check if using gcc before + choosing mt-x86. + + * configure.in (m68*-*-*): New alternative. + * config/mt-m68k: New file. + + * mpn/alpha/invert-limb.s: Put tables in text segment, + since not all systems support "rdata". + +Wed Feb 4 02:20:57 1998 Torbjorn Granlund + + * gmp.h (__GNU_MP_VERSION_SNAP): New #define. + (__GNU_MP_VERSION_MINOR): Now 1. + +Wed Jan 28 22:29:36 1998 Torbjorn Granlund + + * longlong.h (alpha udiv_qrnnd): #define UDIV_NEEDS_NORMALIZATION. + +Wed Jan 28 20:28:19 1998 Torbjorn Granlund + + * mpz/pprime_p.c (mpz_probab_prime_p): Delete 59 from tried divisors. + +Mon Jan 26 01:39:02 1998 Torbjorn Granlund + + * mpz/pprime_p.c (mpz_probab_prime_p): Major overhaul: Check small + numbers specifically; check small factors, then perform a fermat test. + +Tue Jan 13 14:58:28 1998 Torbjorn Granlund + + * longlong.h (alpha udiv_qrnnd): Call __mpn_invert_normalized_limb + and udiv_qrnnd_preinv. + +Wed Jan 7 01:52:54 1998 Torbjorn Granlund + + * mpn/configure.in (alpha*, extra_functions): Add invert-limb and + remove udiv_qrnnd. + + * mpn/tests/divrem.c: Get allocations right. + + * mpn/generic/divrem.c: Conditionally pre-invert most significant + divisor limb. + +Tue Jan 6 23:08:54 1998 Torbjorn Granlund + + * mpn/generic/divrem_1.c: Rename variables to comply to conventions. + Make `i' have type `mp_size_t'. + +Tue Dec 30 22:21:42 1997 Torbjorn Granlund + + * mpz/tdiv_qr_ui.c: Return the remainder. + * mpz/tdiv_r_ui.c: Likewise. + * mpz/tdiv_q_ui.c: Likewise. + * gmp.h: Change return type of mpz_tdiv_qr_ui, mpz_tdiv_r_ui, + mpz_tdiv_q_ui. + + * mpz/tdiv_ui.c: New file. + * mpz/Makefile.in: Compile it. + * make.bat: Likewise. + * gmp.h (mpz_tdiv_ui): Declare. + +Fri Nov 7 04:21:15 1997 Torbjorn Granlund + + * mpf/integer.c (FUNC_NAME): Fix bogus test for mpf_trunc. + + * demos/isprime.c: New file. + + Sat Nov 1 19:32:25 1997 Torbjorn Granlund + + * mpz/cmp_abs.c: New file. + * mpz/Makefile.in: Compile it. + * make.bat: Likewise. + * gmp.h (mpz_cmp_abs): Declare. + + * mpz/cmp_abs_ui.c: New file. + * mpz/Makefile.in: Compile it. + * make.bat: Likewise. + * gmp.h (mpz_cmp_abs_ui): Declare. + +Sat Sep 27 04:49:52 1997 Torbjorn Granlund + + * mpz/fdiv_r_2exp.c: Get allocation for `tmp' right. + + * mpz/fdiv_q_2exp.c: In final result adjustment code, handle + that intermediate result is zero. + + * mpz/tests/t-2exp.c: New file. + * mpz/tests/Makefile.in: Handle t-2exp.c. + +Fri Sep 26 16:29:21 1997 Torbjorn Granlund + + * mpz/divexact.c: Fix typo in test for whether to copy numerator to + quotient and move that statement to after handling quotient and + denominator overlap. Misc cleanups. + + * mpn/generic/gcd.c: Change count argument of mpn_lshift/mpn_rshift + calls to `unsigned int'. + * mpz/divexact.c: Likewise. + +Mon Sep 22 02:19:52 1997 Torbjorn Granlund + + * mpz/tests/t-powm.c: Decrease `reps' to 2500. + + * mpz/tests/t-pow_ui.c: New file. + * mpz/tests/Makefile.in: Handle t-pow_ui.c. + + * mpz/ui_pow_ui.c: Get special cases for exponent and base right. + + * mpz/pow_ui.c: Increase temp space allocation by 1 limb. + Split `rsize' into two variables; compute space allocation into + `ralloc'. + +Sun Sep 7 04:15:12 1997 Torbjorn Granlund + + * mpn/pa64/lshift.s: New file. + * mpn/pa64/rshift.s: New file. + * mpn/pa64/sub_n.s: New file. + +Sat Sep 6 19:14:13 1997 Torbjorn Granlund + + * mpn/pa64/add_n.s: New file. + * mpn/pa64: New directory. + +Tue Aug 19 16:17:09 1997 Torbjorn Granlund + + * mpz/swap.c: New file. + * mpz/Makefile.in: Compile it. + * make.bat: Likewise. + * gmp.h (mpz_swap): Declare. + + * mpn/generic/mul_n.c: Push assignment of x and y pointers into the + if/else clauses in several places. (Decreases register pressure.) + +Mon Aug 18 03:29:50 1997 Torbjorn Granlund + + * mpn/thumb/add_n.s: New file. + * mpn/thumb/sub_n.s: New file. + * mpn/arm/add_n.s: New file. + * mpn/arm/sub_n.s: New file. + + * mpz/powm.c: After mpn_mul_n and mpn_mul calls, adjust product size + if most significant limb is zero. + * mpz/powm_ui.c: Likewise. + +Fri Aug 15 02:13:57 1997 Torbjorn Granlund + + * mpn/arm/m/mul_1.s: New file. + * mpn/arm/m/addmul_1.s: New file. + + * mpn/powerpc32/mul_1.s: Rewrite. + + * mpn/alpha/mul_1.s: Prefix labels with `.'. + +Mon Aug 11 02:37:16 1997 Torbjorn Granlund + + * mpn/powerpc32/add_n.s: Rewrite. + * mpn/powerpc32/sub_n.s: Rewrite. + +Sun Aug 10 17:07:15 1997 Torbjorn Granlund + + * mpn/powerpc32/addmul_1.s: Delete obsolete comments. + * mpn/powerpc32/submul_1.s: Likewise. + +Fri Jul 25 20:07:54 1997 Torbjorn Granlund + + * mpz/addmul_ui.c: New file. + * mpz/Makefile.in: Compile it. + * make.bat: Likewise. + * gmp.h (mpz_addmul_ui): Declare. + + * mpz/setbit.c: Add missing code after final `else'. + +Tue Jul 22 17:45:01 1997 Torbjorn Granlund + + * mpn/sh/add_n.s: Fix typo. + * mpn/sh/sub_n.s: Likewise. + + * longlong.h (ns32k count_trailing_zeros): Fix typo. + + * insert-dbl.c: Check for exponent overflow and return Inf. + + * mpz/get_d.c: Rewrite to avoid rounding errors. + +Thu May 29 11:51:07 1997 Torbjorn Granlund + + * mpq/add.c: Swap some usages of tmp1 and tmp2 to make sure + their allocation suffices. + * mpq/sub.c: Likewise. + +Wed Apr 16 02:24:25 1997 Torbjorn Granlund + + * demos/pexpr.c: New file. + + * mpn/generic/mul_n.c: Misc optimizations from Robert Harley. + + * gmp-impl.h (MPZ_PROVOKE_REALLOC): New #define. + +Sat Apr 12 17:54:04 1997 Torbjorn Granlund + + * mpz/tstbit.c: New file. + * mpz/Makefile.in: Compile it. + * make.bat: Likewise. + * gmp.h (mpz_tstbit): Declare. + + * mpz/tests/logic.c: Use MPZ_CHECK_FORMAT. + * mpz/tests/bit.c: New test. + * mpz/tests/Makefile.in: Handle bit.c. + + * mpz/ior.c: In -OP2,+OP1 case, normalize OP2 after call to mpn_sub_1. + + * gmp-impl.h (MPZ_CHECK_FORMAT): New #define. + +Thu Apr 10 00:30:14 1997 Torbjorn Granlund + + * longlong.h (POWER/PowerPC): Test _ARCH_PWR instead of _IBMR2. + +Wed Apr 9 18:23:31 1997 Torbjorn Granlund + + * gmp-impl.h: Move defaulting of UMUL_TIME and UDIV_TIME from here... + * longlong.h: ...to here. + +Sun Mar 30 12:16:23 1997 Torbjorn Granlund + + * mpn/generic/next_prime.c: New file. + + * mpn/generic/perfsqr.c: Remove definitions of PP and PP_INVERTED. + * gmp-impl.h: Put them here. + +Fri Mar 28 08:18:05 1997 Torbjorn Granlund + + * gmp-impl.h (MPN_COPY_INCR, MPN_COPY_DECR): Define as inline asm for + for x86, but leave disabled for now. + +Fri Feb 28 02:39:47 1997 Torbjorn Granlund + + * mpn/Makefile.in (.S.o): Pass SFLAGS and CFLAGS also to compiler + for assembly phase. + (.s.o): Pass SFLAGS. + +Wed Feb 26 06:46:08 1997 Torbjorn Granlund + + * mpn/configure.in: For Pentium Pro, use default code, not Pentium + optimized code. + + * mpn/x86/addmul_1.S: Unroll and optimize for Pentium Pro. + * mpn/x86/submul_1.S: Likewise. + +Thu Feb 13 08:26:09 1997 Torbjorn Granlund + + * mpf/Makefile.in: Compile floor.o, ceil.o and trunc.o (from + integer.c). + * make.bat: Likewise. + +Wed Feb 5 05:58:44 1997 Torbjorn Granlund + + * mpn/configure.in (alpha*): Add cntlz to extra_functions. + +Wed Feb 4 03:30:45 1997 Torbjorn Granlund + + * mpf/integer.c: New file (supporting mpf_floor, mpf_ceil, mpf_trunc). + +Mon Feb 3 14:21:36 1997 Torbjorn Granlund + + * make.bat: Fix typo, set_dfl_prc => set_dfl_prec. + +Sun Feb 2 02:34:33 1997 Torbjorn Granlund + + * mpf/out_str.c: After outputting `-', decrement n_digits. + +Wed Jan 8 02:50:20 1997 Torbjorn Granlund + + * mpn/generic/divrem.c: qextra_limbs => qxn. + +Wed Dec 18 07:50:46 1996 Torbjorn Granlund + + * mpz/tests/t-tdiv.c (SIZE): Increase to 200. + +Tue Dec 17 19:32:48 1996 Torbjorn Granlund + + * mpn/generic/divrem.c (mpn_divrem_classic): New name for mpn_divrem. + * gmp.h (mpn_divrem): New function. + * mpn/generic/divrem_newton.c: New file. + * mpn/configure.in (functions): Add divrem_newton. + * make.bat: Likewise. + +Thu Dec 12 17:55:13 1996 Torbjorn Granlund + + * gmp.h (_GMP_H_HAVE_FILE): Test also __dj_include_stdio_h_. + +Sat Dec 7 09:40:06 1996 Torbjorn Granlund + + * mpn/alpha/invert-limb.s: New file. + +Thu Dec 5 01:25:31 1996 Torbjorn Granlund + + * mpz/ui_pow_ui.c (mpz_pow2): New (static) function. + (mpz_ui_pow_ui): Rewrite. + + * make.bat: `pre_mod_1.c' => `pre_mod_.c'. Fix typo in path to + gmp-mpar.h. + +Fri Nov 15 00:49:55 1996 Torbjorn Granlund + + * mpz/ui_pow_ui.c: Rewrite for better speed. + +Fri Nov 1 16:36:56 1996 Torbjorn Granlund + + * Makefile.in (recursive make rules): Use `&&' instead of `;' as + delimiter. + +Fri Oct 25 17:12:36 1996 Torbjorn Granlund + + * gmp-impl.h (Cray/uxp MPN_COPY): Really declare as inline. + +Thu Oct 24 15:08:19 1996 Torbjorn Granlund + + * mpn/fujitsu/rshift.c: Fix typo in loop boundaries. + +Fri Oct 18 03:13:54 1996 Torbjorn Granlund + + * mpn/configure.in: Recognize `nextstep' for m68k variants; likewise + for x86 variants. + + * mpn/x86/syntax.h (INSND): New macro. + * mpn/x86/[lr]shift.S: Use INSND. + * mpn/x86/pentium/[lr]shift.S: Likewise. + * mpn/config/t-oldgas (SFLAGS): Pass -DOLD_GAS. + + * gmp-impl.h: In code for determining endianness, test also + __BIG_ENDIAN__ and __hppa__. Remove test of __NeXT__. + +Wed Oct 16 03:50:34 1996 Torbjorn Granlund + + * mpf/set_str.c: Let `prec' determine precision used in + exponentiation code; decrease allocation accordingly. + + * mpn/vax: Change `jsob*' to `sob*' in all files. + +Tue Oct 15 03:54:06 1996 Torbjorn Granlund + + * longlong.h (m88110 udiv_qrnnd): Change type of intermediate quotient + to DImode (divu.d generates a 64-bit quotient). + + * configure.in (m88110*): Fix typo. + + * mpf/get_str.c: Compute exp_in_base using `double' to avoid overflow. + + * gmp-impl.h (struct bases): Change type of chars_per_bit_exactly from + float to double. + * mpn/mp_bases.c (__mp_bases): Give 17 digits for chars_per_bit_exactly + field. + + * mpf/get_str.c: Let `prec' determine precision used in + exponentiation code; decrease allocation accordingly. + +Sun Oct 13 03:31:53 1996 Torbjorn Granlund + + * longlong.h: Major cleanup. + (__udiv_qrnnd_c): Compute remainders using multiply and subtract, + not explicit `%' operator. + (C umul_ppmm): Get rid of a redundant __ll_lowpart. + + * mpz/invert.c: Properly detect all operands that would yield an + undefined inverse; make sure the inverse is always positive. + + * mpz/xor.c: New file. + * mpz/Makefile.in: Compile it. + * make.bat: Likewise. + * gmp.h (mpz_xor): Declare. + + * mpz/tests/logic.c: Also test mpz_xor. + + * mpz/lcm.c: Special case for when either operand equals 0. + +Sat Oct 12 01:57:09 1996 Torbjorn Granlund + + * mpn/generic/gcd.c (find_a): Don't inline on x86. + + * Makefile.in (CFLAGS): Default to just `-g'. + + * configure.in: Recognize 386 and 486 wherever other x86 cpus are + recognized. + * configure.in: Use mt-x86 for all x86 cpus. + * config/mt-x86: New file. + + * mpn/alpha/cntlz.s: New file. + +Tue Oct 8 00:16:18 1996 Torbjorn Granlund + + * longlong.h: Define smul_ppmm for Fujitsu vpp/uxp. + Rewrite umul_ppmm to actually work on the hardware. + + * mpn/x86/sub_n.S: Avoid parens around displacement of `leal'. + * mpn/x86/add_n.S: Likewise. + + * mpn/x86/syntax.h (R): Define differently depending on __STDC__. + +Mon Oct 7 16:48:08 1996 Torbjorn Granlund + + * longlong.h: Don't test for __NeXT__ in outer 68k conditional; + add test for __m68k__. + +Sun Oct 6 00:59:09 1996 Torbjorn Granlund + + * gmp.h: Declare mpn_random. + * make.bat: Compile mpn/generic/random.c. + + * longlong.h: Define umul_ppmm for Fujitsu vpp/uxp. + + * gmp-impl.h: Protect definitions using `__attribute__ ((mode (...)))' + with test also for __GNUC_MINOR__. + + * gmp.h: Don't define macros using __builtin_constant_p when using + NeXT's compiler. + +Fri Oct 4 16:53:50 1996 Torbjorn Granlund + + * mpz/lcm.c: New file. + * mpz/Makefile.in: Compile it. + * make.bat: Likewise. + * gmp.h (mpz_lcm): Declare. + +Wed Sep 25 00:06:21 1996 Torbjorn Granlund + + * mpq/tests/t-cmp_ui.c: Make sure numerator and denominator of `b' is + within limits of an `unsigned long int'. + + * mpz/tests/t-powm_ui.c: Change type of exp2 to `unsigned long int'. + +Tue Sep 24 18:58:20 1996 Torbjorn Granlund + + * mpz/powm_ui.c: Make result always positive. + + * urandom.h (urandom): Make it return mp_limb_t. + + * gmp-impl.h (CNST_LIMB): New macro. + * mpn/mp_bases.c: Use CNST_LIMB. + * mpn/generic/hamdist.c (popc_limb): Likewise. + * mpn/generic/popcount.c (popc_limb): Likewise. + * mpn/generic/perfsqr.c: Likewise. + +Fri Sep 20 03:08:10 1996 Torbjorn Granlund + + * mpz/pprime_p.c: When n <= 3, don't clear out n before using it. + +Wed Sep 18 11:22:45 1996 Torbjorn Granlund + + * mpn/fujitsu/mul_1.c: New file. + * mpn/fujitsu/addmul_1.c: New file. + * mpn/fujitsu/sub_n.c: New file. + * mpn/fujitsu/add_n.c: Mew file. + +Sun Sep 15 03:13:02 1996 Torbjorn Granlund + + * mpn/generic/random.c: New file. + * mpn/configure.in (functions): Add `random'. + + * gmp-impl.h (MPN_COPY): Define as annotated inline function for + Crays and Fujitsu VPPs. + + * gmp.h (mp_size_t): Define as `int' for non-MPP Cray. + (mp_exp_t): Likewise. + + * configure.in: Add support for Fujitsu VPP machines. + * mpn/configure.in: Likewise. + * config.guess: Likewise. + * config.sub: Likewise. + + * mpn/fujitsu/rshift.c: New file. + * mpn/fujitsu/lshift.c: New file. + * mpn/fujitsu: New directory, for Fujitsu VPP machines. + +Wed Sep 11 11:34:38 1996 Torbjorn Granlund + + * mpn/generic/mul_n.c (__gmpn_mul_n): New name for impn_mul_n. + Call __gmpn_mul_basecase, not impn_mul_n_basecase; update parameter + list to work with __gmpn_mul_basecase. + (__gmpn_sqr): New name for impn_sqr_n. + Call __gmpn_sqr_basecase, not impn_sqr_n_basecase; update parameter + list to work with __gmpn_sqr_basecase. + (mpn_mul_n): Update calls to match new names and parameter conventions. + * gmp-impl.h (MPN_MUL_N_RECURSE): Likewise. + (MPN_SQR_RECURSE): New name for MPN_SQR_N_RECURSE. + Update calls to match new names and parameter conventions. + * mpn/generic/mul.c: Never perform multiply explicitly here, call + __gmpn_mul_basecase instead. + Update calls to match new names and parameter conventions. + + * mpn/x86/mul_basecase.S: New file. + * mpn/generic/mul_basecase.c: New file. + * mpn/generic/sqr_basecase.c: New file. + +Wed Sep 4 02:59:21 1996 Torbjorn Granlund + + * mpz/set_str.c: Let `0b' and `0B' mean base 2. + +Fri Aug 30 00:44:00 1996 Torbjorn Granlund + + * longlong.h (x86 umul_ppmm): Work around GCC bug that was + triggered by Aug 28 change. + + * mpbsd/min.c (digit_value_in_base): New function. + + * mpz/set_str.c: Refine allocation size computation, use + chars_per_bit_exactly instead of chars_per_limb. + + * mpbsd/Makefile.in (.c.o): Add -D_mpz_realloc=_mp_realloc. + +Wed Aug 28 02:52:14 1996 Torbjorn Granlund + + * longlong.h (x86 umul_ppmm): Don't cast result operands. + (x86 udiv_qrnnd): Likewise. + (default smul_ppmm): Fix typo, umul_ppmm => smul_ppmm. + (default umul_ppmm): New #define using smul_ppmm. + (vax smul_ppmm): New #define. + (vax umul_ppmm): Delete. + (POWER umul_ppmm): Delete. + (IBM 370 smul_ppmm): New #define. + (IBM 370 umul_ppmm): Delete. + (IBM RT/ROMP smul_ppmm): New #define. + (IBM RT/ROMP umul_ppmm): Delete. + +Tue Aug 27 01:03:25 1996 Torbjorn Granlund + + * gmp-impl.h (__gmp_0): Make it `const'. + + * mpn/Makefile.in (clean mostlyclean): Comment out recursive clean + of `tests'. + + * mpn/generic/mul.c: Identify when we do squaring, and call + impn_sqr_n_basecase/impn_sqr_n as appropriate. Use + KARATSUBA_MUL_THRESHOLD and KARATSUBA_SQR_THRESHOLD. + Don't #define KARATSUBA_THRESHOLD. + + * mpn/generic/mul_n.c: Don't #define KARATSUBA_THRESHOLD. + (impn_mul_n, impn_sqr_n): Rewrite, based on code contributed by + Robert Harley. + (impn_sqr_n_basecase): Rewrite. + + * gmp-impl.h (KARATSUBA_MUL_THRESHOLD): New #define. + (KARATSUBA_SQR_THRESHOLD): Likewise. + (MPN_SQR_N_RECURSE): Use KARATSUBA_SQR_THRESHOLD. + (MPN_MUL_N_RECURSE): Use KARATSUBA_MUL_THRESHOLD. + + * configure.in: Fix typo in last change. + +Mon Aug 26 22:25:18 1996 Torbjorn Granlund + + * mpn/generic/random2.c: Fix typo, `alpha__' => `__alpha'. + * mpf/random2.c: Likewise. + +Sun Aug 25 00:07:09 1996 Torbjorn Granlund + + * mpz/tests/t-mul.c: Also test squaring. + +Fri Aug 16 05:12:08 1996 Torbjorn Granlund + + * mp_clz_tab.c (__clz_tab): Declare as `const'. + * version.c (gmp_version): Likewise. + * mpn/generic/sqrtrem.c (even_approx_tab, odd_approx_tab): Likewise. + +Thu Aug 15 02:34:47 1996 Torbjorn Granlund + + * gmp.h: Fix typo, `mips__' => `__mips'. + + * mpf/set_str.c: Allow a number to start with a period, if next + position contains a digit. + +Tue Aug 13 18:41:25 1996 Torbjorn Granlund + + * mpz/gcdext.c: Get cofactor sign right for negative input operands. + Clean up code for computing tt. + + * mpz/invert.c: Get rid of variable `rv'. + + * mpz/divexact.c: Test for zero divisor in special case for zero + dividend. + +Mon Aug 12 18:04:07 1996 Torbjorn Granlund + + * mpz/?div_*_ui.c: Special case for division by 0. + * mpz/tdiv_q.c: Likewise. + +Sat Aug 10 14:45:26 1996 Torbjorn Granlund + + * mpz/dmincl.c: Special case for division by 0. + + * mpz/tdiv_*_ui.c: Delete special case for dividend being 0; handle + it when computing size after mpn_divmod_1 call. + + * mp_bpl.c: (__gmp_junk): New variable. + (__gmp_0): New constant. + + * gmp-impl.h (DIVIDE_BY_ZERO): New #define. + +Fri Aug 9 20:03:27 1996 Torbjorn Granlund + + * mpz/divexact.c: Test for dividend being zero before testing + for small divisors. + +Thu Aug 8 13:20:23 1996 Torbjorn Granlund + + * configure.in: Require operating system specification for cpus + where assembly syntax differs between system. + + * Makefile.in (many targets): Change `-' action prefix to `@'. + + * mpn/Makefile.in: (distclean): Fix typo. + + * mpq/cmp_ui.c: Rename function to _mpq_cmp_ui. + (mpq_cmp_ui): #undef deleted. + * mpz/cmp_si.c: Rename function to _mpz_cmp_si. + (mpz_cmp_si): #undef deleted. + * mpz/cmp_ui.c: Rename function to _mpz_cmp_ui. + (mpz_cmp_ui): #undef deleted. + * Makefile.in: Corresponding changes. + + * mpf/get_prc.c: Return the *highest* precision achievable. + + * mpf/get_str.c: Complete rewrite. + + * mpf/set_str.c (swapptr): New #define. + (assert): New #define. + * mpf/set_str.c: Set prec to one more than the saved _mp_prec. + Misc cleanups. + + * mpz/set_str.c: #include string.h. + * mpf/out_str.c: #include string.h. + * mpbsd/xtom.c: #include string.h and ctype.h. + * mpbsd/mout.c: #include string.h. + +Wed Aug 7 11:46:04 EDT 1996 Ken Weber + + * mpn/generic/gcd.c: Reorder mpn_gcd argument list. + * mpz/gcd.c: Change call to mpn_gcd. + * gmp.texi: Update manual entry on mpn_gcd. + * mpn/generic/bdivmod.c: Delete limb cache to make mpn_bdivmod + reentrant. + +Wed Aug 7 02:15:38 1996 Torbjorn Granlund + + * mpf/get_str.c: Rewrite code for converting integral part of a + number with both an integral and fractional part. + + * mpf/set_str.c: Get rid of variable xxx. New variables madj and radj. + In exp_in_base==0 case, add madj to msize for EXP field. + + * mpz/tests/t-gcd.c: Test deleted. Rename t-gcd2.c to t-gcd.c. + Increase reps to 2000. + * mpz/tests/t-gcd2.c: Get rid of mpz_refgcd. + + * mpf/set_str.c: Ignore excess limbs in MP,MSIZE. + +Thu Jul 25 04:39:10 1996 Torbjorn Granlund + + * mpn/configure.in: Fix typo in setting path, "sparc" => "sparc32". + +Wed Jul 24 02:27:02 1996 Torbjorn Granlund + + * mpn/generic/gcdext.c: Reorganize and clean up. Get rid of all + signed limb arithmetic. + +Mon Jul 22 02:39:56 1996 Torbjorn Granlund + + * mpn/generic/gcdext.c (mpn_gcdext): For large enough operands, + work with most significant *two* limbs. + (div2): New function (two variants). + (THRESHOLD): New #define. + + * mpz/gcdext.c: Fix typo in MPZ_TMP_INIT call. + + * longlong.h (alpha UMUL_TIME): Now 30. + (alpha UDIV_TIME): Now 350. + (x86 UMUL_TIME): Now 10 (let Pentium decide). + (SuperSPARC UDIV_TIME): Override default. + + * extract-dbl.c (MP_BASE_AS_DOUBLE): Don't redefine here. + + * extract-dbl.c: New name for extract-double.c. + * insert-dbl.c: New name for insert-double.c. + * Makefile.in: Corresponding changes. + * make.bat: Likewise. + + * mpz/Makefile.in (.c.o): Don't pass non-portable `-f' to cp. + * mpq/Makefile.in: Likewise. + * mpf/Makefile.in: Likewise. + +Sat Jul 20 01:35:18 1996 Torbjorn Granlund + + * mpz/getlimbn.c: Take ABS of integer->_mp_size. + + * mpz/divexact.c: Use mpn_divmod_1 if divisor is a single limb. + +Thu Jul 18 00:31:15 1996 Torbjorn Granlund + + * mpn/generic/popcount.c (popc_limb): Use different masking trick + for first step (due to David Seal). + * mpn/generic/hamdist.c (popc_limb): Likewise. + +Wed Jul 17 23:21:48 1996 Torbjorn Granlund + + * mpn/generic/divrem.c: In MPN_COPY_DECR call, copy dsize - 1 limbs. + +Sun Jul 14 17:47:46 1996 Torbjorn Granlund + + * configure.in: Handle sparc9, sparc64, and ultrasparc like sparc8. + +Thu Jul 11 14:05:54 1996 J.T. Conklin + + * longlong.h (mc680x0): Define umul_ppmm, udiv_qrnnd, sdiv_qrnnd + for the '020, '030, '040, and '332. Define count_leading_zeros + for the '020, '030, '040, and '060. + +Sun Jul 14 15:24:53 1996 Torbjorn Granlund + + From Joe Keane: + * mpq/equal.c: Take ABS of num1_size before passing it to mpn_cmp. + +Fri Jul 12 17:11:17 1996 Torbjorn Granlund + + * mpn/generic/sqrtrem.c (SQRT): New asm for x86, but leave it + disabled for now. + + * mpn/generic/sqrtrem.c: Use MP_BASE_AS_DOUBLE. + +Wed Jul 10 03:17:45 1996 Torbjorn Granlund + + * cre-mparam.c: Delete obsolete file. + + * gmp.h: #define _LONG_LONG_LIMB if __mips && _ABIN32. + * longlong.h: Test __mips instead of __mips__. + +Sun Jul 7 23:19:13 1996 Torbjorn Granlund + + * longlong.h (_PROTO): Define, unless already defined. + (alpha __udiv_qrnnd): Declare using _PROTO. + (hppa __udiv_qrnnd): Likewise. + (sparc __udiv_qrnnd): Likewise. + +Mon Jul 1 01:44:30 1996 Torbjorn Granlund + + * config.guess: Update from master version; add Cray x90 handling. + +Wed Jun 26 05:35:02 1996 Torbjorn Granlund + + * mpn/power/add_n.s (__mpn_add_n): Work around GAS bug. + * mpn/power/sub_n.s (__mpn_sub_n): Likewise. + + * insert-double.c: Rework loop to avoid potential overflow. + + * mpq/get_d.c: For vax, if qsize > N_QLIMBS, ignore excess limbs. + + * mpq/tests/t-get_d.c (SIZE): Special case for vax. + + * gmp.h (mpX_cmp_ui): #define also when ! __GNUC__. + +Mon Jun 24 17:13:21 1996 Torbjorn Granlund + + * longlong.h (vax sdiv_qrnnd): Fix typo. + +Sat Jun 15 01:33:33 1996 Torbjorn Granlund + + * gmp.h: Support `small' and `large' type and function variants, + controlled by GMP_SMALL. + + * mpz/Makefile.in (.c.o): Compile each function twice, for small and + large variant. + (MPZS_OBJS): New variable. + (libmpz.a): Include MPZS_OBJS in archive. + * mpf/Makefile.in: Analogous changes. + * mpq/Makefile.in: Analogous changes. + + * gmp.h: Prefix all functions with __gmp, to allow namespace-clean + internal calls. + + * mp.h: Rip out __MP_SMALL__ stuff. + (__mpz_struct): mp_size_t => int. + + * mpz/invert.c: #include "gmp-impl.h". + Use MPZ_TMP_INIT, not mpz_init. + + * mpz/gcdext.c: Rewrite to call mpn_gcdext. + +Fri Jun 14 18:05:29 1996 Torbjorn Granlund + + * mpn/generic/gcdext.c (s0size): New parameter. + * gmp.h (mpn_gcdext): Update prototype. + + * mpn/generic/gcdext.c: Major rewrite. + +Mon Jun 10 00:14:27 1996 Torbjorn Granlund + + * mpn/generic/dump.c: Add missing `else'. + +Fri Jun 7 03:35:12 1996 Torbjorn Granlund + + * Makefile.in (gmp_toc.html): Pass -expandinfo to texi2html. + +Thu Jun 6 19:00:53 1996 Torbjorn Granlund + + * Version 2.0.2 released. + + * install.sh: New file. + * Makefile.in (INSTALL): Use install.sh. + (install-normal): New name for target `install'. + (install): New dummy target. + + * mpz/pow_ui.c: Swap tests for (e == 0) and (bsize == 0). + * mpz/ui_pow_ui.c: Swap tests for (e == 0) and (blimb == 0). + + * config/mt-linux (AR_FLAGS): New file. + * configure.in: Use config/mt-linux for all linux systems. + +Tue Jun 4 03:42:18 1996 Torbjorn Granlund + + * Version 2.0.1 released. + + * mpf/tests/ref.c: Cast result of TMP_ALLOC to the right pointer type. + + * extract-double.c: Test _GMP_IEEE_FLOATS with #if, not plain if. + + * insert-double.c: Don't #include stdlib.h. + + * gmp-impl.h (union ieee_double_extract): Test sparc and __sparc. + Do not test __sparc__. + + * mpf/reldiff.c: Change declaration to work around irix5 compiler bug. + * mpq/equal.c: Likewise. + + * mpn/generic/gcd.c: Delete spurious comma at end of enumeration. + + * mpn/generic/gcdext.c: Add K&R declaration syntax. + * stack-alloc.h: Likewise. + * insert-double.c: Likewise. + * extract-double.c: Likewise. + * mpf/tests/reuse.c: Likewise. + * mpz/tests/reuse.c: Likewise. + * mpf/tests/t-sub.c: Likewise. + * mpf/tests/t-add.c: Likewise. + * mpf/tests/t-muldiv.c: Likewise. + * mpf/tests/t-conv.c: Likewise. + * mpf/tests/ref.c: Likewise. + + * mpn/config/t-oldgas: Renamed from t-freebsd. + * mpn/configure.in: Use t-oldgas for freebsd, netbsd, and some linux + configurations. + + * mpn/powerpc32/mul_1.s: Really clear cy before entering loop. + * mpn/powerpc32/*.s: Fix power/powerpc syntax issues. + + * mpn/config/t-ppc-aix: New file. + * mpn/configure.in: Use t-ppc-aix for powerpc like t-pwr-aix for power. + +Wed May 29 02:07:31 1996 Torbjorn Granlund + + * gmp.h (mp_bits_per_limb): Change qualifier from `const' to + __gmp_const. + + * gmp.h (mpf_init_set_str): Add `const' qualifier for 2nd parameter. + * mpf/iset_str.c: Likewise. + +Mon May 27 00:15:58 1996 Torbjorn Granlund + + * gmp-impl.h: Declare __gmp_extract_double. + + * mpz/set_q.c: Delete unused variables. + + * gmp.h (mpq_equal): Declare. + + * mpf/eq.c: mpf_cmp2 -> mpf_eq. + +Fri May 24 03:20:44 1996 Torbjorn Granlund + + * mpz/iset_d.c: Don't include . + + * insert-double.c (__gmp_scale2): New name for scal2. + * mpz/get_d.c: Corresponding change. + * mpf/get_d.c: Likewise. + * mpq/get_d.c: Likewise. + * gmp-impl.h: Declare __gmp_scale2. + + * mpn/generic/scan0.c: Clarify comment. + + * mpz/set_q.c: New file. + * Makefile.in: Compile it. + * make.bat: Likewise. + * gmp.h: Declare mpz_set_q. + + * insert-double.c: New file. + * Makefile.in: Compile it. + * make.bat: Likewise. + + * mpz/get_d.c: New file. + * mpz/Makefile.in: Compile it. + * make.bat: Likewise. + * gmp.h: Declare mpz_get_d. + + * mpf/get_d.c: New file. + * mpf/Makefile.in: Compile it. + * make.bat: Likewise. + * gmp.h: Declare mpf_get_d. + + * make.bat: Compile things in alphabetical order. + + * gmp-impl.h (MP_BASE_AS_DOUBLE): New #define. + (LIMBS_PER_DOUBLE): New #define. + + * extract-double.c: New file. + * Makefile.in: Compile it. + * make.bat: Likewise. + * mpz/set_d.c: Rewrite to use __gmp_extract_double. + * mpf/set_d.c: Likewise. + + * mpn/configure.in: Use t-pwr-aix also for aix 3.2.4 and up. + +Wed May 22 02:48:35 1996 Torbjorn Granlund + + * gmp-impl.h: Rework code for defining ieee_double_extract. + (IEEE_DOUBLE_BIG_ENDIAN): Macro removed. + (_GMP_IEEE_FLOATS): New macro. + * mpn/vax/gmp-mparam.h: Delete. + + * mpn/config/t-pwr-aix: New file. + * mpn/configure.in: Use t-pwr-aix for aix 4 and later. + +Mon May 20 16:30:31 1996 Torbjorn Granlund + + * gmp.h: In code for setting _GMP_H_HAVE_FILE, test more symbols. + + * mpf/tests/t-add.c (oo): Add some `l' printf modifiers. + * mpf/tests/t-sub.c (oo): Likewise. + * mpf/tests/t-conv.c (oo): Likewise. + * mpf/tests/t-sqrt.c (oo): Likewise. + + * mpz/tests/t-mul.c (_mpn_mul_classic): Remove unused variables. + + * mpn/{pyr,i960,clipper}/*.s: Add missing copyright headers. + +Fri May 17 02:24:43 1996 Torbjorn Granlund + + * mpz/set_d.c: Call _mpz_realloc. + + * mpq/set_z.c: New file. + * mpq/Makefile.in: Compile it. + * make.bat: Likewise. + * gmp.h: Declare mpq_set_z. + + * mp?/Makefile.in (libmp?.a): Depend on Makefile, not Makefile.in. + * mpf/Makefile.in (test): Delete spurious target. + * mpq/Makefile.in (test): Likewise. + + * mpf/out_str.c: Use `e' to separate exponent when base <= 10. + + * mpn/configure.in: Treat ultrasparc just like sparc v8, + until 64-bit compilers are ready. + + * mpf/set_d.c: Make it work for 64-bit machines. + +Thu May 16 20:53:57 1996 Torbjorn Granlund + + * gmp-impl.h: Set IEEE_DOUBLE_BIG_ENDIAN to 0 for little-endian + machines. + * mpn/x86/gmp-mparam.h: Delete file. + + * configure.in: Treat microsparc like sparc8. + + * urandom.h: Test __alpha instead of __alpha__, since the former + is the standard symbol. + * mpn/generic/random2.c: Likewise. + * mpf/random2.c: Likewise. + +Tue May 14 13:42:39 1996 Torbjorn Granlund (tege@tiny.matematik.su.se) + + * mpz/set_f.c: New file. + * mpz/Makefile.in: Compile it. + * gmp.h: Declare mpz_set_f. + + * mpf/set_q.c: Simplify expression in rsize == nsize if-then-else arms. + +Tue May 14 13:03:07 1996 Torbjorn Granlund (tege@tiny.matematik.su.se) + + * make.bat: Add all new files. + +Sun May 12 22:24:36 1996 Torbjorn Granlund + + * mpf/set_z.c: New file. + * mpf/Makefile.in: Compile it. + * gmp.h: Declare mpf_set_z. + +Sat May 11 19:26:25 1996 Torbjorn Granlund + + * gmp.h: Declare mpf_set_q. + + * mpf/set_q.c: Compute prec-1 limbs in mpn_divrem call. + +Fri May 10 17:37:38 1996 Torbjorn Granlund + + * mpf/set_q.c: New file. + * mpf/Makefile.in: Compile it. + + * config.sub: Recognize sparc8. + +Wed May 8 09:19:11 1996 Torbjorn Granlund + + * mpf/tests/t-dm2exp.c: New file. + + * mpf/tests/t-add.c: Correct header comment. + * mpf/tests/t-sub.c: Likewise. + * mpf/tests/t-sqrt.c: Likewise. + + * mpf/div.c: Misc variable name cleanups. + * mpf/div_ui.c: Base more closely on mpf/div.c. + * mpf/ui_div.c: Likewise. + + * mpz/tests/Makefile.in (check): Depend on Makefile. + * mpq/tests/Makefile.in (check): Likewise. + * mpf/tests/Makefile.in (check): Likewise. + + * mpf/tests/t-muldiv.c: New file. + * mpf/tests/Makefile.in: Compile and run `t-muldiv'. + (t-ref.o): Delete spurious rule. + + * mpf/sqrt.c: Properly detect negative input operand. + + * mpf/sqrt_ui.c: Delete spurious header comment. + * mpf/sqrt.c: Likewise. + * mpz/sqrt.c: Likewise. + + * mpz/tests/reuse.c (main): Read `reps' from command line. + + * mpf/tests/reuse.c: New file. + * mpf/tests/Makefile.in: Compile and run `reuse'. + + * mpf/mul_ui.c: Disable code for removing low zero limbs. + + * mpf/div.c: Fix condition for when vp and qp overlaps. + + * mpf/add_ui.c: When sum equals u, copy up to prec+1 limbs. + + * mpf/out_str.c: Don't output '\n' after exponent. + + * mpf/add_ui.c: New special case for when U is completely cancelled. + +Wed Apr 24 05:33:28 1996 Torbjorn Granlund + + * Version 2.0 released. + + * All files: Update FSF's address. + + * Makefile.in (gmp_toc.html): New name for gmp.html. + (TAGS): Depend on force. + + * mpf/tests/t-conv.c: Pass -base to mpf_set_str. + +Sat Apr 20 03:54:06 1996 Torbjorn Granlund + + * Makefile.in (ps): New target, depend on gmp.ps. + +Fri Apr 19 14:03:15 1996 Torbjorn Granlund + + * mpf/out_str.c: Print `@' before exponent, not `e'. + + * make.bat: Update from Makefiles. + +Thu Apr 18 01:22:05 1996 Torbjorn Granlund + + * mpf/set_str.c: If parameter `base' is negative, expect exponent + to be decimal, otherwise in the same base as the mantissa. + +Wed Apr 17 17:28:36 1996 Torbjorn Granlund + + * mpf/set_dfl_prec.c: Don't return anything. + * gmp.h: Corresponding changes. + + * mpf/set_dfl_prec.c: Use `unsigned long int' for bit counts. + * mpf/init2.c: Likewise. + * mpf/get_prc.c: Likewise. + * mpf/set_prc.c: Likewise. + * mpf/set_prc_raw.c: Likewise. + * mpz/popcount.c: Likewise. + * mpz/hamdist.c: Likewise. + * mpz/scan1.c: Likewise. + * mpz/scan0.c: Likewise. + * mpn/generic/popcount.c: Likewise. + * mpn/generic/hamdist.c: Likewise. + * mpn/generic/scan1.c: Likewise. + * mpn/generic/scan0.c: Likewise. + * gmp.h: Likewise. + + * mpf/eq.c: New file, based on mpf/diff.c. + * mpf/diff.c: Delete. + * mpf/Makefile.in: Corresponding changes. + * gmp.h: Likewise. + + * mpf/reldiff.c: New file. + * mpf/Makefile.in: Compile it. + * gmp.h: Declare mpf_reldiff. + + * mpz/iset_d.c: New file. + * mpz/Makefile.in: Compile it. + * gmp.h: Declare mpz_init_set_d. + +Tue Apr 16 16:28:31 1996 Torbjorn Granlund + + * Makefile.in (gmp.html): Pass -acc to texi2html. + +Mon Apr 15 16:20:24 1996 Torbjorn Granlund + + * mpf/set_str.c: Switch off code for defaulting the base from the + leading characters. + + * gmp.h (mp?_sign): Delete. + (mp?_sgn): New macros. + +Fri Apr 12 17:23:33 1996 Torbjorn Granlund + + * Makefile.in (gmp.dvi): Delete tmp.* at end of rule. + +Wed Apr 10 22:52:02 1996 Torbjorn Granlund (tege@tiny.matematik.su.se) + + * mpf/random2.c: Change of `exp' param, mp_size_t => mp_exp_t. + * gmp.h: Corresponding change. + + * gmp.h (mp_bits_per_limb): Make it const. + +Sat Mar 30 01:20:23 1996 Torbjorn Granlund + + * configure.in: Re-enable recognition of with_gcc. + + * mpf/Makefile.in (.c.o): Pass XCFLAGS. + * mpn/Makefile.in (.c.o): Likewise. + * mpz/Makefile.in (.c.o): Likewise. + * mpq/Makefile.in (.c.o): Likewise. + * mpbsd/Makefile.in (.c.o): Likewise. + * mpf/tests/Makefile.in (.c.o): Likewise. + * mpz/tests/Makefile.in (.c.o): Likewise. + * mpq/tests/Makefile.in (.c.o): Likewise. + + * Makefile.in (XCFLAGS): Default to empty. + (FLAGS_TO_PASS): Pass on XCFLAGS. + (.c.o): Pass XCFLAGS. + + * config/mt-m88110 (XCFLAGS): Define instead of CC. + * config/mt-sprc8-gcc (XCFLAGS): Likewise. + * config/mt-supspc-gcc (XCFLAGS): Likewise. + + * configure: Don't default CC to "gcc -O2" is -with-gcc=no was + specified. + +Mon Mar 25 01:07:54 1996 Torbjorn Granlund + + * urandom.h: Test for __SVR4 in addition to __svr4__. + + * mp_bpl.c (mp_bits_per_limb): Declare as `const'. + + * Makefile.in (CFLAGS): `-O2' => `-O'. + * mpn/Makefile.in (CFLAGS): Likewise. + + * gmp-impl.h: Get rid of obsolete field access macros. + + * mpn/mp_bases.c (__mp_bases): 1e39 => 1e38 to work around Solaris + cc compiler bug. + + * gmp.h (__MPN): Make it work also for non-ANSI compilers. + +Thu Mar 21 01:07:54 1996 Torbjorn Granlund + + * mpf/sub.c: New special case for ediff <= 1 before generic code. + Simplify generic code for ediff == 0. + Rename uexp => exp. + +Mon Mar 11 18:24:57 1996 Torbjorn Granlund + + * mpf/tests/*.c: Use ref_mpf_sub for error calculation. + * mpf/tests/Makefile.in: Link ref.o to all executables. + + * mpf/tests/t-sub.c: Make u = v + 1 with 50% probability. + +Sun Mar 10 21:03:17 1996 Torbjorn Granlund (tege@tiny.matematik.su.se) + + * mpf/get_str.c: In digit development loop for fractions, change + loop condition from `<' to `<='. + +Thu Mar 7 04:58:11 1996 Torbjorn Granlund + + * mpn/mp_bases.c (__mp_bases): 1e100 => 1e39 to avoid overflow warning. + +Wed Mar 6 01:10:42 1996 Torbjorn Granlund + + * mpf/tests/t-sqrt.c: New file. + * mpf/tests/Makefile.in: Corresponding changes. + + * mpf/sqrt.c: Special case for square root of zero. + + * mpq/add.c: Clean up variable names. + * mpq/sub.c: Update from mpq/add.c. + + * mpz/divexact.c: abs => ABS. + * mpz/gcd.c: Likewise. Rewrite final fixup code, to decrease + allocation. Misc cleanups. + +Tue Mar 5 22:24:56 1996 Torbjorn Granlund + + * mpn/configure.in: Recognize linuxoldld as a synonym for linuxaout. + + * gmp.h (mpn_add, mpn_add_1, mpn_sub, mpn_sub_1): Add prototypes. + + * mpn/configure.in: Use t-freebsd also for netbsd. + +Mon Mar 4 15:13:28 1996 Torbjorn Granlund + + * mpq/Makefile.in (cmp.o): Depend on longlong.h. + + * mpq/equal.c: New file. + * mpq/Makefile.in: Corresponding changes. + + * mpf/tests/t-add.c: New file. + * mpf/tests/t-sub.c: Renamed from t-addsub.c. + * mpf/tests/ref.c: New file. + * mpf/tests/Makefile.in: Corresponding changes. + + * gmp-impl.h (SIZ, ABSIZ, PTR, EXP, PREC, ALLOC): New #defines. + +Sun Mar 3 07:45:46 1996 Torbjorn Granlund + + * mpf/set_str.c: In exponentiation code, allocate 3 extra + limbs, not just 2. + + * mpf/get_str.c: Allocate sufficient space for tstr. + When calculating exp_in_base, round result down. + + * mpf/tests/t-conv.c: New file. + * mpf/tests/Makefile.in: Corresponding changes. + + * mp_bpl.c: New file. + * gmp.h: Declare it. + * Makefile.in: Corresponding changes. + +Sat Mar 2 06:27:56 1996 Torbjorn Granlund + + * mpf/set_prc_raw.c: New file. + * mpf/set_prc.c: Renamed from set_prec.c. + * mpf/get_prc.c: New file. + * mpf/Makefile.in: Corresponding changes. + * gmp.h: Declare new functions. + + * mpn/generic/gcdext.c: Add copyright header. + +Fri Mar 1 01:22:24 1996 Torbjorn Granlund + + * mpn/configure.in: For ppc601, search "power" before "powerpc32". + + * mp?/Makefile.in (AR_FLAGS): New variable. + (libmp?.a): Use it. + + * make.bat: New file. + * mpn/msdos: New directory. + * mpn/msdos/asm-syntax.h: New file. + + * mpn/Makefile.in (distclean maintainer-clean): Delete asm-syntax.h. + + * config.sub: Recognize [ctj]90-cray. + + * mpn/configure.in: Recognize [ctj]90-cray-unicos*. + + * mpn/generic/gcdext.c: Don't use alloca directly, use TMP_* macros. + + * mpn/generic/gcd.c: Split increment from use of USIZE to avoid + undefined behaviour. + +Thu Feb 29 04:11:24 1996 Torbjorn Granlund + + * Makefile.in (install-info-files): Update for new install-info + behaviour. + + * mpn/power/add_n.s: Rewrite. + * mpn/power/sub_n.s: Rewrite. + +Wed Feb 28 01:34:30 1996 Torbjorn Granlund + + * mpz/pow_ui.c: Compute allocation more aggressively for small bases. + * mpz/ui_pow_ui.c: Likewise. + + * mpn/mp_bases.c (__mp_bases): Put huge value in 2nd field for index 1. + + * mpn/generic/sqrtrem.c: sizeof (mp_limb_t) => BYTES_PER_MP_LIMB. + * mpn/generic/gcd.c: Likewise. + (SIGN_BIT): Compute differently. + +Mon Feb 26 00:07:36 1996 Torbjorn Granlund + + * All files: mp_limb => mp_limb_t, mp_limb_signed => mp_limb_signed_t. + + * Makefile.in (install, install-bsdmp, install-info-files): Depend + on installdirs. chmod all installed files. + +Sun Feb 25 01:47:41 1996 Torbjorn Granlund + + * mpbsd/configure.in: Delete debugging code. + + * All Makefile.in: Update clean targets. + + * Makefile.in (AR_FLAGS): New variable. + (libgmp.a): Use it. + (libmp.a): Likewise. + + * VERSION: Delete file. + + * Makefile.in (installdirs): New target. + * mkinstalldirs: New file (from the texinfo package). + + * Makefile.in (INSTALL, INSTALL_DATA, INSTALL_PROGRAM): New variables. + (MAKEINFO, MAKEINFOFLAGS, TEXI2DVI): New variables. + (install-info): New target. + (install, install-bsdmp): Depend on install-info. + ($(srcdir)/gmp.info): Changed from plain gmp.info; put info files + into source directory. + (distclean, mostlyclean): New targets. + (maintainer-clean): New name for realclean. + (uninstall): New target. + (TAGS): New target. + (info, dvi): New targets. + (.PHONY): Assign. + + * Makefile.in (install, install-bsdmp): Use INSTALL_DATA. + + * mp{n,z,f,bsd}/move-if-change: Delete. + + * mpbsd/Makefile.in (stamp-stddefh): Delete target. + + * Makefile.in (.c.o): Pass CFLAGS last. + * mpbsd/Makefile.in (.c.o): Likewise. + * mpf/Makefile.in (.c.o): Likewise. + * mpq/Makefile.in (.c.o): Likewise. + * mpz/Makefile.in (.c.o): Likewise. + * mpn/Makefile.in (.c.o): Likewise. + (.S.o): Likewise. + + * memory.c: Change allocation error message. + + * Makefile.in (install): Prefix gmp.h with $(srcdir). + (install-bsdmp): Prefix mp.h with $(srcdir). + + * mp{n,z,f,bsd}/{configure,config.sub}: Delete. + + * Makefile.in (gmp.dvi): Set TEXINPUTS also for 2nd tex invocation + (install targets): Install gmp.info-N. + +Sat Feb 24 03:36:52 1996 Torbjorn Granlund + + * mpf/get_str.c: Fix typo. + + * mpz/legendre.c: Clarify expression with extra parens. + + * version.c (gmp_version): Not static. + + * mpf/iset_str.c: Properly return error code. + + * mpf/add.c: Delete unused variables. + * mpf/inp_str.c: Likewise. + * mpq/get_d.c: Likewise. + + * mpn/generic/dump.c: #include . + * mpf/dump.c: Likewise. + * mpf/set_str.c: #include . + (strtol): Declare. + + * gmp.h: mpn_sqrt => mpn_sqrtrem. + + * Makefile.in (clean, realclean): Clean in mpbsd. + (check): Test in mpf. + + * mpf/Makefile.in (clean): Clean in tests. + * mpq/Makefile.in (clean): Clean in tests. + + * mpf/tests/Makefile.in: New file. + * mpf/tests/configure.in: New file. + * mpf/tests/t-addsub.c: New file. + + * mpf/sub_ui.c: Simply call mpf_sub for now. + + * mpf/sub.c: Increase prec by 1. + * mpf/ui_sub.c: Likewise. + +Fri Feb 23 00:59:54 1996 Torbjorn Granlund + + * mpf/ui_sub.c: Fix typos. + + * mpf/get_str.c: When allocating space for tmp, allow for an extra + limb. In code for fraction conversion, add special case for bases + that are a power of 2. + + * mpf/out_str.c: Output leading "0.". + Default base to 10, before computing string allocation. + + * mpf/get_str.c: Make variables for string size have type size_t. + * gmp.h: Corresponding change. + + * mpf/random2.c: Allow creation of prec+1 large mantissas. + + * mpf/add_ui.c: Don't abort if u < 0; special case for u <= 0. + Fix typo in MPN_COPY offset. + * mpf/sub_ui.c: Analogous changes. + + * mpf/set_prec.c: Rewrite. + + * mpf/init2.c: Compute precision as in set_prec.c. + + * mpf/div_2exp.c: Special case for u == 0. + * mpf/mul_2exp.c: Likewise. Write r->_mp_size always. + + * mpf/sqrt_ui.c: mpn_sqrt => mpn_sqrtrem. + * mpf/sqrt.c: Likewise. When computing new exponent, round quotient + towards -infinity. + + * mpf/add.c: Fix typos. + * mpf/sub.c: Fix typos. + +Thu Feb 22 00:24:48 1996 Torbjorn Granlund + + * mpz/Makefile.in (stamp-stddefh): Delete target. + (test): Delete target. + * Makefile.in (stamp-stddefh): Delete target. + (cre-stddefh.o): Delete target. + (gmp.dvi): Set TEXINPUTS before invoking tex. + + * cre-stddefh.c: Delete. + + * mpz/sqrt.c: Fix typo. + + * mpz/powm.c: Special case for mod == 0. + * mpz/powm_ui.c: Likewise. + + * mpz/get_si.c: Handle -0x80000000 correctly. + + * mpz/inp_str.c: Now returns size_t. + Make it return number of bytes read or error indication. + * mpf/inp_str.c: Likewise. + + * mpz/out_raw.c: Replace by mpz/out_binary.c, with modifications. + * mpz/inp_raw.c: Rewrite, using mpz/inp_binary as a base. + * mpz/inp_binary.c: Delete. + + * mpn/Makefile.in (XCFLAGS): Remove variable. + (.c.o): Don't pass XCFLAGS. + (SFLAGS): Set to nothing. + (.S.o): Pass SFLAGS, not XCFLAGS. + + * mpn/config/t-freebsd (SFLAGS): New name for XCFLAGS. + + * mpf/out_str.c: Make return number of bytes written or error + indication. + * mpz/out_str.c: Likewise. + * gmp.h: Corresponding changes. + + * gmp.h (__mpz_struct): mp_size_t => int. + (__mpq_struct): Likewise. + (__mpf_struct): Likewise. + (mp_size_t): int => long int. + + * mpn/cray: New directory. + * mpn/cray/gmp-mparam.h: New file. + * mpn/configure.in: Recognize cray variants. + + * Makefile.in: Set defaults for prefix, libdir, etc. + (install): New target. + (install-bsdmp): New target. + (gmp.html): New target. + + * stack-alloc.c (__tmp_alloc): Cast void ptrs to char * in comparison. + +Wed Feb 21 04:35:02 1996 Torbjorn Granlund + + * gmp.h: Sort mpn declarations. + (mpn_gcdext): Add declaration. + + * mpn/generic/divrem_1.c: New file. + * mpn/Makefile.in (divrem_1.o): New rule. + * configure.in (functions): Add divrem_1. + + * mpn/generic/divmod.c: Delete file. + * mpn/configure.in (functions): Delete divmod. + * Makefile.in (divmod.o): Delete rule. + * gmp.h (mpn_divmod): New #define. + + * gmp.h (mpn_next_bit_set): Delete spurious declaration. + + * mpn/generic/divrem.c (default case): In code assigning + most_significant_q_limb, move reassignment of n0 into if statement. + + * gmp.h (mpf_inp_str): Fix typo. + (mpf_out_str): Make prototype match reality. + * mpf/inp_str.c: New file. + * mpf/out_str.c: New file. + * mpf/Makefile.in: Compile new files. + + * mpn/Makefile.in (dump.o): Fix dependency path. + (inlines.o): Likewise. + + * mpn/configure.in: Make m68060 be the same as m68000. Clean up + m68k configs. + +Tue Feb 20 01:35:11 1996 Torbjorn Granlund + + * mpn/generic/sqrtrem.c: Renamed from sqrt. + * mpn/configure.in (functions): Corresponding change. + * mpn/Makefile.in: Likewise. + * mpz/sqrtrem.c: Likewise. + * mpz/sqrt.c: Likewise. + * mpn/generic/perfsqr.c: Likewise. + + * Makefile.in (clean): Also remove libmp.a. + Don't compile cre-conv-tab.c or mp_bases.c. + cre-conv-tab.c: Delete file. + (gmp.ps): New rule. + + * mpn/mp_bases.c: New file. + * mpn/Makefile.in: Compile mp_bases.c. + + * mpz/set_str.c: Skip initial whitespace. + * mpf/set_str.c: Likewise. + * mpbsd/xtom.c: Likewise. + + * gmp.h: Add missing mpz declarations. + Delete all formal parameter names from declarations. + + * mpn/Makefile.in: Add dependencies for .c files. + + * Makefile.in (check): Write recursive make calls separately, not as + a loop. + (FLAGS_TO_PASS): New variable. Use it for most recursive makes. + +Mon Feb 19 01:02:20 1996 Torbjorn Granlund + + * mpn/Makefile.in (.S.o): Pipe cpp output to grep in order to delete + lines starting with #. + (CPP): Set to $(CC) -E to avoid gcc dependency. + + * mpn/m68k/syntax.h (moveql): Define to moveq for MIT_SYNTAX. + + * mpn/hppa/hppa1_1/pa7100/addmul_1.S: Fix typo in s1_ptr alignment + code. + * mpn/hppa/hppa1_1/pa7100/submul_1.S: Likewise. + + * gmp.h: Fix typos in #defines of recently added mpn functions. + + * mpz/inp_str.c: Skip all whitespace, not just plain space. + * mpbsd/min.c: Likewise. + + * mpn/configure.in (functions): Add gcdext. + * mpn/generic/gcdext.c: New file. + + * mpz/legendre.c: mpz_div_2exp => mpz_tdiv_q_2exp. + + * gmp.h: Surround mpn declarations with extern "C" { ... }. + + * Makefile.in (check): New target. + + * mpq/get_d.c: Update comments. Use rsize instead of dsize + N_QLIMBS + when possible. Add special case for nsize == 0. + + * gmp.h (mpq_get_d): Add declaration. + (mpq_canonicalize): Likewise. + (mpq_cmp_ui): Likewise. + (mpf_diff): Likewise. + (mpf_ui_sub): Likewise. + (mpf_set_prec): Likewise. + (mpf_random2): Likewise. + + * gmp.h (mpz_cmp_ui): New #define. + (mpz_cmp_si): New #define. + (mpq_cmp_ui): New #define. + (mpz_sign): New #define. + (mpq_sign): New #define. + (mpf_sign): New #define. + (mpq_numref): New #define. + (mpq_denref): New #define. + + * mpq/set_z.c: File deleted. + * mpq/Makefile.in: Corresponding changes. + +Sun Feb 18 01:34:47 1996 Torbjorn Granlund + + * mpbsd/sdiv.c: Use _mp_realloc, not _mpz_realloc. + + * mpz/inp_binary.c: Default stream to stdin. + * mpz/inp_str.c: Likewise. + * mpz/inp_raw.c: Likewise. + * mpz/out_binary.c: Default stream to stdout. + * mpz/out_raw.c: Likewise. + * mpz/out_str.c: Likewise. + + * mpbsd/realloc.c: New file. + * mpbsd/Makefile.in: Corresponding changes. + + * mpbsd/min.c: Rewrite (base on mpz/inp_str.c). + * mpbsd/mtox.c: Rewrite (base on mpz/get_str.c). + + * mpbsd/mout.c: Rewrite (base on mpz/out_str) but make it output + spaces in each 10th position. + * mpbsd/xtom.c: Rewrite (base on mpz/set_str). + + * mpq/tests/Makefile.in (st-cmp): New file. + * mpq/tests/configure.in (srcname): New file. + + * mpz/tests/configure.in (srcname): Fix typo. + + * mpq/cmp.c: Add check using number of significant bits, to avoid + general multiplication. + +Sat Feb 17 11:58:30 1996 Torbjorn Granlund + + * mpq/cmp_ui.c: Store cy_limb after the mpn_mul_1 calls. + + * mpq/tests: New directory. + * mpq/tests/t-cmp.c: New file. + * mpq/tests/t-cmp_ui.c: New file. + + * mpz/tests/dive.c (main): Generate zero numerator. + (get_random_size) : Delete. + + * mpz/divexact.c: Add special case for 0/x. + + * gmp.h (mpz_mod): Add declaration. + +Fri Feb 16 18:18:39 1996 Andreas Schwab + + * mpn/m68k/*: Rewrite code not to use the INSN macros. + (L): New macro to properly prefix local labels for ELF. + +Fri Feb 16 00:20:56 1996 Torbjorn Granlund + + * gmp-impl.h (ieee_double_extract): Use plain `unsigned int' for + fields. + * mpn/generic/inlines.c (_FORCE_INLINES): New #define. Delete + conditional __GNUC__. + * gmp.h (mpn_add, mpn_sub, mpn_add_1, mpn_sub_1): + Only define these if __GNUC__ || _FORCE_INLINES. + * mpf/random2.c: Add missing parameter in non-ANSI header. + * mpn/generic/gcd.c (SIGN_BIT): Do as #define to work around bug + in AIX compilers. + * mpq/get_d.c: #define N_QLIMBS. + * mpz/divexact.c: Obscure division by 0 to silent compiler warnings. + * stack-alloc.c: Cast void* pointer to char* before doing arithmetic + on it. + + * Makefile.in (mpbsd/libmpbsd.a): New rule. + * configure.in (configdirs): Add mpbsd. + + * gmp.h: Add declarations for a few missing mpn functions. + + * Makefile.in (libmp.a): New rule. + + * mpbsd/mdiv.c: #include "dmincl.c", not "mpz_dmincl.c" + * gmp.h: Move #define of __GNU_MP__ into the `#if __GNU_MP__' block. + * mp.h: Likewise. Update typedefs from gmp.h. + * mpbsd/configure.in: New file. + * mpbsd/Makefile.in: New file. + * mpbsd/configure: Link to master configure. + * mpbsd/config.sub: Link to master config.sub. + + * Makefile.in: Set RANLIB_TEST. + * (libgmp.a): Use it. + * (libgmp.a): Do ranlib before moving the libgmp.a to the build + directory. + * mp?/Makefile.in: Don't use or set RANLIB. + +Thu Feb 15 16:38:41 1996 Torbjorn Granlund + + * mpz/add_ui.c: MP_INT => mpz_t. + * mpz/cmp_ui.c: Likewise. + * mpz/fac_ui.c: Likewise. + * mpz/inp_binary.c: Likewise. + * mpz/inp_raw.c: Likewise. + * mpz/legendre.c: Likewise. + * mpz/jacobi.c: Likewise. + * mpz/out_binary.c: Likewise. + * mpz/out_raw.c: Likewise. + * mpz/random2.c: Likewise. + * mpz/random.c: Likewise. + * mpz/realloc.c: Likewise. + + * mpz/legendre.c: __mpz_2factor(X) => mpz_scan1(X,0), + __mpz_odd_less1_2factor => mpz_scan1(X,1). + * mpz/ntsup.c: File deleted. + * mpz/Makefile.in: Corresponding changes. + + * mpz/pprime_p: Use mpz_scan1 to avoid looping. + + * mpz/fac_ui.c: Type of `k' and `p' is `unsigned long'. + * mpz/pprime_p.c: Pass long to *_ui functions. + * mpz/gcdext.c: Likewise. + * mpz/fdiv_r_2exp.c: Likewise. + * mpz/fac_ui.c: Likewise. + + * mpz/powm.c: Don't use mpn_rshift when mod_shift_cnt is 0. + + * mpz/tests/Makefile.in (st-sqrtrem): Fix typo. + + * mpz/cmp_ui.c: #undef mpz_cmp_ui. + * mpz/cmp_si.c: #undef mpz_cmp_si. + * gmp.h (mpz_cmp_ui): New #define. + (mpz_cmp_si): New #define. + +Wed Feb 14 22:11:24 1996 Torbjorn Granlund + + * gmp.h: Test __cplusplus in addition to __STDC__. + * gmp-impl.h: Likewise. + + * gmp.h: Surround declarations with extern "C" { ... }. + +Tue Feb 13 15:20:45 1996 Torbjorn Granlund + + * mpz/fdiv_r_2exp.c: Use MPN_NORMALIZE. + * mpz/tdiv_r_2exp.c: Likewise. + + * mpz/fdiv_r_2exp.c: New file. + * mpz/fdiv_q_2exp.c: New file. + * mpz/tdiv_r_2exp.c: Renamed from mpz/mod_2exp.c. + * mpz/tdiv_q_2exp.c: Renamed from mpz/div_2exp.c + * mpz/Makefile.in: Corresponding changes. + + * mpz/scan0.c,scan1.c: New files. + * mpz/Makefile.in: Compile them. + + * gmp.h (mpn_normal_size): Delete. + + * config.guess: Update from Cygnus version. + + * mpn/m68k/rshift.S: Use INSN2 macro for lea instructions. + * mpn/m68k/lshift.S: Likewise. + + * mpn/configure.in: Fix configuration for plain 68000. + +Mon Feb 12 01:06:06 1996 Torbjorn Granlund + + * mpz/tests/t-powm.c: Generate negative BASE operand. + + * mpz/powm.c: Make result always positive. + +Sun Feb 11 01:44:56 1996 Torbjorn Granlund + + * mpz/tests/*.c: Add t- prefix. + * mpz/tests/Makefile.in: Corresponding changes. + * mpz/tests/configure.in: Update srctrigger. + + * mpz/tests/gcd.c: Generate negative operands. + * mpz/tests/gcd2.c: Likewise. + + * mpz/gcdext.c: At end, if G is negative, negate all G, S, and T. + +Thu Feb 8 17:16:12 UTC 1996 Ken Weber + + * mp{z,n}/gcd.c: Change mpn_gcd interface. + * gmp.h: Ditto. + * gmp.texi: update documentation. + +Mon Feb 7 23:58:43 1996 Andreas Schwab + + * mpn/m68k/{lshift,rshift}.S: New files. + * mpn/m68k/syntax.h: New ELF_SYNTAX macros. + (MEM_INDX, R, PROLOG, EPILOG): New macros. + * mpn/m68k/*.S: Use R macro with register name. Use PROLOG and EPILOG + macros. Rename `size' to `s_size' or s1_size to avoid clash with ELF + .size directive. + * mpn/configure.in: New target m68k-*-linux*. + +Wed Feb 7 07:41:31 1996 Torbjorn Granlund + + * Makefile.in (cre-conv-tab): Workaround for SunOS make. + + * mpz/tests/reuse.c: New file. + * mpz/tests/Makefile.in: Handle reuse.c. + +Tue Feb 6 11:56:24 UTC 1996 Ken Weber + + * mpz/gcd.c: Fix g->size when one op is 0 and g == other op. + +Tue Feb 6 01:36:39 1996 Torbjorn Granlund + + * gmp.h (mpz_divexact): Delete parameter names. + (mpz_lcm): Delete spurious declaration. + + * mpz/dmincl.c: Fix typo. + +Mon Feb 5 01:11:56 1996 Torbjorn Granlund + + * mpn/generic/gcd.c (gcd_2): Declare consistently. + + * mpz/tdiv_q.c: Optimize division by a single-limb divisor. + * mpz/dmincl.c: Likewise. + + * mpz/add.c: Use MPN_NORMALIZE instead of mpn_normal_size. + * mpz/sub.c: Likewise. + * mpn/generic/sqrt.c: Likewise. + + * mpn/tests/{add_n,sub_n,lshift,rshift}.c: Put garbage in the + destination arrays. + +Fri Feb 2 02:21:27 1996 Torbjorn Granlund + + * mpz/{jacobi.c,legendre.c,ntsup.c,invert.c}: New files. + * mpz/Makefile.in: Compile them. + + * mpn/Makefile.in (INCLUDES): Don't search in `generic'. + +Thu Feb 1 02:15:11 1996 Torbjorn Granlund + + Change from Ken Weber: + * mpz/divexact.c: Make it work when quot is identical to either input. + + * mpf/ui_sub.c: New file. + * mpf/Makefile.in: Compile it. + + * gmp-impl.h (MPZ_TMP_INIT): alloca -> TMP_ALLOC. + * mpz/{c,f}div_{q,qr,r}.c: Use TMP_DECL/TMP_MARK/TMP_FREE since + these use MPZ_TMP_INIT. + * mpz/mod.c: Likewise. + * mpq/{add,sub}.c: Likewise. + * mpq/canonicalize: Likewise. + + * mpq/{add,sub,mul,div}.c: Use mpz_divexact. MP_INT -> mpz_t. + * mpq/canonicalize.c: Likewise. + +Wed Jan 31 01:45:00 1996 Torbjorn Granlund + + * mpn/generic/gcd.c: Misc changes from Ken. + + * mpz/tests/gcd2.c: New file. + * mpz/tests/Makefile.in: Handle gcd2.c. + + * mpn/generic/gcd.c (mpn_gcd): When GCD == ORIG_V, return vsize, + not orig_vsize. Fix parameter declaration. + + * mpz/mod_ui.c: Delete file. + * mpz/Makefile.in: Don't try to compile mod_ui. + + * mpz/cdiv_*_ui.c): Make them work right. + * gmp.h: Declare cdiv*. + +Tue Jan 30 02:22:56 1996 Torbjorn Granlund + + * mpz/{cdiv_q.c,cdiv_q_ui.c,cdiv_qr.c,cdiv_qr_ui.c,cdiv_r.c, + cdiv_r_ui.c,cdiv_ui.c}: New files. + * mpz/Makefile.in: Compile them. + + * All files: Make file permissions right. + + Changes from Ken Weber: + * mpn/generic/accelgcd.c: Delete. + * mpn/generic/bingcd.c: Delete. + * mpn/generic/numbits.c: Delete. + * mpn/generic/gcd.c: New file. + * mpn/configure.in (functions): Update accordingly. + * mpz/divexact.c: New file. + * mpz/Makefile.in: Compile divexact.c. + * mpz/gcd.c: Rewrite to accommodate for gcd changes in mpn. + * gmp.h: declare new functions, delete obsolete declarations. + * mpz/tests/dive.c: New file. + * mpz/tests/Makefile.in: Handle dive.c. + +Mon Jan 29 03:53:24 1996 Torbjorn Granlund + + * mpz/random.c: Handle negative SIZE parameter. + + * mpz/tests/tdiv(_ui).c: New name for tst-dm(_ui).c. + * mpz/tests/tst-mdm(_ui).c: Delete. + * mpz/tests/fdiv(_ui).c: New test based in tst-mdm(_ui). + * mpz/tests/*.c: Get rid of tst- prefix for DOS 8+3 naming. + * mpz/tests/Makefile.in: Corresponding changes. + * mpz/tests/configure.in: Update srctrigger. + + * mpn/generic/divmod.c: Update from divrem. + * mpn/generic/divrem.c: Misc cleanups. + +Sun Jan 28 03:25:08 1996 Torbjorn Granlund + + * All files: Use new TMP_ALLOC interface. + + * mpz/powm_ui.c: Make Jan 25 changes to powm.c also here. + + * mpz/tests/powm_ui.c: New file. + * mpz/tests/Makefile.in: Add rules for tst-powm and tst-powm_ui. + + * Makefile.in: Update dependency list. + * mpf/Makefile.in: Likewise. + * mpz/Makefile.in: Likewise. + * mpq/Makefile.in: Likewise. + * Makefile.in: Set RANLIB simply to ranlib, and allow configure + to override it. + + * mpz/Makefile.in (conf): Delete spurious target. + (mp_bases.c): Delete. + (cre-conv-tab rules): Delete. + + * Makefile.in (cre-conv-tab): Greatly simplify. + +Sat Jan 27 13:38:15 1996 Torbjorn Granlund + + * stack-alloc.c: New file. + * stack-alloc.h: New file. + + * gmp.h (__gmp_inline): Define using __inline__. + +Thu Jan 25 00:28:37 1996 Torbjorn Granlund + + * mpn/generic/scan0.c: New file. + * mpn/generic/scan1.c: Renamed from next_bit.c. + * mpn/configure.in (functions): Include scan0 and scan1. + + * mpn/m68k/*: #include sysdep.h. Use C_GLOBAL_NAME. + + * configure: Update from Cygnus version. + * config.guess: Likewise. + * config.sub: Likewise. + * configure: Pass --nfp to recursive configures. + + * mpz/tests/tst-*.c: Adjust SIZE and reps. + + * mpz/powm.c: Move esize==0 test earlier. + In final reduction of rp,rsize, don't call mpn_divmod unless + reduction is really needed. + + * mpz/tests/tst-powm.c: Fix thinko in checking code. + + * All files: Get rid of `__' prefix from mpn_* calls and declarations. + * gmp.h: #define __MPN. + * gmp.h: Use __MPN in #defines for mpn calls. + + * mpn/generic/mul_n.c: Prepend `i' to internal routines. + * gmp-impl.h: Add #defines using __MPN for those internal routines. + + * mpn/generic/sqrt.c: Change call to mpn_mul to mpn_mul_n. + +Wed Jan 24 13:28:19 1996 Torbjorn Granlund + + * mpn/sparc32/udiv_fp.S: New name for udiv_qrnnd.S. + * mpn/sparc32/udiv_nfp.S: New name for v8/udiv_qrnnd.S. + * mpn/sparc32/v8/supersparc: New directory. + * mpn/sparc32/v8/supersparc/udiv.S: New file. + +Tue Jan 23 01:10:11 1996 Torbjorn Granlund + + This major contribution is from Ken Weber: + * mpn/generic/accelgcd.c: New file. + * mpn/generic/bdivmod.c: New file. + * mpn/generic/bingcd.c: New file. + * mpn/generic/gcd_1.c: Rewrite. + * mpn/generic/numbits.c: New file (to go away soon). + * mpz/gcd.c: Rewrite. + * mpz/tests/tst-gcd.c (SIZE): Now 128. + * gmp.h: Declare new functions. + * mpn/configure.in (functions): List new files. + * gmp-impl.h (MPN_SWAP): Delete. + (MPN_LESS_BITS_LIMB, MPN_LESS_BITS, MPN_MORE_BITS): Delete. + (MPN_COMPL_INCR, MPN_COMPL): Delete. + +Mon Jan 22 02:04:59 1996 Torbjorn Granlund + + * gmp.h (mpn_name): New #define. + + * mpn/m88k/mc88110/addmul_1.s: New file. + * mpn/m88k/mc88110/add_n.S: New file. + * mpn/m88k/mc88110/sub_n.S: New file. + + * mpn/m88k/sub_n.s: Correctly initialize carry. + + * mpn/sparc32/{add_n.S,sub_n.S,lshift.S,rshift.S): `beq' => `be'. + +Sun Jan 21 00:04:35 1996 Torbjorn Granlund + + * mpn/sparc64/addmul_1.s: New file. + * mpn/sparc64/submul_1.s: New file. + * mpn/sparc64/rshift.s: New file. + +Sat Jan 20 00:32:54 1996 Torbjorn Granlund + + * mpz/iset.c: Fix typo introduced Dec 25. + +Wed Jan 17 13:16:44 1996 Torbjorn Granlund + + * config/mt-sprc8-gcc: New name for mt-sparc8-gcc. + * config/mt-sparcv8-gcc: Delete. + * configure.in: Corresponding changes. + +Tue Jan 16 16:31:01 1996 Torbjorn Granlund + + * gmp-impl.h: #include alloca.h when necessary. + + * longlong.h: Test __alpha instead of __alpha__, since the former + is the standard symbol. + +Mon Jan 15 18:06:57 1996 Torbjorn Granlund + + * mpn/sparc64/mul_1.s: Swap operands of mulx instructions. + * mpn/sparc64/lshift.s: New file. + +Fri Dec 29 17:34:03 1995 Torbjorn Granlund + + * mpn/x86/pentium/add_n.S: Get rid of #defines for register names. + * mpn/x86/pentium/sub_n.S: Likewise. + +Thu Dec 28 03:16:57 1995 Torbjorn Granlund + + * mpn/x86/pentium/mul_1.S: Rework loop to avoid AGI between update + of loop induction variable and load insn at beginning of loop. + * mpn/x86/pentium/addmul_1.S: Likewise. + * mpn/x86/pentium/submul_1.S: Likewise. + +Mon Dec 25 23:22:55 1995 Torbjorn Granlund + + * All files: Prefix user-visible structure fields with _mp_. + +Fri Dec 22 20:42:17 1995 Torbjorn Granlund + + * mpn/configure.in (m68k configs): Terminate path variable with + plain "m68k". + +Fri Dec 22 03:29:33 1995 Torbjorn Granlund + + * mpn/sparc32/add_n.S: Update from sub_n.S to fix bugs, and to + clean things up. + + * mpn/configure.in (m68k configs): Update #include path for new + mpn directory organization. + +Tue Dec 12 02:53:02 1995 Torbjorn Granlund + + * gmp.h: Prefix all structure field with _mp_. + * gmp-impl.h: Define access macros for these fields. + +Sun Dec 10 00:47:17 1995 Torbjorn Granlund + + * mpn/alpha/addmul_1.s: Prefix labels with `.'. + * mpn/alpha/submul_1.s: Likewise. + * mpn/alpha/[lr]shift.s: Likewise. + * mpn/alpha/udiv_qrnnd.S: Likewise. + * mpn/alpha/ev5/[lr]shift.s: Likewise. + + * mpn/alpha/ev5/lshift.s: Fix typos. + +Fri Dec 1 14:28:20 1995 Torbjorn Granlund + + * mpn/Makefile.in (.SUFFIXES): Define. + +Wed Nov 29 23:11:57 1995 Torbjorn Granlund + + * mpn/sparc64/{add_n.s, sub_n.s}: New files. + +Tue Nov 28 06:03:13 1995 Torbjorn Granlund + + * mpn/x86/syntax.h: Handle ELF_SYNTAX. + Rename GAS_SYNTAX => BSD_SYNTAX. + + * mpn/configure.in: Handle linuxelf and SysV for x86 variants. + +Mon Nov 27 01:32:12 1995 Torbjorn Granlund + + * mpn/hppa/hppa1_1/pa7100/submul_1.S: New file. + +Sun Nov 26 04:30:47 1995 Torbjorn Granlund + + * mpn/hppa/hppa1_1/pa7100/addmul_1.S: New file. + + * mpn/sparc32/add_n.S: Rewrite to use 64 bit loads/stores. + * mpn/sparc32/sub_n.S: Likewise. + +Fri Nov 17 00:18:46 1995 Torbjorn Granlund + + * mpn/configure.in: Handle m68k on NextStep. + +Thu Nov 16 02:30:26 1995 Torbjorn Granlund + + * mpn: Reorganize machine-specific directories. + * mpn/configure.in: Corresponding changes. + (sh, sh2): Handle these. + (m68k targets): Create asm-syntax.h. + +Thu Nov 9 02:20:50 1995 Torbjorn Granlund + + * mpn/generic/mul_n.c (____mpn_sqr_n): Delete code that calls abort. + (____mpn_mul_n): Likewise. + +Tue Nov 7 03:25:12 1995 Torbjorn Granlund + + * mpf/get_str.c: In exponentiation code (two places), don't swap + input and output areas when calling mpn_mul_1. + * mpf/set_str.c: Likewise. + +Fri Nov 3 02:35:58 1995 Torbjorn Granlund + + * mpf/Makefile.in: Make sure all objects are listed in dependency list; + delete spurious entries. + + * mpf/mul.c: Handle U or V being 0. Allow prec+1 for result precision. + + * mpf/set_prec.c: New computation of limb precision. + * mpf/set_dfl_prec.c: Likewise. + + * mpf/random2.c: Fix typo computing exp. + * mpf/get_str.c: In (uexp > usize) case, set n_limbs as a function of + the user-requested number of digits, n_digits. + +Thu Nov 2 16:25:07 1995 Torbjorn Granlund + + * mpn/generic/divrem.c (case 2): Don't move np vector back, it is + never read. + (default case): Put most significant limb from np in new variable n2; + decrease size argument for MPN_COPY_DECR; use n2 instead of np[dsize]. + +Wed Nov 1 02:59:53 1995 Torbjorn Granlund + + * mpn/sparc/[lr]shift.S: New files. + +Tue Oct 31 00:08:12 1995 Torbjorn Granlund + + * mpz/gcd_ui.c: Set w->size unconditionally when v is zero. + + * gmp-impl.h (assert): Delete definition. + + * mpf/sub.c: Delete all assert calls. Delete variable `cy'. + + * mpf/neg.c: Use prec+1 as precision. Optimize for when arguments + are the same. + * mpf/abs.c: Likewise. + * mpf/{set,neg,abs}.c: Make structure and variable names similar. + +Mon Oct 30 12:45:26 1995 Torbjorn Granlund + + * mpf/random2.c (random): Test __SVR4 in addition to __svr4__. + * mpn/generic/random2.c (random): Likewise. + +Sun Oct 29 01:54:28 1995 Torbjorn Granlund + + * mpf/div.c: Special handle U or V being 0. + + * mpf/random2.c: New file. + + * longlong.h (i860 rshift_rhlc): Define. + (i960 udiv_qrnnd): Define. + (i960 count_leading_zeros): Define. + (i960 add_ssaaaa): Define. + (i960 sub_ddmmss): Define. + (i960 rshift_rhlc): Define. + +Sat Oct 28 19:09:15 1995 Torbjorn Granlund + + * mpn/pentium/rshift.S: Fix and generalize condition for when to use + special code for shift by 1. + * mpn/pentium/lshift.S: Likewise. + +Thu Oct 26 00:02:56 1995 Torbjorn Granlund + + * gmp.h: #undef __need_size_t. + * mp.h: Update from gmp.h. + +Wed Oct 25 00:17:27 1995 Torbjorn Granlund + + * mpf/Makefile.in: Compile set_prec.c. + * mpf/realloc.c: Delete this file. + * mpf/Makefile.in: Delete mentions of realloc.c. + + * gmp.h (__mpf_struct): Get rid of `alloc' field. + * mpf/clear.c: Likewise. + * mpf/init*.c: Likewise. + * mpf/set_prec.c: Likewise. + * mpf/iset*.c: Likewise. + + * mpf/iset_str.c: New file. + + * mpn/configure.in: Handle pyramid. + + * mpf/set.c: Use prec+1 as precision. + + * mpf/set_prec.c: New file. + +Tue Oct 24 00:56:41 1995 Torbjorn Granlund + + * mpn/generic/divrem.c: New file. Will replace mpn/generic/divmod.c + when rest of source is converted. + * mpn/configure.in (functions): Add `divrem' + * mpn/generic/set_str.c: Never call __mpn_mul_1 with zero size. + + * mpf/get_str.c: Completely rewritten. + * mpf/add.c: Fix several problems. + * mpf/sub.c: Compare operands from most significant end until + first difference, exclude skipped limbs from computation. + Accordingly simplify normalization code. + * mpf/set_str.c: Fix several problems. + * mpf/dump.c: New file. + * mpf/Makefile.in: Compile dump.c. + * mpf/init2.c: Set prec field correctly. + +Sun Oct 22 03:02:09 1995 Torbjorn Granlund + + * cre-conv-tab.c: #include math.h; don't declare log and floor. + +Sat Oct 21 23:04:10 1995 Torbjorn Granlund + + * mpf/mul_ui.c: Handle U being 0. + +Wed Oct 18 19:39:27 1995 Torbjorn Granlund + + * mpn/generic/set_str.c: Correctly handle input like "000000000000". + Misc cleanups. + +Tue Oct 17 15:14:13 1995 Torbjorn Granlund + + * longlong.h: Define COUNT_LEADING_ZEROS_0 for machines where + appropriate. + +Mon Oct 16 19:14:43 1995 Torbjorn Granlund + + * mpf/add.c: Rewrite. + * mpf/set_str.c: New file. Needs more work. + +Sat Oct 14 00:14:04 1995 Torbjorn Granlund + + * mpf/div_2exp.c: Vastly simplify. + * mpf/mul_2exp.c: Likewise. + + * mpf/sub.c: Rewrite. + + * gmp-impl.h (udiv_qrnnd_preinv2gen): Terminate comment. + + * mpf/dump.c: Free allocated memory. + + * gmp-impl.h (assert): Define. + +Wed Oct 11 13:31:00 1995 Torbjorn Granlund + + * mpn/pentium/rshift.S: Install new code to optimize shift-by-1. + +Tue Oct 10 00:37:21 1995 Torbjorn Granlund + + * mpn/pentium/lshift.S: Install new code to optimize shift-by-1. + + * mpn/powerpc32/{lshift.s,rshift.s}: New files. + + * configure.in: Fix typo. + +Sat Oct 7 08:17:09 1995 Torbjorn Granlund + + * longlong.h (smul_ppmm): Correct type of __m0 and __m1. + +Wed Oct 4 16:31:28 1995 Torbjorn Granlund + + * mpn/configure.in: Handle alphaev5. + * mpn/ev4: New name for alpha subdir. + * mpn/ev5: New subdir. + * mpn/ev5/lshift.s: New file. + +Tue Oct 3 15:06:45 1995 Torbjorn Granlund + + * mpn/alpha/mul_1.s: Avoid static increments of pointers; use + corresponding offsets in ldq and stq instructions instead. + (Loop): Swap cmpult and stq to save one cycle on EV5. + + * mpn/tests/{add_n.s,sub_n.s,lshift.s,rshift.s,mul_1.s,addmul_1.s, + submul_1.s}: Don't check results if NOCHECK is defined. + +Mon Oct 2 11:40:18 1995 Torbjorn Granlund + + * longlong.h (mips umul_ppmm [32 and 64 bit versions]): + Make new variants, based on GCC version number, that use `l' and `h' + constraints instead of explicit mflo and mfhi instructions + +Sun Oct 1 00:17:47 1995 Torbjorn Granlund + + * mpn/mc88100/add_n.s: Decrease unrolling factor from 16 to 8. + * mpn/mc88100/sub_n.s: Likewise. + + * config/mt-m88110: New file. + * configure.in: Use it. + + * mpn/mc88110/mul_1.s: Fix thinko. + +Sat Sep 30 21:28:19 1995 Torbjorn Granlund + + * mpz/set_d.c: Declare `size' at function start. + + * experimental: New directory for mpx and mpz2. + + * mpz/tdiv_q.c: Clarify comments. + * mpz/{mod.c,mod_ui.c}: New file, for math mod function. + + * mpn/sh2/{mul_1.s,addmul_1.s,submul_1.s}: New files. + + * mpn/sh/{add_n.s,sub_n.s}: New files. + + * mpn/pyr/{add_n.s,sub_n.s,mul_1.s,addmul_1.s}: New files. + + * mpn/i960/{add_n.s,sub_n.s}: New files. + + * mpn/alpha/addmul_1.s (Loop): Move decrement of r18 to before umulh, + to save cycles on EV5. + * mpn/alpha/submul_1.s: Ditto. + * mpn/alpha/mul_1.s: Ditto. + +Thu Sep 28 02:48:59 1995 Torbjorn Granlund + + * gmp.h (mp_limb, mp_limb_signed): Define as `long long' if + _LONG_LONG_LIMB is defined. + + * longlong.h (m88110): Test __m88110__, not __mc88110__ + + * mpn/mc88110/mul_1.s: Rewrite. + +Tue Sep 26 23:29:05 1995 Torbjorn Granlund + + * config.sub: Update from current Cygnus version. + + * mpn/configure.in: Recognize canonical m88*, not mc88*. + +Fri Sep 22 14:58:05 1995 Torbjorn Granlund + + * mpz/set_d.c: New file. + * mpz/Makefile.in: Build new files. + + * mpq/get_d.c: Replace usage of scalbn with ldexp. + + * mpn/{vax,i386}/gmp-mparam.h: New files. + * gmp-impl.h (ieee_double_extract): Define here. + * mpf/set_d.c (ieee_double_extract): Not here. + +Thu Sep 21 00:56:36 1995 Torbjorn Granlund + + * longlong.h (C umul_ppmm): Use UWtype, not USItype for temps. + (udiv_qrnnd): For cases implemented with call to __udiv_qrnnd, + protect with new symbol LONGLONG_STANDALONE. + (68000 umul_ppmm): Use %# prefix for immediate constants. + +Wed Sep 20 15:36:23 1995 Torbjorn Granlund + + * mpn/generic/divmod_1.c: Handle + divisor_limb == 1 << (BITS_PER_MP_LIMB - 1) + specifically also when normalization_steps != 0. + +Mon Sep 18 15:42:30 1995 Torbjorn Granlund + + * mpq/get_d.c: New file. + +Sun Sep 17 02:04:36 1995 Torbjorn Granlund + + * longlong.h (pyr): Botch up for now. + +Sat Sep 16 00:11:50 1995 Torbjorn Granlund + + * mpn/clipper/mul_1.s: New file. + * mpn/clipper/add_n.s: New file. + * mpn/clipper/sub_n.s: New file. + * mpn/configure.in: Handle clipper*-*-*. + + * mpn/configure.in: Recognize rs6000-*-*. + +Fri Sep 15 00:41:34 1995 Torbjorn Granlund + + * mpn/alpha/add_n.s: New file. + * mpn/alpha/sub_n.s: New file. + + * mpn/mips3: New name for mpn/r4000. + * mpn/mips2: New name for mpn/r3000. + * mpn/configure.in: Corresponding changes. + + * mpn/generic/perfsqr.c (primes): Delete. + (residue_map): Delete. + +Thu Sep 14 00:07:58 1995 Torbjorn Granlund + + * mpn/r3000/sub_n.s: Fix typo. + + * dm_trunc.c: Delete spurious file. + + * mpz/out_binary.c: Fix typo. + + * mpn/configure.in (per-target): Make mips*-*-irix6* imply r4000. + + * gmp-impl.h: For sparc and sgi, include alloca.h. + + * mpn/z8000/mul_1.s: Replace `test r' with `and r,r'. Replace + `ldk r,#0' with `xor r,r'. + +Wed Sep 6 00:58:38 1995 Torbjorn Granlund + + * mpz/inp_binary.c: New file. + * mpz/out_binary.c: New file. + * mpz/Makefile.in: Build new files. + +Tue Sep 5 22:53:51 1995 Torbjorn Granlund + + * gmp.h (__mpz_struct): Change `long int' => `mp_size_t' for alloc + and size fields. + +Sat Sep 2 17:47:59 1995 Torbjorn Granlund + + * mpn/r4000/{add_n.s,sub_n.s}: Optimize away some pointer arithmetic. + * mpn/r3000/{add_n.s,sub_n.s,lshift.s,rshift.s}: New files, + derived from r4000 code. + +Fri Sep 1 05:35:52 1995 Torbjorn Granlund + + * mpn/r3000/mul_1.s: Fix typo. + + * mpn/powerpc32: Fix some old vs new mnemonic issues. + + * mpn/powerpc32/{add_n.s,sub_n.s}: New files. + * mpn/r4000/{add_n.s,sub_n.s,lshift.s,rshift.s}: New files. + +Wed Aug 30 10:43:47 1995 Torbjorn Granlund + + * mpn/r3000/mul_1.s ($LC1): Use addiu for immediate add. + * mpn/r4000/{mul_1.s,addmul_1.s,submul_1.s}: New files. + + * config.guess: Update to latest FSF revision. + +Mon Aug 28 02:18:13 1995 Torbjorn Granlund + + * mpz/out_str.c: Cast str to char * in fputs call. + + * gmp-impl.h: Define UQItype, SItype, and USItype also + when not __GNUC__. + +Fri Aug 25 01:45:04 1995 Torbjorn Granlund + + * mpn/i386/syntax.h: Renamed from asm-syntax.h. + * mpn/mc68020/syntax.h: Renamed from asm-syntax.h. + * mpn/configure.in: Corresponding changes. + +Sun Aug 13 19:20:04 1995 Torbjorn Granlund + + * mpn/generic/random2.c: Test __hpux, not hpux. + +Sat Apr 15 20:50:33 1995 Torbjorn Granlund (tege@tiny.cygnus.com) + + * mpn/sparc/add_n.S: Make it work for PIC. + * mpn/sparc/sub_n.s: Likewise. + * mpn/sparc8/addmul_1.S: Likewise. + * mpn/sparc8/mul_1.S: Likewise. + * mpn/i386/add_n.S: Likewise. + * mpn/i386/sub_n.S: Likewise. + +Thu Apr 13 23:15:03 1995 Torbjorn Granlund (tege@tiny.cygnus.com) + + * mpn/configure.in: Don't search power subdir for generic ppc configs. + Add some ppc cpu-specific configs. Misc clean up. + +Mon Apr 10 00:16:35 1995 Torbjorn Granlund (tege@tiny.cygnus.com) + + * mpz/ui_pow_ui.c: Delete spurious code to handle negative results. + +Sun Apr 9 12:38:11 1995 Torbjorn Granlund (tege@tiny.cygnus.com) + + * longlong.h (SPARC v8 udiv_qrnnd): Generate remainder in C, + not in asm. + + * mpn/generic/sqrt.c (SQRT): Test for __SOFT_FLOAT. + +Tue Mar 28 00:19:52 1995 Torbjorn Granlund (tege@tiny.cygnus.com) + + * mpn/generic/hamdist.c (popc_limb): Make Mar 16 change here too. + +Fri Mar 17 23:29:22 1995 Torbjorn Granlund (tege@tiny.cygnus.com) + + * longlong.h (SH umul_ppmm): Define. + +Thu Mar 16 16:40:44 1995 Torbjorn Granlund (tege@tiny.cygnus.com) + + * mpn/generic/popcount.c (popc_limb): Rearrange 32 bit case + to help CSE. + +Fri Mar 10 20:03:49 1995 Torbjorn Granlund (tege@tiny.cygnus.com) + + * mpn/powerpc32/mul_1.s: Clear cy before entering loop. + Rearrange loop to save a cycle. + * mpn/powerpc32/addmul_1.s: New file. + * mpn/powerpc32/submul_1.s: New file. + +Fri Feb 17 22:44:45 1995 Torbjorn Granlund (tege@tiny.cygnus.com) + + * mpn/configure.in: Set target_makefile_frag for freebsd + in new case stmt. + * mpn/config/t-freebsd: New file. + * mpn/Makefile.in: Add #### for frag insertion. + (XCFLAGS): Clear by default. + (.c.o, .S.o rules): Pass XCFLAGS. + +Tue Feb 7 16:27:50 1995 Torbjorn Granlund (tege@tiny.cygnus.com) + + * longlong.h (68000 umul_ppmm): Merge improvements from henderson. + +Tue Jan 24 04:23:20 1995 Torbjorn Granlund (tege@tiny.cygnus.com) + + * longlong.h (default umul_ppmm): Store input parameters in temporaries + to avoid reading them twice. + (default smul_ppmm): New definition. + +Thu Dec 29 04:20:07 1994 Jim Meyering (meyering@comco.com) + + * generic/perfsqr.c (__mpn_perfect_square_p): Remove declaration + of unused variable. + * generic/pre_mod_1.c (__mpn_preinv_mod_1): Likewise. + * mpz/powm.c (pow): Likewise. + + * mpz/and.c (mpz_and): Use {} instead of `;' for empty else clause + to placate `gcc -Wall'. + * mpz/ior.c (mpz_ior): Likewise. + +Wed Dec 28 13:31:40 1994 Torbjorn Granlund (tege@tiny.cygnus.com) + + * mpn/m*68*/*.S: #include asm-syntax.h, not asm.h. + +Mon Dec 26 17:15:36 1994 Torbjorn Granlund (tege@tiny.cygnus.com) + + * longlong.h: Test for more symbols, in __mc68000__ case. + + * mpn/mpn/config.sub: Recognize m68060. + * mpn/configure.in: Change mc* to m* for 68k targets. + * mpn/Makefile.in (.S.o): Delete spurious creation of temp .c file. + +Mon Dec 19 01:56:30 1994 Torbjorn Granlund (tege@tiny.cygnus.com) + + * config.sub: Recognize pentium as a valid CPU. + * mpn/configure.in: Handle pentium specifically, to use new assembly + code. + +Mon Dec 19 00:13:01 1994 Jim Meyering (meyering@comco.com) + + * gmp.h: Define _GMP_H_HAVE_FILE if FILE, __STDIO_H__, or H_STDIO + is defined. + * gmp.h: test _GMP_H_HAVE_FILE instead of FILE everywhere else. + +Mon Dec 19 00:04:54 1994 Kent Boortz (boortz@sics.se) + + * Makefile.in (recursive makes): Pass CFLAGS. + +Sun Dec 18 22:34:49 1994 Torbjorn Granlund (tege@tiny.cygnus.com) + + * mpn/pentium: New directory. + + * mpz/pprime.c: Make sure to mpz_clear all temporaries. + + * longlong.h: Don't use udiv instruction when SUPERSPARC is defined. + * configure.in: Handle supersparc*-. + * config/mt-supspc-gcc: New file. + * config/mt-sparc8-gcc: New name for mt-sparcv8-gcc. + +Mon Dec 12 22:22:10 1994 Torbjorn Granlund (tege@tiny.cygnus.com) + + * mpn/i386/*.S: #include "asm-syntax.h", not "asm.h". + #include sysdep.h before asm-syntax.h. + + * mpn/mc68020/asm-syntax.h: #undef ALIGN before defining it. + * mpn/i386/asm-syntax.h: Likewise. + + * mpn/mc68020/asm-syntax.h: New name for asm.h. + * mpn/i386/asm-syntax.h: New name for asm.h. + +Tue Dec 6 21:55:25 1994 Torbjorn Granlund (tege@tiny.cygnus.com) + + * mpz/array_init.c: Fix typo in declaration. + +Fri Nov 18 19:50:52 1994 Torbjorn Granlund (tege@tiny.cygnus.com) + + * mpn/Makefile.in (.S.o): Pass CFLAGS and INCLUDES. + +Mon Nov 14 00:34:12 1994 Torbjorn Granlund (tege@tiny.cygnus.com) + + * mpn/generic/random2.c (random): Test for __svr4__. + +Wed Oct 12 23:28:16 1994 Torbjorn Granlund (tege@tiny.cygnus.com) + + * cre-conv-tab.c (main): Avoid upper-case X in printf format string. + +Tue Aug 23 17:16:35 1994 Torbjorn Granlund (tege@tiny.cygnus.com) + + * mpz/perfsqr.c: Use mpn_perfect_square_p. + * mpn/generic/perfsqr.c: New file. + +Wed Jul 6 13:46:51 1994 Torbjorn Granlund (tege@tiny.cygnus.com) + + * mpz/array_init.c: New file. + * mpz/Makefile.in: Compile array_init. + * gmp.h: Declare mpz_array_init. + +Mon Jul 4 01:10:03 1994 Torbjorn Granlund (tege@tiny.cygnus.com) + + * mpz/add.c: Fix bogus comment. + * mpz/sub.c: Likewise. + +Sat Jul 2 02:14:56 1994 Torbjorn Granlund (tege@adder.cygnus.com) + + * mpn/generic/pre_mod_1.c: New file. + * mpz/perfsqr.c: Use __mpn_preinv_mod_1 when faster. + +Fri Jul 01 22:10:19 1994 Richard Earnshaw (rwe11@cl.cam.ac.uk) + + * longlong.h (arm umul_ppmm): Fix typos in last change. Mark + hard-coded registers with "%|" + +Thu Jun 30 03:59:33 1994 Torbjorn Granlund (tege@tiny.cygnus.com) + + * mpz/perfsqr.c: Define PP, etc, for machines with 64 bit limbs. + Use __mpn_mod_1. + * mpz/perfsqr.c: Don't clobber REM in quadratic residue check loop. + +Wed Jun 29 18:45:41 1994 Torbjorn Granlund (tege@adder.cygnus.com) + + * mpn/generic/sqrt.c (SQRT): New asm for IBM POWER2. + + * mpz/gcd_ui.c: Return 0 if result does not fit an unsigned long. + + * gmp.h: Use "defined (__STDC__)" consistently. + +Tue Jun 28 18:44:58 1994 Torbjorn Granlund (tege@adder.cygnus.com) + + * gmp.h (mpz_get_si): Don't use "signed" keyword for return type. + + * mpz/tests/Makefile.in: Use CFLAGS for linking. + + * Makefile.in (CFLAGS): Use -O2 here. + * mpn/Makefile (CFLAGS): Not here. + + * mpq/cmp_ui.c: Fix typo. + * mpq/canonicalize.c: Fix typo. + * mpz/gcd_ui.c: Handle gcd(0,v) and gcd(u,0) correctly. + * mpn/generic/gcd_1.c: Fix braino in last change. + +Mon Jun 27 16:10:27 1994 Torbjorn Granlund (tege@rtl.cygnus.com) + + * mpz/gcd_ui.c: Change return type and return result. + Allow destination param to be NULL. + * gmp.h: Corresponding change. + * mpn/generic/gcd_1.c: Handle zero return from mpn_mod_1. + +Tue Jun 14 02:17:43 1994 Torbjorn Granlund (tege@tiny.cygnus.com) + + * mpn/i386/asm.h (ALIGN): Make it take a parameter. + * mpn/i386/*.S: Use ALIGN to align all loops. + + * mpn/i386/*.S: Move colon inside C_GLOBAL_NAME expression. + (Makes old versions of GAS happy.) + +Sat May 28 01:43:54 1994 Torbjorn Granlund (tege@adder.cygnus.com) + + * Many files: Delete unused variables and labels. + * mpn/generic/dump.c: cast printf width argument to int. + +Wed May 25 00:42:37 1994 Torbjorn Granlund (tege@thepub.cygnus.com) + + * mpz/gcd.c (mpz_gcd): Normalize after __mpn_sub calls. + (xmod): Ignore return value of __mpn_divmod. + (xmod): Improve normalization code. + +Sat May 21 01:30:09 1994 Torbjorn Granlund (tege@adder.cygnus.com) + + * mpz/gcdext.c: Cosmetic changes. + + * mpz/fdiv_ui.c: New file. + +Fri May 20 00:24:53 1994 Torbjorn Granlund (tege@adder.cygnus.com) + + * mpz/tests/Makefile.in: Use explicit rules for running tests, + not a shell loop. + (clean): Delete stmp-*. + + * mpz/Makefile.in: Update. + + * mpz/div_ui.c: Don't include longlong.h. + * mpz/dm_ui.c: Likewise. + + * mpz/fdiv_q.c, mpz/fdiv_q_ui.c, mpz/fdiv_qr.c, mpz/fdiv_qr_ui.c, + mpz/fdiv_r.c, mpz/fdiv_r_ui.c: New files. Code partly from deleted + mdm.c, mdm_ui.c, etc, partly rewritten. + * mpz/dm_floor_ui.c, mpz/dm_floor.c: Delete. + * mpz/mdm.c, mpz/mdm_ui.c, mpz/mdiv.c, mpz/mdiv_ui.c, mpz/mmod.c, + mpz/mmod_ui.c: Delete. + + * mpz/tdiv_q.c, mpz/tdiv_q_ui.c, mpz/tdiv_qr.c, mpz/tdiv_qr_ui.c, + mpz/tdiv_r.c, mpz/tdiv_r_ui.c: + New names for files implementing truncating division. + * mpz/div_ui.c, mpz/dm_ui.c, mpz/mod_ui.c: Simplify. + + * mpn/Makefile.in (.S.o): Don't rely on CPP being defined, use CC + instead. + (clean): Delete tmp-*. + +Thu May 19 01:37:44 1994 Torbjorn Granlund (tege@adder.cygnus.com) + + * mpz/cmp.c: Call __mpn_cmp. + + * mpz/popcount.c: Fix typo. + + * mpz/powm_ui.c: Simplify main loop. Keep principal operand size + smaller than MSIZE when possible. + * mpz/powm.c: Likewise. + + * mpn/generic/sqrt.c: Move alloca calls into where the memory is + needed. Simplify. + + * gmp.h: (_PROTO): New macro. + Add many function declarations; use _PROTO macro in all declarations. + + * mpf/*.c: Prepend mpn calls with __. + +Wed May 18 20:57:06 1994 Torbjorn Granlund (tege@adder.cygnus.com) + + * mpf/*ui*.c: Make ui argument `long' for consistency with mpz + functions. + + * mpf/div_ui.c: Simplify. + +Tue May 17 01:05:14 1994 Torbjorn Granlund (tege@adder.cygnus.com) + + * mpz/*.c: Prepend mpn calls with __. + + * mpz/mul_ui.c: Use mpn_mul_1. + +Mon May 16 17:19:41 1994 Torbjorn Granlund (tege@adder.cygnus.com) + + * mpn/i386/mul_1.S: Use C_GLOBAL_NAME. + * mpn/i386/mul_1.S, mpn/i386/addmul_1.S, mpn/i386/submul_1.S: + Nuke use of LAB. + +Sat May 14 14:21:02 1994 Torbjorn Granlund (tege@adder.cygnus.com) + + * gmp-impl.h: Don't define abort here. + + * mpz/pow_ui.c: Increase temporary allocation. + * mpz/ui_pow_ui.c: Likewise. + + * gmp.h (mpz_add_1, mpz_sub_1): Don't call memcpy. + + * All Makefile.in: Delete spurious -I arguments. + Update dependencies. + + * mpz/popcount.c: New file. + * mpz/hamdist.c: New file. + + * All configure: Latest version from Cygnus. + + * mpq/Makefile.in: New file. + * mpq/configure.in: New file. + * Makefile.in, configure.in: Enable compilation of mpq. + + * mpq/set_z.c: Fix typos. + * mpq/canonicalize.c: Fix typos. + * mpq/cmp_ui.c: Fix typos. + + * mpf/add_ui.c: Read U->D into UP always. Delete spurious MPN_COPY. + * mpf/sub_ui.c: Likewise. + + * gmp-impl.h: Don't redefine alloca. + + * COPYING.LIB: Renamed from COPYING. + +Wed May 11 01:45:44 1994 Torbjorn Granlund (tege@adder.cygnus.com) + + * mpz/powm_ui.c: When shifting E left by C+1, handle out-of-range + shift counts. Fix typo when testing negative_result. + * mpz/powm.c: Likewise. + + * mpz/ui_pow_ui.c: New file. + * mpz/Makefile.in: Update. + + * mpz/pow_ui.c: Call __mpn_mul_n instead of __mpn_mul when possible. + + * mpz/div.c, mpz/div_ui.c, mpz/gcd.c: Prefix external mpn calls. + * mpz/gcd.c: Declare mpn_xmod. + + * mpz/powm.c: Major changes to accommodate changed mpn semantics. + * mpz/powm_ui.c: Update from mpz/powm.c. + + * mpz/tests/tst-io.c: New file. + * mpz/tests/tst-logic: New file. + * mpz/tests/Makefile.in: Update. + + * mpz/inp_str.c: Get base right when checking for first digit. + * mpz/inp_str.c: Allocate more space for DEST when needed. + + * mpz/com.c: Use mpn_add_1 and mpn_sub_1. + * mpz/and.c, mpz/ior.c: Likewise. Simplify somewhat. + + * mpz/add_ui.c: Use mpn_add_1 and mpn_sub_1. + Rename parameters to be consistent with mpz/sub_ui. + General simplifications. + * mpz/sub_ui.x: Likewise. + +Tue Aug 10 19:41:16 1993 Torbjorn Granlund (tege@prudens.matematik.su.se) + + * mpf: New directory. + * mpf/*.c: Merge basic set of mpf functions. + + * Many logs missing... + +Sun Apr 25 18:40:26 1993 Torbjorn Granlund (tege@pde.nada.kth.se) + + * memory.c: Use #if instead of #ifdef for __STDC__ for consistency. + * bsd/xtom.c: Likewise. + + * mpz/div.c: Remove free_me and free_me_size and their usage. + Use mpn_divmod for division; corresponding changes in return value + convention. + * mpz/powm.c: `carry_digit' => `carry_limb'. + * bsd/sdiv.c: Clarify comment. + +Sun Apr 25 00:31:28 1993 Torbjorn Granlund (tege@pde.nada.kth.se) + + * longlong.h (__udiv_qrnnd_c): Make all variables `unsigned long int'. + +Sat Apr 24 16:23:33 1993 Torbjorn Granlund (tege@pde.nada.kth.se) + + * longlong.h (__udiv_qrnnd_c): Make all variables `unsigned long int'. + + * gmp-impl.h: #define ABS. + * (Many files): Use ABS instead of abs. + + * mpn/generic/sqrt.c, mpz/clrbit.c, mpz/get_si.c, mpz/mod_2exp.c, + mpz/pow_ui.c: Cast 1 to mp_limb before shifting. + + * mpz/perfsqr.c: Use #if, not plain if for exclusion of code for + non-32-bit machines. + +Tue Apr 20 13:13:58 1993 Torbjorn Granlund (tege@du.nada.kth.se) + + * mpn/generic/sqrt.c: Handle overflow for intermediate quotients by + rounding them down to fit. + + * mpz/perfsqr.c (PP): Define in hexadecimal to avoid GCC warnings. + + * mpz/inp_str.c (char_ok_for_base): New function. + (mpz_inp_str): Use it. + +Sun Mar 28 21:54:06 1993 Torbjorn Granlund (tege@cyklop.nada.kth.se) + + * mpz/inp_raw.c: Allocate x_index, not xsize limbs. + +Mon Mar 15 11:44:06 1993 Torbjorn Granlund (tege@pde.nada.kth.se) + + * mpz/pprime.c: Declare param `const'. + * gmp.h: Add declarations for mpz_com. + +Thu Feb 18 14:10:34 1993 Torbjorn Granlund (tege@pde.nada.kth.se) + + * mpq/add.c, mpq/sub.c: Call mpz_clear for t. + +Fri Feb 12 20:27:34 1993 Torbjorn Granlund (tege@cyklop.nada.kth.se) + + * mpz/inp_str.c: Recog minus sign as first character. + +Wed Feb 3 01:36:02 1993 Torbjorn Granlund (tege@cyklop.nada.kth.se) + + * mpz/iset.c: Handle 0 size. + +Tue Feb 2 13:03:33 1993 Torbjorn Granlund (tege@cyklop.nada.kth.se) + + * mpz/mod_ui.c: Initialize dividend_size before it's used. + +Mon Jan 4 09:11:15 1993 Torbjorn Granlund (tege@sics.se) + + * bsd/itom.c: Declare param explicitly 'signed'. + * bsd/sdiv.c: Likewise. + + * mpq/cmp.c: Remove unused variable tmp_size. + * mpz/powm_ui.c: Fix typo in esize==0 if stmt. + * mpz/powm.c: Likewise. + +Sun Nov 29 01:16:11 1992 Torbjorn Granlund (tege@sics.se) + + * mpn/generic/divmod_1.c (mpn_divmod_1): Handle + divisor_limb == 1 << (BITS_PER_MP_LIMB - 1) + specifically. + + * Reorganize sources. New directories mpn, mpn/MACH, mpn/generic, + mpz, mpq, bsd. Use full file name for change logs hereafter. + +Wed Oct 28 17:40:04 1992 Torbjorn Granlund (tege@jupiter.sics.se) + + * longlong.h (__hppa umul_ppmm): Fix typos. + (__hppa sub_ddmmss): Swap input arguments. + + * mpz_perfsqr.c (mpz_perfect_square_p): Avoid , before } in + initializator. + +Sun Oct 25 20:30:06 1992 Torbjorn Granlund (tege@jupiter.sics.se) + + * mpz_pprime.c (mpz_probab_prime_p): Handle numbers <= 3 + specifically (used to consider all negative numbers prime). + + * mpz_powm_ui: `carry_digit' => `carry_limb'. + + * sdiv: Handle zero dividend specifically. Replace most code in + this function with a call to mpn_divmod_1. + +Fri Sep 11 22:15:55 1992 Torbjorn Granlund (tege@tarrega.sics.se) + + * mpq_clear: Don't free the MP_RAT! + + * mpn_lshift, mpn_rshift, mpn_rshiftci: Remove `long' from 4:th arg. + +Thu Sep 3 01:47:07 1992 Torbjorn Granlund (tege@jupiter.sics.se) + + * All files: Remove leading _ from mpn function names. + +Wed Sep 2 22:21:16 1992 Torbjorn Granlund (tege@jupiter.sics.se) + + Fix from Jan-Hein Buhrman: + * mpz_mdiv.c, mpz_mmod.c, mpz_mdm.c: Make them work as documented. + + * mpz_mmod.c, mpz_mdm.c: Move decl of TEMP_DIVISOR to reflect its + life. + +Sun Aug 30 18:37:15 1992 Torbjorn Granlund (tege@jupiter.sics.se) + + * _mpz_get_str: Use mpz_sizeinbase for computing out_len. + * _mpz_get_str: Don't remove leading zeros. Abort if there are some. + +Wed Mar 4 17:56:56 1992 Torbjorn Granlund (tege@zevs.sics.se) + + * gmp.h: Change definition of MP_INT to make the & before params + optional. Use typedef to define it. + * mp.h: Use typedef to define MINT. + +Tue Feb 18 14:38:39 1992 Torbjorn Granlund (tege@zevs.sics.se) + + longlong.h (hppa umul_ppmm): Add missing semicolon. Declare type + of __w1 and __w0. + +Fri Feb 14 21:33:21 1992 Torbjorn Granlund (tege@zevs.sics.se) + + * longlong.h: Make default count_leading_zeros work for machines > + 32 bits. Prepend `__' before local variables to avoid conflicts + with users' variables. + + * mpn_dm_1.c: Remove udiv_qrnnd_preinv ... + * gmp-impl.h: ... and put it here. + * mpn_mod_1: Use udiv_qrnnd_preinv if it is faster than udiv_qrnnd. + +Tue Feb 11 17:20:12 1992 Torbjorn Granlund (tege@zevs.sics.se) + + * mpn_mul: Enhance base case by handling small multiplicands. + * mpn_dm_1.c: Revert last change. + +Mon Feb 10 11:55:15 1992 Torbjorn Granlund (tege@zevs.sics.se) + + * mpn_dm_1.c: Don't define udiv_qrnnd_preinv unless needed. + +Fri Feb 7 16:26:16 1992 Torbjorn Granlund (tege@zevs.sics.se) + + * mpn_mul: Replace code for base case. + +Thu Feb 6 15:10:42 1992 Torbjorn Granlund (tege@zevs.sics.se) + + * mpn_dm_1.c (_mpn_divmod_1): Add code for avoiding division by + pre-inverting divisor. + +Sun Feb 2 11:10:25 1992 Torbjorn Granlund (tege@zevs.sics.se) + + * longlong.h: Make __LLDEBUG__ work differently. + (_IBMR2): Reinsert old code. + +Sat Feb 1 16:43:00 1992 Torbjorn Granlund (tege@zevs.sics.se) + + * longlong.h (#ifdef _IBMR2): Replace udiv_qrnnd with new code + using floating point operations. Don't define + UDIV_NEEDS_NORMALIZATION any longer. + +Fri Jan 31 15:09:13 1992 Torbjorn Granlund (tege@zevs.sics.se) + + * longlong.h: Define UMUL_TIME and UDIV_TIME for most machines. + * longlong.h (#ifdef __hppa): Define umul_ppmm. + +Wed Jan 29 16:41:36 1992 Torbjorn Granlund (tege@zevs.sics.se) + + * mpn_cmp: Only one length parameter, assume operand lengths are + the same. Don't require normalization. + * mpq_cmp, mpz_add, mpz_sub, mpz_gcd, mpn_mul, mpn_sqrt: Change for + new mpn_cmp definition. + +Tue Jan 28 11:18:55 1992 Torbjorn Granlund (tege@zevs.sics.se) + + * _mpz_get_str: Fix typo in comment. + +Mon Jan 27 09:44:16 1992 Torbjorn Granlund (tege@zevs.sics.se) + + * Makefile.in: Add new files. + + * mpn_dm_1.c: New file with function _mpn_divmod_1. + * mpz_dm_ui.c (mpz_divmod_ui): Use _mpn_divmod_1. + * mpz_div_ui: Likewise. + + * mpn_mod_1.c: New file with function _mpn_mod_1. + * mpz_mod_ui: Use _mpn_mod_1. + +Thu Jan 23 18:54:09 1992 Torbjorn Granlund (tege@zevs.sics.se) + + Bug found by Paul Zimmermann (zimmermann@inria.inria.fr): + * mpz_div_ui.c (mpz_div_ui), mpz_dm_ui.c (mpz_divmod_ui): + Handle dividend == 0. + +Wed Jan 22 12:02:26 1992 Torbjorn Granlund (tege@zevs.sics.se) + + * mpz_pprime.c: Use "" for #include. + +Sun Jan 19 13:36:55 1992 Torbjorn Granlund (tege@zevs.sics.se) + + * mpn_rshiftci.c (header): Correct comment. + +Wed Jan 15 18:56:04 1992 Torbjorn Granlund (tege@zevs.sics.se) + + * mpz_powm, mpz_powm_ui (if (bsize > msize)): Do alloca (bsize + 1) + to make space for ignored quotient at the end. (The quotient might + always be an extra limb.) + +Tue Jan 14 21:28:48 1992 Torbjorn Granlund (tege@zevs.sics.se) + + * mpz_powm_ui: Fix comment. + * mpz_powm: Likewise. + +Mon Jan 13 18:16:25 1992 Torbjorn Granlund (tege@zevs.sics.se) + + * tests/Makefile.in: Prepend $(TEST_PREFIX) to Makefile target. + +Sun Jan 12 13:54:28 1992 Torbjorn Granlund (tege@zevs.sics.se) + + Fixes from Kazumaro Aoki: + * mpz_out_raw: Take abs of size to handle negative values. + * mpz_inp_raw: Reallocate before reading ptr from X. + * mpz_inp_raw: Store, don't read, size to x->size. + +Tue Jan 7 17:50:25 1992 Torbjorn Granlund (tege@zevs.sics.se) + + * gmp.h, mp.h: Remove parameter names from prototypes. + +Sun Dec 15 00:09:36 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * tests/Makefile.in: Prepend "./" to file names when executing + tests. + + * Makefile.in: Fix many problems. + +Sat Dec 14 01:00:02 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * mpn_sqrt.c: New file with _mpn_sqrt. + * mpz_sqrt, mpz_sqrtrem, mpz_perfect_square_p: Use _mpn_sqrt. + * msqrt.c: Delete. Create from mpz_sqrtrem.c in Makefile.in. + * mpz_do_sqrt.c: Delete. + * Makefile.in: Update to reflect these changes. + + * Makefile.in, configure, configure.subr: New files + (from bothner@cygnus.com). + * dist-Makefile: Delete. + + * mpz_fac_ui: Fix comment. + + * mpz_random2: Rewrite a bit to make it possible for the most + significant limb to be == 1. + + * mpz_pprime.c (mpz_probab_prime_p): Remove \t\n. + +Fri Dec 13 23:10:02 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * mpz_do_sqrt: Simplify special case for U == 0. + * m*sqrt*.c, mpz_perfsqr.c (mpz_perfect_square_p): + Rename _mpz_impl_sqrt to _mpz_do_sqrt. + +Fri Dec 13 12:52:28 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * gmp-impl.h (MPZ_TMP_INIT): Cast to the right type. + +Thu Dec 12 22:17:29 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * mpn_add, mpn_sub, mpn_mul, mpn_div: Change type of several + variables to mp_size. + +Wed Dec 11 22:00:34 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * mpn_rshift.c: Fix header comments. + +Mon Dec 9 17:46:10 1991 Torbjorn Granlund (tege@zevs.sics.se) + + Released 1.2. + + * gmp-impl.h (MPZ_TMP_INIT): Cast alloca return value. + + * dist-Makefile: Add missing dependency for cre-mparam. + + * mpz_mdiv.c, mpz_mmod.c, mpz_mdm.c, mpz_mdiv_ui.c, + mpz_mmod_ui.c, mpz_mdm_ui.c: Remove obsolete comment. + + * dist-Makefile (clean): clean in tests subdir too. + * tests/Makefile: Define default values for ROOT and SUB. + + * longlong.h (__a29k__ udiv_qrnnd): Change "q" to "1" for operand + 2 constraint. + +Mon Nov 11 00:06:05 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * mpz_sizeinb.c (mpz_sizeinbase): Special code for size == 0. + +Sat Nov 9 23:47:38 1991 Torbjorn Granlund (tege@zevs.sics.se) + + Released 1.1.94. + + * dist-Makefile, Makefile, tests/Makefile: Merge tests into + distribution. + +Fri Nov 8 22:57:19 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * gmp.h: Don't use keyword `signed' for non-ANSI compilers. + +Thu Nov 7 22:06:46 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * longlong.h: Cosmetic changes to keep it identical to gcc2 version + of longlong.h. + * longlong.h (__ibm032__): Fix operand order for add_ssaaaa and + sub_ddmmss. + +Mon Nov 4 00:36:46 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * mpn_mul: Fix indentation. + + * mpz_do_sqrt: Don't assume 32 bit limbs (had constant + 4294967296.0). + * mpz_do_sqrt: Handle overflow in conversion from double returned + by SQRT to mp_limb. + + * gmp.h: Add missing function definitions. + +Sun Nov 3 18:25:25 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * mpz_pow_ui: Change type of `i' to int. + + * ChangeLog: Add change log entry. + * ChangeLog: Add change log entry. + * ChangeLog: Add change log entry. + * ChangeLog: Add change log entry. + * ChangeLog: Add change log entry. + * ChangeLog: Add change log entry. + * ChangeLog: Add change log entry. + * ChangeLog: Add change log entry. +Stack overflow. + + * mpz_pow_ui.c: Fix typo in comment. + + * dist-Makefile: Create rpow.c from mpz_powm_ui.c. + * mpz_powm_ui.c: Add code for rpow. + * rpow.c: Delete this file. The rpow function is now implemented + in mpz_powm_ui.c. + + * mpz_fac_ui.c: New file. + * gmp.h, dist-Makefile: Add stuff for mpz_fac_ui. + + Bug found by John Amanatides (amana@sasquatch.cs.yorku.ca): + * mpz_powm_ui, mpz_powm: Call _mpn_mul in the right way, with + the first argument not smaller than the second. + +Tue Oct 29 13:56:55 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * cre-conv-tab.c (main), cre-mparam.c (main): Fix typo in output + header text. + +Mon Oct 28 00:35:29 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * mpz_random2: Handle size == 0. + + * gmp-impl.h (struct __mp_bases): Rename chars_per_limb_exactly to + chars_per_bit_exactly, and change its definition. + * cre-conv-tab.c (main): Output field according to its new + definition. + * mpz_out_str, _mpz_get_str, mpz_sizeinb, mout: + Use chars_per_bit_exactly. + + * mpz_random2: Change the loop termination condition in order to + get a large most significant limb with higher probability. + + * gmp.h: Add declaration of new mpz_random2 and mpz_get_si. + * mpz_get_si.c: New file. + * dist-Makefile: Add mpz_random2 and mpz_get_si. + + * mpz_sizeinb.c (mpz_sizeinbase): Special code for base being a + power of 2, giving exact result. + + * mpn_mul: Fix MPN_MUL_VERIFY in various ways. + * mpn_mul: New macro KARATSUBA_THRESHOLD. + * mpn_mul (karatsuba's algorithm): Don't write intermediate results + to prodp, use temporary pp instead. (Intermediate results can be + larger than the final result, possibly writing into hyperspace.) + * mpn_mul: Make smarter choice between Karatsuba's algorithm and the + shortcut algorithm. + * mpn_mul: Fix typo, cy instead of xcy. Unify carry handling code. + +Sun Oct 27 19:57:32 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * mpn_mul: In non-classical case, choose Karatsuba's algorithm only + when usize > 1.5 vsize. + + * mpn_mul: Break between classical and Karatsuba's algorithm at + KARATSUBA_THRESHOLD, if defined. Default to 8. + + * mpn_div: Kludge to fix stray memory read. + +Sat Oct 26 20:06:14 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * mpz_gcdext: Handle a = b = 0. Remove memory leakage by calling + mpz_clear for all temporary variables. + + * mpz_gcd: Reduce w_bcnt in _mpn_lshift call to hold that + function's argument constraints. Compute wsize correctly. + + * mpz_gcd: Fix typo in comment. + + * memory.c (_mp_default_allocate, _mp_default_reallocate): Call + abort if allocation fails, don't just exit. + +Fri Oct 25 22:17:20 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * mpz_random2.c: New file. + +Thu Oct 17 18:06:42 1991 Torbjorn Granlund (tege@zevs.sics.se) + + Bugs found by Pierre-Joseph Gailly (pjg@sunbim.be): + * mpq_cmp: Take sign into account, don't just compare the + magnitudes. + * mpq_cmp: Call _mpn_mul in the right way, with the first argument + not smaller than the second. + +Wed Oct 16 19:27:32 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * mpz_random: Ensure the result is normalized. + +Tue Oct 15 14:55:13 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * mpz_clrbit: Support non-ANSI compilers. + +Wed Oct 9 18:03:28 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * longlong.h (68k add_ssaaaa, sub_ddmmss): Generalize constraints. + +Tue Oct 8 17:42:59 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * mpz_mdm_ui: Add comments. + + * mpz_mdiv: Use MPZ_TMP_INIT instead of mpz_init. + * mpz_init_ui: Change spacing and header comment. + +Thu Oct 3 18:36:13 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * dist-Makefile: Prepend `./' before some filenames. + +Sun Sep 29 14:02:11 1991 Torbjorn Granlund (tege@zevs.sics.se) + + Released 1.1 (public). + + * mpz_com: New name of mpz_not. + * dist-Makefile: Change mpz_not to mpz_com. + +Tue Sep 24 12:44:11 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * longlong.h: Fix header comment. + +Mon Sep 9 15:16:24 1991 Torbjorn Granlund (tege@zevs.sics.se) + + Released 1.0.92. + + * mpn_mul.c (_mpn_mul): Handle leading zero limbs in non-Karatsuba + case. + + * longlong.h (m68000 umul_ppmm): Clobber one register less by + slightly rearranging the code. + +Sun Sep 1 18:53:25 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * dist-Makefile (stamp-stddefh): Fix typo. + +Sat Aug 31 20:41:31 1991 Torbjorn Granlund (tege@zevs.sics.se) + + Released 1.0.91. + + * mpz_mdiv.c, mpz_mmod.c, mpz_mdm.c, mpz_mdiv_ui.c, + mpz_mmod_ui.c, mpz_mdm_ui.c: New files and functions. + * gmp.h, gmp.texi: Define the new functions. + +Fri Aug 30 08:32:56 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * mpz_gcdext: Compute t argument from the other quantities at the + end, of the function, not in the loop. New feature: Allow t to be + NULL. + + * mpz_add.c, mpz_sub.c, mpz_mul.c, mpz_powm.c, mpz_gcd.c: Don't + include "mp.h". Use type name `MP_INT' always. + + * dist-Makefile, mpz_cmp.c: Merge mcmp.c from mpz_cmp.c. + +Wed Aug 28 00:45:11 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * dist-Makefile (documentation): Go via tmp.texi to avoid the + creation of gmp.dvi if any errors occur. Make tex read input + from /dev/null. + +Fri Aug 23 15:58:52 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * longlong.h (68020, i386): Don't define machine-dependent + __umulsidi3 (so the default definition is used). + * longlong.h (all machines): Cast all operands, sources and + destinations, to `unsigned long int'. + * longlong.h: Add gmicro support. + +Thu Aug 22 00:28:29 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * longlong.h: Rename BITS_PER_LONG to LONG_TYPE_SIZE. + * longlong.h (__ibm032__): Define count_leading_zeros and umul_ppmm. + * longlong.h: Define UMUL_TIME and UDIV_TIME for some CPUs. + * _mpz_get_str.c: Add code to do division by big_base using only + umul_qrnnd, if that is faster. Use UMUL_TIME and UDIV_TIME to + decide which variant to use. + +Wed Aug 21 15:45:23 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * longlong.h (__sparc__ umul_ppmm): Move two insn from end to the + nops. (Saves two insn.) + + * longlong.h (__sparc__ umul_ppmm): Rewrite in order to avoid + branch, and to permit input/output register overlap. + + * longlong.h (__29k__): Remove duplicated udiv_qrnnd definition. + * longlong.h (__29k__ umul_ppmm): Split asm instructions into two + asm statements (gives better code if either the upper or lower + part of the product is unused. + +Tue Aug 20 17:57:59 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * _mpz_get_str.c (outside of functions): Remove + num_to_ascii_lower_case and num_to_ascii_upper_case. Use string + constants in the function instead. + +Mon Aug 19 00:37:42 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * cre-conv-tab.c (main): Output table in hex. Output 4 fields, not + 3, for components 0 and 1. + + * gmp.h: Add declaration of mpq_neg. + + Released 1.0beta.13. + + * _mpz_set_str.c (mpz_set_str): Cast EOF and SPC to char before + comparing to enum literals SPC and EOF. This makes the code work + for compilers where `char' is unsigned. (Bug found by Brian + Beuning). + + Released 1.0beta.12. + + * mpz_mod_ui: Remove references to quot. Remove quot_ptr, quot_size + declarations and assignment code. + +Sun Aug 18 14:44:26 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * mpz_mod_ui: Handle dividend < 0. + + Released 1.0beta.11. + + * mpz_dm_ui, mpz_div_ui, mpz_mod_ui, sdiv: Make them share the same + general structure, variable names, etc. + + * sdiv: Un-normalize the remainder in n1 before it is negated. + + * longlong.h: Mention UDIV_NEEDS_NORMALIZATION in description of + udiv_qrnnd. + + * mpz_dm_ui.c (mpz_divmod_ui), mpz_div_ui.c (mpz_div_ui): Increment + the quotient size if the dividend size is incremented. (Bug found + by Brian Beuning.) + + * mpz_mod_ui: Shift back the remainder, if UDIV_NEEDS_NORMALIZATION. + (Bug found by Brian Beuning.) + + * mpz_mod_ui: Replace "digit" by "limb". + + * mpz_perfsqr.c (mpz_perfect_square_p): Disable second test case + for non-32-bit machines (PP is hardwired for such machines). + * mpz_perfsqr.c (outside of functions): Define PP value with an L. + + * mpn_mul.c (_mpn_mul): Add verification code that is activated if + DEBUG is defined. Replace "digit" by "limb". + * mpn_mul.c (_mpn_mul: Karatsuba's algorithm: 4.): Normalize temp + after the addition. + * mpn_mul.c (_mpn_mul: Karatsuba's algorithm: 1.): Compare u0_size + and v0_size, and according to the result, swap arguments in + recursive call. (Don't violate mpn_mul's own argument + constraints.) + +Fri Aug 16 13:47:12 1991 Torbjorn Granlund (tege@zevs.sics.se) + + Released 1.0beta.10. + + * longlong.h (IBMR2): Add udiv_qrnnd. + + * mpz_perfsqr: Remove unused variables. + + * mpz_and (case for different signs): Initialize loop variable i! + + * dist-Makefile: Update automatically generated dependencies. + * dist-Makefile (madd.c, msub.c, pow.c, mult.c, gcd.c): Add mp.h, + etc to dependency file lists. + + * longlong.h (add_ssaaaa, sub_ddmmss [C default versions]): Make __x + `unsigned long int'. + * longlong.h: Add `int' after `unsigned' and `long' everywhere. + +Wed Aug 14 18:06:48 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * longlong.h: Add ARM, i860 support. + + * mpn_lshift, mpn_rshift, mpn_rshiftci: Rename *_word with *_limb. + +Tue Aug 13 21:57:43 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * _mpz_get_str.c, _mpz_set_str.c, mpz_sizeinb.c (mpz_sizeinbase), + mpz_out_str.c, mout.c: Remove declaration of __mp_bases. + * gmp-impl.h: Put it here, and make it `const'. + * cre-conv-tab.c (main): Make struct __mp_bases `const'. + +Mon Aug 12 17:11:46 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * cre-conv-tab.c (main): Use %lu in printf for long ints. + + * dist-Makefile: Fix cre-* dependencies. + + * cre-conv-tab.c (main): Output field big_base_inverted. + + * gmp-impl.h (struct bases): New field big_base_inverted. + * gmp-impl.h (struct bases): Change type of chars_per_limb_exactly + to float (in order to keep the structure smaller). + + * mp.h, gmp.h: Change names of macros for avoiding multiple + includes. + +Fri Aug 9 18:01:36 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * _mpz_get_str: Only shift limb array if normalization_steps != 0 + (optimization). + + * longlong.h (sparc umul_ppmm): Use __asm__, not asm. + * longlong.h (IBMR2 umul_ppmm): Refer to __m0 and __m1, not to m0 + and m1 (overlap between output and input operands did not work). + * longlong.h: Add VAX, ROMP and HP-PA support. + * longlong.h: Sort the machine dependent code in alphabetical order + on the CPU name. + * longlong.h: Hack comments. + +Thu Aug 8 14:13:36 1991 Torbjorn Granlund (tege@zevs.sics.se) + + Released 1.0beta.9. + + * longlong.h: Define BITS_PER_LONG to 32 if it's not already + defined. + * Define __BITS4 to BITS_PER_LONG / 4. + * Don't assume 32 bit word size in "count_leading_zeros" C macro. + Use __BITS4 and BITS_PER_LONG instead. + + * longlong.h: Don't #undef internal macros (reverse change of Aug 3). + + * longlong.h (68k): Define add_ssaaaa sub_ddmmss, and umul_ppmm + even for plain mc68000. + + * mpq_div: Flip the sign of the numerator *and* denominator of the + result if the intermediate denominator is negative. + + * mpz_and.c, mpz_ior.c: Use MPN_COPY for all copying operations. + + * mpz_and.c: Compute the result size more conservatively. + * mpz_ior.c: Likewise. + + * mpz_realloc: Never allocate zero space even if NEW_SIZE == 0. + + * dist-Makefile: Remove madd.c, msub.c, pow.c, mult.c, gcd.c from + BSDMP_SRCS. + + * dist-Makefile: Create mult.c from mpz_mul.c. + * mult.c: Delete this file. + + * _mpz_set_str: Normalize the result (for bases 2, 4, 8... it was + not done properly if the input string had many leading zeros). + +Sun Aug 4 16:54:14 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * dist-Makefile (gcd.c, pow.c, madd.c, msub.c): Make these targets + work with VPATH and GNU MP. + + * mpz_gcd: Don't call mpz_set; inline its functionality. + + * mpq_mul, mpq_div: Fix several serious typos. + + * mpz_dmincl, mpz_div: Don't normalize the quotient if it's already + zero. + + * mpq_neg.c: New file. + + * dist-Makefile: Remove obsolete dependencies. + + * mpz_sub: Fix typo. + + Bugs found by Pierre-Joseph Gailly (pjg@sunbim.be): + * mpq_mul, mpq_div: Initialize tmp[12] variables even when the gcd + is just 1. + * mpz_gcd: Handle gcd(0,v) and gcd(u,0) in special cases. + +Sat Aug 3 23:45:28 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * longlong.h: Clean up comments. + * longlong.h: #undef internal macros. + +Fri Aug 2 18:29:11 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * mpq_set_si, mpq_set_ui: Canonicalize 0/x to 0/1. + * mpq_set_si, mpq_set_ui: Cosmetic formatting changes. + + * mpz_dmincl.c: Normalize the remainder before shifting it back. + + * mpz_dm_ui.c (mpz_divmod_ui): Handle rem == dividend. + + * mpn_div.c: Fix comment. + + * mpz_add.c, mpz_sub.c: Use __MP_INT (not MP_INT) for intermediate + type, in order to work for both GNU and Berkeley functions. + + * dist-Makefile: Create gcd.c from mpz_gcd.c, pow.c from mpz_powm, + madd.c from mpz_add.c, msub.c from mpz_sub.c. + respectively. + * pow.c, gcd.c, mpz_powmincl.c, madd.c, msub.c: Remove these. + * mpz_powm.c, mpz_gcd.c, mpz_add.c, mpz_sub.c: #ifdef for GNU and + Berkeley function name variants. + * dist-Makefile: Add created files to "clean" target. + +Tue Jul 16 15:19:46 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * mpq_get_den: No need for absolute value of the size, the + denominator is always positive. + + * mpz_get_ui: If the operand is zero, return zero. Don't read the + limb array! + + * mpz_dmincl.c: Don't ignore the return value from _mpn_rshift, it + is the size of the remainder. + +Mon Jul 15 11:08:05 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * Several files: Remove unused variables and functions. + + * gmp-impl.h: Declare _mpz_impl_sqrt. + + * mpz_dm_ui (mpz_divmod_ui), sdiv: Shift back the remainder if + UDIV_NEEDS_NORMALIZATION. (Fix from Brian Beuning.) + + * mpz_dm_ui.c, sdiv: Replace *digit with *limb. + + * mpz_ior: Add missing else statement in -OP1 | -OP2 case. + * mpz_ior: Add missing else statement in OP1 | -OP2 case. + * mpz_ior: Swap also OP1 and OP2 pointers in -OP1 & OP2 case. + * mpz_ior: Duplicate _mpz_realloc code. + + * mpz_and: Add missing else statement in -OP1 & -OP2 case. + * mpz_and: Rewrite OP1 & -OP2 case. + * mpz_and: Swap also OP1 and OP2 pointers in -OP1 & OP2 case. + + * mpz_gcdext: Loop in d1.size (not b->size). (Fix from Brian + Beuning.) + + * mpz_perfsqr: Fix argument order in _mpz_impl_sqrt call. (Fix from + Brian Beuning.) + +Fri Jul 12 17:10:33 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * mpq_set.c, mpq_set_ui.c, mpq_set_si.c, mpq_inv.c, + mpq_get_num.c, mpq_get_den.c, mpq_set_num.c, mpq_set_den.c: + New files. + + * mpz_dmincl.c: Remove second re-allocation of rem->d. It + was never executed. + + * dist-Makefile: Use `-r' instead of `-x' for test for ranlib (as + some unixes' test doesn't have the -r option). + + * *.*: Cast allocated pointers to the appropriate type (makes old C + compilers happier). + + * cre-conv-tab.c (main): Divide max_uli by 2 and multiply again + after conversion to double. (Kludge for broken C compilers.) + + * dist-Makefile (stamp-stddefh): New target. Test if "stddef.h" + exists in the system and creates a minimal one if it does not + exist. + * cre-stddefh.c: New file. + * dist-Makefile: Make libgmp.a and libmp.a depend on stamp-stddefh. + * dist-Makefile (clean): Add some more. + * gmp.h, mp.h: Unconditionally include "stddef.h". + +Thu Jul 11 10:08:21 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * min: Do ungetc of last read character. + * min.c: include stdio.h. + + * dist-Makefile: Go via tmp- files for cre* redirection. + * dist-Makefile: Add tmp* to "clean" target. + + * dist-Makefile: Use LOCAL_CC for cre*, to simplify cross + compilation. + + * gmp.h, mp.h: Don't define NULL here. + * gmp-impl.h: Define it here. + +Wed Jul 10 14:13:33 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * mpz_mod_2exp: Don't copy too much, overwriting most significant + limb. + + * mpz_and, mpz_ior: Don't read op[12]_ptr from op[12] when + reallocating res, if op[12]_ptr got their value from alloca. + + * mpz_and, mpz_ior: Clear up comments. + + * cre-mparam.c: Output parameters for `short int' and `int'. + + * mpz_and, mpz_ior: Negate negative op[12]_size in several places. + +Tue Jul 9 18:40:30 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * gmp.h, mp.h: Test for _SIZE_T defined before typedef'ing size_t. + (Fix for Sun lossage.) + + * gmp.h: Add declaration of mpq_clear. + + * dist-Makefile: Check if "ranlib" exists, before using it. + * dist-Makefile: Add mpz_sqrtrem.c and mpz_size.c. + * mpz_powm: Fix typo, "pow" instead of "mpz_powm". + +Fri Jul 5 19:08:09 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * move: Remove incorrect comment. + + * mpz_free, mpq_free: Rename to *_clear. + * dist-Makefile: Likewise. + * mpq_add, mpq_sub, mpq_mul, mpq_div: Likewise. + + * mpz_dmincl.c: Don't call "move", inline its functionality. + +Thu Jul 4 00:06:39 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * Makefile: Include dist-Makefile. Fix dist target to include + dist-Makefile (with the name "Makefile" in the archive). + + * dist-Makefile: New file made from Makefile. Add new mpz_... + functions. + + * mpz_powincl.c New file for mpz_powm (Berkeley MP pow) + functionality. Avoids code duplication. + * pow.c, mpz_powm.c: Include mpz_powincl.c + + * mpz_dmincl.c: New file containing general division code. Avoids + code duplication. + * mpz_dm.c (mpz_divmod), mpz_mod.c (mpz_mod), mdiv.c (mdiv): Include + mpz_dmincl.c. + + * _mpz_get_str: Don't call memmove, unless HAS_MEMMOVE is defined. + Instead, write the overlapping memory copying inline. + + * mpz_dm_ui.c: New name for mpz_divmod_ui.c (SysV file name limit). + + * longlong.h: Don't use #elif. + * mpz_do_sqrt.c: Likewise. + + * longlong.h: Use __asm__ instead of asm. + * longlong.h (sparc udiv_qrnnd): Make it to one string over several + lines. + + * longlong.h: Preend __ll_ to B, highpart, and lowpart. + + * longlong.h: Move array t in count_leading_zeros to the new file + mp_clz_tab.c. Rename the array __clz_tab. + * All files: #ifdef for traditional C compatibility. + +Wed Jul 3 11:42:14 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * mpz_and: Initialize res_ptr always (used to be initialized only + when reallocating). + + * longlong.h (umul_ppmm [C variant]): Make __ul...__vh + `unsigned int', and cast the multiplications. This way + compilers more easily can choose cheaper multiplication + instructions. + + * mpz_mod_2exp: Handle input argument < modulo argument. + * mpz_many: Make sure mp_size is the type for sizes, not int. + + * mpz_init, mpz_init_set*, mpq_init, mpq_add, mpq_sub, mpq_mul, + mpq_div: Change mpz_init* interface. Structure pointer as first + arg to initialization function, no longer *return* struct. + +Sun Jun 30 19:21:44 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * Rename mpz_impl_sqrt.c to mpz_do_sqrt.c to satisfy SysV 14 + character file name length limit. + + * Most files: Rename MINT to MP_INT. Rename MRAT to MP_RAT. + * mpz_sizeinb.c: New file with function mpz_sizeinbase. + * mp_bases.c: New file, with array __mp_bases. + * _mpz_get_str, _mpz_set_str: Remove struct bases, use extern + __mp_bases instead. + * mout, mpz_out_str: Use array __mp_bases instead of function + _mpz_get_cvtlen. + * mpz_get_cvtlen.c: Remove. + * Makefile: Update. + +Sat Jun 29 21:57:28 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * longlong.h (__sparc8__ umul_ppmm): Insert 3 nop:s for wr delay. + * longlong.h (___IBMR2__): Define umul_ppmm, add_ssaaaa, sub_ddmmss. + * longlong.h (__sparc__): Don't call .umul; expand asm instead. + Don't define __umulsidi3 (i.e. use default definition). + +Mon Jun 24 17:37:23 1991 Torbjorn Granlund (tege@amon.sics.se) + + * _mpz_get_str.c (num_to_ascii_lower_case, num_to_ascii_upper_case): + Swap 't' and 's'. + +Sat Jun 22 13:54:01 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * mpz_gcdext.c: New file. + + * mpn_mul: Handle carry and unexpected operand sizes in last + additions/subtractions. (Bug trigged when v1_size == 1.) + + * mp*_alloc*: Rename functions to mp*_init* (files to mp*_iset*.c). + * mpq_*: Call mpz_init*. + + * mpz_pow_ui, rpow: Use _mpn_mul instead of mult. Restructure. + +Wed May 29 20:32:33 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * mpz_get_cvtlen: multiply by size. + +Sun May 26 15:01:15 1991 Torbjorn Granlund (tege@bella.nada.kth.se) + + Alpha-release 0.95. + + Fixes from Doug Lea (dl@g.oswego.edu): + * mpz_mul_ui: Loop to MULT_SIZE (not PROD_SIZE). Adjust PROD_SIZE + correctly. + * mpz_div: Prepend _ to mpz_realloc. + * mpz_set_xs, mpz_set_ds: Fix typos in function name. + +Sat May 25 22:51:16 1991 Torbjorn Granlund (tege@bella.nada.kth.se) + + * mpz_divmod_ui: New function. + + * sdiv: Make the sign of the remainder correct. + +Thu May 23 15:28:24 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * Alpha-release 0.94. + + * mpz_mul_ui: Include longlong.h. + + * mpz_perfsqr.c (mpz_perfect_square_p): Call _mpz_impl_sqrt instead + of msqrt. + + * mpz_impl_sqrt: Don't call "move", inline its functionality. + + * mdiv: Use MPN_COPY instead of memcpy. + * rpow, mpz_mul, mpz_mod_2exp: Likewise. + * pow.c: Likewise, and fix bug in the size arg. + + * xtom: Don't use mpz_alloc, inline needed code instead. Call + _mpz_set_str instead of mpz_set_str. + + * Makefile: Make two libraries, libmp.a and libgmp.a. + +Thu May 22 20:25:29 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * Add manual to distribution. + * Fold in many missing routines described in the manual. + * Update Makefile. + +Wed May 22 13:48:46 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * mpz_set_str: Make it handle 0x prefix OK. + +Sat May 18 18:31:02 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * memory.c (_mp_default_reallocate): Swap OLD_SIZE and NEW_SIZE + arguments. + * mpz_realloc (_mpz_realloc): Swap in call to _mp_reallocate_func. + * min: Likewise. + +Thu May 16 20:43:05 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * memory.c: Make the default allocations functions global. + * mp_set_fns (mp_set_memory_functions): Make a NULL pointer mean the + default memory function. + +Wed May 8 20:02:42 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * mpz_div: Handle DEN the same as QUOT correctly by copying DEN->D + even if no normalization is needed. + * mpz_div: Rework reallocation scheme, to avoid excess copying. + + * mpz_sub_ui.c, mpz_add_ui.c: New files. + + * mpz_cmp.c, mpz_cmp_ui.c: New files. + + * mpz_mul_2exp: Handle zero input MINT correctly. + + * mpn_rshiftci: Don't handle shift counts > BITS_PER_MP_DIGIT. + + * mpz_out_raw.c, mpz_inp_raw.c: New files for raw I/O. + +Tue May 7 15:44:58 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * mpn_rshift: Don't handle shift counts > BITS_PER_MP_DIGIT. + * mpz_div_2exp: Don't call _mpn_rshift with cnt > BITS_PER_MP_DIGIT. + * gcd, mpz_gcd: Likewise. + + * gcd, mpz_gcd: Handle common 2 factors correctly. + +Mon May 6 20:22:59 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * gmp-impl.h (MPN_COPY): Inline a loop instead of calling memcpy. + + * gmp-impl.h, mpz_get_str, rpow: Swap DST and SRC in TMPCOPY* macros. + +Sun May 5 15:16:23 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * mpz_div: Remove test for QUOT == 0. + +Sun Apr 28 20:21:04 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * pow: Don't make MOD normalization in place, as it's a bad idea to + write on an input parameter. + * pow: Reduce BASE if it's > MOD. + * pow, mult, mpz_mul: Simplify realloc code. + +Sat Apr 27 21:03:11 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * Install multiplication using Karatsuba's algorithm as default. + +Fri Apr 26 01:03:57 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * msqrt: Store in ROOT even for U==0, to make msqrt(0) defined. + + * mpz_div_2exp.c, mpz_mul_2exp.c: New files for shifting right and + left, respectively. + * gmp.h: Add definitions for mpz_div_2exp and mpz_mul_2exp. + + * mlshift.c, mrshift.c: Remove. + +Wed Apr 24 21:39:22 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * mpn_mul: Check only for m2_size == 0 in function header. + +Mon Apr 22 01:31:57 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * karatsuba.c: New file for Karatsuba's multiplication algorithm. + + * mpz_random, mpz_init, mpz_mod_2exp: New files and functions. + + * mpn_cmp: Fix header comment. + +Sun Apr 21 00:10:44 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * pow: Switch off initial base reduction. + +Sat Apr 20 22:06:05 1991 Torbjorn Granlund (tege@echnaton.sics.se) + + * mpz_get_str: Don't generate initial zeros for initial word. + Used to write outside of allocated storage. + +Mon Apr 15 15:48:08 1991 Torbjorn Granlund (tege@zevs.sics.se) + + * _mpz_realloc: Make it accept size in number of mp_digits. + * Most functions: Use new _mpz_realloc definition. + + * mpz_set_str: Remove calls _mp_free_func. + + * Most functions: Rename mpn_* to _mpn_*. Rename mpz_realloc to + _mpz_realloc. + * mpn_lshift: Redefine _mpn_lshift to only handle small shifts. + * mdiv, mpz_div, ...: Changes for new definition of _mpn_lshift. + * msqrt, mp*_*shift*: Define cnt as unsigned (for speed). + +Sat Apr 6 14:05:16 1991 Torbjorn Granlund (tege@musta.nada.kth.se) + + * mpn_mul: Multiply by the first digit in M2 in a special + loop instead of zeroing the product area. + + * mpz_abs.c: New file. + + * sdiv: Implement as mpz_div_si for speed. + + * mpn_add: Make it work for second source operand == 0. + + * msub: Negate the correct operand, i.e. V before swapping, not + the smaller of U and V! + * madd, msub: Update abs_* when swapping operands, and not after + (optimization). + +Fri Apr 5 00:19:36 1991 Torbjorn Granlund (tege@black.nada.kth.se) + + * mpn_sub: Make it work for subtrahend == 0. + + * madd, msub: Rewrite to minimize mpn_cmp calls. Ensure + mpn_cmp is called with positive sizes (used to be called + incorrectly with negative sizes sometimes). + + * msqrt: Make it divide by zero if fed with a negative number. + * Remove if statement at end of precision calculation that was + never true. + + * itom, mp.h: The argument is of type short, not int. + + * mpz_realloc, gmp.h: Make mpz_realloc return the new digit pointer. + + * mpz_get_str.c, mpz_set_str.c, mpz_new_str.c: Don't include mp.h. + + * Add COPYING to distribution. + + * mpz_div_ui.c, mpz_div_si.c, mpz_new_ui.c, mpz_new_si.c: New files. + +Fri Mar 15 00:26:29 1991 Torbjorn Granlund (tege@musta.nada.kth.se) + + * Add Copyleft headers to all files. + + * mpn_mul.c, mpn_div.c: Add header comments. + * mult.c, mdiv.c: Update header comments. + + * mpq_add.c, mpq_sub.c, mpq_div.c, mpq_new.c, mpq_new_ui.c, + mpq_free.c: New files for rational arithmetics. + + * mpn_lshift.c: Avoid writing the most significant word if it is 0. + + * mdiv.c: Call mpn_lshift for the normalization. + * mdiv.c: Remove #ifdefs. + + * Makefile: Add ChangeLog to DISTFILES. + + * mpn_div.c: Make the add_back code work (by removing abort()). + * mpn_div.c: Make it return if the quotient is size as compared + with the difference NSIZE - DSIZE. If the stored quotient is + larger than that, return 1, otherwise 0. + * gmp.h: Fix mpn_div declaration. + * mdiv.c: Adopt call to mpn_div. + * mpz_div.c: New file (developed from mdiv.c). + + * README: Update routine names. + +Thu Mar 14 18:45:28 1991 Torbjorn Granlund (tege@musta.nada.kth.se) + + * mpq_mul.c: New file for rational multiplication. + + * gmp.h: Add definitions for rational arithmetics. + + * mpn_div: Kludge the case where the high numerator digit > the + high denominator digit. (This code is going to be optimized later.) + + * New files: gmp.h for GNU specific functions, gmp-common.h for + definitions common for mp.h and gmp.h. + + * Ensure mp.h just defines what BSD mp.h defines. + + * pow.c: Fix typo for bp allocation. + + * Rename natural number functions to mpn_*, integer functions to + mpz_*. + +Tue Mar 5 18:47:04 1991 Torbjorn Granlund (tege@musta.nada.kth.se) + + * mdiv.c (_mp_divide, case 2): Change test for estimate of Q from + "n0 >= r" to "n0 > r". + + * msqrt: Tune the increasing precision scheme, to do fewer steps. + +Tue Mar 3 18:50:10 1991 Torbjorn Granlund (tege@musta.nada.kth.se) + + * msqrt: Use the low level routines. Use low precision in the + beginning, and increase the precision as the result converges. + (This optimization gave a 6-fold speedup.) diff --git a/gmp4/INSTALL b/gmp4/INSTALL new file mode 100644 index 0000000..2099840 --- /dev/null +++ b/gmp4/INSTALL @@ -0,0 +1,370 @@ +Installation Instructions +************************* + +Copyright (C) 1994-1996, 1999-2002, 2004-2013 Free Software Foundation, +Inc. + + Copying and distribution of this file, with or without modification, +are permitted in any medium without royalty provided the copyright +notice and this notice are preserved. This file is offered as-is, +without warranty of any kind. + +Basic Installation +================== + + Briefly, the shell command `./configure && make && make install' +should configure, build, and install this package. The following +more-detailed instructions are generic; see the `README' file for +instructions specific to this package. Some packages provide this +`INSTALL' file but do not implement all of the features documented +below. The lack of an optional feature in a given package is not +necessarily a bug. More recommendations for GNU packages can be found +in *note Makefile Conventions: (standards)Makefile Conventions. + + The `configure' shell script attempts to guess correct values for +various system-dependent variables used during compilation. It uses +those values to create a `Makefile' in each directory of the package. +It may also create one or more `.h' files containing system-dependent +definitions. Finally, it creates a shell script `config.status' that +you can run in the future to recreate the current configuration, and a +file `config.log' containing compiler output (useful mainly for +debugging `configure'). + + It can also use an optional file (typically called `config.cache' +and enabled with `--cache-file=config.cache' or simply `-C') that saves +the results of its tests to speed up reconfiguring. Caching is +disabled by default to prevent problems with accidental use of stale +cache files. + + If you need to do unusual things to compile the package, please try +to figure out how `configure' could check whether to do them, and mail +diffs or instructions to the address given in the `README' so they can +be considered for the next release. If you are using the cache, and at +some point `config.cache' contains results you don't want to keep, you +may remove or edit it. + + The file `configure.ac' (or `configure.in') is used to create +`configure' by a program called `autoconf'. You need `configure.ac' if +you want to change it or regenerate `configure' using a newer version +of `autoconf'. + + The simplest way to compile this package is: + + 1. `cd' to the directory containing the package's source code and type + `./configure' to configure the package for your system. + + Running `configure' might take a while. While running, it prints + some messages telling which features it is checking for. + + 2. Type `make' to compile the package. + + 3. Optionally, type `make check' to run any self-tests that come with + the package, generally using the just-built uninstalled binaries. + + 4. Type `make install' to install the programs and any data files and + documentation. When installing into a prefix owned by root, it is + recommended that the package be configured and built as a regular + user, and only the `make install' phase executed with root + privileges. + + 5. Optionally, type `make installcheck' to repeat any self-tests, but + this time using the binaries in their final installed location. + This target does not install anything. Running this target as a + regular user, particularly if the prior `make install' required + root privileges, verifies that the installation completed + correctly. + + 6. You can remove the program binaries and object files from the + source code directory by typing `make clean'. To also remove the + files that `configure' created (so you can compile the package for + a different kind of computer), type `make distclean'. There is + also a `make maintainer-clean' target, but that is intended mainly + for the package's developers. If you use it, you may have to get + all sorts of other programs in order to regenerate files that came + with the distribution. + + 7. Often, you can also type `make uninstall' to remove the installed + files again. In practice, not all packages have tested that + uninstallation works correctly, even though it is required by the + GNU Coding Standards. + + 8. Some packages, particularly those that use Automake, provide `make + distcheck', which can by used by developers to test that all other + targets like `make install' and `make uninstall' work correctly. + This target is generally not run by end users. + +Compilers and Options +===================== + + Some systems require unusual options for compilation or linking that +the `configure' script does not know about. Run `./configure --help' +for details on some of the pertinent environment variables. + + You can give `configure' initial values for configuration parameters +by setting variables in the command line or in the environment. Here +is an example: + + ./configure CC=c99 CFLAGS=-g LIBS=-lposix + + *Note Defining Variables::, for more details. + +Compiling For Multiple Architectures +==================================== + + You can compile the package for more than one kind of computer at the +same time, by placing the object files for each architecture in their +own directory. To do this, you can use GNU `make'. `cd' to the +directory where you want the object files and executables to go and run +the `configure' script. `configure' automatically checks for the +source code in the directory that `configure' is in and in `..'. This +is known as a "VPATH" build. + + With a non-GNU `make', it is safer to compile the package for one +architecture at a time in the source code directory. After you have +installed the package for one architecture, use `make distclean' before +reconfiguring for another architecture. + + On MacOS X 10.5 and later systems, you can create libraries and +executables that work on multiple system types--known as "fat" or +"universal" binaries--by specifying multiple `-arch' options to the +compiler but only a single `-arch' option to the preprocessor. Like +this: + + ./configure CC="gcc -arch i386 -arch x86_64 -arch ppc -arch ppc64" \ + CXX="g++ -arch i386 -arch x86_64 -arch ppc -arch ppc64" \ + CPP="gcc -E" CXXCPP="g++ -E" + + This is not guaranteed to produce working output in all cases, you +may have to build one architecture at a time and combine the results +using the `lipo' tool if you have problems. + +Installation Names +================== + + By default, `make install' installs the package's commands under +`/usr/local/bin', include files under `/usr/local/include', etc. You +can specify an installation prefix other than `/usr/local' by giving +`configure' the option `--prefix=PREFIX', where PREFIX must be an +absolute file name. + + You can specify separate installation prefixes for +architecture-specific files and architecture-independent files. If you +pass the option `--exec-prefix=PREFIX' to `configure', the package uses +PREFIX as the prefix for installing programs and libraries. +Documentation and other data files still use the regular prefix. + + In addition, if you use an unusual directory layout you can give +options like `--bindir=DIR' to specify different values for particular +kinds of files. Run `configure --help' for a list of the directories +you can set and what kinds of files go in them. In general, the +default for these options is expressed in terms of `${prefix}', so that +specifying just `--prefix' will affect all of the other directory +specifications that were not explicitly provided. + + The most portable way to affect installation locations is to pass the +correct locations to `configure'; however, many packages provide one or +both of the following shortcuts of passing variable assignments to the +`make install' command line to change installation locations without +having to reconfigure or recompile. + + The first method involves providing an override variable for each +affected directory. For example, `make install +prefix=/alternate/directory' will choose an alternate location for all +directory configuration variables that were expressed in terms of +`${prefix}'. Any directories that were specified during `configure', +but not in terms of `${prefix}', must each be overridden at install +time for the entire installation to be relocated. The approach of +makefile variable overrides for each directory variable is required by +the GNU Coding Standards, and ideally causes no recompilation. +However, some platforms have known limitations with the semantics of +shared libraries that end up requiring recompilation when using this +method, particularly noticeable in packages that use GNU Libtool. + + The second method involves providing the `DESTDIR' variable. For +example, `make install DESTDIR=/alternate/directory' will prepend +`/alternate/directory' before all installation names. The approach of +`DESTDIR' overrides is not required by the GNU Coding Standards, and +does not work on platforms that have drive letters. On the other hand, +it does better at avoiding recompilation issues, and works well even +when some directory options were not specified in terms of `${prefix}' +at `configure' time. + +Optional Features +================= + + If the package supports it, you can cause programs to be installed +with an extra prefix or suffix on their names by giving `configure' the +option `--program-prefix=PREFIX' or `--program-suffix=SUFFIX'. + + Some packages pay attention to `--enable-FEATURE' options to +`configure', where FEATURE indicates an optional part of the package. +They may also pay attention to `--with-PACKAGE' options, where PACKAGE +is something like `gnu-as' or `x' (for the X Window System). The +`README' should mention any `--enable-' and `--with-' options that the +package recognizes. + + For packages that use the X Window System, `configure' can usually +find the X include and library files automatically, but if it doesn't, +you can use the `configure' options `--x-includes=DIR' and +`--x-libraries=DIR' to specify their locations. + + Some packages offer the ability to configure how verbose the +execution of `make' will be. For these packages, running `./configure +--enable-silent-rules' sets the default to minimal output, which can be +overridden with `make V=1'; while running `./configure +--disable-silent-rules' sets the default to verbose, which can be +overridden with `make V=0'. + +Particular systems +================== + + On HP-UX, the default C compiler is not ANSI C compatible. If GNU +CC is not installed, it is recommended to use the following options in +order to use an ANSI C compiler: + + ./configure CC="cc -Ae -D_XOPEN_SOURCE=500" + +and if that doesn't work, install pre-built binaries of GCC for HP-UX. + + HP-UX `make' updates targets which have the same time stamps as +their prerequisites, which makes it generally unusable when shipped +generated files such as `configure' are involved. Use GNU `make' +instead. + + On OSF/1 a.k.a. Tru64, some versions of the default C compiler cannot +parse its `' header file. The option `-nodtk' can be used as +a workaround. If GNU CC is not installed, it is therefore recommended +to try + + ./configure CC="cc" + +and if that doesn't work, try + + ./configure CC="cc -nodtk" + + On Solaris, don't put `/usr/ucb' early in your `PATH'. This +directory contains several dysfunctional programs; working variants of +these programs are available in `/usr/bin'. So, if you need `/usr/ucb' +in your `PATH', put it _after_ `/usr/bin'. + + On Haiku, software installed for all users goes in `/boot/common', +not `/usr/local'. It is recommended to use the following options: + + ./configure --prefix=/boot/common + +Specifying the System Type +========================== + + There may be some features `configure' cannot figure out +automatically, but needs to determine by the type of machine the package +will run on. Usually, assuming the package is built to be run on the +_same_ architectures, `configure' can figure that out, but if it prints +a message saying it cannot guess the machine type, give it the +`--build=TYPE' option. TYPE can either be a short name for the system +type, such as `sun4', or a canonical name which has the form: + + CPU-COMPANY-SYSTEM + +where SYSTEM can have one of these forms: + + OS + KERNEL-OS + + See the file `config.sub' for the possible values of each field. If +`config.sub' isn't included in this package, then this package doesn't +need to know the machine type. + + If you are _building_ compiler tools for cross-compiling, you should +use the option `--target=TYPE' to select the type of system they will +produce code for. + + If you want to _use_ a cross compiler, that generates code for a +platform different from the build platform, you should specify the +"host" platform (i.e., that on which the generated programs will +eventually be run) with `--host=TYPE'. + +Sharing Defaults +================ + + If you want to set default values for `configure' scripts to share, +you can create a site shell script called `config.site' that gives +default values for variables like `CC', `cache_file', and `prefix'. +`configure' looks for `PREFIX/share/config.site' if it exists, then +`PREFIX/etc/config.site' if it exists. Or, you can set the +`CONFIG_SITE' environment variable to the location of the site script. +A warning: not all `configure' scripts look for a site script. + +Defining Variables +================== + + Variables not defined in a site shell script can be set in the +environment passed to `configure'. However, some packages may run +configure again during the build, and the customized values of these +variables may be lost. In order to avoid this problem, you should set +them in the `configure' command line, using `VAR=value'. For example: + + ./configure CC=/usr/local2/bin/gcc + +causes the specified `gcc' to be used as the C compiler (unless it is +overridden in the site shell script). + +Unfortunately, this technique does not work for `CONFIG_SHELL' due to +an Autoconf limitation. Until the limitation is lifted, you can use +this workaround: + + CONFIG_SHELL=/bin/bash ./configure CONFIG_SHELL=/bin/bash + +`configure' Invocation +====================== + + `configure' recognizes the following options to control how it +operates. + +`--help' +`-h' + Print a summary of all of the options to `configure', and exit. + +`--help=short' +`--help=recursive' + Print a summary of the options unique to this package's + `configure', and exit. The `short' variant lists options used + only in the top level, while the `recursive' variant lists options + also present in any nested packages. + +`--version' +`-V' + Print the version of Autoconf used to generate the `configure' + script, and exit. + +`--cache-file=FILE' + Enable the cache: use and save the results of the tests in FILE, + traditionally `config.cache'. FILE defaults to `/dev/null' to + disable caching. + +`--config-cache' +`-C' + Alias for `--cache-file=config.cache'. + +`--quiet' +`--silent' +`-q' + Do not print messages saying which checks are being made. To + suppress all normal output, redirect it to `/dev/null' (any error + messages will still be shown). + +`--srcdir=DIR' + Look for the package's source code in directory DIR. Usually + `configure' can determine that directory automatically. + +`--prefix=DIR' + Use DIR as the installation prefix. *note Installation Names:: + for more details, including other options available for fine-tuning + the installation locations. + +`--no-create' +`-n' + Run the configure checks, but stop before creating any output + files. + +`configure' also accepts some other, not widely useful, options. Run +`configure --help' for more details. diff --git a/gmp4/INSTALL.autoconf b/gmp4/INSTALL.autoconf new file mode 100644 index 0000000..0600b32 --- /dev/null +++ b/gmp4/INSTALL.autoconf @@ -0,0 +1,228 @@ +Copyright (C) 1994-1996, 1999-2002 Free Software Foundation, Inc. + + This file is free documentation; the Free Software Foundation gives +unlimited permission to copy, distribute and modify it. + +Basic Installation +================== + + These are generic installation instructions. + + The `configure' shell script attempts to guess correct values for +various system-dependent variables used during compilation. It uses +those values to create a `Makefile' in each directory of the package. +It may also create one or more `.h' files containing system-dependent +definitions. Finally, it creates a shell script `config.status' that +you can run in the future to recreate the current configuration, and a +file `config.log' containing compiler output (useful mainly for +debugging `configure'). + + It can also use an optional file (typically called `config.cache' +and enabled with `--cache-file=config.cache' or simply `-C') that saves +the results of its tests to speed up reconfiguring. (Caching is +disabled by default to prevent problems with accidental use of stale +cache files.) + + If you need to do unusual things to compile the package, please try +to figure out how `configure' could check whether to do them, and mail +diffs or instructions to the address given in the `README' so they can +be considered for the next release. If you are using the cache, and at +some point `config.cache' contains results you don't want to keep, you +may remove or edit it. + + The file `configure.ac' (or `configure.in') is used to create +`configure' by a program called `autoconf'. You only need +`configure.ac' if you want to change it or regenerate `configure' using +a newer version of `autoconf'. + +The simplest way to compile this package is: + + 1. `cd' to the directory containing the package's source code and type + `./configure' to configure the package for your system. If you're + using `csh' on an old version of System V, you might need to type + `sh ./configure' instead to prevent `csh' from trying to execute + `configure' itself. + + Running `configure' takes awhile. While running, it prints some + messages telling which features it is checking for. + + 2. Type `make' to compile the package. + + 3. Optionally, type `make check' to run any self-tests that come with + the package. + + 4. Type `make install' to install the programs and any data files and + documentation. + + 5. You can remove the program binaries and object files from the + source code directory by typing `make clean'. To also remove the + files that `configure' created (so you can compile the package for + a different kind of computer), type `make distclean'. There is + also a `make maintainer-clean' target, but that is intended mainly + for the package's developers. If you use it, you may have to get + all sorts of other programs in order to regenerate files that came + with the distribution. + +Compilers and Options +===================== + + Some systems require unusual options for compilation or linking that +the `configure' script does not know about. Run `./configure --help' +for details on some of the pertinent environment variables. + + You can give `configure' initial values for configuration parameters +by setting variables in the command line or in the environment. Here +is an example: + + ./configure CC=c89 CFLAGS=-O2 LIBS=-lposix + + *Note Defining Variables::, for more details. + +Compiling For Multiple Architectures +==================================== + + You can compile the package for more than one kind of computer at the +same time, by placing the object files for each architecture in their +own directory. To do this, you must use a version of `make' that +supports the `VPATH' variable, such as GNU `make'. `cd' to the +directory where you want the object files and executables to go and run +the `configure' script. `configure' automatically checks for the +source code in the directory that `configure' is in and in `..'. + + If you have to use a `make' that does not support the `VPATH' +variable, you have to compile the package for one architecture at a +time in the source code directory. After you have installed the +package for one architecture, use `make distclean' before reconfiguring +for another architecture. + +Installation Names +================== + + By default, `make install' will install the package's files in +`/usr/local/bin', `/usr/local/man', etc. You can specify an +installation prefix other than `/usr/local' by giving `configure' the +option `--prefix=PATH'. + + You can specify separate installation prefixes for +architecture-specific files and architecture-independent files. If you +give `configure' the option `--exec-prefix=PATH', the package will use +PATH as the prefix for installing programs and libraries. +Documentation and other data files will still use the regular prefix. + + In addition, if you use an unusual directory layout you can give +options like `--bindir=PATH' to specify different values for particular +kinds of files. Run `configure --help' for a list of the directories +you can set and what kinds of files go in them. + + If the package supports it, you can cause programs to be installed +with an extra prefix or suffix on their names by giving `configure' the +option `--program-prefix=PREFIX' or `--program-suffix=SUFFIX'. + +Optional Features +================= + + Some packages pay attention to `--enable-FEATURE' options to +`configure', where FEATURE indicates an optional part of the package. +They may also pay attention to `--with-PACKAGE' options, where PACKAGE +is something like `gnu-as' or `x' (for the X Window System). The +`README' should mention any `--enable-' and `--with-' options that the +package recognizes. + + For packages that use the X Window System, `configure' can usually +find the X include and library files automatically, but if it doesn't, +you can use the `configure' options `--x-includes=DIR' and +`--x-libraries=DIR' to specify their locations. + +Specifying the System Type +========================== + + There may be some features `configure' cannot figure out +automatically, but needs to determine by the type of machine the package +will run on. Usually, assuming the package is built to be run on the +_same_ architectures, `configure' can figure that out, but if it prints +a message saying it cannot guess the machine type, give it the +`--build=TYPE' option. TYPE can either be a short name for the system +type, such as `sun4', or a canonical name which has the form: + + CPU-COMPANY-SYSTEM + +where SYSTEM can have one of these forms: + + OS KERNEL-OS + + See the file `config.sub' for the possible values of each field. If +`config.sub' isn't included in this package, then this package doesn't +need to know the machine type. + + If you are _building_ compiler tools for cross-compiling, you should +use the `--target=TYPE' option to select the type of system they will +produce code for. + + If you want to _use_ a cross compiler, that generates code for a +platform different from the build platform, you should specify the +"host" platform (i.e., that on which the generated programs will +eventually be run) with `--host=TYPE'. + +Sharing Defaults +================ + + If you want to set default values for `configure' scripts to share, +you can create a site shell script called `config.site' that gives +default values for variables like `CC', `cache_file', and `prefix'. +`configure' looks for `PREFIX/share/config.site' if it exists, then +`PREFIX/etc/config.site' if it exists. Or, you can set the +`CONFIG_SITE' environment variable to the location of the site script. +A warning: not all `configure' scripts look for a site script. + +Defining Variables +================== + + Variables not defined in a site shell script can be set in the +environment passed to `configure'. However, some packages may run +configure again during the build, and the customized values of these +variables may be lost. In order to avoid this problem, you should set +them in the `configure' command line, using `VAR=value'. For example: + + ./configure CC=/usr/local2/bin/gcc + +will cause the specified gcc to be used as the C compiler (unless it is +overridden in the site shell script). + +`configure' Invocation +====================== + + `configure' recognizes the following options to control how it +operates. + +`--help' +`-h' + Print a summary of the options to `configure', and exit. + +`--version' +`-V' + Print the version of Autoconf used to generate the `configure' + script, and exit. + +`--cache-file=FILE' + Enable the cache: use and save the results of the tests in FILE, + traditionally `config.cache'. FILE defaults to `/dev/null' to + disable caching. + +`--config-cache' +`-C' + Alias for `--cache-file=config.cache'. + +`--quiet' +`--silent' +`-q' + Do not print messages saying which checks are being made. To + suppress all normal output, redirect it to `/dev/null' (any error + messages will still be shown). + +`--srcdir=DIR' + Look for the package's source code in directory DIR. Usually + `configure' can determine that directory automatically. + +`configure' also accepts some other, not widely useful, options. Run +`configure --help' for more details. + diff --git a/gmp4/Makefile.am b/gmp4/Makefile.am new file mode 100644 index 0000000..8567c0e --- /dev/null +++ b/gmp4/Makefile.am @@ -0,0 +1,445 @@ +## Process this file with automake to generate Makefile.in + + +# Copyright 1991, 1993, 1994, 1996, 1997, 1999-2004, 2006-2009, 2011-2014 Free +# Software Foundation, Inc. +# +# This file is part of the GNU MP Library. +# +# The GNU MP Library is free software; you can redistribute it and/or modify +# it under the terms of either: +# +# * the GNU Lesser General Public License as published by the Free +# Software Foundation; either version 3 of the License, or (at your +# option) any later version. +# +# or +# +# * the GNU General Public License as published by the Free Software +# Foundation; either version 2 of the License, or (at your option) any +# later version. +# +# or both in parallel, as here. +# +# The GNU MP Library is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +# for more details. +# +# You should have received copies of the GNU General Public License and the +# GNU Lesser General Public License along with the GNU MP Library. If not, +# see https://www.gnu.org/licenses/. + + +# The following options are the same as AM_INIT_AUTOMAKE in configure.in, +# except no $(top_builddir) on ansi2knr. That directory is wanted for the +# Makefiles in subdirectories, but here we must omit it so automake gives +# the actual ansi2knr build rule, not "cd $(top_builddir) && make ansi2knr". +# +# AUTOMAKE_OPTIONS = 1.8 gnu no-dependencies + + +# Libtool -version-info for libgmp.la and libmp.la. See "Versioning" in the +# libtool manual. +# +# CURRENT:REVISION:AGE +# +# 1. No interfaces changed, only implementations (good): Increment REVISION. +# +# 2. Interfaces added, none removed (good): Increment CURRENT, increment +# AGE, set REVISION to 0. +# +# 3. Interfaces removed (BAD, breaks upward compatibility): Increment +# CURRENT, set AGE and REVISION to 0. +# +# Do this separately for libgmp, libgmpxx and libmp, and only for releases. +# +# GMP -version-info +# release libgmp libgmpxx libmp +# 2.0.x - - - +# 3.0 3:0:0 - 3:0:0 +# 3.0.1 3:1:0 - 3:0:0 +# 3.1 4:0:1 - 4:0:1 +# 3.1.1 4:1:1 - 4:1:1 +# 4.0 5:0:2 3:0:0 4:2:1 +# 4.0.1 5:1:2 3:1:0 4:3:1 +# 4.1 6:0:3 3:2:0 4:4:1 +# 4.1.1 6:1:3 3:3:0 4:5:1 +# 4.1.2 6:2:3 3:4:0 4:6:1 +# 4.1.3 6:3:3 3:5:0 4:7:1 +# 4.1.4 6:3:3 3:5:0 4:7:1 WRONG, same as 4.1.3! +# 4.2 6:0:3 3:2:0 4:4:1 REALLY WRONG, same as 4.1! +# 4.2.1 7:1:4 4:1:1 4:10:1 WRONG for libgmpxx +# 4.2.2 7:2:4 4:2:0 4:11:1 +# 4.2.3 7:3:4 4:3:0 4:12:1 +# 4.2.4 7:4:4 4:4:0 4:13:1 +# 4.3.0 8:0:5 5:0:1 4:14:1 +# 4.3.1 8:1:5 5:1:1 4:15:1 WRONG Really used same as 4.3.0 +# 4.3.2 8:2:5 5:2:1 4:16:1 +# 5.0.0 9:0:6 6:0:2 4:20:1 Should have been 10:0:0 +# 5.0.1 10:1:0 6:1:2 4:21:1 +# 5.0.2 10:2:0 6:2:2 4:22:1 +# 5.0.3 10:3:0 6:3:2 4:23:1 +# 5.0.4 10:4:0 6:4:2 4:24:1 +# 5.0.5 10:5:0 6:5:2 4:25:1 +# 5.1.0 11:0:1 7:0:3 - +# 5.1.1 11:1:1 7:1:3 - +# 5.1.2 11:2:1 7:2:3 - +# 6.0.0 12:0:2 8:0:4 - +# +# Starting at 3:0:0 is a slight abuse of the versioning system, but it +# ensures we're past soname libgmp.so.2, which was used on Debian GNU/Linux +# packages of gmp 2. Pretend gmp 2 was 2:0:0, so the interface changes for +# gmp 3 mean 3:0:0 is right. +# +# We interpret "implementation changed" in item "1." above as meaning any +# release, ie. the REVISION is incremented every time (if nothing else). +# Even if we thought the code generated will be identical on all systems, +# it's still good to get the shared library filename (like +# libgmpxx.so.3.0.4) incrementing, to make it clear which GMP it's from. + +LIBGMP_LT_CURRENT = 12 +LIBGMP_LT_REVISION = 0 +LIBGMP_LT_AGE = 2 + +LIBGMPXX_LT_CURRENT = 8 +LIBGMPXX_LT_REVISION = 0 +LIBGMPXX_LT_AGE = 4 + + +SUBDIRS = tests mpn mpz mpq mpf printf scanf rand cxx demos tune doc + +EXTRA_DIST = configfsf.guess configfsf.sub .gdbinit INSTALL.autoconf \ + COPYING.LESSERv3 COPYINGv2 COPYINGv3 + + +if WANT_CXX +GMPXX_HEADERS_OPTION = gmpxx.h +endif +EXTRA_DIST += gmpxx.h + +# gmp.h and mp.h are architecture dependent, mainly since they encode the +# limb size used in libgmp. For that reason they belong under $exec_prefix +# not $prefix, strictly speaking. +# +# $exec_prefix/include is not in the default include path for gcc built to +# the same $prefix and $exec_prefix, which might mean gmp.h is not found, +# but anyone knowledgeable enough to be playing with exec_prefix will be able +# to address that. +# +includeexecdir = $(exec_prefix)/include +include_HEADERS = $(GMPXX_HEADERS_OPTION) +nodist_includeexec_HEADERS = gmp.h +lib_LTLIBRARIES = libgmp.la $(GMPXX_LTLIBRARIES_OPTION) + +BUILT_SOURCES = gmp.h + +DISTCLEANFILES = $(BUILT_SOURCES) config.m4 @gmp_srclinks@ + +# Tell gmp.h it's building gmp, not an application, used by windows DLL stuff. +INCLUDES=-D__GMP_WITHIN_GMP + + +MPF_OBJECTS = mpf/init$U.lo mpf/init2$U.lo mpf/inits$U.lo mpf/set$U.lo \ + mpf/set_ui$U.lo mpf/set_si$U.lo mpf/set_str$U.lo mpf/set_d$U.lo \ + mpf/set_z$U.lo mpf/iset$U.lo mpf/iset_ui$U.lo mpf/iset_si$U.lo \ + mpf/iset_str$U.lo mpf/iset_d$U.lo mpf/clear$U.lo mpf/clears$U.lo \ + mpf/get_str$U.lo mpf/dump$U.lo mpf/size$U.lo mpf/eq$U.lo mpf/reldiff$U.lo \ + mpf/sqrt$U.lo mpf/random2$U.lo mpf/inp_str$U.lo mpf/out_str$U.lo \ + mpf/add$U.lo mpf/add_ui$U.lo mpf/sub$U.lo mpf/sub_ui$U.lo mpf/ui_sub$U.lo \ + mpf/mul$U.lo mpf/mul_ui$U.lo mpf/div$U.lo mpf/div_ui$U.lo \ + mpf/cmp$U.lo mpf/cmp_d$U.lo mpf/cmp_ui$U.lo mpf/cmp_si$U.lo \ + mpf/mul_2exp$U.lo mpf/div_2exp$U.lo mpf/abs$U.lo mpf/neg$U.lo \ + mpf/set_q$U.lo mpf/get_d$U.lo mpf/get_d_2exp$U.lo mpf/set_dfl_prec$U.lo \ + mpf/set_prc$U.lo mpf/set_prc_raw$U.lo mpf/get_dfl_prec$U.lo \ + mpf/get_prc$U.lo mpf/ui_div$U.lo mpf/sqrt_ui$U.lo \ + mpf/ceilfloor$U.lo mpf/trunc$U.lo mpf/pow_ui$U.lo \ + mpf/urandomb$U.lo mpf/swap$U.lo \ + mpf/fits_sint$U.lo mpf/fits_slong$U.lo mpf/fits_sshort$U.lo \ + mpf/fits_uint$U.lo mpf/fits_ulong$U.lo mpf/fits_ushort$U.lo \ + mpf/get_si$U.lo mpf/get_ui$U.lo \ + mpf/int_p$U.lo + +MPZ_OBJECTS = mpz/abs$U.lo mpz/add$U.lo mpz/add_ui$U.lo \ + mpz/aorsmul$U.lo mpz/aorsmul_i$U.lo mpz/and$U.lo mpz/array_init$U.lo \ + mpz/bin_ui$U.lo mpz/bin_uiui$U.lo \ + mpz/cdiv_q$U.lo mpz/cdiv_q_ui$U.lo \ + mpz/cdiv_qr$U.lo mpz/cdiv_qr_ui$U.lo \ + mpz/cdiv_r$U.lo mpz/cdiv_r_ui$U.lo mpz/cdiv_ui$U.lo \ + mpz/cfdiv_q_2exp$U.lo mpz/cfdiv_r_2exp$U.lo \ + mpz/clear$U.lo mpz/clears$U.lo mpz/clrbit$U.lo \ + mpz/cmp$U.lo mpz/cmp_d$U.lo mpz/cmp_si$U.lo mpz/cmp_ui$U.lo \ + mpz/cmpabs$U.lo mpz/cmpabs_d$U.lo mpz/cmpabs_ui$U.lo \ + mpz/com$U.lo mpz/combit$U.lo \ + mpz/cong$U.lo mpz/cong_2exp$U.lo mpz/cong_ui$U.lo \ + mpz/divexact$U.lo mpz/divegcd$U.lo mpz/dive_ui$U.lo \ + mpz/divis$U.lo mpz/divis_ui$U.lo mpz/divis_2exp$U.lo mpz/dump$U.lo \ + mpz/export$U.lo mpz/mfac_uiui$U.lo \ + mpz/2fac_ui$U.lo mpz/fac_ui$U.lo mpz/oddfac_1$U.lo mpz/prodlimbs$U.lo \ + mpz/fdiv_q_ui$U.lo mpz/fdiv_qr$U.lo mpz/fdiv_qr_ui$U.lo \ + mpz/fdiv_r$U.lo mpz/fdiv_r_ui$U.lo mpz/fdiv_q$U.lo \ + mpz/fdiv_ui$U.lo mpz/fib_ui$U.lo mpz/fib2_ui$U.lo mpz/fits_sint$U.lo \ + mpz/fits_slong$U.lo mpz/fits_sshort$U.lo mpz/fits_uint$U.lo \ + mpz/fits_ulong$U.lo mpz/fits_ushort$U.lo mpz/gcd$U.lo \ + mpz/gcd_ui$U.lo mpz/gcdext$U.lo mpz/get_d$U.lo mpz/get_d_2exp$U.lo \ + mpz/get_si$U.lo mpz/get_str$U.lo mpz/get_ui$U.lo mpz/getlimbn$U.lo \ + mpz/hamdist$U.lo \ + mpz/import$U.lo mpz/init$U.lo mpz/init2$U.lo mpz/inits$U.lo \ + mpz/inp_raw$U.lo mpz/inp_str$U.lo mpz/invert$U.lo \ + mpz/ior$U.lo mpz/iset$U.lo mpz/iset_d$U.lo mpz/iset_si$U.lo \ + mpz/iset_str$U.lo mpz/iset_ui$U.lo mpz/jacobi$U.lo mpz/kronsz$U.lo \ + mpz/kronuz$U.lo mpz/kronzs$U.lo mpz/kronzu$U.lo \ + mpz/lcm$U.lo mpz/lcm_ui$U.lo mpz/limbs_finish$U.lo \ + mpz/limbs_modify$U.lo mpz/limbs_read$U.lo mpz/limbs_write$U.lo \ + mpz/lucnum_ui$U.lo mpz/lucnum2_ui$U.lo \ + mpz/millerrabin$U.lo mpz/mod$U.lo mpz/mul$U.lo mpz/mul_2exp$U.lo \ + mpz/mul_si$U.lo mpz/mul_ui$U.lo \ + mpz/n_pow_ui$U.lo mpz/neg$U.lo mpz/nextprime$U.lo \ + mpz/out_raw$U.lo mpz/out_str$U.lo mpz/perfpow$U.lo mpz/perfsqr$U.lo \ + mpz/popcount$U.lo mpz/pow_ui$U.lo mpz/powm$U.lo mpz/powm_sec$U.lo \ + mpz/powm_ui$U.lo mpz/primorial_ui$U.lo \ + mpz/pprime_p$U.lo mpz/random$U.lo mpz/random2$U.lo \ + mpz/realloc$U.lo mpz/realloc2$U.lo mpz/remove$U.lo mpz/roinit_n$U.lo \ + mpz/root$U.lo mpz/rootrem$U.lo mpz/rrandomb$U.lo mpz/scan0$U.lo \ + mpz/scan1$U.lo mpz/set$U.lo mpz/set_d$U.lo mpz/set_f$U.lo \ + mpz/set_q$U.lo mpz/set_si$U.lo mpz/set_str$U.lo mpz/set_ui$U.lo \ + mpz/setbit$U.lo \ + mpz/size$U.lo mpz/sizeinbase$U.lo mpz/sqrt$U.lo \ + mpz/sqrtrem$U.lo mpz/sub$U.lo mpz/sub_ui$U.lo mpz/swap$U.lo \ + mpz/tdiv_ui$U.lo mpz/tdiv_q$U.lo mpz/tdiv_q_2exp$U.lo \ + mpz/tdiv_q_ui$U.lo mpz/tdiv_qr$U.lo mpz/tdiv_qr_ui$U.lo \ + mpz/tdiv_r$U.lo mpz/tdiv_r_2exp$U.lo mpz/tdiv_r_ui$U.lo \ + mpz/tstbit$U.lo mpz/ui_pow_ui$U.lo mpz/ui_sub$U.lo mpz/urandomb$U.lo \ + mpz/urandomm$U.lo mpz/xor$U.lo + +MPQ_OBJECTS = mpq/abs$U.lo mpq/aors$U.lo \ + mpq/canonicalize$U.lo mpq/clear$U.lo mpq/clears$U.lo \ + mpq/cmp$U.lo mpq/cmp_si$U.lo mpq/cmp_ui$U.lo mpq/div$U.lo \ + mpq/get_d$U.lo mpq/get_den$U.lo mpq/get_num$U.lo mpq/get_str$U.lo \ + mpq/init$U.lo mpq/inits$U.lo mpq/inp_str$U.lo mpq/inv$U.lo \ + mpq/md_2exp$U.lo mpq/mul$U.lo mpq/neg$U.lo mpq/out_str$U.lo \ + mpq/set$U.lo mpq/set_den$U.lo mpq/set_num$U.lo \ + mpq/set_si$U.lo mpq/set_str$U.lo mpq/set_ui$U.lo \ + mpq/equal$U.lo mpq/set_z$U.lo mpq/set_d$U.lo \ + mpq/set_f$U.lo mpq/swap$U.lo + +MPN_OBJECTS = mpn/fib_table$U.lo mpn/mp_bases$U.lo + +PRINTF_OBJECTS = \ + printf/asprintf$U.lo printf/asprntffuns$U.lo \ + printf/doprnt$U.lo printf/doprntf$U.lo printf/doprnti$U.lo \ + printf/fprintf$U.lo \ + printf/obprintf$U.lo printf/obvprintf$U.lo printf/obprntffuns$U.lo \ + printf/printf$U.lo printf/printffuns$U.lo \ + printf/snprintf$U.lo printf/snprntffuns$U.lo \ + printf/sprintf$U.lo printf/sprintffuns$U.lo \ + printf/vasprintf$U.lo printf/vfprintf$U.lo printf/vprintf$U.lo \ + printf/vsnprintf$U.lo printf/vsprintf$U.lo \ + printf/repl-vsnprintf$U.lo + +SCANF_OBJECTS = \ + scanf/doscan$U.lo scanf/fscanf$U.lo scanf/fscanffuns$U.lo \ + scanf/scanf$U.lo scanf/sscanf$U.lo scanf/sscanffuns$U.lo \ + scanf/vfscanf$U.lo scanf/vscanf$U.lo scanf/vsscanf$U.lo + +RANDOM_OBJECTS = \ + rand/rand$U.lo rand/randclr$U.lo rand/randdef$U.lo rand/randiset$U.lo \ + rand/randlc2s$U.lo rand/randlc2x$U.lo rand/randmt$U.lo \ + rand/randmts$U.lo rand/rands$U.lo rand/randsd$U.lo rand/randsdui$U.lo \ + rand/randbui$U.lo rand/randmui$U.lo + +# no $U for C++ files +CXX_OBJECTS = \ + cxx/isfuns.lo cxx/ismpf.lo cxx/ismpq.lo cxx/ismpz.lo cxx/ismpznw.lo \ + cxx/limits.lo cxx/osdoprnti.lo cxx/osfuns.lo \ + cxx/osmpf.lo cxx/osmpq.lo cxx/osmpz.lo + +# In libtool 1.5 it doesn't work to build libgmp.la from the convenience +# libraries like mpz/libmpz.la. Or rather it works, but it ends up putting +# PIC objects into libgmp.a if shared and static are both built. (The PIC +# objects go into mpz/.libs/libmpz.a, and thence into .libs/libgmp.a.) +# +# For now the big lists of objects above are used. Something like mpz/*.lo +# would probably work, but might risk missing something out or getting +# something extra. The source files for each .lo are listed in the +# Makefile.am's in the subdirectories. +# +# Currently, for libgmp, unlike libmp below, we're not using +# -export-symbols, since the tune and speed programs, and perhaps some of +# the test programs, want to access undocumented symbols. + +libgmp_la_SOURCES = gmp-impl.h longlong.h \ + assert.c compat.c errno.c extract-dbl.c invalid.c memory.c \ + mp_bpl.c mp_clz_tab.c mp_dv_tab.c mp_minv_tab.c mp_get_fns.c mp_set_fns.c \ + version.c nextprime.c primesieve.c +EXTRA_libgmp_la_SOURCES = tal-debug.c tal-notreent.c tal-reent.c +libgmp_la_DEPENDENCIES = @TAL_OBJECT@ \ + $(MPF_OBJECTS) $(MPZ_OBJECTS) $(MPQ_OBJECTS) \ + $(MPN_OBJECTS) @mpn_objs_in_libgmp@ \ + $(PRINTF_OBJECTS) $(SCANF_OBJECTS) $(RANDOM_OBJECTS) +libgmp_la_LIBADD = $(libgmp_la_DEPENDENCIES) +libgmp_la_LDFLAGS = $(GMP_LDFLAGS) $(LIBGMP_LDFLAGS) \ + -version-info $(LIBGMP_LT_CURRENT):$(LIBGMP_LT_REVISION):$(LIBGMP_LT_AGE) + + +# We need at least one .cc file in $(libgmpxx_la_SOURCES) so automake will +# use $(CXXLINK) rather than the plain C $(LINK). cxx/dummy.cc is that +# file. + +if WANT_CXX +GMPXX_LTLIBRARIES_OPTION = libgmpxx.la +endif +libgmpxx_la_SOURCES = cxx/dummy.cc +libgmpxx_la_DEPENDENCIES = $(CXX_OBJECTS) libgmp.la +libgmpxx_la_LIBADD = $(libgmpxx_la_DEPENDENCIES) +libgmpxx_la_LDFLAGS = $(GMP_LDFLAGS) $(LIBGMPXX_LDFLAGS) \ + -version-info $(LIBGMPXX_LT_CURRENT):$(LIBGMPXX_LT_REVISION):$(LIBGMPXX_LT_AGE) + + + +install-data-hook: + @echo '' + @echo '+-------------------------------------------------------------+' + @echo '| CAUTION: |' + @echo '| |' + @echo '| If you have not already run "make check", then we strongly |' + @echo '| recommend you do so. |' + @echo '| |' + @echo '| GMP has been carefully tested by its authors, but compilers |' + @echo '| are all too often released with serious bugs. GMP tends to |' + @echo '| explore interesting corners in compilers and has hit bugs |' + @echo '| on quite a few occasions. |' + @echo '| |' + @echo '+-------------------------------------------------------------+' + @echo '' + + +# The "test -f" support for srcdir!=builddir is similar to the automake .c.o +# etc rules, but with each foo.c explicitly, since $< is not portable +# outside an inference rule. +# +# A quoted 'foo.c' is used with the "test -f"'s to avoid Sun make rewriting +# it as part of its VPATH support. See the autoconf manual "Limitations of +# Make". +# +# Generated .h files which are used by gmp-impl.h are BUILT_SOURCES since +# they must exist before anything can be compiled. +# +# Other generated .h files are also BUILT_SOURCES so as to get all the +# build-system stuff over and done with at the start. Also, dependencies on +# the .h files are not properly expressed for the various objects that use +# them. + +EXTRA_DIST += bootstrap.c + +fac_table.h: gen-fac$(EXEEXT_FOR_BUILD) + ./gen-fac $(GMP_LIMB_BITS) $(GMP_NAIL_BITS) >fac_table.h || (rm -f fac_table.h; exit 1) +BUILT_SOURCES += fac_table.h + +gen-fac$(EXEEXT_FOR_BUILD): gen-fac$(U_FOR_BUILD).c bootstrap.c + $(CC_FOR_BUILD) `test -f 'gen-fac$(U_FOR_BUILD).c' || echo '$(srcdir)/'`gen-fac$(U_FOR_BUILD).c -o gen-fac$(EXEEXT_FOR_BUILD) +DISTCLEANFILES += gen-fac$(EXEEXT_FOR_BUILD) +EXTRA_DIST += gen-fac.c + + +fib_table.h: gen-fib$(EXEEXT_FOR_BUILD) + ./gen-fib header $(GMP_LIMB_BITS) $(GMP_NAIL_BITS) >fib_table.h || (rm -f fib_table.h; exit 1) +BUILT_SOURCES += fib_table.h + +mpn/fib_table.c: gen-fib$(EXEEXT_FOR_BUILD) + ./gen-fib table $(GMP_LIMB_BITS) $(GMP_NAIL_BITS) >mpn/fib_table.c || (rm -f mpn/fib_table.c; exit 1) +BUILT_SOURCES += mpn/fib_table.c + +gen-fib$(EXEEXT_FOR_BUILD): gen-fib$(U_FOR_BUILD).c bootstrap.c + $(CC_FOR_BUILD) `test -f 'gen-fib$(U_FOR_BUILD).c' || echo '$(srcdir)/'`gen-fib$(U_FOR_BUILD).c -o gen-fib$(EXEEXT_FOR_BUILD) +DISTCLEANFILES += gen-fib$(EXEEXT_FOR_BUILD) +EXTRA_DIST += gen-fib.c + + +mp_bases.h: gen-bases$(EXEEXT_FOR_BUILD) + ./gen-bases header $(GMP_LIMB_BITS) $(GMP_NAIL_BITS) >mp_bases.h || (rm -f mp_bases.h; exit 1) +BUILT_SOURCES += mp_bases.h + +mpn/mp_bases.c: gen-bases$(EXEEXT_FOR_BUILD) + ./gen-bases table $(GMP_LIMB_BITS) $(GMP_NAIL_BITS) >mpn/mp_bases.c || (rm -f mpn/mp_bases.c; exit 1) +BUILT_SOURCES += mpn/mp_bases.c + +gen-bases$(EXEEXT_FOR_BUILD): gen-bases$(U_FOR_BUILD).c bootstrap.c + $(CC_FOR_BUILD) `test -f 'gen-bases$(U_FOR_BUILD).c' || echo '$(srcdir)/'`gen-bases$(U_FOR_BUILD).c -o gen-bases$(EXEEXT_FOR_BUILD) $(LIBM_FOR_BUILD) +DISTCLEANFILES += gen-bases$(EXEEXT_FOR_BUILD) +EXTRA_DIST += gen-bases.c + + +trialdivtab.h: gen-trialdivtab$(EXEEXT_FOR_BUILD) + ./gen-trialdivtab $(GMP_LIMB_BITS) 8000 >trialdivtab.h || (rm -f trialdivtab.h; exit 1) +BUILT_SOURCES += trialdivtab.h + +gen-trialdivtab$(EXEEXT_FOR_BUILD): gen-trialdivtab$(U_FOR_BUILD).c bootstrap.c + $(CC_FOR_BUILD) `test -f 'gen-trialdivtab$(U_FOR_BUILD).c' || echo '$(srcdir)/'`gen-trialdivtab$(U_FOR_BUILD).c -o gen-trialdivtab$(EXEEXT_FOR_BUILD) $(LIBM_FOR_BUILD) +DISTCLEANFILES += gen-trialdivtab$(EXEEXT_FOR_BUILD) +EXTRA_DIST += gen-trialdivtab.c + + +mpn/jacobitab.h: gen-jacobitab$(EXEEXT_FOR_BUILD) + ./gen-jacobitab >mpn/jacobitab.h || (rm -f mpn/jacobitab.h; exit 1) +BUILT_SOURCES += mpn/jacobitab.h + +gen-jacobitab$(EXEEXT_FOR_BUILD): gen-jacobitab$(U_FOR_BUILD).c + $(CC_FOR_BUILD) `test -f 'gen-jacobitab$(U_FOR_BUILD).c' || echo '$(srcdir)/'`gen-jacobitab$(U_FOR_BUILD).c -o gen-jacobitab$(EXEEXT_FOR_BUILD) +DISTCLEANFILES += gen-jacobitab$(EXEEXT_FOR_BUILD) +EXTRA_DIST += gen-jacobitab.c + + +mpn/perfsqr.h: gen-psqr$(EXEEXT_FOR_BUILD) + ./gen-psqr $(GMP_LIMB_BITS) $(GMP_NAIL_BITS) >mpn/perfsqr.h || (rm -f mpn/perfsqr.h; exit 1) +BUILT_SOURCES += mpn/perfsqr.h + +gen-psqr$(EXEEXT_FOR_BUILD): gen-psqr$(U_FOR_BUILD).c bootstrap.c + $(CC_FOR_BUILD) `test -f 'gen-psqr$(U_FOR_BUILD).c' || echo '$(srcdir)/'`gen-psqr$(U_FOR_BUILD).c -o gen-psqr$(EXEEXT_FOR_BUILD) $(LIBM_FOR_BUILD) +DISTCLEANFILES += gen-psqr$(EXEEXT_FOR_BUILD) +EXTRA_DIST += gen-psqr.c + +# Distribute mini-gmp. Test sources copied by dist-hook. +EXTRA_DIST += mini-gmp/README mini-gmp/mini-gmp.c mini-gmp/mini-gmp.h \ + mini-gmp/tests/Makefile mini-gmp/tests/run-tests + +# Avoid: CVS - cvs directories +# *~ - emacs backups +# .#* - cvs merge originals +# +# *~ and .#* only occur when a whole directory without it's own Makefile.am +# is distributed, like "doc" or the mpn cpu subdirectories. +# +dist-hook: + -find $(distdir) \( -name CVS -type d \) -o -name "*~" -o -name ".#*" \ + | xargs rm -rf + cp "$(srcdir)"/mini-gmp/tests/*.[ch] "$(distdir)/mini-gmp/tests" +# grep -F $(VERSION) $(srcdir)/Makefile.am \ +# | grep -q "^# *$(VERSION) *$(LIBGMP_LT_CURRENT):$(LIBGMP_LT_REVISION):$(LIBGMP_LT_AGE) *$(LIBGMPXX_LT_CURRENT):$(LIBGMPXX_LT_REVISION):$(LIBGMPXX_LT_AGE)" +# test -z "`sed -n 's/^# *[0-9]*\.[0-9]*\.[0-9]* *\([0-9]*:[0-9]*:[0-9]*\) *\([0-9]*:[0-9]*:[0-9]*\) *\([0-9]*:[0-9]*:[0-9]*\).*/A\1\nB\2\nC\3/p' $(srcdir)/Makefile.am | grep -v 'A6:3:3\|B3:5:0\|C4:7:1' | sort | uniq -d`" + +.PHONY: check-mini-gmp clean-mini-gmp + +check-mini-gmp: + abs_srcdir="`cd $(srcdir) && pwd`" ; \ + $(MKDIR_P) mini-gmp/tests \ + && cd mini-gmp/tests \ + && LD_LIBRARY_PATH="../../.libs:$$LD_LIBRARY_PATH" \ + DYLD_LIBRARY_PATH="../../.libs:$$DYLD_LIBRARY_PATH" \ + $(MAKE) -f "$$abs_srcdir/mini-gmp/tests/Makefile" \ + VPATH="$$abs_srcdir/mini-gmp/tests" \ + srcdir="$$abs_srcdir/mini-gmp/tests" \ + MINI_GMP_DIR="$$abs_srcdir/mini-gmp" \ + LDFLAGS="-L../../.libs" \ + LIBS="-lgmp -lm" \ + CC="$(CC_FOR_BUILD)" EXTRA_CFLAGS="-g -I../.." check + +clean-mini-gmp: + if [ -d mini-gmp/tests ] ; then \ + abs_srcdir="`cd $(srcdir) && pwd`" ; \ + cd mini-gmp/tests \ + && $(MAKE) -f "$$abs_srcdir/mini-gmp/tests/Makefile" clean ; \ + fi + +clean-local: clean-mini-gmp +distclean-local: clean-mini-gmp diff --git a/gmp4/Makefile.in b/gmp4/Makefile.in new file mode 100644 index 0000000..001ae3b --- /dev/null +++ b/gmp4/Makefile.in @@ -0,0 +1,1476 @@ +# Makefile.in generated by automake 1.14.1 from Makefile.am. +# @configure_input@ + +# Copyright (C) 1994-2013 Free Software Foundation, Inc. + +# This Makefile.in is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY, to the extent permitted by law; without +# even the implied warranty of MERCHANTABILITY or FITNESS FOR A +# PARTICULAR PURPOSE. + +@SET_MAKE@ + +# Copyright 1991, 1993, 1994, 1996, 1997, 1999-2004, 2006-2009, 2011-2014 Free +# Software Foundation, Inc. +# +# This file is part of the GNU MP Library. +# +# The GNU MP Library is free software; you can redistribute it and/or modify +# it under the terms of either: +# +# * the GNU Lesser General Public License as published by the Free +# Software Foundation; either version 3 of the License, or (at your +# option) any later version. +# +# or +# +# * the GNU General Public License as published by the Free Software +# Foundation; either version 2 of the License, or (at your option) any +# later version. +# +# or both in parallel, as here. +# +# The GNU MP Library is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +# for more details. +# +# You should have received copies of the GNU General Public License and the +# GNU Lesser General Public License along with the GNU MP Library. If not, +# see https://www.gnu.org/licenses/. + +# The following options are the same as AM_INIT_AUTOMAKE in configure.in, +# except no $(top_builddir) on ansi2knr. That directory is wanted for the +# Makefiles in subdirectories, but here we must omit it so automake gives +# the actual ansi2knr build rule, not "cd $(top_builddir) && make ansi2knr". +# +# AUTOMAKE_OPTIONS = 1.8 gnu no-dependencies + +# Libtool -version-info for libgmp.la and libmp.la. See "Versioning" in the +# libtool manual. +# +# CURRENT:REVISION:AGE +# +# 1. No interfaces changed, only implementations (good): Increment REVISION. +# +# 2. Interfaces added, none removed (good): Increment CURRENT, increment +# AGE, set REVISION to 0. +# +# 3. Interfaces removed (BAD, breaks upward compatibility): Increment +# CURRENT, set AGE and REVISION to 0. +# +# Do this separately for libgmp, libgmpxx and libmp, and only for releases. +# +# GMP -version-info +# release libgmp libgmpxx libmp +# 2.0.x - - - +# 3.0 3:0:0 - 3:0:0 +# 3.0.1 3:1:0 - 3:0:0 +# 3.1 4:0:1 - 4:0:1 +# 3.1.1 4:1:1 - 4:1:1 +# 4.0 5:0:2 3:0:0 4:2:1 +# 4.0.1 5:1:2 3:1:0 4:3:1 +# 4.1 6:0:3 3:2:0 4:4:1 +# 4.1.1 6:1:3 3:3:0 4:5:1 +# 4.1.2 6:2:3 3:4:0 4:6:1 +# 4.1.3 6:3:3 3:5:0 4:7:1 +# 4.1.4 6:3:3 3:5:0 4:7:1 WRONG, same as 4.1.3! +# 4.2 6:0:3 3:2:0 4:4:1 REALLY WRONG, same as 4.1! +# 4.2.1 7:1:4 4:1:1 4:10:1 WRONG for libgmpxx +# 4.2.2 7:2:4 4:2:0 4:11:1 +# 4.2.3 7:3:4 4:3:0 4:12:1 +# 4.2.4 7:4:4 4:4:0 4:13:1 +# 4.3.0 8:0:5 5:0:1 4:14:1 +# 4.3.1 8:1:5 5:1:1 4:15:1 WRONG Really used same as 4.3.0 +# 4.3.2 8:2:5 5:2:1 4:16:1 +# 5.0.0 9:0:6 6:0:2 4:20:1 Should have been 10:0:0 +# 5.0.1 10:1:0 6:1:2 4:21:1 +# 5.0.2 10:2:0 6:2:2 4:22:1 +# 5.0.3 10:3:0 6:3:2 4:23:1 +# 5.0.4 10:4:0 6:4:2 4:24:1 +# 5.0.5 10:5:0 6:5:2 4:25:1 +# 5.1.0 11:0:1 7:0:3 - +# 5.1.1 11:1:1 7:1:3 - +# 5.1.2 11:2:1 7:2:3 - +# 6.0.0 12:0:2 8:0:4 - +# +# Starting at 3:0:0 is a slight abuse of the versioning system, but it +# ensures we're past soname libgmp.so.2, which was used on Debian GNU/Linux +# packages of gmp 2. Pretend gmp 2 was 2:0:0, so the interface changes for +# gmp 3 mean 3:0:0 is right. +# +# We interpret "implementation changed" in item "1." above as meaning any +# release, ie. the REVISION is incremented every time (if nothing else). +# Even if we thought the code generated will be identical on all systems, +# it's still good to get the shared library filename (like +# libgmpxx.so.3.0.4) incrementing, to make it clear which GMP it's from. + + +VPATH = @srcdir@ +am__is_gnu_make = test -n '$(MAKEFILE_LIST)' && test -n '$(MAKELEVEL)' +am__make_running_with_option = \ + case $${target_option-} in \ + ?) ;; \ + *) echo "am__make_running_with_option: internal error: invalid" \ + "target option '$${target_option-}' specified" >&2; \ + exit 1;; \ + esac; \ + has_opt=no; \ + sane_makeflags=$$MAKEFLAGS; \ + if $(am__is_gnu_make); then \ + sane_makeflags=$$MFLAGS; \ + else \ + case $$MAKEFLAGS in \ + *\\[\ \ ]*) \ + bs=\\; \ + sane_makeflags=`printf '%s\n' "$$MAKEFLAGS" \ + | sed "s/$$bs$$bs[$$bs $$bs ]*//g"`;; \ + esac; \ + fi; \ + skip_next=no; \ + strip_trailopt () \ + { \ + flg=`printf '%s\n' "$$flg" | sed "s/$$1.*$$//"`; \ + }; \ + for flg in $$sane_makeflags; do \ + test $$skip_next = yes && { skip_next=no; continue; }; \ + case $$flg in \ + *=*|--*) continue;; \ + -*I) strip_trailopt 'I'; skip_next=yes;; \ + -*I?*) strip_trailopt 'I';; \ + -*O) strip_trailopt 'O'; skip_next=yes;; \ + -*O?*) strip_trailopt 'O';; \ + -*l) strip_trailopt 'l'; skip_next=yes;; \ + -*l?*) strip_trailopt 'l';; \ + -[dEDm]) skip_next=yes;; \ + -[JT]) skip_next=yes;; \ + esac; \ + case $$flg in \ + *$$target_option*) has_opt=yes; break;; \ + esac; \ + done; \ + test $$has_opt = yes +am__make_dryrun = (target_option=n; $(am__make_running_with_option)) +am__make_keepgoing = (target_option=k; $(am__make_running_with_option)) +pkgdatadir = $(datadir)/@PACKAGE@ +pkgincludedir = $(includedir)/@PACKAGE@ +pkglibdir = $(libdir)/@PACKAGE@ +pkglibexecdir = $(libexecdir)/@PACKAGE@ +am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd +install_sh_DATA = $(install_sh) -c -m 644 +install_sh_PROGRAM = $(install_sh) -c +install_sh_SCRIPT = $(install_sh) -c +INSTALL_HEADER = $(INSTALL_DATA) +transform = $(program_transform_name) +NORMAL_INSTALL = : +PRE_INSTALL = : +POST_INSTALL = : +NORMAL_UNINSTALL = : +PRE_UNINSTALL = : +POST_UNINSTALL = : +build_triplet = @build@ +host_triplet = @host@ +subdir = . +DIST_COMMON = INSTALL NEWS README AUTHORS ChangeLog \ + $(srcdir)/Makefile.in $(srcdir)/Makefile.am \ + $(top_srcdir)/configure $(am__configure_deps) \ + $(srcdir)/config.in $(srcdir)/gmp-h.in \ + $(am__include_HEADERS_DIST) COPYING compile config.guess \ + config.sub install-sh missing ylwrap ltmain.sh +ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 +am__aclocal_m4_deps = $(top_srcdir)/acinclude.m4 \ + $(top_srcdir)/configure.ac +am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ + $(ACLOCAL_M4) +am__CONFIG_DISTCLEAN_FILES = config.status config.cache config.log \ + configure.lineno config.status.lineno +mkinstalldirs = $(install_sh) -d +CONFIG_HEADER = config.h +CONFIG_CLEAN_FILES = gmp.h gmp-mparam.h +CONFIG_CLEAN_VPATH_FILES = +am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`; +am__vpath_adj = case $$p in \ + $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \ + *) f=$$p;; \ + esac; +am__strip_dir = f=`echo $$p | sed -e 's|^.*/||'`; +am__install_max = 40 +am__nobase_strip_setup = \ + srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*|]/\\\\&/g'` +am__nobase_strip = \ + for p in $$list; do echo "$$p"; done | sed -e "s|$$srcdirstrip/||" +am__nobase_list = $(am__nobase_strip_setup); \ + for p in $$list; do echo "$$p $$p"; done | \ + sed "s| $$srcdirstrip/| |;"' / .*\//!s/ .*/ ./; s,\( .*\)/[^/]*$$,\1,' | \ + $(AWK) 'BEGIN { files["."] = "" } { files[$$2] = files[$$2] " " $$1; \ + if (++n[$$2] == $(am__install_max)) \ + { print $$2, files[$$2]; n[$$2] = 0; files[$$2] = "" } } \ + END { for (dir in files) print dir, files[dir] }' +am__base_list = \ + sed '$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;s/\n/ /g' | \ + sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g' +am__uninstall_files_from_dir = { \ + test -z "$$files" \ + || { test ! -d "$$dir" && test ! -f "$$dir" && test ! -r "$$dir"; } \ + || { echo " ( cd '$$dir' && rm -f" $$files ")"; \ + $(am__cd) "$$dir" && rm -f $$files; }; \ + } +am__installdirs = "$(DESTDIR)$(libdir)" "$(DESTDIR)$(includedir)" \ + "$(DESTDIR)$(includeexecdir)" +LTLIBRARIES = $(lib_LTLIBRARIES) +am__DEPENDENCIES_1 = $(MPF_OBJECTS) $(MPZ_OBJECTS) $(MPQ_OBJECTS) \ + $(MPN_OBJECTS) $(PRINTF_OBJECTS) $(SCANF_OBJECTS) \ + $(RANDOM_OBJECTS) +am_libgmp_la_OBJECTS = assert.lo compat.lo errno.lo extract-dbl.lo \ + invalid.lo memory.lo mp_bpl.lo mp_clz_tab.lo mp_dv_tab.lo \ + mp_minv_tab.lo mp_get_fns.lo mp_set_fns.lo version.lo \ + nextprime.lo primesieve.lo +libgmp_la_OBJECTS = $(am_libgmp_la_OBJECTS) +AM_V_lt = $(am__v_lt_@AM_V@) +am__v_lt_ = $(am__v_lt_@AM_DEFAULT_V@) +am__v_lt_0 = --silent +am__v_lt_1 = +libgmp_la_LINK = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \ + $(LIBTOOLFLAGS) --mode=link $(CCLD) $(AM_CFLAGS) $(CFLAGS) \ + $(libgmp_la_LDFLAGS) $(LDFLAGS) -o $@ +am_libgmpxx_la_OBJECTS = dummy.lo +libgmpxx_la_OBJECTS = $(am_libgmpxx_la_OBJECTS) +libgmpxx_la_LINK = $(LIBTOOL) $(AM_V_lt) --tag=CXX $(AM_LIBTOOLFLAGS) \ + $(LIBTOOLFLAGS) --mode=link $(CXXLD) $(AM_CXXFLAGS) \ + $(CXXFLAGS) $(libgmpxx_la_LDFLAGS) $(LDFLAGS) -o $@ +@WANT_CXX_TRUE@am_libgmpxx_la_rpath = -rpath $(libdir) +AM_V_P = $(am__v_P_@AM_V@) +am__v_P_ = $(am__v_P_@AM_DEFAULT_V@) +am__v_P_0 = false +am__v_P_1 = : +AM_V_GEN = $(am__v_GEN_@AM_V@) +am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@) +am__v_GEN_0 = @echo " GEN " $@; +am__v_GEN_1 = +AM_V_at = $(am__v_at_@AM_V@) +am__v_at_ = $(am__v_at_@AM_DEFAULT_V@) +am__v_at_0 = @ +am__v_at_1 = +DEFAULT_INCLUDES = -I.@am__isrc@ +depcomp = +am__depfiles_maybe = +COMPILE = $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \ + $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) +LTCOMPILE = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \ + $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) \ + $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) \ + $(AM_CFLAGS) $(CFLAGS) +AM_V_CC = $(am__v_CC_@AM_V@) +am__v_CC_ = $(am__v_CC_@AM_DEFAULT_V@) +am__v_CC_0 = @echo " CC " $@; +am__v_CC_1 = +CCLD = $(CC) +LINK = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \ + $(LIBTOOLFLAGS) --mode=link $(CCLD) $(AM_CFLAGS) $(CFLAGS) \ + $(AM_LDFLAGS) $(LDFLAGS) -o $@ +AM_V_CCLD = $(am__v_CCLD_@AM_V@) +am__v_CCLD_ = $(am__v_CCLD_@AM_DEFAULT_V@) +am__v_CCLD_0 = @echo " CCLD " $@; +am__v_CCLD_1 = +CXXCOMPILE = $(CXX) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) \ + $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CXXFLAGS) $(CXXFLAGS) +LTCXXCOMPILE = $(LIBTOOL) $(AM_V_lt) --tag=CXX $(AM_LIBTOOLFLAGS) \ + $(LIBTOOLFLAGS) --mode=compile $(CXX) $(DEFS) \ + $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) \ + $(AM_CXXFLAGS) $(CXXFLAGS) +AM_V_CXX = $(am__v_CXX_@AM_V@) +am__v_CXX_ = $(am__v_CXX_@AM_DEFAULT_V@) +am__v_CXX_0 = @echo " CXX " $@; +am__v_CXX_1 = +CXXLD = $(CXX) +CXXLINK = $(LIBTOOL) $(AM_V_lt) --tag=CXX $(AM_LIBTOOLFLAGS) \ + $(LIBTOOLFLAGS) --mode=link $(CXXLD) $(AM_CXXFLAGS) \ + $(CXXFLAGS) $(AM_LDFLAGS) $(LDFLAGS) -o $@ +AM_V_CXXLD = $(am__v_CXXLD_@AM_V@) +am__v_CXXLD_ = $(am__v_CXXLD_@AM_DEFAULT_V@) +am__v_CXXLD_0 = @echo " CXXLD " $@; +am__v_CXXLD_1 = +SOURCES = $(libgmp_la_SOURCES) $(EXTRA_libgmp_la_SOURCES) \ + $(libgmpxx_la_SOURCES) +DIST_SOURCES = $(libgmp_la_SOURCES) $(EXTRA_libgmp_la_SOURCES) \ + $(libgmpxx_la_SOURCES) +RECURSIVE_TARGETS = all-recursive check-recursive cscopelist-recursive \ + ctags-recursive dvi-recursive html-recursive info-recursive \ + install-data-recursive install-dvi-recursive \ + install-exec-recursive install-html-recursive \ + install-info-recursive install-pdf-recursive \ + install-ps-recursive install-recursive installcheck-recursive \ + installdirs-recursive pdf-recursive ps-recursive \ + tags-recursive uninstall-recursive +am__can_run_installinfo = \ + case $$AM_UPDATE_INFO_DIR in \ + n|no|NO) false;; \ + *) (install-info --version) >/dev/null 2>&1;; \ + esac +am__include_HEADERS_DIST = gmpxx.h +HEADERS = $(include_HEADERS) $(nodist_includeexec_HEADERS) +RECURSIVE_CLEAN_TARGETS = mostlyclean-recursive clean-recursive \ + distclean-recursive maintainer-clean-recursive +am__recursive_targets = \ + $(RECURSIVE_TARGETS) \ + $(RECURSIVE_CLEAN_TARGETS) \ + $(am__extra_recursive_targets) +AM_RECURSIVE_TARGETS = $(am__recursive_targets:-recursive=) TAGS CTAGS \ + cscope distdir dist dist-all distcheck +am__tagged_files = $(HEADERS) $(SOURCES) $(TAGS_FILES) \ + $(LISP)config.in +# Read a list of newline-separated strings from the standard input, +# and print each of them once, without duplicates. Input order is +# *not* preserved. +am__uniquify_input = $(AWK) '\ + BEGIN { nonempty = 0; } \ + { items[$$0] = 1; nonempty = 1; } \ + END { if (nonempty) { for (i in items) print i; }; } \ +' +# Make sure the list of sources is unique. This is necessary because, +# e.g., the same source file might be shared among _SOURCES variables +# for different programs/libraries. +am__define_uniq_tagged_files = \ + list='$(am__tagged_files)'; \ + unique=`for i in $$list; do \ + if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ + done | $(am__uniquify_input)` +ETAGS = etags +CTAGS = ctags +CSCOPE = cscope +DIST_SUBDIRS = $(SUBDIRS) +DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) +distdir = $(PACKAGE)-$(VERSION) +top_distdir = $(distdir) +am__remove_distdir = \ + if test -d "$(distdir)"; then \ + find "$(distdir)" -type d ! -perm -200 -exec chmod u+w {} ';' \ + && rm -rf "$(distdir)" \ + || { sleep 5 && rm -rf "$(distdir)"; }; \ + else :; fi +am__post_remove_distdir = $(am__remove_distdir) +am__relativize = \ + dir0=`pwd`; \ + sed_first='s,^\([^/]*\)/.*$$,\1,'; \ + sed_rest='s,^[^/]*/*,,'; \ + sed_last='s,^.*/\([^/]*\)$$,\1,'; \ + sed_butlast='s,/*[^/]*$$,,'; \ + while test -n "$$dir1"; do \ + first=`echo "$$dir1" | sed -e "$$sed_first"`; \ + if test "$$first" != "."; then \ + if test "$$first" = ".."; then \ + dir2=`echo "$$dir0" | sed -e "$$sed_last"`/"$$dir2"; \ + dir0=`echo "$$dir0" | sed -e "$$sed_butlast"`; \ + else \ + first2=`echo "$$dir2" | sed -e "$$sed_first"`; \ + if test "$$first2" = "$$first"; then \ + dir2=`echo "$$dir2" | sed -e "$$sed_rest"`; \ + else \ + dir2="../$$dir2"; \ + fi; \ + dir0="$$dir0"/"$$first"; \ + fi; \ + fi; \ + dir1=`echo "$$dir1" | sed -e "$$sed_rest"`; \ + done; \ + reldir="$$dir2" +DIST_ARCHIVES = $(distdir).tar.gz +GZIP_ENV = --best +DIST_TARGETS = dist-gzip +distuninstallcheck_listfiles = find . -type f -print +am__distuninstallcheck_listfiles = $(distuninstallcheck_listfiles) \ + | sed 's|^\./|$(prefix)/|' | grep -v '$(infodir)/dir$$' +distcleancheck_listfiles = find . -type f -print +ABI = @ABI@ +ACLOCAL = @ACLOCAL@ +AMTAR = @AMTAR@ +AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ +AR = @AR@ +AS = @AS@ +ASMFLAGS = @ASMFLAGS@ +AUTOCONF = @AUTOCONF@ +AUTOHEADER = @AUTOHEADER@ +AUTOMAKE = @AUTOMAKE@ +AWK = @AWK@ +CALLING_CONVENTIONS_OBJS = @CALLING_CONVENTIONS_OBJS@ +CC = @CC@ +CCAS = @CCAS@ +CC_FOR_BUILD = @CC_FOR_BUILD@ +CFLAGS = @CFLAGS@ +CPP = @CPP@ +CPPFLAGS = @CPPFLAGS@ +CPP_FOR_BUILD = @CPP_FOR_BUILD@ +CXX = @CXX@ +CXXCPP = @CXXCPP@ +CXXFLAGS = @CXXFLAGS@ +CYGPATH_W = @CYGPATH_W@ +DEFN_LONG_LONG_LIMB = @DEFN_LONG_LONG_LIMB@ +DEFS = @DEFS@ +DLLTOOL = @DLLTOOL@ +DSYMUTIL = @DSYMUTIL@ +DUMPBIN = @DUMPBIN@ +ECHO_C = @ECHO_C@ +ECHO_N = @ECHO_N@ +ECHO_T = @ECHO_T@ +EGREP = @EGREP@ +EXEEXT = @EXEEXT@ +EXEEXT_FOR_BUILD = @EXEEXT_FOR_BUILD@ +FGREP = @FGREP@ +GMP_LDFLAGS = @GMP_LDFLAGS@ +GMP_LIMB_BITS = @GMP_LIMB_BITS@ +GMP_NAIL_BITS = @GMP_NAIL_BITS@ +GREP = @GREP@ +HAVE_CLOCK_01 = @HAVE_CLOCK_01@ +HAVE_CPUTIME_01 = @HAVE_CPUTIME_01@ +HAVE_GETRUSAGE_01 = @HAVE_GETRUSAGE_01@ +HAVE_GETTIMEOFDAY_01 = @HAVE_GETTIMEOFDAY_01@ +HAVE_HOST_CPU_FAMILY_power = @HAVE_HOST_CPU_FAMILY_power@ +HAVE_HOST_CPU_FAMILY_powerpc = @HAVE_HOST_CPU_FAMILY_powerpc@ +HAVE_SIGACTION_01 = @HAVE_SIGACTION_01@ +HAVE_SIGALTSTACK_01 = @HAVE_SIGALTSTACK_01@ +HAVE_SIGSTACK_01 = @HAVE_SIGSTACK_01@ +HAVE_STACK_T_01 = @HAVE_STACK_T_01@ +HAVE_SYS_RESOURCE_H_01 = @HAVE_SYS_RESOURCE_H_01@ +INSTALL = @INSTALL@ +INSTALL_DATA = @INSTALL_DATA@ +INSTALL_PROGRAM = @INSTALL_PROGRAM@ +INSTALL_SCRIPT = @INSTALL_SCRIPT@ +INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ +LD = @LD@ +LDFLAGS = @LDFLAGS@ +LEX = @LEX@ +LEXLIB = @LEXLIB@ +LEX_OUTPUT_ROOT = @LEX_OUTPUT_ROOT@ +LIBCURSES = @LIBCURSES@ +LIBGMPXX_LDFLAGS = @LIBGMPXX_LDFLAGS@ +LIBGMP_DLL = @LIBGMP_DLL@ +LIBGMP_LDFLAGS = @LIBGMP_LDFLAGS@ +LIBM = @LIBM@ +LIBM_FOR_BUILD = @LIBM_FOR_BUILD@ +LIBOBJS = @LIBOBJS@ +LIBREADLINE = @LIBREADLINE@ +LIBS = @LIBS@ +LIBTOOL = @LIBTOOL@ +LIPO = @LIPO@ +LN_S = @LN_S@ +LTLIBOBJS = @LTLIBOBJS@ +M4 = @M4@ +MAINT = @MAINT@ +MAKEINFO = @MAKEINFO@ +MANIFEST_TOOL = @MANIFEST_TOOL@ +MKDIR_P = @MKDIR_P@ +NM = @NM@ +NMEDIT = @NMEDIT@ +OBJDUMP = @OBJDUMP@ +OBJEXT = @OBJEXT@ +OTOOL = @OTOOL@ +OTOOL64 = @OTOOL64@ +PACKAGE = @PACKAGE@ +PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ +PACKAGE_NAME = @PACKAGE_NAME@ +PACKAGE_STRING = @PACKAGE_STRING@ +PACKAGE_TARNAME = @PACKAGE_TARNAME@ +PACKAGE_URL = @PACKAGE_URL@ +PACKAGE_VERSION = @PACKAGE_VERSION@ +PATH_SEPARATOR = @PATH_SEPARATOR@ +RANLIB = @RANLIB@ +SED = @SED@ +SET_MAKE = @SET_MAKE@ +SHELL = @SHELL@ +SPEED_CYCLECOUNTER_OBJ = @SPEED_CYCLECOUNTER_OBJ@ +STRIP = @STRIP@ +TAL_OBJECT = @TAL_OBJECT@ +TUNE_LIBS = @TUNE_LIBS@ +TUNE_SQR_OBJ = @TUNE_SQR_OBJ@ +U_FOR_BUILD = @U_FOR_BUILD@ +VERSION = @VERSION@ +WITH_READLINE_01 = @WITH_READLINE_01@ +YACC = @YACC@ +YFLAGS = @YFLAGS@ +abs_builddir = @abs_builddir@ +abs_srcdir = @abs_srcdir@ +abs_top_builddir = @abs_top_builddir@ +abs_top_srcdir = @abs_top_srcdir@ +ac_ct_AR = @ac_ct_AR@ +ac_ct_CC = @ac_ct_CC@ +ac_ct_CXX = @ac_ct_CXX@ +ac_ct_DUMPBIN = @ac_ct_DUMPBIN@ +am__leading_dot = @am__leading_dot@ +am__tar = @am__tar@ +am__untar = @am__untar@ +bindir = @bindir@ +build = @build@ +build_alias = @build_alias@ +build_cpu = @build_cpu@ +build_os = @build_os@ +build_vendor = @build_vendor@ +builddir = @builddir@ +datadir = @datadir@ +datarootdir = @datarootdir@ +docdir = @docdir@ +dvidir = @dvidir@ +exec_prefix = @exec_prefix@ +gmp_srclinks = @gmp_srclinks@ +host = @host@ +host_alias = @host_alias@ +host_cpu = @host_cpu@ +host_os = @host_os@ +host_vendor = @host_vendor@ +htmldir = @htmldir@ +includedir = @includedir@ +infodir = @infodir@ +install_sh = @install_sh@ +libdir = @libdir@ +libexecdir = @libexecdir@ +localedir = @localedir@ +localstatedir = @localstatedir@ +mandir = @mandir@ +mkdir_p = @mkdir_p@ +mpn_objects = @mpn_objects@ +mpn_objs_in_libgmp = @mpn_objs_in_libgmp@ +oldincludedir = @oldincludedir@ +pdfdir = @pdfdir@ +prefix = @prefix@ +program_transform_name = @program_transform_name@ +psdir = @psdir@ +sbindir = @sbindir@ +sharedstatedir = @sharedstatedir@ +srcdir = @srcdir@ +sysconfdir = @sysconfdir@ +target_alias = @target_alias@ +top_build_prefix = @top_build_prefix@ +top_builddir = @top_builddir@ +top_srcdir = @top_srcdir@ +LIBGMP_LT_CURRENT = 12 +LIBGMP_LT_REVISION = 0 +LIBGMP_LT_AGE = 2 +LIBGMPXX_LT_CURRENT = 8 +LIBGMPXX_LT_REVISION = 0 +LIBGMPXX_LT_AGE = 4 +SUBDIRS = tests mpn mpz mpq mpf printf scanf rand cxx demos tune doc + +# The "test -f" support for srcdir!=builddir is similar to the automake .c.o +# etc rules, but with each foo.c explicitly, since $< is not portable +# outside an inference rule. +# +# A quoted 'foo.c' is used with the "test -f"'s to avoid Sun make rewriting +# it as part of its VPATH support. See the autoconf manual "Limitations of +# Make". +# +# Generated .h files which are used by gmp-impl.h are BUILT_SOURCES since +# they must exist before anything can be compiled. +# +# Other generated .h files are also BUILT_SOURCES so as to get all the +# build-system stuff over and done with at the start. Also, dependencies on +# the .h files are not properly expressed for the various objects that use +# them. + +# Distribute mini-gmp. Test sources copied by dist-hook. +EXTRA_DIST = configfsf.guess configfsf.sub .gdbinit INSTALL.autoconf \ + COPYING.LESSERv3 COPYINGv2 COPYINGv3 gmpxx.h bootstrap.c \ + gen-fac.c gen-fib.c gen-bases.c gen-trialdivtab.c \ + gen-jacobitab.c gen-psqr.c mini-gmp/README mini-gmp/mini-gmp.c \ + mini-gmp/mini-gmp.h mini-gmp/tests/Makefile \ + mini-gmp/tests/run-tests +@WANT_CXX_TRUE@GMPXX_HEADERS_OPTION = gmpxx.h + +# gmp.h and mp.h are architecture dependent, mainly since they encode the +# limb size used in libgmp. For that reason they belong under $exec_prefix +# not $prefix, strictly speaking. +# +# $exec_prefix/include is not in the default include path for gcc built to +# the same $prefix and $exec_prefix, which might mean gmp.h is not found, +# but anyone knowledgeable enough to be playing with exec_prefix will be able +# to address that. +# +includeexecdir = $(exec_prefix)/include +include_HEADERS = $(GMPXX_HEADERS_OPTION) +nodist_includeexec_HEADERS = gmp.h +lib_LTLIBRARIES = libgmp.la $(GMPXX_LTLIBRARIES_OPTION) +BUILT_SOURCES = gmp.h fac_table.h fib_table.h mpn/fib_table.c \ + mp_bases.h mpn/mp_bases.c trialdivtab.h mpn/jacobitab.h \ + mpn/perfsqr.h +DISTCLEANFILES = $(BUILT_SOURCES) config.m4 @gmp_srclinks@ \ + gen-fac$(EXEEXT_FOR_BUILD) gen-fib$(EXEEXT_FOR_BUILD) \ + gen-bases$(EXEEXT_FOR_BUILD) \ + gen-trialdivtab$(EXEEXT_FOR_BUILD) \ + gen-jacobitab$(EXEEXT_FOR_BUILD) gen-psqr$(EXEEXT_FOR_BUILD) + +# Tell gmp.h it's building gmp, not an application, used by windows DLL stuff. +INCLUDES = -D__GMP_WITHIN_GMP +MPF_OBJECTS = mpf/init$U.lo mpf/init2$U.lo mpf/inits$U.lo mpf/set$U.lo \ + mpf/set_ui$U.lo mpf/set_si$U.lo mpf/set_str$U.lo mpf/set_d$U.lo \ + mpf/set_z$U.lo mpf/iset$U.lo mpf/iset_ui$U.lo mpf/iset_si$U.lo \ + mpf/iset_str$U.lo mpf/iset_d$U.lo mpf/clear$U.lo mpf/clears$U.lo \ + mpf/get_str$U.lo mpf/dump$U.lo mpf/size$U.lo mpf/eq$U.lo mpf/reldiff$U.lo \ + mpf/sqrt$U.lo mpf/random2$U.lo mpf/inp_str$U.lo mpf/out_str$U.lo \ + mpf/add$U.lo mpf/add_ui$U.lo mpf/sub$U.lo mpf/sub_ui$U.lo mpf/ui_sub$U.lo \ + mpf/mul$U.lo mpf/mul_ui$U.lo mpf/div$U.lo mpf/div_ui$U.lo \ + mpf/cmp$U.lo mpf/cmp_d$U.lo mpf/cmp_ui$U.lo mpf/cmp_si$U.lo \ + mpf/mul_2exp$U.lo mpf/div_2exp$U.lo mpf/abs$U.lo mpf/neg$U.lo \ + mpf/set_q$U.lo mpf/get_d$U.lo mpf/get_d_2exp$U.lo mpf/set_dfl_prec$U.lo \ + mpf/set_prc$U.lo mpf/set_prc_raw$U.lo mpf/get_dfl_prec$U.lo \ + mpf/get_prc$U.lo mpf/ui_div$U.lo mpf/sqrt_ui$U.lo \ + mpf/ceilfloor$U.lo mpf/trunc$U.lo mpf/pow_ui$U.lo \ + mpf/urandomb$U.lo mpf/swap$U.lo \ + mpf/fits_sint$U.lo mpf/fits_slong$U.lo mpf/fits_sshort$U.lo \ + mpf/fits_uint$U.lo mpf/fits_ulong$U.lo mpf/fits_ushort$U.lo \ + mpf/get_si$U.lo mpf/get_ui$U.lo \ + mpf/int_p$U.lo + +MPZ_OBJECTS = mpz/abs$U.lo mpz/add$U.lo mpz/add_ui$U.lo \ + mpz/aorsmul$U.lo mpz/aorsmul_i$U.lo mpz/and$U.lo mpz/array_init$U.lo \ + mpz/bin_ui$U.lo mpz/bin_uiui$U.lo \ + mpz/cdiv_q$U.lo mpz/cdiv_q_ui$U.lo \ + mpz/cdiv_qr$U.lo mpz/cdiv_qr_ui$U.lo \ + mpz/cdiv_r$U.lo mpz/cdiv_r_ui$U.lo mpz/cdiv_ui$U.lo \ + mpz/cfdiv_q_2exp$U.lo mpz/cfdiv_r_2exp$U.lo \ + mpz/clear$U.lo mpz/clears$U.lo mpz/clrbit$U.lo \ + mpz/cmp$U.lo mpz/cmp_d$U.lo mpz/cmp_si$U.lo mpz/cmp_ui$U.lo \ + mpz/cmpabs$U.lo mpz/cmpabs_d$U.lo mpz/cmpabs_ui$U.lo \ + mpz/com$U.lo mpz/combit$U.lo \ + mpz/cong$U.lo mpz/cong_2exp$U.lo mpz/cong_ui$U.lo \ + mpz/divexact$U.lo mpz/divegcd$U.lo mpz/dive_ui$U.lo \ + mpz/divis$U.lo mpz/divis_ui$U.lo mpz/divis_2exp$U.lo mpz/dump$U.lo \ + mpz/export$U.lo mpz/mfac_uiui$U.lo \ + mpz/2fac_ui$U.lo mpz/fac_ui$U.lo mpz/oddfac_1$U.lo mpz/prodlimbs$U.lo \ + mpz/fdiv_q_ui$U.lo mpz/fdiv_qr$U.lo mpz/fdiv_qr_ui$U.lo \ + mpz/fdiv_r$U.lo mpz/fdiv_r_ui$U.lo mpz/fdiv_q$U.lo \ + mpz/fdiv_ui$U.lo mpz/fib_ui$U.lo mpz/fib2_ui$U.lo mpz/fits_sint$U.lo \ + mpz/fits_slong$U.lo mpz/fits_sshort$U.lo mpz/fits_uint$U.lo \ + mpz/fits_ulong$U.lo mpz/fits_ushort$U.lo mpz/gcd$U.lo \ + mpz/gcd_ui$U.lo mpz/gcdext$U.lo mpz/get_d$U.lo mpz/get_d_2exp$U.lo \ + mpz/get_si$U.lo mpz/get_str$U.lo mpz/get_ui$U.lo mpz/getlimbn$U.lo \ + mpz/hamdist$U.lo \ + mpz/import$U.lo mpz/init$U.lo mpz/init2$U.lo mpz/inits$U.lo \ + mpz/inp_raw$U.lo mpz/inp_str$U.lo mpz/invert$U.lo \ + mpz/ior$U.lo mpz/iset$U.lo mpz/iset_d$U.lo mpz/iset_si$U.lo \ + mpz/iset_str$U.lo mpz/iset_ui$U.lo mpz/jacobi$U.lo mpz/kronsz$U.lo \ + mpz/kronuz$U.lo mpz/kronzs$U.lo mpz/kronzu$U.lo \ + mpz/lcm$U.lo mpz/lcm_ui$U.lo mpz/limbs_finish$U.lo \ + mpz/limbs_modify$U.lo mpz/limbs_read$U.lo mpz/limbs_write$U.lo \ + mpz/lucnum_ui$U.lo mpz/lucnum2_ui$U.lo \ + mpz/millerrabin$U.lo mpz/mod$U.lo mpz/mul$U.lo mpz/mul_2exp$U.lo \ + mpz/mul_si$U.lo mpz/mul_ui$U.lo \ + mpz/n_pow_ui$U.lo mpz/neg$U.lo mpz/nextprime$U.lo \ + mpz/out_raw$U.lo mpz/out_str$U.lo mpz/perfpow$U.lo mpz/perfsqr$U.lo \ + mpz/popcount$U.lo mpz/pow_ui$U.lo mpz/powm$U.lo mpz/powm_sec$U.lo \ + mpz/powm_ui$U.lo mpz/primorial_ui$U.lo \ + mpz/pprime_p$U.lo mpz/random$U.lo mpz/random2$U.lo \ + mpz/realloc$U.lo mpz/realloc2$U.lo mpz/remove$U.lo mpz/roinit_n$U.lo \ + mpz/root$U.lo mpz/rootrem$U.lo mpz/rrandomb$U.lo mpz/scan0$U.lo \ + mpz/scan1$U.lo mpz/set$U.lo mpz/set_d$U.lo mpz/set_f$U.lo \ + mpz/set_q$U.lo mpz/set_si$U.lo mpz/set_str$U.lo mpz/set_ui$U.lo \ + mpz/setbit$U.lo \ + mpz/size$U.lo mpz/sizeinbase$U.lo mpz/sqrt$U.lo \ + mpz/sqrtrem$U.lo mpz/sub$U.lo mpz/sub_ui$U.lo mpz/swap$U.lo \ + mpz/tdiv_ui$U.lo mpz/tdiv_q$U.lo mpz/tdiv_q_2exp$U.lo \ + mpz/tdiv_q_ui$U.lo mpz/tdiv_qr$U.lo mpz/tdiv_qr_ui$U.lo \ + mpz/tdiv_r$U.lo mpz/tdiv_r_2exp$U.lo mpz/tdiv_r_ui$U.lo \ + mpz/tstbit$U.lo mpz/ui_pow_ui$U.lo mpz/ui_sub$U.lo mpz/urandomb$U.lo \ + mpz/urandomm$U.lo mpz/xor$U.lo + +MPQ_OBJECTS = mpq/abs$U.lo mpq/aors$U.lo \ + mpq/canonicalize$U.lo mpq/clear$U.lo mpq/clears$U.lo \ + mpq/cmp$U.lo mpq/cmp_si$U.lo mpq/cmp_ui$U.lo mpq/div$U.lo \ + mpq/get_d$U.lo mpq/get_den$U.lo mpq/get_num$U.lo mpq/get_str$U.lo \ + mpq/init$U.lo mpq/inits$U.lo mpq/inp_str$U.lo mpq/inv$U.lo \ + mpq/md_2exp$U.lo mpq/mul$U.lo mpq/neg$U.lo mpq/out_str$U.lo \ + mpq/set$U.lo mpq/set_den$U.lo mpq/set_num$U.lo \ + mpq/set_si$U.lo mpq/set_str$U.lo mpq/set_ui$U.lo \ + mpq/equal$U.lo mpq/set_z$U.lo mpq/set_d$U.lo \ + mpq/set_f$U.lo mpq/swap$U.lo + +MPN_OBJECTS = mpn/fib_table$U.lo mpn/mp_bases$U.lo +PRINTF_OBJECTS = \ + printf/asprintf$U.lo printf/asprntffuns$U.lo \ + printf/doprnt$U.lo printf/doprntf$U.lo printf/doprnti$U.lo \ + printf/fprintf$U.lo \ + printf/obprintf$U.lo printf/obvprintf$U.lo printf/obprntffuns$U.lo \ + printf/printf$U.lo printf/printffuns$U.lo \ + printf/snprintf$U.lo printf/snprntffuns$U.lo \ + printf/sprintf$U.lo printf/sprintffuns$U.lo \ + printf/vasprintf$U.lo printf/vfprintf$U.lo printf/vprintf$U.lo \ + printf/vsnprintf$U.lo printf/vsprintf$U.lo \ + printf/repl-vsnprintf$U.lo + +SCANF_OBJECTS = \ + scanf/doscan$U.lo scanf/fscanf$U.lo scanf/fscanffuns$U.lo \ + scanf/scanf$U.lo scanf/sscanf$U.lo scanf/sscanffuns$U.lo \ + scanf/vfscanf$U.lo scanf/vscanf$U.lo scanf/vsscanf$U.lo + +RANDOM_OBJECTS = \ + rand/rand$U.lo rand/randclr$U.lo rand/randdef$U.lo rand/randiset$U.lo \ + rand/randlc2s$U.lo rand/randlc2x$U.lo rand/randmt$U.lo \ + rand/randmts$U.lo rand/rands$U.lo rand/randsd$U.lo rand/randsdui$U.lo \ + rand/randbui$U.lo rand/randmui$U.lo + + +# no $U for C++ files +CXX_OBJECTS = \ + cxx/isfuns.lo cxx/ismpf.lo cxx/ismpq.lo cxx/ismpz.lo cxx/ismpznw.lo \ + cxx/limits.lo cxx/osdoprnti.lo cxx/osfuns.lo \ + cxx/osmpf.lo cxx/osmpq.lo cxx/osmpz.lo + + +# In libtool 1.5 it doesn't work to build libgmp.la from the convenience +# libraries like mpz/libmpz.la. Or rather it works, but it ends up putting +# PIC objects into libgmp.a if shared and static are both built. (The PIC +# objects go into mpz/.libs/libmpz.a, and thence into .libs/libgmp.a.) +# +# For now the big lists of objects above are used. Something like mpz/*.lo +# would probably work, but might risk missing something out or getting +# something extra. The source files for each .lo are listed in the +# Makefile.am's in the subdirectories. +# +# Currently, for libgmp, unlike libmp below, we're not using +# -export-symbols, since the tune and speed programs, and perhaps some of +# the test programs, want to access undocumented symbols. +libgmp_la_SOURCES = gmp-impl.h longlong.h \ + assert.c compat.c errno.c extract-dbl.c invalid.c memory.c \ + mp_bpl.c mp_clz_tab.c mp_dv_tab.c mp_minv_tab.c mp_get_fns.c mp_set_fns.c \ + version.c nextprime.c primesieve.c + +EXTRA_libgmp_la_SOURCES = tal-debug.c tal-notreent.c tal-reent.c +libgmp_la_DEPENDENCIES = @TAL_OBJECT@ \ + $(MPF_OBJECTS) $(MPZ_OBJECTS) $(MPQ_OBJECTS) \ + $(MPN_OBJECTS) @mpn_objs_in_libgmp@ \ + $(PRINTF_OBJECTS) $(SCANF_OBJECTS) $(RANDOM_OBJECTS) + +libgmp_la_LIBADD = $(libgmp_la_DEPENDENCIES) +libgmp_la_LDFLAGS = $(GMP_LDFLAGS) $(LIBGMP_LDFLAGS) \ + -version-info $(LIBGMP_LT_CURRENT):$(LIBGMP_LT_REVISION):$(LIBGMP_LT_AGE) + + +# We need at least one .cc file in $(libgmpxx_la_SOURCES) so automake will +# use $(CXXLINK) rather than the plain C $(LINK). cxx/dummy.cc is that +# file. +@WANT_CXX_TRUE@GMPXX_LTLIBRARIES_OPTION = libgmpxx.la +libgmpxx_la_SOURCES = cxx/dummy.cc +libgmpxx_la_DEPENDENCIES = $(CXX_OBJECTS) libgmp.la +libgmpxx_la_LIBADD = $(libgmpxx_la_DEPENDENCIES) +libgmpxx_la_LDFLAGS = $(GMP_LDFLAGS) $(LIBGMPXX_LDFLAGS) \ + -version-info $(LIBGMPXX_LT_CURRENT):$(LIBGMPXX_LT_REVISION):$(LIBGMPXX_LT_AGE) + +all: $(BUILT_SOURCES) config.h + $(MAKE) $(AM_MAKEFLAGS) all-recursive + +.SUFFIXES: +.SUFFIXES: .c .cc .lo .o .obj +am--refresh: Makefile + @: +$(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__configure_deps) + @for dep in $?; do \ + case '$(am__configure_deps)' in \ + *$$dep*) \ + echo ' cd $(srcdir) && $(AUTOMAKE) --gnu --ignore-deps'; \ + $(am__cd) $(srcdir) && $(AUTOMAKE) --gnu --ignore-deps \ + && exit 0; \ + exit 1;; \ + esac; \ + done; \ + echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu --ignore-deps Makefile'; \ + $(am__cd) $(top_srcdir) && \ + $(AUTOMAKE) --gnu --ignore-deps Makefile +.PRECIOUS: Makefile +Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status + @case '$?' in \ + *config.status*) \ + echo ' $(SHELL) ./config.status'; \ + $(SHELL) ./config.status;; \ + *) \ + echo ' cd $(top_builddir) && $(SHELL) ./config.status $@ $(am__depfiles_maybe)'; \ + cd $(top_builddir) && $(SHELL) ./config.status $@ $(am__depfiles_maybe);; \ + esac; + +$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) + $(SHELL) ./config.status --recheck + +$(top_srcdir)/configure: @MAINTAINER_MODE_TRUE@ $(am__configure_deps) + $(am__cd) $(srcdir) && $(AUTOCONF) +$(ACLOCAL_M4): @MAINTAINER_MODE_TRUE@ $(am__aclocal_m4_deps) + $(am__cd) $(srcdir) && $(ACLOCAL) $(ACLOCAL_AMFLAGS) +$(am__aclocal_m4_deps): + +config.h: stamp-h1 + @test -f $@ || rm -f stamp-h1 + @test -f $@ || $(MAKE) $(AM_MAKEFLAGS) stamp-h1 + +stamp-h1: $(srcdir)/config.in $(top_builddir)/config.status + @rm -f stamp-h1 + cd $(top_builddir) && $(SHELL) ./config.status config.h +$(srcdir)/config.in: @MAINTAINER_MODE_TRUE@ $(am__configure_deps) + ($(am__cd) $(top_srcdir) && $(AUTOHEADER)) + rm -f stamp-h1 + touch $@ + +distclean-hdr: + -rm -f config.h stamp-h1 +gmp.h: $(top_builddir)/config.status $(srcdir)/gmp-h.in + cd $(top_builddir) && $(SHELL) ./config.status $@ + +install-libLTLIBRARIES: $(lib_LTLIBRARIES) + @$(NORMAL_INSTALL) + @list='$(lib_LTLIBRARIES)'; test -n "$(libdir)" || list=; \ + list2=; for p in $$list; do \ + if test -f $$p; then \ + list2="$$list2 $$p"; \ + else :; fi; \ + done; \ + test -z "$$list2" || { \ + echo " $(MKDIR_P) '$(DESTDIR)$(libdir)'"; \ + $(MKDIR_P) "$(DESTDIR)$(libdir)" || exit 1; \ + echo " $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=install $(INSTALL) $(INSTALL_STRIP_FLAG) $$list2 '$(DESTDIR)$(libdir)'"; \ + $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=install $(INSTALL) $(INSTALL_STRIP_FLAG) $$list2 "$(DESTDIR)$(libdir)"; \ + } + +uninstall-libLTLIBRARIES: + @$(NORMAL_UNINSTALL) + @list='$(lib_LTLIBRARIES)'; test -n "$(libdir)" || list=; \ + for p in $$list; do \ + $(am__strip_dir) \ + echo " $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=uninstall rm -f '$(DESTDIR)$(libdir)/$$f'"; \ + $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=uninstall rm -f "$(DESTDIR)$(libdir)/$$f"; \ + done + +clean-libLTLIBRARIES: + -test -z "$(lib_LTLIBRARIES)" || rm -f $(lib_LTLIBRARIES) + @list='$(lib_LTLIBRARIES)'; \ + locs=`for p in $$list; do echo $$p; done | \ + sed 's|^[^/]*$$|.|; s|/[^/]*$$||; s|$$|/so_locations|' | \ + sort -u`; \ + test -z "$$locs" || { \ + echo rm -f $${locs}; \ + rm -f $${locs}; \ + } + +libgmp.la: $(libgmp_la_OBJECTS) $(libgmp_la_DEPENDENCIES) $(EXTRA_libgmp_la_DEPENDENCIES) + $(AM_V_CCLD)$(libgmp_la_LINK) -rpath $(libdir) $(libgmp_la_OBJECTS) $(libgmp_la_LIBADD) $(LIBS) + +libgmpxx.la: $(libgmpxx_la_OBJECTS) $(libgmpxx_la_DEPENDENCIES) $(EXTRA_libgmpxx_la_DEPENDENCIES) + $(AM_V_CXXLD)$(libgmpxx_la_LINK) $(am_libgmpxx_la_rpath) $(libgmpxx_la_OBJECTS) $(libgmpxx_la_LIBADD) $(LIBS) + +mostlyclean-compile: + -rm -f *.$(OBJEXT) + +distclean-compile: + -rm -f *.tab.c + +.c.o: + $(AM_V_CC)$(COMPILE) -c -o $@ $< + +.c.obj: + $(AM_V_CC)$(COMPILE) -c -o $@ `$(CYGPATH_W) '$<'` + +.c.lo: + $(AM_V_CC)$(LTCOMPILE) -c -o $@ $< + +.cc.o: + $(AM_V_CXX)$(CXXCOMPILE) -c -o $@ $< + +.cc.obj: + $(AM_V_CXX)$(CXXCOMPILE) -c -o $@ `$(CYGPATH_W) '$<'` + +.cc.lo: + $(AM_V_CXX)$(LTCXXCOMPILE) -c -o $@ $< + +dummy.lo: cxx/dummy.cc + $(AM_V_CXX)$(LIBTOOL) $(AM_V_lt) --tag=CXX $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CXX) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CXXFLAGS) $(CXXFLAGS) -c -o dummy.lo `test -f 'cxx/dummy.cc' || echo '$(srcdir)/'`cxx/dummy.cc + +mostlyclean-libtool: + -rm -f *.lo + +clean-libtool: + -rm -rf .libs _libs + +distclean-libtool: + -rm -f libtool config.lt +install-includeHEADERS: $(include_HEADERS) + @$(NORMAL_INSTALL) + @list='$(include_HEADERS)'; test -n "$(includedir)" || list=; \ + if test -n "$$list"; then \ + echo " $(MKDIR_P) '$(DESTDIR)$(includedir)'"; \ + $(MKDIR_P) "$(DESTDIR)$(includedir)" || exit 1; \ + fi; \ + for p in $$list; do \ + if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ + echo "$$d$$p"; \ + done | $(am__base_list) | \ + while read files; do \ + echo " $(INSTALL_HEADER) $$files '$(DESTDIR)$(includedir)'"; \ + $(INSTALL_HEADER) $$files "$(DESTDIR)$(includedir)" || exit $$?; \ + done + +uninstall-includeHEADERS: + @$(NORMAL_UNINSTALL) + @list='$(include_HEADERS)'; test -n "$(includedir)" || list=; \ + files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \ + dir='$(DESTDIR)$(includedir)'; $(am__uninstall_files_from_dir) +install-nodist_includeexecHEADERS: $(nodist_includeexec_HEADERS) + @$(NORMAL_INSTALL) + @list='$(nodist_includeexec_HEADERS)'; test -n "$(includeexecdir)" || list=; \ + if test -n "$$list"; then \ + echo " $(MKDIR_P) '$(DESTDIR)$(includeexecdir)'"; \ + $(MKDIR_P) "$(DESTDIR)$(includeexecdir)" || exit 1; \ + fi; \ + for p in $$list; do \ + if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ + echo "$$d$$p"; \ + done | $(am__base_list) | \ + while read files; do \ + echo " $(INSTALL_HEADER) $$files '$(DESTDIR)$(includeexecdir)'"; \ + $(INSTALL_HEADER) $$files "$(DESTDIR)$(includeexecdir)" || exit $$?; \ + done + +uninstall-nodist_includeexecHEADERS: + @$(NORMAL_UNINSTALL) + @list='$(nodist_includeexec_HEADERS)'; test -n "$(includeexecdir)" || list=; \ + files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \ + dir='$(DESTDIR)$(includeexecdir)'; $(am__uninstall_files_from_dir) + +# This directory's subdirectories are mostly independent; you can cd +# into them and run 'make' without going through this Makefile. +# To change the values of 'make' variables: instead of editing Makefiles, +# (1) if the variable is set in 'config.status', edit 'config.status' +# (which will cause the Makefiles to be regenerated when you run 'make'); +# (2) otherwise, pass the desired values on the 'make' command line. +$(am__recursive_targets): + @fail=; \ + if $(am__make_keepgoing); then \ + failcom='fail=yes'; \ + else \ + failcom='exit 1'; \ + fi; \ + dot_seen=no; \ + target=`echo $@ | sed s/-recursive//`; \ + case "$@" in \ + distclean-* | maintainer-clean-*) list='$(DIST_SUBDIRS)' ;; \ + *) list='$(SUBDIRS)' ;; \ + esac; \ + for subdir in $$list; do \ + echo "Making $$target in $$subdir"; \ + if test "$$subdir" = "."; then \ + dot_seen=yes; \ + local_target="$$target-am"; \ + else \ + local_target="$$target"; \ + fi; \ + ($(am__cd) $$subdir && $(MAKE) $(AM_MAKEFLAGS) $$local_target) \ + || eval $$failcom; \ + done; \ + if test "$$dot_seen" = "no"; then \ + $(MAKE) $(AM_MAKEFLAGS) "$$target-am" || exit 1; \ + fi; test -z "$$fail" + +ID: $(am__tagged_files) + $(am__define_uniq_tagged_files); mkid -fID $$unique +tags: tags-recursive +TAGS: tags + +tags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) + set x; \ + here=`pwd`; \ + if ($(ETAGS) --etags-include --version) >/dev/null 2>&1; then \ + include_option=--etags-include; \ + empty_fix=.; \ + else \ + include_option=--include; \ + empty_fix=; \ + fi; \ + list='$(SUBDIRS)'; for subdir in $$list; do \ + if test "$$subdir" = .; then :; else \ + test ! -f $$subdir/TAGS || \ + set "$$@" "$$include_option=$$here/$$subdir/TAGS"; \ + fi; \ + done; \ + $(am__define_uniq_tagged_files); \ + shift; \ + if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \ + test -n "$$unique" || unique=$$empty_fix; \ + if test $$# -gt 0; then \ + $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ + "$$@" $$unique; \ + else \ + $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ + $$unique; \ + fi; \ + fi +ctags: ctags-recursive + +CTAGS: ctags +ctags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files) + $(am__define_uniq_tagged_files); \ + test -z "$(CTAGS_ARGS)$$unique" \ + || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \ + $$unique + +GTAGS: + here=`$(am__cd) $(top_builddir) && pwd` \ + && $(am__cd) $(top_srcdir) \ + && gtags -i $(GTAGS_ARGS) "$$here" +cscope: cscope.files + test ! -s cscope.files \ + || $(CSCOPE) -b -q $(AM_CSCOPEFLAGS) $(CSCOPEFLAGS) -i cscope.files $(CSCOPE_ARGS) +clean-cscope: + -rm -f cscope.files +cscope.files: clean-cscope cscopelist +cscopelist: cscopelist-recursive + +cscopelist-am: $(am__tagged_files) + list='$(am__tagged_files)'; \ + case "$(srcdir)" in \ + [\\/]* | ?:[\\/]*) sdir="$(srcdir)" ;; \ + *) sdir=$(subdir)/$(srcdir) ;; \ + esac; \ + for i in $$list; do \ + if test -f "$$i"; then \ + echo "$(subdir)/$$i"; \ + else \ + echo "$$sdir/$$i"; \ + fi; \ + done >> $(top_builddir)/cscope.files + +distclean-tags: + -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags + -rm -f cscope.out cscope.in.out cscope.po.out cscope.files + +distdir: $(DISTFILES) + $(am__remove_distdir) + test -d "$(distdir)" || mkdir "$(distdir)" + @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ + topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ + list='$(DISTFILES)'; \ + dist_files=`for file in $$list; do echo $$file; done | \ + sed -e "s|^$$srcdirstrip/||;t" \ + -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \ + case $$dist_files in \ + */*) $(MKDIR_P) `echo "$$dist_files" | \ + sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \ + sort -u` ;; \ + esac; \ + for file in $$dist_files; do \ + if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ + if test -d $$d/$$file; then \ + dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \ + if test -d "$(distdir)/$$file"; then \ + find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ + fi; \ + if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ + cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \ + find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ + fi; \ + cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \ + else \ + test -f "$(distdir)/$$file" \ + || cp -p $$d/$$file "$(distdir)/$$file" \ + || exit 1; \ + fi; \ + done + @list='$(DIST_SUBDIRS)'; for subdir in $$list; do \ + if test "$$subdir" = .; then :; else \ + $(am__make_dryrun) \ + || test -d "$(distdir)/$$subdir" \ + || $(MKDIR_P) "$(distdir)/$$subdir" \ + || exit 1; \ + dir1=$$subdir; dir2="$(distdir)/$$subdir"; \ + $(am__relativize); \ + new_distdir=$$reldir; \ + dir1=$$subdir; dir2="$(top_distdir)"; \ + $(am__relativize); \ + new_top_distdir=$$reldir; \ + echo " (cd $$subdir && $(MAKE) $(AM_MAKEFLAGS) top_distdir="$$new_top_distdir" distdir="$$new_distdir" \\"; \ + echo " am__remove_distdir=: am__skip_length_check=: am__skip_mode_fix=: distdir)"; \ + ($(am__cd) $$subdir && \ + $(MAKE) $(AM_MAKEFLAGS) \ + top_distdir="$$new_top_distdir" \ + distdir="$$new_distdir" \ + am__remove_distdir=: \ + am__skip_length_check=: \ + am__skip_mode_fix=: \ + distdir) \ + || exit 1; \ + fi; \ + done + $(MAKE) $(AM_MAKEFLAGS) \ + top_distdir="$(top_distdir)" distdir="$(distdir)" \ + dist-hook + -test -n "$(am__skip_mode_fix)" \ + || find "$(distdir)" -type d ! -perm -755 \ + -exec chmod u+rwx,go+rx {} \; -o \ + ! -type d ! -perm -444 -links 1 -exec chmod a+r {} \; -o \ + ! -type d ! -perm -400 -exec chmod a+r {} \; -o \ + ! -type d ! -perm -444 -exec $(install_sh) -c -m a+r {} {} \; \ + || chmod -R a+r "$(distdir)" +dist-gzip: distdir + tardir=$(distdir) && $(am__tar) | GZIP=$(GZIP_ENV) gzip -c >$(distdir).tar.gz + $(am__post_remove_distdir) + +dist-bzip2: distdir + tardir=$(distdir) && $(am__tar) | BZIP2=$${BZIP2--9} bzip2 -c >$(distdir).tar.bz2 + $(am__post_remove_distdir) + +dist-lzip: distdir + tardir=$(distdir) && $(am__tar) | lzip -c $${LZIP_OPT--9} >$(distdir).tar.lz + $(am__post_remove_distdir) + +dist-xz: distdir + tardir=$(distdir) && $(am__tar) | XZ_OPT=$${XZ_OPT--e} xz -c >$(distdir).tar.xz + $(am__post_remove_distdir) + +dist-tarZ: distdir + @echo WARNING: "Support for shar distribution archives is" \ + "deprecated." >&2 + @echo WARNING: "It will be removed altogether in Automake 2.0" >&2 + tardir=$(distdir) && $(am__tar) | compress -c >$(distdir).tar.Z + $(am__post_remove_distdir) + +dist-shar: distdir + @echo WARNING: "Support for distribution archives compressed with" \ + "legacy program 'compress' is deprecated." >&2 + @echo WARNING: "It will be removed altogether in Automake 2.0" >&2 + shar $(distdir) | GZIP=$(GZIP_ENV) gzip -c >$(distdir).shar.gz + $(am__post_remove_distdir) + +dist-zip: distdir + -rm -f $(distdir).zip + zip -rq $(distdir).zip $(distdir) + $(am__post_remove_distdir) + +dist dist-all: + $(MAKE) $(AM_MAKEFLAGS) $(DIST_TARGETS) am__post_remove_distdir='@:' + $(am__post_remove_distdir) + +# This target untars the dist file and tries a VPATH configuration. Then +# it guarantees that the distribution is self-contained by making another +# tarfile. +distcheck: dist + case '$(DIST_ARCHIVES)' in \ + *.tar.gz*) \ + GZIP=$(GZIP_ENV) gzip -dc $(distdir).tar.gz | $(am__untar) ;;\ + *.tar.bz2*) \ + bzip2 -dc $(distdir).tar.bz2 | $(am__untar) ;;\ + *.tar.lz*) \ + lzip -dc $(distdir).tar.lz | $(am__untar) ;;\ + *.tar.xz*) \ + xz -dc $(distdir).tar.xz | $(am__untar) ;;\ + *.tar.Z*) \ + uncompress -c $(distdir).tar.Z | $(am__untar) ;;\ + *.shar.gz*) \ + GZIP=$(GZIP_ENV) gzip -dc $(distdir).shar.gz | unshar ;;\ + *.zip*) \ + unzip $(distdir).zip ;;\ + esac + chmod -R a-w $(distdir) + chmod u+w $(distdir) + mkdir $(distdir)/_build $(distdir)/_inst + chmod a-w $(distdir) + test -d $(distdir)/_build || exit 0; \ + dc_install_base=`$(am__cd) $(distdir)/_inst && pwd | sed -e 's,^[^:\\/]:[\\/],/,'` \ + && dc_destdir="$${TMPDIR-/tmp}/am-dc-$$$$/" \ + && am__cwd=`pwd` \ + && $(am__cd) $(distdir)/_build \ + && ../configure \ + $(AM_DISTCHECK_CONFIGURE_FLAGS) \ + $(DISTCHECK_CONFIGURE_FLAGS) \ + --srcdir=.. --prefix="$$dc_install_base" \ + && $(MAKE) $(AM_MAKEFLAGS) \ + && $(MAKE) $(AM_MAKEFLAGS) dvi \ + && $(MAKE) $(AM_MAKEFLAGS) check \ + && $(MAKE) $(AM_MAKEFLAGS) install \ + && $(MAKE) $(AM_MAKEFLAGS) installcheck \ + && $(MAKE) $(AM_MAKEFLAGS) uninstall \ + && $(MAKE) $(AM_MAKEFLAGS) distuninstallcheck_dir="$$dc_install_base" \ + distuninstallcheck \ + && chmod -R a-w "$$dc_install_base" \ + && ({ \ + (cd ../.. && umask 077 && mkdir "$$dc_destdir") \ + && $(MAKE) $(AM_MAKEFLAGS) DESTDIR="$$dc_destdir" install \ + && $(MAKE) $(AM_MAKEFLAGS) DESTDIR="$$dc_destdir" uninstall \ + && $(MAKE) $(AM_MAKEFLAGS) DESTDIR="$$dc_destdir" \ + distuninstallcheck_dir="$$dc_destdir" distuninstallcheck; \ + } || { rm -rf "$$dc_destdir"; exit 1; }) \ + && rm -rf "$$dc_destdir" \ + && $(MAKE) $(AM_MAKEFLAGS) dist \ + && rm -rf $(DIST_ARCHIVES) \ + && $(MAKE) $(AM_MAKEFLAGS) distcleancheck \ + && cd "$$am__cwd" \ + || exit 1 + $(am__post_remove_distdir) + @(echo "$(distdir) archives ready for distribution: "; \ + list='$(DIST_ARCHIVES)'; for i in $$list; do echo $$i; done) | \ + sed -e 1h -e 1s/./=/g -e 1p -e 1x -e '$$p' -e '$$x' +distuninstallcheck: + @test -n '$(distuninstallcheck_dir)' || { \ + echo 'ERROR: trying to run $@ with an empty' \ + '$$(distuninstallcheck_dir)' >&2; \ + exit 1; \ + }; \ + $(am__cd) '$(distuninstallcheck_dir)' || { \ + echo 'ERROR: cannot chdir into $(distuninstallcheck_dir)' >&2; \ + exit 1; \ + }; \ + test `$(am__distuninstallcheck_listfiles) | wc -l` -eq 0 \ + || { echo "ERROR: files left after uninstall:" ; \ + if test -n "$(DESTDIR)"; then \ + echo " (check DESTDIR support)"; \ + fi ; \ + $(distuninstallcheck_listfiles) ; \ + exit 1; } >&2 +distcleancheck: distclean + @if test '$(srcdir)' = . ; then \ + echo "ERROR: distcleancheck can only run from a VPATH build" ; \ + exit 1 ; \ + fi + @test `$(distcleancheck_listfiles) | wc -l` -eq 0 \ + || { echo "ERROR: files left in build directory after distclean:" ; \ + $(distcleancheck_listfiles) ; \ + exit 1; } >&2 +check-am: all-am +check: $(BUILT_SOURCES) + $(MAKE) $(AM_MAKEFLAGS) check-recursive +all-am: Makefile $(LTLIBRARIES) $(HEADERS) config.h +installdirs: installdirs-recursive +installdirs-am: + for dir in "$(DESTDIR)$(libdir)" "$(DESTDIR)$(includedir)" "$(DESTDIR)$(includeexecdir)"; do \ + test -z "$$dir" || $(MKDIR_P) "$$dir"; \ + done +install: $(BUILT_SOURCES) + $(MAKE) $(AM_MAKEFLAGS) install-recursive +install-exec: install-exec-recursive +install-data: install-data-recursive +uninstall: uninstall-recursive + +install-am: all-am + @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am + +installcheck: installcheck-recursive +install-strip: + if test -z '$(STRIP)'; then \ + $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ + install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ + install; \ + else \ + $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ + install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ + "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'" install; \ + fi +mostlyclean-generic: + +clean-generic: + +distclean-generic: + -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) + -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES) + -test -z "$(DISTCLEANFILES)" || rm -f $(DISTCLEANFILES) + +maintainer-clean-generic: + @echo "This command is intended for maintainers to use" + @echo "it deletes files that may require special tools to rebuild." + -test -z "$(BUILT_SOURCES)" || rm -f $(BUILT_SOURCES) +clean: clean-recursive + +clean-am: clean-generic clean-libLTLIBRARIES clean-libtool clean-local \ + mostlyclean-am + +distclean: distclean-recursive + -rm -f $(am__CONFIG_DISTCLEAN_FILES) + -rm -f Makefile +distclean-am: clean-am distclean-compile distclean-generic \ + distclean-hdr distclean-libtool distclean-local distclean-tags + +dvi: dvi-recursive + +dvi-am: + +html: html-recursive + +html-am: + +info: info-recursive + +info-am: + +install-data-am: install-includeHEADERS + @$(NORMAL_INSTALL) + $(MAKE) $(AM_MAKEFLAGS) install-data-hook +install-dvi: install-dvi-recursive + +install-dvi-am: + +install-exec-am: install-libLTLIBRARIES \ + install-nodist_includeexecHEADERS + +install-html: install-html-recursive + +install-html-am: + +install-info: install-info-recursive + +install-info-am: + +install-man: + +install-pdf: install-pdf-recursive + +install-pdf-am: + +install-ps: install-ps-recursive + +install-ps-am: + +installcheck-am: + +maintainer-clean: maintainer-clean-recursive + -rm -f $(am__CONFIG_DISTCLEAN_FILES) + -rm -rf $(top_srcdir)/autom4te.cache + -rm -f Makefile +maintainer-clean-am: distclean-am maintainer-clean-generic + +mostlyclean: mostlyclean-recursive + +mostlyclean-am: mostlyclean-compile mostlyclean-generic \ + mostlyclean-libtool + +pdf: pdf-recursive + +pdf-am: + +ps: ps-recursive + +ps-am: + +uninstall-am: uninstall-includeHEADERS uninstall-libLTLIBRARIES \ + uninstall-nodist_includeexecHEADERS + +.MAKE: $(am__recursive_targets) all check install install-am \ + install-data-am install-strip + +.PHONY: $(am__recursive_targets) CTAGS GTAGS TAGS all all-am \ + am--refresh check check-am clean clean-cscope clean-generic \ + clean-libLTLIBRARIES clean-libtool clean-local cscope \ + cscopelist-am ctags ctags-am dist dist-all dist-bzip2 \ + dist-gzip dist-hook dist-lzip dist-shar dist-tarZ dist-xz \ + dist-zip distcheck distclean distclean-compile \ + distclean-generic distclean-hdr distclean-libtool \ + distclean-local distclean-tags distcleancheck distdir \ + distuninstallcheck dvi dvi-am html html-am info info-am \ + install install-am install-data install-data-am \ + install-data-hook install-dvi install-dvi-am install-exec \ + install-exec-am install-html install-html-am \ + install-includeHEADERS install-info install-info-am \ + install-libLTLIBRARIES install-man \ + install-nodist_includeexecHEADERS install-pdf install-pdf-am \ + install-ps install-ps-am install-strip installcheck \ + installcheck-am installdirs installdirs-am maintainer-clean \ + maintainer-clean-generic mostlyclean mostlyclean-compile \ + mostlyclean-generic mostlyclean-libtool pdf pdf-am ps ps-am \ + tags tags-am uninstall uninstall-am uninstall-includeHEADERS \ + uninstall-libLTLIBRARIES uninstall-nodist_includeexecHEADERS + + +install-data-hook: + @echo '' + @echo '+-------------------------------------------------------------+' + @echo '| CAUTION: |' + @echo '| |' + @echo '| If you have not already run "make check", then we strongly |' + @echo '| recommend you do so. |' + @echo '| |' + @echo '| GMP has been carefully tested by its authors, but compilers |' + @echo '| are all too often released with serious bugs. GMP tends to |' + @echo '| explore interesting corners in compilers and has hit bugs |' + @echo '| on quite a few occasions. |' + @echo '| |' + @echo '+-------------------------------------------------------------+' + @echo '' + +fac_table.h: gen-fac$(EXEEXT_FOR_BUILD) + ./gen-fac $(GMP_LIMB_BITS) $(GMP_NAIL_BITS) >fac_table.h || (rm -f fac_table.h; exit 1) + +gen-fac$(EXEEXT_FOR_BUILD): gen-fac$(U_FOR_BUILD).c bootstrap.c + $(CC_FOR_BUILD) `test -f 'gen-fac$(U_FOR_BUILD).c' || echo '$(srcdir)/'`gen-fac$(U_FOR_BUILD).c -o gen-fac$(EXEEXT_FOR_BUILD) + +fib_table.h: gen-fib$(EXEEXT_FOR_BUILD) + ./gen-fib header $(GMP_LIMB_BITS) $(GMP_NAIL_BITS) >fib_table.h || (rm -f fib_table.h; exit 1) + +mpn/fib_table.c: gen-fib$(EXEEXT_FOR_BUILD) + ./gen-fib table $(GMP_LIMB_BITS) $(GMP_NAIL_BITS) >mpn/fib_table.c || (rm -f mpn/fib_table.c; exit 1) + +gen-fib$(EXEEXT_FOR_BUILD): gen-fib$(U_FOR_BUILD).c bootstrap.c + $(CC_FOR_BUILD) `test -f 'gen-fib$(U_FOR_BUILD).c' || echo '$(srcdir)/'`gen-fib$(U_FOR_BUILD).c -o gen-fib$(EXEEXT_FOR_BUILD) + +mp_bases.h: gen-bases$(EXEEXT_FOR_BUILD) + ./gen-bases header $(GMP_LIMB_BITS) $(GMP_NAIL_BITS) >mp_bases.h || (rm -f mp_bases.h; exit 1) + +mpn/mp_bases.c: gen-bases$(EXEEXT_FOR_BUILD) + ./gen-bases table $(GMP_LIMB_BITS) $(GMP_NAIL_BITS) >mpn/mp_bases.c || (rm -f mpn/mp_bases.c; exit 1) + +gen-bases$(EXEEXT_FOR_BUILD): gen-bases$(U_FOR_BUILD).c bootstrap.c + $(CC_FOR_BUILD) `test -f 'gen-bases$(U_FOR_BUILD).c' || echo '$(srcdir)/'`gen-bases$(U_FOR_BUILD).c -o gen-bases$(EXEEXT_FOR_BUILD) $(LIBM_FOR_BUILD) + +trialdivtab.h: gen-trialdivtab$(EXEEXT_FOR_BUILD) + ./gen-trialdivtab $(GMP_LIMB_BITS) 8000 >trialdivtab.h || (rm -f trialdivtab.h; exit 1) + +gen-trialdivtab$(EXEEXT_FOR_BUILD): gen-trialdivtab$(U_FOR_BUILD).c bootstrap.c + $(CC_FOR_BUILD) `test -f 'gen-trialdivtab$(U_FOR_BUILD).c' || echo '$(srcdir)/'`gen-trialdivtab$(U_FOR_BUILD).c -o gen-trialdivtab$(EXEEXT_FOR_BUILD) $(LIBM_FOR_BUILD) + +mpn/jacobitab.h: gen-jacobitab$(EXEEXT_FOR_BUILD) + ./gen-jacobitab >mpn/jacobitab.h || (rm -f mpn/jacobitab.h; exit 1) + +gen-jacobitab$(EXEEXT_FOR_BUILD): gen-jacobitab$(U_FOR_BUILD).c + $(CC_FOR_BUILD) `test -f 'gen-jacobitab$(U_FOR_BUILD).c' || echo '$(srcdir)/'`gen-jacobitab$(U_FOR_BUILD).c -o gen-jacobitab$(EXEEXT_FOR_BUILD) + +mpn/perfsqr.h: gen-psqr$(EXEEXT_FOR_BUILD) + ./gen-psqr $(GMP_LIMB_BITS) $(GMP_NAIL_BITS) >mpn/perfsqr.h || (rm -f mpn/perfsqr.h; exit 1) + +gen-psqr$(EXEEXT_FOR_BUILD): gen-psqr$(U_FOR_BUILD).c bootstrap.c + $(CC_FOR_BUILD) `test -f 'gen-psqr$(U_FOR_BUILD).c' || echo '$(srcdir)/'`gen-psqr$(U_FOR_BUILD).c -o gen-psqr$(EXEEXT_FOR_BUILD) $(LIBM_FOR_BUILD) + +# Avoid: CVS - cvs directories +# *~ - emacs backups +# .#* - cvs merge originals +# +# *~ and .#* only occur when a whole directory without it's own Makefile.am +# is distributed, like "doc" or the mpn cpu subdirectories. +# +dist-hook: + -find $(distdir) \( -name CVS -type d \) -o -name "*~" -o -name ".#*" \ + | xargs rm -rf + cp "$(srcdir)"/mini-gmp/tests/*.[ch] "$(distdir)/mini-gmp/tests" +# grep -F $(VERSION) $(srcdir)/Makefile.am \ +# | grep -q "^# *$(VERSION) *$(LIBGMP_LT_CURRENT):$(LIBGMP_LT_REVISION):$(LIBGMP_LT_AGE) *$(LIBGMPXX_LT_CURRENT):$(LIBGMPXX_LT_REVISION):$(LIBGMPXX_LT_AGE)" +# test -z "`sed -n 's/^# *[0-9]*\.[0-9]*\.[0-9]* *\([0-9]*:[0-9]*:[0-9]*\) *\([0-9]*:[0-9]*:[0-9]*\) *\([0-9]*:[0-9]*:[0-9]*\).*/A\1\nB\2\nC\3/p' $(srcdir)/Makefile.am | grep -v 'A6:3:3\|B3:5:0\|C4:7:1' | sort | uniq -d`" + +.PHONY: check-mini-gmp clean-mini-gmp + +check-mini-gmp: + abs_srcdir="`cd $(srcdir) && pwd`" ; \ + $(MKDIR_P) mini-gmp/tests \ + && cd mini-gmp/tests \ + && LD_LIBRARY_PATH="../../.libs:$$LD_LIBRARY_PATH" \ + DYLD_LIBRARY_PATH="../../.libs:$$DYLD_LIBRARY_PATH" \ + $(MAKE) -f "$$abs_srcdir/mini-gmp/tests/Makefile" \ + VPATH="$$abs_srcdir/mini-gmp/tests" \ + srcdir="$$abs_srcdir/mini-gmp/tests" \ + MINI_GMP_DIR="$$abs_srcdir/mini-gmp" \ + LDFLAGS="-L../../.libs" \ + LIBS="-lgmp -lm" \ + CC="$(CC_FOR_BUILD)" EXTRA_CFLAGS="-g -I../.." check + +clean-mini-gmp: + if [ -d mini-gmp/tests ] ; then \ + abs_srcdir="`cd $(srcdir) && pwd`" ; \ + cd mini-gmp/tests \ + && $(MAKE) -f "$$abs_srcdir/mini-gmp/tests/Makefile" clean ; \ + fi + +clean-local: clean-mini-gmp +distclean-local: clean-mini-gmp + +# Tell versions [3.59,3.63) of GNU make to not export all variables. +# Otherwise a system limit (for SysV at least) may be exceeded. +.NOEXPORT: diff --git a/gmp4/NEWS b/gmp4/NEWS new file mode 100644 index 0000000..f8c5229 --- /dev/null +++ b/gmp4/NEWS @@ -0,0 +1,891 @@ +Copyright 1996, 1999-2014 Free Software Foundation, Inc. + +Verbatim copying and distribution of this entire article is permitted in any +medium, provided this notice is preserved. + + +Changes between GMP version 5.1.* and 5.2.0 + + BUGS FIXED + * The function mpz_invert now considers any number invertible in Z/1Z. + + * The mpn multiply code now handles operands of more than 2^31 limbs + correctly. (Note however that the mpz code is limited to 2^32 bits on + 32-bit hosts and 2^37 bits on 64-bit hosts.) + + * Contains all fixes from release 5.1.3. + + SPEEDUPS + * Plain division of large operands is faster and more monotonous in operand + size. + + * Major speedup for ARM, in particular ARM Cortex-A15, thanks to improved + assembly. + + * Major speedup for SPARC T4/T5 and speedup also for T3, thanks to a lot of + new assembly. + + * Speedup for Intel Sandy Bridge, Ivy Bridge, Haswell, thanks to rewritten + and vastly expanded assembly support. Speedup also for the older Core 2 + and Nehalem. + + * Faster mixed arithmetic between mpq_class and double. + + * With g++, optimise more operations when one argument is a simple constant. + + FEATURES + * Support for new Intel and AMD CPUs. + + * Support for ARM64 alias Aarch64 alias ARMv8. + + * New public functions mpn_sec_mul and mpn_sec_sqr, implementing side-channel + silent multiplication and squaring. + + * New public functions mpn_sec_div_qr and mpn_sec_div_r, implementing + side-channel silent division. + + * New public functions mpn_cnd_add_n and mpn_cnd_sub_n. Side-channel silent + conditional addition and subtraction. + + * New public function mpn_sec_powm, implementing side-channel silent modexp. + + * New public function mpn_sec_invert, implementing side-channel silent + modular inversion. + + * Better support for applications which use the mpz_t type, but nevertheless + need to call some of the lower-level mpn functions. See the documentation + for mpz_limbs_read and related functions. + + MISC + * This release will not work on NetBSD 5.x, FreeBSD 7.x, 8.x or 9 series + before 9.3. The reason is that the m4 command is not correctly + implemented. (Workaround: Use an older GMP release, or install GNU m4 from + /usr/ports and tell GMP to use it.) + + * This release will not build properly on FreeBSD/amd64 before version 10 + using the 32-bit ABI (once a working m4 is installed). The reason is + broken limits.h. (Workaround: Use an older GMP release if using the 32-bit + ABI on these FreeBSD releases is important.) + + * This release will not work reliably on FreeBSD 10.0 for i386 or amd64 using + the 32-bit ABI. The reason is bugs in the compiler 'clang'. Depending on + CPU-dependent compiler flags, GMP may or may not be miscompiled in a + particular build. (Workaround: Compiling gcc from /usr/ports should work, + except that gcc circularly depends on GMP; we have not been able to test + that workaround due to FreeBSD 10.0 bugs affecting its ability to run under + KVM and Xen.) + + * This release will not compile on FreeBSD before version 10 for i386, + targeting any modern AMD processor. The reason is bugs in the old gcc + bundled with FreeBSD. (Workaround: install a less obsolete gcc from + /usr/ports and tell GMP to use it, or override the -march=amdfam10 + GMP configure command line argument.) + + +Changes between GMP version 5.1.2 and 5.1.3 + + BUGS FIXED + * The internal functions mpn_sbpi1_div_qr_sec mpn_sbpi1_div_r_sec could + compute garbage with a low probability. They are now rewritten, and the + test code has been improved. + + * A bug in the ia64 implementation of mpn_divrem_2, clobbering some + callee-save registers, has been fixed. This is an internal + function, with the bug manifesting itself as miscomputation in, + e.g., mpn_sqrtrem. + + * The documentation now correctly says 'const' for input arguments. + + SPEEDUPS + * None. + + FEATURES + * None. + + MISC + * None. + + +Changes between GMP version 5.1.1 and 5.1.2 + + BUGS FIXED + * A bug in mpz_powm_ui triggered by base arguments of at least 15000 decimal + digits or mod arguments of at least 7500 decimal digits has been fixed. + + * An AMD Bulldozer specific bug affecting the 64-bit Windows ABI has been + fixed. This bug was in a key function (mpn_mul_1) and made both Bulldozer + specific builds and fat builds run on Bulldozer completely non-functional. + + SPEEDUPS + * None. + + FEATURES + * None. + + MISC + * Fixes and generalisations to the test suite. + + * Minor portability enhancements. + + +Changes between GMP version 5.1.0 and 5.1.1 + + BUGS FIXED + * On Windows 64-bit, an error causing link errors about + __gmp_binvert_limb_table has been fixed. + + * Aarch64 alias ARM64 support now works. + + * A possible buffer overrun in mpz_ior has been fixed. + + * A rare sign flip in mpz_remove has been fixed. + + * A bug causing problems with mpf numbers with absolute value >= 2^31 has + been fixed. + + * Several bugs in mini-gmp have been fixed. + + * A bug caused by automake, related to the 'distcheck' target, has been fixed + by upgrading the automake used for GMP release engineering. + + SPEEDUPS + * None. + + FEATURES + * Preliminary support for the x32 ABI under x86-64. + + MISC + * The mini-gmp testsuite now tests the entire set of functions. + + * Various improvements of the GMP testsuite. + + +Changes between GMP version 5.0.* and 5.1.0 + + BUGS FIXED + * When reading a C++ number (like mpz_class) in an istream reaches the end + of the stream, the eofbit is now set. + + * The result sign of mpz_rootrem's remainder is now always correct. + + * The mpz_remove function now handles negative divisors. + + * Contains all fixes from release 5.0.5. + + SPEEDUPS + * The n-factorial and n-over-k functions have been reimplemented for great + speedups for small and large operands. + + * New subquadratic algorithm for the Kronecker/Jacobi/Legendre symbol. + + * Major speedup for ARM, in particular ARM Cortex-A9 and A15, thanks to broad + assembly support. + + * Significant speedup for POWER6 and POWER7 thanks to improved assembly. + + * The performance under M$ Windows' 64-bit ABI has been greatly improved + thanks to complete assembly support. + + * Minor speed improvements of many functions and for many platforms. + + FEATURES + * Many new CPUs recognised. + + * New functions for multi-factorials, and primorial: mpz_2fac_ui, + mpz_mfac_uiui and mpz_primorial_ui. + + * The mpz_powm_sec function now uses side-channel silent division for + converting into Montgomery residues. + + * The fat binary mechanism is now more robust in its CPU recognition. + + MISC + * Inclusion of assembly code is now controlled by the configure options + --enable-assembly and --disable-assembly. The "none" CPU target is gone. + + * In C++, the conversions mpq_class->mpz_class, mpf_class->mpz_class and + mpf_class->mpq_class are now explicit. + + * Includes "mini-gmp", a small, portable, but less efficient, implementation + of a subset of GMP's mpn and mpz interfaces. Used in GMP bootstrap, but it + can also be bundled with applications as a fallback when the real GMP + library is unavailable. + + * The ABIs under AIX are no longer called aix32 and aix64, but mode64 and 32. + This is more consistent with other powerpc systems. + + * The coverage of the testsuite has been improved, using the lcov tool. See + also https://gmplib.org/devel/lcov/. + + * It is now possible to compile GMP using a C++ compiler. + + * K&R C compilers are no longer supported. + + * The BSD MP compatibility functions have been removed. + + +Changes between GMP version 5.0.4 and 5.0.5 + + BUGS FIXED + * A bug causing AMD 11h processors to be treated like AMD 10h has been fixed. + The 11h processors do not correctly handle all 10h (aka K10) instructions, + and GMP's use of these instructions results in major miscomputations (not + as one would have hoped CPU traps of some 'illegal instruction' sort). + + * A bug affecting recent Intel Sandy Bridge CPUs resulting in configuration + failures has been fixed. + + SPEEDUPS + * None. + + FEATURES + * A couple of tests added to the self-check suite. + + MISC + * None. + + +Changes between GMP version 5.0.3 and 5.0.4 + + BUGS FIXED + * Thresholds in mpn_powm_sec for both fat and non-fat builds are now used + safely, plugging a one-word buffer overrun introduced in the 5.0.3 release + (for non-fat) and a multi-word buffer overrun that existed since 5.0 (for + fat). (We have not been able to provoke malign stack smashing in any of + the ~100 configurations explored by the GMP nightly builds, but the bug + should be assumed to be exploitable.) + + * Two bugs in multiplication code causing incorrect computation with + extremely low probability have been fixed. + + * A bug in the test suite causing buffer overruns during "make check", + sometimes leading to subsequent malloc crashes, has been fixed. + + * Two bugs in the gcd code have been fixed. They could lead to incorrect + results, but for uniformly distributed random operands, the likelihood for + that is infinitesimally small. (There was also a third bug, but that was + an incorrect ASSERT, which furthermore was not enabled by default.) + + * A bug affecting 32-bit PowerPC division has been fixed. The bug caused + miscomputation for certain divisors in the range 2^32 ... 2^64-1 (about 1 + in 2^30 of these). + + SPEEDUPS + * None, except indirectly through recognition of new CPUs, and through better + tuning parameters. + + FEATURES + * Some more tests added to the self-check suite. + + * The AMD "Bulldozer" CPU is now recognised. + + MISC + * None. + + +Changes between GMP version 5.0.2 and 5.0.3 + + BUGS FIXED + * A few minor bugs related to portability fixed. + + * A slight timing leak of the powm_sec functions have been sealed. (This + leak could possibly be used to extract the most significant few bits of the + exponent. "Few" here means at most 10.) + + * The mpz_nextprime function now runs a safer number of pseudo-random prime + tests. + + * A bug in division code possibly causing incorrect computation was fixed. + + SPEEDUPS + * None, except indirectly through recognition of new CPUs, and through better + tuning parameters. + + FEATURES + * New CPUs recognised. + + * IBM S/390 are now supported in both 31/32-bit and 64-bit mode. (We have + not been able to fully test this on any multilib machine, since IBM expired + our guest account a few days before our release.) + + MISC + * None. + + +Changes between GMP version 5.0.1 and 5.0.2 + + BUGS FIXED + * Many minor bugs related to portability fixed. + + * The support for HPPA 2.0N now works, after an assembly bug fix. + + * A test case type error has been fixed. The symptom of this bug was + spurious 'make check' failures. + + SPEEDUPS + * None, except indirectly through recognition of new CPUs. + + FEATURES + * Fat builds are now supported for 64-bit x86 processors also under Darwin. + + MISC + * None. + + +Changes between GMP version 5.0.0 and 5.0.1 + + BUGS FIXED + * Fat builds fixed. + + * Fixed crash for huge multiplies when old FFT_TABLE2 type of parameter + selection tables' sentinel was smaller than multiplied operands. + + * The solib numbers now reflect the removal of the documented but preliminary + mpn_bdivmod function; we correctly flag incompatibility with GMP 4.3. GMP + 5.0.0 has this wrong, and should perhaps be uninstalled to avoid confusion. + + SPEEDUPS + * Multiplication of large numbers has indirectly been sped up through better + FFT tuning and processor recognition. Since many operations depend on + multiplication, there will be a general speedup. + + FEATURES + * More Core i3, i5 an Core i7 processor models are recognised. + + * Fixes and workarounds for Mac OS quirks should make this GMP version build + using many of the different versions of "Xcode". + + MISC + * The amount of scratch memory needed for multiplication of huge numbers has + been reduced substantially (but is still larger than in GMP 4.3.) + + * Likewise, the amount of scratch memory needed for division of large numbers + has been reduced substantially. + + * The FFT tuning code of tune/tuneup.c has been completely rewritten, and + new, large FFT parameter selection tables are provided for many machines. + + * Upgraded to the latest autoconf, automake, libtool. + + +Changes between GMP version 4.3.X and 5.0.0 + + BUGS FIXED + * None (contains the same fixes as release 4.3.2). + + SPEEDUPS + * Multiplication has been overhauled: + (1) Multiplication of larger same size operands has been improved with + the addition of two new Toom functions and a new internal function + mpn_mulmod_bnm1 (computing U * V mod (B^n-1), B being the word base. + This latter function is used for the largest products, waiting for a + better Schoenhage-Strassen U * V mod (B^n+1) implementation. + (2) Likewise for squaring. + (3) Multiplication of different size operands has been improved with the + addition of many new Toom function, and by selecting underlying + functions better from the main multiply functions. + + * Division and mod have been overhauled: + (1) Plain "schoolbook" division is reimplemented using faster quotient + approximation. + (2) Division Q = N/D, R = N mod D where both the quotient and remainder + are needed now runs in time O(M(log(N))). This is an improvement of + a factor log(log(N)) + (3) Division where just the quotient is needed is now O(M(log(Q))) on + average. + (4) Modulo operations using Montgomery REDC form now take time O(M(n)). + (5) Exact division Q = N/D by means of mpz_divexact has been improved + for all sizes, and now runs in time O(M(log(N))). + + * The function mpz_powm is now faster for all sizes. Its complexity has + gone from O(M(n)log(n)m) to O(M(n)m) where n is the size of the modulo + argument and m is the size of the exponent. It is also radically + faster for even modulus, since it now partially factors such modulus + and performs two smaller modexp operations, then uses CRT. + + * The internal support for multiplication yielding just the lower n limbs + has been improved by using Mulders' algorithm. + + * Computation of inverses, both plain 1/N and 1/N mod B^n have been + improved by using well-tuned Newton iterations, and wrap-around + multiplication using mpn_mulmod_bnm1. + + * A new algorithm makes mpz_perfect_power_p asymptotically faster. + + * The function mpz_remove uses a much faster algorithm, is better tuned, + and also benefits from the division improvements. + + * Intel Atom and VIA Nano specific optimisations. + + * Plus hundreds of smaller improvements and tweaks! + + FEATURES + * New mpz function: mpz_powm_sec for side-channel quiet modexp + computations. + + * New mpn functions: mpn_sqr, mpn_and_n, mpn_ior_n, mpn_xor_n, mpn_nand_n, + mpn_nior_n, mpn_xnor_n, mpn_andn_n, mpn_iorn_n, mpn_com, mpn_neg, + mpn_copyi, mpn_copyd, mpn_zero. + + * The function mpn_tdiv_qr now allows certain argument overlap. + + * Support for fat binaries for 64-bit x86 processors has been added. + + * A new type, mp_bitcnt_t for bignum bit counts, has been introduced. + + * Support for Windows64 through mingw64 has been added. + + * The cofactors of mpz_gcdext and mpn_gcdext are now more strictly + normalised, returning to how GMP 4.2 worked. (Note that also release + 4.3.2 has this change.) + + MISC + * The mpn_mul function should no longer be used for squaring, + instead use the new mpn_sqr. + + * The algorithm selection has been improved, the number of thresholds have + more than doubled, and the tuning and use of existing thresholds have + been improved. + + * The tune/speed program can measure many of new functions. + + * The mpn_bdivmod function has been removed. We do not consider this an + incompatible change, since the function was marked as preliminary. + + * The testsuite has been enhanced in various ways. + + +Changes between GMP version 4.3.1 and 4.3.2 + + Bugs: + * Fixed bug in mpf_eq. + * Fixed overflow issues in mpz_set_str, mpz_inp_str, mpf_set_str, and + mpf_get_str. + * Avoid unbounded stack allocation for unbalanced multiplication. + * Fixed bug in FFT multiplication. + + Speedups: + * None, except that proper processor recognition helps affected processors. + + Features: + * Recognise more "Core 2" processor variants. + * The cofactors of mpz_gcdext and mpn_gcdext are now more strictly + normalised, returning to how GMP 4.2 worked. + + +Changes between GMP version 4.3.0 and 4.3.1 + + Bugs: + * Fixed bug in mpn_gcdext, affecting also mpz_gcdext and mpz_invert. + The bug could cause a cofactor to have a leading zero limb, which + could lead to crashes or miscomputation later on. + * Fixed some minor documentation issues. + + Speedups: + * None. + + Features: + * Workarounds for various issues with Mac OS X's build tools. + * Recognise more IBM "POWER" processor variants. + + +Changes between GMP version 4.2.X and 4.3.0 + + Bugs: + * Fixed bug in mpz_perfect_power_p with recognition of negative perfect + powers that can be written both as an even and odd power. + * We might accidentally have added bugs since there is a large amount of + new code in this release. + + Speedups: + * Vastly improved assembly code for x86-64 processors from AMD and Intel. + * Major improvements also for many other processor families, such as + Alpha, PowerPC, and Itanium. + * New sub-quadratic mpn_gcd and mpn_gcdext, as well as improved basecase + gcd code. + * The multiply FFT code has been slightly improved. + * Balanced multiplication now uses 4-way Toom in addition to schoolbook, + Karatsuba, 3-way Toom, and FFT. + * Unbalanced multiplication has been vastly improved. + * Improved schoolbook division by means of faster quotient approximation. + * Several new algorithms for division and mod by single limbs, giving + many-fold speedups. + * Improved nth root computations. + * The mpz_nextprime function uses sieving and is much faster. + * Countless minor tweaks. + + Features: + * Updated support for fat binaries for x86_32 include current processors + * Lots of new mpn internal interfaces. Some of them will become public + in a future GMP release. + * Support for the 32-bit ABI under x86-apple-darwin. + * x86 CPU recognition code should now default better for future + processors. + * The experimental nails feature does not work in this release, but + it might be re-enabled in the future. + + Misc: + * The gmp_version variable now always contains three parts. For this + release, it is "4.3.0". + + +Changes between GMP version 4.2.3 and 4.2.4 + + Bugs: + * Fix bug with parsing exponent '+' sign in mpf. + * Fix an allocation bug in mpf_set_str, also affecting mpf_init_set_str, and + mpf_inp_str. + + Speedups: + * None, except that proper processor recognition helps affected processors. + + Features: + * Recognize new AMD processors. + + +Changes between GMP version 4.2.2 and 4.2.3 + + Bugs: + * Fix x86 CPU recognition code to properly identify recent AMD and Intel + 64-bit processors. + * The >> operator of the C++ wrapper gmpxx.h now does floor rounding, not + truncation. + * Inline semantics now follow the C99 standard, and works with recent GCC + releases. + * C++ bitwise logical operations work for more types. + * For C++, gmp.h now includes cstdio, improving compiler compatibility. + * Bases > 36 now work properly in mpf_set_str. + + Speedups: + * None, except that proper processor recognition helps affected processors. + + Features: + * The allocation functions now detect overflow of the mpz_t type. This means + that overflow will now cause an abort, except when the allocation + computation itself overflows. (Such overflow can probably only happen in + powering functions; we will detect powering overflow in the future.) + + +Changes between GMP version 4.2.1 and 4.2.2 + + * License is now LGPL version 3. + + Bugs: + * Shared library numbers corrected for libcxx. + * Fixed serious bug in gmpxx.h where a=a+b*c would generate garbage. + Note that this only affects C++ programs. + * Fix crash in mpz_set_d for arguments with large negative exponent. + * Fix 32-bit ABI bug with Itanium assembly for popcount and hamdist. + * Fix assembly syntax problem for powerpc-ibm-aix with AIX native assembler. + * Fix problems with x86 --enable-fat, where the compiler where told to + generate code for the build machine, not plain i386 code as it should. + * Improved recognition of powerpc systems wrt Altivec/VMX capability. + * Misc minor fixes, mainly workarounds for compiler/assembler bugs. + + Speedups: + * "Core 2" and Pentium 4 processors, running in 64-bit mode will get a + slight boost as they are now specifically recognized. + + Features: + * New support for x86_64-solaris + * New, rudimentary support for x86-apple-darwin and x86_64-apple-darwin. + (Please see https://gmplib.org/macos.html for more information.) + + +Changes between GMP version 4.2 and 4.2.1 + + Bugs: + * Shared library numbers corrected. + * Broken support for 32-bit AIX fixed. + * Misc minor fixes. + + Speedups: + * Exact division (mpz_divexact) now falls back to plain division for large + operands. + + Features: + * Support for some new systems. + + +Changes between GMP version 4.1.4 and 4.2 + + Bugs: + * Minor bug fixes and code generalizations. + * Expanded and improved test suite. + + Speedups: + * Many minor optimizations, too many to mention here. + * Division now always subquadratic. + * Computation of n-factorial much faster. + * Added basic x86-64 assembly code. + * Floating-point output is now subquadratic for all bases. + * FFT multiply code now about 25% faster. + * Toom3 multiply code faster. + + Features: + * Much improved configure. + * Workarounds for many more compiler bugs. + * Temporary allocations are now made on the stack only if small. + * New systems supported: HPPA-2.0 gcc, IA-64 HP-UX, PowerPC-64 Darwin, + Sparc64 GNU/Linux. + * New i386 fat binaries, selecting optimised code at runtime (--enable-fat). + * New build option: --enable-profiling=instrument. + * New memory function: mp_get_memory_functions. + * New Mersenne Twister random numbers: gmp_randinit_mt, also now used for + gmp_randinit_default. + * New random functions: gmp_randinit_set, gmp_urandomb_ui, gmp_urandomm_ui. + * New integer functions: mpz_combit, mpz_rootrem. + * gmp_printf etc new type "M" for mp_limb_t. + * gmp_scanf and friends now accept C99 hex floats. + * Numeric input and output can now be in bases up to 62. + * Comparisons mpz_cmp_d, mpz_cmpabs_d, mpf_cmp_d recognise infinities. + * Conversions mpz_get_d, mpq_get_d, mpf_get_d truncate towards zero, + previously their behaviour was unspecified. + * Fixes for overflow issues with operands >= 2^31 bits. + + Caveats: + * mpfr is gone, and will from now on be released only separately. Please see + www.mpfr.org. + + +Changes between GMP version 4.1.3 and 4.1.4 + +* Bug fix to FFT multiplication code (crash for huge operands). +* Bug fix to mpf_sub (miscomputation). +* Support for powerpc64-gnu-linux. +* Better support for AMD64 in 32-bit mode. +* Upwardly binary compatible with 4.1.3, 4.1.2, 4.1.1, 4.1, 4.0.1, 4.0, + and 3.x versions. + + +Changes between GMP version 4.1.2 and 4.1.3 + +* Bug fix for FFT multiplication code (miscomputation). +* Bug fix to K6 assembly code for gcd. +* Bug fix to IA-64 assembly code for population count. +* Portability improvements, most notably functional AMD64 support. +* mpz_export allows NULL for countp parameter. +* Many minor bug fixes. +* mpz_export allows NULL for countp parameter. +* Upwardly binary compatible with 4.1.2, 4.1.1, 4.1, 4.0.1, 4.0, and 3.x + versions. + + +Changes between GMP version 4.1.1 and 4.1.2 + +* Bug fixes. + + +Changes between GMP version 4.1 and 4.1.1 + +* Bug fixes. +* New systems supported: NetBSD and OpenBSD sparc64. + + +Changes between GMP version 4.0.1 and 4.1 + +* Bug fixes. +* Speed improvements. +* Upwardly binary compatible with 4.0, 4.0.1, and 3.x versions. +* Asymptotically fast conversion to/from strings (mpz, mpq, mpn levels), but + also major speed improvements for tiny operands. +* mpn_get_str parameter restrictions relaxed. +* Major speed improvements for HPPA 2.0 systems. +* Major speed improvements for UltraSPARC systems. +* Major speed improvements for IA-64 systems (but still sub-optimal code). +* Extended test suite. +* mpfr is back, with many bug fixes and portability improvements. +* New function: mpz_ui_sub. +* New functions: mpz_export, mpz_import. +* Optimization for nth root functions (mpz_root, mpz_perfect_power_p). +* Optimization for extended gcd (mpz_gcdext, mpz_invert, mpn_gcdext). +* Generalized low-level number format, reserving a `nails' part of each + limb. (Please note that this is really experimental; some functions + are likely to compute garbage when nails are enabled.) +* Nails-enabled Alpha 21264 assembly code, allowing up to 75% better + performance. (Use --enable-nails=4 to enable it.) + + +Changes between GMP version 4.0 and 4.0.1 + +* Bug fixes. + + +Changes between GMP version 3.1.1 and 4.0 + +* Bug fixes. +* Speed improvements. +* Upwardly binary compatible with 3.x versions. +* New CPU support: IA-64, Pentium 4. +* Improved CPU support: 21264, Cray vector systems. +* Support for all MIPS ABIs: o32, n32, 64. +* New systems supported: Darwin, SCO, Windows DLLs. +* New divide-and-conquer square root algorithm. +* New algorithms chapter in the manual. +* New malloc reentrant temporary memory method. +* New C++ class interface by Gerardo Ballabio (beta). +* Revamped configure, featuring ABI selection. +* Speed improvements for mpz_powm and mpz_powm_ui (mainly affecting small + operands). +* mpz_perfect_power_p now properly recognizes 0, 1, and negative perfect + powers. +* mpz_hamdist now supports negative operands. +* mpz_jacobi now accepts non-positive denominators. +* mpz_powm now supports negative exponents. +* mpn_mul_1 operand overlap requirements relaxed. +* Float input and output uses locale specific decimal point where available. +* New gmp_printf, gmp_scanf and related functions. +* New division functions: mpz_cdiv_q_2exp, mpz_cdiv_r_2exp, mpz_divexact_ui. +* New divisibility tests: mpz_divisible_p, mpz_divisible_ui_p, + mpz_divisible_2exp_p, mpz_congruent_p, mpz_congruent_ui_p, + mpz_congruent_2exp_p. +* New Fibonacci function: mpz_fib2_ui. +* New Lucas number functions: mpz_lucnum_ui, mpz_lucnum2_ui. +* Other new integer functions: mpz_cmp_d, mpz_cmpabs_d, mpz_get_d_2exp, + mpz_init2, mpz_kronecker, mpz_lcm_ui, mpz_realloc2. +* New rational I/O: mpq_get_str, mpq_inp_str, mpq_out_str, mpq_set_str. +* Other new rational functions: mpq_abs, mpq_cmp_si, mpq_div_2exp, + mpq_mul_2exp, mpq_set_f. +* New float tests: mpf_integer_p, mpf_fits_sint_p, mpf_fits_slong_p, + mpf_fits_sshort_p, mpf_fits_uint_p, mpf_fits_ulong_p, mpf_fits_ushort_p. +* Other new float functions: mpf_cmp_d, mpf_get_default_prec, mpf_get_si, + mpf_get_ui, mpf_get_d_2exp. +* New random functions: gmp_randinit_default, gmp_randinit_lc_2exp_size. +* New demo expression string parser (see demos/expr). +* New preliminary perl interface (see demos/perl). +* Tuned algorithm thresholds for many more CPUs. + + +Changes between GMP version 3.1 and 3.1.1 + +* Bug fixes for division (rare), mpf_get_str, FFT, and miscellaneous minor + things. + + +Changes between GMP version 3.0 and 3.1 + +* Bug fixes. +* Improved `make check' running more tests. +* Tuned algorithm cutoff points for many machines. This will improve speed for + a lot of operations, in some cases by a large amount. +* Major speed improvements: Alpha 21264. +* Some speed improvements: Cray vector computers, AMD K6 and Athlon, Intel P5 + and Pentium Pro/II/III. +* The mpf_get_prec function now works as it did in GMP 2. +* New utilities for auto-tuning and speed measuring. +* Multiplication now optionally uses FFT for very large operands. (To enable + it, pass --enable-fft to configure.) +* Support for new systems: Solaris running on x86, FreeBSD 5, HP-UX 11, Cray + vector computers, Rhapsody, Nextstep/Openstep, MacOS. +* Support for shared libraries on 32-bit HPPA. +* New integer functions: mpz_mul_si, mpz_odd_p, mpz_even_p. +* New Kronecker symbol functions: mpz_kronecker_si, mpz_kronecker_ui, + mpz_si_kronecker, mpz_ui_kronecker. +* New rational functions: mpq_out_str, mpq_swap. +* New float functions: mpf_swap. +* New mpn functions: mpn_divexact_by3c, mpn_tdiv_qr. +* New EXPERIMENTAL function layer for accurate floating-point arithmetic, mpfr. + To try it, pass --enable-mpfr to configure. See the mpfr subdirectory for + more information; it is not documented in the main GMP manual. + + +Changes between GMP version 3.0 and 3.0.1 + +* Memory leaks in gmp_randinit and mpz_probab_prime_p fixed. +* Documentation for gmp_randinit fixed. Misc documentation errors fixed. + + +Changes between GMP version 2.0 and 3.0 + +* Source level compatibility with past releases (except mpn_gcd). +* Bug fixes. +* Much improved speed thanks to both host independent and host dependent + optimizations. +* Switch to autoconf/automake/libtool. +* Support for building libgmp as a shared library. +* Multiplication and squaring using 3-way Toom-Cook. +* Division using the Burnikel-Ziegler method. +* New functions computing binomial coefficients: mpz_bin_ui, mpz_bin_uiui. +* New function computing Fibonacci numbers: mpz_fib_ui. +* New random number generators: mpf_urandomb, mpz_rrandomb, mpz_urandomb, + mpz_urandomm, gmp_randclear, gmp_randinit, gmp_randinit_lc_2exp, + gmp_randseed, gmp_randseed_ui. +* New function for quickly extracting limbs: mpz_getlimbn. +* New functions performing integer size tests: mpz_fits_sint_p, + mpz_fits_slong_p, mpz_fits_sshort_p, mpz_fits_uint_p, mpz_fits_ulong_p, + mpz_fits_ushort_p. +* New mpf functions: mpf_ceil, mpf_floor, mpf_pow_ui, mpf_trunc. +* New mpq function: mpq_set_d. +* New mpz functions: mpz_addmul_ui, mpz_cmpabs, mpz_cmpabs_ui, mpz_lcm, + mpz_nextprime, mpz_perfect_power_p, mpz_remove, mpz_root, mpz_swap, + mpz_tdiv_ui, mpz_tstbit, mpz_xor. +* New mpn function: mpn_divexact_by3. +* New CPU support: DEC Alpha 21264, AMD K6 and Athlon, HPPA 2.0 and 64, + Intel Pentium Pro and Pentium-II/III, Sparc 64, PowerPC 64. +* Almost 10 times faster mpz_invert and mpn_gcdext. +* The interface of mpn_gcd has changed. +* Better support for MIPS R4x000 and R5000 under Irix 6. +* Improved support for SPARCv8 and SPARCv9 processors. + + +Changes between GMP version 2.0 and 2.0.2 + +* Many bug fixes. + + +Changes between GMP version 1.3.2 and 2.0 + +* Division routines in the mpz class have changed. There are three classes of + functions, that rounds the quotient to -infinity, 0, and +infinity, + respectively. The first class of functions have names that begin with + mpz_fdiv (f is short for floor), the second class' names begin with mpz_tdiv + (t is short for trunc), and the third class' names begin with mpz_cdiv (c is + short for ceil). + + The old division routines beginning with mpz_m are similar to the new + mpz_fdiv, with the exception that some of the new functions return useful + values. + + The old function names can still be used. All the old functions names will + now do floor division, not trunc division as some of them used to. This was + changed to make the functions more compatible with common mathematical + practice. + + The mpz_mod and mpz_mod_ui functions now compute the mathematical mod + function. I.e., the sign of the 2nd argument is ignored. + +* The mpq assignment functions do not canonicalize their results. A new + function, mpq_canonicalize must be called by the user if the result is not + known to be canonical. +* The mpn functions are now documented. These functions are intended for + very time critical applications, or applications that need full control over + memory allocation. Note that the mpn interface is irregular and hard to + use. +* New functions for arbitrary precision floating point arithmetic. Names + begin with `mpf_'. Associated type mpf_t. +* New and improved mpz functions, including much faster GCD, fast exact + division (mpz_divexact), bit scan (mpz_scan0 and mpz_scan1), and number + theoretical functions like Jacobi (mpz_jacobi) and multiplicative inverse + (mpz_invert). +* New variable types (mpz_t and mpq_t) are available that makes syntax of + mpz and mpq calls nicer (no need for & before variables). The MP_INT and + MP_RAT types are still available for compatibility. +* Uses GNU configure. This makes it possible to choose target architecture + and CPU variant, and to compile into a separate object directory. +* Carefully optimized assembly for important inner loops. Support for DEC + Alpha, Amd 29000, HPPA 1.0 and 1.1, Intel Pentium and generic x86, Intel + i960, Motorola MC68000, MC68020, MC88100, and MC88110, Motorola/IBM + PowerPC, National NS32000, IBM POWER, MIPS R3000, R4000, SPARCv7, + SuperSPARC, generic SPARCv8, and DEC VAX. Some support also for ARM, + Clipper, IBM ROMP (RT), and Pyramid AP/XP. +* Faster. Thanks to the assembler code, new algorithms, and general tuning. + In particular, the speed on machines without GCC is improved. +* Support for machines without alloca. +* Now under the LGPL. + +INCOMPATIBILITIES BETWEEN GMP 1 AND GMP 2 + +* mpq assignment functions do not canonicalize their results. +* mpz division functions round differently. +* mpz mod functions now really compute mod. +* mpz_powm and mpz_powm_ui now really use mod for reduction. diff --git a/gmp4/README b/gmp4/README new file mode 100644 index 0000000..013899d --- /dev/null +++ b/gmp4/README @@ -0,0 +1,116 @@ +Copyright 1991, 1996, 1999, 2000, 2007 Free Software Foundation, Inc. + +This file is part of the GNU MP Library. + +The GNU MP Library is free software; you can redistribute it and/or modify +it under the terms of either: + + * the GNU Lesser General Public License as published by the Free + Software Foundation; either version 3 of the License, or (at your + option) any later version. + +or + + * the GNU General Public License as published by the Free Software + Foundation; either version 2 of the License, or (at your option) any + later version. + +or both in parallel, as here. + +The GNU MP Library is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received copies of the GNU General Public License and the +GNU Lesser General Public License along with the GNU MP Library. If not, +see https://www.gnu.org/licenses/. + + + + + + + THE GNU MP LIBRARY + + +GNU MP is a library for arbitrary precision arithmetic, operating on signed +integers, rational numbers, and floating point numbers. It has a rich set of +functions, and the functions have a regular interface. + +GNU MP is designed to be as fast as possible, both for small operands and huge +operands. The speed is achieved by using fullwords as the basic arithmetic +type, by using fast algorithms, with carefully optimized assembly code for the +most common inner loops for lots of CPUs, and by a general emphasis on speed +(instead of simplicity or elegance). + +GNU MP is believed to be faster than any other similar library. Its advantage +increases with operand sizes for certain operations, since GNU MP in many +cases has asymptotically faster algorithms. + +GNU MP is free software and may be freely copied on the terms contained in the +files COPYING* (see the manual for information on which license(s) applies to +which components of GNU MP). + + + + OVERVIEW OF GNU MP + +There are five classes of functions in GNU MP. + + 1. Signed integer arithmetic functions (mpz). These functions are intended + to be easy to use, with their regular interface. The associated type is + `mpz_t'. + + 2. Rational arithmetic functions (mpq). For now, just a small set of + functions necessary for basic rational arithmetics. The associated type + is `mpq_t'. + + 3. Floating-point arithmetic functions (mpf). If the C type `double' + doesn't give enough precision for your application, declare your + variables as `mpf_t' instead, set the precision to any number desired, + and call the functions in the mpf class for the arithmetic operations. + + 4. Positive-integer, hard-to-use, very low overhead functions are in the + mpn class. No memory management is performed. The caller must ensure + enough space is available for the results. The set of functions is not + regular, nor is the calling interface. These functions accept input + arguments in the form of pairs consisting of a pointer to the least + significant word, and an integral size telling how many limbs (= words) + the pointer points to. + + Almost all calculations, in the entire package, are made by calling these + low-level functions. + + 5. Berkeley MP compatible functions. + + To use these functions, include the file "mp.h". You can test if you are + using the GNU version by testing if the symbol __GNU_MP__ is defined. + +For more information on how to use GNU MP, please refer to the documentation. +It is composed from the file doc/gmp.texi, and can be displayed on the screen +or printed. How to do that, as well how to build the library, is described in +the INSTALL file in this directory. + + + + REPORTING BUGS + +If you find a bug in the library, please make sure to tell us about it! + +You should first check the GNU MP web pages at https://gmplib.org/, under +"Status of the current release". There will be patches for all known serious +bugs there. + +Report bugs to gmp-bugs@gmplib.org. What information is needed in a useful bug +report is described in the manual. The same address can be used for suggesting +modifications and enhancements. + + + + +---------------- +Local variables: +mode: text +fill-column: 78 +End: diff --git a/gmp4/acinclude.m4 b/gmp4/acinclude.m4 new file mode 100644 index 0000000..227712a --- /dev/null +++ b/gmp4/acinclude.m4 @@ -0,0 +1,3984 @@ +dnl GMP specific autoconf macros + + +dnl Copyright 2000-2006, 2009, 2011, 2013, 2014 Free Software Foundation, Inc. +dnl +dnl This file is part of the GNU MP Library. +dnl +dnl The GNU MP Library is free software; you can redistribute it and/or modify +dnl it under the terms of either: +dnl +dnl * the GNU Lesser General Public License as published by the Free +dnl Software Foundation; either version 3 of the License, or (at your +dnl option) any later version. +dnl +dnl or +dnl +dnl * the GNU General Public License as published by the Free Software +dnl Foundation; either version 2 of the License, or (at your option) any +dnl later version. +dnl +dnl or both in parallel, as here. +dnl +dnl The GNU MP Library is distributed in the hope that it will be useful, but +dnl WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +dnl or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +dnl for more details. +dnl +dnl You should have received copies of the GNU General Public License and the +dnl GNU Lesser General Public License along with the GNU MP Library. If not, +dnl see https://www.gnu.org/licenses/. + + +dnl Some tests use, or must delete, the default compiler output. The +dnl possible filenames are based on what autoconf looks for, namely +dnl +dnl a.out - normal unix style +dnl b.out - i960 systems, including gcc there +dnl a.exe - djgpp +dnl a_out.exe - OpenVMS DEC C called via GNV wrapper (gnv.sourceforge.net) +dnl conftest.exe - various DOS compilers + + +define(IA64_PATTERN, +[[ia64*-*-* | itanium-*-* | itanium2-*-*]]) + +dnl Need to be careful not to match m6811, m6812, m68hc11 and m68hc12, all +dnl of which config.sub accepts. (Though none of which are likely to work +dnl with GMP.) +dnl +define(M68K_PATTERN, +[[m68k-*-* | m68[0-9][0-9][0-9]-*-*]]) + +define(POWERPC64_PATTERN, +[[powerpc64-*-* | powerpc64le-*-* | powerpc620-*-* | powerpc630-*-* | powerpc970-*-* | power[3-9]-*-*]]) + +define(S390_PATTERN, +[[s390-*-* | z900esa-*-* | z990esa-*-* | z9esa-*-* | z10esa-*-* | z196esa-*-*]]) + +define(S390X_PATTERN, +[[s390x-*-* | z900-*-* | z990-*-* | z9-*-* | z10-*-* | z196-*-*]]) + +define(X86_PATTERN, +[[i?86*-*-* | k[5-8]*-*-* | pentium*-*-* | athlon-*-* | viac3*-*-* | geode*-*-* | atom-*-*]]) + +define(X86_64_PATTERN, +[[athlon64-*-* | k8-*-* | k10-*-* | bobcat-*-* | jaguar-*-* | bulldozer-*-* | piledriver-*-* | steamroller-*-* | excavator-*-* | pentium4-*-* | atom-*-* | core2-*-* | corei*-*-* | x86_64-*-* | nano-*-*]]) + +dnl GMP_FAT_SUFFIX(DSTVAR, DIRECTORY) +dnl --------------------------------- +dnl Emit code to set shell variable DSTVAR to the suffix for a fat binary +dnl routine from DIRECTORY. DIRECTORY can be a shell expression like $foo +dnl etc. +dnl +dnl The suffix is directory separators / or \ changed to underscores, and +dnl if there's more than one directory part, then the first is dropped. +dnl +dnl For instance, +dnl +dnl x86 -> x86 +dnl x86/k6 -> k6 +dnl x86/k6/mmx -> k6_mmx + +define(GMP_FAT_SUFFIX, +[[$1=`echo $2 | sed -e '/\//s:^[^/]*/::' -e 's:[\\/]:_:g'`]]) + + +dnl GMP_REMOVE_FROM_LIST(listvar,item) +dnl ---------------------------------- +dnl Emit code to remove any occurrence of ITEM from $LISTVAR. ITEM can be a +dnl shell expression like $foo if desired. + +define(GMP_REMOVE_FROM_LIST, +[remove_from_list_tmp= +for remove_from_list_i in $[][$1]; do + if test $remove_from_list_i = [$2]; then :; + else + remove_from_list_tmp="$remove_from_list_tmp $remove_from_list_i" + fi +done +[$1]=$remove_from_list_tmp +]) + + +dnl GMP_STRIP_PATH(subdir) +dnl ---------------------- +dnl Strip entries */subdir from $path and $fat_path. + +define(GMP_STRIP_PATH, +[GMP_STRIP_PATH_VAR(path, [$1]) +GMP_STRIP_PATH_VAR(fat_path, [$1]) +]) + +define(GMP_STRIP_PATH_VAR, +[tmp_path= +for i in $[][$1]; do + case $i in + */[$2]) ;; + *) tmp_path="$tmp_path $i" ;; + esac +done +[$1]="$tmp_path" +]) + + +dnl GMP_INCLUDE_GMP_H +dnl ----------------- +dnl Expand to the right way to #include gmp-h.in. This must be used +dnl instead of gmp.h, since that file isn't generated until the end of the +dnl configure. +dnl +dnl Dummy value for GMP_LIMB_BITS is enough +dnl for all current configure-time uses of gmp.h. + +define(GMP_INCLUDE_GMP_H, +[[#define __GMP_WITHIN_CONFIGURE 1 /* ignore template stuff */ +#define GMP_NAIL_BITS $GMP_NAIL_BITS +#define GMP_LIMB_BITS 123 +$DEFN_LONG_LONG_LIMB +#include "$srcdir/gmp-h.in"] +]) + + +dnl GMP_HEADER_GETVAL(NAME,FILE) +dnl ---------------------------- +dnl Expand at autoconf time to the value of a "#define NAME" from the given +dnl FILE. The regexps here aren't very rugged, but are enough for gmp. +dnl /dev/null as a parameter prevents a hang if $2 is accidentally omitted. + +define(GMP_HEADER_GETVAL, +[patsubst(patsubst( +esyscmd([grep "^#define $1 " $2 /dev/null 2>/dev/null]), +[^.*$1[ ]+],[]), +[[ + ]*$],[])]) + + +dnl GMP_VERSION +dnl ----------- +dnl The gmp version number, extracted from the #defines in gmp-h.in at +dnl autoconf time. Two digits like 3.0 if patchlevel <= 0, or three digits +dnl like 3.0.1 if patchlevel > 0. + +define(GMP_VERSION, +[GMP_HEADER_GETVAL(__GNU_MP_VERSION,gmp-h.in)[]dnl +.GMP_HEADER_GETVAL(__GNU_MP_VERSION_MINOR,gmp-h.in)[]dnl +.GMP_HEADER_GETVAL(__GNU_MP_VERSION_PATCHLEVEL,gmp-h.in)]) + + +dnl GMP_SUBST_CHECK_FUNCS(func,...) +dnl ------------------------------ +dnl Setup an AC_SUBST of HAVE_FUNC_01 for each argument. + +AC_DEFUN([GMP_SUBST_CHECK_FUNCS], +[m4_if([$1],,, +[_GMP_SUBST_CHECK_FUNCS(ac_cv_func_[$1],HAVE_[]m4_translit([$1],[a-z],[A-Z])_01) +GMP_SUBST_CHECK_FUNCS(m4_shift($@))])]) + +dnl Called: _GMP_SUBST_CHECK_FUNCS(cachevar,substvar) +AC_DEFUN([_GMP_SUBST_CHECK_FUNCS], +[case $[$1] in +yes) AC_SUBST([$2],1) ;; +no) [$2]=0 ;; +esac +]) + + +dnl GMP_SUBST_CHECK_HEADERS(foo.h,...) +dnl ---------------------------------- +dnl Setup an AC_SUBST of HAVE_FOO_H_01 for each argument. + +AC_DEFUN([GMP_SUBST_CHECK_HEADERS], +[m4_if([$1],,, +[_GMP_SUBST_CHECK_HEADERS(ac_cv_header_[]m4_translit([$1],[./],[__]), +HAVE_[]m4_translit([$1],[a-z./],[A-Z__])_01) +GMP_SUBST_CHECK_HEADERS(m4_shift($@))])]) + +dnl Called: _GMP_SUBST_CHECK_HEADERS(cachevar,substvar) +AC_DEFUN([_GMP_SUBST_CHECK_HEADERS], +[case $[$1] in +yes) AC_SUBST([$2],1) ;; +no) [$2]=0 ;; +esac +]) + + +dnl GMP_COMPARE_GE(A1,B1, A2,B2, ...) +dnl --------------------------------- +dnl Compare two version numbers A1.A2.etc and B1.B2.etc. Set +dnl $gmp_compare_ge to yes or no according to the result. The A parts +dnl should be variables, the B parts fixed numbers. As many parts as +dnl desired can be included. An empty string in an A part is taken to be +dnl zero, the B parts should be non-empty and non-zero. +dnl +dnl For example, +dnl +dnl GMP_COMPARE($major,10, $minor,3, $subminor,1) +dnl +dnl would test whether $major.$minor.$subminor is greater than or equal to +dnl 10.3.1. + +AC_DEFUN([GMP_COMPARE_GE], +[gmp_compare_ge=no +GMP_COMPARE_GE_INTERNAL($@) +]) + +AC_DEFUN([GMP_COMPARE_GE_INTERNAL], +[ifelse(len([$3]),0, +[if test -n "$1" && test "$1" -ge $2; then + gmp_compare_ge=yes +fi], +[if test -n "$1"; then + if test "$1" -gt $2; then + gmp_compare_ge=yes + else + if test "$1" -eq $2; then + GMP_COMPARE_GE_INTERNAL(m4_shift(m4_shift($@))) + fi + fi +fi]) +]) + + +dnl GMP_PROG_AR +dnl ----------- +dnl GMP additions to $AR. +dnl +dnl A cross-"ar" may be necessary when cross-compiling since the build +dnl system "ar" might try to interpret the object files to build a symbol +dnl table index, hence the use of AC_CHECK_TOOL. +dnl +dnl A user-selected $AR is always left unchanged. AC_CHECK_TOOL is still +dnl run to get the "checking" message printed though. +dnl +dnl If extra flags are added to AR, then ac_cv_prog_AR and +dnl ac_cv_prog_ac_ct_AR are set too, since libtool (cvs 2003-03-31 at +dnl least) will do an AC_CHECK_TOOL and that will AR from one of those two +dnl cached variables. (ac_cv_prog_AR is used if there's an ac_tool_prefix, +dnl or ac_cv_prog_ac_ct_AR is used otherwise.) FIXME: This is highly +dnl dependent on autoconf internals, perhaps it'd work to put our extra +dnl flags into AR_FLAGS instead. +dnl +dnl $AR_FLAGS is set to "cq" rather than leaving it to libtool "cru". The +dnl latter fails when libtool goes into piecewise mode and is unlucky +dnl enough to have two same-named objects in separate pieces, as happens +dnl for instance to random.o (and others) on vax-dec-ultrix4.5. Naturally +dnl a user-selected $AR_FLAGS is left unchanged. +dnl +dnl For reference, $ARFLAGS is used by automake (1.8) for its ".a" archive +dnl file rules. This doesn't get used by the piecewise linking, so we +dnl leave it at the default "cru". +dnl +dnl FIXME: Libtool 1.5.2 has its own arrangements for "cq", but that version +dnl is broken in other ways. When we can upgrade, remove the forcible +dnl AR_FLAGS=cq. + +AC_DEFUN([GMP_PROG_AR], +[dnl Want to establish $AR before libtool initialization. +AC_BEFORE([$0],[AC_PROG_LIBTOOL]) +gmp_user_AR=$AR +AC_CHECK_TOOL(AR, ar, ar) +if test -z "$gmp_user_AR"; then + eval arflags=\"\$ar${abi1}_flags\" + test -n "$arflags" || eval arflags=\"\$ar${abi2}_flags\" + if test -n "$arflags"; then + AC_MSG_CHECKING([for extra ar flags]) + AR="$AR $arflags" + ac_cv_prog_AR="$AR $arflags" + ac_cv_prog_ac_ct_AR="$AR $arflags" + AC_MSG_RESULT([$arflags]) + fi +fi +if test -z "$AR_FLAGS"; then + AR_FLAGS=cq +fi +]) + + +dnl GMP_PROG_M4 +dnl ----------- +dnl Find a working m4, either in $PATH or likely locations, and setup $M4 +dnl and an AC_SUBST accordingly. If $M4 is already set then it's a user +dnl choice and is accepted with no checks. GMP_PROG_M4 is like +dnl AC_PATH_PROG or AC_CHECK_PROG, but tests each m4 found to see if it's +dnl good enough. +dnl +dnl See mpn/asm-defs.m4 for details on the known bad m4s. + +AC_DEFUN([GMP_PROG_M4], +[AC_ARG_VAR(M4,[m4 macro processor]) +AC_CACHE_CHECK([for suitable m4], + gmp_cv_prog_m4, +[if test -n "$M4"; then + gmp_cv_prog_m4="$M4" +else + cat >conftest.m4 <<\EOF +dnl Must protect this against being expanded during autoconf m4! +dnl Dont put "dnl"s in this as autoconf will flag an error for unexpanded +dnl macros. +[define(dollarhash,``$][#'')ifelse(dollarhash(x),1,`define(t1,Y)', +``bad: $][# not supported (SunOS /usr/bin/m4) +'')ifelse(eval(89),89,`define(t2,Y)', +`bad: eval() doesnt support 8 or 9 in a constant (OpenBSD 2.6 m4) +')ifelse(eval(9,9),10,`define(t3,Y)', +`bad: eval() doesnt support radix in eval (FreeBSD 8.x,9.0,9.1,9.2 m4) +')ifelse(t1`'t2`'t3,YYY,`good +')] +EOF +dnl ' <- balance the quotes for emacs sh-mode + echo "trying m4" >&AC_FD_CC + gmp_tmp_val=`(m4 conftest.m4) 2>&AC_FD_CC` + echo "$gmp_tmp_val" >&AC_FD_CC + if test "$gmp_tmp_val" = good; then + gmp_cv_prog_m4="m4" + else + IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS=":" +dnl $ac_dummy forces splitting on constant user-supplied paths. +dnl POSIX.2 word splitting is done only on the output of word expansions, +dnl not every word. This closes a longstanding sh security hole. + ac_dummy="$PATH:/usr/5bin" + for ac_dir in $ac_dummy; do + test -z "$ac_dir" && ac_dir=. + echo "trying $ac_dir/m4" >&AC_FD_CC + gmp_tmp_val=`($ac_dir/m4 conftest.m4) 2>&AC_FD_CC` + echo "$gmp_tmp_val" >&AC_FD_CC + if test "$gmp_tmp_val" = good; then + gmp_cv_prog_m4="$ac_dir/m4" + break + fi + done + IFS="$ac_save_ifs" + if test -z "$gmp_cv_prog_m4"; then + AC_MSG_ERROR([No usable m4 in \$PATH or /usr/5bin (see config.log for reasons).]) + fi + fi + rm -f conftest.m4 +fi]) +M4="$gmp_cv_prog_m4" +AC_SUBST(M4) +]) + + +dnl GMP_M4_M4WRAP_SPURIOUS +dnl ---------------------- +dnl Check for spurious output from m4wrap(), as described in mpn/asm-defs.m4. +dnl +dnl The following systems have been seen with the problem. +dnl +dnl - Unicos alpha, but its assembler doesn't seem to mind. +dnl - MacOS X Darwin, its assembler fails. +dnl - NetBSD 1.4.1 m68k, and gas 1.92.3 there gives a warning and ignores +dnl the bad last line since it doesn't have a newline. +dnl - NetBSD 1.4.2 alpha, but its assembler doesn't seem to mind. +dnl - HP-UX ia64. +dnl +dnl Enhancement: Maybe this could be in GMP_PROG_M4, and attempt to prefer +dnl an m4 with a working m4wrap, if it can be found. + +AC_DEFUN([GMP_M4_M4WRAP_SPURIOUS], +[AC_REQUIRE([GMP_PROG_M4]) +AC_CACHE_CHECK([if m4wrap produces spurious output], + gmp_cv_m4_m4wrap_spurious, +[# hide the d-n-l from autoconf's error checking +tmp_d_n_l=d""nl +cat >conftest.m4 <&AC_FD_CC +cat conftest.m4 >&AC_FD_CC +tmp_chars=`$M4 conftest.m4 | wc -c` +echo produces $tmp_chars chars output >&AC_FD_CC +rm -f conftest.m4 +if test $tmp_chars = 0; then + gmp_cv_m4_m4wrap_spurious=no +else + gmp_cv_m4_m4wrap_spurious=yes +fi +]) +GMP_DEFINE_RAW(["define(,<$gmp_cv_m4_m4wrap_spurious>)"]) +]) + + +dnl GMP_PROG_NM +dnl ----------- +dnl GMP additions to libtool AC_PROG_NM. +dnl +dnl Note that if AC_PROG_NM can't find a working nm it still leaves +dnl $NM set to "nm", so $NM can't be assumed to actually work. +dnl +dnl A user-selected $NM is always left unchanged. AC_PROG_NM is still run +dnl to get the "checking" message printed though. +dnl +dnl Perhaps it'd be worthwhile checking that nm works, by running it on an +dnl actual object file. For instance on sparcv9 solaris old versions of +dnl GNU nm don't recognise 64-bit objects. Checking would give a better +dnl error message than just a failure in later tests like GMP_ASM_W32 etc. +dnl +dnl On the other hand it's not really normal autoconf practice to take too +dnl much trouble over detecting a broken set of tools. And libtool doesn't +dnl do anything at all for say ranlib or strip. So for now we're inclined +dnl to just demand that the user provides a coherent environment. + +AC_DEFUN([GMP_PROG_NM], +[dnl Make sure we're the first to call AC_PROG_NM, so our extra flags are +dnl used by everyone. +AC_BEFORE([$0],[AC_PROG_NM]) +gmp_user_NM=$NM +AC_PROG_NM + +# FIXME: When cross compiling (ie. $ac_tool_prefix not empty), libtool +# defaults to plain "nm" if a "${ac_tool_prefix}nm" is not found. In this +# case run it again to try the native "nm", firstly so that likely locations +# are searched, secondly so that -B or -p are added if necessary for BSD +# format. This is necessary for instance on OSF with "./configure +# --build=alphaev5-dec-osf --host=alphaev6-dec-osf". +# +if test -z "$gmp_user_NM" && test -n "$ac_tool_prefix" && test "$NM" = nm; then + $as_unset lt_cv_path_NM + gmp_save_ac_tool_prefix=$ac_tool_prefix + ac_tool_prefix= + NM= + AC_PROG_NM + ac_tool_prefix=$gmp_save_ac_tool_prefix +fi + +if test -z "$gmp_user_NM"; then + eval nmflags=\"\$nm${abi1}_flags\" + test -n "$nmflags" || eval nmflags=\"\$nm${abi2}_flags\" + if test -n "$nmflags"; then + AC_MSG_CHECKING([for extra nm flags]) + NM="$NM $nmflags" + AC_MSG_RESULT([$nmflags]) + fi +fi +]) + + +dnl GMP_PROG_CC_WORKS(cc+cflags,[ACTION-IF-WORKS][,ACTION-IF-NOT-WORKS]) +dnl -------------------------------------------------------------------- +dnl Check if cc+cflags can compile and link. +dnl +dnl This test is designed to be run repeatedly with different cc+cflags +dnl selections, so the result is not cached. +dnl +dnl For a native build, meaning $cross_compiling == no, we require that the +dnl generated program will run. This is the same as AC_PROG_CC does in +dnl _AC_COMPILER_EXEEXT_WORKS, and checking here will ensure we don't pass +dnl a CC/CFLAGS combination that it rejects. +dnl +dnl sparc-*-solaris2.7 can compile ABI=64 but won't run it if the kernel +dnl was booted in 32-bit mode. The effect of requiring the compiler output +dnl will run is that a plain native "./configure" falls back on ABI=32, but +dnl ABI=64 is still available as a cross-compile. +dnl +dnl The various specific problems we try to detect are done in separate +dnl compiles. Although this is probably a bit slower than one test +dnl program, it makes it easy to indicate the problem in AC_MSG_RESULT, +dnl hence giving the user a clue about why we rejected the compiler. + +AC_DEFUN([GMP_PROG_CC_WORKS], +[AC_MSG_CHECKING([compiler $1]) +gmp_prog_cc_works=yes + +# first see a simple "main()" works, then go on to other checks +GMP_PROG_CC_WORKS_PART([$1], []) + +GMP_PROG_CC_WORKS_PART([$1], [function pointer return], +[/* The following provokes an internal error from gcc 2.95.2 -mpowerpc64 + (without -maix64), hence detecting an unusable compiler */ +void *g() { return (void *) 0; } +void *f() { return g(); } +]) + +GMP_PROG_CC_WORKS_PART([$1], [cmov instruction], +[/* The following provokes an invalid instruction syntax from i386 gcc + -march=pentiumpro on Solaris 2.8. The native sun assembler + requires a non-standard syntax for cmov which gcc (as of 2.95.2 at + least) doesn't know. */ +int n; +int cmov () { return (n >= 0 ? n : 0); } +]) + +GMP_PROG_CC_WORKS_PART([$1], [double -> ulong conversion], +[/* The following provokes a linker invocation problem with gcc 3.0.3 + on AIX 4.3 under "-maix64 -mpowerpc64 -mcpu=630". The -mcpu=630 + option causes gcc to incorrectly select the 32-bit libgcc.a, not + the 64-bit one, and consequently it misses out on the __fixunsdfdi + helper (double -> uint64 conversion). */ +double d; +unsigned long gcc303 () { return (unsigned long) d; } +]) + +GMP_PROG_CC_WORKS_PART([$1], [double negation], +[/* The following provokes an error from hppa gcc 2.95 under -mpa-risc-2-0 if + the assembler doesn't know hppa 2.0 instructions. fneg is a 2.0 + instruction, and a negation like this comes out using it. */ +double fneg_data; +unsigned long fneg () { return -fneg_data; } +]) + +GMP_PROG_CC_WORKS_PART([$1], [double -> float conversion], +[/* The following makes gcc 3.3 -march=pentium4 generate an SSE2 xmm insn + (cvtsd2ss) which will provoke an error if the assembler doesn't recognise + those instructions. Not sure how much of the gmp code will come out + wanting sse2, but it's easiest to reject an option we know is bad. */ +double ftod_data; +float ftod () { return (float) ftod_data; } +]) + +GMP_PROG_CC_WORKS_PART([$1], [gnupro alpha ev6 char spilling], +[/* The following provokes an internal compiler error from gcc version + "2.9-gnupro-99r1" under "-O2 -mcpu=ev6", apparently relating to char + values being spilled into floating point registers. The problem doesn't + show up all the time, but has occurred enough in GMP for us to reject + this compiler+flags. */ +#include /* for memcpy */ +struct try_t +{ + char dst[2]; + char size; + long d0, d1, d2, d3, d4, d5, d6; + char overlap; +}; +struct try_t param[6]; +int +param_init () +{ + struct try_t *p; + memcpy (p, ¶m[ 2 ], sizeof (*p)); + memcpy (p, ¶m[ 2 ], sizeof (*p)); + p->size = 2; + memcpy (p, ¶m[ 1 ], sizeof (*p)); + p->dst[0] = 1; + p->overlap = 2; + memcpy (p, ¶m[ 3 ], sizeof (*p)); + p->dst[0] = 1; + p->overlap = 8; + memcpy (p, ¶m[ 4 ], sizeof (*p)); + memcpy (p, ¶m[ 4 ], sizeof (*p)); + p->overlap = 8; + memcpy (p, ¶m[ 5 ], sizeof (*p)); + memcpy (p, ¶m[ 5 ], sizeof (*p)); + memcpy (p, ¶m[ 5 ], sizeof (*p)); + return 0; +} +]) + +# __builtin_alloca is not available everywhere, check it exists before +# seeing that it works +GMP_PROG_CC_WORKS_PART_TEST([$1],[__builtin_alloca availability], +[int k; int foo () { __builtin_alloca (k); }], + [GMP_PROG_CC_WORKS_PART([$1], [alloca array], +[/* The following provokes an internal compiler error from Itanium HP-UX cc + under +O2 or higher. We use this sort of code in mpn/generic/mul_fft.c. */ +int k; +int foo () +{ + int i, **a; + a = __builtin_alloca (k); + for (i = 0; i <= k; i++) + a[i] = __builtin_alloca (1 << i); +} +])]) + +GMP_PROG_CC_WORKS_PART([$1], [abs int -> double conversion], +[/* The following provokes an internal error from the assembler on + power2-ibm-aix4.3.1.0. gcc -mrios2 compiles to nabs+fcirz, and this + results in "Internal error related to the source program domain". + + For reference it seems to be the combination of nabs+fcirz which is bad, + not either alone. This sort of thing occurs in mpz/get_str.c with the + way double chars_per_bit_exactly is applied in MPN_SIZEINBASE. Perhaps + if that code changes to a scaled-integer style then we won't need this + test. */ + +double fp[1]; +int x; +int f () +{ + int a; + a = (x >= 0 ? x : -x); + return a * fp[0]; +} +]) + +GMP_PROG_CC_WORKS_PART([$1], [long long reliability test 1], +[/* The following provokes a segfault in the compiler on powerpc-apple-darwin. + Extracted from tests/mpn/t-iord_u.c. Causes Apple's gcc 3.3 build 1640 and + 1666 to segfault with e.g., -O2 -mpowerpc64. */ + +#if defined (__GNUC__) && ! defined (__cplusplus) +typedef unsigned long long t1;typedef t1*t2; +static __inline__ t1 e(t2 rp,t2 up,int n,t1 v0) +{t1 c,x,r;int i;if(v0){c=1;for(i=1;i> tnc; + high_limb = low_limb << cnt; + for (i = n - 1; i != 0; i--) + { + low_limb = *up++; + *rp++ = ~(high_limb | (low_limb >> tnc)); + high_limb = low_limb << cnt; + } + return retval; +} +int +main () +{ + unsigned long cy, rp[2], up[2]; + up[0] = ~ 0L; + up[1] = 0; + cy = lshift_com (rp, up, 2L, 1); + if (cy != 1L) + return 1; + return 0; +} +#else +int +main () +{ + return 0; +} +#endif +]) + +GMP_PROG_CC_WORKS_PART_MAIN([$1], [mpn_lshift_com optimization 2], +[/* The following is mis-compiled by Intel ia-64 icc version 1.8 under + "icc -O3", After several calls, the function writes partial garbage to + the result vector. Perhaps relates to the chk.a.nc insn. This code needs + to be run to show the problem, but that's fine, the offending cc is a + native-only compiler so we don't have to worry about cross compiling. */ + +#if ! defined (__cplusplus) +#include +void +lshift_com (rp, up, n, cnt) + unsigned long *rp; + unsigned long *up; + long n; + unsigned cnt; +{ + unsigned long high_limb, low_limb; + unsigned tnc; + long i; + up += n; + rp += n; + tnc = 8 * sizeof (unsigned long) - cnt; + low_limb = *--up; + high_limb = low_limb << cnt; + for (i = n - 1; i != 0; i--) + { + low_limb = *--up; + *--rp = ~(high_limb | (low_limb >> tnc)); + high_limb = low_limb << cnt; + } + *--rp = ~high_limb; +} +int +main () +{ + unsigned long *r, *r2; + unsigned long a[88 + 1]; + long i; + for (i = 0; i < 88 + 1; i++) + a[i] = ~0L; + r = malloc (10000 * sizeof (unsigned long)); + r2 = r; + for (i = 0; i < 528; i += 22) + { + lshift_com (r2, a, + i / (8 * sizeof (unsigned long)) + 1, + i % (8 * sizeof (unsigned long))); + r2 += 88 + 1; + } + if (r[2048] != 0 || r[2049] != 0 || r[2050] != 0 || r[2051] != 0 || + r[2052] != 0 || r[2053] != 0 || r[2054] != 0) + abort (); + return 0; +} +#else +int +main () +{ + return 0; +} +#endif +]) + + +# A certain _GLOBAL_OFFSET_TABLE_ problem in past versions of gas, tickled +# by recent versions of gcc. +# +if test "$gmp_prog_cc_works" = yes; then + case $host in + X86_PATTERN) + # this problem only arises in PIC code, so don't need to test when + # --disable-shared. We don't necessarily have $enable_shared set to + # yes at this point, it will still be unset for the default (which is + # yes); hence the use of "!= no". + if test "$enable_shared" != no; then + GMP_PROG_CC_X86_GOT_EAX_EMITTED([$1], + [GMP_ASM_X86_GOT_EAX_OK([$1],, + [gmp_prog_cc_works="no, bad gas GOT with eax"])]) + fi + ;; + esac +fi + +AC_MSG_RESULT($gmp_prog_cc_works) +case $gmp_prog_cc_works in + yes) + [$2] + ;; + *) + [$3] + ;; +esac +]) + +dnl Called: GMP_PROG_CC_WORKS_PART(CC+CFLAGS,FAIL-MESSAGE [,CODE]) +dnl A dummy main() is appended to the CODE given. +dnl +AC_DEFUN([GMP_PROG_CC_WORKS_PART], +[GMP_PROG_CC_WORKS_PART_MAIN([$1],[$2], +[$3] +[int main () { return 0; }]) +]) + +dnl Called: GMP_PROG_CC_WORKS_PART_MAIN(CC+CFLAGS,FAIL-MESSAGE,CODE) +dnl CODE must include a main(). +dnl +AC_DEFUN([GMP_PROG_CC_WORKS_PART_MAIN], +[GMP_PROG_CC_WORKS_PART_TEST([$1],[$2],[$3], + [], + gmp_prog_cc_works="no[]m4_if([$2],,,[[, ]])[$2]", + gmp_prog_cc_works="no[]m4_if([$2],,,[[, ]])[$2][[, program does not run]]") +]) + +dnl Called: GMP_PROG_CC_WORKS_PART_TEST(CC+CFLAGS,TITLE,[CODE], +dnl [ACTION-GOOD],[ACTION-BAD][ACTION-NORUN]) +dnl +AC_DEFUN([GMP_PROG_CC_WORKS_PART_TEST], +[if test "$gmp_prog_cc_works" = yes; then + # remove anything that might look like compiler output to our "||" expression + rm -f conftest* a.out b.out a.exe a_out.exe + cat >conftest.c <&AC_FD_CC + gmp_compile="$1 conftest.c >&AC_FD_CC" + if AC_TRY_EVAL(gmp_compile); then + cc_works_part=yes + if test "$cross_compiling" = no; then + if AC_TRY_COMMAND([./a.out || ./b.out || ./a.exe || ./a_out.exe || ./conftest]); then :; + else + cc_works_part=norun + fi + fi + else + cc_works_part=no + fi + if test "$cc_works_part" != yes; then + echo "failed program was:" >&AC_FD_CC + cat conftest.c >&AC_FD_CC + fi + rm -f conftest* a.out b.out a.exe a_out.exe + case $cc_works_part in + yes) + $4 + ;; + no) + $5 + ;; + norun) + $6 + ;; + esac +fi +]) + + +dnl GMP_PROG_CC_WORKS_LONGLONG(cc+cflags,[ACTION-YES][,ACTION-NO]) +dnl -------------------------------------------------------------- +dnl Check that cc+cflags accepts "long long". +dnl +dnl This test is designed to be run repeatedly with different cc+cflags +dnl selections, so the result is not cached. + +AC_DEFUN([GMP_PROG_CC_WORKS_LONGLONG], +[AC_MSG_CHECKING([compiler $1 has long long]) +cat >conftest.c <&AC_FD_CC + cat conftest.c >&AC_FD_CC +fi +rm -f conftest* a.out b.out a.exe a_out.exe +AC_MSG_RESULT($gmp_prog_cc_works) +if test $gmp_prog_cc_works = yes; then + ifelse([$2],,:,[$2]) +else + ifelse([$3],,:,[$3]) +fi +]) + + +dnl GMP_C_TEST_SIZEOF(cc/cflags,test,[ACTION-GOOD][,ACTION-BAD]) +dnl ------------------------------------------------------------ +dnl The given cc/cflags compiler is run to check the size of a type +dnl specified by the "test" argument. "test" can either be a string, or a +dnl variable like $foo. The value should be for instance "sizeof-long-4", +dnl to test that sizeof(long)==4. +dnl +dnl This test is designed to be run for different compiler and/or flags +dnl combinations, so the result is not cached. +dnl +dnl The idea for making an array that has a negative size if the desired +dnl condition test is false comes from autoconf AC_CHECK_SIZEOF. The cast +dnl to "long" in the array dimension also follows autoconf, apparently it's +dnl a workaround for a HP compiler bug. + +AC_DEFUN([GMP_C_TEST_SIZEOF], +[echo "configure: testlist $2" >&AC_FD_CC +[gmp_sizeof_type=`echo "$2" | sed 's/sizeof-\([a-z]*\).*/\1/'`] +[gmp_sizeof_want=`echo "$2" | sed 's/sizeof-[a-z]*-\([0-9]*\).*/\1/'`] +AC_MSG_CHECKING([compiler $1 has sizeof($gmp_sizeof_type)==$gmp_sizeof_want]) +cat >conftest.c <conftest.c <MdU42&|L6+}dW1Q?D~T21r_odHulajck(PBQw2p0yMGF{%(n&urYri^&X=rI}k8g95$TPTlb-SxKx>0 zXuRi-QB4Lp)SA{8{Pq18Lx99-it|&g$}z>%Fr2WLj}ueONwdeqsrGO3Q;*(8J3aNw z^rJz>Y;%S~AHKmY zOxROn>UA>iy>fvUO;A4#XFn^qldzTZEOg+w<67zFPGO?Gz9B~n1w}~HI`27u<>Fjh z6tsF(L?sbW5qtGg{b5)#;k?Qkpg&Gq2&nNzLWF96QA8$o3A!xTitr;HHGE1wt<|=6 z>h7(tmdmhnIyVa?_2irc{I~>7U6)dLX%S-LD#%_wIc^!kGV#Nv<;@|KFlX2B(J4*_ zrTtL=qpaDhNzrpE1-r37y8IjxXp>lCX6wR&Ig5CMW@n9q0PGk;=OikJvm}zgaCl}B z2%IAdc-i~#_R0MD!0j!P{z00+4;KAqzGX7T3B}d_x zamWQl9iTZuK_EW0P$|Dg3pJ2AwiO>H{8cYQf*#mKqK%wl>m7)B%aGKcEj1A$-EJ7La%ufxGWPjVM`J1+)hwJ*DX0nS$k2l$sNv$q$IY zA-5IbZ)vhr#JZq2POMe)6=4(hxPJ=b#-}p#2F*2!UlSQy%=Bvc0128Xr1w@8pZ229 z-p{9%n!zwS<{4}OS|=u{ks7zj97_l>jtG12QO3(wZ|=rYWSi}&6p31gHI!=ldHl{E zY@o$zq@JT5=S#{KDfb;EqAhlYrgB}mo$sy_*lAN>AMGY2wLNo&8<&V|A%(Q2Ia06m zBUb@JG*Pg#6Hp^{#>+f2Tc;fcsITFVhXZ+M_5euWh2^9&&3_4ji}JKfZ&$dBWU4v6 zY(6bP&RT@zy96chLy!N~rK$i%h=vtaGrf-mub*t#^;RN%*GwX5%0ZA!_5{L}&Dm~j z&8@lbCWqGH(0_rHkEizP%(iGTYgsEEUIMs3TvRW|Z2o+z#i}`~0M0|s zG{EMM6JCXSIgWqS;eA`c?PZ_mln)}ToyvmLUm^u*F5rcNe32;~rZT^N!a@@`T)CE5rKjcbYt3y~i+6U7~sJKPHfdL#eO{l~s z4JH|eFt`OcZuz;tL}0dLuG*3|i$J~Rjrg#=B@+PcwnSbJk6z~e01dD&VECtI_OEak zdPe5|xlSBZU3d6-GJ9XE-XKn-MTz+}Ka7eOkyKf&B5kf2zWNvAXEGC)6B%nJ9&NWr zf|8FZtcNpN4>Jx~*WtTNt7BtyW5vt{@(x325#A7TMnyU4cf>|F125ZoxGY3Qx!JJg z@7n#R(YQ?hUhW9@WpF!K`LQl3o9}C6JEodC(<)zV2HskQkL+`Sk?eu2UZXc|_&r^| z*2tyWb3#vEcTS&`g?1PqvRqWTG51WvwZSbDv4lN>52?2VJoq0064mxGw za^lXPpkk?1rZQqKgZ@QK6t`#tRP+S;8wWlAm|Qn)Bu+A@W!sv{#NXSqRe0)7HM*QY zg*m=kB5qYC`M3kM;o{{S44A`&nY)q(m^%3EAl^!5+)0!A3l0P)u%YUnyn?QjEtFJ` z^GcQ`1U(?lOL}$Qduam%*2E!)kA(trk>j)^H$-usM9MAa5(L3?*#-O2eHobXz^YT~ zyi#q;Dt{LsgDXG;V#LC4fp?k20NmSUdKOHv7`7wEzg9bcIrlV^C3K^w**!Wl@CL#< zS3r`Fx4*)WLhwn?gGch}fODizJrkrSUM^+dx{_Tuwn0ktF@YftU(C)+SXyBWt*k5| z_{x}3?6+Uh)ErTX7775~OVGBFhVOQWb_qOJlB_!Mv*S(|4LI6xe*-We3UyT87JUpX6tO?M%q=gbmtz&SsV0uqo+so_~ZrG)WEg@qlB4Gl9xTU(v z!0M7|@`5_^vL=rg7p~@-WoU~NX)t{3IdTgr6H#8n0P+&_$F@?mL?#&u|1nSRqUZ;y zCU4^(dk{q^q4QuW=9mt+?^rvS#iBpb56lJk%$Jb*jshA~DoVF03f{k!0y-@hpT#=^ z?M@EZotf(M`c5pEua-)E(PqH?M!Y#uzJ;~zfi-Vz2O3U-!%VH{R9AEq3h4+u5ckxh z>91B!bK%PZ#YF;52#H$_C9mUk3gGg^qzNKeD1m;fpA!oD2|?021xBdgVGJlID!74LYwC*X~naix>gVUa$NchGedt)Lz1dgMM*46YVzc zv_+?#YVu=2u%kqi>M8+~hZFxrtZWxf;WndW$LauI2Tt4XX%&=8C@Zc`p_>`;QHois zG6tX(w>2YrQsR*6^(JlutGQ%O@d}u7Lz66%&`1U6NOpHoTK3EvRXMsi`aWyt0I;K> z(h0Pc2pjy{-N%)W#pW=>Ot?_l8nszi=Mr-GTseWKN1U^7R)F07e)`UyHbIwwco3SL z+{=egV$Q2hDqf&V&rw(+O~GJRG@KZq&#t}r0$AUnelleNiCuph!#(uH=S7{F_sLve zw0>8Jauv=%_(qH~Sf&k(Mv=qrw-IGR9sJp7OQPa^7*F5hL8@rz48C8O>uGc%u%F3^Vk&)yA9uYZK1<)Fx; zKGl%mKRMDhhpcqVNk2IMGZmq!*?R7l^RqD8+lbNX+Xb@iq?zNOjC|4zMcCH6Ub=FD zqT{rCcn>f8)jB3z# zklGZ3-if{OFuj-mmofD)L5UTWRQqVGyck^JulTE=3N1^H^_3hdM+uVqJEeGVi?l_) zB1wg_48ZTG%L5@^apTn-n0QlBseM;Qba>h6{Zy1bf*f7Q#Dm>~+Yj${tV>8Enm%~e z#}-SU%yXf?5k}-+>~nxykCSVx3@GDB(;b4(2sq2Zd;!X2SY9_yOmYgddT@L>m7=&fh>f?yYZA*>$MGOa_2`1I41%9xm1D^jpBU9^wZH<%kf+PM z9s~z)(L`_6VY(+0_Pg24W`aJc4%|wPfw^9*Zbwc}omw2OVOKpbjyFxl%^D|-Fa4Xp zLe^rEqx6VeHS9jQbkBmD4ex1cFImC=1)sBOj=T1>?%yqW<_UTYFbK}eTB8lTTz;|m zVm@G6AYojrv4-4}s`wGc_>Ec?@?4_|#Ne~OR3+Fx{zR~0GoXpU)BKCKk9BQ0 z(HBbVO-IGi{IxY*2JukZB|=>#btZWsirq#fu@MlLFrRd>fIOmpMbcivT>X?g)(b#L zls|lU2(SAC`t%NI=AX*yzoT$|>^=TpMR`(n+i~y5H1=9|w*-s5ESP${`wfh}Z}tcu zwB&SRlN((w%yX#tueiszx2jG$<4)!u0x1qIe988T#pd>0m9_1RqV$^vrdabFEIHnp zBg!f?i)_habrRSKKIm(v@nxz^uozSto_N1=-9BAr&e~G&HV2EO(-7-*qNs5prHT+i z{?Q%11m)kkUo+mBLhjg;NVi1^r&?0#tTP z^XZaZqxA39j4dq!*}-YnDU$Ju1HHFod8TwS($~VGm(p*W+flb8EtfJP{j+)=2kG82 zHrK)wqSX%Dt|OZy*{Sv^d&^Ze>LmW3ay&G49=OEeY9BCo{<25-FlLDG`( zXfN6(rA1G6qcA-m5sr|R{&s(>rwmxMr{@l^1TeQR2M_sO*}@Z|`7Rnbg*rN7Bdh!r z`7@t9o*eyB*W=V~;{F@Pnv{Pyd=KLli=ZSL^58P9(sq^HUcd;3*E!xK}+O<%O$EREb zNybuzB`MSa4}C5>V-Cl-WVoNzAytOw6Vb&+%{!zDg+R&ry4_Qb4Rpq!dcx1bYLw}R z6Z`m*-m_|_1_iUMl}PjpaE$ga#&`_8nbr9hFy+Zz>c|?J;(O|)mO&;*EitxeCBH7Phyz{u?U%Cz;zGSlku3@ljb zn%D|+yoGk*Md#1IgjZBv0hjGV6;~iPL+5tZvbiXky*X$fSjT0&cII zwkoeUYjmDP6ZP0mbsnN`rQN)dab?5wVMQVNtLF6;tIx4}MNWgV9)15*qUHu%FQ1P? zj9ZI?jn|c$<0Qf;m)u#5&MYzDk@TmyV6k#l*9gh`4elks)jlWc*SIeF(%`Uq7K7n* zk1siJj!X+Kfx&NT*x)2Tn>Qj+lR3oJe@=}W$c;>mqkBSJ^l^h>@(^l=i@)eEe69?u zuP!)DlZ>OY69so|&~q1XY#V1$0Ir6P`<}Gad*vS)Z5-eak>Iv!Yyr$URn;X^{C#|1 zZETSfIbcInV)aUuG=SB_Wdu%@~SZVi|aW(VOjl`8z0I9l8 zyyPGiS4x^Tlap~^?bPQ-yanvQSnDY{LE3f}4M5 zc&M4P=ZH$;_Z2Nz9mfhJ(u`-({rx~&M_3;4PZjLnfeXxx|5L$=ep1PP6k*?M-TYfY zLgHCrJW~G=DN~5xmFQ?~D%NaBceX%)=wKlt{fR&Sm4uP{N^MLzxXi9?YQe@O4gO!CDM*MR42FmA#%;7lImEyRQCiij*PHlJ2T zH9S-pd9XS#uY(QZYUsCV(-jmRc%{L-=c1t5uAIG9j{llgQibsmgfW$I{&M`wZ~R-{ zN=Go}nEo5zH2%<1K0`Qt_%uOFcHhXNaRi=f$(|C_T`7sWPdl}>YY*|YUXDtX9v=N# zH)DIQcjD)Da*l0tqa&W?~?JaQkwM|W=b3Ae#Yt$C7WEe=-0j{DEMXw9_1gNw2 z@tq3^UQELy0fS^@lqE{Rqb~0gQKutE>ye%}-yKVaW(e<;jOHZMq>R0*#Y>WbTy0RY znex5|kwNy4A3N{QiOYJ1O%Y-#YUi*#?>BCzJ-_pfZqmZmkCch z{rHk)7=P~{p5;39<1{;w-B$-_FFj+X$l!zza4@BVx)#}jCkOwv^8Bx2Py?A%=Wpb+ zKf%Z94753|2@rQNf(0xlNZbWMVwfjl=wz;5WGRTFTepS?HV zX1Ar7ygJK=+l>=kVfeuWN07mK zH!URr!`_`M2yUjg3-#_yC7TkW{yRaLx%&>nq~;>qvzu-RI$E)l_TLt2dXu+&(}fP1 zC7|{YZ)6vM$<%Otlc++4Ji-0eITe@^Pf4Q6hR*wmi0KXUGf&6&YLANZ4PKv$joTP- zX48mlErhjF+|UZi0AKv0aEu|<`{r45yTiT2h@7XK3JhjqD9&#uGRgQ7LZT#nirh;E zGR)3h%|>H}8;Zk`jiAshrv8QKUl!*xERG-jL1LO#ek3-oIxP7VGh6*KutU|;T+QjY zRDV!+V*+8E-iOD(aPrnr5NfB!mtPysNnF)JSrutaUBD8zA+fppfG$obHKK=Jg4xNJ zkT}Gk-;~frFEm(;Yx4>nK&hX@AkP6p#%{#iuIEknC{$Ki(vhqDBqFJ*!i0(0IfQxa z#CJUF)r?@S8f`AG#%$#Z%0Ay8wcE8Nxez}!%6v2PuoJlBqrA#T)yO)b+ zY&bsJi&W0B5-kb9kr-5FaoX!+C@u%@*|%%y&XZjf*u*0x7cn+9_hrqo66Lr}89~^IQ%6+nOQ8P|F~zj+<(c*6Z06L_E0+{AI?> zV6{H??q-W16P;=bzWVaT9UTqZAuK_}Ev68z@|!%@TZo|c;8d~l1y{H}I%3Rv*!1d@ z3G;C_4mn5S9NZ%-kI79_tb-uiIvGle&_^CdzHTjFM^in2Dyi!E)*&3;dr#1dz*sY7 zFe7E9@(qlN(h*07^SV;OYeI%1VFm8cGI@>auOywrzCTwr$(CZQHi(n*QeQtT`8Ft@#K0B6sGS zkr7YC!2Pn8AWV|1t08y@1xexWOuhW8!3?~-ueD(a>#;fR6dPfTT_L;UCK05~j;Kqj zFev-}S=>bc0QfK9RwnxYO<-W9{|~}Zw%Wfc@&B8IYxTbrD~yPM0Cgvx`elwra91r1 zOA=+5!9|NmWXTmz3|4=8I@SFOgohnCa~ROqfFpT&f~&Y9wUpitRrfUg@$2auQnW5p z*F4JGbT7>B*xDZoBr zutTO`X~YH)YZTL`?GE65Db~x6{hVc2&|hk5R*DVnXNp|Mv{g+i-0+}>2(1jvTy+$s zab}ar)0f0O{_n}W%K{x)GlV~jwXX8fQR2evv0+-j{ZIB}5k6H)3itJM>t&gQ1>^70DK+EF>0E(}h<<I&;{)c=?7q@?$->49cDyF~O7(LNBkvRjI^m;0xD*=52hnxwVM^*pz**$W zNI&z3m<0~08M#;78CHr^MFxEDXKnk(XSJxZhRjw@~o$kSqn`fyNN>;wIYZ&ad53WT~F7m zE5h>UgBA{O#L@BkOD1t#BJ2(OwVP5T~9gO@NK?(t?FbOF+ z97lFyT4LrXjqbzakpHiWKz|^=bb46Gy;Qy-V13??j$Oqml%ht1@HcFgv9X$cJQn7b zto|I{I1nWg1E=yeueD>{F}Bu(2x+$6Uvb-eaVbgXl$cLoqG+N4T^DEAG{_ds1tb?O zvPo)EkL7-mIz@~jzt9)%^H~wvqsTICjz8B?4T??@R?viC3{l%+`>QoMn%AyW0ZT3A~=ufb_~6Aaq^R>`*M9jcT?@Xe8pW@`x!8KpirH zq6^46x1g7xfjqS3V_(avJUi_c2X|s}Z>&4$Wo!S!bmK6$U&>LO-d#T)d&GNZvvF;# z3y~w^x)WLDU^I)`Mt1@{wiz{XD=r1+jJFvJ6nfCfHiB6I+rSS=Uq~ zmVhdz3ifvYD=VzKpauwqWPHb4Tj?0-WZqg-F%NE%;l; zao3n*|-L6i$X6OE?}SE z+k$=$2a2qer%1|NqlDz9yV3_%4Fad?u!^(3wug$#yQ{-I(t6f<)Wrip=$PE{4upuP~gx+WwIeZ9Hc;3Sc{6E zIlJLkzAtbMSAUQH?|p`e{(nhf4<0w?Dg_tblp`9+2lli zPC7Ha&FpP&0GZRz+AJgf^Lb$e%NnQ4xd;PancURyZ|>Ku>ZMtA+&k5j)TE5MCT}@u ze^xT|#*&(JzFG^fHnwPwKlX6JQ6E2mcj%U6i>?6^ntcqSq5~J&eH|8>rq+{=@K*+6 zPC3_x|B?1-_B!9tAIm?iC&H`PFtCR8eybpnXa@m~Azrw!$h2xvWQr82!I-r+m4+!K zkKDIr?B3I9T%hj3nNH{wAQ@)cp_`;MqpWS1-5`5d+_1n66*x; zbQ-#8Jd~L_3W)rgI5}C_nOmCpdE{X4Fw&VHgy7U$r*#fB@W)%OYwtkG*1p)DNTK%x z7&D?*A3efxdJ4B;s^7hXb?ZJ#4McQygw)Mva3f9iJ%w_YE>l5VuEV3Y@hI1p&z8PB*fs*pa3u|;JmdKd$Kcjp@n zPzlgXs{HUnV4k=LCgEwKb3WDolJmeaLOq@mWe+r48hXd5I`n{}aw6aY@5?{{8j%1~ zuS^VMvvW>DU0jw(J&C;4jb%2PT&GDfxK)Eq*@jv;kxWEP zps$^%oSN`JvK`0a2sb?b0pqBTK_2V^BCY2Zt1qxh56WkAD%zhZ{KDX>FoLzEyRLej zG#2dvBfLSq_aV+g#Pq@q93&u)3amZJR$V5SGm>{z!KFy{?zLAsh)!)WbpG2H2P`7g z|3TW*0-J;09HXqIXO()JFcQU>3nmE@%>Kwgh@TpI=OVSrAehuR%zdq>@gRJi;xVVe zjL|A4e;b+^1*fC%QB}_=`tYHNt^=XWNkWb+>6R|V7Jwc=JcFLZ-N;_N+0g7j*vx9xS^O{dS84&TcQ5l9j`cnOyOye=%lOopVCdz33<1=uG+9rdGj;X(t zfO(}F-3FHJG$%5uXe@S*OE3Um{KfZwMg6?Y>DEoXOO)`vd~v$$dbXo{9my#{})_Scuza9;)2sxHy!H=-eqk8PS|m?CQdavL6hwgtJ*nPU2WK6UF~^r)S-F`6+Ry^z=_9i+`r6nx9mg~j(ca}=_Ni5i=` zTNhSixHh^Jg8_Y8Cr-|Op;{-FfX6mV>C5i6giU{0>@UcBTn6{(MfA}Hz4q^;h;c+l zh>r@zNOJEZ@b)+EA>`z-Nde80oMEMUr=|Bs2Ke_WTZEtE#^wq(OT#F6M(aW)Qzn{w`u}9)CvM{x-IqHp|HOmz68D6b_v_ zGE3&?%%?Rqw9pbg2VvmYu>Ed;-iePHnofNC`e5+{oD7CNFuUhumQkit*CCXQdJj?Z z2__OfV1fV9q5iIbeJ%lnEuq9E45dmOM{bBf%+5obMsYvq;=11aLe4bOo*mpuB7R+{ zrK|V%_~z%P|1Ow#UO%)Bjjug~5R0jffcbK}p5_955IHsp(w6;a180svV+JCE2raa` zByfv1VCdT!ak$1y0cE*^JQt1WXEY1ce_Ij;PYwu8h+yB39e0igO1R#F&gI?V+rIYQ zdoM~O3xVv-e`*vCjxOM~=Ntu&snxR@P2h@mklH1)f%w8*pM9-cmxii%b^i^!Ktg>n zD0G_ca`Vbi?FX779 zf9J!+nJtiOzmfchZ?A^Bqj2@At6+x(Z=_iHPlH~vgcB`gum%DzGL8ICb3l19%O7^mDB?E|&%}GuFK`QLt2t$CDF@R&n3kI2GBa=3B z^?0Q=A}aD3?up=$=DesF>%6}#VRT$IWcx=IAgnTSUW;E~mo)Yk7O1Hei8l9Y3)h11 zBq5k03^S>Xa9or+25Slw5yrcJr$EZ8P<=44XERn&{Kj>rQu-oBETu!Vtwipw^F?#8 z*T442i|Dz0{_5G#OST1$PHVJ_-*zX@@aoo(YTz&(>YeU z>MBZ3UV@|s9}a&*8SIL2el?pe~efLji6qde8x7IY3fI+*vOuq2M)2J$0V>(7(ucu%+z zq@6v1tf)|n<>r7@GM}7**m!-#mUf!@S)EbHBQ)Sl-T7ncNU{4X6h;Hf8%tkoc3;Ie zSA~S@f3!sJ)oC#uE<(x}e9C7VIFl?#QVC4XG0NrsfMLDsPn5S{#Hth3Sp!&^;YLA&ziKF_*l=tG@znHp_@;cMeGQ z>2^4@k>Mak?~*H-gQwnL-h6rr(At7Bk-@cfXp+6dWPPmjFAe#}uH&#Z@k1q~yF z&;ub3l!FOk7zS!^!q3b;1>xX(0Bw`q4Iv^23E$3sen!L>*%=!r8Q^(ukC6<6p+$d< zf=A7?LdSmE-)`0j_qvfU6<6i_Jy)O+88|%T``b)oQh7VztB3fk_vByL*O_oLF2~dl zi`*XoBI8%sw+9D;zq_l~%5}&(jcN2Z6~sgrK!&UTEUI~i*}`XO7b2Wy_P$K1d+Lzd z_~$O~jmX4wsT6V2O)sxYUf5pZ+!PUI9+$aNL#}=>Y}?3zI)7niSqvhLCf4o@{Z6+5 zG+_Y@6gwCal`#91=tx?cvAdUZ&p{t|*fj2ywr@bo4iype)$dfp<)g%pkVYfc;O<9N zFNA)BRmCKAU%u{kKy3oCBF*|yx4vWQL}B%;(LU7+4}b!oVF zJ)y*?>hec+9)}~=933G$k*|S$+;#km5jvX&Rx!5h?B@Wp;F5Tp1F_n5_(e%;I-nLt z9rK4BCZ@gvan4_VJ0BFW?}~G!kKFVtcm^dJ`TcZ=64>Xm%ryz?GHK{5QTLZgxolqa5V(mZ6|f+A9_7_uoD)YjFi-1elGYO- zEJj2*5B@e?pPxxz0Q~5p(*H7ZF#JzZc{b+%NXmOF_s3+?|BG!>Rdp{3NA`~(j8!LV zQmCjjTP{tS!jlkUH-RWhH)ZzTMvY2rh19TPc#a&tn(n}SPLo9LCt6pmF;fZa);;HV zYuBAM8Zx4ZXx9y=jAxAtqflsB1kqjOmshb!gKj~w z3@NW1@2ka;bzNOLE-U|2Uq7@5<9kC_VaOEOb@cWg(=YyaQP*G zo_XYzbZdZ-ZygQ{(q@*GtNk{&|Mh}fC}helyM0~4 z>&D2S3yhZzrbv?bz>o=VlI2H9lNi@?QHfnofW+t2#8xLv-e$5z-F4}1yv-u!m1;4e zc2>ef4B{Mr_p)~pS}81Ny)pJRzhF5#6#h&GWk^s`At@6|@b@+=`jSLhXx}pGipre$ z_bk6D^Xw7KkqN0t;-)drPlV+8NY#)9B$Wx3JtC}Jns7V0>Y)c!5T1e_w26zYU+BC~ zHr9!*6mS>1Ao$DHf03d~k$IA9mDy3dBDA`i+&+e8nXA!NrY2pg8X?$s@d~-55A~d7 zH@-w*C-L2NPsoj=P0ux6wJbgTpI?*4`L*3PR) zu6L=+cvH?Nb>zp_Y_;Z*r`rr8J`&EEC?a&txm9Sc^{ef1y1c+pfSnITlO(fSf))9d z1#^KWEY<&-Ts;(Dw=C4`ItX?u^>X3`nJg=u^102GuS+H~ZSF?x-gNn*^3=eBh^hZI z!i>#*PXo-rO0Y%U-KGBwjMaNEsI$HhVa&+;MAqsJs*n*Gk-Zq5BZnT_gJn~eoSfA- zzl32|HCWFV#~sb(zkl5fB>}!!yREOc`-f#*IH6thy*fN67wu}alTUGd>HNR_F8@=? znSq|=KPp0p)nxup!T-OQGlZ#h5J4Z^r*Wm?g{ofs8m5^wJ~>v)x_FVKybX8y*DHXw ze1WlMJ*qP&FExlhdgLo!iq)ZAAV$juT8}2Az~{8d@<5qKlE%YU233?6V~3m*-bZQJX}yw|7zk>#M1 zuc{_ka$Ca_4Sngnc>7)MRNv12z7f%%f1_oct>jEG>(o?uN;>)vr;%utr?r_1oc z(u#W9OFGYCNGF&TBuS>i*Kr4K4^H-!h~_ANWkUIoSSBTGn&;!etyMa25fuqRg$8c# zK`iX-pIBlad8Ia>Qx0Rousm4fKZJIN_v{!ZNM6yn(J#nRTl6;YD40v$3u)uL^q4(|w=0GgEN)>9d$j}UcsB&&4@u+)@dUO;;ES|(-5 zc_5ID=+e>5j~whMy!cwV{xYDL(kyc}#&%L?$mBJ#w8Qk}*eMPQE^qD2_@CRzPbn%9S6UqBY z=7~W@j~awdGOy;Spy}q(Fdwp0K#z*Gw>vS5g(C=G@9BnCEU zAn8C!M&+#%keO+@QQ@*(H@0JO?4q12<_|DA3ax6RLT62mLAgf4bwwN0q zlAjGMyE`GMcmFccHI_h6%F*a`Xc)^x+6}w{eSSXKNtyO!`Y}G#U~k4NMp&$?Wfa}g z9*qG&2(7keA!vgXF(3!)KE+zua48@}XjX?s2p6k93Ua8dKTo}BoOKyKpyP`q^5J6c z7g(sti7{=miC#e)`U zcSC4*`c5Ol*9i+QkFisfB|i>Ri~(j7hyB9`pG4v~I2Kl3@rm}eBm)L5XQ#!^nU`Y- z-F?o-YzT7W=TFd=wfn@U&cB3v9(rIY5EMC`wxD| zmz94t)ZX#MZBnwsi2~k7$iNj4EJnC$Wv+->T%boOR1Os_nr^-V!O#xyqS-umFh_zb zg+Jjlp3q?cHx;;{JTlRZ8?0{`Xdx1wXDaPFtzHM#f~V_)`%>mj6v&b;x|%b)?g2Pd zm41dNCSpZtDjV}>RJ_=*=R947Ekqx>r>&>UG5yh`{8CL-FKThG?D9Fn*+D$+b@dz- zxnm|1mN-ylLkeg_1#CS>L%+L1c5*AdjrZMcrpeOIyF?qE2u>)x%EQzsVgcP`R`D#X zg2^Xk` ze)+;@ab-grg9R#s#;UB2Qa$)Zo;4^Ws-=sjoHYEqAz{ozN5Yj4KF}!+4zqNNuYO&2 ziBCQx|BV7(m%kllN+FxW7ucc$ee7N`&X4l)nIUcbqBR6VZS*0K{CF zL0icg)GZ2ZZ~~XkZpt$aRhBm=k7!>#Cw3ymS{`FT4v(V8wC;# z0AletY~FUIzt%0krsC^jDLtkI1Hu&-2a8{aiM{ZW+Y4K}&lS-8C-Oj~K*s4I^E%H# zf!u5KkD{DU0?#Blf&%0o^V|0a+PJC?keBlb48Tq z6>zv-!O;Mdp?a`G6yNLBDW`(}tVBUy zpQ6N_IsFFG*}SKPCwDZSd(J1pTQ7s5CE&~V>l$g^GyLKQ_dhiP;d9_a@c7g1-DQ{H4=6G4y2Y`n;NDpl@)CPgFutC7F5@@eIn6l?;{(jx#?+;QV{+F$j z@qfyPGjK5fhqzh&ufctj^{!j5{~S395_3oF<7myXB8IdxWy1pN6)>M592P!V%$jV` z_m&nduPjVrgZU5>S^bLkWhXeQ7iP3>f0lu0HEdug0-2a53Z3e3z1WJqC3!8pegi|+ znms2OWW@42Bm4HP2laXAi942~|1tdhlh@PTCm11@<`sD{I!(NhYx90_9KSLbW*4$* zE;KT3r=ADW%jFzH*0^2PPc02<^hp3J6(KMjGpNQ87c`;y6sM6FZ7EVGgVcC%-n~K@DZ~c{eR6*QTnh-TIp)B({V#u&Fs{{!o(X z18^+MC>{WKutQ%7Jkho0JOW(ltRvY2PAacdWx?LDCN5Qzb>W?AYvZt#;1qMD;(pR+ zO|gjn%O^Wdl)r2aLMI` zwC^|730y4`T&g#bE5VmG>b#ulBle@A%cn6(-S%2UFUrd4>SN~m@)MddOwy*qJoI*G zquu8fQKdk1g^zF%z%@<$t*b^vm1`5|DrMxdcHz#p&HHDC*C$Ut!6MEg5StG1N~x$< zA?{xLgq6O`SgLo55^fNC4Jw8bK(C#+d9W7rPQ-I-!{gQQzo$gYnOUFAY2WlrHZ!`? z$y$~V#}F14MU4{@;^o0tqLz#y+90VN1Xhjya2AazC&ujqe=5`|! zm5j)BRAoNMvLyjX(EXtsS81aS$V3jHU0zTF8oZaJKXtqi`iI%Y@~EJ4Mx^uw_n}pN zTUSt={@k@iwTe5Al9c?Lfk3b{t~i*8Y(xq@sK@1FjDAJ4o!_nhNaWL&thwJm*Eqc9 zxc&LgZTUPIR$?<^BoeMZ&y#YpJ+H)cuF1 z@z2{fS~cRkSI1Bk;Wi&WV7Ejwn;Tt(lVh zMM=&xuPyBz30k|Qw!$ii4+2Iei+mQFqs~SE#Bp6Tzyji#_+EthQc|G>^g9P2aDcij zQ^-zK6AQ>*7`AWjV-R#oi5-{)&-vr4%Q~UF{o0^q=4Su0Ye`S*m9|cICE zwG8Z3loe&)n>*c_a&Nyj{^``6o85Ne%<8ef+FxSYJEBZ%g&}9&b^M08WU9$esd7N! z3O6oz(Z8z96Yht3B}-D*K=a>^U2KHL!Q$c4*J4?nn5Y%A_OtpcfrcGWE;JX;3$F6- z`~x{|Djrf}qty?g7*4sQ*x*iPC*Fm^3fvOz$+)XL5z9=rgmAFPkuQYO7k}se^wYSj zDnjjoFY?|+Dv`Y5M2=|B;k_Ch@-k}hw18bF= zDZG&_Aq@vPP6(1eG?<)`h@w)3U0m)#0ym^D7c2AG6V+9!w)pN;Pm~ZqC2}Y1nd*{7 zKO+Yo)RX|GGueXX&+nxLlVL@kP1PI3KjR(oCCCwfps}*BF8~DaqV(;@Ig1qxbqu$Y z=*TG`yq8=l9A!)dmb6Zf5b{wP08gBbrQXAP^6U~62<*(Iis9><)1Qxq!(e~Umf}m= z&wE;qv1oYbIZ9@H2hJ!SsNfE^zK29@YhG+KqpjZ~D? z@jFQVVGD#Bd7ABa7FUbemzro=@D~{~N;^01xqdFVXIeFb(22N9+=av)^~hR4j7y_6 zB`uj@DP^HQ=8*ek5Y?}5UtReqWFit(^6 z(_{;&bO!8vCB9~zT;SDGPAS#l>Fp0-Or>d&M=lG;f4C>BF*a>CS)aW12(JwC zBg2w~FH(4#MX`#+7p1uMMYh33N^GhdjwBtCULS6`LPHx!wWc|(A@t)zLr;B-s%BHH zIPOk0^UZ<o6B(iB(h#PP0xHs3BIp2)x^4pH>`uEwicT_4ETF$M8HCj{?vYp zSKH08VPI003at3opJ028TXROf;n3 zLc|XIYIFm}SIVzv9(Ohw$Bm@AKO4@p>|kha(cO=v^v2`>xp&=9K|3a;&=*CO0{fVVHgnvwhY&H$y3o{UcFGU7ZDc9Ad;~}mih@*zeC2X z62Ss$ovhED=`;&f!OBG)aiRD-(^8_TZ<*N_YFQ8O#h%%q$&wpBh7OdCqEQpg>czdh zE^9RiKwUsLH1h)#5KA?G<2WlYf+xF*#HLl@JwCV|w@CueO}+%@S`diR>@C+&98jRR zzhNe#u@_AU7c!-jV247}%a?B_Hg6QcS9H$V^T<9=yXl-$#Mk#``<5&BZ)qMenES#zU|%?% z`q$(%se1Yq0=7FFbr<(+Jo?S{)8|CBptgvJ*?7ji@UoiBfsj#om@(UU;d z!?(VCS0nwhe;mp1ghB_SZewYhv2UG{(~ofsW*sn$6bq{hA!5-y<4BDGp-P2&5Qd8n>9gef z>f+-0ZT)DAV8WIwsA|`l!4%=k7JVqez?7axp#U5RtC3{!!&()CW~3`QAJM4@l4J#i z=s~MpG(XYH4;_lwbwC-abOt~BkMew5ZFT6n=F42OI2%FQUX)tfSurR-kC)qrbB<9 znEur?Orsax$wz;5A-Wlub!!tOzTJYJUnNdmZhUy-0&oeWZ=pXQCtn8SiSB2wM!$Jw zAKIe7gz&=5N#MNFcd48$O`Vf+;<8$t8?g0wS|rOfs**A!G>L1Mp9vIkOJWvbBxfQzer~cT#ABBXea$N!l4Y-b42p- zl{Cz;hW(r2ch_{j!1aIiUjN(a^FPsA7#W%V!!tRozL~Ho3g^9BtM6XfkYqI$X8g$N zlcB;qLvna;Oky{TdYmt!h_u=@*5y_u`EU!(%pZZ&OfmXd=dxT!XU>cTi<6b|qR`kx z@zu(_yW&O194H^@c%3VCy{V_9~+&12gL2G})bl zAqesPe1#_#)UzfBv$>i`t|LQ(DC48^lLtA;!UKrC?_qUOAuw1kJ-Z46xVd3@lDa9e zcV>ggVxjR>5!BP|%sd%Tt7WKy^&o`|thqiV6`Fs07fhH%Q$V^jE zg3=CB?d-X{wJ%+F?-DvZgEzmR=uf|Csywk}B_)M@Pd{Mk;_-!oM!j^#;K~-se1b;; z?`Or9Dq|^}Z5C*G z*(jtH-9d(^`JcQ&gG1z-BxUD~=_Krr0YVu|8m@JvV`mR<9r!KNsOf5W=fu5yU@0+Z z5&cA?y-u)6eN^Wcl?I8vNe1Ws;0vn8t}1Lzy2dE5!lsCgE?Z+nQkFD~pp>7Qu?6@G z5)$sFOH0Ex)x1(znpslF6_W56jCCDSjdC3HanYLl3i{cLA}*ey{hX;}ubM8vMXplVqHV8+tkH4)75a%POd6+|o8KwmZ*J_;uTZZpWuXk7*Hz=}#g3g^KT%lLUDXvNW?b=9A z<#5>~`^#N#PjPC8SA*5Kvw(q%5Y<}-=nuLD?=hoeQPDp*A(Rx7(#45L39!vGE=2;M zX?MXm(fb%Rhv%+cNc<~caiHk4KFYbPe;LcP9_?Lym$ek-q4zDE5*j_rFbOO0rmI%xbH zm$IXv#1RBrqoD`X6uL%BTN^(!+1MsKTj9|!1nF74f1xjdcADn(W=IFjGJW1kgXmy> z!COw{QCUGps{51 ztAV@rQJuWu;{#8m)=E11(sCBDgb?1pi6mwW2~8CRyJOhA*g~N_Gno3xsWM0pCp%<4 ze*ywV4jgzZNA-<L;J++}2B~~VEQ1UueL}CFXI+uI$UPKX$adtRM zwg8$V?G5Rd;v<~BPhr(D6y8gtZKmu{(z`K3dlDPwi@wtosLsOlRbUzhN&rvFeq%E0 zmR;aFg_jS{1=9r34g#CwE)3^H>H_{ z>|o}GoF9pHcOdG#_Ej^WD~B$_(W<{s+?RAUdJnxMva5>ZWpWIFs`=}zn?`-}Wb-^o ze?9;s6=IdpwEdZb*k3S>cJSb2f$k)<2V^Y2VL}0AA^venrsTLwCdnWJ_NfFIKTs>) z_(kR{kiLgW@phpy7sNMY-ws|o6ZUQ+L_D!4cHx0w7`>Gh{`+kNfDUUYE#LHoZrO8i zK>_Ao&Wxi6K%w+W8!%k%LY`E2(cTBjF!(cWp`6SOX7iijpc9%4xUWGHbmZ&{W%qu< zeXzWl+m{loc6i4}Axwrv7(uAN%rw;e+!-J`N!b%rsJ#DgsKy}=%xVd{;!NQRQ#pI; zB~}mcvdSOaD}YC*tOjkW@@+qykW$%U%8og~om(}LnqMk~zT#I7mx&WWhav!V!Vm;N z!Y?R`JPuHEmaVYB%?j0f_CIe&pUaCB%rlOU5NP!s!=(x2<_UpHnuY&hKD@=IFui*BN{A>MIq^Cwo@?_`&r3E;I8> zwMY%TFGi}DYIezOlIDjAkKXzn-8ZzyttF}I=^4ZDVIVfxY8eMJCOS>;^)G!;ioZq# zqHD>T90CYy*z2i+xjo$wrZ9VPol}nN+WS@!)jDC>WuGtZ$3eWUztteLg6wA>sw7G{c2CscLB=FShwSJLC_`FH!G*p*Aa?DLXFSU-8ZI)tsFuhMAdfh!Kg;&kG zrzGMEY5pi#U!O?RVj2w{zx?yyl#V70?Y9&Op>^)vVGj5*uW|Ud7T|AWm}hdmA7dZ= zeuK5Uj9byA@1=|79+J@_iP|Qa4_so21MRj}CgZOQtuEg99KY39#{zN9YSv>*ZscX( zZ$4K{zkm@_Nrh?h0V+F^0-3DB78E`o3SgKgI%mH`m0-K)H*O^lax~ISgKq4%v9l@8 z!3L{0d_Wa_+klQ<0RCQBweuk(v6c!x05A%Ox0RD7c^*AVU*g;;%q_w^Vg5A`IoBlI z^y*&{IA9C}X7HW>9Xg#KIuh`jR@tVxgA`hogULC2yuN@rUW8OgEF$kEa3*oE2MUX0 zPTM3W-V)W~_lLhRq4<>06OB3U4{Mv<@HFCV^45ULF8*+|b&Y`g5L!X**^(KUn@{uq zP_^$MhxiF|HO1A@tn}&12MZv)1-u^Wjom9C<-031SuqkcI=@PtI_oshkE6i)4q9)x zHIHw$F^%%ylo02;KWXs)@VUU={DdsqMi!_EX~;7vrcZWahKjOS)0ZZ0VTC)$S~RQh z-mq{u`eR+=$`XMBLN}-um-DA85{`~ehxk;Yo1IE7V5K0m+`hz zF@JMP-%>gCIw+Crk+HKmS9&<;Yj0mWzFH^ZXF9B<`O-ln!ha&`V{d2UK1n7`pUs-5ijefouT^B6KQo`#0!NvL$4|46?9Q!g-atvwlJ>+dXdZ$ zWf|g;o4ukT4Ie_sr?Js=QK=ebn}3 zy2z`afvHaobaD}O9FmA_59{{EFd3vJe4cI;!GOLuh&hskeljX?^8L9~>va2c_SQCA zZZ(%JbyY1SXm%1$N}Ko3!3rzJJ`8X}M&@H_qgm3PbOY0Q?y|MN-k7#;Rb!+jM^tEy zS%*o{J@5I|41*B9s)4Z(T(uo7VLQ;6^b|w|a9ttB0LpwY5J9J^O54M=-q|7*XIn81 zh`f{%^i3V73_k^rk1PNAcKQZNM9R`!a;qBQcv^P%2;ldU}D#V2rMrIDrsc3X@K1G4& zIBLACkYiPEcDYM+xx*4+o(rN~m4}8iwY#PPJCAWm-FOAZ1RJY|ANqi}68cEKlLA#o zzOcv>4%~FgFg>Zi_W5rD(5)RG_0U zvn73nXXHKp@ZzFjmHJdH0BhrqqM%n-*E{pOg(c80=dXDee`3(s@rn_*-r?QIHN0F$ zArTNM)Q4%oytj6(X~S=$1-S3bw6#ukIkJ83F` z)8SFS_$X$ozvsvDHV7Hm35k|JIIBw06&eCI6R(P5+lTh ziH@8){Q@sS6%xmU^O)tjiW7SSlCz86g#mc`UR5ZF#|oE(_A*+-%-#8U>HHN#C>KtC zy>$sgTMsp4*|D(vN?O#APcVSRn7JfTAM>i!l7pidbr@cCAMgqg9lZ#1bZo0=qt@+s zPLKlOb{?)H`!Yl{sb-lqq}+9M4L!Hy7`uXH6xP0!ajL*M|Ii%qE`U=;w|$}lW?2dWP|WesU2cG^6lFtI_Q&gLsp+w|=|&<3V^p!<2j z=klPO8w5`exek<*%y>PE65FVbd@@}O?NT1-Tw2JX$feoQr5Q?=xKRiEOfnTt&kjo< z4dgZMWTa|tAXCEgMct*iDvs_#MQP}<>=q`u^`WhlwNEhRZ!p3o4LwmkotXg7nj>}d-{@O&Kfv{*{owZzh2MVZ$bFdKgiW#hmlR7DS~{AXoWzB| zsZD21zILGknsWHn$v3S2`FXZT-LP6n2auwxW)WBQ+o%w73X3t;j+0U7{T8&F{&u7 zpgfPm+)}a`o*F}1is{2+7r&(iHZaw{u=!dVvm>UFG~kP7Biuw$QB+mX5!=%qnbV7; zkn%@GQ^XZsK~*$ex`MmI$|qLu=D9!JqB%uzMC0e#vN|cE*Yh2Wkn-oaPBT)*`obmC zv_kjW;k8%X#9fhGKIluMgK%#{Xcg)SO3+)K@YHzI0l*-W+lAOC@(s^8rM`di&q|6v z7z&EB71)s@3^aQyn-@SlKL<}km!{l_!A*ylC|>Cb2NOvB$`koT5Am&E*K?W3#!X&n zih+#P_R`KQT$IdMKC`A!5@XClr3%F%;t_cm(mhrBXt!uQ)WFgumh<&y|C$-VM5Vgt zQZgaLfV|5{?%^P_B6mhRD=hGB{7?LBXU9$rxB4bO1DtihW@`#zAcu!m)TU?ntSyg# zqXs2}==OB9MZz*?E$jVu4&uAuo!`wtf6I*9mcwpCu3NGL6QdgjZsHA#A;+yW(25W@ zi8;i9ZCXtA_T#v_GS5qB3lpCBI?*w4pDj*9?23S2xle5M<|E{jBNkJ#vV5{eym7=? zuZ63!A=6zLQFK1Y7M>wkPCpOvFXE0-`ShM`_zlsKfYt>HH#~7cECNrm%Kh*29#aTA zTs)r3NF=8tF$SGF+fUF>!9)k2{L5Vx7Z>kf&Ln!1EtYNl-sHh2I*n`OdipuEJ-1A| ziK6}i{P=JnF|aoqnf6#M18}+DL1;wMT)FfIeKb!lZ`A`1a8dsM!`nN?XcDbqyKURH zZQHhO+qQe!)3$Bfw(+)m+BT>AOmcE^vXlK|CtvbaQvWNdwd$$0)^lCA2mLf5Ar`xc zL0Ll7*h9MYgoaIBpR?pXuzaw|tAf!b5qj(!=>|BDqMs=KE6ejx@!SiO~86 zsEhzoR^cdoOzVV_l;A~zaNrSy>IHOs3vI&h16#GGD|TyYqV_zi9@K6>m$PPmeoLN*XOz zFT_)O03kaZ+%m8v2ZxcII|BMxh%sEdnxvMiJHKLAz{qt_c(O^MQtzoHx^M{|IXVPn zcA54gmoG*VOQWst(Yg1Tk)D$V{4B}wSh+)3bSSRGzC{kbI#!OSPgi-LYC#7<_uNX) z@fvQ@Xgy>ZkM3GtLJUIR6Nb?4QJw|XP+wr}KcZIy$uM(PMwIJ6J}5oImcA^tmTD@3o1K72d<^+uo-1MwjSt?0nW(k+#6+92W9Eu^O>lO z8=brkGmYWxV#f^n8?D6Va%~a6coO?$hEOy2jCWjTh~@I)QA3;KoNE%@ zj(dX-q)J4+)0Jbf!>ukM3ImdMCQpWckHdnJ3OFR279P)ZaIWSh1ttj}O43d)@^CN1 zM+}!5k@j|1$rC+OaU?EyNU%v)FY*GlD-<@4CW+Hg88h()KYDlN|G_TcCtSLof}Lrq zW-FNJDvq&C^C%c+HB?mj6c_WE+{J!1-`^P%SL^_se%VDbg54&B$+yzrDU1tw3^bV5~iAyi@R%R>dg zD`xRPP!mO3kE;I$^+LW!j@^wQg7qG~W+qVu=SJV2N{Q?E-5B@7g37?!GTw=FO5dBy zm;)HQq@^FujHATYN*FC)FZO)87Uws-*FD;84u6>f^G$tfCkBn>s=RA-r>N_9KAonG z;-uyUKgwFMtk%ECLA*efI@YdX2m}+@gf~zLe7J^b{w+{Trs7F(NY597a5KY+{?F(W z$$2xM{}+Ba>_O_k74H8Vurb^J1RJw+{YR3DyP9mmG80nYBdwoXNgS?V^2)Z+CvcM+8e%e zh_;MYo&)s2c8GkLee_mN;9Pl}ksfP&oFDG2-ft1jr@zmXNL;N1@POjn zA@qr?h(+&E2SQpg1e5T$2pH;(xik1;;n2Xl!K+2C&FdxlH7~VWNdV{w)@p0nPI3|^ zYsTnI?`C0NcmX6FPP{8&O|~-;mN3h12{Hxmo-kR7bfGG(ipG2PKf}41ztAN7nTvBw zS6ROtA)k-KbtMu!xC#pf3YB4w?Cc0n{TCNN5VAdNwXd5sGfC`?tE)AIAzUpNQhgXo+vLT=>qk{}4aSjn~$v<}&hy z>HMP{nx#usLYv+>-$$!9;y`{LMCe&>N7c~%u6E-uM9H`bR>WLI*^hK=b=GGrbUYG; zI)J{A+A3@GjQ&83YAX-qS4Bsb+|9?;u8_Y4ORDR=00x=5Mv}a@!o~8j0dYRSR0udh zc1f2tyEOam7D?iA(NC+(tFCu)kl=6g^k(Kb`9P5~`z^FRzXVD^sxGVa;_C*bY> z5VB|c-!LII_W$TZ?fw6w9V$WR!r+{VrT)mbS!?10T+F+c$>u=m7m>@+DrMAAUN5_0 zgSu22t2^-LwTL_#wXV3kVYvdiSD^P3c#vI5D!;V2iz{7|c^v06ML`Y0r=$t-ad>}! z(zq?%OSF7mFUiX;Nc#ZwfWRT7)O1PY31vWn_3ZpxoDB^MUbK|Dl2 zf2;7nzvS?+Jz&E-BhFuVfovN|FuU|BHML$-T{ZMx(;jyLYDWk-77$@TmKw7IC);~JTWBecB|NpiL>O(cHiY`#W{(J zzR|TjOqnxlE9he+L9Ux73&G8TbRNKI3K$t{eCf?EoYq`1;fXX1tgO1Mz*~u7uxe3MHZQP8KJ3c*z&z$q^5WSgw@msOxJ4NcJSW*Xt7DBIkq%UN^f9U3B+6nDV-gjl8S zFb%+dm(g@y|s&K|676$(gUEwaSeI zeq*6YKjWOL_tk_x5u1>@UHt8<2X01NHSdugtpK*b6c$+-Cv|vgqQW@ch^^`VNS9=s z@7JTK;RB~#?-Te`PXw^%zs=R7s8=1w{S|<_&G0c46_DR&{7c+mT=@HwXIgzh*>aeP zVz@_pjuuQ@85ZWOO-VMSVZ^5UrAWf^S{%2Fq|#kHgj$qkRfD^An4{Y~lOBT>)wdzL zbRl=f+ek^y(p;c5YzE1gwci%EZ0VJAlGeH8`q^@q$s1UfN=kH`Z-l+dRE_u z6>r;348JZ^ueYI)E>AF+yLS-7wNcwmq^r*R}NI38wRa(=i5P=jG+L;Q}*p>>_D+)|0N8#bBIoyfd z==Qc*dsQL5F0=4YU{!|TNL)I)9Cp2-|GWVNFG#;*vaF!ep5g-6f+SxXkn8FoW*y0A zl<|;<0G=JYir%Jvyl}yEqZYdgUKS5*Q#=psVXr0JQDeYZ0a70G$LzzD{++nuF1;Kg zy0q7D>=Cn)-|2ZtHW4gmR)I}+0nZ9ps(pw|O;O!TcEQ%Xwi@ex!S@_2>M6liS+r-B zrfu+b_%k_CShlqj6d1<49KIo!_X2px23<~1FZe?(B)D9|jxNRWB=M^(ZTqc3U!S>4 zHXhf)efs5FapBJij7w6w$WXYzJ;TECTtCiAipu$$N#~rk-jO-GQb65xXwgKpj`kE8 zjsEv1Fqrvt+dr%M`t&hWFcH+Dq~F4rAp~p0-8fu6ZXf2Buoao@5gCg?u5&2-wbQ>5 zGG!Dz7>3^^;r2La_6t!!{1y(G1rRwpk(~-E3uP>kIit#M``*R~Hw~Pt7wyM|3pQjI zBW7WKFFo1Ag9>3M<|0^%S!(AZggdO7|a z^m+0;aG0lk!oL-^k#l(T&owpg;2n?8GzV&Aa9Rrky+6}??!bK+A%=Pq^Zk|5W(fxVbe zNWjhhlo#lU=M1_Yk{{Uz|4ArpAEmD?GecTiz0yDrgEQ+kyJ=fj?54@X&x=fNSB@ku zf<4zADQixFGVlo)?XB(cYJ()G>CoD*gMMTAZGf6P&^gR__dJ?ueA6V1WNJr*%VG(L z0sMw2X>hitL;9zz)1{S^Zie6#9~!6Dn=e03a?uRp$KR`Az+*&!z(CR(G9mwqfu=z)CAYap&7CTJm_k_ zg%5>;vRwA^uhk+b)Cw!I0INV#pN%Qv=pDuy-W>3mIt%o!%K3lGc zJ7HuxrZ=NAB53J?9Oow6Fg|SBtTBVJ=9ui_z6R1Z$C9L(rn*mUv~#wHa?x27;BQQg zynP)Wk%?Nh;tlHAOCkI~-a=9Y0l9;7$TidxYulyaoulI+O#3t=O$vvm1+;;MYX zxQU05R&D8HU1dzLPMMa5|h6y7Eqkkynp`0=rzsp69Q`nBdd;*Pk6TJpB6C zP8>vnr8Q`A+n3BqHHZ^Vm;(xuV{4pDz|!bZ-va!u!v$_{G!r$q`~^=Wpk5_PP5f zdQp+w^ap}0z1zFqP&GZgn%S0JT&q5moxt$;rV7_ns`!G~3FRF4 zM%ax`<`r%`hq&bTEMq(_xjlEXwtmio_a)rJkc8~kc=W3{zCG4<{;`7{P4x|wK1J*W zM0cO3&^8|6(kj$n+0^b<3pXJAd5jnt5}*$83Ui*n!D*g{8bmOOk(V2M-F3rtz_PML zS=GPcJJ-Mr#N`W_G#f_(;3n6o5@221r zXM5dY8MJX68W+xBKze!j`xF!#5tOFN~-wIXHJhQUdnkLC}knga?5Cu#jAerEmamMq;ANH-eaBxx7@M1x&}`a zMCe0eOjH^wDQ(Z%EmCJd>ML1SORu4&MX)Af%-DgzUJfRX)X-IW%Obm7W z+Fq`@`Z*bMVr3;+Lty`0NmNjcL-^9D`k2){;-PN&FlITY=e$`%aoRJ9Z@x39K=>_? zm+x;J7p(y09hdUq-7Fi-9%PD_Qx)`{&zY`?0Jhk8`CwQ}Q)am+nsr(wZ^>5qYlW_k z`MLR=AZ*z>sV=j86j_8ZIY^K;3!Oo@G6<#IJSu$@gk{vMq?OUIXvCT31Au|*N36%g1`_8TVjKy z)qMfoRzuNNMAt$ECP*Me_S7IRS=(GqGHaVv0{$0(6(YoVj1mrn;MF=~1e?SfgSpXQ zV62zX<^$ZLO+Wb@y5rg>weBstqOJ27OAt}MgIPu@xi-;{cCQrZDH+&tRS=+kpGDyY zSBG(yUaQk4-i~Z-9mlc$8v~`YvE+yI@75UVvb-Z>o&=WSrAdVMG44H>_EgF}8y`0U zW%BeUG_fuj{$ZyQIVix`$*sDye(9u3D!oVa*U`C#?}~UmsT%vqWx@JuXsbKdvVXPv zn{9_XArRek!P)h#IAaaMDF66IvmEviQ$}sIOd0x?U*u6!SMZfE>|@Pgb6L&J@!Ugj z*x%*19F0Z9En~A{TZBcI{P4B6FVd4UBd4_kyZOaURN`qE_$G42bhLkINYC#0MUz3JJ`^!pIJFEw`jYr*)pGlg=ls8PmPgfsKz{DoHgyeAo3s^Npjov}NA+ki zab)I?QOZ!L-;p?y-$e$(m7#P3ex>Yp54iho71F?%(++!QDFJ|bQ~DB~Y_XY~ev(0{AiOt!A6ulGb#-2K27%TH zBDDld!rC+U-gVGg$EQ!EQgHG$!+lYC{>v4GVjsq@oeVaPGxGZHXu6T*w*9q+Rk^7z zYk{751^JnwiLgXOYLlsZ6lSCy!|pii29>5jK)E*a!?ALH(_Bch_{ekMYZWqb z@ZLhZWu!oAG>ZI`vqQ# zSWqt%i^JQ8Ir&g5U4xH5uJ4~%5BOHKbxrSgKXUfe&D-@14C$uq(bgOlO)#{uzlE{Z z{)?DzVq7xlOl1U?((JSZt@Kj~vohy$vj9Z-d`47d)`Y zE9Im*+b_iqn^uM!d96eioDvnt8yBI=WG`l-k-XZk7ZQhQik2)&%4j$?{p1 zAjGx`|8yynhw_>&&`ah$CVjR!Z0tNo^AX}yYxfa&#Xw+Wo823tPHQedkHD;SM_*Q+ z)BB=I9##SSd&I5Kw=ajv|g!e?w|?O~NQ2e2;UjVq_uSXUQOq*;tR9aI=n)>W5j z)3&AQI7HLU+o#&j#%t7MXyt9)L7;mRc^L4S7~Y$ZrdlbP8}=?!>(y0f3uswh*8R5gDmC&Cnx7>P1dG798@rm=9 zm1YR9@jVh7YqGaWGTqlT-ibf#lfR5m*EcI%s|lS57?>zSSJcG*6gK1EX)Q@H93?z5 z3#iN$mt}hOdB0zcTCNrPK~I47&!-A&H*c#XJho3dadB4zeg@shTJ{;HZF88q2=xdG_6_G@fV_PF4dE2&CcW`mY}x5>PcClrB+s%$G;Gb?8<$TeoKz2ds&8 z!GHKg#M4&@Iqv`y&x(V$7rwtzGq}Oki!17`-}Xm9V^ROW>g}4_Vc7MNSGLnC4w?86#&{iv?Tg|0@f=@%L4Q+#Cq?z2p z${0-x+JvuvUW)36lwKMO1%nqG2)Q7aBNi_IONjNlV=>G*=D1E8k&Cu3fp4f zp84Dn^YX{ZmuFjNmq;eQ6J@6%dTy?fAW)Sjr|qX-`X!}Q{6|O*jt?zwG)29u5WI0+ zg#-&%UoU3?*`Y2aC5Zry{v;jR6Xp3l$^>q=mZ#~x({LGKA>$ftm4``%8~ zep2PvH8AK)KtaZll@QDQCexW*NF3;mxNv-RQx!@Z=s83bu1=HxPDlI|v6P`YUGFl> z3wnaK2P-hCQ4CQ2oyn|}$@~m2u^9&5F`XnAp9<>b5<3Wui{2kGcpn6XEu9KmprxBB4givS+zcaDp5p$tQvltrVbYCVK61w0(RE z({A>H2fVu=aez?RsPgBkAppN0wAd&=P->(RGH~76w;R^}9?Z|tM18BE!1+!4ZKBiPXj5x}@R<2C1-_kirEtie4dvug{)&pz*Brj?Wx4?~Uw*>#3& zLS?i%(Eu~m)f7iGeG&%215;%#jKEQY1P{saTR2Ug2339^ed$l3JCnZFlW=JNLc7+u zj>phum;FZZCkkX@Td2-NSLK_~?YV|f2>k7~W~meZN#BGvSu$w&D$#Y=8X6repaO0> z(e+H23e1``uco3IhQ&kpT_$J`Lm$E9P$3D?36h3uuD-SABVYGiu~S9AcJF_;wxWN#I6%_%p!i4Mi5vQ*@pF~>fysc1 z=9*x@gMZCi6Wy{x0g5m@)p)HRaZ%de?2Np~e*k8Gj!S8K; zI|Bs2)mQ`HfskdES{v?qj3)X+P@`pMM_w$3k&fwZ#QZiOtMZl%%Bj7;FW3oTsI&i8 zrT!;ui<#>`BUfs*{=dkTecejANu-|hOo54}E2<zP;?%cvHSvbC12G{qd|nKe5&``La(6YbE(Tp-o6erGYg=kN<*zfe&O0a z`&0)Pu{>K6-4vA&S?1a_j|vc3_JE6rLWg9$=r*6UZLArFB?|gjpF4KH`i+@IeOwO_ z@L$|H6`8?va^lU#hAH)a?_78E>{Ux=9I|~bW$mYFLs(bW1;km$-Cd?I;*Jrg2VRBx zIq@x?kMEJ3A_cac=a+p&!S}y@_2XpZ;f#VVYxcwAX~uC(PP(ux$gKl6uPbM>v(M?Z zQlIOVY!Wg(fIPR^NBx$pI1VmxI5?_?u3eFS)Z!_c@1i$(g80XXM5l!##a78@Q;rUR z372fxyuI7V*?I!l#;)7G+$3I^tmTEH&QeOB<0bYW<DMMiH zlQ)@j6i$ncxdc#iJSejmc<**9LI%&7HoB){-DnLAKUAM2(6o_pc=4+fC z>LNK9Jd99I>dhf&5LNT}$_N9ZJ5AxJCyRacu&rh+zGYjLR8qyZ)X292B&k7GjzDj% zU{gBh?HY@hst|DTb-Rg^xEOSAm?mT`wC7ZJn_oQ~5BJ2wH0&QXzN_eAl&PKO+Pvv9 zK;~BU360n%Rce-hlJkySOue`>`v&t6YSlJ2Lu2vrKb!0ptUzs9ML^+a>V83}Y#~YD zHtiZKNp|8DR+4E+tEg)9oG3RX+IeS*quY;#)`A{}Mh?^G#%QdWi+@e}|GsT9tN#Pl zid36XxFw(gVG0CK8{k)9PVIe?S7ycrw-&@gZZU};J_^JXZxcjYx365fP9`iFBJMIJ zjGaO-fb0#l8JkL!D%K$@jX#<$Ur?& zo)SBKiG5EW0lKF)Jegx-!IrNtKb~)8kIis*wO)MZ!<@!+c{XzyzGDlRz5OCEKe7Jj!il-FXW?Z1VAVaU`QE84 zm+^$PamiCu8|e01HgrKv3zuJqZ^vi%z0CgXrJ8}~#vkzN({sz6##4n-5r(7fN9Q{? zdA$Op?rC2^A6A62g?S@woi$-)&>maj94z&zfLKu>68B}P~?>B+q#wZBf45q0)pWymQ zI*waQ^W?EpmHdg|@`6r0V+<$+|0puog_(S{8oELdf6TBiT2Z=*KR37coCHJG+W3Ul z?{E+9Op{kTXj7*|2bd0XuXL1!T`BpgR*7p%HF4%ZL!x&GhKw}L)7>~o&4JIs_Atz! zoBPyaUzc|{m3-Pi{9c}>8#IcsRK?i+P#^2(lP26?o4{$oBO%eiTW4NDhS}i(H_Xii za-sOU2=^0@$K&L{XEGilUg(;Ur=^uFpNK`xKm&JB(mR^O=Wb0sOBTb5n!~a859Qwo zcNsu*^H-vZ7S*>?aG^nPVdzXj<*He+yLp!zoF6L$op=<9DL>#qhVMrIBxzGlL!60h$Kt6{J>E# zaWC4h_X}Kq63M%M3ngxK6Z&ov^Q1-wKR)Xt**AusO5ku}?HaDw!DC_;_aUqZZKOf1 zBGSX<+X{x!IbdpUE8KbsVXO&bd>KY1j`|-i(thJLb^SmK*As_%7rLho(5EafgHzmj z9hxZ$KnF|oPI+#ZmMD0+<3;#u_BfUimczpQ5$5;6e)6Gdz$ig~Z)syiN%gYKBxv!&2C6LmWbmZtqhvEV!!Q!;Z`8ke+Iy`)nvb zWm~c$i?ir^xA^rU-^_;kt*v8Z8%&68Tv8hDk!bZf-e!?0VJ4yDQmtKR!7cH}dh!dk znJ(~&{9WCZWE#qdb*gMt$`db=Tss@KvkFpT->M7Na!ciS`JT${|Mg@Umdt%O7HebV zTpo~jp$_3!qaK}$QFnsM;w|6#l|E!rgF6=Nn$7MR^458O5{e@DhmZ&*ym0sge3OTiK&8C1MZLB^f;}zUJuSb-WCgF+7>c?)qFMa z8$Dzx-yP$aQC-Ni%bJQc4#dg9vlc1s_lt|8UL34S`wd)<>FVuTOLo0-u02rg&RGoJ z`hS+xa@40_*(Il6gs`Sy&3-`w@Ly`Dx9}xqy*rWISJ}f@4CbsCg2X#<_7?EDoVC}X z$O9&}$m3KDU_%oxfw}DE+xds%pmH>!6bvlCC@=+q%N@PiLZ-9NBh6g=YV+~%`Zj^_ zc-e+52O#F)plKAau7hGuz3p6Nt674$ItaZPj=U+Yd|P$W8Ni^a7i6VGXpw2FRq_=S zUNtDwa4i|V{6X97KLu+a@Qk!qgA8#IZAz1h3cb7k0BNr?Yp*4Xftx0!_R5I&yK5$& zfa)>cEHaDa;Vc>OiP~cewSLf`p8|~zG;TmPbOcP`04q8lv<6zX%S8f9Owd6W&|yAg zaRiEiJ-yw*(I&p#84T$+zuDBx*I7=!*+JfdG30#kL3AHoH~k6UaE`&n^0*`O6)!OE z&FIye-T{{0gWLF3PhCPR9!-Q-qOV^p>K`%KlJiZ6D56Z8TQgusK|QJ!0;<6UeS2Y} z{1{^9nCgr93^>)Ft<9i2yz= z^cZE{R+Cn^;)-W$(9i2~RY&NrkgzuVLwrE=8btUKkzSXuApa5;Ot4$ysD`%bf&@AZ z7Q6^}^Ka1pYVWT|?dZG%eyUe<23VLb6yS_e!Eva2z7>Xj;mMn_mCg38CXE&79I}SLH39|!W zYi(eZ$91#W>2u>8yuNkBLsEYZ?#!|BX8az@%{pW)+V3yuXK#rol?#Ai27cvX!%k1I zF5@)!u`?k$3=dowS)y8}zR6Hh?vnAZD1a9rZTUmvPrmoHO?isQa7&)HX_J0!qp`py zHtz;ZZ%fnHc58K?*S^V085_pC5auO#&(|autKSm7v&|`S@3`FdOy;J8U zGoJ3Kg9mbK)_aTd@JY$&uV)E-E)~6+Kj*6qHnL%k-rxRyyxdv?$p~H5Elc+E|VS7AhDPJVSJ?u*eVL5*=Cie%O3LZxD#ECo7%$`kRcekg)Zd;(7gcN zJ)PZHf!6r3@%v-zBFdEJ#_!L_^S3=e=l4A6u|p%kXd1TIm4E6y?n=X1a0L%$d(X5k z`7DfZv0ya{fMz<{&r0Jr6Kylc5w|^FL(;8;7Ft^m6gUVWHE#jdbsryoID@QPs^6t2 z>Op166ZNJ*eX)?o0o3(JBh08iD7at!yrq=ReJ*FdWc_dq<&hcRPO2M2&yo)Xs>th7 zyAUoL7FPU^Sy!jht)WihKP7ZZ!qa*re*XRo(<#VvX(;Ga{bx;`Or~w&Osml|WMnJD zlT43Nx5ebBnU9ERUA$T#OW|ohVA0HR>E>kh_leeJTVF!Oe9E5W%CDza#Gn!!k@Ou6 zeeS(W-WlK@P<2#=vFH~7V<7NW9Yw`|t8o7l(Za&P_8PHe<4alusynl%hx&zI%mzEzG z^!M<2GY5j3`~q#>ou%U{TY{UE5$-TP%SbnGszD}V%Z?+Nc+5nKhejEw+;c5#XJDAO za%-RL8s($yBXTsQJHDQI@PBNU!QCR}W51>tZ7Od+rJZ-EE}23ab2TaAx}egK)%o`T z!JXsIW^OlDU13DKJXRx)r&g0kg@ew@sfgDx8IFH@QOu8+}BF z==peEBBy^XZ6);*DI3dS;l_lzbKPC?4}J+4Ks4zATo#bKhA;@E)!A7V$1wd2d!Vq4 z)_IhpUE!xxcvlJR#fiH>>N;47(vu+N@>(f zvS2be$^8wND9Ll_pQj&!`yq|m?b8^cZPyl1Vu1Rg=c5Vn%yh*IgeHWz%(B2vj#B2< zw3GgDJtk?Gi4GRO;_vkcVfcA_Wm3;d+70w<0!8wzfep3?>Sv{A)HsIK`~lq=jDWQ6 z+%fkKu@PLWk`P=0@XRW1k#ygxi%d_$-7*YzB(!*&mQ7R6f6L@6V4>asixlEVIl9_f z5@N2GKmMT1AwMz&PC-I*wjABMiPRAq<*aVY^r|{eY2dZvcDbjlQ8Ov%&p)H?xIgp z(gUh2QMk+Mt~GLN&$#G}hD8p@_(3a3K)08J-v~~jLG+bF7i&H8-d&wup5F63jr3t*v3y~I(V3w} z)P=^qBgCc2mJc_87=Gv?=Vog5j2%a_I_j1qDH-Mw4BB>4Vwn*v?M6i%GXs=s&s)XC zK?3oSh$_-fsr@}p=1Bl{d*KJ^n@hkNZ~Kh_hY{}`XNC-{Ajc`n~8MW<7*zN{hsS17~K zGI5a1yIKmA$npB9uR$cHw5uEyP4AB|Aam8us^qEIM#wj3!a0q*%SxRb(03>Ir2F>3 zcz!YbJbF0ex2aXB~Nnd-*4L#~F*_&PWJMON8(;fI@Uv(I|YV zKOuuNkCJ{Pd0|H~x)3Gi_?KZxU)#oVdnTg=2Qsy)wMfJi0rwShlt z5jEOvb7+sb5%dreT*>zJ{d?j!waVK@=vO>!%-EgpqW3)z%!k1ObO;FtCl(bR0@etZ z4Z*akAELm{6?F8`ZMs)`6yYE{V7l7LbaR0f77ED>rAxGQ-~dBI44Drud=x+DI874T zmBPa_tUE|Vap9z2Dy!(SEEdm85a4LtA&zZ0%#S%$=)`Zl!7GFNa8PySL*3_{y^{Ex zzzF>LZzkz?cag%i#HKA-CbDTt zyYI(w97i$a@IDcHIE95tR}^!t94-k7amlYmbBJQu?B37CzmobC{%Qg7YH@_*0wddz z76z?y@NSLxos>PlMZ|nOVh8am5jMPikWhvTVK=;=kxHR||3t_%s(!a*^88pe@|Cx@T`*-L)<5WC0WOLCd` z5hyjCXU-jheMk@uN~c=K6WG=-R58C+hZ52l?ulsxK~E!m<&V{Ri~2p_77==^7cJ`mSL)V0(vd*E5e_F;yUXV`HlvOA)$BsUB2B> zJhuuOqHRWJuh(DQTHu)B?wj;Ve-}llRR=@usrt`ovxK9Eb_{8h&zaU4uHGr>j#Iv) z%S$P)(rU^I`(z;e#*A>u#9&lT~uNpa( zp%+2~&BA*9YducY9-k7IwfmavQ%LpqEVMWc89L?XrLRNJL~@oas}B$q-oMN56hfPj z&fNP>HSL}rmE0jm>wWBlyEUNeiT=1VI$i60OQo^2B|A)`%g2@$o$*^Lu+gnZ4>Z>K zs!N+o$Cj7=v#LOQyhB1)0f^6^#M`$ss2I1TxrcZaEQnb6DvE$Jh8Nx&3`i!+9`?>fX){cY> z_PU0?86ZRTSQ80P`kB|}ou)%b$H}x7dVIMNmwGG~jEntG2NitlbAP9=&AC<|=@}*F zEF~6AqP?!2uim4+*MKC8aenYmS~2j-2iW24wi!ihhlO+_Dzap6H;-HKch+pV8Io?X zWL*CRk}6h*ImbR(&JtP9(r3G`G)82?kp{g(hAp7@FYc-i_=Liv*D8Pvf6Qak*w)S+ z!d~p7&f8+yjeq|7qHO|q>JHP0F>L1Evl^HM+@%`2SkT1s!HFA4&Uk^|U!z8BOMydUI9cE4hU z0(c>;#BC7r=cm)%So860nGlz5ENBM7Oe-YKI&Hy%qoF$DKy?M(jCq%^#z+MBi-F)eepJC{$$3E1Slhqr%Xy{uX zY9Xv;~{f)CC zKX9HSK&>Jo$S9fxYhsdIb1a7=RHO*Sk<=P|Njv7|aW;3NN}$*4_i}qo&sCc{8j@ia zvq0bC)>c`z4(2o&)Ys==U&v#=8(*KuIguIW@X<&>51>wQ_i1?o{AJl#?xAGC*Plg^cm{3SX zekGEUzFYol1YVnOn|kP^&0yiZmJqf1mqvhqIqm&g4JT@OX>a2Y(};(Nc(I`TQhrZK{`H&$$A z(BE{cJ#92Eqv5#%#Wq>^feZRTk--Gd%AV%ym~_Vz{fuu^JaGEvFGK6?>KyZdeNIcq zv6hk-C`S01foM{L!$-&=Ohf>4c-$A}NuX9D=IIEw*)kH`eZu5atSzBZx~!V!kp zhF~SmjmU;@#uJVt*%1`Bk0GIBj1#f^IO-fOWG?S#?jP3N-Uej7*k#xtZ9sK;;&$Co}^kQ;$-;}fQi(J-~A z8v|->ltOgv&LXL=9~^F&X54TKLkfW*7WU2wViugB%}mYer{51To+sUZ0;Ne^^z{Z) z03xTjVsV1Wf!YbHe444j`knZwTFE4S8(-XB9FSPw^Y!HyBSxXZx(2UQ?gBkW)S2qkROv8=pmr;qjfhWIRyj7o{iA79$*pLyU{0Y z$XK86njdBXHKe)bI{mD>_Ar(0hWz>RZu=+wVS$%Ji|Dz7cpMV7)QRXQxQ&5U4x-Wb z{$bXg=V9Dv&w`thh;(|GFWuk=Ey#1Ui*9`zh7;$aBel0-dfJcgqWKZ?<}38G*$%!# z(Hd6H+&6vf?>#VhCF^EFE{9hbXl41*MmwV+H{)JO{cg#e9F~1Q0iVDjIN9lpi0I+M z-MSHonr#AwP5UWjti6|>@KZ%O#ble!5OM6aC{57G4 z9h&%SXy)LZUzGqp3Ua4v4GD=ksvp=Ca`h6Ubx8bJp!r4R-Q(%E-_`ZK0rX6@jM&Sx zOvtg}Kk8B#Y`W`wc;@|Ql*ncqz%h!H?#7Www>Ac`V%76{{UgI_>>DdPiGhz3tl zY756th8tX{%(-ws<{y9+$MzSi@Ka(ycF2UpU(wU){)Q4IcI;}ljnW^n4{tnL1av;a zKE0?^O*p^g%aPz^*CcA9FHk6f1wm>N1CHIkg35t0MK6>#y5AP@s}8FEt#$wNrfu|DPrFph`4VP&J6&n_Y8Z0@g2f?!4V{-Q4}EJP;_R z<`Zi4STUNkQjcdQt~H);@w%{gF~9q2R1OhMvCpWW3oqK`Gd^f{FC0@@EbI2Q|64RS zPBgX(r2Kpqp%?C-_^>uu+UFmWW!!A)`Tk z?8EKqt3;~89F`Dspjw2ripg zByaDfN1VZBR{b(?J@JFKvk#ix}E-B#^LMQ zVM=JEd6Hg3OIY!!T#R3YyV2h3AVdg!dDw+Ab^$N1o3fq1#(Zi7-Q5-?ot;mc)eYse zi0+HnCEpVUFHNYa4f{ece?$0RCRCpMoA!NWZF;v;M0!7%YasyH+5Z&Fg}K&AH;hJn@|B$HxjrO z3>8lsJLW`~uN6-eJiMq*HYH>+tUD}W-XfXmj83j8`<$r*H+J?BD^}T3__x8o0*P3V zUc!yAK`{O`xd6tz0I20ub5a7qnAO6f6LXHaoxlxyQC$ul{ZflIj~)oYH8x(Gfh7Zn zO{R}B7?V@I`-p6p6Unh-(oiemxX|knRkiwarDG~XBYeux!fMSkqqFu-iZe3uB&c#i za@pqQOKmk`Z+r76z;>i?765t(stoyqsZT_2sf3TI7BhPz4Jc8-fu*Cm6R2 zb<0LE4zge4R&Q`r;CLr$O`sP7lg^!TbzpUMtC>L{eopwYKn*a}Prw$Pm7nHI00wU* zA`tRc;?a;|)AT!?t6>)D-TxmI6C9gC3dMO>C< z4JW4G5c@mt1zep(nVGR5Ww+qx1Mnj8U+1G5lW?-@wsTy5BpLSlV$nnacq}6!sC8%$ z)2b*VoA$lFKM!ucrv>+#nsN<`Q!mQ2Ubhi~yvU0Bmd>-e*(aPOwsjgn1n#^|1F9oA zuUTyGC3|&_?f|7JTaqzjhSth4be{~-&U_dpEz}&}K5FDY%zcz??}qDH3idUJx6^U8 zGp+VJ?SzW1t(-?s+mz;MP8lC(zs4itm^!krz5N^v$5TMiyup#2ZpX!@dz_2-qgq1_ z;4Py#P%=Akk5S$Fosx`nxnR$_s>m;h_k6<{p@Obevv|nqieN_i&XY$E54x)_J@a^PWAw2 zcl9V7StEUjm4R9B4KElN-$cxew!G?Q3JnCa>B6(~yOrP%T9POGq4bqrdQn7RHL;yO z!PE$M4M$)9VAJdS`}};p-?G$ap6Wjc><>3O&k)`sl1iX>8-4PO?Ry)2TO@ ztMD3G7YKW~GAZ1i;m6BPXLs8XQk_fWn)15%A97^i6tDceJG2_>x0_&aIWoH*C_1Lf z$!zH9dOX=ul`|qCDH%!9GKtLuff=Do_h0%3&^`>=s@_D&ARoDn(YkLv4C9g*^AcYn zEdU+D)&(bthe;1Dz?3vErm$oQcuNQ6762(Dyaq`KYut^k=e~*vqZ4O-P>g?L#3zIY z?M2mRL$C9Qlteu`uej8|3}LFK(+v}vHTIWclqhUToG&hOQ8YrHq$)*lVyGw9GflT77bTc4t1C~?A>TIfL!!b79OC+%!D7j`1prHkXbBAI zBtgTr3NoX;v8HZp#2mB=$POVl5*OKLkk>(>S@pM`3ZApj4Pf>a;26y#f?+t~hlzRg z2ezoMUbMK!h(SN>FTK~jgG4E&aTYav`?`*kPKqZSgkW-7G`TJk4gNO1^#J;e8TuhE z-rMPzi-jA-yr1F$AAK87@1r5yQ5=>>M9+a5xsMbKDOeaKmEODwZ>*OpI84=tp)xj= zoQ%i5`VDoj(#c-bDzd3R#nN4Qhs$JoA~ktoD4S-3O-OFwA-3$LGsT;Dlk4JJ6?Fqa zFi-Qbor(XRzI26_I#Cx{ZXEWf-oCf~B6x{3t%C8v!E)W@C}WM>9v6$kBTjZYcKESU zMWLP#W+<(Is3ens+cu%l_&f}u#FKbT847qYOg8}c>w@=FY?RfDCRAkv+SU+tx^E>X zf#u^l7@?78b_^~2@o6wP+VyXZeA1)(AQ`SqdhGQf8pb(RYYekXCAlu+@Ga9~69c#O zg@a`OtxjU8YqO*q+ggVuUwaEeww&->+MSn0yl8#BdW^5hzRd_fd0Cu1dc5B$*n0KK|w5{jkie{Aj5C@h9#iJww?H2oN18f;PpbQF92CFkw+H zd0C_;UF6T$*O_m*It}vg8P#^*2&}3cKCLujjFog>7r|E}<|K8;{!NX=y~s~X7nqx? zI4_mEh}=ah0Rp|<_)=-ea|junbQj$m1tlm$@hO@CnzObW@&Mgyp-M4@?V{DnM#z+KZ>61#GY#cEyRt0r+1E^eQ zq}8u_bpL=Uff$of#Ghr~9KBT~ID*>u$HjZK>ifK;?E?ANT1@;m)cHT<_As+Cvi|?5 zv-|(%D~urf-x>s-%k;-UA36XbNamvHNT+n9lGeMLCrzP2#FJPfCEO!xUH|pJ^}~mX zN7-O*_Fm2bk>9W_@d5j)YF-iz;Z{6^qc}zxl z7}BZse^5jF<)`I)d#(!(!7sjX=~lm_{ZVOMMqm9)&akO9#%MM|)2~C*bb~O7?TLe$kuA7is=Ss7~ zby;Af-BqUu7zyMg(!a5TU*Lmf#-z7f zht7!BT;@}5ld0SKW+c!mZYge1v@+!9`1t89dii+y(qd{+XOxlAsO#`YWYRg)J8Txmq@uQGn81W^*tf@gIdb6v)9Jsi~(@N_~5w1Do^Qg?nPK z0sq0gZ=9;e>fL5E;=8#?Z=mgXG3|=``F+%+wH^mw1J}}M)8>U!@@<_c_PyR(D=)ci zzgZt_(7ON)jmt6*BYe!-*7~YXy$z?|d>fT=^ZKp|;VBmmWwD zS!qIEQCw?=d5^Nz(#gmBIb2zp^>|!Q@vBcP1rZ2BdL{p1pSV|7zixM@OSh(GXYb3j zo(K_^lpj%?ACaOPoW45#ln&CVg}0}>M>ppd5z6C`WxaMUzvdrPrleB`gY|X0M`2rR zZ3vnuzvr)nK#H{|^nHJ@)0oTTv17lfPZw<-b}BrgKWSm6!)Dgp!q>Q^G5CCG!e|;U z_%rbe&b)*Zv=NfWE)_gybT6PF=tywX;N`%yl_>WE{~3w;^QIw7R@_G?a54%Re^?ix z`~wWkdF-B{uog0Dz=!!fy8HWILd3ZX9-kphq7}-KmmSop2T+iS!ar9^ImKMY+ye0J zrza{AEDN7KT68+%6|TzB2ZRL|bST;i@O8k{`B2q*|AEJ|3v>s#TzpQsQ4HNCzDzWt z>Q0my&@?u?l{mBcdZCGt5zI;%|L}##drS4|gQ@|L;eAXE;^7}MtcAF^lY)G_7u*{} z507x6O<5saHS}RRpsI&OUPGA#_z0M-1EcVshdABhYHxFT?zgai{|TN?6hd*d8AjCa z1b(F7h<|}$)f!s}rIJliij$z6Z94Z}^=U^Ewirfhf*l}19C-x{JPEsq*mwB4GO-93 znWKo57IzS!DCVq5mUd!a1|vflr-J5y(h!0f&5lmf%S4s=GqQmt(^)lh7r>2pyNK?b zb_S*7HxK31MmWIjT3G#7?#I*v#_>hu45W<1d9x&VKU5)z1R|z%Wj@`O4_hnE+xK)0 zl(0mpb$R20ctw20xF!FJdPo}}7Zq_iof8@7RRWxOZ0FmXgGr7J*m#Z2hZ?1e_BpG_ z0H|A(Os(qb75-x}a)FHnmoWEDoM80Yoh>%sxxqaTA_PZ9bg|F}pTGN!G?MiuvA(CF zUD%b7D1&-`xKpTD2FnHi^y!o#J)s=WQ%dDc`R7Z>Q~yyXRV^}l$Z&nI zIGa6E>HZ0M2Le_5CMUmR+t)J%Yjj*#iwB({AZ9^nQxz>S8Af@_Z1^pKE8R{g(@t2- z1rD=ych5d*-?8B^)NSAZ5%Cy|qj10*`XY&fpN_W_p3b630s>o|b;SZq-aI6PfSCBB zJ0o?ECyv1FOV1N&nO#H}ee(`|7V&5Y)n6!crzcZ%xpA|`Go9v9s(TWNA&((C|Fg(O zEPMG^Mi*72LH=n;W!{Rnn5EqESM2ZsBUhaV%{faPnrT4(nKuH2nHpU3QRznsB6D3L zV=6YLmGXr@>rKeZuk2#yJs$S2CH^R^06=55X zuFx*%o{mxuyyJ31R9Q}iU=(Lyi^<$F4_%$cR?YQv6w+)ow*DDgLY8*qnHM{>py#y? zNx~K}mR{s=f|){D?#o;3LuLXK1VDw{$iy(XOY#tzvR!&N66c>Ln>vk?yqTg#>jgu5 zJ8Qe7>j1Kc^lpm-!nun`;cymms~#&-OLMGgkBP)JNu70Ix&=}1e+4-_8P`mUuXfQ~ zfcQd(4S>>k;M!uJ7RB8!1J~|P>gW#fZGvq>#LuX}AO9pmUELmtsn5gpr{l}pTuEfr zbTF;w48hOD;9(Uxr|K8q3`#}K;XwHwuu!Ia>7fBB@pGO|6r^Hz;Ksqsq}P?MhTAUX zP{z%0aoZXa+$Zx0;WW|NFcKGX&)&q1d_M;NaKLI@>qBS+)Y<3QkS)(-hOowZZZwld zA8?$S8Pl4?@m5JAp|~UyK@sn^WJ>rK_#uw1>kpirfZ;wWZTn5n4Jhw<{Umnjw;5<{ zrjCcM+C~mqa%)YVZUt($i`8!ns@34j0BwqEJzO5{)Q<5rYul9?`b)10UUS9Hl$>oT z+JPFqG<{iUIO%uMEv@y5`Q;gTVaeXpJSs5|i6y72cT}MJpw3Y*ntdRBj)$1^8B(a( zm>OW%-|I>bX5_nQ4agj+Mk7#6t|FD^D1Dy+k8Vc-FKP^?BgIg-TRC`R%hzkr3pur2 zgnlpf3T~+Vdv79d zEVGL4V*XE~L6u;bJX+tssqb$Q@`nC}zeig=Tp3@F??=|3q?d^BFDR7twsm?**Bqn_7}iV=DEFK&r1=DY zJ3FEAj~i5FE~XoewNzTQEZFcXsCgnwX4Kg(g#oPaX_ehZT|wE9r=+;g%Ubt>yIi)# zX>m+z@x~I;ZE%s0EUga37;2uMuU2P8N%8*tJ?Xmf*W*v*?3gdB7LDV7GfTlmUch@$ z-CBQy>clzcpzvyO4O}fAhW#aspmxeUg<0#!;M`eu=I;0W_O#Rf#M9lD@|5DM`JJ!` zYTI8$Bp!^)|7FV+1z`Ra)&+es9|_byi>g^B+=P?IfJ(UpIprWiR6aChNH#9l0Q6TV zz;*-5cB|AxU~VOpI}VPX<4yo*nGYHKQAsHnW`PIdX5g`1)U8;EH2$!=N_0D_9d;ex zq!$;n-EUt^G7*h^;PA`*T%#ZHbOZF~W5yj@@nk+KKbag=|ZC zG~VOYP!2)BU_>78n-GnyExmE`oGC2m^||17Qt{~h^%Cns@NE)~JZFy$%r&sxCL|It zO7_~%1uDRKq&Oh~nHb0+iRSCJ)<5T_$7GL7aFQw&ls3uUMZkbJxU;92bY5CbV?DGF zd_xexHBS>#b{iOLdrPG9USPA?G3hvq&=vj_*L^huk}fr8P!`n!+=SW#dVh-;G~DA+ z=>`REKlzF+%)r?9ruluc*Kf-?sp|M9xR!S$nDpw)4FG|`xH9<>zsw=WdX@)t;;tLxotO=`3Y`jm%NhIIPY;p z_Nzmv_$1v&iE-1^fO9MD&Qi}=;jm=jGr}IE%rK)^%oe6y}$}HHGW1OqCm14R;zg-88 z-=>BMLy_icTEcYX94XN+IiiMQ-BfOxR(*ns*O-Qn&ZjN6X0k<_anmHpG>Tf?tXV0W zE)Y}oOZaUYSy{tvFqj;z*?jsII(KpNe!N$oW?E(UzMCPB>gqvXg8+}Bv(Nd!E~96T zw*e=c@*?%p4t2m$Kh1OVjPx~HcQp1{B?of+oh_k@Wmr#`C}<=^0Jv}}g4EJ5^nQoB zq~?qvAp~CPeqAKVR*c@0FbpCEEn*b{pXjDP#2EsKThJgrc}!slOhY06j=wuge`nTV zmX%mh$cDymalEccLjNF%^%`EfW0GJhcx*v!J9)4mSzNZPcsx$zzHotSO}ZV3+_5&y z8xJp_GCaJB>RscsAJuh7IQdny6bac~PZTNE#GY#wa7ga0Xpp|@&>9xjG`&A8HSors z|M>A%&DV`h2#X`?_?fb#!(sS+g5~cWM`=*BGd6TW>)==U)_?dGp#FPCS1Cv)PxC8Y zpOvg^Gv*CrSv~ncw_c5n@7LX6AE@{}bAa@WRFs1RwS{CW4;lQ;br!l#6}Xb9wLRjz zF@ehK*s!l(XAaTG^lwkG`1P3GzCU-vVf`V9+Ks?)sQ?k4kQ`zPzR`mYTh{V~{QW*f zq<@5U_1jZ7Eta8VqMMGX0vV^Vr>Io{(G`3nJR^>JdSx|W#?Cz}6KiiH5q<1AFigRM zZqsLcE8>P(Na>bXK*z227y`K;al-d%a@FwXU?f*}cWd^l6WinKLUTtl=S)X5;KdkB za+P-y;^nJ16o}6koiBMji|VWvw@CDf$TYhEjwC?eKv9oXlciv84*%>v1uJ9!DEa~rBsiAvlOSnS#NGfE}s}D zO#Z3_gDK%bCF@40zzoqSdH3NNwFnFMX#NxuY*Y59dz^D{{-NS=bR6z%m4W{&tY6jg z#(#OaIsZ5MkcpM;|6k-ZWBosWMUaA)BstL#8_*|(OjEU}1{K9R%_t(Nv7|gWWb9zl z!_#^04RJnFB>JXK)d8Nbtb)Rybf4_k-_)OK6ZmeINo;fI}I|rV06$X2X;iJg`jeP_L3gdS>c(RkmHiWEh2=sS!two4b&Q@mdZ3cb*^M{eA8Yn< zbvLps4WR5|Wbtq&cTO;($?j0*l)~FCPcpA8`33FK8h~psZ`WN=KS-L}BJm4Ob_0O6 z4=Rf!tC>!orS~sta1}OQ9ad((3{a@83Zf|E1HBcWI0e()iHCm(Dbn5CR5*>rO}@kD z$iA^P@q({+409}n56)5mj9oA{0VEplDWaR%aT}22IUW}8y*3uta>e9Z=@hh`g}bPg zW9Gr2)6JXQTl<%k&qsuW-l{oSY~IUsz);$c*)g~ebw5q}y!J7A*mfunY)+K#ps<=a1BBj<^CnYtGLvw z8O-^pafq7S?wy5V+IdPfLw|pmUBRW8HlAEs56?!TW>Mt zlW_^lMy$+0$6_V?>&#=EQ0@0*-Rw%dZ~HNWFTNQ^o7Q~s`bHb&4S7nOfHmhcOYSsh zGDVP6Soy`YW5jjWVbEGDct_>>3$Af({G9GLoRQXYS1-VNrWF3YS4b_PPm@(@p4)A0 zHj{Erw3$DDx}~JPFb0NY`Y`xcj0}tgxodwNdaS}&`OUd;IvwjacVsXNQd^z?DNHwRD7pYD%^>;UQTWH+H&SHJ{ex@uAI7c$1s%; zn6X0_BO8yBkA}UHv{nq`2)7TRpxgw@6D(NO;A-Ta-oR-+swztN(YSKi{oS~+fNM?6 zGq|V>0Bp3c$*^*236;~N{XVV+1Hd@kp1DVweqTo%Z8RHBi#K%Fa8oX5r% zUijObJC&k^IB+&=J6V9Eo9_+s5`^%UtM9)eqQR%W76+>WAbE9HgX6QM#c~yq004nY zWkeHp-JuiF(JB@ceOYoq<|ndVABQhU99p$e5SvIa7Z7IgaszZlP_%o9;;@Mf4x=B%eMVwTX5z8~f>668HgAoQs$?gG z3v%oPKRhx-9hxH*JL=6KrG@p1mlmOK@E}nfq5{_S5kU_56Py~jx;8-nBKEnHohp5# ziE8Slva(PPP+8UW;8ENYDFXL31u~v==snXv1+`7@@f36Jm=4+^mFSy-&Y05?T@R9Q zrU_RLp7I@`LEF<{sl+o%chBWM`qixX64zr%3YVSNt=kd%v=GX39+*Kh<67FnGTF&~ zu0~}1deW5uAY@lpHPY@EF;&9k-S(81L_XyrVTZgh>5Y$3Y+m}i4o;hE#DyBf z#U9h9loNIl@7%#;_QF_aQ`?`7EpJ9njpI+`{n)S$1UV9C(0y3>a#a6|7skU$fgwc6S!`x(D%dU2P) z(2^f)-;Ft`KWdjHxaC2?{YJZAaT&^du@11lOH_~-9cDk)Y9fSVINFoXBT*EZ|$M@o3QlemHex{oZH)JfmuP{5PEPzY$KH9RGn+LbYU^H^-2BPBn-qgLNok zM)!)d=q9xQpW2a9){_swB*e&OD0?7zro|73iw5q9KvA-~yoM#Er4}WBcHwdaa{BJi zF**N@+fp}X?TuU9_LwtSFZrmi`ZuRD2RqQrlo4ILZWxudH^UukPi8z>5=uu9=j*n1 zF^=}RojqGYmRtXt2nf?VE-FiI%y%(*xhNvKhvxq2F+z}0PnA+VG8|9BFc3V?E^^6^ z0zWQKv%t0UbzFtd-5Nd9+m9Q9uAH7SQ=d><4bqyKp9iS^*|p|8eRY-*g|$=ko)j^= zQ9!0r6Dt{nsnjc5u2hAc84Qj|w9Gy@VO7!)H-KR)+l z;;vJ5CEs!C<=5rD?y(9SKVLu=WtTQdTZ^?Ee z$c;l%Xytv55}vZ5VJyBuJ{g$rS>YpIId)fOSVk(p{ZWEG^B_^b4Uj(Pt*0#rg(tY~ z*j{bsBxoOQLDJJ;(;;(N4aI4rT^^2#jaf271mRI$^ushJ|DfIcFxGP0snfm@yT_7r zS<9Nd)Ixf_5n#yo$sF8AJ}EtbHjSmk+4mrck{#pBE%WZJt*%8@>f$r9AElsuhB4Op zjh%;;s>+a6jhEw9$li%s0+0;m%CU_#lgn+tBF^u;Gu^|V@%4MVf22HrWLmIFHcS$Y zY?8KuyO6M0W#x-b_vRdv&nin}E=9q-0++2xHA%@5PJ~tXyDG6UT!cGt@7|HP% zcnNP=U!~|1++$_g;C}?bqJb)83(_>!;m!Kv9Rm z!9J^W=%B#Kg(YT{K?Cn&ZHIIDd`%iev#%=>LYaaSqwJpiW2=cj{%^It@0%)6(KCoK z4w1=-lI4f;a`HI5%YeDiQcg9mx+HbFxD2VFecE-w!d<_a5Tl;ysxliXlP+1TjafFB z@uvs%i;!~Cc(;F7xbOpp+TY!aOr0>R025)IOw*9r2e4zBnd5(!o~KItW-J3)H7Y*9 ztx`;48uSOxcvriS2%DstwYjOyja-r|2OsHSGs|6DY>iIzjp*F+M+ECOD$W;TJw~bj zM_O@2G#nUEv;(TJB*y@Eb(!a|KrXBYNC;mPq#mhOO$FmY=3XX2xWmsUVwRU=KxCs0a@W0n=Yv^{Ai3w_5TliHybB9=bovI754=x5@!gTjLtWB;th)tdr5Q9go3Q zo3GR^m9j2cN%|WjX9fe|kxx85|2Y^jT$i(vN;%PcqCBCtye%GxoW>odf@ccmRkP!x z?(whGh~Cz3a#^Zm%$idK<^5(_Xg<&@SLqvlQVr%CCc{&+1E^PCOO1H9-eR$VuQUI) zQ&-nFQI-(w`^>#IRN^tu{zX2v-t`xw*A!K6W=2+U_Bz^EefjU1v8T6&AxUj!L_NQ z1tZHZ!3;Y+vxrhSeXPs2+(S)CG_QRk(-OGF%4y!`Zq}UK=ODgt+w3F~Sf4SI2}-NK z4*bv?T>iFQLF?APv2owDZ3Ec<6=kS(R}fS#6Cf$PW3c3L^gmMGD`l$?(bq7{3iPDT z98Cn?oTWNK5QW_o>Wc^}d4NKKejriNRa|IAK>#xpL&IOsXF;4Sp7A2+4>3TIvP)rS zF(xkXkcVgUn&ZIp79_w0NJgP(gK~;UT+EPWi7*FAr@R73!^sZ84Ly}fWHMtzXvZjrUz5^j2-&p>R!2$LDf(g6CY{mj!NJu|# zMk=isB03Z=xZT%E?u~lZf+z}Ej1X=oB1DgItWu$oslUylKlYN^6y{F!xNIO}J+LYR zmpAMhBg3;!CS{KLo|8FlAuQ4tOqCLT>F`;zk5X54cmtKH#kGS92d1SWiO?Jn?la@{ zI!Uk#gO<9=aF{|xvvB4faq<;*!|}RLaP(^@(FB(?Njm3^YieYXrf~jUW*uq5kUmO9 zQF_})$3qvgfk0U-&y}r8AR0vV^x#l2eUM*fJ=7r8=959TG!29y+Ota&mtJp zLZdhs-;7L_n6@7C3QIKf*|T1CqNmj~`NTk(jPi=TM9+dHNEQe}r7b_NX@?azmdA*^ z;Z>HE${-JIpcNkbU^JLa6O=*VHixw*Y`z5!1Ko!_d{a@hd6RlOc{bq)DnfHLI>~MP z`3*ie1Q*6U*rU?H#*iKwUQ_SvA+Ua&e=y_w#9`|gvl;(Lkx)n=}dDCU84D_@IH^!0c|$XK*d!m z;9sPt5b2Z%o!8#5!wGM27nLTEn_p6=-G|1F3s*NPw1cM^5Xs`pAmgK#SpU zej7oC6kqXiD?Q>dyBh=8%D&Z9i1@CXFy~guhI*C%92fuE5P3~;*saTz4Dkh$QB%!D zIBgxY2oEW?xu!r6YqL)K#w~YZzXBnv==$;n@X<#Bj}p?z_E~3CkNQH09BJ|x_{h%P zpb?fF4Z16oaRf<4XSXUH3S%Cx_0J^g2rge=SWx^QDqp#F*5?B_B1eb(enijLnkYSk zwU>gi8b{qwwPsvDO?EUVywM(Y1=byQ=CoS80n&@2`uNzMC+b??zsJvcG&xP4mfAEk zIw`wdniAC)l!F*I8wD$0)uLgprzViNdbnJ46ZyZ?VRD(oCkr;O!ygh#!-bHK+t;Gj z^of^^^Cv?eOAj-aJe|g#y0fLNWcN0QW>%noBN?utu+PLke%!P8Nw)7IhSHAHYuhNK zL?-k#i=F*&DWMrNG?ND^A_DbC(~IZdf-ll1z0JRlW02C};n^n6{79?zr?|cgLh{Lh zIFnZ_@z|V*_k7RpQPR19C|A-$LXfM2Vf8`{^PfuQPw?d2eqS#N6e-z77tgf02J^-z zGFc7r2P4UxeGC{Dqh9~WthO>u6amD@!~gggm_DI4mt3tnq3S#4@Pf(emWZzkyV7#M z`O%+z*cWsjE4~xFT7{gTE&LI0hFgoue4U^gW+b7<%0KfI;`y48H{0Uj9}9A3CrG$* z_uz{9+dPhE#_d^hiu^GvPo_q=yY{jU^{Nv>i4LeI13g1sxn?~hnTP9nH;9tUc-NS8 zw^woP+{_qmcpFk+`NUHSGo~y?%7F$t>Y*Y@BR%;|dLlAI!CTfe z_2nKZ0Ug6m_3su~lBl`jLghs>M~(T6jas~XGuR#DfP2zBxN?$3h(z;uf9 zzajAdiQ{8t{m;gOX{~MhEp`D_f$1N!q`jaXewzrH~mfLM8JufE%b zPMcdtQ?AbOLaSfnF+tPbvA!*?YkK*@@uOReZUNpEX=zFFUQi{tp9ZaI7W_G zRIU@QIe_zk`kJ8F4_$9JB-i`}zf8F7Mjv%%gm1wceFL#PJ~w7Yn9 z`!tu85onI^Whh32X^}()<^VkOXp>28&CYHx+bOY$|QJam+KSw+Zf~A6$Ij7c*|B$L~ZIZ&MVzo`^{{ zd@y-{jKYz6Z;4kXlb~*cG#xdiR78Vm`;&Im82r=s5)EkZd+VWMJgJ8`x2Z`R;j*Gi z9q7NCNncpHSOQ6WsU6M&rgwm?oSFJsOzDkBKm*a+#A^tV-{Ff-^qWFfb2;7>kdJ91 zTbBnXN!{OY09!0OsN7&dvJURJy#9(v63@7e6Ocr|l-Hud2j<)pbN_cXr}HYS#yM-I3tczu#v?O^lFZmY7UKI`!!obMYVBvbo+GPt7GF}YncU)R zqpn%hfr<1r=rMz!%Bu%uZ@gE4Tph>Pwgl2dEDI}G3c|a{chxYpSM3*peURjxJhSs! z)q3b4)Z4-knW_b}y7{bQVm5S^n2C69U<8c6G{bVAl-_y&)dA9bC|*D(-~)L&o+tAc z+A6KW-sZn~)-hG;^w%NCny$i7=Vdr3`O9n5m{mgeV@jK~thAcGI&*)y>O}d3cTD$3 z|A_Iwz02=LN)zX2-8#KP*OL~w;J~yY$9=AzL<-g`5E@xGN%ASR@a=kL@m4^imPN8+u0^V#?;$@7xn5ew?lo+A@Wtx1pG3fKb* z6#C{c0aHiW>I$f*bt7CCU`H(_3_hL2R}d^%He+RVghHLaPFhG%>FSZ<1?+`#^3R#E z#bc4Jea;{qsB?_O&(j%>_#kjWe?a8+U12uNvr|(Bv;2P?s_)(L?^+H?Ofp^7S95IW z@XjV|3o_e9JsmCW_MNhZ)Xok-t8!qyvKQQ`5}+wMy*BZZ$EV$=doq4`C=t_MWp&e0 zY*kI7?I)l^r~7T@y0P))3D9v;A*vQ^7|w%4mc&L1?WWc()R0yrRIpzXPq3Sv ztp{YOW_PKkG6%XNbCK@;3DW~4^^rvH1|1(=)c}i= zC=~c^Tj`xaPRU#25G1#AI$&PGv(t8O2m66Z@Luq+6j!>0rhWciU)1rcDHD&1+Hr0s zw7b8Yep9c09veiPk^S0eET1R)C(3XiB^1x<7fowO=Dbnr#%wFbe)6r)H|6 zsrOt6g`(N=K=q5*T{11gJK%u&_Y&2d4nWPYbh@y zqe4|d$Fm}KWX#t7YgsT+==&%HijbnLG>PuMRS7(sQS>N7xPnp<@~pZj@3PL>J#WXW z-zJ@{a26iC=H+1djMyD<}lwfwOT3DBQ+f zuC(r!SGXfn?f9yNOh2aHJ~9Y;1c}u2LS%dBnRitmi#c)J#q7)mbc%M++#jU3sFn<$ z%AjZ(eX?5NaZk?usUGAZ=6FT6NorR)0+{>g#Nh+6`&ph!5Y`SJ@eMc!8jvt=MfQ?{ zd4e$@59UE+fCkNJsv*a1pq=_^Zo#OY>QZ>Z3Jz8_N)6YbJ0%8U{|53qjCe5UmyvHHuiE7nPYdRdB$K84wRH) zpY*9+(tpv-5&dN7AcSdI<$&%SFVCEF#9vxC;1I zwnEQ12}Er@yii${L_;e{Y|UkQGBFDKCH*!ka&tn9u|d_s@15|9YIK20j*U39PSDWfH8+2ke#11a1|3 zwt_UN0%&hBDApCJh*4 zLwYD7@^O8I%_%u2rI&Q{7 z75+Vn0)`#-J;2m3>ZuAozWb5z_Dj=y67Bhrqk48N1G>$U}cX4 z$o9BazsJ8VS_1(}*X)XAg!bwJKi9p&kj{Jm4X^!g6^QIy|51ThtO>B+WJmh$F(AhJ zASy+tRW8!!ZUS#<77WiHbO!<~*0bw4JuQ$4`hVVd6w!@Jrvadll#cFqZrgtc zD*z)Jza9!v1kurJ>VsX1+ zb7x7Z&0aV4HZwr&ChjB}W7?}GYN{&Tz8&vXh}wLdt{ zBn*ik?*L-6D?S%;&Fu6&7)IU20B3Jo*-a4t4TIJ2LtYfEf5Ebu(X3Zjp>$VnVRoER zTS}&JB#5poimHHirr33)S%3=RnW=pX{+#bJv#F`t!~)t3?8rC; ztC)F|YGMZ1@zZ`AN0W@QgHElaz|j--Pey6#ej~>@Cz^5{iF>YY*t<2CfgV?f;~2_t z)KDV6ORIPo&!W6TGV~;GF$DQ9Pe&URCBZfpA-`_Z6bFhZmTihQ=m5^(u(A@kp?`B@vH0_aW&2Bp+l08!CT`4)&e<8)zWPhh&7-GL zICpTnsVgs`7e%w{(h==4AC#w*74GmGCKK&llN`oXho^Sa;Yd{FvSW2q;A@1<08H6U z3JNs?i~YivjETo|v?EqBt$87|&YNEX9>={Lv?!JZEt;g-n zKYGAhsFr48w9b0!DXyU@Z=7c5HT^!hJ>-P+i9eK)X{|{TGH5?1H$+OGh>>YR(F7(( z!K*ViKuY>TYLOt0v%$Ve??np3zN+CXVjm)?oP~C>s~mB|r|ru5J1;j-6<-aKqEi`v zk(i5(`WI9h+tyP;5{K$-DLE&uz_=L7?I`6inVxM&J#Vnovz)4VqATt;u3aQbEWO~c zEf7J7qST9-UL$;j((Ht&Tg~?JBW2@?1Ad zo9G_zeC@mAc|=!H1~OeEs|RrsX_<{H7K$A^%ks0at9og;n}({eNTXSVb_sfA2tHQE`G!w!5mQ$KoQJ^M!KgzE3%+@spl_6Q z6Ky*xp{c@cEmIKT(6(?_o+~YRXSBp}$X4f9H97p(6UVGG!&FtxbvQ;YS&N}(iDgn& zO)CP5CAHYyR@%8^{%WlO*Ny_+y%K8)XBRYQ(utj`ty_&s-{Pio-rR|47WRqqFgp;` zymaucSwZN}z>UO0CXb<{J`&SwAj%p-KSu4~W)l|`X|8jVhe4TQ1>%tkT0sc$Pclyx zMCt}a-Z8zy5kf*fxJW$qw{`8SX|Nim57rM}^K6uuniEKB_K%u?8cAfwHfY^ig?n6z z*BaRgM<1d^h0Jv9sd@5qXgUyj#6G-OcL()WXi2UuaEJ4sYJbvZFxxA zBz=_E@-#ZS9H+83FP6JZlg^C3i;<|&3CLI!X4OLibb%K+O2FZ^*T&_zF!v)?G;BBw zgR*c@wa7{0F(ePT@Nh4z82^>s_;ASnldSKyA@{P`R`?&QZ_h`#6EDhpY5*YLinFGd zk7dJi4G_Sd%}#W9Row>&@dzl3%cZOuch5b!9|oxN=~LrBZ<>PlLqSAN%Vq`(uOzPy zLvp7XYqLu1a#1T^PH-4wA{0Joe4d6J>k41xWEj-ofpM8XeR`yBruT09v?3xgz;Rp2 z+8|hU+`D&fZ|`Em{WqFMeEU+zpQ$7U$DQ7ztzVU0_Rf&~V+Kr0Xt;bU^uJIidwA*_ zqDhB_f{6S&C6$1_6*nCrwCCD0Ha%x@TboY>>F+}(6BAJUfw5K#YDvJ`tn+0fmBwlD z{ts#A6eCKzt?RaJo3m}(wr$(CZF{zD+qP|EcF(p>uZwfCR`$xtpX`fDDyh1vq{chG zf#>~hqHzyF)vYG)1`ARv=s97*kmv@t#st#q787w0DFcIkIpbKEKm(wey+f!kpfE4w z=`5$wF8>2liNktGc7jdwxymVLSn`rVHE{{WI7}2KnO$F(tQ*}Gw^HX+vQ2^~mFh$K z)CpHu@o8xCZ|=jQ%ELmMElumn_cY)i4Rq@ z1_K^j{N5As<8693Zu3j@zepU%KQdwbU%JP0{3B;AMrOwUSatKk+;rS*x$o91I3L8c z95Hq;J!>6uFx?t)n62NGExiC1?nlFpREA`1F?;)CX16DjXvAk9prc>^4BGT!_Aj^s zJeo$^*us|9ag<^2%UzxOGo?02PulzI!M+1x6`H`&@%Vwkd#O{iQkZP36k8+_xw;PR zHhXMNoaZ7RPs-!seQj7CnnS$11q|0=AiQ#oC~MTUq9=|TC* z@AH5idOX$#@pAwAF2=oLPR=}Re}fN*UfsSLMgug$M&^keJ_InU{tNHpbhX8EoOj)K9TuOEiy0^IPM`0`_K5)}P8M)=$CfM{i;+GFu|RiD>(>~J$Hyi#wjC1y z3M$cSW2D zzUD0Hld%1F;0q$aU_sTKK}qJ)INkU9LMWNzF*kj>20&X@@g&hcr}eea+{uWMviR;w zNAM*vq0IhgfhoNygq46lyZXy+u#uW&6`m%nTJo->r-jpUJV9NwEv|9MrGRB7ckNaE z-~#ir=wWQK-H3&BkU6H72 zXze)YH+b@Xz8zoepWIA-k~)Guqv(O%Eu}HcxsqPD9`4JI6H=<}!-yrUu-F0N#Xbco zvP7s0SCLMvv$q@({5B3;5Mcie92!+pL9o8w!2v6ZW*+V;ErW9nAOrIrN_6K=(q%;) z5A1Y3HTrD<$1aZwKkP;y$W~JR77HpV?g%!gEZm20$hb;Fl;30^zz=1W#76Qv7>?1W z=hbmqzLE-ITGL=^-S|s&tbB_f%kO*t>*k>re)V+O-sc^!wY>w}kk6s!#@24v?=^e} z@wMFPvWFgkGzU-BP^4p+8Zcw`uSqFuG8%vc5b@lT%XBw1jPkS|eTJ=+ zRG`Z%tdG3Jtk0dupnpQJMzT3+_C8aOErAsv{x9nGIx)|w`YAqml0yAAt@1pR74%j{ z_1z$lOE2+&$ak1?TyWL>I$=dos;wo285u2CGeIn2V=3H?lX4ZW%l5|bSdmuq&72yL zCd;Q8wcRX*6#K-uCP0AJ7I%LaWb*`DRNtIlntfkt+M*r+gxckJKQ7g|-^{1h{6t)n zsJ{`S`I!&J__f^K0FSQxC%|;MN?2aHjX_~wA(|D!UZa6Pcl3& z6~*N`kRhYrscgy14hhiR=!(G-`^Lo=ph*+u3q$+;smU%kiM4q&)GyOwCBU6I1d0~% zs#)zo#>D+tk2uO2!_UYnFJ8mnWZt94uuU z+yk*$ln+jlIGD_zKb<|D4tp)Wl7~VU1W>#ZlWyZ9Ht!u%k#g>d4`wLfU9Au_)h8G( z@h`G`m~>8I)RU4c0p26nD&zK*R4f8VGE~hyFwQdLgs{Gqco^mn?M% zj=uSJ(zIKY2_KzGRPV&32;{Y+DY%c!b8{~;a37wPZAYK0`!m64b&fiF<|gS6mzPr! zMh*Z4B>u64K1ccGrDLw41>MI$y_q|^Aw)S?w(md5vA4&x$r1clj*D2dqe43nsp8(c zsM)9|6+Dz&$8oY#-#+tEaYI%S9|;S#9oNOY7K(W@%SjEN*2VoZvlYqSfwSo#`M{W? z`6;}hBWza{VX17mr+epRl+eRlX9&4;#UkM23%zU3iO+Rf4rxvqOLT*xk2nWpa?ESu z{>XNywX%`nyY|ybj_2M@R@VTA28j$#86>u@9~ODDZ7_Ixid&QGm{{m30d#+1>{t8A zVzxCMq}a;hJBrI{fwm+fMs)yT9bBM<-AIH%V`Z z%u2=kzJ0u|#-nk#m}eqyl!Mii>DdPS4TgLLTwqnTfMd&%-ZaHhgtYR4r7sU8Y6+Q} z=w8t%-1nP z`uOx2rW*xM!wLiITI=?M83t4es1CO7<=irXaRDI>B(67>lT*&qcO8Sgk^|BtBLg!r z5+mq`)}HtwJzn>w@v^#^bKd#ulD5Y!RO7#u`chhHpLQM6qb3Pl-JSQSaBs#XJnYFk z3fvljU5<4To_;S3!r0l7L$=hRBIQvHY5)@Zh5Ja7ztqD^FpI!TXjgm`g^>)!snH70 zF3`y0uyENzwccoTLF{QN3tSn!HOSSrfh3cNEzyC3U@pSl_CHiGV2HjI?hlOO>o*`-fC{G?S2zM|6K2h zd-#}rOX2ReXorTf85?j|+;6iqpFNVO2waMKxd=qh+0p+q8o7R0ufyplJ21QekGE`) zzHSw=o{C*^88+RdTImi5;1_Iq`+i{ER2tRErBD+(`toU2j_Yu5g z_-g;n>p)qW1=8}(P?;PAuD(dWFH>&UjRmL_F7`*l!$0mPYDy}tlNLw+5F`UzL1d6}6mGWy^}w3&b{ ztF9EGz-}su)OddOUXT_^fv6oWFLaN~Cf-fJX#Oh${Sm%zef(RSn_++dAZ+hy$PY48 zvPxR=G;P?Y5+=LW#*BFZYq-Ovra}~fm~PCrR+ggqPB3p;t(!l`pzp+mw5_0b!3+UL zz2>ZvH9NfFmJ<#`F@|tVecL>#SkxgvkbwhgU^%i!f0~}e$7Hv~WjHOA3XB2QBu@vI zpsq$(m!F5^gRZmS&*-)lScS$=l{4|-+dH%QlK6t_rnQvvydg7293o8|I%{IXK zL|Ln?J9%MuAjS|v9tRj_XnHO7+ph;5m)BHe%CiUCLD&$){=s)fbc{^-QRT|@J0Tu| z*tRJLX@uJiI8S#E0Ra_t4)|(U=wfhKAXFSs%xL^D#(l)}O*%uMIZ+Fa$JrxLEeEli#YALq|>FTSHjN zV)8I_%xUV+0x0g0W_K4QT~O=^iYK^4a-gYrdXP4E##>*K=3L>S6kd>j3K@MJb5NP7 z7%bnxr5-Y)^%V|!b2YMbh54_ulTarzFt0qn1ltP$;=g0c@Shg+i5-3=;9@p~k`geD zFuw(tP<9AOVQ3b&6Zo$?tQ+-g4dr3rj?+pW89SaC8#9x!M#gs)vIZ_m$V3J4{Zz~f zp>bUl>8nL1xfx77DYWjlo17PO@85~Xy|1WTreaeHbfgitnh|barmgBO$<1~A6XBn5rQRQQ)TxK1OB^F&-!>qBb4@wV=N0 zE&lXrb4&DN+Eta&Q8I!f)P&u5Vhn&^h)s*!K+CMA4ig(~RQgKFFu2?>o5J~k{#I1p61=(h*;+1>FRT@6zG zK6tJ6DuF~2Dwg^R5$}TW0|3K#h<*3zW9asBL5tTB_|k@1%=%_P)4%d!ugT2@9~%1< zBtfWajK^r#3kLac-sSD#fR6B9LzDTeMextKC2r$|?kD#?{W1eExVVN5-0WnNv)eMO zg#{>L(F0B-?xTCRp^`u-T{LjkbPuljt4CARpC7QVyp*!FmUFP5mDD&oTcgYOI>}7P zlN8VW7zU%rQM)tPNOX4?t;4c%+NCvkOqbjwRTN}2<`^QU!k#$S3#^2kAATmY)8Y-$ z;!wr@M~;+ySA=-WXb$~nF!uzS)ywzcEk`Ha0t8&f(z*s6=HBo5uPZ}Cwj|!Btw$Jo zm5(!D4u{{@6TI4bee?f}^UU=B%nFT(nf>1vnL<=G;(p5AKS1s|t#g8f$V6%l532>4 zEYr=Va0Ti)8hOz$nJQ||-%VnEKBxIjj$KiL@K`g$8T(UWV0yrqLwDo(;(jIk4KFfBF&Yyr|mj=0vBy+fVdoNzHZAr_fX8a)~z8mSR_&6SxoNk636;weTzgOkKUa=#^Q;%l4rbHRA8tcPizUXDv^2*6- zJNFrj)EB=feuB~v=-=S%gyujPx=H|OW@|T6V_Hqu#X~DukiKfcMnBl}A(sb2s~I9f z+s;VQ8DV0&u5Yp7V0f}3lenpp_#hk77H})uaI$ULjaHGwMzsPW;YcLG-yoh8#}X;; zm!#j19c4>c#uf9eUX~$%SEZ`gG2(%liVk`ExkQ2{?`)H{f}6~FP|a>3?b_e zyB(&q&7>dL*ICi553m`M?0hbL4}yok=4#~-sf$VJBu*aTYj+bePW8dRZ4R3im zj(K{tR6Wf$ax)J*9dMrXL9o#^HDot}r@YGZ)?HpI|BOeR^D}}Go-5K**%4L03NMBy zz(o*iOsO0oK&*EqIT>;7FG5KS56F{OC|cnAaDw^+czCK+Zvo-npe~5zpSQl{I-u6H z$K-W^AY*lbSU?$3`g1Sx=f3e|Y#}={NOp)TJ<~{`er4@^?W0HeMcLbyThC?Y<(mHT zx^#E&p|6(qyQ>Sz@9XdRVP)E>C0=Fn=*7gI)gB&J-Pn+dQ>$dLIj64fp&e{e*sr@> z3zg-M-Mvo$+ayJH7j{Fsn*Mw9=^3D!`9hI4fx;H3&C^@}7@7Q9&mm|OqIAOB%(Q%E z>;=~;yXrq*0DiI37Iu~I71-rNWf7+#+MIMGx}2`oie(=nrC|kDHGdH50OjE=)d!%Z zPZFj+yuwF1qC;4SyZG$Wr6RocwTwj2c@y2&OR^wC_=^|;$Y*BzL3aB5+zzIvZ^FHN z9`|jAs%B4=jjd(m;i)}k0Ii&rn0bf9aup{?vK2EHOQOt4Kz>2}k*m}$ec!xw7$263 ziizu`XeVZM%0^iBM2^BQzy9omX*xp;7?Ryp!1R2Q6`?9|M0semDt*tDQn)j^{Beym zF#a>&ebTgXTC?(sH(F`Blv7Jz~A58-dn z&er9bnc@9kq~X9E4PH@ie_{Y|ZF}C}FG_Vw%DJA$d6Fes3=|o_3Zt0Z9VI92VEjo4 zMt9DpuTX(H5wnMF@5IAn)|bQ1ZvYoECyDcUg>Hj_6AOAn@ zt^T?St^5x)GstU~6)9ydp)5vt7{1cSe{3JBncW;GHAU~X$38xIbz+3BJh_5ht*F$j z!wwP`sZmCC+NWcx&3s z6eP{@OIs8ra|w7L1(EX8)?Z+j6TCO%E%;#bf+x5dpAEJ;$EH-CF^w%GOo4c4{Zn zP+&DSzgb$RvCVyE&2yQRmamPf{cK$r)B@)Bw2iG3sV~o@Y)!ZxkbK=wIHnnIY!X}0 zY_S(q0@=2qSMZBa`d#~wT`8-ntDnO*&$w;c(s1T)pfb?=bN|RPM*tXaTg&NcIx&G5 zX}g_XVdlRYYm$I71jr=)7NG$zo6vMu@hqj%v0gZMIM-M(R8!@^UsB$Kp$G_s1#cf| zBtNn@>SR3>;pT3ppmJq3Nj;wqZCz$iEgB70o>Nnw7r!2jH*JZHvsqm% zw60VeX6k?u0XZBFbe&eqbdOERpg$Cj@sIyEM;)J_7xbSsG>}0Spu0nOI6$2C28uOc zWGgoF&;k9*OPLhjM6bj2eKa@JMnuj)wU@6wXJlV{wUfTSXB1#|`2&}O^pDkNfa^#S zuUEEfac5@??KLu)0jD^L>X0@hSH92B5pF*}7nkSIAFOO=vqx`-x;Cv^R21Y@TbEu= zZ5kWZ2SB$7FFzi?Usomy(EjS}cRfAdR-wdJwqCcM?yiQBkkQUF3l`C-2YgO|^6d`f zMpRy4Owu7QPL}*_xDYQUu&LMq_O47@XdLhKcV#{L_$os z-Wg?F$g&8Tkb<$`qI5TvUEE|uua%ON?v6!34CLpG&v-w1%UPt1o zs5Lp<@Q1O#A>cv){sQ>70b*J|5%y*o*7xpfz_0=|P}N+&%84LJ%E`yFfV{8JI--kp zAK@Cv2ePn*9U>5eYpfqU159uIK!STy{iJ=z@ai`;D6hC{_IdPr%)R1(C>#yB;Y3Z# z>b0d2qw12y_7Zm?f#o~#gpSI|*5S6kLld?RTS-B(BxI8F=ry!e5;(#{-Witl3`Bjg zqSy&oGH16=y8s~za#l+P^B{#>T_S=v|9W?{@I*=2 zw#~RT9)bgQBh8!5lZ8>58O|iWm-DaRxLl|(^A~c%smyN4N$R+7e|(ms{SWvN zfP$->viFr{#qrh&|G;!F-LS`hNO-^ra0dhWdjz~h7!Nz-tGdQHCy9)mnPd;P(e9ilPllUX3`u zKJfN&>eSwnV824~${(Qx_Bn$mW|pwc<}sXD%gVISsUe~(e3ADdL3D=j{;-7TR_rJ!o)6suUtIxfg2jofb)nS ztk)K1_N3*=ijmluK%#BabEiKi!XGXoT3E-6vnlSkG}vWI@*phu@JBZ4po7R?Dpj%K zusYP55t)f1gbj3~30ncdf7uA+#n}?rO0qxYltA20Gn7%9nXtC#e&-TN;mm&tB696o zknV}&;c>~Hik;wHXoN$)XFoaR4!C3wrek7J@Ws`Cinyf(qS}Ti?MN&#bHPr;ys}UK zm6TvqFPN5Eq&|WqL+t9&$G$i<>AEgYt_@QHK|euW-dPYVIye)&drOP#LtL|8_m-C( zA^KR;sG;YK%5z0V0F?no9`25P0?_+OX1UjZVxGEboS)WmG`Ya~hz6vsbvP}sNR@Dt zWt$7&l#;esFz?M;C|wz=QZ$1!YIhPg8%Ma}u%=A*g7Z^bnpj3N+?XMc3y+7BAKx&K zL(wbK4ONR8o?wnw&0;Y=xjw2Hdqiujgyfmq&|Teaf9kB_02q6+v`X6gYKQ|r^vo-q z`IooLJUtF84*pZJnO?!SgW=by3f#9=vCQAy6xJJs^k-_e18Y$qC)S5%X|hlf;h*Ny z;`TZGF`gT!F}sZE$NV=H-W{O;IfvdKjcxvHiHhp+S!}bUTCUj2su%WA1>f)mAEDU6 zCBA)~fF#3>8-^7luht%&uHICRiF0@a{8D)B-V+X5tuES+y(I%ee}mvioGSy4V7dzd z>#fy$qUeY5a;xWp!qF#5yhPUzT9U_e_OZhUMbcSOp?S=`A_@cNZ(&pn6)hCSh|u6> zWrJZbF&6@iLe6ga@lzpXd>#v)6pG6S5N?;a&5x!XliRM0Q*1X%kfJo&-ZbYzswntf zX3~C4ll)N);K4mZp7&EdUts4C8r%PpyD|JD9tZ5~1=Ql=Swz1DJ0pW=U@tlW9`BqW2wa!cVf}qjt`N>_0cHXJ=vFXPA|l4 zTJYR>aUZW|y)JO+ZB2cQCdX+cWaP=fdsMe{O6FaOwL7RyyQ-;n@Nmp;HaxG?jjD^< z+BNvBZDYct6t4q|S(u-#s2+yZwZf>V z!avzRpC&r;83mv6?*$ALdD({oAqK;tfl#CUk}_pH?wK6TxJzzYX|=;e+}5sz)iUr z@1a;W`GEh@*9pS!}KQ67LpXS9d>`c#K2aHqw#f1K9(G>Y5H|t49f-~Oo$bDEURX4OzEhmU5XBFVL6TTS z$t#R;OHl#yP_p@%%>U2fvcS3EtfP-Jm7q6MCI}y zofz{*)4eJf@&#x%@;KiCI&;8_Md+qkq&xUL&dPzY5s|R%a3TB#L#-W%c0}ljr?eC~V{uX7I zkI@pLQTw=JFWWop8!>bbn=S7ai}N@0a7d4z{{0X&?1O=E9af(?7nE0_AF3_+ym^AlJ9i*#WozS;wcjF&izlc;&0FipG55(1( zn#qEYw}t*o^ku$pTSdq$CwfxVh39_dEcdECYy6REcE*>Hdz}{uo3AXN!Bwj3kb0vR zU0Ly6Xc}1k-U>qV0PRHv=p~4K5?TDW>2d7t4!kh_-=}>dmXci}XkaF&M)Uh4(>3S; zu8qY>*`m*CD;Aqs>ZR{e*C;)<+xv@0?>`roU&U^WubFO)km*|IKNBM$7DdtdYlS0S zdu_B-XeEEMxC`{sKMa_AL^x%Pq)IXB84=6O71B{?LJtbJ!IWlfwi#?&l7@-1Jr+*VuTIe~u;z>J`r=^PUznBceUGMiRpF5VG=UC25yfyI*Mo zwY#6N&wvy}|4n@VQQ?GDHdRhNPd|Y z+hrb`68lUOmz$4o)~X7Gs&_2aXz(7hmrkNE(a~i*d9VLP*?ZiF4=hqA{%@b_AC-Xq zmvtt_e>7vr!TuliO4k}P|H_BDpVjun@xl!O5%9Z2JLBwyys zzkL7$S(2! zJmc8W)l(tTy8~2DZyU(IogN#tLii1#77GKFj#W{&Y=uirO4BxN$DqkPTpMhhL>v0o zppAv_S@R*-O|{!_F-m|?UD4n1ZZ7$bKq2<&?l+DRw?9Pn>`PARq0}XCn2Zm=N>D+m zI9mR0(iu#jfP>l>H0X`W$cnh8qCd5s7Y0j3O0n9xqZs?C_?7`tpTUrKj>G5S&1K{% zJvcDi*m!2;DVwTz-SCEANvx{GwpE@BVB(Ekl~(lrl~QdFtm4$lq9{*JRbOPTe1=7q zkIaBEpf<~H8&JkS7&6V4rLC-~2onaOY6$z-CwbwR+GVR zg}daCrsLjPpTVnBBXU&V8#8%2-yB3KS&_6KGCJ3dK5Bn|VPri=| zxC6hUW@36#qUjZ#$EC32isx7#=H0>9@;GO`X@22qV#RBQWLI4$qXK42Y_{cacA`Q&V(q1FKqDJkryMm8IVTeet{OEF*u{ zG~>paUTZV!;OTD#{uEioP(HoEC=DaS6sAKEAbgZ08EAahoMPvMQB_!dlpFa1S|t3? zRnIgCLJJg3O@(tJ%$;!;PRZIXq(_;gHM9g{62(aXW7VGc13@UqaXL8cYCIBdKHkHw z*P=(VUds#~HRx?6=S51(@32uzIJas+(td546Q0<@w}&PGWs zkeg6>P7XDIn|00O)XK{BDx>6-shF0u`)^w%NlI#0V3P)9)<}-tRHb6G^Wkx-TC4Y) zXLum)OruPLj_6c7GdgV}C@w7ZM6i7e_V(g-oY*3GJtKpI-Fra#89>`v1ADflS3YJXypNg1{1h>{lN&u*IIA)ugPwar7=DY4BZWzfG-nW zGPt!!dwEYG8SSS?D=&p5J%>O**;A@&c1lDPsK2y6B__>R0K|^dXh=_ew-py;yR_Og z*%M6Dvb^h2L`ycU_$vNdYtev|*zCZ|tVQ=I2gYyQh7x?LLP)!6eYU9o@Co#vLQBW( zcsLAs3W-sGhbi5-nb&C4p+fdRVsL_Sb*T~CrN1{)p!*l31oMhLaECWJ=?&NJNPyl& z^06G57{EdB{oQkVcaN7j?L6^JmsP&+ymZX)3f@b|FJ2Dfs@kvfM1P6RBTEM) zJluWWA_jxvIE}-Y#RFC4<_f@=v3E{iSZ~k#Mr4Hi`od^dczAX#72?yx2 z!u(*N3e)@<<)C&*j|xDBppG46*x625-(Krf<2Anb`(#~3VOto|0K(~Y5%SU?Umm$J zNLrjBt(z0%B35v4(Obtji&uQMJJ9CxzF@@Vq0@33ZSz;=t@fNrsjvEgn4o~F^xj?2 zQk7w5e){Hp&6@F-_dJXMoM!IA^1DVC3IzA>tp0Wkw$4eiTgB4ZiYR#K7>ky5lf07# z)-~NYp`GtVG!r}-)}k)>Z^?02cUqf1&~}DK>V^Q3XXMkC?V+3>#0s9(8~22jIwn0a zSmR$8U@$*;NmV7ugb}y(hqoS!2gV80V*fuy9XZ56<}_;r8mcfFZTIS1~XB1b61vhB7%;Che<5ar;kJE1sieESFK zJ=Xz{Ks$ZGXYbrzBZ^AHTe96jWv)H)Lv48C8=horVp`%UB3wt^nY1qKj>Kr6``k{K z&dNhlf`wK32V-Kq4G2K8tytHVlYzNk9_y~_+gf1}gQfRbHU1faFf10^KZsOOPf zV0->g2natCAAsQeTw7goK_}DY=F6M6SW6h3p!`_=m|i|OXOUPJe2>08$>g*@lt=}{ z4+mGvd*h?AL2iT!BLo?W4nR6LZ8y1>sb~2ltQ@W;HhG@7+)vikP^L>RF7v0+YFHwc*AEg~^?Emq@AFEHwZt|mSKU0}n z&@oO;KAgoW#w!X`rj}JKxf)~>HXp5(AO4=Jy~W*hKw|VKjfBV-m*9@GI?r~R?PfY- zD-7=oBN~oR1hWcCr1WGH1Sf}42!v%YcaA6%O*TRakt-v^1zkMJFX_0o_*s9MUCKh3+Pq4|}2#Nucuz#O1 zx{yG&@dc=@!h)+eH&hxFeIKAF%DTssW;YpND0+(Q%L{k`5AG&$AbceG=B_1&G|-5W zKnBJ&YfEssWc>B9t6`B$ZD$idIFh@1fhf<*N#vJwVd+%LccsTK7FEL#++rSW9Y8y-c+?hm-+B6t;Wtd}#{dCrlLnV$DlT0}* ztQjbSc^kz^UDKJPEbxy;nXRrYG01+h7y;#; zCrj>2Q=qXgu;GBp*H~lC82}|!!+)FX>AxK8>%o-Q11GTLu?ge^rvpWDm0LM`QP$Gc zid^9TCfZeKJu@RMVvTEX%2}rlx6`0~^#l*a# zWWATYcaPh+uP&z=+=AU{>sYhZB~^7>N>THwyTc_d>m=;3NPAW$5Z!=sR+cuiFrDl< zHI}JcQ`7atjV^+CNNL!MUb?`fhWZQEF`~Vy6xN8zF9@6!w^#|5EfhWh8dNjptdo$1 zD3BeOMXDz>7}O@c8AX(ibz*fNd)S-M$r)NIIor_55-`%!(}`L*IynOAcvX&g zQ7kFsFP9g)%*|M?YHltr@Ei+N;26S#tp&KlPx6s|i_61n(wIZ4I@MuxwdkWMF6wg} zr3N<3Yr@tPh(P8B4xP2ZeHlVR`YIcW+gkw*0tG`z?G>+q4N+q`g5k|MLMsBQF^dE1 zN(c}GNQsE^SA|OeY9OWqHlhtd%%KI5`Llv#0dB+#0-9Ti`{yeJv3kZqa4h&#^@DtY zMr5IZU5!;IKptJ%lVSytz96w2L7N?o{K}393okdZMddgNst#4?m@;vYA3E_%0T0$ha6?4iQDj3z!AWFecuzXP)uBuz!SxU05)!GJ z`wu=4yCvS05{6mYS^iCac@I-~na~|UC2UVX88;AIdOBQ0 zK$#{y1gaL*AF9yOX3J6@1=uRtWe_cSCv*>61Z)^9+)|dqzbrN10a$^iAJfT7qnwVS zjz1PfpmMG?plrn)v~Z4+d5|k2XrL@!{3IGF!rN|1+!?_bMM4^dQUwWlfo+1s^hS}K zp;3x5c`TRt7ij|x4Pwx-fA)ID8Fmp-up@({V3YizH89m3(7_x6D2Bc)Nr4H>QiSo1 z>J8e@r3x{zhYUNoV*p>E6Troc_-H7EUT@6Wgy?iv5Qme&g)Mwyjk7Lg%_hE4 zZi*8BIlK*}YaW7XXaqYKlhF;P9W|G!v@lYFuiFp$t~3t=M+td$oPHP>Q5V4>ycJ4o zn$n)eALS^90gbsPBG0O5OxZaH3jl%(ddu> zn?p@OTCBMdn?IR_!}X-1M#0p3d|ceaTCY>1>mvy(+vjbr{jxk^fwd|H!D`0hG6=rx*d z_eQqgm-8@s+mOKP&6V}T)8uJf?+?Upt?TpL`{C;#uW~x8*Z2MK;PK`D@a6twwXqSu zCc{V{$LNbj{XL!S)Ywitpr5hET{4=Aeo;1l6RL5bioP^(or4d6*DM{};p+p+@6z9Q zZ=q_t{pShQ)F4c2N_Vq3)zrVEp@G!iKOc(pyzP+WV=axht0|`7BSwQ+R zix|nf*xo~tctCv{b-XO&G0`j2g{j-)d zxpjftAfNkON}_I(`x8F*fZ?h4Vo`J2>Wr8FUS8U;#OrqLq;0utE4AHGUg}`_o4IG} z*ZRtBuR;nJ;`Ofv=v!0HMkiy(E92|U)8Z$K0;HPh0&e+1I~cbDGc7;IyQ8muHRl4K z1Y$w_QT=ndZpO{Gq@dEjN^~yeKJ8v-Cd#tsm%TI1zL_}O&3T@W#ZRunXNLw#kKsX+ zt>9^P@U**l+7@JS?Hq|@;BwawYX^$&Ezx1lHnB?%{!2Y~o7%IbhIYS*m60gf}9-_Gjt!l5X$FN0VRM8eSdT&@*!tmdFV+#R(Ic z)Q5%0p>1xaCLC@n%}*I6oLyO4D7~;A_NRKv^NtX&+qp3-8eb~lsIYJdZkLc+4nJ&vgQVw$E=5}JEJkcxZ4uZLb3%#&tOQ+ zti%)3>9kX><#%S%BKJEep)X-XQAOW?k-e# zB$S`gNOXF7`uPrF!r~y&$8Ik3GA|kZuRh-xz2ADmO?kE5TI%M>pOUu-eDA)MrO)3^ zu+WgZ$j9ggw|FO)=!lZlxaQN+X4zo0d#Yor>h6p?+I6sl!Sq7u22=K?AWVt-8ENSX z(KJS*T~pBpBaDaXf2Kf8i4Mo44at}m&sxpsWv8f3Ssyr=!W>Lb7@#rLOc5K?9gKEN zQt72KOrp6O6E%k2=_@l>rZi1)8*|tDtc|%dWTs3fs_c9#!|;Rz}?~4 zsr5+s%>HzUlpa%0dWOUhNjaps7&x_2YU8kGs# z>xw-(?r@9Rc5rxWaX7B#NLhf%8%OOb`xMfyPm&lMp-(CHf=AkQWtW;WD0s1f?Zg9(n73NDJ1soAklvjo^}oqK47!SR2q1$aAw-K;*CAvZ8=I>=anm*QuxCqtq7 zaTJs>hE14%`-x^~YezG^hK-CL0EtwyQVE6^%aRNwg!xojtGFklB}fmmp5Y5vO%j(C zG2~1kWnhdX(Lwy}dEA z9sm)LVj(HE+3w|Vps50^4Wu!#^a|{r=IoTmBO5y6G5cJ@jSoHTe|}-%&B6 zG5Ui8!N@cK%6^ij&wZ&TvG?)SF#MEV+p3MOZ} zwN>NOK3S51!lY1xiQ)dd2k~%2{A?|-I!Sd9s+ENt6lP}^DpCZ?_E`*@JM4S*4j$-S zT*7ku3DLr#(Y!pv=kY-4Im($jBVpESG5a+DTwbc`JdmblJ$3Yp#@5BH7SeF;vu5kuYg@Uy%-!g` zx6tt(z6Rgqe6gTu15p#bN6??kFlJKVcLl8of_LdHe1M9fV7rU8y$%Am1u-6rl<6j= zq~jO5h3RY^$cvfvk2uGrwj{MT4cnA>biKu&=#vQhlgZ#pIs44oEWZmNry?dK&=QJO zNjj+e;bC3WWGcjM1N$PV#%F+g`l!P97)PZ6Jwmf%MquF zt_J&tW!Z-eH3VOtbZ8&^^2?>+T8;d)z6}ny{GpRRQ+k+i=>IVGPR*Hc;nr^4v2EK= zY}>YNTOHfBla6iMwr$(_-r7fdRjq^d7v{;lYv3Bfk~}|5kr)IACNJ+A zziEoNJ9z=ClrtHL4g|j?ib((J!}3$44NIOm(72+_iLeLUM23d`PHeX?JirDQHn2Wva?nrSKBmUxQY3B)p#)N_9_Td~2-R>&2kw)rQBhS{e@#p#7Pe2e69Z4Aj6CBbFuE;{Y zY=f7B$BG4a&P8{%|8X)m=9e^QhP`1$KW>_Am|k(ujSm_gfFc1FQB25{@P^{wL;;T} z=YKU1{0+V!PJcgXAeyurrl-F61EGE{(6#-ed3sFK-0greQ;FSzr>lDgkJ8WNcthSA z-seh<@z2nn6tghKV=16|WFHyT0Ea6&90fs|OW%@J=PyFrsIeW2d%%iRnxk7)^-!&<+0_PK+IMr&mQsxrPLjiJw&iPoT^XSLqh4`BJ1gaC{1C6N$3JBCL)S^ zMNgu-#76;gX?f}j@#-qt-gcMOZ;vj?+`b=I8OT2;esN<~mb8_YRKDI?q54vE`_iY& z{N&U|63C`No|Kc{5Tn5Ejkns&q9ttw{vdP&-%xfE+bp7AFA&lg&N+``Ku~Ei{A8G- z^}Ve_Ot*@fg%Q7p)K2e%)Yv15^(bm6GzXcn40$L+?Z1B!0h&gi(Xf5hXMS1m$@>dc zvNbGl%o8%eNcf|*o% z7)OvuE~C8YI6q934CM0K&~7F12%ag~o{`dYYM2j~LX6P(H?ivrr zvXC&jw&?xn15_3=gec)wky3_(B5nn3e`$4=;g!C7gb7>{&Rq6>&18N&?N8wwlx~jUG3cUw2h7Ow!g3Vj0Xs~#% z@yUkq>r89q5#8sa_?;e}3gA1qP{+bcq}Cv;iQOT*Z6%=t-3?F2K~Q=5GN3kq+2>K>-D8q~L(r{0AHLGUU2Z@QVf-J2?oG%Wl z){^F({-eYc#IGdTj6bW5pRVQhZBVRD=;qR=^bO5e`knsWSclpsvaO5{nlE&mJ;9T2 zNu9F`${4cW8T|TcLhcsULVm)QvT7N8Bry*=9`qd^xBG*`$0@A!(>sCCK7~cbzE(cx z`&lFd9jzENME?zNkvQz`tO4EqQGK47_)hqDqgWUE_+|oC)5mV-@1PrCug)%l>a|Q8 zrkSi~AI6eHO;Heo?p;$;oF6_Yxc+7H_SOBm_sH$uXM3sUkX6ki-St+PcE}C^R#jSN zrTyDzi@_ievEVaGq?KVE;Fbd0D(R~l*ZuX%S2hM@2x6n>LKwVwfDpN>_QB~aQ!_X2 z^*rn=Mi?~}lN%*YLvjjJeDgYa0s}`9xy^sTL51TK%`!f{ip|&m*UwM(@AZi_Tthf* z$?~doP0yqmQJ%2wx2W^h_Au4A(NNg-H?xr6s{g52I(@v8oajQQe+B|Boq9e>_a z=*fgtUJnG%04OO^OmhM;`(boiMM1l;Inu& zDD})kefC%it-KdXMg{Ye3rl!}FE^-Vg6(XE z*Ef=6^M{1lnC#&*Rs4&7FSYh!SlwYDufwaC=YB-3B&MyKpGiKCFJW!~}1H}sP~sRsPy z(QG40YTZJ|$xEz|i;kqq#hgua29X(SOj-&vNcfedWVr-Osd3Na;U4ntWXCPgq8~*q zIh0qXdhX)od%$B&A2SZ0S_&a;GZ*p=i1M5xXb_r8>p$~2G+mgF?(h2LV;V*kbwJV< zg?oXL0H+DViul=qbID*_M$CG+wB>Z2ShhaVC-?N_9z5rVbhxDEEQiiz^&FQMCzqK+ zr(GiX%D&oCigk{8Efnt#&Uy(^L4W0*(sNY8z&C{ST}Io3KIm{#POojrB=>oX2L)>W5DGUu%P|@$(&py+Hji7~a0{*9B_P+=fKd`OsOa@riDr?1bl4i#`e+ zP-{|hCH0ijQWV4{OGy*L@m4aP7LDA5vk4?D>AqYsiXERSqenTxE=@PD1xzIqX$_mkF9j}lFM+l)2)23N zZX2_S{@(gu7s`eU5 zWowp3igm67gUMJ7XyKJCcc1=36iwkQKcfNQW-t1+e`}9kyezCP0^K6LFJc5!ih=Mh zob7S*3+Ts3Xwvp6g<}3t7dYNi-ssYjgxatN6k?hwOMX-bhX8*J$GXsgcLI zlY7kl^_L|lvpUNNWqoa&h_9KOb!G5XAP)#dvFuu&)QUN-G^Im9PmAj$DN%VJ9K1#S z3Ic7W4P(?Oah4LzZDSg&F8c#hLYzaM1#+5WI4q9*f$Q-50sot-`hQ9kFa!PvA3;}P z(rSsZi|_50W}G|>zv-&REHp#5;$+F< zn6Nz_iH-|1IW@RZQ-bh`gL=9Fw;0(j&j<~rmGIH*L8o`YM{z`klGKEc3E6lvlD39g+g4*RvyHG^C^ zUU3y|kxq*yveb2G$}NZ0a5cq*q!x5$kJCMfx5*KDS9P?N~v_WHw)gH=&3D)gv0b}G1&G?<@5hl zP|swe$;F%@5XQe}0*?K5pHDhxzki3#J<>UycYeHgcc(NIQd5&dLPU2>X;x`FXhCfatV?}6wbR!8&`g>P{PDQ>pQ*RZMMTdc$it(ROVp~68MiIsgWxC-^ zEe-pFMgNV)WO0~nwLv|CfRF^WdU}Oyz`5fYviof`Q59X2N8_+h+r{R2-?6D<_;()D z7wFyi(H9&c=yQJpt=ircB)AQldxV5S$PsX}@$mRWN9m8H2N=w1l89}F*uy+GXkX(W z;CF3rPumFw_?K^=()-=G>2k%LbIriq!N9_}BD84Z@15XZ$-AJvqQl*AcI?Vnv7PdS zH=K#SEB>H&|HD_|FqPC)G>R<6te{wqx{!S?sru)q;%^0HDlA$47gf4jv|Cn^O8Wxu zLe~m$SkZ0C;KJ7mk~R4w;3FPe46aN}f#jd!lEnpy6)bBiws=e#xdO^R$t9BuV=HLZ zluR+%GQI*ch0Su!C0r|d*0@Z0UopCTbfu{B;U#1%s^(}dIbXTzd^M%Y^5taS=1?u^ z>Y^28obs3@aw`Cuz(1-m{A6&&*Wh8cDE}u9>P#vwQ%##=VtnD(eDwua*g+Piwlde* zdEVCNu2pN7+J~LIXZnlAhS{7Rm`^|BYkS)Zii=mxUXt%eh&6c1I?qw^c?iiZ2rc+2 z0*|zu(Vy>XP5T^w@99m|g`b7Tmb;k)_m>{-7u~^p)!S!phR5!__8lGkR%tV;$~qkD zG;WWxy`}!%-d}_8(fDuS_5wO#|DXJmK_&t-*hU;P%pLc)c_dzO8yrW|VymSl#WHaO zEMC_qCq2_?eNceCshFi$l(~7r==vXbkuPjN$|wuKO$g@w_V?$DgBN8$;E{)^2`(6* zAY?yf89ej>q89IEOUl7XUh#u{qYNAbfDO20A{#uw>e)S@X)3}+ckFS=d5NDf;mWtW z0xZceBo5+Zbp-P0>Dw>dEUL2J2AMhea`TGkED{bjpJ7E+orUc-`;FrTR6x=(VslC1 z;r{{7pMy{*uQ(t?I>3@yT=DTv1MlfX^lk085U$d2^B>n77jy|quV*K*tAtJa_SW@4 zim^p5Vm%^Qld>ykwF(ChO}8WSbLo6XRR@KG3Z1LA5(N?g?4UW4nVN>MQmi!1U3`PIhz3Lt^6(mz3Bd0DxA%r9b7)PQ;yN;Hq$9C$!3f0=}HjlsW{s^D8|6`*{ zGH6^-b4vP{%^8&qUam=CDtM+3jp_3V_C{9!5%)ZN|E>4Bhbbc1wdCqg5%!fb4ankR z0vjNrW$)k!sTX6tyYiwUFs^I=wlRze7AGKbZ;5cPtAL?}hlY-RI?3c>w>EB)Y&Xb) z`(Uv}S_~eoUnV;K`5_|u`8g(9UOqlv&StGWFfG|s{M<8Vb1j!ozfW|C|BB!{uy3Rg ze&O&Ig@6D@17~x97@L)oU%hD3N*v}2SDomi@Z4!QzQ50hKugLlm6>e6hr1XqaJBz- zXHS$ka4k6#0bnmi%VE>Ty0t~T37Je5DmeN%O@9&c-5DMoSsq>6L&!UgI7X z!bM@AUTV7lzrRS*iB%j^Q@z$=A!1Q0INb6@?y_elDdomk7n2ocw9jtA&2>G~=BGQt z)B4xnE$23t-@0_hrMyeltkCbMwg!0xJx_YdB6YCHN{Or$tR#3CT(wa&eduSr6e0wC z@5}5Csp~kt#y=07))3BniF~zw18oUPqjZ9Q>rykGwj0E^=s4;t>uJ0MmKxS5F zgM-X%Jw^KtodFQFk#BD5-wzg-{<^&@U8tARd7C)2_;?rvSsWSQyk~`xcR(hGL2AGs zkaJr(7W5Zk5J$&>@J}+KO0|Ru1icPqsWyGQ2lbGpeN(twuaGTV5ue+7iEuJr6@0=k zUiPT6Z1$pF=rt3HyR2hY;1}%g(uoz&B}zn~Xywwx{`h{d@?cl+9xZ=z<35eE+U!ix z{!O?f;=J~72~I#hkBJhujmIkq>!;bBp6+|oQH;-$1x=@Qq3tM;zyFyybzTd~O}k!H zv83*%MoAyY4&=c)q68E%-|salk#cJ%rep%Qw|G7TTF_@mKt=WyS}uUFOjZ!mbJJ_# z6O0N9;h(q|w*B&2+Qed`_K8dyAD9rz%Th}T1z||n+c=68GGiUsj(@x2Hhhvn%r-=h zOOMe^jZYsEa>F}X6(KTowb1C5km~Vv9vl~&&IUKN^+2l=9hI7!U$`h$|0kmbl>p~) zb5f!fchYnUrF>quhM!c;M;@YcmTLr8%tOC$(Cdl1yFx^5&Wcz}7qAa}!~7B)@1oyJ zOWc*#|{$7ynno()XSxP$V^{-yF2jfXEvVdS6JNul&XpjF;{3De`0= z&+d~ZZmKmV)Q0a+uzO#K5SSZIV~eleph=$r*-%E~&wac{TfMv$aDK!qr^s0j!>^sN zOorOj5tPsSF>2v_L*@KNv>~oZ(=p8B6+A?Ae_-Tk5k0tHtz&J;1h@r$3(jFIpSGxo zsChU_3Y}O^^zdwX;HDF}$>xy<$+OL9G~(9w?%bY3%6n?*gq&!BM=5_L<{%p- zCZP*!q`erbVju>ErWWY+W;3rh5l_bXi{@?ReTxKAHNo(j_Ez%v<+h!6Mu?01a(EBh z*c*#9uNzeHodGdrzxS?D?vP2hFp%Az%MXo!xKwjMRR*p4;$()Y3y}b;r*NyU&W)Tr6rANu-gy ze=|8{`^OL?W8$G0kq~)nxopaDaSzZk6S3c|<9xGd#1h>~`I@N})z(<@-Y}MN%TOjSu%r-_Qq|ypSm`jLH zo;3}S%gfAFUh{b4Y6`NHHZv&*n}K6vPCVTMrxDT-+Tsap>C@5hrMw8%D_T7QQdT#i zW{6|<9Q7iz&+xG$Jr_^hMS8rHmmt1e$nfvI8bO#QRd|ix{3d%P&5?+#X*_0;692~8 z7?W73V6-zf(&?XX4iwLF|pv#3fDQ8HE^{@(&Q<|H;{+%D6*8cTAiK z*{dh=0R(v+PF^wJasQ(X-}V+w^r`!b?kEo0(B zgQACN4Ru%|x9TC!24OIxzn9)CvdXXPp8F5n1Mf{WQpxEiPu`7F0oQF&Tf>zuKT##5s7aT%jF(Ww7{n-;m6Z5`MoR zT3VB_fVN*+Htd#w+w(Co4oDEaYZ}`so;E;jE?BXhc7kz@`~~ycfXp_V6Y*+DE#)5g z(8J1aWc^#kaqod0#zB#M2>199zG3p$!$}qy0x_2;Z9y0yZAMbgYdfR2Cp6vaxum)F zLl`@vS1qexdfwD59;zC19oiU>k-?AbIwiciroQNSDqmZs^CRB%ABa!N{pb6+&U*S2 zIv6D9bDySYdj7LyHZ>i8C*A-x&V`mRD-7d;h8nH}Zf*kCy*p6c!0LT~Y;(eBvLX@= z&0B{s6+pnHHz$QW1A^W$ZeZ$SVsdogX=uFfJd&XDkC+{yA(C^PVA|sWr$b4+ekDy~>vz$UaSwqJ}dOH}Qx0u3HT+ueo`I-9kSyb&&OTVRx6 z##d%TmvJ{p6uUz%tv*ipdl=!8U$50=5tTOaJARChmeU=Ap2>a0FKqXK%lj=gs`l(C zw_(Of>mm6mP*W$IfnOrp=63r(*xQXvXS8Vhl+zbo)Sqy?B`jBFmA`5WaayCanZ14+ z3K_0p;_2;&B#qPa6kYPX=gkPQg#?;ck$fYE^QRUQvl5}{He=z3M?lcBLdf_=>~PvZ zkDNPopv~hF2~9=M+&y~|YTJ0`eFPUqf+_N$>~m=o3Lv^*SWa?KQVZT}GYMWSHXIz# znB$;bfna{bZsZTj{ac2HEdpD%dJh^ZyG&WnbY=RPPYe0@Ml7I?793g;YKQLg9z5Ei ze|`){-86@8uU?jn@2NO2R@nSkC#uF7QR*m-LQYHX`j#vCNZ+=Yf;c{kv6ipv1cGh~ zWyx74irFLP@+<#a(@h(yrVN_`@Ar^7)A^zr2W(={1Gb6?PTqWI0R;yJ_a^PP5_UXN z=l#B`2ZW6bS^Paa74=wwxh5u&bO6)DLqYz zGQ#Qw|BnAy5WXMC#)WoyVJ&Qx`cL>#c}WGnQra;~`4e@-Va9+Z`4XLkTU^2`r*qB+ z1Wteb(cS-gt5NSJ4efQ$oQAP>BZFgwVTOvzm1Zv~^&Lm*Db_4{asI~Sfzq!ixjjF| zZzyRpA!r#&910-wQ0BEFso&OcPyEF5!?f=k{9$h5Yqmx}prHT6^^c}7z__icYG-w|JQNdV!7Z7Sk^ zW6q~sFZ3am$ITrC2h?^4W=iclTc8Wg%Y&=mt{4v;O~&onwVMc~Sq@qt@dO9g>v67E z9icTKb4N2?wlX6_frJItS~SWyG1RtFzM(N@Pjyzz66NZH_SF~Y-W@W7M{%_7IJ1M1ud6a+5o)bhra@|%XPAZz0;Xb3KGF*!NJ8Q zKIpB|^C7=~QBLPgsBiwFA1*u%RdEPqe{B(F=WBNd*gbQ1&c*1#Y$|`dB@t>T5O!jF z)Nqfr2D^xJ+SFl=Th{4{@IL1(g?f^Y5GQecq)<_cIO%fn=RX;m>%euBA?HEL83n zD?}(ujX|=~E9b=!Q_SAgqG0;+spgXZHDQMva7q6NH4}5uiB?Lg-W72ZNHrcbXTlmh z5EY4x5aiPs?xG~Z>t)JX+26`?^$R|sI6x-5&Xk6fk)q)#Q`1WP4Rw)k`HQiqGQI94c z*pr11pyE-KFzdP*=R~5>?HJFSFD8x(-yQ_EndoJBDL(I_}3=sD9az!V3SJq?X^1lK#@S_uKv0aZRNh1R( zaD<9%ruUoK1M24%nu+H@fCC`w<1rVyEws09N(5Dz@xT8IoN6o>zzNa8o*-N;pIuQ6 z0#5fHQ;Oi%KxD>4NaKw)CP>x)2B~4@H@uhSi5~R#4&ujo!jNFrJG%g9pkczBZ#s$- zvIzOG<>u|jK<`I(uywS*=P4`)KCzm2S3QqMp&+T|QcS8!zeU56v5->Iz6xryUKj&p zU92R>XLRSVd^xJJiPHqm&`+RhUE98ibx0h8or-ju5b z1U|*`NYEq{&~4}E!D7ogb*)KW?7ds0Wm%x$;9U)n%@H>3RWN5GCmZk4E)o84>!u0s;7|QKv1NEEo%>Iw==PFEAIGVy;CFAaTXU zRQWP>6vD&=nN$Q?I#i&XAWg%KTLrH^vn%_O{6o6E^IYyt)IWU3c8OFtp_Kd_tzv7C zr6e*1{<`z!ZY`^zM6~YQKs3TP0-4Rz`uQJG6yZ5AplD6sgZ?0EelB=08Zox#2(xT? zD+CXDftm;cg6J1q>%`0LN+*Jd=SoVB0V}i4oyTbW2uQpHGDm0xnW8PjP1-xVED-kL zKq1r-V>s*Ws*x1`5#&`|xr*0UaKj?$Jz*kHvR$=9o=5Xhop@vNB@h)HYp#GcH+NxU%zLFktsL4>BOc{Q%_g;K`SD;CZKXodPOx6De^VK)YL1)mJ@=D=E+EHp-wWZ9tKHRVdp23tBudmp)TD3Mkai!Uv7Kv|oLan`q z%DObVFTlzlqCc+d^9J5ts&zs))mup;M1L{`{F2Ozv=>JPrcDC1_UhJV5mkv0y|Io; zmu%P;Xp5yz=znV%}`!%4z^B;QUJKC<9bw?352nv>fn zy7Dp3YuTFl9rKAf*&Ri-5LUtvk2nZ${8-s zlVlv%{lN~L*rsW@P#;vgQ>eXj-@3WH=|;!xZ{#UvYC(NckYUlJVlU|Uj3Lj$W1su@ ztREoR%N@%TRqnCo9Ww2=l9`~5fOX3*@C4i$) zzT|E$mv?gmDQ^=|pjn3gWs*MNh5S8QmE8&NCJYs3Fi@{N;CvjSb4w@dI>llI+{1G$P1)Y~oH3QNT*Lf0Z3teI!R zzR@_n(LhIZY$hLlnaSd>*!K7ZZ^=oHYghrkmhn_9r(!;OuBZ#vwR+?Uwrz!7{!pVX zLJyrHc2=y|7Rxozi6oofs%$7qYh$^Z&64nWQ8U80%ycwf02JW2n&<$KM_(5 zNiI}@)6lMot8@49Ksf!)87EuQbQOd%(1DmDfgirUjIH*;d8 z{nCmIo~XE?@YBZgm9(`DCZ^~rtsqX|VPVJsIU^M098`QPeJLCnj>bf26Opj8z;qSJ z2Kd?B?xGMe^D+IVaNO7nk>EUF-C{K|3Bo)mDH!_cx`~QvsQQ;;kxP>M4a+4nqVgvL zOfcwEiGP#kx0`tB$ro_CFeU$h_jul%+@UG*&FoD~c{f357U}gi>mKLxwb%+TcT}j} zae@T_NUeR9TC@I&xKr|t`nBa>$HTtd*lbms%Z1yMNT+wX{fr-me-MgLq6%md1tS87fiXunHcFC#o;;exI#+u+Q0L)VDy z2dUFRXc=AiL5=~}urmuhJo z0vqo6K}ydF{S!+|lb8e?sJF6kfwBZ~Q^swPE91p5* zPDc2~uy@ml7l@pRoHNIhUh^O6EA;=h9gC{f)f$Xu+vXJbk%mWv_>LbgdHN;A_+fV< zf0@a~6;FqOp8=l48hO*Wf$o}crcsqGn{qM=P@8{A&ejWVT*hU>goN8CdGvxfUg2@q(I!j?ZD{^fU@-O zKWwLXzoxJa+O46f?d$BrR`%iX7}};QrxzvtitYQ#a_gCsgF@PGV%vDlU*jj*t%mV_ z62s7&P-dGXUgqdA$ZizauBxiExF)^YEt=11x@fsvZrJO!_9evCmB>6ekhgJ!ge9PB z^c5m@bX*I#;xJCA0^264iyU@X#S@4W{+ZnH5LC;%w)faqa%Xpfh~E zF1#BXHhpr?j1RU|RG0B1#Xo!}ywUOO?T3XEMdpR2>W)~6#rbIRq(kJ51=Pj2Y2*p~ zF*xz_OLK|bIkng6SmCn7bA0P$DEhg&YTQhuIYV)Y66Lj^^-j4@ojbd#+4?wJH*K9LAV}cUJ}#4+Aw74rUomW}u!TJBw0Wd3 z6Dj_4s@;HQ8j4xDiMle~Q^i!k8j-kJfl#IDi6zsLmh{Fq696`2SvI)e|?QT+m$OVyKA zs2;f@jYg7Fl1~lD8`r|axh#J`P09;b5YMJH@sY~LEteb#;uo8hn8CPoY3tPAJsc67 z(QEt6WverU!;l;deBrqw4Sd648Ebvr zQ*trI5gvLL+=e>*kg<@_OA5V3vyBc7-2kgw$r`mhzlqn;%fW@9HQj?2$4K)H`MT3( zRpQmzhe_jNW-IDi*`ZUu!RYIRpHUUP?5gkcJ3YsY?@SB z`sry^OyAT2gQ*ie%>K@ZypTogN9^c0e9mS|)D>+}97HdJXupCghLkKjSFU`(KZH$% zPE^FKog>wyHV;Xr)7qlQK+>V_fw~tW=B6c~d|=d#=4faQf=&xw;46-rr3{Es7*i2J z4Gj$&e&=lQ!atG|o~(Z`9!Q2J_sgFzTn?5)+IWNi18`TsXH4dMO2C56}s842x;te|;#82-;mAr3~s|G>t@c>U2qIsN?=-E*Q>Sx_$b zyLD)_sxE4=s@B$4r~+*bEF9A#LKGW-1iS|$y+D#)m4v&}$l(gw;^euoD%w3LE@{Jri-kt48o%4i!KUUt1eePjnH z)onGM9y{SII!v$#8GNV{pqQItn|(7xBCEg?iC^p!KHmQrJUWtcc70dlnbILL?lY$| zn|>ToDVNegL&u_idU#6X?rz+-94=`#@}(bf*iIyC#=?N`4D)ff{Nd`bN%QcAut|$Y z@gHRsEH7;Z6a$@~x6``M)I=E3RjJ)*!FEkAO_c=|VGQ0ww42xbpTT9xJ})04)i+ zLUd*6@{*;|C5mK}V;Q=lRAu@l=nG{lvgSxF+3EtFf6Yr=R=mxBHzaHe*_5@*tCMk# z<=S5hz=r-lt8^P^6ZFg)R+?1KR^wHLbn1m679gs{apXTiP7=B)55m=N@@KO%?$0gF$B|0qH?blX2- zOLTN+Z9=Q@GYlU0g8k{CF2Hd1ihZ4+!T*A>-!M!#XRw4ltV@$`%dKtn4u@n1E8)F1 z-=BBy#L@fx+^77|VH9^1ha^WFAM=>;;?AOT-m&O58VW0DgnGn}f5uy9<4y2z&}M&J zx7)H@G=F2WKYXj7+)U#Z;A|L2Q$jfcxrwMRDa{;(e z#xmb$Sxm6kMNvaXMMXzPRY6x%R#sCRTrb=_OW*rdWWvDl?|E!QgJ#h+Ta0@*85IBn z8!73;FmU&7rseH|peAY*sWzRnYP$CC8AN}wP{F}o4HY{Fiz$^=E9E-_eWBs%MZ(7E zCQ5ZLl%C_rI!tBYITs?GvVopX`5VMv3|3)e>XHAQzUs%F7W)ige=9b2+M7>u&ygjY z%D`7tbWbP&jE16#S#o+o)XhfMi@Cn>`_lmfiy!G{;(x1S0&B~y?BDNjNbl6WY1NkB z$nEc``S}{UYe(Bj`ym|{Td4K&m@aHr2h7%HtBF2ZB`{B$3boCGZ`zQQ8NFpgX>KLd ztQ4X?p$2c3n-`VNVV1^-J@o9VpgDDoLcF<<#4muu^5;8rR1Hx0%N64W?Ov80k6|A! zFA*DpDOLzqyP|%??s(UH$-2dmW{He0Y#P8HUc@O+bc51pgHIcv09QJP>t8zU<$BZ6 z?SLFhu)CW%xi(`XTBN0DMT5OfZDC_+>nZr7nStJoJ79KHYAS@TOuQ)7t{@RD5j(8v zPggG=p-wJLjG~CEJE1C|CMkv=)bktEU4J<+64R+huQAv3FceV=!`}9a-dK;c9EOml zc6yoy(b*{uHu~UEeU9#JZ9aJ-n_GF}|FoWYIQ==Zd)3i+a`!i}BQP)#2;nt6Ut@=D zCZGmqP9Z3Nq};N7Gw>=xl_1@sC6~S;xZ^`1{A9Pp)Clsf7Ko0ZYt3Ekt^>1slodau{c|Bj(gVdjYcQmMqM@KTJlq*U(ld< zb%Zq$F`>g^W+nLO%_Q86xcOlq5<|>nbbV%_ z7nUrhtIxvJNo!I_(MZgM58ua~#tFy-PX2`mzx&o}KH^h_2Co&ope=Hp=rl|qlR``W7tkE|gft_w3j=n%Jt>)sYhh^RP{Iu{_NIX82 z_3dh**|s)TF385f1)NNj$HLe-*{c5KaGNM3yu%yQsrmL?h-!Rg?*+#XltVMxTE}EDnVbQGoVV20@4V$82?ed%kI zB2^$L8570iSel?JVp(8et;u9t#B9dGSqUug!be&yCUm$#-@0dyFLJjLn%sTEa)buI zz#Wm9|MFJrSK>3}1YR&PfFHL*ugy&l9=}Pf*U#`Z3&wTq+yoEuBC%*|*X9Wc^i z@=>pzUOsvutZHa=Aw&{-N%{k+{eY7@zEa~CR6`faw?8UENO8=xaJ(UG4Cz*g*&Pv9 zF>3nR=4eooxG8zN)zEBRrja%x-UP7TLPRpn|D1DbvoiJc{n4BP-XDU~a1el* zZ}%8`5$hME+qpy`5XZv(DAHA?@Jjr--^VM^tW)Lp-TSt>;*B#hG_mKH(2%(5No7vh zukWc@AmKiL_DSTPFl+4E_f*6=<^m{#{?*DUY=#ceseLL?SB3+V{iE2;9`b@WHJS)% z0lP(!zSBW;opgFZ@{+rin|j#~JX4TR8PhV6Omh*6r-&o*|i)UW)8jE<0ddXO-U_I{srsCWX_1GBGhbRb$7cB$}i8c$`TH znIWM6c>?8wOf~(JGd(pmL+rOA6**`M9GL^Sr59YW7_&!+N2B<7U2N|?@XO|Wk*&5! z?Z0_qm)Pmqk-)ZKG+Y*9c_`z4HAFxiH6>5VBMmnZk}g(F;j-0jT+M(g=Gz?tt;eD8 ziaktt9@vfFTkW&}DlBU~N4B-%bw8xuD(~N55W09FIz-<6Z=8_BhDUtEDE}NY3S;k>j|0g61DnQ6*AJ zQqUO_wGiHwP#OtcnO3a7^X1mbbEWPU#>4Jgre>r7~6k_qwwh zjTP}eYmL1)Q>%nwoS>==5B}G@Hi{sy-o@QP^pp&oMMk8AZny?E+Map?X18FU529y3 zIkJ9oaCLN2-Evz7>E6?~W%$tRf8KQouTwz3G4tB`Wlx*qt<@y!58{$UWQl6eI}RaK zGBp{gu#*@ICFW{#rMZ(Crm!43B|!5RW%3UE(*FSGuSOte&TOWj+t>t5VOg!e&Xa{{ z7%NWW3P30|KABpcG}#hjw?Th~@NyOuo2OeS&?m6zzsWG$sGXyl%Yp5bQVTYQO2Vu= zIZqKkma+hq6rI1fdw4IA#pz(o#Um!8$K-_sb!EN<#JZv%-EAzr*2(m>BI z25?KAr^Nj+ue3Jf_%c4OVVs3;#U*KRY4~2xOl%#M>9UP7hhFPo@Y}~NWAsC0c7x*D z$1^7~jWzRtAFlxX{`f)zMkELKYY2weR|alEQ$HO#)A-0II$iPKWyliD*(~{7PKda6 z@AcqxL_r&v%A{GD=qd*=Q(-fJI=Gu%wokD~hClOxGy#S8Mm!)0BZGGoZ^kB3c=3lp zou^jTfrPnnfhyr~uP=|$kH8ShD2O3q1+95}pEUK|5uW;+r0lP<3hoP`}YDYJzwO;N$J}8ItFQgd``l%pvtwAJA+Y z2HpVW0*9asUOyJ%497;S{vDG1zoB!xY3*-bZ=AAwqjMIvh~Dj2cT^UpHMMO))f~8T zlfq+jQjjsVH}Q*wr~NKX>0Ql{Dqu?UV<$$RbokL(wNvz_*$#YBqLjFfPp_^p+icf5 z@A$jZJD)LUlTm7=;rRcLwRemWCG56!SKGF2+qP}nwyo8+ZQHhOthR0A_P&44-pQAn zlbxHCQhzG5kgB)Fn9rDq24lm~fgOH3~O`8F~ zX=8<;w?Y6{sFzIuhY8aei#-qhxDCw=z;&y><`Bg)?uS5_iF)aevE_z>8(cj_RX`8q z$hOAAT3|3jG(safpBoEf?Qg<>v?KC(^-ma&_9(?LTYf2EV2(Z?OqlIDph59k;pNC2 zE@q1ATD(2xdO)W;rjxcxZsKW=^L>HQscE`$#ie9w^%H@csQ}?{S=Ai3!eAc!z1b>; zzlZ#b#R|4wy`xj;dXow~k>;~Aht=rT8Hm#w{*tMHQjo$bo=i&t_Q{0+|G?n~_fByN zugIwWsf6ajKbS%A=YV2cP@M|h*MhY9|JnnF-H3|pyt=H;m) zmQiep8(Y^#Oez8oXPFrIqd_Ty;r_yFjazzV zTO*uqHc!6ZKcrCXQ?W8S43PyJ-R95fnhQkm!(eMS7jf`eEY zu{TK>?-2BGex1c+Iv(a*9LIb;_m>H`4n;Ir-!2ManyF1sj84-bV<|{(CL|V!w}?0S zKOyVuA!ivk@uWY@h1cNudLMP#Yx*%IX|MI6P3nKO5f%=v3sI3}qqJ-~MnqhTG_f=;u}@K;82!g(NGcBz{NQa!|=XqQfQ0y5{y z$Q`G503QrM+WPj}njNeJ2TBD_`g*qf#WfJwl@fqwL?xNP@Q>ev#9~po`vh^NJOkvz zy3pnbRup#tnj~z$0>6*u7F;e`XtKq*8RYnXu5G@<(##^8Y7TSQgx8IkEPQ)}hvwD&vxFde7=A6e&stL=+yy!}kj{aI)~MQ|Gg~8dcx~ zpphN87S53W6;%>P(JREm)ou4k+^nGZB*bigug_&m#@zk$FxbT<{AZWshfV*kScJ@W zzE~a%M!;kb9(1!G15om-34mqZ%fDUu?yU!usdyMkQVE0}VnRnj!2XdLEEQi%0auG^ ze)6FMrS@MrRoUy`6O?(PrKpPajG~*OTiiz9%?S=|c)OE`LAJy1}F)$7&=`}GTb>wwYk-Ktng^!deglFbJmti80s@#6zE zjwQIi+w-rbVMioqo^_i&P@NH&k&@uI=GvJzqKpPCels83-i}LWo${iOn(Lq1vJ1}o33a5|)KAjiPMu;&D7Xn8K6|BkQCmYqSjGO;UG zPa&!aptkD*q(}3lZ<;wa3Wm+IQ8x%6W->}8#$E?DJCdKE9XL46vt#LaunESr1UF}i z0@8u`?+u0)J_mYuYU#lV} zG??O4kB_p+zBGY=pnxAHK7LoR$H-GSG3z#O_Nytd2G2+%J5Z=pHWSm-2QiG;Z8OZ6R+X9rY7-VG9mtdjz=lyMJ6rAH$jDB&!u6Ca zfIP}4N;T|km+6GPq%E(YzhF@V%CK}dtmCrUT8Yt)DzI0|1#Ox7X|u$mXW?0{!`c76 zRWT0fx;ma|aT{%@siEh@)a*s%6ANtvt(!GdRm*7U?Sg$=Cj1!aI73s5_64vE2pb<0 z9++g2w}GoQM$gmPn*zW1#cw&h&5G2LGCeYfhK**;xS4_jVmh;g{Q$<@D!Qh`BAyQF@DXT7QHctA`R2KsAmVW zyU{DFA!swXJOXvXf_1VaNOkr^Q1e(DcE?TbQTSJjl8 z#N|F2?qRm3JE8e`Hh-nIP}!truC}>$Fzge04&t+038NH=9p|xB^&n@!cVDV;BfsRb z=Y-R2mL9cuPMtpKNz9Rn89%+}Jxmg!B7_LDBF z=ALrjEL8V(HM;ZWuh?kr6o88cm$#XVpac86<+GEy24JPz?5APOs^ziGVa;mwp5#&7 z4~3qmRb81V1!xG8@k0|Ar5jMT(AUTp2QiQR(r(90KzvtKDT(CjWWa07{oac`*lb zX$tbS*WVnT4dlsjQ2$#;F>E9ixOwb|yq?&+B6A&k7*{01u-BBab3Irs(~YR>uXfk3 zy?baQVJI}8S4zBR`I(I*f(~99Ul`q-r+?U=m077p%@ysP;K1CtgN0Gp#n{KWJd^9- zfj3+kI5UlNFVmgZk;=T|oca9>DskAUv&oY^^3q6s^MmL3 z6xsW+kzSB5T-wk*bMtr}m;Z0wo@FiDR^V$IZ{CKOKH4PNMKK(BWR~$@S2bVF-A(ky zEgc?Km-}6v+|riM{*vFrAc-mLXdpbNY3FlO=I4TDTo{|s6BF$ZE`tDXRL zK0hwzNLNE+qq2w|(vnY*jeh}-Us&17Pd>Yd*f-o!gt4<3Sa{F%b$~50ubFUikx*A0 zpMrFv-{8uc=e?FYIO-QS#FK!J?>ET0gF9DFKdpWH+vzBkT8(b!CAUe#Ehsnz0qjz{Ay}t_81hNb-2!QtTT=bY^usCAvmSVcnAPx_{w2Jr}Dqpt3e`xviOe zy&lH2$*xrl=eR_h9&=8?5s_fO&Iahr@k?QsC8+`^7E#nL4B=)D+4>s9SC67jFL-ol z{6EwyzFBRv|5buPdOgLV{7VMzv;sx8x@8N`DM&0@CB|5Ab}-c+8GXCOP+FG%VS2$q z1}zFJD_kfz?@W%W7aJ=YOOCkqbPLDV^&?L|8XoMNEySIOh_jG=Wd&Vf=yZLP-D~N~ z;J&LqOi1dAvsGcqmr_3BujlM7U%zN-2sJj-9CRD?m{)oQYV_=#nn8S9xb2kHhwW!x z2sdOxn!a2%W4f8E6&=yI(HJ}7l`SUoJ#+aQxe~e}$$NQL2@!LkOkKW1)IT05pRnz* zy`uO4e>4NCd|niSpzl7*V1D8|+Xz$sTw1U9b<%eO3Y++WIARaWF^BG+i6DgS3)m{b z9AP~|?y!JYPWxrpK}Ep1bZehlNyx%PgS?WW=4G<7_;ntjEG^HAhvOZ6obtoL7R$qW zbdK+PHuZ&9K?fQtWhGlwdiXRZL57IqLYZ; zLJ09=%=2;5q~Z~2nsBq5EUq_@QsF~(9@=ovUnARigc4{s;b1?0@sdOG9(p=yx}wbT z$M2+DY(xZn6~W|rq~dfl1y zIuh{_-=+eZ6?0@MvZ4{)NBTF|ON-{nzUc^XlJXq>iriG9*r(^kN#*?6=`bMDCdLu$ z?39egA2~SFTS)AImrVDbfD6{bV4Q9NdJUd9`64#0vYt!Di7lGWiYSsu`&4Zl+7*%^ zWwhDGn8K+R;ea%TGg?UrWVB3FB+dh$XM0pMP|0(qA3^9B^HY2{2^6n^@;@pmztWPb7+Vc6E@5Hf)W}dMgs_3 z6!fT6soc24d>&zed=#+8hz^NSYT1=phtRP2%vg_4%hWVoT z*f}!#45Lo|Eo^5Omz0%;1c!`BNgNR$ix`ikh&%VeM-MC@QBc&-M;B(C7nvW{#x-Yb zWOiXu84ihqTK^lk7KpC%idz<%vF})2Q`Q14iN4v!y;y+FOcy&6uOTSJXXH2N4=@4% z)b6_yF97tOF|qynbKP1F`k$nG_Wy-+&&=>YLimh~^$iU4e><$4Tppb7?&n;eVPILA z|3sv{e_em5d^Ki1g)tApVT|B4Nb?=0`Gq%*{iaQHAppnEz6l%}0l=5T5Tjp&psS-} za7MQV2|tpM5ZP$700}Z|YqOiaGGsDd+q&;Y8-@d$RLsv#@$i#ZS|#(jz5mcXDgA ziSwoN+DbmRcD)<3lO@sHp5W^Q{AOn2aGOl~i9mni^*XQ)weCwMW0rbg$dEfb$Pp1% z85Z^dyee~zqidwCxkD1_di|n|En}DMka>;o~ETE-)|d458Zu2hV z27=v*i<4XmG|uM+DU}~9Yr7fi7Q0?subBRVn_ zQep!_BmD#=$wrHz>0R$e9=h;7zKQ8#tjbN`5Z7E;#81x4l4Rqhgp63sp}qd~GtrH= zLh%!zVaUehKb$P4{|$|um4oqrM5Hu(xVbAYcf8<+TC>6ff?=l#WJ3S~Qo_TFAV3LN z+`|0j|`A2AZDlbWl2vYr59k0WCyf9Ktq$&$(|Km7aW$m5n zd=V7rP@7sBow9d13zhv);4fnG=lBZ-eTKJU>&PoFS$yocg;9AvAwr@O zH~~TIEF?sFCp!%fACtiet;y}<8b-fUj<4spQNNRrU=FNq5@KpPJXSVl7o}!96)lOT z#J4zXjCiC>xY9A0oL-w$xwIa=m#eMqb=7H7m4-z+S8nE=y1i|nquOmpTUFasRvS*g z)PiDie`TT4eju1~F3YWzgQlcs3nML)yUIpP+mv#_Nm;xQsnX(5?EHi9LwRW!bpa}z z4uvk8F%t?+p)gSyGG#KRB*TBXTUZh>ML-k^%Ndq(|I6AUDHvT^v?P4)dk%0;@L!Z0 z&$R#I+?XmhmaQv;Ke4mKdIoxCKo+Aa(J9g?{Fj}D(UPM%5VG+9rQ9rGQfB=Z<%Y2A zX$jPls5xRox?9>NUpGGoOE4mQH&=KxwCHbYgv|b=P%gG72R|x2VjbrnK>F_J9&T$Q zB12dDUf5iwEqX!D{o64Qq8~(buJdmNZ+Z8*tNF?i;Mn%>(xG~~=x(MO`>o^;$eRz@ z1TNpf;CZAaB;O?0$ zJIwIh=tzq|vV2PAS$J)6kD;%S?F8(^K(r&yltmk&(tx*^Z8tKMy^sOf7~4h~_HIzV3;t zeiwB`{8qjCuTj8(G4-3uA86B4Ph|OrtLiVifGHra=p5!_6dUionC`4*!`_F(^6Gz5 zC__sOnfGL0ZqhLMUK5WRkh}b5GqFQ3ib7fAZQyBqyc1hYLBZ8BYc#0a=UN05hLP)p zPLBUv$pgpz#j4a~-fqfJe}2B&W`8IW&NFlIKB$)b!>pFD)}jc-L$@HK7qen=6ZVBU z%WjCe>H)H^L>fKkIa*I8b9Jd73Dbd1=2@P0T~7o80L2z>3N!#tJvv->sgeO_i{{mr zF3NzxZW|!0D}`3_x}*M1NFP+F+)9v-g1N!(Qds;DUmk`K!>=coIm7QC3JXV{?n zBxdM>?=+mAfqm~@3D^L zm2;-)>}rBS51Toi|2kdVeYmhWfDVDp>XYF}ay_%qD&^0BKJ5vT=CM-#q3=tD3&;*$ z$Bo$=i*%Q;Z`ixxnYm6-8~9+xjoXAA;zq=ihhI>G;WLLXP0ThKQf~OzEl>MqB5M)> zbBSMBQCXwJU%aBa-*+%0HD7q6vR0WbPgl8=gqAo~CtuW`C|CqGr~TXI;;*A>SvHkg z3Ya-?CV7iZQDTdnn%Vz{Q6;~EAHXuTe!%})i(ojGmWmM>17EI$Rz+7iJjjrwJx;X-mjAi81E}K;ong~eRuNMpB^dz^iHJt! zrTI(CWeQU7D|b(ahB6s8B2?)|i==k4uoRV24aGA2=2I4F@6N5CQ1QFrJ{VFV?Q-%Y zRiCaY-4h4P<|5fsIIVB6?gu|LGejoI>cTubHuWf6A0{^?8|%9Si7%!qJyqo`G_#T~ zL=U?+A`D-&XiC0WUPwRAS0+h>L9=-o;P#D(OE%t3=bfwx7k%|jrGr19piv#iLAyHk zZ2~8Z_dU4p6&c}iT(#+^a#=W3>esR4zK4m_m**-`}KJGYXFG*<^7tik%ySr z;`Ykt2J^lMthDy(8{10`$Z@R>f>eY-1k|k$d)(obYPqNpbts`Iy66XtFjBW*lh$KL zoh~)`N8pX7dJRZWSFpd2go2;`k7{|#kT!S-bVQv*xo^z!g%c$79=|3ugH!Gk%qfpO z;`2|~j8SE~LAicU>D9KsMUyHzt;RAR_n$`I@pT*Xu~ze9Fqzk?Et>ZWoTP_z^dm?+ ziRTI}4K{l6+es{yV$U3vI%1@zlIeD>CoX*40-Si;=6^5QuEQ~>2`6K^2>n%jgttq?HEj8$WP?s+1huXX8a5Ci}z;aK0BxGhVj13aiTPGXgx zDh?Fhr!fB=ElEj?*Nor0HoG{Ftscnz$VBXbp#03|`ktIFegz~Hj7O$m!f0Ocyw<*+ zkumpR#)$nJ#AHkAq~=CiDkX_{Z%|XeMs<0nL4Z2)nIt*(oKgJ~qR)5+dAt6twQzZ= zgE0wu5pS{kqUHJTropBN&JEanbpw_h{Hk8LrR{|Ur`Ey*f#p7m_$ZhgBay~w`&X2=J3 zfLfdQ>yVVbu`2y&N;KtPon*ygJS5@K*qx`@;l;(4l{n7mu6Y;4$pJm_V8AKF@Th(N z$HpC2Dpe0q4#nbwX#0BVhNh2Xe*xNR)q0m~GejB(`>jipHh_wMPJ6@%HrLNl`eqL% zM-T>;wymCeR+;8&hnNS%mej=?WGmRN8ee7cQnE6c;S4<%ESA^*OvpKaQ zKf|Gu<-Ik<1neo_$shsTmuv`cn6tIM#?{uhYdJ%N3f&*l588GlUP1>b(hi)b0wUgj zxCn)^kL8C>@7`gaiGcUhluq9~cOeAr7>xnxa(MhTo%4@5(fvHgKfv?jkLQ{B(6R-gD70N6_rHG4cCQ->v^eThP!COwj(6 z{n04LoA{KyxIieh`!JPqUdFB^W~FYk5~A_}wv;(Kj{62uR4So8=TrO1kSA%rxWcSN z$iDv3KBwMaXDs`(ZCm{z$xhSU+!phRbE$hqYYUZ`*1VB`%|0B5J?9P}K8_&)iqf_A zgFRnG+gW^5ZaPoL2ad7x_ah@11F;D?RJZAV}JQlInUo_4+EsSv9vLsMtMU<7AGBsy<0=4i-LdvAdURtI~HYbh)odbQBcX$ zP4|J;EhREtm!h9A5Olc(v}ejDFtWSWA$QXgn&LXrbsmFxFyPi@ zL>mzWk3Qf`T!+q3}eaz?W#-v?F@;G;*2?P7+-Kc zDj(?TMYUH_Aq?f_W!yuFg&StNP@FTWHymKArlLM)X_zlq&$nRII^AOVt713}Z^4k}sqtHsl~n{f3^~MTw60|m?Ccmx#>XO#L9MP@e1SPD zt?fQ9>UDp0fkI{mVDb8??(#lCADhG;N65mz8r8`Klt@aTeVQ~XrN*gfi9M=cmZEw0v&fhH)nEf{a_z{ZZ0-?gw7X_aT@omWo@^kAi*bL0$G2Tq3Lj z)*C9Y6i&b4=7RB1RO~}-cAn%~dfXiJ1s=spu7@NPWn>2C5tsv#5NWUX)-3uFvufMk;sv3psbO!Qr;?F5qm z&#%aLUqf;dOEF)7oZ1jqOF@c zoABcNxd3cUBZ*gVKx>H>&wpJNt}+Ce6#kPyedLZE#Esp$w2j2Lr^7;DMuh&ogz zY~sy~O03p#3yFRp zvc9-be9e-#U*h=;M11aUe)X*%5-qfW&}a;W5-YkCk$&p6x-$A8W7{h?_s5&a?^WVg zJ?X8V^-sJiZNGIwly^($R$m4Or%xC3}+A&YRh+PwMc>ph}dH9=%gH+lz%kehXc6c}yf5otJoyo-2YPs!0 zt*D$KtnO2W*jw>N@v$yKQ4aSWz!T*_*!|{Oo=11AwA=7U8fY?x&C8q-2)UCX4Kg4z6+=$4vi;#yW zrEQDxlkRvebEfy*PxwoB=pT=WnPpC|FU+2aZyC;zRUl8|wpU%m;eph)+PY=0Dr&r8 zBuZ2YL8y(*p-{RF0U%Ycuh#fGZjW$*wdY>?gZ~qASHT*`p?+(1FJ>c7b8@^@FDKAw zweV6_RBQ-!ewD8Yn{(mPo86qryD92*Qca8=&1`^i$N(QRQuS*6$)39(^m9qN%W5*` z#ry!%jyHCb2%?{->Yy|q7G&%oEx%>P^IlzbNwTIaomw-cxOc;`g6ot57$)tm0hb$b zJ#$Y`ZILiE-4V*mOpy&*|S%dWON%q?`pn9Tl-Ul=G zoqtJav*YccwcwannV*K+j-M`ZSRap12?S^#opONmYj(iiOE(1)6R%tkCfip$GhG_e zn0D!#}QxgBCk1dWNbj3%i6^e1ki7m{Jci zto4e#6X2xJzv%fU0Dxk+~XD%1IdhY6`wPr)8b8!NJZIq?5s==boCnxSplz$ zL^M!OEIK%ap{XP4ITdr#)-P$-*mQ5>71MwMEX(!CZIC0wSXN%<&~EEZ!oxLKPB96V z2+gdi!YD>x9_06LVXfiEwstz83pIT`-dB9Raj)djjQMcs4(XXS4u+F5TIOWI)wa0| zs1#i(OPdBvgK><4TwIDRv!M0DWp78a`MXtDURU>@ErvHsQa_Cu6sVxFv@cMF#;j~Q z+=2JwC>5jLlS#je#NzjJ=mBa1$oMg#cy}tu%)b)i1dtBHLR7f{(gY9~Yz%-t(hK%K zPxqa6xozO8>4=kNuUYS;Ytc2v>nfi?B9ln+__s|KuD&UZ6a);QOL1m271u2)O@cg& z2^W-OvP#3F&ZW31dZA1^T;4{8?95Ov9>O?+Y3kv~xG8Ot)vET4CZ1!72QO#rpThi1 z|AGNKw65Wq(M1n#-h(9na{TG88iIv!bWZ0DU5V3_9Uf#Na)1xWk9U@D5mVQWRGh@Y z#T-?Jeu!yfUr@qCC&y!O?%}d$@9^CD0n(=yyZuiR8`J+nfo5c9_#gUYwW^1*k{PNW zLEH;Jzl{e9}0k^`9m7G=RY_HZnK5iLM%1EGzjEzo=L=~k$Y_HYnG>tG1$=uYOFEOsC z=A{%QypN0%(m@H~oYel6&Fd3OV z5Z)ZNFw_WT*F2<29uxUS7&n|}J~mk_EoJ5)(VOQ?G*Z_Pi!9rUof z-{S4`qnsCAj+8`S`=%M|`+R7D6-p`R=R=C9swyhhE9R7?2+}qmm&~?Kp|G!VZE<1x zF?c|J11FX`ua=DloKk1ADY|1$Eu9F_Tpe^Qe_)7D?R-3ECXwZcWUl1gwVmSSwvZ8_ zlS_EhWY7ewrd{F|U~8CFS$&^8lWyzb-Okf!^9!|WmR33c7|>}#l7r5L${t3zhqI#d z!+BP8$k!S-5LmZrM&}MnGx~zva^EuUqLtis?ZL3AHUp_B6xX8iMn(y?&5g$AfDXxt z1>Sb{!>#^{11hFgrU;fVQo~46+fLgp(1+P|VfeK@GNl8`qf)?8>s)OG9$Qj1dCs*rl`fl1EIJ)Qmo<@e_)NcgoD};hD5IpJ`b(8i zQ)z&gKZ&>uj}Z)Ea0MTtouCL*NI80`A}Il(9HE4IwPr2eX-6v-0yalh(e#!#AL&y8 zdCHV`q&N!W!nrS(1;lp5fqng9qb9{!C+4@!WhwMLTr)e&7HPzq8XSv=Wj2osl>$QJ z<>OjV;egIYF1T|P9}2YL?I93z-1PblL&P|pG?!&~bir9(25S*;$sEPS%Uc6Ek4i~B*&`rY1_4r zys>e1l=&vcHVrYqK*~N4o=tvz>H=vJx1GQF-T~ObVOu-NG;#VLw8PtJnZv&+v|WEa z2H?YIBIWWYg3fy4^E-Iy1>H2G+eiUi`H_SBuDKm_y#+O)hxiSZDnxbwL`YprB38q) z;&3vi#qjE+PQN5YXvfNPrM{e%Ml;tulCeL>HGSltG83pH0@*d^*NEWWEjZZyq4C0(N&!O5+G<9j z?h6WHVVksF5_V}1*7iY_wU-MK9iJxrd2x&cmibqWvCT<}++r!_B2;v?Jd-+CLTm}f^zmOh*I2Y09)dUW?6)vp zQAoT;kdR0T} z_g&^j2IL^wt|94Bg|Rr&$N95{s<@EXH~>M}-@i+k)I+i}m#+6OEZFlIE+a$-i+A1e zOcs}w)8B}*0fec79EVJ(f6$z5N(fw_+ybUr=4z%F%bz}IT!&SLwmBY(vUqwkC8Tb3 zV*=vi8C-slKyh{U@_r^CnI;#d`4+x1&Q6o^sx~j4B6cDA;}fcrj=2DQKT^{cgFoqt zepYk1ZNB`@KYqXfQU!-KCLZL-VwmVy5hU7=n(k?HBF~PfZY$mUyIr>0*!_MXmFQW2 zzfRHNTghW6KJ*hZjhLd;o>gIREqDNl=E%yWtE6|csGtQ2%IJIOIYn`yP{sPWrp8ubTn_1#C|*ala9|W3*HM^{ouphmXa^%M-~x&4J5gv9VO}L!>Vq z-0z^CO~));@qAqs@@F%@?WU_EH#xQ1!x6ifxHy%w@#e=N9nc((c`!}n)vgd_az%+I zWHnWEdXQfI6MDNLK{BVITVy)BLl^<8pX176mW(G|&x%mJc0Fr2)K8n&-fV=|qS8SSr)gc9*afgAeY%7R$u9ZudNXp9 z`z)qOk}g+pR#%#Q%4}QE1BUM3%iAKVvhDWLSq<_7ZLdZ!s(k6ypzyU?Nsd1qjMpNi{tk(LBw`{bKQlrARd9^Mm%x(yZ(aEBd85 zC@a?eC6TwaRcQJQKo_jT!ZApLx_JoSuW-=0E?8uqTQt4I9zzy;0b1}lwg1xx^?%E4 z6Sc5*HgTjAwKi}z5jHWhGd7`znJ9em;%KKPVHIT?T>>fQPFLWJpTLI?>Rk?BqGJ-+V8ReGmxR$Ikb>J zKR)U|!(9@^G#MV;Vnc1hNKo zVfye`#GtN>;xOVg(mP-t?;USoe1u*61}}Kmb)Mly{05&te^M*S)bRgIK+xv=r#s~0|f`I7ch*5XTfi#_rYg6Ju{6{(%%Dt>;!@*3mQN^M3zSn^6o!6A4dWIQ{zcP z{2%INrvE?n{$CTfm>3!V=b%Z=>UYr8vCV+aCb*LG`z7wv2kWDR=Vt3(x^Eb%j8sI z)-yM)apLV?)8eFIrOiY|#YNR>$G7v)b@R}L7Zx6l&yEf2_YyPB<=XxHn3B}ZwL&`O zd*2AS@-E}v;cD>eK=_H5bsLKoOkw*PhOlHdj_`xlygLfquki)sO=60h)4lCu{M>=8 zhief_O304gP=JYu=-WX`u(wWAyiXZH-kV2F%WGz`wE=^*Qv277mB2t~t7M-$f}E_9 zn3kln3cr@U61tb-uU9v-SdyA53ffO&U<2bF)GW7>hDJMSea6RGQ-9{rd)P32jLW+ngfcLXyJp<}8^Z)qNMj zNb0|F_7DYW;iQJ)CPRrsoQ6#GA?_jK13Pv^El6D9#)Khj5|@OoNM5&m&xjx4U&5Dw zfkMLYy$3~f;ac=#)zRX5V_Iud2e-7en%$>}8p!RGj*fRDB$=t7c1t~BuW;*cv3E9b zcCc8lds5aZy+lOW{TtsywfXHSl05&w4FPNA3K zssl>m-1?XxP#bapV2XhgCA4%OIv!65@niYLh+t&dkD<5u?VzS%BXNFassS*D8M$v# zdw#6l;qC}n!AoHP#``tLK#uo4gGl0_sGe+be>08Z{xo!Jllm8HR5;)uZny85t<0YeFg6aX~9FJ zgu)LFf|*J{02`P02i&zaGgB4}w2oY}MvAS3&;4S3!?$R06BNZF5)jvJ~r^p75_;TP*ZvOt9{QM7t!?+ zKe~Lt{K8ND_wZ|2uPHgS5VSmhiWqH%W&zwZbJz=;1fu#%v+R%KFEC3QMg@}Wl{BEd zxE~nPhvlO%9hZP;fpOD6X%;Oq8JGL_zT)D+Y_6IKiY!L8Q<&a_t^vig)~{#Tqik2k z&5#9moXb=?-9>iuymK!2W8~r=-IS(nDH(=Rp<>cSJN4^Db0Uem9Ha*0Lz|B~-{GTh zMgQC&{c?}K^=_V=(>|(kNEPBuk9$3A#A18?N)J4EhONY+Hl4JFS_wpLt(Y&Xl{I+? zP9p<4matmoA}33usqt(r?e6T!_uKhcK5#kOtRcCuD%W5sszvd?*?oW1Ya7v;Xc_t!th9Bs^Ad+%ek)@rLQS>U~G_9Rw( z2-WMwd1~}TAr_28A6jB{A|#It(@z&6vOK+!%n? zxz}D_bmlrW>dW|>n^Rt2P+o|;GmJ{s(}-cHgeA4Zk`qTbeoG}_(!?U{CoXi6`Me?P z=`ZbHtSBUU7ZPFePICpV@z0?2UN&AAzNKYH)WTt;2H^|{xi-AAL*qNPAW7%}~n#Oob`?`nE zmA}|)l^r$i?j#A=je8GX))lZYV&;xtezvJ>J>AYQ@Gm81Bd@RFq2bUK|Ah zHn?(pys@<=lUx~PEr0<8I6@-6iIE*OLtAVdrAwMca_i{)m<&fPf60R=S6jT-z)EG( zomcq43Y{ae*rtWVOgrAMeK+bMXk8z&yHTB5K0!nYjC_~?U5iv!vX%EjPz?f!6g+=y z=dGTTWnXB)EvK#+pFXYakn@G-@LP2Tbs88K)M z86Its%J1%lW8YFc+kYK5DxxnG9SFysPPLI9o@tkR6Pg*yqDR^A;JPy~b|OW%U9K}b zw@uT`+d1h@7Pqu$wDGi!STc=&nDyFkKU z!1KX>TotBmvS0(-|ZxQ z8jcXMp1LI~%FRpzKzGh8p;({Tdk~jiWb=hFpx(qWJE?^#{&^6+}1jWKx?W%l|%_C!z_SMu?EbTEfe+ZR1YNaAMKgVMyKk(UHwoUrF|+lwewd_orslL=i-7fCkIp6ge87QZ+BB!3}7h@Wjm*kF{nx9UJn|w579M`igRG$tM|O;RNTa( zgaL{3`IgyrXF1<0vbv!<=g$@`bw%v78Qu$(TiS9GydWYo!#ZqOOk_lsm;~pp@g^0^ zNKssHlTw`Y_kWqN1Xa18vej#-p`jY*uY77;q-2 zL=f<}B%PE{e`OV@A^SU*eFAm{xoWOx$v?LQUN<+f3KD-d#Bsx;Vx0y@@M$uC zn7}0h_1*3J#>75wIg3-Y6%6ih!cHN@)TavA`tPE|t3@F4p&YR7mirVGX_8XAY;9;w2WIIOO*?N8{OL4$iPI*+eC&=gfIc|fx_3}igL_awx1Toh5(n7sV#p~a&>=M0YRV*+^X7fW_h7gjR$@P~2KQPNg7HA_|!B$nfm=_|r7eLS|ii?ZU z6ziKe)_Uyn(I`E3mnIGgx#O7~Of0XFaMot)%33S7459sJK1OxFb_Q+dZT zyRH%`dY`^;p8j>u6qP!qf54Tz(3(n^;xrgFI&%gQK)atzY)<`3y( za*1e^|K6FNMhb`6w-QUVs1`0wE{)xxH3%LA|17e+g@yA9k#EsXESxKUDN@Bvmp+J- z7M4R#81|WC5~XB{eh$}^t|DAQwi@y>2Ca`k0{=luMB4J>cpT}sJU{F!<4Gi;{&lot z!!^GJ^nQu4#N^q%x$}Jo&`01j+=6Bnn*CJX9Bvb?B1~So9wmHt6uFuPPnM!cCr#xf znRr@q18|~F35GZ*J}gx;=K(T8cikcOGs&#oqp!C`vWo4qr&iqAGIPX{G6BpqR zypa%~w@6bdQg2d0?>42QqCppfJrj`z+DXH=N3%GxNcESpHw2TK`&xDCWouo+`Eudc ztiic$0XW|ROLYmlIxqQKCWj24V%nz`#EWZ*dtT8VoxS}HQBvbPFxodjWs5nw#UNnp z(fVV}?+ooE)TO51q*SN#ZAIvM@O1M6W>&vWi0PthM75&@fgS`qY;un&X!Hv|YDD^~ zFa5KSuIc$tGHQlC!Ibjk)FrI)C3wibY(KSiTZ<1%F7cm*fZHz1`q*=yaN0o-dhBGz zYPPvspG_3p2(c@L;r;7ifh`du%JYF-yG!X*EiWM2!xn0@Dcdvt6%eh9*PLt&TaA8& z^=?@@X%E*nQ2Ktgc07sSMklCsx^)B*NI#qqe~h<&m%&oo!v__D64@`P+otTHQ~v=g zM@DlSnK%A=uOpzp&MHGwW9wGFDNE!Tc182LQ}fE!-YhZc?AoG-R$wrkOnD`aa|FA< z{E;hU6Bp+B@{qb*%WA7n)9?Lt!+UJmkSnllhy&+g{u9BLHhM|rn$Oi*{)7h=K9dl* zg@JByt_A6)Re=ikjsb7uy_dY4oO3dEUfbs-$E|C(>rfDf|f7^T$HD z#hTa93~c`;ttdoG)GhzF64V*gW}LO8QJ2l}=(P+oct%n8)))U2LXeF+T<*>v)Yw1m z!Q54LER9$ZAwv*YeBpx|YW9;!}QX-N67MjBCBce1E zbrJ-R*UC?q5V9P(+-jO)apfSKgA0VCE-SN?%_>mZN6O6*jaD-GCFOIqF+77L=Go|rF5RZ(%2MqO<& z)A8v@sfeVbrD~BwTd_-ctV3JU0ryx^16EU#a~x-c9;6qOP>_ijDw-^O=~jujA_-Lr zwpet@6cwyB+ygyZPKKad(N-zBlKO(FH8xvzLy0XVk2N`4REFGi{y7z-HCA($wor8u ze-UoES`y2laCJU^!IE;#KYBVGireL}D`!%8sN)`*HA7Vf9z%d*`K=7j{&BLc9iu=b25GRQOd@jI+eG|cVI?FLH_C$S&* zs@DfM!#Lpmp8+@FKS&BB?xW$bUchNg1n}9MRCiC{3khJHS@J<$2l5bD&nwZRPg3v3 zp1Lsg(A4Wr300`!2qeKE5QWJTaxYtb2hawT%tQ$H$q=Pemd?w|s;KOFdzx+H;qkk$ zRCr4S;`}16=J3bsA`^cP2WY?1FBSguS+gg~$2hn`=?S+UpskjI}uUCJ+yG*TId0X$*J;pVe zi}zOg_!Wa&{gb^c-Jhi-Hde7Dai`Ofsx^9n09?Zi26D|CBpL&XP5g5#N<_6slL*f2 z9jQLv*L2K}l4C8l15)R5!mtI>jrC&(da*|oa>z9QjQd;F(4r#StoLqTu=I zS1{kY_(Z>$6pXr#Iym*FIZ>BMRE}%oPi|CLVYFoZpZOhNc`(L>Fm#X zLLQY;$)*lw{p|?_?;ALZ(m-%=zXnxAe98CPe+o26LR`%R&FK$3%>AsgMshh&{<^sz z9GmY@axcZiljyDIb2D%q)R_9<%GFkQ?b`|s>Ko{L?JMBZnxMH%K=(_QG!T;x?O{kVkJ6Y*^QE^RW&9@I#3>G zaX!-Ht1yk?9vob)j=afPsVwC3p;X2eo~@zYhW?ibLzRncb8GkkItEBcWg+wcKw#}7qAXA7xV8_ zX|awe-~9H`(_}gXQ44hwo!ixz?s-|;Al&(l(Gxz_JSgWxvx#4<{NU?G<}ap(Df@1a zN*LVX{MmTJ7=8z&epd9Oc6CLDo~W=Ea!tp6SF=dIM*VdZHt48@{`ob4Kcq1bN$wgaN6wm~%5y&PnaZ}w=Xevvba`}JvZT3k(ET7sN~D`jV4 z$e`@Sqx`D&uGXgFyCZy9bCmtkcOYWVwLQBV1!k9hb5C&@9zrp|a30VdvdkGRkDQ+d z`FqC`NvOd~&4zZ6LUQPtz#nx{v+tc_m$=C#~5LmN6C%8Zw7dr3dYV(ka_xzkTa z448*rk(g>Sr99P=5o4=ui=z>k$J{#cG$j)8`ByAk=?G?;$RbubYA&$1Jo@NUo6=(c zoWvN6iqm&hMO0E~lUMw7403a-yPu>f*~P}evsQSxp4JD)5Kz#oKt^ELuT-|lx4tn= z>H27T)dreoJB?o^^?oF;F=AUD)D6Rr9^fqlEYNSf^QgR_TzScs$PFUvoIW`Ilk$B> z+l3%Sg74iFv-3QSju7=-Z! zo>+n%$|?2Y*d4Gf0q2r`rOfnSiC%h|a;8dlMh*(c!{>7hXm@^nPsPoERr3H`0t%|q zL;6sKV{kn9H&yV%)fZ~KvH+j< zzFyRIY&OQMK9&*#+fOA6%W)5M9rH{u>chDPYENY!W*!mE*UtC@1)O1Jj&Eb zV{3Rb+uR>`;UfFmQ!MMa7R%~Sz3ejOD_Zn8$1u7T4X5WxT5$;nWy(GZSC(KLbOMc( z5J5O3fy|un<@@oe8}oePLMYX|hPj76{szxrV?RgTf519xafpo=FJ>GcL|LWNH-Z%c`mi zuCF2>2ENypW{`}Vxz95@-Bw+4Jst?O#^`<+ekpHo9o!2Njjimj1R&zxCHGhFr)6$U zHlo%A3|X}M>UbvA=kE6I+w)#Ypr$eCXss2J*m%s*hSfp=c%l6@wY~nd9Wv|o2;R$xd4FhR_Hjgj zsOr$NYNd=@Y6?MiETo)&?DIzawhj@B>DEtKSeV~}Go?S3=@lZikI>H{eoek7ni6Mx zxmh4?LzE&{_=yE;DfqADA+M$+jXzq}>;%&uidu+Y!MeQkG;vHK6mTwW2#3gt^xR)3Etqsa z$Qw+Zhgh*mUs^gl6DPx%#hkoKn0djAWKCZ#|7P6YW`KTn&`n}=$n9L``Db=32#IVi zYTR1XQZmOBuE<1f$om$GQCFXwACK+cJ(`ee9gN{a{{>=Z_w_!#rNjTLybfS%cE=?G z)oa<+Aex+t6Jk!(OjFG4V`;fqJwn7uM^n%p-(Wd-8OOmrmw7Xl+b>z0W`xxxgx_0e7(ivS%qMOws7vys zH@VmmV^hFf)>0~6VnekK@B~63@l>wFyUDNrZK%b{=!RLZavtkDCDK#TUENaA^i%e6 ziq8~;ML@f2G2_a=l4(g2Ra8%O3uAadJ868tq%77pp~Ybup7f?$gA9U6`abc%Ku7qE z=Vx<;ei;Rz_i=g>7UT8sxO6s~X7gZRw@5%wA_*+Xlv#+4l>bkFI4_H;%CGYf{ucHQ zZcZBbLu`$q3^_E}6&q8Bp8N7uduX zdY8uV+vLQD|G_i&_n|6X#|H2il&jx~05pU*zhbehxc=n~GXCHMmzvwL5Xfug>O%3Z z^V?CP=R;pBeg{Jk#>uifuMlu;>jGcfHPp>k*k^YH5r6_ZuB#@}X&HXSF1bPI5(=wg z8)%}QXTVV6nl}T_8GW>{R?rA_e|=Yq6zjsXbxW{dPCfaoFc_D+J9q6QWG&)ejX=Pf}n_J5ZoHk6rN2F}&by#`U zia4_-nQ>eF+41T8nJc=5o+tXKHCm`6x}+LcEjzuDjgbGViMw65kgD7Us(O278lv3I zi`Gi%`{U>(QTnTVB$`-b=v-RK1tandxsYcd@Y9MD&A9Nla^NHQ;UzJ~kfOhYa~PS3 zppKx**k{valFB&QtuIqDG?^08fGy&-@hI0oN=q353k{J>dhyr{*vpllwQX-Ma~D&^ z+|fZmMOBxb4TCDs-R)5NI`93Ztu)oO1KhM5Ey7GQLx@7UxZP7LF0#<2tD2&^HU7D; z*%K6Tu$_skWsUg#ofvD2^e=R5QU5H2SP^+8*w`GjIZ>_@72C_Tmn5=_24OV=MpV#DLcAmWH5Ej=C zD_ST^>8@Et->F)+j=#6;gv#S^JC1_hjmr~)VuqyK+EqN7tbKpVV3Dn3$ zl-$5ASQ~RfV)BeatYY!;@vOiY=_u~sWQYo|vHCJQ7VbvJVR5LM13eA(I{;nZBRy1dCO5A4r1lzQ)v+aRdv0W(^RmzbU zuX#>7xL;Vjn-+N1%E{IT@cOrmA&5wcPv30}ogGz69UHDXL;s;1D;)X=beCoNMuDLpH#bSG0Y zAwDBh6Xf8466~15q9jF?+H%D-DG62c^ei|e7qa5?K6%HSwn+&ANf!~6L=;m{{{=Tecs>iUMFYj~JOomRg~IHuNh7xCEYkGapR-q<6L6ZXGi zQQ1cC!jL}ppIBT!m>m6gELhq92@6$EM>7TmV`~*xI|g~eZ+T}1aVuvRS3)LECXVmn z|Evgsg^PvjpBecVx^}Usqdz_`4Vbn;B3CYI{%TA%9Dwd;nVhpg24mjsg4p;VJDyyI zkM+)~@bPsvHmV$(|0)!XyuP@XcVC`V`Bt{$X*uBjqZO$Kl?{u@yoDXbq^1+C3Bv?+m=64%Eobg&WgXP{yP8{}L)(VnC z53Xj@q(WXfsRMH#OP?4ubismpQsjhs5mp9_6Yh}(ssp)W2vKO)g(J~ST!gztpp-ar z;5ec~GmAEjyP0BMDGw1!ROQD6=fjqhAWJq}l!eFFrxn)q^>O6~=xrH>F=2uk?ef6r zmKg(?js?dU*QE^*D(waV_Yp;9V@V>#8Hp%zftZ8J=^eyWW9)#!^%1N7O{05`8wMKE zWya$%l&mB5HiG(l4jd5_h`SQCgK6p*DpU_WN2ba8qirxL3)wV)jtjOHtQkI{jL@hq zPH z&lg(UMR3UMh9T~H1S-z4ff(Y~-f*%myCYAOUf=2@Y=2vh5iDeS7mH!MDd7?dciJFo z3nbHzp=;n4!hDor^lP^^MA+jQiW?8Yy~Z8T1>qkg7H|c1*LrodE!a3K2-Fasc< z=ygULeQ_a18-zytJEZ+8^%M|Dk-+Lu_)!6F;po&s>fv(>{iDLjqWKy~Oqe6lBjFgL zaA43To#7rQ!3IrnF-9Ab*A_R!Pz?RqKY{PfF*&#q;|N{u_o(Wuf-5iy#X&th(}=`z zz}?{b(gWON9ic~Dr$}uC87XcUmiz5BK{pecjcKsLSq9o7be+2C>wg47`J)?zez$R? z+xex3%nv7r{40R14Mp?*77rJAy%0_m?!EY+4}?F7Ig21C3fQ(^kq~EP0Muft?wJ{) zE+j8^_@>(o&JYWtLhHb6g_sAKg99_XJRiu1U@pK5p>H%m9i0hRb%qHFR!W<;lNo~W zDA)>N0AzduGZ4BSip0q^O4q0=OhhVFSg^lR@)i%6RH7jW4R|*=>b@ekb4NQvQ#>q#3#)vMy-RUcNa|V6 z!q3wNRAn9H#!S;3KfpZUk$WyLOK ziaaxW_M>^!70FIKwdi!Oq=V9fdtJIeot+gVb{+~Xx~k3{+greF7A9mxmWWodPpS5& z%0NF(v~OC22I2LFbpIb@aIe$^k~3a!Hj*JKZ}`CP$C*}vT977M$t2wIgz}lD^36(V ze1R9e^|5@sVQgD8%oZBL%3feiEam135wDn_l)Im&MAc;h z*DnyvB`wy-u&6Z)tym531`%SOM!f|AFQ|o~G>UJULMlzBra~&3lNEx#w9TM87@5Nr ziL*r%svyePOPH%#WL~mf)v-Ww5~o00wwj*A4w;kfZ{-rlrKr+X8kaU7(;kWblaYF? z7X`Nhjt2#c){jtaZHLY1`F6Xw$9TZ+6>L*hz5QI3ouW3WSY{N${0Z#NgL4#Q( zxIs8The~mOx2hHu&19X1kRWinarsuZLFG|DKQ5E12pnbs5S;{wUI5U^O+ZpzV3%L4 z5rMY~2CUWmprJ1UXf|`kuFxQr;Vl7&EFst!1Sq17*?pMfCU5^84q|~zLnxR&DIlw6 zrNfagM9QRMZLzURA}VXKDQdDQ`W|bu|Hr*AehS-kw$utvLrHgvTX&|ENNw979hk#d z1%NcK64wR?t(_IK8WEsEEzJCl3v~8S)+1@w<0+b3sVR0Us3>(+mOuQq>Zx7+pH}09_45Sz2IGF$#IMyH zS`{m=u_>=Ni@^8=fUr%fC=U=@r4uR8Bp(H*Yg3t$wKY1F>|l$yAO^0b9bgxvV+5OT z>TX)s%@FSWlGpAS{|9o3NKK}OU|=}iP%)a32K3s0ny2T z=tTgXf;B$Pw_xHwX7eAb3U@VOKwmD#YC=Ci@FE0(ic&xCQ5X`{{xZY^Kd`5l)_@|F zW|b^otJ3`8#QJ-=#$Irkd>EGdajU6}6F$KSOMgC&$p5&7`QCf^7mi17v4+$m&3Y!q zdM4F+cjn4JHLaF4ZI;a`+x`R4??-3`OylHy@0hu@?>`)Uu_pSBoMNEtSzVWt$|DSz zb{Lz;_wLFAXrBA%^rlN3wtC&{z=4(oS%!63USx3mX~=J~scNPU-WOF{ zXH#Eelh05(Z&Iep4Rwl~MjZeF{~P91<-<0*rs48^y_&LZnePvPB+>VAVC}5x#kbTW zb_dWdZ-5Z8FJZg_mp`jQpyd4X_$SC0%2}>7pH{V z3RRgUWaR|2F!<1V)m^&ts44@CoNbosBBSvihgX519as`zS_`e0)l9&^71xOdyZ{_# zWsQKUJ4b~FE3@?cSmaN=RY~4h--dKRITPzB(t`e&61-fCjBum6oKB^=oqqQ;?CZ4G z9Dc=HoHRr`n{|qdT7=EhS(t;?*;C zo`LSxUwpe90LE4Ac6S&g)|ooF;l(k#N>4X`dzZ({=kU?((xiV*ulLJjCgSF7t7*Iu zj(?ADCxx@$&EwYU!_iXr?4)WQX=Zi1$yDz3_C=0?k_oKv{Q2eT!|GX-Mw&l*q{GLS zzpWLSt54in!?JJWxY@#Zc7*rqJY8Ynk2j*{+wzce=`bg%i9+e+YP50s>9JG7&zuh% z0@4RRt@gtCR|%4}66XX8E~wD6Z86uJdD8fxiOs%1SLQi-j|4PEN7}QwmpFmJ?^(ty#Es9<)jwZ9%Uc-=k`F^1TCPzLjNC{_e6ZT=kbu_ewPx=d> zvc9*E#Sa+VP4(L>q5S1Rfs6~WtI-deWMRKHd#`PztCz2B|5wDZSYvZ`@pY6F&WzO2 zeOFeDh{0Y>{-<`X+t6m0dUXK7&`R1PY3wIQ=#MIPOPBE0a?P)nhu5mdx5+XY9^NNK zn0!r>$T%y(QeFYoYpOBRMm>|3x5+aXE?S>(iCafqE^43fCr0|w?D_JOvsMOr{hVIk z<{tOYNd_F;I>#6v^N2}x8U2=VspIrJntT!r=$LCO!ipKwH)q0Hj_N3T+rF)4wTxaO zqggq83@4-am}pE3_ga4gkQRmo_N5>YxdQ+xeU!K&ZtNs42z5->Erivt)6eD4i&B}9 zRe2EhSmbHpj(Pe!Vo%{eqt%O4FY~~P=5L@9@bddIKo!I4gV@ny`r*YpI70cFeV&^28*Y7t7)z{hc7RMV@dY;h9i=EfYgLw{tEy&KW zCESAH3(Fgcd^Cu<0VoO!uu^Bmoc{5PeOB~$^R$+{XK2bP6U709Bnpbr?e}}2CIY?; zkzuw%kQGQ(#*G4D#}$BTT~0gi5RUW8DCxOL1BE*Yr4vXb3y)&frqS)g$G-RWCwP;B z!ZG8`bXp$?|A>llMnCDwmde5D(a9Y@r4>OEU;jEN^%Xd3CJv}|l0SYHKQ}jeFYkvv zLg{rm$zOT>c1A2#cDe=H6cr90)+&-Q>1>0#U{@lyz?t2O0J-E zPe=W&^*Dl!Ci_;3P*A}4cOy;aBgp&x)wCPS886DAVzKke#y9q5Z}ykZFM-?LnL`-a zo_8SzTvM`&T!f?f-S+Svdb!Ew4(=7)zSUHLmEdEDB!Ni7=L(?^wiTL&pW zmN>Ee_c*Y~bdI?9Pq<1FB(D{ogv!ekJX(jh~h*`)#j2H$D*fhhPv!P{5#5O#s9y*LXSbk%F7Ifjh&rALx+iwg^*eAe}VTmU;kf9MA()+9pyD}M{c%V z=#8aBk-TZ^*_K9f#FeNYt5Ync7PN~Omm68nY06Y^cB(H4=*4s!}(G5!TPDR@AM=J&Pt+oc|bm?xfDQ zMKF!@=3iVfiCbk*t!QkI6XR2}uA?9te^Rw>`1Ce7-4df)@?W-6Q?qWgAk54xTQHgx z0t8nE*B=wT)l@E+!4g99lr5OR5^>3>{%!o+;KZu_{j(d2t5KXRs~e0eE$??+Hwcw= z#qaQLnD&D$Z<87B03RKLVrcL+Bp!Qa=Vyt4?1HU+F z7irHiktcZ_MQXvE&w}3x$Y7rQGR0`c#0QIx$xBJnpBg@ex9ntKluzB#q{YlgS>?Y& zkzs=I)vaX8A%ff6*J6}GEmakY`HIPrcGb-wrR@kC6pKlU5$0Mtr75KK3>s7mC?9^7 znNVLT{%sT!Y^tiv9`grnXhg3T%v1>6*_9F5b!UI~f`Hm;2N2=-+T@ zT`Grs(y)f1-fNpwbOA5DmG^l~AjlitT?$s9MWki-MNQx-ogBy_R)|F%dSw{JpmnFk z(hkxThO>Uj{7ICAoe9zg(yVc3mrVr4ERNKo#RA2Z40oy!iXFf&m)}2fg^X0Mge$lQ zs%h51l0Aif*AzE{B7WJdB} z7bZ(##`HJ^gvKWk^;JGl6DWtihDqBb$5IaZIK8b?PC%tG*M6&t8ykUac8@BF4+OuL zBP(Emt4vp?GNHa%L>c{kul{5r!!ODAUNfOGF(lql!Ir=}i^|m4r`k6pPE;dTB=2jQ zR7;mkheA07EJ!6uG3r5-`v|9lp!^XwV>Y9f{jyC~p!#DN+KI&z!i+~=qiIHM1~D}h zLY=E*{(38DhHb_^W$KRchswpr>3H%u>4ovnrcS1i77$Bo`-JR-aGKZ)bt7ezq4G$@ zR0(Nc6>kl5SOQdHi;x*T88rFk$MhZLI3w2OuN(!bfN{H$hMx_nM?Ogt7)fU5WNCZH ze_^R;3~Nd&X$z`?+xOLPjHRikK%aDo0~%nC;=N-dlGqqyMbuIhmj>QlWXQfHtL_Q} z$z}?{&V(o5>s?orR`|%Rjyf@QhUiU~)Z?s7+d_0^Z;oFYA=Xi> z1f3f_QhI068Q-lm+VXn`Z1?AQJ!0&bJz@{{b>e8<+I=`#wNUHCz?%lGQrmLsWLFP| z*28OhudNv%Jf{BSTfJzv)yUSpmGItLO`N=3dAzSLjo`yO-?D#V?G#x5Sh~yw zJT;zeUK#=z8oZ-6u^t-$dMjvl8fAJ;0Ps~V6ODlES%BZ#YI9EWU4PH&;yE_}u`^ + + + +GCL SI Manual: Available Symbols + + + + + + + + + + + + + + + + + + + + +
+

+Previous: , Up: C Interface   [Contents][Index]

+
+
+ +

16.1 Available Symbols

+ +

When GCL is built, those symbols in the system libraries which +are referenced by functions linked in in the list of objects +given in unixport/makefile, become available for reference +by GCL code. +

+

On some systems it is possible with faslink to load .o files +which reference other libraries, but in general this practice is not +portable. +

+ + + + + + + + + + + + + diff --git a/info/gcl-si/Bignums.html b/info/gcl-si/Bignums.html new file mode 100644 index 0000000..785fe35 --- /dev/null +++ b/info/gcl-si/Bignums.html @@ -0,0 +1,131 @@ + + + + +GCL SI Manual: Bignums + + + + + + + + + + + + + + + + + + + + +
+

+Previous: , Up: GCL Specific   [Contents][Index]

+
+
+ +

15.1 Bignums

+ +

A directory mp was added to hold the new multi precision arithmetic +code. The layout and a fair amount of code in the mp directory is an +enhanced version of gpari version 34. The gpari c code was rewritten +to be more efficient, and gcc assembler macros were added to allow +inlining of operations not possible to do in C. On a 68K machine, +this allows the C version to be as efficient as the very carefully +written assembler in the gpari distribution. For the main machines, +an assembler file (produced by gcc) based on this new method, is +included. This is for sites which do not have gcc, or do not +wish to compile the whole system with gcc. +

+

Bignum arithmetic is much faster now. Many changes were made to +cmpnew also, to add ’integer’ as a new type. It differs from +variables of other types, in that storage is associated to each such +variable, and assignments mean copying the storage. This allows a +function which does a good deal of bignum arithmetic, to do very +little consing in the heap. An example is the computation of PI-INV +in scratchpad, which calculates the inverse of pi to a prescribed +number of bits accuracy. That function is now about 20 times faster, +and no longer causes garbage collection. In versions of GCL where +HAVE_ALLOCA is defined, the temporary storage growth is on the C +stack, although this often not so critical (for example it makes +virtually no difference in the PI-INV example, since in spite of the +many operations, only one storage allocation takes place. +

+

Below is the actual code for PI-INV +

+

On a sun3/280 (cli.com) +

+

Here is the comparison of lucid and gcl before and after +on that pi-inv. Times are in seconds with multiples of the +gcl/akcl time in parentheses. +

+

On a sun3/280 (cli.com) +

+
+
+pi-inv   akcl-566  franz        lucid         old kcl/akcl
+----------------------------------------
+10000      3.3     9.2(2.8 X)  15.3 (4.6X)    92.7   (29.5 X)
+20000      12.7    31.0(2.4 X) 62.2 (4.9X)    580.0  (45.5 X)
+
+
+(defun pi-inv (bits &aux (m 0))
+  (declare (integer bits m))
+  (let* ((n (+ bits (integer-length bits) 11))
+         (tt (truncate (ash 1 n) 882))
+         (d (* 4 882 882))
+         (s 0))
+    (declare (integer s d tt n))
+    (do ((i 2 (+ i 2))
+         (j 1123 (+ j 21460)))
+        ((zerop tt) (cons s (- (+ n 2))))
+      (declare (integer i j))
+        (setq s (+ s (* j tt))
+              m (- (* (- i 1) (- (* 2 i) 1) (- (* 2 i) 3)))
+              tt (truncate (* m tt) (* d (the integer (expt i 3))))))))
+
+
+ + +
+
+

+Previous: , Up: GCL Specific   [Contents][Index]

+
+ + + + + diff --git a/info/gcl-si/C-Interface.html b/info/gcl-si/C-Interface.html new file mode 100644 index 0000000..4847110 --- /dev/null +++ b/info/gcl-si/C-Interface.html @@ -0,0 +1,70 @@ + + + + +GCL SI Manual: C Interface + + + + + + + + + + + + + + + + + + + + +
+

+Next: , Previous: , Up: Top   [Contents][Index]

+
+
+ +

16 C Interface

+ + + +
• Available Symbols:   +
+ + + + + + diff --git a/info/gcl-si/Characters.html b/info/gcl-si/Characters.html new file mode 100644 index 0000000..5f6f7e3 --- /dev/null +++ b/info/gcl-si/Characters.html @@ -0,0 +1,488 @@ + + + + +GCL SI Manual: Characters + + + + + + + + + + + + + + + + + + + + +
+

+Next: , Previous: , Up: Top   [Contents][Index]

+
+
+ +

3 Characters

+ +
+
Function: NAME-CHAR (name)
+

Package:LISP +

+

Given an argument acceptable to string, +Returns a character object whose name is NAME if one exists. Returns NIL +otherwise. NAME must be an object that can be coerced to a string. +

+ +
+ +
+
Function: CHAR-NAME (char)
+

Package:LISP +

+

Returns the name for CHAR as a string; NIL if CHAR has no name. +Only #\Backspace, #\Tab, #\Newline (or #\Linefeed), #\Page, #\Return, +and #\Rubout have names. +

+ +
+ +
+
Function: BOTH-CASE-P (char)
+

Package:LISP +

+

Returns T if CHAR is an alphabetic character; NIL otherwise. Equivalent to +ALPHA-CHAR-P. +

+ +
+ +
+
Function: SCHAR (simple-string index)
+

Package:LISP +

+

Returns the character object representing the INDEX-th character in STRING. +This is faster than CHAR. +

+ +
+ +
+
Constant: CHAR-SUPER-BIT
+

Package:LISP +The bit that indicates a super character. +

+ +
+ +
+
Constant: CHAR-FONT-LIMIT
+

Package:LISP +The upper exclusive bound on values produced by CHAR-FONT. +

+ +
+ +
+
Function: CHAR-DOWNCASE (char)
+

Package:LISP +

+

Returns the lower-case equivalent of CHAR, if any. +If not, simply returns CHAR. +

+ +
+ +
+
Function: STRING-CHAR-P (char)
+

Package:LISP +

+

Returns T if CHAR can be stored in a string. In GCL, this function always +returns T since any character in GCL can be stored in a string. +

+ +
+ +
+
Function: CHAR-NOT-LESSP (char &rest more-chars)
+

Package:LISP +

+

Returns T if the codes of CHARs are in strictly non-increasing order; NIL +otherwise. For a lower-case character, the code of its upper-case equivalent +is used. +

+ +
+ +
+
Function: DISASSEMBLE (thing)
+

Package:LISP +

+

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 a symbol that names a not-yet-compiled function, the function +definition is disassembled. +If THING is a lambda expression, it is disassembled as a function definition. +Otherwise, THING itself is disassembled as a top-level form. +

+ +
+ + +
+
Function: LOWER-CASE-P (char)
+

Package:LISP +

+

Returns T if CHAR is a lower-case character; NIL otherwise. +

+ +
+ +
+
Function: CHAR<= (char &rest more-chars)
+

Package:LISP +

+

Returns T if the codes of CHARs are in strictly non-decreasing order; NIL +otherwise. +

+ +
+ +
+
Constant: CHAR-HYPER-BIT
+

Package:LISP +The bit that indicates a hyper character. +

+ +
+ +
+
Function: CODE-CHAR (code &optional (bits 0) (font 0))
+

Package:LISP +

+

Returns a character object with the specified code, if any. +If not, returns NIL. +

+ +
+ +
+
Function: CHAR-CODE (char)
+

Package:LISP +

+

Returns the code attribute of CHAR. +

+ +
+ +
+
Constant: CHAR-CONTROL-BIT
+

Package:LISP +The bit that indicates a control character. +

+ +
+ +
+
Function: CHAR-LESSP (char &rest more-chars)
+

Package:LISP +

+

Returns T if the codes of CHARs are in strictly increasing order; NIL +otherwise. For a lower-case character, the code of its upper-case equivalent +is used. +

+ +
+ +
+
Function: CHAR-FONT (char)
+

Package:LISP +

+

Returns the font attribute of CHAR. +

+ +
+ +
+
Function: CHAR< (char &rest more-chars)
+

Package:LISP +

+

Returns T if the codes of CHARs are in strictly increasing order; NIL otherwise. +

+ +
+ +
+
Function: CHAR>= (char &rest more-chars)
+

Package:LISP +

+

Returns T if the codes of CHARs are in strictly non-increasing order; NIL +otherwise. +

+ +
+ +
+
Constant: CHAR-META-BIT
+

Package:LISP +The bit that indicates a meta character. +

+ +
+ +
+
Function: GRAPHIC-CHAR-P (char)
+

Package:LISP +

+

Returns T if CHAR is a printing character, i.e., #\Space through #\~; +NIL otherwise. +

+ +
+ +
+
Function: CHAR-NOT-EQUAL (char &rest more-chars)
+

Package:LISP +

+

Returns T if no two of CHARs are the same character; NIL otherwise. +Upper case character and its lower case equivalent are regarded the same. +

+ +
+ +
+
Constant: CHAR-BITS-LIMIT
+

Package:LISP +The upper exclusive bound on values produced by CHAR-BITS. +

+ +
+ +
+
Function: CHARACTERP (x)
+

Package:LISP +

+

Returns T if X is a character; NIL otherwise. +

+ +
+ +
+
Function: CHAR= (char &rest more-chars)
+

Package:LISP +

+

Returns T if all CHARs are the same character; NIL otherwise. +

+ +
+ +
+
Function: ALPHA-CHAR-P (char)
+

Package:LISP +

+

Returns T if CHAR is an alphabetic character, A-Z or a-z; NIL otherwise. +

+ +
+ +
+
Function: UPPER-CASE-P (char)
+

Package:LISP +

+

Returns T if CHAR is an upper-case character; NIL otherwise. +

+ +
+ +
+
Function: CHAR-BIT (char name)
+

Package:LISP +

+

Returns T if the named bit is on in the character CHAR; NIL otherwise. +In GCL, this function always returns NIL. +

+ +
+ +
+
Function: MAKE-CHAR (char &optional (bits 0) (font 0))
+

Package:LISP +

+

Returns a character object with the same code attribute as CHAR and with +the specified BITS and FONT attributes. +

+ +
+ +
+
Function: CHARACTER (x)
+

Package:LISP +

+

Coerces X into a character object if possible. +

+ +
+ +
+
Function: CHAR-EQUAL (char &rest more-chars)
+

Package:LISP +

+

Returns T if all of its arguments are the same character; NIL otherwise. +Upper case character and its lower case equivalent are regarded the same. +

+ +
+ +
+
Function: CHAR-NOT-GREATERP (char &rest more-chars)
+

Package:LISP +

+

Returns T if the codes of CHARs are in strictly non-decreasing order; NIL +otherwise. For a lower-case character, the code of its upper-case equivalent +is used. +

+ +
+ +
+
Function: CHAR> (char &rest more-chars)
+

Package:LISP +

+

Returns T if the codes of CHARs are in strictly decreasing order; NIL +otherwise. +

+ +
+ +
+
Function: STANDARD-CHAR-P (char)
+

Package:LISP +

+

Returns T if CHAR is a standard character, i.e., one of the 95 ASCII printing +characters #\Space to #\~ and #Newline; NIL otherwise. +

+ +
+ +
+
Function: CHAR-UPCASE (char)
+

Package:LISP +

+

Returns the upper-case equivalent of CHAR, if any. +If not, simply returns CHAR. +

+ +
+ +
+
Function: DIGIT-CHAR-P (char &optional (radix 10))
+

Package:LISP +

+

If CHAR represents a digit in RADIX, then returns the weight as an integer. +Otherwise, returns nil. +

+ +
+ +
+
Function: CHAR/= (char &rest more-chars)
+

Package:LISP +

+

Returns T if no two of CHARs are the same character; NIL otherwise. +

+ +
+ +
+
Function: CHAR-GREATERP (char &rest more-chars)
+

Package:LISP +

+

Returns T if the codes of CHARs are in strictly decreasing order; NIL +otherwise. For a lower-case character, the code of its upper-case equivalent +is used. +

+ +
+ +
+
Function: ALPHANUMERICP (char)
+

Package:LISP +

+

Returns T if CHAR is either numeric or alphabetic; NIL otherwise. +

+ +
+ +
+
Function: CHAR-BITS (char)
+

Package:LISP +

+

Returns the bits attribute (which is always 0 in GCL) of CHAR. +

+ +
+ +
+
Function: DIGIT-CHAR (digit &optional (radix 10) (font 0))
+

Package:LISP +

+

Returns a character object that represents the DIGIT in the specified RADIX. +Returns NIL if no such character exists. +

+ +
+ +
+
Function: SET-CHAR-BIT (char name newvalue)
+

Package:LISP +

+

Returns a character just like CHAR except that the named bit is set or +cleared, according to whether NEWVALUE is non-NIL or NIL. This function +is useless in GCL. +

+ +
+ +
+
+

+Next: , Previous: , Up: Top   [Contents][Index]

+
+ + + + + diff --git a/info/gcl-si/Command-Line.html b/info/gcl-si/Command-Line.html new file mode 100644 index 0000000..406a54d --- /dev/null +++ b/info/gcl-si/Command-Line.html @@ -0,0 +1,212 @@ + + + + +GCL SI Manual: Command Line + + + + + + + + + + + + + + + + + + + + +
+

+Next: , Previous: , Up: Operating System   [Contents][Index]

+
+
+ +

9.1 Command Line

+ +

The variable si::*command-args* is set to the list of strings passed +in when gcl is invoked. +

+

Various flags are understood. +

+
-eval + +
+

Call read and then eval on the command argument following -eval +

+
-load + +
+

Load the file whose pathname is specified after -load. +

+
-f + +
+

Replace si::*command-args* by the the list starting after -f. +Open the file following -f for input, skip the first line, and then +read and eval the rest of the forms in the file. This can be used +as with the shells to write small shell programs: +

+
#!/usr/local/bin/gcl.exe -f
+(format t "hello world ~a~%" (nth 1 si::*command-args*))
+
+

The value si::*command-args* will have the appropriate value. +Thus if the above 2 line file is made executable and called foo +then +

+
tutorial% foo billy
+hello world billy
+
+

NOTE: On many systems (eg SunOs) the first line of an executable script file +such as: +

+
#!/usr/local/bin/gcl.exe -f
+
+

only reads the first 32 characters! So if your pathname where the executable +together with the ’-f’ amount to more than 32 characters the file will not +be recognized. Also the executable must be the actual large binary file, +[or a link to it], +and not just a /bin/sh script. In latter case the +/bin/sh interpreter would get invoked on the file. +

+

Alternately one could invoke the file foo without making it +executable: +

+
tutorial% gcl -f foo "from bill"
+hello world from bill
+
+ +

Finally perhaps the best way (why do we save the best for last.. +I guess because we only figure it out after all the others..) +The following file myhello has 4 lines: +

+
#!/bin/sh
+#| Lisp will skip the next 2 lines on reading
+exec gcl   -f "$0" $ |#
+(format t "hello world ~a~%" (nth 1 si::*command-args*))
+
+ +
+
marie% chmod a+x myhello
+marie% myhello bill
+hello world bill
+
+ +

The advantage of this method is that gcl can itself +be a shell script, which sets up environment and +so on. Also the normal path will be searched to find gcl +The disadvantage is that this would cause 2 invocations of sh +and one invocation of gcl. The plan using gcl.exe +bypasses the sh entirely. Inded invoking gcl.exe to +print hello world is faster on most systems than a similar +csh or bash script, but slightly slower than the old +sh. +

+ +
+
-batch + +
+

Do not enter the command print loop. Useful if the other command line +arguments do something. Do not print the License and acknowledgement +information. Note if your program does print any License information, +it must print the GCL header information also. +

+
-dir + +
+

Directory where the executable binary that is running is located. +Needed by save and friends. This gets set as si::*system-directory* +

+
-libdir + +
+
+
   -libdir /d/wfs/gcl-2.0/
+
+

would mean that the files like gcl-tk/tk.o would be found by +concatting the path to the libdir path, ie in +

+
/d/wfs/gcl-2.0/gcl-tk/tk.o
+
+
+
-compile + +
+

Invoke the compiler on the filename following -compile. +Other flags affect compilation. +

+
-o-file + +
+

If nil follows -o-file then do not produce an .o file. +

+
-c-file + +
+

If -c-file is specified, leave the intermediate .c file there. +

+
-h-file + +
+

If -h-file is specified, leave the intermediate .h file there. +

+
-data-file + +
+

If -data-file is specified, leave the intermediate .data file there. +

+
-system-p + +
+

If -system-p is specified then invoke compile-file with the +:system-p t keyword argument, meaning that the C init function +will bear a name based on the name of the file, so that it may be invoked +by name by C code. +

+
+ +
+
+

+Next: , Previous: , Up: Operating System   [Contents][Index]

+
+ + + + + diff --git a/info/gcl-si/Compilation.html b/info/gcl-si/Compilation.html new file mode 100644 index 0000000..51dfebb --- /dev/null +++ b/info/gcl-si/Compilation.html @@ -0,0 +1,400 @@ + + + + +GCL SI Manual: Compilation + + + + + + + + + + + + + + + + + + + + +
+

+Next: , Previous: , Up: Top   [Contents][Index]

+
+
+ +

7 Compilation

+ +
+
Function: COMPILE (name &optional (definition nil))
+

Package:LISP +

+

If DEFINITION is NIL, NAME must be the name of a not-yet-compiled +function. In this case, COMPILE compiles the function, installs the compiled +function as the global function definition of NAME, and returns NAME. +If DEFINITION is non-NIL, it must be a lambda expression and NAME must be +a symbol. COMPILE compiles the lambda expression, installs the compiled +function as the function definition of NAME, and returns NAME. +There is only one exception for this: If NAME is NIL, then the compiled +function is not installed but is simply returned as the value of COMPILE. + In any case, COMPILE creates temporary files whose filenames are +"gazonk***". By default, i.e. if :LEAVE-GAZONK is not supplied or is +NIL, these files are automatically deleted after compilation. +

+ +
+ +
+
Function: LINK (files image &optional post extra-libs (run-user-init t) &aux raw init)
+

Package:LISP +

+

On systems where dlopen is used for relocations, one cannot make custom +images containing loaded binary object files simply by loading the files +and executing save-system. This function is provided for such cases. +

+

After compiling source files into objects, LINK can be called with a +list of binary and source FILES which would otherwise normally be +loaded in sequence before saving the image to IMAGE. LINK will use +the system C linker to link the binary files thus supplied with GCL’s +objects, using EXTRA-LIBS as well if provided, and producing a +raw_IMAGE executable. This executable is then run to initialize first +GCL’s objects, followed by the supplied files, in order, if +RUN-USER-INIT is set. In such a case, source files are loaded at +their position in the sequence. Any optional code which should be run +after file initialization can be supplied in the POST variable. The +image is then saved using save-system to IMAGE. +

+

This method of creating lisp images may also have the advantage that +all new object files are kept out of the lisp core and placed instead +in the final image’s .text section. This should in principle reduce +the core size, speed up garbage collection, and forego any performance +penalty induced by data cache flushing on some machines. +

+ +

In both the RAW and SAVED image, any calls to LOAD binary object files +which have been specified in this list will bypass the normal load +procedure, and simply initialize the already linked in module. One +can rely on this feature by disabling RUN-USER-INIT, and instead +passing the normal build commands in POST. In the course of executing +this code, binary modules previously linked into the .text section of +the executable will be initialized at the same point at which they +would have normally been loaded into the lisp core, in the +executable’s .data section. In this way, the user can choose to take +advantage of the aforementioned possible benefits of this linking +method in a relatively transparent way. +

+

All binary objects specified in FILES must have been compiled with +:SYSTEM-P set to T. +

+
+ +
+
Special Form: EVAL-WHEN
+

Package:LISP +

+

Syntax: +

+
(eval-when ({situation}*) {form}*)
+
+ +

A situation must be either COMPILE, LOAD, or EVAL. The interpreter evaluates +only when EVAL is specified. If COMPILE is specified, FORMs are evaluated +at compile time. If LOAD is specified, the compiler arranges so that FORMs +be evaluated when the compiled code is loaded. +

+ +
+ +
+
Function: COMPILE-FILE (input-pathname &key output-file (load nil) (message-file nil) ;GCL specific keywords: system-p c-debug c-file h-file data-file)
+

Package:LISP +

+ +

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, +then ".lsp" is used as the default file type for the source file. :LOAD +specifies whether to load the generated fasl file after compilation. +:MESSAGE-FILE specifies the log file for the compiler messages. It defaults to +the value of the variable COMPILER:*DEFAULT-MESSAGE-FILE*. A non-NIL value of +COMPILER::*COMPILE-PRINT* forces the compiler to indicate the form currently +being compiled. More keyword parameters are accepted, depending on the +version. Most versions of GCL can receive :O-FILE, :C-FILE, :H-FILE, and +:DATA-FILE keyword parameters, with which you can control the intermediate +files generated by the GCL compiler. Also :C-DEBUG will pass the -g flag to +the C compiler. +

+ +

By top level forms in a file, we mean the value of *top-level-forms* after +doing (TF form) for each form read from a file. We define TF as follows: +

+

(defun TF (x) + (when (consp x) + (setq x (macroexpand x)) + (when (consp x) + (cond ((member (car x) ’(progn eval-when)) + (mapcar ’tf (cdr x))) + (t (push x *top-level-forms*)))))) +

+

Among the common lisp special forms only DEFUN and DEFMACRO will cause actual +native machine code to be generated. The rest will be specially treated in an +init section of the .data file. This is done so that things like putprop,setq, +and many other forms would use up space which could not be usefully freed, if +we were to compile to native machine code. If you have other ‘ordinary’ top +level forms which you need to have compiled fully to machine code you may +either set compiler::*COMPILE-ORDINARIES* to t, or put them inside a +

+

(PROGN ’COMPILE ...forms-which-need-to-be-compiled) +

+

The compiler will take each of them and make a temporary function which will be +compiled and invoked once. It is permissible to wrap a (PROGN ’COMPILE ..) +around the whole file. Currently this construction binds the +compiler::*COMPILE-ORDINARIES* flag to t. Setting this flag globally to a non +nil value to cause all top level forms to generate machine code. This might be +useful in a system such as PCL, where a number of top level lambda expressions +are given. Note that most common lisps will simply ignore the top level atom +’compile, since it has no side effects. +

+

Defentry, clines, and defcfun also result in machine code being generated. +

+
+ + +

subsection Evaluation at Compile time

+ +

In GCL the eval-when behaviour was changed in order to allow +more efficient init code, and also to bring it into line with the resolution +passed by the X3j13 committee. Evaluation at compile time is controlled by +placing eval-when special forms in the code, or by the value of the variable +compiler::*eval-when-defaults* [default value :defaults]. If that variable +has value :defaults, then the following hold: +

+

Eval at Compile       Type of Top Level Form
+

+
+
Partial:
+

defstructs, defvar, defparameter +

+
Full:
+

defmacro, defconstant, defsetf, define-setf-method, + deftype, package ops, proclaim +

+
None:
+

defun, others +

+
+ + +

By ‘partial’ we mean (see the X3J13 Common Lisp document +(doc/compile-file-handling-of-top-level-forms) for more detail), that functions +will not be defined, values will not be set, but other miscellaneous compiler +properties will be set: eg properties to inline expand defstruct accessors and +testers, defstruct properties allowing subsequent defstructs to include this +one, any type hierarch information, special variable information will be set up. +

+

Example: +

+
(defun foo () 3)
+(defstruct jo a b)
+
+ +

As a side effect of compiling these two forms, foo would not have its function +cell changed. Neither would jo-a, although it would gain a property which +allows it to expand inline to a structure access. Thus if it had a previous +definition (as commonly happens from previously loading the file), this previous +definition would not be touched, and could well be inconsistent with the +compiler properties. Unfortunately this is what the CL standard says to do, +and I am just trying to follow it. +

+

If you prefer a more intuitive scheme, of evaling all forms in the file, so +that there are no inconsistencies, (previous behaviour of AKCL) you may set +compiler::*eval-when-defaults* to ’(compile eval load). +

+

The variable compiler::*FASD-DATA* [default t] controls whether an ascii output +is used for the data section of the object file. The data section will be in +ascii if *fasd-data* is nil or if the system-p keyword is supplied to +compile-file and *fasd-data* is not eq to :system-p. +

+

The old GCL variable *compile-time-too* has disappeared. +

+

See OPTIMIZE on how to enable warnings of slow constructs. +

+
+
Function: PROCLAIM (decl-spec)
+

Package:LISP +

+

Puts the declaration given by DECL-SPEC into effect globally. See the doc of +DECLARE for possible DECL-SPECs. +

+ +
+ + + + + + +
+
Function: PROVIDE (module-name)
+

Package:LISP +

+

Adds the specified module to the list of modules maintained in *MODULES*. +

+ +
+ +
+
Function: COMPILED-FUNCTION-P (x)
+

Package:LISP +

+

Returns T if X is a compiled function; NIL otherwise. +

+ +
+ +
+
Function: GPROF-START ()
+

Package:SYSTEM +

+

GCL now has preliminary support for profiling with gprof, an +externally supplied profiling tool at the C level which typically +accompanies gcc. Support must be enabled at compile time with +–enable-gprof. This function starts the profiling timers and +counters. +

+
+ + +
+
Function: GPROF-QUIT ()
+

Package:SYSTEM +

+

GCL now has preliminary support for profiling with gprof, an +externally supplied profiling tool at the C level which typically +accompanies gcc. Support must be enabled at compile time with +–enable-gprof. This function reports the profiling results in the +form of a call graph to standard output, and clears the profiling +arrays. Please note that lisp functions are not (yet) displayed with +their lisp names. Please see also the PROFILE function. +

+
+ + +
+
Function: GPROF-SET (begin end)
+

Package:SYSTEM +

+

GCL now has preliminary support for profiling with gprof, an +externally supplied profiling tool at the C level which typically +accompanies gcc. Support must be enabled at compile time with +–enable-gprof. This function sets the address range used by +GPROF-START in specifying the section of the running program which is +to be profiled. All subsequent calls to GPROF-START will use this new +address range. By default, the range is set to begin at the starting +address of the .text section, and to end at the current end of the +running core. These default values can be restored by calling +GPROF-SET with both argments set to 0. +

+
+ + +
+
Variable: *DEFAULT-SYSTEM-P*
+

Pakcage:COMPILER +Specifies the default setting of :SYSTEM-P used by COMPILE. Defaults to NIL. +

+ +
+
Variable: *DEFAULT-C-FILE*
+

Pakcage:COMPILER +Specifies the default setting of :C-FILE used by COMPILE. Defaults to NIL. +

+ +
+
Variable: *DEFAULT-H-FILE*
+

Pakcage:COMPILER +Specifies the default setting of :H-FILE used by COMPILE. Defaults to NIL. +

+ +
+
Variable: *DEFAULT-DATA-FILE*
+

Pakcage:COMPILER +Specifies the default setting of :DATA-FILE used by COMPILE. Defaults to NIL. +

+ +
+
Variable: *FEATURES*
+

Package:LISP +List of symbols that name features of the current version of GCL. +These features are used to decide the read-time conditionalization facility +provided by ’#+’ and ’#-’ read macros. When the GCL reader encounters +

+
	#+ feature-description form
+
+

it reads FORM in the usual manner if FEATURE-DESCRIPTION is true. Otherwise, +the reader just skips FORM. +

+
	#- feature-description form
+
+

is equivalent to +

+
	#- (not feature-description) form
+
+

A feature-description may be a symbol, which is true only when it is an +element of *FEATURES*. Or else, it must be one of the following: +

+
(and feature-desciption-1 ... feature-desciption-n)
+(or  feature-desciption-1 ... feature-desciption-n)
+(not feature-desciption)
+
+

The AND description is true only when all of its sub-descriptions are true. +The OR description is true only when at least one of its sub-descriptions is +true. The NOT description is true only when its sub-description is false. +

+ +
+ + + +
+
+

+Next: , Previous: , Up: Top   [Contents][Index]

+
+ + + + + diff --git a/info/gcl-si/Compiler-Definitions.html b/info/gcl-si/Compiler-Definitions.html new file mode 100644 index 0000000..070d05e --- /dev/null +++ b/info/gcl-si/Compiler-Definitions.html @@ -0,0 +1,236 @@ + + + + +GCL SI Manual: Compiler Definitions + + + + + + + + + + + + + + + + + + + + +
+

+Next: , Previous: , Up: Top   [Contents][Index]

+
+
+ +

20 Compiler Definitions

+ +
+
Function: EMIT-FN (turn-on)
+

Package:COMPILER +

+

If TURN-ON is t, the subsequent calls to COMPILE-FILE will +cause compilation of foo.lisp to emit a foo.fn as well as foo.o. +The .fn file contains cross referencing information as well as +information useful to the collection utilities in cmpnew/collectfn +This latter file must be manually loaded to call emit-fn. +

+ +
+
+
Variable: *CMPINCLUDE-STRING*
+

Package:COMPILER +If it is a string it holds the text of the cmpinclude.h file appropriate for +this version. Otherwise the usual #include of *cmpinclude* will be used. To +disable this feature set *cmpinclude-string* to NIL in the init-form. +

+ +
+
+
Function: EMIT-FN (turn-on)
+

Package:COMPILER +

+ +

If TURN-ON is t, then subsequent calls to compile-file on a file foo.lisp +cause output of a file foo.fn. This .fn file contains lisp structures +describing the functions in foo.lisp. Some tools for analyzing this data base +are WHO-CALLS, LIST-UNDEFINED-FUNCTIONS, LIST-UNCALLED-FUNCTIONS, and +MAKE-PROCLAIMS. +

+

Usage: +(compiler::emit-fn t) +(compile-file "foo1.lisp") +(compile-file "foo2.lisp") +

+

This would create foo1.fn and foo2.fn. These may be loaded using LOAD. Each +time compile-file is called the data base is cleared. Immediately after the +compilation, the data base consists of data from the compilation. Thus if you +wished to find functions called but not defined in the current file, you could +do (list-undefined-functions), immediately following the compilation. If you +have a large system, you would load all the .fn files before using the above +tools. +

+ +
+
+
Function: MAKE-ALL-PROCLAIMS (&rest directories)
+

Package:COMPILER +

+ +

For each D in DIRECTORIES all files in (directory D) are loaded. +

+

For example +(make-all-proclaims "lsp/*.fn" "cmpnew/*.fn") +would load any files in lsp/*.fn and cmpnew/*.fn. +

+

[See EMIT-FN for details on creation of .fn files] +

+

Then calculations on the newly loaded .fn files are made, to determine +function proclamations. If number of values of a function cannot be +determined [for example because of a final funcall, or call of a function +totally unknown at this time] then return type * is assigned. +

+

Finally a file sys-proclaim.lisp is written out. This file contains function +proclamations. +

+

(load "sys-proclaim.lisp") +(compile-file "foo1.lisp") +(compile-file "foo2.lisp") +

+ + + +
+
+
Function: MAKE-PROCLAIMS (&optional (stream *standard-output*))
+

Package:COMPILER +

+ +

Write to STREAM the function proclaims from the current data base. Usually a +number of .fn files are loaded prior to running this. See EMIT-FN for details +on how to collect this. Simply use LOAD to load in .fn files. +

+ +
+
+
Function: LIST-UNDEFINED-FUNCTIONS ()
+

Package:COMPILER +

+ +

Return a list of all functions called but not defined, in the current data +base (see EMIT-FN). +

+
+
Sample:
+(compiler::emit-fn t)
+(compile-file "foo1.lisp")
+(compiler::list-undefined-functions)
+or
+(mapcar 'load (directory "*.fn")) (compiler::list-undefined-functions)
+
+
+ +
+
+
Function: WHO-CALLS (function-name)
+

Package:COMPILER +

+ +

List all functions in the data base [see emit-fn] which call FUNCTION-NAME. +

+ +
+
+
Function: LIST-UNCALLED-FUNCTIONS ()
+

Package:COMPILER +

+ +

Examine the current data base [see emit-fn] for any functions or macros which +are called but are not: fboundp, OR defined in the data base, OR having +special compiler optimizer properties which would eliminate an actual call. +

+ + + +
+
+
Variable: *CC*
+

Package:COMPILER +Has value a string which controls which C compiler is used by GCL. +Usually this string is obtained from the machine.defs file, but +may be reset by the user, to change compilers or add an include path. +

+ +
+
+
Variable: *SPLIT-FILES*
+

Package:COMPILER +This affects the behaviour of compile-file, and is useful for cases where +the C compiler cannot handle large C files resulting from lisp compilation. +This scheme should allow arbitrarily long lisp files to be compiled. +

+

If the value [default NIL] is a positive integer, then the source file will +be compiled into several object files whose names have 0,1,2,.. prepended, +and which will be loaded by the main object file. File 0 will +contain compilation of top level forms thru position *split-files* in the +lisp source file, and file 1 the next forms, etc. Thus a 180k file +would probably result in three object files (plus the master object file +of the same name) if *split-files* was set to 60000. +The package information will be inserted in each file. +

+ +
+
+
Variable: *COMPILE-ORDINARIES*
+

Package:COMPILER +If this has a non nil value [default = nil], then all top level +forms will be compiled into machine instructions. Otherwise +only defun’s, defmacro’s, and top level forms beginning +with (progn ’compile ...) will do so. +

+ +
+ +
+
+

+Next: , Previous: , Up: Top   [Contents][Index]

+
+ + + + + diff --git a/info/gcl-si/Debugging.html b/info/gcl-si/Debugging.html new file mode 100644 index 0000000..a9a9b89 --- /dev/null +++ b/info/gcl-si/Debugging.html @@ -0,0 +1,74 @@ + + + + +GCL SI Manual: Debugging + + + + + + + + + + + + + + + + + + + + +
+

+Next: , Previous: , Up: Top   [Contents][Index]

+
+
+ +

18 Debugging

+ + + + + + +
• Source Level Debugging in Emacs:   +
• Low Level Debug Functions:   +
+ + + + + + diff --git a/info/gcl-si/Doc.html b/info/gcl-si/Doc.html new file mode 100644 index 0000000..21a0985 --- /dev/null +++ b/info/gcl-si/Doc.html @@ -0,0 +1,170 @@ + + + + +GCL SI Manual: Doc + + + + + + + + + + + + + + + + + + + + +
+

+Next: , Previous: , Up: Top   [Contents][Index]

+
+
+ +

13 Doc

+ +
+
Function: APROPOS (string &optional (package nil))
+

Package:LISP +

+

Prints those symbols whose print-names contain STRING as substring. +If PACKAGE is non-NIL, then only the specified package is searched. +

+ +
+ +
+
Function: INFO (string &optional (list-of-info-files *default-info-files*))
+

PACKAGE:SI +

+

Find all documentation about STRING in LIST-OF-INFO-FILES. The search +is done for STRING as a substring of a node name, or for STRING in the +indexed entries in the first index for each info file. Typically that +should be a variable and function definition index, if the info file is +about a programming language. If the windowing system is connected, +then a choice box is offered and double clicking on an item brings up +its documentation. +

+

Otherwise a list of choices is offered and the user may select some of +these choices. +

+

list-of-info-files is of the form +

+
 ("gcl-si.info" "gcl-tk.info" "gcl.info")
+
+

The above list is the default value of *default-info-files*, +a variable in the SI package. To find these files in the file +system, the search path *info-paths* is consulted as is the master +info directory dir. +

+

see *Index *default-info-files*:: and *Index *info-paths*::. +For example +

+
(info "defun")
+
+ 0: DEFUN :(gcl-si.info)Special Forms and Functions.
+ 1: (gcl.info)defun.
+Enter n, all, none, or multiple choices eg 1 3 : 1
+
+Info from file /home/wfs/gcl-doc/gcl.info:
+defun                                                               [Macro]
+---------------------------------------------------------------------------
+`Defun'  function-name lambda-list [[{declaration}* | documentation]]
+...
+
+
+

would list the node (gcl.info)defun. +That is the node entitled defun from the info file gcl.info. That +documentation is based on the ANSI common lisp standard. The choice +

+
DEFUN :(gcl-si.info)Special Forms and Functions.
+
+ +

refers to the documentation on DEFUN from the info file gcl-si.info in +the node Special Forms And Functions. This is an index reference +and only the part of the node which refers to defun will be +printed. +

+
+
(info "factor" '("maxima.info"))
+
+

would search the maxima info files index and nodes for factor. +

+
+ + + + + +
+
Variable: *info-paths*
+

Package SI: +

+

A list of strings such as +

+
  '("" "/usr/info/" "/usr/local/lib/info/" "/usr/local/info/"
+    "/usr/local/gnu/info/" )
+
+

saying where to look for the info files. It is used implicitly +by info, see *Index info::. +

+

Looking for maxima.info would look for the file +maxima.info in all the directories listed in *info-paths*. If nto found +then it would look for dir in the *info-paths* directories, +and if it were found it would look in the dir for a menu item +such as +

+
+
* maxima: (/home/wfs/maxima-5.0/info/maxima.info).
+
+ +

If such an entry exists then the directory there would be used for the +purpose of finding maxima.info +

+
+ +
+
+

+Next: , Previous: , Up: Top   [Contents][Index]

+
+ + + + + diff --git a/info/gcl-si/Environment.html b/info/gcl-si/Environment.html new file mode 100644 index 0000000..9415d38 --- /dev/null +++ b/info/gcl-si/Environment.html @@ -0,0 +1,74 @@ + + + + +GCL SI Manual: Environment + + + + + + + + + + + + + + + + + + + + +
+

+Next: , Previous: , Up: Miscellaneous   [Contents][Index]

+
+
+ +

19.1 Environment

+ +

The environment in GCL which is passed to macroexpand and +other functions requesting an environment, should be a +list of 3 lists. The first list looks like ((v1 val1) (v2 val2) ..) +where vi are variables and vali are their values. +The second is a list of ((fname1 . fbody1) (fname2 . fbody2) ...) +where fbody1 is either (macro lambda-list lambda-body) or +(lambda-list lambda-body) depending on whether this is a macro +or a function. The third list contains tags and blocks. +

+ + + + + diff --git a/info/gcl-si/Function-and-Variable-Index.html b/info/gcl-si/Function-and-Variable-Index.html new file mode 100644 index 0000000..7f7a7ff --- /dev/null +++ b/info/gcl-si/Function-and-Variable-Index.html @@ -0,0 +1,1240 @@ + + + + +GCL SI Manual: Function and Variable Index + + + + + + + + + + + + + + + + + + + +
+

+Previous: , Up: Top   [Contents][Index]

+
+
+ +

Appendix A Function and Variable Index

+
Jump to:   * +   ++ +   +- +   +/ +   +1 +   +< +   += +   +> +   +
+A +   +B +   +C +   +D +   +E +   +F +   +G +   +H +   +I +   +K +   +L +   +M +   +N +   +O +   +P +   +Q +   +R +   +S +   +T +   +U +   +V +   +W +   +X +   +Y +   +Z +   +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Index Entry  Section
*
*: Numbers
*: User Interface
**: User Interface
***: User Interface
*AFTER-GBC-HOOK*: System Definitions
*APPLYHOOK*: Special Forms and Functions
*BREAK-ENABLE*: User Interface
*BREAK-ON-WARNINGS*: User Interface
*CASE-FOLD-SEARCH*: System Definitions
*CC*: Compiler Definitions
*CMPINCLUDE-STRING*: Compiler Definitions
*COMPILE-ORDINARIES*: Compiler Definitions
*DEBUG-IO*: User Interface
*DEFAULT-C-FILE*: Compilation
*DEFAULT-DATA-FILE*: Compilation
*DEFAULT-H-FILE*: Compilation
*DEFAULT-PATHNAME-DEFAULTS*: Operating System Definitions
*DEFAULT-SYSTEM-P*: Compilation
*DEFAULT-TIME-ZONE*: System Definitions
*ERROR-OUTPUT*: User Interface
*EVALHOOK*: Special Forms and Functions
*FEATURES*: Compilation
*GBC-MESSAGE*: System Definitions
*GBC-NOTIFY*: System Definitions
*IGNORE-EOF-ON-TERMINAL-IO*: System Definitions
*IGNORE-MAXIMUM-PAGES*: GCL Specific
*INDENT-FORMATTED-OUTPUT*: System Definitions
*info-paths*: Doc
*INTERRUPT-ENABLE*: System Definitions
*LISP-MAXPAGES*: System Definitions
*LOAD-PATHNAME*: System Definitions
*LOAD-VERBOSE*: Streams and Reading
*MACROEXPAND-HOOK*: Special Forms and Functions
*MAKE-CONSTANT: System Definitions
*MAKE-SPECIAL: System Definitions
*MODULES*: Operating System Definitions
*MULTIPLY-STACKS*: System Definitions
*NOTIFY-GBC*: System Definitions
*OPTIMIZE-MAXIMUM-PAGES*: GCL Specific
*PACKAGE*: Symbols
*PRINT-ARRAY*: Streams and Reading
*PRINT-BASE*: Streams and Reading
*PRINT-CASE*: Streams and Reading
*PRINT-CIRCLE*: Streams and Reading
*PRINT-ESCAPE*: Streams and Reading
*PRINT-GENSYM*: Streams and Reading
*PRINT-LENGTH*: Streams and Reading
*PRINT-LEVEL*: Streams and Reading
*PRINT-PRETTY*: Streams and Reading
*PRINT-RADIX*: Streams and Reading
*QUERY-IO*: Streams and Reading
*RANDOM-STATE*: Numbers
*READ-BASE*: Streams and Reading
*READ-DEFAULT-FLOAT-FORMAT*: Streams and Reading
*READ-SUPPRESS*: Streams and Reading
*READLINE-PREFIX*: Streams and Reading
*READTABLE*: Streams and Reading
*SPLIT-FILES*: Compiler Definitions
*STANDARD-INPUT*: Streams and Reading
*STANDARD-OUTPUT*: Streams and Reading
*SYSTEM-DIRECTORY*: System Definitions
*TERMINAL-IO*: Streams and Reading
*TMP-DIR*: GCL Specific
*TOP-LEVEL-HOOK*: System Definitions
*TRACE-OUTPUT*: User Interface
+
+: Numbers
+: User Interface
++: User Interface
+++: User Interface
-
-: User Interface
-: User Interface
-batch: Command Line
-c-file: Command Line
-compile: Command Line
-data-file: Command Line
-dir: Command Line
-eval: Command Line
-f: Command Line
-h-file: Command Line
-libdir: Command Line
-load: Command Line
-o-file: Command Line
-system-p: Command Line
/
/: Numbers
/: User Interface
//: User Interface
///: User Interface
/=: Numbers
1
1+: Numbers
1-: Numbers
<
<: Numbers
<=: Numbers
=
=: Numbers
>
>: Numbers
>=: Numbers
A
ABS: Numbers
ACCEPT: System Definitions
ACONS: Lists
ACOS: Numbers
ACOSH: Numbers
ADDRESS: System Definitions
ADJOIN: Lists
ADJUST-ARRAY: Sequences and Arrays and Hash Tables
ADJUSTABLE-ARRAY-P: Sequences and Arrays and Hash Tables
ALLOCATE: GCL Specific
ALLOCATE-CONTIGUOUS-PAGES: System Definitions
ALLOCATE-GROWTH: System Definitions
ALLOCATE-RELOCATABLE-PAGES: System Definitions
ALLOCATE-SGC: System Definitions
ALLOCATED: System Definitions
ALLOCATED-CONTIGUOUS-PAGES: System Definitions
ALLOCATED-PAGES: System Definitions
ALLOCATED-RELOCATABLE-PAGES: System Definitions
ALPHA-CHAR-P: Characters
ALPHANUMERICP: Characters
AND: Special Forms and Functions
APPEND: Lists
APPLY: Special Forms and Functions
APPLYHOOK: Special Forms and Functions
APROPOS: Doc
APROPOS-LIST: Symbols
AREF: Sequences and Arrays and Hash Tables
ARGC: System Definitions
ARGV: System Definitions
ARRAY-DIMENSION: Sequences and Arrays and Hash Tables
ARRAY-DIMENSION-LIMIT: Sequences and Arrays and Hash Tables
ARRAY-DIMENSIONS: Sequences and Arrays and Hash Tables
ARRAY-ELEMENT-TYPE: Sequences and Arrays and Hash Tables
ARRAY-HAS-FILL-POINTER-P: Sequences and Arrays and Hash Tables
ARRAY-IN-BOUNDS-P: Sequences and Arrays and Hash Tables
ARRAY-RANK: Sequences and Arrays and Hash Tables
ARRAY-RANK-LIMIT: Sequences and Arrays and Hash Tables
ARRAY-ROW-MAJOR-INDEX: Sequences and Arrays and Hash Tables
ARRAY-TOTAL-SIZE: Sequences and Arrays and Hash Tables
ARRAY-TOTAL-SIZE-LIMIT: Sequences and Arrays and Hash Tables
ARRAYP: Sequences and Arrays and Hash Tables
ASH: Numbers
ASIN: Numbers
ASINH: Numbers
ASSERT: Type
ASSOC: Lists
ASSOC-IF: Lists
ASSOC-IF-NOT: Lists
ATAN: Numbers
ATANH: Numbers
ATOM: Lists
B
BDS-VAL: System Definitions
BDS-VAR: System Definitions
BIT: Sequences and Arrays and Hash Tables
BIT-AND: Numbers
BIT-ANDC1: Numbers
BIT-ANDC2: Numbers
BIT-EQV: Sequences and Arrays and Hash Tables
BIT-IOR: Sequences and Arrays and Hash Tables
BIT-NAND: Numbers
BIT-NOR: Numbers
BIT-NOT: Sequences and Arrays and Hash Tables
BIT-ORC1: Sequences and Arrays and Hash Tables
BIT-ORC2: Sequences and Arrays and Hash Tables
BIT-VECTOR-P: Sequences and Arrays and Hash Tables
BIT-XOR: Sequences and Arrays and Hash Tables
BLOCK: Special Forms and Functions
BOOLE: Numbers
BOOLE-1: Numbers
BOOLE-2: Numbers
BOOLE-AND: Numbers
BOOLE-ANDC1: Numbers
BOOLE-ANDC2: Numbers
BOOLE-C1: Numbers
BOOLE-C2: Numbers
BOOLE-CLR: Numbers
BOOLE-EQV: Numbers
BOOLE-IOR: Numbers
BOOLE-NAND: Numbers
BOOLE-NOR: Numbers
BOOLE-ORC1: Numbers
BOOLE-ORC2: Numbers
BOOLE-SET: Numbers
BOOLE-XOR: Numbers
BOTH-CASE-P: Characters
BOUNDP: Symbols
BREAK: User Interface
BREAK-FUNCTION: System Definitions
BREAK-ON-FLOATING-POINT-EXCEPTIONS: Operating System Definitions
BUTLAST: Lists
BY: GCL Specific
BYE: GCL Specific
BYTE: Numbers
BYTE-POSITION: Numbers
BYTE-SIZE: Numbers
C
CAAAAR: Lists
CAAADR: Lists
CAAAR: Lists
CAADAR: Lists
CAADDR: Lists
CAADR: Lists
CAAR: Lists
CADAAR: Lists
CADADR: Lists
CADAR: Lists
CADDAR: Lists
CADDDR: Lists
CADDR: Lists
CADR: Lists
CALL-ARGUMENTS-LIMIT: Special Forms and Functions
CAR: Lists
CASE: Special Forms and Functions
CATCH: Special Forms and Functions
CATCH-BAD-SIGNALS: System Definitions
CATCH-FATAL: System Definitions
CCASE: Special Forms and Functions
CDAAAR: Lists
CDAADR: Lists
CDAAR: Lists
CDADAR: Lists
CDADDR: Lists
CDADR: Lists
CDAR: Lists
CDDAAR: Lists
CDDADR: Lists
CDDAR: Lists
CDDDAR: Lists
CDDDDR: Lists
CDDDR: Lists
CDDR: Lists
CDR: Lists
CEILING: Numbers
CERROR: User Interface
CHAR: Sequences and Arrays and Hash Tables
CHAR-BIT: Characters
CHAR-BITS: Characters
CHAR-BITS-LIMIT: Characters
CHAR-CODE: Characters
CHAR-CODE-LIMIT: Numbers
CHAR-CONTROL-BIT: Characters
CHAR-DOWNCASE: Characters
CHAR-EQUAL: Characters
CHAR-FONT: Characters
CHAR-FONT-LIMIT: Characters
CHAR-GREATERP: Characters
CHAR-HYPER-BIT: Characters
CHAR-INT: Numbers
CHAR-LESSP: Characters
CHAR-META-BIT: Characters
CHAR-NAME: Characters
CHAR-NOT-EQUAL: Characters
CHAR-NOT-GREATERP: Characters
CHAR-NOT-LESSP: Characters
CHAR-SUPER-BIT: Characters
CHAR-UPCASE: Characters
CHAR/=: Characters
CHAR<: Characters
CHAR<=: Characters
CHAR=: Characters
CHAR>: Characters
CHAR>=: Characters
CHARACTER: Characters
CHARACTERP: Characters
CHDIR: System Definitions
CHECK-TYPE: Type
CIS: Numbers
CLEAR-INPUT: Streams and Reading
CLEAR-OUTPUT: Streams and Reading
CLINES: GCL Specific
CLOSE: Streams and Reading
CLOSE-FASD: System Definitions
CLRHASH: Sequences and Arrays and Hash Tables
CODE-CHAR: Characters
COERCE: Type
COMMONP: Type
COMPILE: Compilation
COMPILE-FILE: Compilation
COMPILED-FUNCTION-NAME: System Definitions
COMPILED-FUNCTION-P: Compilation
COMPILER-LET: Special Forms and Functions
COMPLEX: Numbers
COMPLEXP: Numbers
CONCATENATE: Sequences and Arrays and Hash Tables
COND: Special Forms and Functions
CONJUGATE: Numbers
CONS: Lists
CONSP: Lists
CONSTANTP: Type
COPY-ALIST: Lists
COPY-ARRAY-PORTION: GCL Specific
COPY-LIST: Lists
COPY-READTABLE: Streams and Reading
COPY-SEQ: Sequences and Arrays and Hash Tables
COPY-STREAM: System Definitions
COPY-SYMBOL: Symbols
COPY-TREE: Lists
COS: Numbers
COSH: Numbers
COUNT: Sequences and Arrays and Hash Tables
COUNT-IF: Sequences and Arrays and Hash Tables
COUNT-IF-NOT: Sequences and Arrays and Hash Tables
CTYPECASE: Special Forms and Functions
D
DBL: System Definitions
DECF: Numbers
DECLARE: Special Forms and Functions
DECODE-FLOAT: Numbers
DECODE-UNIVERSAL-TIME: Operating System Definitions
DEFCFUN: GCL Specific
DEFCONSTANT: Special Forms and Functions
DEFENTRY: GCL Specific
DEFINE-COMPILER-MACRO: System Definitions
DEFINE-INLINE-FUNCTION: System Definitions
DEFINE-MODIFY-MACRO: Special Forms and Functions
DEFINE-SETF-METHOD: Special Forms and Functions
DEFLA: GCL Specific
DEFMACRO: Special Forms and Functions
DEFPARAMETER: Special Forms and Functions
DEFSETF: Special Forms and Functions
DEFSTRUCT: Structures
DEFTYPE: Type
DEFUN: Special Forms and Functions
DEFVAR: Special Forms and Functions
DELETE: Sequences and Arrays and Hash Tables
DELETE-DUPLICATES: Sequences and Arrays and Hash Tables
DELETE-FILE: Operating System Definitions
DELETE-IF: Sequences and Arrays and Hash Tables
DELETE-IF-NOT: Sequences and Arrays and Hash Tables
DENOMINATOR: Numbers
DEPOSIT-FIELD: Numbers
DESCRIBE: User Interface
DIGIT-CHAR: Characters
DIGIT-CHAR-P: Characters
DIRECTORY: Operating System Definitions
DIRECTORY-NAMESTRING: Streams and Reading
DISASSEMBLE: Characters
DISPLACED-ARRAY-P: System Definitions
DO: Streams and Reading
DO*: Iteration and Tests
DO-ALL-SYMBOLS: Iteration and Tests
DO-EXTERNAL-SYMBOLS: Iteration and Tests
DO-SYMBOLS: Iteration and Tests
DOCUMENTATION: Symbols
DOLIST: Iteration and Tests
DOTIMES: Special Forms and Functions
DOUBLE-FLOAT-EPSILON: Numbers
DOUBLE-FLOAT-NEGATIVE-EPSILON: Numbers
DPB: Numbers
DRIBBLE: User Interface
DYNAMIC-EXTENT: Type
E
ECASE: Special Forms and Functions
ED: User Interface
EIGHTH: Lists
ELT: Sequences and Arrays and Hash Tables
EMIT-FN: Compiler Definitions
EMIT-FN: Compiler Definitions
ENCODE-UNIVERSAL-TIME: Operating System Definitions
ENDP: Lists
ENOUGH-NAMESTRING: Operating System Definitions
EQ: Iteration and Tests
EQL: Numbers
EQUAL: Iteration and Tests
EQUALP: Iteration and Tests
ERROR: Special Forms and Functions
ERROR-SET: System Definitions
ETYPECASE: Special Forms and Functions
EVAL: Special Forms and Functions
EVAL-WHEN: Compilation
EVALHOOK: Special Forms and Functions
EVENP: Numbers
EVERY: Sequences and Arrays and Hash Tables
EXP: Numbers
EXPORT: Symbols
EXPT: Numbers
F
FASLINK: System Definitions
FBOUNDP: Symbols
FCEILING: Numbers
FFLOOR: Numbers
FIFTH: Lists
FILE-AUTHOR: Operating System Definitions
FILE-LENGTH: Streams and Reading
FILE-NAMESTRING: Streams and Reading
FILE-POSITION: Operating System Definitions
FILE-WRITE-DATE: Streams and Reading
FILL: Sequences and Arrays and Hash Tables
FILL-POINTER: Sequences and Arrays and Hash Tables
FIND: Sequences and Arrays and Hash Tables
FIND-ALL-SYMBOLS: Symbols
FIND-IF: Sequences and Arrays and Hash Tables
FIND-IF-NOT: Sequences and Arrays and Hash Tables
FIND-PACKAGE: Symbols
FIND-SHARING-TOP: System Definitions
FIND-SYMBOL: Symbols
FINISH-OUTPUT: Streams and Reading
FIRST: Lists
FIXNUMP: System Definitions
FLET: Special Forms and Functions
FLOAT: Numbers
FLOAT-DIGITS: Numbers
FLOAT-PRECISION: Numbers
FLOAT-RADIX: Numbers
FLOAT-SIGN: Numbers
FLOATP: Numbers
FLOOR: Numbers
FMAKUNBOUND: Symbols
FORCE-OUTPUT: Streams and Reading
FORMAT: Streams and Reading
FOURTH: Lists
FP-INPUT-STREAM: System Definitions
FP-OUTPUT-STREAM: System Definitions
FREAD: System Definitions
FREEZE-DEFSTRUCT: System Definitions
FRESH-LINE: Streams and Reading
FROUND: Numbers
FRS-BDS: System Definitions
FRS-IHS: System Definitions
FRS-VS: System Definitions
FTRUNCATE: Numbers
FUNCALL: Special Forms and Functions
FUNCTION: Special Forms and Functions
FUNCTIONP: Special Forms and Functions
FWRITE: System Definitions
G
GBC: GCL Specific
GBC-TIME: System Definitions
GCD: Numbers
GENSYM: Symbols
GENTEMP: Symbols
GET: Symbols
GET-DECODED-TIME: Operating System Definitions
GET-DISPATCH-MACRO-CHARACTER: Streams and Reading
GET-HOLE-SIZE: System Definitions
GET-INTERNAL-REAL-TIME: Operating System Definitions
GET-INTERNAL-RUN-TIME: Operating System Definitions
GET-MACRO-CHARACTER: Streams and Reading
GET-OUTPUT-STREAM-STRING: Streams and Reading
GET-PROPERTIES: Lists
GET-SETF-METHOD: Special Forms and Functions
GET-SETF-METHOD-MULTIPLE-VALUE: Special Forms and Functions
GET-STRING-INPUT-STREAM-INDEX: System Definitions
GET-UNIVERSAL-TIME: Operating System Definitions
GETENV: System Definitions
GETF: Lists
GETHASH: Sequences and Arrays and Hash Tables
GO: Special Forms and Functions
GPROF-QUIT: Compilation
GPROF-SET: Compilation
GPROF-START: Compilation
GRAPHIC-CHAR-P: Characters
H
HASH-TABLE-COUNT: Sequences and Arrays and Hash Tables
HASH-TABLE-P: Sequences and Arrays and Hash Tables
HELP: Structures
HELP*: GCL Specific
HOST-NAMESTRING: Operating System Definitions
I
IDENTITY: Special Forms and Functions
IF: Special Forms and Functions
IHS-FUN: System Definitions
IHS-VS: System Definitions
IMAGPART: Numbers
IMPORT: Symbols
IN-PACKAGE: Symbols
INCF: Numbers
INFO: Doc
INIT-SYSTEM: System Definitions
INPUT-STREAM-P: Streams and Reading
INSPECT: User Interface
INT-CHAR: Numbers
INTEGER-DECODE-FLOAT: Numbers
INTEGER-LENGTH: Numbers
INTEGERP: Numbers
INTERN: Symbols
INTERNAL-TIME-UNITS-PER-SECOND: Operating System Definitions
INTERSECTION: Lists
ISQRT: Numbers
K
KEYWORDP: Symbols
L
LABELS: Special Forms and Functions
LAMBDA-LIST-KEYWORDS: Special Forms and Functions
LAMBDA-PARAMETERS-LIMIT: Special Forms and Functions
LAST: Lists
LCM: Numbers
LDB: Numbers
LDB-TEST: Numbers
LDIFF: Lists
LEAST-NEGATIVE-DOUBLE-FLOAT: Numbers
LEAST-NEGATIVE-LONG-FLOAT: Numbers
LEAST-NEGATIVE-SHORT-FLOAT: Numbers
LEAST-NEGATIVE-SINGLE-FLOAT: Numbers
LEAST-POSITIVE-DOUBLE-FLOAT: Numbers
LEAST-POSITIVE-LONG-FLOAT: Numbers
LEAST-POSITIVE-SHORT-FLOAT: Numbers
LEAST-POSITIVE-SINGLE-FLOAT: Numbers
LENGTH: Lists
LET: Special Forms and Functions
LET*: Special Forms and Functions
LINK: Compilation
LISP-IMPLEMENTATION-TYPE: Operating System Definitions
LISP-IMPLEMENTATION-VERSION: Operating System Definitions
LIST: Lists
LIST*: Lists
LIST-ALL-PACKAGES: Symbols
LIST-LENGTH: Lists
LIST-UNCALLED-FUNCTIONS: Compiler Definitions
LIST-UNDEFINED-FUNCTIONS: Compiler Definitions
LISTEN: Streams and Reading
LISTP: Lists
LOAD: Streams and Reading
LOCALLY: Special Forms and Functions
LOG: Numbers
LOGAND: Numbers
LOGANDC1: Numbers
LOGANDC2: Numbers
LOGBITP: Numbers
LOGCOUNT: Numbers
LOGEQV: Numbers
LOGIOR: Numbers
LOGNAND: Numbers
LOGNOR: Numbers
LOGNOT: Numbers
LOGORC1: Numbers
LOGORC2: Numbers
LOGTEST: Numbers
LOGXOR: Numbers
LONG-FLOAT-EPSILON: Numbers
LONG-FLOAT-NEGATIVE-EPSILON: Numbers
LONG-SITE-NAME: Operating System Definitions
LOOP: Iteration and Tests
LOWER-CASE-P: Characters
M
MACHINE-INSTANCE: Operating System Definitions
MACHINE-TYPE: Operating System Definitions
MACHINE-VERSION: GCL Specific
MACRO-FUNCTION: Symbols
MACROEXPAND: Special Forms and Functions
MACROEXPAND-1: Special Forms and Functions
MACROLET: Special Forms and Functions
MAKE-ALL-PROCLAIMS: Compiler Definitions
MAKE-ARRAY: Sequences and Arrays and Hash Tables
MAKE-BROADCAST-STREAM: Streams and Reading
MAKE-CHAR: Characters
MAKE-CONCATENATED-STREAM: Streams and Reading
MAKE-DISPATCH-MACRO-CHARACTER: Streams and Reading
MAKE-ECHO-STREAM: Streams and Reading
MAKE-HASH-TABLE: Sequences and Arrays and Hash Tables
MAKE-LIST: Lists
MAKE-PACKAGE: Symbols
MAKE-PATHNAME: Streams and Reading
MAKE-PROCLAIMS: Compiler Definitions
MAKE-RANDOM-STATE: Numbers
MAKE-SEQUENCE: Sequences and Arrays and Hash Tables
MAKE-STRING: Sequences and Arrays and Hash Tables
MAKE-STRING-INPUT-STREAM: Streams and Reading
MAKE-STRING-INPUT-STREAM: User Interface
MAKE-STRING-OUTPUT-STREAM: Streams and Reading
MAKE-STRING-OUTPUT-STREAM-FROM-STRING: System Definitions
MAKE-SYMBOL: Symbols
MAKE-SYNONYM-STREAM: Streams and Reading
MAKE-TWO-WAY-STREAM: Streams and Reading
MAKUNBOUND: Symbols
MAP: Sequences and Arrays and Hash Tables
MAPC: Lists
MAPCAN: Lists
MAPCAR: Iteration and Tests
MAPCON: Lists
MAPHASH: Iteration and Tests
MAPL: Lists
MAPLIST: Lists
MASK-FIELD: Numbers
MATCH-BEGINNING: System Definitions
MATCH-END: System Definitions
MAX: Numbers
MAXIMUM-ALLOCATABLE-PAGES: System Definitions
MAXIMUM-CONTIGUOUS-PAGES: System Definitions
MEMBER: Lists
MEMBER-IF: Lists
MEMBER-IF-NOT: Lists
MERGE: Sequences and Arrays and Hash Tables
MERGE-PATHNAMES: Streams and Reading
MIN: Numbers
MINUSP: Numbers
MISMATCH: Sequences and Arrays and Hash Tables
MOD: Numbers
MODF: Numbers
MOST-NEGATIVE-DOUBLE-FLOAT: Numbers
MOST-NEGATIVE-FIXNUM: Numbers
MOST-NEGATIVE-LONG-FLOAT: Numbers
MOST-NEGATIVE-SHORT-FLOAT: Numbers
MOST-NEGATIVE-SINGLE-FLOAT: Numbers
MOST-POSITIVE-DOUBLE-FLOAT: Numbers
MOST-POSITIVE-FIXNUM: Numbers
MOST-POSITIVE-LONG-FLOAT: Numbers
MOST-POSITIVE-SHORT-FLOAT: Numbers
MOST-POSITIVE-SINGLE-FLOAT: Numbers
MULTIPLE-VALUE-BIND: Special Forms and Functions
MULTIPLE-VALUE-CALL: Special Forms and Functions
MULTIPLE-VALUE-LIST: Special Forms and Functions
MULTIPLE-VALUE-PROG1: Special Forms and Functions
MULTIPLE-VALUE-SETQ: Special Forms and Functions
MULTIPLE-VALUES-LIMIT: Special Forms and Functions
N
NAME-CHAR: Characters
NAMESTRING: Streams and Reading
NANI: System Definitions
NBUTLAST: Lists
NCONC: Lists
NIL: Symbols
NINTERSECTION: Lists
NINTH: Lists
NLOAD: System Definitions
NOT: Special Forms and Functions
NOTANY: Sequences and Arrays and Hash Tables
NOTEVERY: Sequences and Arrays and Hash Tables
NRECONC: Lists
NREVERSE: Sequences and Arrays and Hash Tables
NSET-DIFFERENCE: Lists
NSET-EXCLUSIVE-OR: Lists
NSTRING-CAPITALIZE: Sequences and Arrays and Hash Tables
NSTRING-DOWNCASE: Sequences and Arrays and Hash Tables
NSTRING-UPCASE: Sequences and Arrays and Hash Tables
NSUBLIS: Lists
NSUBST: Lists
NSUBST-IF: Lists
NSUBST-IF-NOT: Lists
NSUBSTITUTE: Sequences and Arrays and Hash Tables
NSUBSTITUTE-IF: Sequences and Arrays and Hash Tables
NSUBSTITUTE-IF-NOT: Sequences and Arrays and Hash Tables
NTH: Lists
NTHCDR: Lists
NULL: Lists
NUMBERP: Numbers
NUMERATOR: Numbers
NUNION: Lists
O
ODDP: Numbers
OPEN: Streams and Reading
OPEN-FASD: System Definitions
OR: Special Forms and Functions
OUTPUT-STREAM-P: Streams and Reading
OUTPUT-STREAM-STRING: System Definitions
P
PACKAGE-NAME: Symbols
PACKAGE-NICKNAMES: Symbols
PACKAGE-SHADOWING-SYMBOLS: Symbols
PACKAGE-USE-LIST: Symbols
PACKAGE-USED-BY-LIST: Symbols
PACKAGEP: Symbols
PAIRLIS: Lists
PARSE-INTEGER: Numbers
PARSE-NAMESTRING: Streams and Reading
PATHNAME: Streams and Reading
PATHNAME-DEVICE: Streams and Reading
PATHNAME-DIRECTORY: Streams and Reading
PATHNAME-HOST: Operating System Definitions
PATHNAME-NAME: Streams and Reading
PATHNAME-TYPE: Streams and Reading
PATHNAME-VERSION: Streams and Reading
PATHNAMEP: Streams and Reading
PEEK-CHAR: Streams and Reading
PHASE: Numbers
PI: Numbers
PLUSP: Numbers
POP: Lists
POSITION: Sequences and Arrays and Hash Tables
POSITION-IF: Sequences and Arrays and Hash Tables
POSITION-IF-NOT: Sequences and Arrays and Hash Tables
PPRINT: Streams and Reading
PRIN1: Streams and Reading
PRIN1-TO-STRING: Streams and Reading
PRINC: Streams and Reading
PRINC-TO-STRING: Streams and Reading
PRINT: Streams and Reading
PROBE-FILE: Streams and Reading
PROCLAIM: Compilation
PROCLAMATION: GCL Specific
PROF: System Definitions
PROG: Special Forms and Functions
PROG*: Special Forms and Functions
PROG1: Special Forms and Functions
PROG2: Special Forms and Functions
PROGN: Special Forms and Functions
PROGV: Special Forms and Functions
PROVIDE: Compilation
PSETF: Special Forms and Functions
PSETQ: Symbols
PUSH: Lists
PUSHNEW: Lists
PUTPROP: System Definitions
Q
QUOTE: Special Forms and Functions
R
RANDOM: Numbers
RANDOM-STATE-P: Numbers
RASSOC: Lists
RASSOC-IF: Lists
RASSOC-IF-NOT: Lists
RATIONAL: Numbers
RATIONALIZE: Numbers
RATIONALP: Numbers
READ: Streams and Reading
READ-BYTE: Streams and Reading
READ-CHAR: Streams and Reading
READ-CHAR-NO-HANG: Streams and Reading
READ-DELIMITED-LIST: Streams and Reading
READ-FASD-TOP: System Definitions
READ-FROM-STRING: Streams and Reading
READ-LINE: Streams and Reading
READ-PRESERVING-WHITESPACE: Streams and Reading
READLINE-OFF: Streams and Reading
READLINE-ON: Streams and Reading
READTABLEP: Streams and Reading
REALPART: Numbers
REDUCE: Sequences and Arrays and Hash Tables
REM: Numbers
REMF: Symbols
REMHASH: Sequences and Arrays and Hash Tables
REMOVE: Sequences and Arrays and Hash Tables
REMOVE-DUPLICATES: Sequences and Arrays and Hash Tables
REMOVE-IF: Sequences and Arrays and Hash Tables
REMOVE-IF-NOT: Sequences and Arrays and Hash Tables
REMPROP: Symbols
RENAME-FILE: Operating System Definitions
RENAME-PACKAGE: Symbols
REPLACE: Sequences and Arrays and Hash Tables
REQUIRE: Operating System Definitions
RESET-GBC-COUNT: System Definitions
RESET-STACK-LIMITS: System Definitions
REST: Lists
RETURN: Special Forms and Functions
RETURN-FROM: Special Forms and Functions
REVAPPEND: Lists
REVERSE: Sequences and Arrays and Hash Tables
ROOM: Operating System Definitions
ROTATEF: Numbers
ROUND: Numbers
RPLACA: Lists
RPLACD: Lists
RUN-PROCESS: System Definitions
S
SAVE: GCL Specific
SAVE-SYSTEM: System Definitions
SBIT: Sequences and Arrays and Hash Tables
SCALE-FLOAT: Numbers
SCHAR: Characters
SEARCH: Sequences and Arrays and Hash Tables
SECOND: Lists
SET: Symbols
SET-CHAR-BIT: Characters
SET-DIFFERENCE: Lists
SET-DISPATCH-MACRO-CHARACTER: Streams and Reading
SET-EXCLUSIVE-OR: Lists
SET-HOLE-SIZE: System Definitions
SET-MACRO-CHARACTER: Streams and Reading
SET-SYNTAX-FROM-CHAR: Streams and Reading
SETF: Special Forms and Functions
SETQ: Symbols
SEVENTH: Lists
SGC-ON: System Definitions
SHADOW: Symbols
SHADOWING-IMPORT: Symbols
SHIFTF: Numbers
SHORT-FLOAT-EPSILON: Numbers
SHORT-FLOAT-NEGATIVE-EPSILON: Numbers
SHORT-SITE-NAME: Operating System Definitions
SIGNUM: Numbers
SIMPLE-BIT-VECTOR-P: Sequences and Arrays and Hash Tables
SIMPLE-STRING-P: Sequences and Arrays and Hash Tables
SIMPLE-VECTOR-P: Sequences and Arrays and Hash Tables
SIN: Numbers
SINGLE-FLOAT-EPSILON: Numbers
SINGLE-FLOAT-NEGATIVE-EPSILON: Numbers
SINH: Numbers
SIXTH: Lists
SLEEP: Operating System Definitions
SOCKET: System Definitions
SOFTWARE-TYPE: Operating System Definitions
SOFTWARE-VERSION: Operating System Definitions
SOME: Sequences and Arrays and Hash Tables
SORT: Sequences and Arrays and Hash Tables
SPECIAL-FORM-P: Special Forms and Functions
SPECIALP: System Definitions
SQRT: Numbers
STABLE-SORT: Sequences and Arrays and Hash Tables
STANDARD-CHAR-P: Characters
STEP: User Interface
STREAM-ELEMENT-TYPE: Streams and Reading
STREAMP: Streams and Reading
STRING: Sequences and Arrays and Hash Tables
STRING-CAPITALIZE: Sequences and Arrays and Hash Tables
STRING-CHAR-P: Characters
STRING-CONCATENATE: System Definitions
STRING-DOWNCASE: Sequences and Arrays and Hash Tables
STRING-EQUAL: Sequences and Arrays and Hash Tables
STRING-GREATERP: Sequences and Arrays and Hash Tables
STRING-LEFT-TRIM: Sequences and Arrays and Hash Tables
STRING-LESSP: Sequences and Arrays and Hash Tables
STRING-MATCH: System Definitions
STRING-NOT-EQUAL: Sequences and Arrays and Hash Tables
STRING-NOT-GREATERP: Sequences and Arrays and Hash Tables
STRING-NOT-LESSP: Sequences and Arrays and Hash Tables
STRING-RIGHT-TRIM: Sequences and Arrays and Hash Tables
STRING-TO-OBJECT: System Definitions
STRING-TRIM: Sequences and Arrays and Hash Tables
STRING-UPCASE: Sequences and Arrays and Hash Tables
STRING/=: Sequences and Arrays and Hash Tables
STRING<: Sequences and Arrays and Hash Tables
STRING<=: Sequences and Arrays and Hash Tables
STRING=: Sequences and Arrays and Hash Tables
STRING>: Sequences and Arrays and Hash Tables
STRING>=: Sequences and Arrays and Hash Tables
STRINGP: Sequences and Arrays and Hash Tables
STRUCTUREP: System Definitions
SUBLIS: Lists
SUBSEQ: Sequences and Arrays and Hash Tables
SUBSETP: Lists
SUBST: Lists
SUBST-IF: Lists
SUBST-IF-NOT: Lists
SUBSTITUTE: Sequences and Arrays and Hash Tables
SUBSTITUTE-IF: Sequences and Arrays and Hash Tables
SUBSTITUTE-IF-NOT: Sequences and Arrays and Hash Tables
SUBTYPEP: Type
SVREF: Sequences and Arrays and Hash Tables
SXHASH: Numbers
SYMBOL-FUNCTION: Symbols
SYMBOL-NAME: Symbols
SYMBOL-PACKAGE: Symbols
SYMBOL-PLIST: Symbols
SYMBOL-VALUE: Symbols
SYMBOLP: Symbols
SYSTEM: GCL Specific
T
T: Symbols
TAGBODY: Special Forms and Functions
TAILP: Lists
TAN: Numbers
TANH: Numbers
TENTH: Lists
TERPRI: Streams and Reading
THE: Special Forms and Functions
THIRD: Lists
THROW: Special Forms and Functions
TIME: Operating System Definitions
TOP-LEVEL: System Definitions
TRACE: User Interface
TREE-EQUAL: Lists
TRUENAME: Streams and Reading
TRUNCATE: Numbers
TYPE-OF: Type
TYPECASE: Special Forms and Functions
TYPEP: Type
U
UNCATCH-BAD-SIGNALS: System Definitions
UNEXPORT: Symbols
UNINTERN: Symbols
UNION: Lists
UNIVERSAL-ERROR-HANDLER: System Definitions
UNLESS: Special Forms and Functions
UNREAD-CHAR: Streams and Reading
UNTRACE: User Interface
UNUSE-PACKAGE: Symbols
UNWIND-PROTECT: Special Forms and Functions
UPPER-CASE-P: Characters
USE-FAST-LINKS: GCL Specific
USE-PACKAGE: Symbols
USER-HOMEDIR-PATHNAME: Operating System Definitions
V
VALUES: Special Forms and Functions
VALUES-LIST: Special Forms and Functions
VECTOR: Sequences and Arrays and Hash Tables
VECTOR-POP: Sequences and Arrays and Hash Tables
VECTOR-PUSH: Sequences and Arrays and Hash Tables
VECTOR-PUSH-EXTEND: Sequences and Arrays and Hash Tables
VECTORP: Sequences and Arrays and Hash Tables
VS: System Definitions
W
WARN: User Interface
WHEN: Special Forms and Functions
WHO-CALLS: Compiler Definitions
WITH-INPUT-FROM-STRING: Streams and Reading
WITH-OPEN-FILE: Streams and Reading
WITH-OPEN-STREAM: Streams and Reading
WITH-OUTPUT-TO-STRING: Streams and Reading
WRITE: Streams and Reading
WRITE-BYTE: Streams and Reading
WRITE-CHAR: Streams and Reading
WRITE-DEBUG-SYMBOLS: System Definitions
WRITE-FASD-TOP: System Definitions
WRITE-LINE: Streams and Reading
WRITE-STRING: Streams and Reading
WRITE-TO-STRING: Streams and Reading
X
XDR-OPEN: System Definitions
XDR-READ: System Definitions
XDR-WRITE: System Definitions
Y
Y-OR-N-P: Streams and Reading
YES-OR-NO-P: Iteration and Tests
Z
ZEROP: Numbers
+
Jump to:   * +   ++ +   +- +   +/ +   +1 +   +< +   += +   +> +   +
+A +   +B +   +C +   +D +   +E +   +F +   +G +   +H +   +I +   +K +   +L +   +M +   +N +   +O +   +P +   +Q +   +R +   +S +   +T +   +U +   +V +   +W +   +X +   +Y +   +Z +   +
+ + + + +

Short Table of Contents

+ +
+ +
+ + +

Table of Contents

+ +
+ + +
+ +
+
+

+Previous: , Up: Top   [Contents][Index]

+
+ + + + + diff --git a/info/gcl-si/GCL-Specific.html b/info/gcl-si/GCL-Specific.html new file mode 100644 index 0000000..1d13f83 --- /dev/null +++ b/info/gcl-si/GCL-Specific.html @@ -0,0 +1,385 @@ + + + + +GCL SI Manual: GCL Specific + + + + + + + + + + + + + + + + + + + + +
+

+Next: , Previous: , Up: Top   [Contents][Index]

+
+
+ +

15 GCL Specific

+ +
+
Function: SYSTEM (string)
+

Package:LISP +

+

GCL specific: Executes a Shell command as if STRING is an input to the +Shell. Not all versions of GCL support this function. At least on +POSIX systems, this call should return two integers represeting the +exit status and any possible terminating signal respectively. +

+ +
+ +
+
Variable: *TMP-DIR*
+

Package:COMPILER +GCL specific: Directory in which temporary “gazonk” files used by the +compiler are to be created. +

+ +
+ +
+
Variable: *IGNORE-MAXIMUM-PAGES*
+

Package:SI +GCL specific: Tells the GCL memory manager whether (non-NIL) or not (NIL) it +should expand memory whenever the maximum allocatable pages have been used +up. +

+ +
+ +
+
Variable: *OPTIMIZE-MAXIMUM-PAGES*
+

Package:SI +

+

GCL specific: Tells the GCL memory manager whether to attempt to +adjust the maximum allowable pages for each type to approximately +optimize the garbage collection load in the current process. Defaults +to T. Set to NIL if you care more about memory usage than runtime. +

+ +
+ +
+
Function: MACHINE-VERSION ()
+

Package:LISP +

+

Returns a string that identifies the machine version of the machine +on which GCL is currently running. +

+ +
+ +
+
Function: BY ()
+

Package:LISP +

+

GCL specific: Exits from GCL. +

+ +
+ +
+
Macro: DEFCFUN
+

Package:LISP +

+

Syntax: +

+
(defcfun header n {element}*)
+
+ + +

GCL specific: Defines a C-language function which calls Lisp functions +and/or handles Lisp objects. HEADER gives the header of the C +function as a string. Non-negative-integer is the number of the main +stack entries used by the C function, primarily for protecting Lisp +objects from being garbage-collected. Each ELEMENT may give a C code +fragment as a string, or it may be a list + ((symbol {arg}*) {place}*) +which, when executed, calls the Lisp function named by SYMBOL with the +specified arguments and saves the value(s) to the specified places. +The DEFCFUN form has the above meanings only after compiled; The GCL +interpreter simply ignores this form. +

+

An example which defines a C function list2 of two arguments, but which +calls the ’lisp’ function CONS by name, and refers to the constant ’NIL. +Note to be loaded by load the function should be static. +

+ +

(defCfun "static object list2(x,y) object x,y;" 0 + "object z;" + (’NIL z) + ((CONS y z) z) + ((CONS x z) z) + "return(z);" +) +

+

In lisp the operations in the body would be + (setq z ’nil) + (setq z (cons y z)) + (setq z (cons x z)) +

+ + +

Syntax: +

+
+        (defCfun header non-negative-integer
+                { string
+                  | ( function-symbol { value }* )
+                  | (( function-symbol  { value }* ) { place }* ) })
+
+
+value:
+place:
+         { C-expr | ( C-type C-expr ) }
+
+C-function-name:
+C-expr:
+         { string | symbol }
+ 
+C-type:
+         { object | int | char | float | double }
+
+
+ + + + +
+ +
+
Macro: CLINES
+

Package:LISP +

+

Syntax: +

+
(clines {string}*)
+
+ +

GCL specific: The GCL compiler embeds STRINGs into the intermediate C +language code. The interpreter ignores this form. +

+ +
+ +
+
Function: ALLOCATE (type number &optional (really-allocate nil))
+

Package:LISP +

+

GCL specific: Sets the maximum number of pages for the type class of the +GCL implementation type TYPE to NUMBER. If REALLY-ALLOCATE is given a +non-NIL value, then the specified number of pages will be allocated +immediately. +

+ +
+ +
+
Function: GBC (x)
+

Package:LISP +

+

GCL specific: Invokes the garbage collector (GC) with the collection level +specified by X. NIL as the argument causes GC to collect cells only. T as +the argument causes GC to collect everything. +

+ +
+ +
+
Function: SAVE (pathname)
+

Package:LISP +

+

GCL specific: Saves the current GCL core image into a program file specified +by PATHNAME. This function depends on the version of GCL. The function +si::save-system is to be preferred in almost all circumstances. Unlike +save, it makes the relocatable section permanent, and causes no future gc of +currently loaded .o files. +

+
+ +
+
Function: HELP* (string &optional (package 'lisp))
+

Package:LISP +

+

GCL specific: Prints the documentation associated with those symbols in the +specified 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. +

+ +
+ +
+
Macro: DEFLA
+

Package:LISP +

+

Syntax: +

+
(defla name lambda-list {decl | doc}* {form}*)
+
+ +

GCL specific: Used to DEFine Lisp Alternative. For the interpreter, DEFLA is +equivalent to DEFUN, but the compiler ignores this form. +

+ +
+ +
+
Function: PROCLAMATION (decl-spec)
+

Package:LISP +

+

GCL specific: Returns T if the specified declaration is globally in effect; +NIL otherwise. See the doc of DECLARE for possible DECL-SPECs. +

+ +
+ +
+
Macro: DEFENTRY
+

Package:LISP +

+

Syntax: +

+
(defentry name arg-types c-function)
+
+ + +

GCL specific: The compiler defines a Lisp function whose body consists of a +calling sequence to the C language function specified by C-FUNCTION. The +interpreter ignores this form. The ARG-TYPES specifies the C types of the +arguments which C-FUNCTION requires. The list of allowed types is (object +char int float double string). Code will be produced to coerce from a lisp +object to the appropriate type before passing the argument to the C-FUNCTION. +The c-function should be of the form (c-result-type c-fname) where +c-result-type is a member of (void object char int float double string). +c-fname may be a symbol (in which case it will be downcased) or a string. If +c-function is not a list, then (object c-function) is assumed. In order +for C code to be loaded in by load you should declare any +variables and functions to be static. If you will link them in +at build time, of course you are allowed to define new externals. +

+
+
  Sample usage:
+--File begin-----
+;; JOE takes X a lisp string and Y a fixnum and returns a character.
+(clines "#include \"foo.ch\"")
+(defentry joe (string int) (char "our_c_fun"))
+---File end------
+---File foo.ch---
+/* C function for extracting the i'th element of a string */
+static char our_c_fun(p,i)
+char *p;
+int i;
+   {
+	return p[i];
+   }
+-----File end---
+
+ +

One must be careful of storage allocation issues when passing a string. +If the C code invokes storage allocation (either by calling malloc +or make_cons etc), then there is a possibility of a garbage +collection, so that if the string passed was not constructed with +:static t when its array was constructed, then it could move. +If the C function may allocate storage, then you should pass a copy: +

+
(defun safe-c-string (x)
+  (let* ((n (length x))
+         (a (make-array (+ n 1) :element-type 'string-char
+           :static t :fill-pointer n)))
+    (si::copy-array-portion x y 0 0 n)
+    (setf (aref a n) (code-char 0)))
+    a)
+
+
+ + +
+
+
Function: COPY-ARRAY-PORTION (x,y,i1,i2,n1)
+

Package:SI +Copy elements from X to Y starting at X[i1] to Y[i2] and doing N1 +elements if N1 is supplied otherwise, doing the length of X - I1 +elements. If the types of the arrays are not the same, this has +implementation dependent results. +

+ +
+
Function: BYE ( &optional (exit-status 0))
+

Package:LISP +

+

GCL specific: Exits from GCL with exit-status. +

+ +
+ +
+
Function: USE-FAST-LINKS (turn-on)
+

Package:LISP +

+

GCL specific: If TURN-ON is not nil, the fast link mechanism is enabled, +so that ordinary function calls will not appear in the invocation stack, +and calls will be much faster. This is the default. If you anticipate +needing to see a stack trace in the debugger, then you should turn this +off. +

+ +
+ + + +
• Bignums:   +
+ +
+
+

+Next: , Previous: , Up: Top   [Contents][Index]

+
+ + + + + diff --git a/info/gcl-si/Inititialization.html b/info/gcl-si/Inititialization.html new file mode 100644 index 0000000..a49b6db --- /dev/null +++ b/info/gcl-si/Inititialization.html @@ -0,0 +1,72 @@ + + + + +GCL SI Manual: Inititialization + + + + + + + + + + + + + + + + + + + + +
+

+Next: , Previous: , Up: Miscellaneous   [Contents][Index]

+
+
+ +

19.2 Initialization

+ +

If the file init.lsp exists in the current directory, it is +loaded at startup. The first argument passed to the executable image +should be the system directory. Normally this would be gcl/unixport. +This directory is stored in the si::*system-directory* variable. If +the file sys-init.lsp exists in the system directory, it is loaded +before init.lsp. See also si::*TOP-LEVEL-HOOK*. +

+ + + + + diff --git a/info/gcl-si/Iteration-and-Tests.html b/info/gcl-si/Iteration-and-Tests.html new file mode 100644 index 0000000..ffebc88 --- /dev/null +++ b/info/gcl-si/Iteration-and-Tests.html @@ -0,0 +1,229 @@ + + + + +GCL SI Manual: Iteration and Tests + + + + + + + + + + + + + + + + + + + + +
+

+Next: , Previous: , Up: Top   [Contents][Index]

+
+
+ +

11 Iteration and Tests

+ +
+
Macro: DO-EXTERNAL-SYMBOLS
+

Package:LISP +

+

Syntax: +

+
(do-external-symbols (var [package [result-form]])
+          {decl}* {tag | statement}*)
+
+ +

Executes STATEMENTs once for each external symbol in the PACKAGE (which +defaults to the current package), with VAR bound to the current symbol. +Then evaluates RESULT-FORM (which defaults to NIL) and returns the value(s). +

+ +
+ +
+
Special Form: DO*
+

Package:LISP +

+

Syntax: +

+
(do* ({(var [init [step]])}*) (endtest {result}*)
+          {decl}* {tag | statement}*)
+
+ +

Just like DO, but performs variable bindings and assignments in serial, just +like LET* and SETQ do. +

+ +
+ +
+
Macro: DO-ALL-SYMBOLS
+

Package:LISP +

+

Syntax: +

+
(do-all-symbols (var [result-form]) {decl}* {tag | statement}*)
+
+ +

Executes STATEMENTs once for each symbol in each package, with VAR bound to +the current symbol. Then evaluates RESULT-FORM (which defaults to NIL) and +returns the value(s). +

+ +
+ +
+
Function: YES-OR-NO-P (&optional (format-string nil) &rest args)
+

Package:LISP +

+

Asks the user a question whose answer is either ’YES’ or ’NO’. If FORMAT- +STRING is non-NIL, then FRESH-LINE operation is performed, a message is +printed as if FORMAT-STRING and ARGs were given to FORMAT, and then a prompt +"(Yes or No)" is printed. Otherwise, no prompt will appear. +

+ +
+ +
+
Function: MAPHASH #'hash-table
+

Package:LISP +

+

For each entry in HASH-TABLE, calls FUNCTION on the key and value of the +entry; returns NIL. +

+ +
+ +
+
Function: MAPCAR (fun list &rest more-lists)
+

Package:LISP +

+

Applies FUN to successive cars of LISTs and returns the results as a list. +

+ +
+ +
+
Special Form: DOLIST
+

Package:LISP +

+

Syntax: +

+
(dolist (var listform [result]) {decl}* {tag | statement}*)
+
+ +

Executes STATEMENTs, with VAR bound to each member of the list value of +LISTFORM. Then returns the value(s) of RESULT (which defaults to NIL). +

+ +
+ +
+
Function: EQ (x y)
+

Package:LISP +

+

Returns T if X and Y are the same identical object; NIL otherwise. +

+ +
+ +
+
Function: EQUALP (x y)
+

Package:LISP +

+

Returns T if X and Y are EQUAL, if they are characters and satisfy CHAR-EQUAL, +if they are numbers and have the same numerical value, or if they have +components that are all EQUALP. Returns NIL otherwise. +

+ +
+ +
+
Function: EQUAL (x y)
+

Package:LISP +

+

Returns T if X and Y are EQL or if they are of the same type and corresponding +components are EQUAL. Returns NIL otherwise. Strings and bit-vectors are +EQUAL if they are the same length and have identical components. Other +arrays must be EQ to be EQUAL. +

+ +
+ +
+
Macro: DO-SYMBOLS
+

Package:LISP +

+

Syntax: +

+
(do-symbols (var [package [result-form]]) {decl}* {tag |
+statement}*)
+
+ +

Executes STATEMENTs once for each symbol in the PACKAGE (which defaults to +the current package), with VAR bound to the current symbol. Then evaluates +RESULT-FORM (which defaults to NIL) and returns the value(s). +

+ +
+ +
+
Special Form: LOOP
+

Package:LISP +

+

Syntax: +

+
(loop {form}*)
+
+ +

Executes FORMs repeatedly until exited by a THROW or RETURN. The FORMs are +surrounded by an implicit NIL block. +

+ +
+ +
+
+

+Next: , Previous: , Up: Top   [Contents][Index]

+
+ + + + + diff --git a/info/gcl-si/Lists.html b/info/gcl-si/Lists.html new file mode 100644 index 0000000..12ebe09 --- /dev/null +++ b/info/gcl-si/Lists.html @@ -0,0 +1,1075 @@ + + + + +GCL SI Manual: Lists + + + + + + + + + + + + + + + + + + + + +
+

+Next: , Previous: , Up: Top   [Contents][Index]

+
+
+ +

4 Lists

+ +
+
Function: NINTERSECTION (list1 list2 &key (test #'eql) test-not (key #'identity))
+

Package:LISP +

+

Returns the intersection of LIST1 and LIST2. LIST1 may be destroyed. +

+ +
+ +
+
Function: RASSOC-IF (predicate alist)
+

Package:LISP +

+

Returns the first cons in ALIST whose cdr satisfies PREDICATE. +

+ +
+ +
+
Function: MAKE-LIST (size &key (initial-element nil))
+

Package:LISP +

+

Creates and returns a list containing SIZE elements, each of which is +initialized to INITIAL-ELEMENT. +

+ +
+ +
+
Function: NTH (n list)
+

Package:LISP +

+

Returns the N-th element of LIST, where the car of LIST is the zeroth +element. +

+ +
+ +
+
Function: CAAR (x)
+

Package:LISP +

+

Equivalent to (CAR (CAR X)). +

+ +
+ +
+
Function: NULL (x)
+

Package:LISP +

+

Returns T if X is NIL; NIL otherwise. +

+ +
+ +
+
Function: FIFTH (x)
+

Package:LISP +

+

Equivalent to (CAR (CDDDDR X)). +

+ +
+ +
+
Function: NCONC (&rest lists)
+

Package:LISP +

+

Concatenates LISTs by destructively modifying them. +

+ +
+ +
+
Function: TAILP (sublist list)
+

Package:LISP +

+

Returns T if SUBLIST is one of the conses in LIST; NIL otherwise. +

+ +
+ +
+
Function: CONSP (x)
+

Package:LISP +

+

Returns T if X is a cons; NIL otherwise. +

+ +
+ +
+
Function: TENTH (x)
+

Package:LISP +

+

Equivalent to (CADR (CDDDDR (CDDDDR X))). +

+ +
+ +
+
Function: LISTP (x)
+

Package:LISP +

+

Returns T if X is either a cons or NIL; NIL otherwise. +

+ +
+ +
+
Function: MAPCAN (fun list &rest more-lists)
+

Package:LISP +

+

Applies FUN to successive cars of LISTs, NCONCs the results, and returns it. +

+ +
+ +
+
Function: EIGHTH (x)
+

Package:LISP +

+

Equivalent to (CADDDR (CDDDDR X)). +

+ +
+ +
+
Function: LENGTH (sequence)
+

Package:LISP +

+

Returns the length of SEQUENCE. +

+ +
+ +
+
Function: RASSOC (item alist &key (test #'eql) test-not (key #'identity))
+

Package:LISP +

+

Returns the first cons in ALIST whose cdr is equal to ITEM. +

+ +
+ +
+
Function: NSUBST-IF-NOT (new test tree &key (key #'identity))
+

Package:LISP +

+

Substitutes NEW for subtrees of TREE that do not satisfy TEST. +

+ +
+ +
+
Function: NBUTLAST (list &optional (n 1))
+

Package:LISP +

+

Changes the cdr of the N+1 th cons from the end of the list LIST to NIL. +Returns the whole list. +

+ +
+ + + +
+
Function: CDR (list)
+

Package:LISP +

+

Returns the cdr of LIST. Returns NIL if LIST is NIL. +

+ +
+ +
+
Function: MAPC (fun list &rest more-lists)
+

Package:LISP +

+

Applies FUN to successive cars of LISTs. Returns the first LIST. +

+ +
+ +
+
Function: MAPL (fun list &rest more-lists)
+

Package:LISP +

+

Applies FUN to successive cdrs of LISTs. Returns the first LIST. +

+ +
+ +
+
Function: CONS (x y)
+

Package:LISP +

+

Returns a new cons whose car and cdr are X and Y, respectively. +

+ +
+ +
+
Function: LIST (&rest args)
+

Package:LISP +

+

Returns a list of its arguments +

+ +
+ + +
+
Function: THIRD (x)
+

Package:LISP +

+

Equivalent to (CADDR X). +

+ +
+ +
+
Function: CDDAAR (x)
+

Package:LISP +

+

Equivalent to (CDR (CDR (CAR (CAR X)))). +

+ +
+ +
+
Function: CDADAR (x)
+

Package:LISP +

+

Equivalent to (CDR (CAR (CDR (CAR X)))). +

+ +
+ +
+
Function: CDAADR (x)
+

Package:LISP +

+

Equivalent to (CDR (CAR (CAR (CDR X)))). +

+ +
+ +
+
Function: CADDAR (x)
+

Package:LISP +

+

Equivalent to (CAR (CDR (CDR (CAR X)))). +

+ +
+ +
+
Function: CADADR (x)
+

Package:LISP +

+

Equivalent to (CAR (CDR (CAR (CDR X)))). +

+ +
+ +
+
Function: CAADDR (x)
+

Package:LISP +

+

Equivalent to (CAR (CAR (CDR (CDR X)))). +

+ +
+ +
+
Function: NTHCDR (n list)
+

Package:LISP +

+

Returns the result of performing the CDR operation N times on LIST. +

+ +
+ +
+
Function: PAIRLIS (keys data &optional (alist nil))
+

Package:LISP +

+

Constructs an association list from KEYS and DATA adding to ALIST. +

+ +
+ +
+
Function: SEVENTH (x)
+

Package:LISP +

+

Equivalent to (CADDR (CDDDDR X)). +

+ +
+ +
+
Function: SUBSETP (list1 list2 &key (test #'eql) test-not (key #'identity))
+

Package:LISP +

+

Returns T if every element of LIST1 appears in LIST2; NIL otherwise. +

+ +
+ +
+
Function: NSUBST-IF (new test tree &key (key #'identity))
+

Package:LISP +

+

Substitutes NEW for subtrees of TREE that satisfy TEST. +

+ +
+ +
+
Function: COPY-LIST (list)
+

Package:LISP +

+

Returns a new copy of LIST. +

+ +
+ +
+
Function: LAST (list)
+

Package:LISP +

+

Returns the last cons in LIST +

+ +
+ +
+
Function: CAAAR (x)
+

Package:LISP +

+

Equivalent to (CAR (CAR (CAR X))). +

+ +
+ +
+
Function: LIST-LENGTH (list)
+

Package:LISP +

+

Returns the length of LIST, or NIL if LIST is circular. +

+ +
+ +
+
Function: CDDDR (x)
+

Package:LISP +

+

Equivalent to (CDR (CDR (CDR X))). +

+ +
+ +
+
Function: INTERSECTION (list1 list2 &key (test #'eql) test-not (key #'identity))
+

Package:LISP +

+

Returns the intersection of List1 and List2. +

+ +
+ +
+
Function: NSUBST (new old tree &key (test #'eql) test-not (key #'identity))
+

Package:LISP +

+

Substitutes NEW for subtrees in TREE that match OLD. +

+ +
+ +
+
Function: REVAPPEND (x y)
+

Package:LISP +

+

Equivalent to (APPEND (REVERSE X) Y) +

+ +
+ +
+
Function: CDAR (x)
+

Package:LISP +

+

Equivalent to (CDR (CAR X)). +

+ +
+ +
+
Function: CADR (x)
+

Package:LISP +

+

Equivalent to (CAR (CDR X)). +

+ +
+ +
+
Function: REST (x)
+

Package:LISP +

+

Equivalent to (CDR X). +

+ +
+ +
+
Function: NSET-EXCLUSIVE-OR (list1 list2 &key (test #'eql) test-not (key #'identity))
+

Package:LISP +

+

Returns a list with elements which appear but once in LIST1 and LIST2. +

+ +
+ +
+
Function: ACONS (key datum alist)
+

Package:LISP +

+

Constructs a new alist by adding the pair (KEY . DATUM) to ALIST. +

+ +
+ +
+
Function: SUBST-IF-NOT (new test tree &key (key #'identity))
+

Package:LISP +

+

Substitutes NEW for subtrees of TREE that do not satisfy TEST. +

+ +
+ +
+
Function: RPLACA (x y)
+

Package:LISP +

+

Replaces the car of X with Y, and returns the modified X. +

+ +
+ +
+
Function: SECOND (x)
+

Package:LISP +

+

Equivalent to (CADR X). +

+ +
+ +
+
Function: NUNION (list1 list2 &key (test #'eql) test-not (key #'identity))
+

Package:LISP +

+

Returns the union of LIST1 and LIST2. LIST1 and/or LIST2 may be destroyed. +

+ +
+ +
+
Function: BUTLAST (list &optional (n 1))
+

Package:LISP +

+

Creates and returns a list with the same elements as LIST but without the +last N elements. +

+ +
+ +
+
Function: COPY-ALIST (alist)
+

Package:LISP + Returns a new copy of ALIST. +

+ +
+ +
+
Function: SIXTH (x)
+

Package:LISP + Equivalent to (CADR (CDDDDR X)). +

+ +
+ +
+
Function: CAAAAR (x)
+

Package:LISP +

+

Equivalent to (CAR (CAR (CAR (CAR X)))). +

+ +
+ +
+
Function: CDDDAR (x)
+

Package:LISP +

+

Equivalent to (CDR (CDR (CDR (CAR X)))). +

+ +
+ +
+
Function: CDDADR (x)
+

Package:LISP +

+

Equivalent to (CDR (CDR (CAR (CDR X)))). +

+ +
+ +
+
Function: CDADDR (x)
+

Package:LISP +

+

Equivalent to (CDR (CAR (CDR (CDR X)))). +

+ +
+ +
+
Function: CADDDR (x)
+

Package:LISP +

+

Equivalent to (CAR (CDR (CDR (CDR X)))). +

+ +
+ +
+
Function: FOURTH (x)
+

Package:LISP +

+

Equivalent to (CADDDR X). +

+ +
+ +
+
Function: NSUBLIS (alist tree &key (test #'eql) test-not (key #'identity))
+

Package:LISP +

+

Substitutes from ALIST for subtrees of TREE. +

+ +
+ +
+
Function: SUBST-IF (new test tree &key (key #'identity))
+

Package:LISP +

+

Substitutes NEW for subtrees of TREE that satisfy TEST. +

+ +
+ +
+
Function: NSET-DIFFERENCE (list1 list2 &key (test #'eql) test-not (key #'identity))
+

Package:LISP +

+

Returns a list of elements of LIST1 that do not appear in LIST2. LIST1 may +be destroyed. +

+ +
+ +
+
Special Form: POP
+

Package:LISP +

+

Syntax: +

+
(pop place)
+
+ +

Pops one item off the front of the list in PLACE and returns it. +

+ +
+ +
+
Special Form: PUSH
+

Package:LISP +

+

Syntax: +

+
(push item place)
+
+ +

Conses ITEM onto the list in PLACE, and returns the new list. +

+ +
+ +
+
Function: CDAAR (x)
+

Package:LISP +

+

Equivalent to (CDR (CAR (CAR X))). +

+ +
+ +
+
Function: CADAR (x)
+

Package:LISP +

+

Equivalent to (CAR (CDR (CAR X))). +

+ +
+ +
+
Function: CAADR (x)
+

Package:LISP +

+

Equivalent to (CAR (CAR (CDR X))). +

+ +
+ +
+
Function: FIRST (x)
+

Package:LISP +

+

Equivalent to (CAR X). +

+ +
+ +
+
Function: SUBST (new old tree &key (test #'eql) test-not (key #'identity))
+

Package:LISP +

+

Substitutes NEW for subtrees of TREE that match OLD. +

+ +
+ +
+
Function: ADJOIN (item list &key (test #'eql) test-not (key #'identity))
+

Package:LISP +

+

Adds ITEM to LIST unless ITEM is already a member of LIST. +

+ +
+ +
+
Function: MAPCON (fun list &rest more-lists)
+

Package:LISP +

+

Applies FUN to successive cdrs of LISTs, NCONCs the results, and returns it. +

+ +
+ +
+
Macro: PUSHNEW
+

Package:LISP +

+

Syntax: +

+
(pushnew item place {keyword value}*)
+
+ +

If ITEM is already in the list stored in PLACE, does nothing. Else, conses +ITEM onto the list. Returns NIL. If no KEYWORDs are supplied, each element +in the list is compared with ITEM by EQL, but the comparison can be controlled +by supplying keywords :TEST, :TEST-NOT, and/or :KEY. +

+ +
+ +
+
Function: SET-EXCLUSIVE-OR (list1 list2 &key (test #'eql) test-not (key #'identity))
+

Package:LISP +

+

Returns a list of elements appearing exactly once in LIST1 and LIST2. +

+ +
+ +
+
Function: TREE-EQUAL (x y &key (test #'eql) test-not)
+

Package:LISP +

+

Returns T if X and Y are isomorphic trees with identical leaves. +

+ +
+ +
+
Function: CDDR (x)
+

Package:LISP +

+

Equivalent to (CDR (CDR X)). +

+ +
+ +
+
Function: GETF (place indicator &optional (default nil))
+

Package:LISP +

+

Searches the property list stored in Place for an indicator EQ to Indicator. +If one is found, the corresponding value is returned, else the Default is +returned. +

+ +
+ +
+
Function: LDIFF (list sublist)
+

Package:LISP +

+

Returns a new list, whose elements are those of LIST that appear before +SUBLIST. If SUBLIST is not a tail of LIST, a copy of LIST is returned. +

+ +
+ +
+
Function: UNION (list1 list2 &key (test #'eql) test-not (key #'identity))
+

Package:LISP +

+

Returns the union of LIST1 and LIST2. +

+ +
+ +
+
Function: ASSOC-IF-NOT (test alist)
+

Package:LISP +

+

Returns the first pair in ALIST whose car does not satisfy TEST. +

+ +
+ +
+
Function: RPLACD (x y)
+

Package:LISP +

+

Replaces the cdr of X with Y, and returns the modified X. +

+ +
+ +
+
Function: MEMBER-IF-NOT (test list &key (key #'identity))
+

Package:LISP +

+

Returns the tail of LIST beginning with the first element not satisfying +TEST. +

+ +
+ +
+
Function: CAR (list)
+

Package:LISP +

+

Returns the car of LIST. Returns NIL if LIST is NIL. +

+ +
+ +
+
Function: ENDP (x)
+

Package:LISP +

+

Returns T if X is NIL. Returns NIL if X is a cons. Otherwise, signals an +error. +

+ +
+ +
+
Function: LIST* (arg &rest others)
+

Package:LISP +

+

Returns a list of its arguments with the last cons being a dotted pair of +the next to the last argument and the last argument. +

+ +
+ +
+
Function: NINTH (x)
+

Package:LISP +

+

Equivalent to (CAR (CDDDDR (CDDDDR X))). +

+ +
+ +
+
Function: CDAAAR (x)
+

Package:LISP +

+

Equivalent to (CDR (CAR (CAR (CAR X)))). +

+ +
+ +
+
Function: CADAAR (x)
+

Package:LISP +

+

Equivalent to (CAR (CDR (CAR (CAR X)))). +

+ +
+ +
+
Function: CAADAR (x)
+

Package:LISP +

+

Equivalent to (CAR (CAR (CDR (CAR X)))). +

+ +
+ +
+
Function: CAAADR (x)
+

Package:LISP +

+

Equivalent to (CAR (CAR (CAR (CDR X)))). +

+ +
+ +
+
Function: CDDDDR (x)
+

Package:LISP +

+

Equivalent to (CDR (CDR (CDR (CDR X)))). +

+ +
+ +
+
Function: SUBLIS (alist tree &key (test #'eql) test-not (key #'identity))
+

Package:LISP +

+

Substitutes from ALIST for subtrees of TREE nondestructively. +

+ +
+ +
+
Function: RASSOC-IF-NOT (predicate alist)
+

Package:LISP +

+

Returns the first cons in ALIST whose cdr does not satisfy PREDICATE. +

+ +
+ +
+
Function: NRECONC (x y)
+

Package:LISP +

+

Equivalent to (NCONC (NREVERSE X) Y). +

+ +
+ +
+
Function: MAPLIST (fun list &rest more-lists)
+

Package:LISP +

+

Applies FUN to successive cdrs of LISTs and returns the results as a list. +

+ +
+ +
+
Function: SET-DIFFERENCE (list1 list2 &key (test #'eql) test-not (key #'identity))
+

Package:LISP +

+

Returns a list of elements of LIST1 that do not appear in LIST2. +

+ +
+ +
+
Function: ASSOC-IF (test alist)
+

Package:LISP +

+

Returns the first pair in ALIST whose car satisfies TEST. +

+ +
+ +
+
Function: GET-PROPERTIES (place indicator-list)
+

Package:LISP +

+

Looks for the elements of INDICATOR-LIST in the property list stored in PLACE. +If found, returns the indicator, the value, and T as multiple-values. If not, +returns NILs as its three values. +

+ +
+ +
+
Function: MEMBER-IF (test list &key (key #'identity))
+

Package:LISP +

+

Returns the tail of LIST beginning with the first element satisfying TEST. +

+ +
+ +
+
Function: COPY-TREE (object)
+

Package:LISP +

+

Recursively copies conses in OBJECT and returns the result. +

+ +
+ +
+
Function: ATOM (x)
+

Package:LISP +

+

Returns T if X is not a cons; NIL otherwise. +

+ +
+ +
+
Function: CDDAR (x)
+

Package:LISP +

+

Equivalent to (CDR (CDR (CAR X))). +

+ +
+ +
+
Function: CDADR (x)
+

Package:LISP +

+

Equivalent to (CDR (CAR (CDR X))). +

+ +
+ +
+
Function: CADDR (x)
+

Package:LISP +

+

Equivalent to (CAR (CDR (CDR X))). +

+ +
+ +
+
Function: ASSOC (item alist &key (test #'eql) test-not)
+

Package:LISP +

+

Returns the first pair in ALIST whose car is equal (in the sense of TEST) to +ITEM. +

+ +
+ +
+
Function: APPEND (&rest lists)
+

Package:LISP +

+

Constructs a new list by concatenating its arguments. +

+ +
+ +
+
Function: MEMBER (item list &key (test #'eql) test-not (key #'identity))
+

Package:LISP +

+

Returns the tail of LIST beginning with the first ITEM. +

+ +
+ +
+
+

+Next: , Previous: , Up: Top   [Contents][Index]

+
+ + + + + diff --git a/info/gcl-si/Low-Level-Debug-Functions.html b/info/gcl-si/Low-Level-Debug-Functions.html new file mode 100644 index 0000000..a2aae36 --- /dev/null +++ b/info/gcl-si/Low-Level-Debug-Functions.html @@ -0,0 +1,84 @@ + + + + +GCL SI Manual: Low Level Debug Functions + + + + + + + + + + + + + + + + + + + + +
+

+Previous: , Up: Debugging   [Contents][Index]

+
+
+ +

18.2 Low Level Debug Functions

+ +

Use the following functions to directly access GCL stacks. +

+
(SI:VS i)	Returns the i-th entity in VS.
+(SI:IHS-VS i)	Returns the VS index of the i-th entity in IHS.
+(SI:IHS-FUN i)	Returns the function of the i-th entity in IHS.
+(SI:FRS-VS i)	Returns the VS index of the i-th entity in FRS.
+(SI:FRS-BDS i)	Returns the BDS index of the i-th entity in FRS.
+(SI:FRS-IHS i)	Returns the IHS index of the i-th entity in FRS.
+(SI:BDS-VAR i)	Returns the symbol of the i-th entity in BDS.
+(SI:BDS-VAL i)	Returns the value of the i-th entity in BDS.
+
+(SI:SUPER-GO i tag)
+	Jumps to the specified tag established by the TAGBODY frame at
+	FRS[i].  Both arguments are evaluated.  If FRS[i] happens to be
+	a non-TAGBODY frame, then (THROW (SI:IHS-TAG i) (VALUES)) is
+	performed.
+
+ + + + + + + diff --git a/info/gcl-si/Low-Level-X-Interface.html b/info/gcl-si/Low-Level-X-Interface.html new file mode 100644 index 0000000..3742467 --- /dev/null +++ b/info/gcl-si/Low-Level-X-Interface.html @@ -0,0 +1,79 @@ + + + + +GCL SI Manual: Low Level X Interface + + + + + + + + + + + + + + + + + + + + +
+

+Previous: , Up: Miscellaneous   [Contents][Index]

+
+
+ +

19.3 Low Level X Interface

+ +

A sample program for drawing things on X windows from lisp +is included in the file gcl/lsp/littleXlsp.lsp +

+

That routine invokes the corresponding C routines in XLIB. +So in order to use it you must ‘faslink’ in the X routines. +Directions are given at the beginning of the lisp file, +for either building them into the image or using faslink. +

+

This program is also a good tutorial on invoking C from lisp. +

+

See also defentry and faslink. +

+ + + + + + + diff --git a/info/gcl-si/Miscellaneous.html b/info/gcl-si/Miscellaneous.html new file mode 100644 index 0000000..910e0ed --- /dev/null +++ b/info/gcl-si/Miscellaneous.html @@ -0,0 +1,74 @@ + + + + +GCL SI Manual: Miscellaneous + + + + + + + + + + + + + + + + + + + + +
+

+Next: , Previous: , Up: Top   [Contents][Index]

+
+
+ +

19 Miscellaneous

+ + + + + +
• Environment:   +
• Inititialization:   +
• Low Level X Interface:   +
+ + + + + + diff --git a/info/gcl-si/Numbers.html b/info/gcl-si/Numbers.html new file mode 100644 index 0000000..4367297 --- /dev/null +++ b/info/gcl-si/Numbers.html @@ -0,0 +1,1560 @@ + + + + +GCL SI Manual: Numbers + + + + + + + + + + + + + + + + + + + + +
+

+Next: , Previous: , Up: Top   [Contents][Index]

+
+
+ +

1 Numbers

+ + +
+
Function: SIGNUM (number)
+

Package:LISP +

+

If NUMBER is zero, returns NUMBER; else returns (/ NUMBER (ABS NUMBER)). +

+ +
+ +
+
Function: LOGNOT (integer)
+

Package:LISP +

+

Returns the bit-wise logical NOT of INTEGER. +

+ +
+ +
+
Constant: MOST-POSITIVE-SHORT-FLOAT
+

Package:LISP +The short-float closest in value to positive infinity. +

+ +
+ +
+
Function: INTEGER-DECODE-FLOAT (float)
+

Package:LISP +

+

Returns, as three values, the integer interpretation of significand F, +the exponent E, and the sign S of the given float, so that + E + FLOAT = S * F * B where B = (FLOAT-RADIX FLOAT) +

+

F is a non-negative integer, E is an integer, and S is either 1 or -1. +

+ +
+ +
+
Function: MINUSP (number)
+

Package:LISP +

+

Returns T if NUMBER < 0; NIL otherwise. +

+ +
+ +
+
Function: LOGORC1 (integer1 integer2)
+

Package:LISP +

+

Returns the logical OR of (LOGNOT INTEGER1) and INTEGER2. +

+ +
+ +
+
Constant: MOST-NEGATIVE-SINGLE-FLOAT
+

Package:LISP +Same as MOST-NEGATIVE-LONG-FLOAT. +

+ +
+ +
+
Constant: BOOLE-C1
+

Package:LISP +Makes BOOLE return the complement of INTEGER1. +

+ +
+ +
+
Constant: LEAST-POSITIVE-SHORT-FLOAT
+

Package:LISP +The positive short-float closest in value to zero. +

+ +
+ +
+
Function: BIT-NAND (bit-array1 bit-array2 &optional (result-bit-array nil))
+

Package:LISP +

+

Performs a bit-wise logical NAND on the elements of BIT-ARRAY1 and +BIT-ARRAY2. +Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into +BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. +

+
+ +
+
Function: INT-CHAR (integer)
+

Package:LISP +

+

Performs the inverse of CHAR-INT. Equivalent to CODE-CHAR in GCL. +

+ +
+ +
+
Function: CHAR-INT (char)
+

Package:LISP +

+

Returns the font, bits, and code attributes as a single non-negative integer. +Equivalent to CHAR-CODE in GCL. +

+ +
+ +
+
Constant: LEAST-NEGATIVE-SINGLE-FLOAT
+

Package:LISP +Same as LEAST-NEGATIVE-LONG-FLOAT. +

+ +
+ +
+
Function: /= (number &rest more-numbers)
+

Package:LISP +

+

Returns T if no two of its arguments are numerically equal; NIL otherwise. +

+ +
+ +
+
Function: LDB-TEST (bytespec integer)
+

Package:LISP +

+

Returns T if at least one of the bits in the specified bytes of INTEGER is 1; +NIL otherwise. +

+ +
+ +
+
Constant: CHAR-CODE-LIMIT
+

Package:LISP +The upper exclusive bound on values produced by CHAR-CODE. +

+ +
+ +
+
Function: RATIONAL (number)
+

Package:LISP +

+

Converts NUMBER into rational accurately and returns it. +

+ +
+ +
+
Constant: PI
+

Package:LISP +The floating-point number that is appropriately equal to the ratio of the +circumference of the circle to the diameter. +

+ +
+ +
+
Function: SIN (radians)
+

Package:LISP +

+

Returns the sine of RADIANS. +

+ +
+ +
+
Constant: BOOLE-ORC2
+

Package:LISP +Makes BOOLE return LOGORC2 of INTEGER1 and INTEGER2. +

+ +
+ +
+
Function: NUMERATOR (rational)
+

Package:LISP +

+

Returns as an integer the numerator of the given rational number. +

+ +
+ +
+
Function: MASK-FIELD (bytespec integer)
+

Package:LISP +

+

Extracts the specified byte from INTEGER. +

+ +
+ +
+
Special Form: INCF
+

Package:LISP +

+

Syntax: +

+
(incf place [delta])
+
+ +

Adds the number produced by DELTA (which defaults to 1) to the number +in PLACE. +

+ +
+ +
+
Function: SINH (number)
+

Package:LISP +

+

Returns the hyperbolic sine of NUMBER. +

+ +
+ +
+
Function: PHASE (number)
+

Package:LISP +

+

Returns the angle part of the polar representation of a complex number. +For non-complex numbers, this is 0. +

+ +
+ +
+
Function: BOOLE (op integer1 integer2)
+

Package:LISP +

+

Returns an integer produced by performing 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 +See the variable docs of these constants for their operations. +

+ +
+ +
+
Constant: SHORT-FLOAT-EPSILON
+

Package:LISP +The smallest positive short-float that satisfies + (not (= (float 1 e) (+ (float 1 e) e))). +

+ +
+ +
+
Function: LOGORC2 (integer1 integer2)
+

Package:LISP +

+

Returns the logical OR of INTEGER1 and (LOGNOT INTEGER2). +

+ +
+ +
+
Constant: BOOLE-C2
+

Package:LISP +Makes BOOLE return the complement of INTEGER2. +

+ +
+ +
+
Function: REALPART (number)
+

Package:LISP +

+

Extracts the real part of NUMBER. +

+ +
+ + +
+
Constant: BOOLE-CLR
+

Package:LISP +Makes BOOLE return 0. +

+ +
+ +
+
Constant: BOOLE-IOR
+

Package:LISP +Makes BOOLE return LOGIOR of INTEGER1 and INTEGER2. +

+ +
+ +
+
Function: FTRUNCATE (number &optional (divisor 1))
+

Package:LISP +

+

Values: (quotient remainder) +Same as TRUNCATE, but returns first value as a float. +

+ +
+ +
+
Function: EQL (x y)
+

Package:LISP +

+

Returns T if X and Y are EQ, or if they are numbers of the same type with +the same value, or if they are character objects that represent the same +character. Returns NIL otherwise. +

+ +
+ +
+
Function: LOG (number &optional base)
+

Package:LISP +

+

Returns the logarithm of NUMBER in the base BASE. BASE defaults to the base +of natural logarithms. +

+ +
+ +
+
Constant: DOUBLE-FLOAT-NEGATIVE-EPSILON
+

Package:LISP +Same as LONG-FLOAT-NEGATIVE-EPSILON. +

+ +
+ +
+
Function: LOGIOR (&rest integers)
+

Package:LISP +

+

Returns the bit-wise INCLUSIVE OR of its arguments. +

+ +
+ +
+
Constant: MOST-NEGATIVE-DOUBLE-FLOAT
+

Package:LISP +Same as MOST-NEGATIVE-LONG-FLOAT. +

+ +
+ +
+
Function: / (number &rest more-numbers)
+

Package:LISP +

+

Divides the first NUMBER by each of the subsequent NUMBERS. +With one arg, returns the reciprocal of the number. +

+ +
+ +
+
Variable: *RANDOM-STATE*
+

Package:LISP +The default random-state object used by RAMDOM. +

+ +
+ +
+
Function: 1+ (number)
+

Package:LISP +

+

Returns NUMBER + 1. +

+ +
+ +
+
Constant: LEAST-NEGATIVE-DOUBLE-FLOAT
+

Package:LISP +Same as LEAST-NEGATIVE-LONG-FLOAT. +

+ +
+ +
+
Function: FCEILING (number &optional (divisor 1))
+

Package:LISP +

+

Same as CEILING, but returns a float as the first value. +

+ +
+ +
+
Constant: MOST-POSITIVE-FIXNUM
+

Package:LISP +The fixnum closest in value to positive infinity. +

+ +
+ +
+
Function: BIT-ANDC1 (bit-array1 bit-array2 &optional (result-bit-array nil))
+

Package:LISP +

+

Performs a bit-wise logical ANDC1 on the elements of BIT-ARRAY1 and +BIT-ARRAY2. +Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into +BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. +

+ +
+ +
+
Function: TAN (radians)
+

Package:LISP +

+

Returns the tangent of RADIANS. +

+ +
+ +
+
Constant: BOOLE-NAND
+

Package:LISP +Makes BOOLE return LOGNAND of INTEGER1 and INTEGER2. +

+ +
+ +
+
Function: TANH (number)
+

Package:LISP +

+

Returns the hyperbolic tangent of NUMBER. +

+ +
+ +
+
Function: ASIN (number)
+

Package:LISP +

+

Returns the arc sine of NUMBER. +

+ +
+ +
+
Function: BYTE (size position)
+

Package:LISP +

+

Returns a byte specifier. In GCL, a byte specifier is represented by +a dotted pair (<size> . <position>). +

+ +
+ +
+
Function: ASINH (number)
+

Package:LISP +

+

Returns the hyperbolic arc sine of NUMBER. +

+ +
+ +
+
Constant: MOST-POSITIVE-LONG-FLOAT
+

Package:LISP +The long-float closest in value to positive infinity. +

+ +
+ +
+
Macro: SHIFTF
+

Package:LISP +

+

Syntax: +

+
(shiftf {place}+ newvalue)
+
+ +

Evaluates all PLACEs and NEWVALUE in turn, then assigns the value of each +form to the PLACE on its left. Returns the original value of the leftmost +form. +

+ +
+ +
+
Constant: LEAST-POSITIVE-LONG-FLOAT
+

Package:LISP +The positive long-float closest in value to zero. +

+ +
+ +
+
Function: DEPOSIT-FIELD (newbyte bytespec integer)
+

Package:LISP +

+

Returns an integer computed by replacing the specified byte of INTEGER with +the specified byte of NEWBYTE. +

+ +
+ +
+
Function: BIT-AND (bit-array1 bit-array2 &optional (result-bit-array nil))
+

Package:LISP +

+

Performs a bit-wise logical AND on the elements of BIT-ARRAY1 and BIT-ARRAY2. +Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into +BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. +

+ +
+ +
+
Function: LOGNAND (integer1 integer2)
+

Package:LISP +

+

Returns the complement of the logical AND of INTEGER1 and INTEGER2. +

+ +
+ +
+
Function: BYTE-POSITION (bytespec)
+

Package:LISP +

+

Returns the position part (in GCL, the cdr part) of the byte specifier. +

+ +
+ +
+
Macro: ROTATEF
+

Package:LISP +

+

Syntax: +

+
(rotatef {place}*)
+
+ +

Evaluates PLACEs in turn, then assigns to each PLACE the value of the form to +its right. The rightmost PLACE gets the value of the leftmost PLACE. +Returns NIL always. +

+ +
+ +
+
Function: BIT-ANDC2 (bit-array1 bit-array2 &optional (result-bit-array nil))
+

Package:LISP +

+

Performs a bit-wise logical ANDC2 on the elements of BIT-ARRAY1 and +BIT-ARRAY2. +Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into +BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. +

+ +
+ +
+
Function: TRUNCATE (number &optional (divisor 1))
+

Package:LISP +

+

Values: (quotient remainder) +Returns NUMBER/DIVISOR as an integer, rounded toward 0. The second returned +value is the remainder. +

+ +
+ +
+
Constant: BOOLE-EQV
+

Package:LISP +Makes BOOLE return LOGEQV of INTEGER1 and INTEGER2. +

+ +
+ +
+
Constant: BOOLE-SET
+

Package:LISP +Makes BOOLE return -1. +

+ +
+ +
+
Function: LDB (bytespec integer)
+

Package:LISP +

+

Extracts and right-justifies the specified byte of INTEGER, and returns the +result. +

+ +
+ +
+
Function: BYTE-SIZE (bytespec)
+

Package:LISP +

+

Returns the size part (in GCL, the car part) of the byte specifier. +

+ +
+ +
+
Constant: SHORT-FLOAT-NEGATIVE-EPSILON
+

Package:LISP +The smallest positive short-float that satisfies + (not (= (float 1 e) (- (float 1 e) e))). +

+ +
+ +
+
Function: REM (number divisor)
+

Package:LISP +

+

Returns the second value of (TRUNCATE NUMBER DIVISOR). +

+ +
+ +
+
Function: MIN (number &rest more-numbers)
+

Package:LISP +

+

Returns the least of its arguments. +

+ +
+ +
+
Function: EXP (number)
+

Package:LISP +

+

Calculates e raised to the power NUMBER, where e is the base of natural +logarithms. +

+ +
+ +
+
Function: DECODE-FLOAT (float)
+

Package:LISP +

+

Returns, as three values, the significand F, the exponent E, and the sign S +of the given float, so that + E + FLOAT = S * F * B where B = (FLOAT-RADIX FLOAT) +

+

S and F are floating-point numbers of the same float format as FLOAT, and E +is an integer. +

+ + +
+ +
+
Constant: LONG-FLOAT-EPSILON
+

Package:LISP +The smallest positive long-float that satisfies + (not (= (float 1 e) (+ (float 1 e) e))). +

+ +
+ +
+
Function: FROUND (number &optional (divisor 1))
+

Package:LISP +

+

Same as ROUND, but returns first value as a float. +

+ +
+ +
+
Function: LOGEQV (&rest integers)
+

Package:LISP +

+

Returns the bit-wise EQUIVALENCE of its arguments. +

+ +
+ +
+
Constant: MOST-NEGATIVE-SHORT-FLOAT
+

Package:LISP +The short-float closest in value to negative infinity. +

+ +
+ +
+
Function: BIT-NOR (bit-array1 bit-array2 &optional (result-bit-array nil))
+

Package:LISP +

+

Performs a bit-wise logical NOR on the elements of BIT-ARRAY1 and BIT-ARRAY2. +Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into +BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. +

+ +
+ +
+
Function: CEILING (number &optional (divisor 1))
+

Package:LISP +

+

Returns the smallest integer not less than or NUMBER/DIVISOR. Returns the +remainder as the second value. +

+ +
+ +
+
Constant: LEAST-NEGATIVE-SHORT-FLOAT
+

Package:LISP +The negative short-float closest in value to zero. +

+ +
+ +
+
Function: 1- (number)
+

Package:LISP +

+

Returns NUMBER - 1. +

+ +
+ +
+
Function: <= (number &rest more-numbers)
+

Package:LISP +

+

Returns T if arguments are in strictly non-decreasing order; NIL otherwise. +

+ +
+ +
+
Function: IMAGPART (number)
+

Package:LISP +

+

Extracts the imaginary part of NUMBER. +

+ +
+ +
+
Function: INTEGERP (x)
+

Package:LISP +

+

Returns T if X is an integer (fixnum or bignum); NIL otherwise. +

+ +
+ +
+
Function: ASH (integer count)
+

Package:LISP +

+

Shifts INTEGER left by COUNT places. Shifts right if COUNT is negative. +

+ +
+ +
+
Function: LCM (integer &rest more-integers)
+

Package:LISP +

+

Returns the least common multiple of the arguments. +

+ +
+ +
+
Function: COS (radians)
+

Package:LISP +

+

Returns the cosine of RADIANS. +

+ +
+ +
+
Special Form: DECF
+

Package:LISP +

+

Syntax: +

+
(decf place [delta])
+
+

Subtracts the number +produced by DELTA (which defaults to 1) from the number in +PLACE. +

+ +
+ +
+
Function: ATAN (x &optional (y 1))
+

Package:LISP + Returns the arc tangent of +X/Y. +

+ +
+ +
+
Constant: BOOLE-ANDC1
+

Package:LISP +Makes BOOLE return LOGANDC1 of INTEGER1 and INTEGER2. +

+ +
+ +
+
Function: COSH (number)
+

Package:LISP + Returns the hyperbolic cosine of +NUMBER. +

+ +
+ +
+
Function: FLOAT-RADIX (float)
+

Package:LISP +

+

Returns the representation radix (or base) of the floating-point +number. +

+ +
+ +
+
Function: ATANH (number)
+

Package:LISP +

+

Returns the hyperbolic arc tangent of NUMBER. +

+ +
+ +
+
Function: EVENP (integer)
+

Package:LISP + Returns T +if INTEGER is even. Returns NIL if INTEGER is odd. +

+ +
+ +
+
Function: ZEROP (number)
+

Package:LISP + Returns T if NUMBER = 0; NIL +otherwise. +

+ +
+ +
+
Function: FLOATP (x)
+

Package:LISP +

+

Returns T if X is a floating-point number; NIL otherwise. +

+ +
+ +
+
Function: SXHASH (object)
+

Package:LISP +

+

Computes a hash code for OBJECT and returns it as an integer. +

+ +
+ +
+
Constant: BOOLE-1
+

Package:LISP +Makes BOOLE return INTEGER1. +

+ +
+ +
+
Constant: MOST-POSITIVE-SINGLE-FLOAT
+

Package:LISP +Same as MOST-POSITIVE-LONG-FLOAT. +

+ +
+ +
+
Function: LOGANDC1 (integer1 integer2)
+

Package:LISP +

+

Returns the logical AND of (LOGNOT INTEGER1) and INTEGER2. +

+ +
+ +
+
Constant: LEAST-POSITIVE-SINGLE-FLOAT
+

Package:LISP +Same as LEAST-POSITIVE-LONG-FLOAT. +

+ +
+ +
+
Function: COMPLEXP (x)
+

Package:LISP +

+

Returns T if X is a complex number; NIL otherwise. +

+ +
+ +
+
Constant: BOOLE-AND
+

Package:LISP +Makes BOOLE return LOGAND of INTEGER1 and INTEGER2. +

+ +
+ +
+
Function: MAX (number &rest more-numbers)
+

Package:LISP +

+

Returns the greatest of its arguments. +

+ +
+ +
+
Function: FLOAT-SIGN (float1 &optional (float2 (float 1 float1)))
+

Package:LISP +

+

Returns a floating-point number with the same sign as FLOAT1 and with the +same absolute value as FLOAT2. +

+ +
+ +
+
Constant: BOOLE-ANDC2
+

Package:LISP +Makes BOOLE return LOGANDC2 of INTEGER1 and INTEGER2. +

+ +
+ +
+
Function: DENOMINATOR (rational)
+

Package:LISP +

+

Returns the denominator of RATIONAL as an integer. +

+ +
+ +
+
Function: FLOAT (number &optional other)
+

Package:LISP +

+

Converts a non-complex number to a floating-point number. If NUMBER is +already a float, FLOAT simply returns NUMBER. Otherwise, the format of +the returned float depends on OTHER; If OTHER is not provided, FLOAT returns +a SINGLE-FLOAT. If OTHER is provided, the result is in the same float format +as OTHER’s. +

+ +
+ +
+
Function: ROUND (number &optional (divisor 1))
+

Package:LISP +

+

Rounds NUMBER/DIVISOR to nearest integer. The second returned value is the +remainder. +

+ +
+ +
+
Function: LOGAND (&rest integers)
+

Package:LISP +

+

Returns the bit-wise AND of its arguments. +

+ +
+ +
+
Constant: BOOLE-2
+

Package:LISP +Makes BOOLE return INTEGER2. +

+ +
+ +
+
Function: * (&rest numbers)
+

Package:LISP +

+

Returns the product of its arguments. With no args, returns 1. +

+ +
+ +
+
Function: < (number &rest more-numbers)
+

Package:LISP +

+

Returns T if its arguments are in strictly increasing order; NIL otherwise. +

+ +
+ +
+
Function: COMPLEX (realpart &optional (imagpart 0))
+

Package:LISP +

+

Returns a complex number with the given real and imaginary parts. +

+ +
+ +
+
Constant: SINGLE-FLOAT-EPSILON
+

Package:LISP +Same as LONG-FLOAT-EPSILON. +

+ +
+ +
+
Function: LOGANDC2 (integer1 integer2)
+

Package:LISP +

+

Returns the logical AND of INTEGER1 and (LOGNOT INTEGER2). +

+ +
+ +
+
Function: INTEGER-LENGTH (integer)
+

Package:LISP +

+

Returns the number of significant bits in the absolute value of INTEGER. +

+ +
+ +
+
Constant: MOST-NEGATIVE-FIXNUM
+

Package:LISP +The fixnum closest in value to negative infinity. +

+ +
+ +
+
Constant: LONG-FLOAT-NEGATIVE-EPSILON
+

Package:LISP +The smallest positive long-float that satisfies + (not (= (float 1 e) (- (float 1 e) e))). +

+ +
+ +
+
Function: >= (number &rest more-numbers)
+

Package:LISP +

+

Returns T if arguments are in strictly non-increasing order; NIL otherwise. +

+ +
+ +
+
Constant: BOOLE-NOR
+

Package:LISP +Makes BOOLE return LOGNOR of INTEGER1 and INTEGER2. +

+ +
+ +
+
Function: ACOS (number)
+

Package:LISP +

+

Returns the arc cosine of NUMBER. +

+ +
+ +
+
Function: MAKE-RANDOM-STATE (&optional (state *random-state*))
+

Package:LISP +

+

Creates and returns a copy of the specified random state. If STATE is NIL, +then the value of *RANDOM-STATE* is used. If STATE is T, then returns a +random state object generated from the universal time. +

+ +
+ +
+
Function: EXPT (base-number power-number)
+

Package:LISP +

+

Returns BASE-NUMBER raised to the power POWER-NUMBER. +

+ +
+ +
+
Function: SQRT (number)
+

Package:LISP +

+

Returns the principal square root of NUMBER. +

+ +
+ +
+
Function: SCALE-FLOAT (float integer)
+

Package:LISP +

+

Returns (* FLOAT (expt (float-radix FLOAT) INTEGER)). +

+ +
+ +
+
Function: ACOSH (number)
+

Package:LISP +

+

Returns the hyperbolic arc cosine of NUMBER. +

+ +
+ +
+
Constant: MOST-NEGATIVE-LONG-FLOAT
+

Package:LISP +The long-float closest in value to negative infinity. +

+ +
+ +
+
Constant: LEAST-NEGATIVE-LONG-FLOAT
+

Package:LISP +The negative long-float closest in value to zero. +

+ +
+ +
+
Function: FFLOOR (number &optional (divisor 1))
+

Package:LISP +

+

Same as FLOOR, but returns a float as the first value. +

+ +
+ +
+
Function: LOGNOR (integer1 integer2)
+

Package:LISP +

+

Returns the complement of the logical OR of INTEGER1 and INTEGER2. +

+ +
+ +
+
Function: PARSE-INTEGER (string &key (start 0) (end (length string)) (radix 10) (junk-allowed nil))
+

Package:LISP +

+

Parses STRING for an integer and returns it. +

+ +
+ +
+
Function: + (&rest numbers)
+

Package:LISP +

+

Returns the sum of its arguments. With no args, returns 0. +

+ +
+ +
+
Function: = (number &rest more-numbers)
+

Package:LISP +

+

Returns T if all of its arguments are numerically equal; NIL otherwise. +

+ +
+ +
+
Function: NUMBERP (x)
+

Package:LISP +

+

Returns T if X is any kind of number; NIL otherwise. +

+ +
+ +
+
Constant: MOST-POSITIVE-DOUBLE-FLOAT
+

Package:LISP +Same as MOST-POSITIVE-LONG-FLOAT. +

+ +
+ +
+
Function: LOGTEST (integer1 integer2)
+

Package:LISP +

+

Returns T if LOGAND of INTEGER1 and INTEGER2 is not zero; NIL otherwise. +

+ +
+ +
+
Function: RANDOM-STATE-P (x)
+

Package:LISP +

+

Returns T if X is a random-state object; NIL otherwise. +

+ +
+ +
+
Constant: LEAST-POSITIVE-DOUBLE-FLOAT
+

Package:LISP +Same as LEAST-POSITIVE-LONG-FLOAT. +

+ +
+ +
+
Function: FLOAT-PRECISION (float)
+

Package:LISP +

+

Returns the number of significant radix-B digits used to represent the +significand F of the floating-point number, where B = (FLOAT-RADIX FLOAT). +

+ +
+ +
+
Constant: BOOLE-XOR
+

Package:LISP +Makes BOOLE return LOGXOR of INTEGER1 and INTEGER2. +

+ +
+ +
+
Function: DPB (newbyte bytespec integer)
+

Package:LISP +

+

Returns an integer computed by replacing the specified byte of INTEGER with +NEWBYTE. +

+ +
+ +
+
Function: ABS (number)
+

Package:LISP +

+

Returns the absolute value of NUMBER. +

+ +
+ +
+
Function: CONJUGATE (number)
+

Package:LISP +

+

Returns the complex conjugate of NUMBER. +

+ +
+ +
+
Function: CIS (radians)
+

Package:LISP +

+

Returns e raised to i*RADIANS. +

+ +
+ +
+
Function: ODDP (integer)
+

Package:LISP +

+

Returns T if INTEGER is odd; NIL otherwise. +

+ +
+ +
+
Function: RATIONALIZE (number)
+

Package:LISP +

+

Converts NUMBER into rational approximately and returns it. +

+ +
+ +
+
Function: ISQRT (integer)
+

Package:LISP +

+

Returns the greatest integer less than or equal to the square root of the +given non-negative integer. +

+ +
+ +
+
Function: LOGXOR (&rest integers)
+

Package:LISP +

+

Returns the bit-wise EXCLUSIVE OR of its arguments. +

+ +
+ +
+
Function: > (number &rest more-numbers)
+

Package:LISP +

+

Returns T if its arguments are in strictly decreasing order; NIL otherwise. +

+ +
+ +
+
Function: LOGBITP (index integer)
+

Package:LISP +

+

Returns T if the INDEX-th bit of INTEGER is 1. +

+ +
+ +
+
Constant: DOUBLE-FLOAT-EPSILON
+

Package:LISP +Same as LONG-FLOAT-EPSILON. +

+ +
+ +
+
Function: LOGCOUNT (integer)
+

Package:LISP +

+

If INTEGER is negative, returns the number of 0 bits. Otherwise, returns +the number of 1 bits. +

+ +
+ +
+
Function: GCD (&rest integers)
+

Package:LISP +

+

Returns the greatest common divisor of INTEGERs. +

+ +
+ +
+
Function: RATIONALP (x)
+

Package:LISP +

+

Returns T if X is an integer or a ratio; NIL otherwise. +

+ +
+ +
+
Function: MOD (number divisor)
+

Package:LISP +

+

Returns the second result of (FLOOR NUMBER DIVISOR). +

+ +
+ +
+
Function: MODF (number)
+

Package:SYSTEM +

+

Returns the integer and fractional part of a floating point number mod 1.0. +

+ +
+ +
+
Constant: BOOLE-ORC1
+

Package:LISP +Makes BOOLE return LOGORC1 of INTEGER1 and INTEGER2. +

+ +
+ +
+
Constant: SINGLE-FLOAT-NEGATIVE-EPSILON
+

Package:LISP +Same as LONG-FLOAT-NEGATIVE-EPSILON. +

+ +
+ +
+
Function: FLOOR (number &optional (divisor 1))
+

Package:LISP +

+

Returns the largest integer not larger than the NUMBER divided by DIVISOR. +The second returned value is (- NUMBER (* first-value DIVISOR)). +

+ +
+ +
+
Function: PLUSP (number)
+

Package:LISP +

+

Returns T if NUMBER > 0; NIL otherwise. +

+ +
+ +
+
Function: FLOAT-DIGITS (float)
+

Package:LISP +

+

Returns the number of radix-B digits used to represent the significand F of +the floating-point number, where B = (FLOAT-RADIX FLOAT). +

+ +
+ +
+
Function: RANDOM (number &optional (state *random-state*))
+

Package:LISP +

+

Generates a uniformly distributed pseudo-random number between zero +(inclusive) and NUMBER (exclusive), by using the random state object STATE. +

+ +
+ +
+
+

+Next: , Previous: , Up: Top   [Contents][Index]

+
+ + + + + diff --git a/info/gcl-si/Operating-System-Definitions.html b/info/gcl-si/Operating-System-Definitions.html new file mode 100644 index 0000000..d3d0b62 --- /dev/null +++ b/info/gcl-si/Operating-System-Definitions.html @@ -0,0 +1,419 @@ + + + + +GCL SI Manual: Operating System Definitions + + + + + + + + + + + + + + + + + + + + +
+

+Previous: , Up: Operating System   [Contents][Index]

+
+
+ +

9.2 Operating System Definitions

+ +
+
Function: GET-DECODED-TIME ()
+

Package:LISP +

+

Returns the current time in decoded time format. Returns nine values: second, +minute, hour, date, month, year, day-of-week, daylight-saving-time-p, and +time-zone. +

+ +
+ +
+
Function: HOST-NAMESTRING (pathname)
+

Package:LISP +

+

Returns the host part of PATHNAME as a string. +

+ +
+ +
+
Function: RENAME-FILE (file new-name)
+

Package:LISP +

+

Renames the file FILE to NEW-NAME. FILE may be a string, a pathname, or +a stream. +

+ +
+ +
+
Function: FILE-AUTHOR (file)
+

Package:LISP +

+

Returns the author name of the specified file, as a string. +FILE may be a string or a stream +

+ +
+ +
+
Function: PATHNAME-HOST (pathname)
+

Package:LISP +

+

Returns the host slot of PATHNAME. +

+ +
+ +
+
Function: FILE-POSITION (file-stream &optional position)
+

Package:LISP +

+

Sets the file pointer of the specified file to POSITION, if POSITION is given. +Otherwise, returns the current file position of the specified file. +

+ +
+ +
+
Function: DECODE-UNIVERSAL-TIME (universal-time &optional (timezone -9))
+

Package:LISP +

+

Converts UNIVERSAL-TIME into a decoded time at the TIMEZONE. +Returns nine values: second, minute, hour, date, month (1 - 12), year, +day-of-week (0 - 6), daylight-saving-time-p, and time-zone. +TIMEZONE in GCL defaults to 6, the time zone of Austin, Texas. +

+ +
+ +
+
Function: USER-HOMEDIR-PATHNAME (&optional host)
+

Package:LISP +

+

Returns the home directory of the logged in user as a pathname. HOST +is ignored. +

+ +
+ + +
+
Variable: *MODULES*
+

Package:LISP +A list of names of the modules that have been loaded into GCL. +

+ +
+ +
+
Function: SHORT-SITE-NAME ()
+

Package:LISP +

+

Returns a string that identifies the physical location of the current GCL. +

+ +
+ +
+
Function: DIRECTORY (name)
+

Package:LISP +

+

Returns a list of files that match NAME. NAME may be a string, a pathname, +or a file stream. +

+ +
+ +
+
Function: SOFTWARE-VERSION ()
+

Package:LISP +

+

Returns a string that identifies the software version of the software +under which GCL is currently running. +

+ +
+ +
+
Constant: INTERNAL-TIME-UNITS-PER-SECOND
+

Package:LISP +The number of internal time units that fit into a second. +

+ +
+ +
+
Function: ENOUGH-NAMESTRING (pathname &optional (defaults *default-pathname-defaults*))
+

Package:LISP +

+

Returns a string which uniquely identifies PATHNAME with respect to +DEFAULTS. +

+ +
+ +
+
Function: REQUIRE (module-name &optional (pathname))
+

Package:LISP +

+

If the specified module is not present, then loads the appropriate file(s). +PATHNAME may be a single pathname or it may be a list of pathnames. +

+ +
+ +
+
Function: ENCODE-UNIVERSAL-TIME (second minute hour date month year &optional (timezone ))
+

Package:LISP +

+

Does the inverse operation of DECODE-UNIVERSAL-TIME. +

+ +
+ +
+
Function: LISP-IMPLEMENTATION-VERSION ()
+

Package:LISP +

+

Returns a string that tells you when the current GCL implementation is +brought up. +

+ +
+ +
+
Function: MACHINE-INSTANCE ()
+

Package:LISP +

+

Returns a string that identifies the machine instance of the machine +on which GCL is currently running. +

+ +
+ +
+
Function: ROOM (&optional (x t))
+

Package:LISP +

+

Displays information about storage allocation in the following format. +

+
    +
  • for each type class +
      +
    • the number of pages so-far allocated for the type class +
    • the maximum number of pages for the type class +
    • the percentage of used cells to cells so-far allocated +
    • the number of times the garbage collector has been called to + collect cells of the type class +
    • the implementation types that belongs to the type class +
    +
  • the number of pages actually allocated for contiguous blocks +
  • the maximum number of pages for contiguous blocks +
  • the number of times the garbage collector has been called to collect + contiguous blocks +
  • the number of pages in the hole +
  • the maximum number of pages for relocatable blocks +
  • the number of times the garbage collector has been called to collect + relocatable blocks +
  • the total number of pages allocated for cells +
  • the total number of pages allocated +
  • the number of available pages +
  • the number of pages GCL can use. + +

    The number of times the garbage collector has been called is not shown, +if the number is zero. The optional X is ignored. +

+ +
+ +
+
Function: GET-UNIVERSAL-TIME ()
+

Package:LISP +

+

Returns the current time as a single integer in universal time format. +

+ +
+ +
+
Function: GET-INTERNAL-RUN-TIME ()
+

Package:LISP +

+

Returns the run time in the internal time format. This is useful for +finding CPU usage. If the operating system allows, a second value +containing CPU usage of child processes is returned. +

+ +
+ +
+
Variable: *DEFAULT-PATHNAME-DEFAULTS*
+

Package:LISP +The default pathname-defaults pathname. +

+ +
+ +
+
Function: LONG-SITE-NAME ()
+

Package:LISP +

+

Returns a string that identifies the physical location of the current GCL. +

+ +
+ +
+
Function: DELETE-FILE (file)
+

Package:LISP + Deletes FILE. +

+ +
+ +
+
Function: GET-INTERNAL-REAL-TIME ()
+

Package:LISP +

+

Returns the real time in the internal time format. This is useful for +finding elapsed time. +

+ +
+ +
+
Function: MACHINE-TYPE ()
+

Package:LISP +

+

Returns a string that identifies the machine type of the machine +on which GCL is currently running. +

+ +
+ +
+
Macro: TIME
+

Package:LISP +

+

Syntax: +

+
(time form)
+
+ +

Evaluates FORM and outputs timing statistics on *TRACE-OUTPUT*. +

+ +
+ +
+
Function: SOFTWARE-TYPE ()
+

Package:LISP +

+

Returns a string that identifies the software type of the software +under which GCL is currently running. +

+ +
+ +
+
Function: LISP-IMPLEMENTATION-TYPE ()
+

Package:LISP +

+

Returns a string that tells you that you are using a version of GCL. +

+ +
+ +
+
Function: SLEEP (n)
+

Package:LISP +

+

This function causes execution to be suspended for N seconds. N may +be any non-negative, non-complex number. +

+ +
+ +
+
Function: BREAK-ON-FLOATING-POINT-EXCEPTIONS (&key division-by-zero
+

floating-point-invalid-operation + floating-point-overflow + floating-point-underflow + floating-point-inexact) +Package:SI +

+

Break on the specified IEEE floating point error conditions. With no +arguments, report the exceptions currently trapped. Disable the break +by setting the key to nil, e.g. +

+

> (break-on-floaing-point-exceptions :division-by-zero t) + (DIVISION-BY-ZERO) +

+

> (break-on-floaing-point-exceptions) + (DIVISION-BY-ZERO) +

+

> (break-on-floaing-point-exceptions :division-by-zero nil) + NIL +

+

On some of the most common platforms, the offending instruction will be +disassembled, and the register arguments looked up in the saved context +and reported in as operands. Within the error handler, addresses may be +disassembled, and other registers inspected, using the functions defined +in gcl_fpe.lsp. +

+
+ + +
+
+

+Previous: , Up: Operating System   [Contents][Index]

+
+ + + + + diff --git a/info/gcl-si/Operating-System.html b/info/gcl-si/Operating-System.html new file mode 100644 index 0000000..ae9f3b0 --- /dev/null +++ b/info/gcl-si/Operating-System.html @@ -0,0 +1,72 @@ + + + + +GCL SI Manual: Operating System + + + + + + + + + + + + + + + + + + + + +
+

+Next: , Previous: , Up: Top   [Contents][Index]

+
+
+ +

9 Operating System

+ + + + +
• Command Line:   +
• Operating System Definitions:   +
+ + + + + + diff --git a/info/gcl-si/Regular-Expressions.html b/info/gcl-si/Regular-Expressions.html new file mode 100644 index 0000000..5629633 --- /dev/null +++ b/info/gcl-si/Regular-Expressions.html @@ -0,0 +1,211 @@ + + + + +GCL SI Manual: Regular Expressions + + + + + + + + + + + + + + + + + + + + +
+

+Previous: , Up: System Definitions   [Contents][Index]

+
+
+ +

17.1 Regular Expressions

+ +

The function string-match (*Index string-match::) is used to +match a regular expression against a string. If the variable +*case-fold-search* is not nil, case is ignored in the match. +To determine the extent of the match use *Index match-beginning:: and +*Index match-end::. +

+

Regular expressions are implemented using Henry Spencer’s package +(thank you Henry!), and much of the description of regular expressions +below is copied verbatim from his manual entry. Code for delimited +searches, case insensitive searches, and speedups to allow fast +searching of long files was contributed by W. Schelter. The speedups +use an adaptation by Schelter of the Boyer and Moore string search +algorithm to the case of branched regular expressions. These allow +such expressions as ’not_there|really_not’ to be searched for 30 times +faster than in GNU emacs (1995), and 200 times faster than in the +original Spencer method. Expressions such as [a-u]bcdex get a speedup +of 60 and 194 times respectively. This is based on searching a string +of 50000 characters (such as the file tk.lisp). +

+
    +
  • A regular expression is a string containing zero or more branches which are separated by |. A match of the regular expression against a string is simply a match of the string with one of the branches. +
  • Each branch consists of zero or more pieces, concatenated. A matching +string must contain an initial substring matching the first piece, immediately +followed by a second substring matching the second piece and so on. +
  • Each piece is an atom optionally followed by +, *, or ?. +
  • An atom followed by + matches a sequence of 1 or more matches of the atom. +
  • An atom followed by * matches a sequence of 0 or more matches of the atom. +
  • An atom followed by ? matches a match of the atom, or the null string. +
  • An atom is +
      +
    • - a regular expression in parentheses matching a match for the regular expression +
    • - a range see below +
    • - a . matching any single character +
    • - a ^ matching the null string at the beginning of the input string +
    • - a $ matching the null string at the end of the input string +
    • - a \ followed by a single character matching that character +
    • - a single character with no other significance +(matching that character). +
    +
  • A range is a sequence of characters enclosed in []. +It normally matches any single character from the sequence. +
      +
    • - If the sequence begins with ^, +it matches any single character not from the rest of the sequence. +
    • - If two characters in the sequence are separated by -, this is shorthand +for the full list of ASCII characters between them +(e.g. [0-9] matches any decimal digit). +
    • - To include a literal ] in the sequence, make it the first character +(following a possible ^). +
    • - To include a literal -, make it the first or last character. +
    +
+ + +

Ordering Multiple Matches

+ +

In general there may be more than one way to match a regular expression +to an input string. For example, consider the command +

+
+
 (string-match "(a*)b*"  "aabaaabb")
+
+ +

Considering only the rules given so far, the value of (list-matches 0 1) +might be ("aabb" "aa") or ("aaab" "aaa") or ("ab" "a") +or any of several other combinations. +To resolve this potential ambiguity string-match chooses among +alternatives using the rule first then longest. +In other words, it considers the possible matches in order working +from left to right across the input string and the pattern, and it +attempts to match longer pieces of the input string before shorter +ones. More specifically, the following rules apply in decreasing +order of priority: +

    +
  • [1] +If a regular expression could match two different parts of an input string +then it will match the one that begins earliest. +
  • [2] +If a regular expression contains | operators then the leftmost +matching sub-expression is chosen. +
  • [3] +In *, +, and ? constructs, longer matches are chosen +in preference to shorter ones. +
  • [4] +In sequences of expression components the components are considered +from left to right. +
+ +

In the example from above, (a*)b* matches aab: the (a*) +portion of the pattern is matched first and it consumes the leading +aa; then the b* portion of the pattern consumes the +next b. Or, consider the following example: +

+
+
 (string-match "(ab|a)(b*)c"  "xabc") ==> 1
+ (list-matches 0 1 2 3) ==> ("abc" "ab" "" NIL)
+ (match-beginning 0) ==> 1
+ (match-end 0) ==> 4
+ (match-beginning 1) ==> 1
+ (match-end 1) ==> 3
+ (match-beginning 2) ==> 3
+ (match-end 2) ==> 3
+ (match-beginning 3) ==> -1
+ (match-end 3) ==> -1
+
+
+ +

In the above example the return value of 1 (which is > -1) +indicates that a match was found. The entire match runs from +1 to 4. +Rule 4 specifies that (ab|a) gets first shot at the input +string and Rule 2 specifies that the ab sub-expression +is checked before the a sub-expression. +Thus the b has already been claimed before the (b*) +component is checked and (b*) must match an empty string. +

+

The special characters in the string "\()[]+.*|^$?", +must be quoted, if a simple string search is desired. The function +re-quote-string is provided for this purpose. +

+
(re-quote-string "*standard*") ==> "\\*standard\\*"
+
+(string-match (re-quote-string "*standard*") "X *standard* ")
+ ==> 2
+
+(string-match "*standard*" "X *standard* ")
+Error: Regexp Error: ?+* follows nothing
+
+

Note there is actually just one \ before the * +but the printer makes two so that the string can be read, since +\ is also the lisp quote character. In the last example +an error is signalled since the special character * must +follow an atom if it is interpreted as a regular expression. +

+ + + + + + + +
+
+

+Previous: , Up: System Definitions   [Contents][Index]

+
+ + + + + diff --git a/info/gcl-si/Sequences-and-Arrays-and-Hash-Tables.html b/info/gcl-si/Sequences-and-Arrays-and-Hash-Tables.html new file mode 100644 index 0000000..4671dba --- /dev/null +++ b/info/gcl-si/Sequences-and-Arrays-and-Hash-Tables.html @@ -0,0 +1,1162 @@ + + + + +GCL SI Manual: Sequences and Arrays and Hash Tables + + + + + + + + + + + + + + + + + + + + +
+

+Next: , Previous: , Up: Top   [Contents][Index]

+
+
+ +

2 Sequences and Arrays and Hash Tables

+ +
+
Function: VECTOR (&rest objects)
+

Package:LISP +

+

Constructs a Simple-Vector from the given objects. +

+ +
+ +
+
Function: SUBSEQ (sequence start &optional (end (length sequence)))
+

Package:LISP +

+

Returns a copy of a subsequence of SEQUENCE between START (inclusive) and +END (exclusive). +

+ +
+ +
+
Function: COPY-SEQ (sequence)
+

Package:LISP +

+

Returns a copy of SEQUENCE. +

+ +
+ +
+
Function: POSITION (item sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (key #'identity))
+

Package:LISP +

+

Returns the index of the first element in SEQUENCE that satisfies TEST with +ITEM; NIL if no such element exists. +

+ +
+ +
+
Function: ARRAY-RANK (array)
+

Package:LISP +

+

Returns the number of dimensions of ARRAY. +

+ +
+ +
+
Function: SBIT (simple-bit-array &rest subscripts)
+

Package:LISP +

+

Returns the bit from SIMPLE-BIT-ARRAY at SUBSCRIPTS. +

+ +
+ +
+
Function: STRING-CAPITALIZE (string &key (start 0) (end (length string)))
+

Package:LISP +

+

Returns a copy of STRING with the first character of each word converted to +upper-case, and remaining characters in the word converted to lower case. +

+ +
+ +
+
Function: NSUBSTITUTE-IF-NOT (new test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity))
+

Package:LISP +

+

Returns a sequence of the same kind as SEQUENCE with the same elements +

+

except that all elements not satisfying TEST are replaced with NEWITEM. +SEQUENCE may be destroyed. +

+ +
+ +
+
Function: FIND-IF (test sequence &key (from-end nil) (start 0) (end (length sequence)) (key #'identity))
+

Package:LISP +

+

Returns the index of the first element in SEQUENCE that satisfies TEST; NIL if +no such element exists. +

+ +
+ +
+
Function: BIT-EQV (bit-array1 bit-array2 &optional (result-bit-array nil))
+

Package:LISP +

+

Performs a bit-wise logical EQV on the elements of BIT-ARRAY1 and BIT-ARRAY2. +Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into +BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. +

+ +
+ +
+
Function: STRING< (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2)))
+

Package:LISP +

+

If STRING1 is lexicographically less than STRING2, then returns the longest +common prefix of the strings. Otherwise, returns NIL. +

+ +
+ +
+
Function: REVERSE (sequence)
+

Package:LISP +

+

Returns a new sequence containing the same elements as SEQUENCE but in +reverse order. +

+ +
+ +
+
Function: NSTRING-UPCASE (string &key (start 0) (end (length string)))
+

Package:LISP +

+

Returns STRING with all lower case characters converted to uppercase. +

+ +
+ +
+
Function: STRING>= (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2)))
+

Package:LISP +

+

If STRING1 is lexicographically greater than or equal to STRING2, then returns +the longest common prefix of the strings. Otherwise, returns NIL. +

+ +
+ +
+
Function: ARRAY-ROW-MAJOR-INDEX (array &rest subscripts)
+

Package:LISP +

+

Returns the index into the data vector of ARRAY for the element of ARRAY +specified by SUBSCRIPTS. +

+ +
+ + +
+
Function: ARRAY-DIMENSION (array axis-number)
+

Package:LISP +

+

Returns the length of AXIS-NUMBER of ARRAY. +

+ +
+ +
+
Function: FIND (item sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (key #'identity))
+

Package:LISP +

+

Returns the first element in SEQUENCE satisfying TEST with ITEM; NIL if no +such element exists. +

+ +
+ +
+
Function: STRING-NOT-EQUAL (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2)))
+

Package:LISP +

+

Similar to STRING=, but ignores cases. +

+ +
+ +
+
Function: STRING-RIGHT-TRIM (char-bag string)
+

Package:LISP +

+

Returns a copy of STRING with the characters in CHAR-BAG removed from the +right end. +

+ +
+ +
+
Function: DELETE-IF-NOT (test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity))
+

Package:LISP +

+

Returns a sequence formed by destructively removing the elements not +satisfying TEST from SEQUENCE. +

+ +
+ +
+
Function: REMOVE-IF-NOT (test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity))
+

Package:LISP +

+

Returns a copy of SEQUENCE with elements not satisfying TEST removed. +

+ +
+ +
+
Function: STRING= (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2)))
+

Package:LISP +

+

Returns T if the two strings are character-wise CHAR=; NIL otherwise. +

+ +
+ +
+
Function: NSUBSTITUTE-IF (new test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity))
+

Package:LISP +

+

Returns a sequence of the same kind as SEQUENCE with the same elements +except that all elements satisfying TEST are replaced with NEWITEM. SEQUENCE +may be destroyed. +

+ +
+ +
+
Function: SOME (predicate sequence &rest more-sequences)
+

Package:LISP +

+

Returns T if at least one of the elements in SEQUENCEs satisfies PREDICATE; +NIL otherwise. +

+ +
+ +
+
Function: MAKE-STRING (size &key (initial-element #\Space))
+

Package:LISP +

+

Creates and returns a new string of SIZE length whose elements are all +INITIAL-ELEMENT. +

+ +
+ +
+
Function: NSUBSTITUTE (newitem olditem sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity))
+

Package:LISP +

+

Returns a sequence of the same kind as SEQUENCE with the same elements +except that OLDITEMs are replaced with NEWITEM. SEQUENCE may be destroyed. +

+ +
+ +
+
Function: STRING-EQUAL (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2)))
+

Package:LISP +

+

Given two strings (string1 and string2), and optional integers start1, +start2, end1 and end2, compares characters in string1 to characters in +string2 (using char-equal). +

+ +
+ +
+
Function: STRING-NOT-GREATERP (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2)))
+

Package:LISP +

+

Similar to STRING<=, but ignores cases. +

+ +
+ +
+
Function: STRING> (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2)))
+

Package:LISP +

+

If STRING1 is lexicographically greater than STRING2, then returns the +longest common prefix of the strings. Otherwise, returns NIL. +

+ +
+ +
+
Function: STRINGP (x)
+

Package:LISP +

+

Returns T if X is a string; NIL otherwise. +

+ +
+ +
+
Function: DELETE-IF (test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity))
+

Package:LISP +

+

Returns a sequence formed by removing the elements satisfying TEST +destructively from SEQUENCE. +

+ +
+ +
+
Function: SIMPLE-STRING-P (x)
+

Package:LISP +

+

Returns T if X is a simple string; NIL otherwise. +

+ +
+ +
+
Function: REMOVE-IF (test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity))
+

Package:LISP +

+

Returns a copy of SEQUENCE with elements satisfying TEST removed. +

+ +
+ +
+
Function: HASH-TABLE-COUNT (hash-table)
+

Package:LISP +

+

Returns the number of entries in the given Hash-Table. +

+ +
+ +
+
Function: ARRAY-DIMENSIONS (array)
+

Package:LISP +

+

Returns a list whose elements are the dimensions of ARRAY +

+ +
+ +
+
Function: SUBSTITUTE-IF-NOT (new test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity))
+

Package:LISP +

+

Returns a sequence of the same kind as SEQUENCE with the same elements +except that all elements not satisfying TEST are replaced with NEWITEM. +

+ +
+ +
+
Function: ADJUSTABLE-ARRAY-P (array)
+

Package:LISP +

+

Returns T if ARRAY is adjustable; NIL otherwise. +

+ +
+ +
+
Function: SVREF (simple-vector index)
+

Package:LISP +

+

Returns the INDEX-th element of SIMPLE-VECTOR. +

+ +
+ +
+
Function: VECTOR-PUSH-EXTEND (new-element vector &optional (extension (length vector)))
+

Package:LISP +

+

Similar to VECTOR-PUSH except that, if the fill pointer gets too large, +extends VECTOR rather then simply returns NIL. +

+ +
+ +
+
Function: DELETE (item sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity))
+

Package:LISP +

+

Returns a sequence formed by removing the specified ITEM destructively from +SEQUENCE. +

+ +
+ +
+
Function: REMOVE (item sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity))
+

Package:LISP +

+

Returns a copy of SEQUENCE with ITEM removed. +

+ +
+ +
+
Function: STRING (x)
+

Package:LISP +

+

Coerces X into a string. If X is a string, then returns X itself. If X is a +symbol, then returns X’s print name. If X is a character, then returns a one +element string containing that character. Signals an error if X cannot be +coerced into a string. +

+ +
+ +
+
Function: STRING-UPCASE (string &key (start 0) (end (length string)))
+

Package:LISP +

+

Returns a copy of STRING with all lower case characters converted to +uppercase. +

+ +
+ +
+
Function: GETHASH (key hash-table &optional (default nil))
+

Package:LISP +

+

Finds the entry in HASH-TABLE whose key is KEY and returns the associated +value and T, as multiple values. Returns DEFAULT and NIL if there is no +such entry. +

+ +
+ +
+
Function: MAKE-HASH-TABLE (&key (test 'eql) (size 1024) (rehash-size 1.5) (rehash-threshold 0.7))
+

Package:LISP +

+

Creates and returns a hash table. +

+ +
+ +
+
Function: STRING/= (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2)))
+

Package:LISP +

+

Returns NIL if STRING1 and STRING2 are character-wise CHAR=. Otherwise, +returns the index to the longest common prefix of the strings. +

+ +
+ +
+
Function: STRING-GREATERP (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2)))
+

Package:LISP +

+

Similar to STRING>, but ignores cases. +

+ +
+ +
+
Function: ELT (sequence index)
+

Package:LISP +

+

Returns the INDEX-th element of SEQUENCE. +

+ +
+ +
+
Function: MAKE-ARRAY (dimensions &key (element-type t) initial-element (initial-contents nil) (adjustable nil) (fill-pointer nil) (displaced-to nil) (displaced-index-offset 0) static)
+

Package:LISP +

+

Creates an array of the specified DIMENSIONS. The default for INITIAL- +ELEMENT depends on ELEMENT-TYPE. +MAKE-ARRAY will always try to find the ‘best’ array to +accommodate the element-type specified. For example on a SUN element-type +(mod 1) –> bit +(integer 0 10) –> unsigned-char +(integer -3 10) –> signed-char +si::best-array-element-type is the function doing this. It +is also used by the compiler, for coercing array element types. +If you are going to declare an array you should use the same +element type as was used in making it. eg +(setq my-array (make-array 4 :element-type ’(integer 0 10))) +(the (array (integer 0 10)) my-array) + When wanting to optimize references to an array you need to +declare the array eg: (the (array (integer -3 10)) my-array) if ar +were constructed using the (integer -3 10) element-type. You could of +course have used signed-char, but since the ranges may be +implementation dependent it is better to use -3 10 range. MAKE-ARRAY +needs to do some calculation with the element-type if you don’t +provide a primitive data-type. One way of doing this in a machine +independent fashion: +

+

(defvar *my-elt-type* #. + (array-element-type (make-array 1 :element-type ’(integer -3 10)))) +

+

Then calls to (make-array n :element-type *my-elt-type*) will not have to go +through a type inclusion computation. The keyword STATIC (GCL specific) if non +nil, will cause the array body to be non relocatable. +

+ + +
+ +
+
Function: NSTRING-DOWNCASE (string &key (start 0) (end (length string)))
+

Package:LISP + Returns STRING with all upper case +characters converted to lowercase. +

+ +
+ +
+
Function: ARRAY-IN-BOUNDS-P (array &rest subscripts)
+

Package:LISP + Returns T if SUBSCRIPTS are valid subscripts for +ARRAY; NIL otherwise. +

+ +
+ +
+
Function: SORT (sequence predicate &key (key #'identity))
+

Package:LISP + Destructively sorts SEQUENCE. +PREDICATE should return non-NIL if its first argument is to precede +its second argument. +

+ +
+ +
+
Function: HASH-TABLE-P (x)
+

Package:LISP +

+

Returns T if X is a hash table object; NIL +otherwise. +

+ +
+ +
+
Function: COUNT-IF-NOT (test sequence &key (from-end nil) (start 0) (end (length sequence)) (key #'identity))
+

Package:LISP +

+

Returns the number of elements in SEQUENCE not satisfying TEST. +

+ +
+ +
+
Function: FILL-POINTER (vector)
+

Package:LISP +

+

Returns the fill pointer of VECTOR. +

+ +
+ + +
+
Function: ARRAYP (x)
+

Package:LISP +

+

Returns T if X is an array; NIL otherwise. +

+ +
+ +
+
Function: REPLACE (sequence1 sequence2 &key (start1 0) (end1 (length sequence1)) (start2 0) (end2 (length sequence2)))
+

Package:LISP +

+

Destructively modifies SEQUENCE1 by copying successive elements into it from +SEQUENCE2. +

+ +
+ +
+
Function: BIT-XOR (bit-array1 bit-array2 &optional (result-bit-array nil))
+

Package:LISP +

+

Performs a bit-wise logical XOR on the elements of BIT-ARRAY1 and BIT-ARRAY2. +Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into +BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. +

+ +
+ +
+
Function: CLRHASH (hash-table)
+

Package:LISP +

+

Removes all entries of HASH-TABLE and returns the hash table itself. +

+ +
+ +
+
Function: SUBSTITUTE-IF (newitem test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity))
+

Package:LISP +

+

Returns a sequence of the same kind as SEQUENCE with the same elements +except that all elements satisfying TEST are replaced with NEWITEM. +

+ +
+ +
+
Function: MISMATCH (sequence1 sequence2 &key (from-end nil) (test #'eql) test-not (start1 0) (start2 0) (end1 (length sequence1)) (end2 (length sequence2)) (key #'identity))
+

Package:LISP +

+

The specified subsequences of SEQUENCE1 and SEQUENCE2 are compared +element-wise. If they are of equal length and match in every element, the +result is NIL. Otherwise, the result is a non-negative integer, the index +within SEQUENCE1 of the leftmost position at which they fail to match; or, if +one is shorter than and a matching prefix of the other, the index within +SEQUENCE1 beyond the last position tested is returned. +

+ +
+ +
+
Constant: ARRAY-TOTAL-SIZE-LIMIT
+

Package:LISP +The exclusive upper bound on the total number of elements of an array. +

+ +
+ +
+
Function: VECTOR-POP (vector)
+

Package:LISP +

+

Attempts to decrease the fill-pointer of VECTOR by 1 and returns the element +pointed to by the new fill pointer. Signals an error if the old value of +the fill pointer is 0. +

+ +
+ +
+
Function: SUBSTITUTE (newitem olditem sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity))
+

Package:LISP +

+

Returns a sequence of the same kind as SEQUENCE with the same elements +except that OLDITEMs are replaced with NEWITEM. +

+ +
+ +
+
Function: ARRAY-HAS-FILL-POINTER-P (array)
+

Package:LISP +

+

Returns T if ARRAY has a fill pointer; NIL otherwise. +

+ +
+ +
+
Function: CONCATENATE (result-type &rest sequences)
+

Package:LISP +

+

Returns a new sequence of the specified RESULT-TYPE, consisting of all +elements in SEQUENCEs. +

+ +
+ +
+
Function: VECTOR-PUSH (new-element vector)
+

Package:LISP +

+

Attempts to set the element of ARRAY designated by its fill pointer to +NEW-ELEMENT and increments the fill pointer by one. Returns NIL if the fill +pointer is too large. Otherwise, returns the new fill pointer value. +

+ +
+ +
+
Function: STRING-TRIM (char-bag string)
+

Package:LISP +

+

Returns a copy of STRING with the characters in CHAR-BAG removed from both +ends. +

+ +
+ +
+
Function: ARRAY-ELEMENT-TYPE (array)
+

Package:LISP +

+

Returns the type of the elements of ARRAY +

+ +
+ +
+
Function: NOTANY (predicate sequence &rest more-sequences)
+

Package:LISP +

+

Returns T if none of the elements in SEQUENCEs satisfies PREDICATE; NIL +otherwise. +

+ +
+ +
+
Function: BIT-NOT (bit-array &optional (result-bit-array nil))
+

Package:LISP +

+

Performs a bit-wise logical NOT in the elements of BIT-ARRAY. +Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into +BIT-ARRAY if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. +

+ +
+ +
+
Function: BIT-ORC1 (bit-array1 bit-array2 &optional (result-bit-array nil))
+

Package:LISP +

+

Performs a bit-wise logical ORC1 on the elements of BIT-ARRAY1 and BIT-ARRAY2. +Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into +BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. +

+ +
+ +
+
Function: COUNT-IF (test sequence &key (from-end nil) (start 0) (end (length sequence)) (key #'identity))
+

Package:LISP +

+

Returns the number of elements in SEQUENCE satisfying TEST. +

+ +
+ +
+
Function: MAP (result-type function sequence &rest more-sequences)
+

Package:LISP +

+

FUNCTION must take as many arguments as there are sequences provided. The +result is a sequence such that the i-th element is the result of applying +FUNCTION to the i-th elements of the SEQUENCEs. +

+ +
+ +
+
Constant: ARRAY-RANK-LIMIT
+

Package:LISP +The exclusive upper bound on the rank of an array. +

+ +
+ +
+
Function: COUNT (item sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (key #'identity))
+

Package:LISP +

+

Returns the number of elements in SEQUENCE satisfying TEST with ITEM. +

+ +
+ +
+
Function: BIT-VECTOR-P (x)
+

Package:LISP +

+

Returns T if X is a bit vector; NIL otherwise. +

+ +
+ +
+
Function: NSTRING-CAPITALIZE (string &key (start 0) (end (length string)))
+

Package:LISP +

+

Returns STRING with the first character of each word converted to upper-case, +and remaining characters in the word converted to lower case. +

+ +
+ +
+
Function: ADJUST-ARRAY (array dimensions &key (element-type (array-element-type array)) initial-element (initial-contents nil) (fill-pointer nil) (displaced-to nil) (displaced-index-offset 0))
+

Package:LISP +

+

Adjusts the dimensions of ARRAY to the given DIMENSIONS. The default value +of INITIAL-ELEMENT depends on ELEMENT-TYPE. +

+ +
+ +
+
Function: SEARCH (sequence1 sequence2 &key (from-end nil) (test #'eql) test-not (start1 0) (start2 0) (end1 (length sequence1)) (end2 (length sequence2)) (key #'identity))
+

Package:LISP +

+

A search is conducted for the first subsequence of SEQUENCE2 which +element-wise matches SEQUENCE1. If there is such a subsequence in SEQUENCE2, +the index of the its leftmost element is returned; otherwise, NIL is +returned. +

+ +
+ +
+
Function: SIMPLE-BIT-VECTOR-P (x)
+

Package:LISP +

+

Returns T if X is a simple bit-vector; NIL otherwise. +

+ +
+ +
+
Function: MAKE-SEQUENCE (type length &key initial-element)
+

Package:LISP +

+

Returns a sequence of the given TYPE and LENGTH, with elements initialized +to INITIAL-ELEMENT. The default value of INITIAL-ELEMENT depends on TYPE. +

+ +
+ +
+
Function: BIT-ORC2 (bit-array1 bit-array2 &optional (result-bit-array nil))
+

Package:LISP +

+

Performs a bit-wise logical ORC2 on the elements of BIT-ARRAY1 and BIT-ARRAY2. +Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into +BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. +

+ +
+ +
+
Function: NREVERSE (sequence)
+

Package:LISP +

+

Returns a sequence of the same elements as SEQUENCE but in reverse order. +SEQUENCE may be destroyed. +

+ +
+ +
+
Constant: ARRAY-DIMENSION-LIMIT
+

Package:LISP +The exclusive upper bound of the array dimension. +

+ +
+ +
+
Function: NOTEVERY (predicate sequence &rest more-sequences)
+

Package:LISP +

+

Returns T if at least one of the elements in SEQUENCEs does not satisfy +PREDICATE; NIL otherwise. +

+ +
+ +
+
Function: POSITION-IF-NOT (test sequence &key (from-end nil) (start 0) (end (length sequence)) (key #'identity))
+

Package:LISP +

+

Returns the index of the first element in SEQUENCE that does not satisfy TEST; +NIL if no such element exists. +

+ +
+ +
+
Function: STRING-DOWNCASE (string &key (start 0) (end (length string)))
+

Package:LISP +

+

Returns a copy of STRING with all upper case characters converted to +lowercase. +

+ +
+ +
+
Function: BIT (bit-array &rest subscripts)
+

Package:LISP +

+

Returns the bit from BIT-ARRAY at SUBSCRIPTS. +

+ +
+ +
+
Function: STRING-NOT-LESSP (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2)))
+

Package:LISP +

+

Similar to STRING>=, but ignores cases. +

+ +
+ +
+
Function: CHAR (string index)
+

Package:LISP +

+

Returns the INDEX-th character in STRING. +

+ +
+ +
+
Function: AREF (array &rest subscripts)
+

Package:LISP +

+

Returns the element of ARRAY specified by SUBSCRIPTS. +

+ +
+ +
+
Function: FILL (sequence item &key (start 0) (end (length sequence)))
+

Package:LISP +

+

Replaces the specified elements of SEQUENCE all with ITEM. +

+ +
+ +
+
Function: STABLE-SORT (sequence predicate &key (key #'identity))
+

Package:LISP +

+

Destructively sorts SEQUENCE. PREDICATE should return non-NIL if its first +argument is to precede its second argument. +

+ +
+ +
+
Function: BIT-IOR (bit-array1 bit-array2 &optional (result-bit-array nil))
+

Package:LISP +

+

Performs a bit-wise logical IOR on the elements of BIT-ARRAY1 and BIT-ARRAY2. +Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into +BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. +

+ +
+ +
+
Function: REMHASH (key hash-table)
+

Package:LISP +

+

Removes any entry for KEY in HASH-TABLE. Returns T if such an entry +existed; NIL otherwise. +

+ +
+ +
+
Function: VECTORP (x)
+

Package:LISP +

+

Returns T if X is a vector; NIL otherwise. +

+ +
+ +
+
Function: STRING<= (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2)))
+

Package:LISP +

+

If STRING1 is lexicographically less than or equal to STRING2, then returns +the longest common prefix of the two strings. Otherwise, returns NIL. +

+ +
+ +
+
Function: SIMPLE-VECTOR-P (x)
+

Package:LISP +

+

Returns T if X is a simple vector; NIL otherwise. +

+ +
+ +
+
Function: STRING-LEFT-TRIM (char-bag string)
+

Package:LISP +

+

Returns a copy of STRING with the characters in CHAR-BAG removed from the +left end. +

+ +
+ +
+
Function: ARRAY-TOTAL-SIZE (array)
+

Package:LISP +

+

Returns the total number of elements of ARRAY. +

+ +
+ +
+
Function: FIND-IF-NOT (test sequence &key (from-end nil) (start 0) (end (length sequence)) (key #'identity))
+

Package:LISP +

+

Returns the index of the first element in SEQUENCE that does not satisfy +TEST; NIL if no such element exists. +

+ +
+ +
+
Function: DELETE-DUPLICATES (sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (key #'identity))
+

Package:LISP +

+

Returns a sequence formed by removing duplicated elements destructively from +SEQUENCE. +

+ +
+ +
+
Function: REMOVE-DUPLICATES (sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (key #'identity))
+

Package:LISP +

+

The elements of SEQUENCE are examined, and if any two match, one is discarded. +Returns the resulting sequence. +

+ +
+ +
+
Function: POSITION-IF (test sequence &key (from-end nil) (start 0) (end (length sequence)) (key #'identity))
+

Package:LISP +

+

Returns the index of the first element in SEQUENCE that satisfies TEST; NIL +if no such element exists. +

+ +
+ +
+
Function: MERGE (result-type sequence1 sequence2 predicate &key (key #'identity))
+

Package:LISP +

+

SEQUENCE1 and SEQUENCE2 are destructively merged into a sequence of type +RESULT-TYPE using PREDICATE to order the elements. +

+ +
+ +
+
Function: EVERY (predicate sequence &rest more-sequences)
+

Package:LISP +

+

Returns T if every elements of SEQUENCEs satisfy PREDICATE; NIL otherwise. +

+ +
+ +
+
Function: REDUCE (function sequence &key (from-end nil) (start 0) (end (length sequence)) initial-value)
+

Package:LISP +

+

Combines all the elements of SEQUENCE using a binary operation FUNCTION. +If INITIAL-VALUE is supplied, it is logically placed before the SEQUENCE. +

+ +
+ +
+
Function: STRING-LESSP (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2)))
+

Package:LISP +

+

Similar to STRING<, but ignores cases. +

+ +
+ +
+
+

+Next: , Previous: , Up: Top   [Contents][Index]

+
+ + + + + diff --git a/info/gcl-si/Source-Level-Debugging-in-Emacs.html b/info/gcl-si/Source-Level-Debugging-in-Emacs.html new file mode 100644 index 0000000..1980d93 --- /dev/null +++ b/info/gcl-si/Source-Level-Debugging-in-Emacs.html @@ -0,0 +1,170 @@ + + + + +GCL SI Manual: Source Level Debugging in Emacs + + + + + + + + + + + + + + + + + + + + +
+

+Next: , Previous: , Up: Debugging   [Contents][Index]

+
+
+ +

18.1 Source Level Debugging in Emacs

+ +

In emacs load (load "dbl.el") from the gcl/doc directory. +[ It also requires gcl.el from that directory. Your system +administrator should do make in the doc directory, so that +these files are copied to the standard location.] +

+

OVERVIEW: +

+

Lisp files loaded with si::nload will have source line information about +them recorded. Break points may be set, and functions stepped. Source code +will be automatically displayed in the other window, with a little arrow beside +the current line. The backtrace (command :bt) will show line information and +you will get automatic display of the source as you move up and down the stack. +

+

FUNCTIONS: +break points which have been set. + si::nload (file) + load a lisp file collecting source line information. +

+

si::break-function (function &optional line absolute) + set up a breakpoint for FUNCTION at LINE relative to start or ABSOLUTE +

+

EMACS COMMANDS: +M-x dbl makes a dbl buffer, suitable for running an inferior gcl. +It has special keybindings for stepping and viewing sources. You may +start your favorite gcl program in the dbl shell buffer. +

+

Inferior Dbl Mode: +Major mode for interacting with an inferior Dbl process. +The following commands are available: +

+

C-c l dbl-find-line +

+

ESC d dbl-:down +ESC u dbl-:up +ESC c dbl-:r +ESC n dbl-:next +ESC i dbl-:step +ESC s dbl-:step +

+ +

M-x dbl-display-frame displays in the other window +the last line referred to in the dbl buffer. +

+

ESC i and ESC n in the dbl window, +call dbl to step and next and then update the other window +with the current file and position. +

+

If you are in a source file, you may select a point to break +at, by doing C-x SPC. +

+

Commands: +Many commands are inherited from shell mode. +Additionally we have: +

+

M-x dbl-display-frame display frames file in other window +ESC i advance one line in program +ESC n advance one line in program (skip over calls). +M-x send-dbl-command used for special printing of an arg at the current point. +C-x SPACE sets break point at current line. +

+

—————————- +

+

When visiting a lisp buffer (if gcl.el is loaded in your emacs) the command +c-m-x evaluates the current defun into the process running in the other window. +Line information will be kept. This line information allows you to set break +points at a given line (by typing C-x \space on the line in the source file +where you want the break to occur. Once stopped within a function you may +single step with M-s. This moves one line at a time in the source code, +displaying a little arrow beside your current position. M-c is like M-s, +except that function invocations are skipped over, rather than entered into. +M-c continues execution. +

+

Keywords typed at top level, in the debug loop have +a special meaning: +

    +
  • :delete [n1] [n2] .. – delete all break points or just n1,n2 +
  • :disable [n1] [n2] .. – disable all break points or just n1,n2 +
  • :enable [n1] [n2] .. – enable all break points or just n1,n2 +
  • :info [:bkpt] –print information about +
  • :break [fun] [line] – break at the current location, or if + fun is supplied in fun. Break at the beginning unless a + line offset from the beginning of fun is supplied. +
  • :fr [n] go to frame n When in frame n, if the frame is interpreted, + typing the name of locals, will print their values. If it is compiled + you must use (si::loc j) to print ‘locj’. Autodisplay of the source + will take place if it is interpreted and the line can be determined. +
  • :up [n] go up n frames from the current frame. +
  • :down [n] go down n frames +
  • :bt [n] back trace starting at the current frame and going to top level + If n is specified show only n frames. +
  • :r If stopped in a function resume. If at top level in the dbl + loop, exit and resume an outer loop. +
  • :q quit the computation back to top level dbl loop. +
  • :step step to the next line with line information +
  • :next step to the next line with line information skipping over function + invocations. + +
+

Files: debug.lsp dbl.el gcl.el +

+
+
+

+Next: , Previous: , Up: Debugging   [Contents][Index]

+
+ + + + + diff --git a/info/gcl-si/Special-Forms-and-Functions.html b/info/gcl-si/Special-Forms-and-Functions.html new file mode 100644 index 0000000..84e2d33 --- /dev/null +++ b/info/gcl-si/Special-Forms-and-Functions.html @@ -0,0 +1,1279 @@ + + + + +GCL SI Manual: Special Forms and Functions + + + + + + + + + + + + + + + + + + + + +
+

+Next: , Previous: , Up: Top   [Contents][Index]

+
+
+ +

6 Special Forms and Functions

+ +
+
Constant: LAMBDA-LIST-KEYWORDS
+

Package:LISP +List of all the lambda-list keywords used in GCL. +

+ +
+ +
+
Function: GET-SETF-METHOD (form)
+

Package:LISP +

+

Returns the five values (or five ’gangs’) constituting the SETF method for +FORM. See the doc of DEFINE-SETF-METHOD for the meanings of the gangs. It +is an error if the third value (i.e., the list of store variables) is not a +one-element list. See the doc of GET-SETF-METHOD-MULTIPLE-VALUE for +comparison. +

+ +
+ +
+
Special Form: THE
+

Package:LISP +

+

Syntax: +

+
(the value-type form)
+
+ +

Declares that the value of FORM must be of VALUE-TYPE. Signals an error if +this is not the case. +

+ +
+ +
+
Special Form: SETF
+

Package:LISP +

+

Syntax: +

+
(setf {place newvalue}*)
+
+ +

Replaces the value in PLACE with the value of NEWVALUE, from left to right. +Returns the value of the last NEWVALUE. 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-poiter
+get	getf	documentation	symbol-value	symbol-function
+symbol-plist	macro-function	gethash
+char-bit	ldb	mask-field
+apply
+
    +

    where ’?’ stands for either ’a’ or ’d’. +

  • the form (THE type place) with PLACE being a place recognized by SETF. +
  • a macro call which expands to a place recognized by SETF. +
  • any form for which a DEFSETF or DEFINE-SETF-METHOD declaration has been + made. +
+ +
+ +
+
Special Form: WHEN
+

Package:LISP +

+

Syntax: +

+
(when test {form}*)
+
+ +

If TEST evaluates to non-NIL, then evaluates FORMs as a PROGN. If not, +simply returns NIL. +

+ +
+ +
+
Macro: CCASE
+

Package:LISP +

+

Syntax: +

+
(ccase keyplace {({key | ({key}*)} {form}*)}*)
+
+ +

Evaluates KEYPLACE and tries to find the KEY that is EQL to the value of +KEYPLACE. If one is found, then evaluates FORMs that follow the KEY and +returns the value(s) of the last FORM. If not, signals a correctable error. +

+ +
+ +
+
Function: MACROEXPAND (form &optional (env nil))
+

Package:LISP +

+

If FORM is a macro form, then expands it repeatedly until it is not a macro +any more. Returns two values: the expanded form and a T-or-NIL flag +indicating whether the original form was a macro. +

+ +
+ +
+
Special Form: MULTIPLE-VALUE-CALL
+

Package:LISP +

+

Syntax: +

+
(multiple-value-call function {form}*)
+
+ +

Calls FUNCTION with all the values of FORMs as arguments. +

+ +
+ +
+
Macro: DEFSETF
+

Package:LISP +

+

Syntax: +

+
(defsetf access-fun {update-fun [doc] |
+                             lambda-list (store-var) {decl | doc}*
+{form}*)
+
+ +

Defines how to SETF a generalized-variable reference of the form +(ACCESS-FUN ...). The doc-string DOC, if supplied, is saved as a SETF doc and +can be retrieved by (documentation ’NAME ’setf). +

+
+
(defsetf access-fun update-fun) defines an expansion from
+(setf (ACCESS-FUN arg1 ... argn) value) to (UPDATE-FUN arg1 ... argn value).
+
+(defsetf access-fun lambda-list (store-var) . body) defines a macro which
+
+

expands +

+
+
(setf (ACCESS-FUN arg1 ... argn) value) into the form
+	(let* ((temp1 ARG1) ... (tempn ARGn) (temp0 value)) rest)
+
+

where REST is the value of BODY with parameters in LAMBDA-LIST bound to the +symbols TEMP1 ... TEMPn and with STORE-VAR bound to the symbol TEMP0. +

+
+ +
+
Special Form: TAGBODY
+

Package:LISP +

+

Syntax: +

+
(tagbody {tag | statement}*)
+
+ +

Executes STATEMENTs and returns NIL if it falls off the end. +

+ +
+ + +
+
Macro: ETYPECASE
+

Package:LISP +

+

Syntax: +

+
(etypecase keyform {(type {form}*)}*)
+
+ +

Evaluates KEYFORM and tries to find the TYPE in which the value of KEYFORM +belongs. If one is found, then evaluates FORMs that follow the KEY and +returns the value(s) of the last FORM. If not, signals an error. +

+ +
+ +
+
Special Form: LET*
+

Package:LISP +

+

Syntax: +

+
(let* ({var | (var [value])}*) {decl}* {form}*)
+
+ +

Initializes VARs, binding them to the values of VALUEs (which defaults to NIL) +from left to right, then evaluates FORMs as a PROGN. +

+ +
+ +
+
Special Form: PROG1
+

Package:LISP +

+

Syntax: +

+
(prog1 first {form}*)
+
+ +

Evaluates FIRST and FORMs in order, and returns the (single) value of FIRST. +

+ +
+ +
+
Special Form: DEFUN
+

Package:LISP +

+

Syntax: +

+
(defun name lambda-list {decl | doc}* {form}*)
+
+ +

Defines a function as the global function definition of the symbol NAME. +The complete syntax of a lambda-list is: + ({var}* + [&optional {var | (var [initform [svar]])}*] + [&rest var] + [&key {var | ({var | (keyword var)} [initform [svar]])}* + [&allow-other-keys]] + [&aux {var | (var [initform])}*]) +The doc-string DOC, if supplied, is saved as a FUNCTION doc and can be +retrieved by (documentation ’NAME ’function). +

+ +
+ +
+
Special Form: MULTIPLE-VALUE-BIND
+

Package:LISP +

+

Syntax: +

+
(multiple-value-bind ({var}*) values-form {decl}* {form}*)
+
+ +

Binds the VARiables to the results of VALUES-FORM, in order (defaulting to +NIL) and evaluates FORMs in order. +

+ +
+ +
+
Special Form: DECLARE
+

Package:LISP +

+

Syntax: +

+
(declare {decl-spec}*)
+
+ +

Gives a declaration. Possible DECL-SPECs are: + (SPECIAL {var}*) + (TYPE type {var}*) + where ’TYPE’ is one of the following symbols +

+
array		fixnum		package		simple-bit-vector
+atom		float		pathname	simple-string
+bignum		function	random-state	simple-vector
+bit		hash-table	ratio		single-float
+bit-vector	integer		rational	standard-char
+character	keyword		readtable	stream
+common		list		sequence	string
+compiled-function  long-float	short-float	string-char
+complex		nil		signed-byte	symbol
+cons		null		unsigned-byte	t
+double-float	number		simple-array	vector
+
+

’TYPE’ may also be a list containing one of the above symbols as +its first element and more specific information later in the list. +For example +

+
(vector long-float 80) ; vector of 80 long-floats.
+(array long-float *)   ; array of long-floats
+(array fixnum)         ; array of fixnums
+(array * 30)           ; an array of length 30 but unspecified type
+
+ +

A list of 1 element may be replaced by the symbol alone, and a list ending + in ’*’ may drop the the final ’*’. +

+
(OBJECT {var}*)
+(FTYPE type {function-name}*)
+    eg: ;; function of two required args and optional args and one value:
+     (ftype (function (t t *) t) sort reduce)
+        ;; function with 1 arg of general type returning 1 fixnum as value.
+     (ftype (function (t) fixnum) length)
+(FUNCTION function-name ({arg-type}*) {return-type}*)
+(INLINE {function-name}*)
+(NOTINLINE {function-name}*)
+(IGNORE {var}*)
+(OPTIMIZE {({SPEED | SPACE | SAFETY | COMPILATION-SPEED} {0 | 1 | 2 | 3})}*)
+(DECLARATION {non-standard-decl-name}*)
+(:DYNAMIC-EXTENT {var}*) ;GCL-specific.
+
+ +
+ +
+
Special Form: DEFMACRO
+

Package:LISP +

+

Syntax: +

+
(defmacro name defmacro-lambda-list {decl | doc}* {form}*)
+
+ +

Defines a macro as the global macro definition of the symbol NAME. +The complete syntax of a defmacro-lambda-list is: +

+

( [&whole var] + [&environment var] + {pseudo-var}* + [&optional {var | (pseudo-var [initform [pseudo-var]])}*] + {[{&rest | &body} pseudo-var] + [&key {var | ({var | (keyword pseudo-var)} [initform [pseudo-var]])}* + [&allow-other-keys]] + [&aux {var | (pseudo-var [initform])}*] + | . var}) +

+

where pseudo-var is either a symbol or a list of the following form: +

+

( {pseudo-var}* + [&optional {var | (pseudo-var [initform [pseudo-var]])}*] + {[{&rest | &body} pseudo-var] + [&key {var | ({var | (keyword pseudo-var)} [initform [pseudo-var]])}* + [ &allow-other-keys ] ] + [&aux {var | (pseudo-var [initform])}*] + | . var}) +

+

As a special case, a non-NIL symbol is accepcted as a defmacro-lambda-list: +(DEFMACRO <name> <symbol> ...) is equivalent to +(DEFMACRO <name> (&REST <symbol>) ...). + The doc-string DOC, if supplied, is saved as a FUNCTION doc and can be +retrieved by (documentation ’NAME ’function). +See the type doc of LIST for the backquote macro useful for defining macros. +Also, see the function doc of PPRINT for the output-formatting. +

+ +
+ +
+
Variable: *EVALHOOK*
+

Package:LISP +If *EVALHOOK* is not NIL, its value must be a function that can receive +two arguments: a form to evaluate and an environment. This function does +the evaluation instead of EVAL. +

+ +
+ +
+
Function: FUNCTIONP (x)
+

Package:LISP +

+

Returns T if X is a function, suitable for use by FUNCALL or APPLY. Returns +NIL otherwise. +

+ +
+ +
+
Constant: LAMBDA-PARAMETERS-LIMIT
+

Package:LISP +The exclusive upper bound on the number of distinct parameter names that may +appear in a single lambda-list. Actually, however, there is no such upper +bound in GCL. +

+ +
+ +
+
Special Form: FLET
+

Package:LISP +

+

Syntax: +

+
(flet ({(name lambda-list {decl | doc}* {form}*)}*) . body)
+
+ +

Evaluates BODY as a PROGN, with local function definitions in effect. BODY is +the scope of each local function definition. Since the scope does not include +the function definitions themselves, the local function can reference +externally defined functions of the same name. See the doc of DEFUN for the +complete syntax of a lambda-list. Doc-strings for local functions are simply +ignored. +

+ +
+ +
+
Macro: ECASE
+

Package:LISP +

+

Syntax: +

+
(ecase keyform {({key | ({key}*)} {form}*)}*)
+
+ +

Evaluates KEYFORM and tries to find the KEY that is EQL to the value of +KEYFORM. If one is found, then evaluates FORMs that follow the KEY and +returns the value(s) of the last FORM. If not, signals an error. +

+ +
+ +
+
Special Form: PROG2
+

Package:LISP +

+

Syntax: +

+
(prog2 first second {forms}*)
+
+ +

Evaluates FIRST, SECOND, and FORMs in order, and returns the (single) value +of SECOND. +

+ +
+ +
+
Special Form: PROGV
+

Package:LISP +

+

Syntax: +

+
(progv symbols values {form}*)
+
+ +

SYMBOLS must evaluate to a list of variables. VALUES must evaluate to a list +of initial values. Evaluates FORMs as a PROGN, with each variable bound (as +special) to the corresponding value. +

+ +
+ +
+
Special Form: QUOTE
+

Package:LISP +

+

Syntax: +

+
(quote x)
+
+

or ’x +Simply returns X without evaluating it. +

+ +
+ +
+
Special Form: DOTIMES
+

Package:LISP +

+

Syntax: +

+
(dotimes (var countform [result]) {decl}* {tag | statement}*)
+
+ +

Executes STATEMENTs, with VAR bound to each number between 0 (inclusive) and +the value of COUNTFORM (exclusive). Then returns the value(s) of RESULT +(which defaults to NIL). +

+ +
+ +
+
Function: SPECIAL-FORM-P (symbol)
+

Package:LISP +

+

Returns T if SYMBOL globally names a special form; NIL otherwise. +The special forms defined in Steele’s manual 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
+
+ +

In addition, GCL 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* 
+
+ + +
+ +
+
Special Form: FUNCTION
+

Package:LISP +

+

Syntax: +

+
(function x)
+
+

or #’x +If X is a lambda expression, creates and returns a lexical closure of X in +the current lexical environment. If X is a symbol that names a function, +returns that function. +

+ +
+ +
+
Constant: MULTIPLE-VALUES-LIMIT
+

Package:LISP +The exclusive upper bound on the number of values that may be returned from +a function. Actually, however, there is no such upper bound in GCL. +

+ +
+ +
+
Function: APPLYHOOK (function args evalhookfn applyhookfn &optional (env nil))
+

Package:LISP +

+

Applies FUNCTION to ARGS, with *EVALHOOK* bound to EVALHOOKFN and with +*APPLYHOOK* bound to APPLYHOOKFN. Ignores the hook function once, for the +top-level application of FUNCTION to ARGS. +

+ +
+ +
+
Variable: *MACROEXPAND-HOOK*
+

Package:LISP +Holds a function that can take two arguments (a macro expansion function +and the macro form to be expanded) and returns the expanded form. This +function is whenever a macro-expansion takes place. Initially this is set to +#’FUNCALL. +

+ +
+ +
+
Special Form: PROG*
+

Package:LISP +

+

Syntax: +

+
(prog* ({var | (var [init])}*) {decl}* {tag | statement}*)
+
+ +

Creates a NIL block, binds VARs sequentially, and then executes STATEMENTs. +

+ +
+ +
+
Special Form: BLOCK
+

Package:LISP +

+

Syntax: +

+
(block name {form}*)
+
+ +

The FORMs are evaluated in order, but it is possible to exit the block +using (RETURN-FROM name value). The RETURN-FROM must be lexically contained +within the block. +

+ +
+ +
+
Special Form: PROGN
+

Package:LISP +

+

Syntax: +

+
(progn {form}*)
+
+ +

Evaluates FORMs in order, and returns whatever the last FORM returns. +

+ +
+ +
+
Function: APPLY (function arg &rest more-args)
+

Package:LISP +

+

Applies FUNCTION. The arguments to the function consist of all ARGs +except for the last, and all elements of the last ARG. +

+ +
+ +
+
Special Form: LABELS
+

Package:LISP +

+

Syntax: +

+
(labels ({(name lambda-list {decl | doc}* {form}*)}*) . body)
+
+ +

Evaluates BODY as a PROGN, with the local function definitions in effect. The +scope of the locally defined functions include the function definitions +themselves, so their definitions may include recursive references. See the doc +of DEFUN for the complete syntax of a lambda-list. Doc-strings for local +functions are simply ignored. +

+ +
+ +
+
Special Form: RETURN
+

Package:LISP +

+

Syntax: +

+
(return [result])
+
+ +

Returns from the lexically surrounding NIL block. The value of RESULT, +which defaults to NIL, is returned as the value of the block. +

+ +
+ +
+
Macro: TYPECASE
+

Package:LISP +

+

Syntax: +

+
(typecase keyform {(type {form}*)}*)
+
+ +

Evaluates KEYFORM and tries to find the TYPE in which the value of KEYFORM +belongs. If one is found, then evaluates FORMs that follow the KEY and +returns the value of the last FORM. If not, simply returns NIL. +

+ +
+ +
+
Special Form: AND
+

Package:LISP +

+

Syntax: +

+
(and {form}*)
+
+ +

Evaluates FORMs in order from left to right. If any FORM evaluates to NIL, +returns immediately with the value NIL. Else, returns the value(s) of the +last FORM. +

+ +
+ +
+
Special Form: LET
+

Package:LISP +

+

Syntax: +

+
(let ({var | (var [value])}*) {decl}* {form}*)
+
+ +

Initializes VARs, binding them to the values of VALUEs (which defaults to NIL) +all at once, then evaluates FORMs as a PROGN. +

+ +
+ +
+
Special Form: COND
+

Package:LISP +

+

Syntax: +

+
(cond {(test {form}*)}*)
+
+

Evaluates each +TEST in order until one evaluates to a non-NIL value. Then evaluates +the associated FORMs in order and returns the value(s) of the last +FORM. If no forms follow the TEST, then returns the value of the +TEST. Returns NIL, if all TESTs evaluate to NIL. +

+ +
+ +
+
Function: GET-SETF-METHOD-MULTIPLE-VALUE (form)
+

Package:LISP + Returns the five values (or five ’gangs’) +constituting the SETF method for FORM. See the doc of +DEFINE-SETF-METHOD for the meanings of the gangs. The third value +(i.e., the list of store variables) may consist of any number of +elements. See the doc of GET-SETF-METHOD for +comparison. +

+ +
+ +
+
Special Form: CATCH
+

Package:LISP +

+

Syntax: +

+
(catch tag {form}*)
+
+ +

Sets up a catcher with +that value TAG. Then evaluates FORMs as a PROGN, but may possibly +abort the evaluation by a THROW form that specifies the value EQ to +the catcher tag. +

+ +
+ +
+
Macro: DEFINE-MODIFY-MACRO
+

Package:LISP +

+

Syntax: +

+
(define-modify-macro name lambda-list fun [doc])
+
+ +

Defines a read-modify-write macro, like PUSH and INCF. The defined macro will +expand a form (NAME place val1 ... valn) into a form that in effect SETFs the +value of the call (FUN PLACE arg1 ... argm) into PLACE, where arg1 ... argm +are parameters in LAMBDA-LIST which are bound to the forms VAL1 ... VALn. +The doc-string DOC, if supplied, is saved as a FUNCTION doc and can be +retrieved by (documentation ’NAME ’function). +

+ +
+ +
+
Function: MACROEXPAND-1 (form &optional (env nil))
+

Package:LISP +

+

If FORM is a macro form, then expands it once. Returns two values: the +expanded form and a T-or-NIL flag indicating whether the original form was +a macro. +

+ +
+ +
+
Function: FUNCALL (function &rest arguments)
+

Package:LISP +

+

Applies FUNCTION to the ARGUMENTs +

+ +
+ +
+
Constant: CALL-ARGUMENTS-LIMIT
+

Package:LISP +The upper exclusive bound on the number of arguments that may be passed to +a function. Actually, however, there is no such upper bound in GCL. +

+ +
+ +
+
Special Form: CASE
+

Package:LISP +

+

Syntax: +

+
(case keyform {({key | ({key}*)} {form}*)}*)
+
+ +

Evaluates KEYFORM and tries to find the KEY that is EQL to the value of +KEYFORM. If one is found, then evaluates FORMs that follow the KEY and +returns the value(s) of the last FORM. If not, simply returns NIL. +

+ +
+ +
+
Macro: DEFINE-SETF-METHOD
+

Package:LISP +

+

Syntax: +

+
(define-setf-method access-fun defmacro-lambda-list {decl | doc}*
+          {form}*)
+
+ +

Defines how to SETF a generalized-variable reference of the form +(ACCESS-FUN ...). When a form (setf (ACCESS-FUN arg1 ... argn) value) is +being evaluated, the FORMs are first evaluated as a PROGN with the parameters +in DEFMACRO-LAMBDA-LIST bound to ARG1 ... ARGn. Assuming that the last FORM +returns five values + (temp-var-1 ... temp-var-k) + (value-from-1 ... value-form-k) + (store-var) + storing-form + access-form +in order, the whole SETF is then expanded into + (let* ((temp-var-1 value-from-1) ... (temp-k value-form-k) + (store-var VALUE)) + storing-from) +Incidentally, the five values are called the five gangs of a SETF method. +The doc-string DOC, if supplied, is saved as a SETF doc and can be retrieved +by (documentation ’NAME ’setf). +

+ +
+ +
+
Special Form: COMPILER-LET
+

Package:LISP +

+

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 +time, but no bindings occur when the compiled code is executed. +

+ +
+ +
+
Function: VALUES (&rest args)
+

Package:LISP +

+

Returns ARGs in order, as values. +

+ +
+ +
+
Special Form: MULTIPLE-VALUE-LIST
+

Package:LISP +

+

Syntax: +

+
(multiple-value-list form)
+
+ +

Evaluates FORM, and returns a list of multiple values it returned. +

+ +
+ +
+
Special Form: MULTIPLE-VALUE-PROG1
+

Package:LISP +

+

Syntax: +

+
(multiple-value-prog1 form {form}*)
+
+ +

Evaluates the first FORM, saves all the values produced, then evaluates +the other FORMs. Returns the saved values. +

+ +
+ +
+
Special Form: MACROLET
+

Package:LISP +

+

Syntax: +

+
(macrolet ({(name defmacro-lambda-list {decl | doc}* . body)}*)
+          {form}*)
+
+ +

Evaluates FORMs as a PROGN, with the local macro definitions in effect. +See the doc of DEFMACRO for the complete syntax of a defmacro-lambda-list. +Doc-strings for local macros are simply ignored. +

+ +
+ +
+
Special Form: GO
+

Package:LISP +

+

Syntax: +

+
(go tag)
+
+ +

Jumps to the specified TAG established by a lexically surrounding TAGBODY. +

+ +
+ +
+
Special Form: PROG
+

Package:LISP +

+

Syntax: +

+
(prog ({var | (var [init])}*) {decl}* {tag | statement}*)
+
+ +

Creates a NIL block, binds VARs in parallel, and then executes STATEMENTs. +

+ +
+ +
+
Variable: *APPLYHOOK*
+

Package:LISP +Used to substitute another function for the implicit APPLY normally done +within EVAL. If *APPLYHOOK* is not NIL, its value must be a function +which takes three arguments: a function to be applied, a list of arguments, +and an environment. This function does the application instead of APPLY. +

+ +
+ +
+
Special Form: RETURN-FROM
+

Package:LISP +

+

Syntax: +

+
(return-from name [result])
+
+ +

Returns from the lexically surrounding block whose name is NAME. The value +of RESULT, which defaults to NIL, is returned as the value of the block. +

+ +
+ +
+
Special Form: UNLESS
+

Package:LISP +

+

Syntax: +

+
(unless test {form}*)
+
+ +

If TEST evaluates to NIL, then evaluates FORMs as a PROGN. If not, +simply returns NIL. +

+ +
+ +
+
Special Form: MULTIPLE-VALUE-SETQ
+

Package:LISP +

+

Syntax: +

+
(multiple-value-setq variables form)
+
+ +

Sets each variable in the list VARIABLES to the corresponding value of FORM. +Returns the value assigned to the first variable. +

+ +
+ +
+
Special Form: LOCALLY
+

Package:LISP +

+

Syntax: +

+
(locally {decl}* {form}*)
+
+ +

Gives local pervasive declarations. +

+ +
+ +
+
Function: IDENTITY (x)
+

Package:LISP +

+

Simply returns X. +

+ +
+ +
+
Function: NOT (x)
+

Package:LISP +

+

Returns T if X is NIL; NIL otherwise. +

+ +
+ +
+
Macro: DEFCONSTANT
+

Package:LISP +

+

Syntax: +

+
(defconstant name initial-value [doc])
+
+ +

Declares that the variable NAME is a constant whose value is the value of +INITIAL-VALUE. The doc-string DOC, if supplied, is saved as a VARIABLE doc +and can be retrieved by (documentation ’NAME ’variable). +

+ +
+ +
+
Function: VALUES-LIST (list)
+

Package:LISP +

+

Returns all of the elements of LIST in order, as values. +

+ +
+ +
+
Function: ERROR (control-string &rest args)
+

Package:LISP +

+

Signals a fatal error. +

+ +
+ +
+
Special Form: IF
+

Package:LISP +

+

Syntax: +

+
(if test then [else])
+
+ +

If TEST evaluates to non-NIL, then evaluates THEN and returns the result. +If not, evaluates ELSE (which defaults to NIL) and returns the result. +

+ +
+ +
+
Special Form: UNWIND-PROTECT
+

Package:LISP +

+

Syntax: +

+
(unwind-protect protected-form {cleanup-form}*)
+
+ +

Evaluates PROTECTED-FORM and returns whatever it returned. Guarantees that +CLEANUP-FORMs be always evaluated before exiting from the UNWIND-PROTECT +form. +

+ +
+ +
+
Function: EVALHOOK (form evalhookfn applyhookfn &optional (env nil))
+

Package:LISP +

+

Evaluates FORM with *EVALHOOK* bound to EVALHOOKFN and *APPLYHOOK* bound +to APPLYHOOKFN. Ignores these hooks once, for the top-level evaluation +of FORM. +

+ +
+ +
+
Special Form: OR
+

Package:LISP +

+

Syntax: +

+
(or {form}*)
+
+ +

Evaluates FORMs in order from left to right. If any FORM evaluates to +non-NIL, quits and returns that (single) value. If the last FORM is reached, +returns whatever values it returns. +

+ +
+ +
+
Macro: CTYPECASE
+

Package:LISP +

+

Syntax: +

+
(ctypecase keyplace {(type {form}*)}*)
+
+ +

Evaluates KEYPLACE and tries to find the TYPE in which the value of KEYPLACE +belongs. If one is found, then evaluates FORMs that follow the KEY and +returns the value(s) of the last FORM. If not, signals a correctable error. +

+ +
+ +
+
Function: EVAL (exp)
+

Package:LISP +

+

Evaluates EXP and returns the result(s). +

+ +
+ +
+
Macro: PSETF
+

Package:LISP +

+

Syntax: +

+
(psetf {place newvalue}*)
+
+ +

Similar to SETF, but evaluates all NEWVALUEs first, and then replaces the +value in each PLACE with the value of the corresponding NEWVALUE. Returns +NIL always. +

+ +
+ +
+
Special Form: THROW
+

Package:LISP +

+

Syntax: +

+
(throw tag result)
+
+ +

Evaluates TAG and aborts the execution of the most recent CATCH form that sets +up a catcher with the same tag value. The CATCH form returns whatever RESULT +returned. +

+ +
+ +
+
Macro: DEFPARAMETER
+

Package:LISP +

+

Syntax: +

+
(defparameter name initial-value [doc])
+
+ +

Declares the variable NAME as a special variable and initializes the value. +The doc-string DOC, if supplied, is saved as a VARIABLE doc and can be +retrieved by (documentation ’NAME ’variable). +

+ +
+ +
+
Macro: DEFVAR
+

Package:LISP +

+

Syntax: +

+
(defvar name [initial-value [doc]])
+
+ +

Declares the variable NAME as a special variable and, optionally, initializes +it. The doc-string DOC, if supplied, is saved as a VARIABLE doc and can be +retrieved by (documentation ’NAME ’variable). +

+ +
+ +
+
+

+Next: , Previous: , Up: Top   [Contents][Index]

+
+ + + + + diff --git a/info/gcl-si/Streams-and-Reading.html b/info/gcl-si/Streams-and-Reading.html new file mode 100644 index 0000000..86acf5d --- /dev/null +++ b/info/gcl-si/Streams-and-Reading.html @@ -0,0 +1,1174 @@ + + + + +GCL SI Manual: Streams and Reading + + + + + + + + + + + + + + + + + + + + +
+

+Next: , Previous: , Up: Top   [Contents][Index]

+
+
+ +

5 Streams and Reading

+ +
+
Function: MAKE-ECHO-STREAM (input-stream output-stream)
+

Package:LISP +

+

Returns a bidirectional stream which gets its input from INPUT-STREAM and +sends its output to OUTPUT-STREAM. In addition, all input is echoed to +OUTPUT-STREAM. +

+ +
+ +
+
Variable: *READTABLE*
+

Package:LISP +The current readtable. +

+ +
+ +
+
Function: LOAD (filename &key (verbose *load-verbose*) (print nil) (if-does-not-exist :error))
+

Package:LISP +

+

Loads the file named by FILENAME into GCL. +

+ +
+ +
+
Function: OPEN (filename &key (direction :input) (element-type 'string-char) (if-exists :error) (if-does-not-exist :error))
+

Package:LISP +

+

Opens the file specified by FILENAME, which may be a string, a pathname, +or a stream. Returns a stream for the open file. +DIRECTION is :INPUT, :OUTPUT, :IO or :PROBE. +ELEMENT-TYPE is STRING-CHAR, (UNSIGNED-BYTE n), +UNSIGNED-BYTE, (SIGNED-BYTE n), SIGNED-BYTE, CHARACTER, BIT, (MOD n), or +:DEFAULT. +IF-EXISTS is :ERROR, :NEW-VERSION, :RENAME, +:RENAME-AND-DELETE, :OVERWRITE, :APPEND, :SUPERSEDE, or NIL. +IF-DOES-NOT-EXIST is :ERROR, :CREATE, or NIL. +

+

If FILENAME begins with a vertical pipe sign: ’|’ then the resulting +stream is actually a one way pipe. It will be open for reading +or writing depending on the direction given. The rest +of FILENAME in this case is passed to the /bin/sh command. See +the posix description of popen for more details. +

+
(setq pipe (open "| wc < /tmp/jim"))
+(format t "File has ~%d lines" (read pipe))
+(close pipe)
+
+ +
+ +
+
Variable: *PRINT-BASE*
+

Package:LISP +The radix in which the GCL printer prints integers and rationals. +The value must be an integer from 2 to 36, inclusive. +

+ +
+ +
+
Function: MAKE-STRING-INPUT-STREAM (string &optional (start 0) (end (length string)))
+

Package:LISP +

+

Returns an input stream which will supply the characters of String between +Start and End in order. +

+ +
+ +
+
Function: PPRINT (object &optional (stream *standard-output*))
+

Package:LISP +

+

Pretty-prints OBJECT. Returns OBJECT. Equivalent to + (WRITE :STREAM STREAM :PRETTY T) +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) +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. +

+ +
+ +
+
Variable: *READ-DEFAULT-FLOAT-FORMAT*
+

Package:LISP +The floating-point format the GCL reader uses when reading floating-point +numbers that have no exponent marker or have e or E for an exponent marker. +Must be one of SHORT-FLOAT, SINGLE-FLOAT, DOUBLE-FLOAT, and LONG-FLOAT. +

+ +
+ +
+
Function: READ-PRESERVING-WHITESPACE (&optional (stream *standard-input*) (eof-error-p t) (eof-value nil) (recursive-p nil))
+

Package:LISP +

+

Reads an object from STREAM, preserving the whitespace that followed the +object. +

+ +
+ +
+
Function: STREAMP (x)
+

Package:LISP +

+

Returns T if X is a stream object; NIL otherwise. +

+ +
+ + +
+
Function: SET-DISPATCH-MACRO-CHARACTER (disp-char sub-char function &optional (readtable *readtable*))
+

Package:LISP +

+

Causes FUNCTION to be called when the DISP-CHAR followed by SUB-CHAR is +read. +

+ +
+ +
+
Macro: WITH-OUTPUT-TO-STRING
+

Package:LISP +

+

Syntax: +

+
(with-output-to-string (var [string]) {decl}* {form}*)
+
+ +

Binds VAR to a string output stream that puts characters into STRING, which +defaults to a new string. The stream is automatically closed on exit and +the string is returned. +

+ +
+ +
+
Function: FILE-LENGTH (file-stream)
+

Package:LISP +

+

Returns the length of the specified file stream. +

+ +
+ +
+
Variable: *PRINT-CASE*
+

Package:LISP +The case in which the GCL printer should print ordinary symbols. +The value must be one of the keywords :UPCASE, :DOWNCASE, and :CAPITALIZE. +

+ +
+ +
+
Function: PRINT (object &optional (stream *standard-output*))
+

Package:LISP +

+

Outputs a newline character, and then prints OBJECT in the mostly readable +representation. Returns OBJECT. Equivalent to + (PROGN (TERPRI STREAM) (WRITE OBJECT :STREAM STREAM :ESCAPE T)). +

+ +
+ +
+
Function: SET-MACRO-CHARACTER (char function &optional (non-terminating-p nil) (readtable *readtable*))
+

Package:LISP +

+

Causes CHAR to be a macro character that, when seen by READ, causes FUNCTION +to be called. +

+ +
+ +
+
Function: FORCE-OUTPUT (&optional (stream *standard-output*))
+

Package:LISP +

+

Attempts to force any buffered output to be sent. +

+ +
+ +
+
Variable: *PRINT-ARRAY*
+

Package:LISP +Whether the GCL printer should print array elements. +

+ +
+ +
+
Function: STREAM-ELEMENT-TYPE (stream)
+

Package:LISP +

+

Returns a type specifier for the kind of object returned by STREAM. +

+ +
+ +
+
Function: WRITE-BYTE (integer stream)
+

Package:LISP +

+

Outputs INTEGER to the binary stream STREAM. Returns INTEGER. +

+ +
+ +
+
Function: MAKE-CONCATENATED-STREAM (&rest streams)
+

Package:LISP +

+

Returns a stream which takes its input from each of the STREAMs in turn, +going on to the next at end of stream. +

+ +
+ +
+
Function: PRIN1 (object &optional (stream *standard-output*))
+

Package:LISP +

+

Prints OBJECT in the mostly readable representation. Returns OBJECT. +Equivalent to (WRITE OBJECT :STREAM STREAM :ESCAPE T). +

+ +
+ +
+
Function: PRINC (object &optional (stream *standard-output*))
+

Package:LISP +

+

Prints OBJECT without escape characters. Returns OBJECT. Equivalent to + (WRITE OBJECT :STREAM STREAM :ESCAPE NIL). +

+ +
+ +
+
Function: CLEAR-OUTPUT (&optional (stream *standard-output*))
+

Package:LISP +

+

Clears the output stream STREAM. +

+ +
+ +
+
Function: TERPRI (&optional (stream *standard-output*))
+

Package:LISP +

+

Outputs a newline character. +

+ +
+ +
+
Function: FINISH-OUTPUT (&optional (stream *standard-output*))
+

Package:LISP +

+

Attempts to ensure that all output sent to STREAM has reached its destination, +and only then returns. +

+ +
+ +
+
Macro: WITH-OPEN-FILE
+

Package:LISP +

+

Syntax: +

+
(with-open-file (stream filename {options}*) {decl}* {form}*)
+
+ +

Opens the file whose name is FILENAME, using OPTIONs, and binds the variable +STREAM to a stream to/from the file. Then evaluates FORMs as a PROGN. +The file is automatically closed on exit. +

+ +
+ +
+
Special Form: DO
+

Package:LISP +

+

Syntax: +

+
(do ({(var [init [step]])}*) (endtest {result}*)
+          {decl}* {tag | statement}*)
+
+ +

Creates a NIL block, binds each VAR to the value of the corresponding INIT, +and then executes STATEMENTs repeatedly until ENDTEST is satisfied. After +each iteration, assigns to each VAR the value of the corresponding STEP. When +ENDTEST is satisfied, evaluates RESULTs as a PROGN and returns the value(s) of +the last RESULT (or NIL if no RESULTs are supplied). Performs variable +bindings and assignments all at once, just like LET and PSETQ do. +

+ +
+ +
+
Function: READ-FROM-STRING (string &optional (eof-error-p t) (eof-value nil) &key (start 0) (end (length string)) (preserve-whitespace nil))
+

Package:LISP +

+

Reads an object from STRING. +

+ +
+ +
+
Function: WRITE-STRING (string &optional (stream *standard-output*) &key (start 0) (end (length string)))
+

Package:LISP +

+

Outputs STRING and returns it. +

+ +
+ +
+
Variable: *PRINT-LEVEL*
+

Package:LISP +How many levels deep the GCL printer should print. Unlimited if NIL. +

+ +
+ +
+
Variable: *PRINT-RADIX*
+

Package:LISP +Whether the GCL printer should print the radix indicator when printing +integers and rationals. +

+ +
+ +
+
Function: Y-OR-N-P (&optional (format-string nil) &rest args)
+

Package:LISP +

+

Asks the user a question whose answer is either ’Y’ or ’N’. If FORMAT-STRING +is non-NIL, then FRESH-LINE operation is performed, a message is printed as +if FORMAT-STRING and ARGs were given to FORMAT, and then a prompt +"(Y or N)" is printed. Otherwise, no prompt will appear. +

+ +
+ +
+
Function: MAKE-BROADCAST-STREAM (&rest streams)
+

Package:LISP +

+

Returns an output stream which sends its output to all of the given streams. +

+ +
+ +
+
Function: READ-CHAR (&optional (stream *standard-input*) (eof-error-p t) (eof-value nil) (recursive-p nil))
+

Package:LISP +

+

Reads a character from STREAM. +

+ +
+ +
+
Function: PEEK-CHAR (&optional (peek-type nil) (stream *standard-input*) (eof-error-p t) (eof-value nil) (recursive-p nil))
+

Package:LISP +

+

Peeks at the next character in the input stream STREAM. +

+ +
+ +
+
Function: OUTPUT-STREAM-P (stream)
+

Package:LISP +

+

Returns non-nil if STREAM can handle output operations; NIL otherwise. +

+ +
+ +
+
Variable: *QUERY-IO*
+

Package:LISP +The query I/O stream. +

+ +
+ +
+
Variable: *READ-BASE*
+

Package:LISP +The radix that the GCL reader reads numbers in. +

+ +
+ +
+
Macro: WITH-OPEN-STREAM
+

Package:LISP +

+

Syntax: +

+
(with-open-stream (var stream) {decl}* {form}*)
+
+ +

Evaluates FORMs as a PROGN with VAR bound to the value of STREAM. The stream +is automatically closed on exit. +

+ +
+ +
+
Macro: WITH-INPUT-FROM-STRING
+

Package:LISP +

+

Syntax: +

+
(with-input-from-string (var string {keyword value}*) {decl}*
+{form}*)
+
+ +

Binds VAR to an input stream that returns characters from STRING and evaluates +the FORMs. The stream is automatically closed on exit. Allowed keywords are +:INDEX, :START, and :END. +

+ +
+ +
+
Function: CLEAR-INPUT (&optional (stream *standard-input*))
+

Package:LISP + Clears the input +stream STREAM. +

+ +
+ +
+
Variable: *TERMINAL-IO*
+

Package:LISP +The terminal I/O stream. +

+ +
+ +
+
Function: LISTEN (&optional (stream *standard-input*))
+

Package:LISP +

+

Returns T if a character is available on STREAM; NIL otherwise. This function +does not correctly work in some versions of GCL because of the lack of such +mechanism in the underlying operating system. +

+ +
+ +
+
Function: MAKE-PATHNAME (&key (defaults (parse-namestring "" (pathname-host *default-pathname-defaults*))) (host (pathname-host defaults)) (device (pathname-device defaults)) (directory (pathname-directory defaults)) (name (pathname-name defaults)) (type (pathname-type defaults)) (version (pathname-version defaults)))
+

Package:LISP +

+

Create a pathname from HOST, DEVICE, DIRECTORY, NAME, TYPE and VERSION. +

+ +
+ +
+
Function: PATHNAME-TYPE (pathname)
+

Package:LISP +

+

Returns the type slot of PATHNAME. +

+ +
+ +
+
Variable: *PRINT-GENSYM*
+

Package:LISP +Whether the GCL printer should prefix symbols with no home package +with "#:". +

+ +
+ +
+
Function: READ-LINE (&optional (stream *standard-input*) (eof-error-p t) (eof-value nil) (recursive-p nil))
+

Package:LISP +

+

Returns a line of text read from STREAM as a string, discarding the newline +character. +

+

Note that when using line at a time input under unix, +input forms will always be followed by a #\newline. Thus if you +do +

+

>(read-line) +"" +nil +

+

the empty string will be returned. After lisp reads the (read-line) +it then invokes (read-line). This happens before it does anything +else and so happens before the newline character immediately following +(read-line) has been read. Thus read-line immediately encounters a +#\newline and so returns the empty string. If there had been other +characters before the #\newline it would have been different: +

+

>(read-line) how are you +" how are you" +nil +

+

If you want to throw away "" input, you can do that with +the following: +

+

(sloop::sloop while (equal (setq input (read-line)) "")) +

+

You may also want to use character at a time input, but that +makes input editing harder. +nicolas% stty cbreak +nicolas% gcl +GCL (GNU Common Lisp) Version(1.1.2) Mon Jan 9 12:58:22 MET 1995 +Licensed under GNU Public Library License +Contains Enhancements by W. Schelter +

+

>(let ((ifilename nil)) + (format t "~%Input file name: ") + (setq ifilename (read-line))) +Input file name: /tmp/myfile +"/tmp/myfile" +

+

>(bye)Bye. +

+ + + +
+ +
+
Function: WRITE-TO-STRING (object &key (escape *print-escape*) (radix *print-radix*) (base *print-base*) (circle *print-circle*) (pretty *print-pretty*) (level *print-level*) (length *print-length*) (case *print-case*) (array *print-array*) (gensym *print-gensym*))
+

Package:LISP +

+

Returns as a string the printed representation of OBJECT in the specified +mode. See the variable docs of *PRINT-...* for the mode. +

+ +
+ +
+
Function: PATHNAMEP (x)
+

Package:LISP +

+

Returns T if X is a pathname object; NIL otherwise. +

+ +
+ +
+
Function: READTABLEP (x)
+

Package:LISP +

+

Returns T if X is a readtable object; NIL otherwise. +

+ +
+ +
+
Function: READ (&optional (stream *standard-input*) (eof-error-p t) (eof-value nil) (recursivep nil))
+

Package:LISP +

+

Reads in the next object from STREAM. +

+ +
+ +
+
Function: NAMESTRING (pathname)
+

Package:LISP +

+

Returns the full form of PATHNAME as a string. +

+ +
+ +
+
Function: UNREAD-CHAR (character &optional (stream *standard-input*))
+

Package:LISP +

+

Puts CHARACTER back on the front of the input stream STREAM. +

+ +
+ +
+
Function: CLOSE (stream &key (abort nil))
+

Package:LISP +

+

Closes STREAM. A non-NIL value of :ABORT indicates an abnormal termination. +

+ +
+ +
+
Variable: *PRINT-LENGTH*
+

Package:LISP +How many elements the GCL printer should print at each level of nested data +object. Unlimited if NIL. +

+ +
+ +
+
Function: SET-SYNTAX-FROM-CHAR (to-char from-char &optional (to-readtable *readtable*) (from-readtable nil))
+

Package:LISP +

+

Makes the syntax of TO-CHAR in TO-READTABLE be the same as the syntax of +FROM-CHAR in FROM-READTABLE. +

+ +
+ +
+
Function: INPUT-STREAM-P (stream)
+

Package:LISP +

+

Returns non-NIL if STREAM can handle input operations; NIL otherwise. +

+ +
+ +
+
Function: PATHNAME (x)
+

Package:LISP +

+

Turns X into a pathname. X may be a string, symbol, stream, or pathname. +

+ +
+ +
+
Function: FILE-NAMESTRING (pathname)
+

Package:LISP +

+

Returns the written representation of PATHNAME as a string. +

+ +
+ +
+
Function: MAKE-DISPATCH-MACRO-CHARACTER (char &optional (non-terminating-p nil) (readtable *readtable*))
+

Package:LISP +

+

Causes the character CHAR to be a dispatching macro character in READTABLE. +

+ +
+ +
+
Variable: *STANDARD-OUTPUT*
+

Package:LISP +The default output stream used by the GCL printer. +

+ +
+ +
+
Function: MAKE-TWO-WAY-STREAM (input-stream output-stream)
+

Package:LISP +

+

Returns a bidirectional stream which gets its input from INPUT-STREAM and +sends its output to OUTPUT-STREAM. +

+ +
+ +
+
Variable: *PRINT-ESCAPE*
+

Package:LISP +Whether the GCL printer should put escape characters whenever appropriate. +

+ +
+ +
+
Function: COPY-READTABLE (&optional (from-readtable *readtable*) (to-readtable nil))
+

Package:LISP +

+

Returns a copy of the readtable FROM-READTABLE. If TO-READTABLE is non-NIL, +then copies into TO-READTABLE. Otherwise, creates a new readtable. +

+ +
+ +
+
Function: DIRECTORY-NAMESTRING (pathname)
+

Package:LISP +

+

Returns the directory part of PATHNAME as a string. +

+ +
+ +
+
Function: TRUENAME (pathname)
+

Package:LISP +

+

Returns the pathname for the actual file described by PATHNAME. +

+ +
+ +
+
Variable: *READ-SUPPRESS*
+

Package:LISP +When the value of this variable is NIL, the GCL reader operates normally. +When it is non-NIL, then the reader parses input characters but much of what +is read is not interpreted. +

+ +
+ +
+
Function: GET-DISPATCH-MACRO-CHARACTER (disp-char sub-char &optional (readtable *readtable*))
+

Package:LISP +

+

Returns the macro-character function for SUB-CHAR under DISP-CHAR. +

+ +
+ +
+
Function: PATHNAME-DEVICE (pathname)
+

Package:LISP +

+

Returns the device slot of PATHNAME. +

+ +
+ +
+
Function: READ-CHAR-NO-HANG (&optional (stream *standard-input*) (eof-error-p t) (eof-value nil) (recursive-p nil))
+

Package:LISP +

+

Returns the next character from STREAM if one is available; NIL otherwise. +

+ +
+ +
+
Function: FRESH-LINE (&optional (stream *standard-output*))
+

Package:LISP +

+

Outputs a newline if it is not positioned at the beginning of a line. Returns +T if it output a newline; NIL otherwise. +

+ +
+ +
+
Function: WRITE-CHAR (char &optional (stream *standard-output*))
+

Package:LISP +

+

Outputs CHAR and returns it. +

+ +
+ +
+
Function: PARSE-NAMESTRING (thing &optional host (defaults *default-pathname-defaults*) &key (start 0) (end (length thing)) (junk-allowed nil))
+

Package:LISP +

+

Parses a string representation of a pathname into a pathname. HOST +is ignored. +

+ +
+ +
+
Function: PATHNAME-DIRECTORY (pathname)
+

Package:LISP +

+

Returns the directory slot of PATHNAME. +

+ +
+ +
+
Function: GET-MACRO-CHARACTER (char &optional (readtable *readtable*))
+

Package:LISP +

+

Returns the function associated with CHAR and, as a second value, returns +the non-terminating-p flag. +

+ +
+ +
+
Function: FORMAT (destination control-string &rest arguments)
+

Package:LISP +

+

Provides various facilities for formatting output. +DESTINATION controls where the result will go. If DESTINATION is T, then +the output is sent to the standard output stream. If it is NIL, then the +output is returned in a string as the value of the call. Otherwise, +DESTINATION must be a stream to which the output will be sent. +

+

CONTROL-STRING is a string to be output, possibly with embedded +formatting directives, which are flagged with the escape character +"~". Directives generally expand into additional text to be output, +usually consuming one or more of ARGUMENTs in the process. +

+ + +

A few useful directives are: +

+
+~A, ~nA, ~n@A	Prints one argument as if by PRINC
+~S, ~nS, ~n@S	Prints one argument as if by PRIN1
+~D, ~B, ~O, ~X	Prints one integer in decimal, binary, octal, and hexa
+~%		Does TERPRI
+~&		Does FRESH-LINE
+
+ +

where n is the minimal width of the field in which the object is printed. +~nA and ~nS put padding spaces on the right; ~n@A and ~n@S put on the left. +

+
+
~R  is for printing numbers in various formats.
+
+  ~nR   prints arg in radix n.
+  ~R    prints arg as a cardinal english number: two
+  ~:R   prints arg as an ordinal english number: third
+  ~@R   prints arg as an a Roman Numeral: VII
+  ~:@R   prints arg as an old Roman Numeral: IIII
+
+~C prints a character.
+  ~:C represents non printing characters by their pretty names,eg Space
+  ~@C uses the #\ syntax to allow the reader to read it.
+
+~F prints a floating point number arg.
+  The full form is ~w,d,k,overflowchar,padcharF
+  w represents the total width of the printed representation (variable if
+    not present)
+  d the number of fractional digits to display
+    (format nil "~,2f" 10010.0314) --> "10010.03"
+  k arg is multiplied by 10^k before printing it as a decimal number.
+  overflowchar width w characters copies of the overflow character will
+    be printed.   eg(format t "X>~5,2,,'?F<X" 100.034) --> X>?????<X
+  padchar is the character to pad with
+    (format t "X>~10,2,1,'?,'bF<X" 100.03417) -->X>bbb1000.34<X
+  @ makes + sign print if the arg is positive
+
+~@[print-if-true~]
+
+

if arg is not nil, then it is retained as an arg for further printing, + otherwise it is used up +

+
+
   (format nil "~@[x = ~d~]~a" nil 'bil) --> "BIL"
+   (format nil "~@[x = ~d ~]~a" 8) --> "x = 8 BIL"
+
+ + +
+ +
+
Function: PATHNAME-NAME (pathname)
+

Package:LISP +

+

Returns the name slot of PATHNAME. +

+ +
+ +
+
Function: MAKE-STRING-OUTPUT-STREAM ()
+

Package:LISP +

+

Returns an output stream which will accumulate all output given it for +the benefit of the function GET-OUTPUT-STREAM-STRING. +

+ +
+ +
+
Function: MAKE-SYNONYM-STREAM (symbol)
+

Package:LISP +

+

Returns a stream which performs its operations on the stream which is the +value of the dynamic variable named by SYMBOL. +

+ +
+ +
+
Variable: *LOAD-VERBOSE*
+

Package:LISP +The default for the VERBOSE argument to LOAD. +

+ +
+ +
+
Variable: *PRINT-CIRCLE*
+

Package:LISP +Whether the GCL printer should take care of circular lists. +

+ +
+ +
+
Variable: *PRINT-PRETTY*
+

Package:LISP +Whether the GCL printer should pretty-print. See the function doc of PPRINT +for more information about pretty-printing. +

+ +
+ +
+
Function: FILE-WRITE-DATE (file)
+

Package:LISP +

+

Returns the time at which the specified file is written, as an integer in +universal time format. FILE may be a string or a stream. +

+ +
+ +
+
Function: PRIN1-TO-STRING (object)
+

Package:LISP +

+

Returns as a string the printed representation of OBJECT in the mostly +readable representation. +Equivalent to (WRITE-TO-STRING OBJECT :ESCAPE T). +

+ +
+ +
+
Function: MERGE-PATHNAMES (pathname &optional (defaults *default-pathname-defaults*) default-version)
+

Package:LISP +

+

Fills in unspecified slots of PATHNAME from DEFAULTS. DEFAULT-VERSION +is ignored in GCL. +

+ +
+ +
+
Function: READ-BYTE (stream &optional (eof-error-p t) (eof-value nil))
+

Package:LISP +

+

Reads the next byte from STREAM. +

+ +
+ +
+
Function: PRINC-TO-STRING (object)
+

Package:LISP +

+

Returns as a string the printed representation of OBJECT without escape +characters. Equivalent to + (WRITE-TO-STRING OBJECT :ESCAPE NIL). +

+ +
+ +
+
Variable: *STANDARD-INPUT*
+

Package:LISP +The default input stream used by the GCL reader. +

+ +
+ +
+
Function: PROBE-FILE (file)
+

Package:LISP +

+

Returns the truename of file if the file exists. +Returns NIL otherwise. +

+ +
+ +
+
Function: PATHNAME-VERSION (pathname)
+

Package:LISP +

+

Returns the version slot of PATHNAME. +

+ +
+ +
+
Function: WRITE-LINE (string &optional (stream *standard-output*) &key (start 0) (end (length string)))
+

Package:LISP +

+

Outputs STRING and then outputs a newline character. Returns STRING. +

+ +
+ +
+
Function: WRITE (object &key (stream *standard-output*) (escape *print-escape*) (radix *print-radix*) (base *print-base*) (circle *print-circle*) (pretty *print-pretty*) (level *print-level*) (length *print-length*) (case *print-case*) (array *print-array*) (gensym *print-gensym*))
+

Package:LISP +

+

Prints OBJECT in the specified mode. See the variable docs of *PRINT-...* +for the mode. +

+ +
+ +
+
Function: GET-OUTPUT-STREAM-STRING (stream)
+

Package:LISP +

+

Returns a string of all the characters sent to STREAM made by +MAKE-STRING-OUTPUT-STREAM since the last call to this function. +

+ +
+ +
+
Function: READ-DELIMITED-LIST (char &optional (stream *standard-input*) (recursive-p nil))
+

Package:LISP +

+

Reads objects from STREAM until the next character after an object’s +representation is CHAR. Returns a list of the objects read. +

+ +
+ +
+
Function: READLINE-ON ()
+

Package:SI +

+

Begins readline command editing mode when possible. In addition to +the basic readline editing features, command word completion is +implemented according to the following scheme: +

+

[[pkg]:[:]]txt +

+

pkg – an optional package specifier. Defaults to the current +package. The symbols in this package and those in the packages in +this package’s use list will be searched. +

+

:[:] – an optional internal/external specifier. Defaults to +external. The keyword package is denoted by a single colon at the +beginning of the token. Only symbols of this type will be searched +for completion. +

+

txt – a string. Symbol names beginning with this string are +completed. The comparison is case insensitive. +

+ +
+ +
+
Function: READLINE-OFF ()
+

Package:SI +

+

Disables readline command editing mode. +

+
+ +
+
Variable: *READLINE-PREFIX*
+

Package:SI +

+

A string implicitly prepended to input text for use in readline +command completion. If this string contains one or more colons, it is +used to specify the default package and internal/external setting for +searched symbols in the case that the supplied text itself contains no +explicit package specification. If this string contains characters +after the colon(s), or contains no colons at all, it is treated as a +symbol name prefix. In this case, the prefix is matched first, then +the supplied text, and the completion returned is relative to the +supplied text itself, i.e. contains no prefix. For example, the +setting “maxima::$” will complete input text “int” according to +the internal symbols in the maxima package of the form +“maxima::$int...”, and return suggestions to the user of the form +“int...”. +

+
+ + +
+
+

+Next: , Previous: , Up: Top   [Contents][Index]

+
+ + + + + diff --git a/info/gcl-si/Structures.html b/info/gcl-si/Structures.html new file mode 100644 index 0000000..43165bd --- /dev/null +++ b/info/gcl-si/Structures.html @@ -0,0 +1,108 @@ + + + + +GCL SI Manual: Structures + + + + + + + + + + + + + + + + + + + + +
+

+Next: , Previous: , Up: Top   [Contents][Index]

+
+
+ +

10 Structures

+ +
+
Macro: DEFSTRUCT
+

Package:LISP +

+

Syntax: +

+
(defstruct
+         {name | (name {:conc-name | (:conc-name prefix-string) |
+                        :constructor | (:constructor symbol [lambda-list]) |
+                        :copier | (:copier symbol) |
+                        :predicate | (:predicate symbol) | 
+                        (:include symbol) |
+                        (:print-function function) |
+                        (:type {vector | (vector type) | list}) |
+                        :named | (:static { nil | t})
+                        (:initial-offset number)}*)}
+         [doc]
+         {slot-name |
+          (slot-name [default-value-form] {:type type | :read-only flag}*) }*
+         )
+
+ +

Defines a structure. The doc-string DOC, if supplied, is saved as a STRUCTURE +doc and can be retrieved by (documentation ’NAME ’structure). +STATIC is gcl specific and makes the body non relocatable. +

+

See the files misc/rusage.lsp misc/cstruct.lsp, for examples of making +a lisp structure correspond to a C structure. +

+ + +
+ +
+
Function: HELP (&optional symbol)
+

Package:LISP +

+

GCL specific: Prints the documentation associated with SYMBOL. With no +argument, this function prints the greeting message to GCL beginners. +

+ +
+ + + + + + diff --git a/info/gcl-si/Symbols.html b/info/gcl-si/Symbols.html new file mode 100644 index 0000000..ae388a1 --- /dev/null +++ b/info/gcl-si/Symbols.html @@ -0,0 +1,580 @@ + + + + +GCL SI Manual: Symbols + + + + + + + + + + + + + + + + + + + + +
+

+Next: , Previous: , Up: Top   [Contents][Index]

+
+
+ +

8 Symbols

+ +
+
Function: GENSYM (&optional (x nil))
+

Package:LISP +

+

Creates and returns a new uninterned symbol whose name is a prefix string +(defaults to "G"), followed by a decimal number. The number is incremented +by each call to GENSYM. X, if an integer, resets the counter. If X is a +string, it becomes the new prefix. +

+ +
+ +
+
Function: KEYWORDP (x)
+

Package:LISP +

+

Returns T if X is a symbol and it belongs to the KEYWORD package; NIL +otherwise. +

+ +
+ +
+
Function: REMPROP (symbol indicator)
+

Package:LISP +

+

Look on property list of SYMBOL for property with specified +INDICATOR. If found, splice this indicator and its value out of +the plist, and return T. If not found, returns NIL with no side effects. +

+
+ +
+
Function: SYMBOL-PACKAGE (symbol)
+

Package:LISP +

+

Returns the contents of the package cell of the symbol SYMBOL. +

+ +
+ +
+
Variable: *PACKAGE*
+

Package:LISP +The current package. +

+ +
+ + +
+
Function: SHADOWING-IMPORT (symbols &optional (package *package*))
+

Package:LISP +

+

Imports SYMBOLS into PACKAGE, disregarding any name conflict. If a symbol +of the same name is already present, then it is uninterned. SYMBOLS must +be a list of symbols or a symbol. +

+ +
+ +
+
Macro: REMF
+

Package:LISP +

+

Syntax: +

+
(remf place indicator)
+
+ +

PLACE may be any place expression acceptable to SETF, and is expected +to hold a property list or NIL. This list is destructively altered to +remove the property specified by INDICATOR. Returns T if such a +property was present; NIL otherwise. +

+ +
+ +
+
Function: MAKUNBOUND (symbol)
+

Package:LISP +

+

Makes empty the value slot of SYMBOL. Returns SYMBOL. +

+ +
+ +
+
Function: USE-PACKAGE (packages-to-use &optional (package *package*))
+

Package:LISP +

+

Adds all packages in PACKAGE-TO-USE list to the use list for PACKAGE so that +the external symbols of the used packages are available as internal symbols +in PACKAGE. +

+ +
+ +
+
Function: MAKE-SYMBOL (string)
+

Package:LISP +

+

Creates and returns a new uninterned symbol whose print name is STRING. +

+ +
+ +
+
Special Form: PSETQ
+

Package:LISP +

+

Syntax: +

+
(psetq {var form}*)
+
+ +

Similar to SETQ, but evaluates all FORMs first, and then assigns each value to +the corresponding VAR. Returns NIL always. +

+ +
+ +
+
Function: PACKAGE-USED-BY-LIST (package)
+

Package:LISP +

+

Returns the list of packages that use PACKAGE. +

+ +
+ +
+
Function: SYMBOLP (x)
+

Package:LISP +

+

Returns T if X is a symbol; NIL otherwise. +

+ +
+ +
+
Constant: NIL
+

Package:LISP +Holds NIL. +

+ +
+ +
+
Function: SET (symbol value)
+

Package:LISP +

+

Assigns the value of VALUE to the dynamic variable named by SYMBOL, and +returns the value assigned. +

+ +
+ +
+
Special Form: SETQ
+

Package:LISP +

+

Syntax: +

+
(setq {var form}*)
+
+ +

VARs are not evaluated and must be symbols. Assigns the value of the first +FORM to the first VAR, then assigns the value of the second FORM to the second +VAR, and so on. Returns the last value assigned. +

+ +
+ +
+
Function: UNUSE-PACKAGE (packages-to-unuse &optional (package *package*))
+

Package:LISP +

+

Removes PACKAGES-TO-UNUSE from the use list for PACKAGE. +

+ +
+ +
+
Constant: T
+

Package:LISP +Holds T. +

+ +
+ +
+
Function: PACKAGE-USE-LIST (package)
+

Package:LISP +

+

Returns the list of packages used by PACKAGE. +

+ +
+ +
+
Function: LIST-ALL-PACKAGES ()
+

Package:LISP +

+

Returns a list of all existing packages. +

+ +
+ +
+
Function: COPY-SYMBOL (symbol &optional (copy-props nil))
+

Package:LISP +

+

Returns a new uninterned symbol with the same print name as SYMBOL. +If COPY-PROPS is NIL, the function, the variable, and the property slots +of the new symbol have no value. Otherwise, these slots are given the +values of the corresponding slots of SYMBOL. +

+ +
+ +
+
Function: SYMBOL-PLIST (symbol)
+

Package:LISP +

+

Returns the property list of SYMBOL. +

+ +
+ +
+
Function: SYMBOL-NAME (symbol)
+

Package:LISP +

+

Returns the print name of the symbol SYMBOL. +

+ +
+ +
+
Function: FIND-SYMBOL (name &optional (package *package*))
+

Package:LISP +

+

Returns the symbol named NAME in +PACKAGE. If such a symbol is found, then the second value is :INTERN, +:EXTERNAL, or :INHERITED to indicate how the symbol is accessible. If +no symbol is found then both values are NIL. +

+ +
+ +
+
Function: SHADOW (symbols &optional (package *package*))
+

Package:LISP +

+

Creates an internal symbol in PACKAGE with the same name as each of the +specified SYMBOLS. SYMBOLS must be a list of symbols or a symbol. +

+ +
+ + +
+
Function: FBOUNDP (symbol)
+

Package:LISP +

+

Returns T if SYMBOL has a global function definition or if SYMBOL names a +special form or a macro; NIL otherwise. +

+ +
+ +
+
Function: MACRO-FUNCTION (symbol)
+

Package:LISP +

+

If SYMBOL globally names a macro, then returns the expansion function. +Returns NIL otherwise. +

+ +
+ +
+
Function: IN-PACKAGE (package-name &key (nicknames nil) (use '(lisp)))
+

Package:LISP +

+

Sets *PACKAGE* to the package with PACKAGE-NAME, creating the package if +it does not exist. If the package already exists then it is modified +to agree with USE and NICKNAMES arguments. Any new nicknames are added +without removing any old ones not specified. If any package in the USE list +is not currently used, then it is added to the use list. +

+ +
+ +
+
Function: MAKE-PACKAGE (package-name &key (nicknames nil) (use '(lisp)))
+

Package:LISP +

+

Makes a new package having the specified PACKAGE-NAME and NICKNAMES. The +package will inherit all external symbols from each package in the USE list. +

+ +
+ +
+
Function: PACKAGE-SHADOWING-SYMBOLS (package)
+

Package:LISP +

+

Returns the list of symbols that have been declared as shadowing symbols +in PACKAGE. +

+ +
+ +
+
Function: INTERN (name &optional (package *package*))
+

Package:LISP +

+

Returns a symbol having the specified name, creating it if necessary. +Returns as the second value one of the symbols :INTERNAL, :EXTERNAL, +:INHERITED, and NIL. +

+ +
+ +
+
Function: EXPORT (symbols &optional (package *package*))
+

Package:LISP +

+

Makes SYMBOLS external symbols of PACKAGE. SYMBOLS must be a list of symbols +or a symbol. +

+ +
+ +
+
Function: PACKAGEP (x)
+

Package:LISP +

+

Returns T if X is a package; NIL otherwise. +

+ +
+ +
+
Function: SYMBOL-FUNCTION (symbol)
+

Package:LISP +

+

Returns the current global function definition named by SYMBOL. +

+ +
+ +
+
Function: SYMBOL-VALUE (symbol)
+

Package:LISP +

+

Returns the current value of the dynamic (special) variable named by SYMBOL. +

+ +
+ +
+
Function: BOUNDP (symbol)
+

Package:LISP +

+

Returns T if the global variable named by SYMBOL has a value; NIL otherwise. +

+ +
+ +
+
Function: DOCUMENTATION (symbol doc-type)
+

Package:LISP +

+

Returns the doc-string of DOC-TYPE for SYMBOL; NIL if none exists. +Possible doc-types are: + FUNCTION (special forms, macros, and functions) + VARIABLE (dynamic variables, including constants) + TYPE (types defined by DEFTYPE) + STRUCTURE (structures defined by DEFSTRUCT) + SETF (SETF methods defined by DEFSETF, DEFINE-SETF-METHOD, and + DEFINE-MODIFY-MACRO) +All built-in special forms, macros, functions, and variables have their +doc-strings. +

+ +
+ +
+
Function: GENTEMP (&optional (prefix "t") (package *package*))
+

Package:LISP +

+

Creates a new symbol interned in the package PACKAGE with the given PREFIX. +

+ +
+ +
+
Function: RENAME-PACKAGE (package new-name &optional (new-nicknames nil))
+

Package:LISP +

+

Replaces the old name and nicknames of PACKAGE with NEW-NAME and +NEW-NICKNAMES. +

+ +
+ +
+
Function: UNINTERN (symbol &optional (package *package*))
+

Package:LISP +

+

Makes SYMBOL no longer present in PACKAGE. Returns T if SYMBOL was present; +NIL otherwise. If PACKAGE is the home package of SYMBOL, then makes SYMBOL +uninterned. +

+ +
+ +
+
Function: UNEXPORT (symbols &optional (package *package*))
+

Package:LISP +

+

Makes SYMBOLS no longer accessible as external symbols in PACKAGE. SYMBOLS +must be a list of symbols or a symbol. +

+ +
+ +
+
Function: PACKAGE-NICKNAMES (package)
+

Package:LISP +

+

Returns as a list the nickname strings for the specified PACKAGE. +

+ +
+ +
+
Function: IMPORT (symbols &optional (package *package*))
+

Package:LISP +

+

Makes SYMBOLS internal symbols of PACKAGE. SYMBOLS must be a list of symbols +or a symbol. +

+ +
+ +
+
Function: GET (symbol indicator &optional (default nil))
+

Package:LISP +

+

Looks on the property list of SYMBOL for the specified INDICATOR. If this +is found, returns the associated value. Otherwise, returns DEFAULT. +

+ +
+ +
+
Function: FIND-ALL-SYMBOLS (string-or-symbol)
+

Package:LISP +

+

Returns a list of all symbols that have the specified name. +

+ +
+ +
+
Function: FMAKUNBOUND (symbol)
+

Package:LISP +

+

Discards the global function definition named by SYMBOL. Returns SYMBOL. +

+ +
+ +
+
Function: PACKAGE-NAME (package)
+

Package:LISP +

+

Returns the string that names the specified PACKAGE. +

+ +
+ +
+
Function: FIND-PACKAGE (name)
+

Package:LISP +

+

Returns the specified package if it already exists; NIL otherwise. NAME may +be a string that is the name or nickname of the package. NAME may also be +a symbol, in which case the symbol’s print name is used. +

+ +
+ + +
+
Function: APROPOS-LIST (string &optional (package nil))
+

Package:LISP +

+

Returns, as a list, all symbols whose print-names contain STRING as substring. +If PACKAGE is non-NIL, then only the specified package is searched. +

+ +
+ + + +
+
+

+Next: , Previous: , Up: Top   [Contents][Index]

+
+ + + + + diff --git a/info/gcl-si/System-Definitions.html b/info/gcl-si/System-Definitions.html new file mode 100644 index 0000000..feaf1c7 --- /dev/null +++ b/info/gcl-si/System-Definitions.html @@ -0,0 +1,1159 @@ + + + + +GCL SI Manual: System Definitions + + + + + + + + + + + + + + + + + + + + +
+

+Next: , Previous: , Up: Top   [Contents][Index]

+
+
+ +

17 System Definitions

+ + +
+
Function: ALLOCATE-CONTIGUOUS-PAGES (number &optional (really-allocate nil))
+

Package:SI +

+

GCL specific: Sets the maximum number of pages for contiguous blocks to +NUMBER. If REALLY-ALLOCATE is non-NIL, then the specified +number of pages will be allocated immediately. +

+ +
+
+
Function: FREEZE-DEFSTRUCT (name)
+

Package:SI +

+

The inline defstruct type checker will be made more efficient, in that +it will only check for types which currently include NAME. After +calling this the defstruct should not be altered. +

+ +
+
+
Function: MAXIMUM-ALLOCATABLE-PAGES (type)
+

Package:SI +

+

GCL specific: Returns the current maximum number of pages for the type class +of the GCL implementation type TYPE. +

+ +
+
+
Function: ALLOCATED-RELOCATABLE-PAGES ()
+

Package:SI +

+

GCL specific: Returns the number of pages currently allocated for relocatable +blocks. +

+ +
+
+
Function: PUTPROP (symbol value indicator)
+

Package:SI +

+

Give SYMBOL the VALUE on INDICATOR property. +

+ +
+
+
Function: ALLOCATED-PAGES (type)
+

Package:SI +

+

GCL specific: Returns the number of pages currently allocated for the type +class of the GCL implementation type TYPE. +

+ +
+
+
Function: ALLOCATE-RELOCATABLE-PAGES (number)
+

Package:SI +

+

GCL specific: Sets the maximum number of pages for relocatable blocks to +NUMBER. +

+ +
+
+
Function: ALLOCATED-CONTIGUOUS-PAGES ()
+

Package:SI +

+

GCL specific: Returns the number of pages currently allocated for contiguous +blocks. +

+ +
+
+
Function: MAXIMUM-CONTIGUOUS-PAGES ()
+

Package:SI +

+

GCL specific: Returns the current maximum number of pages for contiguous +blocks. +

+ +
+
+
Function: GET-HOLE-SIZE ()
+

Package:SI +

+

GCL specific: Returns as a fixnum the size of the memory hole (in pages). +

+ +
+
+
Function: SPECIALP (symbol)
+

Package:SI +

+

GCL specific: Returns T if the SYMBOL is a globally special variable; NIL +otherwise. +

+ +
+
+
Function: OUTPUT-STREAM-STRING (string-output-stream)
+

Package:SI +

+

GCL specific: Returns the string corresponding to the STRING-OUTPUT-STREAM. +

+ +
+
+
Function: GET-STRING-INPUT-STREAM-INDEX (string-input-stream)
+

Package:SI +

+

GCL specific: Returns the current index of the STRING-INPUT-STREAM. +

+ +
+
+
Function: STRING-CONCATENATE (&rest strings)
+

Package:SI +

+

GCL specific: Returns the result of concatenating the given STRINGS. +

+ +
+
+
Function: BDS-VAR (i)
+

Package:SI +

+

GCL specific: Returns the symbol of the i-th entity in the bind stack. +

+ +
+
+
Function: ERROR-SET (form)
+

Package:SI +

+

GCL specific: Evaluates the FORM in the null environment. If the evaluation +of the FORM has successfully completed, SI:ERROR-SET returns NIL as the first +value and the result of the evaluation as the rest of the values. If, in the +course of the evaluation, a non-local jump from the FORM is atempted, +SI:ERROR-SET traps the jump and returns the corresponding jump tag as its +value. +

+ +
+
+
Function: COMPILED-FUNCTION-NAME (compiled-function-object)
+

Package:SI +

+

GCL specific: Returns the name of the COMPILED-FUNCTION-OBJECT. +

+ +
+
+
Function: STRUCTUREP (object)
+

Package:SI +

+

GCL specific: Returns T if the OBJECT is a structure; NIL otherwise. +

+ +
+
+
Function: IHS-VS (i)
+

Package:SI +

+

GCL specific: Returns the value stack index of the i-th entity in the +invocation history stack. +

+ +
+
+
Function: UNIVERSAL-ERROR-HANDLER (error-name correctable function-name continue-format-string error-format-string &rest args)
+

Package:SI +

+

GCL specific: Starts the error handler of GCL. When an error is detected, +GCL calls SI:UNIVERSAL-ERROR-HANDLER with the specified arguments. +ERROR-NAME is the name of the error. CORRECTABLE is T for a correctable +error and NIL for a fatal error. FUNCTION-NAME is the name of the function +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. + To change the error handler of GCL, redefine SI:UNIVERSAL-ERROR- +HANDLER. +

+ +
+
+
Variable: *INTERRUPT-ENABLE*
+

Package:SI +GCL specific: If the value of SI:*INTERRUPT-ENABLE* is non-NIL, GCL signals +an error on the terminal interrupt (this is the default case). If it is NIL, +GCL ignores the interrupt and assigns T to SI:*INTERRUPT-ENABLE*. +

+ +
+
+
Function: CHDIR (pathname)
+

Package:SI +

+

GCL/UNIX specific: Changes the current working directory to the specified +pathname. +

+ +
+
+
Function: COPY-STREAM (in-stream out-stream)
+

Package:SI +

+

GCL specific: Copies IN-STREAM to OUT-STREAM until the end-of-file on IN- +STREAM. +

+ +
+
+
Function: INIT-SYSTEM ()
+

Package:SI +

+

GCL specific: Initializes the library and the compiler of GCL. Since they +have already been initialized in the standard image of GCL, calling SI:INIT- +SYSTEM will cause an error. +

+ +
+
+
Variable: *INDENT-FORMATTED-OUTPUT*
+

Package:SI +GCL specific: The FORMAT directive ~% indents the next line if the value of +this variable is non-NIL. If NIL, ~% simply does Newline. +

+ +
+
+
Function: SET-HOLE-SIZE (fixnum)
+

Package:SI +

+

GCL specific: Sets the size of the memory hole (in pages). +

+ +
+
+
Function: FRS-BDS (i)
+

Package:SI +

+

GCL specific: Returns the bind stack index of the i-th entity in the frame +stack. +

+ +
+
+
Function: IHS-FUN (i)
+

Package:SI +

+

GCL specific: Returns the function value of the i-th entity in the invocation +history stack. +

+ +
+
+
Function: *MAKE-CONSTANT (symbol value)
+

Package:SI +

+

GCL specific: Makes the SYMBOL a constant with the specified VALUE. +

+ +
+
+
Function: FIXNUMP (object)
+

Package:SI +

+

GCL specific: Returns T if the OBJECT is a fixnum; NIL otherwise. +

+ +
+
+
Function: BDS-VAL (i)
+

Package:SI +

+

GCL specific: Returns the value of the i-th entity in the bind stack. +

+ +
+
+
Function: STRING-TO-OBJECT (string)
+

Package:SI +

+

GCL specific: (SI:STRING-TO-OBJECT STRING) is equivalent to +(READ-FROM-STRING STRING), but much faster. +

+ +
+
+
Variable: *SYSTEM-DIRECTORY*
+

Package:SI +GCL specific: Holds the name of the system directory of GCL. +

+ +
+
+
Function: FRS-IHS (i)
+

Package:SI +

+

GCL specific: Returns the invocation history stack index of the i-th entity +in the frame stack. +

+ +
+
+
Function: RESET-GBC-COUNT ()
+

Package:SI +

+

GCL specific: Resets the counter of the garbage collector that records how +many times the garbage collector has been called for each implementation +type. +

+ +
+
+
Function: CATCH-BAD-SIGNALS ()
+

Package:SI +

+

GCL/BSD specific: Installs a signal catcher for bad signals: + SIGILL, SIGIOT, SIGEMT, SIGBUS, SIGSEGV, SIGSYS. +The signal catcher, upon catching the signal, signals an error (and enter +the break-level). Since the internal memory of GCL may be broken, the user +should check the signal and exit from GCL if necessary. When the signal +is caught during garbage collection, GCL terminates immediately. +

+ +
+
+
Function: RESET-STACK-LIMITS ()
+

Package:SI +

+

GCL specific: Resets the stack limits to the normal state. When a stack has +overflowed, GCL extends the limit for the stack in order to execute the error +handler. After processing the error, GCL resets the stack limit by calling +SI:RESET-STACK-LIMITS. +

+ +
+
+
Variable: *GBC-MESSAGE*
+

Package:SI +GCL specific: If the value of SI:*GBC-MESSAGE* is non-NIL, the garbage +collector prints some information on the terminal. Usually SI:*GBC-MESSAGE* +should be set NIL. +

+ +
+
+
Variable: *GBC-NOTIFY*
+

Package:SI +GCL specific: If the value is non-NIL, the garbage +collector prints a very brief one line message about the area causing the collection, +and the time spent in internal time units. +

+ +
+
+
Variable: *AFTER-GBC-HOOK*
+

Package:SI +Defaults to nil, but may be set to a function of one argument TYPE which is +a lisp variable indicating the TYPE which caused the current collection. +

+ +
+
+
Funcition: ALLOCATED (type)
+

Package:SI +

+

Returns 6 values: +

+
nfree
+

number free +

+
npages
+

number of pages +

+
maxpage
+

number of pages to grow to +

+
nppage
+

number per page +

+
gbccount
+

number of gc’s due to running out of items of this size +

+
nused
+

number of items used +

+
+ +

Note that all items of the same size are stored on similar pages. +Thus for example on a 486 under linux the following basic types are +all the same size and so will share the same allocated information: +CONS BIGNUM RATIO COMPLEX STRUCTURE. +

+ + +
+ +
+
Function: *MAKE-SPECIAL (symbol)
+

Package:SI +

+

GCL specific: Makes the SYMBOL globally special. +

+ +
+
+
Function: MAKE-STRING-OUTPUT-STREAM-FROM-STRING (string)
+

Package:SI +

+

GCL specific: Creates a string-output-stream corresponding to the STRING and +returns it. The STRING should have a fill-pointer. +

+ +
+
+
Variable: *IGNORE-EOF-ON-TERMINAL-IO*
+

Package:SI +GCL specific: If the value of SI:*IGNORE-EOF-ON-TERMINAL-IO* is non-NIL, GCL +ignores the eof-character (usually ^D) on the terminal and the terminal never +becomes end-of-file. The default value of SI:*IGNORE-EOF-ON-TERMINAL-IO* is +NIL. +

+ +
+
+
Function: ADDRESS (object)
+

Package:SI +

+

GCL specific: Returns the address of the OBJECT as a fixnum. The address of +an object depends on the version of GCL. E.g. (SI:ADDRESS NIL) returns +1879062044 on GCL/AOSVS dated March 14, 1986. +

+ +
+
+
Variable: *LISP-MAXPAGES*
+

Package:SI +GCL specific: Holds the maximum number of pages (1 page = 2048 bytes) for the +GCL process. The result of changing the value of SI:*LISP-MAXPAGES* is +unpredictable. +

+ +
+
+
Function: ARGC ()
+

Package:SI +

+

GCL specific: Returns the number of arguments on the command line that invoked +the GCL process. +

+ +
+
+
Function: NANI (fixnum)
+

Package:SI +

+

GCL specific: Returns the object in the address FIXNUM. This function is +the inverse of SI:ADDRESS. Although SI:ADDRESS is a harmless operation, +SI:NANI is quite dangerous and should be used with care. +

+ +
+
+
Variable: *NOTIFY-GBC*
+

Package:SI +GCL specific: If the value of this variable is non-NIL, then the garbage +collector notifies that it begins to run whenever it is invoked. Otherwise, +garbage collection begins silently. +

+ +
+
+
Function: SAVE-SYSTEM (pathname)
+

Package:SI +

+

GCL specific: Saves the current GCL core imange into a program file specified +by PATHNAME. This function differs from SAVE in that the contiguous and +relocatable areas are made permanent in the saved image. Usually the +standard image of GCL interpreter/compiler is saved by SI:SAVE-SYSTEM. +This function causes an exit from lisp. Various changes are made +to the memory of the running system, such as closing files and +resetting io streams. It would not be possible to continue normally. +

+ +
+
+
Function: UNCATCH-BAD-SIGNALS ()
+

Package:SI +

+

GCL/BSD specific: Undoes the effect of SI:CATCH-BAD-SIGNALS. +

+ +
+
+
Function: VS (i)
+

Package:SI +

+

GCL specific: Returns the i-th entity in the value stack. +

+ +
+
+
Function: DISPLACED-ARRAY-P (array)
+

Package:SI +

+

GCL specific: Returns T if the ARRAY is a displaced array; NIL otherwise. +

+ +
+
+
Function: ARGV (fixnum)
+

Package:SI +

+

GCL specific: Returns the FIXNUM-th argument on the command line that invoked +the GCL process. +

+ +
+
+
Variable: *DEFAULT-TIME-ZONE*
+

Package:SI +GCL specific: Holds the default time zone. The initial value of SI:*DEFAULT- +TIME-ZONE* is 6 (the time zone of Austin, Texas). +

+ +
+
+
Function: GETENV (string)
+

Package:SI +

+

GCL/UNIX specific: Returns the environment with the name STRING as a string; +if the environment specified by STRING is not found, returns NIL. +

+ +
+
+
Function: FASLINK (file string)
+

Package:SI +

+

GCL/BSD specific: Loads the FASL file FILE while linking the object files and +libraries specified by STRING. For example, + (faslink "foo.o" "bar.o boo.o -lpixrect") +loads foo.o while linking two object files (bar.o and boo.o) and the library +pixrect. Usually, foo.o consists of the C language interface for the +functions defined in the object files or the libraries. +

+

A more portable way of making references to C code, is to build it +in at the time of the original make. If foo.c references things +in -lpixrect, and foo.o is its compilation in the gcl/unixport directory +

+

(cd gcl/unixport ; make "EXTRAS= foo.o -lpixrect ") +

+

should add them. If EXTRAS was already joe.o in the unixport/makefile +you should of course add joe.o to the above "EXTRAS= joe.o foo.o.." +

+

Faslink does not work on most UNIX systems which are derived from SYS V or AIX. +

+ + + +
+
+
Function: TOP-LEVEL ()
+

Package:SI +

+

GCL specific: Starts the standard top-level listner of GCL. When the GCL +process is invoked, it calls SI:TOP-LEVEL by (FUNCALL ’SI:TOP-LEVEL). + To change the top-level of GCL, redefine SI:TOP-LEVEL and save the core +imange in a file. When the saved imange is invoked, it will start the +redefined top-level. +

+ +
+
+
Function: FRS-VS (i)
+

Package:SI +

+

GCL specific: Returns the value stack index of the i-th entity in the frame +stack. +

+ +
+
+
Function: WRITE-DEBUG-SYMBOLS (start file &key (main-file "/usr/local/schelter/xgcl/unixport/raw_gcl") (output-file "debug-symbols.o" ))
+

Package:SI +

+

Write out a file of debug-symbols using address START as the place +where FILE will be loaded into the running executable MAIN-FILE. The +last is a keyword argument. +

+ + + +
+
+
Function: PROF (x y)
+

Package:SI +

+

These functions in the SI package are GCL specific, and allow monitoring +the run time of functions loaded into GCL, as well as the basic functions. + Sample Usage: + (si::set-up-profile 1000000) (si::prof 0 90) + run program + (si::prof 0 0) ;; turn off profile + (si::display-prof) + (si::clear-profile) + (si::prof 0 90) ;; start profile again + run program + .. + Profile can be stopped with (si::prof 0 0) and restarted with (si::prof 0 90) +The START-ADDRESS will correspond to the beginning of the profile array, and +the SCALE will mean that 256 bytes of code correspond to SCALE bytes in the +profile array. +

+

Thus if the profile array is 1,000,000 bytes long and the code segment is +5 megabytes long you can profile the whole thing using a scale of 50 +Note that long runs may result in overflow, and so an understating of the +time in a function. +

+

You must run intensively however since, with a scale of 128 it takes +6,000,000 times through a loop to overflow the sampling in one part of +the code. +

+ +
+
+
Function: CATCH-FATAL (i)
+

Package:SI +

+ +

Sets the value of the C variable catch_fatal to I which should be an integer. +If catch_fatal is 1, then most unrecoverable fatal errors will be caught. +Upon catching such an error catch_fatal becomes -1, to avoid recursive errors. +The top level loop automatically sets catch_fatal to 1, if the value is less +than zero. Catching can be turned off by making catch_fatal = 0. +

+ + + +
+
+
Variable: *MULTIPLY-STACKS*
+

Package:SI +

+

If this variable is set to a positive fixnum, then the next time through the +TOP-LEVEL loop, the loop will be exited. The size of the stacks will be +multiplied by the value of *multiply-stacks*, and the TOP-LEVEL will be called +again. Thus to double the size of the stacks: +

+

>(setq si::*multiply-stacks* 2) +[exits top level and reinvokes it, with the new stacks in place] +> +

+

We must exit TOP-LEVEL, because it and any other lisp functions +maintain many pointers into the stacks, which would be incorrect when the +stacks have been moved. Interrupting the process of growing the stacks, +can leave you in an inconsistent state. +

+ +
+
+
Function: GBC-TIME (&optional x)
+

Package:SI +

+

Sets the internal C variable gc_time to X if X is supplied and then +returns gc_time. If gc_time is greater or equal to 0, then gc_time is +incremented by the garbage collector, according to the number of +internal time units spent there. The initial value of gc_time is -1. +

+ + +
+
+
Function: FWRITE (string start count stream)
+

Package:SI +

+

Write from STRING starting at char START (or 0 if it is nil) COUNT characters +(or to end if COUNT is nil) to STREAM. STREAM must be a stream such as +returned by FP-OUTPUT-STREAM. Returns nil if it fails. +

+ + +
+
+
Function: FREAD (string start count stream)
+

Package:SI +

+

Read characters into STRING starting at char START (or 0 if it is nil) COUNT +characters (or from start to length of STRING if COUNT is nil). Characters +are read from STREAM. STREAM must be a stream such as returned by +FP-INPUT-STREAM. Returns nil if it fails. Return number of characters read +if it succeeds. +

+ +
+
+
Function: SGC-ON (&optional ON)
+

Package:SI +

+

If ON is not nil then SGC (stratified garbage collection) is turned +on. If ON is supplied and is nil, then SGC is turned off. +If ON is not supplied, then it returns T if SGC is on, and NIL if +SGC is off. +

+

The purpose of SGC is to prevent paging activity during garbage +collection. It is efficient if the actual number of pages being +written to form a small percentage of the total image size. The image +should be built as compactly as possible. This can be accomplished by +using a settings such as (si::allocate-growth ’cons 1 10 50 20) to limit +the growth in the cons maxpage to 10 pages per time. Then +just before calling si::save-system to save your image you can +do something like: +

+

(si::set-hole-size 500)(gbc nil) (si::sgc-on t) (si::save-system ..) +

+

This makes the saved image come up with SGC on. We have set a +reasonably large hole size. This is so that allocation of pages +either because they fill up, or through specific calls to +si::allocate, will not need to move all the relocatable data. Moving +relocatable data requires turning SGC off, performing a full gc, and +then turning it back on. New relocatable data is collected by SGC, +but moving the old requires going through all pages of memory to +change pointers into it. +

+

Using si::*notify-gbc* gives information about the number of pages +used by SGC. +

+

Note that SGC is only available on operating systems which provide +the mprotect system call, to write protect pages. Otherwise we +cannot tell which pages have been written too. +

+ + +
+
+
Function: ALLOCATE-SGC (type min-pages max-pages percent-free)
+

Package:SI +

+

If MIN-PAGES is 0, then this type will not be swept by SGC. Otherwise +this is the minimum number of pages to make available to SGC. MAX-PAGES +is the upper limit of such pages. Only pages with PERCENT-FREE objects +on them, will be assigned to SGC. +A list of the previous values for min, max and percent are returned. +

+ +
+
+
Function: ALLOCATE-GROWTH (type min max percent percent-free)
+

Package:SI +

+ +

The next time after a garbage collection for TYPE, if PERCENT-FREE of +the objects of this TYPE are not actually free, and if the maximum +number of pages for this type has already been allocated, then the +maximum number will be increased by PERCENT of the old maximum, +subject to the condition that this increment be at least MIN pages and +at most MAX pages. A list of the previous values for min, max, +percent, and percent-free for the type TYPE is returned. A value +of 0 means use the system default, and if an argument is out of range +then the current values are returned with no change made. +

+

Examples: +(si::allocate-growth ’cons 1 10 50 10) +would insist that after a garbage collection for cons, there be at least +10% cons’s free. If not the number of cons pages would be grown by +50% or 10 pages which ever was smaller. This might be reasonable if you +were trying to build an image which was ‘full’, ie had few free objects +of this type. +

+

(si::allocate-growth ’fixnum 0 10000 30 40) +would grow space till there were normally 40% free fixnums, usually +growing by 30% per time. +

+

(si::allocate-growth ’cons 0 0 0 40) would require 40% free conses after +garbage collection for conses, and would use system defaults for the the rate +to grow towards this goal. +

+

(si::allocate-growth ’cons -1 0 0 0) +would return the current values, but not make any changes. +

+ +
+
+
Function: OPEN-FASD (stream direction eof-value table)
+

Package:SI +

+

Given file STREAM open for input or output in DIRECTION, +set it up to start writing or reading in fasd format. When +reading from this stream the EOF-VALUE will be returned when +the end a fasd end of dump marker is encountered. TABLE should +be an eq hashtable on output, a vector on input, or nil. In this +last case a default one will be constructed. +

+

We shall refer to the result as a ‘fasd stream’. It is +suitable as the arg to CLOSE-FASD, READ-FASD-TOP, and as the second +second arg to WRITE-FASD. As a lisp object it is actually a vector, +whose body coincides with: +

+

struct fasd { + object stream; /* lisp object of type stream */ + object table; /* hash table used in dumping or vector on input*/ + object eof; /* lisp object to be returned on coming to eof mark */ + object direction; /* holds Cnil or Kinput or Koutput */ + object package; /* the package symbols are in by default */ + object index; /* integer. The current_dump index on write */ + object filepos; /* nil or the position of the start */ + object table_length; /* On read it is set to the size dump array needed + or 0 + */ + object macro ; } +

+

We did not use a defstruct for this, because we want the compiler to use this +and it makes bootstrapping more difficult. It is in "cmpnew/fasdmacros.lsp" +

+ + +
+
+
Function: WRITE-FASD-TOP (X FASD-STREAM)
+

Package:SI +

+

Write X to FASD-STREAM. +

+ +
+
+
Function: READ-FASD-TOP (FASD-STREAM)
+

Package:SI +

+

Read the next object from FASD-STREAM. Return the eof-value of FASD-STREAM if we +encounter an eof marker put out by CLOSE-FASD. Encountering end of actual file +stream causes an error. +

+ +
+
+
Function: CLOSE-FASD (FASD-STREAM)
+

Package:SI +

+

On output write an eof marker to the associated file stream, and then +make FASD-STREAM invalid for further output. It also attempts to write +information to the stream on the size of the index table needed to read from the +stream from the last open. This is useful in growing the array. +It does not alter the file stream, other than for writing this information to it. +The file stream may be reopened for further use. It is an error +to OPEN-FASD the same file or file stream again with out first calling CLOSE-FASD. +

+ + + + +
+
+
Function: FIND-SHARING-TOP (x table)
+

Package:SI +

+

X is any lisp object and TABLE is an eq hash table. This walks through X +making entries to indicate the frequency of symbols,lists, and arrays. +Initially items get -1 when they are first met, and this is decremented by 1 +each time the object occurs. Call this function on all the objects in a fasd +file, which you wish to share structure. +

+ +
+
+
Variable: *LOAD-PATHNAME*
+

Package:SI +Load binds this to the pathname of the file being loaded. +

+ +
+
+
Macro: DEFINE-INLINE-FUNCTION (fname vars &body body)
+

Package:SI +

+

This is equivalent to defun except that VARS may not contain +&optional, &rest, &key or &aux. Also a compiler property is +added, which essentially saves the body and turns this into +a let of the VARS and then execution of the body. This +last is done using si::DEFINE-COMPILER-MACRO +Example: +(si::define-inline-function myplus (a b c) (+ a b c)) +

+ +
+
+
Macro: DEFINE-COMPILER-MACRO (fname vars &body body)
+

Package:SI +

+

FNAME may be the name of a function, but at compile time the macro +expansion given by this is used. +

+

(si::define-compiler-macro mycar (a) ‘(car ,a)) +

+ +
+
+
Function: DBL ()
+

Package:SI +

+

Invoke a top level loop, in which debug commands may be entered. +These commands may also be entered at breaks, or in the error +handler. +See SOURCE-LEVEL-DEBUG +

+ +
+
+
Function: NLOAD (file)
+

Package:SI +

+

Load a file with the readtable bound to a special readtable, which +permits tracking of source line information as the file is loaded. +see SOURCE-LEVEL-DEBUG +

+ +
+
+
Function: BREAK-FUNCTION (function &optional line absolute)
+

Package:SI +

+

Set a breakpoint for a FUNCTION at LINE if the function has source +information loaded. If ABSOLUTE is not nil, then the line is understood to be +relative to the beginning of the buffer. See also dbl-break-function, the +emacs command. +

+ +
+
+
Function: XDR-OPEN (stream)
+

Package:SI +

+

Returns an object suitable for passing to XDR-READ if the stream +is an input stream, and XDR-WRITE if it was an output stream. +Note the stream must be a unix stream, on which si::fp-input-stream +or si::fp-output-stream would act as the identity. +

+ + +
+
+
Function: FP-INPUT-STREAM (stream)
+

Package:SI +

+

Return a unix stream for input associated to STREAM if possible, +otherwise return nil. +

+ +
+
+
Function: FP-OUTPUT-STREAM (stream)
+

Package:SI +

+

Return a unix stream for output associated to STREAM if possible, +otherwise return nil. +

+ + +
+
+
Function: XDR-READ (stream element)
+

Package:SI +

+

Read one item from STREAM of type the type of ELEMENT. The representation +of the elements is machine independent. The xdr routines are what is +used by the basic unix rpc calls. +

+ +
+
+
Function: XDR-WRITE (stream element)
+

Package:SI +

+

Write to STREAM the given ELEMENT. +

+ + + +
+
+
Variable: *TOP-LEVEL-HOOK*
+

Package:SI +If this variable is has a function as its value at start up time, then +it is run immediately after the init.lsp file is loaded. This is useful +for starting up an alternate top level loop. +

+ +
+
+
Function: RUN-PROCESS (string arglist)
+

Package:SI +

+ +

Execute the command STRING in a subshell passing the strings in the +list ARGLIST as arguments to the command. Return a two way stream +associated to this. Use si::fp-output-stream to get an associated +output stream or si::fp-input-stream. +

+

Bugs: It does not properly deallocate everything, so that it will fail +if you call it too many times. +

+ +
+ +
+
Variable: *CASE-FOLD-SEARCH*
+

Package: SI +Non nil means that a string-match should ignore case +

+ +
+
Function: STRING-MATCH (pattern string &optional start end)
+

Package: SI +Match regexp PATTERN in STRING starting in string starting at START +and ending at END. Return -1 if match not found, otherwise +return the start index of the first matchs. The variable +*MATCH-DATA* will be set to a fixnum array of sufficient size to hold +the matches, to be obtained with match-beginning and match-end. +If it already contains such an array, then the contents of it will +be over written. +

+

The form of a regexp pattern is discussed in See Regular Expressions. +

+
+ +
+
Function: MATCH-BEGINNING (index)
+

Returns the beginning of the I’th match from the previous STRING-MATCH, +where the 0th is for the whole regexp and the subsequent ones match parenthetical expressions. -1 is returned if there is no match, or if the *match-data* +vector is not a fixnum array. +

+ +
+
Function: MATCH-END (index)
+

Returns the end of the I’th match from the previous STRING-MATCH +

+ +
+
Function: SOCKET (port &key host server async myaddr myport daemon)
+
+

Establishes a socket connection to the specified PORT under a variety +of circumstances. +

+

If HOST is specified, then it is a string designating the IP address +of the server to which we are the client. ASYNC specifies that the +connection should be made asynchronously, and the call return +immediately. MYADDR and MYPORT can specify the IP address and port +respectively of a client connection, for example when the running +machine has several network interfaces. +

+

If SERVER is specified, then it is a function which will handle +incoming connections to this PORT. DAEMON specifies that the running +process should be forked to handle incoming connections in the +background. If DAEMON is set to the keyword PERSISTENT, then the +backgrounded process will survive when the parent process exits, and +the SOCKET call returns NIL. Any other non-NIL setting of DAEMON +causes the socket call to return the process id of the backgrounded +process. DAEMON currently only works on BSD and Linux based systems. +

+

If DAEMON is not set or nil, or if the socket is not a SERVER socket, +then the SOCKET call returns a two way stream. In this case, the +running process is responsible for all I/O operations on the stream. +Specifically, if a SERVER socket is created as a non-DAEMON, then the +running process must LISTEN for connections, ACCEPT them when present, +and call the SERVER function on the stream returned by ACCEPT. +

+
+ +
+
Function: ACCEPT (stream)
+
+

Creates a new two-way stream to handle an individual incoming +connection to STREAM, which must have been created with the SOCKET +function with the SERVER keyword set. ACCEPT should only be invoked +when LISTEN on STREAM returns T. If the STREAM was created with the +DAEMON keyword set in the call to SOCKET, ACCEPT is unnecessary and +will be called automatically as needed. +

+
+ + + +
• Regular Expressions:   +
+ +
+
+

+Next: , Previous: , Up: Top   [Contents][Index]

+
+ + + + + diff --git a/info/gcl-si/Type.html b/info/gcl-si/Type.html new file mode 100644 index 0000000..6ffe5d2 --- /dev/null +++ b/info/gcl-si/Type.html @@ -0,0 +1,197 @@ + + + + +GCL SI Manual: Type + + + + + + + + + + + + + + + + + + + + +
+

+Next: , Previous: , Up: Top   [Contents][Index]

+
+
+ +

14 Type

+ +
+
Function: COERCE (x type)
+

Package:LISP +

+

Coerces X to an object of the type TYPE. +

+ +
+ +
+
Function: TYPE-OF (x)
+

Package:LISP +

+

Returns the type of X. +

+ +
+ +
+
Function: CONSTANTP (symbol)
+

Package:LISP +

+

Returns T if the variable named by SYMBOL is a constant; NIL otherwise. +

+ +
+ +
+
Function: TYPEP (x type)
+

Package:LISP +

+

Returns T if X is of the type TYPE; NIL otherwise. +

+ +
+ +
+
Function: COMMONP (x)
+

Package:LISP +

+

Returns T if X is a Common Lisp object; NIL otherwise. +

+ +
+ +
+
Function: SUBTYPEP (type1 type2)
+

Package:LISP +

+

Returns T if TYPE1 is a subtype of TYPE2; NIL otherwise. If it could not +determine, then returns NIL as the second value. Otherwise, the second value +is T. +

+ +
+ +
+
Macro: CHECK-TYPE
+

Package:LISP +

+

Syntax: +

+
(check-type place typespec [string])
+
+ +

Signals an error, if the contents of PLACE are not of the specified type. +

+ +
+ +
+
Macro: ASSERT
+

Package:LISP +

+

Syntax: +

+
(assert test-form [({place}*) [string {arg}*]])
+
+ +

Signals an error if the value of TEST-FORM is NIL. STRING is an format string +used as the error message. ARGs are arguments to the format string. +

+ +
+ +
+
Macro: DEFTYPE
+

Package:LISP +

+

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}*) +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 GCL encounters a +type specifier (NAME arg1 ... argn), it calls the expansion function with +the arguments arg1 ... argn, and uses the returned value instead of the +original type specifier. When the symbol NAME is used as a type specifier, +the expansion function is called with no argument. The doc-string DOC, if +supplied, is saved as the TYPE doc of NAME, and is retrieved by +(documentation ’NAME ’type). +

+ +
+ +
+
Declaration: DYNAMIC-EXTENT
+

Package:LISP +Declaration to allow locals to be cons’d on the C stack. +For example +(defun foo (&rest l) (declare (:dynamic-extent l)) ...) +will cause l to be a list formed on the C stack of the foo function +frame. +Of course passing L out as a value of foo will cause havoc. +(setq x (make-list n)) +(setq x (cons a b)) +(setq x (list a b c ..)) +also are handled on the stack, for dynamic-extent x. +

+ + +
+ +
+
+

+Next: , Previous: , Up: Top   [Contents][Index]

+
+ + + + + diff --git a/info/gcl-si/User-Interface.html b/info/gcl-si/User-Interface.html new file mode 100644 index 0000000..fbc7db6 --- /dev/null +++ b/info/gcl-si/User-Interface.html @@ -0,0 +1,485 @@ + + + + +GCL SI Manual: User Interface + + + + + + + + + + + + + + + + + + + + +
+

+Next: , Previous: , Up: Top   [Contents][Index]

+
+
+ +

12 User Interface

+ +
+
Special Variable: -
+

Package:LISP +Holds the top-level form that GCL is currently evaluating. +

+ +
+ +
+
Function: - (number &rest more-numbers)
+

Package:LISP +

+

Subtracts the second and all subsequent NUMBERs from the first NUMBER. +With one arg, negates it. +

+ +
+ +
+
Macro: UNTRACE
+

Package:LISP +

+

Syntax: +

+
(untrace {function-name}*)
+
+ +

Removes tracing from the specified functions. With no FUNCTION-NAMEs, +untraces all functions. +

+ +
+ +
+
Variable: ***
+

Package:LISP +Gets the previous value of ** when GCL evaluates a top-level form. +

+ +
+ +
+
Function: MAKE-STRING-INPUT-STREAM (string &optional (start 0) (end (length string)))
+

Package:LISP +

+

Returns an input stream which will supply the characters of String between +Start and End in order. +

+ +
+ +
+
Macro: STEP
+

Package:LISP +

+

Syntax: +

+
(step form)
+
+ +

Evaluates FORM in the single-step mode and returns the value. +

+ +
+ +
+
Variable: *BREAK-ENABLE*
+

Package:LISP +GCL specific: When an error occurrs, control enters to the break loop only +if the value of this variable is non-NIL. +

+ +
+ +
+
Special Variable: /
+

Package:LISP +Holds a list of the values of the last top-level form. +

+ +
+ +
+
Function: DESCRIBE (x)
+

Package:LISP +

+

Prints a description of the object X. +

+ +
+ +
+
Function: ED (&optional x)
+

Package:LISP +

+

Invokes the editor. The action depends on the version of GCL. +

+ +
+ +
+
Variable: *DEBUG-IO*
+

Package:LISP +Holds the I/O stream used by the GCL debugger. +

+ +
+ +
+
Variable: *BREAK-ON-WARNINGS*
+

Package:LISP +When the function WARN is called, control enters to the break loop only +if the value of this varialbe is non-NIL. +

+ +
+ +
+
Function: CERROR (continue-format-string error-format-string &rest args)
+

Package:LISP +

+

Signals a correctable error. +

+ +
+ +
+
Variable: **
+

Package:LISP +Gets the previous value of * when GCL evaluates a top-level form. +

+ +
+ +
+
Special Variable: +++
+

Package:LISP +Gets the previous value of ++ when GCL evaluates a top-level form. +

+ +
+ +
+
Function: INSPECT (x)
+

Package:LISP +

+

Shows the information about the object X in an interactive manner +

+ +
+ +
+
Special Variable: //
+

Package:LISP +Gets the previous value of / when GCL evaluates a top-level form. +

+ +
+ +
+
Variable: *TRACE-OUTPUT*
+

Package:LISP +The trace output stream. +

+ +
+ +
+
Special Variable: ++
+

Package:LISP +Gets the previous value of + when GCL evaluates a top-level form. +

+ +
+ +
+
Variable: *ERROR-OUTPUT*
+

Package:LISP +Holds the output stream for error messages. +

+ +
+ +
+
Function: DRIBBLE (&optional pathname)
+

Package:LISP +

+

If PATHNAME is given, begins to record the interaction to the specified file. +If PATHNAME is not given, ends the recording. +

+ +
+ +
+
Variable: *
+

Package:LISP +Holds the value of the last top-level form. +

+ +
+ +
+
Special Variable: ///
+

Package:LISP +Gets the previous value of // when GCL evaluates a top-level form. +

+ +
+ +
+
Function: WARN (format-string &rest args)
+

Package:LISP +

+

Formats FORMAT-STRING and ARGs to *ERROR-OUTPUT* as a warning message. +

+ +
+ +
+
Function: BREAK (&optional (format-string nil) &rest args)
+

Package:LISP +

+

Enters a break loop. If FORMAT-STRING is non-NIL, formats FORMAT-STRING +and ARGS to *ERROR-OUTPUT* before entering a break loop. +Typing :HELP at the break loop will list the break-loop commands. +

+ +
+ +
+
Special Variable: +
+

Package:LISP +Holds the last top-level form. +

+ +
+ +
+
Macro: TRACE
+

Package:LISP +

+

Syntax: +

+
(trace {function-name}*)
+
+ +

Traces the specified functions. With no FUNCTION-NAMEs, returns a list of +functions currently being traced. +

+

Additional Keywords are allowed in GCL with the +syntax (trace {fn | (fn {:kw form}*)}*) +

+

For each FN naming a function, traces that function. Each :KW should +be one of the ones listed below, and FORM should have the +corresponding form. No :KW may be given more than once for the same +FN. Returns a list of all FNs now traced which weren’t already +traced. +

+ +

EXAMPLE (Try this with your favorite factorial function FACT): +

+
+
;; print entry args and exit values
+
+(trace FACT)
+
+;; Break coming out of FACT if the value is bigger than 1000.
+
+(trace (fact :exit
+	     (progn
+	       (if (> (car values) 1000)(break "big result"))
+	       (car values))))
+
+;; Hairy example:
+
+;;make arglist available without the si:: prefix
+(import 'si::arglist)
+
+(trace (fact
+        :DECLARATIONS
+        ((in-string "Here comes input: ")
+         (out-string "Here comes output: ")
+         all-values
+         (silly (+ 3 4)))
+        :COND
+        (equal (rem (car arglist) 2) 0)
+        :ENTRY
+        (progn
+          (cond
+           ((equal (car arglist) 8)
+            (princ "Entering FACT on input 8!! ")
+            (setq out-string "Here comes output from inside (FACT 8): "))
+           (t
+            (princ in-string)))
+          (car arglist))
+        :EXIT
+        (progn
+          (setq all-values (cons (car values) all-values))
+          (princ out-string)
+          (when (equal (car arglist) 8)
+                ;; reset out-string
+                (setq out-string "Here comes output: "))
+          (cons 'fact values))
+        :ENTRYCOND
+        (not (= (car arglist) 6))
+        :EXITCOND
+        (not (= (car values) (* 6 (car arglist))))
+        :DEPTH
+        5))
+
+ +

Syntax is :keyword form1 :keyword form2 ... +

+
+
:declarations
+
+
DEFAULT: NIL
+
+ +

FORM is ((var1 form1 )(var2 form2 )...), where +the var_i are symbols distinct from each other and from +all symbols which are similarly declared for currently +traced functions. Each form is evaluated immediately. +Upon any invocation of a traced function when not already +inside a traced function call, each var is bound to +that value of form . +

+
+
:COND
+
+
DEFAULT: T
+
+ +

Here, FORM is any Lisp form to be evaluated (by EVAL) +upon entering a call of FN, in the environment where si::ARGLIST +is bound to the current list of arguments of FN. Note that +even if the evaluation of FORM changes the value of SI::ARGLIST +(e.g. by evaluation of (SETQ si::ARGLIST ...)), the list of +arguments passed to FN is unchanged. Users may alter args passed +by destructively modifying the list structure of SI::ARGLIST +however. The call is traced +(thus invoking the :ENTRYCOND and :EXITCOND forms, at least) +if and only if FORM does not evaluate to NIL. +

+
+
:ENTRYCOND
+
+
DEFAULT: T
+
+ +

This is evaluated (by EVAL) if the :COND form evaluates to +non-NIL, both in an environment where SI::ARGLIST is bound to the +current list of arguments of FN. If non-NIL, the :ENTRY form +is then evaluated and printed with the trace "prompt". +

+
+
:ENTRY
+
+
DEFAULT: (CONS (QUOTE x) SI::ARGLIST),
+
+ +

where x is the symbol we call FN +If the :COND and :ENTRYCOND forms evaluate to non-NIL, +then the trace "prompt" is printed and then this FORM is +evaluated (by EVAL) in an environment where SI::ARGLIST is bound +to the current list of arguments of FN. The result is then +printed. +

+
+
:EXITCOND
+
+
DEFAULT: T
+
+ +

This is evaluated (by EVAL) in the environment described +below for the :EXIT form. The :EXIT form is then evaluated +and printed with the "prompt" if and only if the result here +is non-NIL. +

+
+
:EXIT
+
+
DEFAULT: (CONS (QUOTE x) VALUES),
+
+ +

where x is the symbol we call FN +Upon exit from tracing a given call, this FORM is +evaluated (after the appropriate trace "prompt" is printed), +using EVAL in an environment where SI::ARGLIST is bound to the +current list of arguments of FN and VALUES is bound to the +list of values returned by FN (recalling that Common Lisp +functions may return multiple values). +

+
+
:DEPTH
+
+
DEFAULT:  No depth limit
+
+ +

FORM is simply a positive integer specifying the maximum +nesting of traced calls of FN, i.e. of calls of FN in which +the :COND form evaluated to non-NIL. For calls of FN in +which this limit is exceeded, even the :COND form is not +evaluated, and the call is not traced. +

+
+
+ +
+ + + + + + +
+
+

+Next: , Previous: , Up: Top   [Contents][Index]

+
+ + + + + diff --git a/info/gcl-si/index.html b/info/gcl-si/index.html new file mode 100644 index 0000000..2cc7f01 --- /dev/null +++ b/info/gcl-si/index.html @@ -0,0 +1,160 @@ + + + + +GCL SI Manual: Top + + + + + + + + + + + + + + + + + + + + + + + + + + +
+

+Next: , Previous: , Up: (dir)   [Contents][Index]

+
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
• Numbers:   +
• Sequences and Arrays and Hash Tables:   +
• Characters:   +
• Lists:   +
• Streams and Reading:   +
• Special Forms and Functions:   +
• Compilation:   +
• Symbols:   +
• Operating System:   +
• Structures:   +
• Iteration and Tests:   +
• User Interface:   +
• Doc:   +
• Type:   +
• GCL Specific:   +
• C Interface:   +
• System Definitions:   +
• Debugging:   +
• Miscellaneous:   +
• Compiler Definitions:   +
• Function and Variable Index:   +
+ — The Detailed Node Listing —
+
+Operating System
+
+
• Command Line:   +
• Operating System Definitions:   +
+GCL Specific
+
+
• Bignums:   +
+C Interface
+
+
• Available Symbols:   +
+System Definitions
+
+
• Regular Expressions:   +
+Debugging
+
+
• Source Level Debugging in Emacs:   +
• Low Level Debug Functions:   +
+Miscellaneous
+
+
• Environment:   +
• Inititialization:   +
• Low Level X Interface:   +
+ +
+
+

+Next: , Previous: , Up: (dir)   [Contents][Index]

+
+ + + + + diff --git a/info/gcl-tk.info b/info/gcl-tk.info new file mode 100644 index 0000000..24d1990 --- /dev/null +++ b/info/gcl-tk.info @@ -0,0 +1,72 @@ +This is gcl-tk.info, produced by makeinfo version 5.2 from gcl-tk.texi. + +INFO-DIR-SECTION GNU Common Lisp +START-INFO-DIR-ENTRY +* gcl-tk: (gcl-tk.info). GNU TK Manual +END-INFO-DIR-ENTRY + +This is a Texinfo GCL TK Manual + + Copyright 1994 William F. Schelter + + +Indirect: +gcl-tk.info-1: 258 +gcl-tk.info-2: 301240 + +Tag Table: +(Indirect) +Node: Top258 +Node: General1286 +Node: Introduction1589 +Node: Getting Started3086 +Node: Common Features of Widgets4688 +Node: Return Values8350 +Node: Argument Lists12408 +Node: Lisp Functions Invoked from Graphics15840 +Node: Linked Variables20893 +Node: tkconnect24626 +Node: Widgets26553 +Node: button26886 +Node: listbox33607 +Node: scale42026 +Node: canvas49273 +Node: menu109974 +Node: scrollbar129133 +Node: checkbutton136422 +Node: menubutton146160 +Node: text154138 +Node: entry188279 +Node: message198621 +Node: frame204579 +Node: label208582 +Node: radiobutton211997 +Node: toplevel221434 +Node: Control225276 +Node: after225730 +Node: bind226886 +Node: destroy242569 +Node: tk-dialog243154 +Node: exit244969 +Node: focus245646 +Node: grab250361 +Node: tk-listbox-single-select255029 +Node: lower255933 +Node: tk-menu-bar256811 +Node: option262479 +Node: options265561 +Node: pack-old283145 +Node: pack290905 +Node: place301241 +Node: raise310062 +Node: selection310921 +Node: send316127 +Node: tk317948 +Node: tkerror319785 +Node: tkvars321509 +Node: tkwait323777 +Node: update325261 +Node: winfo326783 +Node: wm335226 + +End Tag Table diff --git a/info/gcl-tk.info-1 b/info/gcl-tk.info-1 new file mode 100644 index 0000000..571bf42 --- /dev/null +++ b/info/gcl-tk.info-1 @@ -0,0 +1,6649 @@ +This is gcl-tk.info, produced by makeinfo version 5.2 from gcl-tk.texi. + +INFO-DIR-SECTION GNU Common Lisp +START-INFO-DIR-ENTRY +* gcl-tk: (gcl-tk.info). GNU TK Manual +END-INFO-DIR-ENTRY + +This is a Texinfo GCL TK Manual + + Copyright 1994 William F. Schelter + + +File: gcl-tk.info, Node: Top, Next: General, Prev: (dir), Up: (dir) + +* Menu: + +* General:: +* Widgets:: +* Control:: + + -- The Detailed Node Listing -- + +General + +* Introduction:: +* Getting Started:: +* Common Features of Widgets:: +* Return Values:: +* Argument Lists:: +* Lisp Functions Invoked from Graphics:: +* Linked Variables:: +* tkconnect:: + +Widgets + +* button:: +* listbox:: +* scale:: +* canvas:: +* menu:: +* scrollbar:: +* checkbutton:: +* menubutton:: +* text:: +* entry:: +* message:: +* frame:: +* label:: +* radiobutton:: +* toplevel:: + +Control + +* after:: +* bind:: +* destroy:: +* tk-dialog:: +* exit:: +* focus:: +* grab:: +* tk-listbox-single-select:: +* lower:: +* tk-menu-bar:: +* option:: +* options:: +* pack-old:: +* pack:: +* place:: +* raise:: +* selection:: +* send:: +* tk:: +* tkerror:: +* tkvars:: +* tkwait:: +* update:: +* winfo:: +* wm:: + + +File: gcl-tk.info, Node: General, Next: Widgets, Prev: Top, Up: Top + +1 General +********* + +* Menu: + +* Introduction:: +* Getting Started:: +* Common Features of Widgets:: +* Return Values:: +* Argument Lists:: +* Lisp Functions Invoked from Graphics:: +* Linked Variables:: +* tkconnect:: + + +File: gcl-tk.info, Node: Introduction, Next: Getting Started, Prev: General, Up: General + +1.1 Introduction +================ + +GCL-TK is a windowing interface for GNU Common Lisp. It provides the +functionality of the TK widget set, which in turn implements a widget +set which has the look and feel of Motif. + + The interface allows the user to draw graphics, get input from menus, +make regions mouse sensitive, and bind lisp commands to regions. It +communicates over a socket with a 'gcltksrv' process, which speaks to +the display via the TK library. The displaying process may run on a +machine which is closer to the display, and so involves less +communication. It also may remain active even though the lisp is +involved in a separate user computation. The display server can, +however, interrupt the lisp at will, to inquire about variables and run +commands. + + The user may also interface with existing 'TCL/TK' programs, binding +some buttons, or tracking some objects. + + The size of the program is moderate. In its current form it adds +only about 45K bytes to the lisp image, and the 'gcltksrv' program uses +shared libraries, and is on the order of 150Kbytes on a sparc. + + This chapter describes some of the common features of the command +structure of widgets, and of control functions. The actual functions +for construction of windows are discussed in *note Widgets::, and more +general functions for making them appear, lowering them, querying about +them in *note Control::. + + +File: gcl-tk.info, Node: Getting Started, Next: Common Features of Widgets, Prev: Introduction, Up: General + +1.2 Getting Started +=================== + +Once GCL has been properly installed you should be able to do the +following simple example: + + (in-package "TK") + (tkconnect) + (button '.hello :text "Hello World" :command '(print "hi")) + ==>.HELLO + (pack '.hello) + We first switched to the "TK" package, so that functions like button +and pack would be found. After doing the tkconnect, a window should +appear on your screen, see *Note tkconnect::. The invocation of the +function 'button' creates a new function called '.hello' which is a +widget function. It is then made visible in the window by using the +'pack' function. + + You may now click on the little window, and you should see the +command executed in your lisp. Thus "hi" should be printed in the lisp +window. This will happen whether or not you have a job running in the +lisp, that is lisp will be interrupted and your command will run, and +then return the control to your program. + + The function 'button' is called a widget constructor, and the +function '.hello' is called a widget. If you have managed to accomplish +the above, then GCL is probably installed correctly, and you can +graduate to the next section! If you dont like reading but prefer to +look at demos and code, then you should look in the demos directory, +where you will find a number of examples. A monitor for the garbage +collector (mkgcmonitor), a demonstration of canvas widgets (mkitems), a +sample listbox with scrolling (mklistbox). + + +File: gcl-tk.info, Node: Common Features of Widgets, Next: Return Values, Prev: Getting Started, Up: General + +1.3 Common Features of Widgets +============================== + +A widget is a lisp symbol which has a function binding. The first +argument is always a keyword and is called the option. The argument +pattern for the remaining arguments depends on the option. The most +common option is ':configure' in which case the remaining arguments are +alternating keyword/value pairs, with the same keywords being permitted +as at the creation of the widget. + + A widget is created by means of a widget constructor, of which there +are currently 15, each of them appearing as the title of a section in +*note Widgets::. They live in the '"TK"' package, and for the moment we +will assume we have switched to this package. Thus for example 'button' +is such a widget constructor function. Of course this is lisp, and you +can make your own widget constructors, but when you do so it is a good +idea to follow the standard argument patterns that are outlined in this +section. + + (button '.hello) + ==> .HELLO +creates a widget whose name is '.hello'. There is a parent child +hierarchy among widgets which is implicit in the name used for the +widget. This is much like the pathname structure on a Unix or Dos file +system, except that ''.'' is used as the separator rather than a '/' or +'\'. For this reason the widget instances are sometimes referred to as +pathnames. A child of the parent widget '.hello' might be called +'.hello.joe', and a child of this last might be '.hello.joe.bar'. The +parent of everyone is called '.' . Multiple top level windows are +created using the 'toplevel' command (*note toplevel::). + + The widget constructor functions take keyword and value pairs, which +allow you to specify attributes at the time of creation: + + (button '.hello :text "Hello World" :width 20) + ==>.HELLO +indicating that we want the text in the button window to be 'Hello +World' and the width of the window to be 20 characters wide. Other +types of windows allow specification in centimeters '2c', or in inches +('2i') or in millimeters '2m' or in pixels '2'. But text windows +usually have their dimensions specified as multiples of a character +width and height. This latter concept is called a grid. + + Once the window has been created, if you want to change the text you +do NOT do: + (button '.hello :text "Bye World" :width 20) + This would be in error, because the window .hello already exists. +You would either have to first call + + (destroy '.hello) + + But usually you just want to change an attribute. '.hello' is +actually a function, as we mentioned earlier, and it is this function +that you use: + + (.hello :configure :text "Bye World") + + This would simply change the text, and not change where the window +had been placed on the screen (if it had), or how it had been packed +into the window hierarchy. Here the argument ':configure' is called an +option, and it specifies which types of keywords can follow it. For +example + + (.hello :flash) +is also valid, but in this case the ':text' keyword is not permitted +after flash. If it were, then it would mean something else besides what +it means in the above. For example one might have defined + + (.hello :flash :text "PUSH ME") +so here the same keyword ':text' would mean something else, eg to flash +a subliminal message on the screen. + + We often refer to calls to the widget functions as messages. One +reason for this is that they actually turn into messages to the graphics +process 'gcltksrv'. To actually see these messages you can do + (debugging t). + + +File: gcl-tk.info, Node: Return Values, Next: Argument Lists, Prev: Common Features of Widgets, Up: General + +1.4 Return Values +================= + +1.4.1 Widget Constructor Return Values +-------------------------------------- + +On successful completion, the widget constructor functions return the +symbol passed in as the first argument. It will now have a functional +binding. It is an error to pass in a symbol which already corresponds +to a widget, without first calling the 'destroy' command. On failure, +an error is signalled. + +1.4.2 Widget Return Values +-------------------------- + +The widget functions themselves, do not normally return any value. +Indeed the lisp process does not wait for them to return, but merely +dispatches the commands, such as to change the text in themselves. +Sometimes however you either wish to wait, in order to synchronize, or +you wish to see if your command fails or succeeds. You request values +by passing the keyword :return and a value indicating the type. + + (.hello :configure :text "Bye World" :return 'string) + ==> "" + ==> T +the empty string is returned as first value, and the second value 'T' +indicates that the new text value was successfully set. LISP will not +continue until the tkclsrv process indicates back that the function call +has succeeded. While waiting of course LISP will continue to process +other graphics events which arrive, since otherwise a deadlock would +arise: the user for instance might click on a mouse, just after we had +decided to wait for a return value from the '.hello' function. More +generally a user program may be running in GCL and be interrupted to +receive and act on communications from the 'gcltksrv' process. If an +error occurred then the second return value of the lisp function will be +NIL. In this case the first value, the string is usually an informative +message about the type of error. + + A special variable 'tk::*break-on-errors*' which if not 'nil', +requests that that LISP signal an error when a message is received +indicating a function failed. Whenever a command fails, whether a +return value was requested or not, 'gcltksrv' returns a message +indicating failure. The default is to not go into the debugger. When +debugging your windows it may be convenient however to set this variable +to 'T' to track down incorrect messages. + + The 'gcltksrv' process always returns strings as values. If +':return' type is specified, then conversion to type is accomplished by +calling + + (coerce-result return-string type) + + Here type must be a symbol with a 'coercion-functions' property. The +builtin return types which may be requested are: + +'T' + in which case the string passed back from the 'gcltksrv' process, + will be read by the lisp reader. +'number' + the string is converted to a number using the current *read-base* +'list-strings' + + (coerce-result "a b {c d} e" 'list-strings) + ==> ("a" "b" "c d" "e") +'boolean' + (coerce-result "1" 'boolean) ==> T (coerce-result "0" 'boolean) ==> + NIL + + The above symbols are in the 'TK' or 'LISP' package. It would be +possible to add new types just as the ':return t' is done: + + (setf (get 't 'coercion-functions) + (cons #'(lambda (x) (our-read-from-string x 0)) + #'(lambda (x) (format nil "~s" x)))) + + The 'coercion-functions' property of a symbol, is a cons whose 'car' +is the coercion form from a string to some possibly different lisp +object, and whose 'cdr' is a function which builds a string to send to +the graphics server. Often the two functions are inverse functions one +of the other up to equal. + +1.4.3 Control Function Return Values +------------------------------------ + +The control funcions (*note Control::) do not return a value or wait +unless requested to do so, using the ':return' keyword. The types and +method of specification are the same as for the Widget Functions in the +previous section. + + (winfo :width '.hello :return 'number) + ==> 120 +indicates that the '.hello' button is actually 120 pixels wide. + + +File: gcl-tk.info, Node: Argument Lists, Next: Lisp Functions Invoked from Graphics, Prev: Return Values, Up: General + +1.5 Argument Lists +================== + +1.5.1 Widget Functions +---------------------- + +The rule is that the first argument for a widget function is a keyword, +called the option. The pattern of the remaining arguments depends +completely on the option argument. Thus + + (.hello option ?arg1? ?arg2? ...) + + One option which is permitted for every widget function is +':configure'. The argument pattern following it is the same +keyword/value pair list which is used in widget creation. For a +'button' widget, the other valid options are ':deactivate', ':flash', +and ':invoke'. To find these, since '.hello' was constructed with the +'button' constructor, you should see *Note button::. The argument +pattern for other options depends completely on the option and the +widget function. For example if '.scrollbar' is a scroll bar window, +then the option ':set' must be followed by 4 numeric arguments, which +indicate how the scrollbar should be displayed, see *Note scrollbar::. + + (.scrollbar :set a1 a2 a3 a4) + + If on the other hand '.scale' is a scale (*note scale::), then we +have + + (.scale :set a1 ) +only one numeric argument should be supplied, in order to position the +scale. + +1.5.2 Widget Constructor Argument Lists +--------------------------------------- + +These are + + (widget-constructor pathname :keyword1 value1 :keyword2 value2 ...) + +to create the widget whose name is pathname. The possible keywords +allowed are specified in the corresponding section of *Note Widgets::. + +1.5.3 Concatenation Using ':' in Argument List +---------------------------------------------- + +What has been said so far about arguments is not quite true. A special +string concatenation construction is allowed in argument lists for +widgets, widget constructors and control functions. + + First we introduce the function 'tk-conc' which takes an arbitrary +number of arguments, which may be symbols, strings or numbers, and +concatenates these into a string. The print names of symbols are +converted to lower case, and package names are ignored. + + (tk-conc "a" 1 :b 'cd "e") ==> "a1bcde" + + One could use 'tk-conc' to construct arguments for widget functions. +But even though 'tk-conc' has been made quite efficient, it still would +involve the creation of a string. The ':' construct avoids this. In a +call to a widget function, a widget constructor, or a control function +you may remove the call to 'tk-conc' and place ':' in between each of +its arguments. Those functions are able to understand this and treat +the extra arguments as if they were glued together in one string, but +without the extra cost of actually forming that string. + + (tk-conc a b c .. w) <==> a : b : c : ... w + (setq i 10) + (.hello :configure :text i : " pies") + (.hello :configure :text (tk-conc i " pies")) + (.hello :configure :text (format nil "~a pies" i)) + + The last three examples would all result in the text string being +'"10 pies"', but the first method is the most efficient. That call will +be made with no string or cons creation. The GC Monitor example, is +written in such a way that there is no creation of 'cons' or 'string' +types during normal operation. This is particularly useful in that +case, since one is trying to monitor usage of conses by other programs, +not its own usage. + + +File: gcl-tk.info, Node: Lisp Functions Invoked from Graphics, Next: Linked Variables, Prev: Argument Lists, Up: General + +1.6 Lisp Functions Invoked from Graphics +======================================== + +It is possible to make certain areas of a window mouse sensitive, or to +run commands on reception of certain events such as keystrokes, while +the focus is in a certain window. This is done by having a lisp +function invoked or some lisp form evaluated. We shall refer to such a +lisp function or form as a _command_. + + For example + + (button '.button :text "Hello" :command '(print "hi")) + (button '.jim :text "Call Jim" :command 'call-jim) + + In the first case when the window '.button' is clicked on, the word +"hi" will be printed in the lisp to standard output. In the second case +'call-jim' will be funcalled with no arguments. + + A command must be one of the following three types. What happens +depends on which type it is: + +'function' + If the value satisfies 'functionp' then it will be called with a + number of arguments which is dependent on the way it was bound, to + graphics. +'string' + If the command is a string, then it is passed directly to TCL/TK + for evaluation on that side. Lisp will not be required for the + evaluation when the command is invoked. +'lisp form' + Any other lisp object is regarded as a lisp form to be eval'd, and + this will be done when the command is invoked. + + The following keywords accept as their value a command: + + :command + :yscroll :yscrollcommand + :xscroll :xscrollcommand + :scrollcommand + :bind + +and in addition 'bind' takes a command as its third argument, see *Note +bind::. + + Below we give three different examples using the 3 possibilities for +a command: functionp, string, and lisp form. They all accomplish +exactly the same thing. For given a frame '.frame' we could construct a +listbox in it as: + + (listbox '.frame.listbox :yscroll 'joe) + + Then whenever the listbox view position changes, or text is inserted, +so that something changes, the function 'joe' will be invoked with 4 +arguments giving the totalsize of the text, maximum number of units the +window can display, the index of the top unit, and finally the index of +the bottom unit. What these arguments are is specific to the widget +'listbox' and is documented *Note listbox::. + + 'joe' might be used to do anything, but a common usage is to have +'joe' alter the position of some other window, such as a scroll bar +window. Indeed if '.scrollbar' is a scrollbar then the function + + (defun joe (a b c d) + (.scrollbar :set a b c d)) + +would look after sizing the scrollbar appropriately for the percentage +of the window visible, and positioning it. + + A second method of accomplishing this identical, using a string (the +second type of command), + + (listbox '.frame.listbox :yscroll ".scrollbar set") + +and this will not involve a call back to lisp. It uses the fact that +the TK graphics side understands the window name '.scrollbar' and that +it takes the option 'set'. Note that it does not get the ':' before the +keyword in this case. + + In the case of a command which is a lisp form but is not installed +via 'bind' or ':bind', then the form will be installed as + + #'(lambda (&rest *arglist*) lisp-form) + +where the lisp-form might wish to access the elements of the special +variable '*arglist*'. Most often this list will be empty, but for +example if the command was setup for '.scale' which is a scale, then the +command will be supplied one argument which is the new numeric value +which is the scale position. A third way of accomplishing the scrollbar +setting using a lisp form is: + + (listbox '.frame.listbox :yscroll '(apply '.scrollbar :set *arglist*)) + + The 'bind' command and ':bind' keyword, have an additional wrinkle, +see *Note bind::. These are associated to an event in a particular +window, and the lisp function or form to be evaled must have access to +that information. For example the x y position, the window name, the +key pressed, etc. This is done via percent symbols which are specified, +see *Note bind::. + + (bind "Entry" "" '(emacs-move %W %A )) + +will cause the function emacs-move to be be invoked whenever a control +key is pressed (unless there are more key specific or window specific +bindings of said key). It will be invoked with two arguments, the first +%W indicating the window in which it was invoked, and the second being a +string which is the ascii keysym which was pressed at the same time as +the control key. + + These percent constructs are only permitted in commands which are +invoked via 'bind' or ':bind'. The lisp form which is passed as the +command, is searched for the percent constructs, and then a function + + #'(lambda (%W %A) (emacs-move %W %A)) + +will be invoked with two arguments, which will be supplied by the TK +graphics server, at the time the command is invoked. The '*arglist*' +construct is not available for these commands. + + +File: gcl-tk.info, Node: Linked Variables, Next: tkconnect, Prev: Lisp Functions Invoked from Graphics, Up: General + +1.7 Linked Variables +==================== + +It is possible to link lisp variables to TK variables. In general when +the TK variable is changed, by for instance clicking on a radiobutton, +the linked lisp variable will be changed. Conversely changing the lisp +variable will be noticed by the TK graphics side, if one does the +assignment in lisp using 'setk' instead of 'setq'. + + (button '.hello :textvariable '*message* :text "hi there") + (pack '.hello) + + This causes linking of the global variable '*message*' in lisp to a +corresponding variable in TK. Moreover the message that is in the button +'.hello' will be whatever the value of this global variable is (so long +as the TK side is notified of the change!). + + Thus if one does + + (setk *message* "good bye") + +then the button will change to have good bye as its text. The lisp +macro 'setk' expands into + + (prog1 (setf *message* "good bye") (notice-text-variables)) + +which does the assignment, and then goes thru the linked variables +checking for those that have changed, and updating the TK side should +there be any. Thus if you have a more complex program which might have +done the assignment of your global variable, you may include the call to +'notice-text-variables' at the end, to assure that the graphics side +knows about the changes. + + A variable which is linked using the keyword ':textvariable' is +always a variable containing a string. + + However it is possible to have other types of variables. + + (checkbutton '.checkbutton1 :text "A button" :variable '(boolean *joe*)) + (checkbutton '.checkbutton2 :text "A button" :variable '*joe*) + (checkbutton '.checkbutton3 :text "Debugging" :variable '(t *debug*) + :onvalue 100 :offvalue -1) + + The first two examples are the same in that the default variable type +for a checkbutton is 'boolean'. Notice that the specification of a +variable type is by '(type variable)'. The types which are permissible +are those which have coercion-fucntions, *Note Return Values::. In the +first example a variable '*joe*' will be linked, and its default initial +value will be set to nil, since the default initial state of the check +button is off, and the default off value is nil. Actually on the TK +side, the corresponding boolean values are '"1"' and '"0"', but the +'boolean' type makes these become 't' and 'nil'. + + In the third example the variable *debug* may have any lisp value +(here type is 't'). The initial value will be made to be '-1', since +the checkbutton is off. Clicking on '.checkbutton3' will result in the +value of '*debug*' being changed to 100, and the light in the button +will be toggled to on, *Note checkbutton::. You may set the variable to +be another value besides 100. + + You may also call + + (link-text-variable '*joe* 'boolean) + +to cause the linking of a variable named *joe*. This is done +automatically whenever the variable is specified after one of the keys + + :variable :textvariable. + + Just as one must be cautious about using global variables in lisp, +one must be cautious in making such linked variables. In particular +note that the TK side, uses variables for various purposes. If you make +a checkbutton with pathname '.a.b.c' then unless you specify a +':variable' option, the variable 'c' will become associated to the TK +value of the checkbutton. We do NOT link this variable by default, +feeling that one might inadvertently alter global variables, and that +they would not typically use the lisp convention of being of the form +'*c*'. You must specify the ':variable' option, or call +'link-variable'. + + +File: gcl-tk.info, Node: tkconnect, Prev: Linked Variables, Up: General + +1.8 tkconnect +============= + + tkconnect &key host display can-rsh gcltksrv + + This function provides a connection to a graphics server process, +which in turn connects to possibly several graphics display screens. +The graphics server process, called 'gcltksrv' may or may not run on the +same machine as the lisp to which it is attached. 'display' indicates +the name of the default display to connect to, and this in turn defaults +to the value of the environment variable 'DISPLAY'. + + When tkconnect is invoked, a socket is opened and it waits for a +graphics process to connect to it. If the host argument is not +supplied, then a process will be spawned which will connect back to the +lisp process. The name of the command for invoking the process is the +value of the 'gcltksrv' argument, which defaults to the value of the +environment variable 'GCL_TK_SERVER'. If that variable is not set, then +the lisp '*lib-directory*' is searched for an entry 'gcl-tk/gcltksrv'. + + If 'host' is supplied, then a command to run on the remote machine +will be printed on standard output. If 'can-rsh' is not nil, then the +command will not be printed, but rather an attempt will be made to rsh +to the machine, and to run the command. + + Thus + + (tkconnect) + +would start the process on the local machine, and use for 'display' the +value of the environment variable 'DISPLAY'. + + (tkconnect :host "max.ma.utexas.edu" :can-rsh t) + +would cause an attempt to rsh to 'max' and to run the command there, to +connect back to the appropriate port on the localhost. + + You may indicate that different toplevel windows be on different +displays, by using the ':display' argument when creating the window, +*Note toplevel::. + + Clearly you must have a copy of the program 'gcltksrv' and TK +libraries installed on the machine where you wish to run the server. + + +File: gcl-tk.info, Node: Widgets, Next: Control, Prev: General, Up: Top + +2 Widgets +********* + +* Menu: + +* button:: +* listbox:: +* scale:: +* canvas:: +* menu:: +* scrollbar:: +* checkbutton:: +* menubutton:: +* text:: +* entry:: +* message:: +* frame:: +* label:: +* radiobutton:: +* toplevel:: + + +File: gcl-tk.info, Node: button, Next: listbox, Prev: Widgets, Up: Widgets + +2.1 button +========== + +button \- Create and manipulate button widgets + +Synopsis +-------- + +button pathName ?options? + +Standard Options +---------------- + + activeBackground bitmap font relief + activeForeground borderWidth foreground text + anchor cursor padX textVariable + background disabledForeground padY + + *Note options::, for more information. + +Arguments for Button +-------------------- + +':command' + Name='"command" Class="Command"' + + Specifies a Tcl command to associate with the button. This command + is typically invoked when mouse button 1 is released over the + button window. + +':height' + Name='"height" Class="Height"' + + Specifies a desired height for the button. If a bitmap is being + displayed in the button then the value is in screen units (i.e. + any of the forms acceptable to Tk_GetPixels); for text it is in + lines of text. If this option isn't specified, the button's + desired height is computed from the size of the bitmap or text + being displayed in it. + +':state' + Name='"state" Class="State"' + + Specifies one of three states for the button: normal, active, or + disabled. In normal state the button is displayed using the + foreground and background options. The active state is typically + used when the pointer is over the button. In active state the + button is displayed using the activeForeground and activeBackground + options. Disabled state means that the button is insensitive: it + doesn't activate and doesn't respond to mouse button presses. In + this state the disabledForeground and background options determine + how the button is displayed. + +':width' + Name='"width" Class="Width"' + + Specifies a desired width for the button. If a bitmap is being + displayed in the button then the value is in screen units (i.e. + any of the forms acceptable to Tk_GetPixels); for text it is in + characters. If this option isn't specified, the button's desired + width is computed from the size of the bitmap or text being + displayed in it. + +Description +----------- + +The button command creates a new window (given by the pathName argument) +and makes it into a button widget. Additional options, described above, +may be specified on the command line or in the option database to +configure aspects of the button such as its colors, font, text, and +initial relief. The button command returns its pathName argument. At +the time this command is invoked, there must not exist a window named +pathName, but pathName's parent must exist. + + A button is a widget that displays a textual string or bitmap. It +can display itself in either of three different ways, according to the +state option; it can be made to appear raised, sunken, or flat; and it +can be made to flash. When a user invokes the button (by pressing mouse +button 1 with the cursor over the button), then the Tcl command +specified in the :command option is invoked. + +A Button Widget's Arguments +--------------------------- + +The button command creates a new Tcl command whose name is pathName. +This command may be used to invoke various operations on the widget. It +has the following general form: + + pathName option ?arg arg ...? + + Option and the args determine the exact behavior of the command. The +following commands are possible for button widgets: + +pathName :activate + Change the button's state to active and redisplay the button using + its active foreground and background colors instead of normal + colors. This command is ignored if the button's state is disabled. + This command is obsolete and will eventually be removed; use + "pathName :configure :state active" instead. +pathName :configure ?option? ?value option value ...? + Query or modify the configuration options of the widget. If no + option is specified, returns a list describing all of the available + options for pathName (see Tk_ConfigureInfo for information on the + format of this list). If option is specified with no value, then + the command returns a list describing the one named option (this + list will be identical to the corresponding sublist of the value + returned if no option is specified). If one or more option:value + pairs are specified, then the command modifies the given widget + option(s) to have the given value(s); in this case the command + returns an empty string. Option may have any of the values + accepted by the button command. +pathName :deactivate + Change the button's state to normal and redisplay the button using + its normal foreground and background colors. This command is + ignored if the button's state is disabled. This command is + obsolete and will eventually be removed; use "pathName :configure + :state normal" instead. +pathName :flash + Flash the button. This is accomplished by redisplaying the button + several times, alternating between active and normal colors. At + the end of the flash the button is left in the same normal/active + state as when the command was invoked. This command is ignored if + the button's state is disabled. +pathName :invoke + Invoke the Tcl command associated with the button, if there is one. + The return value is the return value from the Tcl command, or an + empty string if there is no command associated with the button. + This command is ignored if the button's state is disabled. + +"Default Bindings" +------------------ + +Tk automatically creates class bindings for buttons that give them the +following default behavior: + [1] The button activates whenever the mouse passes over it and + deactivates whenever the mouse leaves the button. + [2] The button's relief is changed to sunken whenever mouse button + 1 is pressed over the button, and the relief is restored to its + original value when button 1 is later released. + [3] If mouse button 1 is pressed over the button and later released + over the button, the button is invoked. However, if the mouse is + not over the button when button 1 is released, then no invocation + occurs. + + If the button's state is disabled then none of the above actions +occur: the button is completely non-responsive. + + The behavior of buttons can be changed by defining new bindings for +individual widgets or by redefining the class bindings. + +Keywords +-------- + +button, widget + + +File: gcl-tk.info, Node: listbox, Next: scale, Prev: button, Up: Widgets + +2.2 listbox +=========== + +listbox \- Create and manipulate listbox widgets + +Synopsis +-------- + +listbox pathName ?options? + +Standard Options +---------------- + + background foreground selectBackground xScrollCommand + borderWidth font selectBorderWidth yScrollCommand + cursor geometry selectForeground + exportSelection relief setGrid + + *Note options::, for more information. + +Arguments for Listbox +--------------------- + +None. + +Description +----------- + +The listbox command creates a new window (given by the pathName +argument) and makes it into a listbox widget. Additional options, +described above, may be specified on the command line or in the option +database to configure aspects of the listbox such as its colors, font, +text, and relief. The listbox command returns its pathName argument. +At the time this command is invoked, there must not exist a window named +pathName, but pathName's parent must exist. + + A listbox is a widget that displays a list of strings, one per line. +When first created, a new listbox has no elements in its list. Elements +may be added or deleted using widget commands described below. In +addition, one or more elements may be selected as described below. If a +listbox is exporting its selection (see exportSelection option), then it +will observe the standard X11 protocols for handling the selection; +listbox selections are available as type STRING, consisting of a Tcl +list with one entry for each selected element. + + For large lists only a subset of the list elements will be displayed +in the listbox window at once; commands described below may be used to +change the view in the window. Listboxes allow scrolling in both +directions using the standard xScrollCommand and yScrollCommand options. +They also support scanning, as described below. + +A Listbox's Arguments +--------------------- + +The listbox command creates a new Tcl command whose name is pathName. +This command may be used to invoke various operations on the widget. It +has the following general form: + + pathName option ?arg arg ...? + + Option and the args determine the exact behavior of the command. The +following commands are possible for listbox widgets: + +pathName :configure ?option? ?value option value ...? + Query or modify the configuration options of the widget. If no + option is specified, returns a list describing all of the available + options for pathName (see Tk_ConfigureInfo for information on the + format of this list). If option is specified with no value, then + the command returns a list describing the one named option (this + list will be identical to the corresponding sublist of the value + returned if no option is specified). If one or more option:value + pairs are specified, then the command modifies the given widget + option(s) to have the given value(s); in this case the command + returns an empty string. Option may have any of the values + accepted by the listbox command. +pathName :curselection + Returns a list containing the indices of all of the elements in the + listbox that are currently selected. If there are no elements + selected in the listbox then an empty string is returned. +pathName :delete first ?last? + Delete one or more elements of the listbox. First and last give + the integer indices of the first and last elements in the range to + be deleted. If last isn't specified it defaults to first, i.e. a + single element is deleted. An index of 0 corresponds to the first + element in the listbox. Either first or last may be specified as + end, in which case it refers to the last element of the listbox. + This command returns an empty string +pathName :get index + Return the contents of the listbox element indicated by index. + Index must be a non-negative integer (0 corresponds to the first + element in the listbox), or it may also be specified as end to + indicate the last element in the listbox. +pathName :insert index ?element element ...? + Insert zero or more new elements in the list just before the + element given by index. If index is specified as end then the new + elements are added to the end of the list. Returns an empty + string. +pathName :nearest y + Given a y-coordinate within the listbox window, this command + returns the index of the (visible) listbox element nearest to that + y-coordinate. +pathName :scan option args + This command is used to implement scanning on listboxes. It has + two forms, depending on option: + pathName :scan :mark x y + Records x and y and the current view in the listbox window; + used in conjunction with later scan dragto commands. + Typically this command is associated with a mouse button press + in the widget. It returns an empty string. + pathName :scan :dragto x y. + This command computes the difference between its x and y + arguments and the x and y arguments to the last scan mark + command for the widget. It then adjusts the view by 10 times + the difference in coordinates. This command is typically + associated with mouse motion events in the widget, to produce + the effect of dragging the list at high speed through the + window. The return value is an empty string. +pathName :select option arg + This command is used to adjust the selection within a listbox. It + has several forms, depending on option. In all of the forms the + index end refers to the last element in the listbox. + pathName :select :adjust index + Locate the end of the selection nearest to the element given + by index, and adjust that end of the selection to be at index + (i.e including but not going beyond index). The other end of + the selection is made the anchor point for future select to + commands. If the selection isn't currently in the listbox, + then this command is identical to the select from widget + command. Returns an empty string. + pathName :select :clear + If the selection is in this listbox then it is cleared so that + none of the listbox's elements are selected anymore. + pathName :select :from index + Set the selection to consist of element index, and make index + the anchor point for future select to widget commands. + Returns an empty string. + pathName :select :to index + Set the selection to consist of the elements from the anchor + point to element index, inclusive. The anchor point is + determined by the most recent select from or select adjust + command in this widget. If the selection isn't in this + widget, this command is identical to select from. Returns an + empty string. + +pathName :size + Returns a decimal string indicating the total number of elements in + the listbox. +pathName :xview index + Adjust the view in the listbox so that character position index is + displayed at the left edge of the widget. Returns an empty string. +pathName :yview index + Adjust the view in the listbox so that element index is displayed + at the top of the widget. If index is specified as end it + indicates the last element of the listbox. Returns an empty + string. + +"Default Bindings" +------------------ + +Tk automatically creates class bindings for listboxes that give them the +following default behavior: + [1] When button 1 is pressed over a listbox, the element underneath + the mouse cursor is selected. The mouse can be dragged to select a + range of elements. + [2] The ends of the selection can be adjusted by dragging with + mouse button 1 while the shift key is down; this will adjust the + end of the selection that was nearest to the mouse cursor when + button 1 was pressed. + [3] The view in the listbox can be adjusted by dragging with mouse + button 2. + + The behavior of listboxes can be changed by defining new bindings for +individual widgets or by redefining the class bindings. In addition, +the procedure tk_listboxSingleSelect may be invoked to change listbox +behavior so that only a single element may be selected at once. + +Keywords +-------- + +listbox, widget + + +File: gcl-tk.info, Node: scale, Next: canvas, Prev: listbox, Up: Widgets + +2.3 scale +========= + +scale \- Create and manipulate scale widgets + +Synopsis +-------- + +scale pathName ?options? + +Standard Options +---------------- + + activeForeground borderWidth font orient + background cursor foreground relief + + *Note options::, for more information. + +Arguments for Scale +------------------- + +':command' + Name='"command" Class="Command"' + + Specifies the prefix of a Tcl command to invoke whenever the value + of the scale is changed interactively. The actual command consists + of this option followed by a space and a number. The number + indicates the new value of the scale. + +':from' + Name='"from" Class="From"' + + Specifies the value corresponding to the left or top end of the + scale. Must be an integer. + +':label' + Name='"label" Class="Label"' + + Specifies a string to displayed as a label for the scale. For + vertical scales the label is displayed just to the right of the top + end of the scale. For horizontal scales the label is displayed + just above the left end of the scale. + +':length' + Name='"length" Class="Length"' + + Specifies the desired long dimension of the scale in screen units, + that is in any of the forms acceptable to Tk_GetPixels. For + vertical scales this is the scale's height; for horizontal scales + it is the scale's width. + +':showvalue' + Name='"showValue" Class="ShowValue"' + + Specifies a boolean value indicating whether or not the current + value of the scale is to be displayed. + +':sliderforeground' + Name='"sliderForeground" Class="sliderForeground"' + + Specifies the color to use for drawing the slider under normal + conditions. When the mouse is in the slider window then the + slider's color is determined by the activeForeground option. + +':sliderlength' + Name='"sliderLength" Class="SliderLength"' + + Specfies the size of the slider, measured in screen units along the + slider's long dimension. The value may be specified in any of the + forms acceptable to Tk_GetPixels. + +':state' + Name='"state" Class="State"' + + Specifies one of two states for the scale: normal or disabled. If + the scale is disabled then the value may not be changed and the + scale won't activate when the mouse enters it. + +':tickinterval' + Name='"tickInterval" Class="TickInterval"' + + Must be an integer value. Determines the spacing between numerical + tick-marks displayed below or to the left of the slider. If + specified as 0, then no tick-marks will be displayed. + +':to' + Name='"to" Class="To"' + + Specifies the value corresponding to the right or bottom end of the + scale. Must be an integer. This value may be either less than or + greater than the from option. + +':width' + Name='"width" Class="Width"' + + Specifies the desired narrow dimension of the scale in screen units + (i.e. any of the forms acceptable to Tk_GetPixels). For vertical + scales this is the scale's width; for horizontal scales this is the + scale's height. + +Description +----------- + +The scale command creates a new window (given by the pathName argument) +and makes it into a scale widget. Additional options, described above, +may be specified on the command line or in the option database to +configure aspects of the scale such as its colors, orientation, and +relief. The scale command returns its pathName argument. At the time +this command is invoked, there must not exist a window named pathName, +but pathName's parent must exist. + + A scale is a widget that displays a rectangular region and a small +slider. The rectangular region corresponds to a range of integer values +(determined by the from and to options), and the position of the slider +selects a particular integer value. The slider's position (and hence +the scale's value) may be adjusted by clicking or dragging with the +mouse as described in the BINDINGS section below. Whenever the scale's +value is changed, a Tcl command is invoked (using the command option) to +notify other interested widgets of the change. + + Three annotations may be displayed in a scale widget: a label +appearing at the top-left of the widget (top-right for vertical scales), +a number displayed just underneath the slider (just to the left of the +slider for vertical scales), and a collection of numerical tick-marks +just underneath the current value (just to the left of the current value +for vertical scales). Each of these three annotations may be +selectively enabled or disabled using the configuration options. + +A Scale's"Argumentsommand" +-------------------------- + +The scale command creates a new Tcl command whose name is pathName. +This command may be used to invoke various operations on the widget. It +has the following general form: + + pathName option ?arg arg ...? + + Option and the args determine the exact behavior of the command. The +following commands are possible for scale widgets: + +pathName :configure ?option? ?value option value ...? + Query or modify the configuration options of the widget. If no + option is specified, returns a list describing all of the available + options for pathName (see Tk_ConfigureInfo for information on the + format of this list). If option is specified with no value, then + the command returns a list describing the one named option (this + list will be identical to the corresponding sublist of the value + returned if no option is specified). If one or more option:value + pairs are specified, then the command modifies the given widget + option(s) to have the given value(s); in this case the command + returns an empty string. Option may have any of the values + accepted by the scale command. +pathName :get + Returns a decimal string giving the current value of the scale. +pathName :set value + This command is invoked to change the current value of the scale, + and hence the position at which the slider is displayed. Value + gives the new value for the scale. + +Bindings +-------- + +When a new scale is created, it is given the following initial behavior +by default: + + + Change the slider display to use activeForeground instead of + sliderForeground. + + Reset the slider display to use sliderForeground instead of + activeForeground. + + Change the slider display so that the slider appears sunken rather + than raised. Move the slider (and adjust the scale's value) to + correspond to the current mouse position. + + Move the slider (and adjust the scale's value) to correspond to the + current mouse position. + + Reset the slider display so that the slider appears raised again. + +Keywords +-------- + +scale, widget + + +File: gcl-tk.info, Node: canvas, Next: menu, Prev: scale, Up: Widgets + +2.4 canvas +========== + +canvas \- Create and manipulate canvas widgets + +Synopsis +-------- + +canvas pathName ?options? + +Standard Options +---------------- + + background insertBorderWidth relief xScrollCommand + borderWidth insertOffTime selectBackground yScrollCommand + cursor insertOnTime selectBorderWidth + insertBackground insertWidth selectForeground + + *Note options::, for more information. + +Arguments for Canvas +-------------------- + +':closeenough' + Name='"closeEnough" Class="CloseEnough"' + + Specifies a floating-point value indicating how close the mouse + cursor must be to an item before it is considered to be "inside" + the item. Defaults to 1.0. + +':confine' + Name='"confine" Class="Confine"' + + Specifies a boolean value that indicates whether or not it should + be allowable to set the canvas's view outside the region defined by + the scrollRegion argument. Defaults to true, which means that the + view will be constrained within the scroll region. + +':height' + Name='"height" Class="Height"' + + Specifies a desired window height that the canvas widget should + request from its geometry manager. The value may be specified in + any of the forms described in the COORDINATES section below. + +':scrollincrement' + Name='"scrollIncrement" Class="ScrollIncrement"' + + Specifies a distance used as increment during scrolling: when one + of the arrow buttons on an associated scrollbar is pressed, the + picture will shift by this distance. The distance may be specified + in any of the forms described in the COORDINATES section below. + +':scrollregion' + Name='"scrollRegion" Class="ScrollRegion"' + + Specifies a list with four coordinates describing the left, top, + right, and bottom coordinates of a rectangular region. This region + is used for scrolling purposes and is considered to be the boundary + of the information in the canvas. Each of the coordinates may be + specified in any of the forms given in the COORDINATES section + below. + +':width' + Name='"width" Class="width"' + + Specifies a desired window width that the canvas widget should + request from its geometry manager. The value may be specified in + any of the forms described in the COORDINATES section below. + +Introduction +------------ + +The canvas command creates a new window (given by the pathName argument) +and makes it into a canvas widget. Additional options, described above, +may be specified on the command line or in the option database to +configure aspects of the canvas such as its colors and 3-D relief. The +canvas command returns its pathName argument. At the time this command +is invoked, there must not exist a window named pathName, but pathName's +parent must exist. + + Canvas widgets implement structured graphics. A canvas displays any +number of items, which may be things like rectangles, circles, lines, +and text. Items may be manipulated (e.g. moved or re-colored) and +commands may be associated with items in much the same way that the bind +command allows commands to be bound to widgets. For example, a +particular command may be associated with the event so that +the command is invoked whenever button 1 is pressed with the mouse +cursor over an item. This means that items in a canvas can have +behaviors defined by the Tcl scripts bound to them. + +Display List +------------ + +The items in a canvas are ordered for purposes of display, with the +first item in the display list being displayed first, followed by the +next item in the list, and so on. Items later in the display list +obscure those that are earlier in the display list and are sometimes +referred to as being "on top" of earlier items. When a new item is +created it is placed at the end of the display list, on top of +everything else. Widget commands may be used to re-arrange the order of +the display list. + +Item Ids And Tags +----------------- + +Items in a canvas widget may be named in either of two ways: by id or by +tag. Each item has a unique identifying number which is assigned to +that item when it is created. The id of an item never changes and id +numbers are never re-used within the lifetime of a canvas widget. + + Each item may also have any number of tags associated with it. A tag +is just a string of characters, and it may take any form except that of +an integer. For example, "x123" is OK but "123" isn't. The same tag +may be associated with many different items. This is commonly done to +group items in various interesting ways; for example, all selected items +might be given the tag "selected". + + The tag all is implicitly associated with every item in the canvas; +it may be used to invoke operations on all the items in the canvas. + + The tag current is managed automatically by Tk; it applies to the +current item, which is the topmost item whose drawn area covers the +position of the mouse cursor. If the mouse is not in the canvas widget +or is not over an item, then no item has the current tag. + + When specifying items in canvas widget commands, if the specifier is +an integer then it is assumed to refer to the single item with that id. +If the specifier is not an integer, then it is assumed to refer to all +of the items in the canvas that have a tag matching the specifier. The +symbol tagOrId is used below to indicate that an argument specifies +either an id that selects a single item or a tag that selects zero or +more items. Some widget commands only operate on a single item at a +time; if tagOrId is specified in a way that names multiple items, then +the normal behavior is for the command to use the first (lowest) of +these items in the display list that is suitable for the command. +Exceptions are noted in the widget command descriptions below. + +Coordinates +----------- + +All coordinates related to canvases are stored as floating-point +numbers. Coordinates and distances are specified in screen units, which +are floating-point numbers optionally followed by one of several +letters. If no letter is supplied then the distance is in pixels. If +the letter is m then the distance is in millimeters on the screen; if it +is c then the distance is in centimeters; i means inches, and p means +printers points (1/72 inch). Larger y-coordinates refer to points lower +on the screen; larger x-coordinates refer to points farther to the +right. + +Transformations +--------------- + +Normally the origin of the canvas coordinate system is at the upper-left +corner of the window containing the canvas. It is possible to adjust +the origin of the canvas coordinate system relative to the origin of the +window using the xview and yview widget commands; this is typically used +for scrolling. Canvases do not support scaling or rotation of the +canvas coordinate system relative to the window coordinate system. + + Indidividual items may be moved or scaled using widget commands +described below, but they may not be rotated. + +Indices +------- + +Text items support the notion of an index for identifying particular +positions within the item. Indices are used for commands such as +inserting text, deleting a range of characters, and setting the +insertion cursor position. An index may be specified in any of a number +of ways, and different types of items may support different forms for +specifying indices. Text items support the following forms for an +index; if you define new types of text-like items, it would be advisable +to support as many of these forms as practical. Note that it is +possible to refer to the character just after the last one in the text +item; this is necessary for such tasks as inserting new text at the end +of the item. + +number + A decimal number giving the position of the desired character + within the text item. 0 refers to the first character, 1 to the + next character, and so on. A number less than 0 is treated as if + it were zero, and a number greater than the length of the text item + is treated as if it were equal to the length of the text item. +end + Refers to the character just after the last one in the item (same + as the number of characters in the item). +insert + Refers to the character just before which the insertion cursor is + drawn in this item. +sel.first + Refers to the first selected character in the item. If the + selection isn't in this item then this form is illegal. +sel.last + Refers to the last selected character in the item. If the + selection isn't in this item then this form is illegal. +@x,y + Refers to the character at the point given by x and y, where x and + y are specified in the coordinate system of the canvas. If x and y + lie outside the coordinates covered by the text item, then they + refer to the first or last character in the line that is closest to + the given point. + +A Canvas Widget's Arguments +--------------------------- + +The canvas command creates a new Tcl command whose name is pathName. +This command may be used to invoke various operations on the widget. It +has the following general form: + + pathName option ?arg arg ...? + + Option and the args determine the exact behavior of the command. The +following widget commands are possible for canvas widgets: + +pathName :addtag tag searchSpec ?arg arg ...? + For each item that meets the constraints specified by searchSpec + and the args, add tag to the list of tags associated with the item + if it isn't already present on that list. It is possible that no + items will satisfy the constraints given by searchSpec and args, in + which case the command has no effect. This command returns an + empty string as result. SearchSpec and arg's may take any of the + following forms: + + above tagOrId + Selects the item just after (above) the one given by tagOrId + in the display list. If tagOrId denotes more than one item, + then the last (topmost) of these items in the display list is + used. + all + Selects all the items in the canvas. + below tagOrId + Selects the item just before (below) the one given by tagOrId + in the display list. If tagOrId denotes more than one item, + then the first (lowest) of these items in the display list is + used. + closest x y ?halo? ?start? + Selects the item closest to the point given by x and y. If + more than one item is at the same closest distance (e.g. two + items overlap the point), then the top-most of these items + (the last one in the display list) is used. If halo is + specified, then it must be a non-negative value. Any item + closer than halo to the point is considered to overlap it. + The start argument may be used to step circularly through all + the closest items. If start is specified, it names an item + using a tag or id (if by tag, it selects the first item in the + display list with the given tag). Instead of selecting the + topmost closest item, this form will select the topmost + closest item that is below start in the display list; if no + such item exists, then the selection behaves as if the start + argument had not been specified. + enclosed x1 y1 x2 y2 + Selects all the items completely enclosed within the + rectangular region given by x1, y1, x2, and y2. X1 must be no + greater then x2 and y1 must be no greater than y2. + overlapping x1 y1 x2 y2 + Selects all the items that overlap or are enclosed within the + rectangular region given by x1, y1, x2, and y2. X1 must be no + greater then x2 and y1 must be no greater than y2. + withtag tagOrId + Selects all the items given by tagOrId. + +pathName :bbox tagOrId ?tagOrId tagOrId ...? + Returns a list with four elements giving an approximate bounding + box for all the items named by the tagOrId arguments. The list has + the form "x1 y1 x2 y2" such that the drawn areas of all the named + elements are within the region bounded by x1 on the left, x2 on the + right, y1 on the top, and y2 on the bottom. The return value may + overestimate the actual bounding box by a few pixels. If no items + match any of the tagOrId arguments then an empty string is + returned. +pathName :bind tagOrId ?sequence? ?command? + This command associates command with all the items given by tagOrId + such that whenever the event sequence given by sequence occurs for + one of the items the command will be invoked. This widget command + is similar to the bind command except that it operates on items in + a canvas rather than entire widgets. See the bind manual entry for + complete details on the syntax of sequence and the substitutions + performed on command before invoking it. If all arguments are + specified then a new binding is created, replacing any existing + binding for the same sequence and tagOrId (if the first character + of command is "+" then command augments an existing binding rather + than replacing it). In this case the return value is an empty + string. If command is omitted then the command returns the command + associated with tagOrId and sequence (an error occurs if there is + no such binding). If both command and sequence are omitted then + the command returns a list of all the sequences for which bindings + have been defined for tagOrId. + + The only events for which bindings may be specified are those related +to the mouse and keyboard, such as Enter, Leave, ButtonPress, Motion, +and KeyPress. The handling of events in canvases uses the current item +defined in ITEM IDS AND TAGS above. Enter and Leave events trigger for +an item when it becomes the current item or ceases to be the current +item; note that these events are different than Enter and Leave events +for windows. Mouse-related events are directed to the current item, if +any. Keyboard-related events are directed to the focus item, if any +(see the focus widget command below for more on this). + + It is possible for multiple commands to be bound to a single event +sequence for a single object. This occurs, for example, if one command +is associated with the item's id and another is associated with one of +the item's tags. When this occurs, the first matching binding is used. +A binding for the item's id has highest priority, followed by the oldest +tag for the item and proceeding through all of the item's tags up +through the most-recently-added one. If a binding is associated with +the tag all, the binding will have lower priority than all other +bindings associated with the item. + +pathName :canvasx screenx ?gridspacing? + Given a screen x-coordinate screenx this command returns the canvas + x-coordinate that is displayed at that location. If gridspacing is + specified, then the canvas coordinate is rounded to the nearest + multiple of gridspacing units. +pathName :canvasy screeny ?gridspacing? + Given a screen y-coordinate screeny this command returns the canvas + y-coordinate that is displayed at that location. If gridspacing is + specified, then the canvas coordinate is rounded to the nearest + multiple of gridspacing units. +pathName :configure ?option? ?value? ?option value ...? + Query or modify the configuration options of the widget. If no + option is specified, returns a list describing all of the available + options for pathName (see Tk_ConfigureInfo for information on the + format of this list). If option is specified with no value, then + the command returns a list describing the one named option (this + list will be identical to the corresponding sublist of the value + returned if no option is specified). If one or more option:value + pairs are specified, then the command modifies the given widget + option(s) to have the given value(s); in this case the command + returns an empty string. Option may have any of the values + accepted by the canvas command. +pathName :coords tagOrId ?x0 y0 ...? + Query or modify the coordinates that define an item. If no + coordinates are specified, this command returns a list whose + elements are the coordinates of the item named by tagOrId. If + coordinates are specified, then they replace the current + coordinates for the named item. If tagOrId refers to multiple + items, then the first one in the display list is used. +pathName :create type x y ?x y ...? ?option value ...? + Create a new item in pathName of type type. The exact format of + the arguments after type depends on type, but usually they consist + of the coordinates for one or more points, followed by + specifications for zero or more item options. See the subsections + on individual item types below for more on the syntax of this + command. This command returns the id for the new item. +pathName :dchars tagOrId first ?last? + For each item given by tagOrId, delete the characters in the range + given by first and last, inclusive. If some of the items given by + tagOrId don't support text operations, then they are ignored. + First and last are indices of characters within the item(s) as + described in INDICES above. If last is omitted, it defaults to + first. This command returns an empty string. +pathName :delete ?tagOrId tagOrId ...? + Delete each of the items given by each tagOrId, and return an empty + string. +pathName :dtag tagOrId ?tagToDelete? + For each of the items given by tagOrId, delete the tag given by + tagToDelete from the list of those associated with the item. If an + item doesn't have the tag tagToDelete then the item is unaffected + by the command. If tagToDelete is omitted then it defaults to + tagOrId. This command returns an empty string. +pathName :find searchCommand ?arg arg ...? + This command returns a list consisting of all the items that meet + the constraints specified by searchCommand and arg's. + SearchCommand and args have any of the forms accepted by the addtag + command. +pathName :focus ?tagOrId? + Set the keyboard focus for the canvas widget to the item given by + tagOrId. If tagOrId refers to several items, then the focus is set + to the first such item in the display list that supports the + insertion cursor. If tagOrId doesn't refer to any items, or if + none of them support the insertion cursor, then the focus isn't + changed. If tagOrId is an empty string, then the focus item is + reset so that no item has the focus. If tagOrId is not specified + then the command returns the id for the item that currently has the + focus, or an empty string if no item has the focus. + + Once the focus has been set to an item, the item will display the +insertion cursor and all keyboard events will be directed to that item. +The focus item within a canvas and the focus window on the screen (set +with the focus command) are totally independent: a given item doesn't +actually have the input focus unless (a) its canvas is the focus window +and (b) the item is the focus item within the canvas. In most cases it +is advisable to follow the focus widget command with the focus command +to set the focus window to the canvas (if it wasn't there already). + +pathName :gettags tagOrId + Return a list whose elements are the tags associated with the item + given by tagOrId. If tagOrId refers to more than one item, then + the tags are returned from the first such item in the display list. + If tagOrId doesn't refer to any items, or if the item contains no + tags, then an empty string is returned. +pathName :icursor tagOrId index + Set the position of the insertion cursor for the item(s) given by + tagOrId to just before the character whose position is given by + index. If some or all of the items given by tagOrId don't support + an insertion cursor then this command has no effect on them. See + INDICES above for a description of the legal forms for index. + Note: the insertion cursor is only displayed in an item if that + item currently has the keyboard focus (see the widget command + focus, below), but the cursor position may be set even when the + item doesn't have the focus. This command returns an empty string. +pathName :index tagOrId index + This command returns a decimal string giving the numerical index + within tagOrId corresponding to index. Index gives a textual + description of the desired position as described in INDICES above. + The return value is guaranteed to lie between 0 and the number of + characters within the item, inclusive. If tagOrId refers to + multiple items, then the index is processed in the first of these + items that supports indexing operations (in display list order). +pathName :insert tagOrId beforeThis string + For each of the items given by tagOrId, if the item supports text + insertion then string is inserted into the item's text just before + the character whose index is beforeThis. See INDICES above for + information about the forms allowed for beforeThis. This command + returns an empty string. +pathName :itemconfigure tagOrId ?option? ?value? ?option value ...? + This command is similar to the configure widget command except that + it modifies item-specific options for the items given by tagOrId + instead of modifying options for the overall canvas widget. If no + option is specified, returns a list describing all of the available + options for the first item given by tagOrId (see Tk_ConfigureInfo + for information on the format of this list). If option is + specified with no value, then the command returns a list describing + the one named option (this list will be identical to the + corresponding sublist of the value returned if no option is + specified). If one or more option:value pairs are specified, then + the command modifies the given widget option(s) to have the given + value(s) in each of the items given by tagOrId; in this case the + command returns an empty string. The options and values are the + same as those permissible in the create widget command when the + item(s) were created; see the sections describing individual item + types below for details on the legal options. +pathName :lower tagOrId ?belowThis? + Move all of the items given by tagOrId to a new position in the + display list just before the item given by belowThis. If tagOrId + refers to more than one item then all are moved but the relative + order of the moved items will not be changed. BelowThis is a tag + or id; if it refers to more than one item then the first (lowest) + of these items in the display list is used as the destination + location for the moved items. This command returns an empty + string. +pathName :move tagOrId xAmount yAmount + Move each of the items given by tagOrId in the canvas coordinate + space by adding xAmount to the x-coordinate of each point + associated with the item and yAmount to the y-coordinate of each + point associated with the item. This command returns an empty + string. +pathName :postscript ?option value option value ...? + Generate a Postscript representation for part or all of the canvas. + If the :file option is specified then the Postscript is written to + a file and an empty string is returned; otherwise the Postscript is + returned as the result of the command. The Postscript is created + in Encapsulated Postscript form using version 3.0 of the Document + Structuring Conventions. The option\-value argument pairs provide + additional information to control the generation of Postscript. + The following options are supported: + + :colormap varName + VarName must be the name of a global array variable that + specifies a color mapping to use in the Postscript. Each + element of varName must consist of Postscript code to set a + particular color value (e.g. "1.0 1.0 0.0 setrgbcolor"). + When outputting color information in the Postscript, Tk checks + to see if there is an element of varName with the same name as + the color. If so, Tk uses the value of the element as the + Postscript command to set the color. If this option hasn't + been specified, or if there isn't an entry in varName for a + given color, then Tk uses the red, green, and blue intensities + from the X color. + :colormode mode + Specifies how to output color information. Mode must be + either color (for full color output), gray (convert all colors + to their gray-scale equivalents) or mono (convert all colors + to black or white). + :file fileName + Specifies the name of the file in which to write the + Postscript. If this option isn't specified then the + Postscript is returned as the result of the command instead of + being written to a file. + :fontmap varName + VarName must be the name of a global array variable that + specifies a font mapping to use in the Postscript. Each + element of varName must consist of a Tcl list with two + elements, which are the name and point size of a Postscript + font. When outputting Postscript commands for a particular + font, Tk checks to see if varName contains an element with the + same name as the font. If there is such an element, then the + font information contained in that element is used in the + Postscript. Otherwise Tk attempts to guess what Postscript + font to use. Tk's guesses generally only work for well-known + fonts such as Times and Helvetica and Courier, and only if the + X font name does not omit any dashes up through the point + size. For example, + \fB\-*\-Courier\-Bold\-R\-Normal\-\-*\-120\-* will work but + \fB*Courier\-Bold\-R\-Normal*120* will not; Tk needs the + dashes to parse the font name). + :height size + Specifies the height of the area of the canvas to print. + Defaults to the height of the canvas window. + :pageanchor anchor + Specifies which point of the printed area should be appear + over the positioning point on the page (which is given by the + :pagex and :pagey options). For example, :pageanchor n means + that the top center of the printed area should be over the + positioning point. Defaults to center. + :pageheight size + Specifies that the Postscript should be scaled in both x and y + so that the printed area is size high on the Postscript page. + Size consists of a floating-point number followed by c for + centimeters, i for inches, m for millimeters, or p or nothing + for printer's points (1/72 inch). Defaults to the height of + the printed area on the screen. If both :pageheight and + :pagewidth are specified then the scale factor from the later + option is used (non-uniform scaling is not implemented). + :pagewidth size + Specifies that the Postscript should be scaled in both x and y + so that the printed area is size wide on the Postscript page. + Size has the same form as for :pageheight. Defaults to the + width of the printed area on the screen. If both :pageheight + and :pagewidth are specified then the scale factor from the + later option is used (non-uniform scaling is not implemented). + :pagex position + Position gives the x-coordinate of the positioning point on + the Postscript page, using any of the forms allowed for + :pageheight. Used in conjunction with the :pagey and + :pageanchor options to determine where the printed area + appears on the Postscript page. Defaults to the center of the + page. + :pagey position + Position gives the y-coordinate of the positioning point on + the Postscript page, using any of the forms allowed for + :pageheight. Used in conjunction with the :pagex and + :pageanchor options to determine where the printed area + appears on the Postscript page. Defaults to the center of the + page. + :rotate boolean + Boolean specifies whether the printed area is to be rotated 90 + degrees. In non-rotated output the x-axis of the printed area + runs along the short dimension of the page ("portrait" + orientation); in rotated output the x-axis runs along the long + dimension of the page ("landscape" orientation). Defaults to + non-rotated. + :width size + Specifies the width of the area of the canvas to print. + Defaults to the width of the canvas window. + :x position + Specifies the x-coordinate of the left edge of the area of the + canvas that is to be printed, in canvas coordinates, not + window coordinates. Defaults to the coordinate of the left + edge of the window. + :y position + Specifies the y-coordinate of the top edge of the area of the + canvas that is to be printed, in canvas coordinates, not + window coordinates. Defaults to the coordinate of the top + edge of the window. + +pathName :raise tagOrId ?aboveThis? + Move all of the items given by tagOrId to a new position in the + display list just after the item given by aboveThis. If tagOrId + refers to more than one item then all are moved but the relative + order of the moved items will not be changed. AboveThis is a tag + or id; if it refers to more than one item then the last (topmost) + of these items in the display list is used as the destination + location for the moved items. This command returns an empty + string. +pathName :scale tagOrId xOrigin yOrigin xScale yScale + Rescale all of the items given by tagOrId in canvas coordinate + space. XOrigin and yOrigin identify the origin for the scaling + operation and xScale and yScale identify the scale factors for x- + and y-coordinates, respectively (a scale factor of 1.0 implies no + change to that coordinate). For each of the points defining each + item, the x-coordinate is adjusted to change the distance from + xOrigin by a factor of xScale. Similarly, each y-coordinate is + adjusted to change the distance from yOrigin by a factor of yScale. + This command returns an empty string. +pathName :scan option args + This command is used to implement scanning on canvases. It has two + forms, depending on option: + + pathName :scan :mark x y + Records x and y and the canvas's current view; used in + conjunction with later scan dragto commands. Typically this + command is associated with a mouse button press in the widget + and x and y are the coordinates of the mouse. It returns an + empty string. + pathName :scan :dragto x y. + This command computes the difference between its x and y + arguments (which are typically mouse coordinates) and the x + and y arguments to the last scan mark command for the widget. + It then adjusts the view by 10 times the difference in + coordinates. This command is typically associated with mouse + motion events in the widget, to produce the effect of dragging + the canvas at high speed through its window. The return value + is an empty string. + +pathName :select option ?tagOrId arg? + Manipulates the selection in one of several ways, depending on + option. The command may take any of the forms described below. In + all of the descriptions below, tagOrId must refer to an item that + supports indexing and selection; if it refers to multiple items + then the first of these that supports indexing and the selection is + used. Index gives a textual description of a position within + tagOrId, as described in INDICES above. + + pathName :select :adjust tagOrId index + Locate the end of the selection in tagOrId nearest to the + character given by index, and adjust that end of the selection + to be at index (i.e. including but not going beyond index). + The other end of the selection is made the anchor point for + future select to commands. If the selection isn't currently + in tagOrId then this command behaves the same as the select to + widget command. Returns an empty string. + pathName :select :clear + Clear the selection if it is in this widget. If the selection + isn't in this widget then the command has no effect. Returns + an empty string. + pathName :select :from tagOrId index + Set the selection anchor point for the widget to be just + before the character given by index in the item given by + tagOrId. This command doesn't change the selection; it just + sets the fixed end of the selection for future select to + commands. Returns an empty string. + pathName :select :item + Returns the id of the selected item, if the selection is in an + item in this canvas. If the selection is not in this canvas + then an empty string is returned. + pathName :select :to tagOrId index + Set the selection to consist of those characters of tagOrId + between the selection anchor point and index. The new + selection will include the character given by index; it will + include the character given by the anchor point only if index + is greater than or equal to the anchor point. The anchor + point is determined by the most recent select adjust or select + from command for this widget. If the selection anchor point + for the widget isn't currently in tagOrId, then it is set to + the same character given by index. Returns an empty string. + +pathName :type tagOrId + Returns the type of the item given by tagOrId, such as rectangle or + text. If tagOrId refers to more than one item, then the type of + the first item in the display list is returned. If tagOrId doesn't + refer to any items at all then an empty string is returned. +pathName :xview index + Change the view in the canvas so that the canvas position given by + index appears at the left edge of the window. This command is + typically used by scrollbars to scroll the canvas. Index counts in + units of scroll increments (the value of the scrollIncrement + option): a value of 0 corresponds to the left edge of the scroll + region (as defined by the scrollRegion option), a value of 1 means + one scroll unit to the right of this, and so on. The return value + is an empty string. +pathName :yview index + Change the view in the canvas so that the canvas position given by + index appears at the top edge of the window. This command is + typically used by scrollbars to scroll the canvas. Index counts in + units of scroll increments (the value of the scrollIncrement + option): a value of 0 corresponds to the top edge of the scroll + region (as defined by the scrollRegion option), a value of 1 means + one scroll unit below this, and so on. The return value is an + empty string. + +Overview Of Item Types +---------------------- + +The sections below describe the various types of items supported by +canvas widgets. Each item type is characterized by two things: first, +the form of the create command used to create instances of the type; and +second, a set of configuration options for items of that type, which may +be used in the create and itemconfigure widget commands. Most items +don't support indexing or selection or the commands related to them, +such as index and insert. Where items do support these facilities, it +is noted explicitly in the descriptions below (at present, only text +items provide this support). + +Arc Items +--------- + +Items of type arc appear on the display as arc-shaped regions. An arc +is a section of an oval delimited by two angles (specified by the :start +and :extent options) and displayed in one of several ways (specified by +the :style option). Arcs are created with widget commands of the +following form: + +pathName :create arc x1 y1 x2 y2 ?option value option value ...? + The arguments x1, y1, x2, and y2 give the coordinates of two + diagonally opposite corners of a rectangular region enclosing the + oval that defines the arc. After the coordinates there may be any + number of option-value pairs, each of which sets one of the + configuration options for the item. These same option\-value pairs + may be used in itemconfigure widget commands to change the item's + configuration. The following options are supported for arcs: + + :extent degrees + Specifies the size of the angular range occupied by the arc. + The arc's range extends for degrees degrees counter-clockwise + from the starting angle given by the :start option. Degrees + may be negative. + :fill color + Fill the region of the arc with color. Color may have any of + the forms accepted by Tk_GetColor. If color is an empty + string (the default), then then the arc will not be filled. + :outline color + Color specifies a color to use for drawing the arc's outline; + it may have any of the forms accepted by Tk_GetColor. This + option defaults to black. If the arc's style is arc then this + option is ignored (the section of perimeter is filled using + the :fill option). If color is specified as an empty string + then no outline is drawn for the arc. + :start degrees + Specifies the beginning of the angular range occupied by the + arc. Degrees is given in units of degrees measured + counter-clockwise from the 3-o'clock position; it may be + either positive or negative. + :stipple bitmap + Indicates that the arc should be filled in a stipple pattern; + bitmap specifies the stipple pattern to use, in any of the + forms accepted by Tk_GetBitmap. If the :fill option hasn't + been specified then this option has no effect. If bitmap is + an empty string (the default), then filling is done in a solid + fashion. + :style type + Specifies how to draw the arc. If type is pieslice (the + default) then the arc's region is defined by a section of the + oval's perimeter plus two line segments, one between the + center of the oval and each end of the perimeter section. If + type is chord then the arc's region is defined by a section of + the oval's perimeter plus a single line segment connecting the + two end points of the perimeter section. If type is arc then + the arc's region consists of a section of the perimeter alone. + In this last case there is no outline for the arc and the + :outline option is ignored. + :tags tagList + Specifies a set of tags to apply to the item. TagList + consists of a list of tag names, which replace any existing + tags for the item. TagList may be an empty list. + :width outlineWidth + Specifies the width of the outline to be drawn around the + arc's region, in any of the forms described in the COORDINATES + section above. If the :outline option has been specified as + an empty string then this option has no effect. Wide outlines + will be drawn centered on the edges of the arc's region. This + option defaults to 1.0. + +Bitmap Items +------------ + +Items of type bitmap appear on the display as images with two colors, +foreground and background. Bitmaps are created with widget commands of +the following form: + +pathName :create bitmap x y ?option value option value ...? + The arguments x and y specify the coordinates of a point used to + position the bitmap on the display (see the :anchor option below + for more information on how bitmaps are displayed). After the + coordinates there may be any number of option-value pairs, each of + which sets one of the configuration options for the item. These + same option\-value pairs may be used in itemconfigure widget + commands to change the item's configuration. The following options + are supported for bitmaps: + + :anchor anchorPos + AnchorPos tells how to position the bitmap relative to the + positioning point for the item; it may have any of the forms + accepted by Tk_GetAnchor. For example, if anchorPos is center + then the bitmap is centered on the point; if anchorPos is n + then the bitmap will be drawn so that its top center point is + at the positioning point. This option defaults to center. + :background color + Specifies a color to use for each of the bitmap pixels whose + value is 0. Color may have any of the forms accepted by + Tk_GetColor. If this option isn't specified, or if it is + specified as an empty string, then the background color for + the canvas is used. + :bitmap bitmap + Specifies the bitmap to display in the item. Bitmap may have + any of the forms accepted by Tk_GetBitmap. + :foreground color + Specifies a color to use for each of the bitmap pixels whose + value is 1. Color may have any of the forms accepted by + Tk_GetColor and defaults to black. + :tags tagList + Specifies a set of tags to apply to the item. TagList + consists of a list of tag names, which replace any existing + tags for the item. TagList may be an empty list. + +Line Items +---------- + +Items of type line appear on the display as one or more connected line +segments or curves. Lines are created with widget commands of the +following form: + +pathName :create line x1 y1... xn yn ?option value option value ...? + + The arguments x1 through yn give the coordinates for a series of + two or more points that describe a series of connected line + segments. After the coordinates there may be any number of + option-value pairs, each of which sets one of the configuration + options for the item. These same option\-value pairs may be used + in itemconfigure widget commands to change the item's + configuration. The following options are supported for lines: + + :arrow where + Indicates whether or not arrowheads are to be drawn at one or + both ends of the line. Where must have one of the values none + (for no arrowheads), first (for an arrowhead at the first + point of the line), last (for an arrowhead at the last point + of the line), or both (for arrowheads at both ends). This + option defaults to none. + :arrowshape shape + This option indicates how to draw arrowheads. The shape + argument must be a list with three elements, each specifying a + distance in any of the forms described in the COORDINATES + section above. The first element of the list gives the + distance along the line from the neck of the arrowhead to its + tip. The second element gives the distance along the line + from the trailing points of the arrowhead to the tip, and the + third element gives the distance from the outside edge of the + line to the trailing points. If this option isn't specified + then Tk picks a "reasonable" shape. + :capstyle style + Specifies the ways in which caps are to be drawn at the + endpoints of the line. Style may have any of the forms + accepted by Tk_GetCapStyle (butt, projecting, or round). If + this option isn't specified then it defaults to butt. Where + arrowheads are drawn the cap style is ignored. + :fill color + Color specifies a color to use for drawing the line; it may + have any of the forms acceptable to Tk_GetColor. It may also + be an empty string, in which case the line will be + transparent. This option defaults to black. + :joinstyle style + Specifies the ways in which joints are to be drawn at the + vertices of the line. Style may have any of the forms + accepted by Tk_GetCapStyle (bevel, miter, or round). If this + option isn't specified then it defaults to miter. If the line + only contains two points then this option is irrelevant. + :smooth boolean + Boolean must have one of the forms accepted by Tk_GetBoolean. + It indicates whether or not the line should be drawn as a + curve. If so, the line is rendered as a set of Bezier + splines: one spline is drawn for the first and second line + segments, one for the second and third, and so on. + Straight-line segments can be generated within a curve by + duplicating the end-points of the desired line segment. + :splinesteps number + Specifies the degree of smoothness desired for curves: each + spline will be approximated with number line segments. This + option is ignored unless the :smooth option is true. + :stipple bitmap + Indicates that the line should be filled in a stipple pattern; + bitmap specifies the stipple pattern to use, in any of the + forms accepted by Tk_GetBitmap. If bitmap is an empty string + (the default), then filling is done in a solid fashion. + :tags tagList + Specifies a set of tags to apply to the item. TagList + consists of a list of tag names, which replace any existing + tags for the item. TagList may be an empty list. + :width lineWidth + LineWidth specifies the width of the line, in any of the forms + described in the COORDINATES section above. Wide lines will + be drawn centered on the path specified by the points. If + this option isn't specified then it defaults to 1.0. + +Oval Items +---------- + +Items of type oval appear as circular or oval regions on the display. +Each oval may have an outline, a fill, or both. Ovals are created with +widget commands of the following form: + +pathName :create oval x1 y1 x2 y2 ?option value option value ...? + + The arguments x1, y1, x2, and y2 give the coordinates of two + diagonally opposite corners of a rectangular region enclosing the + oval. The oval will include the top and left edges of the + rectangle not the lower or right edges. If the region is square + then the resulting oval is circular; otherwise it is elongated in + shape. After the coordinates there may be any number of + option-value pairs, each of which sets one of the configuration + options for the item. These same option\-value pairs may be used + in itemconfigure widget commands to change the item's + configuration. The following options are supported for ovals: + + :fill color + Fill the area of the oval with color. Color may have any of + the forms accepted by Tk_GetColor. If color is an empty + string (the default), then then the oval will not be filled. + :outline color + Color specifies a color to use for drawing the oval's outline; + it may have any of the forms accepted by Tk_GetColor. This + option defaults to black. If color is an empty string then no + outline will be drawn for the oval. + :stipple bitmap + Indicates that the oval should be filled in a stipple pattern; + bitmap specifies the stipple pattern to use, in any of the + forms accepted by Tk_GetBitmap. If the :fill option hasn't + been specified then this option has no effect. If bitmap is + an empty string (the default), then filling is done in a solid + fashion. + :tags tagList + Specifies a set of tags to apply to the item. TagList + consists of a list of tag names, which replace any existing + tags for the item. TagList may be an empty list. + :width outlineWidth + outlineWidth specifies the width of the outline to be drawn + around the oval, in any of the forms described in the + COORDINATES section above. If the :outline option hasn't been + specified then this option has no effect. Wide outlines are + drawn centered on the oval path defined by x1, y1, x2, and y2. + This option defaults to 1.0. + +Polygon Items +------------- + +Items of type polygon appear as polygonal or curved filled regions on +the display. Polygons are created with widget commands of the following +form: + +pathName :create polygon x1 y1 ... xn yn ?option value option value ...? + + The arguments x1 through yn specify the coordinates for three or + more points that define a closed polygon. The first and last + points may be the same; whether they are or not, Tk will draw the + polygon as a closed polygon. After the coordinates there may be + any number of option-value pairs, each of which sets one of the + configuration options for the item. These same option\-value pairs + may be used in itemconfigure widget commands to change the item's + configuration. The following options are supported for polygons: + + :fill color + Color specifies a color to use for filling the area of the + polygon; it may have any of the forms acceptable to + Tk_GetColor. If color is an empty string then the polygon + will be transparent. This option defaults to black. + :smooth boolean + Boolean must have one of the forms accepted by Tk_GetBoolean + It indicates whether or not the polygon should be drawn with a + curved perimeter. If so, the outline of the polygon becomes a + set of Bezier splines, one spline for the first and second + line segments, one for the second and third, and so on. + Straight-line segments can be generated in a smoothed polygon + by duplicating the end-points of the desired line segment. + :splinesteps number + Specifies the degree of smoothness desired for curves: each + spline will be approximated with number line segments. This + option is ignored unless the :smooth option is true. + :stipple bitmap + Indicates that the polygon should be filled in a stipple + pattern; bitmap specifies the stipple pattern to use, in any + of the forms accepted by Tk_GetBitmap. If bitmap is an empty + string (the default), then filling is done in a solid fashion. + :tags tagList + Specifies a set of tags to apply to the item. TagList + consists of a list of tag names, which replace any existing + tags for the item. TagList may be an empty list. + +Rectangle Items +--------------- + +Items of type rectangle appear as rectangular regions on the display. +Each rectangle may have an outline, a fill, or both. Rectangles are +created with widget commands of the following form: + +pathName :create rectangle x1 y1 x2 y2 ?option value option value ...? + + The arguments x1, y1, x2, and y2 give the coordinates of two + diagonally opposite corners of the rectangle (the rectangle will + include its upper and left edges but not its lower or right edges). + After the coordinates there may be any number of option-value + pairs, each of which sets one of the configuration options for the + item. These same option\-value pairs may be used in itemconfigure + widget commands to change the item's configuration. The following + options are supported for rectangles: + + :fill color + Fill the area of the rectangle with color, which may be + specified in any of the forms accepted by Tk_GetColor. If + color is an empty string (the default), then then the + rectangle will not be filled. + :outline color + Draw an outline around the edge of the rectangle in color. + Color may have any of the forms accepted by Tk_GetColor. This + option defaults to black. If color is an empty string then no + outline will be drawn for the rectangle. + :stipple bitmap + Indicates that the rectangle should be filled in a stipple + pattern; bitmap specifies the stipple pattern to use, in any + of the forms accepted by Tk_GetBitmap. If the :fill option + hasn't been specified then this option has no effect. If + bitmap is an empty string (the default), then filling is done + in a solid fashion. + :tags tagList + Specifies a set of tags to apply to the item. TagList + consists of a list of tag names, which replace any existing + tags for the item. TagList may be an empty list. + :width outlineWidth + OutlineWidth specifies the width of the outline to be drawn + around the rectangle, in any of the forms described in the + COORDINATES section above. If the :outline option hasn't been + specified then this option has no effect. Wide outlines are + drawn centered on the rectangular path defined by x1, y1, x2, + and y2. This option defaults to 1.0. + +Text Items +---------- + +A text item displays a string of characters on the screen in one or more +lines. Text items support indexing and selection, along with the +following text-related canvas widget commands: dchars, focus, icursor, +index, insert, select. Text items are created with widget commands of +the following form: + +pathName :create text x y ?option value option value ...? + + The arguments x and y specify the coordinates of a point used to + position the text on the display (see the options below for more + information on how text is displayed). After the coordinates there + may be any number of option-value pairs, each of which sets one of + the configuration options for the item. These same option\-value + pairs may be used in itemconfigure widget commands to change the + item's configuration. The following options are supported for text + items: + + :anchor anchorPos + AnchorPos tells how to position the text relative to the + positioning point for the text; it may have any of the forms + accepted by Tk_GetAnchor. For example, if anchorPos is center + then the text is centered on the point; if anchorPos is n then + the text will be drawn such that the top center point of the + rectangular region occupied by the text will be at the + positioning point. This option defaults to center. + :fill color + Color specifies a color to use for filling the text + characters; it may have any of the forms accepted by + Tk_GetColor. If this option isn't specified then it defaults + to black. + :font fontName + Specifies the font to use for the text item. FontName may be + any string acceptable to Tk_GetFontStruct. If this option + isn't specified, it defaults to a system-dependent font. + :justify how + Specifies how to justify the text within its bounding region. + How must be one of the values left, right, or center. This + option will only matter if the text is displayed as multiple + lines. If the option is omitted, it defaults to left. + :stipple bitmap + Indicates that the text should be drawn in a stippled pattern + rather than solid; bitmap specifies the stipple pattern to + use, in any of the forms accepted by Tk_GetBitmap. If bitmap + is an empty string (the default) then the text is drawn in a + solid fashion. + :tags tagList + Specifies a set of tags to apply to the item. TagList + consists of a list of tag names, which replace any existing + tags for the item. TagList may be an empty list. + :text string + String specifies the characters to be displayed in the text + item. Newline characters cause line breaks. The characters + in the item may also be changed with the insert and delete + widget commands. This option defaults to an empty string. + :width lineLength + Specifies a maximum line length for the text, in any of the + forms described in the COORDINATES section abov. If this + option is zero (the default) the text is broken into lines + only at newline characters. However, if this option is + non-zero then any line that would be longer than lineLength is + broken just before a space character to make the line shorter + than lineLength; the space character is treated as if it were + a newline character. + +Window Items +------------ + +Items of type window cause a particular window to be displayed at a +given position on the canvas. Window items are created with widget +commands of the following form: + + pathName :create window x y ?option value option value ...? + + The arguments x and y specify the coordinates of a point used to +position the window on the display (see the :anchor option below for +more information on how bitmaps are displayed). After the coordinates +there may be any number of option-value pairs, each of which sets one of +the configuration options for the item. These same option\-value pairs +may be used in itemconfigure widget commands to change the item's +configuration. The following options are supported for window items: + +:anchor anchorPos + AnchorPos tells how to position the window relative to the + positioning point for the item; it may have any of the forms + accepted by Tk_GetAnchor. For example, if anchorPos is center then + the window is centered on the point; if anchorPos is n then the + window will be drawn so that its top center point is at the + positioning point. This option defaults to center. +:height pixels + Specifies the height to assign to the item's window. Pixels may + have any of the forms described in the COORDINATES section above. + If this option isn't specified, or if it is specified as an empty + string, then the window is given whatever height it requests + internally. +:tags tagList + Specifies a set of tags to apply to the item. TagList consists of + a list of tag names, which replace any existing tags for the item. + TagList may be an empty list. +:width pixels + Specifies the width to assign to the item's window. Pixels may + have any of the forms described in the COORDINATES section above. + If this option isn't specified, or if it is specified as an empty + string, then the window is given whatever width it requests + internally. +:window pathName + Specifies the window to associate with this item. The window + specified by pathName must either be a child of the canvas widget + or a child of some ancestor of the canvas widget. PathName may not + refer to a top-level window. + +Application-Defined Item Types +------------------------------ + +It is possible for individual applications to define new item types for +canvas widgets using C code. The interfaces for this mechanism are not +presently documented, and it's possible they may change, but you should +be able to see how they work by examining the code for some of the +existing item types. + +Bindings +-------- + +In the current implementation, new canvases are not given any default +behavior: you'll have to execute explicit Tcl commands to give the +canvas its behavior. + +Credits +------- + +Tk's canvas widget is a blatant ripoff of ideas from Joel Bartlett's ezd +program. Ezd provides structured graphics in a Scheme environment and +preceded canvases by a year or two. Its simple mechanisms for placing +and animating graphical objects inspired the functions of canvases. + +Keywords +-------- + +canvas, widget + + +File: gcl-tk.info, Node: menu, Next: scrollbar, Prev: canvas, Up: Widgets + +2.5 menu +======== + +menu \- Create and manipulate menu widgets + +Synopsis +-------- + +menu pathName ?options? + +Standard Options +---------------- + + activeBackground background disabledForeground + activeBorderWidth borderWidth font + activeForeground cursor foreground + + *Note options::, for more information. + +Arguments for Menu +------------------ + +':postcommand' + Name='"postCommand" Class="Command"' + + If this option is specified then it provides a Tcl command to + execute each time the menu is posted. The command is invoked by + the post widget command before posting the menu. + +':selector' + Name='"selector" Class="Foreground"' + + For menu entries that are check buttons or radio buttons, this + option specifies the color to display in the selector when the + check button or radio button is selected. + +Introduction +------------ + +The menu command creates a new top-level window (given by the pathName +argument) and makes it into a menu widget. Additional options, +described above, may be specified on the command line or in the option +database to configure aspects of the menu such as its colors and font. +The menu command returns its pathName argument. At the time this +command is invoked, there must not exist a window named pathName, but +pathName's parent must exist. + + A menu is a widget that displays a collection of one-line entries +arranged in a column. There exist several different types of entries, +each with different properties. Entries of different types may be +combined in a single menu. Menu entries are not the same as entry +widgets. In fact, menu entries are not even distinct widgets; the +entire menu is one widget. + + Menu entries are displayed with up to three separate fields. The +main field is a label in the form of text or a bitmap, which is +determined by the :label or :bitmap option for the entry. If the +:accelerator option is specified for an entry then a second textual +field is displayed to the right of the label. The accelerator typically +describes a keystroke sequence that may be typed in the application to +cause the same result as invoking the menu entry. The third field is a +selector. The selector is present only for check-button or radio-button +entries. It indicates whether the entry is selected or not, and is +displayed to the left of the entry's string. + + In normal use, an entry becomes active (displays itself differently) +whenever the mouse pointer is over the entry. If a mouse button is +released over the entry then the entry is invoked. The effect of +invocation is different for each type of entry; these effects are +described below in the sections on individual entries. + + Entries may be disabled, which causes their labels and accelerators +to be displayed with dimmer colors. A disabled entry cannot be +activated or invoked. Disabled entries may be re-enabled, at which +point it becomes possible to activate and invoke them again. + +Command Entries +--------------- + +The most common kind of menu entry is a command entry, which behaves +much like a button widget. When a command entry is invoked, a Tcl +command is executed. The Tcl command is specified with the :command +option. + +Separator Entries +----------------- + +A separator is an entry that is displayed as a horizontal dividing line. +A separator may not be activated or invoked, and it has no behavior +other than its display appearance. + +Check-Button Entries +-------------------- + +A check-button menu entry behaves much like a check-button widget. When +it is invoked it toggles back and forth between the selected and +deselected states. When the entry is selected, a particular value is +stored in a particular global variable (as determined by the :onvalue +and :variable options for the entry); when the entry is deselected +another value (determined by the :offvalue option) is stored in the +global variable. A selector box is displayed to the left of the label +in a check-button entry. If the entry is selected then the box's center +is displayed in the color given by the selector option for the menu; +otherwise the box's center is displayed in the background color for the +menu. If a :command option is specified for a check-button entry, then +its value is evaluated as a Tcl command each time the entry is invoked; +this happens after toggling the entry's selected state. + +Radio-Button Entries +-------------------- + +A radio-button menu entry behaves much like a radio-button widget. +Radio-button entries are organized in groups of which only one entry may +be selected at a time. Whenever a particular entry becomes selected it +stores a particular value into a particular global variable (as +determined by the :value and :variable options for the entry). This +action causes any previously-selected entry in the same group to +deselect itself. Once an entry has become selected, any change to the +entry's associated variable will cause the entry to deselect itself. +Grouping of radio-button entries is determined by their associated +variables: if two entries have the same associated variable then they +are in the same group. A selector diamond is displayed to the left of +the label in each radio-button entry. If the entry is selected then the +diamond's center is displayed in the color given by the selector option +for the menu; otherwise the diamond's center is displayed in the +background color for the menu. If a :command option is specified for a +radio-button entry, then its value is evaluated as a Tcl command each +time the entry is invoked; this happens after selecting the entry. + +Cascade Entries +--------------- + +A cascade entry is one with an associated menu (determined by the :menu +option). Cascade entries allow the construction of cascading menus. +When the entry is activated, the associated menu is posted just to the +right of the entry; that menu remains posted until the higher-level menu +is unposted or until some other entry is activated in the higher-level +menu. The associated menu should normally be a child of the menu +containing the cascade entry, in order for menu traversal to work +correctly. + + A cascade entry posts its associated menu by invoking a Tcl command +of the form + +menu :post x y + + where menu is the path name of the associated menu, x and y are the + root-window coordinates of the upper-right corner of the cascade + entry, and group is the name of the menu's group (as determined in + its last post widget command). The lower-level menu is unposted by + executing a Tcl command with the form + +menu:unpost + where menu is the name of the associated menu. + + If a :command option is specified for a cascade entry then it is +evaluated as a Tcl command each time the associated menu is posted (the +evaluation occurs before the menu is posted). + +A Menu Widget's Arguments +------------------------- + +The menu command creates a new Tcl command whose name is pathName. This +command may be used to invoke various operations on the widget. It has +the following general form: + +pathName option ?arg arg ...? + Option and the args determine the exact behavior of the command. + + Many of the widget commands for a menu take as one argument an +indicator of which entry of the menu to operate on. These indicators +are called indexes and may be specified in any of the following forms: + +number + Specifies the entry numerically, where 0 corresponds to the + top-most entry of the menu, 1 to the entry below it, and so on. +active + Indicates the entry that is currently active. If no entry is + active then this form is equivalent to none. This form may not be + abbreviated. +last + Indicates the bottommost entry in the menu. If there are no + entries in the menu then this form is equivalent to none. This + form may not be abbreviated. +none + Indicates "no entry at all"; this is used most commonly with the + activate option to deactivate all the entries in the menu. In most + cases the specification of none causes nothing to happen in the + widget command. This form may not be abbreviated. +@number + In this form, number is treated as a y-coordinate in the menu's + window; the entry spanning that y-coordinate is used. For example, + "@0" indicates the top-most entry in the window. If number is + outside the range of the window then this form is equivalent to + none. +pattern + If the index doesn't satisfy one of the above forms then this form + is used. Pattern is pattern-matched against the label of each + entry in the menu, in order from the top down, until a matching + entry is found. The rules of Tcl_StringMatch are used. + + The following widget commands are possible for menu widgets: +pathName :activate index + Change the state of the entry indicated by index to active and + redisplay it using its active colors. Any previously-active entry + is deactivated. If index is specified as none, or if the specified + entry is disabled, then the menu ends up with no active entry. + Returns an empty string. +pathName :add type ?option value option value ...? + Add a new entry to the bottom of the menu. The new entry's type is + given by type and must be one of cascade, checkbutton, command, + radiobutton, or separator, or a unique abbreviation of one of the + above. If additional arguments are present, they specify any of + the following options: + + :activebackground value + Specifies a background color to use for displaying this entry + when it is active. If this option is specified as an empty + string (the default), then the activeBackground option for the + overall menu is used. This option is not available for + separator entries. + :accelerator value + Specifies a string to display at the right side of the menu + entry. Normally describes an accelerator keystroke sequence + that may be typed to invoke the same function as the menu + entry. This option is not available for separator entries. + :background value + Specifies a background color to use for displaying this entry + when it is in the normal state (neither active nor disabled). + If this option is specified as an empty string (the default), + then the background option for the overall menu is used. This + option is not available for separator entries. + :bitmap value + Specifies a bitmap to display in the menu instead of a textual + label, in any of the forms accepted by Tk_GetBitmap. This + option overrides the :label option but may be reset to an + empty string to enable a textual label to be displayed. This + option is not available for separator entries. + :command value + For command, checkbutton, and radiobutton entries, specifies a + Tcl command to execute when the menu entry is invoked. For + cascade entries, specifies a Tcl command to execute when the + entry is activated (i.e. just before its submenu is posted). + Not available for separator entries. + :font value + Specifies the font to use when drawing the label or + accelerator string in this entry. If this option is specified + as an empty string (the default) then the font option for the + overall menu is used. This option is not available for + separator entries. + :label value + Specifies a string to display as an identifying label in the + menu entry. Not available for separator entries. + :menu value + Available only for cascade entries. Specifies the path name + of the menu associated with this entry. + :offvalue value + Available only for check-button entries. Specifies the value + to store in the entry's associated variable when the entry is + deselected. + :onvalue value + Available only for check-button entries. Specifies the value + to store in the entry's associated variable when the entry is + selected. + :state value + Specifies one of three states for the entry: normal, active, + or disabled. In normal state the entry is displayed using the + foreground option for the menu and the background option from + the entry or the menu. The active state is typically used + when the pointer is over the entry. In active state the entry + is displayed using the activeForeground option for the menu + along with the activebackground option from the entry. + Disabled state means that the entry is insensitive: it doesn't + activate and doesn't respond to mouse button presses or + releases. In this state the entry is displayed according to + the disabledForeground option for the menu and the background + option from the entry. This option is not available for + separator entries. + :underline value + Specifies the integer index of a character to underline in the + entry. This option is typically used to indicate keyboard + traversal characters. 0 corresponds to the first character of + the text displayed in the entry, 1 to the next character, and + so on. If a bitmap is displayed in the entry then this option + is ignored. This option is not available for separator + entries. + :value value + Available only for radio-button entries. Specifies the value + to store in the entry's associated variable when the entry is + selected. + :variable value + Available only for check-button and radio-button entries. + Specifies the name of a global value to set when the entry is + selected. For check-button entries the variable is also set + when the entry is deselected. For radio-button entries, + changing the variable causes the currently-selected entry to + deselect itself. + + The add widget command returns an empty string. + +pathName :configure ?option? ?value option value ...? + Query or modify the configuration options of the widget. If no + option is specified, returns a list describing all of the available + options for pathName (see Tk_ConfigureInfo for information on the + format of this list). If option is specified with no value, then + the command returns a list describing the one named option (this + list will be identical to the corresponding sublist of the value + returned if no option is specified). If one or more option:value + pairs are specified, then the command modifies the given widget + option(s) to have the given value(s); in this case the command + returns an empty string. Option may have any of the values + accepted by the menu command. +pathName :delete index1 ?index2? + Delete all of the menu entries between index1 and index2 inclusive. + If index2 is omitted then it defaults to index1. Returns an empty + string. +pathName :disable index + Change the state of the entry given by index to disabled and + redisplay the entry using its disabled colors. Returns an empty + string. This command is obsolete and will eventually be removed; + use "pathName :entryconfigure index :state disabled" instead. +pathName :enable index + Change the state of the entry given by index to normal and + redisplay the entry using its normal colors. Returns an empty + string. This command is obsolete and will eventually be removed; + use "pathName :entryconfigure index :state normal" instead. +pathName :entryconfigure index ?options? + This command is similar to the configure command, except that it + applies to the options for an individual entry, whereas configure + applies to the options for the menu as a whole. Options may have + any of the values accepted by the add widget command. If options + are specified, options are modified as indicated in the command and + the command returns an empty string. If no options are specified, + returns a list describing the current options for entry index (see + Tk_ConfigureInfo for information on the format of this list). +pathName :index index + Returns the numerical index corresponding to index, or none if + index was specified as none. +pathName :invoke index + Invoke the action of the menu entry. See the sections on the + individual entries above for details on what happens. If the menu + entry is disabled then nothing happens. If the entry has a command + associated with it then the result of that command is returned as + the result of the invoke widget command. Otherwise the result is + an empty string. Note: invoking a menu entry does not + automatically unpost the menu. Normally the associated menubutton + will take care of unposting the menu. +pathName :post x y + Arrange for the menu to be displayed on the screen at the + root-window coordinates given by x and y. These coordinates are + adjusted if necessary to guarantee that the entire menu is visible + on the screen. This command normally returns an empty string. If + the :postcommand option has been specified, then its value is + executed as a Tcl script before posting the menu and the result of + that script is returned as the result of the post widget command. + If an error returns while executing the command, then the error is + returned without posting the menu. +pathName :unpost + Unmap the window so that it is no longer displayed. If a + lower-level cascaded menu is posted, unpost that menu. Returns an + empty string. +pathName :yposition index + Returns a decimal string giving the y-coordinate within the menu + window of the topmost pixel in the entry specified by index. + +Default Bindings +---------------- + +Tk automatically creates class bindings for menus that give them the +following default behavior: + [1] When the mouse cursor enters a menu, the entry underneath the + mouse cursor is activated; as the mouse moves around the menu, the + active entry changes to track the mouse. + [2] When button 1 is released over a menu, the active entry (if + any) is invoked. + [3] A menu can be repositioned on the screen by dragging it with + mouse button 2. + [4] A number of other bindings are created to support keyboard menu + traversal. See the manual entry for tk_bindForTraversal for + details on these bindings. + + Disabled menu entries are non-responsive: they don't activate and +ignore mouse button presses and releases. + + The behavior of menus can be changed by defining new bindings for +individual widgets or by redefining the class bindings. + +Bugs +---- + +At present it isn't possible to use the option database to specify +values for the options to individual entries. + +Keywords +-------- + +menu, widget + + +File: gcl-tk.info, Node: scrollbar, Next: checkbutton, Prev: menu, Up: Widgets + +2.6 scrollbar +============= + +scrollbar \- Create and manipulate scrollbar widgets + +Synopsis +-------- + +scrollbar pathName ?options? + +Standard Options +---------------- + + activeForeground cursor relief + background foreground repeatDelay + borderWidth orient repeatInterval + + *Note options::, for more information. + +Arguments for Scrollbar +----------------------- + +':command' + Name='"command" Class="Command"' + + Specifies the prefix of a Tcl command to invoke to change the view + in the widget associated with the scrollbar. When a user requests + a view change by manipulating the scrollbar, a Tcl command is + invoked. The actual command consists of this option followed by a + space and a number. The number indicates the logical unit that + should appear at the top of the associated window. + +':width' + Name='"width" Class="Width"' + + Specifies the desired narrow dimension of the scrollbar window, not + including 3-D border, if any. For vertical scrollbars this will be + the width and for horizontal scrollbars this will be the height. + The value may have any of the forms acceptable to Tk_GetPixels. + +Description +----------- + +The scrollbar command creates a new window (given by the pathName +argument) and makes it into a scrollbar widget. Additional options, +described above, may be specified on the command line or in the option +database to configure aspects of the scrollbar such as its colors, +orientation, and relief. The scrollbar command returns its pathName +argument. At the time this command is invoked, there must not exist a +window named pathName, but pathName's parent must exist. + + A scrollbar is a widget that displays two arrows, one at each end of +the scrollbar, and a slider in the middle portion of the scrollbar. A +scrollbar is used to provide information about what is visible in an +associated window that displays an object of some sort (such as a file +being edited or a drawing). The position and size of the slider +indicate which portion of the object is visible in the associated +window. For example, if the slider in a vertical scrollbar covers the +top third of the area between the two arrows, it means that the +associated window displays the top third of its object. + + Scrollbars can be used to adjust the view in the associated window by +clicking or dragging with the mouse. See the BINDINGS section below for +details. + +A Scrollbar Widget's Arguments +------------------------------ + +The scrollbar command creates a new Tcl command whose name is pathName. +This command may be used to invoke various operations on the widget. It +has the following general form: + + pathName option ?arg arg ...? + + Option and the args determine the exact behavior of the command. The +following commands are possible for scrollbar widgets: + +pathName :configure ?option? ?value option value ...? + Query or modify the configuration options of the widget. If no + option is specified, returns a list describing all of the available + options for pathName (see Tk_ConfigureInfo for information on the + format of this list). If option is specified with no value, then + the command returns a list describing the one named option (this + list will be identical to the corresponding sublist of the value + returned if no option is specified). If one or more option:value + pairs are specified, then the command modifies the given widget + option(s) to have the given value(s); in this case the command + returns an empty string. Option may have any of the values + accepted by the scrollbar command. +pathName :get + Returns a Tcl list containing four decimal values, which are the + current totalUnits, widnowUnits, firstUnit, and lastUnit values for + the scrollbar. These are the values from the most recent set + widget command on the scrollbar. +pathName :set totalUnits windowUnits firstUnit lastUnit + This command is invoked to give the scrollbar information about the + widget associated with the scrollbar. TotalUnits is an integer + value giving the total size of the object being displayed in the + associated widget. The meaning of one unit depends on the + associated widget; for example, in a text editor widget units might + correspond to lines of text. WindowUnits indicates the total + number of units that can fit in the associated window at one time. + FirstUnit and lastUnit give the indices of the first and last units + currently visible in the associated window (zero corresponds to the + first unit of the object). This command should be invoked by the + associated widget whenever its object or window changes size and + whenever it changes the view in its window. + +Bindings +-------- + +The description below assumes a vertically-oriented scrollbar. For a +horizontally-oriented scrollbar replace the words "up", "down", "top", +and "bottom" with "left", "right", "left", and "right", respectively + + A scrollbar widget is divided into five distinct areas. From top to +bottom, they are: the top arrow, the top gap (the empty space between +the arrow and the slider), the slider, the bottom gap, and the bottom +arrow. Pressing mouse button 1 in each area has a different effect: + +top arrow + Causes the view in the associated window to shift up by one unit + (i.e. the object appears to move down one unit in its window). If + the button is held down the action will auto-repeat. +top gap + Causes the view in the associated window to shift up by one less + than the number of units in the window (i.e. the portion of the + object that used to appear at the very top of the window will now + appear at the very bottom). If the button is held down the action + will auto-repeat. +slider + Pressing button 1 in this area has no immediate effect except to + cause the slider to appear sunken rather than raised. However, if + the mouse is moved with the button down then the slider will be + dragged, adjusting the view as the mouse is moved. +bottom gap + Causes the view in the associated window to shift down by one less + than the number of units in the window (i.e. the portion of the + object that used to appear at the very bottom of the window will + now appear at the very top). If the button is held down the action + will auto-repeat. +bottom arrow + Causes the view in the associated window to shift down by one unit + (i.e. the object appears to move up one unit in its window). If + the button is held down the action will auto-repeat. + + Note: none of the actions described above has an immediate impact + on the position of the slider in the scrollbar. It simply invokes + the command specified in the command option to notify the + associated widget that a change in view is desired. If the view is + actually changed then the associated widget must invoke the + scrollbar's set widget command to change what is displayed in the + scrollbar. + +Keywords +-------- + +scrollbar, widget + + +File: gcl-tk.info, Node: checkbutton, Next: menubutton, Prev: scrollbar, Up: Widgets + +2.7 checkbutton +=============== + +checkbutton \- Create and manipulate check-button widgets + +Synopsis +-------- + +checkbutton pathName ?options? + +Standard Options +---------------- + + activeBackground bitmap font relief + activeForeground borderWidth foreground text + anchor cursor padX textVariable + background disabledForeground padY + + *Note options::, for more information. + +Arguments for Checkbutton +------------------------- + +':command' + Name='"command" Class="Command"' + + Specifies a Tcl command to associate with the button. This command + is typically invoked when mouse button 1 is released over the + button window. The button's global variable (:variable option) + will be updated before the command is invoked. + +':height' + Name='"height" Class="Height"' + + Specifies a desired height for the button. If a bitmap is being + displayed in the button then the value is in screen units (i.e. + any of the forms acceptable to Tk_GetPixels); for text it is in + lines of text. If this option isn't specified, the button's + desired height is computed from the size of the bitmap or text + being displayed in it. + +':offvalue' + Name='"offValue" Class="Value"' + + Specifies value to store in the button's associated variable + whenever this button is deselected. Defaults to "0". + +':onvalue' + Name='"onValue" Class="Value"' + + Specifies value to store in the button's associated variable + whenever this button is selected. Defaults to "1". + +':selector' + Name='"selector" Class="Foreground"' + + Specifies the color to draw in the selector when this button is + selected. If specified as an empty string then no selector is + drawn for the button. + +':state' + Name='"state" Class="State"' + + Specifies one of three states for the check button: normal, active, + or disabled. In normal state the check button is displayed using + the foreground and background options. The active state is + typically used when the pointer is over the check button. In + active state the check button is displayed using the + activeForeground and activeBackground options. Disabled state + means that the check button is insensitive: it doesn't activate and + doesn't respond to mouse button presses. In this state the + disabledForeground and background options determine how the check + button is displayed. + +':variable' + Name='"variable" Class="Variable"' + + Specifies name of global variable to set to indicate whether or not + this button is selected. Defaults to the name of the button within + its parent (i.e. the last element of the button window's path + name). + +':width' + Name='"width" Class="Width"' + + Specifies a desired width for the button. If a bitmap is being + displayed in the button then the value is in screen units (i.e. + any of the forms acceptable to Tk_GetPixels); for text it is in + characters. If this option isn't specified, the button's desired + width is computed from the size of the bitmap or text being + displayed in it. + +Description +----------- + +The checkbutton command creates a new window (given by the pathName +argument) and makes it into a check-button widget. Additional options, +described above, may be specified on the command line or in the option +database to configure aspects of the check button such as its colors, +font, text, and initial relief. The checkbutton command returns its +pathName argument. At the time this command is invoked, there must not +exist a window named pathName, but pathName's parent must exist. + + A check button is a widget that displays a textual string or bitmap +and a square called a selector. A check button has all of the behavior +of a simple button, including the following: it can display itself in +either of three different ways, according to the state option; it can be +made to appear raised, sunken, or flat; it can be made to flash; and it +invokes a Tcl command whenever mouse button 1 is clicked over the check +button. + + In addition, check buttons can be selected. If a check button is +selected then a special highlight appears in the selector, and a Tcl +variable associated with the check button is set to a particular value +(normally 1). If the check button is not selected, then the selector is +drawn in a different fashion and the associated variable is set to a +different value (typically 0). By default, the name of the variable +associated with a check button is the same as the name used to create +the check button. The variable name, and the "on" and "off" values +stored in it, may be modified with options on the command line or in the +option database. By default a check button is configured to select and +deselect itself on alternate button clicks. In addition, each check +button monitors its associated variable and automatically selects and +deselects itself when the variables value changes to and from the +button's "on" value. + +A Checkbutton Widget's Arguments +-------------------------------- + +The checkbutton command creates a new Tcl command whose name is +pathName. This command may be used to invoke various operations on the +widget. It has the following general form: + + pathName option ?arg arg ...? + + Option and the args determine the exact behavior of the command. The +following commands are possible for check button widgets: + +pathName :activate + Change the check button's state to active and redisplay the button + using its active foreground and background colors instead of normal + colors. This command is ignored if the check button's state is + disabled. This command is obsolete and will eventually be removed; + use "pathName :configure :state active" instead. +pathName :configure ?option? ?value option value ...? + Query or modify the configuration options of the widget. If no + option is specified, returns a list describing all of the available + options for pathName (see Tk_ConfigureInfo for information on the + format of this list). If option is specified with no value, then + the command returns a list describing the one named option (this + list will be identical to the corresponding sublist of the value + returned if no option is specified). If one or more option:value + pairs are specified, then the command modifies the given widget + option(s) to have the given value(s); in this case the command + returns an empty string. Option may have any of the values + accepted by the checkbutton command. +pathName :deactivate + Change the check button's state to normal and redisplay the button + using its normal foreground and background colors. This command is + ignored if the check button's state is disabled. This command is + obsolete and will eventually be removed; use "pathName :configure + :state normal" instead. +pathName :deselect + Deselect the check button: redisplay it without a highlight in the + selector and set the associated variable to its "off" value. +pathName :flash + Flash the check button. This is accomplished by redisplaying the + check button several times, alternating between active and normal + colors. At the end of the flash the check button is left in the + same normal/active state as when the command was invoked. This + command is ignored if the check button's state is disabled. +pathName :invoke + Does just what would have happened if the user invoked the check + button with the mouse: toggle the selection state of the button and + invoke the Tcl command associated with the check button, if there + is one. The return value is the return value from the Tcl command, + or an empty string if there is no command associated with the check + button. This command is ignored if the check button's state is + disabled. +pathName :select + Select the check button: display it with a highlighted selector and + set the associated variable to its "on" value. +pathName :toggle + Toggle the selection state of the button, redisplaying it and + modifying its associated variable to reflect the new state. + +Bindings +-------- + +Tk automatically creates class bindings for check buttons that give them +the following default behavior: + [1] The check button activates whenever the mouse passes over it + and deactivates whenever the mouse leaves the check button. + [2] The check button's relief is changed to sunken whenever mouse + button 1 is pressed over it, and the relief is restored to its + original value when button 1 is later released. + [3] If mouse button 1 is pressed over the check button and later + released over the check button, the check button is invoked (i.e. + its selection state toggles and the command associated with the + button is invoked, if there is one). However, if the mouse is not + over the check button when button 1 is released, then no invocation + occurs. + + If the check button's state is disabled then none of the above +actions occur: the check button is completely non-responsive. + + The behavior of check buttons can be changed by defining new bindings +for individual widgets or by redefining the class bindings. + +Keywords +-------- + +check button, widget + + +File: gcl-tk.info, Node: menubutton, Next: text, Prev: checkbutton, Up: Widgets + +2.8 menubutton +============== + +menubutton \- Create and manipulate menubutton widgets + +Synopsis +-------- + +menubutton pathName ?options? + +Standard Options +---------------- + + activeBackground bitmap font relief + activeForeground borderWidth foreground text + anchor cursor padX textVariable + background disabledForeground padY underline + + *Note options::, for more information. + +Arguments for Menubutton +------------------------ + +':height' + Name='"height" Class="Height"' + + Specifies a desired height for the menu button. If a bitmap is + being displayed in the menu button then the value is in screen + units (i.e. any of the forms acceptable to Tk_GetPixels); for text + it is in lines of text. If this option isn't specified, the menu + button's desired height is computed from the size of the bitmap or + text being displayed in it. + +':menu' + Name='"menu" Class="MenuName"' + + Specifies the path name of the menu associated with this + menubutton. The menu must be a descendant of the menubutton in + order for normal pull-down operation to work via the mouse. + +':state' + Name='"state" Class="State"' + + Specifies one of three states for the menu button: normal, active, + or disabled. In normal state the menu button is displayed using + the foreground and background options. The active state is + typically used when the pointer is over the menu button. In active + state the menu button is displayed using the activeForeground and + activeBackground options. Disabled state means that the menu + button is insensitive: it doesn't activate and doesn't respond to + mouse button presses. In this state the disabledForeground and + background options determine how the button is displayed. + +':width' + Name='"width" Class="Width"' + + Specifies a desired width for the menu button. If a bitmap is + being displayed in the menu button then the value is in screen + units (i.e. any of the forms acceptable to Tk_GetPixels); for text + it is in characters. If this option isn't specified, the menu + button's desired width is computed from the size of the bitmap or + text being displayed in it. + +Introduction +------------ + +The menubutton command creates a new window (given by the pathName +argument) and makes it into a menubutton widget. Additional options, +described above, may be specified on the command line or in the option +database to configure aspects of the menubutton such as its colors, +font, text, and initial relief. The menubutton command returns its +pathName argument. At the time this command is invoked, there must not +exist a window named pathName, but pathName's parent must exist. + + A menubutton is a widget that displays a textual string or bitmap and +is associated with a menu widget. In normal usage, pressing mouse +button 1 over the menubutton causes the associated menu to be posted +just underneath the menubutton. If the mouse is moved over the menu +before releasing the mouse button, the button release causes the +underlying menu entry to be invoked. When the button is released, the +menu is unposted. + + Menubuttons are typically organized into groups called menu bars that +allow scanning: if the mouse button is pressed over one menubutton +(causing it to post its menu) and the mouse is moved over another +menubutton in the same menu bar without releasing the mouse button, then +the menu of the first menubutton is unposted and the menu of the new +menubutton is posted instead. The tk-menu-bar procedure is used to set +up menu bars for scanning; see that procedure for more details. + +A Menubutton Widget's Arguments +------------------------------- + +The menubutton command creates a new Tcl command whose name is pathName. +This command may be used to invoke various operations on the widget. It +has the following general form: + + pathName option ?arg arg ...? + + Option and the args determine the exact behavior of the command. The +following commands are possible for menubutton widgets: + +pathName :activate + Change the menu button's state to active and redisplay the menu + button using its active foreground and background colors instead of + normal colors. The command returns an empty string. This command + is ignored if the menu button's state is disabled. This command is + obsolete and will eventually be removed; use "pathName :configure + :state active" instead. +pathName :configure ?option? ?value option value ...? + Query or modify the configuration options of the widget. If no + option is specified, returns a list describing all of the available + options for pathName (see Tk_ConfigureInfo for information on the + format of this list). If option is specified with no value, then + the command returns a list describing the one named option (this + list will be identical to the corresponding sublist of the value + returned if no option is specified). If one or more option:value + pairs are specified, then the command modifies the given widget + option(s) to have the given value(s); in this case the command + returns an empty string. Option may have any of the values + accepted by the menubutton command. +pathName :deactivate + Change the menu button's state to normal and redisplay the menu + button using its normal foreground and background colors. The + command returns an empty string. This command is ignored if the + menu button's state is disabled. This command is obsolete and will + eventually be removed; use "pathName :configure :state normal" + instead. + +"Default Bindings" +------------------ + +Tk automatically creates class bindings for menu buttons that give them +the following default behavior: + [1] A menu button activates whenever the mouse passes over it and + deactivates whenever the mouse leaves it. + [2] A menu button's relief is changed to raised whenever mouse + button 1 is pressed over it, and the relief is restored to its + original value when button 1 is later released or the mouse is + dragged into another menu button in the same menu bar. + [3] When mouse button 1 is pressed over a menu button, or when the + mouse is dragged into a menu button with mouse button 1 pressed, + the associated menu is posted; the mouse can be dragged across the + menu and released over an entry in the menu to invoke that entry. + The menu is unposted when button 1 is released outside either the + menu or the menu button. The menu is also unposted when the mouse + is dragged into another menu button in the same menu bar. + [4] If mouse button 1 is pressed and released within the menu + button, then the menu stays posted and keyboard traversal is + possible as described in the manual entry for tk-menu-bar. + [5] Menubuttons may also be posted by typing characters on the + keyboard. See the manual entry for tk-menu-bar for full details on + keyboard menu traversal. + [6] If mouse button 2 is pressed over a menu button then the + associated menu is posted and also torn off: it can then be dragged + around on the screen with button 2 and the menu will not + automatically unpost when entries in it are invoked. To close a + torn off menu, click mouse button 1 over the associated menu + button. + + If the menu button's state is disabled then none of the above actions +occur: the menu button is completely non-responsive. + + The behavior of menu buttons can be changed by defining new bindings +for individual widgets or by redefining the class bindings. + +Keywords +-------- + +menubutton, widget + + +File: gcl-tk.info, Node: text, Next: entry, Prev: menubutton, Up: Widgets + +2.9 text +======== + +text \- Create and manipulate text widgets + +Synopsis +-------- + +text pathName ?options? + +Standard Options +---------------- + + background foreground insertWidth selectBorderWidth + borderWidth insertBackground padX selectForeground + cursor insertBorderWidth padY setGrid + exportSelection insertOffTime relief yScrollCommand + font insertOnTime selectBackground + + *Note options::, for more information. + +Arguments for Text +------------------ + +':height' + Name='"height" Class="Height"' + + Specifies the desired height for the window, in units of + characters. Must be at least one. + +':state' + Name='"state" Class="State"' + + Specifies one of two states for the text: normal or disabled. If + the text is disabled then characters may not be inserted or deleted + and no insertion cursor will be displayed, even if the input focus + is in the widget. + +':width' + Name='"width" Class="Width"' + + Specifies the desired width for the window in units of characters. + If the font doesn't have a uniform width then the width of the + character "0" is used in translating from character units to screen + units. + +':wrap' + Name='"wrap" Class="Wrap"' + + Specifies how to handle lines in the text that are too long to be + displayed in a single line of the text's window. The value must be + none or char or word. A wrap mode of none means that each line of + text appears as exactly one line on the screen; extra characters + that don't fit on the screen are not displayed. In the other modes + each line of text will be broken up into several screen lines if + necessary to keep all the characters visible. In char mode a + screen line break may occur after any character; in word mode a + line break will only be made at word boundaries. + +Description +----------- + +The text command creates a new window (given by the pathName argument) +and makes it into a text widget. Additional options, described above, +may be specified on the command line or in the option database to +configure aspects of the text such as its default background color and +relief. The text command returns the path name of the new window. + + A text widget displays one or more lines of text and allows that text +to be edited. Text widgets support three different kinds of annotations +on the text, called tags, marks, and windows. Tags allow different +portions of the text to be displayed with different fonts and colors. +In addition, Tcl commands can be associated with tags so that commands +are invoked when particular actions such as keystrokes and mouse button +presses occur in particular ranges of the text. See TAGS below for more +details. + + The second form of annotation consists of marks, which are floating +markers in the text. Marks are used to keep track of various +interesting positions in the text as it is edited. See MARKS below for +more details. + + The third form of annotation allows arbitrary windows to be displayed +in the text widget. See WINDOWS below for more details. + +Indices +------- + +Many of the widget commands for texts take one or more indices as +arguments. An index is a string used to indicate a particular place +within a text, such as a place to insert characters or one endpoint of a +range of characters to delete. Indices have the syntax + + base modifier modifier modifier ... + + Where base gives a starting point and the modifiers adjust the index +from the starting point (e.g. move forward or backward one character). +Every index must contain a base, but the modifiers are optional. + + The base for an index must have one of the following forms: + +line.char + Indicates char'th character on line line. Lines are numbered from + 1 for consistency with other UNIX programs that use this numbering + scheme. Within a line, characters are numbered from 0. +@x,y + Indicates the character that covers the pixel whose x and y + coordinates within the text's window are x and y. +end + Indicates the last character in the text, which is always a newline + character. +mark + Indicates the character just after the mark whose name is mark. +tag.first + Indicates the first character in the text that has been tagged with + tag. This form generates an error if no characters are currently + tagged with tag. +tag.last + Indicates the character just after the last one in the text that + has been tagged with tag. This form generates an error if no + characters are currently tagged with tag. + + If modifiers follow the base index, each one of them must have one of +the forms listed below. Keywords such as chars and wordend may be +abbreviated as long as the abbreviation is unambiguous. + ++ count chars + Adjust the index forward by count characters, moving to later lines + in the text if necessary. If there are fewer than count characters + in the text after the current index, then set the index to the last + character in the text. Spaces on either side of count are + optional. +- count chars + Adjust the index backward by count characters, moving to earlier + lines in the text if necessary. If there are fewer than count + characters in the text before the current index, then set the index + to the first character in the text. Spaces on either side of count + are optional. ++ count lines + Adjust the index forward by count lines, retaining the same + character position within the line. If there are fewer than count + lines after the line containing the current index, then set the + index to refer to the same character position on the last line of + the text. Then, if the line is not long enough to contain a + character at the indicated character position, adjust the character + position to refer to the last character of the line (the newline). + Spaces on either side of count are optional. +- count lines + Adjust the index backward by count lines, retaining the same + character position within the line. If there are fewer than count + lines before the line containing the current index, then set the + index to refer to the same character position on the first line of + the text. Then, if the line is not long enough to contain a + character at the indicated character position, adjust the character + position to refer to the last character of the line (the newline). + Spaces on either side of count are optional. +linestart + Adjust the index to refer to the first character on the line. +lineend + Adjust the index to refer to the last character on the line (the + newline). +wordstart + Adjust the index to refer to the first character of the word + containing the current index. A word consists of any number of + adjacent characters that are letters, digits, or underscores, or a + single character that is not one of these. +wordend + Adjust the index to refer to the character just after the last one + of the word containing the current index. If the current index + refers to the last character of the text then it is not modified. + + If more than one modifier is present then they are applied in +left-to-right order. For example, the index "\fBend \- 1 chars" refers +to the next-to-last character in the text and "\fBinsert wordstart \- 1 +c" refers to the character just before the first one in the word +containing the insertion cursor. + +Tags +---- + +The first form of annotation in text widgets is a tag. A tag is a +textual string that is associated with some of the characters in a text. +There may be any number of tags associated with characters in a text. +Each tag may refer to a single character, a range of characters, or +several ranges of characters. An individual character may have any +number of tags associated with it. + + A priority order is defined among tags, and this order is used in +implementing some of the tag-related functions described below. When a +tag is defined (by associating it with characters or setting its display +options or binding commands to it), it is given a priority higher than +any existing tag. The priority order of tags may be redefined using the +"pathName :tag :raise" and "pathName :tag :lower" widget commands. + + Tags serve three purposes in text widgets. First, they control the +way information is displayed on the screen. By default, characters are +displayed as determined by the background, font, and foreground options +for the text widget. However, display options may be associated with +individual tags using the "pathName :tag configure" widget command. If +a character has been tagged, then the display options associated with +the tag override the default display style. The following options are +currently supported for tags: + +:background color + Color specifies the background color to use for characters + associated with the tag. It may have any of the forms accepted by + Tk_GetColor. +:bgstipple bitmap + Bitmap specifies a bitmap that is used as a stipple pattern for the + background. It may have any of the forms accepted by Tk_GetBitmap. + If bitmap hasn't been specified, or if it is specified as an empty + string, then a solid fill will be used for the background. +:borderwidth pixels + Pixels specifies the width of a 3-D border to draw around the + background. It may have any of the forms accepted by Tk_GetPixels. + This option is used in conjunction with the :relief option to give + a 3-D appearance to the background for characters; it is ignored + unless the :background option has been set for the tag. +:fgstipple bitmap + Bitmap specifies a bitmap that is used as a stipple pattern when + drawing text and other foreground information such as underlines. + It may have any of the forms accepted by Tk_GetBitmap. If bitmap + hasn't been specified, or if it is specified as an empty string, + then a solid fill will be used. +:font fontName + FontName is the name of a font to use for drawing characters. It + may have any of the forms accepted by Tk_GetFontStruct. +:foreground color + Color specifies the color to use when drawing text and other + foreground information such as underlines. It may have any of the + forms accepted by Tk_GetColor. +:relief relief + \fIRelief specifies the 3-D relief to use for drawing backgrounds, + in any of the forms accepted by Tk_GetRelief. This option is used + in conjunction with the :borderwidth option to give a 3-D + appearance to the background for characters; it is ignored unless + the :background option has been set for the tag. +:underline boolean + Boolean specifies whether or not to draw an underline underneath + characters. It may have any of the forms accepted by + Tk_GetBoolean. + + If a character has several tags associated with it, and if their + display options conflict, then the options of the highest priority + tag are used. If a particular display option hasn't been specified + for a particular tag, or if it is specified as an empty string, + then that option will never be used; the next-highest-priority + tag's option will used instead. If no tag specifies a particular + display optionl, then the default style for the widget will be + used. + + The second purpose for tags is event bindings. You can associate + bindings with a tag in much the same way you can associate bindings + with a widget class: whenever particular X events occur on + characters with the given tag, a given Tcl command will be + executed. Tag bindings can be used to give behaviors to ranges of + characters; among other things, this allows hypertext-like features + to be implemented. For details, see the description of the tag + bind widget command below. + + The third use for tags is in managing the selection. See THE + SELECTION below. + +Marks +----- + +The second form of annotation in text widgets is a mark. Marks are used +for remembering particular places in a text. They are something like +tags, in that they have names and they refer to places in the file, but +a mark isn't associated with particular characters. Instead, a mark is +associated with the gap between two characters. Only a single position +may be associated with a mark at any given time. If the characters +around a mark are deleted the mark will still remain; it will just have +new neighbor characters. In contrast, if the characters containing a +tag are deleted then the tag will no longer have an association with +characters in the file. Marks may be manipulated with the "pathName +:mark" widget command, and their current locations may be determined by +using the mark name as an index in widget commands. + + The name space for marks is different from that for tags: the same +name may be used for both a mark and a tag, but they will refer to +different things. + + Two marks have special significance. First, the mark insert is +associated with the insertion cursor, as described under THE INSERTION +CURSOR below. Second, the mark current is associated with the character +closest to the mouse and is adjusted automatically to track the mouse +position and any changes to the text in the widget (one exception: +current is not updated in response to mouse motions if a mouse button is +down; the update will be deferred until all mouse buttons have been +released). Neither of these special marks may be unset. + +Windows +------- + +The third form of annotation in text widgets is a window. Window +support isn't implemented yet, but when it is it will be described here. + +The Selection +------------- + +Text widgets support the standard X selection. Selection support is +implemented via tags. If the exportSelection option for the text widget +is true then the sel tag will be associated with the selection: + [1] Whenever characters are tagged with sel the text widget will + claim ownership of the selection. + [2] Attempts to retrieve the selection will be serviced by the text + widget, returning all the charaters with the sel tag. + [3] If the selection is claimed away by another application or by + another window within this application, then the sel tag will be + removed from all characters in the text. + + The sel tag is automatically defined when a text widget is created, +and it may not be deleted with the "pathName :tag delete" widget +command. Furthermore, the selectBackground, selectBorderWidth, and +selectForeground options for the text widget are tied to the +:background, :borderwidth, and :foreground options for the sel tag: +changes in either will automatically be reflected in the other. + +The Insertion Cursor +-------------------- + +The mark named insert has special significance in text widgets. It is +defined automatically when a text widget is created and it may not be +unset with the "pathName :mark unset" widget command. The insert mark +represents the position of the insertion cursor, and the insertion +cursor will automatically be drawn at this point whenever the text +widget has the input focus. + +A Text Widget's Arguments +------------------------- + +The text command creates a new Tcl command whose name is the same as the +path name of the text's window. This command may be used to invoke +various operations on the widget. It has the following general form: + + pathName option ?arg arg ...? + + PathName is the name of the command, which is the same as the text +widget's path name. Option and the args determine the exact behavior of +the command. The following commands are possible for text widgets: + +pathName :compare index1 op index2 + Compares the indices given by index1 and index2 according to the + relational operator given by op, and returns 1 if the relationship + is satisfied and 0 if it isn't. Op must be one of the operators <, + <=, ==, >=, >, or !=. If op is == then 1 is returned if the two + indices refer to the same character, if op is < then 1 is returned + if index1 refers to an earlier character in the text than index2, + and so on. +pathName :configure ?option? ?value option value ...? + Query or modify the configuration options of the widget. If no + option is specified, returns a list describing all of the available + options for pathName (see Tk_ConfigureInfo for information on the + format of this list). If option is specified with no value, then + the command returns a list describing the one named option (this + list will be identical to the corresponding sublist of the value + returned if no option is specified). If one or more option:value + pairs are specified, then the command modifies the given widget + option(s) to have the given value(s); in this case the command + returns an empty string. Option may have any of the values + accepted by the text command. +pathName :debug ?boolean? + If boolean is specified, then it must have one of the true or false + values accepted by Tcl_GetBoolean. If the value is a true one then + internal consistency checks will be turned on in the B-tree code + associated with text widgets. If boolean has a false value then + the debugging checks will be turned off. In either case the + command returns an empty string. If boolean is not specified then + the command returns on or off to indicate whether or not debugging + is turned on. There is a single debugging switch shared by all + text widgets: turning debugging on or off in any widget turns it on + or off for all widgets. For widgets with large amounts of text, + the consistency checks may cause a noticeable slow-down. +pathName :delete index1 ?index2? + Delete a range of characters from the text. If both index1 and + index2 are specified, then delete all the characters starting with + the one given by index1 and stopping just before index2 (i.e. the + character at index2 is not deleted). If index2 doesn't specify a + position later in the text than index1 then no characters are + deleted. If index2 isn't specified then the single character at + index1 is deleted. It is not allowable to delete characters in a + way that would leave the text without a newline as the last + character. The command returns an empty string. +pathName :get index1 ?index2? + Return a range of characters from the text. The return value will + be all the characters in the text starting with the one whose index + is index1 and ending just before the one whose index is index2 (the + character at index2 will not be returned). If index2 is omitted + then the single character at index1 is returned. If there are no + characters in the specified range (e.g. index1 is past the end of + the file or index2 is less than or equal to index1) then an empty + string is returned. +pathName :index index + Returns the position corresponding to index in the form line.char + where line is the line number and char is the character number. + Index may have any of the forms described under INDICES above. +pathName :insert \fIindex chars + Inserts chars into the text just before the character at index and + returns an empty string. It is not possible to insert characters + after the last newline of the text. +pathName :mark option ?arg arg ...? + This command is used to manipulate marks. The exact behavior of + the command depends on the option argument that follows the mark + argument. The following forms of the command are currently + supported: + pathName :mark :names + Returns a list whose elements are the names of all the marks + that are currently set. + pathName :mark :set markName index + Sets the mark named markName to a position just before the + character at index. If markName already exists, it is moved + from its old position; if it doesn't exist, a new mark is + created. This command returns an empty string. + pathName :mark :unset markName ?markName markName ...? + Remove the mark corresponding to each of the markName + arguments. The removed marks will not be usable in indices + and will not be returned by future calls to "pathName :mark + names". This command returns an empty string. + +pathName :scan option args + This command is used to implement scanning on texts. It has two + forms, depending on option: + pathName :scan :mark y + Records y and the current view in the text window; used in + conjunction with later scan dragto commands. Typically this + command is associated with a mouse button press in the widget. + It returns an empty string. + pathName :scan :dragto y + This command computes the difference between its y argument + and the y argument to the last scan mark command for the + widget. It then adjusts the view up or down by 10 times the + difference in y-coordinates. This command is typically + associated with mouse motion events in the widget, to produce + the effect of dragging the text at high speed through the + window. The return value is an empty string. + +pathName :tag option ?arg arg ...? + This command is used to manipulate tags. The exact behavior of the + command depends on the option argument that follows the tag + argument. The following forms of the command are currently + supported: + + pathName :tag :add tagName index1 ?index2? + Associate the tag tagName with all of the characters starting + with index1 and ending just before index2 (the character at + index2 isn't tagged). If index2 is omitted then the single + character at index1 is tagged. If there are no characters in + the specified range (e.g. index1 is past the end of the file + or index2 is less than or equal to index1) then the command + has no effect. This command returns an empty string. + pathName :tag :bind tagName ?sequence? ?command? + This command associates command with the tag given by tagName. + Whenever the event sequence given by sequence occurs for a + character that has been tagged with tagName, the command will + be invoked. This widget command is similar to the bind + command except that it operates on characters in a text rather + than entire widgets. See the bind manual entry for complete + details on the syntax of sequence and the substitutions + performed on command before invoking it. If all arguments are + specified then a new binding is created, replacing any + existing binding for the same sequence and tagName (if the + first character of command is "+" then command augments an + existing binding rather than replacing it). In this case the + return value is an empty string. If command is omitted then + the command returns the command associated with tagName and + sequence (an error occurs if there is no such binding). If + both command and sequence are omitted then the command returns + a list of all the sequences for which bindings have been + defined for tagName. + + The only events for which bindings may be specified are those + related to the mouse and keyboard, such as Enter, Leave, + ButtonPress, Motion, and KeyPress. Event bindings for a text + widget use the current mark described under MARKS above. + Enter events trigger for a character when it becomes the + current character (i.e. the current mark moves to just in + front of that character). Leave events trigger for a + character when it ceases to be the current item (i.e. the + current mark moves away from that character, or the character + is deleted). These events are different than Enter and Leave + events for windows. Mouse and keyboard events are directed to + the current character. + + It is possible for the current character to have multiple + tags, and for each of them to have a binding for a particular + event sequence. When this occurs, the binding from the + highest priority tag is used. If a particular tag doesn't + have a binding that matches an event, then the tag is ignored + and tags with lower priority will be checked. + + If bindings are created for the widget as a whole using the + bind command, then those bindings will supplement the tag + bindings. This means that a single event can trigger two Tcl + scripts, one for a widget-level binding and one for a + tag-level binding. + + pathName :tag :configure tagName ?option? ?value? ?option value ...? + This command is similar to the configure widget command except + that it modifies options associated with the tag given by + tagName instead of modifying options for the overall text + widget. If no option is specified, the command returns a list + describing all of the available options for tagName (see + Tk_ConfigureInfo for information on the format of this list). + If option is specified with no value, then the command returns + a list describing the one named option (this list will be + identical to the corresponding sublist of the value returned + if no option is specified). If one or more option:value pairs + are specified, then the command modifies the given option(s) + to have the given value(s) in tagName; in this case the + command returns an empty string. See TAGS above for details + on the options available for tags. + pathName :tag :delete tagName ?tagName ...? + Deletes all tag information for each of the tagName arguments. + The command removes the tags from all characters in the file + and also deletes any other information associated with the + tags, such as bindings and display information. The command + returns an empty string. + pathName :tag :lower tagName ?belowThis? + Changes the priority of tag tagName so that it is just lower + in priority than the tag whose name is belowThis. If + belowThis is omitted, then tagName's priority is changed to + make it lowest priority of all tags. + pathName :tag :names ?index? + Returns a list whose elements are the names of all the tags + that are active at the character position given by index. If + index is omitted, then the return value will describe all of + the tags that exist for the text (this includes all tags that + have been named in a "pathName :tag" widget command but + haven't been deleted by a "pathName :tag :delete" widget + command, even if no characters are currently marked with the + tag). The list will be sorted in order from lowest priority + to highest priority. + pathName :tag :nextrange tagName index1 ?index2? + This command searches the text for a range of characters + tagged with tagName where the first character of the range is + no earlier than the character at index1 and no later than the + character just before index2 (a range starting at index2 will + not be considered). If several matching ranges exist, the + first one is chosen. The command's return value is a list + containing two elements, which are the index of the first + character of the range and the index of the character just + after the last one in the range. If no matching range is + found then the return value is an empty string. If index2 is + not given then it defaults to the end of the text. + pathName :tag :raise tagName ?aboveThis? + Changes the priority of tag tagName so that it is just higher + in priority than the tag whose name is aboveThis. If + aboveThis is omitted, then tagName's priority is changed to + make it highest priority of all tags. + pathName :tag :ranges tagName + Returns a list describing all of the ranges of text that have + been tagged with tagName. The first two elements of the list + describe the first tagged range in the text, the next two + elements describe the second range, and so on. The first + element of each pair contains the index of the first character + of the range, and the second element of the pair contains the + index of the character just after the last one in the range. + If there are no characters tagged with tag then an empty + string is returned. + pathName :tag :remove tagName index1 ?index2? + Remove the tag tagName from all of the characters starting at + index1 and ending just before index2 (the character at index2 + isn't affected). If index2 is omitted then the single + character at index1 is untagged. If there are no characters + in the specified range (e.g. index1 is past the end of the + file or index2 is less than or equal to index1) then the + command has no effect. This command returns an empty string. + +pathName :yview ?:pickplace? what + This command changes the view in the widget's window so that the + line given by what is visible in the window. What may be either an + absolute line number, where 0 corresponds to the first line of the + file, or an index with any of the forms described under INDICES + above. The first form (absolute line number) is used in the + commands issued by scrollbars to control the widget's view. If the + :pickplace option isn't specified then what will appear at the top + of the window. If :pickplace is specified then the widget chooses + where what appears in the window: + [1] If what is already visible somewhere in the window then + the command does nothing. + [2] If what is only a few lines off-screen above the window + then it will be positioned at the top of the window. + [3] If what is only a few lines off-screen below the window + then it will be positioned at the bottom of the window. + [4] Otherwise, what will be centered in the window. + + The :pickplace option is typically used after inserting text to + make sure that the insertion cursor is still visible on the screen. + This command returns an empty string. + +Bindings +-------- + +Tk automatically creates class bindings for texts that give them the +following default behavior: + [1] Pressing mouse button 1 in an text positions the insertion + cursor just before the character underneath the mouse cursor and + sets the input focus to this widget. + [2] Dragging with mouse button 1 strokes out a selection between + the insertion cursor and the character under the mouse. + [3] If you double-press mouse button 1 then the word under the + mouse cursor will be selected, the insertion cursor will be + positioned at the beginning of the word, and dragging the mouse + will stroke out a selection whole words at a time. + [4] If you triple-press mouse button 1 then the line under the + mouse cursor will be selected, the insertion cursor will be + positioned at the beginning of the line, and dragging the mouse + will stroke out a selection whole line at a time. + [5] The ends of the selection can be adjusted by dragging with + mouse button 1 while the shift key is down; this will adjust the + end of the selection that was nearest to the mouse cursor when + button 1 was pressed. If the selection was made in word or line + mode then it will be adjusted in this same mode. + [6] The view in the text can be adjusted by dragging with mouse + button 2. + [7] If the input focus is in a text widget and characters are typed + on the keyboard, the characters are inserted just before the + insertion cursor. + [8] Control+h and the Backspace and Delete keys erase the character + just before the insertion cursor. + [9] Control+v inserts the current selection just before the + insertion cursor. + [10] Control+d deletes the selected characters; an error occurs if + the selection is not in this widget. + + If the text is disabled using the state option, then the text's view +can still be adjusted and text in the text can still be selected, but no +insertion cursor will be displayed and no text modifications will take +place. + + The behavior of texts can be changed by defining new bindings for +individual widgets or by redefining the class bindings. + +"Performance Issues" +-------------------- + +Text widgets should run efficiently under a variety of conditions. The +text widget uses about 2-3 bytes of main memory for each byte of text, +so texts containing a megabyte or more should be practical on most +workstations. Text is represented internally with a modified B-tree +structure that makes operations relatively efficient even with large +texts. Tags are included in the B-tree structure in a way that allows +tags to span large ranges or have many disjoint smaller ranges without +loss of efficiency. Marks are also implemented in a way that allows +large numbers of marks. The only known mode of operation where a text +widget may not run efficiently is if it has a very large number of +different tags. Hundreds of tags should be fine, or even a thousand, +but tens of thousands of tags will make texts consume a lot of memory +and run slowly. + +Keywords +-------- + +text, widget + + +File: gcl-tk.info, Node: entry, Next: message, Prev: text, Up: Widgets + +2.10 entry +========== + +entry \- Create and manipulate entry widgets + +Synopsis +-------- + +entry pathName ?options? + +Standard Options +---------------- + + background foreground insertWidth selectForeground + borderWidth insertBackground relief textVariable + cursor insertBorderWidth scrollCommand + exportSelection insertOffTime selectBackground + font insertOnTime selectBorderWidth + + *Note options::, for more information. + +Arguments for Entry +------------------- + +':state' + Name='"state" Class="State"' + + Specifies one of two states for the entry: normal or disabled. If + the entry is disabled then the value may not be changed using + widget commands and no insertion cursor will be displayed, even if + the input focus is in the widget. + +':width' + Name='"width" Class="Width"' + + Specifies an integer value indicating the desired width of the + entry window, in average-size characters of the widget's font. + +Description +----------- + +The entry command creates a new window (given by the pathName argument) +and makes it into an entry widget. Additional options, described above, +may be specified on the command line or in the option database to +configure aspects of the entry such as its colors, font, and relief. +The entry command returns its pathName argument. At the time this +command is invoked, there must not exist a window named pathName, but +pathName's parent must exist. + + An entry is a widget that displays a one-line text string and allows +that string to be edited using widget commands described below, which +are typically bound to keystrokes and mouse actions. When first +created, an entry's string is empty. A portion of the entry may be +selected as described below. If an entry is exporting its selection +(see the exportSelection option), then it will observe the standard X11 +protocols for handling the selection; entry selections are available as +type STRING. Entries also observe the standard Tk rules for dealing with +the input focus. When an entry has the input focus it displays an +insertion cursor to indicate where new characters will be inserted. + + Entries are capable of displaying strings that are too long to fit +entirely within the widget's window. In this case, only a portion of +the string will be displayed; commands described below may be used to +change the view in the window. Entries use the standard scrollCommand +mechanism for interacting with scrollbars (see the description of the +scrollCommand option for details). They also support scanning, as +described below. + +A Entry Widget's Arguments +-------------------------- + +The entry command creates a new Tcl command whose name is pathName. +This command may be used to invoke various operations on the widget. It +has the following general form: + + pathName option ?arg arg ...? + + Option and the args determine the exact behavior of the command. + + Many of the widget commands for entries take one or more indices as +arguments. An index specifies a particular character in the entry's +string, in any of the following ways: + +number + Specifies the character as a numerical index, where 0 corresponds + to the first character in the string. +end + Indicates the character just after the last one in the entry's + string. This is equivalent to specifying a numerical index equal + to the length of the entry's string. +insert + Indicates the character adjacent to and immediately following the + insertion cursor. +sel.first + Indicates the first character in the selection. It is an error to + use this form if the selection isn't in the entry window. +sel.last + Indicates the last character in the selection. It is an error to + use this form if the selection isn't in the entry window. +@number + In this form, number is treated as an x-coordinate in the entry's + window; the character spanning that x-coordinate is used. For + example, "@0" indicates the left-most character in the window. + + Abbreviations may be used for any of the forms above, e.g. "e" or +"sel.f". In general, out-of-range indices are automatically rounded to +the nearest legal value. + + The following commands are possible for entry widgets: + +pathName :configure ?option? ?value option value ...? + Query or modify the configuration options of the widget. If no + option is specified, returns a list describing all of the available + options for pathName (see Tk_ConfigureInfo for information on the + format of this list). If option is specified with no value, then + the command returns a list describing the one named option (this + list will be identical to the corresponding sublist of the value + returned if no option is specified). If one or more option:value + pairs are specified, then the command modifies the given widget + option(s) to have the given value(s); in this case the command + returns an empty string. Option may have any of the values + accepted by the entry command. +pathName :delete first ?last? + Delete one or more elements of the entry. First and last are + indices of of the first and last characters in the range to be + deleted. If last isn't specified it defaults to first, i.e. a + single character is deleted. This command returns an empty string. +pathName :get + Returns the entry's string. +pathName :icursor index + Arrange for the insertion cursor to be displayed just before the + character given by index. Returns an empty string. +pathName :index index + Returns the numerical index corresponding to index. +pathName :insert index string + Insert the characters of string just before the character indicated + by index. Returns an empty string. +pathName :scan option args + This command is used to implement scanning on entries. It has two + forms, depending on option: + pathName :scan :mark x + Records x and the current view in the entry window; used in + conjunction with later scan dragto commands. Typically this + command is associated with a mouse button press in the widget. + It returns an empty string. + pathName :scan :dragto x + This command computes the difference between its x argument + and the x argument to the last scan mark command for the + widget. It then adjusts the view left or right by 10 times + the difference in x-coordinates. This command is typically + associated with mouse motion events in the widget, to produce + the effect of dragging the entry at high speed through the + window. The return value is an empty string. +pathName :select option arg + This command is used to adjust the selection within an entry. It + has several forms, depending on option: + pathName :select :adjust index + Locate the end of the selection nearest to the character given + by index, and adjust that end of the selection to be at index + (i.e including but not going beyond index). The other end of + the selection is made the anchor point for future select to + commands. If the selection isn't currently in the entry, then + a new selection is created to include the characters between + index and the most recent selection anchor point, inclusive. + Returns an empty string. + pathName :select :clear + Clear the selection if it is currently in this widget. If the + selection isn't in this widget then the command has no effect. + Returns an empty string. + pathName :select :from index + Set the selection anchor point to just before the character + given by index. Doesn't change the selection. Returns an + empty string. + pathName :select :to index + Set the selection to consist of the elements from the anchor + point to element index, inclusive. The anchor point is + determined by the most recent select from or select adjust + command in this widget. If the selection isn't in this widget + then a new selection is created using the most recent anchor + point specified for the widget. Returns an empty string. +pathName :view index + Adjust the view in the entry so that element index is at the left + edge of the window. Returns an empty string. + +"Default Bindings" +------------------ + +Tk automatically creates class bindings for entries that give them the +following default behavior: + + [1] Clicking mouse button 1 in an entry positions the insertion + cursor just before the character underneath the mouse cursor and + sets the input focus to this widget. + [2] Dragging with mouse button 1 strokes out a selection between + the insertion cursor and the character under the mouse. + [3] The ends of the selection can be adjusted by dragging with + mouse button 1 while the shift key is down; this will adjust the + end of the selection that was nearest to the mouse cursor when + button 1 was pressed. + [4] The view in the entry can be adjusted by dragging with mouse + button 2. + [5] If the input focus is in an entry widget and characters are + typed on the keyboard, the characters are inserted just before the + insertion cursor. + [6] Control-h and the Backspace and Delete keys erase the character + just before the insertion cursor. + [7] Control-w erases the word just before the insertion cursor. + [8] Control-u clears the entry to an empty string. + [9] Control-v inserts the current selection just before the + insertion cursor. + [10] Control-d deletes the selected characters; an error occurs if + the selection is not in this widget. + + If the entry is disabled using the state option, then the entry's +view can still be adjusted and text in the entry can still be selected, +but no insertion cursor will be displayed and no text modifications will +take place. + + The behavior of entries can be changed by defining new bindings for +individual widgets or by redefining the class bindings. + +Keywords +-------- + +entry, widget + + +File: gcl-tk.info, Node: message, Next: frame, Prev: entry, Up: Widgets + +2.11 message +============ + +message \- Create and manipulate message widgets + +Synopsis +-------- + +message pathName ?options? + +Standard Options +---------------- + + anchor cursor padX text + background font padY textVariable + borderWidth foreground relief width + + *Note options::, for more information. + +Arguments for Message +--------------------- + +':aspect' + Name='"aspect" Class="Aspect"' + + Specifies a non-negative integer value indicating desired aspect + ratio for the text. The aspect ratio is specified as + 100*width/height. 100 means the text should be as wide as it is + tall, 200 means the text should be twice as wide as it is tall, 50 + means the text should be twice as tall as it is wide, and so on. + Used to choose line length for text if width option isn't + specified. Defaults to 150. + +':justify' + Name='"justify" Class="Justify"' + + Specifies how to justify lines of text. Must be one of left, + center, or right. Defaults to left. This option works together + with the anchor, aspect, padX, padY, and width options to provide a + variety of arrangements of the text within the window. The aspect + and width options determine the amount of screen space needed to + display the text. The anchor, padX, and padY options determine + where this rectangular area is displayed within the widget's + window, and the justify option determines how each line is + displayed within that rectangular region. For example, suppose + anchor is e and justify is left, and that the message window is + much larger than needed for the text. The the text will displayed + so that the left edges of all the lines line up and the right edge + of the longest line is padX from the right side of the window; the + entire text block will be centered in the vertical span of the + window. + +':width' + Name='"width" Class="Width"' + + Specifies the length of lines in the window. The value may have + any of the forms acceptable to Tk_GetPixels. If this option has a + value greater than zero then the aspect option is ignored and the + width option determines the line length. If this option has a + value less than or equal to zero, then the aspect option determines + the line length. + +Description +----------- + +The message command creates a new window (given by the pathName +argument) and makes it into a message widget. Additional options, +described above, may be specified on the command line or in the option +database to configure aspects of the message such as its colors, font, +text, and initial relief. The message command returns its pathName +argument. At the time this command is invoked, there must not exist a +window named pathName, but pathName's parent must exist. + + A message is a widget that displays a textual string. A message +widget has three special features. First, it breaks up its string into +lines in order to produce a given aspect ratio for the window. The line +breaks are chosen at word boundaries wherever possible (if not even a +single word would fit on a line, then the word will be split across +lines). Newline characters in the string will force line breaks; they +can be used, for example, to leave blank lines in the display. + + The second feature of a message widget is justification. The text +may be displayed left-justified (each line starts at the left side of +the window), centered on a line-by-line basis, or right-justified (each +line ends at the right side of the window). + + The third feature of a message widget is that it handles control +characters and non-printing characters specially. Tab characters are +replaced with enough blank space to line up on the next 8-character +boundary. Newlines cause line breaks. Other control characters (ASCII +code less than 0x20) and characters not defined in the font are +displayed as a four-character sequence \fB\exhh where hh is the +two-digit hexadecimal number corresponding to the character. In the +unusual case where the font doesn't contain all of the characters in +"0123456789abcdef\ex" then control characters and undefined characters +are not displayed at all. + +A Message Widget's Arguments +---------------------------- + +The message command creates a new Tcl command whose name is pathName. +This command may be used to invoke various operations on the widget. It +has the following general form: + + pathName option ?arg arg ...? + + Option and the args determine the exact behavior of the command. The +following commands are possible for message widgets: + +pathName :configure ?option? ?value option value ...? + Query or modify the configuration options of the widget. If no + option is specified, returns a list describing all of the available + options for pathName (see Tk_ConfigureInfo for information on the + format of this list). If option is specified with no value, then + the command returns a list describing the one named option (this + list will be identical to the corresponding sublist of the value + returned if no option is specified). If one or more option:value + pairs are specified, then the command modifies the given widget + option(s) to have the given value(s); in this case the command + returns an empty string. Option may have any of the values + accepted by the message command. + +"Default Bindings" +------------------ + +When a new message is created, it has no default event bindings: +messages are intended for output purposes only. + +Bugs +---- + +Tabs don't work very well with text that is centered or right-justified. +The most common result is that the line is justified wrong. + +Keywords +-------- + +message, widget + + +File: gcl-tk.info, Node: frame, Next: label, Prev: message, Up: Widgets + +2.12 frame +========== + +frame \- Create and manipulate frame widgets + +Synopsis +-------- + +frame pathName ?:class className? ?options? + +Standard Options +---------------- + + background cursor relief + borderWidth geometry + + *Note options::, for more information. + +Arguments for Frame +------------------- + +':height' + Name='"height" Class="Height"' + + Specifies the desired height for the window in any of the forms + acceptable to Tk_GetPixels. This option is only used if the + :geometry option is unspecified. If this option is less than or + equal to zero (and :geometry is not specified) then the window will + not request any size at all. + +':width' + Name='"width" Class="Width"' + + Specifies the desired width for the window in any of the forms + acceptable to Tk_GetPixels. This option is only used if the + :geometry option is unspecified. If this option is less than or + equal to zero (and :geometry is not specified) then the window will + not request any size at all. + +Description +----------- + +The frame command creates a new window (given by the pathName argument) +and makes it into a frame widget. Additional options, described above, +may be specified on the command line or in the option database to +configure aspects of the frame such as its background color and relief. +The frame command returns the path name of the new window. + + A frame is a simple widget. Its primary purpose is to act as a +spacer or container for complex window layouts. The only features of a +frame are its background color and an optional 3-D border to make the +frame appear raised or sunken. + + In addition to the standard options listed above, a :class option may +be specified on the command line. If it is specified, then the new +widget's class will be set to className instead of Frame. Changing the +class of a frame widget may be useful in order to use a special class +name in database options referring to this widget and its children. +Note: :class is handled differently than other command-line options and +cannot be specified using the option database (it has to be processed +before the other options are even looked up, since the new class name +will affect the lookup of the other options). In addition, the :class +option may not be queried or changed using the config command described +below. + +A Frame Widget's Arguments +-------------------------- + +The frame command creates a new Tcl command whose name is the same as +the path name of the frame's window. This command may be used to invoke +various operations on the widget. It has the following general form: + + pathName option ?arg arg ...? + + PathName is the name of the command, which is the same as the frame +widget's path name. Option and the args determine the exact behavior of +the command. The following commands are possible for frame widgets: + +pathName :configure ?option? ?value option value ...? + Query or modify the configuration options of the widget. If no + option is specified, returns a list describing all of the available + options for pathName (see Tk_ConfigureInfo for information on the + format of this list). If option is specified with no value, then + the command returns a list describing the one named option (this + list will be identical to the corresponding sublist of the value + returned if no option is specified). If one or more option:value + pairs are specified, then the command modifies the given widget + option(s) to have the given value(s); in this case the command + returns an empty string. Option may have any of the values + accepted by the frame command. + +Bindings +-------- + +When a new frame is created, it has no default event bindings: frames +are not intended to be interactive. + +Keywords +-------- + +frame, widget + + +File: gcl-tk.info, Node: label, Next: radiobutton, Prev: frame, Up: Widgets + +2.13 label +========== + +label \- Create and manipulate label widgets + +Synopsis +-------- + +label pathName ?options? + +Standard Options +---------------- + + anchor borderWidth foreground relief + background cursor padX text + bitmap font padY textVariable + + *Note options::, for more information. + +Arguments for Label +------------------- + +':height' + Name='"height" Class="Height"' + + Specifies a desired height for the label. If a bitmap is being + displayed in the label then the value is in screen units (i.e. any + of the forms acceptable to Tk_GetPixels); for text it is in lines + of text. If this option isn't specified, the label's desired + height is computed from the size of the bitmap or text being + displayed in it. + +':width' + Name='"width" Class="Width"' + + Specifies a desired width for the label. If a bitmap is being + displayed in the label then the value is in screen units (i.e. any + of the forms acceptable to Tk_GetPixels); for text it is in + characters. If this option isn't specified, the label's desired + width is computed from the size of the bitmap or text being + displayed in it. + +Description +----------- + +The label command creates a new window (given by the pathName argument) +and makes it into a label widget. Additional options, described above, +may be specified on the command line or in the option database to +configure aspects of the label such as its colors, font, text, and +initial relief. The label command returns its pathName argument. At +the time this command is invoked, there must not exist a window named +pathName, but pathName's parent must exist. + + A label is a widget that displays a textual string or bitmap. The +label can be manipulated in a few simple ways, such as changing its +relief or text, using the commands described below. + +A Label Widget's Arguments +-------------------------- + +The label command creates a new Tcl command whose name is pathName. +This command may be used to invoke various operations on the widget. It +has the following general form: + + pathName option ?arg arg ...? + + Option and the args determine the exact behavior of the command. The +following commands are possible for label widgets: + +pathName :configure ?option? ?value option value ...? + Query or modify the configuration options of the widget. If no + option is specified, returns a list describing all of the available + options for pathName (see Tk_ConfigureInfo for information on the + format of this list). If option is specified with no value, then + the command returns a list describing the one named option (this + list will be identical to the corresponding sublist of the value + returned if no option is specified). If one or more option:value + pairs are specified, then the command modifies the given widget + option(s) to have the given value(s); in this case the command + returns an empty string. Option may have any of the values + accepted by the label command. + +Bindings +-------- + +When a new label is created, it has no default event bindings: labels +are not intended to be interactive. + +Keywords +-------- + +label, widget + + +File: gcl-tk.info, Node: radiobutton, Next: toplevel, Prev: label, Up: Widgets + +2.14 radiobutton +================ + +radiobutton \- Create and manipulate radio-button widgets + +Synopsis +-------- + +radiobutton pathName ?options? + +Standard Options +---------------- + + activeBackground bitmap font relief + activeForeground borderWidth foreground text + anchor cursor padX textVariable + background disabledForeground padX + + *Note options::, for more information. + +Arguments for Radiobutton +------------------------- + +':command' + Name='"command" Class="Command"' + + Specifies a Tcl command to associate with the button. This command + is typically invoked when mouse button 1 is released over the + button window. The button's global variable (:variable option) + will be updated before the command is invoked. + +':height' + Name='"height" Class="Height"' + + Specifies a desired height for the button. If a bitmap is being + displayed in the button then the value is in screen units (i.e. + any of the forms acceptable to Tk_GetPixels); for text it is in + lines of text. If this option isn't specified, the button's + desired height is computed from the size of the bitmap or text + being displayed in it. + +':selector' + Name='"selector" Class="Foreground"' + + Specifies the color to draw in the selector when this button is + selected. If specified as an empty string then no selector is + drawn for the button. + +':state' + Name='"state" Class="State"' + + Specifies one of three states for the radio button: normal, active, + or disabled. In normal state the radio button is displayed using + the foreground and background options. The active state is + typically used when the pointer is over the radio button. In + active state the radio button is displayed using the + activeForeground and activeBackground options. Disabled state + means that the radio button is insensitive: it doesn't activate and + doesn't respond to mouse button presses. In this state the + disabledForeground and background options determine how the radio + button is displayed. + +':value' + Name='"value" Class="Value"' + + Specifies value to store in the button's associated variable + whenever this button is selected. Defaults to the name of the + radio button. + +':variable' + Name='"variable" Class="Variable"' + + Specifies name of global variable to set whenever this button is + selected. Changes in this variable also cause the button to select + or deselect itself. Defaults to the value selectedButton. + +':width' + Name='"width" Class="Width"' + + Specifies a desired width for the button. If a bitmap is being + displayed in the button then the value is in screen units (i.e. + any of the forms acceptable to Tk_GetPixels); for text it is in + characters. If this option isn't specified, the button's desired + width is computed from the size of the bitmap or text being + displayed in it. + +Description +----------- + +The radiobutton command creates a new window (given by the pathName +argument) and makes it into a radiobutton widget. Additional options, +described above, may be specified on the command line or in the option +database to configure aspects of the radio button such as its colors, +font, text, and initial relief. The radiobutton command returns its +pathName argument. At the time this command is invoked, there must not +exist a window named pathName, but pathName's parent must exist. + + A radio button is a widget that displays a textual string or bitmap +and a diamond called a selector. A radio button has all of the behavior +of a simple button: it can display itself in either of three different +ways, according to the state option; it can be made to appear raised, +sunken, or flat; it can be made to flash; and it invokes a Tcl command +whenever mouse button 1 is clicked over the check button. + + In addition, radio buttons can be selected. If a radio button is +selected then a special highlight appears in the selector and a Tcl +variable associated with the radio button is set to a particular value. +If the radio button is not selected then the selector is drawn in a +different fashion. Typically, several radio buttons share a single +variable and the value of the variable indicates which radio button is +to be selected. When a radio button is selected it sets the value of +the variable to indicate that fact; each radio button also monitors the +value of the variable and automatically selects and deselects itself +when the variable's value changes. By default the variable +selectedButton is used; its contents give the name of the button that is +selected, or the empty string if no button associated with that variable +is selected. The name of the variable for a radio button, plus the +variable to be stored into it, may be modified with options on the +command line or in the option database. By default a radio button is +configured to select itself on button clicks. + +A Radiobutton Widget's Arguments +-------------------------------- + +The radiobutton command creates a new Tcl command whose name is +pathName. This command may be used to invoke various operations on the +widget. It has the following general form: + + pathName option ?arg arg ...? + + Option and the args determine the exact behavior of the command. The +following commands are possible for radio-button widgets: + +pathName :activate + Change the radio button's state to active and redisplay the button + using its active foreground and background colors instead of normal + colors. This command is ignored if the radio button's state is + disabled. This command is obsolete and will eventually be removed; + use "pathName :configure :state active" instead. +pathName :configure ?option? ?value option value ...? + Query or modify the configuration options of the widget. If no + option is specified, returns a list describing all of the available + options for pathName (see Tk_ConfigureInfo for information on the + format of this list). If option is specified with no value, then + the command returns a list describing the one named option (this + list will be identical to the corresponding sublist of the value + returned if no option is specified). If one or more option:value + pairs are specified, then the command modifies the given widget + option(s) to have the given value(s); in this case the command + returns an empty string. Option may have any of the values + accepted by the radiobutton command. +pathName :deactivate + Change the radio button's state to normal and redisplay the button + using its normal foreground and background colors. This command is + ignored if the radio button's state is disabled. This command is + obsolete and will eventually be removed; use "pathName :configure + :state normal" instead. +pathName :deselect + Deselect the radio button: redisplay it without a highlight in the + selector and set the associated variable to an empty string. If + this radio button was not currently selected, then the command has + no effect. +pathName :flash + Flash the radio button. This is accomplished by redisplaying the + radio button several times, alternating between active and normal + colors. At the end of the flash the radio button is left in the + same normal/active state as when the command was invoked. This + command is ignored if the radio button's state is disabled. +pathName :invoke + Does just what would have happened if the user invoked the radio + button with the mouse: select the button and invoke its associated + Tcl command, if there is one. The return value is the return value + from the Tcl command, or an empty string if there is no command + associated with the radio button. This command is ignored if the + radio button's state is disabled. +pathName :select + Select the radio button: display it with a highlighted selector and + set the associated variable to the value corresponding to this + widget. + +Bindings +-------- + +Tk automatically creates class bindings for radio buttons that give them +the following default behavior: + [1] The radio button activates whenever the mouse passes over it + and deactivates whenever the mouse leaves the radio button. + [2] The radio button's relief is changed to sunken whenever mouse + button 1 is pressed over it, and the relief is restored to its + original value when button 1 is later released. + [3] If mouse button 1 is pressed over the radio button and later + released over the radio button, the radio button is invoked (i.e. + it is selected and the command associated with the button is + invoked, if there is one). However, if the mouse is not over the + radio button when button 1 is released, then no invocation occurs. + + The behavior of radio buttons can be changed by defining new bindings +for individual widgets or by redefining the class bindings. + +Keywords +-------- + +radio button, widget + + +File: gcl-tk.info, Node: toplevel, Prev: radiobutton, Up: Widgets + +2.15 toplevel +============= + +toplevel \- Create and manipulate toplevel widgets + +Synopsis +-------- + +toplevel pathName ?:screen screenName? ?:class className? ?options? + +Standard Options +---------------- + + background geometry + borderWidth relief + + *Note options::, for more information. + +Arguments for Toplevel +---------------------- + +Description +----------- + +The toplevel command creates a new toplevel widget (given by the +pathName argument). Additional options, described above, may be +specified on the command line or in the option database to configure +aspects of the toplevel such as its background color and relief. The +toplevel command returns the path name of the new window. + + A toplevel is similar to a frame except that it is created as a +top-level window: its X parent is the root window of a screen rather +than the logical parent from its path name. The primary purpose of a +toplevel is to serve as a container for dialog boxes and other +collections of widgets. The only features of a toplevel are its +background color and an optional 3-D border to make the toplevel appear +raised or sunken. + + Two special command-line options may be provided to the toplevel +command: :class and :screen. If :class is specified, then the new +widget's class will be set to className instead of Toplevel. Changing +the class of a toplevel widget may be useful in order to use a special +class name in database options referring to this widget and its +children. The :screen option may be used to place the window on a +different screen than the window's logical parent. Any valid screen +name may be used, even one associated with a different display. + + Note: :class and :screen are handled differently than other +command-line options. They may not be specified using the option +database (these options must have been processed before the new window +has been created enough to use the option database; in particular, the +new class name will affect the lookup of options in the database). In +addition, :class and :screen may not be queried or changed using the +config command described below. However, the winfo :class command may +be used to query the class of a window, and winfo :screen may be used to +query its screen. + +A Toplevel Widget's Arguments +----------------------------- + +The toplevel command creates a new Tcl command whose name is the same as +the path name of the toplevel's window. This command may be used to +invoke various operations on the widget. It has the following general +form: + + pathName option ?arg arg ...? + + PathName is the name of the command, which is the same as the +toplevel widget's path name. Option and the args determine the exact +behavior of the command. The following commands are possible for +toplevel widgets: + +pathName :configure ?option? ?value option value ...? + Query or modify the configuration options of the widget. If no + option is specified, returns a list describing all of the available + options for pathName (see Tk_ConfigureInfo for information on the + format of this list). If option is specified with no value, then + the command returns a list describing the one named option (this + list will be identical to the corresponding sublist of the value + returned if no option is specified). If one or more option:value + pairs are specified, then the command modifies the given widget + option(s) to have the given value(s); in this case the command + returns an empty string. Option may have any of the values + accepted by the toplevel command. + +Bindings +-------- + +When a new toplevel is created, it has no default event bindings: +toplevels are not intended to be interactive. + +Keywords +-------- + +toplevel, widget + + +File: gcl-tk.info, Node: Control, Prev: Widgets, Up: Top + +3 Control +********* + +* Menu: + +* after:: +* bind:: +* destroy:: +* tk-dialog:: +* exit:: +* focus:: +* grab:: +* tk-listbox-single-select:: +* lower:: +* tk-menu-bar:: +* option:: +* options:: +* pack-old:: +* pack:: +* place:: +* raise:: +* selection:: +* send:: +* tk:: +* tkerror:: +* tkvars:: +* tkwait:: +* update:: +* winfo:: +* wm:: + + +File: gcl-tk.info, Node: after, Next: bind, Prev: Control, Up: Control + +3.1 after +========= + +after - Execute a command after a time delay + +Synopsis +-------- + +after ms ?arg1 arg2 arg3 ...? + +Description +----------- + +This command is used to delay execution of the program or to execute a +command in background after a delay. The ms argument gives a time in +milliseconds. If ms is the only argument to after then the command +sleeps for ms milliseconds and returns. While the command is sleeping +the application does not respond to X events and other events. + + If additional arguments are present after ms, then a Tcl command is +formed by concatenating all the additional arguments in the same fashion +as the concat command. After returns immediately but arranges for the +command to be executed ms milliseconds later in background. The command +will be executed at global level (outside the context of any Tcl +procedure). If an error occurs while executing the delayed command then +the tkerror mechanism is used to report the error. + + The after command always returns an empty string. + + *Note tkerror::. + +Keywords +-------- + +delay, sleep, time + + +File: gcl-tk.info, Node: bind, Next: destroy, Prev: after, Up: Control + +3.2 bind +======== + +bind \- Arrange for X events to invoke Tcl commands + +Synopsis +-------- + + +bind windowSpec + +bind windowSpec sequence + +bind windowSpec sequence command +bind windowSpec sequence +command + +Description +----------- + +If all three arguments are specified, bind will arrange for command (a +Tcl command) to be executed whenever the sequence of events given by +sequence occurs in the window(s) identified by windowSpec. If command +is prefixed with a "+", then it is appended to any existing binding for +sequence; otherwise command replaces the existing binding, if any. If +command is an empty string then the current binding for sequence is +destroyed, leaving sequence unbound. In all of the cases where a +command argument is provided, bind returns an empty string. + + If sequence is specified without a command, then the command +currently bound to sequence is returned, or an empty string if there is +no binding for sequence. If neither sequence nor command is specified, +then the return value is a list whose elements are all the sequences for +which there exist bindings for windowSpec. + + The windowSpec argument selects which window(s) the binding applies +to. It may have one of three forms. If windowSpec is the path name for +a window, then the binding applies to that particular window. If +windowSpec is the name of a class of widgets, then the binding applies +to all widgets in that class. Lastly, windowSpec may have the value +all, in which case the binding applies to all windows in the +application. + + The sequence argument specifies a sequence of one or more event +patterns, with optional white space between the patterns. Each event +pattern may take either of two forms. In the simplest case it is a +single printing ASCII character, such as a or [. The character may not +be a space character or the character <. This form of pattern matches a +KeyPress event for the particular character. The second form of pattern +is longer but more general. It has the following syntax: + + + + The entire event pattern is surrounded by angle brackets. Inside the +angle brackets are zero or more modifiers, an event type, and an extra +piece of information (detail) identifying a particular button or keysym. +Any of the fields may be omitted, as long as at least one of type and +detail is present. The fields must be separated by white space or +dashes. + + Modifiers may consist of any of the values in the following list: + + Control Any + Shift Double + Lock Triple + Button1, B1 Mod1, M1, Meta, M + Button2, B2 Mod2, M2, Alt + Button3, B3 Mod3, M3 + Button4, B4 Mod4, M4 + Button5, B5 Mod5, M5 + + Where more than one value is listed, separated by commas, the values +are equivalent. All of the modifiers except Any, Double, and Triple +have the obvious X meanings. For example, Button1 requires that button +1 be depressed when the event occurs. Under normal conditions the +button and modifier state at the time of the event must match exactly +those specified in the bind command. If no modifiers are specified, +then events will match only if no modifiers are present. If the Any +modifier is specified, then additional modifiers may be present besides +those specified explicitly. For example, if button 1 is pressed while +the shift and control keys are down, the specifier + will match the event, but the specifier + will not. + + The Double and Triple modifiers are a convenience for specifying +double mouse clicks and other repeated events. They cause a particular +event pattern to be repeated 2 or 3 times, and also place a time and +space requirement on the sequence: for a sequence of events to match a +Double or Triple pattern, all of the events must occur close together in +time and without substantial mouse motion in between. For example, + is equivalent to with the extra +time and space requirement. + + The type field may be any of the standard X event types, with a few +extra abbreviations. Below is a list of all the valid types; where two +name appear together, they are synonyms. + + ButtonPress, Button Expose Leave + ButtonRelease FocusIn Map + Circulate FocusOut Property + CirculateRequest Gravity Reparent + Colormap Keymap ResizeRequest + Configure KeyPress, Key Unmap + ConfigureRequest KeyRelease Visibility + Destroy MapRequest + Enter Motion + + The last part of a long event specification is detail. In the case +of a ButtonPress or ButtonRelease event, it is the number of a button +(1-5). If a button number is given, then only an event on that +particular button will match; if no button number is given, then an +event on any button will match. Note: giving a specific button number +is different than specifying a button modifier; in the first case, it +refers to a button being pressed or released, while in the second it +refers to some other button that is already depressed when the matching +event occurs. If a button number is given then type may be omitted: if +will default to ButtonPress. For example, the specifier <1> is +equivalent to . + + If the event type is KeyPress or KeyRelease, then detail may be +specified in the form of an X keysym. Keysyms are textual +specifications for particular keys on the keyboard; they include all the +alphanumeric ASCII characters (e.g. "a" is the keysym for the ASCII +character "a"), plus descriptions for non-alphanumeric characters +("comma" is the keysym for the comma character), plus descriptions for +all the non-ASCII keys on the keyboard ("Shift_L" is the keysm for the +left shift key, and "F1" is the keysym for the F1 function key, if it +exists). The complete list of keysyms is not presented here; it should +be available in other X documentation. If necessary, you can use the %K +notation described below to print out the keysym name for an arbitrary +key. If a keysym detail is given, then the type field may be omitted; +it will default to KeyPress. For example, is equivalent +to . If a keysym detail is specified then the +Shift modifier need not be specified and will be ignored if specified: +each keysym already implies a particular state for the shift key. + + The command argument to bind is a Tcl command string, which will be +executed whenever the given event sequence occurs. Command will be +executed in the same interpreter that the bind command was executed in. +If command contains any % characters, then the command string will not +be executed directly. Instead, a new command string will be generated +by replacing each %, and the character following it, with information +from the current event. The replacement depends on the character +following the %, as defined in the list below. Unless otherwise +indicated, the replacement string is the decimal value of the given +field from the current event. Some of the substitutions are only valid +for certain types of events; if they are used for other types of events +the value substituted is undefined. + +%% + Replaced with a single percent. +|%#| + The number of the last client request processed by the server (the + serial field from the event). Valid for all event types. +|%a| + The above field from the event. Valid only for ConfigureNotify + events. +|%b| + The number of the button that was pressed or released. Valid only + for ButtonPress and ButtonRelease events. +|%c| + The count field from the event. Valid only for Expose, + GraphicsExpose, and MappingNotify events. +|%d| + The detail field from the event. The |%d| is replaced by a string + identifying the detail. For EnterNotify, LeaveNotify, FocusIn, and + FocusOut events, the string will be one of the following: + + NotifyAncestor NotifyNonlinearVirtual + NotifyDetailNone NotifyPointer + NotifyInferior NotifyPointerRoot + NotifyNonlinear NotifyVirtual + + For ConfigureRequest events, the substituted string will be one of + the following: + + Above Opposite + Below TopIf + BottomIf + + For events other than these, the substituted string is undefined. + .RE +|%f| + The focus field from the event (0 or 1). Valid only for + EnterNotify and LeaveNotify events. +|%h| + The height field from the event. Valid only for Configure, + ConfigureNotify, Expose, GraphicsExpose, and ResizeRequest events. +|%k| + The keycode field from the event. Valid only for KeyPress and + KeyRelease events. +|%m| + The mode field from the event. The substituted string is one of + NotifyNormal, NotifyGrab, NotifyUngrab, or NotifyWhileGrabbed. + Valid only for EnterWindow, FocusIn, FocusOut, and LeaveWindow + events. +|%o| + The override_redirect field from the event. Valid only for + CreateNotify, MapNotify, ReparentNotify, and ConfigureNotify + events. +|%p| + The place field from the event, substituted as one of the strings + PlaceOnTop or PlaceOnBottom. Valid only for CirculateNotify and + CirculateRequest events. +|%s| + The state field from the event. For ButtonPress, ButtonRelease, + EnterNotify, KeyPress, KeyRelease, LeaveNotify, and MotionNotify + events, a decimal string is substituted. For VisibilityNotify, one + of the strings VisibilityUnobscured, VisibilityPartiallyObscured, + and VisibilityFullyObscured is substituted. +|%t| + The time field from the event. Valid only for events that contain + a time field. +|%v| + The value_mask field from the event. Valid only for + ConfigureRequest events. +|%w| + The width field from the event. Valid only for Configure, + ConfigureRequest, Expose, GraphicsExpose, and ResizeRequest events. +|%x| + The x field from the event. Valid only for events containing an x + field. +|%y| + The y field from the event. Valid only for events containing a y + field. +%A + Substitutes the ASCII character corresponding to the event, or the + empty string if the event doesn't correspond to an ASCII character + (e.g. the shift key was pressed). XLookupString does all the work + of translating from the event to an ASCII character. Valid only + for KeyPress and KeyRelease events. +%B + The border_width field from the event. Valid only for + ConfigureNotify and CreateWindow events. +%D + The display field from the event. Valid for all event types. +%E + The send_event field from the event. Valid for all event types. +%K + The keysym corresponding to the event, substituted as a textual + string. Valid only for KeyPress and KeyRelease events. +%N + The keysym corresponding to the event, substituted as a decimal + number. Valid only for KeyPress and KeyRelease events. +%R + The root window identifier from the event. Valid only for events + containing a root field. +%S + The subwindow window identifier from the event. Valid only for + events containing a subwindow field. +%T + The type field from the event. Valid for all event types. +%W + The path name of the window to which the event was reported (the + window field from the event). Valid for all event types. +%X + The x_root field from the event. If a virtual-root window manager + is being used then the substituted value is the corresponding + x-coordinate in the virtual root. Valid only for ButtonPress, + ButtonRelease, KeyPress, KeyRelease, and MotionNotify events. +%Y + The y_root field from the event. If a virtual-root window manager + is being used then the substituted value is the corresponding + y-coordinate in the virtual root. Valid only for ButtonPress, + ButtonRelease, KeyPress, KeyRelease, and MotionNotify events. + + If the replacement string for a %-replacement contains characters +that are interpreted specially by the Tcl parser (such as backslashes or +square brackets or spaces) additional backslashes are added during +replacement so that the result after parsing is the original replacement +string. For example, if command is + + insert %A + + and the character typed is an open square bracket, then the command +actually executed will be + + insert \e[ + + This will cause the insert to receive the original replacement string +(open square bracket) as its first argument. If the extra backslash +hadn't been added, Tcl would not have been able to parse the command +correctly. + + At most one binding will trigger for any given X event. If several +bindings match the recent events, the most specific binding is chosen +and its command will be executed. The following tests are applied, in +order, to determine which of several matching sequences is more +specific: (a) a binding whose windowSpec names a particular window is +more specific than a binding for a class, which is more specific than a +binding whose windowSpec is all; (b) a longer sequence (in terms of +number of events matched) is more specific than a shorter sequence; (c) +an event pattern that specifies a specific button or key is more +specific than one that doesn't; (e) an event pattern that requires a +particular modifier is more specific than one that doesn't require the +modifier; (e) an event pattern specifying the Any modifier is less +specific than one that doesn't. If the matching sequences contain more +than one event, then tests (c)-(e) are applied in order from the most +recent event to the least recent event in the sequences. If these tests +fail to determine a winner, then the most recently registered sequence +is the winner. + + If an X event does not match any of the existing bindings, then the +event is ignored (an unbound event is not considered to be an error). + + When a sequence specified in a bind command contains more than one +event pattern, then its command is executed whenever the recent events +(leading up to and including the current event) match the given +sequence. This means, for example, that if button 1 is clicked +repeatedly the sequence will match each button +press but the first. If extraneous events that would prevent a match +occur in the middle of an event sequence then the extraneous events are +ignored unless they are KeyPress or ButtonPress events. For example, + will match a sequence of presses of button 1, +even though there will be ButtonRelease events (and possibly +MotionNotify events) between the ButtonPress events. Furthermore, a +KeyPress event may be preceded by any number of other KeyPress events +for modifier keys without the modifier keys preventing a match. For +example, the event sequence aB will match a press of the a key, a +release of the a key, a press of the Shift key, and a press of the b +key: the press of Shift is ignored because it is a modifier key. +Finally, if several MotionNotify events occur in a row, only the last +one is used for purposes of matching binding sequences. + + If an error occurs in executing the command for a binding then the +tkerror mechanism is used to report the error. The command will be +executed at global level (outside the context of any Tcl procedure). + + *Note tkerror::. + +Keywords +-------- + +form, manual + + +File: gcl-tk.info, Node: destroy, Next: tk-dialog, Prev: bind, Up: Control + +3.3 destroy +=========== + +destroy \- Destroy one or more windows + +Synopsis +-------- + +destroy ?window window ...? + +Description +----------- + +This command deletes the windows given by the window arguments, plus all +of their descendants. If a window "." is deleted then the entire +application will be destroyed. The windows are destroyed in order, and +if an error occurs in destroying a window the command aborts without +destroying the remaining windows. + +Keywords +-------- + +application, destroy, window + + +File: gcl-tk.info, Node: tk-dialog, Next: exit, Prev: destroy, Up: Control + +3.4 tk-dialog +============= + +tk-dialog \- Create modal dialog and wait for response + +Synopsis +-------- + +tk-dialog window title text bitmap default string string ... + +Description +----------- + +This procedure is part of the Tk script library. Its arguments describe +a dialog box: + +window + Name of top-level window to use for dialog. Any existing window by + this name is destroyed. +title + Text to appear in the window manager's title bar for the dialog. +text + Message to appear in the top portion of the dialog box. +bitmap + If non-empty, specifies a bitmap to display in the top portion of + the dialog, to the left of the text. If this is an empty string + then no bitmap is displayed in the dialog. +default + If this is an integer greater than or equal to zero, then it gives + the index of the button that is to be the default button for the + dialog (0 for the leftmost button, and so on). If less than zero + or an empty string then there won't be any default button. +string + There will be one button for each of these arguments. Each string + specifies text to display in a button, in order from left to right. + + After creating a dialog box, tk-dialog waits for the user to select + one of the buttons either by clicking on the button with the mouse + or by typing return to invoke the default button (if any). Then it + returns the index of the selected button: 0 for the leftmost + button, 1 for the button next to it, and so on. + + While waiting for the user to respond, tk-dialog sets a local grab. + This prevents the user from interacting with the application in any + way except to invoke the dialog box. + +Keywords +-------- + +bitmap, dialog, modal + + +File: gcl-tk.info, Node: exit, Next: focus, Prev: tk-dialog, Up: Control + +3.5 exit +======== + +exit \- Exit the process + +Synopsis +-------- + +exit ?returnCode? + +Description +----------- + +Terminate the process, returning returnCode (an integer) to the system +as the exit status. If returnCode isn't specified then it defaults to +0. This command replaces the Tcl command by the same name. It is +identical to Tcl's exit command except that before exiting it destroys +all the windows managed by the process. This allows various cleanup +operations to be performed, such as removing application names from the +global registry of applications. + +Keywords +-------- + +exit, process + + +File: gcl-tk.info, Node: focus, Next: grab, Prev: exit, Up: Control + +3.6 focus +========= + +focus \- Direct keyboard events to a particular window + +Synopsis +-------- + + +focus + +focus window +focus option ?arg arg ...? + +Description +----------- + +The focus command is used to manage the Tk input focus. At any given +time, one window in an application is designated as the focus window for +that application; any key press or key release events directed to any +window in the application will be redirected instead to the focus +window. If there is no focus window for an application then keyboard +events are discarded. Typically, windows that are prepared to deal with +the focus (e.g. entries and other widgets that display editable text) +will claim the focus when mouse button 1 is pressed in them. When an +application is created its main window is initially given the focus. + + The focus command can take any of the following forms: + +focus + If invoked with no arguments, focus returns the path name of the + current focus window, or none if there is no focus window. +focus window + If invoked with a single argument consisting of a window's path + name, focus sets the input focus to that window. The return value + is an empty string. +focus :default ?window? + If window is specified, it becomes the default focus window (the + window that receives the focus whenever the focus window is + deleted) and the command returns an empty string. If window isn't + specified, the command returns the path name of the current default + focus window, or none if there is no default. Window may be + specified as none to clear its existing value. The default window + is initially none. +focus :none + Clears the focus window, so that keyboard input to this application + will be discarded. + +"Focus Events" +-------------- + +Tk's model of the input focus is different than X's model, and the focus +window set with the focus command is not usually the same as the X focus +window. Tk never explicitly changes the official X focus window. It +waits for the window manager to direct the X input focus to and from the +application's top-level windows, and it intercepts FocusIn and FocusOut +events coming from the X server to detect these changes. All of the +focus events received from X are discarded by Tk; they never reach the +application. Instead, Tk generates a different stream of FocusIn and +FocusOut for the application. This means that FocusIn and and FocusOut +events seen by the application will not obey the conventions described +in the documentation for Xlib. + + Tk applications receive two kinds of FocusIn and FocusOut events, +which can be distinguished by their detail fields. Events with a detail +of NotifyAncestor are directed to the current focus window when it +becomes active or inactive. A window is the active focus whenever two +conditions are simultaneously true: (a) the window is the focus window +for its application, and (b) some top-level window in the application +has received the X focus. When this happens Tk generates a FocusIn +event for the focus window with detail NotifyAncestor. When a window +loses the active focus (either because the window manager removed the +focus from the application or because the focus window changed within +the application) then it receives a FocusOut event with detail +NotifyAncestor. + + The events described above are directed to the application's focus +window regardless of which top-level window within the application has +received the focus. The second kind of focus event is provided for +applications that need to know which particular top-level window has the +X focus. Tk generates FocusIn and FocusOut events with detail +NotifyVirtual for top-level windows whenever they receive or lose the X +focus. These events are generated regardless of which window in the +application has the Tk input focus. They do not imply that keystrokes +will be directed to the window that receives the event; they simply +indicate which top-level window is active as far as the window manager +is concerned. If a top-level window is also the application's focus +window, then it will receive both NotifyVirtual and NotifyAncestor +events when it receives or loses the X focus. + + Tk does not generate the hierarchical chains of FocusIn and FocusOut +events described in the Xlib documentation (e.g. a window can get a +FocusIn or FocusOut event without all of its ancestors getting events +too). Furthermore, the mode field in focus events is always +NotifyNormal and the only values ever present in the detail field are +NotifyAncestor and NotifyVirtual. + +Keywords +-------- + +events, focus, keyboard, top-level, window manager + + +File: gcl-tk.info, Node: grab, Next: tk-listbox-single-select, Prev: focus, Up: Control + +3.7 grab +======== + +grab \- Confine pointer and keyboard events to a window sub-tree + +Synopsis +-------- + + +grab ?:global? window +grab option ?arg arg ...? + +Description +----------- + +This command implements simple pointer and keyboard grabs for Tk. Tk's +grabs are different than the grabs described in the Xlib documentation. +When a grab is set for a particular window, Tk restricts all pointer +events to the grab window and its descendants in Tk's window hierarchy. +Whenever the pointer is within the grab window's subtree, the pointer +will behave exactly the same as if there had been no grab at all and all +events will be reported in the normal fashion. When the pointer is +outside window's tree, button presses and releases and mouse motion +events are reported to window, and window entry and window exit events +are ignored. The grab subtree "owns" the pointer: windows outside the +grab subtree will be visible on the screen but they will be insensitive +until the grab is released. The tree of windows underneath the grab +window can include top-level windows, in which case all of those +top-level windows and their descendants will continue to receive mouse +events during the grab. + + Two forms of grabs are possible: local and global. A local grab +affects only the grabbing application: events will be reported to other +applications as if the grab had never occurred. Grabs are local by +default. A global grab locks out all applications on the screen, so +that only the given subtree of the grabbing application will be +sensitive to pointer events (mouse button presses, mouse button +releases, pointer motions, window entries, and window exits). During +global grabs the window manager will not receive pointer events either. + + During local grabs, keyboard events (key presses and key releases) +are delivered as usual: the window manager controls which application +receives keyboard events, and if they are sent to any window in the +grabbing application then they are redirected to the focus window. +During a global grab Tk grabs the keyboard so that all keyboard events +are always sent to the grabbing application. The focus command is still +used to determine which window in the application receives the keyboard +events. The keyboard grab is released when the grab is released. + + Grabs apply to particular displays. If an application has windows on +multiple displays then it can establish a separate grab on each display. +The grab on a particular display affects only the windows on that +display. It is possible for different applications on a single display +to have simultaneous local grabs, but only one application can have a +global grab on a given display at once. + + The grab command can take any of the following forms: + +grab ?:global? window + Same as grab :set, described below. +grab :current ?window? + If window is specified, returns the name of the current grab window + in this application for window's display, or an empty string if + there is no such window. If window is omitted, the command returns + a list whose elements are all of the windows grabbed by this + application for all displays, or an empty string if the application + has no grabs. +grab :release window + Releases the grab on window if there is one, otherwise does + nothing. Returns an empty string. +grab :set ?:global? window + Sets a grab on window. If :global is specified then the grab is + global, otherwise it is local. If a grab was already in effect for + this application on window's display then it is automatically + released. If there is already a grab on window and it has the same + global/local form as the requested grab, then the command does + nothing. Returns an empty string. +grab :status window + Returns none if no grab is currently set on window, local if a + local grab is set on window, and global if a global grab is set. + +Bugs +---- + +It took an incredibly complex and gross implementation to produce the +simple grab effect described above. Given the current implementation, +it isn't safe for applications to use the Xlib grab facilities at all +except through the Tk grab procedures. If applications try to +manipulate X's grab mechanisms directly, things will probably break. + + If a single process is managing several different Tk applications, +only one of those applications can have a local grab for a given display +at any given time. If the applications are in different processes, this +restriction doesn't exist. + +Keywords +-------- + +grab, keyboard events, pointer events, window + + +File: gcl-tk.info, Node: tk-listbox-single-select, Next: lower, Prev: grab, Up: Control + +3.8 tk-listbox-single-select +============================ + +tk-listbox-single-select \- Allow only one selected element in +listbox(es) + +Synopsis +-------- + +tk-listbox-single-select arg ?arg arg ...? + +Description +----------- + +This command is a Tcl procedure provided as part of the Tk script +library. It takes as arguments the path names of one or more listbox +widgets, or the value Listbox. For each named widget, +tk-listbox-single-select modifies the bindings of the widget so that +only a single element may be selected at a time (the normal +configuration allows multiple elements to be selected). If the keyword +Listbox is among the window arguments, then the class bindings for +listboxes are changed so that all listboxes have the +one-selection-at-a-time behavior. + +Keywords +-------- + +listbox, selection + + +File: gcl-tk.info, Node: lower, Next: tk-menu-bar, Prev: tk-listbox-single-select, Up: Control + +3.9 lower +========= + +lower \- Change a window's position in the stacking order + +Synopsis +-------- + +lower window ?belowThis? + +Description +----------- + +If the belowThis argument is omitted then the command lowers window so +that it is below all of its siblings in the stacking order (it will be +obscured by any siblings that overlap it and will not obscure any +siblings). If belowThis is specified then it must be the path name of a +window that is either a sibling of window or the descendant of a sibling +of window. In this case the lower command will insert window into the +stacking order just below belowThis (or the ancestor of belowThis that +is a sibling of window); this could end up either raising or lowering +window. + +Keywords +-------- + +lower, obscure, stacking order + + +File: gcl-tk.info, Node: tk-menu-bar, Next: option, Prev: lower, Up: Control + +3.10 tk-menu-bar +================ + +tk-menu-bar, tk_bindForTraversal \- Support for menu bars + +Synopsis +-------- + +tk-menu-bar frame ?menu menu ...? + + tk_bindForTraversal arg arg ... + +Description +----------- + +These two commands are Tcl procedures in the Tk script library. They +provide support for menu bars. A menu bar is a frame that contains a +collection of menu buttons that work together, so that the user can scan +from one menu to another with the mouse: if the mouse button is pressed +over one menubutton (causing it to post its menu) and the mouse is moved +over another menubutton in the same menu bar without releasing the mouse +button, then the menu of the first menubutton is unposted and the menu +of the new menubutton is posted instead. Menus in a menu bar can also +be accessed using keyboard traversal (i.e. by typing keystrokes instead +of using the mouse). In order for an application to use these +procedures, it must do three things, which are described in the +paragraphs below. + + First, each application must call tk-menu-bar to provide information +about the menubar. The frame argument gives the path name of the frame +that contains all of the menu buttons, and the menu arguments give path +names for all of the menu buttons associated with the menu bar. +Normally frame is the parent of each of the menu's. This need not be +the case, but frame must be an ancestor of each of the menu's in order +for grabs to work correctly when the mouse is used to pull down menus. +The order of the menu arguments determines the traversal order for the +menu buttons. If tk-menu-bar is called without any menu arguments, it +returns a list containing the current menu buttons for frame, or an +empty string if frame isn't currently set up as a menu bar. If +tk-menu-bar is called with a single menu argument consisting of an empty +string, any menubar information for frame is removed; from now on the +menu buttons will function independently without keyboard traversal. +Only one menu bar may be defined at a time within each top-level window. + + The second thing an application must do is to identify the traversal +characters for menu buttons and menu entries. This is done by +underlining those characters using the :underline options for the +widgets. The menu traversal system uses this information to traverse +the menus under keyboard control (see below). + + The third thing that an application must do is to make sure that the +input focus is always in a window that has been configured to support +menu traversal. If the input focus is none then input characters will +be discarded and no menu traversal will be possible. If you have no +other place to set the focus, set it to the menubar widget: tk-menu-bar +creates bindings for its frame argument to support menu traversal. + + The Tk startup scripts configure all the Tk widget classes with +bindings to support menu traversal, so menu traversal will be possible +regardless of which widget has the focus. If your application defines +new classes of widgets that support the input focus, then you should +call tk_bindForTraversal for each of these classes. Tk_bindForTraversal +takes any number of arguments, each of which is a widget path name or +widget class name. It sets up bindings for all the named widgets and +classes so that the menu traversal system will be invoked when +appropriate keystrokes are typed in those widgets or classes. + +"Menu Traversal Bindings" +------------------------- + +Once an application has made the three arrangements described above, +menu traversal will be available. At any given time, the only menus +available for traversal are those associated with the top-level window +containing the input focus. Menu traversal is initiated by one of the +following actions: + [1] If is typed, then the first menu button in the list for + the top-level window is posted and the first entry within that menu + is selected. + [2] If is pressed, then the menu button that has key as + its underlined character is posted and the first entry within that + menu is selected. The comparison between key and the underlined + characters ignores case differences. If no menu button matches key + then the keystroke has no effect. + [3] Clicking mouse button 1 on a menu button posts that menu and + selects its first entry. + + Once a menu has been posted, the input focus is switched to that menu +and the following actions are possible: + [1] Typing or clicking mouse button 1 outside the menu button + or its menu will abort the menu traversal. + [2] If is pressed, then the entry in the posted menu + whose underlined character is key is invoked. This causes the menu + to be unposted, the entry's action to be taken, and the menu + traversal to end. The comparison between key and underlined + characters ignores case differences. If no menu entry matches key + then the keystroke is ignored. + [3] The arrow keys may be used to move among entries and menus. + The left and right arrow keys move circularly among the available + menus and the up and down arrow keys move circularly among the + entries in the current menu. + [4] If is pressed, the selected entry in the posted menu + is invoked, which causes the menu to be unposted, the entry's + action to be taken, and the menu traversal to end. + + When a menu traversal completes, the input focus reverts to the +window that contained it when the traversal started. + +Keywords +-------- + +keyboard traversal, menu, menu bar, post + + +File: gcl-tk.info, Node: option, Next: options, Prev: tk-menu-bar, Up: Control + +3.11 option +=========== + +option \- Add/retrieve window options to/from the option database + +Synopsis +-------- + +option :add pattern value ?priority? + + option :clear + + option :get window name class + + option :readfile fileName ?priority? + +Description +----------- + +The option command allows you to add entries to the Tk option database +or to retrieve options from the database. The add form of the command +adds a new option to the database. Pattern contains the option being +specified, and consists of names and/or classes separated by asterisks +or dots, in the usual X format. Value contains a text string to +associate with pattern; this is the value that will be returned in calls +to Tk_GetOption or by invocations of the option :get command. If +priority is specified, it indicates the priority level for this option +(see below for legal values); it defaults to interactive. This command +always returns an empty string. + + The option :clear command clears the option database. Default +options (in the RESOURCE_MANAGER property or the .Xdefaults file) will +be reloaded automatically the next time an option is added to the +database or removed from it. This command always returns an empty +string. + + The option :get command returns the value of the option specified for +window under name and class. If several entries in the option database +match window, name, and class, then the command returns whichever was +created with highest priority level. If there are several matching +entries at the same priority level, then it returns whichever entry was +most recently entered into the option database. If there are no +matching entries, then the empty string is returned. + + The readfile form of the command reads fileName, which should have +the standard format for an X resource database such as .Xdefaults, and +adds all the options specified in that file to the option database. If +priority is specified, it indicates the priority level at which to enter +the options; priority defaults to interactive. + + The priority arguments to the option command are normally specified +symbolically using one of the following values: + +widgetDefault + Level 20. Used for default values hard-coded into widgets. +startupFile + Level 40. Used for options specified in application-specific + startup files. +userDefault + Level 60. Used for options specified in user-specific defaults + files, such as .Xdefaults, resource databases loaded into the X + server, or user-specific startup files. +interactive + Level 80. Used for options specified interactively after the + application starts running. If priority isn't specified, it + defaults to this level. + + Any of the above keywords may be abbreviated. In addition, +priorities may be specified numerically using integers between 0 and +100, inclusive. The numeric form is probably a bad idea except for new +priority levels other than the ones given above. + +Keywords +-------- + +database, option, priority, retrieve + + +File: gcl-tk.info, Node: options, Next: pack-old, Prev: option, Up: Control + +3.12 options +============ + +options \- Standard options supported by widgets + +Description +----------- + +This manual entry describes the common configuration options supported +by widgets in the Tk toolkit. Every widget does not necessarily support +every option (see the manual entries for individual widgets for a list +of the standard options supported by that widget), but if a widget does +support an option with one of the names listed below, then the option +has exactly the effect described below. + + In the descriptions below, "Name" refers to the option's name in the +option database (e.g. in .Xdefaults files). "Class" refers to the +option's class value in the option database. "Command-Line Switch" +refers to the switch used in widget-creation and configure widget +commands to set this value. For example, if an option's command-line +switch is :foreground and there exists a widget .a.b.c, then the command + + + (.a.b.c :configure :foreground "black") + + may be used to specify the value black for the option in the the +widget .a.b.c. Command-line switches may be abbreviated, as long as the +abbreviation is unambiguous. + +':activebackground' + Name='"activeBackground" Class="Foreground"' + + Specifies background color to use when drawing active elements. An + element (a widget or portion of a widget) is active if the mouse + cursor is positioned over the element and pressing a mouse button + will cause some action to occur. + +':activeborderwidth' + Name='"activeBorderWidth" Class="BorderWidth"' + + Specifies a non-negative value indicating the width of the 3-D + border drawn around active elements. See above for definition of + active elements. The value may have any of the forms acceptable to + Tk_GetPixels. This option is typically only available in widgets + displaying more than one element at a time (e.g. menus but not + buttons). + +':activeforeground' + Name='"activeForeground" Class="Background"' + + Specifies foreground color to use when drawing active elements. + See above for definition of active elements. + +':anchor' + Name='"anchor" Class="Anchor"' + + Specifies how the information in a widget (e.g. text or a bitmap) + is to be displayed in the widget. Must be one of the values n, ne, + e, se, s, sw, w, nw, or center. For example, nw means display the + information such that its top-left corner is at the top-left corner + of the widget. + +':background or :bg' + Name='"background" Class="Background"' + + Specifies the normal background color to use when displaying the + widget. + +':bitmap' + Name='"bitmap" Class="Bitmap"' + + Specifies a bitmap to display in the widget, in any of the forms + acceptable to Tk_GetBitmap. The exact way in which the bitmap is + displayed may be affected by other options such as anchor or + justify. Typically, if this option is specified then it overrides + other options that specify a textual value to display in the + widget; the bitmap option may be reset to an empty string to + re-enable a text display. + +':borderwidth or :bd' + Name='"borderWidth" Class="BorderWidth"' + + Specifies a non-negative value indicating the width of the 3-D + border to draw around the outside of the widget (if such a border + is being drawn; the relief option typically determines this). The + value may also be used when drawing 3-D effects in the interior of + the widget. The value may have any of the forms acceptable to + Tk_GetPixels. + +':cursor' + Name='"cursor" Class="Cursor"' + + Specifies the mouse cursor to be used for the widget. The value + may have any of the forms acceptable to Tk_GetCursor. + +':cursorbackground' + Name='"cursorBackground" Class="Foreground"' + + Specifies the color to use as background in the area covered by the + insertion cursor. This color will normally override either the + normal background for the widget (or the selection background if + the insertion cursor happens to fall in the selection). \fIThis + option is obsolete and is gradually being replaced by the + insertBackground option. + +':cursorborderwidth' + Name='"cursorBorderWidth" Class="BorderWidth"' + + Specifies a non-negative value indicating the width of the 3-D + border to draw around the insertion cursor. The value may have any + of the forms acceptable to Tk_GetPixels. \fIThis option is + obsolete and is gradually being replaced by the insertBorderWidth + option. + +':cursorofftime' + Name='"cursorOffTime" Class="OffTime"' + + Specifies a non-negative integer value indicating the number of + milliseconds the cursor should remain "off" in each blink cycle. + If this option is zero then the cursor doesn't blink: it is on all + the time. \fIThis option is obsolete and is gradually being + replaced by the insertOffTime option. + +':cursorontime' + Name='"cursorOnTime" Class="OnTime"' + + Specifies a non-negative integer value indicating the number of + milliseconds the cursor should remain "on" in each blink cycle. + \fIThis option is obsolete and is gradually being replaced by the + insertOnTime option. + +':cursorwidth' + Name='"cursorWidth" Class="CursorWidth"' + + Specifies a value indicating the total width of the insertion + cursor. The value may have any of the forms acceptable to + Tk_GetPixels. If a border has been specified for the cursor (using + the cursorBorderWidth option), the border will be drawn inside the + width specified by the cursorWidth option. \fIThis option is + obsolete and is gradually being replaced by the insertWidth option. + +':disabledforeground' + Name='"disabledForeground" Class="DisabledForeground"' + + Specifies foreground color to use when drawing a disabled element. + If the option is specified as an empty string (which is typically + the case on monochrome displays), disabled elements are drawn with + the normal fooreground color but they are dimmed by drawing them + with a stippled fill pattern. + +':exportselection' + Name='"exportSelection" Class="ExportSelection"' + + Specifies whether or not a selection in the widget should also be + the X selection. The value may have any of the forms accepted by + Tcl_GetBoolean, such as true, false, 0, 1, yes, or no. If the + selection is exported, then selecting in the widget deselects the + current X selection, selecting outside the widget deselects any + widget selection, and the widget will respond to selection + retrieval requests when it has a selection. The default is usually + for widgets to export selections. + +':font' + Name='"font" Class="Font"' + + Specifies the font to use when drawing text inside the widget. + +':foreground or :fg' + Name='"foreground" Class="Foreground"' + + Specifies the normal foreground color to use when displaying the + widget. + +':geometry' + Name='"geometry" Class="Geometry"' + + Specifies the desired geometry for the widget's window, in the form + widthxheight, where width is the desired width of the window and + height is the desired height. The units for width and height + depend on the particular widget. For widgets displaying text the + units are usually the size of the characters in the font being + displayed; for other widgets the units are usually pixels. + +':insertbackground' + Name='"insertBackground" Class="Foreground"' + + Specifies the color to use as background in the area covered by the + insertion cursor. This color will normally override either the + normal background for the widget (or the selection background if + the insertion cursor happens to fall in the selection). + +':insertborderwidth' + Name='"insertBorderWidth" Class="BorderWidth"' + + Specifies a non-negative value indicating the width of the 3-D + border to draw around the insertion cursor. The value may have any + of the forms acceptable to Tk_GetPixels. + +':insertofftime' + Name='"insertOffTime" Class="OffTime"' + + Specifies a non-negative integer value indicating the number of + milliseconds the insertion cursor should remain "off" in each blink + cycle. If this option is zero then the cursor doesn't blink: it is + on all the time. + +':insertontime' + Name='"insertOnTime" Class="OnTime"' + + Specifies a non-negative integer value indicating the number of + milliseconds the insertion cursor should remain "on" in each blink + cycle. + +':insertwidth' + Name='"insertWidth" Class="InsertWidth"' + + Specifies a value indicating the total width of the insertion + cursor. The value may have any of the forms acceptable to + Tk_GetPixels. If a border has been specified for the insertion + cursor (using the insertBorderWidth option), the border will be + drawn inside the width specified by the insertWidth option. + +':orient' + Name='"orient" Class="Orient"' + + For widgets that can lay themselves out with either a horizontal or + vertical orientation, such as scrollbars, this option specifies + which orientation should be used. Must be either horizontal or + vertical or an abbreviation of one of these. + +':padx' + Name='"padX" Class="Pad"' + + Specifies a non-negative value indicating how much extra space to + request for the widget in the X-direction. The value may have any + of the forms acceptable to Tk_GetPixels. When computing how large + a window it needs, the widget will add this amount to the width it + would normally need (as determined by the width of the things + displayed in the widget); if the geometry manager can satisfy this + request, the widget will end up with extra internal space to the + left and/or right of what it displays inside. + +':pady' + Name='"padY" Class="Pad"' + + Specifies a non-negative value indicating how much extra space to + request for the widget in the Y-direction. The value may have any + of the forms acceptable to Tk_GetPixels. When computing how large + a window it needs, the widget will add this amount to the height it + would normally need (as determined by the height of the things + displayed in the widget); if the geometry manager can satisfy this + request, the widget will end up with extra internal space above + and/or below what it displays inside. + +':relief' + Name='"relief" Class="Relief"' + + Specifies the 3-D effect desired for the widget. Acceptable values + are raised, sunken, flat, ridge, and groove. The value indicates + how the interior of the widget should appear relative to its + exterior; for example, raised means the interior of the widget + should appear to protrude from the screen, relative to the exterior + of the widget. + +':repeatdelay' + Name='"repeatDelay" Class="RepeatDelay"' + + Specifies the number of milliseconds a button or key must be held + down before it begins to auto-repeat. Used, for example, on the + up- and down-arrows in scrollbars. + +':repeatinterval' + Name='"repeatInterval" Class="RepeatInterval"' + + Used in conjunction with repeatDelay: once auto-repeat begins, this + option determines the number of milliseconds between auto-repeats. + +':scrollcommand' + Name='"scrollCommand" Class="ScrollCommand"' + + Specifies the prefix for a command used to communicate with + scrollbar widgets. When the view in the widget's window changes + (or whenever anything else occurs that could change the display in + a scrollbar, such as a change in the total size of the widget's + contents), the widget will generate a Tcl command by concatenating + the scroll command and four numbers. The four numbers are, in + order: the total size of the widget's contents, in unspecified + units ("unit" is a widget-specific term; for widgets displaying + text, the unit is a line); the maximum number of units that may be + displayed at once in the widget's window, given its current size; + the index of the top-most or left-most unit currently visible in + the window (index 0 corresponds to the first unit); and the index + of the bottom-most or right-most unit currently visible in the + window. This command is then passed to the Tcl interpreter for + execution. Typically the scrollCommand option consists of the path + name of a scrollbar widget followed by "set", e.g. ".x.scrollbar + set": this will cause the scrollbar to be updated whenever the view + in the window changes. If this option is not specified, then no + command will be executed. + + The scrollCommand option is used for widgets that support scrolling + in only one direction. For widgets that support scrolling in both + directions, this option is replaced with the xScrollCommand and + yScrollCommand options. + +':selectbackground' + Name='"selectBackground" Class="Foreground"' + + Specifies the background color to use when displaying selected + items. + +':selectborderwidth' + Name='"selectBorderWidth" Class="BorderWidth"' + + Specifies a non-negative value indicating the width of the 3-D + border to draw around selected items. The value may have any of + the forms acceptable to Tk_GetPixels. + +':selectforeground' + Name='"selectForeground" Class="Background"' + + Specifies the foreground color to use when displaying selected + items. + +':setgrid' + Name='"setGrid" Class="SetGrid"' + + Specifies a boolean value that determines whether this widget + controls the resizing grid for its top-level window. This option + is typically used in text widgets, where the information in the + widget has a natural size (the size of a character) and it makes + sense for the window's dimensions to be integral numbers of these + units. These natural window sizes form a grid. If the setGrid + option is set to true then the widget will communicate with the + window manager so that when the user interactively resizes the + top-level window that contains the widget, the dimensions of the + window will be displayed to the user in grid units and the window + size will be constrained to integral numbers of grid units. See + the section GRIDDED GEOMETRY MANAGEMENT in the wm manual entry for + more details. + +':text' + Name='"text" Class="Text"' + + Specifies a string to be displayed inside the widget. The way in + which the string is displayed depends on the particular widget and + may be determined by other options, such as anchor or justify. + +':textvariable' + Name='"textVariable" Class="Variable"' + + Specifies the name of a variable. The value of the variable is a + text string to be displayed inside the widget; if the variable + value changes then the widget will automatically update itself to + reflect the new value. The way in which the string is displayed in + the widget depends on the particular widget and may be determined + by other options, such as anchor or justify. + +':underline' + Name='"underline" Class="Underline"' + + Specifies the integer index of a character to underline in the + widget. This option is typically used to indicate keyboard + traversal characters in menu buttons and menu entries. 0 + corresponds to the first character of the text displayed in the + widget, 1 to the next character, and so on. + +':xscrollcommand' + Name='"xScrollCommand" Class="ScrollCommand"' + + Specifies the prefix for a command used to communicate with + horizontal scrollbars. This option is treated in the same way as + the scrollCommand option, except that it is used for horizontal + scrollbars associated with widgets that support both horizontal and + vertical scrolling. See the description of scrollCommand for + complete details on how this option is used. + +':yscrollcommand' + Name='"yScrollCommand" Class="ScrollCommand"' + + Specifies the prefix for a command used to communicate with + vertical scrollbars. This option is treated in the same way as the + scrollCommand option, except that it is used for vertical + scrollbars associated with widgets that support both horizontal and + vertical scrolling. See the description of scrollCommand for + complete details on how this option is used. + +Keywords +-------- + +class, name, standard option, switch + + +File: gcl-tk.info, Node: pack-old, Next: pack, Prev: options, Up: Control + +3.13 pack-old +============= + +pack \- Obsolete syntax for packer geometry manager + +Synopsis +-------- + +pack after sibling window options ?window options ...? + + pack append parent window options ?window options ...? + + pack before sibling window options ?window options ...? + + pack info parent + + pack unpack window + +Description +----------- + +Note: this manual entry describes the syntax for the pack\fI command as +it before Tk version 3.3. Although this syntax continues to be +supported for backward compatibility, it is obsolete and should not be +used anymore. At some point in the future it may cease to be supported. + + The packer is a geometry manager that arranges the children of a +parent by packing them in order around the edges of the parent. The +first child is placed against one side of the window, occupying the +entire span of the window along that side. This reduces the space +remaining for other children as if the side had been moved in by the +size of the first child. Then the next child is placed against one side +of the remaining cavity, and so on until all children have been placed +or there is no space left in the cavity. + + The before, after, and append forms of the pack command are used to +insert one or more children into the packing order for their parent. +The before form inserts the children before window sibling in the order; +all of the other windows must be siblings of sibling. The after form +inserts the windows after sibling, and the append form appends one or +more windows to the end of the packing order for parent. If a window +named in any of these commands is already packed in its parent, it is +removed from its current position in the packing order and repositioned +as indicated by the command. All of these commands return an empty +string as result. + + The unpack form of the pack command removes window from the packing +order of its parent and unmaps it. After the execution of this command +the packer will no longer manage window's geometry. + + The placement of each child is actually a four-step process; the +options argument following each window consists of a list of one or more +fields that govern the placement of that window. In the discussion +below, the term cavity refers to the space left in a parent when a +particular child is placed (i.e. all the space that wasn't claimed by +earlier children in the packing order). The term parcel refers to the +space allocated to a particular child; this is not necessarily the same +as the child window's final geometry. + + The first step in placing a child is to determine which side of the +cavity it will lie against. Any one of the following options may be +used to specify a side: + +top + Position the child's parcel against the top of the cavity, + occupying the full width of the cavity. +bottom + Position the child's parcel against the bottom of the cavity, + occupying the full width of the cavity. +left + Position the child's parcel against the left side of the cavity, + occupying the full height of the cavity. +right + Position the child's parcel against the right side of the cavity, + occupying the full height of the cavity. + + At most one of these options should be specified for any given +window. If no side is specified, then the default is top. + + The second step is to decide on a parcel for the child. For top and +bottom windows, the desired parcel width is normally the cavity width +and the desired parcel height is the window's requested height, as +passed to Tk_GeometryRequest. For left and right windows, the desired +parcel height is normally the cavity height and the desired width is the +window's requested width. However, extra space may be requested for the +window using any of the following options: + +padx num + Add num pixels to the window's requested width before computing the + parcel size as described above. +pady num + Add num pixels to the window's requested height before computing + the parcel size as described above. +expand + This option requests that the window's parcel absorb any extra + space left over in the parent's cavity after packing all the + children. The amount of space left over depends on the sizes + requested by the other children, and may be zero. If several + windows have all specified expand then the extra width will be + divided equally among all the left and right windows that specified + expand and the extra height will be divided equally among all the + top and bottom windows that specified expand. + + If the desired width or height for a parcel is larger than the +corresponding dimension of the cavity, then the cavity's dimension is +used instead. + + The third step in placing the window is to decide on the window's +width and height. The default is for the window to receive either its +requested width and height or the those of the parcel, whichever is +smaller. If the parcel is larger than the window's requested size, then +the following options may be used to expand the window to partially or +completely fill the parcel: + +fill + Set the window's size to equal the parcel size. +fillx + Increase the window's width to equal the parcel's width, but retain + the window's requested height. +filly + Increase the window's height to equal the parcel's height, but + retain the window's requested width. + + The last step is to decide the window's location within its parcel. + If the window's size equals the parcel's size, then the window + simply fills the entire parcel. If the parcel is larger than the + window, then one of the following options may be used to specify + where the window should be positioned within its parcel: +frame center + Center the window in its parcel. This is the default if no framing + option is specified. +frame n + Position the window with its top edge centered on the top edge of + the parcel. +frame ne + Position the window with its upper-right corner at the upper-right + corner of the parcel. +frame e + Position the window with its right edge centered on the right edge + of the parcel. +frame se + Position the window with its lower-right corner at the lower-right + corner of the parcel. +frame s + Position the window with its bottom edge centered on the bottom + edge of the parcel. +frame sw + Position the window with its lower-left corner at the lower-left + corner of the parcel. +frame w + Position the window with its left edge centered on the left edge of + the parcel. +frame nw + Position the window with its upper-left corner at the upper-left + corner of the parcel. + + The pack info command may be used to retrieve information about the + packing order for a parent. It returns a list in the form + + window options window options ... + + Each window is a name of a window packed in parent, and the + following options describes all of the options for that window, + just as they would be typed to pack append. The order of the list + is the same as the packing order for parent. + + The packer manages the mapped/unmapped state of all the packed + children windows. It automatically maps the windows when it packs + them, and it unmaps any windows for which there was no space left + in the cavity. + + The packer makes geometry requests on behalf of the parent windows + it manages. For each parent window it requests a size large enough + to accommodate all the options specified by all the packed + children, such that zero space would be leftover for expand + options. + +Keywords +-------- + +geometry manager, location, packer, parcel, size + + +File: gcl-tk.info, Node: pack, Next: place, Prev: pack-old, Up: Control + +3.14 pack +========= + +pack \- Geometry manager that packs around edges of cavity + +Synopsis +-------- + +pack option arg ?arg ...? + +Description +----------- + +The pack command is used to communicate with the packer, a geometry +manager that arranges the children of a parent by packing them in order +around the edges of the parent. The pack command can have any of +several forms, depending on the option argument: + +pack slave ?slave ...? ?options? + If the first argument to pack is a window name (any value starting + with "."), then the command is processed in the same way as pack + configure. +pack configure slave ?slave ...? ?options? + The arguments consist of the names of one or more slave windows + followed by pairs of arguments that specify how to manage the + slaves. See "THE PACKER ALGORITHM" below for details on how the + options are used by the packer. The following options are + supported: +:after other + Other must the name of another window. Use its master as the + master for the slaves, and insert the slaves just after other in + the packing order. +:anchor anchor + Anchor must be a valid anchor position such as n or sw; it + specifies where to position each slave in its parcel. Defaults to + center. +:before other + Other must the name of another window. Use its master as the + master for the slaves, and insert the slaves just before other in + the packing order. +:expand boolean + Specifies whether the slaves should be expanded to consume extra + space in their master. Boolean may have any proper boolean value, + such as 1 or no. Defaults to 0. +:fill style + If a slave's parcel is larger than its requested dimensions, this + option may be used to stretch the slave. Style must have one of + the following values: + none + Give the slave its requested dimensions plus any internal + padding requested with :ipadx or :ipady. This is the default. + x + Stretch the slave horizontally to fill the entire width of its + parcel (except leave external padding as specified by :padx). + y + Stretch the slave vertically to fill the entire height of its + parcel (except leave external padding as specified by :pady). + both + Stretch the slave both horizontally and vertically. +:in other + Insert the slave(s) at the end of the packing order for the master + window given by other. +:ipadx amount + Amount specifies how much horizontal internal padding to leave on + each side of the slave(s). Amount must be a valid screen distance, + such as 2 or .5c. It defaults to 0. +:ipady amount + Amount specifies how much vertical internal padding to leave on + each side of the slave(s). Amount defaults to 0. +:padx amount + Amount specifies how much horizontal external padding to leave on + each side of the slave(s). Amount defaults to 0. +:pady amount + Amount specifies how much vertical external padding to leave on + each side of the slave(s). Amount defaults to 0. +:side side + Specifies which side of the master the slave(s) will be packed + against. Must be left, right, top, or bottom. Defaults to top. + + If no :in, :after or :before option is specified then each of the +slaves will be inserted at the end of the packing list for its parent +unless it is already managed by the packer (in which case it will be +left where it is). If one of these options is specified then all the +slaves will be inserted at the specified point. If any of the slaves +are already managed by the geometry manager then any unspecified options +for them retain their previous values rather than receiving default +values. .RE + +pack :forget slave ?slave ...? + Removes each of the slaves from the packing order for its master + and unmaps their windows. The slaves will no longer be managed by + the packer. +pack :newinfo slave + Returns a list whose elements are the current configuration state + of the slave given by slave in the same option-value form that + might be specified to pack configure. The first two elements of + the list are ":in master" where master is the slave's master. + Starting with Tk 4.0 this option will be renamed "pack info". +pack :propagate master ?boolean? + If boolean has a true boolean value such as 1 or on then + propagation is enabled for master, which must be a window name (see + "GEOMETRY PROPAGATION" below). If boolean has a false boolean + value then propagation is disabled for master. In either of these + cases an empty string is returned. If boolean is omitted then the + command returns 0 or 1 to indicate whether propagation is currently + enabled for master. Propagation is enabled by default. +pack :slaves master + Returns a list of all of the slaves in the packing order for + master. The order of the slaves in the list is the same as their + order in the packing order. If master has no slaves then an empty + string is returned. + +"The Packer Algorithm" +---------------------- + +For each master the packer maintains an ordered list of slaves called +the packing list. The :in, :after, and :before configuration options +are used to specify the master for each slave and the slave's position +in the packing list. If none of these options is given for a slave then +the slave is added to the end of the packing list for its parent. + + The packer arranges the slaves for a master by scanning the packing +list in order. At the time it processes each slave, a rectangular area +within the master is still unallocated. This area is called the cavity; +for the first slave it is the entire area of the master. + + For each slave the packer carries out the following steps: + [1] The packer allocates a rectangular parcel for the slave along + the side of the cavity given by the slave's :side option. If the + side is top or bottom then the width of the parcel is the width of + the cavity and its height is the requested height of the slave plus + the :ipady and :pady options. For the left or right side the + height of the parcel is the height of the cavity and the width is + the requested width of the slave plus the :ipadx and :padx options. + The parcel may be enlarged further because of the :expand option + (see "EXPANSION" below) + [2] The packer chooses the dimensions of the slave. The width will + normally be the slave's requested width plus twice its :ipadx + option and the height will normally be the slave's requested height + plus twice its :ipady option. However, if the :fill option is x or + both then the width of the slave is expanded to fill the width of + the parcel, minus twice the :padx option. If the :fill option is y + or both then the height of the slave is expanded to fill the width + of the parcel, minus twice the :pady option. + [3] The packer positions the slave over its parcel. If the slave + is smaller than the parcel then the :anchor option determines where + in the parcel the slave will be placed. If :padx or :pady is + non-zero, then the given amount of external padding will always be + left between the slave and the edges of the parcel. + + Once a given slave has been packed, the area of its parcel is +subtracted from the cavity, leaving a smaller rectangular cavity for the +next slave. If a slave doesn't use all of its parcel, the unused space +in the parcel will not be used by subsequent slaves. If the cavity +should become too small to meet the needs of a slave then the slave will +be given whatever space is left in the cavity. If the cavity shrinks to +zero size, then all remaining slaves on the packing list will be +unmapped from the screen until the master window becomes large enough to +hold them again. + +"Expansion" +----------- + +If a master window is so large that there will be extra space left over +after all of its slaves have been packed, then the extra space is +distributed uniformly among all of the slaves for which the :expand +option is set. Extra horizontal space is distributed among the +expandable slaves whose :side is left or right, and extra vertical space +is distributed among the expandable slaves whose :side is top or bottom. + +"Geometry Propagation" +---------------------- + +The packer normally computes how large a master must be to just exactly +meet the needs of its slaves, and it sets the requested width and height +of the master to these dimensions. This causes geometry information to +propagate up through a window hierarchy to a top-level window so that +the entire sub-tree sizes itself to fit the needs of the leaf windows. +However, the pack propagate command may be used to turn off propagation +for one or more masters. If propagation is disabled then the packer +will not set the requested width and height of the packer. This may be +useful if, for example, you wish for a master window to have a fixed +size that you specify. + +"Restrictions On Master Windows" +-------------------------------- + +The master for each slave must either be the slave's parent (the +default) or a descendant of the slave's parent. This restriction is +necessary to guarantee that the slave can be placed over any part of its +master that is visible without danger of the slave being clipped by its +parent. + +"Packing Order" +--------------- + +If the master for a slave is not its parent then you must make sure that +the slave is higher in the stacking order than the master. Otherwise +the master will obscure the slave and it will appear as if the slave +hasn't been packed correctly. The easiest way to make sure the slave is +higher than the master is to create the master window first: the most +recently created window will be highest in the stacking order. Or, you +can use the raise and lower commands to change the stacking order of +either the master or the slave. + +Keywords +-------- + +geometry manager, location, packer, parcel, propagation, size diff --git a/info/gcl-tk.info-2 b/info/gcl-tk.info-2 new file mode 100644 index 0000000..a8b3124 --- /dev/null +++ b/info/gcl-tk.info-2 @@ -0,0 +1,1234 @@ +This is gcl-tk.info, produced by makeinfo version 5.2 from gcl-tk.texi. + +INFO-DIR-SECTION GNU Common Lisp +START-INFO-DIR-ENTRY +* gcl-tk: (gcl-tk.info). GNU TK Manual +END-INFO-DIR-ENTRY + +This is a Texinfo GCL TK Manual + + Copyright 1994 William F. Schelter + + + +File: gcl-tk.info, Node: place, Next: raise, Prev: pack, Up: Control + +3.15 place +========== + +place \- Geometry manager for fixed or rubber-sheet placement + +Synopsis +-------- + +place window option value ?option value ...? + + place configure window option value ?option value ...? + + place forget window + + place info window + + place slaves window + +Description +----------- + +The placer is a geometry manager for Tk. It provides simple fixed +placement of windows, where you specify the exact size and location of +one window, called the slave, within another window, called the master. +The placer also provides rubber-sheet placement, where you specify the +size and location of the slave in terms of the dimensions of the master, +so that the slave changes size and location in response to changes in +the size of the master. Lastly, the placer allows you to mix these +styles of placement so that, for example, the slave has a fixed width +and height but is centered inside the master. + + If the first argument to the place command is a window path name or +configure then the command arranges for the placer to manage the +geometry of a slave whose path name is window. The remaining arguments +consist of one or more option:value pairs that specify the way in which +window's geometry is managed. If the placer is already managing window, +then the option:value pairs modify the configuration for window. In +this form the place command returns an empty string as result. The +following option:value pairs are supported: + +:in master + Master specifes the path name of the window relative to which + window is to be placed. Master must either be window's parent or a + descendant of window's parent. In addition, master and window must + both be descendants of the same top-level window. These + restrictions are necessary to guarantee that window is visible + whenever master is visible. If this option isn't specified then + the master defaults to window's parent. +:x location + Location specifies the x-coordinate within the master window of the + anchor point for window. The location is specified in screen units + (i.e. any of the forms accepted by Tk_GetPixels) and need not lie + within the bounds of the master window. +:relx location + Location specifies the x-coordinate within the master window of the + anchor point for window. In this case the location is specified in + a relative fashion as a floating-point number: 0.0 corresponds to + the left edge of the master and 1.0 corresponds to the right edge + of the master. Location need not be in the range 0.0\-1.0. +:y location + Location specifies the y-coordinate within the master window of the + anchor point for window. The location is specified in screen units + (i.e. any of the forms accepted by Tk_GetPixels) and need not lie + within the bounds of the master window. +:rely location + Location specifies the y-coordinate within the master window of the + anchor point for window. In this case the value is specified in a + relative fashion as a floating-point number: 0.0 corresponds to the + top edge of the master and 1.0 corresponds to the bottom edge of + the master. Location need not be in the range 0.0\-1.0. +:anchor where + Where specifies which point of window is to be positioned at the + (x,y) location selected by the :x, :y, :relx, and :rely options. + The anchor point is in terms of the outer area of window including + its border, if any. Thus if where is se then the lower-right + corner of window's border will appear at the given (x,y) location + in the master. The anchor position defaults to nw. +:width size + Size specifies the width for window in screen units (i.e. any of + the forms accepted by Tk_GetPixels). The width will be the outer + width of window including its border, if any. If size is an empty + string, or if no :width or :relwidth option is specified, then the + width requested internally by the window will be used. +:relwidth size + Size specifies the width for window. In this case the width is + specified as a floating-point number relative to the width of the + master: 0.5 means window will be half as wide as the master, 1.0 + means window will have the same width as the master, and so on. +:height size + Size specifies the height for window in screen units (i.e. any of + the forms accepted by Tk_GetPixels). The height will be the outer + dimension of window including its border, if any. If size is an + empty string, or if no :height or :relheight option is specified, + then the height requested internally by the window will be used. +:relheight size + Size specifies the height for window. In this case the height is + specified as a floating-point number relative to the height of the + master: 0.5 means window will be half as high as the master, 1.0 + means window will have the same height as the master, and so on. +:bordermode mode + Mode determines the degree to which borders within the master are + used in determining the placement of the slave. The default and + most common value is inside. In this case the placer considers the + area of the master to be the innermost area of the master, inside + any border: an option of :x 0 corresponds to an x-coordinate just + inside the border and an option of :relwidth 1.0 means window will + fill the area inside the master's border. If mode is outside then + the placer considers the area of the master to include its border; + this mode is typically used when placing window outside its master, + as with the options :x 0 :y 0 :anchor ne. Lastly, mode may be + specified as ignore, in which case borders are ignored: the area of + the master is considered to be its official X area, which includes + any internal border but no external border. A bordermode of ignore + is probably not very useful. + + If the same value is specified separately with two different + options, such as :x and :relx, then the most recent option is used + and the older one is ignored. + + The place slaves command returns a list of all the slave windows + for which window is the master. If there are no slaves for window + then an empty string is returned. + + The place forget command causes the placer to stop managing the + geometry of window. As a side effect of this command window will + be unmapped so that it doesn't appear on the screen. If window + isn't currently managed by the placer then the command has no + effect. Place forget returns an empty string as result. + + The place info command returns a list giving the current + configuration of window. The list consists of option:value pairs + in exactly the same form as might be specified to the place + configure command. If the configuration of a window has been + retrieved with place info, that configuration can be restored later + by first using place forget to erase any existing information for + the window and then invoking place configure with the saved + information. + +"Fine Points" +------------- + +It is not necessary for the master window to be the parent of the slave +window. This feature is useful in at least two situations. First, for +complex window layouts it means you can create a hierarchy of subwindows +whose only purpose is to assist in the layout of the parent. The "real +children" of the parent (i.e. the windows that are significant for the +application's user interface) can be children of the parent yet be +placed inside the windows of the geometry-management hierarchy. This +means that the path names of the "real children" don't reflect the +geometry-management hierarchy and users can specify options for the real +children without being aware of the structure of the geometry-management +hierarchy. + + A second reason for having a master different than the slave's parent +is to tie two siblings together. For example, the placer can be used to +force a window always to be positioned centered just below one of its +siblings by specifying the configuration + + :in sibling :relx 0.5 :rely 1.0 :anchor n :bordermode outside + + Whenever the sibling is repositioned in the future, the slave will be +repositioned as well. + + Unlike many other geometry managers (such as the packer) the placer +does not make any attempt to manipulate the geometry of the master +windows or the parents of slave windows (i.e. it doesn't set their +requested sizes). To control the sizes of these windows, make them +windows like frames and canvases that provide configuration options for +this purpose. + +Keywords +-------- + +geometry manager, height, location, master, place, rubber sheet, slave, +width + + +File: gcl-tk.info, Node: raise, Next: selection, Prev: place, Up: Control + +3.16 raise +========== + +raise \- Change a window's position in the stacking order + +Synopsis +-------- + +raise window ?aboveThis? + +Description +----------- + +If the aboveThis argument is omitted then the command raises window so +that it is above all of its siblings in the stacking order (it will not +be obscured by any siblings and will obscure any siblings that overlap +it). If aboveThis is specified then it must be the path name of a +window that is either a sibling of window or the descendant of a sibling +of window. In this case the raise command will insert window into the +stacking order just above aboveThis (or the ancestor of aboveThis that +is a sibling of window); this could end up either raising or lowering +window. + +Keywords +-------- + +obscure, raise, stacking order + + +File: gcl-tk.info, Node: selection, Next: send, Prev: raise, Up: Control + +3.17 selection +============== + +selection \- Manipulate the X selection + +Synopsis +-------- + +selection option ?arg arg ...? + +Description +----------- + +This command provides a Tcl interface to the X selection mechanism and +implements the full selection functionality described in the X +Inter-Client Communication Conventions Manual (ICCCM), except that it +supports only the primary selection. + + The first argument to selection determines the format of the rest of +the arguments and the behavior of the command. The following forms are +currently supported: + +selection :clear window + If there is a selection anywhere on window's display, clear it so + that no window owns the selection anymore. Returns an empty + string. +selection :get ?type? + Retrieves the value of the primary selection and returns it as a + result. Type specifies the form in which the selection is to be + returned (the desired "target" for conversion, in ICCCM + terminology), and should be an atom name such as STRING or + FILE_NAME; see the Inter-Client Communication Conventions Manual + for complete details. Type defaults to STRING. The selection + :owner may choose to return the selection in any of several + different representation formats, such as STRING, ATOM, INTEGER, + etc. (this format is different than the selection type; see the + ICCCM for all the confusing details). If the selection is returned + in a non-string format, such as INTEGER or ATOM, the selection + command converts it to string format as a collection of fields + separated by spaces: atoms are converted to their textual names, + and anything else is converted to hexadecimal integers. +selection :handle window command ?type? ?format? + Creates a handler for selection requests, such that command will be + executed whenever the primary selection is owned by window and + someone attempts to retrieve it in the form given by type (e.g. + type is specified in the selection :get command). Type defaults to + STRING. If command is an empty string then any existing handler for + window and type is removed. + + When the selection is requested and window is the selection :owner + and type is the requested type, command will be executed as a Tcl + command with two additional numbers appended to it (with space + separators). The two additional numbers are offset and maxBytes: + offset specifies a starting character position in the selection and + maxBytes gives the maximum number of bytes to retrieve. The + command should return a value consisting of at most maxBytes of the + selection, starting at position offset. For very large selections + (larger than maxBytes) the selection will be retrieved using + several invocations of command with increasing offset values. If + command returns a string whose length is less than maxBytes, the + return value is assumed to include all of the remainder of the + selection; if the length of command's result is equal to maxBytes + then command will be invoked again, until it eventually returns a + result shorter than maxBytes. The value of maxBytes will always be + relatively large (thousands of bytes). + + If command returns an error then the selection retrieval is + rejected just as if the selection didn't exist at all. + + The format argument specifies the representation that should be + used to transmit the selection to the requester (the second column + of Table 2 of the ICCCM), and defaults to STRING. If format is + STRING, the selection is transmitted as 8-bit ASCII characters + (i.e. just in the form returned by command). If format is ATOM, + then the return value from command is divided into fields separated + by white space; each field is converted to its atom value, and the + 32-bit atom value is transmitted instead of the atom name. For any + other format, the return value from command is divided into fields + separated by white space and each field is converted to a 32-bit + integer; an array of integers is transmitted to the selection + requester. + + The format argument is needed only for compatibility with selection + requesters that don't use Tk. If the Tk toolkit is being used to + retrieve the selection then the value is converted back to a string + at the requesting end, so format is irrelevant. .RE +selection :own ?window? ?command? + If window is specified, then it becomes the new selection :owner + and the command returns an empty string as result. The existing + owner, if any, is notified that it has lost the selection. If + command is specified, it is a Tcl script to execute when some other + window claims ownership of the selection away from window. If + neither window nor command is specified then the command returns + the path name of the window in this application that owns the + selection, or an empty string if no window in this application owns + the selection. + +Keywords +-------- + +clear, format, handler, ICCCM, own, selection, target, type + + +File: gcl-tk.info, Node: send, Next: tk, Prev: selection, Up: Control + +3.18 send +========= + +send \- Execute a command in a different interpreter + +Synopsis +-------- + +send interp cmd ?arg arg ...? + +Description +----------- + +This command arranges for cmd (and args) to be executed in the +interpreter named by interp. It returns the result or error from that +command execution. Interp must be the name of an interpreter registered +on the display associated with the interpreter in which the command is +invoked; it need not be within the same process or application. If no +arg arguments are present, then the command to be executed is contained +entirely within the cmd argument. If one or more args are present, they +are concatenated to form the command to be executed, just as for the +eval Tcl command. + +Security +-------- + +The send command is potentially a serious security loophole, since any +application that can connect to your X server can send scripts to your +applications. These incoming scripts can use Tcl to read and write your +files and invoke subprocesses under your name. Host-based access +control such as that provided by xhost is particularly insecure, since +it allows anyone with an account on particular hosts to connect to your +server, and if disabled it allows anyone anywhere to connect to your +server. In order to provide at least a small amount of security, Tk +checks the access control being used by the server and rejects incoming +sends unless (a) xhost-style access control is enabled (i.e. only +certain hosts can establish connections) and (b) the list of enabled +hosts is empty. This means that applications cannot connect to your +server unless they use some other form of authorization such as that +provide by xauth. + +Keywords +-------- + +interpreter, remote execution, security, send + + +File: gcl-tk.info, Node: tk, Next: tkerror, Prev: send, Up: Control + +3.19 tk +======= + +tk \- Manipulate Tk internal state + +Synopsis +-------- + +tk option ?arg arg ...? + +Description +----------- + +The tk command provides access to miscellaneous elements of Tk's +internal state. Most of the information manipulated by this command +pertains to the application as a whole, or to a screen or display, +rather than to a particular window. The command can take any of a +number of different forms depending on the option argument. The legal +forms are: + +tk :colormodel window ?newValue? + If newValue isn't specified, this command returns the current color + model in use for window's screen, which will be either color or + monochrome. If newValue is specified, then it must be either color + or monochrome or an abbreviation of one of them; the color model + for window's screen is set to this value. + + The color model is used by Tk and its widgets to determine whether it +should display in black and white only or use colors. A single color +model is shared by all of the windows managed by one process on a given +screen. The color model for a screen is set initially by Tk to +monochrome if the display has four or fewer bit planes and to color +otherwise. The color model will automatically be changed from color to +monochrome if Tk fails to allocate a color because all entries in the +colormap were in use. An application can change its own color model at +any time (e.g. it might change the model to monochrome in order to +conserve colormap entries, or it might set the model to color to use +color on a four-bit display in special circumstances), but an +application is not allowed to change the color model to color unless the +screen has at least two bit planes. .RE + +Keywords +-------- + +color model, internal state + + +File: gcl-tk.info, Node: tkerror, Next: tkvars, Prev: tk, Up: Control + +3.20 tkerror +============ + +tkerror \- Command invoked to process background errors + +Synopsis +-------- + +tkerror message + +Description +----------- + +The tkerror command doesn't exist as built-in part of Tk. Instead, +individual applications or users can define a tkerror command (e.g. as +a Tcl procedure) if they wish to handle background errors. + + A background error is one that occurs in a command that didn't +originate with the application. For example, if an error occurs while +executing a command specified with a bind of after command, then it is a +background error. For a non-background error, the error can simply be +returned up through nested Tcl command evaluations until it reaches the +top-level code in the application; then the application can report the +error in whatever way it wishes. When a background error occurs, the +unwinding ends in the Tk library and there is no obvious way for Tk to +report the error. + + When Tk detects a background error, it invokes the tkerror command, +passing it the error message as its only argument. Tk assumes that the +application has implemented the tkerror command, and that the command +will report the error in a way that makes sense for the application. Tk +will ignore any result returned by the tkerror command. + + If another Tcl error occurs within the tkerror command then Tk +reports the error itself by writing a message to stderr. + + The Tk script library includes a default tkerror procedure that posts +a dialog box containing the error message and offers the user a chance +to see a stack trace that shows where the error occurred. + +Keywords +-------- + +background error, reporting + + +File: gcl-tk.info, Node: tkvars, Next: tkwait, Prev: tkerror, Up: Control + +3.21 tkvars +=========== + +tkvars \- Variables used or set by Tk + +Description +----------- + +The following Tcl variables are either set or used by Tk at various +times in its execution: + +tk_library + Tk sets this variable hold the name of a directory containing a + library of Tcl scripts related to Tk. These scripts include an + initialization file that is normally processed whenever a Tk + application starts up, plus other files containing procedures that + implement default behaviors for widgets. The value of this + variable is taken from the TK_LIBRARY environment variable, if one + exists, or else from a default value compiled into Tk. +tk_patchLevel + Contains a decimal integer giving the current patch level for Tk. + The patch level is incremented for each new release or patch, and + it uniquely identifies an official version of Tk. +tk_priv + This variable is an array containing several pieces of information + that are private to Tk. The elements of tk_priv are used by Tk + library procedures and default bindings. They should not be + accessed by any code outside Tk. +tk_strictMotif + This variable is set to zero by default. If an application sets it + to one, then Tk attempts to adhere as closely as possible to Motif + look-and-feel standards. For example, active elements such as + buttons and scrollbar sliders will not change color when the + pointer passes over them. +tk_version + Tk sets this variable in the interpreter for each application. The + variable holds the current version number of the Tk library in the + form major.minor. Major and minor are integers. The major version + number increases in any Tk release that includes changes that are + not backward compatible (i.e. whenever existing Tk applications + and scripts may have to change to work with the new release). The + minor version number increases with each new release of Tk, except + that it resets to zero whenever the major version number changes. +tkVersion + Has the same value as tk_version. This variable is obsolete and + will be deleted soon. + +Keywords +-------- + +variables, version + + +File: gcl-tk.info, Node: tkwait, Next: update, Prev: tkvars, Up: Control + +3.22 tkwait +=========== + +tkwait \- Wait for variable to change or window to be destroyed + +Synopsis +-------- + + +tkwait :variable name + +tkwait :visibility name +tkwait :window name + +Description +----------- + +The tkwait command waits for one of several things to happen, then it +returns without taking any other actions. The return value is always an +empty string. If the first argument is :variable (or any abbreviation +of it) then the second argument is the name of a global variable and the +command waits for that variable to be modified. If the first argument +is :visibility (or any abbreviation of it) then the second argument is +the name of a window and the tkwait command waits for a change in its +visibility state (as indicated by the arrival of a VisibilityNotify +event). This form is typically used to wait for a newly-created window +to appear on the screen before taking some action. If the first +argument is :window (or any abbreviation of it) then the second argument +is the name of a window and the tkwait command waits for that window to +be destroyed. This form is typically used to wait for a user to finish +interacting with a dialog box before using the result of that +interaction. + + While the tkwait command is waiting it processes events in the normal +fashion, so the application will continue to respond to user +interactions. + +Keywords +-------- + +variable, visibility, wait, window + + +File: gcl-tk.info, Node: update, Next: winfo, Prev: tkwait, Up: Control + +3.23 update +=========== + +update \- Process pending events and/or when-idle handlers + +Synopsis +-------- + +update ?:idletasks? + +Description +----------- + +This command is used to bring the entire application world "up to date." +It flushes all pending output to the display, waits for the server to +process that output and return errors or events, handles all pending +events of any sort (including when-idle handlers), and repeats this set +of operations until there are no pending events, no pending when-idle +handlers, no pending output to the server, and no operations still +outstanding at the server. + + If the idletasks keyword is specified as an argument to the command, +then no new events or errors are processed; only when-idle idlers are +invoked. This causes operations that are normally deferred, such as +display updates and window layout calculations, to be performed +immediately. + + The update :idletasks command is useful in scripts where changes have +been made to the application's state and you want those changes to +appear on the display immediately, rather than waiting for the script to +complete. The update command with no options is useful in scripts where +you are performing a long-running computation but you still want the +application to respond to user interactions; if you occasionally call +update then user input will be processed during the next call to update. + +Keywords +-------- + +event, flush, handler, idle, update + + +File: gcl-tk.info, Node: winfo, Next: wm, Prev: update, Up: Control + +3.24 winfo +========== + +winfo \- Return window-related information + +Synopsis +-------- + +winfo option ?arg arg ...? + +Description +----------- + +The winfo command is used to retrieve information about windows managed +by Tk. It can take any of a number of different forms, depending on the +option argument. The legal forms are: + +winfo :atom name + Returns a decimal string giving the integer identifier for the atom + whose name is name. If no atom exists with the name name then a + new one is created. +winfo :atomname id + Returns the textual name for the atom whose integer identifier is + id. This command is the inverse of the winfo :atom command. + Generates an error if no such atom exists. +winfo :cells window + Returns a decimal string giving the number of cells in the color + map for window. +winfo :children window + Returns a list containing the path names of all the children of + window. Top-level windows are returned as children of their + logical parents. +winfo :class window + Returns the class name for window. +winfo :containing rootX rootY + Returns the path name for the window containing the point given by + rootX and rootY. RootX and rootY are specified in screen units + (i.e. any form acceptable to Tk_GetPixels) in the coordinate + system of the root window (if a virtual-root window manager is in + use then the coordinate system of the virtual root window is used). + If no window in this application contains the point then an empty + string is returned. In selecting the containing window, children + are given higher priority than parents and among siblings the + highest one in the stacking order is chosen. +winfo :depth window + Returns a decimal string giving the depth of window (number of bits + per pixel). +winfo :exists window + Returns 1 if there exists a window named window, 0 if no such + window exists. +winfo :fpixels window number + Returns a floating-point value giving the number of pixels in + window corresponding to the distance given by number. Number may + be specified in any of the forms acceptable to Tk_GetScreenMM, such + as "2.0c" or "1i". The return value may be fractional; for an + integer value, use winfo :pixels. +winfo :geometry window + Returns the geometry for window, in the form widthxheight+x+y. All + dimensions are in pixels. +winfo :height window + Returns a decimal string giving window's height in pixels. When a + window is first created its height will be 1 pixel; the height will + eventually be changed by a geometry manager to fulfill the window's + needs. If you need the true height immediately after creating a + widget, invoke update to force the geometry manager to arrange it, + or use winfo :reqheight to get the window's requested height + instead of its actual height. +winfo :id window + Returns a hexadecimal string indicating the X identifier for + window. +winfo :interps + Returns a list whose members are the names of all Tcl interpreters + (e.g. all Tk-based applications) currently registered for the + display of the invoking application. +winfo :ismapped window + Returns 1 if window is currently mapped, 0 otherwise. +winfo :name window + Returns window's name (i.e. its name within its parent, as opposed + to its full path name). The command winfo :name . will return the + name of the application. +winfo :parent window + Returns the path name of window's parent, or an empty string if + window is the main window of the application. +winfo :pathname id + Returns the path name of the window whose X identifier is id. Id + must be a decimal, hexadecimal, or octal integer and must + correspond to a window in the invoking application. +winfo :pixels window number + Returns the number of pixels in window corresponding to the + distance given by number. Number may be specified in any of the + forms acceptable to Tk_GetPixels, such as "2.0c" or "1i". The + result is rounded to the nearest integer value; for a fractional + result, use winfo :fpixels. +winfo :reqheight window + Returns a decimal string giving window's requested height, in + pixels. This is the value used by window's geometry manager to + compute its geometry. +winfo :reqwidth window + Returns a decimal string giving window's requested width, in + pixels. This is the value used by window's geometry manager to + compute its geometry. +winfo :rgb window color + Returns a list containing three decimal values, which are the red, + green, and blue intensities that correspond to color in the window + given by window. Color may be specified in any of the forms + acceptable for a color option. +winfo :rootx window + Returns a decimal string giving the x-coordinate, in the root + window of the screen, of the upper-left corner of window's border + (or window if it has no border). +winfo :rooty window + Returns a decimal string giving the y-coordinate, in the root + window of the screen, of the upper-left corner of window's border + (or window if it has no border). +winfo :screen window + Returns the name of the screen associated with window, in the form + displayName.screenIndex. +winfo :screencells window + Returns a decimal string giving the number of cells in the default + color map for window's screen. +winfo :screendepth window + Returns a decimal string giving the depth of the root window of + window's screen (number of bits per pixel). +winfo :screenheight window + Returns a decimal string giving the height of window's screen, in + pixels. +winfo :screenmmheight window + Returns a decimal string giving the height of window's screen, in + millimeters. +winfo :screenmmwidth window + Returns a decimal string giving the width of window's screen, in + millimeters. +winfo :screenvisual window + Returns one of the following strings to indicate the default visual + type for window's screen: directcolor, grayscale, pseudocolor, + staticcolor, staticgray, or truecolor. +winfo :screenwidth window + Returns a decimal string giving the width of window's screen, in + pixels. +winfo :toplevel window + Returns the path name of the top-level window containing window. +winfo :visual window + Returns one of the following strings to indicate the visual type + for window: directcolor, grayscale, pseudocolor, staticcolor, + staticgray, or truecolor. +winfo :vrootheight window + Returns the height of the virtual root window associated with + window if there is one; otherwise returns the height of window's + screen. +winfo :vrootwidth window + Returns the width of the virtual root window associated with window + if there is one; otherwise returns the width of window's screen. +winfo :vrootx window + Returns the x-offset of the virtual root window associated with + window, relative to the root window of its screen. This is + normally either zero or negative. Returns 0 if there is no virtual + root window for window. +winfo :vrooty window + Returns the y-offset of the virtual root window associated with + window, relative to the root window of its screen. This is + normally either zero or negative. Returns 0 if there is no virtual + root window for window. +winfo :width window + Returns a decimal string giving window's width in pixels. When a + window is first created its width will be 1 pixel; the width will + eventually be changed by a geometry manager to fulfill the window's + needs. If you need the true width immediately after creating a + widget, invoke update to force the geometry manager to arrange it, + or use winfo :reqwidth to get the window's requested width instead + of its actual width. +winfo :x window + Returns a decimal string giving the x-coordinate, in window's + parent, of the upper-left corner of window's border (or window if + it has no border). +winfo :y window + Returns a decimal string giving the y-coordinate, in window's + parent, of the upper-left corner of window's border (or window if + it has no border). + +Keywords +-------- + +atom, children, class, geometry, height, identifier, information, +interpreters, mapped, parent, path name, screen, virtual root, width, +window + + +File: gcl-tk.info, Node: wm, Prev: winfo, Up: Control + +3.25 wm +======= + +wm \- Communicate with window manager + +Synopsis +-------- + +wm option window ?args? + +Description +----------- + +The wm command is used to interact with window managers in order to +control such things as the title for a window, its geometry, or the +increments in terms of which it may be resized. The wm command can take +any of a number of different forms, depending on the option argument. +All of the forms expect at least one additional argument, window, which +must be the path name of a top-level window. + + The legal forms for the wm command are: + +wm :aspect window ?minNumer minDenom maxNumer maxDenom? + If minNumer, minDenom, maxNumer, and maxDenom are all specified, + then they will be passed to the window manager and the window + manager should use them to enforce a range of acceptable aspect + ratios for window. The aspect ratio of window (width/length) will + be constrained to lie between minNumer/minDenom and + maxNumer/maxDenom. If minNumer etc. are all specified as empty + strings, then any existing aspect ratio restrictions are removed. + If minNumer etc. are specified, then the command returns an empty + string. Otherwise, it returns a Tcl list containing four elements, + which are the current values of minNumer, minDenom, maxNumer, and + maxDenom (if no aspect restrictions are in effect, then an empty + string is returned). +wm :client window ?name? + If name is specified, this command stores name (which should be the + name of the host on which the application is executing) in window's + WM_CLIENT_MACHINE property for use by the window manager or session + manager. The command returns an empty string in this case. If + name isn't specified, the command returns the last name set in a wm + :client command for window. If name is specified as an empty + string, the command deletes the WM_CLIENT_MACHINE property from + window. +wm :command window ?value? + If value is specified, this command stores value in window's + WM_COMMAND property for use by the window manager or session + manager and returns an empty string. Value must have proper list + structure; the elements should contain the words of the command + used to invoke the application. If value isn't specified then the + command returns the last value set in a wm :command command for + window. If value is specified as an empty string, the command + deletes the WM_COMMAND property from window. +wm :deiconify window + Arrange for window to be displayed in normal (non-iconified) form. + This is done by mapping the window. If the window has never been + mapped then this command will not map the window, but it will + ensure that when the window is first mapped it will be displayed in + de-iconified form. Returns an empty string. +wm :focusmodel window ?active|passive? + If active or passive is supplied as an optional argument to the + command, then it specifies the focus model for window. In this + case the command returns an empty string. If no additional + argument is supplied, then the command returns the current focus + model for window. An active focus model means that window will + claim the input focus for itself or its descendants, even at times + when the focus is currently in some other application. Passive + means that window will never claim the focus for itself: the window + manager should give the focus to window at appropriate times. + However, once the focus has been given to window or one of its + descendants, the application may re-assign the focus among window's + descendants. The focus model defaults to passive, and Tk's focus + command assumes a passive model of focussing. +wm :frame window + If window has been reparented by the window manager into a + decorative frame, the command returns the X window identifier for + the outermost frame that contains window (the window whose parent + is the root or virtual root). If window hasn't been reparented by + the window manager then the command returns the X window identifier + for window. +wm :geometry window ?newGeometry? + If newGeometry is specified, then the geometry of window is changed + and an empty string is returned. Otherwise the current geometry + for window is returned (this is the most recent geometry specified + either by manual resizing or in a wm :geometry command). + NewGeometry has the form =widthxheight\(+-x\(+-y, where any of =, + widthxheight, or \(+-x\(+-y may be omitted. Width and height are + positive integers specifying the desired dimensions of window. If + window is gridded (see GRIDDED GEOMETRY MANAGEMENT below) then the + dimensions are specified in grid units; otherwise they are + specified in pixel units. X and y specify the desired location of + window on the screen, in pixels. If x is preceded by +, it + specifies the number of pixels between the left edge of the screen + and the left edge of window's border; if preceded by - then x + specifies the number of pixels between the right edge of the screen + and the right edge of window's border. If y is preceded by + then + it specifies the number of pixels between the top of the screen and + the top of window's border; if y is preceded by - then it specifies + the number of pixels between the bottom of window's border and the + bottom of the screen. If newGeometry is specified as an empty + string then any existing user-specified geometry for window is + cancelled, and the window will revert to the size requested + internally by its widgets. +wm :grid window ?baseWidth baseHeight widthInc heightInc? + This command indicates that window is to be managed as a gridded + window. It also specifies the relationship between grid units and + pixel units. BaseWidth and baseHeight specify the number of grid + units corresponding to the pixel dimensions requested internally by + window using Tk_GeometryRequest. WidthInc and heightInc specify + the number of pixels in each horizontal and vertical grid unit. + These four values determine a range of acceptable sizes for window, + corresponding to grid-based widths and heights that are + non-negative integers. Tk will pass this information to the window + manager; during manual resizing, the window manager will restrict + the window's size to one of these acceptable sizes. Furthermore, + during manual resizing the window manager will display the window's + current size in terms of grid units rather than pixels. If + baseWidth etc. are all specified as empty strings, then window + will no longer be managed as a gridded window. If baseWidth etc. + are specified then the return value is an empty string. Otherwise + the return value is a Tcl list containing four elements + corresponding to the current baseWidth, baseHeight, widthInc, and + heightInc; if window is not currently gridded, then an empty string + is returned. Note: this command should not be needed very often, + since the Tk_SetGrid library procedure and the setGrid option + provide easier access to the same functionality. +wm :group window ?pathName? + If pathName is specified, it gives the path name for the leader of + a group of related windows. The window manager may use this + information, for example, to unmap all of the windows in a group + when the group's leader is iconified. PathName may be specified as + an empty string to remove window from any group association. If + pathName is specified then the command returns an empty string; + otherwise it returns the path name of window's current group + leader, or an empty string if window isn't part of any group. +wm :iconbitmap window ?bitmap? + If bitmap is specified, then it names a bitmap in the standard + forms accepted by Tk (see the Tk_GetBitmap manual entry for + details). This bitmap is passed to the window manager to be + displayed in window's icon, and the command returns an empty + string. If an empty string is specified for bitmap, then any + current icon bitmap is cancelled for window. If bitmap is + specified then the command returns an empty string. Otherwise it + returns the name of the current icon bitmap associated with window, + or an empty string if window has no icon bitmap. +wm :iconify window + Arrange for window to be iconified. It window hasn't yet been + mapped for the first time, this command will arrange for it to + appear in the iconified state when it is eventually mapped. +wm :iconmask window ?bitmap? + If bitmap is specified, then it names a bitmap in the standard + forms accepted by Tk (see the Tk_GetBitmap manual entry for + details). This bitmap is passed to the window manager to be used + as a mask in conjunction with the iconbitmap option: where the mask + has zeroes no icon will be displayed; where it has ones, the bits + from the icon bitmap will be displayed. If an empty string is + specified for bitmap then any current icon mask is cancelled for + window (this is equivalent to specifying a bitmap of all ones). If + bitmap is specified then the command returns an empty string. + Otherwise it returns the name of the current icon mask associated + with window, or an empty string if no mask is in effect. +wm :iconname window ?newName? + If newName is specified, then it is passed to the window manager; + the window manager should display newName inside the icon + associated with window. In this case an empty string is returned + as result. If newName isn't specified then the command returns the + current icon name for window, or an empty string if no icon name + has been specified (in this case the window manager will normally + display the window's title, as specified with the wm :title + command). +wm :iconposition window ?x y? + If x and y are specified, they are passed to the window manager as + a hint about where to position the icon for window. In this case + an empty string is returned. If x and y are specified as empty + strings then any existing icon position hint is cancelled. If + neither x nor y is specified, then the command returns a Tcl list + containing two values, which are the current icon position hints + (if no hints are in effect then an empty string is returned). +wm :iconwindow window ?pathName? + If pathName is specified, it is the path name for a window to use + as icon for window: when window is iconified then pathName should + be mapped to serve as icon, and when window is de-iconified then + pathName will be unmapped again. If pathName is specified as an + empty string then any existing icon window association for window + will be cancelled. If the pathName argument is specified then an + empty string is returned. Otherwise the command returns the path + name of the current icon window for window, or an empty string if + there is no icon window currently specified for window. Note: not + all window managers support the notion of an icon window. +wm :maxsize window ?width height? + If width and height are specified, then window becomes resizable + and width and height give its maximum permissible dimensions. For + gridded windows the dimensions are specified in grid units; + otherwise they are specified in pixel units. During manual sizing, + the window manager should restrict the window's dimensions to be + less than or equal to width and height. If width and height are + specified as empty strings, then the maximum size option is + cancelled for window. If width and height are specified, then the + command returns an empty string. Otherwise it returns a Tcl list + with two elements, which are the maximum width and height currently + in effect; if no maximum dimensions are in effect for window then + an empty string is returned. See the sections on geometry + management below for more information. +wm :minsize window ?width height? + If width and height are specified, then window becomes resizable + and width and height give its minimum permissible dimensions. For + gridded windows the dimensions are specified in grid units; + otherwise they are specified in pixel units. During manual sizing, + the window manager should restrict the window's dimensions to be + greater than or equal to width and height. If width and height are + specified as empty strings, then the minimum size option is + cancelled for window. If width and height are specified, then the + command returns an empty string. Otherwise it returns a Tcl list + with two elements, which are the minimum width and height currently + in effect; if no minimum dimensions are in effect for window then + an empty string is returned. See the sections on geometry + management below for more information. +wm :overrideredirect window ?boolean? + If boolean is specified, it must have a proper boolean form and the + override-redirect flag for window is set to that value. If boolean + is not specified then 1 or 0 is returned to indicate whether or not + the override-redirect flag is currently set for window. Setting + the override-redirect flag for a window causes it to be ignored by + the window manager; among other things, this means that the window + will not be reparented from the root window into a decorative frame + and the user will not be able to manipulate the window using the + normal window manager mechanisms. +wm :positionfrom window ?who? + If who is specified, it must be either program or user, or an + abbreviation of one of these two. It indicates whether window's + current position was requested by the program or by the user. Many + window managers ignore program-requested initial positions and ask + the user to manually position the window; if user is specified then + the window manager should position the window at the given place + without asking the user for assistance. If who is specified as an + empty string, then the current position source is cancelled. If + who is specified, then the command returns an empty string. + Otherwise it returns user or window to indicate the source of the + window's current position, or an empty string if no source has been + specified yet. Most window managers interpret "no source" as + equivalent to program. Tk will automatically set the position + source to user when a wm :geometry command is invoked, unless the + source has been set explicitly to program. +wm :protocol window ?name? ?command? + This command is used to manage window manager protocols such as + WM_DELETE_WINDOW. Name is the name of an atom corresponding to a + window manager protocol, such as WM_DELETE_WINDOW or + WM_SAVE_YOURSELF or WM_TAKE_FOCUS. If both name and command are + specified, then command is associated with the protocol specified + by name. Name will be added to window's WM_PROTOCOLS property to + tell the window manager that the application has a protocol handler + for name, and command will be invoked in the future whenever the + window manager sends a message to the client for that protocol. In + this case the command returns an empty string. If name is + specified but command isn't, then the current command for name is + returned, or an empty string if there is no handler defined for + name. If command is specified as an empty string then the current + handler for name is deleted and it is removed from the WM_PROTOCOLS + property on window; an empty string is returned. Lastly, if + neither name nor command is specified, the command returns a list + of all the protocols for which handlers are currently defined for + window. + + Tk always defines a protocol handler for WM_DELETE_WINDOW, even if +you haven't asked for one with wm :protocol. If a WM_DELETE_WINDOW +message arrives when you haven't defined a handler, then Tk handles the +message by destroying the window for which it was received. .RE + +wm :sizefrom window ?who? + If who is specified, it must be either program or user, or an + abbreviation of one of these two. It indicates whether window's + current size was requested by the program or by the user. Some + window managers ignore program-requested sizes and ask the user to + manually size the window; if user is specified then the window + manager should give the window its specified size without asking + the user for assistance. If who is specified as an empty string, + then the current size source is cancelled. If who is specified, + then the command returns an empty string. Otherwise it returns + user or window to indicate the source of the window's current size, + or an empty string if no source has been specified yet. Most + window managers interpret "no source" as equivalent to program. +wm :state window + Returns the current state of window: either normal, iconic, or + withdrawn. +wm :title window ?string? + If string is specified, then it will be passed to the window + manager for use as the title for window (the window manager should + display this string in window's title bar). In this case the + command returns an empty string. If string isn't specified then + the command returns the current title for the window. The title + for a window defaults to its name. +wm :transient window ?master? + If master is specified, then the window manager is informed that + window is a transient window (e.g. pull-down menu) working on + behalf of master (where master is the path name for a top-level + window). Some window managers will use this information to manage + window specially. If master is specified as an empty string then + window is marked as not being a transient window any more. If + master is specified, then the command returns an empty string. + Otherwise the command returns the path name of window's current + master, or an empty string if window isn't currently a transient + window. +wm :withdraw window + Arranges for window to be withdrawn from the screen. This causes + the window to be unmapped and forgotten about by the window + manager. If the window has never been mapped, then this command + causes the window to be mapped in the withdrawn state. Not all + window managers appear to know how to handle windows that are + mapped in the withdrawn state. Note: it sometimes seems to be + necessary to withdraw a window and then re-map it (e.g. with wm + :deiconify) to get some window managers to pay attention to changes + in window attributes such as group. + +"Sources Of Geometry Information" +--------------------------------- + +Size-related information for top-level windows can come from three +sources. First, geometry requests come from the widgets that are +descendants of a top-level window. Each widget requests a particular +size for itself by calling Tk_GeometryRequest. This information is +passed to geometry managers, which then request large enough sizes for +parent windows so that they can layout the children properly. Geometry +information passes upwards through the window hierarchy until eventually +a particular size is requested for each top-level window. These +requests are called internal requests in the discussion below. The +second source of width and height information is through the wm +:geometry command. Third, the user can request a particular size for a +window using the interactive facilities of the window manager. The +second and third types of geometry requests are called external requests +in the discussion below; Tk treats these two kinds of requests +identically. + +"Ungridded Geometry Management" +------------------------------- + +Tk allows the geometry of a top-level window to be managed in either of +two general ways: ungridded or gridded. The ungridded form occurs if no +wm :grid command has been issued for a top-level window. Ungridded +management has several variants. In the simplest variant of ungridded +windows, no wm :geometry, wm :minsize, or wm :maxsize commands have been +invoked either. In this case, the window's size is determined totally +by the internal requests emanating from the widgets inside the window: +Tk will ask the window manager not to permit the user to resize the +window interactively. + + If a wm :geometry command is invoked on an ungridded window, then the +size in that command overrides any size requested by the window's +widgets; from now on, the window's size will be determined entirely by +the most recent information from wm :geometry commands. To go back to +using the size requested by the window's widgets, issue a wm :geometry +command with an empty geometry string. + + To enable interactive resizing of an ungridded window, one or both of +the wm :maxsize and wm :minsize commands must be issued. The +information from these commands will be passed to the window manager, +and size changes within the specified range will be permitted. For +ungridded windows the limits refer to the top-level window's dimensions +in pixels. If only a wm :maxsize command is issued then the minimum +dimensions default to 1; if only a wm :minsize command is issued then +the maximum dimensions default to the size of the display. If the size +of a window is changed interactively, it has the same effect as if wm +:geometry had been invoked: from now on, internal geometry requests will +be ignored. To return to internal control over the window's size, issue +a wm :geometry command with an empty geometry argument. If a window has +been manually resized or moved, the wm :geometry command will return the +geometry that was requested interactively. + +"Gridded Geometry Management" +----------------------------- + +The second style of geometry management is called gridded. This +approach occurs when one of the widgets of an application supports a +range of useful sizes. This occurs, for example, in a text editor where +the scrollbars, menus, and other adornments are fixed in size but the +edit widget can support any number of lines of text or characters per +line. In this case, it is usually desirable to let the user specify the +number of lines or characters-per-line, either with the wm :geometry +command or by interactively resizing the window. In the case of text, +and in other interesting cases also, only discrete sizes of the window +make sense, such as integral numbers of lines and characters-per-line; +arbitrary pixel sizes are not useful. + + Gridded geometry management provides support for this kind of +application. Tk (and the window manager) assume that there is a grid of +some sort within the application and that the application should be +resized in terms of grid units rather than pixels. Gridded geometry +management is typically invoked by turning on the setGrid option for a +widget; it can also be invoked with the wm :grid command or by calling +Tk_SetGrid. In each of these approaches the particular widget (or +sometimes code in the application as a whole) specifies the relationship +between integral grid sizes for the window and pixel sizes. To return +to non-gridded geometry management, invoke wm :grid with empty argument +strings. + + When gridded geometry management is enabled then all the dimensions +specified in wm :minsize, wm :maxsize, and wm :geometry commands are +treated as grid units rather than pixel units. Interactive resizing is +automatically enabled, and it will be carried out in even numbers of +grid units rather than pixels. By default there are no limits on the +minimum or maximum dimensions of a gridded window. As with ungridded +windows, interactive resizing has exactly the same effect as invoking +the wm :geometry command. For gridded windows, internally- and +externally-requested dimensions work together: the externally-specified +width and height determine the size of the window in grid units, and the +information from the last wm :grid command maps from grid units to pixel +units. + +Bugs +---- + +The window manager interactions seem too complicated, especially for +managing geometry. Suggestions on how to simplify this would be greatly +appreciated. + + Most existing window managers appear to have bugs that affect the +operation of the wm command. For example, some changes won't take +effect if the window is already active: the window will have to be +withdrawn and de-iconified in order to make the change happen. + +Keywords +-------- + +aspect ratio, deiconify, focus model, geometry, grid, group, icon, +iconify, increments, position, size, title, top-level window, units, +window manager + diff --git a/info/gcl-tk.pdf b/info/gcl-tk.pdf new file mode 100644 index 0000000000000000000000000000000000000000..fa518bda401bef8529cad606d31ecd725544f7b9 GIT binary patch literal 387116 zcma&NL$GM;7Oc5!+qP}nwr$(iUbb!9wr$(m%SN3WQH^)&-H1B9*&CUie}0i82dRRH z7%d|mD-`MR-OU>mD**$6y^$3Z4-dVVrHzZJ6TO&?p^K@AsjkK#apa25M{;odbiEhF(UdLD~7^)A-z|Albg_{-0iyDO4C#7yyKXL7j;~otdS1p`}BQbwJAyKz-SXL4|>NrGceG<5@tF zk&$_ol|hA#d8L&@HlBOe`W~dfYSco zGnoFBWhQoZhW~R)kEXW$_9&{~-@5fnQk{P3q@k`r6pPSx$!ao+!a)ifeud-eRKzqL zc*%*&y15QmdMzp0K(_gzSs3%#Y|ga5I?eBm_w0CI?^zepPI} zXJ&e>9lQ2lE=S;YXtuReakD3c{Lh;;;iK6hMvb z-1#MI_Q5fE?UQlw+j4H#LhXtRZ2nzQMlA%7AGYoH!t4;nJVyg|bE=eo-AsSsXV~tt zcbofT&XR=})NP5&iZ+1voAWyO_MUGatlYo#+-CAHNA1p`_f*5-VRCT%iOveFCf%x# zaJC=PDhD_vjPlSk(_U&cJGSA8*y|rWUYGbY4o$szfa+XsD=+1!zf2OcOq^y#In8I` zdGq)%4^MlkS{OF*X^@45jmEDk_bS&tO=MfVI}OVcLrmbIo;3?RoI$lRHQ`lUQ+dSl{Z%`xtl@? z9grO%j_1UpuR%3ftS>ln^?|6J^fl>^gw=RKN|IGQ?nz~~S=LVB0%536gr+ZFUnX?! zEc(mq?@|5{yfbkbnfLbn*1T1C`kJ+VMgo{!x6;>y?H-3Y-k&P`j`Dtk9M#6iy%uZc3L5+sllh>nT${<9N4QY3 z+QPt)4$A{TFw~q^HKFj28gVJWu1=Gv%d~FHTz-!uQ=yrnE7`Bt{r@L5edF&D z1Rf~e_qMaff+UAJ3q1g!+3sEUICdg!KZ!7$FUnpaJ#z@tP{o;XVc9qzETU$>cR{5! z7e#LlK_I=b>9L5PFyAIzbBYWBN%0cI))xj}KCnr_^zBOLlgZPSvt{MHXpcO&YPlC4EYy2{B7+ zEd4oL2cbEc9zqcH4sAz-W^sK+zVocFwN&G#$F!iEUt;G3(ajz4-)|E1#sIZ!;&+n)@8p8EeTh@Uj*Bo_^~P_oRg7f;?Fe zD%2tUMl>%zU;Rek(d|H~PC#WE1?d7rzxW!^zvR_35Rl^48u(1}sUXlr+7)*eOl#@( ztf$1)%s_`k7@LZBi^0dlYr~4@5rYu@3 zjY=CT3E%pr8SR!{3rMet_OA~=zDLS#IQ4v;KDYz=!H~kA=dyDc6708w z#mEeiIPJZ@Th0zfUY8!iSC>yhZ7>h;&G&qO9MxiYoy!9XTDbeZU+8aN_jGl?yGP;p ztOlYLG%C^Jitl+o-|J;jDT$?Vnr)VzIRc$vo%rD*iWSFgC4}!zGLiu;K33)F)NW(9 zNj$WwXd#BntIy`jloLG%L+C>j(V#pgED2(Ytl@6P0ZA9a?s)6pI!;LgZ zCK(mT0(t6TlTHSgwdlr?Op_LHCwOS6J)I&9Kw@FdgH&> zi&RLZ%ob437S6dmq7%49k556RoQbAS8l14AaVTLps1imZC2zk(>jLqI?bkl(`#s0% z!kc$sgF+$spriIf_3n%u@G#%jlfpz8Lbm$fncH*1>9%vAfCzg z!FvB>OX0arOV1R2R#s6o&WpWITiq3wL;=p}a7%Qe2*`DgH-+2D_^c+-%gm#SnRIH~ z2gLUHerj2U1ns6hkM|)YFgg@c}R zi#(*1Ix>M{1;Sy<3I^bfikiLLdVm0U+*fCLmB?}odLX{ME{Yd;eJ zb_D~T#w6KiNPhePKHcVo$W@GSuFHm@*bUOG7JhGjw&#a1a0C65{u>J$^j4hEu~tLj z6o6+mR?5e@b<$~#a_K_6<3BblJXubv*@ES1aFne8w#s)VPq|GpouAWVr@w2#0+O+C zeIB@ z-9&hG2nGSBQtQV|a^$^TyI)80eSm*GX{!DQ7ym2vX5wUK|1U1qvW?qnNBr549Vi{0hxdu~{T}ZSqmZW5>T`x95+P#d!0Kx4*?_H*AG0$s5c1yi7v3_3!!J z5<4x(8&tV|@7TF5PTuXovohViJ%6SHN*Ii`Y$bXgJyJ8-J-dP1tQ?X|SmRr)^P-9^ z(|Z1KLl@0>&Gm}2Eecpn{JodCjXwYLxx zq^Aa@|0tja+hH@C8ZZMlhq;Juro2cA-FRKI&GrzL_chnOS?PywkHA}QI0G%#&1Www zsMUG}#^ZX_N`49H0Xl{O$J2JJcip)*&sbB&Ywg`Q*@{~ri}t}J^`NgePk3)&@rLv5 z*cthA_p^w1;6Okf(-XI)<5h_r@6O(%k;2LV+E2wy7 zRK~m;s!LdhI?Fl&p=8KjBLH!=1z6@q=8F@5%cZq^5+L0QdA~CWe9%yd;9xj#hx%Ed zZFZ!gg08SOgI!R}fZX|V!+Z=Q!*$+i86I{&9mrW6^Xqa7S3({eDvqo~{cxDyT3iYg z|J?7GvS>lRa>2TB)GMh8RIClmn_CRe^AP%4{37~k%m9XXzj&Hy%K~2ksro*+1R`+f%6lxpWEeDoF&h_5 ztQ~CuqW*d>6_$II^IHGl$Y|Q!ev+Uu9$^HfHK*wNht3cNE3Fv&Zf+}vvP(2HS`akg zZzeckIk(98NFqkMIz8gbP%mjLxw>a4ngjnp>@{(c-!Pk9h9YhxDXJqkeeZ?*SD{`2x zHlU?tc)fMaFaM1UXOTQ&aFC-DQNZ>A+en^(^w*Vk0$xmxi5-XpnmC4niV!@;{R2EMuFgcnKSu2p=Jl)9G(l)TV#3cAxP3pyaQcju}K%F2m#ag0L1Cz z#V}8}856wH7oOM>*W-mF{s@}k1Tayfoa0HEKSDknN_{L~9R+*9iu`NY zF6W|jA&y3Ju5eXY_B>E~v|eu!DIIiVWdQ@=Cnw6jhs2Wve6b0l6987zS!i4*BsG&1 zICE3s>DCyln=Y7%*a78sp(<7t1!ITqqo3xrUl!&EIhQYJg`f%2E(kF^-hg2$2{Fim zK7zH`VV;#uUPXUORrx z5l0Jg3>kl4$i5a&o{BmKS0mk@iVz_+a+DE44iF;FdR~-y%tJ+Bfhuj~>C$&Nhjf@w z-|MwG>hNnqZ(YH5ocaDh@K^HbS|eFBz^v)5QwTBCr;m@BC0;# zu)S1JyoddkXFf5TbsqSvi+VrlQ?gfMQ zdlb;s(8>3_sHYGug4=umgb`$1$5%^P=6dSbZ0zUEDCH)2dpdB2rc_4FYygS$U}N6; zO;rT2D{A5t>&TAN(*%vLZh~P#CqmD;ibmJ&mAySN($+4pdm3}m%>)iK{N z)d+r~n~7VFybFM{Yl|dbz!*=O&v1Dizk$CTnz3}SN3b7_&cnb-y-N^}4ZVgfh-A5G z3vUlT+3X*B`zpQkR<`Z8&KP1k@%7}sLcYri7 zvZAXF0>#TQ=msu>&>XPV(p752{=VmgC^%)q=HnXNk~;9Ln^3v<^c31%TJfHkWE$jP*v+1R@=UvkcjW$i!wy*q6u?+d3@YPC~KT zshAiqS`lEE_KI@n=x9LBY>8>qrU(vKAMZ`a4fqSDG50Ew;Yf_`+C3!SbD8~GQy2MYz50$rpyas%oMP{H>7G6M#km>Es zkjU(YDg*YEYxxK}OVq(?jHa6mMur{hr0cTN+7E==NlY%_1Sr7%2#R{nz}zj8rI>JA zVa`yLWl9m>R)z$roi91Hc2unf}p7dQ)`5yzhJD>S+$2>3IVSq-GV>v zpsKvr(UP=?1p=mhU)vcN&SVfYFJL2G!CozF>1{pH&T4J4gC0r&N?X!fvu30%TW0G5 zDRBQ_PbUilnf__@!!kAS;TTk;Y>!irI-s6H!VAL)N5QA5+Gy@{_Cnyflb2g;3t0?^C z7+0br7u=IMG;$}HabZs?b$-U>rp^_{2i5XA%qdp?V#uxX`BU>?njp!e3~4g&x6t_K z;Po}j|LcPPgY0nof8aaYzlqM7*x3Fn%g@o&PTFeyPpm!vR-!U$1QD>7BWaE$pKUj4 zndqf0Uv>+u9zwE;(s3}7b@NZI9T=kKa%uL|AG|d%(BT)r#&5q&7L>PX;+0e)nvS0J z?fLk;b2_!=Ra96X5jnGCSo9FXWSC%cTj>v4CwDSr@p&_gfn5GirX72cyxhc6v7sks1oBZv_wdGdTWKhhh-z(Qcn?#`!de^?;epA3F*OT(6 z*QNr_l@9p|uvjwEK%Xt9CY?@OGx;-0rQAq!nK#;Xt=3_cpejL?h6;M zl{*LAO}{Tr#m4j>((D-v&S~c)`VL`U3MegBoX7RJ29Dh*8>4l&_=v&4U5CVT)8V7cr+Pfc)GU7Ne(A~>S zr(!hB^03jxG@LQ&k>Eexe zB6jvHruCvO10EQWqLLphzN-n5ma*}WWM@TXb9HDn(7?jzYy!1y7Ps33TM1m|mF8GR z?S#7LNEwXj7#$V^vpxvdA}KThJ0`+c#6*)%!kptj9O1W+T!V6~jVmK1ApR97b21#K zQ`2;LM{9oj%!auTk&!-*!vFnwp_lRdor#)z6nx-8I0Z2iltKyA74}T6J*#avwB>?o zI`;R@nly2hXmE+aokP(-5~F02f0gyE)gCWi_H7+fz^n1l zEF2X26uZ!x9klV;_TAIo3S-e9F+}|A^a_UyKt=|=FmI+!>fu#jlh+*mm zz`MG%5HE#S?ixF$be4XPTn6UQL#o&hS4(|q#gQ=4+3et@BqccMCH~;f(}-oj$0+s) zlEgI0_~r;qUX}`Sywolwz$2JST-M}~CTik(U(^iXcsT(sw!-u~r;Gvh)@VLm(!>&@ zBgTE5c{4ocuWgsiHu!U7SsvI7aZB;E3W8sqV~RCAD^|rY_igMw20+Z;@YfOLma-t7 zqr7u2a%gf_evJ5?JnZnz4|}o`gLibe0^MArSy`)m5F@TIxNk#r?ROn5{hR!1S(QL0 z0xFb-NUJtR8;{EDZuT9X!2`6G`DMwE#5^E&@A#G)(^(mDm{qHn;z`U?u1G9*}j^*c{9+dR(0D!BHT_~qZtwEmo zDDP3KA>8^2GNEl#0ELyK3Sovo;-=LI^kF1VW;)$)B(ahLC8Pue)v;c0t*9*y8C)`u zIZohJ;LsA$u%D5@45gI20S!%dWI!O8X{E&mWs>+7js*pLZJ?3^av{-hNw)CFUbvJ! zbWHaqA)luzU9Ut24N6x>3{Hic&|o?WklA2cJ|$V)yW{x7s#tJLbHs%_&Z!F{NJ1RS zi6K(~fFlu%5s?8~ZOtIl&|xejS=nBor8*{-a!Al;8lglJK;yDxP@y0ww+R5MgiGKZ z53B;NpT=sB+I9ngs2=lv^yH?%T7g_AlfS3FIz|9OJmv^s@rev#@;n-y8;$63DK#o@ z=b9D9FjD{*NTQ!)1ofGq_J|(K=G=FcNhDCyu-SxOc#|sZ^lQQdm%x6=?0sjTg}S*x z1MCbJ?aH9_sFx(6uD`{d)LG9j<`L-$Btcl$jYq>JfK80qNu*-CUa&aP|yQa(*6 zk?Hi2VS%`Qr{BkmVDBFKvE5TZ`$m5&(+M4Z`x2g=lzWBN^!X*vx@zq!(U}GyV`BJ) ztUwY#JoU5Rs_K4*xw}2?v4h?7fHy#W10Qqn#axtvgsAps5>lHpFd@Y%E9R+6+$ppA zO;>5ebZSK(GlZ)deCzX34FQ{wTZgoABGTByTZ&K&Ps2t6qG>=I7r`EDYkXZCWtZsNAd=K(0>Tsc$K!4M%r9|Jsx)VZ*C zBTqtp60$w_2+~X7R@FiaAaMcJx|v{wL3->Bc|;j0KgxF;eIKBt}mz-i93jX2@5 zk$97Xl_z`aJkeH0ASV5~+VJ!xJQiu*l>w=&ip&2HHEi|ip+UeJ;`TOQtfz<~%K(pi zx)RjdB-eyD6z?>&Y+n~t^lv}guv;X0I^fF%oY@s>TjP`r_>;+HZ1N^ykmsJXlrg;CAhkc>E z`mQOz&;}9r87XxOHXXxLW>Vat-Th%^pDn4vBuMYxyp!N>sVR1Y!Al_P@X(4zbL{nf zHoJLd%z-BzG1&-xlu`_t7;zSu(SyHp_R3$QO_DN|MGU^7OZ0wnsbUZGO7ib?3$%?PVhTW622JG9~(!eq>rIw-W!WHcenU@evuttzM%os zZ`}4i19ev)t^M*vyCN+LJz2ewI`(PmXW7q1hHx7<@D>2zlVUSsyJh@iKFLf7sPhYX z0Tg(rvl!L2=5y$HF_&$e_Uh2-eOiH2S~vB%a&}IHB#*(rz3t-&-!=^2RlBpGHiS++ zTjYW>S_|X-zIF^5JesZe`>a+07xOsVYPafP4h#0YVu>LH87n4KkKAk$u=XJDd2Is(_J;KX3`J_hQ z8=VtTSn(F5q2NOZ?39?_!&>*peBU?p3Noaqwttd<99`Z=ZTL7tM7mut4L<0=?kVE) zE~VVTtCV2$Rq_BR)u$uX@{nZuVQ!M8!h6+J5)7@%S;1!N%}kxH_Y$ z8Mobz=r>nqA%j<~XS0+jp$qI0LlV&-7rjHmErI9uB1qd%)}kie!*wbU|MjBM5XrTf z-S8MMYS3@=NP!lms_#3p@zn^)#`guyCfP1|C{w&q%3kA^`Qxh}wrIV}a?kp$3PsN=cv_GjML$RLGppo@<%N}SQp5?M)c}~D;%Tirq6I=Ly1U441~1WRJ9fC>TL<4I_expzu4TBXP)AYN zFu6@CHs3!XFBqSIG)N-`xXv+ez`hGUALPvD_BgFI6^{j2v2LkHGWEhnb0*hd?A_ea zvWx;n?&TLP*~LqJ0v@od{tt5c+;Z1LewZJ5fskW>MIsu}3{vEb zRS4Lqi4fflW3)*iLt$8}zV*JdpSu)*)UO?yZwY94oi8l(E+PIHGvkj)0;WVsZ~;LE zsg_XcdTY(F9Y9y>7u_a9&|M%XLk%!Wnc42Ce`a=t zrOGO&E?YbS$H`1k4VZ|IUz!t1r7e6im)OWie8Wh?p(il2w@k;Cc5T}Zh|mO6ZH;E! zxk*Oq7>~qz@#4^wZeIijj{EVS0K!lz6%^_1<1Omxylknr>E-0TkPhwEyhhYY&$wN? zfjKjR(v7Pf^Dd6{?PzU70huI3>8>WOXgw6%$Z=Zls<0OA_j!*Fi6?VU^yXV5O@^Vm z`;^+m6G{DW$0kRx_@)xyB!iH1@3Rm2l$v;98pcnk;$(DbZ*g%MFiq4x#{$(9!5(qIrRk+(LOc*)HfrZU|3AD|_fAAeUz0Zzog1MVb~yl^5*PUg&_M=PDK@)oe za3Jba+wwchGlfDWw?>(>_%HpVw+X4B}S+wkq4Fhr@lWjjHsxRfH~iCg#0R# zy>Zvg#nBa!3J)(!$#`Ywe34K>P?BS$L|7rx9-HNhI1_;mRrU>8DD;8wVy9zS8enTt zUzisGWu}EOohCFoBxCJ0(~SUovpMW0d$iOYF_xiy#wEo_%Y|EN3*l=;pl`I44W5Zf zcg;7uzM<>bevin>!1@`}?DjixOvL_QN9R`2x_s=thdhw<%s)f7@IZ zQ6>+N!6y63fu#K;_NAYMDComZRsV@5NY6Ghn;3MeKu#Zp+t=?fza`{o-VOcWE3T5o z5}$j|HinlRAYu4S?Qt%rw{A1x4vVukDi(#H8(}EU{Gwy4=1cu zbG7y@k`(}B^~)+$EAhQjT=x;BKCm@adEAFI8LZqV07WfB7=+T;OeEsH>(-9PQb-nP z9A1I>WzN7324ZwdQ~;>-6O2c<@CG`*@^n&QFvzaD!*n)Nc6A!13(}>)*)8mr$fRje z$JKll-Z6p?UX2mHwElh@-A#}rZwlPEVYU0e|PY2!gCZJxeK2INI->(PL71{8Zd ze($bD8HB1mghsOyFGb?i)f|K6!z#U)O#aY4e*vZbJXsx9k>IVPSy28;dWODUc4LX; z@vZ{gmI4vV)~q0w8PH!jk2fh<*|&FjAXx|zCv5khR6Gbq_O5m^RF$DxPf3-Q6Rb`~5>5o62a4LS z0UWAP3Oy-KY58D>(75;s{JjDzwV)fqU=}woZ2QVvS;jb*4QbYMWkJiQ=g>h8^4awft;BUtLsinBWtO59L(s`1sfc>C6p{F zp|Y5FBF+nIirc&=r>rClL}5pG)R6*7o3+=ihaPfo^y#@^_Oocqo1ADWT!8LC zW^mytS%LNSMm&vgs$66j=;;!yLSPC3f?2&Jwjj(RV_ZPFE(UHASWT6qi4sLKPrmdK zc2R%D>w_6kty7pC4JBBS>l>5U_cj4iD&|}|n=qT&bGPv3jYR&5No4Cu+>4mWwx;4f zxCx}+odmIFcjY$VEjN1Z1K~w7>B9w1Uxk4soqL`^Ah1o3|v#21+vt5+`Ji~!9r^;mLT$yM> zB~oDIGyRC~sfdeXk6`(WTy6nfp=`zb%vuI#T7C$OQTYQIyj*x{I+K6b=I0~p7l6p~ zJ@J1a=f5jBu(5OeSHVGZCvKY!&cCnEsGj~A0CVl34SfxGb04YryntgH?_(Z?qei^R zc-UB;hI`Amqp#;HQGC~tF92--$T}mDGLguigf;6GyXDWmylte1^0BIhTGmJN`+?o# zO_j$#F==Gwe`3lq4bpNk_J8fi_Z!5A{`ht=11LxZ=I`8L|Az~5=S3aHd!&%5EH`oRBV@uZeT^D)ofa8tH2PVsZxn7 z^<#ckuRN?#vGkv#x!N%}xf(C%)8km0clgG`459Yv9FRpKG|oB=I#{C>GV(jS-7zYg zfrho5C7u{3jg6XyDmrreYnl~%di4(G-}Pj=ieV`qRUy=TgxO;hI*tvxN%)VW^8#uoC(;1#p(|b7mG@e)ieM?C_fRGGW9v;g( zezaJH95UH60wOz^DYQvUGTRmGshC!NcjPQS(!0*KvI2jetlMQUNAE{W1!$bmBL?Hz zrE3RSez1Z(qj&8@$%1I0Zi<0EkNqr|vmFHRC?)u9C|&C2=;?+YCg;vYR()-Dis*FK z3qERn4<)X+2ZBLE2nWI$24XR7lz^}o0DVlj^0ven$N)`{cZYT%d{xNC>a$25E*FCXe>h%zgtd$wkq+uerJ5lzCr(k$cfEk|K)f z7x&9XW8FqL`gKtaXRrUpj$)Plmdz2TJbI8Yy0wr4`j-;%!>MAK%}UOC@wk07kMb+) zJ$RYt;tfPZ!hZ(akrR(ymx3r-NR1j|_<^WZqBM1!$+%GUci_R05n-4+;RyJ+oPr)6 zHMB9wJ1qr`YBoJR)8MRUw`ro#pz03Gpp|Y!Hz+Vtu<$v%=^15xsy^{LcNBlg3=6JnoEl$(32PI1qgUa$zYI2b-u`jrhY{<&C6slCKP)J9^MhXZep4Y* z)!<6e=T2~vSf49dI1GBhN2L9%a&)Avb(d5NRsEppM2@wKu&9pZqD2c&|EW7k3OM++ z>pL)&eXa2L^=Nl~`f*xr=c)n-qlGVy9P~ogud#b!x_tM{--HJHr?;L|ud(bSK}DJ- zCb%}0`Kl}&_)lXTT7Vm3gX2xlE&UsH(yTNZxC-WI6VpUoOSBg}DyESm-B5x8atdJX zN@HT!X9IP8NJiR0G6@_=6@!7qfH!J#2H?Pc3*N5FZVot|s8s<+7uqkK3u&d%A3&mz zUkBk*m07`557l`wx(a8+EHydwMVZ#+7S5pIs7npeRPo%Z?;iKit>?6Jf>i8l5SM)c zMl4m|m3;1?7ZaS9rvW5UeqlY48a!8EyZ@{SEwF(y2&zpZ87i$Oi2_myU7WM1S zD6c%>pywkMPIBZ>Fm-L7Q>?17Oq~lOphZeRdVRlUQA5@iQ*Rr+-fz@OU8o|$TDt7r&B~g4 z0>Q!LS3XERGeD-BG~n21Ni2*QqWJC}DlBEy(uasBKZFQcTzI3HU7DPLVbPIrO~k&UB|DuzE3~3GbtTId18; zQ^3Eot=v2q7XKNHmEDRoqiAY!6syf^0)MGVzA217u&>B8dJCPKXbP-+cZEx&k)@DO zTQ*POxv^J&dYOd&O_wU~I7PU?rb-TA!^7r^VS?XvvBTs+0fC^5wEh?w_9+x_B9Bz7 zMAAd_q)yHQuuz;fIJ$YHfxVUpOi>9q*LbKAUq4eTGQ$Xwi4lVoI~XOvk+O^CV*H(pHZ5u0%$sH z;aMNiuizw>5ccOdS|<~uc6CV_PlR1UT96IL!7wM)=dvD&ns>YfCQ*W)?Y1Z*BzC51 zV*_q;$BvqN%}t30vU3l4 zoJ6CTpgwxhy)$ulLUN@CH;uHrb_^0nT+67xIVt&TTmV`hy+ePoh~6pC%q0y*p^Gji zFOClS%U2G#@yG3cP ze?_O@ko3kN#KLc_%z28`=(;SvJrZc393y{P?q*z{fo&LWQlA|(@kuMU^- z&*Ie0Kul!uHsQ0HLTqh`$31kIJQUGpc1Z-V%@3GmF+pI8$I0KE0mwt;NQY^At6L8e z?8^P&1uzo&10bP@vt37@fo76I9A@}9qPoFQ^t2Jw(01$UbS8Ewfulr{!sOv5I^sER zE}Xes*03hMI{iabA=Iy`znN1pvGzSYaMa+RPMaYjh*Z)#-I%5vXz-Zehz;hV`+hU2`IG6{4IIL-R3Nbzq#cAHO#VlPin#&EzQ;9 zMbH?6N$w7>IN1>MGHB2%J-x(-^4)T2NtmGsG_f+{hLe}8GS#N_9g*w~&?BSf4ZhMU zr){WB>Tn;6cuYHX#rp^s%&Rt`?nMZYr)*i$veMH(j9Fw82?_iqc83vZ;B!3p~r*6+c4!u*(y+lf^xI2?Wv zn-pxsUUo6JTRQdTBIqD`2$6M?E6^6u1e?h$JqjdM2(h4)o(Pa|0xkL6kxzd@MrC4X zE*+9Sf*($%l3`U(?=FK1la$)(Ffsly16 zF{TKpCQXobNzQ8+&MWOG=DRf-cu40u;SP@zyqQnDWp=IyygU`73Lv zBqGUfSC^=IN6p-{9H(`~!*C|I$xpxLVZ`*5|1aC`&lY}14bsH_VAp@Q-Dl$X@1r#h z>A0hI#NIP?3};MC3+pGpCtLRfL9-?Zgkb@=e>P0C4O`g_q;(YX?q_RdddU{rvm}B@ z7z~t+<5Z26y_JWTZK~ao`{;F(CaP$z8Y@+&^&gI1|NK2PM-(;0pRGQdBdb)i!(4ke zTl>IPJ|17rRJFzoA*CIU<-fg>N-gVIkMx$V$!MeMY1Fb{USuN9k28c$ zvb5ir=Xh(!xFz2+ldrKW87^ovnNI^W5F`sII&3eb|n|n?NJshZnmU}XW4>nQDZ!FGX-bc z0^#Ok<6d~N%v=>zEZ5W@9j!jPD^H;iswwm2uRX7gB{r*dzboE!Ey-zwo77YGPDSIa zpDOPl4JiP!gXGp*Ghny!Ba)|Suwp^e+1Dz~mk?&@MmXv?;f1px5fO-e^d|uy8~KHd z^)S4NgiKI+F!wMF=G3MCSG;#5klc%N#zZ|pX4SGlM6;);DN{-T85BS$^GT-8D1%3C zGc@%El8e5*M~KHO30F*wEHJ*2XT0oEUe}xa%DdDHZyAvUp=mDwAMH16@rENGRbSsV zvmlN$B^W;ilez;feR%d*<}DC>OwDnKyQp6A_(}Egz~{24QEdvY2GfQ4b}vMl-spsH zR%OB_ax2g8z5e?su}3Ka&3kY>d)YC6fP|Svl2wy)TrJ%4!a8YLxv(o~D%I0KwrU{m zu@K6S5MxAe!0g=hdz{+rEnq?L*DYwNnMagqpMe^eYx5l(T37`MY|4hr8U0%H$tc$R z{M!Suxym9`b;=K`xHaZ{U_-WNf7&%BVNR=F9iiKIq$h2hoq4^wnM0`=WZXftPX zV}})%FUp;Q8`2mIO+0vW1oEZK^e1V_n4t?A=3n&cX#2yT88%`0eym{huDPwJy0fRc zy`taUucC|15*1`1CEa&(1lhFYk78BS@>W(omPh*hYBQJi0RqY)k4V-?RjZ7^!*6qL z0kc$XW-0J%TL))7J0P)C`m>BJTgF)d)C60dY1mRV^~^NeGY3ErOVQV6A=)3;r1YrGk}=o#9B zh@-`5qZiTsVvAY(+uFs>LFfs02%8{-iR1xectM26$#yXY&m+Ogo$@7sE@FkhZ`g9g zge#^`>kXIrI|vLzHw5?LLTn{MXpQd|i(Ee{gFgK!(D_Qj?HMY^$~o^f@$VZ+=a3Cm z7xLbMY7`v%cycktLXqMJ8bu^R?boUgCAU29s&0@kiB#3IRrZ@T{;r~okhosK9pU~e zKYka_eH!m}oDKo`7(y(fU{K)}W+;G(Ru?Q7qS1Z_p62>uN+56hBFe6Fo4fZArfBm{ zgmJu3QtNJN@CqbIhPdl`5S$Hxxi|2c%l<{Z?FMXX0u!b+4r=(~`_*(+0od9?YZTK} zk3{UTJqmc_X`V65myRToJc%aV*VQk^SPZ(9Gl!c0G#*!WGyAOZ&Km79<1T=5q{%SV zDt1+Ima8}=S_CXXRzNhkROIZW+=_LonfkdQ!ERR#)il`ttGm^s8!wW(bdgZHyo2OIkgzKu4`dFhB`aaQlMTN2yogkTrm z>p;>hu_=H_Ey)rl#sL&lkDPGG4K;uH51la8ly%%F6v0fm>hk_-jA9dZM4#6DmN9uX z@aiZa>(~q{@CP2sGK}jqIy201qyHI*J(KDMTS{U|um#;x(;9IF7sOo2qU3X*#9_w> z`kb{5VHek>6FS3nw-U-35wFE^IPe~4!xg&`_mVG{R%b{9?1Sc%I74C~XL*vICy%~` zJYaq;P9MDeVu+kDftom;=;1So2uqzvwjn%#{*1fyfes*aI4P_SmN$TS+79dgY(92Y z!!4G_XT`I(e$vdRc~xJ&1wz^YU~Xto@z_*M>4NH@~jHXF5W@*0P<{(%-5dYgR>l8&iyw)iW1;?v4~v3>mq6@k2eS zl87YI+`09G;k$iyWZ3Z{E`ce`dKRNZ^|8iUy72m5y3tpsk`qnrZ%I# zH2Hr>d#5E)fNe{(Y}>YN+qR8W#wy#kZQHhO+qQXE$9?G?=RE9){(^kSj2ttDCXuun zHYoW>$`xH%rO#SR?rJ89T7T+6&muT+S3gOc`}t%|wbg|#;7 zA`9YI!~Js$Vtt>ARqW|f0k>|G%61;E4TKe*x^T7<|GwWu=jfr%5S8|^H&we{{Wf!) z2pz_L;nLX8ilfDkKjPfBBoLg6cNj_{Bs0p5%)0!2nE>@NLPoM=h+UG6R;vzZJc}a0 zNSbkGAWF_&?o95}`dHy%=T#tQ3|%ZO75;L#PsBNvJhm2bU`Wc9-KF}|$k+P?<7IYvx;19&3OZb$62kC8 zZWVY>kz;>0pPCO|{P~4iI_bsN#rhV*KTZIae$y~6Qt>6H=OO`G5hbc>9VO+Ze}Ojt zChx3BpWv9cE5L1xxat|;@5)8nI|*w0Sa?=mjIA4>k}J>TG!A`8Vi`}5drkYtaN>YB z&7`vG++^I0ofIkDT3|nF;>WPkm)~qthM4g>g*x3eJImwt%`ZA^SOGfsx5knI{s_d% zqveJIoKGPlR+xlQIgnNFkJ?WlRrrl!R(H~``pr$24k5qk93qoiN7Q#xvyF6)9A=LE zWEz$7xZyR#cFwSZBSE*|Q_5eDSC|dA^SL*l(B2pZNan83| z?&qQuj!Dqlh{2`3w9(JkH)(xob}CK&i+Z+GtuY^T#31&I`J(zgomrRiHL-?ZuMpU$*XD{xxnsa!4;L}15yD6C z%=qFmpFcW()K13{;rzgsIO1=45x=#IV0?dsyGu+Q&ncW4;Exjsxbz|f>KQ#q=Tf{l z2KQuZ-VBTg_c^P(%(F65GpMjJch?)$X~Wi8-B|IBBo?{m5L17wi%~vuh1Q~YM*=rh zSv;z~SJ1e$T8w{B>C;i7aax9-(k2an^U(UP{EPn66;!E z&srRvksrEG{M}$GG|2?fn`rJY+GkpT@W*wDUjwG`2ExP1bTED%&=cEH0oRZqbks6b zkqMr!`Z3L2k{2Ac9RL+8SN{;YAXVlx&wO`?HgJR{IX+z0lt%W(g25ZunU!9|KB%vp zox6llIGkqS*p9R2qzt`fN7K%aSefGDlL|70|6}kF%O1(m+)wVZMaGypis(!qPCLu$ z(noNSsSdbwAu%-njWCFWJZHapu`4GBZAK8ac0n`MwcY*G8@5HWdM+#jZAtphufLP21Cm-5{;p^ zc+U0Ws79I9dItbK*5x=RMaX`a!RIeafu-oWk_pIbse_BsQhjo&NmJ9Ri#NDq6|GO% zP==#9=eT6Q!_`~|q21||%&l~R1-I5AG2jb&7&En8n5l=J$81r@#&k@lHZawZpK42w zF*~{B(cz+dtCZwn1|n&xc@kAnb0F+B!5Yy^TtLYeL!&scBI6*M4AExxuz^MdRZ#Dk zZ#gH6^1R6OsyrkF^aGQ?-f*>q+P#nRS!`gfX0IN^tF?i$JuW16H=yjEpbz>a#tUmA z%r?gnXorKG|BW^GcB-nVY=||0e8F>}-4)kO{K`4zHDlIeSTikF1)SNw+P5YUzp`yD zPU8&epjeSe{*2J*4vhx{;;dxCh-XY{d1D2Onn-I&4ID>;`wpr)Z(rj{w z?wSe-1fIl;VW1mCAz{0sp&iG4HMfYk2NX}c@(pkR^;)kTmJ&!T)*Z!=^WA|nPmVP< z+v4b{EkFd3CF(oTY!_c>@;_=6y~8+EiJqVMF9cHH%8H30N^>3jaaP8|#;*;E7z#`7q|zj5+r( z#x=l_uM9h10u?>i$Ou^ZI=9DsjGLfj8G&1qP~G5O!}Muj=^^NA3o99TCIt+6r%vj} zy+6e5F+x+yX8T9W4~;y1haX{!nu{(o>H+qu@v37E^8X8U5p9Ps47)?Z*>*ZQmlHW8W8$c07INJ`OlH(^LjX5=mSeaFH=Gm>+ zXeT6O71Ki(j5$^{_K-#z5!L<5>}6ZgY#DB|w^sW8-1OpHT$cXNVVs5OzZ%9lIsa33*V42*`v0AtQ^IOCZS4ny ziW{xt^T$uH*!e&jQlM1h%Swm)kW=oy7w~? ze(s~uuyIRiB-!8HA3HmzU-=_o;We>JGCK!D$g$}(v21Q4=mFtdd$+!u;wjCsdWQ37 zuU*KCVQwn&>87t<`9~seU765mwy#jK2&T|q1@+xTg3EHNxVH<7xyoy*n|^j&-L~FRCdv8osd6fL0xbkXKq(+s zfN>%&P+^`;eDrX!ohEQ}4);?4#FU!CHpfif3SO4lcCD4yWPooK(VPvH+JJ0oS6GHw zmrl(~;8py4m!U0AnJwPuF4JIxrVu=mBj+bo*4CwMP+_7?BL`?Uf{51<;{9(H6m$*! zSwX@Q)Zuhm86s2Z&SoyJjk5$oXxxEkl><53x&Iu3CE1+`8J9^Q*DTV>y|kr z`_vpvt}J6O1TOXL>u@daGNz-{vNvNe*6xEES#&4J>}F&CzM~GIOB%cBx{SnVX#!1U zR~|w>GZ?6+4IZ2`=qNPFO6n)r7D`j+n_m0-=-++1T$Q<2ZF;LIds+foXeu&2T2hQl zaHxCKWOU(0r-@34Q1l1#2;&FQ-ona|elRH|yq>tBOa>cCUhzyBxbm+jPL5zCCyb2m zql_6|Nwr4tX(&K2`GOd}E-|MVHIcdv6zMs>%{7gEGV8%m21G@b;DSd0leo1v-R7is zw;7#JOnLWW;;1%uJLxr-HAbPf<(1F94KUHAb! zz8boUZ;*@A(2_O*7=32O6GAf>;m~R~6|L4B-!v0XNb395N)T3K9ReJqEzI>fGdPnn zKso;rNni*2HNm)+fJ{d1Aw)EZ{Q-_bmC1#OXItw}c!nL0N8|NV&Djs{Vat)K~f&t$R%Lk$LU>G}vwVo6gEc z@?A-5S2EYo5p|15@WT#t75@9}{_xSopY(a}29n%6QKjpyyeH*qjl`5g6Z?~IlhfeQ zlzY$6wAmawXyi5ejmV)&qoXSeEG>cq{z|B>%Wps~^cXh&rG-V&Yj)P*d10FUZDFtf zy1w25;5&yl@?3?6dQ6CI#ogfo_A<9lW*HCJxi)4oPQ}4}ekij1c^A{Eo_LqV>u#Vk zmM8d%kBB{X*XS@OA$Qd_AA?;TxTBPzPSJrQ)J6zqc1N_o5amP1G0aQH5lq-M_tu#^ zI33I$NuoTHxee|D3Xd*LR8p+V(8cq?z?C;LmJea>t0x@J5n0gue^PD%kqSrqbo#s&kDmevtS&zniX=H#f2bI0Pz=7mX=rSbH>wEvvrRc#Aln4P~cs6Iwu2h2cR7U0I&<20M{az7!%s!$|8e@$n8k} zLg-auQ3XQg3!|^RDPfk<)dqz_vKfOrlKx5agYK18B@S4k%&Q=4t)$U|+~ugjZ|J9E zBGh<%r|tk)*+=A5o{0Q>TCFb!tsc{k1dYZKicCN)3Pr}`_>-dK)ZYjNslVsA2k8_* z0mpYT2(kAPJQ5Gkdi%G9s36GUTdswP5|6PgU!8*qP`O1{T?>Ab4b)UTUzvORb3J)b zV?Zs;%4pPob;jIRkwcZ8?+)IF2{{x>F$FJn;#B2Z_-r%KDr&FkASG_aCp^FQRb_-T z=vI`b-Tw8`FF-q&S!hfRz+TA?u%OvUVx-FzX#o~f{`12tV`-NLsV>)5WZ>#M%82X< zDcwtJ)uT@FFDNUyexsH>;6#5EO-g}f>O^{aWD=8#GL|)0jl>}vsX2mC^pMH?>M$|n zkIJai+wed<{X78w(0i7J8wx=9m-a*G+Of=oPbUQ(CSye$b56~p%HVT&C^!=F6q-k?2uupW$v#&zVeG~X+VeT{nlca=3CJhnr z-dad31^PoW4&IdhK zs53xPea7-J3LIjX)f7x_&=F~E!A}GVAnylD!W#&P^aXZIR zbjxFqsae)d`8M%lSxHYfLip`RVUYkgo&#%8U>?=`X~(Z}d#VP=>m%-@$i}ViplCvV zweF;*@2G$Pf1ENQD!Bbs%*}(#!33j+_5)0^mE(YeGx5ipQ>>fP6`HetH<@qnQ4=mn;RgHe_^&T^fym>6=tGjK#NoJShPR4>RrGwBbt z(@fG!A@eN!(d9PgJJ&CNDvg(dT<8i9(?BrguowHeX3+=9S)+h%XsvJ6*Q#UR$hJmB z$gBy7yjE?Gm?^*tVp05BIXQ|vZ06RRvK)H8PaaND7X=Ye6Oljy{XSDtxuU&HS?et; zN}mg^6C+`K%Z0Nxu4;_=u&0;)m{`F|cw=?0=7b*BKFcVT(aE!l7wc$)}19~tOxzoi4;H?@A$s_1(Mpigr-+hq{)h8F2Q{I%w!&329eVX~rmz81lEDBHBwX`NT{ z3hIfK@-DyL6)|hI>yh^^T#mrTQ37?Cog?Lty*^w&24Vu8tf?d_^9h$=RUT}+Avb+2P21Jq#m>Y%#@ykaG8U5 zpz5Wk(avdopGSNsHZJr3W%mE?x{}!${-e>iT4OV2lMTW9Rvp4UArO^VX~|}Hg9UQo zC|@=TO%Mr0N4pbEEk#9lWxe+n#@uASB_U6=zAu6(G;1?`FuuE&_dNKHyj#WHG9i-Y zmCf@uwfXg`_`!tYf#G$fHD`(kGo0sTWi$5YG21eT;wpH5@sGB9$oh>I_Y; zc8WN%eI8na&JRN>!cfz0G8z*~g@l<65sbARxbOrm_r0r$)^=J0_RA<)Hh%ya%fmLK zgN|*G#XWc((p%Y%T$Hqu#){AP>H-Xy*$ zu5OLc-{19xWDWpfA2q^E8aas&BZvek&DTg`U0*$+b#H zs3MEApUTz@m=1Potn!kGf}`V4wev+suH$PkRtR2t(#gk&N*xLh{_w__AElf_!foC9R=yYV)U zDDpJY+DN4wkrJ*@hzH#(m1x4Plr(a3P?c%`*>~|Mh^oOPf|UltW9k@`zQtqTauWcD zCtOtMyMe%5)6Tc5-F<%2_Vl*F@ z)^NgtlT4sv6vR#j*ZJGF94WtWVymui9Yh!>X?Zz5!YYHU_+~n#)+dwNtzdQu7y+r@-BE&*&iAmg+NkiN%`oj2NZfuMVDLOoCXvEecTh|L^urFbpC9(T@#Z+$x>I$TI*Qdq*MXF zMEV-&eDz|Sx{cGugMoy`NA8`XKG~p>aj(WXB_m`xwH=>{VOdz3$LxZFRvYIg8mqP- z>liFNFit69_Vbl-y)A6gZv#;Y_I=gu#tIWA3lozd<|4_m`TzMg3lA5{Cr0x-X#s8- z#iyI=X$ZNjtFQ(KtyKmGh4E|Z9U>{+PXC4llZse7j4w+$oqU7~=nOEX&d;~HfndQk zJsaNmJS_bebc5dv{$H?;Ht%G1jFejfk$h@e$C_M4!qi0k!QrsnijKYgSl&|O66Po;;I)5DL z$D%-^;343QNb@>jvGVAcQ~E3cWs<19L$*wgf;?EJX2ouyQMUb7rg4npl#*N1L@4aZ zwX=s=x6{q@S(ylf)ZXsAjMCMUe%4(G)lh|~mnO~xNQ6mz6fJ#fJ!p2)DPBRaZR~yq zsf=>pKSM#@*XgXI1M0{)**~j4lss4An3#$#d?K)9b(PtAFDv+QO51BCt%11>%~G@a z`=qAo>ZcACoCnHT1RgmN>glKWV5AV^FI9Ma6?hz#k{^ahLHlr1y4nG7u4?bIh7#GSJ-;PM}3_M0TS z_c)SD;l&Yefi4urfa8x?Vr+#zJ5%Gy%xd?Egv@?v@qv|=;mS*5Zo!RQX2KbYX~tLP z3dq+hdRdSpEOkgf^SJu-ePW2nQG!Js`tq_VkC0dZn9-sp<|veTL`ORyrd^-oM_c`! zY0DA}#o^!ljWESIh&x0nkhV>95bgex8j;~~oe2i}qLjm=_m+0<)_gkuCf8jRYLisP{ldUKKqz#?S_V=|$HfEO92 zaS@Le+Rc|`8gVX?!SzKNR>~pbZZe3IIR17ZUlbAmx8AWdsp$!$D%cN|yQU#unrwtW__8j}a9_<4`s~>oWnKVt>KQ*gS}g2G;z)%e<>=i`}q^ zbR+#ke_)H;KLpGUk|Zhq)(DRKwMN&wVw-GF3(6_7+&v22NE{TUqmZN;FOA3M(INew zwO?q~;G7`*jQ1(yxw&_+Rom$3>=CCW1{%Dj5bp022*^Yel(>61a2uj_6l^{)1oDDw z8&`G`%(Q&koY$=mLV~RSiE|1Xg@6=sG{^!MqYYuv<=n}f|@xHu${;IbRkv{%o`jTxGpcncPo)76fn|-7H8guYjc~lE> zLYK}%(m{ZL+i%E}JWfZ6K^byuu*YH>d6aU$M zc#sUo<8<#FV2fBlPN3>D!(#BxrqfrwW&}@udXz92kBm7##S)_p-zvB^`8m2nq9hU*Oo z4<%FkS-Ni7#Kni+coqo+eO?CEX^G2|qMQ{m2RQ7A!$~16dP}0g5m^@|`&>4slLtXrIx*m?qBb%EGe_i2*KGeK7~V99UIz~9yJt7=uTB4#5GAeF|pKYp!> z(Hgq3%Df8&3e&Ko1XH98~s(I@^t5SXtCny5>GEJx^nX93&ZQvE=;uYZgD8|bK z$yz_v#hM^W(pqEjUj5)oJH6(H>J!@(j~UXsd>3|ZT2vo~dRS9oZA+ww>xg3m3!%zW z#V*IPybaQ866lx{jc4WYciyvL$ScCZ_bzqb*AWRF3$05Ik*SjXv{Q!ekE*&W6^+RL ze1`~RhgG$4D3`@W&p^c=&x@hDab>-1p4%2av~8@!hO;aKU`g8O92ADRE-Sn)$9%p~ zm-+5KZ?WT1+45wM)?0!4h#>WDJ~k~xFCW(PIH+HPoBusb}_pYN&tuAw0Iw{W^H;n55_vs zQoY6S%sZ?<_*;0lp8ierQW%)0rE1;0U`dgW#>VPI1*V(%x$`&sx+eS}Mki#M^zV!?Cki0E9@aIHq4_c<+sBX4OH zUcd1?1AFvnv}GdRqtai0;TDn30p*x_gbbY{Vd;0;#FamtmtT9`j@O2fw}5%})rFpJ z!^oHm5A4P!`8#(OwMhL%%b?9*cHfBDxZy_@+!!dzo}?kE&M++shOQ7E5cJgyM6goT zY*o4M!?4R>merC%pfI7itQ%@Y$c4J$Nj0}rZ@phMk%3_=z z^~K?_YR{N+8SBihedE@ljHw4_9lJOmF+2~@{o_{JsWNixCg9uQC}D3$_E&lG=iRI7 z?BU-{bPYP68Nd6>^%Lw`mqPAX_X35Rja+rh4P%KE6hP>rDbMX97v?oWbaR0XQTbQr!4A;EiX!BQX=k%n_CS zuXF+nA*$z@$H|6!F;AP{Tsw6?d2*okK!#uDR&(3uW4kNxu`~BLWI^0_@RFvDed_EL zv|Ew0^qhYUPS3f=Qa+nKtsuaesdKH{Xqjf6O|#^_RUeoIpx1e2NzDt;@FwK-F9XUMMQWB*<5tH)+r^luvM=C1B4+NQb-hV3_5&hZ@?Ky?2$D zI)N9R4FR*|EB88ETzS@k3N^Unbq5~A(H&V<3o?L_+hWc5JaQ#h4U-EFL+R0~FcgriMhqfIp|UD~C3B<3f2 zZjXddzbxnU!&6W-T#qv>K9@M{U>p2fCFUQ}PcUxL-+zLb3fjyp0OHg0F{MiH`e9(P zOdv8)>D)P;Az(5z@pLQoB5kO27aCVRoPxTh_B<~Q+xa_Jmms>soW)1u{VPGeB!EEx z2OvnngF%%hCtp$kJD+tONYGeQpW zKmV-Vwf_-xIUM~w>|TtJ5kf^PfG{2(w~9-6zd@^RMdIYOdZf232^7-(33i=kA%kC`$MJ=oefj7?<2~1h5;2{rfq#vP*?c9+!16$rb{@7rS!SDvg4ky)pL`zdhXfLa7aB~q<7cc~g3f|xUfRGk`VegKBD^CTi zrlU|WB#kY)bNgWpefL3zh6lW?+vBE_*(Rmfb`@q$Q3>wB5RZj!eeb>lccj9(lHxdY z2F;dn`;5jZv0l%#=+T7ZFPtTX329+@t{@btE!4qmPA-gCG0^m3<|5BD&I${B&H^@G zQrL0f_J?P5m-b1Lg7OpK3Y%qoBYs{lQ)P`V~6X<*)c{AG@YW;TR! zM(DN^f@TFBU`rDRy&q{ez~raXGIzj478f{|)Q^YyEkFI34PFwqlq-Uc%Y))(TSC_O zDXG&EnEcO7bj!AuP=??6lRB!!$%fK3TecJp5Qj?Jt)8HfTT&%7B*WFWf(rUsQ7V9rFL zjp1Y6@ghPU6G2f>jR5IcrDNalctME3)b@d7svk}pB?G(Mv6<+a8}*E0^_VdbZ# zntYf%I;dYqfl8l$kj3tzVxpl43pFMIc_eMqKpKW?frwGV;rs!G=$Q?H49r-5wSYS7 zT@1x+4B6PjmggOP!XqV2469-I_=O_`lh$oE+Bt$XK*zQ1z>xwQL(}=>qwH+o z-PbpX@E40Y5`n$IvC+}jZ&C7JS&f9jSkeq~EmciT(oW@v7ee>P9CDi3iY_U<7f5Pk zvW5x?yno@MPGj$!sk(J2LM5Nxbt%e4{mm1D5{Jk4ef{twnn2I?L9^gMn_#5$s)T9~ zvaReWWnRp->4&D`NV^?$L}f)&Ax|nbVOCBwnOo~P+k0$FzRjm?uae_05+pBYx z*Xb$H9-8LZ!fTm5UVQ#$U2*Eizk`4Oe8AE#o-4U-Gxt4Gd2d+*9^As7m>@>mXWmN6 z>Y4?RYS*C=Tj`1kr+hq(L+gtTIHg0w6dI)O;XV79f68+vhEDE< z?|K?T5iah)m3C;?qX3sr3@pCI(6xMXq<4&~nQS_iH|hj3nU-kA#eb_|3icJ?#Zo(# zMWxn<@3@A6$M-LuTUgw?rIT$2@>9+vqTH~zsPmI(IS4e`tkh44QbVj5BX*CmpVIsy$OajQDP79gYr(UD2 z2FN1b1bhV%k)jv*^j6e6Nw4|Qh+__+kynU!?GXmHV8^H%J7b?y z|9W5y1K^Io(Ji~1gB;mw_b6C4q})B4Ure^+L^$JG{mP{%0$6g3*7tx>CT101jqYi2 zX>;XZAf^0Uh7uhQifj)V%(!4A3t5!wgSxE6R{;x9prmp3Xkhu+HxDA^fm~LZ z0oU2@T)n>7@mz=7z_Ie({|pNH-FMI`F)IB#Ebjp4V@%gP#{HNdd6m)c&S20V!lsU< z(+WZ_q9WLwOYcsYdYA_eq{~RF(CSctw5LF8*pkTKBJ645nT2bQo-8p`AQuHL2p`m7 z1*Us#<}$mxRA{-PL%?_FT)B|@^7Jg0AVY7A?1$-XQJ@wXk8sO1b(i)KQcjKJbF(7I z6a+eMfgZhj)73`m{Hnz=A*w|v{ZPC#d6ZvE25;f?+cb%BD%v}^H)}ZqfW^Fzz{b3d z^f4r2&W=g;+`;4H9IyD`{l~T6 zeX(0fr9_3Nfx|9xVpBay@qmz{YssK}!we%3QS|4Rk65&1@JyJCpcW4dlE~I>xXf}a z1_*F}BU!j&)6Gil7O(Uifz+NUG&5})%0|RY6^HSL5U^Izn$Tpy2YTO&Z07sS6Hqfo z@=8r{VD3zLylskF{RD9;Tk3|x8EfmxUL>5(-9l%=jr30PumoL)9Sq;A+loDGE0bK_ z=*GHj6ItJDmGyeHrM)cy5L|x#(+j&P&Box{iqC$?19q6=AY715-F{bN8+MjYJ00AS zoxZOSU-N5|hu;Q-rzg}*2NHH@nt8mCa1@+d@}^ee$uEvdXFi=~8#U*Cx#(pEnOIpb9nQ6kNms^bVfvwdX`fV=+ zja2{UM$fBqD^H>0K^EwU| z<3?ZeDaQ(z;uMXY=hu$FNVs~eyL?w*7;ii8(di1UbMy#A3Cw`E<||j-zgQJ5?J-e;cJTXvE?@;o5=p++(?{hfV}ZU_N0!tk0K3hj#`9PE zLN^Dx>S)62j|F@Al(}vXDy*JDl2+Ke!?DY$(TmMcmV5RCY7pm&Tu@7LJeXngJxC>EHzj~ zE*9>pdvUbu$9}s1d?eTSlY-VQn0{TGx710pijT=DB+I`|>spovypZsUCJyc9VMZZ{ z8X({xRsL$T#9v{(gX$m1wJyuLM6v=PP=dw==1jh;6kNa;n(DIS%uC8Rl_BC?li*c` zEW7B!4*E|&LGDHX#)102Jgz@^7~?|B1SIhEbzop-g1ZLlqu=hKmBIptl2{+j=1VrA zTP$Rt)W(#b#|nI*l)WnJZPb?)UI6PwOr1vX3#LTO{00beYtVsvcCe>4f)~po-%6#X zM*nv9Y4wyWNSRns$=XRCx;EWuT{Vq8WyucN+pF9w;0|6XJo8|OkAT`yExaZ@*M7@r zwTbJInPg{=I*6n>@!wTgeiwPw4CwU-vipXf)IO5f?nQs1`dEOo-So_k$WqDdb&_BI z@Kg~57s~i$=H4G-cd?}_2mi zM;rG8f5K%^8#puG-Sk|@vugh$b&-h?Go+(kJqfF`{^M#fOvY*qH?@t>YYbJ^J6Qe& z2?XGyGA+7v1x9CZMC9lb#E#5n_)#h!Z*)7Ik8L*A-~37dUxtGg zLG46f;5!<>vF!A)bg_Ug?qlQF->{9%qHLp@LWzL+zLZy36or43!9xm1P#v~C&sY2lGYjbTDr+^%lBnG9q&&)L53fm12y0bpVYwFhlL9s zW3jL?)Y_S`dZlImq5=!fM^a4YI(o6`eN0-~+NK{g7F{Xner~Pgc}t;67G)?uzJBv5 zTe4<=bBA1jqbVrVM4+z&N3x{v-nbY21G9kd2E7|VJP85!j@b4*aJDyf2|q;^87O+! zd}i*Y7P5I(W^b~TQ(}4(DnkFD13(`_jn`!3LP`-MH??&yQ0A46L` z*$u#u<=I0{$vSw5s|4{!=4)zz7+_CY)x-ITPYPOUCryZrvx6szuFxly`dmX%o~7X7 zwxcCSCbS2z&>Z^@D&4DUD+A(fW$FmpmCNun26fZ3)X!Hq-+QFIB^@mh^FYWPpCHX0 zsZeOw!DZ{5O|xuJ0`$0JNUTmE0T^cqdqTmDHe2D37gl%v?mDV0aP145)?3zLF&)9# zRBNJj%~A+aJmGsE5X(|F)TJCIfA4+pxke?~eOjI#tyt|+tdhn%k?xG1WNNg1>NBy4 zhw`_@dYj?i2O`-~3dA3uD4Z=V)|JrIttrwL{IpD8 z?Ln(}S7Y75wXdNOArM&CMryfUfi{U((~986$F_%BtD$piD)u(p$*trU;E;uR2j?=u zSZau4m081*9L>7@{Hqup1J5G{Ktq1?PXE^~NqmY6uktdm(9EO-d3BvRUId36iw3a` zJ*lL@XqB<&<*O7NnN#5Q*@usw0vHptscEU8!H&@7D&NilB4@OAg>zQo#!0y8Gt=D} zZE)&jdJdD+oqtXpKXSb} zXluYBXm>B3)FfWa8U%ZumZ2-}X94i^R!xrdH)S`WyA4V=U>%-24!!g)K#Q?x{$MWa z;uAR-7wDd00b-dwnPdKq&nM?r*kF1IUq$mz9~8C1@(flHzi&|Zo&Z*3`lzl1Ml>f# zJ_2rre5)Yx)Nn#PcF%`v^MKE5whv|`gOPdV zq~j%m7RrV@jAN;z#f}(0QT%pV-q9?p_&;EdoP!@LH^0nw~@R#$%2n5Bs8ASAap5{Kux4L;G@h~CGn)g z2yi|b!bX|LoWXRr;Wm5b zB$-*0-x)`Cn%Rdu5GG2=kb&i7W{o^(EspDJlYn4y;$oDLp4}(8Uz<9*h`?mzw|`Tl z;Y8#<23A9ERUX&xD(~JhW1P#O*v|JILyR8oJ|Bg?wD!0cDp0}PKyW19sq2o#jsDtL zIhec)W7dB_WT&2m$9mT7Y>QvYp)qCXl-i`~VK`4lt0hoUl+OAIYb zBxJLu*0rEVa&4Lk%q}|^3a)0vH0tKc^!J=K;It*y@mOm=O$U6!R3PwncjjP(7ST2Y z7v(v*WM6u`^G*zAieNCfbLrW{&owr9HbNB}sNBV>d1gOSXsavV!xlr+V@ThHC{!rZU6cw85@Viq20AF$DEuU4X7x8yw~7Gku1G%v*j=HiMI6Om*teO6Qw|gmY`Jg;Avey zF8_3YVs;Z!Z{l=pV4*j4*ItFpvUG!KB)_PIKzkTG(3W;`fig zm+0Sqqx9P4+4MCCZ#b#ch+)Ha6=BQUOQ@aX>s<^Yc9E6o#q@Xg+t<+X#?44*S~cy( z^w47H25ee&Ei3#LUnCz+*2!ATMow}g0$wXuiSpe`El<10`uD@095xAi(2FG9bj;0$ z1WiUI8y9F21Ro=ho!cOa?G8_>b_W`Yipl)+qxF`O6GwpPj~#Azs$E}Og^D%T zZl@Ekf`dEctjgGvfXcKe#blKCHdB}yBlwG9`psqC+fi}iZ}lRk!IOcqv=K` z3${o{ZWiA*N{MYckH3rt4CMn6%`kaXVLkU5oDX6PuAJ zQ{L|qj;?Ge0ea3$;Cw!Gp==6dVF(ILfZNEs<<{@%I-u%bkj%uyAm?9)Q$BzJ;i2t- zlo-Qf+KCFct5>M`dDjoqX9D0lKf<3wetE`^Z72|Geo)L*1;dP3O5WZAK}S+|VE`1z-6F>BpQ!(+H9%62Mjd zK8t;s6_y2nyEYo$-V-FkUa)g*&VLhAps%C@+L`bXJP`OL8bGEuFv14_zRx5y!c7pL z`G1j&na=>8nGEC1Hd3Ou{)LBM>}Ro7ArWj2ct_nRM)hIadMf(gD&L6&erGP>#7hqe5 z%A5Nv1QUdw@y)ObR>%;Kwr_eq&}BTq(zIbrxE&7exm^Whx>lk~KIx8HP`BzO8hZX$ z#q$z9CenypbV<-WzFX{$zPfL}b;jw7hR1uLZ73(b`gX{AdCc9|43Jov^x>dglM9j_ zLH+iJ$LX)*R$6+{LuS4|s+k(Uq9)#<6T~i8h00sZ4eT z2s2}n5yt2G(r z$KR`TxlKjQ2GHUhc5;LX7XVN^r4^80ddVw4L(2!F#eL34hfT(&(pt_~HgJX$w~*4) z(CDs`1k{$XWS`Mt!d)odto1ByctB}DF*ARRa^{%{Z$e{;*Q%-_&{B2NixWgIK(3TJ z0fo`_Mg#J12RhX&RJ7%uN~?`7;_2!C$_0^~&6~^iN=J}ZpgN@ufE8P*Z7pH*lxt${u0RdFwPZbTa+S?!sYzsfW;w~ls)J|>vp$5b5H6w{ z?He$nH^R~)eWS(5MNak{Ix5Yb3LY@wC2m!{*1E7gPIBt=ETB5U_Hr}elOKX^b4;8K z73I~Lzb&GS+}IW6+7aw?wPC?l*tN~+x48nBSl)I~37xrz6Bx8N^IuPFKvQnc_RFD4 zIG5211hq0A7c-I{A|vu-O5_`^o5IZg3j3(xW9i|iju2?!VX5B3IA~^orBWN3kt5iU zN7q2uL-_cr6$p?f0;@j&JU(x{#w8q(_R>MHJdv%f7(DhY-;Rbkd=PjH5?& zQ)ejOs6-JK(1||jne|+xMJP{SjY0U$7M}56);;z8qLMFSy1mY976d* zzzQRPq0JN3ZF@{02UpL~zbj*ZaEJ;&LPg}1Wqh?0>OJ#0{m4D#5G$yHABu?^O{Ccx zzco4BY{un0e(xzdd%?gE)BD}tlW&T}2gaq zZT6RxS;oE90E}As`s~Z|CDADrC3@#W5>4*FekLXO-Sb041S$f22*c+`hW2`CdPHaZ z!ZBr~&ujJbN$m#|n08t1KSVCJ|K|ITfrIV;S1Z$s+h|4l<+~xgD`JLg+z~2Hc$}k} zLxY?~1U$qa3N#$GU`ee@-rKhJ^)h7_$gD}S@z9{DD;4e8)9z@OAHE2aVt)P|t{7fZ zL@{Z!NwQ=6yTVr~Y+5)qVcaBVoFGm!!M%35UEHYNv+*{j$Dwb+L{lbAO$D3va6VKUsz&{FvVr&CMue<;2hYFdelA1Q z8hMdMFd7nzw?$l5_B7eBOf=$>GcHeS(NCI%QfO~shqDIEvX`nB$_3vN?RUfqv?J$k zqeznWB`f8d*W}#vQlSxRot*}-ukDMR5z9nR{ne)my#nVN#ktOqqyXlaVaTxgKln}ucNpfYwD}#*a&!g`nX*HQ?ZqH5fei%O z?Z7zhRhbQhx4f)fU6~$jJ{y5gMd~#=dka7R?A6&8xcJl9_%(@=qhZT8J|JCu2)kn! z=bYVU@#VjnAaY|OM}%w|W=D)|n&*yafOPotCr?}m$v`?W0&aH^!|5y*K_gQem(G^T zB&L#Q1!J;m1%0%zZ_PQ7dxJ%O+hZ{4SrEra7u(P7SXtn|)|>Wu+AVjPqm#Wzk6uN`oDai@VEs$ka!8=D&+jS1)Swg=)^27M-jdn)w{#S#U?$SaWG z4uA|_^$BDrA{hMkk1J+bDV`AsrCTsrxb?j(u<`*JVDeL!pL#67;%7~>(z|uR?hp3uRtPG{-~r2rCb$4cc1~osS<8} zyRrLSH$Pv7_}14xD}e{GFHGcq4FQ$a=0QAg{ok8BCm5bMm!{CM|5)im6MVAXBl6wG zQrT{WjsT^8S!g$AIQS$W<5ZP@U~kAkc0`x$!;fdd=j+^39JHVV097tk+(d+i%V#K~ zQO$!qzQG>6KdJ_sR|`ES;PR|+ZjGUa*5iBu7A1yW{qP}Ya(cs^ghN%IW5?Y4TW-}X zjbCw->$JOHHAJ#~Ae|C_ZRuQs)8%3mkw(u+aXA4X+(RaVfY-?@gh$AD!X3!wx{x`viaK_wrmD}&*UpV5Hys;DG!FUst#(;L!QaU$eU z%k2odX*prdSe2iGN@;_^uOD2H<0p)&aZFM9m&!y=!$M7D!~c@p7{eBA4)YQ8!tPqs zn*pvoA+L_>xB#Nd@mZ)$VBE$p2Js$9oKg^zP-*%1KRoqvV!3O5qEcPm4ifb^JY0T%Nt89-W$>zwS<%&gNf;4%Zv**n|k(3WMtG;br)`AGrbGq@L$}K4QGZ?%wdW zj96eS%Ph`0EEC0H+a5j&aK$>+kCPYSd7HqlpC6rap6SA;N*MYAvGfl?G8mnAr-2#h z$+TPE7ss<&e@zYZHl}7wGju)NA=b9Sr_R`vbQEJtTk>052{PVw+)_p$i&X{Z*X~l} z&klO%X3N#&5N&oS@Bc#IFwx@c%WG-GgJBy$1-*L!IL|C+kwJOpgwInzb036Zt?WPx z1_^n)sSL#E@z#X21E@1@=5F0GLgL`(yvKx^PX0-|ZIcx$!GrF2kn_3z2sm&?_i(uO z9VC35U6tqi?A@c>gucpLhOU|4hM%ZW_YTof5vwRo-A|SfX6=yC?va5gxS2L*L0o0d z)fN@)1`zb2=zhia*@ooKA|r^~bXGa&8vwl%6BdzwsHI^NL^k3vkQwU2l`#1{-YnvfMZUpt-_f#`7x-gFgoB!iE z5yh@1<-MK+HNjRLX6km&)C%jClW?N|cHzER!BAa)k%$O&9e0-jGMkB3pnd?yi#s6- zhx<`M>stu>m!W75#A4eVRh@<8c)`O~s`W3xRt~uKY zb`5VjY()N?~e&$d@f^W%2+s^P{)UMEWAb09yaDOsQ z3RrJxxp)xpuW?q)0qd2KG#nA)cas0g)!4U z-mJ2+nHT#xc4?FIjL*GOc7wJ|8h|jB9)AhS&Ti zh^zOf(_>`j!{CUg2Z9GPoO--_c|ECuEM=U~PNnxr&-&p@zjH*9;wWqu zO{%8lr<9V-^c4L@mCuVa8E6J{n1-p4r)OMVI9?*Tt(jU1mQrZHtJ`ATNAD?>%dr`J zThUaINl)*vr9rx42xU~TO!dSUQGySzwePSiVY!7gQ7|O+sS8sfAwFTt_C;u!^(z_y zRD10Y0U4=e22@24iF)RU^?p2?$#%+ahww*VZg{MYl48Q(oA7Yt%+ZLvPF7SaQ&uex zvpsLL(3M_`js>UvXFZAJVcmu)zK20-xNVp`* zi_ruo2Pc|3`d1^!8-6c@(v2>=z6|fP(NNPLIM5cr;ixM>-eGT^ip@hfpd^HvfdYN zXgg&Y4b(UOyI>M81ZU>sag?#;cH&7}Ow=yTDSQV^0g^ILTI88>mzC?|1&Ww@Fz+>I zN9UZ!ba~-EOrHT+dvq%Y34@hUTh{Q4bl z4VY|;?x5hu;!4pU|6qn;Iz9>(G)W&;w8n5nu0>xyXB=C6h4uhd)vw-}4#8ak7;CVR z-A7{VynPmn=`HvX`CWxpSZ^3@fSY)MB!dZ|2Kp_4kOEVvhG%b>*}Q^5hbKjWt>VVC z?GCF6w-Dj?BnL1UW97=Ln%$x*RxLp^CnW7HA5rE@`oaLmQAPsJs6Ruy<7lRXeVSml zx_Md*8E0ti$YO-IUbXQ~r2-wTzX0-Mr>mtc7$<3#f2CDeHW?FDzRDgoGEJDrrY#7% z>ZOAC%_h6pGkv{HuBP1bnxS1;seI!c6PKU%S-Ybj32MTQ|hT^pc z##f#4LPpM{K~^s2pQ>Jl?+zwDb_b9d?qhLf|K?j&B=HYdv;|>dK-G{6 zUg>z&y`kddC`*Re@$OHwn|>LG?o`H==6Vqf_T$CSflCk4A0JCdK$NaV*jCdz*k`#K zbIVCDz*)s|gLY#dXBZ@(=@1SvLKJjT%A9;2+Fwg$e4;}T_OKerxpW~Zos`x3ffkDW z^&^hmH89AFzEx;uAtY#K0#AhNF&NBr%LjBusURYtz%hgR-1XXUntoi{oke14LSfHZ zw4-``4^;090Keq0zuf)v+LcP1kEC^RYd7Ra6PLZT&$e0FJS)n{XFbi$r9!P=Puc|~ z2^_bnvn+oT^z=Aq?D6tR?#T5iH+ul>{l^a~hoTwK<=&|f1AF13?i+0J-g);w%(MT_ zNytF|e~t$=zh0Na*8l0TL3Bi8*)I}{obUCA$y~DhvyaBG#SfE)%S7u6!{ixF^xSx^ zlS7S4UfRlhy7VjvdaX80&{Od-ev~36gv$$O#5A!OxF=j^o8NJpPqQ;2W~XvTyn;&@ zCrYRn6ze+YYdFmMx$cci6s(6iHe8I`GR-2E=x#Ey(Y{Hudouh^1+zmnkGCCF6SARN zTq)&=jq@EYq-@3>BB(s^sHZ`Dg!Y#af?Y#$8E zF{vJFIxXcm(uh)8Oijg`l}4RRBQhQ=aVK$om&hNI^>k#^%qr%fVdf;rBPSIERl)i3qRh6N|d~G=vvj4 zKV0>~5sHPtC@WyHhpU<<<+47Qb~PuNz%R9=adDEz=5$^j9%$mHo}_>xur)ui}UB#vBat z85zgw#Kya=UZF3a$n3qPwsf=JFBgoRH^Z0-p&n=t}M%`8>qG$!tSP(;-k!f1{HR;WsFf$ zB=}xJY%2k2C6obw50n)0^#s>bzI@uCIB~MZNo}u*ATurA%<#tMe(;}TKHr!$b>eOi zelaZ6Pk(Atjg{c%Wte;i!(GbuT+ImfuDYQ7^Y{<-wGcoyGtCLQ)6W>7cM{oMCO<(& zJYLwz#!`a)A2>C=VBy+*pOu%}~gE0PZ;eO8j$vAUlQCme%kPZegrclv06r*m{+7L`=se6kC zHlYN@S^31p6GnFUt}iQF=0jJIr1rrc;jCe}uKHL0=5vD+*B;K)_bl$b8$pSmZYZC#5M3ML+EdF1f=I6OgCijqKa8n|taH+v((APGY#x!MzZZ z)P@>Q-1s|?C8|sLC*Xm`S7@`IOYQ>1-YZw96vTgeha8?ADJo>Fwyn=CIa(@@A&`?g ziE}J_Q*WA@s+@>p6qK=F_O>7B=Cd0?3Vz8Ttd{`*^n%;fB<{A`07$^O4U4##U-rfh z2hN;oyL+7Kqt*iFB-sP^Mu%O{Faa33r1f8Rg?+0Hs($R#$E*37c)Z5pI5;_$p+~I# zn<7In7UDJMEH-R8E*?W-H8m0r7o@D#vzR`$GsX+{0zFM9MV>qZ4Hqz>)Cr7nW(4&6 zbp@(1mIk?*E&~TqywC8!d^D}m_^XVH1~=$ffLMcvn{0>NpPU! zEsrgc{&}yJ!pGgxN35eJ+9(0pp*;!9B^H`otUXU+y<>hKtkR3l)>FF;Blx7}gvHVFPCw?F{UA>_hM5M*+y7_0$-!TCOriH{*ZIajia+zdDsh}OAnNzW`( zjM2OMMnBdTUxB`FOF>O>bkn0X8;W)HzfCoV(W8q^HIs*z_^@RgR=R z_Ulhk?zEnrGpZ~KF#hun?v~%$Ua;>>he=V;7{~!OzgxAYIxX3C|dqST;Jw3+?2YQwf)#~I&V0_>Pf@=M*{XYPp+TFmf>Fx2}CnGi0N84g5TG3k!TIdt1i`EI?uLM7GT;Id+L``(;t*-dq2;6+3+E-=vFDtfqa zOHfWT_C|%SKaw+LE0oE6@{8GSP3-1PHu}|kUq?T|s@_ijA%gsOYB?4rrvLrFu&g1K zv@!ZW5hULcQk`TleE|wJoK6(^|YjxHRjedK~}(7=9!q!sJGI}uKEZwAu$R4#x~xC0FgZ|Zz7PLA8>y9xnGj<)!YjNZg3_x|E1!dbI`kTb z!&3WXxR&7goVr44IJcAIz}_p~2Xf98l7&F7f^G>i1dM{9#c>gaFz;kl>dd`Wu8j_63{;-hnJ`r&_P&!jL+CxF;aYEthNx#n1UgC=W>Uk`Pkb z&x9zr;TwO>hQAt-1%_7p^*WGt3wUbamxu6Q7!(Y=pAsOdi`s0BY zKB9!4!>~+i2i)nRTr!c^PotuoGed|$u?D4POM~%X7ryEVOi5lAE1qu3oR)r4DWtxw z*M|l)s2yE4!T~C090Gq~ChI3p4VSzxQ#rA|E+rW-$*7p*t5=&YDhDVACQi0RM zwffGsYV>X>@%&?+uAodlB1mTBxWR>%6LR2!$ntX*0Tlkz*eR=gX2C@=>ecK@73@0uZB}Ux-{846K&+EpnaWI`-WJc z1&FeS3GBN!lvW>}$vIweFU; zAgpn$UnenwmoI(p`bERqfM>5KzXLA;xn;TtJp&o6+k=GjiG+&ZuH6sxkv<5gh$2j3 z0+Nz;*DZ+v^x{eR$yf-d)1n7`VUe01JUTrz-H)*gn;z=xe>nP||oNbUre*4S`rRCG;jp>JI8t>gP+9G>HB zSei`eP%%3ls697*q;QvP@OC{=N$wEp!qhQEg5Au3^>0zK^;G?<+g75(Az7B2yieD# zgd4y&LEXe@3~fDwj~mdj^qD=^@hPn^2nYk452Bk-?N28dQ2}W0SgLd15zf+~Vc9Wf z@oi($13;(~$Y-n+DLg=Vd&*j=PP-FQ7P*|Sia#l%EMtrHdLBk~R!e(-akw+@)Eu5OUG0)HjZ$G;MuL&AW`6AEBHvOeqw2F8(Dp(droHa|)WEw+}gFweSf@ z;2+`Z1s#F~lcbBdJclpVj3sw?%t53`Krjl+rLOxevqCQ?^iLFF{mucScytA@0G?T* zEYPw1IR%C%_<^upo<4XpyG#%xHpIUN*H6a8ZPP+s_J-~@v7wBmYA!*#n|q=X_34Z( z6UuQV#_md3V*<1!pc0g+MDb|*6un@PbpY{-y#Bk^Js?doJcQ&i)(lc3ko@L$Q1sK7 z-I`#Im4qr&(QX6>^a-wng(sjSO~&i%JilNHG>OUFqva#1ahjLV@UVtxrs*-_ zvGH2WgnR)mv7oq%FS4h%f@t5M+i&)}scH3t$evUkEymL#Qx(E{whFs6_`v9hZPTiZ zD(>@nd@`RLAd-*Gwi;CB%F4bB0HK*TUO8@3dRRLEi-nSb_S`?dZ>NKG_~ zldiH&EJjC()N(??%z4lS&ot^Rhk#z{)pQ9ETC#QP$|Mvor21})Ge=O#65V?DJ=zkcQ0 z-&b8MS!Id{D6mgK2xkf93@4;He1#tU7p`1j@4uy*x5Kr(Cy6hbKv1f{A}nzqno#80 zf1RYXTc9jXGwEGbq_mn<#FK1jk-k?brH06gv*Z1YIZyoGH4GFcn|L$8aq;8J#*7_| z(OK{8_<&RNUJ>LCXhIa8DoX)Y>2MgItuXP{%;Zc7#-vKo;}H!=6ie{k;CnpNXW!vA z>EQHuI~^>5EsZv$w6oFmbh#L$Wg%>y3b^q?vqDble?UGa6ThTM3fN%x-OD>cS$C^M z!#=MZaak;%TZDWrZ85VTwdbA%MwDsfvOh%3EMa@sjy!l$kG5+a$M3oiEtny$B#-7WTmWs#px+X}t4my#4x7td z&a87@q-5x{XQxl*Cjp9TlXq&$r^GZcsP8LZ?&e{YJr6UO)cWc z&XoOjEZ~L5a}9bs)+6jLk=?-j5V`Kvai80ZhzqZdX1r~AaJO`jXp+!Ix$_}N&0FpJ zWIUj*eU6>-egekV>FO^pcv(O4??tRN^^XyFu}BPN7wa+9}XGx79m>PI!H3$N!v( zUhUOP_p1T4XR>IjWqgj_HtL^|Zojo3s?QrBSL5N)`J?$Hz<@MD1( zQVb#x?}kO}Y73FrAGdBMqOEZ$czlOLHI7{xAh7~FnRQ*13@OH7$nqxcs{oYo`a+~KfJlhGz>X4)vywrcVj& z0{@MlX((jKR*b@IaBxA)XrxLLgm4_aY5V42?EgIwS&a1NLFF((DIs?-HU{)kInsIY zPNf=KCE2eMTN~Y%?m!lvWH({hL{^j&lsG|)GTE;ZEP6oI@4#0vUXVL7B}6Y4O11pc9O&`{tc_)mH2$|kTP z%#$gV8q1~5a&RrPwwVKH_6f7oX#|E492@K?a%` z*+|+5&5r{2$n2IJDZ+g?;M3@o@39b;M$VobY42TV(>@%h1IHDrdv#&By@7$}&*HUw z8%4p(a~lmz2ZKL|<7`n;>;&|%A@O=)FPoVSf~={^-@U2$#;BqlU5J>=9r zgcax1DwMI6bv5u(>2mpg`AS(OR+(Fkxn%eXzP-hdwGOYoH98S7T3z(|vu%ZEuV{&4 zo8>WqwR3TRlF$pofMiZq8~6w?ojfGJMBz_^LA#!d7s4qay)N# zoW+RmZDyAzM)(14TJL#TCGmy;p^9#|w^S(8VDBS@Cj^-5GKsJiFT4w=r z8~P2G5mGF0?rK(=j8t|6qzF2Zw z7j3QiRB^UL8$X#>o4IPBf6aA9NUh&4Up zeC6v!3A<(0Qvw+ImA_KGni9>bgbk1FjxJ_qlZAdVv`>@uuy!d~rK)9arkM@x%SutRR6i*c)D-l&s&y zEGML5;|i5d+}zk!yCP#VctsmGxw~iVZ;Tpe|0x+5wM{B=3(8lxYtbb&!GF7%(r5XB zF*0$9X^FjEmbKRV+~2?bz}~zy0?Bo7J_B`xO&A`xAeQwfn=kd@=YF!zZu{rcQmb@e zXk$kmerBo12KyVq@B~f79WG+n?WQq9&`ksJn7WN;j{?iLW{_W=Ih9f}#=j2jcY*9nd3 zE^r=PlN>rFV=4tV*kYT#loEBCz)|YI9=hKSbOtVy@$SrBy1ax4ICpZy+RUvqvx7HU z20u!SFJD&Xwc6`m-R`QOb}zF4$-OWlgCm5#kS(u+0y{@y*Rw{z4@qtUcq2iNQrO~8 z0|SSsag4(H|G6R?W`?bM{VGz&A$5HKKD=!Ab2xNw{rGN1V~k{!Mr47W{H%k*bTWMl z)JRu;P*3=hs2=YP)PMT{iy*F>n@#K%4r??12jSH^ovShxMGYeJk#vn2VT&YSoX>$} z4hP10?e9J2v2Vf}%6!iO&z`tZx9`ROPEUm=ghFL?U z@`9}HvNXYzgXwl#I&{cKgknyj1`BKPGOXm zi`09N3B#}}+s=n+rsai4Aq=~KuhQ<4U2 zJCTo^x^tKO336m-9XM4DN{(5EFG^ShvMGqE*=ZxLjyze@A~>tNdV?T%?NuPj$7J>7 zT1PeIN;tH+`EM4f2lLUpb2*M6=|tZL@rI4@_ZTb>0b5G?0XOe-qbwj%gW$7U+0t0d z#QQNL?_`C2Ow?(XUSJlSJfNb^l9TU@p!6WY$jL|k%+973F%(H``LSZqr%(p2ySDsH zP}shq-ihU#@+LJ6d)(#@lbud(4v<}mB=CWea___XbLe=Br=qb>lWXsS-m0vPo5iO?@MU7#|S{Jx&M5pq|_vW(iKl z_So%Sql0^h?q=Cf!iAzZNPdKT*<+w9tq0ZF_1!|6IOnAX%4=FWiR~lfLEw`vk~pfu z1(V#zP7fBlHz_WHPzSxKXW$foQ-zBWQ-yhIKA=@bHmLXjJJr-D)$ z9T(u(6yBK^+{43V0w{szfKkGRTFvH~hfe=9=#wi=gu@leJx^h;3&sHd@6P=y+Nrw< zWqJ?p@6YcS_^z=ge9pnSQKipBLKxcnDHsZZ(%E}N1Es+d~=T z9vsh+^-MH6=ib{Ts~qOlpcXct+}1x^tlubABH^+F#653%Y?Qy(p+FR0yRpfg+i=)0 zseueXhV93O`tbX5Ip?qx_6K|W}ukJtv{oJE{!G5%pUbilPRc%z)X;FuV~a_UxZnPA&ro z^(e=-*vgUJWY;?d0Lbv$8RESDyQ~~sri{>Po9#$HendN;=mO5-I419#edj3~ndb5O z7;3Q1fyZyFyylkG|3;^V zJ9uFJIL@pDet!#{GW5`O25#r8A^sbmjv}11ihTEi@ub;(FeyyVLK6|lB=VY*ynIS3 zHKp`&hmnWcFujvQGjneK8(*5??8On3(p^pwUE?k=jI`l!4_6sujWA#ShS zqy36tu^9_5*WSlE%fXZu~u@pV>Kb&8PpS4iE2 z$|=Y6-BW7GsJ6I4b0dJdwe>e*rih((h@SbGsK;So^BT6Kb{n_1ex%%*@=3~XA-16d zt*jR7uDa|Zo5yio(U8;<2E`I)P}m;_roLJa8EapbfREMQmEcX+Jw^4=Te>KImOeF> z1eCVka!x)XVpvw#_(;`CCdLRRRy;hAxnx7Z_;Vi-^9S5e1giBK#^`Clo+?Hki4~ct z>K`sd>PSoX`|jXI*mU2|Gv8Q?3fO;0g#VRwh>4!z|6H_Uu>Qs#v_Iw6(H|pWnpcrT zuFIFn7J;7T)I7d;U{#D#;R)hQ-@ku-j%oSWq1_g_MZa-u znQUUDp4htU{+Rr_KA5#c7c;<2>H1itrFC^cN+$$njn-m9B{411z%$#QzS7sho}S- z2F}N|Vad!S=v%#u5Oalj2~)nRMe zcp{WI3dmG`UUgvpz6UHzxW-ba36eo+i17eOI(E+Gi}{_Y4uV%!%l9zejXNzO8z;9s z-sD|1DD-G`c599+1Alnd2;sYpPI>AHUd*Y7MWoKd-91YACLznnSHvOH_YM0mlKj>6 zkH_sTKDfSh*z@f05FzY!9>N2y+F^R?Qt^@vGKqRf=UoLHj6}F)j(vptU=D&f}yD6g`9Xf6ievf~x+)v$d z0(D*+I%S~yPIjS)DS_&*fuiySoPDrvf53tu}AFqeu zvP;on`n7S-8O~)#vv(558DI47?)Gk(ysY12&tf!SBTz!v3yne@0+9l;5Hh&<}`R+GhWI8E{Dc-DjfD;=m(i(wADNmGeQvMO<7 z*o)3NUCr>%A%w&G-j03bP&WPgjBHx=tt+9&mtX?5$GYNMwajXop%#rpk8xWwQ>RoL z-0cu$C*@HcLt#i@b#tqQabm?ya7&@vqJk;veGM64J10AYW@GTG#VW@E+gdB?{;$?`9cU5=i!M9;on&E;h5>|3IU6T4wG&9Wqpq)w5 zJ=pY64>qRnyOS4ALrLqHy57w0kpD7h+Tq9m<7iM$kN&2b?mw_Plaw3#( zq7a271NR+@1emC@e*%h|}sgUL(^eqtO~(grKKbnjw=xYDiR10XGO| z?<}_YFbq|E5BZqMw?`9mnI!OUXajS8*Sp1vRU6N}fiPp~W98eb#{gt^TfG3 zP^l-IVzGFx67g6wfHSTR$G7VL$JjY_X##agI&IswZB^Q~txB73+O}C~+qPM0+qS2A z=B9g1UwnVy+?}=djvevD=fUaR_BtCCzcKFy+j?Vv7w7_Sr&bx-8`%b-r9Vug*fQFV zr7?XvU4qXVssi)$P=xSngbaPr4#;`*1i)6@+wmw{x=@iZh|(#=hA(5SZB+~|w?I$> zKCV~@mA7$gAYv%-q@mJ~iUcv^>NRcPU>~8Vu~ZmV5Tx{OEZE3r^})^!4QvzGgHnw` zT@1y_QE_8$;kAls;g`uB$F|CN_$p%W;8N^Tt9UGm9IT-*>ZwtxSU+aP7#I1_Qbn5W zu9B1slxIv_*`>Mfz-1tkPS)P)Mw9|)Qi=$aSdKK^*&h~hR}f2SBQP<`JnCqF{G}Ff zy&amAyJx;BwyU3^C&>V6ByJABc$B_vHs$<&4EfJUwYsBfa8_W*L8uX02^uXhqf)&P z@Wo#X)E8f>nf6bhWo@ARA5+7FAhm%L=eY8LL!%Y^`vhvKfr@Chs~9uN+5Jl<_R-O` z)%fFdg|aAfa5@APbQG3?MBw&MMGj?STm?fx_z`L>cCP}iF&bX^9zjHTNtCCxw*dMO z!A}J7L>?B^@b4IGiQ}vpmKkuDskdx{Bkl%0FvsGqo@4xd$R<`ZEUwsl2=}RpmMCBL z>30F{3&u@p9J{13&5#PTv^F&&A#HT46HRD^9P4^|ELo3zOlye(sq(p2jdN?eNim3ddGmZB90jQ00XZbdPmkvQ#!SK zwC{jD#9yDx8eB72gk|pp&t)3%>7V!wIP$uUyH^gn-k|boEJSun^B;#Q?|c(!j)C)i zQI`H0qWEhHPud9WRJRW^tYg5I-oR3l3Sgn1tf-h=rR*@`9z6ajE9ZL5FI$@>7$r|3S2L$OKCqu z6$6F>7aU$h6i=|G$3V;|R{i-GSE80Se%x!i2qn(dK!dz$&o!DIbnT2sP|hu|(;_#! z&nrYBM=QSl(*=+FfimiS_jy{Q4MR0|WjnFEyZv>|^h2pu#Qj!<{XPKk0thITcT~_U z=NW8qRF1;l>t`QL`9dFM_&%9O3e@fbC!fly?6Bt+j#?daaBtmU z0q&!w=1JTl-_TV(qRZ6-bP{ZP?MF_?+(8ah4W{-NEJ*ZGquiQF$%^S_3p95uZzZ{v zRfikmqMRPxu(Q4M9rU~GsdYD|ZoXQ>17xm`01azU&tiiz50t>2Kf01VSS4JQ83YG* za0=24P#W>2FhUwR`?L@yebe8PnH_xkw^3yZfeO{Up$i3jML`dk&>eRz1X4u=0Xt_` zlk5|>$RR5&J90^5-B}D&*{-lu?VxNKmem~Ff0)q2pvBpFC2!!(U+uch#T}6%%V!t*nbZ84!96Q~LmADo zUBc{XDCd^Tc7bddr~tHpy3-tM9Z17XxJs)4WR5VsWbG6LCh@?6O~x*#z^5VpR6K40 z&cxmG*lt+>ILhUZ0Sjs%t|F+!nR4xpsc+P&7_xK(bDq=u!=QGh^Mo#tnG@AcuF>|d zS1_lN`fFc{1NgnDai7MQJD*Ca`K}^MlYT69*1L;8uFo*dMP)cWGI1sMwE)=G;rD=q zOvk=|8?Dx8+YF-4`#F2UpT)F~Ey3?czwMeY$^T^)_>Vx=ENt8y|6LsJ){<%b(}uo% zqT#X9Rx#~Q2KH#qk|C|(ijg7xu5QNcj?qNFVanuz)N23o`JNpH78teVu3Vms2}O)A zl{a(1JDRn_aYhkf&@nztv0|p1ob_e)koI2!@i2wlJ_|J`;;5XqjWTxH+VS44^W#B# z2SUltby0GHN9z`KaiQN*SQ7T-b6QxhZL*|EdfJ?2g3^xrO_b2~4E!3krt)0d^Vz*s zRxvWv@!j6L7Qt`I8%RyeQ2eQ$9##0>CY=Ncg|up_LWK?dCM);bJypM&4b&DfwrqHJ zeIrR^*A{~FnxmTQv02Bd{?!gnNWhwXNbHQ7!PVQU77G8$V7nb=62ya9{xoG4eqRcU z?vo+Iom<)koitJ<+xhhTBgTdlo6DwzaNPm3l$t%{_0~cE=Y)NM!UdHpDi5VUB?wd- zk85{!iiDc?Zrn2cYI74cynoN?Jx{K%cuYNpPPqA!lfgjT`n~h196OTJt#bSP(>y%R z>suFjL1^!{-TO5?2kSP)^x^1qPPQfX%Rc8|+UGu3jFrM5HUt{>4jbRw0?c%pxSog7 zri4ZRuLG_8MyDJX47|e<{y%QFS}^DtJGqjyN=~hs=SKofKj~X)1RUXXY(x#=dYPjk zB>@oroxeGMT%;xbo#r_QV=_jV5`O>&tvIL_R80<}*EYIGOSbrFl!y`78M0AgO z;zQ*hRIOSsZ2i*;8N=DUE!fv!ePBwdlJuxO@-~0xjPS8OVhbkPnd_6y0!6k_x$~B3o$vPSKV(@Wchrqaktu>?D z6Y<^H+cN_of!T>hx9%?}(H>mQN=e2|j>f0bQgSdH&p5SXsE7QU3E)X(MjSCU6I3w zdrS(K2+uJFsQj7@=qqvHh)QdG;r`j;BKN;eY$0U(3T1!>KzMrG;^CGqIMC)2-vuzN zvX9*B{FkBJR66n96oRS|&D(F@q}F=egwY)fg~JW;@DcaO+{#go*yGk^k5Oi&RR@-1 z@#H-ghvY4Nk1!miR@Pz&+nJT5;#b?1{*|;e*Wu~*<{sA0m36Rhv*t(0eFIh1omJJ> zBz5IH5)s72=eP05<|nS)ofY|=Z;JHa%G`ILPQpHqffCriRC8OYb5%*w zge;BMhD|n#Sb}(se%(Ae$JYXMR9?|mSep{XuViX1Dlhk)ze)W_NnNO!9yL@0Dnwl z-V$$~P~Ef-?7p{)*ODfaXb5KQtH!Ca{BtVaM8OW1SHV>Mu`1lxozDy65Q4^j%PkN9k;I2)>ff-P(>F41I=QK;EPe zP4wDfYEIWy>}sMUm3=B`N@t%VvgDb4NNkgjd?8vy1>&lStS^t2tOA`!{OeD-FU>C> z7(q44$?6I15{i!w9A~&Hy=l|vw9vJY`IojA>Yy^5aI3J|O~0!ccD%l~CYs?&C>6JT zlw3NZ&b}PueUOfqepe&1fs+CK4A?t9?B*O?xK5XYJYwLz)DSM?IOp#o;j0O$PDObk zk=v&d?P<+f{N{BjHLfeABTF4xBhn149@h{C1A1s$5Y6!Ns*Dt+zeC8kov;CsO#P+6 zA_?*L!@5fcs|50YCin2cO3$Zn|EfIF_d~aQvZY<@k_sFrip(lCy8uvf9WE56CD(-K z7Wg8XH5TIh#xR~thd9fL*oC{W=KLp2G;J!oL-_)Rj6VFyLEz+m673^_=5D zC6+H$F(E!4&M=5(zY_T}*-EhKfdKcm@#yWtPVl%Y3Z+dB>aNv19c-@D<2A|L#U*MP ze?kd-c%5Aeae=Pg4$G$7>V+Qa;ufo3k$7hg0$HE%0pbC~gnnxDB_OSyt=8<+=nK>? z4UOHK8z#{IbU>pMuAfR@*VKWpBjvDl?0@#o$;bd_S87$1}?Yfp?4B`iK)>~Xep45lG-I$d} z$GHsoE%4r6?Paci|Fq-9{K2{iYtN+P4Iyi%v!Gzch$jE$-OZ=4a2b_7ECN`U15k4%=7=xf#NtqC(_ci@&~}j2_|yzaX7^u{r+#DUka=gP?PB z|BsaAmbT1)AsYWh9I&{{6PPu8q>P<3O#}1{?^pR+5P=uCEp0mJtLXowpGrPAH1l>d4~Nekw4mPhTdtn^!>@*oBCv9BESYZVroMC4Rtmzx2z z6k0grlN!Gb!%;;x%(?Kbi;mHy_SOop{TXbcs`{S-njZ{XFOBqQa(y@3*?Zm!q{W74 zN7~aydjwnnvNYla>Bs=6YT5?iVI_07MZP25HF{|gjbAvDeUh^WK~(;c36h_O!Ioz# za&axcSIB&7$R^DuOn&EG)W1c`4v;B@Up@q>Yx#2N>`F)QeVAO3`x7eFttzh_&%w8h zwty9$yG1-Hv%1E)5|!PHj4;qylry(Nor}EfIxjYhG&Xl{c`eHhCrfD!9`#{0B3OWi z5v6`B=GC!6iu-qi(CyCu2FQ0HSKX?@n{36&B&S6~PF(ye$!iLb)&0S`gfJ*nj>lue zvIYkUo6jw4wtAm_Q+x^2m__5Psxp_o`ndk=3fseb^yX3=l!C*Rr?rHA-R}ZwrkbQ} zDIYfV(0HRumyJQyAdqA&ca+xWN*bEA^=$%>VL|YbVS!H9~h zce~jw<9B7#@e(kbj_vV@RM*}p4GZz)3>ILPE zt_Z(GOlykvUWl1;)AJij1^HL%k-QVyCY_sO=y5CEHFQ-4h6=J2Z|Wn;WW{_bDR9rz>#?q&R7#Kjkecu15Mj2Bb= zo`kn4sgSv7TqotT&~9KRN?FV_o!<}aGabjW^zRi+;BOU7#k0{RP(9MV={R+bS;Az% zbVh7uc3A2!fb+x2ReT@M7M{2J_l3CeZeoUq@#4yM84XU|%##QOK#D>dD#SZYp8RpI zZhfRMxq$5u`yURvmEPqZ^RZNF*TvFlQR{s)we!W4mow{otBR}q`0{P@TXN2R$M+IG zHrhe|AI2L7f7YZD!!VMN!AMvgX;w2Mth?6l12=9Y1F7~g_!MXsAwk3CPUh!gfkV>+ zp=FR8AmgSUnFzXcYP)p8*LIR*%)yPbUk_CTFM`5Lbwn)FltG_gl!5#V`(1Pqw7oI~ z`&G$+zpXNkXl7gnru42EJ*wCyHbz!_Z&VgCwVuRC@RSvArTDYHQ45Uh%e=1+Pa(hG zGC{OEuQyd-U9ji!vq}`LR9SaXs{L~1yC=~Yr;+J0AQH>nPuy@vKNvU@A+C6Ok#Q!3 z&5Xu>g68vIf+|{=Pf=(Xr_mpy^i^&@ypU0~rT#IV>TrmDO!5a|VaHZ^U*Yv~#R(z_ zE&2KBb0rSD$OjJ{K0C zBx7QMU-!>{6?9j2tO4Yan%n9?wF3k~TzEESN~Ie_B+ZzK(|5%hxs4CL}G2U;5` z4LN@BRahCsUv))_&D{@3CZXLY{?AzIS6lJ~PbEe?Eb%-YUTBDJhk?O&nmP z+6#J_+{Iw(-i|(b7rK(VLqpjwFoJ_-5vE?Lv6`C!w8J5k9uE^_hY6E^J4z%h6sziu z_yf!3TLqaG+WQNgJCuYo=H$7NdnF&KV(mnqGjEKZDkc1hhtOUh4v`7p{f9t9B?+xZ ztn;F0nx1X?`)VphlTmS@WxhyG+rv}KzCzPh@or$=)K8++n++UoGRRPiad6venz+M| zi!Wa}plujBdT_|x2o6gzl~o1h=%GKrzwoA}wTJDmGuHigaE|+6lg)5x5CtD3m2q1v zJTxAajNsnpNTg;~zlL&^{;~M9tP7c>UA64_<*?0T8>ivleo3E^_|PTulrq)hf44q+ zDsbJm6|Tr!J_T|A3CtZ$P^D5^%sDEwht(IMv6nN3zI`C8p14zw!k+T2FOuafI9I|; z^NqIE*ftWIo8XYh+@8hqfRhYyHiQ<;@y&+XNeURX>%eo^tNmC5|J4=S&x_AOoqb!p zCa{q(GP?{18hX6i27}7G#SW&|OxIS8CgrcN`8@3_PY@0KtOJSu00j=M>A@RTW@^Ck z%%*I5-`5YWcz*V|r+?$)-?7fgoElrN7yM^M?utApV=(NOrs0h>-uj5b?eQWPQ-KU) zO@LnLM_yITor@F)I_(tx{Av19Tr=!^a=Huh*r~55g(^&p1C^w`4)5}Ge<^xm;OzD) zbJqe1`!VyC!;!@a{dn3f0MfmXxl2*xrz3L!QyR_{u`Z^I-GIY%CP^l!b9um` z)uYawE+Nuo+L&e;(AqQ?%nrcy)MPOO>P*a7vzpUGIZ$)(1<1?bA30{xsF*0K8N=OD zi*us?!F{GkJ-VJf6-VgKhd06P9WNo^Q>HX#h>nbcPIcxEI?^5DZE!ftFqZ9Ncg1=* z4zVewQ1pOQ!{!suFqm{3HOI^0UEnw1?Zi)Ieo63?c{=U|^5x55T0&<-z*@O|39R-g zRiHKZ7?nj%*{$-t_qRFsdK3(YJ0gdo}4M%(}UV|mLO<7cyl@3SohxQQ- z774P!xIbuuMC{ef*yXmkq{jj8__xUE9TC5&*C{m9%Iu?sCXoKK92)bZH}Z$l$9k#Q zi+$P|+mu(uiQi8>R~&7u z?^&um)(MN~femK;ROg&*_ra!+&FL?Cc#aWYP7fY0@7wLjFTL06UV_et-IJmCfr8L< z;_LhG0~jYvishy_DlsgN4(AbK7yuYCNg^hTbop#B3pK;p z7@qcx9$HVQdwAeWbZQpZVh%MXQcy*3j?1yt`!J{O3 zjRok;2r|s6qo8_pi$fyMA@X>%HQ*5dn%4Mg-Fx$_tuAbr@CtnHIrYwvB~0n0@U~MQ zqGcmCrzw&a^IwA-d1WWxo$h~MpHFVe?&|0kPIZc&2YE>}_!%^A*BQ(pHi1ehT0Y+H zy|2b4$a&;pw(oS-ktM?^-UD^-rqIJx;<+l#QS+e|q`^@?E6XLZ+I;*iVd%%5;ipL= z^6QerL;uBzs|J#zTdHk~>KI(>`tqNeIN@WKK%aJx1J*nEwfjX7p$TxD`)5y^y8f=$ zo%`?4%}~h?RXJK>PyWT6i0+_smihYqDov)ehycO+YvjY)fqrpg=6<5;_M+mTUk;ul zA(PvdXfaqdKT4BIq5KWLIPfz>I-3 zJ{NmMf&O)>f;Gv_!Yyzwh91(Acp)nb{C-K3b?UL~p3tjOiQh1VuksoP9jU77Jz zirG*kK~yjk^SQ8M<8{iEGo$~C>|2~~M7f2+M|&i{-nLq=dRCG&=QWUcQX@0gXD#hT z$$mqaP{$iXIK^$E^-h~n~NyoTS$C`bzomjwa3j( zAzP64Y_s-4q4s!sVSa*+A09)`Z?(pjmpVLS4av|m;fnEP z&YWr9!Oj4dRE&zw2iytBPcvb!QquCC>tp|j1ES;tlBOANSO8Plg!if+FqwarUEB?k z<8q8mkG9!(4$b|jpse`tg5=^?yeY5TKtRBO#Bh&2?DvFTKM3vdap{4*a;$!?!!8d9 zuW1#%ObHaE9u;|8*i0vT0SFDoxi9{&%?9o5Q(;_v|G++Dm*I354MjiAa;KEn+~r<)Y{)C z`_9HV@`*m;a6^^MUUx&EB3DGdDI)Redm_Z8p&bjSp3M|{E%@Phhq${kecCh+t<(-# z`y(8`s4|j>iE$a&Ksb9`%(>j<6fQNv*QwP+j?Ipyy=kJNh_bk6C}V-8Q4ok!s9&k% zh-OX|!XoEJ_Ts2WGdXWYJ&&9Gbo8&rHOEU>b+Y?o4sF1t4pIeJMpx-uSmmK(TB

UF zRZQ$`l!*(>Ev8JeQ7Aihkk2vuBe52^#QDoUee+Sol`Cw)x!m{UlT3LkH74QT4JnE$ z_5kQhcjyRDN}UDx40^{7z@LTi$0)_Q9z4+dK3lH)2v~l-|5buneF_p_?s@)Z#`{5b z!pBkKGBJ`PRB8qKA&bhM!eKXQP_XBH4f6XjxjFO6nnr(Yt$_b6Vd4mkj_N*=AZ-1Z zV=hqEaBC@!<5N{rv=0gy(#H5Ge=JtE&w!97i)q7Cp6E3&Ld3H63{3!;Zwk)ym|*+v z*Kp`>lhISG+28h)h(Apa+X8d|1EI%COogbzXyaG3o;+FG0F(dO)#PwL-h> z0bj9HB*G|X65|%<21lQxx_kmZxjaZz$s8X~C$iRIt|`qx$%{l(3s;+KP;f+s8WIMJ z%{nfGeid+Xo}rNN)ISKk2d}mw#>E0AB{ot=7FHt>GRL8;A>JMGjz;}s5+Mz$<}AS? z(H=Tr*Q`l9TUm)vi@wFDa@f6uxSYYz6a1l2d$6L7k6&Cj;PJj2mB%z)wik^7I%rvS zyT8eG@M+ddZ|yEPHlDh9SkJ{FI6i#Cd?Nbe;Xw3cVjQK*?U;1C1cI7L}` z9%&{VmnNb9yUgg6`nK@PfN*FTh!raF+LJwzVXEng^t2AW4Jf>ljA1A`q}FZ?f+?%L zytLvv9aBeZn7pPMJ$6LdK&NuLV#!joX1f4(r%rm{BM@eNLVeA3uOxNeE)t>MuS!NZ z>lrxx5itI!gR|P%;X=?()6d>si31x#M}#VK_q#{X^7S~t21Wa#qSYdb7M*%WL3RHP zI$HI!ojVso<28W$Yc2pgbRUj;+waq9QPHU?ccI9HJvDIB(=(8bR3@93_9}+Z0e!5N zIGSX4wMx5o+KP^c&nqwV_cX}^LX@XDN~o~KEnUCiA$jxg((FWBqz_ED?&Vq-f^hg3 z9sU{`UM zX5hL!tpPIo)DEfqU+>qQ7^b>OVfxHaLl#!y|#vrINxICuNX|jc;0_#o0J?Xa8(QZ!siG_dP z;@fAX$Mdm^^YFF2m80uq`89C_Tp&v;hi|GJ#puNY8nOSrUjgZszN_|94J$!@A0MBe zW`_qxO3$H5uxdIuHgWG(rs5O0(Uy)IDqX4S$DD)2VSr+Nqe3&_tu=2CF_g9o)nz0XMSSbT6YA`%^g zD;HZ(cpuG?L=ZU?FGWL05~Kd}r^K%?c+z6ji5S|*%hhLb#MQVMb z3IwVCq+$M%TOIkn3l^(G$WxN;8Kpy*;*i-fcaP%yVD5`aZsn5@u0ux1A)R~&o&37Y z{+1^Qk9-pPx5a>9OY36D*QdGQj4lG<`l8s>jgYm82aZ8*;YF|wcOHY1fV7^h(m4K3 zcP=CiUd{)rX+2{T3Tft$wa#J^?f@Qclw>Nb8(6#wjXPwPwgKfI5Z)PcW`yB^K>I&x zB%}!6zf~rrf?G_3MCuVfp!0pv3AZ)nmk+g^1agX>QQQ*7Nc!e`W2O8HSntx~i>6uMq zRy;s;@UkXDyCnUfSNuOL?&C?Z=PJs{k%Vf3+*3F2%w^Wo-X`nlX&-c$JNT=#caz`F z!Gy`)W*O1RrPb7|5v;EcEsGSTXD^O=%um@y(=;aNgOdRBjB8M3_t$%=AE=&SlFt9K zcKk;j1uUH0O#j_^(){n{u)&4Wb5nb3Yf5w+UPPtrjBRK^A#_6=l=EoojTlMq{(B|W zi<~>-`$cD%Mmm|!od*~KcpWWo*bAUGb?k@RF144pso7lbNvvDHmdEMWyYu;~Z)^JR z*s{7w$hlx!gb}i~N%);Y)%x}FCCJecKQN$u`LBJ|UHjs&hd@4sFl1JCY?>j6KP8V< z)enJ7hWzTmtyEXp^+>T*?k9E`K|zhRMZZkV4W0dbwB)KH=+^t^b$i;9Hdsk^?4#oX zG8fH2NQ*4!IC+gYb_6Kv$bBu4 zCBFA*1Qn3pKS=ZPsMwoe3e+eO=T|)mEAm?%u*jt_Q`ict*l~ZN+}{Wo8CdT`?A`vl z-;j8xvXYNN^BECLS-oaCOYA&YFOI=DrfroEN#!dxw_bPVhg$*$E46_jgT#qDI${g{ z(5BChzTs{9y|5_!d;6O>Wv%12C~GL}WxV0=yWG6yX5#_dERrV8Wy#?Thk#nEpyJ`7 zPR;XPnB^j@#*Sdc#R{^+6dvg+*!8>Vq&h*0o6nbO_Mfma4?-G(5d7s*CcmUu9bX%x z2tNDnd88RcSGZT;^V!`wIEjVp*Cq;8-@uMjkYn4OG!ZU5n*EakMXH}%lw%VqVVt!h zXm6SCH`P7*&dL%~rA(gZur_I&#O^#5;vBV6RY!&?Hq*EbZiQd=i-m09m;?{nLo9eg zD#46waDT%LimVnp5}o7YytqNNO$m$X3UJX!jr5|$)h_HCXZo-`dnQz#u=2-&#jMML z<@Ir(-v|SNgLH3K6=Non3+^=cTiwwVJCl`qIvV6K_U7(nqiqTCIrp5p+Ri7_+^WiW4Z2q;{vE~H)LL}~@~J7s&QvrXy7?ol08a%;aAct& zjc;Y?j*Lnm;?mOg4z9N*!<^fquv_}6y#I|7XT{Y_!hF;KoUtupRI@Zbo`<_c)W zJC>lO55IO1N$XD0w4YU*;)KqM`#Vmw`-LVMDnlLWUmW+#+net*Op5RKncXMZXRqjS ziQB*|e&y)?xMYEQTxNrCEYdAn`T>9+zxIyhl}fqS zQFM@enk3wy>s(9B?O1kWO*X(cm9AfwSU)1@0`aXMo1C)}|4~m$6$uKVdTybu(%E?W z)RIy?YH!%iO#TTJep&}uT(tuLTsYmep$L~)a`!hDQ-EmW97P|G<>w0IMVdlxN6RI` zU;G5v9f;yO%{E3{6nc-ah1mrpS;V*lX!>eAOhwfJbueUyB{|f^zB^q&r3z=hMr8qP ze*=>nagL-gLSZrtXZuacHx=130Q|;ww$#}tao`P8&IxbUUOX3&#^HZ9Iboa(gn3kZX z(jU9`ib0?3l50l29k(%yaAZy=3CjCg5#!sCei=N;4J_Hcg4`n)qEYW#Olpvk)7YYb zZSW$}pXO8o_5*w0qMZ_38iGB7wyg|pAJ-@i!ch-T7w3Opy%(2Xo;53XMl5>r%e7`7 zZUrcFbON;c5@L=;y^PZVxuJ^-T4F(ZX3{((!L+HNth`L9M?1bYFwv+I@eI?7RydEN zilM#Kh#4KhSIfmg3S8OW5q9D!%+59L6<9nVE5StOOosrns1@<3!9* zM0Oz<#K=cDfG>nO7VQk~;P19=NxvLKvA_7O*PmwWT1h=IuER%R*a&ut91Qt=4~bYd zo2y~i-g*xs;)paver1D2hKN4r8kI!qA!k%_YXDc>d7FA3*c04D;0<*$&Z^T~4p}Zv| zC__Oo>b79_Nb!F)P;=|dB>{0FTaMNt254`OR1Wwo(n-c0{lCqRN1TPxithqh9lhP@=gd!Ya+e|gta=89&@p#X+BP>yMTAA}a zSq6m?tgan_KcP$un{_n+@Z5!NQ}E%JsZuXv6SVw}kbCb|vo+)ZI{=tX(hYmuHG6a~VmI)kJQ3>dOeYJY zj^-)OgYMwcc zBFqB!r{H(9<(G0ajAAEhSdx&`RhSeQ-3SRq!pT1`7O0nFq1<4Os2|{T4ij=r!Bj(t zV6gbuSHv`ZTnnXP*+z!I1xtp=`HaQvRTnG7Tt?feJRkXJy8G#&sbqVL9|bVzk3As> zW<5hoi^zpXsz{LFfT9V{$tIXb5GEdQ&+e!R8e4!*J&^v8LxRLa59 zOX-tLQ47CY&Kx^Uq^@22Z5Nq*KuRCEoi$X8D%H(R@zw+rCw9A}-gc4s)OwK%>7lP_g-5^KEMU zYqX-U=Z>9#GBw+FC_m{|Nup6EQ)2dGR#tHPMiLZmN!O`@z!w@OQ(+{IbO@LrGFp<*;(R!_Y zojC`_gji6G^-Z^UnWJbqz-*+N(q|Z?TnS@{*24u73Vq$X)C8YlBORl!NcPl&+?FZ1g^Z8)^11bLMg#7={%FImv zQLP6HHy7uBAC{-JWt{(?LFW{sf@U8D3@WiPtorg&cA|V;u4P1xdx(3E#D+D2ie74s z^+(_fgb;$9bZ`un*UPh zw*;zG>y>#J8kcOpUQWMMT=8^Uw=JvxJZ^cJL`Qrt|BbUdUHNJIdYCAp3H5|lDkXpN zeW_2cZbeRv37}Ug(RW zHTPu8V-j4UXs(Cg*ma0RbpQDKcp;a%Zt1;xQ`vHyHUnQ;Q=Gt8(N^oWVQz5MR!i7X z;(Hh{daSkX$;QWhZL@Ogw%%E@c8^D^tMpKeotw$wP-HrjEx35}3$Cflqb01y`OC3e zD(ZA@c}O}lW!?d*%Al-m%ygffx>&2KX>KTh{eG1OyQjS&Sl-wy7-A@>!GXU)EuT## zOEl<%FI$o2Rk;(e!9H5R-8A*F_p3}XdleW>?nDy}SIxA3`Z#f5@npWh-UB+PL}}?E zX{Cqqt}XKer=b1qs5I+^P+$+1igXb#Uh9|(LT`oqG~C2#8OBbqwvn#FjdC;zckSv< z)fIi~YuAG_1oM|kXDGX`~< z^>#>eNV;TGko7uB);0KP$CDwqfKq~t1_*51j94uKxvY1|<6AyA$d2~v3vW)6K4X34 zE%FJMuf9KIR0LOM*)82&xqIa}Sa0u(N;XxvUe_f0W81e^eS^IQ4*>XzT>=FB>wPS| zdV^ht;4)9$Dez}UJ%1`i;v_aF^h%Q6gukft?jZ1~-0aX~Hli!=MK5%vGBYXT`@-E7 zzUw2!=rn(ei=s2BS;Ow>A&1%|Wg+PNqA739qABM#D^q#5zPX}3^2H1SiSki!OV>CD zfy$x^5x@?$a zv4360$Uy6WS8DAygp>W1GU9yy{4zWxolaD=R)WCHrl(XjiOo3 ztVVQrd78k~(B%ksJZxxhg8FCu!@Ht|L25eWwO(_*;?oja6U{A7{D8pGZ@dU1c=rvbn{RL~M#Y`Q7;bW>;N!}pEH)SMKK*E#8 zFvLHYWRHlGf`_`VJGbu*GiNy9auOo+XuOPO*&p?)X*qpEc&yj$7ZY)!QzQ5!+!f`8 z*+9i)>s_+c`a{xz*jl-xULPQOYNnR#7@KLd&th<;VHT*yU}L9s!t zMs`My%GP`U7q8-{M}aqy@{LvuLvbZJmv>$IbT)9(*oPIPz+<#DV+(=}3l+>ze3-sM zHl9K&b#O_~Rdf;w9F=>3M4ivB?ZAk9210&d1)_-;&66xuqM57Z;V#GNzgBqeu{{;B)Q^1#nH`-xpP3DCc}e#G?Z(HO~;=xQGd4P{*r|m&Qgrov-DKPX|JCig?`^%J@ z7S^o>M;Gf-BI`Nx_hS{1H5-|nDdDL)7uJGqIx;;O%mP(|V76@M(vHbq8CjUD=)vK( zEw^?4gX#Me2d3n7O3HD2dAX3}4W5M1{m?|;Sx1tp%-l+;x2m2IVU#N-r_d`&GNe@Z ztFocX3BeZu%F5?#CDQ|46Rbx4zX(T|W=1dl+y17jyGMI!%dzF}s3GxyW3nT@#y3xl z599oDZpEQ+)C7n;pY}PVBIYxasZs8g1d2%tiXNPkBmH=&qBfo3xaDpKk?gYCFBFk0 z?69bPTow+ov5KiX)-hS^_IzX2cDgddFuL?`VdIt0p^8`SBbq#vE{$5K`!C}Py2FSL zlzjpYY5po-7uT`v zdErmBuh*2{6H_j7x-`vrA;%uLpYmM6=vH77H1+(qLZri|<#Y_>f~N<#1-YftFc>IJ z+Khg&MA`}zE5#`2Sr2t#_w`MZM6vkuPa>vbNC1V|M@4p2v^YS`n|p1-E-yTA@(XYL<9tVI(Z6QQpkp$TuvfP z@dy(7`CYYxoy>+U7D>mSTaoe+u2n~hCvUCpUzYtahF%J?A%6D1M=B`(D5YdC4A$f2 zgmu=cm8UGfrbU{uY4}IZ7Qaxg>|01lPqKSbd3>UyyYN7(;qbU$_JQ8=zjvsXg9jEk zR`HOqC)^m#8sLt6quWoHTSkAQW^>YmPphcLzG}1R*~S zFXI=Nt*HNR6aRl!e8l!YseM~oI<@~?Ie?p5 zrgs$2dUer+4s!b}^LdQZXY(fDbH3BnCi*Hm?nEE?|5xEFsU_fa zcwU;KDRzrmNvCgSg?v10?WfhfQPTq;tQAGWP^w=i&>%5@#>N=8_I}kM`tuaGAy{Kd zJOKB+KNsfKouCY{VO`do5u$(|xg-uey;{}ocEvLjcygY@ zX|kawjaL{@Q0#^XTIYPap6P~QA;(I&bvm;)Pf-2^TVwxGu;aeu3bm4@d))slTP0Qr z4@D}OZlbdiTANnEU4Y~`r=MV`fRd6k5)1Rb@zk+BXSB;aF0<@+Vzm>lfV$dnLz z&H2$HZdKF8k1lzv#%e$w!vs2^TW7j2x@>Q~js=5Tz%p~P*STBf_)w^~i;-_Hh{ z3zvr@=(K?DhC^oJRYq+vu1bbnN8hoZ27G zu6jSbKVj9HweB(3J;u00olVJD%!4*n^cyUZz1c>{u`N09L6qAUId(ELze7zqZAs1azDN#KazBjYA}e-0w%D zPaHc?HmQ_$UOL&vlqojwM5+LiGJ3hmM(DF?ga+%i`5t~V>)W?P2r2A-$6Ed6U^*9uG_3P!)2hA+tRY8hm~RPQT{ zR3%l*Ic$%t_=aCTcOip`)FZxpNo|9`pA{Q0`g^;$Eb#Mra599JT^lk zgA*BpP{`4W6Y&tA6F9H>oM$66`bd$n9*=N5?pOz^@m03t(@@bY6x~2O06}d~cLIUw zQw&2<&ZsC9=V$w@%`#TkLzgzwnmmBGTtAUcZI)tYe9^Ho+I`ZowWt)^rqTsLfFM8~ ztu!-ue4{Dq+$qNagT=cv6HDl-x<_P=dpX9jv{#>EEmGhVCPEz9AP8(aIF}ikueV+0 zx$0Sc5K%Y3>q{fbs8UJ0b$Vx$8>Vur%ut1H!gNjSBY79qK$Ai-du;t1EIB8L7p7mcIR za>lAi=9Jh_VWLHV@mrq4gz)4+=8NadP_n|c?~bVw!!_V8DNvT~a^&K`wsbMFuS^J}#rb5PlV>)bVDrbz={P#`*o zZ>uYsncP;8Gn-HXyzBBO>c?r6qQlZ%=xJA^`_CT_=vT=pg$!c9)0X58l$ujZ22fka zyMA=?c^xH>7y=1JQ<=<(lZs`Yd`qGW+0X(}-}P68_KuPO3C0$SD~Jc8fp^p!tv0ZZ zg+ehF7Uo0)>9I(%lf0wH1d_N%15x71+O)oB^E|c>4hlQcbS}=nMkNnyC6q0ncIO!&l26EE{{QDUife@ zY8^mbLVwQV11j!-t(dBPr+q`*DW(Zo>7wzb3s_GqGo(pkUSWrW1f(=WS-jxR8!I(H zhV1DwWrwmL;mpJ4K$y*FhSSz(Y3JB1M1RiCes=zlLOd{)yuwgACbi}vO+1|Q$!mO@ zT6bCBm9n%Y&+mso>j>(3vs|;>08{fR8}4(QzB{kH@V}Qiu#vG|SRR>^csdF|7rob` z1 z-JChK7x{cJK2k{Vw;j#c0(h^PKe7q(Zl6&CTcZy~=;AJ8=ro|*1gma6uTVq~de3D} z-FPK_6Il)PV}8PzhGfBZZp@Kf(OkpEm(QIP!=S)wvnR!ST~Dj(ovh-f0`RCq?O8Sy z?htq{LA{bAbXcZmz#02N{e2d4E6q=LJ!;#uxFUrRdiaxHwrhXtp8T&jx6b*xYK}>) z_wD6$tkBZHZq_=?Dj%!CkBB~~B@T8mJk7mdeVI>*ZtI;X7lgvj!W)vggfsAA<66qHoPdwjX0I!jUSP*A9&<9byEogGN{tw1PC)!|+K$A90?dK5)tbBy@`h;?DLNFNy2&^VW)Cz&&AF z(T>)Cl577JB#N1f{eP7#Uup0BH2=f>aF>lA%n_8TS0nm5+w5uQ`Q6UoeYBqTC}u}Q zO)OiNx-Ne+Qp-f+@pf!I)q~(8a4n&TC!xKP9)kry@I~$?KxRQTHXC^%*E|j6bnUI^ zBLB-ocS7E_1IdTfYb1fbUhNCpb(k7ba*L6Y!H!;wk)lTb()oQ;U1a#-|EyXFW?9d$ zx}E&DLDKzcdNQzpME4A-gNP{Zt9Vo6lu%v?<%;M-b^1Pwl!(ACk$U zjGtB8>K4WJvv6MP2)f>WrIH(1ttr|Y-Z+JC4ZrEFQ%?4aKpW1$dt|f2%r(>4)Sp@N zCtO@lDfl*Ivd9v4=yYypH5V;}{h8GgrAJ|Z% z_*CiSYol2)j_6uA>~)%cW}o_nA9&P!Uv5&)v4t`}DXTemU#d1IZE8oY#fY^a@cFB? zAZaG-^j^{t-}YKp-V$4K6r8a|r#Ny!$`cbQF3ZZ>gp57WpZ&nIkxNa_g)P6WCA_jC zfdMwW2O|sy(Jva*;lf(Qp(|(MBn&4ub2LmrwVb>5p%EH}!6J6WSUobnv-uk&BhzqY zl}av7=`zonC8J^3eM5D4T`_BlK@W*V?h(K&?(r>O>T9nYi^U-*u?dah@U(a$#d3bQj}J_$Bikzoxqx=&=~j0leNKUp zI{cS6DH7MK{^y^UKdT~R)%(Gr>RUlP)@KGlA(U3YAb}C^c9tWA_sPwUT{+AJt;RH0FF?S zvA`*Ee8Ld9MY|*S>8-@}eua*tS+o>Uo8*sV8KcTX>V5p=+MNgYvKNv)$zsNb0@aby znO|fJPS+O|#V8JRMFMYz!1Kh33`Pf2Ui!EblAR4oZ!9GLhPUFMJ%Ze;ORdA9R4RG< znNc-~SSD!PH=i2~&uK+XIqohw!=Drc^LJAncFd}&I#?!M)*O9q?h z?#m8y4~yaX_Lbn$&dy>wuK)+!Svi|&&nS_ip}*F+SoF9T`wuZ1^sG@7ER!$!<0?Nt z<~o4Ul!j054gUp?yb8_)kgL7OD)Lf^xm;MWMn#=$K;+#Jj#-$4C^-s&gMm|rf`-Uy zp~zA6>Hx6qh{T4k;2!IYb!4LSH3;nU7$xMbV}-48`0{=%?Jh~6RhIK7$dKF%5M_$nXsB)ka9^`x$@i3Q3)|%Z*-rC zn=xRxj+1(`63^G1tb8dSZphwF=tK9?F0Q;<3k$FthXU{Gt2=&ANe>$lp1R(hyx_fw zZr<|97|if>)h>TVOIZ6NW*Z_7$H@?P_tC}BIzOFE91HmoA`XSv+?s^=B#udKim^E` zQx4x-9G`z>Uc}1_@}D`cUD(sGiX;a5sB$88)D`7iPy@4WIt)hx6qi}_7~qTDL^W53 zV4F&-<)P9tai>N+T$@;|1yx3|85fta6Ab&N0S(jG3C$c*O*o_yxu?W)5cD1{1C@4} zXTeXGK!k<+Z2Y&dE{C0LP$@F6(q;E0Ezi~-<#V*QYYcNL0dGBiqF_Ms_PhDyT>YWm zCO6_z7a@5u9&9p-wR>gyo(jHLXI^u6HU}lKHR6j+%B5I90397WB;Imc}PU zC#wZL$>Ap!vo8-*U=RQZIM0hNX1=)s(Y+B+cq>9R3BqM3iJQbud?UF~%+^P5XaFx( z9e2T0XuydxK%D9Ab#RWznq?d@I7(H&V*DO}d8mfPqL3E@upEo0)(6lwxYRD>hAUi0 z%yN;3tq{CrFX^3SR{h!}(3vN&8kU%aONh(Os@xbyHuO15RQ)zM`tZd3_?WSDqvSdK zPlNcsLh$_93R(XDO=-*jr8WM)Duc6DwX_j(0x;?K#7R?q_R5+zlsRH`Cxm7w>FqSB zuu{ICMd^-JAQ-ik*>Bpi5FsG2Ab;OaH`B*mbY1d)rq!{(S=5KU8aDGa0{rzpU-Exz zp3?TS!MFEdt^~CHFX#N|AMB-f&QNmFo*gMzr%*p0O zx(~bE?PLI;qlp-bxH~eC>cLdOfVIaA*h+IF)Jem1D!wc&+WubTS94GA^T-fiT_E_;>NQme}q)!{k%A{{GmK&)I3<#Rq>z}*Iwp_?ypCj%0BgIgB=Q$i6 zyNUma2q_=uJr5wrv2Om|x98JY?|GGrEm)bSNj&e$RFa!aH?#N}0 z_0y#GJ{tFZYD#xG9{TCx?9a_I7ky!f!Hk{d zV<)Q7xnCI_vz-B#r%y$?0ijEs6=uDs!sYH<4%%2*4|}=CGEYV-Ve9&)g`g402DqX@ z<3K15^J=n|Hm_|cX87g0?pw7(kiF`E%8CVE7Yix0$?8t zQ~8SSREZ)fer-Xww0*FCF1sI-y_W(bCJhNp8YS|B09_hgTv}U$UV2TA@xgH z+FP3dUzW|v)-U*R4$w*{P+K`9#lw2Cv$dg6zivCKY%~2KWrqEVJkxTc=UqZyS0C$6#SLbr1B@ffi`v_ z4iKLT=XpHmYY*vX`J7*w5imo^VT(aO04qLe3-<4$Pv8{#p7i4cQG5T8)x3$@239dB zhs1hq7eDKNv~u+BZJmNYbt>|G{Zd^r;1JQF8w+3Pb43XcUlL&B_eD)6?XASs${!o? zqcU;2E{^9$@im5>WKv3^X~cM$ZYAftpU$fJ^%sm3>O<*fn_)mxxv+JXoV{fSB`EM?64dxzY=XP-y-r0mFwug7b%1@t$ zv^T$-#+&M(ndnm>fXTL)H1jT8gvesoxrOzz4WDo^uafoG@C*y+0$F{u%&aTh(a=3 z#0(Jl(uVd>@iFz}5iJwd3`X*Zk;dkW^>O4r1C?aj2>899Uc;W#}CdaVbh`DRgTLFT<0%2EM(dPpU2kl1dK2$_PYPY!fH zIJN~2<3|8&2N;PI3hh|rZn&Dpk(7Dt=*!JgWG?A8#kbJnzEEh2w8a= zdJY4x9dQUUC%xMMR>w5hm(>d68jf)v9qn0TJ#w%pK-seyva$RtB0sz>qpoQ`m8W<4 z?HoTSot@Eh%@JC!#LmBmZ3})tM!+dRoNqeWsy@@3O9>W*L8`tEJ=tlPY_n!b5=ULX z15y{Ely5`~tA-Kl3*Kw7q$u(fC;0X@EFGIpj*5^%%`Am_omtmx*L-(Nu8@J+pkbIm zgd$A3ZtrHp~(L(w^%%?ix%aKeBAjHKSkwjTt7{{bELL47y%+&6=APRw(DQ>Y;l5`ZlODq0YwoLz4wq@KeQ zKL}TW2ywK%>tnRkA2!UtrSy9P;(l1$eYHuP1jG9C%XtyiK@B=_4oZKnfr|V*(E+Tpd@2Dfu4>P6G0=4-bGKBT2^iP z1!T8z9F~*S6_jQ2P^%Ov!fA0#yshWRL{!!QvzW+Du6av0Ai*tJpKifCH(7ugs| zl$Hr#g|f%j)Obb<%-YIKcAmQmjU!{AeDq+Y8;yfNapNwIhUCZaHF2~S8GCQ5r95J$ ztkvA;1lid_OJMY8X)9r!*;1?NDv>KGNtPx=xEDH5K|)8rHQU>^j3llZc@X26!7iGd z+V(2yNiIdba1rQox!1em88Z9&PEKFn!GX*5YD5k#6uJCXjWdnfLm;kM>s>6nFx)5@_w5zwKW{hs>*X zprE=kAO!0#2~X?84!Gk;sLZi@rYrB0Ov#}ji=-`R5&py7M{`t5q=m_0PowS|SPbze zU^p{++0%x1pC<=JSf7Z2<-HuVQh`+Upi?~Yke8yWabK$8TwP*esg#6u#@VnyM*cb*7#Em4_z6poott}%qSnjSXzy`pdw!WF2l6Ei{HSu60!nyr)6^6AbgT!vu%mU?hO2R6{3TCsqSWnL}qsv5Hc(`sbVxWAGamjuJus3Ug#vj5;%W1>}XwGozcu^s7EW_6yXdaD0@$1 zLe~luFD?^gen4EGQ%0W>+#q@-jH$rs8H9k=FRs+3F#eI(0s_tNm!WTZ%9{|WzNR81Znh$rgpHll0VA-Hd3RpB*qJCaM4q>4?FwRGLz?EFOk z_Y!fu@EjQ2&w-Gvfa3gpci?ON4JOh83-pd{(zaOWCs&@j-?oM>W;|@j#dV^cAL|V# zOvv4IEUF`R`cga+R?0lCer(_h%Uh45SScTW+j-l2b-z#d3295rVE%>zRyPyun#UcV zdISP7N3EJBW4L z&7M~MDf=t0Jb6U9X1JA&SZiam^SbyuO+G);snXnrzO|AJ*wxRc29dfzM+{)!$Oo=c zree-_Zk{($dO_GXMmy_}I-y2;a%b0$8vS_nbX4WOZ@{50K0U>&*rwb{=4BGW!NbAs zNASG;wC%pVYOIe%EF5GTyEyUwnP=Da_WN^CVZ13)8}4AtXTaidekdLqr)WX4`RD5f zKhudQV#CEj&Wei`&Za)YW?;-s1t+lbEzbYm%FT#pq@K;}XNd1_wR_mohzHi}Vu;b) zF(FhygRv^uQ`$&WFgbjl^0AoN4mcv$6BK**q`;2iw!aZ&$XL z-Ct`7LtY0)hz7X1PQ_{_#WvOS!ocIVjvt{R1_S?Ilhjx+Rj84nq-5H_O2n%qa5fVe zOZpRcvb?{fe7>cqfs&S4XXtWmmRJHIu=FU*?)LIP=RkOOkVvR#Rk(%0IE=Xb))Lhw zxE({u)d>@QjMD3XO+!rj#7j{A2s-7e?^D0Udv{kz_2W-tjzx4h+B6YPSX4#BOF=*LhR+y+ zj~PvO<_z742}ic|7>T68^z=x@$NWNfph7@ti0IZscBq5u%#95lKt3 zCJ=!qZC#r@WiLiNi%q0qR5Dozqsj)|8(ZL0Mbn@QL;vV~;rG*Oz|x4cXbY_+YVPu^ zYgD^H){dJ7*3L@V^fNG$7Mza?a{zgKIAbO|@|Y39t7dk5cSAU8PXs$Tw3}j^% z@;a<$uypeuhJ2S}BwGn1VptrybgJ3tySaJQ5!(?Z3)M5jt*+bZ*ZzNN?DA;T~ zf}{*`AVvzUxQeC{1OFVmldWP(v>SY0;x7|HH0b#qgROM%tC^+;Vk=-EWxOZ#4xC|q zdayB?fJ;ZdmPDzBO`^~v)qhqLkC7)fsmwkglsfXh7*-BL(iDq&eJE((&$-Z{+0nar z%I8SV^lhbCBxxRxjX?)}N}P){xOhl;7_zo}(-i(xr*OXtC%6~Jil`PiNqmH__tM3` zbPkzeCTnPcY4MfZU&GrJ)tHRKF?$WrfFTa9 z@a4{ka7I9Ua4un$wxuX)evQHo_HpBzm8Fq`{{TtPF%(J6u@uEC#q(a+I85F2?MZ!` z0+1e=+{+UOXZdt2Kr9%eEbN9AuQkFOjTP+q^nOJGERH21(o|6+l`=WUn}Tvd)jW>C z@W&~Bqa52E1s-^d#bf4^yE+zL49)@LfI4%`nd=>+`W5vM8_9Nyo*q5@gd% z4T}{7#f+XlVBraUe_#Ns9_C~f5}jfu!xFR^IViHZU45tqVUeT}UbWh}@YtP{ok$+6 zAEBWak*i!{7Bx;=KAr{xs9DPsZXBRh%S~}yY8xESUp=ej?~il{tt*Ib<+$!D-T%(U zCkrWBrXZ3Q^b_&yvZEnrhg;z7c+@PV>w&(git3yw`U&Q8TEyJO6>cUMq1Z53g%GZO z`SB^z@K~Eo_&6I0g_5ACl*Y%k|8ZMFaiJ34@NR}*Wu@jGvMVZNwzxwWPG&{fzZ056 zp8pn_yPn_L|5d#|%#Dj`X>A_~C9ZQ873*J|hiRbeiiWPug{2sH9z7cq8Y21j0z8zQ z-BfLJf@+FV=7K~a-s>t|Th^Ape>|B`52e0HfS9m9paz>x&=ck>s_&ni4kpYrznojb zKTnbDlxZ=6t<~_cS^T;nR!vaIdRO&jm9f9gm)-YN_MaV8@8j~+V}D?w1$6J@J;+l1ZNHSz zO?^^UaT^1LLv;Y%!z!rv-+z)TQQg#1DM>n%Lj@7|-N6}8sn8WX<4lO zr4sJ*V^@JpZgML1?C$(tTrhfQ&h6hJo${n}f*P;Tj*e*mo-sgtFT#mbZBC0^@hNII zS<<<-ZG}eTW~o=MH0AAykx~@N#f*Es-O`~h_D(HlairW%oj3viVr1TVTi!7vn=O~) zp>eI7np-RXGn;3BR0TL69IV~VxwWw7^~D?|&XRk`#%qf>2EQq9LaTa+1Cc-s4aTRH zhY#z+t#?Ty+grotfeK`s@^*HtYGb<_g|an|CPbH*nUDA4QB`$o$oXYK1?X(M3u}Ge z-X)wZP?x>-_5jEG*OGS%xwUIfY1Q9|gn!cIW=N?%yY7-U`*qgof~NR*;d0`1XuQL% ztSd$s@p6+~YyL_;d>Zh7y{@HAk>P7|+LC0(%&|9v$`)I5{426+ow_n=avp4^enhZn zK{_%c#e(>z#i=_@@#HhSi!u|Ke50TT`WtEhUxULwY-V^Gv0x^x3Va47w{@C0#F}FA z*{xBVCljP&w20(bw4xk_Hrp#zcVd)T($Gnz40RJ6bSd(iWq?TLa88p$e8^HQCiz+St`Yd;NBeZ?3D?>$(2 zj04XgtK*@Zd=R1gF9h3{YxJV)*=6(*YG0g9r^{Q?Fqwc8qfkT?Q1^j-SaiT3E|i-N ziwnw>W-VNGrB;-7J7>>%IJhxMg8JlQe?Ir#K_6ndXaXiFma)s)qKiH6Wf1)n-&gPE z<|e}GL%U_1!E~^e%n}c*@e*I2O&7RpzzOjTRlKHa;^csE#6>E6tD9s47Ewd2eThxs zY9;6h&POOzD8HSmpz1FsMLruaJ#f_ALdY(caeAcb7uCp-w!fal#KKB2P=SloPi0#w zFmF7aN3>qy5JAcb!I%CC2^toXEu-sp7h9Uzg6l7hy^@+-G2@Qfj&7)YwTTLm_V zsKrVQMSD<4z2}JNdEEK@FeB^xcl46|o}$U%6GuO01e^YLtjjzp{{ z6*&BLI9Qky^wh2oaw+w7lUJ+I! zQn($b3|HfD0Rd8DhZ5`z-cgH-;`lNVgD1VoY%UhA$#y1FIFm6d#n;3<1~Ulet@9Po zq5!Oq(5E&=4tq9l&DYR>Tn+?J{)@e=4S*(LQ(y0cv5-=D+N4!qz(67T?I+E2&B?|% z;a_plMBJe2f$To!)D1?KxCYCt>p&VPbzEfa040S4_H;_h>)ltVSBFG8rq4)6S&sJN zBrL?CJa|fbU*_-E`~5*yS5pvwPn_+Fv|U7$BoEZ(sX%SijCj%Gr-gbY;)vhf(n^2& zd1FNBhiOGYN)d^i$Q+G)!Z{%0lkZGs>cEQ`bP=8WhO z4bJgbM6C=qJqZT2@sMIYSE^P9R0YfJu24t23GUj@e$_>%Nu;}KR@QNzx^t~A?4{ey*)=lODi#3uyritw0h7t&~+Jg zn=|=tMWjONMn#A{b5_!N(?-uDMV)k2zB?wmyD%UyDfa0>MIVw}UX*ZM5tmW)x3hSpyvM zFu9WNWaU8elciWcOE|`QyE!wTB|D&+ys}(LKcD6v;^XVCC#e$tfUQy_N)rsq_zRTf z47u{k^E=E;LKl&&gz!N{%`>9} z%q_5e=U`Khfk6Vv5KPy=d%An+sH1EYk$BB7aO#O+!fz)#Ol!U9j3;$z7$gaDX^9oG z@ljQc3A9B-*OLt;2A{oeaTiNX)j7%Iq&rmlT>IZ_L+n0O>^~QLlDJ-m`xq^Y8}339 z4gcK76RR`pc)$Q^E=ySARl8$YOTt8bRA;-yuI8zCyS@uESUAUhdbYjP>`MLZnJ-!& zJH4h{Fil%5716Xkv%f2W%R?!ez?D~pUDG%L5W_>Ud3_=?Xr*SZGn;)t5<{uGo3^iQ z9?+Vr8_$)qpxgF4V^tHFS(=GEXIQ*m;bDsJ9dkViyxWXo1# z1F%r`xu}QZuTxN~m&pDgRk5Sv$4IFlpEFGnkzi@yP!1UTWJhe?IDFw#_&)El<|UeP8I_pmzw+AEAf7D)~u{a?waZovfgk(P3Yj}2kDbKi90>9-Sh)# z`3b1Bpu<=1Ip@5*CNsWOIMd0j))PkeN{t+fbFfxT8Asuw5L3B~-U_IxSdBvV@rWn+ zt*kss-{Y9*(^?Nv_OzAKa#~V%=e)WmN!Iopga_^grqKwR$9$hBTfY`44Y??z{Fh*b&N(V}rzQLQgA|tubm5J~a4ys27Bjl&aKlt(IK8@IAONX3r zREQ9HE-SLBmxEW^tUj_Smc79H*A#36jRgt*08h+~u%CuuY9-JvC@rd99shh>-hWWr zi4euii>8-+*;Rt3N*!&S}7IBH*T| z@s`sQXgPTSYOmsDMbrbZesAn4_kCUkz-8jp{U?F{-w~xaIN1OH1$>#dZo*+J`cH6S zerr-_IucWP`JrgtwrK=Ic+nMdToiz)qiYJAL_W57dHM044_g^Cvq7iyB8=uGMvy<{ z!JzOZWtKdkND(FjqYI-+(WQDfsEEmp=&DlrrRXAd|3Z_^C^g0QW|)}QoPDN?wCvCeC}v=Z{%N#V++& zJ1c%H+q!y6VQ=T|VaPO;JS#(_E_3ogZa}<@@>h5youe85Ku2Xn>&D2_f`ZiX1OZ4! zzwf6Of6L)ecvkppyucqC`mmM>j0XyBhcDa+P9N5P|5OOGdk>usPoLPMYpQ<`TT#ow zha|P0HWeO+58B`3bJjk|x2N*?0QIR;w92*7GVYZ>u6o|~1zH3f(Xy+FgMO_%tkzqu z?M~@K4H2k%h^u4!yqU?`n-MLFjzUSRq`y$+s(8QhUqO=dzSCzTz)kQ@D1-ak!AG-7 zFP^&9Gd&#!f1!y&-+I%o#Xt`am1D_7-SLXH^;%2+mi?!ivN zubl~Hw>J`kt8}N6FD8A?R~+Dnm-9CJqqgD**fwVCmR-HoiCT1mqHOht%3F$FIFV51 z4H0EJ?|O>o!k8dpiZh9Od- z6rT^93chne#`50b%1f$Q?ZY3ab^^#p9>T=Ef|-AK+@5ZS zz<|8;BfaWX0)j}Ph#aHHgK`?U!Apm;G;gjjh`;_m|MA`&p;uTz3q%j&4n!{~QUc?! z_Tx!_#X*}W&`LE+@wR_DWFD+9*PGj7)_r$?U95f>Ju&2@Qw_CJ8Ba|p<%Y?eYMIcr zZatkiALWv+#3_Zu3V{&=d_nVjw7`n4!iO{Y2Hl~XxxyExn275lC`>|<^rfiau>0b8 zw*QXUDZA~y^or+PVEybe^nZQc75w;cKXmo}K9u}JU$_r1iVmRTcm9{ff+536&E)8h zGeYt!bZHk%e6^-1l7nAkXfl~f7DN|k_4O`4s>;~f`eJi2{5CjV_?nU!kx85^_b6=4 z0S{cmQLbhWXaT1nlhXlCN`}7OT(Ko#w8oR@ApF|X(gbZFl*N{F*#8;vylLZT| z01Z5fY$?cgSP5c&Hdsmsq!b?Md`kmDScGrm)9c}>x^w?_56h`1##H~)IEt*Zb8?m9Do*>)Rd&L+zGpbx# zhd9vYf-v`IywE`Jn67|E#xB6p`9_#-$fzq7FVMt2qZ4PNvBfe>Qmex|`O7tUC|F}H z+$ivO>oH97A#gj8$*?|{2y0D$q9)DXdXw7G!#Sh?l8f=Oc~$oTy}JS09Xb!jhukke zV4cJ>S+TIinXJ!UlC2}E5!zTFr+~UmK(Yp3Yiz-AY8Tj9tb2($)>X5U8z$e zV`xcjZiFGr)EJooo0|c4b>qrZSrZ0bWiQjQVq;)x2(5|0(BhID{nA_Enen|Gw8!%w zT)OgYh#(*th!*mKln;JjS)^b96G0TUUPKWIk;y1bUtPHX1c7VH>iDOhMZe*RFAPkGQJv zB2=5{4rODqj4}zGf=diz?|ub*dZq7Bi2P(=e27FhQwm4VPEU0d^quj5_p@3{T{Mxb zEd^9Hzg%PomxzJJ@?iMM9^>$Vv@@jblE$Xr(t^X2gq8ThvURI`*Pa%_tar_xvJi&U5d zDP7aBH=w@U1fCi4OCm*j+M7o^aQ?K0kZG=}5M96Bb=d26X67VK81)sNhCaab$K7Dg z6ZNw%>R(`#zIqKoG;SM{6tv!LnscNxfJr(g1C!5m9*4SQWmqBOtb%701cVtwTS$r7 zST|y?gK)0;0!Njpv}u)RwrY^|I!r%SzG8_?}d<5#@zM(vHgA0>!k{rD}S znsM@Mb7)~-Z=nCsKPi0pV1aac$0PGX=5)2fFO?&?Vzty#%OP?D8Itt{^l?PltWMm#Ah!gy%>e2YT|E*Hx|Os zvY^UiGzR;~X6ZI}O+d3MY&wl_(rv5%32p@)Af^GeCdN+LB?%S0lCg9lSQKAkDbdiB z{Amxy#AZHPE2GjF5vqX0EW$S&B;-@W7FpT6fAFl4AYfnC8?5}A4ml10f0=24JkUE7 zJkb9jgy-5HndBO%H5cS{Ahy@1)=;=m=a#-|%hW&TPBL^Ph_hAo;NB!r(WaQLx@u>r zCn+~x(UZHbH;hZut7$PmBkcR_7LC+NRa(TSh=?{z(*R=`2XNfjrNK1Ed}oPJ4exT}sK^R-Kpp{8s+M8krp^%^JA*y2KT zA9iQx%_t}YXqYKCF!PTA}wl8%y-=4UVB`9uLwr$t;8!i>$zo-b*Jg$0PLYYpsy(FQmD?iN5*f^ zjzx@(|Dab{{yX*+2kZZ;zc15P{C&uQ(02o1dQySJs!p#FeA2_PYtx@D&Mf8yewtqk zp}dvtPFb(Kn$CH?l8sKLrrFMae(jD9d8~E@7p6HO(tSU z@-10PeMmj)AAehbi=R`sc|WZS#b+mNd74o8Ey;usm4b+0yDf|HqQ#oPu^tEMq-yz6 zLlI^h60(o?_13L(6{iT`w-l50*3PsI;AEPF1ZGy7IxlutAi1Fe%Y)Byee}gH{%P(s zj%q2K%1v^pU4jCwhDdbh&9bpBrCO@seczTn)w*YkJ)?4CsejBo?-AH>Kzl!Q!@m)3 z*Wu?eDP+^S$wV^bD6>v#P$syMAs$%2zNudmKjZ|E8K`58aE_LPolG&mG+FuC!f7(m z6o4@9k<@g9;kr%2T#%KTxZyrqwj^hT(rWJP8@H(Pp8)=mwz)wE;Wd?nUNQz{>;jXn zmYNN}SLOG-@NvDp%9Cj9F7P*BBfsJD6s~(H5Pjjb7_Tx;*ib%?*Wb$o98zWeF0Fjp zNz!@}5bz{$6TrbHJ+ zgQj072xC}m$T|a8#4K=km4HRhR z`bN`I%qzvZbUh^4MaW`j^@1+^^fp2klh3+B8V!v!HeL>Aj&01L;}aF_~i~J#^h+j|92g4 zRzAYONK~i7>+YJzcT_$*i7qP*h~3v()RmI|G4IoW2-24P4ooswK zWd(|z8cM?R`^j?N!g}S(ZaI(|r0KdQy0T$Tn?JhxA`%dQlE*WNaQMrrEFKJG)hw18 z%pSo)YN(h0&Sh?$D4ktm^rV4_FO10r1aWdc5;l}A1hQ=#mbZGy`nh|-bLfnlOO5W3 zlIt702)7gNiOfc;!`apPkppczwr`ShdLBJ5VuxX|&=PDY8pj>(Jwcg|?qgL;aKi}c zDU&+QI5R#Lk!zAdQ!-xEwH3`HzPE@yl2H4(!& zTIshH9n6lD&2a%mRfc=MLP21GG`4xrogluC>nhUUgOp( z<^NZX;`7AI2I9b_6LxV2taBHgr{AUo0fTF9rF|7x=z^u+$*AdOjWzq2bbm!ikI1#u zBA7JQ_o`x{O8VVpmZTa@>+d3ymowPc9#Qw0{)Kz}E3}H35`&EmHx7f(!lTf{6;mOc{dNCU%w*YG*H&hXs2o%5SPqp5qz?t zKt@?&wPydch6`lHX=cQ}8(*VA`vt<1di&xsLz$NaH!f~@V_E%Pf0Z_K84a}hQ^6Mp z0p-d_p?0j_=HL+;DPk!R2mY?uCY?S=$|qjc}1#f_5Y5L3mjM9wct-QawGg8o9YIggyfSdb92N@2tV zOO*)}$wW#4;gPoHonT%~KtE3I=@c+%77p55xSi+#ui1J;a1qM0aa&^X3FeOg%;ab_ zP-RfS<#|V@kCRxDe5@vJ*)qq@Ig)13P~teBi_gXAR=M1zH>zYxpJGoE=;~S3z)hj| z=3lgLE1_;@%AG7u+77BqT=y=qO|Ll`OGs@7tW zZ{A?&2Sjr@#*KOJ?1Tze7fJlnXoy7&<_N)2uU)`eK{rv>ggVOsH3}&r1;+eB22<}h zU6}X*gE4b%vT$NtkV<23nf9WjkKMMKrJce~nR^^S@L9M~HWnf+?*OOTDDd+D2zGjv z6+<1Acsb*%x!GMXpCIh$Lk=LZM_=m>URNmSi^2?X-v%nL-R-HnV_I+_HA`MU%dD<( z>wG)VdZ?YA+2k_1eD}Yv0R><8a~?N+8>u8a{@=h|BQTToc^*3JTO$k3b{2km)2EFn zRzby!)9FNbH2NEwZ@PnvT&g4!9`IDYmHd*}SYY2PfIk+mi*$H(IFO6?^9333*JdFo z`E|c-mn`?iPkZ6^JtD(Q`QclZ{tsjC)FoJ$McIaJ+qUhtL5uQjW$%1uu*El)VRW&PCNnmQ15zb?8_D|jvE2pqV z`vo77@OnTg2AN8h2J#kuIU}xpOlaEyte-(rp2>?(iJ(4ere_OWI8fFgf7xpYJDJ^o zyF7TIw-;#UV3%C4dNa>loZYx?Djo1!v`+azeF{%YNLL@(X`b9Yu`)fcx;_po-n*(4 zA@gjKMdEcbvb2_Td@#=!E>MIeDpGsBv(a)@Zs}}m18;5>Q|wIdk3rk25FvH15eg!4 zIa~2g0}a^+)fY)Pv}*|wR#En`oeY*nBXLOHBZ+*=^?eTrXDk;$nJ!J z)aH6KGVb<-fkro(*=45jkuD~~u=$~63YNc6_b6kYW7_kmyJ{Cv`p}krBhpx7|W6HmV@#u?6&^OnX{MiRD~XAop2fi$PlAJPwXMpRpX$^ zzx$`^g3h+X;c=KN9K#`k$mWJOE(MCmtOVlpIiB&eS7loX+E-4rYQfq#YV|@%7x*$j za3dB^MN>Ot#hZLof6l5|;Zm(*+hmbB)VusHzzUo0%lknrk%UT5X9&;Cq+8KP3C04 z6q)nu?7|)Im`Q~oL@7Py!x7CqOEnUpI0?+VGZd4+Nx2{%4z?8wbHS%!24bv%0T`yh zQ8p1k7HApK?=So_{=;!*RAX|I;9;?eV+3h@(bfirahU^sBdvsCLK%jLVD5q_FAdl+ zd>S#z9jVaaKS!9m9%PWFV&9d(nJO&wrat3MqvrK-7hxJAO-p!m^pG5oo@zm+T?~L6 z+{^;W1=hC+?-Zc?iN(GyS9pUN)Il)b;jYi1hfPHubcD!WJ+-6;4Apd9F-iTL6-0LX=2C}K z6}YDthgx1pjvkkPGd4qlU!dLyh!v+xs)^i_3jVE;0$wwy!96GuuS@C|w5LgERgSgu zMVUT}+P8oPb|Z^Z${a1+{9(%ZGCNsp$H zCWcVkF8>zP2}W}(qal0EeQ>#D_`X=b%=7-4>$a!xh6EbbFGnM_Rwh>goj0el&2kzF z0#*T=c)vF(?^rA5;aQ3@4&M<0x;$%p?%#{#5GqL?{YBc6b5MeLm`=6qPs?&IBoR5; ziZsvf8D)_f2Gvu-_)2NIjtOinTx z1oQm3M@DE{*ZB0OXj$uixvGUC&g`LFZzEu##R}~;R?v3U+*zNn#l97CCOfEjglX(K zh`~j+6R>szUFP?cd528QqO8QNcuZ{H1*GPVaGb|{b^x=oj1}9D+XA8YBu5TQ!yeGf$K9g1x z**=?lRIxvmi5`C5``;NQMS^GV`1QsVD>dUtk^X6CQX2s(6>V#~nDatY|g2V+pWn0?B62GC6O-b6BchRQ`qaTo?i zHyus{*KRpplig8D(mFq=U(T?61`+FJknM20kpE(_PyLgHTMrj{vmQBLNeHXdxv!>A zFO(&-+gY20f?0^2=-mf&nmq|C)%zDLse8WXtq^3WDR2mxbPjC)Mx>X1qDe-Ho6oe! z-)CM-`rLPy#<%M*_}{P1&%EExah0#9n}kkcfpTs7fFcqv=f`De5_(|me5AH;mj(DC znQ{%1>Tzz!M<1#pc5>dhDpx z=B4`HFmY@kyfC4_q_V9al^IwP_P)Df1_L!1ok#VA4=VyTsvQUryXd88I6};YL=(Bs z7`@X zFw8p>AMSACA4~2q=lV*RZIdTNc63@QM;=jLrwLsc2&K7MI(_1#0~M~e0p8OJ9ldu` zN#qUJMZK*$mZ^mt*}0i_>`b!*{i!g19u^t)-;09xws5t8trYptqNw1eE@8|#e&GXn zoq$PB!5$(?4S%goJ$5Oc>#E|p4>C%_UMf#trGnt}!#W6-d-?*Gc`&tdoRuF%wlquB z_*h*SXhNYitOxg6)lb0`n!6oakFd*RYr=|`u*ogFUCA_!u+O{BNIASUMaT-G*#`to z(AONacULpS@Q+))qpD8g2yGgnch626omI22J@Sme$qs1pS;z7+`NrNm_3pOf@UvH! zN#1DE?wd6RyfSX-EJ5wGuv%Jdx9f;#Gd~09IZY>d&wsKDukxHQA+!3+kJbxtPY3Q| zlcc^b=RMF>^>&^Sr__2gnqCJ-i4uB~T9I|uG@txr z1+PGrGH&Gk8>@Kp%F~2$D8+t(Vk;}}1fjsV`MavF0xd>+$^2b?`*6kTtV>%z|FqC; zHv4~jp1aRsK6W9wOdwu)#Nf!^ccF?Yb-mT-*%>gWR{)n7lt?5RCGhCtMXp|qZn8@^ zcgS}|`0nVcq{UhS$Hf+K*({E&kD049{%>@Itc#TYmU{n37Z5w!e|83>;tuU2~Hs<>Mp9_eHv@+`<+5m<@=3apY?Xn6z zsSi29{ta1zE{TU)LxHTz=;2W2;ae*MVn$MzjQur&0;xdVA~EYbuY!v0x9eT5P;$Ug zJxb^Hb6S-$WrxK`Yg6HENt#3pmZcYcX>=GY5@{hc;^QwZ z!=~{4FB6GZ@2D5#!oWJ2cX^i%1%Q3R6e*5bl1QLpbauBL3-Iw~Q+Uy*8_k@pZa*Il zW2Cbh_y$Q$3dQZJ~w_EBhmXWK)kj?1_Aw=M;Y zjL91nOW=oj%5BG(tp`iak}eJ+{z;fBjJC-`rFm`QXZ;NGB-!Ztaj)+D7VwJY{a(0M z-3|(hQYM{zluvfX2B6yd=nB|CZ-Y!LZW)j&-2d#g@hbkRIL9lu>a~0;pRql-bLZkL zj!}hhWxNPjs3^H}FlubJ3|mDU-%CNCI!c{g9h2V_y^#iZiAfr>H4>20S|b9g4n);; zw8JK7S)Q;cQpL%rEr(9w#z2CWwRk8qNFJ2v# zcy6ZIZ$#|CXD{}9(cdxL2hWMwY)TM?_$!V0uW>u)KoG3jrQ=hW6;#Jv=;WhNV!Xxd z^q7`&_bBt=HprqqRR)qGE3p=6Mnj)uMATwjn$5LwB>ceb5fop!6iL~v%44Rjb?{p| z${JwKTLcjkiE`dmj)*30Lf=skXu)51e_-!g!=i01(m|-tp`NS4avnowX()Ewf zH0s*D-AzQ%zht|L?kfLY}%DIwq4TGCL9Z}EcL!Sz89yyS(}L1Z67L(F3mT=wH& zokeGAx!=izjG8bu&%KFkqNge+Z{UXwoZ;`eN)WWNE;%Rpv919$hcaX8(44kJAO#rn zy-wBA#8&7m6qq0{zT!TR&%K7-=szva%qu>IsQD6@#i{&f?DL)I>5;ReYwH#oHV!eH z!w3XSm66DCW(r-PP@om`A=%=K7ichG-0?yk5ORjP6FYUuveGZ(nsq2L*osh9Kt@0QZW&2QU|HW4JgTL-aml?r@ z_6`GEnG$vgh4cfF?Feyj_v!;c2Q7y8>UCC5)IWo}zvWX6L?(pP-vU4DR~9S~R_{jE zr)6hod9U8<(F!a=fZLsF(4mhGC+qFzJ&GXcd$S}WsW4d$w8x*d%NI8#&rCozFdK$h zn#;8y_gQ&49|uCq$?{I+#(fS6pg)bg->7 zEwJ9+|eJwu_93xjaN+4_ZD0_pb>%#n8VSv0bvzpOV*F*Fm>2ASfpQFw1HUYnR`u5(I& zGM=dW`?HEy}Cqr5b>P~?= z%0$5-&-H6W8pfhIZnCNa@1YBP#T ztgPzV;gdN%%}ESC&u+X6!oq5^yNc7p);Ya{ZL#^PoPO7?CD_BmCbcz;c*HqVU5@iH zMG5cM%`89v)<*gxBa^Ujj?cF(CW z8YO;Hwg@XZ5OQC}B5%Asj1mBX@5Z3Xx~;xx40TnQ_J=>Igb0i>*umwfFUzK0GM@8} zn?AX<8sap_#+1J#ato6=s2@15<}^Q9j4Dw$-PGjPgNf4o`{G~SrIZZ?)6)huI3sca z9FeM_3GR2<)N?HI@F?u&&$$^&g@cK^yKtb(*brKis_%26dteV`mH);FkU)QtY7n>m zV*ngDeJJH*pI2rt*KPIIQkhz;sbi0fF^4<9x|7}AoO468>|bj0w+ms@o#T9hp9Z~5 z1K>p{*Uwc1{n}+k7{syVDr|62J}EbC=3H7*t*mpUS#@X@X)a-*zORTBI;r3_ug~2- zORBg%(2z^t0I1!bLfN~6V|;jid&_7qj1({!^-pHZG2aoSO(F{1X%$Bogfr#(-jp9w zx|VPn@5T1>6Jui}?}umv^OpNtSIle=Z{=)m6Q2Q!X^sv1vVl&Z2{NJ@k)mngEJmohemjM+9$KdH>m)?V9);B6LMU#SJ)1}T@XcaZ?-NR(GHQ;^C zPy!L6M~^nj|CzPe$h_TPy*W>_g~3vrwQx=KGa7)8N*~7h%?1-);w>|{op8zwEDeXc zec+_^I^mS@$+90na7>;eYHh5uxGO7=D?lvwYbMx!mY0NYJ6OMnTD@eyJ?2(_L=tw;9o0Zua}vW>jP4O~V#`^F6HE zP#(y`2khUtFl@PiS427XT;5$%1YFVcS{jIR)fnVeUgzo){OHtH9QMm8h*&oj zIt2bk@gADg)p4Jo^$|Bq>f#>y~_il10MPB>=m8VHF7$Y!Jue~EKs z+o7f2vP4}mdieFB+z{!xmTU$DjD|1Ls6Jb_HjkeWjr5kJP+Q1D9ZXyJm-NFP{rgTq zgb7hZ@sC?vLUY1Wp?Fc(q1}Dl=>wPQw{2ZZ?DFUK4hHhCCcfM<$JLM1>+Bc>rM}KV zxy$~D?^`o9)}!y|S*eIB|?DQMrWH5OLb@(MX;+x&*r9`ixul z`O`CW#RW$>9rFZA^2K1|k2uS(ej%I6z3*2lsbB@E0v{njf78nsb^M8j!6*x4{v7Id zJGq=%^2}Cj3;#cWG1U04-WQr!m^0fooQj`-rV_dJZ)@C${4Gm9m4f%NmCn&*Ql)Th zKhQ`;`YkCp7;EKq^r-2DYuAfHqj`7^io?RMa9ARe+7?xZH*9P!m)z29(+j4#W;h=9 zZRK#=pmlM?q&}gR-qYEeb7OD9&$}D%pv_^_cpL=8d$=>sCkB@MuCXi3K*X;REWB6* zt`jd~R{rpoRqndH%4Jf^h0>xN$EQ;OI9_w8~Q*Mn#Z+*A?DPAFJpiUq$NJ#%9us|fFh+un(3Nr5jP&7>dwUu)juy#>v zbUldlPkTD5dxAxDe}MK}ajpKy)!PC)9%*yfGC`;)JSN-fn7%P)kc+z2{sR8gMrE#o z1Sc`IQ9JVCX;bMB(t?_s7v|ZWyb3_xh*0(C-6HlG17O67({K_T7DIDXJo~``cQdKC zAqZ`q1yydD793S~*t=_{<)2re%@1;$D4;a^wt?K{{x0zO4m1UA;_hNUrHs3feEV@rkXM*gx4r+uitQV>o1_StbMO%$$FEKS(}m>6-tnCeI@_S(%c8dtYr% zP6>tRo2i3KM=Z{ygFA*7`iR5DPL@7c!$m_k>)|(ClH~!B_aq-o1HrP?Kq9Onle+s_ z0#d_?cM)Zsk@jt7X3)10XSUUpyIrW8uq{VwnY^}|y~gdiz=IQSG+}~xLXGvii?UjV zR0I|A**@0H&fevWE6R+#0SJ-J<5UvQp9SDd&uTiNAxj{@RjXUuv>*q&2dyblNCZQG zN`q;nrj57fJr>EM;VS7Y@uOTU8xO+lWOaayXFy(PWSPVv9~YYmU`rZ>nNy1GztYdB zu>{Y9C=x*IMJTE6(xAjyudQ=ay_Y*)r8*+GvoIXP!In9KEykkIS)y1d5oSgGhExFz zCx%_ppnG;H#IB)oQ*ti;ssrfVGXtJuO3ek4>94Ogd$R9nNvA01!$-6|Cr6OSmBZ zD$90)dtIX&`jhJJ9o-TzcP)%YS;7iHT>$pMeDCgKLSmIul7xZd0Lx!SVq$pT-9fxj z0!T_nV*Gn#5Dg0JF~$bKrO`6{9!ctxoztQF&v!4NMn});7L<K%dDt=!GbT zh$t0@_`w3|fYj2*!(Y9ZSlgo7bTQHdL+qmqM5xxz0CR)SSI2MRs_^KSexI|UQ`B_? zr7ThdXmi`=A}v5a>gWeqi(=1WU%Gs}c=CU%*ksd}J!f;r6_lq&3|BKN~=`O2y9MU#2n^m?Rr<*7EH4#jfC9A~6`Ow@(EHtJN-HG!n9CfX^1VwnC_E z7F-rU;glZ|r9H5wFH|7_Y=2H;Qt{NQw1u6x9!=EYd7NT59Ys3PFzIl@BFj8;C{_XO z!Y+ltvuCG$Ed;=BpkQ4!%Lekox_n*x#6;_ecHG6qSNP6ubW^ucJ;xFC?s6AnN;=BYIUK|I`9^t7NM^M zG0Sh@d^_ot!${DiqDF5B5;d6%mjUll1utB(1Ik8D&?ONS>-;HyBfSn}SNkJ^d(y|4ef}}O`WcL$rs3$0A1~EN1q2}z3|%Bq z0Pa0@mPz-N3`qK!Jk94w^Y{V-ySK(0g^ELju2dyp&W^9b#H_WW6-~iQj>%(p?p^;K z?Wxi$&~t~0f#G=USUkV6YR2ZLa4xMd37}f`>U_PsIQ^Adt9E;SQsc>)rR1KkuNva& zA`Vqw-jD90azr#<8W0nRSy3%YMNw5kpYFF6pUdc^|F^AdDfrTabl#cFW=zILJ>euO zaecgqRATBFG$0Qp(6UpqQTtC3<1YO!E4oPY3DE|>T}zeN94pwWQs(pRPbU5oC92>k z|CjgfWVv4w{7{FG@wuBi^%DQ^#f;yn9?D%!t}c4>bZXo$=bNIN)B3LI54isnsd;AU zE*P4U6k`7u3hC;yZ?EE6+cvdwJeoSd!c%Gh;GI;k1}_Lb)clnQYA`V~mp>e@^?1tuNa%pFzRch5x%5QyiyiE&kYOx%Q9+UfOQ0w55LX~iEm_j$6oQ? zJrvDiYG8v){4+6x zl1`K+4Fg&E!i?{Gf0>3#{z$tg4&uv2i$~L`>yj)pz8~|wzxRl{PeeA0-{2$XlK;b& zOZ{7GZI?TL_I>)1H119HYvO#Y*|{lBO#3jmwB&rh`=C{aNesI;D%l6tQ{RkKaORjE z@DQYOPHy$;WuB|&;!H;t0JQ<kbU1RQD7uhS zT680c5ax8{mucq5lIg9mVmEnCoBh~KGWN(_-=rx7ZI$QE7OoPcbz;O1D6$8Eb>;nD zsm}xX_wceXs&lik)eb85J7QX3*pK)cFX3+C%O$g;`Dd~yIL{3~GDtm=ElxCH>YncP zrJ22cs`nB8k!$;lHokHL)N2PnwC}UKykyChNm;@DV$)Q1V#J9jfJYNboMC{4p|Hbo zQ~F>LE&j*2`mPp~6)2}+bt&!b>2Riq$b*s~Dq1L3EEnwevwe zuDqXRmj^%7lKSbye;Y;MaVZtmk_HtzcTf5oNG#sdAd(~?3$VJqKv;&D{WeEfsqbQk zTg=L?;5yLgJR@Q7lPE*(9EQ5yqF6AYd!{%y>)Sbem=qfjmnxf_;pT&%xguWLtRS6V zN3puD7|=;1{QG_4B3jteK!Ds8n%i`_dkQrdo_%BSmIm(X3Y@y)G?tAz>}QM9nFw!X z4@5abBk&koTVy8kunAIslnJ=cR^>)05_faeh?ONafmh~J=0wT&`{{hw@AK|{n+-kd zbC*x6R5if~gbf1I=}u^)Mhvd^pbv|Hkv>|)JDh_ZA1JuHx$zRoIyf=~D?dbGYG z%=?JI-#fcA(0f+ow4WbY8rAAua}P9NMob`!V3#7$8v}xXe{~&9x||GXv}dyjXUjg{ z&}66-2&_MZP^6w`KzvtcG8GBXUb*bjNehmHfU$=|-YPEp-+3N*TZO1Tl3!znhpy*N zT>v%O%gPUVy`KPX@u>~_(&Xj)+4mFO;n16}E{ul|RB2~aph7=`J=JbLM=>>v^l%Q7 zq^EeKyJ^UR7T?7N-XN z6ynsufK`39{~#&^b_k0}oFNHRoAy=BDZnw>f8hPkdVDABjSOJtY|QmkR-iP? z+XGP2dL8*t#|=|&V1jQ%q&9Vp5ylh;z_>S8@I%lrmD!!-8iB9ya;HW%i%FEK2m-tr zv}w`%omt(8=p4vS!I3m=^yFzNUqw>9W+7@vMc?&yT%Oha7Ix^hNR9-n@(81hvBTed zFxZB|9b)`!vc)sC6!&{r!~z&sgKR%YKldy!ARI};1MDldGXci?EbI&AQb9PD z3q)Bjha`YJwH90~C;uk7=iW~S8tOD`9YV5NbV9g?8H@ed(d7g^Z6$7Ec$nsftZ_o`1gNaS&n2cjE38S1#+rdj>QtRKf4XkH$yD?z&k{X zp%UX2?^F^TsImr9Z98_BNJA{9;I+>}^{CEH49X1@XymOG%yTJQkcnCH8;6>2&v`hG zHK^!AXvVckOd0|tbh&+;kaaAcxJ*zG`ka2V#CD{ zvZg|nD0?dPdaAiPCvg6@yQ8ytik?G-|12Xf37Z4K!^C>Eg{*ZGb=0H(4R&j*u+{1| zn4x8|_(OK3UOZiw!1n5&E0w2lsxBhfxhAiJRr|XC<4DZ3h|7os6`3f1Sb+^?!6HhL zg#|w~!gPn03FYJ!c+hXmnm(jRw>b7dm8}Sgf5o15$I;3IbT~9EwwIDgT-UFSNl^{h z1Z(*Y(PB8k#0oe;2+o3~ljOja{$diU}@lmaN^f zJWrb{G)}n{Eov!v`F%;9S5WnJ*sIW)N=@-CN@}0p7E-4&@bAl{YP(?wbuhlIa|g%@ zXMdVkWjs-I%efmqCDC(8rrre5xQKA2#zpnmB(>U>F9H-$|3#8?Z!O=$dQmH;aS|;T zn;O;bm*wUvOuDm&df!iPXly8DnJ1mdq7et>q1-?OpAR_?9$}EW; z?ws_W6N8N2c8BUw;D%WancG&bev7NQ$6mjG3ZqvUlxAQ2|XM15op- zhHkLvRBiR>(jVCH)czjlDCZNxk5sy3O(?g|64|*lF0TsH;+3x&*o_z;H&QipG`qjX zjy2P~J#X}SdDV0GPD=XIRJPOFm7rC9&B=d$5&eW2sja{Oe}2+_fg507sQz0p{hx$7 zOl*w*QH0I;#|hgM{lA>BJz5lf*ERTFvM`av7`Gk>9AjF7FljiP2rS0Ze;9w!-0x?t zWffXB(g`*+uxekFuByv-6`4CVf*_2aaRMd5R5T*`z-hua16=P$$7k&*PfHqTG(n7S9wRHS~2| z1}Qwre6(WgzfKxsL$pP(81xg4M9D`gio9zw=exTks-pPrFazfyjYxH2clcj7?jzlxrOSYwdE8MfxW+?I^FB-sCPhe{ zw?xd7kDXpYY}S05#$}rpYB^YpikyO8hqmJLJ1&3OA{!Ty^R~?ijj)wSYf@OT2IFZ7 zGQ~Zyf!~$nUmjSa9xt7G_?*b8JFnMm4?!X-G>;Dt;+6bYpRlWJ2c$(M{rPPx@)gVL zeoflg8CHmvVMYkYqolEoPNlAv&|oQ_XBZ&8=364fj;35cT0R0ptXoKM6p}kIs_3XF z4>3_m1_XA27OB&m`nyI+0nX_Ptki1tQ6iT>>&op!oAE!!GkrTW*$I#kp3U2n=|&SP`l648t2%E^UWk3 zW$fdL`D_MQof7U0#iS;CxeDeEK8}mRM~Ru!rVj+&Wk?9o6Rcr_^}@52MQd~|LD|HJrY#2Fv^e3rf@R( zDhidmgq8bAyE_Y~)#w%2%lCMCri0zvsG9BO zQyi1DF#|0@c@(LmOb}Y!sopjZ5I}!MZE7~8*%aDtlvP7r9{fO`DG~eEQ4(!U%Xde0q45rnC>nsa_znN zlw4nU9Hz}X{l%8ZDElLU@fCLZ2yO%*b%WsWvyq-10eRb0tPdFpNGL76iIS06W_y7R z-= zle%zIndKZUUuPW#Lb;^Q#3Moe)4Cy?Bwdm?4Ysx(aOiv~B)Ai|(s%wZfOr>*TI(k1 z5SrY(jTY;&ds%rjE*$43QCi0h95{z70lZ~&+ z9mtA+Idu6*>NQM}z$||q(%sw3yO1}i%i@t#3wVgf8)tH!WndII73Es2epLbXRr;WK zt&U(}HK?+}|1pn<|6FRk$p?b4`ZMwQn8m`qu9qo${>8Ub#A*-GiY0T7?XK}pPQk|;*JRNEahQ2!OWtQD+H$6TtJ}%StS@eHk0-9T*L8Ct zkTV1Plhjh1Y~!@OpPhaTYbr{SEBN1pW-7tRx9>_(k{bE{POKh=ZatZ#2w*f24z$|y zk|8cPJ;^T@%OKl&1Ml(Jh-G6W1S1ol_HLI{=U?lrvN%Hv%5G|1!o$-TV$Rx^^dr^V zyTd_E_N+=jKZn-t-#r04oU3;!9$bMz5T?0aliMR9Y+foFDi7|*^wHxUf)b(A+?S(U z>+Lh#ry~1lK$!hh+@9%&+&_mfqtpQ2jb~Ux)Ck&Bex5D{e9HZGT%su@r+?xwEU?vA z;^--jVoQKC0uJG{Vf^%pK>C?tTkLkkTQZEsZ~sdZ5*|^u^qo#m|n~ z9Yid6h=Z_t29LnNvBnbox=PC>HNHC#__-~If3n4oVGiz-mYaJ-l(WpvPC9xBWhht} zb@z$;jIx+4l0jD7;9c6V#AfYD#$m68NakxU)uRf3vnI-=FPhR7y^E~UwuC<4fS8dh zWsP`M1~(xlRVKY{_|QAtdR5}epXy?Fc?QGaA#ss?4{?Yyy(RUmY=>-MTR*J7??y_yR(!t-cNL7%;Q+WMk>cH%`B&Xj4awf)|e)LnbA zXHM^N4En1>`bwpo*~C9#n*m%M(_89pV+IK`M;&l|IH%B$o!u=NA-UessC3<-JAYrk%|X+lYcSh zcAZ$K9o4u@J?bYcKs4ktPHg1)yllhX-V;8UdP|*5g&QoIH)rYn=@h(;LiZs2BBDpt z&AbYc z*B_TdF7~27duo*>k-h2s#l8gIwR`|oGT2ua<%8uck?cl(_U{C0BnxC>G;hbRHR;Yx z54~=F<64(HlLSzP$0iAs>tIzuA9Ui{GxcrKKeCEtt#YYBJ_tkvfn?1|-t!$)Lc(-> zL%VDM0||BDG#hNluWgb*w`iSigGbwcPFf)hqbT)+5LAPZKIL5wTt7L+{nm&D0-5!>r%gjcOQ zyCA2cJJYUn3mB+8Sz|{UUxJ*A!4Cv+$tQJf#5@;L86_IWfXEz6LsW@)CZOuBr-p<)G6`*!acjBsl)<6=C< zB>7L4p5OPZ+%13ihVkHT-}j%U9y$z?xp4{M$<+A|n#B7A!YpCiJAYfvd(sO?j&k$qc8iqy; z1fp!~4LhZ|$CNJU*B(Z(dDf2lYXRU430uqHa};EKiZF0vn>I-zS)B_!K|FygXC@H+ zLHIVr&6)BssHhN085XG76Z={q1#0OS@>=6?JTBKmqu4C&UyFlVZg%6MZC2cTRHaVB z&#PY$#}lBj$0#C{o=2av&U8nPTE@EUhs(n$Y8#1XlFnjkl6=7|L1v=6{yFhZidDL! zq6p{fjZ<;ADHOSc8+9hxVrpTj&hbB;OxY<_a~TPAIc)Fzhd(vZlLDDzsx|R8T*O-E zes&zuE8Bt65f#~dHU|(B4Ts?QsVx_Zpc)_2#>EpJ$CX2&y|AEfVRz=VNKn9h_Kj@e z@)LmosED98O(2)uB{RX!P@OZ@9yyNh{h4{L4xqC*>~Lj?WuhTw#%2YWnyg=l1O4q|2}mX)+ox~-rGYFB6v^(*SnViD{b4-Io{GbyDPSvr2xt8 ztC;J&+~joXC~J#94cmG1;GcE#@+gB*Q^$32a&J&cQ^4rZu*Y*VU)ShEfUVp4K zy*5;F;80<=9S`C9;)1)z3bp@OAe5$K?5CLZDF`63i^O&}d`l2xVNI$46u$zHSP#e7 z`@iGeEhBw+#>gNNAn-3#ddInrKCva=KQWw7>y%i8Bau(Al)PI`IO)#+;mi12b)8`3 zofGfSTsx1B#b!(brMc^1{T$_E+YrQccBB5VW#pT84}1TC{bULB9L6hbQNe!FpZMnM za^&bgQ9y36p&UB|W7tB*auRcHl{v*N1KWGL#P8C1O0M!O;ACPIr<83qO-hW^sv1YBk$$ss!H#5Orfn#{Y zYPfPhnk_P6HDu}Z%kxDz9YJEUBYF4I8GD-o2IKow;W1|TO`1zjqP$58T`8y^5lk4g zh{i-TZkmw@qFoY*>pQauRV(x+VzF@}R-H`jHcEe&1U5mNo85+BnIr7tfG2uuIMx|9 z(_20^Euyswu&~33`mGg&9EGd49kY}h|B1{lqV`<6NJ{5-Qu>m| z=nPW2RQ2s(ElnFZLGU$uep@>c=H0Cje+>hUZ=XzpnPq2hQQ@TPbGDJG*(a|}Y+>~3 zvICof$B?KtVJA&eo4fo=yDAw?BfbS*tF*e~_I^S9r$q2dae7llME)n3Sp))D->mej zW-Ed~mxr)mkQ@E)y6=;)WJr$OUHJuW$D*Gs%4bBm=q5)9Rv^$`)%iy034J2XZatU& zkWiZJyN!H)Y6Ab3XrMsNV=Ra^6h?UTU8?`^Ap(?n=vbndwete^!h-8y^YpFJ4*;Aq zbexD36_w<;v1K|J{)mGsL@E1KtG|i=nx6dbD~n;~kMUWNMY8Pe>E8}Y4#*9cFfHLU z%4?6Gk2K$QYm$#5ZxW_Go7$tuo3uyGQ6HV(Yy4kepTpeP{}NDG{x@$A(|?}Fdepb= z{$cd}`uYaXq)Z4_BJm54P(&JZSo-nixN$7=;brhKA|gV@5~;_>Px|^W;V2av9oyU} zA^{jh;7+5M`!F3JM?-Cp-i)%M?U-8P9=}UDYP$2bqJYl7O?AyfPNxe*`ku9b;D5wvUH7NVKS+6_lcpSLc zBd?7*ES34#CpMjTN+pWJ4*8$Pt2IUq2XN2fsj~$*k5e}v20>)T(4|e;m^cQN zr=xNDojQe2O_)ATqo1$bA2`CkHL8QR%c2TA8Tl^`-Ycx=_q?|TL9*b^4SHK=4fkm& zs&x66O1rJNk>js8-k^zLSWGP_O0Ojs1>509Q8}ZA<>!nxVOFbE`aKH`$cFzSJv~nn3KO~Vo-m0>BpDUO?WTNPE{Cu zjBVnZB?;RRcnCk?0NY=Wu1K!s=JQrfL#Wpazi(FYHTCL| z*gcti-oAQnJeyO!ka3z+A@1cUfs!g3NonE2o&~l>4R|`c3ytupgeqpU!eU>3>FIhl z0HgWIsyF?>FaVDtnl65H{#=DKU1k6oXk7loT{69kYQZ zyZG@b#pIz86nWF^%TBV;mtSVbJesKvKC}uZB~$i~ScjEC>PSQ!T&1p42*maaP6A*3 zQ-7u*-Y5^2O;sj&X2T4GlyP_ADIMro+cI5|rQ2rK21?N2a7b<9Fphxgu;PyfWkY=1 zUgG#KIqFR-XIv@+o};Wux7n|jD1aQIMt*|Cn#*5w9~d2zA}zxe^JwpJBAZ!oFqH1n zzYLyam0^<%`mC*&Lm47DbXBRLwzv&SPh z9V@))0boSA5avnQvZHi;8&kQ6G*^OD3t6c>!e(f2WhRI!)KE#{((@^f{QF$b?0FRk z&S#AzRP-S()0SCWtn6XW$tLbga}|O_+g;c9!L5Oy;99#{dUEH z+orVcI1W=#$r^gmV)doSi){DdvZ9Yjw-9j_9WY*qvuV5YGzRLoq<>?uoWkoau<|iA zpry@NQQS)qNzy8Rgr#yRG5RD0k`UFgk4h6G{HNzmp%V8Jh9(niD-Y=nzqR>+wF9 zSPr2G%Wfy3EHRcbvz##2+)(Uf6f?I#(ySe=|;1^Eci zjZzErA+A(lNlt?1jG(@l^$zQhIuFp1ZJn|#a%cca1*EE_DgYjOa<}a@4`NY%j=A?q zYaa6q%5urz9oz%-+7t-J0qL2+@qSJI9*oLBZUv(+Sm)qFX-sHM&8<&O*ioyMNOh^J z0^CSv;Clb&F=o7P6s%Y;felnT?Fy=TQ#$2gP7qZsr@O(H^rw0tjgTjJ6(b+0$(6GD z!t=7Q-X_-}r9sFs`m35LzWMrL1;|~ZezpnveFemfizI9fm|(rW&+84z*Oxg@7XhofG> zTGPcN_6(Y@P-IoTj5`hVQ+mq!n*&G)I>s*gos|YN@A!L@zh) z!1tum5&PnNcrQ6gYY2i*%`Q!CJ(JYIosmg5T1wq-iwQEwDVUQboWTv2VS(HK!KHbIasgzthc$;4Oz_yl4j%>iF(Kh3Onfq3x2Oy`6 z(S0pNH`u^^s9`gDpCW3UgOitS5&#k?I#e(|ZIQibMR5o(1-0AtG$DHS%(5sTO)HM; zzMXYs6-|&EC2Yt%@5%M6T=?Z{?^*!~ zH|M}wk2kF|sas6kZLfeZ)vLn~scRO3^pwXm_}4-LGKu}7F7?pklmKx2zPVzT8~?O2 zo7HDYrzW|wP)NJbwY}~~9>N96Kpj_(d7}2wP(~lH&9XuWXd5FrcPMK-ZTqG(k5l?O zj7{FB>+O}gd`&)Fw%?DiV!bTp=D$T&T=BKE$jouOHh8A1Sk z`TIz26d&UKdsfN7yTCJ#Y~(BzS1Z;VeShAjkM|emyyfOXz>flTZTQ>+Y<}Mr{YN?# zG6}YkTO%dgOQX|ruUYuM66{nFHiqo4VKG$flA~;!TerW+m`&fe-@9xZmF@lwYfrBR zU5lDxuh&bgOI?RIIekz0k0XmHDK1ohmL$s!*>#UA?cVmYy4ACd0)t&9MUCrI%R2 zHFoUPJLj5>n}E&AY3eTyxfk+8iPhKmhDj=w6a)F517?*xFT- z1~ofCT}})u=jRVy!IfB^?MdJR_*LYt(X-nOBEr@yc|I^YYI6Rvf~W4b!AC4iOQ3D~ z@K|d=Xm7JupAXSm^F?#Q)idl!nvGaLQP-H8Yv97Mnh4^J-1^t(jdiRksjEinM46OC z5I{-3ZQ-`p9l*~@4Ue{2V13BHL%wujIjkC2ekE0q=oag+LPo=Ma9P5aOr(MsD zxaLr4k4YD1I;b2uF|*C381N{{w69&i*}SHcl5`$(Z{^6S=aK+PCt3-)&G%tm zDN`jqu`W5 z)rJ}xnjk~d$nL5MD6YT*tYd2Fjq=crBq1}mB+$`3HOeljB~Z5bK!LTE)4rn0=uIkN z1QU=`Sw-kAv&53MUHhxore9etfKu*ZS7s(L_GHMnahRaU5j2O%H3#pIRzdWUusNi> zl$-*Xdf;CP{`csi5h30vdmKOn)1bgFUgF>GB?MSsjP`g!x2qi3m9SNRkuaq$L{t7ir?7<>26;YmkV6Rkc&~vzU(CXD*2dq>QA_v!FNHq(r<%=?3 zR(Wj%Nf;$&Vu%`wu$FAfnA%^;2R}+oO$#$pCp$!+RuI-p!65H|BNRplh$SZN`LCxh zPD~Ko+{Z$Jyj3x9@O4bqZ%}hTk4&AE0k9xaY}Hm_t#wGGg7HKKZ-{3iN-3`j^hitt zcUr?JY0S0830+oO=cW$xhJ9y7oOax5~Gq~6wwc(lO-|GdEh{?pkSmWR2Zq;CpT?DsKQ6gs&OoEp}g7Nh= z;V~%h?`iRP5`|K-b(%AUB+TjjF0A88#o57%Zy$XfXDAZ!f2|<^Ov6Yzo9yB^0TJJ0 zv}V*=@uY-c?MQYv97Ee2;Ot}OrEw=bhdLyn`2+-y+K`CXVE`^90-CCjmAECt4CPx5 z>=H+ByhQgGDu$3SSC=Qq)&}Mtwih+3^OHAaoF%;;b@wFs(spN$jaiG#lYgY|6~2i% zSZ4SG=6C@>tu^=omsP#zXdYAhyF*0w}SHsOK0q$ew=5htn zniPqZ%Fu5O%a@0%8f+M5sf$Hljx=?->aiVTYG?bFtj{tspYi8Iluz$^dJUHP@#cN@nuu22n45VIH(LN zvGXY6p`EEtB`Rs%S3vf_XZOl)u>bvyi_a{4nFn=9(CP2`o1G=V24@7g>V;V*O1x^Y zrTx$+&nG4P!>5v~RR<(2;stGp}c1@df;kMqWK>^z)eSZ!$y+1B$C8x}q+!o(Ldj^yHfo%>rMxJ)2f;a~Wf258t+;#?BpC_mDXlgn zE`(|}2;AJgJ+fSMCu91aZ6+*vpzgLC1wvXEZS`G37KRoN1gbMk>#E`7vy7$2NhPi7 z251zqS^c&%8q;(?E?B!Bh={iO&poI|qOFSvM+zvwt2$MlGM5NDBR!#gWrq{4rE?^} zyeVa@{2uMSKcW^$4lM?bFnQGd-GXN=3Uo9E*>mvNIOv)XtWWH4f;d8rFrSlCQ{^$U zT4XOR@cN>5BME2`4%>7lIB z706FHj}@#`1gS!7<}EZF`vveB8<{GwH8E;43TYE&14H9s4=Q2ObeIuPyyZkP&(p;@ zuI)7Kd+(8$XjkeV%E4;S?Tp+Qofi1RisP!Dr?=b~H~AwiD@dZ8E^yl?75Ory=I%4% zDB*qs*E()Vv-4NYnjLHw%Y3(0&E5jU!>G__bB6>(cdPs^+2<5aTDsMiMB%?1hqPml z2AEc9jd-BI6U7YeY}Ov~KG^58)(_^n+=H%U)6>CxPqfH z(=aEA31Qw53dt1)0WGYtKBL5kpPNXK!@AD!;8=aOa>4aXb-4~|A7<*h&q@#+VM{g} z2&BpN)}(?g@G{n;e^M(P{r(B&baJcx;^7nGNVfCJ6bHgu!D zuBt_N)jIXXp>M{HQ3S z+{u25i*0|szfQhEiF{3M&F)>U>p|P)@@wG@+Tr@!32k_3&r2ULADnl~{`z^3#G!4kui zl-3d~iJOa$&nf-zz-4T@GtMmp69UR?UGP zj4`d0E#G&&!iWwP3Oll)S2Q#h>Xxia%SFHy9WlPPZ4x*!K8Ii#xR%Ivu3Tywf{(s| zm?5zj7F^!#u2zoeKcRUJOE7ON3agU8R?Ii=HI~PmFx#$Xk>$3P^M4!<5s!`MBTBZ! z;^3xu*=lb6{;KS}`D}5|v%s=|!dLtYN^T`~10CsPf*dx#s=qR^>3H?2Z0cwpou%VW zuaRn$Izo>O>cb6}jGr+o{u>J7vi8h*HWG8W{x_J0wYryjL+Na=$lKHwOY^`Ij@Ngs z<3$$r?Q~*hPX_VZEMpT~+a1ulApH{|^gMj|e&m8Zy4cB4N071hAvk{y1}Cc_`pXMT z>=uLDR{g$9-1jx1#Xm*#pe zSuf(U(X z*&)^33{C5_^e{kB*B}^1I*&UYeLc|{fqv4zT7N4Ges0nA1L5&Ll7w$wdRQB|X_?(& z_XQ#;;~wkVFW=g)UCJSp%wc214F4Q%Z!mRLF(ArbAgAB|Gf%vk^y-U27r(3aHe7oV zc0n+WJL@SD()mN&wxYA!1qBk3RKJYs!;qD%&HFjO$}R`#M|F zi7eWXP|XSPIR+=S_K2~l*;sWGJ6idS`8E`zBpRd^8>lDZugA?eIV6dl$5h5D9G&v) z&T;%1$)8lU27GF!&Lu)k=YVX475swwuvQ~370uKk4vnHkP_N3BK#1o&W+|8l1r65Q zvaGOyRv$>eIuCcglgSW2V!21xAe)6IgX7=2MC|}MBx@)N2m0(Le=3*}&OpYOzp>^HVbhCH zd^OqZfWFywN=hec+3_SD3mNL~TXsqiGv_A5*rm!PxkfZ1s7$nd{B}uZNLJp&GW(n^ z@AbZMcw;M{!qyb}NRXG#GCj3P;#5SWN!B6rNz^2Pwszf9f{314Xe zkb#bXqa{<(_XX2~Q6$QRZ1OL*;Nn*e_#%6rWen*E#bK_j$(YjBWs557q?&iC@&S7i z^e;B3WWW_X0~5(b)ao?gLzKzgYu#Q-`6yK-8uznnkPzbYfXi~LvA;I7f|#02kS3^= zjyCJv6H{oml3@2tIZ$pg;&Wz$kQ&&t(i|B!#$T5xyaUArUIFr|FzWoRLpek2;(WcC zUfIf`P2@^4H!=HS>bK#EfJ8A}fT@bu`dEqrFks#z${<~Q^yr5sTM!q3M|<^h_0SE} z7^!5*!vM}s@O5w&=ekGF>qCe|@-NE!I9*Km9IeaEzfp~&Q`eZ_JU4@;BUpa(&I&Xl zD0aCm=C{{wsBx+Lk}>zE??>Se@?qz|9G{!iXi|JxP`3E+tKA?Nm`Po$^c? z|5gPSl_k&&;|dWUEqpv4_^OJxCXIEcBK#A81j^idmV&qKMiQ_2m?Q~%hK zurSWv`gK$-AYSTUIItp&FM6}BHn?72Hk0>=;b72j29BEQPWk*gx`_%uLYPm(Bd#sQ zu)mNc!u8n5S2reeDyjWU@sa_ms+@XG9F?qi8IWn%N#>ab{FcSQ^V?oZiV%1XB)CTe z8GBZsj17KK7)nh-rLse|Uaw@rH|X?=IiuA}q8R_`t!e(oU{DOQ*0Cc2=271-k~hKI8&w_@`#{^p+rpZ+3wJzM7d+)Z=iCOw46)!AEdjzT|bMgTUIZ7w?n z&-ETj%{3#Dyp>bK;7Z>`ywGIP!#XlXk z2S@0jAODQoLq*qNt6RMY0 z6Bn04R^*t~2?Q*vcuh$dp4XJVAj^(|1oA<;Zs{cna2lBU=DYLCGUsIp`MVZ5H5*W{ zZ0)9a-~C@~z46^g!G}Xh9s1;FHYb(1)v8Wfv*HqnVO1uy-MQEn>Ms@pNCfd8j6?K%!Jp2Vaz_VJN)*Z#Xx=1AMdF-Y=%hS)>wCMd_P<0< zn65TSb~07!!%*M}qRhstzmC`uNL<$uesx_0E`*nD;mMVx6 z%j$J1V8&>_GBpD~dADr;fY1+sh7!#0KL8=?f2W#Z=KLRF+Zv63Q)U0B$K|dyn+jSg z5CGpvqDIMqsv?pa`!aPrfLM_^no^RCa`W-FO^-kzLX)(12?qoy25c^_4j zK8r+Rz=pY%wdUuG@b$$m-Q8#pM21@yo(*o&q54zy?EBHWRMFsj^?Oj%3Olxr6+W}J zvhT4z(8vXEMd)>Lj9G}2ZSW_CFE+=T6DiL5M1gm419J2*0vvVxMJp`(frRI=A9jaMY9KM<&Bo$w!|q-$FHmnC*}GI+8G~SfY9{=#tRd|3ce}zuWwJpb;vQ7>h1F}ynxA4$xr9>hRb}OM zwADnRF&YWB=%PgQo1AP57e1`93XCkbJ$J1;tiZ$8suX1Nn6=C(Z~dZW8@Gbv z+2`fi$fI2C$i^szBgv1(&FJyDKd>ss%3mKq#<0L7OcxnDJMT^LbJ1$O=dV}v^x9GM z^q|2Iv3a;?T;F1*nQS|_tfecz&iw^5U2n~n>}Up6BKNA4p-J>y^eC!_{{k*=BMXF? zDu#s$2Q#S7gUV;8WvG(Y1M2$=vCYmIky66*u_NA406_Xk0Jx(uR%F{%>~#bFTv#K= zR|#^jxW~n1-Sj%TYODlI3f{-d(ghuC*f1K644Ii^4D10#j% z?(gncS;W0C-S1ZGxe8c&lvRr!<;j|ybh1d&l3$N(4yxtOfNOoqXa9o91<-z-AJ}k_ zphLo#M1V5PAR-V!C{7cu#G7!6r$rw(|@OQ zhiE!434D-m467Qi`sSd^XWuwL8yI-zmML*5i9BgGjS-zbLYk`PJH}Kli2l~%xSF&? z#@M&4OVxE4GlNN`HVdVHe|dui)S0HfTmN~*aJ1GjFucO)xnVe;tmNG3g$4Pt1|vj9 zgwSCYu2S_xgbw>qemUky(A%QVy#=R=fZS}BnfGROAM3E{&DWY+dSn*$PxJv(qtpvU zmCbjkKLwS|x0p2nipfVl&8`I|CEyQ&nN($aqBmoFQb5SH>qtcr5dH`GxQ8e>Un2l) z_O`(4-F{j5Hef6hUdUnFR*=d>cMQioz4^p^yB^sJFCE5Rp686nI`;)cnNBjH*)74M zLMP{aZ;MRz`U-#${#=2|pBYMSZe&v?IKvrG31H&{K}Y?$Y7cWJa29W(b|W#0L&Z_q z5PW?OIl#o@^dQU&6*nflTO^cf4a45_{!CdlzUXG0``p4Ixxh)zcUqmLXMp*H~`>HlK#L`5*Xb~cB(mlNsI`#gohl2E%Bjzw2h~kTGQLl*b838CV zj^QjTP0bUd4qk>78pXh8LIYXcJ%L&Wb5X4PK_DWKPUX+lhiK%bz!Cj;GCg_bn>5)S z*e$1TYAets@ZZ+WWw^`<1xZF%MNv9V!{PRC^EiW5^+ZL(azQr;o;-8yT1XIJQ!ADh zJ~!?L%5*V&Z3It=iiXv9W4aT`D#L6w_8x{MV`K>AOW!SdPEwz4|1m4A5GEf< zPP>gth0-@4Eg40bKhSR-!p9^rxKxKslwhS0DGr9Wsysm_;vmY=x$T{2Q$x`cs}I9; zYIJvzeYn3&aQ*qji^mO1!yMj$+DMWRSNmr?Iwg! z%bSLv_YSGmv@vTAdz*EF_DOGiv3c6;R1b*wy-I45>jz*Hmnix>p!=s@d%cJcsB_CA zgq~4E9dIzU0=@CE8j=Kh3}eIsiBDD#Zq>bbNG)tyaE#g>Ucxdwv3@awXQpvl3 zhl;IByQ9pSJig7xrZpD@n=R%-At_B?#SVsP%5a?*EONHyes7Cwo zrl0SftL4nr64o>*S`M+>qSl_pi$gW8MnG(t3@H-f?|K*aJ#~LY{v=H4m|abvY!tZW zzSTlgdPLKr@4lQW_udjFBQ0fN=cZ>L3g2M5@dm>>}YaApY%2=W$A5Y)=N2 zs7Bdo9N3m#+f(ajNcgNH+^AAC*o!%C@vl#kdk^;_@R8quXqWe^b2GaDA0%02 zkoKq`@P41ps@@}mlGig+DL=&-zz-J)laiK2r-gABa=z!%8A`(yhAIUyd=sJ{=zk)j zrC<1ox)Z8oeI@E~AB@Sr^6cM=u5-Vjv_@HRWQ!gAwf`N_G`rLfVwJP!#)OL5|GFw@ zWF6qn`B`R=+|Vzme;0p|-42};JRZHqoqJm4`vQa9wRQPVc=lhpR~R|i{{Nx>xJ|Zy z!br6xLWNz>g3=tGgRY_eZaZh37ZCRTR zDJdoy6K++~lqo+utZ~;oH9y^-oC=CZcRKqeD%Ybsy{q${8X74bjS{8$Qs>7ze_*~P zSI(yn$dJ;w)L83Y*KKmOQX^DoOz0*^fLTE+-ZyPi`aQ2ZKh+_YW$)^$7v3vMW_-Ed z$`(EHUpx-Z>E&$XdQ6=u-byaC$MpvN+~+9C_M1Xx6+QajjaTKQtc zOn9o{a5<>y?ma@pu(wTx47C~;na4em`Jwk%&6#yd+{~%B*pLN}G)KsxJ_&v9m8?Gv zMq(v#ZNR14;qJDZS#F;PW|nSnh@<>~b#=IprFd3dbo+PM>N1XpGO#$C{yIga9dON- zjEA((IH?4@EL{PH@;c&dmS(wPqpQnX5JCDbDs8fQSKsW1^zo8)p&J?iRYv~%Qpz5% zauP8=2k1=h9qjF~uyjHF%YAHb37VrPU}*~5j?{|B|9)I=w?ZqE#e&^#`MBoVDCg_a z7AyB3@l$CliS!H%=C83VB)+wd_lQu>HrOm4oZuO{^L^g@>n#>o-*1;w(o(uP=%0*lnz5>3sh_sO&QVQ87$7vrP_H+ z?}?kdQ_MO>D10sT6vO_3cAyU1GaT8yzSo=G0~gE@*LAs~9*F!k``t!TbQ#&K=8|H31q?mjO4d&oCKYq(QnX~Gjs+TU1DYZPdRmO`SYkM!O`7W>C){2! zUdt5UyY|)n@Lsv{ce=%bSZ~s=nsm5l-t-j&>3e%v89q5)`&9Ht5)G`WGND42*0{sF zE&B89amiy(#(;T16bP^T}*nvb);=5n%P}P8sNjStoO54KMS22B;EAhC!@hD`0 zESL-KsI7{W?|B8pxSI*QkX6IyCmntJRYt_8{FE{!lCvZ#C}Lbi*7`{;*)##t)`XK1 zJTUYPkfj+i6b=D0qNf8myDV#bTkx4NGxvDFKdcKD`lpy{@jmu}$n~`%((LJOS^bZA zWE}hD!=x9>@u10OTwZvY)I7rN4-0g<5X8W^GV+LA&ko-x zX!ef-ii8vx0=fX9UA)}nlS?m3=&{2lj-w``%<Vz<*ANENGB_oy9>a!t)PnTs<$G1ZIqAco z=t_H?Y3eYG@@VizLcR@mSoAw}prvcttKfCF4!~fORWPk&Y0nlR8ukl?k^jo&#g(N4 zHFquye8&w0k1GxHJaVd1#-y5tR7h!@R3v1-8=NMVJL8q7KGwfS=irTcorjmbCET<- zKV-fF1n%S|a@N0}RZz>a?6+LEoWB)qi$HtNwP$Udb+fQ5WH6zK#Ib^!e4l1zk#NYa zep7UhbGasWBI9fceTh{1lXrhYO}c_gKZB9 z7wIBufDNQjZg^$K3qI6?V#`UKPhAM?1eXAK_?Ax8249KUf)1=v4 zl%3;VxRi1KH(cY0RgUY)0x&fflyPTAP`~5DZnqs9`lfRB7GgztW?2|kBRI7x*1JpP z3rP%l`<~whFPzFOY>iLY@&vD>f_cM4=SJjJs`}fBo|r^V`8<33&|=vO^6FA0UGY!_ zPZB?K4;%p@37rsIdmidj5w28LV%YK|NhDYZjW1kMh>u_XJ)06K#&9PKecaU<0fO_w zg=85Q3?**ft5r749Vrh4L{z4qv-*6p6{IJg8v`4s8H(Q${oIS4IXZ2BYsGM;L??WP zC3H4$w=}b4fD!$t+ABF5Q+CE0L`W6ThU4}5tlM?l0Gi?KOM>cofv|Zo#p=( zLtJbA-y4&9#{*>%bs!M_0nTEoto8}c>dEyE6UROAC74MhPASFQ=RP@hECPN=to7QX z)XbneQMbcOa`I2wLk&Pbo+@Egi$TjIo49qo+orsosA%*l6tb>ev+f!9@#u*gx8Dg9 zpV!+@KjV`9>cAe3r%C%Z%1Nfa+Y=!xGxov-X%lQnGpH_8FY?N-j*vXA-);|{>BqT2 zx{8O^(F%{NjR>%lQ#5R@U&k`#ooJm$cXNx%Eb~%MY2X;?YiXgnSsS?;lRm!pOV7vJ z9JbU6qD=t3>^DpJYgb#hD_dfhoW8y)5#H$bg0WH4RanGnp3-+Y4n?k?%%6(OJo7Z- zAYyDL)1tAqX$vCT4jos4sTY>mo7lnC=_7L?$|zJdf~R#z{PxDl^400NO=eFRT@-2a zH`b{+tF106KhL^CH?+XdlS*lJ|tx1v06XFn@Fxs!y?P#0VJ)BDBT;B*{t{Xw3GBgO$SvdvBj?IIX)C^ z-kcFOfnF;0^YLG)1KZ*DJUrbKINi^O=th06?1ltIvbY1N-NaNM3pjFb50y`&0-fQ( z=!PMcH`}?$bI^vr{Y)bhWlB;IbvXJ}Ul8d48n>N2Ipu%Qs(8lA9D?`Qq?V4jygqbV z=eUb>m$-iSOg{v6lpsv?k3`Z#gSfjkEFCbMz`!~=Z;Mb6=h^IUV#AzWVwmQm_Rsk;F| zg3-(%boy&yX5RqNs6!0>14N%hXm1!0whjLLjjDbq zRV^1rbc-@z#9=rIwhiXnC73M-Tk|B*m=Cl)#gS~Yx$+jE8+NCIaRj^>i*P@46DFcb zmyO%^{@lB#d+;(o+*@jpao0f!_dzjwfNN=@sO5>!zaV2kp`O6Nur~()>*)i{2Mhb| z-xgg6Nr7;};ed;}RmXJJsL!kucXxxu=C6K{(#y1UZe}r(QqwL(rRh;fGZ)df=m3~> zmtSJ6hgtu`y6V|xorh{$I+EK)_txhsg!A=s5Ytb>yV-gNmf_)^4F4R{B8}~Gmw{U2 zCwm#d!-sKjt<^Twzt zm~^Bu#-U6F-V@Wn-e$;nQOqG4^pB`PDq^@38sgiVS(lBT_LXYjNl1+o6WAe_Bbu1v zw9>>EMrn!GNpM3%BW^Hu5HB|Oahk> zh|-l%zF_vB@!fFgD(aQ>G|l-%^V2H_{e)6n-7?(HC)N4Dt7W3@YbDqG+Mu}3nNBze zA?-46T&1>-RYIcckL!IF&SPNW(g~_-5f{WE-)CcGnNl^lMyGh(*zInDl?*(7SN2a~ zqup${$L3;uO098VuDZ!`{gk%EXu}#m-BP$?E*FYjNn8-~5Y{3-uov4#LVcj?ldGCU zAleM|f(J8ca6m6X?lKA%@QbYV7()Ic&WS4)6W4Z@#?3XCR^kxx{z$E(0OM{e?ObaU zx4(U!#he1gNc`?=6TpH*G!F z_823OfbfjQ01zA%BczIq`~=Cb00FS5#+}ij>D3u21)1*2j0q)PE1zu> zZcKKt^YjAxkl6tgA3zCiA&QTFjeSxh-dEp?s#u;Dx7aLBi>ONdl(9E|GMQAN3szkc zngmH)=G&b`(kUjAUKJKSMQZ zl@Z5y)rQlzp;eO09}?ob=>+R#JI&ksc1i$cky$BJ=Y-XF+NX$DgpmVTy80~&BZB^P zkHh}xA@^w^pWFPLdcN62Q@TRG?A=CvYz_$M`Adu>qu&!4n+{i!oaCzxi}pE+_EkPs zaJzqAa z6GM#;MUt0|P@$B`ci1?9VaGH{6MWrBwQ(2B81hm0=xlI_C>U0FTW3+K0Mbd9TW;yA zHIdG1s@K1ms;}evNH92rKi7T)4koTT2LK>Qx?o@%8uwni@Kut?ruCfGQfiOPi z{T`D9?-^EDo%7WkUgV+z+iYRM@F3C{-;212R5}M=DUMpxm*ME6Y>3f9|Ey>zk!B)n zZ;YJut1m6USL0p0EM%Q&Z*I}<1qJ-%ASiVFGo|RlHesfuAVEoRq1raxbo4t+)q(^> z4KJ0l@w{8Bcu4e&t8zg~OU$XxhoM%%m~%ZV$s(14MV|HnYtrXfp-8?(krv5w2hX{n zesei$(AkMP2Q@vR(%2iUH;|?sLh00)HR@VyNH;T|(3(MYcu;E$M-Q?mup4RIf0U|# zh;vzCG!cXK#lH`{(JOE0%wABbrWSE4Rr?VC5EJi) z(&iqX%M?QpJ3a{yY#w16Hd`R<5lUu{@n!0%oS#i}!>5fGqbJ`z!|&ek40YU#5IX+v z#jhl?5~HQr1y|*yuhsV4ac{}C2X&D6vx)eS0gU{s0K-HW5(u)Ppx!UsvMm+K4EZkV zcgr~}g6pSNEpjOT8Ri~(zbFraFG{WTBNU5-L~PM5sF7vK|U!!==} zJ&W3pIpvAK{4URrBd$u2lwN;Q_z?Cx7y^B?G~(;7)k>S9(fcYe6_)e->gNiL0j4Y{ z3l9y6Uoh=At6saD)uFZrzLnilksHT_w;HO<>eWDA54v5XKLf7z0_tFv7aYpthYwOy zY(628=@()(rfz%5)9(2k{uhv`2W;s-KqcFMr&C~HXa0Yoa#&p|?q7EDU$xkrjR}D& ziQ??I1z8vH6&(UWL=dO+Y=BL}=0+;1SaN6Cug`^ugzuB_E6SUGqdHCE^RiO^tpL){ zom8M8sEDqJ3F=i`f0)kQw-_pkgYvLSy%$6xlen|8Nq_AR&W}4o**x6;HtZ_j{%^zX zpq$LNxmeqK1hnr;148+FvKq|ZH+9?;W$V5Q0K0-L0XDa zmoA-QX#-zo!}`MWp*}Q}xH_QMVrx5h++YRw{L4;^^q$!9xHrWXs}kmx3&)2|#A&3^ zAx>VO-ITc%*}@7>_Dz|?l>)p5YA=fowbwKFJI>5H0 z(AMkss3Yhb8+9QL37|U3S@U?}Ty$98)I5||tKn>-I5ptcw)YWiM`iedG)CV6G=hey z*5;<_u!2Ih-h(fO^lLbK+~i$>*ku&82Q-W-!r;dm^K)*2iQ#s;l9hZzojF;tH9=CK zLmc|?OHd1L+_byH%-rMQ$hFjBz`1`jx;Ev&pTjlyXWFE50G)aU(A}mp$zDxz(PoQA|&Z_ zh!W`geR%2Nr+QuziRI#EYPJXTPBHQYg@S9Ji)&AgK|%dyBoS?P)Xt*~V>ek{91=F) zxQP;&xR2~bMl+`}U<9p6VMSAOv}*SGh037)4^`W8Ff3Cr3ale4**7n=vjUT_6d~b` zW5}xFvW1YFkz(}9qedZ%gN_E~fh}R5>N2idxxWDTxi7G1+ z>KwKnz-`UpiugNpMVnakB}IiOz37tRG^z-^%t#UrcXnX`2bkLtF>z${VWrOis1n61 zcE;KyrI)0olM=hr1-)JRcVQOy1U0Lkf$LJtcpnzVseJ@q)ru>yu%`)BtDbK)+?mKH zh<;5p(4aKT%rwmM;efFtzuda#p1Ey*iqiu|d38{Db@YkCcm&Q0Uf*cFks4t( zR~)TJm2&{GMy_RSF0HV2hM8(iNleum@cLWWgnysHnE}cHK26wg)tP~~M=P@pQ*%Qc-a324jig1P!#op4tXWi8SG75)2b+%I9<^GQuON;5xS)6e3?5VF#C|&;dQ^@f z7boqfm)I`>QBT!5{j{Q}q7q4~9z8=^ytGNR)l*cG1_5YQ~%06~I? zwqfVr+!>H$vRviz`-pO@j42})fdaSnI}GzBpi$}IZ+px$6(GZqx({&W)_Wa*#dgN;62n!y0255I8e6>rWl3QQ_UO_knuRz5D9z$$FQB_d|D_|Qw-MVl2Z~9HT2?q-%2}>XSK_l& zM}`7@CD|D=zOc37H|lcr3fd58>LiFsg9eKQFPx_J}E`P~BT1JAFdafeKl79kDJ zK*`!=;s7FyOLQh{?yu{g{hB_Orm-hgnJ!1{PQsxv1XT@*8xSC*im=A-<==6S~3)N zK1&_;YK-?bUP;0;q?^u<2-)a!xCWws2Aq5Q(13RKo+mK-eTs=OrNguWWXke7qI0DY zSsSKSYJU-|yLOMO-m|K>O>@?H$O9}`=d&m0@`C^Q(KrveQf_w!_eG~-rV~U$W5MX5 z6q#DJxMfFG6vZDc%3YSe2OOr`T#r|9O!-baPn3$WeD=389v zd*Vzfx^cqN@;KmF>Rb>-DMa)AZs!NEL-)4upZMax>(poB_#c;6J?eV@_yW$aPtIU# zl9T^%Bk}9jztFsE+wimAZ5U)NOctM|l}ur@p{bR*X;aRxSe)DOphF8M($K$wL=iZa0!3qKJtuXxk_rMS!S?3D)(w&H&5Kck>%( zj48r#ElTRPYg$zj^X6&|L+tzC!LD_{)c>tzxI@Ju(2nbtw|T>|7LcKIThFmZW>Oq( zSN>6Jf#*CM9Wq+JATEuS&1Qjgaet?aPY(J8T`WNY+T`0sL=}^mJicwwtixRmk?>bV z7gA%3DM3SdLZ7-3g65=_^P+Xd2lixK<*hE{Yzmn+vfTgMBUz$NPOZp?&8}hor6 z#a4=_KRgk&eCB&DL1ls`5tIJ4wBcl))-HrXfK?gVE^G;0=T8sWorA}k;@SAweT>D^ zsT!%9kIe^sD;|7XVb@NktGCEimn+M6ldURDFREnzs*MOv!)E%qi_`9(ejW7_1Ci*+ zA>q)?j86`QnhLd}a+*l;g^JoI&A0lgNDAPqB!^;(_FLJknlT|I4R1SOR}~M;Sa6{rrQ5GP+t`@*gJKH0<1xsv2EM7vt!$~cWm3XZQHhO+fH`u$$a0%%vtMPoIlWO z^-aIs)m2aZ-Gqhk8S&j-6h+BLPG`ntBRtOA>?ZX2(+H7U?M{e>z*rgB8vaG$TmQ5Z z_4+9SVG3MsCu;I!jx&(l2XKEYD$4?A3KHA5CxYX{;m5}rQ8Me!z#HxHaBl_Xz(OWh zF;0CQ|IhDXwpBAg=jwdRFSpfmkH$f@go18@Kdy|!-V9({1NFR7#eNyC$<1;Z>n34X zqm8(o^WaHCZ@g{35~!>0#skPE5T3dZ@33E%8cxyt332J_ZU~(#j^lNNfll7p7)Q2) ziNz@bx&dbk8_i>Ajf!Z_cY)UB2BND*AHfds)L-Ek2W z(g!;DcgTN9siB>qPf!!P6wRw}}0MOB7y9b%tX!pvR$}!v~l<(`h__pSt>;%ZE71 zwju!vld$r*$g7J|nB9alow5vHgX_RV)hYw!RRFed_gcw)EHg{`v;h5h=?cppN?I^@ znN>?G`)i@&d-RQy3XPmxY1}AcZjI!v(`a8{VEsp6VsN|`lqgOfkL?1>()9Y=bD^nu z-?#v?emuW=I?M^#&GLzoK44`)GXJWIiEN>d`3ZoI{Q`~93laDhFJ}n8YyT*LqP#>G zh(v}#Ke#@1fiReuIz^%MG_;Hz`lldlC_U?VpH8@hqRw3+=8rXBx@k2-=mAA`!QbXO z38=A!V!gF4#yg4>fEQK$tJQ)#3oDBQ0DxXq%H8DWTh^ex zwj~4}FT*eB1Kl60w6-U)Fj?5}Iv!sAG z1|jm_@k%FN4EftIcpx&pmv@p$#(W?DO=_4n>fTbJ5yxFPmULy^4jUkaTr|C{HT3m} z%ML9+t#(LmdVUo`8@=|R9k2zgScnV*r+F;0CJMS@ea6&)ngnSD)mf&PnldcW426k6 z|2N}ORvCP_hbfa)qzcA1qi#b4Nb@u^J+w)xQ64_mfU=E2cWp$dBB1%X#?hZT)+R2; z#J5<33s27$j_xv7*SrpDF)JScOyL7@(j`qr?)EYaMJ5&+%M4wt7^ezqfA!7%CHW-g z502Cc+}qp>w9}8^019>zQzS!{CuAPWH+C#4i-mFkadcW>sEmFFg|)Z0H;3VgT zqx?9H4-LxjgK|n|w*>OV^F67S8f?7WHax>1e^kX4BRv)^3jtBt6j4*#5PB!wo0Wh* z$XJ3(-oT1BgbzNJXaYVZL>Z32ZaUd(iVu{}T(eZ@4}wE>1@vgR_{bYk-xKdER`R z8NNd+(BywTgbeAGQ>2c`p%DMvEN~pr9KI+TFvMNVJ&Fvd`sr;eJxi&z9ejKJ)u#H7 zwdX@W)_}pJ==NHgY0T<;8B#yS`R(8BNE~?CbFjD#y*broN!il_JA%eHm5IdZcmT$S zL0R-Cz=WZCIFL@zN5hY=A6hb9;LyKZY%&GFxzrx11g@4wl>#w!4L01m5;*h_oc9hN zuai@}{VC8%!~Mi+I;8fahC3+Qp+yQVJN68jIVDd)v# zH?9j+v)VkMIAcXy2c44e=pAe#U6^cco+kb($Pr2E4F@Gr>u~HMwJHhG>2#F9eIaoM z-5{gQocWwK^9Tm8VK{N@|YShUrCc|M*&p-znh!X*%A#SnCIE(;d(&NnN_#?e=}R`I2)r z{%xcaX@ezsjvnzv{_aKtn2g$B6JmK%?ESpv3jnG6Z`K>O|Bd#}!TcYR%rEUd@$eV$ zaH>}41*y^;0NKO&r)`DKcKHOs?9l!V;n**pAiQ39f`qlPvG>mx5M&HTqwL>`5H}Vq ze!iZYkN`d)T;aRYKq9z^E=3bmtJ!||m;P4#1AeiJh>ATQ{4=Jx@QQ{#pO@OZ(ZY6^ z7Om<;63D~OWiFY;U*5ZGolx)l%hzrI%L>$rh;X(A*2l9@Fin9Zac^^6mC_m$S;tFX zt@xl`i;gE3FNU$6@xXH}@5_#B=;bJ5`Ow|Bc`(U?_<_1fF-|r9 zONU9aspP3(tM#ne;?*9E1)>eNCD^9p=w2xd_Qz24$F)RR38~4ela(iR(uq}ifeSjt z*Wz)!q{-?e)nYzojPEEZG&qei7IZlfZW8EL+s)|pY7^LSNdwMN0>$)2qT@M^W+exF zZhc}fe5JE?h#QAa(CW@_Jf!KfI#WeED3&_U!dH)T0!Orgg+*su*Avg2zOM|z+AO5Q z+Cz7nZQz;$nyd-H#UT-S9l8 zBj{#jQiK!9QW|ygC11Vz*t9*JCw^u#rr^^$POh5IaXerK+0Df@4pdL^O0TJtAJ6 znzxw;p&_w)PE%m?)oyb!ch>A7{j$8Ga6nRZa7gscW_Rt!K_K<9@J(7Q&~LJY%c&A; zp%_%k6Qc%)b^9zX=NQYCwclH-?$=yi;9?Yp49r3;L&-(&vA?q}eD+pm0*aU6L1Zj4 zf=`?dARPc+8-Vv<0?krFOa5Rss24Z_^}}V{F6a=NqbZ4p?La_kFqPXQKf8=a^ustb z{kffZ=|$d_d+Epb2l|1{320CRjY|rjh}gqXuCFNhrhFxR9pVg_ZI@JzXHY2TR7lG@ zGHSF%mxaL`J)^klK?uJ9%imgu4MBPHFaSI?akwS34CgP)n~pG)3J+;QFmGpU-uZn?W`7qo={PJJ1_F)V8hIU$~*rE-mgvYmHU72aaw{zHWDxEdPHN4cdpObKCxV|RV^&c?~_ zAE)^H9-ikeJVQ<9_jy$r98*qu4FQxUAJqR!1U#`26c6dFck)jtAc4u+w4v0#WD)$i zkF|Truw|50N0vX1TVmK&W_jzN2xK9%@k@d+Xpx8 zkjgOAg{_|vrtU}b$1q3qk&13s2Ul2)c7xlV*QtY_Z$YEkq6oVfu@7^N0nm_z!&YbuEv{83l?OlTl_icdD5x?dR)xlb zAl>pI*I6=%TpuF>z_w*Bu$(F^)EKXvM9Vn{b%$VjT@(Nd$O6*!fRNe%aS9W~PgNa8 zY`QIBz#)q<&s=tTXdPU4Y#C`ir(C95*n)Ey1@LAz_0Yj8_$!>pHdbUi=dU5{QsnM%(bRz$IR5fwJ{%h(&LxE11Qd#5Y|H{X zHg$T~No7eHeQ;4ZyNoz`b1?adgYrz86#ub#^Q^%35v(eLqqEo*84Q@y42#PbG6gpNuJ=0Bz(Z--(NK2ufp7Z6@kya0g> ziu5l0-`3nc$TL5z^fr~L zhfzUqhw8DhwiDK)6*?%hO!cc3ELdWls2-iDpL;hS{Rd3W%;)>%52w910&8?f9 zSG~Wyzyhx2)F09Pbbnan=Pf5KV>Q8RilaR%d+{^FM-#z%F%^g5KDIE$$6y>Pxe&TC z0^i7|tUT{qi7%7?&xvlUcDtUbEdD=&SfitrRc13gOkUO`^^Cr*>#{jM-rCI?QEJhk z&3hug+DU@S@45hiiSLP|bmM)*6mR?TPgrcZvA0O55WC+rVRK7Lqenl1`0cm{mxq*S z+lDs%uKo$Udhhzxt0ru;FlrP`wY23tVRihK;V%P_eINzjJ+FB^>&hq1%>@OCKw4Hh zc+Z*Iz7k3!d5`)?eGEQ;698fiXt!SR2R!iQ6XYaP=u}A%%KAmJC6L9?>^PNRoKw^1 zNDv=i%Hd21iD7A46@&l6+T-mwgk{vCS+uTgOiO!GPfpb>ISuOmG#>WbDb3i(zr&?9 zUDrB{FfOgeNQpeWEwyjR8j={CIC`4pJoO)B&vv~8$&J2?zU>HEwY;Vvtahlhgg#G>9``O&CXkbMvH>M;1d;K%syg*++_s37=lvDY6 zZO_(!P?1=-PaES zzTg8E@*kvowuX8mPkCox7W3Hyl z87LCWaZTS2_&;CAz5Fh&O#e-a{GT}XjO;A`Aw@3#Vq$+S?Y_HugjXg^@{LGO0_FUS zRs9jpz#XvA&;BLwO~Y$eR^y3BZEv@(qr{|CignHKz!3mw&OAG(w=tz4zTox<{dzbM zcwt?}BA8aO{gsz{ZCau7{c0aQEy0FdNy&X^Upr2a>JvMBY8>DM>VY>QBiW?qx!D_>b-Z5v(0c zXF|Y^lG1HS!F6YSIQoI=lciG6khMv*d6$kRh8t2IATB4ygFv4pzz;?wpOZ!sw&pOdLsJdKR|JF+F| z`sI!=o{~iSIt$P3C8c>_Dd37mp3l4%UPz!p&&nQV1A&_nH-xv9$;I%f6n*CeQ$oDK zQpD)UkL3Gvz+FX2(uDaS$lO~f2i?bges0z{N3n0^U~Gq;+swmhD569(h1V088wgx* zb(@(!twl}OSLwlSE@k0*vJCGVIDZu_D7psqK?BlR??xNcVZHGj+I(JQ8u%3+LwgID zbGQy52%0_|OvvNjCO-z9TLvVry0l1=sPp`5%U&^bJ5nuDi{@0^>`LrOFP;jheYx5T zvIt~gkcVgcN?DifO<*k=rc(ZRhFL4@)vcA9=;86;{Ngz0)At$UiID1Kg34mnWLSr0 zMc{7+TMN8z{d<4In`zsRDYA={wa_3OY@>qQp+ZiXvoZ=_^zGZxKxSze`7uep`#Z3! zLnt)&BOv`1G@v?}yG9xnYFBQR{AqW*iHpJZOBposfHEyYNaWxogUGIobqPGO!qB|> zcRBsS7^8~7gFE3+)=|;mnn|+Yx{>~Y4OnX7U1Q4?lXwowS0eHvl;F#Tu>(+C4DH(C z=JVz;neLP(3AtMualOB}(|nb)9@e*w@6~C~n+Hl*pQ-a^W^<|5mbgDbKnQTh1$LkW zR)7E|YYm_TBR~KLB)}A9gdNlXjFbRw*iZl~$^d=Qb)*TvCZ?>jhPHF58jqx1kBOUz z!)pL?y&6Qt49M^|afa&Z!*xtI2aTYOgG4kxp*n2BU6@jcs;$C9($rmlvE#8FOF?h#eeHNHxh{);LhFN>= z?fqx?owLCw!Z+CIu)LQgtF7>DEiYt9W~nep^c@@JJN6Sh4M+x&x`WmA%t%43-A%z! zQ2^4+O_2%7iRHKe`C3@g06t(_@xZPuTl;lPb0OqKpEU4f7k6xbYryC)#F$P}O;KRK z_uj*d7^4tK48)E1k=}$Kju|{*#$HRb#1(J6<(>1aa|kF(reF(&!US&oP`wz}Cx%(3 z>4_Ziiyq@S$9zsSBkUt(iv_Y8NT#>T6BPJ4k=^ng?+`sUb^8NDU0a%Y zi|a^&QP4Pm@Z@5TeCP~Q+O@Z~Xmn(x+rC&ed_W6*ZZnD~wX=Los^v}x>lpu{?{9l_ zMYTJ3X+_x4VaR;}{5;FEm&(%nL-?yTu)Lw`LGP-~5Ut|KR>DZ;?e->%H6J-oB@8wA zbP`YrjeWoxQ~pSVxTQm-6H!T}g^|O(ASkS7VDrHG=7c>jjzEKnM;Tb<0qj{j)as63 zZ`WAQq$P1k?jtRI&C70OrHyB7mXMttgCfVQRRpTCC<$2Fz29&Q3_*!rdDl4^?58EBJ zsICCzwD{dA+EV~QKU8R|D_Y8}btmWec7h2Im-L%&+6iO>8X(7(nTh47tq$-##r)kc z+!SG)$jR!Y>-CLSP$g_e9VT49xp>Xk0QDk$p&0DG0{njc;BI8;DQFG~1S0ccysi~C zJ^BUH{lMK*z=&1Qg>p7M$+S8qyxdR_>t=<># z13?bde;JGH{}Vl(k)4_I|L*`={&fKT-=r5ryD%7)s8?7*%NS{_^`g)`fvD%%bKdXi zgP`F+!KY<+v7g)+c?BerANYy^hyP%If(@1ngg10|Pk<^=;h1vV{};VW6O5it zq|Yd2)V*#Cga^9K*d2*x)i=1db-0H)RD`4$W_XxLQ8L&!FCyA&;=Y55g7@;3i%55gRW9cSX8gK5bDb>p6%F0sDZ zeTKvJxibxhXrGZK$ynpWIMZ8=?P)o{X*VS~^JQaWLdJb-a{~*eHOI*|BM`Yhb2Oke zNd#dv;P`EbiPqn4gv!cPPa%N`SJ+RM{oBxTB9j*G%+!TUks9MZ$=>?dm)hl|IB|(s zqFkeD8UW5IU6&Hx^ll2T}lRdEgy%;X8L36K2n*w6ad>cFmen zVl!zABF4n~h>TjxM@1j<$Hp#uT3J=7`^*+VTEZy>LsA*QFQZWb*P6AF*@(G9nFwxk zx&M`MwBt(qMMa$n_(R+X6OEO2EXJ0NrDhdAw9YXwVtL|y3zBT~9-}B#^QFgoV6rhU{*;pB0=FQ8$$nuSLsVa>F z+~?&3a*hoi#}?`RsOi)g$>N{Z8@<%OyDatGj0 zL=jOCcuBD@>sS6H1sECwoG`x&M(r1je&pG~K=VTC`)Th1SHc~p6f4%bJMvOm{3uRCT}PmGAZEuEuKk$b>H8s30QY{8r|LD+pl?ku`DM(!m{ z-`fRlgFi)~Dl&PQ_RPmOn_X`lFh2V`bz}(=6wr77H$?o$MqZq z>3!m1qk=iv%{qttkHkx@Q!NB!z#mHwv9(oP+|^6DNGS18X!0t5e4oj1-NW>C7J&n> zj<4mJ3X;>9h1(DEu-&)k{@}WS?b!N$l5AU*PUs z#cw}VJfz3uVGI_>`abHMGtsqnqw<444iMz%$R4b^)&aBUeigb#dMgtrf?H{c7PZrQ z{w?8>*Pc<)WDpqDDYe?O!k=_ZqC|D2x_on?7Do@3^Eh$Lb454{rZ`|tFmp(_)X{jd zXKfl9KWY*On_lRO_9fPy*v4ei6Js9B6U{Hul{sqixFU|@y>b3DDppuC%dOgzHdpHz z*LU+M-0RF*&Vg*PJm2EU5_r{CZN&zBbL1Z7>hj@l7?HG$yxRdP5TdKJ~D{=UH7ZC-WgpxM?2AD=3{PrI^>vc5M6dZ{^yHBgGJ>v5z&k1P# z!%KD?zuD(0uwJm=SE8@IJc&TOT18dBHRbEC*8E&b5=N{dqH@;+f4~&h{QLi6@lwkm zh5!BaxXQ0qPqjxA@V&xk)wHs&#N5n!Jz!RGpq~gd9c1Uj$!C>7RMk4|h*J6lLEgY} zHC2A1(tElqwAq`MvYLz6K*J(rq^miwu)p*$qb}D~=U1}Hs>KXhe_5Xs^F)vY{%7;) zd8$7CQjczN$#uvc#cD5_u{Zt&x~-(TRjFGEK9i^vl&SydqL(VU7k63U?7349uAf?* za_rcut!PNrw9^slpS?GMdDPwSBzLsBUs(t|lSIK@B(6B_>IAEuGE4^HBvc*@!$1z=!O3W~k)Z!Hw!s62=S+}Y|Iqv5TOaQmM ztLt#wcU$z7w8s)SOpo!3ilwSvhnG#L+X$mKV9%3nV&b9&2{(Tvk>Zo$*~qvyUG{_q zjTpVFui8YNeOtih?}+2Cr&jOI*UJpCA^)Bida~Xnek6#Y)(!9`HKe3_j(j&tpClb9 z@zAC0I$cUEB}&S&U8G28kx|GAZyITq^PM0l5r=8h+B;`$Hayfv#Gk#3uN!G3_m_|Z zoSdRz2Rk8|zi(1paj=J?42ezT+uBdxKZ~>Bm60q;4O}#V^ex5vRrsdedKmG(sBN;c zlY{>a(Uk&u$pqS)c`=Jz!_vkoByRk=egA?sY|j$tpT`tMQN%)KQhHPq1qbJqlhM;i z(qS8P;bxj0S$vHL7-cW6+&QiUYVVb=_wRw|#j2hni*_J^2Fj=P>)b1yX29o6uFDWP zczEqoOcll8lh!Q1jdP4FJkZ5VOJ{8_dOO9c_4O)7NR4^jPT2tN7jUS{F`=S@l#Fj# zHxe@3qO3KvFW$Hx)@E}JK%`|_2y0os^Q+hCMzoP;jHb~Y3;S}V!)eF~j0?erLj-61 z{ipwWenCxtayL0PyPy9i47bU+C&B}^nrPJAWx%RZ44ZWtN&`jcXB4MnfMlp^a+r<@ zhn`81gZ~OOW2N42q;D3A zt8m4EQn=^VdlaPp%iT&p>rSPSiE*1$ zYS|%~HGSF_+jIgF6&l$sIn)ca{X$;l1~!beFnGgbj+m8Bm~ZvogeOsbT?6(ffiD#k6|7CdZBch%lZU1R%@f*Yd%|N) zF}3BADoSvBPFbk`Vzs552yX4$7UI>lwMI~e18Pp8ESTH zg6I?Xmoi!@Glm~=dc1}MX|TiywI60`2=vc>=Z6}cCPoD7JXX*Mq&;1swqP@Pz~yXo zFlNXrqQCsUK_@EZRvAtag0BdaMgD>?2-yVKbk%Tz_Hi$BQcC*Ryd9~PJhRtmvSxD+BP9=x4n~k1VXwOr&xW4l#`2y-u`T}` zRD*&@m-FF?xVJ*8p~uT(VrECTiD#*+DI%9`kIb$gpPRMbJX`Q|dV_gmH+zg>>pA~0 zjUwB!4`kpvE0EVPc#g8_dhQ^=1GfB6wb z4Tm7uyn@RFp>1(@%)=t#kLHvCD^0m8&(j>;goprCbpfc?gM`H=D?r2=bBy$V#pRTk zdRk2H%_f%Ri&UA3PYyx?oulu>*gw~g_jU8#To;LhNxn#%=qihf;oOQ!tMbLxeB9Vj z{3RC`(_hDgMd`1_jm%I6dPUpK7z zyS@CjvE14Kx@6{OB>0D23+e8_84(iuWA#?y6U&U0MaT1q{@$5gWsyl`ak$Hw9Y3i0 z7~0t)8m1Mq4gx`JpB5z$m5x2Xq*10e0 zoG@IS@;d>K(63WehTLODF3iDD=GrP(lz$$zs)%zaHcFEXgy}Y1E$tAz)ym0S|MLWI zx5cWhg*H=DlXQdVM6X`tlb~@lm%CD;J1Jz7r%U2%#defC$;X+DZdN_Z3lKu57TBzY zYk(D5bYAXhE?$G+wK~0dGM__jVjst(yW*}9kL+Q?ZaO;iZ2+~x%LSCf^CF-1iW0jI zojq+iBU1(X5?Hc|V5nF6Yh2oP7$^mxUDddAVNJsHNKTDo;C`ck2LiTd%?RzYGjhdLC7!QzfT&k|5MTbFum3V@Qz=VA$Z>G7 zgXWV!hx#AqcP=w+_2bV<5xFD#nRAZ^o<;j#c~Q+48e^KDv8T1zr>%LWI!rasIql^2 zTPwltkrWU2wr>jMe1=%%0=39R76}R@1?&KPM`t*L@I!{0F%@Lq)PZ2y;J37C4*6xK zywnH_2Bhjc7IzyWU%&p~%m7q^pjc$!^5loPgiSO{3sZ248gTBC{{1)4czK++1DfPr zv)pQi^IGCBE#d_#)%NR~pC(Z@A-XMs`0{Zg=wwA|U+M8D-2Tm!_BpEAw8gZ!?{756 z4&~rxDOI!d-uM8ey0@kKaOYQpVEwFV6>h~r1{i^7VfP`VP*C+TGogA+eM2TOCgPjQ zdy+2=qdy5+g}~Nob8LJXbrh{>$(`YcAjLf_>X@~2pZ+H_JfOIvqExuFz5?%>^h29g z9*3SEs|mS3cX~IID;fXo&icRcwV62ogRlLIQ;a?QKR87Q&v2M3&H{1Cqa%hfOTTHt zetqmQ!tB6}6l)XXO0|Si#vh+bb&>FvR#|!GCsmy|fI^Mf-gSld2tq*O)goidrU0H{%bWo1a&c8lp`((2HW}c6w zO;b+J4#p|Ty72)zC7N3hJ!7TK#D5+CY4mLu^))$O%0>{gj=Y@i?qPIY76NWgt<*DvG6Fm33Da1I| zJ{a1K-Rr&c4Hb$&sYqqfaEw_;9-@bzO1rBPX&pM=Y2W29+o3ntl9VotjeOpVh+5Cb z#rd~S>SqdsywATRb#ew1Km1d72Wf4(t{xCA}fPMdOs z4o-QOoysErvTXxAv)*_Stehh%hCFB8tzZ#bV~l+N8?`g>i2~wnD%Mm@ju$ZS1SS`P zxM^;LqJ9}>cX`67$Ylw*pnJ0Z(ox`OG~D($!2#X)aS9(>(DCN6ND}$4C>U6(!BN+l zzy8c64Sw{AmqZdGjz=9F5jyC*>0)plrl#a~jC6!6`Xq1EX!R2-6B2eTD_xVozT`sD z{`0_;Q4krlXxI?%rb=(l@H(GJ5_@-O-g=EWor@{LAOZWI3=c1=v91Dk0zrxeju5&l zt)zIU2egM-wO3q|IrY#>L2BKDVba4pfYN5S1mt(R>gLCbm^q>wppuWySsX4(fbC-! zT*#`rVR!eOw*Ur_{O{_lypxIspu@yAI%o^s%&l~hF)C-{_1bn&*xV_FMYe?JA3DGa z4CPWUGJPmMISC%xi3E(>wQ0U$(BQJMQJm84LpLKCLA3(pIm81<(Wv;jOs^zSY{_C& zT+qp6G052>_CVCAwzaXb#D}^?m?L;wc95b+bo>Fnyq6TkafJT(z!@O}hqXEkRfdyC za2AD9s-+e}va;}XA#^}~=8FCN(95PuLZ^+e6gE2%S}9yXWro_1*f4kKT{0048v-8M zL2B*O`6*rKy4IJjF7g!+CIxMPmu+l;&Lj|PNFkHB%8BQ+>1?1VI)AKVw`B(%l+}V=|+F9*^lX|xR1O|)#y@;L3 zw?3JA30Zy9#*NShblMZC6O#|XvmIN5SVSRgMATJqKS+th3N`XI-Q8YGUX@`8izVPJ zb+ipyJS-qFIFg^~)FExPN8CN&!TYD>wmdEar{p-YDNx@|0vb#{{KF~ zx`o01ijt5@ZV*vqv&F!IyC#B^4M<4E%9sp**nUiU1l%aDQCS)Sfbi}E&uu%PnF2y2e zblJijep!D-MTc)s5wVtA2e!i%-+8%nm79Kp$!2p#fkqhbw%J=fpQ?u&R%nx>#Xt}C zv4uG|UOdsypcXzy&@RmYusnW~te`mA%2$^>h*!=Zx!gV#FN3B6{cPD5?I zOqQ`P4>rk~oiD{0&*pg_UbKo6hU0 z85R{8Jv%#s);|`C!8<{KWV*6ax&pA^+w*W|tEg>^oM8!Yf&&5&ep8pUf5f7~0m^=t zhYUU}jg8c4l3*DTOu}@JaY8Tkpj-}tLeH*mJBh|M0blz@Usod+_PCRFfHzInS%EJP zz@T!yd9@Plz81U0#7mMq++1UrMw^sQxvBH(08b?B?uzpPunqGvckR^VW&#SC0J7W| z1XQby3cUgo_Iqvy)EEm%?uYU8AO;j*u%F+EnKd0MX~ivwbMQNJF}}?Lm|bFfcLDUF zOdqbbn!BZ~ zYO8S5X@3ABLO*{hzoZmOiJ+{yBt=%PVfbZ;WzV}in6O-dE<-_x!X%lKG>_6;4VUW+ zwvTi&dONFiGBH~h@~ggoUu^-!!{VTKH)}1hYpQN**alsRlGXs#?I`b4`ktJyBB2}tm zv6?b#nVAyz+?Bb2DG1xTRZQ~Ql8|Z8 z-;&DsfNGXxlJi|M1`c7cVvym);`372#!Vg|IN-$dpmDI+N4J{qrsFwiv@a1wvH%lq zd0uAXnTfx|YBPkP1S;i2gq=iToDwDR?*c+~NGb!P3@gBy^GoPDzgd<7vZ7EE_?L+t zR2ZG|T-8flRSOp>1_3!pXMkR))0m>K*Ye3MHNJfRt%_M)2H(l}Hm9W8gcot!Kjfw_ zk)vSa0d|nJRUPXL&QBWBBx^!`<|5kuhwSGd_qA|<9@!nA8bAZOtmX9%R+kES*$VXo z?2L58q{acE`);8t@YUMbWt*7>?Ygc{K51wW&d8P?8~lx#Y047+;XqvM6Gr*uoB@@*}ncZxiyl5!~BQEid!m11lMgs0^iA_vl z1FOuEjm$B%EV2o`##GqHG|X*e-F+=jR;m<9PI8|SMQDwR#roR1>g>bJBv`^AqP}Mm zL8rv5Z_WLMrIeYYsDF^mFT3+EQN2LEX-rh#O=rHg5~GSUpTD}7xx@x{Db`R~KV(;f zhkkhXOv6APUe(o>{>=}hL+3qfW>1RTan~ zN)htj5a$SZ2B#z@W1^J^4WUMn54XvS-4?Vyo-P~fhwSqk3zJeX`Ya9Fopi& z{-1EfOsq`*;obay<&CZXgQ-DyHiXq@M3U&nIodN`jRX;o>jQqRYXp~-Vy@1%DJL#x ze*S*1Mt@3E-5fDx3@uR~CeoO#<@mp(npBW>xPMj3BA8b({V%Qk?6*#FLlsezd(VX8 z5d@4C(t(>7x%=>*u2`4fWK1JL@6$5I)v$al%SOC#>^~h}lyzJRb#!DmET!!ffah$m zM9`V$1)m2oPp-nBCps-_Q^r&?#!q^|Ido^`0fS6$>aFZt@Uz&8k2FM*&RE}ec7u1@ zC0)YBdi7^x&y|3*n?gout>WZiziXn1+mtPpDwI&xDLE`6NSvdX0scJPVDKXJp zRXgIh!2ILHJKL<|>jaLMI}<9T?A-R<-pyl6E_uDZ7H4iWSZ@^SH6o((Go>7Xy;VDjBW?dhv&)AG-#(5b=6VMPsd*6;6?fS2pUSCxx;j`Yt{=oo;D;_bw9mXnMrCX?|i?XY24^ z*GSnEbN9|ty_|>*JDcy`NT%qtiiWfyQ8wmX0j#}5e$;NwUocl+Ka4F7m3&ECNC@7{ zqW##b@x8rts;h#{BVlcPh$8Ebw{NEUigp zM2TinmGi9>5TS0KiKlS^cL$}Wr*NTi(g6guZjW8HS_Th9a!HFFAx#s-RtaD}(T!ci z3W~i9daIc#k{JnAGBlc4JX*CeF}pi03`y#9kw-PwOq*yF##)wa*3ibbT8J$Mu}BR9 zNWxUIDL3#)JKHE{+pE#IZ_N*&wQD>ICrn*EKM7CJb=`7ajqBDH1HEr?0Sw{fT7!4$ zoi2O(ZLWp*GE3zF>r7cvvQe7GpMaf0ExKD}7NH%uSia^UOptEoIjDgc$S%j?L0Y6p6@XtdCAbiV0>zXnnLrHXPBXO72POgJy5 z&NQDnHRas42eFSpKygDSg*vx?>&!4BF%FXu*oa!?+vy8h<%aHFHuqityx3uL0!e7g zA_Hhjo$zo1Nu(H-zJ>_h@IObsHldn~v9fd96rZnrmkw*EN8cH&+@OYZFLWMmPP8~| z=on@$kf2UR_4ks0@ z0Q7mb5bll1fLlOyCML%YzKF`O&o!_vOtBQo8I!W@*r(GVYm~4YI+P);-9N3p4;eV` z#Q&kc##EA=r14y4Q=fDE>pS1BGXb1S-R0}|9it2m3xF7gGx9a!Fg7Ts#rLq+Zc$0O z3jCn+N>SW;9PSB8)fm7se31l=;?d#%5AN%sKyCFhi4)Lcl`rR5^>7>Zc25dt1y}j3 z0pCT=iLNWGtsM{)TKCFr<^D({vvPbI?^40u!%a&Cb|ctBOP!$kj@8$IdYgU0SdHiO zb@5Q10ODcZ9k!p$(FhI&5L+q8>TxQJ848{U5K1~^a2+_=NT=@hKzi}t%g}8hYIt%W z&k0yQLWBRh&g#KU?5Qq<4Hp`jf^oj8J>^sJJInvW*gH0f0waZhisd! z&BYk9azW*>>B+85LG@@~>tin_s1buX-^lTaXl9Tb)HNxM_QA@p*J)mLo@FgtvZRxB`ZzstQI^oVO4(ldAGG21f-dWqkrOeWHiaVolH@ zwox~{Teb#mcmitSi}z1SaVKTDHUoedGZgZ9f^pYy7hmt*v>)He3+!IPA>Ite)C>&l z4DH2GA2S*C-jep`QXu0)F~na ziniT%>OQ3D@L;7WTjSE85J$U2-baAEsTZ*4cyG)wr82t<1$l+8Q3+4;4UNR>nR0rH zzSNjb7+iOs%DyOmkZj$|z9KSEivBs5SY~qYx*!K*f_I(sQ=H?wZ-9A;E(oe4H~ZdqaOnOEIB0Q?@Tj|`S*14oDF=FDekQ4;wSKojJF~w zI`88xJc=AGzWA)M$J22Ck;M=(3`|Hpm;x5qIs>+x;^$v0et#?tC(r(O-$SL zXiQh!{gRjL{9z<^fJfj%(LHxo(&L6cPVBJT@!i|7gJe&F23fk|Df<1_nA4 zA;mod2T0;J$QV%O@c*vBc)*%zHV4)e#S%)H{&xjdB))zzZamK)Icr#dQHhrQopWF1 z$CqOfZ()*NzkZYOeHZ8bnK%|>T}Mf zMPc$YCwn?F?em#9OcQ+E<|`H1N|J@Y72{ebkow-6`Ijj2>%%F#q^Gc6Z}Yo8{fF1E zc48N1^fFjgrjRVVLDg8RCOskMVvr(BmqaSac!4P*DJXrmldKd(X@YL&IaO-=nr$;- z(uD?%oO(lMH@f>Z- zan_(*gW^lEWt|duG?#nXMgv(|96sE*tD`*#{=IkyJlVHoX3><&DaINiU2oJ>uDZO` z7Aj%ko$PDXS2&-g>3XrG;=#lG^HLo6o9UnTF+XRc2g`zua#4Zn9auL@)!zU{@XfuT zUx|k{CH!kHcb13oeZfV{wUn@Xy8e7Giz)wl4lcD-SFlTb*doneC*nSV7_+FoS{UMs zFqbL;G^%1j>gAKA1EoRW@!5{pvPa=KilJAm*e!t#M5!6rfka7V;=)(gNEWjMm|h}R zl%sw-kp}SgcNt$nEp;K!HRPr0Qo`|9y7t<1c;=|rLcV-$Iz&gozh0~r$(XB7q zRt+R5t|4kt|L@nxmg1>`J!xQjHz-F_(67ZbGYS%E_c))dv#YQ!lx#tKaGLwDZamWH z%zFP8JAr}bZY}*_vOt&HGN);lK}}yUQ@&Cg{&fC&>)~Vj$RnRGs1~y$PGLipiE5FW zbw33#vGty4er6x_=-eD17a_*-=(R&M4X~|0@g8JKa-_rb5 zy-Xy=2b9d5;D=wvb$2iRDp_$zr`&43V;*B4Gz@F%DFrxi$02i{O1wkyczMVEdho%@ zN}_pepVDD?D;OrR#Q;B{%-OVL&*3ap*O3S`booHB31b<8lN#{T>*Y*;iiGqWFDd(g zgtS9xU+U@i;#zK|-3#~kLeA`xW!7n_9f!{4BSxX9K{i;PIzVK|$-=Bc!Md*)`Fw~( z&dvj;N1(TtHk8jXc8;3hZe>f`W#?!>>Zp|+ylvpKpU|E8Qe{g&RG>h@nU_!|&&66s zDk_PY$@A|=RMM=cZbg8^b1*z00hx3!X6rvMSjw#cgGsw&1lj(jl6Ox*870z~pjPQ1 zLl%vQ8ozAo9@@XtktfNg@1G55bH#sG&A{G(Wau0(*ZndeN)+=Q0bZ7~;D0?|+Ji2! z&$w*U9U-D9_&(Qb^x7M#B~6cVA?t*{7YbJJIC+)IHsjR*MaU9!rWZAZ4}c=L&Zd57T4OzHOt$-F2W4xrbSiXS?7R%w^oodxjM`rBGv)W%w$ zS4rZNqb$9qMonRc0f2+gq-wtI=Bq#N2|js@;NKckr_`mdKtV|1_emN9*4OyVey4Yo zIN}vs5-cPllZwSLqK{5*=4yvkv0#D^cx(GC8Ni_1_9@}?0wC2mra#Ap(wrniP$|#s z1NnhYVfZ!eWxI@5d_eu!_@H#+-}Z!P#IcHIrtSLOLPG9t2$ygJwG z)nU;e1zQQ{TDQcotfv(~(V9FXa+Eq9%X?_F6#|ro{D-xmg$_lwTs;jDP@`5$#dj&V zw?SP%M4Bs>*Fy!%NDONh#U`dv#C=seYl=PLW;wb3-%t8K~?*hsvFSs*uM;Ad+ z>3F~Zr~0T*KDukr528_bdBb3-uZ9%QI&-<{YP&>>Z55($cRzn9LuewXS7iB{0Fz5Y zQcL~p`1QJWifZnsZhWnUTn$7g^2rS%ycLZ`m+meOmB*z25vfFRaNQ`f#xXu1_X+LU zPHwq7227mWSf&-Bh=ey*+817awJu>K+aQI9^pRa8V2i7tAZ|r5QBNKNW=7w15ct=4AdWMXym-RFQz9qS7F4 z(;+TJE*8}@53U-4r6;SR8SEfg%G^9Ns83zmL|5u`hvuOmYmvP&r8&#e$Xc5up9bV( z0z+a1qhgWWRq4N~Z~CkOV>P?7+E-r|fkMYjK4oB4T{iIH3hUcOPEip>RnanFS&?t& z(H*i7v7YwfJs$&E@@zE>!Hzb)G|)cOAlVb+XopZNLq%z?r6Ayw)CK0)KVNDcY|MV( zvdxD@RT3Ed-N>=D`Y22{#MeZ75NlOb-y@l?cnv!7-@DGn>GksQmYiZel(NX z3BK~aj>dKB@ibl97qEGTsE8fIPh*z%fwKtlC~qBXClU#8l-e!=b(1@e>e8HRvj5c@ z7!w;~!#5X*Hl|j58_|0Y*Ytzqy#NM@kn5@KW*5^ub-r^$0Ta+2dIL`c+THc+X#Wd6 z0Kq^CShqVb+rxP4wWrZ>cT|*|W&Lc20T-%RS$-Iw6YgTjR89_l4|pw}k3Tffyr+){ z%*@&4xQT6E@@&MVeH}2KLt3&!SF_0wMFSc_l%v8>7_i|b@rB`_DJM*4;zpL>;(@f& z@WK`==YRdC9c*-nyi*B%to-(u<$blv$2`_X4DOQD6uRjm*ny`UDGS|rJN^!NCU3}q zx3_%MPW4ty$f4dVH}cM+d*wyQn|tA8;TK%sO3;7dncqYlzG?;jYJp2bG%M=n+Sf#h zr;0$BP%w}CZFyUZe;dBZ>~NAC*71Y=x?gz-cLf&;s_%SbF~To%yt^Ov_>=vO5l`B^ zKLMCCW;UQBR1`Twv8F;P623wiIdvibL77S1o?fT#{IK>l#3z+#e}G<{=lG+urKIZN z-|v@Z(O&Ky8QOADydFq!89r4xmt>q_P|yrC!qrk|KHjJZW^4x{?1UR-KY1sm28?T@$g0cUCyJOckVizy7QQ?plL2&5nnl@f>`3Q~Ly-H@G%jop{J$Jd!=;T{Kf?k*{W+JYsSIPAty=HRHdmI?7E`@my zvF_(l{rwRE?n4H|4ffPnZ&Q*n2bHCR?T;VghZN(D%^SP6qxtBB1E+n9GLd$i+BYnttaL~!~X`MRMCelp|~@GF39eGg{dw`|Sl=~QSB_6h0d z#~-FoWQ@IaMFERjJG5bwzTp@0odF|!66h$N#~N_iJV!m%!@kpb_S-k4H>d<_&=yz> z8JUmt4R7U$lEf1onj3}{mIYj`KriJqom5lc3NgXV2{z&UYz;S+=Z+#;Tom0HBR1=@ zW8b_i_b05|^&^T~cJv`21AO&4Lx~OnhDfJdZWHz&_rLNBg14!jXQd*FZxr&x06cI% znIyQ&T#R4=lv7GcKFS=}Az*HI0k;TUY*!L>rd1fYMifVbHT*8>)pUx}U>diSfGBUk zzLjvoT^wGXSBa%u3#r4=)EaS&@27#3*3KS8P>cUsdqPfdL7U`=eubRRNg-g;LfZVK`%#q3WIamN{`UlwqI;u7ANPWc z;34M`$aW`6%C!l_`lj!W+$Hlp6#$W`9IEs?3!4DlZkAhsB1>&@L|sR2JmRlWKajoA zVx!N$?Mey798Y`GKfWp9hX@nzbv?(D(81(Io#W4T`5v;WZlTyU01ZB*8gU>dypxQ- z=+8eaGD~!)2F$K6f|!rSyi||(c5SO1sjKFJ`ZemZWpPPa^#-H^jMTdDWHHzFm8J|gtpe~Q-R*6`UU?ic zJnBz>3KLX%P(F_Wj`m@Kf7{(RIy4~GOMaMYQ0YAyx#6?}8=S=J!m3kmDRfK7=#85v z3(uqH;J_Ce7|Df^`7;Nj5aR z1p>lDQt2X3Q9pHm!R&tKb$CYSYk%zTUb|=*>P6%NO)PwX|H62Db~JW3KF2Ow6v$lq zaEs=m$6*uRUxy%aCqr#{LjV5#OxAe6(SK|NT7KU3!Uf3HoWV0sfUNlrTqWzG(AjzB zk(bYtoP^hJ1Yeu{GQtt93C-zkx#QH~J>MJZVT^Yep_eT~c6Tx7Dl>rBf0ML}Y^fg< z;0rRdo)c(t9YR_c`yczgXk_HO;{`Q%t1QcxE?K6$ANkCdqzVBFqP{e^5W|GeGowN=Il zr|a>psoYmkKh+{>hn3QgZlpI|KQZ@( zAF&=OYoMPn{2`ER^t9`v{8&B#+_E3Q1I9sJVJeSL;DeeW<}=7 z!Kf^4)~o1oCUc3&v~&#&cA0-0!`%@VLtKvu3kLDG^_GURI_c!tj%HzzdrE&3F)$Ih zo2|5&oi2fX(N{W)jCZEA8r1-{9BX!v`&%-tly|B%7;+~rJ-Fh_mq^DV3>&Xea@5+A zIHLs!pFmToH3v-y)0cueY_|tG$Jp4|g9}0`f?t>w=N(6bOSiYwWOAs&r8Feq%{g)@ z!u>1egfj;l1o1qrw1_B{-r+t~WeBkBt@^OO$Q+ehXr@>LW6Pt4Zj%{C+Oeb@HfGGp z1$efrV0A`P5oZK9X``mu%0DHzJr)lj+KRxgXh1A(Hi(4-^ZQ+vW0t)1vXX_vasg~Q zPOKlM{#rSM;VG82#BZmZ7$OFmBl(yj?OhWvtd0A-g251OP7KPg?||4t-xwwnz^wk2 z%62RZ+n%1W6zOyLiEwzV)*BGtLibpRu76UI|KKr2{(K3jfE}CBKZ9?uCc;YGv`A)heCxW%3?pI8yJ}aq zZM)pH`x9E2Xw$mekYN-p`u6Jzx4j<;1->r_--QBqr;@tK_|)e&h7Q_gA9mZ~n9eY#H zks&P6PKqiDDla|0oJRcACQurCzuUQnFuZ`}K|TQZj)>aafPEG|^y^n7j)-90H5z+@ zJ~YJNKaRFpRr0{Vy`MG1+jukG)M*MdR|*ni1_aB4lnGnwYE2-RFhqDuUnGVT{aIN1 z-KQ6?Pjg0++IVKWEZNLsSK8=LE#=q#SqVJ|clIDMCilrr`jCMjf?Q*6@7X&s>YsnNGo-;{PAup`$0kDf#3gGQzj+HzZm6+65h|Z$5n^tRH8xW3 z|8PSGwbAoF&y~BMi2N2zE^GY?vI$cy@~XG5>GA&wr6Wm&<<-dFKEQeVl>5fE^eK1PVztr+*=;37MOXYkzi-niQ9YI@f)`z?Vc!vP&4xXo5ZKzq%Zg*SR#1 z9K%t3hjLbryWgXHC3+OBFT>^jb+>Cbc$L8^9$Qe^dPD;SwqV zz2m?gIC@Dp0*WmTI<|hx>l5>9+G_!r-;~3>60pFysnXk+fk+~b5_=jG^iacCm+L2c z-%OacCn8nvug~u&-i=wbX?6Xnbe?ELW-~iHITYKaiFcm6uU_E$T|mGhhH%7PjIWq_ z-}nJxs?r9j=2umBZZnu*%H;L32Ty#IeE(@|@6VeY^85Q@S9lJVqz;xO4NUV@eWAPW zcYU>GTU__HmQ}cbub2en%yALCms~`7(4m{4f-%8zTof7F20l&&cwq_5SWY6Gf0AYr zQNw+2&pW8Ki18}^MaePCTVKyus}=jC4F&)~DQOf(yxkB?o;BneEe-bXRDASF^tzO9 z*xs!7$rw#C2gQSk5V={J#Ixc_C)cJ_pqu?^H)qT%XRA1UoefF5)~8@N!QfnF`S5EQ zH<*dHccooj8CpSwo;i}uO&H!G-lA!O2tn^7^t^)|47c|uY+JU3v<}@;mq2W$_#W1wr>q- zTaE~;mp#;`J<1CTbHSHGt+wT8n)`*L4G+~kbU~WkL?tM^AWWME9rh2kaM;wei(Ks) z-w2WkzJG+&s(11qSyX>;g`2<6ddO^iI<~)FN`C>Jed3S*Q*`|AFy2i6lOoale;0Xg zEtba9C=v=u4imr{`U&{_aj=N^iT?(9n-d%V+Q`<m$xL!xH#=@a|k*(2A{3zMqP z(0_V0gW2c1Q%L~m%&((rk#~?Yo;~D_?>bKt5OS7 zE~s-=L@FqYcuTf!F4gYEFqzf%u_~qarJGD0mX*N?NsO~?JqYPPaCH-|hX}K|q@7^N zWO;hmSyBr{R`*&XWD#r$7L-Y?8EOU~Ftqi|SjK$crf>eU9-!)xplKD9K6 z(l+J({P^tj)RNdxRCP&eMi2=P3^VX{cw*V+Gz4@I8F973R|&@hsvbW<^&d@ zRJ=uQdhmeYFH3OUvJBF-8>ha4jMG5Ib|Wq3v}V%!vuH%Z?(y$D4^woeu9ChyD8X}K zW=w;&ST7caub&UA)y~;N#3C5b`<3y>@>0zZAvP>LW(E9_vUOJFck$O{q%!gRXcvu_ z72Oqlz)pH&B7312CrvMV+o@4>aw3KBF=eYx#YAw23Q;RtionL}qTWN7id9rRR`Z@C zSp#mgeTPnoP-%5$+<3xl*xxt9hnhRNnB>qqdDoTp zXu2P?RSU2`tBfF))>}_07+vm``xI{Ms@{jcEdC|(RLOO*fP7v|FBLWD3hopnfAjPg zr_UHkf9k1kh*0NJV1X9(xNCouvQ)-BFp%6kU{EXbBuij!r>425P(v z9ODs!X**>+ee$SBV9zlI?JRJSLYa5&psatdobU%2r7ZdxE5Vl{u>*1ojuYEa{v3Ay zoJneCX;a?8?@L`~_~)f?ryz%uH7+~D;7K;HFh%2vd6kjlvK}m1<6-n8djg&rxGp51 z#;MIM@?MRlDqpNviRluUt7^Utg|xHc_Fl0qp>}U4?in%LBK}gIMgAE_Mj0334VeD* zX=#;@4W+{$^hUiDwsTS9;EvU^7osvRCcVy;KCjyOpyq{N=_ z+kr$zD*thh8yKOx=`g~|iL&X#FVUZ65`)vH(F|5GeG<_`Td@HeF+?lYXEuQBfCy5*Pw(1V&|mCF#iWMk3B+S*A)S9M2wW%E=& zc{Tt9&FC9Y1FdY;P2aAxOX`tB7ZYDDot<7#TofHk)w{B2GaIFkyuG_{t0B2saBQGr zR=2@mx2ga}s?y9eG)BhWV2SKZ3{rbBY1pRHnhzx*2n!%e=b5r6v%RDs*&gbXT1@a# z6WM3HULxg+q2n1cwp01=!3j7*<%WNj*Gae&Xn3V^)$F|~>p+UX@UnXskaZ?J=XUP$ z5sQ>rT$cKCYR5~!>aj95N+YDO+N<#9>Bc(TU{*m;V3Mh}#SS5-SAbx0M$&#{Gp~eH+)kL>F#p|6@+C>hZq$+|Yr0>kxQ9VNn-wckIo2wp7R2E> zD%p{(hid>uzC5e5&;;5yjF1BFmIyR;S^II&eUX}(m+Xj~92d~{e6-pw=rQX1X(3@l z(IzYe5kfR3;|+-<;Od1M8Q9Ol;pol;f=tTRq86oNjTP#QI@7m_U4TczD|sN;0Y_Q{ ziSY8d4;ans-P!LQ!p6d*3M{RHu~NenbB`wpC!0tAgrz{_!lv#mFY(`V>(V~kuZ|da4-i*hX#1|^)pL-`!qlLSg zaCL9`iDv0}@z-v*Z9e4q((WevT}<)V#Xy@^IH+gQJQtg3K*9Mb(Q3;gV`PZcGRoX^ z+gzcP=qGIbwJw_e0hu?W`&STdpMnupK!2YjvT43<6r2a=f27FF)2wu_!&4l3N)-yGLJnSrfV0>t(P_g(f9%nS(3Pnj zGhGZ{2TDZQZF#O^2MVo}tx|sRQB1V)cL#^sD|lQ?`$L6!L^8_TDzIOGYDjlKy+zA{ z*O)&Tg)7mPx00Xe#4rV$X>SCEx%K}6a^Zml9m zD+Z87ED$(Ch_=kme7L~I#ir2!YSKNk5yQ@T7YXtp!$U?Fo>pb&jC!+?DmwL~=CY^X zNlLL?gdFN$ajb*EwkCpYsd;Y^xw1lDYyO=~DKa6kuWOmW$}@x=$(=+5jh*5aK9%7kWwyv=#oxz*;5sJve(Lj^bdad+6(D7b^zr;Q><`fCpQ= z!UUu9@<|W%T^U%c;@% zSrqvSa{2zTe@xZ;LYvLeQ~OUj?7zZ3GqThFkLf_Prc~nQ{~;rkd4-ou93bL@CnP3j zS0SC&C09$Uz@}rf6B5r$#cL*P)c<;afc6MS>u8zy^B2y?*5dVDoxDbG1l{Fs5PKx9 zQHwWD|8%{-HNBrF?v&Aw4Ol-qt(7?y7T`y+$qoCqs`7o^p66zgD+vI3+Fzue7@&#F zzm#85iBN05EGN_R2Y1(e{ZXmF{a33BmJ$pTSX^C9ci=*(7qCLRiCpxscxPPe2Q zX}Q`}$FVdVjaP0tuJN52droY6?Rs96=+cYTr}aOwYjmn*`TBsbC=iobes)VvpG z(jS@yBmID7sf{1Wwl+t_(f~GOP{U34qh%9>d(U!b|9RGLixB)au!2iG}<{jRZfv2o{?K_>v$s`D)U?A3N+aHKxq&mj(tPNePQxH1LI44p*EW-$1`rzBnA(*Sux0ar)9|`@5S$7vv~MIIqM~_D(0k#M5M5n9vW&ZvOIzR4tpJC4%=ou6QiD2*L!@ui)u$D2O6o);@H%Ds> z6ET4W^JmL$#h=-@I!wh~SCWZhhYpiBe*2tzJ=}ube||ix7T51k!$I z_5J`}*RAI*)k2f)9$8kq^L{I_bJ?uy_T0nF-aU*!_j8f%-TnFnw-W!MdVt7`tE@EE zM%U$UF?I&Ayx_O&jl6Szpo#$D8S@o+_(u$}2Z2PBw{YI#Fzawv!@@+6f6NJ?y?t^h zpg`QyiRLE%=%UlZQ=DbRx8FN*+@^!e@$AnMC#LDgTXB*C|hi|D(FU{|~`vYBOaytR`L7j*aDkbL}Sb1vq@(dgqywYUoZN!ii$xsKU&K=pxmy~~?P zP@j8z?1l_hf|~*V1l$R7K&TjWYQWb1-#dD+LWg1-i6*BU*7(ySzj`_YH+7Vt^QnTK z)dF0Td8U42_VdIN8^9Xzjs_#xf$>CoEf`mr)SahLq}Xh+&f>McBiF7LtMSnhe;Lwz z*#)UGBe3Co+IUXqe4ne zVNeE4ZQ;}HG@O5WUL{&siD458d~vWp*Re^nmiRw=H#R0 zeMpuF=*zFAkaI^b|MDIN1J`bGLhI0$>pi_Cc&6A(1Kyrc?wXNzWHHr29vSZL(S~{D zADsaZ(#(v5+Q9{E>Uc;)ydxZ_tCz1f!LpZ-(0)Pew7^Q(`d|Y>8eV5VZhf0-opy~O zD*;xwO;RD$t$Ht|Tn9CSsh7q#$1}vat4Go-s@pwF9&f)Rl`8B9-Q?TX8^*T_6KV8F z>(WE~7n{LFTjBf1#gkVVfas$W6lzQ`%!*hE=e*?;Xe0~xOM`-qFV9D+UvGjO4nioW z3FQ!#@6OBH_Gv%g?oHKQ1tMS#d@Nl>JiVB?bRF8kT+#)1Tlf!$d&QU2FF|1m_}PS` zQF{yjd}i^6Pjp3sW5hRv6XujtL-cvid_@Om{D*f|Iu37b2e0Lt_dtS@qQ7$pOmQE? zVnDKv*sO#KoVscBFO!4UytJA#J$uKZzir}9V_e6NOo z`*LE`E~r$3mS_b6NCI=_=hNLVxacu>$ViJycQV_|SZh?Q;ILjLb_`8oQD+H$@5BeNS8`$_%R!lCLI!t10p{ zp9s|wd|y`i(yo&_C-6qT);ru7Fu?pgkjNu_G`@W-7)A>TaIB9nMH`G|G{w6983_y@ zYG~izEhvuqiqL!8xtSDUZXknNpBJ1{97Ru#!s|BQ9aSqf#wcNDdiT^M^kseY{UaGd zPcpzTNM;*UJ^@|Q(`jF!Bvif;LfHpWy9h!R;I#{(oLwSNlt#|TD}UQDv6g=;bm?~| z_jDBy;0QNxsHlv@eh{S{kf&D)JRh~f2jLr^iqu8%xhjoay~~L_c5!{T)=}XU%Ay?X zuhLk9>kf(S*XnD%x1L3YAwoY^EaNbTx8zB7z+9-#tZos^&k!wQ7l0H#G`#!J(c4G7 z1xTKaUe3m^jBC|ah5Th-O||MQZ8wT;5%g=z&wf6=z;>fQms##+kxZU=!ZBew-Pr#+ zk#h=05`rrZj4tT72m(Rv`@Q%JcnulZ_WzI0jP(B%8lI7z;s4Wq|KI5BpiyBtL?Yl9 zdvAlomA+)!>QY@njB?5^6*t5pVku!c`ty2@CN5v#B{?m?UkJ$B(d%QN+FN^|0^)m5 zsZ>c#Gti}eJyVI-QhB>use&CWqFmJys*+WEKukSl+4(DX_oA%(XS143A_3&Wy?b60 z?6>MgjO*$0_wR4d0wt`0p7551VAJg`)@@gGoi($UBEs(D{ueJPR!dor*R zl|jdg%WTrZZV3<>XSL1*;M3yW#N{}v^p5K>X3wW4ix}}xzkV+?@ny*HBdsFqTQ)cB z#=daHjEbE(m*>?66VOmF=SgS3POe?Z%c_D`Wal?h+#$6&*GUcRlg%<@S$M`Z46X+2m(^^lLA7FoegOD2fSX(wD?PbA8q!Bg%?tMs(`AO5 z9u+Q$6I#e0={cAIl2%rYumlg;ZN!KWlIaY2u4SOjJ0*8hYZA&Rq~D&~RSnEHY}XRy za_pd(3djz8ILs{}qM$m;vk`V2l0b~Tj$@IwbgdgV`bSOU?R-T!6SbSZ@%d7x0p8%P zLb-k88>P0@cVvu|3!_WZ%(jeR=3vu!8sk*!2lEd{4+172GFiDW|-&>fhqLk8wR6?I=i&> zYM7y7%q!uIAWyR%#@!ex$8==`)bl~3jV1WrHlVT0@x z@`yv$@B{J3LiQPw2-~4`3C>$g?Cs=v>}{o}n+dxgg^{Vk&KO5gLTYL8pl%{WCc%Py z^8R{2vLnp8P+M4FKwMa|z5OeKy99E$M_YV43WpXa++a@7JApE&NBbWDPfo>riFB$+ zoEO}5)l2!&-GEHhAiMyq+?TEOjs_`zKL2>GDxtFXsB*Y6W@#u^4aqG$K3dRnddCfp zuCEC*n*`+sLEcJHzX<|>KjSBK?D7Jq*8)4rUvf+U zIE``~xat&NMM^QdaZ|7EyyITVdsp^3v8Cw0__KiveQ@~Db_HNa7x8!Wi$WZI(f}NQ z!?iu$re%Is$Vw$_8pzgi$y zDa8-t*->l(=1rPqj|0uZ$nNJfq8^iyqfc=x!1&>;AIi)%0VA=Kr!nB|OFOcFS1x*o zg_lIrK#bH)MGq=3#qDbl-XhW&zLh)r4Lk_vVsV8I#ZpQ<{E}NDn*u&ZSNz!wM^7~K zSCIh>HtBB^Baw+${}tAERqtQ@OS4QR~aqxUe>#q zmsS5wxP5xP#u8@ZPcL`5Q9p-$U*pc=U{_IY__h54O74Kp`em36wfEDQ4Yc{Xi zXFK$d`JJpo(6TW#?Lb1N{lzIB9FU3+{$!2PP5_}{{??abE*(e7WQxV7zNg&erAiUR zl$ZKRKgT_pS=j0}Z3kE2qY?LT@b`_P_w*#Mecp4DQmZ0i-6jQHBJ0s+u&>`;*6qcr zZ*;_Ja+Wc*?GJt7?$PGzv6!qb%F&c?vBS2{gk;wTcEB2z%B?Vk)889mg#GFMQ{19v z!GpkeLCb%q@t4R^zNu{#?*$wJ3lvO!?@S%c3>o+{68jSh#}PqXiic%x>?=Z=Gecoc0 zSz+a7W4vpB*S&jiR5EK?$15JpKOY#q^qH%^l?xzgB)0XGY1k@@e#VaZ z0GjM2a$5%sGCG|yfMz2{8Z^|Ca%fR}vyaGDn%kgs$eH@j-Kqqs+1+Rn7Raw2xPr2% zpK4wRcS34GG@NuN4V*tXCwuFXbzg#K)sSm466EI)HSp?YpTdf>)H1|0Odd?O(t%@W z_G3v6Z{%3pJ^;%^b0Zwcvc`c00O|6(;$~yQ zste;DQxxuZO(pRe0if+IJ8A?{83`hdGawhL7f5xp@}Yp%p(QsUPw%f_c{18R*r?ro z073<=M%hLCSb{HH|Y5xOm)Q zU~=&F?heCcs4HKOXQ%i3d#UGVn9k5n%?<4x9t48Z%A#Zb0s-61FL~$ecfiV>`kr)2 zC8;H32LxY5mVFUu#ajn>&&H7_O5-bT~Dq@`@I$Wnaa)4b(Y%w8>(d_-MPEjM+Utx!Hu9D8Zv|TiZ z*C>U%!UpdHI+)+oGu__~1JlN=GD4zv!@&X@66#ebDI%36G%L z0L1h{0DtT#{a3PBf}^|5Bg(X2EWsoQlN|!IamCexiHbvzqkkfruvqrcj*Bo}5bRz> z(76P&cGYD0iE3lBS4U?qDdI$p@S~yN2J6)T?N?IGC zcp9L|Zt+A-e|(TS)yB;PR|k3_8t7fqKW1f<7z}zhYkb}pe*r+z$+G@akpAzC5-k7o z4?0;x%JK03;A`ZM5i2H4!FdHv>sTbBt-8TVT|~7SRqSD#K%~~<#c9Mf{%w;x=V9Oz z$hj!+Kv;FR^?LW$e@zWj`f}4$&Z{Ud)mIvi|GrEbzASokB1veIJzL*1A~}#Yw9%SI zF5fDo&;F`^Ii@TV*67nE;C8;-q?pVL!fBb9*;;(ChB7I2nyz2F$aHr2Cp)9`ga2s= z3yEF`37HIJsK_ogVa6wjZLzb~6qz)g)7e}s&z){$t|Oq2l%6Sa&yf z>2gg+yivoT7ryk*JzTi2m9ZijKlNAOuYkj)OL0$pR!8w}p>FjuzfnqU?6qwCs55M* z6xq*!uGZ2`gP`blj|Ss?F%vU?i3g_TkIs3iuBAVFA%8th{^%liDF3vfmw5CHK+=|<%XSV*5T)*t!l7;FU)CD;G z&Ct*&Kkwp!p`)|7yi=waH26MVpo+>Oz2EPPC%ZiJOn3lvP=PrAKZH%^O`5LPhj3)- zo}i`3XO6vbmpK5^qbV>0NFN~T0><_FB5ly&RPN`cj5Ch)Oi=bKHfvSB`5sor2cbIP zt8;GZ$Y7a$&M$kycXn2A!fiqO&DO13ch!hf76j@1co+h5y}8?|ac!uG8is3DtNP;t zOI&KAKa7nwnXWaSMDwI0?w9$!4ep)1$a7;f1bm`8Q^qeg6|e3OJHeIxmq(SRp#GKX zU+Fj!pP_I|G^ylV)s^KpU|2Y>Y>9R1NdgVtLv@PR1@V9=3DwQ_SNT=_$lPf}_E*r~ zY-UqbFg(Iz;K=YM&6fx>MxV?b*ayeziK(QCsUY=(sj5)18W9kNW{H78f&k2_aPM3Q z1et1V&7?2d1M%&b7e_QgF=17yXc#Rju)$|#oE$oE1s93|3tCH|BRkMFK#|-(G=m2_ zYy`R_?Tom_76eGco51?~!_~`JRsqFm*FzR~=q)?HpiIW>b0W^yJb95LCccC=@z2wwc7{1~j@Y;mi8sgfiS%WkCv>;fq%OhM=YaLyUbm`%=e zS463bWk3XsMZ>Yl#Vfna_ff?a`BC*{Tce4PKXkqV&Q2H5&8q;p(pmhKfxs%JY>M1iNc8LidSY5%(>BHv z9gzhDc@y|5yPzhw8k@SAW=RhcfbamUp9iq6^Ig5Jm;?$mSp)8QFlH1UqTO=(sr_%0 zGlD0FRZdmtYv}ul_J)fcdCWPUHnII)2AY@8`^if)q4yp#-~JN67*II9Cg?G004d@b{SYqlgx8W^?-^0W{~-0v&SW%t-` z3mmS;R}2<@`&OmRxSNk5tGVF>$pj>YN86UoJ1g?GAB}#hf0AV)bT;(?on~1KmFuvh z!DVN)OAhNsvzegVV!Jl&vd#BqUp`XF{dqXmQvY}4wSOXKBK=&Q{1HSqPl`2GhSxWcV!FN%! zrk{yYTyoDm_zqHDo~8w+IMp%Q@zVov8$L_ix}Tnq1|(ER({l{s#QO>)R}@J)?abF+ zhLgbY4JRN*Lr45=eH<4?^Sze&($t!Q97aji0ZpB({fK_MtGyK&$Tq)7erDLjUd7i_#VjBFyHJhKDtK&VFb@<-!H-1)h~#CW;!XX^e_!n*SyVeB38^3J z&m^n=^Uc44B6|0qfQA_#*BmnJ1|7_k^zP`ZCjy=n#4)Pl+YH3MNqfShZg*sL#gCzO z2q679HGkTrb{Synf~~$loB7DSo^DVJz!z~BK#LTHVutk5g2|)5JN@b40S|E2+7jrS z?bLKuwuDLHpTxD1Qon|diz5aw{Ln%_F;PQ>1L4a4tR0exgScgNhRuVH{P~;I`)Nmfcl8E+$GKJ0f%SS& zaGxgS$4n)vY3Ddc(q;PTInfUUo09SJyKs-YbGPb2KdX@Vm7~QU!2F&5py*~UJyxQZ z1lMOKzNBiBF17))r@aqFWdDm&g5BsJ`et&S2tcFx%XHY=l!P%dcPtW z+&(8p`u>l=myt>0Y5IPe(!26Twm_FoQ;j5b#$W0gp?E&`$WX%pR^B*xY;y$LiBp$zE>ne+}us z8_F0S2dd%M{}`?Pl;IhY1@gQG;OIT1Myz!^Pt#jF5eO?b02l6uh@^>XR>eN|sM~t1 zw1YBiIlrr#sBQkr5-eC2+G8B~NxN4z(r;K0?kJ<)U^^?5wD=-o;B`oc&HLGE;~VJA%fm9;PyCg(f0T|D5Z;8)f+5X?{sf;oarWHlX+nF z0$=M0bkQzu^Crlsm^oZjcJ#^TXc5e@?4`5jj0O=!8kv2YsHYo~gZpYv|Gc#Q0)PG{ zApfU0_+McS%#0lW>q){0)>iD*KVVGnfKL?6P^?%&N6t%=z~WCfU$bnN0KVtn{Fajz ztgTIn%_efcy$;1fYfrZ%Gzv8JKix24LmhEy{I$NO&#-5VwIajH(}xgzfCY3Oi-W+FJakM!X^+}do0u!F@qe668IXp=zz zWIzmElk$os|7fF;aF^JNmjCwHCuWIj@%lkYpeK6{6aJ)-HXZ{w8X8mH65EH|=aCdv zpN}1Up(JQ(_u$U%!!X($P_9f*7QWUjnfx}&TO}Zp2Zpqg9MmL(^>e0K)m4?IuR>kw zM#+SC6vE5ZZ-NZj8+C4=nig5Rx&hUF7}@#R*d1yz7ES2(!w*UVB;?88>xmX~=BMhu zKKb65#tR3pK+m7A+bbe+vUoJW_aKOG9qb) zhr+1Qsc=H=Hhb-THf~j1IjyT7C58E$DS}vyb=(hAAc~%xaFkg}P zrHr44W#9CSuU=3S9va>lk(-AK301z?Nt)VTvO=P$@%qz0j*~w+6G-+e7YUS0jCSlt4ay)p|HO4ox4b2O^j_~vaO40qoUFi;L{AZ0d9{ythC;W{5uVYgS^Bo zh*=(gh9*RKDZ0Tyjvg+rkJ&RiC}58AZk^$@%g05G0(g(act1AW)Lwkbc&c$7!V|Rz zG!*U^+z#Z_z}`)X8#zD7o8nf%VxNxC!-VG>;wDDezkBU75a3s0Vy|18h7+KbiCqnU7Wz@bY zZ|1EIXmtOL9BkS~%o9f5=yFi%^-@V8XTe`eSX=oL6zb0Q0gNE)vn0-C3z`mv;Sh0c zJF_&s4g!LivWun-*+?aqax%VwYW0=W+-sBd9!f)#Hjw!&38;V(DCXIL_MSVJBV2db z$GVDWzg8DncY7fUd3Z11bZ&fMy!w>~vd4xu-sB-R7xrYhG$6ZQhIT7!>1Z4ft>zz~ zvCe>(lFn{S)4aA_wkbSQDbfgTg#_=53E}u0a>r!DF#WvWcP~n?nmmNu5q0BE4&k{qsu`VtMMwZJ_zaO~^ft03uC-ChS7_xl}Pxvk$;7p(l zbkinVEXz;RqMcVH)tBHNA@u@0rcSDgiY?X8dbCcX0zmYN8SADSWlw(2klTT~=ol2o zCX3b42}hrFid!^StCdUEkF3dvk=YHeKa=I`M!pawemu-H%J|3N-XWC=%^;QCs$>qJ zu{H-*dcqf~xu)5$VDk8CW}SU;FA^?g&J)93e`~b}oWvG5aKBmiWaYwN6%<7xStX%1 zX}MdLhOLpj{TvXvr<7n05PME^9+swtk|#ly&=OKDo`*mFU{pR99NW?t!yO$N$&CCL zfS-pDQ5#$+ky1{(udt^u%0RgXHXY(Oj&1=0(VOEC7+!WD!ECqSk zA<)x7!Y#Em&6P+GD-^1jf<(VXIvuYlQ0Rf9Ezi8PahOkLFyF?ta^ zuB4YpS+$U}{8Q1AV{}UFVkcoye3C(kQHt)R{Mprn%!vF0b9ZNe?uhgXpW!O3T@1!Q`#~f!Y3a54u zERgeii)&(^gM(ExT}>l2Tf0wYjujraYYP?)iy(Y=)CQap5VE+Xt#?h!iE|huoHFqa zp4k?2n{}yyTr>#mNYZ9!rt~(wB_j6e7a+-{5TEe_%wbt3Qt}Rw-^7C70VY26yh-g* zFpbp7Gd2h#g)zbf!dDA)P*HTtvvC22(G;8k9vTD`?imU28|4(cdFB+-6xkHCOd1$S z#>KwBFMc@-1)a#PPC~Y`Fgt4e@cnUO@#IUjn4`}JLUXLO$1Ecx%UruLlf(0nzb8y- zXW3CKIl*lLPPj7FQo9;;0f75{c|s@oM|lS)`<(dC4p1ztQeiy!Kc;pHy_{H5p!@Et zkznI!kf!kD8lt)B$U9{3MrOj#By|Bj67AIH!LM<`q@Wqr?uWe)MXk%qwp&tegrp2H zDO-+=lcpg`a@Of%0YWefj$%*&ql_c-Fb`CMMb!M>+<{o2^H>kUB-}6O?NFQTK?`kD zI8B!GM!&*1*5Gy?c9Aqv$}PNypfpu5#0cS0laQ%}x=&^u`A~2cUiuMc-9T{x0oWo9 zED?;PBL34@kk7zoCzv%_tYOuocGqyf(z~(DF}JI+P#rb$!PO$=n^RoEbkLL9(o7fO z5^z zO7N#qsvI!1y;J7%;ckPYxA?I2F8`tge?|w=&O>8E&Ik>$)l&rknvX0d@+|QmTXQo< zG10aZcN5Ae0vw9<(9zeUOh1*AJsbEZ^(5{P^DhC6Yn9a^%v`Kmw$B=w^A} z05rdQ6RU819Z!}gQBx?YR!sZ;ZtYx#<*i7a7Eb;fTZW`ksVhWH)ZAwL8VlP$?soXq zIui#6+SFev`ZTO+nz~#!JuE}ih>tC8^5sR@zK3QukJ++X@t{Rr^Q4=gPki(1eBV2? zqcznFR4@u|uzp2Bi%yoE3864!#BOcQ#u(vL-Nq2lFZ}YZaM8>77|WAG>`xq(Gq6-3 zH9(6#vyKJ_)g5H|_+{89P3Wx|?qOT z?kSplt;<^P>L*RJd@;VlVd<{ALUH_GEY8wc`nQr4Qz#;fW;S4~U+3XJMaEhYI^g!M zH)o?}TJey4u&K4T*UoD2y(bO+NVJ?&vyOxu9m!n{Mr_miNF=T9qhEqbnXK-V6J@=z zD}2e&JppGe>m)s@KLdZ4q!Cba^t51aMUkVsc~x`nyXADh?u< zY=>;Axk{Z$P*^wB36q$gJ82zp<=JQO)!waNhf~>ma>&ObogoxM?;Y^P$#BKsvkQM_ zJW*LY9qucR+AHCl3e+SZ&Rc%y#TfDa&UTXzfKM$c)N0v}Wj}upI?~!|h_DA*b zY%@Ju{B?*Tie#}p8$@hlIZPk4AdJ@VHI)e6}a;9&1(>#cX-m{xd5yUGEaXA?^K8Ph;ZN5%laeFXekN}N%5>U9^?l^RFgO0;h;7gWEBBE*P}r= z2jwv*@ffE<>>7d@bRt>UWqf(WTI?qz{mXub2Xm0-KI^S+dy)emhz6rf???K*$xlsU zxV8ZD`+9&!Bms26Wby4n>9nQqwI+-c4X@qjg44nsPY0YanMPN=1hOC~C>}~A>L+;D z_6=P$#DKL3b}xVdqAO)5%K;C+j~ijfJ(hDG5h&#(=ygPz&nlffA zbR`W&opOk+bQPh`BFR_+a>Z&c3jG52v&Iua8W5T$$CZK6KGdwInNt*`0j~RWYT@$K zOR#f!wp^L84rEPVsaJq?5iA*#N#j;nGInUS+PvBJFmyS3-*^ZGaG z@_aU*ea9(yu`-7aIfI8JFf_YrF)5wvytf2AogHr*)Ju6lCU2Z04 z@+lpz3}|-O%O``)Zd!R7;{_cNOHSpEJFU4-s7;lqzU2XSMa3SqVNa;#!WycM_J*Kkt$Uz{dpi& zZLA+b3IT1sh8I+f|6xv(~M@WKL0#j=*53OwcK%O}md~A<@1{rZB1u&u!6QUXB~1?qaqKAs%^1 z4JhCl9gfoX;%px04@fPo(#An{i-$(Ci%uQ1!0`e)EFDRX4In!r+7H%vGTNIf?kafq z$R&f5$iM~bgc!9v)W)WxYL7cb9ASK){FAMJ6=8wkv*V)Po#*m{AJPNxoUunwH|F$7 zRxEw6&3Z!7b?@WOIh_PA8_h?-a^pkS0^V#ZBs|2Ns_qH>sx#$C#$r2^~xQqhG zDf(z1R)McgV3D8Hcdjt_%UL1nt%FLgFc8;t~v=jJU6Un#wvKxjGYGTlm+j--{sr z-X$5TbUtHx!_o4B#dCF!6RN)ArdB?m{t6bHQo(dfFq;UteS4G!JmWn1BzfA9G;A?} zK;bOJoj&d%))nWDgqU)^?#|$EdWaxD-;TnrA?_IX8QZ^)0MADOgJ6mx&I48Er!jr? zZ^xms`H)=I!n9y##ARdp+1;~262BHn=zcQ~3Gs1R4%j_Wu=rG_~Tk z+EIP)>KOk1fyc5Ejp$^cAF)jUUA#ft*#Uff4KS!B^6v%6E(ygCWehc>ddGEphi`K2D+1GOOl9;3 zi2XGjMf#t8ylmeK!nlas*ORQ4AU?rvQd`7=8`8;(YaKL&9d8HbT@_&FZvFO&CZ6lb zj=}_*;-3$Fz@9ONSI_Q861mvdDzO2)-&r_LT z_V{svluvy4n` zw^Z)A);OJko2tbqO+BTGKCDe|tSkxiw5+k3Dx@|z!O&}*BhX=NIGlBJO+0S)F_I~L zSec^uJCX)<#$iJ7nszRq(Y*5-GQ$``7nN*}q zp`j%d5JtyZKM=LH^fnR_fQrI_63?`e^gbg)+Fo04wyl+zW%-PsAIdi-^{_KgGc=#2 zfxPtY?Z}{2B$JOBfg7iZ>!Qi)Q!o)gDzDp7P@`p_1;wtikdk9S(D93(G`g;?94;~5 zQlG$3UL0`dc=Tx#UHDw}&+(&b2%b-SdHQ^-vJ68Q$z!mLoISJ^&u9ayXGu1zZW@g+ zOiGH0G20M9=C{w@P`?YDunbuh|AJwh!uV2h zM3;^(5rjUh5@AQMdcMMhC_wsOn)4s{NePH1L?9N8@hC2g-dLd3(~8fpg?Z|^d;haK{wj&E#2h1^^&rNHf)avUS$NTZo%6r~(0oQ1#sWubgUBIS`bLC4W99MjV%oJ!B#2WZGXy;(_e>@!UG3;lGfrx=G2sVqZ& zm6|&N3PwkqRSVL6NX*Z31ODYf@QA_OzgsYM4UGbP>amPB0S}F2_7K^6!t!4;w&S34 zmBg`QRu(q zQP$p*9Jo%M>1-^_>F~ejVYWj=v`6^z?F^Lke1gl5ItCw#S zE~(T!+7Xn=B9L6F$jA}spX5&R6_dmeNDZ<(*Q4opmTRQpU9Ju%E7GL$F*;-m>iZ`g zOgS8en6&}nL>WW(>pBx=b+1y|JiJn4ZzVmW32&Wo2P)Ka0BO$&&|_1oEGwi#%TEK$ z{0!wyO$}>)A^;Q}=52$RBnjv(Skb$L9mz!3uWgHJ5R zYF!h@i~tk56%G^|jzu`x?gi+Otm{=*VDso1*8JxQEHj?nP%%L>anLoAK@pJVFDUg5 zuB55w^IA2I0$?po0&XKU$z4{~|a^WlJu zP7t_R;BG3=pNZWmw0sM3yTd)yaLGJ#Omo!`Jn#co8zLOj)^{5atkK1i$S|wIrNu@- zN`GvrkB1y#8>sG;pU71CvqKAPvhmTtN@;^k=w zz=m_>&7203XSw_u>DN+01YBjf6Vdl#QpM5HbaP3=T*9l2`@!Mq=;}`@sXNvY1#%Zx zg41^Ev>nsOqajT@5Y3*9Vg@FLd^I3% z<-{RCwm&Glg7c+D^iSnT5tO|Oi|XbENDzR3qK)U!70Aoe5!wB87%K*H{zeY8JK6_= zRb7%UH%D83yyI&r*AG55SdEPU6XMpKc2I{Gux`PfF8bdDNsVG9ZSP)i{xb;Y%f6(( zcwQ@qmogj!Fg&S!`Oz7p!)Nv5okK;?_D$w&Hu-r9T4g-}@4 zSjvtrF5j>-smu1qGKUuL_B$X*<#`nPvk0#X%>NGdmQ&&yxgalT?)`KxiPK zsGg#oy^(m6B2-bZ{_<-LOMNWpIPwc>r(PLB?P8L^O%7=@P55ky;-&tXn!dsrqniZp^@(tznftjm#^Y4tL#!e=3x;jri>Skw_y`7_1M%bn5`%ebShm z;(*jSR=Hom**_Quw_BKLFLfpE0)%ZQJ_w^x(}Z9gj=-q zFjkXQg!AIyAn~O7^I&339VFguuakE^jJRiZX(|=w0Q~S5_~=?FPPF><3dOl|Q6~>| zlRmA*X@e+h)a?b$+hRY>NUaTbm=0kZnwvgvXed4l%C8Gi9d(6O>|vuQ(++V;sZ%Rp zG?adjR;TdKT*jfywYv;c@!wXYzrw8bj@KUFH&G9=3=6E*4~-v#H?{FQ15R7bIZpr% zWJF009TonmU-^NlJB(XS7blL&pW9S3`_AC=gZ0PZ=RxtIr0-M-Z@Bi2dwA1&|o^Oq7U<5d%YiKn#karV8f z5iuEq6j~9hWsy@F_O293t@XxJ+Pki$3Tt?L0q06ZXJ}d-fhuf!3uO8>(4MtU3-?KT z&b+Kk5Iqd^12AX0u0RVT4{g61i9Gj?*V_`jd*`Ne@E8 zwdtY+{++ZM@Ab7YqZR410pkT~xhwZg+r991AHBS>1K`)law}1$-Km&B(mme2`PPAz zrg9>|Q9BrJdjtDj7Bvtu?*+&`($@olRU{;O!3o)usjS8f$9$>UKeCnC_|>tK4<}`h zD4jl4Du&08{EHh$K=^MupBPuq?iW@4L>Y<=DRKK*A?GCv#d4T-YJN}>4N}}5J2_*W zR=`Y&>YVHo07}w9h0j8(WsM!d%Z#cc8=oQ@Et*@yrbK9&9>vK}<8#eai7T!H2ZHK| zjoaIw@NQrG3VD~M&!y`gLvT9Ttr3&oxps9{E{GXYju{t%M`9tDPrY1mg>Ka;l4+h% zP9=1eCmujI{Uq?LblR{y$8F}d|m zUi*cXZ$~VY` zA}eVSRup#Cd~siy@EU}Tm_Qyl)?M?ej%AV8wDjwf%_nl_@dJjl#ojGvUIILF)em7> zG`ARJZ!7K>AD&Qw=onU)2FC%yAqa27^B{KSM(h1SgOEfhfN1^COF<#rwOKX*Ke-5Q zvbi*~jPhjV-9X4?iO)6+4OCCI9~iJI42giL9`M`WQpmkqHojZsENxk85Y7#O>Afqh z0#|$k03i2EN{X?4B%J^ zeXt3pr&4|(78zm|1S^piMpk-E+-m>mZx(K{vgzmxp z8M&GL9#QIt^F!#yQ(=`AqwyzOqRxJL)?LEMbsKDoiwy8B1hjfj3b0!;s^Ndt7BT8L zsX6A$I_7%v8=zD<`Zvf~Djnm_eg^f3j1Qbj%c+kS5H_RQ+VUv*E3V_xl8h}J4bETE z#j7P)9^$PfZJFw~mjY8^sS`62K<%$O?&P+S0)ZXl=em=9I`FG>d#klR=A{Mv&5Lzf z0a56%PrJ-V96QO#$qmH^*m1+JJia0kirc&~%_PTXNbkl7x1q%5fadQ9E18QZ!n8_G zad6h*%(C7O3h-uSFHosfpFwsw7Q81p+_+4xW#0P_-R;GKvR-(ZyczebIw_6ngq|HU z$iDTo?=J=du~~MgPaFlER@Z*O4|gIDeLnxRiZ>!$EkT)Qe|BD3!B>w;#Ts7B27S?~ zdHm$gl<0afF=j~#g%w);qS*YnU>X~9ZPE}GwV>ph%94UuNi_Mp(SMAiV6$)`plUYH z;n%MVw}Ho~(V-nor5ea8G2uu}1(43M=l>qTa+rKo#51D1ojcT8zshCQe+?IglLZ#; zRN#plV+AUuHbs!e!HYWS53Kf3XL_CVj)EGoZ-o^Ng&_VRB?AFg5X<7ahc+a0z{{D` z^U01O^$5F|$|C*Sfs*TSAR=KjD!ExWl`NU6eFZ(H(j2jGay;2Rrvdm~IaeSvJVQq) zmkA8YHg)y+3E~od_@&<}*FRkvH6s<7p??)5;BnWGDVWs+hbYPyLsVhUAm4~o>|UPi zGRY@kO`x!n%bx)xkCvDCY9xFeK#Vn)aBWmhde~nLia&zs22F>BbVAwG>s9P(dVB2h zpi{RrqSXj>l4!yOG^y)_&H2&NM(a=-uRn5Q!W1$-G?5+QGb*uC9T}F6VSdWqBvLB} z?;B2KIA6)<1O+ZjmVFBMeFmg>*vPpN?7DNCHC2#^M}I>$c*xY3I90m@BaumpT#_>c zlDCzpjz~ex7aBi~>SS^s?Qqi@WozvYlv+(*nnD45oZo^7!%+t&Row5PPeypP`=?x|!)ntY&)M{zWZ zZs3DC?>Q&2Q#cKnQ*c#AMCW7#f$$yh!yZs-wnC?g)Tn@YLN!YwHc6@v{PGYogjnoW zWs!f82E)9c#ydJ|@4`eUG=VOd2B$8JS2g^NzAzCy$!Iz%F-Q0$qk;QQU!Z;}D2fNG zveAU8@~An9nE{?pgq}}@ftNqGRYqo@o3N8-ODUd!`SdkeemyBzH9;qAEG3Yv`+M|K%eFA?PZ9njR+`Im^VS%SA zqfqD90;E-zCBjbMdp~yVoSyN2VbfxSbp3}A%Jg4RK1|F^|Lf3q=Kq_L_cq4*)Axjm z%i3t`)i$2`z}SBq8Q4?sll)GaaudV`A zk?~<(M!B&%2ADX0hpa3Ks2A;NyfKg~tHnMBXU~e>{M+J?1x0-OS|}UKMPog_vH z^iB4Iyk<~W$y5L+&Y|R`w7xe((J-A{w zR*Ya|X5sBXX%~#T0TB+4HkBpS1<*xhC*ysT`6o>(6R3jgt;rK2s6AE(>Ak1&$Y0zb z@G-PMa4S=QLC_Tl0@V>sgPRp(LDQTQ*0{AgM-)JSiTCO8|LDxl#4uJU>7s#X<{fRa z;;yw*)pqxB1bVt8_Cr$Cj~r=J&34IckZl@~O!*c&IhDP%&$lg|Ql;3`D;+1=W{=P0 z=6c0;H+Kv=Ei7~jXPH?ds?FeR^EsGk5##KyI+T6`&pBnTDLRp!KNS?Vd4!`r(Yk&- zq3193J9$_=C~(vPYTHKK^*=ykKeFXfqd;G;UvAaoEr5q_CU48CaUl0BfGfj*BU&;j z7QsKZ10Wjm!>ZhuCIlhr}nEVjiS9VD%T1WnfMyv6A_3 z?~$iKqGyQ&NExy*8EV+A6o0@*>^DV#jvZfunxy6$CYGD(G)sqCS+>+%+?4pRr-*Ex z>I-AKy@~vB5eQaAH%$*hytS>B6~I8twii%7WOAqvP89)PP^?0VGE|o&nJfdF+yPnX z>M1VmJtcUI6xqE3B0H@H%KM#|-j!(Xx7GJe00NcwIW?5eTyL!8!w zmEqb?D~1pUi-kX(mFjTIk>LMt^+lxJtU5v#<>E}yK@6{<7qi;LpS4BtgPAs=)nf&T@0kTkLU?Z)4lrvs5<6oA$DTSv(IUf+ ztum&-Aw!tld((V0%bkM>M^9KWN)J~--+0+|YRJ+^2^#+_Oh3LztMt}x0INDhRmazu zg}|RhcE7JZE%2vYwe@fN5)V;erq_iLvY9EKK^-hFOAIvb0~eV*1O!Fcfn75X2uez0 zsk{uj=~Ym_)kev`^d3~Es-9TpXmSv?vkA!v1}30A zUr>p|u;|oRai*DeV1Vj7rI6x8e0V*>=0+n`>nI%Q*Krr|>Xu~&LNs1N7V$mKgb}8qJbK!GY|XQEcSTV6hcBe{!2JZ!r2;VG z!a)85d>!BK@8{T^-@CjyW1|Uqh~halpM4%vmiCrD<~C_OIoa6RehdSaOm5NyZ8{Eu zO^@`Yw&O*6s%wF|TZ6hAWBcH6x>-B68hG+DkM{ZazxwU%zb>kU(t|6)~U2e&Q z3Jv*962iZwE#h3tIu_R`#bh{C$e7{SjTTEO1wAtlJ&qbl8S$60G|mo_!?BD}Snb*+ zPa^zQPFWEheDmB`K0pEz>caG2g?vXMZbgC?W6thcgWjw2?CX7&(tW>^(D3Uq*|nT0 zfOq!^BQbgg(NX`rP?vG8C(4odzvDpb=FCf5tGP9E8S#9yIH5p7vnXrj?zOg5x4W+{ ztWTLZefKzhkCk}8&W|!5>}tVExbWCCX|4eHq!*z{b@TBT)lRji7o2GeH2np41oenv z*ndoY8mv!o&-OD=0|7sp56rVWU_^->(e`AfkDXUxEPwo9u&nL1*J&~@w?>tN7+qv` z{kGE&j6d=2&W^&$ooR*EqBDI@HGYRTk6JD#->lRog^owE3@p#)d8E)mJfL9N!)Nao zuF*1K;O>WpPWAjg@Y6PiasE@f`tNWh7Eb2>dBhjXZ5zT6H-Sn%>+#n3QGaP%XA@^19|Fae29WevQ?dt7s1C;{08EuBVSA^0-bLSfp{D zQoea5ou9UtIZ80={j7+jIHOw8Ecf=ig@^aZ@#cg--A5m@24K_~KfLIEUV5*ebIE;% z>l1CDY*yot5VAon-s$6V*ialRt${Y?Rs6F{OSIKT?Zi z`P3}&=-LYMM5z)FC$%yquG-;;LZ)>u2zHX7%xAXD%!P0%;F#FiV~u>jV#e|T%4b+cPj|2!|(Trkzoy$`NtU}R{=z1uT+ zHT!A-z`63;$1m2QlcOl0D1cH-KPH18iqS9?6=lo>FzBIpIAU^h$Jt|wv#F@+DtcJ)g#|L0YZDP!lBry0;_ZuEYR=1elgr$BO)slrJaa|X~EQDu!X^BN8Cq)2W&e>xjQP@_oD5K3?nkvjlXI0 z#)U!^5?n*!R~(83A=_cNZt;UKAmBqAg-3xqCu34SPlwAxZlsT~BMyOFj-?S=`?mqD zARalw)6c|Wtl@qR_{s*Lu8%hO2`W}G8Kn5!bBHs8zOz5e-5tS8&~@XeD6n4}rFP(+ zYsUIZsS5KTR|Sm5T$38H2;t!g*XM_DKifjaU@Hzf>50`bDHw@E*RVpAb3la0QZ*3~ zDz)H(ICfgDPnnhYeXyGgLS@yEFHKbP<(itoJ>_B!uHepIoN@EjuD?dV)zl21T)Gxof^=1^9%m_!zlWE-vzDjb_eQm5u3{vXE9X-O0y zi?U_gwr$(CZQHi(x@Ft8ZQHzMn{y{(9;PGuq2KZgGI!)TYcFPe8y{`)o1<`9lP0eb zqKR8aE#k6Dlkh5@G!;xET+#+P+6Fke_uFxOVr@-?6Jh)el4hZ!fb36=K#BmHrff1y z82wP2Kcm!X!%=U8WJ7h?RzCt1XZQu2AWmoTH6mU{##M)$liMQESqKy2G1#F_t*;$| zp{=S9>Kgz01^aMFV&@gH6e+j+F?aNDiZNBSK0|KDpETm<4brr7e3-IXJDJU5w?z4a zOlceCmQOuKXGb@vrPd5_rX%I@TUH`%ick=iN~2tB?UnlXRFtS+?z^NWr}#^Y+uro* zhTQgz!9Ky?Xk&t_)F=1+J7$=M9fwnHqgv}+HdnWE!gzY4RPk)f81*j7Dh_g7y@x z^~$WY@9>vfti!`n+uS$*(Pc>xoDSdsY+B6G#c1P z5c#-rlRU`uB#TtL!c0ivpSrbAe0HyU|kX1`;<)9~0h8k!2c3V5fh{Te|nI@h0z5fXChcHy5Q_VOGU{=_txk5-pbTN4z4INHtDHI}Yc(e_VH+n>1Sf)3h~Y9ZGqA z%CKOOC0(>bsZjWS^S(1u*&@Qd`?Df(46xIlBJD)U7PBaU7zF2tRA~q?>>y@fy6(rI zn_59a^=~!8km^p-;Isq?J~nQc^jHQ@x|Fm2Lk5V?kSY$}d}_X6F!)y)Ajkty+9*;wogKq!IxbZMY+!2tDF?!5 zH+!dvdHlmTFtZ~X*!CPM?W944ida>Cq{}Wq3~!E2M)P=Fz4R~j`Sh;uSy3clCzE5 zTX;QN+_x*<2lojlhBrIcJh`4cMxIwYsd?XR;fKprcE}=%$I)w90#fJxm6JUe&!9Jms!Nd04nJWHvA{SL) z;)C>e@*lkQ^Pdq-U<-N~oCR=P? z98^W}XP^d%a%hy}Xs%mJ;RkTP;;uGb(0li0?^_Gd%^2#v*YJ51R&J1ArmnQCNyYl05`Yl93wQYmw*%Rt;(WxXIq<6LDZQS zEXzlOE~hf=Jw}{&=*UiXz47U#yyugMW6~`ivnI`zYHaFL3W@7wvN#{2{%<9nB1NR?80?&5e7CMHs6(KZ$QoR`bTmDH@mkvt>Ox-& zm@?|o9OxewKLTw+#ECf!MhyH(QERR-cL^L2)t~7en0|2B5O` z@pqe{pXiYa0x=Pge2okPKdp4leod3{P3swtN33B`wMN~xDVPUh^bkV!O;{+qhU=`KyAu+=EUX4oo{X@5bOWE}mO{T9aZ zvM{icy%>f-DruQ|=ko{5z#>OiVZgPoG~h&=$ZI3{&nh>TGOt-8;u4T$@yt}_96K%Z zjPM7t0TpD}qL*5GvvOgOZUevMfafn&v^5o3mVQJBnMzGAzU#!q;O_}t!BZK%?OEQ5UNoOR)Y>NL*;JW2js^>VsXDy(ltmUi#WL#kQu z?Jm-Mh|bSXiVmq0qL`AEB??Lt#|VAp1zWJ4cqW`Q_$#NOb^<5t(rn6|kd`L*Gl2MO z3JB>0PiYGhY{&_kL=0gTn>9((!97Kau}MmKs|ds75TY}3amI%G=^CyK(FdnxBYWJ> zgOSQ4Y_n*h`Q9s7bb;0cqBsj1@flEHI%^Y&*m?Whi9q!%c=bOr7;3UazdcC}1G~l2PFe6kUbt4`bNLYU z3$pGKG>s58aZ`cN{+8vVuIur`YApk)bTR^S#aPkHyqx+8C`TjZ)^_Sh8CIse+uLN9 z_iFC-)BGdg(Ad(f0NRh-tV`&L=d4a$sVcm^G{1L97tOxec`@=g&jjig63 zWTi>k?V73CFDLqt&DmVc>s!2*li*`sskp4Zg)ApyPJaSg$(O^xYSR6!d6X6YPAU8l zxkhaPTX#im=3?V4C8qYubj5`PC@8fZSVRl?TU3%iCgf|5{ms9Av{1CE6L!AM|doMV9lOOj5tkD8L9Jao;^RWT9-8+PGURX^~L%LDS zgHs7Q8>naI8&&60p4m<&aK&{Bf>bUN1T$CKR@wmPbLB}y!wxWVmI9fuPJ=+xUMr{5 zL#uIV>K_2cc`6dRz3JZT{lxwlNf`WZ5BdM7*!CVl}Qqh9oYs$AvvbTF(q~XN*L^!rj0=gg#sG6Xen?1wa>Yt`}-UKc*&gzkZ z*J~@<5*YRs1#IrF(sNfR9%SjqdM$EKi+%sJ@SchpHwNyDRNf!6gW0F8TA@KA7w7J3 zJ9SAkzQ`3W*~2@#IcRJxi%e7m*d6r?HD1{)dh@BO>#$1ByY2Z;@$${E&Q}J52osJ) zTtA;O9+=`u(aQJ1VNUT`d~v?!(J|YZ=+yu{nX?x2;vW5;uq+YI8&L2BuE5}fI+(o5 z&eFt}0`?u^-K~8A8+bFzj{+Mv(>CHx{}D#mye>D3>yB32ou&2O>vG2s(w0!bHJR$| zdw(GdWO%7=xnq1^lIuhk=&4x);9S6Tp4t?ssY*J0tD#33_I=b|A_I?PZ4=|vC>}Et ze!Cyf*B^UmjZ!5Ea{Hi{@7OslO!vZ0d&@~fbJAJ7!|_;1?&2+Qmq8t{ z)%VH`)h#E6WpA#`xU5*uK`|`5dylb3YQZCJo)Vetl%XpN^m<`&X6^$$0Sg}hQl_rI zUjvUpq6}*XtvpTpf@PqO322G%alWiN3qu#D^T-DdG~iaTF?ZFPU8%4sMh^dQRc$&YH4pUD$$XpFS8 zH?;RLVJks4l4+b?KuRss!xyQbpElSD5jVgvh`;8Zt~dhb;`*j`t#QTo`^|IDy4)v1 z-PAf?_;RNdLSw`apBK0&jKSB#5_ z!LUbr42C7T4D?T%&T5i|j_0fynFdK)I>6)r7Hue(72{hoBI|}^+0Ll^B$XLQ7urxx zB@-@I>NC7XDiOJ!{&WK+(uW^;>oo1F6ADT4^g)e!8q>!2@pD3vin2Y17dcId$WGD< zVoP?A9xg6IOneb%roSL_o9T!-3ahuQwg4JR0|8GCG=$;WoTVS*j|}vdr*@NcV_T%@ zl*_k*Ba+_}@&?1gmjdp#WZlZyW2ACq@@L=>;E66s8cV;#|AixWK6u)gMEN+F(0bEZvfv?xnllW{ z5Dkkxw1AUwuf%fueFB+h(C?p|@%dix${dS=f%K%Ym%JE`D+0(dAY;_MyEQ!;t{t~< zOzbMBG@i&GSn%J#)1 zvvofDMitlRehif*l>TTPEFWZuBmK^nzB}KN)^&qcL^)7nRd0_?J3|fEJpRz{+K*z# zI0&9aeR&WwW+>NIOwbodcsCQ&nb#94m&shzk%OmTF{2C!aT%AK5ueQenzH`8m+$Di zQ%KNmSXqqk4c*@peAh$<62+G}s#J`7Qa&wd)D_{(F!}LFoC;%_$rbd+81&taS53)8@m5RnSdD9-UnX zlP71U4#<(CCSZpVj^{Q)Os}NuGC7a%ut4 zgL56~p_Sv!_^0=T*jBeWFs4}knmA)5rr3;xmAHbOBxhtP8v~J9d`9BJnxyF$IjN7v zBTJ|lR9K>yOzVZU0?m=hD0U*zjeX|4v<|)9TuNjj=9{^eCRXHXQD_QfV=LcJoI9mk zdBWRY)4rp1{<<=Zii|-wR{SWi135ecvMH}rAv`ErB9i1MEk3BckzaXmH zSNAju?5f{+MpVVqeK4<%P$h^AXROyuU5csDEJ;HT%%xl3O?fu68q^p?+fhVCH_SDp z0r;zaQ{vesbO?YBNIqB5Yg%kz%gw#DGet+jIO6!oJaSjRw+uGhUW7vrk0Do<%ScOa zosBJ`J7yI=^H7?@Y6AvdJZC?J4K!uPFAEjgV$V~S?N+`wuTJNPcznooZz4Wb^G*}i ztdJf?0UZZk{{1;o)%uh!KB9ShJ5}jo!sPb>WqJ;z3W}`KM-%k}(2-`;(}599HKn=1 zop+(r2ONr~*;QJ%0 zcPRT~;CG**ae3(SfX5$R7i$A!`@p_&Pn_12PLU#@odzafm&GLRGrhVTj-}+Hgt&2x z&_Y93$7H8W%2yZS^ZA~++g*~Mppg<^Ny#OPV(wSnAlOdU$ zLP!M5ZR@J>1uYcgnmnS^#U;=!lPV-|L{E|_LRu?s_%IC;w^B*#m?dbEQdqTL$Nl-K%Y6$eTbZAhi8XRcVHb3Bqn%kH4UvZiL8eZ93< z*VO=K70qcd?!+#ENFzAlHt$vg`N9y|)6`$~xyi5`Hm4GErYrZFXHA$kj?^^<=PjM7 zYADq-xS&%bJ^PIRD1DP#==xV_@?kEzH2rXKD93~cM!I7zmYHPOpZp=W2U^x z^z{bUkGu3=punI8#s8A7ng2Hv4(~$k9hH~XZhQ|k%jX2PK=PvNvWk| zeRRL?9G#BI8x1L|m7bhB_8p9bNvmDV7(d1zzm8onWf*oPE0G-@xs|0z{p_-VGskZE z^Zi&BftWkcwXAnE*XK-=D4&>>?IRhw_u90`RW7aYkRC0)tO>|Z6kp$^lP@*kTB@oS z4X8pf90`2C>$t)Sf-~!e&l0NNv~%j0){G~c4`P-TT*FN}Jsg!0CCH=aZhPwfl%x1E^R9bq(jSKi7<}T^UU~>naP6z}fotTtNsRe759m%h7js~8} zc)|MFOi##=38`C=@np$Ust<9D{6X=cH2fwL5-n1){8SO8yvwdI5;aVxCTp4}@+Tm3 zXPQguZHneO2mj!G4Gsoa#bnJST{=s6Z5Cb?PSHFFl`5P~HLJe+^0B&=&}BGRm@gw% z;h36SI}t;XH+E=j(Op_yZBXd_{#ff;k~;=frjCDp39L^`Bkrn4-;$_PJTqohVI>Jn zbYrx-U#kQ|7hb`IIgsZK_{2FZR)jhB3 z8r_INF38OpITb^RD7F2^*Oj**Lv=E7FXGZtt^2&M+aUDs8!*C==^_&_lUbz z;=?}&p;w7yXE&~;^#XjZFOSz-_WPajtdB?Ig_-}H2Zin*D8j^T`B3g0X7rDTEMfd4 ze-UC#WYO`dy;GeY6Tyz*1$eu^{=>%F`r(K~yh(WhxvxdFjC~>^fTMctGxp$rPm-!k z?3p2GB&ccw=Pkgrm1wqiWI1>XrU?W4OL6JR)%6fI5#Ih%gW=WUyyPmWc&tE+C+U!d zzd)bT3F{?>`E)fpRe|D>tb1D_1RO1)7HPo6RF(r2$qLtbuN0cbaX$2r!LI9Is?;m> znkptX$n;(3u5#CzGdH`s5+NiuPj%vh9WlwlQ?_xpA2qNLfozlhK%-V^jv&TPsQ8N~ zlJ&)$%QQ4=+_xrkxtB&?z|){t-Ud?Ks@zZm(pb3+)$1I$!bf@JNo2ezdb}z{2%S6A zgo5ccLdEWTxh5MsONKTy>Z0ZJpu?5)uO4V024?o-Ea&V!SJ}rW+)j8J>$)x+PPVtX z`a5b$q0jRYTn}NeveO7x=%@z0cvVQ<9R#i=QqjBP0$gR&*H#4C$P<{J)$of<2X`pS@M&OSk>ifq%H zX1GVjFW9It6!cDMtYY)!RvqX!@D&?m#3x$FE$ug*Y`zi*vl@q_X=RRLP-@)MSjZSA zJoMB})@Q@k@{;wZulkgr#yT+Dt&?wk*C9yvu;S19XmQ93%J?_mbm4*`pONdg-16&p zWqzre;#kOv>p)r{GWOe}!kmasYmQu?&#?--{$YNqG!Fcne9jNy(->#*Y+mph_}3pq z#>7%`_#AM_aoTBe9%YJ-z1ZSDAEJ7+zLlcdMu!MEKM}O`eX=N`I&{!^%w2p=&hxe} zQ{8QnaTkrwJc6yr#SbvOhRQ}kNVzGt)LYt4o??)o)k9pIomxdOup|fvRTqMieCZm2 z;CK<39-isqC@#vG4OE6j)gz+-$4U@C9GH=QPW6l3idYk3O8N+?J(*bk($h9dlby8w&S?#o?Q8LlP#&yz0 zDVruJH3Sdua?d#z0>K`R~zsNUaboje4-ZCdY+il3PTGt;DB!`c=z>WXeqZ~KIcN|>&_XfHx;ih z|F$XC)~xH>$yQ5GHFyI9MV>F%R(p?;XP2@ofE2`#%nH@}q^|v+rJBnX&xVuE@4Cc6!m7pN? z<+khK3h*m0cc*qJ^KbILtzIF#v}!va@B)?4#n(6z)%xxU9Tp6#^_N4^&%NX0n*KL< zq9dT*e+wc1o5h5I@jt%!YA|Gzi&`IY^$#XVWmYl?NI-1l?A?r)llsVaAOc zF>pfM8-IUXtF$!?%*?57Q{mBS)cpM=yZYRW();DF9$eBdndl~UeK&i$_I!VpJO3$6 z$WCs4>XAp}#@naeUT5$XYj5~=e;boaBAhv*^Yz2KdQzA=?aOA{cYHH1Ikv7*=Vfr^ zw$^q^7~Macr;E~^${~5+j4IlEWN~^KJ%g!C{%|-jUYFB z8U2}+C_J@BJ591H?bWvBgL5ocGqL^v3`LsMmoh&u!wq}TKM>85d`)SX$i#@?i>dI& z&dQw?kP_KLoVm1K|Lsx{C+pp!CN0{VcER+P2CMS=QcvW}$?4QT%gz~X^^ajs*){j9 z7K|g3gC-w)r$bg`#r3a|3%hRu;74wd(fn;IMsf7hb}z+ZrzuTz%0KfCZ%dE5CR0V! z81rof|H*sXTlDwE6mPY94V7s2G2!wmE^GB zOd3`Og;0D}V7|rPtPNk92n803Pc0GUpRawFCnBi_EofE>95blfOgPT-sQcRMcE<=` z0t3zwTJ+^5e!=wMfF1e8g(XG4)z=9537r$ICig5o*NLS*r7uF*_H!xP)#hqzIQfr)g zrqV0|UNWEUeJV zkVNJ%)O%mdOAJFj0#bUFU{;{XI}uFy~Q7>Q@XKX{Bs#0fFmuS+&0gKG74;jcP8O=;$-VWlo34{>oW!Pn3+o?f>!q1 z-0x#IkkBTwM5IPYBsYuHNTGHZIk6FBOlK`1G2%h2c2LFquO7Dk$+@SBh?X=K;EM*2oR zj)kpm$)RC;1CMU$*t>urp-O?18!ZbTluV2s?{v{Xn?}rSLHE9zwdl4M3fx%wn&A-` z`9TLp=Dj7JW?2Vb9zhu$;->+;42SaABSo=Eh~vg1%`U>yVlQ)oE>0rh$tT0&Re)L9 z_nsqo%$9R>=pm0LCc7}Ppv@1XYD}D|epoY4gr+tLRb6>VYaX9u;%=hFLfQl@DRQz; zN6nX{p_}paW)y;Z^HPF7{!o8pg@kUh+k+fHSm}hHwFCQy#OP!8cgzJm{42 zdaFopw+cY7OJOM#-u5HE_xcnrNB=LJ2D`fPjhWX-tWEd2t3AX^K{cQFA5ll?AW$Sho-@{TkJjjK+M9Z~0BhnK$ zd9*zuPH%R$`fH(y;3dR%G>{V=Z6l8g$qo{`uwzpSIkRU=$DFqY-2;LRbKsDl zVUOyL5_)E}G_lUr|p*Q9-IxoU?)`c@snOOx=xH(s_nn6WjNg zmKF7CU7H9eLdET>Rjm}&-FLp1sIIRh`;LLvCjWEcjkTCy@cNalLF<}AJ^WxI!F!cf zggQcnqru6Z_V?WKube$nkbv}#N8rC!@>ym$x*H+NI=Bi5n?-;5{g2eW-g*AqJLkuJ z7#;$Dt3kD`qPOnLL9$Pd1Y@q&G^hMPs)zQ{2v*lB6=y4)~4ZTyBgYVu;kNc(C=A zN#wD=t-9Rn<10T^b@yG52vUs@ryQqtbhGSwVs6DLkNSsbg}j%y9sCWhl2UXg{1Fu^XHhxPw!3?&fiBdQdHGS?Q-O!{q1t- za0R*hQ_0R=^_cVs$}cd&fgIjDn&aVW$BFb}`esH+Wh1;)cv;ANC(X~c3&oV}B^KAh z*j7vHEjq+Bw(YfaXG4}FG?rY;{%R{5-FE2)qP-bcv zMB;0QkC%=VTq$c{XcSCnJsY)HLq!7=%3Ety^o0_U2=Hsh2#{#J5Qd#vE%m0qm7C%C3-2sLDd|WS3jQq( zlq$4VaCF1Mrkll72}0o;YC=Yw4vNf-DL$WduIQ?o`0X6V$re|x3A-jJO44Mx=Ivkv za@^4ka{I9j@2Bq!@-mn;^J>>rO)rLXO@FLUtth2d&LOay@%*W~more#&eE#OT}ttl zP<%(f#D2Onuv-EGXyiREcEl%I*@lQM!LZ)c7Cvf6o;2VVk6hScNnl1r*0E%G?P?!P ztm1eI()ZA=a(l2%$@Bf7NoDBcHG?HZ;lWLIq<6n

7I_cU*Vjkf%N*|#nRer^)7Co1& z!3ibQug?>Yc6b!klff>1=b28+ik!0E2YZIa!lSk;R586TpV*??Wpxc#{R~JQJE99o z=3+W_Q_n6?4=>&A#3BDT%M8}N9`Epe6izmNWYaM2%^jQf0|=0-=@5vT!YOYIFHYYRC&olRT0`#}4$JWhzEs%o>Djs5JA#*i2 zKJXz0)SL(I^TwyYdOEt?G7z4Gykn5Zxn(KlY3J>B0S69)Pe7Oe*y9w_Va(fqk8!{C z1_4x~dC9oRE$_h-&rZbB=P%M*V9BH}i?`dI%k9x-6R==rMKo~#ieuXXu*T)FUA=c6@SYGp~+|fX}YDN^pJE(st0DK|oZImum8uAaDMorj?+=uzY9uZmD)mwQ=%i>nui=gIGj zo}_BY6mdX4#sxm@W>Ht&riR8h@SLM|0Oi?NgcpyCMw^Sq#^R@U;m$Y$C zL?5mB!Pfaqt#OYWv)z27$jikC6ur~I0ga*Zx|eC|g6XfLGFc#r^C}O|py_C=LN|Lz zp>tZlP%{Oh@=wBjj}pWF3_cT|-qiZv#xa-}7_A#eI)%fAwH+DfS)qH(lubg)J}Bke z7o$McvbSVd4#~(W=wv5V1gg&wE3MhSrP88MPnk2y=&`kIv|*g`2&jW<+M0dVgcaalkbjKE8P2NleIS(HI==9G)xA;-QLYfH zh9ARHv-k#ks-I81C4_2djw$g8tqDy87{(pej!B#~4=%qezR=ReIq8Rf5UY&ayGFp{ zBHW2n8R#*zF^FS$Q+VyLQ;L}nb+)Zq8**f{tO1AXkeEeT)a)oEi-b{eAXtYj4R{#0 z16u{VjEAb`?kQr>6An*tG*<3mXrijMqXQov&Mp&_vchZLht3Dwp*(2a%b_P9S~As8 z`w&O+LMFjs2^+f~Yhh?S@00Ae{tX^D6%r<1(iRp6B%$a4AuUojEGilq@pbjkTs+`C zPA2r>+@oz0PvNTbNiROhF=4+U()Q;ihRn zE}s5di&8vYL@=|EJ|j`pu?kR~XBB%i6Ddfq)fL7i_y=i^#`+-l0>q;K$0)8W*c#tC z5%w?g2+d0Xq&X=5@?p_rK&DsUu{81=J+b!1PI+$a-u?U+Q!~FcVS&EUk-96Eob;@3 zh}td^kq4gLNSzsV;5kE%=(oWEcntB!aK@7)w}BEnzmy(PMw%MoI|0b^!Oi+dsC{?w zi~ZzUxM8m&FzD4xcFiQvX@N8h)UnIkxBxLMd1!~?h)^?Zv!pD+SwvVG29HaW5f+Vy z8=t2`rZ&+XpG?-%T@1-73S9(ux%&`CfgG&0e*cNs5J4ma#Ki(mD3ADGRpIgf-L zN7pcxg*kA=^w~%uepU--h~$(9fs!Lj&*%z2qh3W+YSY1mQtj_c{o5)0FDPQVXV`y9 z6fFN+_dF;2e<-tZFm?YWiu;~Ep>gSEf$4}sK4p**(rZ-ge92&%`EWb@W~6IX`Lq|3 z_m|qf-bc~M)|2g)yWoif3yIlRnBdnyIHI?6g7{z_YE?zBXU4Y!!nYS&oHL13MNFP6 zU|o>Sawb^3O#d)Xx7WJxJRoJO)S)(r56|{3Oyj|Dw;P(8o90;+yC7X45o58+xEF7& zuNT`>MD~m*Cc>xG>atz0C>M|S7TeRmut<)zhfahI(nlm;4OOM*pR!(BC6NTbM__`; z71iw=$#V%g6Huuq19Wt$auC;T>0P?n;jMP~#5wDbW|nBPb7l;4++K3M8(AC$t zdRxpAcg*cpdob<-cd9$rNIBu~b|*u)`>H#V5ct%?A0f#kK4FkX!=e_LO3zbHoi^Q9 zjrgNSBCpW`CSsOoj;d=frnR{Oe;k&WvcqBd%sQm9xAArn2lerSUIV3~SUg}|GKo8M zbE}lV#{|q1rDC$&2kZyxsxA0rb1X}w1*lSHBOdgxzg}O8u1jGlNiw8z)&r$2tp-1P zvfnyDXES-A!qYo&y~6m^k>RQI9yKE8hb*c#;^Kr>m{K+#9d_p?=m zA1m;u2p$l4BEVP7G_(ABL+*LK_A@6B5*CGz!NxudJqDQvBkvQ!rW(#|$_fe9a-cH& zDA9$I(p4k*gZOdkPYAGokMGIAMLfnkBTqBFgB%ZdKeAV@JVzYQ5Bkr&Of3{TlirOI zuG%BBSZJ(pX+J7?<-G%!mXq=05w3lhxmjW{=|hOgAl#8gPmytf#C*f-TV7GHC=jsl z!jGUaPBH}W)v=-8xajbQp zU}}^$u>!Z@lO>X@r=e+s&xRZmjr%v2L&@q;DHU4l;O zes%1l$5UoFVoH@OlaH46qjW2jxTEbp?%KuF9EzC1870*;B8bk%!oM7bY~s`Sv^Rs0 zrAdlQa`d?7CV$V$cgfXE88SR=K7lKonmf|vvkyscnY5-v(2+$i_d`I0)D9o5;b(Dd zyn=KaNuc&xk3wEj&r*DiG(+U~@Ae4m1VrWNzxI+AhKTYM1F9Zrpwn9q6TV;xV2p)5 zl{M)!=>M<`U}h=XdX^l5Mqy))z$%~ib{RG|0HwQLbH5xPK}qU4I;0Vm-JJl}nanZ* z%{qx${k}?KNLzsbl%c&Q zvQ=yRhLvalG`R(JUx^oPsYNLt?_MrtAjZF?Zgkh;UB;mhs|st0=!cbBO~{qx+;6Zz zjWI=O0J2yEDi{JzjJAvKD73Ld4z`v$p8_zQyd-indnTd+YVcz0>T^zk5WJaeb_mw0 zg;R2(%;&25d-EZ*lexLT`-L*6$ra|N0PIFG3xzH|NQD{fLkqGQHfEH`bFe?@1>mn| zA&br)U|b2j|GT%}PoZDFAm`;m6sh+r$WNT2V`yZm%As6K_&md?1`gjw@uIWa4 zTn>QSwu1CpRKgK4@2GM_vq(M_C3S#RIDiL}xhZBa9Ee)+1oL?xX95l=kJEv>11RxM z{6f|EdlPxntUU*GF2^0I7NDd9>0tvuC*tnzCpiDm1nou13li6hSdxD!*&`Sbino-& zZ3NoXr-0vK9OnMTyCVrx=@;!5JtXStz;yNAci8vuaHs-4rW1;aR0=`#t6<2ATk=&p zER!(H2d83uqW%)YP>Z&|gkh7z9S&A*KrwrDxr z`NM=P4i{Yn%3G^@__b*i40_OtF9(jQ>Jx+lUG)92CM0ebuZ+;o1 z*uc$=S@j2>X*)K-@{p1Ir@2-xdEU8q7L;lv=?xT_P4Fc&$Xkcu_~I)5AZyRBn|yV* zNY}V=JW%7om9E}VPzwhjnr{?wRSiOSGMajIEQvvh(QrY->jk#~1@B&q=qjA_aWHcb z6}@-OWn@W-b@&S8{%EQFu`W$_4E;qj+1J0(*OuMO!!!n$YZd|@zirVuwadiicL)ry zW^MGC7O0lllHYC>N@J6G@KFsK%!XIjD=VeQ{&-Cf(J?t<%7;^eBRu3FfY}4)yQ`E} z!69Du4JNSxaEe>W7urK5DkqKtSrS4_uRI(vNrFuk!oXs|=1H_*T9Y|MhRO+3+{Li7 zc*D|TPoE&iOKy^qeKa+bT1CSsF1yIv3Uoh=bxZDht?7#L5|z>OyZD+IW_0~PO6e*e^2d^>H%BbzMlF|h`+W{I?u=~*D!wNu)&L1r9OrG z>G`jX-3ZkjpZ?}p)kIBC5{+h-Hisa4a>@4g;Jfe+MDAV;)n z%GWI`0~k+m&9|G@OL{&OjOvIcAPsmhK!;ljgG05XgPbHoJjce&TB*Q6CXme05H25F z%(X)%27?4g=|ffCn>Ad(tVQ!0$q<7pKXby?1vOSLwF|B}d(x%(!N7|^*A~rH+#Y0+ z%dvBdLTDa*4@c=D@SH=HqL!74so7m#>shIFdNUThj4YUCdCF$})wB)*kG0wvjtt>* z{Kr(yP=?Wpkz7gCl~@-G<0Q!xXTzuC`pZuoo|%P$Go9>tDhG@cO<4V~*q?R}Pg<*r z9z6%jL*FD$X8_0a#6+KFjpD2(my-_qUI&7QnyD1=32*u-Qvk;fFv$n4PlceEOg7)P z0Zf%Vpqe8w{jcS84*02e=+`4pUY8a(WM4G#)j#w@R%k~!gk?%cDFhv zexv@nF7FK|vfNHEl17?9vOAEt0M3+wU&5m8q0D(F1Y9$9yhYQFq=whkhQ z%(fFyHW*`^a8|I@QahHGQ!6+5>;JNV8GftM(f=4OJ_#aoeLgtcZg>xbp?L5Nh{k3E zPsD1tfhEtovknN4>8N&y)2x8MfbtpzLGK^3Z#L?9-aE5}B$7go%+bXu2bWeoE57XB z+`o(oLCpKnu&!wtEfkW-WYGjk`67REPS@3CVU3{h=m!1NUEk;ieOI2Fy((Y4y|ibE z62mhgDqCvJiJ(8NR5QOhuCO;R+%qxMWVbGEEY>rVKeM-Q!&_IaNhk)PK*l-XE=T8iy>h(;r9qY1AXZfi?}4)@(8$vwzUYOl zTl7?;|48@fO|R2PnIiodw6M02O_r8~3NKwi0=LI#&eF@Ycd+j2Vgrqq#yx4M)wGm= z42X?vl#ib>$2Aai_b0T#2QsE&D9O}N**K`eQF7u;ddXIWkB)06$Kxt$ED~+2wf!+b zN)*O5a9rSiZ-D3;nV$StOR7!;eSaXuMtVb)mEdT~WJlr$`h;)>^(=K`g|w??8s2DP z6MDFK7B?(4&{#iQV!9S?9Ph=CB)it85N1Q9Sct&(M1Mn@5_3O|geyhPN*S|7*%^B+ zn1Kko=p~o-JWf!4R^U95D3U8YzaZA3WodE8>PyS3WqHi|8Vcdo9vX;740hJsC z`8O~&CmQrG1ij-xA{~-Kv?$bEh^fghu(Y~|3FTCA>Pzfy$`IZqaq_{^q>DE@Y33Lw zHO^WvBsTFZsMme;RiT6BV}2zNmHAwWSC z`9U@TA?Vk6wLtZV84%|FTYg~>f@;oXMq}R+@8@KGgZQx}X_E3*_NO0FXT`#6@{dO* zsRKpJrFS8X5n1S-DZFGssQ6(bz$Z;&#nD8)e1bRw9RWlI1iP*0{A(qJM5uhqhX9JP zxdJpT8nP0~6i%k7$sY3(G77Yi%)c>lUEI*F9f=zL$iL1?I$$tyXlW&Wt2(~bnTD!P zNS#3&G&-YRZoVh7Y*M(cIA&1Y-CMt0xOgC?zZ=PrzEITRt@di4jhCefeCCUYn3tAg=!(~b@}^y6626XvoINh&|K=2$wY#=k zW&tF`jNxZycHNq=w&n|vjvhENT0M17VR3YT$k9oD=yV0RF3?M)27{^NHFj{F;3yeF zP8ENsVjMeMrMe`{{U8cNs@r##D@H=L!0K39S>^oKoJ=MUmt~!hgZg8(?fM!jysST8 zJ@^=WBQp#%@9qDbLN=n=VsYF*qn8dO=9a05KH+fiK`DL~}s)ch);g3>d3LB*0O0VDI8P{ZGiQ zqA+nwuroh6X%N`d8QXF7t1ofbixYeVsprwb{6Yb8wl1N-4R%B-XVsoBL{S0HXtJ}+ zlafa|ciRIC9l59WgK-q+P-p@sh9@rgV3+RJ&~l&y*Lb@7oEiw<)5pMesj`%)SibAl z{Ny0s)><75u{PazMs?9`eJ9?{H2+2CWohR+HtBU3ygRxq176#a<{=CxYZ$C1+DAGt z5XJ;#5{BK7;pdMBq);*G=e>}E#{j5zNg}Ap`xDGQVARl% zlmB)l{;wGH|JbCZYU?KCNMQKy84hGyQOgHb9Ul5=aZl*n*B$HINKOtZ5LgH136~YZ zw@`k+aJL8lu^&ygEGc9tw?Fee+Z;$If;N7Y4d#QtuZfLjsfZs?^cYCESt5!mW?=~F z68(iHTvW6O=JE71^luROZ}cUUDxET(;C5=+Gme=6-Eq zm9{)9PuTKclSboJ;T6bBaD=fH+`D;gIGL6F$YdaHx3}1|tzYDlk=aj=MoCkg!iAI4 zT)b=&(-NCGYxB1~wQOIr!t1TR#0UfM=HW?^Eg{ZN$!jI25EQ6}!tavCh)(SQBO0|K zHHO3T^a7>U9L%~N8m#P&MV-d&SLF4Li;%dG40?=w$NX-SOaf8Bf7^QgJZa?`P%3h_ zv-ki|W)e&Ex8r#8ecka*hL+k4d{uiT$s=fX@ze>s@MuOxQC^)iX#71$6Ih2a{CRW2 zn+^tn(*5I0@DauPNKxwQ2|{}?`8pJBlCc{d3r}z^XE**tOGaq8ZWIH zB#+a~5*7 zsXkihil@`z9yl2JPC^kj*_J~<9)VgJ85c^H&<^n5WBig__A6nQA)YTYmE0M`^^HQG zF5_(b71N^Xjs{MsUByT(f`#mNu&9*Kcz5T`8MzvJlngwHe`Sg94x1X|WwTFkQV@+Cr(_Q71pE~~a z1n0rsOm2mWfa;Swoh3fNlukhxz}3J`iU7ZxAa9(2z|uXQ+rR9pb5;kU^ir@T*-n|N&PVWqaFH!X{ zr3Nx)FVbW$9%i>B$L?yg2nIgpG_V}c!xxa}!2nn&=S@C;G1YrAVDK4M!X@NU8sl>4 zcefew2K7@Zf~Fy|=d3JpOqOx7(2XCRLKp=dcx~+E<@kX)h5HR&%o*N+DbQoPiPWVyK`n1n! z1-9IuzK6gtNphVk<2Dr&^__dtu5X3uJtMEOTHFq!JTSqzT7A}a#Ejz%GwfD*@zg_F z*bV0#@0=1b_oWcIjA!Py8^u<4mNIDIS1~Sb2>d8wI|h8fG5Hj-V53H-?gi!?psnoF z7;iM!44ZEQYw9Yg!DiFwzAlfQ3>YC&pI>!yqE5&2Un?#!6uy+w;lY8{-rO&XdviU} z$4}dr&y7}jKAo7ZbOBh!1?wK_lxmkKjs}WouqfoDn%!jaObCU{^s3L!RlhPkv=sxH ztxA@|(23HOxjaZ3H?yN8zl1#V&BzP#`8}VmR5#dmrVpm7R8(_g{ocC~_43qiB=>?!(H^SeXzKzbojDqjjd~JzTPPtS} zYJ6Q8NTU3p(3B4>fGN`tKnz>!Gtw&puZUe}z7uNw-~|8^;a;3p8BEbR1g5)5a{6}X z5ln$*=w_pRe**fFV=u?KjzngswMD?as!C)tItgC8aee(~k@9rMMO6PRCOim)TsqG4zN?nWQ_+ zj!;m!Atq-o&Fx1?c^^}Aoz_2Ry>ifC`|tU+ryKg(Ors76rp+Cq8n}(MwmT1GkzA}H zIhg0_oq6?WH<)~MEIZU(tOO!C?xupB&L;d%MProj+AmBs|k3;E3;t6`#Pnj=2|=*wIf=Al`x_FYQk z=*14aP8)Y-bmLSvc3MdAPp6YVyU_6!2DN<)$)sx^K5~I6Caxc$f}Y~;fHOU1 zq~NKX2ET>FDTiF^@dQ;%nv=xL5hz|fg%(SbhpBGg1cebPY*vSvO;0_98G^peci!0W zSt@9z3H!ZBhs7v_rzO=i6?=DA7KW=eOTzmK{m&Mb1rmQGcT+rEg2l z-$nnf@;cBB7m<_c&`XT|g*8DHlppJiexgks&9a$Syk}dK?x0SFs!Uq!dN&~uY>%x;+2`z?M5aS~ev6Z&_C}Q{Po_@cdWv{=+fYD*-ue7s z!*MFFyU}~tR_n3Obhokk*O?z4wc9EvTjj^f_-(44oQH;*T)Pq-yE0Y@{QBX#{CB4- z15~-okSX=F1sv^ZxNytse!4o1$rj;{?c7RIl*&2L`z5$~<*&+odxjpHKlZ{=5S8~5 z6Vr0ku!S+1x%?e-ZRZ2q!vUFnKc*Vb5kx_lj4gDoJE7#C})Lmr_V(F=B zlM{q7^kervN7qzYuw@+(52qC7#y*2_JbtG^Mof;}Ut2rz&2V($X$an{)Fq4A$=AQ@ zF;is{Ar1r^R*jXbB{=%Hci?7tXvH8b!>{FM9ebIM?C>ReK@hXSD&T*TJT=|wz?qaR zjOTRH$t8iqK1@bXNX27Tcv!7I?dMPpauqeKyJi#aU^EFo)9Si%u4K&aC|giC$7b|q zmO3yuQ{|)qB3m}eHfSPFLNJ8z;Q}>_Y;EPVZs<1%LnRpBU3R)*>}#7({_n)@MIgG- z(?F6%*ZH1)&4liU5Jj7eO07Nf1<;koh7uuW@QFWJ&ew=R++WI^`Btt+qxV-`9Iyq@x%o}v6Vu_J(yP+ z=l7~|0@2Xqg{}7!K;VzIPJKI{>A>ghvRM;cfC?8n1Ku%4FhavCf!nw?-rbIg&>qHw zf%bq|1G)19wP~M;lZ+TK3V;#NuybP_cv}Y74B&sIiVbW!ywn!;G_nq3f+8Icq3B_t#U(9NT@e zSX5Z@Uwgg-EMW}MM?%Ydf2P>X(9o*$6;vS(M~K73?zN#f;np6YyyScmgacxBxi(kr z4=$F25}Zl7cXfQ+MH>4RYJ%6H!7}FfG*bEViZU3!Wy|XU~fTkQVw!m zU!Jp+@weAO3j@byA7#|UF&r)~){Q8~K1cd~dmoM_S9`$YybTW`-VONm3;go~^1bT~ zxC`buKA(f)Ku8IGtYB)bzU$Iz6h)xlFyX!1?vc9OHmVLY6iN>n+#Y6!PBaEX9Lp3@ zs%LG8YNZ|!(;+po`1fpa$42lsHUy9Yw8OGD<3Uc-Z?p!xdInJah?sskf|SGUQbRI1 zopI2AYOv3t@Hr8I{mFwm_#61*E>W9C4T|_}Mb8m_2?BLZH=lC-3Fi&^(=H#^MOasx z-=I&0_^2R6{()Po3Nh;MVdlT@S7UfO_-^N7t#h9{+=UD|j5RAU z{mupqP9;umbaAuG#S;JP3?op4;(o&;=x%wGwN07eG9_=uhl0FhEB3EttwlGhf+4Rl z7xtR`oK1B?-9wFqmuc4fdi}uYj*5RexdBUF>K?_|jo1+EnyKSk*K>?a7{}bQc5MAA z=B^P076zk0@eo7X)2u}v!A@YkO;aAUF3z!ZH*%Stt|4fAOO{JGW3o(gd&3mkpy=1a zGanB%3Vwp8)A09-x4Qn`VlC8~G0zbeCdEKz1F=8{FIb9zuFqYN-hA6Z7vY!JKk5)V7?{eDDx8QbcaU)1qozMkJIe=NTbkovd{7*ZTXUkJioDz1q;Gc)RwhH;Q z%3seVH=A$d-{^&}nL*>vFcQCKGVSk}5A^%@^=O(Wt}Y=1?)DM!qoZgQzby7J@n25! zrTh)ZHAG71jPv0V+=m2oPEE*1)uZ*#49Y&>fl3s}tXy(`&PL>e1*-|0 z&XidNuNc2hb795zw~hC1Wq2UDo=d(^w700hP8lDxdXtoMp76Xl%{Ee8)GL<5HnC5D zYm>T@0O0FP(hitH|0Frtr+>N5aVa;;c%PKJw=!5~DnQ~R>q1dPZ_KJsEcuBMF=nQ7 z7PYY0J(WZhb6-?DTB=ok_iQMzwQ1M7U~#ck>y;VG3C_>@x37~d*#+KesfRsI=i z@!^k4Kt3}qkZG);02H|Jaar17k7lzb@)Gjfe=NC-#(bI0BRiyFquwiuz|Y?;dE8O5 zP}H-miYtqW-vNaiX8jGGrLtkf*i`584Lc!u)gCQC--NXX9*B|h?LI$1A4XHR=7;|o z+vWMq&daN;I_`A(Cw~+>c&kRa`10yJU{}P*I5h5N`>HY_N81#m)PA zN^H_qrV3N2We`!$X8F(I)*nlw2+6Mx(So(JH*aV$8l_W9&>pfu-mT67vPN z+Gv5P(Va6td9_*dZDD8d~h5>sU5dRX36Z-9DJqug5`~yTZ zD+&~3M~Y6+!_FE^MvLB=tRN3G=zA1+aUoPo^^4p>k3Q*THM$$n>9GJhNwa{+(du%B zjC3Z_lJ60_#R|G`oVx)}6bedD=%xHL!$qe7n zN^H0QvJ|}V3p{y)!(BkOJg;mVB&-|@;#zMzUxx)5BQ||Ty%*lI1NI&!DcKrN3ZE^E z0(M3sV!ePW6=!;ut_w9OCp7>%Hpz?x3<9bLB;?QmmCgQez3oh(D;R& zkwxPn3_9VZ0eDoV?{Pb0V8hr!TFog&qvFvTd9HICT6?-*g#gVBicb8gH{9F7Bd%qT zUj1U%cK|3ka&zV3mM1vtvD^9HCyT3NGVeV0HUQ(SZb9(GFo5Y ztV}$5RjFClk?WBpO!TbY@OML1a$gHugaqV5tXY^!g1V1PfF`wW&Hhb^VS%!REDfX| zuC`VKzAG!TZ6Q!blmz08)RY20e2e#*-tQ=g)(BLt9s7!`aw!NG7rr)yx# zFC4!R1}P&90yDS`c{r7St+uM#XmZIAh7{7>S(*B2Ys=>wD1LddnUFz8eq+AOYB0`e zK(NLBV8g=_z<8|x+(%;{dBABpgwoAUOy!&yJIzD$t;1oYhtbNIkjZ(?Sjz|she0@1 z?y+ypeH8WqkUTZ0q~b5ubFRO0FnsddNgOBMab|@*Bv4m^;gZJx462y3`v$@~R08kU zM&!%Gl2I2?=)re;EcPiX0N3g+PhJl!Smc3++4*2g2qJhXVLX^^e7~H+RqPAS0O$n! zT#{y1WH~2wSPxg9Pji~v%pwn3X)ieHGKwI7$}^iajcOrcdGI45@rWY*aa^stvlZj} z=ugm+%zBfuBZ(^DTeH7Mh#%G^~RZ&Lh;?Y zT|Eq;SID{*{wfk9^CEsuUjC@V9&_l6517wDJ^b=ZWLF)*?YcjKY|D}cFbDyh@5d;A zCVTJ2q!E#+7t8G=zi81z;!i?4Eb*dD?BP=buv`+TE~o|BsOaG8?eYYW4}54B5f!9b z4dxOhfqTV%Yr^pEEIxbx71S*PTvF+=$LFK~wZxnxH+c8P6wFwya(xPsFZc86;#^x) zdKY-{4B=uk3W<5QJb=%Um3~QKtjqeB;s=0=chW5StvTG1huIm2)VXdXp0P>169J!6 zULP5&lAR2<;&FZVl59K<4y}F;4$X!c;M$p3Su*uBV@HEN->yRu!%ZX}x$wpQn@=ZJ zG^|U;p)iErs_q^MXMYXcGyK>c9ccytMPN@X|2Hl0zu}&_nEs>k<3vj~d5Z(?AMV-G zJBkmL6~!=Vae`cWsVqW)^^Pr~46;_fo;~qjpIY2mMdFrT~*MXt54NtYYBSuW} zN}PNv8jl$dbQ)6+lE&4wQDZ23mfM{`bg9*VGYhoK=eeWFW)U;)pN=of4D5HB?NxZ@ z-?@d#nqzgEE-F%z&))o>hRVjQhTW%(w87Atk@m~UT89{zziBJ#G z7^Y)ux;Sf>kfc{T1-?BT5e$7a_|?@GdfeI{e?n4Uz0iH(GUU`9QA@BvUrd>gc-A4Y zEwuOOL)r&$gMYM4D3F|~L}db)cL+x;RNGj;)3c}(zFuPT`)joSd}ajt&78&Sg#EPr z)m><(qlx)N)|hr1(yv0}L?F31n^29YudHdH`7~Z>hj{E6(K%y6R4#q9SDFSF|CyOg zSg0{0SrIyWo+2z*Mh@zye}gzSD{GhStw;|-%eHw)xYneL-RxaM((EM1g5V6foLA@+ zyq|(Z$F-p-)j*p)0EU%dHJ`*xpi8f)tD5BoshZ#QOBP5JVlhj2-={#yjb$$?O)MTX z^;4waey|>cT4zp=^Qm!j+EOFQ?9MMFRZjmi=m=DRaX~*#W65Jl%V8U!xY$T2ac*?v z{s}*luq=vY<>xDX!39@54dIwC&V2X{2X*aQihCchyEu}f`N;ku8iD+j23T~59}xj4 z(+vr$%cmICt~YZ**6jhrY1;A>0T951DSa>=`n#Fj^QDd?>_H4ZO!ILR*?MsxYY+I5 zK0eZg!&Kgi1y0}#eJtw*`w^k`kZX{MSN1tMZXhVNs0|Cp*+mo-Z$}r?1|5;ie-}h( zJGAbd&09s7u4f)RC1TqBd;dl&KI7!NSPnMTXoBdr2L093&Ota0TMtj)GPjqfE>k2M zJumasSEj?1X?FEx*&a>P<0&>`bt_8>sWjcp=l|;rQ8FW@WlE^)s!Mqk7BY;=KK7n38PFb7K%AiIrI8HzY|0ht8JV5$@1 z13cp$%X0p5DUk-+htppVnLx9N*<|rAsDI2~^+=vzJc+8ffDjnyBN^(!?Rfza-{wBB zLNq$}C@5J@>A{7s(lJgLKClHd+WSa3Zcej1@=N7P-k??N+TH6+H~#V}g3UoN{bK$I zyiCKpJGaPMeg$Kf^%W+Xy7CA*ryvUjYjW(DNH(bEubW>gb_~#*qooe5=>uJ9l-eEj zzzJf1zTmDwV=dt~g+K!J^)iU2$YWKrr+M`$MI#@9FJcJh07~vJl@OXS_53R^by22& z06Jfz{mfgKsapee?v)WQWp0=eWO@qoXJ4@G?l*gP@Buh?y?+@fBMzr5{t6^y`c{xF zb{)A6CevyKXkxrknkS~GSo_xQy%<1-#uG&GEg;NM2Obiyr648x|%!9(OUGhYI|$E!V~-Lo%9&h z0OEl%C15{VLtwX;hLhy6V{eXBx*QNzF_D8RKhY!PrtRn97&KRaEC5>jsey07iMdp>x`AatoBDqg&Qzi=C z`2-#50bNAJC|M3IqY_Dm-H>>>9DUGKuRVNf!-Ux>%;GgZI%M8uWMH^wt??i_#4p!n z_z!aQ^eD6b37c2sA<^sG4B`(+e5ak`f4fotC+;#U6W4zX<#TcVKQbJXvo?FfsSL>z z;KqnK*)(XvC`1}(U6cp1jlMlBk-VNvaqiRak9btm3Ttk`0urHklhzH5_rn;)#_(;r zZM3WEu|}$UGq2sQpsoKq`wm%SQ{xUF9*1{?eBMEN<;XTBe+N5~uH9lz3o+9CeWB4Su=w6=EE_*W+gaV~~)t3;`jVm_jHj|Em} zQSBrXZ?DU5hhKlx$*q}BBNJm>--D;q9dX^9V)H2#w>pS7UeN9-IF8P{a?8&n9RvBv z?GcNAEx*yQmG9Oy{d7UoJ^?lQ1Y|@mm0;{aA4Aff@B36?1tv+mDoIR8|HqemfY}N= zF2N(1fGDo|UlXdDaiD+>`E)|^hnVMqcuU+L)&9Ns!^9H=L>zc_*}6%jy|?bq4-&YQ3*5*>ppV!->ysF24{3ar-! zK(dm?y;oIMgE~$2R-r~MPUxnJY~hv`n2gHqL1gSrx}lU;(d|*J>FVR8rouLP-i1#M zx!pHK?kYpprD2t|OE+28DE7M5K<4ErjTjM3i!BNk_qyi)mEs9Xl2|h6xpETuSM(Lp zvNJxklD?V1O#qFaFLYr1flfoG1+OO6D-5nml?*fBZ>kENqs@xlIr-48yqZG84)Q+K zpPi@A7<%&UYgMb-TW!pmG#s`#o+gKGo48l_Io6!Ar9EkcWff;QM#zD?O^~3V^Wn|K zS@R0&K)g@2jfrN8hdbJ9pYIi{hSjV1ZeN9Tu#Rf!aUog|pIKdRu ztjvv~EU@OOpL>Ryb2O)vKP!(;;D~reNxgO79jZH(2pr}`IX_>;&BQM^Iy`;>V~OsT zDXAW(6KFS3FZTIfb$CiJ(@+P}8N|-Gjv-Oht+Rh@zxL!~jCVc%ma74uNX!;`Me4bM z?pL3ok`WBJYYKM!E=iG)Nrd zU?N+cH|KNMrJGk5q24ul=aop#8HMk2yuv4!xiVlMByi=W&5M`@$O}PuJO^YBmJ^TubWey4z(wx`p?fj^QZ#lf@ zT^&6K0ww*l_T4Q_VjwGv2LC~Do;EIE@a`vP}Ta-wymAOKZ5I+IL1 zP+;_DhNu|HW|_zpIGU3aS}RTG`Lq%}t*os>1XGx+3>eD;yDJ%2d><-{n#0ioB-EA` z4^vQ4m2nsaFBNqvtl*33Hj`D^fuSGF>Dq<8fFzKrJ6+D*5P!QA`>Z7m2bR0n?M2#L zJr4o`7kvNArcx64bQ2Rn%6cEj(bUIOGf$>1#b|ZRoA!@v@kL6Qi^CvNv8#RJEg1J3 z2lx*VCFENEw2G~msT|z}SnMlo0jX@O7^DCraK|540&);ms#}!VMGVMrJKn!@kY>B4 zn8_2P!W=p({|{%GX2DpwoUadcK87@ke(Bhs+^(;*&≈wdd&^R9ykoW>qyRFx8`Y5PXKmJAjK`Gv zh;)ERil|bD6Il3{Q(iI=Evp_^-Zy+Yq?qs*cLQpl#edD!QH@Pk3(qs=>3m={c5w z(m`0OIu6u4EnQE84W!u|XQOR+<8|wrchn8yK5jN4v0g4UKRnb-?j$^?6ClkZWyG{& zgFk^g9IIClj#?eM)7v`~($Q*tsan(oPDC;4WOWw^qV#X!7?Qvk5o+GJI&2v22j8hE z+EFs!GEsDFxY|W6nr%J>A~TD9I^5&xzbmM|!$h!Sy^RS`au`pPzyr4rwxR#=LE^chBHCPft zN2U93ior_q2rGnr03(>VTrc%+X*fymm^X_kc`dHxtgmIP*7Bcvfe6pKZod(kvpuHW zjT*ChZ#4Y5um?jSpjho48fd&J3u&%q=lGW<61+V8nIu={Q&i&Kg8Ge>>g_Sv71atY zsSNFD;wxbgy(rEYA{}~rfGURn6?8OeOAE9_*w5T-Xe+OiE?r_uSQywR@!cC@ zq>?3g8c-nmCuP9Vo6aBMW6z*~TalZNX4U(J0Le41cY9!{DNsUBs<(}gl)EC-M3wxj z2}3vaeQSd~(f3jV3P^-xw9`Jl>~v`*f)0TA1;&^Mbm$pdilJM${Lj`D2r!z93r13%HzIfqGtMQiob08=%8YiS!fLp9N&u1qaw+c2f-7fs zt4+O^g&S=)^rK~Jq)7&cd8wa(Aj15KkE~@$eHUxrye_ExD(FeODTVUmz za%WvLQnK|yB#hrr9ysJfs(Lcd0KU8au$SaKmOQ>y03J@#1cVh!N3@{n$cjF_syg!v zK-t!Olr#C#%n6U(5#Q?|&k-Bj4mFwLt{+u*?uZ#({I_dvRxc`gzylAWI)hC5WL?$N zJ{%*qEhz&CX?Cpa@(!?8^Z-c2RVdea0vwKm7$rh*Vn77~BVBTwfEorHf)bi#jDeTdN(9xR z?5yc5R3p9Db0I1>%3%^lFf^=r0nhQSH;9D^SuSzC)YK1lwtFr$jJP^N2K6rgoKErJ z5GcE>-`MrnzQ4Wxej-avgl$1N4IfGr`C&?$K`9^G$=co|)j-960Te_7L}gzM?h4=x zsz7x)I($8bC@o)h~hyvZX? z&9M(T@bz=J3%zp)&j*=A_=}(5~^mHm{@EzW8^K$@I6%Z*HuU6 zai|{x5susQ*X`8wR7NZd#Yilm$A>ldBfDGecD!hRJ7<>u^XNdXXt#%DY(St$6y2miSsKC&(1MUJZ(EF%c6)(jx}03lxq%rQ2-9TGY9eYMxD! zBeSmkIrNyW34>A{>xY9I=fq?M*|Y)!Zws3(t)|ey_JY{}%?LIQieK7y+Gk@hlcR?{ zeBRhWcEw|!fYkTro; zvn#_aBE5aBky$FsAxYQ*+DUr#c+2?0u+7jqW<#RN!gyLO&h9lVmzyR^21rGcLiY*6 zBF%>^Fbw?b{VK?mLAA6_l{LXf%4%i(Ld4$5^unazSFKXQ>%AEp1YsYd|BxG|<2A}+ zT^PwBSgDTM9orrh$Gp?KC`^Xb8FhszWXnZI)hHNC@in=1?$>;Z{0LuWh4{_Y1Y@$u z=O-NMQOb1+T3Un`aWv@ml!^Fd_7T(YRD;$*bKEz#W9W}60#aRYmlKJ_(}~=+c}p9H z&jb8139@$dmDidbnWL@wn*|4MN|*Rni4jiU7QBlqJ_s#Fe{8m@I62jSTIo}p#N|3+ zyIp@=l`|{vRbJdIxCMnS3AQVFUJI`{Y!5WLpr?A{_zf zuQ9`s#3Thv*qL7Mb!m%sXXMW!h)KMDG!5k{hv{JzY6c%DHr>HRvU}_;iygsizY#XG z9-s4p20+~1v)^IWUO@G+q+GG!Y;967&-F}Sjnm88Ne9D0w=U41ZN-d8KokN^73yfI zpq67+nA~gIN@d6Kg*^j1ImZ61Dm+Ik%F)y9J`VY0A<A#I-xwThf0R>G=qofEL_y>yC)`_CE*!CYU zsEu)ojayZlJq8`;*fZaBt=<=t6eIO+(g`D z!*bZ6?2K?eXJ{BE@7AAQL8hSD6GG7=W|vSEg0>^Fhi-UW?bE$dCji^+4U@8ZsJR+y1T>czvi|{Mv7)KjP?-O~9H|c@G}+%9{Hk zXq9ctq|#?Spb(CE>@Fn`g8aE^WbRy215U$`G6SCLEyZ*o?&9JN%kI$?T$I)@1eNZGv?qBl_B2=6pkGRfTR7 zkEuAAdyZjP-Wfw44wKK1FUdf8ih64;B5)FB9N+DmN&mp$neeX&D6SY&&Nv^jn0iae z|NIUz59r(bJY)QUq!q|@`EP3De`88>u>6PG=+TxkDL9ZwKJXFuC zxu1?4tZ_eE*=wu5@t4zRM3cx`d2Wb~QLhP=*4+AXP%d2SbNK00q4J&TPZhU=xoa_Ts((!~5+D!0#ClM<^vFI;UpH_7G;)#b8} zN$ofaS5!=yV;&z{`svUe6|(kz4ezzjKF4pi?V5;6TIi;y+px<`w>^Mn5l^cWnn7H}nRIvqR?WjQ7uL zoIO3G-mh~>T+kQX+9@~L(gSvq!n07RaNI4nnXPj${F)9g=OB`hdw$t&@mc%U`TMc- zb-1ct%1eibz_CUm-HjAQaiFhcC9r}Hl$4o^@oK3jzeLpIlhjzZ;~#{$9t5Y73LERJ z4A$~F>T&xE;tCLw+WeY6iW|6-N6^oI~n%jg2V^@>8$)lSiV;8y4tUyk>{ z8kvh>aY)Zq)>^nngoU*Pt^`AyZtsZEbw_DCGQQ47->J|_@l&~2zt_xsv0k> zgP^_pv|j8WqH>GPtzCgF1m-NzX(ooV@t)D0gtauvDD5i1RUW{ml)q&3Pumf0J;*P4j z(0S~l6}r%l7TV3S9VrTtc_yw8#(;5Mh#@#;0iQ3XS!@+K1($c~=?43UNCcA_n7$T` zdl=9K!L3~O&mkF|>13U`?U?q6=!zC!&|^8t!gZ&Qb^2KyWDLi3i-oip>Pdzk11nKz zpw9z8?e?EBw&2?XcY7SAxc9n;ddnE;PH zZn*4PoX$newznAR`#O!~9D>`hb2$CB;c+SX$QB<_PciP(8eWtXavQK+%u@%Qt!8Ij zF^I%nU8}?KN3Q*R8B8a_Tj{NR&`KW6cWVSOOoIw$Lk8TeqA(Y{#g}vUk%yqk`Z_RZ zC%au=H2|5gphb3RP3_faVN2)eivpT3lH+Qh6E<^-qZQEUB-qD%lS-&G7ruG z&gmvgxu6Vup0{B!LPXi}RFNu&NsUy^2F5Oobx@A7ui@)a>6;3ooBn!RyyV1W9F9g~?n?if50!7TA-v}& ziZ&CXVm)0thf9s>g{1VMv$^G@QP8G!;=m)!+C}XDcU~07Lq)_vAsfKwT+CIl=5@LM zLR{7+Wry0$+CFWd8@9XwiQL&)Yp`TaNK=$q&`pzEp*GSJNbz#c_?fX1QMs%5dRvPd zl0+2f%!<~NEw^=Z9yEO{Qw zjmjnjQ3Q`N{xc2fp*N*Xym?n4L;2w*rVGogl6{iN%J#9fQmDpk%uP?Rr7(2O=ObH) zv2ckvym*xdX(K%mKS~itfz99D3I{VvsXp#gMqAP}W!)f64aQ*D(*+=}?4wwZ2N%h{^bS`EN zK}oX_9`R$nQTwaUse(>)4v6QhK-ek_Wc$Y;*$?aCrnV9UPXftMZcym3nGDA2ve+vb zNY&8%J-3`{UEa0WcG{(W3ve3se?N&o(2i?kG(3qBXbYLb$DUMM1sdji#FE(@DJ0-w@5#wIXO%7QJuG1y;} z%jslGwuJDHD8_D~;wIwnyPuD$43`skE<;iMLqr*Vu2@7sToee#m5(2GWFJo6+kVoV zIle+~z+}EHUVdu<9G2}!gl@1SI;~5GxyX^ccn?{HWWPpH;*WG$fmU2>I2OvGI5t=m z`~Ek84uR(J??budUBf;Lm1(yz;8QPLI(K z{R{FXbLE_|BEArai)}J?yf(|*=Ud+ph5P;}5fX-=3Ng_is0NiHyC{`6)cxDRE4jddJSY-XppL&z|39rA7Z?h+i4uXgB z%`v(N(Wn2_6%41!E;0Z8kVsa8V04!u34xN6fCWgpvMRzZMF%*uBr1DQ3K1Y<$RiyN z>cB!@-z?8ONT6RVEzjz2zw>3D-lt0WDP1Ihc%IG0(}n`+-Uk#AlbH@I=uA1>b!!>+ z{Yp7NHsd_1_#uZeFTK?EEa75+5)BFYH1JLUl!gT)wdK#1)Xf8A@9GF8rt7;v{kMzn zF^w`97prxpb?3QJZvq;Rsl6O$=&JIl+Pvh>C}@XInj4|}?$-Q#|I@vi*)VSZ+a&rw zG0W-c*qQ%d-78u}()N%A{+~7NjtrPSm6kgV7xJnA$_lCp+(Hjd8ZJs`RKR+iavb8} zUwLu9RfkGPFdPv#Bi`x#wA>X|qEw%3gF<~nT~|XDPhBk5%YLJQf*mE*rd4`X+S1mE z)#6vW_eT5SQRuRUWp?@Jzero6w{@l|Z**lZOD|m^5f~>zQzh5e>%L?1UUlKbMqe_; z8IEfE)K=5yG>%u(7*eE`Lp8yX_qJ=SK*s4JU1iD4Nx&sR#ZQx+`^+)bO|0UkD-^oM z-9Z2XfmT3*U$SU3S}U)+n1s%BT^;RWFZ(H!syIH)dV%E10#Kd5G9eEnu8fZxFuJ12 zH{WHxZnbhc^EC^2h1G_8g4V-f0ihXc7UrS87#+f$g&k+yP&mkEkV$rc(%8VVOZ6?;#fn{~V^{}0CD=8RO1GqZ~l z*;Lr~1?x{x*ZlQa?FN{n1oxGI8@n`d!bmHfaMC(_cVrt={W7|%I*wRMqxhOQ;Z_Xg z1v|@MFwY{Xb>JS*7p1e8Gl zO}rxM4dM1~!X1Pmt$}3(p`@&@1GJ13WeFbo43G!+3?n{k@X`47xwy6O1p5^!%_z>K zFzx&}+$f^Ownu`33e+;2*D?gU6cL9XZxMkz_)3QW=Ah`ye*FD{=k=rZt&_Cpgfb5C zLVv#Ow4@yg-H2~2T1N@)bBHp+mT{yqBB2M!U0PjVyuP{gc z)Hs|FU0JY(gbGj5N^Ove5P1V3qD_DAv+Z}=7BR{I&&AQgAaMFZe*MtMOVFJ5d)qNq zwBTO>4UW9zO^`))h{x4%Vv!MWd!5Vu-Oy5?OXyo}4uvZSk&z82&)DJtY7oUA#t76RjCgnYn-$tj3@11+Cg_68J} zV?{6uGB=NVuL(DN@K}0sggH4ceO@=RdtOr5PE{aVxca`>)ltR#vorT4`sZ01^tSA# z{`a8s=WdXfvEsJ#znn&_{}b={Ka;kKWJ+{ObN~W^ppJx~j*ODrP?Et%TEToY0D{<{ z)c@@v{~K?Ojrl*^xZP@!vHzF1#yx%(5iiEQDHvY@5%;1r#P=_XIH#ed8AkQ*9?aQ@N%3Bk_7W1vD-IM#W3PP%S^=**0vaEGywP^i#5VJK4f;TS9#DsCFCeRh)?!?L&8pdR9~ycGWI% z#Gd_m^RItWkQ=?-s0Oc%C>rNmjm$O3h@$BE*hj4nu{#6HKNpQf4CF0~H}#tW;+win zniyl6z?ZTV!%LA1Nq`DFSu#H&vQTR-yOTjozdkh%Yd(vX&4Evz}(fg$Tb5jv}g0>IEPgG_R3kuib&FDYFY1F z-Y^(fIQn)1Cg<0F(^d3ObQT|y=A4wp$pl&!gQeVseOUn;lJJXA9pEfW#^#}p;KlLJ zSl-r3?)_hGEkNouKHC@P#ihU%nt`GA_hm zgVkckV@4&O7=@^zLu7G(cdEA9;&veodImd|5Z(!?HGMi^1QNl*XZ^i1KpJVAmBuP4a32diF*eY_4ln=%=i2Mna!9tK1%!R zml=sJC5Av|HlQiRiScf%yj-Tap4N`^FFhQ@bjj??=@;=vPE56zYH5T{fxlS$M^qZw zIdCoo6{!rEcLl3(5d?-j-E@z*&p=iR_>fbQ7I8ffMrzCNIKcq5)nSP`C?Fu{uNfvb zI`ToEGuZU$O`mX5_Dx3qR_44n`xVS_GRzw|*R)4HQ!EP9Ur0o$O;D?M)0J+(ZxUW;IEBQbW9sdZs0c%^a-X&!(qJ3Dd|$&nWmlC1Ef73ve$Ref$2L)<64;+ufZqN|kUn+1Jsvb;Zet`3;NZ81FFK5B{uJE{ zJkSawz?VSqt=to*HOjO}YIohvHuV{Jls+%;+OswK@HPA6miK{DP)fmNaCAes;tr?& zm)&3m-o$l+i~19_Q(&}JHC4)mCPWc}iPkPE(MzWfTeT91TzN<(wb+!8D`fv#uRV<` zV~K!u{kcCP>8#WuVf%S|<>p0s&S<>2cH1yPtI5s|ja5R}lmN?KS(j0b$sB?*uRO0E z#qe0N-o5G9lD8JdNg%TnFCCp5UdmRrK>X3HZ3!P2B@Ik>gY*Ob%ZWXE&!FT+#im ziTpLAoUq7nAva@aqdZLqMj-!IpYSV?m(25C8KHSF4( zIL`q9kbtpwDHeForXJBZ;!DKL9-Xx1s z+yB7HAxWPRn z{pC^WiHha>XHazS{7CW$4n(|)o=nM=Ne{oKPfcf2Ii=Ce5c)?&QoC(>o<}D5>cA!_ zUnpnmM-P@Yb#chIF6OVFIcGTw1pw_vPS(wp2i-b<-uOK1>;+U2JLvdt|KR@#@Wx0- z_aEulWDU*O%{G*OP>s7nFmy*@g(YKoWU&Ppy6c$&;Sw`{X*^_2B&h%2ziZ0y{mjjJ zVX(*uanesDjGJ)!kv*vXUB6HX{_{k^T*)-9oKo8oy1W^>EPFdGAxaVZusnDuVM=MO ze4_%_xx1?F^0*t?TWwXN3~6b9*7{;%Sgp;gB&fZxn!97#_>7g)6|N5^Ncr(Fa{i20 z+OTdgNSk4cIXW@Y&|lt8zy7f}JyLY}vUIgHO%meY`A3AIljZ^w>%PPL$X{Rgp|9m^ zGG{dB#hA2EcrS{hnd13#K7V5{-^?XH@p!_7q4A6-7nT^CRvS)itEw`GmEDCp#;4ll z_(r9y?L9=kpy_n4l%g#W5Z5eyA$hRe(jx;DT3Q*mmgO(%v;jG03couWY}+lP%X9}` zN5y-US#pfKbVXJ%vuiBA2zoM6!|7`nxqNv1x!W^a>*Y@vm0IfNg<;X5!)T%Ga-FR# zuxkLpoCfjDr_f%~OK4a3I-4YeZ5oR>?+pJ(LykymX$=zp@+_N?SU!USSq^U#{xP#k z<=Bk-x3?9&%M5C27>GO;i~XNZ7q+Z~qq|h%)Vw1*7ReZ1<=8LII@m?I*9?!+hy-!wg3F41 zg5w2@)Baa2G9rn;5<oqG74JIS_J2*~lwBgcc4Rw(QMI(zn8wD0u>t(_)V_UuV^j25QdMzw{ zB3R^?&kqo&O|p0~V=@WzEJHG-3r0&o9e(1>x&YYXQh2y8_^q~5X0+b}I_(qAbM+d5 zQ{|J?^~-GgViMT&DdU8pIXpF=v8-HUR?PQCSZxh#xR()ZR&xjRNkb;ytap9+cQZ&F zo)=!jYlE+wew)F1Y)IOhd$=5>bB59&nJ&iT((wKHq#yGrs#x)&KlHH1<679m9Z!)_O9g254~)R|d<{2F-0eZc=h!TAI*X9H`rJ*0Rp? z_P!f&0WIwV5Sf(Ozi~PO@HwM6Ji_BJJ-jX82t`iba+}XBG#@_i$K@N|G@(B(La@^q z^s}%hd^zN$X#TECrCj(vd$jn7R^ZMzO3_mUHu{k>z)|9T2ENoDQBnZ-Hi9D{_Uyd| z?IdIQM3{h>7S19XFrG9`m?BxPJ`f&VY1})+I{lHJo5-pzA&AWljcM4H+&XR#x=}g| zl?PrkLPO?Pts=T?=J-w|B%5jJR-iBOp4ipBreNyKPzLn1yQqT8EUI;LC}<_5o}V&P z6}5i{&$u8FWR{B3?+&$jU(v@fU1*u+?r-z2jf%b^iqNq9fYBxT!pbJmQz@Rnnm)o< zX^8-g_j=GMpbs$Oy>z(RHHg%`@-Od5{n3_4Mj?BHEY7j1X)(4bue?Z^z~T*tRwdQ!miN_CyMqwq znaz|L24a>PB7@j~HB={)2=(X;>Vn`JeIEC>al-Fq#^$3VYt{y)ZP;y|O37LH_ilk# zj2hglpvn|V7;LW%iFAwLR4{B~d%;#TQQ9H8hU-aSdbt>K?NMK#|JLzeDRH7uH$cxr zEY(IavC4K&=siX;z&1Zj-aHw=;&G`H8Jq{P{a`N?65=^1 zv14-~1Ka9Od=U((r;_*n?oOWiIvMYVT5&7Z=c+WY;#ebS<&5g?{Q|`O*~@8(R15zG zwLG&a7n3IZT5m}!)61+4r*44dZl$7zgz0tO^r8uVA)V^7Bk}xKlB~sIth&@NpY64a z*6=Zv@^%$#t?kH$whK*u!noV{_TtEwMM5}4_n}TJj}t8HVdlDQsO*wiPtS!nIbDMt zQ2|>nnNT)H7}^VR)HI*2DDDEQ%8DwNE>>m0ls)T3(Mg4#fe!T;UVpbKNE2>OSkkig zOXQA4LpJ2OXEzFa4`n{eH$zdsSM^~*s`$q@>5k#4w|njyB=BR7dE&^|IFycRl33!1 zN8$*fX-xf^?Z^omlVO70{vbV;MSaBQ<$WxKM`oA4-F~|@pVIA2Eg8Gnp`Kk&F%VK> zK84py3(TN07~5T_7wVlx;_vy<82lO``<_nVDQ?B+DMI@CQiT^F1teUgsfr1c#=soQ zmW^?g`u7$u-WcY?bLL2-)6mNXp;0%9$x3IAC*vuGxHSJsb0}n!sVn8Z@JXS%!(=Qx zcF?f1x?S2rf*N`NP->Uv8WH*!GoJx~S+u-~RO&2z41FyGV8aMeZYd6`py7Jtx13+S zfy$lv2yUMaSeD}f)$-Jv;QK%F68cyaU0^m!4Ht>Oeyq5jzigPRFdUE8gFHZo%f8{w zY*NmultBRO+ky^*seJ)BS>`%4FB{MT0yZt5370hZn+O$RP!|C>oZayhakph=zNKY< z32LL1$!q4xdS*BGBscF><>ALVfg5S=E~z<>02Z-1-=0?5#BlC(Hn9=ko>*Oy zLoN(7qC?)@PQ51wa>F`#%?CCRe7e05 zrzRvBdti6-8U@yq;#4CBlyk{Nc1OQ^C7-V2kEq)oE}F-gRCjpovv-Y-!$WmK4zkG{u}e|@fo%YDEyiD!);2Jh8<&}2^UYtsA5 zQ(QsL(@d3u;;tZh+4sSCX76^5|L`{0ssLX929m&rDu5RAJ*NSBvZ+QP3iNLIi(bybuSp;b&5Gh|(Za5@_XIY3-~$L z$k(O9nUr)>BMPwX`;&6ad6boU=g$KO@A9p~ zaONs-i?1>&jrIlKwCHmwwR0$6P909sK^w8hQwO*fVdvs<+>@BjCWpX}lDw6$p{#PzHQQ^HefGnz;Q zJxPXQ(INhju}i?$JH`^jn#OB5I&vP@G5L^$>+R!%^_tH>!qH?EOEj%_S*EYrRl#)5 zM#IL(AflAg5|zIv4MwQ|ru^q3gJKY;0`>YVZy^xpnB-Ciww znyLuX>TZ@yT5397A~}WKqcFeC9nDwL}3GQMvq+DS-Gx_Dt&-~j-MIch#`uA==?81ma6LN$i>1GZ?1Ml<*D zOrk=++L@gv-(wJzGVC+@?w~divq1f%moA`zxQ*891nkx;#P%Al-%apC|27G%=x_i* zw}FT(YT29;_+@xcRvSu_6Tm#ciJD>FEfU8LmH4FvE+NqQ3LjBPzA{X%9{K*6DZ+rV zY#CN+7|l64k5tqR;wF_9vcY(QmkEh8=ixTiRlQO=9;Zw`xaVckS-f0ZH57_E(?%qu zrH-krSaH`qTG)dzwFC3O#zPpmkFcKJ2P<#Nl_Y=S3}AFC(ZyBy{aXA5{4aX| z+y4aDWBk{d`u|=(Bx|V0ZjK@N%+|uA((wVJrdqMoI>Y~c+2}WNyxM5&2TJF%D_em^ zh)5EjFg#u@ts%)oWX=i36?&1^R@T;jR%TYsRo$oX(`}PjrjT~vom4&cd46$u{swD? z1m=Z%SiZJFF{z|`cyx2_{BC`{sb_;O(X=ffdnmwL!K!Y4t+8IAcn+zlUj1$VzLcn( z3vCCS9&@nR6gw0d6o~K$v9R@%tLiRTKM=g)Rvt9;#C|L0-FX%4FRCm!$^U#=!@AjR z6$GVRbR_!P_4v!dQ=CLfVIV*U~zdXt=&9Q57Ej^Td4KR5bbr$uQ-PnU*--fj{JDn zZri+9KlvfcA_##)AKL6wt-ZfglW^qSSGGGMWEImzNAK-aYDM4Se5As`RxHx$#7;)X zv7*34tB7h{!es@TrQlC_VNJVa3;DwkOJ(&xR`V|F*4vXA2jdH=7m21$1NlqC{xE+D zN_N#e54u{ZC$%Epw0PT@k%X_s+GW-Y!NC@g@}JI=Gyts2+3a)q+l1AGo_AfOWp>iu}~`0DZ&>-6*C89oFIJ6CJlWTwG_TQ?bV82Yc3`XwV_wd zzLB_&KDj2qWcqXO3X4^L8Z{K(o|5{WbH7Vx;JrkQfUra9>U* zPIgwldZH>SXO|NJgjFVB^?L%!N24l&nvBTG-ADX}ysiCU0rr^3JJE7DRENYA**PRG zw1cv+lfjL5f-iM-CIzMNi!M+_fA1<9`#jxaPMPRyz{k@s<|O@XEC0NUs#X}-C(ZHs zT(phWzh0ek-2B~zB!u$mHjNdMcGYPMzg^)WpgP{Zaue#$UgQgPlNd^jXKRdigG;`n zumaMwQpQRcjqkO-K)T==1sC~EOe5C>|Cf-*#D%h&2UOPxz9~M$oy6hcRYqsATk1iV zAbJFk=ReI?y>=5?bm--@lqbOsV%P^zCCMI2lmeVgjN>8#9U@C2u)o62Fe_$D7hq$LeevQN0&co!&;0a`Ix#8o&_m)nJ{% zJ~IOc%W{vKbXPB_7P1_>kh*8aNS@fwbaS4K3N9xJy8s_CnLC}dL3o-gUdGkn7BW3i@k4^C|dyB zBs*?aIBQnF#^{kf5^Y$^q;%d1ijO|3sa7ZLhPs&JJ_%lX+{tQ+ZSwMot5$LKvE$7B zW~ulOT4DpyCa&*Y%drMC@~`o;31Deh(Xy`4Kke+)_G(jWGVSRBU}K zFgA4`BEJkzDEMpH@#NWl!SqMnld&pJm5;uw8?l?;kaOc-(z%W}D3RTMNaN1k zM4>w!@y@)-x#Y6|T@6LXvqLZf;@BGtqJTf#b>M5fXn>j`4o&uq9b`$J(rYXjF)Bdq zTjXdVj^n(LzvuNE^pGCDogZBf&K({a!*(xqY3Lwom7BE&*Ox|KwW_%)y;>>^`(Kp7 zfoFRPGO-fU#UJq+S@AI<+l9$RF1ICs@v52IebU_br!xb6LO;ZD6(~;I+uq>4hvlkh zoZ9Nr?sx(}yEvH+Q;_+=N9jws}uJz!2c9-r{W%qRb_%m8bKAz01~+ zDLdQiVyT+|xR3Ze8?XGZR}y@NzX>KM41h&`=<}IxD2x7N%nWBjRX;s zE&Hj=Koa6`j;UN48)1=n03pooXSxmKnl+eTXepnawO2xl?J<5coLy|qTe1D2N|;=3 zR8u*8%lar^UOg|M-&CY zt`NW|m#*Ws2LUVB4UYKj_v|>)>cS$PwIBeo9`7R9Ld&ey)$#Fi9RC2^NlIL@Y!*K4 z!tRSE4&p1$r=NP>j<;yvx(J3J=0DS zL(a8|1W_snTq8Qn>PMg@WNfxU2s(My5s~pkJai`;hU1>fEPY}p_`DNnPRc|iV%kI8AbMqVTyY?PDz=IGI%#%LwZ;WKc#oUAN8ZrR@N!8e2Y3V{4*3R7wt~djFk!2d>Qh42ZbX;)|8t16#80t`8pV)TY%Dm z4s_eQbsX#Hph%NVN2vW%t)PJr#(cYM#(X6o>MRlYABW^W5i_`r!Tpu>KXndn22d*) z-un#a0yguF^jd8%=(~G$G;Lok)`1CMv!JEs~wh*IFV*$OTsUo;C&|(WY&YTDN2JM8U zV|eEr?+W(dQy=(t(yUhPY z{A6Ha{SQVY zL6!gU&KovY4y_qwgi6KV$Yh~*_xH*dXF|gws@5{qv2dXX0$|ocH9ogimb;llw;{QV z>JZr6!+&jgwc;zI;kmqgi`COm*>M9J?^-IZubRm2_@j6hMNr5PMRDO&5@GJwIaGuO ze3-;l)H$BjHQ;lo)HM+DMN@cGDGY_^SP8dvhUL|~$Gi-N+TntGqjc}2*m z&2$lmNqkU=^Vd;6(iwbC^kfMyP48AK5O7;YTdE~Kl|55iT%G`XrLZ`?$~aF20Gn~D z8VMxzk(ps(3`ivRt@ld zFACRO*KjW&2T^h}Sl^oaEGkIT1J$x#&zNe29T=?Fe~>XAs(IO^W#3mCu7428BW81| z5O9u4bcm&wouBu2CCK7XhI2j+9I=lk5Zz#34)?{i1B`VtIM0Zkk$W zp!xXC9YO!4I0q;|1cP^Di|(o~DJ&+wpRZuqQq_t2xmnR*zxshNQl?wH(qX(bUn zXoOXKD=e%tx1?+E&c4+K01G_KgW!*1K&+>y%d({_<#mD_8B9Gx*7*XKGlTQ3EUn53 zMkzAuIRo@|`DT~2Z)JI;8o$iGh48ln!R7elY^9U@^LI$}2D!Xl4{C;}%U~DR8y_M| z)?Kk&UHIk6Y7nr`D*?d+O2EitjGFg=WZob7Gqz&N>Vy@-b_&a;vY-sU5AN?F7~Dx3 z38qS77@%aS{48$@AHAljHAP>sxoqqGH&$4+dtT1YE#%^c1>Uquvl?>WC0+*9OhNP;TfRg zBIW~cZ*#mhoHCs9yPJdg77r|$i@%RmWwZ5t zlkrAuPS)O_Z@TNAl8M}zZZT;U=(|zhb3wXkPE@ZL8_i8ia$#{=y>F1g(~<;P4Z&|HQj!a~5~Y~sc^pP^KUm*N-C zw0{Z+T6z!z6U9vCMO6E*Z#L!V$rv~acZ}ahJ6C4IJSSiEkObK4Aoe?m{w)Ktn#fM6(>WROm_@(^C;_n|60s71NG-3ZDT-4Y&w5l2Ni*wfl%cWQIsF|wt zpb}StkV#0A@F|Mmv6T?T!^i^;I6(nnBxvX27*f<{EycGFkqf%;wn1& zllZ6Akpi!}`L`F;;OeCNK06^}L__N0VxI|d&e}w%*~9q#&6XnlljOE~g^^@#W+R^DX@MB=E0kfw>*-x@wok_m<7=rRTA z5Ah^H<>6zyHxC4Z-|aQ;JA~OH^L6ruz#J|_DPc7Gq>eE1D2Z(B)tbJOpF7wuBc$u@ zw&D%8tmAu@vO@=wk#kT%(@8mf(Pzc_+wiD38hL>-cV`=(PAD)ZnkajOUFYg}dz8L@ zvAJf%4nImtXP%pK<4evr1p|?pdyalI&+u|K$PEaH3a#Kb`sx-Fe_7=~e!+d}(NsJd z*h8*G8KJP@RLkhEj7VON1|Msl8{gid;Oy6RA;)Tj;t#4^F&@Pk`rB(2G=Xdzln49>XR($C>1NDSB!3F-d!UyF;t+@3-IYK2hoBU!bU#aSvN>G(8U}!BYA9 zm7nQD%A)E9WD85+KMM$EHXuY@DQ{4X%cK|*uoY`~l7e}0>!23*s-$iYLZVSX=)qf+ zJ4K5VtR^AchuLxCn-1`*y!^02SN+T8JCFhC1U6M<%{o|kTynETSq_x6n0L&&uq!w` z!j0Zv2SW;>^OPsYJwwrx!_++`IsgWSV`g1>?;LG*ja|e2Juw8s!v?BFDQZAKOC1TL zJ-&4C=0xH56jz?!Bk`ah2_%YB~t5uSONUU6KczL4%C&FhJ-G0zt2P45W$TE zDN-2^JUDKUFftDlwyasa@*~H8p!Xj)g|MPANs|eq9`PM*VqIT&h*`Dt;)=en+BJa&A+8_JpQz3{MKUPOKkB7buPX0BWfXMuurwG?Aj^ju)+Imv6D5$r9oh1XWQZ zM<%nJ7v=8i)>bA}Yr_k)tm6la?{_s{)W=XEev)+iKoZ_jyx3oRUoH`%q$;kLkS$Na zKelCxJ8_=2V}`bIaF1!M5&5iqVp6YKjMh2@T#;*TB>YjB9tYE`2Mk^Oh#L>ot=|`+#@?wkh0x>4W5dEq?In2VFPmL>^_*TNxcI57k;-? zHf^+@k#p(xkp$9!PsjX!T1RLFn~g_;jZE6aZKns+krFJ7q*Ik1l)@Eh%44Jln+=K| zHos?heqgTA>BAX9H5B|?V~P2p5WfDNiFURqn;Nz&Fd$s4v~7(b$=RD6kpb^=XZw>{ zq#LNKy_^U*N};{=))}SP)+WqCC<;5|+Q}fk71Flj2k}yJD=sJOE$dT6jGk9+0qje$lme3dz1Cc;sYE+i!4_->7h=^?m+s9;9xDR7@(r!TQjU<;jouBdc>x9H{Q4=qS#JZjGt>m8TD^t>-tYVn#G zMs{>+s>a^CkPRtbU%A`STbX{6h$tIwOp|e!bM3xUAh800b&uejZSGnG&3Kf;7Ul>F zQrY8-u?EV+9g9|c50#gNb{(LD!82;P&2CuZ$s;UCr2FFOgkia@wazfrE$MaSd-rWRF``ST`SXDhb#Rg(_ZD%AL?y%6C)Sc#A2ZeDLMa~r(X;9R<1k=RAXNoO!#ZZ zY#g8~3Ue5aJpB4Rqn)M#;6s)Sk8$qi?&I+9j0d{vL{&dPv|ze}g;T`dPCw0_qyyp}d!2orzCc*Z<=Csx zV=NjLIlWVW`Kb#Qu5Ggoj%2U{0Mv}GjMl)}({w#Q`aj#R6k^?Ak;9g(%tqr1s2x3= zg&+lSpIq3<6g-;-Wkw>-FZXrL=AiWBtNYBPFdy`u;`BH3$HH*iKWlorz-ddFmPeoZ zBbqX=K!AtmV!Wi{$B$gZM{-rxo8+ycw|{wwT#MxHD*I(-YqlW}f%vj3_~tm#RzFYYJ1gU+wz+JL#>6*p2@QhRVGYciBn{@SIQL72#S4>4+BKjO4S4>Hi@yCF}0-Pp^1^;#T zC|LN+C=}c}J4B{Sm*S;4Z;im!y+G|>sd{b&MW@k-CWH;Lt*~~!tiZZk!r`_(D*m8`X!I;+;BiGF@zSm@OLcLpoQf!c}S3S3zWDbOc4VAdjI zOg>>a0{|b53o_}nP3F)4LW(|^cs}UmWCDW^(Xrs4$|~u_ z%g)C5`dUXk&MRLK4HNrt#j&$+OW2ED)7=Y27~;#>-JHC)v(v;lX5Bhwg<_+LwiS>? z&)V~|(;TqVkg(5$vd?(OL;_sGvD={k;vKym{yKiWrXDiRuw(g4LR+bSoQ(qhO?PH) z%>@2S)@b*A3l7fTXC!=UYa*DkRiEbYc3k<$2&?u^c^YH%R5?K_->l=G@n+?@suAU| zpec=+A8W?O0UT$K-WxPk0EZfZ2H2i_zU&nZ4BS?Cea7UE2ivg?cnXRRCVDe5?Q^lB z+}eQiz2;VO^Eg9(o?=1i8u&B5-i9Zil82pE*xB>9$D+P$-m;#k)3(huX=U-JM}Q#Hm`+Khj9^Jgwe4lu%qRj-+`V08 zkaCIdo5cj6i=VCl8Ii=$#JMt1qqX;j{fhX?=c~E)ZD*`7%j>O`rDA&mCrWEr`O9;X z_=v>(l>Il4BfKyAH?WbTT&_2;h4d&YW~^l+*L4lPOQ%$J;Tr&v&F3eD=GM+UzfYxf z`DyBhyK%&Sy_(*d@p1B?1LUCmt#`UIk9#7W#1^W5=^CZ@gJDT;<@p*NNrm-xS#n&J z^AVR&z6?CgMa6ZttG>&3xA_JamuJW09r4oHF5^bJLg#|6OaU*x??Qb6Yeom@|J%&; zKe2lmSQ-CACu_#A{D<1Q_w)_!RsOTW6<&lZ6@kiL1l1%Q$kNIOH1wX=e6GE3G)_9c zz3ID)F(X$%WqqU3q^2hftNZBV{%D?P^{?HTrG4ut9U*ufdnWT0F4OhZA#rG6$mG#( zgJ_sUexN8b^pG|_ep46kr$e3ufjvuj4({5eG${hNBEQAPx%5HmXx*fAU*Vj^yEWOJ zsc(cJcEoC&xylh*!?LL$@<)$KGI6HLzUszO;&XF*sgDIw#n1YBmGh5l=o~+>TGj#)%#VirzHP zyW{0upkYk&``Csp04a5$x6(~(Q-0CxkTnqo`<0Eit8S1-?y*2|)lpxn;pfACgS3DC z+if4IfTTD~1vrk`MB|{l$CHAKpmW=b@#yVAa?B~)tk?xZFEQyHa%rf-i9kl&&wjg= z7^vh2$OLlZ`ajZZ$CWszBP!InhlSd$K`daDiW75>H*I?FD=KI5j8GNYRaAVoLvpq{ z74ofVeQ&3%ARw`T2dPrP1+A?g4#gqPF5HJBMS%+TT;wHWx#t|*u(T)AVh%md?;*|`F&9Y*b-CUj2WffDx0Wb-g^HMdS^ zzO`B4qOhO0(`+~5Tse-H`n8_>aZbRQ_S^_Q(KFcqc-2JqP3A5fUxQ4X(WO|3vM7TW zJ7g3Q8pmJuHd-~l1j z`zQtt!!5IQP^_Sxzra#)B(G9^*+0?ZH#AY>TydN?nb;TS%j#{uCg#x;vBFo=_nffv zl8H$Q$Pl*D!yfRBJ$ z4qAiTk9&p6h=1_5?99UDjhE**#+~2a1S%Lm1x_ioE&M7-O68#VOfxxaYwAS)2?J~| z3q=QsG*5_UOUt({AL|NbleoceT2y$WAZi z7yE#tT5-om5B4WkYV`CH<~}NIo^0ev;bKjllf>!aB(%W0x#y0CrjX_jnBxBmPxJWG zdD`( zS=7?JDtY9~0Um}iFy!`dc<@**u=&ZZS11gzy=~N3c7D6`n;gfzg^MwkK}{+NO5(2% zKhdZ=J`^qei~T!MEZBci`8$PS4u{`7shqw16`%4>2>a4?bT6L^X_bQD+(LUplCfo% zL%)@?Llb60--3jDX>9B|Cw(ltE=Y%UAj?odU!tgjDbDGN z<15X}hj$1^z2e+#;4h5l(H6=3*2M@m`=(7kFL4|>ralB5KckN zZ5YqwP>0rDUwet5D6!pAll5fN4V<4`X)pN@Q|#LtVF#=$iWD$~l5-dbo8!=M390SA z9sORuS9@GzH=M4~q1Db)aTFhsoP-`o&O$gpVQmSHUp5AAWAm`g(!!F7KI>48N!ZrN z_yZa;rz8AhqML0{ThHFcqizNZiI}0jNS2SOpCX2=1bVQl4x)^NWJi^-rxtL( z2?8lR(@iFnGUZ&>&67XgZZWKY66ZlUJc0_gLaZx=Z^VJL6N~!T-Taou>DYyWr&@Qn zlcU7}OHOV3+2c{AyPC_aQ~t99tGxLI@GEQSET9r5^ru!Pg^xMvWeH|Upg-U7X(%dr z6u+7*DCd|#cWIMNT^MjtO*thO`FP2974$M{n;24`;*q@E;i;mH6Xvq_A z6v4`P7M+3k564S+yu76S_$D9EYfiXa4(;)0^UiYB=NWc%Iwz(e2>Nj#6>NEP#ZH|+ zh{JrjY0Jg70ls|&Fyd%jVra|-75yX<@O=ipK#K38a>SWBRo`i%7MPnec7c49T27O%oN zg4JI@cN9kJisy&=FOHzhz<$PfHu*@UBbM@$F_v@=HngsZj zC<1tyafn;|+||OSc;B}TY?@35qd2OUy*Rd=3>7O0LQV+HZxV#pIyd3z5^v2R+iLpn zy7qI4ArLyOPYJHj{6LQaX{amh+u|u%jy#Wb%9p7VOf#m#Q`MoNmIEsP+R@27L&0hcyD)*L6*|?1V5bR*zFATPUI<7I+UOrmz$jTJW z#m;>3w9kr#b77TdxoB*~D31NALD1Lh8W0vOjqxlFtQK|Om-DXVubmRk*&q^~0!4R! z%2G)6I8{jgSrKv`b7P<dlNz8S+DA$EymBr=F##?C_AeKFmL zxu$Q!k7j$7Bo;_cbtnjT@!FNm7sv_a^5SIq$|dt!%vgso>1E?~H~;7ndBP1(3?6%C zl9icTNtfgUwc$IP)CjQxi%LLGdSDO5dtI*4NHYp**k>bxjB-Jr?_&_-j1T#teTBe4CgXG z=Qt4YQbwd=FdIZh1sUAquY<1T9;e+!Pf76^t&`Xk2mkSMZZ z-^LY}boVTMH*4`xbamQSCVa%ffdoz)L2+XoWM)0o+jJOhpny3%{qoH11j@@NOM#BR zhdona;id617k1S_Em2-i9S1E__HEtEZLJ*Xn^CJ~lscRVy&Cl~6QY_W8NybbX2vJA zBv5Ho0-aFKZzzJKQq88I>rata=(Fkk{8|Xda(S2CaM#2gH)S~SK$Ym93&~>$%o|;r zF%m^41-QnBGk1)AV00$1YuiX@y^%q~qYgMeFAZ!GdHvfR0((TUdB*uY&M9hu4O*M?gRnBmg1OEJ9te-dKb~X(&A>sBnV_`5WSiV#Wzc6 z5pYU)R05-f_PjH{PuQGbtb0%cI!0~l?d>=6n4V;zU0OG!3>PZp?rS6Ku9?{M%Rn~{ zD`(2PhY0$UX0FB#3IyIboBA`Cw9oU~CDzxO*H#JMeZDaT)_q))Wg0_x^(Gg*$Qk2s zqW7;7`-Rd616JUt=&;iwu=IxR7*nBHj@XZKyjIG!hX2XV!!V+n$7oNKCTa-@za$CJ z#R4S&m9~jB{S>udG~u)EaAGW$e^MglfbShaS-Mw|@?}^Aq3oVOkOLP7oNynFRj5@~ z-=FULt2S-u>O63mMIFE4w+wbc&rBS2P2?1K@Svar%pA_r^~@^4;-c4Cyb&M+-G27_ zrY`j6gw{GhmN~WJL0BU@z;!dWSH)e2p;B!?*ik$u(X!y~msANyuvZaYO&gpbLRL(Y zA&DYoA(XeoLB~8`hu`3J0Tgp{1f-&yS3|85tDMo8>SEVJXmasuA`-sPQT(hlAH6%{ zfA1>HAeot_hTh~&4|BM=orury*5jVbVrOvfGU*{{YB2caorek+9{>1Fn=>%3FYp#_ zW&G%%^Kyv5z~_h05H-nXH#(nBs?~OI%{7&jLI*8RvsaEoX*O`{0pzU1{KjAG2KPX? ztz8w|swH$qyP;t8keQ_L375u2$)lN)g)L20c^2oH<-h1#wg|ONnSy~*IR0R9YZK$K zxyi6Zb@V0AO$kSmtOw~nvw<*A1N7efrkj3DOmhqAL^bC;626!^4xd?fBF!E+*CK3p zq(G!~VM>K&?&Ev7o?ay+ah`2Qx6 z^TZOCZe)j)3hMrN1drld1eTrIp0G%QV`Aq%CloDKMk4!URJqFo(TGI3^c$_-oe@L3 z-FXgJzYgd6qe?R#8O9*B80X5qemzBdH!el)$45*2y8xj5D=>UmrOzApWnwnct^xhe zcXVpNcSBq#Qw5I5s!lE}Vi9(%?VssL!V+UqROwjDU2|hxOS*ewxb9vX+Ut`!HfWO{ zB=V7!{DY$16G-A*qE^_sW!&l#&B}n`Pc=ob+Kcz&6#*;c2*Hxl&X2>cYpBAYNq+a= zC}@5<67YmkHHq`S<7YK1Kz|~NT}5b*Y-#|blZZHr*W_5etS-^`J9bt#5Y3S8#CSK1 zXw8Xu{1tFC=;OGU zxZzhh8{VSgy&KxcD}FAlS8vUGJse*Oy*FQ=k6i}Xe2YkukoiRK&*K<<*TDLGp6JdW zXH7&_$P&|A>`!+jibSJqAZfRqJlae^v#TNd;3oi?sy5Fe7!w(dds zlnmFnwrTxy&(!qp_Lx=1gi2hGp7vd?W>wSDN6{5Tbn&4VT_&9$GxB9+s*A-=P>91B zu6DU5+WVpD+GylycveG{PX8D@ChJa!I-Fo`@7IS<440VOYYNKuyK(Ch2M0dN$CB@z z{2F4Vm5@--Vo)mnL=H&^%%`AF6Y+kjxLnqHm2udyLJ3*jyTX}imGjT{L*VRO+5#22 zLt~`iw$n-JOS{hS*ls&9VNcS9#Lko-6HK%T5YoZN*=9buthTz!WG;@?TD9U?$BDYC z8`w|8VK8+es?A&GLJZ(Ba^R$eXj z1Msa-Oah2mpH?R+Wefq=2;ZC@@@CmoJ|~om9<&=0PUl$nAranMQ&*=0kJh>YVPouI zpNkE+2K0umIvqJ98uX&Mw=V#ZG&Shp@TebU70tDWr31l(K$>^lywC-(M3&8bQx%}C z)R1~%s4#nh=*!DNZ#BR4PV$omT4d1FM9C@gZ8?cuCiZQ0xByubka`b0^iTx}87cE# zQqks)LyOfMsHE?(hHx5il)+(a@dElYhN5g4Fi5f`NP|9DGqus`(wGL~^7pqqpZvdo zt#%(s+g|#To%>s1{Pv?(>5xUFkFGB6n&yW~(@kDzI8*8-H}BD2E4K>R6y z<|5;#D5nohm}?Mnu-QKtBm$`d8y zR`kzFtai^+p`E*j^jazXe3rugta<4$fkfIrbG=KJ>kQ{iu>{+>XtA11tHfTr)J?u{ z3JI>8cRp#|!ZL7wXwszCt^0vCHky9x23q{U{bR&g9xyhxF5+NmB+|$YAsPo*wL}kTUU_AQ$zqz ze8$d#qABbqzSEP5k@WOTw3Hz+V+g>C0VQ!;Z2e>ApMcsZ_2zybMHyu)GR0*f&2&d$ z1l~bhlR*S@WsVIixl?_zV)XPJ0+9xI&&ebiG-;OSQ2^mwOAJzSz8l7+dck#3`fHzJ z1K72Nw$!Ho8M@^&7<*zrfQHeyD!i^jl`lAfQKU>KWx&ZVQThyE8oU6tDI6?@&6BcS z^cUA;Y8sWk??tDcOeOT6x#a2&STJpyK-T;``>?*<3)~_kSs`9@zwjA6NtgpPNZ%A5 zoGixnD%^)fDnAc`rStd{QBzZ6J*yI02L}{Aryw|yH2i68m5Ijog^pzF;_`WtPvV#u zJ#Xm#E-@Cz<3+}nsY1ToVKK;F%9-&~dfE_9y7oKqpXU_Re-S9AnX*)BgQ~mcd@Fij z;N;K2It(kH=v3|VcGUa8oiQZX`90$$e=Z$o-7P>uF95a$cI{wqH+5vbNS9$PZt97w z`KSl#V-Ob+qZj_Ui0q4)iO6-|DWuLnQU|1>9q9Uv{`{MqP?Yd89stT8La?3w_P(mx z-CkfC@He_%GCF_6jrw3?=@Zc6jmi_CXFndg|5rYs(9>l|IV(d1)v%xz7N}QVpP-C#aqR<~*YteVL`% znlbq2nH5=0eg^&n{apnLUw~3CUH>wYkH(l76(1jNU4Q-!OjjDT8)c6`KqG4F$+p$w z-)C2N-#h+Gb*Hq zx53~8uRHYU9X~ghY^mb#)5{Ld{_*Cn%k>ZybaxYmLucmHJ!u5q5!O)PH5#Y*W9#VK z`qAHitm%{LW0dW(X(4gKlz;1>*bMR)_b;K)ES(-Lj$^x6JzvR6Z@uy}7l>HTiy(@3 z5ScT!tA@1;Lcxr2pJz7dAzkb&7^#r{8gmSwdK|#(L7AFI;$Z>Y7t>km8ZR?}#y9-* z)`#FC$H)K0?xU8EqyOTZH-e)4usHmB+y3$HX#M$5zvBN2K*`9#!2W-~)H#|Oc8Bap zzPow`(^6CX)rcY&`g2NlMwn+h`e@J~T!5^P`K{-|;WQp39bS*OWsxe$;u;*>5D53A zRq9X60(IYQNL3);!UYtzX zU8P|y&VN*3eO-)W%K*{6N>6;xE=~w^?Hox8>%6*_=JX_gev?_r(TwlXOzqb|kvE|- z(&-=g%8!#F{;sF8Cooo~&39hJ$tzob`~w9$;F3hVOwM~LlS_PB_+I=b` z0d7u}AtIQ`hw_Tpc6n9d>s(E96Z5s)u33c5ax=5%<+uJ6AL!G->p7lf8l6iND0{(- zsPgOd@o6GP6%TFl(nbrcrv7l|xTY-zLr!J0a`hMI?owD;R62TG3^Jp0;z?O^=mA(OrG=>>H0_JE@fnhK-H7z{pl|?fb1!b&{ zKb?5|qvg*&IVK7&>{tjKDQ9PBx6oXpmje@vF7+_R$I@Wbcmg69rMMRt_U^j)gvbt> z-2%dxr?%qV^&nT|2hs!R&6I6J)n_QwoQfiNdg`212U~piW=Aq{P&)C+lqz73;Vz`z z^^WC{+!tCG7`RmdC%goD(@Zjff)uGYym##uby(ElZ-Jfxo1F&K2ATT71?L=~D z=*C_A6C^h=>{*tB`N~9Ku*&Q&W>tc%X|XUhJ)mmTDqq!?vAlo^8)6Dew(ZNCWEbYs zZd5Jdu$;i+{0`ON8%VQp(EzQy7=^!t{TB!l^*NWN!I&ehzwRgnAn<{C0J8`LS`Q=3%wt_6A)nH3cEu_EQ-&MebsCYF zId0RaRYoUk%%6B@G^}V8!LJnR|JJl*vY(k(mX;Z;eCpCO0R4*=j*}gIVL}36MrGVf&9>@l2oEQt02i z0H^NzxRvg@vdnGG2X_{vh}Gc@mQe3a%qn;pQ@$FXfgnW-?cd1z5xIf7SI!3>K?oiF z$$wOMHGWz;sGwr?&mj5?J8W6H13{PyLN~!4!B0)&5P*1sTFI7y~RBI1DN)r z&gIS@*~*Fy;yDTcsO7ezv}@0uLEHcleK*u`gBR0617t#4hQAOfvrQvRZ^C)bt8b@* zhZYM5_l%*t(SB4fgfY7af-{VuZ9w-BSL}+w0xn)4-Hj0bT=CK3i6zBY8<>$hDa?MbcxWs}93mcu##_tQn$0V-8Tf zwk-Q+AQuUEK6F(K8;rnUIsJL7sLuS_)r}QzKr)KCGp_Q(ML#bp<43f%+c~y9o8v$V z`Pq96kl=`(@Cn&7-%!H!slgu4r>QK!aCf5_By&HbkM*!#`pg`QD zWm|hh(wKzXzl^P<*Tl%(n&J4tm1^0zdaMYUAsRGtmpuf1rzfBrlGTowj5x(2+eI{x z!;J>PsJq5JX~0`&#=rmw7an$^;qZ*I$!J?jiUZ7l`p!NLfM#D>1YezV@|d*k&#N3M?ncdS-j-@(ZN0A6MIDoO0I zIRIE!{i{kyRjlWYXO+~mjaJmvqsl{#SCdN;g}?FAkYb+1qfQ~g=!D2LiNI+Z|AQ8m z!q4$fFaYCp4|SBT@{@4DCKs){s+42JEJSb_#PPZuFN(b;#F%CmEov50*nG7KyHMrmno|T;i zJGtB=$10(MD0UpsIetqncpvA9kEA^cP8A_?>N}V>OZZR3=b3g*r1Y@rH!Q}G`A~z`*{h6^qEXCNKMJh! zs0E*wZUXi8MWiJzfK3N&d9mnnj}@{Z?D8^F98WOJNy*y zs6BR&GbMQ@G-hqf;o`ttE)ggZ-N_Z#PYFJ@iDK6Px#MT61iNCXWGIx*oTq@IZDm&X ztOi8`c7I&vs_qQ~2(=Rr?F!ba)b>1Z?tDO`yfYsLMJaGL%Fh!*@IDy#vmrzZlCgKi z>Pe>IqTxwt`bPwDQM)6#z4$~?>VmceEzfMm2=cn4p?yTfLU2f3_UTcJhJ?>ij=9yJ zo7hJLb$S;R21$FyTgS5-S*u0lNqB+-fsw0CY#jh1F*UgcVcLg*U7Cv2Hz7bTq6oY) zQ|Ti(ZL$#ulN+&g#+=y)@u)A7=Dr%zH&qGMkdH-~oeZ~?)A zkBK3k1{BJl=sKL`n%PejGiig8!h9yj(-_~Qa%kkAy;w0*`CHk)GIP3NdkTb5;^OPu>N1oyWj!5u%dzy{^ILP)ncU+yQf)fB8*7Zx(NS zOCJKs`C4@y5{jZu{Idd^bVixQK+g}4X%YVW&nJiCqk30q+etm&^`d_S!!Jsq{+O;2 zJ)O*%(_~3k>L5aDWx)2VL3^Qgp?$no{9NK|HUAB@`(+2}AY}Cc7WQsu>Bl11Z|~53 z^EwsReL%QWqWTEvU<)B$?tdR&pZmiAtiZ?q@16Gem9|SpafVONuJ@PSZ;)NyT!a5N ztTWO7SA1qh7DoF2JFL(A`PHtEU+32SYS;f@Sd~!nd@zbPuIoENAXEo{h@a-SR&5TB zCl)1^t@`2hN>cK8x;jC7%kzk%O%Q4j_k7IJ?ugt)xpizDYy3ewzH#3Ex^MsZ7Hf$r zs*j%BzIQ=K?@|vl>Ez1&K}}x&-W}_^asCs=v3Ibr+xaD6g@b)rz|j2h6*oaEE0|*( z?x(*e1VlzY_}8G9uQ&s0=lw#2{u8-qTVNnKfG2%ANI^m!WpLo}5iEguy5$NlUI6v8 z!YZ$b-2zrNX|I*9obc?zweCTmo(EXvI%DLmQB6Z1mkuBWRA)Kw&y=@_J+Qb4y*e0< zFfgj$&gJtK!4lWp_17`|ztQtjVHZ)8>CT8jYA^?ta-)N%Q?bo$Ya3AZoGQ@%N5={@ zJ@KTRe?$~f1bli}PAu1qLHZX6<5pQis)*jv8*v&dw5_4i6xal>S}r}VUrDy`CLzFg zCw3rI{jaQL66y|qLEkkpbXS1Il7ah*E$os8!P0>YT%7f;q%qwHt0&V|Pe|W+u!0Eg zV)12NN&+FBAfisFpg-*x1J$oWYO};NN{yy_plC__YKB{tzU6W+rGjzOgmXE(`+{JY z`!PFf1$A;qA@ntwq2O4tIjKkO8Mp2AqOs5z#FTL9COIQcWMJ~K&;W{EkMeG%JZiHT zs)6~0h$(gmVorr3_7yUEPh`edf!;jNpy^D*qNqunA*ZDo9CqkjnI6P2b zQG{#J;3t*+ufh8g%~9l+Tn153*PMV*ES1<|h5~6&FMWmN=3J0>-%>7^nc%X*03dD4 zDxxXJc3+cv0OznmdX>B9Oo3VX{y5h$A(UT2BaACl0j3L+8U4{zINZ?o5p=3RX zIxoPT;Is*r`%{%60-H~(lJR;}UIuaEje^{UVBHQb62ofXUE4nOPwUph5;YI>GOdF* z)bgeUQAxXy5^hZqaJn}`_zCc~nqec<{JZ@*)dJOoNLF<6fH4)u9J#4=+uN9I#qN@a z%ZK5`o`>QyE|5}teprQ~mQXKvQBd$kT*Xg28@o(6jc_23Thv0A z?m&SKCk`eVfp%m}OlW>{Vt#a`MGl0fa6}H2q2HRD?qT=tMT%=!?IG}{+(VP%?nlUeF38nV? zJGnBunU?JkQ2Uh(_!r|t132#6cLT#QojfcrOt_dFRtn-|?`zmXLSM zJSs=*7KFE`FyU_~c^9+SG;&f;TM+gEGdXwC+mH5dq>!at=Svaa6VbP!FXyPi+dJ9P zGp4=0z^C`|?lvX;r(Sw(iRlfo2L7CI5h%*QB%)a;kwCL`I|*PV$e^acYRy-L#5&~^ zB!eXPjSC)OBw8Y?^1ohHO>P4KQvC;G40}f@Tn#Y4y%y00bnvTBWbO<`GD(u~D6~9k z>Dgahe2PX@Mr~^ebxe3fM5=kw5aTij4H+o;|VV#%66+sdwIJIhl{qyFz57^E3fhg3X z2=Vs%CWJ(4OAAzf3e_Hmn%wq&usfSy6l$D7aJ|kk9jc5K%liiS{p5Xhqa&^p<1?!w zxb~Z9NEm*VJ^45VIy!h-k5WTU7i4a{ocOUrVA!FJY3CijnRR>so zqsGfd!=4JK8T?|oAf#M7JCkhs;bAoY)n4Zvj&>R}_-gXCGzPq`(X|!K?kOhm$y!YR zcHnCjRThn%^u~9p8@VmH04yITWGqMQVECjyO9w3KM<}?~MW_i>;uZ?VQE=%S>F7m` zShlWg1*Yc+6{U`eQzuNeL||V+k!eSn6U<)j>^*9Lz#SnAS^pA@6y=|MP z0Vu04hW*vSo`SM1Ah7Em0FV>{y-AW65a=t4aFo?HR8#MS**dpHum_EcO16+qLfuGA zR7l$J$b!^?ci?s>ta|P)7%7{+%$S}4QdESx4NV{VnNgC6J7+%B94J z+J>jJ-dyD1hOh)HZkBv@U`dePoE0kznQyBI2`}d*YrMqD?McO|vy1(m+i7MDUF)<% zxw)RabFv=jx57C!rESyh;Ydi2daxJ8L}j;`YB|%XIy3_XL{^V!Cch_ zRHA5bz)9SQp1@s*|S<}vDQf3qolpgWAh~t59mhX zvZeIp_Z}812UsM+9EHZG1fSI0_+%y{_~5ZY=EH3O?k&R;F*JB-Qt&4_<}DlZvE00Z z29wW4-JC^KvT()NwG}S6d<{8F`!W95Alq9=EVs~4>L)=0TXBubr$xYi_irE6;p=L6 zkh#%V+_$_q{^lOOu`Grik`vf92}dhtnAa{;v~x~@czkUW>7q=c@y3G+FtnvL?VOU) zRzaUwcy;qHS`}_tYzBZjaU7Plcvj%zz|Z=eutmgOG%6xLxO6htJGuA76H6NmM*LL` zvZRgv#5cfo#ua-dwa;cu&&y2?osb%Ng%8io?`PW&(Don5^nZ$n|CL#Tk%8@hY(v(l zOV}NbqyB0w&sI?MRh=jr$9rKIlbq=#Xfy5&{Mo~hR8k?7ibIPDKXy-TND^7MZvcS+ z4QuLl9(qbFA3sQUgzuu*NY~T5l|?!#WV7&Y+4A~Gv)C0)lx=VD*c=)nlvGT!KEC>b z@?xL4JAJWAEijAqS_@V5Nj5KA z=iBb*TI>36i%Ub{HH_`JT>`EhqdC~nB2_Z_UKx!tMBuy+=y8OQP2wi^q#!0E>%)9V z9fXKD;9)yAuA2y=*p9_X`fV}~dm(0HL=!+o&)&8dld&x1sbIKWx~6B&=2w^dTk6E$ zjQP`?u(nplNnAN%n*B#%4RxEqa?5d_Pu*fpt!ZUJIdQIgqMQ3_N!US1L&i))!5Io~ zq#z%sp!0(%-7iw`k}W}64IZ^BnSREP^lGGeO>fYPLMsp2Fu7QMgw6h6EZ!xQRJ@$h zVw6v>p4~Wqrx1-vIr|GPWYC=1y=owN>(Q!lN&N{mRtK5Ob!~=Vx{uKT2@FVADk!1Q zsLZaT7EV{BkQ;XJmf!Y9SLxHFETFJt^_SkgqjCww>>us5|*dlEvi zdbmozTiDT*vY57^$`fLs$_xlENEoA(J-MhLkSF0R+m2ur7^1JT4hjV1K!_%#_Iu^F z)z+29sk<(V^LN zit4)4Bj_=i*(d_L0e#Pmu4MYK%=7tu7|7zy>qUzh$;?4iJ?OivSrRzH5qyRek8n2& z&cR(zQzb9$gckLXnOYf%$v@kpm4X(*)Abo2PDxU`{qN5)Rb zJq;&=D6qNwe4`XsxwVu|n9$4Lf!*F6M1Fnj?%S<)vp(~=7@=L*AnSe)y}0*I>9fNH zr#bLzx|F0p57z0J=5=M_hC}~o*81-6dax>cbC=82-*0{ke&2nsr^IpJH77TWa~U1T zchg#cH|pfvyAMxA2*Kd@3DuYU&wXY;hw%?Yw%JT%4mPc6p&B){A>bluI{=s&HiiMAyAH1BLz-ga&eh7r2IX*1an+ z#IX9VW`DftdxMT%hS%a+C|T?SXK7xV=wsN)MD;Q7MdbqvB=iT(iPuqj`+Ioqcz|En zMaAW6(M|eE1nSVK?{JmLahR1*06~mM888h9Q=86rPzxsBI#1X_dkak|Y~Qo}fjO!U zrWC+Bk=cbx4=JYdM6iQH3SDZxNT?sF;30mp_u*IT)?=h0VjH`AU`y-RVxA(pC+M~9 zIl2&Uv<7i0o~g*|jtB2lTPzysld*2R0~FwUCHp~iWYl`J9?blPy~dfe<5vTXnBk*- z?CDl%@VhQwZiB}_DhrNM&q9*O1jnGqvSyzZ1KIJ^&VXpmPbj;pJd$_u6Q4>JN3`7M zA#RjU2ceH3hYB!l_2lsd9kKERy&?18u?2N7LFWjFc(L=7t4G~RC^af003rj!>X66L z-HIJ6&2Vv5W5?;g?!3o4-<%f1&50}7A=VOcf)oGXo_5ocJe=Sn;nL-5MO@9n>pz8E zTcUv!&scw5N^RzZdDi46GN*qN#85|qnTz&X)_yJp#_A>LS{8*XH^`6ckz3?WMD5VPs*}AOd2&vaW@2%1ix;4Ey{HU*nHcU% zU=RIOxy`w16@0M%NO&=b9!8wifDBW|))(!7U2kaPA%U4zw+H^xFctj}7Kl8vEdF^; zDCg5Yku&b-lRfHh!HHX&3`Db~f8ZA~zzW4ET|4tQSbAc7z)axwta$++tF>9!q~)Lv zLdXRSn;EI;N95K;#U=ak4jFl}{O4*^w3mEA}nV!ZD@LiX^@d(HDly;J4n5uK-w z|3b@4buyA7ml{94PEdaCAP*k(dC5TFSWdSCEejHH*E5#9Y@BjO%YI?$-%^kWnf8&V7`a~>}`}Hu787G?r*9bTAiui5|^ZLfgWrPz@=5H`cSS3@)rJK1vf7irM z_`3XrE5$|Nb`KWlwoR*&Bi)|0I`$DpZCnXuR^GTgdJPon+Na7;iaa zr3~Y%jjH&mS?-r4*007iBRjAXrK)0_U;BA$@0$waKDSlh>&cpYXy3OFvy-u_b$bo|V|=d81qx5*+&2e5+1F zEwg_mJz1(r_+fSY?BkO$65efgy&JbDmXQ#pX2asS!1R@yON!`0-*J^!cUmbT1~a_m;HKNeY@@4!SkW?Qq?jm5zaaRu4r`tmYHAo2| z>WUzdA&$x}vtN+lAp`9EN8M?77kiCe*ZxTfxZ(WMajMT4$42SXl-Jk9)cX@@naCoj zXq6M+}8H)l+%|172>`P#a1DZr*=Zobs+YPz(W9vv-X2%Wgi)cA)Bny=PSK9lZXP3XyP4t z=8(zr=puBagE0cWmAf~2C?aj+;cB&$s4m(2m9b&4RH`g^I^+*IBL$CiXve;oCq_4tG)ioj zNv#mO6uGaWI@il~uXBEt?1Dyb2AN?^Fw{UpYS=L&+xlJ|gB8A2tS0tyP1U=>%($?u zZ?{#ktS}m*-ONO_(CE%Fxq(N4!<3%+)+b#EUaacEtGAeE$qF zw(79ku1*#(JXIwM{;TIb^!{(>n$9Y0@{VU#DS`TiK@YDbx{3d%R?`e(g4cya^@2Iw zb{adu8wz^1#an;)$mt$9sQ6_~oVI=*O1v4DxD>Kzc;6(71uJpX2REKCwcbLV^x@<4${ z{(3M%z(y`p8X6|$eVB3A>}j9@>IS=9h6GAgAOQvZwN3tXESL#K3Q_&Y_`{4C+KDJ% z#`PXs;wnI?8M(nxCoyF^CYexW^Am*@lPz0_3j*|@){H`7)+ zm*=M(fek>mY5qAp*wp!+2nX3x9B%lhFZq1|k36zjY^DeVg)YZ2Cl1%IFF*D6>HFrKNW{hM!zSFJH=K9Hb(xj_M&~*}wgo7q zyxLj%UvSiU&bgaJO8DFGJY2R$YfH*nL0pGgAXmz#-4OZRZN%D?(vUwt{utOibrwGc z+FtFgj0{U9PzpitC?5kd@Dk7Zd9dbY?wVnI0bX-|!*XGPe^2tqt>2j(x>A?9!lb=; z;dQV-8ieEZ%76C0k<~Z8pbW{}lUbVQiIAL>n&7Uz<1S;&4%(ro>Wf0!o^_!cp1N;q z#UR^0+_RaRGT!QA$VbbMSt(A?AovdO05}=~7}O6u_oYcG-Aet8hje%L_hM#rrCk2h z;=3=2UDF;Q^QHwTtQA1RoB15)%>wWVIo;$T=*h9P(2$XqT?Ac%SK9Pyacp@6cP0D0 zZKb6pJ?fj!Z{0!iF9+KK>IaO!(L6}O3jFwk@uv;&qXtWn%R+~V+pil#+1}na9HTkl z@BKC6I~YjniP8q-j=}J6%-n~Hau9Ao5Lu?lUh!BG9wW&b%@}k?-_!4IGokbL1FVO> zpLW*mdO~k;7Az41B63s6o>kLZBnC=<$C@0oAE{WCdIyJX4#8u#kJ%}Y&JOoR6{Y-P z2Z@@ZjFx^&fDX6Cm`9VQFgVnspUgb5c`_hGe<#A%i?se`EDfT`EX>C%67e!(@KQ5r|M$53;8|42tIn47lQ;?F*Pg)MYJ zCCox90)Xqwl1vJOGm=H~=AWrYfNUmM8KJoOV-LHx9jGYVYZH=Pk;%1}6;6Ho+j(3q zQhRwD$DV1MjI@*6`|TfZt}lmVJxUVVq{lbUzGaa)j1C#swwH7BVPhA}9s8zs(Gk-h zSw5Mi^I^SR^B&BwK3cTVQQuXpv6}f(Lr>)0KE^+4E$S7DiI0i1bhgm+U8)qv**I}9D{rfz- z!{~@pczmdU$D~RQxllL&H`Hc=H|fN)&>V`e@MfN<0I||76wcY_+qmrI=|L^P-#A&b z1OgRgXy8I2uiqi7+w`j9DEZe7A;>R0u#v~HWeIURIb{{M@jK1+^K>tPwrKfPHi&7u z%!`XVz-zlILtrjwe^ZBI_PokBQiTByPfb0q=8)wm1OGJ+h{>bLH0rhAVX~=Yn`&)& zgEO0OTJF^-r_Jw`KK=z1t&k{;T-`8D-VQo5T6UIs@wXae+~5vcx#y*$<{ow$6xtCC zwJQ&yINUPw;M+2$tc}$Yn0@-7#p+wmpc>&lO@ozfm&bI7g(k4 z(1V;+IC%KkmbdB39Ty*3AMjHXT++3=wDk7%)rvEXhPa#L(kIi{D#dWlV!$-^>p=g) z4_}R?|03=Rn(H~2eWK9!I&vgSGm+bRPBl<#4wg&bUjFn3Ke^v?aT#t2LN7=m-`si3 z3oe~|Kh>)vsA(^;s(`dJF+QB?G+dUJW!?@)fSE%7ik%Xa6N<@{nO02~MpVo#8f~|F zJ59I*=ll&b_EBN{&2^+`&A`ypx4p*FOI(EBWm3IEyOIpS1guiOgKjJkP$Sp zaqUDHF{}v02Clj4gn{?2Ur3SWlP726WDk`X5bLNsRGk#l2p5Nlf(V4KPD5YG>1U9P z>}O9kKi~@(*RT3_LK@KWh$WU?qFuiFyB( z@8Cv!@M9szeb^Fm{=283ta#z9*J9vQp*af;5LX%?bzHsC37j_|V$LG)?Q!#K>OBOB zE(oVE?0pUok#IR$LOLphOA5p}&Cg)+hCiCDLX7@G@!Rt$boq^joYsxCCNe*cP9>MF z^H0nw;!uGp1S6)Hg){pQDY?EvC2~qQp-Fb7?NZ^2o><1yd7Re}KMq$F7<+S9e;D9xOXX<(7tw9`6vGOjReO@Fp zjeN{Ai6iJv#0=amijuGA1dQ%S(g)cN0h!~RJ_B_i;W#Cphv=JaL;tq|H&QWd>$n8z` z`AoqjTCpuk?`-W&QW*C(uMBqV-dKPO<#+QO1Z)mK-7vISIP_YQO{!J@tl*rntX+=h z{@Q_IGA*_wC7VE_?2bz6j!;qFAUbp4Sxx_Zb7=wJ*2^dOfmrQV|Lwcy58}Fk zE(Lq$wsrBj_BpAM21ABL2Ev~kvd+t~#V@=JUBfO(0gq7RAt_&n0{$xLG3?5fvw#o< zEV&+2fXGTw0e25;%nJrKyl1?;WGVqs;U!oo;~qb?nlV*|H9AGA4Gd=lt?x-2cu%v4 z6%dXgwb0W!3bdg9CC^-h_mkx3SDq~JPDYJ*9B)7vZ#NV9F)w<9JcJgUGUyr&?o&W^UT6@03GFlxmtpl0aP5fL$`jJ)%AZbN$ls#N_;0mh9`y$+dU7bxUR}Hq>>NG>SqaX;QVWn!>SBZ| zuJOxAhG;?xyA9sHZOf}7pN3$66BPi#dj zLaJ_O*pLLMJSLX=5FsG%CaJ1VwFzsv%CamZw;A*L!@b;$TIOFtQJ7bZZr;C3*MphP z%^WQ@reqC*FS#)W=fCdsA#hyP2n9G{w8A$!Wo>B5#d+8w0N{lx)IFv!h*WtiY8Q+Q zYoCZ)cTh=C5b0t9q)(SsT=l{0p=L0O>2&{eNeG`}mq|~ZWJJV2Gi*N8oL%L4l5;rn z?OU|_c;;QX-Wttn6u~OVQ<{LRUt@?x>XEmsR_lC{S_~_dLQU%f^LiReW9)F###dns z3?N)MEH>?D13+$s+)A%-8eu$Jr~MV%<(sHxo<}hN;FN6u1I=^N@LQGOU8%m+u<$xW zqEdr+RD`XCQszSM(m+h}AP3Atl->Dgs3ZGdjJ;ELrqLE|8&quDwr$(CZ9A#hwrv|< zY$p{b727s_yJIv@vc}e8<{j->jYLuI?F4NV;W?O2R6^E z-mcW<;?aaKylNJwz?;I>t}ZMVAoVn@9;J#S!JEZ*N#`NEui1ha5Oev73WD%0zAME@ zPF*Hy!vjv^%dIU(^>-y9Gc^lKYnzsT=F(t&v+aDiP}+RB@3i;PS1*U&)J#D6wnbJE zQsgaZA;mkjIr?!9z#$4#c`K<(m69D@L_)m-f16j20PtZ?jrRGz%G+iP@Ip zUKr&gis?{j!!M={WYtr$p!r#HE&3%XI8Fx4j1-pBEpsb>9+ac~gcuyHoLI2odeP7D z`5LZ}1JGdsspfQ1N2%;50~{Sp zF3(VRRX*-mJ`ZHi=g2B*(s^GfHsM)RpEAKW&Km?juMI~}!EJxqWa$0Cw^XKJr%RD6L z8odyXXd6PwR4sEziy=F7ga!JClMWIdxmiaalhv$g=3ijP#5I4(YB2a~IE0~+$<|-S z{%+j_d?1XxJp9+!$p7YCVBuu{e*=lRS~~w&a{t#OJ+EVCSd%DuzJgBIHbX8MWuLWW zg+thkfE~?(uAYV~J-hVNdm=2ILZ=X9j4!Jk&Wn+EqsuukCxkqFoBpd4^1db}ig^t$ zsE_~Gi$OGDWHB>+aQF!!RgkE-88+{dK&TY11HXVT#yE4N^ID7z!TXH5G!{RrN%h%< z`ms~WFCDOO=%P0%e{kZ$!SJ4AAv4)NB(2vd6)gYt2;QZWKmmN}oIJ1lmi2v(oRU4O zc{YZ4zIt5mk}orosChiUe-C;5b9k?qvOk~?mE3@@{(O0nmUU`0o`Hpi<+)A6w~JaGUFJ9Hc$UXM+XGv?XcI?2NkHPGbWL3k{WL=&012 zxiLm~;$@E5V#%;tDd?9B=Pdd%SpFZf1UG%Nyy>W7DQPPo-==*Z^x5K_E%^fHccxvb zEG01u!^mG=N3fV?*9qo^MseZ@y8#}IQ?+|eUh}ovv8U?=opAo-(K3Qfk;ouLK|k4Ambw`kq6=H zh+9t6oSe^j|NKs;Jn9ZuIDY{pP`Vl|yP-{QJs6GBt0^uND8YjJ!Hr|K zpU^TFaszg6pbvh#ySs{LG$Yzse(L#yIj8$6o{H`Ptvc=0@UpNYkp1n5^jxFZqN!o> zqzdPK6xG%g)0A^VMI^+Z3;5<_y-r#vU6G2rn^?@k{4A`pkui8ZM^nnt{))>+?dOc! z*v&(&YqVDI9wFDlHnU$eSb-PQXtl^HNvcLC3!*?nB0G?+)H<)$0!7VI4*w`H@Q(3eb ziLm!1_{U&GOS6>@)N=O?i-M25kFylB%D6)9JPU&UN>Oc3#gRMo3&Fs1U<)yhA_Gax z;W91n1f`0|+vQg7p@Q~vmuEm*2;Nk-T3M@%(Gj-5omQyVjfYGNA4-FCuH&(m^jA`B%E5$t=+C^fd^br=s7$Vz&KF#hVWP1vt$cw9dXDN zvf}mu917FE7E4jPSfst|yE*AzL40au$K|ASLWmA*C>cu%Zy8oE>}Mn|xc`O!a1vpu z^zZanc|%8R`3z4r{BVJLXnjMrIxQ6-@KPA)pKU=n50XP^B&s7ERu6D8s#?hRK9YEF zM^jeP+UK^Xpv8ONKSi)23ZYwdz*hskSjUY{edyiD<3luF#%Mb#j$b4>nV_sMnt(}K zsJB&h?~eX0*mGGG9jJlRRx2HRxmFT;R@GLO^6)XYPeAb6p8WMHNOF>kWN624)Ek1J z{9s8mt6S`GkR_D)G;=A{@m(Mo>d7)M9A9Yv-S1TaHFPV|NNK{~x0eo&uV1zO>B2-O z35zcK8`S-snwt}gOFNUD3*m&~p(}OHVqlMXr}wWsbz>Qr#C}b%qf3B)%`mM?QNmP% z?3V*Ghjy=kDdNaTJq3~2)5|7JA&^Z!_*O*?m>VGhM?rbpQt?GE9R@oBmV#+g(w%Mh zN}A~*7qnA&@H+6~Ix?gGuU#Abjr0(AZ_itg_V-X~D@^%oZeIKO&ghJzFojnCI{7Qh zx0qm*+03r5f28WGH92|F7jxzsX+-itWV6 zd?S|#dxOSxKW@OsANREhxRCLVjNrks7oF&FQNyjn%)7;xpZAEBx4$3N9l(@|g4vV5 zwmuOB_2(w7{7Gz0``OKkaxUHix<78=xqKhK53(u`W2TGGI?=+f7q&1-;qI4s`wA%! zF(H;u$0p=7eB}%q9$=Qn;PP#Po%B5w>=~JWGOEf9V=^yTpA(L;VMi^Jq zT8nkbU@E||tGZw&zBQ-Kfa4}s?{sEjpg(#wI>f7PvnaOhURN!DQe&T?b(;PRknC5g z!YeeeauGA-%qNH2#2eu!9daif{zR5k5@u}jPuPdqRgf;D#U;6-BXF=JByB3RONu_3 z?pvD^K62@gTIu^;&uHU;%F`{H$+Tv{K~r2-RzGb>DMkcW)AE}2$ONI=E^LAgz!Y|8 zjX0drpWAYUYk=K->d018hi)3?J5fHeiT&AC!)l7jbyF-tVlRpvTtmP9;Lo5E4!8K z>G5orVjI&E%V*wH)zM-tr0&LS`iUI7I5GZNA8Di;?ao8PIr7}$=>1#G+8?JCOl~g! zZ8F&t94x`JQ)eQ_ZmPa&R9S=dcWd2AXelt?sHLFmfhdc9Oa{@=t1OkDpF1Y5 zGpH|HJ-v)AzvM4Vj}}ElFCQ3@J)|xbNvg+x{D|kr9eK5Uc^9|FJ&rw%Vxst+Z?sMp zHQr=B)yMy6Vr51w0a@`9nVgYxkjIIE2lPvJrj8Z6(d-1sgSbyZPDuFZT(>u}#_nK5 znHeWiZ+o7;qeLW?D|z$>B!F20gqCyV%>d;Hq@0YkysCdJ6Uk*`IKQiT>6}xErMwP? zypt78R0Rt$&;mzAbm=Q zncybTf7BjB`F(g?(|em9TN%cjHQ>|QVAG{2u_TTfOsy(KYqYTL%p4GoO0mMpYF!d1 zv}}q4i<+qzsb370lj^K21*HeIJ@7B;j*j-aw+o1>u<2|mW`NPim%72p+=5gU18|wZ zE!!Tdd4+f#YsgU`cQp_HD1?^+W|v`eTns$?`1I57Qs1)cAW8^!DsO);TB$bYxB=>` zom+-tBc{!27fz)^us?#@O>o|SiA`Wi!{mmKLiU%o5?>8G*hUYpA)&bhd9lA5q(81m zQ@({i$}?}X3k@Pc9KR4s$J`=TQ9-Zu){JHe1t@#EavDV7TECDZ|!ZdIYc9pGO2;WoHS;H25C< zo>~-8uSX;B1Q;!`1CPkHM+xdT`IoPtTdxZ}X2fubZ!SPayCuf1+{vOpSc)P^;Saxt zAO&Ozk@0wi5jRzHU21v+v{8C_HiV1djD^A6lo)>zdX4D>M)W=IZ_z=iic6B z6eB-qMzkVHe`wNPxNZ&A{22QlUnx%6Leb zOeU15qRmA91s*&tDyP9czULX1Gr3mj_zv?GxWLe1?^70?HWX^+(n0c_ba(JV&$X)Q zJ=6XPad7(44)>&ya$r{;dia-}`N>QayX?pnc#_kH1{Aq>KPhrDc#5YZ8pRKrIIptk z-c`(r(k#GACqh05dTiuZE~!h%bx&!<#_ox9)&@0@JxQkxerk1<)*!p_UY`s1L%V$;ameWH~i`BpB*in&u zK358t0g4XGmKGsQ+pow@;1BvBl*M@zvq>mM;CE+be_Vcx={$yX5Crt~DU zJYcnUR%B%)^#4@Xf((eoYhoa(Rp1dxk%B`d^Yj;huRuuA@N=Irzk(l^ovTT_NC?>L zz&08`>h-@#(Pj0ieDMy0U6I-!(kv>8;w!P|#{^zx#@NW1wFsB}SkVUqWhinNRO9Oe(_7u4`Z(>fSL?!T5@S^N8)wVob1PDel^`!b%l22 zdTnuy9I#+g&{IwU_Z)ZP>v>8Q6F@an@?R5Xv2J@LqhqRW#GUB;10qp=bnS^07PPE} zsXlaS1eekss!r|W*2af7%Q*?ObMc9{^O%i?vRrM{rF$!s6RyfX_akhBSw*vRJTWeW zL~mspU8gkgZ8Ra;b+|^i(F$hMVCdFElNk5v2`CQ#)yvTF>salNOqp$)ZQ^JPo5P77 zjEUyC705&$t$*?)RbIl~y$}4>>ZG-vN~VY+CnRGg0N`Nc>gUd1EBd(bntIS;*bn)K zN*8u+{}O|lUunbkBS3r|K5VXg-yIDlE}oN`hnJSvJn9X)fWy7Ch{v-$mPhh+UbDZ$ zIsv`zAIk?VtqJ0ZP9Qvc!DA?Hv^=cZCI)PcE5Bl-AIWxwO2((k6KBdNh0oF6=Du|~ z0^C1#eLgCw!uLRH<%ub<1bh#_)rerk!p@-M|A4q^j=E`na{pll=En3SlAUEB_uzmo zQgi{lb-FhwJ3Yb(#zMa#urf(iyjqFB8AGCnTXFaqRNN_U%JvHg1*klw1ryj0IU5!7 zNj~as&I!5PCDNmO2ZsCEc>iVFk6GlqeRDMF!6}|$k+&|P5Shi@bhX&R1`&B zgD4el{$Z?-jgdq03y~36x}G#5j@(%r=o$83V>5gDGy>=|!(@<*>1#uYXa!WIs8OFt zYn4VhRViB|I-1wzB4}h4>gIvZYclH^hcI|4ve$g)rOT$z^u)+$QX;#|C-)JzclizJ z&pCGo_>>`%zoE3BFyc#We{{mkk@6=(R1iY~v~7bL0+xjSmi3}$0}zKdHrE)XrFXpD z9<7fo$d@wS5JwcQ@IEI&_Ul?hm+IJoOXI2%t>%*5z#p?BC zsFz=rMuE>bpDMA^5T04`A9SMEt)9=Ew|}WIf;+P}FJTCplae9-wJ&#HV3Vy?c+!8h zQ;qzycRKs{i4=ya=5GAPyb}7N2hi2bMx1PMUzNDMuR2`7i3eo{c{OCuE>W32qDLBQ zW0;ne;F|Gh0h9rs?xuC))mi%%V2O(mhof<4**ceauc?Y4>#httr+3!&yJo+^ZrIk| z@JP;B*(_Pzk&L+7e~VPbYfW)s3Kw6pNHZH!^*{ z;+(A*_^leSXurv02rvc&0vRje;(!sOFzEzHhPFZajlVB|%x;NZV^#JXby7!(+hR(s zZt`_MZ0=4c%?FoY34M@!PjzjhM)MuVqDGze6jqYJ-3_J8-b6oU(B9kesv7I0Rgp1s zHHfIYDSP;LjiaN|xx(0awa{kjNQ=Gq6%itI#^t&FAX#_VTiRl z!RJ??BNHu`gR|RB9P!*4ZEHYxh)O{S=49JyP!U?HQV|-WqStW8^RqATzpv5!fq3pe zbwQ$>B}USO79;i>RnC_v%5E|d)86*%HG!*IGY;fVj}+{;kPb&%PN#?~_Cs~{4s7k_ z5*V}8pdt3FE?u*sLTnlfqrZ$mxp+W_je;(Anq3XH6dQrzQUF9D2 z?g?0wd=zaR^VB?BwvRqkd(D=yBr0}gglT~?&F7SoTD3fOf&$Ybh*Rc<_2Fivt=_y1 z^A>hU1V2S+=Q3-vIFU{MX5GqFMXADHo8UlsWGX3++mHieiQIe8dZ!PPOB6YA#&Kd1 z%Y|~uK27daIK_#KS2_rW|FX`?_%qV4divMs`=c;0CQcEvD&5^U^T~a$$9oCNb4h_84yU60OVui~N z0Z)gAPwpRrQM*%J>+!Hqt5c^~vOp{)ep3H}rrv~ESot(KzU9oZ_@eSfz6tk4T88k< zXMNJwjtX^>%jj<1ntrtWHMA63A$fYqvI_G;Aa|^e`Sp_ywHowuT1DN0u+z3Mu;1tp zcsH7FdEZv|cmj<9M_=QZVgMLVq9>o>_^v3vr{!n$d_?0i<6ISry%%W|wrhB_4Ej6o zU{j>19<(Iq2&PEy2}FUAKWE|~QMQjo_C+`}_$Gf@?_?1{wKg^cDD3O72=lg@r!!C` z+hLbP9(t#flLXUqw4)otx?3?zhp_YQN~e<-qvl@%O}X-I{IwAW#ldom8iRTiT$;wN zp~NrTJp})Wz#ea$_S|P%fcuQkE`mwtwBy;(|9a(~XSAIUaRY;457j{^nrPU_6j8`J zQ+h$bsNHHR)gCkdeMQn0x{vL7gEc*4HiQy&!ZhO2KUqGBi8a-0<<%xEK6h5*&x~ih zaar@qK-n7gw7A6nhbqaqx%dCZLuXFwhx=Yjab%Wst4K4**jxkqLLbX)Ms^mkq(xt zNrkqc^Y8Tru-4+WpQ=FN_131EALDOfqH7p3f8<+-(#?OOKSzTsdsA&IF8DG!p}|$QgXH0K-yAH>H+D zbxZm=KZj5ad)z7Km+W!`-e4WoQk36j)4Z~!7XHq`daY=^u%oVBs^$W_)wQ*PqiA(w zxv;mbbkMkse_gqLWo|;Ay8c4i3HHK%^#xFWipH#ru*kZb;$rD0r6B4&U4B5W;vdts>sD6{4&N_w0Z3GY-%-{9xz~ zT;LgM_5VSTR--UR(PRd>8J zUldfUGQ0gIJY$E@MIvmnmy-362NA8fxTq^9LV&@9qGsMixfDhtzXU0{qgU;QAzSb{ zB_zGGmQ-$~gc?%dt#Dm^`Y-}k$&U5mRBewfZU8~e+bLz5M%|-cCFmYRxHw!5p{hL8M!PG89x|ZS@LUhCk~ZLuHAW zQ&`E5FsO@K(;Z|q025%lX_;mN)QHHaAr}Ngi5}F0m%FAh^l0;Fm;V|^w-MxYhn&!-r$tz`t=9rOrgYB$_CZTv z-&J-Y0)8cV_$NNrdfMY*=y`Jdthq(!sSaBX92FGlh5mF0JY(*7>1x+If0NiZ`?P|| zlQn#|lCNc^L)VsnMJ|{QZbYgN;SKSy@nstWq~gH(7TY{5gUN`P>Qydlk(?>PU61vE z_E)(w@v5TqtIBk+6DnL?AnGX#$K)J5lB(}p;)PROB>b?4#Jdn4q(I1`srTwt#exP*xLe zhI>x-MjoV;u+}<>()G#Oxog$Hpi(M;N+5I+6W}9mM<_8LHx3IgOG#V+;dbPbKC?js zdP&#t9-kI?IANZumFOj)-FdX*1G+;T(%R zFD?_j`vC;*vqFqW@%QW}OXp!nD1~d6<7OJ#fjsD2PN-6MvoZ@Af3O$yEUf|MK98>< z-g%Es)p4kC(W?w~e*XN``=R?NELk!$IqnzK;2)v4EF~_Mci}Fi72+*O9s2p$hLK0y z9+5CXA=D98|9t{haVj)y|81u}=md~pJ~%_#gByJ76mQ4ux-IzfP75MlJ{IUy_?NB5 zb!C9Z$D}}Bp`XhEgI_8d`W%MXK|=LtJx0^-koBc22-|bl2d72O5=ujW2ahtpBCe24 z6bUPuX+TFW&eLah-~4KN&8}bLmF0uT$4nrpKU}?f=D?VL!dpGX?L{q`|`?F)ja42A}|nqy!8} zVPdJ4d{8MPN}QrXI_bLTNL=`h%X=MX79_Fxh3V7 zyGjFSC24|OEMu0rSuJ*U6fG)+F}N&_Cr>ykc+EhdSS2nm3+prJ$p=d79TYXC#k8L@ zpS;QfKej{d)E-#^c(gvp`G-knTMs68ehw6*lXoQkTM7Q(KoM# z57{XSZVXSwPin@LzHST5fTF(Hb7PXH=6VwE>f68C%TPxS&81I?4+?Juu<0*2Et^Cd}az9i( zuW(Zf&Ek%8l&5nBoxBw95?N_)xDTLfBRsyA{09VdXP&2c(<3`bJxd>TJv?BnS*M1) zKMdHzyC_toiUph#nUqHBoOBT}uKae`-5Xe|<*#p-U*8I=-P5bA_!m;T9li#pTAEMF zHnbU7xh2dMxFpi1L+FN}*6ckOxDbcdi(HIDZ7N~ZvDdT)QXHoRF3)?r94_HO*7#ko zz@A;J^($ghsh`IkmjCqX-}f2uir%%ukc(a;(Ddn{?XFiZo8*?7hT^-`xs@#hu&eF# z>FWwI;`u%wG;1(+)ORkgPdk+vl84s-|45BJ+v|f9f-wIxx3?;{`?{-ICi_w75=L}^r>W=g4{F8_K11qQ*N*xf7oxsrsPp8%^o|yHRp~Y% zRMqut=@1*XCDO~;!eKT&w-=o#NhDk#IPF3|LD6zdCs21>A+bI?aY9tR&Z}bAzn?=Gy`|@upW&rFy$Q8&;I50;%WpKwb|qb zt6j$jUw1&!4DvEGt`u0`E5M;Ggw=n8^aiDja2Ow@lJ&XLjhqet6A5zn)tQua0&wUt zXxFF>bxOlA4AxiiWx>;JMfD3?hi;^mT^4;i?WXba&?*2+2IIQYz&0_-1T?a_8?XlU zg=OKp5Kv8JQ3!Xn_Zx#Pf-0ZCHjn`X>xtLsj%|?Ok5QY!@Glh&@gL{7$VNnzpoxA6 zwE!WcL$`kV`88OMy2c6OmsV_WCF_YI!hSGQYL<*d#Ozr}jU5FRA`PeL%_9i0-%%)^3$u22GZcLTkw0U4h{8G?CM+0!sE(2Yb3q2@b|sF3Q^ z_Y=1%KN(JADupRnp1<0HPgMFGWqH-krl(MLAt{f-`-S< ze=I^QKabXdbs=miaRv9Gzxo^35%jIQwML`PBJzD4kt~OJv?clkE(y|RnHOEt7$V)D z^Sg8`J1hd;to)@LjZ0s(9a&sHA|kfdNA1-}(0lnT+3;Ipn0#Vfe_mAl8XPGwyW(Xe zDmb_A4A}ANSE5@fEnSag1kdO4=QEp|UN>}UI|Kkh0C%;2c-;i<>(LqABT@W0T>7wqK5#b^Wx_ zg*h;tv-FlYG@Az~3}ni(4KsTBsZbFd`8g3NKi#1sL8EWOr+VO^3yQH=*f=E8;W`4% zT$N?v-CZvVisTaepLLPx{%GrvDCJ8=NTTvU&g_9#&Q*;P)P-Ab444+MEXOX}`zlei zH%wDy5bfpdl;tOtxle(<8;M@mN`e&)B5>`S_7&~vW#^wNWSi7YIvL}?F2@mmTY{-v&w@I}X&)o(gR_Qs1_es(Vi1?i*31-RYfFG`2GKz~XM!u5z^^(hjLJ={$0 zI=>CGEr`jyBfIN2>3<#`vyG_MWdvyE7aY>k;@Hrm&VCN^szV?L_+xLt?uCVraGlXq#`MWaR`S^w zSU4n)R(s(8wSu%GXkZ?ugeC7Uv`RMLAO(r`!;#w5=lEO}cgo%Fgf8%;Joa@@7J83G z2`t@StWRf36xn3`M1b&uUta%7K3MXpOzYV7-}!YnA|V_kP|W8+gRU>`|8v~8YVHEE7W_^BB%dE$@?!S<1kdnH(q(M%Sc2h}?SY1Dfq z4A;a=?H=<>MiC;_$OdP>r{8AxaLamciU~(3`gTT_r0j8s^c{F{#)<$w=4J#yGfQZb z3$QInove8bdgL*rNhnaH8m4M@)8!liMHvkjWXh&F64}?KxWGyuT z)$##Hq|Kov|SAxB42dMVCpKGiXA)+!!@$^npb z)ib0hBkR=ZAF-n94Y2IfGUTCXAA5%JQW`UMIg)m}!cDxYkE;lNOBWDqY&W<1tk33q z06l7vW&ACR#Z@^l;xACStmiCj*Yh^6&HB+MMbUs_{O-~q`-w={M}v51JN^y3;VB;F z1IJ676zbeTUib3t-=OPr=bTwarj9KQD>w`-+FnTRhD0#=l8f6}!G7p1bIhtMSX&KS zz!jWW-2|hviYjWU{IchD%jwafSGwDjurN3D9DUk>eLKG#K*^(7J%0%e7z1k?Pb`q0 z7Lb@cc;I{@`YPONQ^mTVpOB^|-vykW0gij@XTli9V@kKd*3lb~f%_+S34F=4Kx}{% zkW?1W;A(R$YR112Mg5}99n70)#vpK~$nq92Zd17TPEw+rdrL9?kk%JOVt^GzVjO{I zc_t1W+m0_HKmuKAa#F?4-3ptn05=+);PJR>Lc5g|G}J}?=q2)67LtGTch<1?RO*;VE*cfOBJ}$^gYsCHpx$B#uDkC?iQ6RPMPt;a~;Vi`PyOPs8 zk=|CHQ>~mgoifR#3Yd>&`8R@1_wFnwEAR5};~?vVY4o05r@^L+#~{#;U+hGrHSptL z41sEg-yhJOyJnLiq(npl3A&r#>nlYxwkTTm4vN#!X!-m1{BsfMS+Ot^miYp_|max_(CXi|7jIKeBwtYgh`WP zgs@uHri-Kt`|s9Xbr0c#_<8ZJ{W6&3YUl0?JPhZZy~NqkyctkFH|kjUA>O708#W!% zraL2^0a(lZ#hIF8twy%2VsEtxX)s}x%qHEhx|Iu9wDRET-kt-V?@F6@zBtv(LKmPi zjjI6RkQI?d%$s{51#p4ex}}g>(i&BT*cAv=)G)whjQx%gS25fZoCL>FqfmK&T38x> zWv%1`e%vv~m>whiMy7m76Ek6j@|BrrHiOdMR&Y7Yt*gtUReZXlIQBaSn(E_KE_N(h za@^})0)>A!?QHIf;>|&CrknYRdoFN#M&p%{OXGg=A2t&F*ZSg2cEMwK%VNXeDB8PK zFL(2Fk7#-4`)-<}{JD`7F!b`7{1Dx0q$As*SEyib4Be=mutHk4pA>N z246!i3P~tGM@G1Sm>bJ^6tO$0*g2+bPQ50IY^D~BZ%!ln>Hj@7HFUD>YQVq*UIRs& z4nrZ5f-_gh)!qyxPFBxXF%_Yve@xBrPEO4C@4}wEYC^y8WJ?X!0ROkBt-_hmg6Wo(%scfyp3m{p?%9O(6Sy`l(Td zoR(uO2;E^V4$S>jy8;0pe+YbGED!5A{+Ei&^1s2DS^pEpT&pGH^8Z)dhG*m|>u?#6 z-63gQB@RFH&g}#0wi4+Z|HdjobEm4m5e@cRTey>D~ zL4(86NttBcap#+P&w%cy?XQAvO4xhG7yFwY$_HY+!$uFC@5T7R!()SX0Wa?OAXNU* z)_g#A?#f1A?dS$FS{ZpncW$5@+MO@w&ZX-4Uy)V>5)+75;@D4+0O7u?4LzIq5ly~L zLX;Zv&L2k|zK~YCD(SsC!P?Q>zA_^#NaLIXZZL=|TZ*r;t6GbO@FWIc{y=iICDovXL)Xl~ zIz~N50BjD@mmTZKt{Io4zr%_=-{5qt10M1Os_R~OH|iQqeljiO{-8_zeK-UP{E+<% zyx`ga;ht>CL=#7PHm~4C>o5J7W5_GszB}GV1|K7ki)Y0P6{&&~js}=`wiDW+O23q( zy#{h&?$bHkU{Q;1^Ie_L%Gg?AY4}}>uP{QXj+JR+v^22pQX!3Fd$>(64?3Pq35N;R zcV?%z{t-*6q=jjUt!a|3EPxUFrOufQRxTgJnCR-=OvD1OoPJGXHN}?#m6G|gHbVW} zR~>Ei>h3Z`8DV1deG$!rOkC5dorl241(UP{3In0tr-&?jI0ypn{lbSpo4{sBJ15Np zw4cT+bf_ONG7!R;9R5u}uPHT*l_Z6Zn!atHqk$8;MnO(n1zcjsMawu#?a;1^kV-Ls zMom}tOtReWZX!?{toSqOuZ1Wk4DK^L($NUSg@0u{8v;EkYq%t zq!7CB7o@O8CEF#;O2#ySe9RIj{VZ~f*c?m(_huZaW?}3e@$VFCTu&fI(LrFggZUBS zT8x>_HXV4ydA7Us^bM>9lg~Y+*B`OkuOA+E7prN7Am~18xG| zgWyFByq~-e`^$1={=OT)vGv&Ayv|?YgbH1~X|XLFXr~X(T8)Ye*|7+3wV~;p;Xd#R zrEA1xFMHZr8h0EgxIwj9Zc+mT1B>+?g9-g>Oba2*FZLF{P%Zv<*Rk6&!PA=gb?^ zN+;oj6Xeah48j3+;Ye*kH10AJv9qF%We(_T%*C~I0KqaO(*eLFX?@ZRbRKoNodI`#By{)3LAGt9e7 zsNS>i=4$K>LA#n}D3PefeL&b7&9I=>O!E)j#-G*Q^o&oCJ|tb9jQ|C@t-qduT~o1B zD7HyG#9PZSXWwwF#PhcvbWbIB50-~&Qp~XWu>2tk*I9upxl%IpmRiWB=4VH5AWXVX zm!{*9O>iCxoT0$FcpLhqx1~RLonK<1wo`c5tt<7>hVY&pdu-|W#$OEuLBqbK8E$?E zFkkj$u4w%8@8(mKYz7g^8j%9NRtJX*{a?@Unq=?}#*_nV?^zW3=qXWW^fjl)n~;dW z>MkLmsYdY=s33H$%Dxmz4kmi*FG#0YS$ht zT1ViYul}hE9iED?r(M++32r9Z%Su&5nux|t@ki%}a_z^=x>lT6QNDQ;C{`rY?C_x_ zgl@+B88~r>&ctwVv2t4MlgXZjn)*r6y>fgxH@MU0p6z|!aQ(b?=zV5Vx+u&63dd8YwVm#x@FE(2jykb^q?*4ftkWC982%Nx zxuivoPjS=Vx_XGQcS~LA9h-d7hn<*_W9c)7%m~+j%9B4a3hC&<#xtV#As{&c zJl*FJM0JH>FQr#VA!>*B(p=Fvr6c>pUJRmRtr13K=n4$z<@iE#&Smb1jw!nITiga1 zh8-_2J~_SX^X>_~##CPI+jsr65zjYw#_XU$2kCseguxH5YH&Q5r|nWkE?oFkg9fTa z1(NlJ8S^TLlWQ?+Wu8^oPUGZ_D7<>aZFPnQ+|MFfQ;1D@RiN)AG_i%o5CR%Up>JJyrp?m=5%X zp}@fZ#oz^7J^R14ZvPV~nTd<}KOj0inp+Nk*%1SF42Ukxm=T-z!$m7a2sX&!xC^#6 zF!93N{>k9Sw9WqcY0K6P`griEWa1Xwtk^Lb`{KqHw{G~ycTM_(A^myhiRYz87icx@ zgDs+W|G*&KMwls~)2;w3fYNKBLqsp%>^;c!UdXa!%TS5Dd9rIrht6GCle@05xp94% z+^H0JP9uZWI6=g>hy85=l>y$F_TbZ0zI)`>g0TPMjO02Xwe{cQl&$>ulrK$E4 z?nxt1KJ`PJAM-?B^BM||ZYB@cSd`hPq&kzbW>S$FFg@)o?fS^<{uFKW3z9||pWtB8 zp=6@Fy;gc_G?bnkohQCs_jX29nYtK^*~OOh&yP{4@|UwrbSVPY~OlLB)p4tRachAG4)N9f+Ys4 zR#Hg5c_Z|L^G%poD|MQnu^o6eB=kH{>Rl*@jC-`rznYII>NpoK#3w znG)I^m&Gq-Uv@JdBd64YLMWueS(Hz5W6htyz#-g8vLo_)AVn}#BIq;s;Kw}Rb)nRgRl%O-5{j+o0oHjJP zr*utNiZ;x)YIxd?rHr;$8-ArYBydy9E6c0CXG&^rgidb`2Ds3(1q|Ees?njk#%Wci zkl{h4ml4LMTU^>*cf=_fN+Z61sWMzA3x1D00G*10{S=J0CE_BlQ(Qljl;P?0R;4?L zj$gs8^x!wSgB4r3Q>w=YIfE6DG;_=Qcf(%=@)T=NVI4P1J^y45E>499fA&PVc@Dd; zOXw@R?*Z#SXcM)S+9EVI)PH&=3Jz5N4`c5TBucP_>$Yv%wrv}`?e5*SZQHhO+qP}n z=6)S-aO0jEXK-dUsYyj-<;s=o|2`P=i_n$S7p*lv&@$p`c$IcprW$2&7y+}s*a2&{ z%d6J3urf2oXhXl-$$!0e~y)KuNR|5CM8{Ea?z|zWTZe3vr48UF9F%rs1L^NdO zc5``l=d}-5cMpQInl60qJ-bkiI-YdfN*7=A(T6wN*D|rQ4DFfVDhQxf9Ol2YIv-k~ z{2BxmeTFhOF#Yq-F~Neh{hCB1VK4E;^gPbjY{XIfWqxEff+f%49=JO<{E zcsN`o&=}I}SmO1=%p;SD313&^9eqK{;+%j7jx9x0VgP#YJ#pVle!bX>yx8Q6PlE`l zN<@-$0Ju*=#udq=K}RZzmk&)auI`Jdlium3>n8u91-)&52FZ8*or zeswLytF-Ccj&qQJZQGylBL!Tx=fgWsg!kJ3K@HixpD?;g>vK&?OhvF3<+1vWx`l!->nut$o z0zz_Ly|}e@#cC$S_NKllwo8(1+?T`wN%E7RaUCk~>(4@iTJfsI3TrP-KhTjdIuhDD zgrfIBl67j>c?Nn-yWVeXe?PUvf7{9bCs;5e8!P93j3E9W(L4n2xWH5xJuegpAQnp~ znwesi=fz82bDJe=!%>7o*G=s$OsKYG3)^}DV8CC0Qch-^nMdN|v)V9m$gg_}WW^LT z8v253z7HSdZXbH0oH`=Pf@$xe$1rKtGc%=cyhjqf@A`Mf1W;2I z^H?}1M|HR#9o_=qi)}3|s?EGCq&GZ={7QrxiJJO}=1jn)mEg>8ykOZ=hKs7Y(yIwc z=<%!_Wvg?Z;TW}|>sEDsW+O2Jl_F8ovOo8XG&eA242r!ucq-8m~ls&zu|U8%I=uHC6ws?kd{iMn@^`Xy3K=^p<4u`Xq|v(gqw zDMz{yv}PL8ISnvU(Wf$|a#x*(TIoH2r|3_R$qbMS8OM~Uw(ab;UHV+S9LACix0}I% z?(yUB_w4UmidRSvgX&BqS;yJ1Yet_NhUJK=q=$I3JY1q8ck@R(rw6{`Do0W zSRE3W6oUEQ#ZcJ>=RmFu@amXChO}xY@j)G)SkhP&r^b3V;7D>hkp~=L1GM${WTim? zBQHmwO{Uk?c~o6=e@E#b-0X%uA;JhFX!ta%tVXZQKmr8;072C7we@n!`8yim2f8nF zV#7d7T8)J_`ih^%Nu^m#d92p4(KCn@Z({}lV1;R}#;FU%-P0#9&=LH4*wD6C=EfkI zoVu<*cGRV$#Nz;zL!CLeBqUU##xJh-UZ;p-y{4wE2KDi}pJ0j{fG82{2##H~G36m2 z?E1{@*Z@`C(h>mLZXnX8VIDep6aX{cwDK*{KUGa>vYoFBw_kJ?tvbK?Kwb{;CVt%* zOI!4Fow4jUORkMdr5z4!rxE7Bm9s2%0;98(Gkp^8dYS5E1LR<2;I5(-;+os8ys}a_ zZa6@fW=s4wuHwWEI{Pg>(RQ=tcrHU=akc+$AV}-17%xL$?UR`|#Sia_RIv=-&y za)YvKm^^vh1kUG4NVh%-MxpUjy;z8!P5P+ElR+kYoZ{9yLove>gYQ22wM`_w3}F~4 zgzHL~2$VvHfB^5#xNwo^1W8TL)k6`uXGn%-PbHyC28+d;X?2$Iuns3s37~X&jknkQ zxLIzvo?b;B25aD~Y*}xhS*Es#)a}y-ncbk&PHTbGPXDoMLmuPbaA593snPvPgUsCm zsI}iNb?2>7)|lIn6ug&c$8yk_A4XgZSN%jONTGRCME7$)MY#%4pq6qZ%b<~kD6^(} znFU&!3a@~q!lTB&jwy;Gp_2kkQQ*@=u9M7Erw}3)q#Vu_CZf%d;VFVqEXW9^14F7P z#r8j-3ggb`A^G|#NJ0yjLFovMhl(qewFQl9c*Ty-NyPvyBNRo6exLdHsb=XIsN_=_ zrSuPr=w-ziLy4e#CeoFa)Jpb9Qu`!1?IwPBIZ)r8lTf@K5|HjVMMr;(W=c`DyLI%| zK@SNxhy<6M$%xqAQnh|#&-Kx`{%21poxFRALjHzlS9O%dKUnkX$L|-W4y{wzal;9_)j^Ti22NO9<%ah z1@;?DxnK(KBV+X6&luX=g`~RgqY*!U%p#Tzb zSy@?iH7CSL&}{A6>B8Boo^;QtcB!^*yiq*JsnI(HkOn^45R4 zC9UyH-c4M$zRt}bAH};B71PAuPt1E2*TvEq~X+* zTc!i$0`n~|L;vx7TO(JJG%;F5Q!6JaozCJrZjn!*+H@pyZeq+Vv)s?t>^d)-m+7d%7L<`TIBOhfpp|ZWMF0L`3FM2!LrsY zPSA4{3l!d@p#b~!{Z+TDvFFD#3M}t+rFu%ng4y?1XgKu|HQYfb7GeNY6i^1@J%Vp( zFrT*v*Vtjf2CSQ11@Hh=r{`WdU3;TB zxD7$HIf2q_H}yAB(djb;2N0QL0w{i%BTjTc5AOt&LHS=CwC=hV$&quo(9Aw4u z_R#>iy_sxk4@~eYo3{)zmikdfV;td(>H`MwYXvrC%4#>F^ks_#-Yy6f4O~PS4%NHa zNMIXvK$dgS`vK3>7jBSag=OPYteviHdNzJkj)AqkyGFZcYk95Z zuDU1>HnEZYtV3WbeuIc!Yc(YMIhu|a8H>Cs1d!|+BO?2Y9AD$988d(CW(_)u{-oLX zh)$n9a}kt>pj^hn;L6Ltr&63B#bsDI@TV*d(t61^FAs4rz$Zb)fLN&&lv+dA0R>rU zd8C*d*E8fm;QQ(|2o;rbJ)cVRc9#~8$L#Wf&|ahN3QM%Mr}T*{!1-n8?Vu16=6Q{d z$L``-Su(2D{g61FgN6qnWcYx9B`hrkqjP2k`7GiXk}P(J8&o*uFJF@)qd+*$xDg51 zf4SU#qjN)xY6%Ak=qk~`XC_%MS_qjG( zVAts&ky1=ZNEc7S{_(=NJ#a|K8GYSyOW)>C7-g;injtk7Z_Et7z!LeuwFJRIQ140R zdB4Ng^lC?yT_&|9R?q!POTbM}3OiIo>J>LIKAL-({AcrD&?_&uO@m`tf6+rLI}ND(VAf@v*fd~r|EIpQQEZ$0WjBHw&O7yw9(u2U4{-hqw`uoDdVpy6z z4)LZxY?_X<&(GAKQLbKc5J{Ah_s^leJRaG!N6smC{+!upt(Fr-RKs}1-wbeF+6>IC zHHXCm!@bkXvg0-H4r;XhnIwtxysnPZl;1bvrm7Pr_v>oo(3jAzi2N+B_!mbZFO%l1 z5VJZN$+*bca|&=a(BO$RnlgqvX`cF@?RG9?*;jk{=N9{uUk%jD!EdCZ||?XR@L&LM29n4!}@I1E(5TJIU3Ofh@2G&$D#xdkrs3=3DVOm zO{3J~g$xE=k$03xEqFv0oOxSOj}u~OTGkae+F{0}1ymFzRFj;|Md1K@q91t3ckHfj6$N1Y&l+A`>n3hjA97V+ zNzM<8y(w7o$y$tnB*~^9s{CO!cWksch9itQ+7{;pSwgLtepQWYsF}?Njj3eMdw;op zBty%wZN9kp02?7*d9kH@&H_1PF7S0l;?wb3?i`ZC&S;^~nDzjIfU&^cndeiFw|W4f z&>f;&>;P&l=d!b^$KsR{B$bkLUcKz#dv0ykqnGpMO1ARugeV_TRtMaRH{6Q-(=hd7 zJ{Y;{|QOf-W7md?6<8x~vXl8m;DD0TOFcG|I&sF2xrmfUrBlB8zSlAx_UK7K% z(>P5v3s$RD%$91I?IF-PBKTtR%+&`m{UC83o%VJZOHbtGXa!bW2Qhj6ReIge_VBuH z`sg1AGjolT>g*cUA&4?V>TIaeFVZH@eK`Ls>JFvpNM)YSao>2g)@i(4XF4SV%wK{& z94|nX{i@!BV=Q(LCCPMKN-C-KV2WWwmn^mb##2`7Ueb3XKspVNj`1CK7lK9>R7*sa zBF@DXzAVmuAZ(Ckd$mB;**y>myb@3lu!GRG4;ey9(N{<^?kAVh?d}iZ>8|?NZco+3 zfsyc1eXJOzq%K|0lO1i=ie8|^+ll860l9R(wsFRI@4VjHaqga5)SYKN`AU~R`D@Rv zuDv(gPTO}2O*Ui2PH?9~r09me0lR#ojgC@%^5~TDr7^p0cmny0K1ThsOvJ_qgonE$ zQabZ3D|8vqiRS&d*w^Ultcd&VQwT4d6hPM@!b)lB zHR{#_Rk^hB1J5U{U4~O?2oHr>PIkX=FIUt*w9;=)ww%^074Ejt;>d3@|L?{9Vw5Nz z9Ew>s`EfzRYB4w8n!8gN5D*(nO7qNd$IJwcVdTCgBklfDA;;3>I z+v5^KOI!qp?xOn6{=H6fYA0r9_B<-w=xO_5qcGs&Qzp%eA~(6QI@I}OmuvaQdeug= z0ERfG1>AqpYn26e`(j#2OrMGK%(;!_rRSQm1%!Q>0!kLm!#TwB6eHF(2hQG$mLuq< zwFj-`=DBRZ)w*%I4p~3`f$6f_d;&v^^uPtm6GDU74-vaPdN9$Y!xe+V98Pf0;NC~d zHb5EjR4&o<8M2DCtr$e@uIyS@2~&^NkG?bTIh%*Ec$(isBc`sD2|E~EJh)(denbBb z1;qNiF=FaOXiDe&>N^;CQaI0eYd<1t!tjrlm|kR(3o@YT3bY~Njf)bc+P6bo&PkabRDH$RL6wSp2R^AlDlLQi@{P8eFX; z5wWYQ(18d{|A>}zqM)Q=<17o|28wa$Ef{ro5Qg9RH0xtb(nW=mX7>BjR61Vbv*NK z!KuH}{HsqwSB;*e5ngaPyT!vRlCS%Q*LskBiWQw5IoFiHH0@EoWCN#A=s8aQ+8Cwfi?hd(;B^JGT2|&8o84@HRKezKN>F z7OMOwM=K$)WOzqagSMIU`6kNO8vqD}vf0B#yWC+qpAv~69DWZxuJO~F+y(M0T!+rp zU3EmXojc2wpYOWoQ{zSiDOIxFlj}yL9+`@6aa-y8RwC?ZzgOOOxBSl#CxziI|3_%| zA1V)vl9jc2Uf5e!8LH|jCnk8$^kYTq5fcVhZ|#bGeNBs8naATNf=9D~TN(?oi`$QV z?dEH0@99Szs-*7?8Tf`UUCH3mu`Lu8wb~}MN?*&1a}n9rHJZ2T^9ww+w-@s!GSW`o zJOYT|{x28S!yx4HB=QLSmvV}N-gvZ|39sQ2OgupLn0HMrf%S!iAkV8bnbP$$Kay_rf~1)A@%ao{n(oBjx(x(vN>N z@A4M7G8izNCny9*2NGMzLC{DzVeEqL!OLKyaX%i9xe%E+-ormR?S7YJoT)Ly`P!Gw znTRs+x6m4HNQh~zdlcXG3WdS}Y~QOno+*gOxq$CB81L*3Xtx)(6DsyMADtASSQ zA8T~BPeZ3)zMoOL>_i!toQWM2IL=#g7sx~3A`8>3IjEeh*5J}uoWP7c3)sTx&jzE; z;Z#Z~ldbef%huJ_x{AoJlGD+eZcnMMu~M9@KE}s1ijmEYCQ9_p%Vi~)?mVA$&dqGF z&=L63<0C{@e)sOa6Vszk9oX87Z)by{<4S?h2p}L9kdLu+B2$tGgx)I_UGseIiyU!d z345QKiDUYvY6n&)c{B#OZzl%rq%mdoo-{I@#JV8QI_MmV@8ZN#=~4BC$^WZX$P>_E z;y{!7i6c*P)Mj11O(Q}mu;P6d1Bc5%Q{JNCP?b!H@KvvIc2Cy+)7JJVkSe3 zKQF9KGICL?(^lIxZAPH}{Wvnh8vY=%hY1Q;tjc^wlSjvuYRTv zmhPTW`R0*1z*SqT)1xlM7c4eqmChIty==9|!_ouXZ&u2BF;1r3A5iBcN*xJ#?~iv% zVo`D5h>}@$C<`O?Bk65#?;Tw+WLSyXB5oZV>>cb1|D3{_55kkkSxSB*p=?@+uCV@|Yxz`k_5lXCn9TU4a4D0{qYv+nyga=RFm4`l>3 zX@Nn&tpq{7T^uz*e`b}Y;SpT2LQlg_Er_u5+ghyG^~k#7AGolo zLNlybX=n{~tg)c0j2R2jd()$2MiL)+n`zTuMH%qFNr#}R8^UBqlf^Zps^x!A6{)(h zc1S}tD>$}-d!fTT?ELc&o7&dU>-0s2Jr9#VnS8ZLKaC3cO^!GtKw1exI*`H92m_3o zeGJI^il@F=6TX+MYcayt#cZmMRy>8E3odmsC{!{iIAZ8W7T}3!zS@QoAVFzCgU}7P zbTf2HsGFhLT3B$w5A-4r{Rt|%%U4$)C?MRnE=;(zrn`gxTu*?$;^yN$G>w8{85jlI z>@U?i1?24f2RsLKlTviEzOX8(uWp>Qms5^Z+SpGsd|Wk|krrK+3w+m>$F7Mi^)$W`pOC2y#sji28FzGS ze{*{{mf?kT=-Eaw#=Cd#s9P4Y>vXQTvpj9ve_vkntEv{;n+UQvP!yXzEO$DQIT2g3 zp}j0O+3l*8Vu4i9ILHq$@r!E?l_TZz@A+g~hJdw*Y0TRZ?C^M4Z0Lj@k*7Q_!GM>r z1Rj9VpA%0X!la}*4Cw%Ei& zPHEq!#gk&wyQjm_$2Qr2{`+omM{KS-7JVEXJ;-)sM1Gi^o;B=X_PWpBKm59@+nJgU zOWcWi)0x-ig#1>5>)`&93u!%;4w3f*=+Q&iSH%$eHVckPgt$cWz9GgVh|X}?rKK1x zvDbwdY~jwXa0$I^JX6l6%SnF+{yI{ePHL<)o}Rn6)r0p|;;;F}+NtJOsWQ?2<4wTp zbSkJ0PZTYeE{>o1l7kxO9}JA@^gVM325}r4!3)-;#2hdLK|$uh&j2Xrbfd+tWmRB! z7_~<)yz~1v%SK#?Lm0geSYc1pZ#mIg84z4S zdt^4UuNW3;m~IwO8W}k>Ih@lZ)zvc8RtVYy`M{b{=E>sbk^AM5C|tY2u{e7ZC2y>` zmAb2!QdM|-_1c667oIb`je?Eo8ab zS=_ONBN61|gOZG@L+d3Uk`kNa4Lh~1qm_+VknMuHg)+e2fGJ(8N$FI12UGDh_y^{6=(b-a?yhD(K zZu8adKM9gekvC>4&raneuEVx1mLKFFlD;~-1{ejmO2Qh2@6I-32Z^BqPC=>TR2=4z zbG_r1M0;)Q+nd3snFRsJwdQF(3IEzIBX_Ey*V1M(M4IJ+SfJP?2R=YXxov9wuZ)36b}@tzHMpol;5op;}-ha(}ZnZ-6Mv7?qF=>;UCWASjiu=N6M zbB0Dtvp@LZmx<;wc<3G(Sl^TM{{Bl85DaOTG&a}9lKAGLlh*v!`TlAO$ploTGiGiJ z3~3q-zL~NY1covBjs`)I^Yu6yg#vthH6I!63HU`leaA(Z~(LS|Q_%ZnN(I72{d2(m^b=+-2NRhL9ORGZd& z0A!RX^aS2)wEU_v33nVR2JEaAcNsn;noP#9f_@%AB`8^@se>j*@-k$V1Y1w>T%45S zrFCiUdwcX}4$L&Mn%OF@#_k?;(0nM1pItj*qrDF2)N1@7)FNO#_|E`%QQ}B_Z45D5 zZkFFt4W6a;3IfB_E=tOU6tX4i$Oe$vCLFdO4zqQ8gqwLcT+YNvbj((l#84Q9A*8L49RksgKNR*k7V81cqR}@IYGPQlX2@;UT*tz z_?J3YbA8rSo5n9KVtwf}Bp8jYynJrzrb}2A_Jh-&za={Ce1ml$8Xa+ucRh>D?&w1n zFA>}nCb{SJf%H7o7Ut>YFy8ZVC`u<_eK>njQ4`-dy2`PIp2z76kb4wD})SldY7)2g_qQIw0YHnhO^=qqIu7*uP;V>ztN?qe>neJ z4fH>OM46Zw|DPIY*Y-ER<#Vf7Z@Ub{Nc;yyv|S!H14S(lcEd5}fNzYtMlD)(Lt^8x z-Pb!5C!v6(CR^BE02){~9OozFHgkWus zLdO{1e)xusZ^$sndR5pxDH|ZM9~{&dpbL@l!kSV{o2j!Ip3=l}Sf>wXd4G=A#dJ^} zwA2I7(&aFP8K3nCvda6S2@U3^RIm4j7O#-fA|ZH&`4D2N1xH!R)h);AcshQ zhlAy?UZ0P;M>7dabasftpD95Qhw(#j5X@ddkjfgdqYNA6L8E*o>b^isqAdiRdwL%7 zCqBYeo3hl21cr|JTQC*+!?7c^UV?8Q^A1z(4txt%k$%%)0!l5vT0Xs}{TA#)oBmR7 zxx}3>V0bWol_hO|GD3X5f_xCN5s*c)kiH9aMmyXgCfXqbE4*qH@K#_o^nt*$XVRY>3m(l zL}jwlVkHUIQE&FQx%^f-^FA;hhuD8wD&}+LuET1@?vl(-O#^K?$|Jb6i#~HU;bJW? z=;ALixy3eKtD|w?=$xHd+&SUv#rfg&L@agVJ7MNY1?~oJEXc}>rPhWiN(ocv9$C8I z*ApqN#ZI1|dD)Ru)74=7(A@vJTQtvcn4wsRe_EFBtn~d)&yC{ZeofkDSWC5PpiAZV z%{DU?*!wmNHHAw)W3o$nSJ{BG%$)ivqqc>#3G`QITp8*2CIYt1uofA%SxPp$yC%s3-Hn4Ff$S8-5~C%8UX0MdYjZfS+LCvYV5o%%knEVt=g5H zt7BX2N%n#A!ctARL}RoB-VUyAdi=-vM$ab0l5R0f$p$oZZMX1v7!<-d@#2y`gs|26 zmd!fvKZ#K{a)844dZTAYLDeRaQuir!GIDLCoJH2ZI>klRtUn{FGhRMcKLDB6W(yQL z811oT{w*x!SuYl2mixlqc>q~%Vt3)~_i&U&9&@~Hkd8BZXLD>#J4d!wmJNccyt4P1{_T0fe`OD7&q84uI(&w{+Z)L@m!0?<7>cqI3!~&%XJ+<} zH_VGgaC!bA{wT6y1wlCxkW-4e52MGVmM)ORuuT7b=r|0{d#ZNzWO5{%&j>tb`rM}#nB4`s9&Xj{d$A)~ec$JAIBA6Fc zJ$-T8^TQy14qWw#GR&vk?!Jx=sQS=Ap<=M61GBV(`-~yGl%^_F!o3oYDBMolAig_U zBYWYgor=VSFg%hpe9>=6 zw4KbJkX0+lF?4Mq@A7G02U7tFcbqsnxto80fG0^|L2Ab9)Q-+PgZ6piv2ed7vcY-VOC zqx*0cnljB+3VANYcnRT(OkaFmzCTHYz1O8JvWpbyF{g3TIAdzdo>V#BbBlJ?t6Xbq zi8(7O_$lH4@Zt9Q<^>3fq)?|&5gD}SW)NKx2Xbm^#QPX*@vbb_z81))nX8T;* zbZ9~IlA)nrs6)c(AY_OWW~F+~pIV;TaJfeuMg@sMcG&T5fF5BP3B~?os9GK#pP2x8 zZPkL>$KO`>q_(;rReXumJ8nVk6(6w{1(qLZY+tj~HFX5cz5q; zs+jPR#aM1KEYYAV+Mi3rQg$j0%1 z_mz@0w_`Wk5Pfg;47Q|=2~NV3L?kyuiFip?spq6KHbc?Yc_>=C(EdvENy^#$`<$^0 zAtGH|=cTDD8Q))>vgJEpzNK!D*q5(yXr6GUjBse?t^Tp^{kX5z99K`WZ|~TxHL6bt zr)XUMzA=1S%;$=A?%g4gL?U&)l>If7%j@jE z)~&*26OQ8%i0V`eL>aX#5~bt&=KZM?+8*-xoZVh(EmcIG{VInQWnVe>*fE_wKXBlk z_js663cPOQ!slKHfN5K9I}^25SYXhdpNh@#&oOj*nID86Vz8&p&=ls&vBbDFo4GBt zHey{?l5#ndaH!b0sNX?cHq|~4-zePH7lO8#i$oY|&^F_6r+Z)mscQ*&yzN97fKo)6l`teO zRv5+sIV`rluMx#ld9t?(iPzkP+x8Qu-)kHFP);1du)tN}g`a=+^YT3REFny=UgaBN z^6q+CUi0h0d@!gI%hA6B&FvCmO!aFQxXOL0e~%bst$o52d_>t3&4?iKg-dUzs1{>0 z=}(wd9GO?hwz#;MaeJ6vbxsjmz8^RRQOF5%;87-SmYY5_=gSO{2IHJ9&QZz!cg5|mGWZdvkoIM9 zowHcNg6ba+pzs!sK3067)p*i0T1(Yizj;9Jf?#Et{tjFQvv7$kW1qa}Ufc^lqtrij zP9N*f4)N;F=4&>6q#{}LS6~}qR&Z0ja7&Vrz?P3fV!hES{8+#t!n+ywezdsTzWF)I zLraW!SUK`*1-cE)Yutd~y?%UvD6U?B*Lnn?$hopO?L7t|>g}M!mUyg(zD$%qX!^lq zi4Rk7f?BG6&GEa8CZ|2zYO!XpHNg;?dCSm27?Y{)Q?r&%)Rs;bqaLujMHa%)B{8K} z?2~_nn6p2P@t=Z)EL)SGS`ye>sI*1w$`qy#7S#12L-N@}z%)TZVt(*1D~fFx#M4>D z8LZnd{<-gohQ#5SXqrt@V{*W^!B>{(;A;Y4=%2dgLyw~b)~{W_<}OX7P4PPsyxk-F zeZP;5?UX6g79@T5u^k|fEa+@p#M5~qLo$vpj7uj zCqa<4`~r;O5fPqlf`{ktb$`8Of5l&^8~zt|_YI!)eDmEQQLt)87-ZB8%hQdJQaY*oZ~uB1+AUxU(1 zalQphMnnw*Z$4_#{kQwEc584&`4yBOBI${YyUg8~3NtBu9Nef(uk6i0d7-hpn4MwI zk}njm5lqz-oy^e2l}+(Q%fx4{aQ~=Wq)LC-XD(&hZbRvl?lWrV_Ba|N2fVRp#W}(3 zvoRq?e+9U}1gs2WLzD^1PM5{Q7e84iHYl>lZihlnq~Z%Fkp|k8iwiUG9>VOmo`d6% zF?e<1?aUb?xJo`LLSgKshv?uPsZ6}rA$8hmv-6i&G$nZOorG-$gpcEoG)MLzpp^OF zo4RleCv8&!M$l17tMDTy)IaDda_gEzwqqiIV5M6h!%X%27D%7mPM)f1>V>14V3r7I zI=et0Q?v_Ph>Ti!l?F(76V^}gIwSOpG>QB|sk~5fR_Ms5S@lD1=|r$vu_Vr^J+vkT z4>eMNfvHIy)TcBY#@1j_sxaoeM}YlC4?IoWiQ=aKx$v7K#ZL`N#s}j3R5ZLqv<}o3 z33_l7&0=fTs|3CDmP>~@AA0!sop>~_luemIEH)01{2=@Aa?MlGDd$6R-J+w?sK9h4 z3hE%cUk&|TzuLx!EI4Bb>;|s8abv_mfu;)zc|+*Fb*6wWu5r}6JX`1u)!QC5aeu^k zb%d<>Vl}N0g`7D$|26C??E`b^bZnc@2vz$IhAKMP%wgM!VuM;BXu$y^;o43Me6flN z?Xr8QMD2<>kOpmJl}8J0QNT^b&_Q%_=3W6o!V?yYJbLZqFv1?buB$d#i2MTO z7cWx8$3Tl$S(#d75;Fi{v(a2Jz@@E-Kp6UsY6-w8=gEzTXnCNOCq&Pq^VeThKFv^? zo7nPU%6t~#kgb>PP-%=x zu)>;nueW{8UN_Sjm2vGJYB|E~ic<=H0?bc#Ht2>U#3kTeZkHVeqDavd6Ww&jl>$51n7q=&uHn(nG^T{oAamwf(MRZ? zN*$ZQ%_!)nx%3o;w>|up_z_=|kfb*i)b$rW71_`3LGK5K1LQ(6$rqn~Wb2$d)NEFD zVJT>C)%q{gvX#B57*yb>ZV36594S|MVA#yAUdhDInhJa5W8y=Pd!PYj{0L$?K0w#G zgHFS_33-F0$OLNAfRb<@pE;OrXeGN1P2<5ikhp#mqb zcf%zdK93WhKF~Jz$;ez7)f%xg;H7vsKgha91EnTZ}NNDCLMqV{thDSQy z7_G(Ksp^%CV3{XLyn8f)CX>K+ksvS2o_etgdV`irlATy#eH{c$qUAB&HKV$eb9iY5 z)uMfgR#-&nwVcL^WpWe$@tBvqd&7#-Vr??aqo5-NS|p0XSH8y=M2U$=Ysg2Cv2qI8 z(Touyq?D^Oky#a+6L3WiN)k@jXkx!>6$qzXtFG<~q`dIE__PBW#y+aMnhqE_(RG1+ zEf4C}`>N*W@T#Wt#FqAci^bkWm%xel#%_DbZ6lQZpLZ;P&-bORGO*~s#wvfgi?gk` zkD!(^lA0oQZQV9P9Fp2`V;N*n!eg`2D*`hMaHyzz?)BCM#3>%yjddP-Y|TNljFWya zP3zU%zIWbvb~U*ZmD+)v$|Qm0a(D|BIW&w+5cML=aYI|nj|em-<=aV7vfM%20+EVS z2j)yn*`bhq@S6dsYQ_9}?rm(Xn;i~=j@ImHmF@(lr_EOR!?j*spXXPZi3E+fk%U|- zSm?MrFlZ=Rrf(o*-ev1-HCgAUSsM@d>hm<-9^x?`ix;nmI>Wf&R@#xoQH498A7Ulw zmBRwrGpcfz*(5>kp!Mz?jXf>VEp0hbiwFR?{oOp7S{`lw1vbCs^v32F(KYPOhGrb< zL4#{*m)iXIu0(lgez0N9q@hNwd#^rwwL2*0~w-`L$&7N z`KA;W|Dd;9CxR&X8O<7Up|{GF?m8BqP?{cg%#K=E?z}tL0ce-|I`)3d>ixjK8A<>A zw`0oxM9pSm`_I;IG3I2tK&Lxly6i8$*u_C%v#Gd=#$D2# zhgYvxrK&)Lw}V`8P9Ty7Epqs8clW0?`Yq90q^on>V}a7(I+dekp()ql)ew0?;TUN@9ZeRa*pen7Wh{!ByAKTB+AqhUo|WGL_Im z2yqq;_FVh~o;tfV1)UGAP(S~Z@9?>$RKfEa3v)0WoXi^;iq{fjyX77H1e!9u1R^(M zxE%Z!iJgbeS;3sYt)ZJkBrB@fU`RvkCFu0?>v z;R3j`69_%W+j^a@=SmJJldGjg4LH57OdOsDlh z|0#s+#ou5|)+IT*GgI;DCY-vhlF$P?mT#zfZp4J@Ghl%S>?XI6>;vw*uy0u_bNW#@Hi5y)=!BN;5P zoTWQhD9pSb|7xxGo43rVq0agqelFxBd`QWY2y7ey%#C>+KQ1+pFhE+{`8S*6#CmIzxq@!eawl!Az46S)Xb>v2nO?~jMM9fF;7dCxW3$OBGC-7fKM2`7V35Y>zc>Yp zrieOlMOMWWiwUvmGhDN46O@oS0N+kj?B~?^{}?-`CP9FO$+m6Vwrx(^wr$(CZQHhO z+qT`av%4?*ZQO_ZBPt>*E9)G}?9m9tM#=L6&UF+NG#!kvf|+Ch3o=`6eTO3~FTRVY zEX86Hc$3>H*OT!D@@~RA8px^lt;g6Uw-Z=m@}Pn~+xYM)`O&>{c#%O6{o zxwBqLBOzlW6kvDJaU+yrM$d&T*nXm?K{}d^VF1^k zu(SnJLP9rjMavL~pra(ks+7FKK$0_Wy<_OJpFaY%7El64G_2_(fLKn_!jW_g!T4dB zb*qfks;k$H{&mN2W>_QFueXu)=I`M~P6}+hnf5+OWt&(!2|}8n5e#v2Nkk}^$CelX ze-N)5c|p)>s|h3f+o%J=G@Wb#`y=&zY0%=gS7H|9i;h|>)5w9>6>7Hy*M3ydBy@{M z0*kW~QW01fyQdgSiH9Yj1hZ$@F%BH4Nj|;+6KOO@Xcp!X@KjsKcW0jYL>sh`j+e0w zekO3MAOJ|Qg2>?7a`)$cl&PFH{oz=W?1G1?AwrnH7h?Cbx4q(8SWiJ)#m&*zS4S$- zP)N<;&lVKjHK=6E8H8|<0KM%xixl7&5m>rCeFuT8i`)L>90s_WSmTi~%50c9Lt zu8i{(u;@P(6EPMJ&r+i%dLRorsSLS-yBB>o#Aa-xR{MX;vDYeOCe`S*Yl}m)*G{## zn9NWkUD!Dv_As)>h+R+Oj@A-omW=J*FvaR7KdfDe!TQW&^itF!%-feM3A2UOM-Wc8 zcdT-OnCF16PI=n7<(I@yiAEbzu*_qk9Q6jC5^qF+?me_|W^4 zN+6Lr;`SFVBO6}^!>HJgM9@wjSI&XtL%T45ZI)rtu$f=;b}tzaa7^jbp}qO4FCQ&L|y1>QM{y$B8^CTx23QV zW-2lIPb?`n8IuvxF*$>=G?81yPGLyM7uFHds6j%gj1Y$0x%r5bc!pglN0qKMbd>37 zsZQ&7FHIhX4r?vBsbx42P5wrgevuSe_3S!7EASXFwWjuEjrk2x_C^QdQIdWCsw0IC zf8iLwTP<6HxwIgh_)in(_A`=Of!}yQRry)=7M?2CYkhy5dP%TOim88rtddh9C%Tzc zR)}X!Z8?7Qly4Sp>C-Ie09?=LtBY0FzWo=>Vhg#ru1cxG=tGznb(%=(wXUS^`gV>T z{%g!_qqHgx@Hii>_lJc6&3gdCBzI3bm+b)>$uzvCf+x+0^K!G`^pl~4L@C=4xHLeB zo0y#)be14R_2JFcCzo^X3+B^r+8-T$sp7#qzo!?PkL0h$3T{k*;@XZU5P*iu$X@)% zl(_WDLb=RqXohj#q5jt&+>RJBan1cWwr%ZltR@W?GmM}j#tY3Pi9`8Vn^-*jds&@O zT04>=n&cB{(_~oeTUWmITa&L~PT3y+@BBG$W72;ZNhGS^ z1Q{>m$~XWrZuo_EM$mR_YtU7qE5Y0P^rAIFL@Fs0$2->VKO)|seh1F|NqndP<;O$S zST0YxWYWwp?zbh%|C=q!V`8Ey)>RgM6%MU>x={No_r286DLrGK20>`}a6y-#ILiOB zqoX>!G@p0-+x2Be;xU^Hvg{uCv`zE--W1(#EJP)esh%z}*pmT>0z;6bZSruUe1q*Z zUPcm=2tx*P3rq=5L7l$(dK(r7keZD;cuPJmj`nx)`OFkc*MaQFX+;Hm>`=)L9G)_b zUPgw%)}ft`Z|aUY-V&6pE3y!$23Jl!F17CM`66Pq*urskI1n z_FwNFNa--ttjnx}mRfPvTJ>d?PeOnA%hZyOgK_n4<}&?+%vw4^Jo;(nJH`6Ij>$12xc# zT6Vt-Iu!NS>qSaySy2G>(P_!1Tr*qi-=?st+R_~*_&uUsHRIOy;A8^nJ&pa4VlNOd zwJO=NQr+7Qm7@G`QBRN(KiChIRK^;b=#lSj*|An9mREmo25>=^$O%JIs5~l4^h#s0 z-TcaFja#9g4lMF0Z<& z8?|OI`SOD_;b6MvxjF@hgMSdL1m$SpMe5jST?hT=O0%BB#0G{8ud#VdR4!t9Nw1m^ z(1mPq%|fGH8y9GvXn)t|2TuT!O|R@^M#%`*s*Ba!3mE$Det~9t)VqXsqZQm}?uQH+ ze=;_MdK2VS%`aT6D-?lpUN%BnZQ@hIkc}LT@dh=E!`VHe+kTc}iX(ak&Ys;1nqI%C z4r#gsvZ(=Ee^dQykK&$<7zaZLkbI{vAz%T6@UR08!sDxo25?w|`d&J`>DBeFCDhFf ze_SZ7dawh4phOKy+2)F{VOK=x zz-#pPZ4pssy1U+0#UO3TbUfEzPZ>ZJWWCch&l-iuvjcC`C<>(}+bU*KHvGZm{@bZh zAE7ofM@vL2iPQllv9^xWq=nP!xnG)DkZ7GC4=}U9`eLsNrK*qhOxUz^ugzi^_Q2<) zQZgIBZPb~zM$w_pj@RN*LB)agB&ga}!X|>A$RBya1=vuG4a2sO6CP)a`}5gVtyW#Y zGCoHblzaa51%X}G*1+zZ&z0<*l9t~7L{5>jiRON(X?9H> z7nG=rN)59?905*bj{_-F!2S8?2~VHnVqrxZnLqPQt;aLyQ&tx)eAtx7hQmH zQ!@R;Qp=nnMhI0*Tf)pb;7X|J(gJ&@-UY)Z*!~s_eC7f)6vmfV7D9CS+v~VzucOA3 zKqd&yFcggZxAsm^b}J^g_}XfYJ?n}F>6xEO^~gn=j0c$#wg^6!UGcB^bJJ_2riFx; zf3IpBnf-$hGnGg?L=*;>nt z0USAs4xQ2h90vT(?uTK}>oYiIs91Wg1i1WhVUjVT_*+n3QH46LG%n^prR{?cNFt%4 ze|k^KnPd#Lm>ehoc_X3Ic8>g3z*erW@nDNxjE0pnXE#kUBK_Q(GOndV7*d>NE=0mQ0|Zj~ zW89Ugys;0UrPE|L+Q9T8W9bF4&aYiHu(-z3%+kh@rMq5-*+)u|LVx=l+S}J^^ktrl z5>NQYVZ1OhOP**UzW5z{S=)Xt3bC$d_zxxfMRvPYjrl1%9Y&kc+mOgmiRFN@S>-27 zTL>j#z2jrJ1c&hs(UV4XRvFY{K+J;DIWARNla=?n-$TZVQ|kOx;WCYu=zCiHlhCRI zBGjYOY(ZAAA6pH&eyZN>Ba16{#!d%my>uEyGa@b@@o}sF;DA))osDnhR&C~WqZf_F zKxeTqfD~7}JaPeejek{aqCc$&66Az$35?_)pDW$U`T>YET1BScgu)Rot$z=}vn{q+ zvUuF2Yl=HqsTS=t%kB7Bmp&riH=4+_`X7Y08bL!rIL+s;1e8L4|+Fm zGbT)})zIMzU^6v00s#X#bZ&jv{(jem{6u6fc)Y?2@rHnj$BOmRVrJ^`?m=1{qJ5%$ zi|~|HstEa$(fK4U-F+-eeOqa#ETLNioV0w~h$F3ALlk1t=j~VISlOGQui3ZchE~e+@DVDO{!gl1!*>~v8G`-E1 z;)UUcJq0Na3cCi)l#@_WUJ!7s^)`}yMim^XJ2!7#o3$34bwaVoDjztGDy!cvP_P;5 z3d+x2;26$$3C`gnXqUD+Mgwh_dvhCreMt<#zH=1HIZP;fHg3KKyx^*Ds_=QiJ>|U0 zPAv)*l<=>qkFoFknmPM~g(`b|NVIHew`($dq$ak%AYs7nN?A4eAB?kOIBMC0B`f}0fIURh9VTsBh9_JiCP59BKRjfqsvsWuJAP<#0@?c@HGYV zr$-j_{yvfe7w=OFdsp+kw`z z9l*!@b3excsg2py_1c>4=SnIvnbzx?#H*iBKrGcfvhe+ZILBMYIB_6PI$Kg(H?mL~ z?(A5OePV2mDj|cSiK(MQ$~fT48Zua_+M>}s%gGQoVacHyjlZq{k47__iRu-MEt*(Fd?VWXMDC!9HFa=tB zu);v}=h%)es)diaEwja?ZyWn+@sO}gP})zy6UffVdh<&E(%j7bd^7Z>(+d0xDMIs@ zZJG9G^c>gCE!wb(SN}=a?IGwkHhHn+tG$>+q)3PM<^Ua)9C)%|iJLUS^w#>AA%xn~lg! zmNISbV~Dvt#;1ikS*qZ~=#icf8@bMBMg~M`{YFEt#i0Gy(Fs!VMjMYH6{bE%x+-1#81@CKfpyUu}DMet0M~#GuD5X)0 zOepy(&kR=rum_>GV61C}oK-KFcS^K3t(Ir9s!-a)D1XrwZI7d<7D0W4&)keR{oIDA ze*LKz1Mlaq$Q9Y%6G+0{Nvb!!srQMOE}37d_sSa!#!cwmiBQU&10OGE9<9!2QlDEi zcub!e^zGW3K`i*5D+YzE9IJ#tvgrt=L+U>o8!GQ$&mgMzkP}l|SEb)QTr525Q{^Av z5ERo>pZ*Qk{`{UjJ<6c~M&iA)C%EBvAvgCA5b!0B%m^6HpdRNmshL7oY5^b-1kmj~Z73i2H+Nr1G>~qm#pK|- z?e_Ldyxc%0E%Qa03^BG#_xQWtzX9O+PCDZqDU;D_5x1o{=EGXv9z2^ke?J@6#&!rlt0D7?>qo|czNbC?dQVFvr#ClL zA~PAM#P6=~6ykV?SG)D~jf!KAy44OA1?=JMR{yp>!@Ya@leiO`;O&LO!znu0`$wJU zQe5?GyHrr;YPWRIATM^CIDySeawsq1$;!pQ-$wL>sd2m`IU4#ra0L(d8-mt@b_`Yt z1yaph=6+`(U8sUkH>&9Aa0CgtvvCc*#7IQc&g^!M8q_&aH)5&+vKn$xac&Bs`o|t1 zx5-g{Njd%X=QJgt3cszH13pPL0*-98`*fibV)`|bn43mAyNe+;8r{^uc*IQ38Ob$#p}wagN8XG) zSEuDv%_H7Fjv4OkQ$rNb&Q7eaLA_2eN*o=lIOybrgSXlkKo7gYkoh;kf?~aYG-7|P zzVY6HxY3XsJef@!SXH~d55HEJ6_TuS@4)}#+;5mxnX?^RjgtenGMlH?(OE(T4yoQa zwF-w{4foX=W7ZHBOBlV@RawJUjk`2GxkL4)za?K+1#l&K!13P(kzCq(g&WLYR8YC} zdmvC;9;VO|$@t7GpU@K#H#`8A4<;bF=7v}1;{4ddb_|-k z3KP%E%fn8|qiQ^G8itnA(aexzLLdFOMvo5Cm3#+~rXlLVwrczm(bq!Yvfxc1D5cHG zjbd1!v(=Y?i%zts@>rl6;U?w5wb#{Dq4bZtuAX9}PI3#W@FNF)T!erlMeHg?i(!SO z6h#Kj+^Wh}U1_bO&~nz~HuFX`Jw%yx=3Z4^{AoKz*>J zYx+$G{C3NoQ+wFv5&!Tdbs8{(tj+;c_@Acg&J#y8NH*?%Qv8u*DigwPi^HeXy^e~+ zT`_c|r)v;;`yv2(`{{e2Hpu%zWz#_P_I;~(_5Sh*Drg8&W^Gg#g%@?Bu1@**r|NImSiCj!5F?ra9c^|)NNCNsj4ij&BdnU~X|UA#lK4khnu3r7#&m+$ z-?V-ZOqm2Z{Xr@zeV~#TB2;XBpgyW#b%&dXrt-sj-e;&ne-LZ5d+4N#DrvwA(~s(I z@DxjNJ+f!2YI!y@^#T@f#o}liaY5P0e{3Dv2GGP{-6*ID_z#iwz|K+K!K?B*7whED zF@Vu3!nx`Vk%0IgT*Ntu6g%aj!n^lUjn}gEuR8Gcl|rm`lk} zfleTH{no=3L|b#~CNYEi71!2Xf9%`JC^+Wjez<~BS|MZv`8Q7z2E%D(D}96oh2=>V}{7=3UYhSbRbn znr&do{fSuLqT4nFGCIAFn+IWyX^U@pu%pYtB#c7yWqbC_;z(Hpk*5yXF8S7h{Rd@S z%khRHc=gwS@KS!zXvolry#DOt<6CWWEkshky$QhrUOC*(r;ReZFf=1tAEYR#j_;J# z;!Gh^U7*GIfMG4`lLjNvAINWH}>ngh626?w1-D8oX(FS~t^7l)V3xH(8X^0V7p;95267#Y5OzeLefe?5pq%g_A@D=k{i zZ#`Yd((5AOD%jvOjFrl>umFESDOY2m8w|b~ctGU=R{FjV{uV_%#Qvwu`d>*Bm>C%V z$CfunQz~w2{Qnpwy)@wT9VUG5896zlFxE-JU>O8~j2-h!R>K)ZEkEwpKVB--l4K%| zSWoj!-I_WpuU=FfT>EYob%6XX=+wG+sE-P_ap}7Fd2f6_^Ia|eFPY|M(J<|@y}7IG zsIMq*ZpFp;nct^8h{)R} znuDRM7w{R?=DTLw*saQIC`>vD9Z$=@yVm|ZOH^*s^816kE5~?Ir5mc;%8fk!&dg&8 zmj4Gnc<%3ey_)Fqi}>0Y{8#nz0(}{*YKrVpcl;CmPLK>Sf%jZ#A@;G&3jwyZdxC|w zJJ${ilHZ%LGvb#_znc{IeyekKY8NjBQHw8Za{R{mrZTu9L^M3E#18y>I<40~U+i*@ zZR)$EJCAF(dRv$&*JP+Cjyr<(8ooiPyg+d(Yde~D_MX8*66%mSkzUF1^3*H=0Vb*}4 z8?IIR9IYrC7hN^Z<9o;jxvr9i_CJ(6#NwsM5ZF88g3$`zJ=Ltv+|x}e>am1%ceQ@D zSk}2+Kl?V$_E%TT7NaF&tsSOC!}dW5Q3?Zkways)P)Z>0yKEBxhagZ6QlTPR(!0 z%_qAy@mpE1up#L>2C@(Dnm4ZZV*wTpJ;>?k*{w?I$Y!V-v};UOO1Af~d$A;=Z9bVR zJofl4atqCjYn&atV|zP1boDy^s$0=8zJ6;^*94r)%Kdj=DzU^c5yH(Z=I~IwVr^mN zOQe5TrcuR}R$+G8fy_S0J#$QV+l~96kH%|NR=X)PYEPdQ1TI_IRfk#)nX*%XvMdq;eomd14d<3G#|e@ zgyjs$_L9dxtixe-m#Pmd*CBB3#!3Ve)8nVV+hB0)dm$LGKJNIAJ&r&Lnt)B_3@U5e z2@(R}5sl8^&}z;@>U{Fn5g294sAcJLmuVEnb%W@>wx-kJJu#kkr(kWLTbL-{&B+mK z9cSz`hfuG%Md>oDI6Oe-YRw)pzp+gq{ip|K<@3dLYw)s^bG|j0u62{SIR&4O*iXBG z@I6h84BZ`W=TwL~t3GBAc3CfOy7UOYOw8jEgfJj2f@eJ*-a9fgXM%)6E+I3f`(dyF zHhW#q7uXI8n<|&`U0eT5wLzz-*0{=$e-H{+gXB8Cd&*!gE$Qz74k%E1dk1s+RK!t? zwPq#hkT<%Up|ZW^%A>`tBd*VJU{GkoTZUJiekkCqA6}3p_af5niALYSKo+!)=l$sj)U}Lcnus3myZl$U(M5z;{ zz~M}_l;b^SgSknAj)K*!yFuA)@UZO&`x>G5yY?Id7Vq+m3JmiF`vQ&*i#X`)Fw+Zm zVU>uluT?U~xc+gnS4Lv$sD?euY^mD;l>3~N8Gs1DCHNFC*hXLW$Xv~7{Q-Bmt z`#hOW8+(O$kuebPFTW z5OBBz%N2BaGJOVAH#M7{XS7*U(g_o$ab=3;`7`VT*hb*S200e-OEh>05>zAd933PO zCelyd<&&9-J>KH4Pgenf;*!@IG9BsFV)63zT5;AdC@LD>9tIGJ%S+tk&o^I2>AIH4 zM7o@hk3`NiZju#;hTP?w@ ze|cPNtfi0`eto-oM_(W*fbZYTfRA{!U*G1 zIdBmBo+6T9jx_Jsw?_=NUq>^{!Mwq~b=m{1WgVlo_7vr?95$_xC*b{^Au!`rwi8u; z- z+2!|B4-#-~YRj3ya!?53y7=z{Iy(#wzJ1>5P=~S42BY&lf@P2tO}cUco>i}Adv9CaMbPIq4Tuyypj{V@)D@nQsfDD{uK$b+Fv}YfSzW$6`P%vo5 z;P8tPQ>4qM%X6ILh9mq2x(l4Ht>IR&oxpPsTN|0}@RzKah1|C5SxiI$PN~!Zhp*eOd_J3eJb%P5rZYR(;emsw&TmCMc$C z;g~)CI=1ad=n~c$^x4S0OB@FSpHXnGohH9AzTCQVS$Th7{TH7n?S3ISR4wCtSHd&t zQSqz2M+C|`Rj6g2z|p(9y));p7KoNu2sn$Xw*6oe#pDf#;0f(=g-KDaNs*mpnikH! z#J867z5z`_chD*z?<<7y2MrL}HYc?+nNTzjE;6(pFk21}S|m?35|IK(EKZO){o)|m z)Zw(@N5xm+T)?FQI=l<(J+AIEp07uuW5lL86tzI{*41LfFt%6MDhRE`p3E?55)ar0 z+YcUL@?3hw$lVp!>RiL(H|`KTuR>pQ-0F~e=&qw<8%2=eRzzF3VaaEJ%DFUvz%Fyc z{_Q&hv67V>|!d5X^!;)8>#!Mc09(u`G6 z2%v?S&~Y-dx`IkZ?(IL8nG5?F{doU$43fe3+ersu^T<#^DMsnFa0ud_w0Cjgy3JhV z%o3)QgmSmIZ9{j@BI=G|zvv>N1^c<^={1Z7)i=H#E^RL>Ihzupz1N$x;`>FK_b?W-Q9QvO`Rd?Cj(M7 z*_u!);+Nfj?v(1tC^H`2(ZH&GQM#^l^jhA^%DNGLlhed>GmiyRy|Q}VmL|V`g^w#3 z#)r1GZg^5WB*8tdYg+$4q)ejq)%{*vXoFIEM_b`%jVM~()J^s_Hh=wqA5kKkC+!1D zk?CT!6BW`s=O>OZ$rAO^PR{x;_pm&tB1)%wOD0Q)7jpcwl^XWsa+1Ocuzp1I+6>Pi_#tbT8O#k#EI}v z;~;@gUevbh4HxWrH&l%UR9q;K!7e@($&x7dJK2^J{SLWiwerLRnbmMhdUOH1jAbfw z6H{krOTR1E-D8Fg5Ga1xZ*O@5x?X>{zXSQk>|Iawwrw5EW~NQlbF8y``6x{BY2;@a zLBF$qXj$*4-(k5a9B^EEgm5lV;CF?bB`BfPuc(dyMmQlD^gs}_iD2Pg zl^iHn2OZDAl>`oZplCwUpL1}p%XGk{5aJ@Jo&T8zsJl++GFp4OEaywF=k!07e~#m+ zjOwvYlrSjK&k{GlIY-Wl`+$0y%}1z77kzIb-JXAJ-^X7dl*`l@A)%7DdpO@NSuS;f zQRj1m7PPyf#iD=k+9h%5jfmrbM0!%;Bk<`+203K|o7Q=%=xHKd&Y>7*TGbIM&MF+r zpDdDS%_!9aE|QMzQO>NtyIF|gzf~UWlZT*S1_ka_9faStdl#&RTXZHpsr)=M6 ziFJ@V#9;qRP&c%oAtnf(&HgP<)~5<}Xy5!7i`O5;MmcoE^sxBwkWu8HB80aCYTA@G zH!!TsuE%e%Y6^srn@{&&>7S(2iG(vmqSqpf#DT6wzdK}+!GWIBWf8lQ8rGUR@IU}f z2Vf9wOEOIoG+4+1*XUkZFDaDSh`HEjym{V`+0DpcYUz?`kS-_r(s%u|B$Nd1f}W6W zpeeDg7VS@(#{Y#;50}{z+&3G4$4z5_pq;{kQQd7 z@(grEl7{)09r5bA6AJ7Z2ZLYGY?o{rl}~XOCBLK zot*@!;&TNL1I7@q#3AGZG=H0H^NEW}Y&C#YM|kpNsMm@ zI`f|WMXkjfNrOVPLTOgb4V{fl#!b4GGx_8tl|;o7_QU8rT_iORnsG;BffC8Nd7&&M zbRdh^Gw4)TX(ABeMG7cF6H3k3=X&cPHZ~PkL*Y(uSA0fe|GCrKXwseyl~%J8>lTQZ zPYqgtP~bI4*REt=;E94~graAP5LYrJuo3^m@p(b+S`)@7$VD5<^WE{P%?55|ATj$A zA6O`qPpT#t^+APcD$$~9y9rO|Mpz_*iM5mo5b@*%2O&qPC z*cMLnSI`uTwi_ZX2(zosXuRu2tLbVhd~2S9Vq!jgUq$Ql9C$Uk6M@EwU}jD>kQ*4e zCg8>9qGJ&>Q>MJKkq~SLEf|X$E^VDr`u<}*zcFt1KN&Qoi5pI{tPh7E_hRidwD=Nk zm9MPNrnF`bs_BLqOtG`-c8RVMp?PyppvNEBu_YmNZ@zs(zD~aenlXmjZzd6leK)7H?cTWNBQicC(o-7=^vl z->1u^o3T6(=?#>@*P)v}yYr~5l(#bU^kuI{<;ox&0ZkYkxaS`)b%Fbf)0DT3FPGC9 z<7n1&73qt+w#|~*hgE`nxabZ;z!G7+*y1>0`}MIt7)aNG?cMCq6q4C*q=L z9@YA`br@%E##UzL*z=5+Ua{qkpo&_Y)7mfhA!BzoIfsx(aW?bQ9pQb!zOPBx3zZ5D z=kFuz_KL6(Y69|2+R5fkI=mE#Fr#cgdIsCvcg>?9HuD%_sy3e0Or%Px|h zOGp_l#lW!gh^|Q0xOGiYbskR5L2Ha;kpze`O_4^mAvJ}gSnav~A~*+ZVb)7roP4uV zq=H=HIYJ7G@6(oa|0q5obv@1)nK^kvyV?zYHvxXLH{&wc9nWM-O0}RK&f-P3_K(>} z1or*j(9Z~WO#O%S!~WlTdj3ZpnxiS@bj0?*)6YDua>@vTTw>CY>fxldM^&R%R=Fko z6^=P%YkGl5Nb&VU-<~ZCKp>ill_D3wFm}vsou1}*hkg`{uXVzcXzf%p1$x%cVcE;! z*PQo2WApUn$fv_VBq*{)1=`ik-^48)7aZv}ZAe0-2aAqGMY6UVgNY~O^G(x_ug^T_ z3FS&sniysbYMUd;a-x}ILsA2B+b%r&RqE=2sbYRr?4_YV&0`7H<}bWW(NyJ}g2_-e z58X#1#vT1u7CZ9_ul0;hCz;bL`${ZJer2zvJprAGVlL~QLf48l12z0y^H>YdHo2Xx zBhx6$VwbuX#Jw2a ztGp?+v)-KQV!<7<@uqa3+>VSVX-{9{G&9ZE#wNqJ+qW`a_GXo#1J`juTe$DJwI%v5 zOuedRp|!4WgAFtl;50RV1SWo1Lrh>TJu58&u^k?mq#x2HHfWLpr72HCcgV?nB+teR z7q$JiG(|k%I7H{VEAE)dE&$uRa_ZZ-(cSc~2c1@r1w9@wCZ;3CBpFgIc}EDQV&A4Z zpaFA}bBWicw8`(Zq1LyT9IWuFl!E3a1I!R->%VP&u6Fu<6Ar^9Z}HA_fn?P#6;#(v zGyt2=OhkmY0ruBY#}#Ek_s!tDgWRp>8kxbl{D&;Z92850MvWQuu6*m45IDr05mJXt zXWG%1v!X2J zH8)4pL*b9`k|zS>vps#CeN;wOW2ExuQd5#&;{kG6r}OW;sr0n0DOb0{s^kzXiA(cb z7d7)4Aa^^T5HOF5=&fqq!m5Ze1)+Ba%C1XV!aL)c$K_7W2ZAXs>UuVa8XF*^?vW?j zH}trB9qnYT)n37=g1fG&6(?zEo%1~V{6>5#E&&z+=W2?mR?o$iwYQaNeJY#Jtoh18+FOkI<<%eqCA1(_P?8KQNqc)Ai+_p-C!&{FE8Hz#YK7{i-qqJROsFfeX%0 zh=$F745cxdMN-7Fv8%Yq?VDE8m2Ss%0h+>XYw|9n-gn9+Drw2&D}~q|L7t`7?gm-% z?E@-X^LndpH9L*5F#h@@PNc&doT7OdI|Bf3cTW;Hw$@@zuEGcf>mj)^~Pcmwg?eHO~C$qwf zSsAMI>Rjt}d3_FDebgabqh7n@9jK}nx%Y$QK1hwos6zC9QIBRxysDYP)`(z8S)QgO zM`XHYzt)6@{=9-lod>C#pv0ciMFeMe7LB2M&tj%_0Tyq-U_@3q0oc`F!@gg(-ZTRc zgC*1FwyS7d{$-)A|A6U+@n=DMR0d_M>lYJAFW@ z-SB4Pa|hD^V|@hqq^FOwzxa*SuUhen6SV7jpf5p%JK!&LI8N}_nE^-f<;TKq249pS z*yz9@b7_@Ukuc4Gdg8(O!v}OVp3ul4!fYpYS8Eeg=68(8dQp=f_hrF(WVUm*zQ%OhJLeRthii@vvIZ#}4`xtH&4DT* zs;<|j35fFhxioP6d$cp#AEJa5UF!XBF9JcY%L7m^OM7u`M%cAX0X_N8UGy2lx|6^m zj!-W?mLcHU5Ok6=ASs5yu3DGh(S00}3tkk?7kQC+qSW_g5m{K*A3)*>lf()9GGF_z z_8&_(zZu4LWMzh#HZ7^_w~@Kha_b2Sk< z69+Oh4C=DU0b*66P6zO{B;UJZmt{ZvIglVbshO-+&KvmUScI4pEZF?Z0*9fG<~7=) zq^_;4Exp?`_A^=74;%f3xCF!jN~S=Q@aX+9o}!_u;P(ELGGO^U5zxU+_GaD(jJ$hh z-_L>6Ljes(v5phX#MSH)N5fLos<2ImleoT}-Ho*FqC42Y05@fA`$N78r6U-4B&bG* za_4S(pJ&-WJ;uNW-#mZAS20Y7%=fnHfdsbW#_6v7{yGXn zNZ1pl$FcWA*m>$39ee7p8Li#Yi)z$%nQ;>3@GrFb*4Bu}VRzC9NtHDjZX<9x-HnC; zFk{3o{i&X-fv6d%tOCa#v`_HIXP|-mqZv}q0pobJ!~oTOtZ+yS9|2!;F3n+Wf5c!Q z+>(E8OM!4pM7UcO61g8sY@oz_Ck;g`>6D_dj^I2Re9=(A2Oz0@8&sU_L3ws7y&lX- za7=8kJ|K#;Dmv(jui4zy%+QeKg50l)ymrj|xZr#8JJ=p$MC6FYiJ^{uOXcVjQI(A2 z@*DQ4G%5{h6)T-`#;A0{Wm?G-mpeL__)j~6JRUNROUsZR=2APuUgmxKd; z8kvaUq``X8kLCoY4B|SFu`1o{!Fp_qo<~%!Y@l_w zXV#S46SvO=`yzv-qf@l7q7|bXFXmHm!WkpCrrsIkgfa0Q8z06gA4?6(aAS21S z`Mj3*R}yM-RMvOH5}S?>ju1{{G;=8l}OQ4aYNXGOhmxdLf1MZ2kBwS8RPTGZd~o4?r- z^(_A>{Qp;)o_|9JrvI<{jQhum{io?UF9&NiNhqX%|CRv}C50V-vh zk0yr}VUnXa_#!Q%krXo|~?`-uWBGpQ6k++zWtP>ge z$nB+}YF;fITnzE=&jtxTkm#p@c;1nN-Q=|c!5i$YX3DuXNr7ZKr++>1Q1frSJ8jI`mRiAhdfUR%FosJ#l-53w1aoGs4 zuP{+iCQ??Vm?=bIsuDo}mDav{EfLH8d5{^vM)DRcLT6DliP1mn>f6&-G*uaR@><*< zt9!M_-B=6-;fFb6#?be$UD|HwnG-e0xl!nHC>)4&K{q?_yGoDbS+ewy{p)@a7G-yY znPR0P8gg8xT$5IrdY)7)xplNkAgNIj_LTZC$+VPM@wa=xW?;HqhjNkpFf@n9wUK5^ zza~)3YL$9M6!0eH(y!rne^bi-dnQQiCQ85)y--ww6CcVo+Nsp9kq5N4t00NuvRZ*= zqgA6noaxdhFVjZYDmrz8%{*3176@iqr2khAT=T{@;jOI5>#7O1rH7V#NSR(PKm?M8WSS z9jJ*|R`aa9Vo97myF#=Bt?XFQ_fBTMnzbx@CmNk(xUkSMN-#E2Cz)7tt4zRfDU~FlB*zfzfFAXJ+Ks$@8};+1)iBT`Omb1 zW?4^5cPYM@rF82MTqKrb&gzqHt|VhKoh`&N_?5?$Jb8e-!f1b%WJ*~c-jNvgSq(uu z^pCB;O@^%jU^(p?^Vtpo@UppC1>op2+d6?VzD^Mw?@R-mqXlQA>^EI>eYC9hpV1MQ z<_e21juEexS=Vq-=id6fe+R4P3{(z_b zRyGjn)RjZONu7jAP%jdlSn!CM71}%Gf}k_UzEv!vXgC;v4u>)hypa6)TJ=U}eyH7k!u> z@UOJ0O%S>zU`ONdSTneh8_*6owb8x5(f8Xvf~3{N+p#>rF7>c2K$-V@hOG#TMl6D< zKv!N;&G{SlWF&txcMPtu>|bCoHY8BGY63eAVy`oK*>eY)rF-KcaiIN+FRT4TWnT;? zk5!@p{e1Fqv_o)k)^xs%>R}w#nB8dH1(kAsUG9&52i(27RYq_qil)S*J!WBXVc)6M zisqT6N6)s#tgcK#*)cSVfeg`%>MyFxXqetjx6S55VN8 zIcPpj63&wJfNZ851G<)YLp((MM6+ID5Q_oy)o5e}Ml=~&9mwK)5dlM&4x~5K?6?Qt^(cmHH}l*bnGfd= zLR)4zn;2)m1gTeLyF&TrRf1g=fblD}a8$zP%X=W0%tS<2K0QASu)jFu=yxFl;eV~; zQ|JC)jJ;EnDA2O4S+;GvYL#uk9OIh; zDeFFA(F`Oz8`2wC-|dgCJ3!OKWXz1 zO`4iGiR}^X?!df9PHa5Y*V^xUZ#O5Vo~v96%IJCCS(@`)e0%R+EeRK_%|X8lKH0RD zad=-*F6zzb>E@pgyU=^dkm4=d%B1C`A(}_qvl=Kq`}Gyga4OS1N0{|;yW}aMI1y`P z+lhJNvK9NlwiPoN{uu2%y7m2_gF!!}_)l`+zr*LS(*G|zPcr8Czx<%*oZ35UqrB>P z3X4me00~pDG!RE|MRB-t9HYpV@B~sZDff%pM^=k^747Xif0WeGR@jje6MlZ)UtDmo?_j~kaNMJtrhv`LoWRpz#hex+Z<)6_{2ilr$^VUv^h_16om(u2! z9_Hu2#X7sJ%P;>he%ojCFUYWY_o8Kj8ejLRIQt;(Vf?NRCZ+q@BH+IU|EhLvH>jDH zevC-ndT@EJu+!7I)sZ+iS3y$kcIEdZ6pS0M#8F>~P~W1^!80OwG^hwg9+x7BRs=?Tzqyf?i<8h#5#6CD`T z6zD=WaBm2r+O=oS2^>&^3HgD5NE1e>X5wVkW~BnAWr9WvsJB+F?deKm(cSnj`NmZIPUTc&qL*V;jC&9 z$dPx|OgT>$_ip6DIYtIM6ua^yq`4S_fsKo~Az_L@!I1W9VpU>02~{U0$fx@jmd{kC zMY4%1DIk{gBTq73CVtkTTruRpM~DQe*3CnZVY<_~UU9(oItB6t5NkFbgzrqXvzat>rWj{b>of-3KC%82o_6>^5t`-O9P!sZ&ZXq9)>UCgxkV`={4=>nbz0nb|@cwMflyGQ`N^_)6yYwaXith z(nblvMFH~Uua}dlhd{MGMMw3jHBO@7n;^d5)VhF)p=?8BA3Y8vJt>kRAz%+AMwDI+ z>Ff*bM-gEWOxFk@G@2FNscj24=Bq$kzZ%vUC2dQJsjVq-KQjIWrl6}$h-6MisFq72 z76;p^fq~fBb!7naK`h!C72Z}v~ z13<51NFPaT43405g=7xjL%>;d1}WgSAp|(ORu)8#Y$*=pQmP741HClBI0E~5AnM9# z)BxWW=elaw=~P-WxOtFtBx!A9JY)CMmfPI2olE=}ENu4i($L+2>K&w;Q1tf0{DrJ&o1! zJyJVjQFDdxYkmwuiAa3y!Y7Fucwzu}41Q?9HQwJfc739CY0LJsiS^pP5VOR-b`;eg zBx{DrL11X6@a|kAWAzk*v;i4WcLQV3EiICKlYU6I(r3@Tt$;ENXn zxA%3XA4mphC5J|kft(p-kcWK^&NdmRTAt>bFY~L@^VbM&yK(3Tczrf&a}7~Uk!Y#V zk{jvIiRD;v&e1pLSq!9TxPx{I%GP2Jco+8geq^QvX97f&SJK|-TZgqH+zi6P546D9 zhH-faPILSK+{TkMEjC(I?!3T_Yuuhk3UO%K(!X)yLy<)ti2>Jo^$v<0X<^pzgP;?y zSU|&%XpLNX?tD*O(HCV8PUU57{&;w77bDrig+j|i9!S{`HwkGDNY0EEaMt6sAz%@5VOI;ad)aE|IN+ztcscY{-f0f01l+z0w%aIM_oLG?hs+rl> zex(fdeh*KRTjc#5?99HVyS7`B^pmzd#2^~zs?lt`?cu|!S z_^BeMy#HPDg0!Qdo-&kA8tNI-m2Z_>gQboldTd*$%IarxCHC{}UYu;K+lX`)5tr`f zdn)*rtZAXdf|Uudw!CoS7p^|Hwt_sbY6i?NA$ASQ|6!0`3|+|!s7lAQXgeE4eeAq8 zk~9H0^r=(nEgS>YUCTSbEH0<#?T%Xs-Klk6%?y|jq!1=FZLV#>5&wg@b;QO=`2;*Q zej=hg84v!Yvw5FXKp-m_C_-M+^rli}jMPulm7`I6E;9A!yU?)-3w{{4mY^NO3zw~7T zCp23v-llSQQKedi-+>7f2(ia?siU8OZuX`@5c_R)^?Ab~k4-3?rxhbX>8V_$t0CLrD-8@ZhY6P}jiS7C3KBsK{sV>dh0bL?K*RhV8oFwW@W1LZ@jA1o$bpPdCC`8@l99? z8kS6s&WShe=(#jIkKE@F?cZ+dM(9MdpwM>Kmm)at(Z~c}J~bKoMl9wTAL$`P@6;{5 zspG+K53|@tO7#!=6jJIMprjKGC){yUorNe9oZvX#stx<3D0didJKikueavD*UmEu} zB{G+-QB7Q{aTPc`ZYCHbb4-PU2OBr=@7~YT_{2WQ+uU4M-`~Msz$4E^*Z-tD|2t$6 z3+w+HLlvt_{eNSqHCQXlOqB9aTl)kNoK3(h7#NTp9CnKr7#@pqRmIt>kJVD0CGqby zZ9RrivPjYfwb+nrbVD z)=%%^CY|5g8(oRN1<#zb5Fx>O)J9_uimTB zzh8Y-(kir`tK0i~8{63IglyCp{e5Va_w&*0RQgBm1XE>{XYue0zuH z7#cs$4=j?WD;-+ioP0NXYES;?V7qW$$FNe}fGU)KmvdaeyYIs3?M4leE!aY8WLB{a zuP$!FRfTmhfD0=z% z)F}9pp(_}xnYZRdP2cq4LoGlZT0-DT1$6K}10(AUyopPO-aE&u zlq+dY3)AwEJLsnpHB!_yW(jzN=)Qy?b?c|O(GI~L?q%}qYM8PvA8*w-I`=;5!(0cZ zrB2)54esF$9Tg6Z(BJFLjR#uPz|{T{K2~RZ;~h!C%-(%^Xyeg7mL;Ka>eTMI!Ti+#E7k_ z?zVIJ;(BW%{)H(dULns4IQCG52Hwqf!#h``1AgrCTWx%_K}U}O#P@~@!7T?7%6mmp zu-#P&tJ;*z2W&aBET1+D#s4l%bq4caybYlq5!|u1z>vNbxeD#!ia!n1UFf$ZQj_M5 z)i~LP@z6JUXw!_>*!d&XtYK>fhvw^{GZ=emE1p-OY@t{!A!d3y2Pc?tnc&|}|9 zG~K9fHNfy$W4`u=bf=LAXOwU`3+jS6Sz)B~*KPoI6Z>Bn?)Zrz z`yB^nDeW3%l;9n{xA#D%w<{>Zodsz@F#wRm*CFkDTv18WxKx3Dy|C+ANxKA`Syy%T ziOfUp5jrixRd8^4IgR;gn0jgl3l_YdRx1Lo;F=T1`il8K2-b;n~m_|`4(dy!2Jzm zW5>!FQ=sX_6*cyJrYb=@G@@dd` zp5FE)3Nmzu4Q>;3jNrlgd+=FJ!g1O6=oOCUH?dHd+5Ex?ptPcmfx9gpKcRd|E3`p2 z^iT`gob~Y~Cwg}ruhzRZX!Uq#=oW>G-jveM94uG#5q21=9MkMDDXhg<4 zRy_fwGnKW*BJE4}Jw7n;gQkfv;UO}#CdqPUrO1dB8?I!|^({t|a{cJ!H3nwHW?<~5 zNcwD@OJth7n^iz%lRp-AKose|czJP@h9Y>|YK1L$z6ohVa?E94gd~e`UNJbtIvnU8-<2FEA$`HbIVnC4~$xw2c67(B^Ti9#_apRK-JfF{l zIJ{kV8|!59-HFJi6@oYyr5MD}fbqZ(U^^llb}Jv~cmPN4p>-jNV_ezaWG+Arni%h| zOCj*&yIx2aF}N-;VK^vX1Sytuq@xG4wSkrfU?g8y5QTGr>^{@2o=6mI(^r+`<6n}y%=D?V#KrCV>1O^!1GWgjK zQA#LxUeZWGmY9$iA#nHI`3nrEVpc8GU{sJ3H57))Kh{DZiI5EHGZ~J#sK<)#^>QHf=;mbzz6ERQMKNTjCjcJS?dFyP>=m0a? z!AL%FQ8IQevIk|y9v`-j1pQgWY(1)B0(EK~%wJ3l`#+J8SOx9-cb9TmS>Rtd;29r@zh9H-MIF0|nd z0sQ&TlgO(q-a-giS6wQd4*vey@_oFl$9*Vun3Ai^)wPb=Wv#8L32ChxL;DL3vKV+h z;}9G+^?=&hgyGsgwov~CRC1oy?-3}oWC0R{wkoT(HV{~B_RC?Cr^8>eP;B&kkXCB$j zc!X81WP%&&Yemt0wTXDv_~BI+G*c!;V-~TGe!Z-THQpA!YHoWUBh^EZD(m=ywO15- z(8~(iqT^xnp9v>y-CExsLQpbfFS~RhNa3Yqu5u^K9s)VAbul`|Y$`HWKcb{N!bnJ* z6*xG2x4*u1j#=0+7&X{1(Bd>WxMDc?NYL!#()>nzw51;LibX7@n2Hne3sX7F&gP~7 z0zp;=O^U5aDf1wF(R8|BI=i=T&{o`it?ffVFRztx9v4%Sk0ux|d1Mqlk$*DGd&Ua* z@PY{IkxH_F4ZPuv)x)b9Tc> zu`>2?dqTsezJLxmf1a!l^thu1k4<-xk2Q-A%n~dhA3cC28ov9dm&oUBY%Ef{(3*5z zRh0gkLR`quosgBdjf4H*tQ}Y5YOhC7E5UoLkV~unIjd;5(m#oLNv1qto2q5Y&wAs4 z_#J=e`3K}1Qw8QzJ~x;r84SR#QJL9fthPa)sc2B!uyN3qPcEVI**SWTo+_${$Z$8B zu$Gn?zWy{iK^-Z|i%8b+Q7B(m(K^2gt?>sLYEAwfI;uxOpth3+a6gTA{g<3g^e19C z5gWZdtymbc_v`qVjl~`EKL|5UB%k$P~Y!Tq?$4-=EZ-a;CryHt_lsEGpE zO3n@3!rR+|)mx*a@Fp~8r&k1Hm89~fnZnNR-1|)-$Ba$$M2cdAXOl#;>ciH?+PORfFPN96rM-r@?m-ku9gk zNYxc5Fpm8IXw!XrD*8Ajw@z)uTz4~U z(uIbemgs+yf*+bw%RO|GYMLa|&@ARU;w#7vNxkSIn2U39+m**lv)ab?-z{RQZdIaCXv zgTg67V5kcLUK8ZA(^I*WpnAjYpHaFY!Mdz9}0lnpNUuk3YWElKYWtGJIHxo(d(Suv1oli1> zb5)b?@%yiPqa0uFq`9K%whh`Elvowv> zh5khN5a|DvyOn|xB)%=pbD=D27ScIt13~n1bgXd1hAJM`erq#ltq)3(no2w(zUQ29 zo(i;zao;-9>{^-f)p5k0vvYykG>vM^X9E8Kdh+|!OX%Ngng)CFSWB665&HAgWBG9( zFOG8cx6(I^2g28g0~_twPgq~fV1|e7eP!B$ft;_+fsURD$FWah;{I5@HpRv!LRa9 z*uY0V1GqdgcncCD(Gul&khlu2(ee2b@n0pp4gJzvcbtR#L}|0mF5|a)6LONmAgu#_ z&v<)duf!Us+W@TB2Va>o8-CbM5R6~9LCkG$9XXubOheS^`cveW{Cm8~ZFDeoBhY<3 zOZss%c3>Z$gyema&q{PGVf)3toJWD}kcfdA&)Cd-#DMr}->N zo=}I%H2g5szqlX~cWuTQAO>7A#G}NO!ZVHC+%Sj&siD6K3CTzFtV8~2^^x>kTl#!l zMhf=6v|WUNVJ2B7M7DrEF5mA&gOdbXu9!{RcbZjy$Jm=|Ml+`+$;DYVVt!i0A*nRq zW&wHG*5w(R+)Yq!!okU(Qc_@(MF3I#d}`$dK18X<&BUM9yY&Di0g%v9b^ok-QSK$3 zn$@!G8C;9aRDu?mnd+^eV(%r@E0ZF?Gljb5Rz67y@w@u9l2@?t?TGYxKhjMPmOlNb z#{1uqM;QNqheYa{wufz~KL1<I?SCGemTF6f&;BCf0Oe=>L}ShFGGNoz@B zO@F*+WmX2JAbc!vCo1$W!%CxV6Ec-3qilDkpk$hLN=PzP1_-uL+u z`nWNjc&i>wpv}WAr8azY;3+4kul*Yx!E@Jm%mzxyd5(bd!Th{|r#X?`Y@A@z?e1OS zQibZ;KUqX##kk(1D~>b$yox!uP9o9IDE%1e4UYTB!TbW){Noi^ z4wg7FymF|0lI)S*$Tm#Cj)C3jDE+=1`zR5ZcIN9qgDrQ+>o1R-)1ORrFttc9n>I0(Sm)2N2zF3cL9#!@Q? z^jdp83QiC^yUI~=-iGAD&dH-(2*_~S4rYk?KI9B8{eV<0#fRWfQ)zrL#t zLp2_H_4~r}jZtl1>rHn+76)8NT<&{6JgUx4_gDQY?EMH8x;3}s*dm|I63exFkPU#` zZv3=ixa4LXz;#a?bEp6S8wd;V1uS7j%gHughJ70L9`PX_Wng&+<-tD$eawJ|SYxIi zts5&cNmXF-{1c&VX6x@iA>->sX<0)02sE|GPpC!O z4deia$PHD7V_WOaZXZKHey;{2pF;uqUdj7ZsbiFAhHV10Zzy+6Ql%K6$CI>E4^A|DcU+b}}J=s%S#%NN2!Mtm%@^ z8oj+2W09c|#k>8_n^sbf{gBln2 z6u)7N!O##pKbAc5u!8%s71)L)LB^|MR&92F+u_&f_0nW=iUUiz-3|p-Cj^@B?9O;b zv{CuN^g85?$KNOd-rNGU%Pt>_!(oYv`ohoy!ls**`R0aV;(BW#ki7B-&4f)#p2Oo% zqlg)p;M&1a=GM4T=h{%s?wazpqb2HXeZ|1$qIIft*w1O!Kdl0&G{;+m{6&vUhP)K5!wW)762JMQhwHT%Bn|W(WFOf#dV_|*6g*(E{W{gQfEoH# zr6vg9Bb^UEs&v-Rum3wxjDh zOOAIvqH9P8^=4R?a!p`fPijgbxv?Fo<@rwNz?H^5PPm-oS*<4?>o#$d$3lr#Mft%S zA9q=KNFKO=VS=}rZgHdCgANiZgs>P5MIsahTasaWUDm7Ji_eSAmAUZFQBNKyb zVYU&IPLMdMHBq-@JWd#ueAdxBkxN4uF1B0}>cy36)b zB30(h*E{h~6;-6``{KD4u=h~vJjQUzLxy5a%(0}gv$|}v$)wy_+uIGo$ZAUoBV5J! zXWL($h4U@*JsY(cscBF4w@Eb~>0YR!zBASkFk8|*_gtq&-;#fp??PQ-FqiMChQHIL*Xn4}~r zy2!O-mzvO<&>JCphd0)!pQ$8_b32WSh==SXey~y>$d*Xj!`PR(T+)} z1ifJXo{o#Nh-GUpXj_@~%q#bJD!S9PqPwmK>#HZvk&Be&ZZsHj@_svM!majWX#J#D z^&*tP@2AdRAc^J`hyNs<{yS*Kzd*YGd4pZ7u5Nq8isZAaOL%0wtQLt#hdZ-q6Gvm> z4bzONHj#er}HKk3V#xj?U+!0>=x=9kw3}UJkK9Vycdp zG`h$4xwnZg(r1`5>R#sy;f7{6?tpt$$v1EdKWxtYO`D(?^5B9_Sv+vt=|a9>cl9q4 z`}D`x{~&`Ds$~RK%WM-v9@f}A1xYONT^hsq@k|Te1Q854XqlL2ac!? zfE+sQ(0piowvI7*pZ>-9GtAofc+}Q*#BnzRidkMT6kp>4Pug(8KIb1jBm|YN{-9l; zec=I&bV)y)56)TXdBj@v$>!Ve8xuTQY)$Cfjo&t$8(PkL`}sLcj7MqKjY5O%?_LW9 zNJU&}o_laKH%&}-GGvC3_pYBG@Hf$YzWywR=*N6>O{Ifv8%v8vIaYeF^gYb%*3B)NY(K%+P|;Rb@vaD8S3Ft;gr?nEK~PAhS$MFr z<&Ia|(d06?HbU!KVvWw+0SG`j(88WEVY;M7|EC5^rLcneJY*)kb)iZ2cV8M&qE|;! zAiyJ<%3)5s+hiI1624X)Ii*PR9nj{mjtBqNl~Xj-<0`9>{aLhD5iAii7(>k(2Nh|2hi)rN7j# zTpC=??wdLCe&Q4pnVVfuY~<*x6VeCThp-`^Efwv6Enhw2>qD36=kLo%6W{kyy)qV4 za?K50SZ7Ds9c7iGyPGSynwF1{Qb$gYt83Q}Sgtwg;I|Q^M^ARYK^`x5U^OlHj;E8H zpb47g>)2gBo#YXL$Yb_pT`5ojO0^J%0q%*t$Hz&xtr;JIAl@W&x|Lsao^VhrHi(|bA~rk;#sKqaq$&LLg2YfDpa*jY$GAtV7hsF;`)eFsj2fL> zn)GhV$2vNK^vpg2sbI*j4OWAs3cd`NJ`KC{gYz9c!tA0YH_to>dyFcKYTJgfojNe$ z=LEok;{rw^v*Ei zD9Sl_X>2kyfn@Oj&#msdVCV_cMaVi3H_T~)c}~6VpS93QNWaLJd4@*VRo7dqA|z`_ ziG(Vf9!bT%rIxz1Frl}Q!`J<-yofoH-PE_MWz@xkqpivqYa6PMVTAME`w zVby%LHI6*^dxp5i2wq4hl>{Jv6Rb)| zPY~Q*dOG1duM~nRNZgV+z2TG9B#0E8#|&O=?s#>yomk2+_9tnX2SoPSkc3YzKceTP zs6){`mogRQ(2fxSrd7OI!VQr(*yy_`AU-+8?5#QmC>Zc7dA1MV&hT35vKBB;IDyKr zuL*dLe`fvW8R`eYg{>Kc?&&KbV?EqKR)Q{ZXK=9ePq}H#cj|{aZjr?TvsfPl zBto3Kwb5xC#v_*Pcdcuitr7Q0W0ks0gL+)?iM|f&xwp@(sFd&9gnGOGW4M&x1cU`F zdOSjW@c&$cmJ<4BjgJ{cILsVXjfCtp; z86+^hOkm1&)ecIID)C_WZW92qBiF9u6R(b@u}jr3kqsOCbo|SWBV~y6#D`Wix1d97 zL24ssVS2+U-B3tcruTE_!HXl(_r!B~7O&&v=FWi59NyhlJ*VhAM5NBet0g-)Fdsy1l|@`jcyCxlg?B}f zELI9=r!AX8OQ)t_7QV%@3vfEDMNRAaJfLlP4wjp!DRq3O&ZBt0UriN$tN zY5hsiZ%yLb2L5gB;>6SO50a*JK1|QFQcyGW?wjOl2p8fH)Qb4yP(D?*(UpGGBz^YF zWZ;oxf9Cpu04}kDLz0P{gN{Oi4t?fnJe%?nSi6@(mz)6KbF4*YW@UMPs!u|hsv#S) z6xl^hbF70ofyhv`3IMC7z_fV?CByKxaq~AOrE&O6EQBs%O#`;Z%XOOrk+Qk zan(;E0vF1JZ`!jD<_ZXF@Kz`=5Wm49`E-jP2FC1MYHwny54I}6q1c_0-v)2P?GmftaeY8VNCyQey2ZsP*kVQEoV@Xvx}V-b@RjcuV*IISC;JZl;Gs z9AY3S(`~F;M*Tpj7Rz-nuO61QMaJ`NYp7su zl()Bfi@dH7+%t($@bpCE*SO@n4ekbr$Ovf*T#=BwF=&X99V7yg#ierZbuX|R*|9zX zJFOqb2Jt)b#y1=IeTs@w0_?HppHRSaDFu>i57ikM>}u>~V~ZLZrrtE)(2q;09ivLH zN2-Ap)2EFyy0=tiH^4Fe6oeXLF@%3x2graQ!I(S$SlP0% z8hjpZxm7d{YOw5lOoGAkv2=;*UveeCBk{muvm=)lYU&9KZWn*+*FcR+RD>L(%pNFa zaS{d`Jb(cKqc&r=^D)Tc>u@yGjLa7`Ni59qLPKaba=t;JfC;d#GlLsd zx>ct9obka$A25C(3Y0W^gdS_7WBcB5Op-=Q*8v9|jys!Wf(#HGItPKeg30T34P%42LV#c;}-VqYe_>>Vc4V9r4$8 zN*VKp-{?B!_<7_EH#Z*QP@8N$4eFxiN@{zb05sk`_7ATi1Cn}_HdD!tV+e@43H>f< zVtrJdzXYLL^ia3b=o;?eX7{pDfzZh#=5|l ziMSVnN$kIzPCIKtZX|rI(4o;hpSHl5w=@)PVqP-z++!0bh2=J>MH~hRPdX6c45xce z=9S*>z}QqJ8n7BraRIl3UhuyPfEzM*qK7c|h_;Qc{Q2_boDH`{+UHI^rLCbmy)MmKbf_Eh{VjA0Wy zs0^2mO`ebaG&*VkDxN6wB6Km7bAP~>`G6{pK>3ZQFO+z^ff{3uOr4*iR!nJcs4!RF z`}@4a%eXu=WD84s)Iftk|40jKUdelRWO!13uaa7X3l?(X**DxtOA zbt8;8^Y4I+Q{TRh9N8P4ag?kg@T~rh?uQb3?6r}S)1P^Z4q%3%X6do83Wcnf`LCxX z*k@)E?MOFqV2{GT&&ODIzdq13aEEGYVtZJ_7w2_YeZbPg;iu>yBOkDuH6pa7(=Q_- zH(Ee)6`tqwWZ<1>T&Ay=#hGIn4&J^^4_!X%)*q4&Qn78cOyB3 z)M4`pwn<@>1Yt>~5kjxoD^+{j%Xht9=TX{uB72m@lgGPN$nNKmVzSH z1b+2aeEBOi)SCH!w9%A^?p!2dO(y(bWmdDJdZ9l%f;^|rud>JFPWgf zs%^Oo*g;h51tWDA-m8n~eD!2*=(tg!b1qDYUIYtMe)-r#lL7)MBK(0PFv#)!`xfU= zP?t5VRBjLVCR`wNY8!hkL02(Gz8JTk%YonXj!g_{UGksW@P8Gp&%nmQ^q<@C+h0sI zh65?2Ma@7oGf#_pe)w%Xl+2dki3H;D^|sy~CLGC>2Ia0zG&4UiXqxePJ9ZqOEbwlR z)`LorpEoMxN*Wd#w#sSy=j-o_)Nb>O=COhv>x$>wSH2pQRT>onEK|F9j)ThEXJNA|cLUH%sL?mImCg{5-W%5H zX4x~t_G@?@eqKa9lEW=JK&IB|Leq>2JgI4B-Qhew@^9bz@AhggjgmYQOSa?sGP}Hj z8rw+^IsBL7&-z__8iqK*n3XG_2*@19v+X(Q5^0Z|+HTgSQ!cC|mTDI&zO@QNLgff8O3{_F$L2FjcJ{YGKuRfaoY$KMe;&>jtRp7Cgek|9 zd~(W^{*~!w44SSowF$;YbMx}wt!EKkn-ma#DW!8MkalmAc~TN;V|U((g3M(wqlh5V zL5An+b=nKo_SgMRedfvcgJZM#5ceg3hl%h0?Ugvk6B_Rj$GO7ufxB<-9D$DjH&wB=j#RCyXwe!(&U zapz=Gw>F2G~D0`PEP#=Y6h3)`Q^rnDN0~jgWPRVXd9#Ei))!k?t{(Q!84vr6VSY7_edpyjo$UsxtIOoUzK{Q!gozHD~wq&b5ZT4J1 ze*g~C_O`%jP676YG7##s<=kT(GUUP?ckHN zjFsS7`4;!2sf-A--5%E@`Ui5(Cdjg^`G&Pq0&4VTkrugKC&o&M3s;^4%lD+X;4ym| zLhmIdN3B#oEK$i2_1wg<-sLnv!;S1%>)Zs)-Rcf;RcG0+-_3U&^!K%XJNuW-VV+>oI%0R$k-#g5Vl!KL}Gk4q~KLz6+*fBt~^ z?}5tZl4imD)Wu`)1}4hCxdaRPHl&U=AF)?LSHbVg`0bLOp?W(Gy|!=Z_01FrsatD$ zOp7UkwzuEL+LNH)h|tZ3w&HTKlO$>8q9kFIT3?nDbrC*ZPnO_O+GJSERR{lO=larY z)eBl}d5HFja)TL1hX_@FQ@I*-?PKb8n0|5ndX7D*hTCm;ve|#S4#tugo`{4fA*`k; zpX;@Gy$MJ#<`b$)iafb#F*n@zBEaIDe;qq|S$erabYC`DwLLMIf0S_GDYQFY?=DDu z>%ZcY-wBzC&F^m4`utqbDJLTW{HOl--z816vH!1cYPE(`;%3|b6SvZ$oD7N#k92er z=Ww+hp=4=m?Lx(2s!1dDID zIqLF%Ll<42>zGs$ctHj-k^&s?n-=3uw@jg0S2h`~`I@Ii^9n6n&US$g) zNQ5UGZbEF}g|=Dgy-E^KJJy?KZvyRrH0ZNC;eU`6(in2uZz?oRxZN*^HQdH09)u^Y zQnJu#4kME()D+a}T}yObS<>BV>{u5&tHWtR_NwkuVl4?zEaR!j>ug>>E7ocH0do2_ z25QA)y4U5+&9vnjQQR5RYBb>25(WlfH52Nk+ED6JNT5F|$QL=Z?~1LhJEPA9i-AUL z?i%wgU5gs|YV6bgEQeTcw~1&|&Pb-U4~eu&#cVKvGLE2DVGA%w;cdojP*upibO(fV zNniAPe;aLdV|LI<(T_aOx2_kp*{o!*V>dLtTHDAkUVA3k;+LPhYt||_U6O!*Y^$!l z1yjM_6(XBjn|^%snhaiXFWSYRyP$i8_O^9qg)dGg2g|Og2nFYVSW6rlR$F8lH;i4= z7%A*c=;vN@-lP`XvAQnFIdHBoy;7!@I8F*h*Zq9rr6?7fH!y&2O${+)uSvhww;E>Y zVyGe{RZX47d+xhps6sqR<^BY1JzN3fhmn zpQZhEFwMCV^wa3go3l8ay@=tY2d`Xa@tT(UV6@^w7+39_V?cQ0?|FAsO7)THrHS#r6%~|i}h|1^^Pw$e41GIqi@W*=ia)0 zjYU*qH&x8uaNrdrQ`3m*aj6ky>L>q`dNtLDcHe+jJ0!KQVfL6I9wFnSoa?$+m5;K_8-KJy3KBen+M4RjKgcp7r{&DN@)l zwmEUVdFEOoWgW8s9KTPv9Nx^2(wW4#BY)7UqPEgHtRl?T;;1yw9f;Cf7LaC-wXCo3 z+XQ5Mzn~Q1fdDyEsU08}Z%qK^id@k!sH#*Hbkhk>meb@;XErcY{OHl*;=g4n*l2n( z3S=8_gGw>C{}q~yL>FZ6)M*Dk%`c&>L9is_2g?&6Hb{t7F@`M<)0%6|%%Pth;$f0Y z6Kn$>15t-LrkREBVBxWH{6e9L=6QeeC}VP`MNywbUFi^PO%7(P&LX#f?U|dFL?

  • lNH`SG;^qz{8IP9J|LdTG>38cR3 zmBh?dG`Yh!wI$R$y0<)a{@a*^X=fduD>A5>1tfOhXx#R^#+J;Xf~v6$+AfiS)jcgz zOR66F+1UeAHwcb^LR1#hi~CrQ{DrtyO{q&l1q<~_SxcCm7q3>{DO*!Te38-qBRpzFYk#0|%jH>Wp0Y?}z@eZ`+@*9(|~@ zr$-orP!1ga;Q-!S&{?VX?N?@{~%2qK<2oQ{=!VRnLaBN6ERnIa)1&5;4&IcZGkG0xx6 zkD=az1J$R}+wT|<8ai<#^irdbk%d3k=d^j=c+^HC4Og87dO(C$C`9?-gjbc=vv*dn z^Bos4xCcVDVHUDyUX<<&5$nr7k2$@X02+ZJcR<)eYqQ^!;vr7TMCn=5DJ^x4uM}(Y zh@m#!4zjMEY;NK=9ZmWkoI0o){Z1M=@4_PwS4R(hIW$l__~6V@_@?eNQVx@vVlpbM z(v8prS`FHI+YppM2qCx}z>3zYsR4$6WwqCN98CBe3^FITUh?mT2KS<15pw!DSnoG8 zQex~qfE_8uX1GM)R_#GK6)L+RIZFW{IBU<`#t_eXBXJtM0XhAld0cI-Xa&n;d~(7> zRy32Lf>^|`fm(SnFghlC4l2qeSj?_$o+cDyV5ZtT-@>a)$g_h zb72rw9Pfdw{CR07{$lc{2Da;0e)%yoB#Q~*LK0|FqyoJw+(GYjgn>;TY4q+LHc;H5 zfGc4ZvDdfq`@P+r9Coh3whwts)xr|%*6xj-h<6R;Pm-MZL3lzAU#E;Esh9Kbm5mX$^$Za%K{%olR~Re( zAi@P0WPcQ4ypG(nz&x^WY=jYskQuv=l~$UdP#C14U>!skV(8`5?gef^?&b0T#kqqi z9n#{ODdpYqz3O9;qf!m7ZvX8h7}kggqVX4S#XWLI^QYac075t@|B;_*&2JaKU^tNsj0TO_k zb=JITyfE<}$~riRJMq)>-L@Tp05Epa&y)bDBQ*xVRtC0QiqkvDSJyScuY)Bwew97F z{kfi2pOSRq!)>S6%L$54s(0IE>LOIPXsGxcoZ)rdl$K1ar@{BlYS}zYB22w4SgF2} z87I6x=059d6@dWAf#wie7lvn9+3EKehjNoo|HIAp#5HNNQ`pqc_>KeToG=I-hv)gy zViDv1D}gI#n0r!ZWM#pQg7qr3@m{ZXUzmB3PwJ0l!#Ej}zCcK1d!k9bMA%I^&)pb4!whcASpA{+>S@i6&seYp)M zQ}O>7$}9~3Qzu1W!)`U>G0@wk2~C)2_jwaqVT|>$J?&@v z+k@nhAO$FW7@e)!aUXRHZ8zVH*@#y6kGhoi(sYsb`aPYQGJe8wQ(v5D)5t8Hyn|$t zIvwU^=%;bV{+Hoq6NQ+}yj{Hxh$M-t8b$qG|#5!`>0wu!(cw z0D}$%H?$}O0w~{eG`kp`!(~+`noGr9hi^!IuTnm2q3TVU(l8Ni zExs4GH}1}Z<7(4bqGh9X8T<1&xb&ja&0I4$=&MtcpabYXhOUi zXuhoA8qa>QTI7Dtr~~ges(8otkF<+*UPW#E1&0nkoS4=QV6!M?_`kE)43yKg=DmA{ zAA{Eo>+IBWT^%RfU>EXir2h{O^m*Jf@)P)D(Sv+(@1E$xKQf4&8iy&CtYR5U$R_CR zdH%^>BAo6Ee-c?z+^6a-JZgg z`5-fwOST!$U#0%qW6X4mJPYk(Nizvfh2=YhsA7`HkiwEnQwB!3F7y7AeNJ2e*%RcI zMv$j^-@41VxNnEn5*Ix0aoxrHuBf>{6Vw|$6Z4=vWgz3$YB~#oD@HGR6fAArHTI{l zf*SJ1oK&JY`HaS+Fg*FU;tZ3sr$FP{TQ*m3dpRra{2z_10dA)E71kq6Y0-SMR3xq3 z$2U+=w+Y{yzy`;j#q6asLqB=gQ)lYG)i+FfbrxSeEo8W!VWu&GU;54nX6KtJK;K<% z?fyPULw>t%@QiSd!Afb?#Llf>KI%hTyWL`Ct$P?Hl~DqOZb0Put;pCbs#hgU(iQ1 zz!yJ>MFc*5S=J)oOhPfpkqOFTAmc7tu#H?Li@yptB6(0#-`!R~>1+L;M}1jzLRqog zq3zL*aze7WWh95LgPJ5SD4os^Fx>xz2QX_R^( z9Q(=CzZxtia5JXZ)-!AXFq!yyX!C}{xR%D5h@rYv&}_$yOVe#{ibngRj#l#vj~Ur0 zFymZa^MOsw304cCMG(~{Lh4_P_-u{%sI0C*F-ZVzTJmF{29EO(MERSwPTQAlC_oG_ zXWZO|Z`z_Cs-4envVqJ7I%#U*6h=7Dh!{Yewc9xFj%I?#vlZ+7ZH8dY34$VJg&Q3R zNtbx}1Z~FkGPj#hkG1jJEB^sD1Jhl3oX zhaW9U9#m-eK(Q9W9aH4)ceR)3>PVgHWH30{5qZ%3+ds$F`yC;?QhP@hEGj6>cI?VV z*PcnS@Ub2VEs2svZR2D=?>L5$EL1J&J>Agdi>JROje8_Awhtd47gy));VsC0eEq_$ zfiN_6I7oW!B^-X@zorP=rE^Ex^xBfQprJMi+3>NTt}U-0_?6a{Mi;`N3WFU9!D*6# zTfK+UI4HTu$xcf|Mv8+&loILbIJ0Ql6(oMj93$y%I}nN*#|-<%I1#uhQGLxdl7`eF+klBQ6^y*VQ8=QskHP(e=LIDCo+qQ*xT%GP<6Vo%}&&rh;t;!v$ zrz`FyQ<20EQo?<@Usuj{eHMJ@7rB_UgmWEQ&P@McDdXg-tw86Zm}+LLcXNV0lpxKL zTH`5jBn(Z=6f?@OL1rCX zmqS2jOq7so%o&UzW5ENRaT0uNB0*<_IL^uv2eUjb%@)Zyw#2w62wl7qYcC*f_23&+ zC1|H2Xm9PBTi?TtZHrSFt#?t<(`uKlATl7z*f79dqvf?FRdQil@T580b0_ zTcPl|E5|G}H3S;;G@D+hUtXjwBqQ0>fJ{EP;_c=MG8V!k+RB4RjMbE;c0?ckozn?S zqvojzWA@TG_+>tw1t^{>jEq0da2|6YKB<3sBjP8oF;fy*-q0<2+4x`nPxJ=)&p-JR z`(CKcq=$I|oyG4@sO;A##5&8)n_|Sqg4Fn}%lwxIklH^Z+J}gJJHjl6wrNDHofF)X zJX^UGha0j%A|xi$I5E1{$evUf41M3Ugu@89I7$>Ih`M2^S}7sT*P0Ye-2vR zR~BN9JxE0M%ZR3SjOGb%lwQIBa5G%bS9q!JT~iTna~R57L>HR#j0de6D&8ukqERRd z{)Pinkg+39mO;0I8?gr+dvMk8qt?HSQrn@4={be|%J z3ieSfbc)mj&ZFoFhN2rvcf>0@AzG=3XWu_kw0l583lX*cF+%qWN zpbMYq{Q@Xnxpd^E7tXXwr>#&_auG7~sYxK%FnkuGZpVL3`BxPv{d^v#kAa+HOLE}w zhelrcwQY(=nkK-E7)3=Sjml;l)(9q@MuI42Q=o#oQ`T`M5avh6D1c6y^3>A&*;1$| zx;LaS^}*jvz|e~S+TlJb^h`n#)(jy6hGqF-Vi-et#}eeoD86+>+jtPAm=#o`?#AI0 zQlM0HD-JRy4&wo==neQfzwSfr-`9zIWW=jMPG`ioeoDc+x^%kr0w^ie zIr=L#t_yU}wL>k|YJS>3GI|JL(NZw^1p3R7_IYZ*C)Tc8oi8z7lIU6!MwHtpc_!#r zoJDTn1dfE}W|VY6G0TyuQ`{HJjUgvJ9f)Fw;Ak}mh7&Ya^27!8louNjoB3XZKf`>u zN5C}`+T{rux+b9U6E#nPOl?kOpi-%5yWTX#`|lg!awHSpx~CoT7jD_#*7t5CP7v~T z?;|>|r}{E~z`SP)?Gh>ULvp7}Ic1(Zb1)<5tcwX9%(8W!rLO$WUjwxbWzOqzy37mc zJAJ{~46O951Tn-em~}e{Mi$iRR$eb=)9t79z3u*S+-g1S@$oVI!^oj_BThh!q+ozU z0IkSsCe1>AjDt6>Ceiyg;q=U{@kYHr1cb4;cY_e>B0Uy=BJpZkM*Dg6C4W68%P(gA z-tl+zn|c4QiR*uAf@k9V?+UJerwOOSk^h_~?o8{Xf=?sDd?bcd>l-=O95huqjh*}@ zB!pxFSpaIgexA=)0e}&c+f?ar8L};=o}L~rL)Cg~o}~KobdOC_%uKYBtF8^6x4$ng zZ>OcInpBQ2ejG}oQd%s|)n7Y*Nj55<{ceBT8%pGy+%Zpmd1~2LHja8QUs!7fN^lPEIv5-QzJB!2kb2=uU@%3+h!G< z8mRBv9Os-?9;?eu-#+6NJNDm(iD!O(d=jVgJc^t(XXI z!D}IKuW6F1gnN4(Awiu02LHC`W)xMj%Ziig^dz6;<-Z)XK+yCkLT<`@sQ?do&t}=B ztFx$bc$H2}4yZBpLcj&7!|?(ubVhlQ7J_wLR6YtMO@H1amy zI&)1b1k6keR!5|X=H_h0w}uJRNiU|x=-vE#LyBV6GC(A9N#1EQA>P*f8-)>h8| zY9+gn7h3~ng+QO?W&Vqka}SM$Hn|utqrWlJ&(t|R1b^^1u93_HxUX9rJOH(}X|17W zlELxvB3h}jg+d{mcLP}~c`VR^AdV1TYn=vkLPDblQueabY5ORNp0DQbv=Mn?ZWJ3* z7P(V+*5#P%l$m^UPAMiN6s+4ZkfFH{@~q3B>4te}jE4(;z{2zyXJwQFWpUvs*gOmT z_;O#F$ZQi10=^YYFEfFGqWKAhUBo2`!q#|~u5o)8*som)3krN1ioa;G$}|y9zyFHd zy?!p+RV|_VJ_7}VUU(D{>Lw3g)GcV0W#Ey&ROzYlGmE8PLlx|xNgOjE9h~$o4Z^2u zq^6*<^xENdMADT^9xdUXzieVDQAY@n64AO`bB&Y{+B~VtHPI=iickab{H-lIZ~Q;(+SUse@y+AKh=+-bY*RN;FYxC(<#%OG2ja z`b%Y-e)8Sv?((>dK3eo+3UnEXbzi{PZ!(p?{guwz!*zcb5j1xHLCnyD5jX8wECqS> z<-fmdnp;G?h#~Hhd?a$!xu#D<{HO@I^M|V;lxNFRsBTt}E*(ok&K^LaJqHqx8;u1Q zN+JF1*jQ$gj8`zr7GMA@S{j7XK@V)DKm2rk?!g)(@7FFRiIG6OKmBf8vw^Wra0Y2< zbH}*Hsm}Id>_H$y@n_xpR4719h{Nsyr(5n-4_oZ%iTdWnrd^=ytGF)Ux{nt?hC3^q z2rjlUoN*9B<||fzLlg-p#=$#mwMZdg|H1%;Iutv>l4vRHa_;9db-2*8!w8d?tt(PA zg)3$-qzWUr1?t?R38WSW4E7sc11=Q?86{1`;pzP7yVsW`bcdu&{ zqx)hDb%Ow+GJ8pd(?o@{Klltd&Jb8!93!m7SmP<7!x;(wnmW7!si>^N1!#SaBg61Sw%>O}{S)V{tA7i5AOB$mm zF<59P7nfxd*fA)t48I12$y*qRX}ELK%pzA5F5nrHQ-n{Nmn}^Q0s^WTaS{xvHWP3fe7=+tb%519^N5%rCo^m^AHx1y z!-2-2ONKDAuPZPX00UkcgrDCA5#XS?mt$z%*wok_mgq zL|xdT<(9veGG)Mp68AtVo+j2qF6j8xCqC0vv+~KxIh3@(*oW7y%N+GNqp2y<-+XB2 zjrgWBU-T-yMe~ZlzdOd@ZMqFP1eXWI=Q{SU^gQaRSg!CCDoAEodoFPT0=4vPf7z62 zKX_>w)TZSVN}+)kzAES4qHF+^#2D_x)c~&hi(=p&HDNMYrQGh_dHt*tJ5>cPXOv^H zLq*Q#;;dd?z_?&fyRnD%Go)$l96~Q!5qxuIUo6Bt! zfjD|30sRXtJ!3RiFO9+&lD=;5w)rW<{|#sP~>C<_qqVYV47Z#-RtdTkT}HvvHHo< zCay9P{a%8h2|PX3%mFmGl|QQ`CnV{q@5oumdV$c=IU83#8W@DDmz|##!e~!ja|sMa zrwEXNwxDPSD#LMzUC~f4NrB`V6se97^xzs2#_)<-&Um~e9h3t?RSf{p4s9^df@MY* zI)Neng#y*se`!V#{X-NED7fXcgF*yAs|1eYKfsLBPZ^nLFffTW4NI5cR1P>e_{Bpr z2!ypU7a?8aOyuGTp@n+p%&QieI^Vnlwih*vMuuXrsz{QDbu`m?9$y$_>+$Nb`N!zZ z1Mc{z{2RaII|BAus7$V#eaS?Mm*P~pR1Jq+l(!)~oat@t3=c8ogSK>MBQ4O=gAvQ9 zFuoMsvcs)1^0z`vI8SYk2VNyGWb+!Ao*a+_NkEaQZe_jgDXvEsV{Nu~XW=6KwL2oD?-N6R5sTZBp>Nh=x>8iB>_M!ioz@+&@DqD$S zp%KZSbTMGeqSwE=_ydq>Aj+Xc3OEjG<K2*y!>98Kw@m`sQz`Fu~{aAefJFciBQ78;xj!YsyZDL{;WpgvYaISDUY z_gZ5QKeHuqNsL7@^Ix zb81oVs*=eCL9-bkDpP1RR8!E&@J|NDVxPc51KFvm;(>DB%${O7g3Qcb<6lQXDu!+bp1?*DxXTvA-q*i(*W-PSM7~Mm1p_(pL6!(kxZmplu5=&?*vgeiNXfo-=^oP^3<(W`{HU~ z^f0d-FV!{&FYMr}?D+0csU6kZmIoIj*HMw%m8-%=e~ousD0wGVh*@f1-;;UkUQ`+z^++4t!QMoo#bwq0#3d~&G z&m9)ryj3+<@h?v>H_4*#ajSlutt&_G_UATpUVPxPAydBZj#ht8l4RM2LMGawuUMBa z>nC-?Ei`W52t=(?e1MwSev9jDbk%A{!{5tn?v0J*)7-m z3T$s7DgmFdx3F|&n-6Q|0=zGE-QFvY@<%aKtlB{PwIVg)={r=L<{3M za>h4^W&ebRD9rK_@<8uI?gFlCa?(Sz^UZL(ZPYN^~Gh33u-n>4UEaJf*`~Kd%(<#N`U*4GLjl@9V z!2v#bW`78yhhF&V`4lVuH5Wp9H7$gg`_y{nE*w0U_@Uw@y>UdhIeZo<-u-wtlaszk z;4q&(b>U;Ct(CPrbsQ{9I!uT!-mJa3Y{^i>qjs9MyO10B&@&@bq|n0h4QfV}dT~Uv zhtrlZUDrs0&d8mv-WHM$H~5*1(4jkI&{~fUL1~Xgxot!a|JM+HwmhYCMnM7S1_S?! z3mz!|8I#s<*##%uX*cME4o1FVsbn)u*>P7qS{n-oKq<|X`LdK$-RFaqI`I$e;DMH% zZ;~@rT6WzTj*N~A)pD{8k;H>;+dK~K8b=;sytChM6=uL`*D(iG3SGk#P5J|x5&JXD zjLsKXo1@}07(I?!CVN>0Ww@jY3Yh1jDyX4b{_o4Uk|401lO3RYN3xIkxnwG|JCqTh zIlM#Cyt1|9a{O>W;qG^ii(BOiixrd~WZ%PrGF3j>;t$)VWv{r!K)T3!fP*E3&t6rf zChk8JiM=`rBrTrk`czfIWOFx>lsW9o0JyWh`N&EznxdQ(I6SPcNp!Ikc>;=gCL*VWkK`jrda)SdQEs=nE4<0{{dW9HVemP3SCxnK9 zF%KBQ>G!5=hz}?l1IS%t$P*@6a3qXOiK>Y4eb!%7L*RD+jIF;ki9}5BjT%ct7jDw>M9Z|S<^&$v z#_3B!0Sw<% zet4|TuG3NE@qx3&Z&!MGGqES7n5LU>_U4k4rkf>*6C&D@uP3UQqG4*bVk`+9+DfX$ z+FnVAqhA*YffvxA0bl+-PV*7{``9U1rdfy01X%TWM+yrr-GE6&xoXTTa(T)H1Xlrw zKsb|z1-oCvx7T;>kIQoew|uYQrX%|&aAyOOGCuN6nJYYno1-hH>JH83$y+Ron`<>3cYyK}WVu~D{S+jIw&ywBp z&qC)XsrR~|u^<2N1A{pH!LXVkn1%pERqw#ssAS>@xi5G{Xdn!n*jl)a0-^mlUkTOP z)+>HT`^EtUKjcz4-92Zp>(IhyWz--yK5M}&KF*U0zt>NFm7Uq56&uijC^y|h)-#;j zVr)CE53;8-0P3TOOX}usAfZnbp$ZjC-V#bTnI?0YWGVwO-=ap;kV=dozKHlH0wyjK z3mMy4Zy&^7*hU(HwRKy(e-B{Q{G~TW&e^z*$%lqkmdmMRXeWuwjU%NUsu*qOd1K;M zPGm0QBI{zJEMX8$0>KjQbNIoXiGahK5||PfF7AXV0qON^RN~t0EOeDdsl_M}5;H?g?OaT>-KRsiSb)oB=1B%YIv_85Wj{)A+dt zd!UG$phJnklppk|Mwb{(Vm1Kz6FCjp%jj@=)qcD@hd;|WBm&$|XJvWb69fdeev)g* zwoUqbdtm-9e$a&m04MU2#Ey@QL){yy_q}g8P+(Xg^xlZD7fgABZSEZu4Y~cr4Dv z_AZ<84=@c0=U?5qvp&(;ATd@ntH1Tm--hURo^zo{9=bt{gUieIZrqRZAd>^#G+Dv4 zBzXG7ZaiY`3W<*~5riM~Jk~=65ZLv&R@TJU#lPe3U`aJJDMpSZzBa5QG`PU{zn6}n zU0HwldfFg&LNKiMj}9@jgcHKujT94xh4AIA0%&SLnT9Y>mRUMpk6ejqMT7!*{UxZ$ z2#}bKK@#3@$V1Z-@$f_pg9J!OmoQxGmzBHY1xRWg!H7zb0YxsX#Zekx-H&LRVyRH} zaGZxQ{>lo(ZOF_M&t(^hpFQ9qN+3T`RFgbGY~%3`I2G2v=^Vt;rIV0XlgQSpcwUyL z{^S_TXkF+=PJ!;ol$;@^Q64f$zLX~ZlJ+BP6I7w_Rt_L~4*l3WR3klw+u1B(vXn|z zGVV#n9p41S5e@~iz{qV|6RM*M&MK{Z%9afdDU-Ms^6(oKDu z`|QI<1rkZz{~(sN<2G0*viMCcFKQfrHY6TwUU%I>g(Z_^H@yVv`yz|Q2KT*Z=c@SC zyodMV{#I*f9zG1zuzfD;*{SRGB2v#dj&5DN_zp**rnN8r#~j2=H~b$HP)lO$DH`8M zbKXW)b23wBO_9hY|*%t91+>Zc% z{E3X5CMBdbqg5~-T-vR7%rV%#01|>x`rX#;TrrczlKwk|c>oa;L&cg1?93n)B3&7z zU|4G~k;@0-7(kCeS+!Z19ul<@qM7gkW1r(!iiQHxuR&o<*KhBl{j*Nt6yWoLoCNsA zc0@fgf~?Mi@aR%lV|U4QO{IXguu94F;Kn4n$00G%+EE{}Qd-)H@~yS>Tbh88;|;MR zDJwyq!2+vzE{h14H;|syEXQ()lk)4Hmt{JZTsFS74@7O~SiL)FkcMRdp(w{2+uj5vXOAkeGV0<6%E_waJjIg3GhTtQ4W zTmzC(c&UMX_R-lq2v=pif2o0ZE*!wM%UN>|TQs=CSQXH8rLpRtwWgdj2$>s%W9C?o zJrs zdg=2;GTnAG27+aucJ2WF0v3rRqJy3df;C|4t=mr?lh2J4(`Ga-^kJs-#3;K@&+^TY z#-F8sL&=}dM2bo}@%eER{w7F}t>Y=$qEhAdrPUy^$&}7;t#Iv!HE`|}sKi7`yHKDe zKe$8)o^`yQN=rM&GVK$L=s`9FUjD!q(s0Fi^n2;pOlX;Gh(2n=0|9GSwOspsA3CKl zgLVGfn~n=7okDGkl5Y6fP#QN{f_6jEDLs&c3GllfC}Eg=`Li3X=;%G*okCm+ZczVR zfKiBeg!uXNFKuN4X2#npe>pw~niGAN6mCa?e|-J01IIXAQ9S6s~61 z5i-sGVCAd8VQ!vRX2+?R_#^aqXeAT=R9X8@2t?~;_cV}4{XAYDv7O8jgT`l>iwK8R z*lhT2f1!f|Vxww(9uh5%GyZx1LS$@Sbl>nF2=y0<@^QFh+b~9;aPEVHgU|JIZ|T$O zTVyJ#l=Q`5C$36I-p%Z^02Vg0$uXZq07?T&z`*%*Ng}<&ImpLxz=L8xbNEi$m^gTL z;(Bq3KCw^>{=hGc0Z}Kan$c8Y)`e%QNk98Yvn}^EMai7e#d}w0+4eJ1;5d_ ztN8@SjWImHQakuy7W7O(Z#r$!m*1nnCjVDQ=)~RsHx^0MQq`?QP|2T+$^j3{FFyGBx0KpV~-j zHQ)tS^rE2b$@wCfeG-DWE-WXhYJjVS#VO7%oJIuJNdz<>3IFEv(PJR)?~(49sQ!gTMZX@ot6atyMA^XbqVArvmlx;jLjp;(0n~`A*4*@W1)Mt zo5990<1szCe03FJfh)z@u9rrA>6HiNJTTXIM8Bcld~}KtLnB4Odxls-1sBZ#e4%VyK$O0}J zr_#)?$@R($)aT;2aWi$6!6^(uU`mw-*Q!tsB2^{^RfNrt?0r;3)PH@pma{zX=24X{ znyfW#-=vMLwn(-_ux4EnxF-&;74dePmlgq1uaI_7ldInNOYdOOlpt?S98Jh!^v$Uv z!o}0s*fUK8BOzncwQ*2EaUA1BU(Z(1E72ahC9$ii8XORp{?#!A*@w_%uNYqD?YgjN zGO*@f!ec)$A+p za4Ibq6-LW0{mDb^F=k zhKow=#b=_;go75~0D0W&A#{TLZ4^d)$~M(N^g^Z=a|Z3ZLY5VB*+ z=3i$&41n?hcZ%rub`$E9`^{_soLICO{^H-Hl~v{CFD6yLcBpsj_kBEg>1LUTk>4kr4a(x$Xk04d3-hm-Y0)2bBR!4#1KJ$(v`u0u%G{k|TR-8h* zd`Pzre!z9pPp@S_mo^;rq5^kKP^qdzCF5S@l4%3C$a8 zTkXaI*1^V5MC4jgQ2!QmJCi6$j74PPQ8ty`hcyPxkpl+4ofgAlr)iGs$l@$5GhZ`WT4?Qv%m2rQ@S!s%m^+)8-mF}IFf0*T9S!N`+<=A}$ z#NKyp?u6;^sBS{o9Z|@cL5UYgBB57!7Us#qOXD+$_o#VyP^5#5Lb zS2HKWHs_)f`kHL_RnL1hRIbvs(l?(*H+M1JZOyG*@6f6xpE{(=t~YD`iQ*v@PW&6t zpJ7^>1~wTDv=z2`IpE6~ZGlGZ4C*rU^quLl)g+v9EY^`$ktTgzs5dT4HVa)DT11fk zR0zKMV->_EaVY7v=)QOJzGR?AO3+ea8){nD)eEVG5e``mu;pOk6|^qC%zQTjPlmcM3B8dbDo!DLG2~r zPOb}}-pB2iCwYwi8(f;kw-b0?Y$1IdB?f>tF#DOqpu0p>Ksw!tjURQU=-TFqkwb#l z)016)j;zn5a>*Oj*x4-hC7jH#$(+nO?=S&suPt|fgA?rT1{$Bxw?onsa9a88ZJHuk zI|S;jAC`?$qE|4iE8t5vbF}v9)~*LwE0|qJb0X>D>A%B;>6EnQ_+p#kvVoo_)1>n# zJm}oy%acj5Hl5_Hh-nQXrw({h;^b?Ac6ZAz`3W?&8Dy5oU=v0K0H+wSmx26NP)<%0 z6>0C$CGaG4uOJ}Q-z;54==UqOQJ;_wLRp}n=xu?!iDvYvOqgzc8A&_I(cW*oyf8A@ zy*R^H_8o`z^TB9hy4L{^gjdWbCCFx4c#X>*pm^RE#o)J1v@BChqrnm z)w_D4O}N&Z&|G^$CCAm?@JXv-RW^i*>_eU?4K+B(b-GwkK}zVM(5bu#jlL8%&#KO9 z>?B3b=v}=^Yrm353Na>Xt0aebX%*b?FHA7cR*6J4`YVe_Ge=l*}K^{F> zf282u`dpf}-+knfKXMRY$haJseyAeZ0{r)cFB{>Z+t_@X+d9M0b!We##*1=v=i!f5 zPxSC5o*J{L>P)kg2~&QV#&1sfzu}Wm4k`bSiHq@nBC9ZQ{x?~rMr-@u#D(a0t7mXT zsh%kvm%1 zyD3FU{C;m+l^p4NwZUyrSbv+@`MdpVRkT2}0#!PKSdpyqK3F!Dt1j>3)-dR3m(IrMeK$1g(s`R}L+&@&5Dwk?u?v)B?2y^c8LOio*p#lm57{C% zvSHnlAD)bQ|4zx^lsVGw;baN;c+?{PFYh9P1$){_TmE-r8D6ro@*8}qGWr5BOVn9t zTNjLqbe{NWx+qdy?b$teuuaXbQpQ@TbEf?k&c_4lO3b9*KG1dF!;sP@Y?6VtIi4ay z*`RZ722@UTllo6;zPI;P)$WC3b!X}yu9Y1%^KnBK749<>ZrqUm+Z`}lOiMXhgaagb)8Q>!)!CC=7nFN+zX15 z--+dadvq!ds$aHV!foi)ln4!*>j>6JoTVGjz4P-W-8A0AtGe%AmyqKCLefN^O1Rgh zkU-QuM;apKO#a|i`tH472yZ@5hO|7gIao#XQldmpDfORU-xC9$_c+2{16z%uv{fEr zX(UfIS!bf#8lcjKuICIe{-9DhBQDDWW+9WssQM0`saQ9JU{ksldAk-_+^^&c6c`cy zmG485M$O!+K!EZ;TFxy`tqDWJGk8g;5}bAM zYU4xJ6_coPg;e5A$PiHFgn4F2y{?U1e;sH8sWXaf4Uin-dS;=@5t}xAHAinj?Z$3Z z$eAI==0Xu=iRP8K2ZYXSmhUDf^wukMl1zzR-T)I!?+OpSS-8Do$8|~&;YMk(sN{vv zF8&Ki^Oyxxr6IW+Y~O7~G9zM8(g$ZfaaVsSNA4OAwC&sVRFhNGbdqX`3B5l#97*&S zP1F)q^d?)3pV*jp6~eU;A^7|4(iD!MamAt5);%KHhMM1PB%}TF?BUyDq z_8HmDhMPNT8@&a0JoIr&RGCTX3fX=Yh74S~cI0h?`FGnuLu{cz0D#gPAr(qR^g!hs z6E2yXhi7giKY{%PcUBlXNKe4rKNF^_T2SXG0hi5{aEK-{W1$Q2I%y5GmqTRS*uXF) zz?;@Nrll306d5NQ%ztN@u)Lrbc=Ob3%9lEMTjYDdgy35B>Pa zMqjo)ipTxReI-d8Ga}DUJzmz_JrI+;%*Sm0<_bSB)cC1fs)H4x*}KgM?3MCPrp`xz z?Ag=AEI+|jr+El2gdeN@c!$NC)xq|fcW7PInLjK@*ajd0%ZGyhafFOMJ=B(l7h!o= zrepeO(jJv)!q=O88SqWU{9PYoiG$-JbpL1b;W_-ub)+?K84Iu+1z{&-i+*d zUyFd66c1o0=URxZ3-(&R{~z54@Cf#Ep@WcFkQ7CcIFny{@O$MdmX9sRoJ|ywGskjm zT(E1Bj3BlZIYDgb65N|nWC(WU@Rh%e)RamjDXlOF)*ej#FJ98##$eUf4hw_>De@## zZX^@#i2~O&KA-hPlaI zTwt9FSIP4|o>cVHXFwvOy;Bv0x-G{QP(a$IhPa`vJ=S3x}Fy56y860p_~=CIVo_BB>UNJAbh3<#PVUm@NzdIY8CgEx}naL zEFkl*{t07howPaX>8h0`9^MklYUL&XbCu~|Dkt;r3oL&&Hyj@$!1eHMuIy=CzSX0& z?zS5S|0MILPA8FO3zo^NWRL%IDP#b?Vp52Yt+pUh)Q@?4>}E1*n#)>_=D`dV-;e2? z5qz2OPS=$MymUOaRJ=iL-o0ri1(!fkl*!VLrDPT~&RW8Pi}NvWq>}@QvRjlA7&JBG zWdRqK#$vlK#BZBj_>>;;IEBhf2_FGDP%=xd)i@(f9^i(RNB?z1?jlW(&fpGLmOBTV z3-!GIFs_cZnYBV3_jlQ_J%U@Ay9NWng19z1 zw_Iz;XAVvD^j;qwsJNs>vr`6KeRB)QP`RD|7??A_CuEo`0cJk5MH2JqN3=ZMg9ur0 zeID#WbV{FXdaym18hN1fw4lc({x&f_p(WO-1-8tQuN)_DRKH;gxy$(BW=?YS(foHH zeG1a4I+aSqo@m@+BhNU5oggQO9XIInfl`|0N21EOs{ZSiPB_$QZPDBu=ytxT%`j)= zO0JA^@n};1YA0DBL4WX63bKi^=aW$U<^}J?qi?8kbb*Ql_nJZp|C8!S2D>l}Sn6dw zHz3r~aeVLih9VT>J>17LTKl&WZ6Ay0AeR7b(~WfRrtYG1;?jDNWO(oR4+~H|+as#@ z1y4s)*@N}H^Q@}%Rp!}Y0k*g)qQWeaJ)ZKZ(*@Q^6AZB)Bg~-?Bv%d-1nSbHE4#1Q z3)SVoI(A9XN+?s4W3$W&MKrY;G-fcW<^Ln?9b-gU!miP=ZF^>qZQHhO+qSvK#va?Y zZQHha_nUif@}A`6%Spae(m$$`u5@*}YSr^RYb_#P$&OkOy#{onKFatG<(h9TZ#NK3CcY}z) z@o{y$Dnh$91?95jb&WuhKP)h&RuwudFeX3smj^e1JjMLGd!ZZ`a!bEwh7z)FLMT2g zp#>djx<&-D4>CmSJHQYu>ud(el8xs^d_*AgOHu*oU*R)H6;%v(RP}cOokA(+imNQp~4plC8Ds1#vjz%SNjU`MOvYC!tR8h2yzc1!{ zQ9I^i*XIJ}-N8I!hQU{D7nG@OCh2-|&wVj$iqCh2yB(1}n#Cv?T>(G$L2n%C9aOoWK!r= z&FX_qsr)qNy16Wn2b*Y0ZAIy{R)p?rZC=G<7_V2av@Re?I0D{PwgV%cYzaotVQ0_2 zVL_~bb$HYjH5)e$oVSf`L?ifaeL-BD#mU{o<7!IcRI9AC z5R`2rKtk26ORsfy=IoE@`efhscZ2#JVDQ7nC@FH~_+x5mo#|&em|5`WAg%geV|pIR zDiu5gQ=P5)!pj1Hm%{jz&{Tgu|BLL?}@*jVDTrO$1u9nTGNJhu*lt( z!s5ysrI?~L-hMr#S2eupec$^Dy;*Dj8;Ji;E=^2K3~c{fpYP9K5MMNm=r^Osa37^% z0lu&`+xteNXsuHuT;J(CeiV>>mM$>Ti-mEc^ZmZ4Cd5?h6;YXtc3OQNSAJfur!sT> zlD$rPTjJWbebgKs<>=OW{r%qfvG=P>NkW_K==!WtX-GD`b<$OC#7|_r2>!?S{bTw! z<#Yh%#`hY}Wemfd5)W&v=gVf7oPoRy^T@Tp$(+?^t(*%YkIv>U-g7&7!S&FU%GK$6v!%YLN#Qr46wyn3nYgI&u{~8tqzx;>fwTv+ zuK744=kmZFD~!v^JyOmcV%xFr(I!``&8lbI8NQx-{sB9t9o zU5sa84Hwn6mp!)P#48SEA>Xq)HMNwhCMg!HCR_OU4#$B!w0n*i3`oE>;CcFb05>P!}E>Q~98`uy>+o%@>I z-Ts(|h|^Kdm3GK7i6u2_(-xJwWbO;oF%(9m;|_XcTy%_$PERykY!3ORT)+PO!CI{9 z=V>tA+YL>L+mV|1LBtjy%e_k%HM*f(4;7G@K{=qEbp@)_jq&5c7dz!1G zv_k1$3F{ZGyA+{t=76L|X9f102TP5$`j#ah_wOBUWBb@ychbX;gIh`}nVV^Vx~F~z zKYN90z+#uzQnJV%S|3;6v4KESEf5Iyu!fzBmsdvW15;NA_WR3oC8Y=YqmFP}8C>qQ z#&!*F>7}3*LlK5Td@$C>k-$OuWcdQ!DRS+2hA^2ip5D;7z)1K zS?qQ326iRfgVr$%A%{WNy}?oJvr7J_-2+)3PH0?|YrW+BKEeqX zMh0f<R1Znk33c7w%!ev>7qM1V?2g`) zuquh=)b@S@#FTVf%l?4?su}#iqaV5$fQR~$`F@)i^l=aSzO7bUiYV%FDSej@=8cop zJB%o}za~_Q>8+oRVhpNc77Q&YfthqDl_Nornxm0iDihr#=>p#iAR?NAa*3+koj;c zffz1ZEK-OX&Z@78?S?KeI+`~S4`~1coG-em`5w$MK1z%UjHq9dUdN zp)klT&`Yp*`zA$Lkb=~#Y`7Khk7-Zxw& zxEmnun%u}jJ~lHZBRaU#IL+(EZ7kt=X6(|v->MCpyJ9K0us5iT z3V}>_lQE~mu~IP*uY=gegOb6>lP+Z9v3bjZp%pud61{b*P}=w^&q$-z`rEOMI1ME_RQ3`{$)qnkc- zN0J55RhEhadEeJba#S*zZ)jjO2*zj(967Kg;33V~fO=K=X)|7lvKblM$kElH5;X}r zjn)`^Xn!&D^LkOpZ)N;dX9mUk5Lc=o{_dVFQ8GFNnme@UW>7;~wJsjP9O_Tc9vNyP z=t0U&KTziI7^iO`hu&Pco%8WHGkYIB-T)6LP{g70YCC)AECFF0jW0sEePXl@$XNq` z$Kl>H2#&uEI+Ws;0Rg@my>rQl2q*fQ&0lkxS*2n}S-J$>EHe7PAy~yGGskKViRY+T zEG`rEyi|MlQa)13r-ql&;hM{x_>mfyBW%*3p>R&dX7HO2WKsTltghadS4@8i>)UA{ z&kQWEd{OG_tgPE4zqui4x7^Ru&uypPi8?Uqn20iODaH)o&0Fdf@|{L^XMAF%6FcTl$Ol$dC3h?Y-vHjqGwQCMc~D z?Q^k+0Wg4PB84)Ft_kBL^^bMuA}nZyK1eTocP-pZ=Obp7VRm7Y1u_TT0HpB?+;#!) z2eLYYe6G*uOp@m7SRYN)-B{-72^Y|*0kp)O+j-^77RWzWOzuDKa%2t@$;Q1;>v-!8^Q(eg!%F3BDWF+PUY#6wjbm!aV12-duE>pPho#rkgAZVQzaNpABIR z*pONR5%#x59z_?)q7&L-yC~z-8-R1&NYvCs{pE>?TUTzj4N7EzX(r+?l<4LV{$y49 z{tzRHxa)Ek&W}?_4Aij4K|X)P;cv=%&`&K5aatXHZkOna##_aC4?YAz0?jONWE2pB zT`Nda0YnvV_5(9Y%vH2Gv!N9K0ZJyFZp6X}s5Ss53n7$cHQ91M&_TJMllt7FM&tLb z#4=GNEPSs!g;Z-+jbw~sFN1Q} zwb6i=5Fkh_~k5Af1X$9pdIRa81U=Vaohe_ZQ5je=bYRA zO|k!=J@d)7ElclI5+<-py8gDC7Up7N_h zBg-crPrK++COk=~5a7!hNU4t4ogd8V^VsLxCBB-GDx8+$0IT*6IZ;L#aQfe87r2NK zAVc!6vsB#H!JbIKtP(4Z3tqVZmkEyv5{IG&O~ijg7cE&{P_H!b2V}vaZU@EbbULPT za05=-W5=g9GVe5VLn04`(u* z->ysxoxFjssdFyD8dGB$Ag)+*R`Eg-rcoC>hIqMaFzzQ0{pny4yM}?Hr{s_LqpiG8 z6LL`l%;r)e(-=R*2|Wvx0-JQYyqxK_1<~wHSXOgLGVe$c-n*epP-`#Rxkk@SPV;R{ zG^^zA8VTE|1hGzW*#B`6rLF60x;!ZPd<;c$q>lz#ECtf%mBq^kt!$L_OFPs0e&n<2 zi9>tGb+p8%Si^_Q3-k|$WkPEjNDwxnM#@T!9TizF1MgOx0t4|+@&wGf={>R)U5o-IVSh<`gf{U@6?24*()|9y6fQTzWbMo#}~ zn^Po`UnFQDGxKXb$}jT6+rUSQYzULg<(FP^_H;kwnR{G;4B<(`h7EXlKftoR;~Xh~ z`FSX#E9f*?EQo#(dbUJudy^M%OKnufxQ3D26=)Y-v97!LjoirHU;f@A5e!%F+#)g2 z7`~Zmr8r;JSg`xv`oc~>zhdp&tT<6&0HTr_0+Tv@D=ld`G&wC<}_d?9zaK;4BL z^&x+^zWp(Bh`8&H_iA;bp0UijwGU-3IPY5uk?E1kpK(f>OcAvXWUGojX^Y2hajz_N zIeEpwqy|rJ!Byqrf=R_WL3@>qRO9m+lD^(xe*MCQbc5QJA7hU;b^pPwUzB4LjWjDP`PMdsT0wYq)$mBoHcAN} z!8|iLyp&{4#!bS7t}sXLPN_ zcwik+^FZwVHIY*AVn>&g09{>ShI;N3g@BC8XohF~HkG(`d>7k#7aaaWUKUlVx+{~{ z-QX;owD;4)$z*g?>01-1tv_2`~eJ3DAzmX?}Y1Uu2LPD}R zN88*!14>ZvlRC-$ab8G_!*k) z+5B`rP>t2Tg89$V$TPS!m3ePn|7HRiFagw}08B#mt{qEw9X18!JT#4prhjx^+%Mb@{ShrzMH z+27XBGt}o;TPy+*6||L@h%S+pD=^Pm<>?GY%4ZrfS{)3`bY$zJO{2dCQ#qZK!|Br6 zH{P*lHP*=PD_0IFGHBR0=Kj{h+#rm~O5)2+@S98WGh+ZEP;M7%?ghHXsfIT!sk$&} z&w;QKQ@TT0az}7GXhYMOwk#H=^g#@G<$(i2!!5s#ow$s*rY3p$`*)H!{rG7&w=C%m zKY4iiG{A#Y>$ak7F??RMF2svV(x~6DKE@_lpustcRp@;XW_kuXp||Sy0~IE z09JKR)B8U3f^wtHwz74J-wGs4lm)1rlDi^U3Dut9k*^^_qst?>WH(ALmWs-i+M_<< zMGEn;h-7W2-p#zZgNS<}2sx%u<^b`kre`v@JGN3EEg_dAB=Ei9@+tI_?<)3IUeHyN z&zME&3Q=E9-oru6r0&4-gT|W8;$YzvvS)0(=qrQ;D_%P`PFxYwR5(F7?Ka$6D|z1% zrzE(@&g+o^r|)5oh=BM$i&lxT*&5Q_?TKZnnqm^1MxJ`L&JJ)QUtodI1|e?frdOE9 zdy^PzD{Ni3GXi@o4|+vIfo&@$ab* zn|DE1ZRaJp-3cf1lQw4?1QOpp0o;=a9m{jK16+clA(d&FR-DTbTZWF=E)%|)awiqv zONTbF>NxtrY1RS~Ou>QRYnSkr!L`f6;M(nb4Tq>_0sSndox%2oU%lp1CJkrmjf;fZ9t4En7uZxlcLpEv@U!mFQFrKc zk5@^>0~*`Ojjy5T1QNi74{+OU8k+6@g2r*PcNc{VueHHC#p4&AW8=p`o~5y!tZ%=f zEr<-@<{T%Yq9sXAHb1PtJh#9o8LvloVyvXBo?0B?H}#|fL%{{nVCJCb1jW`d#6Npi zFp+S<{S3PeOXOPD?`!yiYAr)f=WNKYtlfkV{k%hJ)`m(E4&t~``*MHb9??KekDR$l zAEhNVJ8j)%5KpJ{D<*E+h04A-+ONyq5qv6r7jpgvPQglMlWN!_0@Uf43V}|2l;LDq zVE3-$_-J~QbwrDnf>}O*;gyo*YUOqZx1O_A|F`M=Z#Crqci)idKgp^vFfq~pZ`5$5 zC1bZCiqiR_hR~MAZ9m}ik*$@zD6jz_V%5Zh0xBuhC?!m!lW3Xfx1*DYBw}e%_8n<%t4Y_%N(cu4+fMl>q7k_xNw@7qeE(I!F1n!7UFM%Hs!CZE!jtUM!N^JK0B%HH1`hQHJ z@MlsZn))M&sIy3T#Re`IA{ZA>Ix^q{%F^{2Gl!cEyQ#4UiQoh>WYW0r+qp;ed8Z4%nZ zWkt2zG{u{-URAz~5l+Oyw2_cPj?fzW`a46aH@Z6$sloxm1lm9an0=~&I$hI*|CFx) zu6_U@)#_J05V}}OgspffBL_|JyWw?^Ycy}#%j57V45XQ|8-$6S{j{;!Rh^F`91_K9 zR@Q*0qi<6s2jjq$&jK(bK(D%1%mI6R4siK=nAyHf-H0 ztOKf9Lu(q#@_ot1+#`9@0ic`kThRzH21Ofm?bPl<`_F|+BRBq%k&!w_t59{ABhqX`iEMIjkA%~)je%nZ0dt6h;xo<19Jxj4faH7rhR8U;b4OCbR93`h`&q8ZCZ@| z<;dYgiKnm1q!EDMa+G5 z60Uq8i6MH0PM|jfWMUhLhc;y57O{Zus!&Fq$Jub@i`ulft8njT$Y?4mQ48QvCZXdH zy#dDX*Nhnr=tpJaJX|~Q!H0nF`aZ@|9KfTzmu*(_!&Ng6e3JJiOG0Awj7+6QMs`G@HqO!Y{AS61lOGjf!%; z#HX-^$Fp;-Z8&_FOvvltuN@ID4{SexR;!@@rf0?UpEgehCWe1nQDu!e?yI7NzIZ@g z0YS^|c#KX9xg{sbW;K?bizJ3%jR`Ligd@0qTonQmUT#h_Rjd<4Y3Z(_fsMaAe=~g% zy|VQJQg+)DNDzd8{RtZ5X2%D=;f)6%o)rf_*Z`;iP@3h&5c^A;=-Asi$OSHE7~O9> z%HKg7K>XuOFMF?{&BIv$6x81rjxsZ_g#U%aw+SDCLtSsK@-@`~pLW#=sYI}L4C;p! zTZ{0-X7PTd4<7f}EXJ)~xHcq50z}4Y4zUJM3_}kuIusIc0UZQDr3*~RoEB^$@oqc% zM!?*E3`JfyaJ}Q<>ov(i{{EX|ncp>Ghr1~1h>~H133QkXeTKIZpD<-Jf*pQ=e6m1u zuO`)_UOc8V8N^YM@M|0#wwD~N>ath(saJzlXXZfC|3O6}2F4a$Bj%=`ViH3l9`9fR z4oltuM!L=LqP+Mw>Jc(xkU0-U(1frEN}I}!;9c7-gmfD~1a|Ra|0AOYjhVsNQ$AdG z+!!TW3O`mnJxB(86>%Oa1ie#!*Z6@)RiWBk`S%|67Rm6Pe1ZTwi)A^Pf8(z&N*0&| z|7->i1t{w!4>F6ik>*%o3%zRBAWOtpXQ^b3QZzy_aE-L;$a_;f%?rgceoDPr99bz$ zAW`kx>Ur|?G~xtCgvOHI_tj)_Fzt5tTpk;K;WdBd5#C>O%+r3>jOT^VLyP(LAP~73 zia$S{M)`njm{Il<9zESuGsan4q<20#ak@LUmT59915kuC6-y?`#8ZS3kU*r~uHJyS zRsO7~q)nnCtQH1oCFUZjy}IO~yh6CbFC>&=v~c|=61?!KaHE3n>knx@Jhl}wmdNvQ z5?EaHj_XkMd=Fx?6iUAc*9`-pyb`Iw3mP~Dt`91TPByA!6M$_pKq+aw{c4`48^X?r zTnJJyf<3E|yeM~S%zpP~<|I%;56j(=z%QIl{uyvAdAu+Ap~wAc=E_^IPc0v2xog>^ zsrUVHp2V?6Tf1V6B9wCWm7O z5i4P0ReSH>;Yg8oyn#{b9PoU-tlO%!hUZ4L)2hX`5z+L=lavPo@Tmtwk&6bpaC>{* z$*TgluBF9we%lhXd1m|l0?%X^qK8FGAT{7inot;e$&K zTLl$3cl012nBCWkptS3-+hqOxD~jltVHljt!d~8)Tai<_+X{+Jv-7ZAYeulbCpEpI zN7T0fYW&`E%gn3q!fA754T${;?Rbs>I?Z<3L(|dT3bNw$qG$7iALdTzg@&%uYD=iu0jTZ#NhA?%R z`XTFQ(#dG#z(mE(_9E6>T&qKdl0=z zP{h3Tp(93GMg96l8r0TD$2HtsUf)p09G;jmpO-MGi?4hvI2IymR{REa$LbVe%iAZZt`Pd<1e91$r!xyRMjXJsxcqK>aKF!6{BjG~ zpnpNpO#cZ*GcYhP{{!G=%GfRNBZS_3Mxvr;38j2}?=Ax+Lkaq0MF8(37?#9H;@0Bk z{p7f0E!wWe5H>Qqit;Ge5sR&l++21tHJoA>gtziVG7D*HSW{DN)wFNC7Yx8MR&vV#^~k~wm>;WgidbdO<rwT* zSko6ts{AzGAZvHtM4{%BnHG~STL~ssVJJmmVsSn<8v3b5FSut71reTbdww*fO)1gY z6*3qZZ1W$`(RuniL{?b7T6@P#IY3h>F<_N_o^kTc{v zdaPSC+c4ypwiwS0(s?`~BGC+(W^j-r01=_eV23zOwK;8ppZH{87MrL~w($sMTg_%G z8<2UClBvYi+QwETklG$!r7XwrO$A^Hl2RoxY0>n&=1p%*8Ht`0U!?>SrNxC)lm{Q5 zDjC9}!?Z-G;PKRuneB9gaDnQQo9(1NI{DPDXqlv<$q z086~;T}$Zl>3OMw%ZfBV?j=E1uy2SN|Nk60YLsnx5o_cQ+08HmXdk)&NNHseQ5gp3v1Pl z|FT@x02O}rn_lX`BVFg~b^{O4V$oM=xnO!s+5FwuIYF7?LF1kj68%ZX5)8<%)v{Y^ z_&e*+BIB>NfiX*U)2QP~l(&jkKRqz)PV#nXe{=HuT#UexR8afp;$`zK-)XabNb(Ft zfD^?=I*im>C}8MyJD2JjPW!?k?YjL9*rc!oYqpu%fpa}vp+~p4_Y}KSi_5;WhbBnT zTig+N*mZGkr9@4JZP-eLl|{P+mTkL2{ds%U^T6f07Dq6NX-!NxWq@sOD4Ld@mbJm) ztl`E4S|)g!rA=MeCR)6dnZ!F2{IlMRgC1)U1B=ah;I$@Ohm}B{Sf=2H1*6jJz4wQJ z(+dh@*nierdpSbIU_;_~g4X6?QpGseBfZm;oh*HjN&^>>L%Tfnro0E4+0~;%big=sf z^}J|ve&={$r;f1Ywl&P`g9DD?`A!WZQN0kA3ouy#7w7TGE`cpJr(Vi9?2S&HEs?;U zQV#xAk-!Vq-bXT0e}+ILfxWgIToc@dCg{XYzY6u94ec5JWr1S;Ps9Zd)_;WUuQI1> zGxTXrMEbQ8w6k_8_L*ZZ zCD7qip_6;BG0FkIU#VSmVJB2gjv*;{JY9GZ6kC(}c0{RF)x*bLQ1ApC7!*G>q&p>8 zuKbnnqt*J*=C%yglnYQydWs#=Xvp?Fs6erqlpc6|OQe7t3hg0DV^lhxwzH0$-!O^;XpN>+#&Dgsp5HwS zid!>y#G$Wn3lNXbmS&2%fWYT5{QYtsT>)0|u`C3ELoxiaQE$Vd-BELih9{ed0-|}R z|3hCf=$ghKB5A>20+~=+7L$za{as&?nOLXN?PMa@-~O;Bh#^ow?# z$z$Dk+!7J(L)BGBp}3tmry&e=YiI#4C|xnacb1#OQkRT@th`REyQ`y zIZ?7yfy^Z&Nk>^yHh(=f`dS3;C~Y-a3~N)X(_`Ft7rx`_lpJCYZu04G@HxAp(_hVn zdfHQHHZ2@hCp<2#a_x&OUP{6|)}=Vu_1#*r*6fI^zehupOoi5P_8O6Uw|w1%M?*l} z>_?aJmmHR&6~>KkhfRn|1T+par-NIjnGx+{wtat-U2#ooE1+hg+pZUCj;5ELS9gFw zC|ChC2E4p!q@(Gga{{W|K!N`@Ax~Zz9k+MG0~UUVB<7)2&%_8cw@xM7qCE?%nO8v` zu7o^54&%i|lKR-JfSoJ;VT}6IPd)tqH9T!Jt!0+VsXfyGtHkPYqME_(XE;ly_*Y8D zcwmc+z{Qv3;m2&tcUQ^iGp^~!CiXJx^|OhNg%?v1`8Ou%`ZprJn>6`i(rR$5^=QVq z6TQjJF=N`1$!x>p?x?X;bU(mFdknyTTMhnG1tbGK$3Nq7S%2ek?0@0P2UU2^VGzb$ z=A}E7;4`W8!VmfmV((jbvEUi0;4>Z?{H5=bU)9tR?mbr@uo`nR`1c<<}_ZT+V1V!0U7AGbf< zbmJn~AH)fI~&!E9ey$ll^$t&&o< zQl`q;5`duuL3(bi7_vI|U=v6jTDw@%?p*)9xe))1o$0pwA48qrfMbPtk9lmW32NOd zHJKGh^%`e+J3}tIlgAp`W)If;TRTM2`@w>6uMXT1Re`J3 zx4}Myei#sfMs$_#>>)K33=;4KlX` z!+nu;U<`0l(Ju0apBEI5$b;@GJ&DFTy}BJf{HR-lYGrD1uzjIHczn6lj*%3A2B3c% zkBPxot`D}|#&b0GN?l(;-Nk;XVrr?~#(bIV$u&aE^n+mrI+GqYc-_mPvlf2Xpk_bL zdT5IIlGX#8+>3P96Fzfm_P|JGuQe*pGK`CHnM(_{X@s+B8P4R;mv33NzW-=LqpEr* ze49 zIh8|=ja}f?P-XC=SK?VJ|2r(p*ZJP#MEhfh_^;Tzlh!ObpLo=vKmj=3+xJ>n^#VMD zkbbh>eo-L<0H+e??V^UpyBRpEQ-=cAM%B}jwP!ur`oD>Z>!>3=jV5Uh}&MPKCqk(2KJBa~x_y_$x$m5UU`)vxdUj-fvRur8T#qc$O-Vdl)4a7f+ z>QSHR9o*6Sb$$5DbU@lY=5xBybGbb}pgG-`i2t?_{ikvQ4n~%L9GkKx{s)%uzkEe1 zsMg*Fd%)|6Ruwj%OF5{ippV8wuz;Z-2!DSB_64V4YAJm79*#pF?vcJtcAZRPfPD#o zcnpORh$JNPF7swg&n|)J#8MF9J@eqp*doq_(_ca}L;7*TJK%Kmkl`afK&lR{nH;1p z;xY_pNo4JaU33u_lc*xam^+YZ;1ALxUWdEqoJ`&XS-5N-rQI%91@}v@p!;ayP@6O< z{8;DRy~WIM)d((JgD4|Tn#Y8qkWh__jK~AUh(o${U6>{pJ&1JD&mCP9wmS#RJ7CK= z^H94D_@L7iYjDpTFxLsw-STiq5^|B#jnumY173#g2?9~6>Y3sEQb^w`dzkt&FL5yV zXMGGkGzxlq^Q(VR4CNRI>C*rkHaigdvZ7e6)YgCEsakICeD2STvYq^NLfrZw=6siUnr6iZfU%SdmrxDEhxw`AB*y z$=R#6zY>-%6_#7H1s~>?QK}+!s;);s3kSj#y%_a_b{l;Tbbe)s-%kq@#7Gt=VIuDwcMbCt>xT`)mA`D3p(to~>9fDUV){~(`{p)c~1 z4CZOk|AL~Yy5xQ*W%tPkV!NTQdMGwLMP5t52GsjQMJoY04Sg18sB_SAo5&yg0WG|c zT8atTXsqt!#u$b>c0A2U!ZnP}{P~kbioYRGW7c|xMd~VpG{zKPn=p%ji6{j{33hM2 z;*5fV;f5$w*!wvmO^^uBlF0N~SUOX<(-dd0jTF%eZg0Itn7TFvcaVM)bJspBz$DC2 z11!adCnXtsqJF)8qK&Iy9WrS1wOUR=OA6{|?Rl^U#S7~b$``aJP>*mbXS-&TH}a@S z5C7nhl|{6C7$nE-;^e^=53L>;lbefw#_{%2o_hlRLL<+fb7ozwA}_P4AI}V}5!{^` zwf1VOm3J9;onR9X3SGAnH`@Lw3JrF{_$AXhU8Yc^iSck{!*L?}f;?Nqqq$s@4@Icd z8m+Ni^dqGx3k`V#9r@u9?}XkfB)C@4A%+5T13C$ROb0E@07bROFB8m-7hJ*~eX5|S zvdobfq0Y*o<@hLwFkn}XPyfz@j-XmEP{4k&#gY7c+u$q2Hm@I)?2?ZX3{Gu=%Sc1u zZMhrD#el9%>58vQT2j5K{pbVo{ri~C8E32JUw(0x|CA(VVEIReaVwz;4u}CEm`9G` zo^t)d_NQ7LN!FjJjF=n_353ueU^_?G3Jx~1a`kf3Sk=2VFz*2Yi1@X%J^TwZD!AD! zUR6P?h`5q;2!xT6v&dj0E5|TZHJ%L11S7FQXh;KJ7rrmQZ8OwstdVEULZzf~jBeyo zTl_ws_Q%18;=A#3W^mkCGPMhvP?gMBJAxXSwSkT7-q!5j-j11op1{t~5{jFfPSnEM z*~F1f)Y`z=MA*d0&e()b+Qin(*_`12E(QL-?6Q?T>`mz83@w$MZRlhP80qQ%4(jOS zOu)d-$ohX6pOK#9AJcoKEfcrFiqQ3{yIat%UKn*;RGze( zC?~sU(rq}c=yI+jF;~`VIcDM7x3b^ZA3gFJF4mcr2yN&-c%exN(;B}=a^O(V%=b2{kMO=NO(7(S30c0yG$^tA8kptmx}G2WGhW zuCabW0$4y~q?oNgKMSJ=K}t9+!^ABPl0rpV7Cs5)EX-Y0c(=Z0iZzF`y*Dm5Hr1l2sJVc%ddjEE6U7vqgq*^lkW&gQ9^h z!5*5-SIFd~Wb3UDIvyg`KR;)_B`NEx3P*GDnmf$@vTtLlwv z55^$&Bj?9K;e~@aVn~Gdi$R>i0!|VlfMR0MmUfaTYAdix9J&iO_w#~O=*MwG4|`k= z^%f(#8kHvhHiIXijV6Zy{326Fl~)!9V4vLzh@o$U=m5=*0Fbw21{W=5Y7C;352oyg zD<933!5J)!a5l$PAB5lyjw#H66)l~U$ADz7vPL5$Os)zso~1KxiBE*uG3P%lPq3l@ zGUpM4s1-DC+ixR+di;f;wn##*Jf09Kkk5tzD-#v|8>)Cxw9G*A^EYMjA=Sw*d;L@E zcO2&_bpu(}z@awKrFm&SRBMB9%`vr4+JpspfY?$)`sCW)y5orK;lz^gXEKGn0F>lG zjd4d9;5=ERqTqTe5!$2PSq=ap@latGQgaMIqYD&w&CgCaf{^(4FD z`T+!Fsso7pIg|w6t5@yn{mYmxSyED_*o;fgJ=rx-OKAE4q?}F&)0HMqI~RmOq*eLD zJA-sHTj`;3C**y~YV+*I*3;pU_I5Q5rqb^xb&*)$onYuEbvZn$hcUR!-vbFAIWE8n zONqRYSAdZC+J5x|M)h|3^~fVOa~pY@RXUI11yr8tjlO|STAo?f{lnM3CbNIdAk-9} zkegpDk5FUq-4>g~XF?IYU0!VwOj1ql6g%4AznvWDs2q=j?|<}Sbm_E4KU0o+RtPqpX20izkCBs>H0RKM8p^mF(MXPXYCz1U_ z^_>Mjgw7Rlo%`ic=hRxfj&6_V&%{ptYCF};q}>&p1y|kbk$yedVF}1L6{|1S_i&i7 z^A%0&T|_1<$)$ykAI(YH3_%5t?V3yWyek)_&F!)~&)r?SOwAZugLEo&QYJ>dRN zq36C3zSbq_ibHDQ+g)#Vhf|4{FZQLc-u!a=nHjpLTl16b2D;eIIvoBlx{hY+pBy&m z8raF~hK}Yqmn(0C&p_jcim%2IGObHl^s&^oA+&;p(uNM}06jWs^v)?ZQ2W_4K;j50 zwi#n*5v9yQxA4KWr!~IQnLI_gjL(6qtqu4a->xnvBew6yo1GT68U{eV?XB-8-&Z7R zzdInn{kN^md<3zId<35fhm7oHKG~juVE8n=5|;y->6@R|tLqs1Q^}1wTJ~w*WA%&+ zqf>4C83=9|(8HF{%xZKYc%~KTe65@J&&SyV3{UGY+Njc@IGrfFnw9ORtHmMDm0W3^ z^)h%PHdp+fI-h>QZ0c3xy__d_63^06A$PH}QawpAv$Mr#&ok|sx;RJ;xOTf>p}$HU ziMEH#PFtpl%iB*!XZaPe`C1Duky6zU()a6SC5s)pxpnh> zRM|;MS~h%5tV=Uq=;Y?&wZ|Y?UM$TGI z(K0;!#NzzCBXDkFox?~Un$q6o@;j zfE$;~(lV3lTlPXTCD-lS7wD=L&(x1E)yJ1M|J+Ru;BoB(7_i$xvsf}R({s*9R%;K4 zfM%lKj2==8ATYXxhPUy?ch*JnFK0Fu=Kod9rQ~Ah{6CQ7e{czd(EkB}u&^-wqr@Oa z9a3FsrJ0w3}k;czDg&ph4GPGf+5I>|y%)TENHTw?Da$o;5v> zoUz@V`>gQ{Nn@?y7_}|AoMYSHE+xD1rSg3EJNDQeQ${w$lWBYOea9|dADFBSz+FOL ztX^Pit?r>8p5UIL3v7U_wtbmjodbo|m)p;<@bDg1_lKjSqY^m*21$WJKHHdFePr`= zn=7UvZfS1j!7pgoC%bv}nSXKuwpn>p<<8$uP;fBni8r|xhe_R|+{_W0miq%S2c&+DDTv#9{Wr7=tkcVdh}=!2BuVW68* zG(81hr^Ba7O};R?X*ksQc42vS#h+xtGDs=e zN1_aYk5h~jEoZ&oJ1X87-Hr_b(N+)|lw+bQc_9r(Atmf0#U8 zT=z8nL;$t}^1)?s-0t`4fgQp0_fdi69*5nPgxL!%3T@+`^FDSjsWJ@IO96_0p1rCx zmNJj#@C?w*9KH%`kNqVb%Bd^od3+P*18C;`6=-6hg=u!uy6At#Jg?A_v*qT=ARhza zn^(i&(ejD;JghXWc*+&f*)o&2VVFOS=G)_LX4Sf=AX@o(m(Cj0+#exV-M7Y}=!jW3 zJSEmWW{KU<-ee^swQ7o=CPgJPMgOtKuHsvBowrdMZKmOE;uQ-9TUAQToY2_c1g{so z{H;Xc^aft!R8N8+-7h-saDv)xqqUGivjNoE2?GcYkCm|wB6TO-Dd24#?~(^PTo9s7 zJxui})T^Axj}%Z8jSWwNhfFUJ#t;YkzQ?eQ|F^u3O312E3h-c$QG1j}_w!X!7L|FR zEzK~jljRnT8Z;3B85;uw6EhJ53`Yf6lwo02fv`{$#nF3n=pGj97TuJN%yAWPQ`V); zkDvQ=4hR+!R6sPrv70%W!!6&wB7S!fQJ-Wq% zIS3ICyDx>l96~+quRTzj+B`^%ww8QQs+oNJ$>FbxTKwtPeLXo4cfLn0#j0-bD4+$lS1+5Fjq1DQK`Y{> zvy4R;@qCtADr`y+C1C}NzXZ1UZ)6ik2Rzw5e9V!EhUBL8N_oOaPDFemJQunK#REXi zWJZ>aJU;8RK#Ip_aC6D8ta2<%A42LXYhrZ0dk`pcfO0kC^W;yZeL=sgcgLT!i_8qu^b% zY(2HDe-7YaS){!;AVuSS%d2XOR&Ru=8&2g_CZ5}?0yYYkeq9b(!&Prfu=6BjK$)`@Nq~+I9{RQ@lA3n_!O3WFLy`e;b<^f^0&|C`Vjix z7DL!>Sbn=?ZGFz!Gy1c0ChmjsOVT4&b${U4%$oi`jGa?+XiW#dv?d}?uLtTy8uutvFBEV~=2WMNrXz0_X`T?+-a?9m9YQ9>>0>&msKd-$Y zRbz(-5C?$V^Kcx?6Sn$oVhlBSb@6W`o>$ZD=yV_e(3!tT)ofq*g2fGKi{*kjpcnNt znU*KxVw0r{ZufNSA$s9XUCRHE0QxBm`G)_P^lnXleR2YzE^rz2=XNZL+bEU|OsrzQ<{Wzd+3UL`f)Sm6^{xAw{;9Wut@G9S z5m%+5HLxF<@q$~vyK$Bxw!@9BuId97Z3l;K6Kf8rF3h`Ehly4%ONFyCy|FLkUNNe6 zPZEQd3l`Be0p4IAwxb!StnT7Gj5XH5d?9WONCWYVmfvg6s_|ls7V*SJiLEh_1 zq8gLgZucerE#C^ey3!CgxkPp}SAST}uPX@SCV}vY;OsyQi>O;5)BJsX2#uqqs=R;}I!GAC*~q1o+vl$yIz zyk!tmscc1Ex`8_|M#oazWS*N%%#~>(+(Va1*?Qfa;+swWiCZ6v+!^9WGsD0w4{I4PIVWc%hsO3BTyyOm_Yr5VI6eb90#Y3$jbRftQF1X1)q(xeu0qiuIx=czM`X zN*k@e+W&DYY^V_x`&&-}&9vMf`NZs=Q~ggS3=N58fkW1@vszaYxsNJ&cCie$&)XD( z=%6VgC)+-Lc46p80%d|3VPzN|kB2-2SL6ECnS8pKHL~5Fg>lojV`&xF5#{jqC`JAW;6lsAeeP1P4FxpR--VUpHo7_ zC!yN>;aA?sQlsrIWtLUT2Jcm?XVEkCW?;j4a1>ZFT6-^gtz>HVGRLBA(Ym}vF1N-B zN!9AwLaLk4J}Hb_`iN^H`@;p7Y+RaM$fTUJ>?uUbz3iL*9m*X-OoIOKXVC6n(uz<> zF7t=YP&Og-J6{0JNFZqg%{dpj$W~Q{!zI)K6!tzI4DXCq@U8HjLEZubAJ4RBpv&Bs zx|n--<`GqE+s6XE4&QG#oCmIJ4@pgsO}L3Wn10^p0jQl7`O)Pi>DKh)Q`tG!HSCYhIl$x)E%92wT-8dyw!p z!(gVEKv6qaFA|J&41jfqT}pxmji72Pj>AE4ir74938k6_$SN%lJM5rjgoa}HG)UCO zO1fyCYn_~T>d&!g0cm9+c`ZTu%DqJdTO=lZN_b^M#^~j1ze%xOLVTjkd@K?+3K9X> zQ>V9oARzyQo0>}4Hp96j!MeW4W^yWau~I&SR3wp$iKKnFvJll z_(lcQuW_&;Hm9y@M%|k3gTE;*KTh%N1kb1L_Ep)`-sx8eVjkmrOD;y-3do-uL)brg zC?zlV^CU_(GMYqn^EL$U21=n<*ahrri2@g%OHD4w`O3!3#8%Ap!B%*DNr*(~$c_go zaCA9nLKl9Pdlc0So-!Z%VNM+~WTO1$|4Nr%o*O1Qzqv4Yy2z`1v+RyXj{k{5A_kjb zDa)(1`*V&oZ%`F#+Cm2bkA$L&mGqr{w|ix43K;!C&HA}XM#m_t3AtPp3->Q6^T^U< z9e0k8CG2PFl6x4w!s@N>C-eywDP=~ZvWJ74zvt3p!4l&70viX+*IS5z&GQaLjmhSWsz3L~jyWJyY&;$0!&kcRpVkVFxIt z$4(%8pT-wbWCSDUh(#8R;MK=%$#<9arBPz?x>ME>5aITOEteQHA*_p*-;svDkd% z2O;1-j*`=KyGtzT727W0R9aEkZtEHcqQ#0*J6W1H@g&-yN1~g==IyWX93G;RNAI8U zioSCz^L`XA;v@U&WK@NTORa+-Y#tw%b}7@4;8^osIbMZrX4v(Y?%beN3wjMmm*&+n zNNXI82Ag<(^*xzHZjf2F2kFl=*pAtQ)9%OE@Cl=Fq`xQpbXNKs^3&YC!4$Em8^1>~ zkB1(#hVEy1yr8D2E(@`EKw8{}hlbvluL->Tiw39KNh|U9^{jE}(dH`f>;qd|(xfUF zP|)tz2RV7a1Jv@j-Qu;^_N_@~3q*Baqz*1ibhGtm&f+BNPD1slt}e_C9pGL2WNv-j z_OLs<*0$TO1;{KZlR<#{K0ji2)!jLAl5e@^SaRRvPArvrq0etC12t0}vnyCseR2!_ zS-$X^mqdrTI35Od(D;;j8B`x{!!wn8ouAuiTq+iq88j zq^5?Nf>IOM2ckzsrjf+&2Vg)vsKBXQ@B@4vjq>XqT{R001lG1PaW@fQFuj-ZbgCSw z>h1a4f7YY(SDy69EZj}DmF?+stmAq%mT%P|bGm=7*4w+$=P~PzBtoCNwL{2l_Vz^q zab%~k8+uB&pRVKI=civePV^7y=g)}Y^9to_3&}1pZMXN$_m9<*g5 zik>sNRNM67h!LcHDyu&OUXFc{Hq*HIltB{aqB4Led93w0#9D)?EQ#5g zKbM;ztjy51fR(^FZRma{bccl{jIs5|<^@k+OWzE~assG)HSxj^<{+Qp1S8})YgGNR zEW^9vnT7$XEul(TBer4uJQJeAJfpv4i-}??4Do?4w0xi4WlsS`741}PI!H)7Y>+?M zOEixVxTT)B`E9`>WR=ZIO=kF4lHyrjzLRa+lKu|TU-Kz(Y&o$!oM;<1q3gT#laww> zAN#&~K=yGjPdG}DM8RinuTolC)%83n&lv?Rv4$~BdzGL|FwDE|t9fb4Al2~-k^GDj z151`v!NBc9|1ydL<%L9cG z*9A*i$k$ks=^jyX{on^tL6uRT}$B zZSS3s5Z-u=9g{F{+v7Fh&pCA?yj4kAr)Kqv5ry<*#xYy4nOr zQJ~B7Os1=ohgpt)t8w(n>DNC10Uer4rbbNi76jNz!5f!&OP`nz>>#FsuIv=l+C9|k{j@Lg_RPu`EQ>xSq z4kfk6Wp%Z1FVG*j@h?c*|M!)fh53K=%FW31AMIgnxe1#9dic%{s^`@5ayO-O2m%)3 zQtWvZ0t8b-x1OysR^u*-A26Zv~M|R4o zdh9|(n;Ziaq!#Kj+D-3!2!gX|?H74I)fCI*?oC_gXHdit7<)|`f$o{9GHufk#R4!O z;l4ld6=<0_Rd#ME#UmxPAB16rkKiF5OT*F~Y9A3u7GM-q6XYq@$$@d~nzXU4xN#`v z8UpewB!V(+wUu*8wmUaLSDouP;oEtHwX(LL=p!FM$4D~W2CTC}2`48x1l{=UlvhvFdwWN!PgfDdg*5I12Q!FJRq`;pu zu^WP}xb5UeBSlut>FeT`_Oaqx2ywAIA$%oy`fzY?e|+@u3i9yXEVqIiSF*fUFS?qY zkIo;y+sOxd$CGSF?~}|O4%6%K(rzz`I5B3shmQ<4I&E(Iy>jP;Vn{ZVcKw5!@@gTf zZ{=`2+I`)N0Y`)Hr0yE|#8M~lHiaG-#OfVb)arsU<9-mV@*1&0^87}{lIc`#=kv!P zKmIrZuCC63%i*@DmJC*p=Sp#xg%X)8Ytx$>g!+Xkl3tr6$<&sR9!d1Kn4GQmzb#p~ z`f)A?$8I4(AYDwx5^ipaIPIgegOI|c&)D< zt52ugZ71#YvwUI*#|Q>3l(Snz#J;ENH9c;DX3Q)q+~%`d7P!WA8`~rQ(A%Wn6an(T zmGCGt{A5SL=kWnq3RF#L;p7U0H$;$?Zrl3h|=0%PQw7U)luESbOJY762gPL^;? z>8QM6g@e+&MPLg;mN55#bSde)Vugj$vqk80X$#UPRF(+$jCAQP!KpkKg&X+qeVyylBV!?Uk&N1yk&)p(x*jG3!x?@70+ z-icSWI7S-`R#&yX`dc-y9!nmtk^@X32P@1qU*pyZHHkTO2^%EQu~BMVzl*ELxSpC_^d3mm?Q#Eksr(U~(T0O<8ipP}ydlDM{|^F@ z`8WLyfN5|LxmfI)=*R$g(n|Wy^5Wda{63EvcN-Y?e}$z$m@6e9089`}84M&N@f_Z| z2NR72h{+D#PFdfjeOA1M*4Xsp0(8p#037X++&O%<^DP+V85_B2+&jV>mX4T*t*AUE zaVTCt8OyS5f^s-{U?QTT<^u=#@JjEodQ@H2OXdWq=mzachb0+PId&a+1bNJp$`z1- zX2T_n)rFm%b}yn>8dqco-Qx?>_$YQJvJ(&jco$ALqNmv{2=_oDA|fS%3QA(=ZeZ4Jtcmd4aBN zwvf8q>$vg{eZJuO99OIq$@*NHsvbd~aso!Ce4TCL81$cLi!}ZI0rd#we#Yz%U;G$8 z)su;V*drFl}O^rypNd9{Sz1Pcd1FLAy z-QV5K6~n78^XT9e$w`E2Uel9WKx2@0qtrywK!AtG#Dtea&`?yAmmg4nz|_%chH8p& zvr-HJC6_`Aig=WL1ocVa!Ex_h<6OfX_Dn#l)suwQR#jIn=giu5`*?_neFQ&Gh#0gBAlM7)rrsE$8*I^(N$5e7wB|jk zx=nUCd_>Kc;}nZ!;n! zVF!#boq(M6Pyw-Dv!5G(Wrsz)r#F?`?Q1cvH%16M zHwtYbxmmFvy*@$z%vP4t5zx_>vB3pfvkzTJ4~*=`^7vF1`Fv7{>B)S&T$@F0F}eE>+15ug*pe82K*k$fij}7_lH9_RxyB0fh$`ZwgS)# zDw8xpWYHE)TN&zPYVYk|O03vMbN!_6m<3T8@Yh=z>yA)7?(d-IbJm#X^t#ak=K~(u zt*HOnS;>~{0Mun#h0@jA(vRY}2Rkxvg~IDoKON;(@qgDHXB5P75=xGo(E05_lT3z? zjH56lEWdI2<7d#@78vt|W#&d0EH1MoR{aq~Z?PDH#!ovHO^L5sr%Jm9T$e=Ri+XrU zSj4jBcYL5JC9^t_lwCMv9uKmnEf9_IZeGRq4$Qm`Ooe!ypSU~-F{9jFLu!zwI{#RvJKgGdz?EPKdd?HQ zWK%Bb#=rGsIv5;ecu<*nU=UtZlaOW!!NCu1z&;7y?y?uG_vw_yxOpFY(s?qQzvyh+O^9#My*p&27E@eq8l z3^bwU&E?0#lP*bI7mpkx>w1&;HusxKhKu+!e@d$G1Q+n~QfPY;dJUdmr9m)nBKyw z{ke!1@iJP(aOUV;L`kEf%%9|~+aBXG$xl(7RAYb&Hc`}bpfE_? z9x}M|6VOSK^$mpTIDbvD+eYHa74Uu_c`0$rS4A0W6;L5Jsa57>mr?l1Ut3A}97t0O z(>$^RCAcNjl4c%MA`z-$ulY&4xR}ove}V0?#SqTR z6&4=46f*E!F#e?!?*84sHU-6@cGB(D#AX<--($tS2#Yhh zbw*Ya?KR@f2o?uAq7st%It=fKOyt$ds(0*;J`(wAd`4vS^!2pEZYGC&YZgTwF|9K< z8R@J)m)o|4VEujTSM~Kd)nH2ddB_P?Vlm^rv0NcLu!VK>N!|xDaYOjBL2Ng8%6%bu z(7NJUd6chLKwt*fz}HYbil~tr`Yh|D>puCUsX$&eXLl&s=_{4`?aA2!&@9Z!)y^5* z*6Rrh_h!RQkv_k}8=Sm+uLzC%iHilp)q5jlM1&3MSF=8jSpj=9RY3+@wxNEQdXdqN z=t6IMlSvQ%R9X7&V~kx5KfBho5k?$Bf|teS058){CuITu($k_caA z`zwH$6|jFmGWYMaPYhe#TbHcC;nq*=;3MxC8UGC#^S{&0tQl!mvg>3X9h+_+?QnT+ z##&#i>ztaJN=h0_UzOv;4P$Ox#foI=9d%qy9c?X*f4v|E920YjAXUV>LbZe1u$K8m zL_{exN>YAs=%VpO<(u52l*ffW%m-<7r4rg$DyWeD#(j8Sy1kp}}Ue zr3wahnlCT)qck=QSk8fG6Hgz|Fv%{~RkK4jFbt~WeWf$YSg`r3M&QJvcUXmQs($Os zK0Ls2)h&ImAeURNaw`(cqVp95tb*zzdPq6a$0VLZkW|FW+M1z&IHZe4b^P}ir;A@8 zaANx4dmpu8qAM7TzhVJ3ho0{$X{zR_euK9xp=a;0wg$VnHkKo-PsWw4ks1MqwcN*e zSJl~h(Lk1+1A(vCJwzjqjt4x4R+bM$)Dy;v+ZAeDLi<^h#W8sj4Z)v9&VOh5Qw^eH zRUOtKroTv2C|N!CC1Y#2>gSzr-& zxSC<6JLpTP!xH}@Nh1V;Yf?Hd{OX(Zk$2@;S!s6*IXsB;0Cr~BD*lVx3Ny@XvJt_b zT0;-&{g-FLr@!|QnTpuzjkeOuQmIgC*mdicnr^f0O@`nJ&Qk<`bDDG8c?g+1k*t{t z!b}R(BZGDIb0FKu&4oD%{eySM^r3D&8L`)R{VE?>z4%66XxcDPLc~lczew#CQlgurJE~#Hg}>+iKiXeOe^8cOOcD z;g$x4=a@63>CAsQk-1;gam`Qh?a)cci}{R7E4T_#B6CIgHIp)JXBWhtL~|Nj8wagw zrvMC1EMVuIVG_?eW+byQcg#Mq)6;nahEIkcP-OiE97+2Av>%FLuX<@LBTaT~mmZs{ zM#xL8II%LQmc-ywcAcmaQTQro`&DZdtndRbXy3Dyqs*C8xNDb(=PY{ZCZp7>82?Ft z!ys|^hSvtMh7)IZyJ$A|@@&Qc_B{>Rg(tqr7ESP#Q*xOqM~+i+btk{R|LdxL7)geB ztP`EG%XXWwnq;(R#En8DGBGE_48-B^s`-h-g#h;fdsLvseEe|HGJ6qWhe|tKGnGzw zLo(KtbQ;+^l2v+@haObmNS#i_4+QUg)faQnJy0`tchG~J)f0vdLunxYkB-e%Vip>` zZVG@t$P~OUl8uMkR3t#kGivR45Qup!aJZS<6W$>1J3$}?axJQ;^#z9tOU9K*Ja{F( zp%`zvx?BjU0E3c1bF&nT1h^siZ(+=Z_=Hp{v8T5$0M3I{g3X=y@HbY=WT)t1XBm+L zAt9E^?IpvTxuhr$1FlkaAFG@oj8$ij5S4LrjR(3m6}e#d9^GNQ_=_3y7n-!jF*JDN zB|LUe4N`q}G8f7T2OGYAL$XD?W5J`N??T-LN@1d1L`{f9dt*qO@EeP@r>^|ik;gFa ztI?)i@24qPPv5?ynmRRBFJ7cbc@Jf)!^n-tR_-Xlz@WB@1Hwe#amwI!^?I}8tz@v( z6ApRdtAm<|P&xrjSWirH!nD$7<|;|`)1&nD1wlyXZp>><`tRYJ<(Jbp0G0cZS25L- zAGn-(d}t@cRyE@%DPD=>Qn6tA)wQDB8j&poK;POfWhEbkaqNY$yKeB&*0URF4Ka}& zD7tRzGh$)!p*vy7HEkNhTxu-XU}WSXH*hRK{r6$1&9g0*-!>J^gR(=zoR zxE^J9*?SQPFKmf;Nx(S?tGK-udkL%7pJ)a>NlbUIioEJOH(7;wu19%g;_>>(G7Jtg z;`_wBGxo7u)^dJBsJn1-Q+=aSHXYxtsxG3xz+D(FMOXFQE4W*&6vsXXwzW}sK8YGo zvY%LoFM~ZaK?r*ea^?Grl-yV;W4DZt`VOr2w&~Vs98Z7Y0-<`hj6=4AsOgINLZpoK z>F)=3CT@?>7{$@QvPnC{qgf$yE^6!EUc{#e7i-ib8SCP#vu{5NKc-%r_zcbVA~;^$ zfGyzYng}*4{{qoMqMhZ8PS%)G6_j_j+J#EXl{snb(Fe~7c$Z^aFm-c3h+ikrHBgjM zjJKTZc~?+jzbv7tDnsT>{&b-I5%DO&FSkDt z>Mwlve21zLdJ#Rbr;RcN-nsoZyL z;(%u?anv@w4sI&(MXl28$l8ONG#_#%uFmAv-UTCS_*hN-^d*52cC0AmRrkk&@3{a7 zGn0x9QdEm*#1K`|2Rj6~Vy54Z=U4+Y>1l|TS;$`n;};MwzekO(iqX#2D(v|CKQ(99 ze*8Dh*mjGdG-Me)!cYd;jNm?O?%UYRZ>;#8Q{wXUEp`K~sP4?{6XpR|57*>Cb?b=T z9xcLxgp?@ptMQKa%rlLm;1-^v?%!$wM5xFzSZpgX*H|p!YUMoXznFATh+33Qmk^eB zA8?%6UbO*b%udNWgYo9xD+XBc1Mm^+($!wdtiR;bl}t%t4~0B<`b;+j-1w1PQ4I~f>2b0u z8;~Q^aB$qT+FrAwWw% z`4XiPa)Ruz@d&y}+A(sv@ET__@$*6ld*?DohWKmi`~9JtvA(fG{cRL9q%)xH$i@i3 z9&R|v*K=}RQ#(V{??wRi0`DH&wtjxE%Q%{)jPjL!FnGY}*vc2_En|TFE%{e$E|a^s z0tfci7W=+gKJD2SS$AI$=-AAQ$n3KYyry)c1YCTFm=MbMV9)g>{ZeCdb0yPpvAX1F|AD~ zFrHS9XLlbs^B$*OzoEkh1QqX;LfkA1Pm+8EpGj$H%}r9BRMs+a%6I1Yjj^TRIN%pD ze;NgBMxU+^4x)?KUxVUBn`E&64VvV1;yvkw`Rier}U=TO#A%#YvVy41EBt~%_A5N}^ z$v73kG`R>MW_$S4rg3#| z_m`8I-&w0B3TehRI{r^#$Y`cV&XDor4>9UDn*r%_vR5<_^&ha4UggNgb)tC@NELCo zC(Nx6te}&2Nw`m2@^6EnY)bpLG(@m$@;v$Uw=zy$*m+-Xj*pN6ESMqKGDhaOKWy-2NK76;`mWm0cX@!d@l-9|GX-T9RhB-Dn=hJ` z5<3NU7GN{v3EY)iLJ%{4r?qA1n|M=)Z28uo<^yr$%o#b3v7(jsuAKBn(H)!8O3ryM zgO_yPkm>w|d`&j*r%qs*SBRG+$(tDvv=TcI3O^8P$Rf*V>~apk$)FfhJu2?oFZE{! zwp(%-3jz>XIHT8Hs%$f+KB@GmZ3(9+yibORluwVdPjQedh9wDizUuX-$qqop=uBVT zVZrMderWkmD6=)wa{b8Bm?0vw+bC$Iz~P~HP>w$hy8$u^6z@LvU;9hTY-|X0pkj-0$Nwwtya#pi0|G%&-- zFgzvEuyHJc%@<>QK8C3ab!~?|oNW6s1ubs3xGu(v2E7*0`V~d=0^{h{^% z2H!+0hM5ftx~3O`*jy={fFOEM$ycdTi5^a4+(cU{zjq(*7$+qs{p#tl>0+fGmA;{) z<^w7#=jKy*kEP~Wj*SQV7n`1xP6IvFwI3ct6z!8Q)BIXXQlkT3g1?Up5FHG@_XV0o zfe82)WIeI9j9roycB$OaxxZ0<3Aji|!`CK)b&)SuRf7oGqTyg(iQ^jsfyqAH3XxJ8 zq5XWZq{72V(RThNGCPDoHQ^${>ejZtQOz(uH-mtO=Ermq{{w`rm@-JS`Jdk9+>3Y- z!qL4ugN4Z5<#m?_oU)PzrUv9Xa8*Flw-NZZQ7DoN?SjcLKeG_oU{R^cRMONJhkR=6 zymekKenq2clT8|{drAPWnA#V}sk3#3Pk-el%%;!BI?K9tzm}?b?J1R|MiYv_GG*l0 zzrqH_rA4pLBUMA=wDC?ee{ll?saX2itK}T})bezv4v!vp5zKxI_t3r}CC>m=_>^t< z2PW{rB-7|qsJ${#A{=N){!U?4bYV4C{u1dhyZ~oLY7tWBX4a%!l{Ih@t(s7BZz3wl>j4H=b8fiNL!CEDDABU6&<@$c>BG6qYRGyd2%6_;m0%AaeLPgCB zW^i1=gSBErVN&e3FC-M_d0?9N4<5}q|JIbE=5Sxx)YtMubg+ck*V2duLIPN+d3@*R zZIve-kfZPJi8s|F!8_l1ym4l3j>^OmzOFP%@N#Q?=&K_H*{z%vnlOvZDIMq;{+Y8?>U3%t{l(vd zu9fXf!hsI`Ai6H9t``Qr3rj#?El3Gb4Ic}!-^T63LDX})`z1de8uCd=)%oiz6sih+K7>tP{rDk%d5WXiuogVH&ss8Hpec*{@Qj!DvM{s zCV%SJioM1P1;j1rwdD%D&VCL4atFPNAmek{sE&4ceSv{%$Yhf(>*jWwNuijZpHF%N z4xWLHeExO4fn=TUIpAfr>>m6tSj63Zl^OyPx<$Q-sCQx5>cQw?iI*Ioop6(BahPFr zfQdPFeZ9mrX6_gJ&u&7<6_7SCX^IN1Ho?KbRf(ZaN9qevtIt^Ju`*_){v!QNs163H z&-zA737+ch>xp>&cFTCneP?}|Mj)VS(oAbGCf8lkyYOfZ!tCSTVZBlDTzQ~Aedeur zbn%{j>D-KNr@U9*BrK?|y~HkoSHyY)y=$ND^!P~p%z(DSypHrv0TF?wgZ_hQXLY;V z9q%K}vmUJ_uo0|=*5+fDW)MOsc>O=^ks>ycPJ4&cA^H;is{x!~UCcVGK^=w(iBG`D z*U8X6&@~<-J6uMees704Rcs1w*66P|;cq7GFa@}^*eY?E4HPJXPD{tf?qHxK>niWz zmqdVC(k-6Vt}&2&KQd~JT@m)BRhDVAu?CXqO@J$VZP5{ir#@c8NXc7_X{H_PW!xnk zu1^B=(=Au_c`0X}Bb(-|cM)}Pl=S<>#K_;CYtU-vXjj;$*t7(+1VT&8@hYn63hy;n0SB{g;;tvwqv{%yrBf7_et? z=ZQmwBK%fAA*S0_pE9c$a&SYGP6n>ZKf(@ zNC|wj`nT}beC=^yF=ca-A4jh^wm^hqc~tMA{|A=h+seod3&$oQ&N zk~FFBaH^TWry%S-uvhZI0y?;-{4;1I7m7&?wbm6H(x8aOf7GFk(Af{;2-rqzo8NRN zOF?*h<7|kLl2RgFz4SA^9w)cOW^EZoqwP#o39@2 zoogPrizd)Yd8@0ZcyVy1 zrf?*vel@jJIW+}OB(O;l6VeqynTQ&=bn);I=5=Y}hciE!m7`+0L1|;6SK{kcmA;=_ z93F1(_VN6m!}ykcee76Z6T+&W3AZ?UoOguVe-%b#|HS+1oWitTgvD<&L(bLak$-he zD*9qG_aV3y-;DlrE9!!O^rB~Qk!^s8!QJ{9>t&oJK2INO%j1^;6r|d4D-aAwuWCl) zWgPbVLEkFVYBGd(PjERt8nP=6yP_aKnO@g^W1XJ5L5G;HAY>=-jsUm;h+;+7C$NKh z5aM`Y(JR@RH1y9mlMWjfP8SwQW~5hDyxm%8OAEi95uqHB$*5rNA;<6(d&^XcOsiY8 zyt{c$`TfokB+Q`7p2n&y*)tVEKfCfA#bgTY!;cMxpu`;&MncS@ z454Fcee8oS=P)vZ3J%#d79l+t9a&&{4{m4X40N;G$>o!T`J|>+QM+iCU{v~^dH9FU z+NrfsZ|`E^O9-vCkcpM3BJeeH5>y*Y>b^j4RrTkPQP>Bb3w?p%Zd$XLF}cPEI3wH3 zLCub5T9bo^Y$eoLY8H~0_hU)og$7dYx@$8}eao+NTA>PM9r0o=_sHW372uo^BDDPGeD>7RWs`~?W$eE$Sx);L~5NUN?Uxr*-8wT+T|uEUW^0!m`wI;R56X1GrqF zXQ-jzc?h;Je-eOqGc5d9#2MyrnS3Umq#rLW$L6&U|2Y?J?cafykv%~DOO(T1cB^pd z!YN=Bvjd!s{!14T7(-dwB%Te!+?Q486Q9~3#QYNAcW3V9qoFHCASS|d;z)GPQeDl; zuBBg%?ZK=NDd&G3K{TplbZ7k?KtSt67$+T)nJj02Kr}S3Q$=5;qBD_JAa~*!CF{eR z7&+vFL}AoS66db*!s8li;nGndreivAe?3Pd_UzBY17wu1?pN0H6^|eH3#z-UKeKyO z0{YH~Z*skijeE~JV2pbDv-cd7^9i05yYiW%%Dn)kF4ayUPqBd26kJGz{@R-a$@{)z zRAc14Z1Vzwx!g0lF?Z9a(&5$!f5NA%0GNDQ=1%;*6X~I2K!aX9Rm|SlbrOPM{(a@t$a& zJ*&L@1-nt{16?)Z?aK;*0eSf}e&OapkTq?+L!JL-jW6 zayY);%7=Z0zOJbzwEbbMJ)QaD48e-7+3E^Ao=uY?7Bu4%CY&O%k^cgTZcb5I4siiJ z0qDV!AooqRC@rB8p=NdQNGDih8D|bf)L167q-^bw1;MjeF;tLZtbMJE`&iPZaMfz~ zMrds2^*6zc6kqknC_HL$r3jDljQiwAbWxRuk&UW!T{g0F%z)ljT3)CQImqM)_|`PD z{8-+kIyhA&5f5hc)YP&~1dwqLA2`bQ_jZ?rOb2T1hy-J!F#BqcZ!N?9=1M%4nY+9QLqx|%Kn=A4R*Q^$Ilo`d^sSGAlzy=Q zWMA|}Kpu_fLRus=kS9sa;Nuhu`=$KAU4z-L@D(q1QL`lpBo1?qp%5m`bG_si9k4si zy7sqK#U>@xXG9;8F~44;aJXD&S) z(eZE)p&tBcLl0a4u9sOXR5Cpc=u3B-ccp892S~5245c3D_lY-}X&dIR+rfqEWT)HZGy{(IL zlLJ7;6nxVie2Qehh{VQ{S_mqfrw%PtKE1QWQWy<$(e|Mg8_la+Y=?y`KLbBBV{K%4 zr}QG3-LJ|8$+cJU@ZdNrTrbjwxomVd)3=qQ(8(=78qwPOJ_5d|#jo&29>Id6hM0Kz~k)ArS%P?5a`dUf1(OoqS zgtA-q_?h>jYNFCZm|UQSX@pa6oAb&77KAb*eAu`hjG$eYK`~&-Mw06@=;_%R+$L}6 zklj{6n9t&WUfGJHY+oV9AMF~2cTQrw9jtu@@k*i~NbvyoQP>u@rnHTw1$xja9brQ{O)#P6tK6D`;C*UYmHZ zRS3n@EE>s<%N4~^>_9mEZ5HRbWyTNQ7fXP#=8OkoKL{aCcWLUgqr+3W#zA>hD=MC@ zHT5?AS*ya5x`+t_;=9xwx!<%-`tULNV9Yfj4quNb&EC_%2>#dwbRPBNlgEX@u&|7% z66O_d{q%)DP*bf<_BN-|hhrG0YAX?1*#=O$`iWSGw-+bU_Y!y+?i=kWy820MIhx0x zfB&4$ensSBF#f>Zvl!uiV{*^{NzA(KOlbdZ!F=uZlCa02`y%_`Wna%DMIG*#rjQZZ zEmhHb;kC_}OxzWW`!mG-dZoyfVxnnoUHprETn?sAc9eGE&>y5T5q71uyo;anJeX{B z9Tt)rkoc-^g9ZSe0K7DVSFv}lj2*&P8M)=Y+9d65-L3Jpt|9&W4X_;^eH~g>kFS;L z+I(ESJjm+&tv%#DlX5t;P;@1St`tcM+mC2QwVZw(t|YBy>|7l|5j?!&SLZws%2$8g zvOc`ENh;_m$gpc&hnwj8vy)%lqj9y{FtC#qLsV7}wFs?;klm3RN4`|Q{0XGl)Yd9r z;y9_YdGIbRq-Lupz`<-PIfiLq)T71=A1-PX8ma z*}^G=Q!U6!cJkjsw1DJB16w9~%t+DlVpb1wL_Rfr#WIU|FG=2P#%Raph{mD&lewFIV5P=ZvRe4-?}J=yy~CM!BtEp(TgJPTinfv;Y17HXvn;i4e-Dax{3Wj7PB-WD!y2mI zGCfXm0_-8eDk)&5rzM5FpX!9tI@8Byo8mN<4hA@eUV4*+`uKpiDKUcDpdwJ>hsw^v zRXP4?ZEI{QYlg?^Loz&;e)KMG*&CP!lgC(B^*$i@@r|D_w@X9Y`Es^- z=>w?V7vgS@A`Nqh-S-F79Ure32nwXzK66_On#JH6r#f`;g}p!iDs*kGn+inj=`riQ z;aC$G-%g=Q-(Rc=Mbei-#|u9DAgO95n?e$efYH(Kd@O@e0OzE{L_fwfyPjSKl(7^TdOgr7Slz?!eEgv7KxX_3B!Ox;Is#rdJWz2BFF`tn=i=9^(h#Q-=;>kL$LI!j~Ay-;dn^ZRZo>v2&B%Y%zN~*B< z=NBDNH)T*!c1b-W;YXtHisdxD+m_BDgVbWlx%Jb@lQ76Op33nhHqJ%YTlx1?4MDcg zpOnZ#tp$CmtRnwEGzvQ)yCo&$L$6+hGH6_Uv_Ja!G|x~b?~6EC<-xU2Pp#p}1joqhHZaCCtC_u70-Cp{aCv5kCg zk6nIezG0$2Ngh6an+7cgprJr^3BjFu&Ju=z;cWXL5qlS?A#IB-4$Jm$p4uM3i|>3L3L+esOF$r?@%A1+1ldD<(X;A zwkH*`+VjXhu9;NVkK$^C+n?*Te^_ zLL7BH{@Ii)J6I@Ux8Jv3*qdjqFZ_m_C6C)u-aIhgS4f!*0d7Mz_Usx{{tcFjn)!Mlfw zch1;!8;@lhmfW;pl@VZ`}@F&=vv#tMd{-q9M{cWiZ5eD z@rK{+B?+GH&T&O^YjZd4GU36nsU%hAa4c`vb_a4$IV(O-F;VF$?K{MIvU92#)F+{* zMBEX5L0X8%xo{ik7hA+w?PAXEE*$DdoBZ4@b7qOx6Vv%5{rNaC?lO(r3hyKk#Nb$^ zx5m$DR?~+z6IEdVKLwxNHB*jG%dT#b^72zsqZ2_3l=EpnpK{#K5d*>SxJg#q)stTc z8#F8V=j;-_KCqxj>oj)m3Qb%gk;LgC{yvA%?0$sf zO4&HXj=7kM(hXtF>IVI4SP-^HaB9&um0>q)uyk1=Xd*FNtWsKx?J`G2E2+T16UkpJ zPI7&A?&)w2;eSajRdhQo1v({%QV!LA3!)%hbu{zMaFpC3@kb(*UNNQ-!TC-hHVmL- z!`f8bre5rr-~dx`3l9_Xf)3o?OlG%2@ohakfg6KXPxxW19TIEPNBU;b!TkX;%O*DRY^ z0zXmF)*4K*^UAKnWa-kqe|r!D${=&i~sMs z2^aJK1K7rD{{w8zT5`$9E|lcRCX5QWP=$rS6G^0!5pe!xTng!kz@FMQoOYbL&HN*5 zv$lvr8Gtfi9D(gr`Fef9!gZigxkHRwK0WdqkLf<&-(DP97UtdD+g8^;)2|x+TDq(# zzXsj+&(te07;(3l0#M za@*T{R&V}s{`}vS{HFAYj>a;-`MlPP#*#}I5a6Oxe0;pAvkg{X3l>te8w|2e*xc?8 zv=v}K`46^uTOhgGY&AW-UK})MVFgQ?f_S_5(GnFHCm&U)g3WvG{x4cvbooV`40@P* zZ;*Y0c2#xbth0~2M~ryCde}(EB(&RT-O&@FS~H*Q{Y{VXfC!`RIhvyf>ftr|v$Q!x zQg&E?J1fJcY1Tg0wP7%4O(C_(q!K$Vkp++S_y6^t3};qkYL3CbCu7a7vj9v&g8Qv0kYe)00L9rsgaS zSnas?JPm=`gLLL;OtKkflem*vF{};Q+I^J(z2EASx|7yNcINO6X-;O#%;y>Klf07> z=BN!BYyGxnn^+#^Q$!N|a3;&r;WE|`W03d_^>sR?W{n1xIY#;xpWTlE8(bSH^>n&4 z_+;`4%`PEroNWbt?jfj<$;4Ztafmt0jqauw}bVR3~K^*8}`oyIqO%`$(g$@ z;h1pWQ~p(-*Y#3sm&k<@m4wLCE}g+E@!6~_4hMva`Yu|#O2?zTXLJYT1Rc^UU| z8>JTvsr0%Q8B#S(Py%H|$@k z&86r%x?MyXuI99k*;7vU@QBS|#cOuN;4+R6A&WoUDwFtjZ$3<~r%g?}dM7H-qXrSz zq*$iSlV68HI5Jm-X-eBhlc;iL;WA>e#my|wZ_f7#906qh6W{Bk2VTqW=9F<)gN+J! z3)EJZCl@a{U)tE1f;iI_=m3BygC>v;5mSVSnuI)U@v~`>m|cJ$JgGIZ{zL`{;Y?c( z!~Jo_`L%v^kIQ*w(B){nah6QEF>Q!ypx-|tu}H|Tqiv|BhJA2FfQ&|)^v_i8BUT?j zi_@#KYv=K&O?=*Jz?Jv)cz9t1O=eUy?T1IJB-n6Nvy*pc`ADL-bO>?Dzu;BZe4Q?H zz^i$4BSvPXD3OkDnEH6%b`8Y%P(Hc9Ldf#SiMt+L!1b3X7vfU3z{LVN?n+xMrjhQI z&foFD!4}P;3R01RE+bmb9>3d?ek-oU`OY4?y;0ud!1w&y!hN4$Vty`uE^#@x_{d-3 ze|MbdfKn^v{2EFViK#CrHGEY9KfN~F+S|*!upKC%kdRK>oaiwXDqlBGWb#nNm#Qy9 z?-Kr=^Q)@$whb9pV(xkxE5BP!W6YfO*SdW0`#gyFry7_KUdN7oSafW-zlcFZfLWo- zi!cCeSOO=4LjlMn^B6OKGk>GxfzIgx+RBTLJbtdjHaED&i!`F>S=O@f)a(Pz|rn#Qnm4R4CG@;F_SyuY=6S2CtG-Ks=jUDE0)}Qv zloCN!UUg!6PaS0|SjIhqc-v5$k~F=;CUpWOrp2O_K%m5k@9O^kPXP)}n{3u#XqP$R z)I0>~-mnodnzCq^^;h# z!ru56KB^HlhJ9X(XE(GOo+vh+cy`02*s-RoB$kf_y;10+SS&g`fy{XF!?krgOEQ?4 z(9L2+yL6NTZcnY?BUP~yQ{UZ2lV zZId1dRa0<=9Enb$OGh}>r#fM%_gD6fn5%7oBBU#w4piMpP;MU?9-k9G-*5ay+pO(RA$33^Ti7Uqevo#A z=7Od(%-3~L1cErr2Gi@pSB(>`m?%8x&F7U#M_ECTP~wQBvprDa)F#v^MezORj2Fzf z!!^LTQf=Us7(>ZOM=5Gh!gChe{06z0N6i+^pzN3~T-AdFGFC@jN5IN4C|)F4F)&Y@ zkgQph0+Z@Ub$sGq?ehe%a)o+%T@fjZ)HWAVG?xcmct~1Ushcx;+~pP^X66Q0%QmD> zfqud7pycckuT0huNo~Ot1A`$8;tx0*IhRB*xZrY!7C3fXZ9N}MgUjHx8NLc{b=G(D z3i%;UJp|oWJhGlO1L|?!P_-bY)qZMcp_xp`v=7>TdKvHDwG<{Co&&L_C_&pf<#A!- zNw~FNP5+i4HC9`kmHxU|-q_VIlLR}@l9eSG?zQ{v{A8KolSQY>J`>^xwh8EoquRe(&#K+I`46&=un6+@VMmR0lubq zbDMTQE#DYM7Z!0iX~O@dXSvANN2=htf$p*zs1Ho1D=6ixc;e-2;DG5Xa@QAm0XekIK- zBLB!B%|jHcRwp10-Az)KA`x65UK&_=(HZ=fCW@ZIV-~RG?J;-9ExYCYPx?jo3bJTu zxOXngiH)jfD*h)nWf(Gu+u(go;5VWG0yguWS+PleC*kHyLEATeS%fFwFMm(IA>_>I zZ$xJ=4O@0IwQ$9=NVSlIAz$M4`gyx*25=8hcWYfSG7cvdsj)+Nn8T0dy{ z1?y#>e6O>OQ(P@L0IT9`jl1rG_~UseuqF?x4_JqM3%J1h4a3`}kK|HYMr2V#)S)Yc zaSIPr4+;VTgM!q7@bK#D@N8Ib+Ygql)McD+TEITfWX08*`4{0IVxqy2UIn_x`Jmur zB_rhjSUb35L&(GapUnl~=8{~VQA<5*J8;e3F|ih0QxiC)NQAYAZnI<}PBOx_?#|{^ zR6(TCvB1voE;%@k!9FloxP`3V=PHoY@F|G#{2H7MFT81g^~1e}ft6SCTQ7_i@VoT# zxZH4stFv<5K^Y?BN}AuxzT=Q4el1a{{BS0PhpsC;I0$MDmM*~aaH#O9bPG-A>7qzV z7C6zM&vL88jX(MohUo93*ZClV?M7xXCl-}b`NbU6{OI$h2LkZAP1j0(UM7DKxLJj_cUc^2Hk!GAmSOeKSIPKY&ec8L*?ihr1bhjD1m@JJsq1e$8F1g&5 zOf_(x2t`8I4 zyx5sYR?49;tHob=zvscdr0nVsV1!)E_*&>ov`xVz|5V-g5*eb0%6(-_YBmUEirp-=>QFTK+xpBF&w3wu6 zFxC^ev7LwD=w{a{`Hkl%Z$(A}y(sy63q?`IDkN2Xp1|y2 zvFNtTCqrm6BqXT9=b|@L$rW(DXXHwf!SOSpXX{-L1jNK!!#a*9v28x6X|bME0#{&}m6(V- zP_^Oqa-o)rpR!v5p|Qts1D6rMG4d}>nS)l|fo>NN_NU<-R%IfFeV3SCgUKD*5W$)> z_b+j2aV0o%FE8>8ZbM^*Ic$Xm{7Hc)v((0+19|QyQ~EHiavI{+?adB+EQwTI(~r>j zzlD=LBapczRwq zEk)JgiA5R$1e^TF5pudnJmLs9;gew6inH5VA@^AhC!A5YI!aT;K07YhoEzocy1n}; z@s=H)Mv9bn47(ukS{OYe>CN`mraog;V9B<2nPg^K%JjU|4-3=wG6*7%$LYTvu-8as zQfL@ti&gbRJO@*+moqr(%RLQ(1lrC1pUq~drQ~YQv3{Xuigo9h2FnyHszkK|lU)3_FF<`ER%;fy#>m_-2&MeDYcvI1yvsoWu`W zzll%Wf@e^Vx}%U!`aj;tisxbLd9rfb_~=k0(@>7ccPQnixad6U#)h2s0dFj6`cJKN z9nqAvxeiiaBzOjg9Jadrnoyzg+Pvp2D4}P^OgymbJhPm-Fgo5 zdj#H497p}`Jp)qfZL-o#EkjSgrMcJrxA| z=pGxSjn{pImA$acqqDaV4yUg!m&5nf4lgynQK@QH7ADr3)|BXPL2X{x zkxminxk9&sUTUK-z7(f)cOy7wnF~redcu!eB!pX_m9*|?8XBeyM?zJ#oVP>B+*n^h z{^Vux62vGb`vv9Sb=w*oDo`F88=z2D#yi0<0RMo^Hf_U)OeHy&wkAaHtrMbN_now5 z`@}p<^0vpbQ8-LK6G>I5o7rE7%uAWYoLbixITXegM6m~JMYZ3@#~ZHbMV`= zKykU_%qi+Cck8RtSQoP$3t&7fOz)ez?eyrsgY#zh7vXm8R|ejjw4lK=xtITjmexT{ zbTzUJkl1hm!V4#sqfkuM7Drf+|FT6ar75}CYS5lkZYND&?@K5ltV!6y-iH-4qT*$x zD8;YeUEEuuO_;=yf%l03X?JkNj*BCjmAXiDu~1%-H^Vf6+NpUiXymX9%K&gywS75l zJU|@7A-=97?7lbqL<&uxVoxUc8OYL@^>*)4AlHVyNz(PnRX_Ju{_xSpidmDR`*0Ro zJdxgg^*H4ebQP9&O0EfyHE(9N8H>_Q{39vMGEz|yMltT!YCTdbc65!ePbWz6OU%^| zvPhg78FhF^_V&Bs3e(=L}skVSUGz?k#G5_EAS(faCgk#EZEUbGS~C1 z>yVY$@%rqGTB4}jdo)>BOyDp~2Ay!#y0^@;~}4lvM2T@SJ#Kzq-O5q&Dz1fAb%L z-s$dmgRY{HhmKW-Z!gHKG?7Bna}}X_3DNw;C+H5u?F4b!e2A!U1dH=reNFvgmq@u?7C-jafE~QG*p_5a z$Rr#kiMW}pTC6GzZgiY#jAqA?s%Cryh%aNOLmwU~jd95)Yo73n zu4JzSNwU)7?Q z5#_Q4X|Q7Cu_uV{k3IBnEwU;ndO;UzeT43VU{@+v@Rc_p3hoP-AL_)w&A?p#GMe|8 z`YWhza2b!UoC2Qjyn~dkcfuk{nl%EjQGxRTAwt+5hhCj1B*llqsiz{tNcOti2T*JU zfS}x0;hX`{#+a)=aN@CJ+o1d7mNGp}G54U}2xuvL;O#pU%C_>A>6FZIdH5j+ zl^4_CFPC~!fn1-5vmnd&g)kKUJ)zSauwcUv$+@KFqFIQ#?X!q z7#;A9f`B3zY--nT9rt2iZ;5iGRYcMOmuT2vwOkoCQM37a6}5YRem(7i0RbAqi0im! zx7I;b!v64nFSv&qOi{$wiP1`9r`^TzbR&0*uZ4Wto|Np@+=2-TNZ>wqNSa>5z@n<_ zO+eqk1$$R~z^Zs&n7G=fj$#+r@chHaOLQJf!qvOf#P&_(3qt;t(U(~oQ+m`b@OO6m zPf7WF@}}Drl5kaS;qOE0ep+qxWY`S(5EELdS=N2+=5u3^se{y;C6zO@5E<4T6`XH!~Op`xPND zJ9HE5;E#e6O`KCN)D5P7$Njk&AQj)zhh%v|gl5Mf8V0`|ML&IW3DOJ^`o zkGC$7ZL?8@3KdBe*#e{#Y4xddjX0B3IjlLF7>=|qfTPh?VFry0@qt|Hr`Kd6)?Akl zoIBK6s9hsvFp*fE`jGN_;Pa`)qiO_TBOwVHhQOLn3DqQRao&#$csqcjhKaHo_~rEm zQ3G8?dAvH=ql5#h--K6DZ2gpQ^g=@4C%=1FtK;U!JBQmRJ|(uTKsER19?~7CSCU-I znpJmn$h#uN$6(D|b@b{Q*i*~P!&)x^?^<^|Ik)rscB>!rZQNQ8UdDk1P74jHt8{8I z)0p#WU5qembm3TGrKc2R6KTsi3DFtaAEHZfvU6x>#~$1(ISL1#3A zcGxEZw{fp1KV)RQXHHt$kh8r5l^E24{dH*j5+88cI6OscusE_XcE8Ybr8<^bs%$1O;!L_%6;m?v&BZQg$D(zVxkXsu|!cdpaYKE(z_ zjD-gENtiWap;#%)eYEM+(e9K$o_>Y1?%}KG^#t302XnILNOr16>#L&v*vm4|gOkm^ zS~uemTn}wX+0l#!zA-`J@qQQTubD;JHS&8D4%#iT}<(4JPuI7y_Vu?tt>=nByA`2CoDiD=Xw{HOq{cE znfxDjC{d=-rj5ovKmwfc@`~MZ!xVktv zJdRZ@_Pqd*n2Z|m|0a8}{4a^KENuTz+}c05$~u$@=^tEm)LNWU8ga=Wm2U|S?AYMw zNFgv~Sr?KQiGlp?#xXH;bx zXfZ_m0`1N?{_knIU@!o#{0aG6wc|7(dF)>&iAqEqBi`ovNLJO~2mQ<7H-dC78QfjD z30Umgb9zcJ=M z>*MaR?J{9KoZtagz$ojdlF=9OG|BU9^r0YPGTqOgg$YEF2ZxY}*`Pv6!tjH9G=sgv zqoa%^JYGjpgPjjW1%n3{i%HpwjVNF>RIL1kgT1|4Grhf|+&%dylbW+q%W6!GjchB* zOe{>bYL1ig^y6|0ld3oJbYoIe@^m21&S=5+$*iifH0W%$EHW}Ml@E^-6BCapF42#7 z(esyVZfN7IvMgx9D$%OZ<0`6Xn|JpzXdfsps^~-p3n5C=uWjJPw6a6^VkkH?7PSAVfAA)`SL%uh&c(h`rGvvmFo|?yj6nD znZ1=w*~jGvr9nYMQ(;p_Q%7Nki^!(|!Qr(~-B&oY8*2x7iF^i&e0N7pM~mIM!wMla z3X~{f$fVv|mxgPfzoZ%^_!%Nx@mz5n%nThS0q?BzTEg|CyFM%rG)!B9Is1f`X`ti1=(?J++x-aewoJ z`T9A6T1sS-UFX zgz)-4WPf4|3H|VpTT~Jg9bHQyZkXKWQ20p9^-o^I=VFO)-Qx|}AKmVlGG#OXz(JIekiqIEivx@AQ{qlH*;H9AD6NjB zMR_=LtYGQQs7!!xEL2gTItK<_dygF<3(}tNe%}E}KQ!Ck{93Q{wdFNBytf)6ECk=z zjzh<=c+>g-ET3CC4PH}m`ZLvQjh|EEu>1jD+;JS6?rpFH&is9j{9~@4#xc==HUeB( z|2pG~?<}?>L^udm7Z!huj~UY3X9t4EPQ?+2hG%)>7&De%mA+c7H?QEZm<$HVNtqMz z@v#$7*{Ix{j&t>9vd7>I2Ca_TJ7-0f{=NWD=bb+{F|8*>H*g=aCOge3qc0~ho4wqO zBW8dihJdTKi;D~JUFlO;m6y7j$sEkz_<6{ft?WGfnR)2==r0m7&JsHtyV7$(0vnhw z0?S2Y#pdQ>_dhv{#l-KE>zei{S&n11M|Gw>Q|mH4Z7!Cbc0u5dz$8%ijl&7|k%s}p zXyJmUH2csJM5Yk?)WdSa3o+U;Ycbq0Z7~*D_t>ylGt3w)7|gjAoxPrkb)j`BwQ&1+h=C;PRX11ob78gbr05Dc}W)Z9o zY#%Jfcw;7~m{vJ9^P%61%)`uum6LT7!~VCklMx7YoOR#K3@)23gQ>Uhs3?^7*<4Jg zu@P;Ei0@O6=K)18%3lY?$u$blkA?z|LuGmS2-HrXFW9#Zs z&N^XLSy{X~!ol$i2rfaoz}e-DiRij1~;c-#6xsAS4@E$^95N9912E3f)U-1*#!g zJip*_?7~@lPxfqb4{@1xm3Dz~jgV0C%YFEZvF;TGp+GzK#Ht@Lr^rLi0%*EWQIa2l zL|e7B9p;|yd}j!~*2<|uw`?seUJCE*0`3jQA4Aa$bMBS+(F!n#ZOp6;X6dLy5+pqV zyN3ms0H2kRN>E~qsOGce5U9waV1$I``z~y4qh*Sesa%AlBk7cc_hNS?DYlZvL_S#Y zBJz2{(i2h=G!iwpk8JHIKK0V%BC^hn3T`cC+gRyVnA5Wts>Bv75!xU$F5nB+Ixs`$ zY>b!_q1eI*D7PbY`HyE8_zgXPLykH5@v-CFowenP)GrsNY_ng+$0H;7c0v!XWOhYH zk2>w7wgyLA3Hp73F18>gv_rpstIKJYW(~|?KVW2|MHeUu(>UG@zSd0Y(JE@tHlffT zAn%b-k;(4Xo+|P38?$B5?vEAG1|_^Y8%Kzo3FYnf_I-sUoBxi!PKl1859Z5}O1Dxv z$p@43uBe`Ea5^Gy_=(Ov>wj@tZ_YLrl=~JKcH}q6eK&MSU;(byIpbJSPS(pbPHTl1*VpCR56vv+NS!>h1~8bZjM5Wh+O$CUfKi z)Z5OK16y&kp`{vozYXq$4hf=S&V>ozKv8NzZ=>m=3`@#b!O!onik*AH?l^(NMW}L> zJyfq>*k)_7cGDOokjXduZjgJ1lDK%PNQlgu&7@8p--;)}HY5>wO^gIvBq%f{-ZRgB zN;b*C^Qx~nsZv+Gf_;m*0~k&nmsOH)lXOiuZofHzY!S#_^{h!Kc- z>E6Dq$*kB;Xb!wQAy!zeFfQkc6|0yUDAPEHxd7-V1Gm=Z`K-c`MUy}~-~c>f3>t_E zwK&n0hlB;xdMN|V3loIn3YZbngIMF@Mnt?F@cNhdcK?bkD!)K09Eb;J9sNgOa_Yz$ zUnk@TSbh>MnHb5`-s0>EK|$e~|CQZp(KB;-j;bE#zwJ!P?;3r)6{?YS<8TeQYUm5( zjrKwE8oqy{VdjKHCn&<5&C3bwOX!Q^y>_Pbyu})*BE5G0{MrvMv{KF>Ej?AE8pwqVM&FkA2yGAfVQH}G7cEbwoSiOp;R+Tz<-kmPyFj^Fu+$bSv77F z^6?~NEHHkup(avcF)Q~6QVykn9^|K87HG~Vb9RFb&L1o0W20qPi$+%inK8dUj=vNG zU+VVPFsYaZWlusP3C~7J&Kj27Ck{l%pkG|q|-=#O&6!X%F9b^zyvuK#O8C^cg{!(Y{ zY^^jafMhgn6_`?A8x7Rct*p|}Z6pFiw**jUM6)LqrPP*Q?pYEY(fbgBD>11>=k~;D zee+sJBu2dp72oYWFE~+uU^6^(y6G(7*SS}EKTw3^+%PX&QChpOD0bw~we%kDY3b0V zu?nf_0{a!J?Mqg$XD6^xtY$IAGa?6uoP6}}aqUp4AHOg>2mdoSg0{43^sSZzp8Q-H2WzXq?N zz<<9tnv!Cn;&Pe9nD35r%Lh#=r1Rycl#)KJ^`W3^-bD2!*30h zJJdvq|2IaDY$_d;L2S-1-r;TSF=ggsdY8XqPCEOP&!jv%^h~z%zouIaO_9bIl+?4{ zHYe%5ozE?7+Eo+B4v?z;JP9;3`zR|E*V}EjbSe!`kZx=Pr)bKswrAziUC-%`QzKjX zRaWIK&rd)O$AxD`)w?vhR2L!Hvv3^Li3S?gXUVaqzyDY6!@~RRB;!4Kt!;aDX=&jV zckIDv30DtMiB)ff+w9*0eWq(DP)hTPwgrqm9y5>2DjX$3!(>UP%oInKgW&@-R*$rB zB*y+=Ubxy>JVPTr>@(YUM)BS$!E02gFl~Nw4x-x8C*~vv@;P~*W{+g+gx<7UK@}9_ zw>OiAvCmY-<5lsa9NV$1<^z0M$5>NFh=KQ;t~U(6g5 zTA_mzhW$I7d{KT67`TCme@IJryDw^_q99xWVad*`7LUVYeSVHZHcTRD{FZ1s&esHNBz|&uKc*9yoeEETSe%=84hwj$W zglwWocGcQtsc~1MXbAj&NwTNo;*-sc{OU~O%$&Lp<{#EUGDOo~n3E+!K%H7sNfl=) zh-M=UTySV^ONo)NEXR!2w=;2X7U^`s*1uYqm*4OmGe8ywlUkp6=w&4$HB6`$>8JA0 z1kp-@qa19juepCEC6?P=pcZ}KOnzI-C8xsKsHEgj%D#we9Rmr(Q5bx@D!-Y`)A~ba z3n<{nob86Cdk%e1iJD)iAO~)=DjyrJnC&O1g7*|3#=81ZCA^A_T$_VkysB%05j z(sTGI`$bo^x{R!Sm}(8l3)4MtWr_$VcT!e`U8CV1u^(ZfR>}DJS{cATAm#bpmEgAE ztW;4D%hPI_S%+;JM&uDz|osv;4jz1zF|p35tthZ<8I4|G4ti#o#pgH*nJSx*47g`ID%>P z+%4w{-PN^K8xfGQOrI3=Glwz5NxixQ@+w&afCvm!=hm`qZ&5*>i+Uc zAw=8)vXtxrry^8NQT;v{CFyp+X^=WWtG9rDVR@XN5-Q0yHTw#G>gdW@U2u`Fv?2AS zJt{Nimzw0r2>FZez*|iy59k{x|M%hvm1bU{Y8nVa@pPQBFYk36ymHHNt-Y+?F}Gcb z%>)FDUAqYFDir?eAV4CMCkJ!no;#A%?9X_U9gGxMUA+)7P`;3PQ!ZVs;wL{Egiu@A zU3OgU&V`nlH#jvLY8YOJ3ZJh(#O#;Ley0GT8nZUKruOtTAM5Q|L~TLKJA6B%c8u4qrc zAN(aq&NxK-4<=1@cO0lfea)+hfFho8T-%|)MuZU}W#sp~?P0Q#bMsT@&1I-;ARgud z|JHX&adX1|G{psNkf=%uR2!LX4tjTbTTsJVyS*fO}Nr@p)7(BO^wG6 zH5uj)4>Wp!Jt*ZoGe1l8;^)^-(0-rtz_|7FI*;r$5_s2Cc<0ZaIknHHYalkFcu7BJ zbL=*zQQa*5PERaXUZ8eG_aML-WH_%|V25-aa^FTSjC%0KyLX9443f8>eo5>eTcUl0 zp#!8MKirSw&AC^3H>Dwc1!wtm)b<#ZBeLhn zuUy=>&$kci?Y8=j`VgOt_kJ~9>F#+G(g~|Yg^^|i86)PFt1NRTL{OuS^5w@3>1oC{ zIY#FV${(NGR1|PIlJZT7?^xUZ&g6ub!R>QO&$9LBaD&*W<^sS9E}3oVEAH^u@jH=# z2w@pKLN$Mmh8@P%3ai<*`{&RD%UtWT(wP?q&#r;%bLn_F)2I}?RFm~39=7HMcgZ+0 z85iKEcUuZr6AotVTV12aUo$q0Sjn0EH9>HE1d>8x0ovSu$zh*dAE9UQ z)LfQ!4kETL^e3_vne83x?SUr^c8AJHxiX4!TU198Re!++DwI~11Rzmk+d}&tYW2?b z5M4yjkbBQ09UZQUVy{uGf=S%1&nxL*G5koHOEdAXCszK@m4GeZirs&g=iGnJyW^=-+ z8Q2B67*V{LJ~?Cy3$jNWbXXdVarPh=z$YO-sm_|6vvML)Kpy|_KIIL8kG#rUd^vq! zk;>;gZhMaVml^Uzppi#l3^ZSno3^-c-oQuiPSU?i1Qt9b6)y;^2FX`1qroPn^t+Be z5%jMtsW%Zumi{6-2F=T*h@UAKaom2ODzwF0QMso6@Vuq43MHWx!eE4n1E)T~A}fB* zVT&LbJtOOhAV4#{x*7a|tMM>KA2Bf#G-2mR_89z)cv2y(u&m+~NkU65K;-N|b`S!E z>R;Y9uA&BiDCQ(=rej~gL{rb|5&8jA-D&6r&a98y8djW3u|vzj3>Z}#3;pKo|FbyE zl)Y2;z$I6_kdCJl5q%j^=$Kzp8p#zQ!v%bRz`njrZC!P@tlqh`%Eyka5m58^FxvJf zQqWExFEtdp9R3xxyR8p+$ezp6tCG;&Q6^gckg3Osnt*@mpT}UE+O%~2T^@^I6QN)@ zr?TX{GfA#@@HR^a!*N+i2}3G=dj>j6^29!j;QKfH2&an*4dm+PwSIB2P4`Bulzxb+ zvSCTrx&p#yRtt+nVB>04zB;0{b&zbvse9%t@LY9v5jA29{(EveOk!3wJ5P{?`%(LY zDnn@{5Z%Jb#_3r5fo5en)UT3kE4Dg1gHUlsUB=H^HbOnFsp;#SnCQaY3QqHlrTBY$IM|}ECSxg(Enr??|UTj`+Qvo1Xk4=>?LQG$_Vdz+C zZbe4(u)aS2Dm)>1LyBmrg_DUCm4`&>1 zgje+>BdIyYgypZmT%gZ={sfX(URG9+KfGDWic@j>p$&(*%+YC9MO{{H??}Mg*7FUO z3z$U7;n1s&`MK7m3w+ybR&u5c4I7cP_fsW`oEYHh<#KoN&S+8i^zWgFFK^RHWx;I; zxDM06RAWb5No`5b?y_k@LCe<|f8FeC;@+k1Igk*1PQVP7L*tFvB9P#9fvF(3s+qP}nwr!r+=80{b*tTtB^X{#^d*8k9qVC82FjX@(Q!_RFbkB7Ey8CI+ zOWW!Y#JURkC(;Eet6BZw~iQoR^*FL%Oiwa~OUFnL;y0nez>bX$%~c zR0=pw|I$#SQ5-;ZKDh6o+0@A66ol1l(VHm0>ZX#y+S5()m(l@kAUA)0=2zND3TN@2 zjgC|J0RsWq(eDW~-Ild3)9jUdb`Rv8I*bWYb0qD-@CbXKFit&ggGTHtY+SP;C65;S zEfc6d2GiSsgyt)#jf+nG0#}Y1uB!%Z{v&nWSw(y3HcUl$Q*v<$1_H|MLe+Lz7eE@@c-3^;9Yd4CPbCxlT$Unns6uFg`0% zvlHh*59AI02$~CzRUny8CjZdATAN-|iB0kmZ%t1Yf6H$fp1;_LuAE_Kix1YMgVZ+e zP#pV8TM(KC+g_^GLC^x2?iqQ7$a0*R2rMNk}Yv>}lBWrvx8q6cLESPJ>E!o97rlZn6`~8=ge)f72}}N{s1x(cE~wzv)*16s1VKW%67f7 zAtVhFd*WVOq;G*C4HsU)jtdHQXOdq_&;v|(%HcDB5jnM=8zinD=s za!=qf=`P2j_Tb-CYzh$Dis%TL(9!PV;0yfZ?nG8|ZhQ>vJT|T#)ju05pZh&$6jx$l z#1kq-PQS!(beM>(;0Q6{jF~(WhtDBzb`TpoTReR8sc&D{TEC)68S#)SH0s9Ki*H zTndV#VbYw+!jBg?L}szXBW3V?_aKqj6ngL`M>P!Om?7^xbKu+&uC;;DCD4O)DqV054-gp zm|Sr+zkcUv>n*C45_aU(jqIA0p9N8r#<3Sxy|@5^-#dWA`S`kpXb)_@KS|6cxMd5T zo#7XZsY@6p%fOPAxMETX^vPw@nOEY>QG?w#nBx*N^iCYvm@J?|%nUo`ulA2nJTl$TZS)% zI}2eW$X1fEz+;6=51<-Q-jLQsFUxcYpW|$jWY$og*JnER*u7D z4=3*=>vO$E6k+n5>Q$w^n! z&*n40Y3#qu2yUXI+Bqq-m&s}(yT zb69|v^T2abd&@!J^H#8+*5=lX(;usp@virYfX&x9~}8zTH$dw z#w~nzh^ik?rI3*@v5)325}PZB9F;BLPbp%s zJP{X{o-Ua)=$fuHVm*UPVVB|}K$d33yRfW-Tc`?OlhFXOXa+K2JuJWIFH~!O#r*i-?r`!0g;m0oFxRO&P5=+~6mtqLKxdk$V8dg; zmQrSqdQh%f__*}{t+%-buFS{ktQni>i*mbMR7)maAwE?)e<(V~`0oCk;sLFTC=SZ;r*q5_OLTDt4$ZkqaRq^@j!8&72)mQ_7^hseSwBH1GP$ zDG&68v5a;@`>44MlZH|ZBIWe2;k-$~jIN1FOvJygqYOCa&L@1lcYW_>s0tStq~6tS z*En(f7}#bCv{KWRK~x?ORjku{9l+>QQ)U!CT@?IOqWt4D>R)A&fr8mj9$VsJTYvPq zDTlWhr)<%;{h3%{Gmq`os_bBoJ)iWP*BQm-D_PA|y#iuyp?w_W-6&tJ%kdq#Fz(0{ zw)|0*@ETp3a@bwRK<-CZwb-GHLI?%b5oscq8G9`*g(~{ZTqo!ang0m+v{kr9yK$b6 zZq}e1-lpssP=-%_P;Hwyq^3V=l@JP6$r*FhYir}+Xd7@n<%Rdok-B~M$WBU~3Nr0N z6FV@$zcVG*U~Y-Y8EQc8G~SYw8$S!cBH})|0YZ=dlDJ|zlSVCE7PGsa#0R{wsmHTxEhF%%5-_it=6q9qxwd3~Kw)u1 z^70VuYkp2f^$+C}wg%k+7v9m8gBY&ayv8U51~lGZ3oW#*^6<i`MUO|sXC#}V~9)HM*$b{IJl2PN;yUM zWy|5@NBz<~jmG74H~mrn0qevBV*H+GzB~7mS2-PxtaR#7bxSd+X!x^p<+S7NU4Gq^Ka)!AzQQifgc(P zjb~)=pzB@tUtaZBd;0St${pkPN;V)DCbOCooMdT+t`g;x<0fTPbDcm1j;V5URMx=O zwukGtQM4C#i2~IaAJ>dvS4R%xsuP)D<8)`yjYE#(qP6uBc#U
  • _riR`y*s2S zHAsms)603p`EK-roYGsyXmwrhyKHFMENJ6GZfb`l8^_{&ZXw8=|%;4m-b_BUdk(_ zo8*=>x(#8&SuhKEmQOdc&ITM+iM8$42|clLUp)=iRvmIJYdJJRZ`b4mq27MQzxK)m%pcvd zz&sg`KU4;a6{hlo1rR2M=UQOkR=h;%;)CSjdq3s(3hf|h;s;g#1eT5CypRIxFYR+` z&!eHIH*&p%h)rK<7gDaHHFq;i>6O(j=f>E~HjdrR{(*dJLmnP%-k#msz?&ho20_yd z)iIx5CHJZ&9bq(P6XGJd&Lw0@bL4r&yVBABSAz>!=>KOG;Qw=78zb{SG4cObJV>64o;~^AJ3SC|;v#5K zd<6tCx;9AqS~>=Yqy;A|^zY&;baeJ3G$mByV$&pm8L=e=x`sx^82}vvU5$e6uo%^t zl2J>%qZ+M|kU?$BXcZO9ltjK|0Cz z5=7ZxnXqvgIh4(dI|-CecxxFHyyzJ};OKolU^Zc%5OnK3X+EDTw*fub@0XE@o`I1O z)X|%dW$#n?9mW^qyzWuk*FC}A(;qxjAy3rC%8~QSI2(O0chnJTx$ajDs!lz^Gu>%X*$xI)nAMqXsVxzuvMt^9fgcc@>dZoFga% z6x0e%XQ!EZe$Mi7Sn{Ujwr*WRZ}=mAJ0))2kp-J*JG;(124C!`#7&aR$6;|Zo7Ylz zd!pk38bULnaISs<7k87Ao2%p9=(aNHd6_MEnPgS@ywzp{leI22beQ9&m{?rG%PC2z zgIWTCOguv28ZUfTyZ+cMoKW(77pX*UMAyZ2YGgzWBRQ!}AqBC$cR@N6p(YF|R6>D- z{3HRru3M@cK2(TAe84eNbyA&IJ%LM_Kpep~aZpU5kW1B5_BV4O9s=JvNq!hQLrNGK zA|!dbfgn6|SnvR0U$~kS6^T|@V-Rg!`ZZY-JpTZT0cTy{vhX?SBYdP4L_#e|6Qbe% zuUV@-gE?X~^5L=gkg zBfAS6&WBbHC=s4~hFr3Ci{^`mJU@UKD7qPvbCpJmp^=D{nCFRwD;MG5hQ62{XZv=x zi=dP)Bg2D(@qwZE$9(SWag9`z6p;7Zh3ba78cq|r6Xmbr6PYq>@f)By&aQW`&gmHJ zOC1}snswo~Vo(6OzI;=$5(wxY1!xWvA-8tlJE(UlJ}q?5AB&CRTUX@tXWPWqGOQyC ziH;;Xy03&l9=nqpp)g*ZCqoe_v@)4*KX~$Nt2n#g2c-$RW;TMQhaQWov*(AHirr$A zzmh$3LEBs@hLeM(7HG_k6ofh?s`E_QFCyXHH|Zj~b@zH2S$xO@LTJUI;?H!@hs> zp~9Pt*K|A4l}5&SCT6ko#H6ARTfkQH8>oMqA?YnF}d-D@28bb7NV$}z&xTQftRn+NI=Bs!0@XFk--X9t>47v(LJ;45@e78j{Ios>k28B2 zJ~Af<(z&mqB_Tlskn`XRE!EL2(1~Ew{VeN;drAVZIwT{rmN7PmRSIkpSPRlQ%*dL4 zO*gTQQBj7Cw9KtnSYz^ZO#(}*;=Nh%1amm%;NWs@Q10Q5h9OM*AvwUOCF^GRbNVdc z>8JQZtMvsn^+jM^Tz^v*=7PE(uDj~)sEFcooW&mIGT)n5mV>`LUI_K;%vj(?oh`66 z*VZ%Zqt+@71yduPDzIrrS}uKj#nsG6Z9kbP2A_|xMJk$v%v$;1izvfK0Vx3+83j$Pz@KJQ z)IeBj5Eq;ZnsKR#B*Ey*E2#?F4#&%RYRi&uThPL?`DD16FJb;j!dEs|o2IL9wEPgr z{3$x>nz`Uaf0P>MS!Usq2yNY#hXQ_qX>!~jR%;MVyXvI}95{1jQcoq3lF#{H_K5xI zb3MmFE&mJtDqR)L{2jba#p6`2*4^ZCo`tQxX!C1M_q`Dlz97CjFcKK zUfHZ-Y-C95CGgUxT|mAI=H?GR5`-rz;`l4ttL2Kjx$O#uqEwEf$F6DdYudu}1>=Ht z5g)AWqzvSn-j1onF`LWWy82B%h z!G4FhO6u`k<}K)(1YHFCH`=h`TgYQ3S-%riA!GsWHV+$zdV5`nz&oEMTi!yyV$13R z4fdMWig{qLSl!HY+b`gn@Kkyo%;(YVxhZB-#}ElXTUEs9RF*RlQb{2JDSV@ zpO$Iv^_N3AM?9FGvdWmWOF?)TQT$&`BzQ?UY)PZveBZyn96flo-fvQVREf6czooR} zF)qBzmChrlbm_o2Xso7eSr7z$+(@qvLi{TGUeaiG@9hl}->~Z|L2{)4K zI&E7?{$SclsBkvAq8r0R&6RC^;FWz47?Gl+5aWthOYUJU6tvp5LA@oY=B*Ze6qyn0 zU3mvv2#3*@5yTuh9!Ub(l)}e8mVIkd0yoZJa5g3{^_vV$phBh1tIsV=nGsM|kCgYs z9{Zi~1}DP@JsrEr;~NDlu6x$%`{dS>S4 z)dhM+dU|EsX}>j+zW+}p+rQNk;xm4$0q^evejbsT7N;mtm@OM6B_XSwoTa9wo{=1) zo*keSt(l(!l1x*K06&XROHh-GiUBPLN6CO^lEY#OzV&MGyv#dCXbDM$NMx@&MTN*) zze$5Xz#MTo{^9ZQ!Y88OTTg=yuG9>kBeHN$`DL;qLWc^LmU zSU5hy!a&{5{TmkFopDBAmv4=S|KDJdyrGMM=VSbd>%jMo#coH(HxwO%gOn;%IvoNr zHBLKlN9J=TUQ^m5kDT_H|BOXN3ymXf`pCaw0WDzo{-5I+CRVop8P6!W+Zof!8dxYg zS<}kkGtkk|ikLe%I^ol^G0=bSS~(dz(27{;I~fZZ8`>Hf(@GiJm^zu^GqSKV|HtU2 zQ)?{-yBWdzN%dZn>SqRtx^f442#{pVuA~*932`Oj-&t^Tga) ze0~{nKkKk|RIyUA`OvAkQ#SE8TM@Ykw%IK)l4M2zTq2we)ZmU766B;Qul=--wV@Rt z(T<-}Y6kjnH_c#B4Er?goT2N8e3-%gQL&eOip%}zM@l0C5@y^kq#`@eB8aAvje;HM zcgp_0zMr*h51H4T_NUkkua{6IjYw(S%Ifk4n)lA|5^B zjDb%K;um3rXn_nU+RtF_Bq$|(;9P&Ap4vYAG3XzGd<mGlZqqL z3D8C;W@EzYV8K99aWq71*(2a62s6_pEldbTdd@b4x9X|kV9$F2iZD$9!+JMqF}w+t zb9X}WN`Z9p0m2}B1+B7PFQ&dnPf3b^T2stXA zQV2bFW6E7gxz1W-f*L})w0VZnUXnajKiWt>T6;SMe^sz|@qxaD3S#|Epu#P5<7{*n;AWyz?R{Fa??kA{&Qq2I{K13Sk z{C*GyraU{Pe61YKb}al|YiZ}U`>~uZDw7iJv(wBm8oYdlE78i&<0AfmN{~)IA^m9) zyRm%n$ZaX%Tp$8H$)KujX)``Wpit1H9i>bOZLmtU`c-J`6kt#K(itw5Jz>pLrb6*H)!D+F-h8tm6Id!(+^GzJPy?6cJY*(z(T^C~Iuua43Q=d4iB&NgJD4ic43a-! z;#E`{!c1dv;L`@$DT@iEX&QJx{h7SqZ&sS$&i*c`%04ZXBT^hRo5p_LS@=F)zqk5m zUFdGk@0O8W>UMSXKAn-_^K<&V?kB?e*>Qei66qLn;gBk1JueJ0X6-*jI&8+CSmPg{ z3e5rqDgGX(v)~-^@uEZ@1kupS6}M?1dNBOjT-=yJg(1*u#u)P%l)DBCfFZhGV}c3| zx9PRFi(bA!7Xc)ND z=->yM0|0}A5d0z==N}s@zZB(2|$sFhP4lIV`Qvss6j^-!xa%D1K`i2gstrsq+{GlcrgLOxT5$<0CE|?GZ2wx zCL#5xwsLXnbO8wK;UWkM=r9u`pz<7`+(L=GBut(Y);7$VraHSJGAeE4XBnwch3R8- z0=SM*^-^jd`F&&shsKnQNzN00MOLO5qI$>xah@wvA`^dAOaR|k!$L*i2?H*XK|NNQ zwMx~}^C~G-=m7w8bbZd2K*xRvV=AUt0N|r9?;f7|C1{$e)54|JCd)k>i$ndSxY8o~ zQ|V7Md?Ha4JTTVyaRcy#AufMvzAmExzU49U_gkj?V*L;zafw(W0J7zJYy7jCq>JZ8{HMvV zTOB`1+MXh`ZP)#*Kb?@5g9W;PadmT@XE0%rN%-b+WB;g3etUF%DpN5@q%5OT_Q3Ds zK}1>08|7?{^$%U>t}f$zIxpg<^vvDnvpy)0}?=c`0_gNpVvTXLXU}cSG+T zK}iTf*p(}+0hs-c#^>G@4jF508D!><4PB`+IUASsQY<;9%34eoi^9e>MjG zRLF|duej(8)ynbhCFUA*a}3;A;7Y^^E-k)doCaJ=Xy0GH~_>{1S#HNF8B!+MW%@Hupp3 zt|QVG-S#OoC`XkHv@ZVmWJcgBas~&m68)gw%$X}0)`Zq07#4>RHFly(OAIV_K{I6j zK60r0Ff`k+W<(h^Rl+&|pdaGpC+I3_BM;UeavqIv(n=q862oR8`4EICErdHd0nEsI zBB)iLKRh4{G4_?2q5ll3kx7j+iG;{6nQ!9@jEPUF{39hi3Md-=2c$_bQ1$;%Nx(E- zSDsPQwADBL(Ne6HT-+XAKxQtVZ;M}4C?r5L-T(a`DhycwF$i%<*bl*lo*{~Se-`&? zNsGeqZL1fsosTTvD)iqW{Zs93%xPYK7YK1aWFrqjjimBroFzd&@O>9I>TH-GrYQI= zU7*Wu^!giU0#8cDxXM8+WH(IV>m6j!*G`x{6D&_g#(_q+$N+|@TAX$4K7hcrVV=7X z|5lAdci%y??hIz$3T=J6=EP$9KOj9xb+1bF=d(fAuRWf=9i8&Q=o#vY9)+1uo-o`S zH)Oa*v5uX2bcExAN)ZwPQbLvTKvKovqvTOVNYR;CH zjyD_ksxPm0SC{+4tB5Yug9xM)v3>izcq8Qcn0t% z?O?o{t#f=dG`c=6J`G>j4Y5vLNUBct1MQO^Kwlf?x8<14#7YyFIa`_CEnYEqvIZOG z9bde+`pubTOMe}6gt)UGTZf!q%OO1!$T_`5g{MrS3d!X+Z<4fDPq0Wk6t^s#X-z}x z=tryPn`vCS`mU?Hh!l4iQSQrc$-#T}N7|Q#UmmabQ@Z*P@HwO}bYipd)6-m9E#%e;*83m+R_0umAX95voL zXM@6@)%Q~@`Am6+X&D4vgdgoiT6K4^o0X)WOZb=vk$euVyGSRoq%;bYkr@2wIOQT z0`m0=>WulC!&}zgXZMO^_O#^rMW);<>}|JTTlf;*^x!>_(z=*qJK5f-z?;+ZT2sM3 z&Ir_&f&NSD#2QkJcGby;UA_esfLr}B((wyKz0 z3VgV_t~#+hKGRx%3{ffZI%Q_Su9LqBAQe21Twqc9ZpP#kiN>!+38*M`UY9R?Pw_2) z=%&V8_p^nf0VaycjI?Nd&U9RCJ9^e_M?Jkr+j3Xl&RPTJfPnWNOfC$V?7TS1c~KKx zk16rk5f-b;Ys`ZgT9_)_I+Q#EUslcZetOMeeHHe6U)hT^W#!dfYLZRzj(Fs{kT8fMX9bn^DO95*P6tG z>tVjGn0i8+^6lc64mZuw;a#W#mKaTsnR(QXrPbXQc-cKEq0Q-Dmc2Z0|NTMhyM*R6 zh1J$v39s70vd~*bcf2n!3X;cx_Abd5bk~tayon0H; zj&=Hwwzf@w%{TfCx7u;QsTR$+{d@%fO!m7{R6JaLW~@*DX4-lA`sZa;af& zsv!~#U2Fo#8`8{QQ!?+z&KnchAX_jZ)0C<|{fi>#2s-r+Fnn?$2J8rI0mc}?&)F!T zBn5fQu}b%@Az;kj?blUk-E6~}?hPZI>o?UD@D~`5okyEQs-{?avC*>1R@WRZlZqq( zU%bae?F?ttnHVVeO#lV(iE}>FW=ZC_$5X+{@Fm-Gj8(TJtqfZGKKt6`Bc4RKjSWxI zUpDINwwb#lHuY)-xuK`k6T(fSo(``;eWsCo=Xx{SlrwYHpK<>oi36rkwxc?a}9Vo^F`OJDJT3WkM>yWSP2CVGoqzM4^lVC8dy!S3J6{ zd86I-k2YIrBH|Z8Q6->KL#&s#HK}YbAJ@u0-BI4wd{m3(!h!uk_mIL)3RHB2;a9eu zjcMoTz2qmYh`!n|5!T%_9NX=5?e@++EjF$v$-MmVA`4PM^RX7i{2zf z%!Pv+$&#p{U>SHA&kOt#xcHp4(&i?8QM8xSdsl1Ba`HkryRn4Ik z4X_1B<4?MGCLH-&_pETAvpuJoAg*J40yV?Q$@p9CB!>-HX`w-(j6}$2=mh-|MxPPe zKR3CP107c=M3yz^UY!Q$sz*$-MfRt*W(An5PQwi^UJfJLj@`?yjWZpKA$Zn8(rZf9 zx+Ojo_q0NH9z6d-SJ~+Pm*p2V1!EIh1zX$iRhREG3bf)jCbszhpy2x671HElXJlqE zV4^cIFflY>WM*b#FlJ^lG+|<3V=!W&r)M+Z`M+PGO{-|`VGPC0Mo+7%NsrHn&!GK( zumyT%`hQ~fVqS8UQc=Yoy1C2rtnu6a0SX?WQQ1=Esf@h7sBBMbx2K}j0~@_WB$%qH8Wt6)-+sYGPkM>_jaGWdcT{PIO^)?c44U{}BMI6R`kcdOLuskQ{=n|=9I(6%);xF;4*#YMH%R;(LO!|>) zz6l~;ujvN`w<2*+Cq#0iVj-$0B!y{$nDryW{OA#3-Z@HX-;a2@M+znT7%`kjOr;m$ z__lNB(oj~R(>fA4*)ieM2G%^Cl<=SiV>w@ERP&x!kxAbH+$8Oe=pTMJ!6dH2nK$<@A=Hg|)&ZQ8|h0B1>#o^7RA%PtFg;wP(fK2m+ zRuu&NC7*;=zljJEAPIBiPJvzTgjW?$f#514opOUfcn8Cr3YmWB7)3heGyU{wAj)Gb zqQ5@EiKj^-?P*UY)FzLgo$Q4~cJrOjA<7QVN4w(hwxG58(Dk8d{B_s4E&&peZ zLp~8b0nU2mE95Q0ax#&O2THn}249PSDZKZa^rU16Lxjz;?at{<+MHIsIKmJJ_wPE0 z@Dd3R?&4K30uWJ|`7&44OXQcZ{i z*xMdpBSa!c+JULtIwc+>W-GYJq)TT2mFeibQUoaOjLV>Ly}Fzw4EfW+dY2LFa#z*kl7}WNR4T+9a%<<=Z}Xf-iMA@jRCV2Q3@T( zq4t$Ms}jf8qfdgoosSn$`QN#vk8nvKW|}@;j+amc-i>ul0gpMb)m)4>#U;QTRdohN z0xEVWJY7*07yDq30rf%kzih0oOrQSX6VWfh@7@2|6JAQ34#Bx`aZaSW6e#pmIl8!OTOL^@5{6l#Rh|LY(&Imb5W!(h#~#bT0hJ=9$4gj9RO@ z&Ag@jQbFvIxE@(??SZB&A>c1Y-(fzr|BTtun3rt&1RAatn!3=fP+t<6)WaD^FwDA* z@|3)%;C2x1;Dw|k+=89j>v^pfW83SAOgnsF1!_4o?#(0G6@S+u + + + +GCL TK Manual: Argument Lists + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: General   [Contents]

    +
    +
    + +

    1.5 Argument Lists

    + + +

    1.5.1 Widget Functions

    + +

    The rule is that the first argument for a widget function is a keyword, +called the option. The pattern of the remaining arguments depends +completely +on the option argument. Thus +

    +
    +
    (.hello option ?arg1? ?arg2? ...)
+
    + +

    One option which is permitted for every widget function is +:configure. The argument pattern following it is the same +keyword/value pair list which is used in widget creation. For a +button widget, the other valid options are :deactivate, +:flash, and :invoke. To find these, since +.hello was constructed with the button constructor, you +should see See button. +The argument pattern for other options depends completely on the option +and the widget function. +For example if .scrollbar is a scroll bar window, then the option +:set must be followed by 4 numeric arguments, which indicate how +the scrollbar should be displayed, see See scrollbar. +

    +
    +
    (.scrollbar :set a1 a2 a3 a4)
+
    + +

    If on the other hand .scale is a scale (see scale), then we have +

    +
    +
    (.scale :set a1 )
+
    +

    only one numeric argument should be supplied, in order to position the +scale. +

    + +

    1.5.2 Widget Constructor Argument Lists

    + +

    These are +

    +
    +
    (widget-constructor pathname :keyword1 value1 :keyword2 value2 ...)
+
    + +

    to create the widget whose name is pathname. The possible keywords +allowed are specified in the corresponding section of See Widgets. +

    + +

    1.5.3 Concatenation Using ‘:’ in Argument List

    + +

    What has been said so far about arguments is not quite true. A +special string concatenation construction is allowed in argument lists +for widgets, widget constructors and control functions. +

    +

    First we introduce the function tk-conc which takes an arbitrary +number of arguments, which may be symbols, strings or numbers, and +concatenates these into a string. The print names of symbols are +converted to lower case, and package names are ignored. +

    +
    +
    (tk-conc "a" 1 :b 'cd "e") ==> "a1bcde"
+
    + +

    One could use tk-conc to construct arguments for widget +functions. But even though tk-conc has been made quite +efficient, it still would involve the creation of a string. The +: construct avoids this. In a call to a widget function, +a widget constructor, or a control function you may remove the call to +tk-conc and place : in between each of its arguments. +Those functions are able to understand this and treat the extra +arguments as if they were glued together in one string, but without +the extra cost of actually forming that string. +

    +
    +
    (tk-conc a b c .. w) <==> a : b : c : ... w
+(setq i 10)
+(.hello :configure :text i : " pies")
+(.hello :configure :text (tk-conc i  " pies"))
+(.hello :configure :text (format nil "~a pies" i))
+
    + +

    The last three examples would all result in the text string being +"10 pies", but the first method is the most efficient. +That call will be made with no string or cons creation. The +GC Monitor example, is written in such a way that there is no +creation of cons or string types during normal operation. +This is particularly useful in that case, since one is trying to +monitor usage of conses by other programs, not its own usage. +

    +
    +
    +

    +Next: , Previous: , Up: General   [Contents]

    +
    + + + + + diff --git a/info/gcl-tk/Common-Features-of-Widgets.html b/info/gcl-tk/Common-Features-of-Widgets.html new file mode 100644 index 0000000..15e5464 --- /dev/null +++ b/info/gcl-tk/Common-Features-of-Widgets.html @@ -0,0 +1,163 @@ + + + + +GCL TK Manual: Common Features of Widgets + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: General   [Contents]

    +
    +
    + +

    1.3 Common Features of Widgets

    + +

    A widget is a lisp symbol which has a function binding. The +first argument is always a keyword and is called the option. +The argument pattern for the remaining arguments depends on the +option. The most common option is :configure in +which case the remaining arguments are alternating keyword/value +pairs, with the same keywords being permitted as at the creation +of the widget. +

    +

    A widget is created by means of a widget constructor, of +which there are currently 15, each of them appearing as the title of a +section in Widgets. They live in the "TK" package, and for +the moment we will assume we have switched to this package. Thus for +example button is such a widget constructor function. Of course +this is lisp, and you can make your own widget constructors, but when +you do so it is a good idea to follow the standard argument patterns +that are outlined in this section. +

    +
    +
    (button '.hello)
+==> .HELLO
+
    +

    creates a widget whose name is .hello. There is a parent child +hierarchy among widgets which is implicit in the name used for the +widget. This is much like the pathname structure on a Unix or Dos +file system, except that '.' is used as the separator rather +than a / or \. For this reason the widget instances +are sometimes referred to as pathnames. A child of the +parent widget .hello might be called .hello.joe, and +a child of this last might be .hello.joe.bar. The parent of +everyone is called . . Multiple top level windows are created +using the toplevel command (see toplevel). +

    +

    The widget constructor functions take keyword and value pairs, which +allow you to specify attributes at the time of creation: +

    +
    +
    (button '.hello :text "Hello World" :width 20)
+==>.HELLO
+
    +

    indicating that we want the text in the button window to be +Hello World and the width of the window to be 20 characters +wide. Other types of windows allow specification in centimeters +2c, or in inches (2i) or in millimeters 2m +or in pixels 2. But text windows usually have their +dimensions specified as multiples of a character width and height. +This latter concept is called a grid. +

    +

    Once the window has been created, if you want to change the +text you do NOT do: +

    +
    (button '.hello :text "Bye World" :width 20)
+
    +

    This would be in error, because the window .hello already exists. +You would either have to first call +

    +
    +
    (destroy '.hello)
+
    + +

    But usually you just want to change an attribute. .hello is +actually a function, as we mentioned earlier, and it is this function +that you use: +

    +
    +
    (.hello :configure :text "Bye World")
+
    + +

    This would simply change the text, and not change where the window had +been placed on the screen (if it had), or how it had been packed +into the window hierarchy. Here the argument :configure is +called an option, and it specifies which types of keywords can +follow it. For example +

    +
    +
    (.hello :flash)
+
    +

    is also valid, but in this case the :text keyword is not permitted +after flash. If it were, then it would mean something else besides +what it means in the above. For example one might have defined +

    +
    +
    (.hello :flash :text "PUSH ME")
+
    +

    so here the same keyword :text would mean something else, eg +to flash a subliminal message on the screen. +

    +

    We often refer to calls to the widget functions +as messages. One reason for this is that they actually turn into +messages to the graphics process gcltksrv. To actually see these +messages you can do +

    +
    (debugging t).
+
    + +
    +
    +

    +Next: , Previous: , Up: General   [Contents]

    +
    + + + + + diff --git a/info/gcl-tk/Control.html b/info/gcl-tk/Control.html new file mode 100644 index 0000000..741991e --- /dev/null +++ b/info/gcl-tk/Control.html @@ -0,0 +1,117 @@ + + + + +GCL TK Manual: Control + + + + + + + + + + + + + + + + + + + +
    +

    +Previous: , Up: Top   [Contents]

    +
    +
    + +

    3 Control

    + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    • after:   +
    • bind:   +
    • destroy:   +
    • tk-dialog:   +
    • exit:   +
    • focus:   +
    • grab:   +
    • tk-listbox-single-select:   +
    • lower:   +
    • tk-menu-bar:   +
    • option:   +
    • options:   +
    • pack-old:   +
    • pack:   +
    • place:   +
    • raise:   +
    • selection:   +
    • send:   +
    • tk:   +
    • tkerror:   +
    • tkvars:   +
    • tkwait:   +
    • update:   +
    • winfo:   +
    • wm:   +
    + + + + + + diff --git a/info/gcl-tk/General.html b/info/gcl-tk/General.html new file mode 100644 index 0000000..5a0d8b8 --- /dev/null +++ b/info/gcl-tk/General.html @@ -0,0 +1,83 @@ + + + + +GCL TK Manual: General + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Top   [Contents]

    +
    +
    + +

    1 General

    + + + + + + + + + + +
    • Introduction:   +
    • Getting Started:   +
    • Common Features of Widgets:   +
    • Return Values:   +
    • Argument Lists:   +
    • Lisp Functions Invoked from Graphics:   +
    • Linked Variables:   +
    • tkconnect:   +
    + + + + + + diff --git a/info/gcl-tk/Getting-Started.html b/info/gcl-tk/Getting-Started.html new file mode 100644 index 0000000..2af4377 --- /dev/null +++ b/info/gcl-tk/Getting-Started.html @@ -0,0 +1,96 @@ + + + + +GCL TK Manual: Getting Started + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: General   [Contents]

    +
    +
    + +

    1.2 Getting Started

    + +

    Once GCL has been properly installed you should be able to do the +following simple example: +

    +
    +
    (in-package "TK")
+(tkconnect)
+(button '.hello :text "Hello World" :command '(print "hi"))
+==>.HELLO
+(pack '.hello)
+
    +

    We first switched to the "TK" package, so that functions like button +and pack would be found. +After doing the tkconnect, a window should appear on your screen, see See tkconnect. +The invocation of the function button creates a new function +called .hello which is a widget function. It is then +made visible in the window by using the pack function. +

    +

    You may now click on the little window, and you should see the command +executed in your lisp. Thus "hi" should be printed in the lisp +window. This will happen whether or not you have a job running in +the lisp, that is lisp will be interrupted and your command will run, +and then return the control to your program. +

    +

    The function button is called a widget constructor, and the +function .hello is called a widget. If you have managed to +accomplish the above, then GCL is probably installed correctly, and you +can graduate to the next section! If you dont like reading but prefer +to look at demos and code, then you should look in the demos directory, +where you will find a number of examples. A monitor for the garbage +collector (mkgcmonitor), a demonstration of canvas widgets (mkitems), +a sample listbox with scrolling (mklistbox). +

    + + + + + diff --git a/info/gcl-tk/Introduction.html b/info/gcl-tk/Introduction.html new file mode 100644 index 0000000..fe33cf8 --- /dev/null +++ b/info/gcl-tk/Introduction.html @@ -0,0 +1,91 @@ + + + + +GCL TK Manual: Introduction + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: General   [Contents]

    +
    +
    + +

    1.1 Introduction

    + +

    GCL-TK is a windowing interface for GNU Common Lisp. It provides the +functionality of the TK widget set, which in turn implements a widget +set which has the look and feel of Motif. +

    +

    The interface allows the user to draw graphics, get input from menus, +make regions mouse sensitive, and bind lisp commands to regions. It +communicates over a socket with a gcltksrv process, which speaks to the +display via the TK library. The displaying process may run on +a machine which is closer to the display, and so involves less +communication. It also may remain active even though the lisp is +involved in a separate user computation. The display server can, however, +interrupt the lisp at will, to inquire about variables and run +commands. +

    +

    The user may also interface with existing TCL/TK programs, +binding some buttons, or tracking some objects. +

    +

    The size of the program is moderate. In its current form it adds only +about 45K bytes to the lisp image, and the gcltksrv program uses shared +libraries, and is on the order of 150Kbytes on a sparc. +

    +

    This chapter describes some of the common features of the command +structure of widgets, and of control functions. The actual functions +for construction of windows +are discussed in Widgets, and more general functions +for making them appear, lowering them, querying about them in Control. +

    + + + + + diff --git a/info/gcl-tk/Linked-Variables.html b/info/gcl-tk/Linked-Variables.html new file mode 100644 index 0000000..55aced5 --- /dev/null +++ b/info/gcl-tk/Linked-Variables.html @@ -0,0 +1,161 @@ + + + + +GCL TK Manual: Linked Variables + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: General   [Contents]

    +
    +
    + +

    1.7 Linked Variables

    + +

    It is possible to link lisp variables to TK variables. In general +when the TK variable is changed, by for instance clicking on a +radiobutton, the linked lisp variable will be changed. Conversely +changing the lisp variable will be noticed by the TK graphics side, if +one does the assignment in lisp using setk instead of +setq. +

    +
    +
    (button '.hello :textvariable '*message* :text "hi there")
+(pack '.hello)
+
    + +

    This causes linking of the global variable *message* in lisp +to a corresponding variable in TK. Moreover the message that is in +the button .hello will be whatever the value of this global +variable is (so long as the TK side is notified of the change!). +

    +

    Thus if one does +

    +
    +
    (setk *message* "good bye")
+
    + +

    then the button will change to have good bye as its text. +The lisp macro setk expands into +

    +
    +
    (prog1 (setf *message* "good bye") (notice-text-variables))
+
    + +

    which does the assignment, and then goes thru the linked variables +checking for those that have changed, and updating the TK side should +there be any. Thus if you have a more complex program which might +have done the assignment of your global variable, you may include +the call to notice-text-variables at the end, to assure that +the graphics side knows about the changes. +

    +

    A variable which is linked using the keyword :textvariable is +always a variable containing a string. +

    +

    However it is possible to have other types of variables. +

    +
    +
    (checkbutton '.checkbutton1 :text "A button" :variable '(boolean *joe*))
+(checkbutton '.checkbutton2 :text "A button" :variable '*joe*)
+(checkbutton '.checkbutton3 :text "Debugging" :variable '(t *debug*)
+              :onvalue 100 :offvalue -1)
+
    + +

    The first two examples are the same in that the default variable type +for a checkbutton is boolean. Notice that the specification of a +variable type is by (type variable). The types which are +permissible are those which have coercion-fucntions, See Return Values. In the first example a variable *joe* will be linked, and +its default initial value will be set to nil, since the default initial +state of the check button is off, and the default off value is nil. +Actually on the TK side, the corresponding boolean values are "1" +and "0", but the boolean type makes these become t +and nil. +

    +

    In the third example the variable *debug* may have any lisp value (here +type is t). The initial value will be made to be -1, +since the checkbutton is off. Clicking on .checkbutton3 will +result in the value of *debug* being changed to 100, and the light +in the button will be toggled to on, See checkbutton. You may +set the variable to be another value besides 100. +

    +

    You may also call +

    +
    +
    (link-text-variable '*joe* 'boolean)
+
    + +

    to cause the linking of a variable named *joe*. This is done +automatically +whenever the variable is specified after one of the keys +

    +
    +
    :variable   :textvariable.
+
    + +

    Just as one must be cautious about using global variables in lisp, one +must be cautious in making such linked variables. In particular note +that the TK side, uses variables for various purposes. If you make a +checkbutton with pathname .a.b.c then unless you specify a +:variable option, the variable c will become associated to +the TK value of the checkbutton. We do NOT link this variable by +default, feeling that one might inadvertently alter global variables, +and that they would not typically use the lisp convention of being of +the form *c*. You must specify the :variable option, or +call link-variable. +

    + +
    +
    +

    +Next: , Previous: , Up: General   [Contents]

    +
    + + + + + diff --git a/info/gcl-tk/Lisp-Functions-Invoked-from-Graphics.html b/info/gcl-tk/Lisp-Functions-Invoked-from-Graphics.html new file mode 100644 index 0000000..938f770 --- /dev/null +++ b/info/gcl-tk/Lisp-Functions-Invoked-from-Graphics.html @@ -0,0 +1,212 @@ + + + + +GCL TK Manual: Lisp Functions Invoked from Graphics + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: General   [Contents]

    +
    +
    + +

    1.6 Lisp Functions Invoked from Graphics

    + + +

    It is possible to make certain areas of a window mouse sensitive, +or to run commands on reception of certain events such as keystrokes, +while the focus is in a certain window. This is done by having +a lisp function invoked or some lisp form evaluated. We shall +refer to such a lisp function or form as a command. +

    +

    For example +

    +
    +
    (button '.button :text "Hello" :command '(print "hi"))
+(button '.jim :text "Call Jim" :command 'call-jim)
+
    + +

    In the first case when the window .button is clicked on, the +word "hi" will be printed in the lisp to standard output. In the +second case call-jim will be funcalled with no arguments. +

    +

    A command must be one of the following three types. What happens +depends on which type it is: +

    +
    +
    ‘function’
    +

    If the value satisfies functionp then it will be called with +a number of arguments which is dependent on the way it was bound, +to graphics. +

    +
    ‘string’
    +

    If the command is a string, then it is passed directly to TCL/TK +for evaluation on that side. Lisp will not be required for the +evaluation when the command is invoked. +

    +
    ‘lisp form’
    +

    Any other lisp object is regarded as a lisp form to be eval’d, and +this will be done when the command is invoked. +

    +
    + +

    The following keywords accept as their value a command: +

    +
    +
       :command
+   :yscroll    :yscrollcommand
+   :xscroll    :xscrollcommand
+   :scrollcommand
+   :bind
+
    + +

    and in addition bind takes a command as its third argument, +see See bind. +

    +

    Below we give three different examples using the 3 possibilities for +a command: functionp, string, and lisp form. They all accomplish +exactly the same thing. +For given a frame .frame we could construct a listbox +in it as: +

    +
    +
    (listbox '.frame.listbox :yscroll 'joe)
+
    + +

    Then whenever the listbox view position changes, or text is inserted, +so that something changes, the function joe will be invoked with 4 +arguments giving the totalsize of the text, maximum number of units +the window can display, the index of the top unit, and finally the +index of the bottom unit. What these arguments are is specific +to the widget listbox and is documented See listbox. +

    +

    joe might be used to do anything, but a common usage is to have +joe alter the position of some other window, such as a scroll +bar window. Indeed if .scrollbar is a scrollbar then +the function +

    +
    +
    (defun joe (a b c d)
+  (.scrollbar :set a b c d))
+
    + +

    would look after sizing the scrollbar appropriately for the percentage +of the window visible, and positioning it. +

    +

    A second method of accomplishing this identical, using a string (the +second type of command), +

    + +
    +
    (listbox '.frame.listbox :yscroll ".scrollbar set")
+
    + +

    and this will not involve a call back to lisp. It uses the fact that +the TK graphics side understands the window name .scrollbar and +that it takes the option set. Note that it does not get +the : before the keyword in this case. +

    +

    In the case of a command which is a lisp form but is not installed +via bind or :bind, then the form will be installed as +

    +
    +
    #'(lambda (&rest *arglist*) lisp-form)
+
    + +

    where the lisp-form might wish to access the elements of the special +variable *arglist*. Most often this list will be empty, but for +example if the command was setup for .scale which is a scale, +then the command will be supplied one argument which is the new numeric +value which is the scale position. A third way of accomplishing the +scrollbar setting using a lisp form is: +

    +
    +
    (listbox '.frame.listbox :yscroll '(apply '.scrollbar :set *arglist*))
+
    + +

    The bind command and :bind keyword, have an additional +wrinkle, see See bind. These are associated to an event in a +particular window, and the lisp function or form to be evaled must have +access to that information. For example the x y position, the window +name, the key pressed, etc. This is done via percent symbols which +are specified, see See bind. +

    +
    +
    (bind "Entry" "<Control-KeyPress>" '(emacs-move  %W %A ))
+
    + +

    will cause the function emacs-move to be be invoked whenever a control +key is pressed (unless there are more key specific or window specific +bindings of said key). It will be invoked with two arguments, the +first %W indicating the window in which it was invoked, and the second +being a string which is the ascii keysym which was pressed at the same +time as the control key. +

    +

    These percent constructs are only permitted in commands which are +invoked via bind or :bind. The lisp form which is passed +as the command, is searched for the percent constructs, and then a +function +

    +
    +
    #'(lambda (%W %A) (emacs-move %W %A))
+
    + +

    will be invoked with two arguments, which will be supplied by the +TK graphics server, at the time the command is invoked. The +*arglist* construct is not available for these commands. +

    +
    +
    +

    +Next: , Previous: , Up: General   [Contents]

    +
    + + + + + diff --git a/info/gcl-tk/Return-Values.html b/info/gcl-tk/Return-Values.html new file mode 100644 index 0000000..3d5fe1b --- /dev/null +++ b/info/gcl-tk/Return-Values.html @@ -0,0 +1,181 @@ + + + + +GCL TK Manual: Return Values + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: General   [Contents]

    +
    +
    + +

    1.4 Return Values

    + + +

    1.4.1 Widget Constructor Return Values

    + +

    On successful completion, the widget constructor functions return the +symbol passed in as the first argument. It will now have a functional +binding. It is an error to pass in a symbol which already corresponds +to a widget, without first calling the destroy command. On failure, +an error is signalled. +

    + +

    1.4.2 Widget Return Values

    + +

    The widget functions themselves, do not normally return any value. +Indeed the lisp process does not wait for them to return, but merely +dispatches the commands, such as to change the text in themselves. +Sometimes however you either wish to wait, in order to synchronize, or +you wish to see if your command fails or succeeds. You request values +by passing the keyword :return and a value indicating the type. +

    +
    +
    (.hello :configure :text "Bye World" :return 'string)
+==> "" 
+==> T
+
    +

    the empty string is returned as first value, and the second value +T indicates that the new text value was successfully set. LISP +will not continue until the tkclsrv process indicates back that the +function call has succeeded. While waiting of course LISP will continue +to process other graphics events which arrive, since otherwise a +deadlock would arise: the user for instance might click on a mouse, just after +we had decided to wait for a return value from the .hello function. +More generally a user program may be running in GCL and be interrupted +to receive and act on communications from the gcltksrv +process. If an error occurred then the second return value of the +lisp function will be NIL. In this case the first value, the string +is usually an informative message about the type of error. +

    +

    A special variable tk::*break-on-errors* which if not +nil, requests that that LISP signal an error when a message +is received indicating a function failed. Whenever a command fails, +whether a return value was requested or not, gcltksrv returns a +message indicating failure. The default is to not go into the +debugger. When debugging your windows it may be convenient however to +set this variable to T to track down incorrect messages. +

    +

    The gcltksrv process always returns strings as values. +If :return type is specified, then conversion to type +is accomplished by calling +

    +
    +
    (coerce-result return-string type)
+
    + +

    Here type must be a symbol with a coercion-functions +property. +The builtin return types which may be requested are: +

    +
    +
    T
    +

    in which case +the string passed back from the gcltksrv process, will be read by the +lisp reader. +

    +
    number
    +

    the string is converted to a number using the current *read-base* +

    +
    list-strings
    +
    +
    +
    (coerce-result "a b {c d} e" 'list-strings)
+==> ("a" "b" "c d" "e")
+
    +
    +
    boolean
    +

    (coerce-result "1" ’boolean) +==> T +(coerce-result "0" ’boolean) +==> NIL +

    +
    + +

    The above symbols are in the TK or LISP package. +It would be possible to add new types just as the :return t +is done: +

    +
    +
    (setf (get 't 'coercion-functions)
+      (cons #'(lambda (x) (our-read-from-string x 0))
+	    #'(lambda (x) (format nil "~s" x))))
+
    + +

    The coercion-functions property of a symbol, is a cons whose +car is the coercion form from a string to some possibly different +lisp object, and whose cdr is a function which builds a string +to send to the graphics server. Often the two functions are inverse +functions one of the other up to equal. +

    + +

    1.4.3 Control Function Return Values

    + +

    The control funcions (see Control) do not return a value +or wait unless requested to do so, using the :return keyword. +The types and method of specification are the same as for the +Widget Functions in the previous section. +

    +
    +
    (winfo :width '.hello :return 'number)
+==> 120
+
    +

    indicates that the .hello button is actually 120 pixels +wide. +

    +
    +
    +

    +Next: , Previous: , Up: General   [Contents]

    +
    + + + + + diff --git a/info/gcl-tk/Widgets.html b/info/gcl-tk/Widgets.html new file mode 100644 index 0000000..3f2efa7 --- /dev/null +++ b/info/gcl-tk/Widgets.html @@ -0,0 +1,97 @@ + + + + +GCL TK Manual: Widgets + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Top   [Contents]

    +
    +
    + +

    2 Widgets

    + + + + + + + + + + + + + + + + + +
    • button:   +
    • listbox:   +
    • scale:   +
    • canvas:   +
    • menu:   +
    • scrollbar:   +
    • checkbutton:   +
    • menubutton:   +
    • text:   +
    • entry:   +
    • message:   +
    • frame:   +
    • label:   +
    • radiobutton:   +
    • toplevel:   +
    + + + + + + diff --git a/info/gcl-tk/after.html b/info/gcl-tk/after.html new file mode 100644 index 0000000..aabc59f --- /dev/null +++ b/info/gcl-tk/after.html @@ -0,0 +1,97 @@ + + + + +GCL TK Manual: after + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    +
    + +

    3.1 after

    + +

    after - Execute a command after a time delay +

    +

    Synopsis

    +

    after ms ?arg1 arg2 arg3 ...? +

    + +

    Description

    + +

    This command is used to delay execution of the program or to execute +a command in background after a delay. The ms argument gives +a time in milliseconds. +If ms is the only argument to after +then the command sleeps for ms milliseconds and returns. +While the command is sleeping the application does not respond to +X events and other events. +

    +

    If additional arguments are +present after ms, then a Tcl command is formed by concatenating +all the additional arguments in the same fashion as the concat +command. After returns immediately but arranges for the command +to be executed ms milliseconds later in background. +The command will be executed at global level (outside the context +of any Tcl procedure). +If an error occurs while executing the delayed command then the +tkerror mechanism is used to report the error. +

    +

    The after command always returns an empty string. +

    +

    See tkerror. +

    + +

    Keywords

    +

    delay, sleep, time +

    + + + + diff --git a/info/gcl-tk/bind.html b/info/gcl-tk/bind.html new file mode 100644 index 0000000..7dedd09 --- /dev/null +++ b/info/gcl-tk/bind.html @@ -0,0 +1,490 @@ + + + + +GCL TK Manual: bind + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    +
    + +

    3.2 bind

    + +

    bind \- Arrange for X events to invoke Tcl commands +

    +

    Synopsis

    +

    bind windowSpec
    +
    bind windowSpec sequence
    +
    bind windowSpec sequence command
    +bind windowSpec sequence +command +

    + +

    Description

    + +

    If all three arguments are specified, bind will +arrange for command (a Tcl +command) to be executed whenever the sequence of events given +by sequence occurs in the window(s) identified by windowSpec. +If command is prefixed with a “+”, then it is appended to +any existing binding for sequence; otherwise command replaces +the existing binding, if any. If command +is an empty string then the current binding for sequence +is destroyed, leaving sequence unbound. In all of the cases +where a command argument is provided, bind returns +an empty string. +

    +

    If sequence is specified without a command, then the +command currently bound to sequence is returned, or +an empty string if there is no binding for sequence. If +neither sequence nor command is specified, then the +return value is a list whose elements are all the sequences +for which there exist bindings for windowSpec. +

    +

    The windowSpec argument selects which window(s) the binding +applies to. +It may have one of three forms. +If windowSpec is the path name for a window, then the binding +applies to that particular window. +If windowSpec is the name of a class of widgets, then the +binding applies to all widgets in that class. +Lastly, windowSpec may have the value all, in which case +the binding applies to all windows in the application. +

    +

    The sequence argument specifies a sequence of one or more +event patterns, with optional white space between the patterns. Each +event pattern may +take either of two forms. In the simplest case it is a single +printing ASCII character, such as a or [. The character +may not be a space character or the character <. This form of +pattern matches a KeyPress event for the particular +character. The second form of pattern is longer but more general. +It has the following syntax: +

    +
    +
    <modifier-modifier-type-detail>
+
    + +

    The entire event pattern is surrounded by angle brackets. +Inside the angle brackets are zero or more modifiers, an event +type, and an extra piece of information (detail) identifying +a particular button or keysym. Any of the fields may be omitted, +as long as at least one of type and detail is present. +The fields must be separated by white space or dashes. +

    + +

    Modifiers may consist of any of the values in the following list: +

    +
    +
    Control                  Any                            
+Shift                    Double                         
+Lock                     Triple                         
+Button1, B1              Mod1, M1, Meta, M              
+Button2, B2              Mod2, M2, Alt                  
+Button3, B3              Mod3, M3                       
+Button4, B4              Mod4, M4                       
+Button5, B5              Mod5, M5                       
+
    + +

    Where more than one value is listed, separated by commas, the values +are equivalent. All of the modifiers except Any, +Double, and Triple have +the obvious X meanings. For example, Button1 requires that +button 1 be depressed when the event occurs. Under normal conditions +the button and modifier state at the time of the event must +match exactly those specified in the bind command. If +no modifiers are specified, then events will match only if no modifiers +are present. If the Any modifier is specified, then additional +modifiers may be present besides those specified explicitly. For +example, if button 1 is pressed while the shift and control keys +are down, the specifier <Any-Control-Button-1> will match +the event, but the specifier <Control-Button-1> will not. +

    + +

    The Double and Triple modifiers are a convenience +for specifying double mouse clicks and other repeated +events. They cause a particular event pattern to be +repeated 2 or 3 times, and also place a time and space requirement +on the sequence: for a sequence of events to match a Double +or Triple pattern, all of the events must occur close together +in time and without substantial mouse motion in between. +For example, <Double-Button-1> +is equivalent to <Button-1><Button-1> with the extra +time and space requirement. +

    + +

    The type field may be any of the standard X event types, with a +few extra abbreviations. Below is a list of all the valid types; +where two name appear together, they are synonyms. +

    +
    +
    ButtonPress, Button      Expose             Leave              
+ButtonRelease            FocusIn            Map                
+Circulate                FocusOut           Property           
+CirculateRequest         Gravity            Reparent           
+Colormap                 Keymap             ResizeRequest      
+Configure                KeyPress, Key      Unmap              
+ConfigureRequest         KeyRelease         Visibility         
+Destroy                  MapRequest         
+Enter                    Motion             
+
    + + + +

    The last part of a long event specification is detail. In the +case of a ButtonPress or ButtonRelease event, it is the +number of a button (1-5). If a button number is given, then only an +event on that particular button will match; if no button number is +given, then an event on any button will match. Note: giving a +specific button number is different than specifying a button modifier; +in the first case, it refers to a button being pressed or released, +while in the second it refers to some other button that is already +depressed when the matching event occurs. If a button +number is given then type may be omitted: if will default +to ButtonPress. For example, the specifier <1> +is equivalent to <ButtonPress-1>. +

    + +

    If the event type is KeyPress or KeyRelease, then +detail may be specified in the form of an X keysym. Keysyms +are textual specifications for particular keys on the keyboard; +they include all the alphanumeric ASCII characters (e.g. “a” is +the keysym for the ASCII character “a”), plus descriptions for +non-alphanumeric characters (“comma” is the keysym for the comma +character), plus descriptions for all the non-ASCII keys on the +keyboard (“Shift_L” is the keysm for the left shift key, and +“F1” is the keysym for the F1 function key, if it exists). The +complete list of keysyms is not presented here; it should be +available in other X documentation. If necessary, you can use the +%K notation described below to print out the keysym name for +an arbitrary key. If a keysym detail is given, then the +type field may be omitted; it will default to KeyPress. +For example, <Control-comma> is equivalent to +<Control-KeyPress-comma>. If a keysym detail is specified +then the Shift modifier need not be specified and will be +ignored if specified: each keysym already implies a particular +state for the shift key. +

    + +

    The command argument to bind is a Tcl command string, +which will be executed whenever the given event sequence occurs. +Command will be executed in the same interpreter that the +bind command was executed in. If command contains +any % characters, then the command string will not be +executed directly. Instead, a new command string will be +generated by replacing each %, and the character following +it, with information from the current event. The replacement +depends on the character following the %, as defined in the +list below. Unless otherwise indicated, the +replacement string is the decimal value of the given field from +the current event. +Some of the substitutions are only valid for +certain types of events; if they are used for other types of events +the value substituted is undefined. +

    +
    +
    %%
    +

    Replaced with a single percent. +

    +
    |%#|
    +

    The number of the last client request processed by the server +(the serial field from the event). Valid for all event +types. +

    +
    |%a|
    +

    The above field from the event. +Valid only for ConfigureNotify events. +

    +
    |%b|
    +

    The number of the button that was pressed or released. Valid only +for ButtonPress and ButtonRelease events. +

    +
    |%c|
    +

    The count field from the event. Valid only for Expose, +GraphicsExpose, and MappingNotify events. +

    +
    |%d|
    +

    The detail field from the event. The |%d| is replaced by +a string identifying the detail. For EnterNotify, +LeaveNotify, FocusIn, and FocusOut events, +the string will be one of the following: +

    +
    +
    NotifyAncestor            NotifyNonlinearVirtual          
+NotifyDetailNone          NotifyPointer                   
+NotifyInferior            NotifyPointerRoot               
+NotifyNonlinear           NotifyVirtual                   
+
    + +

    For ConfigureRequest events, the substituted string will be +one of the following: +

    +
    +
    Above                     Opposite                  
+Below                     TopIf                     
+BottomIf                  
+
    + +

    For events other than these, the substituted string is undefined. +.RE +

    +
    |%f|
    +

    The focus field from the event (0 or 1). Valid only +for EnterNotify and LeaveNotify events. +

    +
    |%h|
    +

    The height field from the event. Valid only for Configure, +ConfigureNotify, Expose, GraphicsExpose, and +ResizeRequest events. +

    +
    |%k|
    +

    The keycode field from the event. Valid only for KeyPress +and KeyRelease events. +

    +
    |%m|
    +

    The mode field from the event. The substituted string is one of +NotifyNormal, NotifyGrab, NotifyUngrab, or +NotifyWhileGrabbed. Valid only for EnterWindow, +FocusIn, FocusOut, and LeaveWindow events. +

    +
    |%o|
    +

    The override_redirect field from the event. Valid only for +CreateNotify, MapNotify, ReparentNotify, +and ConfigureNotify events. +

    +
    |%p|
    +

    The place field from the event, substituted as one of the +strings PlaceOnTop or PlaceOnBottom. Valid only +for CirculateNotify and CirculateRequest events. +

    +
    |%s|
    +

    The state field from the event. For ButtonPress, +ButtonRelease, EnterNotify, KeyPress, KeyRelease, +LeaveNotify, and MotionNotify events, +a decimal string +is substituted. For VisibilityNotify, one of the strings +VisibilityUnobscured, VisibilityPartiallyObscured, +and VisibilityFullyObscured is substituted. +

    +
    |%t|
    +

    The time field from the event. Valid only for events that +contain a time field. +

    +
    |%v|
    +

    The value_mask field from the event. Valid only for +ConfigureRequest events. +

    +
    |%w|
    +

    The width field from the event. Valid only for +Configure, ConfigureRequest, Expose, +GraphicsExpose, and ResizeRequest events. +

    +
    |%x|
    +

    The x field from the event. Valid only for events containing +an x field. +

    +
    |%y|
    +

    The y field from the event. Valid only for events containing +a y field. +

    +
    %A
    +

    Substitutes the ASCII character corresponding to the event, or +the empty string if the event doesn’t correspond to an ASCII character +(e.g. the shift key was pressed). XLookupString does all the +work of translating from the event to an ASCII character. +Valid only for KeyPress and KeyRelease events. +

    +
    %B
    +

    The border_width field from the event. Valid only for +ConfigureNotify and CreateWindow events. +

    +
    %D
    +

    The display field from the event. Valid for all event types. +

    +
    %E
    +

    The send_event field from the event. Valid for all event types. +

    +
    %K
    +

    The keysym corresponding to the event, substituted as a textual +string. Valid only for KeyPress and KeyRelease events. +

    +
    %N
    +

    The keysym corresponding to the event, substituted as +a decimal +number. Valid only for KeyPress and KeyRelease events. +

    +
    %R
    +

    The root window identifier from the event. Valid only for +events containing a root field. +

    +
    %S
    +

    The subwindow window identifier from the event. Valid only for +events containing a subwindow field. +

    +
    %T
    +

    The type field from the event. Valid for all event types. +

    +
    %W
    +

    The path name of the window to which the event was reported (the +window field from the event). Valid for all event types. +

    +
    %X
    +

    The x_root field from the event. +If a virtual-root window manager is being used then the substituted +value is the corresponding x-coordinate in the virtual root. +Valid only for +ButtonPress, ButtonRelease, KeyPress, KeyRelease, +and MotionNotify events. +

    +
    %Y
    +

    The y_root field from the event. +If a virtual-root window manager is being used then the substituted +value is the corresponding y-coordinate in the virtual root. +Valid only for +ButtonPress, ButtonRelease, KeyPress, KeyRelease, +and MotionNotify events. +

    +
    + + +

    If the replacement string +for a %-replacement contains characters that are interpreted +specially by the Tcl parser (such as backslashes or square +brackets or spaces) additional backslashes are added +during replacement so that the result after parsing is the original +replacement string. +For example, if command is +

    +
    +
    insert %A
+
    + +

    and the character typed is an open square bracket, then the command +actually executed will be +

    +
    +
    insert \e[
+
    + +

    This will cause the insert to receive the original replacement +string (open square bracket) as its first argument. +If the extra backslash hadn’t been added, Tcl would not have been +able to parse the command correctly. +

    + +

    At most one binding will trigger for any given X event. +If several bindings match the recent events, the most specific binding +is chosen and its command will be executed. +The following tests are applied, in order, to determine which of +several matching sequences is more specific: +(a) a binding whose windowSpec names a particular window is +more specific than a binding for a class, +which is more specific than a binding whose windowSpec is +all; +(b) a longer sequence (in terms of number +of events matched) is more specific than a shorter sequence; +(c) an event pattern that specifies a specific button or key is more specific +than one that doesn’t; (e) an event pattern that requires a particular +modifier is more specific than one that doesn’t require the modifier; +(e) an event pattern specifying the Any modifier is less specific +than one that doesn’t. If the matching sequences contain more than +one event, then tests (c)-(e) are applied in order from the most +recent event to the least recent event in the sequences. If these +tests fail to determine a winner, then the most recently registered +sequence is the winner. +

    + +

    If an X event does not match any of the existing bindings, then the +event is ignored (an unbound event is not considered to be an error). +

    + +

    When a sequence specified in a bind command contains +more than one event pattern, then its command is executed whenever +the recent events (leading up to and including the current event) +match the given sequence. This means, for example, that if button 1 is +clicked repeatedly the sequence <Double-ButtonPress-1> will match +each button press but the first. +If extraneous events that would prevent a match occur in the middle +of an event sequence then the extraneous events are +ignored unless they are KeyPress or ButtonPress events. +For example, <Double-ButtonPress-1> will match a sequence of +presses of button 1, even though there will be ButtonRelease +events (and possibly MotionNotify events) between the +ButtonPress events. +Furthermore, a KeyPress event may be preceded by any number +of other KeyPress events for modifier keys without the +modifier keys preventing a match. +For example, the event sequence aB will match a press of the +a key, a release of the a key, a press of the Shift +key, and a press of the b key: the press of Shift is +ignored because it is a modifier key. +Finally, if several MotionNotify events occur in a row, only +the last one is used for purposes of matching binding sequences. +

    + +

    If an error occurs in executing the command for a binding then the +tkerror mechanism is used to report the error. +The command will be executed at global level (outside the context +of any Tcl procedure). +

    +

    See tkerror. +

    + +

    Keywords

    +

    form, manual +

    +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    + + + + + diff --git a/info/gcl-tk/button.html b/info/gcl-tk/button.html new file mode 100644 index 0000000..a3c7bb6 --- /dev/null +++ b/info/gcl-tk/button.html @@ -0,0 +1,263 @@ + + + + +GCL TK Manual: button + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Widgets   [Contents]

    +
    +
    + +

    2.1 button

    + +

    button \- Create and manipulate button widgets +

    +

    Synopsis

    +

    button pathName ?options? +

    +

    Standard Options

    + + +
    +
    activeBackground  bitmap              font        relief        
+activeForeground  borderWidth         foreground  text          
+anchor            cursor              padX        textVariable  
+background        disabledForeground  padY        
+
    + + +

    See options, for more information. +

    +

    Arguments for Button

    + + +
    +
    :command
    +

    Name="command" Class="Command" +


    + +

    Specifies a Tcl command to associate with the button. This command +is typically invoked when mouse button 1 is released over the button +window. +

    +
    + + +
    +
    :height
    +

    Name="height" Class="Height" +


    + +

    Specifies a desired height for the button. +If a bitmap is being displayed in the button then the value is in +screen units (i.e. any of the forms acceptable to Tk_GetPixels); +for text it is in lines of text. +If this option isn’t specified, the button’s desired height is computed +from the size of the bitmap or text being displayed in it. +

    +
    + + +
    +
    :state
    +

    Name="state" Class="State" +


    + +

    Specifies one of three states for the button: normal, active, +or disabled. In normal state the button is displayed using the +foreground and background options. The active state is +typically used when the pointer is over the button. In active state +the button is displayed using the activeForeground and +activeBackground options. Disabled state means that the button +is insensitive: it doesn’t activate and doesn’t respond to mouse +button presses. In this state the disabledForeground and +background options determine how the button is displayed. +

    +
    + + +
    +
    :width
    +

    Name="width" Class="Width" +


    + +

    Specifies a desired width for the button. +If a bitmap is being displayed in the button then the value is in +screen units (i.e. any of the forms acceptable to Tk_GetPixels); +for text it is in characters. +If this option isn’t specified, the button’s desired width is computed +from the size of the bitmap or text being displayed in it. +

    +
    + + +

    Description

    + +

    The button command creates a new window (given by the +pathName argument) and makes it into a button widget. +Additional +options, described above, may be specified on the command line +or in the option database +to configure aspects of the button such as its colors, font, +text, and initial relief. The button command returns its +pathName argument. At the time this command is invoked, +there must not exist a window named pathName, but +pathName’s parent must exist. +

    +

    A button is a widget +that displays a textual string or bitmap. +It can display itself in either of three different ways, according +to +the state option; +it can be made to appear raised, sunken, or flat; +and it can be made to flash. When a user invokes the +button (by pressing mouse button 1 with the cursor over the +button), then the Tcl command specified in the :command +option is invoked. +

    + +

    A Button Widget’s Arguments

    + +

    The button command creates a new Tcl command whose +name is pathName. This +command may be used to invoke various +operations on the widget. It has the following general form: +

    +
    +
    pathName option ?arg arg ...?
+
    + +

    Option and the args +determine the exact behavior of the command. The following +commands are possible for button widgets: +

    +
    +
    pathName :activate
    +

    Change the button’s state to active and redisplay the button +using its active foreground and background colors instead of normal +colors. +This command is ignored if the button’s state is disabled. +This command is obsolete and will eventually be removed; +use “pathName :configure :state active” instead. +

    +
    pathName :configure ?option? ?value option value ...?
    +

    Query or modify the configuration options of the widget. +If no option is specified, returns a list describing all of +the available options for pathName (see Tk_ConfigureInfo for +information on the format of this list). If option is specified +with no value, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no option is specified). If +one or more option:value pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +Option may have any of the values accepted by the button +command. +

    +
    pathName :deactivate
    +

    Change the button’s state to normal and redisplay the button +using its normal foreground and background colors. +This command is ignored if the button’s state is disabled. +This command is obsolete and will eventually be removed; +use “pathName :configure :state normal” instead. +

    +
    pathName :flash
    +

    Flash the button. This is accomplished by redisplaying the button +several times, alternating between active and normal colors. At +the end of the flash the button is left in the same normal/active +state as when the command was invoked. +This command is ignored if the button’s state is disabled. +

    +
    pathName :invoke
    +

    Invoke the Tcl command associated with the button, if there is one. +The return value is the return value from the Tcl command, or an +empty string if there is no command associated with the button. +This command is ignored if the button’s state is disabled. +

    +
    +
    + +

    "Default Bindings"

    + +

    Tk automatically creates class bindings for buttons that give them +the following default behavior: +

      +
    • [1] +The button activates whenever the mouse passes over it and deactivates +whenever the mouse leaves the button. +
    • [2] +The button’s relief is changed to sunken whenever mouse button 1 is +pressed over the button, and the relief is restored to its original +value when button 1 is later released. +
    • [3] +If mouse button 1 is pressed over the button and later released over +the button, the button is invoked. However, if the mouse is not +over the button when button 1 is released, then no invocation occurs. +
    + +

    If the button’s state is disabled then none of the above +actions occur: the button is completely non-responsive. +

    +

    The behavior of buttons can be changed by defining new bindings for +individual widgets or by redefining the class bindings. +

    + +

    Keywords

    +

    button, widget +

    +
    +

    +Next: , Previous: , Up: Widgets   [Contents]

    +
    + + + + + diff --git a/info/gcl-tk/canvas.html b/info/gcl-tk/canvas.html new file mode 100644 index 0000000..4c1f247 --- /dev/null +++ b/info/gcl-tk/canvas.html @@ -0,0 +1,1570 @@ + + + + +GCL TK Manual: canvas + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Widgets   [Contents]

    +
    +
    + +

    2.4 canvas

    + +

    canvas \- Create and manipulate canvas widgets +

    +

    Synopsis

    +

    canvas pathName ?options? +

    +

    Standard Options

    + + +
    +
    background       insertBorderWidth relief            xScrollCommand 
+borderWidth      insertOffTime     selectBackground  yScrollCommand 
+cursor           insertOnTime      selectBorderWidth 
+insertBackground insertWidth       selectForeground  
+
    + + +

    See options, for more information. +

    +

    Arguments for Canvas

    + + +
    +
    :closeenough
    +

    Name="closeEnough" Class="CloseEnough" +


    + +

    Specifies a floating-point value indicating how close the mouse cursor +must be to an item before it is considered to be “inside” the item. +Defaults to 1.0. +

    +
    + + +
    +
    :confine
    +

    Name="confine" Class="Confine" +


    + +

    Specifies a boolean value that indicates whether or not it should be +allowable to set the canvas’s view outside the region defined by the +scrollRegion argument. +Defaults to true, which means that the view will +be constrained within the scroll region. +

    +
    + + +
    +
    :height
    +

    Name="height" Class="Height" +


    + +

    Specifies a desired window height that the canvas widget should request from +its geometry manager. The value may be specified in any +of the forms described in the COORDINATES section below. +

    +
    + + +
    +
    :scrollincrement
    +

    Name="scrollIncrement" Class="ScrollIncrement" +


    + +

    Specifies a distance used as increment during scrolling: when one of +the arrow buttons on an associated scrollbar is pressed, the picture +will shift by this distance. The distance may be specified in any +of the forms described in the COORDINATES section below. +

    +
    + + +
    +
    :scrollregion
    +

    Name="scrollRegion" Class="ScrollRegion" +


    + +

    Specifies a list with four coordinates describing the left, top, right, and +bottom coordinates of a rectangular region. +This region is used for scrolling purposes and is considered to be +the boundary of the information in the canvas. +Each of the coordinates may be specified +in any of the forms given in the COORDINATES section below. +

    +
    + + +
    +
    :width
    +

    Name="width" Class="width" +


    + +

    Specifies a desired window width that the canvas widget should request from +its geometry manager. The value may be specified in any +of the forms described in the COORDINATES section below. +

    +
    + + +

    Introduction

    + +

    The canvas command creates a new window (given +by the pathName argument) and makes it into a canvas widget. +Additional options, described above, may be specified on the +command line or in the option database +to configure aspects of the canvas such as its colors and 3-D relief. +The canvas command returns its +pathName argument. At the time this command is invoked, +there must not exist a window named pathName, but +pathName’s parent must exist. +

    +

    Canvas widgets implement structured graphics. +A canvas displays any number of items, which may be things like +rectangles, circles, lines, and text. +Items may be manipulated (e.g. moved or re-colored) and commands may +be associated with items in much the same way that the bind +command allows commands to be bound to widgets. For example, +a particular command may be associated with the <Button-1> event +so that the command is invoked whenever button 1 is pressed with +the mouse cursor over an item. +This means that items in a canvas can have behaviors defined by +the Tcl scripts bound to them. +

    + +

    Display List

    + +

    The items in a canvas are ordered for purposes of display, +with the first item in the display list being displayed +first, followed by the next item in the list, and so on. +Items later in the display list obscure those that are +earlier in the display list and are sometimes referred to +as being “on top” of earlier items. +When a new item is created it is placed at the end of the +display list, on top of everything else. +Widget commands may be used to re-arrange the order of the +display list. +

    + +

    Item Ids And Tags

    + +

    Items in a canvas widget may be named in either of two ways: +by id or by tag. +Each item has a unique identifying number which is assigned to +that item when it is created. The id of an item never changes +and id numbers are never re-used within the lifetime of a +canvas widget. +

    +

    Each item may also have any number of tags associated +with it. A tag is just a string of characters, and it may +take any form except that of an integer. +For example, “x123” is OK but “123” isn’t. +The same tag may be associated with many different items. +This is commonly done to group items in various interesting +ways; for example, all selected items might be given the +tag “selected”. +

    +

    The tag all is implicitly associated with every item +in the canvas; it may be used to invoke operations on +all the items in the canvas. +

    +

    The tag current is managed automatically by Tk; +it applies to the current item, which is the +topmost item whose drawn area covers the position of +the mouse cursor. +If the mouse is not in the canvas widget or is not over +an item, then no item has the current tag. +

    +

    When specifying items in canvas widget commands, if the +specifier is an integer then it is assumed to refer to +the single item with that id. +If the specifier is not an integer, then it is assumed to +refer to all of the items in the canvas that have a tag +matching the specifier. +The symbol tagOrId is used below to indicate that +an argument specifies either an id that selects a single +item or a tag that selects zero or more items. +Some widget commands only operate on a single item at a +time; if tagOrId is specified in a way that +names multiple items, then the normal behavior is for +the command to use the first (lowest) of these items in +the display list that is suitable for the command. +Exceptions are noted in the widget command descriptions +below. +

    + +

    Coordinates

    + +

    All coordinates related to canvases are stored as floating-point +numbers. +Coordinates and distances are specified in screen units, +which are floating-point numbers optionally followed +by one of several letters. +If no letter is supplied then the distance is in pixels. +If the letter is m then the distance is in millimeters on +the screen; if it is c then the distance is in centimeters; +i means inches, and p means printers points (1/72 inch). +Larger y-coordinates refer to points lower on the screen; larger +x-coordinates refer to points farther to the right. +

    + +

    Transformations

    + +

    Normally the origin of the canvas coordinate system is at the +upper-left corner of the window containing the canvas. +It is possible to adjust the origin of the canvas +coordinate system relative to the origin of the window using the +xview and yview widget commands; this is typically used +for scrolling. +Canvases do not support scaling or rotation of the canvas coordinate +system relative to the window coordinate system. +

    +

    Indidividual items may be moved or scaled using widget commands +described below, but they may not be rotated. +

    + +

    Indices

    + +

    Text items support the notion of an index for identifying +particular positions within the item. +Indices are used for commands such as inserting text, deleting +a range of characters, and setting the insertion cursor position. +An index may be specified in any of a number of ways, and +different types of items may support different forms for +specifying indices. +Text items support the following forms for an index; if you +define new types of text-like items, it would be advisable to +support as many of these forms as practical. +Note that it is possible to refer to the character just after +the last one in the text item; this is necessary for such +tasks as inserting new text at the end of the item. +

    +
    +
    number
    +

    A decimal number giving the position of the desired character +within the text item. +0 refers to the first character, 1 to the next character, and +so on. +A number less than 0 is treated as if it were zero, and a +number greater than the length of the text item is treated +as if it were equal to the length of the text item. +

    +
    end
    +

    Refers to the character just after the last one in the item +(same as the number of characters in the item). +

    +
    insert
    +

    Refers to the character just before which the insertion cursor +is drawn in this item. +

    +
    sel.first
    +

    Refers to the first selected character in the item. +If the selection isn’t in this item then this form is illegal. +

    +
    sel.last
    +

    Refers to the last selected character in the item. +If the selection isn’t in this item then this form is illegal. +

    +
    @x,y
    +

    Refers to the character at the point given by x and +y, where x and y are specified in the coordinate +system of the canvas. +If x and y lie outside the coordinates covered by the +text item, then they refer to the first or last character in the +line that is closest to the given point. +

    +
    +
    + +

    A Canvas Widget’s Arguments

    + +

    The canvas command creates a new Tcl command whose +name is pathName. This +command may be used to invoke various +operations on the widget. It has the following general form: +

    +
    +
    pathName option ?arg arg ...?
+
    + +

    Option and the args +determine the exact behavior of the command. +The following widget commands are possible for canvas widgets: +

    +
    +
    pathName :addtag tag searchSpec ?arg arg ...?
    +

    For each item that meets the constraints specified by +searchSpec and the args, add +tag to the list of tags associated with the item if it +isn’t already present on that list. +It is possible that no items will satisfy the constraints +given by searchSpec and args, in which case the +command has no effect. +This command returns an empty string as result. +SearchSpec and arg’s may take any of the following +forms: +

    +
    +
    above tagOrId
    +

    Selects the item just after (above) the one given by tagOrId +in the display list. +If tagOrId denotes more than one item, then the last (topmost) +of these items in the display list is used. +

    +
    all
    +

    Selects all the items in the canvas. +

    +
    below tagOrId
    +

    Selects the item just before (below) the one given by tagOrId +in the display list. +If tagOrId denotes more than one item, then the first (lowest) +of these items in the display list is used. +

    +
    closest x y ?halo? ?start?
    +

    Selects the item closest to the point given by x and y. +If more than one item is at the same closest distance (e.g. two +items overlap the point), then the top-most of these items (the +last one in the display list) is used. +If halo is specified, then it must be a non-negative +value. +Any item closer than halo to the point is considered to +overlap it. +The start argument may be used to step circularly through +all the closest items. +If start is specified, it names an item using a tag or id +(if by tag, it selects the first item in the display list with +the given tag). +Instead of selecting the topmost closest item, this form will +select the topmost closest item that is below start in +the display list; if no such item exists, then the selection +behaves as if the start argument had not been specified. +

    +
    enclosed x1 y1 x2 y2
    +

    Selects all the items completely enclosed within the rectangular +region given by x1, y1, x2, and y2. +X1 must be no greater then x2 and y1 must be +no greater than y2. +

    +
    overlapping x1 y1 x2 y2
    +

    Selects all the items that overlap or are enclosed within the +rectangular region given by x1, y1, x2, +and y2. +X1 must be no greater then x2 and y1 must be +no greater than y2. +

    +
    withtag tagOrId
    +

    Selects all the items given by tagOrId. +

    +
    + +
    +
    pathName :bbox tagOrId ?tagOrId tagOrId ...?
    +

    Returns a list with four elements giving an approximate bounding box +for all the items named by the tagOrId arguments. +The list has the form “x1 y1 x2 y2” such that the drawn +areas of all the named elements are within the region bounded by +x1 on the left, x2 on the right, y1 on the top, +and y2 on the bottom. +The return value may overestimate the actual bounding box by +a few pixels. +If no items match any of the tagOrId arguments then an +empty string is returned. +

    +
    pathName :bind tagOrId ?sequence? ?command?
    +

    This command associates command with all the items given by +tagOrId such that whenever the event sequence given by +sequence occurs for one of the items the command will +be invoked. +This widget command is similar to the bind command except that +it operates on items in a canvas rather than entire widgets. +See the bind manual entry for complete details +on the syntax of sequence and the substitutions performed +on command before invoking it. +If all arguments are specified then a new binding is created, replacing +any existing binding for the same sequence and tagOrId +(if the first character of command is “+” then command +augments an existing binding rather than replacing it). +In this case the return value is an empty string. +If command is omitted then the command returns the command +associated with tagOrId and sequence (an error occurs +if there is no such binding). +If both command and sequence are omitted then the command +returns a list of all the sequences for which bindings have been +defined for tagOrId. +

    +
    + + +

    The only events for which bindings may be specified are those related +to the mouse and keyboard, such as Enter, Leave, +ButtonPress, Motion, and KeyPress. +The handling of events in canvases uses the current item defined +in ITEM IDS AND TAGS above. +Enter and Leave events trigger for an item when it +becomes the current item or ceases to be the current item; note +that these events are different than Enter and Leave +events for windows. +Mouse-related events are directed to the current item, if any. +Keyboard-related events are directed to the focus item, if any +(see the focus widget command below for more on this). +

    + +

    It is possible for multiple commands to be bound to a single +event sequence for a single object. +This occurs, for example, if one command is associated with the +item’s id and another is associated with one of the item’s tags. +When this occurs, the first matching binding is used. +A binding for the item’s id has highest priority, followed by +the oldest tag for the item and proceeding through all of the +item’s tags up through the most-recently-added one. +If a binding is associated with the tag all, the binding +will have lower priority than all other bindings associated +with the item. +

    +
    +
    pathName :canvasx screenx ?gridspacing?
    +

    Given a screen x-coordinate screenx this command returns +the canvas x-coordinate that is displayed at that location. +If gridspacing is specified, then the canvas coordinate is +rounded to the nearest multiple of gridspacing units. +

    +
    pathName :canvasy screeny ?gridspacing?
    +

    Given a screen y-coordinate screeny this command returns +the canvas y-coordinate that is displayed at that location. +If gridspacing is specified, then the canvas coordinate is +rounded to the nearest multiple of gridspacing units. +

    +
    pathName :configure ?option? ?value? ?option value ...?
    +

    Query or modify the configuration options of the widget. +If no option is specified, returns a list describing all of +the available options for pathName (see Tk_ConfigureInfo for +information on the format of this list). If option is specified +with no value, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no option is specified). If +one or more option:value pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +Option may have any of the values accepted by the canvas +command. +

    +
    pathName :coords tagOrId ?x0 y0 ...?
    +

    Query or modify the coordinates that define an item. +If no coordinates are specified, this command returns a list +whose elements are the coordinates of the item named by +tagOrId. +If coordinates are specified, then they replace the current +coordinates for the named item. +If tagOrId refers to multiple items, then +the first one in the display list is used. +

    +
    pathName :create type x y ?x y ...? ?option value ...?
    +

    Create a new item in pathName of type type. +The exact format of the arguments after type depends +on type, but usually they consist of the coordinates for +one or more points, followed by specifications for zero or +more item options. +See the subsections on individual item types below for more +on the syntax of this command. +This command returns the id for the new item. +

    +
    pathName :dchars tagOrId first ?last?
    +

    For each item given by tagOrId, delete the characters +in the range given by first and last, +inclusive. +If some of the items given by tagOrId don’t support +text operations, then they are ignored. +First and last are indices of characters +within the item(s) as described in INDICES above. +If last is omitted, it defaults to first. +This command returns an empty string. +

    +
    pathName :delete ?tagOrId tagOrId ...?
    +

    Delete each of the items given by each tagOrId, and return +an empty string. +

    +
    pathName :dtag tagOrId ?tagToDelete?
    +

    For each of the items given by tagOrId, delete the +tag given by tagToDelete from the list of those +associated with the item. +If an item doesn’t have the tag tagToDelete then +the item is unaffected by the command. +If tagToDelete is omitted then it defaults to tagOrId. +This command returns an empty string. +

    +
    pathName :find searchCommand ?arg arg ...?
    +

    This command returns a list consisting of all the items that +meet the constraints specified by searchCommand and +arg’s. +SearchCommand and args have any of the forms +accepted by the addtag command. +

    +
    pathName :focus ?tagOrId?
    +

    Set the keyboard focus for the canvas widget to the item given by +tagOrId. +If tagOrId refers to several items, then the focus is set +to the first such item in the display list that supports the +insertion cursor. +If tagOrId doesn’t refer to any items, or if none of them +support the insertion cursor, then the focus isn’t changed. +If tagOrId is an empty +string, then the focus item is reset so that no item has the focus. +If tagOrId is not specified then the command returns the +id for the item that currently has the focus, or an empty string +if no item has the focus. +

    +
    + + +

    Once the focus has been set to an item, the item will display +the insertion cursor and all keyboard events will be directed +to that item. +The focus item within a canvas and the focus window on the +screen (set with the focus command) are totally independent: +a given item doesn’t actually have the input focus unless (a) +its canvas is the focus window and (b) the item is the focus item +within the canvas. +In most cases it is advisable to follow the focus widget +command with the focus command to set the focus window to +the canvas (if it wasn’t there already). +

    +
    +
    pathName :gettags tagOrId
    +

    Return a list whose elements are the tags associated with the +item given by tagOrId. +If tagOrId refers to more than one item, then the tags +are returned from the first such item in the display list. +If tagOrId doesn’t refer to any items, or if the item +contains no tags, then an empty string is returned. +

    +
    pathName :icursor tagOrId index
    +

    Set the position of the insertion cursor for the item(s) +given by tagOrId +to just before the character whose position is given by index. +If some or all of the items given by tagOrId don’t support +an insertion cursor then this command has no effect on them. +See INDICES above for a description of the +legal forms for index. +Note: the insertion cursor is only displayed in an item if +that item currently has the keyboard focus (see the widget +command focus, below), but the cursor position may +be set even when the item doesn’t have the focus. +This command returns an empty string. +

    +
    pathName :index tagOrId index
    +

    This command returns a decimal string giving the numerical index +within tagOrId corresponding to index. +Index gives a textual description of the desired position +as described in INDICES above. +The return value is guaranteed to lie between 0 and the number +of characters within the item, inclusive. +If tagOrId refers to multiple items, then the index +is processed in the first of these items that supports indexing +operations (in display list order). +

    +
    pathName :insert tagOrId beforeThis string
    +

    For each of the items given by tagOrId, if the item supports +text insertion then string is inserted into the item’s +text just before the character whose index is beforeThis. +See INDICES above for information about the forms allowed +for beforeThis. +This command returns an empty string. +

    +
    pathName :itemconfigure tagOrId ?option? ?value? ?option value ...?
    +

    This command is similar to the configure widget command except +that it modifies item-specific options for the items given by +tagOrId instead of modifying options for the overall +canvas widget. +If no option is specified, returns a list describing all of +the available options for the first item given by tagOrId +(see Tk_ConfigureInfo for +information on the format of this list). If option is specified +with no value, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no option is specified). If +one or more option:value pairs are specified, then the command +modifies the given widget option(s) to have the given value(s) in +each of the items given by tagOrId; in +this case the command returns an empty string. +The options and values are the same as those permissible +in the create widget command when the item(s) were created; +see the sections describing individual item types below for details +on the legal options. +

    +
    pathName :lower tagOrId ?belowThis?
    +

    Move all of the items given by tagOrId to a new position +in the display list just before the item given by belowThis. +If tagOrId refers to more than one item then all are moved +but the relative order of the moved items will not be changed. +BelowThis is a tag or id; if it refers to more than one +item then the first (lowest) of these items in the display list is used +as the destination location for the moved items. +This command returns an empty string. +

    +
    pathName :move tagOrId xAmount yAmount
    +

    Move each of the items given by tagOrId in the canvas coordinate +space by adding xAmount to the x-coordinate of each point +associated with the item and yAmount to the y-coordinate of +each point associated with the item. +This command returns an empty string. +

    +
    pathName :postscript ?option value option value ...?
    +

    Generate a Postscript representation for part or all of the canvas. +If the :file option is specified then the Postscript is written +to a file and an empty string is returned; otherwise the Postscript +is returned as the result of the command. +The Postscript is created in Encapsulated Postscript form using +version 3.0 of the Document Structuring Conventions. +The option\-value argument pairs provide additional +information to control the generation of Postscript. The following +options are supported: +

    +
    +
    :colormap varName
    +

    VarName must be the name of a global array variable +that specifies a color mapping to use in the Postscript. +Each element of varName must consist of Postscript +code to set a particular color value (e.g. “1.0 1.0 0.0 setrgbcolor”). +When outputting color information in the Postscript, Tk checks +to see if there is an element of varName with the same +name as the color. +If so, Tk uses the value of the element as the Postscript command +to set the color. +If this option hasn’t been specified, or if there isn’t an entry +in varName for a given color, then Tk uses the red, green, +and blue intensities from the X color. +

    +
    :colormode mode
    +

    Specifies how to output color information. Mode must be either +color (for full color output), gray (convert all colors +to their gray-scale equivalents) or mono (convert all colors +to black or white). +

    +
    :file fileName
    +

    Specifies the name of the file in which to write the Postscript. +If this option isn’t specified then the Postscript is returned as the +result of the command instead of being written to a file. +

    +
    :fontmap varName
    +

    VarName must be the name of a global array variable +that specifies a font mapping to use in the Postscript. +Each element of varName must consist of a Tcl list with +two elements, which are the name and point size of a Postscript font. +When outputting Postscript commands for a particular font, Tk +checks to see if varName contains an element with the same +name as the font. +If there is such an element, then the font information contained in +that element is used in the Postscript. +Otherwise Tk attempts to guess what Postscript font to use. +Tk’s guesses generally only work for well-known fonts such as +Times and Helvetica and Courier, and only if the X font name does not +omit any dashes up through the point size. +For example, \fB\-*\-Courier\-Bold\-R\-Normal\-\-*\-120\-* will work but +\fB*Courier\-Bold\-R\-Normal*120* will not; Tk needs the dashes to +parse the font name). +

    +
    :height size
    +

    Specifies the height of the area of the canvas to print. +Defaults to the height of the canvas window. +

    +
    :pageanchor anchor
    +

    Specifies which point of the printed area should be appear over +the positioning point on the page (which is given by the :pagex +and :pagey options). +For example, :pageanchor n means that the top center of the +printed area should be over the positioning point. +Defaults to center. +

    +
    :pageheight size
    +

    Specifies that the Postscript should be scaled in both x and y so +that the printed area is size high on the Postscript page. +Size consists of a floating-point number followed by +c for centimeters, i for inches, m for millimeters, +or p or nothing for printer’s points (1/72 inch). +Defaults to the height of the printed area on the screen. +If both :pageheight and :pagewidth are specified then +the scale factor from the later option is used (non-uniform scaling +is not implemented). +

    +
    :pagewidth size
    +

    Specifies that the Postscript should be scaled in both x and y so +that the printed area is size wide on the Postscript page. +Size has the same form as for :pageheight. +Defaults to the width of the printed area on the screen. +If both :pageheight and :pagewidth are specified then +the scale factor from the later option is used (non-uniform scaling +is not implemented). +

    +
    :pagex position
    +

    Position gives the x-coordinate of the positioning point on +the Postscript page, using any of the forms allowed for :pageheight. +Used in conjunction with the :pagey and :pageanchor options +to determine where the printed area appears on the Postscript page. +Defaults to the center of the page. +

    +
    :pagey position
    +

    Position gives the y-coordinate of the positioning point on +the Postscript page, using any of the forms allowed for :pageheight. +Used in conjunction with the :pagex and :pageanchor options +to determine where the printed area appears on the Postscript page. +Defaults to the center of the page. +

    +
    :rotate boolean
    +

    Boolean specifies whether the printed area is to be rotated 90 +degrees. +In non-rotated output the x-axis of the printed area runs along +the short dimension of the page (“portrait” orientation); +in rotated output the x-axis runs along the long dimension of the +page (“landscape” orientation). +Defaults to non-rotated. +

    +
    :width size
    +

    Specifies the width of the area of the canvas to print. +Defaults to the width of the canvas window. +

    +
    :x position
    +

    Specifies the x-coordinate of the left edge of the area of the +canvas that is to be printed, in canvas coordinates, not window +coordinates. +Defaults to the coordinate of the left edge of the window. +

    +
    :y position
    +

    Specifies the y-coordinate of the top edge of the area of the +canvas that is to be printed, in canvas coordinates, not window +coordinates. +Defaults to the coordinate of the top edge of the window. +

    +
    + +
    +
    pathName :raise tagOrId ?aboveThis?
    +

    Move all of the items given by tagOrId to a new position +in the display list just after the item given by aboveThis. +If tagOrId refers to more than one item then all are moved +but the relative order of the moved items will not be changed. +AboveThis is a tag or id; if it refers to more than one +item then the last (topmost) of these items in the display list is used +as the destination location for the moved items. +This command returns an empty string. +

    +
    pathName :scale tagOrId xOrigin yOrigin xScale yScale
    +

    Rescale all of the items given by tagOrId in canvas coordinate +space. +XOrigin and yOrigin identify the origin for the scaling +operation and xScale and yScale identify the scale +factors for x- and y-coordinates, respectively (a scale factor of +1.0 implies no change to that coordinate). +For each of the points defining each item, the x-coordinate is +adjusted to change the distance from xOrigin by a factor +of xScale. +Similarly, each y-coordinate is adjusted to change the distance +from yOrigin by a factor of yScale. +This command returns an empty string. +

    +
    pathName :scan option args
    +

    This command is used to implement scanning on canvases. It has +two forms, depending on option: +

    +
    +
    pathName :scan :mark x y
    +

    Records x and y and the canvas’s current view; used +in conjunction with later scan dragto commands. +Typically this command is associated with a mouse button press in +the widget and x and y are the coordinates of the +mouse. It returns an empty string. +

    +
    pathName :scan :dragto x y.
    +

    This command computes the difference between its x and y +arguments (which are typically mouse coordinates) and the x and +y arguments to the last scan mark command for the widget. +It then adjusts the view by 10 times the +difference in coordinates. This command is typically associated +with mouse motion events in the widget, to produce the effect of +dragging the canvas at high speed through its window. The return +value is an empty string. +

    +
    + +
    +
    pathName :select option ?tagOrId arg?
    +

    Manipulates the selection in one of several ways, depending on +option. +The command may take any of the forms described below. +In all of the descriptions below, tagOrId must refer to +an item that supports indexing and selection; if it refers to +multiple items then the first of +these that supports indexing and the selection is used. +Index gives a textual description of a position +within tagOrId, as described in INDICES above. +

    +
    +
    pathName :select :adjust tagOrId index
    +

    Locate the end of the selection in tagOrId nearest +to the character given by index, and adjust that +end of the selection to be at index (i.e. including +but not going beyond index). +The other end of the selection is made the anchor point +for future select to commands. +If the selection isn’t currently in tagOrId then +this command behaves the same as the select to widget +command. +Returns an empty string. +

    +
    pathName :select :clear
    +

    Clear the selection if it is in this widget. +If the selection isn’t in this widget then the command +has no effect. +Returns an empty string. +

    +
    pathName :select :from tagOrId index
    +

    Set the selection anchor point for the widget to be just +before the character +given by index in the item given by tagOrId. +This command doesn’t change the selection; it just sets +the fixed end of the selection for future select to +commands. +Returns an empty string. +

    +
    pathName :select :item
    +

    Returns the id of the selected item, if the selection is in an +item in this canvas. +If the selection is not in this canvas then an empty string +is returned. +

    +
    pathName :select :to tagOrId index
    +

    Set the selection to consist of those characters of tagOrId +between the selection anchor point and +index. +The new selection will include the character given by index; +it will include the character given by the anchor point only if +index is greater than or equal to the anchor point. +The anchor point is determined by the most recent select adjust +or select from command for this widget. +If the selection anchor point for the widget isn’t currently in +tagOrId, then it is set to the same character given +by index. +Returns an empty string. +

    +
    + +
    +
    pathName :type tagOrId
    +

    Returns the type of the item given by tagOrId, such as +rectangle or text. +If tagOrId refers to more than one item, then the type +of the first item in the display list is returned. +If tagOrId doesn’t refer to any items at all then +an empty string is returned. +

    +
    pathName :xview index
    +

    Change the view in the canvas so that the canvas position given by +index appears at the left edge of the window. +This command is typically used by scrollbars to scroll the +canvas. +Index counts in units of scroll increments (the value of the +scrollIncrement option): a value of 0 corresponds to the left +edge of the scroll region (as defined by the scrollRegion +option), a value of 1 means one scroll unit to the right of this, +and so on. The return value is an empty string. +

    +
    pathName :yview index
    +

    Change the view in the canvas so that the canvas position given by +index appears at the top edge of the window. +This command is typically used by scrollbars to scroll the +canvas. +Index counts in units of scroll increments (the value of the +scrollIncrement option): a value of 0 corresponds to the top +edge of the scroll region (as defined by the scrollRegion +option), a value of 1 means one scroll unit below this, +and so on. The return value is an empty string. +

    +
    +
    + +

    Overview Of Item Types

    + +

    The sections below describe the various types of items supported +by canvas widgets. Each item type is characterized by two things: +first, the form of the create command used to create +instances of the type; and second, a set of configuration options +for items of that type, which may be used in the +create and itemconfigure widget commands. +Most items don’t support indexing or selection or the commands +related to them, such as index and insert. +Where items do support these facilities, it is noted explicitly +in the descriptions below (at present, only text items provide +this support). +

    + +

    Arc Items

    + +

    Items of type arc appear on the display as arc-shaped regions. +An arc is a section of an oval delimited by two angles (specified +by the :start and :extent options) and displayed in +one of several ways (specified by the :style option). +Arcs are created with widget commands of the following form: +

    +
    +
    pathName :create arc x1 y1 x2 y2 ?option value option value ...?
    +

    The arguments x1, y1, x2, and y2 give +the coordinates of two diagonally opposite corners of a +rectangular region enclosing the oval that defines the arc. +After the coordinates there may be any number of option-value +pairs, each of which sets one of the configuration options +for the item. These same option\-value pairs may be +used in itemconfigure widget commands to change the item’s +configuration. +The following options are supported for arcs: +

    +
    +
    :extent degrees
    +

    Specifies the size of the angular range occupied by the arc. +The arc’s range extends for degrees degrees counter-clockwise +from the starting angle given by the :start option. +Degrees may be negative. +

    +
    :fill color
    +

    Fill the region of the arc with color. +Color may have any of the forms accepted by Tk_GetColor. +If color is an empty string (the default), then +then the arc will not be filled. +

    +
    :outline color
    +

    Color specifies a color to use for drawing the arc’s +outline; it may have any of the forms accepted by Tk_GetColor. +This option defaults to black. If the arc’s style is +arc then this option is ignored (the section of perimeter is +filled using the :fill option). If color is specified +as an empty string then no outline is drawn for the arc. +

    +
    :start degrees
    +

    Specifies the beginning of the angular range occupied by the +arc. +Degrees is given in units of degrees measured counter-clockwise +from the 3-o’clock position; it may be either positive or negative. +

    +
    :stipple bitmap
    +

    Indicates that the arc should be filled in a stipple pattern; +bitmap specifies the stipple pattern to use, in any of the +forms accepted by Tk_GetBitmap. +If the :fill option hasn’t been specified then this option +has no effect. +If bitmap is an empty string (the default), then filling is done +in a solid fashion. +

    +
    :style type
    +

    Specifies how to draw the arc. If type is pieslice +(the default) then the arc’s region is defined by a section +of the oval’s perimeter plus two line segments, one between the center +of the oval and each end of the perimeter section. +If type is chord then the arc’s region is defined +by a section of the oval’s perimeter plus a single line segment +connecting the two end points of the perimeter section. +If type is arc then the arc’s region consists of +a section of the perimeter alone. In this last case there is +no outline for the arc and the :outline option is ignored. +

    +
    :tags tagList
    +

    Specifies a set of tags to apply to the item. +TagList consists of a list of tag names, which replace any +existing tags for the item. +TagList may be an empty list. +

    +
    :width outlineWidth
    +

    Specifies the width of the outline to be drawn around +the arc’s region, in any of the forms described in the COORDINATES +section above. +If the :outline option has been specified as an empty string +then this option has no effect. +Wide outlines will be drawn centered on the edges of the arc’s region. +This option defaults to 1.0. +

    +
    +
    +
    + + +

    Bitmap Items

    + +

    Items of type bitmap appear on the display as images with +two colors, foreground and background. +Bitmaps are created with widget commands of the following form: +

    +
    +
    pathName :create bitmap x y ?option value option value ...?
    +

    The arguments x and y specify the coordinates of a +point used to position the bitmap on the display (see the :anchor +option below for more information on how bitmaps are displayed). +After the coordinates there may be any number of option-value +pairs, each of which sets one of the configuration options +for the item. These same option\-value pairs may be +used in itemconfigure widget commands to change the item’s +configuration. +The following options are supported for bitmaps: +

    +
    +
    :anchor anchorPos
    +

    AnchorPos tells how to position the bitmap relative to the +positioning point for the item; it may have any of the forms +accepted by Tk_GetAnchor. For example, if anchorPos +is center then the bitmap is centered on the point; if +anchorPos is n then the bitmap will be drawn so that +its top center point is at the positioning point. +This option defaults to center. +

    +
    :background color
    +

    Specifies a color to use for each of the bitmap pixels +whose value is 0. +Color may have any of the forms accepted by Tk_GetColor. +If this option isn’t specified, or if it is specified as an empty +string, then the background color for the canvas is used. +

    +
    :bitmap bitmap
    +

    Specifies the bitmap to display in the item. +Bitmap may have any of the forms accepted by Tk_GetBitmap. +

    +
    :foreground color
    +

    Specifies a color to use for each of the bitmap pixels +whose value is 1. +Color may have any of the forms accepted by Tk_GetColor and +defaults to black. +

    +
    :tags tagList
    +

    Specifies a set of tags to apply to the item. +TagList consists of a list of tag names, which replace any +existing tags for the item. +TagList may be an empty list. +

    +
    +
    +
    + +

    Line Items

    + +

    Items of type line appear on the display as one or more connected +line segments or curves. +Lines are created with widget commands of the following form: +

    +
    +
    pathName :create line x1 y1... xn yn ?option value option value ...?
    +
    +

    The arguments x1 through yn give +the coordinates for a series of two or more points that describe +a series of connected line segments. +After the coordinates there may be any number of option-value +pairs, each of which sets one of the configuration options +for the item. These same option\-value pairs may be +used in itemconfigure widget commands to change the item’s +configuration. +The following options are supported for lines: +

    +
    +
    :arrow where
    +

    Indicates whether or not arrowheads are to be drawn at one or both +ends of the line. +Where must have one of the values none (for no arrowheads), +first (for an arrowhead at the first point of the line), +last (for an arrowhead at the last point of the line), or +both (for arrowheads at both ends). +This option defaults to none. +

    +
    :arrowshape shape
    +

    This option indicates how to draw arrowheads. +The shape argument must be a list with three elements, each +specifying a distance in any of the forms described in +the COORDINATES section above. +The first element of the list gives the distance along the line +from the neck of the arrowhead to its tip. +The second element gives the distance along the line from the +trailing points of the arrowhead to the tip, and the third +element gives the distance from the outside edge of the line to the +trailing points. +If this option isn’t specified then Tk picks a “reasonable” shape. +

    +
    :capstyle style
    +

    Specifies the ways in which caps are to be drawn at the endpoints +of the line. +Style may have any of the forms accepted by Tk_GetCapStyle +(butt, projecting, or round). +If this option isn’t specified then it defaults to butt. +Where arrowheads are drawn the cap style is ignored. +

    +
    :fill color
    +

    Color specifies a color to use for drawing the line; it may have +any of the forms acceptable to Tk_GetColor. It may also be an +empty string, in which case the line will be transparent. +This option defaults to black. +

    +
    :joinstyle style
    +

    Specifies the ways in which joints are to be drawn at the vertices +of the line. +Style may have any of the forms accepted by Tk_GetCapStyle +(bevel, miter, or round). +If this option isn’t specified then it defaults to miter. +If the line only contains two points then this option is +irrelevant. +

    +
    :smooth boolean
    +

    Boolean must have one of the forms accepted by Tk_GetBoolean. +It indicates whether or not the line should be drawn as a curve. +If so, the line is rendered as a set of Bezier splines: one spline +is drawn for the first and second line segments, one for the second +and third, and so on. Straight-line segments can be generated within +a curve by duplicating the end-points of the desired line segment. +

    +
    :splinesteps number
    +

    Specifies the degree of smoothness desired for curves: each spline +will be approximated with number line segments. This +option is ignored unless the :smooth option is true. +

    +
    :stipple bitmap
    +

    Indicates that the line should be filled in a stipple pattern; +bitmap specifies the stipple pattern to use, in any of the +forms accepted by Tk_GetBitmap. +If bitmap is an empty string (the default), then filling is +done in a solid fashion. +

    +
    :tags tagList
    +

    Specifies a set of tags to apply to the item. +TagList consists of a list of tag names, which replace any +existing tags for the item. +TagList may be an empty list. +

    +
    :width lineWidth
    +

    LineWidth specifies the width of the line, in any of the forms +described in the COORDINATES section above. +Wide lines will be drawn centered on the path specified by the +points. +If this option isn’t specified then it defaults to 1.0. +

    +
    +
    +
    + +

    Oval Items

    + +

    Items of type oval appear as circular or oval regions on +the display. Each oval may have an outline, a fill, or +both. Ovals are created with widget commands of the +following form: +

    +
    +
    pathName :create oval x1 y1 x2 y2 ?option value option value ...?
    +
    +

    The arguments x1, y1, x2, and y2 give +the coordinates of two diagonally opposite corners of a +rectangular region enclosing the oval. +The oval will include the top and left edges of the rectangle +not the lower or right edges. +If the region is square then the resulting oval is circular; +otherwise it is elongated in shape. +After the coordinates there may be any number of option-value +pairs, each of which sets one of the configuration options +for the item. These same option\-value pairs may be +used in itemconfigure widget commands to change the item’s +configuration. +The following options are supported for ovals: +

    +
    +
    :fill color
    +

    Fill the area of the oval with color. +Color may have any of the forms accepted by Tk_GetColor. +If color is an empty string (the default), then +then the oval will not be filled. +

    +
    :outline color
    +

    Color specifies a color to use for drawing the oval’s +outline; it may have any of the forms accepted by Tk_GetColor. +This option defaults to black. +If color is an empty string then no outline will be +drawn for the oval. +

    +
    :stipple bitmap
    +

    Indicates that the oval should be filled in a stipple pattern; +bitmap specifies the stipple pattern to use, in any of the +forms accepted by Tk_GetBitmap. +If the :fill option hasn’t been specified then this option +has no effect. +If bitmap is an empty string (the default), then filling is done +in a solid fashion. +

    +
    :tags tagList
    +

    Specifies a set of tags to apply to the item. +TagList consists of a list of tag names, which replace any +existing tags for the item. +TagList may be an empty list. +

    +
    :width outlineWidth
    +

    outlineWidth specifies the width of the outline to be drawn around +the oval, in any of the forms described in the COORDINATES section above. +If the :outline option hasn’t been specified then this option +has no effect. +Wide outlines are drawn centered on the oval path defined by +x1, y1, x2, and y2. +This option defaults to 1.0. +

    +
    +
    +
    + +

    Polygon Items

    + +

    Items of type polygon appear as polygonal or curved filled regions +on the display. +Polygons are created with widget commands of the following form: +

    +
    +
    pathName :create polygon x1 y1 ... xn yn ?option value option value ...?
    +
    + +

    The arguments x1 through yn specify the coordinates for +three or more points that define a closed polygon. +The first and last points may be the same; whether they are or not, +Tk will draw the polygon as a closed polygon. +After the coordinates there may be any number of option-value +pairs, each of which sets one of the configuration options +for the item. These same option\-value pairs may be +used in itemconfigure widget commands to change the item’s +configuration. +The following options are supported for polygons: +

    +
    +
    :fill color
    +

    Color specifies a color to use for filling the area of the +polygon; it may have any of the forms acceptable to Tk_GetColor. +If color is an empty string then the polygon will be +transparent. +This option defaults to black. +

    +
    :smooth boolean
    +

    Boolean must have one of the forms accepted by Tk_GetBoolean +It indicates whether or not the polygon should be drawn with a +curved perimeter. +If so, the outline of the polygon becomes a set of Bezier splines, +one spline for the first and second line segments, one for the second +and third, and so on. Straight-line segments can be generated in a +smoothed polygon by duplicating the end-points of the desired line segment. +

    +
    :splinesteps number
    +

    Specifies the degree of smoothness desired for curves: each spline +will be approximated with number line segments. This +option is ignored unless the :smooth option is true. +

    +
    :stipple bitmap
    +

    Indicates that the polygon should be filled in a stipple pattern; +bitmap specifies the stipple pattern to use, in any of the +forms accepted by Tk_GetBitmap. +If bitmap is an empty string (the default), then filling is +done in a solid fashion. +

    +
    :tags tagList
    +

    Specifies a set of tags to apply to the item. +TagList consists of a list of tag names, which replace any +existing tags for the item. +TagList may be an empty list. +

    +
    +
    +
    + + +

    Rectangle Items

    + +

    Items of type rectangle appear as rectangular regions on +the display. Each rectangle may have an outline, a fill, or +both. Rectangles are created with widget commands of the +following form: +

    +
    +
    pathName :create rectangle x1 y1 x2 y2 ?option value option value ...?
    +
    +

    The arguments x1, y1, x2, and y2 give +the coordinates of two diagonally opposite corners of the rectangle +(the rectangle will include its upper and left edges but not +its lower or right edges). +After the coordinates there may be any number of option-value +pairs, each of which sets one of the configuration options +for the item. These same option\-value pairs may be +used in itemconfigure widget commands to change the item’s +configuration. +The following options are supported for rectangles: +

    +
    +
    :fill color
    +

    Fill the area of the rectangle with color, which may be +specified in any of the forms accepted by Tk_GetColor. +If color is an empty string (the default), then +then the rectangle will not be filled. +

    +
    :outline color
    +

    Draw an outline around the edge of the rectangle in color. +Color may have any of the forms accepted by Tk_GetColor. +This option defaults to black. +If color is an empty string then no outline will be +drawn for the rectangle. +

    +
    :stipple bitmap
    +

    Indicates that the rectangle should be filled in a stipple pattern; +bitmap specifies the stipple pattern to use, in any of the +forms accepted by Tk_GetBitmap. +If the :fill option hasn’t been specified then this option +has no effect. +If bitmap is an empty string (the default), then filling +is done in a solid fashion. +

    +
    :tags tagList
    +

    Specifies a set of tags to apply to the item. +TagList consists of a list of tag names, which replace any +existing tags for the item. +TagList may be an empty list. +

    +
    :width outlineWidth
    +

    OutlineWidth specifies the width of the outline to be drawn around +the rectangle, in any of the forms described in the COORDINATES section above. +If the :outline option hasn’t been specified then this option +has no effect. +Wide outlines are drawn centered on the rectangular path +defined by x1, y1, x2, and y2. +This option defaults to 1.0. +

    +
    +
    +
    + +

    Text Items

    + +

    A text item displays a string of characters on the screen in one +or more lines. +Text items support indexing and selection, along with the +following text-related canvas widget commands: dchars, +focus, icursor, index, insert, +select. +Text items are created with widget commands of the following +form: +

    +
    +
    pathName :create text x y ?option value option value ...?
    +
    +

    The arguments x and y specify the coordinates of a +point used to position the text on the display (see the options +below for more information on how text is displayed). +After the coordinates there may be any number of option-value +pairs, each of which sets one of the configuration options +for the item. These same option\-value pairs may be +used in itemconfigure widget commands to change the item’s +configuration. +The following options are supported for text items: +

    +
    +
    :anchor anchorPos
    +

    AnchorPos tells how to position the text relative to the +positioning point for the text; it may have any of the forms +accepted by Tk_GetAnchor. For example, if anchorPos +is center then the text is centered on the point; if +anchorPos is n then the text will be drawn such that +the top center point of the rectangular region occupied by the +text will be at the positioning point. +This option defaults to center. +

    +
    :fill color
    +

    Color specifies a color to use for filling the text characters; +it may have any of the forms accepted by Tk_GetColor. +If this option isn’t specified then it defaults to black. +

    +
    :font fontName
    +

    Specifies the font to use for the text item. +FontName may be any string acceptable to Tk_GetFontStruct. +If this option isn’t specified, it defaults to a system-dependent +font. +

    +
    :justify how
    +

    Specifies how to justify the text within its bounding region. +How must be one of the values left, right, +or center. +This option will only matter if the text is displayed as multiple +lines. +If the option is omitted, it defaults to left. +

    +
    :stipple bitmap
    +

    Indicates that the text should be drawn in a stippled pattern +rather than solid; +bitmap specifies the stipple pattern to use, in any of the +forms accepted by Tk_GetBitmap. +If bitmap is an empty string (the default) then the text +is drawn in a solid fashion. +

    +
    :tags tagList
    +

    Specifies a set of tags to apply to the item. +TagList consists of a list of tag names, which replace any +existing tags for the item. +TagList may be an empty list. +

    +
    :text string
    +

    String specifies the characters to be displayed in the text item. +Newline characters cause line breaks. +The characters in the item may also be changed with the +insert and delete widget commands. +This option defaults to an empty string. +

    +
    :width lineLength
    +

    Specifies a maximum line length for the text, in any of the forms +described in the COORDINATES section abov. +If this option is zero (the default) the text is broken into +lines only at newline characters. +However, if this option is non-zero then any line that would +be longer than lineLength is broken just before a space +character to make the line shorter than lineLength; the +space character is treated as if it were a newline +character. +

    +
    +
    +
    +
    + +

    Window Items

    + +

    Items of type window cause a particular window to be displayed +at a given position on the canvas. +Window items are created with widget commands of the following form: +

    +
    +
    pathName :create window x y ?option value option value ...?
+
    + +

    The arguments x and y specify the coordinates of a +point used to position the window on the display (see the :anchor +option below for more information on how bitmaps are displayed). +After the coordinates there may be any number of option-value +pairs, each of which sets one of the configuration options +for the item. These same option\-value pairs may be +used in itemconfigure widget commands to change the item’s +configuration. +The following options are supported for window items: +

    +
    +
    :anchor anchorPos
    +

    AnchorPos tells how to position the window relative to the +positioning point for the item; it may have any of the forms +accepted by Tk_GetAnchor. For example, if anchorPos +is center then the window is centered on the point; if +anchorPos is n then the window will be drawn so that +its top center point is at the positioning point. +This option defaults to center. +

    +
    :height pixels
    +

    Specifies the height to assign to the item’s window. +Pixels may have any of the +forms described in the COORDINATES section above. +If this option isn’t specified, or if it is specified as an empty +string, then the window is given whatever height it requests internally. +

    +
    :tags tagList
    +

    Specifies a set of tags to apply to the item. +TagList consists of a list of tag names, which replace any +existing tags for the item. +TagList may be an empty list. +

    +
    :width pixels
    +

    Specifies the width to assign to the item’s window. +Pixels may have any of the +forms described in the COORDINATES section above. +If this option isn’t specified, or if it is specified as an empty +string, then the window is given whatever width it requests internally. +

    +
    :window pathName
    +

    Specifies the window to associate with this item. +The window specified by pathName must either be a child of +the canvas widget or a child of some ancestor of the canvas widget. +PathName may not refer to a top-level window. +

    +
    +
    + +

    Application-Defined Item Types

    + +

    It is possible for individual applications to define new item +types for canvas widgets using C code. +The interfaces for this mechanism are not presently documented, +and it’s possible they may change, but you should be able to +see how they work by examining the code for some of the existing +item types. +

    + +

    Bindings

    + +

    In the current implementation, new canvases are not given any +default behavior: you’ll have to execute explicit Tcl commands +to give the canvas its behavior. +

    + +

    Credits

    + +

    Tk’s canvas widget is a blatant ripoff of ideas from Joel Bartlett’s +ezd program. Ezd provides structured graphics in a Scheme +environment and preceded canvases by a year or two. Its simple +mechanisms for placing and animating graphical objects inspired the +functions of canvases. +

    + +

    Keywords

    +

    canvas, widget +

    +
    +

    +Next: , Previous: , Up: Widgets   [Contents]

    +
    + + + + + diff --git a/info/gcl-tk/checkbutton.html b/info/gcl-tk/checkbutton.html new file mode 100644 index 0000000..4d4b8ca --- /dev/null +++ b/info/gcl-tk/checkbutton.html @@ -0,0 +1,347 @@ + + + + +GCL TK Manual: checkbutton + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Widgets   [Contents]

    +
    +
    + +

    2.7 checkbutton

    + +

    checkbutton \- Create and manipulate check-button widgets +

    +

    Synopsis

    +

    checkbutton pathName ?options? +

    +

    Standard Options

    + + +
    +
    activeBackground  bitmap              font        relief        
+activeForeground  borderWidth         foreground  text          
+anchor            cursor              padX        textVariable  
+background        disabledForeground  padY        
+
    + + +

    See options, for more information. +

    +

    Arguments for Checkbutton

    + + +
    +
    :command
    +

    Name="command" Class="Command" +


    + +

    Specifies a Tcl command to associate with the button. This command +is typically invoked when mouse button 1 is released over the button +window. The button’s global variable (:variable option) will +be updated before the command is invoked. +

    +
    + + +
    +
    :height
    +

    Name="height" Class="Height" +


    + +

    Specifies a desired height for the button. +If a bitmap is being displayed in the button then the value is in +screen units (i.e. any of the forms acceptable to Tk_GetPixels); +for text it is in lines of text. +If this option isn’t specified, the button’s desired height is computed +from the size of the bitmap or text being displayed in it. +

    +
    + + +
    +
    :offvalue
    +

    Name="offValue" Class="Value" +


    + +

    Specifies value to store in the button’s associated variable whenever +this button is deselected. Defaults to “0”. +

    +
    + + +
    +
    :onvalue
    +

    Name="onValue" Class="Value" +


    + +

    Specifies value to store in the button’s associated variable whenever +this button is selected. Defaults to “1”. +

    +
    + + +
    +
    :selector
    +

    Name="selector" Class="Foreground" +


    + +

    Specifies the color to draw in the selector when this button is +selected. +If specified as an empty string then no selector is +drawn for the button. +

    +
    + + +
    +
    :state
    +

    Name="state" Class="State" +


    + +

    Specifies one of three states for the check button: normal, active, +or disabled. In normal state the check button is displayed using the +foreground and background options. The active state is +typically used when the pointer is over the check button. In active state +the check button is displayed using the activeForeground and +activeBackground options. Disabled state means that the check button +is insensitive: it doesn’t activate and doesn’t respond to mouse +button presses. In this state the disabledForeground and +background options determine how the check button is displayed. +

    +
    + + +
    +
    :variable
    +

    Name="variable" Class="Variable" +


    + +

    Specifies name of global variable to set to indicate whether +or not this button is selected. Defaults to the name of the +button within its parent (i.e. the last element of the button +window’s path name). +

    +
    + + +
    +
    :width
    +

    Name="width" Class="Width" +


    + +

    Specifies a desired width for the button. +If a bitmap is being displayed in the button then the value is in +screen units (i.e. any of the forms acceptable to Tk_GetPixels); +for text it is in characters. +If this option isn’t specified, the button’s desired width is computed +from the size of the bitmap or text being displayed in it. +

    +
    + + +

    Description

    + +

    The checkbutton command creates a new window (given by the +pathName argument) and makes it into a check-button widget. +Additional +options, described above, may be specified on the command line +or in the option database +to configure aspects of the check button such as its colors, font, +text, and initial relief. The checkbutton command returns its +pathName argument. At the time this command is invoked, +there must not exist a window named pathName, but +pathName’s parent must exist. +

    +

    A check button is a widget +that displays a textual string or bitmap +and a square called a selector. +A check button has +all of the behavior of a simple button, including the +following: it can display itself in either of three different +ways, according to the state option; +it can be made to appear +raised, sunken, or flat; it can be made to flash; and it invokes +a Tcl command whenever mouse button 1 is clicked over the +check button. +

    +

    In addition, check buttons can be selected. If a check button is +selected then a special highlight appears in the selector, and +a Tcl variable associated with the check button is set to a particular +value (normally 1). If the check button is not selected, then +the selector is drawn in a different fashion and the associated +variable is set to a different value (typically 0). By default, +the name of the variable associated with a check button is the +same as the name used to create the check button. The +variable name, and the “on” and “off” values stored in it, +may be modified with options on the command line or in the option +database. By default a check button is configured to select and deselect +itself on alternate button clicks. +In addition, each check button monitors its associated variable and +automatically selects and deselects itself when the variables value +changes to and from the button’s “on” value. +

    + +

    A Checkbutton Widget’s Arguments

    + +

    The checkbutton command creates a new Tcl command whose +name is pathName. This +command may be used to invoke various +operations on the widget. It has the following general form: +

    +
    +
    pathName option ?arg arg ...?
+
    + +

    Option and the args +determine the exact behavior of the command. The following +commands are possible for check button widgets: +

    +
    +
    pathName :activate
    +

    Change the check button’s state to active and redisplay the button +using its active foreground and background colors instead of normal +colors. +This command is ignored if the check button’s state is disabled. +This command is obsolete and will eventually be removed; +use “pathName :configure :state active” instead. +

    +
    pathName :configure ?option? ?value option value ...?
    +

    Query or modify the configuration options of the widget. +If no option is specified, returns a list describing all of +the available options for pathName (see Tk_ConfigureInfo for +information on the format of this list). If option is specified +with no value, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no option is specified). If +one or more option:value pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +Option may have any of the values accepted by the checkbutton +command. +

    +
    pathName :deactivate
    +

    Change the check button’s state to normal and redisplay the button +using its normal foreground and background colors. +This command is ignored if the check button’s state is disabled. +This command is obsolete and will eventually be removed; +use “pathName :configure :state normal” instead. +

    +
    pathName :deselect
    +

    Deselect the check button: redisplay it without a highlight in +the selector and set the associated variable to its “off” +value. +

    +
    pathName :flash
    +

    Flash the check button. This is accomplished by redisplaying the check button +several times, alternating between active and normal colors. At +the end of the flash the check button is left in the same normal/active +state as when the command was invoked. +This command is ignored if the check button’s state is disabled. +

    +
    pathName :invoke
    +

    Does just what would have happened if the user invoked the check button +with the mouse: toggle the selection state of the button and invoke +the Tcl command associated with the check button, if there is one. +The return value is the return value from the Tcl command, or an +empty string if there is no command associated with the check button. +This command is ignored if the check button’s state is disabled. +

    +
    pathName :select
    +

    Select the check button: display it with a highlighted +selector and set the associated variable to its “on” +value. +

    +
    pathName :toggle
    +

    Toggle the selection state of the button, redisplaying it and +modifying its associated variable to reflect the new state. +

    +
    +
    + +

    Bindings

    + +

    Tk automatically creates class bindings for check buttons that give them +the following default behavior: +

      +
    • [1] +The check button activates whenever the mouse passes over it and deactivates +whenever the mouse leaves the check button. +
    • [2] +The check button’s relief is changed to sunken whenever mouse button 1 is +pressed over it, and the relief is restored to its original +value when button 1 is later released. +
    • [3] +If mouse button 1 is pressed over the check button and later released over +the check button, the check button is invoked (i.e. its selection +state toggles and the command associated with the button is invoked, +if there is one). However, if the mouse is not +over the check button when button 1 is released, then no invocation occurs. +
    + +

    If the check button’s state is disabled then none of the above +actions occur: the check button is completely non-responsive. +

    +

    The behavior of check buttons can be changed by defining new bindings for +individual widgets or by redefining the class bindings. +

    + +

    Keywords

    +

    check button, widget +

    +
    +

    +Next: , Previous: , Up: Widgets   [Contents]

    +
    + + + + + diff --git a/info/gcl-tk/destroy.html b/info/gcl-tk/destroy.html new file mode 100644 index 0000000..5ef9956 --- /dev/null +++ b/info/gcl-tk/destroy.html @@ -0,0 +1,83 @@ + + + + +GCL TK Manual: destroy + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    +
    + +

    3.3 destroy

    + +

    destroy \- Destroy one or more windows +

    +

    Synopsis

    +

    destroy ?window window ...? +

    + +

    Description

    + +

    This command deletes the windows given by the +window arguments, plus all of their descendants. +If a window “.” is deleted then the entire application +will be destroyed. +The windows are destroyed in order, and if an error occurs +in destroying a window the command aborts without destroying the +remaining windows. +

    + +

    Keywords

    +

    application, destroy, window +

    + + + + diff --git a/info/gcl-tk/entry.html b/info/gcl-tk/entry.html new file mode 100644 index 0000000..05d8fee --- /dev/null +++ b/info/gcl-tk/entry.html @@ -0,0 +1,351 @@ + + + + +GCL TK Manual: entry + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Widgets   [Contents]

    +
    +
    + +

    2.10 entry

    + +

    entry \- Create and manipulate entry widgets +

    +

    Synopsis

    +

    entry pathName ?options? +

    +

    Standard Options

    + + +
    +
    background      foreground        insertWidth       selectForeground 
+borderWidth     insertBackground  relief            textVariable     
+cursor          insertBorderWidth scrollCommand     
+exportSelection insertOffTime     selectBackground  
+font            insertOnTime      selectBorderWidth 
+
    + + +

    See options, for more information. +

    +

    Arguments for Entry

    + + +
    +
    :state
    +

    Name="state" Class="State" +


    + +

    Specifies one of two states for the entry: normal or disabled. +If the entry is disabled then the value may not be changed using widget +commands and no insertion cursor will be displayed, even if the input focus is +in the widget. +

    +
    + + +
    +
    :width
    +

    Name="width" Class="Width" +


    + +

    Specifies an integer value indicating the desired width of the entry window, +in average-size characters of the widget’s font. +

    +
    + + +

    Description

    + +

    The entry command creates a new window (given by the +pathName argument) and makes it into an entry widget. +Additional options, described above, may be specified on the +command line or in the option database +to configure aspects of the entry such as its colors, font, +and relief. The entry command returns its +pathName argument. At the time this command is invoked, +there must not exist a window named pathName, but +pathName’s parent must exist. +

    +

    An entry is a widget that displays a one-line text string and +allows that string to be edited using widget commands described below, which +are typically bound to keystrokes and mouse actions. +When first created, an entry’s string is empty. +A portion of the entry may be selected as described below. +If an entry is exporting its selection (see the exportSelection +option), then it will observe the standard X11 protocols for handling the +selection; entry selections are available as type STRING. +Entries also observe the standard Tk rules for dealing with the +input focus. When an entry has the input focus it displays an +insertion cursor to indicate where new characters will be +inserted. +

    +

    Entries are capable of displaying strings that are too long to +fit entirely within the widget’s window. In this case, only a +portion of the string will be displayed; commands described below +may be used to change the view in the window. Entries use +the standard scrollCommand mechanism for interacting with +scrollbars (see the description of the scrollCommand option +for details). They also support scanning, as described below. +

    + +

    A Entry Widget’s Arguments

    + +

    The entry command creates a new Tcl command whose +name is pathName. This +command may be used to invoke various +operations on the widget. It has the following general form: +

    +
    +
    pathName option ?arg arg ...?
+
    + +

    Option and the args +determine the exact behavior of the command. +

    +

    Many of the widget commands for entries take one or more indices as +arguments. An index specifies a particular character in the entry’s +string, in any of the following ways: +

    +
    +
    number
    +

    Specifies the character as a numerical index, where 0 corresponds +to the first character in the string. +

    +
    end
    +

    Indicates the character just after the last one in the entry’s string. +This is equivalent to specifying a numerical index equal to the length +of the entry’s string. +

    +
    insert
    +

    Indicates the character adjacent to and immediately following the +insertion cursor. +

    +
    sel.first
    +

    Indicates the first character in the selection. It is an error to +use this form if the selection isn’t in the entry window. +

    +
    sel.last
    +

    Indicates the last character in the selection. It is an error to +use this form if the selection isn’t in the entry window. +

    +
    @number
    +

    In this form, number is treated as an x-coordinate in the +entry’s window; the character spanning that x-coordinate is used. +For example, “@0” indicates the left-most character in the +window. +

    +
    + + +

    Abbreviations may be used for any of the forms above, e.g. “e” +or “sel.f”. In general, out-of-range indices are automatically +rounded to the nearest legal value. +

    +

    The following commands are possible for entry widgets: +

    +
    +
    pathName :configure ?option? ?value option value ...?
    +

    Query or modify the configuration options of the widget. +If no option is specified, returns a list describing all of +the available options for pathName (see Tk_ConfigureInfo for +information on the format of this list). If option is specified +with no value, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no option is specified). If +one or more option:value pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +Option may have any of the values accepted by the entry +command. +

    +
    pathName :delete first ?last?
    +

    Delete one or more elements of the entry. First and last +are indices of of the first and last characters in the range to +be deleted. If last isn’t specified it defaults to +first, i.e. a single character is deleted. This command +returns an empty string. +

    +
    pathName :get
    +

    Returns the entry’s string. +

    +
    pathName :icursor index
    +

    Arrange for the insertion cursor to be displayed just before the character +given by index. Returns an empty string. +

    +
    pathName :index index
    +

    Returns the numerical index corresponding to index. +

    +
    pathName :insert index string
    +

    Insert the characters of string just before the character +indicated by index. Returns an empty string. +

    +
    pathName :scan option args
    +

    This command is used to implement scanning on entries. It has +two forms, depending on option: +

    +
    pathName :scan :mark x
    +

    Records x and the current view in the entry window; used in +conjunction with later scan dragto commands. Typically this +command is associated with a mouse button press in the widget. It +returns an empty string. +

    +
    pathName :scan :dragto x
    +

    This command computes the difference between its x argument +and the x argument to the last scan mark command for +the widget. It then adjusts the view left or right by 10 times the +difference in x-coordinates. This command is typically associated +with mouse motion events in the widget, to produce the effect of +dragging the entry at high speed through the window. The return +value is an empty string. +

    +
    +
    +
    pathName :select option arg
    +

    This command is used to adjust the selection within an entry. It +has several forms, depending on option: +

    +
    pathName :select :adjust index
    +

    Locate the end of the selection nearest to the character given by +index, and adjust that end of the selection to be at index +(i.e including but not going beyond index). The other +end of the selection is made the anchor point for future +select to commands. If the selection +isn’t currently in the entry, then a new selection is created to +include the characters between index and the most recent +selection anchor point, inclusive. +Returns an empty string. +

    +
    pathName :select :clear
    +

    Clear the selection if it is currently in this widget. If the +selection isn’t in this widget then the command has no effect. +Returns an empty string. +

    +
    pathName :select :from index
    +

    Set the selection anchor point to just before the character +given by index. Doesn’t change the selection. +Returns an empty string. +

    +
    pathName :select :to index
    +

    Set the selection to consist of the elements from the anchor +point to element index, inclusive. The anchor point is +determined by the most recent select from or select adjust +command in this widget. If the selection isn’t in this widget +then a new selection is created using the most recent anchor point +specified for the widget. Returns an empty string. +

    +
    +
    +
    pathName :view index
    +

    Adjust the view in the entry so that element index is +at the left edge of the window. Returns an empty string. +

    +
    +
    + +

    "Default Bindings"

    + +

    Tk automatically creates class bindings for entries that give them +the following default behavior: +

    +
      +
    • [1] +Clicking mouse button 1 in an entry positions the insertion cursor +just before the character underneath the mouse cursor and sets the +input focus to this widget. +
    • [2] +Dragging with mouse button 1 strokes out a selection between +the insertion cursor and the character under the mouse. +
    • [3] +The ends of the selection can be adjusted by dragging with mouse +button 1 while the shift key is down; this will adjust the end +of the selection that was nearest to the mouse cursor when button +1 was pressed. +
    • [4] +The view in the entry can be adjusted by dragging with mouse button 2. +
    • [5] +If the input focus is in an entry widget and characters are typed on the +keyboard, the characters are inserted just before the insertion cursor. +
    • [6] +Control-h and the Backspace and Delete keys erase the character just +before the insertion cursor. +
    • [7] +Control-w erases the word just before the insertion cursor. +
    • [8] +Control-u clears the entry to an empty string. +
    • [9] +Control-v inserts the current selection just before the insertion cursor. +
    • [10] +Control-d deletes the selected characters; an error occurs if the selection +is not in this widget. +
    + +

    If the entry is disabled using the state option, then the entry’s +view can still be adjusted and text in the entry can still be selected, +but no insertion cursor will be displayed and no text modifications will +take place. +

    +

    The behavior of entries can be changed by defining new bindings for +individual widgets or by redefining the class bindings. +

    + +

    Keywords

    +

    entry, widget +

    +
    +

    +Next: , Previous: , Up: Widgets   [Contents]

    +
    + + + + + diff --git a/info/gcl-tk/exit.html b/info/gcl-tk/exit.html new file mode 100644 index 0000000..c4c1110 --- /dev/null +++ b/info/gcl-tk/exit.html @@ -0,0 +1,86 @@ + + + + +GCL TK Manual: exit + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    +
    + +

    3.5 exit

    + +

    exit \- Exit the process +

    +

    Synopsis

    +

    exit ?returnCode? +

    + +

    Description

    + +

    Terminate the process, returning returnCode (an integer) to the +system as the exit status. +If returnCode isn’t specified then it defaults +to 0. +This command replaces the Tcl command by the same name. +It is identical to Tcl’s exit command except that +before exiting it destroys all the windows managed by +the process. +This allows various cleanup operations to be performed, such +as removing application names from the global registry of applications. +

    + +

    Keywords

    +

    exit, process +

    + + + + diff --git a/info/gcl-tk/focus.html b/info/gcl-tk/focus.html new file mode 100644 index 0000000..0ef71af --- /dev/null +++ b/info/gcl-tk/focus.html @@ -0,0 +1,182 @@ + + + + +GCL TK Manual: focus + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    +
    + +

    3.6 focus

    + +

    focus \- Direct keyboard events to a particular window +

    +

    Synopsis

    +

    focus
    +
    focus window
    +focus option ?arg arg ...? +

    + +

    Description

    + +

    The focus command is used to manage the Tk input focus. +At any given time, one window in an application is designated as +the focus window for that application; any key press or key release +events directed to any window in the application will be redirected +instead to the focus window. If there is no focus window for an +application then keyboard events are discarded. +Typically, windows that are prepared to deal with the focus +(e.g. entries and other widgets that display editable text) will +claim the focus when mouse button 1 is pressed in them. +When an application is created its main window is initially given +the focus. +

    +

    The focus command can take any of the following forms: +

    +
    +
    focus
    +

    If invoked with no arguments, focus returns the path name of +the current focus window, or none if there is no focus window. +

    +
    focus window
    +

    If invoked with a single argument consisting of a window’s path +name, focus sets the input focus to that window. +The return value is an empty string. +

    +
    focus :default ?window?
    +

    If window is specified, it becomes the default focus window +(the window that receives the focus whenever the focus window is +deleted) and the command returns an empty string. +If window isn’t specified, the command returns the path name +of the current default focus window, or none if there is no +default. +Window may be specified as none to clear its existing +value. +The default window is initially none. +

    +
    focus :none
    +

    Clears the focus window, so that keyboard input to this application +will be discarded. +

    +
    +
    + +

    "Focus Events"

    + +

    Tk’s model of the input focus is different than X’s model, and the +focus window set with the focus command is not usually the +same as the X focus window. +Tk never explicitly changes the official X focus window. +It waits for the window manager to direct the X input focus to +and from the application’s top-level windows, and it intercepts +FocusIn and FocusOut events coming from the X +server to detect these changes. +All of the focus events received from X are discarded by Tk; they +never reach the application. +Instead, Tk generates a different stream of FocusIn and +FocusOut for the application. +This means that FocusIn and +and FocusOut events seen by the application will not obey the +conventions described in the documentation for Xlib. +

    +

    Tk applications receive two kinds of FocusIn and FocusOut +events, which can be distinguished by their detail fields. +Events with a detail of NotifyAncestor are directed +to the current focus window when it becomes active or inactive. +A window is the active focus whenever two conditions are +simultaneously true: (a) the window is the focus window for its +application, and (b) some top-level window in the application has +received the X focus. +When this happens Tk generates a FocusIn event for the focus +window with detail NotifyAncestor. +When a window loses the active focus (either because the window manager +removed the focus from the application or because the focus window changed +within the application) then it receives a FocusOut event +with detail NotifyAncestor. +

    +

    The events described above are directed to the application’s focus +window regardless of which top-level window within the application +has received the focus. +The second kind of focus event is provided for applications that +need to know which particular top-level window has the X focus. +Tk generates FocusIn and FocusOut events with detail +NotifyVirtual for top-level windows whenever they receive or +lose the X focus. +These events are generated regardless of which window in the +application has the Tk input focus. +They do not imply that keystrokes will be directed to the window +that receives the event; they simply indicate which top-level +window is active as far as the window manager is concerned. +If a top-level window is also the application’s focus window, +then it will receive both NotifyVirtual and NotifyAncestor +events when it receives or loses the X focus. +

    +

    Tk does not generate the hierarchical chains of FocusIn and +FocusOut events described in the Xlib documentation (e.g. +a window can get a FocusIn or FocusOut event without +all of its ancestors getting events too). +Furthermore, the mode field in focus events is always +NotifyNormal and the only values ever present in the +detail field are NotifyAncestor and NotifyVirtual. +

    + +

    Keywords

    +

    events, focus, keyboard, top-level, window manager +

    +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    + + + + + diff --git a/info/gcl-tk/frame.html b/info/gcl-tk/frame.html new file mode 100644 index 0000000..7ea5868 --- /dev/null +++ b/info/gcl-tk/frame.html @@ -0,0 +1,192 @@ + + + + +GCL TK Manual: frame + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Widgets   [Contents]

    +
    +
    + +

    2.12 frame

    + +

    frame \- Create and manipulate frame widgets +

    +

    Synopsis

    +

    frame pathName ?:class className? ?options? +

    +

    Standard Options

    + + +
    +
    background             cursor             relief           
+borderWidth            geometry           
+
    + + +

    See options, for more information. +

    +

    Arguments for Frame

    + + +
    +
    :height
    +

    Name="height" Class="Height" +


    + +

    Specifies the desired height for the window in any of the forms +acceptable to Tk_GetPixels. +This option is only used if the :geometry option is +unspecified. +If this option is less than or equal to zero (and :geometry +is not specified) then the window will not request any size at +all. +

    +
    + + +
    +
    :width
    +

    Name="width" Class="Width" +


    + +

    Specifies the desired width for the window in any of the forms +acceptable to Tk_GetPixels. +This option is only used if the :geometry option is +unspecified. +If this option is less than or equal to zero (and :geometry +is not specified) then the window will not request any size at +all. +

    +
    + + +

    Description

    + +

    The frame command creates a new window (given by the +pathName argument) and makes it into a frame widget. +Additional +options, described above, may be specified on the command line +or in the option database +to configure aspects of the frame such as its background color +and relief. The frame command returns the +path name of the new window. +

    +

    A frame is a simple widget. Its primary purpose is to act as a +spacer or container for complex window layouts. The only features +of a frame are its background color and an optional 3-D border to make the +frame appear raised or sunken. +

    +

    In addition to the standard options listed above, a :class +option may be specified on the command line. If it is specified, then +the new widget’s class will be set to className instead of +Frame. Changing the class of a frame widget may be useful +in order to use a special class name in database options referring +to this widget and its children. Note: :class is handled +differently than other command-line options and cannot be specified +using the option database (it has to be processed +before the other options are even looked up, since the new class +name will affect the lookup of the other options). In addition, +the :class option may not be queried or changed using the +config command described below. +

    + +

    A Frame Widget’s Arguments

    + +

    The frame command creates a new Tcl command whose +name is the same as the path name of the frame’s window. This +command may be used to invoke various +operations on the widget. It has the following general form: +

    +
    +
    pathName option ?arg arg ...?
+
    + +

    PathName is the name of the command, which is the same as +the frame widget’s path name. Option and the args +determine the exact behavior of the command. The following +commands are possible for frame widgets: +

    +
    +
    pathName :configure ?option? ?value option value ...?
    +

    Query or modify the configuration options of the widget. +If no option is specified, returns a list describing all of +the available options for pathName (see Tk_ConfigureInfo for +information on the format of this list). If option is specified +with no value, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no option is specified). If +one or more option:value pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +Option may have any of the values accepted by the frame +command. +

    +
    +
    + +

    Bindings

    + +

    When a new frame is created, it has no default event bindings: +frames are not intended to be interactive. +

    + +

    Keywords

    +

    frame, widget +

    +
    +

    +Next: , Previous: , Up: Widgets   [Contents]

    +
    + + + + + diff --git a/info/gcl-tk/grab.html b/info/gcl-tk/grab.html new file mode 100644 index 0000000..66a5c69 --- /dev/null +++ b/info/gcl-tk/grab.html @@ -0,0 +1,182 @@ + + + + +GCL TK Manual: grab + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    +
    + +

    3.7 grab

    + +

    grab \- Confine pointer and keyboard events to a window sub-tree +

    +

    Synopsis

    +

    grab ?:global? window
    +grab option ?arg arg ...? +

    + +

    Description

    + +

    This command implements simple pointer and keyboard grabs for Tk. +Tk’s grabs are different than the grabs +described in the Xlib documentation. +When a grab is set for a particular window, Tk restricts all pointer +events to the grab window and its descendants in Tk’s window hierarchy. +Whenever the pointer is within the grab window’s subtree, the pointer +will behave exactly the same as if there had been no grab at all +and all events will be reported in the normal fashion. +When the pointer is outside window’s tree, button presses and +releases and +mouse motion events are reported to window, and window entry +and window exit events are ignored. +The grab subtree “owns” the pointer: +windows outside the grab subtree will be visible on the screen +but they will be insensitive until the grab is released. +The tree of windows underneath the grab window can include top-level +windows, in which case all of those top-level windows +and their descendants will continue to receive mouse events +during the grab. +

    +

    Two forms of grabs are possible: local and global. +A local grab affects only the grabbing application: events will +be reported to other applications as if the grab had never occurred. +Grabs are local by default. +A global grab locks out all applications on the screen, +so that only the given subtree of the grabbing application will be +sensitive to pointer events (mouse button presses, mouse button releases, +pointer motions, window entries, and window exits). +During global grabs the window manager will not receive pointer +events either. +

    +

    During local grabs, keyboard events (key presses and key releases) +are delivered as usual: the window +manager controls which application receives keyboard events, and +if they are sent to any window in the grabbing application then they are +redirected to the focus window. +During a global grab Tk grabs the keyboard so that all keyboard events +are always sent to the grabbing application. +The focus command is still used to determine which window in the +application receives the keyboard events. +The keyboard grab is released when the grab is released. +

    +

    Grabs apply to particular displays. If an application has windows +on multiple displays then it can establish a separate grab on each +display. +The grab on a particular display affects only the windows on +that display. +It is possible for different applications on a single display to have +simultaneous local grabs, but only one application can have a global +grab on a given display at once. +

    +

    The grab command can take any of the following forms: +

    +
    +
    grab ?:global? window
    +

    Same as grab :set, described below. +

    +
    grab :current ?window?
    +

    If window is specified, returns the name of the current grab +window in this application for window’s display, or an empty +string if there is no such window. +If window is omitted, the command returns a list whose elements +are all of the windows grabbed by this application for all displays, +or an empty string if the application has no grabs. +

    +
    grab :release window
    +

    Releases the grab on window if there is one, otherwise does +nothing. Returns an empty string. +

    +
    grab :set ?:global? window
    +

    Sets a grab on window. If :global is specified then the +grab is global, otherwise it is local. +If a grab was already in effect for this application on +window’s display then it is automatically released. +If there is already a grab on window and it has the same +global/local form as the requested grab, then the command +does nothing. Returns an empty string. +

    +
    grab :status window
    +

    Returns none if no grab is currently set on window, +local if a local grab is set on window, and +global if a global grab is set. +

    +
    +
    + +

    Bugs

    + +

    It took an incredibly complex and gross implementation to produce +the simple grab effect described above. +Given the current implementation, it isn’t safe for applications +to use the Xlib grab facilities at all except through the Tk grab +procedures. +If applications try to manipulate X’s grab mechanisms directly, +things will probably break. +

    +

    If a single process is managing several different Tk applications, +only one of those applications can have a local grab for a given +display at any given time. If the applications are in different +processes, this restriction doesn’t exist. +

    + +

    Keywords

    +

    grab, keyboard events, pointer events, window +

    +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    + + + + + diff --git a/info/gcl-tk/index.html b/info/gcl-tk/index.html new file mode 100644 index 0000000..80b6dd1 --- /dev/null +++ b/info/gcl-tk/index.html @@ -0,0 +1,191 @@ + + + + +GCL TK Manual: Top + + + + + + + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: (dir)   [Contents]

    +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    • General:   +
    • Widgets:   +
    • Control:   +
    + — The Detailed Node Listing —
+
+General
+
+
    • Introduction:   +
    • Getting Started:   +
    • Common Features of Widgets:   +
    • Return Values:   +
    • Argument Lists:   +
    • Lisp Functions Invoked from Graphics:   +
    • Linked Variables:   +
    • tkconnect:   +
    +Widgets
+
+
    • button:   +
    • listbox:   +
    • scale:   +
    • canvas:   +
    • menu:   +
    • scrollbar:   +
    • checkbutton:   +
    • menubutton:   +
    • text:   +
    • entry:   +
    • message:   +
    • frame:   +
    • label:   +
    • radiobutton:   +
    • toplevel:   +
    +Control
+
+
    • after:   +
    • bind:   +
    • destroy:   +
    • tk-dialog:   +
    • exit:   +
    • focus:   +
    • grab:   +
    • tk-listbox-single-select:   +
    • lower:   +
    • tk-menu-bar:   +
    • option:   +
    • options:   +
    • pack-old:   +
    • pack:   +
    • place:   +
    • raise:   +
    • selection:   +
    • send:   +
    • tk:   +
    • tkerror:   +
    • tkvars:   +
    • tkwait:   +
    • update:   +
    • winfo:   +
    • wm:   +
    + + +
    +
    +

    +Next: , Previous: , Up: (dir)   [Contents]

    +
    + + + + + diff --git a/info/gcl-tk/label.html b/info/gcl-tk/label.html new file mode 100644 index 0000000..a921dcb --- /dev/null +++ b/info/gcl-tk/label.html @@ -0,0 +1,179 @@ + + + + +GCL TK Manual: label + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Widgets   [Contents]

    +
    +
    + +

    2.13 label

    + +

    label \- Create and manipulate label widgets +

    +

    Synopsis

    +

    label pathName ?options? +

    +

    Standard Options

    + + +
    +
    anchor           borderWidth     foreground     relief           
+background       cursor          padX           text             
+bitmap           font            padY           textVariable     
+
    + + +

    See options, for more information. +

    +

    Arguments for Label

    + + +
    +
    :height
    +

    Name="height" Class="Height" +


    + +

    Specifies a desired height for the label. +If a bitmap is being displayed in the label then the value is in +screen units (i.e. any of the forms acceptable to Tk_GetPixels); +for text it is in lines of text. +If this option isn’t specified, the label’s desired height is computed +from the size of the bitmap or text being displayed in it. +

    +
    + + +
    +
    :width
    +

    Name="width" Class="Width" +


    + +

    Specifies a desired width for the label. +If a bitmap is being displayed in the label then the value is in +screen units (i.e. any of the forms acceptable to Tk_GetPixels); +for text it is in characters. +If this option isn’t specified, the label’s desired width is computed +from the size of the bitmap or text being displayed in it. +

    +
    + + +

    Description

    + +

    The label command creates a new window (given by the +pathName argument) and makes it into a label widget. +Additional +options, described above, may be specified on the command line +or in the option database +to configure aspects of the label such as its colors, font, +text, and initial relief. The label command returns its +pathName argument. At the time this command is invoked, +there must not exist a window named pathName, but +pathName’s parent must exist. +

    +

    A label is a widget +that displays a textual string or bitmap. +The label can be manipulated in a few simple ways, such as +changing its relief or text, using the commands described below. +

    + +

    A Label Widget’s Arguments

    + +

    The label command creates a new Tcl command whose +name is pathName. This +command may be used to invoke various +operations on the widget. It has the following general form: +

    +
    +
    pathName option ?arg arg ...?
+
    + +

    Option and the args +determine the exact behavior of the command. The following +commands are possible for label widgets: +

    +
    +
    pathName :configure ?option? ?value option value ...?
    +

    Query or modify the configuration options of the widget. +If no option is specified, returns a list describing all of +the available options for pathName (see Tk_ConfigureInfo for +information on the format of this list). If option is specified +with no value, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no option is specified). If +one or more option:value pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +Option may have any of the values accepted by the label +command. +

    +
    +
    + +

    Bindings

    + +

    When a new label is created, it has no default event bindings: +labels are not intended to be interactive. +

    + +

    Keywords

    +

    label, widget +

    +
    +

    +Next: , Previous: , Up: Widgets   [Contents]

    +
    + + + + + diff --git a/info/gcl-tk/listbox.html b/info/gcl-tk/listbox.html new file mode 100644 index 0000000..0c50367 --- /dev/null +++ b/info/gcl-tk/listbox.html @@ -0,0 +1,289 @@ + + + + +GCL TK Manual: listbox + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Widgets   [Contents]

    +
    +
    + +

    2.2 listbox

    + +

    listbox \- Create and manipulate listbox widgets +

    +

    Synopsis

    +

    listbox pathName ?options? +

    +

    Standard Options

    + + +
    +
    background       foreground  selectBackground   xScrollCommand  
+borderWidth      font        selectBorderWidth  yScrollCommand  
+cursor           geometry    selectForeground   
+exportSelection  relief      setGrid            
+
    + + +

    See options, for more information. +

    +

    Arguments for Listbox

    + + +

    None. +

    + +

    Description

    + +

    The listbox command creates a new window (given by the +pathName argument) and makes it into a listbox widget. +Additional +options, described above, may be specified on the command line +or in the option database +to configure aspects of the listbox such as its colors, font, +text, and relief. The listbox command returns its +pathName argument. At the time this command is invoked, +there must not exist a window named pathName, but +pathName’s parent must exist. +

    +

    A listbox is a widget that displays a list of strings, one per line. +When first created, a new listbox has no elements in its list. +Elements may be added or deleted using widget commands described +below. In addition, one or more elements may be selected as described +below. +If a listbox is exporting its selection (see exportSelection +option), then it will observe the standard X11 protocols +for handling the selection; listbox selections are available +as type STRING, consisting of a Tcl list with one entry +for each selected element. +

    +

    For large lists only a subset of the list elements will be +displayed in the listbox window at once; commands described below +may be used to change the view in the window. Listboxes allow +scrolling in both directions using the standard xScrollCommand +and yScrollCommand options. +They also support scanning, as described below. +

    + +

    A Listbox’s Arguments

    + +

    The listbox command creates a new Tcl command whose +name is pathName. This +command may be used to invoke various +operations on the widget. It has the following general form: +

    +
    +
    pathName option ?arg arg ...?
+
    + +

    Option and the args +determine the exact behavior of the command. The following +commands are possible for listbox widgets: +

    +
    +
    pathName :configure ?option? ?value option value ...?
    +

    Query or modify the configuration options of the widget. +If no option is specified, returns a list describing all of +the available options for pathName (see Tk_ConfigureInfo for +information on the format of this list). If option is specified +with no value, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no option is specified). If +one or more option:value pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +Option may have any of the values accepted by the listbox +command. +

    +
    pathName :curselection
    +

    Returns a list containing the indices of +all of the elements in the listbox that are currently selected. +If there are no elements selected in the listbox then an empty +string is returned. +

    +
    pathName :delete first ?last?
    +

    Delete one or more elements of the listbox. First and last +give the integer indices of the first and last elements in the range +to be deleted. If last isn’t specified it defaults to +first, i.e. a single element is deleted. An index of +0 corresponds to the first element in the listbox. Either +first or last may be specified as end, in which +case it refers to the last element of the listbox. This command +returns an empty string +

    +
    pathName :get index
    +

    Return the contents of the listbox element indicated by index. +Index must be a non-negative integer (0 corresponds to +the first element in the listbox), or it may also be specified as +end to indicate the last element in the listbox. +

    +
    pathName :insert index ?element element ...?
    +

    Insert zero or more new elements in the list just before the +element given by index. If index is specified as +end then the new elements are added to the end of the +list. Returns an empty string. +

    +
    pathName :nearest y
    +

    Given a y-coordinate within the listbox window, this command returns +the index of the (visible) listbox element nearest to that y-coordinate. +

    +
    pathName :scan option args
    +

    This command is used to implement scanning on listboxes. It has +two forms, depending on option: +

    +
    pathName :scan :mark x y
    +

    Records x and y and the current view in the listbox +window; used in conjunction with later scan dragto commands. +Typically this command is associated with a mouse button press in +the widget. It returns an empty string. +

    +
    pathName :scan :dragto x y.
    +

    This command computes the difference between its x and y +arguments and the x and y arguments to the last +scan mark command for the widget. +It then adjusts the view by 10 times the +difference in coordinates. This command is typically associated +with mouse motion events in the widget, to produce the effect of +dragging the list at high speed through the window. The return +value is an empty string. +

    +
    +
    +
    pathName :select option arg
    +

    This command is used to adjust the selection within a listbox. It +has several forms, depending on option. In all of the forms +the index end refers to the last element in the listbox. +

    +
    pathName :select :adjust index
    +

    Locate the end of the selection nearest to the element given by +index, and adjust that end of the selection to be at index +(i.e including but not going beyond index). The other +end of the selection is made the anchor point for future +select to commands. If the selection +isn’t currently in the listbox, then this command is identical to +the select from widget command. +Returns an empty string. +

    +
    pathName :select :clear
    +

    If the selection is in this listbox then it is cleared so that +none of the listbox’s elements are selected anymore. +

    +
    pathName :select :from index
    +

    Set the selection to consist of element index, and make +index the anchor point for future select to widget +commands. Returns an empty string. +

    +
    pathName :select :to index
    +

    Set the selection to consist of the elements from the anchor +point to element index, inclusive. The anchor point is +determined by the most recent select from or select adjust +command in this widget. If the selection isn’t in this widget, +this command is identical to select from. +Returns an empty string. +

    +
    + +
    +
    pathName :size
    +

    Returns a decimal string indicating the total number of elements +in the listbox. +

    +
    pathName :xview index
    +

    Adjust the view in the listbox so that character position index +is displayed at the left edge of the widget. +Returns an empty string. +

    +
    pathName :yview index
    +

    Adjust the view in the listbox so that element index is +displayed at the top of the widget. +If index is specified as end it indicates the last +element of the listbox. Returns an empty string. +

    +
    +
    + +

    "Default Bindings"

    + +

    Tk automatically creates class bindings for listboxes that give them +the following default behavior: +

      +
    • [1] +When button 1 is pressed over a listbox, the element underneath the +mouse cursor is selected. The mouse can be dragged to select a +range of elements. +
    • [2] +The ends of the selection can be adjusted by dragging with mouse +button 1 while the shift key is down; this will adjust the end +of the selection that was nearest to the mouse cursor when button +1 was pressed. +
    • [3] +The view in the listbox can be adjusted by dragging with mouse button 2. +
    + +

    The behavior of listboxes can be changed by defining new bindings for +individual widgets or by redefining the class bindings. +In addition, the procedure tk_listboxSingleSelect may be +invoked to change listbox behavior so that only a single element +may be selected at once. +

    + +

    Keywords

    +

    listbox, widget +

    +
    +

    +Next: , Previous: , Up: Widgets   [Contents]

    +
    + + + + + diff --git a/info/gcl-tk/lower.html b/info/gcl-tk/lower.html new file mode 100644 index 0000000..113ff57 --- /dev/null +++ b/info/gcl-tk/lower.html @@ -0,0 +1,87 @@ + + + + +GCL TK Manual: lower + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    +
    + +

    3.9 lower

    + +

    lower \- Change a window’s position in the stacking order +

    +

    Synopsis

    +

    lower window ?belowThis? +

    + +

    Description

    + +

    If the belowThis argument is omitted then the command lowers +window so that it is below all of its siblings in the stacking +order (it will be obscured by any siblings that overlap it and +will not obscure any siblings). +If belowThis is specified then it must be the path name of +a window that is either a sibling of window or the descendant +of a sibling of window. +In this case the lower command will insert +window into the stacking order just below belowThis +(or the ancestor of belowThis that is a sibling of window); +this could end up either raising or lowering window. +

    + +

    Keywords

    +

    lower, obscure, stacking order +

    + + + + diff --git a/info/gcl-tk/menu.html b/info/gcl-tk/menu.html new file mode 100644 index 0000000..713dbd6 --- /dev/null +++ b/info/gcl-tk/menu.html @@ -0,0 +1,554 @@ + + + + +GCL TK Manual: menu + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Widgets   [Contents]

    +
    +
    + +

    2.5 menu

    + +

    menu \- Create and manipulate menu widgets +

    +

    Synopsis

    +

    menu pathName ?options? +

    +

    Standard Options

    + + +
    +
    activeBackground       background       disabledForeground      
+activeBorderWidth      borderWidth      font                    
+activeForeground       cursor           foreground              
+
    + + +

    See options, for more information. +

    +

    Arguments for Menu

    + + +
    +
    :postcommand
    +

    Name="postCommand" Class="Command" +


    + +

    If this option is specified then it provides a Tcl command to execute +each time the menu is posted. The command is invoked by the post +widget command before posting the menu. +

    +
    + + +
    +
    :selector
    +

    Name="selector" Class="Foreground" +


    + +

    For menu entries that are check buttons or radio buttons, this option +specifies the color to display in the selector when the check button +or radio button is selected. +

    +
    + + +

    Introduction

    + +

    The menu command creates a new top-level window (given +by the pathName argument) and makes it into a menu widget. +Additional +options, described above, may be specified on the command line +or in the option database +to configure aspects of the menu such as its colors and font. +The menu command returns its +pathName argument. At the time this command is invoked, +there must not exist a window named pathName, but +pathName’s parent must exist. +

    +

    A menu is a widget that displays a collection of one-line entries arranged +in a column. There exist several different types of entries, +each with different properties. Entries of different types may be +combined in a single menu. Menu entries are not the same as +entry widgets. In fact, menu entries are not even distinct widgets; +the entire menu is one widget. +

    +

    Menu entries are displayed with up to three +separate fields. The main field is a label in the form of text or +a bitmap, which is determined by the :label or :bitmap +option for the entry. +If the :accelerator option is specified for an entry then a second +textual field is displayed to the right of the label. The accelerator +typically describes a keystroke sequence that may be typed in the +application to cause the same result as invoking the menu entry. +The third field is a selector. The selector is present only for +check-button or radio-button entries. It indicates whether the entry +is selected or not, and is displayed to the left of the entry’s +string. +

    +

    In normal use, an entry becomes active (displays itself differently) +whenever the mouse pointer is over the entry. If a mouse +button is released over the entry then the entry is invoked. +The effect of invocation is different for each type of entry; +these effects are described below in the sections on individual +entries. +

    +

    Entries may be disabled, which causes their labels +and accelerators to be displayed +with dimmer colors. A disabled entry cannot be activated or invoked. +Disabled entries may be re-enabled, at which point it becomes +possible to activate and invoke them again. +

    + +

    Command Entries

    + +

    The most common kind of menu entry is a command entry, which +behaves much like a button widget. When a command entry is +invoked, a Tcl command is executed. The Tcl +command is specified with the :command option. +

    + +

    Separator Entries

    + +

    A separator is an entry that is displayed as a horizontal dividing +line. A separator may not be activated or invoked, and it has +no behavior other than its display appearance. +

    + +

    Check-Button Entries

    + +

    A check-button menu entry behaves much like a check-button widget. +When it is invoked it toggles back and forth between the selected +and deselected states. When the entry is selected, a particular +value is stored in a particular global variable (as determined by +the :onvalue and :variable options for the entry); when +the entry is deselected another value (determined by the +:offvalue option) is stored in the global variable. +A selector box is displayed to the left of the label in a check-button +entry. If the entry is selected then the box’s center is displayed +in the color given by the selector option for the menu; +otherwise the box’s center is displayed in the background color for +the menu. If a :command option is specified for a check-button +entry, then its value is evaluated as a Tcl command each time the entry +is invoked; this happens after toggling the entry’s +selected state. +

    + +

    Radio-Button Entries

    + +

    A radio-button menu entry behaves much like a radio-button widget. +Radio-button entries are organized in groups of which only one +entry may be selected at a time. Whenever a particular entry +becomes selected it stores a particular value into a particular +global variable (as determined by the :value and +:variable options for the entry). This action +causes any previously-selected entry in the same group +to deselect itself. +Once an entry has become selected, any change to the entry’s +associated variable will cause the entry to deselect itself. +Grouping of radio-button entries is determined by their +associated variables: if two entries have the same associated +variable then they are in the same group. +A selector diamond is displayed to the left of the label in each +radio-button entry. If the entry is selected then the diamond’s +center is displayed in the color given by the selector option +for the menu; +otherwise the diamond’s center is displayed in the background color for +the menu. If a :command option is specified for a radio-button +entry, then its value is evaluated as a Tcl command each time the entry +is invoked; this happens after selecting the entry. +

    + +

    Cascade Entries

    + +

    A cascade entry is one with an associated menu (determined +by the :menu option). Cascade entries allow the construction +of cascading menus. When the entry is activated, the +associated menu is posted just to the right of the entry; +that menu remains posted until the higher-level menu is unposted or +until some other entry is activated in the higher-level menu. +The associated menu should normally be a child of the menu containing +the cascade entry, in order for menu traversal to work correctly. +

    +

    A cascade entry posts its associated menu by invoking a +Tcl command of the form +

    +
    +
    menu :post x y
    +
    + + +

    where menu is the path name of the associated menu, x +and y are the root-window coordinates of the upper-right +corner of the cascade entry, and group is the name of the +menu’s group (as determined in its last post widget command). +The lower-level menu is unposted by executing a Tcl command with +the form +

    +
    +
    menu:unpost
    +

    where menu is the name of the associated menu. +

    +
    + +

    If a :command option is specified for a cascade entry then it is +evaluated as a Tcl command each time the associated menu is posted (the +evaluation occurs before the menu is posted). +

    + +

    A Menu Widget’s Arguments

    + +

    The menu command creates a new Tcl command whose +name is pathName. This +command may be used to invoke various +operations on the widget. It has the following general form: +

    +
    +
    pathName option ?arg arg ...?
    +

    Option and the args +determine the exact behavior of the command. +

    +
    + +

    Many of the widget commands for a menu take as one argument an +indicator of which entry of the menu to operate on. These +indicators are called indexes and may be specified in +any of the following forms: +

    +
    +
    number
    +

    Specifies the entry numerically, where 0 corresponds +to the top-most entry of the menu, 1 to the entry below it, and +so on. +

    +
    active
    +

    Indicates the entry that is currently active. If no entry is +active then this form is equivalent to none. This form may +not be abbreviated. +

    +
    last
    +

    Indicates the bottommost entry in the menu. If there are no +entries in the menu then this form is equivalent to none. +This form may not be abbreviated. +

    +
    none
    +

    Indicates “no entry at all”; this is used most commonly with +the activate option to deactivate all the entries in the +menu. In most cases the specification of none causes +nothing to happen in the widget command. +This form may not be abbreviated. +

    +
    @number
    +

    In this form, number is treated as a y-coordinate in the +menu’s window; the entry spanning that y-coordinate is used. +For example, “@0” indicates the top-most entry in the +window. If number is outside the range of the window +then this form is equivalent to none. +

    +
    pattern
    +

    If the index doesn’t satisfy one of the above forms then this +form is used. Pattern is pattern-matched against the label of +each entry in the menu, in order from the top down, until a +matching entry is found. The rules of Tcl_StringMatch +are used. +

    +

    The following widget commands are possible for menu widgets: +

    +
    pathName :activate index
    +

    Change the state of the entry indicated by index to active +and redisplay it using its active colors. +Any previously-active entry is deactivated. If index +is specified as none, or if the specified entry is +disabled, then the menu ends up with no active entry. +Returns an empty string. +

    +
    pathName :add type ?option value option value ...?
    +

    Add a new entry to the bottom of the menu. The new entry’s type +is given by type and must be one of cascade, +checkbutton, command, radiobutton, or separator, +or a unique abbreviation of one of the above. If additional arguments +are present, they specify any of the following options: +

    +
    +
    :activebackground value
    +

    Specifies a background color to use for displaying this entry when it +is active. +If this option is specified as an empty string (the default), then the +activeBackground option for the overall menu is used. +This option is not available for separator entries. +

    +
    :accelerator value
    +

    Specifies a string to display at the right side of the menu entry. +Normally describes an accelerator keystroke sequence that may be +typed to invoke the same function as the menu entry. This option +is not available for separator entries. +

    +
    :background value
    +

    Specifies a background color to use for displaying this entry when it +is in the normal state (neither active nor disabled). +If this option is specified as an empty string (the default), then the +background option for the overall menu is used. +This option is not available for separator entries. +

    +
    :bitmap value
    +

    Specifies a bitmap to display in the menu instead of a textual +label, in any of the forms accepted by Tk_GetBitmap. +This option overrides the :label option but may be reset +to an empty string to enable a textual label to be displayed. +This option is not available for separator entries. +

    +
    :command value
    +

    For command, checkbutton, and radiobutton entries, specifies a +Tcl command to execute when the menu entry is invoked. +For cascade entries, specifies a Tcl command to execute +when the entry is activated (i.e. just before its submenu is +posted). +Not available for separator entries. +

    +
    :font value
    +

    Specifies the font to use when drawing the label or accelerator +string in this entry. +If this option is specified as an empty string (the default) then +the font option for the overall menu is used. +This option is not available for separator entries. +

    +
    :label value
    +

    Specifies a string to display as an identifying label in the menu +entry. Not available for separator entries. +

    +
    :menu value
    +

    Available only for cascade entries. Specifies the path name of +the menu associated with this entry. +

    +
    :offvalue value
    +

    Available only for check-button entries. Specifies the value to +store in the entry’s associated variable when the entry is +deselected. +

    +
    :onvalue value
    +

    Available only for check-button entries. Specifies the value to +store in the entry’s associated variable when the entry is selected. +

    +
    :state value
    +

    Specifies one of three states for the entry: normal, active, +or disabled. In normal state the entry is displayed using the +foreground option for the menu and the background +option from the entry or the menu. +The active state is typically used when the pointer is over the entry. +In active state the entry is displayed using the activeForeground +option for the menu along with the activebackground option from +the entry. +Disabled state means that the entry is insensitive: it doesn’t activate +and doesn’t respond to mouse button presses or releases. +In this state the entry is displayed according to the +disabledForeground option for the menu and the +background option from the entry. +This option is not available for separator entries. +

    +
    :underline value
    +

    Specifies the integer index of a character to underline in the entry. +This option is typically used to indicate keyboard traversal characters. +0 corresponds to the first character of the text displayed in the entry, +1 to the next character, and so on. +If a bitmap is displayed in the entry then this option is ignored. +This option is not available for separator entries. +

    +
    :value value
    +

    Available only for radio-button entries. Specifies the value to +store in the entry’s associated variable when the entry is selected. +

    +
    :variable value
    +

    Available only for check-button and radio-button entries. Specifies +the name of a global value to set when the entry is selected. +For check-button entries the variable is also set when the entry +is deselected. For radio-button entries, changing the variable +causes the currently-selected entry to deselect itself. +

    +
    +
    +
    + +

    The add widget command returns an empty string. +

    + +
    +
    pathName :configure ?option? ?value option value ...?
    +

    Query or modify the configuration options of the widget. +If no option is specified, returns a list describing all of +the available options for pathName (see Tk_ConfigureInfo for +information on the format of this list). If option is specified +with no value, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no option is specified). If +one or more option:value pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +Option may have any of the values accepted by the menu +command. +

    +
    pathName :delete index1 ?index2?
    +

    Delete all of the menu entries between index1 and +index2 inclusive. +If index2 is omitted then it defaults to index1. +Returns an empty string. +

    +
    pathName :disable index
    +

    Change the state of the entry given by index to disabled +and redisplay the entry using its disabled colors. +Returns an empty string. +This command is obsolete and will eventually be removed; +use “pathName :entryconfigure index :state disabled” instead. +

    +
    pathName :enable index
    +

    Change the state of the entry given by index to normal +and redisplay the entry using its normal colors. +Returns an empty string. +This command is obsolete and will eventually be removed; +use “pathName :entryconfigure index :state normal” instead. +

    +
    pathName :entryconfigure index ?options?
    +

    This command is similar to the configure command, except that +it applies to the options for an individual entry, whereas configure +applies to the options for the menu as a whole. +Options may have any of the values accepted by the add +widget command. If options are specified, options are modified +as indicated +in the command and the command returns an empty string. +If no options are specified, returns a list describing +the current options for entry index (see Tk_ConfigureInfo for +information on the format of this list). +

    +
    pathName :index index
    +

    Returns the numerical index corresponding to index, or +none if index was specified as none. +

    +
    pathName :invoke index
    +

    Invoke the action of the menu entry. See the sections on the +individual entries above for details on what happens. If the +menu entry is disabled then nothing happens. If the +entry has a command associated with it then the result of that +command is returned as the result of the invoke widget +command. Otherwise the result is an empty string. Note: invoking +a menu entry does not automatically unpost the menu. Normally +the associated menubutton will take care of unposting the menu. +

    +
    pathName :post x y
    +

    Arrange for the menu to be displayed on the screen at the root-window +coordinates given by x and y. These coordinates are +adjusted if necessary to guarantee that the entire menu is visible on +the screen. This command normally returns an empty string. +If the :postcommand option has been specified, then its value is +executed as a Tcl script before posting the menu and the result of +that script is returned as the result of the post widget +command. +If an error returns while executing the command, then the error is +returned without posting the menu. +

    +
    pathName :unpost
    +

    Unmap the window so that it is no longer displayed. If a +lower-level cascaded menu is posted, unpost that menu. Returns an +empty string. +

    +
    pathName :yposition index
    +

    Returns a decimal string giving the y-coordinate within the menu +window of the topmost pixel in the entry specified by index. +

    + +
    +
    + +

    Default Bindings

    + + +

    Tk automatically creates class bindings for menus that give them +the following default behavior: +

      +
    • [1] +When the mouse cursor enters a menu, the entry underneath the mouse +cursor is activated; as the mouse moves around the menu, the active +entry changes to track the mouse. +
    • [2] +When button 1 is released over a menu, the active entry (if any) is invoked. +
    • [3] +A menu can be repositioned on the screen by dragging it with mouse +button 2. +
    • [4] +A number of other bindings are created to support keyboard menu traversal. +See the manual entry for tk_bindForTraversal for details on these +bindings. +
    + +

    Disabled menu entries are non-responsive: they don’t activate and +ignore mouse button presses and releases. +

    +

    The behavior of menus can be changed by defining new bindings for +individual widgets or by redefining the class bindings. +

    + +

    Bugs

    + +

    At present it isn’t possible to use the +option database to specify values for the options to individual +entries. +

    + +

    Keywords

    +

    menu, widget +

    +
    +

    +Next: , Previous: , Up: Widgets   [Contents]

    +
    + + + + + diff --git a/info/gcl-tk/menubutton.html b/info/gcl-tk/menubutton.html new file mode 100644 index 0000000..3459da1 --- /dev/null +++ b/info/gcl-tk/menubutton.html @@ -0,0 +1,281 @@ + + + + +GCL TK Manual: menubutton + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Widgets   [Contents]

    +
    +
    + +

    2.8 menubutton

    + +

    menubutton \- Create and manipulate menubutton widgets +

    +

    Synopsis

    +

    menubutton pathName ?options? +

    +

    Standard Options

    + + +
    +
    activeBackground  bitmap              font        relief        
+activeForeground  borderWidth         foreground  text          
+anchor            cursor              padX        textVariable  
+background        disabledForeground  padY        underline     
+
    + + +

    See options, for more information. +

    +

    Arguments for Menubutton

    + + +
    +
    :height
    +

    Name="height" Class="Height" +


    + +

    Specifies a desired height for the menu button. +If a bitmap is being displayed in the menu button then the value is in +screen units (i.e. any of the forms acceptable to Tk_GetPixels); +for text it is in lines of text. +If this option isn’t specified, the menu button’s desired height is computed +from the size of the bitmap or text being displayed in it. +

    +
    + + +
    +
    :menu
    +

    Name="menu" Class="MenuName" +


    + +

    Specifies the path name of the menu associated with this menubutton. +The menu must be a descendant of the menubutton in order for normal pull-down +operation to work via the mouse. +

    +
    + + +
    +
    :state
    +

    Name="state" Class="State" +


    + +

    Specifies one of three states for the menu button: normal, active, +or disabled. In normal state the menu button is displayed using the +foreground and background options. The active state is +typically used when the pointer is over the menu button. In active state +the menu button is displayed using the activeForeground and +activeBackground options. Disabled state means that the menu button +is insensitive: it doesn’t activate and doesn’t respond to mouse +button presses. In this state the disabledForeground and +background options determine how the button is displayed. +

    +
    + + +
    +
    :width
    +

    Name="width" Class="Width" +


    + +

    Specifies a desired width for the menu button. +If a bitmap is being displayed in the menu button then the value is in +screen units (i.e. any of the forms acceptable to Tk_GetPixels); +for text it is in characters. +If this option isn’t specified, the menu button’s desired width is computed +from the size of the bitmap or text being displayed in it. +

    +
    + + +

    Introduction

    + +

    The menubutton command creates a new window (given by the +pathName argument) and makes it into a menubutton widget. +Additional +options, described above, may be specified on the command line +or in the option database +to configure aspects of the menubutton such as its colors, font, +text, and initial relief. The menubutton command returns its +pathName argument. At the time this command is invoked, +there must not exist a window named pathName, but +pathName’s parent must exist. +

    +

    A menubutton is a widget that displays a +textual string or bitmap +and is associated with a menu widget. In normal usage, pressing +mouse button 1 over the menubutton causes the associated menu to +be posted just underneath the menubutton. If the mouse is moved over +the menu before releasing the mouse button, the button release +causes the underlying menu entry to be invoked. When the button +is released, the menu is unposted. +

    +

    Menubuttons are typically organized into groups called menu bars +that allow scanning: +if the mouse button is pressed over one menubutton (causing it +to post its menu) and the mouse is moved over another menubutton +in the same menu bar without releasing the mouse button, then the +menu of the first menubutton is unposted and the menu of the +new menubutton is posted instead. +The tk-menu-bar procedure is used to set up menu bars for +scanning; see that procedure for more details. +

    + +

    A Menubutton Widget’s Arguments

    + +

    The menubutton command creates a new Tcl command whose +name is pathName. This +command may be used to invoke various +operations on the widget. It has the following general form: +

    +
    +
    pathName option ?arg arg ...?
+
    + +

    Option and the args +determine the exact behavior of the command. The following +commands are possible for menubutton widgets: +

    +
    +
    pathName :activate
    +

    Change the menu button’s state to active and redisplay the menu +button using its active foreground and background colors instead of normal +colors. +The command returns an empty string. +This command is ignored if the menu button’s state is disabled. +This command is obsolete and will eventually be removed; +use “pathName :configure :state active” instead. +

    +
    pathName :configure ?option? ?value option value ...?
    +

    Query or modify the configuration options of the widget. +If no option is specified, returns a list describing all of +the available options for pathName (see Tk_ConfigureInfo for +information on the format of this list). If option is specified +with no value, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no option is specified). If +one or more option:value pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +Option may have any of the values accepted by the menubutton +command. +

    +
    pathName :deactivate
    +

    Change the menu button’s state to normal and redisplay the menu +button using its normal foreground and background colors. +The command returns an empty string. +This command is ignored if the menu button’s state is disabled. +This command is obsolete and will eventually be removed; +use “pathName :configure :state normal” instead. +

    +
    +
    + +

    "Default Bindings"

    + + +

    Tk automatically creates class bindings for menu buttons that give them +the following default behavior: +

      +
    • [1] +A menu button activates whenever the mouse passes over it and deactivates +whenever the mouse leaves it. +
    • [2] +A menu button’s relief is changed to raised whenever mouse button 1 is +pressed over it, and the relief is restored to its original value +when button 1 is later released or the mouse is dragged into another +menu button in the same menu bar. +
    • [3] +When mouse button 1 is pressed over a menu button, or when the mouse +is dragged into a menu button with mouse button 1 pressed, the associated +menu is posted; the mouse can be dragged across the menu and released +over an entry in the menu to invoke that entry. The menu is unposted +when button 1 is released outside either the menu or the menu button. +The menu is also unposted when the mouse is dragged into another +menu button in the same menu bar. +
    • [4] +If mouse button 1 is pressed and released within the menu button, +then the menu stays posted and keyboard traversal is possible as +described in the manual entry for tk-menu-bar. +
    • [5] +Menubuttons may also be posted by typing characters on the keyboard. +See the manual entry for tk-menu-bar for full details on keyboard +menu traversal. +
    • [6] +If mouse button 2 is pressed over a menu button then the associated +menu is posted and also torn off: it can then be dragged around on +the screen with button 2 and the menu will not automatically unpost when +entries in it are invoked. +To close a torn off menu, click mouse button 1 over the associated +menu button. +
    + +

    If the menu button’s state is disabled then none of the above +actions occur: the menu button is completely non-responsive. +

    +

    The behavior of menu buttons can be changed by defining new bindings for +individual widgets or by redefining the class bindings. +

    + +

    Keywords

    +

    menubutton, widget +

    +
    +

    +Next: , Previous: , Up: Widgets   [Contents]

    +
    + + + + + diff --git a/info/gcl-tk/message.html b/info/gcl-tk/message.html new file mode 100644 index 0000000..27957db --- /dev/null +++ b/info/gcl-tk/message.html @@ -0,0 +1,237 @@ + + + + +GCL TK Manual: message + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Widgets   [Contents]

    +
    +
    + +

    2.11 message

    + +

    message \- Create and manipulate message widgets +

    +

    Synopsis

    +

    message pathName ?options? +

    +

    Standard Options

    + + +
    +
    anchor            cursor          padX        text              
+background        font            padY        textVariable      
+borderWidth       foreground      relief      width             
+
    + + +

    See options, for more information. +

    +

    Arguments for Message

    + + +
    +
    :aspect
    +

    Name="aspect" Class="Aspect" +


    + +

    Specifies a non-negative integer value indicating desired +aspect ratio for the text. The aspect ratio is specified as +100*width/height. 100 means the text should +be as wide as it is tall, 200 means the text should +be twice as wide as it is tall, 50 means the text should +be twice as tall as it is wide, and so on. +Used to choose line length for text if width option +isn’t specified. +Defaults to 150. +

    +
    + + +
    +
    :justify
    +

    Name="justify" Class="Justify" +


    + +

    Specifies how to justify lines of text. +Must be one of left, center, or right. Defaults +to left. +This option works together with the anchor, aspect, +padX, padY, and width options to provide a variety +of arrangements of the text within the window. +The aspect and width options determine the amount of +screen space needed to display the text. +The anchor, padX, and padY options determine where this +rectangular area is displayed within the widget’s window, and the +justify option determines how each line is displayed within that +rectangular region. +For example, suppose anchor is e and justify is +left, and that the message window is much larger than needed +for the text. +The the text will displayed so that the left edges of all the lines +line up and the right edge of the longest line is padX from +the right side of the window; the entire text block will be centered +in the vertical span of the window. +

    +
    + + +
    +
    :width
    +

    Name="width" Class="Width" +


    + +

    Specifies the length of lines in the window. +The value may have any of the forms acceptable to Tk_GetPixels. +If this option has a value greater than zero then the aspect +option is ignored and the width option determines the line +length. +If this option has a value less than or equal to zero, then +the aspect option determines the line length. +

    +
    + + +

    Description

    + +

    The message command creates a new window (given by the +pathName argument) and makes it into a message widget. +Additional +options, described above, may be specified on the command line +or in the option database +to configure aspects of the message such as its colors, font, +text, and initial relief. The message command returns its +pathName argument. At the time this command is invoked, +there must not exist a window named pathName, but +pathName’s parent must exist. +

    +

    A message is a widget that displays a textual string. A message +widget has three special features. First, it breaks up +its string into lines in order to produce a given aspect ratio +for the window. The line breaks are chosen at word boundaries +wherever possible (if not even a single word would fit on a +line, then the word will be split across lines). Newline characters +in the string will force line breaks; they can be used, for example, +to leave blank lines in the display. +

    +

    The second feature of a message widget is justification. The text +may be displayed left-justified (each line starts at the left side of +the window), centered on a line-by-line basis, or right-justified +(each line ends at the right side of the window). +

    +

    The third feature of a message widget is that it handles control +characters and non-printing characters specially. Tab characters +are replaced with enough blank space to line up on the next +8-character boundary. Newlines cause line breaks. Other control +characters (ASCII code less than 0x20) and characters not defined +in the font are displayed as a four-character sequence \fB\exhh where +hh is the two-digit hexadecimal number corresponding to +the character. In the unusual case where the font doesn’t contain +all of the characters in “0123456789abcdef\ex” then control +characters and undefined characters are not displayed at all. +

    + +

    A Message Widget’s Arguments

    + +

    The message command creates a new Tcl command whose +name is pathName. This +command may be used to invoke various +operations on the widget. It has the following general form: +

    +
    +
    pathName option ?arg arg ...?
+
    + +

    Option and the args +determine the exact behavior of the command. The following +commands are possible for message widgets: +

    +
    +
    pathName :configure ?option? ?value option value ...?
    +

    Query or modify the configuration options of the widget. +If no option is specified, returns a list describing all of +the available options for pathName (see Tk_ConfigureInfo for +information on the format of this list). If option is specified +with no value, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no option is specified). If +one or more option:value pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +Option may have any of the values accepted by the message +command. +

    +
    +
    + +

    "Default Bindings"

    + +

    When a new message is created, it has no default event bindings: +messages are intended for output purposes only. +

    + +

    Bugs

    + +

    Tabs don’t work very well with text that is centered or right-justified. +The most common result is that the line is justified wrong. +

    + +

    Keywords

    +

    message, widget +

    +
    +

    +Next: , Previous: , Up: Widgets   [Contents]

    +
    + + + + + diff --git a/info/gcl-tk/option.html b/info/gcl-tk/option.html new file mode 100644 index 0000000..be31366 --- /dev/null +++ b/info/gcl-tk/option.html @@ -0,0 +1,152 @@ + + + + +GCL TK Manual: option + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    +
    + +

    3.11 option

    + +

    option \- Add/retrieve window options to/from the option database +

    +

    Synopsis

    +

    option :add pattern value ?priority? +


    +

    option :clear +


    +

    option :get window name class +


    +

    option :readfile fileName ?priority? +

    + +

    Description

    + +

    The option command allows you to add entries to the Tk option +database or to retrieve options from the database. The add +form of the command adds a new option to the database. +Pattern contains +the option being specified, and consists of names and/or classes +separated by asterisks or dots, in the usual X format. Value +contains a text string to associate with pattern; this is the +value that will be returned in calls to Tk_GetOption or by +invocations of the option :get command. If priority +is specified, it indicates the priority level for this option (see +below for legal values); it defaults to interactive. +This command always returns an empty string. +

    +

    The option :clear command clears the option database. Default +options (in the +RESOURCE_MANAGER property or the .Xdefaults +file) will be reloaded automatically the next time an +option is added to the database or removed from it. This command +always returns an empty string. +

    +

    The option :get command returns the value of the option +specified for window +under name and class. If several entries in the option +database match window, name, and class, then +the command returns whichever was created with highest +priority level. If there are several matching +entries at the same priority level, then it returns whichever entry +was most recently entered into the option database. If there are +no matching entries, then the empty string is returned. +

    +

    The readfile form of the command reads fileName, +which should have the standard format for an +X resource database such as .Xdefaults, and adds all the +options specified in that file to the option database. If priority +is specified, it indicates the priority level at which to enter the +options; priority defaults to interactive. +

    +

    The priority arguments to the option command are +normally specified symbolically using one of the following values: +

    +
    +
    widgetDefault
    +

    Level 20. Used for default values hard-coded into widgets. +

    +
    startupFile
    +

    Level 40. Used for options specified in application-specific +startup files. +

    +
    userDefault
    +

    Level 60. Used for options specified in user-specific defaults +files, such as .Xdefaults, resource databases loaded into +the X server, or user-specific startup files. +

    +
    interactive
    +

    Level 80. Used for options specified interactively after the application +starts running. If priority isn’t specified, it defaults to +this level. +

    +
    + + +

    Any of the above keywords may be abbreviated. In addition, priorities +may be specified numerically using integers between 0 and 100, +inclusive. The numeric form is probably a bad idea except for new priority +levels other than the ones given above. +

    + +

    Keywords

    +

    database, option, priority, retrieve +

    +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    + + + + + diff --git a/info/gcl-tk/options.html b/info/gcl-tk/options.html new file mode 100644 index 0000000..e35e793 --- /dev/null +++ b/info/gcl-tk/options.html @@ -0,0 +1,666 @@ + + + + +GCL TK Manual: options + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    +
    + +

    3.12 options

    + +

    options \- Standard options supported by widgets +

    + +

    Description

    +

    This manual entry describes the common configuration options supported +by widgets in the Tk toolkit. Every widget does not necessarily support +every option (see the manual entries for individual widgets for a list +of the standard options supported by that widget), but if a widget does +support an option with one of the names listed below, then the option +has exactly the effect described below. +

    +

    In the descriptions below, +“Name” refers to the option’s name in the option database (e.g. +in .Xdefaults files). “Class” refers to the option’s class value +in the option database. “Command-Line Switch” refers to the +switch used in widget-creation and configure widget commands to +set this value. For example, if an option’s command-line switch is +:foreground and there exists a widget .a.b.c, then the +command +

    +
    +
    +(.a.b.c  :configure  :foreground "black")
+
    + +

    may be used to specify the value black for the option in the +the widget .a.b.c. Command-line switches may be abbreviated, +as long as the abbreviation is unambiguous. +

    + +
    +
    :activebackground
    +

    Name="activeBackground" Class="Foreground" +


    + +

    Specifies background color to use when drawing active elements. +An element (a widget or portion of a widget) is active if the +mouse cursor is positioned over the element and pressing a mouse button +will cause some action to occur. +

    +
    + + +
    +
    :activeborderwidth
    +

    Name="activeBorderWidth" Class="BorderWidth" +


    + +

    Specifies a non-negative value indicating +the width of the 3-D border drawn around active elements. See above for +definition of active elements. +The value may have any of the forms acceptable to Tk_GetPixels. +This option is typically only available in widgets displaying more +than one element at a time (e.g. menus but not buttons). +

    +
    + + +
    +
    :activeforeground
    +

    Name="activeForeground" Class="Background" +


    + +

    Specifies foreground color to use when drawing active elements. +See above for definition of active elements. +

    +
    + + +
    +
    :anchor
    +

    Name="anchor" Class="Anchor" +


    + +

    Specifies how the information in a widget (e.g. text or a bitmap) +is to be displayed in the widget. +Must be one of the values n, ne, e, se, +s, sw, w, nw, or center. +For example, nw means display the information such that its +top-left corner is at the top-left corner of the widget. +

    +
    + + +
    +
    :background or :bg
    +

    Name="background" Class="Background" +


    + +

    Specifies the normal background color to use when displaying the +widget. +

    +
    + + +
    +
    :bitmap
    +

    Name="bitmap" Class="Bitmap" +


    + +

    Specifies a bitmap to display in the widget, in any of the forms +acceptable to Tk_GetBitmap. +The exact way in which the bitmap is displayed may be affected by +other options such as anchor or justify. +Typically, if this option is specified then it overrides other +options that specify a textual value to display in the widget; +the bitmap option may be reset to an empty string to re-enable +a text display. +

    +
    + + +
    +
    :borderwidth or :bd
    +

    Name="borderWidth" Class="BorderWidth" +


    + +

    Specifies a non-negative value indicating the width +of the 3-D border to draw around the outside of the widget (if such a +border is being drawn; the relief option typically determines +this). The value may also be used when drawing 3-D effects in the +interior of the widget. +The value may have any of the forms acceptable to Tk_GetPixels. +

    +
    + + +
    +
    :cursor
    +

    Name="cursor" Class="Cursor" +


    + +

    Specifies the mouse cursor to be used for the widget. +The value may have any of the forms acceptable to Tk_GetCursor. +

    +
    + + +
    +
    :cursorbackground
    +

    Name="cursorBackground" Class="Foreground" +


    + +

    Specifies the color to use as background in the area covered by the +insertion cursor. This color will normally override either the normal +background for the widget (or the selection background if the insertion +cursor happens to fall in the selection). +\fIThis option is obsolete and is gradually being replaced by +the insertBackground option. +

    +
    + + +
    +
    :cursorborderwidth
    +

    Name="cursorBorderWidth" Class="BorderWidth" +


    + +

    Specifies a non-negative value indicating the width +of the 3-D border to draw around the insertion cursor. +The value may have any of the forms acceptable to Tk_GetPixels. +\fIThis option is obsolete and is gradually being replaced by +the insertBorderWidth option. +

    +
    + + +
    +
    :cursorofftime
    +

    Name="cursorOffTime" Class="OffTime" +


    + +

    Specifies a non-negative integer value indicating the number of +milliseconds the cursor should remain “off” in each blink cycle. +If this option is zero then the cursor doesn’t blink: it is on +all the time. +\fIThis option is obsolete and is gradually being replaced by +the insertOffTime option. +

    +
    + + +
    +
    :cursorontime
    +

    Name="cursorOnTime" Class="OnTime" +


    + +

    Specifies a non-negative integer value indicating the number of +milliseconds the cursor should remain “on” in each blink cycle. +\fIThis option is obsolete and is gradually being replaced by +the insertOnTime option. +

    +
    + + +
    +
    :cursorwidth
    +

    Name="cursorWidth" Class="CursorWidth" +


    + +

    Specifies a value indicating the total width of the insertion cursor. +The value may have any of the forms acceptable to Tk_GetPixels. +If a border has been specified for +the cursor (using the cursorBorderWidth option), the border +will be drawn inside the width specified by the cursorWidth +option. +\fIThis option is obsolete and is gradually being replaced by +the insertWidth option. +

    +
    + + +
    +
    :disabledforeground
    +

    Name="disabledForeground" Class="DisabledForeground" +


    + +

    Specifies foreground color to use when drawing a disabled element. +If the option is specified as an empty string (which is typically the +case on monochrome displays), disabled elements are drawn with the +normal fooreground color but they are dimmed by drawing them +with a stippled fill pattern. +

    +
    + + +
    +
    :exportselection
    +

    Name="exportSelection" Class="ExportSelection" +


    + +

    Specifies whether or not a selection in the widget should also be +the X selection. +The value may have any of the forms accepted by Tcl_GetBoolean, +such as true, false, 0, 1, yes, or no. +If the selection is exported, then selecting in the widget deselects +the current X selection, selecting outside the widget deselects any +widget selection, and the widget will respond to selection retrieval +requests when it has a selection. The default is usually for widgets +to export selections. +

    +
    + + +
    +
    :font
    +

    Name="font" Class="Font" +


    + +

    Specifies the font to use when drawing text inside the widget. +

    +
    + + +
    +
    :foreground or :fg
    +

    Name="foreground" Class="Foreground" +


    + +

    Specifies the normal foreground color to use when displaying the widget. +

    +
    + + +
    +
    :geometry
    +

    Name="geometry" Class="Geometry" +


    + +

    Specifies the desired geometry for the widget’s window, in the +form widthxheight, where width is the desired +width of the window and height is the desired height. The +units for width and height depend on the particular +widget. For widgets displaying text the units are usually the +size of the characters in the font being displayed; for other +widgets the units are usually pixels. +

    +
    + + +
    +
    :insertbackground
    +

    Name="insertBackground" Class="Foreground" +


    + +

    Specifies the color to use as background in the area covered by the +insertion cursor. This color will normally override either the normal +background for the widget (or the selection background if the insertion +cursor happens to fall in the selection). +

    +
    + + +
    +
    :insertborderwidth
    +

    Name="insertBorderWidth" Class="BorderWidth" +


    + +

    Specifies a non-negative value indicating the width +of the 3-D border to draw around the insertion cursor. +The value may have any of the forms acceptable to Tk_GetPixels. +

    +
    + + +
    +
    :insertofftime
    +

    Name="insertOffTime" Class="OffTime" +


    + +

    Specifies a non-negative integer value indicating the number of +milliseconds the insertion cursor should remain “off” in each blink cycle. +If this option is zero then the cursor doesn’t blink: it is on +all the time. +

    +
    + + +
    +
    :insertontime
    +

    Name="insertOnTime" Class="OnTime" +


    + +

    Specifies a non-negative integer value indicating the number of +milliseconds the insertion cursor should remain “on” in each blink cycle. +

    +
    + + +
    +
    :insertwidth
    +

    Name="insertWidth" Class="InsertWidth" +


    + +

    Specifies a value indicating the total width of the insertion cursor. +The value may have any of the forms acceptable to Tk_GetPixels. +If a border has been specified for the insertion +cursor (using the insertBorderWidth option), the border +will be drawn inside the width specified by the insertWidth +option. +

    +
    + + +
    +
    :orient
    +

    Name="orient" Class="Orient" +


    + +

    For widgets that can lay themselves out with either a horizontal +or vertical orientation, such as scrollbars, this option specifies +which orientation should be used. Must be either horizontal +or vertical or an abbreviation of one of these. +

    +
    + + +
    +
    :padx
    +

    Name="padX" Class="Pad" +


    + +

    Specifies a non-negative value indicating how much extra space +to request for the widget in the X-direction. +The value may have any of the forms acceptable to Tk_GetPixels. +When computing how large a window it needs, the widget will +add this amount to the width it would normally need (as determined +by the width of the things displayed in the widget); if the geometry +manager can satisfy this request, the widget will end up with extra +internal space to the left and/or right of what it displays inside. +

    +
    + + +
    +
    :pady
    +

    Name="padY" Class="Pad" +


    + +

    Specifies a non-negative value indicating how much extra space +to request for the widget in the Y-direction. +The value may have any of the forms acceptable to Tk_GetPixels. +When computing how large a window it needs, the widget will add +this amount to the height it would normally need (as determined by +the height of the things displayed in the widget); if the geometry +manager can satisfy this request, the widget will end up with extra +internal space above and/or below what it displays inside. +

    +
    + + +
    +
    :relief
    +

    Name="relief" Class="Relief" +


    + +

    Specifies the 3-D effect desired for the widget. Acceptable +values are raised, sunken, flat, ridge, +and groove. +The value +indicates how the interior of the widget should appear relative +to its exterior; for example, raised means the interior of +the widget should appear to protrude from the screen, relative to +the exterior of the widget. +

    +
    + + +
    +
    :repeatdelay
    +

    Name="repeatDelay" Class="RepeatDelay" +


    + +

    Specifies the number of milliseconds a button or key must be held +down before it begins to auto-repeat. Used, for example, on the +up- and down-arrows in scrollbars. +

    +
    + + +
    +
    :repeatinterval
    +

    Name="repeatInterval" Class="RepeatInterval" +


    + +

    Used in conjunction with repeatDelay: once auto-repeat +begins, this option determines the number of milliseconds between +auto-repeats. +

    +
    + + +
    +
    :scrollcommand
    +

    Name="scrollCommand" Class="ScrollCommand" +


    + +

    Specifies the prefix for a command used to communicate with scrollbar +widgets. When the view in the widget’s window changes (or +whenever anything else occurs that could change the display in a +scrollbar, such as a change in the total size of the widget’s +contents), the widget will +generate a Tcl command by concatenating the scroll command and four +numbers. The four numbers are, in order: the total size of the +widget’s contents, in unspecified units +(“unit” is a widget-specific term; for widgets +displaying text, the unit is a line); the maximum number of units that +may be displayed at once in the widget’s window, given its current size; the +index of the top-most or left-most unit currently visible in the window +(index 0 corresponds to the first unit); and the index of the bottom-most +or right-most unit currently visible in the window. This command is +then passed to the Tcl interpreter for execution. Typically the +scrollCommand option consists of the path name of a scrollbar +widget followed by “set”, e.g. “.x.scrollbar set”: this will cause +the scrollbar to be updated whenever the view in the window changes. +If this option is not specified, then no command will be executed. +

    +

    The scrollCommand option is used for widgets that support scrolling +in only one direction. +For widgets that support scrolling in both directions, this +option is replaced with the xScrollCommand and yScrollCommand +options. +

    +
    + + +
    +
    :selectbackground
    +

    Name="selectBackground" Class="Foreground" +


    + +

    Specifies the background color to use when displaying selected +items. +

    +
    + + +
    +
    :selectborderwidth
    +

    Name="selectBorderWidth" Class="BorderWidth" +


    + +

    Specifies a non-negative value indicating the width +of the 3-D border to draw around selected items. +The value may have any of the forms acceptable to Tk_GetPixels. +

    +
    + + +
    +
    :selectforeground
    +

    Name="selectForeground" Class="Background" +


    + +

    Specifies the foreground color to use when displaying selected +items. +

    +
    + + +
    +
    :setgrid
    +

    Name="setGrid" Class="SetGrid" +


    + +

    Specifies a boolean value that determines whether this widget controls the +resizing grid for its top-level window. +This option is typically used in text widgets, where the information +in the widget has a natural size (the size of a character) and it makes +sense for the window’s dimensions to be integral numbers of these units. +These natural window sizes form a grid. +If the setGrid option is set to true then the widget will +communicate with the window manager so that when the user interactively +resizes the top-level window that contains the widget, the dimensions of +the window will be displayed to the user in grid units and the window +size will be constrained to integral numbers of grid units. +See the section GRIDDED GEOMETRY MANAGEMENT in the wm manual +entry for more details. +

    +
    + + +
    +
    :text
    +

    Name="text" Class="Text" +


    + +

    Specifies a string to be displayed inside the widget. The way in which +the string is displayed depends on the particular widget and may be +determined by other options, such as anchor or justify. +

    +
    + + +
    +
    :textvariable
    +

    Name="textVariable" Class="Variable" +


    + +

    Specifies the name of a variable. The value of the variable is a text +string to be displayed inside the widget; if the variable value changes +then the widget will automatically update itself to reflect the new value. +The way in which the string is displayed in the widget depends on the +particular widget and may be determined by other options, such as +anchor or justify. +

    +
    + + +
    +
    :underline
    +

    Name="underline" Class="Underline" +


    + +

    Specifies the integer index of a character to underline in the widget. +This option is typically used to indicate keyboard traversal characters +in menu buttons and menu entries. 0 corresponds to the first character +of the text displayed in the widget, 1 to the next character, and so +on. +

    +
    + + +
    +
    :xscrollcommand
    +

    Name="xScrollCommand" Class="ScrollCommand" +


    + +

    Specifies the prefix for a command used to communicate with horizontal +scrollbars. This option is treated in the same way as the +scrollCommand option, except that it is used for horizontal +scrollbars associated with widgets that support both horizontal +and vertical scrolling. +See the description of scrollCommand for complete details +on how this option is used. +

    +
    + + +
    +
    :yscrollcommand
    +

    Name="yScrollCommand" Class="ScrollCommand" +


    + +

    Specifies the prefix for a command used to communicate with vertical +scrollbars. This option is treated in the same way as the +scrollCommand option, except that it is used for vertical +scrollbars associated with widgets that support both horizontal +and vertical scrolling. +See the description of scrollCommand for complete details +on how this option is used. +

    +
    +
    + +

    Keywords

    +

    class, name, standard option, switch +

    +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    + + + + + diff --git a/info/gcl-tk/pack.html b/info/gcl-tk/pack.html new file mode 100644 index 0000000..d112522 --- /dev/null +++ b/info/gcl-tk/pack.html @@ -0,0 +1,338 @@ + + + + +GCL TK Manual: pack + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    +
    + +

    3.14 pack

    + +

    pack \- Geometry manager that packs around edges of cavity +

    +

    Synopsis

    +

    pack option arg ?arg ...? +

    + +

    Description

    + +

    The pack command is used to communicate with the packer, +a geometry manager that arranges the children of a parent by +packing them in order around the edges of the parent. +The pack command can have any of several forms, depending +on the option argument: +

    +
    +
    pack slave ?slave ...? ?options?
    +

    If the first argument to pack is a window name (any value +starting with “.”), then the command is processed in the same +way as pack configure. +

    +
    pack configure slave ?slave ...? ?options?
    +

    The arguments consist of the names of one or more slave windows +followed by pairs of arguments that specify how +to manage the slaves. +See “THE PACKER ALGORITHM” below for details on how the options +are used by the packer. +The following options are supported: +

    +
    :after other
    +

    Other must the name of another window. +Use its master as the master for the slaves, and insert +the slaves just after other in the packing order. +

    +
    :anchor anchor
    +

    Anchor must be a valid anchor position such as n +or sw; it specifies where to position each slave in its +parcel. +Defaults to center. +

    +
    :before other
    +

    Other must the name of another window. +Use its master as the master for the slaves, and insert +the slaves just before other in the packing order. +

    +
    :expand boolean
    +

    Specifies whether the slaves should be expanded to consume +extra space in their master. +Boolean may have any proper boolean value, such as 1 +or no. +Defaults to 0. +

    +
    :fill style
    +

    If a slave’s parcel is larger than its requested dimensions, this +option may be used to stretch the slave. +Style must have one of the following values: +

    +
    none
    +

    Give the slave its requested dimensions plus any internal padding +requested with :ipadx or :ipady. This is the default. +

    +
    x
    +

    Stretch the slave horizontally to fill the entire width of its +parcel (except leave external padding as specified by :padx). +

    +
    y
    +

    Stretch the slave vertically to fill the entire height of its +parcel (except leave external padding as specified by :pady). +

    +
    both
    +

    Stretch the slave both horizontally and vertically. +

    +
    +
    +
    :in other
    +

    Insert the slave(s) at the end of the packing order for the master +window given by other. +

    +
    :ipadx amount
    +

    Amount specifies how much horizontal internal padding to +leave on each side of the slave(s). +Amount must be a valid screen distance, such as 2 or .5c. +It defaults to 0. +

    +
    :ipady amount
    +

    Amount specifies how much vertical internal padding to +leave on each side of the slave(s). +Amount defaults to 0. +

    +
    :padx amount
    +

    Amount specifies how much horizontal external padding to +leave on each side of the slave(s). +Amount defaults to 0. +

    +
    :pady amount
    +

    Amount specifies how much vertical external padding to +leave on each side of the slave(s). +Amount defaults to 0. +

    +
    :side side
    +

    Specifies which side of the master the slave(s) will be packed against. +Must be left, right, top, or bottom. +Defaults to top. +

    +
    + + +

    If no :in, :after or :before option is specified +then each of the slaves will be inserted at the end of the packing list +for its parent unless it is already managed by the packer (in which +case it will be left where it is). +If one of these options is specified then all the slaves will be +inserted at the specified point. +If any of the slaves are already managed by the geometry manager +then any unspecified options for them retain their previous values rather +than receiving default values. +.RE +

    +
    +
    pack :forget slave ?slave ...?
    +

    Removes each of the slaves from the packing order for its +master and unmaps their windows. +The slaves will no longer be managed by the packer. +

    +
    pack :newinfo slave
    +

    Returns a list whose elements are the current configuration state of +the slave given by slave in the same option-value form that +might be specified to pack configure. +The first two elements of the list are “:in master” where +master is the slave’s master. +Starting with Tk 4.0 this option will be renamed "pack info". +

    +
    pack :propagate master ?boolean?
    +

    If boolean has a true boolean value such as 1 or on +then propagation is enabled for master, which must be a window +name (see “GEOMETRY PROPAGATION” below). +If boolean has a false boolean value then propagation is +disabled for master. +In either of these cases an empty string is returned. +If boolean is omitted then the command returns 0 or +1 to indicate whether propagation is currently enabled +for master. +Propagation is enabled by default. +

    +
    pack :slaves master
    +

    Returns a list of all of the slaves in the packing order for master. +The order of the slaves in the list is the same as their order in +the packing order. +If master has no slaves then an empty string is returned. +

    +
    +
    + +

    "The Packer Algorithm"

    + +

    For each master the packer maintains an ordered list of slaves +called the packing list. +The :in, :after, and :before configuration +options are used to specify the master for each slave and the slave’s +position in the packing list. +If none of these options is given for a slave then the slave +is added to the end of the packing list for its parent. +

    +

    The packer arranges the slaves for a master by scanning the +packing list in order. +At the time it processes each slave, a rectangular area within +the master is still unallocated. +This area is called the cavity; for the first slave it +is the entire area of the master. +

    +

    For each slave the packer carries out the following steps: +

      +
    • [1] +The packer allocates a rectangular parcel for the slave +along the side of the cavity given by the slave’s :side option. +If the side is top or bottom then the width of the parcel is +the width of the cavity and its height is the requested height +of the slave plus the :ipady and :pady options. +For the left or right side the height of the parcel is +the height of the cavity and the width is the requested width +of the slave plus the :ipadx and :padx options. +The parcel may be enlarged further because of the :expand +option (see “EXPANSION” below) +
    • [2] +The packer chooses the dimensions of the slave. +The width will normally be the slave’s requested width plus +twice its :ipadx option and the height will normally be +the slave’s requested height plus twice its :ipady +option. +However, if the :fill option is x or both +then the width of the slave is expanded to fill the width of the parcel, +minus twice the :padx option. +If the :fill option is y or both +then the height of the slave is expanded to fill the width of the parcel, +minus twice the :pady option. +
    • [3] +The packer positions the slave over its parcel. +If the slave is smaller than the parcel then the :anchor +option determines where in the parcel the slave will be placed. +If :padx or :pady is non-zero, then the given +amount of external padding will always be left between the +slave and the edges of the parcel. +
    + + +

    Once a given slave has been packed, the area of its parcel +is subtracted from the cavity, leaving a smaller rectangular +cavity for the next slave. +If a slave doesn’t use all of its parcel, the unused space +in the parcel will not be used by subsequent slaves. +If the cavity should become too small to meet the needs of +a slave then the slave will be given whatever space is +left in the cavity. +If the cavity shrinks to zero size, then all remaining slaves +on the packing list will be unmapped from the screen until +the master window becomes large enough to hold them again. +

    + +

    "Expansion"

    + +

    If a master window is so large that there will be extra space +left over after all of its slaves have been packed, then the +extra space is distributed uniformly among all of the slaves +for which the :expand option is set. +Extra horizontal space is distributed among the expandable +slaves whose :side is left or right, +and extra vertical space is distributed among the expandable +slaves whose :side is top or bottom. +

    + +

    "Geometry Propagation"

    + +

    The packer normally computes how large a master must be to +just exactly meet the needs of its slaves, and it sets the +requested width and height of the master to these dimensions. +This causes geometry information to propagate up through a +window hierarchy to a top-level window so that the entire +sub-tree sizes itself to fit the needs of the leaf windows. +However, the pack propagate command may be used to +turn off propagation for one or more masters. +If propagation is disabled then the packer will not set +the requested width and height of the packer. +This may be useful if, for example, you wish for a master +window to have a fixed size that you specify. +

    + +

    "Restrictions On Master Windows"

    + +

    The master for each slave must either be the slave’s parent +(the default) or a descendant of the slave’s parent. +This restriction is necessary to guarantee that the +slave can be placed over any part of its master that is +visible without danger of the slave being clipped by its parent. +

    + +

    "Packing Order"

    + +

    If the master for a slave is not its parent then you must make sure +that the slave is higher in the stacking order than the master. +Otherwise the master will obscure the slave and it will appear as +if the slave hasn’t been packed correctly. +The easiest way to make sure the slave is higher than the master is +to create the master window first: the most recently created window +will be highest in the stacking order. +Or, you can use the raise and lower commands to change +the stacking order of either the master or the slave. +

    + +

    Keywords

    +

    geometry manager, location, packer, parcel, propagation, size +

    +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    + + + + + diff --git a/info/gcl-tk/pack_002dold.html b/info/gcl-tk/pack_002dold.html new file mode 100644 index 0000000..e9f0cf2 --- /dev/null +++ b/info/gcl-tk/pack_002dold.html @@ -0,0 +1,279 @@ + + + + +GCL TK Manual: pack-old + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    +
    + +

    3.13 pack-old

    + +

    pack \- Obsolete syntax for packer geometry manager +

    +

    Synopsis

    +

    pack after sibling window options ?window options ...? +


    +

    pack append parent window options ?window options ...? +


    +

    pack before sibling window options ?window options ...? +


    +

    pack info parent +


    +

    pack unpack window +

    + +

    Description

    + +

    Note: this manual entry describes the syntax for the pack\fI +command as it before Tk version 3.3. +Although this syntax continues to be supported for backward +compatibility, it is obsolete and should not be used anymore. +At some point in the future it may cease to be supported. +

    +

    The packer is a geometry manager that arranges the +children of a parent by packing them in order around the edges of +the parent. The first child is placed against one side of +the window, occupying the entire span of the window along that +side. This reduces the space remaining for other children as +if the side had been moved in by the size of the first child. +Then the next child is placed against one side of the remaining +cavity, and so on until all children have been placed or there +is no space left in the cavity. +

    +

    The before, after, and append forms of the pack +command are used to insert one or more children into the packing order +for their parent. The before form inserts the children before +window sibling in the order; all of the other windows must be +siblings of sibling. The after form inserts the windows +after sibling, and the append form appends one or more +windows to the end of the packing order for parent. If a +window named in any of these commands is already packed in +its parent, it is removed from its current position in the packing +order and repositioned as indicated by the command. All of these +commands return an empty string as result. +

    +

    The unpack form of the pack command removes window +from the packing order of its parent and unmaps it. After the +execution of this command the packer will no longer manage +window’s geometry. +

    +

    The placement of each child is actually a four-step process; +the options argument following each window consists of +a list of one or more fields that govern the placement of that +window. In the discussion below, the term cavity refers +to the space left in a parent when a particular child is placed +(i.e. all the space that wasn’t claimed by earlier children in +the packing order). The term parcel refers to the space +allocated to a particular child; this is not necessarily the +same as the child window’s final geometry. +

    +

    The first step in placing a child is to determine which side of +the cavity it will lie against. Any one of the following options +may be used to specify a side: +

    +
    +
    top
    +

    Position the child’s parcel against the top of the cavity, +occupying the full width of the cavity. +

    +
    bottom
    +

    Position the child’s parcel against the bottom of the cavity, +occupying the full width of the cavity. +

    +
    left
    +

    Position the child’s parcel against the left side of the cavity, +occupying the full height of the cavity. +

    +
    right
    +

    Position the child’s parcel against the right side of the cavity, +occupying the full height of the cavity. +

    +
    + + +

    At most one of these options should be specified for any given window. +If no side is specified, then the default is top. +

    +

    The second step is to decide on a parcel for the child. For top +and bottom windows, the desired parcel width is normally the cavity +width and the desired parcel height is the window’s requested height, +as passed to Tk_GeometryRequest. For left and right +windows, the desired parcel height is normally the cavity height and the +desired width is the window’s requested width. However, extra +space may be requested for the window using any of the following +options: +

    +
    +
    padx num
    +

    Add num pixels to the window’s requested width before computing +the parcel size as described above. +

    +
    pady num
    +

    Add num pixels to the window’s requested height before computing +the parcel size as described above. +

    +
    expand
    +

    This option requests that the window’s parcel absorb any extra space left over +in the parent’s cavity after packing all the children. +The amount of space left over depends on the sizes requested by the +other children, and may be zero. If several windows have all specified +expand then the extra width will be divided equally among all the +left and right windows that specified expand and +the extra height will be divided equally among all the top and +bottom windows that specified expand. +

    +
    + + +

    If the desired width or height for a parcel is larger than the corresponding +dimension of the cavity, then the cavity’s dimension is used instead. +

    +

    The third step in placing the window is to decide on the window’s +width and height. The default is for the window to receive either +its requested width and height or the those of the parcel, whichever +is smaller. If the parcel is larger than the window’s requested +size, then the following options may be used to expand the +window to partially or completely fill the parcel: +

    +
    +
    fill
    +

    Set the window’s size to equal the parcel size. +

    +
    fillx
    +

    Increase the window’s width to equal the parcel’s width, but retain +the window’s requested height. +

    +
    filly
    +

    Increase the window’s height to equal the parcel’s height, but retain +the window’s requested width. +

    +

    The last step is to decide the window’s location within its parcel. +If the window’s size equals the parcel’s size, then the window simply +fills the entire parcel. If the parcel is larger than the window, +then one of +the following options may be used to specify where the window should +be positioned within its parcel: +

    +
    frame center
    +

    Center the window in its parcel. This is the default if no framing +option is specified. +

    +
    frame n
    +

    Position the window with its top edge centered on the top edge of +the parcel. +

    +
    frame ne
    +

    Position the window with its upper-right corner at the upper-right corner +of the parcel. +

    +
    frame e
    +

    Position the window with its right edge centered on the right edge of +the parcel. +

    +
    frame se
    +

    Position the window with its lower-right corner at the lower-right corner +of the parcel. +

    +
    frame s
    +

    Position the window with its bottom edge centered on the bottom edge of +the parcel. +

    +
    frame sw
    +

    Position the window with its lower-left corner at the lower-left corner +of the parcel. +

    +
    frame w
    +

    Position the window with its left edge centered on the left edge of +the parcel. +

    +
    frame nw
    +

    Position the window with its upper-left corner at the upper-left corner +of the parcel. +

    +

    The pack info command may be used to retrieve information about +the packing order for a parent. It returns a list in the form +

    +
    +
    window options window options ...
+
    + +

    Each window is a name of a window packed in parent, +and the following options describes all of the options for that +window, just as they would be typed to pack append. +The order of the list is the same as the packing order for +parent. +

    +

    The packer manages the mapped/unmapped state of all the packed +children windows. It automatically maps the windows when it packs +them, and it unmaps any windows for which there was no space left +in the cavity. +

    +

    The packer makes geometry requests on behalf of the parent windows +it manages. For each parent window it requests a size large enough +to accommodate all the options specified by all the packed children, +such that zero space would be leftover for expand options. +

    +
    +
    + +

    Keywords

    +

    geometry manager, location, packer, parcel, size +

    +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    + + + + + diff --git a/info/gcl-tk/place.html b/info/gcl-tk/place.html new file mode 100644 index 0000000..838127a --- /dev/null +++ b/info/gcl-tk/place.html @@ -0,0 +1,286 @@ + + + + +GCL TK Manual: place + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    +
    + +

    3.15 place

    + +

    place \- Geometry manager for fixed or rubber-sheet placement +

    +

    Synopsis

    +

    place window option value ?option value ...? +


    +

    place configure window option value ?option value ...? +


    +

    place forget window +


    +

    place info window +


    +

    place slaves window +

    + +

    Description

    + +

    The placer is a geometry manager for Tk. +It provides simple fixed placement of windows, where you specify +the exact size and location of one window, called the slave, +within another window, called the master. +The placer also provides rubber-sheet placement, where you specify the +size and location of the slave in terms of the dimensions of +the master, so that the slave changes size and location +in response to changes in the size of the master. +Lastly, the placer allows you to mix these styles of placement so +that, for example, the slave has a fixed width and height but is +centered inside the master. +

    +

    If the first argument to the place command is a window path +name or configure then the command arranges for the placer +to manage the geometry of a slave whose path name is window. +The remaining arguments consist of one or more option:value +pairs that specify the way in which window’s +geometry is managed. +If the placer is already managing window, then the +option:value pairs modify the configuration for window. +In this form the place command returns an empty string as result. +The following option:value pairs are supported: +

    +
    +
    :in master
    +

    Master specifes the path name of the window relative +to which window is to be placed. +Master must either be window’s parent or a descendant +of window’s parent. +In addition, master and window must both be descendants +of the same top-level window. +These restrictions are necessary to guarantee +that window is visible whenever master is visible. +If this option isn’t specified then the master defaults to +window’s parent. +

    +
    :x location
    +

    Location specifies the x-coordinate within the master window +of the anchor point for window. +The location is specified in screen units (i.e. any of the forms +accepted by Tk_GetPixels) and need not lie within the bounds +of the master window. +

    +
    :relx location
    +

    Location specifies the x-coordinate within the master window +of the anchor point for window. +In this case the location is specified in a relative fashion +as a floating-point number: 0.0 corresponds to the left edge +of the master and 1.0 corresponds to the right edge of the master. +Location need not be in the range 0.0\-1.0. +

    +
    :y location
    +

    Location specifies the y-coordinate within the master window +of the anchor point for window. +The location is specified in screen units (i.e. any of the forms +accepted by Tk_GetPixels) and need not lie within the bounds +of the master window. +

    +
    :rely location
    +

    Location specifies the y-coordinate within the master window +of the anchor point for window. +In this case the value is specified in a relative fashion +as a floating-point number: 0.0 corresponds to the top edge +of the master and 1.0 corresponds to the bottom edge of the master. +Location need not be in the range 0.0\-1.0. +

    +
    :anchor where
    +

    Where specifies which point of window is to be positioned +at the (x,y) location selected by the :x, :y, +:relx, and :rely options. +The anchor point is in terms of the outer area of window +including its border, if any. +Thus if where is se then the lower-right corner of +window’s border will appear at the given (x,y) location +in the master. +The anchor position defaults to nw. +

    +
    :width size
    +

    Size specifies the width for window in screen units +(i.e. any of the forms accepted by Tk_GetPixels). +The width will be the outer width of window including its +border, if any. +If size is an empty string, or if no :width +or :relwidth option is specified, then the width requested +internally by the window will be used. +

    +
    :relwidth size
    +

    Size specifies the width for window. +In this case the width is specified as a floating-point number +relative to the width of the master: 0.5 means window will +be half as wide as the master, 1.0 means window will have +the same width as the master, and so on. +

    +
    :height size
    +

    Size specifies the height for window in screen units +(i.e. any of the forms accepted by Tk_GetPixels). +The height will be the outer dimension of window including its +border, if any. +If size is an empty string, or if no :height or +:relheight option is specified, then the height requested +internally by the window will be used. +

    +
    :relheight size
    +

    Size specifies the height for window. +In this case the height is specified as a floating-point number +relative to the height of the master: 0.5 means window will +be half as high as the master, 1.0 means window will have +the same height as the master, and so on. +

    +
    :bordermode mode
    +

    Mode determines the degree to which borders within the +master are used in determining the placement of the slave. +The default and most common value is inside. +In this case the placer considers the area of the master to +be the innermost area of the master, inside any border: +an option of :x 0 corresponds to an x-coordinate just +inside the border and an option of :relwidth 1.0 +means window will fill the area inside the master’s +border. +If mode is outside then the placer considers +the area of the master to include its border; +this mode is typically used when placing window +outside its master, as with the options :x 0 :y 0 :anchor ne. +Lastly, mode may be specified as ignore, in which +case borders are ignored: the area of the master is considered +to be its official X area, which includes any internal border but +no external border. A bordermode of ignore is probably +not very useful. +

    +

    If the same value is specified separately with +two different options, such as :x and :relx, then +the most recent option is used and the older one is ignored. +

    +

    The place slaves command returns a list of all the slave +windows for which window is the master. +If there are no slaves for window then an empty string is +returned. +

    +

    The place forget command causes the placer to stop managing +the geometry of window. As a side effect of this command +window will be unmapped so that it doesn’t appear on the +screen. +If window isn’t currently managed by the placer then the +command has no effect. +Place forget returns an empty string as result. +

    +

    The place info command returns a list giving the current +configuration of window. +The list consists of option:value pairs in exactly the +same form as might be specified to the place configure +command. +If the configuration of a window has been retrieved with +place info, that configuration can be restored later by +first using place forget to erase any existing information +for the window and then invoking place configure with +the saved information. +

    +
    +
    + +

    "Fine Points"

    + +

    It is not necessary for the master window to be the parent +of the slave window. +This feature is useful in at least two situations. +First, for complex window layouts it means you can create a +hierarchy of subwindows whose only purpose +is to assist in the layout of the parent. +The “real children” of the parent (i.e. the windows that +are significant for the application’s user interface) can be +children of the parent yet be placed inside the windows +of the geometry-management hierarchy. +This means that the path names of the “real children” +don’t reflect the geometry-management hierarchy and users +can specify options for the real children +without being aware of the structure of the geometry-management +hierarchy. +

    +

    A second reason for having a master different than the slave’s +parent is to tie two siblings together. +For example, the placer can be used to force a window always to +be positioned centered just below one of its +siblings by specifying the configuration +

    +
    +
    :in sibling :relx 0.5 :rely 1.0 :anchor n :bordermode outside
+
    + +

    Whenever the sibling is repositioned in the future, the slave +will be repositioned as well. +

    +

    Unlike many other geometry managers (such as the packer) +the placer does not make any attempt to manipulate the geometry of +the master windows or the parents of slave windows (i.e. it doesn’t +set their requested sizes). +To control the sizes of these windows, make them windows like +frames and canvases that provide configuration options for this purpose. +

    + +

    Keywords

    +

    geometry manager, height, location, master, place, rubber sheet, slave, width +

    +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    + + + + + diff --git a/info/gcl-tk/radiobutton.html b/info/gcl-tk/radiobutton.html new file mode 100644 index 0000000..491cf18 --- /dev/null +++ b/info/gcl-tk/radiobutton.html @@ -0,0 +1,333 @@ + + + + +GCL TK Manual: radiobutton + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Widgets   [Contents]

    +
    +
    + +

    2.14 radiobutton

    + +

    radiobutton \- Create and manipulate radio-button widgets +

    +

    Synopsis

    +

    radiobutton pathName ?options? +

    +

    Standard Options

    + + +
    +
    activeBackground  bitmap              font        relief        
+activeForeground  borderWidth         foreground  text          
+anchor            cursor              padX        textVariable  
+background        disabledForeground  padX        
+
    + + +

    See options, for more information. +

    +

    Arguments for Radiobutton

    + + +
    +
    :command
    +

    Name="command" Class="Command" +


    + +

    Specifies a Tcl command to associate with the button. This command +is typically invoked when mouse button 1 is released over the button +window. The button’s global variable (:variable option) will +be updated before the command is invoked. +

    +
    + + +
    +
    :height
    +

    Name="height" Class="Height" +


    + +

    Specifies a desired height for the button. +If a bitmap is being displayed in the button then the value is in +screen units (i.e. any of the forms acceptable to Tk_GetPixels); +for text it is in lines of text. +If this option isn’t specified, the button’s desired height is computed +from the size of the bitmap or text being displayed in it. +

    +
    + + +
    +
    :selector
    +

    Name="selector" Class="Foreground" +


    + +

    Specifies the color to draw in the selector when this button is +selected. +If specified as an empty string then no selector is drawn for the button. +

    +
    + + +
    +
    :state
    +

    Name="state" Class="State" +


    + +

    Specifies one of three states for the radio button: normal, active, +or disabled. In normal state the radio button is displayed using the +foreground and background options. The active state is +typically used when the pointer is over the radio button. In active state +the radio button is displayed using the activeForeground and +activeBackground options. Disabled state means that the radio button +is insensitive: it doesn’t activate and doesn’t respond to mouse +button presses. In this state the disabledForeground and +background options determine how the radio button is displayed. +

    +
    + + +
    +
    :value
    +

    Name="value" Class="Value" +


    + +

    Specifies value to store in the button’s associated variable whenever +this button is selected. Defaults to the name of the radio button. +

    +
    + + +
    +
    :variable
    +

    Name="variable" Class="Variable" +


    + +

    Specifies name of global variable to set whenever this button is +selected. Changes in this variable also cause the button to select +or deselect itself. +Defaults to the value selectedButton. +

    +
    + + +
    +
    :width
    +

    Name="width" Class="Width" +


    + +

    Specifies a desired width for the button. +If a bitmap is being displayed in the button then the value is in +screen units (i.e. any of the forms acceptable to Tk_GetPixels); +for text it is in characters. +If this option isn’t specified, the button’s desired width is computed +from the size of the bitmap or text being displayed in it. +

    +
    + + +

    Description

    + +

    The radiobutton command creates a new window (given by the +pathName argument) and makes it into a radiobutton widget. +Additional +options, described above, may be specified on the command line +or in the option database +to configure aspects of the radio button such as its colors, font, +text, and initial relief. The radiobutton command returns its +pathName argument. At the time this command is invoked, +there must not exist a window named pathName, but +pathName’s parent must exist. +

    +

    A radio button is a widget +that displays a textual string or bitmap +and a diamond called a selector. +A radio button has +all of the behavior of a simple button: it can display itself in either +of three different ways, according to the state option; +it can be made to appear +raised, sunken, or flat; it can be made to flash; and it invokes +a Tcl command whenever mouse button 1 is clicked over the +check button. +

    +

    In addition, radio buttons can be selected. +If a radio button is selected then a special highlight appears +in the selector and a Tcl variable associated with the radio button +is set to a particular value. +If the radio button is not selected then the selector is drawn +in a different fashion. +Typically, several radio buttons share a single variable and the +value of the variable indicates which radio button is to be selected. +When a radio button is selected it sets the value of the variable to +indicate that fact; each radio button also monitors the value of +the variable and automatically selects and deselects itself when the +variable’s value changes. +By default the variable selectedButton +is used; its contents give the name of the button that is +selected, or the empty string if no button associated with that +variable is selected. +The name of the variable for a radio button, +plus the variable to be stored into it, may be modified with options +on the command line or in the option database. By default a radio +button is configured to select itself on button clicks. +

    + +

    A Radiobutton Widget’s Arguments

    + +

    The radiobutton command creates a new Tcl command whose +name is pathName. This +command may be used to invoke various +operations on the widget. It has the following general form: +

    +
    +
    pathName option ?arg arg ...?
+
    + +

    Option and the args +determine the exact behavior of the command. The following +commands are possible for radio-button widgets: +

    +
    +
    pathName :activate
    +

    Change the radio button’s state to active and redisplay the button +using its active foreground and background colors instead of normal +colors. +This command is ignored if the radio button’s state is disabled. +This command is obsolete and will eventually be removed; +use “pathName :configure :state active” instead. +

    +
    pathName :configure ?option? ?value option value ...?
    +

    Query or modify the configuration options of the widget. +If no option is specified, returns a list describing all of +the available options for pathName (see Tk_ConfigureInfo for +information on the format of this list). If option is specified +with no value, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no option is specified). If +one or more option:value pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +Option may have any of the values accepted by the radiobutton +command. +

    +
    pathName :deactivate
    +

    Change the radio button’s state to normal and redisplay the button +using its normal foreground and background colors. +This command is ignored if the radio button’s state is disabled. +This command is obsolete and will eventually be removed; +use “pathName :configure :state normal” instead. +

    +
    pathName :deselect
    +

    Deselect the radio button: redisplay it without a highlight in +the selector and set the associated variable to an empty string. If +this radio button was not currently selected, then the command has +no effect. +

    +
    pathName :flash
    +

    Flash the radio button. This is accomplished by redisplaying the radio button +several times, alternating between active and normal colors. At +the end of the flash the radio button is left in the same normal/active +state as when the command was invoked. +This command is ignored if the radio button’s state is disabled. +

    +
    pathName :invoke
    +

    Does just what would have happened if the user invoked the radio button +with the mouse: select the button and invoke +its associated Tcl command, if there is one. +The return value is the return value from the Tcl command, or an +empty string if there is no command associated with the radio button. +This command is ignored if the radio button’s state is disabled. +

    +
    pathName :select
    +

    Select the radio button: display it with a highlighted +selector and set the associated variable to the value corresponding +to this widget. +

    +
    +
    + +

    Bindings

    + +

    Tk automatically creates class bindings for radio buttons that give them +the following default behavior: +

      +
    • [1] +The radio button activates whenever the mouse passes over it and deactivates +whenever the mouse leaves the radio button. +
    • [2] +The radio button’s relief is changed to sunken whenever mouse button 1 is +pressed over it, and the relief is restored to its original +value when button 1 is later released. +
    • [3] +If mouse button 1 is pressed over the radio button and later released over +the radio button, the radio button is invoked (i.e. it is selected +and the command associated with the button is invoked, +if there is one). However, if the mouse is not +over the radio button when button 1 is released, then no invocation occurs. +
    + +

    The behavior of radio buttons can be changed by defining new bindings for +individual widgets or by redefining the class bindings. +

    + +

    Keywords

    +

    radio button, widget +

    +
    +

    +Next: , Previous: , Up: Widgets   [Contents]

    +
    + + + + + diff --git a/info/gcl-tk/raise.html b/info/gcl-tk/raise.html new file mode 100644 index 0000000..8ee76ef --- /dev/null +++ b/info/gcl-tk/raise.html @@ -0,0 +1,87 @@ + + + + +GCL TK Manual: raise + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    +
    + +

    3.16 raise

    + +

    raise \- Change a window’s position in the stacking order +

    +

    Synopsis

    +

    raise window ?aboveThis? +

    + +

    Description

    + +

    If the aboveThis argument is omitted then the command raises +window so that it is above all of its siblings in the stacking +order (it will not be obscured by any siblings and will obscure +any siblings that overlap it). +If aboveThis is specified then it must be the path name of +a window that is either a sibling of window or the descendant +of a sibling of window. +In this case the raise command will insert +window into the stacking order just above aboveThis +(or the ancestor of aboveThis that is a sibling of window); +this could end up either raising or lowering window. +

    + +

    Keywords

    +

    obscure, raise, stacking order +

    + + + + diff --git a/info/gcl-tk/scale.html b/info/gcl-tk/scale.html new file mode 100644 index 0000000..2f9d166 --- /dev/null +++ b/info/gcl-tk/scale.html @@ -0,0 +1,328 @@ + + + + +GCL TK Manual: scale + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Widgets   [Contents]

    +
    +
    + +

    2.3 scale

    + +

    scale \- Create and manipulate scale widgets +

    +

    Synopsis

    +

    scale pathName ?options? +

    +

    Standard Options

    + + +
    +
    activeForeground     borderWidth     font           orient     
+background           cursor          foreground     relief     
+
    + + +

    See options, for more information. +

    +

    Arguments for Scale

    + + +
    +
    :command
    +

    Name="command" Class="Command" +


    + +

    Specifies the prefix of a Tcl command to invoke whenever the value of +the scale is changed interactively. The actual command consists +of this option followed by +a space and a number. The number indicates the new value of the +scale. +

    +
    + + +
    +
    :from
    +

    Name="from" Class="From" +


    + +

    Specifies the value corresponding to the left or top end of the +scale. Must be an integer. +

    +
    + + +
    +
    :label
    +

    Name="label" Class="Label" +


    + +

    Specifies a string to displayed as a label for the scale. For +vertical scales the label is displayed just to the right of the +top end of the scale. For horizontal scales the label is displayed +just above the left end of the scale. +

    +
    + + +
    +
    :length
    +

    Name="length" Class="Length" +


    + +

    Specifies the desired long dimension of the scale in screen units, +that is in any of the forms acceptable to Tk_GetPixels. +For vertical scales this is the scale’s height; for horizontal scales +it is the scale’s width. +

    +
    + + +
    +
    :showvalue
    +

    Name="showValue" Class="ShowValue" +


    + +

    Specifies a boolean value indicating whether or not the current +value of the scale is to be displayed. +

    +
    + + +
    +
    :sliderforeground
    +

    Name="sliderForeground" Class="sliderForeground" +


    + +

    Specifies the color to use for drawing the slider under normal conditions. +When the mouse is in the slider window then the slider’s color is +determined by the activeForeground option. +

    +
    + + +
    +
    :sliderlength
    +

    Name="sliderLength" Class="SliderLength" +


    + +

    Specfies the size of the slider, measured in screen units along the slider’s +long dimension. The value may be specified in any of the forms acceptable +to Tk_GetPixels. +

    +
    + + +
    +
    :state
    +

    Name="state" Class="State" +


    + +

    Specifies one of two states for the scale: normal or disabled. +If the scale is disabled then the value may not be changed and the scale +won’t activate when the mouse enters it. +

    +
    + + +
    +
    :tickinterval
    +

    Name="tickInterval" Class="TickInterval" +


    + +

    Must be an integer value. Determines the spacing between numerical +tick-marks displayed below or to the left of the slider. If specified +as 0, then no tick-marks will be displayed. +

    +
    + + +
    +
    :to
    +

    Name="to" Class="To" +


    + +

    Specifies the value corresponding to the right or bottom end of the +scale. Must be an integer. This value may be either less than or +greater than the from option. +

    +
    + + +
    +
    :width
    +

    Name="width" Class="Width" +


    + +

    Specifies the desired narrow dimension of the scale in screen units +(i.e. any of the forms acceptable to Tk_GetPixels). +For vertical scales this is the scale’s width; for horizontal scales +this is the scale’s height. +

    +
    + + +

    Description

    + +

    The scale command creates a new window (given by the +pathName argument) and makes it into a scale widget. +Additional +options, described above, may be specified on the command line +or in the option database +to configure aspects of the scale such as its colors, orientation, +and relief. The scale command returns its +pathName argument. At the time this command is invoked, +there must not exist a window named pathName, but +pathName’s parent must exist. +

    +

    A scale is a widget that displays a rectangular region and a +small slider. The rectangular region corresponds to a range +of integer values (determined by the from and to options), +and the position of the slider selects a particular integer value. +The slider’s position (and hence the scale’s value) may be adjusted +by clicking or dragging with the mouse as described in the BINDINGS +section below. Whenever the scale’s value is changed, a Tcl +command is invoked (using the command option) to notify +other interested widgets of the change. +

    +

    Three annotations may be displayed in a scale widget: a label +appearing at the top-left of the widget (top-right for vertical +scales), a number displayed just underneath the slider +(just to the left of the slider for vertical scales), and a collection +of numerical tick-marks just underneath the current value (just to the left of +the current value for vertical scales). Each of these three +annotations may be selectively enabled or disabled using the +configuration options. +

    + +

    A Scale’s"Argumentsommand"

    + +

    The scale command creates a new Tcl command whose +name is pathName. This +command may be used to invoke various +operations on the widget. It has the following general form: +

    +
    +
    pathName option ?arg arg ...?
+
    + +

    Option and the args +determine the exact behavior of the command. The following +commands are possible for scale widgets: +

    +
    +
    pathName :configure ?option? ?value option value ...?
    +

    Query or modify the configuration options of the widget. +If no option is specified, returns a list describing all of +the available options for pathName (see Tk_ConfigureInfo for +information on the format of this list). If option is specified +with no value, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no option is specified). If +one or more option:value pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +Option may have any of the values accepted by the scale +command. +

    +
    pathName :get
    +

    Returns a decimal string giving the current value of the scale. +

    +
    pathName :set value
    +

    This command is invoked to change the current value of the scale, +and hence the position at which the slider is displayed. Value +gives the new value for the scale. +

    +
    +
    + +

    Bindings

    + +

    When a new scale is created, it is given the following initial +behavior by default: +

    +
    +
    <Enter>
    +

    Change the slider display to use activeForeground instead of +sliderForeground. +

    +
    <Leave>
    +

    Reset the slider display to use sliderForeground instead of +activeForeground. +

    +
    <ButtonPress-1>
    +

    Change the slider display so that the slider appears sunken rather +than raised. Move the slider (and adjust the scale’s value) +to correspond to the current mouse position. +

    +
    <Button1-Motion>
    +

    Move the slider (and adjust the scale’s value) to correspond to +the current mouse position. +

    +
    <ButtonRelease-1>
    +

    Reset the slider display so that the slider appears raised again. +

    +
    +
    + +

    Keywords

    +

    scale, widget +

    +
    +

    +Next: , Previous: , Up: Widgets   [Contents]

    +
    + + + + + diff --git a/info/gcl-tk/scrollbar.html b/info/gcl-tk/scrollbar.html new file mode 100644 index 0000000..a5d66ca --- /dev/null +++ b/info/gcl-tk/scrollbar.html @@ -0,0 +1,258 @@ + + + + +GCL TK Manual: scrollbar + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Widgets   [Contents]

    +
    +
    + +

    2.6 scrollbar

    + +

    scrollbar \- Create and manipulate scrollbar widgets +

    +

    Synopsis

    +

    scrollbar pathName ?options? +

    +

    Standard Options

    + + +
    +
    activeForeground       cursor           relief               
+background             foreground       repeatDelay          
+borderWidth            orient           repeatInterval       
+
    + + +

    See options, for more information. +

    +

    Arguments for Scrollbar

    + + +
    +
    :command
    +

    Name="command" Class="Command" +


    + +

    Specifies the prefix of a Tcl command to invoke to change the view +in the widget associated with the scrollbar. When a user requests +a view change by manipulating the scrollbar, a Tcl command is +invoked. The actual command consists of this option followed by +a space and a number. The number indicates the logical unit that +should appear at the top of the associated window. +

    +
    + + +
    +
    :width
    +

    Name="width" Class="Width" +


    + +

    Specifies the desired narrow dimension of the scrollbar window, +not including 3-D border, if any. For vertical +scrollbars this will be the width and for horizontal scrollbars +this will be the height. +The value may have any of the forms acceptable to Tk_GetPixels. +

    +
    + + +

    Description

    + +

    The scrollbar command creates a new window (given by the +pathName argument) and makes it into a scrollbar widget. +Additional +options, described above, may be specified on the command line +or in the option database +to configure aspects of the scrollbar such as its colors, orientation, +and relief. The scrollbar command returns its +pathName argument. At the time this command is invoked, +there must not exist a window named pathName, but +pathName’s parent must exist. +

    +

    A scrollbar is a widget that displays two arrows, one at each end of +the scrollbar, and a slider in the middle portion of the +scrollbar. A scrollbar is used to provide information about what +is visible in an associated window that displays an object +of some sort (such as a file being edited or a drawing). +The position and size of the slider indicate which portion of the +object is visible in the associated window. For example, if the +slider in a vertical scrollbar covers the top third of the area +between the two arrows, it means that the associated window displays +the top third of its object. +

    +

    Scrollbars can be used to adjust the view in the associated window +by clicking or dragging with the mouse. See the BINDINGS section +below for details. +

    + +

    A Scrollbar Widget’s Arguments

    + +

    The scrollbar command creates a new Tcl command whose +name is pathName. This +command may be used to invoke various +operations on the widget. It has the following general form: +

    +
    +
    pathName option ?arg arg ...?
+
    + +

    Option and the args +determine the exact behavior of the command. The following +commands are possible for scrollbar widgets: +

    +
    +
    pathName :configure ?option? ?value option value ...?
    +

    Query or modify the configuration options of the widget. +If no option is specified, returns a list describing all of +the available options for pathName (see Tk_ConfigureInfo for +information on the format of this list). If option is specified +with no value, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no option is specified). If +one or more option:value pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +Option may have any of the values accepted by the scrollbar +command. +

    +
    pathName :get
    +

    Returns a Tcl list containing four decimal values, which are +the current totalUnits, widnowUnits, firstUnit, +and lastUnit values for the scrollbar. These are the values +from the most recent set widget command on the scrollbar. +

    +
    pathName :set totalUnits windowUnits firstUnit lastUnit
    +

    This command is invoked to give the scrollbar information about the +widget associated with the scrollbar. TotalUnits is an integer +value giving the total size of the object being displayed in the +associated widget. The meaning of one unit depends on the associated +widget; for example, in a text editor widget units might +correspond to lines of +text. WindowUnits indicates the total number of units that +can fit in the associated window at one time. FirstUnit +and lastUnit give the indices of the first and last units +currently visible in the associated window (zero corresponds to the +first unit of the object). This command should +be invoked by the associated widget whenever its object or window +changes size and whenever it changes the view in its window. +

    +
    +
    + +

    Bindings

    + +

    The description below assumes a vertically-oriented scrollbar. +For a horizontally-oriented scrollbar replace the words “up”, “down”, +“top”, and “bottom” with “left”, “right”, “left”, +and “right”, respectively +

    +

    A scrollbar widget is divided into five distinct areas. From top +to bottom, they are: the top arrow, the top gap (the empty space +between the arrow and the slider), the slider, the bottom gap, +and the bottom arrow. Pressing mouse button 1 in each area has +a different effect: +

    +
    +
    top arrow
    +

    Causes the view in the associated window to shift up by one unit +(i.e. the object appears to move down one unit in its window). +If the button is held down the action will auto-repeat. +

    +
    top gap
    +

    Causes the view in the associated window to shift up by one +less than the number of units in the window +(i.e. the portion of the object that used to appear at the very +top of the window will now appear at the very bottom). +If the button is held down the action will auto-repeat. +

    +
    slider
    +

    Pressing button 1 in this area has no immediate effect except to +cause the slider to appear sunken rather than raised. However, +if the mouse is moved with the button down then the slider will +be dragged, adjusting the view as the mouse is moved. +

    +
    bottom gap
    +

    Causes the view in the associated window to shift down by one +less than the number of units in the window +(i.e. the portion of the object that used to appear at the very +bottom of the window will now appear at the very top). +If the button is held down the action will auto-repeat. +

    +
    bottom arrow
    +

    Causes the view in the associated window to shift down by one unit +(i.e. the object appears to move up one unit in its window). +If the button is held down the action will auto-repeat. +

    +

    Note: none of the actions described above has an immediate impact +on the position of the slider in the scrollbar. It simply invokes +the command specified in the command option to notify the +associated widget that a change in view is desired. If the view is +actually changed then the associated widget must invoke the +scrollbar’s set widget command to change what is displayed in +the scrollbar. +

    +
    +
    + +

    Keywords

    +

    scrollbar, widget +

    +
    +

    +Next: , Previous: , Up: Widgets   [Contents]

    +
    + + + + + diff --git a/info/gcl-tk/selection.html b/info/gcl-tk/selection.html new file mode 100644 index 0000000..6407abe --- /dev/null +++ b/info/gcl-tk/selection.html @@ -0,0 +1,177 @@ + + + + +GCL TK Manual: selection + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    +
    + +

    3.17 selection

    + +

    selection \- Manipulate the X selection +

    +

    Synopsis

    +

    selection option ?arg arg ...? +

    + +

    Description

    + +

    This command provides a Tcl interface to the X selection mechanism and +implements the full selection functionality described in the +X Inter-Client Communication Conventions Manual (ICCCM), except that it +supports only the primary selection. +

    +

    The first argument to selection determines the format of the +rest of the arguments and the behavior of the command. The following +forms are currently supported: +

    +
    +
    selection :clear window
    +

    If there is a selection anywhere on window’s display, clear it +so that no window owns the selection anymore. Returns an empty string. +

    +
    selection :get ?type?
    +

    Retrieves the value +of the primary selection and returns it as a result. +Type specifies the form in which the selection is to be +returned (the desired “target” for conversion, in ICCCM +terminology), and should be an +atom name such as STRING or FILE_NAME; see the Inter-Client +Communication Conventions Manual for complete details. +Type defaults to STRING. The selection :owner may choose to +return the selection in any of several different representation +formats, such as STRING, ATOM, INTEGER, etc. (this format is +different than the selection type; see the ICCCM for all the +confusing details). If the selection is returned in +a non-string format, such as INTEGER or ATOM, the selection +command converts it to string format as a collection of fields +separated by spaces: atoms are converted to their +textual names, and anything else is converted to hexadecimal +integers. +

    +
    selection :handle window command ?type? ?format?
    +

    Creates a handler for selection requests, such that command will +be executed whenever the primary selection is +owned by window and someone attempts to retrieve it in the form +given by type (e.g. type is specified in the selection :get +command). Type defaults to STRING. +If command is an empty string then any existing handler for +window and type is removed. +

    +

    When the selection is requested and window is the selection :owner +and type is the requested type, command will be executed +as a Tcl command with two additional numbers appended to it +(with space separators). The two additional numbers +are offset and maxBytes: offset specifies a starting +character position in the selection and maxBytes gives the maximum +number of bytes to retrieve. The command should return a value consisting +of at most maxBytes of the selection, starting at position +offset. For very large selections (larger than maxBytes) +the selection will be retrieved using several invocations of command +with increasing offset values. If command returns a string +whose length is less than maxBytes, the return value is assumed to +include all of the remainder of the selection; if the length of +command’s result is equal to maxBytes then +command will be invoked again, until it eventually +returns a result shorter than maxBytes. The value of maxBytes +will always be relatively large (thousands of bytes). +

    +

    If command returns an error then the selection retrieval is rejected +just as if the selection didn’t exist at all. +

    +

    The format argument specifies the representation that should be +used to transmit the selection to the requester (the second column of +Table 2 of the ICCCM), and defaults to STRING. If format is +STRING, the selection is transmitted as 8-bit ASCII characters (i.e. +just in the form returned by command). If format is +ATOM, then the return value from command is divided into fields +separated by white space; each field is converted to its atom value, +and the 32-bit atom value is transmitted instead of the atom name. +For any other format, the return value from command is +divided into fields separated by white space and each field is +converted to a 32-bit integer; an array of integers is transmitted +to the selection requester. +

    +

    The format argument is needed only for compatibility with +selection requesters that don’t use Tk. If the Tk toolkit is being +used to retrieve the selection then the value is converted back to +a string at the requesting end, so format is +irrelevant. +.RE +

    +
    selection :own ?window? ?command?
    +

    If window is specified, then it becomes the new selection :owner +and the command returns an empty string as result. +The existing owner, if any, is notified that it has lost the selection. +If command is specified, it is a Tcl script to execute when +some other window claims ownership of the selection away from +window. +If neither window nor command is specified then +the command returns the path name of the window in this application +that owns the selection, or an empty string if no window in this +application owns the selection. +

    +
    +
    + +

    Keywords

    +

    clear, format, handler, ICCCM, own, selection, target, type +

    +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    + + + + + diff --git a/info/gcl-tk/send.html b/info/gcl-tk/send.html new file mode 100644 index 0000000..b3b355b --- /dev/null +++ b/info/gcl-tk/send.html @@ -0,0 +1,112 @@ + + + + +GCL TK Manual: send + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    +
    + +

    3.18 send

    + +

    send \- Execute a command in a different interpreter +

    +

    Synopsis

    +

    send interp cmd ?arg arg ...? +

    + +

    Description

    + +

    This command arranges for cmd (and args) to be executed in the +interpreter named by interp. It returns the result or +error from that command execution. Interp must be the +name of an interpreter registered on the display associated with +the interpreter in which the command is invoked; it need not +be within the same process or application. If no arg +arguments are present, then the command to be executed is +contained entirely within the cmd argument. If one or +more args are present, they are concatenated to form the +command to be executed, just as for the eval Tcl command. +

    + +

    Security

    + +

    The send command is potentially a serious security loophole, +since any application that can connect to your X server can send +scripts to your applications. +These incoming scripts can use Tcl to read and +write your files and invoke subprocesses under your name. +Host-based access control such as that provided by xhost +is particularly insecure, since it allows anyone with an account +on particular hosts to connect to your server, and if disabled it +allows anyone anywhere to connect to your server. +In order to provide at least a small amount of +security, Tk checks the access control being used by the server +and rejects incoming sends unless (a) xhost-style access control +is enabled (i.e. only certain hosts can establish connections) and (b) the +list of enabled hosts is empty. +This means that applications cannot connect to your server unless +they use some other form of authorization +such as that provide by xauth. +

    + +

    Keywords

    +

    interpreter, remote execution, security, send +

    +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    + + + + + diff --git a/info/gcl-tk/text.html b/info/gcl-tk/text.html new file mode 100644 index 0000000..a05177f --- /dev/null +++ b/info/gcl-tk/text.html @@ -0,0 +1,910 @@ + + + + +GCL TK Manual: text + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Widgets   [Contents]

    +
    +
    + +

    2.9 text

    + +

    text \- Create and manipulate text widgets +

    +

    Synopsis

    +

    text pathName ?options? +

    +

    Standard Options

    + + +
    +
    background      foreground        insertWidth      selectBorderWidth 
+borderWidth     insertBackground  padX             selectForeground  
+cursor          insertBorderWidth padY             setGrid           
+exportSelection insertOffTime     relief           yScrollCommand    
+font            insertOnTime      selectBackground 
+
    + + +

    See options, for more information. +

    +

    Arguments for Text

    + + +
    +
    :height
    +

    Name="height" Class="Height" +


    + +

    Specifies the desired height for the window, in units of characters. +Must be at least one. +

    +
    + + +
    +
    :state
    +

    Name="state" Class="State" +


    + +

    Specifies one of two states for the text: normal or disabled. +If the text is disabled then characters may not be inserted or deleted +and no insertion cursor will be displayed, even if the input focus is +in the widget. +

    +
    + + +
    +
    :width
    +

    Name="width" Class="Width" +


    + +

    Specifies the desired width for the window in units of characters. +If the font doesn’t have a uniform width then the width of the +character “0” is used in translating from character units to +screen units. +

    +
    + + +
    +
    :wrap
    +

    Name="wrap" Class="Wrap" +


    + +

    Specifies how to handle lines in the text that are too long to be +displayed in a single line of the text’s window. +The value must be none or char or word. +A wrap mode of none means that each line of text appears as +exactly one line on the screen; extra characters that don’t fit +on the screen are not displayed. +In the other modes each line of text will be broken up into several +screen lines if necessary to keep all the characters visible. +In char mode a screen line break may occur after any character; +in word mode a line break will only be made at word boundaries. +

    +
    + + +

    Description

    + +

    The text command creates a new window (given by the +pathName argument) and makes it into a text widget. +Additional +options, described above, may be specified on the command line +or in the option database +to configure aspects of the text such as its default background color +and relief. The text command returns the +path name of the new window. +

    +

    A text widget displays one or more lines of text and allows that +text to be edited. +Text widgets support three different kinds of annotations on the +text, called tags, marks, and windows. +Tags allow different portions of the text +to be displayed with different fonts and colors. +In addition, Tcl commands can be associated with tags so +that commands are invoked when particular actions such as keystrokes +and mouse button presses occur in particular ranges of the text. +See TAGS below for more details. +

    +

    The second form of annotation consists of marks, which are floating +markers in the text. +Marks are used to keep track of various interesting positions in the +text as it is edited. +See MARKS below for more details. +

    +

    The third form of annotation allows arbitrary windows to be displayed +in the text widget. +See WINDOWS below for more details. +

    + +

    Indices

    + +

    Many of the widget commands for texts take one or more indices +as arguments. +An index is a string used to indicate a particular place within +a text, such as a place to insert characters or one endpoint of a +range of characters to delete. +Indices have the syntax +

    +

    base modifier modifier modifier ... +

    + +

    Where base gives a starting point and the modifiers +adjust the index from the starting point (e.g. move forward or +backward one character). Every index must contain a base, +but the modifiers are optional. +

    + +

    The base for an index must have one of the following forms: +

    +
    +
    line.char
    +

    Indicates char’th character on line line. +Lines are numbered from 1 for consistency with other UNIX programs +that use this numbering scheme. +Within a line, characters are numbered from 0. +

    +
    @x,y
    +

    Indicates the character that covers the pixel whose x and y coordinates +within the text’s window are x and y. +

    +
    end
    +

    Indicates the last character in the text, which is always a newline +character. +

    +
    mark
    +

    Indicates the character just after the mark whose name is mark. +

    +
    tag.first
    +

    Indicates the first character in the text that has been tagged with +tag. +This form generates an error if no characters are currently tagged +with tag. +

    +
    tag.last
    +

    Indicates the character just after the last one in the text that has +been tagged with tag. +This form generates an error if no characters are currently tagged +with tag. +

    +
    + + +

    If modifiers follow the base index, each one of them must have one +of the forms listed below. Keywords such as chars and wordend +may be abbreviated as long as the abbreviation is unambiguous. +

    +
    +
    + count chars
    +

    Adjust the index forward by count characters, moving to later +lines in the text if necessary. If there are fewer than count +characters in the text after the current index, then set the index +to the last character in the text. +Spaces on either side of count are optional. +

    +
    - count chars
    +

    Adjust the index backward by count characters, moving to earlier +lines in the text if necessary. If there are fewer than count +characters in the text before the current index, then set the index +to the first character in the text. +Spaces on either side of count are optional. +

    +
    + count lines
    +

    Adjust the index forward by count lines, retaining the same +character position within the line. If there are fewer than count +lines after the line containing the current index, then set the index +to refer to the same character position on the last line of the text. +Then, if the line is not long enough to contain a character at the indicated +character position, adjust the character position to refer to the last +character of the line (the newline). +Spaces on either side of count are optional. +

    +
    - count lines
    +

    Adjust the index backward by count lines, retaining the same +character position within the line. If there are fewer than count +lines before the line containing the current index, then set the index +to refer to the same character position on the first line of the text. +Then, if the line is not long enough to contain a character at the indicated +character position, adjust the character position to refer to the last +character of the line (the newline). +Spaces on either side of count are optional. +

    +
    linestart
    +

    Adjust the index to refer to the first character on the line. +

    +
    lineend
    +

    Adjust the index to refer to the last character on the line (the newline). +

    +
    wordstart
    +

    Adjust the index to refer to the first character of the word containing +the current index. A word consists of any number of adjacent characters +that are letters, digits, or underscores, or a single character that +is not one of these. +

    +
    wordend
    +

    Adjust the index to refer to the character just after the last one of the +word containing the current index. If the current index refers to the last +character of the text then it is not modified. +

    +
    + + +

    If more than one modifier is present then they are applied in +left-to-right order. For example, the index “\fBend \- 1 chars” +refers to the next-to-last character in the text and +“\fBinsert wordstart \- 1 c” refers to the character just before +the first one in the word containing the insertion cursor. +

    + +

    Tags

    + +

    The first form of annotation in text widgets is a tag. +A tag is a textual string that is associated with some of the characters +in a text. +There may be any number of tags associated with characters in a +text. +Each tag may refer to a single character, a range of characters, or +several ranges of characters. +An individual character may have any number of tags associated with it. +

    +

    A priority order is defined among tags, and this order is used in +implementing some of the tag-related functions described below. +When a tag is defined (by associating it with characters or setting +its display options or binding commands to it), it is given +a priority higher than any existing tag. +The priority order of tags may be redefined using the +“pathName :tag :raise” and “pathName :tag :lower” +widget commands. +

    +

    Tags serve three purposes in text widgets. +First, they control the way information is displayed on the screen. +By default, characters are displayed as determined by the +background, font, and foreground options for the +text widget. +However, display options may be associated with individual tags +using the “pathName :tag configure” widget command. +If a character has been tagged, then the display options associated +with the tag override the default display style. +The following options are currently supported for tags: +

    +
    +
    :background color
    +

    Color specifies the background color to use for characters +associated with the tag. +It may have any of the forms accepted by Tk_GetColor. +

    +
    :bgstipple bitmap
    +

    Bitmap specifies a bitmap that is used as a stipple pattern +for the background. +It may have any of the forms accepted by Tk_GetBitmap. +If bitmap hasn’t been specified, or if it is specified +as an empty string, then a solid fill will be used for the +background. +

    +
    :borderwidth pixels
    +

    Pixels specifies the width of a 3-D border to draw around +the background. +It may have any of the forms accepted by Tk_GetPixels. +This option is used in conjunction with the :relief +option to give a 3-D appearance to the background for characters; +it is ignored unless the :background option +has been set for the tag. +

    +
    :fgstipple bitmap
    +

    Bitmap specifies a bitmap that is used as a stipple pattern +when drawing text and other foreground information such as +underlines. +It may have any of the forms accepted by Tk_GetBitmap. +If bitmap hasn’t been specified, or if it is specified +as an empty string, then a solid fill will be used. +

    +
    :font fontName
    +

    FontName is the name of a font to use for drawing characters. +It may have any of the forms accepted by Tk_GetFontStruct. +

    +
    :foreground color
    +

    Color specifies the color to use when drawing text and other +foreground information such as underlines. +It may have any of the forms accepted by Tk_GetColor. +

    +
    :relief relief
    +

    \fIRelief specifies the 3-D relief to use for drawing backgrounds, +in any of the forms accepted by Tk_GetRelief. +This option is used in conjunction with the :borderwidth +option to give a 3-D appearance to the background for characters; +it is ignored unless the :background option +has been set for the tag. +

    +
    :underline boolean
    +

    Boolean specifies whether or not to draw an underline underneath +characters. +It may have any of the forms accepted by Tk_GetBoolean. +

    +

    If a character has several tags associated with it, and if their +display options conflict, then the options of the highest priority +tag are used. +If a particular display option hasn’t been specified for a +particular tag, or if it is specified as an empty string, then +that option will never be used; the next-highest-priority +tag’s option will used instead. +If no tag specifies a particular display optionl, then the default +style for the widget will be used. +

    +

    The second purpose for tags is event bindings. +You can associate bindings with a tag in much the same way you can +associate bindings with a widget class: whenever particular X +events occur on characters with the given tag, a given +Tcl command will be executed. +Tag bindings can be used to give behaviors to ranges of characters; +among other things, this allows hypertext-like +features to be implemented. +For details, see the description of the tag bind widget +command below. +

    +

    The third use for tags is in managing the selection. +See THE SELECTION below. +

    +
    +
    + +

    Marks

    + +

    The second form of annotation in text widgets is a mark. +Marks are used for remembering particular places in a text. +They are something like tags, in that they have names and +they refer to places in the file, but a mark isn’t associated +with particular characters. +Instead, a mark is associated with the gap between two characters. +Only a single position may be associated with a mark at any given +time. +If the characters around a mark are deleted the mark will still +remain; it will just have new neighbor characters. +In contrast, if the characters containing a tag are deleted then +the tag will no longer have an association with characters in +the file. +Marks may be manipulated with the “pathName :mark” widget +command, and their current locations may be determined by using the +mark name as an index in widget commands. +

    +

    The name space for marks is different from that for tags: the +same name may be used for both a mark and a tag, but they will refer +to different things. +

    +

    Two marks have special significance. +First, the mark insert is associated with the insertion cursor, +as described under THE INSERTION CURSOR below. +Second, the mark current is associated with the character +closest to the mouse and is adjusted automatically to track the +mouse position and any changes to the text in the widget (one +exception: current is not updated in response to mouse +motions if a mouse button is down; the update will be deferred +until all mouse buttons have been released). +Neither of these special marks may be unset. +

    + +

    Windows

    + +

    The third form of annotation in text widgets is a window. +Window support isn’t implemented yet, but when it is it will be +described here. +

    + +

    The Selection

    + +

    Text widgets support the standard X selection. +Selection support is implemented via tags. +If the exportSelection option for the text widget is true +then the sel tag will be associated with the selection: +

      +
    • [1] +Whenever characters are tagged with sel the text widget +will claim ownership of the selection. +
    • [2] +Attempts to retrieve the +selection will be serviced by the text widget, returning all the +charaters with the sel tag. +
    • [3] +If the selection is claimed away by another application or by another +window within this application, then the sel tag will be removed +from all characters in the text. +
    + +

    The sel tag is automatically defined when a text widget is +created, and it may not be deleted with the “pathName :tag delete” +widget command. Furthermore, the selectBackground, +selectBorderWidth, and selectForeground options for +the text widget are tied to the :background, +:borderwidth, and :foreground options for the sel +tag: changes in either will automatically be reflected in the +other. +

    + +

    The Insertion Cursor

    + +

    The mark named insert has special significance in text widgets. +It is defined automatically when a text widget is created and it +may not be unset with the “pathName :mark unset” widget +command. +The insert mark represents the position of the insertion +cursor, and the insertion cursor will automatically be drawn at +this point whenever the text widget has the input focus. +

    + +

    A Text Widget’s Arguments

    + +

    The text command creates a new Tcl command whose +name is the same as the path name of the text’s window. This +command may be used to invoke various +operations on the widget. It has the following general form: +

    +
    +
    pathName option ?arg arg ...?
+
    + +

    PathName is the name of the command, which is the same as +the text widget’s path name. Option and the args +determine the exact behavior of the command. The following +commands are possible for text widgets: +

    +
    +
    pathName :compare index1 op index2
    +

    Compares the indices given by index1 and index2 according +to the relational operator given by op, and returns 1 if +the relationship is satisfied and 0 if it isn’t. +Op must be one of the operators <, <=, ==, >=, >, or !=. +If op is == then 1 is returned if the two indices refer to +the same character, if op is < then 1 is returned if index1 +refers to an earlier character in the text than index2, and +so on. +

    +
    pathName :configure ?option? ?value option value ...?
    +

    Query or modify the configuration options of the widget. +If no option is specified, returns a list describing all of +the available options for pathName (see Tk_ConfigureInfo for +information on the format of this list). If option is specified +with no value, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no option is specified). If +one or more option:value pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +Option may have any of the values accepted by the text +command. +

    +
    pathName :debug ?boolean?
    +

    If boolean is specified, then it must have one of the true or +false values accepted by Tcl_GetBoolean. +If the value is a true one then internal consistency checks will be +turned on in the B-tree code associated with text widgets. +If boolean has a false value then the debugging checks will +be turned off. +In either case the command returns an empty string. +If boolean is not specified then the command returns on +or off to indicate whether or not debugging is turned on. +There is a single debugging switch shared by all text widgets: turning +debugging on or off in any widget turns it on or off for all widgets. +For widgets with large amounts of text, the consistency checks may +cause a noticeable slow-down. +

    +
    pathName :delete index1 ?index2?
    +

    Delete a range of characters from the text. +If both index1 and index2 are specified, then delete +all the characters starting with the one given by index1 +and stopping just before index2 (i.e. the character at +index2 is not deleted). +If index2 doesn’t specify a position later in the text +than index1 then no characters are deleted. +If index2 isn’t specified then the single character at +index1 is deleted. +It is not allowable to delete characters in a way that would leave +the text without a newline as the last character. +The command returns an empty string. +

    +
    pathName :get index1 ?index2?
    +

    Return a range of characters from the text. +The return value will be all the characters in the text starting +with the one whose index is index1 and ending just before +the one whose index is index2 (the character at index2 +will not be returned). +If index2 is omitted then the single character at index1 +is returned. +If there are no characters in the specified range (e.g. index1 +is past the end of the file or index2 is less than or equal +to index1) then an empty string is returned. +

    +
    pathName :index index
    +

    Returns the position corresponding to index in the form +line.char where line is the line number and char +is the character number. +Index may have any of the forms described under INDICES above. +

    +
    pathName :insert \fIindex chars
    +

    Inserts chars into the text just before the character at +index and returns an empty string. +It is not possible to insert characters after the last newline +of the text. +

    +
    pathName :mark option ?arg arg ...?
    +

    This command is used to manipulate marks. The exact behavior of +the command depends on the option argument that follows +the mark argument. The following forms of the command +are currently supported: +

    +
    pathName :mark :names
    +

    Returns a list whose elements are the names of all the marks that +are currently set. +

    +
    pathName :mark :set markName index
    +

    Sets the mark named markName to a position just before the +character at index. +If markName already exists, it is moved from its old position; +if it doesn’t exist, a new mark is created. +This command returns an empty string. +

    +
    pathName :mark :unset markName ?markName markName ...?
    +

    Remove the mark corresponding to each of the markName arguments. +The removed marks will not be usable in indices and will not be +returned by future calls to “pathName :mark names”. +This command returns an empty string. +

    +
    + +
    +
    pathName :scan option args
    +

    This command is used to implement scanning on texts. It has +two forms, depending on option: +

    +
    pathName :scan :mark y
    +

    Records y and the current view in the text window; used in +conjunction with later scan dragto commands. Typically this +command is associated with a mouse button press in the widget. It +returns an empty string. +

    +
    pathName :scan :dragto y
    +

    This command computes the difference between its y argument +and the y argument to the last scan mark command for +the widget. It then adjusts the view up or down by 10 times the +difference in y-coordinates. This command is typically associated +with mouse motion events in the widget, to produce the effect of +dragging the text at high speed through the window. The return +value is an empty string. +

    +
    + +
    +
    pathName :tag option ?arg arg ...?
    +

    This command is used to manipulate tags. The exact behavior of the +command depends on the option argument that follows the +tag argument. The following forms of the command are currently +supported: +

    +
    +
    pathName :tag :add tagName index1 ?index2?
    +

    Associate the tag tagName with all of the characters starting +with index1 and ending just before +index2 (the character at index2 isn’t tagged). +If index2 is omitted then the single character at +index1 is tagged. +If there are no characters in the specified range (e.g. index1 +is past the end of the file or index2 is less than or equal +to index1) then the command has no effect. +This command returns an empty string. +

    +
    pathName :tag :bind tagName ?sequence? ?command?
    +

    This command associates command with the tag given by +tagName. +Whenever the event sequence given by sequence occurs for a +character that has been tagged with tagName, +the command will be invoked. +This widget command is similar to the bind command except that +it operates on characters in a text rather than entire widgets. +See the bind manual entry for complete details +on the syntax of sequence and the substitutions performed +on command before invoking it. +If all arguments are specified then a new binding is created, replacing +any existing binding for the same sequence and tagName +(if the first character of command is “+” then command +augments an existing binding rather than replacing it). +In this case the return value is an empty string. +If command is omitted then the command returns the command +associated with tagName and sequence (an error occurs +if there is no such binding). +If both command and sequence are omitted then the command +returns a list of all the sequences for which bindings have been +defined for tagName. +

    + +

    The only events for which bindings may be specified are those related +to the mouse and keyboard, such as Enter, Leave, +ButtonPress, Motion, and KeyPress. +Event bindings for a text widget use the current mark +described under MARKS above. +Enter events trigger for a character when it +becomes the current character (i.e. the current mark moves +to just in front of that character). +Leave events trigger for a character when it ceases to be +the current item (i.e. the current mark moves away from +that character, or the character is deleted). +These events are different than Enter and Leave +events for windows. +Mouse and keyboard events are directed to the current character. +

    + +

    It is possible for the current character to have multiple tags, +and for each of them to have a binding for a particular event +sequence. +When this occurs, the binding from the highest priority tag is +used. +If a particular tag doesn’t have a binding that matches an +event, then the tag is ignored and tags with lower priority +will be checked. +

    + +

    If bindings are created for the widget as a whole using the +bind command, then those bindings will supplement the +tag bindings. +This means that a single event can trigger two Tcl scripts, +one for a widget-level binding and one for a tag-level +binding. +

    + +
    +
    pathName :tag :configure tagName ?option? ?value? ?option value ...?
    +

    This command is similar to the configure widget command except +that it modifies options associated with the tag given by tagName +instead of modifying options for the overall text widget. +If no option is specified, the command returns a list describing +all of the available options for tagName (see Tk_ConfigureInfo +for information on the format of this list). +If option is specified with no value, then the command returns +a list describing the one named option (this list will be identical to +the corresponding sublist of the value returned if no option +is specified). +If one or more option:value pairs are specified, then the command +modifies the given option(s) to have the given value(s) in tagName; +in this case the command returns an empty string. +See TAGS above for details on the options available for tags. +

    +
    pathName :tag :delete tagName ?tagName ...?
    +

    Deletes all tag information for each of the tagName +arguments. +The command removes the tags from all characters in the file +and also deletes any other information associated with the tags, +such as bindings and display information. +The command returns an empty string. +

    +
    pathName :tag :lower tagName ?belowThis?
    +

    Changes the priority of tag tagName so that it is just lower +in priority than the tag whose name is belowThis. +If belowThis is omitted, then tagName’s priority +is changed to make it lowest priority of all tags. +

    +
    pathName :tag :names ?index?
    +

    Returns a list whose elements are the names of all the tags that +are active at the character position given by index. +If index is omitted, then the return value will describe +all of the tags that exist for the text (this includes all tags +that have been named in a “pathName :tag” widget +command but haven’t been deleted by a “pathName :tag :delete” +widget command, even if no characters are currently marked with +the tag). +The list will be sorted in order from lowest priority to highest +priority. +

    +
    pathName :tag :nextrange tagName index1 ?index2?
    +

    This command searches the text for a range of characters tagged +with tagName where the first character of the range is +no earlier than the character at index1 and no later than +the character just before index2 (a range starting at +index2 will not be considered). +If several matching ranges exist, the first one is chosen. +The command’s return value is a list containing +two elements, which are the index of the first character of the +range and the index of the character just after the last one in +the range. +If no matching range is found then the return value is an +empty string. +If index2 is not given then it defaults to the end of the text. +

    +
    pathName :tag :raise tagName ?aboveThis?
    +

    Changes the priority of tag tagName so that it is just higher +in priority than the tag whose name is aboveThis. +If aboveThis is omitted, then tagName’s priority +is changed to make it highest priority of all tags. +

    +
    pathName :tag :ranges tagName
    +

    Returns a list describing all of the ranges of text that have been +tagged with tagName. +The first two elements of the list describe the first tagged range +in the text, the next two elements describe the second range, and +so on. +The first element of each pair contains the index of the first +character of the range, and the second element of the pair contains +the index of the character just after the last one in the +range. +If there are no characters tagged with tag then an +empty string is returned. +

    +
    pathName :tag :remove tagName index1 ?index2?
    +

    Remove the tag tagName from all of the characters starting +at index1 and ending just before +index2 (the character at index2 isn’t affected). +If index2 is omitted then the single character at +index1 is untagged. +If there are no characters in the specified range (e.g. index1 +is past the end of the file or index2 is less than or equal +to index1) then the command has no effect. +This command returns an empty string. +

    +
    +
    +
    +
    pathName :yview ?:pickplace? what
    +

    This command changes the view in the widget’s window so that the line +given by what is visible in the window. +What may be either an absolute line number, where 0 corresponds +to the first line of the file, or an index with any of the forms +described under INDICES above. +The first form (absolute line number) is used in the commands issued +by scrollbars to control the widget’s view. +If the :pickplace option isn’t specified then what will +appear at the top of the window. +If :pickplace is specified then the widget chooses where +what appears in the window: +

      +
    • [1] +If what is already visible somewhere in the window then the +command does nothing. +
    • [2] +If what is only a few lines off-screen above the window then +it will be positioned at the top of the window. +
    • [3] +If what is only a few lines off-screen below the window then +it will be positioned at the bottom of the window. +
    • [4] +Otherwise, what will be centered in the window. +
    + +

    The :pickplace option is typically used after inserting text +to make sure that the insertion cursor is still visible on the screen. +This command returns an empty string. +

    +
    + + + +

    Bindings

    + +

    Tk automatically creates class bindings for texts that give them +the following default behavior: +

      +
    • [1] +Pressing mouse button 1 in an text positions the insertion cursor +just before the character underneath the mouse cursor and sets the +input focus to this widget. +
    • [2] +Dragging with mouse button 1 strokes out a selection between +the insertion cursor and the character under the mouse. +
    • [3] +If you double-press mouse button 1 then the word under the mouse cursor +will be selected, the insertion cursor will be positioned at the +beginning of the word, and dragging the mouse will stroke out a selection +whole words at a time. +
    • [4] +If you triple-press mouse button 1 then the line under the mouse cursor +will be selected, the insertion cursor will be positioned at the +beginning of the line, and dragging the mouse will stroke out a selection +whole line at a time. +
    • [5] +The ends of the selection can be adjusted by dragging with mouse +button 1 while the shift key is down; this will adjust the end +of the selection that was nearest to the mouse cursor when button +1 was pressed. If the selection was made in word or line mode then +it will be adjusted in this same mode. +
    • [6] +The view in the text can be adjusted by dragging with mouse button 2. +
    • [7] +If the input focus is in a text widget and characters are typed on the +keyboard, the characters are inserted just before the insertion cursor. +
    • [8] +Control+h and the Backspace and Delete keys erase the character just +before the insertion cursor. +
    • [9] +Control+v inserts the current selection just before the insertion cursor. +
    • [10] +Control+d deletes the selected characters; an error occurs if the selection +is not in this widget. +
    + +

    If the text is disabled using the state option, then the text’s +view can still be adjusted and text in the text can still be selected, +but no insertion cursor will be displayed and no text modifications will +take place. +

    +

    The behavior of texts can be changed by defining new bindings for +individual widgets or by redefining the class bindings. +

    + +

    "Performance Issues"

    + +

    Text widgets should run efficiently under a variety +of conditions. The text widget uses about 2-3 bytes of +main memory for each byte of text, so texts containing a megabyte +or more should be practical on most workstations. +Text is represented internally with a modified B-tree structure +that makes operations relatively efficient even with large texts. +Tags are included in the B-tree structure in a way that allows +tags to span large ranges or have many disjoint smaller ranges +without loss of efficiency. +Marks are also implemented in a way that allows large numbers of +marks. +The only known mode of operation where a text widget may not run +efficiently is if it has a very large number of different tags. +Hundreds of tags should be fine, or even a thousand, +but tens of thousands of tags will make texts consume a lot of +memory and run slowly. +

    + +

    Keywords

    +

    text, widget +

    +
    +

    +Next: , Previous: , Up: Widgets   [Contents]

    +
    + + + + + diff --git a/info/gcl-tk/tk.html b/info/gcl-tk/tk.html new file mode 100644 index 0000000..102c05e --- /dev/null +++ b/info/gcl-tk/tk.html @@ -0,0 +1,117 @@ + + + + +GCL TK Manual: tk + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    +
    + +

    3.19 tk

    + +

    tk \- Manipulate Tk internal state +

    +

    Synopsis

    +

    tk option ?arg arg ...? +

    + +

    Description

    + +

    The tk command provides access to miscellaneous +elements of Tk’s internal state. +Most of the information manipulated by this command pertains to the +application as a whole, or to a screen or display, rather than to a +particular window. +The command can take any of a number of different forms +depending on the option argument. The legal forms are: +

    +
    +
    tk :colormodel window ?newValue?
    +

    If newValue isn’t specified, this command returns the current +color model in use for window’s screen, which will be either +color or monochrome. +If newValue is specified, then it must be either color +or monochrome or an abbreviation of one of them; +the color model for window’s screen is set to this value. +

    +
    + + +

    The color model is used by Tk and its widgets to determine whether +it should display in black and white only or use colors. +A single color model is shared by all of the windows managed by one +process on a given screen. +The color model for a screen is set initially by Tk to monochrome +if the display has four or fewer bit planes and to color otherwise. +The color model will automatically be changed from color to +monochrome if Tk fails to allocate a color because all entries +in the colormap were in use. +An application can change its own color model at any time (e.g. it +might change the model to monochrome in order to conserve +colormap entries, or it might set the model to color +to use color on a four-bit display in special circumstances), but +an application is not allowed to change the color model to color +unless the screen has at least two bit planes. +.RE +

    + +

    Keywords

    +

    color model, internal state +

    +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    + + + + + diff --git a/info/gcl-tk/tk_002ddialog.html b/info/gcl-tk/tk_002ddialog.html new file mode 100644 index 0000000..3ff2139 --- /dev/null +++ b/info/gcl-tk/tk_002ddialog.html @@ -0,0 +1,123 @@ + + + + +GCL TK Manual: tk-dialog + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    +
    + +

    3.4 tk-dialog

    + +

    tk-dialog \- Create modal dialog and wait for response +

    +

    Synopsis

    +

    tk-dialog window title text bitmap default string string ... +

    + +

    Description

    + +

    This procedure is part of the Tk script library. +Its arguments describe a dialog box: +

    +
    +
    window
    +

    Name of top-level window to use for dialog. Any existing window +by this name is destroyed. +

    +
    title
    +

    Text to appear in the window manager’s title bar for the dialog. +

    +
    text
    +

    Message to appear in the top portion of the dialog box. +

    +
    bitmap
    +

    If non-empty, specifies a bitmap to display in the top portion of +the dialog, to the left of the text. +If this is an empty string then no bitmap is displayed in the dialog. +

    +
    default
    +

    If this is an integer greater than or equal to zero, then it gives +the index of the button that is to be the default button for the dialog +(0 for the leftmost button, and so on). +If less than zero or an empty string then there won’t be any default +button. +

    +
    string
    +

    There will be one button for each of these arguments. +Each string specifies text to display in a button, +in order from left to right. +

    +

    After creating a dialog box, tk-dialog waits for the user to +select one of the buttons either by clicking on the button with the +mouse or by typing return to invoke the default button (if any). +Then it returns the index of the selected button: 0 for the leftmost +button, 1 for the button next to it, and so on. +

    +

    While waiting for the user to respond, tk-dialog sets a local +grab. This prevents the user from interacting with the application +in any way except to invoke the dialog box. +

    +
    +
    + +

    Keywords

    +

    bitmap, dialog, modal +

    +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    + + + + + diff --git a/info/gcl-tk/tk_002dlistbox_002dsingle_002dselect.html b/info/gcl-tk/tk_002dlistbox_002dsingle_002dselect.html new file mode 100644 index 0000000..4d07b13 --- /dev/null +++ b/info/gcl-tk/tk_002dlistbox_002dsingle_002dselect.html @@ -0,0 +1,86 @@ + + + + +GCL TK Manual: tk-listbox-single-select + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    +
    + +

    3.8 tk-listbox-single-select

    + +

    tk-listbox-single-select \- Allow only one selected element in listbox(es) +

    +

    Synopsis

    +

    tk-listbox-single-select arg ?arg arg ...? +

    + +

    Description

    + +

    This command is a Tcl procedure provided as part of the Tk script library. +It takes as arguments the path names of one or more listbox widgets, +or the value Listbox. +For each named widget, tk-listbox-single-select modifies the +bindings of the widget so that only a single element may be selected +at a time (the normal configuration allows multiple elements to be +selected). +If the keyword Listbox is among the window arguments, +then the class bindings for listboxes are changed so that all +listboxes have the one-selection-at-a-time behavior. +

    + +

    Keywords

    +

    listbox, selection +

    + + + + diff --git a/info/gcl-tk/tk_002dmenu_002dbar.html b/info/gcl-tk/tk_002dmenu_002dbar.html new file mode 100644 index 0000000..4dc542d --- /dev/null +++ b/info/gcl-tk/tk_002dmenu_002dbar.html @@ -0,0 +1,200 @@ + + + + +GCL TK Manual: tk-menu-bar + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    +
    + +

    3.10 tk-menu-bar

    + +

    tk-menu-bar, tk_bindForTraversal \- Support for menu bars +

    +

    Synopsis

    +

    tk-menu-bar frame ?menu menu ...? +


    +

    tk_bindForTraversal arg arg ... +

    + +

    Description

    + +

    These two commands are Tcl procedures in the Tk script library. +They provide support for menu bars. +A menu bar is a frame that contains a collection of menu buttons that +work together, so that the user can scan from one menu to another with +the mouse: if the mouse button is pressed over one menubutton (causing it +to post its menu) and the mouse is moved over another menubutton +in the same menu bar without releasing the mouse button, then the +menu of the first menubutton is unposted and the menu of the +new menubutton is posted instead. +Menus in a menu bar can also be accessed using keyboard traversal (i.e. +by typing keystrokes instead of using the mouse). +In order for an application to use these procedures, it must do three +things, which are described in the paragraphs below. +

    +

    First, each application must call tk-menu-bar to provide information +about the menubar. +The frame argument gives the path name of the frame that contains +all of the menu buttons, and the menu arguments give path names +for all of the menu buttons associated with the menu bar. +Normally frame is the parent of each of the menu’s. +This need not be the case, but frame must be an ancestor of +each of the menu’s in order for grabs to work correctly when +the mouse is used to pull down menus. +The order of the menu arguments determines the traversal order +for the menu buttons. +If tk-menu-bar is called without any menu arguments, it +returns a list containing the current menu buttons for frame, +or an empty string if frame isn’t currently set up as a menu bar. +If tk-menu-bar is called with a single menu argument +consisting of an empty string, any menubar information for frame +is removed; from now on the menu buttons will function independently +without keyboard traversal. +Only one menu bar may be defined at a time within each top-level window. +

    +

    The second thing an application must do is to identify the traversal +characters for menu buttons and menu entries. +This is done by underlining those characters using the +:underline options for the widgets. +The menu traversal system uses this information to traverse the +menus under keyboard control (see below). +

    +

    The third thing that an application must do +is to make sure that the input focus is always in a window that +has been configured to support menu traversal. +If the input focus is none then input characters will +be discarded and no menu traversal will be possible. +If you have no other place to set the focus, set it to the menubar +widget: tk-menu-bar creates bindings for its frame argument to +support menu traversal. +

    +

    The Tk startup scripts configure all the Tk widget classes with +bindings to support menu traversal, so menu traversal will be possible +regardless of which widget has the focus. +If your application defines new classes of widgets that support the +input focus, then you should call tk_bindForTraversal for +each of these classes. +Tk_bindForTraversal takes any number of arguments, each of +which is a widget path name or widget class name. +It sets up bindings for all the named widgets and +classes so that the menu traversal system will be invoked when +appropriate keystrokes are typed in those widgets or classes. +

    + +

    "Menu Traversal Bindings"

    + +

    Once an application has made the three arrangements described +above, menu traversal will be available. +At any given time, the only menus available for traversal +are those associated with the top-level window containing the +input focus. +Menu traversal is initiated by one of the following actions: +

      +
    • [1] +If <F10> is typed, then the first menu button in the list for the +top-level window is posted and the first entry within that +menu is selected. +
    • [2] +If <Alt-key> is pressed, then the menu button that has key +as its underlined character is posted +and the first entry within that menu is selected. +The comparison between key and the underlined characters +ignores case differences. +If no menu button matches key then the keystroke has no +effect. +
    • [3] +Clicking mouse button 1 on a menu button posts that menu and selects +its first entry. +
    + + +

    Once a menu has been posted, the input focus is switched to that +menu and the following actions are possible: +

      +
    • [1] +Typing <ESC> or clicking mouse button 1 outside the menu button or +its menu will abort the menu traversal. +
    • [2] +If <Alt-key> is pressed, then the entry in the posted menu +whose underlined character is key is invoked. +This causes the menu to be unposted, the entry’s action to be +taken, and the menu traversal to end. +The comparison between key and underlined characters ignores +case differences. +If no menu entry matches key then the keystroke is ignored. +
    • [3] +The arrow keys may be used to move among entries and menus. +The left and right arrow keys move circularly among the available +menus and the up and down arrow keys move circularly among the +entries in the current menu. +
    • [4] +If <Return> is pressed, the selected entry in the posted menu is +invoked, which causes the menu to be unposted, the entry’s action +to be taken, and the menu traversal to end. +
    + +

    When a menu traversal completes, the input focus reverts to the +window that contained it when the traversal started. +

    + +

    Keywords

    +

    keyboard traversal, menu, menu bar, post +

    +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    + + + + + diff --git a/info/gcl-tk/tkconnect.html b/info/gcl-tk/tkconnect.html new file mode 100644 index 0000000..14c6d95 --- /dev/null +++ b/info/gcl-tk/tkconnect.html @@ -0,0 +1,121 @@ + + + + +GCL TK Manual: tkconnect + + + + + + + + + + + + + + + + + + + +
    +

    +Previous: , Up: General   [Contents]

    +
    +
    + +

    1.8 tkconnect

    + +
    +
    tkconnect &key host display can-rsh gcltksrv
+
    + +

    This function provides a connection to a graphics server process, which +in turn connects to possibly several graphics display screens. The +graphics server process, called gcltksrv may or may not run +on the same machine as the lisp to which it is attached. +display +indicates the name of the default display to connect to, and this +in turn defaults to the value of the environment variable DISPLAY. +

    +

    When tkconnect is invoked, a socket is opened and it waits for +a graphics process to connect to it. If the host argument is not +supplied, then a process will be spawned which will connect back to +the lisp process. The name of the command for invoking the process +is the value of the gcltksrv argument, which defaults to +the value of the environment variable GCL_TK_SERVER. If that variable +is not set, then the lisp *lib-directory* is searched for +an entry gcl-tk/gcltksrv. +

    +

    If host is supplied, then a command to run on the remote machine +will be printed on standard output. If can-rsh is not nil, +then the command will not be printed, but rather an attempt will be +made to rsh to the machine, and to run the command. +

    +

    Thus +

    +
    +
    (tkconnect)
+
    + +

    would start the process on the local machine, and use for display +the value of the environment variable DISPLAY. +

    +
    +
    (tkconnect :host "max.ma.utexas.edu" :can-rsh t)
+
    + +

    would cause an attempt to rsh to max and to run the command +there, to connect back to the appropriate port on the localhost. +

    +

    You may indicate that different toplevel windows be on different +displays, by using the :display argument when creating the +window, See toplevel. +

    +

    Clearly you must have a copy of the program gcltksrv and TK +libraries installed on the machine where you wish to run the server. +

    + + + +
    +
    +

    +Previous: , Up: General   [Contents]

    +
    + + + + + diff --git a/info/gcl-tk/tkerror.html b/info/gcl-tk/tkerror.html new file mode 100644 index 0000000..301a836 --- /dev/null +++ b/info/gcl-tk/tkerror.html @@ -0,0 +1,112 @@ + + + + +GCL TK Manual: tkerror + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    +
    + +

    3.20 tkerror

    + +

    tkerror \- Command invoked to process background errors +

    +

    Synopsis

    +

    tkerror message +

    + +

    Description

    + +

    The tkerror command doesn’t exist as built-in part of Tk. Instead, +individual applications or users can define a tkerror +command (e.g. as a Tcl procedure) if they wish to handle background +errors. +

    +

    A background error is one that occurs in a command that didn’t +originate with the application. For example, if an error occurs +while executing a command specified with a bind of after +command, then it is a background error. For a non-background error, +the error can simply be returned up through nested Tcl command +evaluations until it reaches the top-level code in the application; +then the application can report the error in whatever way it +wishes. When a background error occurs, the unwinding ends in +the Tk library and there is no obvious way for Tk to report +the error. +

    +

    When Tk detects a background error, it invokes the tkerror +command, passing it the error message as its only argument. +Tk assumes that the application has implemented the tkerror +command, and that the command will report the error in a way that +makes sense for the application. Tk will ignore any result returned +by the tkerror command. +

    +

    If another Tcl error occurs within the tkerror command +then Tk reports the error itself by writing a message +to stderr. +

    +

    The Tk script library includes a default tkerror procedure +that posts a dialog box containing the error message and offers +the user a chance to see a stack trace that shows where the +error occurred. +

    + +

    Keywords

    +

    background error, reporting +

    +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    + + + + + diff --git a/info/gcl-tk/tkvars.html b/info/gcl-tk/tkvars.html new file mode 100644 index 0000000..5b31d4b --- /dev/null +++ b/info/gcl-tk/tkvars.html @@ -0,0 +1,126 @@ + + + + +GCL TK Manual: tkvars + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    +
    + +

    3.21 tkvars

    + +

    tkvars \- Variables used or set by Tk +

    + +

    Description

    + +

    The following Tcl variables are either set or used by Tk at various times +in its execution: +

    +
    +
    tk_library
    +

    Tk sets this variable hold the name of a directory containing a library +of Tcl scripts related to Tk. These scripts include an initialization +file that is normally processed whenever a Tk application starts up, +plus other files containing procedures that implement default behaviors +for widgets. +The value of this variable is taken from the TK_LIBRARY environment +variable, if one exists, or else from a default value compiled into +Tk. +

    +
    tk_patchLevel
    +

    Contains a decimal integer giving the current patch level for Tk. +The patch level is incremented for each new release or patch, and +it uniquely identifies an official version of Tk. +

    +
    tk_priv
    +

    This variable is an array containing several pieces of information +that are private to Tk. The elements of tk_priv are used by +Tk library procedures and default bindings. +They should not be accessed by any code outside Tk. +

    +
    tk_strictMotif
    +

    This variable is set to zero by default. +If an application sets it to one, then Tk attempts to adhere as +closely as possible to Motif look-and-feel standards. +For example, active elements such as buttons and scrollbar +sliders will not change color when the pointer passes over them. +

    +
    tk_version
    +

    Tk sets this variable in the interpreter for each application. +The variable holds the current version number of the Tk +library in the form major.minor. Major and +minor are integers. The major version number increases in +any Tk release that includes changes that are not backward compatible +(i.e. whenever existing Tk applications and scripts may have to change to +work with the new release). The minor version number increases with +each new release of Tk, except that it resets to zero whenever the +major version number changes. +

    +
    tkVersion
    +

    Has the same value as tk_version. This variable is obsolete and +will be deleted soon. +

    +
    +
    + +

    Keywords

    +

    variables, version +

    +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    + + + + + diff --git a/info/gcl-tk/tkwait.html b/info/gcl-tk/tkwait.html new file mode 100644 index 0000000..bb74d80 --- /dev/null +++ b/info/gcl-tk/tkwait.html @@ -0,0 +1,99 @@ + + + + +GCL TK Manual: tkwait + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    +
    + +

    3.22 tkwait

    + +

    tkwait \- Wait for variable to change or window to be destroyed +

    +

    Synopsis

    +

    tkwait :variable name
    +
    tkwait :visibility name
    +tkwait :window name +

    + +

    Description

    + +

    The tkwait command waits for one of several things to happen, +then it returns without taking any other actions. +The return value is always an empty string. +If the first argument is :variable (or any abbreviation of +it) then the second argument is the name of a global variable and the +command waits for that variable to be modified. +If the first argument is :visibility (or any abbreviation +of it) then the second argument is the name of a window and the +tkwait command waits for a change in its +visibility state (as indicated by the arrival of a VisibilityNotify +event). This form is typically used to wait for a newly-created +window to appear on the screen before taking some action. +If the first argument is :window (or any abbreviation +of it) then the second argument is the name of a window and the +tkwait command waits for that window to be destroyed. +This form is typically used to wait for a user to finish interacting +with a dialog box before using the result of that interaction. +

    +

    While the tkwait command is waiting it processes events in +the normal fashion, so the application will continue to respond +to user interactions. +

    + +

    Keywords

    +

    variable, visibility, wait, window +

    + + + + diff --git a/info/gcl-tk/toplevel.html b/info/gcl-tk/toplevel.html new file mode 100644 index 0000000..3f6e4fd --- /dev/null +++ b/info/gcl-tk/toplevel.html @@ -0,0 +1,175 @@ + + + + +GCL TK Manual: toplevel + + + + + + + + + + + + + + + + + + + +
    +

    +Previous: , Up: Widgets   [Contents]

    +
    +
    + +

    2.15 toplevel

    + +

    toplevel \- Create and manipulate toplevel widgets +

    +

    Synopsis

    +

    toplevel pathName ?:screen screenName? ?:class className? ?options? +

    +

    Standard Options

    + + +
    +
    background                  geometry                
+borderWidth                 relief                  
+
    + + +

    See options, for more information. +

    +

    Arguments for Toplevel

    + + +

    Description

    + +

    The toplevel command creates a new toplevel widget (given +by the pathName argument). Additional +options, described above, may be specified on the command line +or in the option database +to configure aspects of the toplevel such as its background color +and relief. The toplevel command returns the +path name of the new window. +

    +

    A toplevel is similar to a frame except that it is created as a +top-level window: its X parent is the root window of a screen +rather than the logical parent from its path name. The primary +purpose of a toplevel is to serve as a container for dialog boxes +and other collections of widgets. The only features +of a toplevel are its background color and an optional 3-D border +to make the toplevel appear raised or sunken. +

    +

    Two special command-line options may be provided to the toplevel +command: :class and :screen. If :class +is specified, then the new widget’s class will be set to +className instead of Toplevel. Changing the class of +a toplevel widget may be useful +in order to use a special class name in database options referring +to this widget and its children. The :screen option +may be used to place the window on a different screen than the +window’s logical parent. Any valid screen name may be used, even +one associated with a different display. +

    +

    Note: :class and :screen are handled +differently than other command-line options. They may not be specified +using the option database (these options must have been processed +before the new window has been created enough to use the option database; +in particular, the new class name will affect the lookup of options +in the database). In addition, :class and :screen +may not be queried or changed using the config command described +below. However, the winfo :class command may be used to query +the class of a window, and winfo :screen may be used to query +its screen. +

    + +

    A Toplevel Widget’s Arguments

    + +

    The toplevel command creates a new Tcl command whose +name is the same as the path name of the toplevel’s window. This +command may be used to invoke various +operations on the widget. It has the following general form: +

    +
    +
    pathName option ?arg arg ...?
+
    + +

    PathName is the name of the command, which is the same as +the toplevel widget’s path name. Option and the args +determine the exact behavior of the command. The following +commands are possible for toplevel widgets: +

    +
    +
    pathName :configure ?option? ?value option value ...?
    +

    Query or modify the configuration options of the widget. +If no option is specified, returns a list describing all of +the available options for pathName (see Tk_ConfigureInfo for +information on the format of this list). If option is specified +with no value, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no option is specified). If +one or more option:value pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +Option may have any of the values accepted by the toplevel +command. +

    +
    +
    + +

    Bindings

    + +

    When a new toplevel is created, it has no default event bindings: +toplevels are not intended to be interactive. +

    + +

    Keywords

    +

    toplevel, widget +

    + + + +
    +
    +

    +Previous: , Up: Widgets   [Contents]

    +
    + + + + + diff --git a/info/gcl-tk/update.html b/info/gcl-tk/update.html new file mode 100644 index 0000000..275319a --- /dev/null +++ b/info/gcl-tk/update.html @@ -0,0 +1,100 @@ + + + + +GCL TK Manual: update + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    +
    + +

    3.23 update

    + +

    update \- Process pending events and/or when-idle handlers +

    +

    Synopsis

    +

    update ?:idletasks? +

    + +

    Description

    + +

    This command is used to bring the entire application world +“up to date.” +It flushes all pending output to the display, waits for the +server to process that output and return errors or events, +handles all pending events of any sort (including when-idle handlers), +and repeats this set of operations until there are no pending +events, no pending when-idle handlers, no pending output to the server, +and no operations still outstanding at the server. +

    +

    If the idletasks keyword is specified as an argument to the +command, then no new events or errors are processed; only when-idle +idlers are invoked. +This causes operations that are normally deferred, such as display +updates and window layout calculations, to be performed immediately. +

    +

    The update :idletasks command is useful in scripts where +changes have been made to the application’s state and you want those +changes to appear on the display immediately, rather than waiting +for the script to complete. +The update command with no options is useful in scripts where +you are performing a long-running computation but you still want +the application to respond to user interactions; if you occasionally +call update then user input will be processed during the +next call to update. +

    + +

    Keywords

    +

    event, flush, handler, idle, update +

    + + + + diff --git a/info/gcl-tk/winfo.html b/info/gcl-tk/winfo.html new file mode 100644 index 0000000..788fd35 --- /dev/null +++ b/info/gcl-tk/winfo.html @@ -0,0 +1,302 @@ + + + + +GCL TK Manual: winfo + + + + + + + + + + + + + + + + + + + +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    +
    + +

    3.24 winfo

    + +

    winfo \- Return window-related information +

    +

    Synopsis

    +

    winfo option ?arg arg ...? +

    + +

    Description

    + +

    The winfo command is used to retrieve information about windows +managed by Tk. It can take any of a number of different forms, +depending on the option argument. The legal forms are: +

    +
    +
    winfo :atom name
    +

    Returns a decimal string giving the integer identifier for the +atom whose name is name. If no atom exists with the name +name then a new one is created. +

    +
    winfo :atomname id
    +

    Returns the textual name for the atom whose integer identifier is +id. +This command is the inverse of the winfo :atom command. +Generates an error if no such atom exists. +

    +
    winfo :cells window
    +

    Returns a decimal string giving the number of cells in the +color map for window. +

    +
    winfo :children window
    +

    Returns a list containing the path names of all the children +of window. Top-level windows are returned as children +of their logical parents. +

    +
    winfo :class window
    +

    Returns the class name for window. +

    +
    winfo :containing rootX rootY
    +

    Returns the path name for the window containing the point given +by rootX and rootY. +RootX and rootY are specified in screen units (i.e. +any form acceptable to Tk_GetPixels) in the coordinate +system of the root window (if a virtual-root window manager is in +use then the coordinate system of the virtual root window is used). +If no window in this application contains the point then an empty +string is returned. +In selecting the containing window, children are given higher priority +than parents and among siblings the highest one in the stacking order is +chosen. +

    +
    winfo :depth window
    +

    Returns a decimal string giving the depth of window (number +of bits per pixel). +

    +
    winfo :exists window
    +

    Returns 1 if there exists a window named window, 0 if no such +window exists. +

    +
    winfo :fpixels window number
    +

    Returns a floating-point value giving the number of pixels +in window corresponding to the distance given by number. +Number may be specified in any of the forms acceptable +to Tk_GetScreenMM, such as “2.0c” or “1i”. +The return value may be fractional; for an integer value, use +winfo :pixels. +

    +
    winfo :geometry window
    +

    Returns the geometry for window, in the form +widthxheight+x+y. All dimensions are +in pixels. +

    +
    winfo :height window
    +

    Returns a decimal string giving window’s height in pixels. +When a window is first created its height will be 1 pixel; the +height will eventually be changed by a geometry manager to fulfill +the window’s needs. +If you need the true height immediately after creating a widget, +invoke update to force the geometry manager to arrange it, +or use winfo :reqheight to get the window’s requested height +instead of its actual height. +

    +
    winfo :id window
    +

    Returns a hexadecimal string indicating the X identifier for window. +

    +
    winfo :interps
    +

    Returns a list whose members are the names of all Tcl interpreters +(e.g. all Tk-based applications) currently registered for the +display of the invoking application. +

    +
    winfo :ismapped window
    +

    Returns 1 if window is currently mapped, 0 otherwise. +

    +
    winfo :name window
    +

    Returns window’s name (i.e. its name within its parent, as opposed +to its full path name). +The command winfo :name . will return the name of the application. +

    +
    winfo :parent window
    +

    Returns the path name of window’s parent, or an empty string +if window is the main window of the application. +

    +
    winfo :pathname id
    +

    Returns the path name of the window whose X identifier is id. +Id must be a decimal, hexadecimal, or octal integer and must +correspond to a window in the invoking application. +

    +
    winfo :pixels window number
    +

    Returns the number of pixels in window corresponding +to the distance given by number. +Number may be specified in any of the forms acceptable +to Tk_GetPixels, such as “2.0c” or “1i”. +The result is rounded to the nearest integer value; for a +fractional result, use winfo :fpixels. +

    +
    winfo :reqheight window
    +

    Returns a decimal string giving window’s requested height, +in pixels. This is the value used by window’s geometry +manager to compute its geometry. +

    +
    winfo :reqwidth window
    +

    Returns a decimal string giving window’s requested width, +in pixels. This is the value used by window’s geometry +manager to compute its geometry. +

    +
    winfo :rgb window color
    +

    Returns a list containing three decimal values, which are the +red, green, and blue intensities that correspond to color in +the window given by window. Color +may be specified in any of the forms acceptable for a color +option. +

    +
    winfo :rootx window
    +

    Returns a decimal string giving the x-coordinate, in the root +window of the screen, of the +upper-left corner of window’s border (or window if it +has no border). +

    +
    winfo :rooty window
    +

    Returns a decimal string giving the y-coordinate, in the root +window of the screen, of the +upper-left corner of window’s border (or window if it +has no border). +

    +
    winfo :screen window
    +

    Returns the name of the screen associated with window, in +the form displayName.screenIndex. +

    +
    winfo :screencells window
    +

    Returns a decimal string giving the number of cells in the default +color map for window’s screen. +

    +
    winfo :screendepth window
    +

    Returns a decimal string giving the depth of the root window +of window’s screen (number of bits per pixel). +

    +
    winfo :screenheight window
    +

    Returns a decimal string giving the height of window’s screen, +in pixels. +

    +
    winfo :screenmmheight window
    +

    Returns a decimal string giving the height of window’s screen, +in millimeters. +

    +
    winfo :screenmmwidth window
    +

    Returns a decimal string giving the width of window’s screen, +in millimeters. +

    +
    winfo :screenvisual window
    +

    Returns one of the following strings to indicate the default visual +type for window’s screen: directcolor, grayscale, +pseudocolor, staticcolor, staticgray, or +truecolor. +

    +
    winfo :screenwidth window
    +

    Returns a decimal string giving the width of window’s screen, +in pixels. +

    +
    winfo :toplevel window
    +

    Returns the path name of the top-level window containing window. +

    +
    winfo :visual window
    +

    Returns one of the following strings to indicate the visual +type for window: directcolor, grayscale, +pseudocolor, staticcolor, staticgray, or +truecolor. +

    +
    winfo :vrootheight window
    +

    Returns the height of the virtual root window associated with window +if there is one; otherwise returns the height of window’s screen. +

    +
    winfo :vrootwidth window
    +

    Returns the width of the virtual root window associated with window +if there is one; otherwise returns the width of window’s screen. +

    +
    winfo :vrootx window
    +

    Returns the x-offset of the virtual root window associated with window, +relative to the root window of its screen. +This is normally either zero or negative. +Returns 0 if there is no virtual root window for window. +

    +
    winfo :vrooty window
    +

    Returns the y-offset of the virtual root window associated with window, +relative to the root window of its screen. +This is normally either zero or negative. +Returns 0 if there is no virtual root window for window. +

    +
    winfo :width window
    +

    Returns a decimal string giving window’s width in pixels. +When a window is first created its width will be 1 pixel; the +width will eventually be changed by a geometry manager to fulfill +the window’s needs. +If you need the true width immediately after creating a widget, +invoke update to force the geometry manager to arrange it, +or use winfo :reqwidth to get the window’s requested width +instead of its actual width. +

    +
    winfo :x window
    +

    Returns a decimal string giving the x-coordinate, in window’s +parent, of the +upper-left corner of window’s border (or window if it +has no border). +

    +
    winfo :y window
    +

    Returns a decimal string giving the y-coordinate, in window’s +parent, of the +upper-left corner of window’s border (or window if it +has no border). +

    +
    +
    + +

    Keywords

    +

    atom, children, class, geometry, height, identifier, information, interpreters, +mapped, parent, path name, screen, virtual root, width, window +

    +
    +

    +Next: , Previous: , Up: Control   [Contents]

    +
    + + + + + diff --git a/info/gcl-tk/wm.html b/info/gcl-tk/wm.html new file mode 100644 index 0000000..6b54ba9 --- /dev/null +++ b/info/gcl-tk/wm.html @@ -0,0 +1,964 @@ + + + + +GCL TK Manual: wm + + + + + + + + + + + + + + + + + + +
    +

    +Previous: , Up: Control   [Contents]

    +
    +
    + +

    3.25 wm

    + +

    wm \- Communicate with window manager +

    +

    Synopsis

    +

    wm option window ?args? +

    + +

    Description

    + +

    The wm command is used to interact with window managers in +order to control such things as the title for a window, its geometry, +or the increments in terms of which it may be resized. The wm +command can take any of a number of different forms, depending on +the option argument. All of the forms expect at least one +additional argument, window, which must be the path name of a +top-level window. +

    +

    The legal forms for the wm command are: +

    +
    +
    wm :aspect window ?minNumer minDenom maxNumer maxDenom?
    +

    If minNumer, minDenom, maxNumer, and maxDenom +are all specified, then they will be passed to the window manager +and the window manager should use them to enforce a range of +acceptable aspect ratios for window. The aspect ratio of +window (width/length) will be constrained to lie +between minNumer/minDenom and maxNumer/maxDenom. +If minNumer etc. are all specified as empty strings, then +any existing aspect ratio restrictions are removed. +If minNumer etc. are specified, then the command returns an +empty string. Otherwise, it returns +a Tcl list containing four elements, which are the current values +of minNumer, minDenom, maxNumer, and maxDenom +(if no aspect restrictions are in effect, then an empty string is +returned). +

    +
    wm :client window ?name?
    +

    If name is specified, this command stores name (which +should be the name of +the host on which the application is executing) in window’s +WM_CLIENT_MACHINE property for use by the window manager or +session manager. +The command returns an empty string in this case. +If name isn’t specified, the command returns the last name +set in a wm :client command for window. +If name is specified as an empty string, the command deletes the +WM_CLIENT_MACHINE property from window. +

    +
    wm :command window ?value?
    +

    If value is specified, this command stores value in window’s +WM_COMMAND property for use by the window manager or +session manager and returns an empty string. +Value must have proper list structure; the elements should +contain the words of the command used to invoke the application. +If value isn’t specified then the command returns the last value +set in a wm :command command for window. +If value is specified as an empty string, the command +deletes the WM_COMMAND property from window. +

    +
    wm :deiconify window
    +

    Arrange for window to be displayed in normal (non-iconified) form. +This is done by mapping the window. If the window has never been +mapped then this command will not map the window, but it will ensure +that when the window is first mapped it will be displayed +in de-iconified form. Returns an empty string. +

    +
    wm :focusmodel window ?active|passive?
    +

    If active or passive is supplied as an optional argument +to the command, then it specifies the focus model for window. +In this case the command returns an empty string. If no additional +argument is supplied, then the command returns the current focus +model for window. +An active focus model means that window will claim the +input focus for itself or its descendants, even at times when +the focus is currently in some other application. Passive means that +window will never claim the focus for itself: the window manager +should give the focus to window at appropriate times. However, +once the focus has been given to window or one of its descendants, +the application may re-assign the focus among window’s descendants. +The focus model defaults to passive, and Tk’s focus command +assumes a passive model of focussing. +

    +
    wm :frame window
    +

    If window has been reparented by the window manager into a +decorative frame, the command returns the X window identifier for +the outermost frame that contains window (the window whose +parent is the root or virtual root). If window hasn’t been +reparented by the window manager then the command returns the +X window identifier for window. +

    +
    wm :geometry window ?newGeometry?
    +

    If newGeometry is specified, then the geometry of window +is changed and an empty string is returned. Otherwise the current +geometry for window is returned (this is the most recent +geometry specified either by manual resizing or +in a wm :geometry command). NewGeometry has +the form =widthxheight\(+-x\(+-y, where +any of =, widthxheight, or \(+-x\(+-y +may be omitted. Width and height are positive integers +specifying the desired dimensions of window. If window +is gridded (see GRIDDED GEOMETRY MANAGEMENT below) then the dimensions +are specified in grid units; otherwise they are specified in pixel +units. X and y specify the desired location of +window on the screen, in pixels. +If x is preceded by +, it specifies +the number of pixels between the left edge of the screen and the left +edge of window’s border; if preceded by - then +x specifies the number of pixels +between the right edge of the screen and the right edge of window’s +border. If y is preceded by + then it specifies the +number of pixels between the top of the screen and the top +of window’s border; if y is preceded by - then +it specifies the number of pixels between the bottom of window’s +border and the bottom of the screen. +If newGeometry is specified as an empty string then any +existing user-specified geometry for window is cancelled, and +the window will revert to the size requested internally by its +widgets. +

    +
    wm :grid window ?baseWidth baseHeight widthInc heightInc?
    +

    This command indicates that window is to be managed as a +gridded window. +It also specifies the relationship between grid units and pixel units. +BaseWidth and baseHeight specify the number of grid +units corresponding to the pixel dimensions requested internally +by window using Tk_GeometryRequest. WidthInc +and heightInc specify the number of pixels in each horizontal +and vertical grid unit. +These four values determine a range of acceptable sizes for +window, corresponding to grid-based widths and heights +that are non-negative integers. +Tk will pass this information to the window manager; during +manual resizing, the window manager will restrict the window’s size +to one of these acceptable sizes. +Furthermore, during manual resizing the window manager will display +the window’s current size in terms of grid units rather than pixels. +If baseWidth etc. are all specified as empty strings, then +window will no longer be managed as a gridded window. If +baseWidth etc. are specified then the return value is an +empty string. +Otherwise the return value is a Tcl list containing +four elements corresponding to the current baseWidth, +baseHeight, widthInc, and heightInc; if +window is not currently gridded, then an empty string +is returned. +Note: this command should not be needed very often, since the +Tk_SetGrid library procedure and the setGrid option +provide easier access to the same functionality. +

    +
    wm :group window ?pathName?
    +

    If pathName is specified, it gives the path name for the leader of +a group of related windows. The window manager may use this information, +for example, to unmap all of the windows in a group when the group’s +leader is iconified. PathName may be specified as an empty string to +remove window from any group association. If pathName is +specified then the command returns an empty string; otherwise it +returns the path name of window’s current group leader, or an empty +string if window isn’t part of any group. +

    +
    wm :iconbitmap window ?bitmap?
    +

    If bitmap is specified, then it names a bitmap in the standard +forms accepted by Tk (see the Tk_GetBitmap manual entry for details). +This bitmap is passed to the window manager to be displayed in +window’s icon, and the command returns an empty string. If +an empty string is specified for bitmap, then any current icon +bitmap is cancelled for window. +If bitmap is specified then the command returns an empty string. +Otherwise it returns the name of +the current icon bitmap associated with window, or an empty +string if window has no icon bitmap. +

    +
    wm :iconify window
    +

    Arrange for window to be iconified. It window hasn’t +yet been mapped for the first time, this command will arrange for +it to appear in the iconified state when it is eventually mapped. +

    +
    wm :iconmask window ?bitmap?
    +

    If bitmap is specified, then it names a bitmap in the standard +forms accepted by Tk (see the Tk_GetBitmap manual entry for details). +This bitmap is passed to the window manager to be used as a mask +in conjunction with the iconbitmap option: where the mask +has zeroes no icon will be displayed; where it has ones, the bits +from the icon bitmap will be displayed. If +an empty string is specified for bitmap then any current icon +mask is cancelled for window (this is equivalent to specifying +a bitmap of all ones). If bitmap is specified +then the command returns an empty string. Otherwise it +returns the name of the current icon mask associated with +window, or an empty string if no mask is in effect. +

    +
    wm :iconname window ?newName?
    +

    If newName is specified, then it is passed to the window +manager; the window manager should display newName inside +the icon associated with window. In this case an empty +string is returned as result. If newName isn’t specified +then the command returns the current icon name for window, +or an empty string if no icon name has been specified (in this +case the window manager will normally display the window’s title, +as specified with the wm :title command). +

    +
    wm :iconposition window ?x y?
    +

    If x and y are specified, they are passed to the window +manager as a hint about where to position the icon for window. +In this case an empty string is returned. If x and y are +specified as empty strings then any existing icon position hint is cancelled. +If neither x nor y is specified, then the command returns +a Tcl list containing two values, which are the current icon position +hints (if no hints are in effect then an empty string is returned). +

    +
    wm :iconwindow window ?pathName?
    +

    If pathName is specified, it is the path name for a window to +use as icon for window: when window is iconified then +pathName should be mapped to serve as icon, and when window +is de-iconified then pathName will be unmapped again. If +pathName is specified as an empty string then any existing +icon window association for window will be cancelled. If +the pathName argument is specified then an empty string is +returned. Otherwise the command returns the path name of the +current icon window for window, or an empty string if there +is no icon window currently specified for window. Note: +not all window managers support the notion of an icon window. +

    +
    wm :maxsize window ?width height?
    +

    If width and height are specified, then window +becomes resizable and width and height give its +maximum permissible dimensions. +For gridded windows the dimensions are specified in +grid units; otherwise they are specified in pixel units. +During manual sizing, the window manager +should restrict the window’s dimensions to be less than or +equal to width and height. +If width and height are specified as empty strings, +then the maximum size option is cancelled for window. +If width and height are +specified, then the command returns an empty string. Otherwise +it returns a Tcl list with two elements, which are the +maximum width and height currently in effect; if no maximum +dimensions are in effect for window then an empty +string is returned. See the sections on geometry management +below for more information. +

    +
    wm :minsize window ?width height?
    +

    If width and height are specified, then window +becomes resizable and width and height give its +minimum permissible dimensions. +For gridded windows the dimensions are specified in +grid units; otherwise they are specified in pixel units. +During manual sizing, the window manager +should restrict the window’s dimensions to be greater than or +equal to width and height. +If width and height are specified as empty strings, +then the minimum size option is cancelled for window. +If width and height are +specified, then the command returns an empty string. Otherwise +it returns a Tcl list with two elements, which are the +minimum width and height currently in effect; if no minimum +dimensions are in effect for window then an empty +string is returned. See the sections on geometry management +below for more information. +

    +
    wm :overrideredirect window ?boolean?
    +

    If boolean is specified, it must have a proper boolean form and +the override-redirect flag for window is set to that value. +If boolean is not specified then 1 or 0 is +returned to indicate whether or not the override-redirect flag +is currently set for window. +Setting the override-redirect flag for a window causes +it to be ignored by the window manager; among other things, this means +that the window will not be reparented from the root window into a +decorative frame and the user will not be able to manipulate the +window using the normal window manager mechanisms. +

    +
    wm :positionfrom window ?who?
    +

    If who is specified, it must be either program or +user, or an abbreviation of one of these two. It indicates +whether window’s current position was requested by the +program or by the user. Many window managers ignore program-requested +initial positions and ask the user to manually position the window; if +user is specified then the window manager should position the +window at the given place without asking the user for assistance. +If who is specified as an empty string, then the current position +source is cancelled. +If who is specified, then the command returns an empty string. +Otherwise it returns user or window to indicate the +source of the window’s current position, or an empty string if +no source has been specified yet. Most window managers interpret +“no source” as equivalent to program. +Tk will automatically set the position source to user +when a wm :geometry command is invoked, unless the source has +been set explicitly to program. +

    +
    wm :protocol window ?name? ?command?
    +

    This command is used to manage window manager protocols such as +WM_DELETE_WINDOW. +Name is the name of an atom corresponding to a window manager +protocol, such as WM_DELETE_WINDOW or WM_SAVE_YOURSELF +or WM_TAKE_FOCUS. +If both name and command are specified, then command +is associated with the protocol specified by name. +Name will be added to window’s WM_PROTOCOLS +property to tell the window manager that the application has a +protocol handler for name, and command will +be invoked in the future whenever the window manager sends a +message to the client for that protocol. +In this case the command returns an empty string. +If name is specified but command isn’t, then the current +command for name is returned, or an empty string if there +is no handler defined for name. +If command is specified as an empty string then the current +handler for name is deleted and it is removed from the +WM_PROTOCOLS property on window; an empty string is +returned. +Lastly, if neither name nor command is specified, the +command returns a list of all the protocols for which handlers +are currently defined for window. +

    +
    + + +

    Tk always defines a protocol handler for WM_DELETE_WINDOW, even if +you haven’t asked for one with wm :protocol. +If a WM_DELETE_WINDOW message arrives when you haven’t defined +a handler, then Tk handles the message by destroying the window for +which it was received. +.RE +

    +
    +
    wm :sizefrom window ?who?
    +

    If who is specified, it must be either program or +user, or an abbreviation of one of these two. It indicates +whether window’s current size was requested by the +program or by the user. Some window managers ignore program-requested +sizes and ask the user to manually size the window; if +user is specified then the window manager should give the +window its specified size without asking the user for assistance. +If who is specified as an empty string, then the current size +source is cancelled. +If who is specified, then the command returns an empty string. +Otherwise it returns user or window to indicate the +source of the window’s current size, or an empty string if +no source has been specified yet. Most window managers interpret +“no source” as equivalent to program. +

    +
    wm :state window
    +

    Returns the current state of window: either normal, +iconic, or withdrawn. +

    +
    wm :title window ?string?
    +

    If string is specified, then it will be passed to the window +manager for use as the title for window (the window manager +should display this string in window’s title bar). In this +case the command returns an empty string. If string isn’t +specified then the command returns the current title for the +window. The title for a window defaults to its name. +

    +
    wm :transient window ?master?
    +

    If master is specified, then the window manager is informed +that window is a transient window (e.g. pull-down menu) working +on behalf of master (where master is the +path name for a top-level window). Some window managers will use +this information to manage window specially. If master +is specified as an empty string then window is marked as not +being a transient window any more. If master is specified, +then the command returns an empty string. Otherwise the command +returns the path name of window’s current master, or an +empty string if window isn’t currently a transient window. +

    +
    wm :withdraw window
    +

    Arranges for window to be withdrawn from the screen. This +causes the window to be unmapped and forgotten about by the window +manager. If the window +has never been mapped, then this command +causes the window to be mapped in the withdrawn state. Not all +window managers appear to know how to handle windows that are +mapped in the withdrawn state. +Note: it sometimes seems to be necessary to withdraw a +window and then re-map it (e.g. with wm :deiconify) to get some +window managers to pay attention to changes in window attributes +such as group. +

    +
    +
    + +

    "Sources Of Geometry Information"

    + +

    Size-related information for top-level windows +can come from three sources. +First, geometry requests come from the widgets that are descendants +of a top-level window. +Each widget requests a particular size for itself +by calling Tk_GeometryRequest. This information is passed to +geometry managers, which then request large enough sizes for parent +windows so that they can layout the children properly. +Geometry information passes upwards through the window hierarchy +until eventually a particular size is requested for each top-level +window. +These requests are called internal requests in the discussion +below. +The second source of width and height information is through the +wm :geometry command. Third, the user can +request a particular size for a window using the +interactive facilities of the window manager. +The second and third types of geometry requests are called +external requests in the discussion below; Tk treats +these two kinds of requests identically. +

    + +

    "Ungridded Geometry Management"

    + +

    Tk allows the geometry of a top-level window to be managed in +either of two general ways: ungridded or gridded. +The ungridded form occurs if no wm :grid command +has been issued for a top-level window. +Ungridded management has several variants. +In the simplest variant of ungridded windows, +no wm :geometry, wm :minsize, or wm :maxsize +commands have been invoked either. +In this case, the window’s size is +determined totally by the internal requests emanating from the +widgets inside the window: Tk will ask the window manager not to +permit the user to resize the window interactively. +

    +

    If a wm :geometry command is invoked on an ungridded window, +then the size in that command overrides any size requested by the +window’s widgets; from now on, the window’s size will be determined +entirely by the most recent information from wm :geometry +commands. To go back to using the size requested by the window’s +widgets, issue a wm :geometry command with an empty geometry +string. +

    +

    To enable interactive resizing of an ungridded window, one or both +of the wm :maxsize +and wm :minsize commands must be issued. +The information from these commands will be passed to the window +manager, and size changes within the specified range will be permitted. +For ungridded windows the limits refer to the top-level window’s +dimensions in pixels. +If only a wm :maxsize command is issued then the minimum +dimensions default to 1; if only a wm :minsize command is +issued then the maximum dimensions default to the size of the display. +If the size of a window is changed interactively, it has the same +effect as if wm :geometry had been invoked: from now on, internal +geometry requests will be ignored. +To return to internal control over the window’s size, issue a +wm :geometry command with an empty geometry argument. +If a window has been manually resized or moved, the wm :geometry +command will return the geometry that was requested interactively. +

    + +

    "Gridded Geometry Management"

    + +

    The second style of geometry management is called gridded. +This approach occurs when one of the widgets of an application +supports a range of useful sizes. +This occurs, for example, in a text editor where the scrollbars, +menus, and other adornments are fixed in size but the edit widget +can support any number of lines of text or characters per line. +In this case, it is usually desirable to let the user specify the +number of lines or characters-per-line, either with the +wm :geometry command or by interactively resizing the window. +In the case of text, and in other interesting cases also, only +discrete sizes of the window make sense, such as integral numbers +of lines and characters-per-line; arbitrary pixel sizes are not useful. +

    +

    Gridded geometry management provides support for this kind of +application. +Tk (and the window manager) assume that there is a grid of some +sort within the application and that the application should be +resized in terms of grid units rather than pixels. +Gridded geometry management is typically invoked by turning on +the setGrid option for a widget; it can also be invoked +with the wm :grid command or by calling Tk_SetGrid. +In each of these approaches the particular widget (or sometimes +code in the application as a whole) specifies the relationship between +integral grid sizes for the window and pixel sizes. +To return to non-gridded geometry management, invoke +wm :grid with empty argument strings. +

    +

    When gridded geometry management is enabled then all the dimensions specified +in wm :minsize, wm :maxsize, and wm :geometry commands +are treated as grid units rather than pixel units. +Interactive resizing is automatically enabled, and it will be +carried out in even numbers of grid units rather than pixels. +By default there are no limits on the minimum or maximum dimensions +of a gridded window. +As with ungridded windows, interactive resizing has exactly the +same effect as invoking the wm :geometry command. +For gridded windows, internally- and externally-requested dimensions +work together: the externally-specified width and height determine +the size of the window in grid units, and the information from the +last wm :grid command maps from grid units to pixel units. +

    + +

    Bugs

    + +

    The window manager interactions seem too complicated, especially +for managing geometry. Suggestions on how to simplify this would +be greatly appreciated. +

    +

    Most existing window managers appear to have bugs that affect the +operation of the wm command. For example, some changes won’t +take effect if the window is already active: the window will have +to be withdrawn and de-iconified in order to make the change happen. +

    + +

    Keywords

    +

    aspect ratio, deiconify, focus model, geometry, grid, group, icon, iconify, increments, position, size, title, top-level window, units, window manager +

    + +

    Short Table of Contents

    + +
    + +
    + + +

    Table of Contents

    + +
    + + +
    + +
    +
    +

    +Previous: , Up: Control   [Contents]

    +
    + + + + + diff --git a/info/gcl.texi.diff b/info/gcl.texi.diff new file mode 100644 index 0000000..0468fea --- /dev/null +++ b/info/gcl.texi.diff @@ -0,0 +1,11612 @@ +diff -uNr gcl-texi-orig/chap-10.texi gcl-texi/chap-10.texi +--- gcl-texi-orig/chap-10.texi 1994-07-16 18:03:13 +0400 ++++ gcl-texi/chap-10.texi 2002-10-17 20:53:05 +0400 +@@ -16,6 +16,7 @@ + Figure 10--1 lists some + @i{defined names} that are applicable to the @i{property lists} of @i{symbols}. + ++@format + @group + @noindent + @w{ get remprop symbol-plist } +@@ -24,10 +25,12 @@ + @w{ Figure 10--1: Property list defined names} + + @end group ++@end format + + Figure 10--2 lists some @i{defined names} that are applicable + to the creation of and inquiry about @i{symbols}. + ++@format + @group + @noindent + @w{ copy-symbol keywordp symbol-package } +@@ -38,6 +41,7 @@ + @w{ Figure 10--2: Symbol creation and inquiry defined names} + + @end group ++@end format + + @c end of including concept-symbols + +@@ -364,7 +368,7 @@ + @node copy-symbol, gensym, make-symbol, Symbols Dictionary + @subsection copy-symbol [Function] + +-@code{copy-symbol} @i{symbol {&optional} copy-properties} @result{} @i{new-symbol} ++@code{copy-symbol} @i{symbol @r{&optional} copy-properties} @result{} @i{new-symbol} + + @subsubheading Arguments and Values:: + +@@ -440,7 +444,7 @@ + @node gensym, *gensym-counter*, copy-symbol, Symbols Dictionary + @subsection gensym [Function] + +-@code{gensym} @i{{&optional} x} @result{} @i{new-symbol} ++@code{gensym} @i{@r{&optional} x} @result{} @i{new-symbol} + + @subsubheading Arguments and Values:: + +@@ -549,7 +553,7 @@ + @node gentemp, symbol-function, *gensym-counter*, Symbols Dictionary + @subsection gentemp [Function] + +-@code{gentemp} @i{{&optional} prefix package} @result{} @i{new-symbol} ++@code{gentemp} @i{@r{&optional} prefix package} @result{} @i{new-symbol} + + @subsubheading Arguments and Values:: + +@@ -958,9 +962,9 @@ + @node get, remprop, symbol-value, Symbols Dictionary + @subsection get [Accessor] + +-@code{get} @i{symbol indicator {&optional} default} @result{} @i{value} ++@code{get} @i{symbol indicator @r{&optional} default} @result{} @i{value} + +-(setf (@code{ get} @i{symbol indicator {&optional} default}) new-value)@* ++(setf (@code{ get} @i{symbol indicator @r{&optional} default}) new-value)@* + + @subsubheading Arguments and Values:: + +diff -uNr gcl-texi-orig/chap-11.texi gcl-texi/chap-11.texi +--- gcl-texi-orig/chap-11.texi 1994-07-16 18:03:12 +0400 ++++ gcl-texi/chap-11.texi 2002-10-17 20:53:05 +0400 +@@ -43,6 +43,7 @@ + a @i{package}. If a @i{symbol} is supplied, its name will be used + as the @i{package} name. + ++@format + @group + @noindent + @w{ *modules* import provide } +@@ -60,6 +61,7 @@ + @w{ Figure 11--1: Some Defined Names related to Packages } + + @end group ++@end format + + @menu + * Package Names and Nicknames:: +@@ -304,6 +306,7 @@ + @i{names} and @i{nicknames} of those @i{standardized} @i{packages} + is given in Figure 11--2. + ++@format + @group + @noindent + @w{ Name Nicknames } +@@ -315,6 +318,7 @@ + @w{ Figure 11--2: Standardized Package Names} + + @end group ++@end format + + @menu + * The COMMON-LISP Package:: +@@ -665,7 +669,7 @@ + @node export, find-symbol, package, Packages Dictionary + @subsection export [Function] + +-@code{export} @i{symbols {&optional} package} @result{} @i{@b{t}} ++@code{export} @i{symbols @r{&optional} package} @result{} @i{@b{t}} + + @subsubheading Arguments and Values:: + +@@ -770,7 +774,7 @@ + @node find-symbol, find-package, export, Packages Dictionary + @subsection find-symbol [Function] + +-@code{find-symbol} @i{string {&optional} package} @result{} @i{symbol, status} ++@code{find-symbol} @i{string @r{&optional} package} @result{} @i{symbol, status} + + @subsubheading Arguments and Values:: + +@@ -947,7 +951,7 @@ + @node import, list-all-packages, find-all-symbols, Packages Dictionary + @subsection import [Function] + +-@code{import} @i{symbols {&optional} package} @result{} @i{@b{t}} ++@code{import} @i{symbols @r{&optional} package} @result{} @i{@b{t}} + + @subsubheading Arguments and Values:: + +@@ -1064,7 +1068,7 @@ + @node rename-package, shadow, list-all-packages, Packages Dictionary + @subsection rename-package [Function] + +-@code{rename-package} @i{package new-name {&optional} new-nicknames} @result{} @i{package-object} ++@code{rename-package} @i{package new-name @r{&optional} new-nicknames} @result{} @i{package-object} + + @subsubheading Arguments and Values:: + +@@ -1105,7 +1109,7 @@ + @node shadow, shadowing-import, rename-package, Packages Dictionary + @subsection shadow [Function] + +-@code{shadow} @i{symbol-names {&optional} package} @result{} @i{@b{t}} ++@code{shadow} @i{symbol-names @r{&optional} package} @result{} @i{@b{t}} + + @subsubheading Arguments and Values:: + +@@ -1183,7 +1187,7 @@ + @node shadowing-import, delete-package, shadow, Packages Dictionary + @subsection shadowing-import [Function] + +-@code{shadowing-import} @i{symbols {&optional} package} @result{} @i{@b{t}} ++@code{shadowing-import} @i{symbols @r{&optional} package} @result{} @i{@b{t}} + + @subsubheading Arguments and Values:: + +@@ -1391,7 +1395,7 @@ + @node make-package, with-package-iterator, delete-package, Packages Dictionary + @subsection make-package [Function] + +-@code{make-package} @i{package-name {&key} nicknames use} @result{} @i{package} ++@code{make-package} @i{package-name @r{&key} nicknames use} @result{} @i{package} + + @subsubheading Arguments and Values:: + +@@ -1460,9 +1464,9 @@ + @node with-package-iterator, unexport, make-package, Packages Dictionary + @subsection with-package-iterator [Macro] + +-@code{with-package-iterator} @i{@r{(}name package-list-form {&rest} {symbol-types}@r{)} +- @{@i{declaration}@}{*} @{@i{form}@}{*}}@* +- @result{} @i{@{@i{result}@}{*}} ++@code{with-package-iterator} @i{@r{(}name package-list-form @r{&rest} @r{symbol-types}@r{)} ++ @{@i{declaration}@}* @{@i{form}@}*}@* ++ @result{} @i{@{@i{result}@}*} + + @subsubheading Arguments and Values:: + +@@ -1634,7 +1638,7 @@ + @node unexport, unintern, with-package-iterator, Packages Dictionary + @subsection unexport [Function] + +-@code{unexport} @i{symbols {&optional} package} @result{} @i{@b{t}} ++@code{unexport} @i{symbols @r{&optional} package} @result{} @i{@b{t}} + + @subsubheading Arguments and Values:: + +@@ -1693,7 +1697,7 @@ + @node unintern, in-package, unexport, Packages Dictionary + @subsection unintern [Function] + +-@code{unintern} @i{symbol {&optional} package} @result{} @i{generalized-boolean} ++@code{unintern} @i{symbol @r{&optional} package} @result{} @i{generalized-boolean} + + @subsubheading Arguments and Values:: + +@@ -1795,7 +1799,7 @@ + @node unuse-package, use-package, in-package, Packages Dictionary + @subsection unuse-package [Function] + +-@code{unuse-package} @i{packages-to-unuse {&optional} package} @result{} @i{@b{t}} ++@code{unuse-package} @i{packages-to-unuse @r{&optional} package} @result{} @i{@b{t}} + + @subsubheading Arguments and Values:: + +@@ -1846,7 +1850,7 @@ + @node use-package, defpackage, unuse-package, Packages Dictionary + @subsection use-package [Function] + +-@code{use-package} @i{packages-to-use {&optional} package} @result{} @i{@b{t}} ++@code{use-package} @i{packages-to-use @r{&optional} package} @result{} @i{@b{t}} + + @subsubheading Arguments and Values:: + +@@ -1918,14 +1922,14 @@ + + @code{defpackage} @i{defined-package-name [[!@i{option}]]} @result{} @i{package} + +-@w{@i{option} ::=@{{(}@t{:nicknames} @{@i{nickname}@}{*}@r{)}@}{*} | } ++@w{@i{option} ::=@{@r{(}@t{:nicknames} @{@i{nickname}@}*@r{)}@}* | } + @w{ @r{(}@t{:documentation} @i{string}@r{)} | } +-@w{ @{{(}@t{:use} @{@i{package-name}@}{*}@r{)}@}{*} | } +-@w{ @{{(}@t{:shadow} @{!@i{symbol-name}@}{*}@r{)}@}{*} | } +-@w{ @{{(}@t{:shadowing-import-from} @i{package-name} @{!@i{symbol-name}@}{*}@r{)}@}{*} | } +-@w{ @{{(}@t{:import-from} @i{package-name} @{!@i{symbol-name}@}{*}@r{)}@}{*} | } +-@w{ @{{(}@t{:export} @{!@i{symbol-name}@}{*}@r{)}@}{*} | } +-@w{ @{{(}@t{:intern} @{!@i{symbol-name}@}{*}@r{)}@}{*} | } ++@w{ @{@r{(}@t{:use} @{@i{package-name}@}*@r{)}@}* | } ++@w{ @{@r{(}@t{:shadow} @{!@i{symbol-name}@}*@r{)}@}* | } ++@w{ @{@r{(}@t{:shadowing-import-from} @i{package-name} @{!@i{symbol-name}@}*@r{)}@}* | } ++@w{ @{@r{(}@t{:import-from} @i{package-name} @{!@i{symbol-name}@}*@r{)}@}* | } ++@w{ @{@r{(}@t{:export} @{!@i{symbol-name}@}*@r{)}@}* | } ++@w{ @{@r{(}@t{:intern} @{!@i{symbol-name}@}*@r{)}@}* | } + @w{ @r{(}@t{:size} @i{integer}@r{)}} + + @w{@i{symbol-name} ::=(@i{symbol} | @i{string})} +@@ -2058,7 +2062,7 @@ + particular, @i{shadowing symbols} and + @i{imported} @i{symbols} can be made external. + +-If a {defpackage} @i{form} appears as a @i{top level form}, ++If a @i{defpackage} @i{form} appears as a @i{top level form}, + all of the actions normally performed by this @i{macro} + at load time must also be performed at compile time. + +@@ -2122,7 +2126,7 @@ + + @subsubheading See Also:: + +-@ref{documentation; (setf documentation)} ++@ref{documentation} + , + @ref{Package Concepts}, + @ref{Compilation} +@@ -2176,19 +2180,19 @@ + @subsection do-symbols, do-external-symbols, do-all-symbols [Macro] + + @code{do-symbols} @i{@r{(}var @r{[}package @r{[}result-form@r{]}@r{]}@r{)} +- @{@i{declaration}@}{*} +- @{tag | statement@}{*}}@* +- @result{} @i{@{@i{result}@}{*}} ++ @{@i{declaration}@}* ++ @{tag | statement@}*}@* ++ @result{} @i{@{@i{result}@}*} + + @code{do-external-symbols} @i{@r{(}var @r{[}package @r{[}result-form@r{]}@r{]}@r{)} +- @{@i{declaration}@}{*} +- @{tag | statement@}{*}}@* +- @result{} @i{@{@i{result}@}{*}} ++ @{@i{declaration}@}* ++ @{tag | statement@}*}@* ++ @result{} @i{@{@i{result}@}*} + + @code{do-all-symbols} @i{@r{(}var @r{[}result-form@r{]}@r{)} +- @{@i{declaration}@}{*} +- @{tag | statement@}{*}}@* +- @result{} @i{@{@i{result}@}{*}} ++ @{@i{declaration}@}* ++ @{tag | statement@}*}@* ++ @result{} @i{@{@i{result}@}*} + + @subsubheading Arguments and Values:: + +@@ -2296,7 +2300,7 @@ + @node intern, package-name, do-symbols, Packages Dictionary + @subsection intern [Function] + +-@code{intern} @i{string {&optional} package} @result{} @i{symbol, status} ++@code{intern} @i{string @r{&optional} package} @result{} @i{symbol, status} + + @subsubheading Arguments and Values:: + +@@ -2370,7 +2374,7 @@ + + @ref{find-symbol} + , +-@ref{read; read-preserving-whitespace} ++@ref{read} + , + @b{symbol}, + @ref{unintern} +diff -uNr gcl-texi-orig/chap-12.texi gcl-texi/chap-12.texi +--- gcl-texi-orig/chap-12.texi 1994-07-16 18:03:12 +0400 ++++ gcl-texi/chap-12.texi 2002-10-17 20:53:05 +0400 +@@ -33,6 +33,7 @@ + Figure 12--1 shows @i{operators} relating to + arithmetic operations. + ++@format + @group + @noindent + @w{ * 1+ gcd } +@@ -44,10 +45,12 @@ + @w{ Figure 12--1: Operators relating to Arithmetic.} + + @end group ++@end format + + Figure 12--2 shows @i{defined names} relating to + exponential, logarithmic, and trigonometric operations. + ++@format + @group + @noindent + @w{ abs cos signum } +@@ -63,10 +66,12 @@ + @w{ Figure 12--2: Defined names relating to Exponentials, Logarithms, and Trigonometry.} + + @end group ++@end format + + Figure 12--3 shows @i{operators} relating to + numeric comparison and predication. + ++@format + @group + @noindent + @w{ /= >= oddp } +@@ -79,10 +84,12 @@ + @w{ Figure 12--3: Operators for numeric comparison and predication.} + + @end group ++@end format + + Figure 12--4 shows @i{defined names} relating to + numeric type manipulation and coercion. + ++@format + @group + @noindent + @w{ ceiling float-radix rational } +@@ -99,6 +106,7 @@ + @w{ Figure 12--4: Defined names relating to numeric type manipulation and coercion.} + + @end group ++@end format + + @menu + * Associativity and Commutativity in Numeric Operations:: +@@ -187,6 +195,7 @@ + Figure 12--5 shows @i{defined names} relating to + logical operations on numbers. + ++@format + @group + @noindent + @w{ ash boole-ior logbitp } +@@ -205,6 +214,7 @@ + @w{ Figure 12--5: Defined names relating to logical operations on numbers.} + + @end group ++@end format + + @node Byte Operations on Integers, , Logical Operations on Integers, Numeric Operations + @subsubsection Byte Operations on Integers +@@ -220,6 +230,7 @@ + Figure 12--6 shows @i{defined names} relating to + manipulating @i{bytes} of @i{numbers}. + ++@format + @group + @noindent + @w{ byte deposit-field ldb-test } +@@ -230,6 +241,7 @@ + @w{ Figure 12--6: Defined names relating to byte manipulation.} + + @end group ++@end format + + @node Implementation-Dependent Numeric Constants, Rational Computations, Numeric Operations, Number Concepts + @subsection Implementation-Dependent Numeric Constants +@@ -237,6 +249,7 @@ + Figure 12--7 shows @i{defined names} relating to + @i{implementation-dependent} details about @i{numbers}. + ++@format + @group + @noindent + @w{ double-float-epsilon most-negative-fixnum } +@@ -257,6 +270,7 @@ + @w{ Figure 12--7: Defined names relating to implementation-dependent details about numbers.} + + @end group ++@end format + + @node Rational Computations, Floating-point Computations, Implementation-Dependent Numeric Constants, Number Concepts + @subsection Rational Computations +@@ -331,6 +345,7 @@ + (permissible only if the imaginary + part of the true mathematical result is zero) or @t{(complex single-float)}. + ++@format + @group + @noindent + @w{ Function Sample Results } +@@ -361,6 +376,7 @@ + @w{ Figure 12--8: Functions Affected by Rule of Float Substitutability} + + @end group ++@end format + + @node Floating-point Computations, Complex Computations, Rational Computations, Number Concepts + @subsection Floating-point Computations +@@ -525,7 +541,7 @@ + called branch cuts must be defined, which in turn + define the discontinuities in the range. + @r{Common Lisp} defines the branch cuts, @i{principal} @i{values}, and boundary +-conditions for the complex functions following ``{Principal Values and Branch Cuts in Complex APL}.'' The branch ++conditions for the complex functions following ``Principal Values and Branch Cuts in Complex APL.'' The branch + cut rules that apply to each function are located with the description of + that function. + +@@ -534,6 +550,7 @@ + throughout the applicable portion of the complex domain, even on + the branch cuts: + ++@format + @group + @noindent + @w{ sin i z = i sinh z sinh i z = i sin z arctan i z = i arctanh z } +@@ -544,6 +561,7 @@ + @w{ Figure 12--9: Trigonometric Identities for Complex Domain } + + @end group ++@end format + + The quadrant numbers referred to in the discussions of branch cuts are as illustrated + in Figure 12--10. +@@ -623,6 +641,7 @@ + + Figure 12--10 lists some @i{defined names} that are applicable to @i{random states}. + ++@format + @group + @noindent + @w{ *random-state* random } +@@ -632,6 +651,7 @@ + @w{ Figure 12--10: Random-state defined names} + + @end group ++@end format + + @c end of including concept-numbers + +@@ -646,13 +666,13 @@ + * real:: + * float (System Class):: + * short-float:: +-* rational:: ++* rational (System Class):: + * ratio:: + * integer:: + * signed-byte:: + * unsigned-byte:: +-* mod:: +-* bit:: ++* mod (System Class):: ++* bit (System Class):: + * fixnum:: + * bignum:: + * =:: +@@ -676,7 +696,7 @@ + * incf:: + * lcm:: + * log:: +-* mod:: ++* mod (Function):: + * signum:: + * sqrt:: + * random-state:: +@@ -694,7 +714,7 @@ + * upgraded-complex-part-type:: + * realp:: + * numerator:: +-* rational:: ++* rational (Function):: + * rationalp:: + * ash:: + * integer-length:: +@@ -882,14 +902,14 @@ + A @i{float} + is a mathematical rational (but @i{not} a @r{Common Lisp} @i{rational}) + of the form +-s\cdot f\cdot b^{e-p}, ++s\cdot f\cdot b^@r{e-p}, + where s is +1 or -1, the @i{sign}; + b is an @i{integer} + greater than~1, the @i{base} or @i{radix} of the representation; + p is a positive @i{integer}, + the @i{precision} (in base-b digits) of the @i{float}; + f is a positive @i{integer} +-between b^{p-1} and ++between b^@r{p-1} and + b^p-1 (inclusive), the significand; + and e is an @i{integer}, the exponent. + The value of p and the range of~e +@@ -937,7 +957,7 @@ + + @subsubheading See Also:: + +-{@i{Figure~2--9}}, ++@i{Figure~2--9}, + @ref{Constructing Numbers from Tokens}, + @ref{Printing Floats} + +@@ -950,7 +970,7 @@ + the @i{float} @t{1.0}, + or the @i{complex} @t{#C(1.0 0.0)}. + +-@node short-float, rational, float (System Class), Numbers Dictionary ++@node short-float, rational (System Class), float (System Class), Numbers Dictionary + @subsection short-float, single-float, double-float, long-float [Type] + + @subsubheading Supertypes:: +@@ -1005,6 +1025,7 @@ + as the values in Figure 12--11. + Each of the defined @i{subtypes} of @i{type} @b{float} might or might not have a minus zero. + ++@format + @group + @noindent + @w{ @b{Format} @b{Minimum Precision} @b{Minimum Exponent Size} } +@@ -1018,6 +1039,7 @@ + @w{ Figure 12--11: Recommended Minimum Floating-Point Precision and Exponent Size} + + @end group ++@end format + + There can be fewer than four internal + representations for @i{floats}. +@@ -1099,7 +1121,7 @@ + Each of these denotes the set of @i{floats} of the indicated @i{type} + that are on the interval specified by the @i{interval designators}. + +-@node rational, ratio, short-float, Numbers Dictionary ++@node rational (System Class), ratio, short-float, Numbers Dictionary + @subsection rational [System Class] + + @subsubheading Class Precedence List:: +@@ -1138,7 +1160,7 @@ + This denotes the @i{rationals} on the interval described by + @i{lower-limit} and @i{upper-limit}. + +-@node ratio, integer, rational, Numbers Dictionary ++@node ratio, integer, rational (System Class), Numbers Dictionary + @subsection ratio [System Class] + + @subsubheading Class Precedence List:: +@@ -1160,7 +1182,7 @@ + + @subsubheading See Also:: + +-{@i{Figure~2--9}}, ++@i{Figure~2--9}, + @ref{Constructing Numbers from Tokens}, + @ref{Printing Ratios} + +@@ -1205,7 +1227,7 @@ + + @subsubheading See Also:: + +-{@i{Figure~2--9}}, ++@i{Figure~2--9}, + @ref{Constructing Numbers from Tokens}, + @ref{Printing Integers} + +@@ -1255,11 +1277,11 @@ + + This denotes the set of @i{integers} that can be represented + in two's-complement form in a @i{byte} of @i{s} bits. This is +-equivalent to @t{(integer -2^{s-1} 2^{s-1}-1)}. The type ++equivalent to @t{(integer -2^@r{s-1} 2^@r{s-1}-1)}. The type + @b{signed-byte} or the type @t{(signed-byte *)} is the same + as the @i{type} @b{integer}. + +-@node unsigned-byte, mod, signed-byte, Numbers Dictionary ++@node unsigned-byte, mod (System Class), signed-byte, Numbers Dictionary + @subsection unsigned-byte [Type] + + @subsubheading Supertypes:: +@@ -1306,7 +1328,7 @@ + + The @i{type} @t{(unsigned-byte 1)} is also called @b{bit}. + +-@node mod, bit, unsigned-byte, Numbers Dictionary ++@node mod (System Class), bit (System Class), unsigned-byte, Numbers Dictionary + @subsection mod [Type Specifier] + + @subsubheading Compound Type Specifier Kind:: +@@ -1334,7 +1356,7 @@ + + The symbol @b{mod} is not valid as a @i{type specifier}. + +-@node bit, fixnum, mod, Numbers Dictionary ++@node bit (System Class), fixnum, mod (System Class), Numbers Dictionary + @subsection bit [Type] + + @subsubheading Supertypes:: +@@ -1355,7 +1377,7 @@ + The @i{type} @b{bit} is equivalent to the @i{type} @t{(integer 0 1)} + and @t{(unsigned-byte 1)}. + +-@node fixnum, bignum, bit, Numbers Dictionary ++@node fixnum, bignum, bit (System Class), Numbers Dictionary + @subsection fixnum [Type] + + @subsubheading Supertypes:: +@@ -1400,17 +1422,17 @@ + @node =, max, bignum, Numbers Dictionary + @subsection =, /=, <, >, <=, >= [Function] + +-@code{=} @i{{&rest} numbers^+} @result{} @i{generalized-boolean} ++@code{=} @i{@r{&rest} numbers^+} @result{} @i{generalized-boolean} + +-@code{/=} @i{{&rest} numbers^+} @result{} @i{generalized-boolean} ++@code{/=} @i{@r{&rest} numbers^+} @result{} @i{generalized-boolean} + +-@code{<} @i{{&rest} numbers^+} @result{} @i{generalized-boolean} ++@code{<} @i{@r{&rest} numbers^+} @result{} @i{generalized-boolean} + +-@code{>} @i{{&rest} numbers^+} @result{} @i{generalized-boolean} ++@code{>} @i{@r{&rest} numbers^+} @result{} @i{generalized-boolean} + +-@code{<=} @i{{&rest} numbers^+} @result{} @i{generalized-boolean} ++@code{<=} @i{@r{&rest} numbers^+} @result{} @i{generalized-boolean} + +-@code{>=} @i{{&rest} numbers^+} @result{} @i{generalized-boolean} ++@code{>=} @i{@r{&rest} numbers^+} @result{} @i{generalized-boolean} + + @subsubheading Arguments and Values:: + +@@ -1462,6 +1484,7 @@ + + The uses of these functions are illustrated in Figure 12--12. + ++@format + @group + @noindent + @w{ @t{(= 3 3)} is @i{true}. @t{(/= 3 3)} is @i{false}. } +@@ -1493,6 +1516,7 @@ + @w{ Figure 12--12: Uses of /=, =, <, >, <=, and >= } + + @end group ++@end format + + @subsubheading Exceptional Situations:: + +@@ -1509,9 +1533,9 @@ + @node max, minusp, =, Numbers Dictionary + @subsection max, min [Function] + +-@code{max} @i{{&rest} reals^+} @result{} @i{max-real} ++@code{max} @i{@r{&rest} reals^+} @result{} @i{max-real} + +-@code{min} @i{{&rest} reals^+} @result{} @i{min-real} ++@code{min} @i{@r{&rest} reals^+} @result{} @i{min-real} + + @subsubheading Arguments and Values:: + +@@ -1628,7 +1652,7 @@ + + @subsubheading Pronunciation:: + +-pronounced 'z\=e (, )r\=o{}(, )p\=e ++pronounced 'z\=e (, )r\=o@r{}(, )p\=e + + @subsubheading Arguments and Values:: + +@@ -1673,21 +1697,21 @@ + @i{[Function]} + @end flushright + +-@code{floor} @i{number {&optional} divisor} @result{} @i{quotient, remainder} ++@code{floor} @i{number @r{&optional} divisor} @result{} @i{quotient, remainder} + +-@code{ffloor} @i{number {&optional} divisor} @result{} @i{quotient, remainder} ++@code{ffloor} @i{number @r{&optional} divisor} @result{} @i{quotient, remainder} + +-@code{ceiling} @i{number {&optional} divisor} @result{} @i{quotient, remainder} ++@code{ceiling} @i{number @r{&optional} divisor} @result{} @i{quotient, remainder} + +-@code{fceiling} @i{number {&optional} divisor} @result{} @i{quotient, remainder} ++@code{fceiling} @i{number @r{&optional} divisor} @result{} @i{quotient, remainder} + +-@code{truncate} @i{number {&optional} divisor} @result{} @i{quotient, remainder} ++@code{truncate} @i{number @r{&optional} divisor} @result{} @i{quotient, remainder} + +-@code{ftruncate} @i{number {&optional} divisor} @result{} @i{quotient, remainder} ++@code{ftruncate} @i{number @r{&optional} divisor} @result{} @i{quotient, remainder} + +-@code{round} @i{number {&optional} divisor} @result{} @i{quotient, remainder} ++@code{round} @i{number @r{&optional} divisor} @result{} @i{quotient, remainder} + +-@code{fround} @i{number {&optional} divisor} @result{} @i{quotient, remainder} ++@code{fround} @i{number @r{&optional} divisor} @result{} @i{quotient, remainder} + + @subsubheading Arguments and Values:: + +@@ -1708,7 +1732,7 @@ + These functions divide @i{number} by @i{divisor}, + returning a @i{quotient} and @i{remainder}, such that + +- @i{quotient}{\cdot} @i{divisor}+@i{remainder}=@i{number} ++ @i{quotient}@r{\cdot} @i{divisor}+@i{remainder}=@i{number} + + The @i{quotient} always represents a mathematical integer. + When more than one mathematical integer might be possible +@@ -1853,7 +1877,7 @@ + + @subsubheading See Also:: + +-@ref{asin; acos; atan} ++@ref{asin} + , + @b{acos}, + @b{atan}, +@@ -1866,7 +1890,7 @@ + + @code{acos} @i{number} @result{} @i{radians} + +-@code{atan} @i{number1 {&optional} number2} @result{} @i{radians} ++@code{atan} @i{number1 @r{&optional} number2} @result{} @i{radians} + + @subsubheading Arguments and Values:: + +@@ -1888,17 +1912,19 @@ + functions can be defined mathematically for + @i{number} or @i{number1} specified as @i{x} as in Figure 12--13. + ++@format + @group + @noindent + @w{ Function Definition } +-@w{ Arc sine -i @t{log} (ix+ \sqrt{1-x^2} ) } ++@w{ Arc sine -i @t{log} (ix+ \sqrt@r{1-x^2} ) } + @w{ Arc cosine (\pi/2) - @t{arcsin} x } +-@w{ Arc tangent -i @t{log} ((1+ix) \sqrt{1/(1+x^2)} ) } ++@w{ Arc tangent -i @t{log} ((1+ix) \sqrt@r{1/(1+x^2)} ) } + + @noindent + @w{ Figure 12--13: Mathematical definition of arc sine, arc cosine, and arc tangent} + + @end group ++@end format + + These formulae are mathematically correct, assuming + completely accurate computation. They are not necessarily +@@ -1936,7 +1962,7 @@ + The following definition for arc sine determines the range and + branch cuts: + +-@center @t{arcsin} z = -i @t{log} (iz+\sqrt{1-z^2}\Bigr) ++@center @t{arcsin} z = -i @t{log} (iz+\sqrt@r{1-z^2}\Bigr) + + The branch cut for the arc sine function is in two pieces: + one along the negative real axis to the left of~-1 +@@ -1951,13 +1977,13 @@ + The following definition for arc cosine determines the range and + branch cuts: + +-@center @t{arccos} z = {\pi\over2}- @t{arcsin} z ++@center @t{arccos} z = \pi\over2 - @t{arcsin} z + + or, which are equivalent, + +-@center @t{arccos} z = -i @t{log} (z+i \sqrt{1-z^2}\Bigr) ++@center @t{arccos} z = -i @t{log} (z+i \sqrt@r{1-z^2}\Bigr) + +-@center @t{arccos} z = {{2 @t{log} (\sqrt{(1+z)/2} + i \sqrt{(1-z)/2})}\over{i}} ++@center @t{arccos} z = @t{2 @t{log} (\sqrt@r{(1+z)/2} + i \sqrt@r{(1-z)/2})}\over@r{i} + + The branch cut for the arc cosine function is in two pieces: + one along the negative real axis to the left of~-1 +@@ -1973,7 +1999,7 @@ + The following definition for (one-argument) arc tangent determines the + range and branch cuts: + +-@center @t{arctan} z = {{@t{log} (1+iz) - @t{log} (1-iz)}\over{2i}} ++@center @t{arctan} z = @i{@i{@t{log} (1+iz) - @t{log} (1-iz)}\over@i{2i}} + + Beware of simplifying this formula; ``obvious'' simplifications are likely + to alter the branch cuts or the values on the branch cuts incorrectly. +@@ -1998,31 +2024,33 @@ + The asterisk (*) indicates that the entry in the figure applies to + implementations that support minus zero. + ++@format + @group + @noindent +-@w{ to 1pc{}@i{y} Condition @i{x} Condition Cartesian locus Range of result } +-@w{ to 1pc{} y = 0 x > 0 Positive x-axis 0 } +-@w{ to 1pc{*} y = +0 x > 0 Positive x-axis +0 } +-@w{ to 1pc{*} y = -0 x > 0 Positive x-axis -0 } +-@w{ to 1pc{} y > 0 x > 0 Quadrant I 0 < result < \pi/2 } +-@w{ to 1pc{} y > 0 x = 0 Positive y-axis \pi/2 } +-@w{ to 1pc{} y > 0 x < 0 Quadrant II \pi/2 < result < \pi } +-@w{ to 1pc{} y = 0 x < 0 Negative x-axis \pi } +-@w{ to 1pc{*} y = +0 x < 0 Negative x-axis +\pi } +-@w{ to 1pc{*} y = -0 x < 0 Negative x-axis -\pi } +-@w{ to 1pc{} y < 0 x < 0 Quadrant III -\pi < result < -\pi/2 } +-@w{ to 1pc{} y < 0 x = 0 Negative y-axis -\pi/2 } +-@w{ to 1pc{} y < 0 x > 0 Quadrant IV -\pi/2 < result < 0 } +-@w{ to 1pc{} y = 0 x = 0 Origin undefined consequences } +-@w{ to 1pc{*} y = +0 x = +0 Origin +0 } +-@w{ to 1pc{*} y = -0 x = +0 Origin -0 } +-@w{ to 1pc{*} y = +0 x = -0 Origin +\pi } +-@w{ to 1pc{*} y = -0 x = -0 Origin -\pi } ++@w{ to 1pc@r{}@i{y} Condition @i{x} Condition Cartesian locus Range of result } ++@w{ to 1pc@r{} y = 0 x > 0 Positive x-axis 0 } ++@w{ to 1pc* y = +0 x > 0 Positive x-axis +0 } ++@w{ to 1pc* y = -0 x > 0 Positive x-axis -0 } ++@w{ to 1pc@r{} y > 0 x > 0 Quadrant I 0 < result < \pi/2 } ++@w{ to 1pc@r{} y > 0 x = 0 Positive y-axis \pi/2 } ++@w{ to 1pc@r{} y > 0 x < 0 Quadrant II \pi/2 < result < \pi } ++@w{ to 1pc@r{} y = 0 x < 0 Negative x-axis \pi } ++@w{ to 1pc* y = +0 x < 0 Negative x-axis +\pi } ++@w{ to 1pc* y = -0 x < 0 Negative x-axis -\pi } ++@w{ to 1pc@r{} y < 0 x < 0 Quadrant III -\pi < result < -\pi/2 } ++@w{ to 1pc@r{} y < 0 x = 0 Negative y-axis -\pi/2 } ++@w{ to 1pc@r{} y < 0 x > 0 Quadrant IV -\pi/2 < result < 0 } ++@w{ to 1pc@r{} y = 0 x = 0 Origin undefined consequences } ++@w{ to 1pc* y = +0 x = +0 Origin +0 } ++@w{ to 1pc* y = -0 x = +0 Origin -0 } ++@w{ to 1pc* y = +0 x = -0 Origin +\pi } ++@w{ to 1pc* y = -0 x = -0 Origin -\pi } + + @noindent + @w{ Figure 12--14: Quadrant information for arc tangent } + + @end group ++@end format + + @subsubheading Examples:: + +@@ -2047,7 +2075,7 @@ + + @ref{log} + , +-@ref{sqrt; isqrt} ++@ref{sqrt} + , + @ref{Rule of Float Substitutability} + +@@ -2119,25 +2147,27 @@ + which are mathematically defined for an argument @i{x} + as given in Figure 12--15. + ++@format + @group + @noindent + @w{ Function Definition } +-@w{ Hyperbolic sine (e^x-e^{-x})/2 } +-@w{ Hyperbolic cosine (e^x+e^{-x})/2 } +-@w{ Hyperbolic tangent (e^x-e^{-x})/(e^x+e^{-x}) } +-@w{ Hyperbolic arc sine @t{log} (x+\sqrt{1+x^2}) } +-@w{ Hyperbolic arc cosine 2 @t{log} (\sqrt{(x+1)/2} + \sqrt{(x-1)/2}) } ++@w{ Hyperbolic sine (e^x-e^@i{-x})/2 } ++@w{ Hyperbolic cosine (e^x+e^@i{-x})/2 } ++@w{ Hyperbolic tangent (e^x-e^@i{-x})/(e^x+e^@i{-x}) } ++@w{ Hyperbolic arc sine @t{log} (x+\sqrt@i{1+x^2}) } ++@w{ Hyperbolic arc cosine 2 @t{log} (\sqrt@i{(x+1)/2} + \sqrt@i{(x-1)/2}) } + @w{ Hyperbolic arc tangent (@t{log} (1+x) - @t{log} (1-x))/2 } + + @noindent + @w{ Figure 12--15: Mathematical definitions for hyperbolic functions } + + @end group ++@end format + + The following definition for the inverse hyperbolic cosine + determines the range and branch cuts: + +-@center @t{arccosh} z = 2 @t{log} (\sqrt{(z+1)/2} + \sqrt{(z-1)/2}\Bigr). ++@center @t{arccosh} z = 2 @t{log} (\sqrt@i{(z+1)/2} + \sqrt@i{(z-1)/2}\Bigr). + + The branch cut for the inverse hyperbolic cosine function + lies along the real axis to the left of~1 (inclusive), extending +@@ -2152,7 +2182,7 @@ + The following definition for the inverse hyperbolic sine determines + the range and branch cuts: + +-@center @t{arcsinh} z = @t{log} (z+\sqrt{1+z^2}\Bigr). ++@center @t{arcsinh} z = @t{log} (z+\sqrt@i{1+z^2}\Bigr). + + The branch cut for the inverse hyperbolic sine function is in two pieces: + one along the positive imaginary axis above i +@@ -2167,7 +2197,7 @@ + The following definition for the inverse hyperbolic tangent + determines the range and branch cuts: + +-@center @t{arctanh} z = {{@t{log} (1+z) - @t{log} (1-z)}\over{2}}. ++@center @t{arctanh} z = @i{@i{@t{log} (1+z) - @t{log} (1-z)}\over@r{2}}. + + Note that: + +@@ -2206,7 +2236,7 @@ + + @ref{log} + , +-@ref{sqrt; isqrt} ++@ref{sqrt} + , + @ref{Rule of Float Substitutability} + +@@ -2228,7 +2258,7 @@ + @node *, +, sinh, Numbers Dictionary + @subsection * [Function] + +-@code{*} @i{{&rest} numbers} @result{} @i{product} ++@code{*} @i{@r{&rest} numbers} @result{} @i{product} + + @subsubheading Arguments and Values:: + +@@ -2265,7 +2295,7 @@ + @node +, -, *, Numbers Dictionary + @subsection + [Function] + +-@code{+} @i{{&rest} numbers} @result{} @i{sum} ++@code{+} @i{@r{&rest} numbers} @result{} @i{sum} + + @subsubheading Arguments and Values:: + +@@ -2304,7 +2334,7 @@ + + @code{-} @i{number} @result{} @i{negation} + +-@code{-} @i{minuend {&rest} subtrahends^+} @result{} @i{difference} ++@code{-} @i{minuend @r{&rest} subtrahends^+} @result{} @i{difference} + + @subsubheading Arguments and Values:: + +@@ -2353,7 +2383,7 @@ + + @code{/} @i{number} @result{} @i{reciprocal} + +-@code{/} @i{numerator {&rest} denominators^+} @result{} @i{quotient} ++@code{/} @i{numerator @r{&rest} denominators^+} @result{} @i{quotient} + + @subsubheading Arguments and Values:: + +@@ -2406,16 +2436,16 @@ + + @subsubheading See Also:: + +-@ref{floor; ffloor; ceiling; fceiling; truncate; ftruncate; round; fround} ++@ref{floor} + , @b{ceiling}, @b{truncate}, @b{round} + + @node 1+, abs, /, Numbers Dictionary + @subsection 1+, 1- [Function] + + @code{1} @i{+} @result{} @i{number} +- {successor} ++ @r{successor} + @code{1} @i{-} @result{} @i{number} +- {predecessor} ++ @r{predecessor} + + @subsubheading Arguments and Values:: + +@@ -2444,7 +2474,7 @@ + + @subsubheading See Also:: + +-@ref{incf; decf} ++@ref{incf} + , @b{decf} + + @subsubheading Notes:: +@@ -2611,7 +2641,7 @@ + approximately equal to @t{#C(1.0 1.73205)}, not @t{-2}. + + @b{expt} is defined +-as @i{b^x = e^{x log b\/}}. ++as @i{b^x = e^@i{x log b\/}}. + This defines the @i{principal} @i{values} precisely. The range of + @b{expt} is the entire complex plane. Regarded + as a function of @i{x}, with @i{b} fixed, there is no branch cut. +@@ -2678,7 +2708,7 @@ + @node gcd, incf, exp, Numbers Dictionary + @subsection gcd [Function] + +-@code{gcd} @i{{&rest} integers} @result{} @i{greatest-common-denominator} ++@code{gcd} @i{@r{&rest} integers} @result{} @i{greatest-common-denominator} + + @subsubheading Arguments and Values:: + +@@ -2778,12 +2808,12 @@ + @b{+}, + @ref{-} + , @b{1+}, @b{1-}, +-@ref{setf; psetf} ++@ref{setf} + + @node lcm, log, incf, Numbers Dictionary + @subsection lcm [Function] + +-@code{lcm} @i{{&rest} integers} @result{} @i{least-common-multiple} ++@code{lcm} @i{@r{&rest} integers} @result{} @i{least-common-multiple} + + @subsubheading Arguments and Values:: + +@@ -2836,10 +2866,10 @@ + + @ref{gcd} + +-@node log, mod, lcm, Numbers Dictionary ++@node log, mod (Function), lcm, Numbers Dictionary + @subsection log [Function] + +-@code{log} @i{number {&optional} base} @result{} @i{logarithm} ++@code{log} @i{number @r{&optional} base} @result{} @i{logarithm} + + @subsubheading Arguments and Values:: + +@@ -2924,12 +2954,12 @@ + + @subsubheading See Also:: + +-@ref{exp; expt} ++@ref{exp} + , + @b{expt}, + @ref{Rule of Float Substitutability} + +-@node mod, signum, log, Numbers Dictionary ++@node mod (Function), signum, log, Numbers Dictionary + @subsection mod, rem [Function] + + @code{mod} @i{number divisor} @result{} @i{modulus} +@@ -2981,7 +3011,7 @@ + + @subsubheading See Also:: + +-@ref{floor; ffloor; ceiling; fceiling; truncate; ftruncate; round; fround} ++@ref{floor} + , @b{truncate} + + @subsubheading Notes:: +@@ -2992,7 +3022,7 @@ + + with the same sign as @i{divisor}. + +-@node signum, sqrt, mod, Numbers Dictionary ++@node signum, sqrt, mod (Function), Numbers Dictionary + @subsection signum [Function] + + @code{signum} @i{number} @result{} @i{signed-prototype} +@@ -3122,7 +3152,7 @@ + + @subsubheading See Also:: + +-@ref{exp; expt} ++@ref{exp} + , + @ref{log} + , +@@ -3166,7 +3196,7 @@ + @node make-random-state, random, random-state, Numbers Dictionary + @subsection make-random-state [Function] + +-@code{make-random-state} @i{{&optional} state} @result{} @i{new-state} ++@code{make-random-state} @i{@r{&optional} state} @result{} @i{new-state} + + @subsubheading Arguments and Values:: + +@@ -3230,7 +3260,7 @@ + @node random, random-state-p, make-random-state, Numbers Dictionary + @subsection random [Function] + +-@code{random} @i{limit {&optional} random-state} @result{} @i{random-number} ++@code{random} @i{limit @r{&optional} random-state} @result{} @i{random-number} + + @subsubheading Arguments and Values:: + +@@ -3420,7 +3450,7 @@ + + @subsubheading Description:: + +-@b{cis} returns the value of~@i{e}^{i\cdot @i{radians}}, ++@b{cis} returns the value of~@i{e}^@i{i\cdot @i{radians}}, + which is a @i{complex} in which the + real part is equal to the cosine of @i{radians}, and the + imaginary part is equal to the sine of @i{radians}. +@@ -3437,7 +3467,7 @@ + @node complex, complexp, cis, Numbers Dictionary + @subsection complex [Function] + +-@code{complex} @i{realpart {&optional} imagpart} @result{} @i{complex} ++@code{complex} @i{realpart @r{&optional} imagpart} @result{} @i{complex} + + @subsubheading Arguments and Values:: + +@@ -3490,7 +3520,7 @@ + + @subsubheading See Also:: + +-@ref{realpart; imagpart} ++@ref{realpart} + , @b{imagpart} + + @subsubheading Notes:: +@@ -3687,7 +3717,7 @@ + @node upgraded-complex-part-type, realp, realpart, Numbers Dictionary + @subsection upgraded-complex-part-type [Function] + +-@code{upgraded-complex-part-type} @i{typespec {&optional} environment} @result{} @i{upgraded-typespec} ++@code{upgraded-complex-part-type} @i{typespec @r{&optional} environment} @result{} @i{upgraded-typespec} + + @subsubheading Arguments and Values:: + +@@ -3749,7 +3779,7 @@ + (realp @i{object}) @equiv{} (typep @i{object} 'real) + @end example + +-@node numerator, rational, realp, Numbers Dictionary ++@node numerator, rational (Function), realp, Numbers Dictionary + @subsection numerator, denominator [Function] + + @code{numerator} @i{rational} @result{} @i{numerator} +@@ -3795,7 +3825,7 @@ + (gcd (numerator x) (denominator x)) @result{} 1 + @end example + +-@node rational, rationalp, numerator, Numbers Dictionary ++@node rational (Function), rationalp, numerator, Numbers Dictionary + @subsection rational, rationalize [Function] + + @code{rational} @i{number} @result{} @i{rational} +@@ -3868,7 +3898,7 @@ + to a @i{float} + of the same format produces the original @i{number}. + +-@node rationalp, ash, rational, Numbers Dictionary ++@node rationalp, ash, rational (Function), Numbers Dictionary + @subsection rationalp [Function] + + @code{rationalp} @i{object} @result{} @i{generalized-boolean} +@@ -3894,7 +3924,7 @@ + + @subsubheading See Also:: + +-@ref{rational} ++@ref{rational (Function)} + + @subsubheading Notes:: + @example +@@ -3926,7 +3956,7 @@ + as @i{integer} is returned. + + Mathematically speaking, @b{ash} performs the computation +-@t{floor}(@i{integer}{\cdot} 2^@i{count}). ++@t{floor}(@i{integer}\cdot 2^@i{count}). + Logically, @b{ash} + moves all of the bits in @i{integer} to the left, + adding zero-bits at the right, or moves them to the right, +@@ -4050,7 +4080,7 @@ + @node parse-integer, boole, integerp, Numbers Dictionary + @subsection parse-integer [Function] + +-@code{parse-integer} @i{string {&key} start end radix junk-allowed} @result{} @i{integer, pos} ++@code{parse-integer} @i{string @r{&key} start end radix junk-allowed} @result{} @i{integer, pos} + + @subsubheading Arguments and Values:: + +@@ -4140,8 +4170,9 @@ + @b{boole} returns the values + specified for any @i{op} in Figure 12--16. + +-{ + ++ ++@format + @group + @noindent + @w{ Op Result } +@@ -4166,8 +4197,9 @@ + @w{ Figure 12--16: Bit-Wise Logical Operations } + + @end group ++@end format ++ + +-} + + @subsubheading Examples:: + +@@ -4217,7 +4249,7 @@ + + @subsubheading See Also:: + +-@ref{logand; logandc1; logandc2; logeqv; logior; lognand; lognor; lognot; logorc1; logorc2; logxor} ++@ref{logand} + + @subsubheading Notes:: + +@@ -4292,15 +4324,15 @@ + @i{[Function]} + @end flushright + +-@code{logand} @i{{&rest} integers} @result{} @i{result-integer} ++@code{logand} @i{@r{&rest} integers} @result{} @i{result-integer} + + @code{logandc} @i{1} @result{} @i{integer-1 integer-2} +- {result-integer} ++ @r{result-integer} + @code{logandc} @i{2} @result{} @i{integer-1 integer-2} +- {result-integer} +-@code{logeqv} @i{{&rest} integers} @result{} @i{result-integer} ++ @r{result-integer} ++@code{logeqv} @i{@r{&rest} integers} @result{} @i{result-integer} + +-@code{logior} @i{{&rest} integers} @result{} @i{result-integer} ++@code{logior} @i{@r{&rest} integers} @result{} @i{result-integer} + + @code{lognand} @i{integer-1 integer-2} @result{} @i{result-integer} + +@@ -4309,10 +4341,10 @@ + @code{lognot} @i{integer} @result{} @i{result-integer} + + @code{logorc} @i{1} @result{} @i{integer-1 integer-2} +- {result-integer} ++ @r{result-integer} + @code{logorc} @i{2} @result{} @i{integer-1 integer-2} +- {result-integer} +-@code{logxor} @i{{&rest} integers} @result{} @i{result-integer} ++ @r{result-integer} ++@code{logxor} @i{@r{&rest} integers} @result{} @i{result-integer} + + @subsubheading Arguments and Values:: + +@@ -4347,6 +4379,7 @@ + Where an `identity' is shown, it indicates the @i{value} @i{yielded} + by the @i{function} when no @i{arguments} are supplied. + ++@format + @group + @noindent + @w{ Function Identity Operation performed } +@@ -4366,6 +4399,7 @@ + @w{ Figure 12--17: Bit-wise Logical Operations on Integers } + + @end group ++@end format + + Negative @i{integers} are treated as if they were in two's-complement notation. + +@@ -4594,7 +4628,7 @@ + + @b{byte} returns a @i{byte specifier} that indicates + a @i{byte} of width @i{size} and whose bits have weights +-2^{@i{position} + @i{size} - 1\/} through 2^@i{position}, ++2^@i{@i{position} + @i{size} - 1\/} through 2^@i{position}, + and whose representation is + @i{implementation-dependent}. + +@@ -4663,7 +4697,7 @@ + + @subsubheading See Also:: + +-@ref{byte; byte-size; byte-position} ++@ref{byte} + , + @ref{dpb} + +@@ -4723,7 +4757,7 @@ + + @subsubheading See Also:: + +-@ref{byte; byte-size; byte-position} ++@ref{byte} + , + @ref{deposit-field} + , +@@ -4776,8 +4810,8 @@ + specified by @i{bytespec}. + + @b{ldb} returns an @i{integer} in which the bits with weights +-2^{(@i{s}-1)} through 2^{0} are the same as those in +-@i{integer} with weights 2^{(@i{p}+@i{s}-1)} ++2^@i{(@i{s}-1)} through 2^0 are the same as those in ++@i{integer} with weights 2^@i{(@i{p}+@i{s}-1)} + through 2^@i{p}, and all other bits zero; @i{s} is + @t{(byte-size @i{bytespec})} + and @i{p} is @t{(byte-position @i{bytespec})}. +@@ -4807,7 +4841,7 @@ + + @subsubheading See Also:: + +-@ref{byte; byte-size; byte-position} ++@ref{byte} + , + @b{byte-position}, + @b{byte-size}, +@@ -4859,7 +4893,7 @@ + + @subsubheading See Also:: + +-@ref{byte; byte-size; byte-position} ++@ref{byte} + , + @ref{ldb} + , +@@ -4912,7 +4946,7 @@ + + @subsubheading See Also:: + +-@ref{byte; byte-size; byte-position} ++@ref{byte} + , + @ref{ldb} + +@@ -4937,13 +4971,13 @@ + @b{most-positive-fixnum} is that @i{fixnum} closest in value + to positive infinity provided by the implementation, + +-and greater than or equal to both 2^{15} - 1 and ++and greater than or equal to both 2^@r{15} - 1 and + @b{array-dimension-limit}. + + @b{most-negative-fixnum} is that @i{fixnum} closest in value + to negative infinity provided by the implementation, + +-and less than or equal to -2^{15}. ++and less than or equal to -2^@r{15}. + + @node decode-float, float, most-positive-fixnum, Numbers Dictionary + @subsection decode-float, scale-float, float-radix, float-sign, +@@ -4958,7 +4992,7 @@ + + @code{float-radix} @i{float} @result{} @i{float-radix} + +-@code{float-sign} @i{float-1 {&optional} float-2} @result{} @i{signed-float} ++@code{float-sign} @i{float-1 @r{&optional} float-2} @result{} @i{signed-float} + + @code{float-digits} @i{float} @result{} @i{digits1} + +@@ -5137,7 +5171,7 @@ + @node float, floatp, decode-float, Numbers Dictionary + @subsection float [Function] + +-@code{float} @i{number {&optional} prototype} @result{} @i{float} ++@code{float} @i{number @r{&optional} prototype} @result{} @i{float} + + @subsubheading Arguments and Values:: + +@@ -5184,7 +5218,7 @@ + @subsection floatp [Function] + + @code{floatp} @i{object} +- {generalized-boolean} ++ @r{generalized-boolean} + + @subsubheading Arguments and Values:: + +@@ -5372,7 +5406,7 @@ + @subsubheading See Also:: + + @b{arithmetic-error-operation}, +-@ref{arithmetic-error-operands; arithmetic-error-operation} ++@ref{arithmetic-error-operands} + + @node arithmetic-error-operands, division-by-zero, arithmetic-error, Numbers Dictionary + @subsection arithmetic-error-operands, arithmetic-error-operation [Function] +@@ -5401,7 +5435,7 @@ + @subsubheading See Also:: + + @b{arithmetic-error}, +-{@ref{Conditions}} ++@ref{Conditions} + + @subsubheading Notes:: + +diff -uNr gcl-texi-orig/chap-13.texi gcl-texi/chap-13.texi +--- gcl-texi-orig/chap-13.texi 1994-07-16 18:03:11 +0400 ++++ gcl-texi/chap-13.texi 2002-10-17 20:53:05 +0400 +@@ -46,6 +46,7 @@ + Figure 13--1 lists some @i{defined names} relating to + @i{character} @i{attributes} and @i{character} @i{predicates}. + ++@format + @group + @noindent + @w{ alpha-char-p char-not-equal char> } +@@ -60,9 +61,11 @@ + @w{ Figure 13--1: Character defined names -- 1 } + + @end group ++@end format + + Figure 13--2 lists some @i{character} construction and conversion @i{defined names}. + ++@format + @group + @noindent + @w{ char-code char-name code-char } +@@ -73,6 +76,7 @@ + @w{ Figure 13--2: Character defined names -- 2} + + @end group ++@end format + + @node Introduction to Scripts and Repertoires, Character Attributes, Introduction to Characters, Character Concepts + @subsection Introduction to Scripts and Repertoires +@@ -671,29 +675,29 @@ + @i{[Function]} + @end flushright + +-@code{{char=}} @i{{&rest} characters^+} @result{} @i{generalized-boolean} ++@code{@r{char=}} @i{@r{&rest} characters^+} @result{} @i{generalized-boolean} + +-@code{{char/=}} @i{{&rest} characters^+} @result{} @i{generalized-boolean} ++@code{@r{char/=}} @i{@r{&rest} characters^+} @result{} @i{generalized-boolean} + +-@code{{char<}} @i{{&rest} characters^+} @result{} @i{generalized-boolean} ++@code{@r{char<}} @i{@r{&rest} characters^+} @result{} @i{generalized-boolean} + +-@code{{char>}} @i{{&rest} characters^+} @result{} @i{generalized-boolean} ++@code{@r{char>}} @i{@r{&rest} characters^+} @result{} @i{generalized-boolean} + +-@code{{char<=}} @i{{&rest} characters^+} @result{} @i{generalized-boolean} ++@code{@r{char<=}} @i{@r{&rest} characters^+} @result{} @i{generalized-boolean} + +-@code{{char>=}} @i{{&rest} characters^+} @result{} @i{generalized-boolean} ++@code{@r{char>=}} @i{@r{&rest} characters^+} @result{} @i{generalized-boolean} + +-@code{char-equal} @i{{&rest} characters^+} @result{} @i{generalized-boolean} ++@code{char-equal} @i{@r{&rest} characters^+} @result{} @i{generalized-boolean} + +-@code{char-not-equal} @i{{&rest} characters^+} @result{} @i{generalized-boolean} ++@code{char-not-equal} @i{@r{&rest} characters^+} @result{} @i{generalized-boolean} + +-@code{char-lessp} @i{{&rest} characters^+} @result{} @i{generalized-boolean} ++@code{char-lessp} @i{@r{&rest} characters^+} @result{} @i{generalized-boolean} + +-@code{char-greaterp} @i{{&rest} characters^+} @result{} @i{generalized-boolean} ++@code{char-greaterp} @i{@r{&rest} characters^+} @result{} @i{generalized-boolean} + +-@code{char-not-greaterp} @i{{&rest} characters^+} @result{} @i{generalized-boolean} ++@code{char-not-greaterp} @i{@r{&rest} characters^+} @result{} @i{generalized-boolean} + +-@code{char-not-lessp} @i{{&rest} characters^+} @result{} @i{generalized-boolean} ++@code{char-not-lessp} @i{@r{&rest} characters^+} @result{} @i{generalized-boolean} + + @subsubheading Arguments and Values:: + +@@ -1048,7 +1052,7 @@ + @node digit-char, digit-char-p, alphanumericp, Characters Dictionary + @subsection digit-char [Function] + +-@code{digit-char} @i{weight {&optional} radix} @result{} @i{char} ++@code{digit-char} @i{weight @r{&optional} radix} @result{} @i{char} + + @subsubheading Arguments and Values:: + +@@ -1096,7 +1100,7 @@ + @node digit-char-p, graphic-char-p, digit-char, Characters Dictionary + @subsection digit-char-p [Function] + +-@code{digit-char-p} @i{char {&optional} radix} @result{} @i{weight} ++@code{digit-char-p} @i{char @r{&optional} radix} @result{} @i{weight} + + @subsubheading Arguments and Values:: + +@@ -1182,7 +1186,7 @@ + + @subsubheading See Also:: + +-@ref{read; read-preserving-whitespace} ++@ref{read} + , + @ref{Character Syntax}, + @ref{Documentation of Implementation-Defined Scripts} +@@ -1275,7 +1279,7 @@ + + @subsubheading See Also:: + +-@ref{upper-case-p; lower-case-p; both-case-p} ++@ref{upper-case-p} + , + @ref{alpha-char-p} + , +@@ -1340,7 +1344,7 @@ + + @subsubheading See Also:: + +-@ref{char-upcase; char-downcase} ++@ref{char-upcase} + , + @b{char-downcase}, + @ref{Characters With Case}, +diff -uNr gcl-texi-orig/chap-14.texi gcl-texi/chap-14.texi +--- gcl-texi-orig/chap-14.texi 1994-07-16 18:03:10 +0400 ++++ gcl-texi/chap-14.texi 2002-10-17 20:53:05 +0400 +@@ -18,6 +18,7 @@ + is a compound data @i{object} + having two components called the @i{car} and the @i{cdr}. + ++@format + @group + @noindent + @w{ car cons rplacd } +@@ -27,6 +28,7 @@ + @w{ Figure 14--1: Some defined names relating to conses.} + + @end group ++@end format + + Depending on context, a group of connected @i{conses} can be viewed + in a variety of different ways. A variety of operations is provided to +@@ -52,6 +54,7 @@ + Typically, the @i{leaves} represent data while the branches + establish some relationship among that data. + ++@format + @group + @noindent + @w{ caaaar caddar cdar nsubst } +@@ -69,6 +72,7 @@ + @w{ Figure 14--2: Some defined names relating to trees.} + + @end group ++@end format + + @menu + * General Restrictions on Parameters that must be Trees:: +@@ -114,6 +118,7 @@ + is a chain of @i{conses} that has no termination + because some @i{cons} in the chain is the @i{cdr} of a later @i{cons}. + ++@format + @group + @noindent + @w{ append last nbutlast rest } +@@ -130,6 +135,7 @@ + @w{ Figure 14--3: Some defined names relating to lists.} + + @end group ++@end format + + @menu + * Lists as Association Lists:: +@@ -147,6 +153,7 @@ + where the @i{car} of each @i{cons} is the @i{key} + and the @i{cdr} is the @i{value} associated with that @i{key}. + ++@format + @group + @noindent + @w{ acons assoc-if pairlis rassoc-if } +@@ -156,6 +163,7 @@ + @w{ Figure 14--4: Some defined names related to assocation lists.} + + @end group ++@end format + + @node Lists as Sets, General Restrictions on Parameters that must be Lists, Lists as Association Lists, Conses as Lists + @subsubsection Lists as Sets +@@ -163,6 +171,7 @@ + @i{Lists} are sometimes viewed as sets by considering their elements + unordered and by assuming there is no duplication of elements. + ++@format + @group + @noindent + @w{ adjoin nset-difference set-difference union } +@@ -173,6 +182,7 @@ + @w{ Figure 14--5: Some defined names related to sets. } + + @end group ++@end format + + @node General Restrictions on Parameters that must be Lists, , Lists as Sets, Conses as Lists + @subsubsection General Restrictions on Parameters that must be Lists +@@ -196,7 +206,7 @@ + @c including dict-conses + + @menu +-* list:: ++* list (System Class):: + * null (System Class):: + * cons (System Class):: + * atom (Type):: +@@ -210,7 +220,7 @@ + * subst:: + * tree-equal:: + * copy-list:: +-* list:: ++* list (Function):: + * list-length:: + * listp:: + * make-list:: +@@ -228,7 +238,7 @@ + * ldiff:: + * nthcdr:: + * rest:: +-* member:: ++* member (Function):: + * mapc:: + * acons:: + * assoc:: +@@ -247,7 +257,7 @@ + * union:: + @end menu + +-@node list, null (System Class), Conses Dictionary, Conses Dictionary ++@node list (System Class), null (System Class), Conses Dictionary, Conses Dictionary + @subsection list [System Class] + + @subsubheading Class Precedence List:: +@@ -296,7 +306,7 @@ + @ref{Left-Parenthesis}, + @ref{Printing Lists and Conses} + +-@node null (System Class), cons (System Class), list, Conses Dictionary ++@node null (System Class), cons (System Class), list (System Class), Conses Dictionary + @subsection null [System Class] + + @subsubheading Class Precedence List:: +@@ -408,7 +418,7 @@ + + @subsubheading See Also:: + +-@ref{list} ++@ref{list (Function)} + + @subsubheading Notes:: + If @i{object-2} is a @i{list}, @b{cons} can be thought of as +@@ -677,6 +687,7 @@ + order in which the corresponding operations are performed. Figure 14--6 + defines the relationships precisely. + ++@format + @group + @noindent + @w{ This @i{place} ... Is equivalent to this @i{place} ... } +@@ -713,6 +724,7 @@ + @w{ Figure 14--6: CAR and CDR variants } + + @end group ++@end format + + @b{setf} can also be used with any of these functions to change an + existing component of @i{x}, but @b{setf} will not make new +@@ -749,9 +761,9 @@ + + @subsubheading See Also:: + +-@ref{rplaca; rplacd} ++@ref{rplaca} + , +-@ref{first; second; third; fourth; fifth; sixth; seventh; eighth; ninth; tenth} ++@ref{first} + , + @ref{rest} + +@@ -821,9 +833,9 @@ + @node sublis, subst, copy-tree, Conses Dictionary + @subsection sublis, nsublis [Function] + +-@code{sublis} @i{alist tree {&key} key test test-not} @result{} @i{new-tree} ++@code{sublis} @i{alist tree @r{&key} key test test-not} @result{} @i{new-tree} + +-@code{nsublis} @i{alist tree {&key} key test test-not} @result{} @i{new-tree} ++@code{nsublis} @i{alist tree @r{&key} key test test-not} @result{} @i{new-tree} + + @subsubheading Arguments and Values:: + +@@ -906,7 +918,7 @@ + + @subsubheading See Also:: + +-@ref{subst; subst-if; subst-if-not; nsubst; nsubst-if; nsubst-if-not} ++@ref{subst} + , + + @ref{Compiler Terminology}, +@@ -939,17 +951,17 @@ + @i{[Function]} + @end flushright + +-@code{subst} @i{new old tree {&key} key test test-not} @result{} @i{new-tree} ++@code{subst} @i{new old tree @r{&key} key test test-not} @result{} @i{new-tree} + +-@code{subst-if} @i{new predicate tree {&key} key} @result{} @i{new-tree} ++@code{subst-if} @i{new predicate tree @r{&key} key} @result{} @i{new-tree} + +-@code{subst-if-not} @i{new predicate tree {&key} key} @result{} @i{new-tree} ++@code{subst-if-not} @i{new predicate tree @r{&key} key} @result{} @i{new-tree} + +-@code{nsubst} @i{new old tree {&key} key test test-not} @result{} @i{new-tree} ++@code{nsubst} @i{new old tree @r{&key} key test test-not} @result{} @i{new-tree} + +-@code{nsubst-if} @i{new predicate tree {&key} key} @result{} @i{new-tree} ++@code{nsubst-if} @i{new predicate tree @r{&key} key} @result{} @i{new-tree} + +-@code{nsubst-if-not} @i{new predicate tree {&key} key} @result{} @i{new-tree} ++@code{nsubst-if-not} @i{new predicate tree @r{&key} key} @result{} @i{new-tree} + + @subsubheading Arguments and Values:: + +@@ -1048,7 +1060,7 @@ + + @subsubheading See Also:: + +-@ref{substitute; substitute-if; substitute-if-not; nsubstitute; nsubstitute-if; nsubstitute-if-not} ++@ref{substitute} + , + @b{nsubstitute}, + +@@ -1081,7 +1093,7 @@ + @node tree-equal, copy-list, subst, Conses Dictionary + @subsection tree-equal [Function] + +-@code{tree-equal} @i{tree-1 tree-2 {&key} test test-not} @result{} @i{generalized-boolean} ++@code{tree-equal} @i{tree-1 tree-2 @r{&key} test test-not} @result{} @i{generalized-boolean} + + @subsubheading Arguments and Values:: + +@@ -1148,7 +1160,7 @@ + + The @t{:test-not} parameter is deprecated. + +-@node copy-list, list, tree-equal, Conses Dictionary ++@node copy-list, list (Function), tree-equal, Conses Dictionary + @subsection copy-list [Function] + + @code{copy-list} @i{list} @result{} @i{copy} +@@ -1203,12 +1215,12 @@ + + The copy created is @b{equal} to @i{list}, but not @b{eq}. + +-@node list, list-length, copy-list, Conses Dictionary ++@node list (Function), list-length, copy-list, Conses Dictionary + @subsection list, list* [Function] + +-@code{list} @i{{&rest} objects} @result{} @i{list} ++@code{list} @i{@r{&rest} objects} @result{} @i{list} + +-@code{list*} @i{{&rest} objects^+} @result{} @i{result} ++@code{list*} @i{@r{&rest} objects^+} @result{} @i{result} + + @subsubheading Arguments and Values:: + +@@ -1266,7 +1278,7 @@ + (list* @i{x}) @equiv{} @i{x} + @end example + +-@node list-length, listp, list, Conses Dictionary ++@node list-length, listp, list (Function), Conses Dictionary + @subsection list-length [Function] + + @code{list-length} @i{list} @result{} @i{length} +@@ -1370,7 +1382,7 @@ + @node make-list, push, listp, Conses Dictionary + @subsection make-list [Function] + +-@code{make-list} @i{size {&key} initial-element} @result{} @i{list} ++@code{make-list} @i{size @r{&key} initial-element} @result{} @i{list} + + @subsubheading Arguments and Values:: + +@@ -1404,7 +1416,7 @@ + + @ref{cons} + , +-@ref{list} ++@ref{list (Function)} + + @node push, pop, make-list, Conses Dictionary + @subsection push [Macro] +@@ -1619,7 +1631,7 @@ + + @subsubheading See Also:: + +-@ref{car; cdr; caar; cadr; cdar; cddr; caaar; caadr; cadar; caddr; cdaar; cdadr; cddar; cdddr; caaaar; caaadr; caadar; caaddr; cadaar; cadadr; caddar; cadddr; cdaaar; cdaadr; cdadar; cdaddr; cddaar; cddadr; cdddar; cddddr} ++@ref{car} + , + @ref{nth} + +@@ -1690,7 +1702,7 @@ + + @ref{elt} + , +-@ref{first; second; third; fourth; fifth; sixth; seventh; eighth; ninth; tenth} ++@ref{first} + , + @ref{nthcdr} + +@@ -1787,7 +1799,7 @@ + @node nconc, append, null, Conses Dictionary + @subsection nconc [Function] + +-@code{nconc} @i{{&rest} lists} @result{} @i{concatenated-list} ++@code{nconc} @i{@r{&rest} lists} @result{} @i{concatenated-list} + + @subsubheading Arguments and Values:: + +@@ -1863,7 +1875,7 @@ + @node append, revappend, nconc, Conses Dictionary + @subsection append [Function] + +-@code{append} @i{{&rest} lists} @result{} @i{result} ++@code{append} @i{@r{&rest} lists} @result{} @i{result} + + @subsubheading Arguments and Values:: + +@@ -1975,7 +1987,7 @@ + + @subsubheading See Also:: + +-@ref{reverse; nreverse} ++@ref{reverse} + , + @b{nreverse}, + @ref{nconc} +@@ -1994,9 +2006,9 @@ + @node butlast, last, revappend, Conses Dictionary + @subsection butlast, nbutlast [Function] + +-@code{butlast} @i{list {&optional} n} @result{} @i{result-list} ++@code{butlast} @i{list @r{&optional} n} @result{} @i{result-list} + +-@code{nbutlast} @i{list {&optional} n} @result{} @i{result-list} ++@code{nbutlast} @i{list @r{&optional} n} @result{} @i{result-list} + + @subsubheading Arguments and Values:: + +@@ -2069,7 +2081,7 @@ + @node last, ldiff, butlast, Conses Dictionary + @subsection last [Function] + +-@code{last} @i{list {&optional} n} @result{} @i{tail} ++@code{last} @i{list @r{&optional} n} @result{} @i{tail} + + @subsubheading Arguments and Values:: + +@@ -2126,7 +2138,7 @@ + + @subsubheading See Also:: + +-@ref{butlast; nbutlast} ++@ref{butlast} + , + @ref{nth} + +@@ -2221,7 +2233,7 @@ + + @subsubheading See Also:: + +-@ref{set-difference; nset-difference} ++@ref{set-difference} + + @subsubheading Notes:: + +@@ -2307,7 +2319,7 @@ + , + @ref{rest} + +-@node rest, member, nthcdr, Conses Dictionary ++@node rest, member (Function), nthcdr, Conses Dictionary + @subsection rest [Accessor] + + @code{rest} @i{list} @result{} @i{tail} +@@ -2355,14 +2367,14 @@ + when the argument is to being subjectively viewed as a @i{list} + rather than as a @i{cons}. + +-@node member, mapc, rest, Conses Dictionary ++@node member (Function), mapc, rest, Conses Dictionary + @subsection member, member-if, member-if-not [Function] + +-@code{member} @i{item list {&key} key test test-not} @result{} @i{tail} ++@code{member} @i{item list @r{&key} key test test-not} @result{} @i{tail} + +-@code{member-if} @i{predicate list {&key} key} @result{} @i{tail} ++@code{member-if} @i{predicate list @r{&key} key} @result{} @i{tail} + +-@code{member-if-not} @i{predicate list {&key} key} @result{} @i{tail} ++@code{member-if-not} @i{predicate list @r{&key} key} @result{} @i{tail} + + @subsubheading Arguments and Values:: + +@@ -2422,9 +2434,9 @@ + + @subsubheading See Also:: + +-@ref{find; find-if; find-if-not} ++@ref{find} + , +-@ref{position; position-if; position-if-not} ++@ref{position} + , + + @ref{Traversal Rules and Side Effects} +@@ -2447,20 +2459,20 @@ + where @t{a} was found (assuming a check has been made that @b{member} + did not return @b{nil}). + +-@node mapc, acons, member, Conses Dictionary ++@node mapc, acons, member (Function), Conses Dictionary + @subsection mapc, mapcar, mapcan, mapl, maplist, mapcon [Function] + +-@code{mapc} @i{function {&rest} lists^+} @result{} @i{list-1} ++@code{mapc} @i{function @r{&rest} lists^+} @result{} @i{list-1} + +-@code{mapcar} @i{function {&rest} lists^+} @result{} @i{result-list} ++@code{mapcar} @i{function @r{&rest} lists^+} @result{} @i{result-list} + +-@code{mapcan} @i{function {&rest} lists^+} @result{} @i{concatenated-results} ++@code{mapcan} @i{function @r{&rest} lists^+} @result{} @i{concatenated-results} + +-@code{mapl} @i{function {&rest} lists^+} @result{} @i{list-1} ++@code{mapl} @i{function @r{&rest} lists^+} @result{} @i{list-1} + +-@code{maplist} @i{function {&rest} lists^+} @result{} @i{result-list} ++@code{maplist} @i{function @r{&rest} lists^+} @result{} @i{result-list} + +-@code{mapcon} @i{function {&rest} lists^+} @result{} @i{concatenated-results} ++@code{mapcon} @i{function @r{&rest} lists^+} @result{} @i{concatenated-results} + + @subsubheading Arguments and Values:: + +@@ -2627,7 +2639,7 @@ + + @subsubheading See Also:: + +-@ref{assoc; assoc-if; assoc-if-not} ++@ref{assoc} + , + @ref{pairlis} + +@@ -2640,11 +2652,11 @@ + @node assoc, copy-alist, acons, Conses Dictionary + @subsection assoc, assoc-if, assoc-if-not [Function] + +-@code{assoc} @i{item alist {&key} key test test-not} @result{} @i{entry} ++@code{assoc} @i{item alist @r{&key} key test test-not} @result{} @i{entry} + +-@code{assoc-if} @i{predicate alist {&key} key} @result{} @i{entry} ++@code{assoc-if} @i{predicate alist @r{&key} key} @result{} @i{entry} + +-@code{assoc-if-not} @i{predicate alist {&key} key} @result{} @i{entry} ++@code{assoc-if-not} @i{predicate alist @r{&key} key} @result{} @i{entry} + + @subsubheading Arguments and Values:: + +@@ -2711,13 +2723,13 @@ + + @subsubheading See Also:: + +-@ref{rassoc; rassoc-if; rassoc-if-not} ++@ref{rassoc} + , +-@ref{find; find-if; find-if-not} ++@ref{find} + , +-@ref{member; member-if; member-if-not} ++@ref{member (Function)} + , +-@ref{position; position-if; position-if-not} ++@ref{position} + , + + @ref{Traversal Rules and Side Effects} +@@ -2798,7 +2810,7 @@ + @node pairlis, rassoc, copy-alist, Conses Dictionary + @subsection pairlis [Function] + +-@code{pairlis} @i{keys data {&optional} alist} @result{} @i{new-alist} ++@code{pairlis} @i{keys data @r{&optional} alist} @result{} @i{new-alist} + + @subsubheading Arguments and Values:: + +@@ -2864,11 +2876,11 @@ + @node rassoc, get-properties, pairlis, Conses Dictionary + @subsection rassoc, rassoc-if, rassoc-if-not [Function] + +-@code{rassoc} @i{item alist {&key} key test test-not} @result{} @i{entry} ++@code{rassoc} @i{item alist @r{&key} key test test-not} @result{} @i{entry} + +-@code{rassoc-if} @i{predicate alist {&key} key} @result{} @i{entry} ++@code{rassoc-if} @i{predicate alist @r{&key} key} @result{} @i{entry} + +-@code{rassoc-if-not} @i{predicate alist {&key} key} @result{} @i{entry} ++@code{rassoc-if-not} @i{predicate alist @r{&key} key} @result{} @i{entry} + + @subsubheading Arguments and Values:: + +@@ -2919,7 +2931,7 @@ + + @subsubheading See Also:: + +-@ref{assoc; assoc-if; assoc-if-not} ++@ref{assoc} + , + + @ref{Traversal Rules and Side Effects} +@@ -3001,9 +3013,9 @@ + @node getf, remf, get-properties, Conses Dictionary + @subsection getf [Accessor] + +-@code{getf} @i{plist indicator {&optional} default} @result{} @i{value} ++@code{getf} @i{plist indicator @r{&optional} default} @result{} @i{value} + +-(setf (@code{ getf} @i{place indicator {&optional} default}) new-value)@* ++(setf (@code{ getf} @i{place indicator @r{&optional} default}) new-value)@* + + @subsubheading Arguments and Values:: + +@@ -3081,7 +3093,7 @@ + , + @ref{get-properties} + , +-@ref{setf; psetf} ++@ref{setf} + , + @ref{Function Call Forms as Places} + +@@ -3163,9 +3175,9 @@ + @node intersection, adjoin, remf, Conses Dictionary + @subsection intersection, nintersection [Function] + +-@code{intersection} @i{list-1 list-2 {&key} key test test-not} @result{} @i{result-list} ++@code{intersection} @i{list-1 list-2 @r{&key} key test test-not} @result{} @i{result-list} + +-@code{nintersection} @i{list-1 list-2 {&key} key test test-not} @result{} @i{result-list} ++@code{nintersection} @i{list-1 list-2 @r{&key} key test test-not} @result{} @i{result-list} + + @subsubheading Arguments and Values:: + +@@ -3266,7 +3278,7 @@ + + @subsubheading See Also:: + +-@ref{union; nunion} ++@ref{union} + , + + @ref{Compiler Terminology}, +@@ -3284,7 +3296,7 @@ + @node adjoin, pushnew, intersection, Conses Dictionary + @subsection adjoin [Function] + +-@code{adjoin} @i{item list {&key} key test test-not} @result{} @i{new-list} ++@code{adjoin} @i{item list @r{&key} key test test-not} @result{} @i{new-list} + + @subsubheading Arguments and Values:: + +@@ -3355,7 +3367,7 @@ + @node pushnew, set-difference, adjoin, Conses Dictionary + @subsection pushnew [Macro] + +-@code{pushnew} @i{item place {&key} key test test-not}@* ++@code{pushnew} @i{item place @r{&key} key test test-not}@* + @result{} @i{new-place-value} + + @subsubheading Arguments and Values:: +@@ -3455,9 +3467,9 @@ + @node set-difference, set-exclusive-or, pushnew, Conses Dictionary + @subsection set-difference, nset-difference [Function] + +-@code{set-difference} @i{list-1 list-2 {&key} key test test-not} @result{} @i{result-list} ++@code{set-difference} @i{list-1 list-2 @r{&key} key test test-not} @result{} @i{result-list} + +-@code{nset-difference} @i{list-1 list-2 {&key} key test test-not} @result{} @i{result-list} ++@code{nset-difference} @i{list-1 list-2 @r{&key} key test test-not} @result{} @i{result-list} + + @subsubheading Arguments and Values:: + +@@ -3564,9 +3576,9 @@ + @node set-exclusive-or, subsetp, set-difference, Conses Dictionary + @subsection set-exclusive-or, nset-exclusive-or [Function] + +-@code{set-exclusive-or} @i{list-1 list-2 {&key} key test test-not} @result{} @i{result-list} ++@code{set-exclusive-or} @i{list-1 list-2 @r{&key} key test test-not} @result{} @i{result-list} + +-@code{nset-exclusive-or} @i{list-1 list-2 {&key} key test test-not} @result{} @i{result-list} ++@code{nset-exclusive-or} @i{list-1 list-2 @r{&key} key test test-not} @result{} @i{result-list} + + @subsubheading Arguments and Values:: + +@@ -3660,7 +3672,7 @@ + @node subsetp, union, set-exclusive-or, Conses Dictionary + @subsection subsetp [Function] + +-@code{subsetp} @i{list-1 list-2 {&key} key test test-not} @result{} @i{generalized-boolean} ++@code{subsetp} @i{list-1 list-2 @r{&key} key test test-not} @result{} @i{generalized-boolean} + + @subsubheading Arguments and Values:: + +@@ -3732,9 +3744,9 @@ + @node union, , subsetp, Conses Dictionary + @subsection union, nunion [Function] + +-@code{union} @i{list-1 list-2 {&key} key test test-not} @result{} @i{result-list} ++@code{union} @i{list-1 list-2 @r{&key} key test test-not} @result{} @i{result-list} + +-@code{nunion} @i{list-1 list-2 {&key} key test test-not} @result{} @i{result-list} ++@code{nunion} @i{list-1 list-2 @r{&key} key test test-not} @result{} @i{result-list} + + @subsubheading Arguments and Values:: + +@@ -3827,7 +3839,7 @@ + + @subsubheading See Also:: + +-@ref{intersection; nintersection} ++@ref{intersection} + , + + @ref{Compiler Terminology}, +diff -uNr gcl-texi-orig/chap-15.texi gcl-texi/chap-15.texi +--- gcl-texi-orig/chap-15.texi 1994-07-16 18:03:09 +0400 ++++ gcl-texi/chap-15.texi 2002-10-17 20:53:05 +0400 +@@ -148,6 +148,7 @@ + Figure 15--1 lists some @i{defined names} that are applicable to @i{array} + creation, @i{access}, and information operations. + ++@format + @group + @noindent + @w{ adjust-array array-in-bounds-p svref } +@@ -163,6 +164,7 @@ + @w{ Figure 15--1: General Purpose Array-Related Defined Names } + + @end group ++@end format + + @menu + * Array Upgrading:: +@@ -227,6 +229,7 @@ + most information about @i{strings} does not appear in this chapter; + see instead @ref{Strings}. + ++@format + @group + @noindent + @w{ char string-equal string-upcase } +@@ -243,6 +246,7 @@ + @w{ Figure 15--2: Operators that Manipulate Strings } + + @end group ++@end format + + @i{Vectors} whose @i{elements} are restricted to @i{type} + @b{bit} are called @i{bit vectors} +@@ -251,6 +255,7 @@ + @i{Bit vectors} are of @i{type} @b{bit-vector}. + Figure 15--3 lists some @i{defined names} for operations on @i{bit arrays}. + ++@format + @group + @noindent + @w{ bit bit-ior bit-orc2 } +@@ -263,6 +268,7 @@ + @w{ Figure 15--3: Operators that Manipulate Bit Arrays} + + @end group ++@end format + + @c end of including concept-arrays + +@@ -304,7 +310,7 @@ + * vector-pop:: + * vector-push:: + * vectorp:: +-* bit:: ++* bit (Array):: + * bit-and:: + * bit-vector-p:: + * simple-bit-vector-p:: +@@ -347,7 +353,7 @@ + + (@code{array}@{@i{@t{[}@{element-type | @b{*}@} @r{[}dimension-spec@r{]}@t{]}}@}) + +-@w{@i{dimension-spec} ::=rank | @b{*} | @r{(}@{dimension | @b{*}@}{*}@r{)}} ++@w{@i{dimension-spec} ::=rank | @b{*} | @r{(}@{dimension | @b{*}@}*@r{)}} + + @subsubheading Compound Type Specifier Arguments:: + +@@ -451,7 +457,7 @@ + + (@code{simple-array}@{@i{@t{[}@{element-type | @b{*}@} @r{[}dimension-spec@r{]}@t{]}}@}) + +-@w{@i{dimension-spec} ::=rank | @b{*} | @r{(}@{dimension | @b{*}@}{*}@r{)}} ++@w{@i{dimension-spec} ::=rank | @b{*} | @r{(}@{dimension | @b{*}@}*@r{)}} + + @subsubheading Compound Type Specifier Arguments:: + +@@ -506,7 +512,7 @@ + + @subsubheading Compound Type Specifier Syntax:: + +-(@code{vector}@{@i{@t{[}@{element-type | @b{*}@} @r{[}@{size | @b{*}@}{]}@t{]}}@}) ++(@code{vector}@{@i{@t{[}@{element-type | @b{*}@} @r{[}@{size | @b{*}@}@r{]}@t{]}}@}) + + @subsubheading Compound Type Specifier Arguments:: + +@@ -684,7 +690,7 @@ + @node make-array, adjust-array, simple-bit-vector, Arrays Dictionary + @subsection make-array [Function] + +-@code{make-array} @i{dimensions {&key} element-type ++@code{make-array} @i{dimensions @r{&key} element-type + initial-element + initial-contents + adjustable +@@ -946,7 +952,7 @@ + @node adjust-array, adjustable-array-p, make-array, Arrays Dictionary + @subsection adjust-array [Function] + +-@code{adjust-array} @i{array new-dimensions {&key} element-type ++@code{adjust-array} @i{array new-dimensions @r{&key} element-type + initial-element + initial-contents + fill-pointer +@@ -1240,9 +1246,9 @@ + @node aref, array-dimension, adjustable-array-p, Arrays Dictionary + @subsection aref [Accessor] + +-@code{aref} @i{array {&rest} subscripts} @result{} @i{element} ++@code{aref} @i{array @r{&rest} subscripts} @result{} @i{element} + +-(setf (@code{ aref} @i{array {&rest} subscripts}) new-element)@* ++(setf (@code{ aref} @i{array @r{&rest} subscripts}) new-element)@* + + @subsubheading Arguments and Values:: + +@@ -1288,9 +1294,9 @@ + + @subsubheading See Also:: + +-@ref{bit} ++@ref{bit (Array)} + , +-@ref{char; schar} ++@ref{char} + , + @ref{elt} + , +@@ -1529,7 +1535,7 @@ + @node array-in-bounds-p, array-rank, array-displacement, Arrays Dictionary + @subsection array-in-bounds-p [Function] + +-@code{array-in-bounds-p} @i{array {&rest} subscripts} @result{} @i{generalized-boolean} ++@code{array-in-bounds-p} @i{array @r{&rest} subscripts} @result{} @i{generalized-boolean} + + @subsubheading Arguments and Values:: + +@@ -1605,7 +1611,7 @@ + @node array-row-major-index, array-total-size, array-rank, Arrays Dictionary + @subsection array-row-major-index [Function] + +-@code{array-row-major-index} @i{array {&rest} subscripts} @result{} @i{index} ++@code{array-row-major-index} @i{array @r{&rest} subscripts} @result{} @i{index} + + @subsubheading Arguments and Values:: + +@@ -1832,7 +1838,7 @@ + @node upgraded-array-element-type, array-dimension-limit, row-major-aref, Arrays Dictionary + @subsection upgraded-array-element-type [Function] + +-@code{upgraded-array-element-type} @i{typespec {&optional} environment} @result{} @i{upgraded-typespec} ++@code{upgraded-array-element-type} @i{typespec @r{&optional} environment} @result{} @i{upgraded-typespec} + + @subsubheading Arguments and Values:: + +@@ -2042,7 +2048,7 @@ + @node vector, vector-pop, svref, Arrays Dictionary + @subsection vector [Function] + +-@code{vector} @i{{&rest} objects} @result{} @i{vector} ++@code{vector} @i{@r{&rest} objects} @result{} @i{vector} + + @subsubheading Arguments and Values:: + +@@ -2075,10 +2081,10 @@ + @b{vector} is analogous to @b{list}. + + @example +- (vector a{{}_1} a{{}_2} ... a{{}_n}) ++ (vector a_1 a_2 ... a_n) + @equiv{} (make-array (list @i{n}) :element-type t + :initial-contents +- (list a{{}_1} a{{}_2} ... a{{}_n})) ++ (list a_1 a_2 ... a_n)) + @end example + + @node vector-pop, vector-push, vector, Arrays Dictionary +@@ -2127,7 +2133,7 @@ + + @subsubheading See Also:: + +-@ref{vector-push; vector-push-extend} ++@ref{vector-push} + , @b{vector-push-extend}, + @ref{fill-pointer} + +@@ -2136,7 +2142,7 @@ + + @code{vector-push} @i{new-element vector} @result{} @i{new-index-p} + +-@code{vector-push-extend} @i{new-element vector {&optional} extension} @result{} @i{new-index} ++@code{vector-push-extend} @i{new-element vector @r{&optional} extension} @result{} @i{new-index} + + @subsubheading Arguments and Values:: + +@@ -2221,7 +2227,7 @@ + , + @ref{vector-pop} + +-@node vectorp, bit, vector-push, Arrays Dictionary ++@node vectorp, bit (Array), vector-push, Arrays Dictionary + @subsection vectorp [Function] + + @code{vectorp} @i{object} @result{} @i{generalized-boolean} +@@ -2252,14 +2258,14 @@ + (vectorp @i{object}) @equiv{} (typep @i{object} 'vector) + @end example + +-@node bit, bit-and, vectorp, Arrays Dictionary ++@node bit (Array), bit-and, vectorp, Arrays Dictionary + @subsection bit, sbit [Accessor] + +-@code{bit} @i{bit-array {&rest} subscripts} @result{} @i{bit} ++@code{bit} @i{bit-array @r{&rest} subscripts} @result{} @i{bit} + +-@code{sbit} @i{bit-array {&rest} subscripts} @result{} @i{bit} ++@code{sbit} @i{bit-array @r{&rest} subscripts} @result{} @i{bit} + +-(setf (@code{bit} @i{bit-array {&rest} subscripts}) new-bit)@*(setf (@code{sbit} @i{bit-array {&rest} subscripts}) new-bit)@* ++(setf (@code{bit} @i{bit-array @r{&rest} subscripts}) new-bit)@*(setf (@code{sbit} @i{bit-array @r{&rest} subscripts}) new-bit)@* + + @subsubheading Arguments and Values:: + +@@ -2308,34 +2314,34 @@ + @b{bit} and @b{sbit}, unlike @b{char} and @b{schar}, + allow the first argument to be an @i{array} of any @i{rank}. + +-@node bit-and, bit-vector-p, bit, Arrays Dictionary ++@node bit-and, bit-vector-p, bit (Array), Arrays Dictionary + @subsection bit-and, bit-andc1, bit-andc2, bit-eqv, + @subheading bit-ior, bit-nand, bit-nor, bit-not, bit-orc1, bit-orc2, bit-xor + @flushright + @i{[Function]} + @end flushright + +-@code{bit-and} @i{bit-array1 bit-array2 {&optional} opt-arg} @result{} @i{resulting-bit-array} ++@code{bit-and} @i{bit-array1 bit-array2 @r{&optional} opt-arg} @result{} @i{resulting-bit-array} + +-@code{bit-andc1} @i{bit-array1 bit-array2 {&optional} opt-arg} @result{} @i{resulting-bit-array} ++@code{bit-andc1} @i{bit-array1 bit-array2 @r{&optional} opt-arg} @result{} @i{resulting-bit-array} + +-@code{bit-andc2} @i{bit-array1 bit-array2 {&optional} opt-arg} @result{} @i{resulting-bit-array} ++@code{bit-andc2} @i{bit-array1 bit-array2 @r{&optional} opt-arg} @result{} @i{resulting-bit-array} + +-@code{bit-eqv} @i{bit-array1 bit-array2 {&optional} opt-arg} @result{} @i{resulting-bit-array} ++@code{bit-eqv} @i{bit-array1 bit-array2 @r{&optional} opt-arg} @result{} @i{resulting-bit-array} + +-@code{bit-ior} @i{bit-array1 bit-array2 {&optional} opt-arg} @result{} @i{resulting-bit-array} ++@code{bit-ior} @i{bit-array1 bit-array2 @r{&optional} opt-arg} @result{} @i{resulting-bit-array} + +-@code{bit-nand} @i{bit-array1 bit-array2 {&optional} opt-arg} @result{} @i{resulting-bit-array} ++@code{bit-nand} @i{bit-array1 bit-array2 @r{&optional} opt-arg} @result{} @i{resulting-bit-array} + +-@code{bit-nor} @i{bit-array1 bit-array2 {&optional} opt-arg} @result{} @i{resulting-bit-array} ++@code{bit-nor} @i{bit-array1 bit-array2 @r{&optional} opt-arg} @result{} @i{resulting-bit-array} + +-@code{bit-orc1} @i{bit-array1 bit-array2 {&optional} opt-arg} @result{} @i{resulting-bit-array} ++@code{bit-orc1} @i{bit-array1 bit-array2 @r{&optional} opt-arg} @result{} @i{resulting-bit-array} + +-@code{bit-orc2} @i{bit-array1 bit-array2 {&optional} opt-arg} @result{} @i{resulting-bit-array} ++@code{bit-orc2} @i{bit-array1 bit-array2 @r{&optional} opt-arg} @result{} @i{resulting-bit-array} + +-@code{bit-xor} @i{bit-array1 bit-array2 {&optional} opt-arg} @result{} @i{resulting-bit-array} ++@code{bit-xor} @i{bit-array1 bit-array2 @r{&optional} opt-arg} @result{} @i{resulting-bit-array} + +-@code{bit-not} @i{bit-array {&optional} opt-arg} @result{} @i{resulting-bit-array} ++@code{bit-not} @i{bit-array @r{&optional} opt-arg} @result{} @i{resulting-bit-array} + + @subsubheading Arguments and Values:: + +@@ -2374,6 +2380,7 @@ + performed by each of the @i{functions}. + + 2 ++@format + @group + @noindent + @w{@b{Function} @b{Operation} } +@@ -2393,6 +2400,7 @@ + @w{@w{ Figure 15--3: Bit-wise Logical Operations on Bit Arrays} + } + @end group ++@end format + + @subsubheading Examples:: + @example +@@ -2413,7 +2421,7 @@ + @subsubheading See Also:: + + @b{lognot}, +-@ref{logand; logandc1; logandc2; logeqv; logior; lognand; lognor; lognot; logorc1; logorc2; logxor} ++@ref{logand} + + @node bit-vector-p, simple-bit-vector-p, bit-and, Arrays Dictionary + @subsection bit-vector-p [Function] +diff -uNr gcl-texi-orig/chap-16.texi gcl-texi/chap-16.texi +--- gcl-texi-orig/chap-16.texi 1994-07-16 18:03:08 +0400 ++++ gcl-texi/chap-16.texi 2002-10-17 20:53:05 +0400 +@@ -378,17 +378,17 @@ + @i{[Function]} + @end flushright + +-@code{string-upcase} @i{string {&key} start end} @result{} @i{cased-string} ++@code{string-upcase} @i{string @r{&key} start end} @result{} @i{cased-string} + +-@code{string-downcase} @i{string {&key} start end} @result{} @i{cased-string} ++@code{string-downcase} @i{string @r{&key} start end} @result{} @i{cased-string} + +-@code{string-capitalize} @i{string {&key} start end} @result{} @i{cased-string} ++@code{string-capitalize} @i{string @r{&key} start end} @result{} @i{cased-string} + +-@code{nstring-upcase} @i{string {&key} start end} @result{} @i{string} ++@code{nstring-upcase} @i{string @r{&key} start end} @result{} @i{string} + +-@code{nstring-downcase} @i{string {&key} start end} @result{} @i{string} ++@code{nstring-downcase} @i{string @r{&key} start end} @result{} @i{string} + +-@code{nstring-capitalize} @i{string {&key} start end} @result{} @i{string} ++@code{nstring-capitalize} @i{string @r{&key} start end} @result{} @i{string} + + @subsubheading Arguments and Values:: + +@@ -480,7 +480,7 @@ + + @subsubheading See Also:: + +-@ref{char-upcase; char-downcase} ++@ref{char-upcase} + , @b{char-downcase} + + @subsubheading Notes:: +@@ -545,29 +545,29 @@ + @i{[Function]} + @end flushright + +-@code{string=} @i{string1 string2 {&key} start1 end1 start2 end2} @result{} @i{generalized-boolean} ++@code{string=} @i{string1 string2 @r{&key} start1 end1 start2 end2} @result{} @i{generalized-boolean} + +-@code{string/=} @i{string1 string2 {&key} start1 end1 start2 end2} @result{} @i{mismatch-index} ++@code{string/=} @i{string1 string2 @r{&key} start1 end1 start2 end2} @result{} @i{mismatch-index} + +-@code{string<} @i{string1 string2 {&key} start1 end1 start2 end2} @result{} @i{mismatch-index} ++@code{string<} @i{string1 string2 @r{&key} start1 end1 start2 end2} @result{} @i{mismatch-index} + +-@code{string>} @i{string1 string2 {&key} start1 end1 start2 end2} @result{} @i{mismatch-index} ++@code{string>} @i{string1 string2 @r{&key} start1 end1 start2 end2} @result{} @i{mismatch-index} + +-@code{string<=} @i{string1 string2 {&key} start1 end1 start2 end2} @result{} @i{mismatch-index} ++@code{string<=} @i{string1 string2 @r{&key} start1 end1 start2 end2} @result{} @i{mismatch-index} + +-@code{string>=} @i{string1 string2 {&key} start1 end1 start2 end2} @result{} @i{mismatch-index} ++@code{string>=} @i{string1 string2 @r{&key} start1 end1 start2 end2} @result{} @i{mismatch-index} + +-@code{string-equal} @i{string1 string2 {&key} start1 end1 start2 end2} @result{} @i{generalized-boolean} ++@code{string-equal} @i{string1 string2 @r{&key} start1 end1 start2 end2} @result{} @i{generalized-boolean} + +-@code{string-not-equal} @i{string1 string2 {&key} start1 end1 start2 end2} @result{} @i{mismatch-index} ++@code{string-not-equal} @i{string1 string2 @r{&key} start1 end1 start2 end2} @result{} @i{mismatch-index} + +-@code{string-lessp} @i{string1 string2 {&key} start1 end1 start2 end2} @result{} @i{mismatch-index} ++@code{string-lessp} @i{string1 string2 @r{&key} start1 end1 start2 end2} @result{} @i{mismatch-index} + +-@code{string-greaterp} @i{string1 string2 {&key} start1 end1 start2 end2} @result{} @i{mismatch-index} ++@code{string-greaterp} @i{string1 string2 @r{&key} start1 end1 start2 end2} @result{} @i{mismatch-index} + +-@code{string-not-greaterp} @i{string1 string2 {&key} start1 end1 start2 end2} @result{} @i{mismatch-index} ++@code{string-not-greaterp} @i{string1 string2 @r{&key} start1 end1 start2 end2} @result{} @i{mismatch-index} + +-@code{string-not-lessp} @i{string1 string2 {&key} start1 end1 start2 end2} @result{} @i{mismatch-index} ++@code{string-not-lessp} @i{string1 string2 @r{&key} start1 end1 start2 end2} @result{} @i{mismatch-index} + + @subsubheading Arguments and Values:: + +@@ -684,7 +684,7 @@ + + @subsubheading See Also:: + +-@ref{char=; char/=; char<; char>; char<=; char>=; char-equal; char-not-equal; char-lessp; char-greaterp; char-not-greaterp; char-not-lessp} ++@ref{char=} + + @subsubheading Notes:: + +@@ -728,7 +728,7 @@ + @node make-string, , stringp, Strings Dictionary + @subsection make-string [Function] + +-@code{make-string} @i{size {&key} initial-element element-type} @result{} @i{string} ++@code{make-string} @i{size @r{&key} initial-element element-type} @result{} @i{string} + + @subsubheading Arguments and Values:: + +diff -uNr gcl-texi-orig/chap-17.texi gcl-texi/chap-17.texi +--- gcl-texi-orig/chap-17.texi 1994-07-16 18:03:08 +0400 ++++ gcl-texi/chap-17.texi 2002-10-17 20:53:05 +0400 +@@ -34,6 +34,7 @@ + a new @i{vector}, it always returns a @i{simple vector}. + Similarly, any @i{strings} constructed will be @i{simple strings}. + ++@format + @group + @noindent + @w{ concatenate length remove } +@@ -56,6 +57,7 @@ + @w{ Figure 17--1: Standardized Sequence Functions } + + @end group ++@end format + + @menu + * General Restrictions on Parameters that must be Sequences:: +@@ -91,6 +93,7 @@ + This control is offered on the basis of a @i{function} designated with + either a @t{:test} or @t{:test-not} @i{argument}. + ++@format + @group + @noindent + @w{ adjoin nset-exclusive-or search } +@@ -108,6 +111,7 @@ + @w{ Figure 17--2: Operators that have Two-Argument Tests to be Satisfied} + + @end group ++@end format + + The object O might not be compared directly to E_i. + If a @t{:key} @i{argument} is provided, +@@ -193,6 +197,7 @@ + as with the @i{functions} described in @ref{Satisfying a Two-Argument Test}, + but rather on the basis of a one @i{argument} @i{predicate}. + ++@format + @group + @noindent + @w{ assoc-if member-if rassoc-if } +@@ -208,6 +213,7 @@ + @w{ Figure 17--3: Operators that have One-Argument Tests to be Satisfied} + + @end group ++@end format + + The element E_i might not be considered directly. + If a @t{:key} @i{argument} is provided, +@@ -409,7 +415,7 @@ + @node fill, make-sequence, elt, Sequences Dictionary + @subsection fill [Function] + +-@code{fill} @i{sequence item {&key} start end} @result{} @i{sequence} ++@code{fill} @i{sequence item @r{&key} start end} @result{} @i{sequence} + + @subsubheading Arguments and Values:: + +@@ -464,7 +470,7 @@ + @node make-sequence, subseq, fill, Sequences Dictionary + @subsection make-sequence [Function] + +-@code{make-sequence} @i{result-type size {&key} initial-element} @result{} @i{sequence} ++@code{make-sequence} @i{result-type size @r{&key} initial-element} @result{} @i{sequence} + + @subsubheading Arguments and Values:: + +@@ -540,9 +546,9 @@ + @node subseq, map, make-sequence, Sequences Dictionary + @subsection subseq [Accessor] + +-@code{subseq} @i{sequence start {&optional} end} @result{} @i{subsequence} ++@code{subseq} @i{sequence start @r{&optional} end} @result{} @i{subsequence} + +-(setf (@code{ subseq} @i{sequence start {&optional} end}) new-subsequence)@* ++(setf (@code{ subseq} @i{sequence start @r{&optional} end}) new-subsequence)@* + + @subsubheading Arguments and Values:: + +@@ -610,7 +616,7 @@ + @node map, map-into, subseq, Sequences Dictionary + @subsection map [Function] + +-@code{map} @i{result-type function {&rest} sequences^+} @result{} @i{result} ++@code{map} @i{result-type function @r{&rest} sequences^+} @result{} @i{result} + + @subsubheading Arguments and Values:: + +@@ -698,7 +704,7 @@ + @node map-into, reduce, map, Sequences Dictionary + @subsection map-into [Function] + +-@code{map-into} @i{result-sequence function {&rest} sequences} @result{} @i{result-sequence} ++@code{map-into} @i{result-sequence function @r{&rest} sequences} @result{} @i{result-sequence} + + @subsubheading Arguments and Values:: + +@@ -778,7 +784,7 @@ + @node reduce, count, map-into, Sequences Dictionary + @subsection reduce [Function] + +-@code{reduce} @i{function sequence {&key} key from-end start end initial-value} @result{} @i{result} ++@code{reduce} @i{function sequence @r{&key} key from-end start end initial-value} @result{} @i{result} + + @subsubheading Arguments and Values:: + +@@ -871,11 +877,11 @@ + @node count, length, reduce, Sequences Dictionary + @subsection count, count-if, count-if-not [Function] + +-@code{count} @i{item sequence {&key} from-end start end key test test-not} @result{} @i{n} ++@code{count} @i{item sequence @r{&key} from-end start end key test test-not} @result{} @i{n} + +-@code{count-if} @i{predicate sequence {&key} from-end start end key} @result{} @i{n} ++@code{count-if} @i{predicate sequence @r{&key} from-end start end key} @result{} @i{n} + +-@code{count-if-not} @i{predicate sequence {&key} from-end start end key} @result{} @i{n} ++@code{count-if-not} @i{predicate sequence @r{&key} from-end start end key} @result{} @i{n} + + @subsubheading Arguments and Values:: + +@@ -1058,9 +1064,9 @@ + @node sort, find, reverse, Sequences Dictionary + @subsection sort, stable-sort [Function] + +-@code{sort} @i{sequence predicate {&key} key} @result{} @i{sorted-sequence} ++@code{sort} @i{sequence predicate @r{&key} key} @result{} @i{sorted-sequence} + +-@code{stable-sort} @i{sequence predicate {&key} key} @result{} @i{sorted-sequence} ++@code{stable-sort} @i{sequence predicate @r{&key} key} @result{} @i{sorted-sequence} + + @subsubheading Arguments and Values:: + +@@ -1198,11 +1204,11 @@ + @node find, position, sort, Sequences Dictionary + @subsection find, find-if, find-if-not [Function] + +-@code{find} @i{item sequence {&key} from-end test test-not start end key} @result{} @i{element} ++@code{find} @i{item sequence @r{&key} from-end test test-not start end key} @result{} @i{element} + +-@code{find-if} @i{predicate sequence {&key} from-end start end key} @result{} @i{element} ++@code{find-if} @i{predicate sequence @r{&key} from-end start end key} @result{} @i{element} + +-@code{find-if-not} @i{predicate sequence {&key} from-end start end key} @result{} @i{element} ++@code{find-if-not} @i{predicate sequence @r{&key} from-end start end key} @result{} @i{element} + + @subsubheading Arguments and Values:: + +@@ -1267,7 +1273,7 @@ + + @subsubheading See Also:: + +-@ref{position; position-if; position-if-not} ++@ref{position} + , + @ref{Rules about Test Functions}, + +@@ -1282,11 +1288,11 @@ + @node position, search, find, Sequences Dictionary + @subsection position, position-if, position-if-not [Function] + +-@code{position} @i{item sequence {&key} from-end test test-not start end key} @result{} @i{position} ++@code{position} @i{item sequence @r{&key} from-end test test-not start end key} @result{} @i{position} + +-@code{position-if} @i{predicate sequence {&key} from-end start end key} @result{} @i{position} ++@code{position-if} @i{predicate sequence @r{&key} from-end start end key} @result{} @i{position} + +-@code{position-if-not} @i{predicate sequence {&key} from-end start end key} @result{} @i{position} ++@code{position-if-not} @i{predicate sequence @r{&key} from-end start end key} @result{} @i{position} + + @subsubheading Arguments and Values:: + +@@ -1344,7 +1350,7 @@ + + @subsubheading See Also:: + +-@ref{find; find-if; find-if-not} ++@ref{find} + , + + @ref{Traversal Rules and Side Effects} +@@ -1359,7 +1365,7 @@ + @subsection search [Function] + + @code{search} @i{sequence-1 sequence-2 +- {&key} from-end test test-not ++ @r{&key} from-end test test-not + key start1 start2 + end1 end2}@* + @result{} @i{position} +@@ -1430,7 +1436,7 @@ + @subsection mismatch [Function] + + @code{mismatch} @i{sequence-1 sequence-2 +- {&key} from-end test test-not key start1 start2 end1 end2}@* ++ @r{&key} from-end test test-not key start1 start2 end1 end2}@* + @result{} @i{position} + + @subsubheading Arguments and Values:: +@@ -1506,7 +1512,7 @@ + @node replace, substitute, mismatch, Sequences Dictionary + @subsection replace [Function] + +-@code{replace} @i{sequence-1 sequence-2 {&key} start1 end1 start2 end2} @result{} @i{sequence-1} ++@code{replace} @i{sequence-1 sequence-2 @r{&key} start1 end1 start2 end2} @result{} @i{sequence-1} + + @subsubheading Arguments and Values:: + +@@ -1582,25 +1588,25 @@ + @end flushright + + @code{substitute} @i{newitem olditem sequence +- {&key} from-end test ++ @r{&key} from-end test + test-not start + end count key}@* + @result{} @i{result-sequence} + +-@code{substitute-if} @i{newitem predicate sequence {&key} from-end start end count key}@* ++@code{substitute-if} @i{newitem predicate sequence @r{&key} from-end start end count key}@* + @result{} @i{result-sequence} + +-@code{substitute-if-not} @i{newitem predicate sequence {&key} from-end start end count key}@* ++@code{substitute-if-not} @i{newitem predicate sequence @r{&key} from-end start end count key}@* + @result{} @i{result-sequence} + + @code{nsubstitute} @i{newitem olditem sequence +- {&key} from-end test test-not start end count key}@* ++ @r{&key} from-end test test-not start end count key}@* + @result{} @i{sequence} + +-@code{nsubstitute-if} @i{newitem predicate sequence {&key} from-end start end count key}@* ++@code{nsubstitute-if} @i{newitem predicate sequence @r{&key} from-end start end count key}@* + @result{} @i{sequence} + +-@code{nsubstitute-if-not} @i{newitem predicate sequence {&key} from-end start end count key}@* ++@code{nsubstitute-if-not} @i{newitem predicate sequence @r{&key} from-end start end count key}@* + @result{} @i{sequence} + + @subsubheading Arguments and Values:: +@@ -1734,7 +1740,7 @@ + + @subsubheading See Also:: + +-@ref{subst; subst-if; subst-if-not; nsubst; nsubst-if; nsubst-if-not} ++@ref{subst} + , + @b{nsubst}, + +@@ -1770,7 +1776,7 @@ + @node concatenate, merge, substitute, Sequences Dictionary + @subsection concatenate [Function] + +-@code{concatenate} @i{result-type {&rest} sequences} @result{} @i{result-sequence} ++@code{concatenate} @i{result-type @r{&rest} sequences} @result{} @i{result-sequence} + + @subsubheading Arguments and Values:: + +@@ -1841,7 +1847,7 @@ + @node merge, remove, concatenate, Sequences Dictionary + @subsection merge [Function] + +-@code{merge} @i{result-type sequence-1 sequence-2 predicate {&key} key} @result{} @i{result-sequence} ++@code{merge} @i{result-type sequence-1 sequence-2 predicate @r{&key} key} @result{} @i{result-sequence} + + @subsubheading Arguments and Values:: + +@@ -1949,7 +1955,7 @@ + + @subsubheading See Also:: + +-@ref{sort; stable-sort} ++@ref{sort} + , + @b{stable-sort}, + +@@ -1964,17 +1970,17 @@ + @i{[Function]} + @end flushright + +-@code{remove} @i{item sequence {&key} from-end test test-not start end count key} @result{} @i{result-sequence} ++@code{remove} @i{item sequence @r{&key} from-end test test-not start end count key} @result{} @i{result-sequence} + +-@code{remove-if} @i{test sequence {&key} from-end start end count key} @result{} @i{result-sequence} ++@code{remove-if} @i{test sequence @r{&key} from-end start end count key} @result{} @i{result-sequence} + +-@code{remove-if-not} @i{test sequence {&key} from-end start end count key} @result{} @i{result-sequence} ++@code{remove-if-not} @i{test sequence @r{&key} from-end start end count key} @result{} @i{result-sequence} + +-@code{delete} @i{item sequence {&key} from-end test test-not start end count key} @result{} @i{result-sequence} ++@code{delete} @i{item sequence @r{&key} from-end test test-not start end count key} @result{} @i{result-sequence} + +-@code{delete-if} @i{test sequence {&key} from-end start end count key} @result{} @i{result-sequence} ++@code{delete-if} @i{test sequence @r{&key} from-end start end count key} @result{} @i{result-sequence} + +-@code{delete-if-not} @i{test sequence {&key} from-end start end count key} @result{} @i{result-sequence} ++@code{delete-if-not} @i{test sequence @r{&key} from-end start end count key} @result{} @i{result-sequence} + + @subsubheading Arguments and Values:: + +@@ -2153,12 +2159,12 @@ + @node remove-duplicates, , remove, Sequences Dictionary + @subsection remove-duplicates, delete-duplicates [Function] + +-@code{remove-duplicates} @i{sequence {&key} ++@code{remove-duplicates} @i{sequence @r{&key} + from-end test test-not + start end key}@* + @result{} @i{result-sequence} + +-@code{delete-duplicates} @i{sequence {&key} ++@code{delete-duplicates} @i{sequence @r{&key} + from-end test test-not + start end key}@* + @result{} @i{result-sequence} +diff -uNr gcl-texi-orig/chap-18.texi gcl-texi/chap-18.texi +--- gcl-texi-orig/chap-18.texi 1994-07-16 18:03:08 +0400 ++++ gcl-texi/chap-18.texi 2002-10-17 20:53:05 +0400 +@@ -72,6 +72,7 @@ + from the @i{secondary value} returned by @b{gethash}. + @end table + ++@format + @group + @noindent + @w{ clrhash hash-table-p remhash } +@@ -82,6 +83,7 @@ + @w{ Figure 18--1: Hash-table defined names } + + @end group ++@end format + + @node Modifying Hash Table Keys, , Hash-Table Operations, Hash Table Concepts + @subsection Modifying Hash Table Keys +@@ -241,14 +243,14 @@ + @subsubheading Notes:: + + The intent is that this mapping be implemented by a hashing mechanism, +-such as that described in Section 6.4 ``Hashing'' of {The Art of Computer Programming, Volume 3} ++such as that described in Section 6.4 ``Hashing'' of @b{The Art of Computer Programming, Volume 3} + (pp506-549). In spite of this intent, no @i{conforming implementation} + is required to use any particular technique to implement the mapping. + + @node make-hash-table, hash-table-p, hash-table, Hash Tables Dictionary + @subsection make-hash-table [Function] + +-@code{make-hash-table} @i{{&key} test size rehash-size rehash-threshold} @result{} @i{hash-table} ++@code{make-hash-table} @i{@r{&key} test size rehash-size rehash-threshold} @result{} @i{hash-table} + + @subsubheading Arguments and Values:: + +@@ -571,9 +573,9 @@ + @node gethash, remhash, hash-table-test, Hash Tables Dictionary + @subsection gethash [Accessor] + +-@code{gethash} @i{key hash-table {&optional} default} @result{} @i{value, present-p} ++@code{gethash} @i{key hash-table @r{&optional} default} @result{} @i{value, present-p} + +-(setf (@code{ gethash} @i{key hash-table {&optional} default}) new-value)@* ++(setf (@code{ gethash} @i{key hash-table @r{&optional} default}) new-value)@* + + @subsubheading Arguments and Values:: + +@@ -737,7 +739,7 @@ + @subsection with-hash-table-iterator [Macro] + + @code{with-hash-table-iterator} @i{@r{(}name hash-table@r{)} +- @{@i{declaration}@}{*} @{@i{form}@}{*}} @result{} @i{@{@i{result}@}{*}} ++ @{@i{declaration}@}* @{@i{form}@}*} @result{} @i{@{@i{result}@}*} + + @subsubheading Arguments and Values:: + +diff -uNr gcl-texi-orig/chap-19.texi gcl-texi/chap-19.texi +--- gcl-texi-orig/chap-19.texi 1994-07-16 18:06:18 +0400 ++++ gcl-texi/chap-19.texi 2002-10-17 20:59:17 +0400 +@@ -124,6 +124,7 @@ + + Figure 19--1 lists some @i{defined names} that are applicable to @i{pathnames}. + ++@format + @group + @noindent + @w{ *default-pathname-defaults* namestring pathname-name } +@@ -139,6 +140,7 @@ + @w{ Figure 19--1: Pathname Operations } + + @end group ++@end format + + @node Parsing Namestrings Into Pathnames, , Pathnames as Filenames, Overview of Filenames + @subsection Parsing Namestrings Into Pathnames +@@ -281,9 +283,9 @@ + For example, + + @example +- ;; In a TOPS-20 implementation, which uses {@t{^}}V to quote ++ ;; In a TOPS-20 implementation, which uses @t{^}V to quote + (NAMESTRING (MAKE-PATHNAME :HOST "OZ" :NAME "")) +-@result{} #P"OZ:PS:{@t{^}}V" ++@result{} #P"OZ:PS:@t{^}V" + @i{NOT}@result{} #P"OZ:PS:" + @end example + +@@ -298,6 +300,7 @@ + Figure 19--2 lists the functions + relating to @i{pathnames} that permit a @t{:case} argument: + ++@format + @group + @noindent + @w{ make-pathname pathname-directory pathname-name } +@@ -307,13 +310,14 @@ + @w{ Figure 19--2: Pathname functions using a :CASE argument} + + @end group ++@end format + + @node Local Case in Pathname Components, Common Case in Pathname Components, Case in Pathname Components, Interpreting Pathname Component Values + @subsubsection Local Case in Pathname Components + + For the functions in @i{Figure~19--2}, + a value of @t{:local} +-@IKindex{local} ++@c @IKindex{local} + for the @t{:case} argument + (the default for these functions) + indicates that the functions should receive and yield @i{strings} in component values +@@ -330,7 +334,7 @@ + + For the functions in @i{Figure~19--2}, + a value of @t{:common} +-@IKindex{common} ++@c @IKindex{common} + for the @t{:case} argument + that these @i{functions} should receive + and yield @i{strings} in component values according to the following conventions: +@@ -368,7 +372,7 @@ + @subsubsection :WILD as a Component Value + + If @t{:wild} +-@IKindex{wild} ++@c @IKindex{wild} + is the value of a @i{pathname} component, + that component is considered to be a wildcard, which matches anything. + +@@ -387,13 +391,13 @@ + @t{(:absolute :wild-inferiors)}, + or the same as @t{(:absolute :wild)} in a @i{file system} that does not support + @t{:wild-inferiors}. +-@IKindex{wild-inferiors} ++@c @IKindex{wild-inferiors} + + @node ->UNSPECIFIC as a Component Value, Relation between component values NIL and ->UNSPECIFIC, ->WILD as a Component Value, Interpreting Pathname Component Values + @subsubsection :UNSPECIFIC as a Component Value + + If @t{:unspecific} +-@IKindex{unspecific} ++@c @IKindex{unspecific} + is the value of a @i{pathname} component, + the component is considered to be ``absent'' + or to ``have no meaning'' +@@ -507,10 +511,10 @@ + The directory can be a @i{list} of @i{strings} and @i{symbols}. + + The @i{car} of the @i{list} is one of the symbols @t{:absolute} +-@IKindex{absolute} ++@c @IKindex{absolute} + or + @t{:relative} +-@IKindex{relative} ++@c @IKindex{relative} + , meaning: + + @table @asis +@@ -550,14 +554,15 @@ + signals an error of @i{type} @b{file-error}. + For example, Unix does not support @t{:wild-inferiors} in most implementations. + +-@IKindex{wild} ++@c @IKindex{wild} + +-@IKindex{wild-inferiors} ++@c @IKindex{wild-inferiors} + +-@IKindex{up} ++@c @IKindex{up} + +-@IKindex{back} ++@c @IKindex{back} + ++@format + @group + @noindent + @w{ Symbol Meaning } +@@ -570,6 +575,7 @@ + @w{ Figure 19--3: Special Markers In Directory Component } + + @end group ++@end format + + The following notes apply to the previous figure: + +@@ -782,7 +788,7 @@ + not a structural description of @i{objects}.) + + @w{@i{logical-pathname} ::=@r{[}!@i{host} @i{host-marker}@r{]} } +-@w{ @r{[}!@i{@i{relative-directory-marker}}@r{]} @{!@i{directory} @i{directory-marker}@}{*} } ++@w{ @r{[}!@i{@i{relative-directory-marker}}@r{]} @{!@i{directory} @i{directory-marker}@}* } + @w{ @r{[}!@i{name}@r{]} @r{[}@i{type-marker} !@i{type} @r{[}@i{version-marker} !@i{version}@r{]}@r{]}} + + @w{@i{host} ::=!@i{word}} +@@ -1061,7 +1067,7 @@ + @node make-pathname, pathnamep, pathname, Filenames Dictionary + @subsection make-pathname [Function] + +-@code{make-pathname} @i{{&key} host device directory name type version defaults case}@* ++@code{make-pathname} @i{@r{&key} host device directory name type version defaults case}@* + @result{} @i{pathname} + + @subsubheading Arguments and Values:: +@@ -1238,15 +1244,15 @@ + @i{[Function]} + @end flushright + +-@code{pathname-host} @i{pathname {&key} case} @result{} @i{host} ++@code{pathname-host} @i{pathname @r{&key} case} @result{} @i{host} + +-@code{pathname-device} @i{pathname {&key} case} @result{} @i{device} ++@code{pathname-device} @i{pathname @r{&key} case} @result{} @i{device} + +-@code{pathname-directory} @i{pathname {&key} case} @result{} @i{directory} ++@code{pathname-directory} @i{pathname @r{&key} case} @result{} @i{directory} + +-@code{pathname-name} @i{pathname {&key} case} @result{} @i{name} ++@code{pathname-name} @i{pathname @r{&key} case} @result{} @i{name} + +-@code{pathname-type} @i{pathname {&key} case} @result{} @i{type} ++@code{pathname-type} @i{pathname @r{&key} case} @result{} @i{type} + + @code{pathname-version} @i{pathname} @result{} @i{version} + +@@ -1704,7 +1710,7 @@ + + @code{host-namestring} @i{pathname} @result{} @i{namestring} + +-@code{enough-namestring} @i{pathname {&optional} defaults} @result{} @i{namestring} ++@code{enough-namestring} @i{pathname @r{&optional} defaults} @result{} @i{namestring} + + @subsubheading Arguments and Values:: + +@@ -1809,7 +1815,7 @@ + @node parse-namestring, wild-pathname-p, namestring, Filenames Dictionary + @subsection parse-namestring [Function] + +-@code{parse-namestring} @i{thing {&optional} host default-pathname {&key} start end junk-allowed}@* ++@code{parse-namestring} @i{thing @r{&optional} host default-pathname @r{&key} start end junk-allowed}@* + @result{} @i{pathname, position} + + @subsubheading Arguments and Values:: +@@ -1963,7 +1969,7 @@ + @node wild-pathname-p, pathname-match-p, parse-namestring, Filenames Dictionary + @subsection wild-pathname-p [Function] + +-@code{wild-pathname-p} @i{pathname {&optional} field-key} @result{} @i{generalized-boolean} ++@code{wild-pathname-p} @i{pathname @r{&optional} field-key} @result{} @i{generalized-boolean} + + @subsubheading Arguments and Values:: + +@@ -2069,7 +2075,7 @@ + @node translate-logical-pathname, translate-pathname, pathname-match-p, Filenames Dictionary + @subsection translate-logical-pathname [Function] + +-@code{translate-logical-pathname} @i{pathname {&key}} @result{} @i{physical-pathname} ++@code{translate-logical-pathname} @i{pathname @r{&key}} @result{} @i{physical-pathname} + + @subsubheading Arguments and Values:: + +@@ -2150,7 +2156,7 @@ + @node translate-pathname, merge-pathnames, translate-logical-pathname, Filenames Dictionary + @subsection translate-pathname [Function] + +-@code{translate-pathname} @i{source from-wildcard to-wildcard {&key}}@* ++@code{translate-pathname} @i{source from-wildcard to-wildcard @r{&key}}@* + @result{} @i{translated-pathname} + + @subsubheading Arguments and Values:: +@@ -2273,9 +2279,9 @@ + + @subsubheading See Also:: + +-@ref{namestring; file-namestring; directory-namestring; host-namestring; enough-namestring} ++@ref{namestring} + , +-@ref{pathname-host; pathname-device; pathname-directory; pathname-name; pathname-type; pathname-version} ++@ref{pathname-host} + , + + @b{pathname}, +@@ -2318,7 +2324,7 @@ + @node merge-pathnames, , translate-pathname, Filenames Dictionary + @subsection merge-pathnames [Function] + +-@code{merge-pathnames} @i{pathname {&optional} default-pathname default-version}@* ++@code{merge-pathnames} @i{pathname @r{&optional} default-pathname default-version}@* + @result{} @i{merged-pathname} + + @subsubheading Arguments and Values:: +diff -uNr gcl-texi-orig/chap-1.texi gcl-texi/chap-1.texi +--- gcl-texi-orig/chap-1.texi 1994-07-16 18:02:58 +0400 ++++ gcl-texi/chap-1.texi 2002-10-17 21:52:14 +0400 +@@ -49,7 +49,7 @@ + predominant dialects of Lisp, both arising from these early efforts: + MacLisp and Interlisp. + For further information about very early Lisp dialects, +-see {The Anatomy of Lisp} or {Lisp 1.5 Programmer's Manual}. ++see @b{The Anatomy of Lisp} or @b{Lisp 1.5 Programmer's Manual}. + + MacLisp improved on the Lisp~1.5 notion of special variables and error + handling. MacLisp also introduced the concept of functions that could take +@@ -58,14 +58,14 @@ + on execution speed. + By the end of the 1970's, MacLisp was in use at over 50 sites. + For further information about Maclisp, +-see {Maclisp Reference Manual, Revision~0} or {The Revised Maclisp Manual}. ++see @b{Maclisp Reference Manual, Revision~0} or @b{The Revised Maclisp Manual}. + + Interlisp introduced many ideas into Lisp programming environments and + methodology. One of the Interlisp ideas that influenced @r{Common Lisp} was an iteration + construct implemented by Warren Teitelman that inspired the @b{loop} + macro used both on the Lisp Machines and in MacLisp, and now in @r{Common Lisp}. + For further information about Interlisp, +-see {Interlisp Reference Manual}. ++see @b{Interlisp Reference Manual}. + + Although the first implementations of Lisp were on the IBM~704 and the + IBM~7090, later work focussed on the DEC +@@ -83,14 +83,14 @@ + that enabled fast function calling. + But the limitations of the PDP-10 were evident by 1973: it supported a + small number of researchers using Lisp, and the small, 18-bit address +-space (2^{18} = 262,144 words) limited the size of a single ++space (2^18 = 262,144 words) limited the size of a single + program. + One response to the address space problem was the Lisp Machine, a + special-purpose computer designed to run Lisp programs. The other + response was to use general-purpose computers with address spaces + larger than 18~bits, such as the DEC VAX and + the S-1~Mark~IIA. +-For further information about S-1 Common Lisp, see ``{S-1 Common Lisp Implementation}.'' ++For further information about S-1 Common Lisp, see @b{S-1 Common Lisp Implementation}. + + The Lisp machine concept was developed in the late 1960's. In the + early 1970's, Peter Deutsch, working with +@@ -107,7 +107,7 @@ + Machine Lisp became available on the early MIT Lisp Machines. + Commercial Lisp machines from Xerox, Lisp Machines (LMI), and + Symbolics were on the market by 1981. +-For further information about Lisp Machine Lisp, see {Lisp Machine Manual}. ++For further information about Lisp Machine Lisp, see @b{Lisp Machine Manual}. + + During the late 1970's, Lisp Machine Lisp began to expand towards a + much fuller language. Sophisticated lambda lists, +@@ -132,7 +132,7 @@ + to Lisp implementation. Eventually the S-1 and NIL groups + collaborated. + For further information about the NIL project, +-see ``{NIL---A Perspective}.'' ++see @b{NIL---A Perspective}. + + The first effort towards Lisp standardization was made in 1969, + when Anthony Hearn and Martin Griss at the University of Utah +@@ -142,7 +142,7 @@ + optimizing compiler for Standard Lisp, + and then an extended implementation known as Portable Standard Lisp (PSL). + By the mid 1980's, PSL ran on about a dozen kinds of computers. +-For further information about Standard Lisp, see ``{Standard LISP Report}.'' ++For further information about Standard Lisp, see @b{Standard LISP Report}. + + PSL and Franz Lisp---a MacLisp-like dialect for Unix machines---were + the first examples of widely available Lisp dialects on multiple +@@ -159,7 +159,8 @@ + closures, first-class continuations, and simplified syntax (no + separation of value cells and function cells). Some of these contributions made + a large impact on the design of @r{Common Lisp}. +-For further information about Scheme, see {IEEE Standard for the Scheme Programming Language} or ``{Revised^3 Report on the Algorithmic Language Scheme}.'' ++For further information about Scheme, see @b{IEEE Standard for the Scheme Programming Language} ++or @b{Revised^3 Report on the Algorithmic Language Scheme}. + + In the late 1970's object-oriented programming concepts started to + make a strong impact on Lisp. +@@ -170,12 +171,13 @@ + At Xerox, the experience with Smalltalk and + Knowledge Representation Language (KRL) led to the development of + Lisp Object Oriented Programming System (LOOPS) and later Common LOOPS. +-For further information on Smalltalk, see {Smalltalk-80: The Language and its Implementation}. +-For further information on Flavors, see {Flavors: A Non-Hierarchical Approach to Object-Oriented Programming}. ++For further information on Smalltalk, see @b{Smalltalk-80: The Language and its Implementation}. ++For further information on Flavors, see @b{Flavors: A Non-Hierarchical Approach to Object-Oriented Programming}. + + These systems influenced the design of the Common Lisp Object System (CLOS). + CLOS was developed specifically for this standardization effort, +-and was separately written up in ``Common Lisp Object System Specification.'' However, minor details ++and was separately written up in @b{Common Lisp Object System Specification}. ++However, minor details + of its design have changed slightly since that publication, and that paper + should not be taken as an authoritative reference to the semantics of the + object system as described in this document. +@@ -254,7 +256,7 @@ + For information about data types, see @ref{Types and Classes}. + Not all @i{types} and @i{classes} are defined in this chapter; + many are defined in chapter corresponding to their topic--for example, +-the numeric types are defined in @ref{Numbers}. ++the numeric types are defined in @ref{Numbers (Numbers)}. + For a complete list of @i{standardized} @i{types}, + see @i{Figure~4--2}. + +@@ -271,32 +273,32 @@ + @table @asis + + @item @t{*} +-{The Anatomy of Lisp}, ++@b{The Anatomy of Lisp}, + John Allen, McGraw-Hill, Inc., 1978. + + @item @t{*} +-{The Art of Computer Programming, Volume 3}, ++@b{The Art of Computer Programming, Volume 3}, + Donald E. Knuth, Addison-Wesley Company (Reading, MA), 1973. + + @item @t{*} +-{The Art of the Metaobject Protocol}, ++@b{The Art of the Metaobject Protocol}, + Kiczales et al., MIT Press (Cambridge, MA), 1991. + + @item @t{*} +-``Common Lisp Object System Specification,'' ++@b{Common Lisp Object System Specification}, + D. Bobrow, L. DiMichiel, R.P. Gabriel, S. Keene, G. Kiczales, D. Moon, + @i{SIGPLAN Notices} V23, September, 1988. + + @item @t{*} +-{Common Lisp: The Language}, ++@b{Common Lisp: The Language}, + Guy L. Steele Jr., Digital Press (Burlington, MA), 1984. + + @item @t{*} +-{Common Lisp: The Language, Second Edition}, ++@b{Common Lisp: The Language, Second Edition}, + Guy L. Steele Jr., Digital Press (Bedford, MA), 1990. + + @item @t{*} +-{Exceptional Situations in Lisp}, ++@b{Exceptional Situations in Lisp}, + Kent M. Pitman, + @i{Proceedings of the First European Conference + on the Practical Application of LISP\/} +@@ -305,21 +307,21 @@ + March 27-29, 1990. + + @item @t{*} +-{Flavors: A Non-Hierarchical Approach to Object-Oriented Programming}, ++@b{Flavors: A Non-Hierarchical Approach to Object-Oriented Programming}, + Howard I. Cannon, 1982. + + @item @t{*} +-{IEEE Standard for Binary Floating-Point Arithmetic}, ++@b{IEEE Standard for Binary Floating-Point Arithmetic}, + ANSI/IEEE Std 754-1985, + Institute of Electrical and Electronics Engineers, Inc. (New York), 1985. + + @item @t{*} +-{IEEE Standard for the Scheme Programming Language}, ++@b{IEEE Standard for the Scheme Programming Language}, + IEEE Std 1178-1990, + Institute of Electrical and Electronic Engineers, Inc. (New York), 1991. + + @item @t{*} +-{Interlisp Reference Manual}, Third Revision, ++@b{Interlisp Reference Manual}, Third Revision, + Teitelman, Warren, et al, + Xerox Palo Alto Research Center (Palo Alto, CA), 1978. + +@@ -331,66 +333,66 @@ + ISO, 1983. + + @item @t{*} +-{Lisp 1.5 Programmer's Manual}, ++@b{Lisp 1.5 Programmer's Manual}, + John McCarthy, MIT Press (Cambridge, MA), August, 1962. + + @item @t{*} +-{Lisp Machine Manual}, ++@b{Lisp Machine Manual}, + D.L. Weinreb and D.A. Moon, + Artificial Intelligence Laboratory, MIT (Cambridge, MA), July, 1981. + + @item @t{*} +-{Maclisp Reference Manual, Revision~0}, ++@b{Maclisp Reference Manual, Revision~0}, + David A. Moon, Project MAC (Laboratory for Computer Science), + MIT (Cambridge, MA), March, 1974. + + @item @t{*} +-``{NIL---A Perspective},'' ++@b{NIL---A Perspective}, + JonL White, @i{Macsyma User's Conference}, 1979. + + @item @t{*} +-{Performance and Evaluation of Lisp Programs}, ++@b{Performance and Evaluation of Lisp Programs}, + Richard P. Gabriel, MIT Press (Cambridge, MA), 1985. + + @item @t{*} +-``{Principal Values and Branch Cuts in Complex APL},'' ++@b{Principal Values and Branch Cuts in Complex APL}, + Paul Penfield Jr., @i{APL 81 Conference Proceedings}, + ACM SIGAPL (San Francisco, September 1981), 248-256. + Proceedings published as @i{APL Quote Quad 12}, 1 (September 1981). + + @item @t{*} +-{The Revised Maclisp Manual}, ++@b{The Revised Maclisp Manual}, + Kent M. Pitman, + Technical Report 295, + Laboratory for Computer Science, MIT (Cambridge, MA), May 1983. + + @item @t{*} +-``{Revised^3 Report on the Algorithmic Language Scheme},'' ++@b{Revised^3 Report on the Algorithmic Language Scheme}, + Jonathan Rees and William Clinger (editors), + @i{SIGPLAN Notices} V21, #12, December, 1986. + + @item @t{*} +-``S-1 Common Lisp Implementation,'' ++@b{S-1 Common Lisp Implementation}, + R.A. Brooks, R.P. Gabriel, and G.L. Steele, + @i{Conference Record of the 1982 ACM Symposium on Lisp and Functional Programming}, + 108-113, 1982. + + @item @t{*} +-@i{Smalltalk-80: The Language and its Implementation}, ++@b{Smalltalk-80: The Language and its Implementation}, + A. Goldberg and D. Robson, Addison-Wesley, 1983. + + @item @t{*} +-``{Standard LISP Report},'' ++@b{Standard LISP Report}, + J.B. Marti, A.C. Hearn, M.L. Griss, and C. Griss, + @i{SIGPLAN Notices} V14, #10, October, 1979. + + @item @t{*} +-{Webster's Third New International Dictionary ++@b{Webster's Third New International Dictionary + the English Language, Unabridged}, + Merriam Webster (Springfield, MA), 1986. + + @item @t{*} +-@i{XP: A Common Lisp Pretty Printing System}, ++@b{XP: A Common Lisp Pretty Printing System}, + R.C. Waters, + Memo 1102a, + Artificial Intelligence Laboratory, MIT (Cambridge, MA), September 1989. +@@ -638,15 +640,15 @@ + within the BNF, but might still be useful elsewhere. For example, consider the + following definitions: + +-@code{case} @i{keyform @{!@i{normal-clause}@}{*} @r{[}!@i{otherwise-clause}@r{]}} @result{} @i{@{@i{result}@}{*}} ++@code{case} @i{keyform @{!@i{normal-clause}@}* @r{[}!@i{otherwise-clause}@r{]}} @result{} @i{@{@i{result}@}*} + +-@code{ccase} @i{keyplace @{!@i{normal-clause}@}{*}} @result{} @i{@{@i{result}@}{*}} ++@code{ccase} @i{keyplace @{!@i{normal-clause}@}*} @result{} @i{@{@i{result}@}*} + +-@code{ecase} @i{keyform @{!@i{normal-clause}@}{*}} @result{} @i{@{@i{result}@}{*}} ++@code{ecase} @i{keyform @{!@i{normal-clause}@}*} @result{} @i{@{@i{result}@}*} + +-@w{@i{normal-clause} ::=@r{(}keys @{@i{form}@}{*}@r{)}} ++@w{@i{normal-clause} ::=@r{(}keys @{@i{form}@}*@r{)}} + +-@w{@i{otherwise-clause} ::=@r{(}@{otherwise | t@} @{@i{form}@}{*}@r{)}} ++@w{@i{otherwise-clause} ::=@r{(}@{otherwise | t@} @{@i{form}@}*@r{)}} + + @w{@i{clause} ::=normal-clause | otherwise-clause} + +@@ -697,7 +699,7 @@ + other indicator) before showing return values, while others do not. + + @item @i{OR}@result{} +-The notation ``{@i{OR}@result{}}'' is used to denote one of several possible ++The notation ``@i{OR}@result{}'' is used to denote one of several possible + alternate results. The example + + @example +@@ -722,7 +724,7 @@ + of the ways in which it is permitted for implementations to diverge. + + @item @i{NOT}@result{} +-The notation ``{@i{NOT}@result{}}'' is used to denote a result which is not possible. ++The notation ``@i{NOT}@result{}'' is used to denote a result which is not possible. + This might be used, for example, in order to emphasize a situation where + some anticipated misconception might lead the reader to falsely believe + that the result might be possible. For example, +@@ -750,7 +752,7 @@ + @t{(gcd (gcd x y) z)} for any + @t{x}, @t{y}, and @t{z}. + +-@item {@t{ |> }} ++@item @t{ |> } + @r{Common Lisp} specifies input and output with respect to a non-interactive stream model. + The specific details of how interactive input and output are mapped onto that + non-interactive model are @i{implementation-defined}. +@@ -765,7 +767,7 @@ + a buffer full of input without the command itself being visible on the program's + input stream. + +-In the examples in this document, the notation ``{@t{ |> }}'' precedes ++In the examples in this document, the notation ``@t{ |> }'' precedes + lines where interactive input and output occurs. Within such a scenario, + ``@b{|>>}@t{this notation}@b{<<|}'' notates user input. + +@@ -791,11 +793,11 @@ + Sometimes, the non-interactive stream model calls for a @i{newline}. + How that @i{newline} character is interactively entered is an + @i{implementation-defined} detail of the user interface, but in that +-case, either the notation ``<@i{Newline}>'' or ``{@i{[<--}~]}'' might be used. ++case, either the notation ``<@i{Newline}>'' or ``@i{[<--}~]'' might be used. + + @example + (progn (format t "~&Who? ") (read-line)) +-@t{ |> } Who? @b{|>>}@t{Fred, Mary, and Sally{@i{[<--}~]}}@b{<<|} ++@t{ |> } Who? @b{|>>}@t{Fred, Mary, and Sally @i{[<--}~]}@b{<<|} + @result{} "Fred, Mary, and Sally", @i{false} + @end example + +@@ -886,6 +888,7 @@ + By convention, the choice of notation offers a hint as to which of its many + roles it is playing. + ++@format + @group + @noindent + @w{ @b{For Evaluation?} @b{Notation} @b{Typically Implied Role} } +@@ -900,6 +903,7 @@ + @w{ Figure 1--1: Notations for NIL } + + @end group ++@end format + + Within this document only, @b{nil} is also sometimes notated as @i{false} to + emphasize its role as a @i{boolean}. +@@ -1263,42 +1267,42 @@ + dictionary entry. + + @menu +-* The ``Affected By'' Section of a Dictionary Entry:: +-* The ``Arguments'' Section of a Dictionary Entry:: +-* The ``Arguments and Values'' Section of a Dictionary Entry:: +-* The ``Binding Types Affected'' Section of a Dictionary Entry:: +-* The ``Class Precedence List'' Section of a Dictionary Entry:: ++* The "Affected By" Section of a Dictionary Entry:: ++* The "Arguments" Section of a Dictionary Entry:: ++* The "Arguments and Values" Section of a Dictionary Entry:: ++* The "Binding Types Affected" Section of a Dictionary Entry:: ++* The "Class Precedence List" Section of a Dictionary Entry:: + * Dictionary Entries for Type Specifiers:: +-* The ``Compound Type Specifier Kind'' Section of a Dictionary Entry:: +-* The ``Compound Type Specifier Syntax'' Section of a Dictionary Entry:: +-* The ``Compound Type Specifier Arguments'' Section of a Dictionary Entry:: +-* The ``Compound Type Specifier Description'' Section of a Dictionary Entry:: +-* The ``Constant Value'' Section of a Dictionary Entry:: +-* The ``Description'' Section of a Dictionary Entry:: +-* The ``Examples'' Section of a Dictionary Entry:: +-* The ``Exceptional Situations'' Section of a Dictionary Entry:: +-* The ``Initial Value'' Section of a Dictionary Entry:: +-* The ``Argument Precedence Order'' Section of a Dictionary Entry:: +-* The ``Method Signature'' Section of a Dictionary Entry:: +-* The ``Name'' Section of a Dictionary Entry:: +-* The ``Notes'' Section of a Dictionary Entry:: +-* The ``Pronunciation'' Section of a Dictionary Entry:: +-* The ``See Also'' Section of a Dictionary Entry:: +-* The ``Side Effects'' Section of a Dictionary Entry:: +-* The ``Supertypes'' Section of a Dictionary Entry:: +-* The ``Syntax'' Section of a Dictionary Entry:: +-* Special ``Syntax'' Notations for Overloaded Operators:: ++* The "Compound Type Specifier Kind" Section of a Dictionary Entry:: ++* The "Compound Type Specifier Syntax" Section of a Dictionary Entry:: ++* The "Compound Type Specifier Arguments" Section of a Dictionary Entry:: ++* The "Compound Type Specifier Description" Section of a Dictionary Entry:: ++* The "Constant Value" Section of a Dictionary Entry:: ++* The "Description" Section of a Dictionary Entry:: ++* The "Examples" Section of a Dictionary Entry:: ++* The "Exceptional Situations" Section of a Dictionary Entry:: ++* The "Initial Value" Section of a Dictionary Entry:: ++* The "Argument Precedence Order" Section of a Dictionary Entry:: ++* The "Method Signature" Section of a Dictionary Entry:: ++* The "Name" Section of a Dictionary Entry:: ++* The "Notes" Section of a Dictionary Entry:: ++* The "Pronunciation" Section of a Dictionary Entry:: ++* The "See Also" Section of a Dictionary Entry:: ++* The "Side Effects" Section of a Dictionary Entry:: ++* The "Supertypes" Section of a Dictionary Entry:: ++* The "Syntax" Section of a Dictionary Entry:: ++* Special "Syntax" Notations for Overloaded Operators:: + * Naming Conventions for Rest Parameters:: +-* Requiring Non-Null Rest Parameters in the ``Syntax'' Section:: +-* Return values in the ``Syntax'' Section:: +-* No Arguments or Values in the ``Syntax'' Section:: +-* Unconditional Transfer of Control in the ``Syntax'' Section:: +-* The ``Valid Context'' Section of a Dictionary Entry:: +-* The ``Value Type'' Section of a Dictionary Entry:: ++* Requiring Non-Null Rest Parameters in The "Syntax" Section:: ++* Return values in The "Syntax" Section:: ++* No Arguments or Values in The "Syntax" Section:: ++* Unconditional Transfer of Control in The "Syntax" Section:: ++* The "Valid Context" Section of a Dictionary Entry:: ++* The "Value Type" Section of a Dictionary Entry:: + @end menu + +-@node The ``Affected By'' Section of a Dictionary Entry, The ``Arguments'' Section of a Dictionary Entry, Interpreting Dictionary Entries, Interpreting Dictionary Entries +-@subsubsection The ``Affected By'' Section of a Dictionary Entry ++@node The "Affected By" Section of a Dictionary Entry, The "Arguments" Section of a Dictionary Entry, Interpreting Dictionary Entries, Interpreting Dictionary Entries ++@subsubsection The "Affected By" Section of a Dictionary Entry + + For an @i{operator}, anything that can affect the side effects of + or @i{values} returned by the @i{operator}. +@@ -1306,15 +1310,15 @@ + For a @i{variable}, anything that can affect the @i{value} of the @i{variable} + including @i{functions} that bind or assign it. + +-@node The ``Arguments'' Section of a Dictionary Entry, The ``Arguments and Values'' Section of a Dictionary Entry, The ``Affected By'' Section of a Dictionary Entry, Interpreting Dictionary Entries +-@subsubsection The ``Arguments'' Section of a Dictionary Entry ++@node The "Arguments" Section of a Dictionary Entry, The "Arguments and Values" Section of a Dictionary Entry, The "Affected By" Section of a Dictionary Entry, Interpreting Dictionary Entries ++@subsubsection The "Arguments" Section of a Dictionary Entry + + This information describes the syntax information of entries such as those for + @i{declarations} and special @i{expressions} which are never @i{evaluated} + as @i{forms}, and so do not return @i{values}. + +-@node The ``Arguments and Values'' Section of a Dictionary Entry, The ``Binding Types Affected'' Section of a Dictionary Entry, The ``Arguments'' Section of a Dictionary Entry, Interpreting Dictionary Entries +-@subsubsection The ``Arguments and Values'' Section of a Dictionary Entry ++@node The "Arguments and Values" Section of a Dictionary Entry, The "Binding Types Affected" Section of a Dictionary Entry, The "Arguments" Section of a Dictionary Entry, Interpreting Dictionary Entries ++@subsubsection The "Arguments and Values" Section of a Dictionary Entry + + An English language description of what @i{arguments} the @i{operator} accepts + and what @i{values} it returns, including information about defaults for @i{parameters} +@@ -1324,16 +1328,16 @@ + their @i{arguments} are not @i{evaluated} unless it is explicitly stated in their + descriptions that they are @i{evaluated}. + +-@node The ``Binding Types Affected'' Section of a Dictionary Entry, The ``Class Precedence List'' Section of a Dictionary Entry, The ``Arguments and Values'' Section of a Dictionary Entry, Interpreting Dictionary Entries +-@subsubsection The ``Binding Types Affected'' Section of a Dictionary Entry ++@node The "Binding Types Affected" Section of a Dictionary Entry, The "Class Precedence List" Section of a Dictionary Entry, The "Arguments and Values" Section of a Dictionary Entry, Interpreting Dictionary Entries ++@subsubsection The "Binding Types Affected" Section of a Dictionary Entry + + This information alerts the reader to the kinds of @i{bindings} that might + potentially be affected by a declaration. Whether in fact any particular such + @i{binding} is actually affected is dependent on additional factors as well. +-See the ``Description'' section of the declaration in question for details. ++See The "Description" Section of the declaration in question for details. + +-@node The ``Class Precedence List'' Section of a Dictionary Entry, Dictionary Entries for Type Specifiers, The ``Binding Types Affected'' Section of a Dictionary Entry, Interpreting Dictionary Entries +-@subsubsection The ``Class Precedence List'' Section of a Dictionary Entry ++@node The "Class Precedence List" Section of a Dictionary Entry, Dictionary Entries for Type Specifiers, The "Binding Types Affected" Section of a Dictionary Entry, Interpreting Dictionary Entries ++@subsubsection The "Class Precedence List" Section of a Dictionary Entry + + This appears in the dictionary entry for a @i{class}, + and contains an ordered list of the @i{classes} defined +@@ -1356,7 +1360,7 @@ + the @i{classes} listed in this section are also @i{supertypes} of + the @i{type} denoted by the @i{class}. + +-@node Dictionary Entries for Type Specifiers, The ``Compound Type Specifier Kind'' Section of a Dictionary Entry, The ``Class Precedence List'' Section of a Dictionary Entry, Interpreting Dictionary Entries ++@node Dictionary Entries for Type Specifiers, The "Compound Type Specifier Kind" Section of a Dictionary Entry, The "Class Precedence List" Section of a Dictionary Entry, Interpreting Dictionary Entries + @subsubsection Dictionary Entries for Type Specifiers + + The @i{atomic type specifiers} are those @i{defined names} +@@ -1366,7 +1370,7 @@ + A description of how to interpret + a @i{symbol} naming one of these @i{types} or @i{classes} + as an @i{atomic type specifier} +-is found in the ``Description'' section of such dictionary entries. ++is found in The "Description" Section of such dictionary entries. + + The @i{compound type specifiers} are those @i{defined names} + listed in @i{Figure~4--3}. +@@ -1381,8 +1385,8 @@ + and ``Compound Type Specifier Description'' + sections of such dictionary entries. + +-@node The ``Compound Type Specifier Kind'' Section of a Dictionary Entry, The ``Compound Type Specifier Syntax'' Section of a Dictionary Entry, Dictionary Entries for Type Specifiers, Interpreting Dictionary Entries +-@subsubsection The ``Compound Type Specifier Kind'' Section of a Dictionary Entry ++@node The "Compound Type Specifier Kind" Section of a Dictionary Entry, The "Compound Type Specifier Syntax" Section of a Dictionary Entry, Dictionary Entries for Type Specifiers, Interpreting Dictionary Entries ++@subsubsection The "Compound Type Specifier Kind" Section of a Dictionary Entry + + An ``abbreviating'' @i{type specifier} is one that describes a @i{subtype} + for which it is in principle possible to enumerate the @i{elements}, +@@ -1399,8 +1403,8 @@ + in a compositional way, using combining operations (such as ``and,'' ``or,'' and + ``not'') on other @i{types}. + +-@node The ``Compound Type Specifier Syntax'' Section of a Dictionary Entry, The ``Compound Type Specifier Arguments'' Section of a Dictionary Entry, The ``Compound Type Specifier Kind'' Section of a Dictionary Entry, Interpreting Dictionary Entries +-@subsubsection The ``Compound Type Specifier Syntax'' Section of a Dictionary Entry ++@node The "Compound Type Specifier Syntax" Section of a Dictionary Entry, The "Compound Type Specifier Arguments" Section of a Dictionary Entry, The "Compound Type Specifier Kind" Section of a Dictionary Entry, Interpreting Dictionary Entries ++@subsubsection The "Compound Type Specifier Syntax" Section of a Dictionary Entry + + This information about a @i{type} describes the syntax of a + @i{compound type specifier} for that @i{type}. +@@ -1408,40 +1412,40 @@ + Whether or not the @i{type} is acceptable as an @i{atomic type specifier} + is not represented here; see @ref{Dictionary Entries for Type Specifiers}. + +-@node The ``Compound Type Specifier Arguments'' Section of a Dictionary Entry, The ``Compound Type Specifier Description'' Section of a Dictionary Entry, The ``Compound Type Specifier Syntax'' Section of a Dictionary Entry, Interpreting Dictionary Entries +-@subsubsection The ``Compound Type Specifier Arguments'' Section of a Dictionary Entry ++@node The "Compound Type Specifier Arguments" Section of a Dictionary Entry, The "Compound Type Specifier Description" Section of a Dictionary Entry, The "Compound Type Specifier Syntax" Section of a Dictionary Entry, Interpreting Dictionary Entries ++@subsubsection The "Compound Type Specifier Arguments" Section of a Dictionary Entry + + This information describes @i{type} information for the structures defined in +-the ``Compound Type Specifier Syntax'' section. ++The "Compound Type Specifier Syntax" Section. + +-@node The ``Compound Type Specifier Description'' Section of a Dictionary Entry, The ``Constant Value'' Section of a Dictionary Entry, The ``Compound Type Specifier Arguments'' Section of a Dictionary Entry, Interpreting Dictionary Entries +-@subsubsection The ``Compound Type Specifier Description'' Section of a Dictionary Entry ++@node The "Compound Type Specifier Description" Section of a Dictionary Entry, The "Constant Value" Section of a Dictionary Entry, The "Compound Type Specifier Arguments" Section of a Dictionary Entry, Interpreting Dictionary Entries ++@subsubsection The "Compound Type Specifier Description" Section of a Dictionary Entry + + This information describes the meaning of the structures defined in +-the ``Compound Type Specifier Syntax'' section. ++The "Compound Type Specifier Syntax" Section. + +-@node The ``Constant Value'' Section of a Dictionary Entry, The ``Description'' Section of a Dictionary Entry, The ``Compound Type Specifier Description'' Section of a Dictionary Entry, Interpreting Dictionary Entries +-@subsubsection The ``Constant Value'' Section of a Dictionary Entry ++@node The "Constant Value" Section of a Dictionary Entry, The "Description" Section of a Dictionary Entry, The "Compound Type Specifier Description" Section of a Dictionary Entry, Interpreting Dictionary Entries ++@subsubsection The "Constant Value" Section of a Dictionary Entry + + This information describes the unchanging @i{type} and @i{value} of + a @i{constant variable}. + +-@node The ``Description'' Section of a Dictionary Entry, The ``Examples'' Section of a Dictionary Entry, The ``Constant Value'' Section of a Dictionary Entry, Interpreting Dictionary Entries +-@subsubsection The ``Description'' Section of a Dictionary Entry ++@node The "Description" Section of a Dictionary Entry, The "Examples" Section of a Dictionary Entry, The "Constant Value" Section of a Dictionary Entry, Interpreting Dictionary Entries ++@subsubsection The "Description" Section of a Dictionary Entry + + A summary of the @i{operator} and all intended aspects of the @i{operator}, + but does not necessarily include all the fields referenced below it + (``Side Effects,'' ``Exceptional Situations,'' @i{etc.}) + +-@node The ``Examples'' Section of a Dictionary Entry, The ``Exceptional Situations'' Section of a Dictionary Entry, The ``Description'' Section of a Dictionary Entry, Interpreting Dictionary Entries +-@subsubsection The ``Examples'' Section of a Dictionary Entry ++@node The "Examples" Section of a Dictionary Entry, The "Exceptional Situations" Section of a Dictionary Entry, The "Description" Section of a Dictionary Entry, Interpreting Dictionary Entries ++@subsubsection The "Examples" Section of a Dictionary Entry + + Examples of use of the @i{operator}. + These examples are not considered part of the standard; + see @ref{Sections Not Formally Part Of This Standard}. + +-@node The ``Exceptional Situations'' Section of a Dictionary Entry, The ``Initial Value'' Section of a Dictionary Entry, The ``Examples'' Section of a Dictionary Entry, Interpreting Dictionary Entries +-@subsubsection The ``Exceptional Situations'' Section of a Dictionary Entry ++@node The "Exceptional Situations" Section of a Dictionary Entry, The "Initial Value" Section of a Dictionary Entry, The "Examples" Section of a Dictionary Entry, Interpreting Dictionary Entries ++@subsubsection The "Exceptional Situations" Section of a Dictionary Entry + + Three kinds of information may appear here: + @table @asis +@@ -1459,20 +1463,20 @@ + as arguments or through dynamic variables, nor by executing subforms of this + operator if it is a @i{macro} or @i{special operator}. + +-@node The ``Initial Value'' Section of a Dictionary Entry, The ``Argument Precedence Order'' Section of a Dictionary Entry, The ``Exceptional Situations'' Section of a Dictionary Entry, Interpreting Dictionary Entries +-@subsubsection The ``Initial Value'' Section of a Dictionary Entry ++@node The "Initial Value" Section of a Dictionary Entry, The "Argument Precedence Order" Section of a Dictionary Entry, The "Exceptional Situations" Section of a Dictionary Entry, Interpreting Dictionary Entries ++@subsubsection The "Initial Value" Section of a Dictionary Entry + + This information describes the initial @i{value} of a @i{dynamic variable}. +-Since this variable might change, see @i{type} restrictions in the ``Value Type'' section. ++Since this variable might change, see @i{type} restrictions in The "Value Type" Section. + +-@node The ``Argument Precedence Order'' Section of a Dictionary Entry, The ``Method Signature'' Section of a Dictionary Entry, The ``Initial Value'' Section of a Dictionary Entry, Interpreting Dictionary Entries +-@subsubsection The ``Argument Precedence Order'' Section of a Dictionary Entry ++@node The "Argument Precedence Order" Section of a Dictionary Entry, The "Method Signature" Section of a Dictionary Entry, The "Initial Value" Section of a Dictionary Entry, Interpreting Dictionary Entries ++@subsubsection The "Argument Precedence Order" Section of a Dictionary Entry + + This information describes the argument precedence order. + If it is omitted, the argument precedence order is the default (left to right). + +-@node The ``Method Signature'' Section of a Dictionary Entry, The ``Name'' Section of a Dictionary Entry, The ``Argument Precedence Order'' Section of a Dictionary Entry, Interpreting Dictionary Entries +-@subsubsection The ``Method Signature'' Section of a Dictionary Entry ++@node The "Method Signature" Section of a Dictionary Entry, The "Name" Section of a Dictionary Entry, The "Argument Precedence Order" Section of a Dictionary Entry, Interpreting Dictionary Entries ++@subsubsection The "Method Signature" Section of a Dictionary Entry + + The description of a @i{generic function} includes descriptions of the + @i{methods} that are defined on that @i{generic function} by the standard. +@@ -1483,7 +1487,7 @@ + + @code{F} @i{@r{(}@i{x} @i{class}@r{)} + @r{(}@i{y} t@r{)} +- {&optional} @i{z} {&key} @i{k}} ++ @r{&optional} @i{z} @r{&key} @i{k}} + + @noindent + This @i{signature} indicates that this method on the @i{generic function} +@@ -1503,8 +1507,8 @@ + @i{implementation-defined} or user-defined @i{methods} in situations + where the definition of such @i{methods} is permitted). + +-@node The ``Name'' Section of a Dictionary Entry, The ``Notes'' Section of a Dictionary Entry, The ``Method Signature'' Section of a Dictionary Entry, Interpreting Dictionary Entries +-@subsubsection The ``Name'' Section of a Dictionary Entry ++@node The "Name" Section of a Dictionary Entry, The "Notes" Section of a Dictionary Entry, The "Method Signature" Section of a Dictionary Entry, Interpreting Dictionary Entries ++@subsubsection The "Name" Section of a Dictionary Entry + + This section introduces the dictionary entry. It is not explicitly labeled. + It appears preceded and followed by a horizontal bar. +@@ -1579,8 +1583,8 @@ + + @end table + +-@node The ``Notes'' Section of a Dictionary Entry, The ``Pronunciation'' Section of a Dictionary Entry, The ``Name'' Section of a Dictionary Entry, Interpreting Dictionary Entries +-@subsubsection The ``Notes'' Section of a Dictionary Entry ++@node The "Notes" Section of a Dictionary Entry, The "Pronunciation" Section of a Dictionary Entry, The "Name" Section of a Dictionary Entry, Interpreting Dictionary Entries ++@subsubsection The "Notes" Section of a Dictionary Entry + + Information not found elsewhere in this description + which pertains to this @i{operator}. +@@ -1594,32 +1598,32 @@ + any @i{conforming implementation} or @i{conforming program} + is permitted to ignore the presence of this information. + +-@node The ``Pronunciation'' Section of a Dictionary Entry, The ``See Also'' Section of a Dictionary Entry, The ``Notes'' Section of a Dictionary Entry, Interpreting Dictionary Entries +-@subsubsection The ``Pronunciation'' Section of a Dictionary Entry ++@node The "Pronunciation" Section of a Dictionary Entry, The "See Also" Section of a Dictionary Entry, The "Notes" Section of a Dictionary Entry, Interpreting Dictionary Entries ++@subsubsection The "Pronunciation" Section of a Dictionary Entry + + This offers a suggested pronunciation for @i{defined names} + so that people not in verbal communication with the original designers + can figure out how to pronounce words that are not in normal English usage. + This information is advisory only, and is not considered part of the standard. + For brevity, it is only provided for entries with names that are specific to +-@r{Common Lisp} and would not be found in {Webster's Third New International Dictionary ++@r{Common Lisp} and would not be found in @b{Webster's Third New International Dictionary + the English Language, Unabridged}. + +-@node The ``See Also'' Section of a Dictionary Entry, The ``Side Effects'' Section of a Dictionary Entry, The ``Pronunciation'' Section of a Dictionary Entry, Interpreting Dictionary Entries +-@subsubsection The ``See Also'' Section of a Dictionary Entry ++@node The "See Also" Section of a Dictionary Entry, The "Side Effects" Section of a Dictionary Entry, The "Pronunciation" Section of a Dictionary Entry, Interpreting Dictionary Entries ++@subsubsection The "See Also" Section of a Dictionary Entry + + List of references to other parts of this standard + that offer information relevant to this @i{operator}. + This list is not part of the standard. + +-@node The ``Side Effects'' Section of a Dictionary Entry, The ``Supertypes'' Section of a Dictionary Entry, The ``See Also'' Section of a Dictionary Entry, Interpreting Dictionary Entries +-@subsubsection The ``Side Effects'' Section of a Dictionary Entry ++@node The "Side Effects" Section of a Dictionary Entry, The "Supertypes" Section of a Dictionary Entry, The "See Also" Section of a Dictionary Entry, Interpreting Dictionary Entries ++@subsubsection The "Side Effects" Section of a Dictionary Entry + + Anything that is changed as a result of the + evaluation of the @i{form} containing this @i{operator}. + +-@node The ``Supertypes'' Section of a Dictionary Entry, The ``Syntax'' Section of a Dictionary Entry, The ``Side Effects'' Section of a Dictionary Entry, Interpreting Dictionary Entries +-@subsubsection The ``Supertypes'' Section of a Dictionary Entry ++@node The "Supertypes" Section of a Dictionary Entry, The "Syntax" Section of a Dictionary Entry, The "Side Effects" Section of a Dictionary Entry, Interpreting Dictionary Entries ++@subsubsection The "Supertypes" Section of a Dictionary Entry + + This appears in the dictionary entry for a @i{type}, + and contains a list of the @i{standardized} @i{types} +@@ -1629,15 +1633,15 @@ + the order of the @i{classes} in the @i{class precedence list} + is consistent with the order presented in this section. + +-@node The ``Syntax'' Section of a Dictionary Entry, Special ``Syntax'' Notations for Overloaded Operators, The ``Supertypes'' Section of a Dictionary Entry, Interpreting Dictionary Entries +-@subsubsection The ``Syntax'' Section of a Dictionary Entry ++@node The "Syntax" Section of a Dictionary Entry, Special "Syntax" Notations for Overloaded Operators, The "Supertypes" Section of a Dictionary Entry, Interpreting Dictionary Entries ++@subsubsection The "Syntax" Section of a Dictionary Entry + + This section describes how to use the @i{defined name} in code. +-The ``Syntax'' description for a @i{generic function} ++The "Syntax'' description for a @i{generic function} + describes the @i{lambda list} of the @i{generic function} itself, +-while the ``Method Signatures'' describe the @i{lambda lists} ++while The "Method Signatures'' describe the @i{lambda lists} + of the defined @i{methods}. +-The ``Syntax'' description for ++The "Syntax'' description for + an @i{ordinary function}, + a @i{macro}, + or a @i{special operator} +@@ -1645,7 +1649,7 @@ + + For example, an @i{operator} description might say: + +-@code{F} @i{x y {&optional} z {&key} k} ++@code{F} @i{x y @r{&optional} z @r{&key} k} + + @noindent + This description indicates that the function @b{F} +@@ -1658,8 +1662,8 @@ + In both cases, however, the outermost parentheses are omitted, + and default value information is omitted. + +-@node Special ``Syntax'' Notations for Overloaded Operators, Naming Conventions for Rest Parameters, The ``Syntax'' Section of a Dictionary Entry, Interpreting Dictionary Entries +-@subsubsection Special ``Syntax'' Notations for Overloaded Operators ++@node Special "Syntax" Notations for Overloaded Operators, Naming Conventions for Rest Parameters, The "Syntax" Section of a Dictionary Entry, Interpreting Dictionary Entries ++@subsubsection Special "Syntax" Notations for Overloaded Operators + + If two descriptions exist for the same operation but with different numbers of + arguments, then the extra arguments are to be treated as optional. For example, +@@ -1672,7 +1676,7 @@ + @noindent + is operationally equivalent to this line: + +-@code{file-position} @i{stream {&optional} position-spec} @result{} @i{result} ++@code{file-position} @i{stream @r{&optional} position-spec} @result{} @i{result} + + @noindent + and differs only in that it provides on opportunity to introduce different +@@ -1682,7 +1686,7 @@ + depending on how many @i{arguments} are supplied (@i{e.g.}, for the @i{function} @b{/}) + or the return values are different in the two cases (@i{e.g.}, for the @i{function} @b{file-position}). + +-@node Naming Conventions for Rest Parameters, Requiring Non-Null Rest Parameters in the ``Syntax'' Section, Special ``Syntax'' Notations for Overloaded Operators, Interpreting Dictionary Entries ++@node Naming Conventions for Rest Parameters, Requiring Non-Null Rest Parameters in The "Syntax" Section, Special "Syntax" Notations for Overloaded Operators, Interpreting Dictionary Entries + @subsubsection Naming Conventions for Rest Parameters + + Within this specification, +@@ -1694,15 +1698,15 @@ + + For example, given a syntax description such as: + +-@code{F} @i{{&rest} @i{arguments}} ++@code{F} @i{@r{&rest} @i{arguments}} + + @noindent + it is appropriate to refer either to the @i{rest parameter} named + @i{arguments} by name, or to one of its elements by speaking of ``an @i{argument},'' + ``some @i{argument},'' ``each @i{argument}'' @i{etc.} + +-@node Requiring Non-Null Rest Parameters in the ``Syntax'' Section, Return values in the ``Syntax'' Section, Naming Conventions for Rest Parameters, Interpreting Dictionary Entries +-@subsubsection Requiring Non-Null Rest Parameters in the ``Syntax'' Section ++@node Requiring Non-Null Rest Parameters in The "Syntax" Section, Return values in The "Syntax" Section, Naming Conventions for Rest Parameters, Interpreting Dictionary Entries ++@subsubsection Requiring Non-Null Rest Parameters in The "Syntax" Section + + In some cases it is useful to refer to all arguments equally as a single + aggregation using a @i{rest parameter} while at the same time +@@ -1711,21 +1715,21 @@ + restriction, however they generally do not manifest themselves in a + @i{lambda list}. For descriptive purposes within this specification, + +-@code{F} @i{{&rest} arguments^+} ++@code{F} @i{@r{&rest} arguments^+} + + @noindent + means the same as + +-@code{F} @i{{&rest} arguments} ++@code{F} @i{@r{&rest} arguments} + + @noindent + but introduces the additional requirement that there be + at least one @i{argument}. + +-@node Return values in the ``Syntax'' Section, No Arguments or Values in the ``Syntax'' Section, Requiring Non-Null Rest Parameters in the ``Syntax'' Section, Interpreting Dictionary Entries +-@subsubsection Return values in the ``Syntax'' Section ++@node Return values in The "Syntax" Section, No Arguments or Values in The "Syntax" Section, Requiring Non-Null Rest Parameters in The "Syntax" Section, Interpreting Dictionary Entries ++@subsubsection Return values in The "Syntax" Section + +-An evaluation arrow ``{@result{} }'' precedes a list of @i{values} to be returned. ++An evaluation arrow ``@result{}'' precedes a list of @i{values} to be returned. + For example: + + @code{F} @i{a b c} @result{} @i{x} +@@ -1738,8 +1742,8 @@ + + @code{F} @i{a b c} @result{} @i{x, y, z} + +-@node No Arguments or Values in the ``Syntax'' Section, Unconditional Transfer of Control in the ``Syntax'' Section, Return values in the ``Syntax'' Section, Interpreting Dictionary Entries +-@subsubsection No Arguments or Values in the ``Syntax'' Section ++@node No Arguments or Values in The "Syntax" Section, Unconditional Transfer of Control in The "Syntax" Section, Return values in The "Syntax" Section, Interpreting Dictionary Entries ++@subsubsection No Arguments or Values in The "Syntax" Section + + If no @i{arguments} are permitted, or no @i{values} are returned, + a special notation is used to make this more visually apparent. For example, +@@ -1749,8 +1753,8 @@ + indicates that @t{F} is an operator that accepts no @i{arguments} and returns + no @i{values}. + +-@node Unconditional Transfer of Control in the ``Syntax'' Section, The ``Valid Context'' Section of a Dictionary Entry, No Arguments or Values in the ``Syntax'' Section, Interpreting Dictionary Entries +-@subsubsection Unconditional Transfer of Control in the ``Syntax'' Section ++@node Unconditional Transfer of Control in The "Syntax" Section, The "Valid Context" Section of a Dictionary Entry, No Arguments or Values in The "Syntax" Section, Interpreting Dictionary Entries ++@subsubsection Unconditional Transfer of Control in The "Syntax" Section + + Some @i{operators} perform an unconditional transfer of control, and + so never have any return values. Such @i{operators} are notated using +@@ -1759,8 +1763,8 @@ + @code{F} @i{a b c} + @result{} # + +-@node The ``Valid Context'' Section of a Dictionary Entry, The ``Value Type'' Section of a Dictionary Entry, Unconditional Transfer of Control in the ``Syntax'' Section, Interpreting Dictionary Entries +-@subsubsection The ``Valid Context'' Section of a Dictionary Entry ++@node The "Valid Context" Section of a Dictionary Entry, The "Value Type" Section of a Dictionary Entry, Unconditional Transfer of Control in The "Syntax" Section, Interpreting Dictionary Entries ++@subsubsection The "Valid Context" Section of a Dictionary Entry + + This information is used by dictionary entries such as ``Declarations'' + in order to restrict the context in which the declaration may appear. +@@ -1770,8 +1774,8 @@ + a @i{proclamation} (@i{i.e.}, a @b{declaim} or @b{proclaim} @i{form}), + or both. + +-@node The ``Value Type'' Section of a Dictionary Entry, , The ``Valid Context'' Section of a Dictionary Entry, Interpreting Dictionary Entries +-@subsubsection The ``Value Type'' Section of a Dictionary Entry ++@node The "Value Type" Section of a Dictionary Entry, , The "Valid Context" Section of a Dictionary Entry, Interpreting Dictionary Entries ++@subsubsection The "Value Type" Section of a Dictionary Entry + + This information describes any @i{type} restrictions on a @i{dynamic variable}. + +@@ -2103,6 +2107,7 @@ + @subsection Deprecated Functions + + The @i{functions} in Figure 1--2 are deprecated. ++@format + @group + @noindent + @w{ assoc-if-not nsubst-if-not require } +@@ -2116,6 +2121,7 @@ + @w{ Figure 1--2: Deprecated Functions } + + @end group ++@end format + + @node Deprecated Argument Conventions, Deprecated Variables, Deprecated Functions, Deprecated Language Features + @subsection Deprecated Argument Conventions +@@ -2124,6 +2130,7 @@ + + The @t{:test-not} @i{argument} to the @i{functions} in Figure 1--3 are deprecated. + ++@format + @group + @noindent + @w{ adjoin nset-difference search } +@@ -2141,6 +2148,7 @@ + @w{ Figure 1--3: Functions with Deprecated :TEST-NOT Arguments} + + @end group ++@end format + + The use of the situation names @b{compile}, @b{load}, and @b{eval} + in @b{eval-when} is deprecated. +@@ -2171,6 +2179,7 @@ + of the 978 @i{external} @i{symbols} in the @t{COMMON-LISP} @i{package}. + @IPindex{common-lisp} + ++@format + @group + @noindent + @w{ &allow-other-keys *print-miser-width* } +@@ -2216,9 +2225,11 @@ + @w{ Figure 1--4: Symbols in the COMMON-LISP package (part one of twelve).} + + @end group ++@end format + + @page + ++@format + @group + @noindent + @w{ adjoin atom boundp } +@@ -2264,9 +2275,11 @@ + @w{ Figure 1--5: Symbols in the COMMON-LISP package (part two of twelve).} + + @end group ++@end format + + @page + ++@format + @group + @noindent + @w{ cddadr clear-input copy-tree } +@@ -2312,9 +2325,11 @@ + @w{ Figure 1--6: Symbols in the COMMON-LISP package (part three of twelve). } + + @end group ++@end format + + @page + ++@format + @group + @noindent + @w{ denominator eq } +@@ -2360,9 +2375,11 @@ + @w{ Figure 1--7: Symbols in the COMMON-LISP package (part four of twelve).} + + @end group ++@end format + + @page + ++@format + @group + @noindent + @w{ find-symbol get-internal-run-time } +@@ -2408,9 +2425,11 @@ + @w{ Figure 1--8: Symbols in the COMMON-LISP package (part five of twelve).} + + @end group ++@end format + + @page + ++@format + @group + @noindent + @w{ intern lisp-implementation-type } +@@ -2456,9 +2475,11 @@ + @w{ Figure 1--9: Symbols in the COMMON-LISP package (part six of twelve). } + + @end group ++@end format + + @page + ++@format + @group + @noindent + @w{ machine-version mask-field } +@@ -2504,9 +2525,11 @@ + @w{ Figure 1--10: Symbols in the COMMON-LISP package (part seven of twelve).} + + @end group ++@end format + + @page + ++@format + @group + @noindent + @w{ nintersection package-error } +@@ -2552,9 +2575,11 @@ + @w{ Figure 1--11: Symbols in the COMMON-LISP package (part eight of twelve).} + + @end group ++@end format + + @page + ++@format + @group + @noindent + @w{ pprint-tab read-char } +@@ -2600,9 +2625,11 @@ + @w{ Figure 1--12: Symbols in the COMMON-LISP package (part nine of twelve).} + + @end group ++@end format + + @page + ++@format + @group + @noindent + @w{ room simple-bit-vector } +@@ -2648,9 +2675,11 @@ + @w{ Figure 1--13: Symbols in the COMMON-LISP package (part ten of twelve).} + + @end group ++@end format + + @page + ++@format + @group + @noindent + @w{ standard-class sublis } +@@ -2696,9 +2725,11 @@ + @w{ Figure 1--14: Symbols in the COMMON-LISP package (part eleven of twelve).} + + @end group ++@end format + + @page + ++@format + @group + @noindent + @w{ truncate values-list } +@@ -2739,6 +2770,7 @@ + @w{ Figure 1--15: Symbols in the COMMON-LISP package (part twelve of twelve).} + + @end group ++@end format + + @c end of including concept-cl-symbols + +diff -uNr gcl-texi-orig/chap-20.texi gcl-texi/chap-20.texi +--- gcl-texi-orig/chap-20.texi 1994-07-16 18:03:06 +0400 ++++ gcl-texi/chap-20.texi 2002-10-17 20:53:05 +0400 +@@ -32,6 +32,7 @@ + Figure 20--1 lists some @i{operators} + that are applicable to @i{files} and directories. + ++@format + @group + @noindent + @w{ compile-file file-length open } +@@ -43,6 +44,7 @@ + @w{ Figure 20--1: File and Directory Operations } + + @end group ++@end format + + @menu + * Coercion of Streams to Pathnames:: +@@ -82,6 +84,7 @@ + Of these, the @i{functions} in Figure 20--2 treat @i{open} and + @i{closed} @i{streams} differently. + ++@format + @group + @noindent + @w{ delete-file file-author probe-file } +@@ -91,6 +94,7 @@ + @w{ Figure 20--2: File Functions that Treat Open and Closed Streams Differently} + + @end group ++@end format + + Since treatment of @i{open} @i{streams} by the @i{file system} + may vary considerably between @i{implementations}, however, +@@ -103,6 +107,7 @@ + In general, any code that is intended to be portable should + use such @i{functions} carefully. + ++@format + @group + @noindent + @w{ directory probe-file truename } +@@ -111,6 +116,7 @@ + @w{ Figure 20--3: File Functions where Closed Streams Might Work Best} + + @end group ++@end format + + @node Truenames, , File Operations on Open and Closed Streams, File System Concepts + @subsection Truenames +@@ -194,7 +200,7 @@ + @node directory, probe-file, Files Dictionary, Files Dictionary + @subsection directory [Function] + +-@code{directory} @i{pathspec {&key}} @result{} @i{pathnames} ++@code{directory} @i{pathspec @r{&key}} @result{} @i{pathnames} + + @subsubheading Arguments and Values:: + +@@ -246,7 +252,7 @@ + If the @i{pathspec} is not @i{wild}, + the resulting list will contain either zero or one elements. + +-@r{Common Lisp} specifies ``{&key}'' in the argument list to @b{directory} ++@r{Common Lisp} specifies ``@r{&key}'' in the argument list to @b{directory} + even though no @i{standardized} keyword arguments to @b{directory} are defined. + ``@t{:allow-other-keys t}'' + may be used in @i{conforming programs} in order to quietly ignore any +@@ -308,7 +314,7 @@ + @node ensure-directories-exist, truename, probe-file, Files Dictionary + @subsection ensure-directories-exist [Function] + +-@code{ensure-directories-exist} @i{pathspec {&key} verbose} @result{} @i{pathspec, created} ++@code{ensure-directories-exist} @i{pathspec @r{&key} verbose} @result{} @i{pathspec, created} + + @subsubheading Arguments and Values:: + +@@ -687,7 +693,7 @@ + + @subsubheading See Also:: + +-{file-error-pathname}, ++@r{file-error-pathname}, + @ref{open} + , + @ref{probe-file} +diff -uNr gcl-texi-orig/chap-21.texi gcl-texi/chap-21.texi +--- gcl-texi-orig/chap-21.texi 1994-07-16 18:03:06 +0400 ++++ gcl-texi/chap-21.texi 2002-10-17 20:53:05 +0400 +@@ -43,6 +43,7 @@ + Figure 21--1 provides a list of @i{standardized} operations + that are potentially useful with any kind of @i{stream}. + ++@format + @group + @noindent + @w{ close stream-element-type } +@@ -54,6 +55,7 @@ + @w{ Figure 21--1: Some General-Purpose Stream Operations} + + @end group ++@end format + + Other operations are only meaningful on certain @i{stream} @i{types}. + For example, @b{read-char} is only defined for @i{character} @i{streams} +@@ -92,6 +94,7 @@ + Figure 21--2 shows @i{operators} relating to + @i{input} @i{streams}. + ++@format + @group + @noindent + @w{ clear-input read-byte read-from-string } +@@ -103,10 +106,12 @@ + @w{ Figure 21--2: Operators relating to Input Streams. } + + @end group ++@end format + + Figure 21--3 shows @i{operators} relating to + @i{output} @i{streams}. + ++@format + @group + @noindent + @w{ clear-output prin1 write } +@@ -120,6 +125,7 @@ + @w{ Figure 21--3: Operators relating to Output Streams.} + + @end group ++@end format + + A @i{stream} that is both an @i{input} @i{stream} and an @i{output} @i{stream} + is called a @i{bidirectional} +@@ -134,6 +140,7 @@ + shows a list of @i{operators} that relate specificaly to + @i{bidirectional} @i{streams}. + ++@format + @group + @noindent + @w{ y-or-n-p yes-or-no-p } +@@ -142,6 +149,7 @@ + @w{ Figure 21--4: Operators relating to Bidirectional Streams.} + + @end group ++@end format + + @node Open and Closed Streams, Interactive Streams, Input, Introduction to Streams + @subsubsection Open and Closed Streams +@@ -235,6 +243,7 @@ + by this specification. Figure 21--5 shows some information + about these subclasses. + ++@format + @group + @noindent + @w{ Class Related Operators } +@@ -260,6 +269,7 @@ + @w{ Figure 21--5: Defined Names related to Specialized Streams} + + @end group ++@end format + + @node Stream Variables, Stream Arguments to Standardized Functions, Introduction to Streams, Stream Concepts + @subsection Stream Variables +@@ -277,6 +287,7 @@ + The consequences are undefined if at any time + the @i{value} of any of these @i{variables} is not an @i{open} @i{stream}. + ++@format + @group + @noindent + @w{ Glossary Term Variable Name } +@@ -292,6 +303,7 @@ + @w{ Figure 21--6: Standardized Stream Variables} + + @end group ++@end format + + Note that, by convention, @i{standardized} @i{stream variables} have names + ending in ``@t{-input*}'' if they must be @i{input} @i{streams}, +@@ -307,6 +319,7 @@ + The @i{operators} in Figure 21--7 accept @i{stream} @i{arguments} that + might be either @i{open} or @i{closed} @i{streams}. + ++@format + @group + @noindent + @w{ broadcast-stream-streams file-author pathnamep } +@@ -327,10 +340,12 @@ + @w{ Figure 21--7: Operators that accept either Open or Closed Streams } + + @end group ++@end format + + The @i{operators} in Figure 21--8 accept @i{stream} @i{arguments} that + must be @i{open} @i{streams}. + ++@format + @group + @noindent + @w{ clear-input output-stream-p read-char-no-hang } +@@ -356,6 +371,7 @@ + @w{ Figure 21--8: Operators that accept Open Streams only } + + @end group ++@end format + + @node Restrictions on Composite Streams, , Stream Arguments to Standardized Functions, Stream Concepts + @subsection Restrictions on Composite Streams +@@ -453,8 +469,8 @@ + + @ref{Stream Concepts}, + @ref{Printing Other Objects}, +-{@ref{Printer}}, +-{@ref{Reader}} ++@ref{Printer}, ++@ref{Reader} + + @node broadcast-stream, concatenated-stream, stream, Streams Dictionary + @subsection broadcast-stream [System Class] +@@ -607,7 +623,7 @@ + + @subsubheading See Also:: + +-@ref{echo-stream-input-stream; echo-stream-output-stream} ++@ref{echo-stream-input-stream} + , + @b{echo-stream-output-stream}, + @ref{make-echo-stream} +@@ -710,7 +726,7 @@ + + @ref{make-two-way-stream} + , +-@ref{two-way-stream-input-stream; two-way-stream-output-stream} ++@ref{two-way-stream-input-stream} + , + @b{two-way-stream-output-stream} + +@@ -908,7 +924,7 @@ + @node read-byte, write-byte, streamp, Streams Dictionary + @subsection read-byte [Function] + +-@code{read-byte} @i{stream {&optional} eof-error-p eof-value} @result{} @i{byte} ++@code{read-byte} @i{stream @r{&optional} eof-error-p eof-value} @result{} @i{byte} + + @subsubheading Arguments and Values:: + +@@ -1022,7 +1038,7 @@ + @node peek-char, read-char, write-byte, Streams Dictionary + @subsection peek-char [Function] + +-@code{peek-char} @i{{&optional} peek-type input-stream eof-error-p ++@code{peek-char} @i{@r{&optional} peek-type input-stream eof-error-p + eof-value recursive-p} @result{} @i{char} + + @subsubheading Arguments and Values:: +@@ -1074,9 +1090,9 @@ + If an @i{end of file}_2 occurs and @i{eof-error-p} is @i{false}, + @i{eof-value} is returned. + +-{ }{If @i{recursive-p} is @i{true}, ++If @i{recursive-p} is @i{true}, + this call is expected to be embedded in a higher-level call to @b{read} +-or a similar @i{function} used by the @i{Lisp reader}.} ++or a similar @i{function} used by the @i{Lisp reader}. + + When @i{input-stream} is an @i{echo stream}, + characters that are only peeked at are not echoed. In the +@@ -1119,7 +1135,7 @@ + @node read-char, read-char-no-hang, peek-char, Streams Dictionary + @subsection read-char [Function] + +-@code{read-char} @i{{&optional} input-stream eof-error-p eof-value recursive-p} @result{} @i{char} ++@code{read-char} @i{@r{&optional} input-stream eof-error-p eof-value recursive-p} @result{} @i{char} + + @subsubheading Arguments and Values:: + +@@ -1150,9 +1166,9 @@ + and hence are assumed to have been echoed + already by a previous call to @b{read-char}. + +-{ }{If @i{recursive-p} is @i{true}, ++If @i{recursive-p} is @i{true}, + this call is expected to be embedded in a higher-level call to @b{read} +-or a similar @i{function} used by the @i{Lisp reader}.} ++or a similar @i{function} used by the @i{Lisp reader}. + + If an @i{end of file}_2 occurs and @i{eof-error-p} is @i{false}, + @i{eof-value} is returned. +@@ -1188,7 +1204,7 @@ + + @ref{write-char} + , +-@ref{read; read-preserving-whitespace} ++@ref{read} + + @subsubheading Notes:: + The corresponding output function is @b{write-char}. +@@ -1196,7 +1212,7 @@ + @node read-char-no-hang, terpri, read-char, Streams Dictionary + @subsection read-char-no-hang [Function] + +-@code{read-char-no-hang} @i{{&optional} input-stream eof-error-p ++@code{read-char-no-hang} @i{@r{&optional} input-stream eof-error-p + eof-value recursive-p} @result{} @i{char} + + @subsubheading Arguments and Values:: +@@ -1221,9 +1237,9 @@ + from @i{input-stream} if such a character is available. If no character + is available, @b{read-char-no-hang} returns @b{nil}. + +-{ }{If @i{recursive-p} is @i{true}, ++If @i{recursive-p} is @i{true}, + this call is expected to be embedded in a higher-level call to @b{read} +-or a similar @i{function} used by the @i{Lisp reader}.} ++or a similar @i{function} used by the @i{Lisp reader}. + + If an @i{end of file}_2 occurs and @i{eof-error-p} is @i{false}, + @i{eof-value} is returned. +@@ -1248,7 +1264,7 @@ + ;; interactive input on the console, and where that Newline remains + ;; on the input stream. + (test-it) +-@t{ |> } @b{|>>}@t{a{@i{[<--}~]}}@b{<<|} ++@t{ |> } @b{|>>}@t{a@r{@i{[<--}~]}}@b{<<|} + @result{} (#\a #\Newline NIL) + @end example + +@@ -1276,9 +1292,9 @@ + @node terpri, unread-char, read-char-no-hang, Streams Dictionary + @subsection terpri, fresh-line [Function] + +-@code{terpri} @i{{&optional} output-stream} @result{} @i{@b{nil}} ++@code{terpri} @i{@r{&optional} output-stream} @result{} @i{@b{nil}} + +-@code{fresh-line} @i{{&optional} output-stream} @result{} @i{generalized-boolean} ++@code{fresh-line} @i{@r{&optional} output-stream} @result{} @i{generalized-boolean} + + @subsubheading Arguments and Values:: + +@@ -1343,7 +1359,7 @@ + @node unread-char, write-char, terpri, Streams Dictionary + @subsection unread-char [Function] + +-@code{unread-char} @i{character {&optional} input-stream} @result{} @i{@b{nil}} ++@code{unread-char} @i{character @r{&optional} input-stream} @result{} @i{@b{nil}} + + @subsubheading Arguments and Values:: + +@@ -1416,7 +1432,7 @@ + @node write-char, read-line, unread-char, Streams Dictionary + @subsection write-char [Function] + +-@code{write-char} @i{character {&optional} output-stream} @result{} @i{character} ++@code{write-char} @i{character @r{&optional} output-stream} @result{} @i{character} + + @subsubheading Arguments and Values:: + +@@ -1462,7 +1478,7 @@ + @node read-line, write-string, write-char, Streams Dictionary + @subsection read-line [Function] + +-@code{read-line} @i{{&optional} input-stream eof-error-p eof-value recursive-p}@* ++@code{read-line} @i{@r{&optional} input-stream eof-error-p eof-value recursive-p}@* + @result{} @i{line, missing-newline-p} + + @subsubheading Arguments and Values:: +@@ -1488,9 +1504,9 @@ + Reads from @i{input-stream} a line of text + that is terminated by a @i{newline} or @i{end of file}. + +-{ }{If @i{recursive-p} is @i{true}, ++If @i{recursive-p} is @i{true}, + this call is expected to be embedded in a higher-level call to @b{read} +-or a similar @i{function} used by the @i{Lisp reader}.} ++or a similar @i{function} used by the @i{Lisp reader}. + + The @i{primary value}, @i{line}, is the line that is read, + represented as a @i{string} (without the trailing @i{newline}, if any). +@@ -1533,7 +1549,7 @@ + + @subsubheading See Also:: + +-@ref{read; read-preserving-whitespace} ++@ref{read} + + @subsubheading Notes:: + +@@ -1542,9 +1558,9 @@ + @node write-string, read-sequence, read-line, Streams Dictionary + @subsection write-string, write-line [Function] + +-@code{write-string} @i{string {&optional} output-stream {&key} start end} @result{} @i{string} ++@code{write-string} @i{string @r{&optional} output-stream @r{&key} start end} @result{} @i{string} + +-@code{write-line} @i{string {&optional} output-stream {&key} start end} @result{} @i{string} ++@code{write-line} @i{string @r{&optional} output-stream @r{&key} start end} @result{} @i{string} + + @subsubheading Arguments and Values:: + +@@ -1609,7 +1625,7 @@ + @node read-sequence, write-sequence, write-string, Streams Dictionary + @subsection read-sequence [Function] + +-@code{read-sequence} @i{sequence stream {&key} start end} @result{} @i{position} ++@code{read-sequence} @i{sequence stream @r{&key} start end} @result{} @i{position} + + @i{sequence}---a @i{sequence}. + +@@ -1681,7 +1697,7 @@ + @node write-sequence, file-length, read-sequence, Streams Dictionary + @subsection write-sequence [Function] + +-@code{write-sequence} @i{sequence stream {&key} start end} @result{} @i{sequence} ++@code{write-sequence} @i{sequence stream @r{&key} start end} @result{} @i{sequence} + + @i{sequence}---a @i{sequence}. + +@@ -1726,7 +1742,7 @@ + @ref{Compiler Terminology}, + @ref{read-sequence} + , +-@ref{write-string; write-line} ++@ref{write-string} + , + @b{write-line} + +@@ -1922,7 +1938,7 @@ + @node open, stream-external-format, file-string-length, Streams Dictionary + @subsection open [Function] + +-@code{open} @i{filespec {&key} direction element-type ++@code{open} @i{filespec @r{&key} direction element-type + if-exists if-does-not-exist + external-format}@* + @result{} @i{stream} +@@ -2252,9 +2268,9 @@ + + @subsubheading Syntax:: + +-@code{with-open-file} @i{@r{(}stream filespec @{@i{options}@}{*}@r{)} +- @{@i{declaration}@}{*} +- @{@i{form}@}{*}}@* ++@code{with-open-file} @i{@r{(}stream filespec @{@i{options}@}*@r{)} ++ @{@i{declaration}@}* ++ @{@i{form}@}*}@* + @result{} @i{results} + + @subsubheading Arguments and Values:: +@@ -2367,7 +2383,7 @@ + @node close, with-open-stream, with-open-file, Streams Dictionary + @subsection close [Function] + +-@code{close} @i{stream {&key} abort} @result{} @i{result} ++@code{close} @i{stream @r{&key} abort} @result{} @i{result} + + @subsubheading Arguments and Values:: + +@@ -2440,9 +2456,9 @@ + @subsection with-open-stream [Macro] + + @code{with-open-stream} @i{@r{(}var stream@r{)} +- @{@i{declaration}@}{*} +- @{@i{form}@}{*}}@* +- @result{} @i{@{@i{result}@}{*}} ++ @{@i{declaration}@}* ++ @{@i{form}@}*}@* ++ @result{} @i{@{@i{result}@}*} + + @subsubheading Arguments and Values:: + +@@ -2492,7 +2508,7 @@ + @node listen, clear-input, with-open-stream, Streams Dictionary + @subsection listen [Function] + +-@code{listen} @i{{&optional} input-stream} @result{} @i{generalized-boolean} ++@code{listen} @i{@r{&optional} input-stream} @result{} @i{generalized-boolean} + + @subsubheading Arguments and Values:: + +@@ -2536,7 +2552,7 @@ + @node clear-input, finish-output, listen, Streams Dictionary + @subsection clear-input [Function] + +-@code{clear-input} @i{{&optional} input-stream} @result{} @i{@b{nil}} ++@code{clear-input} @i{@r{&optional} input-stream} @result{} @i{@b{nil}} + + @subsubheading Arguments and Values:: + +@@ -2606,11 +2622,11 @@ + @node finish-output, y-or-n-p, clear-input, Streams Dictionary + @subsection finish-output, force-output, clear-output [Function] + +-@code{finish-output} @i{{&optional} output-stream} @result{} @i{@b{nil}} ++@code{finish-output} @i{@r{&optional} output-stream} @result{} @i{@b{nil}} + +-@code{force-output} @i{{&optional} output-stream} @result{} @i{@b{nil}} ++@code{force-output} @i{@r{&optional} output-stream} @result{} @i{@b{nil}} + +-@code{clear-output} @i{{&optional} output-stream} @result{} @i{@b{nil}} ++@code{clear-output} @i{@r{&optional} output-stream} @result{} @i{@b{nil}} + + @subsubheading Arguments and Values:: + +@@ -2666,9 +2682,9 @@ + @node y-or-n-p, make-synonym-stream, finish-output, Streams Dictionary + @subsection y-or-n-p, yes-or-no-p [Function] + +-@code{y-or-n-p} @i{{&optional} control {&rest} arguments} @result{} @i{generalized-boolean} ++@code{y-or-n-p} @i{@r{&optional} control @r{&rest} arguments} @result{} @i{generalized-boolean} + +-@code{yes-or-no-p} @i{{&optional} control {&rest} arguments} @result{} @i{generalized-boolean} ++@code{yes-or-no-p} @i{@r{&optional} control @r{&rest} arguments} @result{} @i{generalized-boolean} + + @subsubheading Arguments and Values:: + +@@ -2823,7 +2839,7 @@ + @node make-broadcast-stream, make-two-way-stream, broadcast-stream-streams, Streams Dictionary + @subsection make-broadcast-stream [Function] + +-@code{make-broadcast-stream} @i{{&rest} streams} @result{} @i{broadcast-stream} ++@code{make-broadcast-stream} @i{@r{&rest} streams} @result{} @i{broadcast-stream} + + @subsubheading Arguments and Values:: + +@@ -2975,7 +2991,7 @@ + + @subsubheading See Also:: + +-@ref{echo-stream-input-stream; echo-stream-output-stream} ++@ref{echo-stream-input-stream} + , + @b{echo-stream-output-stream}, + @ref{make-two-way-stream} +@@ -3004,7 +3020,7 @@ + @node make-concatenated-stream, get-output-stream-string, concatenated-stream-streams, Streams Dictionary + @subsection make-concatenated-stream [Function] + +-@code{make-concatenated-stream} @i{{&rest} input-streams} @result{} @i{concatenated-stream} ++@code{make-concatenated-stream} @i{@r{&rest} input-streams} @result{} @i{concatenated-stream} + + @subsubheading Arguments and Values:: + +@@ -3083,7 +3099,7 @@ + @node make-string-input-stream, make-string-output-stream, get-output-stream-string, Streams Dictionary + @subsection make-string-input-stream [Function] + +-@code{make-string-input-stream} @i{string {&optional} start end} @result{} @i{string-stream} ++@code{make-string-input-stream} @i{string @r{&optional} start end} @result{} @i{string-stream} + + @subsubheading Arguments and Values:: + +@@ -3121,7 +3137,7 @@ + @node make-string-output-stream, with-input-from-string, make-string-input-stream, Streams Dictionary + @subsection make-string-output-stream [Function] + +-@code{make-string-output-stream} @i{{&key} element-type} @result{} @i{string-stream} ++@code{make-string-output-stream} @i{@r{&key} element-type} @result{} @i{string-stream} + + @subsubheading Arguments and Values:: + +@@ -3163,10 +3179,10 @@ + @node with-input-from-string, with-output-to-string, make-string-output-stream, Streams Dictionary + @subsection with-input-from-string [Macro] + +-@code{with-input-from-string} @i{@r{(}var string {&key} index start end@r{)} +- @{@i{declaration}@}{*} +- @{@i{form}@}{*}}@* +- @result{} @i{@{@i{result}@}{*}} ++@code{with-input-from-string} @i{@r{(}var string @r{&key} index start end@r{)} ++ @{@i{declaration}@}* ++ @{@i{form}@}*}@* ++ @result{} @i{@{@i{result}@}*} + + @subsubheading Arguments and Values:: + +@@ -3252,10 +3268,10 @@ + @node with-output-to-string, *debug-io*, with-input-from-string, Streams Dictionary + @subsection with-output-to-string [Macro] + +-@code{with-output-to-string} @i{@r{(}var {&optional} string-form {&key} element-type@r{)} +- @{@i{declaration}@}{*} +- @{@i{form}@}{*}}@* +- @result{} @i{@{@i{result}@}{*}} ++@code{with-output-to-string} @i{@r{(}var @r{&optional} string-form @r{&key} element-type@r{)} ++ @{@i{declaration}@}* ++ @{@i{form}@}*}@* ++ @result{} @i{@{@i{result}@}*} + + @subsubheading Arguments and Values:: + +@@ -3449,11 +3465,11 @@ + @b{synonym-stream}, + @ref{Time} + , +-@ref{trace; untrace} ++@ref{trace} + , +-{@ref{Conditions}}, +-{@ref{Reader}}, +-{@ref{Printer}} ++@ref{Conditions}, ++@ref{Reader}, ++@ref{Printer} + + @subsubheading Notes:: + +diff -uNr gcl-texi-orig/chap-22.texi gcl-texi/chap-22.texi +--- gcl-texi-orig/chap-22.texi 1994-07-16 18:03:05 +0400 ++++ gcl-texi/chap-22.texi 2002-10-17 22:10:07 +0400 +@@ -86,6 +86,7 @@ + Figure 22--1 shows the @i{standardized} @i{printer control variables}; + there might also be @i{implementation-defined} @i{printer control variables}. + ++@format + @group + @noindent + @w{ *print-array* *print-gensym* *print-pprint-dispatch* } +@@ -98,11 +99,13 @@ + @w{ Figure 22--1: Standardized Printer Control Variables } + + @end group ++@end format + + In addition to the @i{printer control variables}, + the following additional @i{defined names} + relate to or affect the behavior of the @i{Lisp printer}: + ++@format + @group + @noindent + @w{ *package* *read-eval* readtable-case } +@@ -112,6 +115,7 @@ + @w{ Figure 22--2: Additional Influences on the Lisp printer. } + + @end group ++@end format + + @node Printer Escaping, , Multiple Possible Textual Representations, Overview of The Lisp Printer + @subsubsection Printer Escaping +@@ -222,7 +226,7 @@ + + @IRindex{float} + +-If the magnitude of the @i{float} is either zero or between 10^{-3} (inclusive) ++If the magnitude of the @i{float} is either zero or between 10^@r{-3} (inclusive) + and 10^7 (exclusive), it is printed as the integer part of the number, + then a decimal point, + followed by the fractional part of the number; +@@ -238,7 +242,7 @@ + For example, the base of the natural logarithms as a @i{short float} + might be printed as @t{2.71828S0}. + +-For non-zero magnitudes outside of the range 10^{-3} to 10^7, ++For non-zero magnitudes outside of the range 10^@r{-3} to 10^7, + a @i{float} is printed in computerized scientific notation. + The representation of the number is scaled to be between + 1 (inclusive) and 10 (exclusive) and then printed, with one digit +@@ -815,7 +819,7 @@ + the default notation for structures is: + + @example +- #S(@i{structure-name} @{@i{slot-key} @i{slot-value}@}{*}) ++ #S(@i{structure-name} @{@i{slot-key} @i{slot-value}@}*) + @end example + + where @t{#S} indicates structure syntax, +@@ -918,7 +922,7 @@ + @menu + * Pretty Printer Concepts:: + * Examples of using the Pretty Printer:: +-* Notes about the Pretty Printer's Background:: ++* Notes about the Pretty Printer`s Background:: + @end menu + + @node Pretty Printer Concepts, Examples of using the Pretty Printer, The Lisp Pretty Printer, The Lisp Pretty Printer +@@ -1034,6 +1038,7 @@ + arrangement of output is provided through the functions and macros of the + pretty printer. Figure 22--3 shows the defined names related to @i{pretty printing}. + ++@format + @group + @noindent + @w{ *print-lines* pprint-dispatch pprint-pop } +@@ -1048,11 +1053,13 @@ + @w{ Figure 22--3: Defined names related to pretty printing. } + + @end group ++@end format + + Figure 22--4 identifies a set of @i{format directives} which serve + as an alternate interface to the same pretty printing operations in a + more textually compact form. + ++@format + @group + @noindent + @w{ @t{~I} @t{~W} @t{~<...~:>} } +@@ -1062,6 +1069,7 @@ + @w{ Figure 22--4: Format directives related to Pretty Printing} + + @end group ++@end format + + @node Compiling Format Strings, Pretty Print Dispatch Tables, Format Directive Interface, Pretty Printer Concepts + @subsubsection Compiling Format Strings +@@ -1127,7 +1135,7 @@ + the left margin is assumed to be zero. + The right margin is controlled by @b{*print-right-margin*}. + +-@node Examples of using the Pretty Printer, Notes about the Pretty Printer's Background, Pretty Printer Concepts, The Lisp Pretty Printer ++@node Examples of using the Pretty Printer, Notes about the Pretty Printer`s Background, Pretty Printer Concepts, The Lisp Pretty Printer + @subsection Examples of using the Pretty Printer + + As an example of the interaction of logical blocks, conditional newlines, +@@ -1347,7 +1355,7 @@ + (format T "~:<~W ~@@_~:I~W ~:_~W~1I ~_~W~:>" list)) + + (defun pprint-let (*standard-output* list) +- (format T "~:<~W~{@t{^}}~:<~@@@{~:<~@@@{~W~{@t{^}}~_~@}~:>~{@t{^}}~:_~@}~:>~1I~@@@{~{@t{^}}~_~W~@}~:>" list)) ++ (format T "~:<~W~@t{^}~:<~@@@{~:<~@@@{~W~@t{^}~_~@}~:>~@t{^}~:_~@}~:>~1I~@@@{~@t{^}~_~W~@}~:>" list)) + @end example + + In the following example, the first @i{form} restores +@@ -1459,8 +1467,8 @@ + its @b{print-object} @i{method} + is used instead. + +-@node Notes about the Pretty Printer's Background, , Examples of using the Pretty Printer, The Lisp Pretty Printer +-@subsection Notes about the Pretty Printer's Background ++@node Notes about the Pretty Printer`s Background, , Examples of using the Pretty Printer, The Lisp Pretty Printer ++@subsection Notes about the Pretty Printer`s Background + + For a background reference to the abstract concepts detailed in this + section, see @i{XP: A Common Lisp Pretty Printing System}. The details of that paper are not binding on +@@ -1535,6 +1543,7 @@ + + Examples of @i{format strings}: + ++@format + @group + @noindent + @w{ @t{"~S"} ;This is an S directive with no parameters or modifiers. } +@@ -1547,6 +1556,7 @@ + @w{ Figure 22--5: Examples of format control strings } + + @end group ++@end format + + @b{format} sends the output to @i{destination}. + If @i{destination} is @b{nil}, +@@ -1647,7 +1657,7 @@ + this fact is mentioned. For example, + + @example +- (format nil "~:@@C" #\Control-Partial) @result{} "Control-{\partial} (Top-F)" ++ (format nil "~:@@C" #\Control-Partial) @result{} "Control-\partial (Top-F)" + @end example + + This is the format used for telling the user about a key he is expected to type, +@@ -1902,7 +1912,7 @@ + If both @i{w} and @i{d} are omitted, then the effect is to print + the value using ordinary free-format output; @b{prin1} uses this format + for any number whose magnitude is either zero or between +-10^{-3} (inclusive) and 10^7 (exclusive). ++10^@r{-3} (inclusive) and 10^7 (exclusive). + + If @i{w} is omitted, then if the magnitude of @i{arg} is so large (or, if + @i{d} is also omitted, so small) that more than 100 digits would have to +@@ -2020,7 +2030,7 @@ + a similar + + format for any non-zero number whose magnitude +-is less than 10^{-3} or greater than or equal to 10^7. ++is less than 10^@r{-3} or greater than or equal to 10^7. + + The only difference is that the @t{~E} + directive always prints a plus or minus sign in front of the +@@ -2057,7 +2067,7 @@ + The full form is @t{~@i{w},@i{d},@i{e},@i{k},@i{overflowchar},@i{padchar},@i{exponentchar}G}. + The format in which to print @i{arg} depends on the magnitude (absolute + value) of the @i{arg}. Let @i{n} be an integer such that +-10^{{n}-1} \le |@i{arg}| < 10^@i{n}. ++10^@r{@r{n}-1} \le |@i{arg}| < 10^@i{n}. + Let @i{ee} equal @i{e}+2, or 4 if @i{e} is omitted. + Let @i{ww} equal @i{w}- @i{ee}, + or @b{nil} if @i{w} is omitted. If @i{d} is omitted, first let @i{q} +@@ -2263,7 +2273,7 @@ + Elements are extracted from this list using @b{pprint-pop}, + thereby providing automatic support for malformed lists, and the detection + of circularity, sharing, and length abbreviation. +-Within the body segment, @t{~{@t{^}}} acts like @b{pprint-exit-if-list-exhausted}. ++Within the body segment, @t{~@t{^}} acts like @b{pprint-exit-if-list-exhausted}. + + @t{~<...~:>} supports a feature not supported by @b{pprint-logical-block}. + If @t{~:@@>} is used to terminate the directive (@i{i.e.}, @t{~<...~:@@>}), +@@ -2599,7 +2609,7 @@ + @node Tilde Left-Brace-> Iteration, Tilde Right-Brace-> End of Iteration, Tilde Right-Bracket-> End of Conditional Expression, FORMAT Control-Flow Operations + @subsubsection Tilde Left-Brace: Iteration + +-@t{~@{{@i{str}}~@}} ++@t{~@{@i{str}~@}} + + This is an iteration construct. The argument should be a @i{list}, + which is used as a set of arguments +@@ -2837,7 +2847,7 @@ + @node Tilde Circumflex-> Escape Upward, Tilde Newline-> Ignored Newline, Tilde Semicolon-> Clause Separator, FORMAT Miscellaneous Pseudo-Operations + @subsubsection Tilde Circumflex: Escape Upward + +-{@t{~@t{^} }} ++@t{~@t{^} } + + This is an escape construct. If there are no more arguments remaining to + be processed, then the immediately +@@ -2851,16 +2861,16 @@ + construct. + + @example +- (setq donestr "Done.~{@t{^}} ~D warning~:P.~{@t{^}} ~D error~:P.") +-@result{} "Done.~{@t{^}} ~D warning~:P.~{@t{^}} ~D error~:P." ++ (setq donestr "Done.~@t{^} ~D warning~:P.~@t{^} ~D error~:P.") ++@result{} "Done.~@t{^} ~D warning~:P.~@t{^} ~D error~:P." + (format nil donestr) @result{} "Done." + (format nil donestr 3) @result{} "Done. 3 warnings." + (format nil donestr 1 5) @result{} "Done. 1 warning. 5 errors." + @end example + + If a prefix parameter is given, then termination occurs if the parameter +-is zero. (Hence @t{~{@t{^}}} is equivalent to +-@t{~#{@t{^}}}.) If two ++is zero. (Hence @t{~@t{^}} is equivalent to ++@t{~#@t{^}}.) If two + parameters are given, termination occurs if they are equal. + + [Reviewer Note by Barmar: Which equality predicate?] If three +@@ -2869,14 +2879,14 @@ + Of course, this is useless if all the prefix parameters are constants; at + least one of them should be a @t{#} or a @t{V} parameter. + +-If @t{~{@t{^}}} is used within a @t{~:@{ } ++If @t{~@t{^}} is used within a @t{~:@{ } + construct, then it terminates + the current iteration step because in the standard case it tests for + remaining arguments of the current step only; the next iteration step +-commences immediately. @t{~:{@t{^}}} is used to terminate ++commences immediately. @t{~:@t{^}} is used to terminate + the iteration process. + +-@t{~:{@t{^}}} ++@t{~:@t{^}} + may be used only if the command it would terminate is + @t{~:@{ } or @t{~:@@@{ }. + The entire iteration process is terminated if and only if the sublist that is +@@ -2884,8 +2894,8 @@ + the case of @t{~:@{ }, + or the last @b{format} + argument in the case of @t{~:@@@{ }. +-@t{~:{@t{^}}} is not +-equivalent to @t{~#:{@t{^}}}; ++@t{~:@t{^}} is not ++equivalent to @t{~#:@t{^}}; + the latter terminates the entire iteration if and only if no + arguments remain for the current iteration step. + For example: +@@ -2894,7 +2904,7 @@ + (format nil "~:@{ ~@@?~:@t{^} ...~@} " '(("a") ("b"))) @result{} "a...b" + @end example + +-If @t{~{@t{^}}} appears within a control string being processed ++If @t{~@t{^}} appears within a control string being processed + under the control of a @t{~?} directive, but not within + any @t{~@{ } or @t{~<} construct within that string, + then the string being +@@ -2903,9 +2913,9 @@ + continues within the string + containing the @t{~?} directive at the point following that directive. + +-If @t{~{@t{^}}} ++If @t{~@t{^}} + appears within a @t{~[} or @t{~(} construct, +-then all the commands up to the @t{~{@t{^}}} are properly selected ++then all the commands up to the @t{~@t{^}} are properly selected + or case-converted, + the @t{~[} or @t{~(} processing is terminated, + and the outward search continues +@@ -2913,22 +2923,22 @@ + to be terminated. For example: + + @example +- (setq tellstr "~@@(~@@[~R~]~{@t{^}} ~A!~)") +-@result{} "~@@(~@@[~R~]~{@t{^}} ~A!~)" ++ (setq tellstr "~@@(~@@[~R~]~@t{^} ~A!~)") ++@result{} "~@@(~@@[~R~]~@t{^} ~A!~)" + (format nil tellstr 23) @result{} "Twenty-three!" + (format nil tellstr nil "losers") @result{} " Losers!" + (format nil tellstr 23 "losers") @result{} "Twenty-three losers!" + @end example + +-Following are examples of the use of @t{~{@t{^}}} ++Following are examples of the use of @t{~@t{^}} + within a @t{~<} construct. + + @example +- (format nil "~15<~S~;~{@t{^}}~S~;~{@t{^}}~S~>" 'foo) ++ (format nil "~15<~S~;~@t{^}~S~;~@t{^}~S~>" 'foo) + @result{} " FOO" +- (format nil "~15<~S~;~{@t{^}}~S~;~{@t{^}}~S~>" 'foo 'bar) ++ (format nil "~15<~S~;~@t{^}~S~;~@t{^}~S~>" 'foo 'bar) + @result{} "FOO BAR" +- (format nil "~15<~S~;~{@t{^}}~S~;~{@t{^}}~S~>" 'foo 'bar 'baz) ++ (format nil "~15<~S~;~@t{^}~S~;~@t{^}~S~>" 'foo 'bar 'baz) + @result{} "FOO BAR BAZ" + @end example + +@@ -3149,7 +3159,7 @@ + Note that the meaning of @b{nil} and @b{t} as destinations to @b{format} + are different than those of @b{nil} and @b{t} as @i{stream designators}. + +-The @t{~{@t{^}}} should appear only at the beginning of a @t{~<} clause, ++The @t{~@t{^}} should appear only at the beginning of a @t{~<} clause, + because it aborts the entire clause in which it appears (as well as + all following clauses). + +@@ -3197,7 +3207,7 @@ + @node copy-pprint-dispatch, formatter, Printer Dictionary, Printer Dictionary + @subsection copy-pprint-dispatch [Function] + +-@code{copy-pprint-dispatch} @i{{&optional} table} @result{} @i{new-table} ++@code{copy-pprint-dispatch} @i{@r{&optional} table} @result{} @i{new-table} + + @subsubheading Arguments and Values:: + +@@ -3267,7 +3277,7 @@ + @node pprint-dispatch, pprint-exit-if-list-exhausted, formatter, Printer Dictionary + @subsection pprint-dispatch [Function] + +-@code{pprint-dispatch} @i{object {&optional} table} @result{} @i{function, found-p} ++@code{pprint-dispatch} @i{object @r{&optional} table} @result{} @i{function, found-p} + + @subsubheading Arguments and Values:: + +@@ -3361,11 +3371,11 @@ + @node pprint-fill, pprint-indent, pprint-exit-if-list-exhausted, Printer Dictionary + @subsection pprint-fill, pprint-linear, pprint-tabular [Function] + +-@code{pprint-fill} @i{stream object {&optional} colon-p at-sign-p} @result{} @i{@b{nil}} ++@code{pprint-fill} @i{stream object @r{&optional} colon-p at-sign-p} @result{} @i{@b{nil}} + +-@code{pprint-linear} @i{stream object {&optional} colon-p at-sign-p} @result{} @i{@b{nil}} ++@code{pprint-linear} @i{stream object @r{&optional} colon-p at-sign-p} @result{} @i{@b{nil}} + +-@code{pprint-tabular} @i{stream object {&optional} colon-p at-sign-p tabsize} @result{} @i{@b{nil}} ++@code{pprint-tabular} @i{stream object @r{&optional} colon-p at-sign-p tabsize} @result{} @i{@b{nil}} + + @subsubheading Arguments and Values:: + +@@ -3467,7 +3477,7 @@ + @node pprint-indent, pprint-logical-block, pprint-fill, Printer Dictionary + @subsection pprint-indent [Function] + +-@code{pprint-indent} @i{relative-to n {&optional} stream} @result{} @i{@b{nil}} ++@code{pprint-indent} @i{relative-to n @r{&optional} stream} @result{} @i{@b{nil}} + + @subsubheading Arguments and Values:: + +@@ -3521,8 +3531,8 @@ + @subsection pprint-logical-block [Macro] + + @code{pprint-logical-block} @i{@r{(}stream-symbol object +- {&key} prefix per-line-prefix suffix@r{)} +- @{@i{declaration}@}{*} @{@i{form}@}{*}}@* ++ @r{&key} prefix per-line-prefix suffix@r{)} ++ @{@i{declaration}@}* @{@i{form}@}*}@* + @result{} @i{@b{nil}} + + @subsubheading Arguments and Values:: +@@ -3663,7 +3673,7 @@ + @node pprint-newline, pprint-pop, pprint-logical-block, Printer Dictionary + @subsection pprint-newline [Function] + +-@code{pprint-newline} @i{kind {&optional} stream} @result{} @i{@b{nil}} ++@code{pprint-newline} @i{kind @r{&optional} stream} @result{} @i{@b{nil}} + + @subsubheading Arguments and Values:: + +@@ -3888,7 +3898,7 @@ + @node pprint-tab, print-object, pprint-pop, Printer Dictionary + @subsection pprint-tab [Function] + +-@code{pprint-tab} @i{kind colnum colinc {&optional} stream} @result{} @i{@b{nil}} ++@code{pprint-tab} @i{kind colnum colinc @r{&optional} stream} @result{} @i{@b{nil}} + + @subsubheading Arguments and Values:: + +@@ -4064,13 +4074,13 @@ + + @subsubheading See Also:: + +-@ref{pprint-fill; pprint-linear; pprint-tabular} ++@ref{pprint-fill} + , + @ref{pprint-logical-block} + , + @ref{pprint-pop} + , +-@ref{write; prin1; print; pprint; princ} ++@ref{write} + , + @b{*print-readably*}, + @b{*print-escape*}, +@@ -4086,7 +4096,7 @@ + @node print-unreadable-object, set-pprint-dispatch, print-object, Printer Dictionary + @subsection print-unreadable-object [Macro] + +-@code{print-unreadable-object} @i{@r{(}object stream {&key} type identity@r{)} @{@i{form}@}{*}} @result{} @i{@b{nil}} ++@code{print-unreadable-object} @i{@r{(}object stream @r{&key} type identity@r{)} @{@i{form}@}*} @result{} @i{@b{nil}} + + @subsubheading Arguments and Values:: + +@@ -4144,7 +4154,7 @@ + @node set-pprint-dispatch, write, print-unreadable-object, Printer Dictionary + @subsection set-pprint-dispatch [Function] + +-@code{set-pprint-dispatch} @i{type-specifier function {&optional} priority table} @result{} @i{@b{nil}} ++@code{set-pprint-dispatch} @i{type-specifier function @r{&optional} priority table} @result{} @i{@b{nil}} + + @subsubheading Arguments and Values:: + +@@ -4208,16 +4218,16 @@ + @node write, write-to-string, set-pprint-dispatch, Printer Dictionary + @subsection write, prin1, print, pprint, princ [Function] + +-@code{write} @i{@i{object} {&key} \writekeys{stream}}@* ++@code{write} @i{@i{object} @r{&key} \writekeys@r{stream}}@* + @result{} @i{object} + +-@code{prin} @i{1} @result{} @i{object {&optional} output-stream} +- {object} +-@code{princ} @i{object {&optional} output-stream} @result{} @i{object} ++@code{prin} @i{1} @result{} @i{object @r{&optional} output-stream} ++ @r{object} ++@code{princ} @i{object @r{&optional} output-stream} @result{} @i{object} + +-@code{print} @i{object {&optional} output-stream} @result{} @i{object} ++@code{print} @i{object @r{&optional} output-stream} @result{} @i{object} + +-@code{pprint} @i{object {&optional} output-stream} @result{} @i{<@i{no @i{values}}>} ++@code{pprint} @i{object @r{&optional} output-stream} @result{} @i{<@i{no @i{values}}>} + + @subsubheading Arguments and Values:: + +@@ -4226,7 +4236,7 @@ + @i{output-stream}---an @i{output} @i{stream designator}. + The default is @i{standard output}. + +-\writekeydescriptions{@i{stream}---an @i{output} @i{stream designator}. ++\writekeydescriptions@r{@i{stream}---an @i{output} @i{stream designator}. + The default is @i{standard output}.} + + @subsubheading Description:: +@@ -4244,6 +4254,7 @@ + Once the appropriate @i{bindings} are @i{established}, + the @i{object} is output by the @i{Lisp printer}. + ++@format + @group + @noindent + @w{ Parameter Corresponding Dynamic Variable } +@@ -4267,6 +4278,7 @@ + @w{ Figure 22--6: Argument correspondences for the WRITE function.} + + @end group ++@end format + + @b{prin1}, @b{princ}, @b{print}, and @b{pprint} implicitly + @i{bind} certain print parameters to particular values. The remaining parameter +@@ -4364,11 +4376,11 @@ + @node write-to-string, *print-array*, write, Printer Dictionary + @subsection write-to-string, prin1-to-string, princ-to-string [Function] + +-@code{write-to-string} @i{object {&key} \writekeys{}}@* ++@code{write-to-string} @i{object @r{&key} \writekeys}@* + @result{} @i{string} + + @code{prin} @i{1} @result{} @i{-to-string} +- {object} {string} ++ @r{object} @r{string} + + @code{princ-to-string} @i{object} @result{} @i{string} + +@@ -4376,7 +4388,7 @@ + + @i{object}---an @i{object}. + +-\writekeydescriptions{} ++\writekeydescriptions + + @i{string}---a @i{string}. + +@@ -4433,14 +4445,14 @@ + + @subsubheading See Also:: + +-@ref{write; prin1; print; pprint; princ} ++@ref{write} + + @subsubheading Notes:: + + @example +- (write-to-string @i{object} @{@i{key} @i{argument}@}{*}) ++ (write-to-string @i{object} @{@i{key} @i{argument}@}*) + @equiv{} (with-output-to-string (#1=#:string-stream) +- (write object :stream #1# @{@i{key} @i{argument}@}{*})) ++ (write object :stream #1# @{@i{key} @i{argument}@}*)) + + (princ-to-string @i{object}) + @equiv{} (with-output-to-string (string-stream) +@@ -4554,9 +4566,9 @@ + + @ref{format} + , +-@ref{write; prin1; print; pprint; princ} ++@ref{write} + , +-@ref{write-to-string; prin1-to-string; princ-to-string} ++@ref{write-to-string} + + @node *print-case*, *print-circle*, *print-base*, Printer Dictionary + @subsection *print-case* [Variable] +@@ -4606,7 +4618,7 @@ + + @subsubheading See Also:: + +-@ref{write; prin1; print; pprint; princ} ++@ref{write} + + @subsubheading Notes:: + +@@ -4685,7 +4697,7 @@ + + @subsubheading See Also:: + +-@ref{write; prin1; print; pprint; princ} ++@ref{write} + + @subsubheading Notes:: + +@@ -4733,7 +4745,7 @@ + + @subsubheading See Also:: + +-@ref{write; prin1; print; pprint; princ} ++@ref{write} + , + @ref{readtable-case} + +@@ -4771,7 +4783,7 @@ + + @subsubheading See Also:: + +-@ref{write; prin1; print; pprint; princ} ++@ref{write} + , @b{*print-escape*} + + @node *print-level*, *print-lines*, *print-gensym*, Printer Dictionary +@@ -4862,7 +4874,7 @@ + + @subsubheading See Also:: + +-@ref{write; prin1; print; pprint; princ} ++@ref{write} + + @node *print-lines*, *print-miser-width*, *print-level*, Printer Dictionary + @subsection *print-lines* [Variable] +@@ -5027,7 +5039,7 @@ + + @subsubheading See Also:: + +-@ref{write; prin1; print; pprint; princ} ++@ref{write} + + @node *print-readably*, *print-right-margin*, *print-pretty*, Printer Dictionary + @subsection *print-readably* [Variable] +@@ -5129,7 +5141,7 @@ + + @subsubheading See Also:: + +-@ref{write; prin1; print; pprint; princ} ++@ref{write} + , + @ref{print-unreadable-object} + +@@ -5217,7 +5229,7 @@ + @node format, , print-not-readable-object, Printer Dictionary + @subsection format [Function] + +-@code{format} @i{destination control-string {&rest} args} @result{} @i{result} ++@code{format} @i{destination control-string @r{&rest} args} @result{} @i{result} + + @subsubheading Arguments and Values:: + +@@ -5275,7 +5287,7 @@ + + @subsubheading See Also:: + +-@ref{write; prin1; print; pprint; princ} ++@ref{write} + , + @ref{Documentation of Implementation-Defined Scripts} + +diff -uNr gcl-texi-orig/chap-23.texi gcl-texi/chap-23.texi +--- gcl-texi-orig/chap-23.texi 1994-07-16 18:03:03 +0400 ++++ gcl-texi/chap-23.texi 2002-10-17 20:53:05 +0400 +@@ -263,7 +263,7 @@ + @node copy-readtable, make-dispatch-macro-character, readtable, Reader Dictionary + @subsection copy-readtable [Function] + +-@code{copy-readtable} @i{{&optional} from-readtable to-readtable} @result{} @i{readtable} ++@code{copy-readtable} @i{@r{&optional} from-readtable to-readtable} @result{} @i{readtable} + + @subsubheading Arguments and Values:: + +@@ -332,7 +332,7 @@ + @node make-dispatch-macro-character, read, copy-readtable, Reader Dictionary + @subsection make-dispatch-macro-character [Function] + +-@code{make-dispatch-macro-character} @i{char {&optional} non-terminating-p readtable} @result{} @i{@b{t}} ++@code{make-dispatch-macro-character} @i{char @r{&optional} non-terminating-p readtable} @result{} @i{@b{t}} + + @subsubheading Arguments and Values:: + +@@ -374,14 +374,14 @@ + + @ref{readtable} + , +-@ref{set-dispatch-macro-character; get-dispatch-macro-character} ++@ref{set-dispatch-macro-character} + + @node read, read-delimited-list, make-dispatch-macro-character, Reader Dictionary + @subsection read, read-preserving-whitespace [Function] + +-@code{read} @i{{&optional} input-stream eof-error-p eof-value recursive-p} @result{} @i{object} ++@code{read} @i{@r{&optional} input-stream eof-error-p eof-value recursive-p} @result{} @i{object} + +-@code{read-preserving-whitespace} @i{{&optional} input-stream eof-error-p ++@code{read-preserving-whitespace} @i{@r{&optional} input-stream eof-error-p + eof-value recursive-p}@* + @result{} @i{object} + +@@ -543,13 +543,13 @@ + , + @ref{parse-integer} + , +-{@ref{Syntax}}, +-{@ref{Reader Concepts}} ++@ref{Syntax}, ++@ref{Reader Concepts} + + @node read-delimited-list, read-from-string, read, Reader Dictionary + @subsection read-delimited-list [Function] + +-@code{read-delimited-list} @i{char {&optional} input-stream recursive-p} @result{} @i{list} ++@code{read-delimited-list} @i{char @r{&optional} input-stream recursive-p} @result{} @i{list} + + @subsubheading Arguments and Values:: + +@@ -596,11 +596,11 @@ + + @subsubheading Examples:: + @example +- (read-delimited-list #\{]}) 1 2 3 4 5 6 {]} ++ (read-delimited-list #\@r{]}) 1 2 3 4 5 6 @r{]} + @result{} (1 2 3 4 5 6) + @end example + +-Suppose you wanted @t{#@{{@i{a}} @i{b} @i{c} ... @i{z}@}} ++Suppose you wanted @t{#@{@i{a} @i{b} @i{c} ... @i{z}@}} + to read as a list of all pairs of the elements @i{a}, @i{b}, @i{c}, + ..., @i{z}, for example. + +@@ -659,7 +659,7 @@ + + @subsubheading See Also:: + +-@ref{read; read-preserving-whitespace} ++@ref{read} + , + @ref{peek-char} + , +@@ -680,8 +680,8 @@ + @node read-from-string, readtable-case, read-delimited-list, Reader Dictionary + @subsection read-from-string [Function] + +-@code{read-from-string} @i{string {&optional} eof-error-p eof-value +- {&key} start end preserve-whitespace}@* ++@code{read-from-string} @i{string @r{&optional} eof-error-p eof-value ++ @r{&key} start end preserve-whitespace}@* + @result{} @i{object, position} + + @subsubheading Arguments and Values:: +@@ -748,7 +748,7 @@ + + @subsubheading See Also:: + +-@ref{read; read-preserving-whitespace} ++@ref{read} + , + @b{read-preserving-whitespace} + +@@ -840,9 +840,9 @@ + @i{[Function]} + @end flushright + +-@code{get-dispatch-macro-character} @i{disp-char sub-char {&optional} readtable} @result{} @i{function} ++@code{get-dispatch-macro-character} @i{disp-char sub-char @r{&optional} readtable} @result{} @i{function} + +-@code{set-dispatch-macro-character} @i{disp-char sub-char new-function {&optional} readtable} @result{} @i{@b{t}} ++@code{set-dispatch-macro-character} @i{disp-char sub-char new-function @r{&optional} readtable} @result{} @i{@b{t}} + + @subsubheading Arguments and Values:: + +@@ -940,9 +940,9 @@ + @node set-macro-character, set-syntax-from-char, set-dispatch-macro-character, Reader Dictionary + @subsection set-macro-character, get-macro-character [Function] + +-@code{get-macro-character} @i{char {&optional} readtable} @result{} @i{function, non-terminating-p} ++@code{get-macro-character} @i{char @r{&optional} readtable} @result{} @i{function, non-terminating-p} + +-@code{set-macro-character} @i{char new-function {&optional} non-terminating-p readtable} @result{} @i{@b{t}} ++@code{set-macro-character} @i{char new-function @r{&optional} non-terminating-p readtable} @result{} @i{@b{t}} + + @subsubheading Arguments and Values:: + +@@ -1022,7 +1022,7 @@ + @node set-syntax-from-char, with-standard-io-syntax, set-macro-character, Reader Dictionary + @subsection set-syntax-from-char [Function] + +-@code{set-syntax-from-char} @i{to-char from-char {&optional} to-readtable from-readtable} @result{} @i{@b{t}} ++@code{set-syntax-from-char} @i{to-char from-char @r{&optional} to-readtable from-readtable} @result{} @i{@b{t}} + + @subsubheading Arguments and Values:: + +@@ -1075,7 +1075,7 @@ + + @subsubheading See Also:: + +-@ref{set-macro-character; get-macro-character} ++@ref{set-macro-character} + , + @ref{make-dispatch-macro-character} + , +@@ -1093,7 +1093,7 @@ + @node with-standard-io-syntax, *read-base*, set-syntax-from-char, Reader Dictionary + @subsection with-standard-io-syntax [Macro] + +-@code{with-standard-io-syntax} @i{@{@i{form}@}{*}} @result{} @i{@{@i{result}@}{*}} ++@code{with-standard-io-syntax} @i{@{@i{form}@}*} @result{} @i{@{@i{result}@}*} + + @subsubheading Arguments and Values:: + +@@ -1111,6 +1111,7 @@ + + [Reviewer Note by Barrett: *print-pprint-dispatch* should probably be mentioned here, too.] + ++@format + @group + @noindent + @w{ Variable Value } +@@ -1140,6 +1141,7 @@ + @w{ Figure 23--1: Values of standard control variables } + + @end group ++@end format + + @subsubheading Examples:: + +@@ -1363,9 +1365,9 @@ + + @subsubheading See Also:: + +-@ref{read; read-preserving-whitespace} ++@ref{read} + , +-{@ref{Syntax}} ++@ref{Syntax} + + @subsubheading Notes:: + +@@ -1443,7 +1445,7 @@ + + @subsubheading See Also:: + +-@ref{read; read-preserving-whitespace} ++@ref{read} + , + @ref{stream-error-stream} + , +diff -uNr gcl-texi-orig/chap-24.texi gcl-texi/chap-24.texi +--- gcl-texi-orig/chap-24.texi 1994-07-16 18:03:03 +0400 ++++ gcl-texi/chap-24.texi 2002-10-17 20:53:05 +0400 +@@ -97,12 +97,12 @@ + if its argument @i{feature-conditional} fails; + otherwise, it succeeds. + +-@item @t{(and @{@i{feature-conditional}@}{*})} ++@item @t{(and @{@i{feature-conditional}@}*)} + An @b{and} @i{feature expression} succeeds + if all of its argument @i{feature-conditionals} succeed; + otherwise, it fails. + +-@item @t{(or @{@i{feature-conditional}@}{*})} ++@item @t{(or @{@i{feature-conditional}@}*)} + An @b{or} @i{feature expression} succeeds + if any of its argument @i{feature-conditionals} succeed; + otherwise, it fails. +@@ -124,6 +124,7 @@ + Figure 24--1 shows some sample @i{expressions}, and how they would be + @i{read}_2 in these @i{implementations}. + ++@format + @group + @noindent + @w{ @t{(cons #+spice "Spice" #-spice "Lispm" x)} } +@@ -151,6 +152,7 @@ + @w{ Figure 24--1: Features examples } + + @end group ++@end format + + @c end of including concept-systems + +@@ -176,7 +178,7 @@ + @node compile-file, compile-file-pathname, System Construction Dictionary, System Construction Dictionary + @subsection compile-file [Function] + +-@code{compile-file} @i{input-file {&key} output-file verbose ++@code{compile-file} @i{input-file @r{&key} output-file verbose + print external-format}@* + @result{} @i{output-truename, warnings-p, failure-p} + +@@ -320,7 +322,7 @@ + @node compile-file-pathname, load, compile-file, System Construction Dictionary + @subsection compile-file-pathname [Function] + +-@code{compile-file-pathname} @i{input-file {&key} output-file {&allow-other-keys}} @result{} @i{pathname} ++@code{compile-file-pathname} @i{input-file @r{&key} output-file @r{&allow-other-keys}} @result{} @i{pathname} + + @subsubheading Arguments and Values:: + +@@ -388,7 +390,7 @@ + @node load, with-compilation-unit, compile-file-pathname, System Construction Dictionary + @subsection load [Function] + +-@code{load} @i{filespec {&key} verbose print ++@code{load} @i{filespec @r{&key} verbose print + if-does-not-exist external-format}@* + @result{} @i{generalized-boolean} + +@@ -567,7 +569,7 @@ + @subsection with-compilation-unit [Macro] + + @code{with-compilation-unit} @i{@r{(}[[!@i{option}]]@r{)} +- @{@i{form}@}{*}} @result{} @i{@{@i{result}@}{*}} ++ @{@i{form}@}*} @result{} @i{@{@i{result}@}*} + + @w{@i{option} ::=@t{:override} override} + +@@ -908,7 +910,7 @@ + + @subsubheading See Also:: + +-@ref{provide; require} ++@ref{provide} + , + @b{require} + +@@ -921,7 +923,7 @@ + + @code{provide} @i{module-name} @result{} @i{@i{implementation-dependent}} + +-@code{require} @i{module-name {&optional} pathname-list} @result{} @i{@i{implementation-dependent}} ++@code{require} @i{module-name @r{&optional} pathname-list} @result{} @i{@i{implementation-dependent}} + + @subsubheading Arguments and Values:: + +diff -uNr gcl-texi-orig/chap-25.texi gcl-texi/chap-25.texi +--- gcl-texi-orig/chap-25.texi 1994-07-16 18:03:02 +0400 ++++ gcl-texi/chap-25.texi 2002-10-17 20:53:05 +0400 +@@ -36,6 +36,7 @@ + @i{form}. + Figure 25--1 lists variables that are maintained by the @i{Lisp read-eval-print loop}. + ++@format + @group + @noindent + @w{ * + / - } +@@ -46,6 +47,7 @@ + @w{ Figure 25--1: Variables maintained by the Read-Eval-Print Loop} + + @end group ++@end format + + @node Debugging Utilities, Environment Inquiry, Top level loop, The External Environment + @subsection Debugging Utilities +@@ -53,6 +55,7 @@ + Figure 25--2 shows @i{defined names} relating to + debugging. + ++@format + @group + @noindent + @w{ *debugger-hook* documentation step } +@@ -65,6 +68,7 @@ + @w{ Figure 25--2: Defined names relating to debugging} + + @end group ++@end format + + @node Environment Inquiry, Time, Debugging Utilities, The External Environment + @subsection Environment Inquiry +@@ -75,6 +79,7 @@ + + Figure 25--3 shows @i{defined names} relating to environment inquiry. + ++@format + @group + @noindent + @w{ *features* machine-instance short-site-name } +@@ -86,6 +91,7 @@ + @w{ Figure 25--3: Defined names relating to environment inquiry. } + + @end group ++@end format + + @node Time, , Environment Inquiry, The External Environment + @subsection Time +@@ -110,6 +116,7 @@ + + Figure 25--4 shows @i{defined names} relating to @i{time}. + ++@format + @group + @noindent + @w{ decode-universal-time get-internal-run-time } +@@ -121,6 +128,7 @@ + @w{ Figure 25--4: Defined names involving Time. } + + @end group ++@end format + + @menu + * Decoded Time:: +@@ -183,6 +191,7 @@ + + Figure 25--5 shows @i{defined names} relating to @i{decoded time}. + ++@format + @group + @noindent + @w{ decode-universal-time get-decoded-time } +@@ -191,6 +200,7 @@ + @w{ Figure 25--5: Defined names involving time in Decoded Time.} + + @end group ++@end format + + @node Universal Time, Internal Time, Decoded Time, Time + @subsubsection Universal Time +@@ -211,6 +221,7 @@ + Because @i{universal time} must be a non-negative @i{integer}, + times before the base time of midnight, January 1, 1900 GMT cannot be processed by @r{Common Lisp}. + ++@format + @group + @noindent + @w{ decode-universal-time get-universal-time } +@@ -220,6 +231,7 @@ + @w{ Figure 25--6: Defined names involving time in Universal Time.} + + @end group ++@end format + + @node Internal Time, Seconds, Universal Time, Time + @subsubsection Internal Time +@@ -233,6 +245,7 @@ + + Figure 25--7 shows @i{defined names} related to @i{internal time}. + ++@format + @group + @noindent + @w{ get-internal-real-time internal-time-units-per-second } +@@ -242,6 +255,7 @@ + @w{ Figure 25--7: Defined names involving time in Internal Time.} + + @end group ++@end format + + @node Seconds, , Internal Time, Time + @subsubsection Seconds +@@ -253,6 +267,7 @@ + @b{sleep} can be any kind of non-negative @i{real}, in order to allow for + the possibility of fractional seconds. + ++@format + @group + @noindent + @w{ sleep } +@@ -261,6 +276,7 @@ + @w{ Figure 25--8: Defined names involving time in Seconds.} + + @end group ++@end format + + @c end of including concept-environment + +@@ -289,10 +305,10 @@ + * ed:: + * inspect:: + * dribble:: +-* -:: +-* +:: +-* *:: +-* /:: ++* - (Variable):: ++* + (Variable):: ++* * (Variable):: ++* / (Variable):: + * lisp-implementation-type:: + * short-site-name:: + * machine-instance:: +@@ -305,7 +321,7 @@ + @node decode-universal-time, encode-universal-time, Environment Dictionary, Environment Dictionary + @subsection decode-universal-time [Function] + +-@code{decode-universal-time} @i{universal-time {&optional} time-zone}@* ++@code{decode-universal-time} @i{universal-time @r{&optional} time-zone}@* + @result{} @i{second, minute, hour, date, month, year, day, daylight-p, zone} + + @subsubheading Arguments and Values:: +@@ -354,7 +370,7 @@ + + @ref{encode-universal-time} + , +-@ref{get-universal-time; get-decoded-time} ++@ref{get-universal-time} + , + @ref{Time} + +@@ -364,7 +380,7 @@ + @subsubheading Syntax:: + + @code{encode-universal-time} @i{second minute hour date month year +- {&optional} time-zone}@* ++ @r{&optional} time-zone}@* + @result{} @i{universal-time} + + @subsubheading Arguments and Values:: +@@ -511,9 +527,9 @@ + @node apropos, describe, sleep, Environment Dictionary + @subsection apropos, apropos-list [Function] + +-@code{apropos} @i{string {&optional} package} @result{} @i{<@i{no @i{values}}>} ++@code{apropos} @i{string @r{&optional} package} @result{} @i{<@i{no @i{values}}>} + +-@code{apropos-list} @i{string {&optional} package} @result{} @i{symbols} ++@code{apropos-list} @i{string @r{&optional} package} @result{} @i{symbols} + + @subsubheading Arguments and Values:: + +@@ -560,7 +576,7 @@ + @node describe, describe-object, apropos, Environment Dictionary + @subsection describe [Function] + +-@code{describe} @i{object {&optional} stream} @result{} @i{<@i{no @i{values}}>} ++@code{describe} @i{object @r{&optional} stream} @result{} @i{<@i{no @i{values}}>} + + @subsubheading Arguments and Values:: + +@@ -700,9 +716,9 @@ + @node trace, step, describe-object, Environment Dictionary + @subsection trace, untrace [Macro] + +-@code{trace} @i{@{@i{function-name}@}{*}} @result{} @i{trace-result} ++@code{trace} @i{@{@i{function-name}@}*} @result{} @i{trace-result} + +-@code{untrace} @i{@{@i{function-name}@}{*}} @result{} @i{untrace-result} ++@code{untrace} @i{@{@i{function-name}@}*} @result{} @i{untrace-result} + + @subsubheading Arguments and Values:: + +@@ -795,7 +811,7 @@ + @node step, time, trace, Environment Dictionary + @subsection step [Macro] + +-@code{step} @i{form} @result{} @i{@{@i{result}@}{*}} ++@code{step} @i{form} @result{} @i{@{@i{result}@}*} + + @subsubheading Arguments and Values:: + +@@ -830,7 +846,7 @@ + + @subsubheading See Also:: + +-@ref{trace; untrace} ++@ref{trace} + + @subsubheading Notes:: + +@@ -841,7 +857,7 @@ + @node time, internal-time-units-per-second, step, Environment Dictionary + @subsection time [Macro] + +-@code{time} @i{form} @result{} @i{@{@i{result}@}{*}} ++@code{time} @i{form} @result{} @i{@{@i{result}@}*} + + @subsubheading Arguments and Values:: + +@@ -895,7 +911,7 @@ + purposes. + + For useful background information on the complicated issues involved in +-interpreting timing results, see {Performance and Evaluation of Lisp Programs}. ++interpreting timing results, see @i{Performance and Evaluation of Lisp Programs}. + + @node internal-time-units-per-second, get-internal-real-time, time, Environment Dictionary + @subsection internal-time-units-per-second [Constant Variable] +@@ -1215,7 +1231,7 @@ + @node room, ed, documentation, Environment Dictionary + @subsection room [Function] + +-@code{room} @i{{&optional} x} @result{} @i{@i{implementation-dependent}} ++@code{room} @i{@r{&optional} x} @result{} @i{@i{implementation-dependent}} + + @subsubheading Arguments and Values:: + +@@ -1249,7 +1265,7 @@ + @node ed, inspect, room, Environment Dictionary + @subsection ed [Function] + +-@code{ed} @i{{&optional} x} @result{} @i{@i{implementation-dependent}} ++@code{ed} @i{@r{&optional} x} @result{} @i{@i{implementation-dependent}} + + @subsubheading Arguments and Values:: + +@@ -1337,10 +1353,10 @@ + of @t{?} or a ``help key'' by providing help, including a list + of commands. + +-@node dribble, -, inspect, Environment Dictionary ++@node dribble, - (Variable), inspect, Environment Dictionary + @subsection dribble [Function] + +-@code{dribble} @i{{&optional} pathname} @result{} @i{@i{implementation-dependent}} ++@code{dribble} @i{@r{&optional} pathname} @result{} @i{@i{implementation-dependent}} + + @subsubheading Arguments and Values:: + +@@ -1396,7 +1412,7 @@ + @b{dribble} is intended primarily for interactive debugging; + its effect cannot be relied upon when used in a program. + +-@node -, +, dribble, Environment Dictionary ++@node - (Variable), + (Variable), dribble, Environment Dictionary + @subsection - [Variable] + + @subsubheading Value Type:: +@@ -1432,7 +1448,7 @@ + (@i{variable}), + @ref{Top level loop} + +-@node +, *, -, Environment Dictionary ++@node + (Variable), * (Variable), - (Variable), Environment Dictionary + @subsection +, ++, +++ [Variable] + + @subsubheading Value Type:: +@@ -1479,7 +1495,7 @@ + (@i{variable}), + @ref{Top level loop} + +-@node *, /, +, Environment Dictionary ++@node * (Variable), / (Variable), + (Variable), Environment Dictionary + @subsection *, **, *** [Variable] + + @subsubheading Value Type:: +@@ -1543,7 +1559,7 @@ + *** @equiv{} (car ///) + @end example + +-@node /, lisp-implementation-type, *, Environment Dictionary ++@node / (Variable), lisp-implementation-type, * (Variable), Environment Dictionary + @subsection /, //, /// [Variable] + + @subsubheading Value Type:: +@@ -1588,7 +1604,7 @@ + @b{*} (@i{variable}), + @ref{Top level loop} + +-@node lisp-implementation-type, short-site-name, /, Environment Dictionary ++@node lisp-implementation-type, short-site-name, / (Variable), Environment Dictionary + @subsection lisp-implementation-type, + @subheading lisp-implementation-version + @flushright +@@ -1804,7 +1820,7 @@ + @node user-homedir-pathname, , software-type, Environment Dictionary + @subsection user-homedir-pathname [Function] + +-@code{user-homedir-pathname} @i{{&optional} host} @result{} @i{pathname} ++@code{user-homedir-pathname} @i{@r{&optional} host} @result{} @i{pathname} + + @subsubheading Arguments and Values:: + +diff -uNr gcl-texi-orig/chap-26.texi gcl-texi/chap-26.texi +--- gcl-texi-orig/chap-26.texi 1994-07-16 18:03:01 +0400 ++++ gcl-texi/chap-26.texi 2002-10-17 20:53:05 +0400 +@@ -25,7 +25,7 @@ + pronounced 'a ,list . The pronunciation key follows + @i{Webster's Third New International Dictionary + the English Language, Unabridged}, +- except that ``{e}'' is used to notate the schwa (upside-down ``e'') character. ++ except that ``e'' is used to notate the schwa (upside-down ``e'') character. + + @item @t{*} + the part or parts of speech, set in italics. If a term +@@ -48,7 +48,7 @@ + + @item -- + an optional discipline, set in italics, present if the term +-has a standard definition being repeated. For example, ``{Math.}'' ++has a standard definition being repeated. For example, ``Math.'' + + @item -- + an optional context, present if this definition is +@@ -59,7 +59,7 @@ + + @item -- + an optional example sentence. For example, +- {``This is an example of an example.''} ++ ``This is an example of an example.'' + + @item -- + optional cross references. +@@ -70,7 +70,7 @@ + + In addition, some terms have idiomatic usage in the Common Lisp + community which is not shared by other communities, or which is not +-technically correct. Definitions labeled ``{Idiom.}'' represent ++technically correct. Definitions labeled ``Idiom.'' represent + such idiomatic usage; these definitions are sometimes followed by an + explanatory note. + +@@ -272,7 +272,7 @@ + @item @b{alphanumeric} + @i{adj.} (of a @i{character}) + being either an @i{alphabetic}_1 @i{character} +- or a @i{numeric} {character}. ++ or a @i{numeric} @i{character}. + + @IGindex{ampersand} + @item @b{ampersand} +@@ -332,8 +332,8 @@ + @i{v.t.} (a @i{function} to a @i{list}) + to @i{call} the @i{function} with arguments that are the @i{elements} + of the @i{list}. +- {``Applying the function @b{+} to a list of integers returns +- the sum of the elements of that list.''} ++ ``Applying the function @b{+} to a list of integers returns ++ the sum of the elements of that list.'' + + @IGindex{argument} + @item @b{argument} +@@ -347,7 +347,7 @@ + @item @b{argument evaluation order} + @i{n.} + the order in which @i{arguments} are evaluated in a function call. +- {``The argument evaluation order for Common Lisp is left to right.''} ++ ``The argument evaluation order for Common Lisp is left to right.'' + See @ref{Evaluation}. + + @IGindex{argument precedence order} +@@ -418,13 +418,13 @@ + @item @b{atom} + @i{n.} + any @i{object} that is not a @i{cons}. +- {``A vector is an atom.''} ++ ``A vector is an atom.'' + + @IGindex{atomic} + @item @b{atomic} + @i{adj.} + being an @i{atom}. +- {``The number 3, the symbol @t{foo}, and @b{nil} are atomic.''} ++ ``The number 3, the symbol @t{foo}, and @b{nil} are atomic.'' + + @IGindex{atomic type specifier} + @item @b{atomic type specifier} +@@ -441,9 +441,9 @@ + is its @i{code}_2, but @i{implementations} are permitted to have + additional @i{implementation-defined} @i{attributes}. + See @ref{Character Attributes}. +- {``An implementation that support fonts ++ ``An implementation that support fonts + might make font information an attribute of a character, +- while others might represent font information separately from characters.''} ++ while others might represent font information separately from characters.'' + + @IGindex{aux variable} + @item @b{aux variable} +@@ -530,8 +530,8 @@ + @i{n.} + an association between a @i{name} and that which the @i{name} + denotes. +- {``A lexical binding is a lexical association between a +- name and its value.''} ++ ``A lexical binding is a lexical association between a ++ name and its value.'' + + @IGindex{bit} + @item @b{bit} +@@ -624,13 +624,13 @@ + @item @b{bound} + @i{adj.}, @i{v.t.} + 1. @i{adj.} having an associated denotation in a @i{binding}. +- {``The variables named by a @b{let} are bound within +- its body.''} ++ ``The variables named by a @b{let} are bound within ++ its body.'' + See @i{unbound}. + 2. @i{adj.} having a local @i{binding} which + @i{shadows}_2 another. +- {``The variable @b{*print-escape*} is bound while in +- the @b{princ} function.''} ++ ``The variable @b{*print-escape*} is bound while in ++ the @b{princ} function.'' + 3. @i{v.t.} the past tense of @i{bind}. + + @IGindex{bound declaration} +@@ -736,8 +736,8 @@ + @i{executed} in an @i{environment} where @i{bindings} for + the @i{values} of its @i{parameters} have been @i{established} + based on the @i{arguments}. +- {``Calling the function @b{+} with the arguments +- @t{5} and @t{1} yields a value of @t{6}.''} ++ ``Calling the function @b{+} with the arguments ++ @t{5} and @t{1} yields a value of @t{6}.'' + 2. @i{n.} a @i{situation} in which a @i{function} is called. + + @IGindex{captured initialization form} +@@ -746,9 +746,9 @@ + an @i{initialization form} along with the @i{lexical environment} + in which the @i{form} that defined the @i{initialization form} + was @i{evaluated}. +- {``Each newly added shared slot is set to the result of evaluating ++ ``Each newly added shared slot is set to the result of evaluating + the captured initialization form for the slot that was specified +- in the @b{defclass} form for the new class.''} ++ in the @b{defclass} form for the new class.'' + + @IGindex{car} + @item @b{car} +@@ -757,20 +757,20 @@ + the component of a @i{cons} corresponding to the first + @i{argument} to @b{cons}; the other component is the + @i{cdr}. +- {``The function @b{rplaca} modifies the car of a cons.''} ++ ``The function @b{rplaca} modifies the car of a cons.'' + b. (of a @i{list}) + the first @i{element} of the @i{list}, or @b{nil} if the + @i{list} is the @i{empty list}. + 2. the @i{object} that is held in the @i{car}_1. +- {``The function @b{car} returns the car of a cons.''} ++ ``The function @b{car} returns the car of a cons.'' + + @IGindex{case} + @item @b{case} + @i{n.} (of a @i{character}) + the property of being either @i{uppercase} or @i{lowercase}. + Not all @i{characters} have @i{case}. +- {``The characters @t{#\A} and @t{#\a} have case, +- but the character @t{#\$} has no case.''} ++ ``The characters @t{#\A} and @t{#\a} have case, ++ but the character @t{#\$} has no case.'' + See @ref{Characters With Case} and the @i{function} @b{both-case-p}. + + @IGindex{case sensitivity mode} +@@ -808,13 +808,13 @@ + 1. a. (of a @i{cons}) + the component of a @i{cons} corresponding to the second @i{argument} + to @b{cons}; the other component is the @i{car}. +- {``The function @b{rplacd} modifies the cdr of a cons.''} ++ ``The function @b{rplacd} modifies the cdr of a cons.'' + b. (of a @i{list} L_1) + either the @i{list} L_2 that contains + the @i{elements} of L_1 that follow after the first, + or else @b{nil} if L_1 is the @i{empty list}. + 2. the @i{object} that is held in the @i{cdr}_1. +- {``The function @b{cdr} returns the cdr of a cons.''} ++ ``The function @b{cdr} returns the cdr of a cons.'' + + @IGindex{cell} + @item @b{cell} +@@ -884,7 +884,7 @@ + other @i{objects} called its @i{indirect instances}, + and that acts as a @i{type specifier} for a set of objects + called its @i{generalized instances}. +- {``The class @b{integer} is a subclass of the class @b{number}.''} ++ ``The class @b{integer} is a subclass of the class @b{number}.'' + (Note that the phrase ``the @i{class} @t{foo}'' is often substituted for + the more precise phrase ``the @i{class} named @t{foo}''---in both + cases, a @i{class} @i{object} (not a @i{symbol}) is denoted.) +@@ -892,8 +892,8 @@ + the uniquely determined @i{class} of which the @i{object} is + a @i{direct instance}. + See the @i{function} @b{class-of}. +- {``The class of the object returned by @b{gensym} +- is @b{symbol}.''} ++ ``The class of the object returned by @b{gensym} ++ is @b{symbol}.'' + (Note that with this usage a phrase such as ``its @i{class} is @t{foo}'' + is often substituted for the more precise phrase + ``its @i{class} is the @i{class} named @t{foo}''---in both +@@ -929,7 +929,7 @@ + @IGindex{closed} + @item @b{closed} + @i{adj.} (of a @i{stream}) +- having been @i{closed} (see @i{@i}{close}). ++ having been @i{closed} (see @i{close}). + Some (but not all) operations that are valid on @i{open} @i{streams} + are not valid on @i{closed} @i{streams}. + See @ref{File Operations on Open and Closed Streams}. +@@ -1149,7 +1149,7 @@ + @item @b{composite stream} + @i{n.} + a @i{stream} that is composed of one or more other @i{streams}. +- {``@b{make-synonym-stream} creates a composite stream.''} ++ ``@b{make-synonym-stream} creates a composite stream.'' + + @IGindex{compound form} + @item @b{compound form} +@@ -1165,7 +1165,7 @@ + @i{n.} + a @i{type specifier} that is a @i{cons}; + @i{i.e.}, a @i{type specifier} that is not an @i{atomic type specifier}. +- {``@t{(vector single-float)} is a compound type specifier.''} ++ ``@t{(vector single-float)} is a compound type specifier.'' + + @IGindex{concatenated stream} + @item @b{concatenated stream} +@@ -1286,24 +1286,24 @@ + that neither affects nor is affected by the state of any @i{object} + except those @i{objects} that are @i{otherwise inaccessible parts} + of @i{objects} created by the @i{form} itself. +- {``A @b{car} form in which the argument is a +- @b{quote} form is a constant form.''} ++ ``A @b{car} form in which the argument is a ++ @b{quote} form is a constant form.'' + + @IGindex{constant object} + @item @b{constant object} + @i{n.} + an @i{object} that is constrained (@i{e.g.}, by its context in a @i{program} + or by the source from which it was obtained) to be @i{immutable}. +- {``A literal object that has been processed by @b{compile-file} +- is a constant object.''} ++ ``A literal object that has been processed by @b{compile-file} ++ is a constant object.'' + + @IGindex{constant variable} + @item @b{constant variable} + @i{n.} + a @i{variable}, the @i{value} of which can never change; + that is, a @i{keyword}_1 or a @i{named constant}. +- {``The symbols @b{t}, @b{nil}, @t{:direction}, and +- @b{most-positive-fixnum} are constant variables.''} ++ ``The symbols @b{t}, @b{nil}, @t{:direction}, and ++ @b{most-positive-fixnum} are constant variables.'' + + @IGindex{constituent} + @item @b{constituent} +@@ -1329,7 +1329,7 @@ + a @i{stream} whose source or sink is a Lisp @i{object}. + Note that since a @i{stream} is another Lisp @i{object}, + @i{composite streams} are considered @i{constructed streams}. +- {``A string stream is a constructed stream.''} ++ ``A string stream is a constructed stream.'' + + @IGindex{contagion} + @item @b{contagion} +@@ -1394,8 +1394,8 @@ + 1. (by a @i{restart} other than @b{abort} + that has been associated with the @i{error}) + capable of being corrected by invoking that @i{restart}. +- {``The function @b{cerror} signals an error +- that is correctable by the @b{continue} @i{restart}.''} ++ ``The function @b{cerror} signals an error ++ that is correctable by the @b{continue} @i{restart}.'' + + (Note that correctability is not a property of an + @i{error} @i{object}, but rather a property of the +@@ -1407,9 +1407,9 @@ + + 2. (when no specific @i{restart} is mentioned) + @i{correctable}_1 by at least one @i{restart}. +- {``@b{import} signals a correctable error of @i{type} @b{package-error} ++ ``@b{import} signals a correctable error of @i{type} @b{package-error} + if any of the imported symbols has the same name as +- some distinct symbol already accessible in the package.''} ++ some distinct symbol already accessible in the package.'' + + @IGindex{current input base} + @item @b{current input base} +@@ -1573,7 +1573,7 @@ + @item @b{defining form} + @i{n.} + a @i{form} that has the side-effect of @i{establishing} a definition. +- {``@b{defun} and @b{defparameter} are defining forms.''} ++ ``@b{defun} and @b{defparameter} are defining forms.'' + + @IGindex{defsetf lambda list} + @item @b{defsetf lambda list} +@@ -1595,7 +1595,7 @@ + @item @b{denormalized} + @i{adj.}, @i{ANSI}, @i{IEEE} (of a @i{float}) + conforming to the description of ``denormalized'' as described by +- {IEEE Standard for Binary Floating-Point Arithmetic}. ++ @i{IEEE Standard for Binary Floating-Point Arithmetic}. + For example, in an @i{implementation} where the minimum possible exponent + was @t{-7} but where @t{0.001} was a valid mantissa, the number @t{1.0e-10} + might be representable as @t{0.001e-7} internally even if the @i{normalized} +@@ -1646,8 +1646,8 @@ + @item @b{different} + @i{adj.} + not the @i{same} +- {``The strings @t{"FOO"} and @t{"foo"} are different under +- @b{equal} but not under @b{equalp}.''} ++ ``The strings @t{"FOO"} and @t{"foo"} are different under ++ @b{equal} but not under @b{equalp}.'' + + @IGindex{digit} + @item @b{digit} +@@ -1664,18 +1664,18 @@ + @i{objects} an @i{array} can hold along one axis. + If the @i{array} is a @i{vector} with a @i{fill pointer}, + the @i{fill pointer} is ignored. +- {``The second dimension of that array is 7.''} ++ ``The second dimension of that array is 7.'' + 2. an axis of an array. +- {``This array has six dimensions.''} ++ ``This array has six dimensions.'' + + @IGindex{direct instance} + @item @b{direct instance} + @i{n.} (of a @i{class} C) + an @i{object} whose @i{class} is C itself, + rather than some @i{subclass} of C. +- {``The function @b{make-instance} always returns a ++ ``The function @b{make-instance} always returns a + direct instance of the class which is (or is named by) +- its first argument.''} ++ its first argument.'' + + @IGindex{direct subclass} + @item @b{direct subclass} +@@ -1737,8 +1737,8 @@ + In some cases, the @i{documentation string} is saved in such a + way that it can later be obtained by supplying either an @i{object}, + or by supplying a @i{name} and a ``kind'' to the @i{function} @b{documentation}. +- {``The body of code in a @b{defmacro} form can be preceded +- by a documentation string of kind @b{function}.''} ++ ``The body of code in a @b{defmacro} form can be preceded ++ by a documentation string of kind @b{function}.'' + + @IGindex{dot} + @item @b{dot} +@@ -1801,7 +1801,7 @@ + an @i{extent} whose duration is bounded by points of + @i{establishment} and @i{disestablishment} within the execution + of a particular @i{form}. See @i{indefinite extent}. +- {``Dynamic variable bindings have dynamic extent.''} ++ ``Dynamic variable bindings have dynamic extent.'' + + @IGindex{dynamic scope} + @item @b{dynamic scope} +@@ -1907,7 +1907,7 @@ + @i{n.} + 1. a set of @i{bindings}. See @ref{Introduction to Environments}. + 2. an @i{environment object}. +- {``@b{macroexpand} takes an optional environment argument.''} ++ ``@b{macroexpand} takes an optional environment argument.'' + + @IGindex{environment object} + @item @b{environment object} +@@ -1915,7 +1915,7 @@ + an @i{object} representing a set of @i{lexical bindings}, + used in the processing of a @i{form} to provide meanings for + @i{names} within that @i{form}. +- {``@b{macroexpand} takes an optional environment argument.''} ++ ``@b{macroexpand} takes an optional environment argument.'' + (The @i{object} @b{nil} when used as an @i{environment object} + denotes the @i{null lexical environment}; + the @i{values} of @i{environment parameters} +@@ -1966,7 +1966,7 @@ + a @i{handler}, + a @i{restart}, + or an @i{environment}. +- {``@b{let} establishes lexical bindings.''} ++ ``@b{let} establishes lexical bindings.'' + + @IGindex{evaluate} + @item @b{evaluate} +@@ -2029,7 +2029,7 @@ + control and possibly @i{values} can be transferred both actively by using + another @i{control form} and passively through the normal control and + data flow of @i{evaluation}. +- {``@b{catch} and @b{block} establish bindings for ++ ``@b{catch} and @b{block} establish bindings for + exit points to which @b{throw} and @b{return-from}, + respectively, can transfer control and values; + @b{tagbody} establishes a binding for an exit point +@@ -2037,7 +2037,7 @@ + and @b{unwind-protect} establishes an exit point + through which control might be transferred by + operators such as @b{throw}, @b{return-from}, +- and @b{go}.''} ++ and @b{go}.'' + + @IGindex{explicit return} + @item @b{explicit return} +@@ -2062,9 +2062,10 @@ + The characters defined as @i{exponent markers} in the @i{standard readtable} + are shown in Figure 26--1. + For more information, see @ref{Character Syntax}. +- {``The exponent marker `d' in `3.0d7' indicates +- that this number is to be represented as a double float.''} ++ ``The exponent marker `d' in `3.0d7' indicates ++ that this number is to be represented as a double float.'' + ++@format + @group + @noindent + @w{ Marker Meaning } +@@ -2078,6 +2079,7 @@ + @w{ Figure 26--1: Exponent Markers } + + @end group ++@end format + + @IGindex{export} + @item @b{export} +@@ -2135,10 +2137,10 @@ + 1. an @i{object}, often used to emphasize the use + of the @i{object} to encode or represent information in a specialized + format, such as program text. +- {``The second expression in a @b{let} form is a list +- of bindings.''} ++ ``The second expression in a @b{let} form is a list ++ of bindings.'' + 2. the textual notation used to notate an @i{object} in a source file. +- {``The expression @t{'sample} is equivalent to @t{(quote sample)}.''} ++ ``The expression @t{'sample} is equivalent to @t{(quote sample)}.'' + + @IGindex{expressly adjustable} + @item @b{expressly adjustable} +@@ -2181,7 +2183,7 @@ + a list resembling an @i{ordinary lambda list} in form and purpose, but + offering additional syntax or functionality not available in an + @i{ordinary lambda list}. +- {``@b{defmacro} uses extended lambda lists.''} ++ ``@b{defmacro} uses extended lambda lists.'' + + @IGindex{extension} + @item @b{extension} +@@ -2282,7 +2284,7 @@ + or of the @i{environment}. + 2. a @i{symbol} that names a @i{feature}_1. + See @ref{Features}. +- {``The @t{:ansi-cl} feature is present in all conforming implementations.''} ++ ``The @t{:ansi-cl} feature is present in all conforming implementations.'' + + @IGindex{feature expression} + @item @b{feature expression} +@@ -2370,8 +2372,8 @@ + @item @b{finite} + @i{adj.} (of a @i{type}) + having a finite number of @i{elements}. +- {``The type specifier @t{(integer 0 5)} denotes a finite type, +- but the type specifiers @b{integer} and @t{(integer 0)} do not.''} ++ ``The type specifier @t{(integer 0 5)} denotes a finite type, ++ but the type specifiers @b{integer} and @t{(integer 0)} do not.'' + + @IGindex{fixnum} + @item @b{fixnum} +@@ -2398,7 +2400,7 @@ + or a @i{self-evaluating object}. + 3. (for an @i{operator}, as in ``<<@i{operator}>> @i{form}'') + a @i{compound form} having that @i{operator} as its first element. +- {``A @b{quote} form is a constant form.''} ++ ``A @b{quote} form is a constant form.'' + + @IGindex{formal argument} + @item @b{formal argument} +@@ -2439,12 +2441,12 @@ + to mean that some special operation should be performed, possibly + involving data supplied by the @i{format arguments} that + accompanied the @i{format string}. See the @i{function} @b{format}. +- {``In @t{"~D base 10 = ~8R"}, the character +- sequences `@t{~D}' and `@t{~8R}' are format directives.''} ++ ``In @t{"~D base 10 = ~8R"}, the character ++ sequences `@t{~D}' and `@t{~8R}' are format directives.'' + 2. the conceptual category of all @i{format directives}_1 + which use the same dispatch character. +- {``Both @t{"~3d"} and @t{"~3,'0D"} are valid uses of the +- `@t{~D}' format directive.''} ++ ``Both @t{"~3d"} and @t{"~3,'0D"} are valid uses of the ++ `@t{~D}' format directive.'' + + @IGindex{format string} + @item @b{format string} +@@ -2581,8 +2583,8 @@ + @i{n.} + @i{implementation-dependent} compilation beyond @i{minimal compilation}. + Further compilation is permitted to take place at @i{run time}. +- {``Block compilation and generation of machine-specific instructions +- are examples of further compilation.''} ++ ``Block compilation and generation of machine-specific instructions ++ are examples of further compilation.'' + + @end table + @subheading @b{G} +@@ -2673,7 +2675,7 @@ + @item @b{glyph} + @i{n.} + a visual representation. +- {``Graphic characters have associated glyphs.''} ++ ``Graphic characters have associated glyphs.'' + + @IGindex{go} + @item @b{go} +@@ -2749,6 +2751,7 @@ + that is defined by the @i{implementation} + to be an @i{I/O customization variable}. + ++@format + @group + @noindent + @w{ *debug-io* *error-io* query-io* } +@@ -2758,6 +2761,7 @@ + @w{ Figure 26--2: Standardized I/O Customization Variables} + + @end group ++@end format + + @IGindex{identical} + @item @b{identical} +@@ -2780,7 +2784,7 @@ + @i{implementations} are not required to detect attempts to modify + @i{immutable} @i{objects} or @i{cells}; the consequences of attempting + to make such modification are undefined. +- {``Numbers are immutable.''} ++ ``Numbers are immutable.'' + + @IGindex{implementation} + @item @b{implementation} +@@ -2861,7 +2865,7 @@ + @item @b{indefinite extent} + @i{n.} + an @i{extent} whose duration is unlimited. +- {``Most Common Lisp objects have indefinite extent.''} ++ ``Most Common Lisp objects have indefinite extent.'' + + @IGindex{indefinite scope} + @item @b{indefinite scope} +@@ -2878,7 +2882,7 @@ + @i{n.} (of a @i{class} C_1) + an @i{object} of @i{class} C_2, + where C_2 is a @i{subclass} of C_1. +- {``An integer is an indirect instance of the class @b{number}.''} ++ ``An integer is an indirect instance of the class @b{number}.'' + + @IGindex{inherit} + @item @b{inherit} +@@ -2912,8 +2916,8 @@ + @i{n.} + a @i{form} used to supply the initial @i{value} for a @i{slot} + or @i{variable}. +- {``The initialization form for a slot in a @b{defclass} form +- is introduced by the keyword @t{:initform}.''} ++ ``The initialization form for a slot in a @b{defclass} form ++ is introduced by the keyword @t{:initform}.'' + + @IGindex{input} + @item @b{input} +@@ -3028,6 +3032,7 @@ + or a @i{compound form} that has an @i{implementation-defined} @i{operator} + and that is defined by the @i{implementation} to be an @i{iteration form}. + ++@format + @group + @noindent + @w{ do do-external-symbols dotimes } +@@ -3038,6 +3043,7 @@ + @w{ Figure 26--3: Standardized Iteration Forms } + + @end group ++@end format + + @IGindex{iteration variable} + @item @b{iteration variable} +@@ -3199,7 +3205,7 @@ + @i{n.} + @i{scope} that is limited to a spatial or textual region within the + establishing @i{form}. +- {``The names of parameters to a function normally are lexically scoped.''} ++ ``The names of parameters to a function normally are lexically scoped.'' + + @IGindex{lexical variable} + @item @b{lexical variable} +@@ -3303,9 +3309,9 @@ + appearing as data in a @b{quote} @i{form}, + or, if the @i{object} is a @i{self-evaluating object}, + appearing as unquoted data. +- {``In the form @t{(cons "one" '("two"))}, ++ ``In the form @t{(cons "one" '("two"))}, + the expressions @t{"one"}, @t{("two")}, and @t{"two"} +- are literal objects.''} ++ are literal objects.'' + + @IGindex{load} + @item @b{load} +@@ -3544,7 +3550,7 @@ + but which deviates in syntax or functionality from the definition of an + @i{ordinary lambda list}. + See @i{ordinary lambda list}. +- {``@b{deftype} uses a modified lambda list.''} ++ ``@b{deftype} uses a modified lambda list.'' + + @IGindex{most recent} + @item @b{most recent} +@@ -3571,13 +3577,13 @@ + @item @b{multiple values} + @i{n.} + 1. more than one @i{value}. +- {``The function @b{truncate} returns multiple values.''} ++ ``The function @b{truncate} returns multiple values.'' + 2. a variable number of @i{values}, possibly including zero or one. +- {``The function @b{values} returns multiple values.''} ++ ``The function @b{values} returns multiple values.'' + 3. a fixed number of values other than one. +- {``The macro @b{multiple-value-bind} is among the few ++ ``The macro @b{multiple-value-bind} is among the few + operators in @r{Common Lisp} which can detect and manipulate +- multiple values.''} ++ multiple values.'' + + @end table + @subheading @b{N} +@@ -3592,8 +3598,8 @@ + 2. @i{v.t.} to give a @i{name} to. + 3. @i{n.} (of an @i{object} having a name component) + the @i{object} which is that component. +- {``The string which is a symbol's name is returned +- by @b{symbol-name}.''} ++ ``The string which is a symbol's name is returned ++ by @b{symbol-name}.'' + 4. @i{n.} (of a @i{pathname}) + a. the name component, returned by @b{pathname-name}. + b. the entire namestring, returned by @b{namestring}. +@@ -3612,16 +3618,16 @@ + by the @i{implementation}, + or by user code (see the @i{macro} @b{defconstant}) + to always @i{yield} the same @i{value} when @i{evaluated}. +- {``The value of a named constant may not be changed +- by assignment or by binding.''} ++ ``The value of a named constant may not be changed ++ by assignment or by binding.'' + + @IGindex{namespace} + @item @b{namespace} + @i{n.} + 1. @i{bindings} whose denotations are restricted to a particular kind. +- {``The bindings of names to tags is the tag namespace.''} ++ ``The bindings of names to tags is the tag namespace.'' + 2. any @i{mapping} whose domain is a set of @i{names}. +- {``A package defines a namespace.''} ++ ``A package defines a namespace.'' + + @IGindex{namestring} + @item @b{namestring} +@@ -3710,8 +3716,8 @@ + @i{n.} + a transfer of control (and sometimes @i{values}) to + an @i{exit point} for reasons other than a @i{normal return}. +- {``The operators @b{go}, @b{throw}, +- and @b{return-from} cause a non-local exit.''} ++ ``The operators @b{go}, @b{throw}, ++ and @b{return-from} cause a non-local exit.'' + + @IGindex{non-nil} + @item @b{non-nil} +@@ -3755,7 +3761,7 @@ + @IGindex{normalized} + @item @b{normalized} + @i{adj.}, @i{ANSI}, @i{IEEE} (of a @i{float}) +- conforming to the description of ``normalized'' as described by {IEEE Standard for Binary Floating-Point Arithmetic}. ++ conforming to the description of ``normalized'' as described by @i{IEEE Standard for Binary Floating-Point Arithmetic}. + See @i{denormalized}. + + @IGindex{null} +@@ -3803,24 +3809,24 @@ + @item @b{object} + @i{n.} + 1. any Lisp datum. +- {``The function @b{cons} creates an object which refers +- to two other objects.''} ++ ``The function @b{cons} creates an object which refers ++ to two other objects.'' + 2. (immediately following the name of a @i{type}) + an @i{object} which is of that @i{type}, used to emphasize that the + @i{object} is not just a @i{name} for an object of that @i{type} + but really an @i{element} of the @i{type} in cases where @i{objects} + of that @i{type} (such as @b{function} or @b{class}) are commonly + referred to by @i{name}. +- {``The function @b{symbol-function} takes a function name +- and returns a function object.''} ++ ``The function @b{symbol-function} takes a function name ++ and returns a function object.'' + + @IGindex{object-traversing} + @item @b{object-traversing} + @i{adj.} + operating in succession on components of an @i{object}. +- {``The operators @b{mapcar}, @b{maphash}, ++ ``The operators @b{mapcar}, @b{maphash}, + @b{with-package-iterator} and @b{count} +- perform object-traversing operations.''} ++ perform object-traversing operations.'' + + @IGindex{open} + @item @b{open} +@@ -3878,7 +3884,7 @@ + @i{n.} + the kind of @i{lambda list} used by @b{lambda}. + See @i{modified lambda list} and @i{extended lambda list}. +- {``@b{defun} uses an ordinary lambda list.''} ++ ``@b{defun} uses an ordinary lambda list.'' + + @IGindex{otherwise inaccessible part} + @item @b{otherwise inaccessible part} +@@ -3957,10 +3963,10 @@ + @item @b{pairwise} + @i{adv.} (of an adjective on a set) + applying individually to all possible pairings of elements of the set. +- {``The types A, B, and C are pairwise disjoint if ++ ``The types A, B, and C are pairwise disjoint if + A and B are disjoint, + B and C are disjoint, and +- A and C are disjoint.''} ++ A and C are disjoint.'' + + @IGindex{parallel} + @item @b{parallel} +@@ -3988,8 +3994,8 @@ + due to a prefix notation within the @i{format string} at the + @i{format directive}'s point of use. + See @ref{Formatted Output}. +- {``In @t{"~3,'0D"}, the number @t{3} and the character +- @t{#\0} are parameters to the @t{~D} format directive.''} ++ ``In @t{"~3,'0D"}, the number @t{3} and the character ++ @t{#\0} are parameters to the @t{~D} format directive.'' + + @IGindex{parameter specializer} + @item @b{parameter specializer} +@@ -4150,8 +4156,8 @@ + @i{n.} (of @i{values} resulting from the + @i{evaluation} of a @i{form}) + the first @i{value}, if any, or else @b{nil} if there are no @i{values}. +- {``The primary value returned by @b{truncate} is an +- integer quotient, truncated toward zero.''} ++ ``The primary value returned by @b{truncate} is an ++ integer quotient, truncated toward zero.'' + + @IGindex{principal} + @item @b{principal} +@@ -4501,8 +4507,8 @@ + 2. (of a @i{pathname}) + representing a position in a directory hierarchy by motion + from a position other than the root, which might therefore vary. +- {``The notation @t{#P"../foo.text"} denotes a relative +- pathname if the host file system is Unix.''} ++ ``The notation @t{#P"../foo.text"} denotes a relative ++ pathname if the host file system is Unix.'' + See @i{absolute}. + + @IGindex{repertoire} +@@ -4563,6 +4569,7 @@ + as the @i{restart} which it invokes. Figure 26--4 shows a list of the + @i{standardized} @i{restart functions}. + ++@format + @group + @noindent + @w{ abort muffle-warning use-value } +@@ -4572,6 +4579,7 @@ + @w{ Figure 26--4: Standardized Restart Functions} + + @end group ++@end format + + @IGindex{return} + @item @b{return} +@@ -4646,8 +4654,8 @@ + @i{adj.} + 1. (of @i{objects} under a specified @i{predicate}) + indistinguishable by that @i{predicate}. +- {``The symbol @t{car}, the string @t{"car"}, and the string @t{"CAR"} +- are the @t{same} under @b{string-equal}''}. ++ ``The symbol @t{car}, the string @t{"car"}, and the string @t{"CAR"} ++ are the @t{same} under @b{string-equal}''. + 2. (of @i{objects} if no predicate is implied by context) + indistinguishable by @b{eql}. + Note that @b{eq} might be capable of distinguishing some +@@ -4656,13 +4664,13 @@ + is @i{implementation-dependent}. + Since @b{eq} is used only rarely in this specification, + @b{eql} is the default predicate when none is mentioned explicitly. +- {``The conses returned by two successive calls to @b{cons} +- are never the same.''} ++ ``The conses returned by two successive calls to @b{cons} ++ are never the same.'' + 3. (of @i{types}) having the same set of @i{elements}; + that is, each @i{type} is a @i{subtype} of the others. +- {``The types specified by @t{(integer 0 1)}, ++ ``The types specified by @t{(integer 0 1)}, + @t{(unsigned-byte 1)}, +- and @t{bit} are the same.''} ++ and @t{bit} are the same.'' + + @IGindex{satisfy the test} + @item @b{satisfy the test} +@@ -4711,7 +4719,7 @@ + @i{evaluation} of a @i{form}) + the second @i{value}, if any, + or else @b{nil} if there are fewer than two @i{values}. +- {``The secondary value returned by @b{truncate} is a remainder.''} ++ ``The secondary value returned by @b{truncate} is a remainder.'' + + @IGindex{section} + @item @b{section} +@@ -4726,7 +4734,7 @@ + @i{cons}. + If a @i{self-evaluating object} is @i{evaluated}, + it @i{yields} itself as its only @i{value}. +- {``Strings are self-evaluating objects.''} ++ ``Strings are self-evaluating objects.'' + + @IGindex{semi-standard} + @item @b{semi-standard} +@@ -4822,13 +4830,13 @@ + @item @b{shadow} + @i{v.t.} + 1. to override the meaning of. +- {``That binding of @t{X} shadows an outer one.''} ++ ``That binding of @t{X} shadows an outer one.'' + 2. to hide the presence of. +- {``That @b{macrolet} of @t{F} shadows the +- outer @b{flet} of @t{F}.''} ++ ``That @b{macrolet} of @t{F} shadows the ++ outer @b{flet} of @t{F}.'' + 3. to replace. +- {``That package shadows the symbol @t{cl:car} with +- its own symbol @t{car}.''} ++ ``That package shadows the symbol @t{cl:car} with ++ its own symbol @t{car}.'' + + @IGindex{shadowing symbol} + @item @b{shadowing symbol} +@@ -4981,7 +4989,7 @@ + @item @b{singleton} + @i{adj.} (of a @i{sequence}) + having only one @i{element}. +- {``@t{(list 'hello)} returns a singleton list.''} ++ ``@t{(list 'hello)} returns a singleton list.'' + + @IGindex{situation} + @item @b{situation} +@@ -5067,8 +5075,8 @@ + having an @i{actual array element type} + that is a @i{proper subtype} of the @i{type} @b{t}; + see @ref{Array Elements}. +- {``@t{(make-array 5 :element-type 'bit)} makes an array of length +- five that is specialized for bits.''} ++ ``@t{(make-array 5 :element-type 'bit)} makes an array of length ++ five that is specialized for bits.'' + + @IGindex{specialized lambda list} + @item @b{specialized lambda list} +@@ -5086,8 +5094,8 @@ + whose last element is a @i{list} L2 of length m + (denoting a list L3 of length m+n-1 whose @i{elements} are + L1_i for i < n-1 followed by L2_j for j < m). +- {``The list (1 2 (3 4 5)) is a spreadable argument list designator for +- the list (1 2 3 4 5).''} ++ ``The list (1 2 (3 4 5)) is a spreadable argument list designator for ++ the list (1 2 3 4 5).'' + + @IGindex{stack allocate} + @item @b{stack allocate} +@@ -5190,8 +5198,8 @@ + @item @b{standardized} + @i{adj.} (of a @i{name}, @i{object}, or definition) + having been defined by @r{Common Lisp}. +- {``All standardized variables that are required to +- hold bidirectional streams have ``@t{-io*}'' in their name.''} ++ ``All standardized variables that are required to ++ hold bidirectional streams have ``@t{-io*}'' in their name.'' + + @IGindex{startup environment} + @item @b{startup environment} +@@ -5341,8 +5349,8 @@ + an @i{expression} that is a @i{subexpression} of the @i{form}, + and which by virtue of its position in that @i{form} is also a + @i{form}. +- {``@t{(f x)} and @t{x}, but not @t{exit}, are subforms of +- @t{(return-from exit (f x))}.''} ++ ``@t{(f x)} and @t{x}, but not @t{exit}, are subforms of ++ @t{(return-from exit (f x))}.'' + + @IGindex{subrepertoire} + @item @b{subrepertoire} +@@ -5465,15 +5473,15 @@ + an @i{object} that is the @i{same} as either some @i{cons} + which makes up that @i{list} or the @i{atom} (if any) which terminates + the @i{list}. +- {``The empty list is a tail of every proper list.''} ++ ``The empty list is a tail of every proper list.'' + + @IGindex{target} + @item @b{target} + @i{n.} + 1. (of a @i{constructed stream}) + a @i{constituent} of the @i{constructed stream}. +- {``The target of a synonym stream is +- the value of its synonym stream symbol.''} ++ ``The target of a synonym stream is ++ the value of its synonym stream symbol.'' + 2. (of a @i{displaced array}) + the @i{array} to which the @i{displaced array} is displaced. + (In the case of a chain of @i{constructed streams} or @i{displaced arrays}, +@@ -5611,7 +5619,7 @@ + @i{S_a} is a @i{subtype} of @i{S_b}.) + 2. (immediately following the name of a @i{type}) + a @i{subtype} of that @i{type}. +- {``The type @b{vector} is an array type.''} ++ ``The type @b{vector} is an array type.'' + + @IGindex{type declaration} + @item @b{type declaration} +@@ -5641,9 +5649,9 @@ + @item @b{type specifier} + @i{n.} + an @i{expression} that denotes a @i{type}. +- {``The symbol @t{random-state}, the list @t{(integer 3 5)}, ++ ``The symbol @t{random-state}, the list @t{(integer 3 5)}, + the list @t{(and list (not null))}, and the class named +- @t{standard-class} are type specifiers.''} ++ @t{standard-class} are type specifiers.'' + + @end table + @subheading @b{U} +@@ -5765,7 +5773,7 @@ + the @i{external symbols} of P_1 + become @i{internal symbols} of P_2 + unless they are explicitly @i{exported}.) +- {``The package @t{CL-USER} uses the package @t{CL}.''} ++ ``The package @t{CL-USER} uses the package @t{CL}.'' + + @IGindex{use list} + @item @b{use list} +@@ -5808,9 +5816,9 @@ + the phrase ``a @i{list} of @i{valid array indices}'' further implies + that the @i{length} of the @i{list} must be the same as the + @i{rank} of the @i{array}.) +- {``For a @t{2} by~@t{3} array, ++ ``For a @t{2} by~@t{3} array, + valid array indices for the first dimension are @t{0} and~@t{1}, and +- valid array indices for the second dimension are @t{0}, @t{1} and~@t{2}.''} ++ valid array indices for the second dimension are @t{0}, @t{1} and~@t{2}.'' + + @IGindex{valid array row-major index} + @item @b{valid array row-major index} +@@ -6018,7 +6026,7 @@ + @item @b{yield} + @i{v.t.} (@i{values}) + to produce the @i{values} as the result of @i{evaluation}. +- {``The form @t{(+ 2 3)} yields @t{5}.''} ++ ``The form @t{(+ 2 3)} yields @t{5}.'' + + @end table + +diff -uNr gcl-texi-orig/chap-2.texi gcl-texi/chap-2.texi +--- gcl-texi-orig/chap-2.texi 1994-07-16 18:03:22 +0400 ++++ gcl-texi/chap-2.texi 2002-10-17 20:53:05 +0400 +@@ -48,6 +48,7 @@ + Figure 2--1 lists some @i{defined names} that are applicable to + @i{readtables}. + ++@format + @group + @noindent + @w{ *readtable* readtable-case } +@@ -60,6 +61,7 @@ + @w{ Figure 2--1: Readtable defined names } + + @end group ++@end format + + @menu + * The Current Readtable:: +@@ -115,6 +117,7 @@ + but also by various @i{dynamic variables}. Figure 2--2 lists + the @i{variables} that influence the behavior of the @i{Lisp reader}. + ++@format + @group + @noindent + @w{ *package* *read-default-float-format* *readtable* } +@@ -124,6 +127,7 @@ + @w{ Figure 2--2: Variables that influence the Lisp reader. } + + @end group ++@end format + + @node Standard Characters, Character Syntax Types, Variables that affect the Lisp Reader, Character Syntax + @subsection Standard Characters +@@ -140,6 +144,7 @@ + and the following additional + ninety-four @i{graphic} @i{characters} or their equivalents: + ++@format + @group + @noindent + @w{ Graphic ID Glyph Description Graphic ID Glyph Description } +@@ -174,7 +179,9 @@ + @w{ Figure 2--3: Standard Character Subrepertoire (Part 1 of 3: Latin Characters)} + + @end group ++@end format + ++@format + @group + @noindent + @w{ Graphic ID Glyph Description Graphic ID Glyph Description } +@@ -188,7 +195,9 @@ + @w{ Figure 2--4: Standard Character Subrepertoire (Part 2 of 3: Numeric Characters)} + + @end group ++@end format + ++@format + @group + @noindent + @w{ Graphic ID Glyph Description } +@@ -229,9 +238,10 @@ + @w{ Figure 2--5: Standard Character Subrepertoire (Part 3 of 3: Special Characters)} + + @end group ++@end format + + The graphic IDs are not used within @r{Common Lisp}, +-but are provided for cross reference purposes with {@r{ISO 6937/2}}. ++but are provided for cross reference purposes with @r{ISO 6937/2}. + Note that the first letter of the graphic ID + categorizes the character as follows: + L---Latin, N---Numeric, S---Special. +@@ -256,6 +266,7 @@ + Every @i{character} that can appear in the @i{input} @i{stream} + is of one of the @i{syntax types} shown in @i{Figure~2--6}. + ++@format + @group + @noindent + @w{ @i{constituent} @i{macro character} @i{single escape} } +@@ -265,6 +276,7 @@ + @w{ Figure 2--6: Possible Character Syntax Types } + + @end group ++@end format + + The @i{syntax type} of a @i{character} in a @i{readtable} + determines how that character is interpreted by the @i{Lisp reader} +@@ -274,8 +286,9 @@ + @i{Figure~2--7} + lists the @i{syntax type} of each @i{character} in @i{standard syntax}. + +-{ + ++ ++@format + @group + @noindent + @w{ character syntax type character syntax type } +@@ -306,7 +319,8 @@ + @w{ Figure 2--7: Character Syntax Types in Standard Syntax } + + @end group +-} ++@end format ++ + + The characters marked with an asterisk (*) are initially @i{constituents}, + but they are not used in any standard @r{Common Lisp} notations. +@@ -381,6 +395,7 @@ + Any @i{character} quoted by a @i{single escape} + is treated as an @i{alphabetic}_2 constituent, regardless of its normal syntax. + ++@format + @group + @noindent + @w{ constituent traits constituent traits } +@@ -421,6 +436,7 @@ + @w{ @t{|} @i{alphabetic}_2* Rubout @i{invalid} } + @w{ @t{~} @i{alphabetic}_2 } + @end group ++@end format + + @w{ Figure 2--8: Constituent Traits of Standard Characters and Semi-Standard Characters} + +@@ -799,13 +815,14 @@ + The @i{token} is interpreted as a @i{number} if it satisfies + the syntax for numbers specified in Figure 2--9. + ++@format + @group + @noindent + @w{ @i{numeric-token} ::= !@i{integer} | !@i{ratio} | !@i{float} } + @w{ @i{integer} ::= @t{[}@i{sign}@t{]} @{@i{decimal-digit}@}^+ @i{decimal-point} | @t{[}@i{sign}@t{]} @{@i{digit}@}^+ } + @w{ @i{ratio} ::= @t{[}@i{sign}@t{]} @{@i{digit}@}^+ @i{slash} @{@i{digit}@}^+ } +-@w{ @i{float} ::= @t{[}@i{sign}@t{]} @{@i{decimal-digit}@}{*} @i{decimal-point} @{@i{decimal-digit}@}^+ @t{[}!@i{exponent}@t{]} } +-@w{ | @t{[}@i{sign}@t{]} @{@i{decimal-digit}@}^+ @t{[}@i{decimal-point} @{@i{decimal-digit}@}{*}@t{]} !@i{exponent} } ++@w{ @i{float} ::= @t{[}@i{sign}@t{]} @{@i{decimal-digit}@}* @i{decimal-point} @{@i{decimal-digit}@}^+ @t{[}!@i{exponent}@t{]} } ++@w{ | @t{[}@i{sign}@t{]} @{@i{decimal-digit}@}^+ @t{[}@i{decimal-point} @{@i{decimal-digit}@}*@t{]} !@i{exponent} } + @w{ @i{exponent} ::= @i{exponent-marker} @t{[}@i{sign}@t{]} @{@i{digit}@}^+ } + @w{ @i{sign}---a @i{sign}.} + @w{ @i{slash}---a @i{slash}} +@@ -814,6 +831,7 @@ + @w{ @i{decimal-digit}---a @i{digit} in @i{radix} @t{10}.} + @w{ @i{digit}---a @i{digit} in the @i{current input radix}.} + @end group ++@end format + + @w{ Figure 2--9: Syntax for Numeric Tokens} + +@@ -863,7 +881,7 @@ + The syntax involving a leading + @i{package marker} followed by a @i{potential number} is + not well-defined. The consequences of the use +-of notation such as @t{:1}, @t{:1/2}, and @t{:2{@t{^}}3} in a ++of notation such as @t{:1}, @t{:1/2}, and @t{:2^3} in a + position where an expression appropriate for @b{read} + is expected are unspecified. + +@@ -916,42 +934,48 @@ + a @i{conforming implementation} is permitted, but not required, + to define their meaning. + ++@format + @group + @noindent + @w{ @t{1b5000} @t{777777q} @t{1.7J} @t{-3/4+6.7J} @t{12/25/83} } +-@w{ @t{27{@t{^}}19} @t{3{@t{^}}4/5} @t{6//7} @t{3.1.2.6} @t{{@t{^}}-43@t{^}} } ++@w{ @t{27^19} @t{3^4/5} @t{6//7} @t{3.1.2.6} @t{@t{^}-43@t{^}} } + @w{ @t{3.141_592_653_589_793_238_4} @t{-3.7+2.6i-6.17j+19.6k} } + + @noindent + @w{ Figure 2--10: Examples of reserved tokens } + + @end group ++@end format + + The @i{tokens} in Figure 2--11 are not @i{potential numbers}; + they are always treated as @i{symbols}: + ++@format + @group + @noindent + @w{ @t{/} @t{/5} @t{+} @t{1+} @t{1-} } +-@w{ @t{foo+} @t{ab.cd} @t{_} @t{@t{^}} @t{{@t{^}}/-} } ++@w{ @t{foo+} @t{ab.cd} @t{_} @t{@t{^}} @t{@t{^}/-} } + + @noindent + @w{ Figure 2--11: Examples of symbols} + + @end group ++@end format + + The @i{tokens} in Figure 2--12 are @i{potential numbers} + if the @i{current input base} is @t{16}, + but they are always treated as @i{symbols} if the @i{current input base} is @t{10}. + ++@format + @group + @noindent +-@w{ @t{bad-face} @t{25-dec-83} @t{a/b} @t{fad_cafe} @t{f{@t{^}}} } ++@w{ @t{bad-face} @t{25-dec-83} @t{a/b} @t{fad_cafe} @t{f@t{^}} } + + @noindent + @w{ Figure 2--12: Examples of symbols or potential numbers} + + @end group ++@end format + + @node Constructing Numbers from Tokens, The Consing Dot, Numbers as Tokens, Interpretation of Tokens + @subsection Constructing Numbers from Tokens +@@ -1005,12 +1029,13 @@ + entirely of zeros. + Examples of @i{ratios} are in Figure 2--13. + ++@format + @group + @noindent + @w{ @t{2/3} ;This is in canonical form } + @w{ @t{4/6} ;A non-canonical form for 2/3 } + @w{ @t{-17/23} ;A ratio preceded by a sign } +-@w{ @t{-30517578125/32768} ;This is (-5/2)^{15} } ++@w{ @t{-30517578125/32768} ;This is (-5/2)^15 } + @w{ @t{10/5} ;The canonical form for this is @t{2} } + @w{ @t{#o-101/75} ;Octal notation for -65/61 } + @w{ @t{#3r120/21} ;Ternary notation for 15/7 } +@@ -1021,6 +1046,7 @@ + @w{ Figure 2--13: Examples of Ratios } + + @end group ++@end format + + [Reviewer Note by Barmar: #o, #3r, #X, and #x mentioned above + are not in the syntax rules defined just above that.] +@@ -1059,6 +1085,7 @@ + + Figure 2--14 contains examples of notations for @i{floats}: + ++@format + @group + @noindent + @w{ @t{0.0} ;Floating-point zero in default format } +@@ -1084,6 +1111,7 @@ + @w{ Figure 2--14: Examples of Floating-point numbers } + + @end group ++@end format + + For information on how @i{floats} are printed, + see @ref{Printing Floats}. +@@ -1140,6 +1168,7 @@ + these examples assume that + the @i{readtable case} of the @i{current readtable} is @t{:upcase}. + ++@format + @group + @noindent + @w{ @t{FROBBOZ} The @i{symbol} whose @i{name} is @t{FROBBOZ}. } +@@ -1163,30 +1192,33 @@ + @w{ Figure 2--15: Examples of the printed representation of symbols (Part 1 of 2)} + + @end group ++@end format + ++@format + @group + @noindent + @w{ @t{APL\\360} The @i{symbol} whose @i{name} is @t{APL\360}. } + @w{ @t{apl\\360} Also the @i{symbol} whose @i{name} is @t{APL\360}. } +-@w{ @t{\(b{@t{^}}2\)\ -\ 4*a@t{*c}} The @i{name} is @t{(B{@t{^}}2) - 4*A*C}. } ++@w{ @t{\(b@t{^}2\)\ -\ 4*a@t{*c}} The @i{name} is @t{(B@t{^}2) - 4*A*C}. } + @w{ Parentheses and two spaces in it. } +-@w{ @t{\(\b{@t{^}}2\)\ -\4*\a*\c} The @i{name} is @t{(b{@t{^}}2) - 4*a*c}. } ++@w{ @t{\(\b@t{^}2\)\ -\4*\a*\c} The @i{name} is @t{(b@t{^}2) - 4*a*c}. } + @w{ Letters explicitly lowercase. } + @w{ @t{|"|} The same as writing @t{\"}. } +-@w{ @t{|(b{@t{^}}2) - 4*a*c|} The @i{name} is @t{(b{@t{^}}2) - 4*a*c}. } ++@w{ @t{|(b@t{^}2) - 4*a*c|} The @i{name} is @t{(b@t{^}2) - 4*a*c}. } + @w{ @t{|frobboz|} The @i{name} is @t{frobboz}, not @t{FROBBOZ}. } + @w{ @t{|APL\360|} The @i{name} is @t{APL360}. } + @w{ @t{|APL\\360|} The @i{name} is @t{APL\360}. } + @w{ @t{|apl\\360|} The @i{name} is @t{apl\360}. } + @w{ @t{|\|\||} Same as @t{\|\|} ---the @i{name} is @t{||}. } +-@w{ @t{|(B{@t{^}}2) - 4*A*C|} The @i{name} is @t{(B{@t{^}}2) - 4*A*C}. } ++@w{ @t{|(B@t{^}2) - 4*A*C|} The @i{name} is @t{(B@t{^}2) - 4*A*C}. } + @w{ Parentheses and two spaces in it. } +-@w{ @t{|(b{@t{^}}2) - 4*a*c|} The @i{name} is @t{(b{@t{^}}2) - 4*a*c}. } ++@w{ @t{|(b@t{^}2) - 4*a*c|} The @i{name} is @t{(b@t{^}2) - 4*a*c}. } + + @noindent + @w{ Figure 2--16: Examples of the printed representation of symbols (Part 2 of 2)} + + @end group ++@end format + + In the process of parsing a @i{symbol}, + it is @i{implementation-dependent} which +@@ -1214,6 +1246,7 @@ + + The valid patterns for @i{tokens} are summarized in Figure 2--17. + ++@format + @group + @noindent + @w{ @t{@i{nnnnn}} a @i{number} } +@@ -1232,6 +1265,7 @@ + @w{ Figure 2--17: Valid patterns for tokens } + + @end group ++@end format + + Note that @i{nnnnn} has number syntax, + neither @i{xxxxx} nor @i{ppppp} has number syntax, +@@ -1591,6 +1625,7 @@ + + Examples of the use of the @i{double-quote} character are in Figure 2--18. + ++@format + @group + @noindent + @w{ @t{"Foo"} ;A string with three characters in it } +@@ -1602,6 +1637,7 @@ + @w{ Figure 2--18: Examples of the use of double-quote } + + @end group ++@end format + + Note that to place a single escape character or a @i{double-quote} into a string, + such a character must be preceded by a single escape character. +@@ -1670,7 +1706,7 @@ + may be interpreted to mean + + @example +- (append {[} x1{]} {[} x2{]} {[} x3{]} ... {[} xn{]} (quote atom)) ++ (append [ x1 ] [ x2 ] [ x3 ] ... [ xn ] (quote atom)) + @end example + + where the brackets are used to indicate +@@ -1699,7 +1735,7 @@ + @t{`(x1 x2 x3 ... xn . ,form)} may be interpreted to mean + + @example +- (append {[} x1{]} {[} x2{]} {[} x3{]} ... {[} xn{]} form) ++ (append [ x1 ] [ x2 ] [ x3 ] ... [ xn ] form) + @end example + + where the brackets indicate a transformation of an @t{xj} as described above. +@@ -1769,7 +1805,7 @@ + requirement. + + Implementors who have no particular reason to make one choice or another +-might wish to refer to {IEEE Standard for the Scheme Programming Language}, which identifies a popular choice of ++might wish to refer to @b{IEEE Standard for the Scheme Programming Language}, which identifies a popular choice of + representation for such expressions that might provide useful to be useful + compatibility for some user communities. There is no requirement, however, + that any @i{conforming implementation} use this particular representation. +@@ -1804,8 +1840,9 @@ + The @i{reader macros} associated with the @i{dispatching macro character} @t{#} + are described later in this section and summarized in Figure 2--19. + +-{ + ++ ++@format + @group + @noindent + @w{ dispatch char purpose dispatch char purpose } +@@ -1837,7 +1874,7 @@ + @w{ [ undefined* T, t undefined } + @w{ @t{\} character object U, u undefined } + @w{ ] undefined* V, v undefined } +-@w{ {@t{^}} undefined W, w undefined } ++@w{ @t{^} undefined W, w undefined } + @w{ @t{_} undefined X, x hexadecimal rational } + @w{ ` undefined Y, y undefined } + @w{ @t{|} balanced comment Z, z undefined } +@@ -1847,7 +1884,8 @@ + @w{ Figure 2--19: Standard # Dispatching Macro Character Syntax } + + @end group +-} ++@end format ++ + + The combinations marked by an asterisk (*) are explicitly reserved to the + user. No @i{conforming implementation} defines them. +@@ -2075,7 +2113,7 @@ + For example, + + @example +- #B1101 @equiv{} 13 ;1101{{}_2} ++ #B1101 @equiv{} 13 ;1101_2 + #b101/11 @equiv{} 5/3 + @end example + +@@ -2091,7 +2129,7 @@ + @example + #o37/15 @equiv{} 31/13 + #o777 @equiv{} 511 +- #o105 @equiv{} 69 ;105{{}_8} ++ #o105 @equiv{} 69 ;105_8 + @end example + + The consequences are undefined if the token immediately following +@@ -2106,7 +2144,7 @@ + + @example + #xF00 @equiv{} 3840 +- #x105 @equiv{} 261 ;105{{}_@{16@}} ++ #x105 @equiv{} 261 ;105_@t{16} + @end example + + The consequences are undefined if the token immediately following +@@ -2135,6 +2173,7 @@ + Figure 2--20 contains examples of the use of @t{#B}, + @t{#O}, @t{#X}, and @t{#R}. + ++@format + @group + @noindent + @w{ @t{#2r11010101} ;Another way of writing @t{213} decimal } +@@ -2152,6 +2191,7 @@ + @w{ Figure 2--20: Radix Indicator Example } + + @end group ++@end format + + The consequences are undefined if the token immediately following + the @t{#@i{n}R} does not have the syntax of a @i{rational} in radix @i{n}. +@@ -2176,6 +2216,7 @@ + + Figure 2--21 contains examples of the use of @t{#C}. + ++@format + @group + @noindent + @w{ @t{#C(3.0s1 2.0s-1)} ;A @i{complex} with @i{small float} parts. } +@@ -2187,6 +2228,7 @@ + @w{ Figure 2--21: Complex Number Example } + + @end group ++@end format + + For further information, + see @ref{Printing Complexes} and @ref{Syntax of a Complex}. +diff -uNr gcl-texi-orig/chap-3.texi gcl-texi/chap-3.texi +--- gcl-texi-orig/chap-3.texi 1994-07-16 18:03:21 +0400 ++++ gcl-texi/chap-3.texi 2002-10-17 20:58:11 +0400 +@@ -297,6 +297,7 @@ + Figure 3--1 lists some @i{defined names} that + are applicable to assigning, binding, and defining @i{variables}. + ++@format + @group + @noindent + @w{ boundp let progv } +@@ -309,6 +310,7 @@ + @w{ Figure 3--1: Some Defined Names Applicable to Variables} + + @end group ++@end format + + The following is a description of each kind of variable. + +@@ -469,6 +471,7 @@ + Figure 3--2 lists all of the @r{Common Lisp} @i{symbols} + that have definitions as @i{special operators}. + ++@format + @group + @noindent + @w{ block let* return-from } +@@ -485,6 +488,7 @@ + @w{ Figure 3--2: Common Lisp Special Operators } + + @end group ++@end format + + @node Macro Forms, Function Forms, Special Forms, The Evaluation Model + @subsubsection Macro Forms +@@ -526,6 +530,7 @@ + Figure 3--3 lists some @i{defined names} that are applicable + to @i{macros}. + ++@format + @group + @noindent + @w{ *macroexpand-hook* macro-function macroexpand-1 } +@@ -535,6 +540,7 @@ + @w{ Figure 3--3: Defined names applicable to macros } + + @end group ++@end format + + @node Function Forms, Lambda Forms, Macro Forms, The Evaluation Model + @subsubsection Function Forms +@@ -593,6 +599,7 @@ + + Figure 3--4 lists some @i{defined names} that are applicable to @i{functions}. + ++@format + @group + @noindent + @w{ apply fdefinition mapcan } +@@ -608,6 +615,7 @@ + @w{ Figure 3--4: Some function-related defined names } + + @end group ++@end format + + @node Lambda Forms, Self-Evaluating Objects, Function Forms, The Evaluation Model + @subsubsection Lambda Forms +@@ -837,15 +845,15 @@ + + @example + (contorted-example nil nil 2) +- (block here{{}_1} ...) +- (contorted-example nil #'(lambda () (return-from here{{}_1} 4)) 1) +- (block here{{}_2} ...) +- (contorted-example #'(lambda () (return-from here{{}_1} 4)) +- #'(lambda () (return-from here{{}_2} 4)) ++ (block here_1 ...) ++ (contorted-example nil #'(lambda () (return-from here_1 4)) 1) ++ (block here_2 ...) ++ (contorted-example #'(lambda () (return-from here_1 4)) ++ #'(lambda () (return-from here_2 4)) + 0) + (funcall f) +- where f @result{} #'(lambda () (return-from here{{}_1} 4)) +- (return-from here{{}_1} 4) ++ where f @result{} #'(lambda () (return-from here_1 4)) ++ (return-from here_1 4) + @end example + + At the time the @t{funcall} is executed +@@ -854,8 +862,8 @@ + The @b{return-from} @i{form} executed as a result of the @t{funcall} + operation + refers to the outer outstanding @i{exit point} +-(here{{}_1}), not the +-inner one (here{{}_2}). ++(here_1), not the ++inner one (here_2). + It + refers to that @i{exit point} textually visible at the point of + execution of @b{function} +@@ -867,8 +875,8 @@ + @t{(funcall g)}, then the value of the call @t{(contorted-example nil nil 2)} + would be @t{9}. The value would change because + @b{funcall} would cause the +-execution of @t{(return-from here{{}_2} 4)}, thereby causing +-a return from the inner @i{exit point} (here{{}_2}). ++execution of @t{(return-from here_2 4)}, thereby causing ++a return from the inner @i{exit point} (here_2). + When that occurs, the value @t{4} is returned from the + middle invocation of @t{contorted-example}, @t{5} is added to that + to get @t{9}, and that value is returned from the outer block +@@ -967,6 +975,7 @@ + one or more @i{forms} to @i{evaluate} + and where to put the @i{values} returned by those @i{forms}. + ++@format + @group + @noindent + @w{ multiple-value-bind multiple-value-prog1 return-from } +@@ -977,6 +986,7 @@ + @w{ Figure 3--5: Some operators applicable to receiving multiple values} + + @end group ++@end format + + The @i{function} @b{values} can produce @i{multiple values}_2. + @t{(values)} returns zero values; +@@ -1202,6 +1212,7 @@ + or else a form that can, at the discretion of the @i{code} doing the expansion, + be used in place of the original @i{form}. + ++@format + @group + @noindent + @w{ *macroexpand-hook* compiler-macro-function define-compiler-macro } +@@ -1210,6 +1221,7 @@ + @w{ Figure 3--6: Defined names applicable to compiler macros } + + @end group ++@end format + + @node Purpose of Compiler Macros, Naming of Compiler Macros, Compiler Macros, Compilation Semantics + @subsubsection Purpose of Compiler Macros +@@ -1573,6 +1585,7 @@ + + plus .5 fil + \offinterlineskip ++@format + @group + @noindent + @w{ @b{CT} @b{LT} @b{E} @b{Mode} @b{Action} @b{New Mode} } +@@ -1586,6 +1599,7 @@ + @w{ No No Yes NCT Discard --- } + @w{ No No No --- Discard --- } + @end group ++@end format + + @w{ Figure 3--7: EVAL-WHEN processing} + +@@ -1689,6 +1703,7 @@ + effects happen only when the defining macros appear at + top level. + ++@format + @group + @noindent + @w{ declaim define-modify-macro defsetf } +@@ -1701,6 +1716,7 @@ + @w{ Figure 3--8: Defining Macros That Affect the Compile-Time Environment} + + @end group ++@end format + + @node Constraints on Macros and Compiler Macros, , Processing of Defining Macros, File Compilation + @subsubsection Constraints on Macros and Compiler Macros +@@ -2225,6 +2241,7 @@ + + defined by this standard. + ++@format + @group + @noindent + @w{ declaration ignore special } +@@ -2236,6 +2253,7 @@ + @w{ Figure 3--9: Common Lisp Declaration Identifiers} + + @end group ++@end format + + An implementation is free to support other (@i{implementation-defined}) + @i{declaration identifiers} as well. +@@ -2254,8 +2272,8 @@ + @subsubsection Shorthand notation for Type Declarations + + A @i{type specifier} can be used as a @i{declaration identifier}. +-@t{(@i{type-specifier} @{@i{var}@}{*})} is taken as shorthand for +-@t{(type @i{type-specifier} @{@i{var}@}{*})}. ++@t{(@i{type-specifier} @{@i{var}@}*)} is taken as shorthand for ++@t{(type @i{type-specifier} @{@i{var}@}*)}. + + @node Declaration Scope, , Declaration Identifiers, Declarations + @subsection Declaration Scope +@@ -2424,6 +2442,7 @@ + + There are several kinds of @i{lambda lists}. + ++@format + @group + @noindent + @w{ Context Kind of Lambda List } +@@ -2452,10 +2471,12 @@ + @w{ Figure 3--10: What Kind of Lambda Lists to Use } + + @end group ++@end format + + Figure 3--11 lists some @i{defined names} that are applicable + to @i{lambda lists}. + ++@format + @group + @noindent + @w{ lambda-list-keywords lambda-parameters-limit } +@@ -2464,6 +2485,7 @@ + @w{ Figure 3--11: Defined names applicable to lambda lists} + + @end group ++@end format + + @menu + * Ordinary Lambda Lists:: +@@ -2489,6 +2511,7 @@ + The @i{defined names} in Figure 3--12 are those which use + @i{ordinary lambda lists}: + ++@format + @group + @noindent + @w{ define-method-combination handler-case restart-case } +@@ -2499,10 +2522,12 @@ + @w{ Figure 3--12: Standardized Operators that use Ordinary Lambda Lists} + + @end group ++@end format + + An @i{ordinary lambda list} can contain the @i{lambda list keywords} shown + in Figure 3--13. + ++@format + @group + @noindent + @w{ @b{&allow-other-keys} @b{&key} @b{&rest} } +@@ -2512,6 +2537,7 @@ + @w{ Figure 3--13: Lambda List Keywords used by Ordinary Lambda Lists} + + @end group ++@end format + + Each @i{element} of a @i{lambda list} is either a parameter specifier + or a @i{lambda list keyword}. +@@ -2521,15 +2547,15 @@ + + The syntax for @i{ordinary lambda lists} is as follows: + +-@w{@i{lambda-list} ::=@r{(}@{@i{var}@}{*}} +-@w{ @t{[}{&optional} @{@i{var} | +- @r{(}@i{var} @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}{*}@t{]}} +-@w{ @t{[}{&rest} @i{var}@t{]}} +-@w{ @t{[}{&key} @{@i{var} | ++@w{@i{lambda-list} ::=@r{(}@{@i{var}@}*} ++@w{ @t{[}@r{&optional} @{@i{var} | ++ @r{(}@i{var} @r{[}init-form @r{[}supplied-p-parameter @r{]}@r{]}@r{)}@}*@t{]}} ++@w{ @t{[}@r{&rest} @i{var}@t{]}} ++@w{ @t{[}@r{&key} @{@i{var} | + @r{(}@{@i{var} | + @r{(}@i{keyword-name} @i{var}@r{)}@} +- @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}{*} pt @r{[}@t{&allow-other-keys}@r{]}@t{]}} +-@w{ @t{[}{&aux} @{@i{var} | @r{(}@i{var} @r{[}@i{init-form}@r{]}@r{)}@}{*}@t{]}@r{)}} ++ @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}* pt @r{[}@t{&allow-other-keys}@r{]}@t{]}} ++@w{ @t{[}@r{&aux} @{@i{var} | @r{(}@i{var} @r{[}@i{init-form}@r{]}@r{)}@}*@t{]}@r{)}} + @w{ } + + A @i{var} or @i{supplied-p-parameter} must be a @i{symbol} +@@ -2759,7 +2785,7 @@ + These are not really parameters. If the @i{lambda list keyword} + @b{&aux} is present, all specifiers after it are auxiliary variable + specifiers. After all parameter specifiers have been processed, the +-auxiliary variable specifiers (those following {&aux}) are processed ++auxiliary variable specifiers (those following @b{&aux}) are processed + from left to right. For each one, @i{init-form} is evaluated and + @i{var} is bound to that value (or to @b{nil} if no @i{init-form} + was specified). @b{&aux} variable processing is analogous to +@@ -2876,16 +2902,17 @@ + + A @i{generic function lambda list} has the following syntax: + +-@w{@i{lambda-list} ::=@r{(}@{@i{var}@}{*}} +-@w{ @t{[}{&optional} @{@i{var} | @r{(}@i{var}@r{)}@}{*}@t{]}} +-@w{ @t{[}{&rest} @i{var}@t{]}} +-@w{ @t{[}{&key} @{@i{var} | @r{(}@{@i{var} | +- @r{(}@i{keyword-name} @i{var}@r{)}@}{)}@}{*} pt @r{[}@t{&allow-other-keys}@r{]}@t{]}@r{)}} ++@w{@i{lambda-list} ::=@r{(}@{@i{var}@}*} ++@w{ @t{[}@r{&optional} @{@i{var} | @r{(}@i{var}@r{)}@}*@t{]}} ++@w{ @t{[}@r{&rest} @i{var}@t{]}} ++@w{ @t{[}@r{&key} @{@i{var} | @r{(}@{@i{var} | ++ @r{(}@i{keyword-name} @i{var}@r{)}@}@r{)}@}* pt @r{[}@t{&allow-other-keys}@r{]}@t{]}@r{)}} + @w{ } + + A @i{generic function lambda list} can contain the @i{lambda list keywords} shown + in Figure 3--14. + ++@format + @group + @noindent + @w{ @b{&allow-other-keys} @b{&optional} } +@@ -2895,6 +2922,7 @@ + @w{ Figure 3--14: Lambda List Keywords used by Generic Function Lambda Lists} + + @end group ++@end format + + A @i{generic function lambda list} differs from an @i{ordinary lambda list} + in the following ways: +@@ -2923,6 +2951,7 @@ + The @i{defined names} in Figure 3--15 use @i{specialized lambda lists} + in some way; see the dictionary entry for each for information about how. + ++@format + @group + @noindent + @w{ defmethod defgeneric } +@@ -2931,10 +2960,12 @@ + @w{ Figure 3--15: Standardized Operators that use Specialized Lambda Lists} + + @end group ++@end format + + A @i{specialized lambda list} can contain the @i{lambda list keywords} shown + in Figure 3--16. + ++@format + @group + @noindent + @w{ @b{&allow-other-keys} @b{&key} @b{&rest} } +@@ -2944,20 +2975,21 @@ + @w{ Figure 3--16: Lambda List Keywords used by Specialized Lambda Lists} + + @end group ++@end format + + A @i{specialized lambda list} is syntactically the same as an @i{ordinary lambda list} + except that each @i{required parameter} may optionally be associated with a @i{class} + or @i{object} for which that @i{parameter} is @i{specialized}. + +-@w{@i{lambda-list} ::=@r{(}@{@i{var} | @r{(}@i{var} @r{[}@i{specializer}@r{]}@r{)}@}{*}} +-@w{ @t{[}{&optional} @{@i{var} | +- @r{(}@i{var} @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}{*}@t{]}} +-@w{ @t{[}{&rest} @i{var}@t{]}} +-@w{ @t{[}{&key} @{@i{var} | ++@w{@i{lambda-list} ::=@r{(}@{@i{var} | @r{(}@i{var} @r{[}@i{specializer}@r{]}@r{)}@}*} ++@w{ @t{[}@r{&optional} @{@i{var} | ++ @r{(}@i{var} @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}*@t{]}} ++@w{ @t{[}@r{&rest} @i{var}@t{]}} ++@w{ @t{[}@r{&key} @{@i{var} | + @r{(}@{@i{var} | + @r{(}@i{keyword-name} @i{var}@r{)}@} +- @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}{*} @r{[}@t{&allow-other-keys}@r{]}@t{]}} +-@w{ @t{[}{&aux} @{@i{var} | @r{(}@i{var} @r{[}@i{init-form}@r{]}@r{)}@}{*}@t{]}@r{)}} ++ @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}* @r{[}@t{&allow-other-keys}@r{]}@t{]}} ++@w{ @t{[}@r{&aux} @{@i{var} | @r{(}@i{var} @r{[}@i{init-form}@r{]}@r{)}@}*@t{]}@r{)}} + @w{ } + + @node Macro Lambda Lists, Destructuring Lambda Lists, Specialized Lambda Lists, Lambda Lists +@@ -2968,6 +3000,7 @@ + is used in describing @i{macros} + defined by the @i{operators} in Figure 3--17. + ++@format + @group + @noindent + @w{ define-compiler-macro defmacro macrolet } +@@ -2977,32 +3010,33 @@ + @w{ Figure 3--17: Operators that use Macro Lambda Lists} + + @end group ++@end format + + With the additional restriction that + an @i{environment parameter} may appear only once + (at any of the positions indicated), + a @i{macro lambda list} has the following syntax: + +-{ +-@w{@i{reqvars} ::=@{@i{var} | !@i{pattern}@}{*}} + +-@w{@i{optvars} ::=@t{[}{&optional} @{@i{var} | +- @r{(}{@{@i{var} | !@i{pattern}@}} @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}{*}@t{]}} ++@w{@i{reqvars} ::=@{@i{var} | !@i{pattern}@}*} + +-@w{@i{restvar} ::=@t{[}@{{@t{&rest}} | {&body}@} @i{@{@i{var} | !@i{pattern}@}}@t{]}} ++@w{@i{optvars} ::=@t{[}@r{&optional} @{@i{var} | ++ @r{(}@r{@{@i{var} | !@i{pattern}@}} @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}*@t{]}} + +-@w{@i{keyvars} ::=@r{[}{&key} @{@i{var} | ++@w{@i{restvar} ::=@t{[}@{@t{&rest} | @r{&body}@} @i{@{@i{var} | !@i{pattern}@}}@t{]}} ++ ++@w{@i{keyvars} ::=@r{[}@r{&key} @{@i{var} | + @r{(}@{@i{var} | +- @r{(}@i{keyword-name} {@{@i{var} | !@i{pattern}@}}@r{)}@} +- @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}{*}} ++ @r{(}@i{keyword-name} @{@i{var} | !@i{pattern}@}@r{)}@} ++ @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}*} + @w{ @r{[}@t{&allow-other-keys}@r{]}@r{]}} + +-{ +-@w{@i{auxvars} ::=@t{[}{&aux} @{@i{var} | @r{(}{@i{var}} @r{[}@i{init-form}@r{]}@r{)}@}{*}@t{]}} +-} +-@w{@i{envvar} ::=@t{[}{&environment} @i{var}@t{]}} + +-@w{@i{wholevar} ::=@t{[}{&whole} @i{var}@t{]}} ++@w{@i{auxvars} ::=@t{[}@r{&aux} @{@i{var} | @r{(}@r{@i{var}} @r{[}@i{init-form}@r{]}@r{)}@}*@t{]}} ++ ++@w{@i{envvar} ::=@t{[}@r{&environment} @i{var}@t{]}} ++ ++@w{@i{wholevar} ::=@t{[}@r{&whole} @i{var}@t{]}} + + @w{@i{lambda-list} ::=@r{(}!@i{wholevar} !@i{envvar} !@i{reqvars} !@i{envvar} !@i{optvars} !@i{envvar}} + @w{ !@i{restvar} !@i{envvar} !@i{keyvars} !@i{envvar} !@i{auxvars} !@i{envvar}@r{)} |} +@@ -3011,11 +3045,12 @@ + @w{@i{pattern} ::=@r{(}!@i{wholevar} !@i{reqvars} !@i{optvars} !@i{restvar} !@i{keyvars} !@i{auxvars}@r{)} |} + @w{ @r{(}!@i{wholevar} !@i{reqvars} !@i{optvars} @t{.} @i{var}@r{)}} + +-} ++ + + A @i{macro lambda list} can contain + the @i{lambda list keywords} shown in Figure 3--18. + ++@format + @group + @noindent + @w{ @b{&allow-other-keys} @b{&environment} @b{&rest} } +@@ -3026,6 +3061,7 @@ + @w{ Figure 3--18: Lambda List Keywords used by Macro Lambda Lists} + + @end group ++@end format + + @i{Optional parameters} (introduced by @b{&optional}) and + @i{keyword parameters} (introduced by @b{&key}) +@@ -3287,31 +3323,30 @@ + + A @i{destructuring lambda list} has the following syntax: + +-{ +-@w{@i{reqvars} ::=@{@i{var} | !@i{lambda-list}@}{*}} + +-@w{@i{optvars} ::=@t{[}{&optional} @{@i{var} | +- @r{(}{@{@i{var} | !@i{lambda-list}@}} @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}{*}@t{]}} ++@w{@i{reqvars} ::=@{@i{var} | !@i{lambda-list}@}*} + +-@w{@i{restvar} ::=@t{[}@{{@t{&rest}} | {&body}@} @i{@{@i{var} | !@i{lambda-list}@}}@t{]}} ++@w{@i{optvars} ::=@t{[}@r{&optional} @{@i{var} | ++ @r{(}@{@i{var} | !@i{lambda-list}@} @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}*@t{]}} + +-@w{@i{keyvars} ::=@r{[}{&key} @{@i{var} | ++@w{@i{restvar} ::=@t{[}@{@t{&rest}} | @t{&body}@} @i{@{@i{var} | !@i{lambda-list}@}@t{]}} ++ ++@w{@i{keyvars} ::=@r{[}@r{&key} @{@i{var} | + @r{(}@{@i{var} | +- @r{(}@i{keyword-name} {@{@i{var} | !@i{lambda-list}@}}@r{)}@} +- @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}{*}} ++ @r{(}@i{keyword-name} @{@i{var} | !@i{lambda-list}@}@r{)}@} ++ @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}*} + @w{ @r{[}@t{&allow-other-keys}@r{]}@r{]}} + +-{ +-@w{@i{auxvars} ::=@t{[}{&aux} @{@i{var} | @r{(}{@i{var}} @r{[}@i{init-form}@r{]}@r{)}@}{*}@t{]}} +-} +-@w{@i{envvar} ::=@t{[}{&environment} @i{var}@t{]}} + +-@w{@i{wholevar} ::=@t{[}{&whole} @i{var}@t{]}} ++@w{@i{auxvars} ::=@t{[}@r{&aux} @{@i{var} | @r{(}@i{var} @r{[}@i{init-form}@r{]}@r{)}@}*@t{]}} ++ ++@w{@i{envvar} ::=@t{[}@r{&environment} @i{var}@t{]}} ++ ++@w{@i{wholevar} ::=@t{[}@r{&whole} @i{var}@t{]}} + + @w{@i{lambda-list} ::=@r{(}!@i{wholevar} !@i{reqvars} !@i{optvars} !@i{restvar} !@i{keyvars} !@i{auxvars}@r{)} |} + @w{ @r{(}!@i{wholevar} !@i{reqvars} !@i{optvars} @t{.} @i{var}@r{)}} + +-} + + @node Boa Lambda Lists, Defsetf Lambda Lists, Destructuring Lambda Lists, Lambda Lists + @subsection Boa Lambda Lists +@@ -3432,19 +3467,20 @@ + + A @i{defsetf lambda list} has the following syntax: + +-@w{@i{lambda-list} ::=@r{(}@{@i{var}@}{*}} +-@w{ @t{[}{&optional} @{@i{var} | +- @r{(}@i{var} @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}{*}@t{]}} +-@w{ @t{[}{&rest} @i{var}@t{]}} +-@w{ @t{[}{&key} @{@i{var} | ++@w{@i{lambda-list} ::=@r{(}@{@i{var}@}*} ++@w{ @t{[}@r{&optional} @{@i{var} | ++ @r{(}@i{var} @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}*@t{]}} ++@w{ @t{[}@r{&rest} @i{var}@t{]}} ++@w{ @t{[}@r{&key} @{@i{var} | + @r{(}@{@i{var} | + @r{(}@i{keyword-name} @i{var}@r{)}@} +- @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}{*} pt @r{[}@t{&allow-other-keys}@r{]}@t{]}} +-@w{ @t{[}{&environment} @i{var}@t{]}} ++ @r{[}init-form @r{[}supplied-p-parameter@r{]}@r{]}@r{)}@}* pt @r{[}@t{&allow-other-keys}@r{]}@t{]}} ++@w{ @t{[}@r{&environment} @i{var}@t{]}} + + A @i{defsetf lambda list} can contain the @i{lambda list keywords} shown + in Figure 3--19. + ++@format + @group + @noindent + @w{ @b{&allow-other-keys} @b{&key} @b{&rest} } +@@ -3454,6 +3490,7 @@ + @w{ Figure 3--19: Lambda List Keywords used by Defsetf Lambda Lists} + + @end group ++@end format + + A @i{defsetf lambda list} differs from an @i{ordinary lambda list} + only in that it does not permit the use of @b{&aux}, +@@ -3486,6 +3523,7 @@ + A @i{define-modify-macro lambda list} can contain the + @i{lambda list keywords} shown in Figure 3--20. + ++@format + @group + @noindent + @w{ @b{&optional} @b{&rest} } +@@ -3494,6 +3532,7 @@ + @w{ Figure 3--20: Lambda List Keywords used by Define-modify-macro Lambda Lists} + + @end group ++@end format + + @i{Define-modify-macro lambda lists} are similar to + @i{ordinary lambda lists}, but do not support keyword arguments. +@@ -3513,6 +3552,7 @@ + A @i{define-method-combination arguments lambda list} can contain the + @i{lambda list keywords} shown in Figure 3--21. + ++@format + @group + @noindent + @w{ @b{&allow-other-keys} @b{&key} @b{&rest} } +@@ -3522,6 +3562,7 @@ + @w{ Figure 3--21: Lambda List Keywords used by Define-method-combination arguments Lambda Lists} + + @end group ++@end format + + @i{Define-method-combination arguments lambda lists} are similar to + @i{ordinary lambda lists}, but also permit the use of @b{&whole}. +@@ -3979,7 +4020,7 @@ + + @subsubheading Syntax:: + +-@code{lambda} @i{lambda-list {[[@{@i{declaration}@}{*} | @i{documentation}]]} @{@i{form}@}{*}} ++@code{lambda} @i{lambda-list [[@{@i{declaration}@}* | @i{documentation}]] @{@i{form}@}*} + @subsubheading Arguments:: + + @i{lambda-list}---an @i{ordinary lambda list}. +@@ -4003,7 +4044,7 @@ + @subsubheading See Also:: + + @b{function}, +-@ref{documentation; (setf documentation)} ++@ref{documentation} + , + @ref{Lambda Expressions}, + @ref{Lambda Forms}, +@@ -4026,7 +4067,7 @@ + @node lambda, compile, lambda (Symbol), Evaluation and Compilation Dictionary + @subsection lambda [Macro] + +-@code{lambda} @i{lambda-list {[[@{@i{declaration}@}{*} | @i{documentation}]]} @{@i{form}@}{*}} @result{} @i{@i{function}} ++@code{lambda} @i{lambda-list [[@{@i{declaration}@}* | @i{documentation}]] @{@i{form}@}*} @result{} @i{@i{function}} + + @subsubheading Arguments and Values:: + +@@ -4046,9 +4087,9 @@ + involving a @i{lambda expression} such that: + + @example +- (lambda @i{lambda-list} {[[@{@i{declaration}@}{*} | @i{documentation}]]} @{@i{form}@}{*}) +- @equiv{} (function (lambda @i{lambda-list} {[[@{@i{declaration}@}{*} | @i{documentation}]]} @{@i{form}@}{*})) +- @equiv{} #'(lambda @i{lambda-list} {[[@{@i{declaration}@}{*} | @i{documentation}]]} @{@i{form}@}{*}) ++ (lambda @i{lambda-list} [[@{@i{declaration}@}* | @i{documentation}]] @{@i{form}@}*) ++ @equiv{} (function (lambda @i{lambda-list} [[@{@i{declaration}@}* | @i{documentation}]] @{@i{form}@}*)) ++ @equiv{} #'(lambda @i{lambda-list} [[@{@i{declaration}@}* | @i{documentation}]] @{@i{form}@}*) + @end example + + @subsubheading Examples:: +@@ -4074,7 +4115,7 @@ + @node compile, eval, lambda, Evaluation and Compilation Dictionary + @subsection compile [Function] + +-@code{compile} @i{name {&optional} definition} @result{} @i{function, warnings-p, failure-p} ++@code{compile} @i{name @r{&optional} definition} @result{} @i{function, warnings-p, failure-p} + + @subsubheading Arguments and Values:: + +@@ -4174,7 +4215,7 @@ + @node eval, eval-when, compile, Evaluation and Compilation Dictionary + @subsection eval [Function] + +-@code{eval} @i{form} @result{} @i{@{@i{result}@}{*}} ++@code{eval} @i{form} @result{} @i{@{@i{result}@}*} + + @subsubheading Arguments and Values:: + +@@ -4242,19 +4283,19 @@ + @node eval-when, load-time-value, eval, Evaluation and Compilation Dictionary + @subsection eval-when [Special Operator] + +-@code{eval-when} @i{@r{(}@{@i{situation}@}{*}@r{)} @{@i{form}@}{*}} @result{} @i{@{@i{result}@}{*}} ++@code{eval-when} @i{@r{(}@{@i{situation}@}*@r{)} @{@i{form}@}*} @result{} @i{@{@i{result}@}*} + + @subsubheading Arguments and Values:: + + @i{situation}---One of the @i{symbols} + @t{:compile-toplevel} +-@IKindex{compile-toplevel} ++@c @IKindex{compile-toplevel} + , + @t{:load-toplevel} +-@IKindex{load-toplevel} ++@c @IKindex{load-toplevel} + , + @t{:execute} +-@IKindex{execute} ++@c @IKindex{execute} + , + @b{compile} + @IRindex{compile} +@@ -4452,7 +4493,7 @@ + @node load-time-value, quote, eval-when, Evaluation and Compilation Dictionary + @subsection load-time-value [Special Operator] + +-@code{load-time-value} @i{form {&optional} read-only-p} @result{} @i{object} ++@code{load-time-value} @i{form @r{&optional} read-only-p} @result{} @i{object} + + @subsubheading Arguments and Values:: + +@@ -4653,9 +4694,9 @@ + @node compiler-macro-function, define-compiler-macro, quote, Evaluation and Compilation Dictionary + @subsection compiler-macro-function [Accessor] + +-@code{compiler-macro-function} @i{name {&optional} environment} @result{} @i{function} ++@code{compiler-macro-function} @i{name @r{&optional} environment} @result{} @i{function} + +-(setf (@code{ compiler-macro-function} @i{name {&optional} environment}) new-function)@* ++(setf (@code{ compiler-macro-function} @i{name @r{&optional} environment}) new-function)@* + + @subsubheading Arguments and Values:: + +@@ -4685,7 +4726,7 @@ + @node define-compiler-macro, defmacro, compiler-macro-function, Evaluation and Compilation Dictionary + @subsection define-compiler-macro [Macro] + +-@code{define-compiler-macro} @i{name lambda-list {[[@{@i{declaration}@}{*} | @i{documentation}]]} @{@i{form}@}{*}}@* ++@code{define-compiler-macro} @i{name lambda-list [[@{@i{declaration}@}* | @i{documentation}]] @{@i{form}@}*}@* + @result{} @i{name} + + @subsubheading Arguments and Values:: +@@ -4849,7 +4890,7 @@ + , + @ref{defmacro} + , +-@ref{documentation; (setf documentation)} ++@ref{documentation} + , + @ref{Syntactic Interaction of Documentation Strings and Declarations} + +@@ -4867,7 +4908,7 @@ + @node defmacro, macro-function, define-compiler-macro, Evaluation and Compilation Dictionary + @subsection defmacro [Macro] + +-@code{defmacro} @i{name lambda-list {[[@{@i{declaration}@}{*} | @i{documentation}]]} @{@i{form}@}{*}}@* ++@code{defmacro} @i{name lambda-list [[@{@i{declaration}@}* | @i{documentation}]] @{@i{form}@}*}@* + @result{} @i{name} + + @subsubheading Arguments and Values:: +@@ -5041,9 +5082,9 @@ + + @ref{destructuring-bind} + , +-@ref{documentation; (setf documentation)} ++@ref{documentation} + , +-@ref{macroexpand; macroexpand-1} ++@ref{macroexpand} + , + @b{*macroexpand-hook*}, + @b{macrolet}, +@@ -5056,9 +5097,9 @@ + @node macro-function, macroexpand, defmacro, Evaluation and Compilation Dictionary + @subsection macro-function [Accessor] + +-@code{macro-function} @i{symbol {&optional} environment} @result{} @i{function} ++@code{macro-function} @i{symbol @r{&optional} environment} @result{} @i{function} + +-(setf (@code{ macro-function} @i{symbol {&optional} environment}) new-function)@* ++(setf (@code{ macro-function} @i{symbol @r{&optional} environment}) new-function)@* + + @subsubheading Arguments and Values:: + +@@ -5139,10 +5180,10 @@ + @node macroexpand, define-symbol-macro, macro-function, Evaluation and Compilation Dictionary + @subsection macroexpand, macroexpand-1 [Function] + +-@code{macroexpand} @i{form {&optional} env} @result{} @i{expansion, expanded-p} ++@code{macroexpand} @i{form @r{&optional} env} @result{} @i{expansion, expanded-p} + +-@code{macroexpand-} @i{1} @result{} @i{form {&optional} env} +- {expansion, expanded-p} ++@code{macroexpand-} @i{1} @result{} @i{form @r{&optional} env} ++ @r{expansion, expanded-p} + + @subsubheading Arguments and Values:: + +@@ -5276,7 +5317,7 @@ + @b{*macroexpand-hook*}, + @ref{defmacro} + , +-@ref{setf; psetf} ++@ref{setf} + of + @ref{macro-function} + , +@@ -5372,15 +5413,15 @@ + + @ref{symbol-macrolet} + , +-@ref{macroexpand; macroexpand-1} ++@ref{macroexpand} + + @node symbol-macrolet, *macroexpand-hook*, define-symbol-macro, Evaluation and Compilation Dictionary + @subsection symbol-macrolet [Special Operator] + +-@code{symbol-macrolet} @i{@r{(}@{{(}symbol expansion@r{)}@}{*}@r{)} +- @{@i{declaration}@}{*} +- @{@i{form}@}{*}}@* +- @result{} @i{@{@i{result}@}{*}} ++@code{symbol-macrolet} @i{@r{(}@{@r{(}symbol expansion @r{)}@}*@r{)} ++ @{@i{declaration}@}* ++ @{@i{form}@}*}@* ++ @result{} @i{@{@i{result}@}*} + + @subsubheading Arguments and Values:: + +@@ -5463,7 +5504,7 @@ + + @ref{with-slots} + , +-@ref{macroexpand; macroexpand-1} ++@ref{macroexpand} + + @subsubheading Notes:: + +@@ -5518,7 +5559,7 @@ + + @subsubheading See Also:: + +-@ref{macroexpand; macroexpand-1} ++@ref{macroexpand} + , @b{macroexpand-1}, + @ref{funcall} + , @ref{Evaluation} +@@ -5566,6 +5607,7 @@ + Figure 3--22 shows a list of @i{declaration identifiers} + that can be used with @b{proclaim}. + ++@format + @group + @noindent + @w{ declaration inline optimize type } +@@ -5575,6 +5617,7 @@ + @w{ Figure 3--22: Global Declaration Specifiers} + + @end group ++@end format + + An implementation is free to support other (@i{implementation-defined}) + @i{declaration identifiers} as well. +@@ -5628,7 +5671,7 @@ + @node declaim, declare, proclaim, Evaluation and Compilation Dictionary + @subsection declaim [Macro] + +-@code{declaim} @i{@{@i{declaration-specifier}@}{*}} @result{} @i{@i{implementation-dependent}} ++@code{declaim} @i{@{@i{declaration-specifier}@}*} @result{} @i{@i{implementation-dependent}} + + @subsubheading Arguments and Values:: + +@@ -5656,7 +5699,7 @@ + + @subsubheading Syntax:: + +-@code{declare} @i{@{@i{declaration-specifier}@}{*}} ++@code{declare} @i{@{@i{declaration-specifier}@}*} + @subsubheading Arguments:: + + @i{declaration-specifier}---a @i{declaration specifier}; not evaluated. +@@ -5671,6 +5714,7 @@ + A @b{declare} @i{expression} can occur in a @i{lambda expression} + or in any of the @i{forms} listed in Figure 3--23. + ++@format + @group + @noindent + @w{ defgeneric do-external-symbols prog } +@@ -5691,6 +5735,7 @@ + @w{ Figure 3--23: Standardized Forms In Which Declarations Can Occur } + + @end group ++@end format + + A @b{declare} @i{expression} can only occur + where specified by the syntax of these @i{forms}. +@@ -5708,6 +5753,7 @@ + Figure 3--24 shows a list of @i{declaration identifiers} + that can be used with @b{declare}. + ++@format + @group + @noindent + @w{ dynamic-extent ignore optimize } +@@ -5718,6 +5764,7 @@ + @w{ Figure 3--24: Local Declaration Specifiers} + + @end group ++@end format + + An implementation is free to support other (@i{implementation-defined}) + @i{declaration identifiers} as well. +@@ -5782,9 +5829,9 @@ + + @subsubheading Syntax:: + +-@t{@r{(}ignore @{@i{var} | @r{(}@b{function} @i{fn}@r{)}@}{*}@r{)}} ++@t{@r{(}ignore @{@i{var} | @r{(}@b{function} @i{fn}@r{)}@}*@r{)}} + +-@t{@r{(}ignorable @{@i{var} | @r{(}@b{function} @i{fn}@r{)}@}{*}@r{)}} ++@t{@r{(}ignorable @{@i{var} | @r{(}@b{function} @i{fn}@r{)}@}*@r{)}} + + @subsubheading Arguments:: + +@@ -5861,7 +5908,7 @@ + + @subsubheading Syntax:: + +-@t{(dynamic-extent [[@{@i{var}@}{*} | ++@t{(dynamic-extent [[@{@i{var}@}* | + @r{(}@b{function} @i{fn}@r{)}@r{*}]])} + + @subsubheading Arguments:: +@@ -6075,9 +6122,9 @@ + + @subsubheading Syntax:: + +-@t{(type @i{typespec} @{@i{var}@}{*})} ++@t{(type @i{typespec} @{@i{var}@}*)} + +-@t{(@i{typespec} @{@i{var}@}{*})} ++@t{(@i{typespec} @{@i{var}@}*)} + + @subsubheading Arguments:: + +@@ -6250,8 +6297,8 @@ + + @subsubheading Notes:: + +-@t{(@i{typespec} @{@i{var}@}{*})} +-is an abbreviation for @t{(type @i{typespec} @{@i{var}@}{*})}. ++@t{(@i{typespec} @{@i{var}@}*)} ++is an abbreviation for @t{(type @i{typespec} @{@i{var}@}*)}. + + A @b{type} declaration for the arguments to a function does not + necessarily imply anything about the type of the result. The following +@@ -6303,9 +6350,9 @@ + + @subsubheading Syntax:: + +-@t{(inline @{@i{function-name}@}{*})} ++@t{(inline @{@i{function-name}@}*)} + +-@t{(notinline @{@i{function-name}@}{*})} ++@t{(notinline @{@i{function-name}@}*)} + + @subsubheading Arguments:: + +@@ -6422,7 +6469,7 @@ + + @subsubheading Syntax:: + +-@t{(ftype @i{type} @{@i{function-name}@}{*})} ++@t{(ftype @i{type} @{@i{function-name}@}*)} + + @subsubheading Arguments:: + +@@ -6483,7 +6530,7 @@ + + @subsubheading Syntax:: + +-@t{(declaration @{@i{name}@}{*})} ++@t{(declaration @{@i{name}@}*)} + + @subsubheading Arguments:: + +@@ -6522,7 +6569,7 @@ + + @subsubheading Syntax:: + +-@t{(optimize @{@i{quality} | (@i{quality} @i{value})@}{*})} ++@t{(optimize @{@i{quality} | (@i{quality} @i{value})@}*)} + + @IRindex{compilation-speed} + +@@ -6552,6 +6599,7 @@ + the names and meanings of the standard @i{optimize qualities} are shown in + Figure 3--25. + ++@format + @group + @noindent + @w{ Name Meaning } +@@ -6565,6 +6613,7 @@ + @w{ Figure 3--25: Optimize qualities } + + @end group ++@end format + + There may be other, @i{implementation-defined} @i{optimize qualities}. + +@@ -6617,7 +6666,7 @@ + + @subsubheading Syntax:: + +-@t{(special @{@i{var}@}{*})} ++@t{(special @{@i{var}@}*)} + + @subsubheading Arguments:: + +@@ -6764,14 +6813,14 @@ + + @subsubheading See Also:: + +-@ref{defparameter; defvar} ++@ref{defparameter} + , + @b{defvar} + + @node locally, the, special, Evaluation and Compilation Dictionary + @subsection locally [Special Operator] + +-@code{locally} @i{@{@i{declaration}@}{*} @{@i{form}@}{*}} @result{} @i{@{@i{result}@}{*}} ++@code{locally} @i{@{@i{declaration}@}* @{@i{form}@}*} @result{} @i{@{@i{result}@}*} + + @subsubheading Arguments and Values:: + +@@ -6838,7 +6887,7 @@ + @node the, special-operator-p, locally, Evaluation and Compilation Dictionary + @subsection the [Special Operator] + +-@code{the} @i{value-type form} @result{} @i{@{@i{result}@}{*}} ++@code{the} @i{value-type form} @result{} @i{@{@i{result}@}*} + + @subsubheading Arguments and Values:: + +@@ -6950,7 +6999,7 @@ + @node constantp, , special-operator-p, Evaluation and Compilation Dictionary + @subsection constantp [Function] + +-@code{constantp} @i{form {&optional} environment} @result{} @i{generalized-boolean} ++@code{constantp} @i{form @r{&optional} environment} @result{} @i{generalized-boolean} + + @subsubheading Arguments and Values:: + +diff -uNr gcl-texi-orig/chap-4.texi gcl-texi/chap-4.texi +--- gcl-texi-orig/chap-4.texi 1994-07-16 18:03:20 +0400 ++++ gcl-texi/chap-4.texi 2002-10-17 20:53:05 +0400 +@@ -88,6 +88,7 @@ + that are particularly relevant to the object system. + @i{Figure~9--1} lists the defined @i{condition} @i{types}. + ++@format + @group + @noindent + @w{ @b{Section} Data Type } +@@ -106,6 +107,7 @@ + @w{ Figure 4--1: Cross-References to Data Type Information } + + @end group ++@end format + + @node Type Relationships, Type Specifiers, Data Type Definition, Types + @subsection Type Relationships +@@ -182,6 +184,7 @@ + or + @b{deftype}. + ++@format + @group + @noindent + @w{ arithmetic-error function simple-condition } +@@ -222,6 +225,7 @@ + @w{ Figure 4--2: Standardized Atomic Type Specifiers } + + @end group ++@end format + + \indent + If a @i{type specifier} is a @i{list}, the @i{car} of the @i{list} +@@ -270,6 +274,7 @@ + and then to + @t{vector}. + ++@format + @group + @noindent + @w{ and long-float simple-base-string } +@@ -288,11 +293,13 @@ + @w{ Figure 4--3: Standardized Compound Type Specifier Names} + + @end group ++@end format + + Figure 4--4 show the @i{defined names} that can be used as + @i{compound type specifier} @i{names} + but that cannot be used as @i{atomic type specifiers}. + ++@format + @group + @noindent + @w{ and mod satisfies } +@@ -303,6 +310,7 @@ + @w{ Figure 4--4: Standardized Compound-Only Type Specifier Names} + + @end group ++@end format + + New @i{type specifiers} can come into existence in two ways. + @table @asis +@@ -327,6 +335,7 @@ + Figure 4--5 shows some @i{defined names} relating to + @i{types} and @i{declarations}. + ++@format + @group + @noindent + @w{ coerce defstruct subtypep } +@@ -339,12 +348,14 @@ + @w{ Figure 4--5: Defined names relating to types and declarations.} + + @end group ++@end format + + Figure 4--6 shows all @i{defined names} that are @i{type specifier} @i{names}, + whether for @i{atomic type specifiers} or @i{compound type specifiers}; + this list is the union of the lists in @i{Figure~4--2} + and @i{Figure~4--3}. + ++@format + @group + @noindent + @w{ and function simple-array } +@@ -387,6 +398,7 @@ + @w{ Figure 4--6: Standardized Type Specifier Names } + + @end group ++@end format + + @c end of including concept-types + +@@ -400,6 +412,7 @@ + @b{symbol}), Figure 4--7 contains a list of @i{classes} that are + especially relevant to understanding the object system. + ++@format + @group + @noindent + @w{ built-in-class method-combination standard-object } +@@ -411,6 +424,7 @@ + @w{ Figure 4--7: Object System Classes } + + @end group ++@end format + + @menu + * Introduction to Classes:: +@@ -744,7 +758,7 @@ + + Let S_C be the set of C and its @i{superclasses}. Let R be + +-@center R=\bigcup_@{c\in {S_C}@}R_c ++@center R=\bigcup_@{c\in S_C @}R_c + . + + [Reviewer Note by Barmar: ``Consistent'' needs to be defined, or maybe we should say +@@ -838,25 +852,25 @@ + (defclass food () ()) + @end example + +-The set S_@{pie@}~= @{{pie, apple, cinnamon, fruit, spice, food, +-standard-object, t}@}. The set R~= @{{(pie, apple), ++The set S_@{pie@}~= @{pie, apple, cinnamon, fruit, spice, food, ++standard-object, t @}. The set R~= @{ (pie, apple), + (apple, cinnamon), (apple, fruit), (cinnamon, spice), \break + (fruit, food), (spice, food), (food, standard-object), (standard-object, +-t)}@}. ++t) @}. + + The class @t{pie} is not preceded by anything, so it comes first; + the result so far is @t{(pie)}. Remove @t{pie} from S and pairs +-mentioning @t{pie} from R to get S~= @{{apple, cinnamon, +-fruit, spice, food, standard-object, t}@} and R~=~@{{(apple, cinnamon), (apple, fruit), (cinnamon, spice),\break (fruit, ++mentioning @t{pie} from R to get S~= @{apple, cinnamon, ++fruit, spice, food, standard-object, t @} and R~=~@{(apple, cinnamon), (apple, fruit), (cinnamon, spice),\break (fruit, + food), (spice, food), (food, standard-object), +-(standard-object, t)}@}. ++(standard-object, t) @}. + + The class @t{apple} is not preceded by anything, so it is next; the + result is @t{(pie apple)}. Removing @t{apple} and the relevant +-pairs results in S~= @{{cinnamon, fruit, spice, food, +-standard-object, t}@} and R~= @{{(cinnamon, spice), ++pairs results in S~= @{ cinnamon, fruit, spice, food, ++standard-object, t @} and R~= @{ (cinnamon, spice), + (fruit, food), (spice, food), (food, standard-object),\break +-(standard-object, t)}@}. ++(standard-object, t) @}. + + The classes @t{cinnamon} and @t{fruit} are not preceded by + anything, so the one with a direct @i{subclass} rightmost in the +@@ -865,14 +879,14 @@ + @i{subclass} of @t{cinnamon}. Because @t{apple} appears to the right + of @t{pie} in the @i{class precedence list}, + @t{fruit} goes next, and the +-result so far is @t{(pie apple fruit)}. S~= @{{cinnamon, +-spice, food, standard-object, t}@}; R~= @{{(cinnamon, ++result so far is @t{(pie apple fruit)}. S~= @{ cinnamon, ++spice, food, standard-object, t @}; R~= @{(cinnamon, + spice), (spice, food),\break (food, standard-object), +-(standard-object, t)}@}. ++(standard-object, t) @}. + +-The class @t{cinnamon} is next, giving the result so far as @t{(pie apple fruit cinnamon)}. At this point S~= @{{spice, +-food, standard-object, t}@}; R~= @{{(spice, food), (food, +-standard-object), (standard-object, t)}@}. ++The class @t{cinnamon} is next, giving the result so far as @t{(pie apple fruit cinnamon)}. At this point S~= @{ spice, ++food, standard-object, t @}; R~= @{ (spice, food), (food, ++standard-object), (standard-object, t) @}. + + The classes @t{spice}, @t{food}, @b{standard-object}, and + @b{t} are added in that order, and the @i{class precedence list} +@@ -1161,6 +1175,7 @@ + @i{Figure~4--8} lists the set of @i{classes} + that correspond to predefined @i{type specifiers}. + ++@format + @group + @noindent + @w{ arithmetic-error generic-function simple-error } +@@ -1193,6 +1208,7 @@ + @w{ Figure 4--8: Classes that correspond to pre-defined type specifiers } + + @end group ++@end format + + The @i{class precedence list} information specified in the entries for + each of these @i{classes} are those that are required by the object system. +@@ -1232,7 +1248,7 @@ + * method-combination:: + * t (System Class):: + * satisfies:: +-* member:: ++* member (Type Specifier):: + * not (Type Specifier):: + * and (Type Specifier):: + * or (Type Specifier):: +@@ -1330,10 +1346,10 @@ + + (@code{function}@{@i{@t{[}arg-typespec @r{[}value-typespec@r{]}@t{]}}@}) + +-@w{@i{arg-typespec} ::=@r{(}@{@i{typespec}@}{*} } +-@w{ @t{[}{&optional} @{@i{typespec}@}{*}@t{]} } +-@w{ @t{[}{&rest} @i{typespec}@t{]} } +-@w{ @t{[}{&key} @{{(}keyword typespec@r{)}@}{*}@t{]}@r{)}} ++@w{@i{arg-typespec} ::=@r{(}@{@i{typespec}@}* } ++@w{ @t{[}@r{&optional} @{@i{typespec}@}*@t{]} } ++@w{ @t{[}@r{&rest} @i{typespec}@t{]} } ++@w{ @t{[}@r{&key} @{@r{(}keyword typespec @r{)}@}*@t{]}@r{)}} + + @subsubheading Compound Type Specifier Arguments:: + +@@ -1728,7 +1744,7 @@ + The @i{type} @b{t} is a @i{supertype} of every @i{type}, + including itself. Every @i{object} is of @i{type} @b{t}. + +-@node satisfies, member, t (System Class), Types and Classes Dictionary ++@node satisfies, member (Type Specifier), t (System Class), Types and Classes Dictionary + @subsection satisfies [Type Specifier] + + @subsubheading Compound Type Specifier Kind:: +@@ -1762,7 +1778,7 @@ + + The symbol @b{satisfies} is not valid as a @i{type specifier}. + +-@node member, not (Type Specifier), satisfies, Types and Classes Dictionary ++@node member (Type Specifier), not (Type Specifier), satisfies, Types and Classes Dictionary + @subsection member [Type Specifier] + + @subsubheading Compound Type Specifier Kind:: +@@ -1771,7 +1787,7 @@ + + @subsubheading Compound Type Specifier Syntax:: + +-(@code{member}@{@i{@{@i{object}@}{*}}@}) ++(@code{member}@{@i{@{@i{object}@}*}@}) + + @subsubheading Compound Type Specifier Arguments:: + +@@ -1794,7 +1810,7 @@ + + the @i{type} @b{eql} + +-@node not (Type Specifier), and (Type Specifier), member, Types and Classes Dictionary ++@node not (Type Specifier), and (Type Specifier), member (Type Specifier), Types and Classes Dictionary + @subsection not [Type Specifier] + + @subsubheading Compound Type Specifier Kind:: +@@ -1826,7 +1842,7 @@ + + @subsubheading Compound Type Specifier Syntax:: + +-(@code{and}@{@i{@{@i{typespec}@}{*}}@}) ++(@code{and}@{@i{@{@i{typespec}@}*}@}) + + @subsubheading Compound Type Specifier Arguments:: + +@@ -1852,7 +1868,7 @@ + + @subsubheading Compound Type Specifier Syntax:: + +-(@code{or}@{@i{@{@i{typespec}@}{*}}@}) ++(@code{or}@{@i{@{@i{typespec}@}*}@}) + + @subsubheading Compound Type Specifier Arguments:: + +@@ -1885,7 +1901,7 @@ + + [Reviewer Note by Barmar: Missing @b{&key}] + +-@w{@i{value-typespec} ::=@{@i{typespec}@}{*} @t{[}{&optional} {@{@i{typespec}@}{*}}@t{]} @t{[}{&rest} typespec@t{]} @t{[}@b{&allow-other-keys}@t{]}} ++@w{@i{value-typespec} ::=@{@i{typespec}@}* @t{[}@r{&optional} @r{@{@i{typespec}@}*}@t{]} @t{[}@r{&rest} typespec @t{]} @t{[}@b{&allow-other-keys}@t{]}} + + @subsubheading Compound Type Specifier Arguments:: + +@@ -2075,9 +2091,9 @@ + + @subsubheading See Also:: + +-@ref{rational} ++@ref{rational (Function)} + , +-@ref{floor; ffloor; ceiling; fceiling; truncate; ftruncate; round; fround} ++@ref{floor} + , + @ref{char-code} + , +@@ -2096,7 +2112,7 @@ + @node deftype, subtypep, coerce, Types and Classes Dictionary + @subsection deftype [Macro] + +-@code{deftype} @i{name lambda-list {[[@{@i{declaration}@}{*} | @i{documentation}]]} @{@i{form}@}{*}} @result{} @i{name} ++@code{deftype} @i{name lambda-list @r{[[@{@i{declaration}@}* | @i{documentation}]]} @{@i{form}@}*} @result{} @i{name} + + @subsubheading Arguments and Values:: + +@@ -2185,7 +2201,7 @@ + @b{declare}, + @ref{defmacro} + , +-@ref{documentation; (setf documentation)} ++@ref{documentation} + , + @ref{Type Specifiers}, + @ref{Syntactic Interaction of Documentation Strings and Declarations} +@@ -2193,7 +2209,7 @@ + @node subtypep, type-of, deftype, Types and Classes Dictionary + @subsection subtypep [Function] + +-@code{subtypep} @i{type-1 type-2 {&optional} environment} @result{} @i{subtype-p, valid-p} ++@code{subtypep} @i{type-1 type-2 @r{&optional} environment} @result{} @i{subtype-p, valid-p} + + @subsubheading Arguments and Values:: + +@@ -2228,6 +2244,7 @@ + Figure 4--9 summarizes the possible combinations of @i{values} + that might result. + ++@format + @group + @noindent + @w{ Value 1 Value 2 Meaning } +@@ -2240,6 +2257,7 @@ + @w{ Figure 4--9: Result possibilities for subtypep } + + @end group ++@end format + + @b{subtypep} is permitted to return the + @i{values} @i{false} and @i{false} only when at least +@@ -2541,7 +2559,7 @@ + , + @ref{defstruct} + , +-@ref{typecase; ctypecase; etypecase} ++@ref{typecase} + , + @ref{typep} + , +@@ -2556,7 +2574,7 @@ + @node typep, type-error, type-of, Types and Classes Dictionary + @subsection typep [Function] + +-@code{typep} @i{object type-specifier {&optional} environment} @result{} @i{generalized-boolean} ++@code{typep} @i{object type-specifier @r{&optional} environment} @result{} @i{generalized-boolean} + + @subsubheading Arguments and Values:: + +@@ -2625,26 +2643,26 @@ + (typep #c(0 0) '(complex (eql 0))) @result{} @i{false} + @end example + +-Let @t{A{{}_x}} and @t{A{{}_y}} be two @i{type specifiers} that ++Let @t{A_x} and @t{A_y} be two @i{type specifiers} that + denote different @i{types}, but for which + + @example +- (upgraded-array-element-type 'A{{}_x}) ++ (upgraded-array-element-type 'A_x) + @end example + + and + + @example +- (upgraded-array-element-type 'A{{}_y}) ++ (upgraded-array-element-type 'A_y) + @end example + + denote the same @i{type}. Notice that + + @example +- (typep (make-array 0 :element-type 'A{{}_x}) '(array A{{}_x})) @result{} @i{true} +- (typep (make-array 0 :element-type 'A{{}_y}) '(array A{{}_y})) @result{} @i{true} +- (typep (make-array 0 :element-type 'A{{}_x}) '(array A{{}_y})) @result{} @i{true} +- (typep (make-array 0 :element-type 'A{{}_y}) '(array A{{}_x})) @result{} @i{true} ++ (typep (make-array 0 :element-type 'A_x) '(array A_x)) @result{} @i{true} ++ (typep (make-array 0 :element-type 'A_y) '(array A_y)) @result{} @i{true} ++ (typep (make-array 0 :element-type 'A_x) '(array A_y)) @result{} @i{true} ++ (typep (make-array 0 :element-type 'A_y) '(array A_x)) @result{} @i{true} + @end example + + @subsubheading Exceptional Situations:: +@@ -2697,7 +2715,7 @@ + + @subsubheading See Also:: + +-@ref{type-error-datum; type-error-expected-type} ++@ref{type-error-datum} + , @b{type-error-expected-type} + + @node type-error-datum, simple-type-error, type-error, Types and Classes Dictionary +@@ -2773,11 +2791,11 @@ + + @b{simple-condition}, + +-@ref{simple-condition-format-control; simple-condition-format-arguments} ++@ref{simple-condition-format-control} + , + + @b{simple-condition-format-arguments}, +-@ref{type-error-datum; type-error-expected-type} ++@ref{type-error-datum} + , + @b{type-error-expected-type} + +diff -uNr gcl-texi-orig/chap-5.texi gcl-texi/chap-5.texi +--- gcl-texi-orig/chap-5.texi 1994-07-16 18:03:19 +0400 ++++ gcl-texi/chap-5.texi 2002-10-17 21:17:54 +0400 +@@ -50,6 +50,7 @@ + that the ultimate result of evaluating @b{setf} is the value + or values being stored. + ++@format + @group + @noindent + @w{ Access function Update Function Update using @b{setf} } +@@ -61,10 +62,12 @@ + @w{ Figure 5--1: Examples of setf } + + @end group ++@end format + + Figure 5--2 shows @i{operators} relating to + @i{places} and @i{generalized reference}. + ++@format + @group + @noindent + @w{ assert defsetf push } +@@ -78,6 +81,7 @@ + @w{ Figure 5--2: Operators relating to places and generalized reference.} + + @end group ++@end format + + Some of the @i{operators} above manipulate @i{places} + and some manipulate @i{setf expanders}. +@@ -281,6 +285,7 @@ + + For a variable @i{x}: + ++@format + @group + @noindent + @w{ @t{()} ;list of temporary variables } +@@ -293,9 +298,11 @@ + @w{ Figure 5--3: Sample Setf Expansion of a Variable} + + @end group ++@end format + + For @t{(car @i{exp})}: + ++@format + @group + @noindent + @w{ @t{(g0002)} ;list of temporary variables } +@@ -308,9 +315,11 @@ + @w{ Figure 5--4: Sample Setf Expansion of a CAR Form } + + @end group ++@end format + + For @t{(subseq @i{seq} @i{s} @i{e})}: + ++@format + @group + @noindent + @w{ @t{(g0004 g0005 g0006)} ;list of temporary variables } +@@ -324,12 +333,14 @@ + @w{ Figure 5--5: Sample Setf Expansion of a SUBSEQ Form } + + @end group ++@end format + + In some cases, if a @i{subform} of a @i{place} is itself + a @i{place}, it is necessary to expand the @i{subform} + in order to compute some of the values in the expansion of the outer + @i{place}. For @t{(ldb @i{bs} (car @i{exp}))}: + ++@format + @group + @noindent + @w{ @t{(g0001 g0002)} ;list of temporary variables } +@@ -343,6 +354,7 @@ + @w{ Figure 5--6: Sample Setf Expansion of a LDB Form } + + @end group ++@end format + + @node Kinds of Places, Treatment of Other Macros Based on SETF, Overview of Places and Generalized Reference, Generalized Reference + @subsection Kinds of Places +@@ -387,6 +399,7 @@ + search for these items and eliminate stray references to them as `accessors', + which they are not, but I will do that at some point.] + ++@format + @group + @noindent + @w{ aref cdadr get } +@@ -416,6 +429,7 @@ + @w{ Figure 5--7: Functions that setf can be used with---1 } + + @end group ++@end format + + In the case of @b{subseq}, the replacement value must be a @i{sequence} + whose elements might be contained by the sequence argument to @b{subseq}, +@@ -440,6 +454,7 @@ + in this case the new @i{place} has stored back into it the + result of applying the supplied ``update'' function. + ++@format + @group + @noindent + @w{ Function name Argument that is a @i{place} Update function used } +@@ -451,6 +466,7 @@ + @w{ Figure 5--8: Functions that setf can be used with---2 } + + @end group ++@end format + + During the @b{setf} expansion of these @i{forms}, it is necessary to call + +@@ -652,17 +668,17 @@ + + @item @t{*} + @t{(setf (apply #'aref @i{array} +- @{@i{subscript}@}{*} ++ @{@i{subscript}@}* + @i{more-subscripts}) + @i{new-element})} + @item @t{*} + @t{(setf (apply #'bit @i{array} +- @{@i{subscript}@}{*} ++ @{@i{subscript}@}* + @i{more-subscripts}) + @i{new-element})} + @item @t{*} + @t{(setf (apply #'sbit @i{array} +- @{@i{subscript}@}{*} ++ @{@i{subscript}@}* + @i{more-subscripts}) + @i{new-element})} + @end table +@@ -687,8 +703,8 @@ + to preserve proper left-to-right evaluation of argument @i{subforms}: + + @example +- (setf (apply #'@i{name} @{@i{arg}@}{*}) @i{val}) +- @equiv{} (apply #'(setf @i{name}) @i{val} @{@i{arg}@}{*}) ++ (setf (apply #'@i{name} @{@i{arg}@}*) @i{val}) ++ @equiv{} (apply #'(setf @i{name}) @i{val} @{@i{arg}@}*) + @end example + + @node Setf Expansions and Places, Macro Forms as Places, APPLY Forms as Places, Kinds of Places +@@ -772,7 +788,7 @@ + @i{form} with the following general syntax: + + @example +- (@i{operator} @{@i{preceding-form}@}{*} @i{place} @{@i{following-form}@}{*}) ++ (@i{operator} @{@i{preceding-form}@}* @i{place} @{@i{following-form}@}*) + @end example + + The evaluation of each such @i{form} proceeds like this: +@@ -795,6 +811,7 @@ + Store the new value into @i{place}. + @end table + ++@format + @group + @noindent + @w{ decf pop pushnew } +@@ -804,6 +821,7 @@ + @w{ Figure 5--9: Read-Modify-Write Macros} + + @end group ++@end format + + @c end of including concept-places + +@@ -944,7 +962,7 @@ + @node apply, defun, Data and Control Flow Dictionary, Data and Control Flow Dictionary + @subsection apply [Function] + +-@code{apply} @i{function {&rest} args^+} @result{} @i{@{@i{result}@}{*}} ++@code{apply} @i{function @r{&rest} args^+} @result{} @i{@{@i{result}@}*} + + @subsubheading Arguments and Values:: + +@@ -1011,7 +1029,7 @@ + @node defun, fdefinition, apply, Data and Control Flow Dictionary + @subsection defun [Macro] + +-@code{defun} @i{function-name lambda-list {[[@{@i{declaration}@}{*} | @i{documentation}]]} @{@i{form}@}{*}}@* ++@code{defun} @i{function-name lambda-list @r{[[@{@i{declaration}@}* | @i{documentation}]]} @{@i{form}@}*}@* + @result{} @i{function-name} + + @subsubheading Arguments and Values:: +@@ -1056,8 +1074,8 @@ + + @example + (lambda @i{lambda-list} +- {[[@{@i{declaration}@}{*} | @i{documentation}]]} +- (block @i{block-name} @{@i{form}@}{*})) ++ @r{[[@{@i{declaration}@}* | @i{documentation}]]} ++ (block @i{block-name} @{@i{form}@}*)) + @end example + + processed in the @i{lexical environment} in which @b{defun} was executed. +@@ -1106,7 +1124,7 @@ + + @subsubheading See Also:: + +-@ref{flet; labels; macrolet} ++@ref{flet} + , + @b{labels}, + @ref{block} +@@ -1114,7 +1132,7 @@ + @ref{return-from} + , + @b{declare}, +-@ref{documentation; (setf documentation)} ++@ref{documentation} + , + @ref{Evaluation}, + @ref{Ordinary Lambda Lists}, +@@ -1313,29 +1331,29 @@ + @node flet, funcall, fmakunbound, Data and Control Flow Dictionary + @subsection flet, labels, macrolet [Special Operator] + +-@code{flet} @i{@r{(}@{{(}@i{function-name} ++@code{flet} @i{@r{(}@{@r{(}@i{function-name} + @i{lambda-list} +- {[[@{@i{local-declaration}@}{*} ++ @r{[[@{@i{local-declaration}@}* + | @i{local-documentation}]]} +- @{@i{local-form}@}{*}@r{)}@}{*}@r{)} +- @{@i{declaration}@}{*} @{@i{form}@}{*}}@* +- @result{} @i{@{@i{result}@}{*}} ++ @{@i{local-form}@}*@r{)}@}*@r{)} ++ @{@i{declaration}@}* @{@i{form}@}*}@* ++ @result{} @i{@{@i{result}@}*} + +-@code{labels} @i{@r{(}@{{(}@i{function-name} ++@code{labels} @i{@r{(}@{@r{(}@i{function-name} + @i{lambda-list} +- {[[@{@i{local-declaration}@}{*} ++ @r{[[@{@i{local-declaration}@}* + | @i{local-documentation}]]} +- @{@i{local-form}@}{*}@r{)}@}{*}@r{)} +- @{@i{declaration}@}{*} @{@i{form}@}{*}}@* +- @result{} @i{@{@i{result}@}{*}} ++ @{@i{local-form}@}*@r{)}@}*@r{)} ++ @{@i{declaration}@}* @{@i{form}@}*}@* ++ @result{} @i{@{@i{result}@}*} + +-@code{macrolet} @i{@r{(}@{{(}@i{name} ++@code{macrolet} @i{@r{(}@{@r{(}@i{name} + @i{lambda-list} +- {[[@{@i{local-declaration}@}{*} ++ @r{[[@{@i{local-declaration}@}* + | @i{local-documentation}]]} +- @{@i{local-form}@}{*}@r{)}@}{*}@r{)} +- @{@i{declaration}@}{*} @{@i{form}@}{*}}@* +- @result{} @i{@{@i{result}@}{*}} ++ @{@i{local-form}@}*@r{)}@}*@r{)} ++ @{@i{declaration}@}* @{@i{form}@}*}@* ++ @result{} @i{@{@i{result}@}*} + + @subsubheading Arguments and Values:: + +@@ -1556,9 +1574,9 @@ + , + @ref{defun} + , +-@ref{documentation; (setf documentation)} ++@ref{documentation} + , +-@ref{let; let*} ++@ref{let} + , + @ref{Evaluation}, + @ref{Syntactic Interaction of Documentation Strings and Declarations} +@@ -1575,7 +1593,7 @@ + @node funcall, function (Special Operator), flet, Data and Control Flow Dictionary + @subsection funcall [Function] + +-@code{funcall} @i{function {&rest} args} @result{} @i{@{@i{result}@}{*}} ++@code{funcall} @i{function @r{&rest} args} @result{} @i{@{@i{result}@}*} + + @subsubheading Arguments and Values:: + +@@ -1693,7 +1711,7 @@ + , + @ref{fdefinition} + , +-@ref{flet; labels; macrolet} ++@ref{flet} + , + @b{labels}, + @ref{symbol-function} +@@ -1936,7 +1954,7 @@ + + @ref{defun} + , +-@ref{flet; labels; macrolet} ++@ref{flet} + , + @ref{defmacro} + , +@@ -2049,10 +2067,10 @@ + + @ref{declaim} + , +-@ref{defparameter; defvar} ++@ref{defparameter} + , + @b{defvar}, +-@ref{documentation; (setf documentation)} ++@ref{documentation} + , + @ref{proclaim} + , +@@ -2196,7 +2214,7 @@ + , + @ref{defconstant} + , +-@ref{documentation; (setf documentation)} ++@ref{documentation} + , + @ref{Compilation} + +@@ -2242,8 +2260,8 @@ + @node destructuring-bind, let, defparameter, Data and Control Flow Dictionary + @subsection destructuring-bind [Macro] + +-@code{destructuring-bind} @i{lambda-list expression @{@i{declaration}@}{*} @{@i{form}@}{*}}@* +- @result{} @i{@{@i{result}@}{*}} ++@code{destructuring-bind} @i{lambda-list expression @{@i{declaration}@}* @{@i{form}@}*}@* ++ @result{} @i{@{@i{result}@}*} + + @subsubheading Arguments and Values:: + +@@ -2287,9 +2305,9 @@ + @node let, progv, destructuring-bind, Data and Control Flow Dictionary + @subsection let, let* [Special Operator] + +-@code{let} @i{@r{(}@{@i{var} | @r{(}@i{var} @r{[}@i{init-form}@r{]}@r{)}@}{*}@r{)} @{@i{declaration}@}{*} @{@i{form}@}{*}} @result{} @i{@{@i{result}@}{*}} ++@code{let} @i{@r{(}@{@i{var} | @r{(}@i{var} @r{[}@i{init-form}@r{]}@r{)}@}*@r{)} @{@i{declaration}@}* @{@i{form}@}*} @result{} @i{@{@i{result}@}*} + +-@code{let*} @i{@r{(}@{@i{var} | @r{(}@i{var} @r{[}@i{init-form}@r{]}@r{)}@}{*}@r{)} @{@i{declaration}@}{*} @{@i{form}@}{*}} @result{} @i{@{@i{result}@}{*}} ++@code{let*} @i{@r{(}@{@i{var} | @r{(}@i{var} @r{[}@i{init-form}@r{]}@r{)}@}*@r{)} @{@i{declaration}@}* @{@i{form}@}*} @result{} @i{@{@i{result}@}*} + + @subsubheading Arguments and Values:: + +@@ -2417,7 +2435,7 @@ + @node progv, setq, let, Data and Control Flow Dictionary + @subsection progv [Special Operator] + +-@code{progv} @i{@i{symbols} @i{values} @{@i{form}@}{*}} @result{} @i{@{@i{result}@}{*}} ++@code{progv} @i{@i{symbols} @i{values} @{@i{form}@}*} @result{} @i{@{@i{result}@}*} + + @subsubheading Arguments and Values:: + +@@ -2462,7 +2480,7 @@ + + @subsubheading See Also:: + +-@ref{let; let*} ++@ref{let} + , @ref{Evaluation} + + @subsubheading Notes:: +@@ -2474,7 +2492,7 @@ + @node setq, psetq, progv, Data and Control Flow Dictionary + @subsection setq [Special Form] + +-@code{setq} @i{@{!@i{pair}@}{*}} @result{} @i{result} ++@code{setq} @i{@{!@i{pair}@}*} @result{} @i{result} + + @w{@i{pair} ::=var form} + +@@ -2541,18 +2559,19 @@ + , + @ref{set} + , +-@ref{setf; psetf} ++@ref{setf} + + @node psetq, block, setq, Data and Control Flow Dictionary + @subsection psetq [Macro] + +-@code{psetq} @i{@{!@i{pair}@}{*}} @result{} @i{@b{nil}} ++@code{psetq} @i{@{!@i{pair}@}*} @result{} @i{@b{nil}} + + @w{@i{pair} ::=var form} + + @subsubheading Pronunciation:: + +-@b{psetq}: pronounced {{{\vrule width 1pt height 2pt depth 2pt}\kern -1pt\raise 6pt{\vrule width 1pt height 2pt depth 2pt}}}p\=e'set ,ky\"u ++@b{psetq}: pronounced @tex p\=e'set ,ky\"u ++@end tex + + @subsubheading Arguments and Values:: + +@@ -2621,7 +2640,7 @@ + @node block, catch, psetq, Data and Control Flow Dictionary + @subsection block [Special Operator] + +-@code{block} @i{@i{name} @i{form}@r{*}} @result{} @i{@{@i{result}@}{*}} ++@code{block} @i{@i{name} @i{form}@r{*}} @result{} @i{@{@i{result}@}*} + + @subsubheading Arguments and Values:: + +@@ -2681,7 +2700,7 @@ + @node catch, go, block, Data and Control Flow Dictionary + @subsection catch [Special Operator] + +-@code{catch} @i{@i{tag} @{@i{form}@}{*}} @result{} @i{@{@i{result}@}{*}} ++@code{catch} @i{@i{tag} @{@i{form}@}*} @result{} @i{@{@i{result}@}*} + + @subsubheading Arguments and Values:: + +@@ -2980,7 +2999,7 @@ + @node tagbody, throw, return, Data and Control Flow Dictionary + @subsection tagbody [Special Operator] + +-@code{tagbody} @i{@{@i{tag} | @i{statement}@}{*}} @result{} @i{@b{nil}} ++@code{tagbody} @i{@{@i{tag} | @i{statement}@}*} @result{} @i{@b{nil}} + + @subsubheading Arguments and Values:: + +@@ -3060,6 +3079,7 @@ + + The @i{macros} in Figure 5--10 have @i{implicit tagbodies}. + ++@format + @group + @noindent + @w{ do do-external-symbols dotimes } +@@ -3070,6 +3090,7 @@ + @w{ Figure 5--10: Macros that have implicit tagbodies.} + + @end group ++@end format + + @node throw, unwind-protect, tagbody, Data and Control Flow Dictionary + @subsection throw [Special Operator] +@@ -3175,7 +3196,7 @@ + @node unwind-protect, nil, throw, Data and Control Flow Dictionary + @subsection unwind-protect [Special Operator] + +-@code{unwind-protect} @i{@i{protected-form} @{@i{cleanup-form}@}{*}} @result{} @i{@{@i{result}@}{*}} ++@code{unwind-protect} @i{@i{protected-form} @{@i{cleanup-form}@}*} @result{} @i{@{@i{result}@}*} + + @subsubheading Arguments and Values:: + +@@ -3519,7 +3540,7 @@ + , + @ref{equalp} + , +-@ref{=; /=; <; >; <=; >=} ++@ref{=} + , + @ref{Compilation} + +@@ -3544,6 +3565,7 @@ + rather than @b{eql} in a way that cannot be overridden by the + @i{code} which employs them: + ++@format + @group + @noindent + @w{ catch getf throw } +@@ -3554,6 +3576,7 @@ + @w{ Figure 5--11: Operators that always prefer EQ over EQL} + + @end group ++@end format + + @node eql, equal, eq, Data and Control Flow Dictionary + @subsection eql [Function] +@@ -3631,9 +3654,9 @@ + , + @ref{equalp} + , +-@ref{=; /=; <; >; <=; >=} ++@ref{=} + , +-@ref{char=; char/=; char<; char>; char<=; char>=; char-equal; char-not-equal; char-lessp; char-greaterp; char-not-greaterp; char-not-lessp} ++@ref{char=} + + @subsubheading Notes:: + +@@ -3731,6 +3754,7 @@ + with upper + entries taking priority over lower ones. + ++@format + @group + @noindent + @w{ Type Behavior } +@@ -3749,6 +3773,7 @@ + @w{ Figure 5--12: Summary and priorities of behavior of @b{equal}} + + @end group ++@end format + + Any two @i{objects} that are @b{eql} are also @b{equal}. + +@@ -3783,11 +3808,11 @@ + , + @ref{equalp} + , +-@ref{=; /=; <; >; <=; >=} ++@ref{=} + , +-@ref{string=; string/=; string<; string>; string<=; string>=; string-equal; string-not-equal; string-lessp; string-greaterp; string-not-greaterp; string-not-lessp} ++@ref{string=} + , @b{string-equal}, +-@ref{char=; char/=; char<; char>; char<=; char>=; char-equal; char-not-equal; char-lessp; char-greaterp; char-not-greaterp; char-not-lessp} ++@ref{char=} + , + @b{char-equal}, + @ref{tree-equal} +@@ -3869,6 +3894,7 @@ + with upper + entries taking priority over lower ones. + ++@format + @group + @noindent + @w{ Type Behavior } +@@ -3887,6 +3913,7 @@ + @w{ Figure 5--13: Summary and priorities of behavior of @b{equalp}} + + @end group ++@end format + + @subsubheading Examples:: + +@@ -3928,11 +3955,11 @@ + , + @ref{equal} + , +-@ref{=; /=; <; >; <=; >=} ++@ref{=} + , +-@ref{string=; string/=; string<; string>; string<=; string>=; string-equal; string-not-equal; string-lessp; string-greaterp; string-not-greaterp; string-not-lessp} ++@ref{string=} + , @b{string-equal}, +-@ref{char=; char/=; char<; char>; char<=; char>=; char-equal; char-not-equal; char-lessp; char-greaterp; char-not-greaterp; char-not-lessp} ++@ref{char=} + , + @b{char-equal} + +@@ -4089,13 +4116,13 @@ + @node every, and, constantly, Data and Control Flow Dictionary + @subsection every, some, notevery, notany [Function] + +-@code{every} @i{predicate {&rest} sequences^+} @result{} @i{generalized-boolean} ++@code{every} @i{predicate @r{&rest} sequences^+} @result{} @i{generalized-boolean} + +-@code{some} @i{predicate {&rest} sequences^+} @result{} @i{result} ++@code{some} @i{predicate @r{&rest} sequences^+} @result{} @i{result} + +-@code{notevery} @i{predicate {&rest} sequences^+} @result{} @i{generalized-boolean} ++@code{notevery} @i{predicate @r{&rest} sequences^+} @result{} @i{generalized-boolean} + +-@code{notany} @i{predicate {&rest} sequences^+} @result{} @i{generalized-boolean} ++@code{notany} @i{predicate @r{&rest} sequences^+} @result{} @i{generalized-boolean} + + @subsubheading Arguments and Values:: + +@@ -4178,14 +4205,14 @@ + @subsubheading Notes:: + + @example +- (notany @i{predicate} @{@i{sequence}@}{*}) @equiv{} (not (some @i{predicate} @{@i{sequence}@}{*})) +- (notevery @i{predicate} @{@i{sequence}@}{*}) @equiv{} (not (every @i{predicate} @{@i{sequence}@}{*})) ++ (notany @i{predicate} @{@i{sequence}@}*) @equiv{} (not (some @i{predicate} @{@i{sequence}@}*)) ++ (notevery @i{predicate} @{@i{sequence}@}*) @equiv{} (not (every @i{predicate} @{@i{sequence}@}*)) + @end example + + @node and, cond, every, Data and Control Flow Dictionary + @subsection and [Macro] + +-@code{and} @i{@{@i{form}@}{*}} @result{} @i{@{@i{result}@}{*}} ++@code{and} @i{@{@i{form}@}*} @result{} @i{@{@i{result}@}*} + + @subsubheading Arguments and Values:: + +@@ -4236,13 +4263,13 @@ + + @ref{cond} + , +-@ref{every; some; notevery; notany} ++@ref{every} + , + @ref{if} + , + @ref{or} + , +-@ref{when; unless} ++@ref{when} + + @subsubheading Notes:: + +@@ -4254,9 +4281,9 @@ + @node cond, if, and, Data and Control Flow Dictionary + @subsection cond [Macro] + +-@code{cond} @i{@{!@i{clause}@}{*}} @result{} @i{@{@i{result}@}{*}} ++@code{cond} @i{@{!@i{clause}@}*} @result{} @i{@{@i{result}@}*} + +-@w{@i{clause} ::=@r{(}test-form @{@i{form}@}{*}@r{)}} ++@w{@i{clause} ::=@r{(}test-form @{@i{form}@}*@r{)}} + + @subsubheading Arguments and Values:: + +@@ -4312,13 +4339,13 @@ + + @ref{if} + , +-@ref{case; ccase; ecase} ++@ref{case} + . + + @node if, or, cond, Data and Control Flow Dictionary + @subsection if [Special Operator] + +-@code{if} @i{@i{test-form} @i{then-form} @r{[}@i{else-form}@r{]}} @result{} @i{@{@i{result}@}{*}} ++@code{if} @i{@i{test-form} @i{then-form} @r{[}@i{else-form}@r{]}} @result{} @i{@{@i{result}@}*} + + @subsubheading Arguments and Values:: + +@@ -4365,7 +4392,7 @@ + @ref{cond} + , + @b{unless}, +-@ref{when; unless} ++@ref{when} + + @subsubheading Notes:: + +@@ -4377,7 +4404,7 @@ + @node or, when, if, Data and Control Flow Dictionary + @subsection or [Macro] + +-@code{or} @i{@{@i{form}@}{*}} @result{} @i{@{@i{results}@}{*}} ++@code{or} @i{@{@i{form}@}*} @result{} @i{@{@i{results}@}*} + + @subsubheading Arguments and Values:: + +@@ -4428,9 +4455,9 @@ + @node when, case, or, Data and Control Flow Dictionary + @subsection when, unless [Macro] + +-@code{when} @i{test-form @{@i{form}@}{*}} @result{} @i{@{@i{result}@}{*}} ++@code{when} @i{test-form @{@i{form}@}*} @result{} @i{@{@i{result}@}*} + +-@code{unless} @i{test-form @{@i{form}@}{*}} @result{} @i{@{@i{result}@}{*}} ++@code{unless} @i{test-form @{@i{form}@}*} @result{} @i{@{@i{result}@}*} + + @subsubheading Arguments and Values:: + +@@ -4520,15 +4547,15 @@ + @node case, typecase, when, Data and Control Flow Dictionary + @subsection case, ccase, ecase [Macro] + +-@code{case} @i{keyform @{!@i{normal-clause}@}{*} @r{[}!@i{otherwise-clause}@r{]}} @result{} @i{@{@i{result}@}{*}} ++@code{case} @i{keyform @{!@i{normal-clause}@}* @r{[}!@i{otherwise-clause}@r{]}} @result{} @i{@{@i{result}@}*} + +-@code{ccase} @i{keyplace @{!@i{normal-clause}@}{*}} @result{} @i{@{@i{result}@}{*}} ++@code{ccase} @i{keyplace @{!@i{normal-clause}@}*} @result{} @i{@{@i{result}@}*} + +-@code{ecase} @i{keyform @{!@i{normal-clause}@}{*}} @result{} @i{@{@i{result}@}{*}} ++@code{ecase} @i{keyform @{!@i{normal-clause}@}*} @result{} @i{@{@i{result}@}*} + +-@w{@i{normal-clause} ::=@r{(}keys @{@i{form}@}{*}@r{)}} ++@w{@i{normal-clause} ::=@r{(}keys @{@i{form}@}*@r{)}} + +-@w{@i{otherwise-clause} ::=@r{(}@{otherwise | t@} @{@i{form}@}{*}@r{)}} ++@w{@i{otherwise-clause} ::=@r{(}@{otherwise | t@} @{@i{form}@}*@r{)}} + + @w{@i{clause} ::=normal-clause | otherwise-clause} + +@@ -4668,9 +4695,9 @@ + + @ref{cond} + , +-@ref{typecase; ctypecase; etypecase} ++@ref{typecase} + , +-@ref{setf; psetf} ++@ref{setf} + , + @ref{Generalized Reference} + +@@ -4678,10 +4705,10 @@ + + @example + (case @i{test-key} +- @{((@{@i{key}@}{*}) @{@i{form}@}{*})@}{*}) ++ @{((@{@i{key}@}*) @{@i{form}@}*)@}*) + @equiv{} + (let ((#1=#:g0001 @i{test-key})) +- (cond @{((member #1# '(@{@i{key}@}{*})) @{@i{form}@}{*})@}{*})) ++ (cond @{((member #1# '(@{@i{key}@}*)) @{@i{form}@}*)@}*)) + @end example + + The specific error message used by @b{ecase} and @b{ccase} can vary +@@ -4693,15 +4720,15 @@ + @node typecase, multiple-value-bind, case, Data and Control Flow Dictionary + @subsection typecase, ctypecase, etypecase [Macro] + +-@code{typecase} @i{keyform @{!@i{normal-clause}@}{*} @r{[}!@i{otherwise-clause}@r{]}} @result{} @i{@{@i{result}@}{*}} ++@code{typecase} @i{keyform @{!@i{normal-clause}@}* @r{[}!@i{otherwise-clause}@r{]}} @result{} @i{@{@i{result}@}*} + +-@code{ctypecase} @i{keyplace @{!@i{normal-clause}@}{*}} @result{} @i{@{@i{result}@}{*}} ++@code{ctypecase} @i{keyplace @{!@i{normal-clause}@}*} @result{} @i{@{@i{result}@}*} + +-@code{etypecase} @i{keyform @{!@i{normal-clause}@}{*}} @result{} @i{@{@i{result}@}{*}} ++@code{etypecase} @i{keyform @{!@i{normal-clause}@}*} @result{} @i{@{@i{result}@}*} + +-@w{@i{normal-clause} ::=@r{(}type @{@i{form}@}{*}@r{)}} ++@w{@i{normal-clause} ::=@r{(}type @{@i{form}@}*@r{)}} + +-@w{@i{otherwise-clause} ::=@r{(}@{otherwise | t@} @{@i{form}@}{*}@r{)}} ++@w{@i{otherwise-clause} ::=@r{(}@{otherwise | t@} @{@i{form}@}*@r{)}} + + @w{@i{clause} ::=normal-clause | otherwise-clause} + +@@ -4846,11 +4873,11 @@ + + @subsubheading See Also:: + +-@ref{case; ccase; ecase} ++@ref{case} + , + @ref{cond} + , +-@ref{setf; psetf} ++@ref{setf} + , + @ref{Generalized Reference} + +@@ -4858,10 +4885,10 @@ + + @example + (typecase @i{test-key} +- @{(@i{type} @{@i{form}@}{*})@}{*}) ++ @{(@i{type} @{@i{form}@}*)@}*) + @equiv{} + (let ((#1=#:g0001 @i{test-key})) +- (cond @{((typep #1# '@i{type}) @{@i{form}@}{*})@}{*})) ++ (cond @{((typep #1# '@i{type}) @{@i{form}@}*)@}*)) + @end example + + The specific error message used by @b{etypecase} and @b{ctypecase} can vary +@@ -4873,11 +4900,11 @@ + @node multiple-value-bind, multiple-value-call, typecase, Data and Control Flow Dictionary + @subsection multiple-value-bind [Macro] + +-@code{multiple-value-bind} @i{@r{(}@{@i{var}@}{*}@r{)} ++@code{multiple-value-bind} @i{@r{(}@{@i{var}@}*@r{)} + @i{values-form} +- @{@i{declaration}@}{*} +- @{@i{form}@}{*}}@* +- @result{} @i{@{@i{result}@}{*}} ++ @{@i{declaration}@}* ++ @{@i{form}@}*}@* ++ @result{} @i{@{@i{result}@}*} + + @subsubheading Arguments and Values:: + +@@ -4924,24 +4951,24 @@ + + @subsubheading See Also:: + +-@ref{let; let*} ++@ref{let} + , + @ref{multiple-value-call} + + @subsubheading Notes:: + + @example +- (multiple-value-bind (@{@i{var}@}{*}) @i{values-form} @{@i{form}@}{*}) +- @equiv{} (multiple-value-call #'(lambda (&optional @{@i{var}@}{*} &rest #1=#:ignore) ++ (multiple-value-bind (@{@i{var}@}*) @i{values-form} @{@i{form}@}*) ++ @equiv{} (multiple-value-call #'(lambda (&optional @{@i{var}@}* &rest #1=#:ignore) + (declare (ignore #1#)) +- @{@i{form}@}{*}) ++ @{@i{form}@}*) + @i{values-form}) + @end example + + @node multiple-value-call, multiple-value-list, multiple-value-bind, Data and Control Flow Dictionary + @subsection multiple-value-call [Special Operator] + +-@code{multiple-value-call} @i{@i{function-form} @i{form}@r{*}} @result{} @i{@{@i{result}@}{*}} ++@code{multiple-value-call} @i{@i{function-form} @i{form}@r{*}} @result{} @i{@{@i{result}@}*} + + @subsubheading Arguments and Values:: + +@@ -5021,9 +5048,9 @@ + @node multiple-value-prog1, multiple-value-setq, multiple-value-list, Data and Control Flow Dictionary + @subsection multiple-value-prog1 [Special Operator] + +-@code{multiple-value-prog} @i{1} @result{} @i{first-form @{@i{form}@}{*}} ++@code{multiple-value-prog} @i{1} @result{} @i{first-form @{@i{form}@}*} + +- {first-form-results} ++ @r{first-form-results} + + @subsubheading Arguments and Values:: + +@@ -5052,7 +5079,7 @@ + + @subsubheading See Also:: + +-@ref{prog1; prog2} ++@ref{prog1} + + @node multiple-value-setq, values, multiple-value-prog1, Data and Control Flow Dictionary + @subsection multiple-value-setq [Macro] +@@ -5126,9 +5153,9 @@ + @node values, values-list, multiple-value-setq, Data and Control Flow Dictionary + @subsection values [Accessor] + +-@code{values} @i{{&rest} object} @result{} @i{@{@i{object}@}{*}} ++@code{values} @i{@r{&rest} object} @result{} @i{@{@i{object}@}*} + +-(setf (@code{ values} @i{{&rest} place}) new-values)@* ++(setf (@code{ values} @i{@r{&rest} place}) new-values)@* + + @subsubheading Arguments and Values:: + +@@ -5206,7 +5233,7 @@ + @node values-list, multiple-values-limit, values, Data and Control Flow Dictionary + @subsection values-list [Function] + +-@code{values-list} @i{list} @result{} @i{@{@i{element}@}{*}} ++@code{values-list} @i{list} @result{} @i{@{@i{element}@}*} + + @subsubheading Arguments and Values:: + +@@ -5331,16 +5358,16 @@ + @subsection prog, prog* [Macro] + + @code{prog} @i{@r{(}@{@i{var} | +- @r{(}@i{var} @r{[}@i{init-form}@r{]}@r{)}@}{*}@r{)} +- @{@i{declaration}@}{*} +- @{@i{tag} | @i{statement}@}{*}}@* +- @result{} @i{@{@i{result}@}{*}} ++ @r{(}@i{var} @r{[}@i{init-form}@r{]}@r{)}@}*@r{)} ++ @{@i{declaration}@}* ++ @{@i{tag} | @i{statement}@}*}@* ++ @result{} @i{@{@i{result}@}*} + + @code{prog*} @i{@r{(}@{@i{var} | +- @r{(}@i{var} @r{[}@i{init-form}@r{]}@r{)}@}{*}@r{)} +- @{@i{declaration}@}{*} +- @{@i{tag} | @i{statement}@}{*}}@* +- @result{} @i{@{@i{result}@}{*}} ++ @r{(}@i{var} @r{[}@i{init-form}@r{]}@r{)}@}*@r{)} ++ @{@i{declaration}@}* ++ @{@i{tag} | @i{statement}@}*}@* ++ @result{} @i{@{@i{result}@}*} + + @subsubheading Arguments and Values:: + +@@ -5369,7 +5396,7 @@ + + @example + (prog (var1 var2 (var3 init-form-3) var4 (var5 init-form-5)) +- @{@i{declaration}@}{*} ++ @{@i{declaration}@}* + statement1 + tag1 + statement2 +@@ -5457,7 +5484,7 @@ + + @ref{block} + , +-@ref{let; let*} ++@ref{let} + , + @ref{tagbody} + , +@@ -5479,10 +5506,10 @@ + @node prog1, progn, prog, Data and Control Flow Dictionary + @subsection prog1, prog2 [Macro] + +-@code{prog} @i{1} @result{} @i{first-form @{@i{form}@}{*}} +- {result-1} +-@code{prog} @i{2} @result{} @i{first-form second-form @{@i{form}@}{*}} +- {result-2} ++@code{prog} @i{1} @result{} @i{first-form @{@i{form}@}*} ++ @r{result-1} ++@code{prog} @i{2} @result{} @i{first-form second-form @{@i{form}@}*} ++ @r{result-2} + + @subsubheading Arguments and Values:: + +@@ -5553,14 +5580,14 @@ + must be computed before some or all of the side effects happen. + + @example +- (prog1 @{@i{form}@}{*}) @equiv{} (values (multiple-value-prog1 @{@i{form}@}{*})) +- (prog2 @i{form1} @{@i{form}@}{*}) @equiv{} (let () @i{form1} (prog1 @{@i{form}@}{*})) ++ (prog1 @{@i{form}@}*) @equiv{} (values (multiple-value-prog1 @{@i{form}@}*)) ++ (prog2 @i{form1} @{@i{form}@}*) @equiv{} (let () @i{form1} (prog1 @{@i{form}@}*)) + @end example + + @node progn, define-modify-macro, prog1, Data and Control Flow Dictionary + @subsection progn [Special Operator] + +-@code{progn} @i{@{@i{form}@}{*}} @result{} @i{@{@i{result}@}{*}} ++@code{progn} @i{@{@i{form}@}*} @result{} @i{@{@i{result}@}*} + + @subsubheading Arguments and Values:: + +@@ -5593,7 +5620,7 @@ + + @subsubheading See Also:: + +-@ref{prog1; prog2} ++@ref{prog1} + , @b{prog2}, @ref{Evaluation} + + @subsubheading Notes:: +@@ -5690,7 +5717,7 @@ + @ref{define-setf-expander} + , + +-@ref{documentation; (setf documentation)} ++@ref{documentation} + , + @ref{Syntactic Interaction of Documentation Strings and Declarations} + +@@ -5704,8 +5731,8 @@ + + The ``long form'': + +-@code{defsetf} @i{access-fn lambda-list @r{(}@{@i{store-variable}@}{*}@r{)} +- {[[@{@i{declaration}@}{*} | @i{documentation}]]} @{@i{form}@}{*}}@* ++@code{defsetf} @i{access-fn lambda-list @r{(}@{@i{store-variable}@}*@r{)} ++ @r{[[@{@i{declaration}@}* | @i{documentation}]]} @{@i{form}@}*}@* + @result{} @i{access-fn} + + @subsubheading Arguments and Values:: +@@ -5870,9 +5897,9 @@ + + @subsubheading See Also:: + +-@ref{documentation; (setf documentation)} ++@ref{documentation} + , +-@ref{setf; psetf} ++@ref{setf} + , + + @ref{define-setf-expander} +@@ -5913,7 +5940,7 @@ + @subsection define-setf-expander [Macro] + + @code{define-setf-expander} @i{access-fn lambda-list +- {[[@{@i{declaration}@}{*} | @i{documentation}]]} @{@i{form}@}{*}}@* ++ @r{[[@{@i{declaration}@}* | @i{documentation}]]} @{@i{form}@}*}@* + @result{} @i{access-fn} + + @subsubheading Arguments and Values:: +@@ -6025,11 +6052,11 @@ + + @subsubheading See Also:: + +-@ref{setf; psetf} ++@ref{setf} + , + @ref{defsetf} + , +-@ref{documentation; (setf documentation)} ++@ref{documentation} + , + @ref{get-setf-expansion} + , +@@ -6049,7 +6076,7 @@ + @node get-setf-expansion, setf, define-setf-expander, Data and Control Flow Dictionary + @subsection get-setf-expansion [Function] + +-@code{get-setf-expansion} @i{place {&optional} environment}@* ++@code{get-setf-expansion} @i{place @r{&optional} environment}@* + @result{} @i{vars, vals, store-vars, writer-form, reader-form} + + @subsubheading Arguments and Values:: +@@ -6102,7 +6129,7 @@ + , + @ref{define-setf-expander} + , +-@ref{setf; psetf} ++@ref{setf} + + @subsubheading Notes:: + +@@ -6113,9 +6140,9 @@ + @node setf, shiftf, get-setf-expansion, Data and Control Flow Dictionary + @subsection setf, psetf [Macro] + +-@code{setf} @i{@{!@i{pair}@}{*}} @result{} @i{@{@i{result}@}{*}} ++@code{setf} @i{@{!@i{pair}@}*} @result{} @i{@{@i{result}@}*} + +-@code{psetf} @i{@{!@i{pair}@}{*}} @result{} @i{@b{nil}} ++@code{psetf} @i{@{!@i{pair}@}*} @result{} @i{@b{nil}} + + @w{@i{pair} ::=place newvalue} + +@@ -6276,7 +6303,7 @@ + + @subsubheading See Also:: + +-@ref{setf; psetf} ++@ref{setf} + , + @ref{rotatef} + , @ref{Generalized Reference} +@@ -6315,7 +6342,7 @@ + @node rotatef, control-error, shiftf, Data and Control Flow Dictionary + @subsection rotatef [Macro] + +-@code{rotatef} @i{@{@i{place}@}{*}} @result{} @i{@b{nil}} ++@code{rotatef} @i{@{@i{place}@}*} @result{} @i{@b{nil}} + + @subsubheading Arguments and Values:: + +@@ -6358,7 +6385,7 @@ + , + @ref{defsetf} + , +-@ref{setf; psetf} ++@ref{setf} + , + @ref{shiftf} + , +diff -uNr gcl-texi-orig/chap-6.texi gcl-texi/chap-6.texi +--- gcl-texi-orig/chap-6.texi 1994-07-16 18:03:17 +0400 ++++ gcl-texi/chap-6.texi 2002-10-17 20:53:05 +0400 +@@ -889,7 +889,7 @@ + subsequent iterations. If @i{form2} is omitted, the construct + uses @i{form1} on the second and + subsequent iterations. +-The @i{loop keywords} {=} and @t{then} serve as valid prepositions ++The @i{loop keywords} @r{=} and @t{then} serve as valid prepositions + in this syntax. + This construct does not provide any termination tests. + +@@ -981,12 +981,12 @@ + In effect + + @t{being} +-@{{each} | @t{the}@} +-@{{hash-value} | ++@{@t{each} | @t{the}@} ++@{@t{hash-value} | + @t{hash-values} | + @t{hash-key} | + @t{hash-keys}@} +-@{{in} | @t{of}@} ++@{@t{in} | @t{of}@} + + is a compound preposition. + +@@ -1059,14 +1059,14 @@ + In effect + + @t{being} +-@{{each} | @t{the}@} +-@{{symbol} | ++@{@t{each} | @t{the}@} ++@{@t{symbol} | + @t{symbols} | + @t{present-symbol} | + @t{present-symbols} | + @t{external-symbol} | + @t{external-symbols}@} +-@{{in} | @t{of}@} ++@{@t{in} | @t{of}@} + + is a compound preposition. + +@@ -2099,15 +2099,15 @@ + @node do, dotimes, Iteration Dictionary, Iteration Dictionary + @subsection do, do* [Macro] + +-@code{do} @i{@r{(}@{@i{var} | @r{(}@i{var} @r{[}init-form @r{[}step-form@r{]}@r{]}@r{)}@}{*}@r{)} +- @r{(}end-test-form @{@i{result-form}@}{*}@r{)} +- @{@i{declaration}@}{*} @{tag | statement@}{*}}@* +- @result{} @i{@{@i{result}@}{*}} +- +-@code{do*} @i{@r{(}@{@i{var} | @r{(}@i{var} @r{[}init-form @r{[}step-form@r{]}@r{]}@r{)}@}{*}@r{)} +- @r{(}end-test-form {@{@i{result-form}@}{*}}@r{)} +- @{@i{declaration}@}{*} @{tag | statement@}{*}}@* +- @result{} @i{@{@i{result}@}{*}} ++@code{do} @i{@r{(}@{@i{var} | @r{(}@i{var} @r{[}init-form @r{[}step-form@r{]}@r{]}@r{)}@}*@r{)} ++ @r{(}end-test-form @{@i{result-form}@}*@r{)} ++ @{@i{declaration}@}* @{tag | statement@}*}@* ++ @result{} @i{@{@i{result}@}*} ++ ++@code{do*} @i{@r{(}@{@i{var} | @r{(}@i{var} @r{[}init-form @r{[}step-form@r{]}@r{]}@r{)}@}*@r{)} ++ @r{(}end-test-form @r{@{@i{result-form}@}*}@r{)} ++ @{@i{declaration}@}* @{tag | statement@}*}@* ++ @result{} @i{@{@i{result}@}*} + + @subsubheading Arguments and Values:: + +@@ -2337,7 +2337,7 @@ + @ref{return} + , + +-@ref{let; let*} ++@ref{let} + , and + @ref{setq} + ) +@@ -2377,9 +2377,9 @@ + @subsection dotimes [Macro] + + @code{dotimes} @i{@r{(}var count-form @r{[}result-form@r{]}@r{)} +- @{@i{declaration}@}{*} +- @{tag | statement@}{*}}@* +- @result{} @i{@{@i{result}@}{*}} ++ @{@i{declaration}@}* ++ @{tag | statement@}*}@* ++ @result{} @i{@{@i{result}@}*} + + @subsubheading Arguments and Values:: + +@@ -2481,7 +2481,7 @@ + + @subsubheading See Also:: + +-@ref{do; do*} ++@ref{do} + , + @ref{dolist} + , +@@ -2496,9 +2496,9 @@ + @subsection dolist [Macro] + + @code{dolist} @i{@r{(}var list-form @r{[}result-form@r{]}@r{)} +- @{@i{declaration}@}{*} +- @{tag | statement@}{*}}@* +- @result{} @i{@{@i{result}@}{*}} ++ @{@i{declaration}@}* ++ @{tag | statement@}*}@* ++ @result{} @i{@{@i{result}@}*} + + @subsubheading Arguments and Values:: + +@@ -2569,7 +2569,7 @@ + + @subsubheading See Also:: + +-@ref{do; do*} ++@ref{do} + , + @ref{dotimes} + , +@@ -2588,44 +2588,44 @@ + + The ``simple'' @b{loop} @i{form}: + +-@code{loop} @i{@{@i{compound-form}@}{*}} @result{} @i{@{@i{result}@}{*}} ++@code{loop} @i{@{@i{compound-form}@}*} @result{} @i{@{@i{result}@}*} + + The ``extended'' @b{loop} @i{form}: + + @code{loop} @i{@r{[}!@i{name-clause}@r{]} +- @{!@i{variable-clause}@}{*} +- @{!@i{main-clause}@}{*}} @result{} @i{@{@i{result}@}{*}} ++ @{!@i{variable-clause}@}* ++ @{!@i{main-clause}@}*} @result{} @i{@{@i{result}@}*} + + @w{@i{name-clause} ::=@t{named} @i{name}} + + @w{@i{variable-clause} ::=!@i{with-clause} | !@i{initial-final} | !@i{for-as-clause}} + +-@w{@i{with-clause} ::=@t{with} @i{var1} @r{[}@i{type-spec}@r{]} @r{[}= @i{form1}@r{]} @{{and} @i{var2} @r{[}@i{type-spec}@r{]} @r{[}= @i{form2}@r{]}@}{*}} ++@w{@i{with-clause} ::=@t{with} @i{var1} @r{[}@i{type-spec}@r{]} @r{[}= @i{form1}@r{]} @{@t{and} @i{var2} @r{[}@i{type-spec}@r{]} @r{[}= @i{form2}@r{]}@}*} + + @w{@i{main-clause} ::=!@i{unconditional} | !@i{accumulation} | !@i{conditional} | !@i{termination-test} | !@i{initial-final}} + + @w{@i{initial-final} ::=@t{initially} @{@i{compound-form}@}^+ | @t{finally} @{@i{compound-form}@}^+} + +-@w{@i{unconditional} ::=@{{do} | @t{doing}@} @{@i{compound-form}@}^+ | @t{return} @{@i{form} | @t{it}@}} ++@w{@i{unconditional} ::=@{@t{do} | @t{doing}@} @{@i{compound-form}@}^+ | @t{return} @{@i{form} | @t{it}@}} + + @w{@i{accumulation} ::=!@i{list-accumulation} | !@i{numeric-accumulation}} + +-@w{@i{list-accumulation} ::=@{{collect} | @t{collecting} | @t{append} | @t{appending} | @t{nconc} | @t{nconcing}@} @{@i{form} | @t{it}@} } ++@w{@i{list-accumulation} ::=@{@t{collect} | @t{collecting} | @t{append} | @t{appending} | @t{nconc} | @t{nconcing}@} @{@i{form} | @t{it}@} } + @w{ @r{[}@t{into} @i{simple-var}@r{]}} + +-@w{@i{numeric-accumulation} ::=@{{count} | @t{counting} | @t{sum} | @t{summing} | @} ++@w{@i{numeric-accumulation} ::=@{@t{count} | @t{counting} | @t{sum} | @t{summing} | @} + @w{ @t{maximize} | @t{maximizing} | @t{minimize} | @t{minimizing}} @{@i{form} | @t{it}@} } + @w{ @r{[}@t{into} @i{simple-var}@r{]} @r{[}@i{type-spec}@r{]}} + +-@w{@i{conditional} ::=@{{if} | @t{when} | @t{unless}@} @i{form} !@i{selectable-clause} @{{and} !@i{selectable-clause}@}{*} } +-@w{ @r{[}@t{else} !@i{selectable-clause} @{{and} !@i{selectable-clause}@}{*}@r{]} } ++@w{@i{conditional} ::=@{@t{if} | @t{when} | @t{unless}@} @i{form} !@i{selectable-clause} @{@t{and} !@i{selectable-clause}@}* } ++@w{ @r{[}@t{else} !@i{selectable-clause} @{@t{and} !@i{selectable-clause}@}*@r{]} } + @w{ @r{[}@t{end}@r{]}} + + @w{@i{selectable-clause} ::=!@i{unconditional} | !@i{accumulation} | !@i{conditional}} + + @w{@i{termination-test} ::=@t{while} @i{form} | @t{until} @i{form} | @t{repeat} @i{form} | @t{always} @i{form} | @t{never} @i{form} | @t{thereis} @i{form}} + +-@w{@i{for-as-clause} ::=@{{for} | @t{as}@} !@i{for-as-subclause} @{{and} !@i{for-as-subclause}@}{*}} ++@w{@i{for-as-clause} ::=@{@t{for} | @t{as}@} !@i{for-as-subclause} @{@t{and} !@i{for-as-subclause}@}*} + + @w{@i{for-as-subclause} ::=!@i{for-as-arithmetic} | !@i{for-as-in-list} | !@i{for-as-on-list} | !@i{for-as-equals-then} |} + @w{ !@i{for-as-across} | !@i{for-as-hash} | !@i{for-as-package}} +@@ -2634,11 +2634,11 @@ + + @w{@i{for-as-arithmetic-subclause} ::=!@i{arithmetic-up} | !@i{arithmetic-downto} | !@i{arithmetic-downfrom}} + +-@w{@i{arithmetic-up} ::=[[@{{from} | @t{upfrom}@} @i{form1} | @{{to} | @t{upto} | @t{below}@} @i{form2} | @t{by} @i{form3}]]^+} ++@w{@i{arithmetic-up} ::=[[@{@t{from} | @t{upfrom}@} @i{form1} | @{@t{to} | @t{upto} | @t{below}@} @i{form2} | @t{by} @i{form3}]]^+} + +-@w{@i{arithmetic-downto} ::=[[@{{from} @i{form1}@}^1 | @{@{{downto} | @t{above}@} @i{form2}@}^1 | @t{by} @i{form3}]]} ++@w{@i{arithmetic-downto} ::=[[@{@t{from} @i{form1}@}^1 | @{@{@t{downto} | @t{above}@} @i{form2}@}^1 | @t{by} @i{form3}]]} + +-@w{@i{arithmetic-downfrom} ::=[[@{{downfrom} @i{form1}@}^1 | @{{to} | @t{downto} | @t{above}@} @i{form2} | @t{by} @i{form3}]]} ++@w{@i{arithmetic-downfrom} ::=[[@{@t{downfrom} @i{form1}@}^1 | @{@t{to} | @t{downto} | @t{above}@} @i{form2} | @t{by} @i{form3}]]} + + @w{@i{for-as-in-list} ::=@i{var} @r{[}@i{type-spec}@r{]} @t{in} @i{form1} @r{[}@t{by} @i{step-fun}@r{]}} + +@@ -2648,17 +2648,17 @@ + + @w{@i{for-as-across} ::=@i{var} @r{[}@i{type-spec}@r{]} @t{across} @i{vector}} + +-@w{@i{for-as-hash} ::=@i{var} @r{[}@i{type-spec}@r{]} @t{being} @{{each} | @t{the}@} } +-@w{ @{@{{hash-key} | @t{hash-keys}@} @{{in} | @t{of}@} @i{hash-table} } ++@w{@i{for-as-hash} ::=@i{var} @r{[}@i{type-spec}@r{]} @t{being} @{@t{each} | @t{the}@} } ++@w{ @{@{@t{hash-key} | @t{hash-keys}@} @{@t{in} | @t{of}@} @i{hash-table} } + @w{ @r{[}@t{using} @r{(}@t{hash-value} @i{other-var}@r{)}@r{]} | } +-@w{ @{{hash-value} | @t{hash-values}@} @{{in} | @t{of}@} @i{hash-table} } ++@w{ @{@t{hash-value} | @t{hash-values}@} @{@t{in} | @t{of}@} @i{hash-table} } + @w{ @r{[}@t{using} @r{(}@t{hash-key} @i{other-var}@r{)}@r{]}@}} + +-@w{@i{for-as-package} ::=@i{var} @r{[}@i{type-spec}@r{]} @t{being} @{{each} | @t{the}@} } +-@w{ @{{symbol} | @t{symbols} |} ++@w{@i{for-as-package} ::=@i{var} @r{[}@i{type-spec}@r{]} @t{being} @{@t{each} | @t{the}@} } ++@w{ @{@t{symbol} | @t{symbols} |} + @w{ @t{present-symbol} | @t{present-symbols} |} + @w{ @t{external-symbol} | @t{external-symbols}@} } +-@w{ @r{[}@{{in} | @t{of}@} @i{package}@r{]}} ++@w{ @r{[}@{@t{in} | @t{of}@} @i{package}@r{]}} + + @w{@i{type-spec} ::=!@i{simple-type-spec} | !@i{destructured-type-spec}} + +@@ -2718,11 +2718,11 @@ + (format t "~&The square root of ~D is ~D.~ + @result{} SQRT-ADVISOR + (sqrt-advisor) +-@t{ |> } Number: @b{|>>}@t{5{@i{[<--}~]}}@b{<<|} ++@t{ |> } Number: @b{|>>}@t{5 @t{@i{[<--}~]}}@b{<<|} + @t{ |> } The square root of 5 is 2.236068. +-@t{ |> } Number: @b{|>>}@t{4{@i{[<--}~]}}@b{<<|} ++@t{ |> } Number: @b{|>>}@t{4 @t{@i{[<--}~]}}@b{<<|} + @t{ |> } The square root of 4 is 2. +-@t{ |> } Number: @b{|>>}@t{done{@i{[<--}~]}}@b{<<|} ++@t{ |> } Number: @b{|>>}@t{done @t{@i{[<--}~]}}@b{<<|} + @result{} NIL + + ;; An example of the extended form of LOOP. +@@ -2733,11 +2733,11 @@ + do (format t "~&The square of ~D is ~D.~ + @result{} SQUARE-ADVISOR + (square-advisor) +-@t{ |> } Number: @b{|>>}@t{4{@i{[<--}~]}}@b{<<|} ++@t{ |> } Number: @b{|>>}@t{4 @t{@i{[<--}~]}}@b{<<|} + @t{ |> } The square of 4 is 16. +-@t{ |> } Number: @b{|>>}@t{23{@i{[<--}~]}}@b{<<|} ++@t{ |> } Number: @b{|>>}@t{23 @t{@i{[<--}~]}}@b{<<|} + @t{ |> } The square of 23 is 529. +-@t{ |> } Number: @b{|>>}@t{done{@i{[<--}~]}}@b{<<|} ++@t{ |> } Number: @b{|>>}@t{done @t{@i{[<--}~]}}@b{<<|} + @result{} NIL + + ;; Another example of the extended form of LOOP. +@@ -2749,7 +2749,7 @@ + + @subsubheading See Also:: + +-@ref{do; do*} ++@ref{do} + , + @ref{dolist} + , +@@ -2770,7 +2770,7 @@ + in the following way: + + @example +- (loop @{@i{compound-form}@}{*}) @equiv{} (loop do @{@i{compound-form}@}{*}) ++ (loop @{@i{compound-form}@}*) @equiv{} (loop do @{@i{compound-form}@}*) + @end example + + @node loop-finish, , loop, Iteration Dictionary +diff -uNr gcl-texi-orig/chap-7.texi gcl-texi/chap-7.texi +--- gcl-texi-orig/chap-7.texi 1994-07-16 18:03:16 +0400 ++++ gcl-texi/chap-7.texi 2002-10-17 20:53:05 +0400 +@@ -187,7 +187,7 @@ + @i{lambda list} becomes an initialization argument for all @i{classes} + for which the @i{method} is applicable. + +-The presence of {&allow-other-keys} in the ++The presence of @t{&allow-other-keys} in the + @i{lambda list} of an applicable method disables validity checking of + initialization arguments. + +@@ -388,9 +388,10 @@ + + @center + @example ++@format + @group + @noindent +-@w{ {} Defaulted {} } ++@w{ @t{} Defaulted @t{} } + @w{ Form Initialization Argument List Contents of Slot X } + @w{ _____________________________________________________________________________} + @w{ @t{(make-instance 'r)} @t{(a 1 b 2)} @t{1} } +@@ -398,6 +399,7 @@ + @w{ @t{(make-instance 'r 'b 4)} @t{(b 4 a 1)} @t{4} } + @w{ @t{(make-instance 'r 'a 1 'a 2)} @t{(a 1 a 2 b 2)} @t{1} } + @end group ++@end format + + @end example + +@@ -607,10 +609,10 @@ + @c including concept-change-class + + The @i{function} @b{change-class} can be used to change the @i{class} +-of an @i{instance} from its current class, C_@{{from}@}, +-to a different class, C_@{{to}@}; it changes the ++of an @i{instance} from its current class, C_@{@r{from}@}, ++to a different class, C_@{@r{to}@}; it changes the + structure of the @i{instance} to conform to the definition of the class +-C_@{{to}@}. ++C_@{@r{to}@}. + + Note that changing the @i{class} of an @i{instance} may cause + @i{slots} to be added or deleted. Changing the @i{class} of an +@@ -634,14 +636,14 @@ + @node Modifying the Structure of the Instance, Initializing Newly Added Local Slots (Changing the Class of an Instance), Changing the Class of an Instance, Changing the Class of an Instance + @subsection Modifying the Structure of the Instance + +-In order to make the @i{instance} conform to the class C_@{{to}@}, @i{local slots} specified by the class C_@{{to}@} that are not specified by the class C_@{{from}@} are added, and @i{local slots} not specified by +-the class C_@{{to}@} that are specified by the +-class C_@{{from}@} are discarded. ++In order to make the @i{instance} conform to the class C_@{@r{to}@}, @i{local slots} specified by the class C_@{@r{to}@} that are not specified by the class C_@{@r{from}@} are added, and @i{local slots} not specified by ++the class C_@{@r{to}@} that are specified by the ++class C_@{@r{from}@} are discarded. + +-The values of @i{local slots} specified by both the class C_@{{to}@} and the class C_@{{from}@} are retained. If such a @i{local slot} was unbound, it remains ++The values of @i{local slots} specified by both the class C_@{@r{to}@} and the class C_@{@r{from}@} are retained. If such a @i{local slot} was unbound, it remains + unbound. + +-The values of @i{slots} specified as shared in the class C_@{{from}@} and as local in the class C_@{{to}@} are retained. ++The values of @i{slots} specified as shared in the class C_@{@r{from}@} and as local in the class C_@{@r{to}@} are retained. + + This first step of the update does not affect the values of any + @i{shared slots}. +@@ -659,10 +661,10 @@ + The generic function @b{update-instance-for-different-class} is + invoked on arguments computed by @b{change-class}. + The first argument passed is a copy of the @i{instance} being updated +-and is an @i{instance} of the class C_@{{from}@}; ++and is an @i{instance} of the class C_@{@r{from}@}; + this copy has @i{dynamic extent} within the generic function @b{change-class}. + The second argument is the @i{instance} as updated so far by @b{change-class} +-and is an @i{instance} of the class C_@{{to}@}. ++and is an @i{instance} of the class C_@{@r{to}@}. + The remaining arguments are an @i{initialization argument list}. + + There is a system-supplied primary @i{method} for +@@ -1156,6 +1158,7 @@ + their associated @i{forms} are called @i{method-defining forms}. + The @i{standardized} @i{method-defining operators} are listed in Figure 7--2. + ++@format + @group + @noindent + @w{ defgeneric defmethod defclass } +@@ -1165,6 +1168,7 @@ + @w{ Figure 7--2: Standardized Method-Defining Operators} + + @end group ++@end format + + Note that of the @i{standardized} @i{method-defining operators} + only @b{defgeneric} +@@ -1507,14 +1511,14 @@ + @table @asis + + @item 1. +-{Select the applicable methods.} ++@r{Select the applicable methods.} + + @item 2. +-{Sort the applicable methods by precedence order, putting ++@r{Sort the applicable methods by precedence order, putting + the most specific method first.} + + @item 3. +-{Apply method combination to the sorted list of ++@r{Apply method combination to the sorted list of + applicable methods, producing the effective method.} + + @end table +@@ -1773,6 +1777,7 @@ + + @IRindex{standard} + ++@format + @group + @noindent + @w{ + append max nconc progn } +@@ -1782,6 +1787,7 @@ + @w{ Figure 7--3: Built-in Method Combination Types} + + @end group ++@end format + + The semantics of the @b{standard} built-in method combination type is + described in @ref{Standard Method Combination}. The other +@@ -1999,7 +2005,7 @@ + @node ensure-generic-function, allocate-instance, function-keywords, Objects Dictionary + @subsection ensure-generic-function [Function] + +-@code{ensure-generic-function} @i{function-name {&key} ++@code{ensure-generic-function} @i{function-name @r{&key} + argument-precedence-order declare + documentation environment + generic-function-class lambda-list +@@ -2106,13 +2112,13 @@ + + @subsubheading Syntax:: + +-@code{allocate-instance} @i{class {&rest} initargs {&key} {&allow-other-keys}} @result{} @i{new-instance} ++@code{allocate-instance} @i{class @r{&rest} initargs @r{&key} @r{&allow-other-keys}} @result{} @i{new-instance} + + @subsubheading Method Signatures:: + +-@code{allocate-instance} @i{@r{(}@i{class} @b{standard-class}@r{)} {&rest} initargs} ++@code{allocate-instance} @i{@r{(}@i{class} @b{standard-class}@r{)} @r{&rest} initargs} + +-@code{allocate-instance} @i{@r{(}@i{class} @b{structure-class}@r{)} {&rest} initargs} ++@code{allocate-instance} @i{@r{(}@i{class} @b{structure-class}@r{)} @r{&rest} initargs} + + @subsubheading Arguments and Values:: + +@@ -2159,11 +2165,11 @@ + + @subsubheading Syntax:: + +-@code{reinitialize-instance} @i{instance {&rest} initargs {&key} {&allow-other-keys}} @result{} @i{instance} ++@code{reinitialize-instance} @i{instance @r{&rest} initargs @r{&key} @r{&allow-other-keys}} @result{} @i{instance} + + @subsubheading Method Signatures:: + +-@code{reinitialize-instance} @i{@r{(}@i{instance} @b{standard-object}@r{)} {&rest} initargs} ++@code{reinitialize-instance} @i{@r{(}@i{instance} @b{standard-object}@r{)} @r{&rest} initargs} + + @subsubheading Arguments and Values:: + +@@ -2232,11 +2238,11 @@ + + @subsubheading Syntax:: + +-@code{shared-initialize} @i{instance slot-names {&rest} initargs {&key} {&allow-other-keys}} @result{} @i{instance} ++@code{shared-initialize} @i{instance slot-names @r{&rest} initargs @r{&key} @r{&allow-other-keys}} @result{} @i{instance} + + @subsubheading Method Signatures:: + +-@code{shared-initialize} @i{@r{(}@i{instance} @b{standard-object}@r{)} slot-names {&rest} initargs} ++@code{shared-initialize} @i{@r{(}@i{instance} @b{standard-object}@r{)} slot-names @r{&rest} initargs} + + @subsubheading Arguments and Values:: + +@@ -2356,14 +2362,14 @@ + @subsubheading Syntax:: + + @code{update-instance-for-different-class} @i{previous current +- {&rest} initargs +- {&key} {&allow-other-keys}} @result{} @i{@i{implementation-dependent}} ++ @r{&rest} initargs ++ @r{&key} @r{&allow-other-keys}} @result{} @i{@i{implementation-dependent}} + + @subsubheading Method Signatures:: + + @code{update-instance-for-different-class} @i{@r{(}@i{previous} @b{standard-object}@r{)} + @r{(}@i{current} @b{standard-object}@r{)} +- {&rest} initargs} ++ @r{&rest} initargs} + + @subsubheading Arguments and Values:: + +@@ -2462,15 +2468,15 @@ + @code{update-instance-for-redefined-class} @i{instance + added-slots discarded-slots + property-list +- {&rest} initargs {&key} {&allow-other-keys}}@* +- @result{} @i{@{@i{result}@}{*}} ++ @r{&rest} initargs @r{&key} @r{&allow-other-keys}}@* ++ @result{} @i{@{@i{result}@}*} + + @subsubheading Method Signatures:: + + @code{update-instance-for-redefined-class} @i{@r{(}@i{instance} @b{standard-object}@r{)} + added-slots discarded-slots + property-list +- {&rest} initargs} ++ @r{&rest} initargs} + + @subsubheading Arguments and Values:: + +@@ -2610,17 +2616,17 @@ + + @subsubheading Syntax:: + +-@code{change-class} @i{instance new-class {&key} {&allow-other-keys}} @result{} @i{instance} ++@code{change-class} @i{instance new-class @r{&key} @r{&allow-other-keys}} @result{} @i{instance} + + @subsubheading Method Signatures:: + + @code{change-class} @i{@r{(}@i{instance} @b{standard-object}@r{)} + @r{(}@i{new-class} @b{standard-class}@r{)} +- {&rest} initargs} ++ @r{&rest} initargs} + + @code{change-class} @i{@r{(}@i{instance} @b{t}@r{)} + @r{(}@i{new-class} @b{symbol}@r{)} +- {&rest} initargs} ++ @r{&rest} initargs} + + @subsubheading Arguments and Values:: + +@@ -2651,7 +2657,7 @@ + generic function @b{update-instance-for-different-class} can be used + to assign values to slots in the transformed instance. + +-See @ref{Initializing Newly Added Local Slots}. ++See @ref{Initializing Newly Added Local Slots (Changing the Class of an Instance)}. + + If the second of the above @i{methods} is selected, + that @i{method} invokes @b{change-class} +@@ -2868,13 +2874,13 @@ + + @subsubheading Syntax:: + +-@code{slot-missing} @i{class object slot-name operation {&optional} new-value} @result{} @i{@{@i{result}@}{*}} ++@code{slot-missing} @i{class object slot-name operation @r{&optional} new-value} @result{} @i{@{@i{result}@}*} + + @subsubheading Method Signatures:: + + @code{slot-missing} @i{@r{(}@i{class} @b{t}@r{)} + object slot-name +- operation {&optional} new-value} ++ operation @r{&optional} new-value} + + @subsubheading Arguments and Values:: + +@@ -2961,7 +2967,7 @@ + + @subsubheading Syntax:: + +-@code{slot-unbound} @i{class instance slot-name} @result{} @i{@{@i{result}@}{*}} ++@code{slot-unbound} @i{class instance slot-name} @result{} @i{@{@i{result}@}*} + + @subsubheading Method Signatures:: + +@@ -3153,12 +3159,12 @@ + + @subsubheading Syntax:: + +-@code{no-applicable-method} @i{generic-function {&rest} function-arguments} @result{} @i{@{@i{result}@}{*}} ++@code{no-applicable-method} @i{generic-function @r{&rest} function-arguments} @result{} @i{@{@i{result}@}*} + + @subsubheading Method Signatures:: + + @code{no-applicable-method} @i{@r{(}@i{generic-function} @b{t}@r{)} +- {&rest} function-arguments} ++ @r{&rest} function-arguments} + + @subsubheading Arguments and Values:: + +@@ -3191,13 +3197,13 @@ + + @subsubheading Syntax:: + +-@code{no-next-method} @i{generic-function method {&rest} args} @result{} @i{@{@i{result}@}{*}} ++@code{no-next-method} @i{generic-function method @r{&rest} args} @result{} @i{@{@i{result}@}*} + + @subsubheading Method Signatures:: + + @code{no-next-method} @i{@r{(}@i{generic-function} @b{standard-generic-function}@r{)} + @r{(}@i{method} @b{standard-method}@r{)} +- {&rest} args} ++ @r{&rest} args} + + @subsubheading Arguments and Values:: + +@@ -3263,13 +3269,13 @@ + + @subsubheading Syntax:: + +-@code{make-instance} @i{class {&rest} initargs {&key} {&allow-other-keys}} @result{} @i{instance} ++@code{make-instance} @i{class @r{&rest} initargs @r{&key} @r{&allow-other-keys}} @result{} @i{instance} + + @subsubheading Method Signatures:: + +-@code{make-instance} @i{@r{(}@i{class} @b{standard-class}@r{)} {&rest} initargs} ++@code{make-instance} @i{@r{(}@i{class} @b{standard-class}@r{)} @r{&rest} initargs} + +-@code{make-instance} @i{@r{(}@i{class} @b{symbol}@r{)} {&rest} initargs} ++@code{make-instance} @i{@r{(}@i{class} @b{symbol}@r{)} @r{&rest} initargs} + + @subsubheading Arguments and Values:: + +@@ -3359,17 +3365,17 @@ + + @subsubheading Syntax:: + +-@code{make-load-form} @i{object {&optional} environment} @result{} @i{creation-form@r{[}, initialization-form@r{]}} ++@code{make-load-form} @i{object @r{&optional} environment} @result{} @i{creation-form @r{[}, initialization-form @r{]}} + + @subsubheading Method Signatures:: + +-@code{make-load-form} @i{@r{(}@i{object} @b{standard-object}@r{)} {&optional} environment} ++@code{make-load-form} @i{@r{(}@i{object} @b{standard-object}@r{)} @r{&optional} environment} + +-@code{make-load-form} @i{@r{(}@i{object} @b{structure-object}@r{)} {&optional} environment} ++@code{make-load-form} @i{@r{(}@i{object} @b{structure-object}@r{)} @r{&optional} environment} + +-@code{make-load-form} @i{@r{(}@i{object} @b{condition}@r{)} {&optional} environment} ++@code{make-load-form} @i{@r{(}@i{object} @b{condition}@r{)} @r{&optional} environment} + +-@code{make-load-form} @i{@r{(}@i{object} @b{class}@r{)} {&optional} environment} ++@code{make-load-form} @i{@r{(}@i{object} @b{class}@r{)} @r{&optional} environment} + + @subsubheading Arguments and Values:: + +@@ -3643,7 +3649,7 @@ + @node make-load-form-saving-slots, with-accessors, make-load-form, Objects Dictionary + @subsection make-load-form-saving-slots [Function] + +-@code{make-load-form-saving-slots} @i{object {&key} slot-names environment}@* ++@code{make-load-form-saving-slots} @i{object @r{&key} slot-names environment}@* + @result{} @i{creation-form, initialization-form} + + @subsubheading Arguments and Values:: +@@ -3687,7 +3693,7 @@ + , + @ref{make-instance} + , +-@ref{setf; psetf} ++@ref{setf} + , + @ref{slot-value} + , +@@ -3708,12 +3714,12 @@ + @node with-accessors, with-slots, make-load-form-saving-slots, Objects Dictionary + @subsection with-accessors [Macro] + +-@code{with-accessors} @i{{@r{(}@{@i{slot-entry}@}{*}@r{)}} ++@code{with-accessors} @i{@r{@r{(}@{@i{slot-entry}@}*@r{)}} + instance-form +- @{@i{declaration}@}{*} @{@i{form}@}{*}}@* +- @result{} @i{@{@i{result}@}{*}} ++ @{@i{declaration}@}* @{@i{form}@}*}@* ++ @result{} @i{@{@i{result}@}*} + +-@w{@i{slot-entry} ::=@r{(}variable-name accessor-name@r{)}} ++@w{@i{slot-entry} ::=@r{(}variable-name accessor-name @r{)}} + + @subsubheading Arguments and Values:: + +@@ -3794,7 +3800,7 @@ + @center + @example + +-@w{@t{(with-accessors} ({slot-entry}_1 ...{slot-entry}_n) @i{instance-form} {form}_1 ...{form}_k)}@* ++@w{@t{(with-accessors} (@r{slot-entry}_1 ...@r{slot-entry}_n) @i{instance-form} @r{form}_1 ...@r{form}_k)}@* + @end example + + @noindent +@@ -3804,26 +3810,26 @@ + @example + + @w{@t{(}@t{let ((}in @i{instance-form}@t{))}}@* +-@w{ @t{(symbol-macrolet (}{Q}_1... {Q}_n@t{)} {form}_1 ...{form}_k@t{))}}@* ++@w{ @t{(symbol-macrolet (}@r{Q}_1... @r{Q}_n@t{)} @r{form}_1 ...@r{form}_k@t{))}}@* + @end example + + @noindent +-where {Q}_i is ++where @r{Q}_i is + +-@center { ++@center + @example +-@t{(}{variable-name}_i () +-@t{({accessor-name}_i in))} ++@t{(}@r{variable-name}_i () ++@t{(@r{accessor-name}_i in))} + @end example +-} ++ + + @node with-slots, defclass, with-accessors, Objects Dictionary + @subsection with-slots [Macro] + +-@code{with-slots} @i{@r{(}@{@i{slot-entry}@}{*}@r{)} ++@code{with-slots} @i{@r{(}@{@i{slot-entry}@}*@r{)} + instance-form +- @{@i{declaration}@}{*} @{@i{form}@}{*}}@* +- @result{} @i{@{@i{result}@}{*}} ++ @{@i{declaration}@}* @{@i{form}@}*}@* ++ @result{} @i{@{@i{result}@}*} + + @w{@i{slot-entry} ::=slot-name | @r{(}variable-name slot-name@r{)}} + +@@ -3916,7 +3922,7 @@ + @center + @example + +-@w{@t{(with-slots} ({slot-entry}_1 ...{slot-entry}_n) @i{instance-form} {form}_1 ...{form}_k)}@* ++@w{@t{(with-slots} (@r{slot-entry}_1 ...@r{slot-entry}_n) @i{instance-form} @r{form}_1 ...@r{form}_k)}@* + @end example + + @noindent +@@ -3926,44 +3932,44 @@ + @example + + @w{@t{(}@t{let ((}in @i{instance-form}@t{))}}@* +-@w{ @t{(symbol-macrolet (}{Q}_1... {Q}_n@t{)} {form}_1 ...{form}_k@t{))}}@* ++@w{ @t{(symbol-macrolet (}@r{Q}_1... @r{Q}_n@t{)} @r{form}_1 ...@r{form}_k@t{))}}@* + @end example + + @noindent +-where {Q}_i is ++where @r{Q}_i is + + @center + @example +-@t{(}{slot-entry}_i () +-@t{(slot-value }in '{slot-entry}_i@t{))} ++@t{(}@r{slot-entry}_i () ++@t{(slot-value }in '@r{slot-entry}_i@t{))} + @end example + + @noindent +-if {slot-entry}_i is a @i{symbol} ++if @r{slot-entry}_i is a @i{symbol} + and is + +-@center { ++@center + @example +-@t{(}{variable-name}_i () +-@t{(slot-value }in '{slot-name}_i@t{))} ++@t{(}@r{variable-name}_i () ++@t{(slot-value }in '@r{slot-name}_i@t{))} + @end example +-} ++ + + @noindent +-if {slot-entry}_i ++if @r{slot-entry}_i + is of the form + + @center + @example +-@t{(}{variable-name}_i +-{slot-name}_i@t{)} ++@t{(}@r{variable-name}_i ++@r{slot-name}_i@t{)} + @end example + + @node defclass, defgeneric, with-slots, Objects Dictionary + @subsection defclass [Macro] + +-@code{defclass} @i{@i{class-name} @r{(}@{@i{superclass-name}@}{*}@r{)} +-@r{(}@{{@i{slot-specifier}}@}{*}@r{)} ++@code{defclass} @i{@i{class-name} @r{(}@{@i{superclass-name}@}*@r{)} ++@r{(}@{@i{slot-specifier}@}*@r{)} + [[!@i{class-option}]]}@* + @result{} @i{new-class} + +@@ -3971,14 +3977,14 @@ + + @w{ @i{slot-name}::= @i{symbol}}@* + +-@w{ slot-option::=@{{:reader} @i{reader-function-name}@}{*} |}@* +-@w{ @{{:writer} @i{writer-function-name}@}{*} |}@* +-@w{ @{{:accessor} @i{reader-function-name}@}{*} |}@* +-@w{ @{{:allocation} @i{allocation-type}@} |}@* +-@w{ @{{:initarg} @i{initarg-name}@}{*} |}@* +-@w{ @{{:initform} @i{form}@} |}@* +-@w{ @{{:type} @i{type-specifier}@} |}@* +-@w{ @{{:documentation} @i{string}@}}@* ++@w{ slot-option::=@{@t{:reader} @i{reader-function-name}@}* |}@* ++@w{ @{@t{:writer} @i{writer-function-name}@}* |}@* ++@w{ @{@t{:accessor} @i{reader-function-name}@}* |}@* ++@w{ @{@t{:allocation} @i{allocation-type}@} |}@* ++@w{ @{@t{:initarg} @i{initarg-name}@}* |}@* ++@w{ @{@t{:initform} @i{form}@} |}@* ++@w{ @{@t{:type} @i{type-specifier}@} |}@* ++@w{ @{@t{:documentation} @i{string}@}}@* + + @w{ @i{function-name}::= @{@i{symbol} | @t{(setf @i{symbol})}@}}@* + +@@ -4283,7 +4289,7 @@ + + @subsubheading See Also:: + +-@ref{documentation; (setf documentation)} ++@ref{documentation} + , + @ref{Initialize-Instance} + , +@@ -4301,17 +4307,17 @@ + @subsection defgeneric [Macro] + + @code{defgeneric} @i{function-name gf-lambda-list +- [[!@i{option} | @{!@i{method-description}@}{*}]]}@* ++ [[!@i{option} | @{!@i{method-description}@}*]]}@* + @result{} @i{new-generic} + + @w{@i{option} ::=@r{(}@t{:argument-precedence-order} @{@i{parameter-name}@}^+@r{)} |} + @w{ @r{(}@b{declare} @{@i{gf-declaration}@}^+@r{)} |} + @w{ @r{(}@t{:documentation} @i{gf-documentation}@r{)} |} +-@w{ @r{(}@t{:method-combination} @i{method-combination} @{@i{method-combination-argument}@}{*}@r{)} |} ++@w{ @r{(}@t{:method-combination} @i{method-combination} @{@i{method-combination-argument}@}*@r{)} |} + @w{ @r{(}@t{:generic-function-class} @i{generic-function-class}@r{)} |} + @w{ @r{(}@t{:method-class} @i{method-class}@r{)}} + +-@w{@i{method-description} ::=@r{(}@t{:method} @{@i{method-qualifier}@}{*} @i{specialized-lambda-list} {[[@{@i{declaration}@}{*} | @i{documentation}]]} @{@i{form}@}{*}@r{)}} ++@w{@i{method-description} ::=@r{(}@t{:method} @{@i{method-qualifier}@}* @i{specialized-lambda-list} @r{[[@{@i{declaration}@}* | @i{documentation}]]} @{@i{form}@}*@r{)}} + + @subsubheading Arguments and Values:: + +@@ -4560,7 +4566,7 @@ + + @ref{defmethod} + , +-@ref{documentation; (setf documentation)} ++@ref{documentation} + , + @ref{ensure-generic-function} + , +@@ -4573,9 +4579,9 @@ + @subsection defmethod [Macro] + + @code{defmethod} @i{@i{function-name} +- @{{@i{method-qualifier}}@}{*} ++ @{@i{method-qualifier}@}* + @i{specialized-lambda-list} +- {[[@{@i{declaration}@}{*} | @i{documentation}]]} @{@i{form}@}{*}}@* ++ @r{[[@{@i{declaration}@}* | @i{documentation}]]} @{@i{form}@}*}@* + @result{} @i{new-method} + + @i{function-name}::= @{@i{symbol} +@@ -4583,12 +4589,12 @@ + + @i{method-qualifier}::= @i{non-list} + +-@w{ @i{specialized-lambda-list}::= (@{@i{var} | @r{(}{@i{var} @i{parameter-specializer-name}}@r{)}@}{*}}@* +-@w{ @t{[}{&optional} @{@i{var} | @r{(}var @t{[}@i{initform} {@r{[}@i{supplied-p-parameter}@r{]}} @t{]}@r{)}@}{*}@t{]}}@* ++@w{ @i{specialized-lambda-list}::= (@{@i{var} | @r{(}@r{@i{var} @i{parameter-specializer-name}}@r{)}@}*}@* ++@w{ @t{[}@r{&optional} @{@i{var} | @r{(}var @t{[}@i{initform} @r{@r{[}@i{supplied-p-parameter}@r{]}} @t{]}@r{)}@}*@t{]}}@* + @w{ @t{[}@t{&rest} @i{var}@t{]}}@* +-@w{ @t{{[}}{{&key}{}}@{@i{var} | @r{(}@{@i{var} | @r{(}@i{keyword}@i{var}@r{)}@} @t{[}@i{initform} @r{[}@i{supplied-p-parameter}@r{]} @t{]}@r{)}@}{*}}@* +-@w{ @r{[}@b{&allow-other-keys}@r{]} @t{{]}}}@* +-@w{ @t{[}@t{&aux} @{@i{var} | @r{(}@i{var} @r{[}@i{initform}@r{]} @r{)}@}{*}@t{]} @r{)}}@* ++@w{ @t{[}@r{@r{&key}}@{@i{var} | @r{(}@{@i{var} | @r{(}@i{keyword}@i{var}@r{)}@} @t{[}@i{initform} @r{[}@i{supplied-p-parameter}@r{]} @t{]}@r{)}@}*}@* ++@w{ @r{[}@b{&allow-other-keys}@r{]} @t{]}}@* ++@w{ @t{[}@t{&aux} @{@i{var} | @r{(}@i{var} @r{[}@i{initform}@r{]} @r{)}@}*@t{]} @r{)}}@* + + @w{ @i{parameter-specializer-name}::= @i{symbol} | @r{(}@t{eql} @i{eql-specializer-form}@r{)}}@* + +@@ -4747,7 +4753,7 @@ + + @ref{defgeneric} + , +-@ref{documentation; (setf documentation)} ++@ref{documentation} + , + @ref{Introduction to Methods}, + @ref{Congruent Lambda-lists for all Methods of a Generic Function}, +@@ -4757,9 +4763,9 @@ + @node find-class, next-method-p, defmethod, Objects Dictionary + @subsection find-class [Accessor] + +-@code{find-class} @i{symbol {&optional} errorp environment} @result{} @i{class} ++@code{find-class} @i{symbol @r{&optional} errorp environment} @result{} @i{class} + +-(setf (@code{ find-class} @i{symbol {&optional} errorp environment}) new-class)@* ++(setf (@code{ find-class} @i{symbol @r{&optional} errorp environment}) new-class)@* + + @subsubheading Arguments and Values:: + +@@ -4857,14 +4863,14 @@ + , + @ref{defmethod} + , +-@ref{call-method; make-method} ++@ref{call-method} + + @node call-method, call-next-method, next-method-p, Objects Dictionary + @subsection call-method, make-method [Local Macro] + + @subsubheading Syntax:: + +-@code{call-method} @i{method {&optional} next-method-list} @result{} @i{@{@i{result}@}{*}} ++@code{call-method} @i{method @r{&optional} next-method-list} @result{} @i{@{@i{result}@}*} + + @code{make-method} @i{form} @result{} @i{method-object} + +@@ -4935,7 +4941,7 @@ + @b{call-next-method} function available to + @i{method} signals an error of @i{type} @b{control-error} + and the @b{next-method-p} function +-available to @i{method} returns {@b{nil}}. ++available to @i{method} returns @b{nil}. + + @subsubheading Examples:: + +@@ -4952,7 +4958,7 @@ + + @subsubheading Syntax:: + +-@code{call-next-method} @i{{&rest} args} @result{} @i{@{@i{result}@}{*}} ++@code{call-next-method} @i{@r{&rest} args} @result{} @i{@{@i{result}@}*} + + @subsubheading Arguments and Values:: + +@@ -5034,7 +5040,7 @@ + , + @ref{no-next-method} + , +-@ref{call-method; make-method} ++@ref{call-method} + , + @ref{Method Selection and Combination}, + @ref{Standard Method Combination}, +@@ -5083,12 +5089,12 @@ + @result{} @i{name} + + @code{define-method-combination} @i{name lambda-list +- @r{(}@{@i{method-group-specifier}@}{*}@r{)} ++ @r{(}@{@i{method-group-specifier}@}*@r{)} + @r{[}@r{(}@t{:arguments} . args-lambda-list@r{)}@r{]} + @r{[}@r{(}@t{:generic-function} + generic-function-symbol@r{)}@r{]} +- [[@{@i{declaration}@}{*} | @i{documentation}]] +- @{@i{form}@}{*}}@* ++ [[@{@i{declaration}@}* | @i{documentation}]] ++ @{@i{form}@}*}@* + @result{} @i{name} + + @w{@i{short-form-option} ::=@t{:documentation} @i{documentation} | } +@@ -5159,7 +5165,7 @@ + when the second @i{subform} is a @i{non-nil} symbol or is not present. + When the short form is used, @i{name} is defined as a type of + method combination that produces a Lisp form +-@t{({@i{operator} @i{method-call} @i{method-call} ...})}. ++@t{(@r{@i{operator} @i{method-call} @i{method-call} ...})}. + The @i{operator} is a @i{symbol} that can be the @i{name} of a + @i{function}, @i{macro}, or @i{special operator}. + The @i{operator} can be supplied by a keyword option; +@@ -5620,11 +5626,11 @@ + + @subsubheading See Also:: + +-@ref{call-method; make-method} ++@ref{call-method} + , + @ref{call-next-method} + , +-@ref{documentation; (setf documentation)} ++@ref{documentation} + , + @ref{method-qualifiers} + , +@@ -5651,13 +5657,13 @@ + + @subsubheading Syntax:: + +-@code{find-method} @i{generic-function method-qualifiers specializers {&optional} errorp}@* ++@code{find-method} @i{generic-function method-qualifiers specializers @r{&optional} errorp}@* + @result{} @i{method} + + @subsubheading Method Signatures:: + + @code{find-method} @i{@r{(}@i{generic-function} @b{standard-generic-function}@r{)} +- method-qualifiers specializers {&optional} errorp} ++ method-qualifiers specializers @r{&optional} errorp} + + @subsubheading Arguments and Values:: + +@@ -5783,11 +5789,11 @@ + + @subsubheading Syntax:: + +-@code{initialize-instance} @i{instance {&rest} initargs {&key} {&allow-other-keys}} @result{} @i{instance} ++@code{initialize-instance} @i{instance @r{&rest} initargs @r{&key} @r{&allow-other-keys}} @result{} @i{instance} + + @subsubheading Method Signatures:: + +-@code{initialize-instance} @i{@r{(}@i{instance} @b{standard-object}@r{)} {&rest} initargs} ++@code{initialize-instance} @i{@r{(}@i{instance} @b{standard-object}@r{)} @r{&rest} initargs} + + @subsubheading Arguments and Values:: + +diff -uNr gcl-texi-orig/chap-8.texi gcl-texi/chap-8.texi +--- gcl-texi-orig/chap-8.texi 1994-07-16 18:03:14 +0400 ++++ gcl-texi/chap-8.texi 2002-10-17 20:53:05 +0400 +@@ -20,13 +20,13 @@ + @node defstruct, copy-structure, Structures Dictionary, Structures Dictionary + @subsection defstruct [Macro] + +-@code{defstruct} @i{name-and-options @r{[}documentation@r{]} @{!@i{slot-description}@}{*}}@* ++@code{defstruct} @i{name-and-options @r{[}documentation@r{]} @{!@i{slot-description}@}*}@* + @result{} @i{structure-name} + + @w{@i{name-and-options} ::=structure-name | @r{(}structure-name [[!@i{options}]]@r{)}} + + @w{@i{options} ::=!@i{conc-name-option} |} +-@w{ @{!@i{constructor-option}@}{*} |} ++@w{ @{!@i{constructor-option}@}* |} + @w{ !@i{copier-option} |} + @w{ !@i{include-option} |} + @w{ !@i{initial-offset-option} |} +@@ -46,7 +46,7 @@ + + @w{@i{predicate-option} ::=@t{:predicate} | @r{(}@t{:predicate}@r{)} | @r{(}@t{:predicate} @i{predicate-name}@r{)}} + +-@w{@i{include-option} ::=@r{(}@t{:include} @i{included-structure-name} @{!@i{slot-description}@}{*}@r{)}} ++@w{@i{include-option} ::=@r{(}@t{:include} @i{included-structure-name} @{!@i{slot-description}@}*@r{)}} + + @w{@i{printer-option} ::=!@i{print-object-option} | !@i{print-function-option}} + +@@ -461,7 +461,7 @@ + structure specifies, by giving the @t{:include} option as: + + @example +- (:include @i{included-structure-name} @{@i{slot-description}@}{*}) ++ (:include @i{included-structure-name} @{@i{slot-description}@}*) + @end example + + Each @i{slot-description} must have a @i{slot-name} +@@ -1106,11 +1106,11 @@ + + @subsubheading See Also:: + +-@ref{documentation; (setf documentation)} ++@ref{documentation} + , + @ref{print-object} + , +-@ref{setf; psetf} ++@ref{setf} + , + @ref{subtypep} + , +diff -uNr gcl-texi-orig/chap-9.texi gcl-texi/chap-9.texi +--- gcl-texi-orig/chap-9.texi 1994-07-16 18:03:14 +0400 ++++ gcl-texi/chap-9.texi 2002-10-17 22:06:25 +0400 +@@ -98,7 +98,7 @@ + * Printing Conditions:: + * Signaling and Handling Conditions:: + * Assertions:: +-* Notes about the Condition System's Background:: ++* Notes about the Condition System`s Background:: + @end menu + + @node Condition Types, Creating Conditions, Condition System Concepts, Condition System Concepts +@@ -107,6 +107,7 @@ + Figure 9--1 lists the @i{standardized} @i{condition} @i{types}. + Additional @i{condition} @i{types} can be defined by using @b{define-condition}. + ++@format + @group + @noindent + @w{ arithmetic-error floating-point-overflow simple-type-error } +@@ -124,6 +125,7 @@ + @w{ Figure 9--1: Standardized Condition Types } + + @end group ++@end format + + All @i{condition} types are @i{subtypes} of @i{type} @b{condition}. That is, + +@@ -147,6 +149,7 @@ + Figure 9--2 shows @i{operators} that + define @i{condition} @i{types} and creating @i{conditions}. + ++@format + @group + @noindent + @w{ define-condition make-condition } +@@ -155,10 +158,12 @@ + @w{ Figure 9--2: Operators that define and create conditions.} + + @end group ++@end format + + Figure 9--3 shows @i{operators} that @i{read} + the @i{value} of @i{condition} @i{slots}. + ++@format + @group + @noindent + @w{ arithmetic-error-operands simple-condition-format-arguments } +@@ -172,6 +177,7 @@ + @w{ Figure 9--3: Operators that read condition slots. } + + @end group ++@end format + + @menu + * Serious Conditions:: +@@ -210,7 +216,7 @@ + . + By convention, those arguments are notated as + +- @i{datum} {&rest} @i{arguments} ++ @i{datum} @r{&rest} @i{arguments} + + Taken together, the @i{datum} and the @i{arguments} are + ``@i{designators} for a @i{condition} of default type @i{default-type}.'' +@@ -218,7 +224,7 @@ + + @table @asis + +-@item {@t{*}} If the @i{datum} is a @i{symbol} ++@item @t{*} If the @i{datum} is a @i{symbol} + naming a @i{condition} @i{type} ... + The denoted @i{condition} is the result of + +@@ -226,7 +232,7 @@ + (apply #'make-condition @i{datum} @i{arguments}) + @end example + +-@item {@t{*}} If the @i{datum} is a @i{format control} ... ++@item @t{*} If the @i{datum} is a @i{format control} ... + + The denoted @i{condition} is the result of + +@@ -238,7 +244,7 @@ + + where the @i{defaulted-type} is a @i{subtype} of @i{default-type}. + +-@item {@t{*}} If the @i{datum} is a @i{condition} ... ++@item @t{*} If the @i{datum} is a @i{condition} ... + The denoted @i{condition} is the @i{datum} itself. + In this case, unless otherwise specified by the description of the + @i{operator} in question, the @i{arguments} must be @i{null}; +@@ -456,6 +462,7 @@ + Figure 9--4 shows @i{operators} relating to + the @i{handling} of @i{conditions}. + ++@format + @group + @noindent + @w{ handler-bind handler-case ignore-errors } +@@ -464,6 +471,7 @@ + @w{ Figure 9--4: Operators relating to handling conditions.} + + @end group ++@end format + + @menu + * Signaling:: +@@ -502,6 +510,7 @@ + Figure 9--5 shows @i{defined names} relating to + the @i{signaling} of @i{conditions}. + ++@format + @group + @noindent + @w{ *break-on-signals* error warn } +@@ -511,6 +520,7 @@ + @w{ Figure 9--5: Defined names relating to signaling conditions.} + + @end group ++@end format + + @node Resignaling a Condition, Restarts, Signaling, Signaling and Handling Conditions + @subsubsection Resignaling a Condition +@@ -642,6 +652,7 @@ + Figure 9--6 shows @i{defined names} relating to + @i{restarts}. + ++@format + @group + @noindent + @w{ abort invoke-restart-interactively store-value } +@@ -654,6 +665,7 @@ + @w{ Figure 9--6: Defined names relating to restarts. } + + @end group ++@end format + + @node Restart Tests, Associating a Restart with a Condition, Interfaces to Restarts, Signaling and Handling Conditions + @subsubsection Restart Tests +@@ -683,7 +695,7 @@ + @i{condition} by calling such a function without a @i{condition} @i{argument}, + or by supplying a value of @b{nil} for such an @i{argument}. + +-@node Assertions, Notes about the Condition System's Background, Signaling and Handling Conditions, Condition System Concepts ++@node Assertions, Notes about the Condition System`s Background, Signaling and Handling Conditions, Condition System Concepts + @subsection Assertions + + Conditional signaling of @i{conditions} +@@ -691,6 +703,7 @@ + and @i{type} are handled by assertion @i{operators}. + Figure 9--7 shows @i{operators} relating to assertions. + ++@format + @group + @noindent + @w{ assert check-type ecase } +@@ -700,9 +713,10 @@ + @w{ Figure 9--7: Operators relating to assertions.} + + @end group ++@end format + +-@node Notes about the Condition System's Background, , Assertions, Condition System Concepts +-@subsection Notes about the Condition System's Background ++@node Notes about the Condition System`s Background, , Assertions, Condition System Concepts ++@subsection Notes about the Condition System`s Background + + For a background reference to the abstract concepts detailed in this + section, see @i{Exceptional Situations in Lisp}. The details of that paper are not binding on +@@ -757,12 +771,12 @@ + * restart-name:: + * with-condition-restarts:: + * with-simple-restart:: +-* abort:: ++* abort (Restart):: + * continue:: + * muffle-warning:: + * store-value:: + * use-value:: +-* abort:: ++* abort (Function):: + @end menu + + @node condition, warning, Conditions Dictionary, Conditions Dictionary +@@ -1038,9 +1052,9 @@ + @node assert, error, storage-condition, Conditions Dictionary + @subsection assert [Macro] + +-@code{assert} @i{test-form @r{[}@r{(}@{@i{place}@}{*}@r{)} ++@code{assert} @i{test-form @r{[}@r{(}@{@i{place}@}*@r{)} + @r{[}datum-form +- @{@i{argument-form}@}{*}@r{]}@r{]}}@* ++ @{@i{argument-form}@}*@r{]}@r{]}}@* + @result{} @i{@b{nil}} + + @subsubheading Arguments and Values:: +@@ -1158,7 +1172,7 @@ + @node error, cerror, assert, Conditions Dictionary + @subsection error [Function] + +-@code{error} @i{datum {&rest} arguments} ++@code{error} @i{datum @r{&rest} arguments} + @result{} # + + @subsubheading Arguments and Values:: +@@ -1276,7 +1290,7 @@ + @node cerror, check-type, error, Conditions Dictionary + @subsection cerror [Function] + +-@code{cerror} @i{continue-format-control datum {&rest} arguments} @result{} @i{@b{nil}} ++@code{cerror} @i{continue-format-control datum @r{&rest} arguments} @result{} @i{@b{nil}} + + @subsubheading Arguments and Values:: + +@@ -1441,7 +1455,7 @@ + @node check-type, simple-error, cerror, Conditions Dictionary + @subsection check-type [Macro] + +-@code{check-type} @i{place typespec {@r{[}@i{string}@r{]}}} @result{} @i{@b{nil}} ++@code{check-type} @i{place typespec @r{@r{[}@i{string}@r{]}}} @result{} @i{@b{nil}} + + @subsubheading Arguments and Values:: + +@@ -1596,7 +1610,7 @@ + @node invalid-method-error, method-combination-error, simple-error, Conditions Dictionary + @subsection invalid-method-error [Function] + +-@code{invalid-method-error} @i{method format-control {&rest} args} @result{} @i{@i{implementation-dependent}} ++@code{invalid-method-error} @i{method format-control @r{&rest} args} @result{} @i{@i{implementation-dependent}} + + @subsubheading Arguments and Values:: + +@@ -1642,7 +1656,7 @@ + @node method-combination-error, signal, invalid-method-error, Conditions Dictionary + @subsection method-combination-error [Function] + +-@code{method-combination-error} @i{format-control {&rest} args} @result{} @i{@i{implementation-dependent}} ++@code{method-combination-error} @i{format-control @r{&rest} args} @result{} @i{@i{implementation-dependent}} + + @subsubheading Arguments and Values:: + +@@ -1679,7 +1693,7 @@ + @node signal, simple-condition, method-combination-error, Conditions Dictionary + @subsection signal [Function] + +-@code{signal} @i{datum {&rest} arguments} @result{} @i{@b{nil}} ++@code{signal} @i{datum @r{&rest} arguments} @result{} @i{@b{nil}} + + @subsubheading Arguments and Values:: + +@@ -1779,7 +1793,7 @@ + + @subsubheading See Also:: + +-@ref{simple-condition-format-control; simple-condition-format-arguments} ++@ref{simple-condition-format-control} + , + + @b{simple-condition-format-arguments} +@@ -1831,7 +1845,7 @@ + @node warn, simple-warning, simple-condition-format-control, Conditions Dictionary + @subsection warn [Function] + +-@code{warn} @i{datum {&rest} arguments} @result{} @i{@b{nil}} ++@code{warn} @i{datum @r{&rest} arguments} @result{} @i{@b{nil}} + + @subsubheading Arguments and Values:: + +@@ -1999,7 +2013,7 @@ + @node break, *debugger-hook*, invoke-debugger, Conditions Dictionary + @subsection break [Function] + +-@code{break} @i{{&optional} format-control {&rest} format-arguments} @result{} @i{@b{nil}} ++@code{break} @i{@r{&optional} format-control @r{&rest} format-arguments} @result{} @i{@b{nil}} + + @subsubheading Arguments and Values:: + +@@ -2241,8 +2255,8 @@ + @node handler-bind, handler-case, *break-on-signals*, Conditions Dictionary + @subsection handler-bind [Macro] + +-@code{handler-bind} @i{@r{(}@{!@i{binding}@}{*}@r{)} +- @{@i{form}@}{*}} @result{} @i{@{@i{result}@}{*}} ++@code{handler-bind} @i{@r{(}@{!@i{binding}@}*@r{)} ++ @{@i{form}@}*} @result{} @i{@{@i{result}@}*} + + @w{@i{binding} ::=@r{(}type handler@r{)}} + +@@ -2325,13 +2339,13 @@ + @subsection handler-case [Macro] + + @code{handler-case} @i{@i{expression} +- [[@{!@i{error-clause}@}{*} | !@i{no-error-clause}]]} @result{} @i{@{@i{result}@}{*}} ++ [[@{!@i{error-clause}@}* | !@i{no-error-clause}]]} @result{} @i{@{@i{result}@}*} + + @w{@i{clause} ::=!@i{error-clause} | !@i{no-error-clause}} + +-@w{@i{error-clause} ::=@r{(}typespec @r{(}@t{[}var@t{]}@r{)} @{@i{declaration}@}{*} @{@i{form}@}{*}@r{)}} ++@w{@i{error-clause} ::=@r{(}typespec @r{(}@t{[}var@t{]}@r{)} @{@i{declaration}@}* @{@i{form}@}*@r{)}} + +-@w{@i{no-error-clause} ::=@r{(}@t{:no-error} @i{lambda-list} @{@i{declaration}@}{*} @{@i{form}@}{*}@r{)}} ++@w{@i{no-error-clause} ::=@r{(}@t{:no-error} @i{lambda-list} @{@i{declaration}@}* @{@i{form}@}*@r{)}} + + @subsubheading Arguments and Values:: + +@@ -2406,7 +2420,7 @@ + @i{expression} returns normally and a @i{no-error-clause} + does exist, the values returned are used as arguments to the function + described by constructing +- @t{(lambda @i{lambda-list} @{@i{form}@}{*})} ++ @t{(lambda @i{lambda-list} @{@i{form}@}*)} + from the @i{no-error-clause}, and the @i{values} of that function call are + returned by @b{handler-case}. + The handlers which were established around the @i{expression} are no longer active at the time of this call. +@@ -2490,7 +2504,7 @@ + @node ignore-errors, define-condition, handler-case, Conditions Dictionary + @subsection ignore-errors [Macro] + +-@code{ignore-errors} @i{@{@i{form}@}{*}} @result{} @i{@{@i{result}@}{*}} ++@code{ignore-errors} @i{@{@i{form}@}*} @result{} @i{@{@i{result}@}*} + + @subsubheading Arguments and Values:: + +@@ -2561,20 +2575,20 @@ + + [Editorial Note by KMP: This syntax stuff is still very confused and needs lots of work.] + +-@code{define-condition} @i{name @r{(}@{@i{parent-type}@}{*}@r{)} +- @r{(}@{!@i{slot-spec}@}{*}@r{)} +- @{@i{option}@}{*}}@* ++@code{define-condition} @i{name @r{(}@{@i{parent-type}@}*@r{)} ++ @r{(}@{!@i{slot-spec}@}*@r{)} ++ @{@i{option}@}*}@* + @result{} @i{name} + + @w{@i{slot-spec} ::=slot-name | @r{(}slot-name !@i{slot-option}@r{)}} + +-@w{@i{slot-option} ::=[[ @{{:reader} @i{symbol}@}{*} | } +-@w{ @{{:writer} !@i{function-name}@}{*} | } +-@w{ @{{:accessor} @i{symbol}@}{*} | } +-@w{ @{{:allocation} !@i{allocation-type}@} | } +-@w{ @{{:initarg} @i{symbol}@}{*} | } +-@w{ @{{:initform} @i{form}@} | } +-@w{ @{{:type} @i{type-specifier}@} ]]} ++@w{@i{slot-option} ::=[[ @{@t{:reader} @i{symbol}@}* | } ++@w{ @{@t{:writer} !@i{function-name}@}* | } ++@w{ @{@t{:accessor} @i{symbol}@}* | } ++@w{ @{@t{:allocation} !@i{allocation-type}@} | } ++@w{ @{@t{:initarg} @i{symbol}@}* | } ++@w{ @{@t{:initform} @i{form}@} | } ++@w{ @{@t{:type} @i{type-specifier}@} ]]} + + @w{@i{option} ::=[[ @r{(}@t{:default-initargs} @t{.} @i{initarg-list}@r{)} | } + @w{ @r{(}@t{:documentation} @i{string}@r{)} | } +@@ -2897,7 +2911,7 @@ + @node make-condition, restart, define-condition, Conditions Dictionary + @subsection make-condition [Function] + +-@code{make-condition} @i{type {&rest} slot-initializations} @result{} @i{condition} ++@code{make-condition} @i{type @r{&rest} slot-initializations} @result{} @i{condition} + + @subsubheading Arguments and Values:: + +@@ -2963,7 +2977,7 @@ + @node compute-restarts, find-restart, restart, Conditions Dictionary + @subsection compute-restarts [Function] + +-@code{compute-restarts} @i{{&optional} condition} @result{} @i{restarts} ++@code{compute-restarts} @i{@r{&optional} condition} @result{} @i{restarts} + + @subsubheading Arguments and Values:: + +@@ -3051,8 +3065,8 @@ + @node find-restart, invoke-restart, compute-restarts, Conditions Dictionary + @subsection find-restart [Function] + +-@code{find-restart} @i{identifier {&optional} condition} +- {restart} ++@code{find-restart} @i{identifier @r{&optional} condition} ++ @r{restart} + + @subsubheading Arguments and Values:: + +@@ -3120,7 +3134,7 @@ + @node invoke-restart, invoke-restart-interactively, find-restart, Conditions Dictionary + @subsection invoke-restart [Function] + +-@code{invoke-restart} @i{restart {&rest} arguments} @result{} @i{@{@i{result}@}{*}} ++@code{invoke-restart} @i{restart @r{&rest} arguments} @result{} @i{@{@i{result}@}*} + + @subsubheading Arguments and Values:: + +@@ -3185,7 +3199,7 @@ + @node invoke-restart-interactively, restart-bind, invoke-restart, Conditions Dictionary + @subsection invoke-restart-interactively [Function] + +-@code{invoke-restart-interactively} @i{restart} @result{} @i{@{@i{result}@}{*}} ++@code{invoke-restart-interactively} @i{restart} @result{} @i{@{@i{result}@}*} + + @subsubheading Arguments and Values:: + +@@ -3270,14 +3284,14 @@ + @node restart-bind, restart-case, invoke-restart-interactively, Conditions Dictionary + @subsection restart-bind [Macro] + +-@code{restart-bind} @i{@r{(}@{{(}name function +- @{!@i{key-val-pair}@}{*}@r{)}@}{)} +- @{@i{form}@}{*}}@* +- @result{} @i{@{@i{result}@}{*}} +- +-@w{@i{key-val-pair} ::=@t{:interactive-function} {interactive-function} | } +-@w{ @t{:report-function} {report-function} | } +-@w{ @t{:test-function} {test-function}} ++@code{restart-bind} @i{@r{(}@{@r{(}name function ++ @{!@i{key-val-pair}@}*@r{)}@}@r{)} ++ @{@i{form}@}*}@* ++ @result{} @i{@{@i{result}@}*} ++ ++@w{@i{key-val-pair} ::=@t{:interactive-function} @r{interactive-function} | } ++@w{ @t{:report-function} @r{report-function} | } ++@w{ @t{:test-function} @r{test-function}} + + @subsubheading Arguments and Values:: + +@@ -3386,11 +3400,11 @@ + @node restart-case, restart-name, restart-bind, Conditions Dictionary + @subsection restart-case [Macro] + +-@code{restart-case} @i{restartable-form {@{!@i{clause}@}}} @result{} @i{@{@i{result}@}{*}} ++@code{restart-case} @i{restartable-form @r{@{!@i{clause}@}}} @result{} @i{@{@i{result}@}*} + + @w{@i{clause} ::=@r{(} case-name lambda-list } + @w{ [[@t{:interactive} interactive-expression | @t{:report} report-expression | @t{:test} test-expression]] } +-@w{ @{@i{declaration}@}{*} @{@i{form}@}{*}@r{)}} ++@w{ @{@i{declaration}@}* @{@i{form}@}*@r{)}} + + @subsubheading Arguments and Values:: + +@@ -3700,8 +3714,8 @@ + @node with-condition-restarts, with-simple-restart, restart-name, Conditions Dictionary + @subsection with-condition-restarts [Macro] + +-@code{with-condition-restarts} @i{condition-form restarts-form @{@i{form}@}{*}}@* +- @result{} @i{@{@i{result}@}{*}} ++@code{with-condition-restarts} @i{condition-form restarts-form @{@i{form}@}*}@* ++ @result{} @i{@{@i{result}@}*} + + @subsubheading Arguments and Values:: + +@@ -3740,12 +3754,12 @@ + since @b{restart-case} handles most of the common cases + in a way that is syntactically more concise. + +-@node with-simple-restart, abort, with-condition-restarts, Conditions Dictionary ++@node with-simple-restart, abort (Restart), with-condition-restarts, Conditions Dictionary + @subsection with-simple-restart [Macro] + +-@code{with-simple-restart} @i{@r{(}name format-control @{@i{format-argument}@}{*}@r{)} +- @{@i{form}@}{*}}@* +- @result{} @i{@{@i{result}@}{*}} ++@code{with-simple-restart} @i{@r{(}name format-control @{@i{format-argument}@}*@r{)} ++ @{@i{form}@}*}@* ++ @result{} @i{@{@i{result}@}*} + + @subsubheading Arguments and Values:: + +@@ -3800,7 +3814,7 @@ + + @example + (defun compute-fixnum-power-of-2 (x) +- (with-simple-restart (nil "Give up on computing 2{@t{^}}~D." x) ++ (with-simple-restart (nil "Give up on computing 2@t{^}~D." x) + (let ((result 1)) + (dotimes (i x result) + (setq result (* 2 result)) +@@ -3815,7 +3829,7 @@ + (compute-power-of-2 10000) + @t{ |> } Error: Power of 2 is too large. + @t{ |> } To continue, type :CONTINUE followed by an option number. +-@t{ |> } 1: Give up on computing 2{@t{^}}10000. ++@t{ |> } 1: Give up on computing 2@t{^}10000. + @t{ |> } 2: Return to Lisp Toplevel + @t{ |> } Debug> @b{|>>}@t{:continue 1}@b{<<|} + @result{} SOMETHING-BIG +@@ -3848,7 +3862,7 @@ + in the normal case to be missing or @b{nil} so that the two situations + can be distinguished. + +-@node abort, continue, with-simple-restart, Conditions Dictionary ++@node abort (Restart), continue, with-simple-restart, Conditions Dictionary + @subsection abort [Restart] + + @subsubheading Data Arguments Required:: +@@ -3875,10 +3889,10 @@ + @ref{Interfaces to Restarts}, + @ref{invoke-restart} + , +-@ref{abort} ++@ref{abort (Function)} + (@i{function}) + +-@node continue, muffle-warning, abort, Conditions Dictionary ++@node continue, muffle-warning, abort (Restart), Conditions Dictionary + @subsection continue [Restart] + + @subsubheading Data Arguments Required:: +@@ -4020,7 +4034,7 @@ + @ref{use-value} + (@i{function} and @i{restart}) + +-@node use-value, abort, store-value, Conditions Dictionary ++@node use-value, abort (Function), store-value, Conditions Dictionary + @subsection use-value [Restart] + + @subsubheading Data Arguments Required:: +@@ -4044,7 +4058,7 @@ + @ref{store-value} + (@i{function} and @i{restart}) + +-@node abort, , use-value, Conditions Dictionary ++@node abort (Function), , use-value, Conditions Dictionary + @subsection abort, continue, muffle-warning, store-value, use-value [Function] + + @IRindex{abort} +@@ -4057,17 +4071,17 @@ + + @IRindex{use-value} + +-@code{abort} @i{{&optional} condition} ++@code{abort} @i{@r{&optional} condition} + @result{} # + +-@code{continue} @i{{&optional} condition} @result{} @i{@b{nil}} ++@code{continue} @i{@r{&optional} condition} @result{} @i{@b{nil}} + +-@code{muffle-warning} @i{{&optional} condition} ++@code{muffle-warning} @i{@r{&optional} condition} + @result{} # + +-@code{store-value} @i{value {&optional} condition} @result{} @i{@b{nil}} ++@code{store-value} @i{value @r{&optional} condition} @result{} @i{@b{nil}} + +-@code{use-value} @i{value {&optional} condition} @result{} @i{@b{nil}} ++@code{use-value} @i{value @r{&optional} condition} @result{} @i{@b{nil}} + + @subsubheading Arguments and Values:: + +diff -uNr gcl-texi-orig/gcl.texi gcl-texi/gcl.texi +--- gcl-texi-orig/gcl.texi 1994-07-16 18:03:23 +0400 ++++ gcl-texi/gcl.texi 2002-10-18 12:47:46 +0400 +@@ -5,11 +5,19 @@ + @settitle ANSI and GNU Common Lisp Document + @c %**end of header + @setchapternewpage odd ++ + @ifinfo + This is a Texinfo GNU Common Lisp Manual based on the draft ANSI standard + for Common Lisp. + + Copyright 1994 William F. Schelter ++ ++@format ++INFO-DIR-SECTION GNU Common Lisp ++START-INFO-DIR-ENTRY ++* gcl: (gcl.info). GNU Common Lisp Manual ++END-INFO-DIR-ENTRY ++@end format + @end ifinfo + + @titlepage +@@ -32,7 +40,7 @@ + @c Example index + @defcodeindex IP + @c Package index +-@defcodeindex IK ++@c @defcodeindex IK + @c Keyword Index + + @node Top, Introduction (Introduction), (dir), (dir) +@@ -110,38 +118,38 @@ + + Interpreting Dictionary Entries + +-* The ``Affected By'' Section of a Dictionary Entry:: +-* The ``Arguments'' Section of a Dictionary Entry:: +-* The ``Arguments and Values'' Section of a Dictionary Entry:: +-* The ``Binding Types Affected'' Section of a Dictionary Entry:: +-* The ``Class Precedence List'' Section of a Dictionary Entry:: ++* The "Affected By" Section of a Dictionary Entry:: ++* The "Arguments" Section of a Dictionary Entry:: ++* The "Arguments and Values" Section of a Dictionary Entry:: ++* The "Binding Types Affected" Section of a Dictionary Entry:: ++* The "Class Precedence List" Section of a Dictionary Entry:: + * Dictionary Entries for Type Specifiers:: +-* The ``Compound Type Specifier Kind'' Section of a Dictionary Entry:: +-* The ``Compound Type Specifier Syntax'' Section of a Dictionary Entry:: +-* The ``Compound Type Specifier Arguments'' Section of a Dictionary Entry:: +-* The ``Compound Type Specifier Description'' Section of a Dictionary Entry:: +-* The ``Constant Value'' Section of a Dictionary Entry:: +-* The ``Description'' Section of a Dictionary Entry:: +-* The ``Examples'' Section of a Dictionary Entry:: +-* The ``Exceptional Situations'' Section of a Dictionary Entry:: +-* The ``Initial Value'' Section of a Dictionary Entry:: +-* The ``Argument Precedence Order'' Section of a Dictionary Entry:: +-* The ``Method Signature'' Section of a Dictionary Entry:: +-* The ``Name'' Section of a Dictionary Entry:: +-* The ``Notes'' Section of a Dictionary Entry:: +-* The ``Pronunciation'' Section of a Dictionary Entry:: +-* The ``See Also'' Section of a Dictionary Entry:: +-* The ``Side Effects'' Section of a Dictionary Entry:: +-* The ``Supertypes'' Section of a Dictionary Entry:: +-* The ``Syntax'' Section of a Dictionary Entry:: +-* Special ``Syntax'' Notations for Overloaded Operators:: ++* The "Compound Type Specifier Kind" Section of a Dictionary Entry:: ++* The "Compound Type Specifier Syntax" Section of a Dictionary Entry:: ++* The "Compound Type Specifier Arguments" Section of a Dictionary Entry:: ++* The "Compound Type Specifier Description" Section of a Dictionary Entry:: ++* The "Constant Value" Section of a Dictionary Entry:: ++* The "Description" Section of a Dictionary Entry:: ++* The "Examples" Section of a Dictionary Entry:: ++* The "Exceptional Situations" Section of a Dictionary Entry:: ++* The "Initial Value" Section of a Dictionary Entry:: ++* The "Argument Precedence Order" Section of a Dictionary Entry:: ++* The "Method Signature" Section of a Dictionary Entry:: ++* The "Name" Section of a Dictionary Entry:: ++* The "Notes" Section of a Dictionary Entry:: ++* The "Pronunciation" Section of a Dictionary Entry:: ++* The "See Also" Section of a Dictionary Entry:: ++* The "Side Effects" Section of a Dictionary Entry:: ++* The "Supertypes" Section of a Dictionary Entry:: ++* The "Syntax" Section of a Dictionary Entry:: ++* Special "Syntax" Notations for Overloaded Operators:: + * Naming Conventions for Rest Parameters:: +-* Requiring Non-Null Rest Parameters in the ``Syntax'' Section:: +-* Return values in the ``Syntax'' Section:: +-* No Arguments or Values in the ``Syntax'' Section:: +-* Unconditional Transfer of Control in the ``Syntax'' Section:: +-* The ``Valid Context'' Section of a Dictionary Entry:: +-* The ``Value Type'' Section of a Dictionary Entry:: ++* Requiring Non-Null Rest Parameters in The "Syntax" Section:: ++* Return values in The "Syntax" Section:: ++* No Arguments or Values in The "Syntax" Section:: ++* Unconditional Transfer of Control in The "Syntax" Section:: ++* The "Valid Context" Section of a Dictionary Entry:: ++* The "Value Type" Section of a Dictionary Entry:: + + Conformance + +@@ -529,7 +537,7 @@ + * method-combination:: + * t (System Class):: + * satisfies:: +-* member:: ++* member (Type Specifier):: + * not (Type Specifier):: + * and (Type Specifier):: + * or (Type Specifier):: +@@ -871,7 +879,7 @@ + * Printing Conditions:: + * Signaling and Handling Conditions:: + * Assertions:: +-* Notes about the Condition System's Background:: ++* Notes about the Condition System`s Background:: + + Condition Types + +@@ -942,12 +950,12 @@ + * restart-name:: + * with-condition-restarts:: + * with-simple-restart:: +-* abort:: ++* abort (Restart):: + * continue:: + * muffle-warning:: + * store-value:: + * use-value:: +-* abort:: ++* abort (Function):: + + Symbols + +@@ -1095,13 +1103,13 @@ + * real:: + * float (System Class):: + * short-float:: +-* rational:: ++* rational (System Class):: + * ratio:: + * integer:: + * signed-byte:: + * unsigned-byte:: +-* mod:: +-* bit:: ++* mod (System Class):: ++* bit (System Class):: + * fixnum:: + * bignum:: + * =:: +@@ -1125,7 +1133,7 @@ + * incf:: + * lcm:: + * log:: +-* mod:: ++* mod (Function):: + * signum:: + * sqrt:: + * random-state:: +@@ -1143,7 +1151,7 @@ + * upgraded-complex-part-type:: + * realp:: + * numerator:: +-* rational:: ++* rational (Function):: + * rationalp:: + * ash:: + * integer-length:: +@@ -1257,7 +1265,7 @@ + + Conses Dictionary + +-* list:: ++* list (System Class):: + * null (System Class):: + * cons (System Class):: + * atom (Type):: +@@ -1271,7 +1279,7 @@ + * subst:: + * tree-equal:: + * copy-list:: +-* list:: ++* list (Function):: + * list-length:: + * listp:: + * make-list:: +@@ -1289,7 +1297,7 @@ + * ldiff:: + * nthcdr:: + * rest:: +-* member:: ++* member (Function):: + * mapc:: + * acons:: + * assoc:: +@@ -1368,7 +1376,7 @@ + * vector-pop:: + * vector-push:: + * vectorp:: +-* bit:: ++* bit (Array):: + * bit-and:: + * bit-vector-p:: + * simple-bit-vector-p:: +@@ -1741,7 +1749,7 @@ + + * Pretty Printer Concepts:: + * Examples of using the Pretty Printer:: +-* Notes about the Pretty Printer's Background:: ++* Notes about the Pretty Printer`s Background:: + + Pretty Printer Concepts + diff --git a/info/general.texi b/info/general.texi new file mode 100755 index 0000000..4532dca --- /dev/null +++ b/info/general.texi @@ -0,0 +1,687 @@ +@c Copyright (c) 1994 William Schelter. + +@node General, Widgets, Top, Top +@chapter General + +@menu +* Introduction:: +* Getting Started:: +* Common Features of Widgets:: +* Return Values:: +* Argument Lists:: +* Lisp Functions Invoked from Graphics:: +* Linked Variables:: +* tkconnect:: +@end menu + +@node Introduction, Getting Started, General, General +@section Introduction + +@b{GCL-TK} is a windowing interface for @b{GNU Common Lisp}. It provides the +functionality of the @b{TK} widget set, which in turn implements a widget +set which has the look and feel of @b{Motif}. + +The interface allows the user to draw graphics, get input from menus, +make regions mouse sensitive, and bind lisp commands to regions. It +communicates over a socket with a @file{gcltksrv} process, which speaks to the +display via the @b{TK} library. The displaying process may run on +a machine which is closer to the display, and so involves less +communication. It also may remain active even though the lisp is +involved in a separate user computation. The display server can, however, +interrupt the lisp at will, to inquire about variables and run +commands. + +The user may also interface with existing @code{TCL/TK} programs, +binding some buttons, or tracking some objects. + +The size of the program is moderate. In its current form it adds only +about 45K bytes to the lisp image, and the @file{gcltksrv} program uses shared +libraries, and is on the order of 150Kbytes on a sparc. + +This chapter describes some of the common features of the command +structure of widgets, and of control functions. The actual functions +for construction of windows +are discussed in @ref{Widgets}, and more general functions +for making them appear, lowering them, querying about them in @ref{Control}. + +@node Getting Started, Common Features of Widgets, Introduction, General +@section Getting Started + +Once @b{GCL} has been properly installed you should be able to do the +following simple example: + +@example +(in-package "TK") +(tkconnect) +(button '.hello :text "Hello World" :command '(print "hi")) +==>.HELLO +(pack '.hello) +@end example +We first switched to the "TK" package, so that functions like button +and pack would be found. +After doing the tkconnect, a window should appear on your screen, see @xref{tkconnect}. +The invocation of the function @code{button} creates a new function +called @code{.hello} which is a @i{widget function}. It is then +made visible in the window by using the @code{pack} function. + +You may now click on the little window, and you should see the command +executed in your lisp. Thus "hi" should be printed in the lisp +window. This will happen whether or not you have a job running in +the lisp, that is lisp will be interrupted and your command will run, +and then return the control to your program. + +The function @code{button} is called a widget constructor, and the +function @code{.hello} is called a widget. If you have managed to +accomplish the above, then @b{GCL} is probably installed correctly, and you +can graduate to the next section! If you dont like reading but prefer +to look at demos and code, then you should look in the demos directory, +where you will find a number of examples. A monitor for the garbage +collector (mkgcmonitor), a demonstration of canvas widgets (mkitems), +a sample listbox with scrolling (mklistbox). + +@node Common Features of Widgets, Return Values, Getting Started, General +@section Common Features of Widgets + +A @i{widget} is a lisp symbol which has a function binding. The +first argument is always a keyword and is called the @i{option}. +The argument pattern for the remaining arguments depends on the +@i{option}. The most common @i{option} is @code{:configure} in +which case the remaining arguments are alternating keyword/value +pairs, with the same keywords being permitted as at the creation +of the widget. + +A @i{widget} is created by means of a @i{widget constructor}, of +which there are currently 15, each of them appearing as the title of a +section in @ref{Widgets}. They live in the @code{"TK"} package, and for +the moment we will assume we have switched to this package. Thus for +example @code{button} is such a widget constructor function. Of course +this is lisp, and you can make your own widget constructors, but when +you do so it is a good idea to follow the standard argument patterns +that are outlined in this section. + +@example +(button '.hello) +==> .HELLO +@end example +@noindent +creates a @i{widget} whose name is @code{.hello}. There is a parent child +hierarchy among widgets which is implicit in the name used for the +widget. This is much like the pathname structure on a Unix or Dos +file system, except that @code{'.'} is used as the separator rather +than a @code{/} or @code{\}. For this reason the widget instances +are sometimes referred to as @i{pathnames}. A child of the +parent widget @code{.hello} might be called @code{.hello.joe}, and +a child of this last might be @code{.hello.joe.bar}. The parent of +everyone is called @code{.} . Multiple top level windows are created +using the @code{toplevel} command (@pxref{toplevel}). + +The widget constructor functions take keyword and value pairs, which +allow you to specify attributes at the time of creation: + +@example +(button '.hello :text "Hello World" :width 20) +==>.HELLO +@end example +@noindent +indicating that we want the text in the button window to be +@code{Hello World} and the width of the window to be 20 characters +wide. Other types of windows allow specification in centimeters +@code{2c}, or in inches (@code{2i}) or in millimeters @code{2m} +or in pixels @code{2}. But text windows usually have their +dimensions specified as multiples of a character width and height. +This latter concept is called a grid. + +Once the window has been created, if you want to change the +text you do NOT do: +@example +(button '.hello :text "Bye World" :width 20) +@end example +This would be in error, because the window .hello already exists. +You would either have to first call + +@example +(destroy '.hello) +@end example + +But usually you just want to change an attribute. @code{.hello} is +actually a function, as we mentioned earlier, and it is this function +that you use: + +@example +(.hello :configure :text "Bye World") +@end example + +This would simply change the text, and not change where the window had +been placed on the screen (if it had), or how it had been packed +into the window hierarchy. Here the argument @code{:configure} is +called an @i{option}, and it specifies which types of keywords can +follow it. For example + +@example +(.hello :flash) +@end example +@noindent +is also valid, but in this case the @code{:text} keyword is not permitted +after flash. If it were, then it would mean something else besides +what it means in the above. For example one might have defined + +@example +(.hello :flash :text "PUSH ME") +@end example +@noindent +so here the same keyword @code{:text} would mean something else, eg +to flash a subliminal message on the screen. + +We often refer to calls to the widget functions +as messages. One reason for this is that they actually turn into +messages to the graphics process @file{gcltksrv}. To actually see these +messages you can do +@example +(debugging t). +@end example + +@node Return Values, Argument Lists, Common Features of Widgets, General +@section Return Values + +@subsection Widget Constructor Return Values + +On successful completion, the widget constructor functions return the +symbol passed in as the first argument. It will now have a functional +binding. It is an error to pass in a symbol which already corresponds +to a widget, without first calling the @code{destroy} command. On failure, +an error is signalled. + +@subsection Widget Return Values + +The @i{widget} functions themselves, do not normally return any value. +Indeed the lisp process does not wait for them to return, but merely +dispatches the commands, such as to change the text in themselves. +Sometimes however you either wish to wait, in order to synchronize, or +you wish to see if your command fails or succeeds. You request values +by passing the keyword :return and a value indicating the type. + +@example +(.hello :configure :text "Bye World" :return 'string) +==> "" +==> T +@end example +@noindent +the empty string is returned as first value, and the second value +@code{T} indicates that the new text value was successfully set. LISP +will not continue until the tkclsrv process indicates back that the +function call has succeeded. While waiting of course LISP will continue +to process other graphics events which arrive, since otherwise a +deadlock would arise: the user for instance might click on a mouse, just after +we had decided to wait for a return value from the @code{.hello} function. +More generally a user program may be running in @b{GCL} and be interrupted +to receive and act on communications from the @file{gcltksrv} +process. If an error occurred then the second return value of the +lisp function will be NIL. In this case the first value, the string +is usually an informative message about the type of error. + +A special variable @code{tk::*break-on-errors*} which if not +@code{nil}, requests that that @b{LISP} signal an error when a message +is received indicating a function failed. Whenever a command fails, +whether a return value was requested or not, @file{gcltksrv} returns a +message indicating failure. The default is to not go into the +debugger. When debugging your windows it may be convenient however to +set this variable to @code{T} to track down incorrect messages. + +The @file{gcltksrv} process always returns strings as values. +If @code{:return} @i{type} is specified, then conversion to @i{type} +is accomplished by calling + +@example +(coerce-result @i{return-string} @i{type}) +@end example + +Here @i{type} must be a symbol with a @code{coercion-functions} +property. +The builtin return types which may be requested are: + +@table @code +@item T +in which case +the string passed back from the @file{gcltksrv} process, will be read by the +lisp reader. +@item number +the string is converted to a number using the current *read-base* +@item list-strings + +@example +(coerce-result "a b @{c d@} e" 'list-strings) +==> ("a" "b" "c d" "e") +@end example +@item boolean +(coerce-result "1" 'boolean) +==> T +(coerce-result "0" 'boolean) +==> NIL +@end table + +The above symbols are in the @code{TK} or @code{LISP} package. +It would be possible to add new types just as the @code{:return t} +is done: + +@example +(setf (get 't 'coercion-functions) + (cons #'(lambda (x) (our-read-from-string x 0)) + #'(lambda (x) (format nil "~s" x)))) +@end example + +The @code{coercion-functions} property of a symbol, is a cons whose +@code{car} is the coercion form from a string to some possibly different +lisp object, and whose @code{cdr} is a function which builds a string +to send to the graphics server. Often the two functions are inverse +functions one of the other up to equal. + +@subsection Control Function Return Values + +The @i{control} funcions (@pxref{Control}) do not return a value +or wait unless requested to do so, using the @code{:return} keyword. +The types and method of specification are the same as for the +Widget Functions in the previous section. + +@example +(winfo :width '.hello :return 'number) +==> 120 +@end example +@noindent +indicates that the @code{.hello} button is actually 120 pixels +wide. + +@node Argument Lists, Lisp Functions Invoked from Graphics, Return Values, General +@section Argument Lists + +@subsection Widget Functions + +The rule is that the first argument for a widget function is a keyword, +called the @i{option}. The pattern of the remaining arguments depends +completely +on the @i{option} argument. Thus + +@example +(.hello @i{option} ?arg1? ?arg2? ...) +@end example + +One @i{option} which is permitted for every widget function is +@code{:configure}. The argument pattern following it is the same +keyword/value pair list which is used in widget creation. For a +@code{button} widget, the other valid options are @code{:deactivate}, +@code{:flash}, and @code{:invoke}. To find these, since +@code{.hello} was constructed with the @code{button} constructor, you +should see @xref{button}. +The argument pattern for other options depends completely on the option +and the widget function. +For example if @code{.scrollbar} is a scroll bar window, then the option +@code{:set} must be followed by 4 numeric arguments, which indicate how +the scrollbar should be displayed, see @xref{scrollbar}. + +@example +(.scrollbar :set a1 a2 a3 a4) +@end example + +If on the other hand @code{.scale} is a scale (@pxref{scale}), then we have + +@example +(.scale :set a1 ) +@end example +@noindent +only one numeric argument should be supplied, in order to position the +scale. + +@subsection Widget Constructor Argument Lists + +These are + +@example +(widget-constructor @i{pathname} :keyword1 value1 :keyword2 value2 ...) +@end example + +@noindent +to create the widget whose name is @i{pathname}. The possible keywords +allowed are specified in the corresponding section of @xref{Widgets}. + +@subsection Concatenation Using `:' in Argument List + +What has been said so far about arguments is not quite true. A +special string concatenation construction is allowed in argument lists +for widgets, widget constructors and control functions. + +First we introduce the function @code{tk-conc} which takes an arbitrary +number of arguments, which may be symbols, strings or numbers, and +concatenates these into a string. The print names of symbols are +converted to lower case, and package names are ignored. + +@example +(tk-conc "a" 1 :b 'cd "e") ==> "a1bcde" +@end example + +One could use @code{tk-conc} to construct arguments for widget +functions. But even though @code{tk-conc} has been made quite +efficient, it still would involve the creation of a string. The +@code{:} construct avoids this. In a call to a widget function, +a widget constructor, or a control function you may remove the call to +@code{tk-conc} and place @code{:} in between each of its arguments. +Those functions are able to understand this and treat the extra +arguments as if they were glued together in one string, but without +the extra cost of actually forming that string. + +@example +(tk-conc a b c .. w) <==> a : b : c : ... w +(setq i 10) +(.hello :configure :text i : " pies") +(.hello :configure :text (tk-conc i " pies")) +(.hello :configure :text (format nil "~a pies" i)) +@end example + +The last three examples would all result in the text string being +@code{"10 pies"}, but the first method is the most efficient. +That call will be made with no string or cons creation. The +@b{GC Monitor} example, is written in such a way that there is no +creation of @code{cons} or @code{string} types during normal operation. +This is particularly useful in that case, since one is trying to +monitor usage of conses by other programs, not its own usage. + +@node Lisp Functions Invoked from Graphics, Linked Variables, Argument Lists, General +@section Lisp Functions Invoked from Graphics + + +It is possible to make certain areas of a window mouse sensitive, +or to run commands on reception of certain events such as keystrokes, +while the focus is in a certain window. This is done by having +a lisp function invoked or some lisp form evaluated. We shall +refer to such a lisp function or form as a @emph{command}. + +For example + +@example +(button '.button :text "Hello" :command '(print "hi")) +(button '.jim :text "Call Jim" :command 'call-jim) +@end example + +In the first case when the window @code{.button} is clicked on, the +word "hi" will be printed in the lisp to standard output. In the +second case @code{call-jim} will be funcalled with no arguments. + +A command must be one of the following three types. What happens +depends on which type it is: + +@table @samp +@item function +If the value satisfies @code{functionp} then it will be called with +a number of arguments which is dependent on the way it was bound, +to graphics. +@item string +If the command is a string, then it is passed directly to @b{TCL/TK} +for evaluation on that side. Lisp will not be required for the +evaluation when the command is invoked. +@item lisp form +Any other lisp object is regarded as a lisp form to be eval'd, and +this will be done when the command is invoked. +@end table + +The following keywords accept as their value a command: + +@example + :command + :yscroll :yscrollcommand + :xscroll :xscrollcommand + :scrollcommand + :bind +@end example + +@noindent +and in addition @code{bind} takes a command as its third argument, +see @xref{bind}. + +@c todo!! +Below we give three different examples using the 3 possibilities for +a command: functionp, string, and lisp form. They all accomplish +exactly the same thing. +For given a frame @code{.frame} we could construct a listbox +in it as: + +@example +(listbox '.frame.listbox :yscroll 'joe) +@end example + +Then whenever the listbox view position changes, or text is inserted, +so that something changes, the function @code{joe} will be invoked with 4 +arguments giving the totalsize of the text, maximum number of units +the window can display, the index of the top unit, and finally the +index of the bottom unit. What these arguments are is specific +to the widget @code{listbox} and is documented @xref{listbox}. + +@code{joe} might be used to do anything, but a common usage is to have +@code{joe} alter the position of some other window, such as a scroll +bar window. Indeed if @code{.scrollbar} is a scrollbar then +the function + +@example +(defun joe (a b c d) + (.scrollbar :set a b c d)) +@end example + +@noindent +would look after sizing the scrollbar appropriately for the percentage +of the window visible, and positioning it. + +A second method of accomplishing this identical, using a string (the +second type of command), + + +@example +(listbox '.frame.listbox :yscroll ".scrollbar set") +@end example + +@noindent +and this will not involve a call back to lisp. It uses the fact that +the @b{TK} graphics side understands the window name @code{.scrollbar} and +that it takes the @i{option} @code{set}. Note that it does not get +the @code{:} before the keyword in this case. + +In the case of a command which is a @i{lisp form} but is not installed +via @code{bind} or @code{:bind}, then the form will be installed as + +@example +#'(lambda (&rest *arglist*) @i{lisp-form}) +@end example + +@noindent +where the @i{lisp-form} might wish to access the elements of the special +variable @code{*arglist*}. Most often this list will be empty, but for +example if the command was setup for @code{.scale} which is a @i{scale}, +then the command will be supplied one argument which is the new numeric +value which is the scale position. A third way of accomplishing the +scrollbar setting using a lisp form is: + +@example +(listbox '.frame.listbox :yscroll '(apply '.scrollbar :set *arglist*)) +@end example + +The @code{bind} command and @code{:bind} keyword, have an additional +wrinkle, see @xref{bind}. These are associated to an event in a +particular window, and the lisp function or form to be evaled must have +access to that information. For example the x y position, the window +name, the key pressed, etc. This is done via @i{percent symbols} which +are specified, see @xref{bind}. + +@example +(bind "Entry" "" '(emacs-move %W %A )) +@end example + +@noindent +will cause the function emacs-move to be be invoked whenever a control +key is pressed (unless there are more key specific or window specific +bindings of said key). It will be invoked with two arguments, the +first %W indicating the window in which it was invoked, and the second +being a string which is the ascii keysym which was pressed at the same +time as the control key. + +These @i{percent constructs} are only permitted in commands which are +invoked via @code{bind} or @code{:bind}. The lisp form which is passed +as the command, is searched for the percent constructs, and then a +function + +@example +#'(lambda (%W %A) (emacs-move %W %A)) +@end example + +@noindent +will be invoked with two arguments, which will be supplied by the +@b{TK} graphics server, at the time the command is invoked. The +@code{*arglist*} construct is not available for these commands. + +@node Linked Variables, tkconnect, Lisp Functions Invoked from Graphics, General +@section Linked Variables + +It is possible to link lisp variables to @b{TK} variables. In general +when the @b{TK} variable is changed, by for instance clicking on a +radiobutton, the linked lisp variable will be changed. Conversely +changing the lisp variable will be noticed by the @b{TK} graphics side, if +one does the assignment in lisp using @code{setk} instead of +@code{setq}. + +@example +(button '.hello :textvariable '*message* :text "hi there") +(pack '.hello) +@end example + +This causes linking of the global variable @code{*message*} in lisp +to a corresponding variable in @b{TK}. Moreover the message that is in +the button @code{.hello} will be whatever the value of this global +variable is (so long as the @b{TK} side is notified of the change!). + +Thus if one does + +@example +(setk *message* "good bye") +@end example + +@noindent +then the button will change to have @i{good bye} as its text. +The lisp macro @code{setk} expands into + +@example +(prog1 (setf *message* "good bye") (notice-text-variables)) +@end example + +@noindent +which does the assignment, and then goes thru the linked variables +checking for those that have changed, and updating the @b{TK} side should +there be any. Thus if you have a more complex program which might +have done the assignment of your global variable, you may include +the call to @code{notice-text-variables} at the end, to assure that +the graphics side knows about the changes. + +A variable which is linked using the keyword @code{:textvariable} is +always a variable containing a string. + +However it is possible to have other types of variables. + +@example +(checkbutton '.checkbutton1 :text "A button" :variable '(boolean *joe*)) +(checkbutton '.checkbutton2 :text "A button" :variable '*joe*) +(checkbutton '.checkbutton3 :text "Debugging" :variable '(t *debug*) + :onvalue 100 :offvalue -1) +@end example + +The first two examples are the same in that the default variable type +for a checkbutton is @code{boolean}. Notice that the specification of a +variable type is by @code{(@i{type} variable)}. The types which are +permissible are those which have coercion-fucntions, @xref{Return +Values}. In the first example a variable @code{*joe*} will be linked, and +its default initial value will be set to nil, since the default initial +state of the check button is off, and the default off value is nil. +Actually on the @b{TK} side, the corresponding boolean values are @code{"1"} +and @code{"0"}, but the @code{boolean} type makes these become @code{t} +and @code{nil}. + +In the third example the variable *debug* may have any lisp value (here +@i{type} is @code{t}). The initial value will be made to be @code{-1}, +since the checkbutton is off. Clicking on @code{.checkbutton3} will +result in the value of @code{*debug*} being changed to 100, and the light +in the button will be toggled to on, @xref{checkbutton}. You may +set the variable to be another value besides 100. + +You may also call + +@example +(link-text-variable '*joe* 'boolean) +@end example + +@noindent +to cause the linking of a variable named *joe*. This is done +automatically +whenever the variable is specified after one of the keys + +@example +:variable :textvariable. +@end example + +Just as one must be cautious about using global variables in lisp, one +must be cautious in making such linked variables. In particular note +that the @b{TK} side, uses variables for various purposes. If you make a +checkbutton with pathname @code{.a.b.c} then unless you specify a +@code{:variable} option, the variable @code{c} will become associated to +the @b{TK} value of the checkbutton. We do NOT link this variable by +default, feeling that one might inadvertently alter global variables, +and that they would not typically use the lisp convention of being of +the form @code{*c*}. You must specify the @code{:variable} option, or +call @code{link-variable}. + + +@node tkconnect, , Linked Variables, General +@section tkconnect + +@example +@i{tkconnect} &key host display can-rsh gcltksrv +@end example + +This function provides a connection to a graphics server process, which +in turn connects to possibly several graphics display screens. The +graphics server process, called @file{gcltksrv} may or may not run +on the same machine as the lisp to which it is attached. +@code{display} +indicates the name of the default display to connect to, and this +in turn defaults to the value of the environment variable @code{DISPLAY}. + +When @i{tkconnect} is invoked, a socket is opened and it waits for +a graphics process to connect to it. If the host argument is not +supplied, then a process will be spawned which will connect back to +the lisp process. The name of the command for invoking the process +is the value of the @file{gcltksrv} argument, which defaults to +the value of the environment variable @code{GCL_TK_SERVER}. If that variable +is not set, then the lisp @code{*lib-directory*} is searched for +an entry @file{gcl-tk/gcltksrv}. + +If @code{host} is supplied, then a command to run on the remote machine +will be printed on standard output. If @code{can-rsh} is not nil, +then the command will not be printed, but rather an attempt will be +made to rsh to the machine, and to run the command. + +Thus + +@example +(tkconnect) +@end example + +@noindent +would start the process on the local machine, and use for @code{display} +the value of the environment variable @code{DISPLAY}. + +@example +(tkconnect :host "max.ma.utexas.edu" :can-rsh t) +@end example + +@noindent +would cause an attempt to rsh to @code{max} and to run the command +there, to connect back to the appropriate port on the localhost. + +You may indicate that different @i{toplevel} windows be on different +displays, by using the @code{:display} argument when creating the +window, @xref{toplevel}. + +Clearly you must have a copy of the program @file{gcltksrv} and @b{TK} +libraries installed on the machine where you wish to run the server. diff --git a/info/internal.texi b/info/internal.texi new file mode 100755 index 0000000..3b46ac5 --- /dev/null +++ b/info/internal.texi @@ -0,0 +1,361 @@ +@node GCL Specific, C Interface, Type, Top +@chapter GCL Specific + +@defun SYSTEM (string) +Package:LISP + +GCL specific: Executes a Shell command as if STRING is an input to the +Shell. Not all versions of GCL support this function. At least on +POSIX systems, this call should return two integers represeting the +exit status and any possible terminating signal respectively. + + +@end defun + +@defvar *TMP-DIR* +Package:COMPILER +GCL specific: Directory in which temporary ``gazonk'' files used by the +compiler are to be created. + + +@end defvar + +@defvar *IGNORE-MAXIMUM-PAGES* +Package:SI +GCL specific: Tells the GCL memory manager whether (non-NIL) or not (NIL) it +should expand memory whenever the maximum allocatable pages have been used +up. + + +@end defvar + +@defvar *OPTIMIZE-MAXIMUM-PAGES* +Package:SI + +GCL specific: Tells the GCL memory manager whether to attempt to +adjust the maximum allowable pages for each type to approximately +optimize the garbage collection load in the current process. Defaults +to T. Set to NIL if you care more about memory usage than runtime. + + +@end defvar + +@defun MACHINE-VERSION () +Package:LISP + +Returns a string that identifies the machine version of the machine +on which GCL is currently running. + + +@end defun + +@defun BY () +Package:LISP + +GCL specific: Exits from GCL. + + +@end defun + +@deffn {Macro} DEFCFUN +Package:LISP + +Syntax: +@example +(defcfun header n @{element@}*) +@end example + + +GCL specific: Defines a C-language function which calls Lisp functions +and/or handles Lisp objects. HEADER gives the header of the C +function as a string. Non-negative-integer is the number of the main +stack entries used by the C function, primarily for protecting Lisp +objects from being garbage-collected. Each ELEMENT may give a C code +fragment as a string, or it may be a list + ((symbol @{arg@}*) @{place@}*) +which, when executed, calls the Lisp function named by SYMBOL with the +specified arguments and saves the value(s) to the specified places. +The DEFCFUN form has the above meanings only after compiled; The GCL +interpreter simply ignores this form. + +An example which defines a C function list2 of two arguments, but which +calls the 'lisp' function CONS by name, and refers to the constant 'NIL. +Note to be loaded by @code{load} the function should be static. + + +(defCfun "static object list2(x,y) object x,y;" 0 + "object z;" + ('NIL z) + ((CONS y z) z) + ((CONS x z) z) + "return(z);" +) + +In lisp the operations in the body would be + (setq z 'nil) + (setq z (cons y z)) + (setq z (cons x z)) + + + +Syntax: +@example + + (defCfun header non-negative-integer + @{ string + | ( function-symbol @{ value @}* ) + | (( function-symbol @{ value @}* ) @{ place @}* ) @}) + + +value: +place: + @{ C-expr | ( C-type C-expr ) @} + +C-function-name: +C-expr: + @{ string | symbol @} + +C-type: + @{ object | int | char | float | double @} + +@end example + + + + +@end deffn + +@deffn {Macro} CLINES +Package:LISP + +Syntax: +@example +(clines @{string@}*) +@end example + +GCL specific: The GCL compiler embeds STRINGs into the intermediate C +language code. The interpreter ignores this form. + + +@end deffn + +@defun ALLOCATE (type number &optional (really-allocate nil)) +Package:LISP + +GCL specific: Sets the maximum number of pages for the type class of the +GCL implementation type TYPE to NUMBER. If REALLY-ALLOCATE is given a +non-NIL value, then the specified number of pages will be allocated +immediately. + + +@end defun + +@defun GBC (x) +Package:LISP + +GCL specific: Invokes the garbage collector (GC) with the collection level +specified by X. NIL as the argument causes GC to collect cells only. T as +the argument causes GC to collect everything. + + +@end defun + +@defun SAVE (pathname) +Package:LISP + +GCL specific: Saves the current GCL core image into a program file specified +by PATHNAME. This function depends on the version of GCL. The function +si::save-system is to be preferred in almost all circumstances. Unlike +save, it makes the relocatable section permanent, and causes no future gc of +currently loaded .o files. + +@end defun + +@defun HELP* (string &optional (package 'lisp)) +Package:LISP + +GCL specific: Prints the documentation associated with those symbols in the +specified 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. + + +@end defun + +@deffn {Macro} DEFLA +Package:LISP + +Syntax: +@example +(defla name lambda-list @{decl | doc@}* @{form@}*) +@end example + +GCL specific: Used to DEFine Lisp Alternative. For the interpreter, DEFLA is +equivalent to DEFUN, but the compiler ignores this form. + + +@end deffn + +@defun PROCLAMATION (decl-spec) +Package:LISP + +GCL specific: Returns T if the specified declaration is globally in effect; +NIL otherwise. See the doc of DECLARE for possible DECL-SPECs. + + +@end defun + +@deffn {Macro} DEFENTRY +Package:LISP + +Syntax: +@example +(defentry name arg-types c-function) +@end example + + +GCL specific: The compiler defines a Lisp function whose body consists of a +calling sequence to the C language function specified by C-FUNCTION. The +interpreter ignores this form. The ARG-TYPES specifies the C types of the +arguments which C-FUNCTION requires. The list of allowed types is (object +char int float double string). Code will be produced to coerce from a lisp +object to the appropriate type before passing the argument to the C-FUNCTION. +The c-function should be of the form (c-result-type c-fname) where +c-result-type is a member of (void object char int float double string). +c-fname may be a symbol (in which case it will be downcased) or a string. If +c-function is not a list, then (object c-function) is assumed. In order +for C code to be loaded in by @code{load} you should declare any +variables and functions to be static. If you will link them in +at build time, of course you are allowed to define new externals. + +@example + Sample usage: +--File begin----- +;; JOE takes X a lisp string and Y a fixnum and returns a character. +(clines "#include \"foo.ch\"") +(defentry joe (string int) (char "our_c_fun")) +---File end------ +---File foo.ch--- +/* C function for extracting the i'th element of a string */ +static char our_c_fun(p,i) +char *p; +int i; + @{ + return p[i]; + @} +-----File end--- +@end example + +One must be careful of storage allocation issues when passing a string. +If the C code invokes storage allocation (either by calling @code{malloc} +or @code{make_cons} etc), then there is a possibility of a garbage +collection, so that if the string passed was not constructed with +@code{:static t} when its array was constructed, then it could move. +If the C function may allocate storage, then you should pass a copy: +@example +(defun safe-c-string (x) + (let* ((n (length x)) + (a (make-array (+ n 1) :element-type 'string-char + :static t :fill-pointer n))) + (si::copy-array-portion x y 0 0 n) + (setf (aref a n) (code-char 0))) + a) + +@end example + + +@end deffn +@defun COPY-ARRAY-PORTION (x,y,i1,i2,n1) +Package:SI +Copy elements from X to Y starting at X[i1] to Y[i2] and doing N1 +elements if N1 is supplied otherwise, doing the length of X - I1 +elements. If the types of the arrays are not the same, this has +implementation dependent results. +@end defun + +@defun BYE ( &optional (exit-status 0)) +Package:LISP + +GCL specific: Exits from GCL with exit-status. + + +@end defun + +@defun USE-FAST-LINKS (turn-on) +Package:LISP + +GCL specific: If TURN-ON is not nil, the fast link mechanism is enabled, +so that ordinary function calls will not appear in the invocation stack, +and calls will be much faster. This is the default. If you anticipate +needing to see a stack trace in the debugger, then you should turn this +off. + + +@end defun + +@menu +* Bignums:: +@end menu + +@node Bignums, , GCL Specific, GCL Specific +@section Bignums + +A directory mp was added to hold the new multi precision arithmetic +code. The layout and a fair amount of code in the mp directory is an +enhanced version of gpari version 34. The gpari c code was rewritten +to be more efficient, and gcc assembler macros were added to allow +inlining of operations not possible to do in C. On a 68K machine, +this allows the C version to be as efficient as the very carefully +written assembler in the gpari distribution. For the main machines, +an assembler file (produced by gcc) based on this new method, is +included. This is for sites which do not have gcc, or do not +wish to compile the whole system with gcc. + +Bignum arithmetic is much faster now. Many changes were made to +cmpnew also, to add 'integer' as a new type. It differs from +variables of other types, in that storage is associated to each such +variable, and assignments mean copying the storage. This allows a +function which does a good deal of bignum arithmetic, to do very +little consing in the heap. An example is the computation of PI-INV +in scratchpad, which calculates the inverse of pi to a prescribed +number of bits accuracy. That function is now about 20 times faster, +and no longer causes garbage collection. In versions of GCL where +HAVE_ALLOCA is defined, the temporary storage growth is on the C +stack, although this often not so critical (for example it makes +virtually no difference in the PI-INV example, since in spite of the +many operations, only one storage allocation takes place. + +Below is the actual code for PI-INV + +On a sun3/280 (cli.com) + +Here is the comparison of lucid and gcl before and after +on that pi-inv. Times are in seconds with multiples of the +gcl/akcl time in parentheses. + +On a sun3/280 (cli.com) + +@example + +pi-inv akcl-566 franz lucid old kcl/akcl +---------------------------------------- +10000 3.3 9.2(2.8 X) 15.3 (4.6X) 92.7 (29.5 X) +20000 12.7 31.0(2.4 X) 62.2 (4.9X) 580.0 (45.5 X) + + +(defun pi-inv (bits &aux (m 0)) + (declare (integer bits m)) + (let* ((n (+ bits (integer-length bits) 11)) + (tt (truncate (ash 1 n) 882)) + (d (* 4 882 882)) + (s 0)) + (declare (integer s d tt n)) + (do ((i 2 (+ i 2)) + (j 1123 (+ j 21460))) + ((zerop tt) (cons s (- (+ n 2)))) + (declare (integer i j)) + (setq s (+ s (* j tt)) + m (- (* (- i 1) (- (* 2 i) 1) (- (* 2 i) 3))) + tt (truncate (* m tt) (* d (the integer (expt i 3)))))))) + +@end example diff --git a/info/io.texi b/info/io.texi new file mode 100755 index 0000000..426b48d --- /dev/null +++ b/info/io.texi @@ -0,0 +1,1008 @@ +@node Streams and Reading, Special Forms and Functions, Lists, Top +@chapter Streams and Reading + +@defun MAKE-ECHO-STREAM (input-stream output-stream) +Package:LISP + +Returns a bidirectional stream which gets its input from INPUT-STREAM and +sends its output to OUTPUT-STREAM. In addition, all input is echoed to +OUTPUT-STREAM. + + +@end defun + +@defvar *READTABLE* +Package:LISP +The current readtable. + + +@end defvar + +@defun LOAD (filename &key (verbose *load-verbose*) (print nil) (if-does-not-exist :error)) +Package:LISP + +Loads the file named by FILENAME into GCL. + + +@end defun + +@defun OPEN (filename &key (direction :input) (element-type 'string-char) (if-exists :error) (if-does-not-exist :error)) +Package:LISP + +Opens the file specified by FILENAME, which may be a string, a pathname, +or a stream. Returns a stream for the open file. +DIRECTION is :INPUT, :OUTPUT, :IO or :PROBE. +ELEMENT-TYPE is STRING-CHAR, (UNSIGNED-BYTE n), +UNSIGNED-BYTE, (SIGNED-BYTE n), SIGNED-BYTE, CHARACTER, BIT, (MOD n), or +:DEFAULT. +IF-EXISTS is :ERROR, :NEW-VERSION, :RENAME, +:RENAME-AND-DELETE, :OVERWRITE, :APPEND, :SUPERSEDE, or NIL. +IF-DOES-NOT-EXIST is :ERROR, :CREATE, or NIL. + +If FILENAME begins with a vertical pipe sign: '|' then the resulting +stream is actually a one way pipe. It will be open for reading +or writing depending on the direction given. The rest +of FILENAME in this case is passed to the /bin/sh command. See +the posix description of popen for more details. +@example +(setq pipe (open "| wc < /tmp/jim")) +(format t "File has ~%d lines" (read pipe)) +(close pipe) +@end example + +@end defun + +@defvar *PRINT-BASE* +Package:LISP +The radix in which the GCL printer prints integers and rationals. +The value must be an integer from 2 to 36, inclusive. + + +@end defvar + +@defun MAKE-STRING-INPUT-STREAM (string &optional (start 0) (end (length string))) +Package:LISP + +Returns an input stream which will supply the characters of String between +Start and End in order. + + +@end defun + +@defun PPRINT (object &optional (stream *standard-output*)) +Package:LISP + +Pretty-prints OBJECT. Returns OBJECT. Equivalent to + (WRITE :STREAM STREAM :PRETTY T) +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) +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. + + +@end defun + +@defvar *READ-DEFAULT-FLOAT-FORMAT* +Package:LISP +The floating-point format the GCL reader uses when reading floating-point +numbers that have no exponent marker or have e or E for an exponent marker. +Must be one of SHORT-FLOAT, SINGLE-FLOAT, DOUBLE-FLOAT, and LONG-FLOAT. + + +@end defvar + +@defun READ-PRESERVING-WHITESPACE (&optional (stream *standard-input*) (eof-error-p t) (eof-value nil) (recursive-p nil)) +Package:LISP + +Reads an object from STREAM, preserving the whitespace that followed the +object. + + +@end defun + +@defun STREAMP (x) +Package:LISP + +Returns T if X is a stream object; NIL otherwise. + + +@end defun + + +@defun SET-DISPATCH-MACRO-CHARACTER (disp-char sub-char function &optional (readtable *readtable*)) +Package:LISP + +Causes FUNCTION to be called when the DISP-CHAR followed by SUB-CHAR is +read. + + +@end defun + +@deffn {Macro} WITH-OUTPUT-TO-STRING +Package:LISP + +Syntax: +@example +(with-output-to-string (var [string]) @{decl@}* @{form@}*) +@end example + +Binds VAR to a string output stream that puts characters into STRING, which +defaults to a new string. The stream is automatically closed on exit and +the string is returned. + + +@end deffn + +@defun FILE-LENGTH (file-stream) +Package:LISP + +Returns the length of the specified file stream. + + +@end defun + +@defvar *PRINT-CASE* +Package:LISP +The case in which the GCL printer should print ordinary symbols. +The value must be one of the keywords :UPCASE, :DOWNCASE, and :CAPITALIZE. + + +@end defvar + +@defun PRINT (object &optional (stream *standard-output*)) +Package:LISP + +Outputs a newline character, and then prints OBJECT in the mostly readable +representation. Returns OBJECT. Equivalent to + (PROGN (TERPRI STREAM) (WRITE OBJECT :STREAM STREAM :ESCAPE T)). + + +@end defun + +@defun SET-MACRO-CHARACTER (char function &optional (non-terminating-p nil) (readtable *readtable*)) +Package:LISP + +Causes CHAR to be a macro character that, when seen by READ, causes FUNCTION +to be called. + + +@end defun + +@defun FORCE-OUTPUT (&optional (stream *standard-output*)) +Package:LISP + +Attempts to force any buffered output to be sent. + + +@end defun + +@defvar *PRINT-ARRAY* +Package:LISP +Whether the GCL printer should print array elements. + + +@end defvar + +@defun STREAM-ELEMENT-TYPE (stream) +Package:LISP + +Returns a type specifier for the kind of object returned by STREAM. + + +@end defun + +@defun WRITE-BYTE (integer stream) +Package:LISP + +Outputs INTEGER to the binary stream STREAM. Returns INTEGER. + + +@end defun + +@defun MAKE-CONCATENATED-STREAM (&rest streams) +Package:LISP + +Returns a stream which takes its input from each of the STREAMs in turn, +going on to the next at end of stream. + + +@end defun + +@defun PRIN1 (object &optional (stream *standard-output*)) +Package:LISP + +Prints OBJECT in the mostly readable representation. Returns OBJECT. +Equivalent to (WRITE OBJECT :STREAM STREAM :ESCAPE T). + + +@end defun + +@defun PRINC (object &optional (stream *standard-output*)) +Package:LISP + +Prints OBJECT without escape characters. Returns OBJECT. Equivalent to + (WRITE OBJECT :STREAM STREAM :ESCAPE NIL). + + +@end defun + +@defun CLEAR-OUTPUT (&optional (stream *standard-output*)) +Package:LISP + +Clears the output stream STREAM. + + +@end defun + +@defun TERPRI (&optional (stream *standard-output*)) +Package:LISP + +Outputs a newline character. + + +@end defun + +@defun FINISH-OUTPUT (&optional (stream *standard-output*)) +Package:LISP + +Attempts to ensure that all output sent to STREAM has reached its destination, +and only then returns. + + +@end defun + +@deffn {Macro} WITH-OPEN-FILE +Package:LISP + +Syntax: +@example +(with-open-file (stream filename @{options@}*) @{decl@}* @{form@}*) +@end example + +Opens the file whose name is FILENAME, using OPTIONs, and binds the variable +STREAM to a stream to/from the file. Then evaluates FORMs as a PROGN. +The file is automatically closed on exit. + + +@end deffn + +@deffn {Special Form} DO +Package:LISP + +Syntax: +@example +(do (@{(var [init [step]])@}*) (endtest @{result@}*) + @{decl@}* @{tag | statement@}*) +@end example + +Creates a NIL block, binds each VAR to the value of the corresponding INIT, +and then executes STATEMENTs repeatedly until ENDTEST is satisfied. After +each iteration, assigns to each VAR the value of the corresponding STEP. When +ENDTEST is satisfied, evaluates RESULTs as a PROGN and returns the value(s) of +the last RESULT (or NIL if no RESULTs are supplied). Performs variable +bindings and assignments all at once, just like LET and PSETQ do. + + +@end deffn + +@defun READ-FROM-STRING (string &optional (eof-error-p t) (eof-value nil) &key (start 0) (end (length string)) (preserve-whitespace nil)) +Package:LISP + +Reads an object from STRING. + + +@end defun + +@defun WRITE-STRING (string &optional (stream *standard-output*) &key (start 0) (end (length string))) +Package:LISP + +Outputs STRING and returns it. + + +@end defun + +@defvar *PRINT-LEVEL* +Package:LISP +How many levels deep the GCL printer should print. Unlimited if NIL. + + +@end defvar + +@defvar *PRINT-RADIX* +Package:LISP +Whether the GCL printer should print the radix indicator when printing +integers and rationals. + + +@end defvar + +@defun Y-OR-N-P (&optional (format-string nil) &rest args) +Package:LISP + +Asks the user a question whose answer is either 'Y' or 'N'. If FORMAT-STRING +is non-NIL, then FRESH-LINE operation is performed, a message is printed as +if FORMAT-STRING and ARGs were given to FORMAT, and then a prompt +"(Y or N)" is printed. Otherwise, no prompt will appear. + + +@end defun + +@defun MAKE-BROADCAST-STREAM (&rest streams) +Package:LISP + +Returns an output stream which sends its output to all of the given streams. + + +@end defun + +@defun READ-CHAR (&optional (stream *standard-input*) (eof-error-p t) (eof-value nil) (recursive-p nil)) +Package:LISP + +Reads a character from STREAM. + + +@end defun + +@defun PEEK-CHAR (&optional (peek-type nil) (stream *standard-input*) (eof-error-p t) (eof-value nil) (recursive-p nil)) +Package:LISP + +Peeks at the next character in the input stream STREAM. + + +@end defun + +@defun OUTPUT-STREAM-P (stream) +Package:LISP + +Returns non-nil if STREAM can handle output operations; NIL otherwise. + + +@end defun + +@defvar *QUERY-IO* +Package:LISP +The query I/O stream. + + +@end defvar + +@defvar *READ-BASE* +Package:LISP +The radix that the GCL reader reads numbers in. + + +@end defvar + +@deffn {Macro} WITH-OPEN-STREAM +Package:LISP + +Syntax: +@example +(with-open-stream (var stream) @{decl@}* @{form@}*) +@end example + +Evaluates FORMs as a PROGN with VAR bound to the value of STREAM. The stream +is automatically closed on exit. + + +@end deffn + +@deffn {Macro} WITH-INPUT-FROM-STRING +Package:LISP + +Syntax: +@example +(with-input-from-string (var string @{keyword value@}*) @{decl@}* +@{form@}*) +@end example + +Binds VAR to an input stream that returns characters from STRING and evaluates +the FORMs. The stream is automatically closed on exit. Allowed keywords are +:INDEX, :START, and :END. + + +@end deffn + +@defun CLEAR-INPUT (&optional (stream *standard-input*)) +Package:LISP + Clears the input +stream STREAM. + + +@end defun + +@defvar *TERMINAL-IO* +Package:LISP +The terminal I/O stream. + + +@end defvar + +@defun LISTEN (&optional (stream *standard-input*)) +Package:LISP + +Returns T if a character is available on STREAM; NIL otherwise. This function +does not correctly work in some versions of GCL because of the lack of such +mechanism in the underlying operating system. + + +@end defun + +@defun MAKE-PATHNAME (&key (defaults (parse-namestring "" (pathname-host *default-pathname-defaults*))) (host (pathname-host defaults)) (device (pathname-device defaults)) (directory (pathname-directory defaults)) (name (pathname-name defaults)) (type (pathname-type defaults)) (version (pathname-version defaults))) +Package:LISP + +Create a pathname from HOST, DEVICE, DIRECTORY, NAME, TYPE and VERSION. + + +@end defun + +@defun PATHNAME-TYPE (pathname) +Package:LISP + +Returns the type slot of PATHNAME. + + +@end defun + +@defvar *PRINT-GENSYM* +Package:LISP +Whether the GCL printer should prefix symbols with no home package +with "#:". + + +@end defvar + +@defun READ-LINE (&optional (stream *standard-input*) (eof-error-p t) (eof-value nil) (recursive-p nil)) +Package:LISP + +Returns a line of text read from STREAM as a string, discarding the newline +character. + +Note that when using line at a time input under unix, +input forms will always be followed by a #\newline. Thus if you +do + +>(read-line) +"" +nil + +the empty string will be returned. After lisp reads the (read-line) +it then invokes (read-line). This happens before it does anything +else and so happens before the newline character immediately following +(read-line) has been read. Thus read-line immediately encounters a +#\newline and so returns the empty string. If there had been other +characters before the #\newline it would have been different: + +>(read-line) how are you +" how are you" +nil + +If you want to throw away "" input, you can do that with +the following: + +(sloop::sloop while (equal (setq input (read-line)) "")) + +You may also want to use character at a time input, but that +makes input editing harder. +nicolas% stty cbreak +nicolas% gcl +GCL (GNU Common Lisp) Version(1.1.2) Mon Jan 9 12:58:22 MET 1995 +Licensed under GNU Public Library License +Contains Enhancements by W. Schelter + +>(let ((ifilename nil)) + (format t "~%Input file name: ") + (setq ifilename (read-line))) +Input file name: /tmp/myfile +"/tmp/myfile" + +>(bye)Bye. + + + + +@end defun + +@defun WRITE-TO-STRING (object &key (escape *print-escape*) (radix *print-radix*) (base *print-base*) (circle *print-circle*) (pretty *print-pretty*) (level *print-level*) (length *print-length*) (case *print-case*) (array *print-array*) (gensym *print-gensym*)) +Package:LISP + +Returns as a string the printed representation of OBJECT in the specified +mode. See the variable docs of *PRINT-...* for the mode. + + +@end defun + +@defun PATHNAMEP (x) +Package:LISP + +Returns T if X is a pathname object; NIL otherwise. + + +@end defun + +@defun READTABLEP (x) +Package:LISP + +Returns T if X is a readtable object; NIL otherwise. + + +@end defun + +@defun READ (&optional (stream *standard-input*) (eof-error-p t) (eof-value nil) (recursivep nil)) +Package:LISP + +Reads in the next object from STREAM. + + +@end defun + +@defun NAMESTRING (pathname) +Package:LISP + +Returns the full form of PATHNAME as a string. + + +@end defun + +@defun UNREAD-CHAR (character &optional (stream *standard-input*)) +Package:LISP + +Puts CHARACTER back on the front of the input stream STREAM. + + +@end defun + +@defun CLOSE (stream &key (abort nil)) +Package:LISP + +Closes STREAM. A non-NIL value of :ABORT indicates an abnormal termination. + + +@end defun + +@defvar *PRINT-LENGTH* +Package:LISP +How many elements the GCL printer should print at each level of nested data +object. Unlimited if NIL. + + +@end defvar + +@defun SET-SYNTAX-FROM-CHAR (to-char from-char &optional (to-readtable *readtable*) (from-readtable nil)) +Package:LISP + +Makes the syntax of TO-CHAR in TO-READTABLE be the same as the syntax of +FROM-CHAR in FROM-READTABLE. + + +@end defun + +@defun INPUT-STREAM-P (stream) +Package:LISP + +Returns non-NIL if STREAM can handle input operations; NIL otherwise. + + +@end defun + +@defun PATHNAME (x) +Package:LISP + +Turns X into a pathname. X may be a string, symbol, stream, or pathname. + + +@end defun + +@defun FILE-NAMESTRING (pathname) +Package:LISP + +Returns the written representation of PATHNAME as a string. + + +@end defun + +@defun MAKE-DISPATCH-MACRO-CHARACTER (char &optional (non-terminating-p nil) (readtable *readtable*)) +Package:LISP + +Causes the character CHAR to be a dispatching macro character in READTABLE. + + +@end defun + +@defvar *STANDARD-OUTPUT* +Package:LISP +The default output stream used by the GCL printer. + + +@end defvar + +@defun MAKE-TWO-WAY-STREAM (input-stream output-stream) +Package:LISP + +Returns a bidirectional stream which gets its input from INPUT-STREAM and +sends its output to OUTPUT-STREAM. + + +@end defun + +@defvar *PRINT-ESCAPE* +Package:LISP +Whether the GCL printer should put escape characters whenever appropriate. + + +@end defvar + +@defun COPY-READTABLE (&optional (from-readtable *readtable*) (to-readtable nil)) +Package:LISP + +Returns a copy of the readtable FROM-READTABLE. If TO-READTABLE is non-NIL, +then copies into TO-READTABLE. Otherwise, creates a new readtable. + + +@end defun + +@defun DIRECTORY-NAMESTRING (pathname) +Package:LISP + +Returns the directory part of PATHNAME as a string. + + +@end defun + +@defun TRUENAME (pathname) +Package:LISP + +Returns the pathname for the actual file described by PATHNAME. + + +@end defun + +@defvar *READ-SUPPRESS* +Package:LISP +When the value of this variable is NIL, the GCL reader operates normally. +When it is non-NIL, then the reader parses input characters but much of what +is read is not interpreted. + + +@end defvar + +@defun GET-DISPATCH-MACRO-CHARACTER (disp-char sub-char &optional (readtable *readtable*)) +Package:LISP + +Returns the macro-character function for SUB-CHAR under DISP-CHAR. + + +@end defun + +@defun PATHNAME-DEVICE (pathname) +Package:LISP + +Returns the device slot of PATHNAME. + + +@end defun + +@defun READ-CHAR-NO-HANG (&optional (stream *standard-input*) (eof-error-p t) (eof-value nil) (recursive-p nil)) +Package:LISP + +Returns the next character from STREAM if one is available; NIL otherwise. + + +@end defun + +@defun FRESH-LINE (&optional (stream *standard-output*)) +Package:LISP + +Outputs a newline if it is not positioned at the beginning of a line. Returns +T if it output a newline; NIL otherwise. + + +@end defun + +@defun WRITE-CHAR (char &optional (stream *standard-output*)) +Package:LISP + +Outputs CHAR and returns it. + + +@end defun + +@defun PARSE-NAMESTRING (thing &optional host (defaults *default-pathname-defaults*) &key (start 0) (end (length thing)) (junk-allowed nil)) +Package:LISP + +Parses a string representation of a pathname into a pathname. HOST +is ignored. + + +@end defun + +@defun PATHNAME-DIRECTORY (pathname) +Package:LISP + +Returns the directory slot of PATHNAME. + + +@end defun + +@defun GET-MACRO-CHARACTER (char &optional (readtable *readtable*)) +Package:LISP + +Returns the function associated with CHAR and, as a second value, returns +the non-terminating-p flag. + + +@end defun + +@defun FORMAT (destination control-string &rest arguments) +Package:LISP + +Provides various facilities for formatting output. +DESTINATION controls where the result will go. If DESTINATION is T, then +the output is sent to the standard output stream. If it is NIL, then the +output is returned in a string as the value of the call. Otherwise, +DESTINATION must be a stream to which the output will be sent. + +CONTROL-STRING is a string to be output, possibly with embedded +formatting directives, which are flagged with the escape character +"~". Directives generally expand into additional text to be output, +usually consuming one or more of ARGUMENTs in the process. + + + +A few useful directives are: +@example + +~A, ~nA, ~n@@A Prints one argument as if by PRINC +~S, ~nS, ~n@@S Prints one argument as if by PRIN1 +~D, ~B, ~O, ~X Prints one integer in decimal, binary, octal, and hexa +~% Does TERPRI +~& Does FRESH-LINE +@end example + +where n is the minimal width of the field in which the object is printed. +~nA and ~nS put padding spaces on the right; ~n@@A and ~n@@S put on the left. + +@example +~R is for printing numbers in various formats. + + ~nR prints arg in radix n. + ~R prints arg as a cardinal english number: two + ~:R prints arg as an ordinal english number: third + ~@@R prints arg as an a Roman Numeral: VII + ~:@@R prints arg as an old Roman Numeral: IIII + +~C prints a character. + ~:C represents non printing characters by their pretty names,eg Space + ~@@C uses the #\ syntax to allow the reader to read it. + +~F prints a floating point number arg. + The full form is ~w,d,k,overflowchar,padcharF + w represents the total width of the printed representation (variable if + not present) + d the number of fractional digits to display + (format nil "~,2f" 10010.0314) --> "10010.03" + k arg is multiplied by 10^k before printing it as a decimal number. + overflowchar width w characters copies of the overflow character will + be printed. eg(format t "X>~5,2,,'?F X>?????~10,2,1,'?,'bFX>bbb1000.34 "BIL" + (format nil "~@@[x = ~d ~]~a" 8) --> "x = 8 BIL" +@end example + + +@end defun + +@defun PATHNAME-NAME (pathname) +Package:LISP + +Returns the name slot of PATHNAME. + + +@end defun + +@defun MAKE-STRING-OUTPUT-STREAM () +Package:LISP + +Returns an output stream which will accumulate all output given it for +the benefit of the function GET-OUTPUT-STREAM-STRING. + + +@end defun + +@defun MAKE-SYNONYM-STREAM (symbol) +Package:LISP + +Returns a stream which performs its operations on the stream which is the +value of the dynamic variable named by SYMBOL. + + +@end defun + +@defvar *LOAD-VERBOSE* +Package:LISP +The default for the VERBOSE argument to LOAD. + + +@end defvar + +@defvar *PRINT-CIRCLE* +Package:LISP +Whether the GCL printer should take care of circular lists. + + +@end defvar + +@defvar *PRINT-PRETTY* +Package:LISP +Whether the GCL printer should pretty-print. See the function doc of PPRINT +for more information about pretty-printing. + + +@end defvar + +@defun FILE-WRITE-DATE (file) +Package:LISP + +Returns the time at which the specified file is written, as an integer in +universal time format. FILE may be a string or a stream. + + +@end defun + +@defun PRIN1-TO-STRING (object) +Package:LISP + +Returns as a string the printed representation of OBJECT in the mostly +readable representation. +Equivalent to (WRITE-TO-STRING OBJECT :ESCAPE T). + + +@end defun + +@defun MERGE-PATHNAMES (pathname &optional (defaults *default-pathname-defaults*) default-version) +Package:LISP + +Fills in unspecified slots of PATHNAME from DEFAULTS. DEFAULT-VERSION +is ignored in GCL. + + +@end defun + +@defun READ-BYTE (stream &optional (eof-error-p t) (eof-value nil)) +Package:LISP + +Reads the next byte from STREAM. + + +@end defun + +@defun PRINC-TO-STRING (object) +Package:LISP + +Returns as a string the printed representation of OBJECT without escape +characters. Equivalent to + (WRITE-TO-STRING OBJECT :ESCAPE NIL). + + +@end defun + +@defvar *STANDARD-INPUT* +Package:LISP +The default input stream used by the GCL reader. + + +@end defvar + +@defun PROBE-FILE (file) +Package:LISP + +Returns the truename of file if the file exists. +Returns NIL otherwise. + + +@end defun + +@defun PATHNAME-VERSION (pathname) +Package:LISP + +Returns the version slot of PATHNAME. + + +@end defun + +@defun WRITE-LINE (string &optional (stream *standard-output*) &key (start 0) (end (length string))) +Package:LISP + +Outputs STRING and then outputs a newline character. Returns STRING. + + +@end defun + +@defun WRITE (object &key (stream *standard-output*) (escape *print-escape*) (radix *print-radix*) (base *print-base*) (circle *print-circle*) (pretty *print-pretty*) (level *print-level*) (length *print-length*) (case *print-case*) (array *print-array*) (gensym *print-gensym*)) +Package:LISP + +Prints OBJECT in the specified mode. See the variable docs of *PRINT-...* +for the mode. + + +@end defun + +@defun GET-OUTPUT-STREAM-STRING (stream) +Package:LISP + +Returns a string of all the characters sent to STREAM made by +MAKE-STRING-OUTPUT-STREAM since the last call to this function. + + +@end defun + +@defun READ-DELIMITED-LIST (char &optional (stream *standard-input*) (recursive-p nil)) +Package:LISP + +Reads objects from STREAM until the next character after an object's +representation is CHAR. Returns a list of the objects read. + + +@end defun + +@defun READLINE-ON () +Package:SI + +Begins readline command editing mode when possible. In addition to +the basic readline editing features, command word completion is +implemented according to the following scheme: + +[[pkg]:[:]]txt + +pkg -- an optional package specifier. Defaults to the current +package. The symbols in this package and those in the packages in +this package's use list will be searched. + +:[:] -- an optional internal/external specifier. Defaults to +external. The keyword package is denoted by a single colon at the +beginning of the token. Only symbols of this type will be searched +for completion. + +txt -- a string. Symbol names beginning with this string are +completed. The comparison is case insensitive. + + +@end defun + +@defun READLINE-OFF () +Package:SI + +Disables readline command editing mode. + +@end defun + +@defvar *READLINE-PREFIX* +Package:SI + +A string implicitly prepended to input text for use in readline +command completion. If this string contains one or more colons, it is +used to specify the default package and internal/external setting for +searched symbols in the case that the supplied text itself contains no +explicit package specification. If this string contains characters +after the colon(s), or contains no colons at all, it is treated as a +symbol name prefix. In this case, the prefix is matched first, then +the supplied text, and the completion returned is relative to the +supplied text itself, i.e. contains no prefix. For example, the +setting ``maxima::$'' will complete input text ``int'' according to +the internal symbols in the maxima package of the form +``maxima::$int...'', and return suggestions to the user of the form +``int...''. + +@end defvar + diff --git a/info/iteration.texi b/info/iteration.texi new file mode 100755 index 0000000..fab87a2 --- /dev/null +++ b/info/iteration.texi @@ -0,0 +1,149 @@ +@node Iteration and Tests, User Interface, Structures, Top +@chapter Iteration and Tests + +@deffn {Macro} DO-EXTERNAL-SYMBOLS +Package:LISP + +Syntax: +@example +(do-external-symbols (var [package [result-form]]) + @{decl@}* @{tag | statement@}*) +@end example + +Executes STATEMENTs once for each external symbol in the PACKAGE (which +defaults to the current package), with VAR bound to the current symbol. +Then evaluates RESULT-FORM (which defaults to NIL) and returns the value(s). + + +@end deffn + +@deffn {Special Form} DO* +Package:LISP + +Syntax: +@example +(do* (@{(var [init [step]])@}*) (endtest @{result@}*) + @{decl@}* @{tag | statement@}*) +@end example + +Just like DO, but performs variable bindings and assignments in serial, just +like LET* and SETQ do. + + +@end deffn + +@deffn {Macro} DO-ALL-SYMBOLS +Package:LISP + +Syntax: +@example +(do-all-symbols (var [result-form]) @{decl@}* @{tag | statement@}*) +@end example + +Executes STATEMENTs once for each symbol in each package, with VAR bound to +the current symbol. Then evaluates RESULT-FORM (which defaults to NIL) and +returns the value(s). + + +@end deffn + +@defun YES-OR-NO-P (&optional (format-string nil) &rest args) +Package:LISP + +Asks the user a question whose answer is either 'YES' or 'NO'. If FORMAT- +STRING is non-NIL, then FRESH-LINE operation is performed, a message is +printed as if FORMAT-STRING and ARGs were given to FORMAT, and then a prompt +"(Yes or No)" is printed. Otherwise, no prompt will appear. + + +@end defun + +@defun MAPHASH #'hash-table +Package:LISP + +For each entry in HASH-TABLE, calls FUNCTION on the key and value of the +entry; returns NIL. + + +@end defun + +@defun MAPCAR (fun list &rest more-lists) +Package:LISP + +Applies FUN to successive cars of LISTs and returns the results as a list. + + +@end defun + +@deffn {Special Form} DOLIST +Package:LISP + +Syntax: +@example +(dolist (var listform [result]) @{decl@}* @{tag | statement@}*) +@end example + +Executes STATEMENTs, with VAR bound to each member of the list value of +LISTFORM. Then returns the value(s) of RESULT (which defaults to NIL). + + +@end deffn + +@defun EQ (x y) +Package:LISP + +Returns T if X and Y are the same identical object; NIL otherwise. + + +@end defun + +@defun EQUALP (x y) +Package:LISP + +Returns T if X and Y are EQUAL, if they are characters and satisfy CHAR-EQUAL, +if they are numbers and have the same numerical value, or if they have +components that are all EQUALP. Returns NIL otherwise. + + +@end defun + +@defun EQUAL (x y) +Package:LISP + +Returns T if X and Y are EQL or if they are of the same type and corresponding +components are EQUAL. Returns NIL otherwise. Strings and bit-vectors are +EQUAL if they are the same length and have identical components. Other +arrays must be EQ to be EQUAL. + + +@end defun + +@deffn {Macro} DO-SYMBOLS +Package:LISP + +Syntax: +@example +(do-symbols (var [package [result-form]]) @{decl@}* @{tag | +statement@}*) +@end example + +Executes STATEMENTs once for each symbol in the PACKAGE (which defaults to +the current package), with VAR bound to the current symbol. Then evaluates +RESULT-FORM (which defaults to NIL) and returns the value(s). + + +@end deffn + +@deffn {Special Form} LOOP +Package:LISP + +Syntax: +@example +(loop @{form@}*) +@end example + +Executes FORMs repeatedly until exited by a THROW or RETURN. The FORMs are +surrounded by an implicit NIL block. + + +@end deffn diff --git a/info/list.texi b/info/list.texi new file mode 100755 index 0000000..12c5889 --- /dev/null +++ b/info/list.texi @@ -0,0 +1,899 @@ +@node Lists, Streams and Reading, Characters, Top +@chapter Lists + +@defun NINTERSECTION (list1 list2 &key (test #'eql) test-not (key #'identity)) +Package:LISP + +Returns the intersection of LIST1 and LIST2. LIST1 may be destroyed. + + +@end defun + +@defun RASSOC-IF (predicate alist) +Package:LISP + +Returns the first cons in ALIST whose cdr satisfies PREDICATE. + + +@end defun + +@defun MAKE-LIST (size &key (initial-element nil)) +Package:LISP + +Creates and returns a list containing SIZE elements, each of which is +initialized to INITIAL-ELEMENT. + + +@end defun + +@defun NTH (n list) +Package:LISP + +Returns the N-th element of LIST, where the car of LIST is the zeroth +element. + + +@end defun + +@defun CAAR (x) +Package:LISP + +Equivalent to (CAR (CAR X)). + + +@end defun + +@defun NULL (x) +Package:LISP + +Returns T if X is NIL; NIL otherwise. + + +@end defun + +@defun FIFTH (x) +Package:LISP + +Equivalent to (CAR (CDDDDR X)). + + +@end defun + +@defun NCONC (&rest lists) +Package:LISP + +Concatenates LISTs by destructively modifying them. + + +@end defun + +@defun TAILP (sublist list) +Package:LISP + +Returns T if SUBLIST is one of the conses in LIST; NIL otherwise. + + +@end defun + +@defun CONSP (x) +Package:LISP + +Returns T if X is a cons; NIL otherwise. + + +@end defun + +@defun TENTH (x) +Package:LISP + +Equivalent to (CADR (CDDDDR (CDDDDR X))). + + +@end defun + +@defun LISTP (x) +Package:LISP + +Returns T if X is either a cons or NIL; NIL otherwise. + + +@end defun + +@defun MAPCAN (fun list &rest more-lists) +Package:LISP + +Applies FUN to successive cars of LISTs, NCONCs the results, and returns it. + + +@end defun + +@defun EIGHTH (x) +Package:LISP + +Equivalent to (CADDDR (CDDDDR X)). + + +@end defun + +@defun LENGTH (sequence) +Package:LISP + +Returns the length of SEQUENCE. + + +@end defun + +@defun RASSOC (item alist &key (test #'eql) test-not (key #'identity)) +Package:LISP + +Returns the first cons in ALIST whose cdr is equal to ITEM. + + +@end defun + +@defun NSUBST-IF-NOT (new test tree &key (key #'identity)) +Package:LISP + +Substitutes NEW for subtrees of TREE that do not satisfy TEST. + + +@end defun + +@defun NBUTLAST (list &optional (n 1)) +Package:LISP + +Changes the cdr of the N+1 th cons from the end of the list LIST to NIL. +Returns the whole list. + + +@end defun + + + +@defun CDR (list) +Package:LISP + +Returns the cdr of LIST. Returns NIL if LIST is NIL. + + +@end defun + +@defun MAPC (fun list &rest more-lists) +Package:LISP + +Applies FUN to successive cars of LISTs. Returns the first LIST. + + +@end defun + +@defun MAPL (fun list &rest more-lists) +Package:LISP + +Applies FUN to successive cdrs of LISTs. Returns the first LIST. + + +@end defun + +@defun CONS (x y) +Package:LISP + +Returns a new cons whose car and cdr are X and Y, respectively. + + +@end defun + +@defun LIST (&rest args) +Package:LISP + +Returns a list of its arguments + + +@end defun + + +@defun THIRD (x) +Package:LISP + +Equivalent to (CADDR X). + + +@end defun + +@defun CDDAAR (x) +Package:LISP + +Equivalent to (CDR (CDR (CAR (CAR X)))). + + +@end defun + +@defun CDADAR (x) +Package:LISP + +Equivalent to (CDR (CAR (CDR (CAR X)))). + + +@end defun + +@defun CDAADR (x) +Package:LISP + +Equivalent to (CDR (CAR (CAR (CDR X)))). + + +@end defun + +@defun CADDAR (x) +Package:LISP + +Equivalent to (CAR (CDR (CDR (CAR X)))). + + +@end defun + +@defun CADADR (x) +Package:LISP + +Equivalent to (CAR (CDR (CAR (CDR X)))). + + +@end defun + +@defun CAADDR (x) +Package:LISP + +Equivalent to (CAR (CAR (CDR (CDR X)))). + + +@end defun + +@defun NTHCDR (n list) +Package:LISP + +Returns the result of performing the CDR operation N times on LIST. + + +@end defun + +@defun PAIRLIS (keys data &optional (alist nil)) +Package:LISP + +Constructs an association list from KEYS and DATA adding to ALIST. + + +@end defun + +@defun SEVENTH (x) +Package:LISP + +Equivalent to (CADDR (CDDDDR X)). + + +@end defun + +@defun SUBSETP (list1 list2 &key (test #'eql) test-not (key #'identity)) +Package:LISP + +Returns T if every element of LIST1 appears in LIST2; NIL otherwise. + + +@end defun + +@defun NSUBST-IF (new test tree &key (key #'identity)) +Package:LISP + +Substitutes NEW for subtrees of TREE that satisfy TEST. + + +@end defun + +@defun COPY-LIST (list) +Package:LISP + +Returns a new copy of LIST. + + +@end defun + +@defun LAST (list) +Package:LISP + +Returns the last cons in LIST + + +@end defun + +@defun CAAAR (x) +Package:LISP + +Equivalent to (CAR (CAR (CAR X))). + + +@end defun + +@defun LIST-LENGTH (list) +Package:LISP + +Returns the length of LIST, or NIL if LIST is circular. + + +@end defun + +@defun CDDDR (x) +Package:LISP + +Equivalent to (CDR (CDR (CDR X))). + + +@end defun + +@defun INTERSECTION (list1 list2 &key (test #'eql) test-not (key #'identity)) +Package:LISP + +Returns the intersection of List1 and List2. + + +@end defun + +@defun NSUBST (new old tree &key (test #'eql) test-not (key #'identity)) +Package:LISP + +Substitutes NEW for subtrees in TREE that match OLD. + + +@end defun + +@defun REVAPPEND (x y) +Package:LISP + +Equivalent to (APPEND (REVERSE X) Y) + + +@end defun + +@defun CDAR (x) +Package:LISP + +Equivalent to (CDR (CAR X)). + + +@end defun + +@defun CADR (x) +Package:LISP + +Equivalent to (CAR (CDR X)). + + +@end defun + +@defun REST (x) +Package:LISP + +Equivalent to (CDR X). + + +@end defun + +@defun NSET-EXCLUSIVE-OR (list1 list2 &key (test #'eql) test-not (key #'identity)) +Package:LISP + +Returns a list with elements which appear but once in LIST1 and LIST2. + + +@end defun + +@defun ACONS (key datum alist) +Package:LISP + +Constructs a new alist by adding the pair (KEY . DATUM) to ALIST. + + +@end defun + +@defun SUBST-IF-NOT (new test tree &key (key #'identity)) +Package:LISP + +Substitutes NEW for subtrees of TREE that do not satisfy TEST. + + +@end defun + +@defun RPLACA (x y) +Package:LISP + +Replaces the car of X with Y, and returns the modified X. + + +@end defun + +@defun SECOND (x) +Package:LISP + +Equivalent to (CADR X). + + +@end defun + +@defun NUNION (list1 list2 &key (test #'eql) test-not (key #'identity)) +Package:LISP + +Returns the union of LIST1 and LIST2. LIST1 and/or LIST2 may be destroyed. + + +@end defun + +@defun BUTLAST (list &optional (n 1)) +Package:LISP + +Creates and returns a list with the same elements as LIST but without the +last N elements. + + +@end defun + +@defun COPY-ALIST (alist) +Package:LISP + Returns a new copy of ALIST. + + +@end defun + +@defun SIXTH (x) +Package:LISP + Equivalent to (CADR (CDDDDR X)). + + +@end defun + +@defun CAAAAR (x) +Package:LISP + +Equivalent to (CAR (CAR (CAR (CAR X)))). + + +@end defun + +@defun CDDDAR (x) +Package:LISP + +Equivalent to (CDR (CDR (CDR (CAR X)))). + + +@end defun + +@defun CDDADR (x) +Package:LISP + +Equivalent to (CDR (CDR (CAR (CDR X)))). + + +@end defun + +@defun CDADDR (x) +Package:LISP + +Equivalent to (CDR (CAR (CDR (CDR X)))). + + +@end defun + +@defun CADDDR (x) +Package:LISP + +Equivalent to (CAR (CDR (CDR (CDR X)))). + + +@end defun + +@defun FOURTH (x) +Package:LISP + +Equivalent to (CADDDR X). + + +@end defun + +@defun NSUBLIS (alist tree &key (test #'eql) test-not (key #'identity)) +Package:LISP + +Substitutes from ALIST for subtrees of TREE. + + +@end defun + +@defun SUBST-IF (new test tree &key (key #'identity)) +Package:LISP + +Substitutes NEW for subtrees of TREE that satisfy TEST. + + +@end defun + +@defun NSET-DIFFERENCE (list1 list2 &key (test #'eql) test-not (key #'identity)) +Package:LISP + +Returns a list of elements of LIST1 that do not appear in LIST2. LIST1 may +be destroyed. + + +@end defun + +@deffn {Special Form} POP +Package:LISP + +Syntax: +@example +(pop place) +@end example + +Pops one item off the front of the list in PLACE and returns it. + + +@end deffn + +@deffn {Special Form} PUSH +Package:LISP + +Syntax: +@example +(push item place) +@end example + +Conses ITEM onto the list in PLACE, and returns the new list. + + +@end deffn + +@defun CDAAR (x) +Package:LISP + +Equivalent to (CDR (CAR (CAR X))). + + +@end defun + +@defun CADAR (x) +Package:LISP + +Equivalent to (CAR (CDR (CAR X))). + + +@end defun + +@defun CAADR (x) +Package:LISP + +Equivalent to (CAR (CAR (CDR X))). + + +@end defun + +@defun FIRST (x) +Package:LISP + +Equivalent to (CAR X). + + +@end defun + +@defun SUBST (new old tree &key (test #'eql) test-not (key #'identity)) +Package:LISP + +Substitutes NEW for subtrees of TREE that match OLD. + + +@end defun + +@defun ADJOIN (item list &key (test #'eql) test-not (key #'identity)) +Package:LISP + +Adds ITEM to LIST unless ITEM is already a member of LIST. + + +@end defun + +@defun MAPCON (fun list &rest more-lists) +Package:LISP + +Applies FUN to successive cdrs of LISTs, NCONCs the results, and returns it. + + +@end defun + +@deffn {Macro} PUSHNEW +Package:LISP + +Syntax: +@example +(pushnew item place @{keyword value@}*) +@end example + +If ITEM is already in the list stored in PLACE, does nothing. Else, conses +ITEM onto the list. Returns NIL. If no KEYWORDs are supplied, each element +in the list is compared with ITEM by EQL, but the comparison can be controlled +by supplying keywords :TEST, :TEST-NOT, and/or :KEY. + + +@end deffn + +@defun SET-EXCLUSIVE-OR (list1 list2 &key (test #'eql) test-not (key #'identity)) +Package:LISP + +Returns a list of elements appearing exactly once in LIST1 and LIST2. + + +@end defun + +@defun TREE-EQUAL (x y &key (test #'eql) test-not) +Package:LISP + +Returns T if X and Y are isomorphic trees with identical leaves. + + +@end defun + +@defun CDDR (x) +Package:LISP + +Equivalent to (CDR (CDR X)). + + +@end defun + +@defun GETF (place indicator &optional (default nil)) +Package:LISP + +Searches the property list stored in Place for an indicator EQ to Indicator. +If one is found, the corresponding value is returned, else the Default is +returned. + + +@end defun + +@defun LDIFF (list sublist) +Package:LISP + +Returns a new list, whose elements are those of LIST that appear before +SUBLIST. If SUBLIST is not a tail of LIST, a copy of LIST is returned. + + +@end defun + +@defun UNION (list1 list2 &key (test #'eql) test-not (key #'identity)) +Package:LISP + +Returns the union of LIST1 and LIST2. + + +@end defun + +@defun ASSOC-IF-NOT (test alist) +Package:LISP + +Returns the first pair in ALIST whose car does not satisfy TEST. + + +@end defun + +@defun RPLACD (x y) +Package:LISP + +Replaces the cdr of X with Y, and returns the modified X. + + +@end defun + +@defun MEMBER-IF-NOT (test list &key (key #'identity)) +Package:LISP + +Returns the tail of LIST beginning with the first element not satisfying +TEST. + + +@end defun + +@defun CAR (list) +Package:LISP + +Returns the car of LIST. Returns NIL if LIST is NIL. + + +@end defun + +@defun ENDP (x) +Package:LISP + +Returns T if X is NIL. Returns NIL if X is a cons. Otherwise, signals an +error. + + +@end defun + +@defun LIST* (arg &rest others) +Package:LISP + +Returns a list of its arguments with the last cons being a dotted pair of +the next to the last argument and the last argument. + + +@end defun + +@defun NINTH (x) +Package:LISP + +Equivalent to (CAR (CDDDDR (CDDDDR X))). + + +@end defun + +@defun CDAAAR (x) +Package:LISP + +Equivalent to (CDR (CAR (CAR (CAR X)))). + + +@end defun + +@defun CADAAR (x) +Package:LISP + +Equivalent to (CAR (CDR (CAR (CAR X)))). + + +@end defun + +@defun CAADAR (x) +Package:LISP + +Equivalent to (CAR (CAR (CDR (CAR X)))). + + +@end defun + +@defun CAAADR (x) +Package:LISP + +Equivalent to (CAR (CAR (CAR (CDR X)))). + + +@end defun + +@defun CDDDDR (x) +Package:LISP + +Equivalent to (CDR (CDR (CDR (CDR X)))). + + +@end defun + +@defun SUBLIS (alist tree &key (test #'eql) test-not (key #'identity)) +Package:LISP + +Substitutes from ALIST for subtrees of TREE nondestructively. + + +@end defun + +@defun RASSOC-IF-NOT (predicate alist) +Package:LISP + +Returns the first cons in ALIST whose cdr does not satisfy PREDICATE. + + +@end defun + +@defun NRECONC (x y) +Package:LISP + +Equivalent to (NCONC (NREVERSE X) Y). + + +@end defun + +@defun MAPLIST (fun list &rest more-lists) +Package:LISP + +Applies FUN to successive cdrs of LISTs and returns the results as a list. + + +@end defun + +@defun SET-DIFFERENCE (list1 list2 &key (test #'eql) test-not (key #'identity)) +Package:LISP + +Returns a list of elements of LIST1 that do not appear in LIST2. + + +@end defun + +@defun ASSOC-IF (test alist) +Package:LISP + +Returns the first pair in ALIST whose car satisfies TEST. + + +@end defun + +@defun GET-PROPERTIES (place indicator-list) +Package:LISP + +Looks for the elements of INDICATOR-LIST in the property list stored in PLACE. +If found, returns the indicator, the value, and T as multiple-values. If not, +returns NILs as its three values. + + +@end defun + +@defun MEMBER-IF (test list &key (key #'identity)) +Package:LISP + +Returns the tail of LIST beginning with the first element satisfying TEST. + + +@end defun + +@defun COPY-TREE (object) +Package:LISP + +Recursively copies conses in OBJECT and returns the result. + + +@end defun + +@defun ATOM (x) +Package:LISP + +Returns T if X is not a cons; NIL otherwise. + + +@end defun + +@defun CDDAR (x) +Package:LISP + +Equivalent to (CDR (CDR (CAR X))). + + +@end defun + +@defun CDADR (x) +Package:LISP + +Equivalent to (CDR (CAR (CDR X))). + + +@end defun + +@defun CADDR (x) +Package:LISP + +Equivalent to (CAR (CDR (CDR X))). + + +@end defun + +@defun ASSOC (item alist &key (test #'eql) test-not) +Package:LISP + +Returns the first pair in ALIST whose car is equal (in the sense of TEST) to +ITEM. + + +@end defun + +@defun APPEND (&rest lists) +Package:LISP + +Constructs a new list by concatenating its arguments. + + +@end defun + +@defun MEMBER (item list &key (test #'eql) test-not (key #'identity)) +Package:LISP + +Returns the tail of LIST beginning with the first ITEM. + + +@end defun diff --git a/info/makefile b/info/makefile new file mode 100644 index 0000000..4b4a8f2 --- /dev/null +++ b/info/makefile @@ -0,0 +1,123 @@ +.SUFFIXES: +.SUFFIXES: .info .pdf .texi + +INFO_DIR=/usr/local/lib/info + +GCL_PDF=gcl-tk.pdf gcl-si.pdf #gcl.pdf +#GCL_DVI=gcl-tk.dvi gcl-si.dvi #gcl.dvi +#GCL_HTML=gcl-si_toc.html gcl-tk_toc.html gcl_toc.html +GCL_HTML=gcl-si/index.html gcl-tk/index.html #gcl/index.html +#HTML_CMD=texi2html -split_chapter +HTML_CMD=makeinfo --html + +-include ../makedefs + +all: gcl-tk.info gcl-si.info $(GCL_PDF) $(GCL_HTML) #gcl.info + +.texi.info: + rm -f $*.*gz + -$(MAKEINFO) $*.texi + - gzip $*.info-* + +GCL_SI= number.texi sequence.texi character.texi list.texi io.texi \ + form.texi compile.texi symbol.texi system.texi structure.texi \ + iteration.texi user-interface.texi doc.texi type.texi internal.texi \ + c-interface.texi si-defs.texi debug.texi misc.texi compiler-defs.texi \ + gcl-si-index.texi +GCL_TK= general.texi widgets.texi control.texi +GCL_MAN= chap-1.texi chap-2.texi chap-3.texi chap-4.texi chap-5.texi \ + chap-6.texi chap-7.texi chap-8.texi chap-9.texi chap-10.texi chap-11.texi \ + chap-12.texi chap-13.texi chap-14.texi chap-15.texi chap-16.texi chap-17.texi \ + chap-18.texi chap-19.texi chap-20.texi chap-21.texi chap-22.texi chap-23.texi \ + chap-24.texi chap-25.texi chap-26.texi chap-a.texi + +%.pdf: %.dvi + dvipdfm $< + +gcl-si.dvi: ${GCL_SI} gcl-si.texi + TEXINPUTS=.:$$TEXINPUTS tex --interaction nonstopmode gcl-si.texi || true + rm -f *.cp *.ky *.vr *.tp *.pg *.toc *.aux *.log *.fn + +gcl-si.info: ${GCL_SI} gcl-si.texi + -$(MAKEINFO) gcl-si.texi + +gcl-tk.dvi: ${GCL_TK} gcl-tk.texi + TEXINPUTS=.:$$TEXINPUTS tex --interaction nonstopmode gcl-tk.texi || true + rm -f *.cp *.ky *.vr *.tp *.pg *.toc *.aux *.log *.fn + +gcl-tk.info: ${GCL_TK} gcl-tk.texi + -$(MAKEINFO) gcl-tk.texi + +gcl.dvi: ${GCL_MAN} gcl.texi + TEXINPUTS=.:$$TEXINPUTS tex --interaction nonstopmode gcl.texi || true + rm -f *.cp *.ky *.vr *.tp *.pg *.toc *.aux *.log *.fn + +gcl.info: ${GCL_MAN} gcl.texi + -$(MAKEINFO) gcl.texi + +#gcl-si_toc.html: ${GCL_SI} gcl-si.texi +# $(HTML_CMD) gcl-si.texi + +#gcl-tk_toc.html: ${GCL_TK} gcl-tk.texi +# $(HTML_CMD) gcl-tk.texi + +#gcl_toc.html: +# $(HTML_CMD) gcl.texi + +gcl-si/index.html: ${GCL_SI} gcl-si.texi + mkdir -p $(@D) + touch $@ + -$(HTML_CMD) gcl-si.texi + +gcl-tk/index.html: ${GCL_TK} gcl-tk.texi + mkdir -p $(@D) + touch $@ + -$(HTML_CMD) gcl-tk.texi + +gcl/index.html: gcl.texi + mkdir -p $(@D) + touch $@ + -$(HTML_CMD) gcl.texi + +install: #$(GCL_PDF) $(GCL_HTML) + mkdir -p $(DESTDIR)${INFO_DIR} + [ -f $(DESTDIR)$(INFO_DIR)dir ] || touch $(DESTDIR)$(INFO_DIR)dir + grep gcl-si $(DESTDIR)${INFO_DIR}dir >/dev/null 2>&1 || \ + echo "* GCL Doc: (gcl-si.info). GNU Common Lisp specific Documentation." >> $(DESTDIR)${INFO_DIR}dir + grep gcl-tk $(DESTDIR)${INFO_DIR}dir >/dev/null 2>&1 || \ + echo "* GCL TK Doc: (gcl-tk.info). TK window GCL interface." >> $(DESTDIR)${INFO_DIR}dir + grep gcl.info $(DESTDIR)${INFO_DIR}dir >/dev/null 2>&1 || \ + echo "* GCL Ansi Doc: (gcl.info). Ansi Common Lisp Specification." >> $(DESTDIR)${INFO_DIR}dir + -cp *.info* $(DESTDIR)${INFO_DIR} +# -mkdir -p $(DESTDIR)$(INFO_DIR)../doc/gcl-doc/gcl.html +# -mkdir -p $(DESTDIR)$(INFO_DIR)../doc/gcl-doc/gcl-si.html +# -mkdir -p $(DESTDIR)$(INFO_DIR)../doc/gcl-doc/gcl-tk.html +# -cp gcl_*html gcl.html $(DESTDIR)$(INFO_DIR)../doc/gcl-doc/gcl.html +# -cp gcl-si*html $(DESTDIR)$(INFO_DIR)../doc/gcl-doc/gcl-si.html +# -cp gcl-tk*html $(DESTDIR)$(INFO_DIR)../doc/gcl-doc/gcl-tk.html +# -cp gcl/* $(DESTDIR)$(INFO_DIR)../doc/gcl-doc/gcl.html +# -cp gcl-si/* $(DESTDIR)$(INFO_DIR)../doc/gcl-doc/gcl-si.html +# -cp gcl-tk/* $(DESTDIR)$(INFO_DIR)../doc/gcl-doc/gcl-tk.html + -mkdir -p $(DESTDIR)$(INFO_DIR)../doc +# -cp -r gcl-si gcl gcl-tk $(DESTDIR)$(INFO_DIR)../doc + -cp -r gcl-si gcl-tk $(DESTDIR)$(INFO_DIR)../doc + -cp *pdf $(DESTDIR)$(INFO_DIR)../doc + +FILE=gcl-si.texi +srcs: + fgrep '.texi' ${FILE} | sed -e "/@c/d" | \ + awk '{ i++; printf("%s ",$$2); if ((i%5) == 0) printf("\\\n")}' + +tex: + TEXINPUTS=.:$$TEXINPUTS tex gcl-si.texi + TEXINPUTS=.:$$TEXINPUTS tex gcl-tk.texi + TEXINPUTS=.:$$TEXINPUTS tex gcl.texi + @echo must do twice to get indices correct... + @echo so do '$(MAKE) tex' again + +clean: + rm -f *.info* *.html *.pdf + rm -rf gcl.IC gcl.IE gcl.IG gcl.IP gcl.IR gcl.IT gcl.fu gcl gcl-si gcl-tk + rm -rf gcl gcl-si gcl-tk + +.INTERMEDIATE: gcl-tk.dvi gcl-si.dvi gcl.dvi diff --git a/info/misc.texi b/info/misc.texi new file mode 100755 index 0000000..8e5140d --- /dev/null +++ b/info/misc.texi @@ -0,0 +1,47 @@ + +@node Miscellaneous, Compiler Definitions, Debugging, Top +@chapter Miscellaneous + +@menu +* Environment:: +* Inititialization:: +* Low Level X Interface:: +@end menu + +@node Environment, Inititialization, Miscellaneous, Miscellaneous +@section Environment + +The environment in GCL which is passed to macroexpand and +other functions requesting an environment, should be a +list of 3 lists. The first list looks like ((v1 val1) (v2 val2) ..) +where vi are variables and vali are their values. +The second is a list of ((fname1 . fbody1) (fname2 . fbody2) ...) +where fbody1 is either (macro lambda-list lambda-body) or +(lambda-list lambda-body) depending on whether this is a macro +or a function. The third list contains tags and blocks. + +@node Inititialization, Low Level X Interface, Environment, Miscellaneous +@section Initialization + +If the file init.lsp exists in the current directory, it is +loaded at startup. The first argument passed to the executable image +should be the system directory. Normally this would be gcl/unixport. +This directory is stored in the si::*system-directory* variable. If +the file sys-init.lsp exists in the system directory, it is loaded +before init.lsp. See also si::*TOP-LEVEL-HOOK*. + +@node Low Level X Interface, , Inititialization, Miscellaneous +@section Low Level X Interface + +A sample program for drawing things on X windows from lisp +is included in the file gcl/lsp/littleXlsp.lsp + +That routine invokes the corresponding C routines in XLIB. +So in order to use it you must `faslink' in the X routines. +Directions are given at the beginning of the lisp file, +for either building them into the image or using faslink. + +This program is also a good tutorial on invoking C from lisp. + +See also defentry and faslink. + diff --git a/info/number.texi b/info/number.texi new file mode 100755 index 0000000..bafc2ac --- /dev/null +++ b/info/number.texi @@ -0,0 +1,1332 @@ +@node Numbers, Sequences and Arrays and Hash Tables, Top, Top +@chapter Numbers + + +@defun SIGNUM (number) +Package:LISP + +If NUMBER is zero, returns NUMBER; else returns (/ NUMBER (ABS NUMBER)). + + +@end defun + +@defun LOGNOT (integer) +Package:LISP + +Returns the bit-wise logical NOT of INTEGER. + + +@end defun + +@defvr {Constant} MOST-POSITIVE-SHORT-FLOAT +Package:LISP +The short-float closest in value to positive infinity. + + +@end defvr + +@defun INTEGER-DECODE-FLOAT (float) +Package:LISP + +Returns, as three values, the integer interpretation of significand F, +the exponent E, and the sign S of the given float, so that + E + FLOAT = S * F * B where B = (FLOAT-RADIX FLOAT) + +F is a non-negative integer, E is an integer, and S is either 1 or -1. + + +@end defun + +@defun MINUSP (number) +Package:LISP + +Returns T if NUMBER < 0; NIL otherwise. + + +@end defun + +@defun LOGORC1 (integer1 integer2) +Package:LISP + +Returns the logical OR of (LOGNOT INTEGER1) and INTEGER2. + + +@end defun + +@defvr {Constant} MOST-NEGATIVE-SINGLE-FLOAT +Package:LISP +Same as MOST-NEGATIVE-LONG-FLOAT. + + +@end defvr + +@defvr {Constant} BOOLE-C1 +Package:LISP +Makes BOOLE return the complement of INTEGER1. + + +@end defvr + +@defvr {Constant} LEAST-POSITIVE-SHORT-FLOAT +Package:LISP +The positive short-float closest in value to zero. + + +@end defvr + +@defun BIT-NAND (bit-array1 bit-array2 &optional (result-bit-array nil)) +Package:LISP + +Performs a bit-wise logical NAND on the elements of BIT-ARRAY1 and +BIT-ARRAY2. +Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into +BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. + +@end defun + +@defun INT-CHAR (integer) +Package:LISP + +Performs the inverse of CHAR-INT. Equivalent to CODE-CHAR in GCL. + + +@end defun + +@defun CHAR-INT (char) +Package:LISP + +Returns the font, bits, and code attributes as a single non-negative integer. +Equivalent to CHAR-CODE in GCL. + + +@end defun + +@defvr {Constant} LEAST-NEGATIVE-SINGLE-FLOAT +Package:LISP +Same as LEAST-NEGATIVE-LONG-FLOAT. + + +@end defvr + +@defun /= (number &rest more-numbers) +Package:LISP + +Returns T if no two of its arguments are numerically equal; NIL otherwise. + + +@end defun + +@defun LDB-TEST (bytespec integer) +Package:LISP + +Returns T if at least one of the bits in the specified bytes of INTEGER is 1; +NIL otherwise. + + +@end defun + +@defvr {Constant} CHAR-CODE-LIMIT +Package:LISP +The upper exclusive bound on values produced by CHAR-CODE. + + +@end defvr + +@defun RATIONAL (number) +Package:LISP + +Converts NUMBER into rational accurately and returns it. + + +@end defun + +@defvr {Constant} PI +Package:LISP +The floating-point number that is appropriately equal to the ratio of the +circumference of the circle to the diameter. + + +@end defvr + +@defun SIN (radians) +Package:LISP + +Returns the sine of RADIANS. + + +@end defun + +@defvr {Constant} BOOLE-ORC2 +Package:LISP +Makes BOOLE return LOGORC2 of INTEGER1 and INTEGER2. + + +@end defvr + +@defun NUMERATOR (rational) +Package:LISP + +Returns as an integer the numerator of the given rational number. + + +@end defun + +@defun MASK-FIELD (bytespec integer) +Package:LISP + +Extracts the specified byte from INTEGER. + + +@end defun + +@deffn {Special Form} INCF +Package:LISP + +Syntax: +@example +(incf place [delta]) +@end example + +Adds the number produced by DELTA (which defaults to 1) to the number +in PLACE. + + +@end deffn + +@defun SINH (number) +Package:LISP + +Returns the hyperbolic sine of NUMBER. + + +@end defun + +@defun PHASE (number) +Package:LISP + +Returns the angle part of the polar representation of a complex number. +For non-complex numbers, this is 0. + + +@end defun + +@defun BOOLE (op integer1 integer2) +Package:LISP + +Returns an integer produced by performing 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 +See the variable docs of these constants for their operations. + + +@end defun + +@defvr {Constant} SHORT-FLOAT-EPSILON +Package:LISP +The smallest positive short-float that satisfies + (not (= (float 1 e) (+ (float 1 e) e))). + + +@end defvr + +@defun LOGORC2 (integer1 integer2) +Package:LISP + +Returns the logical OR of INTEGER1 and (LOGNOT INTEGER2). + + +@end defun + +@defvr {Constant} BOOLE-C2 +Package:LISP +Makes BOOLE return the complement of INTEGER2. + + +@end defvr + +@defun REALPART (number) +Package:LISP + +Extracts the real part of NUMBER. + + +@end defun + + +@defvr {Constant} BOOLE-CLR +Package:LISP +Makes BOOLE return 0. + + +@end defvr + +@defvr {Constant} BOOLE-IOR +Package:LISP +Makes BOOLE return LOGIOR of INTEGER1 and INTEGER2. + + +@end defvr + +@defun FTRUNCATE (number &optional (divisor 1)) +Package:LISP + +Values: (quotient remainder) +Same as TRUNCATE, but returns first value as a float. + + +@end defun + +@defun EQL (x y) +Package:LISP + +Returns T if X and Y are EQ, or if they are numbers of the same type with +the same value, or if they are character objects that represent the same +character. Returns NIL otherwise. + + +@end defun + +@defun LOG (number &optional base) +Package:LISP + +Returns the logarithm of NUMBER in the base BASE. BASE defaults to the base +of natural logarithms. + + +@end defun + +@defvr {Constant} DOUBLE-FLOAT-NEGATIVE-EPSILON +Package:LISP +Same as LONG-FLOAT-NEGATIVE-EPSILON. + + +@end defvr + +@defun LOGIOR (&rest integers) +Package:LISP + +Returns the bit-wise INCLUSIVE OR of its arguments. + + +@end defun + +@defvr {Constant} MOST-NEGATIVE-DOUBLE-FLOAT +Package:LISP +Same as MOST-NEGATIVE-LONG-FLOAT. + + +@end defvr + +@defun / (number &rest more-numbers) +Package:LISP + +Divides the first NUMBER by each of the subsequent NUMBERS. +With one arg, returns the reciprocal of the number. + + +@end defun + +@defvar *RANDOM-STATE* +Package:LISP +The default random-state object used by RAMDOM. + + +@end defvar + +@defun 1+ (number) +Package:LISP + +Returns NUMBER + 1. + + +@end defun + +@defvr {Constant} LEAST-NEGATIVE-DOUBLE-FLOAT +Package:LISP +Same as LEAST-NEGATIVE-LONG-FLOAT. + + +@end defvr + +@defun FCEILING (number &optional (divisor 1)) +Package:LISP + +Same as CEILING, but returns a float as the first value. + + +@end defun + +@defvr {Constant} MOST-POSITIVE-FIXNUM +Package:LISP +The fixnum closest in value to positive infinity. + + +@end defvr + +@defun BIT-ANDC1 (bit-array1 bit-array2 &optional (result-bit-array nil)) +Package:LISP + +Performs a bit-wise logical ANDC1 on the elements of BIT-ARRAY1 and +BIT-ARRAY2. +Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into +BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. + + +@end defun + +@defun TAN (radians) +Package:LISP + +Returns the tangent of RADIANS. + + +@end defun + +@defvr {Constant} BOOLE-NAND +Package:LISP +Makes BOOLE return LOGNAND of INTEGER1 and INTEGER2. + + +@end defvr + +@defun TANH (number) +Package:LISP + +Returns the hyperbolic tangent of NUMBER. + + +@end defun + +@defun ASIN (number) +Package:LISP + +Returns the arc sine of NUMBER. + + +@end defun + +@defun BYTE (size position) +Package:LISP + +Returns a byte specifier. In GCL, a byte specifier is represented by +a dotted pair ( . ). + + +@end defun + +@defun ASINH (number) +Package:LISP + +Returns the hyperbolic arc sine of NUMBER. + + +@end defun + +@defvr {Constant} MOST-POSITIVE-LONG-FLOAT +Package:LISP +The long-float closest in value to positive infinity. + + +@end defvr + +@deffn {Macro} SHIFTF +Package:LISP + +Syntax: +@example +(shiftf @{place@}+ newvalue) +@end example + +Evaluates all PLACEs and NEWVALUE in turn, then assigns the value of each +form to the PLACE on its left. Returns the original value of the leftmost +form. + + +@end deffn + +@defvr {Constant} LEAST-POSITIVE-LONG-FLOAT +Package:LISP +The positive long-float closest in value to zero. + + +@end defvr + +@defun DEPOSIT-FIELD (newbyte bytespec integer) +Package:LISP + +Returns an integer computed by replacing the specified byte of INTEGER with +the specified byte of NEWBYTE. + + +@end defun + +@defun BIT-AND (bit-array1 bit-array2 &optional (result-bit-array nil)) +Package:LISP + +Performs a bit-wise logical AND on the elements of BIT-ARRAY1 and BIT-ARRAY2. +Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into +BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. + + +@end defun + +@defun LOGNAND (integer1 integer2) +Package:LISP + +Returns the complement of the logical AND of INTEGER1 and INTEGER2. + + +@end defun + +@defun BYTE-POSITION (bytespec) +Package:LISP + +Returns the position part (in GCL, the cdr part) of the byte specifier. + + +@end defun + +@deffn {Macro} ROTATEF +Package:LISP + +Syntax: +@example +(rotatef @{place@}*) +@end example + +Evaluates PLACEs in turn, then assigns to each PLACE the value of the form to +its right. The rightmost PLACE gets the value of the leftmost PLACE. +Returns NIL always. + + +@end deffn + +@defun BIT-ANDC2 (bit-array1 bit-array2 &optional (result-bit-array nil)) +Package:LISP + +Performs a bit-wise logical ANDC2 on the elements of BIT-ARRAY1 and +BIT-ARRAY2. +Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into +BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. + + +@end defun + +@defun TRUNCATE (number &optional (divisor 1)) +Package:LISP + +Values: (quotient remainder) +Returns NUMBER/DIVISOR as an integer, rounded toward 0. The second returned +value is the remainder. + + +@end defun + +@defvr {Constant} BOOLE-EQV +Package:LISP +Makes BOOLE return LOGEQV of INTEGER1 and INTEGER2. + + +@end defvr + +@defvr {Constant} BOOLE-SET +Package:LISP +Makes BOOLE return -1. + + +@end defvr + +@defun LDB (bytespec integer) +Package:LISP + +Extracts and right-justifies the specified byte of INTEGER, and returns the +result. + + +@end defun + +@defun BYTE-SIZE (bytespec) +Package:LISP + +Returns the size part (in GCL, the car part) of the byte specifier. + + +@end defun + +@defvr {Constant} SHORT-FLOAT-NEGATIVE-EPSILON +Package:LISP +The smallest positive short-float that satisfies + (not (= (float 1 e) (- (float 1 e) e))). + + +@end defvr + +@defun REM (number divisor) +Package:LISP + +Returns the second value of (TRUNCATE NUMBER DIVISOR). + + +@end defun + +@defun MIN (number &rest more-numbers) +Package:LISP + +Returns the least of its arguments. + + +@end defun + +@defun EXP (number) +Package:LISP + +Calculates e raised to the power NUMBER, where e is the base of natural +logarithms. + + +@end defun + +@defun DECODE-FLOAT (float) +Package:LISP + +Returns, as three values, the significand F, the exponent E, and the sign S +of the given float, so that + E + FLOAT = S * F * B where B = (FLOAT-RADIX FLOAT) + +S and F are floating-point numbers of the same float format as FLOAT, and E +is an integer. + + + +@end defun + +@defvr {Constant} LONG-FLOAT-EPSILON +Package:LISP +The smallest positive long-float that satisfies + (not (= (float 1 e) (+ (float 1 e) e))). + + +@end defvr + +@defun FROUND (number &optional (divisor 1)) +Package:LISP + +Same as ROUND, but returns first value as a float. + + +@end defun + +@defun LOGEQV (&rest integers) +Package:LISP + +Returns the bit-wise EQUIVALENCE of its arguments. + + +@end defun + +@defvr {Constant} MOST-NEGATIVE-SHORT-FLOAT +Package:LISP +The short-float closest in value to negative infinity. + + +@end defvr + +@defun BIT-NOR (bit-array1 bit-array2 &optional (result-bit-array nil)) +Package:LISP + +Performs a bit-wise logical NOR on the elements of BIT-ARRAY1 and BIT-ARRAY2. +Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into +BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. + + +@end defun + +@defun CEILING (number &optional (divisor 1)) +Package:LISP + +Returns the smallest integer not less than or NUMBER/DIVISOR. Returns the +remainder as the second value. + + +@end defun + +@defvr {Constant} LEAST-NEGATIVE-SHORT-FLOAT +Package:LISP +The negative short-float closest in value to zero. + + +@end defvr + +@defun 1- (number) +Package:LISP + +Returns NUMBER - 1. + + +@end defun + +@defun <= (number &rest more-numbers) +Package:LISP + +Returns T if arguments are in strictly non-decreasing order; NIL otherwise. + + +@end defun + +@defun IMAGPART (number) +Package:LISP + +Extracts the imaginary part of NUMBER. + + +@end defun + +@defun INTEGERP (x) +Package:LISP + +Returns T if X is an integer (fixnum or bignum); NIL otherwise. + + +@end defun + +@defun ASH (integer count) +Package:LISP + +Shifts INTEGER left by COUNT places. Shifts right if COUNT is negative. + + +@end defun + +@defun LCM (integer &rest more-integers) +Package:LISP + +Returns the least common multiple of the arguments. + + +@end defun + +@defun COS (radians) +Package:LISP + +Returns the cosine of RADIANS. + + +@end defun + +@deffn {Special Form} DECF +Package:LISP + +Syntax: +@example +(decf place [delta]) +@end example +Subtracts the number +produced by DELTA (which defaults to 1) from the number in +PLACE. + + +@end deffn + +@defun ATAN (x &optional (y 1)) +Package:LISP + Returns the arc tangent of +X/Y. + + +@end defun + +@defvr {Constant} BOOLE-ANDC1 +Package:LISP +Makes BOOLE return LOGANDC1 of INTEGER1 and INTEGER2. + + +@end defvr + +@defun COSH (number) +Package:LISP + Returns the hyperbolic cosine of +NUMBER. + + +@end defun + +@defun FLOAT-RADIX (float) +Package:LISP + +Returns the representation radix (or base) of the floating-point +number. + + +@end defun + +@defun ATANH (number) +Package:LISP + +Returns the hyperbolic arc tangent of NUMBER. + + +@end defun + +@defun EVENP (integer) +Package:LISP + Returns T +if INTEGER is even. Returns NIL if INTEGER is odd. + + +@end defun + +@defun ZEROP (number) +Package:LISP + Returns T if NUMBER = 0; NIL +otherwise. + + +@end defun + +@defun FLOATP (x) +Package:LISP + +Returns T if X is a floating-point number; NIL otherwise. + + +@end defun + +@defun SXHASH (object) +Package:LISP + +Computes a hash code for OBJECT and returns it as an integer. + + +@end defun + +@defvr {Constant} BOOLE-1 +Package:LISP +Makes BOOLE return INTEGER1. + + +@end defvr + +@defvr {Constant} MOST-POSITIVE-SINGLE-FLOAT +Package:LISP +Same as MOST-POSITIVE-LONG-FLOAT. + + +@end defvr + +@defun LOGANDC1 (integer1 integer2) +Package:LISP + +Returns the logical AND of (LOGNOT INTEGER1) and INTEGER2. + + +@end defun + +@defvr {Constant} LEAST-POSITIVE-SINGLE-FLOAT +Package:LISP +Same as LEAST-POSITIVE-LONG-FLOAT. + + +@end defvr + +@defun COMPLEXP (x) +Package:LISP + +Returns T if X is a complex number; NIL otherwise. + + +@end defun + +@defvr {Constant} BOOLE-AND +Package:LISP +Makes BOOLE return LOGAND of INTEGER1 and INTEGER2. + + +@end defvr + +@defun MAX (number &rest more-numbers) +Package:LISP + +Returns the greatest of its arguments. + + +@end defun + +@defun FLOAT-SIGN (float1 &optional (float2 (float 1 float1))) +Package:LISP + +Returns a floating-point number with the same sign as FLOAT1 and with the +same absolute value as FLOAT2. + + +@end defun + +@defvr {Constant} BOOLE-ANDC2 +Package:LISP +Makes BOOLE return LOGANDC2 of INTEGER1 and INTEGER2. + + +@end defvr + +@defun DENOMINATOR (rational) +Package:LISP + +Returns the denominator of RATIONAL as an integer. + + +@end defun + +@defun FLOAT (number &optional other) +Package:LISP + +Converts a non-complex number to a floating-point number. If NUMBER is +already a float, FLOAT simply returns NUMBER. Otherwise, the format of +the returned float depends on OTHER; If OTHER is not provided, FLOAT returns +a SINGLE-FLOAT. If OTHER is provided, the result is in the same float format +as OTHER's. + + +@end defun + +@defun ROUND (number &optional (divisor 1)) +Package:LISP + +Rounds NUMBER/DIVISOR to nearest integer. The second returned value is the +remainder. + + +@end defun + +@defun LOGAND (&rest integers) +Package:LISP + +Returns the bit-wise AND of its arguments. + + +@end defun + +@defvr {Constant} BOOLE-2 +Package:LISP +Makes BOOLE return INTEGER2. + + +@end defvr + +@defun * (&rest numbers) +Package:LISP + +Returns the product of its arguments. With no args, returns 1. + + +@end defun + +@defun < (number &rest more-numbers) +Package:LISP + +Returns T if its arguments are in strictly increasing order; NIL otherwise. + + +@end defun + +@defun COMPLEX (realpart &optional (imagpart 0)) +Package:LISP + +Returns a complex number with the given real and imaginary parts. + + +@end defun + +@defvr {Constant} SINGLE-FLOAT-EPSILON +Package:LISP +Same as LONG-FLOAT-EPSILON. + + +@end defvr + +@defun LOGANDC2 (integer1 integer2) +Package:LISP + +Returns the logical AND of INTEGER1 and (LOGNOT INTEGER2). + + +@end defun + +@defun INTEGER-LENGTH (integer) +Package:LISP + +Returns the number of significant bits in the absolute value of INTEGER. + + +@end defun + +@defvr {Constant} MOST-NEGATIVE-FIXNUM +Package:LISP +The fixnum closest in value to negative infinity. + + +@end defvr + +@defvr {Constant} LONG-FLOAT-NEGATIVE-EPSILON +Package:LISP +The smallest positive long-float that satisfies + (not (= (float 1 e) (- (float 1 e) e))). + + +@end defvr + +@defun >= (number &rest more-numbers) +Package:LISP + +Returns T if arguments are in strictly non-increasing order; NIL otherwise. + + +@end defun + +@defvr {Constant} BOOLE-NOR +Package:LISP +Makes BOOLE return LOGNOR of INTEGER1 and INTEGER2. + + +@end defvr + +@defun ACOS (number) +Package:LISP + +Returns the arc cosine of NUMBER. + + +@end defun + +@defun MAKE-RANDOM-STATE (&optional (state *random-state*)) +Package:LISP + +Creates and returns a copy of the specified random state. If STATE is NIL, +then the value of *RANDOM-STATE* is used. If STATE is T, then returns a +random state object generated from the universal time. + + +@end defun + +@defun EXPT (base-number power-number) +Package:LISP + +Returns BASE-NUMBER raised to the power POWER-NUMBER. + + +@end defun + +@defun SQRT (number) +Package:LISP + +Returns the principal square root of NUMBER. + + +@end defun + +@defun SCALE-FLOAT (float integer) +Package:LISP + +Returns (* FLOAT (expt (float-radix FLOAT) INTEGER)). + + +@end defun + +@defun ACOSH (number) +Package:LISP + +Returns the hyperbolic arc cosine of NUMBER. + + +@end defun + +@defvr {Constant} MOST-NEGATIVE-LONG-FLOAT +Package:LISP +The long-float closest in value to negative infinity. + + +@end defvr + +@defvr {Constant} LEAST-NEGATIVE-LONG-FLOAT +Package:LISP +The negative long-float closest in value to zero. + + +@end defvr + +@defun FFLOOR (number &optional (divisor 1)) +Package:LISP + +Same as FLOOR, but returns a float as the first value. + + +@end defun + +@defun LOGNOR (integer1 integer2) +Package:LISP + +Returns the complement of the logical OR of INTEGER1 and INTEGER2. + + +@end defun + +@defun PARSE-INTEGER (string &key (start 0) (end (length string)) (radix 10) (junk-allowed nil)) +Package:LISP + +Parses STRING for an integer and returns it. + + +@end defun + +@defun + (&rest numbers) +Package:LISP + +Returns the sum of its arguments. With no args, returns 0. + + +@end defun + +@defun = (number &rest more-numbers) +Package:LISP + +Returns T if all of its arguments are numerically equal; NIL otherwise. + + +@end defun + +@defun NUMBERP (x) +Package:LISP + +Returns T if X is any kind of number; NIL otherwise. + + +@end defun + +@defvr {Constant} MOST-POSITIVE-DOUBLE-FLOAT +Package:LISP +Same as MOST-POSITIVE-LONG-FLOAT. + + +@end defvr + +@defun LOGTEST (integer1 integer2) +Package:LISP + +Returns T if LOGAND of INTEGER1 and INTEGER2 is not zero; NIL otherwise. + + +@end defun + +@defun RANDOM-STATE-P (x) +Package:LISP + +Returns T if X is a random-state object; NIL otherwise. + + +@end defun + +@defvr {Constant} LEAST-POSITIVE-DOUBLE-FLOAT +Package:LISP +Same as LEAST-POSITIVE-LONG-FLOAT. + + +@end defvr + +@defun FLOAT-PRECISION (float) +Package:LISP + +Returns the number of significant radix-B digits used to represent the +significand F of the floating-point number, where B = (FLOAT-RADIX FLOAT). + + +@end defun + +@defvr {Constant} BOOLE-XOR +Package:LISP +Makes BOOLE return LOGXOR of INTEGER1 and INTEGER2. + + +@end defvr + +@defun DPB (newbyte bytespec integer) +Package:LISP + +Returns an integer computed by replacing the specified byte of INTEGER with +NEWBYTE. + + +@end defun + +@defun ABS (number) +Package:LISP + +Returns the absolute value of NUMBER. + + +@end defun + +@defun CONJUGATE (number) +Package:LISP + +Returns the complex conjugate of NUMBER. + + +@end defun + +@defun CIS (radians) +Package:LISP + +Returns e raised to i*RADIANS. + + +@end defun + +@defun ODDP (integer) +Package:LISP + +Returns T if INTEGER is odd; NIL otherwise. + + +@end defun + +@defun RATIONALIZE (number) +Package:LISP + +Converts NUMBER into rational approximately and returns it. + + +@end defun + +@defun ISQRT (integer) +Package:LISP + +Returns the greatest integer less than or equal to the square root of the +given non-negative integer. + + +@end defun + +@defun LOGXOR (&rest integers) +Package:LISP + +Returns the bit-wise EXCLUSIVE OR of its arguments. + + +@end defun + +@defun > (number &rest more-numbers) +Package:LISP + +Returns T if its arguments are in strictly decreasing order; NIL otherwise. + + +@end defun + +@defun LOGBITP (index integer) +Package:LISP + +Returns T if the INDEX-th bit of INTEGER is 1. + + +@end defun + +@defvr {Constant} DOUBLE-FLOAT-EPSILON +Package:LISP +Same as LONG-FLOAT-EPSILON. + + +@end defvr + +@defun LOGCOUNT (integer) +Package:LISP + +If INTEGER is negative, returns the number of 0 bits. Otherwise, returns +the number of 1 bits. + + +@end defun + +@defun GCD (&rest integers) +Package:LISP + +Returns the greatest common divisor of INTEGERs. + + +@end defun + +@defun RATIONALP (x) +Package:LISP + +Returns T if X is an integer or a ratio; NIL otherwise. + + +@end defun + +@defun MOD (number divisor) +Package:LISP + +Returns the second result of (FLOOR NUMBER DIVISOR). + + +@end defun + +@defun MODF (number) +Package:SYSTEM + +Returns the integer and fractional part of a floating point number mod 1.0. + + +@end defun + +@defvr {Constant} BOOLE-ORC1 +Package:LISP +Makes BOOLE return LOGORC1 of INTEGER1 and INTEGER2. + + +@end defvr + +@defvr {Constant} SINGLE-FLOAT-NEGATIVE-EPSILON +Package:LISP +Same as LONG-FLOAT-NEGATIVE-EPSILON. + + +@end defvr + +@defun FLOOR (number &optional (divisor 1)) +Package:LISP + +Returns the largest integer not larger than the NUMBER divided by DIVISOR. +The second returned value is (- NUMBER (* first-value DIVISOR)). + + +@end defun + +@defun PLUSP (number) +Package:LISP + +Returns T if NUMBER > 0; NIL otherwise. + + +@end defun + +@defun FLOAT-DIGITS (float) +Package:LISP + +Returns the number of radix-B digits used to represent the significand F of +the floating-point number, where B = (FLOAT-RADIX FLOAT). + + +@end defun + +@defun RANDOM (number &optional (state *random-state*)) +Package:LISP + +Generates a uniformly distributed pseudo-random number between zero +(inclusive) and NUMBER (exclusive), by using the random state object STATE. + + +@end defun diff --git a/info/sequence.texi b/info/sequence.texi new file mode 100755 index 0000000..c67bd94 --- /dev/null +++ b/info/sequence.texi @@ -0,0 +1,985 @@ +@node Sequences and Arrays and Hash Tables, Characters, Numbers, Top +@chapter Sequences and Arrays and Hash Tables + +@defun VECTOR (&rest objects) +Package:LISP + +Constructs a Simple-Vector from the given objects. + + +@end defun + +@defun SUBSEQ (sequence start &optional (end (length sequence))) +Package:LISP + +Returns a copy of a subsequence of SEQUENCE between START (inclusive) and +END (exclusive). + + +@end defun + +@defun COPY-SEQ (sequence) +Package:LISP + +Returns a copy of SEQUENCE. + + +@end defun + +@defun POSITION (item sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (key #'identity)) +Package:LISP + +Returns the index of the first element in SEQUENCE that satisfies TEST with +ITEM; NIL if no such element exists. + + +@end defun + +@defun ARRAY-RANK (array) +Package:LISP + +Returns the number of dimensions of ARRAY. + + +@end defun + +@defun SBIT (simple-bit-array &rest subscripts) +Package:LISP + +Returns the bit from SIMPLE-BIT-ARRAY at SUBSCRIPTS. + + +@end defun + +@defun STRING-CAPITALIZE (string &key (start 0) (end (length string))) +Package:LISP + +Returns a copy of STRING with the first character of each word converted to +upper-case, and remaining characters in the word converted to lower case. + + +@end defun + +@defun NSUBSTITUTE-IF-NOT (new test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity)) +Package:LISP + +Returns a sequence of the same kind as SEQUENCE with the same elements + +except that all elements not satisfying TEST are replaced with NEWITEM. +SEQUENCE may be destroyed. + + +@end defun + +@defun FIND-IF (test sequence &key (from-end nil) (start 0) (end (length sequence)) (key #'identity)) +Package:LISP + +Returns the index of the first element in SEQUENCE that satisfies TEST; NIL if +no such element exists. + + +@end defun + +@defun BIT-EQV (bit-array1 bit-array2 &optional (result-bit-array nil)) +Package:LISP + +Performs a bit-wise logical EQV on the elements of BIT-ARRAY1 and BIT-ARRAY2. +Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into +BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. + + +@end defun + +@defun STRING< (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2))) +Package:LISP + +If STRING1 is lexicographically less than STRING2, then returns the longest +common prefix of the strings. Otherwise, returns NIL. + + +@end defun + +@defun REVERSE (sequence) +Package:LISP + +Returns a new sequence containing the same elements as SEQUENCE but in +reverse order. + + +@end defun + +@defun NSTRING-UPCASE (string &key (start 0) (end (length string))) +Package:LISP + +Returns STRING with all lower case characters converted to uppercase. + + +@end defun + +@defun STRING>= (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2))) +Package:LISP + +If STRING1 is lexicographically greater than or equal to STRING2, then returns +the longest common prefix of the strings. Otherwise, returns NIL. + + +@end defun + +@defun ARRAY-ROW-MAJOR-INDEX (array &rest subscripts) +Package:LISP + +Returns the index into the data vector of ARRAY for the element of ARRAY +specified by SUBSCRIPTS. + + +@end defun + + +@defun ARRAY-DIMENSION (array axis-number) +Package:LISP + +Returns the length of AXIS-NUMBER of ARRAY. + + +@end defun + +@defun FIND (item sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (key #'identity)) +Package:LISP + +Returns the first element in SEQUENCE satisfying TEST with ITEM; NIL if no +such element exists. + + +@end defun + +@defun STRING-NOT-EQUAL (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2))) +Package:LISP + +Similar to STRING=, but ignores cases. + + +@end defun + +@defun STRING-RIGHT-TRIM (char-bag string) +Package:LISP + +Returns a copy of STRING with the characters in CHAR-BAG removed from the +right end. + + +@end defun + +@defun DELETE-IF-NOT (test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity)) +Package:LISP + +Returns a sequence formed by destructively removing the elements not +satisfying TEST from SEQUENCE. + + +@end defun + +@defun REMOVE-IF-NOT (test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity)) +Package:LISP + +Returns a copy of SEQUENCE with elements not satisfying TEST removed. + + +@end defun + +@defun STRING= (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2))) +Package:LISP + +Returns T if the two strings are character-wise CHAR=; NIL otherwise. + + +@end defun + +@defun NSUBSTITUTE-IF (new test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity)) +Package:LISP + +Returns a sequence of the same kind as SEQUENCE with the same elements +except that all elements satisfying TEST are replaced with NEWITEM. SEQUENCE +may be destroyed. + + +@end defun + +@defun SOME (predicate sequence &rest more-sequences) +Package:LISP + +Returns T if at least one of the elements in SEQUENCEs satisfies PREDICATE; +NIL otherwise. + + +@end defun + +@defun MAKE-STRING (size &key (initial-element #\Space)) +Package:LISP + +Creates and returns a new string of SIZE length whose elements are all +INITIAL-ELEMENT. + + +@end defun + +@defun NSUBSTITUTE (newitem olditem sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity)) +Package:LISP + +Returns a sequence of the same kind as SEQUENCE with the same elements +except that OLDITEMs are replaced with NEWITEM. SEQUENCE may be destroyed. + + +@end defun + +@defun STRING-EQUAL (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2))) +Package:LISP + +Given two strings (string1 and string2), and optional integers start1, +start2, end1 and end2, compares characters in string1 to characters in +string2 (using char-equal). + + +@end defun + +@defun STRING-NOT-GREATERP (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2))) +Package:LISP + +Similar to STRING<=, but ignores cases. + + +@end defun + +@defun STRING> (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2))) +Package:LISP + +If STRING1 is lexicographically greater than STRING2, then returns the +longest common prefix of the strings. Otherwise, returns NIL. + + +@end defun + +@defun STRINGP (x) +Package:LISP + +Returns T if X is a string; NIL otherwise. + + +@end defun + +@defun DELETE-IF (test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity)) +Package:LISP + +Returns a sequence formed by removing the elements satisfying TEST +destructively from SEQUENCE. + + +@end defun + +@defun SIMPLE-STRING-P (x) +Package:LISP + +Returns T if X is a simple string; NIL otherwise. + + +@end defun + +@defun REMOVE-IF (test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity)) +Package:LISP + +Returns a copy of SEQUENCE with elements satisfying TEST removed. + + +@end defun + +@defun HASH-TABLE-COUNT (hash-table) +Package:LISP + +Returns the number of entries in the given Hash-Table. + + +@end defun + +@defun ARRAY-DIMENSIONS (array) +Package:LISP + +Returns a list whose elements are the dimensions of ARRAY + + +@end defun + +@defun SUBSTITUTE-IF-NOT (new test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity)) +Package:LISP + +Returns a sequence of the same kind as SEQUENCE with the same elements +except that all elements not satisfying TEST are replaced with NEWITEM. + + +@end defun + +@defun ADJUSTABLE-ARRAY-P (array) +Package:LISP + +Returns T if ARRAY is adjustable; NIL otherwise. + + +@end defun + +@defun SVREF (simple-vector index) +Package:LISP + +Returns the INDEX-th element of SIMPLE-VECTOR. + + +@end defun + +@defun VECTOR-PUSH-EXTEND (new-element vector &optional (extension (length vector))) +Package:LISP + +Similar to VECTOR-PUSH except that, if the fill pointer gets too large, +extends VECTOR rather then simply returns NIL. + + +@end defun + +@defun DELETE (item sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity)) +Package:LISP + +Returns a sequence formed by removing the specified ITEM destructively from +SEQUENCE. + + +@end defun + +@defun REMOVE (item sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity)) +Package:LISP + +Returns a copy of SEQUENCE with ITEM removed. + + +@end defun + +@defun STRING (x) +Package:LISP + +Coerces X into a string. If X is a string, then returns X itself. If X is a +symbol, then returns X's print name. If X is a character, then returns a one +element string containing that character. Signals an error if X cannot be +coerced into a string. + + +@end defun + +@defun STRING-UPCASE (string &key (start 0) (end (length string))) +Package:LISP + +Returns a copy of STRING with all lower case characters converted to +uppercase. + + +@end defun + +@defun GETHASH (key hash-table &optional (default nil)) +Package:LISP + +Finds the entry in HASH-TABLE whose key is KEY and returns the associated +value and T, as multiple values. Returns DEFAULT and NIL if there is no +such entry. + + +@end defun + +@defun MAKE-HASH-TABLE (&key (test 'eql) (size 1024) (rehash-size 1.5) (rehash-threshold 0.7)) +Package:LISP + +Creates and returns a hash table. + + +@end defun + +@defun STRING/= (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2))) +Package:LISP + +Returns NIL if STRING1 and STRING2 are character-wise CHAR=. Otherwise, +returns the index to the longest common prefix of the strings. + + +@end defun + +@defun STRING-GREATERP (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2))) +Package:LISP + +Similar to STRING>, but ignores cases. + + +@end defun + +@defun ELT (sequence index) +Package:LISP + +Returns the INDEX-th element of SEQUENCE. + + +@end defun + +@defun MAKE-ARRAY (dimensions &key (element-type t) initial-element (initial-contents nil) (adjustable nil) (fill-pointer nil) (displaced-to nil) (displaced-index-offset 0) static) +Package:LISP + +Creates an array of the specified DIMENSIONS. The default for INITIAL- +ELEMENT depends on ELEMENT-TYPE. +MAKE-ARRAY will always try to find the `best' array to +accommodate the element-type specified. For example on a SUN element-type +(mod 1) --> bit +(integer 0 10) --> unsigned-char +(integer -3 10) --> signed-char +si::best-array-element-type is the function doing this. It +is also used by the compiler, for coercing array element types. +If you are going to declare an array you should use the same +element type as was used in making it. eg +(setq my-array (make-array 4 :element-type '(integer 0 10))) +(the (array (integer 0 10)) my-array) + When wanting to optimize references to an array you need to +declare the array eg: (the (array (integer -3 10)) my-array) if ar +were constructed using the (integer -3 10) element-type. You could of +course have used signed-char, but since the ranges may be +implementation dependent it is better to use -3 10 range. MAKE-ARRAY +needs to do some calculation with the element-type if you don't +provide a primitive data-type. One way of doing this in a machine +independent fashion: + + (defvar *my-elt-type* #. + (array-element-type (make-array 1 :element-type '(integer -3 10)))) + +Then calls to (make-array n :element-type *my-elt-type*) will not have to go +through a type inclusion computation. The keyword STATIC (GCL specific) if non +nil, will cause the array body to be non relocatable. + + + +@end defun + +@defun NSTRING-DOWNCASE (string &key (start 0) (end (length string))) +Package:LISP + Returns STRING with all upper case +characters converted to lowercase. + + +@end defun + +@defun ARRAY-IN-BOUNDS-P (array &rest subscripts) +Package:LISP + Returns T if SUBSCRIPTS are valid subscripts for +ARRAY; NIL otherwise. + + +@end defun + +@defun SORT (sequence predicate &key (key #'identity)) +Package:LISP + Destructively sorts SEQUENCE. +PREDICATE should return non-NIL if its first argument is to precede +its second argument. + + +@end defun + +@defun HASH-TABLE-P (x) +Package:LISP + +Returns T if X is a hash table object; NIL +otherwise. + + +@end defun + +@defun COUNT-IF-NOT (test sequence &key (from-end nil) (start 0) (end (length sequence)) (key #'identity)) +Package:LISP + +Returns the number of elements in SEQUENCE not satisfying TEST. + + +@end defun + +@defun FILL-POINTER (vector) +Package:LISP + +Returns the fill pointer of VECTOR. + + +@end defun + + +@defun ARRAYP (x) +Package:LISP + +Returns T if X is an array; NIL otherwise. + + +@end defun + +@defun REPLACE (sequence1 sequence2 &key (start1 0) (end1 (length sequence1)) (start2 0) (end2 (length sequence2))) +Package:LISP + +Destructively modifies SEQUENCE1 by copying successive elements into it from +SEQUENCE2. + + +@end defun + +@defun BIT-XOR (bit-array1 bit-array2 &optional (result-bit-array nil)) +Package:LISP + +Performs a bit-wise logical XOR on the elements of BIT-ARRAY1 and BIT-ARRAY2. +Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into +BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. + + +@end defun + +@defun CLRHASH (hash-table) +Package:LISP + +Removes all entries of HASH-TABLE and returns the hash table itself. + + +@end defun + +@defun SUBSTITUTE-IF (newitem test sequence &key (from-end nil) (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity)) +Package:LISP + +Returns a sequence of the same kind as SEQUENCE with the same elements +except that all elements satisfying TEST are replaced with NEWITEM. + + +@end defun + +@defun MISMATCH (sequence1 sequence2 &key (from-end nil) (test #'eql) test-not (start1 0) (start2 0) (end1 (length sequence1)) (end2 (length sequence2)) (key #'identity)) +Package:LISP + +The specified subsequences of SEQUENCE1 and SEQUENCE2 are compared +element-wise. If they are of equal length and match in every element, the +result is NIL. Otherwise, the result is a non-negative integer, the index +within SEQUENCE1 of the leftmost position at which they fail to match; or, if +one is shorter than and a matching prefix of the other, the index within +SEQUENCE1 beyond the last position tested is returned. + + +@end defun + +@defvr {Constant} ARRAY-TOTAL-SIZE-LIMIT +Package:LISP +The exclusive upper bound on the total number of elements of an array. + + +@end defvr + +@defun VECTOR-POP (vector) +Package:LISP + +Attempts to decrease the fill-pointer of VECTOR by 1 and returns the element +pointed to by the new fill pointer. Signals an error if the old value of +the fill pointer is 0. + + +@end defun + +@defun SUBSTITUTE (newitem olditem sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (count most-positive-fixnum) (key #'identity)) +Package:LISP + +Returns a sequence of the same kind as SEQUENCE with the same elements +except that OLDITEMs are replaced with NEWITEM. + + +@end defun + +@defun ARRAY-HAS-FILL-POINTER-P (array) +Package:LISP + +Returns T if ARRAY has a fill pointer; NIL otherwise. + + +@end defun + +@defun CONCATENATE (result-type &rest sequences) +Package:LISP + +Returns a new sequence of the specified RESULT-TYPE, consisting of all +elements in SEQUENCEs. + + +@end defun + +@defun VECTOR-PUSH (new-element vector) +Package:LISP + +Attempts to set the element of ARRAY designated by its fill pointer to +NEW-ELEMENT and increments the fill pointer by one. Returns NIL if the fill +pointer is too large. Otherwise, returns the new fill pointer value. + + +@end defun + +@defun STRING-TRIM (char-bag string) +Package:LISP + +Returns a copy of STRING with the characters in CHAR-BAG removed from both +ends. + + +@end defun + +@defun ARRAY-ELEMENT-TYPE (array) +Package:LISP + +Returns the type of the elements of ARRAY + + +@end defun + +@defun NOTANY (predicate sequence &rest more-sequences) +Package:LISP + +Returns T if none of the elements in SEQUENCEs satisfies PREDICATE; NIL +otherwise. + + +@end defun + +@defun BIT-NOT (bit-array &optional (result-bit-array nil)) +Package:LISP + +Performs a bit-wise logical NOT in the elements of BIT-ARRAY. +Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into +BIT-ARRAY if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. + + +@end defun + +@defun BIT-ORC1 (bit-array1 bit-array2 &optional (result-bit-array nil)) +Package:LISP + +Performs a bit-wise logical ORC1 on the elements of BIT-ARRAY1 and BIT-ARRAY2. +Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into +BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. + + +@end defun + +@defun COUNT-IF (test sequence &key (from-end nil) (start 0) (end (length sequence)) (key #'identity)) +Package:LISP + +Returns the number of elements in SEQUENCE satisfying TEST. + + +@end defun + +@defun MAP (result-type function sequence &rest more-sequences) +Package:LISP + +FUNCTION must take as many arguments as there are sequences provided. The +result is a sequence such that the i-th element is the result of applying +FUNCTION to the i-th elements of the SEQUENCEs. + + +@end defun + +@defvr {Constant} ARRAY-RANK-LIMIT +Package:LISP +The exclusive upper bound on the rank of an array. + + +@end defvr + +@defun COUNT (item sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (key #'identity)) +Package:LISP + +Returns the number of elements in SEQUENCE satisfying TEST with ITEM. + + +@end defun + +@defun BIT-VECTOR-P (x) +Package:LISP + +Returns T if X is a bit vector; NIL otherwise. + + +@end defun + +@defun NSTRING-CAPITALIZE (string &key (start 0) (end (length string))) +Package:LISP + +Returns STRING with the first character of each word converted to upper-case, +and remaining characters in the word converted to lower case. + + +@end defun + +@defun ADJUST-ARRAY (array dimensions &key (element-type (array-element-type array)) initial-element (initial-contents nil) (fill-pointer nil) (displaced-to nil) (displaced-index-offset 0)) +Package:LISP + +Adjusts the dimensions of ARRAY to the given DIMENSIONS. The default value +of INITIAL-ELEMENT depends on ELEMENT-TYPE. + + +@end defun + +@defun SEARCH (sequence1 sequence2 &key (from-end nil) (test #'eql) test-not (start1 0) (start2 0) (end1 (length sequence1)) (end2 (length sequence2)) (key #'identity)) +Package:LISP + +A search is conducted for the first subsequence of SEQUENCE2 which +element-wise matches SEQUENCE1. If there is such a subsequence in SEQUENCE2, +the index of the its leftmost element is returned; otherwise, NIL is +returned. + + +@end defun + +@defun SIMPLE-BIT-VECTOR-P (x) +Package:LISP + +Returns T if X is a simple bit-vector; NIL otherwise. + + +@end defun + +@defun MAKE-SEQUENCE (type length &key initial-element) +Package:LISP + +Returns a sequence of the given TYPE and LENGTH, with elements initialized +to INITIAL-ELEMENT. The default value of INITIAL-ELEMENT depends on TYPE. + + +@end defun + +@defun BIT-ORC2 (bit-array1 bit-array2 &optional (result-bit-array nil)) +Package:LISP + +Performs a bit-wise logical ORC2 on the elements of BIT-ARRAY1 and BIT-ARRAY2. +Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into +BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. + + +@end defun + +@defun NREVERSE (sequence) +Package:LISP + +Returns a sequence of the same elements as SEQUENCE but in reverse order. +SEQUENCE may be destroyed. + + +@end defun + +@defvr {Constant} ARRAY-DIMENSION-LIMIT +Package:LISP +The exclusive upper bound of the array dimension. + + +@end defvr + +@defun NOTEVERY (predicate sequence &rest more-sequences) +Package:LISP + +Returns T if at least one of the elements in SEQUENCEs does not satisfy +PREDICATE; NIL otherwise. + + +@end defun + +@defun POSITION-IF-NOT (test sequence &key (from-end nil) (start 0) (end (length sequence)) (key #'identity)) +Package:LISP + +Returns the index of the first element in SEQUENCE that does not satisfy TEST; +NIL if no such element exists. + + +@end defun + +@defun STRING-DOWNCASE (string &key (start 0) (end (length string))) +Package:LISP + +Returns a copy of STRING with all upper case characters converted to +lowercase. + + +@end defun + +@defun BIT (bit-array &rest subscripts) +Package:LISP + +Returns the bit from BIT-ARRAY at SUBSCRIPTS. + + +@end defun + +@defun STRING-NOT-LESSP (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2))) +Package:LISP + +Similar to STRING>=, but ignores cases. + + +@end defun + +@defun CHAR (string index) +Package:LISP + +Returns the INDEX-th character in STRING. + + +@end defun + +@defun AREF (array &rest subscripts) +Package:LISP + +Returns the element of ARRAY specified by SUBSCRIPTS. + + +@end defun + +@defun FILL (sequence item &key (start 0) (end (length sequence))) +Package:LISP + +Replaces the specified elements of SEQUENCE all with ITEM. + + +@end defun + +@defun STABLE-SORT (sequence predicate &key (key #'identity)) +Package:LISP + +Destructively sorts SEQUENCE. PREDICATE should return non-NIL if its first +argument is to precede its second argument. + + +@end defun + +@defun BIT-IOR (bit-array1 bit-array2 &optional (result-bit-array nil)) +Package:LISP + +Performs a bit-wise logical IOR on the elements of BIT-ARRAY1 and BIT-ARRAY2. +Puts the results into a new bit array if RESULT-BIT-ARRAY is NIL, into +BIT-ARRAY1 if RESULT-BIT-ARRAY is T, or into RESULT-BIT-ARRAY otherwise. + + +@end defun + +@defun REMHASH (key hash-table) +Package:LISP + +Removes any entry for KEY in HASH-TABLE. Returns T if such an entry +existed; NIL otherwise. + + +@end defun + +@defun VECTORP (x) +Package:LISP + +Returns T if X is a vector; NIL otherwise. + + +@end defun + +@defun STRING<= (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2))) +Package:LISP + +If STRING1 is lexicographically less than or equal to STRING2, then returns +the longest common prefix of the two strings. Otherwise, returns NIL. + + +@end defun + +@defun SIMPLE-VECTOR-P (x) +Package:LISP + +Returns T if X is a simple vector; NIL otherwise. + + +@end defun + +@defun STRING-LEFT-TRIM (char-bag string) +Package:LISP + +Returns a copy of STRING with the characters in CHAR-BAG removed from the +left end. + + +@end defun + +@defun ARRAY-TOTAL-SIZE (array) +Package:LISP + +Returns the total number of elements of ARRAY. + + +@end defun + +@defun FIND-IF-NOT (test sequence &key (from-end nil) (start 0) (end (length sequence)) (key #'identity)) +Package:LISP + +Returns the index of the first element in SEQUENCE that does not satisfy +TEST; NIL if no such element exists. + + +@end defun + +@defun DELETE-DUPLICATES (sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (key #'identity)) +Package:LISP + +Returns a sequence formed by removing duplicated elements destructively from +SEQUENCE. + + +@end defun + +@defun REMOVE-DUPLICATES (sequence &key (from-end nil) (test #'eql) test-not (start 0) (end (length sequence)) (key #'identity)) +Package:LISP + +The elements of SEQUENCE are examined, and if any two match, one is discarded. +Returns the resulting sequence. + + +@end defun + +@defun POSITION-IF (test sequence &key (from-end nil) (start 0) (end (length sequence)) (key #'identity)) +Package:LISP + +Returns the index of the first element in SEQUENCE that satisfies TEST; NIL +if no such element exists. + + +@end defun + +@defun MERGE (result-type sequence1 sequence2 predicate &key (key #'identity)) +Package:LISP + +SEQUENCE1 and SEQUENCE2 are destructively merged into a sequence of type +RESULT-TYPE using PREDICATE to order the elements. + + +@end defun + +@defun EVERY (predicate sequence &rest more-sequences) +Package:LISP + +Returns T if every elements of SEQUENCEs satisfy PREDICATE; NIL otherwise. + + +@end defun + +@defun REDUCE (function sequence &key (from-end nil) (start 0) (end (length sequence)) initial-value) +Package:LISP + +Combines all the elements of SEQUENCE using a binary operation FUNCTION. +If INITIAL-VALUE is supplied, it is logically placed before the SEQUENCE. + + +@end defun + +@defun STRING-LESSP (string1 string2 &key (start1 0) (end1 (length string1)) (start2 0) (end2 (length string2))) +Package:LISP + +Similar to STRING<, but ignores cases. + + +@end defun diff --git a/info/si-defs.texi b/info/si-defs.texi new file mode 100755 index 0000000..da6ced2 --- /dev/null +++ b/info/si-defs.texi @@ -0,0 +1,1157 @@ + +@node System Definitions, Debugging, C Interface, Top +@chapter System Definitions + + +@defun ALLOCATE-CONTIGUOUS-PAGES (number &optional (really-allocate nil)) +Package:SI + +GCL specific: Sets the maximum number of pages for contiguous blocks to +NUMBER. If REALLY-ALLOCATE is non-NIL, then the specified +number of pages will be allocated immediately. + + +@end defun +@defun FREEZE-DEFSTRUCT (name) +Package:SI + +The inline defstruct type checker will be made more efficient, in that +it will only check for types which currently include NAME. After +calling this the defstruct should not be altered. + + +@end defun +@defun MAXIMUM-ALLOCATABLE-PAGES (type) +Package:SI + +GCL specific: Returns the current maximum number of pages for the type class +of the GCL implementation type TYPE. + + +@end defun +@defun ALLOCATED-RELOCATABLE-PAGES () +Package:SI + +GCL specific: Returns the number of pages currently allocated for relocatable +blocks. + + +@end defun +@defun PUTPROP (symbol value indicator) +Package:SI + +Give SYMBOL the VALUE on INDICATOR property. + + +@end defun +@defun ALLOCATED-PAGES (type) +Package:SI + +GCL specific: Returns the number of pages currently allocated for the type +class of the GCL implementation type TYPE. + + +@end defun +@defun ALLOCATE-RELOCATABLE-PAGES (number) +Package:SI + +GCL specific: Sets the maximum number of pages for relocatable blocks to +NUMBER. + + +@end defun +@defun ALLOCATED-CONTIGUOUS-PAGES () +Package:SI + +GCL specific: Returns the number of pages currently allocated for contiguous +blocks. + + +@end defun +@defun MAXIMUM-CONTIGUOUS-PAGES () +Package:SI + +GCL specific: Returns the current maximum number of pages for contiguous +blocks. + + +@end defun +@defun GET-HOLE-SIZE () +Package:SI + +GCL specific: Returns as a fixnum the size of the memory hole (in pages). + + +@end defun +@defun SPECIALP (symbol) +Package:SI + +GCL specific: Returns T if the SYMBOL is a globally special variable; NIL +otherwise. + + +@end defun +@defun OUTPUT-STREAM-STRING (string-output-stream) +Package:SI + +GCL specific: Returns the string corresponding to the STRING-OUTPUT-STREAM. + + +@end defun +@defun GET-STRING-INPUT-STREAM-INDEX (string-input-stream) +Package:SI + +GCL specific: Returns the current index of the STRING-INPUT-STREAM. + + +@end defun +@defun STRING-CONCATENATE (&rest strings) +Package:SI + +GCL specific: Returns the result of concatenating the given STRINGS. + + +@end defun +@defun BDS-VAR (i) +Package:SI + +GCL specific: Returns the symbol of the i-th entity in the bind stack. + + +@end defun +@defun ERROR-SET (form) +Package:SI + +GCL specific: Evaluates the FORM in the null environment. If the evaluation +of the FORM has successfully completed, SI:ERROR-SET returns NIL as the first +value and the result of the evaluation as the rest of the values. If, in the +course of the evaluation, a non-local jump from the FORM is atempted, +SI:ERROR-SET traps the jump and returns the corresponding jump tag as its +value. + + +@end defun +@defun COMPILED-FUNCTION-NAME (compiled-function-object) +Package:SI + +GCL specific: Returns the name of the COMPILED-FUNCTION-OBJECT. + + +@end defun +@defun STRUCTUREP (object) +Package:SI + +GCL specific: Returns T if the OBJECT is a structure; NIL otherwise. + + +@end defun +@defun IHS-VS (i) +Package:SI + +GCL specific: Returns the value stack index of the i-th entity in the +invocation history stack. + + +@end defun +@defun UNIVERSAL-ERROR-HANDLER (error-name correctable function-name continue-format-string error-format-string &rest args) +Package:SI + +GCL specific: Starts the error handler of GCL. When an error is detected, +GCL calls SI:UNIVERSAL-ERROR-HANDLER with the specified arguments. +ERROR-NAME is the name of the error. CORRECTABLE is T for a correctable +error and NIL for a fatal error. FUNCTION-NAME is the name of the function +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. + To change the error handler of GCL, redefine SI:UNIVERSAL-ERROR- +HANDLER. + + +@end defun +@defvar *INTERRUPT-ENABLE* +Package:SI +GCL specific: If the value of SI:*INTERRUPT-ENABLE* is non-NIL, GCL signals +an error on the terminal interrupt (this is the default case). If it is NIL, +GCL ignores the interrupt and assigns T to SI:*INTERRUPT-ENABLE*. + + +@end defvar +@defun CHDIR (pathname) +Package:SI + +GCL/UNIX specific: Changes the current working directory to the specified +pathname. + + +@end defun +@defun COPY-STREAM (in-stream out-stream) +Package:SI + +GCL specific: Copies IN-STREAM to OUT-STREAM until the end-of-file on IN- +STREAM. + + +@end defun +@defun INIT-SYSTEM () +Package:SI + +GCL specific: Initializes the library and the compiler of GCL. Since they +have already been initialized in the standard image of GCL, calling SI:INIT- +SYSTEM will cause an error. + + +@end defun +@defvar *INDENT-FORMATTED-OUTPUT* +Package:SI +GCL specific: The FORMAT directive ~% indents the next line if the value of +this variable is non-NIL. If NIL, ~% simply does Newline. + + +@end defvar +@defun SET-HOLE-SIZE (fixnum) +Package:SI + +GCL specific: Sets the size of the memory hole (in pages). + + +@end defun +@defun FRS-BDS (i) +Package:SI + +GCL specific: Returns the bind stack index of the i-th entity in the frame +stack. + + +@end defun +@defun IHS-FUN (i) +Package:SI + +GCL specific: Returns the function value of the i-th entity in the invocation +history stack. + + +@end defun +@defun *MAKE-CONSTANT (symbol value) +Package:SI + +GCL specific: Makes the SYMBOL a constant with the specified VALUE. + + +@end defun +@defun FIXNUMP (object) +Package:SI + +GCL specific: Returns T if the OBJECT is a fixnum; NIL otherwise. + + +@end defun +@defun BDS-VAL (i) +Package:SI + +GCL specific: Returns the value of the i-th entity in the bind stack. + + +@end defun +@defun STRING-TO-OBJECT (string) +Package:SI + +GCL specific: (SI:STRING-TO-OBJECT STRING) is equivalent to +(READ-FROM-STRING STRING), but much faster. + + +@end defun +@defvar *SYSTEM-DIRECTORY* +Package:SI +GCL specific: Holds the name of the system directory of GCL. + + +@end defvar +@defun FRS-IHS (i) +Package:SI + +GCL specific: Returns the invocation history stack index of the i-th entity +in the frame stack. + + +@end defun +@defun RESET-GBC-COUNT () +Package:SI + +GCL specific: Resets the counter of the garbage collector that records how +many times the garbage collector has been called for each implementation +type. + + +@end defun +@defun CATCH-BAD-SIGNALS () +Package:SI + +GCL/BSD specific: Installs a signal catcher for bad signals: + SIGILL, SIGIOT, SIGEMT, SIGBUS, SIGSEGV, SIGSYS. +The signal catcher, upon catching the signal, signals an error (and enter +the break-level). Since the internal memory of GCL may be broken, the user +should check the signal and exit from GCL if necessary. When the signal +is caught during garbage collection, GCL terminates immediately. + + +@end defun +@defun RESET-STACK-LIMITS () +Package:SI + +GCL specific: Resets the stack limits to the normal state. When a stack has +overflowed, GCL extends the limit for the stack in order to execute the error +handler. After processing the error, GCL resets the stack limit by calling +SI:RESET-STACK-LIMITS. + + +@end defun +@defvar *GBC-MESSAGE* +Package:SI +GCL specific: If the value of SI:*GBC-MESSAGE* is non-NIL, the garbage +collector prints some information on the terminal. Usually SI:*GBC-MESSAGE* +should be set NIL. + + +@end defvar +@defvar *GBC-NOTIFY* +Package:SI +GCL specific: If the value is non-NIL, the garbage +collector prints a very brief one line message about the area causing the collection, +and the time spent in internal time units. + + +@end defvar +@defvar *AFTER-GBC-HOOK* +Package:SI +Defaults to nil, but may be set to a function of one argument TYPE which is +a lisp variable indicating the TYPE which caused the current collection. + + +@end defvar +@deffn {Funcition} ALLOCATED (type) +Package:SI + +Returns 6 values: +@table @asis +@item nfree +number free +@item npages +number of pages +@item maxpage +number of pages to grow to +@item nppage +number per page +@item gbccount +number of gc's due to running out of items of this size +@item nused +number of items used +@end table + +Note that all items of the same size are stored on similar pages. +Thus for example on a 486 under linux the following basic types are +all the same size and so will share the same allocated information: +CONS BIGNUM RATIO COMPLEX STRUCTURE. + + + +@end deffn + +@defun *MAKE-SPECIAL (symbol) +Package:SI + +GCL specific: Makes the SYMBOL globally special. + + +@end defun +@defun MAKE-STRING-OUTPUT-STREAM-FROM-STRING (string) +Package:SI + +GCL specific: Creates a string-output-stream corresponding to the STRING and +returns it. The STRING should have a fill-pointer. + + +@end defun +@defvar *IGNORE-EOF-ON-TERMINAL-IO* +Package:SI +GCL specific: If the value of SI:*IGNORE-EOF-ON-TERMINAL-IO* is non-NIL, GCL +ignores the eof-character (usually ^D) on the terminal and the terminal never +becomes end-of-file. The default value of SI:*IGNORE-EOF-ON-TERMINAL-IO* is +NIL. + + +@end defvar +@defun ADDRESS (object) +Package:SI + +GCL specific: Returns the address of the OBJECT as a fixnum. The address of +an object depends on the version of GCL. E.g. (SI:ADDRESS NIL) returns +1879062044 on GCL/AOSVS dated March 14, 1986. + + +@end defun +@defvar *LISP-MAXPAGES* +Package:SI +GCL specific: Holds the maximum number of pages (1 page = 2048 bytes) for the +GCL process. The result of changing the value of SI:*LISP-MAXPAGES* is +unpredictable. + + +@end defvar +@defun ARGC () +Package:SI + +GCL specific: Returns the number of arguments on the command line that invoked +the GCL process. + + +@end defun +@defun NANI (fixnum) +Package:SI + +GCL specific: Returns the object in the address FIXNUM. This function is +the inverse of SI:ADDRESS. Although SI:ADDRESS is a harmless operation, +SI:NANI is quite dangerous and should be used with care. + + +@end defun +@defvar *NOTIFY-GBC* +Package:SI +GCL specific: If the value of this variable is non-NIL, then the garbage +collector notifies that it begins to run whenever it is invoked. Otherwise, +garbage collection begins silently. + + +@end defvar +@defun SAVE-SYSTEM (pathname) +Package:SI + +GCL specific: Saves the current GCL core imange into a program file specified +by PATHNAME. This function differs from SAVE in that the contiguous and +relocatable areas are made permanent in the saved image. Usually the +standard image of GCL interpreter/compiler is saved by SI:SAVE-SYSTEM. +This function causes an exit from lisp. Various changes are made +to the memory of the running system, such as closing files and +resetting io streams. It would not be possible to continue normally. + + +@end defun +@defun UNCATCH-BAD-SIGNALS () +Package:SI + +GCL/BSD specific: Undoes the effect of SI:CATCH-BAD-SIGNALS. + + +@end defun +@defun VS (i) +Package:SI + +GCL specific: Returns the i-th entity in the value stack. + + +@end defun +@defun DISPLACED-ARRAY-P (array) +Package:SI + +GCL specific: Returns T if the ARRAY is a displaced array; NIL otherwise. + + +@end defun +@defun ARGV (fixnum) +Package:SI + +GCL specific: Returns the FIXNUM-th argument on the command line that invoked +the GCL process. + + +@end defun +@defvar *DEFAULT-TIME-ZONE* +Package:SI +GCL specific: Holds the default time zone. The initial value of SI:*DEFAULT- +TIME-ZONE* is 6 (the time zone of Austin, Texas). + + +@end defvar +@defun GETENV (string) +Package:SI + +GCL/UNIX specific: Returns the environment with the name STRING as a string; +if the environment specified by STRING is not found, returns NIL. + + +@end defun +@defun FASLINK (file string) +Package:SI + +GCL/BSD specific: Loads the FASL file FILE while linking the object files and +libraries specified by STRING. For example, + (faslink "foo.o" "bar.o boo.o -lpixrect") +loads foo.o while linking two object files (bar.o and boo.o) and the library +pixrect. Usually, foo.o consists of the C language interface for the +functions defined in the object files or the libraries. + +A more portable way of making references to C code, is to build it +in at the time of the original make. If foo.c references things +in -lpixrect, and foo.o is its compilation in the gcl/unixport directory + +(cd gcl/unixport ; make "EXTRAS= foo.o -lpixrect ") + +should add them. If EXTRAS was already joe.o in the unixport/makefile +you should of course add joe.o to the above "EXTRAS= joe.o foo.o.." + +Faslink does not work on most UNIX systems which are derived from SYS V or AIX. + + + + +@end defun +@defun TOP-LEVEL () +Package:SI + +GCL specific: Starts the standard top-level listner of GCL. When the GCL +process is invoked, it calls SI:TOP-LEVEL by (FUNCALL 'SI:TOP-LEVEL). + To change the top-level of GCL, redefine SI:TOP-LEVEL and save the core +imange in a file. When the saved imange is invoked, it will start the +redefined top-level. + + +@end defun +@defun FRS-VS (i) +Package:SI + +GCL specific: Returns the value stack index of the i-th entity in the frame +stack. + + +@end defun +@defun WRITE-DEBUG-SYMBOLS (start file &key (main-file "/usr/local/schelter/xgcl/unixport/raw_gcl") (output-file "debug-symbols.o" )) +Package:SI + +Write out a file of debug-symbols using address START as the place +where FILE will be loaded into the running executable MAIN-FILE. The +last is a keyword argument. + + + + +@end defun +@defun PROF (x y) +Package:SI + +These functions in the SI package are GCL specific, and allow monitoring +the run time of functions loaded into GCL, as well as the basic functions. + Sample Usage: + (si::set-up-profile 1000000) (si::prof 0 90) + run program + (si::prof 0 0) ;; turn off profile + (si::display-prof) + (si::clear-profile) + (si::prof 0 90) ;; start profile again + run program + .. + Profile can be stopped with (si::prof 0 0) and restarted with (si::prof 0 90) +The START-ADDRESS will correspond to the beginning of the profile array, and +the SCALE will mean that 256 bytes of code correspond to SCALE bytes in the +profile array. + +Thus if the profile array is 1,000,000 bytes long and the code segment is +5 megabytes long you can profile the whole thing using a scale of 50 +Note that long runs may result in overflow, and so an understating of the +time in a function. + +You must run intensively however since, with a scale of 128 it takes +6,000,000 times through a loop to overflow the sampling in one part of +the code. + + +@end defun +@defun CATCH-FATAL (i) +Package:SI + + +Sets the value of the C variable catch_fatal to I which should be an integer. +If catch_fatal is 1, then most unrecoverable fatal errors will be caught. +Upon catching such an error catch_fatal becomes -1, to avoid recursive errors. +The top level loop automatically sets catch_fatal to 1, if the value is less +than zero. Catching can be turned off by making catch_fatal = 0. + + + + +@end defun +@defvar *MULTIPLY-STACKS* +Package:SI + +If this variable is set to a positive fixnum, then the next time through the +TOP-LEVEL loop, the loop will be exited. The size of the stacks will be +multiplied by the value of *multiply-stacks*, and the TOP-LEVEL will be called +again. Thus to double the size of the stacks: + +>(setq si::*multiply-stacks* 2) +[exits top level and reinvokes it, with the new stacks in place] +> + +We must exit TOP-LEVEL, because it and any other lisp functions +maintain many pointers into the stacks, which would be incorrect when the +stacks have been moved. Interrupting the process of growing the stacks, +can leave you in an inconsistent state. + + +@end defvar +@defun GBC-TIME (&optional x) +Package:SI + +Sets the internal C variable gc_time to X if X is supplied and then +returns gc_time. If gc_time is greater or equal to 0, then gc_time is +incremented by the garbage collector, according to the number of +internal time units spent there. The initial value of gc_time is -1. + + + +@end defun +@defun FWRITE (string start count stream) +Package:SI + +Write from STRING starting at char START (or 0 if it is nil) COUNT characters +(or to end if COUNT is nil) to STREAM. STREAM must be a stream such as +returned by FP-OUTPUT-STREAM. Returns nil if it fails. + + + +@end defun +@defun FREAD (string start count stream) +Package:SI + +Read characters into STRING starting at char START (or 0 if it is nil) COUNT +characters (or from start to length of STRING if COUNT is nil). Characters +are read from STREAM. STREAM must be a stream such as returned by +FP-INPUT-STREAM. Returns nil if it fails. Return number of characters read +if it succeeds. + + +@end defun +@defun SGC-ON (&optional ON) +Package:SI + +If ON is not nil then SGC (stratified garbage collection) is turned +on. If ON is supplied and is nil, then SGC is turned off. +If ON is not supplied, then it returns T if SGC is on, and NIL if +SGC is off. + +The purpose of SGC is to prevent paging activity during garbage +collection. It is efficient if the actual number of pages being +written to form a small percentage of the total image size. The image +should be built as compactly as possible. This can be accomplished by +using a settings such as (si::allocate-growth 'cons 1 10 50 20) to limit +the growth in the cons maxpage to 10 pages per time. Then +just before calling si::save-system to save your image you can +do something like: + +(si::set-hole-size 500)(gbc nil) (si::sgc-on t) (si::save-system ..) + +This makes the saved image come up with SGC on. We have set a +reasonably large hole size. This is so that allocation of pages +either because they fill up, or through specific calls to +si::allocate, will not need to move all the relocatable data. Moving +relocatable data requires turning SGC off, performing a full gc, and +then turning it back on. New relocatable data is collected by SGC, +but moving the old requires going through all pages of memory to +change pointers into it. + +Using si::*notify-gbc* gives information about the number of pages +used by SGC. + +Note that SGC is only available on operating systems which provide +the mprotect system call, to write protect pages. Otherwise we +cannot tell which pages have been written too. + + + +@end defun +@defun ALLOCATE-SGC (type min-pages max-pages percent-free) +Package:SI + +If MIN-PAGES is 0, then this type will not be swept by SGC. Otherwise +this is the minimum number of pages to make available to SGC. MAX-PAGES +is the upper limit of such pages. Only pages with PERCENT-FREE objects +on them, will be assigned to SGC. +A list of the previous values for min, max and percent are returned. + + +@end defun +@defun ALLOCATE-GROWTH (type min max percent percent-free) +Package:SI + + +The next time after a garbage collection for TYPE, if PERCENT-FREE of +the objects of this TYPE are not actually free, and if the maximum +number of pages for this type has already been allocated, then the +maximum number will be increased by PERCENT of the old maximum, +subject to the condition that this increment be at least MIN pages and +at most MAX pages. A list of the previous values for min, max, +percent, and percent-free for the type TYPE is returned. A value +of 0 means use the system default, and if an argument is out of range +then the current values are returned with no change made. + +Examples: +(si::allocate-growth 'cons 1 10 50 10) +would insist that after a garbage collection for cons, there be at least +10% cons's free. If not the number of cons pages would be grown by +50% or 10 pages which ever was smaller. This might be reasonable if you +were trying to build an image which was `full', ie had few free objects +of this type. + +(si::allocate-growth 'fixnum 0 10000 30 40) +would grow space till there were normally 40% free fixnums, usually +growing by 30% per time. + +(si::allocate-growth 'cons 0 0 0 40) would require 40% free conses after +garbage collection for conses, and would use system defaults for the the rate +to grow towards this goal. + +(si::allocate-growth 'cons -1 0 0 0) +would return the current values, but not make any changes. + + +@end defun +@defun OPEN-FASD (stream direction eof-value table) +Package:SI + +Given file STREAM open for input or output in DIRECTION, +set it up to start writing or reading in fasd format. When +reading from this stream the EOF-VALUE will be returned when +the end a fasd end of dump marker is encountered. TABLE should +be an eq hashtable on output, a vector on input, or nil. In this +last case a default one will be constructed. + +We shall refer to the result as a `fasd stream'. It is +suitable as the arg to CLOSE-FASD, READ-FASD-TOP, and as the second +second arg to WRITE-FASD. As a lisp object it is actually a vector, +whose body coincides with: + +struct fasd @{ + object stream; /* lisp object of type stream */ + object table; /* hash table used in dumping or vector on input*/ + object eof; /* lisp object to be returned on coming to eof mark */ + object direction; /* holds Cnil or Kinput or Koutput */ + object package; /* the package symbols are in by default */ + object index; /* integer. The current_dump index on write */ + object filepos; /* nil or the position of the start */ + object table_length; /* On read it is set to the size dump array needed + or 0 + */ + object macro ; @} + +We did not use a defstruct for this, because we want the compiler to use this +and it makes bootstrapping more difficult. It is in "cmpnew/fasdmacros.lsp" + + + +@end defun +@defun WRITE-FASD-TOP (X FASD-STREAM) +Package:SI + +Write X to FASD-STREAM. + + +@end defun +@defun READ-FASD-TOP (FASD-STREAM) +Package:SI + +Read the next object from FASD-STREAM. Return the eof-value of FASD-STREAM if we +encounter an eof marker put out by CLOSE-FASD. Encountering end of actual file +stream causes an error. + + +@end defun +@defun CLOSE-FASD (FASD-STREAM) +Package:SI + +On output write an eof marker to the associated file stream, and then +make FASD-STREAM invalid for further output. It also attempts to write +information to the stream on the size of the index table needed to read from the +stream from the last open. This is useful in growing the array. +It does not alter the file stream, other than for writing this information to it. +The file stream may be reopened for further use. It is an error +to OPEN-FASD the same file or file stream again with out first calling CLOSE-FASD. + + + + + +@end defun +@defun FIND-SHARING-TOP (x table) +Package:SI + +X is any lisp object and TABLE is an eq hash table. This walks through X +making entries to indicate the frequency of symbols,lists, and arrays. +Initially items get -1 when they are first met, and this is decremented by 1 +each time the object occurs. Call this function on all the objects in a fasd +file, which you wish to share structure. + + +@end defun +@defvar *LOAD-PATHNAME* +Package:SI +Load binds this to the pathname of the file being loaded. + + +@end defvar +@deffn {Macro} DEFINE-INLINE-FUNCTION (fname vars &body body) +Package:SI + +This is equivalent to defun except that VARS may not contain +&optional, &rest, &key or &aux. Also a compiler property is +added, which essentially saves the body and turns this into +a let of the VARS and then execution of the body. This +last is done using si::DEFINE-COMPILER-MACRO +Example: +(si::define-inline-function myplus (a b c) (+ a b c)) + + +@end deffn +@deffn {Macro} DEFINE-COMPILER-MACRO (fname vars &body body) +Package:SI + +FNAME may be the name of a function, but at compile time the macro +expansion given by this is used. + +(si::define-compiler-macro mycar (a) `(car ,a)) + + +@end deffn +@defun DBL () +Package:SI + +Invoke a top level loop, in which debug commands may be entered. +These commands may also be entered at breaks, or in the error +handler. +See SOURCE-LEVEL-DEBUG + + +@end defun +@defun NLOAD (file) +Package:SI + +Load a file with the readtable bound to a special readtable, which +permits tracking of source line information as the file is loaded. +see SOURCE-LEVEL-DEBUG + + +@end defun +@defun BREAK-FUNCTION (function &optional line absolute) +Package:SI + +Set a breakpoint for a FUNCTION at LINE if the function has source +information loaded. If ABSOLUTE is not nil, then the line is understood to be +relative to the beginning of the buffer. See also dbl-break-function, the +emacs command. + + +@end defun +@defun XDR-OPEN (stream) +Package:SI + +Returns an object suitable for passing to XDR-READ if the stream +is an input stream, and XDR-WRITE if it was an output stream. +Note the stream must be a unix stream, on which si::fp-input-stream +or si::fp-output-stream would act as the identity. + + + +@end defun +@defun FP-INPUT-STREAM (stream) +Package:SI + +Return a unix stream for input associated to STREAM if possible, +otherwise return nil. + + +@end defun +@defun FP-OUTPUT-STREAM (stream) +Package:SI + +Return a unix stream for output associated to STREAM if possible, +otherwise return nil. + + + +@end defun +@defun XDR-READ (stream element) +Package:SI + +Read one item from STREAM of type the type of ELEMENT. The representation +of the elements is machine independent. The xdr routines are what is +used by the basic unix rpc calls. + + +@end defun +@defun XDR-WRITE (stream element) +Package:SI + +Write to STREAM the given ELEMENT. + + + + +@end defun +@defvar *TOP-LEVEL-HOOK* +Package:SI +If this variable is has a function as its value at start up time, then +it is run immediately after the init.lsp file is loaded. This is useful +for starting up an alternate top level loop. + + +@end defvar +@defun RUN-PROCESS (string arglist) +Package:SI + + +Execute the command STRING in a subshell passing the strings in the +list ARGLIST as arguments to the command. Return a two way stream +associated to this. Use si::fp-output-stream to get an associated +output stream or si::fp-input-stream. + +Bugs: It does not properly deallocate everything, so that it will fail +if you call it too many times. + + +@end defun + +@defvar *CASE-FOLD-SEARCH* +Package: SI +Non nil means that a string-match should ignore case +@end defvar + +@defun STRING-MATCH (pattern string &optional start end) +Package: SI +Match regexp PATTERN in STRING starting in string starting at START +and ending at END. Return -1 if match not found, otherwise +return the start index of the first matchs. The variable +*MATCH-DATA* will be set to a fixnum array of sufficient size to hold +the matches, to be obtained with match-beginning and match-end. +If it already contains such an array, then the contents of it will +be over written. + +The form of a regexp pattern is discussed in @xref{Regular Expressions}. + +@end defun + +@defun MATCH-BEGINNING (index) +Returns the beginning of the I'th match from the previous STRING-MATCH, +where the 0th is for the whole regexp and the subsequent ones match parenthetical expressions. -1 is returned if there is no match, or if the *match-data* +vector is not a fixnum array. +@end defun + +@defun MATCH-END (index) + Returns the end of the I'th match from the previous STRING-MATCH +@end defun + +@defun SOCKET (port &key host server async myaddr myport daemon) + +Establishes a socket connection to the specified PORT under a variety +of circumstances. + +If HOST is specified, then it is a string designating the IP address +of the server to which we are the client. ASYNC specifies that the +connection should be made asynchronously, and the call return +immediately. MYADDR and MYPORT can specify the IP address and port +respectively of a client connection, for example when the running +machine has several network interfaces. + +If SERVER is specified, then it is a function which will handle +incoming connections to this PORT. DAEMON specifies that the running +process should be forked to handle incoming connections in the +background. If DAEMON is set to the keyword PERSISTENT, then the +backgrounded process will survive when the parent process exits, and +the SOCKET call returns NIL. Any other non-NIL setting of DAEMON +causes the socket call to return the process id of the backgrounded +process. DAEMON currently only works on BSD and Linux based systems. + +If DAEMON is not set or nil, or if the socket is not a SERVER socket, +then the SOCKET call returns a two way stream. In this case, the +running process is responsible for all I/O operations on the stream. +Specifically, if a SERVER socket is created as a non-DAEMON, then the +running process must LISTEN for connections, ACCEPT them when present, +and call the SERVER function on the stream returned by ACCEPT. + +@end defun + +@defun ACCEPT (stream) + +Creates a new two-way stream to handle an individual incoming +connection to STREAM, which must have been created with the SOCKET +function with the SERVER keyword set. ACCEPT should only be invoked +when LISTEN on STREAM returns T. If the STREAM was created with the +DAEMON keyword set in the call to SOCKET, ACCEPT is unnecessary and +will be called automatically as needed. + +@end defun + +@menu +* Regular Expressions:: +@end menu + +@node Regular Expressions, , System Definitions, System Definitions +@section Regular Expressions + +The function @code{string-match} (*Index string-match::) is used to +match a regular expression against a string. If the variable +@code{*case-fold-search*} is not nil, case is ignored in the match. +To determine the extent of the match use *Index match-beginning:: and +*Index match-end::. + +Regular expressions are implemented using Henry Spencer's package +(thank you Henry!), and much of the description of regular expressions +below is copied verbatim from his manual entry. Code for delimited +searches, case insensitive searches, and speedups to allow fast +searching of long files was contributed by W. Schelter. The speedups +use an adaptation by Schelter of the Boyer and Moore string search +algorithm to the case of branched regular expressions. These allow +such expressions as 'not_there|really_not' to be searched for 30 times +faster than in GNU emacs (1995), and 200 times faster than in the +original Spencer method. Expressions such as [a-u]bcdex get a speedup +of 60 and 194 times respectively. This is based on searching a string +of 50000 characters (such as the file tk.lisp). + +@itemize @bullet +@item +A regular expression is a string containing zero or more @i{branches} which are separated by @code{|}. A match of the regular expression against a string is simply a match of the string with one of the branches. +@item +Each branch consists of zero or more @i{pieces}, concatenated. A matching +string must contain an initial substring matching the first piece, immediately +followed by a second substring matching the second piece and so on. +@item +Each piece is an @i{atom} optionally followed by @code{+}, @code{*}, or @code{?}. +@item +An atom followed by @code{+} matches a sequence of 1 or more matches of the atom. +@item +An atom followed by @code{*} matches a sequence of 0 or more matches of the atom. +@item +An atom followed by @code{?} matches a match of the atom, or the null string. +@item +An atom is +@itemize @minus +@item +a regular expression in parentheses matching a match for the regular expression +@item +a @i{range} see below +@item +a @code{.} matching any single character +@item +a @code{^} matching the null string at the beginning of the input string +@item +a @code{$} matching the null string at the end of the input string +@item +a @code{\} followed by a single character matching that character +@item +a single character with no other significance +(matching that character). +@end itemize +@item +A @i{range} is a sequence of characters enclosed in @code{[]}. +It normally matches any single character from the sequence. +@itemize @minus +@item +If the sequence begins with @code{^}, +it matches any single character @i{not} from the rest of the sequence. +@item +If two characters in the sequence are separated by @code{-}, this is shorthand +for the full list of ASCII characters between them +(e.g. @code{[0-9]} matches any decimal digit). +@item +To include a literal @code{]} in the sequence, make it the first character +(following a possible @code{^}). +@item +To include a literal @code{-}, make it the first or last character. +@end itemize +@end itemize + +@unnumberedsubsec Ordering Multiple Matches + +In general there may be more than one way to match a regular expression +to an input string. For example, consider the command + +@example + (string-match "(a*)b*" "aabaaabb") +@end example + +Considering only the rules given so far, the value of (list-matches 0 1) +might be @code{("aabb" "aa")} or @code{("aaab" "aaa")} or @code{("ab" "a")} +or any of several other combinations. +To resolve this potential ambiguity @b{string-match} chooses among +alternatives using the rule @i{first then longest}. +In other words, it considers the possible matches in order working +from left to right across the input string and the pattern, and it +attempts to match longer pieces of the input string before shorter +ones. More specifically, the following rules apply in decreasing +order of priority: +@itemize @asis{} +@item +[1] +If a regular expression could match two different parts of an input string +then it will match the one that begins earliest. +@item +[2] +If a regular expression contains @b{|} operators then the leftmost +matching sub-expression is chosen. +@item +[3] +In @b{*}@r{, }@b{+}@r{, and }@b{?} constructs, longer matches are chosen +in preference to shorter ones. +@item +[4] +In sequences of expression components the components are considered +from left to right. +@end itemize + +In the example from above, @b{(a*)b*}@r{ matches }@b{aab}@r{: the }@b{(a*)} +portion of the pattern is matched first and it consumes the leading +@b{aa}@r{; then the }@b{b*} portion of the pattern consumes the +next @b{b}. Or, consider the following example: + +@example + (string-match "(ab|a)(b*)c" "xabc") ==> 1 + (list-matches 0 1 2 3) ==> ("abc" "ab" "" NIL) + (match-beginning 0) ==> 1 + (match-end 0) ==> 4 + (match-beginning 1) ==> 1 + (match-end 1) ==> 3 + (match-beginning 2) ==> 3 + (match-end 2) ==> 3 + (match-beginning 3) ==> -1 + (match-end 3) ==> -1 + +@end example + +In the above example the return value of @code{1} (which is @code{> -1}) +indicates that a match was found. The entire match runs from +1 to 4. +Rule 4 specifies that @b{(ab|a)} gets first shot at the input +string and Rule 2 specifies that the @b{ab} sub-expression +is checked before the @b{a} sub-expression. +Thus the @b{b}@r{ has already been claimed before the }@b{(b*)} +component is checked and @b{(b*)} must match an empty string. + +The special characters in the string @code{"\()[]+.*|^$?"}, +must be quoted, if a simple string search is desired. The function +re-quote-string is provided for this purpose. +@example +(re-quote-string "*standard*") ==> "\\*standard\\*" + +(string-match (re-quote-string "*standard*") "X *standard* ") + ==> 2 + +(string-match "*standard*" "X *standard* ") +Error: Regexp Error: ?+* follows nothing +@end example +Note there is actually just one @code{\} before the @code{*} +but the printer makes two so that the string can be read, since +@code{\} is also the lisp quote character. In the last example +an error is signalled since the special character @code{*} must +follow an atom if it is interpreted as a regular expression. + + + + + + diff --git a/info/structure.texi b/info/structure.texi new file mode 100755 index 0000000..a3794d7 --- /dev/null +++ b/info/structure.texi @@ -0,0 +1,43 @@ +@node Structures, Iteration and Tests, Operating System, Top +@chapter Structures + +@deffn {Macro} DEFSTRUCT +Package:LISP + +Syntax: +@example +(defstruct + @{name | (name @{:conc-name | (:conc-name prefix-string) | + :constructor | (:constructor symbol [lambda-list]) | + :copier | (:copier symbol) | + :predicate | (:predicate symbol) | + (:include symbol) | + (:print-function function) | + (:type @{vector | (vector type) | list@}) | + :named | (:static @{ nil | t@}) + (:initial-offset number)@}*)@} + [doc] + @{slot-name | + (slot-name [default-value-form] @{:type type | :read-only flag@}*) @}* + ) +@end example + +Defines a structure. The doc-string DOC, if supplied, is saved as a STRUCTURE +doc and can be retrieved by (documentation 'NAME 'structure). +STATIC is gcl specific and makes the body non relocatable. + +See the files misc/rusage.lsp misc/cstruct.lsp, for examples of making +a lisp structure correspond to a C structure. + + + +@end deffn + +@defun HELP (&optional symbol) +Package:LISP + +GCL specific: Prints the documentation associated with SYMBOL. With no +argument, this function prints the greeting message to GCL beginners. + + +@end defun diff --git a/info/symbol.texi b/info/symbol.texi new file mode 100755 index 0000000..a7608cf --- /dev/null +++ b/info/symbol.texi @@ -0,0 +1,461 @@ +@node Symbols, Operating System, Compilation, Top +@chapter Symbols + +@defun GENSYM (&optional (x nil)) +Package:LISP + +Creates and returns a new uninterned symbol whose name is a prefix string +(defaults to "G"), followed by a decimal number. The number is incremented +by each call to GENSYM. X, if an integer, resets the counter. If X is a +string, it becomes the new prefix. + + +@end defun + +@defun KEYWORDP (x) +Package:LISP + +Returns T if X is a symbol and it belongs to the KEYWORD package; NIL +otherwise. + + +@end defun + +@defun REMPROP (symbol indicator) +Package:LISP + +Look on property list of SYMBOL for property with specified +INDICATOR. If found, splice this indicator and its value out of +the plist, and return T. If not found, returns NIL with no side effects. + +@end defun + +@defun SYMBOL-PACKAGE (symbol) +Package:LISP + +Returns the contents of the package cell of the symbol SYMBOL. + + +@end defun + +@defvar *PACKAGE* +Package:LISP +The current package. + + +@end defvar + + +@defun SHADOWING-IMPORT (symbols &optional (package *package*)) +Package:LISP + +Imports SYMBOLS into PACKAGE, disregarding any name conflict. If a symbol +of the same name is already present, then it is uninterned. SYMBOLS must +be a list of symbols or a symbol. + + +@end defun + +@deffn {Macro} REMF +Package:LISP + +Syntax: +@example +(remf place indicator) +@end example + +PLACE may be any place expression acceptable to SETF, and is expected +to hold a property list or NIL. This list is destructively altered to +remove the property specified by INDICATOR. Returns T if such a +property was present; NIL otherwise. + + +@end deffn + +@defun MAKUNBOUND (symbol) +Package:LISP + +Makes empty the value slot of SYMBOL. Returns SYMBOL. + + +@end defun + +@defun USE-PACKAGE (packages-to-use &optional (package *package*)) +Package:LISP + +Adds all packages in PACKAGE-TO-USE list to the use list for PACKAGE so that +the external symbols of the used packages are available as internal symbols +in PACKAGE. + + +@end defun + +@defun MAKE-SYMBOL (string) +Package:LISP + +Creates and returns a new uninterned symbol whose print name is STRING. + + +@end defun + +@deffn {Special Form} PSETQ +Package:LISP + +Syntax: +@example +(psetq @{var form@}*) +@end example + +Similar to SETQ, but evaluates all FORMs first, and then assigns each value to +the corresponding VAR. Returns NIL always. + + +@end deffn + +@defun PACKAGE-USED-BY-LIST (package) +Package:LISP + +Returns the list of packages that use PACKAGE. + + +@end defun + +@defun SYMBOLP (x) +Package:LISP + +Returns T if X is a symbol; NIL otherwise. + + +@end defun + +@defvr {Constant} NIL +Package:LISP +Holds NIL. + + +@end defvr + +@defun SET (symbol value) +Package:LISP + +Assigns the value of VALUE to the dynamic variable named by SYMBOL, and +returns the value assigned. + + +@end defun + +@deffn {Special Form} SETQ +Package:LISP + +Syntax: +@example +(setq @{var form@}*) +@end example + +VARs are not evaluated and must be symbols. Assigns the value of the first +FORM to the first VAR, then assigns the value of the second FORM to the second +VAR, and so on. Returns the last value assigned. + + +@end deffn + +@defun UNUSE-PACKAGE (packages-to-unuse &optional (package *package*)) +Package:LISP + +Removes PACKAGES-TO-UNUSE from the use list for PACKAGE. + + +@end defun + +@defvr {Constant} T +Package:LISP +Holds T. + + +@end defvr + +@defun PACKAGE-USE-LIST (package) +Package:LISP + +Returns the list of packages used by PACKAGE. + + +@end defun + +@defun LIST-ALL-PACKAGES () +Package:LISP + +Returns a list of all existing packages. + + +@end defun + +@defun COPY-SYMBOL (symbol &optional (copy-props nil)) +Package:LISP + +Returns a new uninterned symbol with the same print name as SYMBOL. +If COPY-PROPS is NIL, the function, the variable, and the property slots +of the new symbol have no value. Otherwise, these slots are given the +values of the corresponding slots of SYMBOL. + + +@end defun + +@defun SYMBOL-PLIST (symbol) +Package:LISP + +Returns the property list of SYMBOL. + + +@end defun + +@defun SYMBOL-NAME (symbol) +Package:LISP + +Returns the print name of the symbol SYMBOL. + + +@end defun + +@defun FIND-SYMBOL (name &optional (package *package*)) +Package:LISP + +Returns the symbol named NAME in +PACKAGE. If such a symbol is found, then the second value is :INTERN, +:EXTERNAL, or :INHERITED to indicate how the symbol is accessible. If +no symbol is found then both values are NIL. + + +@end defun + +@defun SHADOW (symbols &optional (package *package*)) +Package:LISP + +Creates an internal symbol in PACKAGE with the same name as each of the +specified SYMBOLS. SYMBOLS must be a list of symbols or a symbol. + + +@end defun + + +@defun FBOUNDP (symbol) +Package:LISP + +Returns T if SYMBOL has a global function definition or if SYMBOL names a +special form or a macro; NIL otherwise. + + +@end defun + +@defun MACRO-FUNCTION (symbol) +Package:LISP + +If SYMBOL globally names a macro, then returns the expansion function. +Returns NIL otherwise. + + +@end defun + +@defun IN-PACKAGE (package-name &key (nicknames nil) (use '(lisp))) +Package:LISP + +Sets *PACKAGE* to the package with PACKAGE-NAME, creating the package if +it does not exist. If the package already exists then it is modified +to agree with USE and NICKNAMES arguments. Any new nicknames are added +without removing any old ones not specified. If any package in the USE list +is not currently used, then it is added to the use list. + + +@end defun + +@defun MAKE-PACKAGE (package-name &key (nicknames nil) (use '(lisp))) +Package:LISP + +Makes a new package having the specified PACKAGE-NAME and NICKNAMES. The +package will inherit all external symbols from each package in the USE list. + + +@end defun + +@defun PACKAGE-SHADOWING-SYMBOLS (package) +Package:LISP + +Returns the list of symbols that have been declared as shadowing symbols +in PACKAGE. + + +@end defun + +@defun INTERN (name &optional (package *package*)) +Package:LISP + +Returns a symbol having the specified name, creating it if necessary. +Returns as the second value one of the symbols :INTERNAL, :EXTERNAL, +:INHERITED, and NIL. + + +@end defun + +@defun EXPORT (symbols &optional (package *package*)) +Package:LISP + +Makes SYMBOLS external symbols of PACKAGE. SYMBOLS must be a list of symbols +or a symbol. + + +@end defun + +@defun PACKAGEP (x) +Package:LISP + +Returns T if X is a package; NIL otherwise. + + +@end defun + +@defun SYMBOL-FUNCTION (symbol) +Package:LISP + +Returns the current global function definition named by SYMBOL. + + +@end defun + +@defun SYMBOL-VALUE (symbol) +Package:LISP + +Returns the current value of the dynamic (special) variable named by SYMBOL. + + +@end defun + +@defun BOUNDP (symbol) +Package:LISP + +Returns T if the global variable named by SYMBOL has a value; NIL otherwise. + + +@end defun + +@defun DOCUMENTATION (symbol doc-type) +Package:LISP + +Returns the doc-string of DOC-TYPE for SYMBOL; NIL if none exists. +Possible doc-types are: + FUNCTION (special forms, macros, and functions) + VARIABLE (dynamic variables, including constants) + TYPE (types defined by DEFTYPE) + STRUCTURE (structures defined by DEFSTRUCT) + SETF (SETF methods defined by DEFSETF, DEFINE-SETF-METHOD, and + DEFINE-MODIFY-MACRO) +All built-in special forms, macros, functions, and variables have their +doc-strings. + + +@end defun + +@defun GENTEMP (&optional (prefix "t") (package *package*)) +Package:LISP + +Creates a new symbol interned in the package PACKAGE with the given PREFIX. + + +@end defun + +@defun RENAME-PACKAGE (package new-name &optional (new-nicknames nil)) +Package:LISP + +Replaces the old name and nicknames of PACKAGE with NEW-NAME and +NEW-NICKNAMES. + + +@end defun + +@defun UNINTERN (symbol &optional (package *package*)) +Package:LISP + +Makes SYMBOL no longer present in PACKAGE. Returns T if SYMBOL was present; +NIL otherwise. If PACKAGE is the home package of SYMBOL, then makes SYMBOL +uninterned. + + +@end defun + +@defun UNEXPORT (symbols &optional (package *package*)) +Package:LISP + +Makes SYMBOLS no longer accessible as external symbols in PACKAGE. SYMBOLS +must be a list of symbols or a symbol. + + +@end defun + +@defun PACKAGE-NICKNAMES (package) +Package:LISP + +Returns as a list the nickname strings for the specified PACKAGE. + + +@end defun + +@defun IMPORT (symbols &optional (package *package*)) +Package:LISP + +Makes SYMBOLS internal symbols of PACKAGE. SYMBOLS must be a list of symbols +or a symbol. + + +@end defun + +@defun GET (symbol indicator &optional (default nil)) +Package:LISP + +Looks on the property list of SYMBOL for the specified INDICATOR. If this +is found, returns the associated value. Otherwise, returns DEFAULT. + + +@end defun + +@defun FIND-ALL-SYMBOLS (string-or-symbol) +Package:LISP + +Returns a list of all symbols that have the specified name. + + +@end defun + +@defun FMAKUNBOUND (symbol) +Package:LISP + +Discards the global function definition named by SYMBOL. Returns SYMBOL. + + +@end defun + +@defun PACKAGE-NAME (package) +Package:LISP + +Returns the string that names the specified PACKAGE. + + +@end defun + +@defun FIND-PACKAGE (name) +Package:LISP + +Returns the specified package if it already exists; NIL otherwise. NAME may +be a string that is the name or nickname of the package. NAME may also be +a symbol, in which case the symbol's print name is used. + + +@end defun + + +@defun APROPOS-LIST (string &optional (package nil)) +Package:LISP + +Returns, as a list, all symbols whose print-names contain STRING as substring. +If PACKAGE is non-NIL, then only the specified package is searched. + + +@end defun diff --git a/info/system.texi b/info/system.texi new file mode 100755 index 0000000..06989ea --- /dev/null +++ b/info/system.texi @@ -0,0 +1,458 @@ + + +@node Operating System, Structures, Symbols, Top +@chapter Operating System + +@menu +* Command Line:: +* Operating System Definitions:: +@end menu + +@node Command Line, Operating System Definitions, Operating System, Operating System +@section Command Line + +The variable si::*command-args* is set to the list of strings passed +in when gcl is invoked. + +Various flags are understood. +@vtable @code +@item -eval +Call read and then eval on the command argument following @code{-eval} +@item -load +Load the file whose pathname is specified after @code{-load}. +@item -f +Replace si::*command-args* by the the list starting after @code{-f}. +Open the file following @code{-f} for input, skip the first line, and then +read and eval the rest of the forms in the file. This can be used +as with the shells to write small shell programs: +@example +#!/usr/local/bin/gcl.exe -f +(format t "hello world ~a~%" (nth 1 si::*command-args*)) +@end example +The value si::*command-args* will have the appropriate value. +Thus if the above 2 line file is made executable and called @file{foo} +then +@example +tutorial% foo billy +hello world billy +@end example +@noindent +NOTE: On many systems (eg SunOs) the first line of an executable script file +such as: +@example +#!/usr/local/bin/gcl.exe -f +@end example +only reads the first 32 characters! So if your pathname where the executable +together with the '-f' amount to more than 32 characters the file will not +be recognized. Also the executable must be the actual large binary file, +[or a link to it], +and not just a @code{/bin/sh} script. In latter case the +@code{/bin/sh} interpreter would get invoked on the file. + +Alternately one could invoke the file @file{foo} without making it +executable: +@example +tutorial% gcl -f foo "from bill" +hello world from bill +@end example + +Finally perhaps the best way (why do we save the best for last.. +I guess because we only figure it out after all the others..) +The following file @file{myhello} has 4 lines: +@example +#!/bin/sh +#| Lisp will skip the next 2 lines on reading +exec gcl -f "$0" $@ +|# +(format t "hello world ~a~%" (nth 1 si::*command-args*)) +@end example + +@example +marie% chmod a+x myhello +marie% myhello bill +hello world bill +@end example + +The advantage of this method is that @file{gcl} can itself +be a shell script, which sets up environment and +so on. Also the normal path will be searched to find @file{gcl} +The disadvantage is that this would cause 2 invocations of @file{sh} +and one invocation of @file{gcl}. The plan using @file{gcl.exe} +bypasses the @file{sh} entirely. Inded invoking @file{gcl.exe} to +print @file{hello world} is faster on most systems than a similar +@file{csh} or @file{bash} script, but slightly slower than the old +@file{sh}. + + +@item -batch +Do not enter the command print loop. Useful if the other command line +arguments do something. Do not print the License and acknowledgement +information. Note if your program does print any License information, +it must print the GCL header information also. +@item -dir +Directory where the executable binary that is running is located. +Needed by save and friends. This gets set as si::*system-directory* +@item -libdir +@example + -libdir @file{/d/wfs/gcl-2.0/} +@end example +would mean that the files like gcl-tk/tk.o would be found by +concatting the path to the libdir path, ie in +@example +@file{/d/wfs/gcl-2.0/gcl-tk/tk.o} +@end example +@item -compile +Invoke the compiler on the filename following @code{-compile}. +Other flags affect compilation. +@item -o-file +If nil follows @code{-o-file} then do not produce an @code{.o} file. +@item -c-file +If @code{-c-file} is specified, leave the intermediate @code{.c} file there. +@item -h-file +If @code{-h-file} is specified, leave the intermediate @code{.h} file there. +@item -data-file +If @code{-data-file} is specified, leave the intermediate @code{.data} file there. +@item -system-p +If @code{-system-p} is specified then invoke @code{compile-file} with the +@code{:system-p t} keyword argument, meaning that the C init function +will bear a name based on the name of the file, so that it may be invoked +by name by C code. +@end vtable + +@node Operating System Definitions, , Command Line, Operating System +@section Operating System Definitions + +@defun GET-DECODED-TIME () +Package:LISP + +Returns the current time in decoded time format. Returns nine values: second, +minute, hour, date, month, year, day-of-week, daylight-saving-time-p, and +time-zone. + + +@end defun + +@defun HOST-NAMESTRING (pathname) +Package:LISP + +Returns the host part of PATHNAME as a string. + + +@end defun + +@defun RENAME-FILE (file new-name) +Package:LISP + +Renames the file FILE to NEW-NAME. FILE may be a string, a pathname, or +a stream. + + +@end defun + +@defun FILE-AUTHOR (file) +Package:LISP + +Returns the author name of the specified file, as a string. +FILE may be a string or a stream + + +@end defun + +@defun PATHNAME-HOST (pathname) +Package:LISP + +Returns the host slot of PATHNAME. + + +@end defun + +@defun FILE-POSITION (file-stream &optional position) +Package:LISP + +Sets the file pointer of the specified file to POSITION, if POSITION is given. +Otherwise, returns the current file position of the specified file. + + +@end defun + +@defun DECODE-UNIVERSAL-TIME (universal-time &optional (timezone -9)) +Package:LISP + +Converts UNIVERSAL-TIME into a decoded time at the TIMEZONE. +Returns nine values: second, minute, hour, date, month (1 - 12), year, +day-of-week (0 - 6), daylight-saving-time-p, and time-zone. +TIMEZONE in GCL defaults to 6, the time zone of Austin, Texas. + + +@end defun + +@defun USER-HOMEDIR-PATHNAME (&optional host) +Package:LISP + +Returns the home directory of the logged in user as a pathname. HOST +is ignored. + + +@end defun + + +@defvar *MODULES* +Package:LISP +A list of names of the modules that have been loaded into GCL. + + +@end defvar + +@defun SHORT-SITE-NAME () +Package:LISP + +Returns a string that identifies the physical location of the current GCL. + + +@end defun + +@defun DIRECTORY (name) +Package:LISP + +Returns a list of files that match NAME. NAME may be a string, a pathname, +or a file stream. + + +@end defun + +@defun SOFTWARE-VERSION () +Package:LISP + +Returns a string that identifies the software version of the software +under which GCL is currently running. + + +@end defun + +@defvr {Constant} INTERNAL-TIME-UNITS-PER-SECOND +Package:LISP +The number of internal time units that fit into a second. + + +@end defvr + +@defun ENOUGH-NAMESTRING (pathname &optional (defaults *default-pathname-defaults*)) +Package:LISP + +Returns a string which uniquely identifies PATHNAME with respect to +DEFAULTS. + + +@end defun + +@defun REQUIRE (module-name &optional (pathname)) +Package:LISP + +If the specified module is not present, then loads the appropriate file(s). +PATHNAME may be a single pathname or it may be a list of pathnames. + + +@end defun + +@defun ENCODE-UNIVERSAL-TIME (second minute hour date month year &optional (timezone )) +Package:LISP + +Does the inverse operation of DECODE-UNIVERSAL-TIME. + + +@end defun + +@defun LISP-IMPLEMENTATION-VERSION () +Package:LISP + +Returns a string that tells you when the current GCL implementation is +brought up. + + +@end defun + +@defun MACHINE-INSTANCE () +Package:LISP + +Returns a string that identifies the machine instance of the machine +on which GCL is currently running. + + +@end defun + +@defun ROOM (&optional (x t)) +Package:LISP + +Displays information about storage allocation in the following format. + +@itemize @asis{} + +@item +for each type class +@itemize @asis{} +@item +the number of pages so-far allocated for the type class +@item +the maximum number of pages for the type class +@item +the percentage of used cells to cells so-far allocated +@item +the number of times the garbage collector has been called to + collect cells of the type class +@item +the implementation types that belongs to the type class +@end itemize +@item +the number of pages actually allocated for contiguous blocks +@item +the maximum number of pages for contiguous blocks +@item +the number of times the garbage collector has been called to collect + contiguous blocks +@item +the number of pages in the hole +@item +the maximum number of pages for relocatable blocks +@item +the number of times the garbage collector has been called to collect + relocatable blocks +@item +the total number of pages allocated for cells +@item +the total number of pages allocated +@item +the number of available pages +@item +the number of pages GCL can use. + +The number of times the garbage collector has been called is not shown, +if the number is zero. The optional X is ignored. +@end itemize + +@end defun + +@defun GET-UNIVERSAL-TIME () +Package:LISP + +Returns the current time as a single integer in universal time format. + + +@end defun + +@defun GET-INTERNAL-RUN-TIME () +Package:LISP + +Returns the run time in the internal time format. This is useful for +finding CPU usage. If the operating system allows, a second value +containing CPU usage of child processes is returned. + + +@end defun + +@defvar *DEFAULT-PATHNAME-DEFAULTS* +Package:LISP +The default pathname-defaults pathname. + + +@end defvar + +@defun LONG-SITE-NAME () +Package:LISP + +Returns a string that identifies the physical location of the current GCL. + + +@end defun + +@defun DELETE-FILE (file) +Package:LISP + Deletes FILE. + + +@end defun + +@defun GET-INTERNAL-REAL-TIME () +Package:LISP + +Returns the real time in the internal time format. This is useful for +finding elapsed time. + + +@end defun + +@defun MACHINE-TYPE () +Package:LISP + +Returns a string that identifies the machine type of the machine +on which GCL is currently running. + + +@end defun + +@deffn {Macro} TIME +Package:LISP + +Syntax: +@example +(time form) +@end example + +Evaluates FORM and outputs timing statistics on *TRACE-OUTPUT*. + + +@end deffn + +@defun SOFTWARE-TYPE () +Package:LISP + +Returns a string that identifies the software type of the software +under which GCL is currently running. + + +@end defun + +@defun LISP-IMPLEMENTATION-TYPE () +Package:LISP + +Returns a string that tells you that you are using a version of GCL. + + +@end defun + +@defun SLEEP (n) +Package:LISP + +This function causes execution to be suspended for N seconds. N may +be any non-negative, non-complex number. + + +@end defun + +@defun BREAK-ON-FLOATING-POINT-EXCEPTIONS (&key division-by-zero + floating-point-invalid-operation + floating-point-overflow + floating-point-underflow + floating-point-inexact) +Package:SI + +Break on the specified IEEE floating point error conditions. With no +arguments, report the exceptions currently trapped. Disable the break +by setting the key to nil, e.g. + + > (break-on-floaing-point-exceptions :division-by-zero t) + (DIVISION-BY-ZERO) + + > (break-on-floaing-point-exceptions) + (DIVISION-BY-ZERO) + + > (break-on-floaing-point-exceptions :division-by-zero nil) + NIL + +On some of the most common platforms, the offending instruction will be +disassembled, and the register arguments looked up in the saved context +and reported in as operands. Within the error handler, addresses may be +disassembled, and other registers inspected, using the functions defined +in gcl_fpe.lsp. + +@end defun + diff --git a/info/type.texi b/info/type.texi new file mode 100755 index 0000000..2602f99 --- /dev/null +++ b/info/type.texi @@ -0,0 +1,119 @@ +@node Type, GCL Specific, Doc, Top +@chapter Type + +@defun COERCE (x type) +Package:LISP + +Coerces X to an object of the type TYPE. + + +@end defun + +@defun TYPE-OF (x) +Package:LISP + +Returns the type of X. + + +@end defun + +@defun CONSTANTP (symbol) +Package:LISP + +Returns T if the variable named by SYMBOL is a constant; NIL otherwise. + + +@end defun + +@defun TYPEP (x type) +Package:LISP + +Returns T if X is of the type TYPE; NIL otherwise. + + +@end defun + +@defun COMMONP (x) +Package:LISP + +Returns T if X is a Common Lisp object; NIL otherwise. + + +@end defun + +@defun SUBTYPEP (type1 type2) +Package:LISP + +Returns T if TYPE1 is a subtype of TYPE2; NIL otherwise. If it could not +determine, then returns NIL as the second value. Otherwise, the second value +is T. + + +@end defun + +@deffn {Macro} CHECK-TYPE +Package:LISP + +Syntax: +@example +(check-type place typespec [string]) +@end example + +Signals an error, if the contents of PLACE are not of the specified type. + + +@end deffn + +@deffn {Macro} ASSERT +Package:LISP + +Syntax: +@example +(assert test-form [(@{place@}*) [string @{arg@}*]]) +@end example + +Signals an error if the value of TEST-FORM is NIL. STRING is an format string +used as the error message. ARGs are arguments to the format string. + + +@end deffn + +@deffn {Macro} DEFTYPE +Package:LISP + +Syntax: +@example +(deftype name lambda-list @{decl | doc@}* @{form@}*) +@end example + +Defines a new type-specifier abbreviation in terms of an 'expansion' function + (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 GCL encounters a +type specifier (NAME arg1 ... argn), it calls the expansion function with +the arguments arg1 ... argn, and uses the returned value instead of the +original type specifier. When the symbol NAME is used as a type specifier, +the expansion function is called with no argument. The doc-string DOC, if +supplied, is saved as the TYPE doc of NAME, and is retrieved by +(documentation 'NAME 'type). + + +@end deffn + +@defvr {Declaration} DYNAMIC-EXTENT +Package:LISP +Declaration to allow locals to be cons'd on the C stack. +For example +(defun foo (&rest l) (declare (:dynamic-extent l)) ...) +will cause l to be a list formed on the C stack of the foo function +frame. +Of course passing L out as a value of foo will cause havoc. +(setq x (make-list n)) +(setq x (cons a b)) +(setq x (list a b c ..)) +also are handled on the stack, for dynamic-extent x. + + + +@end defvr diff --git a/info/user-interface.texi b/info/user-interface.texi new file mode 100755 index 0000000..0224253 --- /dev/null +++ b/info/user-interface.texi @@ -0,0 +1,383 @@ +@node User Interface, Doc, Iteration and Tests, Top +@chapter User Interface + +@defvr {Special Variable} - +Package:LISP +Holds the top-level form that GCL is currently evaluating. + + +@end defvr + +@defun - (number &rest more-numbers) +Package:LISP + +Subtracts the second and all subsequent NUMBERs from the first NUMBER. +With one arg, negates it. + + +@end defun + +@deffn {Macro} UNTRACE +Package:LISP + +Syntax: +@example +(untrace @{function-name@}*) +@end example + +Removes tracing from the specified functions. With no FUNCTION-NAMEs, +untraces all functions. + + +@end deffn + +@defvar *** +Package:LISP +Gets the previous value of ** when GCL evaluates a top-level form. + + +@end defvar + +@defun MAKE-STRING-INPUT-STREAM (string &optional (start 0) (end (length string))) +Package:LISP + +Returns an input stream which will supply the characters of String between +Start and End in order. + + +@end defun + +@deffn {Macro} STEP +Package:LISP + +Syntax: +@example +(step form) +@end example + +Evaluates FORM in the single-step mode and returns the value. + + +@end deffn + +@defvar *BREAK-ENABLE* +Package:LISP +GCL specific: When an error occurrs, control enters to the break loop only +if the value of this variable is non-NIL. + + +@end defvar + +@defvr {Special Variable} / +Package:LISP +Holds a list of the values of the last top-level form. + + +@end defvr + +@defun DESCRIBE (x) +Package:LISP + +Prints a description of the object X. + + +@end defun + +@defun ED (&optional x) +Package:LISP + +Invokes the editor. The action depends on the version of GCL. + + +@end defun + +@defvar *DEBUG-IO* +Package:LISP +Holds the I/O stream used by the GCL debugger. + + +@end defvar + +@defvar *BREAK-ON-WARNINGS* +Package:LISP +When the function WARN is called, control enters to the break loop only +if the value of this varialbe is non-NIL. + + +@end defvar + +@defun CERROR (continue-format-string error-format-string &rest args) +Package:LISP + +Signals a correctable error. + + +@end defun + +@defvar ** +Package:LISP +Gets the previous value of * when GCL evaluates a top-level form. + + +@end defvar + +@defvr {Special Variable} +++ +Package:LISP +Gets the previous value of ++ when GCL evaluates a top-level form. + + +@end defvr + +@defun INSPECT (x) +Package:LISP + +Shows the information about the object X in an interactive manner + + +@end defun + +@defvr {Special Variable} // +Package:LISP +Gets the previous value of / when GCL evaluates a top-level form. + + +@end defvr + +@defvar *TRACE-OUTPUT* +Package:LISP +The trace output stream. + + +@end defvar + +@defvr {Special Variable} ++ +Package:LISP +Gets the previous value of + when GCL evaluates a top-level form. + + +@end defvr + +@defvar *ERROR-OUTPUT* +Package:LISP +Holds the output stream for error messages. + + +@end defvar + +@defun DRIBBLE (&optional pathname) +Package:LISP + +If PATHNAME is given, begins to record the interaction to the specified file. +If PATHNAME is not given, ends the recording. + + +@end defun + +@defvar * +Package:LISP +Holds the value of the last top-level form. + + +@end defvar + +@defvr {Special Variable} /// +Package:LISP +Gets the previous value of // when GCL evaluates a top-level form. + + +@end defvr + +@defun WARN (format-string &rest args) +Package:LISP + +Formats FORMAT-STRING and ARGs to *ERROR-OUTPUT* as a warning message. + + +@end defun + +@defun BREAK (&optional (format-string nil) &rest args) +Package:LISP + +Enters a break loop. If FORMAT-STRING is non-NIL, formats FORMAT-STRING +and ARGS to *ERROR-OUTPUT* before entering a break loop. +Typing :HELP at the break loop will list the break-loop commands. + + +@end defun + +@defvr {Special Variable} + +Package:LISP +Holds the last top-level form. + + +@end defvr + +@deffn {Macro} TRACE +Package:LISP + +Syntax: +@example +(trace @{function-name@}*) +@end example + +Traces the specified functions. With no FUNCTION-NAMEs, returns a list of +functions currently being traced. + +Additional Keywords are allowed in GCL with the +syntax (trace @{fn | (fn @{:kw form@}*)@}*) + +For each FN naming a function, traces that function. Each :KW should +be one of the ones listed below, and FORM should have the +corresponding form. No :KW may be given more than once for the same +FN. Returns a list of all FNs now traced which weren't already +traced. + + +EXAMPLE (Try this with your favorite factorial function FACT): + +@example +;; print entry args and exit values + +(trace FACT) + +;; Break coming out of FACT if the value is bigger than 1000. + +(trace (fact :exit + (progn + (if (> (car values) 1000)(break "big result")) + (car values)))) + +;; Hairy example: + +;;make arglist available without the si:: prefix +(import 'si::arglist) + +(trace (fact + :DECLARATIONS + ((in-string "Here comes input: ") + (out-string "Here comes output: ") + all-values + (silly (+ 3 4))) + :COND + (equal (rem (car arglist) 2) 0) + :ENTRY + (progn + (cond + ((equal (car arglist) 8) + (princ "Entering FACT on input 8!! ") + (setq out-string "Here comes output from inside (FACT 8): ")) + (t + (princ in-string))) + (car arglist)) + :EXIT + (progn + (setq all-values (cons (car values) all-values)) + (princ out-string) + (when (equal (car arglist) 8) + ;; reset out-string + (setq out-string "Here comes output: ")) + (cons 'fact values)) + :ENTRYCOND + (not (= (car arglist) 6)) + :EXITCOND + (not (= (car values) (* 6 (car arglist)))) + :DEPTH + 5)) +@end example + +Syntax is @code{:keyword} @i{form1} @code{:keyword} @i{form2} ... + +@table @code +@item :declarations +@example +DEFAULT: NIL +@end example + +FORM is ((var1 form1 )(var2 form2 )...), where +the var_i are symbols distinct from each other and from +all symbols which are similarly declared for currently +traced functions. Each form is evaluated immediately. +Upon any invocation of a traced function when not already +inside a traced function call, each var is bound to +that value of form . + +@item :COND +@example +DEFAULT: T +@end example + +Here, FORM is any Lisp form to be evaluated (by EVAL) +upon entering a call of FN, in the environment where si::ARGLIST +is bound to the current list of arguments of FN. Note that +even if the evaluation of FORM changes the value of SI::ARGLIST +(e.g. by evaluation of (SETQ si::ARGLIST ...)), the list of +arguments passed to FN is unchanged. Users may alter args passed +by destructively modifying the list structure of SI::ARGLIST +however. The call is traced +(thus invoking the :ENTRYCOND and :EXITCOND forms, at least) +if and only if FORM does not evaluate to NIL. + +@item :ENTRYCOND +@example +DEFAULT: T +@end example + +This is evaluated (by EVAL) if the :COND form evaluates to +non-NIL, both in an environment where SI::ARGLIST is bound to the +current list of arguments of FN. If non-NIL, the :ENTRY form +is then evaluated and printed with the trace "prompt". + +@item :ENTRY +@example +DEFAULT: (CONS (QUOTE x) SI::ARGLIST), +@end example + +where x is the symbol we call FN +If the :COND and :ENTRYCOND forms evaluate to non-NIL, +then the trace "prompt" is printed and then this FORM is +evaluated (by EVAL) in an environment where SI::ARGLIST is bound +to the current list of arguments of FN. The result is then +printed. + +@item :EXITCOND +@example +DEFAULT: T +@end example + +This is evaluated (by EVAL) in the environment described +below for the :EXIT form. The :EXIT form is then evaluated +and printed with the "prompt" if and only if the result here +is non-NIL. + +@item :EXIT +@example +DEFAULT: (CONS (QUOTE x) VALUES), +@end example + +where x is the symbol we call FN +Upon exit from tracing a given call, this FORM is +evaluated (after the appropriate trace "prompt" is printed), +using EVAL in an environment where SI::ARGLIST is bound to the +current list of arguments of FN and VALUES is bound to the +list of values returned by FN (recalling that Common Lisp +functions may return multiple values). + +@item :DEPTH +@example +DEFAULT: No depth limit +@end example + +FORM is simply a positive integer specifying the maximum +nesting of traced calls of FN, i.e. of calls of FN in which +the :COND form evaluated to non-NIL. For calls of FN in +which this limit is exceeded, even the :COND form is not +evaluated, and the call is not traced. + +@end table + +@end deffn + + + + + diff --git a/info/widgets.texi b/info/widgets.texi new file mode 100755 index 0000000..21a2e89 --- /dev/null +++ b/info/widgets.texi @@ -0,0 +1,5033 @@ +@c Copyright (c) 1994 William Schelter. + + +@c Copyright (c) 1990 The Regents of the University of California. +@c All rights reserved. +@c +@c Permission is hereby granted, without written agreement and without +@c license or royalty fees, to use, copy, modify, and distribute this +@c documentation for any purpose, provided that the above copyright +@c notice and the following two paragraphs appear in all copies. +@c +@c IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY +@c FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES +@c ARISING OUT OF THE USE OF THIS DOCUMENTATION, EVEN IF THE UNIVERSITY OF +@c CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +@c +@c THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, +@c INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY +@c AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS +@c ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO +@c PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + +@node Widgets, Control, General, Top +@chapter Widgets + +@menu +* button:: +* listbox:: +* scale:: +* canvas:: +* menu:: +* scrollbar:: +* checkbutton:: +* menubutton:: +* text:: +* entry:: +* message:: +* frame:: +* label:: +* radiobutton:: +* toplevel:: +@end menu + +@node button, listbox, Widgets, Widgets +@section button +@c @cartouche + +button \- Create and manipulate button widgets +@unnumberedsubsec Synopsis +@b{button}@i{ }@i{pathName }@r{?}@i{options}? +@unnumberedsubsec Standard Options + + +@example +activeBackground bitmap font relief +activeForeground borderWidth foreground text +anchor cursor padX textVariable +background disabledForeground padY +@end example + + +@xref{options}, for more information. +@unnumberedsubsec Arguments for Button + + +@table @asis +@item @code{@b{:command}} +@flushright +Name=@code{"@b{command}@r{"} Class=@code{"}@b{Command}"} +@end flushright +@sp 1 + +Specifies a Tcl command to associate with the button. This command +is typically invoked when mouse button 1 is released over the button +window. +@end table + + +@table @asis +@item @code{@b{:height}} +@flushright +Name=@code{"@b{height}@r{"} Class=@code{"}@b{Height}"} +@end flushright +@sp 1 + +Specifies a desired height for the button. +If a bitmap is being displayed in the button then the value is in +screen units (i.e. any of the forms acceptable to @b{Tk_GetPixels}); +for text it is in lines of text. +If this option isn't specified, the button's desired height is computed +from the size of the bitmap or text being displayed in it. +@end table + + +@table @asis +@item @code{@b{:state}} +@flushright +Name=@code{"@b{state}@r{"} Class=@code{"}@b{State}"} +@end flushright +@sp 1 + +Specifies one of three states for the button: @b{normal}@r{, }@b{active}, +or @b{disabled}. In normal state the button is displayed using the +@b{foreground}@r{ and }@b{background} options. The active state is +typically used when the pointer is over the button. In active state +the button is displayed using the @b{activeForeground} and +@b{activeBackground} options. Disabled state means that the button +is insensitive: it doesn't activate and doesn't respond to mouse +button presses. In this state the @b{disabledForeground} and +@b{background} options determine how the button is displayed. +@end table + + +@table @asis +@item @code{@b{:width}} +@flushright +Name=@code{"@b{width}@r{"} Class=@code{"}@b{Width}"} +@end flushright +@sp 1 + +Specifies a desired width for the button. +If a bitmap is being displayed in the button then the value is in +screen units (i.e. any of the forms acceptable to @b{Tk_GetPixels}); +for text it is in characters. +If this option isn't specified, the button's desired width is computed +from the size of the bitmap or text being displayed in it. +@end table +@c @end cartouche + +@unnumberedsubsec Description + +The @b{button} command creates a new window (given by the +@i{pathName} argument) and makes it into a button widget. +Additional +options, described above, may be specified on the command line +or in the option database +to configure aspects of the button such as its colors, font, +text, and initial relief. The @b{button} command returns its +@i{pathName} argument. At the time this command is invoked, +there must not exist a window named @i{pathName}, but +@i{pathName}'s parent must exist. + +A button is a widget +that displays a textual string or bitmap. +It can display itself in either of three different ways, according +to +the @b{state} option; +it can be made to appear raised, sunken, or flat; +and it can be made to flash. When a user invokes the +button (by pressing mouse button 1 with the cursor over the +button), then the Tcl command specified in the @b{:command} +option is invoked. + +@unnumberedsubsec A Button Widget's Arguments + +The @b{button} command creates a new Tcl command whose +name is @i{pathName}. This +command may be used to invoke various +operations on the widget. It has the following general form: + +@example +@i{pathName option }@r{?}@i{arg arg ...}? +@end example + +@i{Option}@r{ and the }@i{arg}s +determine the exact behavior of the command. The following +commands are possible for button widgets: + +@table @asis +@item @i{pathName }@b{:activate} +Change the button's state to @b{active} and redisplay the button +using its active foreground and background colors instead of normal +colors. +This command is ignored if the button's state is @b{disabled}. +This command is obsolete and will eventually be removed; +use ``@i{pathName }@b{:configure :state active}'' instead. +@item @i{pathName }@b{:configure}@r{ ?}@i{option}@r{? ?}@i{value option value ...}? +Query or modify the configuration options of the widget. +If no @i{option} is specified, returns a list describing all of +the available options for @i{pathName}@r{ (see }@b{Tk_ConfigureInfo} for +information on the format of this list). If @i{option} is specified +with no @i{value}, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no @i{option} is specified). If +one or more @i{option:value} pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +@i{Option}@r{ may have any of the values accepted by the }@b{button} +command. +@item @i{pathName }@b{:deactivate} +Change the button's state to @b{normal} and redisplay the button +using its normal foreground and background colors. +This command is ignored if the button's state is @b{disabled}. +This command is obsolete and will eventually be removed; +use ``@i{pathName }@b{:configure :state normal}'' instead. +@item @i{pathName }@b{:flash} +Flash the button. This is accomplished by redisplaying the button +several times, alternating between active and normal colors. At +the end of the flash the button is left in the same normal/active +state as when the command was invoked. +This command is ignored if the button's state is @b{disabled}. +@item @i{pathName }@b{:invoke} +Invoke the Tcl command associated with the button, if there is one. +The return value is the return value from the Tcl command, or an +empty string if there is no command associated with the button. +This command is ignored if the button's state is @b{disabled}. + +@end table +@unnumberedsubsec "Default Bindings" + +Tk automatically creates class bindings for buttons that give them +the following default behavior: +@itemize @asis{} +@item +[1] +The button activates whenever the mouse passes over it and deactivates +whenever the mouse leaves the button. +@item +[2] +The button's relief is changed to sunken whenever mouse button 1 is +pressed over the button, and the relief is restored to its original +value when button 1 is later released. +@item +[3] +If mouse button 1 is pressed over the button and later released over +the button, the button is invoked. However, if the mouse is not +over the button when button 1 is released, then no invocation occurs. +@end itemize + +If the button's state is @b{disabled} then none of the above +actions occur: the button is completely non-responsive. + +The behavior of buttons can be changed by defining new bindings for +individual widgets or by redefining the class bindings. + +@unnumberedsubsec Keywords +button, widget +@node listbox, scale, button, Widgets +@section listbox +@c @cartouche + +listbox \- Create and manipulate listbox widgets +@unnumberedsubsec Synopsis +@b{listbox}@i{ }@i{pathName }@r{?}@i{options}? +@unnumberedsubsec Standard Options + + +@example +background foreground selectBackground xScrollCommand +borderWidth font selectBorderWidth yScrollCommand +cursor geometry selectForeground +exportSelection relief setGrid +@end example + + +@xref{options}, for more information. +@unnumberedsubsec Arguments for Listbox + + +None. +@c @end cartouche + +@unnumberedsubsec Description + +The @b{listbox} command creates a new window (given by the +@i{pathName} argument) and makes it into a listbox widget. +Additional +options, described above, may be specified on the command line +or in the option database +to configure aspects of the listbox such as its colors, font, +text, and relief. The @b{listbox} command returns its +@i{pathName} argument. At the time this command is invoked, +there must not exist a window named @i{pathName}, but +@i{pathName}'s parent must exist. + +A listbox is a widget that displays a list of strings, one per line. +When first created, a new listbox has no elements in its list. +Elements may be added or deleted using widget commands described +below. In addition, one or more elements may be selected as described +below. +If a listbox is exporting its selection (see @b{exportSelection} +option), then it will observe the standard X11 protocols +for handling the selection; listbox selections are available +as type @b{STRING}, consisting of a Tcl list with one entry +for each selected element. + +For large lists only a subset of the list elements will be +displayed in the listbox window at once; commands described below +may be used to change the view in the window. Listboxes allow +scrolling in both directions using the standard @b{xScrollCommand} +and @b{yScrollCommand} options. +They also support scanning, as described below. + +@unnumberedsubsec A Listbox's Arguments + +The @b{listbox} command creates a new Tcl command whose +name is @i{pathName}. This +command may be used to invoke various +operations on the widget. It has the following general form: + +@example +@i{pathName option }@r{?}@i{arg arg ...}? +@end example + +@i{Option}@r{ and the }@i{arg}s +determine the exact behavior of the command. The following +commands are possible for listbox widgets: + +@table @asis +@item @i{pathName }@b{:configure}@r{ ?}@i{option}@r{? ?}@i{value option value ...}? +Query or modify the configuration options of the widget. +If no @i{option} is specified, returns a list describing all of +the available options for @i{pathName}@r{ (see }@b{Tk_ConfigureInfo} for +information on the format of this list). If @i{option} is specified +with no @i{value}, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no @i{option} is specified). If +one or more @i{option:value} pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +@i{Option}@r{ may have any of the values accepted by the }@b{listbox} +command. +@item @i{pathName }@b{:curselection} +Returns a list containing the indices of +all of the elements in the listbox that are currently selected. +If there are no elements selected in the listbox then an empty +string is returned. +@item @i{pathName }@b{:delete }@i{first }@r{?}@i{last}? +Delete one or more elements of the listbox. @i{First}@r{ and }@i{last} +give the integer indices of the first and last elements in the range +to be deleted. If @i{last} isn't specified it defaults to +@i{first}, i.e. a single element is deleted. An index of +@b{0} corresponds to the first element in the listbox. Either +@i{first}@r{ or }@i{last}@r{ may be specified as }@b{end}, in which +case it refers to the last element of the listbox. This command +returns an empty string +@item @i{pathName }@b{:get }@i{index} +Return the contents of the listbox element indicated by @i{index}. +@i{Index} must be a non-negative integer (0 corresponds to +the first element in the listbox), or it may also be specified as +@b{end} to indicate the last element in the listbox. +@item @i{pathName }@b{:insert }@i{index }@r{?}@i{element element ...}? +Insert zero or more new elements in the list just before the +element given by @i{index}@r{. If }@i{index} is specified as +@b{end} then the new elements are added to the end of the +list. Returns an empty string. +@item @i{pathName }@b{:nearest }@i{y} +Given a y-coordinate within the listbox window, this command returns +the index of the (visible) listbox element nearest to that y-coordinate. +@item @i{pathName }@b{:scan}@r{ }@i{option args} +This command is used to implement scanning on listboxes. It has +two forms, depending on @i{option}: +@table @asis +@item @i{pathName }@b{:scan :mark }@i{x y} +Records @i{x}@r{ and }@i{y} and the current view in the listbox +window; used in conjunction with later @b{scan dragto} commands. +Typically this command is associated with a mouse button press in +the widget. It returns an empty string. +@item @i{pathName }@b{:scan :dragto }@i{x y}. +This command computes the difference between its @i{x}@r{ and }@i{y} +arguments and the @i{x}@r{ and }@i{y} arguments to the last +@b{scan mark} command for the widget. +It then adjusts the view by 10 times the +difference in coordinates. This command is typically associated +with mouse motion events in the widget, to produce the effect of +dragging the list at high speed through the window. The return +value is an empty string. +@end table +@item @i{pathName }@b{:select }@i{option arg} +This command is used to adjust the selection within a listbox. It +has several forms, depending on @i{option}. In all of the forms +the index @b{end} refers to the last element in the listbox. +@table @asis +@item @i{pathName }@b{:select :adjust }@i{index} +Locate the end of the selection nearest to the element given by +@i{index}@r{, and adjust that end of the selection to be at }@i{index} +(i.e including but not going beyond @i{index}). The other +end of the selection is made the anchor point for future +@b{select to} commands. If the selection +isn't currently in the listbox, then this command is identical to +the @b{select from} widget command. +Returns an empty string. +@item @i{pathName }@b{:select :clear} +If the selection is in this listbox then it is cleared so that +none of the listbox's elements are selected anymore. +@item @i{pathName }@b{:select :from }@i{index} +Set the selection to consist of element @i{index}, and make +@i{index}@r{ the anchor point for future }@b{select to} widget +commands. Returns an empty string. +@item @i{pathName }@b{:select :to }@i{index} +Set the selection to consist of the elements from the anchor +point to element @i{index}, inclusive. The anchor point is +determined by the most recent @b{select from}@r{ or }@b{select adjust} +command in this widget. If the selection isn't in this widget, +this command is identical to @b{select from}. +Returns an empty string. +@end table + +@item @i{pathName }@b{:size} +Returns a decimal string indicating the total number of elements +in the listbox. +@item @i{pathName }@b{:xview }@i{index} +Adjust the view in the listbox so that character position @i{index} +is displayed at the left edge of the widget. +Returns an empty string. +@item @i{pathName }@b{:yview }@i{index} +Adjust the view in the listbox so that element @i{index} is +displayed at the top of the widget. +If @i{index}@r{ is specified as }@b{end} it indicates the last +element of the listbox. Returns an empty string. + +@end table +@unnumberedsubsec "Default Bindings" + +Tk automatically creates class bindings for listboxes that give them +the following default behavior: +@itemize @asis{} +@item +[1] +When button 1 is pressed over a listbox, the element underneath the +mouse cursor is selected. The mouse can be dragged to select a +range of elements. +@item +[2] +The ends of the selection can be adjusted by dragging with mouse +button 1 while the shift key is down; this will adjust the end +of the selection that was nearest to the mouse cursor when button +1 was pressed. +@item +[3] +The view in the listbox can be adjusted by dragging with mouse button 2. +@end itemize + +The behavior of listboxes can be changed by defining new bindings for +individual widgets or by redefining the class bindings. +In addition, the procedure @b{tk_listboxSingleSelect} may be +invoked to change listbox behavior so that only a single element +may be selected at once. + +@unnumberedsubsec Keywords +listbox, widget +@node scale, canvas, listbox, Widgets +@section scale +@c @cartouche + +scale \- Create and manipulate scale widgets +@unnumberedsubsec Synopsis +@b{scale}@i{ }@i{pathName }@r{?}@i{options}? +@unnumberedsubsec Standard Options + + +@example +activeForeground borderWidth font orient +background cursor foreground relief +@end example + + +@xref{options}, for more information. +@unnumberedsubsec Arguments for Scale + + +@table @asis +@item @code{@b{:command}} +@flushright +Name=@code{"@b{command}@r{"} Class=@code{"}@b{Command}"} +@end flushright +@sp 1 + +Specifies the prefix of a Tcl command to invoke whenever the value of +the scale is changed interactively. The actual command consists +of this option followed by +a space and a number. The number indicates the new value of the +scale. +@end table + + +@table @asis +@item @code{@b{:from}} +@flushright +Name=@code{"@b{from}@r{"} Class=@code{"}@b{From}"} +@end flushright +@sp 1 + +Specifies the value corresponding to the left or top end of the +scale. Must be an integer. +@end table + + +@table @asis +@item @code{@b{:label}} +@flushright +Name=@code{"@b{label}@r{"} Class=@code{"}@b{Label}"} +@end flushright +@sp 1 + +Specifies a string to displayed as a label for the scale. For +vertical scales the label is displayed just to the right of the +top end of the scale. For horizontal scales the label is displayed +just above the left end of the scale. +@end table + + +@table @asis +@item @code{@b{:length}} +@flushright +Name=@code{"@b{length}@r{"} Class=@code{"}@b{Length}"} +@end flushright +@sp 1 + +Specifies the desired long dimension of the scale in screen units, +that is in any of the forms acceptable to @b{Tk_GetPixels}. +For vertical scales this is the scale's height; for horizontal scales +it is the scale's width. +@end table + + +@table @asis +@item @code{@b{:showvalue}} +@flushright +Name=@code{"@b{showValue}@r{"} Class=@code{"}@b{ShowValue}"} +@end flushright +@sp 1 + +Specifies a boolean value indicating whether or not the current +value of the scale is to be displayed. +@end table + + +@table @asis +@item @code{@b{:sliderforeground}} +@flushright +Name=@code{"@b{sliderForeground}@r{"} Class=@code{"}@b{sliderForeground}"} +@end flushright +@sp 1 + +Specifies the color to use for drawing the slider under normal conditions. +When the mouse is in the slider window then the slider's color is +determined by the @b{activeForeground} option. +@end table + + +@table @asis +@item @code{@b{:sliderlength}} +@flushright +Name=@code{"@b{sliderLength}@r{"} Class=@code{"}@b{SliderLength}"} +@end flushright +@sp 1 + +Specfies the size of the slider, measured in screen units along the slider's +long dimension. The value may be specified in any of the forms acceptable +to @b{Tk_GetPixels}. +@end table + + +@table @asis +@item @code{@b{:state}} +@flushright +Name=@code{"@b{state}@r{"} Class=@code{"}@b{State}"} +@end flushright +@sp 1 + +Specifies one of two states for the scale: @b{normal}@r{ or }@b{disabled}. +If the scale is disabled then the value may not be changed and the scale +won't activate when the mouse enters it. +@end table + + +@table @asis +@item @code{@b{:tickinterval}} +@flushright +Name=@code{"@b{tickInterval}@r{"} Class=@code{"}@b{TickInterval}"} +@end flushright +@sp 1 + +Must be an integer value. Determines the spacing between numerical +tick-marks displayed below or to the left of the slider. If specified +as 0, then no tick-marks will be displayed. +@end table + + +@table @asis +@item @code{@b{:to}} +@flushright +Name=@code{"@b{to}@r{"} Class=@code{"}@b{To}"} +@end flushright +@sp 1 + +Specifies the value corresponding to the right or bottom end of the +scale. Must be an integer. This value may be either less than or +greater than the @b{from} option. +@end table + + +@table @asis +@item @code{@b{:width}} +@flushright +Name=@code{"@b{width}@r{"} Class=@code{"}@b{Width}"} +@end flushright +@sp 1 + +Specifies the desired narrow dimension of the scale in screen units +(i.e. any of the forms acceptable to @b{Tk_GetPixels}). +For vertical scales this is the scale's width; for horizontal scales +this is the scale's height. +@end table +@c @end cartouche + +@unnumberedsubsec Description + +The @b{scale} command creates a new window (given by the +@i{pathName} argument) and makes it into a scale widget. +Additional +options, described above, may be specified on the command line +or in the option database +to configure aspects of the scale such as its colors, orientation, +and relief. The @b{scale} command returns its +@i{pathName} argument. At the time this command is invoked, +there must not exist a window named @i{pathName}, but +@i{pathName}'s parent must exist. + +A scale is a widget that displays a rectangular region and a +small @i{slider}. The rectangular region corresponds to a range +of integer values (determined by the @b{from}@r{ and }@b{to} options), +and the position of the slider selects a particular integer value. +The slider's position (and hence the scale's value) may be adjusted +by clicking or dragging with the mouse as described in the BINDINGS +section below. Whenever the scale's value is changed, a Tcl +command is invoked (using the @b{command} option) to notify +other interested widgets of the change. + +Three annotations may be displayed in a scale widget: a label +appearing at the top-left of the widget (top-right for vertical +scales), a number displayed just underneath the slider +(just to the left of the slider for vertical scales), and a collection +of numerical tick-marks just underneath the current value (just to the left of +the current value for vertical scales). Each of these three +annotations may be selectively enabled or disabled using the +configuration options. + +@unnumberedsubsec A Scale's"Argumentsommand" + +The @b{scale} command creates a new Tcl command whose +name is @i{pathName}. This +command may be used to invoke various +operations on the widget. It has the following general form: + +@example +@i{pathName option }@r{?}@i{arg arg ...}? +@end example + +@i{Option}@r{ and the }@i{arg}s +determine the exact behavior of the command. The following +commands are possible for scale widgets: + +@table @asis +@item @i{pathName }@b{:configure}@r{ ?}@i{option}@r{? ?}@i{value option value ...}? +Query or modify the configuration options of the widget. +If no @i{option} is specified, returns a list describing all of +the available options for @i{pathName}@r{ (see }@b{Tk_ConfigureInfo} for +information on the format of this list). If @i{option} is specified +with no @i{value}, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no @i{option} is specified). If +one or more @i{option:value} pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +@i{Option}@r{ may have any of the values accepted by the }@b{scale} +command. +@item @i{pathName }@b{:get} +Returns a decimal string giving the current value of the scale. +@item @i{pathName }@b{:set}@r{ }@i{value} +This command is invoked to change the current value of the scale, +and hence the position at which the slider is displayed. @i{Value} +gives the new value for the scale. + +@end table +@unnumberedsubsec Bindings + +When a new scale is created, it is given the following initial +behavior by default: + +@table @asis +@item @b{} +Change the slider display to use @b{activeForeground} instead of +@b{sliderForeground}. +@item @b{} +Reset the slider display to use @b{sliderForeground} instead of +@b{activeForeground}. +@item @b{} +Change the slider display so that the slider appears sunken rather +than raised. Move the slider (and adjust the scale's value) +to correspond to the current mouse position. +@item @b{} +Move the slider (and adjust the scale's value) to correspond to +the current mouse position. +@item @b{} +Reset the slider display so that the slider appears raised again. + +@end table +@unnumberedsubsec Keywords +scale, widget +@node canvas, menu, scale, Widgets +@section canvas +@c @cartouche + +canvas \- Create and manipulate canvas widgets +@unnumberedsubsec Synopsis +@b{canvas}@i{ }@i{pathName }@r{?}@i{options}? +@unnumberedsubsec Standard Options + + +@example +background insertBorderWidth relief xScrollCommand +borderWidth insertOffTime selectBackground yScrollCommand +cursor insertOnTime selectBorderWidth +insertBackground insertWidth selectForeground +@end example + + +@xref{options}, for more information. +@unnumberedsubsec Arguments for Canvas + + +@table @asis +@item @code{@b{:closeenough}} +@flushright +Name=@code{"@b{closeEnough}@r{"} Class=@code{"}@b{CloseEnough}"} +@end flushright +@sp 1 + +Specifies a floating-point value indicating how close the mouse cursor +must be to an item before it is considered to be ``inside'' the item. +Defaults to 1.0. +@end table + + +@table @asis +@item @code{@b{:confine}} +@flushright +Name=@code{"@b{confine}@r{"} Class=@code{"}@b{Confine}"} +@end flushright +@sp 1 + +Specifies a boolean value that indicates whether or not it should be +allowable to set the canvas's view outside the region defined by the +@b{scrollRegion} argument. +Defaults to true, which means that the view will +be constrained within the scroll region. +@end table + + +@table @asis +@item @code{@b{:height}} +@flushright +Name=@code{"@b{height}@r{"} Class=@code{"}@b{Height}"} +@end flushright +@sp 1 + +Specifies a desired window height that the canvas widget should request from +its geometry manager. The value may be specified in any +of the forms described in the COORDINATES section below. +@end table + + +@table @asis +@item @code{@b{:scrollincrement}} +@flushright +Name=@code{"@b{scrollIncrement}@r{"} Class=@code{"}@b{ScrollIncrement}"} +@end flushright +@sp 1 + +Specifies a distance used as increment during scrolling: when one of +the arrow buttons on an associated scrollbar is pressed, the picture +will shift by this distance. The distance may be specified in any +of the forms described in the COORDINATES section below. +@end table + + +@table @asis +@item @code{@b{:scrollregion}} +@flushright +Name=@code{"@b{scrollRegion}@r{"} Class=@code{"}@b{ScrollRegion}"} +@end flushright +@sp 1 + +Specifies a list with four coordinates describing the left, top, right, and +bottom coordinates of a rectangular region. +This region is used for scrolling purposes and is considered to be +the boundary of the information in the canvas. +Each of the coordinates may be specified +in any of the forms given in the COORDINATES section below. +@end table + + +@table @asis +@item @code{@b{:width}} +@flushright +Name=@code{"@b{width}@r{"} Class=@code{"}@b{width}"} +@end flushright +@sp 1 + +Specifies a desired window width that the canvas widget should request from +its geometry manager. The value may be specified in any +of the forms described in the COORDINATES section below. +@end table +@c @end cartouche + +@unnumberedsubsec Introduction + +The @b{canvas} command creates a new window (given +by the @i{pathName} argument) and makes it into a canvas widget. +Additional options, described above, may be specified on the +command line or in the option database +to configure aspects of the canvas such as its colors and 3-D relief. +The @b{canvas} command returns its +@i{pathName} argument. At the time this command is invoked, +there must not exist a window named @i{pathName}, but +@i{pathName}'s parent must exist. + +Canvas widgets implement structured graphics. +A canvas displays any number of @i{items}, which may be things like +rectangles, circles, lines, and text. +Items may be manipulated (e.g. moved or re-colored) and commands may +be associated with items in much the same way that the @b{bind} +command allows commands to be bound to widgets. For example, +a particular command may be associated with the event +so that the command is invoked whenever button 1 is pressed with +the mouse cursor over an item. +This means that items in a canvas can have behaviors defined by +the Tcl scripts bound to them. + +@unnumberedsubsec Display List + +The items in a canvas are ordered for purposes of display, +with the first item in the display list being displayed +first, followed by the next item in the list, and so on. +Items later in the display list obscure those that are +earlier in the display list and are sometimes referred to +as being ``on top'' of earlier items. +When a new item is created it is placed at the end of the +display list, on top of everything else. +Widget commands may be used to re-arrange the order of the +display list. + +@unnumberedsubsec Item Ids And Tags + +Items in a canvas widget may be named in either of two ways: +by id or by tag. +Each item has a unique identifying number which is assigned to +that item when it is created. The id of an item never changes +and id numbers are never re-used within the lifetime of a +canvas widget. + +Each item may also have any number of @i{tags} associated +with it. A tag is just a string of characters, and it may +take any form except that of an integer. +For example, ``x123'' is OK but ``123'' isn't. +The same tag may be associated with many different items. +This is commonly done to group items in various interesting +ways; for example, all selected items might be given the +tag ``selected''. + +The tag @b{all} is implicitly associated with every item +in the canvas; it may be used to invoke operations on +all the items in the canvas. + +The tag @b{current} is managed automatically by Tk; +it applies to the @i{current item}, which is the +topmost item whose drawn area covers the position of +the mouse cursor. +If the mouse is not in the canvas widget or is not over +an item, then no item has the @b{current} tag. + +When specifying items in canvas widget commands, if the +specifier is an integer then it is assumed to refer to +the single item with that id. +If the specifier is not an integer, then it is assumed to +refer to all of the items in the canvas that have a tag +matching the specifier. +The symbol @i{tagOrId} is used below to indicate that +an argument specifies either an id that selects a single +item or a tag that selects zero or more items. +Some widget commands only operate on a single item at a +time; if @i{tagOrId} is specified in a way that +names multiple items, then the normal behavior is for +the command to use the first (lowest) of these items in +the display list that is suitable for the command. +Exceptions are noted in the widget command descriptions +below. + +@unnumberedsubsec Coordinates + +All coordinates related to canvases are stored as floating-point +numbers. +Coordinates and distances are specified in screen units, +which are floating-point numbers optionally followed +by one of several letters. +If no letter is supplied then the distance is in pixels. +If the letter is @b{m} then the distance is in millimeters on +the screen; if it is @b{c} then the distance is in centimeters; +@b{i}@r{ means inches, and }@b{p} means printers points (1/72 inch). +Larger y-coordinates refer to points lower on the screen; larger +x-coordinates refer to points farther to the right. + +@unnumberedsubsec Transformations + +Normally the origin of the canvas coordinate system is at the +upper-left corner of the window containing the canvas. +It is possible to adjust the origin of the canvas +coordinate system relative to the origin of the window using the +@b{xview}@r{ and }@b{yview} widget commands; this is typically used +for scrolling. +Canvases do not support scaling or rotation of the canvas coordinate +system relative to the window coordinate system. + +Indidividual items may be moved or scaled using widget commands +described below, but they may not be rotated. + +@unnumberedsubsec Indices + +Text items support the notion of an @i{index} for identifying +particular positions within the item. +Indices are used for commands such as inserting text, deleting +a range of characters, and setting the insertion cursor position. +An index may be specified in any of a number of ways, and +different types of items may support different forms for +specifying indices. +Text items support the following forms for an index; if you +define new types of text-like items, it would be advisable to +support as many of these forms as practical. +Note that it is possible to refer to the character just after +the last one in the text item; this is necessary for such +tasks as inserting new text at the end of the item. + +@table @asis +@item @i{number} +A decimal number giving the position of the desired character +within the text item. +0 refers to the first character, 1 to the next character, and +so on. +A number less than 0 is treated as if it were zero, and a +number greater than the length of the text item is treated +as if it were equal to the length of the text item. +@item @b{end} +Refers to the character just after the last one in the item +(same as the number of characters in the item). +@item @b{insert} +Refers to the character just before which the insertion cursor +is drawn in this item. +@item @b{sel.first} +Refers to the first selected character in the item. +If the selection isn't in this item then this form is illegal. +@item @b{sel.last} +Refers to the last selected character in the item. +If the selection isn't in this item then this form is illegal. +@item @b{@@}@i{x,y} +Refers to the character at the point given by @i{x} and +@i{y}@r{, where }@i{x}@r{ and }@i{y} are specified in the coordinate +system of the canvas. +If @i{x}@r{ and }@i{y} lie outside the coordinates covered by the +text item, then they refer to the first or last character in the +line that is closest to the given point. + +@end table +@unnumberedsubsec A Canvas Widget's Arguments + +The @b{canvas} command creates a new Tcl command whose +name is @i{pathName}. This +command may be used to invoke various +operations on the widget. It has the following general form: + +@example +@i{pathName option }@r{?}@i{arg arg ...}? +@end example + +@i{Option}@r{ and the }@i{arg}s +determine the exact behavior of the command. +The following widget commands are possible for canvas widgets: + +@table @asis +@item @i{pathName }@b{:addtag }@i{tag searchSpec }@r{?}@i{arg arg ...}? +For each item that meets the constraints specified by +@i{searchSpec}@r{ and the }@i{arg}s, add +@i{tag} to the list of tags associated with the item if it +isn't already present on that list. +It is possible that no items will satisfy the constraints +given by @i{searchSpec and }@i{arg}s, in which case the +command has no effect. +This command returns an empty string as result. +@i{SearchSpec}@r{ and }@i{arg}'s may take any of the following +forms: + +@table @asis +@item @b{above }@i{tagOrId} +Selects the item just after (above) the one given by @i{tagOrId} +in the display list. +If @i{tagOrId} denotes more than one item, then the last (topmost) +of these items in the display list is used. +@item @b{all} +Selects all the items in the canvas. +@item @b{below }@i{tagOrId} +Selects the item just before (below) the one given by @i{tagOrId} +in the display list. +If @i{tagOrId} denotes more than one item, then the first (lowest) +of these items in the display list is used. +@item @b{closest }@i{x y }@r{?}@i{halo}@r{? ?}@i{start}? +Selects the item closest to the point given by @i{x}@r{ and }@i{y}. +If more than one item is at the same closest distance (e.g. two +items overlap the point), then the top-most of these items (the +last one in the display list) is used. +If @i{halo} is specified, then it must be a non-negative +value. +Any item closer than @i{halo} to the point is considered to +overlap it. +The @i{start} argument may be used to step circularly through +all the closest items. +If @i{start} is specified, it names an item using a tag or id +(if by tag, it selects the first item in the display list with +the given tag). +Instead of selecting the topmost closest item, this form will +select the topmost closest item that is below @i{start} in +the display list; if no such item exists, then the selection +behaves as if the @i{start} argument had not been specified. +@item @b{enclosed}@r{ }@i{x1}@r{ }@i{y1}@r{ }@i{x2}@r{ }@i{y2} +Selects all the items completely enclosed within the rectangular +region given by @i{x1}@r{, }@i{y1}@r{, }@i{x2}@r{, and }@i{y2}. +@i{X1}@r{ must be no greater then }@i{x2}@r{ and }@i{y1} must be +no greater than @i{y2}. +@item @b{overlapping}@r{ }@i{x1}@r{ }@i{y1}@r{ }@i{x2}@r{ }@i{y2} +Selects all the items that overlap or are enclosed within the +rectangular region given by @i{x1}@r{, }@i{y1}@r{, }@i{x2}, +and @i{y2}. +@i{X1}@r{ must be no greater then }@i{x2}@r{ and }@i{y1} must be +no greater than @i{y2}. +@item @b{withtag }@i{tagOrId} +Selects all the items given by @i{tagOrId}. +@end table + +@item @i{pathName }@b{:bbox }@i{tagOrId}@r{ ?}@i{tagOrId tagOrId ...}? +Returns a list with four elements giving an approximate bounding box +for all the items named by the @i{tagOrId} arguments. +The list has the form ``@i{x1 y1 x2 y2}'' such that the drawn +areas of all the named elements are within the region bounded by +@i{x1}@r{ on the left, }@i{x2}@r{ on the right, }@i{y1} on the top, +and @i{y2} on the bottom. +The return value may overestimate the actual bounding box by +a few pixels. +If no items match any of the @i{tagOrId} arguments then an +empty string is returned. +@item @i{pathName }@b{:bind }@i{tagOrId}@r{ ?}@i{sequence}@r{? ?}@i{command}? +This command associates @i{command} with all the items given by +@i{tagOrId} such that whenever the event sequence given by +@i{sequence} occurs for one of the items the command will +be invoked. +This widget command is similar to the @b{bind} command except that +it operates on items in a canvas rather than entire widgets. +See the @b{bind} manual entry for complete details +on the syntax of @i{sequence} and the substitutions performed +on @i{command} before invoking it. +If all arguments are specified then a new binding is created, replacing +any existing binding for the same @i{sequence}@r{ and }@i{tagOrId} +(if the first character of @i{command}@r{ is ``+'' then }@i{command} +augments an existing binding rather than replacing it). +In this case the return value is an empty string. +If @i{command}@r{ is omitted then the command returns the }@i{command} +associated with @i{tagOrId}@r{ and }@i{sequence} (an error occurs +if there is no such binding). +If both @i{command}@r{ and }@i{sequence} are omitted then the command +returns a list of all the sequences for which bindings have been +defined for @i{tagOrId}. +@end table + + +The only events for which bindings may be specified are those related +to the mouse and keyboard, such as @b{Enter}@r{, }@b{Leave}, +@b{ButtonPress}@r{, }@b{Motion}@r{, and }@b{KeyPress}. +The handling of events in canvases uses the current item defined +in ITEM IDS AND TAGS above. +@b{Enter}@r{ and }@b{Leave} events trigger for an item when it +becomes the current item or ceases to be the current item; note +that these events are different than @b{Enter}@r{ and }@b{Leave} +events for windows. +Mouse-related events are directed to the current item, if any. +Keyboard-related events are directed to the focus item, if any +(see the @b{focus} widget command below for more on this). + + +It is possible for multiple commands to be bound to a single +event sequence for a single object. +This occurs, for example, if one command is associated with the +item's id and another is associated with one of the item's tags. +When this occurs, the first matching binding is used. +A binding for the item's id has highest priority, followed by +the oldest tag for the item and proceeding through all of the +item's tags up through the most-recently-added one. +If a binding is associated with the tag @b{all}, the binding +will have lower priority than all other bindings associated +with the item. + +@table @asis +@item @i{pathName }@b{:canvasx }@i{screenx}@r{ ?}@i{gridspacing}? +Given a screen x-coordinate @i{screenx} this command returns +the canvas x-coordinate that is displayed at that location. +If @i{gridspacing} is specified, then the canvas coordinate is +rounded to the nearest multiple of @i{gridspacing} units. +@item @i{pathName }@b{:canvasy }@i{screeny}@r{ ?}@i{gridspacing}? +Given a screen y-coordinate @i{screeny} this command returns +the canvas y-coordinate that is displayed at that location. +If @i{gridspacing} is specified, then the canvas coordinate is +rounded to the nearest multiple of @i{gridspacing} units. +@item @i{pathName }@b{:configure ?}@i{option}@r{? ?}@i{value}@r{? ?}@i{option value ...}? +Query or modify the configuration options of the widget. +If no @i{option} is specified, returns a list describing all of +the available options for @i{pathName}@r{ (see }@b{Tk_ConfigureInfo} for +information on the format of this list). If @i{option} is specified +with no @i{value}, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no @i{option} is specified). If +one or more @i{option:value} pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +@i{Option}@r{ may have any of the values accepted by the }@b{canvas} +command. +@item @i{pathName}@r{ }@b{:coords }@i{tagOrId }@r{?}@i{x0 y0 ...}? +Query or modify the coordinates that define an item. +If no coordinates are specified, this command returns a list +whose elements are the coordinates of the item named by +@i{tagOrId}. +If coordinates are specified, then they replace the current +coordinates for the named item. +If @i{tagOrId} refers to multiple items, then +the first one in the display list is used. +@item @i{pathName }@b{:create }@i{type x y }@r{?}@i{x y ...}@r{? ?}@i{option value ...}? +Create a new item in @i{pathName}@r{ of type }@i{type}. +The exact format of the arguments after @b{type} depends +on @b{type}, but usually they consist of the coordinates for +one or more points, followed by specifications for zero or +more item options. +See the subsections on individual item types below for more +on the syntax of this command. +This command returns the id for the new item. +@item @i{pathName }@b{:dchars }@i{tagOrId first }@r{?}@i{last}? +For each item given by @i{tagOrId}, delete the characters +in the range given by @i{first}@r{ and }@i{last}, +inclusive. +If some of the items given by @i{tagOrId} don't support +text operations, then they are ignored. +@i{First}@r{ and }@i{last} are indices of characters +within the item(s) as described in INDICES above. +If @i{last}@r{ is omitted, it defaults to }@i{first}. +This command returns an empty string. +@item @i{pathName }@b{:delete }@r{?}@i{tagOrId tagOrId ...}? +Delete each of the items given by each @i{tagOrId}, and return +an empty string. +@item @i{pathName }@b{:dtag }@i{tagOrId }@r{?tagToDelete}? +For each of the items given by @i{tagOrId}, delete the +tag given by @i{tagToDelete} from the list of those +associated with the item. +If an item doesn't have the tag @i{tagToDelete} then +the item is unaffected by the command. +If @i{tagToDelete}@r{ is omitted then it defaults to }@i{tagOrId}. +This command returns an empty string. +@item @i{pathName }@b{:find }@i{searchCommand }@r{?}@i{arg arg ...}? +This command returns a list consisting of all the items that +meet the constraints specified by @i{searchCommand} and +@i{arg}'s. +@i{SearchCommand}@r{ and }@i{args} have any of the forms +accepted by the @b{addtag} command. +@item @i{pathName }@b{:focus }@r{?}@i{tagOrId}? +Set the keyboard focus for the canvas widget to the item given by +@i{tagOrId}. +If @i{tagOrId} refers to several items, then the focus is set +to the first such item in the display list that supports the +insertion cursor. +If @i{tagOrId} doesn't refer to any items, or if none of them +support the insertion cursor, then the focus isn't changed. +If @i{tagOrId} is an empty +string, then the focus item is reset so that no item has the focus. +If @i{tagOrId} is not specified then the command returns the +id for the item that currently has the focus, or an empty string +if no item has the focus. +@end table + + +Once the focus has been set to an item, the item will display +the insertion cursor and all keyboard events will be directed +to that item. +The focus item within a canvas and the focus window on the +screen (set with the @b{focus} command) are totally independent: +a given item doesn't actually have the input focus unless (a) +its canvas is the focus window and (b) the item is the focus item +within the canvas. +In most cases it is advisable to follow the @b{focus} widget +command with the @b{focus} command to set the focus window to +the canvas (if it wasn't there already). + +@table @asis +@item @i{pathName }@b{:gettags}@r{ }@i{tagOrId} +Return a list whose elements are the tags associated with the +item given by @i{tagOrId}. +If @i{tagOrId} refers to more than one item, then the tags +are returned from the first such item in the display list. +If @i{tagOrId} doesn't refer to any items, or if the item +contains no tags, then an empty string is returned. +@item @i{pathName }@b{:icursor }@i{tagOrId index} +Set the position of the insertion cursor for the item(s) +given by @i{tagOrId} +to just before the character whose position is given by @i{index}. +If some or all of the items given by @i{tagOrId} don't support +an insertion cursor then this command has no effect on them. +See INDICES above for a description of the +legal forms for @i{index}. +Note: the insertion cursor is only displayed in an item if +that item currently has the keyboard focus (see the widget +command @b{focus}, below), but the cursor position may +be set even when the item doesn't have the focus. +This command returns an empty string. +@item @i{pathName }@b{:index }@i{tagOrId index} +This command returns a decimal string giving the numerical index +within @i{tagOrId}@r{ corresponding to }@i{index}. +@i{Index} gives a textual description of the desired position +as described in INDICES above. +The return value is guaranteed to lie between 0 and the number +of characters within the item, inclusive. +If @i{tagOrId} refers to multiple items, then the index +is processed in the first of these items that supports indexing +operations (in display list order). +@item @i{pathName }@b{:insert }@i{tagOrId beforeThis string} +For each of the items given by @i{tagOrId}, if the item supports +text insertion then @i{string} is inserted into the item's +text just before the character whose index is @i{beforeThis}. +See INDICES above for information about the forms allowed +for @i{beforeThis}. +This command returns an empty string. +@item @i{pathName }@b{:itemconfigure }@i{tagOrId}@r{ ?}@i{option}@r{? ?}@i{value}@r{? ?}@i{option value ...}? +This command is similar to the @b{configure} widget command except +that it modifies item-specific options for the items given by +@i{tagOrId} instead of modifying options for the overall +canvas widget. +If no @i{option} is specified, returns a list describing all of +the available options for the first item given by @i{tagOrId} +(see @b{Tk_ConfigureInfo} for +information on the format of this list). If @i{option} is specified +with no @i{value}, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no @i{option} is specified). If +one or more @i{option:value} pairs are specified, then the command +modifies the given widget option(s) to have the given value(s) in +each of the items given by @i{tagOrId}; in +this case the command returns an empty string. +The @i{option}@r{s and }@i{value}s are the same as those permissible +in the @b{create} widget command when the item(s) were created; +see the sections describing individual item types below for details +on the legal options. +@item @i{pathName }@b{:lower }@i{tagOrId }@r{?}@i{belowThis}? +Move all of the items given by @i{tagOrId} to a new position +in the display list just before the item given by @i{belowThis}. +If @i{tagOrId} refers to more than one item then all are moved +but the relative order of the moved items will not be changed. +@i{BelowThis} is a tag or id; if it refers to more than one +item then the first (lowest) of these items in the display list is used +as the destination location for the moved items. +This command returns an empty string. +@item @i{pathName }@b{:move }@i{tagOrId xAmount yAmount} +Move each of the items given by @i{tagOrId} in the canvas coordinate +space by adding @i{xAmount} to the x-coordinate of each point +associated with the item and @i{yAmount} to the y-coordinate of +each point associated with the item. +This command returns an empty string. +@item @i{pathName }@b{:postscript }@r{?}@i{option value option value ...}? +Generate a Postscript representation for part or all of the canvas. +If the @b{:file} option is specified then the Postscript is written +to a file and an empty string is returned; otherwise the Postscript +is returned as the result of the command. +The Postscript is created in Encapsulated Postscript form using +version 3.0 of the Document Structuring Conventions. +The @i{option}\-@i{value} argument pairs provide additional +information to control the generation of Postscript. The following +options are supported: + +@table @asis +@item @b{:colormap }@i{varName} +@i{VarName} must be the name of a global array variable +that specifies a color mapping to use in the Postscript. +Each element of @i{varName} must consist of Postscript +code to set a particular color value (e.g. ``@b{1.0 1.0 0.0 setrgbcolor}''). +When outputting color information in the Postscript, Tk checks +to see if there is an element of @i{varName} with the same +name as the color. +If so, Tk uses the value of the element as the Postscript command +to set the color. +If this option hasn't been specified, or if there isn't an entry +in @i{varName} for a given color, then Tk uses the red, green, +and blue intensities from the X color. +@item @b{:colormode }@i{mode} +Specifies how to output color information. @i{Mode} must be either +@b{color}@r{ (for full color output), }@b{gray} (convert all colors +to their gray-scale equivalents) or @b{mono} (convert all colors +to black or white). +@item @b{:file }@i{fileName} +Specifies the name of the file in which to write the Postscript. +If this option isn't specified then the Postscript is returned as the +result of the command instead of being written to a file. +@item @b{:fontmap }@i{varName} +@i{VarName} must be the name of a global array variable +that specifies a font mapping to use in the Postscript. +Each element of @i{varName} must consist of a Tcl list with +two elements, which are the name and point size of a Postscript font. +When outputting Postscript commands for a particular font, Tk +checks to see if @i{varName} contains an element with the same +name as the font. +If there is such an element, then the font information contained in +that element is used in the Postscript. +Otherwise Tk attempts to guess what Postscript font to use. +Tk's guesses generally only work for well-known fonts such as +Times and Helvetica and Courier, and only if the X font name does not +omit any dashes up through the point size. +For example, \fB\-*\-Courier\-Bold\-R\-Normal\-\-*\-120\-* will work but +\fB*Courier\-Bold\-R\-Normal*120* will not; Tk needs the dashes to +parse the font name). +@item @b{:height }@i{size} +Specifies the height of the area of the canvas to print. +Defaults to the height of the canvas window. +@item @b{:pageanchor }@i{anchor} +Specifies which point of the printed area should be appear over +the positioning point on the page (which is given by the @b{:pagex} +and @b{:pagey} options). +For example, @b{:pageanchor n} means that the top center of the +printed area should be over the positioning point. +Defaults to @b{center}. +@item @b{:pageheight }@i{size} +Specifies that the Postscript should be scaled in both x and y so +that the printed area is @i{size} high on the Postscript page. +@i{Size} consists of a floating-point number followed by +@b{c}@r{ for centimeters, }@b{i}@r{ for inches, }@b{m} for millimeters, +or @b{p} or nothing for printer's points (1/72 inch). +Defaults to the height of the printed area on the screen. +If both @b{:pageheight}@r{ and }@b{:pagewidth} are specified then +the scale factor from the later option is used (non-uniform scaling +is not implemented). +@item @b{:pagewidth }@i{size} +Specifies that the Postscript should be scaled in both x and y so +that the printed area is @i{size} wide on the Postscript page. +@i{Size}@r{ has the same form as for }@b{:pageheight}. +Defaults to the width of the printed area on the screen. +If both @b{:pageheight}@r{ and }@b{:pagewidth} are specified then +the scale factor from the later option is used (non-uniform scaling +is not implemented). +@item @b{:pagex }@i{position} +@i{Position} gives the x-coordinate of the positioning point on +the Postscript page, using any of the forms allowed for @b{:pageheight}. +Used in conjunction with the @b{:pagey}@r{ and }@b{:pageanchor} options +to determine where the printed area appears on the Postscript page. +Defaults to the center of the page. +@item @b{:pagey }@i{position} +@i{Position} gives the y-coordinate of the positioning point on +the Postscript page, using any of the forms allowed for @b{:pageheight}. +Used in conjunction with the @b{:pagex}@r{ and }@b{:pageanchor} options +to determine where the printed area appears on the Postscript page. +Defaults to the center of the page. +@item @b{:rotate }@i{boolean} +@i{Boolean} specifies whether the printed area is to be rotated 90 +degrees. +In non-rotated output the x-axis of the printed area runs along +the short dimension of the page (``portrait'' orientation); +in rotated output the x-axis runs along the long dimension of the +page (``landscape'' orientation). +Defaults to non-rotated. +@item @b{:width }@i{size} +Specifies the width of the area of the canvas to print. +Defaults to the width of the canvas window. +@item @b{:x }@i{position} +Specifies the x-coordinate of the left edge of the area of the +canvas that is to be printed, in canvas coordinates, not window +coordinates. +Defaults to the coordinate of the left edge of the window. +@item @b{:y }@i{position} +Specifies the y-coordinate of the top edge of the area of the +canvas that is to be printed, in canvas coordinates, not window +coordinates. +Defaults to the coordinate of the top edge of the window. +@end table + +@item @i{pathName }@b{:raise }@i{tagOrId }@r{?}@i{aboveThis}? +Move all of the items given by @i{tagOrId} to a new position +in the display list just after the item given by @i{aboveThis}. +If @i{tagOrId} refers to more than one item then all are moved +but the relative order of the moved items will not be changed. +@i{AboveThis} is a tag or id; if it refers to more than one +item then the last (topmost) of these items in the display list is used +as the destination location for the moved items. +This command returns an empty string. +@item @i{pathName }@b{:scale }@i{tagOrId xOrigin yOrigin xScale yScale} +Rescale all of the items given by @i{tagOrId} in canvas coordinate +space. +@i{XOrigin}@r{ and }@i{yOrigin} identify the origin for the scaling +operation and @i{xScale}@r{ and }@i{yScale} identify the scale +factors for x- and y-coordinates, respectively (a scale factor of +1.0 implies no change to that coordinate). +For each of the points defining each item, the x-coordinate is +adjusted to change the distance from @i{xOrigin} by a factor +of @i{xScale}. +Similarly, each y-coordinate is adjusted to change the distance +from @i{yOrigin}@r{ by a factor of }@i{yScale}. +This command returns an empty string. +@item @i{pathName }@b{:scan}@r{ }@i{option args} +This command is used to implement scanning on canvases. It has +two forms, depending on @i{option}: + +@table @asis +@item @i{pathName }@b{:scan :mark }@i{x y} +Records @i{x}@r{ and }@i{y} and the canvas's current view; used +in conjunction with later @b{scan dragto} commands. +Typically this command is associated with a mouse button press in +the widget and @i{x}@r{ and }@i{y} are the coordinates of the +mouse. It returns an empty string. +@item @i{pathName }@b{:scan :dragto }@i{x y}. +This command computes the difference between its @i{x}@r{ and }@i{y} +arguments (which are typically mouse coordinates) and the @i{x} and +@i{y}@r{ arguments to the last }@b{scan mark} command for the widget. +It then adjusts the view by 10 times the +difference in coordinates. This command is typically associated +with mouse motion events in the widget, to produce the effect of +dragging the canvas at high speed through its window. The return +value is an empty string. +@end table + +@item @i{pathName }@b{:select }@i{option}@r{ ?}@i{tagOrId arg}? +Manipulates the selection in one of several ways, depending on +@i{option}. +The command may take any of the forms described below. +In all of the descriptions below, @i{tagOrId} must refer to +an item that supports indexing and selection; if it refers to +multiple items then the first of +these that supports indexing and the selection is used. +@i{Index} gives a textual description of a position +within @i{tagOrId}, as described in INDICES above. + +@table @asis +@item @i{pathName }@b{:select :adjust }@i{tagOrId index} +Locate the end of the selection in @i{tagOrId} nearest +to the character given by @i{index}, and adjust that +end of the selection to be at @i{index} (i.e. including +but not going beyond @i{index}). +The other end of the selection is made the anchor point +for future @b{select to} commands. +If the selection isn't currently in @i{tagOrId} then +this command behaves the same as the @b{select to} widget +command. +Returns an empty string. +@item @i{pathName }@b{:select :clear} +Clear the selection if it is in this widget. +If the selection isn't in this widget then the command +has no effect. +Returns an empty string. +@item @i{pathName }@b{:select :from }@i{tagOrId index} +Set the selection anchor point for the widget to be just +before the character +given by @i{index}@r{ in the item given by }@i{tagOrId}. +This command doesn't change the selection; it just sets +the fixed end of the selection for future @b{select to} +commands. +Returns an empty string. +@item @i{pathName }@b{:select :item} +Returns the id of the selected item, if the selection is in an +item in this canvas. +If the selection is not in this canvas then an empty string +is returned. +@item @i{pathName }@b{:select :to }@i{tagOrId index} +Set the selection to consist of those characters of @i{tagOrId} +between the selection anchor point and +@i{index}. +The new selection will include the character given by @i{index}; +it will include the character given by the anchor point only if +@i{index} is greater than or equal to the anchor point. +The anchor point is determined by the most recent @b{select adjust} +or @b{select from} command for this widget. +If the selection anchor point for the widget isn't currently in +@i{tagOrId}, then it is set to the same character given +by @i{index}. +Returns an empty string. +@end table + +@item @i{pathName }@b{:type}@i{ tagOrId} +Returns the type of the item given by @i{tagOrId}, such as +@b{rectangle}@r{ or }@b{text}. +If @i{tagOrId} refers to more than one item, then the type +of the first item in the display list is returned. +If @i{tagOrId} doesn't refer to any items at all then +an empty string is returned. +@item @i{pathName }@b{:xview}@i{ index} +Change the view in the canvas so that the canvas position given by +@i{index} appears at the left edge of the window. +This command is typically used by scrollbars to scroll the +canvas. +@i{Index} counts in units of scroll increments (the value of the +@b{scrollIncrement} option): a value of 0 corresponds to the left +edge of the scroll region (as defined by the @b{scrollRegion} +option), a value of 1 means one scroll unit to the right of this, +and so on. The return value is an empty string. +@item @i{pathName }@b{:yview}@i{ index} +Change the view in the canvas so that the canvas position given by +@i{index} appears at the top edge of the window. +This command is typically used by scrollbars to scroll the +canvas. +@i{Index} counts in units of scroll increments (the value of the +@b{scrollIncrement} option): a value of 0 corresponds to the top +edge of the scroll region (as defined by the @b{scrollRegion} +option), a value of 1 means one scroll unit below this, +and so on. The return value is an empty string. + +@end table +@unnumberedsubsec Overview Of Item Types + +The sections below describe the various types of items supported +by canvas widgets. Each item type is characterized by two things: +first, the form of the @b{create} command used to create +instances of the type; and second, a set of configuration options +for items of that type, which may be used in the +@b{create}@r{ and }@b{itemconfigure} widget commands. +Most items don't support indexing or selection or the commands +related to them, such as @b{index}@r{ and }@b{insert}. +Where items do support these facilities, it is noted explicitly +in the descriptions below (at present, only text items provide +this support). + +@unnumberedsubsec Arc Items + +Items of type @b{arc} appear on the display as arc-shaped regions. +An arc is a section of an oval delimited by two angles (specified +by the @b{:start}@r{ and }@b{:extent} options) and displayed in +one of several ways (specified by the @b{:style} option). +Arcs are created with widget commands of the following form: + +@table @asis +@item @i{pathName }@b{:create arc }@i{x1 y1 x2 y2 }@r{?}@i{option value option value ...}? +The arguments @i{x1}@r{, }@i{y1}@r{, }@i{x2}@r{, and }@i{y2} give +the coordinates of two diagonally opposite corners of a +rectangular region enclosing the oval that defines the arc. +After the coordinates there may be any number of @i{option}@r{-}@i{value} +pairs, each of which sets one of the configuration options +for the item. These same @i{option}\-@i{value} pairs may be +used in @b{itemconfigure} widget commands to change the item's +configuration. +The following options are supported for arcs: + +@table @asis +@item @b{:extent }@i{degrees} +Specifies the size of the angular range occupied by the arc. +The arc's range extends for @i{degrees} degrees counter-clockwise +from the starting angle given by the @b{:start} option. +@i{Degrees} may be negative. +@item @b{:fill }@i{color} +Fill the region of the arc with @i{color}. +@i{Color}@r{ may have any of the forms accepted by }@b{Tk_GetColor}. +If @i{color} is an empty string (the default), then +then the arc will not be filled. +@item @b{:outline }@i{color} +@i{Color} specifies a color to use for drawing the arc's +outline; it may have any of the forms accepted by @b{Tk_GetColor}. +This option defaults to @b{black}. If the arc's style is +@b{arc} then this option is ignored (the section of perimeter is +filled using the @b{:fill}@r{ option). If }@i{color} is specified +as an empty string then no outline is drawn for the arc. +@item @b{:start }@i{degrees} +Specifies the beginning of the angular range occupied by the +arc. +@i{Degrees} is given in units of degrees measured counter-clockwise +from the 3-o'clock position; it may be either positive or negative. +@item @b{:stipple }@i{bitmap} +Indicates that the arc should be filled in a stipple pattern; +@i{bitmap} specifies the stipple pattern to use, in any of the +forms accepted by @b{Tk_GetBitmap}. +If the @b{:fill} option hasn't been specified then this option +has no effect. +If @i{bitmap} is an empty string (the default), then filling is done +in a solid fashion. +@item @b{:style }@i{type} +Specifies how to draw the arc. If @i{type}@r{ is }@b{pieslice} +(the default) then the arc's region is defined by a section +of the oval's perimeter plus two line segments, one between the center +of the oval and each end of the perimeter section. +If @i{type}@r{ is }@b{chord} then the arc's region is defined +by a section of the oval's perimeter plus a single line segment +connecting the two end points of the perimeter section. +If @i{type}@r{ is }@b{arc} then the arc's region consists of +a section of the perimeter alone. In this last case there is +no outline for the arc and the @b{:outline} option is ignored. +@item @b{:tags }@i{tagList} +Specifies a set of tags to apply to the item. +@i{TagList} consists of a list of tag names, which replace any +existing tags for the item. +@i{TagList} may be an empty list. +@item @b{:width }@i{outlineWidth} +Specifies the width of the outline to be drawn around +the arc's region, in any of the forms described in the COORDINATES +section above. +If the @b{:outline} option has been specified as an empty string +then this option has no effect. +Wide outlines will be drawn centered on the edges of the arc's region. +This option defaults to 1.0. +@end table +@end table + +@unnumberedsubsec Bitmap Items + +Items of type @b{bitmap} appear on the display as images with +two colors, foreground and background. +Bitmaps are created with widget commands of the following form: + +@table @asis +@item @i{pathName }@b{:create bitmap }@i{x y }@r{?}@i{option value option value ...}? +The arguments @i{x}@r{ and }@i{y} specify the coordinates of a +point used to position the bitmap on the display (see the @b{:anchor} +option below for more information on how bitmaps are displayed). +After the coordinates there may be any number of @i{option}@r{-}@i{value} +pairs, each of which sets one of the configuration options +for the item. These same @i{option}\-@i{value} pairs may be +used in @b{itemconfigure} widget commands to change the item's +configuration. +The following options are supported for bitmaps: + +@table @asis +@item @b{:anchor }@i{anchorPos} +@i{AnchorPos} tells how to position the bitmap relative to the +positioning point for the item; it may have any of the forms +accepted by @b{Tk_GetAnchor}@r{. For example, if }@i{anchorPos} +is @b{center} then the bitmap is centered on the point; if +@i{anchorPos}@r{ is }@b{n} then the bitmap will be drawn so that +its top center point is at the positioning point. +This option defaults to @b{center}. +@item @b{:background }@i{color} +Specifies a color to use for each of the bitmap pixels +whose value is 0. +@i{Color}@r{ may have any of the forms accepted by }@b{Tk_GetColor}. +If this option isn't specified, or if it is specified as an empty +string, then the background color for the canvas is used. +@item @b{:bitmap }@i{bitmap} +Specifies the bitmap to display in the item. +@i{Bitmap}@r{ may have any of the forms accepted by }@b{Tk_GetBitmap}. +@item @b{:foreground }@i{color} +Specifies a color to use for each of the bitmap pixels +whose value is 1. +@i{Color}@r{ may have any of the forms accepted by }@b{Tk_GetColor} and +defaults to @b{black}. +@item @b{:tags }@i{tagList} +Specifies a set of tags to apply to the item. +@i{TagList} consists of a list of tag names, which replace any +existing tags for the item. +@i{TagList} may be an empty list. +@end table +@end table +@unnumberedsubsec Line Items + +Items of type @b{line} appear on the display as one or more connected +line segments or curves. +Lines are created with widget commands of the following form: + +@table @asis +@item @i{pathName }@b{:create line }@i{x1 y1... xn yn }@r{?}@i{option value option value ...}? + +The arguments @i{x1}@r{ through }@i{yn} give +the coordinates for a series of two or more points that describe +a series of connected line segments. +After the coordinates there may be any number of @i{option}@r{-}@i{value} +pairs, each of which sets one of the configuration options +for the item. These same @i{option}\-@i{value} pairs may be +used in @b{itemconfigure} widget commands to change the item's +configuration. +The following options are supported for lines: + +@table @asis +@item @b{:arrow }@i{where} +Indicates whether or not arrowheads are to be drawn at one or both +ends of the line. +@i{Where}@r{ must have one of the values }@b{none} (for no arrowheads), +@b{first} (for an arrowhead at the first point of the line), +@b{last} (for an arrowhead at the last point of the line), or +@b{both} (for arrowheads at both ends). +This option defaults to @b{none}. +@item @b{:arrowshape }@i{shape} +This option indicates how to draw arrowheads. +The @i{shape} argument must be a list with three elements, each +specifying a distance in any of the forms described in +the COORDINATES section above. +The first element of the list gives the distance along the line +from the neck of the arrowhead to its tip. +The second element gives the distance along the line from the +trailing points of the arrowhead to the tip, and the third +element gives the distance from the outside edge of the line to the +trailing points. +If this option isn't specified then Tk picks a ``reasonable'' shape. +@item @b{:capstyle }@i{style} +Specifies the ways in which caps are to be drawn at the endpoints +of the line. +@i{Style}@r{ may have any of the forms accepted by }@b{Tk_GetCapStyle} +(@b{butt}@r{, }@b{projecting}@r{, or }@b{round}). +If this option isn't specified then it defaults to @b{butt}. +Where arrowheads are drawn the cap style is ignored. +@item @b{:fill }@i{color} +@i{Color} specifies a color to use for drawing the line; it may have +any of the forms acceptable to @b{Tk_GetColor}. It may also be an +empty string, in which case the line will be transparent. +This option defaults to @b{black}. +@item @b{:joinstyle }@i{style} +Specifies the ways in which joints are to be drawn at the vertices +of the line. +@i{Style}@r{ may have any of the forms accepted by }@b{Tk_GetCapStyle} +(@b{bevel}@r{, }@b{miter}@r{, or }@b{round}). +If this option isn't specified then it defaults to @b{miter}. +If the line only contains two points then this option is +irrelevant. +@item @b{:smooth }@i{boolean} +@i{Boolean}@r{ must have one of the forms accepted by }@b{Tk_GetBoolean}. +It indicates whether or not the line should be drawn as a curve. +If so, the line is rendered as a set of Bezier splines: one spline +is drawn for the first and second line segments, one for the second +and third, and so on. Straight-line segments can be generated within +a curve by duplicating the end-points of the desired line segment. +@item @b{:splinesteps }@i{number} +Specifies the degree of smoothness desired for curves: each spline +will be approximated with @i{number} line segments. This +option is ignored unless the @b{:smooth} option is true. +@item @b{:stipple }@i{bitmap} +Indicates that the line should be filled in a stipple pattern; +@i{bitmap} specifies the stipple pattern to use, in any of the +forms accepted by @b{Tk_GetBitmap}. +If @i{bitmap} is an empty string (the default), then filling is +done in a solid fashion. +@item @b{:tags }@i{tagList} +Specifies a set of tags to apply to the item. +@i{TagList} consists of a list of tag names, which replace any +existing tags for the item. +@i{TagList} may be an empty list. +@item @b{:width }@i{lineWidth} +@i{LineWidth} specifies the width of the line, in any of the forms +described in the COORDINATES section above. +Wide lines will be drawn centered on the path specified by the +points. +If this option isn't specified then it defaults to 1.0. +@end table +@end table +@unnumberedsubsec Oval Items + +Items of type @b{oval} appear as circular or oval regions on +the display. Each oval may have an outline, a fill, or +both. Ovals are created with widget commands of the +following form: + +@table @asis +@item @i{pathName }@b{:create oval }@i{x1 y1 x2 y2 }@r{?}@i{option value option value ...}? + +The arguments @i{x1}@r{, }@i{y1}@r{, }@i{x2}@r{, and }@i{y2} give +the coordinates of two diagonally opposite corners of a +rectangular region enclosing the oval. +The oval will include the top and left edges of the rectangle +not the lower or right edges. +If the region is square then the resulting oval is circular; +otherwise it is elongated in shape. +After the coordinates there may be any number of @i{option}@r{-}@i{value} +pairs, each of which sets one of the configuration options +for the item. These same @i{option}\-@i{value} pairs may be +used in @b{itemconfigure} widget commands to change the item's +configuration. +The following options are supported for ovals: + +@table @asis +@item @b{:fill }@i{color} +Fill the area of the oval with @i{color}. +@i{Color}@r{ may have any of the forms accepted by }@b{Tk_GetColor}. +If @i{color} is an empty string (the default), then +then the oval will not be filled. +@item @b{:outline }@i{color} +@i{Color} specifies a color to use for drawing the oval's +outline; it may have any of the forms accepted by @b{Tk_GetColor}. +This option defaults to @b{black}. +If @i{color} is an empty string then no outline will be +drawn for the oval. +@item @b{:stipple }@i{bitmap} +Indicates that the oval should be filled in a stipple pattern; +@i{bitmap} specifies the stipple pattern to use, in any of the +forms accepted by @b{Tk_GetBitmap}. +If the @b{:fill} option hasn't been specified then this option +has no effect. +If @i{bitmap} is an empty string (the default), then filling is done +in a solid fashion. +@item @b{:tags }@i{tagList} +Specifies a set of tags to apply to the item. +@i{TagList} consists of a list of tag names, which replace any +existing tags for the item. +@i{TagList} may be an empty list. +@item @b{:width }@i{outlineWidth} +@i{outlineWidth} specifies the width of the outline to be drawn around +the oval, in any of the forms described in the COORDINATES section above. +If the @b{:outline} option hasn't been specified then this option +has no effect. +Wide outlines are drawn centered on the oval path defined by +@i{x1}@r{, }@i{y1}@r{, }@i{x2}@r{, and }@i{y2}. +This option defaults to 1.0. +@end table +@end table +@unnumberedsubsec Polygon Items + +Items of type @b{polygon} appear as polygonal or curved filled regions +on the display. +Polygons are created with widget commands of the following form: + +@table @asis +@item @i{pathName }@b{:create polygon }@i{x1 y1 ... xn yn }@r{?}@i{option value option value ...}? + + +The arguments @i{x1}@r{ through }@i{yn} specify the coordinates for +three or more points that define a closed polygon. +The first and last points may be the same; whether they are or not, +Tk will draw the polygon as a closed polygon. +After the coordinates there may be any number of @i{option}@r{-}@i{value} +pairs, each of which sets one of the configuration options +for the item. These same @i{option}\-@i{value} pairs may be +used in @b{itemconfigure} widget commands to change the item's +configuration. +The following options are supported for polygons: + +@table @asis +@item @b{:fill }@i{color} +@i{Color} specifies a color to use for filling the area of the +polygon; it may have any of the forms acceptable to @b{Tk_GetColor}. +If @i{color} is an empty string then the polygon will be +transparent. +This option defaults to @b{black}. +@item @b{:smooth }@i{boolean} +@i{Boolean}@r{ must have one of the forms accepted by }@b{Tk_GetBoolean} +It indicates whether or not the polygon should be drawn with a +curved perimeter. +If so, the outline of the polygon becomes a set of Bezier splines, +one spline for the first and second line segments, one for the second +and third, and so on. Straight-line segments can be generated in a +smoothed polygon by duplicating the end-points of the desired line segment. +@item @b{:splinesteps }@i{number} +Specifies the degree of smoothness desired for curves: each spline +will be approximated with @i{number} line segments. This +option is ignored unless the @b{:smooth} option is true. +@item @b{:stipple }@i{bitmap} +Indicates that the polygon should be filled in a stipple pattern; +@i{bitmap} specifies the stipple pattern to use, in any of the +forms accepted by @b{Tk_GetBitmap}. +If @i{bitmap} is an empty string (the default), then filling is +done in a solid fashion. +@item @b{:tags }@i{tagList} +Specifies a set of tags to apply to the item. +@i{TagList} consists of a list of tag names, which replace any +existing tags for the item. +@i{TagList} may be an empty list. +@end table +@end table + +@unnumberedsubsec Rectangle Items + +Items of type @b{rectangle} appear as rectangular regions on +the display. Each rectangle may have an outline, a fill, or +both. Rectangles are created with widget commands of the +following form: + +@table @asis +@item @i{pathName }@b{:create rectangle }@i{x1 y1 x2 y2 }@r{?}@i{option value option value ...}? + +The arguments @i{x1}@r{, }@i{y1}@r{, }@i{x2}@r{, and }@i{y2} give +the coordinates of two diagonally opposite corners of the rectangle +(the rectangle will include its upper and left edges but not +its lower or right edges). +After the coordinates there may be any number of @i{option}@r{-}@i{value} +pairs, each of which sets one of the configuration options +for the item. These same @i{option}\-@i{value} pairs may be +used in @b{itemconfigure} widget commands to change the item's +configuration. +The following options are supported for rectangles: + +@table @asis +@item @b{:fill }@i{color} +Fill the area of the rectangle with @i{color}, which may be +specified in any of the forms accepted by @b{Tk_GetColor}. +If @i{color} is an empty string (the default), then +then the rectangle will not be filled. +@item @b{:outline }@i{color} +Draw an outline around the edge of the rectangle in @i{color}. +@i{Color}@r{ may have any of the forms accepted by }@b{Tk_GetColor}. +This option defaults to @b{black}. +If @i{color} is an empty string then no outline will be +drawn for the rectangle. +@item @b{:stipple }@i{bitmap} +Indicates that the rectangle should be filled in a stipple pattern; +@i{bitmap} specifies the stipple pattern to use, in any of the +forms accepted by @b{Tk_GetBitmap}. +If the @b{:fill} option hasn't been specified then this option +has no effect. +If @i{bitmap} is an empty string (the default), then filling +is done in a solid fashion. +@item @b{:tags }@i{tagList} +Specifies a set of tags to apply to the item. +@i{TagList} consists of a list of tag names, which replace any +existing tags for the item. +@i{TagList} may be an empty list. +@item @b{:width }@i{outlineWidth} +@i{OutlineWidth} specifies the width of the outline to be drawn around +the rectangle, in any of the forms described in the COORDINATES section above. +If the @b{:outline} option hasn't been specified then this option +has no effect. +Wide outlines are drawn centered on the rectangular path +defined by @i{x1}@r{, }@i{y1}@r{, }@i{x2}@r{, and }@i{y2}. +This option defaults to 1.0. +@end table +@end table +@unnumberedsubsec Text Items + +A text item displays a string of characters on the screen in one +or more lines. +Text items support indexing and selection, along with the +following text-related canvas widget commands: @b{dchars}, +@b{focus}@r{, }@b{icursor}@r{, }@b{index}@r{, }@b{insert}, +@b{select}. +Text items are created with widget commands of the following +form: + +@table @asis +@item @i{pathName }@b{:create text }@i{x y }@r{?}@i{option value option value ...}? + +The arguments @i{x}@r{ and }@i{y} specify the coordinates of a +point used to position the text on the display (see the options +below for more information on how text is displayed). +After the coordinates there may be any number of @i{option}@r{-}@i{value} +pairs, each of which sets one of the configuration options +for the item. These same @i{option}\-@i{value} pairs may be +used in @b{itemconfigure} widget commands to change the item's +configuration. +The following options are supported for text items: + +@table @asis +@item @b{:anchor }@i{anchorPos} +@i{AnchorPos} tells how to position the text relative to the +positioning point for the text; it may have any of the forms +accepted by @b{Tk_GetAnchor}@r{. For example, if }@i{anchorPos} +is @b{center} then the text is centered on the point; if +@i{anchorPos}@r{ is }@b{n} then the text will be drawn such that +the top center point of the rectangular region occupied by the +text will be at the positioning point. +This option defaults to @b{center}. +@item @b{:fill }@i{color} +@i{Color} specifies a color to use for filling the text characters; +it may have any of the forms accepted by @b{Tk_GetColor}. +If this option isn't specified then it defaults to @b{black}. +@item @b{:font }@i{fontName} +Specifies the font to use for the text item. +@i{FontName}@r{ may be any string acceptable to }@b{Tk_GetFontStruct}. +If this option isn't specified, it defaults to a system-dependent +font. +@item @b{:justify }@i{how} +Specifies how to justify the text within its bounding region. +@i{How}@r{ must be one of the values }@b{left}@r{, }@b{right}, +or @b{center}. +This option will only matter if the text is displayed as multiple +lines. +If the option is omitted, it defaults to @b{left}. +@item @b{:stipple }@i{bitmap} +Indicates that the text should be drawn in a stippled pattern +rather than solid; +@i{bitmap} specifies the stipple pattern to use, in any of the +forms accepted by @b{Tk_GetBitmap}. +If @i{bitmap} is an empty string (the default) then the text +is drawn in a solid fashion. +@item @b{:tags }@i{tagList} +Specifies a set of tags to apply to the item. +@i{TagList} consists of a list of tag names, which replace any +existing tags for the item. +@i{TagList} may be an empty list. +@item @b{:text }@i{string} +@i{String} specifies the characters to be displayed in the text item. +Newline characters cause line breaks. +The characters in the item may also be changed with the +@b{insert}@r{ and }@b{delete} widget commands. +This option defaults to an empty string. +@item @b{:width }@i{lineLength} +Specifies a maximum line length for the text, in any of the forms +described in the COORDINATES section abov. +If this option is zero (the default) the text is broken into +lines only at newline characters. +However, if this option is non-zero then any line that would +be longer than @i{lineLength} is broken just before a space +character to make the line shorter than @i{lineLength}; the +space character is treated as if it were a newline +character. + +@end table +@end table +@unnumberedsubsec Window Items + +Items of type @b{window} cause a particular window to be displayed +at a given position on the canvas. +Window items are created with widget commands of the following form: + +@example +@i{pathName }@b{:create window }@i{x y }@r{?}@i{option value option value ...}? +@end example + +The arguments @i{x}@r{ and }@i{y} specify the coordinates of a +point used to position the window on the display (see the @b{:anchor} +option below for more information on how bitmaps are displayed). +After the coordinates there may be any number of @i{option}@r{-}@i{value} +pairs, each of which sets one of the configuration options +for the item. These same @i{option}\-@i{value} pairs may be +used in @b{itemconfigure} widget commands to change the item's +configuration. +The following options are supported for window items: + +@table @asis +@item @b{:anchor }@i{anchorPos} +@i{AnchorPos} tells how to position the window relative to the +positioning point for the item; it may have any of the forms +accepted by @b{Tk_GetAnchor}@r{. For example, if }@i{anchorPos} +is @b{center} then the window is centered on the point; if +@i{anchorPos}@r{ is }@b{n} then the window will be drawn so that +its top center point is at the positioning point. +This option defaults to @b{center}. +@item @b{:height }@i{pixels} +Specifies the height to assign to the item's window. +@i{Pixels} may have any of the +forms described in the COORDINATES section above. +If this option isn't specified, or if it is specified as an empty +string, then the window is given whatever height it requests internally. +@item @b{:tags }@i{tagList} +Specifies a set of tags to apply to the item. +@i{TagList} consists of a list of tag names, which replace any +existing tags for the item. +@i{TagList} may be an empty list. +@item @b{:width }@i{pixels} +Specifies the width to assign to the item's window. +@i{Pixels} may have any of the +forms described in the COORDINATES section above. +If this option isn't specified, or if it is specified as an empty +string, then the window is given whatever width it requests internally. +@item @b{:window }@i{pathName} +Specifies the window to associate with this item. +The window specified by @i{pathName} must either be a child of +the canvas widget or a child of some ancestor of the canvas widget. +@i{PathName} may not refer to a top-level window. + +@end table +@unnumberedsubsec Application-Defined Item Types + +It is possible for individual applications to define new item +types for canvas widgets using C code. +The interfaces for this mechanism are not presently documented, +and it's possible they may change, but you should be able to +see how they work by examining the code for some of the existing +item types. + +@unnumberedsubsec Bindings + +In the current implementation, new canvases are not given any +default behavior: you'll have to execute explicit Tcl commands +to give the canvas its behavior. + +@unnumberedsubsec Credits + +Tk's canvas widget is a blatant ripoff of ideas from Joel Bartlett's +@i{ezd}@r{ program. }@i{Ezd} provides structured graphics in a Scheme +environment and preceded canvases by a year or two. Its simple +mechanisms for placing and animating graphical objects inspired the +functions of canvases. + +@unnumberedsubsec Keywords +canvas, widget +@node menu, scrollbar, canvas, Widgets +@section menu +@c @cartouche + +menu \- Create and manipulate menu widgets +@unnumberedsubsec Synopsis +@b{menu}@i{ }@i{pathName }@r{?}@i{options}? +@unnumberedsubsec Standard Options + + +@example +activeBackground background disabledForeground +activeBorderWidth borderWidth font +activeForeground cursor foreground +@end example + + +@xref{options}, for more information. +@unnumberedsubsec Arguments for Menu + + +@table @asis +@item @code{@b{:postcommand}} +@flushright +Name=@code{"@b{postCommand}@r{"} Class=@code{"}@b{Command}"} +@end flushright +@sp 1 + +If this option is specified then it provides a Tcl command to execute +each time the menu is posted. The command is invoked by the @b{post} +widget command before posting the menu. +@end table + + +@table @asis +@item @code{@b{:selector}} +@flushright +Name=@code{"@b{selector}@r{"} Class=@code{"}@b{Foreground}"} +@end flushright +@sp 1 + +For menu entries that are check buttons or radio buttons, this option +specifies the color to display in the selector when the check button +or radio button is selected. +@end table +@c @end cartouche + +@unnumberedsubsec Introduction + +The @b{menu} command creates a new top-level window (given +by the @i{pathName} argument) and makes it into a menu widget. +Additional +options, described above, may be specified on the command line +or in the option database +to configure aspects of the menu such as its colors and font. +The @b{menu} command returns its +@i{pathName} argument. At the time this command is invoked, +there must not exist a window named @i{pathName}, but +@i{pathName}'s parent must exist. + +A menu is a widget that displays a collection of one-line entries arranged +in a column. There exist several different types of entries, +each with different properties. Entries of different types may be +combined in a single menu. Menu entries are not the same as +entry widgets. In fact, menu entries are not even distinct widgets; +the entire menu is one widget. + +Menu entries are displayed with up to three +separate fields. The main field is a label in the form of text or +a bitmap, which is determined by the @b{:label}@r{ or }@b{:bitmap} +option for the entry. +If the @b{:accelerator} option is specified for an entry then a second +textual field is displayed to the right of the label. The accelerator +typically describes a keystroke sequence that may be typed in the +application to cause the same result as invoking the menu entry. +The third field is a @i{selector}. The selector is present only for +check-button or radio-button entries. It indicates whether the entry +is selected or not, and is displayed to the left of the entry's +string. + +In normal use, an entry becomes active (displays itself differently) +whenever the mouse pointer is over the entry. If a mouse +button is released over the entry then the entry is @i{invoked}. +The effect of invocation is different for each type of entry; +these effects are described below in the sections on individual +entries. + +Entries may be @i{disabled}, which causes their labels +and accelerators to be displayed +with dimmer colors. A disabled entry cannot be activated or invoked. +Disabled entries may be re-enabled, at which point it becomes +possible to activate and invoke them again. + +@unnumberedsubsec Command Entries + +The most common kind of menu entry is a command entry, which +behaves much like a button widget. When a command entry is +invoked, a Tcl command is executed. The Tcl +command is specified with the @b{:command} option. + +@unnumberedsubsec Separator Entries + +A separator is an entry that is displayed as a horizontal dividing +line. A separator may not be activated or invoked, and it has +no behavior other than its display appearance. + +@unnumberedsubsec Check-Button Entries + +A check-button menu entry behaves much like a check-button widget. +When it is invoked it toggles back and forth between the selected +and deselected states. When the entry is selected, a particular +value is stored in a particular global variable (as determined by +the @b{:onvalue}@r{ and }@b{:variable} options for the entry); when +the entry is deselected another value (determined by the +@b{:offvalue} option) is stored in the global variable. +A selector box is displayed to the left of the label in a check-button +entry. If the entry is selected then the box's center is displayed +in the color given by the @b{selector} option for the menu; +otherwise the box's center is displayed in the background color for +the menu. If a @b{:command} option is specified for a check-button +entry, then its value is evaluated as a Tcl command each time the entry +is invoked; this happens after toggling the entry's +selected state. + +@unnumberedsubsec Radio-Button Entries + +A radio-button menu entry behaves much like a radio-button widget. +Radio-button entries are organized in groups of which only one +entry may be selected at a time. Whenever a particular entry +becomes selected it stores a particular value into a particular +global variable (as determined by the @b{:value} and +@b{:variable} options for the entry). This action +causes any previously-selected entry in the same group +to deselect itself. +Once an entry has become selected, any change to the entry's +associated variable will cause the entry to deselect itself. +Grouping of radio-button entries is determined by their +associated variables: if two entries have the same associated +variable then they are in the same group. +A selector diamond is displayed to the left of the label in each +radio-button entry. If the entry is selected then the diamond's +center is displayed in the color given by the @b{selector} option +for the menu; +otherwise the diamond's center is displayed in the background color for +the menu. If a @b{:command} option is specified for a radio-button +entry, then its value is evaluated as a Tcl command each time the entry +is invoked; this happens after selecting the entry. + +@unnumberedsubsec Cascade Entries + +A cascade entry is one with an associated menu (determined +by the @b{:menu} option). Cascade entries allow the construction +of cascading menus. When the entry is activated, the +associated menu is posted just to the right of the entry; +that menu remains posted until the higher-level menu is unposted or +until some other entry is activated in the higher-level menu. +The associated menu should normally be a child of the menu containing +the cascade entry, in order for menu traversal to work correctly. + +A cascade entry posts its associated menu by invoking a +Tcl command of the form + +@table @asis +@item @i{menu}@b{ :post }@i{x y} + + + +where @i{menu}@r{ is the path name of the associated menu, }@i{x} +and @i{y} are the root-window coordinates of the upper-right +corner of the cascade entry, and @i{group} is the name of the +menu's group (as determined in its last @b{post} widget command). +The lower-level menu is unposted by executing a Tcl command with +the form + +@item @i{menu}@b{:unpost} +where @i{menu} is the name of the associated menu. +@end table + +If a @b{:command} option is specified for a cascade entry then it is +evaluated as a Tcl command each time the associated menu is posted (the +evaluation occurs before the menu is posted). + +@unnumberedsubsec A Menu Widget's Arguments + +The @b{menu} command creates a new Tcl command whose +name is @i{pathName}. This +command may be used to invoke various +operations on the widget. It has the following general form: + +@table @asis +@item @i{pathName option }@r{?}@i{arg arg ...}? +@i{Option}@r{ and the }@i{arg}s +determine the exact behavior of the command. +@end table + +Many of the widget commands for a menu take as one argument an +indicator of which entry of the menu to operate on. These +indicators are called @i{index}es and may be specified in +any of the following forms: + +@table @asis +@item @i{number} +Specifies the entry numerically, where 0 corresponds +to the top-most entry of the menu, 1 to the entry below it, and +so on. +@item @b{active} +Indicates the entry that is currently active. If no entry is +active then this form is equivalent to @b{none}. This form may +not be abbreviated. +@item @b{last} +Indicates the bottommost entry in the menu. If there are no +entries in the menu then this form is equivalent to @b{none}. +This form may not be abbreviated. +@item @b{none} +Indicates ``no entry at all''; this is used most commonly with +the @b{activate} option to deactivate all the entries in the +menu. In most cases the specification of @b{none} causes +nothing to happen in the widget command. +This form may not be abbreviated. +@item @b{@@}@i{number} +In this form, @i{number} is treated as a y-coordinate in the +menu's window; the entry spanning that y-coordinate is used. +For example, ``@b{@@0}'' indicates the top-most entry in the +window. If @i{number} is outside the range of the window +then this form is equivalent to @b{none}. +@item @i{pattern} +If the index doesn't satisfy one of the above forms then this +form is used. @i{Pattern} is pattern-matched against the label of +each entry in the menu, in order from the top down, until a +matching entry is found. The rules of @b{Tcl_StringMatch} +are used. + +The following widget commands are possible for menu widgets: +@item @i{pathName }@b{:activate }@i{index} +Change the state of the entry indicated by @i{index}@r{ to }@b{active} +and redisplay it using its active colors. +Any previously-active entry is deactivated. If @i{index} +is specified as @b{none}, or if the specified entry is +disabled, then the menu ends up with no active entry. +Returns an empty string. +@item @i{pathName }@b{:add }@i{type }@r{?}@i{option value option value ...}? +Add a new entry to the bottom of the menu. The new entry's type +is given by @i{type}@r{ and must be one of }@b{cascade}, +@b{checkbutton}@r{, }@b{command}@r{, }@b{radiobutton}@r{, or }@b{separator}, +or a unique abbreviation of one of the above. If additional arguments +are present, they specify any of the following options: + +@table @asis +@item @b{:activebackground }@i{value} +Specifies a background color to use for displaying this entry when it +is active. +If this option is specified as an empty string (the default), then the +@b{activeBackground} option for the overall menu is used. +This option is not available for separator entries. +@item @b{:accelerator }@i{value} +Specifies a string to display at the right side of the menu entry. +Normally describes an accelerator keystroke sequence that may be +typed to invoke the same function as the menu entry. This option +is not available for separator entries. +@item @b{:background }@i{value} +Specifies a background color to use for displaying this entry when it +is in the normal state (neither active nor disabled). +If this option is specified as an empty string (the default), then the +@b{background} option for the overall menu is used. +This option is not available for separator entries. +@item @b{:bitmap }@i{value} +Specifies a bitmap to display in the menu instead of a textual +label, in any of the forms accepted by @b{Tk_GetBitmap}. +This option overrides the @b{:label} option but may be reset +to an empty string to enable a textual label to be displayed. +This option is not available for separator entries. +@item @b{:command }@i{value} +For command, checkbutton, and radiobutton entries, specifies a +Tcl command to execute when the menu entry is invoked. +For cascade entries, specifies a Tcl command to execute +when the entry is activated (i.e. just before its submenu is +posted). +Not available for separator entries. +@item @b{:font }@i{value} +Specifies the font to use when drawing the label or accelerator +string in this entry. +If this option is specified as an empty string (the default) then +the @b{font} option for the overall menu is used. +This option is not available for separator entries. +@item @b{:label }@i{value} +Specifies a string to display as an identifying label in the menu +entry. Not available for separator entries. +@item @b{:menu }@i{value} +Available only for cascade entries. Specifies the path name of +the menu associated with this entry. +@item @b{:offvalue }@i{value} +Available only for check-button entries. Specifies the value to +store in the entry's associated variable when the entry is +deselected. +@item @b{:onvalue }@i{value} +Available only for check-button entries. Specifies the value to +store in the entry's associated variable when the entry is selected. +@item @b{:state }@i{value} +Specifies one of three states for the entry: @b{normal}@r{, }@b{active}, +or @b{disabled}. In normal state the entry is displayed using the +@b{foreground}@r{ option for the menu and the }@b{background} +option from the entry or the menu. +The active state is typically used when the pointer is over the entry. +In active state the entry is displayed using the @b{activeForeground} +option for the menu along with the @b{activebackground} option from +the entry. +Disabled state means that the entry is insensitive: it doesn't activate +and doesn't respond to mouse button presses or releases. +In this state the entry is displayed according to the +@b{disabledForeground} option for the menu and the +@b{background} option from the entry. +This option is not available for separator entries. +@item @b{:underline }@i{value} +Specifies the integer index of a character to underline in the entry. +This option is typically used to indicate keyboard traversal characters. +0 corresponds to the first character of the text displayed in the entry, +1 to the next character, and so on. +If a bitmap is displayed in the entry then this option is ignored. +This option is not available for separator entries. +@item @b{:value }@i{value} +Available only for radio-button entries. Specifies the value to +store in the entry's associated variable when the entry is selected. +@item @b{:variable }@i{value} +Available only for check-button and radio-button entries. Specifies +the name of a global value to set when the entry is selected. +For check-button entries the variable is also set when the entry +is deselected. For radio-button entries, changing the variable +causes the currently-selected entry to deselect itself. +@end table +@end table + +The @b{add} widget command returns an empty string. + + +@table @asis +@item @i{pathName }@b{:configure}@r{ ?}@i{option}@r{? ?}@i{value option value ...}? +Query or modify the configuration options of the widget. +If no @i{option} is specified, returns a list describing all of +the available options for @i{pathName}@r{ (see }@b{Tk_ConfigureInfo} for +information on the format of this list). If @i{option} is specified +with no @i{value}, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no @i{option} is specified). If +one or more @i{option:value} pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +@i{Option}@r{ may have any of the values accepted by the }@b{menu} +command. +@item @i{pathName }@b{:delete }@i{index1}@r{ ?}@i{index2}? +Delete all of the menu entries between @i{index1} and +@i{index2} inclusive. +If @i{index2}@r{ is omitted then it defaults to }@i{index1}. +Returns an empty string. +@item @i{pathName }@b{:disable }@i{index} +Change the state of the entry given by @i{index}@r{ to }@b{disabled} +and redisplay the entry using its disabled colors. +Returns an empty string. +This command is obsolete and will eventually be removed; +use ``@i{pathName }@b{:entryconfigure }@i{index}@r{ :state disabled}'' instead. +@item @i{pathName }@b{:enable }@i{index} +Change the state of the entry given by @i{index}@r{ to }@b{normal} +and redisplay the entry using its normal colors. +Returns an empty string. +This command is obsolete and will eventually be removed; +use ``@i{pathName }@b{:entryconfigure }@i{index}@r{ :state normal}'' instead. +@item @i{pathName }@b{:entryconfigure }@i{index}@r{ }@r{?}@i{options}? +This command is similar to the @b{configure} command, except that +it applies to the options for an individual entry, whereas @b{configure} +applies to the options for the menu as a whole. +@i{Options}@r{ may have any of the values accepted by the }@b{add} +widget command. If @i{options} are specified, options are modified +as indicated +in the command and the command returns an empty string. +If no @i{options} are specified, returns a list describing +the current options for entry @i{index}@r{ (see }@b{Tk_ConfigureInfo} for +information on the format of this list). +@item @i{pathName }@b{:index }@i{index} +Returns the numerical index corresponding to @i{index}, or +@b{none}@r{ if }@i{index}@r{ was specified as }@b{none}. +@item @i{pathName }@b{:invoke }@i{index} +Invoke the action of the menu entry. See the sections on the +individual entries above for details on what happens. If the +menu entry is disabled then nothing happens. If the +entry has a command associated with it then the result of that +command is returned as the result of the @b{invoke} widget +command. Otherwise the result is an empty string. Note: invoking +a menu entry does not automatically unpost the menu. Normally +the associated menubutton will take care of unposting the menu. +@item @i{pathName }@b{:post }@i{x y} +Arrange for the menu to be displayed on the screen at the root-window +coordinates given by @i{x}@r{ and }@i{y}. These coordinates are +adjusted if necessary to guarantee that the entire menu is visible on +the screen. This command normally returns an empty string. +If the @b{:postcommand} option has been specified, then its value is +executed as a Tcl script before posting the menu and the result of +that script is returned as the result of the @b{post} widget +command. +If an error returns while executing the command, then the error is +returned without posting the menu. +@item @i{pathName }@b{:unpost} +Unmap the window so that it is no longer displayed. If a +lower-level cascaded menu is posted, unpost that menu. Returns an +empty string. +@item @i{pathName }@b{:yposition }@i{index} +Returns a decimal string giving the y-coordinate within the menu +window of the topmost pixel in the entry specified by @i{index}. + + +@end table +@unnumberedsubsec Default Bindings + + +Tk automatically creates class bindings for menus that give them +the following default behavior: +@itemize @asis{} +@item +[1] +When the mouse cursor enters a menu, the entry underneath the mouse +cursor is activated; as the mouse moves around the menu, the active +entry changes to track the mouse. +@item +[2] +When button 1 is released over a menu, the active entry (if any) is invoked. +@item +[3] +A menu can be repositioned on the screen by dragging it with mouse +button 2. +@item +[4] +A number of other bindings are created to support keyboard menu traversal. +See the manual entry for @b{tk_bindForTraversal} for details on these +bindings. +@end itemize + +Disabled menu entries are non-responsive: they don't activate and +ignore mouse button presses and releases. + +The behavior of menus can be changed by defining new bindings for +individual widgets or by redefining the class bindings. + +@unnumberedsubsec Bugs + +At present it isn't possible to use the +option database to specify values for the options to individual +entries. + +@unnumberedsubsec Keywords +menu, widget +@node scrollbar, checkbutton, menu, Widgets +@section scrollbar +@c @cartouche + +scrollbar \- Create and manipulate scrollbar widgets +@unnumberedsubsec Synopsis +@b{scrollbar}@i{ pathName }@r{?}@i{options}? +@unnumberedsubsec Standard Options + + +@example +activeForeground cursor relief +background foreground repeatDelay +borderWidth orient repeatInterval +@end example + + +@xref{options}, for more information. +@unnumberedsubsec Arguments for Scrollbar + + +@table @asis +@item @code{@b{:command}} +@flushright +Name=@code{"@b{command}@r{"} Class=@code{"}@b{Command}"} +@end flushright +@sp 1 + +Specifies the prefix of a Tcl command to invoke to change the view +in the widget associated with the scrollbar. When a user requests +a view change by manipulating the scrollbar, a Tcl command is +invoked. The actual command consists of this option followed by +a space and a number. The number indicates the logical unit that +should appear at the top of the associated window. +@end table + + +@table @asis +@item @code{@b{:width}} +@flushright +Name=@code{"@b{width}@r{"} Class=@code{"}@b{Width}"} +@end flushright +@sp 1 + +Specifies the desired narrow dimension of the scrollbar window, +not including 3-D border, if any. For vertical +scrollbars this will be the width and for horizontal scrollbars +this will be the height. +The value may have any of the forms acceptable to @b{Tk_GetPixels}. +@end table +@c @end cartouche + +@unnumberedsubsec Description + +The @b{scrollbar} command creates a new window (given by the +@i{pathName} argument) and makes it into a scrollbar widget. +Additional +options, described above, may be specified on the command line +or in the option database +to configure aspects of the scrollbar such as its colors, orientation, +and relief. The @b{scrollbar} command returns its +@i{pathName} argument. At the time this command is invoked, +there must not exist a window named @i{pathName}, but +@i{pathName}'s parent must exist. + +A scrollbar is a widget that displays two arrows, one at each end of +the scrollbar, and a @i{slider} in the middle portion of the +scrollbar. A scrollbar is used to provide information about what +is visible in an @i{associated window} that displays an object +of some sort (such as a file being edited or a drawing). +The position and size of the slider indicate which portion of the +object is visible in the associated window. For example, if the +slider in a vertical scrollbar covers the top third of the area +between the two arrows, it means that the associated window displays +the top third of its object. + +Scrollbars can be used to adjust the view in the associated window +by clicking or dragging with the mouse. See the BINDINGS section +below for details. + +@unnumberedsubsec A Scrollbar Widget's Arguments + +The @b{scrollbar} command creates a new Tcl command whose +name is @i{pathName}. This +command may be used to invoke various +operations on the widget. It has the following general form: + +@example +@i{pathName option }@r{?}@i{arg arg ...}? +@end example + +@i{Option}@r{ and the }@i{arg}s +determine the exact behavior of the command. The following +commands are possible for scrollbar widgets: + +@table @asis +@item @i{pathName }@b{:configure}@r{ ?}@i{option}@r{? ?}@i{value option value ...}? +Query or modify the configuration options of the widget. +If no @i{option} is specified, returns a list describing all of +the available options for @i{pathName}@r{ (see }@b{Tk_ConfigureInfo} for +information on the format of this list). If @i{option} is specified +with no @i{value}, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no @i{option} is specified). If +one or more @i{option:value} pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +@i{Option}@r{ may have any of the values accepted by the }@b{scrollbar} +command. +@item @i{pathName }@b{:get} +Returns a Tcl list containing four decimal values, which are +the current @i{totalUnits}@r{, }@i{widnowUnits}@r{, }@i{firstUnit}, +and @i{lastUnit} values for the scrollbar. These are the values +from the most recent @b{set} widget command on the scrollbar. +@item @i{pathName }@b{:set}@r{ }@i{totalUnits windowUnits firstUnit lastUnit} +This command is invoked to give the scrollbar information about the +widget associated with the scrollbar. @i{TotalUnits} is an integer +value giving the total size of the object being displayed in the +associated widget. The meaning of one unit depends on the associated +widget; for example, in a text editor widget units might +correspond to lines of +text. @i{WindowUnits} indicates the total number of units that +can fit in the associated window at one time. @i{FirstUnit} +and @i{lastUnit} give the indices of the first and last units +currently visible in the associated window (zero corresponds to the +first unit of the object). This command should +be invoked by the associated widget whenever its object or window +changes size and whenever it changes the view in its window. + +@end table +@unnumberedsubsec Bindings + +The description below assumes a vertically-oriented scrollbar. +For a horizontally-oriented scrollbar replace the words ``up'', ``down'', +``top'', and ``bottom'' with ``left'', ``right'', ``left'', +and ``right'', respectively + +A scrollbar widget is divided into five distinct areas. From top +to bottom, they are: the top arrow, the top gap (the empty space +between the arrow and the slider), the slider, the bottom gap, +and the bottom arrow. Pressing mouse button 1 in each area has +a different effect: + +@table @asis +@item @b{top arrow} +Causes the view in the associated window to shift up by one unit +(i.e. the object appears to move down one unit in its window). +If the button is held down the action will auto-repeat. +@item @b{top gap} +Causes the view in the associated window to shift up by one +less than the number of units in the window +(i.e. the portion of the object that used to appear at the very +top of the window will now appear at the very bottom). +If the button is held down the action will auto-repeat. +@item @b{slider} +Pressing button 1 in this area has no immediate effect except to +cause the slider to appear sunken rather than raised. However, +if the mouse is moved with the button down then the slider will +be dragged, adjusting the view as the mouse is moved. +@item @b{bottom gap} +Causes the view in the associated window to shift down by one +less than the number of units in the window +(i.e. the portion of the object that used to appear at the very +bottom of the window will now appear at the very top). +If the button is held down the action will auto-repeat. +@item @b{bottom arrow} +Causes the view in the associated window to shift down by one unit +(i.e. the object appears to move up one unit in its window). +If the button is held down the action will auto-repeat. + +Note: none of the actions described above has an immediate impact +on the position of the slider in the scrollbar. It simply invokes +the command specified in the @b{command} option to notify the +associated widget that a change in view is desired. If the view is +actually changed then the associated widget must invoke the +scrollbar's @b{set} widget command to change what is displayed in +the scrollbar. + +@end table +@unnumberedsubsec Keywords +scrollbar, widget +@node checkbutton, menubutton, scrollbar, Widgets +@section checkbutton +@c @cartouche + +checkbutton \- Create and manipulate check-button widgets +@unnumberedsubsec Synopsis +@b{checkbutton}@i{ pathName }@r{?}@i{options}? +@unnumberedsubsec Standard Options + + +@example +activeBackground bitmap font relief +activeForeground borderWidth foreground text +anchor cursor padX textVariable +background disabledForeground padY +@end example + + +@xref{options}, for more information. +@unnumberedsubsec Arguments for Checkbutton + + +@table @asis +@item @code{@b{:command}} +@flushright +Name=@code{"@b{command}@r{"} Class=@code{"}@b{Command}"} +@end flushright +@sp 1 + +Specifies a Tcl command to associate with the button. This command +is typically invoked when mouse button 1 is released over the button +window. The button's global variable (@b{:variable} option) will +be updated before the command is invoked. +@end table + + +@table @asis +@item @code{@b{:height}} +@flushright +Name=@code{"@b{height}@r{"} Class=@code{"}@b{Height}"} +@end flushright +@sp 1 + +Specifies a desired height for the button. +If a bitmap is being displayed in the button then the value is in +screen units (i.e. any of the forms acceptable to @b{Tk_GetPixels}); +for text it is in lines of text. +If this option isn't specified, the button's desired height is computed +from the size of the bitmap or text being displayed in it. +@end table + + +@table @asis +@item @code{@b{:offvalue}} +@flushright +Name=@code{"@b{offValue}@r{"} Class=@code{"}@b{Value}"} +@end flushright +@sp 1 + +Specifies value to store in the button's associated variable whenever +this button is deselected. Defaults to ``0''. +@end table + + +@table @asis +@item @code{@b{:onvalue}} +@flushright +Name=@code{"@b{onValue}@r{"} Class=@code{"}@b{Value}"} +@end flushright +@sp 1 + +Specifies value to store in the button's associated variable whenever +this button is selected. Defaults to ``1''. +@end table + + +@table @asis +@item @code{@b{:selector}} +@flushright +Name=@code{"@b{selector}@r{"} Class=@code{"}@b{Foreground}"} +@end flushright +@sp 1 + +Specifies the color to draw in the selector when this button is +selected. +If specified as an empty string then no selector is +drawn for the button. +@end table + + +@table @asis +@item @code{@b{:state}} +@flushright +Name=@code{"@b{state}@r{"} Class=@code{"}@b{State}"} +@end flushright +@sp 1 + +Specifies one of three states for the check button: @b{normal}@r{, }@b{active}, +or @b{disabled}. In normal state the check button is displayed using the +@b{foreground}@r{ and }@b{background} options. The active state is +typically used when the pointer is over the check button. In active state +the check button is displayed using the @b{activeForeground} and +@b{activeBackground} options. Disabled state means that the check button +is insensitive: it doesn't activate and doesn't respond to mouse +button presses. In this state the @b{disabledForeground} and +@b{background} options determine how the check button is displayed. +@end table + + +@table @asis +@item @code{@b{:variable}} +@flushright +Name=@code{"@b{variable}@r{"} Class=@code{"}@b{Variable}"} +@end flushright +@sp 1 + +Specifies name of global variable to set to indicate whether +or not this button is selected. Defaults to the name of the +button within its parent (i.e. the last element of the button +window's path name). +@end table + + +@table @asis +@item @code{@b{:width}} +@flushright +Name=@code{"@b{width}@r{"} Class=@code{"}@b{Width}"} +@end flushright +@sp 1 + +Specifies a desired width for the button. +If a bitmap is being displayed in the button then the value is in +screen units (i.e. any of the forms acceptable to @b{Tk_GetPixels}); +for text it is in characters. +If this option isn't specified, the button's desired width is computed +from the size of the bitmap or text being displayed in it. +@end table +@c @end cartouche + +@unnumberedsubsec Description + +The @b{checkbutton} command creates a new window (given by the +@i{pathName} argument) and makes it into a check-button widget. +Additional +options, described above, may be specified on the command line +or in the option database +to configure aspects of the check button such as its colors, font, +text, and initial relief. The @b{checkbutton} command returns its +@i{pathName} argument. At the time this command is invoked, +there must not exist a window named @i{pathName}, but +@i{pathName}'s parent must exist. + +A check button is a widget +that displays a textual string or bitmap +and a square called a @i{selector}. +A check button has +all of the behavior of a simple button, including the +following: it can display itself in either of three different +ways, according to the @b{state} option; +it can be made to appear +raised, sunken, or flat; it can be made to flash; and it invokes +a Tcl command whenever mouse button 1 is clicked over the +check button. + +In addition, check buttons can be @i{selected}. If a check button is +selected then a special highlight appears in the selector, and +a Tcl variable associated with the check button is set to a particular +value (normally 1). If the check button is not selected, then +the selector is drawn in a different fashion and the associated +variable is set to a different value (typically 0). By default, +the name of the variable associated with a check button is the +same as the @i{name} used to create the check button. The +variable name, and the ``on'' and ``off'' values stored in it, +may be modified with options on the command line or in the option +database. By default a check button is configured to select and deselect +itself on alternate button clicks. +In addition, each check button monitors its associated variable and +automatically selects and deselects itself when the variables value +changes to and from the button's ``on'' value. + +@unnumberedsubsec A Checkbutton Widget's Arguments + +The @b{checkbutton} command creates a new Tcl command whose +name is @i{pathName}. This +command may be used to invoke various +operations on the widget. It has the following general form: + +@example +@i{pathName option }@r{?}@i{arg arg ...}? +@end example + +@i{Option}@r{ and the }@i{arg}s +determine the exact behavior of the command. The following +commands are possible for check button widgets: + +@table @asis +@item @i{pathName }@b{:activate} +Change the check button's state to @b{active} and redisplay the button +using its active foreground and background colors instead of normal +colors. +This command is ignored if the check button's state is @b{disabled}. +This command is obsolete and will eventually be removed; +use ``@i{pathName }@b{:configure :state active}'' instead. +@item @i{pathName }@b{:configure}@r{ ?}@i{option}@r{? ?}@i{value option value ...}? +Query or modify the configuration options of the widget. +If no @i{option} is specified, returns a list describing all of +the available options for @i{pathName}@r{ (see }@b{Tk_ConfigureInfo} for +information on the format of this list). If @i{option} is specified +with no @i{value}, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no @i{option} is specified). If +one or more @i{option:value} pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +@i{Option}@r{ may have any of the values accepted by the }@b{checkbutton} +command. +@item @i{pathName }@b{:deactivate} +Change the check button's state to @b{normal} and redisplay the button +using its normal foreground and background colors. +This command is ignored if the check button's state is @b{disabled}. +This command is obsolete and will eventually be removed; +use ``@i{pathName }@b{:configure :state normal}'' instead. +@item @i{pathName }@b{:deselect} +Deselect the check button: redisplay it without a highlight in +the selector and set the associated variable to its ``off'' +value. +@item @i{pathName }@b{:flash} +Flash the check button. This is accomplished by redisplaying the check button +several times, alternating between active and normal colors. At +the end of the flash the check button is left in the same normal/active +state as when the command was invoked. +This command is ignored if the check button's state is @b{disabled}. +@item @i{pathName }@b{:invoke} +Does just what would have happened if the user invoked the check button +with the mouse: toggle the selection state of the button and invoke +the Tcl command associated with the check button, if there is one. +The return value is the return value from the Tcl command, or an +empty string if there is no command associated with the check button. +This command is ignored if the check button's state is @b{disabled}. +@item @i{pathName }@b{:select} +Select the check button: display it with a highlighted +selector and set the associated variable to its ``on'' +value. +@item @i{pathName }@b{:toggle} +Toggle the selection state of the button, redisplaying it and +modifying its associated variable to reflect the new state. + +@end table +@unnumberedsubsec Bindings + +Tk automatically creates class bindings for check buttons that give them +the following default behavior: +@itemize @asis{} +@item +[1] +The check button activates whenever the mouse passes over it and deactivates +whenever the mouse leaves the check button. +@item +[2] +The check button's relief is changed to sunken whenever mouse button 1 is +pressed over it, and the relief is restored to its original +value when button 1 is later released. +@item +[3] +If mouse button 1 is pressed over the check button and later released over +the check button, the check button is invoked (i.e. its selection +state toggles and the command associated with the button is invoked, +if there is one). However, if the mouse is not +over the check button when button 1 is released, then no invocation occurs. +@end itemize + +If the check button's state is @b{disabled} then none of the above +actions occur: the check button is completely non-responsive. + +The behavior of check buttons can be changed by defining new bindings for +individual widgets or by redefining the class bindings. + +@unnumberedsubsec Keywords +check button, widget +@node menubutton, text, checkbutton, Widgets +@section menubutton +@c @cartouche + +menubutton \- Create and manipulate menubutton widgets +@unnumberedsubsec Synopsis +@b{menubutton}@i{ }@i{pathName }@r{?}@i{options}? +@unnumberedsubsec Standard Options + + +@example +activeBackground bitmap font relief +activeForeground borderWidth foreground text +anchor cursor padX textVariable +background disabledForeground padY underline +@end example + + +@xref{options}, for more information. +@unnumberedsubsec Arguments for Menubutton + + +@table @asis +@item @code{@b{:height}} +@flushright +Name=@code{"@b{height}@r{"} Class=@code{"}@b{Height}"} +@end flushright +@sp 1 + +Specifies a desired height for the menu button. +If a bitmap is being displayed in the menu button then the value is in +screen units (i.e. any of the forms acceptable to @b{Tk_GetPixels}); +for text it is in lines of text. +If this option isn't specified, the menu button's desired height is computed +from the size of the bitmap or text being displayed in it. +@end table + + +@table @asis +@item @code{@b{:menu}} +@flushright +Name=@code{"@b{menu}@r{"} Class=@code{"}@b{MenuName}"} +@end flushright +@sp 1 + +Specifies the path name of the menu associated with this menubutton. +The menu must be a descendant of the menubutton in order for normal pull-down +operation to work via the mouse. +@end table + + +@table @asis +@item @code{@b{:state}} +@flushright +Name=@code{"@b{state}@r{"} Class=@code{"}@b{State}"} +@end flushright +@sp 1 + +Specifies one of three states for the menu button: @b{normal}@r{, }@b{active}, +or @b{disabled}. In normal state the menu button is displayed using the +@b{foreground}@r{ and }@b{background} options. The active state is +typically used when the pointer is over the menu button. In active state +the menu button is displayed using the @b{activeForeground} and +@b{activeBackground} options. Disabled state means that the menu button +is insensitive: it doesn't activate and doesn't respond to mouse +button presses. In this state the @b{disabledForeground} and +@b{background} options determine how the button is displayed. +@end table + + +@table @asis +@item @code{@b{:width}} +@flushright +Name=@code{"@b{width}@r{"} Class=@code{"}@b{Width}"} +@end flushright +@sp 1 + +Specifies a desired width for the menu button. +If a bitmap is being displayed in the menu button then the value is in +screen units (i.e. any of the forms acceptable to @b{Tk_GetPixels}); +for text it is in characters. +If this option isn't specified, the menu button's desired width is computed +from the size of the bitmap or text being displayed in it. +@end table +@c @end cartouche + +@unnumberedsubsec Introduction + +The @b{menubutton} command creates a new window (given by the +@i{pathName} argument) and makes it into a menubutton widget. +Additional +options, described above, may be specified on the command line +or in the option database +to configure aspects of the menubutton such as its colors, font, +text, and initial relief. The @b{menubutton} command returns its +@i{pathName} argument. At the time this command is invoked, +there must not exist a window named @i{pathName}, but +@i{pathName}'s parent must exist. + +A menubutton is a widget that displays a +textual string or bitmap +and is associated with a menu widget. In normal usage, pressing +mouse button 1 over the menubutton causes the associated menu to +be posted just underneath the menubutton. If the mouse is moved over +the menu before releasing the mouse button, the button release +causes the underlying menu entry to be invoked. When the button +is released, the menu is unposted. + +Menubuttons are typically organized into groups called menu bars +that allow scanning: +if the mouse button is pressed over one menubutton (causing it +to post its menu) and the mouse is moved over another menubutton +in the same menu bar without releasing the mouse button, then the +menu of the first menubutton is unposted and the menu of the +new menubutton is posted instead. +The @b{tk-menu-bar} procedure is used to set up menu bars for +scanning; see that procedure for more details. + +@unnumberedsubsec A Menubutton Widget's Arguments + +The @b{menubutton} command creates a new Tcl command whose +name is @i{pathName}. This +command may be used to invoke various +operations on the widget. It has the following general form: + +@example +@i{pathName option }@r{?}@i{arg arg ...}? +@end example + +@i{Option}@r{ and the }@i{arg}s +determine the exact behavior of the command. The following +commands are possible for menubutton widgets: + +@table @asis +@item @i{pathName }@b{:activate} +Change the menu button's state to @b{active} and redisplay the menu +button using its active foreground and background colors instead of normal +colors. +The command returns an empty string. +This command is ignored if the menu button's state is @b{disabled}. +This command is obsolete and will eventually be removed; +use ``@i{pathName }@b{:configure :state active}'' instead. +@item @i{pathName }@b{:configure}@r{ ?}@i{option}@r{? ?}@i{value option value ...}? +Query or modify the configuration options of the widget. +If no @i{option} is specified, returns a list describing all of +the available options for @i{pathName}@r{ (see }@b{Tk_ConfigureInfo} for +information on the format of this list). If @i{option} is specified +with no @i{value}, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no @i{option} is specified). If +one or more @i{option:value} pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +@i{Option}@r{ may have any of the values accepted by the }@b{menubutton} +command. +@item @i{pathName }@b{:deactivate} +Change the menu button's state to @b{normal} and redisplay the menu +button using its normal foreground and background colors. +The command returns an empty string. +This command is ignored if the menu button's state is @b{disabled}. +This command is obsolete and will eventually be removed; +use ``@i{pathName }@b{:configure :state normal}'' instead. + +@end table +@unnumberedsubsec "Default Bindings" + + +Tk automatically creates class bindings for menu buttons that give them +the following default behavior: +@itemize @asis{} +@item +[1] +A menu button activates whenever the mouse passes over it and deactivates +whenever the mouse leaves it. +@item +[2] +A menu button's relief is changed to raised whenever mouse button 1 is +pressed over it, and the relief is restored to its original value +when button 1 is later released or the mouse is dragged into another +menu button in the same menu bar. +@item +[3] +When mouse button 1 is pressed over a menu button, or when the mouse +is dragged into a menu button with mouse button 1 pressed, the associated +menu is posted; the mouse can be dragged across the menu and released +over an entry in the menu to invoke that entry. The menu is unposted +when button 1 is released outside either the menu or the menu button. +The menu is also unposted when the mouse is dragged into another +menu button in the same menu bar. +@item +[4] +If mouse button 1 is pressed and released within the menu button, +then the menu stays posted and keyboard traversal is possible as +described in the manual entry for @b{tk-menu-bar}. +@item +[5] +Menubuttons may also be posted by typing characters on the keyboard. +See the manual entry for @b{tk-menu-bar} for full details on keyboard +menu traversal. +@item +[6] +If mouse button 2 is pressed over a menu button then the associated +menu is posted and also @i{torn off}: it can then be dragged around on +the screen with button 2 and the menu will not automatically unpost when +entries in it are invoked. +To close a torn off menu, click mouse button 1 over the associated +menu button. +@end itemize + +If the menu button's state is @b{disabled} then none of the above +actions occur: the menu button is completely non-responsive. + +The behavior of menu buttons can be changed by defining new bindings for +individual widgets or by redefining the class bindings. + +@unnumberedsubsec Keywords +menubutton, widget +@node text, entry, menubutton, Widgets +@section text +@c @cartouche + +text \- Create and manipulate text widgets +@unnumberedsubsec Synopsis +@b{text}@i{ }@i{pathName }@r{?}@i{options}? +@unnumberedsubsec Standard Options + + +@example +background foreground insertWidth selectBorderWidth +borderWidth insertBackground padX selectForeground +cursor insertBorderWidth padY setGrid +exportSelection insertOffTime relief yScrollCommand +font insertOnTime selectBackground +@end example + + +@xref{options}, for more information. +@unnumberedsubsec Arguments for Text + + +@table @asis +@item @code{@b{:height}} +@flushright +Name=@code{"@b{height}@r{"} Class=@code{"}@b{Height}"} +@end flushright +@sp 1 + +Specifies the desired height for the window, in units of characters. +Must be at least one. +@end table + + +@table @asis +@item @code{@b{:state}} +@flushright +Name=@code{"@b{state}@r{"} Class=@code{"}@b{State}"} +@end flushright +@sp 1 + +Specifies one of two states for the text: @b{normal}@r{ or }@b{disabled}. +If the text is disabled then characters may not be inserted or deleted +and no insertion cursor will be displayed, even if the input focus is +in the widget. +@end table + + +@table @asis +@item @code{@b{:width}} +@flushright +Name=@code{"@b{width}@r{"} Class=@code{"}@b{Width}"} +@end flushright +@sp 1 + +Specifies the desired width for the window in units of characters. +If the font doesn't have a uniform width then the width of the +character ``0'' is used in translating from character units to +screen units. +@end table + + +@table @asis +@item @code{@b{:wrap}} +@flushright +Name=@code{"@b{wrap}@r{"} Class=@code{"}@b{Wrap}"} +@end flushright +@sp 1 + +Specifies how to handle lines in the text that are too long to be +displayed in a single line of the text's window. +The value must be @b{none}@r{ or }@b{char}@r{ or }@b{word}. +A wrap mode of @b{none} means that each line of text appears as +exactly one line on the screen; extra characters that don't fit +on the screen are not displayed. +In the other modes each line of text will be broken up into several +screen lines if necessary to keep all the characters visible. +In @b{char} mode a screen line break may occur after any character; +in @b{word} mode a line break will only be made at word boundaries. +@end table +@c @end cartouche + +@unnumberedsubsec Description + +The @b{text} command creates a new window (given by the +@i{pathName} argument) and makes it into a text widget. +Additional +options, described above, may be specified on the command line +or in the option database +to configure aspects of the text such as its default background color +and relief. The @b{text} command returns the +path name of the new window. + +A text widget displays one or more lines of text and allows that +text to be edited. +Text widgets support three different kinds of annotations on the +text, called tags, marks, and windows. +Tags allow different portions of the text +to be displayed with different fonts and colors. +In addition, Tcl commands can be associated with tags so +that commands are invoked when particular actions such as keystrokes +and mouse button presses occur in particular ranges of the text. +See TAGS below for more details. + +The second form of annotation consists of marks, which are floating +markers in the text. +Marks are used to keep track of various interesting positions in the +text as it is edited. +See MARKS below for more details. + +The third form of annotation allows arbitrary windows to be displayed +in the text widget. +See WINDOWS below for more details. + +@unnumberedsubsec Indices + +Many of the widget commands for texts take one or more indices +as arguments. +An index is a string used to indicate a particular place within +a text, such as a place to insert characters or one endpoint of a +range of characters to delete. +Indices have the syntax + +@i{base modifier modifier modifier ...} + + +Where @i{base}@r{ gives a starting point and the }@i{modifier}s +adjust the index from the starting point (e.g. move forward or +backward one character). Every index must contain a @i{base}, +but the @i{modifier}s are optional. + + +The @i{base} for an index must have one of the following forms: + +@table @asis +@item @i{line}@b{.}@i{char} +Indicates @i{char}@r{'th character on line }@i{line}. +Lines are numbered from 1 for consistency with other UNIX programs +that use this numbering scheme. +Within a line, characters are numbered from 0. +@item @b{@@}@i{x}@b{,}@i{y} +Indicates the character that covers the pixel whose x and y coordinates +within the text's window are @i{x}@r{ and }@i{y}. +@item @b{end} +Indicates the last character in the text, which is always a newline +character. +@item @i{mark} +Indicates the character just after the mark whose name is @i{mark}. +@item @i{tag}@b{.first} +Indicates the first character in the text that has been tagged with +@i{tag}. +This form generates an error if no characters are currently tagged +with @i{tag}. +@item @i{tag}@b{.last} +Indicates the character just after the last one in the text that has +been tagged with @i{tag}. +This form generates an error if no characters are currently tagged +with @i{tag}. +@end table + + +If modifiers follow the base index, each one of them must have one +of the forms listed below. Keywords such as @b{chars}@r{ and }@b{wordend} +may be abbreviated as long as the abbreviation is unambiguous. + +@table @asis +@item @b{+ }@i{count}@b{ chars} +Adjust the index forward by @i{count} characters, moving to later +lines in the text if necessary. If there are fewer than @i{count} +characters in the text after the current index, then set the index +to the last character in the text. +Spaces on either side of @i{count} are optional. +@item @b{-} @i{count}@b{ chars} +Adjust the index backward by @i{count} characters, moving to earlier +lines in the text if necessary. If there are fewer than @i{count} +characters in the text before the current index, then set the index +to the first character in the text. +Spaces on either side of @i{count} are optional. +@item @b{+ }@i{count}@b{ lines} +Adjust the index forward by @i{count} lines, retaining the same +character position within the line. If there are fewer than @i{count} +lines after the line containing the current index, then set the index +to refer to the same character position on the last line of the text. +Then, if the line is not long enough to contain a character at the indicated +character position, adjust the character position to refer to the last +character of the line (the newline). +Spaces on either side of @i{count} are optional. +@item @b{-} @i{count}@b{ lines} +Adjust the index backward by @i{count} lines, retaining the same +character position within the line. If there are fewer than @i{count} +lines before the line containing the current index, then set the index +to refer to the same character position on the first line of the text. +Then, if the line is not long enough to contain a character at the indicated +character position, adjust the character position to refer to the last +character of the line (the newline). +Spaces on either side of @i{count} are optional. +@item @b{linestart} +Adjust the index to refer to the first character on the line. +@item @b{lineend} +Adjust the index to refer to the last character on the line (the newline). +@item @b{wordstart} +Adjust the index to refer to the first character of the word containing +the current index. A word consists of any number of adjacent characters +that are letters, digits, or underscores, or a single character that +is not one of these. +@item @b{wordend} +Adjust the index to refer to the character just after the last one of the +word containing the current index. If the current index refers to the last +character of the text then it is not modified. +@end table + + +If more than one modifier is present then they are applied in +left-to-right order. For example, the index ``\fBend \- 1 chars'' +refers to the next-to-last character in the text and +``\fBinsert wordstart \- 1 c'' refers to the character just before +the first one in the word containing the insertion cursor. + +@unnumberedsubsec Tags + +The first form of annotation in text widgets is a tag. +A tag is a textual string that is associated with some of the characters +in a text. +There may be any number of tags associated with characters in a +text. +Each tag may refer to a single character, a range of characters, or +several ranges of characters. +An individual character may have any number of tags associated with it. + +A priority order is defined among tags, and this order is used in +implementing some of the tag-related functions described below. +When a tag is defined (by associating it with characters or setting +its display options or binding commands to it), it is given +a priority higher than any existing tag. +The priority order of tags may be redefined using the +``@i{pathName }@b{:tag :raise}@r{'' and ``}@i{pathName }@b{:tag :lower}'' +widget commands. + +Tags serve three purposes in text widgets. +First, they control the way information is displayed on the screen. +By default, characters are displayed as determined by the +@b{background}@r{, }@b{font}@r{, and }@b{foreground} options for the +text widget. +However, display options may be associated with individual tags +using the ``@i{pathName }@b{:tag configure}'' widget command. +If a character has been tagged, then the display options associated +with the tag override the default display style. +The following options are currently supported for tags: + +@table @asis +@item @b{:background }@i{color} +@i{Color} specifies the background color to use for characters +associated with the tag. +It may have any of the forms accepted by @b{Tk_GetColor}. +@item @b{:bgstipple }@i{bitmap} +@i{Bitmap} specifies a bitmap that is used as a stipple pattern +for the background. +It may have any of the forms accepted by @b{Tk_GetBitmap}. +If @i{bitmap} hasn't been specified, or if it is specified +as an empty string, then a solid fill will be used for the +background. +@item @b{:borderwidth }@i{pixels} +@i{Pixels} specifies the width of a 3-D border to draw around +the background. +It may have any of the forms accepted by @b{Tk_GetPixels}. +This option is used in conjunction with the @b{:relief} +option to give a 3-D appearance to the background for characters; +it is ignored unless the @b{:background} option +has been set for the tag. +@item @b{:fgstipple }@i{bitmap} +@i{Bitmap} specifies a bitmap that is used as a stipple pattern +when drawing text and other foreground information such as +underlines. +It may have any of the forms accepted by @b{Tk_GetBitmap}. +If @i{bitmap} hasn't been specified, or if it is specified +as an empty string, then a solid fill will be used. +@item @b{:font }@i{fontName} +@i{FontName} is the name of a font to use for drawing characters. +It may have any of the forms accepted by @b{Tk_GetFontStruct}. +@item @b{:foreground }@i{color} +@i{Color} specifies the color to use when drawing text and other +foreground information such as underlines. +It may have any of the forms accepted by @b{Tk_GetColor}. +@item @b{:relief }@i{relief} +\fIRelief specifies the 3-D relief to use for drawing backgrounds, +in any of the forms accepted by @b{Tk_GetRelief}. +This option is used in conjunction with the @b{:borderwidth} +option to give a 3-D appearance to the background for characters; +it is ignored unless the @b{:background} option +has been set for the tag. +@item @b{:underline }@i{boolean} +@i{Boolean} specifies whether or not to draw an underline underneath +characters. +It may have any of the forms accepted by @b{Tk_GetBoolean}. + +If a character has several tags associated with it, and if their +display options conflict, then the options of the highest priority +tag are used. +If a particular display option hasn't been specified for a +particular tag, or if it is specified as an empty string, then +that option will never be used; the next-highest-priority +tag's option will used instead. +If no tag specifies a particular display optionl, then the default +style for the widget will be used. + +The second purpose for tags is event bindings. +You can associate bindings with a tag in much the same way you can +associate bindings with a widget class: whenever particular X +events occur on characters with the given tag, a given +Tcl command will be executed. +Tag bindings can be used to give behaviors to ranges of characters; +among other things, this allows hypertext-like +features to be implemented. +For details, see the description of the @b{tag bind} widget +command below. + +The third use for tags is in managing the selection. +See THE SELECTION below. + +@end table +@unnumberedsubsec Marks + +The second form of annotation in text widgets is a mark. +Marks are used for remembering particular places in a text. +They are something like tags, in that they have names and +they refer to places in the file, but a mark isn't associated +with particular characters. +Instead, a mark is associated with the gap between two characters. +Only a single position may be associated with a mark at any given +time. +If the characters around a mark are deleted the mark will still +remain; it will just have new neighbor characters. +In contrast, if the characters containing a tag are deleted then +the tag will no longer have an association with characters in +the file. +Marks may be manipulated with the ``@i{pathName }@b{:mark}'' widget +command, and their current locations may be determined by using the +mark name as an index in widget commands. + +The name space for marks is different from that for tags: the +same name may be used for both a mark and a tag, but they will refer +to different things. + +Two marks have special significance. +First, the mark @b{insert} is associated with the insertion cursor, +as described under THE INSERTION CURSOR below. +Second, the mark @b{current} is associated with the character +closest to the mouse and is adjusted automatically to track the +mouse position and any changes to the text in the widget (one +exception: @b{current} is not updated in response to mouse +motions if a mouse button is down; the update will be deferred +until all mouse buttons have been released). +Neither of these special marks may be unset. + +@unnumberedsubsec Windows + +The third form of annotation in text widgets is a window. +Window support isn't implemented yet, but when it is it will be +described here. + +@unnumberedsubsec The Selection + +Text widgets support the standard X selection. +Selection support is implemented via tags. +If the @b{exportSelection} option for the text widget is true +then the @b{sel} tag will be associated with the selection: +@itemize @asis{} +@item +[1] +Whenever characters are tagged with @b{sel} the text widget +will claim ownership of the selection. +@item +[2] +Attempts to retrieve the +selection will be serviced by the text widget, returning all the +charaters with the @b{sel} tag. +@item +[3] +If the selection is claimed away by another application or by another +window within this application, then the @b{sel} tag will be removed +from all characters in the text. +@end itemize + +The @b{sel} tag is automatically defined when a text widget is +created, and it may not be deleted with the ``@i{pathName }@b{:tag delete}'' +widget command. Furthermore, the @b{selectBackground}, +@b{selectBorderWidth}@r{, and }@b{selectForeground} options for +the text widget are tied to the @b{:background}, +@b{:borderwidth}@r{, and }@b{:foreground}@r{ options for the }@b{sel} +tag: changes in either will automatically be reflected in the +other. + +@unnumberedsubsec The Insertion Cursor + +The mark named @b{insert} has special significance in text widgets. +It is defined automatically when a text widget is created and it +may not be unset with the ``@i{pathName }@b{:mark unset}'' widget +command. +The @b{insert} mark represents the position of the insertion +cursor, and the insertion cursor will automatically be drawn at +this point whenever the text widget has the input focus. + +@unnumberedsubsec A Text Widget's Arguments + +The @b{text} command creates a new Tcl command whose +name is the same as the path name of the text's window. This +command may be used to invoke various +operations on the widget. It has the following general form: + +@example +@i{pathName option }@r{?}@i{arg arg ...}? +@end example + +@i{PathName} is the name of the command, which is the same as +the text widget's path name. @i{Option}@r{ and the }@i{arg}s +determine the exact behavior of the command. The following +commands are possible for text widgets: + +@table @asis +@item @i{pathName }@b{:compare}@r{ }@i{index1 op index2} +Compares the indices given by @i{index1}@r{ and }@i{index2} according +to the relational operator given by @i{op}, and returns 1 if +the relationship is satisfied and 0 if it isn't. +@i{Op} must be one of the operators <, <=, ==, >=, >, or !=. +If @i{op} is == then 1 is returned if the two indices refer to +the same character, if @i{op}@r{ is < then 1 is returned if }@i{index1} +refers to an earlier character in the text than @i{index2}, and +so on. +@item @i{pathName }@b{:configure}@r{ ?}@i{option}@r{? }@i{?value option value ...}? +Query or modify the configuration options of the widget. +If no @i{option} is specified, returns a list describing all of +the available options for @i{pathName}@r{ (see }@b{Tk_ConfigureInfo} for +information on the format of this list). If @i{option} is specified +with no @i{value}, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no @i{option} is specified). If +one or more @i{option:value} pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +@i{Option}@r{ may have any of the values accepted by the }@b{text} +command. +@item @i{pathName }@b{:debug }@r{?}@i{boolean}? +If @i{boolean} is specified, then it must have one of the true or +false values accepted by Tcl_GetBoolean. +If the value is a true one then internal consistency checks will be +turned on in the B-tree code associated with text widgets. +If @i{boolean} has a false value then the debugging checks will +be turned off. +In either case the command returns an empty string. +If @i{boolean}@r{ is not specified then the command returns }@b{on} +or @b{off} to indicate whether or not debugging is turned on. +There is a single debugging switch shared by all text widgets: turning +debugging on or off in any widget turns it on or off for all widgets. +For widgets with large amounts of text, the consistency checks may +cause a noticeable slow-down. +@item @i{pathName }@b{:delete }@i{index1 }@r{?}@i{index2}? +Delete a range of characters from the text. +If both @i{index1}@r{ and }@i{index2} are specified, then delete +all the characters starting with the one given by @i{index1} +and stopping just before @i{index2} (i.e. the character at +@i{index2} is not deleted). +If @i{index2} doesn't specify a position later in the text +than @i{index1} then no characters are deleted. +If @i{index2} isn't specified then the single character at +@i{index1} is deleted. +It is not allowable to delete characters in a way that would leave +the text without a newline as the last character. +The command returns an empty string. +@item @i{pathName }@b{:get }@i{index1 }@r{?}@i{index2}? +Return a range of characters from the text. +The return value will be all the characters in the text starting +with the one whose index is @i{index1} and ending just before +the one whose index is @i{index2}@r{ (the character at }@i{index2} +will not be returned). +If @i{index2}@r{ is omitted then the single character at }@i{index1} +is returned. +If there are no characters in the specified range (e.g. @i{index1} +is past the end of the file or @i{index2} is less than or equal +to @i{index1}) then an empty string is returned. +@item @i{pathName }@b{:index }@i{index} +Returns the position corresponding to @i{index} in the form +@i{line.char}@r{ where }@i{line}@r{ is the line number and }@i{char} +is the character number. +@i{Index} may have any of the forms described under INDICES above. +@item @i{pathName }@b{:insert }\fIindex chars +Inserts @i{chars} into the text just before the character at +@i{index} and returns an empty string. +It is not possible to insert characters after the last newline +of the text. +@item @i{pathName }@b{:mark }@i{option }@r{?}@i{arg arg ...}? +This command is used to manipulate marks. The exact behavior of +the command depends on the @i{option} argument that follows +the @b{mark} argument. The following forms of the command +are currently supported: +@table @asis +@item @i{pathName }@b{:mark :names} +Returns a list whose elements are the names of all the marks that +are currently set. +@item @i{pathName }@b{:mark :set }@i{markName index} +Sets the mark named @i{markName} to a position just before the +character at @i{index}. +If @i{markName} already exists, it is moved from its old position; +if it doesn't exist, a new mark is created. +This command returns an empty string. +@item @i{pathName }@b{:mark :unset }@i{markName }@r{?}@i{markName markName ...}? +Remove the mark corresponding to each of the @i{markName} arguments. +The removed marks will not be usable in indices and will not be +returned by future calls to ``@i{pathName }@b{:mark names}''. +This command returns an empty string. +@end table + +@item @i{pathName }@b{:scan}@r{ }@i{option args} +This command is used to implement scanning on texts. It has +two forms, depending on @i{option}: +@table @asis +@item @i{pathName }@b{:scan :mark }@i{y} +Records @i{y} and the current view in the text window; used in +conjunction with later @b{scan dragto} commands. Typically this +command is associated with a mouse button press in the widget. It +returns an empty string. +@item @i{pathName }@b{:scan :dragto }@i{y} +This command computes the difference between its @i{y} argument +and the @i{y}@r{ argument to the last }@b{scan mark} command for +the widget. It then adjusts the view up or down by 10 times the +difference in y-coordinates. This command is typically associated +with mouse motion events in the widget, to produce the effect of +dragging the text at high speed through the window. The return +value is an empty string. +@end table + +@item @i{pathName }@b{:tag }@i{option }@r{?}@i{arg arg ...}? +This command is used to manipulate tags. The exact behavior of the +command depends on the @i{option} argument that follows the +@b{tag} argument. The following forms of the command are currently +supported: + +@table @asis +@item @i{pathName }@b{:tag :add }@i{tagName index1 }@r{?}@i{index2}? +Associate the tag @i{tagName} with all of the characters starting +with @i{index1} and ending just before +@i{index2}@r{ (the character at }@i{index2} isn't tagged). +If @i{index2} is omitted then the single character at +@i{index1} is tagged. +If there are no characters in the specified range (e.g. @i{index1} +is past the end of the file or @i{index2} is less than or equal +to @i{index1}) then the command has no effect. +This command returns an empty string. +@item @i{pathName }@b{:tag :bind }@i{tagName}@r{ ?}@i{sequence}@r{? ?}@i{command}? +This command associates @i{command} with the tag given by +@i{tagName}. +Whenever the event sequence given by @i{sequence} occurs for a +character that has been tagged with @i{tagName}, +the command will be invoked. +This widget command is similar to the @b{bind} command except that +it operates on characters in a text rather than entire widgets. +See the @b{bind} manual entry for complete details +on the syntax of @i{sequence} and the substitutions performed +on @i{command} before invoking it. +If all arguments are specified then a new binding is created, replacing +any existing binding for the same @i{sequence}@r{ and }@i{tagName} +(if the first character of @i{command}@r{ is ``+'' then }@i{command} +augments an existing binding rather than replacing it). +In this case the return value is an empty string. +If @i{command}@r{ is omitted then the command returns the }@i{command} +associated with @i{tagName}@r{ and }@i{sequence} (an error occurs +if there is no such binding). +If both @i{command}@r{ and }@i{sequence} are omitted then the command +returns a list of all the sequences for which bindings have been +defined for @i{tagName}. + + +The only events for which bindings may be specified are those related +to the mouse and keyboard, such as @b{Enter}@r{, }@b{Leave}, +@b{ButtonPress}@r{, }@b{Motion}@r{, and }@b{KeyPress}. +Event bindings for a text widget use the @b{current} mark +described under MARKS above. +@b{Enter} events trigger for a character when it +becomes the current character (i.e. the @b{current} mark moves +to just in front of that character). +@b{Leave} events trigger for a character when it ceases to be +the current item (i.e. the @b{current} mark moves away from +that character, or the character is deleted). +These events are different than @b{Enter}@r{ and }@b{Leave} +events for windows. +Mouse and keyboard events are directed to the current character. + + +It is possible for the current character to have multiple tags, +and for each of them to have a binding for a particular event +sequence. +When this occurs, the binding from the highest priority tag is +used. +If a particular tag doesn't have a binding that matches an +event, then the tag is ignored and tags with lower priority +will be checked. + + +If bindings are created for the widget as a whole using the +@b{bind} command, then those bindings will supplement the +tag bindings. +This means that a single event can trigger two Tcl scripts, +one for a widget-level binding and one for a tag-level +binding. + + +@item @i{pathName }@b{:tag :configure }@i{tagName}@r{ ?}@i{option}@r{? ?}@i{value}@r{? ?}@i{option value ...}? +This command is similar to the @b{configure} widget command except +that it modifies options associated with the tag given by @i{tagName} +instead of modifying options for the overall text widget. +If no @i{option} is specified, the command returns a list describing +all of the available options for @i{tagName}@r{ (see }@b{Tk_ConfigureInfo} +for information on the format of this list). +If @i{option}@r{ is specified with no }@i{value}, then the command returns +a list describing the one named option (this list will be identical to +the corresponding sublist of the value returned if no @i{option} +is specified). +If one or more @i{option:value} pairs are specified, then the command +modifies the given option(s) to have the given value(s) in @i{tagName}; +in this case the command returns an empty string. +See TAGS above for details on the options available for tags. +@item @i{pathName }@b{:tag :delete }@i{tagName }@r{?}@i{tagName ...}? +Deletes all tag information for each of the @i{tagName} +arguments. +The command removes the tags from all characters in the file +and also deletes any other information associated with the tags, +such as bindings and display information. +The command returns an empty string. +@item @i{pathName }@b{:tag :lower }@i{tagName }@r{?}@i{belowThis}? +Changes the priority of tag @i{tagName} so that it is just lower +in priority than the tag whose name is @i{belowThis}. +If @i{belowThis}@r{ is omitted, then }@i{tagName}'s priority +is changed to make it lowest priority of all tags. +@item @i{pathName }@b{:tag :names }@r{?}@i{index}? +Returns a list whose elements are the names of all the tags that +are active at the character position given by @i{index}. +If @i{index} is omitted, then the return value will describe +all of the tags that exist for the text (this includes all tags +that have been named in a ``@i{pathName }@b{:tag}'' widget +command but haven't been deleted by a ``@i{pathName }@b{:tag :delete}'' +widget command, even if no characters are currently marked with +the tag). +The list will be sorted in order from lowest priority to highest +priority. +@item @i{pathName }@b{:tag :nextrange }@i{tagName index1 }@r{?}@i{index2}? +This command searches the text for a range of characters tagged +with @i{tagName} where the first character of the range is +no earlier than the character at @i{index1} and no later than +the character just before @i{index2} (a range starting at +@i{index2} will not be considered). +If several matching ranges exist, the first one is chosen. +The command's return value is a list containing +two elements, which are the index of the first character of the +range and the index of the character just after the last one in +the range. +If no matching range is found then the return value is an +empty string. +If @i{index2} is not given then it defaults to the end of the text. +@item @i{pathName }@b{:tag :raise }@i{tagName }@r{?}@i{aboveThis}? +Changes the priority of tag @i{tagName} so that it is just higher +in priority than the tag whose name is @i{aboveThis}. +If @i{aboveThis}@r{ is omitted, then }@i{tagName}'s priority +is changed to make it highest priority of all tags. +@item @i{pathName }@b{:tag :ranges }@i{tagName} +Returns a list describing all of the ranges of text that have been +tagged with @i{tagName}. +The first two elements of the list describe the first tagged range +in the text, the next two elements describe the second range, and +so on. +The first element of each pair contains the index of the first +character of the range, and the second element of the pair contains +the index of the character just after the last one in the +range. +If there are no characters tagged with @i{tag} then an +empty string is returned. +@item @i{pathName }@b{:tag :remove }@i{tagName index1 }@r{?}@i{index2}? +Remove the tag @i{tagName} from all of the characters starting +at @i{index1} and ending just before +@i{index2}@r{ (the character at }@i{index2} isn't affected). +If @i{index2} is omitted then the single character at +@i{index1} is untagged. +If there are no characters in the specified range (e.g. @i{index1} +is past the end of the file or @i{index2} is less than or equal +to @i{index1}) then the command has no effect. +This command returns an empty string. + +@end table +@item @i{pathName }@b{:yview }@r{?}@b{:pickplace}@r{? }@i{what} +This command changes the view in the widget's window so that the line +given by @i{what} is visible in the window. +@i{What} may be either an absolute line number, where 0 corresponds +to the first line of the file, or an index with any of the forms +described under INDICES above. +The first form (absolute line number) is used in the commands issued +by scrollbars to control the widget's view. +If the @b{:pickplace}@r{ option isn't specified then }@i{what} will +appear at the top of the window. +If @b{:pickplace} is specified then the widget chooses where +@i{what} appears in the window: +@itemize @asis{} +@item +[1] +If @i{what} is already visible somewhere in the window then the +command does nothing. +@item +[2] +If @i{what} is only a few lines off-screen above the window then +it will be positioned at the top of the window. +@item +[3] +If @i{what} is only a few lines off-screen below the window then +it will be positioned at the bottom of the window. +@item +[4] +Otherwise, @i{what} will be centered in the window. +@end itemize + +The @b{:pickplace} option is typically used after inserting text +to make sure that the insertion cursor is still visible on the screen. +This command returns an empty string. +@end table + + +@unnumberedsubsec Bindings + +Tk automatically creates class bindings for texts that give them +the following default behavior: +@itemize @asis{} +@item +[1] +Pressing mouse button 1 in an text positions the insertion cursor +just before the character underneath the mouse cursor and sets the +input focus to this widget. +@item +[2] +Dragging with mouse button 1 strokes out a selection between +the insertion cursor and the character under the mouse. +@item +[3] +If you double-press mouse button 1 then the word under the mouse cursor +will be selected, the insertion cursor will be positioned at the +beginning of the word, and dragging the mouse will stroke out a selection +whole words at a time. +@item +[4] +If you triple-press mouse button 1 then the line under the mouse cursor +will be selected, the insertion cursor will be positioned at the +beginning of the line, and dragging the mouse will stroke out a selection +whole line at a time. +@item +[5] +The ends of the selection can be adjusted by dragging with mouse +button 1 while the shift key is down; this will adjust the end +of the selection that was nearest to the mouse cursor when button +1 was pressed. If the selection was made in word or line mode then +it will be adjusted in this same mode. +@item +[6] +The view in the text can be adjusted by dragging with mouse button 2. +@item +[7] +If the input focus is in a text widget and characters are typed on the +keyboard, the characters are inserted just before the insertion cursor. +@item +[8] +Control+h and the Backspace and Delete keys erase the character just +before the insertion cursor. +@item +[9] +Control+v inserts the current selection just before the insertion cursor. +@item +[10] +Control+d deletes the selected characters; an error occurs if the selection +is not in this widget. +@end itemize + +If the text is disabled using the @b{state} option, then the text's +view can still be adjusted and text in the text can still be selected, +but no insertion cursor will be displayed and no text modifications will +take place. + +The behavior of texts can be changed by defining new bindings for +individual widgets or by redefining the class bindings. + +@unnumberedsubsec "Performance Issues" + +Text widgets should run efficiently under a variety +of conditions. The text widget uses about 2-3 bytes of +main memory for each byte of text, so texts containing a megabyte +or more should be practical on most workstations. +Text is represented internally with a modified B-tree structure +that makes operations relatively efficient even with large texts. +Tags are included in the B-tree structure in a way that allows +tags to span large ranges or have many disjoint smaller ranges +without loss of efficiency. +Marks are also implemented in a way that allows large numbers of +marks. +The only known mode of operation where a text widget may not run +efficiently is if it has a very large number of different tags. +Hundreds of tags should be fine, or even a thousand, +but tens of thousands of tags will make texts consume a lot of +memory and run slowly. + +@unnumberedsubsec Keywords +text, widget +@node entry, message, text, Widgets +@section entry +@c @cartouche + +entry \- Create and manipulate entry widgets +@unnumberedsubsec Synopsis +@b{entry}@i{ }@i{pathName }@r{?}@i{options}? +@unnumberedsubsec Standard Options + + +@example +background foreground insertWidth selectForeground +borderWidth insertBackground relief textVariable +cursor insertBorderWidth scrollCommand +exportSelection insertOffTime selectBackground +font insertOnTime selectBorderWidth +@end example + + +@xref{options}, for more information. +@unnumberedsubsec Arguments for Entry + + +@table @asis +@item @code{@b{:state}} +@flushright +Name=@code{"@b{state}@r{"} Class=@code{"}@b{State}"} +@end flushright +@sp 1 + +Specifies one of two states for the entry: @b{normal}@r{ or }@b{disabled}. +If the entry is disabled then the value may not be changed using widget +commands and no insertion cursor will be displayed, even if the input focus is +in the widget. +@end table + + +@table @asis +@item @code{@b{:width}} +@flushright +Name=@code{"@b{width}@r{"} Class=@code{"}@b{Width}"} +@end flushright +@sp 1 + +Specifies an integer value indicating the desired width of the entry window, +in average-size characters of the widget's font. +@end table +@c @end cartouche + +@unnumberedsubsec Description + +The @b{entry} command creates a new window (given by the +@i{pathName} argument) and makes it into an entry widget. +Additional options, described above, may be specified on the +command line or in the option database +to configure aspects of the entry such as its colors, font, +and relief. The @b{entry} command returns its +@i{pathName} argument. At the time this command is invoked, +there must not exist a window named @i{pathName}, but +@i{pathName}'s parent must exist. + +An entry is a widget that displays a one-line text string and +allows that string to be edited using widget commands described below, which +are typically bound to keystrokes and mouse actions. +When first created, an entry's string is empty. +A portion of the entry may be selected as described below. +If an entry is exporting its selection (see the @b{exportSelection} +option), then it will observe the standard X11 protocols for handling the +selection; entry selections are available as type @b{STRING}. +Entries also observe the standard Tk rules for dealing with the +input focus. When an entry has the input focus it displays an +@i{insertion cursor} to indicate where new characters will be +inserted. + +Entries are capable of displaying strings that are too long to +fit entirely within the widget's window. In this case, only a +portion of the string will be displayed; commands described below +may be used to change the view in the window. Entries use +the standard @b{scrollCommand} mechanism for interacting with +scrollbars (see the description of the @b{scrollCommand} option +for details). They also support scanning, as described below. + +@unnumberedsubsec A Entry Widget's Arguments + +The @b{entry} command creates a new Tcl command whose +name is @i{pathName}. This +command may be used to invoke various +operations on the widget. It has the following general form: + +@example +@i{pathName option }@r{?}@i{arg arg ...}? +@end example + +@i{Option}@r{ and the }@i{arg}s +determine the exact behavior of the command. + +Many of the widget commands for entries take one or more indices as +arguments. An index specifies a particular character in the entry's +string, in any of the following ways: + +@table @asis +@item @i{number} +Specifies the character as a numerical index, where 0 corresponds +to the first character in the string. +@item @b{end} +Indicates the character just after the last one in the entry's string. +This is equivalent to specifying a numerical index equal to the length +of the entry's string. +@item @b{insert} +Indicates the character adjacent to and immediately following the +insertion cursor. +@item @b{sel.first} +Indicates the first character in the selection. It is an error to +use this form if the selection isn't in the entry window. +@item @b{sel.last} +Indicates the last character in the selection. It is an error to +use this form if the selection isn't in the entry window. +@item @b{@@}@i{number} +In this form, @i{number} is treated as an x-coordinate in the +entry's window; the character spanning that x-coordinate is used. +For example, ``@b{@@0}'' indicates the left-most character in the +window. +@end table + + +Abbreviations may be used for any of the forms above, e.g. ``@b{e}'' +or ``@b{sel.f}''. In general, out-of-range indices are automatically +rounded to the nearest legal value. + +The following commands are possible for entry widgets: + +@table @asis +@item @i{pathName }@b{:configure}@r{ ?}@i{option}@r{? ?}@i{value option value ...}? +Query or modify the configuration options of the widget. +If no @i{option} is specified, returns a list describing all of +the available options for @i{pathName}@r{ (see }@b{Tk_ConfigureInfo} for +information on the format of this list). If @i{option} is specified +with no @i{value}, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no @i{option} is specified). If +one or more @i{option:value} pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +@i{Option}@r{ may have any of the values accepted by the }@b{entry} +command. +@item @i{pathName }@b{:delete }@i{first }@r{?}@i{last}? +Delete one or more elements of the entry. @i{First}@r{ and }@i{last} +are indices of of the first and last characters in the range to +be deleted. If @i{last} isn't specified it defaults to +@i{first}, i.e. a single character is deleted. This command +returns an empty string. +@item @i{pathName }@b{:get} +Returns the entry's string. +@item @i{pathName }@b{:icursor }@i{index} +Arrange for the insertion cursor to be displayed just before the character +given by @i{index}. Returns an empty string. +@item @i{pathName }@b{:index}@i{ index} +Returns the numerical index corresponding to @i{index}. +@item @i{pathName }@b{:insert }@i{index string} +Insert the characters of @i{string} just before the character +indicated by @i{index}. Returns an empty string. +@item @i{pathName }@b{:scan}@r{ }@i{option args} +This command is used to implement scanning on entries. It has +two forms, depending on @i{option}: +@table @asis +@item @i{pathName }@b{:scan :mark }@i{x} +Records @i{x} and the current view in the entry window; used in +conjunction with later @b{scan dragto} commands. Typically this +command is associated with a mouse button press in the widget. It +returns an empty string. +@item @i{pathName }@b{:scan :dragto }@i{x} +This command computes the difference between its @i{x} argument +and the @i{x}@r{ argument to the last }@b{scan mark} command for +the widget. It then adjusts the view left or right by 10 times the +difference in x-coordinates. This command is typically associated +with mouse motion events in the widget, to produce the effect of +dragging the entry at high speed through the window. The return +value is an empty string. +@end table +@item @i{pathName }@b{:select }@i{option arg} +This command is used to adjust the selection within an entry. It +has several forms, depending on @i{option}: +@table @asis +@item @i{pathName }@b{:select :adjust }@i{index} +Locate the end of the selection nearest to the character given by +@i{index}@r{, and adjust that end of the selection to be at }@i{index} +(i.e including but not going beyond @i{index}). The other +end of the selection is made the anchor point for future +@b{select to} commands. If the selection +isn't currently in the entry, then a new selection is created to +include the characters between @i{index} and the most recent +selection anchor point, inclusive. +Returns an empty string. +@item @i{pathName }@b{:select :clear} +Clear the selection if it is currently in this widget. If the +selection isn't in this widget then the command has no effect. +Returns an empty string. +@item @i{pathName }@b{:select :from }@i{index} +Set the selection anchor point to just before the character +given by @i{index}. Doesn't change the selection. +Returns an empty string. +@item @i{pathName }@b{:select :to }@i{index} +Set the selection to consist of the elements from the anchor +point to element @i{index}, inclusive. The anchor point is +determined by the most recent @b{select from}@r{ or }@b{select adjust} +command in this widget. If the selection isn't in this widget +then a new selection is created using the most recent anchor point +specified for the widget. Returns an empty string. +@end table +@item @i{pathName }@b{:view }@i{index} +Adjust the view in the entry so that element @i{index} is +at the left edge of the window. Returns an empty string. + +@end table +@unnumberedsubsec "Default Bindings" + +Tk automatically creates class bindings for entries that give them +the following default behavior: + +@itemize @asis{} +@item +[1] +Clicking mouse button 1 in an entry positions the insertion cursor +just before the character underneath the mouse cursor and sets the +input focus to this widget. +@item +[2] +Dragging with mouse button 1 strokes out a selection between +the insertion cursor and the character under the mouse. +@item +[3] +The ends of the selection can be adjusted by dragging with mouse +button 1 while the shift key is down; this will adjust the end +of the selection that was nearest to the mouse cursor when button +1 was pressed. +@item +[4] +The view in the entry can be adjusted by dragging with mouse button 2. +@item +[5] +If the input focus is in an entry widget and characters are typed on the +keyboard, the characters are inserted just before the insertion cursor. +@item +[6] +Control-h and the Backspace and Delete keys erase the character just +before the insertion cursor. +@item +[7] +Control-w erases the word just before the insertion cursor. +@item +[8] +Control-u clears the entry to an empty string. +@item +[9] +Control-v inserts the current selection just before the insertion cursor. +@item +[10] +Control-d deletes the selected characters; an error occurs if the selection +is not in this widget. +@end itemize + +If the entry is disabled using the @b{state} option, then the entry's +view can still be adjusted and text in the entry can still be selected, +but no insertion cursor will be displayed and no text modifications will +take place. + +The behavior of entries can be changed by defining new bindings for +individual widgets or by redefining the class bindings. + +@unnumberedsubsec Keywords +entry, widget +@node message, frame, entry, Widgets +@section message +@c @cartouche + +message \- Create and manipulate message widgets +@unnumberedsubsec Synopsis +@b{message}@i{ }@i{pathName }@r{?}@i{options}? +@unnumberedsubsec Standard Options + + +@example +anchor cursor padX text +background font padY textVariable +borderWidth foreground relief width +@end example + + +@xref{options}, for more information. +@unnumberedsubsec Arguments for Message + + +@table @asis +@item @code{@b{:aspect}} +@flushright +Name=@code{"@b{aspect}@r{"} Class=@code{"}@b{Aspect}"} +@end flushright +@sp 1 + +Specifies a non-negative integer value indicating desired +aspect ratio for the text. The aspect ratio is specified as +100*width/height. 100 means the text should +be as wide as it is tall, 200 means the text should +be twice as wide as it is tall, 50 means the text should +be twice as tall as it is wide, and so on. +Used to choose line length for text if @b{width} option +isn't specified. +Defaults to 150. +@end table + + +@table @asis +@item @code{@b{:justify}} +@flushright +Name=@code{"@b{justify}@r{"} Class=@code{"}@b{Justify}"} +@end flushright +@sp 1 + +Specifies how to justify lines of text. +Must be one of @b{left}@r{, }@b{center}@r{, or }@b{right}. Defaults +to @b{left}. +This option works together with the @b{anchor}@r{, }@b{aspect}, +@b{padX}@r{, }@b{padY}@r{, and }@b{width} options to provide a variety +of arrangements of the text within the window. +The @b{aspect}@r{ and }@b{width} options determine the amount of +screen space needed to display the text. +The @b{anchor}@r{, }@b{padX}@r{, and }@b{padY} options determine where this +rectangular area is displayed within the widget's window, and the +@b{justify} option determines how each line is displayed within that +rectangular region. +For example, suppose @b{anchor}@r{ is }@b{e}@r{ and }@b{justify} is +@b{left}, and that the message window is much larger than needed +for the text. +The the text will displayed so that the left edges of all the lines +line up and the right edge of the longest line is @b{padX} from +the right side of the window; the entire text block will be centered +in the vertical span of the window. +@end table + + +@table @asis +@item @code{@b{:width}} +@flushright +Name=@code{"@b{width}@r{"} Class=@code{"}@b{Width}"} +@end flushright +@sp 1 + +Specifies the length of lines in the window. +The value may have any of the forms acceptable to @b{Tk_GetPixels}. +If this option has a value greater than zero then the @b{aspect} +option is ignored and the @b{width} option determines the line +length. +If this option has a value less than or equal to zero, then +the @b{aspect} option determines the line length. +@end table +@c @end cartouche + +@unnumberedsubsec Description + +The @b{message} command creates a new window (given by the +@i{pathName} argument) and makes it into a message widget. +Additional +options, described above, may be specified on the command line +or in the option database +to configure aspects of the message such as its colors, font, +text, and initial relief. The @b{message} command returns its +@i{pathName} argument. At the time this command is invoked, +there must not exist a window named @i{pathName}, but +@i{pathName}'s parent must exist. + +A message is a widget that displays a textual string. A message +widget has three special features. First, it breaks up +its string into lines in order to produce a given aspect ratio +for the window. The line breaks are chosen at word boundaries +wherever possible (if not even a single word would fit on a +line, then the word will be split across lines). Newline characters +in the string will force line breaks; they can be used, for example, +to leave blank lines in the display. + +The second feature of a message widget is justification. The text +may be displayed left-justified (each line starts at the left side of +the window), centered on a line-by-line basis, or right-justified +(each line ends at the right side of the window). + +The third feature of a message widget is that it handles control +characters and non-printing characters specially. Tab characters +are replaced with enough blank space to line up on the next +8-character boundary. Newlines cause line breaks. Other control +characters (ASCII code less than 0x20) and characters not defined +in the font are displayed as a four-character sequence \fB\ex@i{hh} where +@i{hh} is the two-digit hexadecimal number corresponding to +the character. In the unusual case where the font doesn't contain +all of the characters in ``0123456789abcdef\ex'' then control +characters and undefined characters are not displayed at all. + +@unnumberedsubsec A Message Widget's Arguments + +The @b{message} command creates a new Tcl command whose +name is @i{pathName}. This +command may be used to invoke various +operations on the widget. It has the following general form: + +@example +@i{pathName option }@r{?}@i{arg arg ...}? +@end example + +@i{Option}@r{ and the }@i{arg}s +determine the exact behavior of the command. The following +commands are possible for message widgets: + +@table @asis +@item @i{pathName }@b{:configure}@r{ ?}@i{option}@r{? ?}@i{value option value ...}? +Query or modify the configuration options of the widget. +If no @i{option} is specified, returns a list describing all of +the available options for @i{pathName}@r{ (see }@b{Tk_ConfigureInfo} for +information on the format of this list). If @i{option} is specified +with no @i{value}, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no @i{option} is specified). If +one or more @i{option:value} pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +@i{Option}@r{ may have any of the values accepted by the }@b{message} +command. + +@end table +@unnumberedsubsec "Default Bindings" + +When a new message is created, it has no default event bindings: +messages are intended for output purposes only. + +@unnumberedsubsec Bugs + +Tabs don't work very well with text that is centered or right-justified. +The most common result is that the line is justified wrong. + +@unnumberedsubsec Keywords +message, widget +@node frame, label, message, Widgets +@section frame +@c @cartouche + +frame \- Create and manipulate frame widgets +@unnumberedsubsec Synopsis +@b{frame}@i{ }@i{pathName }@r{?}@b{:class }@i{className}@r{? ?}@i{options}? +@unnumberedsubsec Standard Options + + +@example +background cursor relief +borderWidth geometry +@end example + + +@xref{options}, for more information. +@unnumberedsubsec Arguments for Frame + + +@table @asis +@item @code{@b{:height}} +@flushright +Name=@code{"@b{height}@r{"} Class=@code{"}@b{Height}"} +@end flushright +@sp 1 + +Specifies the desired height for the window in any of the forms +acceptable to @b{Tk_GetPixels}. +This option is only used if the @b{:geometry} option is +unspecified. +If this option is less than or equal to zero (and @b{:geometry} +is not specified) then the window will not request any size at +all. +@end table + + +@table @asis +@item @code{@b{:width}} +@flushright +Name=@code{"@b{width}@r{"} Class=@code{"}@b{Width}"} +@end flushright +@sp 1 + +Specifies the desired width for the window in any of the forms +acceptable to @b{Tk_GetPixels}. +This option is only used if the @b{:geometry} option is +unspecified. +If this option is less than or equal to zero (and @b{:geometry} +is not specified) then the window will not request any size at +all. +@end table +@c @end cartouche + +@unnumberedsubsec Description + +The @b{frame} command creates a new window (given by the +@i{pathName} argument) and makes it into a frame widget. +Additional +options, described above, may be specified on the command line +or in the option database +to configure aspects of the frame such as its background color +and relief. The @b{frame} command returns the +path name of the new window. + +A frame is a simple widget. Its primary purpose is to act as a +spacer or container for complex window layouts. The only features +of a frame are its background color and an optional 3-D border to make the +frame appear raised or sunken. + +In addition to the standard options listed above, a @b{:class} +option may be specified on the command line. If it is specified, then +the new widget's class will be set to @i{className} instead of +@b{Frame}. Changing the class of a frame widget may be useful +in order to use a special class name in database options referring +to this widget and its children. Note: @b{:class} is handled +differently than other command-line options and cannot be specified +using the option database (it has to be processed +before the other options are even looked up, since the new class +name will affect the lookup of the other options). In addition, +the @b{:class} option may not be queried or changed using the +@b{config} command described below. + +@unnumberedsubsec A Frame Widget's Arguments + +The @b{frame} command creates a new Tcl command whose +name is the same as the path name of the frame's window. This +command may be used to invoke various +operations on the widget. It has the following general form: + +@example +@i{pathName option }@r{?}@i{arg arg ...}? +@end example + +@i{PathName} is the name of the command, which is the same as +the frame widget's path name. @i{Option}@r{ and the }@i{arg}s +determine the exact behavior of the command. The following +commands are possible for frame widgets: + +@table @asis +@item @i{pathName }@b{:configure}@r{ ?}@i{option}@r{? }@i{?value option value ...}? +Query or modify the configuration options of the widget. +If no @i{option} is specified, returns a list describing all of +the available options for @i{pathName}@r{ (see }@b{Tk_ConfigureInfo} for +information on the format of this list). If @i{option} is specified +with no @i{value}, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no @i{option} is specified). If +one or more @i{option:value} pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +@i{Option}@r{ may have any of the values accepted by the }@b{frame} +command. + +@end table +@unnumberedsubsec Bindings + +When a new frame is created, it has no default event bindings: +frames are not intended to be interactive. + +@unnumberedsubsec Keywords +frame, widget +@node label, radiobutton, frame, Widgets +@section label +@c @cartouche + +label \- Create and manipulate label widgets +@unnumberedsubsec Synopsis +@b{label}@i{ }@i{pathName }@r{?}@i{options}? +@unnumberedsubsec Standard Options + + +@example +anchor borderWidth foreground relief +background cursor padX text +bitmap font padY textVariable +@end example + + +@xref{options}, for more information. +@unnumberedsubsec Arguments for Label + + +@table @asis +@item @code{@b{:height}} +@flushright +Name=@code{"@b{height}@r{"} Class=@code{"}@b{Height}"} +@end flushright +@sp 1 + +Specifies a desired height for the label. +If a bitmap is being displayed in the label then the value is in +screen units (i.e. any of the forms acceptable to @b{Tk_GetPixels}); +for text it is in lines of text. +If this option isn't specified, the label's desired height is computed +from the size of the bitmap or text being displayed in it. +@end table + + +@table @asis +@item @code{@b{:width}} +@flushright +Name=@code{"@b{width}@r{"} Class=@code{"}@b{Width}"} +@end flushright +@sp 1 + +Specifies a desired width for the label. +If a bitmap is being displayed in the label then the value is in +screen units (i.e. any of the forms acceptable to @b{Tk_GetPixels}); +for text it is in characters. +If this option isn't specified, the label's desired width is computed +from the size of the bitmap or text being displayed in it. +@end table +@c @end cartouche + +@unnumberedsubsec Description + +The @b{label} command creates a new window (given by the +@i{pathName} argument) and makes it into a label widget. +Additional +options, described above, may be specified on the command line +or in the option database +to configure aspects of the label such as its colors, font, +text, and initial relief. The @b{label} command returns its +@i{pathName} argument. At the time this command is invoked, +there must not exist a window named @i{pathName}, but +@i{pathName}'s parent must exist. + +A label is a widget +that displays a textual string or bitmap. +The label can be manipulated in a few simple ways, such as +changing its relief or text, using the commands described below. + +@unnumberedsubsec A Label Widget's Arguments + +The @b{label} command creates a new Tcl command whose +name is @i{pathName}. This +command may be used to invoke various +operations on the widget. It has the following general form: + +@example +@i{pathName option }@r{?}@i{arg arg ...}? +@end example + +@i{Option}@r{ and the }@i{arg}s +determine the exact behavior of the command. The following +commands are possible for label widgets: + +@table @asis +@item @i{pathName }@b{:configure}@r{ ?}@i{option}@r{? ?}@i{value option value ...}? +Query or modify the configuration options of the widget. +If no @i{option} is specified, returns a list describing all of +the available options for @i{pathName}@r{ (see }@b{Tk_ConfigureInfo} for +information on the format of this list). If @i{option} is specified +with no @i{value}, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no @i{option} is specified). If +one or more @i{option:value} pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +@i{Option}@r{ may have any of the values accepted by the }@b{label} +command. + +@end table +@unnumberedsubsec Bindings + +When a new label is created, it has no default event bindings: +labels are not intended to be interactive. + +@unnumberedsubsec Keywords +label, widget +@node radiobutton, toplevel, label, Widgets +@section radiobutton +@c @cartouche + +radiobutton \- Create and manipulate radio-button widgets +@unnumberedsubsec Synopsis +@b{radiobutton}@i{ }@i{pathName }@r{?}@i{options}? +@unnumberedsubsec Standard Options + + +@example +activeBackground bitmap font relief +activeForeground borderWidth foreground text +anchor cursor padX textVariable +background disabledForeground padX +@end example + + +@xref{options}, for more information. +@unnumberedsubsec Arguments for Radiobutton + + +@table @asis +@item @code{@b{:command}} +@flushright +Name=@code{"@b{command}@r{"} Class=@code{"}@b{Command}"} +@end flushright +@sp 1 + +Specifies a Tcl command to associate with the button. This command +is typically invoked when mouse button 1 is released over the button +window. The button's global variable (@b{:variable} option) will +be updated before the command is invoked. +@end table + + +@table @asis +@item @code{@b{:height}} +@flushright +Name=@code{"@b{height}@r{"} Class=@code{"}@b{Height}"} +@end flushright +@sp 1 + +Specifies a desired height for the button. +If a bitmap is being displayed in the button then the value is in +screen units (i.e. any of the forms acceptable to @b{Tk_GetPixels}); +for text it is in lines of text. +If this option isn't specified, the button's desired height is computed +from the size of the bitmap or text being displayed in it. +@end table + + +@table @asis +@item @code{@b{:selector}} +@flushright +Name=@code{"@b{selector}@r{"} Class=@code{"}@b{Foreground}"} +@end flushright +@sp 1 + +Specifies the color to draw in the selector when this button is +selected. +If specified as an empty string then no selector is drawn for the button. +@end table + + +@table @asis +@item @code{@b{:state}} +@flushright +Name=@code{"@b{state}@r{"} Class=@code{"}@b{State}"} +@end flushright +@sp 1 + +Specifies one of three states for the radio button: @b{normal}@r{, }@b{active}, +or @b{disabled}. In normal state the radio button is displayed using the +@b{foreground}@r{ and }@b{background} options. The active state is +typically used when the pointer is over the radio button. In active state +the radio button is displayed using the @b{activeForeground} and +@b{activeBackground} options. Disabled state means that the radio button +is insensitive: it doesn't activate and doesn't respond to mouse +button presses. In this state the @b{disabledForeground} and +@b{background} options determine how the radio button is displayed. +@end table + + +@table @asis +@item @code{@b{:value}} +@flushright +Name=@code{"@b{value}@r{"} Class=@code{"}@b{Value}"} +@end flushright +@sp 1 + +Specifies value to store in the button's associated variable whenever +this button is selected. Defaults to the name of the radio button. +@end table + + +@table @asis +@item @code{@b{:variable}} +@flushright +Name=@code{"@b{variable}@r{"} Class=@code{"}@b{Variable}"} +@end flushright +@sp 1 + +Specifies name of global variable to set whenever this button is +selected. Changes in this variable also cause the button to select +or deselect itself. +Defaults to the value @b{selectedButton}. +@end table + + +@table @asis +@item @code{@b{:width}} +@flushright +Name=@code{"@b{width}@r{"} Class=@code{"}@b{Width}"} +@end flushright +@sp 1 + +Specifies a desired width for the button. +If a bitmap is being displayed in the button then the value is in +screen units (i.e. any of the forms acceptable to @b{Tk_GetPixels}); +for text it is in characters. +If this option isn't specified, the button's desired width is computed +from the size of the bitmap or text being displayed in it. +@end table +@c @end cartouche + +@unnumberedsubsec Description + +The @b{radiobutton} command creates a new window (given by the +@i{pathName} argument) and makes it into a radiobutton widget. +Additional +options, described above, may be specified on the command line +or in the option database +to configure aspects of the radio button such as its colors, font, +text, and initial relief. The @b{radiobutton} command returns its +@i{pathName} argument. At the time this command is invoked, +there must not exist a window named @i{pathName}, but +@i{pathName}'s parent must exist. + +A radio button is a widget +that displays a textual string or bitmap +and a diamond called a @i{selector}. +A radio button has +all of the behavior of a simple button: it can display itself in either +of three different ways, according to the @b{state} option; +it can be made to appear +raised, sunken, or flat; it can be made to flash; and it invokes +a Tcl command whenever mouse button 1 is clicked over the +check button. + +In addition, radio buttons can be @i{selected}. +If a radio button is selected then a special highlight appears +in the selector and a Tcl variable associated with the radio button +is set to a particular value. +If the radio button is not selected then the selector is drawn +in a different fashion. +Typically, several radio buttons share a single variable and the +value of the variable indicates which radio button is to be selected. +When a radio button is selected it sets the value of the variable to +indicate that fact; each radio button also monitors the value of +the variable and automatically selects and deselects itself when the +variable's value changes. +By default the variable @b{selectedButton} +is used; its contents give the name of the button that is +selected, or the empty string if no button associated with that +variable is selected. +The name of the variable for a radio button, +plus the variable to be stored into it, may be modified with options +on the command line or in the option database. By default a radio +button is configured to select itself on button clicks. + +@unnumberedsubsec A Radiobutton Widget's Arguments + +The @b{radiobutton} command creates a new Tcl command whose +name is @i{pathName}. This +command may be used to invoke various +operations on the widget. It has the following general form: + +@example +@i{pathName option }@r{?}@i{arg arg ...}? +@end example + +@i{Option}@r{ and the }@i{arg}s +determine the exact behavior of the command. The following +commands are possible for radio-button widgets: + +@table @asis +@item @i{pathName }@b{:activate} +Change the radio button's state to @b{active} and redisplay the button +using its active foreground and background colors instead of normal +colors. +This command is ignored if the radio button's state is @b{disabled}. +This command is obsolete and will eventually be removed; +use ``@i{pathName }@b{:configure :state active}'' instead. +@item @i{pathName }@b{:configure}@r{ ?}@i{option}@r{? ?}@i{value option value ...}? +Query or modify the configuration options of the widget. +If no @i{option} is specified, returns a list describing all of +the available options for @i{pathName}@r{ (see }@b{Tk_ConfigureInfo} for +information on the format of this list). If @i{option} is specified +with no @i{value}, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no @i{option} is specified). If +one or more @i{option:value} pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +@i{Option}@r{ may have any of the values accepted by the }@b{radiobutton} +command. +@item @i{pathName }@b{:deactivate} +Change the radio button's state to @b{normal} and redisplay the button +using its normal foreground and background colors. +This command is ignored if the radio button's state is @b{disabled}. +This command is obsolete and will eventually be removed; +use ``@i{pathName }@b{:configure :state normal}'' instead. +@item @i{pathName }@b{:deselect} +Deselect the radio button: redisplay it without a highlight in +the selector and set the associated variable to an empty string. If +this radio button was not currently selected, then the command has +no effect. +@item @i{pathName }@b{:flash} +Flash the radio button. This is accomplished by redisplaying the radio button +several times, alternating between active and normal colors. At +the end of the flash the radio button is left in the same normal/active +state as when the command was invoked. +This command is ignored if the radio button's state is @b{disabled}. +@item @i{pathName }@b{:invoke} +Does just what would have happened if the user invoked the radio button +with the mouse: select the button and invoke +its associated Tcl command, if there is one. +The return value is the return value from the Tcl command, or an +empty string if there is no command associated with the radio button. +This command is ignored if the radio button's state is @b{disabled}. +@item @i{pathName }@b{:select} +Select the radio button: display it with a highlighted +selector and set the associated variable to the value corresponding +to this widget. + +@end table +@unnumberedsubsec Bindings + +Tk automatically creates class bindings for radio buttons that give them +the following default behavior: +@itemize @asis{} +@item +[1] +The radio button activates whenever the mouse passes over it and deactivates +whenever the mouse leaves the radio button. +@item +[2] +The radio button's relief is changed to sunken whenever mouse button 1 is +pressed over it, and the relief is restored to its original +value when button 1 is later released. +@item +[3] +If mouse button 1 is pressed over the radio button and later released over +the radio button, the radio button is invoked (i.e. it is selected +and the command associated with the button is invoked, +if there is one). However, if the mouse is not +over the radio button when button 1 is released, then no invocation occurs. +@end itemize + +The behavior of radio buttons can be changed by defining new bindings for +individual widgets or by redefining the class bindings. + +@unnumberedsubsec Keywords +radio button, widget +@node toplevel, , radiobutton, Widgets +@section toplevel +@c @cartouche + +toplevel \- Create and manipulate toplevel widgets +@unnumberedsubsec Synopsis +@b{toplevel}@i{ }@i{pathName }@r{?}@b{:screen }@i{screenName}@r{? ?}@b{:class }@i{className}@r{? ?}@i{options}? +@unnumberedsubsec Standard Options + + +@example +background geometry +borderWidth relief +@end example + + +@xref{options}, for more information. +@unnumberedsubsec Arguments for Toplevel +@c @end cartouche + +@unnumberedsubsec Description + +The @b{toplevel} command creates a new toplevel widget (given +by the @i{pathName} argument). Additional +options, described above, may be specified on the command line +or in the option database +to configure aspects of the toplevel such as its background color +and relief. The @b{toplevel} command returns the +path name of the new window. + +A toplevel is similar to a frame except that it is created as a +top-level window: its X parent is the root window of a screen +rather than the logical parent from its path name. The primary +purpose of a toplevel is to serve as a container for dialog boxes +and other collections of widgets. The only features +of a toplevel are its background color and an optional 3-D border +to make the toplevel appear raised or sunken. + +Two special command-line options may be provided to the @b{toplevel} +command: @b{:class}@r{ and }@b{:screen}@r{. If }@b{:class} +is specified, then the new widget's class will be set to +@i{className}@r{ instead of }@b{Toplevel}. Changing the class of +a toplevel widget may be useful +in order to use a special class name in database options referring +to this widget and its children. The @b{:screen} option +may be used to place the window on a different screen than the +window's logical parent. Any valid screen name may be used, even +one associated with a different display. + +Note: @b{:class}@r{ and }@b{:screen} are handled +differently than other command-line options. They may not be specified +using the option database (these options must have been processed +before the new window has been created enough to use the option database; +in particular, the new class name will affect the lookup of options +in the database). In addition, @b{:class}@r{ and }@b{:screen} +may not be queried or changed using the @b{config} command described +below. However, the @b{winfo :class} command may be used to query +the class of a window, and @b{winfo :screen} may be used to query +its screen. + +@unnumberedsubsec A Toplevel Widget's Arguments + +The @b{toplevel} command creates a new Tcl command whose +name is the same as the path name of the toplevel's window. This +command may be used to invoke various +operations on the widget. It has the following general form: + +@example +@i{pathName option }@r{?}@i{arg arg ...}? +@end example + +@i{PathName} is the name of the command, which is the same as +the toplevel widget's path name. @i{Option}@r{ and the }@i{arg}s +determine the exact behavior of the command. The following +commands are possible for toplevel widgets: + +@table @asis +@item @i{pathName }@b{:configure}@r{ ?}@i{option}@r{? ?}@i{value option value ...}? +Query or modify the configuration options of the widget. +If no @i{option} is specified, returns a list describing all of +the available options for @i{pathName}@r{ (see }@b{Tk_ConfigureInfo} for +information on the format of this list). If @i{option} is specified +with no @i{value}, then the command returns a list describing the +one named option (this list will be identical to the corresponding +sublist of the value returned if no @i{option} is specified). If +one or more @i{option:value} pairs are specified, then the command +modifies the given widget option(s) to have the given value(s); in +this case the command returns an empty string. +@i{Option}@r{ may have any of the values accepted by the }@b{toplevel} +command. + +@end table +@unnumberedsubsec Bindings + +When a new toplevel is created, it has no default event bindings: +toplevels are not intended to be interactive. + +@unnumberedsubsec Keywords +toplevel, widget diff --git a/install.sh b/install.sh new file mode 100644 index 0000000..2c212cc --- /dev/null +++ b/install.sh @@ -0,0 +1,250 @@ +#! /bin/sh +# +# install - install a program, script, or datafile +# This comes from X11R5 (mit/util/scripts/install.sh). +# +# Copyright 1991 by the Massachusetts Institute of Technology +# +# Permission to use, copy, modify, distribute, and sell this software and its +# documentation for any purpose is hereby granted without fee, provided that +# the above copyright notice appear in all copies and that both that +# copyright notice and this permission notice appear in supporting +# documentation, and that the name of M.I.T. not be used in advertising or +# publicity pertaining to distribution of the software without specific, +# written prior permission. M.I.T. makes no representations about the +# suitability of this software for any purpose. It is provided "as is" +# without express or implied warranty. +# +# Calling this script install-sh is preferred over install.sh, to prevent +# `make' implicit rules from creating a file called install from it +# when there is no Makefile. +# +# This script is compatible with the BSD install script, but was written +# from scratch. +# + + +# set DOITPROG to echo to test this script + +# Don't use :- since 4.3BSD and earlier shells don't like it. +doit="${DOITPROG-}" + + +# put in absolute paths if you don't have them in your path; or use env. vars. + +mvprog="${MVPROG-mv}" +cpprog="${CPPROG-cp}" +chmodprog="${CHMODPROG-chmod}" +chownprog="${CHOWNPROG-chown}" +chgrpprog="${CHGRPPROG-chgrp}" +stripprog="${STRIPPROG-strip}" +rmprog="${RMPROG-rm}" +mkdirprog="${MKDIRPROG-mkdir}" + +transformbasename="" +transform_arg="" +instcmd="$mvprog" +chmodcmd="$chmodprog 0755" +chowncmd="" +chgrpcmd="" +stripcmd="" +rmcmd="$rmprog -f" +mvcmd="$mvprog" +src="" +dst="" +dir_arg="" + +while [ x"$1" != x ]; do + case $1 in + -c) instcmd="$cpprog" + shift + continue;; + + -d) dir_arg=true + shift + continue;; + + -m) chmodcmd="$chmodprog $2" + shift + shift + continue;; + + -o) chowncmd="$chownprog $2" + shift + shift + continue;; + + -g) chgrpcmd="$chgrpprog $2" + shift + shift + continue;; + + -s) stripcmd="$stripprog" + shift + continue;; + + -t=*) transformarg=`echo $1 | sed 's/-t=//'` + shift + continue;; + + -b=*) transformbasename=`echo $1 | sed 's/-b=//'` + shift + continue;; + + *) if [ x"$src" = x ] + then + src=$1 + else + # this colon is to work around a 386BSD /bin/sh bug + : + dst=$1 + fi + shift + continue;; + esac +done + +if [ x"$src" = x ] +then + echo "install: no input file specified" + exit 1 +else + true +fi + +if [ x"$dir_arg" != x ]; then + dst=$src + src="" + + if [ -d $dst ]; then + instcmd=: + else + instcmd=mkdir + fi +else + +# Waiting for this to be detected by the "$instcmd $src $dsttmp" command +# might cause directories to be created, which would be especially bad +# if $src (and thus $dsttmp) contains '*'. + + if [ -f $src -o -d $src ] + then + true + else + echo "install: $src does not exist" + exit 1 + fi + + if [ x"$dst" = x ] + then + echo "install: no destination specified" + exit 1 + else + true + fi + +# If destination is a directory, append the input filename; if your system +# does not like double slashes in filenames, you may need to add some logic + + if [ -d $dst ] + then + dst="$dst"/`basename $src` + else + true + fi +fi + +## this sed command emulates the dirname command +dstdir=`echo $dst | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'` + +# Make sure that the destination directory exists. +# this part is taken from Noah Friedman's mkinstalldirs script + +# Skip lots of stat calls in the usual case. +if [ ! -d "$dstdir" ]; then +defaultIFS=' +' +IFS="${IFS-${defaultIFS}}" + +oIFS="${IFS}" +# Some sh's can't handle IFS=/ for some reason. +IFS='%' +set - `echo ${dstdir} | sed -e 's@/@%@g' -e 's@^%@/@'` +IFS="${oIFS}" + +pathcomp='' + +while [ $# -ne 0 ] ; do + pathcomp="${pathcomp}${1}" + shift + + if [ ! -d "${pathcomp}" ] ; + then + $mkdirprog "${pathcomp}" + else + true + fi + + pathcomp="${pathcomp}/" +done +fi + +if [ x"$dir_arg" != x ] +then + $doit $instcmd $dst && + + if [ x"$chowncmd" != x ]; then $doit $chowncmd $dst; else true ; fi && + if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dst; else true ; fi && + if [ x"$stripcmd" != x ]; then $doit $stripcmd $dst; else true ; fi && + if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dst; else true ; fi +else + +# If we're going to rename the final executable, determine the name now. + + if [ x"$transformarg" = x ] + then + dstfile=`basename $dst` + else + dstfile=`basename $dst $transformbasename | + sed $transformarg`$transformbasename + fi + +# don't allow the sed command to completely eliminate the filename + + if [ x"$dstfile" = x ] + then + dstfile=`basename $dst` + else + true + fi + +# Make a temp file name in the proper directory. + + dsttmp=$dstdir/#inst.$$# + +# Move or copy the file name to the temp name + + $doit $instcmd $src $dsttmp && + + trap "rm -f ${dsttmp}" 0 && + +# and set any options; do chmod last to preserve setuid bits + +# If any of these fail, we abort the whole thing. If we want to +# ignore errors from any of these, just make sure not to ignore +# errors from the above "$doit $instcmd $src $dsttmp" command. + + if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; else true;fi && + if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; else true;fi && + if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; else true;fi && + if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; else true;fi && + +# Now rename the file to the real destination. + + $doit $rmcmd -f $dstdir/$dstfile && + $doit $mvcmd $dsttmp $dstdir/$dstfile + +fi && + + +exit 0 diff --git a/japitest.lsp b/japitest.lsp new file mode 100644 index 0000000..0db67f0 --- /dev/null +++ b/japitest.lsp @@ -0,0 +1,369 @@ +;;; +;;; Japi is a cross-platform, easy to use (rough and ready) Java based GUI library +;;; Download a library and headers for your platform, and get the C examples +;;; and documentation from: +;;; +;;; http://www.japi.de/ +;;; +;;; This file shows how to use some of the available functions. You may assume +;;; that the only functions tested so far in the binding are those which appear +;;; below, as this file doubles as the test program. The binding is so simple +;;; however that so far no binding (APART FROM J_PRINT) has gone wrong of those +;;; tested so far! +;;; +;;; +;;; HOW TO USE THIS FILE +;;; +;;; (compile-file "c:/cvs/gcl/japitest.lsp") (load "c:/cvs/gcl/japitest.o") +;;; +;;; Requires either "java" or "jre" in the path to work. +;;; + +(in-package :japi-primitives) + +;; Start up the Japi server (needs to find either "java" or "jre" in your path +(defmacro with-server ((app-name debug-level) . body) + (multiple-value-bind (ds b) + (si::find-declarations body) + `(if (= 0 (jpr::j_start)) + (format t (format nil "~S can't connect to the Japi GUI server." ,app-name)) + (progn + (j_setdebug ,debug-level) + ,@ds + (unwind-protect + (progn ,@b) + (j_quit)))))) + +;; Use a frame and clean up afterwards even if trouble ensues +(defmacro with-frame ((frame-var-name title) . body) + (multiple-value-bind (ds b) + (si::find-declarations body) + `(let ((,frame-var-name (j_frame ,title))) + ,@ds + (unwind-protect + (progn ,@b) + (j_dispose ,frame-var-name))))) + +;; Use a canvas and clean up afterwards even if trouble ensues +(defmacro with-canvas ((canvas-var-name frame-obj x-size y-size) . body) + (multiple-value-bind (ds b) + (si::find-declarations body) + `(let ((,canvas-var-name (j_canvas ,frame-obj ,x-size ,y-size))) + ,@ds + (unwind-protect + (progn ,@b) + (j_dispose ,canvas-var-name))))) + +;; Use a text area and clean up afterwards even if trouble ensues +(defmacro with-text-area ((text-area-var-name panel-obj x-size y-size) . body) + (multiple-value-bind (ds b) + (si::find-declarations body) + `(let ((,text-area-var-name (j_textarea ,panel-obj ,x-size ,y-size))) + ,@ds + (unwind-protect + (progn ,@b) + (j_dispose ,text-area-var-name))))) + +;; Use a pulldown menu bar and clean up afterwards even if trouble ensues +(defmacro with-menu-bar ((bar-var-name frame-obj) . body) + (multiple-value-bind (ds b) + (si::find-declarations body) + `(let ((,bar-var-name (j_menubar ,frame-obj))) + ,@ds + (unwind-protect + (progn ,@b) + (j_dispose ,bar-var-name))))) + +;; Add a pulldown menu and clean up afterwards even if trouble ensues +(defmacro with-menu ((menu-var-name bar-obj title) . body) + (multiple-value-bind (ds b) + (si::find-declarations body) + `(let ((,menu-var-name (j_menu ,bar-obj ,title))) + ,@ds + (unwind-protect + (progn ,@b) + (j_dispose ,menu-var-name))))) + +;; Add a pulldown menu item and clean up afterwards even if trouble ensues +(defmacro with-menu-item ((item-var-name menu-obj title) . body) + (multiple-value-bind (ds b) + (si::find-declarations body) + `(let ((,item-var-name (j_menuitem ,menu-obj ,title))) + ,@ds + (unwind-protect + (progn ,@b) + (j_dispose ,item-var-name))))) + +;; Add a mouse listener and clean up afterwards even if trouble ensues +(defmacro with-mouse-listener ((var-name obj type) . body) + (multiple-value-bind (ds b) + (si::find-declarations body) + `(let ((,var-name (j_mouselistener ,obj ,type))) + ,@ds + (unwind-protect + (progn ,@b) + (j_dispose ,var-name))))) + +;; Use a panel and clean up afterwards even if trouble ensues +(defmacro with-panel ((panel-var-name frame-obj) . body) + (multiple-value-bind (ds b) + (si::find-declarations body) + `(let ((,panel-var-name (j_panel ,frame-obj))) + ,@ds + (unwind-protect + (progn ,@b) + (j_dispose ,panel-var-name))))) + + +;; Run a five second frame in a Japi server +(with-server ("GCL Japi library test GUI 1" 0) + (with-frame (frame "Five Second Blank Test Frame") + (j_show frame) + (j_sleep 5000))) + +;; Get a pointer to an array of ints +(defCfun "static void* inta_ptr(object s)" 0 + " return(s->fixa.fixa_self);") +(defentry inta-ptr (object) (int "inta_ptr")) + +;; Draw function +(defun drawgraphics (drawable xmin ymin xmax ymax) + (let* ((fntsize 10) + (tmpstrx (format nil "XMax = ~D" xmax)) + (tmpstry (format nil "YMax = ~D" ymax)) + (tmpstrwidx (j_getstringwidth drawable tmpstrx))) + (j_setfontsize drawable fntsize) + (j_setnamedcolor drawable J_RED) + + (j_drawline drawable xmin ymin (- xmax 1) (- ymax 1)) + (j_drawline drawable xmin (- ymax 1) (- xmax 1) ymin) + (j_drawrect drawable xmin ymin (- xmax xmin 1) (- ymax xmin 1)) + + (j_setnamedcolor drawable J_BLACK) + (j_drawline drawable xmin (- ymax 30) (- xmax 1) (- ymax 30)) + (j_drawstring drawable (- (/ xmax 2) (/ tmpstrwidx 2)) (- ymax 40) tmpstrx) + + (j_drawline drawable (+ xmin 30) ymin (+ xmin 30) (- ymax 1)) + (j_drawstring drawable (+ xmin 50) 40 tmpstry) + + (j_setnamedcolor drawable J_MAGENTA) + (loop for i from 1 to 10 + do (j_drawoval drawable + (+ xmin (/ (- xmax xmin) 2)) + (+ ymin (/ (- ymax ymin) 2)) + (* (/ (- xmax xmin) 20) i) + (* (/ (- ymax ymin) 20) i))) + + (j_setnamedcolor drawable J_BLUE) + (let ((y ymin) + (teststr "JAPI Test Text")) + (loop for i from 5 to 21 do + (j_setfontsize drawable i) + (let ((x (- xmax (j_getstringwidth drawable teststr)))) + (setf y (+ y (j_getfontheight drawable))) + (j_drawstring drawable x y teststr)))))) + +;; Run some more extensive tests +(with-server + ("GCL Japi library test GUI 2" 0) + (with-frame + (frame "Draw") + (j_show frame) + (let ((alert (j_messagebox frame "Two second alert box" "label"))) + (j_sleep 2000) + (j_dispose alert)) + (let ((result1 (j_alertbox frame "label1" "label2" "OK")) + (result2 (j_choicebox2 frame "label1" "label2" "Yes" "No")) + (result3 (j_choicebox3 frame "label1" "label2" "Yes" "No" "Cancel"))) + (format t "Requestor results were: ~D, ~D, ~D~%" result1 result2 result3)) + (j_setborderlayout frame) + (with-menu-bar + (menubar frame) + (with-menu + (file menubar "File") + (with-menu-item + (print file "Print") + (with-menu-item + (save file "Save BMP") + (with-menu-item + (quit file "Quit") + (with-canvas + (canvas frame 400 600) + (j_pack frame) + (drawgraphics canvas 0 0 (j_getwidth canvas) (j_getheight canvas)) + (j_show frame) + (do ((obj (j_nextaction) (j_nextaction))) + ((or (= obj frame) (= obj quit)) t) + (when (= obj canvas) + (j_setnamedcolorbg canvas J_WHITE) + (drawgraphics canvas 10 10 + (- (j_getwidth canvas) 10) + (- (j_getheight canvas) 10))) + (when (= obj print) + (let ((printer (j_printer frame))) + (when (> 0 printer) + (drawgraphics printer 40 40 + (- (j_getwidth printer) 80) + (- (j_getheight printer) 80)) + (j_print printer)))) + (when (= obj save) + (let ((image (j_image 600 800))) + (drawgraphics image 0 0 600 800) + (when (= 0 (j_saveimage image "test.bmp" J_BMP)) + (j_alertbox frame "Problems" "Can't save the image" "OK"))))))))))))) +;; Try some mouse handling +(with-server + ("GCL Japi library test GUI 3" 0) + (with-frame + (frame "Move and drag the mouse") + (j_setsize frame 430 240) + (j_setnamedcolorbg frame J_LIGHT_GRAY) + (with-canvas + (canvas1 frame 200 200) + (with-canvas + (canvas2 frame 200 200) + (j_setpos canvas1 10 30) + (j_setpos canvas2 220 30) + (with-mouse-listener + (pressed canvas1 J_PRESSED) + (with-mouse-listener + (dragged canvas1 J_DRAGGED) + (with-mouse-listener + (released canvas1 J_RELEASED) + (with-mouse-listener + (entered canvas2 J_ENTERERD) + (with-mouse-listener + (moved canvas2 J_MOVED) + (with-mouse-listener + (exited canvas2 J_EXITED) + (j_show frame) + ;; Allocate immovable storage for passing data back from C land. + ;; Uses the GCL only make-array keyword :static + (let* ((xa (make-array 1 :initial-element 0 :element-type 'fixnum :static t)) + (ya (make-array 1 :initial-element 0 :element-type 'fixnum :static t)) + (pxa (inta-ptr xa)) + (pya (inta-ptr ya)) + (x 0) + (y 0) + (get-mouse-xy (lambda (obj) + (progn (j_getmousepos obj pxa pya) + (setf x (aref xa 0)) + (setf y (aref ya 0))))) + (startx 0) + (starty 0)) + (do ((obj (j_nextaction) (j_nextaction))) + ((= obj frame) t) + (when (= obj pressed) + (funcall get-mouse-xy pressed) + (setf startx x) + (setf starty y)) + (when (= obj dragged) + (funcall get-mouse-xy dragged) + (j_drawrect canvas1 startx starty (- x startx) (- y starty))) + (when (= obj released) + (funcall get-mouse-xy released) + (j_drawrect canvas1 startx starty (- x startx) (- y starty))) + (when (= obj entered) + (funcall get-mouse-xy entered) + (setf startx x) + (setf starty y)) + (when (= obj moved) + (funcall get-mouse-xy moved) + (j_drawline canvas2 startx starty x y)) + (setf startx x) + (setf starty y) + (when (= obj exited) + (funcall get-mouse-xy exited) + (j_drawline canvas2 startx starty x y)))))))))))))) + +;; Text editor demo +(with-server + ("GCL Japi library test text editor" 0) + (with-frame + (frame "A simple editor") + (j_setgridlayout frame 1 1) + (with-panel + (panel frame) + (j_setgridlayout panel 1 1) + (with-menu-bar + (menubar frame) + (with-menu + (file-mi menubar "File") + (with-menu-item + (new-mi file-mi "New") + (with-menu-item + (save-mi file-mi "Save") + (j_seperator file-mi) + (with-menu-item + (quit-mi file-mi "Quit") + + (with-menu + (edit-mi menubar "Edit") + (with-menu-item + (select-all-mi edit-mi "Select All") + (j_seperator edit-mi) + (with-menu-item + (cut-mi edit-mi "Cut") + (with-menu-item + (copy-mi edit-mi "Copy") + (with-menu-item + (paste-mi edit-mi "Paste") + + (with-text-area + (text panel 15 4) + (j_setfont text J_DIALOGIN J_BOLD 18) + (let ((new-text (format nil "JAPI (Java Application~%Programming Interface)~%a platform and language~%independent API"))) + (j_settext text new-text) + (j_show frame) + (j_pack frame) + (j_setrows text 4) + (j_setcolumns text 15) + (j_pack frame) + ;; Allocate immovable storage for passing data back from C land. + ;; Uses the GCL only make-array keyword :static + (let* ((xa (make-array 1 :initial-element 0 :element-type 'fixnum :static t)) + (ya (make-array 1 :initial-element 0 :element-type 'fixnum :static t)) + (pxa (inta-ptr xa)) + (pya (inta-ptr ya)) + (x 0) + (y 0) + (get-mouse-xy (lambda (obj) + (progn (j_getmousepos obj pxa pya) + (setf x (aref xa 0)) + (setf y (aref ya 0))))) + (startx 0) + (starty 0) + (selstart 0) + (selend 0) + (text-buffer (make-array 64000 :initial-element 0 :element-type 'character :static t)) +; (text-buffer (make-string 64000 :initial-element #\0)) + (p-text-buffer (inta-ptr text-buffer))) + (do ((obj (j_nextaction) (j_nextaction))) + ((or (= obj frame) (= obj quit-mi))t) + (when (= obj panel) + (format t "Size changed to ~D rows ~D columns~%" (j_getrows text) (j_getcolumns text)) + (format t "Size changed to ~D x ~D pixels~%" (j_getwidth text) (j_getheight text))) + (when (= obj text) (format t "Text changed (len=~D)~%" (j_getlength text) )) + (when (= obj new-mi) (j_settext new-text)) + (when (= obj save-mi) (j_gettext text text-buffer)) + (when (= obj select-all-mi) (j_selectall text)) + (when (or (= obj cut-mi) + (= obj copy-mi) + (= obj paste-mi)) + (setf selstart (1- (j_getselstart text))) + (setf selend (1- (j_getselend text)))) + (when (= obj cut-mi) + (j_getseltext text p-text-buffer) + (j_delete text (1- (j_getselstart text)) (1- (j_getselend text))) + (setf selend selstart)) + (when (= obj copy-mi) + (j_getseltext text p-text-buffer)) + (when (= obj paste-mi) + (if (= selstart selend) + (j_inserttext text p-text-buffer (1- (j_getcurpos text))) + (j_replacetext text p-text-buffer (1- (j_getselstart text)) (1- (j_getselend text)))) + )))))))))))))))))) + + + + \ No newline at end of file diff --git a/lsp/dbind.lisp b/lsp/dbind.lisp new file mode 100755 index 0000000..e0d2505 --- /dev/null +++ b/lsp/dbind.lisp @@ -0,0 +1,15 @@ +(in-package 'si) + +;(defun joe () +; (dbind ((a) b) (foo) (print (list a b)))) + +(defmacro destructuring-bind + (al val &body body &aux *dl* (*key-check* nil) + (*arg-check* nil) (sym (gensym))) + (dm-vl al sym t) + `(compiler::stack-let + ((,sym (cons nil ,val))) + (let* (,@ (nreverse *dl*)) + ,@body))) + + diff --git a/lsp/dummy.lisp b/lsp/dummy.lisp new file mode 100755 index 0000000..8b13789 --- /dev/null +++ b/lsp/dummy.lisp @@ -0,0 +1 @@ + diff --git a/lsp/fasd.lisp b/lsp/fasd.lisp new file mode 100755 index 0000000..ad0a89c --- /dev/null +++ b/lsp/fasd.lisp @@ -0,0 +1,151 @@ +(in-package 'si) + +(require "FASDMACROS" "../cmpnew/fasdmacros.lsp") +;; (test '(a (1)) 2 12.0) --> ((a (1)) 2 12.0) + +(defmacro dprint (x) + `(if (and (boundp 'debug) debug) + (format t "~%The value of ~a is ~s" ',x ,x))) + + + +(defun keep (x) (setq sil x)) +(defun test (&rest l &aux tab) + (with-open-file (st "/tmp/foo.l" + :direction :output ) + (let* ((fd (open-fasd st :output nil (setq tab (make-hash-table :test 'eq))))) + (declare (special *fd*)) + (si::find-sharing-top l tab) +; (preprocess l tab) + (sloop::sloop for v in l + do + (write-fasd-top v fd) + finally (close-fasd fd)))) + (test-in)) + +(defun preprocess1(lis table) + (cond ((symbolp lis) + (and lis + (let ((tem (gethash lis table))) + (cond (tem + (if (< (the fixnum tem) 0) + (setf (gethash lis table) (the fixnum (+ (the fixnum tem) -1))))) + (t (setf (gethash lis table) -1)))))) + ((consp lis) + (preprocess1 (car lis) table) + (preprocess1 (cdr lis) table)) + ((and (arrayp lis) + (eq (array-element-type lis) t)) + (sloop::sloop for i below (length lis) + do (preprocess1 (aref (the (array t) lis) i) table))) + ((and (arrayp lis) + (eq (array-element-type lis) t)) + (sloop::sloop for i below (length lis) + do (preprocess1 (aref (the (array t) lis) i) table))) + (t nil))) + +(defun preprocess (lis table &aux freq) + (preprocess1 lis table) + (sloop:sloop for (ke val) in-table table + with m = 0 declare (fixnum m) + do ;(print (list ke val)) + (cond((> (the fixnum val) 0) + (SETQ m (the fixnum (+ 1 m)))) + ((< (the fixnum val) -1) + (remhash ke table) + (push (cons val ke) freq))) + finally (sloop::loop-return + (sort freq '> :key 'car )))) + +(defun test-in () + (with-open-file (st "/tmp/foo.l" :direction :input) + (let ((fdin (open-fasd st :input (setq eof '(nil)) (keep (make-array 10))))) + (sloop while (not (eq eof (setq tem (read-fasd-top fdin)))) + collect tem + finally + (dprint fdin) + (close-fasd fdin))))) + +(defun try-write (file &aux (tab (make-hash-table :test 'eq)) (eof '(nil))) + (with-open-file (st file) + (with-open-file (st1 "/tmp/foo.l" :direction :output) + (sloop while (not (eq eof (setq tem (read st nil eof)))) with fd + collect (file-position st1) + do(clrhash tab) + + (setq fd (open-fasd st1 :output nil tab)) +; (let ((prp (preprocess tem tab))) +; (dprint prp)) + (write-fasd-top tem fd) + (close-fasd fd) + (dprint tab) + )))) +(defvar *differed* nil) + +(defun try-read (file pos &aux (tab (make-array 10)) (eof '(nil))) + (with-open-file (st file) + (with-open-file (st1 "/tmp/foo.l") + (sloop while (not (eq eof (setq tem (read st nil eof)))) with fd with re + for u in pos + do (file-position st1 u) + (setq fd (open-fasd st1 :input eof tab)) + (sloop::sloop for i below (length tab) do (setf (aref (the (array (t)) tab) i) nil)) + (setq re (read-fasd-top fd)) + (dprint re) + (unless (equalp tem re) + (push (list tem re) *differed*)) + ; (assert (eq eof (read-fasd-top fd))) + (close-fasd fd))))) + +(defun try (file) + (let ((pos (try-write file))) + (try-read file pos) + (print file) + (system (format nil "cat ~a | wc ; cat /tmp/foo.l | wc " (namestring file))) + )) + +(defvar *table* (make-hash-table :test 'eq)) +(defun do-share (x) + (si::find-sharing x *table*)) + + + + +(defun read-data-file (file) + (let ((pack-ops)) + (set-dispatch-macro-character #\# #\! + #'(lambda (st a b ) (setq pack-ops (read st nil nil) ))) + (with-open-file (st file) + (let ((tem (read st nil nil))) + (list pack-ops tem))))) + + +(defun write-out-data (lis fil) + (with-open-file (st fil :direction :output) + (let ((fd (open-fasd st :output nil (setq tab (make-hash-table :test 'eq))))) + (find-sharing-top lis (fasd-table fd)) + (write-fasd-top (car lis) fd) + (write-fasd-top (second lis) fd) +; (close-fasd fd) + fd))) + +;; To convert an ascii .data file to a fasd one. +;(setq bil (si::read-data-file "vmlisp.data") her nil) +;(SI::WRITE-OUT-DATA1 (SECOND BIL) (FIRST BIL) "/tmp/foo.l") +(defun write-out-data1 (data-vec pack-ops fil) + (with-open-file (st fil :direction :output) + (let ((compiler::*data* (list data-vec nil pack-ops)) + (compiler::*compiler-output-data* st) + (compiler::*fasd-data* (list (open-fasd st :output nil nil)))) + (compiler::wt-fasd-data-file) + (car compiler::*fasd-data*)))) + + + + + + +;(setq dirs (directory "/public/spad/libraries/A*/index.KAF*")) +;(mapcar 'try dirs) + + diff --git a/lsp/fast-mv.lisp b/lsp/fast-mv.lisp new file mode 100755 index 0000000..a4d1b0b --- /dev/null +++ b/lsp/fast-mv.lisp @@ -0,0 +1,41 @@ +(in-package 'compiler) + +;; Author W. Schelter + +;; Using fast-values in place of values, and fast-multiple-setq +;; allow functions to still be declared to have only 1 value, while +;; in effect returning several. This allows a great speed up in +;; returning extra values. Eventually we may incorporate this system +;; to allow similar code to be put out where multiple values are proclaimed +;; for the function. + +;; The primitives set-mv and mv-ref provide access to 10 storage places +;; directly by address, without the indirection of going through an array +;; or symbol. + +;; Sample usage: + +;;(proclaim '(function goo-fast-mv () t)) +;;(proclaim '(function foo-fast-mv (t) t)) +;; +;;(defun foo-fast-mv (n) +;; (let (x y z) +;; (sloop for i below n +;; do (fast-multiple-value-setq (x y z) (goo-fast-mv))) +;; (list x y z))) +;; +;;(defun goo-fast-mv () (fast-values 1 2 7)) + +(defmacro fast-values (a &rest l) + (or (< (length l) 10) (error "too many values")) + `(prog1 ,a ,@ (sloop::sloop for v in l + for i below 10 + collect `(si::set-mv ,i ,v)))) + +(defmacro fast-multiple-value-setq ((x &rest l) form) + (or (< (length l) 10) (error "too many values")) + `(prog1 (setq ,x ,form) + ,@ (sloop::sloop for i below 10 + for v in l + collect `(setq ,v (si::mv-ref ,i))))) + diff --git a/lsp/gcl_arraylib.lsp b/lsp/gcl_arraylib.lsp new file mode 100755 index 0000000..135bac8 --- /dev/null +++ b/lsp/gcl_arraylib.lsp @@ -0,0 +1,320 @@ +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +;;;; arraylib.lsp +;;;; +;;;; array routines + + +(in-package 'lisp) + + +(export '(make-array array-displacement vector + array-element-type array-rank array-dimension + array-dimensions + array-in-bounds-p array-row-major-index + adjustable-array-p + bit sbit + bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor + bit-andc1 bit-andc2 bit-orc1 bit-orc2 bit-not + array-has-fill-pointer-p fill-pointer + vector-push vector-push-extend vector-pop + adjust-array upgraded-array-element-type)) + +(in-package 'system) + + +(proclaim '(optimize (safety 2) (space 3))) + +(defvar *baet-hash* (make-hash-table :test 'equal)) +(defun best-array-element-type (type) + (or (gethash type *baet-hash*) + (setf (gethash type *baet-hash*) + (if type + (car (member type '(string-char bit signed-char unsigned-char signed-short unsigned-short + fixnum short-float long-float t) + :test 'subtypep)) t))))) + +(defun upgraded-array-element-type (type &optional environment) + (declare (ignore environment)) + (best-array-element-type type)) + +;(defun array-displacement (array) +; (let ((x (si:array-displacement1 array))) +; (values (car x) (cdr x))) +; ) + +(defun make-array (dimensions + &key (element-type t) + (initial-element nil) + (initial-contents nil initial-contents-supplied-p) + adjustable fill-pointer + displaced-to (displaced-index-offset 0) + static) + (when (integerp dimensions) (setq dimensions (list dimensions))) + (setq element-type (best-array-element-type element-type)) + (cond ((= (length dimensions) 1) + (let ((x (si:make-vector element-type (car dimensions) + adjustable fill-pointer + displaced-to displaced-index-offset + static initial-element))) + (when initial-contents-supplied-p + (do ((n (car dimensions)) + (lic (listp initial-contents) lic) + (ic initial-contents (if lic (cdr ic) ic)) + (i 0 (1+ i))) + ((>= i n)) + (declare (fixnum n i)) + (si:aset x i (if lic (car ic) (aref ic i))))) + x)) + (t + (let ((x + (make-array1 + (the fixnum(get-aelttype element-type)) + static initial-element + displaced-to (the fixnum displaced-index-offset) + dimensions))) + (if fill-pointer (error "fill pointer for 1 dimensional arrays only")) + (unless (member 0 dimensions) + (when initial-contents-supplied-p + (do ((cursor + (make-list (length dimensions) + :initial-element 0))) + (nil) + (declare (:dynamic-extent cursor)) + (aset-by-cursor x + (sequence-cursor initial-contents + cursor) + cursor) + (when (increment-cursor cursor dimensions) + (return nil))))) + x)))) + +(defun increment-cursor (cursor dimensions) + (if (null cursor) + t + (let ((carry (increment-cursor (cdr cursor) (cdr dimensions)))) + (if carry + (cond ((>= (the fixnum (1+ (the fixnum (car cursor)))) + (the fixnum (car dimensions))) + (rplaca cursor 0) + t) + (t + (rplaca cursor + (the fixnum (1+ (the fixnum (car cursor))))) + nil)) + nil)))) + + +(defun sequence-cursor (sequence cursor) + (if (null cursor) + sequence + (sequence-cursor (elt sequence (the fixnum (car cursor))) + (cdr cursor)))) + + +(defun vector (&rest objects &aux (l (list (length objects)))) + (declare (:dynamic-extent objects l)) + (make-array l + :element-type t + :initial-contents objects)) + + +(defun array-dimensions (array) + (do ((i (array-rank array)) + (d nil)) + ((= i 0) d) + (setq i (1- i)) + (setq d (cons (array-dimension array i) d)))) + + +(defun array-in-bounds-p (array &rest indices &aux (r (array-rank array))) + (declare (:dynamic-extent indices)) + (when (/= r (length indices)) + (error "The rank of the array is ~R,~%~ + ~7@Tbut ~R ~:*~[indices are~;index is~:;indices are~] ~ + supplied." + r (length indices))) + (do ((i 0 (1+ i)) + (s indices (cdr s))) + ((>= i r) t) + (when (or (< (car s) 0) + (>= (car s) (array-dimension array i))) + (return nil)))) + + +(defun array-row-major-index (array &rest indices) + (declare (:dynamic-extent indices)) + (do ((i 0 (1+ i)) + (j 0 (+ (* j (array-dimension array i)) (car s))) + (s indices (cdr s))) + ((null s) j))) + + +(defun bit (bit-array &rest indices) + (declare (:dynamic-extent indices)) + (apply #'aref bit-array indices)) + + +(defun sbit (bit-array &rest indices) + (declare (:dynamic-extent indices)) + (apply #'aref bit-array indices)) + + +(defun bit-and (bit-array1 bit-array2 &optional result-bit-array) + (bit-array-op boole-and bit-array1 bit-array2 result-bit-array)) + + +(defun bit-ior (bit-array1 bit-array2 &optional result-bit-array) + (bit-array-op boole-ior bit-array1 bit-array2 result-bit-array)) + + +(defun bit-xor (bit-array1 bit-array2 &optional result-bit-array) + (bit-array-op boole-xor bit-array1 bit-array2 result-bit-array)) + + +(defun bit-eqv (bit-array1 bit-array2 &optional result-bit-array) + (bit-array-op boole-eqv bit-array1 bit-array2 result-bit-array)) + + +(defun bit-nand (bit-array1 bit-array2 &optional result-bit-array) + (bit-array-op boole-nand bit-array1 bit-array2 result-bit-array)) + + +(defun bit-nor (bit-array1 bit-array2 &optional result-bit-array) + (bit-array-op boole-nor bit-array1 bit-array2 result-bit-array)) + + +(defun bit-andc1 (bit-array1 bit-array2 &optional result-bit-array) + (bit-array-op boole-andc1 bit-array1 bit-array2 result-bit-array)) + + +(defun bit-andc2 (bit-array1 bit-array2 &optional result-bit-array) + (bit-array-op boole-andc2 bit-array1 bit-array2 result-bit-array)) + + +(defun bit-orc1 (bit-array1 bit-array2 &optional result-bit-array) + (bit-array-op boole-orc1 bit-array1 bit-array2 result-bit-array)) + + +(defun bit-orc2 (bit-array1 bit-array2 &optional result-bit-array) + (bit-array-op boole-orc2 bit-array1 bit-array2 result-bit-array)) + + +(defun bit-not (bit-array &optional result-bit-array) + (bit-array-op boole-c1 bit-array bit-array result-bit-array)) + + +(defun vector-push (new-element vector) + (let ((fp (fill-pointer vector))) + (declare (fixnum fp)) + (cond ((< fp (the fixnum (array-dimension vector 0))) + (si:aset vector fp new-element) + (si:fill-pointer-set vector (the fixnum (1+ fp))) + fp) + (t nil)))) + + +(defun vector-push-extend (new-element vector &optional extension) + (let ((fp (fill-pointer vector))) + (declare (fixnum fp)) + (cond ((< fp (the fixnum (array-dimension vector 0))) + (si:aset vector fp new-element) + (si:fill-pointer-set vector (the fixnum (1+ fp))) + fp) + (t + (adjust-array vector + (list (+ (array-dimension vector 0) + (or extension + (if (> (array-dimension vector 0) 0) + (array-dimension vector 0) + 5)))) + :element-type (array-element-type vector) + :fill-pointer fp) + (si:aset vector fp new-element) + (si:fill-pointer-set vector (the fixnum (1+ fp))) + fp)))) + + +(defun vector-pop (vector) + (let ((fp (fill-pointer vector))) + (declare (fixnum fp)) + (when (= fp 0) + (error "The fill pointer of the vector ~S zero." vector)) + (si:fill-pointer-set vector (the fixnum (1- fp))) + (aref vector (the fixnum (1- fp))))) + + +(defun maset (array x dim &optional (cx (cons x -1)) (cur (make-list (length dim) :initial-element 0)) (ind cur)) + (declare (dynamic-extent cur)) + (cond (dim (dotimes (i (pop dim)) (setf (car cur) i) (maset array x dim cx (cdr cur) ind))) + ((incf (cdr cx)) + (when (apply 'array-in-bounds-p array ind) + (row-major-aset (apply 'aref array ind) (car cx) (cdr cx)))))) + +(defun adjust-array (array new-dimensions + &key element-type + initial-element + (initial-contents nil initial-contents-supplied-p) + fill-pointer + displaced-to + (displaced-index-offset 0) + (static (staticp array)) + &aux (fill-pointer (or fill-pointer (when (array-has-fill-pointer-p array) (fill-pointer array))))) + + (declare (ignore element-type)) + + (let ((x (if initial-contents-supplied-p + (make-array new-dimensions + :adjustable t + :static static + :element-type (array-element-type array) + :fill-pointer fill-pointer + :initial-contents initial-contents + :displaced-to displaced-to + :displaced-index-offset displaced-index-offset) + (make-array new-dimensions + :adjustable t + :static static + :element-type (array-element-type array) + :fill-pointer fill-pointer + :initial-element initial-element + :displaced-to displaced-to + :displaced-index-offset displaced-index-offset)))) + + (unless (or displaced-to initial-contents-supplied-p) + + (cond ((or (atom new-dimensions) + (null (cdr new-dimensions)) + (when (equal (cdr new-dimensions) (cdr (array-dimensions array))) + (or (not (eq element-type 'bit)) + (eql 0 (the fixnum (mod (the fixnum (car (last new-dimensions))) char-size)))))) + (copy-array-portion array x 0 0 (min (array-total-size x) (array-total-size array)))) + ((maset array x new-dimensions)))) + + (si:replace-array array x) + + (when fill-pointer + (setf (fill-pointer array) (if (eq fill-pointer t) (array-total-size array) fill-pointer))) + array)) + + + + + diff --git a/lsp/gcl_assert.lsp b/lsp/gcl_assert.lsp new file mode 100755 index 0000000..cf1ecfc --- /dev/null +++ b/lsp/gcl_assert.lsp @@ -0,0 +1,81 @@ +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +;;;; assert.lsp + + +(in-package :si) + +(defun read-evaluated-form nil + (format *query-io* "~&type a form to be evaluated:~%") + (list (eval (read *query-io*)))) + +(defun check-type-symbol (symbol value type &optional type-string + &aux (type-string (when type-string (concatenate 'string ": need a " type-string)))) + (restart-case + (cerror "Check type again." 'type-error :datum value :expected-type type) + (store-value (v) + :report (lambda (stream) (format stream "Supply a new value of ~s. ~a" symbol (or type-string ""))) + :interactive read-evaluated-form + (setf value v))) + (if (typep value type) value (check-type-symbol symbol value type type-string))) + +(defmacro check-type (place typespec &optional string) + (declare (optimize (safety 2))) + `(progn (,(if (symbolp place) 'setq 'setf) ,place + (the ,typespec (if (typep ,place ',typespec) ,place (check-type-symbol ',place ,place ',typespec ',string)))) nil)) + + +(defmacro assert (test-form &optional places string &rest args) + `(do nil;(*print-level* 4) (*print-length* 4) + (,test-form nil) + ,(if string + `(cerror "" ,string ,@args) + `(cerror "" "The assertion ~:@(~S~) is failed." ',test-form)) + ,@(mapcan (lambda (place) + `((format *error-output* + "Please input the new value for the place ~:@(~S~): " + ',place) + (finish-output *error-output*) + (setf ,place (read)))) places))) + +(defmacro typecase (keyform &rest clauses &aux (key (if (symbolp keyform) keyform (sgen "TYPECASE")))) + (declare (optimize (safety 2))) + (labels ((l (x &aux (c (pop x))(tp (pop c))(fm (if (cdr c) (cons 'progn c) (car c)))(y (when x (l x)))) + (if (or (eq tp t) (eq tp 'otherwise)) fm `(if (typep ,key ',tp) ,fm ,y)))) + (let ((x (l clauses))) + (if (eq key keyform) x `(let ((,key ,keyform)) ,x))))) + +(defmacro ctypecase (keyform &rest clauses &aux (key (sgen "CTYPECASE"))) + (declare (optimize (safety 2))) +; (check-type clauses (list-of proper-list)) + `(do nil (nil) + (typecase ,keyform + ,@(mapcar (lambda (l) + `(,(car l) (return (progn ,@(subst key keyform (cdr l)))))) + clauses)) + (check-type ,keyform (or ,@(mapcar 'car clauses))))) + +(defmacro etypecase (keyform &rest clauses &aux (key (if (symbolp keyform) keyform (sgen "ETYPECASE")))) + (declare (optimize (safety 2))) +; (check-type clauses (list-of proper-list)) + (let ((tp `(or ,@(mapcar 'car clauses)))) + `(let ((,key ,keyform)) (typecase ,key ,@clauses (t (error 'type-error :datum ,key :expected-type ',tp)))))) + + diff --git a/lsp/gcl_auto.lsp b/lsp/gcl_auto.lsp new file mode 100755 index 0000000..73fa995 --- /dev/null +++ b/lsp/gcl_auto.lsp @@ -0,0 +1,217 @@ +(in-package 'si) +;;; Autoloaders. + + +;;; DEFAUTOLOAD definitions. for lsp directory files normally loaded. +(if (fboundp 'abs) (push :numlib *features*)) +;;hack to avoid interning all the :symbols if the files are loaded.. +#-numlib +(progn +(autoload 'abs '|numlib|) +(autoload 'acos '|numlib|) +(autoload 'acosh '|numlib|) +(autoload 'adjust-array '|arraylib|) +(autoload 'apropos '|packlib|) +(autoload 'apropos-list '|packlib|) +(autoload 'array-dimensions '|arraylib|) +(autoload 'array-in-bounds-p '|arraylib|) +(autoload 'array-row-major-index '|arraylib|) +(autoload 'asin '|numlib|) +(autoload 'asinh '|numlib|) +(autoload 'atanh '|numlib|) +(autoload 'best-array-element-type '|arraylib|) +(autoload 'bit '|arraylib|) +(autoload 'bit-and '|arraylib|) +(autoload 'bit-andc1 '|arraylib|) +(autoload 'bit-andc2 '|arraylib|) +(autoload 'bit-eqv '|arraylib|) +(autoload 'bit-ior '|arraylib|) +(autoload 'bit-nand '|arraylib|) +(autoload 'bit-nor '|arraylib|) +(autoload 'bit-not '|arraylib|) +(autoload 'bit-orc1 '|arraylib|) +(autoload 'bit-orc2 '|arraylib|) +(autoload 'bit-xor '|arraylib|) +(autoload 'byte '|numlib|) +(autoload 'byte-position '|numlib|) +(autoload 'byte-size '|numlib|) +(autoload 'cis '|numlib|) +(autoload 'coerce '|predlib|) +(autoload 'compile-file '|loadcmp|) +(autoload 'compile '|loadcmp|) +(autoload 'disassemble '|loadcmp|) +(autoload 'concatenate '|seq|) +(autoload 'cosh '|numlib|) +(autoload 'count '|seqlib|) +(autoload 'count-if '|seqlib|) +(autoload 'count-if-not '|seqlib|) +(autoload 'decode-universal-time '|mislib|) +(autoload 'delete '|seqlib|) +(autoload 'delete-duplicates '|seqlib|) +(autoload 'delete-if '|seqlib|) +(autoload 'delete-if-not '|seqlib|) +(autoload 'deposit-field '|numlib|) +(autoload 'describe '|describe|) +(autoload 'dpb '|numlib|) +(autoload 'dribble '|iolib|) +(autoload 'encode-universal-time '|mislib|) +(autoload 'every '|seq|) +(autoload 'fceiling '|numlib|) +(autoload 'ffloor '|numlib|) +(autoload 'fill '|seqlib|) +(autoload 'find '|seqlib|) +(autoload 'find-all-symbols '|packlib|) +(autoload 'find-if '|seqlib|) +(autoload 'find-if-not '|seqlib|) +(autoload 'fround '|numlib|) +(autoload 'ftruncate '|numlib|) +#-unix (autoload 'get-decoded-time '|mislib|) +#+aosvs (autoload 'get-universal-time '|mislib|) +(autoload 'get-setf-method '|setf|) +(autoload 'get-setf-method-multiple-value '|setf|) +(autoload 'inspect '|describe|) +(autoload 'intersection '|listlib|) +(autoload 'isqrt '|numlib|) +(autoload 'ldb '|numlib|) +(autoload 'ldb-test '|numlib|) +(autoload 'logandc1 '|numlib|) +(autoload 'logandc2 '|numlib|) +(autoload 'lognand '|numlib|) +(autoload 'lognor '|numlib|) +(autoload 'lognot '|numlib|) +(autoload 'logorc1 '|numlib|) +(autoload 'logorc2 '|numlib|) +(autoload 'logtest '|numlib|) +(autoload 'make-array '|arraylib|) +(autoload 'make-sequence '|seq|) +(autoload 'map '|seq|) +(autoload 'mask-field '|numlib|) +(autoload 'merge '|seqlib|) +(autoload 'mismatch '|seqlib|) +(autoload 'nintersection '|listlib|) +(autoload 'notany '|seq|) +(autoload 'notevery '|seq|) +(autoload 'si::normalize-type ':predlib) +(autoload 'nset-difference '|listlib|) +(autoload 'nset-exclusive-or '|listlib|) +(autoload 'nsubstitute '|seqlib|) +(autoload 'nsubstitute-if '|seqlib|) +(autoload 'nsubstitute-if-not '|seqlib|) +(autoload 'nunion '|listlib|) +(autoload 'phase '|numlib|) +(autoload 'position '|seqlib|) +(autoload 'position-if '|seqlib|) +(autoload 'position-if-not '|seqlib|) +(autoload 'prin1-to-string '|iolib|) +(autoload 'princ-to-string '|iolib|) +(autoload 'rational '|numlib|) +(autoload 'rationalize '|numlib|) +(autoload 'read-from-string '|iolib|) +(autoload 'reduce '|seqlib|) +(autoload 'remove '|seqlib|) +(autoload 'remove-duplicates '|seqlib|) +(autoload 'remove-if '|seqlib|) +(autoload 'remove-if-not '|seqlib|) +(autoload 'replace '|seqlib|) +(autoload 'sbit '|arraylib|) +(autoload 'search '|seqlib|) +(autoload 'set-difference '|listlib|) +(autoload 'set-exclusive-or '|listlib|) +(autoload 'signum '|numlib|) +(autoload 'sinh '|numlib|) +(autoload 'some '|seq|) +(autoload 'sort '|seqlib|) +(autoload 'stable-sort '|seqlib|) +(autoload 'subsetp '|listlib|) +(autoload 'substitute '|seqlib|) +(autoload 'substitute-if '|seqlib|) +(autoload 'substitute-if-not '|seqlib|) +(autoload 'subtypep '|predlib|) +(autoload 'tanh '|numlib|) +(autoload 'typep '|predlib|) +(autoload 'union '|listlib|) +(autoload 'vector '|arraylib|) +(autoload 'vector-pop '|arraylib|) +(autoload 'vector-push '|arraylib|) +(autoload 'vector-extend '|arraylib|) +(autoload 'write-to-string '|iolib|) +(autoload 'y-or-n-p '|iolib|) +(autoload 'yes-or-no-p '|iolib|) + + +(set-dispatch-macro-character #\# #\a 'si::sharp-a-reader) +(set-dispatch-macro-character #\# #\A 'si::sharp-a-reader) +(autoload 'si::sharp-a-reader '"iolib") +(set-dispatch-macro-character #\# #\s 'si::sharp-s-reader) +(set-dispatch-macro-character #\# #\S 'si::sharp-s-reader) +(autoload 'si::sharp-s-reader '|iolib|) + + +;;; DEFAUTOLOADMACRO definitions. + +(autoload-macro 'assert '|assert|) +(autoload-macro 'ccase '|assert|) +(autoload-macro 'check-type '|assert|) +(autoload-macro 'ctypecase '|assert|) +(autoload-macro 'decf '|setf|) +(autoload-macro 'define-modify-macro '|setf|) +(autoload-macro 'define-setf-method '|setf|) +(autoload-macro 'defsetf '|setf|) +(autoload-macro 'defstruct '|defstruct|) +(autoload-macro 'si::define-structure '|defstruct|) +(autoload-macro 'deftype '|predlib|) +(autoload-macro 'do-all-symbols '|packlib|) +(autoload-macro 'do-external-symbols '|packlib|) +(autoload-macro 'do-symbols '|packlib|) +(autoload-macro 'ecase '|assert|) +(autoload-macro 'etypecase '|assert|) +(autoload-macro 'incf '|setf|) +(autoload-macro 'pop '|setf|) +(autoload-macro 'push '|setf|) +(autoload-macro 'pushnew '|setf|) +(autoload-macro 'remf '|setf|) +(autoload-macro 'rotatef '|setf|) +(autoload-macro 'setf '|setf|) +(autoload-macro 'shiftf '|setf|) +(autoload-macro 'step '|trace|) +(autoload-macro 'time '|mislib|) +(autoload-macro 'trace '|trace|) +(autoload-macro 'typecase '|assert|) +(autoload-macro 'untrace '|trace|) +(autoload-macro 'with-input-from-string '|iolib|) +(autoload-macro 'with-open-file '|iolib|) +(autoload-macro 'with-open-stream '|iolib|) +(autoload-macro 'with-output-to-string '|iolib|) +) ;;end autoloads of normally loaded files.j +(if (find-package "COMPILER") (push :compiler *features*)) +#+compiler +(autoload 'compiler::emit-fn '|../cmpnew/gcl_collectfn|) +(autoload 'compiler::init-fn '|../cmpnew/gcl_collectfn|) +(autoload 'si::monstartup '"gprof") +(autoload 'si::set-up-profile '"profile") + +(AUTOLOAD 'IDESCRIBE '|info|) +(AUTOLOAD 'INFO '|info|) +(AUTOLOAD 'LIST-MATCHES '|info|) +(AUTOLOAD 'get-match '|info|) +(AUTOLOAD 'print-node '|tinfo|) +(AUTOLOAD 'offer-choices '|tinfo|) +(AUTOLOAD 'tkconnect '|tkl|) + + + + +;; the sun has a broken ypbind business, if one wants to save. +;; So to stop users from invoking this +#+sun +(defun user-homedir-pathname () + (let* ((tem (si::getenv "HOME")) + (l (- (length tem) 1))) + (cond ((null tem) nil) + (t + (or (and (>= l 0) + (eql (aref tem l) #\/)) + (setq tem (concatenate 'string tem "/"))) + (pathname tem))))) + + diff --git a/lsp/gcl_auto_new.lsp b/lsp/gcl_auto_new.lsp new file mode 100755 index 0000000..ec4e013 --- /dev/null +++ b/lsp/gcl_auto_new.lsp @@ -0,0 +1,220 @@ +(in-package 'si) +;;; Autoloaders. + + +;;; DEFAUTOLOAD definitions. for lsp directory files normally loaded. +(if (fboundp 'abs) (push :numlib *features*)) +;;hack to avoid interning all the :symbols if the files are loaded.. +#-numlib +(progn +(autoload 'abs '|gcl_numlib|) +(autoload 'acos '|gcl_numlib|) +(autoload 'acosh '|gcl_numlib|) +(autoload 'adjust-array '|gcl_arraylib|) +(autoload 'apropos '|gcl_packlib|) +(autoload 'apropos-list '|gcl_packlib|) +(autoload 'array-dimensions '|gcl_arraylib|) +(autoload 'array-in-bounds-p '|gcl_arraylib|) +(autoload 'array-row-major-index '|gcl_arraylib|) +(autoload 'asin '|gcl_numlib|) +(autoload 'asinh '|gcl_numlib|) +(autoload 'atanh '|gcl_numlib|) +(autoload 'best-array-element-type '|gcl_arraylib|) +(autoload 'bit '|gcl_arraylib|) +(autoload 'bit-and '|gcl_arraylib|) +(autoload 'bit-andc1 '|gcl_arraylib|) +(autoload 'bit-andc2 '|gcl_arraylib|) +(autoload 'bit-eqv '|gcl_arraylib|) +(autoload 'bit-ior '|gcl_arraylib|) +(autoload 'bit-nand '|gcl_arraylib|) +(autoload 'bit-nor '|gcl_arraylib|) +(autoload 'bit-not '|gcl_arraylib|) +(autoload 'bit-orc1 '|gcl_arraylib|) +(autoload 'bit-orc2 '|gcl_arraylib|) +(autoload 'bit-xor '|gcl_arraylib|) +(autoload 'byte '|gcl_numlib|) +(autoload 'byte-position '|gcl_numlib|) +(autoload 'byte-size '|gcl_numlib|) +(autoload 'cis '|gcl_numlib|) +(autoload 'coerce '|gcl_predlib|) +(autoload 'compile-file '|gcl_loadcmp|) +(autoload 'compile '|gcl_loadcmp|) +(autoload 'disassemble '|gcl_loadcmp|) +(autoload 'concatenate '|gcl_seq|) +(autoload 'cosh '|gcl_numlib|) +(autoload 'count '|gcl_seqlib|) +(autoload 'count-if '|gcl_seqlib|) +(autoload 'count-if-not '|gcl_seqlib|) +(autoload 'decode-universal-time '|gcl_mislib|) +(autoload 'delete '|gcl_seqlib|) +(autoload 'delete-duplicates '|gcl_seqlib|) +(autoload 'delete-if '|gcl_seqlib|) +(autoload 'delete-if-not '|gcl_seqlib|) +(autoload 'deposit-field '|gcl_numlib|) +(autoload 'describe '|gcl_describe|) +(autoload 'dpb '|gcl_numlib|) +(autoload 'dribble '|gcl_iolib|) +(autoload 'encode-universal-time '|gcl_mislib|) +(autoload 'every '|gcl_seq|) +(autoload 'fceiling '|gcl_numlib|) +(autoload 'ffloor '|gcl_numlib|) +(autoload 'fill '|gcl_seqlib|) +(autoload 'find '|gcl_seqlib|) +(autoload 'find-all-symbols '|gcl_packlib|) +(autoload 'find-if '|gcl_seqlib|) +(autoload 'find-if-not '|gcl_seqlib|) +(autoload 'fround '|gcl_numlib|) +(autoload 'ftruncate '|gcl_numlib|) +#-unix (autoload 'get-decoded-time '|gcl_mislib|) +#+aosvs (autoload 'get-universal-time '|gcl_mislib|) +(autoload 'get-setf-method '|gcl_setf|) +(autoload 'get-setf-method-multiple-value '|gcl_setf|) +(autoload 'inspect '|gcl_describe|) +(autoload 'intersection '|gcl_listlib|) +(autoload 'isqrt '|gcl_numlib|) +(autoload 'ldb '|gcl_numlib|) +(autoload 'ldb-test '|gcl_numlib|) +(autoload 'logandc1 '|gcl_numlib|) +(autoload 'logandc2 '|gcl_numlib|) +(autoload 'lognand '|gcl_numlib|) +(autoload 'lognor '|gcl_numlib|) +(autoload 'lognot '|gcl_numlib|) +(autoload 'logorc1 '|gcl_numlib|) +(autoload 'logorc2 '|gcl_numlib|) +(autoload 'logtest '|gcl_numlib|) +(autoload 'make-array '|gcl_arraylib|) +(autoload 'make-sequence '|gcl_seq|) +(autoload 'map '|gcl_seq|) +(autoload 'mask-field '|gcl_numlib|) +(autoload 'merge '|gcl_seqlib|) +(autoload 'mismatch '|gcl_seqlib|) +(autoload 'nintersection '|gcl_listlib|) +(autoload 'notany '|gcl_seq|) +(autoload 'notevery '|gcl_seq|) +(autoload 'si::normalize-type ':predlib) +(autoload 'nset-difference '|gcl_listlib|) +(autoload 'nset-exclusive-or '|gcl_listlib|) +(autoload 'nsubstitute '|gcl_seqlib|) +(autoload 'nsubstitute-if '|gcl_seqlib|) +(autoload 'nsubstitute-if-not '|gcl_seqlib|) +(autoload 'nunion '|gcl_listlib|) +(autoload 'phase '|gcl_numlib|) +(autoload 'position '|gcl_seqlib|) +(autoload 'position-if '|gcl_seqlib|) +(autoload 'position-if-not '|gcl_seqlib|) +(autoload 'prin1-to-string '|gcl_iolib|) +(autoload 'princ-to-string '|gcl_iolib|) +(autoload 'rational '|gcl_numlib|) +(autoload 'rationalize '|gcl_numlib|) +(autoload 'read-from-string '|gcl_iolib|) +(autoload 'reduce '|gcl_seqlib|) +(autoload 'remove '|gcl_seqlib|) +(autoload 'remove-duplicates '|gcl_seqlib|) +(autoload 'remove-if '|gcl_seqlib|) +(autoload 'remove-if-not '|gcl_seqlib|) +(autoload 'replace '|gcl_seqlib|) +(autoload 'sbit '|gcl_arraylib|) +(autoload 'search '|gcl_seqlib|) +(autoload 'set-difference '|gcl_listlib|) +(autoload 'set-exclusive-or '|gcl_listlib|) +(autoload 'signum '|gcl_numlib|) +(autoload 'sinh '|gcl_numlib|) +(autoload 'some '|gcl_seq|) +(autoload 'sort '|gcl_seqlib|) +(autoload 'stable-sort '|gcl_seqlib|) +(autoload 'subsetp '|gcl_listlib|) +(autoload 'substitute '|gcl_seqlib|) +(autoload 'substitute-if '|gcl_seqlib|) +(autoload 'substitute-if-not '|gcl_seqlib|) +(autoload 'subtypep '|gcl_predlib|) +(autoload 'tanh '|gcl_numlib|) +(autoload 'typep '|gcl_predlib|) +(autoload 'union '|gcl_listlib|) +(autoload 'vector '|gcl_arraylib|) +(autoload 'vector-pop '|gcl_arraylib|) +(autoload 'vector-push '|gcl_arraylib|) +(autoload 'vector-extend '|gcl_arraylib|) +(autoload 'write-to-string '|gcl_iolib|) +(autoload 'y-or-n-p '|gcl_iolib|) +(autoload 'yes-or-no-p '|gcl_iolib|) + + +(set-dispatch-macro-character #\# #\a 'si::sharp-a-reader) +(set-dispatch-macro-character #\# #\A 'si::sharp-a-reader) +(autoload 'si::sharp-a-reader '"iolib") +(set-dispatch-macro-character #\# #\s 'si::sharp-s-reader) +(set-dispatch-macro-character #\# #\S 'si::sharp-s-reader) +(autoload 'si::sharp-s-reader '|gcl_iolib|) + + +;;; DEFAUTOLOADMACRO definitions. + +(autoload-macro 'assert '|gcl_assert|) +(autoload-macro 'ccase '|gcl_assert|) +(autoload-macro 'check-type '|gcl_assert|) +(autoload-macro 'ctypecase '|gcl_assert|) +(autoload-macro 'decf '|gcl_setf|) +(autoload-macro 'define-modify-macro '|gcl_setf|) +(autoload-macro 'define-setf-method '|gcl_setf|) +(autoload-macro 'defsetf '|gcl_setf|) +(autoload-macro 'defstruct '|gcl_defstruct|) +(autoload-macro 'si::define-structure '|gcl_defstruct|) +(autoload-macro 'deftype '|gcl_predlib|) +(autoload-macro 'do-all-symbols '|gcl_packlib|) +(autoload-macro 'do-external-symbols '|gcl_packlib|) +(autoload-macro 'do-symbols '|gcl_packlib|) +(autoload-macro 'ecase '|gcl_assert|) +(autoload-macro 'etypecase '|gcl_assert|) +(autoload-macro 'incf '|gcl_setf|) +(autoload-macro 'pop '|gcl_setf|) +(autoload-macro 'push '|gcl_setf|) +(autoload-macro 'pushnew '|gcl_setf|) +(autoload-macro 'remf '|gcl_setf|) +(autoload-macro 'rotatef '|gcl_setf|) +(autoload-macro 'setf '|gcl_setf|) +(autoload-macro 'shiftf '|gcl_setf|) +(autoload-macro 'step '|gcl_trace|) +(autoload-macro 'time '|gcl_mislib|) +(autoload-macro 'trace '|gcl_trace|) +(autoload-macro 'typecase '|gcl_assert|) +(autoload-macro 'untrace '|gcl_trace|) +(autoload-macro 'with-input-from-string '|gcl_iolib|) +(autoload-macro 'with-open-file '|gcl_iolib|) +(autoload-macro 'with-open-stream '|gcl_iolib|) +(autoload-macro 'with-output-to-string '|gcl_iolib|) +) ;;end autoloads of normally loaded files.j +(if (find-package "COMPILER") (push :compiler *features*)) +#+compiler +(autoload 'compiler::emit-fn '|../cmpnew/gcl_collectfn|) +(autoload 'compiler::init-fn '|../cmpnew/gcl_collectfn|) +(autoload 'si::monstartup '"gprof") +(autoload 'si::set-up-profile '"profile") + +(AUTOLOAD 'IDESCRIBE '|gcl_info|) +(AUTOLOAD 'INFO '|gcl_info|) +(AUTOLOAD 'LIST-MATCHES '|gcl_info|) +(AUTOLOAD 'get-match '|gcl_info|) +(AUTOLOAD 'print-node '|tinfo|) +(AUTOLOAD 'offer-choices '|tinfo|) +(AUTOLOAD 'tkconnect '|tkl|) + +(AUTOLOAD 'user::xgcl-demo '|gcl_dwtest|) +(defun user::xgcl nil + (use-package :xlib) + (format t "Welcome to xgcl! Try (xgcl-demo) for a demonstration.")) + +;; the sun has a broken ypbind business, if one wants to save. +;; So to stop users from invoking this +#+sun +(defun user-homedir-pathname () + (let* ((tem (si::getenv "HOME")) + (l (- (length tem) 1))) + (cond ((null tem) nil) + (t + (or (and (>= l 0) + (eql (aref tem l) #\/)) + (setq tem (concatenate 'string tem "/"))) + (pathname tem))))) + + +(AUTOLOAD 'init-readline '|gcl_readline|) diff --git a/lsp/gcl_autocmp.lsp b/lsp/gcl_autocmp.lsp new file mode 100755 index 0000000..a12c52e --- /dev/null +++ b/lsp/gcl_autocmp.lsp @@ -0,0 +1,51 @@ +;;SAMPLE USAGE: +;;(def-autocomp foo (a b) (+ a b)) +;;(def-autocomp goo (a b) (- a b)) +;; +;;(foo 3 4) ==> 7 (after compiling foo and goo together..) +;; +;;Note: Might want to have a *use-count* which only compiles +;;after *use-count* gets above say 10. Thus it would only compile +;;the set of *new-definitions* when there were more than 10. +;;Would need to change the following slightly. Instead of storing the defun +;;store the lambda form, and have the autocomp do an apply of the lambda +;;form while incrementing the *use-count*. This is probably much better, +;;since the *use-count* much more accurately reflects the cost of not compiling +;;This code is obsolete before being used!! But I have to go now.. + +(require "SLOOP") +(use-package "SLOOP") + + +(defvar *new-definitions* nil) + +(defun compile-new-definitions (name) + (and name + (or (member name *new-definitions*) + (error "~a is not in *new-definitions*" name))) + (let ((lisp-file "cmptemp.lisp")(o-file "cmptemp.o")) + ;;in case somehow order matters.. + (setq *new-definitions* (nreverse *new-definitions*)) + (with-open-file (st lisp-file :direction :output) + (sloop for v in *new-definitions* + do (princ (get v 'new-definition) st))) + (compile-file lisp-file :output-file o-file) + (load o-file) + (setq *new-definitions* nil))) + +(defun autocomp (name args) + (compile-new-definitions name) + (apply name args)) + +(defmacro def-autocomp (fun args &rest body) + (let ((defn (list* 'defun fun args body))) + `(progn (push ',fun *new-definitions*) + (setf (get ',fun 'new-definition) ',defn) + (defun ,fun (&rest args) + (autocomp ',fun args))))) + + + + + + diff --git a/lsp/gcl_autoload.lsp b/lsp/gcl_autoload.lsp new file mode 100755 index 0000000..a604ac1 --- /dev/null +++ b/lsp/gcl_autoload.lsp @@ -0,0 +1,418 @@ +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + + +;;;; AUTOLOAD + + +;;; Go into LISP. +(in-package 'lisp) + +;(defvar *features*) + +(defun lisp-implementation-type () "GNU Common Lisp (GCL)") + +(defun machine-type () #+sun "SUN" + #+hp-ux "HP-UX" + #+eclipse "ECLIPSE" + #+vax "VAX" + ) + +;(defun machine-type () "DEC VAX11/780") + +(defun machine-version () (machine-type)) +;(defun machine-version () nil) + +(defun machine-instance () (machine-type)) +;(defun machine-instance () nil) + +(defun software-type () + #+aosv "AOS/VS" + #+bsd "BSD" + #+system-v "SYSTEM-V" + #+hp-ux "HP-UX") + +;(defun software-type () "UNIX BSD") + +(defun software-version () (software-type)) +;(defun software-version () "4.2BSD") + +;(defun short-site-name () "RIMS") +(defun short-site-name () nil) + +;(defun long-site-name () +; "Research Institute for Mathematical Sciences, Kyoto University") +(defun long-site-name () nil) + + + +;;; Compiler functions. + +(defun proclaim (d) + (when (eq (car d) 'special) (mapc #'si:*make-special (cdr d)))) + +(defun proclamation (d) + (and (eq (car d) 'special) + (dolist (var (cdr d) t) + (unless (si:specialp var) (return nil))))) + +(defun compile-file (&rest args) + (error "COMPILE-FILE is not defined in this load module.")) +(defun compile (&rest args) + (error "COMPILE is not defined in this load module.")) +(defun disassemble (&rest args) + (error "DISASSEMBLE is not defined in this load module.")) + + +;;; Editor. + +; +(defun get-decoded-time () + (decode-universal-time (get-universal-time))) + +#+never +(defun get-universal-time () + (multiple-value-bind (sec min h d m y dow dstp tz) + (get-decoded-time) + (encode-universal-time sec min h d m y tz))) + + +; Set the default system editor to a fairly certain bet. +#-winnt(defvar *gcl-editor* "vi") +#+winnt(defvar *gcl-editor* "notepad") + +(defun new-ed (editor-name) + "Change the editor called by (ed) held in *gcl-editor*." + (setf *gcl-editor* editor-name)) + +(defun ed (&optional name) + "Edit a file using the editor named in *gcl-editor*; customise with new-ed()." + (if (null name) + (system *gcl-editor*) + (cond ((stringp name) + (system (format nil "~A ~A" *gcl-editor* name))) ; If string, assume file name. + ((pathnamep name) + (system (format nil "~A ~A" *gcl-editor* (namestring name)))) ; If pathname. + (t + (let ((body (symbol-function name))) + (cond ((compiled-function-p body) (error "You can't edit compiled functions.")) + ((and body + (consp body) + (eq (car body) 'lambda-block)) ; If lambda block, save file and edit. + (let ((ed-file (concatenate 'string + (temp-dir) + (format nil "~A" (cadr body)) + ".lisp"))) + (with-open-file + (st ed-file :direction :output) + (print `(defun ,name ,@ (cddr body)) st)) + (system (format nil "~A ~A" *gcl-editor* ed-file)))) + (t (system (format nil "~A ~A" *gcl-editor* name))))))))) ; Use symbol as filename + +;;; Allocator. + +(import 'si::allocate) +(export '(allocate + ;allocated-pages maximum-allocatable-pages + ;allocate-contiguous-pages + ;allocated-contiguous-pages maximum-contiguous-pages + ;allocate-relocatable-pages allocated-relocatable-pages + sfun gfun cfun cclosure spice structure)) + +;(defvar type-character-alist +; '((cons . #\.) +; (fixnum . #\N) +; (bignum . #\B) +; (ratio . #\R) +; (short-float . #\F) +; (long-float . #\L) +; (complex . #\C) +; (character . #\#) +; (symbol . #\|) +; (package . #\:) +; (hash-table . #\h) +; (array . #\a) +; (vector . #\v) +; (string . #\") +; (bit-vector . #\b) +; (structure . #\S) +; (sfun . #\g) +; (stream . #\s) +; (random-state . #\$) +; (readtable . #\r) +; (pathname . #\p) +; (cfun . #\f) +; (vfun . #\V) +; (cclosure . #\c) +; (spice . #\!))) +; +;(defun get-type-character (type) +; (let ((a (assoc type type-character-alist))) +; (unless a +; (error "~S is not an implementation type.~%~ +; It should be one of:~%~ +; ~{~10T~S~^~30T~S~^~50T~S~%~}~%" +; type +; (mapcar #'car type-character-alist))) +; (cdr a))) + +;(defun allocate (type quantity &optional really-allocate) +; (si:alloc (get-type-character type) quantity really-allocate)) + +;(defun allocated-pages (type) +; (si:npage (get-type-character type))) + +;(defun maximum-allocatable-pages (type) +; (si:maxpage (get-type-character type))) + +;(defun allocate-contiguous-pages (quantity &optional really-allocate) +; (si::alloc-contpage quantity really-allocate)) + +;(defun allocated-contiguous-pages () +; (si:ncbpage)) + +;(defun maximum-contiguous-pages () +; (si::maxcbpage)) + +;(defun allocate-relocatable-pages (quantity &optional really-allocate) +; (si::alloc-relpage quantity)) + +;(defun allocated-relocatable-pages () +; (si::nrbpage)) + +;; FIXME This has to come straight from enum.h. CM 20050114 +(defvar *type-list* + '(cons + fixnum bignum ratio short-float long-float complex + character symbol package hash-table + array vector string bit-vector + structure stream random-state readtable pathname + cfun cclosure sfun gfun vfun afun closure cfdata spice)) + +(defun heaprep nil + + (let ((f (list + "word size: ~a bits~%" + "page size: ~a bytes~%" + "heap start: 0x~x~%" + "heap max : 0x~x~%" + "shared library start: 0x~x~%" + "cstack start: 0x~x~%" + "cstack mark offset: ~a bytes~%" + "cstack direction: ~[downward~;upward~;~]~%" + "cstack alignment: ~a bytes~%" + "cstack max: ~a bytes~%" + "immfix start: 0x~x~%" + "immfix size: ~a fixnums~%" + "physical memory: ~a pages~%")) + (v (multiple-value-list (si::heap-report)))) + + (do ((v v (cdr v)) (f f (cdr f))) ((not (car v))) + (format t (car f) + (let ((x (car v))) + (cond ((>= x 0) x) + ((+ x (* 2 (1+ most-positive-fixnum)))))))))) + +(defun room (&optional x) + (let ((l (multiple-value-list (si:room-report))) + maxpage leftpage ncbpage maxcbpage ncb cbgbccount npage maxnpage + rbused rbfree nrbpage maxrbpage + info-list link-alist) + (setq maxpage (nth 0 l) leftpage (nth 1 l) + ncbpage (nth 2 l) maxcbpage (nth 3 l) ncb (nth 4 l) + cbgbccount (nth 5 l) + holepage (nth 6 l) + rbused (nth 7 l) rbfree (nth 8 l) nrbpage (nth 9 l) + maxrbpage (nth 10 l) + rbgbccount (nth 11 l) + l (nthcdr 12 l)) + (do ((l l (nthcdr 5 l)) + (tl *type-list* (cdr tl)) + (j 0 (+ j (if (nth 3 l) (nth 3 l) 0))) + (i 0 (+ i (if (nth 2 l) (nth 2 l) 0)))) + ((null l) (setq npage i maxnpage j)) + (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)))))) + (terpri) + (dolist (info (reverse info-list)) + (apply #'format t "~8D/~D~19T~6,1F%~@[~8D~]~35T~{~A~^ ~}" + (append (cdr info) + (if (assoc (car info) link-alist) + (list (assoc (car info) link-alist)) + (list (list (car info)))))) + (terpri) + ) + (terpri) + (format t "~8D/~D~26T~@[~8D~]~35Tcontiguous (~D blocks)~%" + ncbpage maxcbpage (if (zerop cbgbccount) nil cbgbccount) ncb) + (format t "~9T~D~35Thole~%" holepage) + (format t "~8D/~D~19T~6,1F%~@[~8D~]~35Trelocatable~%~%" + nrbpage maxrbpage (/ rbused 0.01 (+ rbused rbfree)) + (if (zerop rbgbccount) nil rbgbccount)) + (format t "~10D pages for cells~%~%" npage) + (format t "~10D total pages in core~%" (+ npage ncbpage nrbpage)) + (format t "~10D current core maximum pages~%" (+ maxnpage maxcbpage maxrbpage)) + (format t "~10D pages reserved for gc~%" maxrbpage) + (format t "~10D pages available for adding to core~%" leftpage) + (format t "~10D pages reserved for core exhaustion~%~%" (- maxpage (+ maxnpage maxcbpage (ash maxrbpage 1) leftpage))) + (format t "~10D maximum pages~%" maxpage) + (values) + ) + + (when x + (format t "~%~%") + (format t "Key:~%~%WS: words per struct~%UP: allocated pages~%MP: maximum pages~%FI: fraction of cells in use on allocated pages~%GC: number of gc triggers allocating this type~%~%") + (heaprep)) + + (values)) + + +;;; C Interface. + +(defmacro Clines (&rest r) nil) +(defmacro defCfun (&rest r) nil) +(defmacro defentry (&rest r) nil) + +(defmacro defla (&rest r) (cons 'defun r)) + +;;; Help. + +(export '(help help*)) + +(defun help (&optional (symbol nil s)) + (if s (si::print-doc symbol) + (progn + (princ " +Welcome to GNU Common Lisp (GCL for short). +Here are some 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* 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. + + (SI::INFO ) chooses from a list of all references in the + on-line documentation to . + + (APROPOS ) or (APROPOS ') list + all symbols containing . + + (DESCRIBE ') or (HELP ') describe particular symbols. + + (BYE) or (BY) ends the current GCL session. + +Good luck! The GCL Development Team") + (values)))) + +(defun help* (string &optional (package (find-package "LISP"))) + (si::apropos-doc string package)) + +;;; 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 KCL pretty-printer. + +(setf (get 'lambda 'si:pretty-print-format) 1) +(setf (get 'lambda-block 'si:pretty-print-format) 2) +(setf (get 'lambda-closure 'si:pretty-print-format) 4) +(setf (get 'lambda-block-closure 'si:pretty-print-format) 5) + +(setf (get 'block 'si:pretty-print-format) 1) +(setf (get 'case 'si:pretty-print-format) 1) +(setf (get 'catch 'si:pretty-print-format) 1) +(setf (get 'ccase 'si:pretty-print-format) 1) +(setf (get 'clines 'si:pretty-print-format) 0) +(setf (get 'compiler-let 'si:pretty-print-format) 1) +(setf (get 'cond 'si:pretty-print-format) 0) +(setf (get 'ctypecase 'si:pretty-print-format) 1) +(setf (get 'defcfun 'si:pretty-print-format) 2) +(setf (get 'define-setf-method 'si:pretty-print-format) 2) +(setf (get 'defla 'si:pretty-print-format) 2) +(setf (get 'defmacro 'si:pretty-print-format) 2) +(setf (get 'defsetf 'si:pretty-print-format) 3) +(setf (get 'defstruct 'si:pretty-print-format) 1) +(setf (get 'deftype 'si:pretty-print-format) 2) +(setf (get 'defun 'si:pretty-print-format) 2) +(setf (get 'do 'si:pretty-print-format) 2) +(setf (get 'do* 'si:pretty-print-format) 2) +(setf (get 'do-symbols 'si:pretty-print-format) 1) +(setf (get 'do-all-symbols 'si:pretty-print-format) 1) +(setf (get 'do-external-symbols 'si:pretty-print-format) 1) +(setf (get 'dolist 'si:pretty-print-format) 1) +(setf (get 'dotimes 'si:pretty-print-format) 1) +(setf (get 'ecase 'si:pretty-print-format) 1) +(setf (get 'etypecase 'si:pretty-print-format) 1) +(setf (get 'eval-when 'si:pretty-print-format) 1) +(setf (get 'flet 'si:pretty-print-format) 1) +(setf (get 'labels 'si:pretty-print-format) 1) +(setf (get 'let 'si:pretty-print-format) 1) +(setf (get 'let* 'si:pretty-print-format) 1) +(setf (get 'locally 'si:pretty-print-format) 0) +(setf (get 'loop 'si:pretty-print-format) 0) +(setf (get 'macrolet 'si:pretty-print-format) 1) +(setf (get 'multiple-value-bind 'si:pretty-print-format) 2) +(setf (get 'multiple-value-prog1 'si:pretty-print-format) 1) +(setf (get 'prog 'si:pretty-print-format) 1) +(setf (get 'prog* 'si:pretty-print-format) 1) +(setf (get 'prog1 'si:pretty-print-format) 1) +(setf (get 'prog2 'si:pretty-print-format) 2) +(setf (get 'progn 'si:pretty-print-format) 0) +(setf (get 'progv 'si:pretty-print-format) 2) +(setf (get 'return 'si:pretty-print-format) 0) +(setf (get 'return-from 'si:pretty-print-format) 1) +(setf (get 'tagbody 'si:pretty-print-format) 0) +(setf (get 'the 'si:pretty-print-format) 1) +(setf (get 'throw 'si:pretty-print-format) 1) +(setf (get 'typecase 'si:pretty-print-format) 1) +(setf (get 'unless 'si:pretty-print-format) 1) +(setf (get 'unwind-protect 'si:pretty-print-format) 0) +(setf (get 'when 'si:pretty-print-format) 1) +(setf (get 'with-input-from-string 'si:pretty-print-format) 1) +(setf (get 'with-open-file 'si:pretty-print-format) 1) +(setf (get 'with-open-stream 'si:pretty-print-format) 1) +(setf (get 'with-output-to-string 'si:pretty-print-format) 1) + + +(in-package 'si) + +(defvar *lib-directory* (namestring (truename "../"))) + +(import '(*lib-directory* *load-path* *system-directory*) 'si::user) diff --git a/lsp/gcl_cmpinit.lsp b/lsp/gcl_cmpinit.lsp new file mode 100755 index 0000000..37a521e --- /dev/null +++ b/lsp/gcl_cmpinit.lsp @@ -0,0 +1,11 @@ +;(proclaim '(optimize (safety 2) (space 3))) + +(setq compiler::*eval-when-defaults* '(compile eval load)) +(or (fboundp 'si::get-&environment) (load "gcl_defmacro.lsp")) +;(or (get 'si::s-data 'si::s-data) +; (progn (load "../lsp/setf.lsp") (load "../lsp/defstruct.lsp"))) +(if (probe-file "sys-proclaim.lisp")(load "sys-proclaim.lisp")) + + + +;;;;; diff --git a/lsp/gcl_debug.lsp b/lsp/gcl_debug.lsp new file mode 100755 index 0000000..5925792 --- /dev/null +++ b/lsp/gcl_debug.lsp @@ -0,0 +1,823 @@ +;;Copyright William F. Schelter 1990, All Rights Reserved + + +(In-package "SYSTEM") +(import 'sloop::sloop) + +(eval-when (compile eval) + (proclaim '(optimize (safety 2) (space 3))) + +(defmacro f (op &rest args) + `(the fixnum (,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) ))) + +(defmacro fb (op &rest args) + `(,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) )) + + ) + +;;; Some debugging features: +;;; Search-stack : +;;; (:s "cal") or (:s 'cal) searches the stack for a frame whose function or +;;; special form has a name containing "cal", moves there to display the local +;;; data. +;;; +;;; Break-locals : +;;; :bl displays the args and locals of the current function. +;;; (:bl 4) does this for 4 functions. +;;; +;;; (si:loc i) accesses the local(i): slot. +;;; the *print-level* and *print-depth* are bound to *debug-print-level* + +;;; Note you must have space < 3 in your optimize proclamation, in order for +;;; the local variable names to be saved by the compiler. + +;;; With BSD You may also use the function write-debug-symbols to +;;; obtain an object file with the correct symbol information for using a +;;; c debugger, on translated lisp code. You should have used the :debug +;;; t keyword when compiling the file. + +;;; To Do: add setf method for si:loc. +;;; add restart capability from various spots on the stack. + +(defun show-break-variables (&optional (n 1)) + (loop + ;(break-current) + (dolist (v (reverse(car *break-env*))) + (format *debug-io* "~%~9a: ~s" (car v) (second v))) + (or (fb > (incf n -1) 0) (return (values))) + (break-previous) + )) + +(defun show-environment (ihs) + (let ((lis (vs (ihs-vs ihs)))) + (if (listp lis) + (dolist (v (reverse (vs (ihs-vs ihs)))) + (format *debug-io* "~%~9a: ~s" (car v) (second v)))))) + +(putprop :a 'show-break-variables 'break-command) + +;;make hack in compiler to remember the local variable names for the +;;vs variables and associate it with the function name + +(defun search-stack (sym &aux string) + (setq string (cond((symbolp sym)(symbol-name sym)) + (t sym))) + (sloop + for ihs downfrom (ihs-top) above 2 + for fun = (ihs-fun ihs) with name + do + (cond ((compiled-function-p fun) + (setq name (compiled-function-name fun))) + ((symbolp fun ) (setq name fun)) + ((and (listp fun) + (member (car fun) '(lambda lambda-block))) + (setq name (second fun))) + (t (setq name '||))) + when (search string (symbol-name name) :test 'equal) + do (return (progn (break-go ihs)(terpri) (break-locals))) + finally (format *debug-io* "~%Search for ~a failed" string) + )) + +(defvar *debug-print-level* 3) + +(defun break-locals (&optional (n 1) + &aux (ihs *current-ihs*) + (base (ihs-vs ihs)) + (*print-level* *debug-print-level*) + *print-circle* + (*print-length* *debug-print-level*) + (current-ihs *current-ihs*) + (fun (ihs-fun ihs)) name args) + (cond ((fb > n 1) + (sloop for i below n + for ihs downfrom current-ihs above 2 + do (let ((*current-ihs* ihs)) + (break-locals) (terpri)(terpri) + ))) + (t + (cond ((compiled-function-p fun) + (setq name (compiled-function-name fun))) + (t (setq name fun))) + (if (symbolp name)(setq args (get name 'debug))) + (let ((next (ihs-vs (f + 1 *current-ihs*)))) + (cond (next + (format *debug-io* ">> ~a():" name) + (cond ((symbolp name) + (sloop for i from base below next for j from 0 + for u = nil + do + (cond ((member 0 args);;old debug info. + (setf u (getf args j))) + (t (setf u (nth j args)))) + (cond (u + (format t + "~%Local~a(~a): ~a" j u (vs i))) + (t + (format *debug-io* "~%Local(~d): ~a" + j (vs i)))))) + ((listp name) + (show-environment ihs)) + (t (format *debug-io* "~%Which case is this??"))))))))) + +(defun loc (&optional (n 0)) + (let ((base (ihs-vs *current-ihs*))) + (unless (and (fb >= n 0) + (fb < n (f - (ihs-vs + (min (ihs-top) (f + 1 *current-ihs*))) + base))) + (error "Not in current function")) + (vs (f + n base)))) + +(putprop :bl 'break-locals 'break-command) +(putprop :s 'search-stack 'break-command) + +(defvar *record-line-info* (make-hash-table :test 'eq)) + +(defvar *at-newline* nil) + +(defvar *standard-readtable* *readtable*) + +(defvar *line-info-readtable* (copy-readtable)) + +(defvar *left-parenthesis-reader* (get-macro-character #\( )) + +(defvar *quotation-reader* (get-macro-character #\" )) + +(defvar *stream-alist* nil) + +(defvar *break-point-vector* (make-array 10 :fill-pointer 0 :adjustable t)) + +(defvar *step-next* nil) + +(defvar *last-dbl-break* nil) + +#-gcl +(eval-when (compile eval load) + +(defvar *places* '(|*mv0*| |*mv1*| |*mv2*| |*mv3*| |*mv4*| |*mv5*| |*mv6*| |*mv7*| + |*mv8*| |*mv9*|)) + +(defmacro set-mv (i val) `(setf ,(nth i *places*) ,val)) + +(defmacro mv-ref (i) (nth i *places*)) + ) + +(defmacro mv-setq (lis form) + `(prog1 (setf ,(car lis) ,form) + ,@ (do ((v (cdr lis) (cdr v)) + (i 0 (1+ i)) + (res)) + ((null v)(reverse res)) + (push `(setf ,(car v) (mv-ref ,i)) res)))) + +(defmacro mv-values (&rest lis) + `(prog1 ,(car lis) + ,@ (do ((v (cdr lis) (cdr v)) + (i 0 (1+ i)) + (res)) + ((null v)(reverse res)) + (push `(set-mv ,i ,(car v)) res)))) + +;;start a lisp debugger loop. Exit it by using :step + +(defun dbl () + (break-level nil nil)) + +(defstruct instream stream (line 0 :type fixnum) stream-name) + + +(eval-when (eval compile) + +(defstruct (bkpt (:type list)) form file file-line function) + ) + +(defun cleanup () + (dolist (v *stream-alist*) + (if (closedp (instream-stream v)) + (setq *stream-alist* (delete v *stream-alist*))))) + +(defun get-instream (str) + (or (dolist (v *stream-alist*) + (cond ((eq str (instream-stream v)) + (return v)))) + (car (setq *stream-alist* + (cons (make-instream :stream str + :stream-name (if (streamp str) + (stream-name str)) + ) *stream-alist*))))) + +(defun newline (str ch) ch + (let ((in (get-instream str))) + (setf (instream-line in) (the fixnum (f + 1 (instream-line in))))) + ;; if the next line begins with '(', then record all cons's eg arglist ) + (setq *at-newline* (if (eql (peek-char nil str nil) #\() :all t)) + (values)) + +(defun quotation-reader (str ch) + (let ((tem (funcall *quotation-reader* str ch)) + (instr (get-instream str))) + (incf (instream-line instr) (count #\newline tem)) + tem)) + +(defvar *old-semicolon-reader* (get-macro-character #\;)) + +(defun new-semi-colon-reader (str ch) + (let ((in (get-instream str)) + (next (peek-char nil str nil nil))) + (setf (instream-line in) (the fixnum (f + 1 (instream-line in)))) + (cond ((eql next #\!) + (read-char str) + (let* ((*readtable* *standard-readtable*) + (command (read-from-string (read-line str nil nil)))) + (cond ((and (consp command) + (eq (car command) :line) + (stringp (second command)) + (typep (third command) 'fixnum)) + (setf (instream-stream-name in) (second command)) + (setf (instream-line in) (third command)))) + )) + (t (funcall *old-semicolon-reader* str ch))) + (setq *at-newline* (if (eql (peek-char nil str nil) #\() :all t)) + (values))) + +(defun setup-lineinfo () + (set-macro-character #\newline #'newline nil *line-info-readtable*) + (set-macro-character #\; #'new-semi-colon-reader nil *line-info-readtable*) + (set-macro-character #\( 'left-parenthesis-reader nil *line-info-readtable*) + (set-macro-character #\" 'quotation-reader nil *line-info-readtable*) + + ) + +(defun nload (file &rest args ) + (clrhash *record-line-info*) + (cleanup) + (setq file (truename file)) + (setup-lineinfo) + (let ((*readtable* *line-info-readtable*)) + (apply 'load file args))) + +(eval-when (compile eval) + +(defmacro break-data (name line) `(cons ,name ,line)) + ) + +(defun left-parenthesis-reader (str ch &aux line(flag *at-newline*)) + (if (eq *at-newline* t) (setq *at-newline* nil)) + (when flag + (setq flag (get-instream str)) + (setq line (instream-line flag)) + ) + (let ((tem (funcall *left-parenthesis-reader* str ch))) + (when flag + (setf (gethash tem *record-line-info*) + (break-data (instream-name flag) + line))) + tem)) + +(defvar *fun-array* (make-array 50 :fill-pointer 0 :adjustable t)) + +(defun walk-through (body &aux tem) + (tagbody + top + (cond ((consp body) + (when (setq tem (gethash body *record-line-info*)) + ;; lines beginning with ((< u v)..) + ;; aren't eval'd but are part of a special form + (cond ((and (consp (car body)) + (not (eq (caar body) 'lambda))) + (remhash body *record-line-info*) + (setf (gethash (car body) *record-line-info*) + tem)) + (t (vector-push-extend (cons tem body) *fun-array*)))) + (walk-through (car body)) + (setq body (cdr body)) + (go top)) + (t nil)))) + +(defun compiler::compiler-def-hook (name body &aux (ar *fun-array*) + (min most-positive-fixnum) + (max -1)) + (declare (fixnum min max)) + ;; (cond ((and (boundp '*do-it*) + ;; (eq (car body) 'lambda-block)) + ;; (setf (cdr body) (cdr (walk-top body))))) + + (cond ((atom body) + (remprop name 'line-info)) + ((eq *readtable* *line-info-readtable*) + (setf (fill-pointer *fun-array*) 0) + (walk-through body) + (dotimes (i (length ar)) + (declare (fixnum i)) + (let ((n (cdar (aref ar i)))) + (declare (fixnum n)) + (if (fb > n max) (setf max n)) + (if (fb < n min) (setf min n)))) + (cond ((fb > (length *fun-array*) 0) + (let ((new (make-array (f + (f - max min) 2) + :initial-element :blank-line)) + (old-info (get name 'line-info))) + (setf (aref new 0) + (cons (caar (aref ar 0)) min)) + (setq min (f - min 1)) + (dotimes (i (length ar)) + (let ((y (aref ar i))) + (setf (aref new (f - (cdar y) min)) + (cdr y)))) + (setf (get name 'line-info) new) + (when + old-info + (let ((tem (get name 'break-points)) + (old-begin (cdr (aref old-info 0)))) + (dolist (bptno tem) + (let* ((bpt (aref *break-points* bptno)) + (fun (bkpt-function bpt)) + (li (f - (bkpt-file-line bpt) old-begin))) + (setf (aref *break-points* bptno) + (make-break-point fun new li)))))))) + (t (let ((tem (get name 'break-points))) + (iterate-over-bkpts tem :delete))))))) + +(defun instream-name (instr) + (or (instream-stream-name instr) + (stream-name (instream-stream instr)))) + +(eval-when (eval) + +(defun stream-name (str) (namestring (pathname str)))) +(clines "object stream_name(str) object str;{ + if (str->sm.sm_object1 != 0 && type_of(str->sm.sm_object1)==t_string) + return str->sm.sm_object1; else return Cnil;}") + +(defentry stream-name (object) (object "stream_name")) + +(clines "object closedp(str) object str;{return (str->sm.sm_fp==0 ? Ct :Cnil);}") + +(defentry closedp (object) (object "closedp")) + +(defun find-line-in-fun (form env fun counter &aux tem) + (setq tem (get fun 'line-info)) + (if tem + (let ((ar tem)) + (declare (type (array (t)) ar)) + (when ar + (dotimes + (i (length ar)) + (cond ((eq form (aref ar i)) + (when counter + (decf (car counter)) + (cond ((fb > (car counter) 0) + ;silent + (return-from find-line-in-fun :break)))) + (break-level + (setq *last-dbl-break* (make-break-point fun ar i)) env + ) + (return-from find-line-in-fun :break)))))))) + +;; get the most recent function on the stack with step info. + +(defun current-step-fun ( &optional (ihs (ihs-top)) ) + (do ((i (1- ihs) (f - i 1))) + ((fb <= i 0)) + (let ((na (ihs-fname i))) + (if (get na 'line-info) (return na))))) + +(defun init-break-points () + (setf (fill-pointer *break-point-vector*) 0) + (setf *break-points* *break-point-vector*)) + +(defun step-into (&optional (n 1)) +;(defun step-into () + (declare (ignore n)) + ;;FORM is the next form about to be evaluated. + (or *break-points* (init-break-points)) + (setq *break-step* 'break-step-into) + :resume) + +(defun step-next ( &optional (n 1)) + (let ((fun (current-step-fun))) + (setq *step-next* (cons n fun)) + (or *break-points* (init-break-points)) + (setq *break-step* 'break-step-next) + :resume)) + +(defun maybe-break (form line-info fun env &aux pos) + (cond ((setq pos (position form line-info)) + (setq *break-step* nil) + (or (> (length *break-points*) 0) + (setf *break-points* nil)) + (break-level (make-break-point fun line-info pos) env) + t))) + +;; These following functions, when they are the value of *break-step* +;; are invoked by an inner hook in eval. They may choose to stop +;; things. + +(defun break-step-into (form env) + (let ((fun (current-step-fun))) + (let ((line-info (get fun 'line-info))) + (maybe-break form line-info fun env)))) + +(defun break-step-next (form env) + (let ((fun (current-step-fun))) + (cond ((eql (cdr *step-next*) fun) + (let ((line-info (get fun 'line-info))) + (maybe-break form line-info fun env)))))) + +(setf (get :next 'break-command) 'step-next) +(setf (get :step 'break-command) 'step-into) +(setf (get :loc 'break-command) 'loc) + + +(defun *break-points* (form env) + (let ((pos(position form *break-points* :key 'car))) + (format t "Bkpt ~a:" pos) + (break-level (aref *break-points* pos) env))) + + +(defun dwim (fun) + (dolist (v (list-all-packages)) + (multiple-value-bind + (sym there) + (intern (symbol-name fun) v) + (cond ((get sym 'line-info) + (return-from dwim sym)) + (t (or there (unintern sym)))))) + (format t "~a has no line information" fun)) + +(defun break-function (fun &optional (li 1) absolute &aux fun1) + (let ((ar (get fun 'line-info))) + (when (null ar) (setq fun1 (dwim fun)) + (if fun1 (return-from break-function + (break-function fun1 li absolute)))) + (or (arrayp ar)(progn (format t "~%No line info for ~a" fun) + (return-from break-function nil))) + (let ((beg (cdr (aref ar 0)))) + (if absolute (setq li (f - li beg))) + (or (and (fb >= li 1) (fb < li (length ar))) + (progn (format t "~%line out of bounds for ~a" fun)) + (return-from break-function nil)) + (if (eql li 1) + (let ((tem (symbol-function fun))) + (cond ((and (consp tem) + (eq (car tem) 'lambda-block) + (third tem)) + (setq li 2))))) + (dotimes (i (f - (length ar) li)) + (when (not (eq (aref ar i) :blank-line)) + (show-break-point (insert-break-point + (make-break-point fun ar (f + li i)))) + (return-from break-function (values)))) + (format t "~%Beyond code for ~a ")))) + +(defun insert-break-point (bpt &aux at) + (or *break-points* (init-break-points)) + (setq at (or (position nil *break-points*) + (prog1 (length *break-points*) + (vector-push-extend nil *break-points*) + ))) + (let ((fun (bkpt-function bpt))) + (push at (get fun 'break-points))) + (setf (aref *break-points* at) bpt) + at) + +(defun short-name (name) + (let ((Pos (position #\/ name :from-end t))) + (if pos (subseq name (f + 1 pos)) name))) + +(defun show-break-point (n &aux disabled) + (let ((bpt (aref *break-points* n))) + (when bpt + (when (eq (car bpt) nil) + (setq disabled t) + (setq bpt (cdr bpt))) + (format t "Bkpt ~a:(~a line ~a)~@[(disabled)~]" + n (short-name (second bpt)) + (third bpt) disabled) + (let ((fun (fourth bpt))) + (format t "(line ~a of ~a)" (relative-line fun (nth 2 bpt)) + fun + ))))) + +(defun iterate-over-bkpts (l action) + (dotimes (i (length *break-points*)) + (if (or (member i l) + (null l)) + (let ((tem (aref *break-points* i))) + (setf (aref *break-points* i) + (case action + (:delete + (if tem (setf (get (bkpt-function tem) 'break-points) + (delete i (get (bkpt-function tem) 'break-points)))) + nil) + (:enable + (if (eq (car tem) nil) (cdr tem) nil)) + (:disable + (if (and tem (not (eq (car tem) nil))) + (cons nil tem) + tem)) + (:show + (when tem (show-break-point i) + (terpri)) + tem + ))))))) + +(setf (get :info 'break-command) + '(lambda (type) + (case type + (:bkpt (iterate-over-bkpts nil :show)) + (otherwise + (format t "usage: :info :bkpt -- show breakpoints") + )))) + +(defun complete-prop (sym package prop &optional return-list) + (cond ((and (symbolp sym)(get sym prop)(equal (symbol-package sym) + (find-package package))) + (return-from complete-prop sym))) + (sloop for v in-package package + when (and (get v prop) + (eql (string-match sym v) 0)) + collect v into all + finally + + (cond (return-list (return-from complete-prop all)) + ((> (length all) 1) + (format t "~&Not unique with property ~(~a: ~{~s~^, ~}~)." + prop all)) + + ((null all) + (format t "~& ~a is not break command" sym)) + (t (return-from complete-prop + (car all)))))) + +(setf (get :delete 'break-command) + '(lambda (&rest l) (iterate-over-bkpts l :delete)(values))) +(setf (get :disable 'break-command) + '(lambda (&rest l) (iterate-over-bkpts l :disable)(values))) +(setf (get :enable 'break-command) + '(lambda (&rest l) (iterate-over-bkpts l :enable)(values))) +(setf (get :break 'break-command) + '(lambda (&rest l) + (print l) + (cond (l + (apply 'si::break-function l)) + (*last-dbl-break* + (let ((fun (nth 3 *last-dbl-break*))) + (si::break-function fun (nth 2 *last-dbl-break*) t)))))) + +(setf (get :fr 'break-command) + '(lambda (&rest l ) + (dbl-up (or (car l) 0) *ihs-top*) + (values))) + +(setf (get :up 'break-command) + '(lambda (&rest l ) + (dbl-up (or (car l) 1) *current-ihs*) + (values))) + +(setf (get :down 'break-command) + '(lambda (&rest l ) + (dbl-up ( - (or (car l) 1)) *current-ihs*) + (values))) + +;; in other common lisps this should be a string output stream. + +(defvar *display-string* + (make-array 100 :element-type 'string-char :fill-pointer 0 :adjustable t)) + +(defun display-env (n env) + (do ((v (reverse env) (cdr v))) + ((or (not (consp v)) (fb > (fill-pointer *display-string*) n))) + (or (and (consp (car v)) + (listp (cdar v))) + (return)) + (format *display-string* "~s=~s~@[,~]" (caar v) (cadar v) (cdr v)))) + +(defun apply-display-fun (display-fun n lis) + (let ((*print-length* *debug-print-level*) + (*print-level* *debug-print-level*) + (*print-pretty* nil) + (*PRINT-CASE* :downcase) + (*print-circle* t) + ) + (setf (fill-pointer *display-string*) 0) + (format *display-string* "{") + (funcall display-fun n lis) + (when (fb > (fill-pointer *display-string*) n) + (setf (fill-pointer *display-string*) n) + (format *display-string* "...")) + + (format *display-string* "}") + ) + *display-string* + ) + +(setf (get :bt 'break-command) 'dbl-backtrace) +(setf (get '*break-points* 'dbl-invisible) t) + +(defun get-line-of-form (form line-info) + (let ((pos (position form line-info))) + (if pos (f + pos (cdr (aref line-info 0)))))) + +(defun get-next-visible-fun (ihs) + (do ((j ihs (f - j 1))) + ((fb < j *ihs-base*) + (mv-values nil j)) + (let + ((na (ihs-fname j))) + (cond ((special-form-p na)) + ((get na 'dbl-invisible)) + ((fboundp na)(return (mv-values na j))))))) + +(defun dbl-what-frame (ihs &aux (j *ihs-top*) (i 0) na) + (declare (fixnum ihs j i)) + (loop + (mv-setq (na j) (get-next-visible-fun j)) + (cond ((fb <= j ihs) (return i))) + (setq i (f + i 1)) + (setq j (f - j 1)))) + +(defun dbl-up (n ihs &aux m fun line file env ) + (setq m (dbl-what-frame ihs)) + (cond ((fb >= n 0) + (mv-setq (*current-ihs* n fun line file env) + (nth-stack-frame n ihs)) + (set-env) + (print-stack-frame (f + m n) t *current-ihs* fun line file env)) + (t (setq n (f + m n)) + (or (fb >= n 0) (setq n 0)) + (dbl-up n *ihs-top*)))) + +(dolist (v '( break-level universal-error-handler terminal-interrupt + break-level evalhook find-line-in-fun)) + (setf (get v 'dbl-invisible) t)) + +(defun next-stack-frame (ihs &aux line-info li i k na) + (cond + ((fb < ihs *ihs-base*) (mv-values nil nil nil nil nil )) + (t (let (fun) + ;; next lower visible ihs + (mv-setq (fun i) (get-next-visible-fun ihs)) + (setq na fun) + (cond + ((and + (setq line-info (get fun 'line-info)) + (do ((j (f + ihs 1) (f - j 1)) + (form )) + ((<= j i) nil) + (setq form (ihs-fun j)) + (cond ((setq li (get-line-of-form (ihs-fun j) line-info)) + (return-from next-stack-frame + (mv-values + i fun li + ;; filename + (car (aref line-info 0)) + ;;environment + (list (vs (setq k (ihs-vs j))) + (vs (1+ k)) + (vs (+ k 2))) + ))))))) + ((special-form-p na) nil) + ((get na 'dbl-invisible)) + ((fboundp na) + (mv-values i na nil nil + (if (ihs-not-interpreted-env i) + nil + (let ((i (ihs-vs i))) + (list (vs i) (vs (1+ i)) (vs (f + i 2)))))))) + )))) + +(defun nth-stack-frame (n &optional (ihs *ihs-top*) + &aux name line file env next) + (or (fb >= n 0) (setq n 0)) + (dotimes (i (f + n 1)) + (setq next (next-stack-frame ihs)) + (cond (next + (mv-setq (ihs name line file env) next) + (setq ihs (f - next 1))) + (t (return (setq n (f - i 1)))))) + + (setq ihs (f + ihs 1) name (ihs-fname ihs)) + (mv-values ihs n name line file env )) + +(defun dbl-backtrace (&optional (m 1000) (ihs *ihs-top*) &aux fun file + line env (i 0)) + (loop + (mv-setq (ihs fun line file env) (next-stack-frame ihs)) + (or (and ihs fun) (return nil)) + (print-stack-frame i nil ihs fun line file env) + (incf i) + (cond ((fb >= i m) (return (values)))) + (setq ihs (f - ihs 1)) + ) + (values)) + +(defun display-compiled-env ( plength ihs &aux + (base (ihs-vs ihs)) + (end (min (ihs-vs (1+ ihs)) (vs-top)))) + (format *display-string* "") + (do ((i base ) + (v (get (ihs-fname ihs) 'debug) (cdr v))) + ((or (fb >= i end)(fb > (fill-pointer *display-string*) plength))) + (format *display-string* "~a~@[~d~]=~s~@[,~]" + (or (car v) 'loc) (if (not (car v)) (f - i base)) (vs i) + (fb < (setq i (f + i 1)) end))) + ) + +(defun computing-args-p (ihs) + ;; When running interpreted we want a line like + ;; (list joe jane) to get recorded in the invocation + ;; history while joe and jane are being evaluated, + ;; even though list has not yet been invoked. We put + ;; it in the history, but with the previous lexical environment. + (and (consp (ihs-fun ihs)) + (> ihs 3) + (not (member (car (ihs-fun ihs)) '(lambda-block lambda))) + ;(<= (ihs-vs ihs) (ihs-vs (- ihs 1))) + ) + ) + + +(defun print-stack-frame (i auto-display ihs fun &optional line file env) + (declare (ignore env)) + (when (and auto-display line) + (format *debug-io* "~a:~a:0:beg~%" file line)) + (let ((computing-args (computing-args-p ihs))) + (format *debug-io* "~&#~d ~@[~a~] ~a ~@[~a~] " i + (and computing-args "Computing args for ") + fun + (if (not (ihs-not-interpreted-env ihs)) + (apply-display-fun 'display-env 80 + (car (vs (ihs-vs ihs)))) + (apply-display-fun 'display-compiled-env 80 ihs))) + (if file (format *debug-io* "(~a line ~a)" file line)) + (format *debug-io* "[ihs=~a]" ihs) + )) + +(defun make-break-point (fun ar i) + (list ;make-bkpt ;:form + (aref ar i) + ;:file + (car (aref ar 0)) + ;:file-line + (f + (cdr (aref ar 0)) i) + ;:function + fun) + ) + +(defun relative-line (fun l) + (let ((info (get fun 'line-info))) + (if info (f - l (cdr (aref info 0))) + 0))) + +(defvar *step-display* nil) + +(defvar *null-io* (make-broadcast-stream)) +;; should really use serror to evaluate this inside. +;; rather than just quietening it. It prints a long stack +;; which is time consuming. + +(defun safe-eval (form env &aux *break-enable*) + (let ((*error-output* *null-io*) + (*debug-io* *null-io*)) + (cond ((symbolp form) + (unless (or (boundp form) + (assoc form (car env))) + (return-from safe-eval :)))) + (multiple-value-bind (er val) + (si::error-set + `(evalhook ',form nil nil ',env)) + (if er : val)))) + +(defvar *no-prompt* nil) + +(defun set-back (at env &aux (i *current-ihs*)) + (setq *no-prompt* nil) + (setq *current-ihs* i) + (cond (env (setq *break-env* env)) + (t (list (vs (ihs-vs i))))) + + (when (consp at) + (format *debug-io* "~a:~a:0:beg~%" (second at) (third at)) + (format *debug-io* "(~a line ~a) " + (second at) (third at)) + ) + (dolist (v *step-display*) + (let ((res (safe-eval v env))) + (or (eq res :) + (format t "(~s=~s)" v res))))) + + +(eval-when (load eval) + (pushnew :sdebug *features* ) + ;(use-fast-links nil) + ) + + + + + + + + + diff --git a/lsp/gcl_defmacro.lsp b/lsp/gcl_defmacro.lsp new file mode 100755 index 0000000..3e4494c --- /dev/null +++ b/lsp/gcl_defmacro.lsp @@ -0,0 +1,271 @@ +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +;;;; defmacro.lsp +;;;; +;;;; defines SI:DEFMACRO*, the defmacro preprocessor + + +(in-package 'lisp) +(export '(&whole &environment &body)) + + +(in-package 'system) + + +(eval-when (compile) (proclaim '(optimize (safety 2) (space 3)))) + + +;;; 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 } +;;; ) +;;; +;;; where v is short for { defmacro-lambda-list | sym }. +;;; A symbol may be accepted as a DEFMACRO lambda-list, in which case +;;; (DEFMACRO ... ) is equivalent to +;;; (DEFMACRO (&REST ) ...). +;;; Defamcro-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 } +;;; ) + +;; defvar is not yet available. +(mapc '*make-special '(*dl* *key-check* *arg-check*)) + + +(defun get-&environment(vl &aux env) + (let ((env-m + (and (listp vl) + (do ((tail vl (cdr tail))) + ((not (consp tail)) nil) + (when (eq '&environment (car tail)) + (return tail)))))) + (cond (env-m + (setq env (cadr env-m)) + (setq vl (append (ldiff vl env-m) (cddr env-m))))) + (values vl env))) + + + +(defun si:defmacro* (name vl body + &aux *dl* (*key-check* nil) + (*arg-check* nil) + doc decls whole ppn (env nil) envp) + (cond ((listp vl)) + ((symbolp vl) (setq vl (list '&rest vl))) + (t (error "The defmacro-lambda-list ~s is not a list." vl))) + (multiple-value-setq (doc decls body) (find-doc body nil)) + (cond ((and (listp vl) (eq (car vl) '&whole)) + (setq whole (cadr vl)) (setq vl (cddr vl))) + (t (setq whole (gensym)))) + (multiple-value-setq (vl env) + (get-&environment vl)) + (setq envp env) + (or env (setq env (gensym))) + (setq *dl* `(&aux ,env ,whole)) + (setq ppn (dm-vl vl whole t)) + (dolist (kc *key-check*) + (push `(unless (getf ,(car kc) :allow-other-keys) + (do ((vl ,(car kc) (cddr vl))) + ((endp vl)) + (unless (member (car vl) ',(cdr kc)) + (dm-key-not-allowed (car vl)) + ))) + body)) + (dolist (ac *arg-check*) + (push `(unless (endp ,(dm-nth-cdr (cdr ac) (car ac))) + (dm-too-many-arguments)) body)) + (unless envp (push `(declare (ignore ,env)) body)) + (list doc ppn `(lambda-block ,name ,(reverse *dl*) ,@(append decls body))) + ) + +(defun dm-vl (vl whole top) + (do ((optionalp nil) (restp nil) (keyp nil) + (allow-other-keys-p nil) (auxp nil) + (rest nil) (allow-other-keys nil) (keys nil) (no-check nil) + (n (if top 1 0)) (ppn nil) + ) + ((not (consp vl)) + (when vl + (when restp (dm-bad-key '&rest)) + (push (list vl (dm-nth-cdr n whole)) *dl*) + (setq no-check t)) + (when (and rest (not allow-other-keys)) + (push (cons rest keys) *key-check*)) + (unless no-check (push (cons whole n) *arg-check*)) + ppn + ) + (let ((v (car vl))) + (cond + ((eq v '&optional) + (when optionalp (dm-bad-key '&optional)) + (setq optionalp t) + (pop vl)) + ((or (eq v '&rest) (eq v '&body)) + (when restp (dm-bad-key v)) + (dm-v (cadr vl) (dm-nth-cdr n whole)) + (setq restp t optionalp t no-check t) + (setq vl (cddr vl)) + (when (eq v '&body) (setq ppn (if top (1- n) n)))) + ((eq v '&key) + (when keyp (dm-bad-key '&key)) + (setq rest (gensym)) + (push (list rest (dm-nth-cdr n whole)) *dl*) + (setq keyp t restp t optionalp t no-check t) + (pop vl)) + ((eq v '&allow-other-keys) + (when (or (not keyp) allow-other-keys-p) + (dm-bad-key '&allow-other-keys)) + (setq allow-other-keys-p t) + (setq allow-other-keys t) + (pop vl)) + ((eq v '&aux) + (when auxp (dm-bad-key '&aux)) + (setq auxp t allow-other-keys-p t keyp t restp t optionalp t) + (pop vl)) + (auxp + (let (x (init nil)) + (cond ((symbolp v) (setq x v)) + (t (setq x (car v)) + (unless (endp (cdr v)) (setq init (cadr v))))) + (dm-v x init)) + (pop vl)) + (keyp + (let ((temp (gensym)) x k (init nil) (sv nil)) + (cond ((symbolp v) (setq x v k (intern (string v) 'keyword))) + (t (if (symbolp (car v)) + (setq x (car v) + k (intern (string (car v)) 'keyword)) + (setq x (cadar v) k (caar v))) + (unless (endp (cdr v)) + (setq init (cadr v)) + (unless (endp (cddr v)) + (setq sv (caddr v)))))) + (dm-v temp `(getf ,rest ,k 'failed)) + (dm-v x `(if (eq ,temp 'failed) ,init ,temp)) + (when sv (dm-v sv `(not (eq ,temp 'failed)))) + (push k keys)) + (pop vl)) + (optionalp + (let (x (init nil) (sv nil)) + (cond ((symbolp v) (setq x v)) + (t (setq x (car v)) + (unless (endp (cdr v)) + (setq init (cadr v)) + (unless (endp (cddr v)) + (setq sv (caddr v)))))) + (dm-v x `(if ,(dm-nth-cdr n whole) ,(dm-nth n whole) ,init)) + (when sv (dm-v sv `(not (null ,(dm-nth-cdr n whole)))))) + (incf n) + (pop vl) + ) + (t (dm-v v `(if ,(dm-nth-cdr n whole) + ,(dm-nth n whole) + (dm-too-few-arguments))) + (incf n) + (pop vl)) + )))) + +(defun dm-v (v init) + (if (symbolp v) + (push (if init (list v init) v) *dl*) + (let ((temp (gensym))) + (push (if init (list temp init) temp) *dl*) + (dm-vl v temp nil)))) + +(defun dm-nth (n v) + (multiple-value-bind (q r) (floor n 4) + (dotimes (i q) (setq v (list 'cddddr v))) + (case r + (0 (list 'car v)) + (1 (list 'cadr v)) + (2 (list 'caddr v)) + (3 (list 'cadddr v)) + ))) + +(defun dm-nth-cdr (n v) + (multiple-value-bind (q r) (floor n 4) + (dotimes (i q) (setq v (list 'cddddr v))) + (case r + (0 v) + (1 (list 'cdr v)) + (2 (list 'cddr v)) + (3 (list 'cdddr v)) + ))) + +(defun dm-bad-key (key) + (error "Defmacro-lambda-list contains illegal use of ~s." key)) + +(defun dm-too-few-arguments () + (error "Too few arguments are supplied to defmacro-lambda-list.")) + +(defun dm-too-many-arguments () + (error "Too many arguments are supplied to defmacro-lambda-list.")) + +(defun dm-key-not-allowed (key) + (error "The key ~s is not allowed." key)) + +(defun find-doc (body ignore-doc) + (if (endp body) + (values nil nil nil) + (let ((d (macroexpand (car body)))) + (cond ((stringp d) + (if (or (endp (cdr body)) ignore-doc) + (values nil nil (cons d (cdr body))) + (multiple-value-bind (doc decls b) (find-doc (cdr body) t) + (declare (ignore doc)) + (values d decls b)))) + ((and (consp d) (eq (car d) 'declare)) + (multiple-value-bind (doc decls b) + (find-doc (cdr body) ignore-doc) + (values doc (cons d decls) b))) + (t (values nil nil (cons d (cdr body)))))))) + +(defun find-declarations (body) + (if (endp body) + (values nil nil) + (let ((d (macroexpand (car body)))) + (cond ((stringp d) + (if (endp (cdr body)) + (values nil (list d)) + (multiple-value-bind (ds b) + (find-declarations (cdr body)) + (values (cons d ds) b)))) + ((and (consp d) (eq (car d) 'declare)) + (multiple-value-bind (ds b) + (find-declarations (cdr body)) + (values (cons d ds) b))) + (t + (values nil (cons d (cdr body)))))))) + diff --git a/lsp/gcl_defpackage.lsp b/lsp/gcl_defpackage.lsp new file mode 100644 index 0000000..fb8e8a2 --- /dev/null +++ b/lsp/gcl_defpackage.lsp @@ -0,0 +1,339 @@ +;;; -*- 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 +;;; +;;; +;;; Copyright (c) 1990, 1991 The Boeing Company, All Rights Reserved. +;;; +;;; Permission is granted to any individual or institution to use, +;;; copy, modify, and distribute this software, provided that this +;;; complete copyright and permission notice is maintained, intact, in +;;; all copies and supporting documentation and that modifications are +;;; appropriately documented with date, author and description of the +;;; change. +;;; +;;; Stephen L. Nicoud (snicoud@boeing.com) provides this software "as +;;; is" without express or implied warranty by him or The Boeing +;;; Company. +;;; +;;; This software is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY. No author or distributor accepts +;;; 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 +;;; +;;; ----------------------------------------------------------------- +;;; +;;; Read-Time Conditionals used in this file. +;;; +;;; #+LISPM +;;; #+EXCL +;;; #+SYMBOLICS +;;; #+TI +;;; +;;; ----------------------------------------------------------------- + +;;; ----------------------------------------------------------------- +;;; +;;; 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: +;;; +;;; 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). +;;; +;;; 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). +;;; +;;; ----------------------------------------------------------------- + + +(lisp:in-package :DEFPACKAGE) + +(export '(defpackage)) +;(provide :defpackage) + +(use-package :SLOOP) +;(use-package :DEFPACKAGE) + +(proclaim '(declaration values arglist)) + + +;#-gcl +;(eval-when (compile load eval) +; #-lispm +; (unless (member :loop *features*) +; (require :loop #+excl (merge-pathnames "loop" excl::*library-code-fasl-pathname*))) +; +; (unless (find-package :common-lisp) +; (rename-package :lisp :common-lisp (union '("CL" "LISP") (package-nicknames (find-package :lisp)) :test #'string=))) +; (unless (find-package :common-lisp-user) +; (rename-package :user :common-lisp-user (union '("CL-USER" "USER") (package-nicknames (find-package :user)) :test #'string=))) +; +; #+lispm +; (shadow (intern "DEFPACKAGE" #+symbolics :scl #+ti :ticl) 'defpackage) +; (proclaim '(declaration values arglist)) +; (export 'defpackage 'defpackage) +; ) + +(defmacro DEFPACKAGE (name &rest options) + (declare (type (or symbol string) name) + (arglist defined-package-name &rest options) + (values package)) + "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 + symbol; if it is a symbol, only its print name matters, and not what + package, if any, the symbol happens to be in. The newly created or + modified package is returned as the value of the DEFPACKAGE form. + + Each standard OPTION is a list of keyword (the name of the option) + and associated arguments. No part of a DEFPACKAGE form is evaluated. + Except for the :SIZE and :DOCUMENTATION options, more than one option + 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}*) + + [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. + + :DOCUMENTATION is an extension to DEFPACKAGE. + + :SIZE is used only in Genera and Allegro.]" + + (sloop for option in options + unless (member + (first option) + '(:documentation :size :nicknames :shadow + :shadowing-import-from :use :import-from + :intern :export :export-from)) + do (cerror "Proceed, ignoring this option." "~s is not a valid option." option)) + (labels ((option-test (arg1 arg2) (when (consp arg2) (equal (car arg2) arg1))) + (option-values-list (option options) + (sloop for result = (member option options + ':test #'option-test) + then (member option (rest result) + ':test #'option-test) + until (null result) when result collect + (rest (first result)))) + (option-values (option options) + (sloop for result = (member option options ':test #'option-test) + then (member option (rest result) ':test #'option-test) + until (null result) when result append + (rest (first result))))) + (sloop for option in '(:size :documentation) + when (<= 2 (count option options ':key #'car)) + do (error 'program-error :format-control "DEFPACKAGE option ~s specified more than once." + :format-arguments (list option))) + (setq name (string name)) + (let ((nicknames (mapcar #'string (option-values ':nicknames options))) + (documentation (first (option-values ':documentation options))) + (size (first (option-values ':size options))) + (shadowed-symbol-names (mapcar #'string (option-values ':shadow options))) + (interned-symbol-names (mapcar #'string (option-values ':intern options))) + (exported-symbol-names (mapcar #'string (option-values ':export options))) + (shadowing-imported-from-symbol-names-list + (sloop for list in (option-values-list ':shadowing-import-from options) + collect (cons (string (first list)) (mapcar #'string (rest list))))) + (imported-from-symbol-names-list + (sloop for list in (option-values-list ':import-from options) + collect (cons (string (first list)) (mapcar #'string (rest list))))) + (exported-from-package-names + (mapcar #'string (option-values ':export-from options)))) + (flet ((find-duplicates + (&rest lists) + (let (results) + (sloop for list in lists + for more on (cdr lists) + for i from 1 + do + (sloop for elt in list + as entry = (find elt results :key #'car :test #'string=) + unless (member i entry) + do + (sloop 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))) + (sloop for duplicate in + (find-duplicates + shadowed-symbol-names + interned-symbol-names + (sloop for list in shadowing-imported-from-symbol-names-list + append (rest list)) + (sloop for list in imported-from-symbol-names-list + append (rest list))) + do + (error + 'program-error + :format-control "The symbol ~s cannot coexist in these lists:~{ ~s~}" + :format-arguments + (list (first duplicate) + (sloop for num in (rest duplicate) + collect + (case num + (1 :SHADOW) + (2 :INTERN) + (3 :SHADOWING-IMPORT-FROM) + (4 :IMPORT-FROM)))))) + (sloop for duplicate in + (find-duplicates exported-symbol-names interned-symbol-names) + do + (error + 'program-error + :format-control "The symbol ~s cannot coexist in these lists:~{ ~s~}" + :format-arguments + (list (first duplicate) + (sloop for num in + (rest duplicate) + collect (case num + (1 :EXPORT) + (2 :INTERN))))))) + `(eval-when (load eval compile) + (if (find-package ,name) + (progn (rename-package ,name ,name) + ,@(when nicknames + `((rename-package ,name ,name ',nicknames))) + #+(or symbolics excl) + ,@(when size + #+symbolics + `((when (> ,size (pkg-max-number-of-symbols + (find-package ,name))) + (pkg-rehash (find-package ,name) ,size))) + #+excl `((let + ((tab (excl::package-internal-symbols + (find-package ,name)))) + (when (hash-table-p tab) + (setf (excl::ha_rehash-size tab) ,size))))) + ,@(when (not (null (member ':use options ':key #'car))) + `((unuse-package + (package-use-list (find-package ,name)) ,name)))) + (make-package + ,name + ':use 'nil + ':nicknames + ',nicknames + ,@(when size + #+lispm `(:size ,size) + #+excl `(:internal-symbols ,size)))) + ,@(progn + `((setf (get ',(intern name :keyword) + 'si::package-documentation) + ,documentation)) + ) + (let ((*package* (find-package ,name))) + ,@(when SHADOWed-symbol-names + `((SHADOW (mapcar #'intern ',SHADOWed-symbol-names)))) + ,@(when SHADOWING-IMPORTed-from-symbol-names-list + (mapcar #'(lambda (list) + `(SHADOWING-IMPORT + (mapcar #'(lambda (symbol) + (unless (multiple-value-bind (s p) (find-symbol symbol ,(first list)) p) + (cerror "Continue anyway" 'package-error + :package (first list) + :format-control "~%Symbol ~a not present" + :format-arguments (list symbol))) + (intern symbol ,(first list))) + ',(rest list)))) + SHADOWING-IMPORTed-from-symbol-names-list)) + (USE-PACKAGE ',(if (member ':USE options ':test #'option-test) + (mapcar #'string (option-values ':USE options)) + "LISP")) + ,@(when IMPORTed-from-symbol-names-list + (mapcar #'(lambda (list) + `(IMPORT (mapcar #'(lambda (symbol) + (unless (multiple-value-bind (s p) (find-symbol symbol ,(first list)) p) + (cerror "Continue anyway" 'package-error + :package (first list) + :format-control "~%Symbol ~a not present" + :format-arguments (list symbol))) + (intern symbol ,(first list))) + ',(rest list)))) + IMPORTed-from-symbol-names-list)) + ,@(when INTERNed-symbol-names + `((mapcar #'INTERN ',INTERNed-symbol-names))) + ,@(when EXPORTed-symbol-names + `((EXPORT (mapcar #'intern ',EXPORTed-symbol-names)))) + ,@(when EXPORTed-from-package-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))))))))) + ) + (find-package ,name))))) + +;#+excl +;(excl::defadvice cl:documentation (look-for-package-type :around) +; (let ((symbol (first excl::arglist)) +; (type (second excl::arglist))) +; (if (or (eq ':package (intern (string type) :keyword)) +; (eq ':defpackage (intern (string type) :keyword))) +; (or (get symbol 'excl::%package-documentation) +; (get (intern (string symbol) :keyword) 'excl::%package-documentation)) +; (values :do-it)))) + +;#+symbolics +;(scl::advise cl:documentation :around look-for-package-type nil +; (let ((symbol (first scl::arglist)) +; (type (second scl::arglist))) +; (if (or (eq ':package (intern (string type) :keyword)) +; (eq ':defpackage (intern (string type) :keyword))) +; (or (get symbol ':package-documentation) +; (get (intern (string symbol) :keyword) ':package-documentation)) +; (values :do-it)))) + +;(pushnew :defpackage *features*) +;(unintern 'defpackage 'user) + +(provide :defpackage) +(pushnew :defpackage *features*) + +(eval-when (load) + (in-package "USER") + (unintern 'defpackage 'user) + (use-package "DEFPACKAGE")) + +;;;; ------------------------------------------------------------ +;;;; End of File +;;;; ------------------------------------------------------------ + diff --git a/lsp/gcl_defstruct.lsp b/lsp/gcl_defstruct.lsp new file mode 100755 index 0000000..011b293 --- /dev/null +++ b/lsp/gcl_defstruct.lsp @@ -0,0 +1,888 @@ +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +;;;; DEFSTRUCT.LSP +;;;; +;;;; The structure routines. + + +(in-package 'lisp) +(export 'defstruct) + + +(in-package 'system) + + +(proclaim '(optimize (safety 2) (space 3))) + + + +;(in-package 'system) + + + +(defvar *accessors* (make-array 10 :adjustable t)) +(defvar *list-accessors* (make-array 2 :adjustable t)) +(defvar *vector-accessors* (make-array 2 :adjustable t)) + +(or (fboundp 'record-fn) (setf (symbol-function 'record-fn) + #'(lambda (&rest l) l nil))) + +(defun make-access-function (name conc-name no-conc type named include no-fun + ;; from apply + slot-name default-init slot-type read-only + offset &optional predicate ) + (declare (ignore named default-init predicate )) + + (let ((access-function + (if no-conc + slot-name + (intern (si:string-concatenate (string conc-name) + (string slot-name))))) + accsrs dont-overwrite) + (ecase type + ((nil) + (setf accsrs *accessors*)) + (list + (setf accsrs *list-accessors*)) + (vector + (setf accsrs *vector-accessors*))) + (or (> (length accsrs) offset) + (adjust-array accsrs (+ offset 10))) + (unless + dont-overwrite + (record-fn access-function 'defun '(t) slot-type) + (or no-fun + (and (fboundp access-function) + (eq (aref accsrs offset) (symbol-function access-function))) + (setf (symbol-function access-function) + (or (aref accsrs offset) + (setf (aref accsrs offset) + (cond ((eq accsrs *accessors*) + #'(lambda (x) + (or (structurep x) + (error "~a is not a structure" x)) + (structure-ref1 x offset))) + ((eq accsrs *list-accessors*) + #'(lambda(x) + (si:list-nth offset x))) + ((eq accsrs *vector-accessors*) + #'(lambda(x) + (aref x offset))))))))) + (cond (read-only + (remprop access-function 'structure-access) + (setf (get access-function 'struct-read-only) t)) + (t (remprop access-function 'setf-update-fn) + (remprop access-function 'setf-lambda) + (remprop access-function 'setf-documentation) + (let ((tem (get access-function 'structure-access))) + (cond ((and (consp tem) include + (subtypep include (car tem)) + (eql (cdr tem) offset)) + ;; don't change overwrite accessor of subtype. + (setq dont-overwrite t) + ) + (t (setf (get access-function 'structure-access) + (cons (if type type name) offset))))))) + nil)) + + +(defun make-constructor (name constructor type named + slot-descriptions) + (declare (ignore named)) + (let ((slot-names + ;; Collect the slot-names. + (mapcar #'(lambda (x) + (cond ((null x) + ;; If the slot-description is NIL, + ;; it is in the padding of initial-offset. + nil) + ((null (car x)) + ;; If the slot name is NIL, + ;; it is the structure name. + ;; This is for typed structures with names. + (list 'quote (cadr x))) + (t (car x)))) + slot-descriptions)) + (keys + ;; Make the keyword parameters. + (mapcan #'(lambda (x) + (cond ((null x) nil) + ((null (car x)) nil) + ((null (cadr x)) (list (car x))) + (t (list (list (car x) (cadr x)))))) + slot-descriptions))) + (cond ((consp constructor) + ;; The case for a BOA constructor. + ;; Dirty code!! + ;; We must add an initial value for an optional parameter, + ;; if the default value is not specified + ;; in the given parameter list and yet the initial value + ;; is supplied in the slot description. + (do ((a (cadr constructor) (cdr a)) (l nil) (vs nil)) + ((endp a) + ;; Add those options that do not appear in the parameter list + ;; as auxiliary paramters. + ;; The parameters are accumulated in the variable VS. + (setq keys + (nreconc (cons '&aux l) + (mapcan #'(lambda (k) + (if (member (if (atom k) k (car k)) + vs) + nil + (list k))) + keys)))) + ;; Skip until &OPTIONAL appears. + (when (member (car a) lambda-list-keywords) + (or (eq (car a) '&optional) (push '&optional a))) + (cond ((eq (car a) '&optional) + (setq l (cons '&optional l)) + (do ((aa (cdr a) (cdr aa)) (ov) (y)) + ((endp aa) + ;; Add those options that do not appear in the + ;; parameter list. + (setq keys + (nreconc (cons '&aux l) + (mapcan #'(lambda (k) + (if (member (if (atom k) + k + (car k)) + vs) + nil + (list k))) + keys))) + (return nil)) + (when (member (car aa) lambda-list-keywords) + (when (eq (car aa) '&rest) + ;; &REST is found. + (setq l (cons '&rest l)) + (setq aa (cdr aa)) + (unless (and (not (endp aa)) + (symbolp (car aa))) + (illegal-boa)) + (setq vs (cons (car aa) vs)) + (setq l (cons (car aa) l)) + (setq aa (cdr aa)) + (when (endp aa) + (setq keys + (nreconc + (cons '&aux l) + (mapcan + #'(lambda (k) + (if (member (if (atom k) + k + (car k)) + vs) + nil + (list k))) + keys))) + (return nil))) + ;; &AUX should follow. + (unless (eq (car aa) '&aux) + (illegal-boa)) + (setq l (cons '&aux l)) + (do ((aaa (cdr aa) (cdr aaa))) + ((endp aaa)) + (setq l (cons (car aaa) l)) + (cond ((and (atom (car aaa)) + (symbolp (car aaa))) + (setq vs (cons (car aaa) vs))) + ((and (symbolp (caar aaa)) + (or (endp (cdar aaa)) + (endp (cddar aaa)))) + (setq vs (cons (caar aaa) vs))) + (t (illegal-boa)))) + ;; End of the parameter list. + (setq keys + (nreconc l + (mapcan + #'(lambda (k) + (if (member (if (atom k) + k + (car k)) + vs) + nil + (list k))) + keys))) + (return nil)) + ;; Checks if the optional paramter without a default + ;; value has a default value in the slot-description. + (if (and (cond ((atom (car aa)) (setq ov (car aa)) t) + ((endp (cdar aa)) (setq ov (caar aa)) t) + (t nil)) + (setq y (member ov + keys + :key + #'(lambda (x) + (if (consp x) + ;; With default value. + (car x)))))) + ;; If no default value is supplied for + ;; the optional parameter and yet appears + ;; in KEYS with a default value, + ;; then cons the pair to L, + (setq l (cons (car y) l)) + ;; otherwise cons just the parameter to L. + (setq l (cons (car aa) l))) + ;; Checks the form of the optional parameter. + (cond ((atom (car aa)) + (unless (symbolp (car aa)) + (illegal-boa)) + (setq vs (cons (car aa) vs))) + ((not (symbolp (caar aa))) + (illegal-boa)) + ((or (endp (cdar aa)) (endp (cddar aa))) + (setq vs (cons (caar aa) vs))) + ((not (symbolp (caddar aa))) + (illegal-boa)) + ((not (endp (cdddar aa))) + (illegal-boa)) + (t + (setq vs (cons (caar aa) vs)) + (setq vs (cons (caddar aa) vs))))) + ;; RETURN from the outside DO. + (return nil)) + (t + (unless (symbolp (car a)) + (illegal-boa)) + (setq l (cons (car a) l)) + (setq vs (cons (car a) vs))))) + (setq constructor (car constructor))) + (t + ;; If not a BOA constructor, just cons &KEY. + (setq keys (cons '&key keys)))) + (cond ((null type) + `(defun ,constructor ,keys + (si:make-structure ',name ,@slot-names))) + ((or (eq type 'vector) + (and (consp type) (eq (car type) 'vector))) + `(defun ,constructor ,keys + (vector ,@slot-names))) + ((eq type 'list) + `(defun ,constructor ,keys + (list ,@slot-names))) + ((error "~S is an illegal structure type" type))))) + +(defun illegal-boa () + (error "An illegal BOA constructor.")) + +(defun make-predicate (name predicate type named name-offset) + (cond ((null type)) + ; done in define-structure + ((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.")) + `(defun ,predicate (x) + (and (vectorp x) + (> (the fixnum (length x)) ,name-offset) + (eq (aref (the (vector t) 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) + `(defun ,predicate (x) + (and (consp x) + (eq (car x) ',name))) + `(defun ,predicate (x) + (do ((i ,name-offset (1- i)) + (z x (cdr z))) + ((= i 0) (and (consp z) (eq (car z) ',name))) + (declare (fixnum i)) + (unless (consp z) (return nil)))))) + ((error "~S is an illegal structure type.")))) + + +;;; PARSE-SLOT-DESCRIPTION parses the given slot-description +;;; and returns a list of the form: +;;; (slot-name default-init slot-type read-only offset) + +(defun parse-slot-description (slot-description offset) + (let (slot-name default-init slot-type read-only) + (cond ((atom slot-description) + (setq slot-name slot-description)) + ((endp (cdr slot-description)) + (setq slot-name (car slot-description))) + (t + (setq slot-name (car slot-description)) + (setq default-init (cadr slot-description)) + (do ((os (cddr slot-description) (cddr os)) (o) (v)) + ((endp os)) + (setq o (car os)) + (when (endp (cdr os)) + (error "~S is an illegal structure slot option." + os)) + (setq v (cadr os)) + (case o + (:type (setq slot-type v)) + (:read-only (setq read-only v)) + (t + (error "~S is an illegal structure slot option." + os)))))) + (list slot-name default-init slot-type read-only offset))) + + +;;; OVERWRITE-SLOT-DESCRIPTIONS overwrites the old slot-descriptions +;;; with the new descriptions which are specified in the +;;; :include defstruct option. + +(defun overwrite-slot-descriptions (news olds) + (if (null olds) + nil + (let ((sds (member (caar olds) news :key #'car))) + (cond (sds + (when (and (null (cadddr (car sds))) + (cadddr (car olds))) + ;; If read-only is true in the old + ;; and false in the new, signal an error. + (error "~S is an illegal include slot-description." + sds)) + ;; If + (setf (caddr (car sds)) + (best-array-element-type (caddr (car sds)))) + (when (not (equal (normalize-type (or (caddr (car sds)) t)) + (normalize-type (or (caddr (car olds)) t)))) + (error "Type mismmatch for included slot ~a" (car sds))) + (cons (list (caar sds) + (cadar sds) + (caddar sds) + (cadddr (car sds)) + ;; The offset if from the old. + (car (cddddr (car olds)))) + (overwrite-slot-descriptions news (cdr olds)))) + (t + (cons (car olds) + (overwrite-slot-descriptions news (cdr olds)))))))) + +(defvar *all-t-s-type* (make-array 50 :element-type 'unsigned-char :static t)) +(defvar *alignment-t* (alignment t)) + +(defun make-t-type (n include slot-descriptions &aux i) + (let ((res (make-array n :element-type 'unsigned-char :static t))) + (when include + (let ((tem (get include 's-data))raw) + (or tem (error "Included structure undefined ~a" include)) + (setq raw (s-data-raw tem)) + (dotimes (i (min n (length raw))) + (setf (aref res i) (aref raw i))))) + (dolist (v slot-descriptions) + (setq i (nth 4 v)) + (let ((type (third v))) + (cond ((<= (the fixnum (alignment type)) *alignment-t*) + (setf (aref res i) (aet-type type)))))) + (cond ((< n (length *all-t-s-type*)) + (dotimes (i n) + (cond ((not (eql (the fixnum (aref res i)) 0)) + (return-from make-t-type res)))) + *all-t-s-type*) + (t res)))) + +(defvar *standard-slot-positions* + (let ((ar (make-array 50 :element-type 'unsigned-short + :static t))) + (dotimes (i 50) + (declare (fixnum i)) + (setf (aref ar i)(* (size-of t) i))) + ar)) + +(eval-when (compile ) +(proclaim '(function round-up (fixnum fixnum ) fixnum)) +) + +(defun round-up (a b) + (declare (fixnum a b)) + (setq a (ceiling a b)) + (the fixnum (* a b))) + + +(defun get-slot-pos (leng include slot-descriptions &aux type small-types + has-holes) + (declare (special *standard-slot-positions*)) include + (dolist (v slot-descriptions) + (when (and v (car v)) + (setf type + (best-array-element-type (caddr v)) + (caddr v) type) + (let ((val (second v))) + (unless (typep val type) + (if (and (symbolp val) + (constantp val)) + (setf val (symbol-value val))) + (and (constantp val) + (setf (cadr v) (coerce val type))))) + (cond ((memq type '(signed-char unsigned-char + short unsigned-short + long-float + bit)) + (setq small-types t))))) + (cond ((and (null small-types) + (< leng (length *standard-slot-positions*)) + (list *standard-slot-positions* (* leng (size-of t)) nil))) + (t (let ((ar (make-array leng :element-type 'unsigned-short + :static t)) + (pos 0)(i 0)(align 0)type (next-pos 0)) + (declare (fixnum pos i align next-pos)) + ;; A default array. + + (dolist + (v slot-descriptions) + (setq type (caddr v)) + (setq align (alignment type)) + (unless (<= align *alignment-t*) + (setq type t) + (setf (caddr v) t) + (setq align *alignment-t*) + (setq v (nconc v '(t)))) + (setq next-pos (round-up pos align)) + (or (eql pos next-pos) (setq has-holes t)) + (setq pos next-pos) + (setf (aref ar i) pos) + (incf pos (size-of type)) + (incf i)) + (list ar (round-up pos (size-of t)) has-holes) + )))) + + + + + + + + + + + + + + + + + + + + + + + +(defun define-structure (name conc-name no-conc type named slot-descriptions copier + static include print-function constructors + offset predicate &optional documentation no-funs + &aux def leng) + (and (consp type) (eq (car type) 'vector)(setq type 'vector)) + (setq leng(length slot-descriptions)) + (dolist (x slot-descriptions) + (and x (car x) + (apply #'make-access-function + name conc-name no-conc type named include no-funs + x ))) + (when (and copier (not no-funs)) + (setf (symbol-function copier) + (ecase type + ((nil) #'si::copy-structure) + (list #'copy-list) + (vector #'copy-seq)))) + + + (cond ((and (null type) + (eq name 's-data)) + ;bootstrapping code! + (setq def (make-s-data-structure + (make-array (* leng (size-of t)) + :element-type 'string-char :static t) + (make-t-type leng nil slot-descriptions) + *standard-slot-positions* + slot-descriptions + t + )) + ) + (t + (let (slot-position + (size 0) has-holes + (include-str (and include + (get include 's-data)))) + (when include-str + (cond ((and (s-data-frozen include-str) + (or (not (s-data-included include-str)) + (not (let ((te (get name 's-data))) + (and te + (eq (s-data-includes + te) + include-str)))))) + (warn " ~a was frozen but now included" + include))) + (pushnew name (s-data-included include-str))) + (when (null type) + (setf slot-position + (get-slot-pos leng include slot-descriptions)) + (setf size (cadr slot-position) + has-holes (caddr slot-position) + slot-position (car slot-position) + )) + (setf def (make-s-data + :name name + :length leng + :raw + (and (null type) + (make-t-type leng include slot-descriptions)) + :slot-position slot-position + :size size + :has-holes has-holes + :staticp static + :includes include-str + :print-function print-function + :slot-descriptions slot-descriptions + :constructors constructors + :offset offset + :type type + :named named + :documentation documentation + :conc-name conc-name))))) + (let ((tem (get name 's-data))) + (cond ((eq name 's-data) + (if tem (warn "not replacing s-data property")) + (or tem (setf (get name 's-data) def))) + (tem + (check-s-data tem def name)) + (t (setf (get name 's-data) def))) + (when documentation + (setf (get name 'structure-documentation) + documentation)) + (when (and (null type) predicate) + (record-fn predicate 'defun '(t) t) + (or no-funs + (setf (symbol-function predicate) + #'(lambda (x) + (si::structure-subtype-p x name)))) + (setf (get predicate 'compiler::co1) + 'compiler::co1structure-predicate) + (setf (get predicate 'struct-predicate) name) + ) + ) nil) + + +(defmacro defstruct (name &rest slots) + (let ((slot-descriptions slots) + options + conc-name + constructors default-constructor no-constructor + copier + predicate predicate-specified + include + print-function type named initial-offset + offset name-offset + documentation + static + (no-conc nil)) + + (when (consp name) + ;; The defstruct options are supplied. + (setq options (cdr name)) + (setq name (car name))) + + ;; The default conc-name. + (setq conc-name (si:string-concatenate (string name) "-")) + + ;; The default constructor. + (setq default-constructor + (intern (si:string-concatenate "MAKE-" (string name)))) + + ;; The default copier and predicate. + (setq copier + (intern (si:string-concatenate "COPY-" (string name))) + predicate + (intern (si:string-concatenate (string name) "-P"))) + + ;; Parse the defstruct options. + (do ((os options (cdr os)) (o) (v)) + ((endp os)) + (cond ((and (consp (car os)) (not (endp (cdar os)))) + (setq o (caar os) v (cadar os)) + (case o + (:conc-name + (if (null v) + (progn + (setq conc-name "") + (setq no-conc t)) + (setq conc-name v))) + (:constructor + (if (null v) + (setq no-constructor t) + (if (endp (cddar os)) + (setq constructors (cons v constructors)) + (setq constructors (cons (cdar os) constructors))))) + (:copier (setq copier v)) + (:static (setq static v)) + (:predicate + (setq predicate v) + (setq predicate-specified t)) + (:include + (setq include (cdar os)) + (unless (get v 's-data) + (error "~S is an illegal included structure." v))) + (:print-function + (and (consp v) (eq (car v) 'function) + (setq v (second v))) + (setq print-function v)) + (:type (setq type v)) + (:initial-offset (setq initial-offset v)) + (t (error "~S is an illegal defstruct option." o)))) + (t + (if (consp (car os)) + (setq o (caar os)) + (setq o (car os))) + (case o + (:constructor + (setq constructors + (cons default-constructor constructors))) + ((:copier :predicate :print-function)) + (:conc-name + (progn + (setq conc-name "") + (setq no-conc t))) + (:named (setq named t)) + (t (error "~S is an illegal defstruct option." o)))))) + + (setq conc-name (intern (string conc-name))) + + (and include (not print-function) + (setq print-function (s-data-print-function (get (car include) 's-data)))) + + ;; Skip the documentation string. + (when (and (not (endp slot-descriptions)) + (stringp (car slot-descriptions))) + (setq documentation (car slot-descriptions)) + (setq slot-descriptions (cdr slot-descriptions))) + + ;; Check the include option. + (when include + (unless (equal type + (s-data-type (get (car include) 's-data))) + (error "~S is an illegal structure include." + (car include)))) + + ;; Set OFFSET. + (cond ((null include) + (setq offset 0)) + (t + (setq offset (s-data-offset (get (car include) 's-data))))) + + ;; Increment OFFSET. + (when (and type initial-offset) + (setq offset (+ offset initial-offset))) + (when (and type named) + (setq name-offset offset) + (setq offset (1+ offset))) + + ;; Parse slot-descriptions, incrementing OFFSET for each one. + (do ((ds slot-descriptions (cdr ds)) + (sds nil)) + ((endp ds) + (setq slot-descriptions (nreverse sds))) + (setq sds (cons (parse-slot-description (car ds) offset) sds)) + (setq offset (1+ offset))) + + ;; If TYPE is non-NIL and structure is named, + ;; add the slot for the structure-name to the slot-descriptions. + (when (and type named) + (setq slot-descriptions + (cons (list nil name) slot-descriptions))) + + ;; Pad the slot-descriptions with the initial-offset number of NILs. + (when (and type initial-offset) + (setq slot-descriptions + (append (make-list initial-offset) slot-descriptions))) + + ;; Append the slot-descriptions of the included structure. + ;; The slot-descriptions in the include option are also counted. + (cond ((null include)) + ((endp (cdr include)) + (setq slot-descriptions + (append (s-data-slot-descriptions + (get (car include) 's-data)) + slot-descriptions))) + (t + (setq slot-descriptions + (append (overwrite-slot-descriptions + (mapcar #'(lambda (sd) + (parse-slot-description sd 0)) + (cdr include)) + (s-data-slot-descriptions + (get (car include) 's-data) + )) + slot-descriptions)))) + + (cond (no-constructor + ;; If a constructor option is NIL, + ;; no constructor should have been specified. + (when constructors + (error "Contradictory constructor options."))) + ((null constructors) + ;; If no constructor is specified, + ;; the default-constructor is made. + (setq constructors (list default-constructor)))) + + ;; We need a default constructor for the sharp-s-reader + (or (member t (mapcar 'symbolp constructors)) + (push (intern (string-concatenate "__si::" default-constructor)) + constructors)) + + ;; Check the named option and set the predicate. + (when (and type (not named)) + (when predicate-specified + (error "~S is an illegal structure predicate." + predicate)) + (setq predicate nil)) + + (when include (setq include (car include))) + + ;; Check the print-function. + (when (and print-function type) + (error "A print function is supplied to a typed structure.")) + + `(progn + (define-structure ',name ',conc-name ',no-conc ',type + ',named ',slot-descriptions ',copier ',static ',include ',print-function ',constructors + ',offset ',predicate ',documentation + ) + + ,@(mapcar #'(lambda (constructor) + (make-constructor name constructor type named + slot-descriptions)) + constructors) + ,@(if (and type predicate) + (list (make-predicate name predicate type named + name-offset))) + ',name + ))) + +;; First several fields of this must coincide with the C structure +;; s_data (see object.h). + + +(defstruct s-data name + (length 0 :type fixnum) + raw + included + includes + staticp + print-function + slot-descriptions + slot-position + (size 0 :type fixnum) + has-holes + frozen + documentation + constructors + offset + named + type + conc-name + ) + + +(defun check-s-data (tem def name) + (cond ((s-data-included tem) + (setf (s-data-included def)(s-data-included tem)))) + (cond ((s-data-frozen tem) + (setf (s-data-frozen def) t))) + (unless (equalp def tem) + (warn "structure ~a is changing" name) + (setf (get name 's-data) def))) +(defun freeze-defstruct (name) + (let ((tem (and (symbolp name) (get name 's-data)))) + (if tem (setf (s-data-frozen tem) t)))) + + +;;; The #S reader. + +(defun sharp-s-reader (stream subchar arg) + (declare (ignore subchar)) + (when (and arg (null *read-suppress*)) + (error "An extra argument was supplied for the #S readmacro.")) + (let* ((l (prog1 (read stream t nil t) + (if *read-suppress* + (return-from sharp-s-reader nil)))) + (sd + (or (get (car l) 's-data) + + (error "~S is not a structure." (car l))))) + + ;; Intern keywords in the keyword package. + (do ((ll (cdr l) (cddr ll))) + ((endp ll) + ;; Find an appropriate construtor. + (do ((cs (s-data-constructors sd) (cdr cs))) + ((endp cs) + (error "The structure ~S has no structure constructor." + (car l))) + (when (symbolp (car cs)) + (return (apply (car cs) (cdr l)))))) + (rplaca ll (intern (string (car ll)) 'keyword))))) + + +;; Set the dispatch macro. +(set-dispatch-macro-character #\# #\s 'sharp-s-reader) +(set-dispatch-macro-character #\# #\S 'sharp-s-reader) + +;; Examples from Common Lisp Reference Manual. + +#| +(defstruct ship + x-position + y-position + x-velocity + y-velocity + mass) + +(defstruct person name (age 20 :type signed-char) (eyes 2 :type signed-char) + sex) +(defstruct person name (age 20 :type signed-char) (eyes 2 :type signed-char) + sex) +(defstruct person1 name (age 20 :type fixnum) + sex) + +(defstruct joe a (a1 0 :type (mod 30)) (a2 0 :type (mod 30)) + (a3 0 :type (mod 30)) (a4 0 :type (mod 30)) ) + +;(defstruct person name age sex) + +(defstruct (astronaut (:include person (age 45 :type fixnum)) + (:conc-name astro-)) + helmet-size + (favorite-beverage 'tang)) + +(defstruct (foo (:constructor create-foo (a + &optional b (c 'sea) + &rest d + &aux e (f 'eff)))) + a (b 'bee) c d e f) + +(defstruct (binop (:type list) :named (:initial-offset 2)) + (operator '?) + operand-1 + operand-2) + +(defstruct (annotated-binop (:type list) + (:initial-offset 3) + (:include binop)) + commutative + associative + identity) + +|# diff --git a/lsp/gcl_describe.lsp b/lsp/gcl_describe.lsp new file mode 100755 index 0000000..01faf92 --- /dev/null +++ b/lsp/gcl_describe.lsp @@ -0,0 +1,454 @@ +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +;;;; describe.lsp +;;;; +;;;; DESCRIBE and INSPECT + + +(in-package 'lisp) + +(export '(describe inspect)) + + +(in-package 'system) + + +(proclaim '(optimize (safety 2) (space 3))) + + +(defvar *inspect-level* 0) +(defvar *inspect-history* nil) +(defvar *inspect-mode* nil) + +(defvar *old-print-level* nil) +(defvar *old-print-length* nil) + + +(defun inspect-read-line () + (do ((char (read-char *query-io*) (read-char *query-io*))) + ((or (char= char #\Newline) (char= char #\Return))))) + +(defun read-inspect-command (label object allow-recursive) + (unless *inspect-mode* + (inspect-indent-1) + (if allow-recursive + (progn (princ label) (inspect-object object)) + (format t label object)) + (return-from read-inspect-command nil)) + (loop + (inspect-indent-1) + (if allow-recursive + (progn (princ label) + (inspect-indent) + (prin1 object)) + (format t label object)) + (write-char #\Space) + (force-output) + (case (do ((char (read-char *query-io*) (read-char *query-io*))) + ((and (char/= char #\Space) (char/= #\Tab)) 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) + (let ((*print-pretty* t) (*print-level* nil) (*print-length* nil)) + (prin1 object) + (terpri))) + ((#\a #\A) (inspect-read-line) (throw 'abort-inspect nil)) + ((#\u #\U) + (return (values t (prog1 + (eval (read-preserving-whitespace *query-io*)) + (inspect-read-line))))) + ((#\e #\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))) + ((#\q #\Q) (inspect-read-line) (throw 'quit-inspect nil)) + (t (inspect-read-line) + (terpri) + (format t + "Inspect commands:~%~ + n (or N or Newline): inspects the field (recursively).~%~ + s (or S): skips the field.~%~ + p (or P): pretty-prints the field.~%~ + a (or A): aborts the inspection ~ + of the rest of the fields.~%~ + u (or U) form: updates the field ~ + with the value of the form.~%~ + e (or E) form: evaluates and prints the form.~%~ + q (or Q): quits the inspection.~%~ + ?: prints this.~%~%"))))) + +(defmacro inspect-recursively (label object &optional place) + (if place + `(multiple-value-bind (update-flag new-value) + (read-inspect-command ,label ,object t) + (when update-flag (setf ,place new-value))) + `(when (read-inspect-command ,label ,object t) + (princ "Not updated.") + (terpri)))) + +(defmacro inspect-print (label object &optional place) + (if place + `(multiple-value-bind (update-flag new-value) + (read-inspect-command ,label ,object nil) + (when update-flag (setf ,place new-value))) + `(when (read-inspect-command ,label ,object nil) + (princ "Not updated.") + (terpri)))) + +(defun inspect-indent () + (fresh-line) + (format t "~V@T" + (* 4 (if (< *inspect-level* 8) *inspect-level* 8)))) + +(defun inspect-indent-1 () + (fresh-line) + (format t "~V@T" + (- (* 4 (if (< *inspect-level* 8) *inspect-level* 8)) 3))) + + +(defun inspect-symbol (symbol) + (let ((p (symbol-package symbol))) + (cond ((null p) + (format t "~:@(~S~) - uninterned symbol" symbol)) + ((eq p (find-package "KEYWORD")) + (format t "~:@(~S~) - keyword" symbol)) + (t + (format t "~:@(~S~) - ~:[internal~;external~] symbol in ~A package" + symbol + (multiple-value-bind (b f) + (find-symbol (symbol-name symbol) p) + (declare (ignore b)) + (eq f :external)) + (package-name p))))) + + (when (boundp symbol) + (if *inspect-mode* + (inspect-recursively "value:" + (symbol-value symbol) + (symbol-value symbol)) + (inspect-print "value:~% ~S" + (symbol-value symbol) + (symbol-value symbol)))) + + (do ((pl (symbol-plist symbol) (cddr pl))) + ((endp pl)) + (unless (and (symbolp (car pl)) + (or (eq (symbol-package (car pl)) (find-package 'system)) + (eq (symbol-package (car pl)) (find-package 'compiler)))) + (if *inspect-mode* + (inspect-recursively (format nil "property ~S:" (car pl)) + (cadr pl) + (get symbol (car pl))) + (inspect-print (format nil "property ~:@(~S~):~% ~~S" (car pl)) + (cadr pl) + (get symbol (car pl)))))) + + (when (print-doc symbol t) + (format t "~&-----------------------------------------------------------------------------~%")) + ) + +(defun inspect-package (package) + (format t "~S - package" package) + (when (package-nicknames package) + (inspect-print "nicknames: ~S" (package-nicknames package))) + (when (package-use-list package) + (inspect-print "use list: ~S" (package-use-list package))) + (when (package-used-by-list package) + (inspect-print "used-by list: ~S" (package-used-by-list package))) + (when (package-shadowing-symbols package) + (inspect-print "shadowing symbols: ~S" + (package-shadowing-symbols package)))) + +(defun inspect-character (character) + (format t + (cond ((standard-char-p character) "~S - standard character") + ((string-char-p character) "~S - string character") + (t "~S - character")) + character) + (inspect-print "code: #x~X" (char-code character)) + (inspect-print "bits: ~D" (char-bits character)) + (inspect-print "font: ~D" (char-font character))) + +(defun inspect-number (number) + (case (type-of number) + (fixnum (format t "~S - fixnum (32 bits)" number)) + (bignum (format t "~S - bignum" number)) + (ratio + (format t "~S - ratio" number) + (inspect-recursively "numerator:" (numerator number)) + (inspect-recursively "denominator:" (denominator number))) + (complex + (format t "~S - complex" number) + (inspect-recursively "real part:" (realpart number)) + (inspect-recursively "imaginary part:" (imagpart number))) + ((short-float single-float) + (format t "~S - short-float" number) + (multiple-value-bind (signif expon sign) + (integer-decode-float number) + (declare (ignore sign)) + (inspect-print "exponent: ~D" expon) + (inspect-print "mantissa: ~D" signif))) + ((long-float double-float) + (format t "~S - long-float" number) + (multiple-value-bind (signif expon sign) + (integer-decode-float number) + (declare (ignore sign)) + (inspect-print "exponent: ~D" expon) + (inspect-print "mantissa: ~D" signif))))) + +(defun inspect-cons (cons) + (format t + (case (car cons) + ((lambda lambda-block lambda-closure lambda-block-closure) + "~S - function") + (quote "~S - constant") + (t "~S - cons")) + cons) + (when *inspect-mode* + (do ((i 0 (1+ i)) + (l cons (cdr l))) + ((atom l) + (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))))) + +(defun inspect-string (string) + (format t (if (simple-string-p string) "~S - simple string" "~S - string") + string) + (inspect-print "dimension: ~D"(array-dimension string 0)) + (when (array-has-fill-pointer-p string) + (inspect-print "fill pointer: ~D" + (fill-pointer string) + (fill-pointer string))) + (when *inspect-mode* + (dotimes (i (array-dimension string 0)) + (inspect-recursively (format nil "aref ~D:" i) + (char string i) + (char string i))))) + +(defun inspect-vector (vector) + (format t (if (simple-vector-p vector) "~S - simple vector" "~S - vector") + vector) + (inspect-print "dimension: ~D" (array-dimension vector 0)) + (when (array-has-fill-pointer-p vector) + (inspect-print "fill pointer: ~D" + (fill-pointer vector) + (fill-pointer vector))) + (when *inspect-mode* + (dotimes (i (array-dimension vector 0)) + (inspect-recursively (format nil "aref ~D:" i) + (aref vector i) + (aref vector i))))) + +(defun inspect-array (array) + (format t (if (adjustable-array-p array) + "~S - adjustable aray" + "~S - array") + array) + (inspect-print "rank: ~D" (array-rank array)) + (inspect-print "dimensions: ~D" (array-dimensions array)) + (inspect-print "total size: ~D" (array-total-size array))) + +(defun inspect-structure (x &aux name) + (format t "Structure of type ~a ~%Byte:[Slot Type]Slot Name :Slot Value" + (setq name (type-of x))) + (let* ((sd (get name 'si::s-data)) + (spos (s-data-slot-position sd))) + (dolist (v (s-data-slot-descriptions sd)) + (format t "~%~4d:~@[[~s] ~]~20a:~s" + (aref spos (nth 4 v)) + (let ((type (nth 2 v))) + (if (eq t type) nil type)) + (car v) + (structure-ref1 x (nth 4 v)))))) + + +(defun inspect-object (object &aux (*inspect-level* *inspect-level*)) + (inspect-indent) + (when (and (not *inspect-mode*) + (or (> *inspect-level* 5) + (member object *inspect-history*))) + (prin1 object) + (return-from inspect-object)) + (incf *inspect-level*) + (push object *inspect-history*) + (catch 'abort-inspect + (cond ((symbolp object) (inspect-symbol object)) + ((packagep object) (inspect-package object)) + ((characterp object) (inspect-character object)) + ((numberp object) (inspect-number object)) + ((consp object) (inspect-cons object)) + ((stringp object) (inspect-string object)) + ((vectorp object) (inspect-vector object)) + ((arrayp object) (inspect-array object)) + ((structurep object)(inspect-structure object)) + (t (format t "~S - ~S" object (type-of object)))))) + + +(defun describe (object &aux (*inspect-mode* nil) + (*inspect-level* 0) + (*inspect-history* nil) + (*print-level* nil) + (*print-length* nil)) +; "The lisp function DESCRIBE." + (terpri) + (catch 'quit-inspect (inspect-object object)) + (terpri) + (values)) + +(defun inspect (object &aux (*inspect-mode* t) + (*inspect-level* 0) + (*inspect-history* nil) + (*old-print-level* *print-level*) + (*old-print-length* *print-length*) + (*print-level* 3) + (*print-length* 3)) +; "The lisp function INSPECT." + (read-line) + (princ "Type ? and a newline for help.") + (terpri) + (catch 'quit-inspect (inspect-object object)) + (terpri) + (values)) + +(defun print-doc (symbol &optional (called-from-apropos-doc-p nil) + &aux (f nil) x) + (flet ((doc1 (doc ind) + (setq f t) + (format t + "~&-----------------------------------------------------------------------------~%~53S~24@A~%~A" + symbol ind doc)) + (good-package () + (if (eq (symbol-package symbol) (find-package "LISP")) + (find-package "SYSTEM") + *package*))) + + (cond ((special-form-p symbol) + (doc1 (or (documentation symbol 'function) "") + (if (macro-function symbol) + "[Special form and Macro]" + "[Special form]"))) + ((macro-function symbol) + (doc1 (or (documentation symbol 'function) "") "[Macro]")) + ((fboundp symbol) + (doc1 + (or (documentation symbol 'function) + (if (consp (setq x (symbol-function symbol))) + (case (car x) + (lambda (format nil "~%Args: ~S" (cadr x))) + (lambda-block (format nil "~%Args: ~S" (caddr x))) + (lambda-closure + (format nil "~%Args: ~S" (car (cddddr x)))) + (lambda-block-closure + (format nil "~%Args: ~S" (cadr (cddddr x)))) + (t "")) + "")) + "[Function]")) + ((setq x (documentation symbol 'function)) + (doc1 x "[Macro or Function]"))) + + (cond ((constantp symbol) + (unless (and (eq (symbol-package symbol) (find-package "KEYWORD")) + (null (documentation symbol 'variable))) + (doc1 (or (documentation symbol 'variable) "") "[Constant]"))) + ((si:specialp symbol) + (doc1 (or (documentation symbol 'variable) "") + "[Special variable]")) + ((or (setq x (documentation symbol 'variable)) (boundp symbol)) + (doc1 (or x "") "[Variable]"))) + + (cond ((setq x (documentation symbol 'type)) + (doc1 x "[Type]")) + ((setq x (get symbol 'deftype-form)) + (let ((*package* (good-package))) + (doc1 (format nil "~%Defined as: ~S~%See the doc of DEFTYPE." x) + "[Type]")))) + + (cond ((setq x (documentation symbol 'structure)) + (doc1 x "[Structure]")) + ((setq x (get symbol 'defstruct-form)) + (doc1 (format nil "~%Defined as: ~S~%See the doc of DEFSTRUCT." x) + "[Structure]"))) + + (cond ((setq x (documentation symbol 'setf)) + (doc1 x "[Setf]")) + ((setq x (get symbol 'setf-update-fn)) + (let ((*package* (good-package))) + (doc1 (format nil "~%Defined as: ~S~%See the doc of DEFSETF." + `(defsetf ,symbol ,(get symbol 'setf-update-fn))) + "[Setf]"))) + ((setq x (get symbol 'setf-lambda)) + (let ((*package* (good-package))) + (doc1 (format nil "~%Defined as: ~S~%See the doc of DEFSETF." + `(defsetf ,symbol ,@(get symbol 'setf-lambda))) + "[Setf]"))) + ((setq x (get symbol 'setf-method)) + (let ((*package* (good-package))) + (doc1 + (format nil + "~@[~%Defined as: ~S~%See the doc of DEFINE-SETF-METHOD.~]" + (if (consp x) + (case (car x) + (lambda `(define-setf-method ,@(cdr x))) + (lambda-block `(define-setf-method ,@(cddr x))) + (lambda-closure `(define-setf-method ,@(cddddr x))) + (lambda-block-closure + `(define-setf-method ,@(cdr (cddddr x)))) + (t nil)) + nil)) + "[Setf]")))) + ) + (idescribe (symbol-name symbol)) + (if called-from-apropos-doc-p + f + (progn (if f + (format t "~&-----------------------------------------------------------------------------") + (format t "~&No documentation for ~:@(~S~)." symbol)) + (values)))) + +(defun apropos-doc (string &optional (package 'lisp) &aux (f nil)) + (setq string (string string)) + (if package + (do-symbols (symbol package) + (when (substringp string (string symbol)) + (setq f (or (print-doc symbol t) f)))) + (do-all-symbols (symbol) + (when (substringp string (string symbol)) + (setq f (or (print-doc symbol t) f))))) + (if f + (format t "~&-----------------------------------------------------------------------------") + (format t "~&No documentation for ~S in ~:[any~;~A~] package." + string package + (and package (package-name (coerce-to-package package))))) + (values)) + diff --git a/lsp/gcl_desetq.lsp b/lsp/gcl_desetq.lsp new file mode 100755 index 0000000..e9a2edd --- /dev/null +++ b/lsp/gcl_desetq.lsp @@ -0,0 +1,25 @@ + + + + +(defun desetq-consp-check (val) + (or (consp val) (error "~a is not a cons" val))) + +(defun desetq1 (form val) + (cond ((symbolp form) + (cond (form ;(push form *desetq-binds*) + `(setf ,form ,val)))) + ((consp form) + `(progn + (desetq-consp-check ,val) + ,(desetq1 (car form) `(car ,val)) + ,@ (if (consp (cdr form)) + (list(desetq1 (cdr form) `(cdr ,val))) + (and (cdr form) `((setf ,(cdr form) (cdr ,val))))))) + (t (error "")))) + + +(defmacro desetq (form val) + (cond ((atom val) (desetq1 form val)) + (t (let ((value (gensym))) + `(let ((,value ,val)) , (desetq1 form value)))))) diff --git a/lsp/gcl_destructuring_bind.lsp b/lsp/gcl_destructuring_bind.lsp new file mode 100644 index 0000000..a5e36bd --- /dev/null +++ b/lsp/gcl_destructuring_bind.lsp @@ -0,0 +1,405 @@ +;;;; From CMULISP + +;;;; From defmacro.lisp + +;;;; Some variable definitions. + +;;; Variables for amassing the results of parsing a defmacro. Declarations +;;; in DEFMACRO are the reason this isn't as easy as it sounds. +;;; + +(in-package 'lisp) + +(export '(destructuring-bind)) + +(defvar *arg-tests* () + "A list of tests that do argument counting at expansion time.") + +(defvar *system-lets* nil) +;(defvar *system-lets* () +; "Let bindings that are done to make lambda-list parsing possible.") + +(defvar *user-lets* () + "Let bindings that the user has explicitly supplied.") + +(defvar *default-default* nil + "Unsupplied optional and keyword arguments get this value defaultly.") + +;; Temps that we introduce and might not reference. +(defvar *ignorable-vars*) + +;;;; Stuff to parse DEFMACRO, MACROLET, DEFINE-SETF-METHOD, and DEFTYPE. + +;;; We save space in macro definitions by callig this function. +;;; +(defun do-arg-count-error (error-kind name arg lambda-list minimum maximum) + (error "Error in do-arg-count-error: ~S ~S ~S ~S ~S ~S~%" + error-kind + name + arg + lambda-list + minimum + maximum)) + +;;; PARSE-DEFMACRO returns, as multiple-values, a body, possibly a declare +;;; form to put where this code is inserted, and the documentation for the +;;; parsed body. +;;; +(defun parse-defmacro (lambda-list arg-list-name code name error-kind + &key (annonymousp nil) + (doc-string-allowed t) + ((:environment env-arg-name)) + ((:default-default *default-default*)) + (error-fun 'error)) + "Returns as multiple-values a parsed body, any local-declarations that + should be made where this body is inserted, and a doc-string if there is + one." + (multiple-value-bind (body declarations documentation) + (parse-body code nil doc-string-allowed) + (let* ((*arg-tests* ()) + (*user-lets* ()) + (*system-lets* ()) + (*ignorable-vars* ())) + (multiple-value-bind + (env-arg-used minimum maximum) + (parse-defmacro-lambda-list lambda-list arg-list-name name + error-kind error-fun (not annonymousp) + nil env-arg-name) + (values + `(let* ,(nreverse *system-lets*) + ,@(when *ignorable-vars* + `((declare (ignorable ,@*ignorable-vars*)))) + ,@*arg-tests* + (let* ,(nreverse *user-lets*) + ,@declarations + ,@body)) + `(,@(when (and env-arg-name (not env-arg-used)) + `((declare (ignore ,env-arg-name))))) + documentation + minimum + maximum))))) + +(defun make-keyword (symbol) + "Takes a non-keyword symbol, symbol, and returns the corresponding keyword." + (intern (symbol-name symbol) (find-package "KEYWORD"))) + +(defun verify-keywords (key-list valid-keys allow-other-keys) + (do ((already-processed nil) + (unknown-keyword nil) + (remaining key-list (cddr remaining))) + ((null remaining) + (if (and unknown-keyword + (not allow-other-keys) + (not (lookup-keyword :allow-other-keys key-list))) + (values :unknown-keyword (list unknown-keyword valid-keys)) + (values nil nil))) + (cond ((not (and (consp remaining) (listp (cdr remaining)))) + (return (values :dotted-list key-list))) + ((null (cdr remaining)) + (return (values :odd-length key-list))) + #+nil ;; Not ANSI compliant to disallow duplicate keywords. + ((member (car remaining) already-processed) + (return (values :duplicate (car remaining)))) + ((or (eq (car remaining) :allow-other-keys) + (member (car remaining) valid-keys)) + (push (car remaining) already-processed)) + (t + (setf unknown-keyword (car remaining)))))) + +(defun lookup-keyword (keyword key-list) + (do ((remaining key-list (cddr remaining))) + ((endp remaining)) + (when (eq keyword (car remaining)) + (return (cadr remaining))))) +;;; +(defun keyword-supplied-p (keyword key-list) + (do ((remaining key-list (cddr remaining))) + ((endp remaining)) + (when (eq keyword (car remaining)) + (return t)))) + + + +;(defun make-keyword (a) +; (error "Need to write make-keyword ~S" a)) + +;(defun defmacro-error (a b c) +; (error "Need to write defmacro-error ~S ~S ~S" a b c)) + +(defun parse-defmacro-lambda-list + (lambda-list arg-list-name name error-kind error-fun + &optional top-level env-illegal env-arg-name) + (let ((path (if top-level `(cdr ,arg-list-name) arg-list-name)) + (now-processing :required) + (maximum 0) + (minimum 0) + (keys ()) + rest-name restp allow-other-keys-p env-arg-used) + ;; This really strange way to test for '&whole is neccessary because member + ;; does not have to work on dotted lists, and dotted lists are legal + ;; in lambda-lists. + (when (and (do ((list lambda-list (cdr list))) + ((atom list) nil) + (when (eq (car list) '&whole) (return t))) + (not (eq (car lambda-list) '&whole))) + (error "&Whole must appear first in ~S lambda-list." error-kind)) + (do ((rest-of-args lambda-list (cdr rest-of-args))) + ((atom rest-of-args) + (cond ((null rest-of-args) nil) + ;; Varlist is dotted, treat as &rest arg and exit. + (t (push-let-binding rest-of-args path nil) + (setf restp t)))) + (let ((var (car rest-of-args))) + (cond ((eq var '&whole) + (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args))) + (setf rest-of-args (cdr rest-of-args)) + (push-let-binding (car rest-of-args) arg-list-name nil)) + (t (error "Bad &WHOLE")))) + ((eq var '&environment) + (cond (env-illegal + (error "&Environment not valid with ~S." error-kind)) + ((not top-level) + (error "&Environment only valid at top level of ~ + lambda-list."))) + (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args))) + (setf rest-of-args (cdr rest-of-args)) + (push-let-binding (car rest-of-args) env-arg-name nil) + (setf env-arg-used t)) + (t (error "Bad &ENVIRONMENT")))) + ((or (eq var '&rest) (eq var '&body)) + (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args))) + (setf rest-of-args (cdr rest-of-args)) + (setf restp t) + (push-let-binding (car rest-of-args) path nil)) + ;; + ;; This branch implements an incompatible extension to + ;; Common Lisp. In place of a symbol following &body, + ;; there may be a list of up to three elements which will + ;; be bound to the body, declarations, and doc-string of + ;; the body. + ((and (cdr rest-of-args) + (consp (cadr rest-of-args)) + (symbolp (caadr rest-of-args))) + (setf rest-of-args (cdr rest-of-args)) + (setf restp t) + (let ((body-name (caar rest-of-args)) + (declarations-name (cadar rest-of-args)) + (doc-string-name (caddar rest-of-args)) + (parse-body-values (gensym))) + (push-let-binding + parse-body-values + `(multiple-value-list + (parse-body ,path ,env-arg-name + ,(not (null doc-string-name)))) + t) + (setf env-arg-used t) + (when body-name + (push-let-binding body-name + `(car ,parse-body-values) nil)) + (when declarations-name + (push-let-binding declarations-name + `(cadr ,parse-body-values) nil)) + (when doc-string-name + (push-let-binding doc-string-name + `(caddr ,parse-body-values) nil)))) + (t (error "Bad lambda list")))) + ((eq var '&optional) + (setf now-processing :optionals)) + ((eq var '&key) + (setf now-processing :keywords) + (setf rest-name (gensym "KEYWORDS-")) + (push rest-name *ignorable-vars*) + (setf restp t) + (push-let-binding rest-name path t)) + ((eq var '&allow-other-keys) + (setf allow-other-keys-p t)) + ((eq var '&aux) + (setf now-processing :auxs)) + ((listp var) + (case now-processing + (:required + (let ((sub-list-name (gensym "SUBLIST-"))) + (push-sub-list-binding sub-list-name `(car ,path) var + name error-kind error-fun) + (parse-defmacro-lambda-list var sub-list-name name + error-kind error-fun)) + (setf path `(cdr ,path)) + (incf minimum) + (incf maximum)) + (:optionals + (when (> (length var) 3) + (cerror "Ignore extra noise." + "More than variable, initform, and suppliedp ~ + in &optional binding - ~S" + var)) + (push-optional-binding (car var) (cadr var) (caddr var) + `(not (null ,path)) `(car ,path) + name error-kind error-fun) + (setf path `(cdr ,path)) + (incf maximum)) + (:keywords + (let* ((keyword-given (consp (car var))) + (variable (if keyword-given + (cadar var) + (car var))) + (keyword (if keyword-given + (caar var) + (make-keyword variable))) + (supplied-p (caddr var))) + (push-optional-binding variable (cadr var) supplied-p + `(keyword-supplied-p ',keyword + ,rest-name) + `(lookup-keyword ',keyword + ,rest-name) + name error-kind error-fun) + (push keyword keys))) + (:auxs (push-let-binding (car var) (cadr var) nil)))) + ((symbolp var) + (case now-processing + (:required + (incf minimum) + (incf maximum) + (push-let-binding var `(car ,path) nil) + (setf path `(cdr ,path))) + (:optionals + (incf maximum) + (push-let-binding var `(car ,path) nil `(not (null ,path))) + (setf path `(cdr ,path))) + (:keywords + (let ((key (make-keyword var))) + (push-let-binding var `(lookup-keyword ,key ,rest-name) + nil) + (push key keys))) + (:auxs + (push-let-binding var nil nil)))) + (t + (error "Non-symbol in lambda-list - ~S." var))))) + ;; Generate code to check the number of arguments, unless dotted + ;; in which case length will not work. + (unless restp + (push `(unless (<= ,minimum + (length (the list ,(if top-level + `(cdr ,arg-list-name) + arg-list-name))) + ,@(unless restp + (list maximum))) + ,(let ((arg (if top-level + `(cdr ,arg-list-name) + arg-list-name))) + (if (eq error-fun 'error) + `(do-arg-count-error ',error-kind ',name ,arg + ',lambda-list ,minimum + ,(unless restp maximum)) + `(,error-fun 'defmacro-ll-arg-count-error + :kind ',error-kind + ,@(when name `(:name ',name)) + :argument ,arg + :lambda-list ',lambda-list + :minimum ,minimum + ,@(unless restp `(:maximum ,maximum)))))) + *arg-tests*)) + (if keys + (let ((problem (gensym "KEY-PROBLEM-")) + (info (gensym "INFO-"))) + (push `(multiple-value-bind + (,problem ,info) + (verify-keywords ,rest-name ',keys ',allow-other-keys-p) + (when ,problem + (,error-fun + 'defmacro-ll-broken-key-list-error + :kind ',error-kind + ,@(when name `(:name ',name)) + :problem ,problem + :info ,info))) + *arg-tests*))) + (values env-arg-used minimum (if (null restp) maximum nil)))) + + +(defun push-sub-list-binding (variable path object name error-kind error-fun) + (let ((var (gensym "TEMP-"))) + (push `(,variable + (let ((,var ,path)) + (if (listp ,var) + ,var + (,error-fun 'defmacro-bogus-sublist-error + :kind ',error-kind + ,@(when name `(:name ',name)) + :object ,var + :lambda-list ',object)))) + *system-lets*))) + +(defun push-let-binding (variable path systemp &optional condition + (init-form *default-default*)) + (let ((let-form (if condition + `(,variable (if ,condition ,path ,init-form)) + `(,variable ,path)))) + (if systemp + (push let-form *system-lets*) + (push let-form *user-lets*)))) + +(defun push-optional-binding (value-var init-form supplied-var condition path + name error-kind error-fun) + (unless supplied-var + (setf supplied-var (gensym "SUPLIEDP-"))) + (push-let-binding supplied-var condition t) + (cond ((consp value-var) + (let ((whole-thing (gensym "OPTIONAL-SUBLIST-"))) + (push-sub-list-binding whole-thing + `(if ,supplied-var ,path ,init-form) + value-var name error-kind error-fun) + (parse-defmacro-lambda-list value-var whole-thing name + error-kind error-fun))) + ((symbolp value-var) + (push-let-binding value-var path nil supplied-var init-form)) + (t + (error "Illegal optional variable name: ~S" value-var)))) + +;;;; From macros.lisp + +;;; Parse-Body -- Public +;;; +;;; Parse out declarations and doc strings, *not* expanding macros. +;;; Eventually the environment arg should be flushed, since macros can't expand +;;; into declarations anymore. +;;; +(defun parse-body (body environment &optional (doc-string-allowed t)) + "This function is to parse the declarations and doc-string out of the body of + a defun-like form. Body is the list of stuff which is to be parsed. + Environment is ignored. If Doc-String-Allowed is true, then a doc string + will be parsed out of the body and returned. If it is false then a string + will terminate the search for declarations. Three values are returned: the + tail of Body after the declarations and doc strings, a list of declare forms, + and the doc-string, or NIL if none." + (declare (ignore environment)) + (let ((decls ()) + (doc nil)) + (do ((tail body (cdr tail))) + ((endp tail) + (values tail (nreverse decls) doc)) + (let ((form (car tail))) + (cond ((and (stringp form) (cdr tail)) + (if doc-string-allowed + (setq doc form + ;; Only one doc string is allowed. + doc-string-allowed nil) + (return (values tail (nreverse decls) doc)))) + ((not (and (consp form) (symbolp (car form)))) + (return (values tail (nreverse decls) doc))) + ((eq (car form) 'declare) + (push form decls)) + (t + (return (values tail (nreverse decls) doc)))))))) + +;;;; Destructuring-bind + +(defmacro destructuring-bind (lambda-list arg-list &rest body) + "Bind the variables in LAMBDA-LIST to the contents of ARG-LIST." + (let* ((arg-list-name (gensym "ARG-LIST-"))) + (multiple-value-bind + (body local-decls) + (parse-defmacro lambda-list arg-list-name body nil 'destructuring-bind + :annonymousp t :doc-string-allowed nil) + `(let ((,arg-list-name ,arg-list)) + ,@local-decls + ,body)))) + diff --git a/lsp/gcl_doc-file.lsp b/lsp/gcl_doc-file.lsp new file mode 100755 index 0000000..7693a53 --- /dev/null +++ b/lsp/gcl_doc-file.lsp @@ -0,0 +1,24 @@ +(defun doc-file (file packages) +;;Write FILE of doc strings for all symbols in PACKAGES +;;This file is suitable for use with the find-doc function. + #+kcl + (and (member 'lisp packages) + (not (documentation 'setq 'function)) + (load (format nil "~a../lsp/setdoc.lsp" si::*system-directory*))) + (with-open-file (st file :direction :output) + (sloop:sloop + for v in packages + do (setq v (if (packagep v) (package-name v) v)) + do (sloop:sloop + for w in-package v + when (setq doc (documentation w 'function)) + do (format st "F~a~%~ain ~a package:~a" w + (cond ((special-form-p w) "Special Form ") + ((functionp w) "Function ") + ((macro-function w) "Macro ") + (t "")) + v + doc) + when (setq doc (documentation w 'variable)) + do (format st "V~a~%Variable in ~a package:~a" w v doc) + )))) diff --git a/lsp/gcl_evalmacros.lsp b/lsp/gcl_evalmacros.lsp new file mode 100755 index 0000000..dc824f0 --- /dev/null +++ b/lsp/gcl_evalmacros.lsp @@ -0,0 +1,389 @@ +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +;;;; evalmacros.lsp + + +(in-package "LISP") + +(export '(defvar defparameter defconstant)) + +(in-package "SYSTEM") + + +(eval-when (compile) (proclaim '(optimize (safety 2) (space 3)))) +;(eval-when (eval compile) (defun si:clear-compiler-properties (symbol))) +(eval-when (eval compile) (setq si:*inhibit-macro-special* nil)) + +(defmacro sgen (&optional (pref "G")) + `(load-time-value (gensym ,pref))) + + +(defmacro defvar (var &optional (form nil form-sp) doc-string) + `(progn (si:*make-special ',var) + ,(if doc-string + `(si:putprop ',var ,doc-string 'variable-documentation)) + ,(if form-sp + `(or (boundp ',var) + (setq ,var ,form))) + ',var) + ) + +(defmacro defparameter (var form &optional doc-string) + (if doc-string + `(progn (si:*make-special ',var) + (si:putprop ',var ,doc-string 'variable-documentation) + (setq ,var ,form) + ',var) + `(progn (si:*make-special ',var) + (setq ,var ,form) + ',var))) + +(defmacro defconstant (var form &optional doc-string) + (if doc-string + `(progn (si:*make-constant ',var ,form) + (si:putprop ',var ,doc-string 'variable-documentation) + ',var) + `(progn (si:*make-constant ',var ,form) + ',var))) + + +;;; Each of the following macros is also defined as a special form. +;;; Thus their names need not be exported. + +(defmacro and (&rest forms) + (if (endp forms) + t + (let ((x (reverse forms))) + (do ((forms (cdr x) (cdr forms)) + (form (car x) `(if ,(car forms) ,form))) + ((endp forms) form)))) + ) + +(defmacro or (&rest forms) + (if (endp forms) + nil + (let ((x (reverse forms))) + (do ((forms (cdr x) (cdr forms)) + (form (car x) + (let ((temp (gensym))) + `(let ((,temp ,(car forms))) + (if ,temp ,temp ,form))))) + ((endp forms) form)))) + ) + +(defun parse-body-header (x &optional doc decl ctps &aux (a (car x))) + (cond + ((unless (or doc ctps) (and (stringp a) (cdr x))) (parse-body-header (cdr x) a decl ctps)) + ((unless ctps (when (consp a) (eq (car a) 'declare))) (parse-body-header (cdr x) doc (cons a decl) ctps)) + ((when (consp a) (eq (car a) 'check-type)) (parse-body-header (cdr x) doc decl (cons a ctps))) + (t (values doc (nreverse decl) (nreverse ctps) x)))) + +(defmacro locally (&rest body) + (multiple-value-bind + (doc decls ctps body) + (parse-body-header body) + `(let (,@(mapcan (lambda (x &aux (z (pop x))(z (if (eq z 'type) (pop x) z))) + (case z + ((ftype inline notinline optimize) nil) + (otherwise (mapcar (lambda (x) (list x x)) x)))) + (apply 'append (mapcar 'cdr decls)))) + ,@(when doc (list doc)) + ,@decls + ,@ctps + ,@body))) + +(defmacro loop (&rest body &aux (tag (gensym))) + `(block nil (tagbody ,tag (progn ,@body) (go ,tag)))) + +(import 'while 'user) +(defmacro while (test &rest forms) + `(loop (unless ,test (return)) ,@forms) ) + +(defmacro defmacro (name vl &rest body) + `(si:define-macro ',name (si:defmacro* ',name ',vl ',body))) + +(defmacro defun (name lambda-list &rest body) + (multiple-value-bind (doc decl body) + (find-doc body nil) + (if doc + `(progn (setf (get ',name 'si:function-documentation) ,doc) + (setf (symbol-function ',name) + #'(lambda ,lambda-list + ,@decl (block ,name ,@body))) + ',name) + `(progn (setf (symbol-function ',name) + #'(lambda ,lambda-list + ,@decl (block ,name ,@body))) + ',name)))) + +; assignment + +(defmacro psetq (&rest args) + (do ((l args (cddr l)) + (forms nil) + (bindings nil)) + ((endp l) (list* 'let* (nreverse bindings) (nreverse (cons nil forms)))) + (declare (object l)) + (let ((sym (gensym))) + (push (list sym (cadr l)) bindings) + (push (list 'setq (car l) sym) forms))) + ) + +; conditionals + +(defmacro cond (&rest clauses &aux (form nil)) + (let ((x (reverse clauses))) + (dolist (l x form) + (cond ((endp (cdr l)) + (if (or (constantp (car l)) (eq l (car x))) + (setq form (car l)) + (let ((sym (gensym))) + (setq form `(let ((,sym ,(car l))) (if ,sym ,sym ,form)))))) + ((and (constantp (car l)) (car l)) + (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)))))))) + + +(defmacro when (pred &rest body) + `(if ,pred (progn ,@body))) + +(defmacro unless (pred &rest body) + `(if (not ,pred) (progn ,@body))) + +; program feature + +(defmacro prog (vl &rest body &aux (decl nil)) + (do () + ((or (endp body) + (not (consp (car body))) + (not (eq (caar body) 'declare))) + `(block nil (let ,vl ,@decl (tagbody ,@body))) + ) + (push (car body) decl) + (pop body)) + ) + +(defmacro prog* (vl &rest body &aux (decl nil)) + (do () + ((or (endp body) + (not (consp (car body))) + (not (eq (caar body) 'declare))) + `(block nil (let* ,vl ,@decl (tagbody ,@body))) + ) + (push (car body) decl) + (pop body)) + ) + +; sequencing + +(defmacro prog1 (first &rest body &aux (sym (gensym))) + `(let ((,sym ,first)) ,@body ,sym)) + +(defmacro prog2 (first second &rest body &aux (sym (gensym))) + `(progn ,first (let ((,sym ,second)) ,@body ,sym))) + +; multiple values + +(defmacro multiple-value-list (form) + `(multiple-value-call 'list ,form)) + +(defmacro multiple-value-setq (vars form) + (do ((vl vars (cdr vl)) + (sym (gensym)) + (forms nil) + (n 0 (1+ n))) + ((endp vl) `(let ((,sym (multiple-value-list ,form))) ,@forms)) + (declare (fixnum n) (object vl)) + (push `(setq ,(car vl) (nth ,n ,sym)) forms)) + ) + +(defmacro multiple-value-bind (vars form &rest body) + (do ((vl vars (cdr vl)) + (sym (gensym)) + (bind nil) + (n 0 (1+ n))) + ((endp vl) `(let* ((,sym (multiple-value-list ,form)) ,@(nreverse bind)) + ,@body)) + (declare (fixnum n) (object vl)) + (push `(,(car vl) (nth ,n ,sym)) bind)) + ) + +(defmacro do (control (test . result) &rest body + &aux (decl nil) (label (gensym)) (vl nil) (step nil)) + (do () + ((or (endp body) + (not (consp (car body))) + (not (eq (caar body) 'declare)))) + (push (car body) decl) + (pop body)) + (dolist (c control) + (declare (object c)) + (if(symbolp c) (setq c (list c))) + (push (list (car c) (cadr c)) vl) + (unless (endp (cddr c)) + (push (car c) step) + (push (caddr c) step))) + `(block nil + (let ,(nreverse vl) + ,@decl + (tagbody + ,label (if ,test (return (progn ,@result))) + (tagbody ,@body) + (psetq ,@(nreverse step)) + (go ,label))))) + +(defmacro do* (control (test . result) &rest body + &aux (decl nil) (label (gensym)) (vl nil) (step nil)) + (do () + ((or (endp body) + (not (consp (car body))) + (not (eq (caar body) 'declare)))) + (push (car body) decl) + (pop body)) + (dolist (c control) + (declare (object c)) + (if(symbolp c) (setq c (list c))) + (push (list (car c) (cadr c)) vl) + (unless (endp (cddr c)) + (push (car c) step) + (push (caddr c) step))) + `(block nil + (let* ,(nreverse vl) + ,@decl + (tagbody + ,label (if ,test (return (progn ,@result))) + (tagbody ,@body) + (setq ,@(nreverse step)) + (go ,label)))) + ) + +(defmacro case (keyform &rest clauses &aux (key (load-time-value (gensym "CASE"))) (c (reverse clauses))) + (declare (optimize (safety 2))) + (labels ((sw (x) `(eql ,key ',x))(dfp (x) (or (eq x t) (eq x 'otherwise))) + (v (x) (if (when (listp x) (not (cdr x))) (car x) x)) + (m (x c &aux (v (v x))) (if (eq v x) (cons c v) v))) + `(let ((,key ,keyform)) + (declare (ignorable ,key)) + ,(let ((df (when (dfp (caar c)) (m (cdr (pop c)) 'progn)))) + (reduce (lambda (y c &aux (a (pop c))(v (v a))) + (when (dfp a) (error "default case must be last")) + `(if ,(if (when (eq a v) (listp v)) (m (mapcar #'sw v) 'or) (sw v)) ,(m c 'progn) ,y)) + c :initial-value df))))) + +(defmacro ecase (keyform &rest clauses &aux (key (sgen "ECASE"))) + (declare (optimize (safety 2))) + `(let ((,key ,keyform)) + (declare (ignorable ,key)) + (case ,key + ,@(mapcar (lambda (x) (if (member (car x) '(t otherwise)) (cons (list (car x)) (cdr x)) x)) clauses) + (otherwise + (error 'type-error :datum ,key + :expected-type '(member ,@(apply 'append (mapcar (lambda (x &aux (x (car x))) (if (listp x) x (list x))) clauses)))))))) + + +(defmacro ccase (keyform &rest clauses &aux (key (sgen "CCASE"))) + (declare (optimize (safety 2))) + `(let ((,key ,keyform)) + (declare (ignorable ,key)) + (do nil (nil) + (case ,key + ,@(mapcar (lambda (x &aux (k (pop x))) + `(,(if (member k '(t otherwise)) (list k) k) (return ,(if (cdr x) (cons 'progn x) (car x))))) clauses) + (otherwise + (check-type ,key (member ,@(apply 'append (mapcar (lambda (x &aux (x (car x))) (if (listp x) x (list x))) clauses))))))))) + +(defmacro return (&optional (val nil)) `(return-from nil ,val)) + +(defmacro dolist ((var form &optional (val nil)) &rest body + &aux (temp (gensym))) + `(do* ((,temp ,form (cdr ,temp)) (,var (car ,temp) (car ,temp))) + ((endp ,temp) ,val) + ,@body)) + +;; In principle, a more complete job could be done here by trying to +;; capture fixnum type declarations from the surrounding context or +;; environment, or from within the compiler's internal structures at +;; compile time. See gcl-devel archives for examples. This +;; implementation relies on the fact that the gcc optimizer will +;; eliminate the bignum branch if the supplied form is a symbol +;; declared to be fixnum, as the comparison of a long integer variable +;; with most-positive-fixnum is then vacuous. Care must be taken in +;; making comparisons with most-negative-fixnum, as the C environment +;; appears to treat this as positive or negative depending on the sign +;; of the other argument in the comparison, apparently to symmetrize +;; the long integer range. 20040403 CM. +(defmacro dotimes ((var form &optional (val nil)) &rest body) + (cond + ((symbolp form) + (let ((temp (gensym))) + `(cond ((< ,form 0) + (let ((,var 0)) + (declare (fixnum ,var) (ignorable ,var)) + ,val)) + ((<= ,form most-positive-fixnum) + (let ((,temp ,form)) + (declare (fixnum ,temp)) + (do* ((,var 0 (1+ ,var))) ((>= ,var ,temp) ,val) + (declare (fixnum ,var)) + ,@body))) + (t + (let ((,temp ,form)) + (do* ((,var 0 (1+ ,var))) ((>= ,var ,temp) ,val) + ,@body)))))) + ((constantp form) + (cond ((< form 0) + `(let ((,var 0)) + (declare (fixnum ,var) (ignorable ,var)) + ,val)) + ((<= form most-positive-fixnum) + `(do* ((,var 0 (1+ ,var))) ((>= ,var ,form) ,val) + (declare (fixnum ,var)) + ,@body)) + (t + `(do* ((,var 0 (1+ ,var))) ((>= ,var ,form) ,val) + ,@body)))) + (t + (let ((temp (gensym))) + `(let ((,temp ,form)) + (cond ((< ,temp 0) + (let ((,var 0)) + (declare (fixnum ,var) (ignorable ,var)) + ,val)) + ((<= ,temp most-positive-fixnum) + (let ((,temp ,temp)) + (declare (fixnum ,temp)) + (do* ((,var 0 (1+ ,var))) ((>= ,var ,temp) ,val) + (declare (fixnum ,var)) + ,@body))) + (t + (do* ((,var 0 (1+ ,var))) ((>= ,var ,temp) ,val) + ,@body)))))))) + + +(defmacro declaim (&rest l) + `(eval-when (compile eval load) + ,@(mapcar #'(lambda (x) `(proclaim ',x)) l))) + +(defmacro lambda ( &rest l) `(function (lambda ,@l))) + +(defun compiler-macro-function (name) + (get name 'compiler-macro-prop)) diff --git a/lsp/gcl_export.lsp b/lsp/gcl_export.lsp new file mode 100755 index 0000000..def2165 --- /dev/null +++ b/lsp/gcl_export.lsp @@ -0,0 +1,333 @@ +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +;;;; export.lsp +;;;; +;;;; Exporting external symbols of LISP package + + +(in-package 'lisp) + + +(export '( + +&whole +&environment +&body +* +** +*** +*break-enable* +*break-on-warnings* +*features* +*modules* ++ +++ ++++ +- +/ +// +/// +COMMON +KYOTO +KCL +abs +acos +acosh +adjust-array +adjustable-array-p +apropos +apropos-list +array-dimension +array-dimensions +array-element-type +array-has-fill-pointer-p +array-in-bounds-p +array-rank +array-row-major-index +asin +asinh +assert +atanh +bit +bit-and +bit-andc1 +bit-andc2 +bit-eqv +bit-ior +bit-nand +bit-nor +bit-not +bit-orc1 +bit-orc2 +bit-xor +break +byte +byte-position +byte-size +ccase +cerror +check-type +cis +coerce +compile +compile-file +concatenate +cosh +count +count-if +count-if-not +ctypecase +decf +declaim +decode-universal-time +defconstant +define-modify-macro +define-setf-method +defparameter +defsetf +defstruct +deftype +defvar +delete +delete-duplicates +delete-if +delete-if-not +deposit-field +describe +disassemble +do* +do-all-symbols +do-external-symbols +do-symbols +documentation +dolist +dotimes +dpb +dribble +ecase +ed +eighth +encode-universal-time +error +etypecase +eval-when +every +fceiling +ffloor +fifth +fill +fill-pointer +find +find-all-symbols +find-if +find-if-not +first +format +fourth +fround +ftruncate +get-decoded-time +get-setf-method +get-setf-method-multiple-value +get-universal-time +getf +ignore +ignorable +incf +inspect +intersection +isqrt +ldb +ldb-test +lisp-implementation-type +logandc1 +logandc2 +lognand +lognor +lognot +logorc1 +logorc2 +logtest +long-site-name +machine-instance +machine-type +machine-version +make-array +make-sequence +map +mask-field +merge +mismatch +mod +multiple-value-setq +nintersection +ninth +notany +notevery +nset-difference +nset-exclusive-or +nsubstitute +nsubstitute-if +nsubstitute-if-not +nunion +phase +pop +position +position-if +position-if-not +prin1-to-string +princ-to-string +prog* +provide +psetf +push +pushnew +rational +rationalize +real +read-from-string +reduce +rem +remf +remove +remove-duplicates +remove-if +remove-if-not +replace +require +rotatef +room +sbit +search +second +set-difference +set-exclusive-or +setf +seventh +shiftf +short-site-name +signum +sinh +sixth +software-type +software-version +some +sort +stable-sort +step +structure +subsetp +substitute +substitute-if +substitute-if-not +subtypep +tanh +tenth +third +time +trace +type +typecase +typep +union +untrace +variable +vector +vector-pop +vector-push +vector-push-extend +warn +with-input-from-string +with-open-file +with-open-stream +with-output-to-string +write-to-string +y-or-n-p +yes-or-no-p + +proclaim +proclamation +special +type +ftype +function +inline +notinline +ignore +optimize +speed +space +safety +compilation-speed +declaration + +*eval-when-compile* + +clines +defcfun +defentry +defla + +void +object +char +int +float +double + +define-compiler-macro +compiler-macro +compiler-macro-function + +with-compilation-unit +with-standard-io-syntax +*print-lines* +*print-miser-width* +*print-pprint-dispatch* +*print-right-margin* + +*read-eval* + +dynamic-extent + +loop +check-type assert typecase etypecase ctypecase case ecase ccase + +restart-bind restart-case with-condition-restarts muffle-warning continue abort + store-value use-value + restart restart-name restart-function restart-report-function + restart-interactive-function restart-test-function + compute-restarts find-restart invoke-restart invoke-restart-interactively + with-simple-restart signal + +simple-condition simple-error simple-warning invoke-debugger *debugger-hook* *break-on-signals* + +handler-case handler-bind ignore-errors define-condition make-condition + condition warning serious-condition simple-condition-format-control simple-condition-format-arguments + storage-condition stack-overflow storage-exhausted type-error + type-error-datum type-error-expected-type simple-type-error + program-error control-error stream-error stream-error-stream + end-of-file file-error file-error-pathname cell-error cell-error-name + unbound-variable undefined-function arithmetic-error + arithmetic-error-operation arithmetic-error-operands + package-error package-error-package + division-by-zero floating-point-overflow floating-point-underflow + +)) diff --git a/lsp/gcl_fdecl.lsp b/lsp/gcl_fdecl.lsp new file mode 100755 index 0000000..a10a7f9 --- /dev/null +++ b/lsp/gcl_fdecl.lsp @@ -0,0 +1,93 @@ +(in-package 'si) + +;; by William F. Schelter + +;; Conveniently and economically make operators which declare the type +;; and result of numerical operations. For example (def-op f+ fixnum +) +;; defines a macro f+ which will give optimal code for calling + on +;; several fixnum args expecting a fixnum result. + +;; Details: +;; Note these will be macros and cannot be `funcalled'. If you add the +;; feature :debug, then code to check the types of the arguments and +;; result will be inserted, and generic operations will be used. This is +;; useful for checking that you did not insert the wrong type +;; declarations. The code will continue running if *dbreak* is nil, +;; returning the correct result but printing out the type mismatch, as +;; well as the actual args given so that you may more easily locate the +;; bad call in the editor. + +;; It is economical, beause all the macros defined are just variations +;; of one closure, and so code is not duplicated. + +;; Sample usage (with :debug in *features*): +;; The call will generate warning messages if the args or result are bad. + +;; (defun foo (x a) (f+ (* 2 x) a)) +;; SYSTEM>(foo 7.0 9) + +;; Bad call (F+ (* 2 X) A) types:(LONG-FLOAT FIXNUM) +;; 23.0 + +;; Without debug (f+ a b c) becomes +;; (the fixnum (+ (the fixnum a) (the fixnum +;; (+ (the fixnum b) (the fixnum c))))) +;; which is painful to write by hand, but which will give the best code. + + +(defmacro def-op (name type op &optional return-type) + `(setf (macro-function ',name) (make-operation ',type ',op + ',return-type))) + +(defun make-operation (.type .op .return) + (or .return (setf .return .type)) + #'(lambda (bod env) env + (sloop for v in (cdr bod) + when (eq t .type) collect v into body + else + collect `(the , .type ,v) into body + finally (setq body `(, .op ,@ body)) + (return + (if (eq t .return) body + `(the , .return ,body)))))) + +#+debug +(progn + ;; Enable this to insert type error checking code. +(defvar *dbreak* t) +(defun callchk-type (lis old na typ sho return-type &aux result) + (setq result (apply old lis)) + (or (and (sloop for v in lis + always (typep v typ)) + (or (null return-type) (typep result return-type))) + (format t "~%Bad call ~a types:~a" (cons na sho) + (sloop:sloop for v in lis collect (type-of v))) + (and *dbreak* (break "hi"))) + result) + +;; debug version: +(defmacro def-op (name type old &optional return-type) + `(defmacro ,name (&rest l) + `(callchk-type (list ,@ l) ',',old ',',name ',',type ',l ',',return-type + ))) +) + +(def-op f+ fixnum +) +(def-op f* fixnum *) +(def-op f- fixnum -) +(def-op +$ double-float +) +(def-op *$ double-float *) +(def-op -$ double-float -) +(def-op 1-$ double-float 1-) +(def-op 1+$ double-float 1+) +(def-op f1- fixnum 1-) +(def-op f1+ fixnum 1+) +(def-op //$ double-float quot) +(def-op ^ fixnum expt) +(def-op ^$ double-float expt) +(def-op f> fixnum > t) +(def-op f< fixnum < t) +(def-op f= fixnum = t) +(def-op lsh fixnum ash) +(def-op fixnum-remainder fixnum rem) + diff --git a/lsp/gcl_fpe.lsp b/lsp/gcl_fpe.lsp new file mode 100644 index 0000000..44a37c3 --- /dev/null +++ b/lsp/gcl_fpe.lsp @@ -0,0 +1,147 @@ +(in-package :fpe :use '(:lisp)) + +(import 'si::(disassemble-instruction feenableexcept fedisableexcept fld *fixnum *float *double + +fe-list+ +mc-context-offsets+ floating-point-error + function-by-address)) +(export '(break-on-floating-point-exceptions read-instruction)) + +(eval-when + (eval compile) + + (defconstant +feallexcept+ (reduce 'logior (mapcar 'caddr +fe-list+))) + + + (defun moff (i r) (* i (cdr r))) + + (defun stl (s &aux (s (if (stringp s) (make-string-input-stream s) s))(x (read s nil 'eof))) + (unless (eq x 'eof) (cons x (stl s)))) + + (defun ml (r) (when r (make-list (truncate (car r) (cdr r))))) + + (defun mcgr (r &aux (i -1)) + (mapcar (lambda (x y) `(defconstant ,x ,(moff (incf i) r))) (when r (stl (pop r))) (ml r))) + + (defun mcr (p r &aux (i -1)) + (mapcar (lambda (x) `(defconstant ,(intern (concatenate 'string p (write-to-string (incf i))) :fpe) ,(moff i r))) + (ml r))) + + (defmacro deft (n rt args &rest code) + `(progn + (clines ,(nstring-downcase + (apply 'concatenate 'string + (symbol-name rt) " " (symbol-name n) "(" + (apply 'concatenate 'string + (mapcon (lambda (x) (list* (symbol-name (caar x)) " " (symbol-name (cadar x)) + (when (cdr x) (list ", ")))) args)) + ") " + code))) + (defentry ,n ,(mapcar 'car args) (,rt ,(string-downcase (symbol-name n))))))) + +#.`(progn ,@(mcgr (first +mc-context-offsets+))) +#.`(progn ,@(mcr "ST" (second +mc-context-offsets+))) +#.`(progn ,@(mcr "XMM" (third +mc-context-offsets+))) + + +(defconstant +top-readtable+ (let ((*readtable* (copy-readtable))) + (set-syntax-from-char #\, #\Space) + (set-syntax-from-char #\; #\a) + (set-macro-character #\0 '0-reader) + (set-macro-character #\$ '0-reader) + (set-macro-character #\- '0-reader) + (set-macro-character #\% '%-reader) + (set-macro-character #\( 'paren-reader) + *readtable*)) +(defconstant +sub-readtable+ (let ((*readtable* (copy-readtable +top-readtable+))) + (set-syntax-from-char #\0 #\a) + *readtable*)) +(defvar *offset* 0) +(defvar *insn* nil) +(defvar *context* nil) + + +(defun rf (addr w) + (ecase w (4 (*float addr)) (8 (*double addr)))) + +(defun ref (addr p w &aux (i -1)) + (if p + (map-into (make-list (truncate 16 w)) (lambda nil (rf (+ addr (* w (incf i))) w))) + (rf addr w))) + +(defun gref (addr &aux (z (symbol-name *insn*))(lz (length z))(lz (if (eql (aref z (- lz 3)) #\2) (- lz 3) lz)) + (f (eql #\F (aref z 0)))) + (ref addr (unless f (eql (aref z (- lz 2)) #\P)) (if (or f (eql (aref z (1- lz)) #\D)) 8 4))) + +(defun reg-lookup (x) (*fixnum (+ (car *context*) (symbol-value x)))) + +(defun st-lookup (x) (fld (+ (cadr *context*) (symbol-value x)))) +(defun xmm-lookup (x) (gref (+ (caddr *context*) (symbol-value x)))) + + +(defun lookup (x &aux (z (symbol-name x))) + (case (aref z 0) + (#\X (xmm-lookup x)) + (#\S (st-lookup x)) + (otherwise (reg-lookup x)))) + +(defun %-reader (stream subchar &aux (*readtable* +sub-readtable+)(*package* (find-package :fpe))) + (declare (ignore subchar)) + (let ((x (read stream))) + (lookup (if (eq x 'st) + (intern (concatenate 'string (symbol-name x) + (write-to-string + (if (eql (peek-char nil stream nil 'eof) #\() + (let ((ch (read-char stream))(x (read stream))(ch (read-char stream))) + (declare (ignore ch)) + x) + 0))) :fpe) x)))) + +(defun 0-reader (stream subchar &aux a (s 1)(*readtable* +sub-readtable+)) + + (when (eql subchar #\$) (setq a t subchar (read-char stream))) + (when (eql subchar #\-) (setq s -1 subchar (read-char stream))) + (assert (eql subchar #\0)) + (assert (eql (read-char stream) #\x)) + + (let* ((*read-base* 16)(x (* s (read stream)))) + (if a x (let ((*offset* x)) (read stream))))) + +(defun paren-reader (stream subchar &aux (*readtable* +sub-readtable+)) + (declare (ignore subchar)) + (let* ((x (read-delimited-list #\) stream))) + (gref (+ *offset* (pop x) (if x (* (pop x) (car x)) 0))))) + +(defun read-operands (s context &aux (*context* context)) + (read-delimited-list #\; s)) + +(defun read-instruction (addr context &aux (*readtable* +top-readtable+) + (i (car (disassemble-instruction addr)))(s (make-string-input-stream i)) + (*insn* (read s))) + (cons i (cons *insn* (when context (read-operands s context))))) + + +(defun fe-enable (a) + (declare (fixnum a)) + (fedisableexcept) + (feenableexcept a)) + + +#.`(let ((fpe-enabled 0)) + (defun break-on-floating-point-exceptions + (&key suspend ,@(mapcar (lambda (x) `(,(car x) (logtest ,(caddr x) fpe-enabled))) +fe-list+) &aux r) + (fe-enable + (if suspend 0 + (setq fpe-enabled + (logior + ,@(mapcar (lambda (x) + `(cond (,(car x) (push ,(intern (symbol-name (car x)) :keyword) r) ,(caddr x)) + (0))) +fe-list+))))) + r)) + +(defun floating-point-error (code addr context) + (break-on-floating-point-exceptions :suspend t) + (unwind-protect + (let* ((fun (function-by-address addr))(m (read-instruction addr context))) + ((lambda (&rest r) (apply 'error (if (find-package :conditions) r (list (format nil "~s" r))))) + (or (caar (member code +fe-list+ :key 'cadr)) 'arithmetic-error) + :operation (list :insn (pop m) :op (pop m) :fun fun :addr addr) :operands m)) + (break-on-floating-point-exceptions))) diff --git a/lsp/gcl_fpe_test.lsp b/lsp/gcl_fpe_test.lsp new file mode 100644 index 0000000..c0f225e --- /dev/null +++ b/lsp/gcl_fpe_test.lsp @@ -0,0 +1,212 @@ +#.`(defun test-fpe (f a r &optional chk &aux cc (o (mapcan (lambda (x) (list x t)) (si::break-on-floating-point-exceptions)))) + (flet ((set-break (x) (when (keywordp r) + (apply 'si::break-on-floating-point-exceptions (append (unless x o) (list r x)))))) + (let* ((rr (handler-case (unwind-protect (progn (set-break t) (apply f a)) (set-break nil)) + ,@(mapcar (lambda (x &aux (x (car x))) `(,x (c) (setq cc c) ,(intern (symbol-name x) :keyword))) + (append si::+fe-list+ '((arithmetic-error)(error))))))) + (print (list* f a r rr (when cc (list cc (arithmetic-error-operation cc) (arithmetic-error-operands cc))))) + (assert (eql r rr)) + (when (and chk cc) + (unless (eq 'fnop (cadr (member :op (arithmetic-error-operation cc)))) + (assert (eq (symbol-function f) (cadr (member :fun (arithmetic-error-operation cc))))) + (assert (or (every 'equalp (mapcar (lambda (x) (if (numberp x) x (coerce x 'list))) a) + (arithmetic-error-operands cc)) + (every 'equalp (nreverse (mapcar (lambda (x) (if (numberp x) x (coerce x 'list))) a)) + (arithmetic-error-operands cc))))))))) + +#+(or x86_64 i386) +(progn + (eval-when + (compile eval) + (defmacro deft (n rt args &rest code) + `(progn + (clines ,(nstring-downcase + (apply 'concatenate 'string + (symbol-name rt) " " (symbol-name n) "(" + (apply 'concatenate 'string + (mapcon (lambda (x) (list* (symbol-name (caar x)) " " (symbol-name (cadar x)) + (when (cdr x) (list ", ")))) args)) ") " code))) + (defentry ,n ,(mapcar 'car args) (,rt ,(string-downcase (symbol-name n))))))) + + (deft fdivp object ((object x) (object y)) + "{volatile double a=lf(x),b=lf(y),c;" + "__asm__ __volatile__ (\"fldl %1;fldl %0;fdivp %%st,%%st(1);fstpl %2;fwait\" " + ": \"=m\" (a), \"=m\" (b) : \"m\" (c));" + "return make_longfloat(c);}") + + (deft divpd object ((object x) (object y) (object z)) + "{__asm__ __volatile__ (\"movapd %0,%%xmm0;movapd %1,%%xmm1;divpd %%xmm0,%%xmm1;movapd %%xmm1,%2\" " + ": \"=m\" (*(char *)x->a.a_self), \"=m\" (*(char *)y->a.a_self) : \"m\" (*(char *)z->a.a_self));" + "return z;}") + + (deft divpdm object ((object x) (object y) (object z)) + "{__asm__ __volatile__ (\"movapd %1,%%xmm1;divpd %0,%%xmm1;movapd %%xmm1,%2\" " + ": \"=m\" (*(char *)x->a.a_self), \"=m\" (*(char *)y->a.a_self) : \"m\" (*(char *)z->a.a_self));" + "return z;}") + + (deft divps object ((object x) (object y) (object z)) + "{__asm__ __volatile__ (\"movaps %0,%%xmm0;movaps %1,%%xmm1;divps %%xmm0,%%xmm1;movaps %%xmm1,%2\" " + ": \"=m\" (*(char *)x->a.a_self), \"=m\" (*(char *)y->a.a_self) : \"m\" (*(char *)z->a.a_self));" + "return z;}") + + (deft divpsm object ((object x) (object y) (object z)) + "{__asm__ __volatile__ (\"movaps %1,%%xmm1;divps %0,%%xmm1;movaps %%xmm1,%2\" " + ": \"=m\" (*(char *)x->a.a_self), \"=m\" (*(char *)y->a.a_self) : \"m\" (*(char *)z->a.a_self));" + "return z;}") + + (deft divsd object ((object x) (object y)) + "{volatile double a=lf(x),b=lf(y),c;" + "__asm__ __volatile__ (\"movsd %0,%%xmm0;movsd %1,%%xmm1;divsd %%xmm1,%%xmm0;movsd %%xmm0,%2\" " + ": \"=m\" (a), \"=m\" (b) : \"m\" (c));" + "return make_longfloat(c);}") + + (deft divsdm object ((object x) (object y)) + "{volatile double a=lf(x),b=lf(y),c;" + "__asm__ __volatile__ (\"movsd %0,%%xmm0;divsd %1,%%xmm0;movsd %%xmm0,%2\" " + ": \"=m\" (a), \"=m\" (b) : \"m\" (c));" + "return make_longfloat(c);}") + + (deft divss object ((object x) (object y)) + "{volatile float a=sf(x),b=sf(y),c;" + "__asm__ __volatile__ (\"movss %0,%%xmm0;movss %1,%%xmm1;divss %%xmm1,%%xmm0;movss %%xmm0,%2\" " + ": \"=m\" (a), \"=m\" (b) : \"m\" (c));" + "return make_shortfloat(c);}") + + (deft divssm object ((object x) (object y)) + "{volatile float a=sf(x),b=sf(y),c;" + "__asm__ __volatile__ (\"movss %0,%%xmm0;divss %1,%%xmm0;movss %%xmm0,%2\" " + ": \"=m\" (a), \"=m\" (b) : \"m\" (c));" + "return make_shortfloat(c);}") + + (deft sqrtpd object ((object x) (object y) (object z)) + "{__asm__ __volatile__ (\"movapd %0,%%xmm0;movapd %1,%%xmm1;sqrtpd %%xmm0,%%xmm1;movapd %%xmm1,%2\" " + ": \"=m\" (*(char *)x->a.a_self), \"=m\" (*(char *)y->a.a_self) : \"m\" (*(char *)z->a.a_self));" + "return z;}") + + (eval-when + (compile load eval) + (deft c_array_self fixnum ((object x)) "{return (fixnum)x->a.a_self;}") + (defun c-array-eltsize (x) (ecase (array-element-type x) (short-float 4) (long-float 8))) + (defun make-aligned-array (alignment size &rest r + &aux (ic (member :initial-contents r)) y + (c (cadr ic)) + (r (append (ldiff r ic) (cddr ic))) + (a (apply 'make-array (+ alignment size) (list* :static t r)))) + (setq y (map-into + (apply 'make-array size + :displaced-to a + :displaced-index-offset (truncate (- alignment (mod (c_array_self a) alignment)) (c-array-eltsize a)) + r) + 'identity c)) + (assert (zerop (mod (c_array_self y) 16))) + y)) + + (setq fa (make-aligned-array 16 4 :element-type 'short-float :initial-contents '(1.2s0 2.3s0 3.4s0 4.1s0)) + fb (make-aligned-array 16 4 :element-type 'short-float) + fc (make-aligned-array 16 4 :element-type 'short-float :initial-contents '(1.3s0 2.4s0 3.5s0 4.6s0)) + fx (make-aligned-array 16 4 :element-type 'short-float :initial-contents (make-list 4 :initial-element most-positive-short-float)) + fm (make-aligned-array 16 4 :element-type 'short-float :initial-contents (make-list 4 :initial-element least-positive-normalized-short-float)) + fn (make-aligned-array 16 4 :element-type 'short-float :initial-contents (make-list 4 :initial-element -1.0s0)) + fr (make-aligned-array 16 4 :element-type 'short-float)) + + (setq da (make-aligned-array 16 2 :element-type 'long-float :initial-contents '(1.2 2.3)) + db (make-aligned-array 16 2 :element-type 'long-float) + dc (make-aligned-array 16 2 :element-type 'long-float :initial-contents '(1.3 2.4)) + dx (make-aligned-array 16 2 :element-type 'long-float :initial-contents (make-list 2 :initial-element most-positive-long-float)) + dm (make-aligned-array 16 2 :element-type 'long-float :initial-contents (make-list 2 :initial-element least-positive-normalized-long-float)) + dn (make-aligned-array 16 2 :element-type 'long-float :initial-contents (make-list 2 :initial-element -1.0)) + dr (make-aligned-array 16 2 :element-type 'long-float)) + + (test-fpe 'fdivp (list 1.0 2.0) 0.5 t) + (test-fpe 'fdivp (list 1.0 0.0) :division-by-zero t) + (test-fpe 'fdivp (list 0.0 0.0) :floating-point-invalid-operation t) + (test-fpe 'fdivp (list most-positive-long-float least-positive-normalized-long-float) :floating-point-overflow);fstpl + (test-fpe 'fdivp (list least-positive-normalized-long-float most-positive-long-float) :floating-point-underflow);fstpl + (test-fpe 'fdivp (list 1.2 1.3) :floating-point-inexact);post args + + (test-fpe 'divpd (list da da dr) dr t) + (test-fpe 'divpd (list db da dr) :division-by-zero t) + (test-fpe 'divpd (list db db dr) :floating-point-invalid-operation t) + (test-fpe 'divpd (list dm dx dr) :floating-point-overflow t) + (test-fpe 'divpd (list dx dm dr) :floating-point-underflow t) + (test-fpe 'divpd (list da dc dr) :floating-point-inexact t) + + (test-fpe 'divpdm (list da da dr) dr t) + (test-fpe 'divpdm (list db da dr) :division-by-zero t) + (test-fpe 'divpdm (list db db dr) :floating-point-invalid-operation t) + (test-fpe 'divpdm (list dm dx dr) :floating-point-overflow t) + (test-fpe 'divpdm (list dx dm dr) :floating-point-underflow t) + (test-fpe 'divpdm (list da dc dr) :floating-point-inexact t) + + + (test-fpe 'divps (list fa fa fr) fr t) + (test-fpe 'divps (list fb fa fr) :division-by-zero t) + (test-fpe 'divps (list fb fb fr) :floating-point-invalid-operation t) + (test-fpe 'divps (list fm fx fr) :floating-point-overflow t) + (test-fpe 'divps (list fx fm fr) :floating-point-underflow t) + (test-fpe 'divps (list fa fc fr) :floating-point-inexact t) + + (test-fpe 'divpsm (list fa fa fr) fr t) + (test-fpe 'divpsm (list fb fa fr) :division-by-zero t) + (test-fpe 'divpsm (list fb fb fr) :floating-point-invalid-operation t) + (test-fpe 'divpsm (list fm fx fr) :floating-point-overflow t) + (test-fpe 'divpsm (list fx fm fr) :floating-point-underflow t) + (test-fpe 'divpsm (list fa fc fr) :floating-point-inexact t) + + + + (test-fpe 'divsd (list 1.0 2.0) 0.5 t) + (test-fpe 'divsd (list 1.0 0.0) :division-by-zero t) + (test-fpe 'divsd (list 0.0 0.0) :floating-point-invalid-operation t) + (test-fpe 'divsd (list most-positive-long-float least-positive-normalized-long-float) :floating-point-overflow t) + (test-fpe 'divsd (list least-positive-normalized-long-float most-positive-long-float) :floating-point-underflow t) + (test-fpe 'divsd (list 1.2 2.3) :floating-point-inexact t) + + (test-fpe 'divsdm (list 1.0 2.0) 0.5 t) + (test-fpe 'divsdm (list 1.0 0.0) :division-by-zero t) + (test-fpe 'divsdm (list 0.0 0.0) :floating-point-invalid-operation t) + (test-fpe 'divsdm (list most-positive-long-float least-positive-normalized-long-float) :floating-point-overflow t) + (test-fpe 'divsdm (list least-positive-normalized-long-float most-positive-long-float) :floating-point-underflow t) + (test-fpe 'divsdm (list 1.2 2.3) :floating-point-inexact t) + + (test-fpe 'divss (list 1.0s0 2.0s0) 0.5s0 t) + (test-fpe 'divss (list 1.0s0 0.0s0) :division-by-zero t) + (test-fpe 'divss (list 0.0s0 0.0s0) :floating-point-invalid-operation t) + (test-fpe 'divss (list most-positive-short-float least-positive-normalized-short-float) :floating-point-overflow t) + (test-fpe 'divss (list least-positive-normalized-short-float most-positive-short-float) :floating-point-underflow t) + (test-fpe 'divss (list 1.2s0 2.3s0) :floating-point-inexact t) + + (test-fpe 'divssm (list 1.0s0 2.0s0) 0.5s0 t) + (test-fpe 'divssm (list 1.0s0 0.0s0) :division-by-zero t) + (test-fpe 'divssm (list 0.0s0 0.0s0) :floating-point-invalid-operation t) + (test-fpe 'divssm (list most-positive-short-float least-positive-normalized-short-float) :floating-point-overflow t) + (test-fpe 'divssm (list least-positive-normalized-short-float most-positive-short-float) :floating-point-underflow t) + (test-fpe 'divssm (list 1.2s0 2.3s0) :floating-point-inexact t) + + (test-fpe 'sqrtpd (list da db dr) dr t) + (test-fpe 'sqrtpd (list dn db dr) :floating-point-invalid-operation t) + (test-fpe 'sqrtpd (list da db dr) :floating-point-inexact t)) + + +(defun l/ (x y) (declare (long-float x y)) (/ x y)) +(defun s/ (x y) (declare (short-float x y)) (/ x y)) +(defun lsqrt (x) (declare (long-float x)) (the long-float (sqrt x))) + + +(test-fpe 'l/ (list 1.0 2.0) 0.5 t) +(test-fpe 'l/ (list 1.0 0.0) :division-by-zero t) +(test-fpe 'l/ (list 0.0 0.0) :floating-point-invalid-operation t) +(test-fpe 'l/ (list most-positive-long-float least-positive-normalized-long-float) :floating-point-overflow t) +(test-fpe 'l/ (list least-positive-normalized-long-float most-positive-long-float) :floating-point-underflow t) +(test-fpe 'l/ (list 1.2 1.3) :floating-point-inexact t) + +(test-fpe 's/ (list 1.0s0 2.0s0) 0.5s0 t) +(test-fpe 's/ (list 1.0s0 0.0s0) :division-by-zero t) +(test-fpe 's/ (list 0.0s0 0.0s0) :floating-point-invalid-operation t) +(test-fpe 's/ (list most-positive-short-float least-positive-normalized-short-float) :floating-point-overflow t) +(test-fpe 's/ (list least-positive-normalized-short-float most-positive-short-float) :floating-point-underflow t) +(test-fpe 's/ (list 1.2s0 1.3s0) :floating-point-inexact t) + +(test-fpe 'lsqrt (list 4.0) 2.0 t) +(test-fpe 'lsqrt (list -1.0) :floating-point-invalid-operation t) +(test-fpe 'lsqrt (list 1.2) :floating-point-inexact t) diff --git a/lsp/gcl_gprof.lsp b/lsp/gcl_gprof.lsp new file mode 100755 index 0000000..796e62e --- /dev/null +++ b/lsp/gcl_gprof.lsp @@ -0,0 +1,133 @@ +(in-package 'si) + +;; (load "gprof.o") +;; You must have a kcl image with profiling information and monstartup +;; typically saved_kcp. NOTE: if monstartup calls sbrk (true in +;; most 4.3bsd's except sun >= OS 4.0) you must be very careful to +;; allocate all the space you will use prior to calling monstartup. +;; If subsequent storage allocation causes the hole to move you will +;; most certainly lose. See below for instructions +;; on how to construct saved_kcp. + +;; If you want function invocation counts to be kept do +;; (setq compiler::*cc* (concatentate 'string compiler::*cc* " -pg ")) +;; before compiling the relevant files. (This is done when you load +;; lsp/gprof.o) + +;; In the image saved_kcp Load in your files. Load in gprof.o: (load +;; "lsp/gprof.o") Invoke monstartup once to setup buffers: (monstartup +;; lowpc highpc) eg. (monstartup #x800 3000000) [highpc should be a bit +;; bigger than the highest address you have seen when loading your files] +;; Use moncontrol to toggle profiling on and off: (moncontrol 0) to turn +;; profiling off, and (moncontrol 1) to turn it on. Use +;; (wrtie-gmons+syms) to terminate with writing a gmon.out and syms.out +;; in the current directory. I know of no way of clearing the buffers, +;; since secret routines set up the buffers, and we don't know where they +;; are or how large. Thus all information is cumulative. + +;; % gprof syms.out +;; will display the output (add -b) to make it briefer. + +;; A sample session on rascal: +#| +/usr2/skcl/unixport/saved_kcp +GCL (Austin Kyoto Common Lisp) Version(1.147) Sun May 14 15:26:07 CDT 1989 +Contains Enhancements by W. Schelter + +>(load "/tmp/fo") +Loading /tmp/fo.o +start address -T 1d04e0 Finished loading /tmp/fo.o +528 + +>(load "/usr2/skcl/lsp/gprof") +Loading gprof.o + + Adding -pg to the *cc* commandstart address -T 1d0800 +Finished loading gprof.o +2112 + +;; NOTE: If the following calls sbrk [eg 4.3bsd or sun OS3 ] but not Sun OS4, +;; then you MUST make sure to allocate sufficient memory before doing +;; monstartup, so that the hole will not have to be moved. +>(si::monstartup #x800 2000000) +2584576 + +>(si::goo)(si::goo) ;;defined in /tmp/foo.lisp +NIL + +>NIL + +>(si::write-gmon+syms) +writing syms.. +0 +[NOTE: The safest way to exit the lisp is to stop it with Ctrl-Z +and then kill it. We do NOT want to run the exit code which +normally writes out a monitoring file]. + +rascal% gprof -b syms.out +... + called/total parents +index %time self descendents called+self name index + called/total children + + 0.00 0.00 1/200 _call_or_link [8] + 0.02 0.02 199/200 GOO [2] +[1] 49.6 0.02 0.02 200 FOO [1] + 0.02 0.00 200/203 _make_cons [4] + +... Interpretation: Foo is called 199 times by (parent) goo and once +by (parent) call_or_link (the setting up of the fast link). Foo +itself calls (child) make_cons 200 of the 203 times that make_cons is +called... Lower down we would see that goo is called twice. + +-- /tmp/fo.lisp -- + (defun foo () (cons nil nil)) + (defun goo () (sloop::sloop for i below 100 do (foo))) +-- end of file -- + +|# + +;; Creating saved_gcp +;; +;; cd gcl +;; make go +;; (cd unixport ; make gcp-sun) +;; (cd go ; ln -s ../o/makefile ../o/*.o ../o/*.c ../o/*.d ../o/*.ini .) +;; remove a few .o files and do +;; (cd go ; make "CFLAGS = -I../h -I../gcl-tk -pg -g -c") + +;; then (cd unixport ; make kcp) + +(clines + #-aix3 "#include \"gprof.hc\"" + #+aix3 "#include \"aix_gprof.hc\"" + ) + +(eval-when (load) +(progn (setq compiler::*cc* (CONCATENATE 'string compiler::*cc* " -pg ")) + (format t "~% Adding -pg to the *cc* command")) +) +(defun write-gmon+syms() + (monitor2 0 0 0 0) + (princ "writing syms..") + (set-up-combined) + (write_outsyms) + ) + + +(defentry monstartup (int int) (int "mymonstartup")) + +(defentry monitor2 (int int int int) (int "mymonitor")) + +(defentry moncontrol (int) (int "moncontrol")) + +(defentry write_outsyms () (int "write_outsyms")) + + + + + + + + + diff --git a/lsp/gcl_info.lsp b/lsp/gcl_info.lsp new file mode 100755 index 0000000..7c146d9 --- /dev/null +++ b/lsp/gcl_info.lsp @@ -0,0 +1,548 @@ +(in-package "SI" ) + +(eval-when (compile eval) +(defmacro while (test &body body) + `(slooP::sloop while ,test do ,@ body)) + (defmacro f (op x y) + `(the ,(if (get op 'compiler::predicate) 't 'fixnum) + (,op (the fixnum ,x) (the fixnum ,y)))) +(defmacro fcr (x) `(load-time-value (compile-regexp ,x)))) + +(eval-when (compile eval load) +(defun sharp-u-reader (stream subchar arg) + subchar arg + (let ((tem (make-array 10 :element-type 'string-char :fill-pointer 0))) + (or (eql (read-char stream) #\") + (error "sharp-u-reader reader needs a \" right after it")) + (loop + (let ((ch (read-char stream))) + (cond ((eql ch #\") (return tem)) + ((eql ch #\\) + (setq ch (read-char stream)) + (setq ch (or (cdr (assoc ch '((#\n . #\newline) + (#\t . #\tab) + (#\r . #\return)))) + ch)))) + (vector-push-extend ch tem))) + tem)) + +(set-dispatch-macro-character #\# #\u 'sharp-u-reader) + +) + +(defconstant +crlu+ (compile-regexp #u"")) +(defconstant +crnp+ (compile-regexp #u"[ ]")) + +(defvar *info-data* nil) +(defvar *current-info-data* nil) + +(defun file-to-string (file &optional (start 0) + &aux (si::*ALLOW-GZIPPED-FILE* t)(len 0)) + (with-open-file + (st file) + (setq len (file-length st)) + (or (and (<= 0 start ) (<= start len)) + (error "illegal file start ~a" start)) + (let ((tem (make-array (- len start) + :element-type 'string-char))) + (if (> start 0) (file-position st start)) + (si::fread tem 0 (length tem) st) tem))) + +(defun atoi (string start &aux (ans 0) (ch 0)(len (length string))) + (declare (string string)) + (declare (fixnum start ans ch len) ) + (while (< start len) + (setq ch (char-code (aref string start))) + (setq start (+ start 1)) + (setq ch (- ch #.(char-code #\0))) + (cond ((and (>= ch 0) (< ch 10)) + (setq ans (+ ch (* 10 ans)))) + (t (return nil)))) + ans)) + +(defun info-get-tags (file &aux (lim 0) *match-data* tags files + (*case-fold-search* t)) + (declare (fixnum lim)) + (let ((s (file-to-string file)) (i 0)) + (declare (fixnum i) (string s)) + (cond ((f >= (string-match (fcr #u"[ \n]+Indirect:") s 0) 0) + (setq i (match-end 0)) + (setq lim (string-match +crlu+ s i)) + (while + (f >= (string-match (fcr #u"\n([^\n]+): ([0-9]+)") s i lim) 0) + (setq i (match-end 0)) + (setq files + (cons(cons + (atoi s (match-beginning 2)) + (get-match s 1) + ) + files))))) + (cond ((f >= (si::string-match (fcr #u"[\n ]+Tag Table:") s i) 0) + (setq i (si::match-end 0)) + (cond ((f >= (si::string-match +crlu+ s i) 0) + (setq tags (subseq s i (si::match-end 0))))))) + (if files (or tags (info-error "Need tags if have multiple files"))) + (list* tags (nreverse files)))) + +(defun re-quote-string (x &aux (i 0) ch (extra 0)) + (declare (fixnum i extra)) + (let ((x (if (stringp x) x (string x)))) + (declare (string x)) + (let (tem (len (length x))) + (declare (fixnum len)) + (tagbody + AGAIN + (while (< i len) + (setq ch (aref x i)) + (cond ((position ch "\\()[]+.*|^$?") + (cond (tem + (vector-push-extend #\\ tem)) + (t (incf extra))))) + (if tem + (vector-push-extend ch tem)) + (setq i (+ i 1))) + (cond (tem ) + ((> extra 0) + (setq tem + (make-array (f + (length x) extra) + :element-type 'string-char :fill-pointer 0)) + (setq i 0) + (go AGAIN)) + (t (setq tem x))) + ) + tem))) + +(defun get-match (string i) + (subseq string (match-beginning i) (match-end i))) + +(defun get-nodes (pat node-string &aux (i 0) ans + (*case-fold-search* t) *match-data*) + (declare (fixnum i)) + (when node-string + (setq pat + (si::string-concatenate "Node: ([^]*" (re-quote-string + pat) "[^]*)")) + (while (f >= (string-match pat node-string i) 0) + (setq i (match-end 0)) + (setq ans (cons (get-match node-string 1) + ans)) + ) + (nreverse ans))) + +(defun get-index-node () + (or (third *current-info-data*) + (let* ( + s + (node-string (car (nth 1 *current-info-data*))) + (node + (and node-string (car (get-nodes "index" node-string))))) + (when node + (setq s (show-info + node + nil + nil + )) + (setf (third *current-info-data*) s))))) + +(defun nodes-from-index (pat &aux (i 0) ans + (*case-fold-search* t) *match-data*) + (let ((index-string (get-index-node))) + (when index-string + (setq pat + (si::string-concatenate #u"\n\\* ([^:\n]*" (re-quote-string + pat) + #u"[^:\n]*):[ \t]+([^\t\n,.]+)")) + (while (f >= (string-match pat index-string i) 0) + (setq i (match-end 0)) + (setq ans (cons (cons (get-match index-string 1) + (get-match index-string 2)) + + + ans)) + ) + (nreverse ans)))) + +(defun get-node-index (pat node-string &aux (node pat) *match-data*) + (cond ((null node-string) 0) + (t + (setq pat + (si::string-concatenate "Node: " + (re-quote-string pat) "([0-9]+)")) + (cond ((f >= (string-match pat node-string) 0) + (atoi node-string (match-beginning 1))) + (t (info-error "cant find node ~s" node) 0))))) + +(defun all-matches (pat st &aux (start 0) *match-data*) + (declare (fixnum start)) + (sloop::sloop while (>= (setq start (si::string-match pat st start)) 0) + do nil;(print start) + collect (list start (setq start (si::match-end 0))))) + + + +(defmacro node (prop x) + `(nth ,(position prop '(string begin end header name + info-subfile + file tags)) ,x)) + +(defun node-offset (node) + (+ (car (node info-subfile node)) (node begin node))) + +(defvar *info-paths* + '("" "/usr/info/" "/usr/local/lib/info/" "/usr/local/info/" + "/usr/local/gnu/info/" "/usr/share/info/")) + +(defvar *old-lib-directory* nil) +(defun setup-info (name &aux tem file) + (or (eq *old-lib-directory* si::*lib-directory*) + (progn + (setq *old-lib-directory* si::*lib-directory*) + (push (si::string-concatenate + si::*lib-directory* "info/") *info-paths*) + (setq *info-paths* (si::fix-load-path *info-paths*)))) + (cond ((or (equal name "DIR")) + (setq name "dir"))) +;; compressed info reading -- search for gzipped files, and open with base filename +;; relying on si::*allow-gzipped-files* to uncompress + (setq file (si::file-search name *info-paths* '("" ".info" ".gz") nil)) + (let ((ext (search ".gz" file))) + (when ext + (setq file (subseq file 0 ext)))) + (cond ((and (null file) + (not (equal name "dir"))) + (let* ( + (tem (show-info "(dir)Top" nil nil)) + *case-fold-search*) + (cond ((f >= (string-match + (si::string-concatenate + "\\(([^(]*" + (re-quote-string name) + "(.info)?)\\)") + tem ) 0) + (setq file (get-match tem 1))))))) + (cond (file + (let* ((na (namestring (truename file)))) + (cond ((setq tem (assoc na *info-data* :test 'equal)) + (setq *current-info-data* tem)) + (t (setq *current-info-data* + (list na (info-get-tags na) nil)) + (setq *info-data* (cons *current-info-data* *info-data*) + ))))) + (t (format t "(not found ~s)" name))) + nil) + +(defun get-info-choices (pat type) + (if (eql type 'index) + (nodes-from-index pat ) + (get-nodes pat (car (nth 1 *current-info-data*)))))) + +(defun add-file (v file &aux (lis v)) + (while lis + (setf (car lis) (list (car lis) file)) + (setq lis (cdr lis))) + v) + +(defvar *info-window* nil) +(defvar *tk-connection* nil) + +(defun info-error (&rest l) + (if *tk-connection* + (tk::tkerror (apply 'format nil l)) + (apply 'error l))) + +(defvar *last-info-file* nil) +;; cache last file read to speed up lookup since may be gzipped.. +(defun info-get-file (pathname) + (setq pathname + (merge-pathnames pathname + (car *current-info-data*))) + (cdr + (cond ((equal (car *last-info-file*) pathname) + *last-info-file*) + (t (setq *last-info-file* + (cons pathname (file-to-string pathname))))))) + +(defun waiting (win) + (and *tk-connection* + (fboundp win) + (winfo :exists win :return 'boolean) + (funcall win :configure :cursor "watch"))) + +(defun end-waiting (win) (and (fboundp win) + (funcall win :configure :cursor ""))) + +(defun info-subfile (n &aux ) +; "For an index N return (START . FILE) for info subfile +; which contains N. A second value bounding the limit if known +; is returned. At last file this limit is nil." + (let ((lis (cdr (nth 1 *current-info-data*))) + ans lim) + (and lis (>= n 0) + (dolist (v lis) + (cond ((> (car v) n ) + (setq lim (car v)) + (return nil))) + (setq ans v) + )) + (values (or ans (cons 0 (car *current-info-data*))) lim))) + +;;used by search +(defun info-node-from-position (n &aux (i 0)) + (let* ((info-subfile (info-subfile n)) + (s (info-get-file (cdr info-subfile))) + (end (- n (car info-subfile)))) + (while (f >= (string-match +crlu+ s i end) 0) + (setq i (match-end 0))) + (setq i (- i 1)) + (if (f >= (string-match + (fcr #u"[\n ][^\n]*Node:[ \t]+([^\n\t,]+)[\n\t,][^\n]*\n") s i) 0) + (let* ((i (match-beginning 0)) + (beg (match-end 0)) + (name (get-match s 1)) + (end(if (f >= (string-match +crnp+ s beg) 0) + (match-beginning 0) + (length s))) + (node (list* s beg end i name info-subfile + *current-info-data*))) + node)))) + +(defun show-info (name &optional position-pattern + (use-tk *tk-connection*) + &aux info-subfile *match-data* + file + (initial-offset 0)(subnode -1)) + (declare (fixnum subnode initial-offset)) +;;; (pat . node) +;;; node +;;; (node file) +;;; ((pat . node) file) +; (print (list name position-pattern use-tk)) + (progn ;decode name + (cond ((and (consp name) (consp (cdr name))) + (setq file (cadr name) + name (car name)))) + (cond ((consp name) + (setq position-pattern (car name) name (cdr name))))) + (or (stringp name) (info-error "bad arg")) + (waiting *info-window*) + (cond ((f >= (string-match (fcr "^\\(([^(]+)\\)([^)]*)") name) 0) + ;; (file)node + (setq file (get-match name 1)) + (setq name (get-match name 2)) + (if (equal name "")(setq name "Top")))) + (if file (setup-info file)) + (let ((indirect-index (get-node-index name + (car (nth 1 *current-info-data*))))) + (cond ((null indirect-index) + (format t"~%Sorry, Can't find node ~a" name) + (return-from show-info nil))) + + (setq info-subfile (info-subfile indirect-index)) + (let* ((s + (info-get-file (cdr info-subfile))) + (start (- indirect-index (car info-subfile)))) + (cond ((f >= (string-match + ;; to do fix this ;; see (info)Add for description; + ;; the + (si::string-concatenate + #u"[\n ][^\n]*Node:[ \t]+" + (re-quote-string name) #u"[,\t\n][^\n]*\n") + s start) 0) + (let* ((i (match-beginning 0)) + (beg (match-end 0)) + (end(if (f >= (string-match +crnp+ s beg) 0) + (match-beginning 0) + (length s))) + (node (list* s beg end i name info-subfile + *current-info-data*))) + + (cond + (position-pattern + (setq position-pattern (re-quote-string position-pattern)) + + (let (*case-fold-search* ) + (if (or + (f >= (setq subnode + (string-match + (si::string-concatenate + #u"\n -+ [A-Za-z ]+: " + position-pattern #u"[ \n]") + s beg end)) 0) + (f >= (string-match position-pattern s beg end) 0)) + (setq initial-offset + (- (match-beginning 0) beg)) + )))) + (cond ( use-tk + (prog1 (print-node node initial-offset) + (end-waiting *info-window*)) + ) + (t + (let ((e + (if (and (>= subnode 0) + (f >= + (string-match + (fcr #u"\n -+ [a-zA-Z]") + s + (let* ((bg (+ beg 1 initial-offset)) + (sd (string-match (fcr #u"\n ") s bg end)) + (nb (if (minusp sd) bg sd))) + nb) + end) + 0)) + (match-beginning 0) + end))) + ;(print (list beg initial-offset e end)) + (subseq s (+ initial-offset beg) e ) + ;s + ))))) + (t (info-error "Cant find node ~a?" name) + (end-waiting *info-window*) + )) + ))) + +(defvar *default-info-files* '( "gcl-si.info" "gcl-tk.info" "gcl.info")) + +(defun info-aux (x dirs) + (sloop for v in dirs + do (setup-info v) + append (add-file (get-info-choices x 'node) v) + append (add-file (get-info-choices x 'index) v))) + +(defun info-search (pattern &optional start end &aux limit) +; "search for PATTERN from START up to END where these are indices in +;the general info file. The search goes over all files." + (or start (setq start 0)) + (while start + (multiple-value-bind + (file lim) + (info-subfile start) + (setq limit lim) + (and end limit (< end limit) (setq limit end)) + + (let* ((s (info-get-file (cdr file))) + (beg (car file)) + (i (- start beg)) + (leng (length s))) + (cond ((f >= (string-match pattern s i (if limit (- limit beg) leng)) 0) + (return-from info-search (+ beg (match-beginning 0)))))) + (setq start lim))) + -1) + +#+debug ; try searching +(defun try (pat &aux (tem 0) s ) + (while (>= tem 0) + (cond ((>= (setq tem (info-search pat tem)) 0) + (setq s (cdr *last-info-file*)) + (print (list + tem + (list-matches s 0 1 2) + (car *last-info-file*) + (subseq s + (max 0 (- (match-beginning 0) 50)) + (min (+ (match-end 0) 50) (length s))))) + (setq tem (+ tem (- (match-end 0) (match-beginning 0)))))))) + +(defun idescribe (name) + (let* ((items (info-aux name *default-info-files*))) + (dolist (v items) + (when (cond ((consp (car v)) + (equalp (caar v) name)) + (t (equalp (car v) name))) + (format t "~%From ~a:~%" v) + (princ (show-info v nil nil)))))) + +(defun info (x &optional (dirs *default-info-files*) &aux wanted + *current-info-data* file position-pattern) + (unless (consp dirs) + (setq dirs *default-info-files*)) + (let ((tem (info-aux x dirs))) + (cond + (*tk-connection* + (offer-choices tem dirs) + ) + (t + + (when tem + (let ((nitems (length tem))) + (sloop for i from 0 for name in tem with prev + do (setq file nil position-pattern nil) + (progn ;decode name + (cond ((and (consp name) (consp (cdr name))) + (setq file (cadr name) + name (car name)))) + (cond ((consp name) + (setq position-pattern (car name) name (cdr name))))) + (format t "~% ~d: ~@[~a :~]~@[(~a)~]~a." i + position-pattern + (if (eq file prev) nil (setq prev file)) name)) + (if (> (length tem) 1) + (format t "~%Enter n, all, none, or multiple choices eg 1 3 : ") + (terpri)) + (let ((line (if (> (length tem) 1) (read-line) "0")) + (start 0) + val) + (while (equal line "") (setq line (read-line))) + (while (multiple-value-setq + (val start) + (read-from-string line nil nil :start start)) + (cond ((numberp val) + (setq wanted (cons val wanted))) + (t (setq wanted val) (return nil)))) + (cond ((consp wanted)(setq wanted (nreverse wanted))) + ((symbolp wanted) + (setq wanted (and + (equal (symbol-name wanted) "ALL") + (sloop for i below (length tem) collect i))))) + (when wanted + ;; Remove invalid (numerical) answers + (setf wanted (remove-if #'(lambda (x) + (and (integerp x) (>= x nitems))) + wanted)) + (format t "~%Info from file ~a:" (car *current-info-data*))) + (sloop for i in wanted + do (princ(show-info (nth i tem))))))))))) + + +;; idea make info_text window have previous,next,up bindings on keys +;; and on menu bar. Have it bring up apropos menu. allow selection +;; to say spawn another info_text window. The symbol that is the window +;; will carry on its plist the prev,next etc nodes, and the string-to-file +;; cache the last read file as well. Add look up in index file, so that can +;; search an indtqex as well. Could be an optional arg to show-node +;; + + + +(defun default-info-hotlist() + (namestring (merge-pathnames "hotlist" (user-homedir-pathname)))) + +(defvar *info-window* nil) + +(defun add-to-hotlist (node ) + (if (symbolp node) (setq node (get node 'node))) + (cond + (node + (with-open-file + (st (default-info-hotlist) + :direction :output + :if-exists :append + :if-does-not-exist :create) + (cond ((< (file-position st) 10) + (princ #u"\nFile:\thotlist\tNode: Top\n\n* Menu: Hot list of favrite info items.\n\n" st))) + (format st "* (~a)~a::~%" + (node file node)(node name node)))))) + +(defun list-matches (s &rest l) + (sloop for i in l + collect + (and (f >= (match-beginning i) 0) + (get-match s i)))) + +;;; Local Variables: *** +;;; mode:lisp *** +;;; version-control:t *** +;;; comment-column:0 *** +;;; comment-start: ";;; " *** +;;; End: *** + + diff --git a/lsp/gcl_iolib.lsp b/lsp/gcl_iolib.lsp new file mode 100755 index 0000000..b2be57f --- /dev/null +++ b/lsp/gcl_iolib.lsp @@ -0,0 +1,325 @@ +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +;;;; iolib.lsp +;;;; +;;;; The IO library. + + +(in-package 'lisp) + + +(export '(with-open-stream with-input-from-string with-output-to-string + ensure-directories-exist wild-pathname-p + read-byte write-byte read-sequence write-sequence)) +(export '(read-from-string)) +(export '(write-to-string prin1-to-string princ-to-string)) +(export 'with-open-file) +(export '(y-or-n-p yes-or-no-p)) +(export 'dribble) + + +(in-package 'system) + + +(proclaim '(optimize (safety 2) (space 3))) + + +(defmacro with-open-stream ((var stream) . body) + (multiple-value-bind (ds b) + (find-declarations body) + `(let ((,var ,stream)) + ,@ds + (unwind-protect + (progn ,@b) + (close ,var))))) + + +(defmacro with-input-from-string ((var string &key index start end) . body) + (if index + (multiple-value-bind (ds b) + (find-declarations body) + `(let ((,var (make-string-input-stream ,string ,start ,end))) + ,@ds + (unwind-protect + (progn ,@b) + (setf ,index (si:get-string-input-stream-index ,var))))) + `(let ((,var (make-string-input-stream ,string ,start ,end))) + ,@body))) + + +(defmacro with-output-to-string ((var &optional string) . body) + (if string + `(let ((,var (make-string-output-stream-from-string ,string))) + ,@body) + `(let ((,var (make-string-output-stream))) + ,@body + (get-output-stream-string ,var)))) + + +(defun read-from-string (string + &optional (eof-error-p t) eof-value + &key (start 0) (end (length string)) + preserve-whitespace) + (let ((stream (make-string-input-stream string start end))) + (if preserve-whitespace + (values (read-preserving-whitespace stream eof-error-p eof-value) + (si:get-string-input-stream-index stream)) + (values (read stream eof-error-p eof-value) + (si:get-string-input-stream-index stream))))) + + +(defun write-to-string (object &rest rest + &key escape radix base + circle pretty level length + case gensym array + &aux (stream (make-string-output-stream))) + (declare (ignore escape radix base + circle pretty level length + case gensym array)) + (apply #'write object :stream stream rest) + (get-output-stream-string stream)) + + +(defun prin1-to-string (object + &aux (stream (make-string-output-stream))) + (prin1 object stream) + (get-output-stream-string stream)) + + +(defun princ-to-string (object + &aux (stream (make-string-output-stream))) + (princ object stream) + (get-output-stream-string stream)) + + +(defmacro with-open-file ((stream . filespec) . body) + (multiple-value-bind (ds b) + (find-declarations body) + `(let ((,stream (open ,@filespec))) + ,@ds + (unwind-protect + (progn ,@b) + (if ,stream (close ,stream)))))) + + +(defun y-or-n-p (&optional string &rest args) + (do ((reply)) + (nil) + (when string (format *query-io* "~&~? (Y or N) " string args)) + (setq reply (read *query-io*)) + (cond ((string-equal (symbol-name reply) "Y") + (return-from y-or-n-p t)) + ((string-equal (symbol-name reply) "N") + (return-from y-or-n-p nil))))) + + +(defun yes-or-no-p (&optional string &rest args) + (do ((reply)) + (nil) + (when string (format *query-io* "~&~? (Yes or No) " string args)) + (setq reply (read *query-io*)) + (cond ((string-equal (symbol-name reply) "YES") + (return-from yes-or-no-p t)) + ((string-equal (symbol-name reply) "NO") + (return-from yes-or-no-p nil))))) + + +(defun sharp-a-reader (stream subchar arg) + (declare (ignore subchar)) + (let ((initial-contents (read stream nil nil t))) + (if *read-suppress* + nil + (do ((i 0 (1+ i)) + (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)))))) + +(set-dispatch-macro-character #\# #\a 'sharp-a-reader) +(set-dispatch-macro-character #\# #\A 'sharp-a-reader) + +;; defined in defstruct.lsp +(set-dispatch-macro-character #\# #\s 'sharp-s-reader) +(set-dispatch-macro-character #\# #\S 'sharp-s-reader) + +(defvar *dribble-stream* nil) +(defvar *dribble-io* nil) +(defvar *dribble-namestring* nil) +(defvar *dribble-saved-terminal-io* nil) + +(defun dribble (&optional (pathname "DRIBBLE.LOG" psp) (f :supersede)) + (cond ((not psp) + (when (null *dribble-stream*) (error "Not in dribble.")) + (if (eq *dribble-io* *terminal-io*) + (setq *terminal-io* *dribble-saved-terminal-io*) + (warn "*TERMINAL-IO* was rebound while DRIBBLE is on.~%~ + You may miss some dribble output.")) + (close *dribble-stream*) + (setq *dribble-stream* nil) + (format t "~&Finished dribbling to ~A." *dribble-namestring*)) + (*dribble-stream* + (error "Already in dribble (to ~A)." *dribble-namestring*)) + (t + (let* ((namestring (namestring pathname)) + (stream (open pathname :direction :output + :if-exists f + :if-does-not-exist :create))) + (setq *dribble-namestring* namestring + *dribble-stream* stream + *dribble-saved-terminal-io* *terminal-io* + *dribble-io* (make-two-way-stream + (make-echo-stream *terminal-io* stream) + (make-broadcast-stream *terminal-io* stream)) + *terminal-io* *dribble-io*) + (multiple-value-bind (sec min hour day month year) + (get-decoded-time) + (format t "~&Starts dribbling to ~A (~d/~d/~d, ~d:~d:~d)." + namestring year month day hour min sec)))))) + +(defconstant char-length 8) + +(defun get-byte-stream-nchars (s) + (check-type s stream) + (let* ((tp (stream-element-type s)) + (tp (if (consp tp) (cadr tp) char-length)) + (nc (ceiling tp char-length))) + nc)) + +(defun write-byte (j s) + (declare (optimize (safety 1))) + (let ((nc (get-byte-stream-nchars s)) + (ff (1- (expt 2 char-length)))) + (do ((k 0 (1+ k))(i j (ash i (- char-length)))) ((>= k nc) j) + (write-char (code-char (logand i ff)) s)))) + +(defun read-byte (s &optional (eof-error-p t) eof-value) + (declare (optimize (safety 1))) + (let ((nc (get-byte-stream-nchars s))) + (do ((j 0 (1+ j)) + (i 0 (logior i + (ash (char-code (let ((ch (read-char s eof-error-p eof-value))) + (if (and (not eof-error-p) (eq ch eof-value)) + (return-from read-byte ch) + ch))) (* j char-length))))) + ((>= j nc) i)))) + + +(defun read-sequence (seq strm &key (start 0) end) + (declare (optimize (safety 1))) + (check-type seq sequence) + (check-type start (integer 0)) + (check-type end (or null (integer 0))) + (let* ((start (min start array-dimension-limit)) + (end (if end (min end array-dimension-limit) (length seq))) + (l (listp seq)) + (seq (if (and l (> start 0)) (nthcdr start seq) seq)) + (tp (subtypep (stream-element-type strm) 'character))) + (do ((i start (1+ i))(seq seq (if l (cdr seq) seq))) + ((or (>= i end) (when l (endp seq))) i) + (declare (fixnum i)) + (let ((el (if tp (read-char strm nil 'eof) (read-byte strm nil 'eof)))) + (when (eq el 'eof) (return i)) + (if l (setf (car seq) el) (setf (aref seq i) el)))))) + + +(defun write-sequence (seq strm &key (start 0) end) + (declare (optimize (safety 1))) + (check-type seq sequence) + (check-type start (integer 0)) + (check-type end (or null (integer 0))) + (let* ((start (min start array-dimension-limit)) + (end (if end (min end array-dimension-limit) (length seq))) + (l (listp seq)) + (tp (subtypep (stream-element-type strm) 'character))) + (do ((i start (1+ i)) + (seq (if (and l (> start 0)) (nthcdr start seq) seq) (if l (cdr seq) seq))) + ((or (>= i end) (when l (endp seq)))) + (declare (fixnum i)) + (let ((el (if l (car seq) (aref seq i)))) + (if tp (write-char el strm) (write-byte el strm)))) + seq)) + +(defmacro with-compilation-unit (opt &rest body) + (declare (optimize (safety 2))) + (declare (ignore opt)) + `(progn ,@body)) + +(defvar *print-lines* nil) +(defvar *print-miser-width* nil) +(defvar *print-pprint-dispatch* nil) +(defvar *print-right-margin* nil) + +(defmacro with-standard-io-syntax (&body body) + (declare (optimize (safety 2))) + `(let* ((*package* (find-package :cl-user)) + (*print-array* t) + (*print-base* 10) + (*print-case* :upcase) + (*print-circle* nil) + (*print-escape* t) + (*print-gensym* t) + (*print-length* nil) + (*print-level* nil) + (*print-lines* nil) + (*print-miser-width* nil) + (*print-pprint-dispatch* *print-pprint-dispatch*) + (*print-pretty* nil) + (*print-radix* nil) + (*print-readably* t) + (*print-right-margin* nil) + (*read-base* 10) + (*read-default-float-format* 'single-float) + (*read-eval* t) + (*read-suppress* nil) + (*readtable* (copy-readtable (si::standard-readtable))));FIXME copy? + ,@body)) + +(defun ensure-directories-exist (ps &key verbose &aux created) + (when (wild-pathname-p ps) + (error 'file-error :pathname ps :format-control "Pathname is wild")) + (labels ((d (x y &aux (z (ldiff x y)) (p (make-pathname :directory z))) + (when (when z (stringp (car (last z)))) + (unless (eq :directory (car (stat p))) + (mkdir (namestring p)) + (setq created t) + (when verbose (format *standard-output* "Creating directory ~s~%" p)))) + (when y (d x (cdr y))))) + (let ((pd (pathname-directory ps))) + (d pd (cdr pd))) + (values ps created))) + +#.(let ((g '(:host :device :directory :name :type :version))) + `(defun wild-pathname-p (pd &optional f &aux (p (pathname pd))) + (declare (optimize (safety 1))) + (check-type f (or null (member ,@g))) + (labels ((w-f (x) + (case x + ,@(mapcar (lambda (x &aux (f (intern (string-concatenate "PATHNAME-" (string-upcase x))))) + `(,x ,(if (eq x :directory) `(when (member :wild (,f p)) t) `(eq :wild (,f p))))) g)))) + (if f + (w-f f) + (reduce (lambda (z x) (or z (w-f x))) ',g :initial-value nil))))) + +(defun maybe-clear-input (&optional (x *standard-input*)) + (cond ((not (typep x 'stream)) nil) + ((typep x 'synonym-stream) (maybe-clear-input (symbol-value (synonym-stream-symbol x)))) + ((typep x 'two-way-stream) (maybe-clear-input (two-way-stream-input-stream x))) + ((terminal-input-stream-p x) (clear-input t)))) diff --git a/lsp/gcl_japi.lsp b/lsp/gcl_japi.lsp new file mode 100644 index 0000000..a415931 --- /dev/null +++ b/lsp/gcl_japi.lsp @@ -0,0 +1,308 @@ +;;; Binding to the cross platform Japi GUI library from http://www.japi.de/ + +(eval-when (load eval) + (make-package :japi-primitives :nicknames '(jpr) :use '(lisp))) +(in-package :japi-primitives) + + +(clines "#include ") + +;; BOOLEAN +(defconstant J_TRUE 1) +(defconstant J_FALSE 0) + +;; ALIGNMENT +(defconstant J_LEFT 0) +(defconstant J_CENTER 1) +(defconstant J_RIGHT 2) +(defconstant J_TOP 3) +(defconstant J_BOTTOM 4) +(defconstant J_TOPLEFT 5) +(defconstant J_TOPRIGHT 6) +(defconstant J_BOTTOMLEFT 7) +(defconstant J_BOTTOMRIGHT 8) + +;; CURSOR +(defconstant J_DEFAULT_CURSOR 0) +(defconstant J_CROSSHAIR_CURSOR 1) +(defconstant J_TEXT_CURSOR 2) +(defconstant J_WAIT_CURSOR 3) +(defconstant J_SW_RESIZE_CURSOR 4) +(defconstant J_SE_RESIZE_CURSOR 5) +(defconstant J_NW_RESIZE_CURSOR 6) +(defconstant J_NE_RESIZE_CURSOR 7) +(defconstant J_N_RESIZE_CURSOR 8) +(defconstant J_S_RESIZE_CURSOR 9) +(defconstant J_W_RESIZE_CURSOR 10) +(defconstant J_E_RESIZE_CURSOR 11) +(defconstant J_HAND_CURSOR 12) +(defconstant J_MOVE_CURSOR 13) + +;; ORIENTATION +(defconstant J_HORIZONTAL 0) +(defconstant J_VERTICAL 1) + +;; FONTS +(defconstant J_PLAIN 0) +(defconstant J_BOLD 1) +(defconstant J_ITALIC 2) +(defconstant J_COURIER 1) +(defconstant J_HELVETIA 2) +(defconstant J_TIMES 3) +(defconstant J_DIALOGIN 4) +(defconstant J_DIALOGOUT 5) + +;; COLORS +(defconstant J_BLACK 0) +(defconstant J_WHITE 1) +(defconstant J_RED 2) +(defconstant J_GREEN 3) +(defconstant J_BLUE 4) +(defconstant J_CYAN 5) +(defconstant J_MAGENTA 6) +(defconstant J_YELLOW 7) +(defconstant J_ORANGE 8) +(defconstant J_GREEN_YELLOW 9) +(defconstant J_GREEN_CYAN 10) +(defconstant J_BLUE_CYAN 11) +(defconstant J_BLUE_MAGENTA 12) +(defconstant J_RED_MAGENTA 13) +(defconstant J_DARK_GRAY 14) +(defconstant J_LIGHT_GRAY 15) +(defconstant J_GRAY 16) + +;; BORDERSTYLE +(defconstant J_NONE 0) +(defconstant J_LINEDOWN 1) +(defconstant J_LINEUP 2) +(defconstant J_AREADOWN 3) +(defconstant J_AREAUP 4) + +;; MOUSELISTENER +(defconstant J_MOVED 0) +(defconstant J_DRAGGED 1) +(defconstant J_PRESSED 2) +(defconstant J_RELEASED 3) +(defconstant J_ENTERERD 4) +(defconstant J_EXITED 5) +(defconstant J_DOUBLECLICK 6) + +;; J_MOVED +(defconstant J_RESIZED 1) +(defconstant J_HIDDEN 2) +(defconstant J_SHOWN 3) + +;; WINDOWLISTENER +(defconstant J_ACTIVATED 0) +(defconstant J_DEACTIVATED 1) +(defconstant J_OPENED 2) +(defconstant J_CLOSED 3) +(defconstant J_ICONIFIED 4) +(defconstant J_DEICONIFIED 5) +(defconstant J_CLOSING 6) + +;; IMAGEFILEFORMAT +(defconstant J_GIF 0) +(defconstant J_JPG 1) +(defconstant J_PPM 2) +(defconstant J_BMP 3) + +(defentry j_start () ( int "j_start" )) +(defentry j_connect ( string ) ( int "j_connect" )) +(defentry j_setdebug ( int ) ( void "j_setdebug" )) +(defentry j_frame ( string ) ( int "j_frame" )) +(defentry j_button ( int string ) ( int "j_button" )) +(defentry j_graphicbutton ( int string ) ( int "j_graphicbutton" )) +(defentry j_checkbox ( int string ) ( int "j_checkbox" )) +(defentry j_label ( int string ) ( int "j_label" )) +(defentry j_graphiclabel ( int string ) ( int "j_graphiclabel" )) +(defentry j_canvas ( int int int ) ( int "j_canvas" )) +(defentry j_panel ( int ) ( int "j_panel" )) +(defentry j_borderpanel ( int int ) ( int "j_borderpanel" )) +(defentry j_radiogroup ( int ) ( int "j_radiogroup" )) +(defentry j_radiobutton ( int string ) ( int "j_radiobutton" )) +(defentry j_list ( int int ) ( int "j_list" )) +(defentry j_choice ( int ) ( int "j_choice" )) +(defentry j_dialog ( int string ) ( int "j_dialog" )) +(defentry j_window ( int ) ( int "j_window" )) +(defentry j_popupmenu ( int string ) ( int "j_popupmenu" )) +(defentry j_scrollpane ( int ) ( int "j_scrollpane" )) +(defentry j_hscrollbar ( int ) ( int "j_hscrollbar" )) +(defentry j_vscrollbar ( int ) ( int "j_vscrollbar" )) +(defentry j_line ( int int int int ) ( int "j_line" )) +(defentry j_printer ( int ) ( int "j_printer" )) +(defentry j_image ( int int ) ( int "j_image" )) +(defentry j_filedialog ( int string string string ) ( string "j_filedialog" )) +(defentry j_fileselect ( int string string string ) ( string "j_fileselect" )) +(defentry j_messagebox ( int string string ) ( int "j_messagebox" )) +(defentry j_alertbox ( int string string string ) ( int "j_alertbox" )) +(defentry j_choicebox2 ( int string string string string ) ( int "j_choicebox2" )) +(defentry j_choicebox3 ( int string string string string string ) ( int "j_choicebox3" )) +(defentry j_additem ( int string ) ( void "j_additem" )) +(defentry j_textfield ( int int ) ( int "j_textfield" )) +(defentry j_textarea ( int int int ) ( int "j_textarea" )) +(defentry j_menubar ( int ) ( int "j_menubar" )) +(defentry j_menu ( int string ) ( int "j_menu" )) +(defentry j_helpmenu ( int string ) ( int "j_helpmenu" )) +(defentry j_menuitem ( int string ) ( int "j_menuitem" )) +(defentry j_checkmenuitem ( int string ) ( int "j_checkmenuitem" )) +(defentry j_pack ( int ) ( void "j_pack" )) +(defentry j_print ( int ) ( void "j_print" )) +(defentry j_playsoundfile ( string ) ( void "j_playsoundfile" )) +(defentry j_play ( int ) ( void "j_play" )) +(defentry j_sound ( string ) ( int "j_sound" )) +(defentry j_setfont ( int int int int ) ( void "j_setfont" )) +(defentry j_setfontname ( int int ) ( void "j_setfontname" )) +(defentry j_setfontsize ( int int ) ( void "j_setfontsize" )) +(defentry j_setfontstyle ( int int ) ( void "j_setfontstyle" )) +(defentry j_seperator ( int ) ( void "j_seperator" )) +(defentry j_disable ( int ) ( void "j_disable" )) +(defentry j_enable ( int ) ( void "j_enable" )) +(defentry j_getstate ( int ) ( int "j_getstate" )) +(defentry j_getrows ( int ) ( int "j_getrows" )) +(defentry j_getcolumns ( int ) ( int "j_getcolumns" )) +(defentry j_getselect ( int ) ( int "j_getselect" )) +(defentry j_isselect ( int int ) ( int "j_isselect" )) +(defentry j_isvisible ( int ) ( int "j_isvisible" )) +(defentry j_isparent ( int int ) ( int "j_isparent" )) +(defentry j_isresizable ( int ) ( int "j_isresizable" )) +(defentry j_select ( int int ) ( void "j_select" )) +(defentry j_deselect ( int int ) ( void "j_deselect" )) +(defentry j_multiplemode ( int int ) ( void "j_multiplemode" )) +(defentry j_insert ( int int string ) ( void "j_insert" )) +(defentry j_remove ( int int ) ( void "j_remove" )) +(defentry j_removeitem ( int string ) ( void "j_removeitem" )) +(defentry j_removeall ( int ) ( void "j_removeall" )) +(defentry j_setstate ( int int ) ( void "j_setstate" )) +(defentry j_setrows ( int int ) ( void "j_setrows" )) +(defentry j_setcolumns ( int int ) ( void "j_setcolumns" )) +(defentry j_seticon ( int int ) ( void "j_seticon" )) +(defentry j_setimage ( int int ) ( void "j_setimage" )) +(defentry j_setvalue ( int int ) ( void "j_setvalue" )) +(defentry j_setradiogroup ( int int ) ( void "j_setradiogroup" )) +(defentry j_setunitinc ( int int ) ( void "j_setunitinc" )) +(defentry j_setblockinc ( int int ) ( void "j_setblockinc" )) +(defentry j_setmin ( int int ) ( void "j_setmin" )) +(defentry j_setmax ( int int ) ( void "j_setmax" )) +(defentry j_setslidesize ( int int ) ( void "j_setslidesize" )) +(defentry j_setcursor ( int int ) ( void "j_setcursor" )) +(defentry j_setresizable ( int int ) ( void "j_setresizable" )) +(defentry j_getlength ( int ) ( int "j_getlength" )) +(defentry j_getvalue ( int ) ( int "j_getvalue" )) +(defentry j_getscreenheight () ( int "j_getscreenheight" )) +(defentry j_getscreenwidth () ( int "j_getscreenwidth" )) +(defentry j_getheight ( int ) ( int "j_getheight" )) +(defentry j_getwidth ( int ) ( int "j_getwidth" )) +(defentry j_getinsets ( int int ) ( int "j_getinsets" )) +(defentry j_getlayoutid ( int ) ( int "j_getlayoutid" )) +(defentry j_getinheight ( int ) ( int "j_getinheight" )) +(defentry j_getinwidth ( int ) ( int "j_getinwidth" )) +(defentry j_gettext ( int string ) ( string "j_gettext" )) +(defentry j_getitem ( int int string ) ( string "j_getitem" )) +(defentry j_getitemcount ( int ) ( int "j_getitemcount" )) +(defentry j_delete ( int int int ) ( void "j_delete" )) +(defentry j_replacetext ( int int int int ) ( void "j_replacetext" )) +(defentry j_appendtext ( int int ) ( void "j_appendtext" )) +(defentry j_inserttext ( int int int ) ( void "j_inserttext" )) +(defentry j_settext ( int string ) ( void "j_settext" )) +(defentry j_selectall ( int ) ( void "j_selectall" )) +(defentry j_selecttext ( int int int ) ( void "j_selecttext" )) +(defentry j_getselstart ( int ) ( int "j_getselstart" )) +(defentry j_getselend ( int ) ( int "j_getselend" )) +;(defentry j_getseltext ( int string ) ( string "j_getseltext" )) +(defentry j_getseltext ( int int ) ( int "j_getseltext" )) +(defentry j_getcurpos ( int ) ( int "j_getcurpos" )) +(defentry j_setcurpos ( int int ) ( void "j_setcurpos" )) +(defentry j_setechochar ( int char ) ( void "j_setechochar" )) +(defentry j_seteditable ( int int ) ( void "j_seteditable" )) +(defentry j_setshortcut ( int char ) ( void "j_setshortcut" )) +(defentry j_quit () ( void "j_quit" )) +(defentry j_kill () ( void "j_kill" )) +(defentry j_setsize ( int int int ) ( void "j_setsize" )) +(defentry j_getaction () ( int "j_getaction" )) +(defentry j_nextaction () ( int "j_nextaction" )) +(defentry j_show ( int ) ( void "j_show" )) +(defentry j_showpopup ( int int int ) ( void "j_showpopup" )) +(defentry j_add ( int int ) ( void "j_add" )) +(defentry j_release ( int ) ( void "j_release" )) +(defentry j_releaseall ( int ) ( void "j_releaseall" )) +(defentry j_hide ( int ) ( void "j_hide" )) +(defentry j_dispose ( int ) ( void "j_dispose" )) +(defentry j_setpos ( int int int ) ( void "j_setpos" )) +(defentry j_getviewportheight ( int ) ( int "j_getviewportheight" )) +(defentry j_getviewportwidth ( int ) ( int "j_getviewportwidth" )) +(defentry j_getxpos ( int ) ( int "j_getxpos" )) +(defentry j_getypos ( int ) ( int "j_getypos" )) +;(defentry j_getpos ( int int* int* ) ( void "j_getpos" )) +(defentry j_getpos ( int int int ) ( void "j_getpos" )) +(defentry j_getparentid ( int ) ( int "j_getparentid" )) +(defentry j_setfocus ( int ) ( void "j_setfocus" )) +(defentry j_hasfocus ( int ) ( int "j_hasfocus" )) +(defentry j_getstringwidth ( int string ) ( int "j_getstringwidth" )) +(defentry j_getfontheight ( int ) ( int "j_getfontheight" )) +(defentry j_getfontascent ( int ) ( int "j_getfontascent" )) +(defentry j_keylistener ( int ) ( int "j_keylistener" )) +(defentry j_getkeycode ( int ) ( int "j_getkeycode" )) +(defentry j_getkeychar ( int ) ( int "j_getkeychar" )) +(defentry j_mouselistener ( int int ) ( int "j_mouselistener" )) +(defentry j_getmousex ( int ) ( int "j_getmousex" )) +(defentry j_getmousey ( int ) ( int "j_getmousey" )) +;(defentry j_getmousepos ( int int* int* ) ( void "j_getmousepos" )) +(defentry j_getmousepos ( int int int ) ( void "j_getmousepos" )) +(defentry j_getmousebutton ( int ) ( int "j_getmousebutton" )) +(defentry j_focuslistener ( int ) ( int "j_focuslistener" )) +(defentry j_componentlistener ( int int ) ( int "j_componentlistener" )) +(defentry j_windowlistener ( int int ) ( int "j_windowlistener" )) +(defentry j_setflowlayout ( int int ) ( void "j_setflowlayout" )) +(defentry j_setborderlayout ( int ) ( void "j_setborderlayout" )) +(defentry j_setgridlayout ( int int int ) ( void "j_setgridlayout" )) +(defentry j_setfixlayout ( int ) ( void "j_setfixlayout" )) +(defentry j_setnolayout ( int ) ( void "j_setnolayout" )) +(defentry j_setborderpos ( int int ) ( void "j_setborderpos" )) +(defentry j_sethgap ( int int ) ( void "j_sethgap" )) +(defentry j_setvgap ( int int ) ( void "j_setvgap" )) +(defentry j_setinsets ( int int int int int ) ( void "j_setinsets" )) +(defentry j_setalign ( int int ) ( void "j_setalign" )) +(defentry j_setflowfill ( int int ) ( void "j_setflowfill" )) +(defentry j_translate ( int int int ) ( void "j_translate" )) +(defentry j_cliprect ( int int int int int ) ( void "j_cliprect" )) +(defentry j_drawrect ( int int int int int ) ( void "j_drawrect" )) +(defentry j_fillrect ( int int int int int ) ( void "j_fillrect" )) +(defentry j_drawroundrect ( int int int int int int int ) ( void "j_drawroundrect" )) +(defentry j_fillroundrect ( int int int int int int int ) ( void "j_fillroundrect" )) +(defentry j_drawoval ( int int int int int ) ( void "j_drawoval" )) +(defentry j_filloval ( int int int int int ) ( void "j_filloval" )) +(defentry j_drawcircle ( int int int int ) ( void "j_drawcircle" )) +(defentry j_fillcircle ( int int int int ) ( void "j_fillcircle" )) +(defentry j_drawarc ( int int int int int int int ) ( void "j_drawarc" )) +(defentry j_fillarc ( int int int int int int int ) ( void "j_fillarc" )) +(defentry j_drawline ( int int int int int ) ( void "j_drawline" )) +;(defentry j_drawpolyline ( int int int* int* ) ( void "j_drawpolyline" )) +;(defentry j_drawpolygon ( int int int* int* ) ( void "j_drawpolygon" )) +;(defentry j_fillpolygon ( int int int* int* ) ( void "j_fillpolygon" )) +(defentry j_drawpolyline ( int int int int ) ( void "j_drawpolyline" )) +(defentry j_drawpolygon ( int int int int ) ( void "j_drawpolygon" )) +(defentry j_fillpolygon ( int int int int ) ( void "j_fillpolygon" )) +(defentry j_drawpixel ( int int int ) ( void "j_drawpixel" )) +(defentry j_drawstring ( int int int string ) ( void "j_drawstring" )) +(defentry j_setxor ( int int ) ( void "j_setxor" )) +(defentry j_getimage ( int ) ( int "j_getimage" )) +;(defentry j_getimagesource ( int int int int int int* int* int* ) ( void "j_getimagesource" )) +;(defentry j_drawimagesource ( int int int int int int* int* int* ) ( void "j_drawimagesource" )) +(defentry j_getimagesource ( int int int int int int int int ) ( void "j_getimagesource" )) +(defentry j_drawimagesource ( int int int int int int int int ) ( void "j_drawimagesource" )) +(defentry j_getscaledimage ( int int int int int int int ) ( int "j_getscaledimage" )) +(defentry j_drawimage ( int int int int ) ( void "j_drawimage" )) +(defentry j_drawscaledimage ( int int int int int int int int int int ) ( void "j_drawscaledimage" )) +(defentry j_setcolor ( int int int int ) ( void "j_setcolor" )) +(defentry j_setcolorbg ( int int int int ) ( void "j_setcolorbg" )) +(defentry j_setnamedcolor ( int int ) ( void "j_setnamedcolor" )) +(defentry j_setnamedcolorbg ( int int ) ( void "j_setnamedcolorbg" )) +(defentry j_loadimage ( string ) ( int "j_loadimage" )) +(defentry j_saveimage ( int string int ) ( int "j_saveimage" )) +(defentry j_sync () ( void "j_sync" )) +(defentry j_beep () ( void "j_beep" )) +(defentry j_random () ( int "j_random" )) +(defentry j_sleep ( int ) ( void "j_sleep" )) + + diff --git a/lsp/gcl_listlib.lsp b/lsp/gcl_listlib.lsp new file mode 100755 index 0000000..128442b --- /dev/null +++ b/lsp/gcl_listlib.lsp @@ -0,0 +1,188 @@ +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +;;;; listlib.lsp +;;;; +;;;; list manipulating routines + +; Rewritten 11 Feb 1993 by William Schelter and Gordon Novak to use iteration +; rather than recursion, as needed for large data sets. + + +(in-package 'lisp) + +(export '(union nunion intersection nintersection + set-difference nset-difference set-exclusive-or nset-exclusive-or + subsetp nth nth-value nthcdr first second third fourth fifth sixth seventh eighth ninth tenth)) + +(in-package 'system) + +(eval-when (compile) + (proclaim '(optimize (safety 0) (space 3))) + ) + + +(macrolet + ((defl2fn (n &rest body) `(defun ,n (list1 list2 &key key test test-not &aux r rp + (key (when key (coerce key 'function))) + (test (when test (coerce test 'function))) + (test-not (when test-not (coerce test-not 'function)))) + (macrolet + ((check-list (list) `(do ((l ,list (cdr l))) + ((not (consp l)) + (when l (error 'type-error :datum l :expected-type 'list))))) + (apply-to-stack (form list) `(let (r rp) + (dolist (l ,list r) + (let ((tmp (cons ,(if form `(,@form l) `l) nil))) + (declare (dynamic-extent tmp)) + (setq rp (if rp (cdr (rplacd rp tmp)) (setq r tmp))))))) + (collect (x) `(let ((temp ,x)) + (setq rp (if rp (cdr (rplacd rp temp)) (setq r temp))))) + (do-test (x z) `(cond (test (funcall test ,x ,z)) + (test-not (not (funcall test-not ,x ,z))) + ((eql ,x ,z)))) + (memb (item list &optional rev) `(do ((item ,item)(l ,list (cdr l))) ((not l)) + (let ((cl (car l))) + (when (do-test ,@(if rev `(cl item) `(item cl))) + (return l)))))) + (check-list list1)(check-list list2) + (let ((klist2 (if key (apply-to-stack (funcall key) list2) list2))) + ,@body))))) + + (defl2fn intersection + (dolist (l1 list1 r) + (when (memb (if key (funcall key l1) l1) klist2) + (collect (cons l1 nil))))) + + (defl2fn union + (dolist (l1 list1) + (unless (memb (if key (funcall key l1) l1) klist2) + (collect (cons l1 nil)))) + (when rp (rplacd rp list2)) + (or r list2)) + + (defl2fn set-difference + (dolist (l1 list1 r) + (unless (memb (if key (funcall key l1) l1) klist2) + (collect (cons l1 nil))))) + + (defl2fn set-exclusive-or + (let ((klist1 (if key (apply-to-stack (funcall key) list1) list1))) + (do ((kl1 klist1 (cdr kl1))(l1 list1 (cdr l1))) ((not kl1)) + (unless (memb (car kl1) klist2) + (collect (cons (car l1) nil)))) + (do ((kl2 klist2 (cdr kl2))(l2 list2 (cdr l2))) ((not kl2) r) + (unless (memb (car kl2) klist1 t) + (collect (cons (car l2) nil)))))) + + (defl2fn nintersection + (do ((l1 list1 (cdr l1)))((not l1) (when rp (rplacd rp nil)) r) + (let ((cl1 (car l1))) + (when (memb (if key (funcall key cl1) cl1) klist2) + (collect l1))))) + + (defl2fn nunion + (do ((l1 list1 (cdr l1)))((not l1) (when rp (rplacd rp list2)) (or r list2)) + (let ((cl1 (car l1))) + (unless (memb (if key (funcall key cl1) cl1) klist2) + (collect l1))))) + + (defl2fn nset-difference + (do ((l1 list1 (cdr l1)))((not l1) (when rp (rplacd rp nil)) r) + (let ((cl1 (car l1))) + (unless (memb (if key (funcall key cl1) cl1) klist2) + (collect l1))))) + + (defl2fn nset-exclusive-or + (let ((klist1 (if key (apply-to-stack (funcall key) list1) (apply-to-stack nil list1)))) + (do ((kl1 klist1 (cdr kl1))(l1 list1 (cdr l1))) ((not kl1)) + (unless (memb (car kl1) klist2) + (collect l1))) + (do ((kl2 klist2 (cdr kl2))(l2 list2 (cdr l2))) ((not kl2) (when rp (rplacd rp nil)) r) + (unless (memb (car kl2) klist1 t) + (collect l2))))) + + (defl2fn subsetp r rp + (dolist (l1 list1 t) + (unless (memb (if key (funcall key l1) l1) klist2) + (return nil))))) + + +(defmacro tp-error (x y) + `(error 'type-error :datum ,x :expected-type ',y)) + +(defun smallnthcdr (n x) + (declare (fixnum n)) + (cond ((atom x) (when x (tp-error x proper-list))) + ((= n 0) x) + ((smallnthcdr (1- n) (cdr x))))) + +(defun bignthcdr (n i s f) + (declare (fixnum i)) + (cond ((atom f) (when f (tp-error f proper-list))) + ((atom (cdr f)) (when (cdr f) (tp-error (cdr f) proper-list))) + ((eq s f) (smallnthcdr (mod n i) s)) + ((bignthcdr n (1+ i) (cdr s) (cddr f))))) + +(defun nthcdr (n x) + (declare (optimize (safety 1))) + (cond ((or (not (integerp n)) (minusp n)) (tp-error n (integer 0))) + ((< n array-dimension-limit) (smallnthcdr n x)) + ((atom x) (when x (tp-error x proper-list))) + ((atom (cdr x)) (when (cdr x) (tp-error (cdr x) proper-list))) + ((bignthcdr n 1 (cdr x) (cddr x))))) + +(defun nth (n x) + (declare (optimize (safety 2))) + (car (nthcdr n x))) +(defun first (x) + (declare (optimize (safety 2))) + (car x)) +(defun second (x) + (declare (optimize (safety 2))) + (cadr x)) +(defun third (x) + (declare (optimize (safety 2))) + (caddr x)) +(defun fourth (x) + (declare (optimize (safety 2))) + (cadddr x)) +(defun fifth (x) + (declare (optimize (safety 2))) + (car (cddddr x))) +(defun sixth (x) + (declare (optimize (safety 2))) + (cadr (cddddr x))) +(defun seventh (x) + (declare (optimize (safety 2))) + (caddr (cddddr x))) +(defun eighth (x) + (declare (optimize (safety 2))) + (cadddr (cddddr x))) +(defun ninth (x) + (declare (optimize (safety 2))) + (car (cddddr (cddddr x)))) +(defun tenth (x) + (declare (optimize (safety 2))) + (cadr (cddddr (cddddr x)))) + +; Courtesy Paul Dietz +(defmacro nth-value (n expr) + (declare (optimize (safety 1))) + `(nth ,n (multiple-value-list ,expr))) diff --git a/lsp/gcl_littleXlsp.lsp b/lsp/gcl_littleXlsp.lsp new file mode 100755 index 0000000000000000000000000000000000000000..966d8fc30e4edaa8d45d9bb47f6494f795d5eb8c GIT binary patch literal 6572 zcmeHLZExGi5$CZ`dN7u4g5QQZ^{*;FGQ%&NN=klLuD+ zlm=mUD>z(LGbPi*MXC;!Ssf~AtrEBRb)*C8ZR=)pEsK$+NZrOUex?D8y3v%p*D`|) zHocL&UdnXI@Z}Xgl`w`@y0pnmiDxuevmvues*KODnb3k{4uhN_taFlOgIBjV*XM7) z{QZxwFR!kD?rAaj_Ufy*U$QRv&hfn%z@f})d6*~ZQWj#AiMe@3rO5mSI7Yk#NZkH2 z2WlzuwXj%WP-J>N95(Bdo%K=}`GcqlX&uvK zJf`?~j3ZlH6Pi39(`0fCrC3ZfOVYbVsVl@9&ILdYE)G*AlCtIJMMra8ikdc>^{e>@%nF*2y#uk=>xxDv?I1P~6*1>d6mwrvlzQu~bM!!IOVXo*j&DyFUZ3c08`_?*0O$!L#qR2^PJN`+kGN z*~Pm+ITMpIrS+tCBYP~2oa1V!hlG`O%(fzgGl#F z8tKqkLY#G15d1$q;j+co-5I?`$-<50>2arC3tN>%{Wo1*y6d^XwP?jcl!!wy$L)%W z*r|0C0vCz=5IE|{=xNRpYB_Fw zM-Xb@#uCO%q6tV*7PuQ2{Su*_V%igm^(~>7@E2sddW!B~gX3e;82K&&6Cj|(+#;2X zrF*E2ke5YbxwGh#9)Z;Am8X3880B+N`bd17>oI6&+FG6OVca_1)e2{=^Edmv^Idy~ ziKa}%6^+$@#U;IgX5)ee&?p zsNN2qe_NcbWoBKWGViLS+>Kg}uchF!$eH;8q7x7qo0OJ&td%yBhk;Y{fD1I!Xs=x8 z9G#9)`nC;wfuo{u&Fc0+zN%f!c{a^i=kX>_x;X;cCPgl|gM$#~_DL{Y{ViDY?(YUH4zRaq!pOiG^6By+RG%sf^q&@UE}E zopRM5HM?>D0&-R`H6<-aa63rK6)FqeMHGznkJP+HzIj`OQOq;8y@Al z7vhecTTSHl1;IC;Ypn6egzIJJIK%Xb9T@jjdpj^Z;B4AscNwt22=@>7NP6~nk#5?h z?lr(vZZyLSR>8N@<}8K2WyY<@N~1A+a3j@*0L*KOaDibgjcP*wF?0v&Cd}V34uanO zvV%kq$erE)G>*QqJ_@Aoq;`;OPk#u?mf{y+`Bqpi(|+(p3gF@CjTEFyy5L!L2Q-HC z;LX)5rZ~9x=JoYuCsMk@E_CQ*19rGhOnJWU1xWV@g&4dejh4iZ$(Xq1oI>%Ay6g3L z&e2uBW;FUkB<9Bb8)Kevoi*RNq+fAwmR1U_ihFNy3E7?P_FC>p3(R^Qqno*z4fdH) zX9PB;e4uA(*9}oRj&d#!}~Ol@UarmMWOSsC^{a zXogK8H)jEjkv9RJuldO&G|?Z89T__{Ld}O~0rvROs(CNzvYB>a+ardZcK8&p;QZ`e z@o?hnKVIvL3J=|wKyvpwkkQjaCj +;;;> Portions of LOOP are Copyright (c) 1986 by the Massachusetts Institute of Technology. +;;;> All Rights Reserved. +;;;> +;;;> Permission to use, copy, modify and distribute this software and its +;;;> documentation for any purpose and without fee is hereby granted, +;;;> provided that the M.I.T. copyright notice appear in all copies and that +;;;> both that copyright notice and this permission notice appear in +;;;> supporting documentation. The names "M.I.T." and "Massachusetts +;;;> Institute of Technology" may not be used in advertising or publicity +;;;> pertaining to distribution of the software without specific, written +;;;> prior permission. Notice must be given in supporting documentation that +;;;> copying distribution is by permission of M.I.T. M.I.T. makes no +;;;> representations about the suitability of this software for any purpose. +;;;> It is provided "as is" without express or implied warranty. +;;;> +;;;> Massachusetts Institute of Technology +;;;> 77 Massachusetts Avenue +;;;> Cambridge, Massachusetts 02139 +;;;> United States of America +;;;> +1-617-253-1000 +;;;> +;;;> Portions of LOOP are Copyright (c) 1989, 1990, 1991, 1992 by Symbolics, Inc. +;;;> All Rights Reserved. +;;;> +;;;> Permission to use, copy, modify and distribute this software and its +;;;> documentation for any purpose and without fee is hereby granted, +;;;> provided that the Symbolics copyright notice appear in all copies and +;;;> that both that copyright notice and this permission notice appear in +;;;> supporting documentation. The name "Symbolics" may not be used in +;;;> advertising or publicity pertaining to distribution of the software +;;;> without specific, written prior permission. Notice must be given in +;;;> supporting documentation that copying distribution is by permission of +;;;> Symbolics. Symbolics makes no representations about the suitability of +;;;> this software for any purpose. It is provided "as is" without express +;;;> or implied warranty. +;;;> +;;;> Symbolics, CLOE Runtime, and Minima are trademarks, and CLOE, Genera, +;;;> and Zetalisp are registered trademarks of Symbolics, Inc. +;;;> +;;;> Symbolics, Inc. +;;;> 8 New England Executive Park, East +;;;> Burlington, Massachusetts 01803 +;;;> United States of America +;;;> +1-617-221-1000 + +;; $aclHeader: loop.cl,v 1.5 91/12/04 01:13:48 cox acl4_1 $ + +#+cmu +(ext:file-comment + "$Header$") + +;;;; LOOP Iteration Macro + +#+allegro +(in-package :excl) +#+ecls +(in-package "SI") + +#-(or allegro ecls) +(in-package :ansi-loop) + +(export '(loop loop-finish)) + +#-ecls +(provide :loop) + +#+Cloe-Runtime ;Don't ask. +(car (push "%Z% %M% %I% %E% %U%" system::*module-identifications*)) + +;;; Technology. +;;; +;;; The LOOP iteration macro is one of a number of pieces of code +;;; originally developed at MIT for which free distribution has been +;;; permitted, as long as the code is not sold for profit, and as long +;;; as notification of MIT's interest in the code is preserved. +;;; +;;; This version of LOOP, which is almost entirely rewritten both as +;;; clean-up and to conform with the ANSI Lisp LOOP standard, started +;;; life as MIT LOOP version 829 (which was a part of NIL, possibly +;;; never released). +;;; +;;; A "light revision" was performed by me (Glenn Burke) while at +;;; Palladian Software in April 1986, to make the code run in Common +;;; Lisp. This revision was informally distributed to a number of +;;; people, and was sort of the "MIT" version of LOOP for running in +;;; Common Lisp. +;;; +;;; A later more drastic revision was performed at Palladian perhaps a +;;; year later. This version was more thoroughly Common Lisp in style, +;;; with a few miscellaneous internal improvements and extensions. I +;;; have lost track of this source, apparently never having moved it to +;;; the MIT distribution point. I do not remember if it was ever +;;; distributed. +;;; +;;; This revision for the ANSI standard is based on the code of my April +;;; 1986 version, with almost everything redesigned and/or rewritten. + + +;;; The design of this LOOP is intended to permit, using mostly the same +;;; kernel of code, up to three different "loop" macros: +;;; +;;; (1) The unextended, unextensible ANSI standard LOOP; +;;; +;;; (2) A clean "superset" extension of the ANSI LOOP which provides +;;; functionality similar to that of the old LOOP, but "in the style of" +;;; the ANSI LOOP. For instance, user-definable iteration paths, with a +;;; somewhat cleaned-up interface. +;;; +;;; (3) Extensions provided in another file which can make this LOOP +;;; kernel behave largely compatibly with the Genera-vintage LOOP macro, +;;; with only a small addition of code (instead of two whole, separate, +;;; LOOP macros). +;;; +;;; Each of the above three LOOP variations can coexist in the same LISP +;;; environment. +;;; + + +;;;; Miscellaneous Environment Things + + + +;;;The LOOP-Prefer-POP feature makes LOOP generate code which "prefers" to use POP or +;;; its obvious expansion (prog1 (car x) (setq x (cdr x))). Usually this involves +;;; shifting fenceposts in an iteration or series of carcdr operations. This is +;;; primarily recognized in the list iterators (FOR .. {IN,ON}), and LOOP's +;;; destructuring setq code. +(eval-when (compile load eval) + #+(or Genera Minima) (pushnew :LOOP-Prefer-POP *features*) + ) + + +;;; The uses of this macro are retained in the CL version of loop, in +;;; case they are needed in a particular implementation. Originally +;;; dating from the use of the Zetalisp COPYLIST* function, this is used +;;; in situations where, were cdr-coding in use, having cdr-NIL at the +;;; end of the list might be suboptimal because the end of the list will +;;; probably be RPLACDed and so cdr-normal should be used instead. +(defmacro loop-copylist* (l) + #+Genera `(lisp:copy-list ,l nil t) ; arglist = (list &optional area force-dotted) + ;;Explorer?? + #-Genera `(copy-list ,l) + ) + + +(defvar *loop-gentemp* + nil) + +(defun loop-gentemp (&optional (pref 'loopvar-)) + (if *loop-gentemp* + (gentemp (string pref)) + (gensym))) + + + +(defvar *loop-real-data-type* 'real) + + +(defun loop-optimization-quantities (env) + ;; The ANSI conditionalization here is for those lisps that implement + ;; DECLARATION-INFORMATION (from cleanup SYNTACTIC-ENVIRONMENT-ACCESS). + ;; It is really commentary on how this code could be written. I don't + ;; actually expect there to be an ANSI #+-conditional -- it should be + ;; replaced with the appropriate conditional name for your + ;; implementation/dialect. + (declare #-ANSI (ignore env) + #+Genera (values speed space safety compilation-speed debug)) + #+ANSI (let ((stuff (declaration-information 'optimize env))) + (values (or (cdr (assoc 'speed stuff)) 1) + (or (cdr (assoc 'space stuff)) 1) + (or (cdr (assoc 'safety stuff)) 1) + (or (cdr (assoc 'compilation-speed stuff)) 1) + (or (cdr (assoc 'debug stuff)) 1))) + #+CLOE-Runtime (values compiler::time compiler::space + compiler::safety compiler::compilation-speed 1) + #-(or ANSI CLOE-Runtime) (values 1 1 1 1 1)) + + +;;; The following form takes a list of variables and a form which presumably +;;; references those variables, and wraps it somehow so that the compiler does not +;;; consider those variables have been referenced. The intent of this is that +;;; iteration variables can be flagged as unused by the compiler, e.g. I in +;;; (loop for i from 1 to 10 do (print t)), since we will tell it when a usage +;;; of it is "invisible" or "not to be considered". +;;;We implicitly assume that a setq does not count as a reference. That is, the +;;; kind of form generated for the above loop construct to step I, simplified, is +;;; `(SETQ I ,(HIDE-VARIABLE-REFERENCES '(I) '(1+ I))). +(defun hide-variable-references (variable-list form) + (declare #-Genera (ignore variable-list)) + #+Genera (if variable-list `(compiler:invisible-references ,variable-list ,form) form) + #-Genera form) + + +;;; The following function takes a flag, a variable, and a form which presumably +;;; references that variable, and wraps it somehow so that the compiler does not +;;; consider that variable to have been referenced. The intent of this is that +;;; iteration variables can be flagged as unused by the compiler, e.g. I in +;;; (loop for i from 1 to 10 do (print t)), since we will tell it when a usage +;;; of it is "invisible" or "not to be considered". +;;;We implicitly assume that a setq does not count as a reference. That is, the +;;; kind of form generated for the above loop construct to step I, simplified, is +;;; `(SETQ I ,(HIDE-VARIABLE-REFERENCES T 'I '(1+ I))). +;;;Certain cases require that the "invisibility" of the reference be conditional upon +;;; something. This occurs in cases of "named" variables (the USING clause). For instance, +;;; we want IDX in (LOOP FOR E BEING THE VECTOR-ELEMENTS OF V USING (INDEX IDX) ...) +;;; to be "invisible" when it is stepped, so that the user gets informed if IDX is +;;; not referenced. However, if no USING clause is present, we definitely do not +;;; want to be informed that some random gensym is not used. +;;;It is easier for the caller to do this conditionally by passing a flag (which +;;; happens to be the second value of NAMED-VARIABLE, q.v.) to this function than +;;; for all callers to contain the conditional invisibility construction. +(defun hide-variable-reference (really-hide variable form) + (declare #-Genera (ignore really-hide variable)) + #+Genera (if (and really-hide variable (atom variable)) ;Punt on destructuring patterns + `(compiler:invisible-references (,variable) ,form) + form) + #-Genera form) + + +;;;; List Collection Macrology + + +(defmacro with-loop-list-collection-head ((head-var tail-var &optional user-head-var) + &body body) + ;; TI? Exploder? + #+LISPM (let ((head-place (or user-head-var head-var))) + `(let* ((,head-place nil) + (,tail-var + ,(hide-variable-reference + user-head-var user-head-var + `(progn #+Genera (scl:locf ,head-place) + #-Genera (system:variable-location ,head-place))))) + ,@body)) + #-LISPM (let ((l (and user-head-var (list (list user-head-var nil))))) + #+CLOE `(sys::with-stack-list* (,head-var nil nil) + (let ((,tail-var ,head-var) ,@l) + ,@body)) + #-CLOE `(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) + (declare + #+LISPM (ignore head-var user-head-var) ;use locatives, unconditionally update through the tail. + ) + (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))))) + (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)))) + ;; Because the last element is going to be RPLACDed, + ;; we don't want the cdr-coded implementations to use + ;; cdr-nil at the end (which would just force copying + ;; the whole list again). + #+LISPM (setq tail-form `(list* ,@(cdr form) nil))) + ((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. + #-LISPM (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) + (or user-head-var + (progn + ;;If we use locatives to get tail-updating to update the head var, + ;; then the head var itself contains the answer. Otherwise we + ;; have to cdr it. + #+LISPM head-var + #-LISPM `(cdr ,head-var)))) + + +;;;; Maximization Technology + + +#| +The basic idea of all this minimax randomness here is that we have to +have constructed all uses of maximize and minimize to a particular +"destination" before we can decide how to code them. The goal is to not +have to have any kinds of flags, by knowing both that (1) the type is +something which we can provide an initial minimum or maximum value for +and (2) know that a MAXIMIZE and MINIMIZE are not being combined. + +SO, we have a datastructure which we annotate with all sorts of things, +incrementally updating it as we generate loop body code, and then use +a wrapper and internal macros to do the coding when the loop has been +constructed. +|# + + +(defstruct (loop-minimax + #+ecls (:type vector) + (:constructor make-loop-minimax-internal) + #+nil (:copier nil) + #+nil (:predicate nil)) + answer-variable + type + temp-variable + flag-variable + operations + infinity-data) + + +(defvar *loop-minimax-type-infinities-alist* + ;; This is the sort of value this should take on for a Lisp that has + ;; "eminently usable" infinities. n.b. there are neither constants nor + ;; printed representations for infinities defined by CL. + ;; This grotesque read-from-string below is to help implementations + ;; which croak on the infinity character when it appears in a token, even + ;; conditionalized out. +; #+Genera +; '#.(read-from-string +; "((fixnum most-positive-fixnum most-negative-fixnum) +; (short-float +1s -1s) +; (single-float +1f -1f) +; (double-float +1d -1d) +; (long-float +1l -1l))") + ;;This is how the alist should look for a lisp that has no infinities. In + ;; that case, MOST-POSITIVE-x-FLOAT really IS the most positive. + #+(or CLOE-Runtime Minima) + '((fixnum most-positive-fixnum most-negative-fixnum) + (short-float most-positive-short-float most-negative-short-float) + (single-float most-positive-single-float most-negative-single-float) + (double-float most-positive-double-float most-negative-double-float) + (long-float most-positive-long-float most-negative-long-float)) + ;; CMUCL has infinities so let's use them. + #+CMU + '((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: + #-(or Genera CLOE-Runtime Minima CMU) + '((fixnum most-positive-fixnum most-negative-fixnum)) + ) + + +(defun make-loop-minimax (answer-variable type) + (let ((infinity-data (cdr (assoc type *loop-minimax-type-infinities-alist* :test #'subtypep)))) + (make-loop-minimax-internal + :answer-variable answer-variable + :type type + :temp-variable (loop-gentemp 'loop-maxmin-temp-) + :flag-variable (and (not infinity-data) (loop-gentemp 'loop-maxmin-flag-)) + :operations nil + :infinity-data infinity-data))) + + +(defun loop-note-minimax-operation (operation minimax) + (pushnew (the symbol operation) (loop-minimax-operations minimax)) + (when (and (cdr (loop-minimax-operations minimax)) + (not (loop-minimax-flag-variable minimax))) + (setf (loop-minimax-flag-variable minimax) (loop-gentemp '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))) + (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)))) + + +(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 + (hide-variable-reference + t (loop-minimax-answer-variable lm) + `(,(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))))) + + + +;;;; Loop Keyword Tables + + +#| +LOOP keyword tables are hash tables string keys and a test of EQUAL. + +The actual descriptive/dispatch structure used by LOOP is called a "loop +universe" contains a few tables and parameterizations. The basic idea is +that we can provide a non-extensible ANSI-compatible loop environment, +an extensible ANSI-superset loop environment, and (for such environments +as CLOE) one which is "sufficiently close" to the old Genera-vintage +LOOP for use by old user programs without requiring all of the old LOOP +code to be loaded. +|# + + +;;;; Token Hackery + + +;;;Compare two "tokens". The first is the frob out of *LOOP-SOURCE-CODE*, +;;; the second a symbol to check against. +(defun loop-tequal (x1 x2) + (and (symbolp x1) (string= x1 x2))) + + +(defun loop-tassoc (kwd alist) + (and (symbolp kwd) (assoc kwd alist :test #'string=))) + + +(defun loop-tmember (kwd list) + (and (symbolp kwd) (member kwd list :test #'string=))) + + +(defun loop-lookup-keyword (loop-token table) + (and (symbolp loop-token) + (values (gethash (symbol-name loop-token) table)))) + + +(defmacro loop-store-table-data (symbol table datum) + `(setf (gethash (symbol-name ,symbol) ,table) ,datum)) + + +(defstruct (loop-universe + #+ecls (:type vector) + #-ecls (: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 + ) + + +#-ecls +(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))))) + ;;Cloe could be done with the above except for bootstrap lossage... + #+CLOE + (format stream "#<~S ~A ~X>" (type-of u) str (sys::address-of u)) + #+Genera ; This is reallly the ANSI definition. + (print-unreadable-object (u stream :type t :identity t) + (princ str stream)) + #-(or Genera CLOE) + (format stream "#<~S ~A>" (type-of u) str) + )) + + +;;;This is the "current" loop context in use when we are expanding a +;;;loop. It gets bound on each invocation of LOOP. +(defvar *loop-universe*) + + +(defun make-standard-loop-universe (&key keywords for-keywords iteration-keywords path-keywords + type-keywords type-symbols ansi) + #-(and CLOE Source-Bootstrap ecls) (check-type ansi (member nil t :extended)) + (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))) + (make-loop-universe + :keywords (maketable keywords) + :for-keywords (maketable for-keywords) + :iteration-keywords (maketable iteration-keywords) + :path-keywords (maketable path-keywords) + :ansi ansi + :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)))) + + +;;;; Setq Hackery + + +(defvar *loop-destructuring-hooks* + 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.") + + +(defun loop-make-psetq (frobs) + (and frobs + (loop-make-desetq + (list (car frobs) + (if (null (cddr frobs)) (cadr frobs) + `(prog1 ,(cadr frobs) + ,(loop-make-psetq (cddr frobs)))))))) + + +(defun loop-make-desetq (var-val-pairs) + (if (null var-val-pairs) + nil + (cons (if *loop-destructuring-hooks* + (cadr *loop-destructuring-hooks*) + 'loop-really-desetq) + var-val-pairs))) + + +(defvar *loop-desetq-temporary* + (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) + ;; 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-Prefer-POP `(,@(loop-desetq-internal + car + `(prog1 (car ,temp) + (setq ,temp (cdr ,temp)))) + ,@(loop-desetq-internal cdr temp temp)) + #-LOOP-Prefer-POP `(,@(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)))) + (setq actions (nreconc;revappend + (loop-desetq-internal (pop var-val-pairs) (pop var-val-pairs)) + actions))))) + + +;;;; LOOP-local variables + +;;;This is the "current" pointer into the LOOP source code. +(defvar *loop-source-code*) + + +;;;This is the pointer to the original, for things like NAMED that +;;;insist on being in a particular position +(defvar *loop-original-source-code*) + + +;;;This is *loop-source-code* as of the "last" clause. It is used +;;;primarily for generating error messages (see loop-error, loop-warn). +(defvar *loop-source-context*) + + +;;;List of names for the LOOP, supplied by the NAMED clause. +(defvar *loop-names*) + +;;;The macroexpansion environment given to the macro. +(defvar *loop-macro-environment*) + +;;;This holds variable names specified with the USING clause. +;;; See LOOP-NAMED-VARIABLE. +(defvar *loop-named-variables*) + +;;; LETlist-like list being accumulated for one group of parallel bindings. +(defvar *loop-variables*) + +;;;List of declarations being accumulated in parallel with +;;;*loop-variables*. +(defvar *loop-declarations*) + +;;;Used by LOOP for destructuring binding, if it is doing that itself. +;;; See loop-make-variable. +(defvar *loop-desetq-crocks*) + +;;; List of wrapping forms, innermost first, which go immediately inside +;;; the current set of parallel bindings being accumulated in +;;; *loop-variables*. The wrappers are appended onto a body. E.g., +;;; this list could conceivably has as its value ((with-open-file (g0001 +;;; g0002 ...))), with g0002 being one of the bindings in +;;; *loop-variables* (this is why the wrappers go inside of the variable +;;; bindings). +(defvar *loop-wrappers*) + +;;;This accumulates lists of previous values of *loop-variables* and the +;;;other lists above, for each new nesting of bindings. See +;;;loop-bind-block. +(defvar *loop-bind-stack*) + +;;;This is a LOOP-global variable for the (obsolete) NODECLARE clause +;;;which inhibits LOOP from actually outputting a type declaration for +;;;an iteration (or any) variable. +(defvar *loop-nodeclare*) + +;;;This is simply a list of LOOP iteration variables, used for checking +;;;for duplications. +(defvar *loop-iteration-variables*) + + +;;;List of prologue forms of the loop, accumulated in reverse order. +(defvar *loop-prologue*) + +(defvar *loop-before-loop*) +(defvar *loop-body*) +(defvar *loop-after-body*) + +;;;This is T if we have emitted any body code, so that iteration driving +;;;clauses can be disallowed. This is not strictly the same as +;;;checking *loop-body*, because we permit some clauses such as RETURN +;;;to not be considered "real" body (so as to permit the user to "code" +;;;an abnormal return value "in loop"). +(defvar *loop-emitted-body*) + + +;;;List of epilogue forms (supplied by FINALLY generally), accumulated +;;; in reverse order. +(defvar *loop-epilogue*) + +;;;List of epilogue forms which are supplied after the above "user" +;;;epilogue. "normal" termination return values are provide by putting +;;;the return form in here. Normally this is done using +;;;loop-emit-final-value, q.v. +(defvar *loop-after-epilogue*) + +;;;The "culprit" responsible for supplying a final value from the loop. +;;;This is so loop-emit-final-value can moan about multiple return +;;;values being supplied. +(defvar *loop-final-value-culprit*) + +;;;If not NIL, we are in some branch of a conditional. Some clauses may +;;;be disallowed. +(defvar *loop-inside-conditional*) + +;;;If not NIL, this is a temporary bound around the loop for holding the +;;;temporary value for "it" in things like "when (f) collect it". It +;;;may be used as a supertemporary by some other things. +(defvar *loop-when-it-variable*) + +;;;Sometimes we decide we need to fold together parts of the loop, but +;;;some part of the generated iteration code is different for the first +;;;and remaining iterations. This variable will be the temporary which +;;;is the flag used in the loop to tell whether we are in the first or +;;;remaining iterations. +(defvar *loop-never-stepped-variable*) + +;;;List of all the value-accumulation descriptor structures in the loop. +;;; See loop-get-collection-info. +(defvar *loop-collection-cruft*) ; for multiple COLLECTs (etc) + +;;;Flag indicating value accumulation without into +(defvar *loop-collection-no-into*) + + + + + +;;;; Code Analysis Stuff + + +(defun loop-constant-fold-if-possible (form &optional expected-type) + #+Genera (declare (values new-form constantp constant-value)) + (let ((new-form form) (constantp nil) (constant-value nil)) + #+Genera (setq new-form (compiler:optimize-form form *loop-macro-environment* + :repeat t + :do-macro-expansion t + :do-named-constants t + :do-inline-forms t + :do-optimizers t + :do-constant-folding t + :do-function-args t) + constantp (constantp new-form *loop-macro-environment*) + constant-value (and constantp (lt:evaluate-constant new-form *loop-macro-environment*))) + #-Genera (when (setq constantp (constantp new-form)) + (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))) + (values new-form constantp constant-value))) + + +(defun loop-constantp (form) + #+Genera (constantp form *loop-macro-environment*) + #-Genera (constantp form)) + + +;;;; LOOP Iteration Optimization + +(defvar *loop-duplicate-code* + nil) + + +(defvar *loop-iteration-flag-variable* + (make-symbol "LOOP-NOT-FIRST-TIME")) + + +(defun loop-code-duplication-threshold (env) + (multiple-value-bind (speed space) (loop-optimization-quantities env) + (+ 40 (* (- speed space) 10)))) + + +(defmacro loop-body (&environment env + prologue + before-loop + main-body + after-loop + epilogue + &aux rbefore rafter flagvar) + (unless (= (length before-loop) (length after-loop)) + (error "LOOP-BODY called with non-synched before- and after-loop lists.")) + ;;All our work is done from these copies, working backwards from the end: + (setq rbefore (reverse before-loop) rafter (reverse after-loop)) + (labels ((psimp (l) + (let ((ans nil)) + (dolist (x l) + (when x + (push x ans) + (when (and (consp x) (member (car x) '(go return return-from))) + (return nil)))) + (nreverse ans))) + (pify (l) (if (null (cdr l)) (car l) `(progn ,@l))) + (makebody () + (let ((form `(tagbody + ,@(psimp (append prologue (nreverse rbefore))) + next-loop + ,@(psimp (append main-body (nreconc rafter `((go next-loop))))) + end-loop + ,@(psimp epilogue)))) + (if flagvar `(let ((,flagvar nil)) ,form) form)))) + (when (or *loop-duplicate-code* (not rbefore)) + (return-from loop-body (makebody))) + ;; This outer loop iterates once for each not-first-time flag test generated + ;; plus once more for the forms that don't need a flag test + (do ((threshold (loop-code-duplication-threshold env))) (nil) + (declare (fixnum threshold)) + ;; Go backwards from the ends of before-loop and after-loop merging all the equivalent + ;; forms into the body. + (do () ((or (null rbefore) (not (equal (car rbefore) (car rafter))))) + (push (pop rbefore) main-body) + (pop rafter)) + (unless rbefore (return (makebody))) + ;; The first forms in rbefore & rafter (which are the chronologically + ;; last forms in the list) differ, therefore they cannot be moved + ;; into the main body. If everything that chronologically precedes + ;; them either differs or is equal but is okay to duplicate, we can + ;; just put all of rbefore in the prologue and all of rafter after + ;; the body. Otherwise, there is something that is not okay to + ;; duplicate, so it and everything chronologically after it in + ;; rbefore and rafter must go into the body, with a flag test to + ;; distinguish the first time around the loop from later times. + ;; What chronologically precedes the non-duplicatable form will + ;; be handled the next time around the outer loop. + (do ((bb rbefore (cdr bb)) (aa rafter (cdr aa)) (lastdiff nil) (count 0) (inc nil)) + ((null bb) (return-from loop-body (makebody))) ;Did it. + (cond ((not (equal (car bb) (car aa))) (setq lastdiff bb count 0)) + ((or (not (setq inc (estimate-code-size (car bb) env))) + (> (incf count inc) threshold)) + ;; Ok, we have found a non-duplicatable piece of code. Everything + ;; chronologically after it must be in the central body. + ;; Everything chronologically at and after lastdiff goes into the + ;; central body under a flag test. + (let ((then nil) (else nil)) + (do () (nil) + (push (pop rbefore) else) + (push (pop rafter) then) + (when (eq rbefore (cdr lastdiff)) (return))) + (unless flagvar + (push `(setq ,(setq flagvar *loop-iteration-flag-variable*) t) else)) + (push `(if ,flagvar ,(pify (psimp then)) ,(pify (psimp else))) + main-body)) + ;; Everything chronologically before lastdiff until the non-duplicatable form (car bb) + ;; is the same in rbefore and rafter so just copy it into the body + (do () (nil) + (pop rafter) + (push (pop rbefore) main-body) + (when (eq rbefore (cdr bb)) (return))) + (return))))))) + + + +(defun duplicatable-code-p (expr env) + (if (null expr) 0 + (let ((ans (estimate-code-size expr env))) + (declare (fixnum ans)) + ;; Use (DECLARATION-INFORMATION 'OPTIMIZE ENV) here to get an alist of + ;; optimize quantities back to help quantify how much code we are willing to + ;; duplicate. + ans))) + + +(defvar *special-code-sizes* + '((return 0) (progn 0) + (null 1) (not 1) (eq 1) (car 1) (cdr 1) + (when 1) (unless 1) (if 1) + (caar 2) (cadr 2) (cdar 2) (cddr 2) + (caaar 3) (caadr 3) (cadar 3) (caddr 3) (cdaar 3) (cdadr 3) (cddar 3) (cdddr 3) + (caaaar 4) (caaadr 4) (caadar 4) (caaddr 4) + (cadaar 4) (cadadr 4) (caddar 4) (cadddr 4) + (cdaaar 4) (cdaadr 4) (cdadar 4) (cdaddr 4) + (cddaar 4) (cddadr 4) (cdddar 4) (cddddr 4))) + + +(defvar *estimate-code-size-punt* + '(block + do do* dolist + flet + labels lambda let let* locally + macrolet multiple-value-bind + prog prog* + symbol-macrolet + tagbody + unwind-protect + with-open-file)) + + +(defun destructuring-size (x) + (do ((x x (cdr x)) (n 0 (+ (destructuring-size (car x)) n))) + ((atom x) (+ n (if (null x) 0 1))))) + + +(defun estimate-code-size (x env) + (catch 'estimate-code-size + (estimate-code-size-1 x env))) + + +(defun estimate-code-size-1 (x env) + (flet ((list-size (l) + (let ((n 0)) + (declare (fixnum n)) + (dolist (x l n) (incf n (estimate-code-size-1 x env)))))) + ;; ???? (declare (function list-size (list) fixnum)) + (cond ((constantp x #+Genera env) 1) + ((symbolp x) (multiple-value-bind (new-form expanded-p) (macroexpand-1 x env) + (if expanded-p (estimate-code-size-1 new-form env) 1))) + ((atom x) 1) ;??? self-evaluating??? + ((symbolp (car x)) + (let ((fn (car x)) (tem nil) (n 0)) + (declare (symbol fn) (fixnum n)) + (macrolet ((f (overhead &optional (args nil args-p)) + `(the fixnum (+ (the fixnum ,overhead) + (the fixnum (list-size ,(if args-p args '(cdr x)))))))) + (cond ((setq tem (get fn 'estimate-code-size)) + (typecase tem + (fixnum (f tem)) + (t (funcall tem x env)))) + ((setq tem (assoc fn *special-code-sizes*)) (f (second tem))) + #+Genera + ((eq fn 'compiler:invisible-references) (list-size (cddr x))) + ((eq fn 'cond) + (dolist (clause (cdr x) n) (incf n (list-size clause)) (incf n))) + ((eq fn 'desetq) + (do ((l (cdr x) (cdr l))) ((null l) n) + (setq n (+ n (destructuring-size (car l)) (estimate-code-size-1 (cadr l) env))))) + ((member fn '(setq psetq)) + (do ((l (cdr x) (cdr l))) ((null l) n) + (setq n (+ n (estimate-code-size-1 (cadr l) env) 1)))) + ((eq fn 'go) 1) + ((eq fn 'function) + ;;This skirts the issue of implementationally-defined lambda macros + ;; by recognizing CL function names and nothing else. + (if (or (symbolp (cadr x)) + (and (consp (cadr x)) (eq (caadr x) 'setf))) + 1 + (throw 'duplicatable-code-p nil))) + ((eq fn 'multiple-value-setq) (f (length (second x)) (cddr x))) + ((eq fn 'return-from) (1+ (estimate-code-size-1 (third x) env))) + ((or (special-operator-p fn) (member fn *estimate-code-size-punt*)) + (throw 'estimate-code-size nil)) + (t (multiple-value-bind (new-form expanded-p) (macroexpand-1 x env) + (if expanded-p + (estimate-code-size-1 new-form env) + (f 3)))))))) + (t (throw 'estimate-code-size nil))))) + + +;;;; Loop Errors + + +(defun loop-context () + (do ((l *loop-source-context* (cdr l)) (new nil (cons (car l) new))) + ((eq l (cdr *loop-source-code*)) (nreverse new)))) + + +(defun loop-error (format-string &rest format-args) + #+(or Genera CLOE) (declare (dbg:error-reporter)) + #+Genera (setq format-args (copy-list format-args)) ;Don't ask. + (error 'program-error :format-control "~?~%Current LOOP context:~{ ~S~}." + :format-arguments (list format-string format-args (loop-context)))) + + +(defun loop-warn (format-string &rest format-args) + (warn "~?~%Current LOOP context:~{ ~S~}." format-string format-args (loop-context))) + + +(defun loop-check-data-type (specified-type required-type + &optional (default-type required-type)) + (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))) + + +;;;INTERFACE: Traditional, ANSI, Lucid. +(defmacro loop-finish () + "Causes the iteration to terminate \"normally\", the same as implicit +termination by an iteration driving clause, or by use of WHILE or +UNTIL -- the epilogue code (if any) will be run, and any implicitly +collected result will be returned as the value of the LOOP." + '(go end-loop)) + + + + +(defun loop-translate (*loop-source-code* *loop-macro-environment* *loop-universe*) + (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-no-into* 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*))))) +; (do () (nil) +; (setq answer `(block ,(pop *loop-names*) ,answer)) +; (unless *loop-names* (return nil))) +; (setq answer `(block ,(car *loop-names*) ,answer)) + (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 + ,@(if crocks + `((destructuring-bind ,@crocks + ,@forms)) + forms))))))) + (setq answer `(block ,(car *loop-names*) ,answer)) + answer))) + + +(defun loop-iteration-driver () + (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)))))))) + + + +(defun loop-pop-source () + (if *loop-source-code* + (pop *loop-source-code*) + (loop-error "LOOP source code ran out when another token was expected."))) + + +(defun loop-get-progn () + (do ((forms (list (loop-pop-source)) (cons (loop-pop-source) forms)) + (nextform (car *loop-source-code*) (car *loop-source-code*))) + ((atom nextform) + (if (null (cdr forms)) (car forms) (cons 'progn (nreverse forms)))))) + + +(defun loop-get-form () + (if *loop-source-code* + (loop-pop-source) + (loop-error "LOOP code ran out where a form was expected."))) + + +(defun loop-construct-return (form) + `(return-from ,(car *loop-names*) ,form)) + + +(defun loop-pseudo-body (form) + (cond ((or *loop-emitted-body* *loop-inside-conditional*) (push form *loop-body*)) + (t (push form *loop-before-loop*) (push form *loop-after-body*)))) + +(defun loop-emit-body (form) + (setq *loop-emitted-body* t) + (loop-pseudo-body form)) + +(defun loop-emit-final-value (form) + (push (loop-construct-return form) *loop-after-epilogue*) + (when *loop-final-value-culprit* + (if *loop-collection-no-into* + (error 'program-error :format-control "LOOP clause is providing a value for the iteration,~@ + however one was already established by a ~S clause." + :format-arguments (list *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*))) + (setq *loop-final-value-culprit* (car *loop-source-context*))) + + +(defun loop-disallow-conditional (&optional kwd) + #+(or Genera CLOE) (declare (dbg:error-reporter)) + (when *loop-inside-conditional* + (loop-error "~:[This LOOP~;The LOOP ~:*~S~] clause is not permitted inside a conditional." kwd))) + + +;;;; Loop Types + + +(defun loop-typed-init (data-type) + (when (and data-type (subtypep data-type 'number)) + (if (or (subtypep data-type 'float) (subtypep data-type '(complex float))) + (coerce 0 data-type) + 0))) + + +(defun loop-optional-type (&optional variable) + ;;No variable specified implies that no destructuring is permissible. + (and *loop-source-code* ;Don't get confused by NILs... + (let ((z (car *loop-source-code*))) + (cond ((loop-tequal z 'of-type) + ;;This is the syntactically unambigous form in that the form of the + ;; type specifier does not matter. Also, it is assumed that the + ;; type specifier is unambiguously, and without need of translation, + ;; a common lisp type specifier or pattern (matching the variable) thereof. + (loop-pop-source) + (loop-pop-source)) + + ((symbolp z) + ;;This is the (sort of) "old" syntax, even though we didn't used to support all of + ;; these type symbols. + (let ((type-spec (or (gethash z (loop-universe-type-symbols *loop-universe*)) + (gethash (symbol-name z) (loop-universe-type-keywords *loop-universe*))))) + (when type-spec + (loop-pop-source) + type-spec))) + (t + ;;This is our sort-of old syntax. But this is only valid for when we are destructuring, + ;; so we will be compulsive (should we really be?) and require that we in fact be + ;; doing variable destructuring here. We must translate the old keyword pattern typespec + ;; into a fully-specified pattern of real type specifiers here. + (if (consp variable) + (unless (consp z) + (loop-error + "~S found where a LOOP keyword, LOOP type keyword, or LOOP type pattern expected." + z)) + (loop-error "~S found where a LOOP keyword or LOOP type keyword expected." z)) + (loop-pop-source) + (labels ((translate (k v) + (cond ((null k) nil) + ((atom k) + (replicate + (or (gethash k (loop-universe-type-symbols *loop-universe*)) + (gethash (symbol-name k) (loop-universe-type-keywords *loop-universe*)) + (loop-error + "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))))))) + + + +;;;; Loop Variables + + +(defun loop-bind-block () + (when (or *loop-variables* *loop-declarations* *loop-wrappers*) + (push (list (nreverse *loop-variables*) *loop-declarations* *loop-desetq-crocks* *loop-wrappers*) + *loop-bind-stack*) + (setq *loop-variables* nil + *loop-declarations* nil + *loop-desetq-crocks* nil + *loop-wrappers* nil))) + + +(defun loop-make-variable (name initialization dtype &optional iteration-variable-p) + (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 (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 (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*)) + #+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) + + +(defun loop-make-iteration-variable (name initialization dtype) + (loop-make-variable name initialization dtype t)) + + +(defun loop-declare-variable (name dtype) + (cond ((or (null name) (null dtype) (eq dtype t)) nil) + ((symbolp name) + (unless (or (eq dtype t) (member (the symbol name) *loop-nodeclare*)) + (let ((dtype #-cmu dtype + #+cmu + (let ((init (loop-typed-init dtype))) + (if (typep init dtype) + dtype + `(or (member ,init) ,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)))) + + +(defun loop-maybe-bind-form (form data-type) + (if (loop-constantp form) + form + (loop-make-variable (loop-gentemp 'loop-bind-) form data-type))) + + + +(defun loop-do-if (for negatep) + (let ((form (loop-get-form)) (*loop-inside-conditional* t) (it-p nil)) + (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 (loop-tequal (car *loop-source-code*) 'it) + (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))))))) + (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)))))) + + +(defun loop-do-initially () + (loop-disallow-conditional :initially) + (push (loop-get-progn) *loop-prologue*)) + +(defun loop-do-finally () + (loop-disallow-conditional :finally) + (push (loop-get-progn) *loop-epilogue*)) + +(defun loop-do-do () + (loop-emit-body (loop-get-progn))) + +(defun loop-do-named () + (let ((name (loop-pop-source))) + (unless (symbolp name) + (loop-error "~S is an invalid name for your LOOP." name)) + (when (or *loop-before-loop* *loop-body* *loop-after-epilogue* *loop-inside-conditional*) + (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)) + (setq *loop-names* (list name nil)))) + +(defun loop-do-return () + (loop-pseudo-body (loop-construct-return (loop-get-form)))) + + +;;;; Value Accumulation: List + + +(defstruct (loop-collector + #+ecls (:type vector) + #+nil (:copier nil) + #+nil (:predicate nil)) + name + class + (history nil) + (tempvars nil) + dtype + (data nil)) ;collector-specific data + + +(defun loop-get-collection-info (collector class default-type) + (unless (loop-tequal (car *loop-source-code*)'into) + (setq *loop-collection-no-into* t)) + (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)))) + (when (not (symbolp name)) + (loop-error "Value accumulation recipient name, ~S, is not a symbol." name)) + (unless dtype + (setq dtype (or (loop-optional-type) default-type))) + (let ((cruft (find (the symbol name) *loop-collection-cruft* + :key #'loop-collector-name))) + (cond ((not cruft) + (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 + (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* (loop-gentemp 'loop-list-head-) + (loop-gentemp '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 `(loop-copylist* ,form))))) + (loop-emit-body `(loop-collect-rplacd ,tempvars ,form))))) + + +;;;; Value Accumulation: max, min, 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) + (loop-gentemp 'loop-sum-)) + nil (loop-collector-dtype lc))))) + (unless (loop-collector-name lc) + (loop-emit-final-value (car (loop-collector-tempvars lc))))) + (loop-emit-body + (if (eq specifically 'count) + `(when ,form + (setq ,(car tempvars) + ,(hide-variable-reference t (car tempvars) `(1+ ,(car tempvars))))) + `(setq ,(car tempvars) + (+ ,(hide-variable-reference t (car tempvars) (car tempvars)) + ,form))))))) + + + +(defun loop-maxmin-collection (specifically) + (multiple-value-bind (lc form) + (loop-get-collection-info specifically 'maxmin *loop-real-data-type*) + (loop-check-data-type (loop-collector-dtype lc) *loop-real-data-type*) + (let ((data (loop-collector-data lc))) + (unless data + (setf (loop-collector-data lc) + (setq data (make-loop-minimax + (or (loop-collector-name lc) (loop-gentemp '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)) + ))) + + +;;;; Value Accumulation: Aggregate Booleans + +;;;ALWAYS and NEVER. +;;; Under ANSI these are not permitted to appear under conditionalization. +(defun loop-do-always (restrictive negate) + (let ((form (loop-get-form))) + (when restrictive (loop-disallow-conditional)) + (loop-emit-body `(,(if negate 'when 'unless) ,form + ,(loop-construct-return nil))) + (loop-emit-final-value t))) + + + +;;;THERIS. +;;; Under ANSI this is not permitted to appear under conditionalization. +(defun loop-do-thereis (restrictive) + (when restrictive (loop-disallow-conditional)) + (loop-emit-body `(when (setq ,(loop-when-it-variable) ,(loop-get-form)) + ,(loop-construct-return *loop-when-it-variable*))) + (loop-emit-final-value nil)) + + +(defun loop-do-while (negate kwd &aux (form (loop-get-form))) + (loop-disallow-conditional kwd) + (loop-pseudo-body `(,(if negate 'when 'unless) ,form (go end-loop)))) + + +(defun loop-do-with () + (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))) + (loop-make-variable var val dtype) + (if (loop-tequal (car *loop-source-code*) :and) + (loop-pop-source) + (return (loop-bind-block))))) + + +;;;; The iteration driver + +(defun loop-hack-iteration (entry) + (flet ((make-endtest (list-of-forms) + (cond ((null list-of-forms) nil) + ((member t list-of-forms) '(go end-loop)) + (t `(when ,(if (null (cdr (setq list-of-forms (nreverse list-of-forms)))) + (car list-of-forms) + (cons 'or list-of-forms)) + (go end-loop)))))) + (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) + ;; 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)))) + (and (car tem) (push (car tem) pre-step-tests)) + (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)))))) + (setq tem (cdr tem)) + (when *loop-emitted-body* + (loop-error "Iteration in LOOP follows body code.")) + (unless tem (setq tem data)) + (when (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)))))) + (when (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)))) + (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" + (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))))) + + +;;;; Main Iteration Drivers + + +;FOR variable keyword ..args.. +(defun loop-do-for () + (let* ((var (loop-pop-source)) + (data-type (loop-optional-type var)) + (keyword (loop-pop-source)) + (first-arg nil) + (tem nil)) + (setq first-arg (loop-get-form)) + (unless (and (symbolp keyword) + (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)))) + + +(defun loop-do-repeat () + (let ((form (loop-get-form)) + (type (loop-check-data-type (loop-optional-type) *loop-real-data-type*))) + (when (and (consp form) (eq (car form) 'the) (subtypep (second form) type)) + (setq type (second form))) + (multiple-value-bind (number constantp value) + (loop-constant-fold-if-possible form type) + (cond ((and constantp (<= value 1)) `(t () () () ,(<= value 0) () () ())) + (t (let ((var (loop-make-variable (loop-gentemp 'loop-repeat-) number type))) + (if constantp + `((not (plusp (setq ,var (1- ,var)))) () () () () () () ()) + `((minusp (setq ,var (1- ,var))) () () ())))))))) + + +(defun loop-when-it-variable () + (or *loop-when-it-variable* + (setq *loop-when-it-variable* + (loop-make-variable (loop-gentemp 'loop-it-) nil nil)))) + + +;;;; Various FOR/AS Subdispatches + + +;;;ANSI "FOR x = y [THEN z]" is sort of like the old Genera one when the THEN +;;; is omitted (other than being more stringent in its placement), and like +;;; the old "FOR x FIRST y THEN z" when the THEN is present. I.e., the first +;;; initialization occurs in the loop body (first-step), not in the variable binding +;;; phase. +(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) () ())))) + + +(defun loop-for-across (var val data-type) + (loop-make-iteration-variable var nil data-type) + (let ((vector-var (loop-gentemp 'loop-across-vector-)) + (index-var (loop-gentemp 'loop-across-index-))) + (multiple-value-bind (vector-form constantp vector-value) + (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)) + #+Genera (push `(system:array-register ,vector-var) *loop-declarations*) + (loop-make-variable index-var 0 'fixnum) + (let* ((length 0) + (length-form (cond ((not constantp) + (let ((v (loop-gentemp 'loop-across-limit-))) + (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))))))) + + + +;;;; List Iteration + + +(defun loop-list-step (listvar) + ;;We are not equipped to analyze whether 'FOO is the same as #'FOO here in any + ;; sensible fashion, so let's give an obnoxious warning whenever 'FOO is used + ;; as the stepping function. + ;;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 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 (loop-gentemp 'loop-fn-) stepper 'function) + ,listvar) + nil))))) + + +(defun loop-for-on (var val data-type) + (multiple-value-bind (list constantp list-value) (loop-constant-fold-if-possible val) + (let ((listvar var)) + (cond ((and var (symbolp var)) (loop-make-iteration-variable var list data-type)) + (t (loop-make-variable (setq listvar (loop-gentemp)) list 'list) + (loop-make-iteration-variable var nil data-type))) + (multiple-value-bind (list-step step-function) (loop-list-step listvar) + (declare #+(and (not LOOP-Prefer-POP) (not CLOE)) (ignore step-function)) + ;; The CLOE problem above has to do with bug in macroexpansion of multiple-value-bind. + (let* ((first-endtest + (hide-variable-reference + (eq var listvar) + listvar + ;; 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) + ;;Contour of the loop is different because we use the user's variable... + `(() (,listvar ,(hide-variable-reference t listvar list-step)) ,other-endtest + () () () ,first-endtest ())) + #+LOOP-Prefer-POP + ((and step-function + (let ((n (cdr (assoc step-function '((cdr . 1) (cddr . 2) + (cdddr . 3) (cddddr . 4)))))) + (and n (do ((l var (cdr l)) (i 0 (1+ i))) + ((atom l) (and (null l) (= i n))) + (declare (fixnum i)))))) + (let ((step (mapcan #'(lambda (x) (list x `(pop ,listvar))) var))) + `(,other-endtest () () ,step ,first-endtest () () ,step))) + (t (let ((step `(,var ,listvar)) (pseudo `(,listvar ,list-step))) + `(,other-endtest ,step () ,pseudo + ,@(and (not (eq first-endtest other-endtest)) + `(,first-endtest ,step () ,pseudo))))))))))) + + +(defun loop-for-in (var val data-type) + (multiple-value-bind (list constantp list-value) (loop-constant-fold-if-possible val) + (let ((listvar (loop-gentemp 'loop-list-))) + (loop-make-iteration-variable var nil data-type) + (loop-make-variable listvar list 'list) + (multiple-value-bind (list-step step-function) (loop-list-step listvar) + #-LOOP-Prefer-POP (declare (ignore step-function)) + (let* ((first-endtest `(endp ,listvar)) + (other-endtest first-endtest) + (step `(,var (car ,listvar))) + (pseudo-step `(,listvar ,list-step))) + (when (and constantp (listp list-value)) + (setq first-endtest (null list-value))) + #+LOOP-Prefer-POP (when (eq step-function 'cdr) + (setq step `(,var (pop ,listvar)) pseudo-step nil)) + `(,other-endtest ,step () ,pseudo-step + ,@(and (not (eq first-endtest other-endtest)) + `(,first-endtest ,step () ,pseudo-step)))))))) + + +;;;; Iteration Paths + + +(defstruct (loop-path + #+ecls (:type vector) + #+nil (:copier nil) + #+nil (:predicate nil)) + names + preposition-groups + inclusive-permitted + function + user-data) + + +(defun add-loop-path (names function universe &key preposition-groups inclusive-permitted user-data) + (unless (listp names) (setq names (list names))) + ;; Can't do this due to CLOS bootstrapping problems. + #-(or Genera (and CLOE Source-Bootstrap) ecls) (check-type universe loop-universe) + (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))) + (dolist (name names) (setf (gethash (symbol-name name) ht) lp)) + lp)) + + +;;; Note: path functions are allowed to use loop-make-variable, hack +;;; the prologue, etc. +(defun loop-for-being (var val data-type) + ;; 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)) + (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?"))) + (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))) + (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))) + (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)))) + (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)) + (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)))) + (setq *loop-prologue* (nconc (reverse (cadr stuff)) *loop-prologue*)) + (cddr stuff))) + + + +;;;INTERFACE: Lucid, exported. +;;; i.e., this is part of our extended ansi-loop interface. +(defun named-variable (name) + (let ((tem (loop-tassoc name *loop-named-variables*))) + (declare (list tem)) + (cond ((null tem) (values (loop-gentemp) nil)) + (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) + (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) + (loop-copylist* + (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)))) + (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 (or (atom z) + (atom (cdr z)) + (not (null (cddr z))) + (not (symbolp (car z))) + (and (cadr z) (not (symbolp (cadr z))))) + (loop-error "~S bad variable pair in path USING phrase." z)) + (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) + (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 + (loop-gentemp '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 (loop-gentemp '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")) + (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)) + (cond ((member dir '(nil :up)) + (when (or limit-given default-top) + (unless limit-given + (loop-make-variable (setq endform (loop-gentemp 'loop-seq-limit-)) + nil indexv-type) + (push `(setq ,endform ,default-top) *loop-prologue*)) + (setq testfn (if inclusive-iteration '> '>=))) + (setq step (if (eql stepby 1) `(1+ ,indexv) `(+ ,indexv ,stepby)))) + (t (unless start-given + (unless default-top + (loop-error "Don't know where to start stepping.")) + (push `(setq ,indexv (1- ,default-top)) *loop-prologue*)) + (when (and default-top (not endform)) + (setq endform (loop-typed-init indexv-type) inclusive-iteration t)) + (when endform (setq testfn (if inclusive-iteration '< '<=))) + (setq step (if (eql stepby 1) `(1- ,indexv) `(- ,indexv ,stepby))))) + (when testfn (setq test (hide-variable-reference t indexv `(,testfn ,indexv ,endform)))) + (when step-hack + (setq step-hack `(,variable ,(hide-variable-reference indexv-user-specified-p indexv step-hack)))) + (let ((first-test test) (remaining-tests test)) + (when (and stepby-constantp start-constantp limit-constantp) + (when (setq first-test (funcall (symbol-function testfn) start-value limit-value)) + (setq remaining-tests t))) + `(() (,indexv ,(hide-variable-reference t indexv step)) ,remaining-tests ,step-hack + () () ,first-test ,step-hack)))) + + +;;;; Interfaces to the Master Sequencer + + + +(defun loop-for-arithmetic (var val data-type kwd) + (loop-sequencer + var (loop-check-data-type data-type *loop-real-data-type*) t + nil nil nil nil nil nil + (loop-collect-prepositional-phrases + '((:from :upfrom :downfrom) (:to :upto :downto :above :below) (:by)) + nil (list (list kwd val))))) + + +(defun loop-sequence-elements-path (variable data-type prep-phrases + &key fetch-function size-function sequence-type element-type) + (multiple-value-bind (indexv indexv-user-specified-p) (named-variable 'index) + (let ((sequencev (named-variable 'sequence))) + #+Genera (when (and sequencev + (symbolp sequencev) + sequence-type + (subtypep sequence-type 'vector) + (not (member (the symbol sequencev) *loop-nodeclare*))) + (push `(sys:array-register ,sequencev) *loop-declarations*)) + (list* nil nil ; dummy bindings and prologue + (loop-sequencer + indexv 'fixnum indexv-user-specified-p + variable (or data-type element-type) + sequencev sequence-type + `(,fetch-function ,sequencev ,indexv) `(,size-function ,sequencev) + prep-phrases))))) + + +;;;; Builtin LOOP Iteration Paths + + +#|| +(loop for v being the hash-values of ht do (print v)) +(loop for k being the hash-keys of ht do (print k)) +(loop for v being the hash-values of ht using (hash-key k) do (print (list k v))) +(loop for k being the hash-keys of ht using (hash-value v) do (print (list k v))) +||# + +(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."))) + (let ((ht-var (loop-gentemp 'loop-hashtab-)) + (next-fn (loop-gentemp 'loop-hashtab-next-)) + (dummy-predicate-var nil) + (post-steps nil)) + (multiple-value-bind (other-var other-p) + (named-variable (if (eq which 'hash-key) 'hash-value 'hash-key)) + ;; named-variable 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. + #-Genera (setq other-p t + dummy-predicate-var (loop-when-it-variable)) + (let ((key-var nil) + (val-var nil) + (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 (loop-gentemp 'loop-hash-key-temp-)) + ,@post-steps)) + (push `(,key-var nil) bindings)) + (when (consp val-var) + (setq post-steps `(,val-var ,(setq val-var (loop-gentemp 'loop-hash-val-temp-)) + ,@post-steps)) + (push `(,val-var nil) bindings)) + `(,bindings ;bindings + () ;prologue + () ;pre-test + () ;parallel steps + (not (multiple-value-setq (,dummy-predicate-var ,key-var ,val-var) (,next-fn))) ;post-test + ,post-steps))))) + + +(defun loop-package-symbols-iteration-path (variable data-type prep-phrases &key symbol-types) + (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."))) + (unless (symbolp variable) + (loop-error "Destructuring is not valid for package symbol iteration.")) + (let ((pkg-var (loop-gentemp 'loop-pkgsym-)) + (next-fn (loop-gentemp 'loop-pkgsym-next-))) + (push `(lisp::with-package-iterator (,next-fn ,pkg-var ,@symbol-types)) *loop-wrappers*) + `(((,variable nil ,data-type) (,pkg-var ,(cadar prep-phrases))) + () + () + () + (not (multiple-value-setq (,(progn + ;; If an implementation can get away without actually + ;; using a variable here, so much the better. + #+Genera NIL + #-Genera (loop-when-it-variable)) + ,variable) + (,next-fn))) + ()))) + +;;;; ANSI Loop + +(defun make-ansi-loop-universe (extended-p) + (let ((w (make-standard-loop-universe + :keywords `((named (loop-do-named)) + (initially (loop-do-initially)) + (finally (loop-do-finally)) + (do (loop-do-do)) + (doing (loop-do-do)) + (return (loop-do-return)) + (collect (loop-list-collection list)) + (collecting (loop-list-collection list)) + (append (loop-list-collection append)) + (appending (loop-list-collection append)) + (nconc (loop-list-collection nconc)) + (nconcing (loop-list-collection nconc)) + (count (loop-sum-collection count ,*loop-real-data-type* fixnum)) + (counting (loop-sum-collection count ,*loop-real-data-type* 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))) + :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)) + (by (loop-for-arithmetic :by)) + (to (loop-for-arithmetic :to)) + (upto (loop-for-arithmetic :upto)) + (being (loop-for-being))) + :iteration-keywords '((for (loop-do-for)) + (as (loop-do-for)) + (repeat (loop-do-repeat))) + :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)) + (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)) + (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))) + (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))) + (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))) + w)) + + +(defparameter *loop-ansi-universe* + (make-ansi-loop-universe nil)) + + +(defun loop-standard-expansion (keywords-and-forms environment universe) + (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)))))) + + +;;;INTERFACE: ANSI +(defmacro loop (&environment env &rest keywords-and-forms) + #+Genera (declare (compiler:do-not-record-macroexpansions) + (zwei:indentation . zwei:indent-loop)) + (loop-standard-expansion keywords-and-forms env *loop-ansi-universe*)) + +#+allegro +(defun excl::complex-loop-expander (body env) + (loop-standard-expansion body env *loop-ansi-universe*)) diff --git a/lsp/gcl_make-declare.lsp b/lsp/gcl_make-declare.lsp new file mode 100755 index 0000000..4d06ced --- /dev/null +++ b/lsp/gcl_make-declare.lsp @@ -0,0 +1,80 @@ +;; By W. Schelter +;; Usage: (si::proclaim-file "foo.lsp") (compile-file "foo.lsp") + +(in-package 'si) + +;; You may wish to adjust the following to output the proclamations +;; for inclusion in a file. All fixed arg functions should be proclaimed +;; before their references for maximum efficiency. + +;; CAVEAT: The following code only checks for fixed args, it does +;; not check for single valuedness BUT does make a proclamation +;; to that effect. Unfortunately it is impossible to tell about +;; multiple values without doing a full compiler type pass over +;; all files in the relevant system. However the GCL compiler should +;; warn if you inadvertantly proclaim foo to be single valued and then try +;; to use more than one value. + +(DEFVAR *DECLARE-T-ONLY* NIL) +(DEFUN PROCLAIM-FILE (NAME &OPTIONAL *DECLARE-T-ONLY*) + (WITH-OPEN-FILE + (FILE NAME + :DIRECTION :INPUT) + (LET ((EOF (CONS NIL NIL))) + (LOOP + (LET ((FORM (READ FILE NIL EOF))) + (COND ((EQ EOF FORM) (RETURN NIL)) + ((MAKE-DECLARE-FORM FORM )))))))) + +(DEFVAR *DEFUNS* '(DEFUN)) + +(DEFUN MAKE-DECLARE-FORM (FORM) +; !!! + (WHEN + (LISTP FORM) + (COND ((MEMBER (CAR FORM) '(EVAL-WHEN )) + (DOLIST (V (CDDR FORM)) (MAKE-DECLARE-FORM V))) + ((MEMBER (CAR FORM) '(PROGN )) + (DOLIST (V (CDR FORM)) (MAKE-DECLARE-FORM V))) + ((MEMBER (CAR FORM) '(IN-PACKAGE DEFCONSTANT)) + (EVAL FORM)) + ((MEMBER (CAR FORM) *DEFUNS*) + (COND + ((AND + (CONSP (CADDR FORM)) + (NOT (MEMBER '&REST (CADDR FORM))) + (NOT (MEMBER '&BODY (CADDR FORM))) + (NOT (MEMBER '&KEY (CADDR FORM))) + (NOT (MEMBER '&OPTIONAL (CADDR FORM)))) + ;;could print declarations here. + ;(print (list (cadr form)(ARG-DECLARES (THIRD FORM)(cdddr FORM)))) + (FUNCALL 'PROCLAIM + (LIST 'FUNCTION + (CADR FORM) + (ARG-DECLARES (THIRD FORM) (cdddr FORM)) + T)))))))) + +(DEFUN ARG-DECLARES (ARGS DECLS &AUX ANS) + (COND ((STRINGP (CAR DECLS)) (SETQ DECLS (CADR DECLS))) + (T (SETQ DECLS (CAR DECLS)))) + (COND ((AND (not *declare-t-only*) + (CONSP DECLS) (EQ (CAR DECLS ) 'DECLARE)) + (DO ((V ARGS (CDR V))) + ((OR (EQ (CAR V) '&AUX) + (NULL V)) + (NREVERSE ANS)) + (PUSH (DECL-TYPE (CAR V) DECLS) ANS))) + (T (MAKE-LIST (- (LENGTH args) + (LENGTH (MEMBER '&AUX args))) + :INITIAL-ELEMENT T)))) + +(DEFUN DECL-TYPE (V DECLS) + (DOLIST (D (CDR DECLS)) + (CASE (CAR D) + (TYPE (IF (MEMBER V (CDDR D)) + (RETURN-FROM DECL-TYPE (SECOND D)))) + ((FIXNUM CHARACTER FLOAT LONG-FLOAT SHORT-FLOAT ) + (IF (MEMBER V (CDR D)) (RETURN-FROM DECL-TYPE (CAR D)))))) + T) + + \ No newline at end of file diff --git a/lsp/gcl_make_defpackage.lsp b/lsp/gcl_make_defpackage.lsp new file mode 100644 index 0000000..dc83054 --- /dev/null +++ b/lsp/gcl_make_defpackage.lsp @@ -0,0 +1,52 @@ +;;; Thu Aug 12 14:22:09 1993 by Mark Kantrowitz +;;; make-defpackage.lisp -- 1961 bytes + +;;; **************************************************************** +;;; Make a Defpackage Form From Package State ********************** +;;; **************************************************************** + +(in-package :si) + +(defun make-defpackage-form (package-name) + "Given a package, returns a defpackage form that could recreate the + current state of the package, more or less." + (let ((package (find-package package-name))) + (let* ((name (package-name package)) + (nicknames (package-nicknames package)) + (package-use-list (package-use-list package)) + (use-list (mapcar #'package-name package-use-list)) + (externs nil) + (shadowed-symbols (package-shadowing-symbols package)) + (imports nil) + (shadow-imports nil) + (pure-shadow nil) + (pure-import nil)) + (do-external-symbols (sym package) (push (symbol-name sym) externs)) + (do-symbols (sym package) + (unless (or (eq package (symbol-package sym)) + (find (symbol-package sym) package-use-list)) + (push sym imports))) + (setq shadow-imports (intersection shadowed-symbols imports)) + (setq pure-shadow (set-difference shadowed-symbols shadow-imports)) + (setq pure-import (set-difference imports shadow-imports)) + `(defpackage ,name + ,@(when nicknames `((:nicknames ,@nicknames))) + ,@(when use-list `((:use ,@use-list))) + ,@(when externs `((:export ,@externs))) + ;; skip :intern + ,@(when pure-shadow + `((:shadow ,@(mapcar #'symbol-name pure-shadow)))) + ,@(when shadow-imports + (mapcar #'(lambda (symbol) + `((:shadowing-import-from + ,(package-name (symbol-package symbol)) + ,(symbol-name symbol)))) + shadow-imports)) + ,@(when pure-import + (mapcar #'(lambda (symbol) + `((:import-from + ,(package-name (symbol-package symbol)) + ,(symbol-name symbol)))) + pure-import)))))) + +;;; *EOF* diff --git a/lsp/gcl_mislib.lsp b/lsp/gcl_mislib.lsp new file mode 100755 index 0000000..4bffc77 --- /dev/null +++ b/lsp/gcl_mislib.lsp @@ -0,0 +1,173 @@ +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +;;;; This file is IMPLEMENTATION-DEPENDENT. + + +(in-package 'lisp) + + +(export 'time) +(export '(reset-sys-paths decode-universal-time encode-universal-time compile-file-pathname complement constantly)) + + +(in-package 'system) + + +(proclaim '(optimize (safety 2) (space 3))) + + +(defmacro time (form) + (let ((real-start (gensym)) (real-end (gensym)) (gbc-time-start (gensym)) + (gbc-time (gensym)) (x (gensym)) (run-start (gensym)) (run-end (gensym)) + (child-run-start (gensym)) (child-run-end (gensym))) + `(let (,real-start ,real-end (,gbc-time-start (si::gbc-time)) ,gbc-time ,x) + (setq ,real-start (get-internal-real-time)) + (multiple-value-bind (,run-start ,child-run-start) (get-internal-run-time) + (si::gbc-time 0) + (setq ,x (multiple-value-list ,form)) + (setq ,gbc-time (si::gbc-time)) + (si::gbc-time (+ ,gbc-time-start ,gbc-time)) + (multiple-value-bind (,run-end ,child-run-end) (get-internal-run-time) + (setq ,real-end (get-internal-real-time)) + (fresh-line *trace-output*) + (format *trace-output* + "real time : ~10,3F secs~%~ + run-gbc time : ~10,3F secs~%~ + child run time : ~10,3F secs~%~ + gbc time : ~10,3F secs~%" + (/ (- ,real-end ,real-start) internal-time-units-per-second) + (/ (- (- ,run-end ,run-start) ,gbc-time) internal-time-units-per-second) + (/ (- ,child-run-end ,child-run-start) internal-time-units-per-second) + (/ ,gbc-time internal-time-units-per-second)))) + (values-list ,x)))) + +(defconstant seconds-per-day #.(* 24 3600)) + +(defun leap-year-p (y) + (and (zerop (mod y 4)) + (or (not (zerop (mod y 100))) (zerop (mod y 400))))) + +(defun number-of-days-from-1900 (y) + (let ((y1 (1- y))) + (+ (* (- y 1900) 365) + (floor y1 4) (- (floor y1 100)) (floor y1 400) + -460))) + +(eval-when + (compile eval) + (defmacro mmd (n &optional lp + &aux (l '(31 28 31 30 31 30 31 31 30 31 30 31)) + (l (if lp (cons (pop l) (cons (1+ (pop l)) l)) l))(r 0)(s (mapcar (lambda (x) (incf r x)) l))) + `(defconstant ,n (make-array ,(length s) :element-type '(integer ,(car s) ,(car (last s))) :initial-contents ',s)))) + +(mmd +md+) +(mmd +lmd+ t) + +(defun decode-universal-time (ut &optional (tz (current-timezone) tzp) + &aux (dstp (unless tzp (current-dstp))) (ut (- ut (* tz 3600)))) + (declare (optimize (safety 2))) + (check-type ut (integer 0)) + (check-type tz rational) + (multiple-value-bind + (d ut) (floor ut seconds-per-day) + (let* ((dow (mod d 7))(y (+ 1900 (floor d 366)))) + (labels ((l (y dd &aux (lyp (leap-year-p y))(td (if lyp 366 365))(x (- d dd))) + (if (< x td) (values (1+ x) y lyp) (l (1+ y) (+ dd td))))) + (multiple-value-bind + (d y lyp) (l y (number-of-days-from-1900 y)) + (let* ((l (if lyp +lmd+ +md+)) + (m (position d l :test '<=)) + (d (if (> m 0) (- d (aref l (1- m))) d))) + (multiple-value-bind + (h ut) (floor ut 3600) + (multiple-value-bind + (min sec) (floor ut 60) + (values sec min h d (1+ m) y dow dstp tz))))))))) + +(defun encode-universal-time (sec min h d m y &optional (tz (current-timezone))) + (declare (optimize (safety 2))) + (check-type sec (integer 0 59)) + (check-type min (integer 0 59)) + (check-type h (integer 0 23)) + (check-type d (integer 1 31)) + (check-type m (integer 1 12)) + (check-type y (integer 1900)) + (check-type tz rational) + (when (<= 0 y 99) + (multiple-value-bind + (sec min h d m y1 dow dstp tz) (get-decoded-time) + (declare (ignore sec min h d m dow dstp tz)) + (incf y (- y1 (mod y1 100))) + (cond ((< (- y y1) -50) (incf y 100)) + ((>= (- y y1) 50) (decf y 100))))) + (+ (* (+ (1- d) (number-of-days-from-1900 y) (if (> m 1) (aref (if (leap-year-p y) +lmd+ +md+) (- m 2)) 0)) + seconds-per-day) + (* (+ h tz) 3600) (* min 60) sec)) + +(defun compile-file-pathname (pathname) +(make-pathname :defaults pathname :type "o")) +(defun constantly (x) +#'(lambda (&rest args) + (declare (ignore args) (:dynamic-extent args)) +x)) +(defun complement (fn) +#'(lambda (&rest args) (not (apply fn args)))) + +(defun default-system-banner () + (let (gpled-modules) + (dolist (l '(:unexec :bfd :readline :xgcl)) + (when (member l *features*) + (push l gpled-modules))) + (format nil "GCL (GNU Common Lisp) ~a.~a.~a ~a ~a ~a~%~a~%~a ~a~%~a~%~a~%~%~a~%" + *gcl-major-version* *gcl-minor-version* *gcl-extra-version* + (if (member :ansi-cl *features*) "ANSI" "CLtL1") + (if (member :gprof *features*) "profiling" "") + (si::gcl-compile-time) + "Source License: LGPL(gcl,gmp), GPL(unexec,bfd,xgcl)" + "Binary License: " + (if gpled-modules (format nil "GPL due to GPL'ed components: ~a" gpled-modules) + "LGPL") + "Modifications of this banner must retain notice of a compatible license" + "Dedicated to the memory of W. Schelter" + "Use (help) to get some basic information on how to use GCL."))) + + (defun lisp-implementation-version nil + (format nil "GCL ~a.~a.~a" + si::*gcl-major-version* + si::*gcl-minor-version* + si::*gcl-extra-version*)) + +(defun objlt (x y) + (declare (object x y)) + (let ((x (si::address x)) (y (si::address y))) + (declare (fixnum x y)) + (if (< y 0) + (if (< x 0) (< x y) t) + (if (< x 0) nil (< x y))))) + +(defun reset-sys-paths (s) + (declare (string s)) + (setq si::*lib-directory* s) + (setq si::*system-directory* (si::string-concatenate s "unixport/")) + (let (nl) + (dolist (l '("cmpnew/" "gcl-tk/" "lsp/" "xgcl-2/")) + (push (si::string-concatenate s l) nl)) + (setq si::*load-path* nl)) + nil) diff --git a/lsp/gcl_module.lsp b/lsp/gcl_module.lsp new file mode 100755 index 0000000..63d122a --- /dev/null +++ b/lsp/gcl_module.lsp @@ -0,0 +1,123 @@ +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +;;;; module.lsp +;;;; +;;;; module routines + + +(in-package 'lisp) + +(export '(*modules* provide require)) +(export 'documentation) +(export '(variable function structure type setf)) + +(in-package 'system) + + +(eval-when (compile) (proclaim '(optimize (safety 2) (space 3)))) + + +(defvar *modules* nil) + + +(defun provide (module-name) + (setq *modules* + (adjoin (string module-name) + *modules* + :test #'string=))) + + +(defun require (module-name + &optional (pathname (string-downcase (string module-name)))) + (let ((*default-pathname-defaults* #"")) + (unless (member (string module-name) + *modules* + :test #'string=) + (if (atom pathname) + (load pathname) + (do ((p pathname (cdr p))) + ((endp p)) + (load (car p))))))) + + +(defun documentation (symbol doc-type) + (case doc-type + (variable (get symbol 'variable-documentation)) + (function (get symbol 'function-documentation)) + (structure (get symbol 'structure-documentation)) + (type (get symbol 'type-documentation)) + (setf (get symbol 'setf-documentation)) + (t + (if (packagep symbol) + (get (find-symbol (package-name symbol) :keyword) 'package-documentation) + (error "~S is an illegal documentation type." doc-type))))) + + +(defun find-documentation (body) + (if (or (endp body) (endp (cdr body))) + nil + (let ((form (macroexpand (car body)))) + (if (stringp form) + form + (if (and (consp form) + (eq (car form) 'declare)) + (find-documentation (cdr body)) + nil))))) + + +(defun eval-feature (x) + (cond ((atom x) + (member x *features* + :test #'(lambda (a b) + (cond ((symbolp a) + (and (symbolp b) + (string-equal (symbol-name a) + (symbol-name b)))) + (t (eql a b)))))) + ((eq (car x) 'and) + (dolist (x (cdr x) t) (unless (eval-feature x) (return nil)))) + ((eq (car x) 'or) + (dolist (x (cdr x) nil) (when (eval-feature x) (return t)))) + ((eq (car x) 'not) + (not (eval-feature (cadr x)))) + (t (error "~S is not a feature expression." x)))) + +(defun sharp-+-reader (stream subchar arg) + (declare (ignore subchar arg)) + (if (eval-feature (let ((*read-suppress* nil) (*read-base* 10.)) + (read stream t nil t))) + (values (read stream t nil t)) + (let ((*read-suppress* t)) (read stream t nil t) (values)))) + +(set-dispatch-macro-character #\# #\+ 'sharp-+-reader) +(set-dispatch-macro-character #\# #\+ 'sharp-+-reader + (si::standard-readtable)) + +(defun sharp---reader (stream subchar arg) + (declare (ignore subchar arg)) + (if (eval-feature (let ((*read-suppress* nil) (*read-base* 10.)) + (read stream t nil t))) + (let ((*read-suppress* t)) (read stream t nil t) (values)) + (values (read stream t nil t)))) + +(set-dispatch-macro-character #\# #\- 'sharp---reader) +(set-dispatch-macro-character #\# #\- 'sharp---reader + (si::standard-readtable)) + diff --git a/lsp/gcl_numlib.lsp b/lsp/gcl_numlib.lsp new file mode 100755 index 0000000..a8375f5 --- /dev/null +++ b/lsp/gcl_numlib.lsp @@ -0,0 +1,290 @@ +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +;;;; numlib.lsp +;;;; +;;;; number routines + + +(in-package 'lisp) +(export + '(isqrt abs phase signum cis asin acos sinh cosh tanh + asinh acosh atanh + rational rationalize + ffloor fround ftruncate fceiling + lognand lognor logandc1 logandc2 logorc1 logorc2 + lognot logtest + byte byte-size byte-position + ldb ldb-test mask-field dpb deposit-field + )) + + +(in-package 'system) + + +(proclaim '(optimize (safety 2) (space 3))) + + +(defconstant imag-one #C(0.0d0 1.0d0)) + + +(defun isqrt (i) + (unless (and (integerp i) (>= i 0)) + (error "~S is not a non-negative integer." i)) + (if (zerop i) + 0 + (let ((n (integer-length i))) + (do ((x (ash 1 (ceiling n 2))) + (y)) + (nil) + (setq y (floor i x)) + (when (<= x y) + (return x)) + (setq x (floor (+ x y) 2)))))) + + +(defun abs (z) + (cond ((complexp z) + ;; Compute (sqrt (+ (* x x) (* y y))) carefully to prevent + ;; overflow! + (let* ((x (abs (realpart z))) + (y (abs (imagpart z)))) + (if (< x y) + (rotatef x y)) + (if (zerop x) + x + (let ((r (/ y x))) + (* x (sqrt (+ 1 (* r r)))))))) + (t ; Should this be (realp z) instead of t? + (if (minusp z) + (- z) + z)))) + + +(defun phase (x) + (atan (imagpart x) (realpart x))) + +(defun signum (x) (if (zerop x) x (/ x (abs x)))) + +(defun cis (x) (exp (* imag-one x))) + +(defun asin (x) + (let ((c (- (* imag-one + (log (+ (* imag-one x) + (sqrt (- 1.0d0 (* x x))))))))) + (if (or (and (not (complexp x)) + (<= x 1.0d0) + (>= x -1.0d0) + ) + (zerop (imagpart c))) + (realpart c) + c))) + +(defun acos (x) + (let ((c (- (* imag-one + (log (+ x (* imag-one + (sqrt (- 1.0d0 (* x x)))))))))) + (if (or (and (not (complexp x)) + (<= x 1.0d0) + (>= x -1.0d0) + ) + (zerop (imagpart c))) + (realpart c) + c))) + + +(defun sinh (z) + (cond ((complexp z) + ;; For complex Z, compute the real and imaginary parts + ;; separately to get better precision. + (let ((x (realpart z)) + (y (imagpart z))) + (complex (* (sinh x) (cos y)) + (* (cosh x) (sin y))))) + (t ; Should this be (realp z) instead of t? + (let ((limit #.(expt (* double-float-epsilon 45/2) 1/5))) + (if (< (- limit) z limit) + ;; For this region, write use the fact that sinh z = + ;; z*exp(z)*[(1 - exp(-2z))/(2z)]. Then use the first + ;; 4 terms in the Taylor series expansion of + ;; (1-exp(-2z))/2/z. series expansion of (1 - + ;; exp(2*x)). This is needed because there is severe + ;; roundoff error calculating (1 - exp(-2z)) for z near + ;; 0. + (* z (exp z) + (- 1 (* z + (- 1 (* z + (- 2/3 (* z + (- 1/3 (* 2/15 z))))))))) + (let ((e (exp z))) + (* 1/2 (- e (/ e))))))))) + +;(defun sinh (x) (/ (- (exp x) (exp (- x))) 2.0d0)) + +(defun cosh (z) + (cond ((complexp z) + ;; For complex Z, compute the real and imaginary parts + ;; separately to get better precision. + (let ((x (realpart z)) + (y (imagpart z))) + (complex (* (cosh x) (cos y)) + (* (sinh x) (sin y))))) + (t ; Should this be (realp z) instead of t? + ;; For real Z, there's no chance of round-off error, so + ;; direct evaluation is ok. + (let ((e (exp z))) + (* 1/2 (+ e (/ e))))))) +;(defun cosh (x) (/ (+ (exp x) (exp (- x))) 2.0d0)) +(defun tanh (x) (/ (sinh x) (cosh x))) + +(defun asinh (x) (log (+ x (sqrt (+ 1.0d0 (* x x)))))) +;(defun acosh (x) +; (log (+ x +; (* (1+ x) +; (sqrt (/ (1- x) (1+ x))))))) +;(defun acosh (x) +; (log (+ x +; (sqrt (* (1- x) (1+ x)))))) +(defun acosh (x) + (* 2 (log (+ (sqrt (/ (1+ x) 2)) (sqrt (/ (1- x) 2)))))) +(defun atanh (x) + (when (or (= x 1.0d0) (= x -1.0d0)) + (error "The argument, ~s, is a logarithmic singularity.~ + ~%Don't be foolish, GLS." + x)) + (log (/ (1+ x) (sqrt (- 1 (* x x)))))) +;; (let ((y (log (/ (1+ x) (sqrt (- 1 (* x x))))))) +;; (if (and (= (imagpart x) 0) (complexp y)) +;; (complex (realpart y) (- (imagpart y))) +;; y))) + + +(defun rational (x) + (etypecase x + (float + (multiple-value-bind (i e s) (integer-decode-float x) + (if (>= s 0) + (* i (expt (float-radix x) e)) + (- (* i (expt (float-radix x) e)))))) + (rational x))) + + +(setf (symbol-function 'rationalize) (symbol-function 'rational)) + +;; although the following is correct code in that it approximates the +;; x to within eps, it does not preserve (eql (float (rationalize x) x) x) +;; since the test for eql is more strict than the float-epsilon + +;;; Rationalize originally by Skef Wholey. +;;; Obtained from Daniel L. Weinreb. +;(defun rationalize (x) +; (typecase x +; (rational x) +; (short-float (rationalize-float x short-float-epsilon 1.0s0)) +; (long-float (rationalize-float x long-float-epsilon 1.0d0)) +; (otherwise (error "~S is neither rational nor float." x)))) +; +;(defun rationalize-float (x eps one) +; (cond ((minusp x) (- (rationalize (- x)))) +; ((zerop x) 0) +; (t (let ((y ()) +; (a ())) +; (do ((xx x (setq y (/ one +; (- xx (float a x))))) +; (num (setq a (truncate x)) +; (+ (* (setq a (truncate y)) num) onum)) +; (den 1 (+ (* a den) oden)) +; (onum 1 num) +; (oden 0 den)) +; ((and (not (zerop den)) +; (not (> (abs (/ (- x (/ (float num x) +; (float den x))) +; x)) +; eps))) +; (/ num den))))))) + + +(defun ffloor (x &optional (y 1.0s0)) + (multiple-value-bind (i r) (floor (float x) (float y)) + (values (float i r) r))) + +(defun fceiling (x &optional (y 1.0s0)) + (multiple-value-bind (i r) (ceiling (float x) (float y)) + (values (float i r) r))) + +(defun ftruncate (x &optional (y 1.0s0)) + (multiple-value-bind (i r) (truncate (float x) (float y)) + (values (float i r) r))) + +(defun fround (x &optional (y 1.0s0)) + (multiple-value-bind (i r) (round (float x) (float y)) + (values (float i r) r))) + + +(defun lognand (x y) (boole boole-nand x y)) +(defun lognor (x y) (boole boole-nor x y)) +(defun logandc1 (x y) (boole boole-andc1 x y)) +(defun logandc2 (x y) (boole boole-andc2 x y)) +(defun logorc1 (x y) (boole boole-orc1 x y)) +(defun logorc2 (x y) (boole boole-orc2 x y)) + +(defun lognot (x) (logxor -1 x)) +(defun logtest (x y) (not (zerop (logand x y)))) + + +(defun byte (size position) + (cons size position)) + +(defun byte-size (bytespec) + (car bytespec)) + +(defun byte-position (bytespec) + (cdr bytespec)) + +;; (defun ldb (bytespec integer) +;; (logandc2 (ash integer (- (byte-position bytespec))) +;; (- (ash 1 (byte-size bytespec))))) + +;; (defun ldb-test (bytespec integer) +;; (not (zerop (ldb bytespec integer)))) + +;; (defun mask-field (bytespec integer) +;; (ash (ldb bytespec integer) (byte-position bytespec))) + +;; (defun dpb (newbyte bytespec integer) +;; (logxor integer +;; (mask-field bytespec integer) +;; (ash (logandc2 newbyte +;; (- (ash 1 (byte-size bytespec)))) +;; (byte-position bytespec)))) + +;; (defun deposit-field (newbyte bytespec integer) +;; (dpb (ash newbyte (- (byte-position bytespec))) bytespec integer)) + + +(defun ldb (bytespec integer) + (logand (ash integer (- (byte-position bytespec))) + (1- (ash 1 (byte-size bytespec))))) +(defun ldb-test (bytespec integer) + (not (zerop (ldb bytespec integer)))) +(defun dpb (newbyte bytespec integer &aux (z (1- (ash 1 (byte-size bytespec))))) + (logior (logandc2 integer (ash z (byte-position bytespec))) + (ash (logand newbyte z) (byte-position bytespec)))) +(defun deposit-field (newbyte bytespec integer &aux (z (ash (1- (ash 1 (byte-size bytespec))) (byte-position bytespec)))) + (logior (logandc2 integer z) (logand newbyte z))) diff --git a/lsp/gcl_packages.lsp b/lsp/gcl_packages.lsp new file mode 100755 index 0000000..8b13789 --- /dev/null +++ b/lsp/gcl_packages.lsp @@ -0,0 +1 @@ + diff --git a/lsp/gcl_packlib.lsp b/lsp/gcl_packlib.lsp new file mode 100755 index 0000000..e70f487 --- /dev/null +++ b/lsp/gcl_packlib.lsp @@ -0,0 +1,225 @@ +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +;;;; packlib.lsp +;;;; +;;;; package routines + + +(in-package 'lisp) + + +(export '(find-all-symbols do-symbols do-external-symbols do-all-symbols with-package-iterator)) +(export '(apropos apropos-list)) + + +(in-package 'system) + + +(proclaim '(optimize (safety 2) (space 3))) + + +(defmacro coerce-to-package (p) + (if (eq p '*package*) + p + (let ((g (gensym))) + `(let ((,g ,p)) + (if (packagep ,g) + ,g + (find-package (string ,g))))))) + +(defun find-all-symbols (string-or-symbol) + (when (symbolp string-or-symbol) + (setq string-or-symbol (symbol-name string-or-symbol))) + (mapcan #'(lambda (p) + (multiple-value-bind (s i) + (find-symbol string-or-symbol p) + (if (or (eq i :internal) (eq i :external)) + (list s) + nil))) + (list-all-packages))) + + +(defmacro do-symbols ((var &optional (package '*package*) (result-form nil)) + . body) + (let ((p (gensym)) (i (gensym)) (l (gensym)) (q (gensym)) + (loop (gensym)) (x (gensym))(y (gensym)) (break (gensym)) declaration) + (multiple-value-setq (declaration body) (find-declarations body)) + `(let ((,p (coerce-to-package ,package)) ,var ,l ) + ,@declaration + (dolist (,q (cons ,p (package-use-list ,p)) (progn (setq ,var nil) ,result-form)) + (multiple-value-bind + (,y ,x) (package-size ,q) + (declare (fixnum ,x ,y)) + (if (not (eq ,p ,q)) (setq ,x 0)) + (dotimes (,i (+ ,x ,y)) + (setq ,l (if (< ,i ,x) + (si:package-internal ,q ,i) + (si:package-external ,q (- ,i ,x)))) + ,loop + (when (null ,l) (go ,break)) + (setq ,var (car ,l)) + (if (or (eq ,q ,p) + (eq :inherited (car (last (multiple-value-list + (find-symbol (symbol-name ,var) ,p)))))) + (tagbody ,@body)) + (setq ,l (cdr ,l)) + (go ,loop) + ,break)))))) + + +(defmacro do-external-symbols + ((var &optional (package '*package*) (result-form nil)) . body) + (let ((p (gensym)) (i (gensym)) (l (gensym)) + (loop (gensym)) (break (gensym)) declaration) + (multiple-value-setq (declaration body) + (find-declarations body)) + `(let ((,p (coerce-to-package ,package)) ,var ,l) + + ,@declaration + (dotimes (,i (package-size ,p) (progn (setq ,var nil) ,result-form)) + (setq ,l (si:package-external ,p ,i)) + ,loop + (when (null ,l) (go ,break)) + (setq ,var (car ,l)) + ,@body + (setq ,l (cdr ,l)) + (go ,loop) + ,break)))) + +(defmacro do-all-symbols((var &optional (result-form nil)) . body) + `(dolist (.v (list-all-packages) ,result-form) + (do-symbols (,var .v) + (tagbody ,@ body)))) + + +(defun substringp (sub str) + (do ((i (- (length str) (length sub))) + (l (length sub)) + (j 0 (1+ j))) + ((> j i) nil) + (when (string-equal sub str :start2 j :end2 (+ j l)) + (return t)))) + + +(defun print-symbol-apropos (symbol) + (prin1 symbol) + (when (fboundp symbol) + (if (special-form-p symbol) + (princ " Special form") + (if (macro-function symbol) + (princ " Macro") + (princ " Function")))) + (when (boundp symbol) + (if (constantp symbol) + (princ " Constant: ") + (princ " has value: ")) + (prin1 (symbol-value symbol))) + (terpri)) + + +;(defun apropos (string &optional package) +; (setq string (string string)) +; (cond (package +; (do-symbols (symbol package) +; (when (substringp string (string symbol)) +; (print-symbol-apropos symbol))) +; (do ((p (package-use-list package) (cdr p))) +; ((null p)) +; (do-external-symbols (symbol (car p)) +; (when (substringp string (string symbol)) +; (print-symbol-apropos symbol))))) +; (t +; (do-all-symbols (symbol) +; (when (substringp string (string symbol)) +; (print-symbol-apropos symbol))))) +; (values)) + + +(defun apropos-list (string &optional package &aux list) + (setq list nil) + (setq string (string string)) + (cond (package + (do-symbols (symbol package) + (when (substringp string (string symbol)) + (setq list (cons symbol list)))) + (do ((p (package-use-list package) (cdr p))) + ((null p)) + (do-external-symbols (symbol (car p)) + (when (substringp string (string symbol)) + (setq list (cons symbol list)))))) + (t + (do-all-symbols (symbol) + (when (substringp string (string symbol)) + (setq list (cons symbol list)))))) + (stable-sort (delete-duplicates list :test #'eq) + #'string< :key #'symbol-name)) + +(defun apropos (string &optional package) + (dolist (symbol (apropos-list string package)) + (print-symbol-apropos symbol)) + (values)) + +(defmacro with-package-iterator ((name plist &rest symbol-types) . body) + (let ((p (gensym)) (i (gensym)) (l (gensym)) (q (gensym)) (dum (gensym)) + (x (gensym))(y (gensym)) (access (gensym)) declaration) + (multiple-value-setq (declaration body) (si::find-declarations body)) + (if (null symbol-types) + (error 'program-error :format-control "Symbol type specifiers must be supplied")) + `(let ((,p (cons t (if (atom ,plist) (list ,plist) ,plist))) (,q nil) (,l nil) + (,i -1) (,x 0) (,y 0) (,dum nil) (,access nil)) + (declare (fixnum ,x ,y)) + (flet ((,name () + (tagbody ,name + (when (null (setq ,l (cdr ,l))) + (when (eql (incf ,i) (+ ,x ,y)) + (when (null (setq ,q (cdr ,q))) + (when (null (setq ,p (cdr ,p))) + (return-from ,name nil)) + (rplaca ,p (coerce-to-package (car ,p))) + (setq ,q (list + (si::coerce-to-package (car ,p)))) + (when (member :inherited (list ,@symbol-types)) + (rplacd ,q (package-use-list (car ,q))))) + (multiple-value-setq (,y ,x) (si::package-size (car ,q))) + (when (or (not (member :internal (list ,@symbol-types))) + (not (eq (car ,p) (car ,q)))) + (setq ,x 0)) + (when (and (not (member :external (list ,@symbol-types))) + (eq (car ,p) (car ,q))) + (setq ,y 0)) + (when (zerop (+ ,x ,y)) + (setq ,i -1) + (go ,name)) + (setq ,i 0)) + (setq ,l (if (< ,i ,x) + (si::package-internal (car ,q) ,i) + (si::package-external (car ,q) (- ,i ,x))))) + (when (null ,l) + (go ,name)) + (multiple-value-setq (,dum ,access) + (find-symbol + (symbol-name (car ,l)) (car ,p))) + (when (and (not (eq ,access :inherited)) + (not (eq (car ,p) (car ,q)))) + (go ,name))) + (values 't (car ,l) ,access (car ,p)))) + ,@declaration + ,@body)))) + diff --git a/lsp/gcl_predlib.lsp b/lsp/gcl_predlib.lsp new file mode 100755 index 0000000..146a6bc --- /dev/null +++ b/lsp/gcl_predlib.lsp @@ -0,0 +1,792 @@ +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +;;;; predlib.lsp +;;;; +;;;; predicate routines + + +(in-package 'system) + +(export '(lisp::deftype lisp::typep lisp::subtypep lisp::coerce) 'lisp) + +(eval-when (compile) +(proclaim '(optimize (safety 2) (space 3))) +) + +;;; DEFTYPE macro. +(defmacro deftype (name lambda-list &rest body) + ;; Replace undefaultized optional parameter X by (X '*). + (do ((l lambda-list (cdr l)) + (m nil (cons (car l) m))) + ((null l)) + (when (member (car l) lambda-list-keywords) + (unless (eq (car l) '&optional) (return nil)) + (setq m (cons '&optional m)) + (setq l (cdr l)) + (do () + ((or (null l) (member (car l) lambda-list-keywords))) + (if (symbolp (car l)) + (setq m (cons (list (car l) ''*) m)) + (setq m (cons (car l) m))) + (setq l (cdr l))) + (setq lambda-list (nreconc m l)) + (return nil))) + `(eval-when (compile eval load) + (si:putprop ',name + '(deftype ,name ,lambda-list ,@body) + 'deftype-form) + (si:putprop ',name + #'(lambda ,lambda-list ,@body) + 'deftype-definition) + (si:putprop ',name + ,(find-documentation body) + 'type-documentation) + ',name)) + + +;;; Some DEFTYPE definitions. +(deftype string-stream nil `(or (satisfies string-input-stream-p) (satisfies string-output-stream-p))) +(deftype spice nil `(satisfies spice-p)) +(deftype fixnum () + `(integer ,most-negative-fixnum ,most-positive-fixnum)) +(deftype bit () '(integer 0 1)) +(deftype mod (n) + `(integer 0 ,(1- n))) +(deftype signed-byte (&optional s) + (if (eq s '*) + `(integer * *) + `(integer ,(- (expt 2 (1- s))) ,(1- (expt 2 (1- s)))))) +(deftype unsigned-byte (&optional s) + (if (eq s '*) + `(integer 0 *) + `(integer 0 ,(1- (expt 2 s))))) +(deftype signed-char ()`(signed-byte ,char-size)) +(deftype unsigned-char ()`(unsigned-byte ,char-size)) +(deftype signed-short ()`(signed-byte ,short-size)) +(deftype unsigned-short ()`(unsigned-byte ,short-size)) + + + +(deftype vector (&optional element-type size) + `(array ,element-type (,size))) +(deftype string (&optional size) + `(vector string-char ,size)) +(deftype base-string (&optional size) + `(vector base-char ,size)) +(deftype bit-vector (&optional size) + `(vector bit ,size)) + +(deftype simple-vector (&optional size) + `(simple-array t (,size))) +(deftype simple-string (&optional size) + `(simple-array string-char (,size))) +(deftype simple-base-string (&optional size) + `(simple-array base-char (,size))) +(deftype simple-bit-vector (&optional size) + `(simple-array bit (,size))) + + + +(defun simple-array-p (x) + (and (arrayp x) + ;; should be (not (expressly-adjustable-p x)) + ;; since the following will always return T + ;; (not (adjustable-array-p x)) + (not (array-has-fill-pointer-p x)) + (not (si:displaced-array-p x)))) + + +(do ((l '((null . null) + (symbol . symbolp) + (keyword . keywordp) + (atom . atom) + (cons . consp) + (list . listp) + (fixnum . fixnump) + (integer . integerp) + (rational . rationalp) + (number . numberp) + (character . characterp) + (package . packagep) + (stream . streamp) + (pathname . pathnamep) + (readtable . readtablep) + (hash-table . hash-table-p) + (random-state . random-state-p) + (structure . si:structurep) + (function . functionp) + (vector . vectorp) + (bit-vector . bit-vector-p) + (array . arrayp) + (string . stringp) + (float . floatp) + (complex . complexp) + (real . realp) + (simple-array . simple-array-p) + (simple-vector . simple-vector-p) + (simple-string . simple-string-p) + (simple-bit-vector . simple-bit-vector-p) + (compiled-function . compiled-function-p) + (common . commonp) + ) + (cdr l))) + ((endp l)) + (si:putprop (caar l) (cdar l) 'type-predicate) + (si:putprop (cdar l) (caar l) 'predicate-type)) + + +(eval-when + (compile eval) + (defmacro clh nil + `(progn + ,@(mapcar (lambda (x &aux (f (when (equal x "FIND-CLASS") `(&optional ep))) (z (intern (string-concatenate "SI-" x)))) + `(defun ,z (o ,@f &aux e (x (find-symbol ,x :user))) + (cond ((and x (fboundp x) (fboundp (find-symbol "CLASSP" :user))) + (prog1 (funcall x o ,@(cdr f)) + (fset ',z (symbol-function x)))) + ((setq e (get ',z 'early)) (values (funcall e o ,@(cdr f))))))) + '("CLASSP" "CLASS-PRECEDENCE-LIST" "FIND-CLASS" "CLASS-OF" "CLASS-NAME"))))) +(clh) + +;; (defun class-of (object) +;; (declare (ignore object)) +;; nil) +;; (defun classp (object) +;; (declare (ignore object)) +;; nil) +;; (defun class-precedence-list (object) +;; (declare (ignore object)) +;; nil) +;; (defun find-class (object) +;; (declare (ignore object)) +;; nil) + +;;; TYPEP predicate. +;;; FIXME --optimize with most likely cases first +(defun typep (object type &optional env &aux tp i tem) + (declare (ignore env)) + (if (atom type) + (setq tp type i nil) + (setq tp (car type) i (cdr type))) + (if (eq tp 'structure-object) (setq tp 'structure)) + (case tp + (member (member object i)) + (not (not (typep object (car i)))) + (or + (do ((l i (cdr l))) + ((null l) nil) + (when (typep object (car l)) (return t)))) + (and + (do ((l i (cdr l))) + ((null l) t) + (unless (typep object (car l)) (return nil)))) + (satisfies (funcall (car i) object)) + ((t) t) + ((nil) nil) + (boolean (or (eq object 't) (eq object 'nil))) + (fixnum (eq (type-of object) 'fixnum)) + (bignum (eq (type-of object) 'bignum)) + (ratio (eq (type-of object) 'ratio)) + (standard-char + (and (characterp object) (standard-char-p object))) + ((base-char string-char) + (and (characterp object) (string-char-p object))) + (integer + (and (integerp object) (in-interval-p object i))) + (rational + (and (rationalp object) (in-interval-p object i))) + (real + (and (realp object) (in-interval-p object i))) + (float + (and (floatp object) (in-interval-p object i))) + ((short-float) + (and (eq (type-of object) 'short-float) (in-interval-p object i))) + ((single-float double-float long-float) + (and (eq (type-of object) 'long-float) (in-interval-p object i))) + (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)))) + )) + (sequence (or (listp object) (vectorp object))) + ((base-string string) ;FIXME + (and (stringp object) + (or (endp i) (match-dimensions (array-dimensions object) i)))) + (bit-vector + (and (bit-vector-p object) + (or (endp i) (match-dimensions (array-dimensions object) i)))) + ((simple-base-string simple-string) ;FIXME + (and (simple-string-p object) + (or (endp i) (match-dimensions (array-dimensions object) i)))) + (simple-bit-vector + (and (simple-bit-vector-p object) + (or (endp i) (match-dimensions (array-dimensions object) i)))) + (simple-vector + (and (simple-vector-p object) + (or (endp i) + (and (not (stringp object)) (not (bit-vector-p object))) + (equal (best-array-element-type (array-element-type object)) t)) + (or (endp i) (match-dimensions (array-dimensions object) i)))) + (vector + (and (vectorp object) + (or (endp i) (eq (car i) '*) + (and (eq (car i) t) (not (stringp object)) (not (bit-vector-p object))) + (equal (array-element-type object) (best-array-element-type (car i)))) + (or (endp (cdr i)) (match-dimensions (array-dimensions object) (cdr i))))) + (simple-array + (and (simple-array-p object) + (or (endp i) (eq (car i) '*) + (equal (array-element-type object) (best-array-element-type (car i)))) + (or (endp (cdr i)) (eq (cadr i) '*) + (if (listp (cadr i)) + (match-dimensions (array-dimensions object) (cadr i)) + (eql (array-rank object) (cadr i)))))) + (array + (and (arrayp object) + (or (endp i) (eq (car i) '*) + ;; Or the element type of object should be EQUAL to (car i). + ;; Is this too strict? + (equal (array-element-type object) (best-array-element-type (car i)))) + (or (endp (cdr i)) (eq (cadr i) '*) + (if (listp (cadr i)) + (match-dimensions (array-dimensions object) (cadr i)) + (eql (array-rank object) (cadr i)))))) + (t + (cond ((si-classp tp) + (if (member type (si-class-precedence-list (si-class-of object))) t nil)) + ((setq tem (if (structurep tp) tp (get tp 'si::s-data))) + (structure-subtype-p object tem)) + ((setq tem (get tp 'type-predicate)) + (funcall tem object)) + ((setq tem (get tp 'deftype-definition)) + (typep object (apply tem i))))))) + + +;;; NORMALIZE-TYPE normalizes the type using the DEFTYPE definitions. +;;; The result is always a list. +(defun normalize-type (type &aux tp i ) + ;; Loops until the car of type has no DEFTYPE definition. + (when (and (consp type) (eq (car type) 'satisfies)) + (when (setq tp (get (cadr type) 'predicate-type)) + (setq type tp))) + (loop + (if (atom type) + (setq tp type i nil) + (setq tp (car type) i (cdr type))) + (cond ((si-classp tp) (return-from normalize-type (list (si-class-name tp)))) + ((get tp 'deftype-definition) (setq type (apply (get tp 'deftype-definition) i))) + ((return-from normalize-type (if (atom type) (list type) type)))))) + + +;;; KNOWN-TYPE-P answers if the given type is a known base type. +;;; The type may not be normalized. +;; FIXME this needs to be more robust +(defun known-type-p (type) + (when (consp type) (setq type (car type))) + (if (or (equal (string type) "ERROR") + (member type + '(t nil boolean null symbol keyword atom cons list sequence + signed-char unsigned-char signed-short unsigned-short + number integer bignum rational ratio float method-combination + short-float single-float double-float long-float complex + character standard-char string-char real + package stream pathname readtable hash-table random-state + structure array simple-array function compiled-function + arithmetic-error base-char base-string broadcast-stream + built-in-class cell-error class concatenated-stream condition + control-error division-by-zero echo-stream end-of-file error + extended-char file-error file-stream floating-point-inexact + floating-point-invalid-operation floating-point-overflow + floating-point-underflow generic-function logical-pathname method + package-error parse-error print-not-readable program-error + reader-error serious-condition simple-base-string simple-condition + simple-type-error simple-warning standard-class + standard-generic-function standard-method standard-object + storage-condition stream-error string-stream structure-class + style-warning synonym-stream two-way-stream structure-object + type-error unbound-slot unbound-variable undefined-function + warning )) + (get type 's-data)) + t + nil)) + + +;;; SUBTYPEP predicate. +(defun subtypep (type1 type2 &optional env &aux t1 t2 i1 i2 ntp1 ntp2 tem) + (declare (ignore env)) + (let ((c1 (si-classp type1)) (c2 (si-classp type2))) + (when (and c1 c2) + (return-from subtypep + (if (member type2 (si-class-precedence-list type1)) + (values t t) (values nil t)))) + (when (and c1 (or (eq type2 'structure-object) (eq type2 'standard-object))) + (return-from subtypep + (if (member (si-find-class type2) (si-class-precedence-list type1)) + (values t t) (values nil t)))) + (when (or c1 c2) + (return-from subtypep (values nil t)))) + (setq type1 (normalize-type type1)) + (setq type2 (normalize-type type2)) + (when (equal type1 type2) + (return-from subtypep (values t t))) + (setq t1 (car type1) t2 (car type2)) + (setq i1 (cdr type1) i2 (cdr type2)) + (cond ((eq t1 'member) + (dolist (e i1) + (unless (typep e type2) (return-from subtypep (values nil t)))) + (return-from subtypep (values t t))) + ((eq t1 'or) + (dolist (tt i1) + (multiple-value-bind (tv flag) (subtypep tt type2) + (unless tv (return-from subtypep (values tv flag))))) + (return-from subtypep (values t t))) + ((eq t1 'and) + (dolist (tt i1) + (let ((tv (subtypep tt type2))) + (when tv (return-from subtypep (values t t))))) + (return-from subtypep (values nil nil))) + ((eq t1 'not) + ;; + (return-from subtypep + (if (eq t2 'not) + (subtypep (car i2) (car i1)) + (subtypep t `(or ,type2 ,(car i1))))))) + (cond ((eq t2 'member) + (return-from subtypep (values nil nil))) + ((eq t2 'or) + (dolist (tt i2) + (let ((tv (subtypep type1 tt))) + (when tv (return-from subtypep (values t t))))) + (return-from subtypep (values nil nil))) + ((eq t2 'and) + (dolist (tt i2) + (multiple-value-bind (tv flag) (subtypep type1 tt) + (unless tv (return-from subtypep (values tv flag))))) + (return-from subtypep (values t t))) + ((eq t2 'not) + (return-from subtypep (subtypep `(and ,type1 ,(car i2)) nil)))) + + (setq ntp1 (known-type-p type1) ntp2 (known-type-p type2)) + (cond ((or (eq t1 'nil) (eq t2 't) (eq t2 'common)) (values t t)) + ((eq t2 'nil) (values nil ntp1)) + ((eq t1 't) (values nil ntp2)) + ((eq t1 'common) (values nil ntp2)) + ((eq t2 'list) + (cond ((member t1 '(null cons)) (values t t)) + (t (values nil ntp1)))) + ((eq t2 'sequence) + (cond ((member t1 '(null cons list)) + (values t t)) + ((or (eq t1 'simple-array) (eq t1 'array)) + (if (and (cdr i1) (consp (cadr i1)) (null (cdadr i1))) + (values t t) + (values nil t))) + (t (values nil ntp1)))) + ((eq t1 'list) (values nil ntp2)) + ((eq t1 'sequence) (values nil ntp2)) + ((eq t2 'atom) + (cond ((member t1 '(cons list)) (values nil t)) + (ntp1 (values t t)) + (t (values nil nil)))) + ((eq t1 'atom) (values nil ntp2)) + ((eq t2 'symbol) + (if (member t1 '(keyword boolean null)) + (values t t) + (values nil ntp1))) + ((eq t2 'function) + (if (member t1 '(compiled-function generic-function standard-generic-function)) + (values t t) + (values nil ntp1))) + ((eq t2 'generic-function) + (if (eq t1 'standard-generic-function) + (values t t) + (values nil ntp1))) + ((eq t2 'boolean) + (if (eq t1 'null) + (values t t) + (values nil ntp1))) + ((eq t2 'standard-object) + (if (member t1 '(class built-in-class structure-class standard-class + method standard-method)) + (values t t) + (values nil ntp1))) + ((eq t2 'class) + (if (member t1 '(built-in-class structure-class standard-class )) + (values t t) + (values nil ntp1))) + ((eq t2 'condition) + (if (or (equal (string t1) "ERROR") + (member t1 '(serious-condition error type-error simple-type-error + parse-error cell-error unbound-slot + warning style-warning storage-condition + simple-warning unbound-variable control-error + program-error undefined-function + package-error arithmetic-error + division-by-zero simple-condition + floating-point-invalid-operation + floating-point-inexact + floating-point-overflow + floating-point-underflow + file-error stream-error end-of-file + print-not-readable + reader-error))) + (values t t) + (values nil ntp1))) + ((eq t2 'serious-condition) + (if (or (equal (string t1) "ERROR") + (member t1 '( error type-error simple-type-error + parse-error cell-error unbound-slot + storage-condition + unbound-variable control-error + program-error undefined-function + package-error arithmetic-error + division-by-zero simple-type-error + floating-point-invalid-operation + floating-point-inexact + floating-point-overflow + floating-point-underflow + file-error stream-error end-of-file + print-not-readable + reader-error))) + (values t t) + (values nil ntp1))) + ((eq t2 'type-error) + (if (eq t1 'simple-type-error) + (values t t) + (values nil ntp1))) + ((eq t2 'parse-error) + (if (eq t1 'reader-error) + (values t t) + (values nil ntp1))) + ((eq t2 'stream-error) + (if (member t1 '(reader-error end-of-file)) + (values t t) + (values nil ntp1))) + ((or (equal (string t2) "ERROR") (eq t2 'error)) + (if (member t1 '(simple-type-error type-error + parse-error cell-error unbound-slot + unbound-variable control-error + program-error undefined-function + package-error arithmetic-error + division-by-zero simple-type-error + floating-point-invalid-operation + floating-point-inexact + floating-point-overflow + floating-point-underflow + file-error stream-error end-of-file print-not-readable + reader-error )) + (values t t) + (values nil ntp1))) + ((eq t2 'stream) + (if (member t1 '(broadcast-stream concatenated-stream echo-stream file-stream + string-stream synonym-stream two-way-stream)) + (values t t) + (values nil ntp1))) + ((eq t2 'pathname) + (if (eq t1 'logical-pathname) + (values t t) + (values nil ntp1))) + ((eq t2 'method) + (if (eq t1 'standard-method) + (values t t) + (values nil ntp1))) + ((eq t2 'simple-condition) + (if (member t1 '(simple-type-error simple-warning)) + (values t t) + (values nil ntp1))) + ((eq t2 'simple-condition) + (if (member t1 '(simple-type-error simple-warning)) + (values t t) + (values nil ntp1))) + ((eq t2 'cell-error) + (if (member t1 '(unbound-slot unbound-variable undefined-function)) + (values t t) + (values nil ntp1))) + ((eq t2 'warning) + (if (member t1 '(style-warning simple-warning)) + (values t t) + (values nil ntp1))) + ((eq t2 'arithmetic-error) + (if (member t1 '(division-by-zero + floating-point-invalid-operation + floating-point-inexact + floating-point-overflow + floating-point-underflow )) + (values t t) + (values nil ntp1))) + ((eq t2 'keyword) + (if (eq t1 'keyword) (values t t) (values nil ntp1))) + ((eq t2 'null) + (if (eq t1 'null) (values t t) (values nil ntp1))) + ((eq t2 'number) + (cond ((member t1 '(bignum integer ratio rational float real + short-float single-float double-float long-float + complex number)) + (values t t)) + (t (values nil ntp1)))) + ((eq t1 'number) (values nil ntp2)) + ((or (eq t2 'structure) (eq t2 'structure-object)) + (if (or (eq t1 'structure) (get t1 'si::s-data)) + (values t t) + (values nil ntp1))) + ((eq t1 'structure) (values nil ntp2)) + ((setq tem (get t1 'si::s-data)) + (let ((tem2 (get t2 'si::s-data))) + (cond (tem2 + (do ((tp1 tem (s-data-includes tp1)) (tp2 tem2)) + ((null tp1)(values nil t)) + (when (eq tp1 tp2) (return (values t t))))) + (t (values nil ntp2))))) + ((eq t2 'real) + (cond ((and + (member t1 '(fixnum integer bignum float short-float + single-float double-float long-float + real ratio + rational)) + (sub-interval-p i1 i2)) + (values t t)) + (t (values nil ntp1)))) + ((get t2 'si::s-data) (values nil ntp1)) + (t + (case t1 + (bignum + (case t2 + (bignum (values t t)) + ((integer rational) + (if (sub-interval-p '(* *) i2) + (values t t) + (values nil t))) + (t (values nil ntp2)))) + (ratio + (case t2 + (rational + (if (sub-interval-p '(* *) i2) (values t t) (values nil t))) + (t (values nil ntp2)))) + (standard-char + (if (member t2 '(base-char string-char character)) + (values t t) + (values nil ntp2))) + (base-char + (if (member t2 '(character string-char)) + (values t t) + (values nil ntp2))) + (extended-char + (if (member t2 '(character string-char)) + (values t t) + (values nil ntp2))) + (string-char + (if (eq t2 'character) + (values t t) + (values nil ntp2))) + (character + (if (eq t2 'string-char) + (values t t) + (values nil ntp2))) + (integer + (if (member t2 '(integer rational)) + (values (sub-interval-p i1 i2) t) + (values nil ntp2))) + (rational + (if (eq t2 'rational) + (values (sub-interval-p i1 i2) t) + (values nil ntp2))) + (float + (if (eq t2 'float) + (values (sub-interval-p i1 i2) t) + (values nil ntp2))) + ((short-float) + (if (member t2 '(short-float float)) + (values (sub-interval-p i1 i2) t) + (values nil ntp2))) + ((single-float double-float long-float) + (if (member t2 '(single-float double-float long-float float)) + (values (sub-interval-p i1 i2) t) + (values nil ntp2))) + (complex + (if (eq t2 'complex) + (subtypep (or (car i1) t) (or (car i2) t)) + (values nil ntp2))) + (simple-array + (cond ((or (eq t2 'simple-array) (eq t2 'array)) + (if (or (endp i1) (eq (car i1) '*)) + (unless (or (endp i2) (eq (car i2) '*)) + (return-from subtypep (values nil t))) + (unless (or (endp i2) (eq (car i2) '*)) + (unless (or (equal (car i1) (car i2)) + ; FIXME + (and (eq (car i1) 'base-char) + (eq (car i2) 'string-char))) + ;; Unless the element type matches, + ;; return NIL T. + ;; Is this too strict? + (return-from subtypep + (values nil t))))) + (when (or (endp (cdr i1)) (eq (cadr i1) '*)) + (if (or (endp (cdr i2)) (eq (cadr i2) '*)) + (return-from subtypep (values t t)) + (return-from subtypep (values nil t)))) + (when (or (endp (cdr i2)) (eq (cadr i2) '*)) + (return-from subtypep (values t t))) + (values (match-dimensions (cadr i1) (cadr i2)) t)) + (t (values nil ntp2)))) + (array + (cond ((eq t2 'array) + (if (or (endp i1) (eq (car i1) '*)) + (unless (or (endp i2) (eq (car i2) '*)) + (return-from subtypep (values nil t))) + (unless (or (endp i2) (eq (car i2) '*)) + (unless (or (equal (car i1) (car i2)) + ; FIXME + (and (eq (car i1) 'base-char) + (eq (car i2) 'string-char))) + (return-from subtypep + (values nil t))))) + (when (or (endp (cdr i1)) (eq (cadr i1) '*)) + (if (or (endp (cdr i2)) (eq (cadr i2) '*)) + (return-from subtypep (values t t)) + (return-from subtypep (values nil t)))) + (when (or (endp (cdr i2)) (eq (cadr i2) '*)) + (return-from subtypep (values t t))) + (values (match-dimensions (cadr i1) (cadr i2)) t)) + (t (values nil ntp2)))) + (t (if ntp1 (values (eq t1 t2) t) (values nil nil))))))) + + +(defun sub-interval-p (i1 i2) + (let (low1 high1 low2 high2) + (if (endp i1) + (setq low1 '* high1 '*) + (if (endp (cdr i1)) + (setq low1 (car i1) high1 '*) + (setq low1 (car i1) high1 (cadr i1)))) + (if (endp i2) + (setq low2 '* high2 '*) + (if (endp (cdr i2)) + (setq low2 (car i2) high2 '*) + (setq low2 (car i2) high2 (cadr i2)))) + (cond ((eq low1 '*) + (unless (eq low2 '*) + (return-from sub-interval-p nil))) + ((eq low2 '*)) + ((consp low1) + (if (consp low2) + (when (< (car low1) (car low2)) + (return-from sub-interval-p nil)) + (when (< (car low1) low2) + (return-from sub-interval-p nil)))) + ((if (consp low2) + (when (<= low1 (car low2)) + (return-from sub-interval-p nil)) + (when (< low1 low2) + (return-from sub-interval-p nil))))) + (cond ((eq high1 '*) + (unless (eq high2 '*) + (return-from sub-interval-p nil))) + ((eq high2 '*)) + ((consp high1) + (if (consp high2) + (when (> (car high1) (car high2)) + (return-from sub-interval-p nil)) + (when (> (car high1) high2) + (return-from sub-interval-p nil)))) + ((if (consp high2) + (when (>= high1 (car high2)) + (return-from sub-interval-p nil)) + (when (> high1 high2) + (return-from sub-interval-p nil))))) + (return-from sub-interval-p t))) + +(defun in-interval-p (x interval) + (let (low high) + (if (endp interval) + (setq low '* high '*) + (if (endp (cdr interval)) + (setq low (car interval) high '*) + (setq low (car interval) high (cadr interval)))) + (cond ((eq low '*)) + ((consp low) + (when (<= x (car low)) (return-from in-interval-p nil))) + ((when (< x low) (return-from in-interval-p nil)))) + (cond ((eq high '*)) + ((consp high) + (when (>= x (car high)) (return-from in-interval-p nil))) + ((when (> x high) (return-from in-interval-p nil)))) + (return-from in-interval-p t))) + +(defun match-dimensions (dim pat) + (if (null dim) + (null pat) + (and (or (eq (car pat) '*) + (eql (car dim) (car pat))) + (match-dimensions (cdr dim) (cdr pat))))) + + +(defmacro check-type-eval (place type) + `(values (assert (typep ,place ,type) (,place) 'type-error :datum ,place :expected-type ,type))) + +(deftype simple-array (&optional (et '*) (dims '*)) `(array ,et ,(if (not dims) 0 dims))) +(deftype null nil `(member nil)) +(deftype single-float (&optional (low '*) (high '*)) `(long-float ,low ,high)) +(deftype double-float (&optional (low '*) (high '*)) `(long-float ,low ,high)) + + +#.`(defun coerce (object type &aux (l (listp type))(ctp (if l (car type) type))(i (when l (cdr type)))) + (when + (case type + ,@(mapcar (lambda (x) `(,x (,(get x 'type-predicate) object))) + '(string list vector bit-vector array character float cons)) + (function (unless (symbolp object) (functionp object)));FIXME + (otherwise (typep object type))) + (return-from coerce object)) + (case ctp + ((string list vector bit-vector simple-string simple-vector simple-bit-vector array cons null member) + (replace (make-sequence type (length object)) object)) + (function (symbol-function object)) + (character (character object)) + (float (float object)) + ((short-float) (float object 0.0S0)) + ((single-float double-float long-float) (float object 0.0L0)) + (complex + (let* ((re (realpart object))(im (imagpart object)) + (rt (car i))(rt (unless (eq rt '*) rt)) + (re (if rt (coerce re rt) re))(im (if rt (coerce im rt) im))) + (complex re im))) + (t (cond ((let ((nt (normalize-type type))) (unless (eq nt type) (coerce object nt)))) + (t (error "Cannot coerce ~S to ~S." object type)))))) + +;; set by unixport/init_kcl.lsp +;; warn if a file was comopiled in another version +(defvar *gcl-extra-version* nil) +(defvar *gcl-minor-version* nil) +(defvar *gcl-major-version* nil) + +(defun warn-version (majvers minvers extvers) + (and *gcl-major-version* *gcl-minor-version* *gcl-extra-version* + (or (not (eql extvers *gcl-extra-version*)) + (not (eql minvers *gcl-minor-version*)) + (not (eql majvers *gcl-major-version*))) + *load-verbose* + (format t "[compiled in GCL ~a.~a.~a] " majvers minvers extvers))) + + + diff --git a/lsp/gcl_profile.lsp b/lsp/gcl_profile.lsp new file mode 100755 index 0000000..abb8d4f --- /dev/null +++ b/lsp/gcl_profile.lsp @@ -0,0 +1,110 @@ + +(in-package 'si) +(use-package "SLOOP") + +;; Sample Usage: +;; (si::set-up-profile 1000000) (si::prof 0 90) +;; run program +;; (si::display-prof) +;; (si::clear-profile) +;; profile can be stopped with (si::prof 0 0) and restarted with +;;start-address will correspond to the beginning of the profile array, and +;;the scale will mean that 256 bytes of code correspond to scale bytes in the +;;profile array. +;;Thus if the profile array is 1,000,000 bytes long and the code segment is +;;5 megabytes long you can profile the whole thing using a scale of 50 +;;Note that long runs may result in overflow, and so an understating of the +;;time in a function. With a scale of 128 it takes 6,000,000 times through +;;a loop to overflow the sampling in one part of the code. + + + +;(defun sort-funs (package) +; (sloop for v in-package package with tem +; when (and (fboundp v) (compiled-function-p +; (setq tem (symbol-function v)))) +; collect (cons (function-start v) v) into all +; finally (loop-return (sort all #'(lambda (x y) +; (< (the fixnum (car x)) +; (the fixnum (car y)))))))) +(defvar si::*profile-array* + (make-array 20000 :element-type 'string-char + :static t + :initial-element + (code-char 0))) + +(defun create-profile-array (&optional (n 100000)) + (if *profile-array* (profile 0 0)) + (setq *profile-array* (make-array n :element-type 'string-char + :static t + :initial-element + (code-char 0))) + n + ) + + +(defvar *current-profile* nil) + +(defun pr (&optional n) + (sloop + with ar = si::*profile-array* declare (string ar) + for i below (if n (min n (array-total-size ar)) (array-total-size ar)) + + do + (cond ((not (= 0 i))(if (= 0 (mod i 20)) (terpri)))) + (princ (char-code (aref ar i))) (princ " ")) + (values)) + +(defun fprofile(fun &optional (fract 1000) offset) + (setq *current-profile* (list (+ (function-start (symbol-function fun)) + (or offset 0)) + fract)) + (apply 'profile *current-profile* )) + +;(defun foo (n) (sloop for i below n do nil)) + +;;problem: the counter will wrap around at 256, so that it really is not valid +;;for long runs if the functions are heavily used. This means that +;;Remove all previous ticks from the profile array. + +(defun clear-profile () (sloop with ar = *profile-array* + declare (string ar) + for i below (array-total-size ar) + do (setf (aref ar i) (code-char 0)))) + + +(defun prof-offset (addr) (* (/ (float (cadr *current-profile*)) #x10000) + (- addr (car *current-profile*)))) + +(defun prof (a b) + (setf *current-profile* (list a b)) + (profile a b)) + +(defun display-prof() + (profile 0 0) + (apply 'display-profile *current-profile*) + (apply 'profile *current-profile*)) + + +(defun set-up-profile (&optional (array-size 100000)(max-funs 6000) +; (name "saved_kcl")(dir *system-directory*)&aux sym + ) +; (compiler::safe-system (format nil "(cd ~a ; rsym ~a \"#sym\")" dir name)) +; (or (probe-file (setq sym (format nil "~a#sym" dir))) (error "could not find ~a" sym)) +; (read-externals sym) + (set-up-combined max-funs) + (unless (and *profile-array* + (>= (array-total-size *profile-array*) array-size)) + (print "making new array") + (setq *profile-array* (make-array array-size + :element-type 'string-char + :static t + :initial-element + (code-char 0)))) + (format t "~%Loaded c and other function addresses~ + ~%Using profile-array length ~a ~ + ~%Use (si::prof 0 90) to start and (prof 0 0) to stop:~ + ~%This starts monitoring at address 0 ~ + ~%thru byte (256/90)*(length *profile-array*)~ + ~%(si::display-prof) displays the results" (length *profile-array*))) + diff --git a/lsp/gcl_readline.lsp b/lsp/gcl_readline.lsp new file mode 100644 index 0000000..dce4787 --- /dev/null +++ b/lsp/gcl_readline.lsp @@ -0,0 +1,12 @@ +(in-package "SI" ) +(defun init-readline () + ; init Readline word completion list for Gcl + (if (fboundp 'si::readline-init) + (let (l) + (sloop::sloop for v in-package 'lisp do + (if (or (boundp v) (fboundp v)) + (setq l (cons (symbol-name v) l)))) + (sloop::sloop for v in-package 'keyword do + (if (or (boundp v) (fboundp v)) + (setq l (cons (format nil ":~A" v) l)))) + (si::readline-init t "Gcl" 1 l)))) diff --git a/lsp/gcl_restart.lsp b/lsp/gcl_restart.lsp new file mode 100644 index 0000000..139debb --- /dev/null +++ b/lsp/gcl_restart.lsp @@ -0,0 +1,196 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- + +(in-package :si) + +(defvar *restarts* nil) +(defvar *restart-condition* nil) + +(defmacro restart-bind (bindings &body forms) + (declare (optimize (safety 2))) + `(let ((*restarts* + (list* ,@(mapcar (lambda (x) `(cons (make-restart :name ',(pop x) :function ,(pop x) ,@x) *restart-condition*)) bindings) + *restarts*))) + ,@forms)) + + +(defmacro with-condition-restarts (condition-form restarts-form &body body) + (declare (optimize (safety 1))) + (let ((n-cond (gensym))) + `(let* ((,n-cond ,condition-form) + (*restarts* (nconc (mapcar (lambda (x) (cons x ,n-cond)) ,restarts-form) *restarts*))) + ,@body))) + +(defun condition-pass (condition restart &aux b (f (restart-test-function restart))) + (when (if f (funcall f condition) t) + (mapc (lambda (x) + (when (eq (pop x) restart) + (if (if condition (eq x condition) t) + (return-from condition-pass t) + (setq b (or b x))))) *restarts*) + (not b))) + +(defvar *kcl-top-restarts* nil) + +(defun make-kcl-top-restart (quit-tag) + (make-restart :name 'gcl-top-restart + :function (lambda () (throw (car (list quit-tag)) quit-tag)) + :report-function + (lambda (stream) + (let ((b-l (if (eq quit-tag si::*quit-tag*) + si::*break-level* + (car (or (find quit-tag si::*quit-tags* + :key #'cdr) + '(:not-found)))))) + (cond ((eq b-l :not-found) + (format stream "Return to ? level.")) + ((null b-l) + (format stream "Return to top level.")) + (t + (format stream "Return to break level ~D." + (length b-l)))))))) + +(defun find-kcl-top-restart (quit-tag) + (cdr (or (assoc quit-tag *kcl-top-restarts*) + (car (push (cons quit-tag (make-kcl-top-restart quit-tag)) + *kcl-top-restarts*))))) + +(defun kcl-top-restarts () + (let* (;(old-tags (ldiff si::*quit-tags* (member nil si::*quit-tags* :key 'cdr))) + (old-tags si::*quit-tags*) + (old-tags (mapcan (lambda (e) (when (cdr e) (list (cdr e)))) old-tags)) + (tags (if si::*quit-tag* (cons si::*quit-tag* old-tags) old-tags)) + (restarts (mapcar 'find-kcl-top-restart tags))) + (setq *kcl-top-restarts* (mapcar 'cons tags restarts)) + restarts)) + +(defun compute-restarts (&optional condition) + (remove-if-not (lambda (x) (condition-pass condition x)) (remove-duplicates (nconc (mapcar 'car *restarts*) (kcl-top-restarts))))) + +(defun find-restart (name &optional condition &aux (sn (symbolp name))) + (car (member name (compute-restarts condition) :key (lambda (x) (if sn (restart-name x) x))))) + +(defun transform-keywords (&key report interactive test + &aux rr (report (if (stringp report) `(lambda (s) (write-string ,report s)) report))) + (macrolet ((do-setf (x) + `(when ,x + (setf (getf rr ,(intern (concatenate 'string (symbol-name x) "-FUNCTION") :keyword)) + (list 'function ,x))))) + (do-setf report) + (do-setf interactive) + (do-setf test) + rr)) + +(defun rewrite-restart-case-clause (r &aux (name (pop r))(ll (pop r))) + (labels ((l (r) (if (member (car r) '(:report :interactive :test)) (l (cddr r)) r))) + (let ((rd (l r))) + (list* name (gensym) (apply 'transform-keywords (ldiff r rd)) ll rd)))) + + +(defun restart-case-expression-condition (expression env c &aux (e (macroexpand expression env))(n (when (listp e) (pop e)))) + (case n + (cerror (let ((ca (pop e))) `((process-error ,(pop e) (list ,@e)) (,n ,ca ,c)))) + (error `((process-error ,(pop e) (list ,@e)) (,n ,c))) + (warn `((process-error ,(pop e) (list ,@e) 'simple-warning) (,n ,c))) + (signal `((coerce-to-condition ,(pop e) (list ,@e) 'simple-condition ',n) (,n ,c))))) + + +(defmacro restart-case (expression &body clauses &environment env) + (declare (optimize (safety 2))) + (let* ((block-tag (gensym))(args (gensym))(c (gensym)) + (data (mapcar 'rewrite-restart-case-clause clauses)) + (e (restart-case-expression-condition expression env c))) + `(block + ,block-tag + (let* (,args (,c ,(car e)) (*restart-condition* ,c)) + (tagbody + (restart-bind + ,(mapcar (lambda (x) `(,(pop x) (lambda (&rest r) (setq ,args r) (go ,(pop x))) ,@(pop x))) data) + (return-from ,block-tag ,(or (cadr e) expression))) + ,@(mapcan (lambda (x &aux (x (cdr x))) + `(,(pop x) (return-from ,block-tag (apply (lambda ,(progn (pop x)(pop x)) ,@x) ,args)))) data)))))) + + +(defvar *unique-id-table* (make-hash-table)) +(defvar *unique-id-count* -1) + +(defun unique-id (obj) + "generates a unique integer id for its argument." + (or (gethash obj *unique-id-table*) + (setf (gethash obj *unique-id-table*) (incf *unique-id-count*)))) + +(defun restart-print (restart stream depth) + (declare (ignore depth)) + (if *print-escape* + (format stream "#<~s.~d>" (type-of restart) (unique-id restart)) + (restart-report restart stream))) + +(defstruct (restart (:print-function restart-print)) + name + function + report-function + interactive-function + (test-function (lambda (c) (declare (ignore c)) t))) + +(defun restart-report (restart stream &aux (f (restart-report-function restart))) + (if f (funcall f stream) + (format stream "~s" (or (restart-name restart) restart)))) + +(defun invoke-restart (restart &rest values) + (let ((real-restart (or (find-restart restart) + (error 'control-error :format-control "restart ~s is not active." :format-arguments (list restart))))) + (apply (restart-function real-restart) values))) + +(defun invoke-restart-interactively (restart) + (let ((real-restart (or (find-restart restart) + (error "restart ~s is not active." restart)))) + (apply (restart-function real-restart) + (let ((interactive-function (restart-interactive-function real-restart))) + (when interactive-function + (funcall interactive-function)))))) + + +(defmacro with-simple-restart ((restart-name format-control &rest format-arguments) + &body forms) + (declare (optimize (safety 1))) + `(restart-case (progn ,@forms) + (,restart-name nil + :report (lambda (stream) (format stream ,format-control ,@format-arguments)) + (values nil t)))) + +(defun abort (&optional condition) + "Transfers control to a restart named abort, signalling a control-error if + none exists." + (invoke-restart (find-restart 'abort condition)) + (error 'abort-failure)) + + +(defun muffle-warning (&optional condition) + "Transfers control to a restart named muffle-warning, signalling a + control-error if none exists." + (invoke-restart (find-restart 'muffle-warning condition))) + +(macrolet ((define-nil-returning-restart (name args doc) + (let ((restart (gensym))) + `(defun ,name (,@args &optional condition) + ,doc + (declare (optimize (safety 1))) + (let ((,restart (find-restart ',name condition))) (when ,restart (invoke-restart ,restart ,@args))))))) + + (define-nil-returning-restart continue nil + "Transfer control to a restart named continue, returning nil if none exists.") + + (define-nil-returning-restart store-value (value) + "Transfer control and value to a restart named store-value, returning nil if + none exists.") + + (define-nil-returning-restart use-value (value) + "Transfer control and value to a restart named use-value, returning nil if + none exists.")) + +(defun show-restarts (&aux (i 0)) + (mapc (lambda (x) + (format t "~& ~4d ~a ~a ~%" + (incf i) + (cond ((eq x *debug-abort*) "(abort)") ((eq x *debug-continue*) "(continue)") ("")) + x)) *debug-restarts*) + nil) diff --git a/lsp/gcl_seq.lsp b/lsp/gcl_seq.lsp new file mode 100755 index 0000000..6a9c2e8 --- /dev/null +++ b/lsp/gcl_seq.lsp @@ -0,0 +1,138 @@ +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +;;;; seq.lsp +;;;; +;;;; sequence routines + + +(in-package 'lisp) + +(export '(make-sequence concatenate map some every notany notevery)) + +(in-package 'system) + + +(proclaim '(optimize (safety 2) (space 3))) + + +(defun make-sequence (type size &key (initial-element nil iesp) + &aux element-type sequence) + (setq element-type + (cond ((eq type 'list) + (return-from make-sequence + (if iesp + (make-list size :initial-element initial-element) + (make-list size)))) + ((or (eq type 'simple-string) (eq type 'string)) 'string-char) + ((or (eq type 'simple-bit-vector) (eq type 'bit-vector)) 'bit) + ((or (eq type 'simple-vector) (eq type 'vector)) t) + (t + (setq type (normalize-type type)) + (when (subtypep (car type) 'list) + (if (or (and (eq 'null (car type)) (not (equal size 0))) + (and (eq 'cons (car type)) (equal size 0))) + (error 'type-error :datum type :expected-type (format nil "list (size ~S)" size))) + (return-from make-sequence + (if iesp + (make-list size :initial-element initial-element) + (make-list size)))) + (unless (or (eq (car type) 'array) + (eq (car type) 'simple-array)) + (error 'type-error :datum type :expected-type 'sequence)) + (let ((ssize (caddr type))) + (if (listp ssize) (setq ssize (car ssize))) + (if (not (si::fixnump ssize)) (setq ssize size)) + (unless (equal ssize size) + (error 'type-error :datum type :expected-type (format nil "~S (size ~S)" type size)))) + (or (cadr type) t)))) + (setq element-type (si::best-array-element-type element-type)) + (setq sequence (si:make-vector element-type size nil nil nil nil nil)) + (when iesp + (do ((i 0 (1+ i)) + (size size)) + ((>= i size)) + (declare (fixnum i size)) + (setf (elt sequence i) initial-element))) + sequence) + + +(defun concatenate (result-type &rest sequences) + (do ((x (make-sequence result-type + (apply #'+ (mapcar #'length sequences)))) + (s sequences (cdr s)) + (i 0)) + ((null s) x) + (declare (fixnum i)) + (do ((j 0 (1+ j)) + (n (length (car s)))) + ((>= j n)) + (declare (fixnum j n)) + (setf (elt x i) (elt (car s) j)) + (incf i)))) + + +(defun map (result-type function sequence &rest more-sequences) + (setq more-sequences (cons sequence more-sequences)) + (let ((l (apply #'min (mapcar #'length more-sequences)))) + (if (null result-type) + (do ((i 0 (1+ i)) + (l l)) + ((>= i l) nil) + (declare (fixnum i l)) + (apply function (mapcar #'(lambda (z) (elt z i)) + more-sequences))) + (let ((x (make-sequence result-type l))) + (do ((i 0 (1+ i)) + (l l)) + ((>= i l) x) + (declare (fixnum i l)) + (setf (elt x i) + (apply function (mapcar #'(lambda (z) (elt z i)) + more-sequences)))))))) + + +(defun some (predicate sequence &rest more-sequences) + (setq more-sequences (cons sequence more-sequences)) + (do ((i 0 (1+ i)) + (l (apply #'min (mapcar #'length more-sequences)))) + ((>= i l) nil) + (declare (fixnum i l)) + (let ((that-value + (apply predicate + (mapcar #'(lambda (z) (elt z i)) more-sequences)))) + (when that-value (return that-value))))) + + +(defun every (predicate sequence &rest more-sequences) + (setq more-sequences (cons sequence more-sequences)) + (do ((i 0 (1+ i)) + (l (apply #'min (mapcar #'length more-sequences)))) + ((>= i l) t) + (declare (fixnum i l)) + (unless (apply predicate (mapcar #'(lambda (z) (elt z i)) more-sequences)) + (return nil)))) + + +(defun notany (predicate sequence &rest more-sequences) + (not (apply #'some predicate sequence more-sequences))) + + +(defun notevery (predicate sequence &rest more-sequences) + (not (apply #'every predicate sequence more-sequences))) diff --git a/lsp/gcl_seqlib.lsp b/lsp/gcl_seqlib.lsp new file mode 100755 index 0000000..c2b41c9 --- /dev/null +++ b/lsp/gcl_seqlib.lsp @@ -0,0 +1,778 @@ +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +;;;; seqlib.lsp +;;;; +;;;; sequence routines + + +(in-package 'lisp) + + +(export '(reduce fill replace + remove remove-if remove-if-not + delete delete-if delete-if-not + count count-if count-if-not + substitute substitute-if substitute-if-not + nsubstitute nsubstitute-if nsubstitute-if-not + find find-if find-if-not + position position-if position-if-not + remove-duplicates delete-duplicates + mismatch search + with-hash-table-iterator + sort stable-sort merge map-into)) + + +(in-package 'system) + + +(proclaim '(optimize (safety 2) (space 3))) + + +(proclaim '(function seqtype (t) t)) +(defun seqtype (sequence) + (cond ((listp sequence) 'list) + ((stringp sequence) 'string) + ((bit-vector-p sequence) 'bit-vector) + ((vectorp sequence) (list 'array (array-element-type sequence))) + (t (error "~S is not a sequence." sequence)))) + +(proclaim '(function call-test (t t t t) t)) +(defun call-test (test test-not item keyx) + (cond (test (funcall test item keyx)) + (test-not (not (funcall test-not item keyx))) + (t (eql item keyx)))) + + +(proclaim '(function check-seq-start-end (t t) t)) +(defun check-seq-start-end (start end) + (unless (and (si:fixnump start) (si:fixnump end)) + (error "Fixnum expected.")) + (when (> (the fixnum start) (the fixnum end)) + (error "START is greater than END."))) + +(proclaim '(function test-error() t)) +(defun test-error() + (error "both test and test not supplied")) + +(defun bad-seq-limit (x &optional y) + (error 'type-error :datum (if y (list x y) x) :expected-type 'sequence-limit));FIXME + + +(eval-when (compile eval) +(proclaim '(function the-start (t) fixnum)) +(proclaim '(function the-end (t t) fixnum)) +(defmacro f+ (x y) `(the fixnum (+ (the fixnum ,x) (the fixnum ,y)))) +(defmacro f- (x y) `(the fixnum (- (the fixnum ,x) (the fixnum ,y)))) + +(defmacro with-start-end ( start end seq &body body) + `(let ((,start (if ,start (the-start ,start) 0))) + (declare (fixnum ,start)) + (let ((,end (the-end ,end ,seq))) + (declare (fixnum ,end)) + (or (<= ,start ,end) (bad-seq-limit ,start ,end)) + ,@ body))) +) + +(defun the-end (x y) + (cond ((fixnump x) + (or (<= (the fixnum x) (the fixnum (length y))) + (bad-seq-limit x)) + x) + ((null x) + (length y)) + (t (bad-seq-limit x)))) + +(defun the-start (x) + (cond ((fixnump x) + (or (>= (the fixnum x) 0) + (bad-seq-limit x)) + (the fixnum x)) + ((null x) 0) + (t (bad-seq-limit x)))) + + + +(defun reduce (function sequence + &key from-end + start + end + (initial-value nil ivsp) + (key #'identity)) + (with-start-end start end sequence + (cond ((not from-end) + (when (null ivsp) + (when (>= start end) + (return-from reduce (funcall function))) + (setq initial-value (funcall key (elt sequence start))) + (setf start (f+ 1 start)) + ) + (do ((x initial-value + (funcall function x (funcall key (prog1 (elt sequence start) + (setf start (f+ 1 start)) + ))))) + ((>= start end) x))) + (t + (when (null ivsp) + (when (>= start end) + (return-from reduce (funcall function))) + (setf end (f+ end -1)) + (setq initial-value (funcall key (elt sequence end))) + ) + (do ((x initial-value (funcall function (funcall key (elt sequence end)) x))) + ((>= start end) x) + (setf end (f+ -1 end))))))) + + +(defun fill (sequence item + &key start end ) + (with-start-end start end sequence + (do ((i start (f+ 1 i))) + ((>= i end) sequence) + (declare (fixnum i)) + (setf (elt sequence i) item)))) + +(defun replace (s1 s2 &key (start1 0) end1 (start2 0) end2 &aux (os1 s1) s3) + (declare (optimize (safety 1))(:dynamic-extent s3)) + (when (and (eq s1 s2) (> start1 start2)) + (setq s3 (make-list (length s2)) s2 (replace s3 s2))) + (let* ((lp1 (listp s1)) (lp2 (listp s2))(start1 start1)(start2 start2) + (e1 (or end1 (if lp1 array-dimension-limit (length s1)))) + (e2 (or end2 (if lp2 array-dimension-limit (length s2))))) + (declare (fixnum start1 start2 e1 e2)) + (do ((i1 start1 (1+ i1))(i2 start2 (1+ i2)) + (s1 (if (when lp1 (> start1 0)) (nthcdr start1 s1) s1) (if lp1 (cdr s1) s1)) + (s2 (if (when lp2 (> start2 0)) (nthcdr start2 s2) s2) (if lp2 (cdr s2) s2))) + ((or (not s1) (>= i1 e1) (not s2) (>= i2 e2)) os1) + (declare (fixnum i1 i2)) + (let ((e2 (if lp2 (car s2) (aref s2 i2)))) + (if lp1 (setf (car s1) e2) (setf (aref s1 i1) e2)))))) + +;; (defun replace (sequence1 sequence2 +;; &key start1 end1 +;; start2 end2 ) +;; (with-start-end start1 end1 sequence1 +;; (with-start-end start2 end2 sequence2 +;; (if (and (eq sequence1 sequence2) +;; (> start1 start2)) +;; (do* ((i 0 (f+ 1 i)) +;; (l (if (< (f- end1 start1) +;; (f- end2 start2)) +;; (f- end1 start1) +;; (f- end2 start2))) +;; (s1 (f+ start1 (f+ -1 l)) (f+ -1 s1)) +;; (s2 (f+ start2 (f+ -1 l)) (f+ -1 s2))) +;; ((>= i l) sequence1) +;; (declare (fixnum i l s1 s2)) +;; (setf (elt sequence1 s1) (elt sequence2 s2))) +;; (do ((i 0 (f+ 1 i)) +;; (l (if (< (f- end1 start1) +;; (f- end2 start2)) +;; (f- end1 start1) +;; (f- end2 start2))) +;; (s1 start1 (f+ 1 s1)) +;; (s2 start2 (f+ 1 s2))) +;; ((>= i l) sequence1) +;; (declare (fixnum i l s1 s2)) +;; (setf (elt sequence1 s1) (elt sequence2 s2))))))) + + +;;; DEFSEQ macro. +;;; Usage: +;;; +;;; (DEFSEQ function-name argument-list countp everywherep body) +;;; +;;; The arguments ITEM and SEQUENCE (PREDICATE and SEQUENCE) +;;; and the keyword arguments are automatically supplied. +;;; If the function has the :COUNT argument, set COUNTP T. + +(eval-when (eval compile) +(defmacro defseq + (f args countp everywherep body + &aux (*macroexpand-hook* 'funcall)) + (setq *body* body) + (list 'progn + (let* ((from-end nil) + (iterate-i '(i start (f+ 1 i))) + (iterate-i-from-end '(i (f+ -1 end) (f+ -1 i))) + (endp-i '(>= i end)) + (endp-i-from-end '(< i start)) + (iterate-i-everywhere '(i 0 (f+ 1 i))) + (iterate-i-everywhere-from-end '(i (f+ -1 l) (f+ -1 i))) + (endp-i-everywhere '(>= i l)) + (endp-i-everywhere-from-end '(< i 0)) + (i-in-range '(and (<= start i) (< i end))) + (x '(elt sequence i)) + (keyx `(funcall key ,x)) + (satisfies-the-test `(call-test test test-not item ,keyx)) + (number-satisfied + `(n (internal-count item sequence + :from-end from-end + :test test :test-not test-not + :start start :end end + ,@(if countp '(:count count)) + :key key))) + (within-count '(< k count)) + (kount-0 '(k 0)) + (kount-up '(setq k (f+ 1 k)))) + `(defun ,f (,@args item sequence + &key from-end test test-not + start end + ,@(if countp '(count)) + (key #'identity) + ,@(if everywherep + (list '&aux '(l (length sequence))) + nil)) + ,@(if everywherep '((declare (fixnum l)))) + (if (eq key nil) (setq key #'identity)) + (with-start-end start end sequence + (let ,@(if countp + '(((count + (cond ((null count) most-positive-fixnum) + ((< count 0) 0) + ((> count most-positive-fixnum) most-positive-fixnum) + (t count)))))) + ,@(if countp '((declare (fixnum count)))) + nil + (and test test-not (test-error)) + (if (not from-end) + ,(eval-body) + ,(progn (setq from-end t + iterate-i iterate-i-from-end + endp-i endp-i-from-end + iterate-i-everywhere + iterate-i-everywhere-from-end + endp-i-everywhere + endp-i-everywhere-from-end) + (eval-body))))))) + `(defun ,(intern (si:string-concatenate (string f) "-IF") + (symbol-package f)) + (,@args predicate sequence + &key from-end + start end + ,@(if countp '(count)) + (key #'identity)) + (if (eq key nil) (setq key #'identity)) + (,f ,@args predicate sequence + :from-end from-end + :test #'funcall + :start start :end end + ,@(if countp '(:count count)) + :key key)) + `(defun ,(intern (si:string-concatenate (string f) "-IF-NOT") + (symbol-package f)) + (,@args predicate sequence + &key from-end start end + ,@(if countp '(count)) + (key #'identity)) + (if (eq key nil) (setq key #'identity)) + (,f ,@args predicate sequence + :from-end from-end + :test-not #'funcall + :start start :end end + ,@(if countp '(:count count)) + :key key)) + (list 'quote f))) + +(defmacro eval-body () *body*) +) + + +(defseq remove () t nil + (if (not from-end) + `(if (listp sequence) + (let ((l sequence) (l1 nil)) + (do ((i 0 (f+ 1 i))) + ((>= i start)) + (declare (fixnum i)) + (push (car l) l1) + (pop l)) + (do ((i start (f+ 1 i)) (j 0)) + ((or (>= i end) (>= j count) (endp l)) + (nreconc l1 l)) + (declare (fixnum i j)) + (cond ((call-test test test-not item (funcall key (car l))) + (setf j (f+ 1 j)) + (pop l)) + (t + (push (car l) l1) + (pop l))))) + (delete item sequence + :from-end from-end + :test test :test-not test-not + :start start :end end + :count count + :key key)) + `(delete item sequence + :from-end from-end + :test test :test-not test-not + :start start :end end + :count count + :key key))) + + +(defseq delete () t t + (if (not from-end) + `(if (listp sequence) + (let* ((l0 (cons nil sequence)) (l l0)) + (do ((i 0 (f+ 1 i))) + ((>= i start)) + (declare (fixnum i)) + (pop l)) + (do ((i start (f+ 1 i)) (j 0)) + ((or (>= i end) (>= j count) (endp (cdr l))) (cdr l0)) + (declare (fixnum i j)) + (cond ((call-test test test-not item (funcall key (cadr l))) + (setf j (f+ 1 j)) + (rplacd l (cddr l))) + (t (setq l (cdr l)))))) + (let (,number-satisfied) + (declare (fixnum n)) + (when (< n count) (setq count n)) + (do ((newseq + (make-sequence (seqtype sequence) + (the fixnum (f- l count)))) + ,iterate-i-everywhere + (j 0) + ,kount-0) + (,endp-i-everywhere newseq) + (declare (fixnum i j k)) + (cond ((and ,i-in-range ,within-count ,satisfies-the-test) + ,kount-up) + (t (setf (elt newseq j) ,x) + (setf j (f+ 1 j))))))) + `(let (,number-satisfied) + (declare (fixnum n)) + (when (< n count) (setq count n)) + (do ((newseq + (make-sequence (seqtype sequence) (the fixnum (f- l count)))) + ,iterate-i-everywhere + (j (f+ -1 (the fixnum (f- l count)))) +; (j (f- (the fixnum (f+ -1 end)) n)) + ,kount-0) + (,endp-i-everywhere newseq) + (declare (fixnum i j k)) + (cond ((and ,i-in-range ,within-count ,satisfies-the-test) + ,kount-up) + (t (setf (elt newseq j) ,x) + (setq j (f+ -1 j)))))))) + + +(defseq count () nil nil + `(do (,iterate-i ,kount-0) + (,endp-i k) + (declare (fixnum i k)) + (when (and ,satisfies-the-test) + ,kount-up))) + + +(defseq internal-count () t nil + `(do (,iterate-i ,kount-0) + (,endp-i k) + (declare (fixnum i k)) + (when (and ,within-count ,satisfies-the-test) + ,kount-up))) + + +(defseq substitute (newitem) t t + `(do ((newseq (make-sequence (seqtype sequence) l)) + ,iterate-i-everywhere + ,kount-0) + (,endp-i-everywhere newseq) + (declare (fixnum i k)) + (cond ((and ,i-in-range ,within-count ,satisfies-the-test) + (setf (elt newseq i) newitem) + ,kount-up) + (t (setf (elt newseq i) ,x)))))) + + +(defseq nsubstitute (newitem) t nil + `(do (,iterate-i ,kount-0) + (,endp-i sequence) + (declare (fixnum i k)) + (when (and ,within-count ,satisfies-the-test) + (setf ,x newitem) + ,kount-up))) + + +(defseq find () nil nil + `(do (,iterate-i) + (,endp-i nil) + (declare (fixnum i)) + (when ,satisfies-the-test (return ,x)))) + + +(defseq position () nil nil + `(do (,iterate-i) + (,endp-i nil) + (declare (fixnum i)) + (when ,satisfies-the-test (return i)))) + + +(defun remove-duplicates (sequence + &key from-end + test test-not + start end + (key #'identity)) + (and test test-not (test-error)) + (when (and (listp sequence) (not from-end) (null start) + (null end)) + (when (endp sequence) (return-from remove-duplicates nil)) + (do ((l sequence (cdr l)) (l1 nil)) + ((endp (cdr l)) + (return-from remove-duplicates (nreconc l1 l))) + (unless (member1 (car l) (cdr l) + :test test :test-not test-not + :key key) + (setq l1 (cons (car l) l1))))) + (delete-duplicates sequence + :from-end from-end + :test test :test-not test-not + :start start :end end + :key key)) + + +(defun delete-duplicates (sequence + &key from-end + test test-not + start + end + (key #'identity) + &aux (l (length sequence))) + (declare (fixnum l)) + (and test test-not (test-error)) + (when (and (listp sequence) (not from-end) (null start) + (null end)) + (when (endp sequence) (return-from delete-duplicates nil)) + (do ((l sequence)) + ((endp (cdr l)) + (return-from delete-duplicates sequence)) + (cond ((member1 (car l) (cdr l) + :test test :test-not test-not + :key key) + (rplaca l (cadr l)) + (rplacd l (cddr l))) + (t (setq l (cdr l)))))) + (with-start-end start end sequence + (if (not from-end) + (do ((n 0) + (i start (f+ 1 i))) + ((>= i end) + (do ((newseq (make-sequence (seqtype sequence) + (the fixnum (f- l n)))) + (i 0 (f+ 1 i)) + (j 0)) + ((>= i l) newseq) + (declare (fixnum i j)) + (cond ((and (<= start i) + (< i end) + (position (funcall key (elt sequence i)) + sequence + :test test + :test-not test-not + :start (the fixnum (f+ 1 i)) + :end end + :key key))) + (t + (setf (elt newseq j) (elt sequence i)) + (setf j (f+ 1 j)))))) + (declare (fixnum n i)) + (when (position (funcall key (elt sequence i)) + sequence + :test test + :test-not test-not + :start (the fixnum (f+ 1 i)) + :end end + :key key) + (setf n (f+ 1 n)))) + (do ((n 0) + (i (f+ -1 end) (f+ -1 i))) + ((< i start) + (do ((newseq (make-sequence (seqtype sequence) + (the fixnum (f- l n)))) + (i (f+ -1 l) (f+ -1 i)) + (j (f- (the fixnum (f+ -1 l)) n))) + ((< i 0) newseq) + (declare (fixnum i j)) + (cond ((and (<= start i) + (< i end) + (position (funcall key (elt sequence i)) + sequence + :from-end t + :test test + :test-not test-not + :start start + :end i + :key key))) + (t + (setf (elt newseq j) (elt sequence i)) + (setq j (f+ -1 j)))))) + (declare (fixnum n i)) + (when (position (funcall key (elt sequence i)) + sequence + :from-end t + :test test + :test-not test-not + :start start + :end i + :key key) + (setf n (f+ 1 n))))))) + + +(defun mismatch (sequence1 sequence2 + &key from-end test test-not + (key #'identity) + start1 start2 + end1 end2) + (and test test-not (test-error)) + (with-start-end start1 end1 sequence1 + (with-start-end start2 end2 sequence2 + (if (not from-end) + (do ((i1 start1 (f+ 1 i1)) + (i2 start2 (f+ 1 i2))) + ((or (>= i1 end1) (>= i2 end2)) + (if (and (>= i1 end1) (>= i2 end2)) nil i1)) + (declare (fixnum i1 i2)) + (unless (call-test test test-not + (funcall key (elt sequence1 i1)) + (funcall key (elt sequence2 i2))) + (return i1))) + (do ((i1 (f+ -1 end1) (f+ -1 i1)) + (i2 (f+ -1 end2) (f+ -1 i2))) + ((or (< i1 start1) (< i2 start2)) + (if (and (< i1 start1) (< i2 start2)) nil (f+ 1 i1))) + (declare (fixnum i1 i2)) + (unless (call-test test test-not + (funcall key (elt sequence1 i1)) + (funcall key (elt sequence2 i2))) + (return (f+ 1 i1)))))))) + + +(defun search (sequence1 sequence2 + &key from-end test test-not + (key #'identity) + start1 start2 + end1 end2) + (and test test-not (test-error)) + (with-start-end start1 end1 sequence1 + (with-start-end start2 end2 sequence2 + (if (not from-end) + (loop + (do ((i1 start1 (f+ 1 i1)) + (i2 start2 (f+ 1 i2))) + ((>= i1 end1) (return-from search start2)) + (declare (fixnum i1 i2)) + (when (>= i2 end2) (return-from search nil)) + (unless (call-test test test-not + (funcall key (elt sequence1 i1)) + (funcall key (elt sequence2 i2))) + (return nil))) + (setf start2 (f+ 1 start2))) + (loop + (do ((i1 (f+ -1 end1) (f+ -1 i1)) + (i2 (f+ -1 end2) (f+ -1 i2))) + ((< i1 start1) (return-from search (the fixnum (f+ 1 i2)))) + (declare (fixnum i1 i2)) + (when (< i2 start2) (return-from search nil)) + (unless (call-test test test-not + (funcall key (elt sequence1 i1)) + (funcall key (elt sequence2 i2))) + (return nil))) + (setq end2 (f+ -1 end2))))))) + + +(defun sort (sequence predicate &key (key #'identity)) + (if (listp sequence) + (list-merge-sort sequence predicate key) + (quick-sort sequence 0 (the fixnum (length sequence)) predicate key))) + + +(defun list-merge-sort (l predicate key) + (labels + ((sort (l) + (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))))) + (setq i (floor i 2)) + (do ((j 1 (f+ 1 j)) (l1 l (cdr l1))) + ((>= j i) + (setq left l) + (setq right (cdr l1)) + (rplacd l1 nil)) + (declare (fixnum j))) + (setq left (sort left)) + (setq right (sort right)) + (cond ((endp left) (return right)) + ((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))) + left + (rplacd l1 left) + (setq l1 (cdr l1)) + (setq left (cdr left)) + (when (endp left) + (rplacd l1 right) + (return (cdr l0))) + (setq key-left (funcall key (car left))) + (go loop) + right + (rplacd l1 right) + (setq l1 (cdr l1)) + (setq right (cdr right)) + (when (endp right) + (rplacd l1 left) + (return (cdr l0))) + (setq key-right (funcall key (car right))) + (go loop)))) + (sort l))) + + +#| +(defun list-quick-sort (l predicate key) + (if (or (endp l) (endp (cdr l))) + l + (multiple-value-bind (x y) + (list-quick-sort-partition (car l) (cdr l) predicate key) + (nconc (list-quick-sort x predicate key) + (list (car l)) + (list-quick-sort y predicate key))))) + +(defun list-quick-sort-partition (k l predicate key) + (do ((l l (cdr l)) (x nil) (y nil)) + ((endp l) (values (nreverse x) (nreverse y))) + (if (funcall predicate (funcall key (car l)) (funcall key k)) + (setq x (cons (car l) x)) + (setq y (cons (car l) y))))) +|# + + +(proclaim '(function quick-sort (t fixnum fixnum t t) t)) + +(defun quick-sort (seq start end pred key) + (declare (fixnum start end)) + (if (<= end (the fixnum (f+ 1 start))) + seq + (let* ((j start) (k end) (d (elt seq start)) (kd (funcall key d))) + (declare (fixnum j k)) + (block outer-loop + (loop (loop (setq k (f+ -1 k)) + (unless (< j k) (return-from outer-loop)) + (when (funcall pred (funcall key (elt seq k)) kd) + (return))) + (loop (setf j (f+ 1 j)) + (unless (< j k) (return-from outer-loop)) + (unless (funcall pred (funcall key (elt seq j)) kd) + (return))) + (let ((temp (elt seq j))) + (setf (elt seq j) (elt seq k) + (elt seq k) temp)))) + (setf (elt seq start) (elt seq j) + (elt seq j) d) + (quick-sort seq start j pred key) + (quick-sort seq (f+ 1 j) end pred key)))) + +(defun stable-sort (sequence predicate &key (key #'identity)) + (if (listp sequence) + (list-merge-sort sequence predicate key) + (if (or (stringp sequence) (bit-vector-p sequence)) + (sort sequence predicate :key key) + (coerce (list-merge-sort (coerce sequence 'list) + predicate + key) + (seqtype sequence))))) + + +(defun merge (result-type sequence1 sequence2 predicate + &key (key #'identity) + &aux (l1 (length sequence1)) (l2 (length sequence2))) + (declare (fixnum l1 l2)) + (when (equal key 'nil) (setq key #'identity)) + (do ((newseq (make-sequence result-type (the fixnum (f+ l1 l2)))) + (j 0 (f+ 1 j)) + (i1 0) + (i2 0)) + ((and (= i1 l1) (= i2 l2)) newseq) + (declare (fixnum j i1 i2)) + (cond ((and (< i1 l1) (< i2 l2)) + (cond ((funcall predicate + (funcall key (elt sequence1 i1)) + (funcall key (elt sequence2 i2))) + (setf (elt newseq j) (elt sequence1 i1)) + (setf i1 (f+ 1 i1))) + ((funcall predicate + (funcall key (elt sequence2 i2)) + (funcall key (elt sequence1 i1))) + (setf (elt newseq j) (elt sequence2 i2)) + (setf i2 (f+ 1 i2))) + (t + (setf (elt newseq j) (elt sequence1 i1)) + (setf i1 (f+ 1 i1))))) + ((< i1 l1) + (setf (elt newseq j) (elt sequence1 i1)) + (setf i1 (f+ 1 i1))) + (t + (setf (elt newseq j) (elt sequence2 i2)) + (setf i2 (f+ 1 i2)))))) + +(defun map-into (result-sequence function &rest sequences) +; "map-into: (result-sequence function &rest sequences)" + (let ((nel (apply #'min (if (subtypep (type-of result-sequence) 'vector) + (array-dimension result-sequence 0) + (length result-sequence)) + (mapcar #'length sequences)))) + ;; Set the fill pointer to the number of iterations + (when (and (subtypep (type-of result-sequence) 'vector) + (array-has-fill-pointer-p result-sequence)) + (setf (fill-pointer result-sequence) nel)) + ;; Perform mapping + (dotimes (k nel result-sequence) + (setf (elt result-sequence k) + (apply function (mapcar #'(lambda (v) (elt v k)) sequences)))))) + + +(defmacro with-hash-table-iterator ((name hash-table) &body body) + (let ((table (gensym )) + (ind (gensym "ind"))) + `(let ((,table ,hash-table) + (,ind 0)) + (macrolet ((,name () + `(multiple-value-bind + (more key val) + (si::next-hash-table-entry ,',table ,',ind) + (cond ((>= (the fixnum more) 0) + (setq ,',ind more) + (values t key val)) + (t (values nil nil nil)))))) + ,@body)))) + + diff --git a/lsp/gcl_serror.lsp b/lsp/gcl_serror.lsp new file mode 100755 index 0000000..0181f80 --- /dev/null +++ b/lsp/gcl_serror.lsp @@ -0,0 +1,281 @@ +;; -*-Lisp-*- +(in-package :si) + +(macrolet + ((make-conditionp (condition &aux (n (intern (concatenate 'string (string condition) "P")))) + `(defun ,n (x &aux (z (si-find-class ',condition))) + (when z + (funcall (setf (symbol-function ',n) (lambda (x) (typep x z))) x)))) + (make-condition-classp (class &aux (n (intern (concatenate 'string (string class) "-CLASS-P")))) + `(defun ,n (x &aux (s (si-find-class 'standard-class)) (z (si-find-class ',class))) + (when (and s z) + (funcall (setf (symbol-function ',n) + (lambda (x &aux (x (if (symbolp x) (si-find-class x) x))) + (when (typep x s) + (member z (si-class-precedence-list x))))) x))))) + (make-conditionp condition) + (make-conditionp warning) + (make-condition-classp condition) + (make-condition-classp simple-condition)) + +(proclaim '(ftype (function (t *) t) make-condition)) + +(defun coerce-to-condition (datum arguments default-type function-name) + (cond ((conditionp datum) + (if 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) + ((condition-class-p datum) + (apply #'make-condition datum arguments)) + ((when (condition-class-p default-type) (or (stringp datum) (functionp datum))) + (make-condition default-type :format-control datum :format-arguments arguments)) + ((coerce-to-string datum arguments)))) + +(defvar *handler-clusters* nil) +(defvar *break-on-signals* nil) + +(defun signal (datum &rest arguments) + (declare (optimize (safety 1))) + (let ((*handler-clusters* *handler-clusters*) + (condition (coerce-to-condition datum arguments 'simple-condition 'signal))) + (if (typep condition *break-on-signals*) + (break "~a~%break entered because of *break-on-signals*." condition)) + (do nil ((not *handler-clusters*)) + (dolist (handler (pop *handler-clusters*)) + (when (typep condition (car handler)) + (funcall (cdr handler) condition)))) + nil)) + +(defvar *debugger-hook* nil) +(defvar *debug-level* 1) +(defvar *debug-restarts* nil) +(defvar *debug-abort* nil) +(defvar *debug-continue* nil) +(defvar *abort-restarts* nil) + +(defun break-level-invoke-restart (n) + (cond ((when (plusp n) (< n (+ (length *debug-restarts*) 1))) + (invoke-restart-interactively (nth (1- n) *debug-restarts*))) + ((format t "~&no such restart.")))) + +(defun find-ihs (s i &optional (j i)) + (cond ((eq (ihs-fname i) s) i) + ((and (> i 0) (find-ihs s (1- i) j))) + (j))) + +(defmacro without-interrupts (&rest forms) + `(let (*quit-tag* *quit-tags* *restarts*) + ,@forms)) + +(defun process-args (args &aux (control (member :format-control args))) + (labels ((r (x &aux (z (member-if (lambda (x) (member x '(:format-control :format-arguments))) x))) + (if z (nconc (ldiff x z) (r (cddr z))) x))) + (if control + (nconc (r args) (list (apply 'format nil (cadr control) (cadr (member :format-arguments args))))) + args))) + +(defun coerce-to-string (datum args) + (cond ((stringp datum) + (if args + (let ((*print-pretty* nil) + (*print-level* *debug-print-level*) + (*print-length* *debug-print-level*) + (*print-case* :upcase)) + (apply 'format nil datum args)) + datum)) + ((symbolp datum) + (let ((args (process-args args))) + (substitute + #\^ #\~ + (coerce-to-string + (if args + (apply 'string-concatenate (cons datum (make-list (length args) :initial-element " ~s"))) + (string datum)) + args)))) + ("unknown error"))) + +(defun warn (datum &rest arguments) + (declare (optimize (safety 2))) + (let ((c (process-error datum arguments 'simple-warning))) + (check-type c (or string (satisfies warningp)) "a warning condition") + (when *break-on-warnings* + (break "~A~%break entered because of *break-on-warnings*." c)) + (restart-case + (signal c) + (muffle-warning nil :report "Skip warning." (return-from warn nil))) + (format *error-output* "~&Warning: ~a~%" c) + nil)) + +(dolist (l '(break cerror error universal-error-handler ihs-top get-sig-fn-name next-stack-frame check-type-symbol)) + (setf (get l 'dbl-invisible) t)) + +(defvar *sig-fn-name* nil) + +(defun get-sig-fn-name (&aux (p (ihs-top))(p (next-stack-frame p))) + (when p (ihs-fname p))) + +(defun process-error (datum args &optional (default-type 'simple-error)) + (let ((internal (cond ((simple-condition-class-p datum) + (find-symbol (concatenate 'string "INTERNAL-" (string datum)) :conditions)) + ((condition-class-p datum) + (find-symbol (concatenate 'string "INTERNAL-SIMPLE-" (string datum)) :conditions))))) + (coerce-to-condition (or internal datum) (if internal (list* :function-name *sig-fn-name* args) args) default-type 'process-error))) + +(defun universal-error-handler (n cp fn cs es &rest args &aux (*sig-fn-name* fn)) + (declare (ignore es)) + (if cp (apply #'cerror cs n args) (apply #'error n args))) + +(defun cerror (continue-string datum &rest args &aux (*sig-fn-name* (or *sig-fn-name* (get-sig-fn-name)))) + (values + (with-simple-restart + (continue continue-string args) + (apply #'error datum args)))) +(putprop 'cerror t 'compiler::cmp-notinline) + + +(defun error (datum &rest args &aux (*sig-fn-name* (or *sig-fn-name* (get-sig-fn-name)))) + (let ((c (process-error datum args))(q (or *quit-tag* +top-level-quit-tag+))) + (signal c) + (invoke-debugger c) + (throw q q))) +(putprop 'error t 'compiler::cmp-notinline) + + +(defun invoke-debugger (condition) + + (when *debugger-hook* + (let ((hook *debugger-hook*) *debugger-hook*) + (funcall hook condition hook))) + + (maybe-clear-input) + + (let ((correctable (find-restart 'continue)) + *print-pretty* + (*print-level* *debug-print-level*) + (*print-length* *debug-print-level*) + (*print-case* :upcase)) + (terpri *error-output*) + (format *error-output* (if (and correctable *break-enable*) "~&Correctable error: " "~&Error: ")) + (let ((*indent-formatted-output* t)) + (when (stringp condition) (format *error-output* condition))) + (terpri *error-output*) + (if (> (length *link-array*) 0) + (format *error-output* "Fast links are on: do (si::use-fast-links nil) for debugging~%")) + (format *error-output* "Signalled by ~:@(~S~).~%" (or *sig-fn-name* "an anonymous function")) + (when (and correctable *break-enable*) + (format *error-output* "~&If continued: ") + (funcall (restart-report-function correctable) *error-output*)) + (force-output *error-output*) + (break-level condition))) + + +(defun dbl-eval (- &aux (break-command t)) + (let ((val-list (multiple-value-list + (cond + ((keywordp -) (break-call - nil 'break-command)) + ((and (consp -) (keywordp (car -))) (break-call (car -) (cdr -) 'break-command)) + ((integerp -) (break-level-invoke-restart -)) + (t (setq break-command nil) (evalhook - nil nil *break-env*)))))) + (cons break-command val-list))) + +(defun do-break-level (at env p-e-p debug-level break-level &aux (first t)) + + (do nil (nil) + + (unless + (with-simple-restart + (abort "Return to debug level ~D." debug-level) + (not + (catch 'step-continue + (let* ((*break-level* break-level) + (*break-enable* (unless p-e-p *break-enable*)) + (*readtable* (or *break-readtable* *readtable*)) + *break-env* *read-suppress*); *error-stack*) + + (setq +++ ++ ++ + + -) + + (when first + (catch-fatal 1) + (setq *interrupt-enable* t first nil) + (cond (p-e-p + (format *debug-io* "~&~A~2%" at) + (set-current) + (setq *no-prompt* nil) + (show-restarts)) + ((set-back at env)))) + + (if *no-prompt* + (setq *no-prompt* nil) + (format *debug-io* "~&~a~a>~{~*>~}" + (if p-e-p "" "dbl:") + (if (eq *package* (find-package 'user)) "" (package-name *package*)) + break-level)) + (force-output *error-output*) + + (setq - (dbl-read *debug-io* nil *top-eof*)) + (when (eq - *top-eof*) (bye -1)) + (let* ((ev (dbl-eval -)) + (break-command (car ev)) + (values (cdr ev))) + (and break-command (eq (car values) :resume)(return)) + (setq /// // // / / values *** ** ** * * (car /)) + (fresh-line *debug-io*) + (dolist (val /) + (prin1 val *debug-io*) + (terpri *debug-io*))) + nil)))) + (terpri *debug-io*) + (break-current)))) + + +(defun break-level (at &optional env) + (let* ((p-e-p (unless (listp at) t)) + (+ +) (++ ++) (+++ +++) + (- -) + (* *) (** **) (*** ***) + (/ /) (// //) (/// ///) + (break-level (if p-e-p (cons t *break-level*) *break-level*)) + (debug-level *debug-level*) + (*quit-tags* (cons (cons *break-level* *quit-tag*) *quit-tags*)) + *quit-tag* + (*ihs-base* (1+ *ihs-top*)) + (*ihs-top* (ihs-top)) + (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top)))) + (*frs-top* (frs-top)) + (*current-ihs* *ihs-top*) + (*debug-level* (1+ *debug-level*)) + (*debug-restarts* (compute-restarts)) + (*debug-abort* (find-restart 'abort)) + (*debug-continue* (find-restart 'continue)) + (*abort-restarts* (remove-if-not (lambda (x) (eq 'abort (restart-name x))) *debug-restarts*))) + + (do-break-level at env p-e-p debug-level break-level))) + +(putprop 'break-level t 'compiler::cmp-notinline) + +(defun break (&optional format-string &rest args &aux message (*sig-fn-name* (or *sig-fn-name* (get-sig-fn-name)))) + + (let ((*print-pretty* nil) + (*print-level* 4) + (*print-length* 4) + (*print-case* :upcase)) + (terpri *error-output*) + (cond (format-string + (format *error-output* "~&Break: ") + (let ((*indent-formatted-output* t)) + (apply 'format *error-output* format-string args)) + (terpri *error-output*) + (setq message (apply 'format nil format-string args))) + (t (format *error-output* "~&Break.~%") + (setq message "")))) + (with-simple-restart + (continue "Return from break.") + (let ((*break-enable* t)) (break-level message))) + nil) +(putprop 'break t 'compiler::cmp-notinline) diff --git a/lsp/gcl_setf.lsp b/lsp/gcl_setf.lsp new file mode 100755 index 0000000..9ada679 --- /dev/null +++ b/lsp/gcl_setf.lsp @@ -0,0 +1,543 @@ +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +;;;; setf.lsp +;;;; +;;;; setf routines + + +(in-package 'lisp) + + +(export '(setf psetf shiftf rotatef + define-modify-macro defsetf + getf remf incf decf push pushnew pop + define-setf-method get-setf-method get-setf-method-multiple-value)) + + +(in-package 'system) + + +(eval-when (compile) (proclaim '(optimize (safety 2) (space 3)))) +;(eval-when (eval compile) (defun si:clear-compiler-properties (symbol))) +(eval-when (eval compile) (setq si:*inhibit-macro-special* nil)) + + +;;; DEFSETF macro. +(defmacro defsetf (access-fn &rest rest) + (cond ((and (car rest) (or (symbolp (car rest)) (functionp (car rest)))) + `(eval-when(compile eval load) + (si:putprop ',access-fn ',(car rest) 'setf-update-fn) + (remprop ',access-fn 'setf-lambda) + (remprop ',access-fn 'setf-method) + (si:putprop ',access-fn + ,(when (not (endp (cdr rest))) + (unless (stringp (cadr rest)) + (error "A doc-string expected.")) + (unless (endp (cddr rest)) + (error "Extra arguments.")) + (cadr rest)) + 'setf-documentation) + ',access-fn)) + (t + (unless (= (list-length (cadr rest)) 1) + (error "(store-variable) expected.")) + `(eval-when (compile eval load) + (si:putprop ',access-fn ',rest 'setf-lambda) + (remprop ',access-fn 'setf-update-fn) + (remprop ',access-fn 'setf-method) + (si:putprop ',access-fn + ,(find-documentation (cddr rest)) + 'setf-documentation) + ',access-fn)))) + + +;;; DEFINE-SETF-METHOD macro. +(defmacro define-setf-method (access-fn &rest rest &aux args env body) + (multiple-value-setq (args env) + (get-&environment (car rest))) + (setq body (cdr rest)) + (cond (env (setq args (cons env args))) + (t (setq args (cons (gensym) args)) + (push `(declare (ignore ,(car args))) body))) + `(eval-when (compile eval load) + (si:putprop ',access-fn #'(lambda ,args ,@ body) 'setf-method) + (remprop ',access-fn 'setf-lambda) + (remprop ',access-fn 'setf-update-fn) + (si:putprop ',access-fn + ,(find-documentation (cdr rest)) + 'setf-documentation) + ',access-fn)) + + +;;; GET-SETF-METHOD. +;;; It just calls GET-SETF-METHOD-MULTIPLE-VALUE +;;; and checks the number of the store variable. +(defun get-setf-method (form &optional env) + (multiple-value-bind (vars vals stores store-form access-form) + (get-setf-method-multiple-value form env) + (unless (= (list-length stores) 1) + (error "Multiple store-variables are not allowed.")) + (values vars vals stores store-form access-form))) + + +;;;; GET-SETF-METHOD-MULTIPLE-VALUE. + +(defun get-setf-method-multiple-value (form &optional env &aux tem) + (cond ((symbolp form) + (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)) + ((and env (setq tem (assoc (car form) (second env)))) + (setq tem (macroexpand form env)) + (if (eq form tem) (error "Cannot get setf-method for ~a" form)) + (return-from get-setf-method-multiple-value + (get-setf-method-multiple-value tem env))) + ((get (car form) 'setf-method) + (apply (get (car form) 'setf-method) env (cdr form))) + ((or (get (car form) 'setf-update-fn) + (setq tem (get (car form) 'si::structure-access))) + (let ((vars (mapcar #'(lambda (x) + (declare (ignore x)) + (gensym)) + (cdr form))) + (store (gensym))) + (values vars (cdr form) (list store) + (cond (tem + (setf-structure-access (car vars) (car tem) + (cdr tem) store)) + (t + `(,(get (car form) 'setf-update-fn) + ,@vars ,store))) + (cons (car form) vars)))) + ((get (car form) 'setf-lambda) + (let* ((vars (mapcar #'(lambda (x) + (declare (ignore x)) + (gensym)) + (cdr form))) + (store (gensym)) + (l (get (car form) 'setf-lambda)) + ;; this looks bogus to me. What if l is compiled?--wfs + (f `(lambda ,(car l) #'(lambda ,(cadr l) ,@(cddr l))))) + (values vars (cdr form) (list store) + (funcall (apply f vars) store) + (cons (car form) vars)))) + ((macro-function (car form)) + (get-setf-method-multiple-value (macroexpand form))) + (t + (error 'program-error :format-control "Cannot expand the SETF form ~S." :format-arguments (list form))))) + + +;;;; SETF definitions. + +(defsetf car (x) (y) `(progn (rplaca ,x ,y) ,y)) +(defsetf cdr (x) (y) `(progn (rplacd ,x ,y), y)) +(defsetf caar (x) (y) `(progn (rplaca (car ,x) ,y) ,y)) +(defsetf cdar (x) (y) `(progn (rplacd (car ,x) ,y) ,y)) +(defsetf cadr (x) (y) `(progn (rplaca (cdr ,x) ,y) ,y)) +(defsetf cddr (x) (y) `(progn (rplacd (cdr ,x) ,y) ,y)) +(defsetf caaar (x) (y) `(progn (rplaca (caar ,x) ,y) ,y)) +(defsetf cdaar (x) (y) `(progn (rplacd (caar ,x) ,y) ,y)) +(defsetf cadar (x) (y) `(progn (rplaca (cdar ,x) ,y) ,y)) +(defsetf cddar (x) (y) `(progn (rplacd (cdar ,x) ,y) ,y)) +(defsetf caadr (x) (y) `(progn (rplaca (cadr ,x) ,y) ,y)) +(defsetf cdadr (x) (y) `(progn (rplacd (cadr ,x) ,y) ,y)) +(defsetf caddr (x) (y) `(progn (rplaca (cddr ,x) ,y) ,y)) +(defsetf cdddr (x) (y) `(progn (rplacd (cddr ,x) ,y) ,y)) +(defsetf caaaar (x) (y) `(progn (rplaca (caaar ,x) ,y) ,y)) +(defsetf cdaaar (x) (y) `(progn (rplacd (caaar ,x) ,y) ,y)) +(defsetf cadaar (x) (y) `(progn (rplaca (cdaar ,x) ,y) ,y)) +(defsetf cddaar (x) (y) `(progn (rplacd (cdaar ,x) ,y) ,y)) +(defsetf caadar (x) (y) `(progn (rplaca (cadar ,x) ,y) ,y)) +(defsetf cdadar (x) (y) `(progn (rplacd (cadar ,x) ,y) ,y)) +(defsetf caddar (x) (y) `(progn (rplaca (cddar ,x) ,y) ,y)) +(defsetf cdddar (x) (y) `(progn (rplacd (cddar ,x) ,y) ,y)) +(defsetf caaadr (x) (y) `(progn (rplaca (caadr ,x) ,y) ,y)) +(defsetf cdaadr (x) (y) `(progn (rplacd (caadr ,x) ,y) ,y)) +(defsetf cadadr (x) (y) `(progn (rplaca (cdadr ,x) ,y) ,y)) +(defsetf cddadr (x) (y) `(progn (rplacd (cdadr ,x) ,y) ,y)) +(defsetf caaddr (x) (y) `(progn (rplaca (caddr ,x) ,y) ,y)) +(defsetf cdaddr (x) (y) `(progn (rplacd (caddr ,x) ,y) ,y)) +(defsetf cadddr (x) (y) `(progn (rplaca (cdddr ,x) ,y) ,y)) +(defsetf cddddr (x) (y) `(progn (rplacd (cdddr ,x) ,y) ,y)) +(defsetf first (x) (y) `(progn (rplaca ,x ,y) ,y)) +(defsetf second (x) (y) `(progn (rplaca (cdr ,x) ,y) ,y)) +(defsetf third (x) (y) `(progn (rplaca (cddr ,x) ,y) ,y)) +(defsetf fourth (x) (y) `(progn (rplaca (cdddr ,x) ,y) ,y)) +(defsetf fifth (x) (y) `(progn (rplaca (cddddr ,x) ,y) ,y)) +(defsetf sixth (x) (y) `(progn (rplaca (nthcdr 5 ,x) ,y) ,y)) +(defsetf seventh (x) (y) `(progn (rplaca (nthcdr 6 ,x) ,y) ,y)) +(defsetf eighth (x) (y) `(progn (rplaca (nthcdr 7 ,x) ,y) ,y)) +(defsetf ninth (x) (y) `(progn (rplaca (nthcdr 8 ,x) ,y) ,y)) +(defsetf tenth (x) (y) `(progn (rplaca (nthcdr 9 ,x) ,y) ,y)) +(defsetf rest (x) (y) `(progn (rplacd ,x ,y) ,y)) +(defsetf svref si:svset) +(defsetf elt si:elt-set) +(defsetf symbol-value set) +(defsetf symbol-function si:fset) +(defsetf macro-function (s) (v) `(progn (si:fset ,s (cons 'macro ,v)) ,v)) +(defsetf aref si:aset) +(defsetf get put-aux) +(defmacro put-aux (a b &rest l) + `(si::sputprop ,a ,b ,(car (last l)))) +(defsetf nth (n l) (v) `(progn (rplaca (nthcdr ,n ,l) ,v) ,v)) +(defsetf char si:char-set) +(defsetf schar si:schar-set) +(defsetf bit si:aset) +(defsetf sbit si:aset) +(defsetf fill-pointer si:fill-pointer-set) +(defsetf symbol-plist si:set-symbol-plist) +(defsetf gethash (k h &optional d) (v) `(si:hash-set ,k ,h ,v)) +(defsetf row-major-aref si:aset1) +(defsetf documentation (s d) (v) + `(case ,d + (variable (si:putprop ,s ,v 'variable-documentation)) + (function (si:putprop ,s ,v 'function-documentation)) + (structure (si:putprop ,s ,v 'structure-documentation)) + (type (si:putprop ,s ,v 'type-documentation)) + (setf (si:putprop ,s ,v 'setf-documentation)) + (t (error "~S is an illegal documentation type." ,d)))) + + +(define-setf-method getf (&environment env place indicator &optional default) + (multiple-value-bind (vars vals stores store-form access-form) + (get-setf-method place env) + (let ((itemp (gensym)) (store (gensym))) + (values `(,@vars ,itemp) + `(,@vals ,indicator) + (list store) + `(let ((,(car stores) (si:put-f ,access-form ,store ,itemp))) + ,store-form + ,store) + `(getf ,access-form ,itemp ,default))))) + +(defsetf subseq (sequence1 start1 &optional end1) + (sequence2) + `(replace ,sequence1 ,sequence2 :start1 ,start1 :end1 ,end1)) + +(define-setf-method the (&environment env type form) + (multiple-value-bind (vars vals stores store-form access-form) + (get-setf-method form env) + (let ((store (gensym))) + (values vars vals (list store) + `(let ((,(car stores) (the ,type ,store))) ,store-form) + `(the ,type ,access-form))))) + +#| +(define-setf-method 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)) + (multiple-value-bind (vars vals stores store-form access-form) + (get-setf-method (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))))) +|# + +(define-setf-method apply (&environment env fn &rest rest) + (unless (and (consp fn) + (or (eq (car fn) 'function) (eq (car fn) 'quote)) + (symbolp (cadr 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-method (cons (cadr fn) rest) env) + (cond ((eq (car (last store-form)) (car (last vars))) + (values vars vals stores + `(apply #',(car store-form) ,@(cdr store-form)) + `(apply #',(cadr fn) ,@(cdr access-form)))) + ((eq (car (last (butlast store-form))) (car (last vars))) + (values vars vals stores + `(apply #',(car store-form) + ,@(cdr (butlast store-form 2)) + (append ,(car (last (butlast store-form))) + (list ,(car (last store-form))))) + `(apply #',(cadr fn) ,@(cdr access-form)))) + (t (error "Can't get the setf-method of ~S." fn))))) + +(define-setf-method char-bit (&environment env char name) + (multiple-value-bind (temps vals stores store-form access-form) + (get-setf-method char env) + (let ((ntemp (gensym)) + (store (gensym)) + (stemp (first stores))) + (values `(,ntemp ,@temps) + `(,name ,@vals) + (list store) + `(let ((,stemp (set-char-bit ,access-form ,ntemp ,store))) + ,store-form ,store) + `(char-bit ,access-form ,ntemp))))) + +(define-setf-method ldb (&environment env bytespec int) + (multiple-value-bind (temps vals stores store-form access-form) + (get-setf-method int env) + (let ((btemp (gensym)) + (store (gensym)) + (stemp (first stores))) + (values `(,btemp ,@temps) + `(,bytespec ,@vals) + (list store) + `(let ((,stemp (dpb ,store ,btemp ,access-form))) + ,store-form ,store) + `(ldb ,btemp ,access-form))))) + +(define-setf-method mask-field (&environment env bytespec int) + (multiple-value-bind (temps vals stores store-form access-form) + (get-setf-method int env) + (let ((btemp (gensym)) + (store (gensym)) + (stemp (first stores))) + (values `(,btemp ,@temps) + `(,bytespec ,@vals) + (list store) + `(let ((,stemp (deposit-field ,store ,btemp ,access-form))) + ,store-form ,store) + `(mask-field ,btemp ,access-form))))) + + +;;; The expansion function for SETF. +(defun setf-expand-1 (place newvalue env &aux g) + (when (and (consp place) (eq (car place) 'the)) + (return-from setf-expand-1 + (setf-expand-1 (caddr place) `(the ,(cadr place) ,newvalue) env))) + (when (and (consp place) (eq (car place) 'values)) + (do ((vl (cdr place) (cdr vl)) + (sym (gensym)) + (forms nil) + (n 0 (1+ n))) + ((endp vl) (return-from setf-expand-1 + `(let ((,sym (multiple-value-list ,newvalue))) + (values ,@(nreverse forms))))) + (declare (fixnum n) (object vl)) + (let ((method (if (symbolp (car vl)) 'setq 'setf))) + (push `(,method ,(car vl) (nth ,n ,sym)) forms)))) + (when (symbolp place) + (return-from setf-expand-1 `(setq ,place ,newvalue))) + (when (and (consp place) + (not (or (get (car place) 'setf-lambda) + (get (car place) 'setf-update-fn)))) + (multiple-value-setq (place g) (macroexpand place env)) + (if g (return-from setf-expand-1 (setf-expand-1 place newvalue env)))) + (when (and (symbolp (car place)) (setq g (get (car place) 'setf-update-fn))) + (return-from setf-expand-1 `(,g ,@(cdr place) ,newvalue))) + (cond ((and (symbolp (car place)) + (setq g (get (car place) 'structure-access))) + (return-from setf-expand-1 + (setf-structure-access (cadr place) (car g) (cdr g) newvalue)))) + + (multiple-value-bind (vars vals stores store-form access-form) + (get-setf-method place env) + (declare (ignore access-form)) + `(let* ,(mapcar #'list + (append vars stores) + (append vals (list newvalue))) + ,store-form))) + +(defun setf-structure-access (struct type index newvalue) + (case type + (list `(si:rplaca-nthcdr ,struct ,index ,newvalue)) + (vector `(si:elt-set ,struct ,index ,newvalue)) + (t `(si::structure-set ,struct ',type ,index ,newvalue)))) + +(defun setf-expand (l env) + (cond ((endp l) nil) + ((endp (cdr l)) (error "~S is an illegal SETF form." l)) + (t + (cons (setf-expand-1 (car l) (cadr l) env) + (setf-expand (cddr l) env))))) + + +;;; SETF macro. + +(defun setf-helper (rest env) + (setq rest (cdr rest)) + (cond ((endp rest) nil) + ((endp (cdr rest)) (error "~S is an illegal SETF form." rest)) + ((endp (cddr rest)) (setf-expand-1 (car rest) (cadr rest) env)) + (t (cons 'progn (setf-expand rest env))))) + +;(setf (macro-function 'setf) 'setf-help) +(si::fset 'setf (cons 'macro (symbol-function 'setf-helper))) + +;;; PSETF macro. + +(defmacro psetf (&environment env &rest rest) + (cond ((endp rest) nil) + ((endp (cdr rest)) (error "~S is an illegal PSETF form." rest)) + ((endp (cddr rest)) + `(progn ,(setf-expand-1 (car rest) (cadr rest) env) + nil)) + (t + (do ((r rest (cddr r)) + (pairs nil) + (store-forms nil)) + ((endp r) + `(let* ,pairs + ,@(nreverse store-forms) + nil)) + (when (endp (cdr r)) (error "~S is an illegal PSETF form." rest)) + (multiple-value-bind (vars vals stores store-form access-form) + (get-setf-method (car r) env) + (declare (ignore access-form)) + (setq store-forms (cons store-form store-forms)) + (setq pairs + (nconc pairs + (mapcar #'list + (append vars stores) + (append vals (list (cadr r))))))))))) + + +;;; SHIFTF macro. +(defmacro shiftf (&environment env &rest rest ) + (do ((r rest (cdr r)) + (pairs nil) + (stores nil) + (store-forms nil) + (g (gensym)) + (access-forms nil)) + ((endp (cdr r)) + (setq stores (nreverse stores)) + (setq store-forms (nreverse store-forms)) + (setq access-forms (nreverse access-forms)) + `(let* ,(nconc pairs + (list (list g (car access-forms))) + (mapcar #'list stores (cdr access-forms)) + (list (list (car (last stores)) (car r)))) + ,@store-forms + ,g)) + (multiple-value-bind (vars vals stores1 store-form access-form) + (get-setf-method (car r) env) + (setq pairs (nconc pairs (mapcar #'list vars vals))) + (setq stores (cons (car stores1) stores)) + (setq store-forms (cons store-form store-forms)) + (setq access-forms (cons access-form access-forms))))) + + +;;; ROTATEF macro. +(defmacro rotatef (&environment env &rest rest ) + (do ((r rest (cdr r)) + (pairs nil) + (stores nil) + (store-forms nil) + (access-forms nil)) + ((endp r) + (setq stores (nreverse stores)) + (setq store-forms (nreverse store-forms)) + (setq access-forms (nreverse access-forms)) + `(let* ,(nconc pairs + (mapcar #'list stores (cdr access-forms)) + (list (list (car (last stores)) (car access-forms)))) + ,@store-forms + nil + )) + (multiple-value-bind (vars vals stores1 store-form access-form) + (get-setf-method (car r) env) + (setq pairs (nconc pairs (mapcar #'list vars vals))) + (setq stores (cons (car stores1) stores)) + (setq store-forms (cons store-form store-forms)) + (setq access-forms (cons access-form access-forms))))) + + +;;; DEFINE-MODIFY-MACRO macro. +(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))))))) + `(defmacro ,name (&environment env reference . ,lambda-list) + ,@(if doc-string (list doc-string)) + (when (symbolp reference) + (return-from ,name + (let ((access-form reference)) + (list 'setq reference ,update-form)))) + (multiple-value-bind (vars vals stores store-form access-form) + (get-setf-method reference env) + (list 'let* + (mapcar #'list + (append vars stores) + (append vals (list ,update-form))) + store-form)))))))))))))))))))) + + +;;; Some macro definitions. + +(defmacro remf (&environment env place indicator) + (multiple-value-bind (vars vals stores store-form access-form) + (get-setf-method place env) + `(let* ,(mapcar #'list vars vals) + (multiple-value-bind (,(car stores) flag) + (si:rem-f ,access-form ,indicator) + ,store-form + flag)))) + +(define-modify-macro incf (&optional (delta 1)) +) +(define-modify-macro decf (&optional (delta 1)) -) + +(defmacro push (&environment env item place) + (let ((myitem (gensym))) + (when (symbolp place) + (return-from push `(let* ((,myitem ,item)) + (setq ,place (cons ,myitem ,place))))) + (multiple-value-bind (vars vals stores store-form access-form) + (get-setf-method place env) + `(let* ,(mapcar #'list + (append (list myitem) vars stores) + (append (list item) vals (list (list 'cons myitem access-form)))) + ,store-form)))) + +(defmacro pushnew (&environment env item place &rest rest) + (let ((myitem (gensym))) + (cond ((symbolp place) + (return-from pushnew `(let* ((,myitem ,item)) + (setq ,place (adjoin ,myitem ,place ,@rest)))))) + (multiple-value-bind (vars vals stores store-form access-form) + (get-setf-method place env) + `(let* ,(mapcar #'list + (append (list myitem) vars stores) + (append (list item) vals + (list (list* 'adjoin myitem access-form rest)))) + ,store-form)))) + +(defmacro pop (&environment env place) + (when (symbolp place) + (return-from pop + (let ((temp (gensym))) + `(let ((,temp (car ,place))) + (setq ,place (cdr ,place)) + ,temp)))) + (multiple-value-bind (vars vals stores store-form access-form) + (get-setf-method place env) + `(let* ,(mapcar #'list + (append vars stores) + (append vals (list (list 'cdr access-form)))) + (prog1 (car ,access-form) + ,store-form)))) diff --git a/lsp/gcl_sharp.lsp b/lsp/gcl_sharp.lsp new file mode 100644 index 0000000..7d9b077 --- /dev/null +++ b/lsp/gcl_sharp.lsp @@ -0,0 +1,64 @@ +(in-package :si) + +(defstruct + context + (vec (make-array 0 :adjustable t :fill-pointer t) :type (vector t)) + (hash nil :type (or null hash-table)) + (spice (make-hash-table :test 'eq :rehash-size 2.0) :type hash-table)) + +(defun get-context (i) + (declare (fixnum i)) + (when *sharp-eq-context* + (let ((v (context-vec *sharp-eq-context*))) + (if (< i (length v)) (aref v i) + (let ((h (context-hash *sharp-eq-context*))) + (when h (gethash1 i h))))))) + +(defun push-context (i) + (declare (fixnum i)) + (unless *sharp-eq-context* (setq *sharp-eq-context* (make-context))) + (let* ((v (context-vec *sharp-eq-context*))(l (length v))(x (cons nil nil))) + (cond ((< i l) (error "#~s= multiply defined" i)) + ((= i l) (vector-push-extend x v (1+ l)) x) + ((let ((h (context-hash *sharp-eq-context*))) + (if h (when (gethash1 i h) (error "#~s= multiply defined" i)) + (setf (context-hash *sharp-eq-context*) (setq h (make-hash-table :test 'eql :rehash-size 2.0)))) + (setf (gethash i h) x)))))) + +(defconstant +nil-proxy+ (cons nil nil)) + +(defun sharp-eq-reader (stream subchar i &aux (x (push-context i))) + (declare (ignore subchar)(fixnum i)) + (let ((y (read stream t 'eof t))) + (when (when y (eq y (cdr x))) (error "#= circularly defined")) + (setf (car x) (or y +nil-proxy+)) + y)) + +(defun sharp-sharp-reader (stream subchar i &aux (x (get-context i))) + (declare (ignore stream subchar)(fixnum i)) + (unless x (error "#~s# without preceding #~s=" i i)) + (or (cdr x) (let ((s (alloc-spice))) (setf (gethash s (context-spice *sharp-eq-context*)) x (cdr x) s)))) + +(defun patch-sharp (x) + (typecase + x + (cons (setf (car x) (patch-sharp (car x)) (cdr x) (patch-sharp (cdr x))) x) + ((vector t) + (dotimes (i (length x) x) + (setf (aref x i) (patch-sharp (aref x i))))) + ((array t) + (dotimes (i (array-total-size x) x) + (aset1 x i (patch-sharp (row-major-aref x i))))) + (structure + (let ((d (structure-def x))) + (dotimes (i (structure-length x) x) + (declare (fixnum i)) + (structure-set x d i (patch-sharp (structure-ref x d i)))))) + (spice (let* ((y (gethash1 x (context-spice *sharp-eq-context*))) + (z (car y))) + (unless y (error "Spice ~s not defined" x)) + (unless (eq z +nil-proxy+) z))) + (otherwise x))) + +(set-dispatch-macro-character #\# #\= #'sharp-eq-reader) +(set-dispatch-macro-character #\# #\# #'sharp-sharp-reader) diff --git a/lsp/gcl_sloop.lsp b/lsp/gcl_sloop.lsp new file mode 100755 index 0000000..6bfce2f --- /dev/null +++ b/lsp/gcl_sloop.lsp @@ -0,0 +1,1230 @@ +;;; -*- Mode:LISP; Package:(SLOOP LISP);Syntax:COMMON-LISP;Base:10 -*- ;;;;; +;;; ;;;;; +;;; Copyright (c) 1985,86 by William Schelter, ;;;;; +;;; All rights reserved ;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;;; Report bugs to wfs@carl.ma.utexas.edu +;;; It comes with ABSOLUTELY NO WARRANTY but we hope it is useful. + + +;;; The following code is meant to run in COMMON LISP and to provide +;;; extensive iteration facilities, with very high backwards compatibility +;;; with the traditional loop macro. It is meant to be publicly available! +;;; Anyone is hereby given permission to copy it provided he does not make +;;; ANY changes to the file unless he is William Schelter. He may change +;;; the behavior after loading it by resetting the global variables such +;;; as like *Use-locatives*, *automatic-declarations*,.. listed at the +;;; beginning of this file. + +;;; The original of this file is on +;;; rascal.ics.utexas.edu:/usr2/ftp/pub/sloop.lisp. I am happy to accept +;;; suggestions for different defaults for various implementations, or for +;;; improvements. + + +;;If you want to redefine the common lisp loop you may include in your code: +;;; (defmacro loop (&body body) (parse-loop body)) + +;; Principal New Features + +;;; Sloop is extremely user extensible so that you may easily redefine +;;; most behavior, or add additional collections, and paths. There are a +;;; number of such examples defined in this file, including such +;;; constructs as + +;;; .. FOR v IN-FRINGE x .. (iterate through the fringe of a tree x) +;;; .. SUM v .. (add the v) +;;; .. AVERAGING v .. +;;; .. FOR sym IN-PACKAGE y (iterate through symbols in a package y) +;;; .. COLLATE v .. (for collecting X into an ordered list), +;;; .. FOR (elt i) IN-ARRAY ar (iterate through array ar, with index i) +;;; .. FOR (key elt) IN-TABLE foo.. (if foo is a hash table) + +;;; you can combine any collection method with any path. +;;; Also there is iteration over products so that you may write +;;; (SLOOP FOR i BELOW k +;;; SLOOP (FOR j BELOW i +;;; COLLECTING (foo i j))) + +;;; Declare is fully supported. The syntax would be +;;; (sloop for u in l with v = 0 +;;; declare (fixnum u v) +;;; do .... + +;;; This extensibility is gained by the ability to define a "loop-macro", +;;; which plays a role analagous to an ordiary lisp macro. See eg. +;;; definitions near that of "averaging". Essentially a "loop-macro" +;;; takes some arguments (supplied from the body of the loop following its +;;; occurrence, and returns a new form to be stuffed onto the front of the +;;; loop form, in place of it and its arguments). + +;;; Compile notes: For dec-20 clisp load the lisp file before compiling. + + +;;; there seems to be no unanimity about what in-package etc. does on +;;; loading and compiling a file. The following is as close to the +;;; examples in the Common Lisp manual, as we could make it. The user +;;; should put (require "SLOOP") and then (use-package "SLOOP") early in +;;; his init file. Note use of the string to avoid interning 'sloop in +;;; some other package. + + +(in-package "SLOOP" :use '(LISP)) +(eval-when (compile eval load) + +(export '(loop-return sloop def-loop-collect def-loop-map + def-loop-for def-loop-macro local-finish + sloop-finish) (find-package "SLOOP")) + +) + +;;; some variables that may be changed to suit different implementations: + +(eval-when (compile load eval) + +(defvar *use-locatives* nil "See sloop.lisp") ;#+lispm t #-lispm nil +;;; If t should have locf, such that if we do +;;; (setf b nil) (setq a (locf b)) +;;; then the command +;;; (setf (cdr a) (cons 3 nil)) means that b==>(3). +;;; This is useful for building lists starting with a variable pointing to +;;; nil, since otherwise we must check each time if the list has really +;;; been started, before we do a (setf (cdr b) ..) + +(defvar *Automatic-declarations* #+lispm nil #-lispm + '(:from fixnum) "See sloop.lisp") + +;;; some other reasonable ones would be :count fixnum :max fixnum +;;; Automatic declarations for variables in the stepping and collecting, +;;; so for i below n, gives i and n a :from declaration (here fixnum) + + +;;valid keys in *automatic-declarations* +(defvar *auto-type* '(:from :in :collect)) +;;give automatic register declaration to these variables +(defvar *auto-register* '(:from :in :collect)) +(eval-when (compile eval load) +(proclaim '(declaration :register)) +) + + +(defvar *type-check* t "If t adds a type check on bounds of from loop +if there is and automatic declare") + +(defvar *macroexpand-hook-for-no-copy* #-(or lmi ti) 'funcall #+(or lmi ti) t) +;;; some lisps remember a macro so that (loop-return) will expand eq forms +;;; always in the same manner, even if the form is in a macrolet! To +;;; defeat this feature we copy all macro expansions unless +;;; *macro-expand-hook* = *macroexpand-hook-for-no-copy* +) + + +;;; *****ONLY CONDITIONALIZATIONS BELOW HERE SHOULD BE FOR BUG FIXES****** +;;; eg. some kcls don't return nil from a prog by default! + +;;; all macros here in here. +(eval-when (compile eval load) + +(defparameter *sloop-translations* '((appending . append) + ((collecting collect) . collect) + ((maximizing maximize) . maximize) + ((minimizing minimize) . minimize) + (nconcing . nconc) + ((count counting) . count) + (summing . sum) + (if . when) + (as . for) + (in-fringe . in-fringe) + (collate . collate) + (in-table . in-table) + (in-carefully . in-carefully) + (averaging . averaging) + (repeat . repeat) + (first-use . first-use) + (in-array . in-array)) + "A list of cons's where the translation is the cdr, and the car +is a list of names or name to be translated. Essentially allows 'globalizing' +a symbol for the purposes of being a keyword in a sloop") + + +(defparameter *additional-collections* nil) + +(defmacro lcase (item &body body) + (let (bod last-case tem) + (do ((rest body (cdr rest)) (v)) + ((or last-case (null rest))) + (setq v (car rest)) + (push + (cond ((eql (car v) t) (setq last-case t) v) + ((eql (car v) :collect) + `((loop-collect-keyword-p .item.) ,@ (cdr v))) + ((eql (car v) :no-body) + `((parse-no-body .item.) ,@ (cdr v))) + ((setq tem + (member (car v) '(sloop-macro sloop-for sloop-map))) + `((and (symbolp .item.)(get .item. ',(car tem))) ,@ (cdr v))) + (t + `((l-equal .item. ',(car v)) ,@ (cdr v)))) + bod)) + (or last-case (push `(t (error "lcase fell off end ~a " .item.)) bod)) + `(let ((.item. (translate-name ,item))) + (cond ,@ (nreverse bod))))) + +(defun desetq1 (form val) + (cond ((symbolp form) + (and form `(setf ,form ,val))) + ((consp form) + `(progn ,(desetq1 (car form) `(car ,val)) + ,@ (if (consp (cdr form)) + (list(desetq1 (cdr form) `(cdr ,val))) + (and (cdr form) `((setf ,(cdr form) (cdr ,val))))))) + (t (error "")))) + +(defmacro desetq (form val) + (cond ((atom val) (desetq1 form val)) + (t (let ((value (gensym))) + `(let ((,value ,val)) , (desetq1 form value)))))) + +(defmacro loop-return (&rest vals) + (cond ((<= (length vals) 1) + `(return ,@ vals)) + (t`(return (values ,@ vals))))) + +(defmacro sloop-finish () + `(go finish-loop)) + +(defmacro local-finish () + `(go finish-loop)) + +(defmacro sloop (&body body) + (parse-loop body)) + +(defmacro def-loop-map (name args &body body) + (def-loop-internal name args body 'map)) +(defmacro def-loop-for (name args &body body ) + (def-loop-internal name args body 'for nil 1)) +(defmacro def-loop-macro (name args &body body) + (def-loop-internal name args body 'macro)) +(defmacro def-loop-collect (name arglist &body body ) + "Define function of 2 args arglist= (collect-var value-to-collect)" + (def-loop-internal name arglist body 'collect '*additional-collections* 2 2)) + +(defmacro sloop-swap () + `(progn (rotatef a *loop-bindings*) + (rotatef b *loop-prologue*) + (rotatef c *loop-epilogue*) + (rotatef e *loop-end-test*) + (rotatef f *loop-increment*) + (setf *inner-sloop* (not *inner-sloop*)) + )) + +) ;;end of macros + +(defun l-equal (a b) + (and (symbolp a) + (cond ((symbolp b) + (equal (symbol-name a) (symbol-name b))) + ((listp b) + (member a b :test 'l-equal))))) + +(defun loop-collect-keyword-p (command) + (or (member command '(collect append nconc sum count) :test 'l-equal) + (find command *additional-collections* :test 'l-equal))) + +(defun translate-name (name) + (cond ((and (symbolp name) + (cdar (member name *sloop-translations* + :test 'l-equal :key 'car)))) + (t name))) + +(defun loop-pop () + (declare (special *last-val* *loop-form*)) + (cond (*loop-form* + (setq *last-val* (pop *loop-form*))) + (t (setq *last-val* 'empty-form) nil))) + +(defun loop-un-pop () (declare (special *last-val* *loop-form*)) + (case *last-val* + (empty-form nil) + (already-un-popped (error "you are un-popping without popping")) + (t (push *last-val* *loop-form*) + (setf *last-val* 'alread-un-popped)))) + +(defun loop-peek () (declare (special *last-val* *loop-form*)) + (car *loop-form*)) + +(defun loop-let-bindings(binds) + (do ((v (car binds) (cdr v))) + ((null v) (nreverse (car binds))) + (or (cdar v) (setf (car v) (caar v))))) + +(defun parse-loop (form &aux inner-body) + (let ((*loop-form* form) + (*Automatic-declarations* *Automatic-declarations*) + *last-val* *loop-map* + *loop-body* + *loop-name* + *loop-prologue* *inner-sloop* + *loop-epilogue* *loop-increment* + *loop-collect-pointers* *loop-map-declares* + *loop-collect-var* *no-declare* + *loop-end-test* + *loop-bindings* + *product-for* + *type-test-limit* + local-macros + (finish-loop 'finish-loop) + ) + (declare (special *loop-form* *last-val* *loop-map* + *loop-collect-pointers* + *loop-name* *inner-sloop* + *loop-body* + *loop-prologue* + *no-declare* + *loop-bindings* + *loop-collect-var* *loop-map-declares* + *loop-epilogue* *loop-increment* + *loop-end-test* *product-for* + *type-test-limit* + )) + (unless (and (symbolp (car *loop-form*)) (car *loop-form*)) + (push 'do *loop-form*)) ;compatible with common lisp loop.. + (parse-loop1) + (when (or *loop-map* *product-for*) + (or *loop-name* (setf *loop-name* (gensym "SLOOP"))) + (and (eql 'finish-loop finish-loop) + (setf finish-loop (gensym "FINISH")))) +;;; some one might use local-finish,local-return or sloop-finish, so they might +;;; be bound at an outer level. WE have to always include this since +;;; loop-return may be being bound outside. + (and ; *loop-name* + (push + `(loop-return (&rest vals) + `(return-from ,',*loop-name* (values ,@ vals))) + local-macros)) + (when t;; (or (> *loop-level* 1) (not (eql finish-loop 'finish-loop))) + (push `(sloop-finish () `(go ,',finish-loop)) local-macros) + (push `(local-finish () `(go ,',finish-loop)) local-macros)) + (and *loop-collect-var* + (push `(return-from ,*loop-name* , *loop-collect-var*) + *loop-epilogue*)) + (setq inner-body (append *loop-end-test* + (nreverse *loop-body*) + (nreverse *loop-increment*))) + (cond (*loop-map* + (setq inner-body (substitute-sloop-body inner-body))) + (t (setf inner-body (cons 'next-loop + (append inner-body '((go next-loop))))))) + (let ((bod + `(macrolet ,local-macros + (block ,*loop-name* + (tagbody + ,@ (append + (nreverse *loop-prologue*) + inner-body + `(,finish-loop) + (nreverse *loop-epilogue*) + #+kcl '((loop-return nil)))))) + + )) +;;; temp-fix..should not be necessary but some lisps cache macro +;;; expansions. and ignore the macrolet!! + (unless (eql *macroexpand-hook* *macroexpand-hook-for-no-copy*) + (setf bod (copy-tree bod))) + (dolist (v *loop-bindings*) + (setf bod + `(let ,(loop-let-bindings v) + ,@(and (cdr v) `(,(cons 'declare (cdr v)))) + ,bod))) + bod + ))) + +(defun parse-loop1 () + (declare (special *loop-form* + *loop-body* *loop-increment* + *no-declare* *loop-end-test* + *loop-name* )) + (lcase (loop-peek) + (named (loop-pop) (setq *loop-name* (loop-pop))) + (t nil)) + (do ((v (loop-pop) (loop-pop))) + ((and (null v) (null *loop-form*))) + (lcase v + (:no-body) + (for (parse-loop-for)) + (while (push + `(or ,(loop-pop) (local-finish)) *loop-body*)) + (until (push + `(and ,(loop-pop) (local-finish)) *loop-body*)) + (do (setq *loop-body* (append (parse-loop-do) *loop-body*))) + ((when unless) (setq *loop-body* + (append (parse-loop-when) *loop-body*))) + (:collect (setq *loop-body* + (append (parse-loop-collect) *loop-body*))) + ))) + + +(defun parse-no-body (com &aux (found t) (first t)) + "Reads successive no-body-contribution type forms, like declare, +initially, etc. which can occur anywhere. Returns t if it finds some +otherwise nil" + (declare (special *loop-form* + *loop-body* + *loop-increment* + *no-declare* *loop-end-test* + *loop-name* )) + (do ((v com (loop-pop))) + ((null (or first *loop-form*))) + (lcase v + ((initially finally)(parse-loop-initially v)) + (nil nil) + (with (parse-loop-with)) + (declare (parse-loop-declare (loop-pop) t)) + (nodeclare (setq *no-declare* (loop-pop))) + ;take argument to be consistent. + (increment (setq *loop-increment* + (append (parse-loop-do) *loop-increment*))) + (end-test (setq *loop-end-test* + (append (parse-loop-do) *loop-end-test*))) + (with-unique (parse-loop-with nil t)) + (sloop-macro (parse-loop-macro v 'sloop-macro)) + (t + (cond (first + (setf found nil)) + (t (loop-un-pop))) + (return 'done))) + (setf first nil)) + found) + +(defun parse-loop-with (&optional and-with only-if-not-there) + (let ((var (loop-pop))) + (lcase (loop-peek) + (= (loop-pop) + (or (symbolp var) (error "Not a variable ~a" var)) + (loop-add-binding var (loop-pop) + (not and-with) nil nil t only-if-not-there)) + (t (loop-add-temps var nil nil (not and-with) only-if-not-there))) + (lcase (loop-peek) + (and (loop-pop) + (lcase (loop-pop) + (with (parse-loop-with t )) + (with-unique (parse-loop-with t t)) + (t (loop-un-pop) (parse-loop-with t)) + )) + (t nil)))) + +(defun parse-loop-do (&aux result) + (declare (special *loop-form*)) + (do ((v (loop-pop) (loop-pop)) ) + (()) + (cond + ((listp v) + (push v result) + (or *loop-form* (return 'done))) + (t (loop-un-pop) (return 'done)))) + (or result (error "empty clause")) + result) + +(defun parse-loop-initially (command ) + (declare (special *loop-prologue* *loop-epilogue* *loop-bindings*)) + (lcase + command + (initially + (let ((form (parse-loop-do))) + (dolist (v (nreverse form)) + (cond ((and (listp v) + (member (car v) '(setf setq)) + (eql (length v) 3) + (symbolp (second v)) + (constantp (third v)) + (assoc (second v) (caar *loop-bindings*)) + (loop-add-binding (second v) (third v) + nil nil nil t t) + )) + (t (setf *loop-prologue* + (cons v *loop-prologue*))))))) + (finally + (setf *loop-epilogue* (append (parse-loop-do) *loop-epilogue*))))) + +(defun parse-one-when-clause ( &aux this-case (want 'body) v) + (declare (special *loop-form*)) + (prog + nil + next-loop + (and (null *loop-form*) (return 'done)) + (setq v (loop-pop)) + (lcase v + (:no-body) + (:collect (or (eql 'body want) (go finish)) + (setq this-case (append (parse-loop-collect) this-case)) + (setq want 'and)) + (when (or (eql 'body want) (go finish)) + (setq this-case (append (parse-loop-when) this-case)) + (setq want 'and)) + (do (or (eql 'body want) (go finish)) + (setq this-case (append (parse-loop-do) this-case)) + (setq want 'and)) + (and (or (eql 'and want) (error "Premature AND")) + (setq want 'body)) + (t (loop-un-pop)(return 'done))) + (go next-loop) + finish + (loop-un-pop)) + (or this-case (error "Hanging conditional")) + this-case) + + +(defun parse-loop-when (&aux initial else else-clause) + (declare (special *last-val* )) + (let ((test (cond ((l-equal *last-val* 'unless) `(not , (loop-pop))) + (t (loop-pop))))) + (setq initial (parse-one-when-clause)) + (lcase (loop-peek) + (else + (loop-pop) + (setq else t) + (setq else-clause (parse-one-when-clause))) + (t nil)) + `((cond (,test ,@ (nreverse initial)) + ,@ (and else `((t ,@ (nreverse else-clause)))))))) + +(defun pointer-for-collect (collect-var) + (declare (special *loop-collect-pointers*)) + (or (cdr (assoc collect-var *loop-collect-pointers*)) + (let ((sym(loop-add-binding (gensym "POIN") nil nil :collect ))) + (push (cons collect-var sym) + *loop-collect-pointers*) + sym))) + +(defun parse-loop-collect ( &aux collect-var pointer name-val) + (declare (special *last-val* *loop-body* *loop-collect-var* + *loop-collect-pointers* *inner-sloop* + *loop-prologue* )) + (and *inner-sloop* (throw 'collect nil)) + (let ((command *last-val*) + (val (loop-pop))) + (lcase + (loop-pop) + (into (loop-add-binding (setq collect-var (loop-pop)) nil nil t nil t )) + (t (loop-un-pop) + (cond (*loop-collect-var* (setf collect-var *loop-collect-var*)) + (t (setf collect-var + (setf *loop-collect-var* + (loop-add-binding (gensym "COLL") nil ))))))) + (lcase command + ((append nconc collect) + (setf pointer (pointer-for-collect collect-var)) + (cond (*use-locatives* + (pushnew `(setf ,pointer + (locf ,collect-var)) + *loop-prologue* :test 'equal))) + (lcase command + ( append + (unless (and (listp val) (eql (car val) 'list)) + (setf val `(copy-list ,val)))) + (t nil))) + (t nil)) + (cond ((and (listp val) (not *use-locatives*)) + (setq name-val (loop-add-binding (gensym "VAL") nil nil))) + (t (setf name-val val))) + (let + ((result + (lcase + command + ((nconc append) + (let ((set-pointer + `(and (setf (cdr ,pointer) ,name-val) + (setf ,pointer (last (cdr ,pointer)))))) + (cond (*use-locatives* + (list set-pointer)) + (t + `((cond (,pointer ,set-pointer) + (t (setf ,pointer + (last (setf + ,collect-var + ,name-val)))))))))) + (collect + (cond (*use-locatives* + `((setf (cdr ,pointer) + (setf ,pointer (cons ,name-val nil))))) + (t `((cond (,pointer + (setf (cdr ,pointer) + (setf ,pointer (cons ,name-val nil)))) + (t (setf ,collect-var + (setf ,pointer + (cons ,name-val nil))))))))) + (t (setq command (translate-name command)) + (cond ((find command *additional-collections* :test 'l-equal) + (loop-parse-additional-collections + command collect-var name-val)) + (t (error "loop fell off end ~a" command))))))) + (cond ((eql name-val val) + result) + (t (nconc result `((setf ,name-val ,val) ))))))) + +(defun loop-parse-additional-collections + (command collect-var name-val &aux eachtime) + (declare (special *loop-prologue* *last-val* + *loop-collect-var* *loop-epilogue* )) + (let* ((com (find command *additional-collections* :test 'l-equal)) + (helper (get com 'sloop-collect))) + (let ((form (funcall helper collect-var name-val))) + (let ((*loop-form* form) *last-val*) + (declare (special *loop-form* *last-val*)) + (do ((v (loop-pop) (loop-pop))) + ((null *loop-form*)) + (lcase v + (:no-body) + (do (setq eachtime (parse-loop-do))))) + eachtime)))) + +(defun the-type (symbol type) + (declare (special *no-declare*)) + (and *no-declare* (setf type nil)) + (and type (setf type (or (getf *Automatic-declarations* type) + (and (not (keywordp type)) type)))) + (and (consp type) (eq (car type) 'type) (setf type (second type))) + (cond (type (list 'the type symbol )) + (t symbol))) + +(defun type-error () + (error "While checking a bound of a sloop, I found the wrong type +for something in sloop::*automatic-declarations*. + Perhaps your limit is wrong? +If not either use nodeclare t or set sloop::*automatic-declarations* to nil. +recompile.")) + + +;;; this puts down code to check that automatic declarations induced by +;;; :from are indeed valid! It checks both ends of the interval, and so +;;; need not check the numbers in between. + +(defun make-value (value type-key &aux type ) + (declare (special *no-declare* *type-test-limit*)) + (cond ((and + (not *no-declare*) + *type-check* + (eq type-key :from) + (setq type (getf *Automatic-declarations* type-key))) + (setq type + (cond ((and (consp type) + (eq (car type) 'type)) + (second type)) + (t type))) + (cond ((constantp value) + (let ((test-value + (cond (*type-test-limit* + (eval (subst value + 'the-value *type-test-limit*))) + (t (eval value))))) + (or (typep test-value type) + (error + "~&Sloop found the type of ~a was not type ~a,~%~ + Maybe you want to insert SLOOP NODECLARE T ..." + value + type)) + (list value))) + (t (let (chk) + `((let ,(cond ((atom value) + nil) + (t `((,(setq chk(gensym)) ,value)))) + (or + (typep + ,(if *type-test-limit* + (subst (or chk value) + 'the-value *type-test-limit*) + (or chk value)) + ',type) + (type-error)) + ,(or chk value))))))) + (t (list value)))) + + +;;; keep track of the bindings in a list *loop-bindings* each element of +;;; the list will give rise to a different let. the car will be the +;;; variable bindings, the cdr the declarations. + + +(defun loop-add-binding + (variable value &optional (new-level t) type force-type (force-new-value t) + only-if-not-there &aux tem) +;;; Add a variable binding to the current or new level. If FORCE-TYPE, +;;; ignore a *no-declare*. If ONLY-IF-NOT-THERE, check all levels. + (declare (special *loop-bindings*)) + (when (or new-level (null *loop-bindings*)) + (push (cons nil nil) *loop-bindings*)) + (cond ((setq tem (assoc variable (caar *loop-bindings*) )) + (and force-new-value + (setf (cdr tem) (and value (make-value value type))))) + ((and (or only-if-not-there (and (null (symbol-package variable)) + (constantp value))) + (dolist (v (cdr *loop-bindings*)) + (cond ((setq tem (assoc variable (car v))) + (and force-new-value + (setf (cdr tem) + (and value (make-value value type)))) + (return t)))))) + (t (push (cons variable (and value (make-value value type))) + (caar *loop-bindings*)))) + (and type (loop-declare-binding variable type force-type)) + variable) + +;(defmacro nth-level (n) `(nth ,n *loop-bindings*)) +;if x = (nth i *loop-bindings*) +;(defmacro binding-declares (x) `(cdr ,x)) ;(cons 'declare (binding-declares x)) to get honest declare statement +;(defmacro binding-values (x) `(car ,x)) ;(let (binding-values x) ) to get let. + +(defun loop-declare-binding (var type force-type &optional odd-type + &aux found ) + (declare (special *loop-bindings* *automatic-declarations* + *no-declare* *loop-map*)) + odd-type ;;ignored + (and type + (member type *auto-type*) + (setf type (getf *automatic-declarations* type)) + *auto-register* + (loop-declare-binding var :register force-type)) + (when (and type(or force-type (null *no-declare*))) + (dolist (v *loop-bindings*) + (cond ((assoc var (car v)) (setf found t) + (pushnew + (if (and (consp type) + (eq (car type) 'type)) + (list 'type (second type) var) + (if odd-type (list 'type type var) + + (list type var))) + (cdr v) :test 'equal) + (return 'done) + ))) + (or found *loop-map* (error "Could not find variable ~a in bindings" var))) + var) + +(defun parse-loop-declare (&optional (decl-list (loop-pop)) (force t)) + (let ((type (car decl-list)) odd-type) + (cond ((eq type 'type) + (setf decl-list (cdr decl-list) type (car decl-list) odd-type t))) + (dolist (v (cdr decl-list)) + (loop-declare-binding v (car decl-list) force odd-type)))) + +(defun loop-add-temps (form &optional val type new-level only-if-not-there) + (cond ((null form)) + ((symbolp form) + (loop-add-binding form val new-level type nil t only-if-not-there)) + ((listp form) + (loop-add-temps (car form)) + (loop-add-temps (cdr form))))) + + +(defun add-from-data (data &rest args) + "rest = var begin end incr direction or-eql" + (or data (setq data (copy-list '(nil 0 nil 1 + nil)))) + (do ((l data (cdr l)) + (v args (cdr v))) + ((null v) l) + (and (car v) (setf (car l) (car v)))) + data) + +(defun parse-loop-for ( &aux inc from-data) + (declare (special *loop-form* *loop-map-declares* *loop-map* + *loop-body* *loop-increment* *no-declare* + *loop-prologue* + *loop-epilogue* + *loop-end-test* + *loop-bindings* + )) + (let* ((var (loop-pop)) test incr) + (do ((v (loop-pop) (loop-pop))) + (()) + (lcase v + (in (let ((lis (gensym "LIS"))) + (loop-add-temps var nil :in t) + (loop-add-binding lis (loop-pop) nil) + (push `(desetq ,var (car ,lis)) *loop-body*) + (setf incr `(setf ,lis (cdr ,lis))) + (setq test `(null ,lis) ) + )) + (on (let ((lis + (cond ((symbolp var) var) + (t (gensym "LIS"))))) + (loop-add-temps var nil :in t) + (loop-add-binding lis (loop-pop) nil) + (setf incr `(setf ,lis (cdr ,lis))) + (unless (eql lis var) + (push `(desetq ,var ,lis) *loop-body*)) + (setf test `(null ,lis)))) + + ((upfrom from) + (setq from-data (add-from-data from-data + var (loop-pop) nil nil '+))) + (downfrom + (setq from-data (add-from-data + from-data var (loop-pop) nil nil '-))) + (by + (setq inc (loop-pop)) + (cond (from-data + (setq from-data (add-from-data + from-data nil nil nil inc))) + (t (assert (eq (car (third incr)) 'cdr)) + (setq incr + `(setf ,(second incr) + ,(if (and (consp inc) + (member (car inc) '(quote function))) + `(,(second inc) ,(second incr)) + `(funcall + ,inc ,(second incr)))))))) + (below + (setq from-data (add-from-data from-data + var nil (loop-pop) nil '+))) + (above + (setq from-data (add-from-data from-data + var nil (loop-pop) nil '-))) + (to + (setq from-data (add-from-data from-data + var nil (loop-pop) nil nil t))) + (sloop-for (parse-loop-macro (translate-name v) + 'sloop-for var ) + (return 'done)) + (sloop-map (parse-loop-map (translate-name v) var ) + (return nil)) + (t(or + (loop-un-pop)) + (return 'done)))) + + ;;whew finished parsing a for clause.. + + (cond (from-data + (let + ((op (nth 4 from-data)) + (or-eql (nth 5 from-data)) + (var (car from-data)) + (end (third from-data)) + (inc (fourth from-data)) + type) + (loop-add-binding var (second from-data) t :from) + (or (constantp inc) (setq *no-declare* t)) + (setf incr `(setf ,var ,(the-type `(,op ,var ,inc) :from))) + (cond (end + (let ((lim (gensym "LIM")) + (*type-test-limit* + (cond ((and (eql inc 1) + (null (nth 5 from-data))) + nil) + (t `(,op + the-value , inc))))) + (declare (special *type-test-limit*)) + (loop-add-binding lim end nil :from nil nil) + (setq test `(,(cond (or-eql + (if (eq op '+) '> '<)) + (t (if (eq op '+) '>= '<=))) + ,var ,lim)))) + ((and (not *no-declare*) + *type-check* + (setq type (getf *automatic-declarations* :from)) + (progn (if (and (consp type)(eq (car type) 'type)) + (setf type (second type))) + (subtypep type 'fixnum))) + (or (constantp inc) (error "increment must be constant.")) + (push + `(or + ,(cond ((eq op '+) + `(< ,var ,(- most-positive-fixnum + (or inc 1)))) + (t `(> ,var ,(+ most-negative-fixnum + (or inc 1))))) + (type-error)) + *loop-increment*) + ))))) + + (and test (push (copy-tree `(and ,test (local-finish))) *loop-end-test*)) + (and incr (push incr *loop-increment*)) + )) + + +(defun parse-loop-macro (v type &optional initial &aux result) + (declare (special *loop-form*)) + (let ((helper (get v type)) args) + (setq args + (ecase type + (sloop-for + (let ((tem (get v 'sloop-for-args))) + (or (cdr tem) (error "sloop-for macro needs at least one arg")) + (cdr tem))) + (sloop-macro(get v 'sloop-macro-args)))) + (let ((last-helper-apply-arg + (cond ((member '&rest args) + (prog1 *loop-form* (setf *loop-form* nil))) + (t (dotimes (i (length args) (nreverse result)) + (push (car *loop-form*) result) + (setf *loop-form* (cdr *loop-form*))))))) + (setq *loop-form* + (append + (case type + (sloop-for (apply helper initial last-helper-apply-arg)) + (sloop-macro(apply helper last-helper-apply-arg))) + *loop-form*))))) + +(defun parse-loop-map (v var) + (declare (special *loop-map* *loop-map-declares* *loop-form*)) + (and *loop-map* (error "Sorry only one allowed loop-map per sloop")) + (let ((helper (get v 'sloop-map)) + (args (get v 'sloop-map-args))) + (or args (error "map needs one arg before the key word")) + (cond ((member '&rest args) + (error "Build this in two steps if you want &rest"))) + (let* (result + (last-helper-apply-arg + (dotimes (i (1- (length args)) (nreverse result)) + (push (car *loop-form*) result) + (setf *loop-form* (cdr *loop-form*))))) + (setq *loop-map-declares* + (do ((v (loop-pop)(loop-pop)) (result)) + ((null (l-equal v 'declare)) + (loop-un-pop) + (and result (cons 'declare result))) + (push (loop-pop) result))) + (setq *loop-map* (apply helper var last-helper-apply-arg)) + nil))) + +(defun substitute-sloop-body (inner-body) + (declare (special *loop-map* *loop-map-declares*)) + (cond (*loop-map* + (setf inner-body (list (subst (cons 'progn inner-body) + :sloop-body *loop-map*))) + (and *loop-map-declares* + (setf inner-body(subst *loop-map-declares* + :sloop-map-declares inner-body))))) + inner-body) + +;;; **User Extensible Iteration Facility** + +(eval-when (compile eval load) +(defun def-loop-internal (name args body type + &optional list min-args max-args + &aux (*print-case* :upcase) + (helper (intern + (format nil "~a-SLOOP-~a" name type)))) + (and min-args (or (>= (length args) min-args)(error "need more args"))) + (and max-args (or (<= (length args) max-args)(error "need less args"))) + `(eval-when (load compile eval) + (defun ,helper ,args + ,@ body) + ,@ (and list `((pushnew ',name ,list))) + (setf (get ',name ',(intern (format nil "SLOOP-~a" type) + (find-package 'sloop))) ',helper) + (setf (get ',name ',(intern (format nil "SLOOP-~a-ARGS" type) + (find-package 'sloop))) ',args))) +) + + +;;; DEF-LOOP-COLLECT lets you get a handle on the collection var. exactly +;;; two args. First arg=collection-variable. Second arg=value this time +;;; thru the loop. + +(def-loop-collect sum (ans val) + `(initially (setq ,ans 0) + do (setq ,ans (+ ,ans ,val)))) +(def-loop-collect logxor (ans val) + `(initially (setf ,ans 0) + do (setf ,ans (logxor ,ans ,val)) + declare (fixnum ,ans ,val))) +(def-loop-collect maximize (ans val) + `(initially (setq ,ans nil) + do (if ,ans (setf ,ans (max ,ans ,val)) (setf ,ans ,val)))) + +(def-loop-collect minimize (ans val) + `(initially (setq ,ans nil) + do (if ,ans (setf ,ans (min ,ans ,val)) (setf ,ans ,val)))) + +(def-loop-collect count (ans val) + `(initially (setq ,ans 0) + do (and ,val (setf ,ans (1+ ,ans))))) + +(def-loop-collect thereis (ans val)(declare(ignore ans)) + `(do (if ,val (loop-return ,val)))) +(def-loop-collect always (ans val) + `(initially (setq ,ans t) do (and (null ,val)(loop-return nil)))) +(def-loop-collect never (ans val) + `(initially (setq ,ans t) do (and ,val (loop-return nil)))) + + +;;; DEF-LOOP-MACRO +;;; If we have done +;;; (def-loop-macro averaging (x) +;;; `(sum ,x into .tot. and count t into .how-many. +;;; finally (loop-return (/ .tot. (float .how-many.))))) + +;;; (def-loop-collect average (ans val) +;;; `(initially (setf ,ans 0.0) +;;; with-unique .how-many. = 0 +;;; do (setf ,ans (/ (+ (* .how-many. ,ans) ,val) (incf .how-many.))) +;;; )) + +;;; Finally we show how to provide averaging with +;;; current value the acutal average. + +(def-loop-macro averaging (x) + `(with-unique .average. = 0.0 + and with-unique .n-to-average. = 0 + declare (float .average. ) declare (fixnum .n-to-average.) + do (setf .average. (/ + (+ (* .n-to-average. .average.) ,x) + (incf .n-to-average.))) + finally (loop-return .average.))) + +(def-loop-macro repeat (x) + (let ((ind (gensym))) + `(for ,ind below ,x))) + +(def-loop-macro return (x) + `(do (loop-return ,@ (if (and (consp x) (eq (car x) 'values)) + (cdr x) + (list x))))) + +;;; then we can write: +;;; (sloop for x in l when (oddp x) averaging x) + + +;;; DEF-LOOP-FOR def-loop-for and def-loop-macro are almost identical +;;; except that the def-loop-for construct can only occur after a for: + +;;; (def-loop-for in-array (vars array) +;;; (let ((elt (car vars)) +;;; (ind (second vars))) +;;; `(for ,ind below (length ,array) do (setf ,elt (aref ,array ,ind))))) + +;;; (sloop for (elt ind) in-array ar when (oddp elt) collecting ind) + +;;; You are just building something understandable by loop but minus the +;;; for. Since this is almost like a "macro", and users may want to +;;; customize their own, the comparsion of tokens uses eq, ie. you must +;;; import IN-ARRAY to your package if you define it in another one. +;;; Actually we make a fancier in-array below which understands from, to, +;;; below, downfrom,.. and can have either (elt ind) or elt as the +;;; argument vars. + +;;; DEF-LOOP-MAP A rather general iteration construct which allows you to +;;; map over things It can only occur after FOR. There can only be one +;;; loop-map for a given loop, so you want to only use them for +;;; complicated iterations. + +(def-loop-map in-table (var table) + `(maphash #'(lambda ,var :sloop-map-declares :sloop-body) ,table)) + +;;; Usage (sloop for (key elt) in-table table +;;; declare (fixnum elt) +;;; when (oddp elt) collecting (cons key elt)) + + +(def-loop-map in-package (var pkg) + `(do-symbols (,var (find-package ,pkg)) :sloop-body)) + +;;; Usage: +;;; (defun te() +;;; (sloop for sym in-package 'sloop when (fboundp sym) count t)) + +;;; IN-ARRAY that understands from,downfrowm,to, below, above,etc. I used +;;; a do for the macro iteration to be able include it here. + +(def-loop-for in-array (vars array &rest args) + (let (elt ind to) + (cond ((listp vars) (setf elt (car vars) ind (second vars))) + (t (setf elt vars ind (gensym "INDEX" )))) + (let ((skip (do ((v args (cddr v)) (result)) + (()) + (lcase (car v) + ((from downfrom) ) + ((to below above) (setf to t)) + (by) + (t (setq args (copy-list v)) + (return (nreverse result)))) + (push (car v) result) (push (second v) result)))) + (or to (setf skip (nconc `(below (length ,array)) skip))) + `(for ,ind + ,@ skip + with ,elt + do (setf ,elt (aref ,array ,ind)) ,@ args)))) + +;;; usage: IN-ARRAY +;;; (sloop for (elt i) in-array ar from 4 +;;; when (oddp i) +;;; collecting elt) + +;;; (sloop for elt in-array ar below 10 by 2 +;;; do (print elt)) + +(def-loop-for = (var val) + (lcase (loop-peek) + (then (loop-pop) `(with ,var initially (desetq ,var ,val) increment (desetq ,var ,(loop-pop)))) + (t `(with ,var do (desetq ,var ,val))))) + +(def-loop-macro sloop (for-loop) + (lcase (car for-loop) + (for)) + (let (*inner-sloop* *loop-body* *loop-map* inner-body + (finish-loop (gensym "FINISH")) + a b c e f (*loop-form* for-loop)) + (declare (special *inner-sloop* *loop-end-test* *loop-increment* + *product-for* *loop-map* + *loop-form* *loop-body* *loop-prologue* + *loop-epilogue* *loop-end-test* + *loop-bindings* + )) + (setf *product-for* t) + (loop-pop) + (sloop-swap) + (parse-loop-for) + (sloop-swap) + (do () + ((null *loop-form*)) + (cond ((catch 'collect (parse-loop1))) + ((null *loop-form*)(return 'done)) + (t ;(fsignal "hi") + (print *loop-form*) + (sloop-swap) + (parse-loop-collect) + (sloop-swap) + (print *loop-form*) + ))) + (sloop-swap) + (setf inner-body (nreverse *loop-body*)) + (and *loop-map* (setf inner-body (substitute-sloop-body inner-body))) + (let ((bod + `(macrolet ((local-finish () `(go ,',finish-loop))) + (tagbody + ,@ (nreverse *loop-prologue*) + ,@ (and (null *loop-map*) '(next-loop)) + ,@ (nreverse *loop-end-test*) + ,@ inner-body + ,@ (nreverse *loop-increment*) + ,@ (and (null *loop-map*) '((go next-loop))) + ,finish-loop + ,@ (nreverse *loop-epilogue*))))) + (dolist (v *loop-bindings*) + (setf bod + `(let ,(loop-let-bindings v) ,@(and (cdr v) `(,(cons 'declare (cdr v)))) + ,bod))) + (sloop-swap) + `(do ,bod)))) + +;;; Usage: SLOOP (FOR +;;; (defun te () +;;; (sloop for i below 5 +;;; sloop (for j to i collecting (list i j)))) + +(def-loop-for in-carefully (var lis) + "Path with var in lis except lis may end with a non nil cdr" + (let ((point (gensym "POINT"))) + `(with ,point and with ,var initially (setf ,point ,lis) + do(desetq ,var (car ,point)) + end-test (and (atom ,point)(local-finish)) + increment (setf ,point (cdr ,point))))) + +;;; Usage: IN-CAREFULLY +;;; (defun te (l) +;;; (sloop for v in-carefully l collecting v)) + +;;; Note the following is much like the mit for i first expr1 then expr2 +;;; but it is not identical, in that if expr1 refers to paralell for loop +;;; it will not get the correct initialization. But since we have such +;;; generality in the our definition of a for construct, it is unlikely +;;; that all people who define This is why we use a different name + +(def-loop-for first-use (var expr1 then expr2) + (or (l-equal then 'then) (error "First must be followed by then")) + `(with ,var initially (desetq ,var ,expr1) increment (desetq ,var ,expr2))) + +;;; I believe the following is what the original loop does with the FIRST +;;; THEN construction. + +(def-loop-for first (var expr1 then expr2) + (declare (special *loop-increment*)) + (or (l-equal then 'then) (error "First must be followed by then")) + ;; If this is the first for, then we don't need the flag, but can + ;; move the FIRST setting into the INITIALLY section + (cond ((null *loop-increment*) + `(with ,var initially (desetq ,var ,expr1) + increment (desetq ,var ,expr2))) + (t + (let ((flag (gensym))) + `(with ,var with ,flag + do (cond (,flag (desetq ,var ,expr2)) + (t (desetq ,var ,expr1))) + increment (desetq ,flag t)))))) + + +(defvar *collate-order* #'<) + +;;; of course this should be a search of the list based on the order and +;;; splitting into halves (binary search). I was too lazy to include one +;;; here, but it should be done. + +(defun find-in-ordered-list + (it list &optional (order-function *collate-order*) &aux prev) + (do ((v list (cdr v))) + ((null v) (values prev nil)) + (cond ((eql (car v) it) (return (values v t))) + ((funcall order-function it (car v)) + (return (values prev nil)))) + (setq prev v))) + +(def-loop-collect collate (ans val) + "Collects values into a sorted list without duplicates. +Order based order function *collate-order*" + `(do (multiple-value-bind + (after already-there ) + (find-in-ordered-list ,val ,ans) + (unless already-there + (cond (after (setf (cdr after) (cons ,val (cdr after)))) + (t (setf ,ans (cons ,val ,ans)))))))) + +;;; Usage: COLLATE +;;; (defun te () +;;; (let ((res +;;; (sloop for i below 10 +;;; sloop (for j downfrom 8 to 0 +;;; collate (* i (mod j (max i 1)) (random 2))))) +;;; + +;;; Two implementations of slooping over the fringe of a tree + +;;;(defun map-fringe (fun tree) +;;; (do ((v tree)) +;;; (()) +;;; (cond ((atom v) +;;; (and v (funcall fun v))(return 'done)) +;;; ((atom (car v)) +;;; (funcall fun (car v))) +;;; (t (map-fringe fun (car v) ))) +;;; (setf v (cdr v)))) +;;; +;;;(def-loop-map in-fringe (var tree) +;;; "Map over the non nil atoms in the fringe of tree" +;;; `(map-fringe #'(lambda (,var) :sloop-map-declares :sloop-body) ,tree)) + +;;; The next version is equivalent to the previous but uses labels and so +;;; avoids having to funcall an anonymous function. [as suggested +;;; by M. Ballantyne] + +(def-loop-map in-fringe (var tree) + "Map over the non nil atoms in the fringe of tree" + (let ((v (gensym))) + `(let (,var) + (labels + ((map-fringe-aux (.xtree.) + (do ((,v .xtree.)) + ((null ,v)) + (cond ((atom ,v) (setf ,var ,v) (setf ,v nil)) + (t (setf ,var (car ,v))(setf ,v (cdr ,v)))) + (cond ((null ,var)) + ((atom ,var) + :sloop-map-declares :sloop-body) + (t (map-fringe-aux ,var )))))) + (map-fringe-aux ,tree))))) + +;;; Usage: IN-FRINGE +;;; (sloop for v in-fringe '(1 2 (3 (4 5) . 6) 8 1 2) +;;; declare (fixnum v) +;;; maximize v) diff --git a/lsp/gcl_stack-problem.lsp b/lsp/gcl_stack-problem.lsp new file mode 100755 index 0000000..4733639 --- /dev/null +++ b/lsp/gcl_stack-problem.lsp @@ -0,0 +1,29 @@ +(in-package 'si) + +(defvar *old-handler* #'si::universal-error-handler) + +(defentry ihs_function_name (object) (object "ihs_function_name")) + + +(defun new-universal-error-handler + (a b c d e &rest l &aux (i 0) (top (si::ihs-top))) + (declare (fixnum i top)) + (if (search "stack overflow" e) + (progn (format t "~a in ~a" e d) + (format t "invocation stack:") + (loop (cond ((or (> i 20) + (< top 10)) + (return nil))) + (setq i (+ i 1)) + (setq top (- top 1)) + (format t "< ~s " (ihs_function_name (si::ihs-fun top)))) + (format t "Jumping to top") + (throw *quit-tag* nil) + ) + (apply *old-handler* a b c d e l))) + + +(setf (symbol-function 'si::universal-error-handler) + #'new-universal-error-handler) + + diff --git a/lsp/gcl_stdlisp.lsp b/lsp/gcl_stdlisp.lsp new file mode 100755 index 0000000..2e72c9e --- /dev/null +++ b/lsp/gcl_stdlisp.lsp @@ -0,0 +1,61 @@ + +;; Loading the following causes these non standard symbols in the LISP +;; package, to no longer be automatically exported to packages which +;; use LISP. For example BYE will no longer be accessible from package +;; USER. You will need to type (lisp::bye) to quit. Of course references +;; to BYE before this file was loaded will mean the symbol BYE in the lisp +;; package. + +;; Someday this file may be loaded by default in GCL, so you should +;; probably use the LISP:: prefix for these symbols, as protection +;; against that day. + +(unexport + '(LISP::LAMBDA-BLOCK-CLOSURE + LISP::BYE LISP::QUIT LISP::EXIT LISP::IEEE-FLOATING-POINT + LISP::DEFENTRY LISP::VOID LISP::ALLOCATE-CONTIGUOUS-PAGES + LISP::UNSIGNED-SHORT + LISP::DOUBLE + LISP::BY + LISP::GBC + LISP::DEFCFUN + LISP::SAVE + LISP::MAXIMUM-CONTIGUOUS-PAGES + LISP::SPICE + LISP::DEFLA + LISP::ALLOCATED-PAGES + LISP::SUN + LISP::INT + LISP::USE-FAST-LINKS + LISP::CFUN + LISP::UNSIGNED-CHAR + LISP::HELP + LISP::HELP* + LISP::MACRO + LISP::*BREAK-ENABLE* + LISP::CLINES + LISP::LAMBDA-CLOSURE + LISP::OBJECT + LISP::FAT-STRING + LISP::SIGNED-SHORT + LISP::MC68020 + LISP::LAMBDA-BLOCK + LISP::TAG + LISP::PROCLAMATION + LISP::ALLOCATED-CONTIGUOUS-PAGES + LISP::*EVAL-WHEN-COMPILE* + LISP::SIGNED-CHAR + LISP::*IGNORE-MAXIMUM-PAGES* + LISP::*LINK-ARRAY* + LISP::KCL + LISP::BSD + LISP::ALLOCATE-RELOCATABLE-PAGES + LISP::ALLOCATE + LISP::UNIX + LISP::MAXIMUM-ALLOCATABLE-PAGES + LISP::ALLOCATED-RELOCATABLE-PAGES + LISP::SYSTEM + LISP::KYOTO + LISP::CCLOSURE) + 'LISP + ) \ No newline at end of file diff --git a/lsp/gcl_top.lsp b/lsp/gcl_top.lsp new file mode 100755 index 0000000..65fff7f --- /dev/null +++ b/lsp/gcl_top.lsp @@ -0,0 +1,653 @@ +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +;;;; top.lsp +;;;; +;;;; Top-level loop, break loop, and error handlers +;;;; +;;;; Revised on July 11, by Carl Hoffman. + + +(in-package "LISP") +;(export 'lisp) +(export '(+ ++ +++ - * ** *** / // ///)) +(export '(break warn)) +(export '*break-on-warnings*) +(export '*break-enable*) + +(in-package 'system) + +(export '*break-readtable*) +(export '(loc *debug-print-level*)) + +(export '(vs ihs-vs ihs-fun frs-vs frs-bds frs-ihs bds-var bds-val super-go)) + +(eval-when + (compile) + (proclaim '(optimize (safety 2) (space 3))) + (defvar *command-args* nil)) + +(defvar +) +(defvar ++) +(defvar +++) +(defvar -) +(defvar *) +(defvar **) +(defvar ***) +(defvar /) +(defvar //) +(defvar ///) + + +;; setup file search and autoload + +(defvar *fixed-load-path* nil) +(defvar *load-path* nil) +(defvar *load-types* '(".o" ".lsp" ".lisp")) + +(defvar *lisp-initialized* nil) +(defconstant +top-level-quit-tag+ (cons nil nil)) +(defvar *quit-tag* +top-level-quit-tag+) +(defvar *quit-tags* nil) +(defvar *break-level* '()) +(defvar *break-env* nil) +(defvar *ihs-base* 1) +(defvar *ihs-top* 1) +(defvar *current-ihs* 1) +(defvar *frs-base* 0) +(defvar *frs-top* 0) +(defvar *break-enable* t) +(defvar *break-message* "") + +(defvar *break-on-warnings* nil) + +(defvar *break-readtable* nil) + +(defvar *top-level-hook* nil) + + +(defvar *top-eof* (cons nil nil)) +(defvar *no-prompt* nil) + +(defun top-level () + (let ((+ nil) (++ nil) (+++ nil) + (- nil) + (* nil) (** nil) (*** nil) + (/ nil) (// nil) (/// nil)) + (setq *lisp-initialized* t) + (catch *quit-tag* + (progn + (cond + (*multiply-stacks* (setq *multiply-stacks* nil)) + ((probe-file "init.lsp") (load "init.lsp")))) + (when (if (symbolp *top-level-hook*) (fboundp *top-level-hook*) (functionp *top-level-hook*)) + (funcall *top-level-hook*))) + + (when (boundp '*system-banner*) + (format t *system-banner*) + (format t "Temporary directory for compiler files set to ~a~%" *tmp-dir*)) + + (loop + (setq +++ ++ ++ + + -) + (if *no-prompt* (setq *no-prompt* nil) + (format t "~%~a>" + (if (eq *package* (find-package 'user)) "" + (package-name *package*)))) + (reset-stack-limits) + ;; have to exit and re-enter to multiply stacks + (cond (*multiply-stacks* (Return-from top-level))) + (when (catch *quit-tag* + (setq - (locally (declare (notinline read)) + (read *standard-input* nil *top-eof*))) + (when (eq - *top-eof*) (bye)) + (let ((values (multiple-value-list + (locally (declare (notinline eval)) (eval -))))) + (setq /// // // / / values *** ** ** * * (car /)) + (fresh-line) + (dolist (val /) + (locally (declare (notinline prin1)) (prin1 val)) + (terpri)) + nil)) + (setq *evalhook* nil *applyhook* nil) + (terpri *error-output*) + (break-current))))) + +(defun set-dir (sym val) + (let ((tem (or val (and (boundp sym) (symbol-value sym))))) + (if tem (set sym (coerce-slash-terminated tem))))) + +(defvar *error-p* nil) + +(defun process-some-args (args &optional compile &aux *load-verbose*) + (when args + (let ((x (pop args))) + (cond ((equal x "-load") (load (pop args))) + ((equal x "-eval") (eval (read-from-string (pop args)))) + ((equal x "-batch") (setq *top-level-hook* 'bye)) + ((equal x "-o-file") (unless (read-from-string (car args)) + (push (cons :o-file nil) compile) + (pop args))) + ((equal x "-h-file") (push (cons :h-file t) compile)) + ((equal x "-data-file") (push (cons :data-file t) compile)) + ((equal x "-c-file") (push (cons :c-file t) compile)) + ((equal x "-system-p") (push (cons :system-p t) compile)) + ((equal x "-compile") (push (cons :compile (pop args)) compile)) + ((equal x "-o") (push (cons :o (pop args)) compile)) + ((equal x "-libdir") (set-dir '*lib-directory* (pop args))) + ((equal x "-dir") (set-dir '*system-directory* (pop args))) + ((equal x "-f") (do-f (car (setq *command-args* args)))) + ((equal x "--") (setq *command-args* args args nil)))) + (process-some-args args compile)) + + (when compile + (let* (*break-enable* + (file (cdr (assoc :compile compile))) + (o (cdr (assoc :o compile))) + (compile (remove :o (remove :compile compile :key 'car) :key 'car)) + (compile (cons (cons :output-file (or o file)) compile)) + (result (system:error-set `(apply 'compile-file ,file ',(mapcan (lambda (x) (list (car x) (cdr x))) compile))))) + (bye (if (or *error-p* (equal result '(nil))) 1 0))))) + +(defun dbl-read (&optional (stream *standard-input*) (eof-error-p t) + (eof-value nil) &aux tem ch) + (tagbody + top + (setq ch (read-char stream eof-error-p eof-value)) + (cond ((eql ch #\newline) (go top)) + ((eq ch eof-value) (return-from dbl-read eof-value))) + (unread-char ch stream)) + + (cond ((eql #\: ch) + (setq tem + (string-concatenate + "(" + (read-line stream eof-error-p eof-value)")")) + (read (make-string-input-stream tem) + eof-error-p eof-value)) + (t (read stream eof-error-p eof-value)))) + + +(defvar *debug-print-level* 3) + +(defun terminal-interrupt (correctablep) + (let ((*break-enable* t)) + (if correctablep + (cerror "Type :r to resume execution, or :q to quit to top level." + "Console interrupt.") + (error "Console interrupt -- cannot continue.")))) + + +(defun break-call (key args &optional (prop 'si::break-command) &aux fun) + (setq fun (complete-prop key 'keyword prop)) + (or fun (return-from break-call nil)) + (setq fun (get fun prop)) + (cond (fun + (setq args (cons fun args)) + (or (symbolp fun) (setq args (cons 'funcall args))) + (evalhook args nil nil *break-env*) + ) + (t (format *debug-io* "~&~S is undefined break command.~%" key)))) + +(defun break-quit (&optional (level 0) + &aux (current-level (length *break-level*))) + (when (and (>= level 0) (< level current-level)) + (let ((x (nthcdr (- current-level level 1) *quit-tags*)) + (y (member nil *quit-tags* :key 'cdr))) + (if (tailp x y) + (format *debug-io* "The *quit-tag* is disabled at level ~s.~%" (length y)) + (throw (cdar x) (cdar x))))) + (break-current)) + +(defun break-previous (&optional (offset 1)) + (do ((i (1- *current-ihs*) (1- i))) + ((or (< i *ihs-base*) (<= offset 0)) + (set-env) + (break-current)) + (when (ihs-visible i) + (setq *current-ihs* i) + (setq offset (1- offset))))) + +(defun set-current () + (do ((i *current-ihs* (1- i))) + ((or (ihs-visible i) (<= i *ihs-base*)) + (setq *current-ihs* i) + (set-env) + (format *debug-io* "Broken at ~:@(~S~).~:[ Type :H for Help.~;~]" + (ihs-fname *current-ihs*) + (cdr *break-level*))))) + +(defun break-next (&optional (offset 1)) + (do ((i *current-ihs* (1+ i))) + ((or (> i *ihs-top*) (< offset 0)) + (set-env) + (break-current)) + (when (ihs-visible i) + (setq *current-ihs* i) + (setq offset (1- offset))))) + +(defun break-go (ihs-index) + (setq *current-ihs* (min (max ihs-index *ihs-base*) *ihs-top*)) + (if (ihs-visible *current-ihs*) + (progn (set-env) (break-current)) + (break-previous))) + +(defun break-message () + (princ *break-message* *debug-io*) + (terpri *debug-io*) + (values)) + +(defun describe-environment (&optional (env *break-env*) (str *debug-io*)) + (or (eql (length env) 3) (error "bad env")) + (let ((fmt "~a~#[none~;~S~;~S and ~S~ + ~:;~@{~#[~;and ~]~S~^, ~}~].~%")) + (apply 'format str fmt "Local variables: " + (mapcar #'car (car *break-env*))) + (apply 'format str fmt "Local functions: " + (mapcar #'car (cadr *break-env*))) + (apply 'format str fmt "Local blocks: " + (mapcan #'(lambda (x) (when (eq (cadr x) 'block) (list (car x)))) + (caddr *break-env*))) + (apply 'format str fmt "Local tags: " + (mapcan #'(lambda (x) (when (eq (cadr x) 'tag) (list (car x)))) + (caddr *break-env*))))) + +(defun break-vs (&optional (x (ihs-vs *ihs-base*)) (y (ihs-vs *ihs-top*))) + (setq x (max x (ihs-vs *ihs-base*))) + (setq y (min y (1- (ihs-vs (1+ *ihs-top*))))) + (do ((ii *ihs-base* (1+ ii))) + ((or (>= ii *ihs-top*) (>= (ihs-vs ii) x)) + (do ((vi x (1+ vi))) + ((> vi y) (values)) + (do () + ((> (ihs-vs ii) vi)) + (when (ihs-visible ii) (print-ihs ii)) + (incf ii)) + (format *debug-io* "~&VS[~d]: ~s" vi (vs vi)))))) + +(defun break-local (&optional (n 0) &aux (x (+ (ihs-vs *current-ihs*) n))) + (break-vs x x)) + +(defun break-bds (&rest vars &aux (fi *frs-base*)) + (do ((bi (1+ (frs-bds (1- *frs-base*))) (1+ bi)) + (last (frs-bds (1+ *frs-top*)))) + ((> bi last) (values)) + (when (or (null vars) (member (bds-var bi) vars)) + (do () + ((or (> fi *frs-top*) (> (frs-bds fi) bi))) + (print-frs fi) + (incf fi)) + (format *debug-io* "~&BDS[~d]: ~s = ~s" + bi (bds-var bi) (bds-val bi))))) + +(defun simple-backtrace () + (princ "Backtrace: " *debug-io*) + (do* ((i *ihs-base* (1+ i)) + (b nil t)) + ((> i *ihs-top*) (terpri *debug-io*) (values)) + (when (ihs-visible i) + (when b (princ " > " *debug-io*)) + (write (ihs-fname i) :stream *debug-io* :escape t + :case (if (= i *current-ihs*) :upcase :downcase))))) + +(defun ihs-backtrace (&optional (from *ihs-base*) (to *ihs-top*)) + (setq from (max from *ihs-base*)) + (setq to (min to *ihs-top*)) + (do* ((i from (1+ i)) + (j (or (sch-frs-base *frs-base* from) (1+ *frs-top*)))) + ((> i to) (values)) + (when (ihs-visible i) (print-ihs i)) + (do () ((or (> j *frs-top*) (> (frs-ihs j) i))) + (print-frs j) + (incf j)))) + +(defun print-ihs (i &aux (*print-level* 2) (*print-length* 4)) + (format t "~&~:[ ~;@ ~]IHS[~d]: ~s ---> VS[~d]" + (= i *current-ihs*) + i + (let ((fun (ihs-fun i))) + (cond ((or (symbolp fun) (compiled-function-p fun)) fun) + ((consp fun) + (case (car fun) + (lambda fun) + ((lambda-block lambda-block-expanded) (cdr fun)) + (lambda-closure (cons 'lambda (cddddr fun))) + (lambda-block-closure (cddddr fun)) + (t (cond + ((and (symbolp (car fun)) + (or (special-form-p(car fun)) + (fboundp (car fun)))) + (car fun)) + (t '(:zombi)))))) + (t (print fun) + :zombi))) + (ihs-vs i))) + +(defun print-frs (i) + (format *debug-io* "~& FRS[~d]: ~s ---> IHS[~d],VS[~d],BDS[~d]" + i (frs-kind i) (frs-ihs i) (frs-vs i) (frs-bds i))) + +(defun frs-kind (i &aux x) + (case (frs-class i) + (:catch + (if (spicep (frs-tag i)) + (or (and (setq x (member (frs-tag i) (vs (+ (frs-vs i) 2)) + :key #'caddr :test #'eq)) + (if (eq (cadar x) 'block) + `(block ,(caar x) ***) + `(tagbody ,@(reverse (mapcar #'car + (remove (frs-tag i) x + :test-not #'eq + :key #'caddr))) + ***))) + `(block/tagbody ,(frs-tag i))) + `(catch ',(frs-tag i) ***))) + (:protect '(unwind-protect ***)) + (t `(system-internal-catcher ,(frs-tag i))))) + +(defun break-current () + (if *break-level* + (format *debug-io* "Broken at ~:@(~S~)." (ihs-fname *current-ihs*)) + (format *debug-io* "~&Top level.")) + (values)) + + + +(defvar *break-hidden-packages* nil) + +(defun ihs-visible (i &aux (tem (ihs-fname i))) + (and tem (not (member tem *break-hidden-packages*)))) + + +(defun ihs-fname (ihs-index) + (let ((fun (ihs-fun ihs-index))) + (cond ((symbolp fun) fun) + ((consp fun) + (case (car fun) + (lambda 'lambda) + ((lambda-block lambda-block-expanded) (cadr fun)) + (lambda-block-closure (nth 4 fun)) + (lambda-closure 'lambda-closure) + (t (if (and (symbolp (car fun)) + (or (special-form-p (car fun)) + (fboundp (car fun)))) + (car fun) :zombi) + ))) + ((compiled-function-p fun) + (compiled-function-name fun)) + (t :zombi)))) + +(defun ihs-not-interpreted-env (ihs-index) + (let ((fun (ihs-fun ihs-index))) + (cond ((and (consp fun) + (> ihs-index 3) + ;(<= (ihs-vs ihs-index) (ihs-vs (- ihs-index 1))) + ) + nil) + (t t)))) + +(defun set-env () + (setq *break-env* + (if (ihs-not-interpreted-env *current-ihs*) + nil + (let ((i (ihs-vs *current-ihs*))) + (list (vs i) (vs (1+ i)) (vs (+ i 2))))))) + +(defun list-delq (x l) + (cond ((null l) nil) + ((eq x (car l)) (cdr l)) + (t (rplacd l (list-delq x (cdr l)))))) + +(defun super-go (i tag &aux x) + (when (and (>= i *frs-base*) (<= i *frs-top*) (spicep (frs-tag i))) + (if (setq x (member (frs-tag i) (vs (+ (frs-vs i) 2)) + :key #'caddr :test #'eq)) + ; Interpreted TAGBODY. + (when (and (eq (cadar x) 'tag) + (member tag (mapcar #'car (remove (frs-tag i) x + :test-not #'eq + :key #'caddr)))) + (internal-super-go (frs-tag i) tag t)) + ; Maybe, compiled cross-closure TAGBODY. + ; But, it may also be compiled cross-closure BLOCK, in which case + ; SUPER-GO just RETURN-FROMs with zero values. + (internal-super-go (frs-tag i) tag nil))) + (format *debug-io* "~s is invalid tagbody identification for ~s." i tag)) + +(defun break-backward-search-stack (sym &aux string) + (setq string (string sym)) + (do* ((ihs (1- *current-ihs*) (1- ihs)) + (fname (ihs-fname ihs) (ihs-fname ihs))) + ((< ihs *ihs-base*) + (format *debug-io* "Search for ~a failed.~%" string)) + (when (and (ihs-visible ihs) + (search string (symbol-name fname) :test #'char-equal)) + (break-go ihs) + (return)))) + +(defun break-forward-search-stack (sym &aux string) + (setq string (string sym)) + (do* ((ihs (1+ *current-ihs*) (1+ ihs)) + (fname (ihs-fname ihs) (ihs-fname ihs))) + ((> ihs *ihs-top*) + (format *debug-io* "Search for ~a failed.~%" string)) + (when (and (ihs-visible ihs) + (search string (symbol-name fname) :test #'char-equal)) + (break-go ihs) + (return)))) + +(defun break-resume () + (if *debug-continue* + (invoke-restart *debug-continue*) + :resume)) + +(putprop :b 'simple-backtrace 'break-command) +(putprop :r 'break-resume 'break-command) +(putprop :resume (get :r 'break-command) 'break-command) +(putprop :bds 'break-bds 'break-command) +(putprop :blocks 'break-blocks 'break-command) +(putprop :bs 'break-backward-search-stack 'break-command) +(putprop :c 'break-current 'break-command) +(putprop :fs 'break-forward-search-stack 'break-command) +(putprop :functions 'break-functions 'break-command) +(putprop :go 'break-go 'break-command) +(putprop :h 'break-help 'break-command) +(putprop :help 'break-help 'break-command) +(putprop :ihs 'ihs-backtrace 'break-command) +(putprop :env '(lambda () (describe-environment *break-env*)) 'break-command) +(putprop :m 'break-message 'break-command) +(putprop :n 'break-next 'break-command) +(putprop :p 'break-previous 'break-command) +(putprop :q 'break-quit 'break-command) +(putprop :s 'break-backward-search-stack 'break-command) +(putprop :vs 'break-vs 'break-command) + +(defun break-help () + (dolist (v '( " +Break-loop Command Summary ([] indicates optional arg) +-------------------------- + +:bl [j] show local variables and their values, or segment of vs if compiled + in j stack frames starting at the current one. +:bt [n] BACKTRACE [n steps] +:down [i] DOWN i frames (one if no i) +:env describe ENVIRONMENT of this stack frame (for interpreted). +:fr [n] show frame n +:loc [i] return i'th local of this frame if its function is compiled (si::loc i) +" +":r RESUME (return from the current break loop). +:up [i] UP i frames (one if no i) + +Example: print a bactrace of the last 4 frames + +>>:bt 4 + +Note: (use-fast-links nil) makes all non system function calls +be recorded in the stack. (use-fast-links t) is the default + +Low level commands: +------------------ +:p [i] make current the i'th PREVIOUS frame (in list show by :b) +:n [i] make current the i'th NEXT frame (in list show by :b) +:go [ihs-index] make current the frame corresponding ihs-index +" +":m print the last break message. +:c show function of the current ihs frame. +:q [i] quit to top level +:r resume from this break loop. +:b full backtrace of all functions and special forms. +:bs [name] backward search for frame named 'name' +:fs [name] search for frame named 'name' +:vs [from] [to] Show value stack between FROM and TO +:ihs [from] [to] Show Invocation History Stack +" +" +:bds ['v1 'v2 ..]Show previous special bindings of v1, v2,.. or all if no v1 + +")) (format *debug-io* v)) + (format *debug-io* "~%Here is a COMPLETE list of bindings. Too +add a new one, add a 'si::break-command property:") + (do-symbols (v (find-package "KEYWORD")) + (cond ((get v 'si::break-command) + (format *debug-io* + "~%~(~a -- ~a~)" v (get v 'si::break-command))))) + (values) + ) + + +;;make sure '/' terminated + +(defun coerce-slash-terminated (v ) + (declare (string v)) + (or (stringp v) (error "not a string ~a" v)) + (let ((n (length v))) + (declare (fixnum n)) + (unless (and (> n 0) (eql + (the character(aref v (the fixnum (- n 1)))) #\/)) + (setf v (format nil "~a/" v)))) + v) +(defun fix-load-path (l) + (when (not (equal l *fixed-load-path*)) + (do ((x l (cdr x)) ) + ((atom x)) + (setf (car x) (coerce-slash-terminated (car x)))) + (do ((v l (cdr v))) + ((atom v)) + (do ((w v (cdr w))) + ((atom (cdr w))) + (cond ((equal (cadr w) (car v)) + (setf (cdr w)(cddr w))))))) + (setq *fixed-load-path* l)) + +(defun file-search (NAME &optional (dirs *load-path*) + (extensions *load-types*) (fail-p t) &aux tem) + "Search for NAMME in DIRS with EXTENSIONS. +First directory is checked for first name and all extensions etc." + (fix-load-path dirs) + (dolist (v dirs) + (dolist (e extensions) + (if (probe-file (setq tem (si::string-concatenate v name e))) + (return-from file-search tem)))) + (if fail-p + (let ((*path* nil)) + (declare (special *path*)) + (cerror + "Do (setq si::*path* \"pathname\") for path to use then :r to continue" + "Lookup failed in directories:~s for name ~s with extensions ~s" + dirs name extensions) + *path*))) + +(defun aload (path) + (load (file-search path *load-path* *load-types*))) + +(defun autoload (sym path &aux (si::*ALLOW-GZIPPED-FILE* t)) + (or (fboundp sym) + (setf (symbol-function sym) + #'(lambda (&rest l) + (aload path) + (apply sym l))))) + +(defun autoload-macro (sym path &aux (si::*ALLOW-GZIPPED-FILE* t)) + (or (fboundp sym) + (setf (macro-function sym) + #'(lambda (form env) + (aload path) + (funcall sym form env))))) + +(eval-when (compile) (proclaim '(optimize (safety 0))) ) +(defvar si::*command-args* nil) + +(defvar *tmp-dir*) + +(defun wine-tmp-redirect () + (let* ((s (find-symbol "*WINE-DETECTED*" (find-package "SYSTEM")))) + (when (and s (symbol-value s)) + (list *system-directory*)))) + + +(defun get-temp-dir nil + (dolist (x `(,@(wine-tmp-redirect) ,@(mapcar 'getenv '("TMPDIR" "TMP" "TEMP")) "/tmp" "")) + (when (or (stringp x) (pathnamep x)) + (let* ((x (truename (pathname x))) + (y (namestring (make-pathname :name (pathname-name x) :type (pathname-type x) :version (pathname-version x)))) + (y (unless (zerop (length y)) (list y)))) + (when (eq :directory (car (stat x))) + (return-from get-temp-dir + (namestring + (make-pathname + :device (pathname-device x) + :directory (append (pathname-directory x) y))))))))) + +(defun set-up-top-level (&aux (i (argc)) tem) + (declare (fixnum i)) + (setq *tmp-dir* (get-temp-dir)) + (dotimes (j i) (push (argv j) tem)) + (setq *command-args* (nreverse tem)) + (setq tem *lib-directory*) + (process-some-args *command-args*) + (unless *lib-directory* + (let ((dir (getenv "GCL_LIBDIR"))) + (when dir + (setq *lib-directory* (coerce-slash-terminated dir))))) + (unless (and *load-path* (equal tem *lib-directory*)) + (setq *load-path* (cons (string-concatenate *lib-directory* "lsp/") *load-path*)) + (setq *load-path* (cons (string-concatenate *lib-directory* "gcl-tk/") *load-path*)) + (setq *load-path* (cons (string-concatenate *lib-directory* "xgcl-2/") *load-path*))) + (unless (boundp '*system-directory*) + (setq *system-directory* (namestring (truename (make-pathname :name nil :type nil :defaults (argv 0)))))))) + +(defvar *old-top-level* #'top-level) + +(defun gcl-top-level nil + + (set-up-top-level) + + (in-package :user) + (setq *ihs-top* (ihs-top)) + (funcall *old-top-level*)) + +(defun do-f (file &aux *break-enable*) + (catch *quit-tag* + (labels ((read-loop (st &aux (tem (read st nil 'eof))) (when (eq tem 'eof) (bye)) (eval tem) (read-loop st)) + (read-file (st) (read-line st nil 'eof) (read-loop st))) + (if file + (with-open-file + (st file) + (read-file st)) + (read-file *standard-input*)))) + (bye 1)) diff --git a/lsp/gcl_trace.lsp b/lsp/gcl_trace.lsp new file mode 100755 index 0000000..f97ed95 --- /dev/null +++ b/lsp/gcl_trace.lsp @@ -0,0 +1,453 @@ +;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +;; This file is part of GNU Common Lisp, herein referred to as GCL +;; +;; GCL is free software; you can redistribute it and/or modify it under +;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; GCL is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +;; License for more details. +;; +;; You should have received a copy of the GNU Library General Public License +;; along with GCL; see the file COPYING. If not, write to the Free Software +;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +;;;; trace.lsp +;;;; +;;;; Tracer package for Common Lisp + +;;;;;; Modified by Matt Kaufmann to allow tracing options. + + +;; If you are working in another package you should (import 'si::arglist) +;; to avoid typing the si:: + +(in-package 'lisp) + +(export '(trace untrace)) +(export 'step) + + +(in-package 'system) + +;;(proclaim '(optimize (safety 2) (space 3))) + + +(defvar *trace-level* 0) +(defvar *trace-list* nil) + + +(defmacro trace (&rest r) + (if (null r) + '(mapcar #'car *trace-list*) + `(let ((old (copy-list *trace-list*)) finish-flg) + (unwind-protect + (prog1 (mapcan #'trace-one ',r) + (setq finish-flg t)) + (when (null finish-flg) + (format *standard-output* "~%Newly traced functions: ~S" + (mapcar #'car (set-difference *trace-list* old :test #'equal)))))))) + +(defmacro untrace (&rest r) + (if (null r) + '(mapcan #'untrace-one (mapcar #'car *trace-list*)) + `(mapcan #'untrace-one ',r))) + +(defun trace-one-preprocess (x) + (cond + ((symbolp x) + (trace-one-preprocess (list x))) + (t ; We've checked for CONSP with null last CDR + (do ((tail (cdr x) (cddr tail)) + (declarations) + (entryform `(cons (quote ,(car x)) arglist)) + (exitform `(cons (quote ,(car x)) values)) + (condform t) + (entrycondform t) + (exitcondform t) + (depth) (depthvar)) + ((null tail) + (when depth + ;; Modify the :cond so that it first checks depth, and then + ;; modify the :entry so that it first increments depth. Notice + ;; that :cond will be fully evaluated before depth is incremented. + (setq depthvar (gensym)) + ;; now reset the condform + (if + (eq condform t) + (setq condform + `(< ,depthvar ,depth)) + (setq condform `(if (< ,depthvar ,depth) ,condform nil))) + (setq declarations (cons (cons depthvar 0) declarations)) + ;; I'll have the depth be incremented for all the entry stuff and no exit stuff, + ;; since I don't see any more uniform, logical way to do this. + (setq entrycondform + `(progn + (setq ,depthvar (1+ ,depthvar)) + ,entrycondform)) + (setq exitcondform + `(progn + (setq ,depthvar (1- ,depthvar)) + ,exitcondform))) + `(,(car x) ,declarations + (quote ,condform) + (quote ,entrycondform) (quote ,entryform) + (quote ,exitcondform) (quote ,exitform))) + (case (car tail) + (:declarations + (setq declarations + (do ((decls (cadr tail) (cdr decls)) + (result)) + ((null decls) result) + (setq result + (cons (if (symbolp (car decls)) + (cons (car decls) nil) + (cons (caar decls) (eval (cadar decls)))) + result))))) + (:cond (setq condform (cadr tail))) + (:entrycond (setq entrycondform (cadr tail))) + (:entry (setq entryform (cadr tail))) + (:exitcond (setq exitcondform (cadr tail))) + (:exit (setq exitform (cadr tail))) + (:depth (setq depth (cadr tail))) + (otherwise nil)))))) + +(defun check-trace-spec (form) + (or (symbolp form) + (if (and (consp form) (null (cdr (last form)))) + (check-trace-args form (cdr form) nil) + (error "Each trace spec must be a symbol or a list terminating in NIL, but ~S is not~&." + form)))) + +(defun check-declarations (declarations &aux decl) + (when (consp declarations) + (setq decl (if (consp (car declarations)) (car declarations) (list (car declarations) nil))) + (when (not (symbolp (car decl))) + (error "Declarations are supposed to be of symbols, but ~S is not a symbol.~&" + (car decl))) + (when (cddr decl) + (error "Expected a CDDR of NIL in ~S.~&" + decl)) + (when (assoc (car decl) (all-trace-declarations)) + (error "The variable ~A is already declared for tracing" + (car decl))))) + +(defun check-trace-args (form args acc-keywords) + (when args + (cond + ((null (cdr args)) + (error "A trace spec must have odd length, but ~S does not.~&" + form)) + ((member (car args) acc-keywords) + (error "The keyword ~A occurred twice in the spec ~S~&" + (car args) form)) + (t + (case (car args) + ((:entry :exit :cond :entrycond :exitcond) + (check-trace-args form (cddr args) (cons (car args) acc-keywords))) + (:depth + (when (not (and (integerp (cadr args)) + (> (cadr args) 0))) + (error + "~&Specified depth should be a positive integer, but~&~S is not.~&" + (cadr args))) + (check-trace-args form (cddr args) (cons :depth acc-keywords))) + (:declarations + (check-declarations (cadr args)) + (check-trace-args form (cddr args) (cons :declarations acc-keywords))) + (otherwise + (error "Expected :entry, :exit, :cond, :depth, or :declarations~&~ + in ~S where instead there was ~S~&" + form (car args)))))))) + +(defun trace-one (form &aux f (fname (if (consp form) (car form) form))) + (when (null (fboundp fname)) + (format *trace-output* "The function ~S is not defined.~%" fname) + (return-from trace-one nil)) + (when (special-form-p fname) + (format *trace-output* "~S is a special form.~%" fname) + (return-from trace-one nil)) + (when (macro-function fname) + (format *trace-output* "~S is a macro.~%" fname) + (return-from trace-one nil)) + (when (get fname 'traced) + (untrace-one fname)) + (check-trace-spec form) + (setq form (trace-one-preprocess form)) + (si:fset (setq f (gensym)) (symbol-function fname)) + (eval `(defun ,fname (&rest args) + (trace-call ',f args + ,@(cddr form)))) + (si:putprop fname f 'traced) + (setq *trace-list* (cons (cons fname (cadr form)) *trace-list*)) + (list fname)) + +(defun reset-trace-declarations (declarations) + (when declarations + (set (caar declarations) (cdar declarations)) + (reset-trace-declarations (cdr declarations)))) + +(defun all-trace-declarations ( &aux result) + (dolist (v *trace-list*) + (setq result (append result (cdr v)))) + result) + +(defun trace-call (temp-name args cond entrycond entry exitcond exit + &aux (*trace-level* *trace-level*) vals indent) + (when (= *trace-level* 0) + (reset-trace-declarations (all-trace-declarations))) + (cond + ((eval `(let ((arglist (quote ,args))) ,cond)) + (setq *trace-level* (1+ *trace-level*)) + (setq indent (min (* *trace-level* 2) 20)) + (fresh-line *trace-output*) + (when (or (eq entrycond t) ;optimization for common value + (eval `(let ((arglist (quote ,args))) ,entrycond))) + ;; put out the prompt before evaluating + (format *trace-output* + "~V@T~D> " + indent *trace-level*) + (format *trace-output* + "~S~%" + (eval `(let ((arglist (quote ,args))) ,entry))) + (fresh-line *trace-output*)) + (setq vals (multiple-value-list (apply temp-name args))) + (when (or (eq exitcond t) ;optimization for common value + (eval `(let ((arglist (quote ,args)) (values (quote ,vals))) + ,exitcond))) + ;; put out the prompt before evaluating + (format *trace-output* + "~V@T<~D " + indent + *trace-level*) + (format *trace-output* + "~S~%" + (eval `(let ((arglist (quote ,args)) (values (quote ,vals))) ,exit)))) + (setq *trace-level* (1- *trace-level*)) + (values-list vals)) + (t (apply temp-name args)))) + +(defun untrace-one (fname &aux sym) + (cond ((setq sym (get fname 'traced)) + (remprop fname 'traced) + (cond + ((not (fboundp fname)) + (format *trace-output* + "The function ~S was traced, but is no longer defined.~%" + fname)) + + ;;(LAMBDA-BLOCK block-name lambda-list (TRACE-CALL ... )) + ((and (consp (symbol-function fname)) + (consp (nth 3 (symbol-function fname))) + (eq (car (nth 3 (symbol-function fname))) 'trace-call)) + (si:fset fname (symbol-function sym))) + (t + (format *trace-output* + "The function ~S was traced, but redefined.~%" + fname))) + (setq *trace-list* + (delete-if #'(lambda (u) (eq (car u) fname)) + *trace-list* :count 1)) + (list fname)) + (t + (format *trace-output* "The function ~S is not traced.~%" fname) + nil))) + +#| Example of tracing a function "fact" so that only the outermost call is traced. + +(defun fact (n) (if (= n 0) 1 (* n (fact (1- n))))) + +;(defvar in-fact nil) +(trace (fact :declarations ((in-fact nil)) + :cond + (null in-fact) + :entry + (progn + (setq in-fact t) + (princ "Here comes input ") + (cons 'fact arglist)) + :exit + (progn (setq in-fact nil) + (princ "Here comes output ") + (cons 'fact values)))) + +; Example of tracing fact so that only three levels are traced + +(trace (fact :declarations + ((fact-depth 0)) + :cond + (and (< fact-depth 3) + (setq fact-depth (1+ fact-depth))) + :exit + (progn (setq fact-depth (1- fact-depth)) (cons 'fact values)))) +|# + + + +(defvar *step-level* 0) +(defvar *step-quit* nil) +(defvar *step-function* nil) + +(defvar *old-print-level* nil) +(defvar *old-print-length* nil) + + +(defun step-read-line () + (do ((char (read-char *debug-io*) (read-char *debug-io*))) + ((or (char= char #\Newline) (char= char #\Return))))) + +(defmacro if-error (error-form form) + (let ((v (gensym)) (f (gensym)) (b (gensym))) + `(let (,v ,f) + (block ,b + (unwind-protect (setq ,v ,form ,f t) + (return-from ,b (if ,f ,v ,error-form))))))) + +(defmacro step (form) + `(let* ((*old-print-level* *print-level*) + (*old-print-length* *print-length*) + (*print-level* 2) + (*print-length* 2)) + (read-line) + (format *debug-io* "Type ? and a newline for help.~%") + (setq *step-quit* nil) + (stepper ',form nil))) + +(defun stepper (form &optional env + &aux values (*step-level* *step-level*) indent) + (when (eq *step-quit* t) + (return-from stepper (evalhook form nil nil env))) + (when (numberp *step-quit*) + (if (>= (1+ *step-level*) *step-quit*) + (return-from stepper (evalhook form nil nil env)) + (setq *step-quit* nil))) + (when *step-function* + (if (and (consp form) (eq (car form) *step-function*)) + (let ((*step-function* nil)) + (return-from stepper (stepper form env))) + (return-from stepper (evalhook form #'stepper nil env)))) + (setq *step-level* (1+ *step-level*)) + (setq indent (min (* *step-level* 2) 20)) + (loop + (format *debug-io* "~VT~S " indent form) + (finish-output *debug-io*) + (case (do ((char (read-char *debug-io*) (read-char *debug-io*))) + ((and (char/= char #\Space) (char/= char #\Tab)) char)) + ((#\Newline #\Return) + (setq values + (multiple-value-list + (evalhook form #'stepper nil env))) + (return)) + ((#\n #\N) + (step-read-line) + (setq values + (multiple-value-list + (evalhook form #'stepper nil env))) + (return)) + ((#\s #\S) + (step-read-line) + (setq values + (multiple-value-list + (evalhook form nil nil env))) + (return)) + ((#\p #\P) + (step-read-line) + (write form + :stream *debug-io* + :pretty t :level nil :length nil) + (terpri)) + ((#\f #\F) + (let ((*step-function* + (if-error nil + (prog1 (read-preserving-whitespace *debug-io*) + (step-read-line))))) + (setq values + (multiple-value-list + (evalhook form #'stepper nil env))) + (return))) + ((#\q #\Q) + (step-read-line) + (setq *step-quit* t) + (setq values + (multiple-value-list + (evalhook form nil nil env))) + (return)) + ((#\u #\U) + (step-read-line) + (setq *step-quit* *step-level*) + (setq values + (multiple-value-list + (evalhook form nil nil env))) + (return)) + ((#\e #\E) + (let ((env1 env)) + (dolist (x + (if-error nil + (multiple-value-list + (evalhook + (if-error nil + (prog1 + (read-preserving-whitespace + *debug-io*) + (step-read-line))) + nil nil env1)))) + (write x + :stream *debug-io* + :level *old-print-level* + :length *old-print-length*) + (terpri *debug-io*)))) + ((#\r #\R) + (let ((env1 env)) + (setq values + (if-error nil + (multiple-value-list + (evalhook + (if-error nil + (prog1 + (read-preserving-whitespace + *debug-io*) + (step-read-line))) + nil nil env1))))) + (return)) + ((#\b #\B) + (step-read-line) + (let ((*ihs-base* (1+ *ihs-top*)) + (*ihs-top* (1- (ihs-top))) + (*current-ihs* *ihs-top*)) + (simple-backtrace))) + (t + (step-read-line) + (terpri) + (format *debug-io* + "Stepper commands:~%~ + n (or N or Newline): advances to the next form.~%~ + s (or S): skips the form.~%~ + p (or P): pretty-prints the form.~%~ + f (or F) FUNCTION: skips until the FUNCTION is called.~%~ + q (or Q): quits.~%~ + u (or U): goes up to the enclosing form.~%~ + e (or E) FORM: evaluates the FORM ~ + and prints the value(s).~%~ + r (or R) FORM: evaluates the FORM ~ + and returns the value(s).~%~ + b (or B): prints backtrace.~%~ + ?: prints this.~%") + (terpri)))) + (when (or (constantp form) (and (consp form) (eq (car form) 'quote))) + (return-from stepper (car values))) + (if (endp values) + (format *debug-io* "~V@T=~%" indent) + (do ((l values (cdr l)) + (b t nil)) + ((endp l)) + (if b + (format *debug-io* "~V@T= ~S~%" indent (car l)) + (format *debug-io* "~V@T& ~S~%" indent (car l))))) + (setq *step-level* (- *step-level* 1)) + (values-list values)) + diff --git a/lsp/gprof.hc b/lsp/gprof.hc new file mode 100755 index 0000000..c408fb0 --- /dev/null +++ b/lsp/gprof.hc @@ -0,0 +1,122 @@ +#include +#include +#define CF_FLAG (1 << 31) + +static +/* +mymonitor(low,high,x) + int low,high; + object x; +{ if (0 == x) {monitor(0); return 0;} + if (type_of(x)!=t_string) FEerror("expected string",0); + monitor(low,high,x->ust.ust_self,x->ust.ust_dim,1000); +} +*/ +mymonitor(low,high,x,leng) + int low,high; + object x; +{ if (0 == x) {monitor(0); return 0;} + monitor(low,high,x,leng); +} + + +char *sbrk(); + +static +mymonstartup(low,high) +int low,high; +{char *buf; +buf = sbrk(0); +monstartup(low,high); +return buf; +} + +char *kcl_self; + +#include +#include "../h/ext_sym.h" +#define syment nlist +#define fileheader exec + +static char symname [200]; + + +static +sym_leng_and_copy(ux,copy) + unsigned int ux; + int copy; +{ char *from; + int leng=0; + if (ux & CF_FLAG) + {object x = (object) (ux & ~CF_FLAG); + if (x->cf.cf_name ==0) + from="ZUNDEF"; + else {leng = x->cf.cf_name->s.s_fillp; + from = x->cf.cf_name->s.s_self;}} + else if (ux) + { from= (char *)(ux);} + else {from="UNDEF";} + if (leng==0) leng=strlen(from); + if (leng >= sizeof(symname)) FEerror("Too long symbol",0); + if(copy) bcopy(from,symname,leng); + symname[leng]='0'; + return leng; +} + + + + + + + + +extern char *core_end; + +static +write_outsyms() +{FILE *fdout,*fdin; + static struct syment sym; + struct fileheader hdr; + fdout= fopen("syms.out","w"); + fdin=fopen(kcl_self,"r"); + if (fdin == 0) FEerror("Can't find akcl image",0); + fread(&hdr,sizeof(hdr),1,fdin); + if (fdout == 0) FEerror("Can't open syms.out",0); + fclose(fdin); + sym.n_type= (N_TEXT | N_EXT); + hdr.a_text=sizeof(hdr); + hdr.a_data=0; + hdr.a_bss=0; + hdr.a_trsize=0; + hdr.a_drsize=0; + hdr.a_syms= (1 + combined_table.length)*sizeof (struct syment); + fwrite(&hdr,sizeof(hdr),1,fdout); + fseek(fdout,N_SYMOFF(hdr),0); + {int i=0; int pos=4; + while (i < combined_table.length) + { /* printf("%d %d",i,SYM_STRING(combined_table,i)); + fflush(stdout); */ + + sym.n_un.n_strx = pos; + sym.n_value=SYM_ADDRESS(combined_table,i); + fwrite(&sym,sizeof(sym),1,fdout); + pos=pos+ sym_leng_and_copy(SYM_STRING(combined_table,i),1)+1; +/* printf("%s\n",symname); */ + i++; + } + + sym.n_un.n_strx = pos; + sym.n_value=(int)core_end; + fwrite(&sym,sizeof(sym),1,fdout); + pos=pos+ strlen("_ENDSYM")+1; + + + fwrite(&pos,sizeof(pos),1,fdout); + for (i=0; i< combined_table.length ; i++) + {int leng=sym_leng_and_copy(SYM_STRING(combined_table,i),1); + fwrite(symname,leng,1,fdout); + putc(0,fdout);} + } + fwrite("_ENDSYM",8,1,fdout); + fclose(fdout); +} diff --git a/lsp/gprof1.lisp b/lsp/gprof1.lisp new file mode 100755 index 0000000..a2ae0f7 --- /dev/null +++ b/lsp/gprof1.lisp @@ -0,0 +1,53 @@ +(in-package 'si) + +;; (load "gprof.o") +;; On a sun in sun0S 3 or 4.0 +;; make a modified copy of /lib/gcrt0.o called gcrt0-mod.o +;; then (cd unixport ; make "EXTRAS=../lsp/gcrt0-mod.o") +;; after compiling some .o files with +;; (cd o ; make "CFLAGS = -I../h -pg -g -c") +;; (invoke gprof-setup) +;; and (monitor #x800 3000000) +;; (monitor 0 0) to start and stop respectively +;; on suns the buffersize = (highpc- lowpc)/2 +6 + + +(clines "#include \"gprof.hc\"") + +(defun gprof-setup (&optional (n 800000) (m 1000000)) + (mymonstartup #x800 n) + (set-up-monitor-array m) +(format t" ;; and (monitor #x800 3000000) + ;; (monitor 0 0) to start and stop respectively + ") + nil) + +(defentry mymonstartup (int int) (int "mymonstartup")) +;(defentry monitor1 (int int object) (int "mymonitor")) +(defentry monitor2 (int int int int) (int "mymonitor")) + +(defentry write_outsyms () (int "write_outsyms")) + +(defvar *monitor-array* nil) + +(defun set-up-monitor-array (&optional (n 1000000)) + (unless *monitor-array* (setf *monitor-array* + (make-array n :element-type 'string-char + :static t)) + ;(mymonstartup 0 2000000) + nil + )) + +(defun monitor (low high) + (monitor1 low high *monitor-array*)) + +(defun write-syms.out () + (set-up-combined) + (write_outsyms)) + + + + + + + diff --git a/lsp/gprof_aix.hc b/lsp/gprof_aix.hc new file mode 100755 index 0000000..44a0949 --- /dev/null +++ b/lsp/gprof_aix.hc @@ -0,0 +1,255 @@ +#include +#include +#include +extern struct monglobal _mondata; +static struct desc { /*function descriptor fields*/ + caddr_t begin; /*initial code address*/ + caddr_t toc; /*table of contents address*/ + caddr_t env; /*environment pointer*/ + } ; /*function descriptor structure*/ +static struct desc *fd; /*pointer to function descriptor*/ + +#include "../h/config.h" +#include "../h/ext_sym.h" +#define CF_FLAG (1 << 31) +extern char *kcl_self; + +#define function_address(f) (((struct desc *)(f))->begin) + +mymonitor(low,high,x,leng) + int low,high; + object x; +{ if (0 == x) {monitor(0); return 0;} + monitor(low,high,x,leng); +} + +static int newmonstartup(); + +mymonstartup(low,high) +caddr_t low,high; +{ +/* static struct frag f[3]; + + f[0].p_low = function_address(&__start); + f[0].p_high = function_address(&init_cmpwt); + f[1].p_low = low; + f[1].p_high = high; + f[2].p_low = 0; + f[3].p_high = 0; + newmonstartup(-1,f); +*/ + _mondata.prof_type = _PROF_TYPE_IS_PG; + return monstartup(low,high); +} + + +/* +symbol table address + &__start == the real address +[if the ld is done with -T0 ] +*/ + + /* +The format of symbol table entries. +[144] m 0x0001486c .text 2 extern void() .Foo +[145] a2 0 60 188239 152 + + */ +/* the monstartup code in aix3.1 is broken: */ + + + + +static size1(f) + struct frag *f; +{ int range; + int fromsize; + int total = 0; + int tonum; + while (f->p_high) + {range = f->p_high - f->p_low; + fromsize = FROM_STG_SIZE(range); + tonum = TO_NUM_ELEMENTS(range); + if ( tonum < MINARCS ) tonum = MINARCS; + else + if ( tonum > TO_MAX-1 ) tonum = TO_MAX-1; + tonum = tonum * sizeof( struct tostruct ); + total += fromsize + tonum + sizeof(struct gfctl); + f++; + } + return total; +} + +static int +newmonstartup(a,f) + struct frag *f; +{struct prof *pb = malloc(3*sizeof(struct prof)); + struct frag *ff =f; + int i = 0 ; + int nranges = 0; + int total = 0; + int range; + caddr_t buffer ; + int callcntsize; + bzero(pb,3*sizeof(struct prof)); + + while(ff->p_high) + { + pb[i].p_high = (caddr_t) ROUNDUP((int)f[i].p_high, INST_CNT_SIZE); + pb[i].p_low = (caddr_t) ROUNDDOWN((int)f[i].p_low, INST_CNT_SIZE); + range = pb[i].p_high - pb[i].p_low; + total += HIST_STG_SIZE(range); + ff++; + i++; + } + nranges = i; + callcntsize = size1(f); + total += callcntsize; + + buffer = (caddr_t) malloc(total); + + + _mondata.monstubuf = buffer; + + for (i=0; i < nranges; i++) + {pb[i].p_buff = (HISTCOUNTER *)buffer; + pb[i].p_scale = HIST_SCALE_1_TO_1; + pb[i].p_bufsize = HIST_NUM_COUNTERS(pb[i].p_high-pb[i].p_low); + if (i == 0) { + pb[i].p_bufsize += + (((callcntsize + HIST_COUNTER_SIZE -1)/HIST_COUNTER_SIZE) + ); + } + buffer += pb[i].p_bufsize * HIST_COUNTER_SIZE; + + } + monitor(1,1,pb,-1, callcntsize); +} + + + + + + + + + + + + + + +static char symname [200]; + +static +sym_leng_and_copy(ux,copy) + unsigned int ux; + int copy; +{ char *from; + int leng=0; + if (ux & CF_FLAG) + {object x = (object) (ux & ~CF_FLAG); + if (x->cf.cf_name ==0) + from="ZUNDEF"; + else {leng = x->cf.cf_name->s.s_fillp; + from = x->cf.cf_name->s.s_self;}} + else if (ux) + { from= (char *)(ux);} + else {from="UNDEF";} + if (leng==0) leng=strlen(from); + if (leng >= sizeof(symname)) FEerror("Too long symbol",0); + if(copy) bcopy(from,symname,leng); + symname[leng]='0'; + return leng; +} + + + +extern char * __start; +extern char *core_end; +extern int bzero(); + +static +write_outsyms() +{FILE *fdout,*fdin; + static struct syment sym; + static struct syment symaux; + struct filehdr Eheader; + struct aouthdr header; + struct scnhdr shdrs[15]; + fdout= fopen("syms.out","w"); + fdin=fopen(kcl_self,"r"); + if (fdin == 0) FEerror("Can't find akcl image"); + fread(&Eheader,1,sizeof(Eheader), fdin); + fread(&header,1,Eheader.f_opthdr,fdin); + fclose(fdin); + if (fdout == 0) FEerror("Can't open syms.out"); + Eheader.f_nscns = 2; + Eheader.f_symptr = sizeof(Eheader) + sizeof(header) + + Eheader.f_nscns*sizeof(struct scnhdr); + Eheader.f_nsyms = 2*(1+ combined_table.length); + bzero(&shdrs[0],10*sizeof(struct scnhdr)); + bzero(&symaux,1*SYMESZ); + bzero(&sym,1*SYMESZ); + + header.tsize=0; + header.dsize=0; + header.bsize=0; + header.o_snentry=1; + header.o_sntext=1; + header.o_sndata=1; + header.o_sntoc=1; + header.o_snbss=1; + header.o_snloader=2; + + + fwrite(&Eheader,1,sizeof(Eheader), fdout); + fwrite(&header,1,Eheader.f_opthdr,fdout); + fwrite(&shdrs[1],Eheader.f_nscns,sizeof(struct scnhdr),fdout); + fseek(fdout,Eheader.f_symptr,0); + + sym.n_scnum == header.o_sntext; + sym.n_sclass = 0x2 ; + sym.n_type = 0x20; + sym.n_numaux = 1; + printf("(&__start = 0x%x)",function_address(&__start)); + {int i=0; int pos=4; + while (i < combined_table.length) + { unsigned int adr = (unsigned int)(SYM_ADDRESS(combined_table,i)); + /* printf("%d %d",i,SYM_STRING(combined_table,i)); + fflush(stdout); */ + + sym.n_offset = pos; + + sym.n_value= + (adr > 0x20000000 ? + (unsigned int) function_address(SYM_ADDRESS(combined_table,i)) + - 0x10000e00 + : adr - 0x10000e00); +/* printf("\n %d %s 0x%x %x ",i,SYM_STRING(combined_table,i), adr, adr); */ + fwrite(&sym,SYMESZ,1,fdout); + fwrite(&symaux,SYMESZ,1,fdout); + pos=pos+ sym_leng_and_copy(SYM_STRING(combined_table,i),1)+1; +/* printf("%s\n",symname); */ + i++; + } + + sym.n_offset = pos; + sym.n_value=(int)core_end - (int) & __start; + fwrite(&sym,SYMESZ,1,fdout); + fwrite(&symaux,SYMESZ,1,fdout); + pos=pos+ strlen("_ENDSYM")+1; + + + fwrite(&pos,sizeof(pos),1,fdout); + printf("(at %d)",ftell(fdout)); + for (i=0; i< combined_table.length ; i++) + {int leng=sym_leng_and_copy(SYM_STRING(combined_table,i),1); + fwrite(symname,leng,1,fdout); + putc(0,fdout);} + } + fwrite("_ENDSYM",8,1,fdout); + fclose(fdout); +} + + + diff --git a/lsp/make.lisp b/lsp/make.lisp new file mode 100755 index 0000000..7a4cb69 --- /dev/null +++ b/lsp/make.lisp @@ -0,0 +1,409 @@ +;;; -*- Mode: Lisp; Package: MAKE; Syntax: Common-Lisp; Base: 10 -*- ;;;; +;; Copyright William F. Schelter 1989. + +;; The author expressly permits copying and alteration of this file, +;; provided any modifications are clearly labeled, and this notice is +;; preserved. The author provides no warranty and this software is +;; provided on an 'as is' basis. +(in-package "MAKE" :use '("LISP") #+gcl :external #+gcl 11 + #+gcl :internal #+gcl 79) + +(export '(make system-load system-compile)) +(provide "MAKE") +;;; ******* Description of Make Facility ************ +;; We provide a simple MAKE facility to allow +;;compiling and loading of a tree of files +;;If the tree is '(a b (d e g h) i) +;; a will be loaded before b is compiled, +;; b will be loaded before d, e, g, h are compiled +;; d e g h will be loaded before i is compiled. + +;; A record is kept of write dates of loaded compiled files, and a file +;;won't be reloaded if it is the same version (unless a force flag is t). + +;;Thus if you do (make :uinfor) twice in a row, the second one would not +;;load anything. NOTE: If you change a, and a macro in it would affect +;;b, b still will not be recompiled. You must choose the :recompile t +;;option, to force the recompiling if you change macro files. +;;Alternately you may specify dependency information (see :depends below). + + +;;****** Sample file which when loaded causes system ALGEBRA +;; to be compiled and loaded ****** + +;;(require "MAKE") +;;(use-package "MAKE") +;;(setf (get :algebra :make) '(a b (d e) l)) +;;(setf (get :algebra :source-path) "/usr2/wfs/algebra/foo.lisp") +;;(setf (get :algebra :object-path) "/usr2/wfs/algebra/o/foo.o") +;;(make :algebra :compile t) + +;; More complex systems may need to do some special operations +;;at certain points of the make. +;;the tree of files may contain some keywords which have special meaning. +;;eg. '(a b (:progn (gbc) (if make::*compile* +;; (format t "A and B finally compiled"))) +;; (:load-source h i) +;; (d e) l) + +;;then during the load and compile phases the function (gbc) will be +;;called after a and b have been acted on, and during the compile phase +;;the message about "A and B finally.." will be printed. +;;the lisp files h and i will be loaded after merging the paths with +;;the source directory. This feature is extensible: see the definitions +;;of :load-source and :progn. + +;; The keyword feature is extensible, and you may specify what +;;happens during the load or compile phase for your favorite keyword. +;;To do this look at the definition of :progn, and :load-source +;;in the source for make. + + +;;Dependency feature: + +;; This make NEVER loads or compiles files in an order different from +;;that specified by the tree. It will omit loading files which are +;;loaded and up to date, but if two files are out of date, the first (in +;;the printed representation of the tree), will always be loaded before +;;the second. A consequence of this is that circular dependencies can +;;never occur. +;; +;; If the :make tree contains (a b c d (:depends (c d) (a b))) then c +;;and d depend on a and b, so that if a or b need recompilation then c +;;and d will also be recompiled. Thus the general form of a :depends +;;clause is (:depends later earlier) where LATER and EARLIER are either +;;a single file or a list of files. Read it as LATER depends on EARLIER. +;;A declaration of a (:depends (c) (d)) would have no effect, since the +;;order in the tree already rules out such a dependence. + +;; An easy way of specifying a linear dependence is by using :serial. +;;The tree (a (:serial b c d) e) is completely equivalent to the tree +;;(a b c d e (:depends c b)(:depends d (b c))), but with a long list of +;;serial files, it is inconvenient to specify them in the +;;latter representation. + +;;A common case is a set of macros whose dependence is serial followed by a set +;;of files whose order is unimportant. A conventient way of building that +;;tree is +;; +;;(let ((macros '(a b c d)) +;; (files '(c d e f g))) +;; `((:serial ,@ macros) +;; ,files +;; (:depends ,files ,macros))) + +;; The depends clause may occur anywhere within the tree, since +;;an initial pass collects all dependency information. + +;; Make takes a SHOW keyword argument. It is almost impossible to simulate +;;all the possible features of make, for show. Nonetheless, it is good +;;to get an idea of the compiling and loading sequence for a new system. +;;As a byproduct, you could use the output, as a simple sequence of calls +;;to compile-file and load, to do the required work, when make is not around +;;to help. + + +;;***** Definitions ******** +(defvar *files-loaded* nil) +(defvar *show-files-loaded* nil) ;only for show option +(defvar *load* nil "Will be non nil inside load-files") +(defvar *compile* nil "Bound by compile-files to t") +(defvar *depends* nil) +(defvar *depends-new* nil) +(defvar *force* nil) +(defvar *when-compile* nil "Each compile-file evals things in this list and sets it to nil") +#+kcl(defvar *system-p* nil) +(defvar *compile-file-function* 'make-compile-file) +(defvar *load-function* 'make-load-file) +(defvar show nil) +(defvar *cflags* #-kcl nil + #+kcl '(:system-p *system-p*)) + + +;;this is the main entry point + +(defun make (system &key recompile compile batch object-path source-path + show proclaims + &aux files *depends* *when-compile* + *show-files-loaded* + #+gcl (*load-fn-too* proclaims) + + ) + + "SYSTEM is a tree of files, or a symbol with :make property. It +loads all file files in system. If COMPILE it will try to compile +files with newer source versions than object versions, before loading. +If RECOMPILE it will recompile all files. This is equivalent to deleting all +objects and using :compile t. SOURCE-PATH is merged with the name given +in the files list, when looking for a file to compile. OBJECT-PATH is +merged with the name in the files list, when looking for a file to +load. If SYSTEM is a symbol, then a null OBJECT-PATH would be set to +the :object-path property of SYSTEM. Similarly for :source-path" + + (declare (special object-path source-path show)) batch + (cond ((symbolp system) + (or object-path (setf object-path (get system :object-path))) + (or source-path (setf source-path (get system :source-path))) + (setf files (get system :make)) + (or files + (if (get system :files) + (error "Use :make property, :files property is obssolet{!"))) + ) + (t (setf files system))) + #+gcl (when proclaims (compiler::emit-fn t) (compiler::setup-sys-proclaims)) + (let (#+lispm ( si::inhibit-fdefine-warnings + (if batch :just-warn si::inhibit-fdefine-warnings))) + (let ((*depends* (if (or compile recompile) (get-depends system))) + *depends-new*) + (dolist (v files) + (when (or compile recompile) + (compile-files v recompile)) + (load-files v recompile))) + #+gcl + (if proclaims (compiler::write-sys-proclaims)) + )) + +(defun system-load (system-name &rest names) + "If :infor is a system, (system-load :uinfor joe betty) will load +joe and betty from the object-path for :uinfor" + (load-files names t (get system-name :object-path))) + +(defun system-compile (system-name &rest names) + + "If :iunfor is a system, (system-compile :uinfor joe) will in the +source path for joe and compile him into the object path for :uinfor" + (compile-files names t :source-path + (get system-name :source-path) :object-path + (get system-name :object-path))) + +(defun get-depends (system-name &aux result) + (dolist (v (get system-name :make)) + (cond ((atom v) ) + ((eq (car v) :serial) + (do ((w (reverse (cdr v))(cdr w))) + ((null (cdr w))) + (push (list (car w) (cdr w)) result))) + ((eq (car v) :depends) + (push (cdr v) result )))) + result) + +#+kcl +(setq si::*default-time-zone* 6) +#+winnt +(setq SYSTEM:*DEFAULT-TIME-ZONE* (GET-SYSTEM-TIME-ZONE)) + +(defun print-date (&optional(stream *standard-output*) + (time (get-universal-time))) + (multiple-value-bind (sec min hr day mon yr wkday) + (decode-universal-time time) + (format stream "~a ~a ~a ~d:~2,'0d:~2,'0d ~a" + (nth wkday '( "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun")) + (nth (1- mon) '("Jan" "Feb" "Mar" "Apr" "May" "Jun" + "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")) + day + hr min sec yr))) + +;;This is an awfully roundabout downcase, but some machines +;;like symbolics swap cases on the pathname, so we have to do an extra +;;swap!! +(defun lowcase (na &aux (*print-case* :downcase)) + (pathname-name (pathname (format nil "~a" na)))) + +(defun our-merge (name path &optional ign ) ign + #+lispm (setq name (string-upcase (string name))) + (make-pathname :name (string name) + :type (pathname-type path) + :version (pathname-version path) + :host (pathname-host path) + :directory (pathname-directory path))) + + +#+kcl +(setf (get :link 'load) + #'(lambda (path to-link) + (declare (special object-path)) + (si::faslink (our-merge (lowcase path) object-path) + to-link))) + +(setf (get :link 'compile) + #'(lambda (path to-link) + to-link + (compile-files path *force*))) + +(setf (get :progn 'load) + #'(lambda (&rest args) + (eval (cons 'progn args)))) + +(setf (get :progn 'compile) (get :progn 'load)) + +(setf (get :load-source 'load) + #'(lambda (&rest args) + (declare (special source-path)) + (load-files args *force* source-path))) + +(setf (get :load-source-when-compile 'compile) + (get :load-source 'load)) + +;;should nott use :lisp anymore +(setf (get :lisp 'load) + #'(lambda (x) (error "please replace :lisp by :load-source"))) + +(setf (get :serial 'load) #'(lambda (&rest l)(load-files l))) +(setf (get :serial 'compile) + #'(lambda (&rest l) + (dolist (v l) + (compile-files v) + (load-files v)))) + + +(defun load-files (files &optional (*force* *force*) (object-path object-path) + &aux path tem (*load* t)) + (declare (special object-path source-path *force* show)) + (cond ((atom files) + (setq path (object files)) + (cond (show + (unless (member path *show-files-loaded* :test 'equalp) + (push path *show-files-loaded*) + (format t "~%(LOAD ~s)" (namestring path)))) + ((null *load-function*)) + ((or *force* + (or (not (setq tem + (member path *files-loaded* + :test 'equalp :key 'car))) + (> (file-write-date path) (cdr (car tem))))) + (funcall *load-function* files) + (push (cons path (file-write-date path)) *files-loaded*)))) + ((keywordp (car files)) + (let ((fun (get (car files) 'load))) + (cond (fun (apply fun (cdr files)))))) + (t (dolist (v files) (load-files v *force* object-path))))) + + +(defun file-date (file) + (if (probe-file file) (or (file-write-date file) 0) 0)) + +(defun source (file) + (declare (special source-path)) + (our-merge (lowcase file) source-path)) + +(defun object (file) + (declare (special object-path)) + (our-merge (lowcase file) object-path)) + + +;;for lisp machines, and others where checking date is slow, this +;;we should try to cache some dates, and then remove them as we do +;;things like compile files... + +(defun file-out-dated (file) + (let ((obj-date (file-date (object file)))) + (or (<= obj-date (file-date (source file))) + (dolist (v *depends*) + (cond ((or (and (consp (car v)) + (member file (car v))) + (eq (car v) file)) + (dolist (w (if (consp (second v)) + (second v) (cdr v))) + (cond ((or (<= obj-date (file-date (source w))) + (member w *depends-new*)) + (return-from file-out-dated t)))))))))) + + +(defun make-compile-file ( l) + (format t "~&Begin compile ~a at ~a~%" l (print-date nil)) + (dolist (v *when-compile*) (eval v)) + (setq *when-compile* nil) + ;;Franz excl needs pathnames quoted, and some other lisp + ;;would not allow an apply here. Sad. + (eval `(compile-file ',(source l) :output-file ',(object l) + ,@ *cflags*)) + (format t "~&End compile ~a at ~a~%" l (print-date nil)) + + ) + +(defvar *load-fn-too* nil) +(defun make-load-file (l) + (let ((na (object l))) + (load na) + (if (and *load-fn-too* + (probe-file + (setq na + (our-merge (lowcase l) (merge-pathnames "foo.fn" na))))) + (load na)) + + + )) + +;;these are versions which don't really compile or load files, but +;;do create a new "compiled file" and "fake load" to test date mechanism. +#+debug +(defun make-compile-file (file) + (format t "~%Fake Compile ~a" (namestring (source file))) + (dolist (v *when-compile*) (eval v)) (setq *when-compile* nil) + (with-open-file (st (object file) :direction :output) + (format st "(print (list 'hi))"))) +#+debug +(defun make-load-file (l) + (format t "~%Fake loading ~a" (namestring(object l)))) + + + + +(defun compile-files (files &optional (*force* *force*) + &key (source-path source-path) + (object-path object-path) + &aux + (*compile* t) ) + (declare (special object-path source-path *force* show)) + (cond ((atom files) + (when (or *force* (file-out-dated files)) + (push files *depends-new*) + (cond + (show + (format t "~%(COMPILE-FILE ~s)" (namestring (source files)))) + (t + (and *compile-file-function* + (funcall *compile-file-function* files)) + )))) + ((keywordp (car files)) + (let ((fun (get (car files) 'compile))) + (if fun (apply fun (cdr files))))) + (t (dolist (v files) (compile-files v *force*))))) + +;;Return the files for SYSTEM + +(defun system-files (system &aux *files*) + (declare (special *files*)) + (let ((sys (get system :make))) + (get-files1 sys)) + (nreverse *files*)) + + +(defun get-files1 (sys) + (declare (special *files*)) + (cond ((and sys (atom sys) )(pushnew sys *files*)) + ((eq (car sys) :serial) (get-files1 (cdr sys))) + ((keywordp (car sys))) + (t (dolist (v sys) (get-files1 v))))) + + +(defmacro make-user-init (files &aux (object-path + (if (boundp 'object-path) object-path + "foo.o"))) + (declare (special object-path)) + `(progn + (clines "void gcl_init_or_load1 (); +#define init_or_load(fn,file) do {extern int fn(); gcl_init_or_load1(fn,file);} while(0) + +user_init{") ,@ + (sloop::sloop for x in files + for f = (substitute #\- #\_ (lowcase x)) + for ff = (namestring (truename (object x))) + collect + `(clines ,(Format nil "init_or_load(init_~a,\"~a\");" f ff))) + (clines "}"))) + + + + + diff --git a/lsp/makefile b/lsp/makefile new file mode 100644 index 0000000..2e94ae1 --- /dev/null +++ b/lsp/makefile @@ -0,0 +1,59 @@ + +.SUFFIXES: +.SUFFIXES: .fn .o .c .lsp + +-include ../makedefs + + +PORTDIR = ../unixport +CAT=cat +APPEND=../xbin/append + +OBJS = gcl_sharp.o gcl_arraylib.o gcl_assert.o gcl_defmacro.o gcl_defstruct.o \ + gcl_describe.o gcl_evalmacros.o gcl_fpe.o \ + gcl_iolib.o gcl_listlib.o gcl_mislib.o gcl_module.o gcl_numlib.o \ + gcl_packlib.o gcl_predlib.o \ + gcl_seq.o gcl_seqlib.o gcl_setf.o gcl_top.o gcl_trace.o gcl_sloop.o \ + gcl_debug.o gcl_info.o gcl_serror.o gcl_restart.o \ + gcl_destructuring_bind.o gcl_defpackage.o gcl_make_defpackage.o gcl_loop.o $(EXTRA_LOBJS) +# export.o autoload.o auto_new.o + +LISP=$(PORTDIR)/saved_pre_gcl$(EXE) +COMPILE_FILE=$(LISP) $(PORTDIR) -system-p -c-file -data-file -h-file -compile + +%.o: $(PORTDIR)/saved_pre_gcl$(EXE) %.lsp + $(COMPILE_FILE) $* + +all: $(OBJS) #$(RL_OBJS) + +.lsp.fn: ../cmpnew/gcl_collectfn.o + ../xbin/make-fn $*.lsp $(LISP) + +all: $(OBJS) + +fns1: $(FNS) + +fns: ../cmpnew/gcl_collectfn.o + $(MAKE) fns1 -e "FNS=`echo ${OBJS} | sed -e 's:\.o:\.fn:g'`" + +#../cmpnew/gcl_collectfn.o: ../cmpnew/gcl_collectfn.lsp +# (cd ../cmpnew ; $(PORTDIR)/saved_gcl $(PORTDIR)/ gcl_collectfn.lisp gcl_collectfn S1000) + + +clean: + rm -f *.o core a.out *.fn *.c *.data *.h +allclean: + rm -f *.h *.data *.c + +dummy3 $(NEWCFILES): sys-proclaim.lisp + +sys-proclaim.lisp: fns + echo '(in-package "SYSTEM")' \ + '(load "../cmpnew/gcl_collectfn")'\ + '(compiler::make-all-proclaims "*.fn")' | ../xbin/gcl + + +newc: + $(MAKE) $(OBJS) -e "NEWCFILES=`echo $(OBJS) | sed -e 's:\.o:.c:g'`" + + diff --git a/lsp/sys-proclaim.lisp b/lsp/sys-proclaim.lisp new file mode 100755 index 0000000..6019877 --- /dev/null +++ b/lsp/sys-proclaim.lisp @@ -0,0 +1,294 @@ + +(IN-PACKAGE "SYSTEM") +(MAPC (LAMBDA (COMPILER::X) + (SETF (GET COMPILER::X 'PROCLAIMED-CLOSURE) T)) + '(SI-CLASS-PRECEDENCE-LIST BREAK-ON-FLOATING-POINT-EXCEPTIONS + SI-FIND-CLASS AUTOLOAD SI-CLASS-NAME TRACE-ONE SI-CLASSP + SIMPLE-CONDITION-CLASS-P CONDITIONP MAKE-ACCESS-FUNCTION + UNTRACE-ONE WARNINGP DEFINE-STRUCTURE CONDITION-CLASS-P + SI-CLASS-OF AUTOLOAD-MACRO)) +(PROCLAIM '(FTYPE (FUNCTION (T) (VALUES T T)) LISP::MAKE-KEYWORD)) +(PROCLAIM + '(FTYPE (FUNCTION (T) T) S-DATA-HAS-HOLES CONSTANTLY + COMPUTING-ARGS-P ANSI-LOOP::LOOP-PATH-PREPOSITION-GROUPS + ANSI-LOOP::LOOP-COLLECTOR-NAME FIRST INSPECT-SYMBOL + CONTEXT-P ANSI-LOOP::LOOP-MAKE-PSETQ TENTH + COMPILER-MACRO-FUNCTION ANSI-LOOP::LOOP-COLLECTOR-DATA + ARRAY-DIMENSIONS ASINH FPE::XMM-LOOKUP KNOWN-TYPE-P + CONTEXT-VEC CONTEXT-HASH SHOW-ENVIRONMENT + CHECK-DECLARATIONS BKPT-FILE-LINE PROVIDE + ANSI-LOOP::LOOP-PATH-P DWIM RESTART-P FPE::LOOKUP ACOSH + PRINT-SYMBOL-APROPOS SIGNUM ANSI-LOOP::LOOP-UNIVERSE-ANSI + IHS-NOT-INTERPRETED-ENV BYTE-SIZE THIRD RESTART-FUNCTION + ANSI-LOOP::LOOP-UNIVERSE-TYPE-KEYWORDS DO-F + ANSI-LOOP::LOOP-EMIT-BODY COSH S-DATA-CONC-NAME + INSTREAM-STREAM-NAME PATCH-SHARP INSPECT-STRING + S-DATA-INCLUDES SHOW-BREAK-POINT FPE::GREF + FIND-KCL-TOP-RESTART RESTART-REPORT-FUNCTION S-DATA-NAMED + S-DATA-CONSTRUCTORS S-DATA-P SLOOP::PARSE-LOOP + INSPECT-STRUCTURE BKPT-FORM PHASE SETUP-INFO + ANSI-LOOP::LOOP-UNIVERSE-TYPE-SYMBOLS + RESET-TRACE-DECLARATIONS SLOOP::SLOOP-SLOOP-MACRO EIGHTH + SECOND SLOOP::TRANSLATE-NAME + ANSI-LOOP::LOOP-MINIMAX-FLAG-VARIABLE NINTH + ANSI-LOOP::LOOP-COLLECTOR-P MAKE-KCL-TOP-RESTART + SEARCH-STACK ANSI-LOOP::LOOP-COLLECTOR-DTYPE ACOS + ANSI-LOOP::LOOP-MAXMIN-COLLECTION MAKE-DEFPACKAGE-FORM + INSPECT-NUMBER SINH ANSI-LOOP::LOOP-HACK-ITERATION + INSTREAM-STREAM WALK-THROUGH PRINT-IHS SIXTH S-DATA-FROZEN + INSPECT-CHARACTER SLOOP::RETURN-SLOOP-MACRO + FREEZE-DEFSTRUCT NEXT-STACK-FRAME + SLOOP::LOOP-COLLECT-KEYWORD-P DM-BAD-KEY + COMPILE-FILE-PATHNAME SEVENTH + ANSI-LOOP::LOOP-CODE-DUPLICATION-THRESHOLD + SLOOP::PARSE-LOOP-INITIALLY TERMINAL-INTERRUPT + ANSI-LOOP::LOOP-EMIT-FINAL-VALUE FRS-KIND CHECK-TRACE-SPEC + CONTEXT-SPICE ANSI-LOOP::DESTRUCTURING-SIZE + ANSI-LOOP::LOOP-MINIMAX-OPERATIONS INSPECT-VECTOR ATANH + ANSI-LOOP::LOOP-PATH-NAMES S-DATA-OFFSET + SLOOP::REPEAT-SLOOP-MACRO FIND-ALL-SYMBOLS + ANSI-LOOP::LOOP-PATH-FUNCTION REWRITE-RESTART-CASE-CLAUSE + ANSI-LOOP::LOOP-COLLECTOR-CLASS + RESTART-INTERACTIVE-FUNCTION DM-KEY-NOT-ALLOWED + INSPECT-PACKAGE S-DATA-PRINT-FUNCTION NODE-OFFSET + RESTART-NAME RATIONAL NORMALIZE-TYPE + SLOOP::SUBSTITUTE-SLOOP-BODY FIFTH INFO-GET-TAGS S-DATA-RAW + RE-QUOTE-STRING SHORT-NAME LOGNOT INSPECT-ARRAY + TRACE-ONE-PREPROCESS SIMPLE-ARRAY-P FIND-DOCUMENTATION + BKPT-FUNCTION ANSI-LOOP::LOOP-PATH-USER-DATA EVAL-FEATURE + ANSI-LOOP::LOOP-MINIMAX-INFINITY-DATA ABS S-DATA-STATICP + ANSI-LOOP::LOOP-MINIMAX-TEMP-VARIABLE INSERT-BREAK-POINT + S-DATA-DOCUMENTATION PRINT-FRS IHS-VISIBLE GET-INSTREAM + INFO-GET-FILE GET-NEXT-VISIBLE-FUN DBL-EVAL FOURTH + ANSI-LOOP::LOOP-COLLECTOR-HISTORY BYTE-POSITION + ANSI-LOOP::LOOP-TYPED-INIT ASIN + ANSI-LOOP::LOOP-COLLECTOR-TEMPVARS FIX-LOAD-PATH BKPT-FILE + VECTOR-POP IDESCRIBE UNIQUE-ID + ANSI-LOOP::LOOP-UNIVERSE-ITERATION-KEYWORDS + ANSI-LOOP::LOOP-UNIVERSE-IMPLICIT-FOR-REQUIRED + SLOOP::POINTER-FOR-COLLECT FPE::ST-LOOKUP + ANSI-LOOP::LOOP-CONSTANTP ANSI-LOOP::LOOP-UNIVERSE-KEYWORDS + ADD-TO-HOTLIST ANSI-LOOP::LOOP-DO-THEREIS + ANSI-LOOP::LOOP-LIST-COLLECTION S-DATA-TYPE + SLOOP::LOOP-LET-BINDINGS + ANSI-LOOP::LOOP-PATH-INCLUSIVE-PERMITTED + BREAK-FORWARD-SEARCH-STACK ISQRT S-DATA-SLOT-POSITION + BREAK-BACKWARD-SEARCH-STACK + ANSI-LOOP::MAKE-ANSI-LOOP-UNIVERSE RESTART-TEST-FUNCTION + INVOKE-DEBUGGER SLOOP::PARSE-NO-BODY + ANSI-LOOP::LOOP-MAKE-DESETQ + ANSI-LOOP::LOOP-CONSTRUCT-RETURN COMPLEMENT + ANSI-LOOP::LOOP-UNIVERSE-FOR-KEYWORDS TANH INSTREAM-P + NODES-FROM-INDEX ANSI-LOOP::LOOP-PSEUDO-BODY + S-DATA-INCLUDED ANSI-LOOP::LOOP-MINIMAX-TYPE + NUMBER-OF-DAYS-FROM-1900 INFO-NODE-FROM-POSITION + ANSI-LOOP::LOOP-MINIMAX-ANSWER-VARIABLE + ANSI-LOOP::LOOP-MINIMAX-P BEST-ARRAY-ELEMENT-TYPE + S-DATA-NAME SLOOP::AVERAGING-SLOOP-MACRO + ANSI-LOOP::LOOP-UNIVERSE-PATH-KEYWORDS CIS SEQTYPE + LEAP-YEAR-P GET-BYTE-STREAM-NCHARS IHS-FNAME + ANSI-LOOP::LOOP-UNIVERSE-P INSPECT-CONS + S-DATA-SLOT-DESCRIPTIONS)) +(PROCLAIM + '(FTYPE (FUNCTION (*) *) INFO-ERROR BREAK-PREVIOUS BREAK-NEXT + CONTINUE BREAK-LOCAL SHOW-BREAK-VARIABLES BREAK-BDS + MUFFLE-WARNING DBL-BACKTRACE ANSI-LOOP::LOOP-OPTIONAL-TYPE + IHS-BACKTRACE BREAK-QUIT BREAK-VS)) +(PROCLAIM + '(FTYPE (FUNCTION (FIXNUM) FIXNUM) FPE::FE-ENABLE DBL-WHAT-FRAME)) +(PROCLAIM + '(FTYPE (FUNCTION (T) FIXNUM) INSTREAM-LINE FPE::REG-LOOKUP + S-DATA-SIZE S-DATA-LENGTH THE-START)) +(PROCLAIM '(FTYPE (FUNCTION (FIXNUM) T) PUSH-CONTEXT GET-CONTEXT)) +(PROCLAIM '(FTYPE (FUNCTION (STRING FIXNUM) FIXNUM) ATOI)) +(PROCLAIM + '(FTYPE (FUNCTION (*) T) ANSI-LOOP::MAKE-STANDARD-LOOP-UNIVERSE + MAYBE-CLEAR-INPUT ANSI-LOOP::MAKE-LOOP-MINIMAX-INTERNAL + DRIBBLE ANSI-LOOP::MAKE-LOOP-COLLECTOR + ANSI-LOOP::MAKE-LOOP-UNIVERSE Y-OR-N-P COMPUTE-RESTARTS + DESCRIBE-ENVIRONMENT TRANSFORM-KEYWORDS + SLOOP::PARSE-LOOP-DECLARE MAKE-RESTART MAKE-INSTREAM + ANSI-LOOP::LOOP-GENTEMP DBL-READ LOC CURRENT-STEP-FUN + VECTOR YES-OR-NO-P BREAK + ANSI-LOOP::LOOP-DISALLOW-CONDITIONAL STEP-INTO MAKE-CONTEXT + ANSI-LOOP::MAKE-LOOP-PATH MAKE-S-DATA BREAK-LOCALS ABORT + SLOOP::PARSE-LOOP-WITH STEP-NEXT)) +(PROCLAIM + '(FTYPE (FUNCTION (T) *) PRINC-TO-STRING GET-&ENVIRONMENT DESCRIBE + INSPECT ANSI-LOOP::NAMED-VARIABLE WAITING + ANSI-LOOP::LOOP-OPTIMIZATION-QUANTITIES PRIN1-TO-STRING + BREAK-LEVEL-INVOKE-RESTART END-WAITING + ANSI-LOOP::LOOP-LIST-STEP ALOAD INSTREAM-NAME + INVOKE-RESTART-INTERACTIVELY FIND-DECLARATIONS BREAK-GO + INSPECT-OBJECT INFO-SUBFILE)) +(PROCLAIM '(FTYPE (FUNCTION (T FIXNUM T T) T) BIGNTHCDR)) +(PROCLAIM '(FTYPE (FUNCTION (T FIXNUM FIXNUM T T) T) QUICK-SORT)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T) *) SHARP-S-READER SHARP---READER + ANSI-LOOP::LOOP-GET-COLLECTION-INFO SHARP-+-READER + LIST-MERGE-SORT LISP::VERIFY-KEYWORDS READ-INSPECT-COMMAND + RESTART-PRINT)) +(PROCLAIM + '(FTYPE (FUNCTION (T T *) *) REDUCE SUBTYPEP SORT + SLOOP::FIND-IN-ORDERED-LIST STABLE-SORT LISP::PARSE-BODY)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T *) *) LISP::PARSE-DEFMACRO-LAMBDA-LIST + LISP::PARSE-DEFMACRO)) +(PROCLAIM '(FTYPE (FUNCTION (T T T *) *) MASET)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T T T T) *) LISP::PUSH-OPTIONAL-BINDING)) +(PROCLAIM + '(FTYPE (FUNCTION (T *) *) DECODE-UNIVERSAL-TIME STEPPER USE-VALUE + FROUND INFO SHOW-INFO INVOKE-RESTART FCEILING + PARSE-BODY-HEADER ENSURE-DIRECTORIES-EXIST PRINT-DOC + APROPOS-DOC WRITE-TO-STRING FFLOOR NLOAD BREAK-FUNCTION + REQUIRE APROPOS GET-SETF-METHOD APROPOS-LIST + ANSI-LOOP::LOOP-CONSTANT-FOLD-IF-POSSIBLE STORE-VALUE + GET-SETF-METHOD-MULTIPLE-VALUE READ-FROM-STRING + WILD-PATHNAME-P FTRUNCATE)) +(PROCLAIM + '(FTYPE (FUNCTION (T T) T) QUOTATION-READER + SLOOP::IN-PACKAGE-SLOOP-MAP SLOOP::NEVER-SLOOP-COLLECT + MATCH-DIMENSIONS OBJLT ANSI-LOOP::LOOP-TEQUAL DBL-UP + GET-INFO-CHOICES NTHCDR ANSI-LOOP::LOOP-DECLARE-VARIABLE + ANSI-LOOP::MAKE-LOOP-MINIMAX LDB + OVERWRITE-SLOT-DESCRIPTIONS GET-LINE-OF-FORM DOCUMENTATION + DM-NTH ANSI-LOOP::LOOP-LOOKUP-KEYWORD DM-NTH-CDR + SLOOP::=-SLOOP-FOR LIST-DELQ SET-DIR LOGANDC2 + SLOOP::IN-FRINGE-SLOOP-MAP DISPLAY-COMPILED-ENV SET-BACK + SLOOP::LOGXOR-SLOOP-COLLECT LEFT-PARENTHESIS-READER + ANSI-LOOP::LOOP-DO-IF FPE::%-READER LDB-TEST + COMPILER::COMPILER-DEF-HOOK BYTE + SLOOP::IN-CAREFULLY-SLOOP-FOR INCREMENT-CURSOR + IN-INTERVAL-P LISP::LOOKUP-KEYWORD SUPER-GO WRITE-BYTE + ANSI-LOOP::LOOP-DO-WHILE READ-INSTRUCTION LOGANDC1 + SLOOP::THEREIS-SLOOP-COLLECT COERCE-TO-STRING LOGORC2 + SEQUENCE-CURSOR LOGNOR FPE::READ-OPERANDS + SLOOP::MAXIMIZE-SLOOP-COLLECT ALL-MATCHES + SLOOP::IN-TABLE-SLOOP-MAP SLOOP::COLLATE-SLOOP-COLLECT + CHECK-SEQ-START-END BREAK-STEP-NEXT FPE::RF + SLOOP::PARSE-LOOP-MAP VECTOR-PUSH FPE::PAREN-READER + FPE::0-READER ANSI-LOOP::LOOP-TASSOC SETF-HELPER + SETF-EXPAND SLOOP::MINIMIZE-SLOOP-COLLECT ADD-FILE LOGORC1 + SLOOP::COUNT-SLOOP-COLLECT SLOOP::MAKE-VALUE + PARSE-SLOT-DESCRIPTION SLOOP::DESETQ1 + ANSI-LOOP::LOOP-DO-ALWAYS SLOOP::L-EQUAL GET-MATCH + SLOOP::SUM-SLOOP-COLLECT DM-V BREAK-STEP-INTO LOGNAND NTH + SUBSTRINGP INFO-AUX SUB-INTERVAL-P *BREAK-POINTS* SAFE-EVAL + ANSI-LOOP::HIDE-VARIABLE-REFERENCES COERCE + ANSI-LOOP::LOOP-NOTE-MINIMAX-OPERATION CONDITION-PASS + GET-NODES ANSI-LOOP::LOOP-TMEMBER + SLOOP::ALWAYS-SLOOP-COLLECT DISPLAY-ENV SLOOP::THE-TYPE + ANSI-LOOP::LOOP-MAYBE-BIND-FORM ITERATE-OVER-BKPTS LOGTEST + LISP::KEYWORD-SUPPLIED-P)) +(PROCLAIM '(FTYPE (FUNCTION (T T T T T T T) *) TRACE-CALL)) +(PROCLAIM + '(FTYPE (FUNCTION NIL *) GCL-TOP-LEVEL SIMPLE-BACKTRACE + BREAK-CURRENT BREAK-MESSAGE ANSI-LOOP::LOOP-DO-FOR + BREAK-HELP)) +(PROCLAIM + '(FTYPE (FUNCTION (STRING) T) RESET-SYS-PATHS + COERCE-SLASH-TERMINATED)) +(PROCLAIM + '(FTYPE (FUNCTION (T T) FIXNUM) RELATIVE-LINE GET-NODE-INDEX + ANSI-LOOP::DUPLICATABLE-CODE-P THE-END)) +(PROCLAIM '(FTYPE (FUNCTION (FIXNUM T) T) SMALLNTHCDR)) +(PROCLAIM '(FTYPE (FUNCTION (FIXNUM FIXNUM) FIXNUM) ROUND-UP)) +(PROCLAIM + '(FTYPE (FUNCTION (T *) T) + ANSI-LOOP::LOOP-COLLECT-PREPOSITIONAL-PHRASES SBIT + INFO-SEARCH PROCESS-ARGS LIST-MATCHES ARRAY-ROW-MAJOR-INDEX + FIND-RESTART SLOOP::LOOP-ADD-TEMPS ANSI-LOOP::LOOP-WARN + ANSI-LOOP::LOOP-ERROR BAD-SEQ-LIMIT ARRAY-IN-BOUNDS-P + MAKE-ARRAY SIGNAL BIT PROCESS-SOME-ARGS CONCATENATE ERROR + REMOVE-DUPLICATES SLOOP::ADD-FROM-DATA READ-BYTE + FILE-SEARCH FILE-TO-STRING UPGRADED-ARRAY-ELEMENT-TYPE WARN + BREAK-LEVEL BIT-NOT NTH-STACK-FRAME DELETE-DUPLICATES)) +(PROCLAIM + '(FTYPE (FUNCTION (T T) *) ANSI-LOOP::ESTIMATE-CODE-SIZE-1 NEWLINE + FIND-DOC RESTART-REPORT ANSI-LOOP::ESTIMATE-CODE-SIZE + NEW-SEMI-COLON-READER)) +(PROCLAIM + '(FTYPE (FUNCTION (T T *) T) NOTANY BIT-ORC1 + ANSI-LOOP::LOOP-CHECK-DATA-TYPE REMOVE BIT-ANDC1 + INTERNAL-COUNT-IF-NOT READ-SEQUENCE SUBSETP + VECTOR-PUSH-EXTEND TYPEP CERROR REPLACE COUNT-IF + NSET-DIFFERENCE DELETE REMOVE-IF NSET-EXCLUSIVE-OR + PROCESS-ERROR INTERNAL-COUNT SLOOP::IN-ARRAY-SLOOP-FOR + SEARCH MAKE-SEQUENCE ADJUST-ARRAY BIT-NAND FIND-IF + NINTERSECTION FILL BIT-ORC2 BIT-XOR UNION DELETE-IF-NOT + SLOOP::PARSE-LOOP-MACRO WRITE-SEQUENCE SOME COUNT-IF-NOT + MAP-INTO FIND FIND-IF-NOT BIT-NOR BIT-ANDC2 POSITION-IF + NOTEVERY NUNION SET-DIFFERENCE INTERSECTION POSITION-IF-NOT + EVERY POSITION FIND-IHS BIT-EQV REMOVE-IF-NOT MISMATCH + BIT-AND INTERNAL-COUNT-IF DELETE-IF COUNT BREAK-CALL + SET-EXCLUSIVE-OR SLOOP::LOOP-ADD-BINDING BIT-IOR)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T) T) ANSI-LOOP::LOOP-FOR-IN + FLOATING-POINT-ERROR CHECK-TRACE-ARGS + ANSI-LOOP::HIDE-VARIABLE-REFERENCE SETF-EXPAND-1 + MAKE-BREAK-POINT FPE::REF SHARP-A-READER SHARP-U-READER DPB + DM-VL CHECK-S-DATA ANSI-LOOP::LOOP-MAKE-ITERATION-VARIABLE + APPLY-DISPLAY-FUN ANSI-LOOP::LOOP-STANDARD-EXPANSION + ANSI-LOOP::LOOP-TRANSLATE DEPOSIT-FIELD + ANSI-LOOP::LOOP-ANSI-FOR-EQUALS + SLOOP::LOOP-PARSE-ADDITIONAL-COLLECTIONS + ANSI-LOOP::LOOP-FOR-ON GET-SLOT-POS + ANSI-LOOP::PRINT-LOOP-UNIVERSE DEFMACRO* WARN-VERSION + RESTART-CASE-EXPRESSION-CONDITION MAKE-T-TYPE + ANSI-LOOP::LOOP-SUM-COLLECTION ANSI-LOOP::LOOP-FOR-BEING + ANSI-LOOP::LOOP-FOR-ACROSS)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T *) T) CHECK-TYPE-SYMBOL + ANSI-LOOP::LOOP-HASH-TABLE-ITERATION-PATH NSUBSTITUTE-IF + SUBSTITUTE-IF + ANSI-LOOP::LOOP-PACKAGE-SYMBOLS-ITERATION-PATH NSUBSTITUTE + ANSI-LOOP::LOOP-SEQUENCE-ELEMENTS-PATH + LISP::PUSH-LET-BINDING ANSI-LOOP::ADD-LOOP-PATH + SUBSTITUTE-IF-NOT MAP SLOOP::LOOP-DECLARE-BINDING + SUBSTITUTE ANSI-LOOP::LOOP-MAKE-VARIABLE NSUBSTITUTE-IF-NOT + COMPLETE-PROP)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T T) T) LISP::DO-ARG-COUNT-ERROR + LISP::PUSH-SUB-LIST-BINDING)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T) T) MAKE-CONSTRUCTOR MAKE-PREDICATE + DO-BREAK-LEVEL)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T *) T) PRINT-STACK-FRAME MERGE + SLOOP::DEF-LOOP-INTERNAL)) +(PROCLAIM + '(FTYPE (FUNCTION (T T FIXNUM) T) SHARP-EQ-READER + SHARP-SHARP-READER)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T) T) CALL-TEST COERCE-TO-CONDITION + FIND-LINE-IN-FUN ANSI-LOOP::LOOP-FOR-ARITHMETIC MAYBE-BREAK + SLOOP::FIRST-USE-SLOOP-FOR SLOOP::FIRST-SLOOP-FOR + SETF-STRUCTURE-ACCESS)) +(PROCLAIM '(FTYPE (FUNCTION (T T T T T T *) T) ENCODE-UNIVERSAL-TIME)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T T T T T T) T) + ANSI-LOOP::LOOP-SEQUENCER)) +(PROCLAIM '(FTYPE (FUNCTION (T T T T T *) T) UNIVERSAL-ERROR-HANDLER)) +(PROCLAIM + '(FTYPE (FUNCTION NIL T) ANSI-LOOP::LOOP-DO-NAMED + SLOOP::LOOP-UN-POP ANSI-LOOP::LOOP-DO-INITIALLY + SLOOP::PARSE-LOOP-WHEN SLOOP::LOOP-POP SLOOP::LOOP-PEEK + SLOOP::PARSE-LOOP-DO SET-ENV ANSI-LOOP::LOOP-DO-REPEAT + READ-EVALUATED-FORM ANSI-LOOP::LOOP-DO-RETURN + ANSI-LOOP::LOOP-GET-FORM ANSI-LOOP::LOOP-DO-FINALLY + SET-CURRENT DEFAULT-SYSTEM-BANNER DM-TOO-FEW-ARGUMENTS + ANSI-LOOP::LOOP-DO-DO SLOOP::PARSE-ONE-WHEN-CLAUSE + DEFAULT-INFO-HOTLIST KCL-TOP-RESTARTS TYPE-ERROR + SET-UP-TOP-LEVEL INSPECT-INDENT GET-INDEX-NODE + ALL-TRACE-DECLARATIONS DBL ANSI-LOOP::LOOP-GET-PROGN + INIT-BREAK-POINTS STEP-READ-LINE + ANSI-LOOP::LOOP-ITERATION-DRIVER GET-SIG-FN-NAME + SETUP-LINEINFO CLEANUP ANSI-LOOP::LOOP-WHEN-IT-VARIABLE + ANSI-LOOP::LOOP-DO-WITH SHOW-RESTARTS + SLOOP::PARSE-LOOP-COLLECT INSPECT-READ-LINE + DM-TOO-MANY-ARGUMENTS INSPECT-INDENT-1 + ANSI-LOOP::LOOP-POP-SOURCE TEST-ERROR SLOOP::PARSE-LOOP1 + ANSI-LOOP::LOOP-CONTEXT ANSI-LOOP::LOOP-BIND-BLOCK + WINE-TMP-REDIRECT ILLEGAL-BOA SLOOP::PARSE-LOOP-FOR + TOP-LEVEL LISP-IMPLEMENTATION-VERSION GET-TEMP-DIR)) \ No newline at end of file diff --git a/lsp/ucall.lisp b/lsp/ucall.lisp new file mode 100755 index 0000000..8999b4a --- /dev/null +++ b/lsp/ucall.lisp @@ -0,0 +1,143 @@ +(in-package 'compiler) +(import 'si::switch) +(import 'sloop::sloop) +(provide "UCALL") + +;;ucall is like funcall, except it assumes +;;1) its first arg has an inline-always property. +;;2) the order of evaluation of the remaining args is unimportant. + +;;This can be useful when we know that the side effects caused by evaluating +;;the args do not affect the order of evaluation. +;;It also returns an indeterminate value. + +(defun c1ucall (args &aux funob (info (compiler::make-info))) + (setq funob (compiler::c1funob (car args))) + (compiler::add-info info (cadr funob)) + (list 'ucall info funob (compiler::c1args (cdr args) info)) + ) + +(defun c2ucall (funob args &aux (*inline-blocks* 0)(*vs* *vs*)) + (let* ((fname (caddr funob)) + (props (car (get fname 'inline-always))) + new-args + ) + (or props (error "no inline-always prop")) + (do ((v args (cdr v)) + (types (car props) (cdr types))) + ((null v) (setq new-args (nreverse new-args))) + (setq new-args + (append (inline-args (list (car v)) (list (car types))) + new-args))) + (wt-nl) + (wt-inline-loc (nth 4 props) new-args) + (wt ";") + (unwind-exit "Cnil") + (close-inline-blocks) + )) + + +;;Usage (comment "hi there") ; will insert a comment at that point in +;;the program. +(defun c1comment (args) + (list 'comment (make-info) args)) +(defun c2comment (args) + (let ((string (car args))) + (if (find #\/ string) (setq string (remove #\/ string))) + (wt "/* "string " */"))) + +(defmacro comment (a) a nil) + +;;Usage: (tlet (char *) jack ....) +;;--> {char * V1; ...V1.. + +(defun c1tlet (args &aux (info (make-info)) (*vars* *vars*)) + (let ((sym (cadr args)) + (type (car args)) + form ) + (let ((var (c1make-var sym nil nil nil))) + (cond ((subtypep type 'fixnum) + (setf (var-type var) 'fixnum))) + (push var *vars*) + (setq form (c1expr* (cons 'progn (cddr args)) info)) + (list 'tlet (second form) type var form)))) + +(defun c2tlet (type var orig &aux (stype type)) + (setf (var-loc var) (next-cvar)) + (or (stringp type) (setq stype (format nil "~(~a~)" type))) + (setf (var-kind var) + (cond ((subtypep type 'fixnum) + (setf (var-type var) 'fixnum)) + (t 'object))) + (if (listp type) (setq stype (string-trim "()" stype))) + (wt-nl "{" stype " V" (var-loc var) ";" ) + (c2expr orig) + (wt "}")) + +(si::putprop 'tlet 'c1tlet 'c1special) +(si::putprop 'tlet 'c2tlet 'c2) + + +(defun c1clet (args) + (let ((string (car args)) + (form (c1expr (cons 'progn (cdr args))))) + (list 'clet (second form) string form))) + +(defun c2clet (string orig ) + (wt-nl "{" string) + (c2expr orig) + (wt "}")) + +;;Usage: Takes a STRING and BODY. Acts like progn +;;on the body, but the c code will have {string . c code for body} +;;Sample (clet "int jack; char *jane;" ....) +(defmacro clet (string &rest body) string `(progn ,@ body)) + +(si::putprop 'clet 'c1clet 'c1special) +(si::putprop 'clet 'c2clet 'c2) + + +(si::putprop 'comment 'c1comment 'c1special) +(si::putprop 'comment 'c2comment 'c2) + + + + + +(si::putprop 'ucall 'c1ucall 'c1) +(si::putprop 'ucall 'c2ucall 'c2) + + + +(defmacro def-inline (name args return-type &rest bod) + (let* ((side-effect-p (if (member (car bod) + '(:side-effect nil t)) + (prog1 (and (car bod) t) (setq bod (cdr bod))) + nil)) + (inline (list args return-type side-effect-p nil (car bod)))) + `(car (push ',inline + (get ',name 'inline-always))))) + + + + +(defmacro defun-inline (name args return-type &rest bod) + (let* ((sym (gensym)) + (named-args + (nthcdr (- 10 (length args)) '(X9 X8 X7 X6 X5 X4 X3 X2 X1 X0))) + (inline (eval `(def-inline ,sym ,args ,return-type ,@ bod)))) + `(progn + (defun ,name ,named-args + (declare ,@ (sloop for v in named-args for w in args + when (not (eq t v)) + collect (list w v))) + (the ,return-type (,sym ,@ named-args))) + (push ',inline + (get ',name 'inline-always))))) + +(defmacro def-ucall (fun args string) + (let ((sym (gensym))) + `(progn + (def-inline ,sym ,args t t ,string) + (defmacro ,fun (&rest args) `(ucall ',',sym ,@ args))))) + diff --git a/lsp/ustreams.lisp b/lsp/ustreams.lisp new file mode 100755 index 0000000..0703fac --- /dev/null +++ b/lsp/ustreams.lisp @@ -0,0 +1,81 @@ + +;;; +;;; This file contains some macros for user defined streams +;;; +;;; +;;; probably need to add some fields to "define-user-stream-type" +;;; +;;; +;;; we probably need the ability for user-defined streams to declare +;;; whether they are input/output or both +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(in-package 'lisp) + +(export '(make-user-stream define-user-stream-type *user-defined-stream-types*)) + +(defvar *user-defined-stream-types* nil) ;;; list of user defined stream types + +(defun make-user-stream (str-type) + (let (struct) + (unless (member str-type *user-defined-stream-types*) + (error "Make-user-stream: ~a undefined stream type" str-type)) + (setq struct (funcall (get str-type 'lisp::str-conc-name))) + (allocate-stream-object str-type struct))) + +(defmacro define-user-stream-type (str-name + str-data + str-read-char + str-write-char + str-peek-char + str-force-output + str-close + str-type + &optional str-unread-char) + (let ((conc-name (intern (concatenate 'string "KCL-" + (symbol-name str-name))))) + nil + `(progn + (setf (get ',str-name 'str-conc-name) ',conc-name) + (setf (get ',str-name 'stream) t) + (format t "Constructor ") + (setq lisp::*user-defined-stream-types* (cons ',str-name lisp::*user-defined-stream-types*)) + (defstruct (,str-name (:constructor ,conc-name)) + (str-data ,str-data) ;0 + (str-read-char ,str-read-char) ;1 + (str-write-char ,str-write-char) ;2 + (str-peek-char ,str-peek-char) ;3 + (str-force-output ,str-force-output) ;4 + (str-close ,str-close) ;5 + (str-type ,str-type) ;6 + (str-unread-char ,str-unread-char) ;7 + (str-name ',str-name))))) ;8 + + +;;; +;;; allocate a stream-object and patch in the struct which holds +;;; the goodies +;;; +(Clines + +" object allocate_stream_object (stream_type, new_struct) + + object stream_type; + object new_struct; + { + object x; + x = alloc_object(t_stream); + x->sm.sm_mode = smm_user_defined; + x->sm.sm_object1 = new_struct; + x->sm.sm_object0 = stream_type; + x->sm.sm_int0 = 0; + x->sm.sm_fp = 0; + x->sm.sm_int1 = 0; + return x; +}" +) + +(defentry allocate-stream-object (object object) (object allocate_stream_object)) + + + diff --git a/ltmain.sh b/ltmain.sh new file mode 100644 index 0000000..742703b --- /dev/null +++ b/ltmain.sh @@ -0,0 +1,5476 @@ +# ltmain.sh - Provide generalized library-building support services. +# NOTE: Changing this file will not affect anything until you rerun ltconfig. +# +# Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001 +# Free Software Foundation, Inc. +# Originally by Gordon Matzigkeit , 1996 +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +# +# As a special exception to the GNU General Public License, if you +# distribute this file as part of a program that contains a +# configuration script generated by Autoconf, you may include it under +# the same distribution terms that you use for the rest of that program. + +# Check that we have a working $echo. +if test "X$1" = X--no-reexec; then + # Discard the --no-reexec flag, and continue. + shift +elif test "X$1" = X--fallback-echo; then + # Avoid inline document here, it may be left over + : +elif test "X`($echo '\t') 2>/dev/null`" = 'X\t'; then + # Yippee, $echo works! + : +else + # Restart under the correct shell, and then maybe $echo will work. + exec $SHELL "$0" --no-reexec ${1+"$@"} +fi + +if test "X$1" = X--fallback-echo; then + # used as fallback echo + shift + cat <&2 + echo "Fatal configuration error. See the $PACKAGE docs for more information." 1>&2 + exit 1 +fi + +if test "$build_libtool_libs" != yes && test "$build_old_libs" != yes; then + echo "$modename: not configured to build any kind of library" 1>&2 + echo "Fatal configuration error. See the $PACKAGE docs for more information." 1>&2 + exit 1 +fi + +# Global variables. +mode=$default_mode +nonopt= +prev= +prevopt= +run= +show="$echo" +show_help= +execute_dlfiles= +lo2o="s/\\.lo\$/.${objext}/" +o2lo="s/\\.${objext}\$/.lo/" +taglist= + +# Parse our command line options once, thoroughly. +while test $# -gt 0 +do + arg="$1" + shift + + case $arg in + -*=*) optarg=`$echo "X$arg" | $Xsed -e 's/[-_a-zA-Z0-9]*=//'` ;; + *) optarg= ;; + esac + + # If the previous option needs an argument, assign it. + if test -n "$prev"; then + case $prev in + execute_dlfiles) + execute_dlfiles="$execute_dlfiles $arg" + ;; + tag) + tagname="$arg" + + # Check whether tagname contains only valid characters + case $tagname in + *[!-_A-Za-z0-9,/]*) + echo "$progname: invalid tag name: $tagname" 1>&2 + exit 1 + ;; + esac + + case $tagname in + CC) + # Don't test for the "default" C tag, as we know, it's there, but + # not specially marked. + taglist="$taglist $tagname" + ;; + *) + if grep "^### BEGIN LIBTOOL TAG CONFIG: $tagname$" < "$0" > /dev/null; then + taglist="$taglist $tagname" + # Evaluate the configuration. + eval "`sed -n -e '/^### BEGIN LIBTOOL TAG CONFIG: '$tagname'$/,/^### END LIBTOOL TAG CONFIG: '$tagname'$/p' < $0`" + else + echo "$progname: ignoring unknown tag $tagname" 1>&2 + fi + ;; + esac + ;; + *) + eval "$prev=\$arg" + ;; + esac + + prev= + prevopt= + continue + fi + + # Have we seen a non-optional argument yet? + case $arg in + --help) + show_help=yes + ;; + + --version) + echo "$PROGRAM (GNU $PACKAGE) $VERSION$TIMESTAMP" + exit 0 + ;; + + --config) + sed -n -e '/^### BEGIN LIBTOOL CONFIG/,/^### END LIBTOOL CONFIG/p' < "$0" + # Now print the configurations for the tags. + for tagname in $taglist; do + sed -n -e "/^### BEGIN LIBTOOL TAG CONFIG: $tagname$/,/^### END LIBTOOL TAG CONFIG: $tagname$/p" < "$0" + done + exit 0 + ;; + + --debug) + echo "$progname: enabling shell trace mode" + set -x + ;; + + --dry-run | -n) + run=: + ;; + + --features) + echo "host: $host" + if test "$build_libtool_libs" = yes; then + echo "enable shared libraries" + else + echo "disable shared libraries" + fi + if test "$build_old_libs" = yes; then + echo "enable static libraries" + else + echo "disable static libraries" + fi + exit 0 + ;; + + --finish) mode="finish" ;; + + --mode) prevopt="--mode" prev=mode ;; + --mode=*) mode="$optarg" ;; + + --quiet | --silent) + show=: + ;; + + --tag) prevopt="--tag" prev=tag ;; + --tag=*) + set tag "$optarg" ${1+"$@"} + shift + prev=tag + ;; + + -dlopen) + prevopt="-dlopen" + prev=execute_dlfiles + ;; + + -*) + $echo "$modename: unrecognized option \`$arg'" 1>&2 + $echo "$help" 1>&2 + exit 1 + ;; + + *) + nonopt="$arg" + break + ;; + esac +done + +if test -n "$prevopt"; then + $echo "$modename: option \`$prevopt' requires an argument" 1>&2 + $echo "$help" 1>&2 + exit 1 +fi + +# If this variable is set in any of the actions, the command in it +# will be execed at the end. This prevents here-documents from being +# left over by shells. +exec_cmd= + +if test -z "$show_help"; then + + # Infer the operation mode. + if test -z "$mode"; then + case $nonopt in + *cc | *++ | gcc* | *-gcc*) + mode=link + for arg + do + case $arg in + -c) + mode=compile + break + ;; + esac + done + ;; + *db | *dbx | *strace | *truss) + mode=execute + ;; + *install*|cp|mv) + mode=install + ;; + *rm) + mode=uninstall + ;; + *) + # If we have no mode, but dlfiles were specified, then do execute mode. + test -n "$execute_dlfiles" && mode=execute + + # Just use the default operation mode. + if test -z "$mode"; then + if test -n "$nonopt"; then + $echo "$modename: warning: cannot infer operation mode from \`$nonopt'" 1>&2 + else + $echo "$modename: warning: cannot infer operation mode without MODE-ARGS" 1>&2 + fi + fi + ;; + esac + fi + + # Only execute mode is allowed to have -dlopen flags. + if test -n "$execute_dlfiles" && test "$mode" != execute; then + $echo "$modename: unrecognized option \`-dlopen'" 1>&2 + $echo "$help" 1>&2 + exit 1 + fi + + # Change the help message to a mode-specific one. + generic_help="$help" + help="Try \`$modename --help --mode=$mode' for more information." + + # These modes are in order of execution frequency so that they run quickly. + case $mode in + # libtool compile mode + compile) + modename="$modename: compile" + # Get the compilation command and the source file. + base_compile= + prev= + lastarg= + srcfile="$nonopt" + suppress_output= + + user_target=no + for arg + do + case $prev in + "") ;; + xcompiler) + # Aesthetically quote the previous argument. + prev= + lastarg=`$echo "X$arg" | $Xsed -e "$sed_quote_subst"` + + case $arg in + # Double-quote args containing other shell metacharacters. + # Many Bourne shells cannot handle close brackets correctly + # in scan sets, so we specify it separately. + *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*|"") + arg="\"$arg\"" + ;; + esac + + # Add the previous argument to base_compile. + if test -z "$base_compile"; then + base_compile="$lastarg" + else + base_compile="$base_compile $lastarg" + fi + continue + ;; + esac + + # Accept any command-line options. + case $arg in + -o) + if test "$user_target" != "no"; then + $echo "$modename: you cannot specify \`-o' more than once" 1>&2 + exit 1 + fi + user_target=next + ;; + + -static) + build_old_libs=yes + continue + ;; + + -prefer-pic) + pic_mode=yes + continue + ;; + + -prefer-non-pic) + pic_mode=no + continue + ;; + + -Xcompiler) + prev=xcompiler + continue + ;; + + -Wc,*) + args=`$echo "X$arg" | $Xsed -e "s/^-Wc,//"` + lastarg= + IFS="${IFS= }"; save_ifs="$IFS"; IFS=',' + for arg in $args; do + IFS="$save_ifs" + + # Double-quote args containing other shell metacharacters. + # Many Bourne shells cannot handle close brackets correctly + # in scan sets, so we specify it separately. + case $arg in + *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*|"") + arg="\"$arg\"" + ;; + esac + lastarg="$lastarg $arg" + done + IFS="$save_ifs" + lastarg=`$echo "X$lastarg" | $Xsed -e "s/^ //"` + + # Add the arguments to base_compile. + if test -z "$base_compile"; then + base_compile="$lastarg" + else + base_compile="$base_compile $lastarg" + fi + continue + ;; + esac + + case $user_target in + next) + # The next one is the -o target name + user_target=yes + continue + ;; + yes) + # We got the output file + user_target=set + libobj="$arg" + continue + ;; + esac + + # Accept the current argument as the source file. + lastarg="$srcfile" + srcfile="$arg" + + # Aesthetically quote the previous argument. + + # Backslashify any backslashes, double quotes, and dollar signs. + # These are the only characters that are still specially + # interpreted inside of double-quoted scrings. + lastarg=`$echo "X$lastarg" | $Xsed -e "$sed_quote_subst"` + + # Double-quote args containing other shell metacharacters. + # Many Bourne shells cannot handle close brackets correctly + # in scan sets, so we specify it separately. + case $lastarg in + *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*|"") + lastarg="\"$lastarg\"" + ;; + esac + + # Add the previous argument to base_compile. + if test -z "$base_compile"; then + base_compile="$lastarg" + else + base_compile="$base_compile $lastarg" + fi + done + + case $user_target in + set) + ;; + no) + # Get the name of the library object. + libobj=`$echo "X$srcfile" | $Xsed -e 's%^.*/%%'` + ;; + *) + $echo "$modename: you must specify a target with \`-o'" 1>&2 + exit 1 + ;; + esac + + # Recognize several different file suffixes. + # If the user specifies -o file.o, it is replaced with file.lo + xform='[cCFSfmso]' + case $libobj in + *.ada) xform=ada ;; + *.adb) xform=adb ;; + *.ads) xform=ads ;; + *.asm) xform=asm ;; + *.c++) xform=c++ ;; + *.cc) xform=cc ;; + *.class) xform=class ;; + *.cpp) xform=cpp ;; + *.cxx) xform=cxx ;; + *.f90) xform=f90 ;; + *.for) xform=for ;; + *.java) xform=java ;; + esac + + libobj=`$echo "X$libobj" | $Xsed -e "s/\.$xform$/.lo/"` + + case $libobj in + *.lo) obj=`$echo "X$libobj" | $Xsed -e "$lo2o"` ;; + *) + $echo "$modename: cannot determine name of library object from \`$libobj'" 1>&2 + exit 1 + ;; + esac + + # Infer tagged configuration to use if any are available and + # if one wasn't chosen via the "--tag" command line option. + # Only attempt this if the compiler in the base compile + # command doesn't match the default compiler. + if test -n "$available_tags" && test -z "$tagname"; then + case $base_compile in + "$CC "*) ;; + # Blanks in the command may have been stripped by the calling shell, + # but not from the CC environment variable when ltconfig was run. + "`$echo $CC` "*) ;; + *) + for z in $available_tags; do + if grep "^### BEGIN LIBTOOL TAG CONFIG: $z$" < "$0" > /dev/null; then + # Evaluate the configuration. + eval "`sed -n -e '/^### BEGIN LIBTOOL TAG CONFIG: '$z'$/,/^### END LIBTOOL TAG CONFIG: '$z'$/p' < $0`" + case $base_compile in + "$CC "*) + # The compiler in the base compile command matches + # the one in the tagged configuration. + # Assume this is the tagged configuration we want. + tagname=$z + break + ;; + "`$echo $CC` "*) + tagname=$z + break + ;; + esac + fi + done + # If $tagname still isn't set, then no tagged configuration + # was found and let the user know that the "--tag" command + # line option must be used. + if test -z "$tagname"; then + echo "$modename: unable to infer tagged configuration" + echo "$modename: specify a tag with \`--tag'" 1>&2 + exit 1 +# else +# echo "$modename: using $tagname tagged configuration" + fi + ;; + esac + fi + + objname=`$echo "X$obj" | $Xsed -e 's%^.*/%%'` + xdir=`$echo "X$obj" | $Xsed -e 's%/[^/]*$%%'` + if test "X$xdir" = "X$obj"; then + xdir= + else + xdir=$xdir/ + fi + lobj=${xdir}$objdir/$objname + + if test -z "$base_compile"; then + $echo "$modename: you must specify a compilation command" 1>&2 + $echo "$help" 1>&2 + exit 1 + fi + + # Delete any leftover library objects. + if test "$build_old_libs" = yes; then + removelist="$obj $lobj $libobj ${libobj}T" + else + removelist="$lobj $libobj ${libobj}T" + fi + + $run $rm $removelist + trap "$run $rm $removelist; exit 1" 1 2 15 + + # On Cygwin there's no "real" PIC flag so we must build both object types + case $host_os in + cygwin* | mingw* | pw32* | os2*) + pic_mode=default + ;; + esac + if test $pic_mode = no && test "$deplibs_check_method" != pass_all; then + # non-PIC code in shared libraries is not supported + pic_mode=default + fi + + # Calculate the filename of the output object if compiler does + # not support -o with -c + if test "$compiler_c_o" = no; then + output_obj=`$echo "X$srcfile" | $Xsed -e 's%^.*/%%' -e 's%\.[^.]*$%%'`.${objext} + lockfile="$output_obj.lock" + removelist="$removelist $output_obj $lockfile" + trap "$run $rm $removelist; exit 1" 1 2 15 + else + output_obj= + need_locks=no + lockfile= + fi + + # Lock this critical section if it is needed + # We use this script file to make the link, it avoids creating a new file + if test "$need_locks" = yes; then + until $run ln "$0" "$lockfile" 2>/dev/null; do + $show "Waiting for $lockfile to be removed" + sleep 2 + done + elif test "$need_locks" = warn; then + if test -f "$lockfile"; then + echo "\ +*** ERROR, $lockfile exists and contains: +`cat $lockfile 2>/dev/null` + +This indicates that another process is trying to use the same +temporary object file, and libtool could not work around it because +your compiler does not support \`-c' and \`-o' together. If you +repeat this compilation, it may succeed, by chance, but you had better +avoid parallel builds (make -j) in this platform, or get a better +compiler." + + $run $rm $removelist + exit 1 + fi + echo $srcfile > "$lockfile" + fi + + if test -n "$fix_srcfile_path"; then + eval srcfile=\"$fix_srcfile_path\" + fi + + $run $rm "$libobj" "${libobj}T" + + # Create a libtool object file (analogous to a ".la" file), + # but don't create it if we're doing a dry run. + test -z "$run" && cat > ${libobj}T </dev/null`" != x"$srcfile"; then + echo "\ +*** ERROR, $lockfile contains: +`cat $lockfile 2>/dev/null` + +but it should contain: +$srcfile + +This indicates that another process is trying to use the same +temporary object file, and libtool could not work around it because +your compiler does not support \`-c' and \`-o' together. If you +repeat this compilation, it may succeed, by chance, but you had better +avoid parallel builds (make -j) in this platform, or get a better +compiler." + + $run $rm $removelist + exit 1 + fi + + # Just move the object if needed, then go on to compile the next one + if test -n "$output_obj" && test "x$output_obj" != "x$lobj"; then + $show "$mv $output_obj $lobj" + if $run $mv $output_obj $lobj; then : + else + error=$? + $run $rm $removelist + exit $error + fi + fi + + # Append the name of the PIC object to the libtool object file. + test -z "$run" && cat >> ${libobj}T <> ${libobj}T </dev/null`" != x"$srcfile"; then + echo "\ +*** ERROR, $lockfile contains: +`cat $lockfile 2>/dev/null` + +but it should contain: +$srcfile + +This indicates that another process is trying to use the same +temporary object file, and libtool could not work around it because +your compiler does not support \`-c' and \`-o' together. If you +repeat this compilation, it may succeed, by chance, but you had better +avoid parallel builds (make -j) in this platform, or get a better +compiler." + + $run $rm $removelist + exit 1 + fi + + # Just move the object if needed + if test -n "$output_obj" && test "x$output_obj" != "x$obj"; then + $show "$mv $output_obj $obj" + if $run $mv $output_obj $obj; then : + else + error=$? + $run $rm $removelist + exit $error + fi + fi + + # Append the name of the non-PIC object the libtool object file. + # Only append if the libtool object file exists. + test -z "$run" && cat >> ${libobj}T <> ${libobj}T <&2 + fi + if test -n "$link_static_flag"; then + dlopen_self=$dlopen_self_static + fi + else + if test -z "$pic_flag" && test -n "$link_static_flag"; then + dlopen_self=$dlopen_self_static + fi + fi + build_libtool_libs=no + build_old_libs=yes + prefer_static_libs=yes + break + ;; + esac + done + + # See if our shared archives depend on static archives. + test -n "$old_archive_from_new_cmds" && build_old_libs=yes + + # Go through the arguments, transforming them on the way. + while test $# -gt 0; do + arg="$1" + base_compile="$base_compile $arg" + shift + case $arg in + *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*|"") + qarg=\"`$echo "X$arg" | $Xsed -e "$sed_quote_subst"`\" ### testsuite: skip nested quoting test + ;; + *) qarg=$arg ;; + esac + libtool_args="$libtool_args $qarg" + + # If the previous option needs an argument, assign it. + if test -n "$prev"; then + case $prev in + output) + compile_command="$compile_command @OUTPUT@" + finalize_command="$finalize_command @OUTPUT@" + ;; + esac + + case $prev in + dlfiles|dlprefiles) + if test "$preload" = no; then + # Add the symbol object into the linking commands. + compile_command="$compile_command @SYMFILE@" + finalize_command="$finalize_command @SYMFILE@" + preload=yes + fi + case $arg in + *.la | *.lo) ;; # We handle these cases below. + force) + if test "$dlself" = no; then + dlself=needless + export_dynamic=yes + fi + prev= + continue + ;; + self) + if test "$prev" = dlprefiles; then + dlself=yes + elif test "$prev" = dlfiles && test "$dlopen_self" != yes; then + dlself=yes + else + dlself=needless + export_dynamic=yes + fi + prev= + continue + ;; + *) + if test "$prev" = dlfiles; then + dlfiles="$dlfiles $arg" + else + dlprefiles="$dlprefiles $arg" + fi + prev= + continue + ;; + esac + ;; + expsyms) + export_symbols="$arg" + if test ! -f "$arg"; then + $echo "$modename: symbol file \`$arg' does not exist" + exit 1 + fi + prev= + continue + ;; + expsyms_regex) + export_symbols_regex="$arg" + prev= + continue + ;; + release) + release="-$arg" + prev= + continue + ;; + objectlist) + if test -f "$arg"; then + save_arg=$arg + moreargs= + for fil in `cat $save_arg` + do +# moreargs="$moreargs $fil" + arg=$fil + # A libtool-controlled object. + + # Check to see that this really is a libtool object. + if (sed -e '2q' $arg | egrep "^# Generated by .*$PACKAGE") >/dev/null 2>&1; then + pic_object= + non_pic_object= + + # Read the .lo file + # If there is no directory component, then add one. + case $arg in + */* | *\\*) . $arg ;; + *) . ./$arg ;; + esac + + if test -z "$pic_object" || \ + test -z "$non_pic_object" || + test "$pic_object" = none && \ + test "$non_pic_object" = none; then + $echo "$modename: cannot find name of object for \`$arg'" 1>&2 + exit 1 + fi + + # Extract subdirectory from the argument. + xdir=`$echo "X$arg" | $Xsed -e 's%/[^/]*$%%'` + if test "X$xdir" = "X$arg"; then + xdir= + else + xdir="$xdir/" + fi + + if test "$pic_object" != none; then + # Prepend the subdirectory the object is found in. + pic_object="$xdir$pic_object" + + if test "$prev" = dlfiles; then + if test "$build_libtool_libs" = yes && test "$dlopen_support" = yes; then + dlfiles="$dlfiles $pic_object" + prev= + continue + else + # If libtool objects are unsupported, then we need to preload. + prev=dlprefiles + fi + fi + + # CHECK ME: I think I busted this. -Ossama + if test "$prev" = dlprefiles; then + # Preload the old-style object. + dlprefiles="$dlprefiles $pic_object" + prev= + fi + + # A PIC object. + libobjs="$libobjs $pic_object" + arg="$pic_object" + fi + + # Non-PIC object. + if test "$non_pic_object" != none; then + # Prepend the subdirectory the object is found in. + non_pic_object="$xdir$non_pic_object" + + # A standard non-PIC object + non_pic_objects="$non_pic_objects $non_pic_object" + if test -z "$pic_object" || test "$pic_object" = none ; then + arg="$non_pic_object" + fi + fi + else + # Only an error if not doing a dry-run. + if test -z "$run"; then + $echo "$modename: \`$arg' is not a valid libtool object" 1>&2 + exit 1 + else + # Dry-run case. + + # Extract subdirectory from the argument. + xdir=`$echo "X$arg" | $Xsed -e 's%/[^/]*$%%'` + if test "X$xdir" = "X$arg"; then + xdir= + else + xdir="$xdir/" + fi + + pic_object=`$echo "X${xdir}${objdir}/${arg}" | $Xsed -e "$lo2o"` + non_pic_object=`$echo "X${xdir}${arg}" | $Xsed -e "$lo2o"` + libobjs="$libobjs $pic_object" + non_pic_objects="$non_pic_objects $non_pic_object" + fi + fi + done + else + $echo "$modename: link input file \`$save_arg' does not exist" + exit 1 + fi + arg=$save_arg + prev= + continue + ;; + rpath | xrpath) + # We need an absolute path. + case $arg in + [\\/]* | [A-Za-z]:[\\/]*) ;; + *) + $echo "$modename: only absolute run-paths are allowed" 1>&2 + exit 1 + ;; + esac + if test "$prev" = rpath; then + case "$rpath " in + *" $arg "*) ;; + *) rpath="$rpath $arg" ;; + esac + else + case "$xrpath " in + *" $arg "*) ;; + *) xrpath="$xrpath $arg" ;; + esac + fi + prev= + continue + ;; + xcompiler) + compiler_flags="$compiler_flags $qarg" + prev= + compile_command="$compile_command $qarg" + finalize_command="$finalize_command $qarg" + continue + ;; + xlinker) + linker_flags="$linker_flags $qarg" + compiler_flags="$compiler_flags $wl$qarg" + prev= + compile_command="$compile_command $wl$qarg" + finalize_command="$finalize_command $wl$qarg" + continue + ;; + *) + eval "$prev=\"\$arg\"" + prev= + continue + ;; + esac + fi # test -n $prev + + prevarg="$arg" + + case $arg in + -all-static) + if test -n "$link_static_flag"; then + compile_command="$compile_command $link_static_flag" + finalize_command="$finalize_command $link_static_flag" + fi + continue + ;; + + -allow-undefined) + # FIXME: remove this flag sometime in the future. + $echo "$modename: \`-allow-undefined' is deprecated because it is the default" 1>&2 + continue + ;; + + -avoid-version) + avoid_version=yes + continue + ;; + + -dlopen) + prev=dlfiles + continue + ;; + + -dlpreopen) + prev=dlprefiles + continue + ;; + + -export-dynamic) + export_dynamic=yes + continue + ;; + + -export-symbols | -export-symbols-regex) + if test -n "$export_symbols" || test -n "$export_symbols_regex"; then + $echo "$modename: more than one -exported-symbols argument is not allowed" + exit 1 + fi + if test "X$arg" = "X-export-symbols"; then + prev=expsyms + else + prev=expsyms_regex + fi + continue + ;; + + # The native IRIX linker understands -LANG:*, -LIST:* and -LNO:* + # so, if we see these flags be careful not to treat them like -L + -L[A-Z][A-Z]*:*) + case $with_gcc/$host in + no/*-*-irix*) + compile_command="$compile_command $arg" + finalize_command="$finalize_command $arg" + ;; + esac + continue + ;; + + -L*) + dir=`$echo "X$arg" | $Xsed -e 's/^-L//'` + # We need an absolute path. + case $dir in + [\\/]* | [A-Za-z]:[\\/]*) ;; + *) + absdir=`cd "$dir" && pwd` + if test -z "$absdir"; then + $echo "$modename: cannot determine absolute directory name of \`$dir'" 1>&2 + exit 1 + fi + dir="$absdir" + ;; + esac + case "$deplibs " in + *" -L$dir "*) ;; + *) + deplibs="$deplibs -L$dir" + lib_search_path="$lib_search_path $dir" + ;; + esac + case $host in + *-*-cygwin* | *-*-mingw* | *-*-pw32* | *-*-os2*) + case :$dllsearchpath: in + *":$dir:"*) ;; + *) dllsearchpath="$dllsearchpath:$dir";; + esac + ;; + esac + continue + ;; + + -l*) + if test "X$arg" = "X-lc" || test "X$arg" = "X-lm"; then + case $host in + *-*-cygwin* | *-*-pw32* | *-*-beos*) + # These systems don't actually have a C or math library (as such) + continue + ;; + *-*-mingw* | *-*-os2*) + # These systems don't actually have a C library (as such) + test "X$arg" = "X-lc" && continue + ;; + esac + fi + deplibs="$deplibs $arg" + continue + ;; + + -module) + module=yes + continue + ;; + + -no-fast-install) + fast_install=no + continue + ;; + + -no-install) + case $host in + *-*-cygwin* | *-*-mingw* | *-*-pw32* | *-*-os2*) + # The PATH hackery in wrapper scripts is required on Windows + # in order for the loader to find any dlls it needs. + $echo "$modename: warning: \`-no-install' is ignored for $host" 1>&2 + $echo "$modename: warning: assuming \`-no-fast-install' instead" 1>&2 + fast_install=no + ;; + *) no_install=yes ;; + esac + continue + ;; + + -no-undefined) + allow_undefined=no + continue + ;; + + -objectlist) + prev=objectlist + continue + ;; + + -o) prev=output ;; + + -release) + prev=release + continue + ;; + + -rpath) + prev=rpath + continue + ;; + + -R) + prev=xrpath + continue + ;; + + -R*) + dir=`$echo "X$arg" | $Xsed -e 's/^-R//'` + # We need an absolute path. + case $dir in + [\\/]* | [A-Za-z]:[\\/]*) ;; + *) + $echo "$modename: only absolute run-paths are allowed" 1>&2 + exit 1 + ;; + esac + case "$xrpath " in + *" $dir "*) ;; + *) xrpath="$xrpath $dir" ;; + esac + continue + ;; + + -static) + # The effects of -static are defined in a previous loop. + # We used to do the same as -all-static on platforms that + # didn't have a PIC flag, but the assumption that the effects + # would be equivalent was wrong. It would break on at least + # Digital Unix and AIX. + continue + ;; + + -thread-safe) + thread_safe=yes + continue + ;; + + -version-info) + prev=vinfo + continue + ;; + + -Wc,*) + args=`$echo "X$arg" | $Xsed -e "$sed_quote_subst" -e 's/^-Wc,//'` + arg= + IFS="${IFS= }"; save_ifs="$IFS"; IFS=',' + for flag in $args; do + IFS="$save_ifs" + case $flag in + *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*|"") + flag="\"$flag\"" + ;; + esac + arg="$arg $wl$flag" + compiler_flags="$compiler_flags $flag" + done + IFS="$save_ifs" + arg=`$echo "X$arg" | $Xsed -e "s/^ //"` + ;; + + -Wl,*) + args=`$echo "X$arg" | $Xsed -e "$sed_quote_subst" -e 's/^-Wl,//'` + arg= + IFS="${IFS= }"; save_ifs="$IFS"; IFS=',' + for flag in $args; do + IFS="$save_ifs" + case $flag in + *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*|"") + flag="\"$flag\"" + ;; + esac + arg="$arg $wl$flag" + compiler_flags="$compiler_flags $wl$flag" + linker_flags="$linker_flags $flag" + done + IFS="$save_ifs" + arg=`$echo "X$arg" | $Xsed -e "s/^ //"` + ;; + + -Xcompiler) + prev=xcompiler + continue + ;; + + -Xlinker) + prev=xlinker + continue + ;; + + # Some other compiler flag. + -* | +*) + # Unknown arguments in both finalize_command and compile_command need + # to be aesthetically quoted because they are evaled later. + arg=`$echo "X$arg" | $Xsed -e "$sed_quote_subst"` + case $arg in + *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*|"") + arg="\"$arg\"" + ;; + esac + ;; + + *.$objext) + # A standard object. + objs="$objs $arg" + ;; + + *.lo) + # A libtool-controlled object. + + # Check to see that this really is a libtool object. + if (sed -e '2q' $arg | egrep "^# Generated by .*$PACKAGE") >/dev/null 2>&1; then + pic_object= + non_pic_object= + + # Read the .lo file + # If there is no directory component, then add one. + case $arg in + */* | *\\*) . $arg ;; + *) . ./$arg ;; + esac + + if test -z "$pic_object" || \ + test -z "$non_pic_object" || + test "$pic_object" = none && \ + test "$non_pic_object" = none; then + $echo "$modename: cannot find name of object for \`$arg'" 1>&2 + exit 1 + fi + + # Extract subdirectory from the argument. + xdir=`$echo "X$arg" | $Xsed -e 's%/[^/]*$%%'` + if test "X$xdir" = "X$arg"; then + xdir= + else + xdir="$xdir/" + fi + + if test "$pic_object" != none; then + # Prepend the subdirectory the object is found in. + pic_object="$xdir$pic_object" + + if test "$prev" = dlfiles; then + if test "$build_libtool_libs" = yes && test "$dlopen_support" = yes; then + dlfiles="$dlfiles $pic_object" + prev= + continue + else + # If libtool objects are unsupported, then we need to preload. + prev=dlprefiles + fi + fi + + # CHECK ME: I think I busted this. -Ossama + if test "$prev" = dlprefiles; then + # Preload the old-style object. + dlprefiles="$dlprefiles $pic_object" + prev= + fi + + # A PIC object. + libobjs="$libobjs $pic_object" + arg="$pic_object" + fi + + # Non-PIC object. + if test "$non_pic_object" != none; then + # Prepend the subdirectory the object is found in. + non_pic_object="$xdir$non_pic_object" + + # A standard non-PIC object + non_pic_objects="$non_pic_objects $non_pic_object" + if test -z "$pic_object" || test "$pic_object" = none ; then + arg="$non_pic_object" + fi + fi + else + # Only an error if not doing a dry-run. + if test -z "$run"; then + $echo "$modename: \`$arg' is not a valid libtool object" 1>&2 + exit 1 + else + # Dry-run case. + + # Extract subdirectory from the argument. + xdir=`$echo "X$arg" | $Xsed -e 's%/[^/]*$%%'` + if test "X$xdir" = "X$arg"; then + xdir= + else + xdir="$xdir/" + fi + + pic_object=`$echo "X${xdir}${objdir}/${arg}" | $Xsed -e "$lo2o"` + non_pic_object=`$echo "X${xdir}${arg}" | $Xsed -e "$lo2o"` + libobjs="$libobjs $pic_object" + non_pic_objects="$non_pic_objects $non_pic_object" + fi + fi + ;; + + *.$libext) + # An archive. + deplibs="$deplibs $arg" + old_deplibs="$old_deplibs $arg" + continue + ;; + + *.la) + # A libtool-controlled library. + + if test "$prev" = dlfiles; then + # This library was specified with -dlopen. + dlfiles="$dlfiles $arg" + prev= + elif test "$prev" = dlprefiles; then + # The library was specified with -dlpreopen. + dlprefiles="$dlprefiles $arg" + prev= + else + deplibs="$deplibs $arg" + fi + continue + ;; + + # Some other compiler argument. + *) + # Unknown arguments in both finalize_command and compile_command need + # to be aesthetically quoted because they are evaled later. + arg=`$echo "X$arg" | $Xsed -e "$sed_quote_subst"` + case $arg in + *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*|"") + arg="\"$arg\"" + ;; + esac + ;; + esac # arg + + # Now actually substitute the argument into the commands. + if test -n "$arg"; then + compile_command="$compile_command $arg" + finalize_command="$finalize_command $arg" + fi + done # argument parsing loop + + if test -n "$prev"; then + $echo "$modename: the \`$prevarg' option requires an argument" 1>&2 + $echo "$help" 1>&2 + exit 1 + fi + + # Infer tagged configuration to use if any are available and + # if one wasn't chosen via the "--tag" command line option. + # Only attempt this if the compiler in the base link + # command doesn't match the default compiler. + if test -n "$available_tags" && test -z "$tagname"; then + case $base_compile in + "$CC "*) ;; + # Blanks in the command may have been stripped by the calling shell, + # but not from the CC environment variable when ltconfig was run. + "`$echo $CC` "*) ;; + *) + for z in $available_tags; do + if grep "^### BEGIN LIBTOOL TAG CONFIG: $z$" < "$0" > /dev/null; then + # Evaluate the configuration. + eval "`sed -n -e '/^### BEGIN LIBTOOL TAG CONFIG: '$z'$/,/^### END LIBTOOL TAG CONFIG: '$z'$/p' < $0`" + case $base_compile in + "$CC "*) + # The compiler in $compile_command matches + # the one in the tagged configuration. + # Assume this is the tagged configuration we want. + tagname=$z + break + ;; + "`$echo $CC` "*) + tagname=$z + break + ;; + esac + fi + done + # If $tagname still isn't set, then no tagged configuration + # was found and let the user know that the "--tag" command + # line option must be used. + if test -z "$tagname"; then + echo "$modename: unable to infer tagged configuration" + echo "$modename: specify a tag with \`--tag'" 1>&2 + exit 1 +# else +# echo "$modename: using $tagname tagged configuration" + fi + ;; + esac + fi + + if test "$export_dynamic" = yes && test -n "$export_dynamic_flag_spec"; then + eval arg=\"$export_dynamic_flag_spec\" + compile_command="$compile_command $arg" + finalize_command="$finalize_command $arg" + fi + + # calculate the name of the file, without its directory + outputname=`$echo "X$output" | $Xsed -e 's%^.*/%%'` + libobjs_save="$libobjs" + + if test -n "$shlibpath_var"; then + # get the directories listed in $shlibpath_var + eval shlib_search_path=\`\$echo \"X\${$shlibpath_var}\" \| \$Xsed -e \'s/:/ /g\'\` + else + shlib_search_path= + fi + eval sys_lib_search_path=\"$sys_lib_search_path_spec\" + eval sys_lib_dlsearch_path=\"$sys_lib_dlsearch_path_spec\" + + output_objdir=`$echo "X$output" | $Xsed -e 's%/[^/]*$%%'` + if test "X$output_objdir" = "X$output"; then + output_objdir="$objdir" + else + output_objdir="$output_objdir/$objdir" + fi + # Create the object directory. + if test ! -d $output_objdir; then + $show "$mkdir $output_objdir" + $run $mkdir $output_objdir + status=$? + if test $status -ne 0 && test ! -d $output_objdir; then + exit $status + fi + fi + + # Determine the type of output + case $output in + "") + $echo "$modename: you must specify an output file" 1>&2 + $echo "$help" 1>&2 + exit 1 + ;; + *.$libext) linkmode=oldlib ;; + *.lo | *.$objext) linkmode=obj ;; + *.la) linkmode=lib ;; + *) linkmode=prog ;; # Anything else should be a program. + esac + + specialdeplibs= + libs= + # Find all interdependent deplibs by searching for libraries + # that are linked more than once (e.g. -la -lb -la) + for deplib in $deplibs; do + case "$libs " in + *" $deplib "*) specialdeplibs="$specialdeplibs $deplib" ;; + esac + libs="$libs $deplib" + done + + if test $linkmode = lib; then + libs="$predeps $libs $compiler_lib_search_path $postdeps" + + # Compute libraries that are listed more than once in $predeps + # $postdeps and mark them as special (i.e., whose duplicates are + # not to be eliminated). + pre_post_deps= + for pre_post_dep in $predeps $postdeps; do + case "$pre_post_deps " in + *" $pre_post_dep "*) specialdeplibs="$specialdeplibs $pre_post_deps" ;; + esac + pre_post_deps="$pre_post_deps $pre_post_dep" + done + pre_post_deps= + fi + + deplibs= + newdependency_libs= + newlib_search_path= + need_relink=no # whether we're linking any uninstalled libtool libraries + notinst_deplibs= # not-installed libtool libraries + notinst_path= # paths that contain not-installed libtool libraries + case $linkmode in + lib) + passes="conv link" + for file in $dlfiles $dlprefiles; do + case $file in + *.la) ;; + *) + $echo "$modename: libraries can \`-dlopen' only libtool libraries: $file" 1>&2 + exit 1 + ;; + esac + done + ;; + prog) + compile_deplibs= + finalize_deplibs= + alldeplibs=no + newdlfiles= + newdlprefiles= + passes="conv scan dlopen dlpreopen link" + ;; + *) passes="conv" + ;; + esac + for pass in $passes; do + if test $linkmode = prog; then + # Determine which files to process + case $pass in + dlopen) + libs="$dlfiles" + save_deplibs="$deplibs" # Collect dlpreopened libraries + deplibs= + ;; + dlpreopen) libs="$dlprefiles" ;; + link) libs="$deplibs %DEPLIBS% $dependency_libs" ;; + esac + fi + for deplib in $libs; do + lib= + found=no + case $deplib in + -l*) + if test $linkmode = oldlib && test $linkmode = obj; then + $echo "$modename: warning: \`-l' is ignored for archives/objects: $deplib" 1>&2 + continue + fi + if test $pass = conv; then + deplibs="$deplib $deplibs" + continue + fi + name=`$echo "X$deplib" | $Xsed -e 's/^-l//'` + for searchdir in $newlib_search_path $lib_search_path $sys_lib_search_path $shlib_search_path; do + # Search the libtool library + lib="$searchdir/lib${name}.la" + if test -f "$lib"; then + found=yes + break + fi + done + if test "$found" != yes; then + # deplib doesn't seem to be a libtool library + if test "$linkmode,$pass" = "prog,link"; then + compile_deplibs="$deplib $compile_deplibs" + finalize_deplibs="$deplib $finalize_deplibs" + else + deplibs="$deplib $deplibs" + test $linkmode = lib && newdependency_libs="$deplib $newdependency_libs" + fi + continue + fi + ;; # -l + -L*) + case $linkmode in + lib) + deplibs="$deplib $deplibs" + test $pass = conv && continue + newdependency_libs="$deplib $newdependency_libs" + newlib_search_path="$newlib_search_path "`$echo "X$deplib" | $Xsed -e 's/^-L//'` + ;; + prog) + if test $pass = conv; then + deplibs="$deplib $deplibs" + continue + fi + if test $pass = scan; then + deplibs="$deplib $deplibs" + newlib_search_path="$newlib_search_path "`$echo "X$deplib" | $Xsed -e 's/^-L//'` + else + compile_deplibs="$deplib $compile_deplibs" + finalize_deplibs="$deplib $finalize_deplibs" + fi + ;; + *) + $echo "$modename: warning: \`-L' is ignored for archives/objects: $deplib" 1>&2 + ;; + esac # linkmode + continue + ;; # -L + -R*) + if test $pass = link; then + dir=`$echo "X$deplib" | $Xsed -e 's/^-R//'` + # Make sure the xrpath contains only unique directories. + case "$xrpath " in + *" $dir "*) ;; + *) xrpath="$xrpath $dir" ;; + esac + fi + deplibs="$deplib $deplibs" + continue + ;; + *.la) lib="$deplib" ;; + *.$libext) + if test $pass = conv; then + deplibs="$deplib $deplibs" + continue + fi + case $linkmode in + lib) + if test "$deplibs_check_method" != pass_all; then + echo + echo "*** Warning: This library needs some functionality provided by $deplib." + echo "*** I have the capability to make that library automatically link in when" + echo "*** you link to this library. But I can only do this if you have a" + echo "*** shared version of the library, which you do not appear to have." + else + echo + echo "*** Warning: Linking the shared library $output against the" + echo "*** static library $deplib is not portable!" + deplibs="$deplib $deplibs" + fi + continue + ;; + prog) + if test $pass != link; then + deplibs="$deplib $deplibs" + else + compile_deplibs="$deplib $compile_deplibs" + finalize_deplibs="$deplib $finalize_deplibs" + fi + continue + ;; + esac # linkmode + ;; # *.$libext + *.lo | *.$objext) + if test $pass = dlpreopen || test "$dlopen_support" != yes || test "$build_libtool_libs" = no; then + # If there is no dlopen support or we're linking statically, + # we need to preload. + newdlprefiles="$newdlprefiles $deplib" + compile_deplibs="$deplib $compile_deplibs" + finalize_deplibs="$deplib $finalize_deplibs" + else + newdlfiles="$newdlfiles $deplib" + fi + continue + ;; + %DEPLIBS%) + alldeplibs=yes + continue + ;; + esac # case $deplib + if test $found = yes || test -f "$lib"; then : + else + $echo "$modename: cannot find the library \`$lib'" 1>&2 + exit 1 + fi + + # Check to see that this really is a libtool archive. + if (sed -e '2q' $lib | egrep "^# Generated by .*$PACKAGE") >/dev/null 2>&1; then : + else + $echo "$modename: \`$lib' is not a valid libtool archive" 1>&2 + exit 1 + fi + + ladir=`$echo "X$lib" | $Xsed -e 's%/[^/]*$%%'` + test "X$ladir" = "X$lib" && ladir="." + + dlname= + dlopen= + dlpreopen= + libdir= + library_names= + old_library= + # If the library was installed with an old release of libtool, + # it will not redefine variable installed. + installed=yes + + # Read the .la file + case $lib in + */* | *\\*) . $lib ;; + *) . ./$lib ;; + esac + + if test "$linkmode,$pass" = "lib,link" || + test "$linkmode,$pass" = "prog,scan" || + { test $linkmode = oldlib && test $linkmode = obj; }; then + # Add dl[pre]opened files of deplib + test -n "$dlopen" && dlfiles="$dlfiles $dlopen" + test -n "$dlpreopen" && dlprefiles="$dlprefiles $dlpreopen" + fi + + if test $pass = conv; then + # Only check for convenience libraries + deplibs="$lib $deplibs" + if test -z "$libdir"; then + if test -z "$old_library"; then + $echo "$modename: cannot find name of link library for \`$lib'" 1>&2 + exit 1 + fi + # It is a libtool convenience library, so add in its objects. + convenience="$convenience $ladir/$objdir/$old_library" + old_convenience="$old_convenience $ladir/$objdir/$old_library" + tmp_libs= + for deplib in $dependency_libs; do + deplibs="$deplib $deplibs" + case "$tmp_libs " in + *" $deplib "*) specialdeplibs="$specialdeplibs $deplib" ;; + esac + tmp_libs="$tmp_libs $deplib" + done + elif test $linkmode != prog && test $linkmode != lib; then + $echo "$modename: \`$lib' is not a convenience library" 1>&2 + exit 1 + fi + continue + fi # $pass = conv + + # Get the name of the library we link against. + linklib= + for l in $old_library $library_names; do + linklib="$l" + done + if test -z "$linklib"; then + $echo "$modename: cannot find name of link library for \`$lib'" 1>&2 + exit 1 + fi + + # This library was specified with -dlopen. + if test $pass = dlopen; then + if test -z "$libdir"; then + $echo "$modename: cannot -dlopen a convenience library: \`$lib'" 1>&2 + exit 1 + fi + if test -z "$dlname" || test "$dlopen_support" != yes || test "$build_libtool_libs" = no; then + # If there is no dlname, no dlopen support or we're linking + # statically, we need to preload. + dlprefiles="$dlprefiles $lib" + else + newdlfiles="$newdlfiles $lib" + fi + continue + fi # $pass = dlopen + + # We need an absolute path. + case $ladir in + [\\/]* | [A-Za-z]:[\\/]*) abs_ladir="$ladir" ;; + *) + abs_ladir=`cd "$ladir" && pwd` + if test -z "$abs_ladir"; then + $echo "$modename: warning: cannot determine absolute directory name of \`$ladir'" 1>&2 + $echo "$modename: passing it literally to the linker, although it might fail" 1>&2 + abs_ladir="$ladir" + fi + ;; + esac + laname=`$echo "X$lib" | $Xsed -e 's%^.*/%%'` + + # Find the relevant object directory and library name. + if test "X$installed" = Xyes; then + if test ! -f "$libdir/$linklib" && test -f "$abs_ladir/$linklib"; then + $echo "$modename: warning: library \`$lib' was moved." 1>&2 + dir="$ladir" + absdir="$abs_ladir" + libdir="$abs_ladir" + else + dir="$libdir" + absdir="$libdir" + fi + else + dir="$ladir/$objdir" + absdir="$abs_ladir/$objdir" + # Remove this search path later + notinst_path="$notinst_path $abs_ladir" + fi # $installed = yes + name=`$echo "X$laname" | $Xsed -e 's/\.la$//' -e 's/^lib//'` + + # This library was specified with -dlpreopen. + if test $pass = dlpreopen; then + if test -z "$libdir"; then + $echo "$modename: cannot -dlpreopen a convenience library: \`$lib'" 1>&2 + exit 1 + fi + # Prefer using a static library (so that no silly _DYNAMIC symbols + # are required to link). + if test -n "$old_library"; then + newdlprefiles="$newdlprefiles $dir/$old_library" + # Otherwise, use the dlname, so that lt_dlopen finds it. + elif test -n "$dlname"; then + newdlprefiles="$newdlprefiles $dir/$dlname" + else + newdlprefiles="$newdlprefiles $dir/$linklib" + fi + fi # $pass = dlpreopen + + if test -z "$libdir"; then + # Link the convenience library + if test $linkmode = lib; then + deplibs="$dir/$old_library $deplibs" + elif test "$linkmode,$pass" = "prog,link"; then + compile_deplibs="$dir/$old_library $compile_deplibs" + finalize_deplibs="$dir/$old_library $finalize_deplibs" + else + deplibs="$lib $deplibs" + fi + continue + fi + + if test $linkmode = prog && test $pass != link; then + newlib_search_path="$newlib_search_path $ladir" + deplibs="$lib $deplibs" + + linkalldeplibs=no + if test "$link_all_deplibs" != no || test -z "$library_names" || + test "$build_libtool_libs" = no; then + linkalldeplibs=yes + fi + + tmp_libs= + for deplib in $dependency_libs; do + case $deplib in + -L*) newlib_search_path="$newlib_search_path "`$echo "X$deplib" | $Xsed -e 's/^-L//'`;; ### testsuite: skip nested quoting test + esac + # Need to link against all dependency_libs? + if test $linkalldeplibs = yes; then + deplibs="$deplib $deplibs" + else + # Need to hardcode shared library paths + # or/and link against static libraries + newdependency_libs="$deplib $newdependency_libs" + fi + case "$tmp_libs " in + *" $deplib "*) specialdeplibs="$specialdeplibs $deplib" ;; + esac + tmp_libs="$tmp_libs $deplib" + done # for deplib + continue + fi # $linkmode = prog... + + link_static=no # Whether the deplib will be linked statically + if test -n "$library_names" && + { test "$prefer_static_libs" = no || test -z "$old_library"; }; then + # Link against this shared library + + if test "$linkmode,$pass" = "prog,link" || + { test $linkmode = lib && test $hardcode_into_libs = yes; }; then + # Hardcode the library path. + # Skip directories that are in the system default run-time + # search path. + case " $sys_lib_dlsearch_path " in + *" $absdir "*) ;; + *) + case "$compile_rpath " in + *" $absdir "*) ;; + *) compile_rpath="$compile_rpath $absdir" + esac + ;; + esac + case " $sys_lib_dlsearch_path " in + *" $libdir "*) ;; + *) + case "$finalize_rpath " in + *" $libdir "*) ;; + *) finalize_rpath="$finalize_rpath $libdir" + esac + ;; + esac + if test $linkmode = prog; then + # We need to hardcode the library path + if test -n "$shlibpath_var"; then + # Make sure the rpath contains only unique directories. + case "$temp_rpath " in + *" $dir "*) ;; + *" $absdir "*) ;; + *) temp_rpath="$temp_rpath $dir" ;; + esac + fi + fi + fi # $linkmode,$pass = prog,link... + + if test "$alldeplibs" = yes && + { test "$deplibs_check_method" = pass_all || + { test "$build_libtool_libs" = yes && + test -n "$library_names"; }; }; then + # We only need to search for static libraries + continue + fi + + if test "$installed" = no; then + notinst_deplibs="$notinst_deplibs $lib" + need_relink=yes + fi + + if test -n "$old_archive_from_expsyms_cmds"; then + # figure out the soname + set dummy $library_names + realname="$2" + shift; shift + libname=`eval \\$echo \"$libname_spec\"` + # use dlname if we got it. it's perfectly good, no? + if test -n "$dlname"; then + soname="$dlname" + elif test -n "$soname_spec"; then + # bleh windows + case $host in + *cygwin*) + major=`expr $current - $age` + versuffix="-$major" + ;; + esac + eval soname=\"$soname_spec\" + else + soname="$realname" + fi + + # Make a new name for the extract_expsyms_cmds to use + soroot="$soname" + soname=`echo $soroot | sed -e 's/^.*\///'` + newlib="libimp-`echo $soname | sed 's/^lib//;s/\.dll$//'`.a" + + # If the library has no export list, then create one now + if test -f "$output_objdir/$soname-def"; then : + else + $show "extracting exported symbol list from \`$soname'" + IFS="${IFS= }"; save_ifs="$IFS"; IFS='~' + eval cmds=\"$extract_expsyms_cmds\" + for cmd in $cmds; do + IFS="$save_ifs" + $show "$cmd" + $run eval "$cmd" || exit $? + done + IFS="$save_ifs" + fi + + # Create $newlib + if test -f "$output_objdir/$newlib"; then :; else + $show "generating import library for \`$soname'" + IFS="${IFS= }"; save_ifs="$IFS"; IFS='~' + eval cmds=\"$old_archive_from_expsyms_cmds\" + for cmd in $cmds; do + IFS="$save_ifs" + $show "$cmd" + $run eval "$cmd" || exit $? + done + IFS="$save_ifs" + fi + # make sure the library variables are pointing to the new library + dir=$output_objdir + linklib=$newlib + fi # test -n $old_archive_from_expsyms_cmds + + if test $linkmode = prog || test "$mode" != relink; then + add_shlibpath= + add_dir= + add= + lib_linked=yes + case $hardcode_action in + immediate | unsupported) + if test "$hardcode_direct" = no; then + add="$dir/$linklib" + elif test "$hardcode_minus_L" = no; then + case $host in + *-*-sunos*) add_shlibpath="$dir" ;; + esac + add_dir="-L$dir" + add="-l$name" + elif test "$hardcode_shlibpath_var" = no; then + add_shlibpath="$dir" + add="-l$name" + else + lib_linked=no + fi + ;; + relink) + if test "$hardcode_direct" = yes; then + add="$dir/$linklib" + elif test "$hardcode_minus_L" = yes; then + add_dir="-L$dir" + add="-l$name" + elif test "$hardcode_shlibpath_var" = yes; then + add_shlibpath="$dir" + add="-l$name" + else + lib_linked=no + fi + ;; + *) lib_linked=no ;; + esac + + if test "$lib_linked" != yes; then + $echo "$modename: configuration error: unsupported hardcode properties" + exit 1 + fi + + if test -n "$add_shlibpath"; then + case :$compile_shlibpath: in + *":$add_shlibpath:"*) ;; + *) compile_shlibpath="$compile_shlibpath$add_shlibpath:" ;; + esac + fi + if test $linkmode = prog; then + test -n "$add_dir" && compile_deplibs="$add_dir $compile_deplibs" + test -n "$add" && compile_deplibs="$add $compile_deplibs" + else + test -n "$add_dir" && deplibs="$add_dir $deplibs" + test -n "$add" && deplibs="$add $deplibs" + if test "$hardcode_direct" != yes && \ + test "$hardcode_minus_L" != yes && \ + test "$hardcode_shlibpath_var" = yes; then + case :$finalize_shlibpath: in + *":$libdir:"*) ;; + *) finalize_shlibpath="$finalize_shlibpath$libdir:" ;; + esac + fi + fi + fi + + if test $linkmode = prog || test "$mode" = relink; then + add_shlibpath= + add_dir= + add= + # Finalize command for both is simple: just hardcode it. + if test "$hardcode_direct" = yes; then + add="$libdir/$linklib" + elif test "$hardcode_minus_L" = yes; then + add_dir="-L$libdir" + add="-l$name" + elif test "$hardcode_shlibpath_var" = yes; then + case :$finalize_shlibpath: in + *":$libdir:"*) ;; + *) finalize_shlibpath="$finalize_shlibpath$libdir:" ;; + esac + add="-l$name" + else + # We cannot seem to hardcode it, guess we'll fake it. + add_dir="-L$libdir" + add="-l$name" + fi + + if test $linkmode = prog; then + test -n "$add_dir" && finalize_deplibs="$add_dir $finalize_deplibs" + test -n "$add" && finalize_deplibs="$add $finalize_deplibs" + else + test -n "$add_dir" && deplibs="$add_dir $deplibs" + test -n "$add" && deplibs="$add $deplibs" + fi + fi + elif test $linkmode = prog; then + if test "$alldeplibs" = yes && + { test "$deplibs_check_method" = pass_all || + { test "$build_libtool_libs" = yes && + test -n "$library_names"; }; }; then + # We only need to search for static libraries + continue + fi + + # Try to link the static library + # Here we assume that one of hardcode_direct or hardcode_minus_L + # is not unsupported. This is valid on all known static and + # shared platforms. + if test "$hardcode_direct" != unsupported; then + test -n "$old_library" && linklib="$old_library" + compile_deplibs="$dir/$linklib $compile_deplibs" + finalize_deplibs="$dir/$linklib $finalize_deplibs" + else + compile_deplibs="-l$name -L$dir $compile_deplibs" + finalize_deplibs="-l$name -L$dir $finalize_deplibs" + fi + elif test "$build_libtool_libs" = yes; then + # Not a shared library + if test "$deplibs_check_method" != pass_all; then + # We're trying link a shared library against a static one + # but the system doesn't support it. + + # Just print a warning and add the library to dependency_libs so + # that the program can be linked against the static library. + echo + echo "*** Warning: This library needs some functionality provided by $lib." + echo "*** I have the capability to make that library automatically link in when" + echo "*** you link to this library. But I can only do this if you have a" + echo "*** shared version of the library, which you do not appear to have." + if test "$module" = yes; then + echo "*** Therefore, libtool will create a static module, that should work " + echo "*** as long as the dlopening application is linked with the -dlopen flag." + if test -z "$global_symbol_pipe"; then + echo + echo "*** However, this would only work if libtool was able to extract symbol" + echo "*** lists from a program, using \`nm' or equivalent, but libtool could" + echo "*** not find such a program. So, this module is probably useless." + echo "*** \`nm' from GNU binutils and a full rebuild may help." + fi + if test "$build_old_libs" = no; then + build_libtool_libs=module + build_old_libs=yes + else + build_libtool_libs=no + fi + fi + else + convenience="$convenience $dir/$old_library" + old_convenience="$old_convenience $dir/$old_library" + deplibs="$dir/$old_library $deplibs" + link_static=yes + fi + fi # link shared/static library? + + if test $linkmode = lib; then + if test -n "$dependency_libs" && + { test $hardcode_into_libs != yes || test $build_old_libs = yes || + test $link_static = yes; }; then + # Extract -R from dependency_libs + temp_deplibs= + for libdir in $dependency_libs; do + case $libdir in + -R*) temp_xrpath=`$echo "X$libdir" | $Xsed -e 's/^-R//'` + case " $xrpath " in + *" $temp_xrpath "*) ;; + *) xrpath="$xrpath $temp_xrpath";; + esac;; + *) temp_deplibs="$temp_deplibs $libdir";; + esac + done + dependency_libs="$temp_deplibs" + fi + + newlib_search_path="$newlib_search_path $absdir" + # Link against this library + test "$link_static" = no && newdependency_libs="$abs_ladir/$laname $newdependency_libs" + # ... and its dependency_libs + tmp_libs= + for deplib in $dependency_libs; do + newdependency_libs="$deplib $newdependency_libs" + case "$tmp_libs " in + *" $deplib "*) specialdeplibs="$specialdeplibs $deplib" ;; + esac + tmp_libs="$tmp_libs $deplib" + done + + if test $link_all_deplibs != no; then + # Add the search paths of all dependency libraries + for deplib in $dependency_libs; do + case $deplib in + -L*) path="$deplib" ;; + *.la) + dir=`$echo "X$deplib" | $Xsed -e 's%/[^/]*$%%'` + test "X$dir" = "X$deplib" && dir="." + # We need an absolute path. + case $dir in + [\\/]* | [A-Za-z]:[\\/]*) absdir="$dir" ;; + *) + absdir=`cd "$dir" && pwd` + if test -z "$absdir"; then + $echo "$modename: warning: cannot determine absolute directory name of \`$dir'" 1>&2 + absdir="$dir" + fi + ;; + esac + if grep "^installed=no" $deplib > /dev/null; then + path="-L$absdir/$objdir" + else + eval libdir=`sed -n -e 's/^libdir=\(.*\)$/\1/p' $deplib` + if test -z "$libdir"; then + $echo "$modename: \`$deplib' is not a valid libtool archive" 1>&2 + exit 1 + fi + if test "$absdir" != "$libdir"; then + $echo "$modename: warning: \`$deplib' seems to be moved" 1>&2 + fi + path="-L$absdir" + fi + ;; + *) continue ;; + esac + case " $deplibs " in + *" $path "*) ;; + *) deplibs="$path $deplibs" ;; + esac + done + fi # link_all_deplibs != no + fi # linkmode = lib + done # for deplib in $libs + if test $pass = dlpreopen; then + # Link the dlpreopened libraries before other libraries + for deplib in $save_deplibs; do + deplibs="$deplib $deplibs" + done + fi + if test $pass != dlopen; then + test $pass != scan && dependency_libs="$newdependency_libs" + if test $pass != conv; then + # Make sure lib_search_path contains only unique directories. + lib_search_path= + for dir in $newlib_search_path; do + case "$lib_search_path " in + *" $dir "*) ;; + *) lib_search_path="$lib_search_path $dir" ;; + esac + done + newlib_search_path= + fi + + if test "$linkmode,$pass" != "prog,link"; then + vars="deplibs" + else + vars="compile_deplibs finalize_deplibs" + fi + for var in $vars dependency_libs; do + # Add libraries to $var in reverse order + eval tmp_libs=\"\$$var\" + new_libs= + for deplib in $tmp_libs; do + case $deplib in + -L*) new_libs="$deplib $new_libs" ;; + *) + case " $specialdeplibs " in + *" $deplib "*) new_libs="$deplib $new_libs" ;; + *) + case " $new_libs " in + *" $deplib "*) ;; + *) new_libs="$deplib $new_libs" ;; + esac + ;; + esac + ;; + esac + done + tmp_libs= + for deplib in $new_libs; do + case $deplib in + -L*) + case " $tmp_libs " in + *" $deplib "*) ;; + *) tmp_libs="$tmp_libs $deplib" ;; + esac + ;; + *) tmp_libs="$tmp_libs $deplib" ;; + esac + done + eval $var=\"$tmp_libs\" + done # for var + fi + if test "$pass" = "conv" && + { test "$linkmode" = "lib" || test "$linkmode" = "prog"; }; then + libs="$deplibs" # reset libs + deplibs= + fi + done # for pass + if test $linkmode = prog; then + dlfiles="$newdlfiles" + dlprefiles="$newdlprefiles" + fi + + case $linkmode in + oldlib) + if test -n "$dlfiles$dlprefiles" || test "$dlself" != no; then + $echo "$modename: warning: \`-dlopen' is ignored for archives" 1>&2 + fi + + if test -n "$rpath"; then + $echo "$modename: warning: \`-rpath' is ignored for archives" 1>&2 + fi + + if test -n "$xrpath"; then + $echo "$modename: warning: \`-R' is ignored for archives" 1>&2 + fi + + if test -n "$vinfo"; then + $echo "$modename: warning: \`-version-info' is ignored for archives" 1>&2 + fi + + if test -n "$release"; then + $echo "$modename: warning: \`-release' is ignored for archives" 1>&2 + fi + + if test -n "$export_symbols" || test -n "$export_symbols_regex"; then + $echo "$modename: warning: \`-export-symbols' is ignored for archives" 1>&2 + fi + + # Now set the variables for building old libraries. + build_libtool_libs=no + oldlibs="$output" + objs="$objs$old_deplibs" + ;; + + lib) + # Make sure we only generate libraries of the form `libNAME.la'. + case $outputname in + lib*) + name=`$echo "X$outputname" | $Xsed -e 's/\.la$//' -e 's/^lib//'` + eval libname=\"$libname_spec\" + ;; + *) + if test "$module" = no; then + $echo "$modename: libtool library \`$output' must begin with \`lib'" 1>&2 + $echo "$help" 1>&2 + exit 1 + fi + if test "$need_lib_prefix" != no; then + # Add the "lib" prefix for modules if required + name=`$echo "X$outputname" | $Xsed -e 's/\.la$//'` + eval libname=\"$libname_spec\" + else + libname=`$echo "X$outputname" | $Xsed -e 's/\.la$//'` + fi + ;; + esac + + if test -n "$objs"; then + if test "$deplibs_check_method" != pass_all; then + $echo "$modename: cannot build libtool library \`$output' from non-libtool objects on this host:$objs" 2>&1 + exit 1 + else + echo + echo "*** Warning: Linking the shared library $output against the non-libtool" + echo "*** objects $objs is not portable!" + libobjs="$libobjs $objs" + fi + fi + + if test "$dlself" != no; then + $echo "$modename: warning: \`-dlopen self' is ignored for libtool libraries" 1>&2 + fi + + set dummy $rpath + if test $# -gt 2; then + $echo "$modename: warning: ignoring multiple \`-rpath's for a libtool library" 1>&2 + fi + install_libdir="$2" + + oldlibs= + if test -z "$rpath"; then + if test "$build_libtool_libs" = yes; then + # Building a libtool convenience library. + # Some compilers have problems with a `.al' extension so + # convenience libraries should have the same extension an + # archive normally would. + oldlibs="$output_objdir/$libname.$libext $oldlibs" + build_libtool_libs=convenience + build_old_libs=yes + fi + + if test -n "$vinfo"; then + $echo "$modename: warning: \`-version-info' is ignored for convenience libraries" 1>&2 + fi + + if test -n "$release"; then + $echo "$modename: warning: \`-release' is ignored for convenience libraries" 1>&2 + fi + else + + # Parse the version information argument. + IFS="${IFS= }"; save_ifs="$IFS"; IFS=':' + set dummy $vinfo 0 0 0 + IFS="$save_ifs" + + if test -n "$8"; then + $echo "$modename: too many parameters to \`-version-info'" 1>&2 + $echo "$help" 1>&2 + exit 1 + fi + + current="$2" + revision="$3" + age="$4" + + # Check that each of the things are valid numbers. + case $current in + 0 | [1-9] | [1-9][0-9] | [1-9][0-9][0-9]) ;; + *) + $echo "$modename: CURRENT \`$current' is not a nonnegative integer" 1>&2 + $echo "$modename: \`$vinfo' is not valid version information" 1>&2 + exit 1 + ;; + esac + + case $revision in + 0 | [1-9] | [1-9][0-9] | [1-9][0-9][0-9]) ;; + *) + $echo "$modename: REVISION \`$revision' is not a nonnegative integer" 1>&2 + $echo "$modename: \`$vinfo' is not valid version information" 1>&2 + exit 1 + ;; + esac + + case $age in + 0 | [1-9] | [1-9][0-9] | [1-9][0-9][0-9]) ;; + *) + $echo "$modename: AGE \`$age' is not a nonnegative integer" 1>&2 + $echo "$modename: \`$vinfo' is not valid version information" 1>&2 + exit 1 + ;; + esac + + if test $age -gt $current; then + $echo "$modename: AGE \`$age' is greater than the current interface number \`$current'" 1>&2 + $echo "$modename: \`$vinfo' is not valid version information" 1>&2 + exit 1 + fi + + # Calculate the version variables. + major= + versuffix= + verstring= + case $version_type in + none) ;; + + darwin) + # Like Linux, but with the current version available in + # verstring for coding it into the library header + major=.`expr $current - $age` + versuffix="$major.$age.$revision" + # Darwin ld doesn't like 0 for these options... + minor_current=`expr $current + 1` + verstring="-compatibility_version $minor_current -current_version $minor_current.$revision" + ;; + + freebsd-aout) + major=".$current" + versuffix=".$current.$revision"; + ;; + + freebsd-elf) + major=".$current" + versuffix=".$current"; + ;; + + irix) + major=`expr $current - $age + 1` + verstring="sgi$major.$revision" + + # Add in all the interfaces that we are compatible with. + loop=$revision + while test $loop != 0; do + iface=`expr $revision - $loop` + loop=`expr $loop - 1` + verstring="sgi$major.$iface:$verstring" + done + + # Before this point, $major must not contain `.'. + major=.$major + versuffix="$major.$revision" + ;; + + linux) + major=.`expr $current - $age` + versuffix="$major.$age.$revision" + ;; + + osf) + major=`expr $current - $age` + versuffix=".$current.$age.$revision" + verstring="$current.$age.$revision" + + # Add in all the interfaces that we are compatible with. + loop=$age + while test $loop != 0; do + iface=`expr $current - $loop` + loop=`expr $loop - 1` + verstring="$verstring:${iface}.0" + done + + # Make executables depend on our current version. + verstring="$verstring:${current}.0" + ;; + + sunos) + major=".$current" + versuffix=".$current.$revision" + ;; + + windows) + # Use '-' rather than '.', since we only want one + # extension on DOS 8.3 filesystems. + major=`expr $current - $age` + versuffix="-$major" + ;; + + *) + $echo "$modename: unknown library version type \`$version_type'" 1>&2 + echo "Fatal configuration error. See the $PACKAGE docs for more information." 1>&2 + exit 1 + ;; + esac + + # Clear the version info if we defaulted, and they specified a release. + if test -z "$vinfo" && test -n "$release"; then + major= + verstring="0.0" + if test "$need_version" = no; then + versuffix= + else + versuffix=".0.0" + fi + fi + + # Remove version info from name if versioning should be avoided + if test "$avoid_version" = yes && test "$need_version" = no; then + major= + versuffix= + verstring="" + fi + + # Check to see if the archive will have undefined symbols. + if test "$allow_undefined" = yes; then + if test "$allow_undefined_flag" = unsupported; then + $echo "$modename: warning: undefined symbols not allowed in $host shared libraries" 1>&2 + build_libtool_libs=no + build_old_libs=yes + fi + else + # Don't allow undefined symbols. + allow_undefined_flag="$no_undefined_flag" + fi + fi + + if test "$mode" != relink; then + # Remove our outputs, but don't remove object files since they + # may have been created when compiling PIC objects. + removelist= + tempremovelist=`echo "$output_objdir/*"` + for p in $tempremovelist; do + case $p in + *.$objext) + ;; + $output_objdir/$outputname | $output_objdir/$libname.* | $output_objdir/${libname}${release}.*) + removelist="$removelist $p" + ;; + *) ;; + esac + done + if test -n "$removelist"; then + $show "${rm}r $removelist" + $run ${rm}r $removelist + fi + fi + + # Now set the variables for building old libraries. + if test "$build_old_libs" = yes && test "$build_libtool_libs" != convenience ; then + oldlibs="$oldlibs $output_objdir/$libname.$libext" + + # Transform .lo files to .o files. + oldobjs="$objs "`$echo "X$libobjs" | $SP2NL | $Xsed -e '/\.'${libext}'$/d' -e "$lo2o" | $NL2SP` + fi + + # Eliminate all temporary directories. + for path in $notinst_path; do + lib_search_path=`echo "$lib_search_path " | sed -e 's% $path % %g'` + deplibs=`echo "$deplibs " | sed -e 's% -L$path % %g'` + dependency_libs=`echo "$dependency_libs " | sed -e 's% -L$path % %g'` + done + + if test -n "$xrpath"; then + # If the user specified any rpath flags, then add them. + temp_xrpath= + for libdir in $xrpath; do + temp_xrpath="$temp_xrpath -R$libdir" + case "$finalize_rpath " in + *" $libdir "*) ;; + *) finalize_rpath="$finalize_rpath $libdir" ;; + esac + done + if test $hardcode_into_libs != yes || test $build_old_libs = yes; then + dependency_libs="$temp_xrpath $dependency_libs" + fi + fi + + # Make sure dlfiles contains only unique files that won't be dlpreopened + old_dlfiles="$dlfiles" + dlfiles= + for lib in $old_dlfiles; do + case " $dlprefiles $dlfiles " in + *" $lib "*) ;; + *) dlfiles="$dlfiles $lib" ;; + esac + done + + # Make sure dlprefiles contains only unique files + old_dlprefiles="$dlprefiles" + dlprefiles= + for lib in $old_dlprefiles; do + case "$dlprefiles " in + *" $lib "*) ;; + *) dlprefiles="$dlprefiles $lib" ;; + esac + done + + if test "$build_libtool_libs" = yes; then + if test -n "$rpath"; then + case $host in + *-*-cygwin* | *-*-mingw* | *-*-pw32* | *-*-os2* | *-*-beos*) + # these systems don't actually have a c library (as such)! + ;; + *-*-rhapsody* | *-*-darwin1.[012]) + # Rhapsody C library is in the System framework + deplibs="$deplibs -framework System" + ;; + *-*-netbsd*) + # Don't link with libc until the a.out ld.so is fixed. + ;; + *) + # Add libc to deplibs on all other systems if necessary. + if test $build_libtool_need_lc = "yes"; then + deplibs="$deplibs -lc" + fi + ;; + esac + fi + + # Transform deplibs into only deplibs that can be linked in shared. + name_save=$name + libname_save=$libname + release_save=$release + versuffix_save=$versuffix + major_save=$major + # I'm not sure if I'm treating the release correctly. I think + # release should show up in the -l (ie -lgmp5) so we don't want to + # add it in twice. Is that correct? + release="" + versuffix="" + major="" + newdeplibs= + droppeddeps=no + case $deplibs_check_method in + pass_all) + # Don't check for shared/static. Everything works. + # This might be a little naive. We might want to check + # whether the library exists or not. But this is on + # osf3 & osf4 and I'm not really sure... Just + # implementing what was already the behaviour. + newdeplibs=$deplibs + ;; + test_compile) + # This code stresses the "libraries are programs" paradigm to its + # limits. Maybe even breaks it. We compile a program, linking it + # against the deplibs as a proxy for the library. Then we can check + # whether they linked in statically or dynamically with ldd. + $rm conftest.c + cat > conftest.c </dev/null` + for potent_lib in $potential_libs; do + # Follow soft links. + if ls -lLd "$potent_lib" 2>/dev/null \ + | grep " -> " >/dev/null; then + continue + fi + # The statement above tries to avoid entering an + # endless loop below, in case of cyclic links. + # We might still enter an endless loop, since a link + # loop can be closed while we follow links, + # but so what? + potlib="$potent_lib" + while test -h "$potlib" 2>/dev/null; do + potliblink=`ls -ld $potlib | sed 's/.* -> //'` + case $potliblink in + [\\/]* | [A-Za-z]:[\\/]*) potlib="$potliblink";; + *) potlib=`$echo "X$potlib" | $Xsed -e 's,[^/]*$,,'`"$potliblink";; + esac + done + # It is ok to link against an archive when + # building a shared library. + if $AR -t $potlib > /dev/null 2>&1; then + newdeplibs="$newdeplibs $a_deplib" + a_deplib="" + break 2 + fi + if eval $file_magic_cmd \"\$potlib\" 2>/dev/null \ + | sed 10q \ + | egrep "$file_magic_regex" > /dev/null; then + newdeplibs="$newdeplibs $a_deplib" + a_deplib="" + break 2 + fi + done + done + if test -n "$a_deplib" ; then + droppeddeps=yes + echo + echo "*** Warning: This library needs some functionality provided by $a_deplib." + echo "*** I have the capability to make that library automatically link in when" + echo "*** you link to this library. But I can only do this if you have a" + echo "*** shared version of the library, which you do not appear to have." + fi + else + # Add a -L argument. + newdeplibs="$newdeplibs $a_deplib" + fi + done # Gone through all deplibs. + ;; + match_pattern*) + set dummy $deplibs_check_method + match_pattern_regex=`expr "$deplibs_check_method" : "$2 \(.*\)"` + for a_deplib in $deplibs; do + name="`expr $a_deplib : '-l\(.*\)'`" + # If $name is empty we are operating on a -L argument. + if test -n "$name" && test "$name" != "0"; then + libname=`eval \\$echo \"$libname_spec\"` + for i in $lib_search_path $sys_lib_search_path $shlib_search_path; do + potential_libs=`ls $i/$libname[.-]* 2>/dev/null` + for potent_lib in $potential_libs; do + if eval echo \"$potent_lib\" 2>/dev/null \ + | sed 10q \ + | egrep "$match_pattern_regex" > /dev/null; then + newdeplibs="$newdeplibs $a_deplib" + a_deplib="" + break 2 + fi + done + done + if test -n "$a_deplib" ; then + droppeddeps=yes + echo + echo "*** Warning: This library needs some functionality provided by $a_deplib." + echo "*** I have the capability to make that library automatically link in when" + echo "*** you link to this library. But I can only do this if you have a" + echo "*** shared version of the library, which you do not appear to have." + fi + else + # Add a -L argument. + newdeplibs="$newdeplibs $a_deplib" + fi + done # Gone through all deplibs. + ;; + none | unknown | *) + newdeplibs="" + if $echo "X $deplibs" | $Xsed -e 's/ -lc$//' \ + -e 's/ -[LR][^ ]*//g' -e 's/[ ]//g' | + grep . >/dev/null; then + echo + if test "X$deplibs_check_method" = "Xnone"; then + echo "*** Warning: inter-library dependencies are not supported in this platform." + else + echo "*** Warning: inter-library dependencies are not known to be supported." + fi + echo "*** All declared inter-library dependencies are being dropped." + droppeddeps=yes + fi + ;; + esac + versuffix=$versuffix_save + major=$major_save + release=$release_save + libname=$libname_save + name=$name_save + + case $host in + *-*-rhapsody* | *-*-darwin1.[012]) + # On Rhapsody replace the C library is the System framework + newdeplibs=`$echo "X $newdeplibs" | $Xsed -e 's/ -lc / -framework System /'` + ;; + esac + + if test "$droppeddeps" = yes; then + if test "$module" = yes; then + echo + echo "*** Warning: libtool could not satisfy all declared inter-library" + echo "*** dependencies of module $libname. Therefore, libtool will create" + echo "*** a static module, that should work as long as the dlopening" + echo "*** application is linked with the -dlopen flag." + if test -z "$global_symbol_pipe"; then + echo + echo "*** However, this would only work if libtool was able to extract symbol" + echo "*** lists from a program, using \`nm' or equivalent, but libtool could" + echo "*** not find such a program. So, this module is probably useless." + echo "*** \`nm' from GNU binutils and a full rebuild may help." + fi + if test "$build_old_libs" = no; then + oldlibs="$output_objdir/$libname.$libext" + build_libtool_libs=module + build_old_libs=yes + else + build_libtool_libs=no + fi + else + echo "*** The inter-library dependencies that have been dropped here will be" + echo "*** automatically added whenever a program is linked with this library" + echo "*** or is declared to -dlopen it." + + if test $allow_undefined = no; then + echo + echo "*** Since this library must not contain undefined symbols," + echo "*** because either the platform does not support them or" + echo "*** it was explicitly requested with -no-undefined," + echo "*** libtool will only create a static version of it." + if test "$build_old_libs" = no; then + oldlibs="$output_objdir/$libname.$libext" + build_libtool_libs=module + build_old_libs=yes + else + build_libtool_libs=no + fi + fi + fi + fi + # Done checking deplibs! + deplibs=$newdeplibs + fi + + # All the library-specific variables (install_libdir is set above). + library_names= + old_library= + dlname= + + # Test again, we may have decided not to build it any more + if test "$build_libtool_libs" = yes; then + if test $hardcode_into_libs = yes; then + # Hardcode the library paths + hardcode_libdirs= + dep_rpath= + rpath="$finalize_rpath" + test "$mode" != relink && rpath="$compile_rpath$rpath" + for libdir in $rpath; do + if test -n "$hardcode_libdir_flag_spec"; then + if test -n "$hardcode_libdir_separator"; then + if test -z "$hardcode_libdirs"; then + hardcode_libdirs="$libdir" + else + # Just accumulate the unique libdirs. + case $hardcode_libdir_separator$hardcode_libdirs$hardcode_libdir_separator in + *"$hardcode_libdir_separator$libdir$hardcode_libdir_separator"*) + ;; + *) + hardcode_libdirs="$hardcode_libdirs$hardcode_libdir_separator$libdir" + ;; + esac + fi + else + eval flag=\"$hardcode_libdir_flag_spec\" + dep_rpath="$dep_rpath $flag" + fi + elif test -n "$runpath_var"; then + case "$perm_rpath " in + *" $libdir "*) ;; + *) perm_rpath="$perm_rpath $libdir" ;; + esac + fi + done + # Substitute the hardcoded libdirs into the rpath. + if test -n "$hardcode_libdir_separator" && + test -n "$hardcode_libdirs"; then + libdir="$hardcode_libdirs" + eval dep_rpath=\"$hardcode_libdir_flag_spec\" + fi + if test -n "$runpath_var" && test -n "$perm_rpath"; then + # We should set the runpath_var. + rpath= + for dir in $perm_rpath; do + rpath="$rpath$dir:" + done + eval "$runpath_var='$rpath\$$runpath_var'; export $runpath_var" + fi + test -n "$dep_rpath" && deplibs="$dep_rpath $deplibs" + fi + + shlibpath="$finalize_shlibpath" + test "$mode" != relink && shlibpath="$compile_shlibpath$shlibpath" + if test -n "$shlibpath"; then + eval "$shlibpath_var='$shlibpath\$$shlibpath_var'; export $shlibpath_var" + fi + + # Get the real and link names of the library. + eval library_names=\"$library_names_spec\" + set dummy $library_names + realname="$2" + shift; shift + + if test -n "$soname_spec"; then + eval soname=\"$soname_spec\" + else + soname="$realname" + fi + test -z "$dlname" && dlname=$soname + + lib="$output_objdir/$realname" + for link + do + linknames="$linknames $link" + done + +# # Ensure that we have .o objects for linkers which dislike .lo +# # (e.g. aix) in case we are running --disable-static +# for obj in $libobjs; do +# xdir=`$echo "X$obj" | $Xsed -e 's%/[^/]*$%%'` +# if test "X$xdir" = "X$obj"; then +# xdir="." +# else +# xdir="$xdir" +# fi +# baseobj=`$echo "X$obj" | $Xsed -e 's%^.*/%%'` +# oldobj=`$echo "X$baseobj" | $Xsed -e "$lo2o"` +# if test ! -f $xdir/$oldobj && test "$baseobj" != "$oldobj"; then +# $show "(cd $xdir && ${LN_S} $baseobj $oldobj)" +# $run eval '(cd $xdir && ${LN_S} $baseobj $oldobj)' || exit $? +# fi +# done + + # Use standard objects if they are pic + test -z "$pic_flag" && libobjs=`$echo "X$libobjs" | $SP2NL | $Xsed -e "$lo2o" | $NL2SP` + + # Prepare the list of exported symbols + if test -z "$export_symbols"; then + if test "$always_export_symbols" = yes || test -n "$export_symbols_regex"; then + $show "generating symbol list for \`$libname.la'" + export_symbols="$output_objdir/$libname.exp" + $run $rm $export_symbols + eval cmds=\"$export_symbols_cmds\" + IFS="${IFS= }"; save_ifs="$IFS"; IFS='~' + for cmd in $cmds; do + IFS="$save_ifs" + $show "$cmd" + $run eval "$cmd" || exit $? + done + IFS="$save_ifs" + if test -n "$export_symbols_regex"; then + $show "egrep -e \"$export_symbols_regex\" \"$export_symbols\" > \"${export_symbols}T\"" + $run eval 'egrep -e "$export_symbols_regex" "$export_symbols" > "${export_symbols}T"' + $show "$mv \"${export_symbols}T\" \"$export_symbols\"" + $run eval '$mv "${export_symbols}T" "$export_symbols"' + fi + fi + fi + + if test -n "$export_symbols" && test -n "$include_expsyms"; then + $run eval '$echo "X$include_expsyms" | $SP2NL >> "$export_symbols"' + fi + + if test -n "$convenience"; then + if test -n "$whole_archive_flag_spec"; then + save_libobjs=$libobjs + eval libobjs=\"\$libobjs $whole_archive_flag_spec\" + else + gentop="$output_objdir/${outputname}x" + $show "${rm}r $gentop" + $run ${rm}r "$gentop" + $show "$mkdir $gentop" + $run $mkdir "$gentop" + status=$? + if test $status -ne 0 && test ! -d "$gentop"; then + exit $status + fi + generated="$generated $gentop" + + for xlib in $convenience; do + # Extract the objects. + case $xlib in + [\\/]* | [A-Za-z]:[\\/]*) xabs="$xlib" ;; + *) xabs=`pwd`"/$xlib" ;; + esac + xlib=`$echo "X$xlib" | $Xsed -e 's%^.*/%%'` + xdir="$gentop/$xlib" + + $show "${rm}r $xdir" + $run ${rm}r "$xdir" + $show "$mkdir $xdir" + $run $mkdir "$xdir" + status=$? + if test $status -ne 0 && test ! -d "$xdir"; then + exit $status + fi + $show "(cd $xdir && $AR x $xabs)" + $run eval "(cd \$xdir && $AR x \$xabs)" || exit $? + + libobjs="$libobjs "`find $xdir -name \*.$objext -print -o -name \*.lo -print | $NL2SP` + done + fi + fi + + if test "$thread_safe" = yes && test -n "$thread_safe_flag_spec"; then + eval flag=\"$thread_safe_flag_spec\" + linker_flags="$linker_flags $flag" + fi + + # Make a backup of the uninstalled library when relinking + if test "$mode" = relink; then + $run eval '(cd $output_objdir && $rm ${realname}U && $mv $realname ${realname}U)' || exit $? + fi + + # Do each of the archive commands. + if test -n "$export_symbols" && test -n "$archive_expsym_cmds"; then + eval cmds=\"$archive_expsym_cmds\" + else + eval cmds=\"$archive_cmds\" + fi + if len=`expr "X$cmds" : ".*"` && + test $len -le $max_cmd_len; then + : + else + # The command line is too long to link in one step, link piecewise. + $echo "creating reloadable object files..." + + # Save the value of $output and $libobjs because we want to + # use them later. If we have whole_archive_flag_spec, we + # want to use save_libobjs as it was before + # whole_archive_flag_spec was expanded, because we can't + # assume the linker understands whole_archive_flag_spec. + # This may have to be revisited, in case too many + # convenience libraries get linked in and end up exceeding + # the spec. + if test -z "$convenience" || test -z "$whole_archive_flag_spec"; then + save_libobjs=$libobjs + fi + save_output=$output + + # Clear the reloadable object creation command queue and + # initialize k to one. + test_cmds= + concat_cmds= + objlist= + delfiles= + last_robj= + k=1 + output=$output_objdir/$save_output-${k}.$objext + # Loop over the list of objects to be linked. + for obj in $save_libobjs + do + eval test_cmds=\"$reload_cmds $objlist $last_robj\" + if test "X$objlist" = X || + { len=`expr "X$test_cmds" : ".*"` && + test $len -le $max_cmd_len; }; then + objlist="$objlist $obj" + else + # The command $test_cmds is almost too long, add a + # command to the queue. + if test $k -eq 1 ; then + # The first file doesn't have a previous command to add. + eval concat_cmds=\"$reload_cmds $objlist $last_robj\" + else + # All subsequent reloadable object files will link in + # the last one created. + eval concat_cmds=\"\$concat_cmds~$reload_cmds $objlist $last_robj\" + fi + last_robj=$output_objdir/$save_output-${k}.$objext + k=`expr $k + 1` + output=$output_objdir/$save_output-${k}.$objext + objlist=$obj + len=1 + fi + done + # Handle the remaining objects by creating one last + # reloadable object file. All subsequent reloadable object + # files will link in the last one created. + test -z "$concat_cmds" || concat_cmds=$concat_cmds~ + eval concat_cmds=\"\${concat_cmds}$reload_cmds $objlist $last_robj\" + + # Set up a command to remove the reloadale object files + # after they are used. + i=0 + while test $i -lt $k + do + i=`expr $i + 1` + delfiles="$delfiles $output_objdir/$save_output-${i}.$objext" + done + + $echo "creating a temporary reloadable object file: $output" + + # Loop through the commands generated above and execute them. + IFS="${IFS= }"; save_ifs="$IFS"; IFS='~' + for cmd in $concat_cmds; do + IFS="$save_ifs" + $show "$cmd" + $run eval "$cmd" || exit $? + done + IFS="$save_ifs" + + libobjs=$output + # Restore the value of output. + output=$save_output + + if test -n "$convenience" && test -n "$whole_archive_flag_spec"; then + eval libobjs=\"\$libobjs $whole_archive_flag_spec\" + fi + # Expand the library linking commands again to reset the + # value of $libobjs for piecewise linking. + + # Do each of the archive commands. + if test -n "$export_symbols" && test -n "$archive_expsym_cmds"; then + eval cmds=\"$archive_expsym_cmds\" + else + eval cmds=\"$archive_cmds\" + fi + + # Append the command to remove the reloadable object files + # to the just-reset $cmds. + eval cmds=\"\$cmds~$rm $delfiles\" + fi + IFS="${IFS= }"; save_ifs="$IFS"; IFS='~' + for cmd in $cmds; do + IFS="$save_ifs" + $show "$cmd" + $run eval "$cmd" || exit $? + done + IFS="$save_ifs" + + # Restore the uninstalled library and exit + if test "$mode" = relink; then + $run eval '(cd $output_objdir && $rm ${realname}T && $mv $realname ${realname}T && $mv "$realname"U $realname)' || exit $? + exit 0 + fi + + # Create links to the real library. + for linkname in $linknames; do + if test "$realname" != "$linkname"; then + $show "(cd $output_objdir && $rm $linkname && $LN_S $realname $linkname)" + $run eval '(cd $output_objdir && $rm $linkname && $LN_S $realname $linkname)' || exit $? + fi + done + + # If -module or -export-dynamic was specified, set the dlname. + if test "$module" = yes || test "$export_dynamic" = yes; then + # On all known operating systems, these are identical. + dlname="$soname" + fi + fi + ;; + + obj) + if test -n "$deplibs"; then + $echo "$modename: warning: \`-l' and \`-L' are ignored for objects" 1>&2 + fi + + if test -n "$dlfiles$dlprefiles" || test "$dlself" != no; then + $echo "$modename: warning: \`-dlopen' is ignored for objects" 1>&2 + fi + + if test -n "$rpath"; then + $echo "$modename: warning: \`-rpath' is ignored for objects" 1>&2 + fi + + if test -n "$xrpath"; then + $echo "$modename: warning: \`-R' is ignored for objects" 1>&2 + fi + + if test -n "$vinfo"; then + $echo "$modename: warning: \`-version-info' is ignored for objects" 1>&2 + fi + + if test -n "$release"; then + $echo "$modename: warning: \`-release' is ignored for objects" 1>&2 + fi + + case $output in + *.lo) + if test -n "$objs$old_deplibs"; then + $echo "$modename: cannot build library object \`$output' from non-libtool objects" 1>&2 + exit 1 + fi + libobj="$output" + obj=`$echo "X$output" | $Xsed -e "$lo2o"` + ;; + *) + libobj= + obj="$output" + ;; + esac + + # Delete the old objects. + $run $rm $obj $libobj + + # Objects from convenience libraries. This assumes + # single-version convenience libraries. Whenever we create + # different ones for PIC/non-PIC, this we'll have to duplicate + # the extraction. + reload_conv_objs= + gentop= + # reload_cmds runs $LD directly, so let us get rid of + # -Wl from whole_archive_flag_spec + wl= + + if test -n "$convenience"; then + if test -n "$whole_archive_flag_spec"; then + eval reload_conv_objs=\"\$reload_objs $whole_archive_flag_spec\" + else + gentop="$output_objdir/${obj}x" + $show "${rm}r $gentop" + $run ${rm}r "$gentop" + $show "$mkdir $gentop" + $run $mkdir "$gentop" + status=$? + if test $status -ne 0 && test ! -d "$gentop"; then + exit $status + fi + generated="$generated $gentop" + + for xlib in $convenience; do + # Extract the objects. + case $xlib in + [\\/]* | [A-Za-z]:[\\/]*) xabs="$xlib" ;; + *) xabs=`pwd`"/$xlib" ;; + esac + xlib=`$echo "X$xlib" | $Xsed -e 's%^.*/%%'` + xdir="$gentop/$xlib" + + $show "${rm}r $xdir" + $run ${rm}r "$xdir" + $show "$mkdir $xdir" + $run $mkdir "$xdir" + status=$? + if test $status -ne 0 && test ! -d "$xdir"; then + exit $status + fi + $show "(cd $xdir && $AR x $xabs)" + $run eval "(cd \$xdir && $AR x \$xabs)" || exit $? + + reload_conv_objs="$reload_objs "`find $xdir -name \*.$objext -print -o -name \*.lo -print | $NL2SP` + done + fi + fi + + # Create the old-style object. + reload_objs="$objs$old_deplibs "`$echo "X$libobjs" | $SP2NL | $Xsed -e '/\.'${libext}$'/d' -e '/\.lib$/d' -e "$lo2o" | $NL2SP`" $reload_conv_objs" ### testsuite: skip nested quoting test + + output="$obj" + eval cmds=\"$reload_cmds\" + IFS="${IFS= }"; save_ifs="$IFS"; IFS='~' + for cmd in $cmds; do + IFS="$save_ifs" + $show "$cmd" + $run eval "$cmd" || exit $? + done + IFS="$save_ifs" + + # Exit if we aren't doing a library object file. + if test -z "$libobj"; then + if test -n "$gentop"; then + $show "${rm}r $gentop" + $run ${rm}r $gentop + fi + + exit 0 + fi + + if test "$build_libtool_libs" != yes; then + if test -n "$gentop"; then + $show "${rm}r $gentop" + $run ${rm}r $gentop + fi + + # Create an invalid libtool object if no PIC, so that we don't + # accidentally link it into a program. + # $show "echo timestamp > $libobj" + # $run eval "echo timestamp > $libobj" || exit $? + exit 0 + fi + + if test -n "$pic_flag" || test "$pic_mode" != default; then + # Only do commands if we really have different PIC objects. + reload_objs="$libobjs $reload_conv_objs" + output="$libobj" + eval cmds=\"$reload_cmds\" + IFS="${IFS= }"; save_ifs="$IFS"; IFS='~' + for cmd in $cmds; do + IFS="$save_ifs" + $show "$cmd" + $run eval "$cmd" || exit $? + done + IFS="$save_ifs" +# else +# # Just create a symlink. +# $show $rm $libobj +# $run $rm $libobj +# xdir=`$echo "X$libobj" | $Xsed -e 's%/[^/]*$%%'` +# if test "X$xdir" = "X$libobj"; then +# xdir="." +# else +# xdir="$xdir" +# fi +# baseobj=`$echo "X$libobj" | $Xsed -e 's%^.*/%%'` +# oldobj=`$echo "X$baseobj" | $Xsed -e "$lo2o"` +# $show "(cd $xdir && $LN_S $oldobj $baseobj)" +# $run eval '(cd $xdir && $LN_S $oldobj $baseobj)' || exit $? + fi + + if test -n "$gentop"; then + $show "${rm}r $gentop" + $run ${rm}r $gentop + fi + + exit 0 + ;; + + prog) + case $host in + *cygwin*) output=`echo $output | sed -e 's,.exe$,,;s,$,.exe,'` ;; + esac + if test -n "$vinfo"; then + $echo "$modename: warning: \`-version-info' is ignored for programs" 1>&2 + fi + + if test -n "$release"; then + $echo "$modename: warning: \`-release' is ignored for programs" 1>&2 + fi + + if test "$preload" = yes; then + if test "$dlopen_support" = unknown && test "$dlopen_self" = unknown && + test "$dlopen_self_static" = unknown; then + $echo "$modename: warning: \`AC_LIBTOOL_DLOPEN' not used. Assuming no dlopen support." + fi + fi + + case $host in + *-*-rhapsody* | *-*-darwin1.[012]) + # On Rhapsody replace the C library is the System framework + compile_deplibs=`$echo "X $compile_deplibs" | $Xsed -e 's/ -lc / -framework System /'` + finalize_deplibs=`$echo "X $finalize_deplibs" | $Xsed -e 's/ -lc / -framework System /'` + ;; + esac + + compile_command="$compile_command $compile_deplibs" + finalize_command="$finalize_command $finalize_deplibs" + + if test -n "$rpath$xrpath"; then + # If the user specified any rpath flags, then add them. + for libdir in $rpath $xrpath; do + # This is the magic to use -rpath. + case "$finalize_rpath " in + *" $libdir "*) ;; + *) finalize_rpath="$finalize_rpath $libdir" ;; + esac + done + fi + + # Now hardcode the library paths + rpath= + hardcode_libdirs= + for libdir in $compile_rpath $finalize_rpath; do + if test -n "$hardcode_libdir_flag_spec"; then + if test -n "$hardcode_libdir_separator"; then + if test -z "$hardcode_libdirs"; then + hardcode_libdirs="$libdir" + else + # Just accumulate the unique libdirs. + case $hardcode_libdir_separator$hardcode_libdirs$hardcode_libdir_separator in + *"$hardcode_libdir_separator$libdir$hardcode_libdir_separator"*) + ;; + *) + hardcode_libdirs="$hardcode_libdirs$hardcode_libdir_separator$libdir" + ;; + esac + fi + else + eval flag=\"$hardcode_libdir_flag_spec\" + rpath="$rpath $flag" + fi + elif test -n "$runpath_var"; then + case "$perm_rpath " in + *" $libdir "*) ;; + *) perm_rpath="$perm_rpath $libdir" ;; + esac + fi + case $host in + *-*-cygwin* | *-*-mingw* | *-*-pw32* | *-*-os2*) + case :$dllsearchpath: in + *":$libdir:"*) ;; + *) dllsearchpath="$dllsearchpath:$libdir";; + esac + ;; + esac + done + # Substitute the hardcoded libdirs into the rpath. + if test -n "$hardcode_libdir_separator" && + test -n "$hardcode_libdirs"; then + libdir="$hardcode_libdirs" + eval rpath=\" $hardcode_libdir_flag_spec\" + fi + compile_rpath="$rpath" + + rpath= + hardcode_libdirs= + for libdir in $finalize_rpath; do + if test -n "$hardcode_libdir_flag_spec"; then + if test -n "$hardcode_libdir_separator"; then + if test -z "$hardcode_libdirs"; then + hardcode_libdirs="$libdir" + else + # Just accumulate the unique libdirs. + case $hardcode_libdir_separator$hardcode_libdirs$hardcode_libdir_separator in + *"$hardcode_libdir_separator$libdir$hardcode_libdir_separator"*) + ;; + *) + hardcode_libdirs="$hardcode_libdirs$hardcode_libdir_separator$libdir" + ;; + esac + fi + else + eval flag=\"$hardcode_libdir_flag_spec\" + rpath="$rpath $flag" + fi + elif test -n "$runpath_var"; then + case "$finalize_perm_rpath " in + *" $libdir "*) ;; + *) finalize_perm_rpath="$finalize_perm_rpath $libdir" ;; + esac + fi + done + # Substitute the hardcoded libdirs into the rpath. + if test -n "$hardcode_libdir_separator" && + test -n "$hardcode_libdirs"; then + libdir="$hardcode_libdirs" + eval rpath=\" $hardcode_libdir_flag_spec\" + fi + finalize_rpath="$rpath" + + dlsyms= + if test -n "$dlfiles$dlprefiles" || test "$dlself" != no; then + if test -n "$NM" && test -n "$global_symbol_pipe"; then + dlsyms="${outputname}S.c" + else + $echo "$modename: not configured to extract global symbols from dlpreopened files" 1>&2 + fi + fi + + if test -n "$dlsyms"; then + case $dlsyms in + "") ;; + *.c) + # Discover the nlist of each of the dlfiles. + nlist="$output_objdir/${outputname}.nm" + + $show "$rm $nlist ${nlist}S ${nlist}T" + $run $rm "$nlist" "${nlist}S" "${nlist}T" + + # Parse the name list into a source file. + $show "creating $output_objdir/$dlsyms" + + test -z "$run" && $echo > "$output_objdir/$dlsyms" "\ +/* $dlsyms - symbol resolution table for \`$outputname' dlsym emulation. */ +/* Generated by $PROGRAM - GNU $PACKAGE $VERSION$TIMESTAMP */ + +#ifdef __cplusplus +extern \"C\" { +#endif + +/* Prevent the only kind of declaration conflicts we can make. */ +#define lt_preloaded_symbols some_other_symbol + +/* External symbol declarations for the compiler. */\ +" + + if test "$dlself" = yes; then + $show "generating symbol list for \`$output'" + + test -z "$run" && $echo ': @PROGRAM@ ' > "$nlist" + + # Add our own program objects to the symbol list. + progfiles="$objs$old_deplibs" + for arg in $progfiles; do + $show "extracting global C symbols from \`$arg'" + $run eval "$NM $arg | $global_symbol_pipe >> '$nlist'" + done + + if test -n "$exclude_expsyms"; then + $run eval 'egrep -v " ($exclude_expsyms)$" "$nlist" > "$nlist"T' + $run eval '$mv "$nlist"T "$nlist"' + fi + + if test -n "$export_symbols_regex"; then + $run eval 'egrep -e "$export_symbols_regex" "$nlist" > "$nlist"T' + $run eval '$mv "$nlist"T "$nlist"' + fi + + # Prepare the list of exported symbols + if test -z "$export_symbols"; then + export_symbols="$output_objdir/$output.exp" + $run $rm $export_symbols + $run eval "sed -n -e '/^: @PROGRAM@$/d' -e 's/^.* \(.*\)$/\1/p' "'< "$nlist" > "$export_symbols"' + else + $run eval "sed -e 's/\([][.*^$]\)/\\\1/g' -e 's/^/ /' -e 's/$/$/'"' < "$export_symbols" > "$output_objdir/$output.exp"' + $run eval 'grep -f "$output_objdir/$output.exp" < "$nlist" > "$nlist"T' + $run eval 'mv "$nlist"T "$nlist"' + fi + fi + + for arg in $dlprefiles; do + $show "extracting global C symbols from \`$arg'" + name=`echo "$arg" | sed -e 's%^.*/%%'` + $run eval 'echo ": $name " >> "$nlist"' + $run eval "$NM $arg | $global_symbol_pipe >> '$nlist'" + done + + if test -z "$run"; then + # Make sure we have at least an empty file. + test -f "$nlist" || : > "$nlist" + + if test -n "$exclude_expsyms"; then + egrep -v " ($exclude_expsyms)$" "$nlist" > "$nlist"T + $mv "$nlist"T "$nlist" + fi + + # Try sorting and uniquifying the output. + if grep -v "^: " < "$nlist" | sort +2 | uniq > "$nlist"S; then + : + else + grep -v "^: " < "$nlist" > "$nlist"S + fi + + if test -f "$nlist"S; then + eval "$global_symbol_to_cdecl"' < "$nlist"S >> "$output_objdir/$dlsyms"' + else + echo '/* NONE */' >> "$output_objdir/$dlsyms" + fi + + $echo >> "$output_objdir/$dlsyms" "\ + +#undef lt_preloaded_symbols + +#if defined (__STDC__) && __STDC__ +# define lt_ptr_t void * +#else +# define lt_ptr_t char * +# define const +#endif + +/* The mapping between symbol names and symbols. */ +const struct { + const char *name; + lt_ptr_t address; +} +lt_preloaded_symbols[] = +{\ +" + + sed -n -e 's/^: \([^ ]*\) $/ {\"\1\", (lt_ptr_t) 0},/p' \ + -e 's/^. \([^ ]*\) \([^ ]*\)$/ {"\2", (lt_ptr_t) \&\2},/p' \ + < "$nlist" >> "$output_objdir/$dlsyms" + + $echo >> "$output_objdir/$dlsyms" "\ + {0, (lt_ptr_t) 0} +}; + +/* This works around a problem in FreeBSD linker */ +#ifdef FREEBSD_WORKAROUND +static const void *lt_preloaded_setup() { + return lt_preloaded_symbols; +} +#endif + +#ifdef __cplusplus +} +#endif\ +" + fi + + pic_flag_for_symtable= + case $host in + # compiling the symbol table file with pic_flag works around + # a FreeBSD bug that causes programs to crash when -lm is + # linked before any other PIC object. But we must not use + # pic_flag when linking with -static. The problem exists in + # FreeBSD 2.2.6 and is fixed in FreeBSD 3.1. + *-*-freebsd2*|*-*-freebsd3.0*|*-*-freebsdelf3.0*) + case "$compile_command " in + *" -static "*) ;; + *) pic_flag_for_symtable=" $pic_flag -DFREEBSD_WORKAROUND";; + esac;; + *-*-hpux*) + case "$compile_command " in + *" -static "*) ;; + *) pic_flag_for_symtable=" $pic_flag";; + esac + esac + + # Now compile the dynamic symbol file. + $show "(cd $output_objdir && $LTCC -c$no_builtin_flag$pic_flag_for_symtable \"$dlsyms\")" + $run eval '(cd $output_objdir && $LTCC -c$no_builtin_flag$pic_flag_for_symtable "$dlsyms")' || exit $? + + # Clean up the generated files. + $show "$rm $output_objdir/$dlsyms $nlist ${nlist}S ${nlist}T" + $run $rm "$output_objdir/$dlsyms" "$nlist" "${nlist}S" "${nlist}T" + + # Transform the symbol file into the correct name. + compile_command=`$echo "X$compile_command" | $Xsed -e "s%@SYMFILE@%$output_objdir/${outputname}S.${objext}%"` + finalize_command=`$echo "X$finalize_command" | $Xsed -e "s%@SYMFILE@%$output_objdir/${outputname}S.${objext}%"` + ;; + *) + $echo "$modename: unknown suffix for \`$dlsyms'" 1>&2 + exit 1 + ;; + esac + else + # We keep going just in case the user didn't refer to + # lt_preloaded_symbols. The linker will fail if global_symbol_pipe + # really was required. + + # Nullify the symbol file. + compile_command=`$echo "X$compile_command" | $Xsed -e "s% @SYMFILE@%%"` + finalize_command=`$echo "X$finalize_command" | $Xsed -e "s% @SYMFILE@%%"` + fi + + if test $need_relink = no || test "$build_libtool_libs" != yes; then + # Replace the output file specification. + compile_command=`$echo "X$compile_command" | $Xsed -e 's%@OUTPUT@%'"$output"'%g'` + link_command="$compile_command$compile_rpath" + + # We have no uninstalled library dependencies, so finalize right now. + $show "$link_command" + $run eval "$link_command" + status=$? + + # Delete the generated files. + if test -n "$dlsyms"; then + $show "$rm $output_objdir/${outputname}S.${objext}" + $run $rm "$output_objdir/${outputname}S.${objext}" + fi + + exit $status + fi + + if test -n "$shlibpath_var"; then + # We should set the shlibpath_var + rpath= + for dir in $temp_rpath; do + case $dir in + [\\/]* | [A-Za-z]:[\\/]*) + # Absolute path. + rpath="$rpath$dir:" + ;; + *) + # Relative path: add a thisdir entry. + rpath="$rpath\$thisdir/$dir:" + ;; + esac + done + temp_rpath="$rpath" + fi + + if test -n "$compile_shlibpath$finalize_shlibpath"; then + compile_command="$shlibpath_var=\"$compile_shlibpath$finalize_shlibpath\$$shlibpath_var\" $compile_command" + fi + if test -n "$finalize_shlibpath"; then + finalize_command="$shlibpath_var=\"$finalize_shlibpath\$$shlibpath_var\" $finalize_command" + fi + + compile_var= + finalize_var= + if test -n "$runpath_var"; then + if test -n "$perm_rpath"; then + # We should set the runpath_var. + rpath= + for dir in $perm_rpath; do + rpath="$rpath$dir:" + done + compile_var="$runpath_var=\"$rpath\$$runpath_var\" " + fi + if test -n "$finalize_perm_rpath"; then + # We should set the runpath_var. + rpath= + for dir in $finalize_perm_rpath; do + rpath="$rpath$dir:" + done + finalize_var="$runpath_var=\"$rpath\$$runpath_var\" " + fi + fi + + if test "$no_install" = yes; then + # We don't need to create a wrapper script. + link_command="$compile_var$compile_command$compile_rpath" + # Replace the output file specification. + link_command=`$echo "X$link_command" | $Xsed -e 's%@OUTPUT@%'"$output"'%g'` + # Delete the old output file. + $run $rm $output + # Link the executable and exit + $show "$link_command" + $run eval "$link_command" || exit $? + exit 0 + fi + + if test "$hardcode_action" = relink; then + # Fast installation is not supported + link_command="$compile_var$compile_command$compile_rpath" + relink_command="$finalize_var$finalize_command$finalize_rpath" + + $echo "$modename: warning: this platform does not like uninstalled shared libraries" 1>&2 + $echo "$modename: \`$output' will be relinked during installation" 1>&2 + else + if test "$fast_install" != no; then + link_command="$finalize_var$compile_command$finalize_rpath" + if test "$fast_install" = yes; then + relink_command=`$echo "X$compile_var$compile_command$compile_rpath" | $Xsed -e 's%@OUTPUT@%\$progdir/\$file%g'` + else + # fast_install is set to needless + relink_command= + fi + else + link_command="$compile_var$compile_command$compile_rpath" + relink_command="$finalize_var$finalize_command$finalize_rpath" + fi + fi + + # Replace the output file specification. + link_command=`$echo "X$link_command" | $Xsed -e 's%@OUTPUT@%'"$output_objdir/$outputname"'%g'` + + # Delete the old output files. + $run $rm $output $output_objdir/$outputname $output_objdir/lt-$outputname + + $show "$link_command" + $run eval "$link_command" || exit $? + + # Now create the wrapper script. + $show "creating $output" + + # Quote the relink command for shipping. + if test -n "$relink_command"; then + # Preserve any variables that may affect compiler behavior + for var in $variables_saved_for_relink; do + if eval test -z \"\${$var+set}\"; then + relink_command="{ test -z \"\${$var+set}\" || unset $var || { $var=; export $var; }; }; $relink_command" + elif eval var_value=\$$var; test -z "$var_value"; then + relink_command="$var=; export $var; $relink_command" + else + var_value=`$echo "X$var_value" | $Xsed -e "$sed_quote_subst"` + relink_command="$var=\"$var_value\"; export $var; $relink_command" + fi + done + relink_command="cd `pwd`; $relink_command" + relink_command=`$echo "X$relink_command" | $Xsed -e "$sed_quote_subst"` + fi + + # Quote $echo for shipping. + if test "X$echo" = "X$SHELL $0 --fallback-echo"; then + case $0 in + [\\/]* | [A-Za-z]:[\\/]*) qecho="$SHELL $0 --fallback-echo";; + *) qecho="$SHELL `pwd`/$0 --fallback-echo";; + esac + qecho=`$echo "X$qecho" | $Xsed -e "$sed_quote_subst"` + else + qecho=`$echo "X$echo" | $Xsed -e "$sed_quote_subst"` + fi + + # Only actually do things if our run command is non-null. + if test -z "$run"; then + # win32 will think the script is a binary if it has + # a .exe suffix, so we strip it off here. + case $output in + *.exe) output=`echo $output|sed 's,.exe$,,'` ;; + esac + # test for cygwin because mv fails w/o .exe extensions + case $host in + *cygwin*) exeext=.exe ;; + *) exeext= ;; + esac + $rm $output + trap "$rm $output; exit 1" 1 2 15 + + $echo > $output "\ +#! $SHELL + +# $output - temporary wrapper script for $objdir/$outputname +# Generated by $PROGRAM - GNU $PACKAGE $VERSION$TIMESTAMP +# +# The $output program cannot be directly executed until all the libtool +# libraries that it depends on are installed. +# +# This wrapper script should never be moved out of the build directory. +# If it is, it will not operate correctly. + +# Sed substitution that helps us do robust quoting. It backslashifies +# metacharacters that are still active within double-quoted strings. +Xsed='sed -e 1s/^X//' +sed_quote_subst='$sed_quote_subst' + +# The HP-UX ksh and POSIX shell print the target directory to stdout +# if CDPATH is set. +if test \"\${CDPATH+set}\" = set; then CDPATH=:; export CDPATH; fi + +relink_command=\"$relink_command > /dev/null 2>&1\" + +# This environment variable determines our operation mode. +if test \"\$libtool_install_magic\" = \"$magic\"; then + # install mode needs the following variable: + notinst_deplibs='$notinst_deplibs' +else + # When we are sourced in execute mode, \$file and \$echo are already set. + if test \"\$libtool_execute_magic\" != \"$magic\"; then + echo=\"$qecho\" + file=\"\$0\" + # Make sure echo works. + if test \"X\$1\" = X--no-reexec; then + # Discard the --no-reexec flag, and continue. + shift + elif test \"X\`(\$echo '\t') 2>/dev/null\`\" = 'X\t'; then + # Yippee, \$echo works! + : + else + # Restart under the correct shell, and then maybe \$echo will work. + exec $SHELL \"\$0\" --no-reexec \${1+\"\$@\"} + fi + fi\ +" + $echo >> $output "\ + + # Find the directory that this script lives in. + thisdir=\`\$echo \"X\$file\" | \$Xsed -e 's%/[^/]*$%%'\` + test \"x\$thisdir\" = \"x\$file\" && thisdir=. + + # Follow symbolic links until we get to the real thisdir. + file=\`ls -ld \"\$file\" | sed -n 's/.*-> //p'\` + while test -n \"\$file\"; do + destdir=\`\$echo \"X\$file\" | \$Xsed -e 's%/[^/]*\$%%'\` + + # If there was a directory component, then change thisdir. + if test \"x\$destdir\" != \"x\$file\"; then + case \"\$destdir\" in + [\\\\/]* | [A-Za-z]:[\\\\/]*) thisdir=\"\$destdir\" ;; + *) thisdir=\"\$thisdir/\$destdir\" ;; + esac + fi + + file=\`\$echo \"X\$file\" | \$Xsed -e 's%^.*/%%'\` + file=\`ls -ld \"\$thisdir/\$file\" | sed -n 's/.*-> //p'\` + done + + # Try to get the absolute directory name. + absdir=\`cd \"\$thisdir\" && pwd\` + test -n \"\$absdir\" && thisdir=\"\$absdir\" +" + + if test "$fast_install" = yes; then + echo >> $output "\ + program=lt-'$outputname'$exeext + progdir=\"\$thisdir/$objdir\" + + if test ! -f \"\$progdir/\$program\" || \\ + { file=\`ls -1dt \"\$progdir/\$program\" \"\$progdir/../\$program\" 2>/dev/null | sed 1q\`; \\ + test \"X\$file\" != \"X\$progdir/\$program\"; }; then + + file=\"\$\$-\$program\" + + if test ! -d \"\$progdir\"; then + $mkdir \"\$progdir\" + else + $rm \"\$progdir/\$file\" + fi" + + echo >> $output "\ + + # relink executable if necessary + if test -n \"\$relink_command\"; then + if relink_command_output=\`eval \$relink_command 2>&1\`; then : + else + $echo \"\$relink_command_output\" >&2 + $rm \"\$progdir/\$file\" + exit 1 + fi + fi + + $mv \"\$progdir/\$file\" \"\$progdir/\$program\" 2>/dev/null || + { $rm \"\$progdir/\$program\"; + $mv \"\$progdir/\$file\" \"\$progdir/\$program\"; } + $rm \"\$progdir/\$file\" + fi" + else + echo >> $output "\ + program='$outputname' + progdir=\"\$thisdir/$objdir\" +" + fi + + echo >> $output "\ + + if test -f \"\$progdir/\$program\"; then" + + # Export our shlibpath_var if we have one. + if test "$shlibpath_overrides_runpath" = yes && test -n "$shlibpath_var" && test -n "$temp_rpath"; then + $echo >> $output "\ + # Add our own library path to $shlibpath_var + $shlibpath_var=\"$temp_rpath\$$shlibpath_var\" + + # Some systems cannot cope with colon-terminated $shlibpath_var + # The second colon is a workaround for a bug in BeOS R4 sed + $shlibpath_var=\`\$echo \"X\$$shlibpath_var\" | \$Xsed -e 's/::*\$//'\` + + export $shlibpath_var +" + fi + + # fixup the dll searchpath if we need to. + if test -n "$dllsearchpath"; then + $echo >> $output "\ + # Add the dll search path components to the executable PATH + PATH=$dllsearchpath:\$PATH +" + fi + + $echo >> $output "\ + if test \"\$libtool_execute_magic\" != \"$magic\"; then + # Run the actual program with our arguments. +" + case $host in + # win32 systems need to use the prog path for dll + # lookup to work + *-*-cygwin* | *-*-pw32*) + $echo >> $output "\ + exec \$progdir/\$program \${1+\"\$@\"} +" + ;; + + # Backslashes separate directories on plain windows + *-*-mingw | *-*-os2*) + $echo >> $output "\ + exec \$progdir\\\\\$program \${1+\"\$@\"} +" + ;; + + *) + $echo >> $output "\ + # Export the path to the program. + PATH=\"\$progdir:\$PATH\" + export PATH + + exec \$program \${1+\"\$@\"} +" + ;; + esac + $echo >> $output "\ + \$echo \"\$0: cannot exec \$program \${1+\"\$@\"}\" + exit 1 + fi + else + # The program doesn't exist. + \$echo \"\$0: error: \$progdir/\$program does not exist\" 1>&2 + \$echo \"This script is just a wrapper for \$program.\" 1>&2 + echo \"See the $PACKAGE documentation for more information.\" 1>&2 + exit 1 + fi +fi\ +" + chmod +x $output + fi + exit 0 + ;; + esac + + # See if we need to build an old-fashioned archive. + for oldlib in $oldlibs; do + + if test "$build_libtool_libs" = convenience; then + oldobjs="$libobjs_save" + addlibs="$convenience" + build_libtool_libs=no + else + if test "$build_libtool_libs" = module; then + oldobjs="$libobjs_save" + build_libtool_libs=no + else + oldobjs="$objs$old_deplibs $non_pic_objects" + fi + addlibs="$old_convenience" + fi + + if test -n "$addlibs"; then + gentop="$output_objdir/${outputname}x" + $show "${rm}r $gentop" + $run ${rm}r "$gentop" + $show "$mkdir $gentop" + $run $mkdir "$gentop" + status=$? + if test $status -ne 0 && test ! -d "$gentop"; then + exit $status + fi + generated="$generated $gentop" + + # Add in members from convenience archives. + for xlib in $addlibs; do + # Extract the objects. + case $xlib in + [\\/]* | [A-Za-z]:[\\/]*) xabs="$xlib" ;; + *) xabs=`pwd`"/$xlib" ;; + esac + xlib=`$echo "X$xlib" | $Xsed -e 's%^.*/%%'` + xdir="$gentop/$xlib" + + $show "${rm}r $xdir" + $run ${rm}r "$xdir" + $show "$mkdir $xdir" + $run $mkdir "$xdir" + status=$? + if test $status -ne 0 && test ! -d "$xdir"; then + exit $status + fi + $show "(cd $xdir && $AR x $xabs)" + $run eval "(cd \$xdir && $AR x \$xabs)" || exit $? + + oldobjs="$oldobjs "`find $xdir -name \*.${objext} -print | $NL2SP` + done + fi + + # Do each command in the archive commands. + if test -n "$old_archive_from_new_cmds" && test "$build_libtool_libs" = yes; then + eval cmds=\"$old_archive_from_new_cmds\" + else +# # Ensure that we have .o objects in place in case we decided +# # not to build a shared library, and have fallen back to building +# # static libs even though --disable-static was passed! +# for oldobj in $oldobjs; do +# if test ! -f $oldobj; then +# xdir=`$echo "X$oldobj" | $Xsed -e 's%/[^/]*$%%'` +# if test "X$xdir" = "X$oldobj"; then +# xdir="." +# else +# xdir="$xdir" +# fi +# baseobj=`$echo "X$oldobj" | $Xsed -e 's%^.*/%%'` +# obj=`$echo "X$baseobj" | $Xsed -e "$o2lo"` +# $show "(cd $xdir && ${LN_S} $obj $baseobj)" +# $run eval '(cd $xdir && ${LN_S} $obj $baseobj)' || exit $? +# fi +# done + + eval cmds=\"$old_archive_cmds\" + + if len=`expr "X$cmds" : ".*"` && + test $len -le $max_cmd_len; then + : + else + # the command line is too long to link in one step, link in parts + $echo "using piecewise archive linking..." + save_RANLIB=$RANLIB + RANLIB=: + objlist= + concat_cmds= + save_oldobjs=$oldobjs + for obj in $save_oldobjs + do + oldobjs="$objlist $obj" + objlist="$objlist $obj" + eval test_cmds=\"$old_archive_cmds\" + if len=`expr "X$test_cmds" : ".*"` && + test $len -le $max_cmd_len; then + : + else + # the above command should be used before it gets too long + oldobjs=$objlist + test -z "$concat_cmds" || concat_cmds=$concat_cmds~ + eval concat_cmds=\"\${concat_cmds}$old_archive_cmds\" + objlist= + fi + done + RANLIB=$save_RANLIB + oldobjs=$objlist + eval cmds=\"\$concat_cmds~$old_archive_cmds\" + fi + fi + IFS="${IFS= }"; save_ifs="$IFS"; IFS='~' + for cmd in $cmds; do + IFS="$save_ifs" + $show "$cmd" + $run eval "$cmd" || exit $? + done + IFS="$save_ifs" + done + + if test -n "$generated"; then + $show "${rm}r$generated" + $run ${rm}r$generated + fi + + # Now create the libtool archive. + case $output in + *.la) + old_library= + test "$build_old_libs" = yes && old_library="$libname.$libext" + $show "creating $output" + + # Preserve any variables that may affect compiler behavior + for var in $variables_saved_for_relink; do + if eval test -z \"\${$var+set}\"; then + relink_command="{ test -z \"\${$var+set}\" || unset $var || { $var=; export $var; }; }; $relink_command" + elif eval var_value=\$$var; test -z "$var_value"; then + relink_command="$var=; export $var; $relink_command" + else + var_value=`$echo "X$var_value" | $Xsed -e "$sed_quote_subst"` + relink_command="$var=\"$var_value\"; export $var; $relink_command" + fi + done + # Quote the link command for shipping. + tagopts= + for tag in $taglist; do + tagopts="$tagopts --tag $tag" + done + relink_command="(cd `pwd`; $SHELL $0$tagopts --mode=relink $libtool_args)" + relink_command=`$echo "X$relink_command" | $Xsed -e "$sed_quote_subst"` + + # Only create the output if not a dry run. + if test -z "$run"; then + for installed in no yes; do + if test "$installed" = yes; then + if test -z "$install_libdir"; then + break + fi + output="$output_objdir/$outputname"i + # Replace all uninstalled libtool libraries with the installed ones + newdependency_libs= + for deplib in $dependency_libs; do + case $deplib in + *.la) + name=`$echo "X$deplib" | $Xsed -e 's%^.*/%%'` + eval libdir=`sed -n -e 's/^libdir=\(.*\)$/\1/p' $deplib` + if test -z "$libdir"; then + $echo "$modename: \`$deplib' is not a valid libtool archive" 1>&2 + exit 1 + fi + newdependency_libs="$newdependency_libs $libdir/$name" + ;; + *) newdependency_libs="$newdependency_libs $deplib" ;; + esac + done + dependency_libs="$newdependency_libs" + newdlfiles= + for lib in $dlfiles; do + name=`$echo "X$lib" | $Xsed -e 's%^.*/%%'` + eval libdir=`sed -n -e 's/^libdir=\(.*\)$/\1/p' $lib` + if test -z "$libdir"; then + $echo "$modename: \`$lib' is not a valid libtool archive" 1>&2 + exit 1 + fi + newdlfiles="$newdlfiles $libdir/$name" + done + dlfiles="$newdlfiles" + newdlprefiles= + for lib in $dlprefiles; do + name=`$echo "X$lib" | $Xsed -e 's%^.*/%%'` + eval libdir=`sed -n -e 's/^libdir=\(.*\)$/\1/p' $lib` + if test -z "$libdir"; then + $echo "$modename: \`$lib' is not a valid libtool archive" 1>&2 + exit 1 + fi + newdlprefiles="$newdlprefiles $libdir/$name" + done + dlprefiles="$newdlprefiles" + fi + $rm $output + # place dlname in correct position for cygwin + tdlname=$dlname + case $host,$output,$installed,$module,$dlname in + *cygwin*,*lai,yes,no,*.dll) tdlname=../bin/$dlname ;; + esac + $echo > $output "\ +# $outputname - a libtool library file +# Generated by $PROGRAM - GNU $PACKAGE $VERSION$TIMESTAMP +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# The name that we can dlopen(3). +dlname='$tdlname' + +# Names of this library. +library_names='$library_names' + +# The name of the static archive. +old_library='$old_library' + +# Libraries that this one depends upon. +dependency_libs='$dependency_libs' + +# Version information for $libname. +current=$current +age=$age +revision=$revision + +# Is this an already installed library? +installed=$installed + +# Files to dlopen/dlpreopen +dlopen='$dlfiles' +dlpreopen='$dlprefiles' + +# Directory that this library needs to be installed in: +libdir='$install_libdir'" + if test "$installed" = no && test $need_relink = yes; then + $echo >> $output "\ +relink_command=\"$relink_command\"" + fi + done + fi + + # Do a symbolic link so that the libtool archive can be found in + # LD_LIBRARY_PATH before the program is installed. + $show "(cd $output_objdir && $rm $outputname && $LN_S ../$outputname $outputname)" + $run eval '(cd $output_objdir && $rm $outputname && $LN_S ../$outputname $outputname)' || exit $? + ;; + esac + exit 0 + ;; + + # libtool install mode + install) + modename="$modename: install" + + # There may be an optional sh(1) argument at the beginning of + # install_prog (especially on Windows NT). + if test "$nonopt" = "$SHELL" || test "$nonopt" = /bin/sh || + # Allow the use of GNU shtool's install command. + $echo "X$nonopt" | $Xsed | grep shtool > /dev/null; then + # Aesthetically quote it. + arg=`$echo "X$nonopt" | $Xsed -e "$sed_quote_subst"` + case $arg in + *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*) + arg="\"$arg\"" + ;; + esac + install_prog="$arg " + arg="$1" + shift + else + install_prog= + arg="$nonopt" + fi + + # The real first argument should be the name of the installation program. + # Aesthetically quote it. + arg=`$echo "X$arg" | $Xsed -e "$sed_quote_subst"` + case $arg in + *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*) + arg="\"$arg\"" + ;; + esac + install_prog="$install_prog$arg" + + # We need to accept at least all the BSD install flags. + dest= + files= + opts= + prev= + install_type= + isdir=no + stripme= + for arg + do + if test -n "$dest"; then + files="$files $dest" + dest="$arg" + continue + fi + + case $arg in + -d) isdir=yes ;; + -f) prev="-f" ;; + -g) prev="-g" ;; + -m) prev="-m" ;; + -o) prev="-o" ;; + -s) + stripme=" -s" + continue + ;; + -*) ;; + + *) + # If the previous option needed an argument, then skip it. + if test -n "$prev"; then + prev= + else + dest="$arg" + continue + fi + ;; + esac + + # Aesthetically quote the argument. + arg=`$echo "X$arg" | $Xsed -e "$sed_quote_subst"` + case $arg in + *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*) + arg="\"$arg\"" + ;; + esac + install_prog="$install_prog $arg" + done + + if test -z "$install_prog"; then + $echo "$modename: you must specify an install program" 1>&2 + $echo "$help" 1>&2 + exit 1 + fi + + if test -n "$prev"; then + $echo "$modename: the \`$prev' option requires an argument" 1>&2 + $echo "$help" 1>&2 + exit 1 + fi + + if test -z "$files"; then + if test -z "$dest"; then + $echo "$modename: no file or destination specified" 1>&2 + else + $echo "$modename: you must specify a destination" 1>&2 + fi + $echo "$help" 1>&2 + exit 1 + fi + + # Strip any trailing slash from the destination. + dest=`$echo "X$dest" | $Xsed -e 's%/$%%'` + + # Check to see that the destination is a directory. + test -d "$dest" && isdir=yes + if test "$isdir" = yes; then + destdir="$dest" + destname= + else + destdir=`$echo "X$dest" | $Xsed -e 's%/[^/]*$%%'` + test "X$destdir" = "X$dest" && destdir=. + destname=`$echo "X$dest" | $Xsed -e 's%^.*/%%'` + + # Not a directory, so check to see that there is only one file specified. + set dummy $files + if test $# -gt 2; then + $echo "$modename: \`$dest' is not a directory" 1>&2 + $echo "$help" 1>&2 + exit 1 + fi + fi + case $destdir in + [\\/]* | [A-Za-z]:[\\/]*) ;; + *) + for file in $files; do + case $file in + *.lo) ;; + *) + $echo "$modename: \`$destdir' must be an absolute directory name" 1>&2 + $echo "$help" 1>&2 + exit 1 + ;; + esac + done + ;; + esac + + # This variable tells wrapper scripts just to set variables rather + # than running their programs. + libtool_install_magic="$magic" + + staticlibs= + future_libdirs= + current_libdirs= + for file in $files; do + + # Do each installation. + case $file in + *.$libext) + # Do the static libraries later. + staticlibs="$staticlibs $file" + ;; + + *.la) + # Check to see that this really is a libtool archive. + if (sed -e '2q' $file | egrep "^# Generated by .*$PACKAGE") >/dev/null 2>&1; then : + else + $echo "$modename: \`$file' is not a valid libtool archive" 1>&2 + $echo "$help" 1>&2 + exit 1 + fi + + library_names= + old_library= + relink_command= + # If there is no directory component, then add one. + case $file in + */* | *\\*) . $file ;; + *) . ./$file ;; + esac + + # Add the libdir to current_libdirs if it is the destination. + if test "X$destdir" = "X$libdir"; then + case "$current_libdirs " in + *" $libdir "*) ;; + *) current_libdirs="$current_libdirs $libdir" ;; + esac + else + # Note the libdir as a future libdir. + case "$future_libdirs " in + *" $libdir "*) ;; + *) future_libdirs="$future_libdirs $libdir" ;; + esac + fi + + dir=`$echo "X$file" | $Xsed -e 's%/[^/]*$%%'`/ + test "X$dir" = "X$file/" && dir= + dir="$dir$objdir" + + if test -n "$relink_command"; then + $echo "$modename: warning: relinking \`$file'" 1>&2 + $show "$relink_command" + if $run eval "$relink_command"; then : + else + $echo "$modename: error: relink \`$file' with the above command before installing it" 1>&2 + exit 1 + fi + fi + + # See the names of the shared library. + set dummy $library_names + if test -n "$2"; then + realname="$2" + shift + shift + + srcname="$realname" + test -n "$relink_command" && srcname="$realname"T + + # Install the shared library and build the symlinks. + $show "$install_prog $dir/$srcname $destdir/$realname" + $run eval "$install_prog $dir/$srcname $destdir/$realname" || exit $? + if test -n "$stripme" && test -n "$striplib"; then + $show "$striplib $destdir/$realname" + $run eval "$striplib $destdir/$realname" || exit $? + fi + + if test $# -gt 0; then + # Delete the old symlinks, and create new ones. + for linkname + do + if test "$linkname" != "$realname"; then + $show "(cd $destdir && $rm $linkname && $LN_S $realname $linkname)" + $run eval "(cd $destdir && $rm $linkname && $LN_S $realname $linkname)" + fi + done + fi + + # Do each command in the postinstall commands. + lib="$destdir/$realname" + eval cmds=\"$postinstall_cmds\" + IFS="${IFS= }"; save_ifs="$IFS"; IFS='~' + for cmd in $cmds; do + IFS="$save_ifs" + $show "$cmd" + $run eval "$cmd" || exit $? + done + IFS="$save_ifs" + fi + + # Install the pseudo-library for information purposes. + name=`$echo "X$file" | $Xsed -e 's%^.*/%%'` + instname="$dir/$name"i + $show "$install_prog $instname $destdir/$name" + $run eval "$install_prog $instname $destdir/$name" || exit $? + + # Maybe install the static library, too. + test -n "$old_library" && staticlibs="$staticlibs $dir/$old_library" + ;; + + *.lo) + # Install (i.e. copy) a libtool object. + + # Figure out destination file name, if it wasn't already specified. + if test -n "$destname"; then + destfile="$destdir/$destname" + else + destfile=`$echo "X$file" | $Xsed -e 's%^.*/%%'` + destfile="$destdir/$destfile" + fi + + # Deduce the name of the destination old-style object file. + case $destfile in + *.lo) + staticdest=`$echo "X$destfile" | $Xsed -e "$lo2o"` + ;; + *.$objext) + staticdest="$destfile" + destfile= + ;; + *) + $echo "$modename: cannot copy a libtool object to \`$destfile'" 1>&2 + $echo "$help" 1>&2 + exit 1 + ;; + esac + + # Install the libtool object if requested. + if test -n "$destfile"; then + $show "$install_prog $file $destfile" + $run eval "$install_prog $file $destfile" || exit $? + fi + + # Install the old object if enabled. + if test "$build_old_libs" = yes; then + # Deduce the name of the old-style object file. + staticobj=`$echo "X$file" | $Xsed -e "$lo2o"` + + $show "$install_prog $staticobj $staticdest" + $run eval "$install_prog \$staticobj \$staticdest" || exit $? + fi + exit 0 + ;; + + *) + # Figure out destination file name, if it wasn't already specified. + if test -n "$destname"; then + destfile="$destdir/$destname" + else + destfile=`$echo "X$file" | $Xsed -e 's%^.*/%%'` + destfile="$destdir/$destfile" + fi + + # Do a test to see if this is really a libtool program. + if (sed -e '4q' $file | egrep "^# Generated by .*$PACKAGE") >/dev/null 2>&1; then + notinst_deplibs= + relink_command= + + # If there is no directory component, then add one. + case $file in + */* | *\\*) . $file ;; + *) . ./$file ;; + esac + + # Check the variables that should have been set. + if test -z "$notinst_deplibs"; then + $echo "$modename: invalid libtool wrapper script \`$file'" 1>&2 + exit 1 + fi + + finalize=yes + for lib in $notinst_deplibs; do + # Check to see that each library is installed. + libdir= + if test -f "$lib"; then + # If there is no directory component, then add one. + case $lib in + */* | *\\*) . $lib ;; + *) . ./$lib ;; + esac + fi + libfile="$libdir/"`$echo "X$lib" | $Xsed -e 's%^.*/%%g'` ### testsuite: skip nested quoting test + if test -n "$libdir" && test ! -f "$libfile"; then + $echo "$modename: warning: \`$lib' has not been installed in \`$libdir'" 1>&2 + finalize=no + fi + done + + relink_command= + # If there is no directory component, then add one. + case $file in + */* | *\\*) . $file ;; + *) . ./$file ;; + esac + + outputname= + if test "$fast_install" = no && test -n "$relink_command"; then + if test "$finalize" = yes && test -z "$run"; then + tmpdir="/tmp" + test -n "$TMPDIR" && tmpdir="$TMPDIR" + tmpdir="$tmpdir/libtool-$$" + if $mkdir -p "$tmpdir" && chmod 700 "$tmpdir"; then : + else + $echo "$modename: error: cannot create temporary directory \`$tmpdir'" 1>&2 + continue + fi + file=`$echo "X$file" | $Xsed -e 's%^.*/%%'` + outputname="$tmpdir/$file" + # Replace the output file specification. + relink_command=`$echo "X$relink_command" | $Xsed -e 's%@OUTPUT@%'"$outputname"'%g'` + + $show "$relink_command" + if $run eval "$relink_command"; then : + else + $echo "$modename: error: relink \`$file' with the above command before installing it" 1>&2 + ${rm}r "$tmpdir" + continue + fi + file="$outputname" + else + $echo "$modename: warning: cannot relink \`$file'" 1>&2 + fi + else + # Install the binary that we compiled earlier. + file=`$echo "X$file" | $Xsed -e "s%\([^/]*\)$%$objdir/\1%"` + fi + fi + + + # remove .exe since cygwin /usr/bin/install will append another + # one anyways + case $install_prog,$host in + */usr/bin/install*,*cygwin*) + case $file:$destfile in + *.exe:*.exe) + # this is ok + ;; + *.exe:*) + destfile=$destfile.exe + ;; + *:*.exe) + destfile=`echo $destfile | sed -e 's,.exe$,,'` + ;; + esac + ;; + esac + + $show "$install_prog$stripme $file $destfile" + $run eval "$install_prog\$stripme \$file \$destfile" || exit $? + test -n "$outputname" && ${rm}r "$tmpdir" + ;; + esac + done + + for file in $staticlibs; do + name=`$echo "X$file" | $Xsed -e 's%^.*/%%'` + + # Set up the ranlib parameters. + oldlib="$destdir/$name" + + $show "$install_prog $file $oldlib" + $run eval "$install_prog \$file \$oldlib" || exit $? + + if test -n "$stripme" && test -n "$striplib"; then + $show "$old_striplib $oldlib" + $run eval "$old_striplib $oldlib" || exit $? + fi + + # Do each command in the postinstall commands. + eval cmds=\"$old_postinstall_cmds\" + IFS="${IFS= }"; save_ifs="$IFS"; IFS='~' + for cmd in $cmds; do + IFS="$save_ifs" + $show "$cmd" + $run eval "$cmd" || exit $? + done + IFS="$save_ifs" + done + + if test -n "$future_libdirs"; then + $echo "$modename: warning: remember to run \`$progname --finish$future_libdirs'" 1>&2 + fi + + if test -n "$current_libdirs"; then + # Maybe just do a dry run. + test -n "$run" && current_libdirs=" -n$current_libdirs" + exec_cmd='$SHELL $0 --finish$current_libdirs' + else + exit 0 + fi + ;; + + # libtool finish mode + finish) + modename="$modename: finish" + libdirs="$nonopt" + admincmds= + + if test -n "$finish_cmds$finish_eval" && test -n "$libdirs"; then + for dir + do + libdirs="$libdirs $dir" + done + + for libdir in $libdirs; do + if test -n "$finish_cmds"; then + # Do each command in the finish commands. + eval cmds=\"$finish_cmds\" + IFS="${IFS= }"; save_ifs="$IFS"; IFS='~' + for cmd in $cmds; do + IFS="$save_ifs" + $show "$cmd" + $run eval "$cmd" || admincmds="$admincmds + $cmd" + done + IFS="$save_ifs" + fi + if test -n "$finish_eval"; then + # Do the single finish_eval. + eval cmds=\"$finish_eval\" + $run eval "$cmds" || admincmds="$admincmds + $cmds" + fi + done + fi + + # Exit here if they wanted silent mode. + test "$show" = ":" && exit 0 + + echo "----------------------------------------------------------------------" + echo "Libraries have been installed in:" + for libdir in $libdirs; do + echo " $libdir" + done + echo + echo "If you ever happen to want to link against installed libraries" + echo "in a given directory, LIBDIR, you must either use libtool, and" + echo "specify the full pathname of the library, or use the \`-LLIBDIR'" + echo "flag during linking and do at least one of the following:" + if test -n "$shlibpath_var"; then + echo " - add LIBDIR to the \`$shlibpath_var' environment variable" + echo " during execution" + fi + if test -n "$runpath_var"; then + echo " - add LIBDIR to the \`$runpath_var' environment variable" + echo " during linking" + fi + if test -n "$hardcode_libdir_flag_spec"; then + libdir=LIBDIR + eval flag=\"$hardcode_libdir_flag_spec\" + + echo " - use the \`$flag' linker flag" + fi + if test -n "$admincmds"; then + echo " - have your system administrator run these commands:$admincmds" + fi + if test -f /etc/ld.so.conf; then + echo " - have your system administrator add LIBDIR to \`/etc/ld.so.conf'" + fi + echo + echo "See any operating system documentation about shared libraries for" + echo "more information, such as the ld(1) and ld.so(8) manual pages." + echo "----------------------------------------------------------------------" + exit 0 + ;; + + # libtool execute mode + execute) + modename="$modename: execute" + + # The first argument is the command name. + cmd="$nonopt" + if test -z "$cmd"; then + $echo "$modename: you must specify a COMMAND" 1>&2 + $echo "$help" + exit 1 + fi + + # Handle -dlopen flags immediately. + for file in $execute_dlfiles; do + if test ! -f "$file"; then + $echo "$modename: \`$file' is not a file" 1>&2 + $echo "$help" 1>&2 + exit 1 + fi + + dir= + case $file in + *.la) + # Check to see that this really is a libtool archive. + if (sed -e '2q' $file | egrep "^# Generated by .*$PACKAGE") >/dev/null 2>&1; then : + else + $echo "$modename: \`$lib' is not a valid libtool archive" 1>&2 + $echo "$help" 1>&2 + exit 1 + fi + + # Read the libtool library. + dlname= + library_names= + + # If there is no directory component, then add one. + case $file in + */* | *\\*) . $file ;; + *) . ./$file ;; + esac + + # Skip this library if it cannot be dlopened. + if test -z "$dlname"; then + # Warn if it was a shared library. + test -n "$library_names" && $echo "$modename: warning: \`$file' was not linked with \`-export-dynamic'" + continue + fi + + dir=`$echo "X$file" | $Xsed -e 's%/[^/]*$%%'` + test "X$dir" = "X$file" && dir=. + + if test -f "$dir/$objdir/$dlname"; then + dir="$dir/$objdir" + else + $echo "$modename: cannot find \`$dlname' in \`$dir' or \`$dir/$objdir'" 1>&2 + exit 1 + fi + ;; + + *.lo) + # Just add the directory containing the .lo file. + dir=`$echo "X$file" | $Xsed -e 's%/[^/]*$%%'` + test "X$dir" = "X$file" && dir=. + ;; + + *) + $echo "$modename: warning \`-dlopen' is ignored for non-libtool libraries and objects" 1>&2 + continue + ;; + esac + + # Get the absolute pathname. + absdir=`cd "$dir" && pwd` + test -n "$absdir" && dir="$absdir" + + # Now add the directory to shlibpath_var. + if eval "test -z \"\$$shlibpath_var\""; then + eval "$shlibpath_var=\"\$dir\"" + else + eval "$shlibpath_var=\"\$dir:\$$shlibpath_var\"" + fi + done + + # This variable tells wrapper scripts just to set shlibpath_var + # rather than running their programs. + libtool_execute_magic="$magic" + + # Check if any of the arguments is a wrapper script. + args= + for file + do + case $file in + -*) ;; + *) + # Do a test to see if this is really a libtool program. + if (sed -e '4q' $file | egrep "^# Generated by .*$PACKAGE") >/dev/null 2>&1; then + # If there is no directory component, then add one. + case $file in + */* | *\\*) . $file ;; + *) . ./$file ;; + esac + + # Transform arg to wrapped name. + file="$progdir/$program" + fi + ;; + esac + # Quote arguments (to preserve shell metacharacters). + file=`$echo "X$file" | $Xsed -e "$sed_quote_subst"` + args="$args \"$file\"" + done + + if test -z "$run"; then + if test -n "$shlibpath_var"; then + # Export the shlibpath_var. + eval "export $shlibpath_var" + fi + + # Restore saved enviroment variables + if test "${save_LC_ALL+set}" = set; then + LC_ALL="$save_LC_ALL"; export LC_ALL + fi + if test "${save_LANG+set}" = set; then + LANG="$save_LANG"; export LANG + fi + + # Now prepare to actually exec the command. + exec_cmd='"$cmd"$args' + else + # Display what would be done. + if test -n "$shlibpath_var"; then + eval "\$echo \"\$shlibpath_var=\$$shlibpath_var\"" + $echo "export $shlibpath_var" + fi + $echo "$cmd$args" + exit 0 + fi + ;; + + # libtool clean and uninstall mode + clean | uninstall) + modename="$modename: $mode" + rm="$nonopt" + files= + rmforce= + exit_status=0 + + # This variable tells wrapper scripts just to set variables rather + # than running their programs. + libtool_install_magic="$magic" + + for arg + do + case $arg in + -f) rm="$rm $arg"; rmforce=yes ;; + -*) rm="$rm $arg" ;; + *) files="$files $arg" ;; + esac + done + + if test -z "$rm"; then + $echo "$modename: you must specify an RM program" 1>&2 + $echo "$help" 1>&2 + exit 1 + fi + + rmdirs= + + for file in $files; do + dir=`$echo "X$file" | $Xsed -e 's%/[^/]*$%%'` + if test "X$dir" = "X$file"; then + dir=. + objdir="$objdir" + else + objdir="$dir/$objdir" + fi + name=`$echo "X$file" | $Xsed -e 's%^.*/%%'` + test $mode = uninstall && objdir="$dir" + + # Remember objdir for removal later, being careful to avoid duplicates + if test $mode = clean; then + case " $rmdirs " in + *" $objdir "*) ;; + *) rmdirs="$rmdirs $objdir" ;; + esac + fi + + # Don't error if the file doesn't exist and rm -f was used. + if (test -L "$file") >/dev/null 2>&1 \ + || (test -h "$file") >/dev/null 2>&1 \ + || test -f "$file"; then + : + elif test -d "$file"; then + exit_status=1 + continue + elif test "$rmforce" = yes; then + continue + fi + + rmfiles="$file" + + case $name in + *.la) + # Possibly a libtool archive, so verify it. + if (sed -e '2q' $file | egrep "^# Generated by .*$PACKAGE") >/dev/null 2>&1; then + . $dir/$name + + # Delete the libtool libraries and symlinks. + for n in $library_names; do + rmfiles="$rmfiles $objdir/$n" + done + test -n "$old_library" && rmfiles="$rmfiles $objdir/$old_library" + test $mode = clean && rmfiles="$rmfiles $objdir/$name $objdir/${name}i" + + if test $mode = uninstall; then + if test -n "$library_names"; then + # Do each command in the postuninstall commands. + eval cmds=\"$postuninstall_cmds\" + IFS="${IFS= }"; save_ifs="$IFS"; IFS='~' + for cmd in $cmds; do + IFS="$save_ifs" + $show "$cmd" + $run eval "$cmd" + if test $? != 0 && test "$rmforce" != yes; then + exit_status=1 + fi + done + IFS="$save_ifs" + fi + + if test -n "$old_library"; then + # Do each command in the old_postuninstall commands. + eval cmds=\"$old_postuninstall_cmds\" + IFS="${IFS= }"; save_ifs="$IFS"; IFS='~' + for cmd in $cmds; do + IFS="$save_ifs" + $show "$cmd" + $run eval "$cmd" + if test $? != 0 && test "$rmforce" != yes; then + exit_status=1 + fi + done + IFS="$save_ifs" + fi + # FIXME: should reinstall the best remaining shared library. + fi + fi + ;; + + *.lo) + # Possibly a libtool object, so verify it. + if (sed -e '2q' $file | egrep "^# Generated by .*$PACKAGE") >/dev/null 2>&1; then + + # Read the .lo file + . $dir/$name + + # Add PIC object to the list of files to remove. + if test -n "$pic_object" \ + && test "$pic_object" != none; then + rmfiles="$rmfiles $dir/$pic_object" + fi + + # Add non-PIC object to the list of files to remove. + if test -n "$non_pic_object" \ + && test "$non_pic_object" != none; then + rmfiles="$rmfiles $dir/$non_pic_object" + fi + fi + ;; + + *) + # Do a test to see if this is a libtool program. + if test $mode = clean && + (sed -e '4q' $file | egrep "^# Generated by .*$PACKAGE") >/dev/null 2>&1; then + relink_command= + . $dir/$file + + rmfiles="$rmfiles $objdir/$name $objdir/${name}S.${objext}" + if test "$fast_install" = yes && test -n "$relink_command"; then + rmfiles="$rmfiles $objdir/lt-$name" + fi + fi + ;; + esac + $show "$rm $rmfiles" + $run $rm $rmfiles || exit_status=1 + done + + # Try to remove the ${objdir}s in the directories where we deleted files + for dir in $rmdirs; do + if test -d "$dir"; then + $show "rmdir $dir" + $run rmdir $dir >/dev/null 2>&1 + fi + done + + exit $exit_status + ;; + + "") + $echo "$modename: you must specify a MODE" 1>&2 + $echo "$generic_help" 1>&2 + exit 1 + ;; + esac + + if test -z "$exec_cmd"; then + $echo "$modename: invalid operation mode \`$mode'" 1>&2 + $echo "$generic_help" 1>&2 + exit 1 + fi +fi # test -z "$show_help" + +if test -n "$exec_cmd"; then + eval exec $exec_cmd + exit 1 +fi + +# We need to display help for each of the modes. +case $mode in +"") $echo \ +"Usage: $modename [OPTION]... [MODE-ARG]... + +Provide generalized library-building support services. + + --config show all configuration variables + --debug enable verbose shell tracing +-n, --dry-run display commands without modifying any files + --features display basic configuration information and exit + --finish same as \`--mode=finish' + --help display this help message and exit + --mode=MODE use operation mode MODE [default=inferred from MODE-ARGS] + --quiet same as \`--silent' + --silent don't print informational messages + --tag=TAG use configuration variables from tag TAG + --version print version information + +MODE must be one of the following: + + clean remove files from the build directory + compile compile a source file into a libtool object + execute automatically set library path, then run a program + finish complete the installation of libtool libraries + install install libraries or executables + link create a library or an executable + uninstall remove libraries from an installed directory + +MODE-ARGS vary depending on the MODE. Try \`$modename --help --mode=MODE' for +a more detailed description of MODE." + exit 0 + ;; + +clean) + $echo \ +"Usage: $modename [OPTION]... --mode=clean RM [RM-OPTION]... FILE... + +Remove files from the build directory. + +RM is the name of the program to use to delete files associated with each FILE +(typically \`/bin/rm'). RM-OPTIONS are options (such as \`-f') to be passed +to RM. + +If FILE is a libtool library, object or program, all the files associated +with it are deleted. Otherwise, only FILE itself is deleted using RM." + ;; + +compile) + $echo \ +"Usage: $modename [OPTION]... --mode=compile COMPILE-COMMAND... SOURCEFILE + +Compile a source file into a libtool library object. + +This mode accepts the following additional options: + + -o OUTPUT-FILE set the output file name to OUTPUT-FILE + -prefer-pic try to building PIC objects only + -prefer-non-pic try to building non-PIC objects only + -static always build a \`.o' file suitable for static linking + +COMPILE-COMMAND is a command to be used in creating a \`standard' object file +from the given SOURCEFILE. + +The output file name is determined by removing the directory component from +SOURCEFILE, then substituting the C source code suffix \`.c' with the +library object suffix, \`.lo'." + ;; + +execute) + $echo \ +"Usage: $modename [OPTION]... --mode=execute COMMAND [ARGS]... + +Automatically set library path, then run a program. + +This mode accepts the following additional options: + + -dlopen FILE add the directory containing FILE to the library path + +This mode sets the library path environment variable according to \`-dlopen' +flags. + +If any of the ARGS are libtool executable wrappers, then they are translated +into their corresponding uninstalled binary, and any of their required library +directories are added to the library path. + +Then, COMMAND is executed, with ARGS as arguments." + ;; + +finish) + $echo \ +"Usage: $modename [OPTION]... --mode=finish [LIBDIR]... + +Complete the installation of libtool libraries. + +Each LIBDIR is a directory that contains libtool libraries. + +The commands that this mode executes may require superuser privileges. Use +the \`--dry-run' option if you just want to see what would be executed." + ;; + +install) + $echo \ +"Usage: $modename [OPTION]... --mode=install INSTALL-COMMAND... + +Install executables or libraries. + +INSTALL-COMMAND is the installation command. The first component should be +either the \`install' or \`cp' program. + +The rest of the components are interpreted as arguments to that command (only +BSD-compatible install options are recognized)." + ;; + +link) + $echo \ +"Usage: $modename [OPTION]... --mode=link LINK-COMMAND... + +Link object files or libraries together to form another library, or to +create an executable program. + +LINK-COMMAND is a command using the C compiler that you would use to create +a program from several object files. + +The following components of LINK-COMMAND are treated specially: + + -all-static do not do any dynamic linking at all + -avoid-version do not add a version suffix if possible + -dlopen FILE \`-dlpreopen' FILE if it cannot be dlopened at runtime + -dlpreopen FILE link in FILE and add its symbols to lt_preloaded_symbols + -export-dynamic allow symbols from OUTPUT-FILE to be resolved with dlsym(3) + -export-symbols SYMFILE + try to export only the symbols listed in SYMFILE + -export-symbols-regex REGEX + try to export only the symbols matching REGEX + -LLIBDIR search LIBDIR for required installed libraries + -lNAME OUTPUT-FILE requires the installed library libNAME + -module build a library that can dlopened + -no-fast-install disable the fast-install mode + -no-install link a not-installable executable + -no-undefined declare that a library does not refer to external symbols + -o OUTPUT-FILE create OUTPUT-FILE from the specified objects + -objectlist FILE Use a list of object files found in FILE to specify objects + -release RELEASE specify package release information + -rpath LIBDIR the created library will eventually be installed in LIBDIR + -R[ ]LIBDIR add LIBDIR to the runtime path of programs and libraries + -static do not do any dynamic linking of libtool libraries + -version-info CURRENT[:REVISION[:AGE]] + specify library version info [each variable defaults to 0] + +All other options (arguments beginning with \`-') are ignored. + +Every other argument is treated as a filename. Files ending in \`.la' are +treated as uninstalled libtool libraries, other files are standard or library +object files. + +If the OUTPUT-FILE ends in \`.la', then a libtool library is created, +only library objects (\`.lo' files) may be specified, and \`-rpath' is +required, except when creating a convenience library. + +If OUTPUT-FILE ends in \`.a' or \`.lib', then a standard library is created +using \`ar' and \`ranlib', or on Windows using \`lib'. + +If OUTPUT-FILE ends in \`.lo' or \`.${objext}', then a reloadable object file +is created, otherwise an executable program is created." + ;; + +uninstall) + $echo \ +"Usage: $modename [OPTION]... --mode=uninstall RM [RM-OPTION]... FILE... + +Remove libraries from an installation directory. + +RM is the name of the program to use to delete files associated with each FILE +(typically \`/bin/rm'). RM-OPTIONS are options (such as \`-f') to be passed +to RM. + +If FILE is a libtool library, all the files associated with it are deleted. +Otherwise, only FILE itself is deleted using RM." + ;; + +*) + $echo "$modename: invalid operation mode \`$mode'" 1>&2 + $echo "$help" 1>&2 + exit 1 + ;; +esac + +echo +$echo "Try \`$modename --help' for more information about other modes." + +exit 0 + +# The TAGs below are defined such that we never get into a situation +# in which we disable both kinds of libraries. Given conflicting +# choices, we go for a static library, that is the most portable, +# since we can't tell whether shared libraries were disabled because +# the user asked for that or because the platform doesn't support +# them. This is particularly important on AIX, because we don't +# support having both static and shared libraries enabled at the same +# time on that platform, so we default to a shared-only configuration. +# If a disable-shared tag is given, we'll fallback to a static-only +# configuration. But we'll never go from static-only to shared-only. + +### BEGIN LIBTOOL TAG CONFIG: disable-shared +build_libtool_libs=no +build_old_libs=yes +### END LIBTOOL TAG CONFIG: disable-shared + +### BEGIN LIBTOOL TAG CONFIG: disable-static +build_old_libs=`case $build_libtool_libs in yes) echo no;; *) echo yes;; esac` +### END LIBTOOL TAG CONFIG: disable-static + +# Local Variables: +# mode:shell-script +# sh-indentation:2 +# End: diff --git a/machines b/machines new file mode 100755 index 0000000..feea6c5 --- /dev/null +++ b/machines @@ -0,0 +1,36 @@ + +names for various supported machines. + +* 386-linux: 386 or 486 running linux (a.out or elf) +* 386-bsd: 386 or 486 running bsd +* alpha-osf1: Dec alpha DEC OSF/1 V3.2 Worksystem Software (Rev. 214) +* dec3100: Decstation 3100,5000, OS=Ultrix V3.1C-0 (Rev. 42) [akcl 505] + ULTRIX V4.2 (Rev. 96)[akcl 602] (VOL= ) +* hp300-bsd: Hp 350, 370 [motorola 68K] under 4.3 BSD (mt xinu) +* hp300: Hp 350, 370 under HPUX. +* hp800: Hp 720,730 under HPUX (version 8). Possibly hp 800 also +* mac2: Macintosh under AUX (unix) +* mingw: Windows built with MSYS hosted Mingw32 gcc +* mp386: intel 386 under System V 3 (eg microport,interactive) +* NeXT30-m68k: NeXT (M68K) under NeXTSTEP 3.0 +* NeXT32-m68k: NeXT (M68K) under NeXTSTEP 3.2, 3.3 (gcc-2.6.3 is required) +* NeXT32-i386: NeXT (I386) under NeXTSTEP 3.2, 3.3 (gcc-2.6.3 is required) +* ncr: intel 386 under System V 4 (loader sfasl not done). +* ps2_aix: ibm ps2 under aix +* rios: Ibm risc 6000 under aix3. +* rios: Ibm risc 6000 under aix4.3 but load does not yet work. +* rt_aix: ibm rt under aix release 2. +* sgi4d: 4d silicon graphics (IRIX System V Release 3.3.1)[akcl 600] +* sgi: silicon graphics 3d versions +* irix5: silicon graphics (IRIX Rel 5.2) /*cant save dynamically loaded*/ +* sun3-os4: sun3 under os 4.03, 4.1, 4.1.1 +* sun3: Sun 3 (motorola 68K) Sun OS 3.5 +* sun4: Sun 4,(sparc) sparctations, sun os 4.03, 4.1.x +* solaris: Sun 4,(sparc) sparctations, sun os 5 (solaris 2.5,2.6) use gcc +* solaris-i386: Intel x86 processors running sun os 5 (solaris 2.5) +* sparc-linux: sparc processor running linux +* symmetry: sequent symmetry (386 chips) DYNIX-3.0.12+ +* u370: IBM 370 (3090's) under AIX +* vax: Vax under 4.3 bsd., also ultrix + + diff --git a/majvers b/majvers new file mode 100755 index 0000000..0cfbf08 --- /dev/null +++ b/majvers @@ -0,0 +1 @@ +2 diff --git a/makdefs b/makdefs new file mode 100755 index 0000000..f5182df --- /dev/null +++ b/makdefs @@ -0,0 +1,42 @@ +# constructed by wfs using: ./add-defs 386-linux +# constructed by wfs using: ./add-defs 386-linux /usr/local +# constructed by wfs using: ./add-defs 386-linux /usr/local +# constructed by wfs using: ./add-defs 386-linux /usr/local +# constructed by wfs using: ./add-defs 386-linux +# constructed by wfs using: add-defs 386-linux /usr/local/lib +# constructed by wfs using: add-defs 386-linux /usr/local +# constructed by wfs using: ./add-defs 386-linux /usr/local +# constructed by wfs using: add-defs 386-linux /usr/local +# constructed by wfs using: ./add-defs cygwin +# constructed by wfs using: ./add-defs cygwin cygwin +# constructed by wfs using: ./add-defs cygwin +# constructed by wfs using: ./add-defs cygwin cygwin +# constructed by wfs using: ./add-defs cygwin cygwin +# constructed by wfs using: ./add-defs cygwin cygwin +# constructed by wfs using: ./add-defs cygwin cygwin +# constructed by wfs using: ./add-defs cygwin cygwin +# constructed by wfs using: ./add-defs cygwin +# constructed by wfs using: ./add-defs cygwin +# constructed by wfs using: ./add-defs cygwin +# constructed by wfs using: ./add-defs cygwin +# constructed by wfs using: ./add-defs cygwin +# constructed by wfs using: ./add-defs cygwin +# constructed by wfs using: ./add-defs cygwin +# constructed by wfs using: ./add-defs cygwin +# constructed by using: ./add-defs cygwinb +# constructed by using: ./add-defs cygwinb +# constructed by using: add-defs cygwinb +# constructed by using: ./add-defs cygwinb +# constructed by using: ./add-defs cygwinb +# constructed by using: ./add-defs cygwinb +# constructed by using: ./add-defs cygwinb +# constructed by using: ./add-defs cygwinb +# constructed by using: add-defs cygwinb +# constructed by using: add-defs cygwinb +# constructed by using: ./add-defs gnuwin95 +# constructed by using: ./add-defs gnuwin95 +# constructed by using: ./add-defs gnuwin95 +# constructed by using: add-defs gnuwin95 +# constructed by using: ./add-defs gnuwin95 +# constructed by wfs using: ./add-defs 386-linux +# constructed by wfs using: ./add-defs 386-linux diff --git a/makedefc.in b/makedefc.in new file mode 100644 index 0000000..6f0d33b --- /dev/null +++ b/makedefc.in @@ -0,0 +1,75 @@ + +# begin makedefs + +# use=@use@ + +# for main link of raw_gcl +LIBS=@LIBS@ + +#The multi precision library stuff +MPFILES=$(MPDIR)/@MPI_FILE@ $(MPDIR)/libmport.a + + +# root for the installation, eg /usr/local +# This would cause make install to create /usr/local/bin/gcl and +# /usr/local/lib/gcl-2-??/* with some basic files. +prefix=@prefix@ + +# where to place the info files +INFO_DIR=@INFO_DIR@ + +# where to put emacs lisp files. +EMACS_SITE_LISP=@EMACS_SITE_LISP@ + +# the default.el file +EMACS_DEFAULT_EL=@EMACS_DEFAULT_EL@ + +# numerous TCL/TK variables culled from the tkConfig.sh and tclConfig.sh +# if these are found. +TK_CONFIG_PREFIX=@TK_CONFIG_PREFIX@ +TK_LIBRARY=@TK_LIBRARY@ +TCL_LIBRARY=@TCL_LIBRARY@ +TK_XINCLUDES=@TK_XINCLUDES@ +TK_INCLUDE=@TK_INCLUDE@ +TCL_INCLUDE=@TCL_INCLUDE@ +TK_LIB_SPEC=@TK_LIB_SPEC@ +TK_BUILD_LIB_SPEC=@TK_BUILD_LIB_SPEC@ +TK_XLIBSW=@TK_XLIBSW@ +TK_XINCLUDES=@TK_XINCLUDES@ +TCL_LIB_SPEC=@TCL_LIB_SPEC@ +TCL_DL_LIBS=@TCL_DL_LIBS@ +TCL_LIBS=@TCL_LIBS@ + +PRELINK_CHECK=@PRELINK_CHECK@ + + +NOTIFY=@NOTIFY@ +CC=@CC@ +CFLAGS=@CFLAGS@ +LDFLAGS=@LDFLAGS@ +FINAL_CFLAGS=@FINAL_CFLAGS@ +NIFLAGS=@NIFLAGS@ +O3FLAGS=@O3FLAGS@ +O2FLAGS=@O2FLAGS@ + +RL_OBJS=@RL_OBJS@ + +RL_LIB=@RL_LIB@ + +MAKEINFO=@MAKEINFO@ + +FLISP=@FLISP@ +SYSTEM=@SYSTEM@ +BUILD_BFD=@BUILD_BFD@ +GMPDIR=@GMPDIR@ +X_LIBS=@X_LIBS@ +X_CFLAGS=@X_CFLAGS@ + +PROCESSOR_FLAGS=@PROCESSOR_FLAGS@ + +EXTRA_LOBJS=@EXTRA_LOBJS@ +LEADING_UNDERSCORE=@LEADING_UNDERSCORE@ +GNU_LD=@GNU_LD@ +AWK=@AWK@ +LIBBFD=@LIBBFD@ +LIBIBERTY=@LIBIBERTY@ diff --git a/makefile b/makefile new file mode 100644 index 0000000..2918843 --- /dev/null +++ b/makefile @@ -0,0 +1,294 @@ +# Compiling gcl: +# ./configure +# make +# For more details see the file readme + +prefix=/usr/local +# This would cause make install to create /usr/local/bin/gcl and +# /usr/local/lib/gcl-x.yy/* with some basic files. +# This prefix may be overridden e.g. with +# ./configure --prefix=/usr/share + +# Allow platform defs file to override this. +TK_LISP_LIB=gcl-tk/tkl.o gcl-tk/tinfo.o gcl-tk/decode.tcl gcl-tk/demos/*.lsp gcl-tk/demos/*.lisp gcl-tk/demos/*.o +TCL_EXES=gcl-tk/gcl.tcl gcl-tk/gcltkaux$(EXE) + +GCL_DVI=gcl-tk.dvi gcl-si.dvi gcl.dvi +GCL_HTML=gcl-si_toc.html gcl-tk_toc.html gcl_toc.html + +-include makedefs + + +BINDIR = bin +HDIR = h/ +CDIR = c +ODIR = o +LSPDIR = lsp +CMPDIR = cmpnew +PORTDIR = unixport +CLCSDIR = clcs +PCLDIR = pcl +MPDIR = mp +TESTDIR = ansi-tests +#GMP_DIR = gmp3/ + +VERSION=`cat majvers`.`cat minvers` + +all: $(BUILD_BFD) system command cmpnew/gcl_collectfn.o lsp/gcl_info.o do-gcl-tk # do-info + +ASRC:=$(shell ls -1 o/*.c lsp/*.lsp cmpnew/*.lsp mod/*.lsp pcl/*sp clcs/*sp xgcl-2/*p) #o/*.d o/*.h h/*.h +TAGS: $(ASRC) + etags --regex='/\#.`(defun[ \n\t]+\([^ \n\t]+\)/' $^ + +system: $(PORTDIR)/$(FLISP) +# [ "$(X_LIBS)" == "" ] || (cd xgcl-2 && make saved_xgcl LISP=../$< && mv saved_xgcl ../$(PORTDIR)/$(FLISP)) + touch $@ + +xgcl: $(PORTDIR)/saved_xgcl + +$(PORTDIR)/saved_xgcl: $(PORTDIR)/saved_gcl + cd xgcl-2 && $(MAKE) + +#binutils/intl/libintl.a: +# cd $(@D) && $(MAKE) + +#binutils/bfd/libbfd.a binutils/libiberty/libiberty.a: binutils/intl/libintl.a +# cd $(@D) && $(MAKE) + +copy_iberty: $(LIBIBERTY) + mkdir -p binutils/libiberty && cd binutils/libiberty && ar x $< + +copy_bfd: $(LIBBFD) copy_iberty + mkdir -p binutils/bfd && cd binutils/bfd && ar x $< + +#h/bfd.h: binutils/bfd/libbfd.a binutils/libiberty/libiberty.a +# cp $(&1 |tee $(@F) & j=$$! ; \ + tail -f --pid=$$j --retry $@ & wait $$j + +#$(PCLDIR)/saved_gcl_pcl: $(PORTDIR)/saved_gcl +# cd $(@D) && $(MAKE) compile LISP="../$<" && $(MAKE) $(@F) LISP="../$<" + +#$(CLCSDIR)/saved_full_gcl: $(PCLDIR)/saved_gcl_pcl +# cd $(@D) && $(MAKE) compile LISP="../$<" && $(MAKE) $(@F) LISP="../$<" + +#$(PORTDIR)/saved_ansi_gcl: $(CLCSDIR)/saved_full_gcl +# cd $(@D) && $(MAKE) $(@F) + +cmpnew/gcl_collectfn.o lsp/gcl_info.o: + cd $(@D) && $(MAKE) $(@F) + +do-gcl-tk: + if [ -d "$(TK_CONFIG_PREFIX)" ] ; then \ + cd gcl-tk && $(MAKE) ; \ + else \ + echo "gcl-tk not made..missing include or lib" ; \ + fi + +do-info: + cd info && $(MAKE) + +mpfiles: $(MPFILES) + +$(MPDIR)/libmport.a: + (cd mp ; $(MAKE) all) + +$(GMPDIR)/libgmp.a: $(GMPDIR)/Makefile + cd $(GMPDIR) && $(MAKE) && rm -f libgmp.a && ar qc libgmp.a *.o */*.o + +PWD_CMD?=pwd + +gmp_all: $(GMPDIR)/Makefile + cd $(GMPDIR) && echo '#include ' >> gmp.h && echo "#include \"`$(PWD_CMD)`/../h/prelink.h\"" >> gmp.h && $(MAKE) + touch $@ + +$(GMPDIR)/mpn/mul_n.o $(GMPDIR)/mpn/lshift.o $(GMPDIR)/mpn/rshift.o: $(GMPDIR)/Makefile + cd $(@D) && $(MAKE) $(@F) + +command: + rm -f bin/gcl xbin/gcl + MGCLDIR=`echo $(GCLDIR) | sed -e 'sX^\([a-z]\):X/\1Xg'` ; \ + GCLDIR=`echo $(GCLDIR)` ; \ + $(MAKE) install-command "INSTALL_LIB_DIR=$$GCLDIR" "prefix=$$GCLDIR" "BINDIR=$$MGCLDIR/$(PORTDIR)" + (cd xbin ; cp ../bin/gcl .) + +# GCLDIR=`echo $(GCLDIR) | sed -e 'sX^/cygdrive/\([a-z]\)X\1!Xg' -e 'sX^//\([a-z]\)X\1!Xg'` ; \ + +merge: + $(CC) -o merge merge.c + +LISP_LIB=cmpnew/gcl_collectfn.o cmpnew/gcl_collectfn.lsp xgcl-2/sysdef.lisp xgcl-2/gcl_dwtest.lsp xgcl-2/gcl_dwtestcases.lsp lsp/gcl_gprof.lsp lsp/gcl_info.o lsp/gcl_profile.lsp lsp/gcl_export.lsp lsp/gcl_autoload.lsp cmpnew/gcl_cmpmain.lsp cmpnew/gcl_cmpopt.lsp cmpnew/gcl_lfun_list.lsp lsp/gcl_auto_new.lsp h/cmpinclude.h unixport/init_$(SYSTEM).lsp unixport/lib$(SYSTEM).a unixport/libgclp.a gcl-tk/tk-package.lsp $(TK_LISP_LIB) $(RL_LIB) $(FIRST_FILE) $(LAST_FILE) $(addsuffix /sys-proclaim.lisp,lsp cmpnew pcl clcs) unixport/gcl.script + +install-command: + rm -f $(DESTDIR)$(prefix)/bin/gcl + (echo '#!/bin/sh' ; \ + echo exec $(BINDIR)/$(FLISP)$(EXE) \\ ; \ + echo ' -dir' $(INSTALL_LIB_DIR)/unixport/ \\ ; \ + echo ' -libdir' $(INSTALL_LIB_DIR)/ \\ ; \ + echo ' -eval '\''(setq si::*allow-gzipped-file* t)'\' \\ ;\ + ! [ -d "$(TK_CONFIG_PREFIX)" ] || echo ' -eval '\''(setq si::*tk-library* '\"$(TK_LIBRARY)\"')'\' \\;\ + echo ' '\"\$$@\" ) > $(DESTDIR)$(prefix)/bin/gcl; + echo '#' other options: -load "/tmp/foo.o" -load "jo.lsp" -eval '"(joe 3)"' >> $(DESTDIR)$(prefix)/bin/gcl + chmod a+x $(DESTDIR)$(prefix)/bin/gcl + rm -f $(DESTDIR)$(prefix)/bin/gclm.bat + if gcc --version | grep mingw >/dev/null 2>&1 ; then (echo '@SET cd='; \ + echo '@SET promp$=%prompt%'; \ + echo '@PROMPT SET cd$Q$P'; \ + echo '@CALL>%temp%.\setdir.bat'; \ + echo '@'; \ + echo '% do not delete this line %'; \ + echo '@ECHO off'; \ + echo 'PROMPT %promp$%'; \ + echo 'FOR %%c IN (CALL DEL) DO %%c %temp%.\setdir.bat'; \ + echo 'set cwd=%cd%'; \ + echo 'set libdir=%cd%\..\lib\gcl-$(VERSION)'; \ + echo 'set unixportdir=%libdir%\unixport'; \ + echo 'path %cd%\..\mingw\bin;%PATH%'; \ + echo "start %unixportdir%\$(FLISP).exe -dir %unixportdir% -libdir %libdir% -eval \"(setq si::*allow-gzipped-file* t)\" %1 %2 %3 %4 %5 %6 %7 %8 %9" ) > $(DESTDIR)$(prefix)/bin/gclm.bat ; fi + rm -f $(DESTDIR)$(prefix)/bin/gclfinal.bat + if gcc --version | grep -i mingw >/dev/null 2>&1 ; then (echo 'ECHO path %1\mingw\bin;%PATH% > gcli.bat'; \ + echo "ECHO start %1\lib\gcl-$(VERSION)\unixport\$(FLISP).exe -dir %1\lib\gcl-$(VERSION)\unixport -libdir %1\lib\gcl-$(VERSION) -eval \"(setq si::*allow-gzipped-file* t)\" %1 %2 %3 %4 %5 %6 %7 %8 %9 >> gcli.bat" ) > $(DESTDIR)$(prefix)/bin/gclfinal.bat ; fi + +install: + $(MAKE) install1 "INSTALL_LIB_DIR=$(prefix)/lib/gcl-`cat majvers`.`cat minvers`" "prefix=$(prefix)" "DESTDIR=$(DESTDIR)" +INSTALL_LIB_DIR= +install1: + mkdir -p $(DESTDIR)$(prefix)/lib + mkdir -p $(DESTDIR)$(prefix)/bin + mkdir -p $(DESTDIR)$(prefix)/share + cp -a man $(DESTDIR)$(prefix)/share/ + mkdir -p $(DESTDIR)$(INSTALL_LIB_DIR) + MINSTALL_LIB_DIR=`echo $(INSTALL_LIB_DIR) | sed -e 'sX^\([a-z]\):X/\1Xg'` ; \ + $(MAKE) install-command "INSTALL_LIB_DIR=$(INSTALL_LIB_DIR)" "prefix=$(prefix)" "DESTDIR=$(DESTDIR)" "BINDIR=$$MINSTALL_LIB_DIR/unixport" + rm -f $(DESTDIR)$(prefix)/bin/gcl.exe + tar cf - $(PORTDIR)/$(FLISP)$(EXE) info/*.info* $(LISP_LIB) \ + $(TCL_EXES) | (cd $(DESTDIR)$(INSTALL_LIB_DIR) ;tar xf -) + if gcc --version | grep -i mingw >/dev/null 2>&1 ; then if grep -i oncrpc makedefs >/dev/null 2>&1 ; then cp /mingw/bin/oncrpc.dll $(DESTDIR)$(INSTALL_LIB_DIR)/$(PORTDIR); fi ; fi + cd $(DESTDIR)$(INSTALL_LIB_DIR)/$(PORTDIR) && \ + mv $(FLISP)$(EXE) temp$(EXE) && \ + echo '(reset-sys-paths "$(INSTALL_LIB_DIR)/")(si::save-system "$(FLISP)$(EXE)")' | ./temp$(EXE) && \ + rm -f temp$(EXE) + if [ -e "unixport/rsym$(EXE)" ] ; then cp unixport/rsym$(EXE) $(DESTDIR)$(INSTALL_LIB_DIR)/unixport/ ; fi +# ln $(SYMB) $(INSTALL_LIB_DIR)/$(PORTDIR)/$(FLISP)$(EXE) \ +# $(DESTDIR)$(prefix)/bin/gcl.exe + if [ -d "$(TK_CONFIG_PREFIX)" ] ; then \ + cat gcl-tk/gcltksrv$(BAT) | \ + sed -e "s!GCL_TK_DIR=.*!GCL_TK_DIR=$(INSTALL_LIB_DIR)/gcl-tk!g" \ + -e "s!TK_LIBRARY=.*!TK_LIBRARY=$(TK_LIBRARY)!g" > \ + $(DESTDIR)$(INSTALL_LIB_DIR)/gcl-tk/gcltksrv$(BAT) ; \ + chmod a+x $(DESTDIR)$(INSTALL_LIB_DIR)/gcl-tk/gcltksrv$(BAT) ; fi +# if [ -d "$(TK_CONFIG_PREFIX)" ] ; then \ +# (cd $(DESTDIR)$(INSTALL_LIB_DIR)/gcl-tk/demos ; \ +# echo '(load "../tkl.o")(TK::GET-AUTOLOADS (directory "*.lisp"))' | ../../$(PORTDIR)/$(FLISP)$(EXE)) ; fi + if test "$(EMACS_SITE_LISP)" != "" ; then (cd elisp ; $(MAKE) install DESTDIR=$(DESTDIR)) ; fi + if test "$(INFO_DIR)" != "unknown"; then (cd info ; $(MAKE) install DESTDIR=$(DESTDIR)) ; fi + if test "$(INFO_DIR)" != "unknown"; then (cd xgcl-2 ; $(MAKE) install DESTDIR=$(DESTDIR)) ; fi + if gcc --version | grep -i mingw >/dev/null 2>&1 ; then cp COPYING.LIB-2.0 readme-bin.mingw $(prefix) ; fi + if gcc --version | grep -i mingw >/dev/null 2>&1 ; then cp gcl.ico $(prefix)/bin ; fi + if gcc --version | grep -i mingw >/dev/null 2>&1 ; then rm -rf $(prefix)/install; mkdir $(prefix)/install ; cp windows/install.lsp $(prefix)/install ; windows/instdos.sh windows/sysdir.bat $(prefix)/bin/sysdir.bat ; fi + -if gcc --version | grep -i mingw >/dev/null 2>&1 ; then rm -rf $(prefix)/doc; mkdir $(prefix)/doc; cp info/*.html $(prefix)/doc ; fi + -if gcc --version | grep -i mingw >/dev/null 2>&1 ; then rm -rf $(prefix)/doc; mkdir $(prefix)/doc; cp -rp info/gcl info/gcl-si info/gcl-tk $(prefix)/doc ; fi + +gclclean: + + (cd $(BINDIR); $(MAKE) clean) + (cd mp ; $(MAKE) clean) + (cd $(ODIR); $(MAKE) clean) + (cd $(LSPDIR); $(MAKE) clean) + (cd $(CMPDIR); $(MAKE) clean) + (cd $(PORTDIR); $(MAKE) clean) + (cd gcl-tk ; $(MAKE) clean) + cd $(CLCSDIR) && $(MAKE) clean + cd $(PCLDIR) && $(MAKE) clean + cd xgcl-2 && $(MAKE) clean + (cd $(TESTDIR); $(MAKE) clean) +# (cd info ; $(MAKE) clean) +# find binutils -name "*.o" -exec rm {} \; + rm -rf binutils + rm -f foo.tcl config.log makedefs makedefsafter config.cache config.status makedefc + rm -f h/config.h h/gclincl.h h/cmpinclude.h h/gmp.h + rm -f xbin/gcl foo foo.c bin/gclm.bat gmp_all + rm -f h/*-linux.defs h/bfd.h h/bfdlink.h h/ansidecl.h h/symcat.h + rm -f windows/gcl.iss bin/gcl.bat windows/gcl.ansi.iss windows/install.ansi.lsp \ + windows/install.lsp windows/sysdir.bat + rm -rf windows/Output + rm -f ansi-tests/test_results ansi-tests/gazonk*lsp + rm -rf autom4te.cache h/mcompdefs.h + rm -f config.log config.cache config.status tmpx $(PORTDIR)/gmon.out gcl.script machine system + +clean: gclclean + -[ -z "$(GMPDIR)" ] || (cd $(GMPDIR) && $(MAKE) distclean) + -[ -z "$(GMPDIR)" ] || rm -rf $(GMPDIR)/.deps $(GMPDIR)/libgmp.a +# -cd binutils/intl && $(MAKE) distclean +# -cd binutils/bfd && $(MAKE) distclean +# -cd binutils/libiberty && $(MAKE) distclean + +CMPINCLUDE_FILES=$(HDIR)cmpincl1.h $(HDIR)gclincl.h $(HDIR)compbas.h $(HDIR)type.h $(HDIR)mgmp.h \ + $(HDIR)lu.h $(HDIR)globals.h $(HDIR)vs.h \ + $(HDIR)bds.h $(HDIR)frame.h \ + $(HDIR)lex.h \ + $(HDIR)compprotos.h $(HDIR)immnum.h + +OTHERS=$(HDIR)notcomp.h $(HDIR)rgbc.h $(HDIR)stacks.h + +$(HDIR)new_decl.h: + (cd o && $(MAKE) ../$@) + +$(HDIR)mcompdefs.h: $(HDIR)compdefs.h $(HDIR)new_decl.h + $(AWK) 'BEGIN {print "#include \"include.h\"";print "#include \"cmponly.h\"";print "---"} {a=$$1;gsub("\\.\\.\\.","",a);print "\"#define " $$1 "\" " a}' $< |\ + $(CC) -E -I./$(HDIR) - |\ + $(AWK) '/^\-\-\-$$/ {i=1;next} {if (!i) next} {gsub("\"","");print}' >$@ + +$(HDIR)cmpinclude.h: $(HDIR)mcompdefs.h $(CMPINCLUDE_FILES) $(HDIR)config.h + cp $< $(@F) + cat $(CMPINCLUDE_FILES) | $(CC) -E -I./$(HDIR) - | $(AWK) '/^# |^$$|^#pragma/ {next}{print}' >> $(@F) + ./xbin/move-if-changed mv $(@F) $@ + ./xbin/move-if-changed cp $@ o/$(@F) + +go: + mkdir go + (cd go ; cp -s ../o/makefile ../o/*.o ../o/*.c ../o/*.d ../o/*.ini .) + (cd go ; $(MAKE) go) + +tar: + rm -f gcl-`cat majvers`.`cat minvers` + xbin/distribute ../ngcl-`cat majvers`.`cat minvers`-beta.tgz + +configure: configure.in + autoconf configure.in > configure + chmod a+rx configure + +kcp: + (cd go ; $(MAKE) "CFLAGS = -I../h -pg -c -g ") + (cd unixport ; $(MAKE) gcp) + +.INTERMEDIATE: $(HDIR)mcompdefs.h diff --git a/man/man1/gcl.1 b/man/man1/gcl.1 new file mode 100755 index 0000000..7a086c5 --- /dev/null +++ b/man/man1/gcl.1 @@ -0,0 +1,248 @@ +.TH GCL 1L "17 March 1997" +.SH NAME +gcl \- GCL Common Lisp interpreter/compiler, CVS snapshot +.SH SYNOPSIS +.B gcl +[ +.B options +] + +.SH DESCRIPTION + +The program +.I gcl +is an implementation of a subset of the Common Lisp Ansi standard. +It is written in C and in Common Lisp, and is highly portable. It +includes those features in the original definition of Common Lisp, +(Guy Steele version 1.), as well as some features from the proposed +new standard. +.LP +The best documentation is available in +.I texinfo/info +form, with there being three groups of information. +.I gcl\-si +for basic common lisp descriptions, and features unique to +.I gcl +The +.I gcl\-tk +info refers to the connection with +.I tk +window system, allowing all the power of the +.I tcl/tk +interaction system to be used from lisp. +The third info file +.I gcl +details the Ansi standard for common lisp, to which this subset +tries to adhere. It is highly recommended to write programs, +which will be in the intersection of gcl and ansi common lisp. +Unfortunately the Ansi standard is huge, and will require a substantial +effort, and increase in the size of gcl, to include all of it. +.LP +When +.I gcl +is invoked from the shell, the variable +.I si::*command\-args* +is set to the list of command line arguments. +Various +.I options +are understood: +.TP +.BR \-eval\ command +.RB +Call read and then eval on the +.I command passed in. +.TP +.B \-\- +.RB +Stop processing arguments, setting si::*command\-args* to a list +containing the arguments after the +.BR \-\- . +.TP +.BR \-load\ pathname +.RB +Load the file whose +.I pathname +is specified after +.BR \-load . +.TP +.BR \-f +.RB +Open the file following +.BR \-f +for input, skip the first line, and +then read and eval the rest of the forms in the file. +Replaces si::*command\-args* by the the list starting after +.BR \-f . +This can be used as with the shells to write small shell programs: + +.LP +.br +#!/usr/local/bin/gcl.exe \-f +.br +(format t "hello world ~a~%" (nth 1 si::*command\-args*)) + +.BR +The value +.I si::*command\-args* +will have the appropriate value. +Thus if the above 2 line file is made executable and called +.I foo +then + +.LP +.LP +.br +tutorial% foo billy +.br +hello world billy + +.BR +NOTE: On many systems (eg SunOs) the first line of an executable +script file such as: +.BR +#!/usr/local/bin/gcl.exe \-f +only reads the first 32 characters! So if your pathname where +the executable together with the '\-f' amount to more than 32 +characters the file will not be recognized. Also the executable +must be the actual large binary file, [or a link to it], and not +just a +.I /bin/sh +script. In latter case the +.I /bin/sh +interpreter would get invoked on the file. + +Alternately one could invoke the file +.I foo +without making it +executable: +.LP +.LP +.br +tutorial% gcl \-f foo "from bill" +.br +hello world from bill + +.TP +.B \-batch +.RB +Do not enter the command print loop. Useful if the other command +line arguments do something. Do not print the License and +acknowledgement information. Note if your program does print any +License information, it must print the GCL header information also. + +.TP +.B \-dir +.RB +Directory where the executable binary that is running is located. +Needed by save and friends. This gets set as +si::*system\-directory* + +.TP +.B \-libdir +.RB +.BR \-libdir +.I /d/wfs/gcl\-2.0/ +.RB + +would mean that the files like gcl\-tk/tk.o would be found by +concatting the path to the libdir path, ie in +.RB /d/wfs/gcl\-2.0/gcl\-tk/tk.o + +.TP +.B \-compile +.RB +Invoke the compiler on the filename following +.BR \-compile +. +Other flags affect compilation. + +.TP +.B \-o\-file +.RB +If nil follows +.BR \-o\-file +then do not produce an +.I .o +file. + +.TP +.B \-c\-file +.RB +If +.BR \-c\-file +is specified, leave the intermediate +.I .c +file there. + +.TP +.B \-h\-file +.RB If +.BR \-h\-file +is specified, leave the intermediate +.I .h +file there. + +.TP +.B \-data\-file +.RB If +.BR \-data\-file +is specified, leave the intermediate +.I .data +file +there. + +.TP +.B \-system\-p +.RB If +.BR \-system\-p +is specified then invoke +.I compile\-file +with the +.I :system\-p t +keyword argument, meaning that the C init function +will bear a name based on the name of the file, so that it may be +invoked by name by C code. + +This GNU package should not be confused with the proprietary program +distributed by FRANZ, Inc. Nor should it be confused with any public +domain or proprietary lisp system. + +For anything other than program development, use of the lisp compiler +is strongly recommended in preference to use of the interpreter, due +to much higher speed. +.\".LP +.\"This program may be used in conjunction with the UCSF +.\".I batchqueue +.\"system. +.\".SH "LOCAL ACCESS" +.\"Locally, access to all LISP systems is made through a shared +.\"interactive front\-end which assumes that the job is be run in batch mode +.\"unless the \fB\-i\fP option is activated, which starts an interactive session. +.\"Interactive sessions are limited to 30 cpu minutes. +.SH FILES +.TP +\fI/usr/bin/gcl +executable shell script wrapper +.TP +\fI/usr/lib/gcl\-version/unixport/saved[_flavor]_gcl +executable lisp images +.SH "SEE ALSO" +.sp +\fICommon LISP: The Language\fP, Guy L. Steele, Jr., Digital Press, Bedford, MA, +1984. +.sp +\fICommon LISPcraft\fP, Robert Wilensky, W. W. Norton & Co., New York, 1984. +.SH AUTHORS + +The GCL system contains C and Lisp source files to build a Common Lisp +system. +CGL is derived from Kyoto Common LISP (\fIkcl\fP), +which was written in 1984 by T. Yuasa and M. Hagiya +(working under Professor R. Nakajima at the Research +Institute for Mathematical Sciences, Kyoto University). +The AKCL system work was begun in 1987 by +William Schelter at the University of Texas, Austin, and continued through 1994. +In 1994 AKCL was released as GCL (GNU Common Lisp) under the +GNU public library license. +.\" + diff --git a/merge.c b/merge.c new file mode 100755 index 0000000..cf77a0c --- /dev/null +++ b/merge.c @@ -0,0 +1,450 @@ +/* Copyright William F. Schelter, University of Texas 1987 */ + +/* This file may be copied by anyone, but changes may not +be made without permission of the author. The author hopes it will be +useful but cannot assume any responsibility for its use or problems +caused by its use. The program is provided as is. */ + +/* The program takes two files file1 = orig and file2 = orig.V + +tutorial% merge orig orig.V > foo + +and copies orig according to the recipe in orig.V. The advantage of +this program is that it does this according to the context of orig. +Thus even though orig might change slightly (eg some one added an +extra line to the copyright notice), the same change file will +probably still be valid. + +If the first argument is - then the orig is standard input. +If a third argument is supplied, it is the name of a file to use +instead of standard output. + + +tutorial% merge orig orig.V | merge - change2 final + +would take the result of merge of orig and orig.V and use it to merge +with change2 to produce the file final. + + +The format of a change (.V) file is very simple: There is only ONE +type of command in a change file. REPLACE X by Y. Here X represents +a chunk of text in the orig file, and Y the substitution which you +wish to make for this occurrence. The Y appears explicitly in the +change file, while the text X may be specified fully and explicitly, +OR by giving sufficient context from the beginning and end of X. Thus +in general it takes three things to specify a change. The beginning +of X (Xbegin), the end of X (Xend), and all of Y. These three pieces +of text are separated by four delimiters. The delimiters are not +single characters, but rather sequences of four characters. This is +done so as to avoid having to quote the delimiter (see QUOTING below). +The delimiters are "\n@s[" "\n@s," "\n@s|" and "\n@s]". +NOTE: The \n (Newline) Character IS PART OF THE DELIMITER in ALL CASES. + +@s[X +@s|Y +@s] + +Thus in the above case the X text is only "X" it does not have any +newlines in it! They belong to the delimiters. For "X\n" we would see + + +@s[X + +@s|Y +@s] + + +The general case where X is a very long chunk of text, or perhaps something +sensitive to copyright, so that you cannot include several pages, you +could make Xbegin be the first few lines, and Xend the last few lines. +All intervening lines (including the Xbegin and the Xend, would be ripped +out, and replaced by Y. + +@s[Xbegin +@s,Xend +@s|Y +@s] + + +One cycle of the merge may be thought of as: +The merge program looks in the change (.V) file for the next \ns[, +in order to determine the next values for Xbegin,Xend,and Y. +Having determined these, its position in the (.V) file will have +advanced to after the \n@s]. + +The merge program then starts at its current position in the original +file and searches for the next occurrence of Xbegin, marking its +beginning, then for the end of Xend. The inclusive interval so +marked, is deleted and Y is substituted. The current position in the +original file is now at the end of the Xend text. The next Xbegin +text must occur after that point. Only one pass is made through the +files. + +It is an error if the start of Xend does not follow +the end of Xbegin. Thus Xbegin and Xend may NOT overlap. A common +case will be that Xbegin is the entire interval and Xend = "" +In this case the merge program, if it finds \n@s| before \n@s, +will assume you want Xend="". + +EXAMPLES: + +@s[Hi bill +@s, +@s|new body +@s] + +would delete the string "Hi bill" replacing it with "new body" +Xbegin="Hi bill" +Xend="" +Interval = "Hi bill" +Equivalently since the E interval is empty, we could have just +omitted the \@s, + +@s[Hi bill +@s|new body +@s] + + +Example of change file with two changes: +**************** + +@s[(defmacro lcase (item &body body) +@s, (setq v (car rest)) +@s|(defmacro lcase (items &body body) + (setq v (cadr rest)) +@s] + +Comments are allowed in change files. In fact anything not between +matching "\ns[" and "\ns]" is a comment. + + +@s[How is he +@s, +He is fine. +@s|He is sick. +@s] + +******* +end of change file + +The first change would replace the interval of the original file +"(defmacro.... (setq v (car rest))" +by +"(defmacro lcase (items &body body) + (setq v (cadr rest))" + +If the program could not find the interval "(defmacro.... (setq v +(car rest))" in the orignal file it would warn you. + +The intervals in the change file, must occur in the same order as in +the original file. There is an emacs program merge.el which can +mechanically produce a changes file from an original and an edited +version. + +Note: For convenience we pretend that the change file starts with +a new line, even if it does not. Thus if @s[ are the first three +characters of the file and CHSTART1 = \n@s[, we count this as a +CHSTART1. Since it is in the first column, it "appears" to have +the new line there. + + +QUOTING: + +In order to have a change which involves one of the four letter +delimiters given above, we use the convention that "\n@@" in the first +column translates to "\n@". You need not perform this quoting of @ +unless the merger would be confused. For example \n@(defun .. would +be ok, since this can't be mistaken for one of our delimiters. +Nonetheless \n@@(defun or \n@@s[ would translate to have one @ sign, +in the merge output. The reason for not doubling all @ signs, is that +it is very easy to scan (visually) a change you are constructing, to +see that there are no @ signs in the first column, or at least none +which could be confused for the four letter change delimiters +"\n@s[","\n@s," ... A poor human constructing a change (.V) file +should not have to sort through the X or Y text adding quoting +characters. + +Note on length: Y may be any length, but Xbegin or Xend, may only be +CONTEXT_LIMIT long. + +*/ + + + + + + + + + + +/****************** THE CODE ********************/ + + +#include + + +#define CONTEXT_LIMIT 3000 /* size of the longest delimiter or replacement */ + +char *malloc(); +void copy_rest(); +char ssearch_for_string(); + +#define NULL_OUT (FILE *)0 + +#define CHSTART1 "\n@s[" +#define CHSTART2 "\n@s," +#define CHSTART3 "\n@s|" +#define CHSTART4 "\n@s]" +#define ACCEPT ",|" +#define NOACCEPT (char *) 0 +#define NUL '\0' +#define TRUE 1 +#define FALSE 0 +#define eofch(ch) ((unsigned char)ch == (unsigned char) EOF) + +char filenames[600]; + +#define myerror(string,arg) {(void)fprintf(stderr,string,arg); exit(-1);} + +main(argc,argv) +int argc; +char *argv[]; +{FILE *orig,*changes,*out; + char *context,*endcontext; + char *origname,*altername,*outname; + char found; + context=malloc(CONTEXT_LIMIT+2); + endcontext=malloc(CONTEXT_LIMIT+2); + + outname=(char *)0; + + if (argc==1) + {int tem; + origname=filenames; altername=filenames+200; outname=filenames+400; + /* get names from stdin */ + if (tem=scanf("%s %s %s",origname,altername,outname)); + else myerror("Three args weren't supplied: scanf returned %d\n",tem); + } + else{ if (!((argc==3) || (argc==4))) + { myerror("Usage: merge file-orig file-changes [out-file]\n %d args given",argc-1);} + else + { origname=argv[1]; + altername=argv[2]; + if (argc >= 4) outname=argv[3];}}; + + +/* now we have the names either from command or stdin, so open files */ + +if(origname[0]=='-' && origname[1]==NULL) + orig=stdin; + else{ + orig=fopen(origname,"r"); + if (!orig) {perror(origname); exit(-1);}; +} + + changes=fopen(altername,"r"); + if (!changes) {perror(origname); exit(-1);}; + if (outname) + {out=fopen(outname,"w"); + if (out); else {perror(outname); exit(-1);}} + else out=stdout; + +/* check if the file starts with chstart1 - newline. to avoid +people thinking that starting file with @s[ is ok. */ + {char *str = CHSTART1; + int ch; + while(*(++str)) /* skip the newline start */ + { (ch=getc(changes)); + if (ch == *str) ; + else + { ungetc(ch,changes); goto not_found;} + } + goto got_one; + not_found:;} + + {while(search_for_string(changes,CHSTART1,NULL_OUT,FALSE) > 0) + { got_one: + if (found= + ssearch_for_string(changes,CHSTART2,context,CONTEXT_LIMIT,TRUE, + ACCEPT)); + else + {myerror("\nNo end for start change context in change file:\n`%s'\n",context);}; + if (found==ACCEPT[1]) + *endcontext=NUL; + else + { + if /* there is probably a non null endcontext */ + (ssearch_for_string(changes,CHSTART3,endcontext, + CONTEXT_LIMIT,TRUE,NOACCEPT)); + else + {myerror("No %s at beginning of line to denote end of change context", + CHSTART3);}}; +/* skip in orig down to the end of the context,copying thru begin context */ + if (search_for_string(orig,context,out,FALSE)>0); + else{myerror("\nCould not find the change start in original:\n`%s'\n" + ,context);}; + if /* copy out the changed version */ + (search_for_string(changes,CHSTART4,out,TRUE)>0); + else + {myerror("No %s at beginning of line to denote end of change context", + CHSTART4);}; + +/*finish skipping over the region to be deleted in orig */ + {if( search_for_string(orig,endcontext,NULL_OUT,FALSE) > 0); + else + {myerror("\nCould not find the end of the change in original:\n`%s'\n", + endcontext);}} + } + copy_rest(orig,out); + return 0; + }} + + +string_match(sta,stb) +char *sta, *stb; +{while(*sta!=0) + {if (*(sta++) != *(stb++)) return 0;} + if (*stb==0) return 1; else return 0; + } + +void +copy_rest(file,out) +FILE *file,*out; +{register int ch; +while(1) + { + ch=getc(file); + if (eofch(ch) && feof(file)) break; + putc(ch,out);}} + +/* advance file to end of first occurrence of string, copying to out +until the beginning of string */ + +#define USE_UNQUOTE 1 + +search_for_string(file,string,out,unquoting) +FILE *file,*out; +char *string; +int unquoting; +{int result; + result=search_for_string1(file,string,out,USE_UNQUOTE && unquoting); + return result;} + + +char *nxt,*lim,*ungetlim,*bp; +char buffer[CONTEXT_LIMIT]; + +/* +void +myungetc(ch) +char ch; +{*bp++ = ch;} + +char +mygetc(file) +FILE *file; +{char x=((bp==buffer)? getc(file) : *--bp); + return x; +} +*/ + +#define mygetc(file) ((bp==buffer)? getc(file) : *--bp) +#define myungetc(ch) *bp++ = ch + +search_for_string1(file,string,out,unquoting) +FILE *file,*out; +char *string; +int unquoting; +{ /* char *nxt,*lim; */ + char *s; + int ch; + nxt=lim=(char *)0; + bp=buffer; + if (*string==NUL) return 1; unquoting; + while(1) + {begin: + ch=mygetc(file); + if ((eofch(ch)) &&(feof(file))) return 0; + if( ch==*string) + { /* loop for checking */ + s = string; + while(*(++s)!=0) + {(ch=mygetc(file)); + if (eofch(ch) && feof(file)) + {char *cp=string;while (cp++<=s) + {putc(*cp,file) ; return 0;}}; + if (*s!=ch) + { if (out) putc(*string,out); + {char *cp=s; + if (!(unquoting && ch==string[1] && (s-string ==2))) + myungetc(ch); + while (--cp > string) + myungetc(*cp); + goto begin;}} + } + return 1; + /* printf(""); */ + } + else if (out) putc(ch,out);}; + } + + + +#define PUTC(ch,out) {if(ind++ < outlim) ((*(out++))=(ch));\ + else return -1;} + +char +ssearch_for_string1(file,string,out,outlim,unquoting,accept) +int outlim,unquoting; +FILE *file; +char *out; +char *string,*accept; +{register int ch; + char *s; int ind=0; + if (*string==NUL) return 'a'; + while(1) + {ch = getc(file); + begin: + if (feof(file)) return (char) 0; + if (ch==(*string)) + {s=string; ind=0; + while(*(++s)!=0) + {if ((*s==(ch=getc(file))) + || (accept && *s==*accept && ch == *(accept+1))); + else + {if (out) + {char *cp; cp=string; + if (unquoting && ch==string[1] && (s-string ==2)) s--; + while (cp!=s) + {PUTC(*cp,out);cp++;} + } + break;}} + if(*s==0) + {PUTC(((char) 0),out); + /* found a match */ + return(ch);} + else goto begin;} + else if (out) PUTC(ch,out); + } +} + +char +ssearch_for_string(file,string,out1,outlim,unquoting,accept) +int outlim; +FILE *file; +char *out1; +char *string,*accept; +int unquoting; +{char result; + result=ssearch_for_string1(file,string,out1,outlim,unquoting,accept); + return result;} + +/* +* +* To do: +* 1)The buffering for mygetc could be more efficient (in local variable). +* 2)Eliminate the double function calls used during debugging. +* 3)Improve error message, for help in finding context if a change +* is not found. +*/ diff --git a/minvers b/minvers new file mode 100755 index 0000000..a3dbbd6 --- /dev/null +++ b/minvers @@ -0,0 +1 @@ +6.12 diff --git a/misc/check.c b/misc/check.c new file mode 100755 index 0000000..09a97ca --- /dev/null +++ b/misc/check.c @@ -0,0 +1,45 @@ +#include "include.h" + + +#define CHECK(a,b)\ +do{ i++; if (((void *) a) != (void *) b) printf("differed %d %d\n",i, (long ) a - (long) b);}while(0) + + + +main() +{object x; + int i=0; +/* 1 2 */ +CHECK(&x->s.s_sfdef,&x->c.c_car); +CHECK(&x->s.s_dbind,&x->c.c_cdr); + +/* 3 4 5 6 */ +CHECK(&x->s.s_fillp,&x->ust.ust_fillp); +CHECK(&x->v.v_fillp,&x->ust.ust_fillp); +CHECK(&x->st.st_fillp,&x->ust.ust_fillp); +CHECK(&x->bv.bv_fillp,&x->ust.ust_fillp); + +/* 7 8 9 10 11 12 */ +CHECK(&x->st.st_dim,&x->ust.ust_dim); +CHECK(&x->v.v_dim,&x->ust.ust_dim); +CHECK(&x->bv.bv_dim,&x->ust.ust_dim); +CHECK(&x->a.a_dim,&x->ust.ust_dim); +CHECK(&x->lfa.lfa_dim,&x->ust.ust_dim); +CHECK(&x->sfa.sfa_dim,&x->ust.ust_dim); +CHECK(&x->fixa.fixa_dim,&x->ust.ust_dim); + +CHECK(&x->st.st_self,&x->ust.ust_self); +CHECK(&x->v.v_self,&x->ust.ust_self); +CHECK(&x->bv.bv_self,&x->ust.ust_self); +CHECK(&x->a.a_self,&x->ust.ust_self); +CHECK(&x->lfa.lfa_self,&x->ust.ust_self); +CHECK(&x->sfa.sfa_self,&x->ust.ust_self); +CHECK(&x->fixa.fixa_self,&x->ust.ust_self); +CHECK(&x->s.s_self,&x->ust.ust_self); + +CHECK(&x->v.v_elttype,&x->a.a_elttype); + + +} + + diff --git a/misc/check_obj.c b/misc/check_obj.c new file mode 100755 index 0000000..eef77cc --- /dev/null +++ b/misc/check_obj.c @@ -0,0 +1,14 @@ + +#include "include.h" +#define CHECK(a,b) \ +do{ i++; if ((void *) a != (void *) b) printf("differed %d\n",i);}while(0) + +main() +{object x; + int i=0; +CHECK(&x->s.s_self,&x->ust.ust_self); +CHECK(&x->s.s_fillp,&x->ust.ust_fillp); +CHECK(&x->v.v_fillp,&x->ust.ust_fillp); +CHECK(&x->v.v_dim,&x->ust.ust_dim); +CHECK(&x->cfn.,&x->ust.ust_dim); +} diff --git a/misc/cstruct.lsp b/misc/cstruct.lsp new file mode 100755 index 0000000..222d7b1 --- /dev/null +++ b/misc/cstruct.lsp @@ -0,0 +1,157 @@ +;; Sample usage: Create lisp defstructs corresponding to C structures: +(use-package "SLOOP") +;; How to: Create a file foo.c which contains just structures +;; and possibly some externs. +;; cc -E /tmp/foo1.c > /tmp/fo2.c +;; ../xbin/strip-ifdef /tmp/fo2.c > /tmp/fo3.c +;; then (parse-file "/tmp/fo3.c") +;; will return a list of defstructs and appropriate slot offsets. + + +(defun white-space (ch) (member ch '(#\space #\linefeed #\return #\newline #\tab))) + +(defvar *eof* (code-char 255)) +(defun delimiter(ch) (or (white-space ch) + (member ch '(#\, #\; #\{ #\} #\*)))) +(defun next-char (st) + (let ((char (read-char st nil *eof*))) + + (case char + (#\{ char) + ( + #\/ (cond ((eql (peek-char nil st nil) #\*) + (read-char st) + (sloop when (eql (read-char st) #\*) + do (cond ((eql (read-char st) #\/ ) + (return-from next-char (next-char st)))))) + (t char))) + ((#\tab #\linefeed #\return #\newline ) + (cond ((member (peek-char nil st nil) '(#\space #\tab #\linefeed #\return #\newline )) + (return-from next-char (next-char st)))) + #\space) + (t char)))) + +(defun get-token (st &aux tem) + (sloop while (white-space (peek-char nil st nil)) + do (read-char st)) + (cond ((member (setq tem (peek-char nil st nil)) '(#\, #\; #\* #\{ #\} )) + (return-from get-token (coerce (list (next-char st)) 'string)))) + (sloop with x = (make-array 10 :element-type 'character :fill-pointer 0 + :adjustable t) + when (delimiter (setq tem (next-char st))) + do (cond ((> (length x) 0) + (or (white-space tem) (unread-char tem st)) + (return x))) + else + do + (cond ((eql tem *eof*) (return *eof*)) + (t (vector-push-extend tem x))))) +(defvar *parse-list* nil) +(defvar *structs* nil) +(defun parse-file (fi &optional *structs*) + (with-open-file (st fi) + (let ((*parse-list* + (sloop while (not (eql *eof* (setq tem (get-token st)))) + collect (intern tem)))) + (print *parse-list*) + (let ((structs + (sloop while (setq tem (parse-struct)) + do (push tem *structs*) + collect tem))) + (get-sizes fi structs) + (with-open-file (st "gaz3.lsp") + (prog1 + (list structs (read st)) + (delete-file "gaz3.lsp"))))))) + + + + + +(defparameter *type-alist* '((|short| . signed-short) + (|unsigned short| . unsigned-short) + (|char| . signed-char) + (|unsigned char| . unsigned-char) + (|int| . fixnum) + (|long| . fixnum) + (|object| . t))) + + +(defun parse-type( &aux top) + (setq top (pop *parse-list*)) + (cond ((member top '(|unsigned| |signed|)) + (push (intern (format nil "~a-~a" (pop *parse-list*))) *parse-list*) + (parse-type)) + ((eq '* (car *parse-list*)) (pop *parse-list*) 'fixnum) + ((eq top '|struct|) + (prog1 + (cond ((car (member (car *parse-list*) *STRUCTS* :key 'cadr))) + (t (error "unknown struct ~a " (car *parse-list*)))) + (pop *parse-list*) + )) + ((cdr (assoc top *type-alist*))) + (t (error "unknown type ~a " top)))) +(defun expect (x) (or (eql (car *parse-list*) x) + (error "expected ~a at beginning of ~s" x *parse-list*)) + (pop *parse-list*)) +(defun parse-field ( &aux tem) + (cond ((eql (car *parse-list*) '|}|) + (pop *parse-list*) + (expect '|;|) + nil) + (t + (let ((type (parse-type))) + + (sloop until (eql (setq tem (pop *parse-list*)) '|;|) + append (get-field tem type) + + do (or (eq (car *parse-list*) '|;|) (expect '|,|))))))) +(deftype pointer () `(integer ,most-negative-fixnum most-positive-fixnum)) +(defun get-field (name type) + (cond ((eq name '|*|)(get-field (pop *parse-list*) 'pointer)) + ((and (consp type) (eq (car type) 'defstruct)) + (sloop for w in (cddr type) + append (get-field + (intern (format nil "~a.~a" name (car w))) + (fourth w)))) + (t + `((,name ,(if (eq type t) nil 0) :type ,type))))) + +(defun parse-struct () + (cond ((null *parse-list*) (return-from parse-struct nil))) + (cond ((not (eq (car *parse-list*) '|struct|)) + (sloop until (eq (pop *parse-list*) '|;|)) + (return-from parse-struct (parse-struct)))) + (expect '|struct|) + (let* ((name (prog1 (pop *parse-list*)(expect '|{|)))) + `(defstruct ,name ,@ + (sloop while (setq tem (parse-field)) + append tem)))) + +(defun printf (st x &rest y) + (format st "~%printf(\"~a\"" x) + (sloop for w in y do (princ "," st) (princ y st)) + (princ ");" st)) + +(defun get-sizes (file structs) + (with-open-file (st "gaz0" :direction :output) + (sloop for i from 1 + for u in structs + do (format st "struct ~a SSS~a;~%" (second u) i)) + (format st "~%main() {~%") + (printf st "(") + (sloop for i from 1 + for u in structs + do + (printf st (format nil "(|~a| " (second u))) + (sloop for w in (cddr u) + do + (printf st " %d " + (format nil "(char *)&SSS~a.~a - (char *)&SSS~a" + i (car w) i))) + (printf st ")")) + (printf st ")") + (princ " ;}" st)) + (system + (format nil "cat ~a gaz0 > tmpx.c ; cc tmpx.c -o tmpx ; (tmpx > gaz3.lsp) ; rm -f gaz0" file))) + diff --git a/misc/foreign.lsp b/misc/foreign.lsp new file mode 100755 index 0000000..e26b3de --- /dev/null +++ b/misc/foreign.lsp @@ -0,0 +1,121 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; -*- Mode: Lisp; -*- +;;; File: foreign-interface.lisp +;;; Author: Paul Viola (viola@ai.mit.edu) +;;; Copyright (C) Paul Viola, 1993 +;;;*---------------------------------------------------------------------------- +;;;* FUNCTION: Code to support foreign function call interface in GCL. +;;;* +;;;* CLASSES: +;;;* +;;;* RELATED PACKAGES: +;;;* +;;;* HISTORY: +;;;* Last edited: May 7 17:55 1993 (viola) +;;;* Created: Thu May 6 11:36:49 1993 (viola) +;;;*---------------------------------------------------------------------------- + +(in-package "USER") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Code that makes some lucid foreign function definitions work in GCL. + +(defparameter *lucid-to-gcl-c-types* + '((:signed-32bit int) + (:unsigned-32bit int) ;I hope this is right. + (:double-float double) + (:single-float float) + (:simple-string string) + ((:pointer :signed-32bit) vector-int) + ((:pointer :single-float) vector-single-float) + ((:pointer :double-float) vector-double-float) + (:null void))) + +(defmacro def-foreign-function ((lisp-name . key-params) . c-params) + "I wrote this so that lucid calls to foreign functions could be used directly in +GCL. " + (progn (print lisp-name) + `(defentry-2 ,lisp-name + ,(loop for param in c-params + collect (cadr (assoc (cadr param) *lucid-to-gcl-c-types* + :test #'equal))) + ,(list (cadr (assoc (lucid-return-type key-params) *lucid-to-gcl-c-types* + :test #'equal)) + (lucid-c-name key-params))))) + +(defun lucid-return-type (key-params) + (cadar (member :return-type key-params :key #'car))) + +(defun lucid-c-name (key-params) + (intern + (string-upcase + (subseq (cadar (member :name key-params :key #'car)) 1)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Using lisp strings in C is a pain. First they need to be NULL terminated +;;; then they need to be converted into a C object. The code below returns a +;;; C-string from a lisp routine. This is pretty dangerous - I don't know what +;;; would happen if you tried to operate on it. + +;;; For an array of ints. +(defCfun "object get_c_ints(s) object s;" 0 + " return(s->fixa.fixa_self);" + ) + +(defentry get-c-ints (object) (object get_c_ints)) + +;;; For an array of single-floats. +(defCfun "object get_c_single_floats(s) object s;" 0 + " return(s->sfa.sfa_self);" + ) + +(defentry get-c-single-floats (object) (object get_c_single_floats)) + +;;; For an array of double-floats. +(defCfun "object get_c_double_floats(s) object s;" 0 + " return(s->lfa.lfa_self);" + ) + +(defentry get-c-double-floats (object) (object get_c_double_floats)) + +;;; For a string. +(defCfun "object get_c_string(s) object s;" 0 + " return(s->st.st_self);" + ) +(defentry get_c_string_2 (object) (object get_c_string)) + +;; make sure string is null terminated +(defun get-c-string (string) + (get_c_string_2 (concatenate 'string string " + + +(defparameter *gcl-to-c-types* + '((int int nil) + (char char nil) + (float float nil) + (double double nil) + (object object nil) + (string object get-c-string) + (vector-int object get-c-ints) + (vector-single-float object get-c-single-floats) + (vector-double-float object get-c-double-floats))) + +(defmacro defentry-2 (func-name param-types declaration) + "Macro enhances defentry so that composite types can be passed to C functions. +For a list of types look at *gcl-to-c-types*" + (let ((f-name (intern (concatenate 'string (symbol-name func-name) "-2"))) + (new-types (mapcar #'(lambda (a) (cadr (assoc a *gcl-to-c-types*))) param-types)) + (param-list (mapcar #'(lambda (a) (gensym)) param-types))) + `(progn + (defentry ,f-name ,new-types ,declaration) + (defmacro ,func-name ,param-list + (list ',f-name + ,@(loop for p in param-list + for type in param-types + for (ntype new-type converter-func) = (assoc type *gcl-to-c-types*) + collect (if (null converter-func) + p + `(list ',converter-func ,p)))))))) + diff --git a/misc/mprotect.ch b/misc/mprotect.ch new file mode 100755 index 0000000..0d7cea0 --- /dev/null +++ b/misc/mprotect.ch @@ -0,0 +1,197 @@ +In this file are all changes necessary to implement the 4.3BSD system +call mprotect, and the changes to make sigreturn pass back the address +where a fault occurred as the `code' arg. Note that sun passes the +address as a 4'th arg. This might be preferable, but would involve +changes to locore.s. + +This has been tested on an hp370 running 4.3 BSD from MT Xinu. + +A man page entry for the call as implemented below. + +Inserting file /usr/man/man2/mprotect.2 +---Begin File /usr/man/man2/mprotect.2--- +.\" @(#)mprotect.2 +.TH MPROTECT 2 "9 December 1989" +.SH NAME +mprotect \- specify protection of data section memory +.SH SYNOPSIS +.nf +.ft B +#include +.ft +.LP +.ft B +mprotect(addr, len, prot) +caddr_t addr; +int len, prot; +.ft +.fi +.IX mprotect "" \fLmprotect\fP +.IX "memory management" mprotect "" \fLmprotect\fP +.IX "change protections \(em \fLmprotect\fP" +.SH DESCRIPTION +.LP +.B mprotect(\|) +changes the access protections on the mappings specified +by +the range +[\fIaddr, addr + len\fP\^) +to be that specified by +.IR prot . +Legitimate values for +.I prot +are PROT_READ and (PROT_WRITE | PROT_READ). +.SH RETURN VALUE +.LP +.B mprotect(\|) +returns 0 on success, \-1 on failure. +.SH ERRORS +.B mprotect(\|) +will fail if: +.TP 15 +.SM EINVAL +.I addr +is not a multiple of the page size as returned +by +.BR getpagesize (2). +.TP +.SM ENOMEM +Addresses in the range +[\fIaddr, addr + len\fP) +are not in the data section of a process. +.LP +.SH SEE ALSO +.BR getpagesize (2), + +---End File /usr/man/man2/mprotect.2--- + + +You need to compile the following and add it to /lib/libc.a + +Inserting file /usr/src/lib/libc/hp300/sys/mprotect.c +---Begin File /usr/src/lib/libc/hp300/sys/mprotect.c--- +#ifdef SYSLIBC_SCCS +_sccsid:.asciz "@(#)mprotect.c" +#endif SYSLIBC_SCCS + +#include "SYS.h" + +SYSCALL(mprotect) + rts +---End File /usr/src/lib/libc/hp300/sys/mprotect.c--- + + + +*** hp300/machdep.c.orig Tue Aug 29 13:09:56 1989 +--- hp300/machdep.c Mon Dec 11 17:07:18 1989 +*************** +*** 560,566 **** + #endif + sigf.sf_signum = sig; + sigf.sf_code = 0; +! if (sig == SIGILL || sig == SIGFPE) { + sigf.sf_code = u.u_code; + u.u_code = 0; + } +--- 560,566 ---- + #endif + sigf.sf_signum = sig; + sigf.sf_code = 0; +! if (sig == SIGILL || sig == SIGFPE || sig == SIGBUS) { + sigf.sf_code = u.u_code; + u.u_code = 0; + } +*** sys/kern_mman.c.orig Tue Aug 29 13:16:29 1989 +--- sys/kern_mman.c Thu Dec 14 10:07:39 1989 +*************** +*** 249,257 **** + u.u_pofile[fd] &= ~UF_MAPPED; + } + + mprotect() +! { + + } + + madvise() +--- 249,296 ---- + u.u_pofile[fd] &= ~UF_MAPPED; + } + ++ + mprotect() +! { struct a { +! caddr_t addr; +! int len; +! int prot; +! } *uap = (struct a *)u.u_ap; +! int fv,off; +! int tprot; +! register struct pte *pte; +! struct cmap *c; +! int s; + ++ u.u_r.r_val1 = -1; ++ ++ if ((uap->len < 0 || ++ (int)uap->addr & CLOFSET)) { ++ u.u_error = EINVAL; ++ return; ++ } ++ ++ ++ if ((uap->prot & PROT_WRITE) == 0) ++ tprot= PG_RO; ++ else tprot=PG_RW; ++ /* check the pages are in data section */ ++ if (!(isadsv(u.u_procp, btoc(uap->addr)) ++ &&isadsv(u.u_procp ,btoc(uap->addr+uap->len) -1))) ++ { u.u_error = ENOMEM; ++ return;} ++ ++ ++ fv = btop(uap->addr); ++ pte = vtopte(u.u_procp, fv); ++ for (off = 0; off < uap->len; off += NBPG) { ++ ++ *(u_int *)pte &= ~PG_PROT; ++ *(u_int *)pte |= tprot; ++ pte++;} ++ ++ newptes(vtopte(u.u_procp, fv), fv, btoc(uap->len)); ++ u.u_r.r_val1 = 0; + } + + madvise() +*** hp300/trap.c.orig Tue Aug 29 13:09:59 1989 +--- hp300/trap.c Mon Dec 11 17:48:59 1989 +*************** +*** 112,117 **** +--- 112,118 ---- + + case T_BUSERR+USER: /* bus error */ + case T_ADDRERR+USER: /* address error */ ++ u.u_code=v; + i = SIGBUS; + break; + +*************** +*** 293,298 **** +--- 294,300 ---- + printf("PTF|WPF...\n"); + if (type == T_MMUFLT) + goto copyfault; ++ u.u_code=v; + i = SIGBUS; + break; + } +*************** +*** 346,351 **** +--- 348,354 ---- + #endif + if (type == T_MMUFLT) + goto copyfault; ++ u.u_code=v; + i = SIGBUS; + break; + } diff --git a/misc/rusage.lsp b/misc/rusage.lsp new file mode 100755 index 0000000..e75ee1c --- /dev/null +++ b/misc/rusage.lsp @@ -0,0 +1,44 @@ +;; sun release 4 getrusage interface. (constructed using structs.lsp) +(in-package 'si) +(DEFSTRUCT (|rusage| (:static t)) + (|ru_utime.tv_sec| 0 :TYPE FIXNUM) + (|ru_utime.tv_usec| 0 :TYPE FIXNUM) + (|ru_stime.tv_sec| 0 :TYPE FIXNUM) + (|ru_stime.tv_usec| 0 :TYPE FIXNUM) + (|ru_maxrss| 0 :TYPE FIXNUM) + (|ru_ixrss| 0 :TYPE FIXNUM) + (|ru_idrss| 0 :TYPE FIXNUM) + (|ru_isrss| 0 :TYPE FIXNUM) + (|ru_minflt| 0 :TYPE FIXNUM) + (|ru_majflt| 0 :TYPE FIXNUM) + (|ru_nswap| 0 :TYPE FIXNUM) + (|ru_inblock| 0 :TYPE FIXNUM) + (|ru_oublock| 0 :TYPE FIXNUM) + (|ru_msgsnd| 0 :TYPE FIXNUM) + (|ru_msgrcv| 0 :TYPE FIXNUM) + (|ru_nsignals| 0 :TYPE FIXNUM) + (|ru_nvcsw| 0 :TYPE FIXNUM) + (|ru_nivcsw| 0 :TYPE FIXNUM)) +(clines "static mygetrusage(x,y) int x; object y;{return getrusage(x,y->str.str_self);}") +(defentry GETRUSAGE1 (int object) (int "mygetrusage")) + +(defun get-usage (self usage) + (or (typep usage '|rusage|) (setq usage (make-|rusage|))) + (getrusage1 (if self 0 -1) usage) + usage) + +(defmacro with-change-displayed (form) + `(let ((.beg (get-usage t nil))) + (prog1 ,form + (let ((.end (get-usage t nil))) + (let ((sd (s-data-slot-descriptions (get '|rusage| 's-data)))) + (sloop for i from 0 + for v in(s-data-slot-descriptions (get '|rusage| 's-data)) + for dif = + (- (structure-ref1 .end i ) (structure-ref1 .beg i ) ) + when (not (zerop dif)) + do(print (list (car v) dif)))))))) + + + + diff --git a/misc/test-seek.c b/misc/test-seek.c new file mode 100755 index 0000000..e119d9c --- /dev/null +++ b/misc/test-seek.c @@ -0,0 +1,37 @@ +#include +#include "include.h" +#ifdef HAVE_AOUT +#include HAVE_AOUT +#endif +#ifdef HAVE_ELF +#include +#endif + +#define OUR_MAX(a,b) (a > b ? a : b) + +#define SEEK_TO_END_OFILE(fp)\ + do{ int m; \ + Elf32_Ehdr eheader; \ + Elf32_Shdr shdr; \ + fseek(fp,0,SEEK_SET); \ + fread(&eheader,sizeof(eheader),1,fp); \ + fseek(fp,eheader.e_shoff+(eheader.e_shnum -1) \ + *eheader.e_shentsize,0); \ + fread(&shdr,eheader.e_shentsize,1,fp); \ + fseek(fp,OUR_MAX(shdr.sh_offset+ shdr.sh_size, \ + eheader.e_shoff+(eheader.e_shnum) \ + *eheader.e_shentsize) \ + , SEEK_SET);\ + }while(0) + + + +main(argc,argv) + char *argv[]; +{ FILE *fp; + fp = fopen (argv[1],"r"); + + SEEK_TO_END_OFILE(fp); + printf("end = %d\n",ftell(fp)); +} + diff --git a/misc/test-sgc.lsp b/misc/test-sgc.lsp new file mode 100755 index 0000000..014ffda --- /dev/null +++ b/misc/test-sgc.lsp @@ -0,0 +1,58 @@ +(in-package 'si) +(or (fboundp 'get-usage) (load "/public/gcl/misc/rusage")) +(gbc-time 0) +(defun cv (x) (/ x (float INTERNAL-TIME-UNITS-PER-SECOND))) +(defvar *all-times* nil) +(defmacro with-timing (&rest forms) + `(let ((usg0 (get-usage t nil)) + (t1 (gbc-time)) + (t2 (get-internal-run-time)) + (t3 (get-internal-real-time))) + (prog1 ,@forms + (setq t1 (- (gbc-time ) t1)) + (setq t2 (- (get-internal-run-time) t2)) + (setq t3 (- (get-internal-real-time) t3)) + (let ((usg (get-usage t nil))) + (let ((ans + (format nil + "Run= ~3,2f Elap= ~3,2f Gc= ~3,2f Fault= ~3d" + (cv t2) (cv t3) (cv t1) + (- (|rusage|-|ru_majflt| usg) (|rusage|-|ru_majflt| usg0))))) + (push (list ',(car forms) ans ) *all-times*) + (print ans)))))) + + +(setq si::*notify-gbc* t) +(allocate 'cons 520 t) +(allocate 'fixnum 40) + +(si::sgc-on nil) +(si::allocate-sgc 'symbol 20 30 30) +(si::allocate-sgc 'cons 50 3000 40) + +(si::allocate-sgc 'vector 1 10 30) +(si::allocate-sgc 'string 1 10 30) +(gbc nil) +(si::sgc-on t) +(print (in-package "MAXIMA")) +(setq $joe #$expand((x+y+z)^20)$) + + +(defun test (form) + (gbc nil) + (eval form) + (push (list form 'cons-pages (si::allocated-pages 'cons)) si::*all-times*) + + (gbc nil) + (si::with-timing (sloop for i below 3 do (displa ($factor $joe)))) + ) + +(test '(si::sgc-on nil)) +(test '(si::sgc-on t)) +(test '(si::sgc-on nil)) +(test '(si::sgc-on t)) + +(print si::*all-times*) + + + diff --git a/misc/warn-slow.lsp b/misc/warn-slow.lsp new file mode 100755 index 0000000..7a99388 --- /dev/null +++ b/misc/warn-slow.lsp @@ -0,0 +1,50 @@ +;; Warn of some slow calls. +(in-package 'compiler) + +;; slow if the result type is type T +(dolist (v '(+ * / mod - float 1- 1+)) + (setf (get v 'slow-test) + #'(lambda (name x) (or (null x) (eql (cadar x) t))))) + +;; slow if the first arg is type T +(dolist (v '(aref si::aset < <= > >=)) + (setf (get v 'slow-test) + #'(lambda (name x) (or (null x) (eql (caar x) t))))) + +(dolist (v '(typep)) + (setf (get v 'slow-test) + #'(lambda (name x) (null x)))) + + +;; turn the compiler expressions back into something vaguely +;; readable. +(defun lispify (x) + (let ((tem (car x))) + (cond ((equal tem 'var) + (var-name (car (third x)))) + ((eq tem 'call-global) + (cons (third x) + (mapcar 'lispify (fourth x)))) + ((eq tem 'fixnum-value) + (third x)) + ((eq tem 'location) + (lispify (third x))) + (t x)))) + +(eval-when (load eval) + (trace (get-inline-info :entry nil + :entrycond nil + :exitcond + (and (not (equal (car values) nil)) + (let ((s (get (car si::arglist) 'slow-test))) + (and s (funcall s (car si::arglist) (car values)))) + (progn + (cmpwarn "Slow code: ~a: " + (cons (car si::arglist) + (mapcar 'lispify (second si::arglist)))) + (format t " ~a --> ~a~%" + (mapcar #'(lambda (form) (info-type (cadr form))) + (second si::arglist)) + (third si::arglist))) + nil))) +) \ No newline at end of file diff --git a/mp/fplus.c b/mp/fplus.c new file mode 100755 index 0000000..9c76576 --- /dev/null +++ b/mp/fplus.c @@ -0,0 +1,104 @@ + +/* Copyright (C) 1994 W. Schelter + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU library general public +license along with GCL; see the file COPYING. If not, write to the +Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +*/ + +/* #include "include.h" */ +#include "config.h" +/* #include "cmpinclude.h" */ +/* #include "genpari.h" */ +#include "arith.h" +object make_integer(); + + +static unsigned plong small_pos_int[3]={0x1000003,0x01000003,0}; +static unsigned plong small_neg_int[3]={0x1000003,0xff000003,0}; +static unsigned plong s4_neg_int[4]={0x1000004,0xff000004,1,0}; + +object +fplus(a,b) + int a,b; +{ int z ; + int x; + if (a >= 0) + { if (b >= 0) + { x = a + b; + if (x == 0) return small_fixnum(0); + small_pos_int[2]=x; + return make_integer(small_pos_int); + } + else + { /* b neg */ + x = a + b; + return make_fixnum(x); + }} + else + { /* a neg */ + if (b >= 0) + { x = a + b; + return make_fixnum(x);} + else + { /* both neg */ + { unsigned plong Xtx,Xty,overflow,Xtres; + Xtres = addll(-a,-b); + if (overflow) + { + s4_neg_int[3]=Xtres; + return make_integer(s4_neg_int);} + else + { small_neg_int[2]=Xtres; + return make_integer(small_neg_int);} + }}} +} + + +object +fminus(a,b) + int a,b; +{ int z ; + int x; + if (a >= 0) + { if (b >= 0) + { x = a - b; + return make_fixnum(x); + } + else + { /* b neg */ + x = a - b; + if (x==0) return small_fixnum(0); + small_pos_int[2]=x; + return make_integer(small_pos_int); + }} + else + { /* a neg */ + if (b <= 0) + { x = a - b; + return make_fixnum(x);} + else + { /* b positive */ + { unsigned plong Xtx,Xty,overflow,Xtres; + unsigned plong t[4]; + Xtres = addll(-a,b); + if (overflow) + { s4_neg_int[3]=Xtres; + return make_integer(s4_neg_int);} + else + { small_neg_int[2]=Xtres; + return make_integer(small_neg_int);} + }}} +} diff --git a/mp/gcclab b/mp/gcclab new file mode 100755 index 0000000..83d4a7a --- /dev/null +++ b/mp/gcclab @@ -0,0 +1,29 @@ +#!/bin/sh +TEMP=/tmp/gcc$$tmp +BIL="$@" + +while [ $# -gt 0 ] +do + case "$1" in + -S) + Sflag=1;; + -o) + OUT=$2; shift ;; + + *.c) + FILE=$1;; + esac + shift +done + +FILE=`echo "${FILE}" | sed -e 's:\.c$::g'` +gcc -o ${TEMP}.s ${BIL} -S +cat ${TEMP}.s | awk -f gcclab.awk > ${TEMP}1.s + +if [ "${Sflag}" = "1" ] ; then + mv ${TEMP}1.s ${FILE}.s +else +as -o ${FILE}.o ${TEMP}1.s +fi +rm -f ${TEMP}.s ${TEMP}1.s + diff --git a/mp/gcclab.awk b/mp/gcclab.awk new file mode 100755 index 0000000..742a073 --- /dev/null +++ b/mp/gcclab.awk @@ -0,0 +1,13 @@ + + /NEW_LABEL/ { lab++; next;} + /Lmylabel/ { at = index($0,"Lmylabel"); + printf("%s%d%s\n", substr($0,1,at),lab,substr($0,at+1)); + next;} + + {print} + + + + + + \ No newline at end of file diff --git a/mp/gnulib1.c b/mp/gnulib1.c new file mode 100755 index 0000000..e9816bb --- /dev/null +++ b/mp/gnulib1.c @@ -0,0 +1,51 @@ + +/* Copyright (C) 1994 W. Schelter + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU library general public +license along with GCL; see the file COPYING. If not, write to the +Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +*/ + + +double +__adddf3 (a, b) + double a, b; +{ + return a + b; +} + +double +__floatsidf (a) + int a; +{ + return (double) a; +} +#ifndef __GO32__ +int +__fixdfsi (a) + double a; +{ + return (int) a; +} +#endif + +double +__muldf3 (a, b) + double a, b; +{ + return a * b; +} + + diff --git a/mp/lo-ibmrt.s b/mp/lo-ibmrt.s new file mode 100755 index 0000000..9a56874 --- /dev/null +++ b/mp/lo-ibmrt.s @@ -0,0 +1,67 @@ + # Copyright W. Schelter 1991 + # untested + .file "foo.c" + .data + .text + .globl .mulul3 + .align 1 +.nmulul3: + .text + .set L.1F,0x00000000 + .set L.1L,0x00000000 + .set L.1R,10 + .set L.1A,0x00000004-(4*L.1R-100)-16 + stm L.1R,4*L.1R-100(1) + cal 1,-(16+L.1A)(1) + lr 14,0 + lr 12,2 + lr 11,3 + lr 10,4 +# line 5, file "foo.c" + mts 10,12 + s 13,13 + m 13,11 + m 13,11 + m 13,11 + m 13,11 + m 13,11 + m 13,11 + m 13,11 + m 13,11 + m 13,11 + m 13,11 + m 13,11 + m 13,11 + m 13,11 + m 13,11 + m 13,11 + m 13,11 + # 86 + # 46 +# line 6, file "foo.c" + ci 12,0# 47 + bge L.13 +# line 7, file "foo.c" + a 13,11# 63 +L.13: +# line 8, file "foo.c" + ci 11,0# 47 + bge L.14 +# line 9, file "foo.c" + a 13,12# 63 +L.14: +# line 10, file "foo.c" + st 13,0(10)# 17 + mfs 10,2 +# line 11, file "foo.c" +#clrcb 15,8 # DMAsync + lm L.1R,(16+L.1A)+(4*L.1R-100)(1) + brx 15 + cal 1,16+L.1A(1) + .short 0xdf01,L.1R*16+0xdf00,L.1A+16 + .data 3 + .globl _mulul3 +_mulul3: + .long .mulul3 + .text + .data diff --git a/mp/lo-rios.s b/mp/lo-rios.s new file mode 100755 index 0000000..fd4a2b9 --- /dev/null +++ b/mp/lo-rios.s @@ -0,0 +1,106 @@ +.file "lo-rios.s" + # Copyright W. Schelter 1991 +######MULUL3####### +#unfortunately the mul operation on rios is signed, +# so we have to go to a bit of work to get the unsigned op. +.toc +.globl mulul3[ds] +.csect mulul3[ds] + .long .mulul3[PR] + .long TOC[tc0] + .long 0 + .toc +# MULUL3(x,y,hi) +T.mulul3: .tc .mulul3[tc],mulul3[ds] + .globl .mulul3[PR] + .csect .mulul3[PR] + mul. 0,3,4 # hp = r0 + cmpi 0,4,0 # + bge Ypos # branch if reg4 >=0 + a 0,3,0 +Ypos: + cmpi 0,3,0 + bge Xpos + a 0,4,0 +Xpos: + mfmq 3 + st 0,0x0(5) + br +######### DIVSL3 ############ +# a divide just like divul3, except that +# it assumes that x,y are signed numbers. +.toc +.globl divsl3[ds] +.csect divsl3[ds] + .long .divsl3[PR] + .long TOC[tc0] + .long 0 + .toc +# DIVSL3(lo,divisor,rem) +# long h,divisor,*rem +T.divsl3: .tc .divsl3[tc],divsl3[ds] + .globl .divsl3[PR] + .csect .divsl3[PR] + mtmq 3 # move lo to q reg + l 3,0x0(5) # put hi in reg3 + div 3,3,4 # r3 = (r3:qreg)/r4 + mfmq 4 # move remainder to reg6 + st 4,0x0(5) # store 6 in *rem + br +#########Xdivul3################# +# Below is a broken attempt to do a divul3 which +# does the test and branches to the slow one if necessary. +.globl .slowdivul3[PR] + .toc +.globl Xdivul3[ds] +.csect Xdivul3[ds] + .long .Xdivul3[PR] + .long TOC[tc0] + .long 0 + .toc +# old(D,H,L,QP,RP) +# XDIVUL3(lo,divisor,rem) +# long h,divisor,*rem +# +T.Xdivul3: .tc .Xdivul3[tc],Xdivul3[ds] + .globl .Xdivul3[PR] + .csect .Xdivul3[PR] + cmpi 0,4,0 # + l 6,0x0(5) + blt Lslow + a 0,6,6 + cmp 1,4,0 + bgt Ldivsl # branch if reg4 >=0 +Lslow: + b .slowdivul3[PR] +Ldivsl: mtmq 3 # move lo to q reg + div 3,6,4 # r3 = (r6:qreg)/r4 + mfmq 4 # move remainder to reg4 + st 4,0x0(5) # store 6 in *rem + br +##### Flush the instruction cache. Necessary for loading. +.toc +#T.myics.s:.tc myics.s[tc],myics.s[rw] + .globl myics[ds] +.csect myics[ds] + .long .myics[PR] + .long TOC[tc0] + .long 0 + .toc +T.myics: .tc .myics[tc],myics[ds] + .globl .myics[PR] + .csect .myics[PR] + dcs + ics + brl + +#### Allocate lots of space for toc entries during dynamic loading. +.globl akcltoc[ds] + .csect akcltoc[ds] + .long .akcltoc[tc] + .csect .akcltoc[tc] + .space 24000 +.globl toc_start[ds] + .csect toc_start[ds] + .long TOC[tc0] + diff --git a/mp/lo-rios1.s b/mp/lo-rios1.s new file mode 100644 index 0000000..f6472ea --- /dev/null +++ b/mp/lo-rios1.s @@ -0,0 +1,26 @@ +##### Flush the instruction cache. Necessary for loading. +.toc +#T.myics.s:.tc myics.s[tc],myics.s[rw] + .globl myics[ds] +.csect myics[ds] + .long .myics[PR] + .long TOC[tc0] + .long 0 + .toc +T.myics: .tc .myics[tc],myics[ds] + .globl .myics[PR] + .csect .myics[PR] + dcs + ics + brl + +#### Allocate lots of space for toc entries during dynamic loading. +.globl akcltoc[ds] + .csect akcltoc[ds] + .long .akcltoc[tc] + .csect .akcltoc[tc] + .space 24000 +.globl toc_start[ds] + .csect toc_start[ds] + .long TOC[tc0] + diff --git a/mp/lo-sgi4d.s b/mp/lo-sgi4d.s new file mode 100755 index 0000000..1a196d2 --- /dev/null +++ b/mp/lo-sgi4d.s @@ -0,0 +1,58 @@ + # Copyright W. Schelter 1991 +#ifdef sgi +#include +#else +#include +#endif + + .text + .align 2 + + .globl mulul3 + # MULUL3(x,y,hi) + .ent mulul3 +mulul3: + .frame sp, 0, ra + + multu a0, a1 # [hi:lo] = d * q + mfhi a1 + mflo v0 + sw a1,0(a2) + j ra + .end mulul3 + + .globl Xdivul3 + # EXTENDED_DIV(D,H,L,QP,RP) + # divul3(x, y, hi) + # unsigned int x,h,*hi; +#define lo a0 +#define q t7 +#define y a1 +#define h v1 + + .ent Xdivul3 +Xdivul3: + .frame sp, 0, ra + + lw h, 0(a2) + li v0, 32 # v0 holds number of shifts +loop: + + srl q, lo, 31 + sll h, 1 + or h, q + sll lo, 1 + subu q, h, y # t = h - d + bltz q, underflow + move h, q + or lo, 1 +underflow: + subu v0, 1 + bnez v0, loop + move q,a0 + sw h, 0(a2) # *rp = h + # } + j ra + .end Xdivul3 + + diff --git a/mp/lo-u370_aix.s b/mp/lo-u370_aix.s new file mode 100755 index 0000000..ae53e15 --- /dev/null +++ b/mp/lo-u370_aix.s @@ -0,0 +1,77 @@ +* --- Copyright W. Schelter 1991 --# + file_ lo-aix370.c + entry $oVhc2_1r +$oVhc2_1r equ 0 + entry $oVO +$oVO equ 0 +L$$C0 csect + ds 0d +L00$TEXT equ * + entry _divsl3 +* -------------| divsl3 |-----------------------# + ds 0f + dc al2(0) arglength in words + dc xl2'FFFF' argument regs unknown + dc al4(LE$1-_divsl3) code size + dc xl2'0000' no flags currently defined + dc al1(3) parmlength in words + dc al1(1) format +_divsl3 ds 0h +LX$011 equ * + using LX$011,12 + stm LR$1,15,x'10'+LV$1(13) + lr 12,13 + la 11,x'60' + slr 13,11 + st 12,4(,13) + lr 12,15 + lr 15,0 + l 14,0(,2) + dr 14,1 + lr 0,15 + st 14,0(,2) + lm LR$1,14,x'70'+LV$1(13) + br 14 +LE$1 equ * +LR$1 equ 2 +LV$1 equ 0 + entry _mulul3 +* -------------| mulul3 |-----------------------# + ds 0f + dc al2(0) arglength in words + dc xl2'FFFF' argument regs unknown + dc al4(LE$2-_mulul3) code size + dc xl2'0000' no flags currently defined + dc al1(3) parmlength in words + dc al1(1) format +_mulul3 ds 0h +LX$021 equ * + using LX$021,12 + stm LR$2,15,x'10'+LV$2(13) + lr 12,13 + la 11,x'60' + slr 13,11 + st 12,4(,13) + lr 12,15 + lr 11,0 + lr 15,1 + mr 14,11 + lr 0,14 + ltr 11,11 + bnm LF$024 + ar 0,1 +L0$023 equ * +LF$024 equ * + ltr 1,1 + bnm LF$025 + ar 0,11 +L0$025 equ * +LF$025 equ * + st 0,0(,2) + lr 0,15 + lm LR$2,14,x'70'+LV$2(13) + br 14 +LE$2 equ * +LR$2 equ 2 +LV$2 equ 0 + end diff --git a/mp/make.defs b/mp/make.defs new file mode 100755 index 0000000..4607cbb --- /dev/null +++ b/mp/make.defs @@ -0,0 +1,37 @@ +h/dec3100.defs: +MPFILES= ${MPDIR}/mpi.o ${MPDIR}/lo-sgi4d.o ${MPDIR}/libmport.a +h/hp300-bsd.defs: +MPFILES= $(MPDIR)/mpi-bsd68k.o $(MPDIR)/libmport.a +h/hp300.defs: +# MPFILES=${MPDIR}/mpi-gcc.o ${MPDIR}/libmport.a +MPFILES=${MPDIR}/mpi.o ${MPDIR}/libmport.a +h/hp800.defs: +# MPFILES=${MPDIR}/mpi-gcc.o ${MPDIR}/libmport.a +MPFILES=${MPDIR}/mpi.o ${MPDIR}/libmport.a +h/mp386.defs: +MPFILES= $(MPDIR)/mpi-386.o $(MPDIR)/libmport.a +h/ncr.defs: +#:MPFILES= $(MPDIR)/mpi-386.o $(MPDIR)/libmport.a +h/ps2_aix.defs: +MPFILES= $(MPDIR)/mpi-386.o $(MPDIR)/libmport.a +h/rios.defs: +MPFILES=${MPDIR}/mpi.o ${MPDIR}/lo-rios.o ${MPDIR}/mp_divul3_word.o ${MPDIR}/libmport.a +h/rt_aix.defs: +h/rt_aos.defs: +h/sgi.defs: +h/sgi4d.defs: +MPFILES= ${MPDIR}/mpi.o ${MPDIR}/lo-sgi4d.o ${MPDIR}/libmport.a +h/sig.defs: +h/sun2r3.defs: +h/sun3-os4.defs: +MPFILES= $(MPDIR)/mpi-bsd68k.o $(MPDIR)/libmport.a +h/sun3.defs: +MPFILES= $(MPDIR)/mpi-bsd68k.o $(MPDIR)/libmport.a +h/sun386i.defs: +h/sun4.defs: +MPFILES=$(MPDIR)/mpi-sparc.o $(MPDIR)/sparcdivul3.o $(MPDIR)/libmport.a +h/symmetry.defs: +h/u370_aix.defs: +MPFILES=${MPDIR}/mpi.o ${MPDIR}/lo-u370_aix.o ${MPDIR}/mp_sl3todivul3.o ${MPDIR}/libmport.a +# MPFILES=${MPDIR}/mpi.o ${MPDIR}/libmport.a +h/vax.defs: diff --git a/mp/makefile b/mp/makefile new file mode 100644 index 0000000..af6a67e --- /dev/null +++ b/mp/makefile @@ -0,0 +1,76 @@ +AR = ar qc +MPDIR=. +RANLIB=ranlib +# if you are using gcc for the main link you probably dont need this: +GNULIB1= ${MPDIR}/gnulib1.o +NATIVE_CC=cc + +# default mp files (overridden by machine.defs) +MPFILES= $(MPDIR)/mpi.o $(MPDIR)/mp2.o $(MPDIR)/libmport.a + +-include ../makedefs + +OBJS= mp_divul3.o mp_bfffo.o mp_mulul3.o mp2.o mp_dblrsl3.o mp_dblrul3.o ${GNULIB1} + +all: + $(MAKE) all1 "MPFILES=$(MPFILES)" + +all1: ${MPFILES} + +$(MPDIR)/libmport.a: $(OBJS) + rm -f libmport.a + $(AR) libmport.a ${OBJS} + ${RANLIB} libmport.a + +.s.o: + $(AS) $*.s -o $*.o + +.c.o: + $(CC) -c $(OFLAG) -I../h -I. $(CFLAGS) $(ODIR_DEBUG) $*.c + +mpi-386_no_under.o: mpi-386_no_under.s + gcc -traditional -c $*.s -o $*.o + +mpi-386d.o: mpi-386d.S + gcc -traditional -c $*.S -o $*.o + +mpi-bsd68k.s: mpi.c + gcc -S -I../h -O mpi.c -o mpi-bsd68k.s + +mpi-sparc.s: mpi.c + gcc -S -I../h -O mpi.c -o mpi-sparc.s + +mpi-sol-sparc.s: mpi.c + gcc -S -I../h -O mpi.c -o mpi-sol-sparc.s + +${MPDIR}/mpi-386.o: ${MPDIR}/mpi-386.s + $(AS) $*.s -o $*.o + +${MPDIR}/mpi-386.s: mpi.c + gcc -S -I../h -O mpi.c -o mpi-386.s + +${MPDIR}/mpi-gcc.o: mpi.c + gcc -c -O -I../h mpi.c -o mpi-gcc.o + +${MPDIR}/gnulib1.o: + ${NATIVE_CC} -c -O gnulib1.c + +$(MPDIR)/mpi-386-winnt.o: $(MPDIR)/mpi-386-winnt.s + $(AS) $*.s -o $*.o + +clean: + rm -f *.o *.a + +make.defs: + (cd .. ; for v in h/*.defs; do echo $$v: ; fgrep MPFILES $$v ; done ; true) > make.defs + + +tar: + (cd .. ; ls mp/*.c mp/*.s h/*.h h/*.defs mp/makefile mp/make.defs) | sed -e '/foo/d' > tmpx + (cd .. ; tar cvf - `cat mp/tmpx`) | compress -c > ${HOME}/tmp/mp.tar.Z + rm -f tmpx + + + + + diff --git a/mp/mp2.c b/mp/mp2.c new file mode 100755 index 0000000..0af336c --- /dev/null +++ b/mp/mp2.c @@ -0,0 +1,619 @@ + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +/*~ ~*/ +/*~ OPERATIONS DE BASE (NOYAU) ~*/ +/*~ Functions which can be efficient in plain C ~*/ +/*~ ~*/ +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ + + +#include "config.h" +#include "genpari.h" +#include "arith.h" + +/* -2147483648 */ + +unsigned plong MOST_NEGS[3]={0x01ff0003, 0xff000003,1<<31}; + +/* +2147483648 */ + +unsigned plong ABS_MOST_NEGS[3]={0x01ff0003, 0x01000003,1<<31}; + + +GEN stoi(x) + plong x; +{ + GEN y; + + if(!x) return gzero; + y=cgeti(3); + if(x>0) {y[1]=0x1000003;y[2]=x;} + else{y[1]=0xff000003;y[2]= -x;} + return y; +} + + +GEN cgetg(x,y) + plong x,y; +{ + unsigned plong p1; + GEN z; + + p1=avma-(((unsigned short)x)<<2);if(p13) err(affer2); + p1=x[2];if(p1>=0x80000000) err(affer2); + p2=(s>0)?p1:(-((plong)p1));return p2; +} + + +void affsi(s,x) + plong s; + GEN x; +{ + plong lx; + + if(!s) {x[1]=2;return;} + lx=lg(x);if(lx<3) err(affer1); + if(s>0) {x[1]=0x1000003;x[2]=s;} + else { s = -s; + if (s < 0) /* s = -2^31 */ + { if(lx<4) err(affer1); + x[1]=0xff000004; + x[2]= 0; + x[3]= 1; + } + else + {x[1]=0xff000003;x[2]= s;} + } +} + + +void affii(x,y) + GEN x,y; +{ + plong lx=lgef(x),i; + + if(x==y) return; + if(lg(y)0) {t[1]=0x1000003;t[2]=x;} + else {t[1]=0xff000003;t[2]= -x;} + return shifti(t,y); +} + + +GEN shifti(x,n) + GEN x; + plong n; +{ + plong lx=lgef(x),i,s=signe(x),d,m,p1,p2,k; + GEN y; TEMPVARS2 + ulong hiremainder; + + if(!s) return gzero; + if(!n) return icopy(x); + if(n>0) + { + d=n>>5;m=n&31; + if(m) + { + p1=shiftl(x[2],m);p2=hiremainder;k=0; + if(p2) + { + y=cgeti(lx+d+1);for(i=lx+1;i<=lx+d;i++) y[i]=0; + for(i=lx;i>=4;i--) {y[i]=shiftl(x[i-1],m)+k;k=hiremainder;} + y[3]=p1+k;y[2]=p2; + } + else + { + y=cgeti(lx+d);for(i=lx;i=3;i--) {y[i]=shiftl(x[i],m)+k;k=hiremainder;} + y[2]=p1+k; + } + } + else + { + y=cgeti(lx+d);for(i=lx;i=2;i--) y[i]=x[i]; + } + } + else + { + n= -n;d=n>>5;m=n&31;if(lx>5;m=e&31;if(d>=lx-2) err(truer2); + y=cgeti(d+3);y[1]=y[0];setsigne(y,s); + if(m==31) for(i=2;i<=d+2;i++) y[i]=x[i]; + else + { + m++;p1=0; + for(i=2;i<=d+2;i++) + { + p2=shiftl(x[i],m);y[i]=hiremainder+p1;p1=p2; + } + } + return y; +} + + +GEN mpent(x) + GEN x; +{ + plong e,i,lx=lg(x),m,f,p1,p2; + unsigned plong d;ulong hiremainder; + GEN y,z; TEMPVARS2 + + if(typ(x)==1) return icopy(x); + if(signe(x)>=0) return mptrunc(x); + e=expo(x);if(e<0) {y=cgeti(3);y[2]=1;y[1]=0xff000003;return y;} + d=e>>5;m=e&31;if(d>=lx-2) err(truer2); + y=cgeti(d+3);y[1]=0xff000003+d; + if(m==31) + { + for(i=2;i<=d+2;i++) y[i]=x[i]; + while((i=2)&&(y[i]==0xffffffff);i--) y[i]=0; + if(i>=2) y[i]++; + else + { + z=y;y=cgeti(1);*y=(*z)+1;y[1]=z[1]+1; + } + } + return y; +} + + +int cmpsi(x,y) + plong x; + GEN y; +{ + ulong p; + + if(!x) return -signe(y); + if(x>0) + { + if(signe(y)<=0) return 1; + if(lgef(y)>3) return -1; + p=y[2];if(p==x) return 0; + return (p<(ulong)x) ? 1 : -1; + } + else + { /* x <= 0 */ + if(signe(y)>=0) return -1; + if(lgef(y)>3) + { if (-x < 0) + { /* x = -2^31 */ + if (lgef(y)==4 && + y[2] == 0 && + y[3] == 1) + return 0; + else + return 1;}} + p=y[2];if(p== -x) return 0; + return (p<(ulong)(-x)) ? -1 : 1; + } +} + + +int cmpii(x,y) + GEN x,y; +{ + plong sx=signe(x),sy=signe(y),lx,ly,i; + + if(sxsy) return 1; + if(!sx) return 0; + lx=lgef(x);ly=lgef(y); + if(lx>ly) return sx; + if(lx(ulong)y[i]) ? sx : -sx; +} + + +GEN addss(x,y) + plong x,y; +{ + plong t[3]; + + if(!x) return stoi(y); + t[0]=0x1010003; + if(x>0) {t[1]=0x1000003;t[2]=x;} else {t[1]=0xff000003;t[2]= -x;} + return addsi(y,t); +} + + +GEN subii(x,y) + GEN x,y; +{ + plong s=signe(y); + GEN z; + + if(x==y) return gzero; + setsigne(y,-s);z=addii(x,y);setsigne(y,s); + return z; +} + + +GEN subsi(x,y) + plong x; + GEN y; +{ + plong s=signe(y); + GEN z; + + setsigne(y,-s);z=addsi(x,y);setsigne(y,s);return z; +} + + +GEN subss(x,y) + plong x,y; +{ + if (y == (1<<31)) + return addsi(x,ABS_MOST_NEGS); + return addss(-y,x); +} + + +GEN convi(x) + GEN x; +{ + plong lx,av=avma,lz; + GEN z,p1,p2; + + if(!signe(x)) + { + z=cgeti(3);z[1]= -1;z[2]=0;avma=av;return z+3; + } + p1=absi(x);lx=lgef(p1);lz=((lx-2)*15)/14+3;z=cgeti(lz);z[1]= -1; + for(p2=z+2;signe(p1);p2++) *p2=divisii(p1,1000000000,p1); + avma=av;return p2; +} + + + +void mulsii(x,y,z) + plong x; + GEN y,z; +{ + plong av=avma; + GEN p1; + + p1=mulsi(x,y);affii(p1,z);avma=av; +} + + +void addsii(x,y,z) + plong x; + GEN y,z; +{ + plong av=avma; + GEN p1; + + p1=addsi(x,y);affii(p1,z);avma=av; +} + + +plong divisii(x,y,z) + plong y; + GEN x,z; +{ + plong av=avma,k; + GEN p1; + + p1=divis(x,y);affii(p1,z);avma=av; + k=hiremainder;return k; +} + + +plong vals(x) + plong x; +{ + unsigned short int y,z; + int s; + + if(!x) return -1; + y=x;if(!y) {s=16;y=((ulong)x)>>16;} else s=0; + z=y&255;if(!z) {s+=8;z=y>>8;} + y=z&15;if(!y) {s+=4;y=z>>4;} + z=y&3;if(!z) {s+=2;z=y>>2;} + return (z&1) ? s : s+1; +} + + +plong vali(x) + GEN x; +{ + plong i,lx=lgef(x); + + if(!signe(x)) return -1; + for(i=lx-1;(i>=2)&&(!x[i]);i--); + return ((lx-1-i)<<5)+vals(x[i]); +} + +GEN dvmdss(x,y,z) + plong x,y; + GEN *z; +{ + GEN p1; + + p1=divss(x,y);*z=stoi(hiremainder); + return p1; +} + + +GEN dvmdsi(x,y,z) + plong x; + GEN y,*z; +{ + GEN p1; + p1=divsi(x,y);*z=stoi(hiremainder); + return p1; +} + + +GEN dvmdis(x,y,z) + plong y; + GEN x,*z; +{ + GEN p1; + p1=divis(x,y);*z=stoi(hiremainder); + return p1; +} + + +GEN ressi(x,y) + plong x; + GEN y; +{ + divsi(x,y);return stoi(hiremainder); +} + + +GEN modsi(x,y) + plong x; + GEN y; +{ + plong s; + GEN p1; + + divsi(x,y); + if(!hiremainder) return gzero; + if(x>0) return stoi(hiremainder); + else + { + s=signe(y);setsigne(y,1);p1=addsi(hiremainder,y); + setsigne(y,s);return p1; + } +} + + +GEN modis(x,y) + plong y; + GEN x; +{ + divis(x,y);if(!hiremainder) return gzero; + return (signe(x)>0) ? stoi(hiremainder) : stoi(abs(y)+hiremainder); +} + + +GEN resis(x,y) + plong y; + GEN x; +{ + divis(x,y);return stoi(hiremainder); +} + + +GEN modii(x,y) + GEN x,y; +{ + plong av=avma,tetpil; + GEN p1; + + p1=dvmdii(x,y,-1); + if(signe(p1)>=0) return p1; + tetpil=avma;p1=(signe(y)>0) ? addii(p1,y) : subii(p1,y); + return gerepile(av,tetpil,p1); +} + +int +mpdivis(x,y,z) + GEN x,y,z; +{ + plong av=avma; + GEN p1,p2; + + p1=dvmdii(x,y,&p2); + if(signe(p2)) {avma=av;return 0;} + affii(p1,z);avma=av;return 1; +} + +int +divise(x,y) + GEN x,y; +{ + plong av=avma; + GEN p1; + + p1=dvmdii(x,y,-1);avma=av; + return signe(p1) ? 0 : 1; +} + + +GEN gerepile(l,p,q) + GEN l,p,q; + +{ + plong av,declg,tl; + GEN ll,pp,l1,l2,l3; + + declg=(plong)l-(plong)p;if(declg<=0) return q; + for(ll=l,pp=p;pp>(GEN)avma;) *--ll= *--pp; + av=(plong)ll; + while((llll) l3=l2;} + else {ll+=lg(ll);l3=ll;} + for(;l2=(GEN)avma)) + { + if(l1=(GEN)avma))) + { + avma=av;return q+(declg>>2); + } + else {avma=av;return q;} +} + + +void cgiv(x) + GEN x; +{ + plong p; + + if((p=pere(x))==255) return; + if((x!=(GEN)avma)||(p>1)) {setpere(x,p-1);return;} + do x+=lg(x);while(!pere(x)); + avma=(plong)x; + return; +} diff --git a/mp/mp_addmul.c b/mp/mp_addmul.c new file mode 100755 index 0000000..101aca9 --- /dev/null +++ b/mp/mp_addmul.c @@ -0,0 +1,40 @@ + +/* Copyright (C) 1994 W. Schelter + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU library general public +license along with GCL; see the file COPYING. If not, write to the +Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +*/ + +#include "include.h" +#include "arith.h" +/* + (h = hiremainder, y = addmul(a,b), hiremainder:y == a*b + h) is true +*/ + +int addmul(x,y) + ulong x,y; +{ + ulong xlo,xhi,ylo,yhi; + ulong z,z2; TEMPVARS + + xlo=x&65535;xhi=x>>16;ylo=y&65535;yhi=y>>16; + z=addll(xlo*yhi,xhi*ylo); + z2=(overflow)?xhi*yhi+65536+(z>>16):xhi*yhi+(z>>16); + z=addll(xlo*ylo,(z<<16));z2+=overflow; + z=addll(z,hiremainder);hiremainder=z2+overflow; + return z; +} + diff --git a/mp/mp_bfffo.c b/mp/mp_bfffo.c new file mode 100755 index 0000000..6aced00 --- /dev/null +++ b/mp/mp_bfffo.c @@ -0,0 +1,64 @@ + + +/* Copyright (C) 1994 W. Schelter + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU library general public +license along with GCL; see the file COPYING. If not, write to the +Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +*/ + +/* + double i; ulong x; + index of the first non zero bit numbering from left + Bit position measured from most significant end + to the first non zero bit of x + if (x == 2^i) bfffo(x) == (31 - truncate(i)) + else if (x==0) 32 + + [truncate (i) chops off the decimal places] + + bfffo(0) == 32 + bfffo(1) == 31 + bfffo(2) == 30 + bfffo(3) == 30 + bfffo(4) == 29 + bfffo(5) == 29 + .. + +*/ + +#include "include.h" + +#ifndef bfffo +int bfffo(x) + unsigned plong x; +{ + int sc; + static int tabshi[16]={4,3,2,2,1,1,1,1,0,0,0,0,0,0,0,0}; + + if(x&(0xffff0000)) sc=0;else {sc=16;x<<=16;} + if(!(x&(0xff000000))) {sc+=8;x<<=8;} + if(x&(0xf0000000)) x>>=28;else {sc+=4;x>>=24;} + sc+=tabshi[x];return sc; +} + +#else +static dummy () {;} +#endif + + + + + diff --git a/mp/mp_dblrsl3.c b/mp/mp_dblrsl3.c new file mode 100755 index 0000000..c61bd28 --- /dev/null +++ b/mp/mp_dblrsl3.c @@ -0,0 +1,45 @@ + +/* Copyright (C) 1994 W. Schelter + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU library general public +license along with GCL; see the file COPYING. If not, write to the +Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +*/ + +#include "config.h" +#include "genpari.h" +#include "arith.h" + +int dblremsl3(x,y,z) + int x,y,z; +{ unsigned plong h; + unsigned plong w; + if (x>= 0 && y>= 0 && z>0) + {w = mulul(x,y,h); + divul(x,z,h); + return h;} + else + { plong save = avma; + GEN yy = stoi(y); + GEN xx = stoi(x); + GEN ans = mulii(xx,yy); + ans = dvmdii(ans,stoi(z),-1); + avma = save; + if (signe(ans) > 0) return ans[2]; + if (signe(ans) < 0) return -ans[2]; + return 0;} +} + + diff --git a/mp/mp_dblrul3.c b/mp/mp_dblrul3.c new file mode 100755 index 0000000..0e7e2b7 --- /dev/null +++ b/mp/mp_dblrul3.c @@ -0,0 +1,39 @@ + +/* Copyright (C) 1994 W. Schelter + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU library general public +license along with GCL; see the file COPYING. If not, write to the +Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +*/ + +#include "config.h" +#include "genpari.h" +#include "arith.h" + + +unsigned plong dblremul3(x,y,z) + int x,y,z; +{ unsigned plong h; + unsigned plong w = mulul(x,y,h); + w; /* ignore quotient */ + divul(x,z,h); + return h; +} + + + + + + diff --git a/mp/mp_divul3.c b/mp/mp_divul3.c new file mode 100755 index 0000000..41ffbce --- /dev/null +++ b/mp/mp_divul3.c @@ -0,0 +1,65 @@ + +/* Copyright (C) 1994 W. Schelter + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU library general public +license along with GCL; see the file COPYING. If not, write to the +Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +*/ + +/* + ulong low,divisor,h,q; + if divisor!= 0 and if (hiremainder:low)/divisor (ie q) + is expressible in 32 bits, + then + (h = hiremainder, q = divll(low,divisor), + h:low == q * divisor + hiremainder && 0<= hiremainder && hiremainder < divisor) + is TRUE. + [the arithmetic is ordinary arithmetic among unsigned 64 bit integers] + A sufficient criteria for (hiremainder:low)/divisor + to be expressible in 32 bits, + is bfffo(divisor)-bfffo(hiremainder) <= 0 + +*/ + +#include "include.h" +#include "arith.h" + +#define WORD_SIZE 32 +/* SHIFT1BIT: shift h and l left by 1 as 64 bits. We don't care what + is coming into the bottom word */ + +#define shift1bit(h,l) \ + l = (h = h << 1, ( l & (1<<(WORD_SIZE -1)) ? h +=1 : 0), l<<1) + +ulong +divul3(x,y,hi) + ulong x,y,*hi; +{ulong q =0; + ulong h = *hi,l=x,hibit; + int count = WORD_SIZE; +/* if (y<=h) printf("error: the quotient will be more than 32 bits"); */ +#ifdef QUICK_DIV + QUICK_DIV(x,y,h,hi) +#endif + do { q = q << 1; + hibit = h & (1 << (WORD_SIZE -1)); + shift1bit(h,l); + if (hibit || (y <= h)) + { q += 1; h -= y;} + } while(--count > 0); + *hi = h; + return q; +} + diff --git a/mp/mp_divul3_word.c b/mp/mp_divul3_word.c new file mode 100755 index 0000000..20cc1f0 --- /dev/null +++ b/mp/mp_divul3_word.c @@ -0,0 +1,80 @@ + +/* Copyright (C) 1994 W. Schelter + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU library general public +license along with GCL; see the file COPYING. If not, write to the +Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +*/ + +#include "include.h" +#include "arith.h" + + + +our_ulong +divul3(x,y,hi) + our_ulong x,y,*hi; +{ +#define HIBIT 0x80000000 +#define HIMASK 0xffff0000 +#define LOMASK 0xffff +#define HIWORD(a) (a >> 16) +/* si le compilateur est bugge, il faut mettre (a >> 16) & LOMASK) */ +#define LOWORD(a) (a & LOMASK) +#define GLUE(hi, lo) ((hi << 16) + lo) +#define SPLIT(a, b, c) b = HIWORD(a); c = LOWORD(a) + + our_ulong v1, v2, u3, u4, q1, q2, aux, aux1, aux2,hiremainder=*hi; + int k; + + for(k = 0; !(y & HIBIT); k++) + { + hiremainder <<= 1; + if (x & HIBIT) hiremainder++; + x <<= 1; + y <<= 1; + } + + SPLIT(y, v1, v2); + SPLIT(x, u3, u4); + + q1 = hiremainder / v1; if (q1 & HIMASK) q1 = LOMASK; + hiremainder -= q1 * v1; + aux = v2 * q1; +again: + SPLIT(aux, aux1, aux2); + if (aux2 > u3) aux1++; + if (aux1 > hiremainder) {q1--; hiremainder += v1; aux -= v2; goto again;} + u3 -= aux2; + hiremainder -= aux1; + hiremainder <<= 16; hiremainder += u3 & LOMASK; + + q2 = hiremainder / v1; if (q2 & HIMASK) q2 = LOMASK; + hiremainder -= q2 * v1; + aux = v2 * q2; +again2: + SPLIT(aux, aux1, aux2); + if (aux2 > u4) aux1++; + if (aux1 > hiremainder) {q2--; hiremainder += v1; aux -= v2; goto again2;} + u4 -= aux2; + hiremainder -= aux1; + hiremainder <<= 16; hiremainder += u4 & LOMASK; + hiremainder >>= k; + *hi = hiremainder; + return GLUE(q1, q2); +} + + + diff --git a/mp/mp_mulul3.c b/mp/mp_mulul3.c new file mode 100755 index 0000000..bb939e7 --- /dev/null +++ b/mp/mp_mulul3.c @@ -0,0 +1,69 @@ + +/* Copyright (C) 1994 W. Schelter + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU library general public +license along with GCL; see the file COPYING. If not, write to the +Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +*/ + + + +#include "include.h" +#include "arith.h" + +/* ulong a,b,y; + (y = mulul3(a,b,&hiremainder), hiremainder:y == a*b) is TRUE. +*/ +#ifdef USE_WORD_MULUL3 + +int mulul3(x,y,hiremainder) + ulong x,y,*hiremainder; +{ + ulong xlo,xhi,ylo,yhi; + ulong z; TEMPVARS + + xlo=x&65535;xhi=x>>16;ylo=y&65535;yhi=y>>16; + z=addll(xlo*yhi,xhi*ylo); + *hiremainder=(overflow)?xhi*yhi+65536+(z>>16):xhi*yhi+(z>>16); + z=addll(xlo*ylo,(z<<16));*hiremainder+=overflow; + return z; +} + +#else +ulong +mulul3(a,b,h) +unsigned int a,b, *h; +{unsigned int temph,templ,ah,al,i; + ah=0; + al=0; + /* in case the shift by 32 does not zero an unsigned int.. + we separate out the first step.*/ + {if (b & 1) + {temph=0;templ=a; + lladd(temph,templ,ah,al);} + /* printf("\n%d b=%d a=%d (%d:%d)",i,b,a,ah,al); */ + b=b>>1; + } + i=1; + while(b) + {if (b & 1) + {llshift(a,i,temph,templ); + lladd(temph,templ,ah,al);} + i++;b=b>>1; + } + *h=ah; + return al; +} +#endif diff --git a/mp/mp_shiftl.c b/mp/mp_shiftl.c new file mode 100755 index 0000000..4b0b2cd --- /dev/null +++ b/mp/mp_shiftl.c @@ -0,0 +1,34 @@ + +/* Copyright (C) 1994 W. Schelter + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU library general public +license along with GCL; see the file COPYING. If not, write to the +Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +*/ + +typedef unsigned plong ulong; +ulong hiremainder,overflow; + +int shiftl(x,y) + ulong x,y; +{ + hiremainder=x>>(32-y);return (x<>y); +} diff --git a/mp/mp_sl3todivul3.c b/mp/mp_sl3todivul3.c new file mode 100755 index 0000000..c6bf75d --- /dev/null +++ b/mp/mp_sl3todivul3.c @@ -0,0 +1,110 @@ + +/* Copyright (C) 1994 W. Schelter + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU library general public +license along with GCL; see the file COPYING. If not, write to the +Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +*/ + +#define ulong unsigned plong +#define shift1BitRight(h,l) \ + (l = l >> 1 , (h & 1 ? l = l | (1 << (WORD_SIZE -1)) : 0), h = h >> 1) + +#define shift2BitRight(h,l) \ + (l = l >> 2 , (h & 3 ? l = l | ((h & 3) << (WORD_SIZE -2)) : 0), h = h >> 2) + +#define addll(x,y) \ + (Xtx=(x),Xty=(y), Xtres = Xtx+Xty, \ + (Xtres < Xtx ? overflow = 1 :0), Xtres) + +/* the following defines divul3 in terms of divsl3. + */ + + +#define WORD_SIZE 32 +divul3(x, y, hi) + ulong x, y, *hi; +{ + ulong q = 0,Xtx,Xty,Xtres,addy,overflow; + ulong h = *hi, l = x, hibit; + ulong dd; + /* if (y<=h) printf("error: the quotient will be more than 32 bits"); */ + + if ((int) y > 0) { + dd = y >> 1; + if (dd <= h) { + unsigned int ll = l; + shift1BitRight(h, ll); + q = divsl3(ll, y, &h); + h = h + h + (l & 1); + q = q + q; + if (h >= y) { + q++; + h -= y; + } + *hi = h; + return q; + } else { + return divsl3(x, y, hi); + } + } + /* negative */ + { + ulong ll; + ulong rem; + ll = l; + shift2BitRight(h, ll); + dd = y >> 1; + q = divsl3(ll, dd, &h); + rem = h + h; + overflow = 0; + rem = addll(rem, rem); + rem += l & 3; + q = q + q; + addy = 0; + if (y & 1) { + if (overflow==0 && rem < q) + { addy = 1; + rem = addll(rem, y); + if (overflow==0 && rem < q) + { addy = 2; + rem +=y; + } + } + if (q > rem ) overflow = 0; + rem -= q; + } + if (addy > 0) + { q -= addy; } + else + { if (overflow || (rem >= y)) + { rem -= y; + q++; + } + } + + *hi = rem; + return q; + } +} + + +/* + ;;- Local variables: + ;;- mode:c + ;;- version-control:t + ;;- End: + + */ diff --git a/mp/mpi-386_no_under.s b/mp/mpi-386_no_under.s new file mode 100644 index 0000000..14727d8 --- /dev/null +++ b/mp/mpi-386_no_under.s @@ -0,0 +1,2337 @@ + .file "mpi.c" + .version "01.01" +gcc2_compiled.: +.text + .align 16 +.globl mulsi + .type mulsi,@function +mulsi: + pushl %ebp + movl %esp,%ebp + subl $20,%esp + pushl %edi + pushl %esi + pushl %ebx + movl 12(%ebp),%ebx + movl 4(%ebx),%edx + sarl $24,%edx + movl %edx,-8(%ebp) + movzwl 4(%ebx),%ecx + movl %ecx,-12(%ebp) + cmpl $0,8(%ebp) + je .L3 + testl %edx,%edx + jne .L2 +.L3: + movl gzero,%eax + jmp .L14 + .align 16 +.L2: + cmpl $0,8(%ebp) + jge .L4 + negl -8(%ebp) + negl 8(%ebp) + jns .L4 + pushl %ebx + pushl $-2147483648 + call stoi + addl $4,%esp + pushl %eax + call mulii + jmp .L14 + .align 16 +.L4: + movl -12(%ebp),%eax + incl %eax + pushl %eax + call cgeti + movl %eax,-16(%ebp) + movl $0,-4(%ebp) + movl -12(%ebp),%edx + leal 0(,%edx,4),%eax + addl %eax,%ebx + movl %ebx,-20(%ebp) + movl -16(%ebp),%ecx + leal 4(%eax,%ecx),%esi + addl $4,%esp + movl %edx,%edi + addl $-2,%edi + je .L7 + .align 4 +.L8: + addl $-4,%esi + movl -4(%ebp),%ebx + leal -4(%ebp),%eax + pushl %eax + addl $-4,-20(%ebp) + movl -20(%ebp),%edx + movl (%edx),%eax + pushl %eax + movl 8(%ebp),%ecx + pushl %ecx + call mulul3 + addl %ebx,%eax + addl $12,%esp + cmpl %ebx,%eax + jae .L10 + incl -4(%ebp) +.L10: + movl %eax,(%esi) + decl %edi + jne .L8 +.L7: + cmpl $0,-4(%ebp) + je .L12 + movl -4(%ebp),%eax + movl %eax,-4(%esi) + movl -16(%ebp),%edx + movl 4(%edx),%eax + andl $-65536,%eax + movl -12(%ebp),%ecx + leal 1(%ecx,%eax),%eax + movl %eax,4(%edx) + jmp .L13 + .align 16 +.L12: + addl $4,avma + movl -16(%ebp),%edx + movl (%edx),%ecx + decl %ecx + movl %ecx,4(%edx) + addl $4,%edx + movl %edx,-16(%ebp) + movw -12(%ebp),%cx + movw %cx,4(%edx) +.L13: + movb -8(%ebp),%dl + movl -16(%ebp),%ecx + movb %dl,7(%ecx) + movl -16(%ebp),%eax +.L14: + leal -32(%ebp),%esp + popl %ebx + popl %esi + popl %edi + movl %ebp,%esp + popl %ebp + ret +.Lfe1: + .size mulsi,.Lfe1-mulsi + .align 16 +.globl expi + .type expi,@function +expi: + pushl %ebp + movl %esp,%ebp + pushl %ebx + movl 8(%ebp),%eax + movzwl 4(%eax),%ebx + cmpl $2,%ebx + je .L16 + movl 8(%eax),%eax + pushl %eax + call bfffo + movl %eax,%edx + leal -2(%ebx),%eax + sall $5,%eax + subl %edx,%eax + decl %eax + jmp .L17 + .align 16 +.L16: + movl $-8388608,%eax +.L17: + movl -4(%ebp),%ebx + movl %ebp,%esp + popl %ebp + ret +.Lfe2: + .size expi,.Lfe2-expi + .align 16 +.globl addsi + .type addsi,@function +addsi: + pushl %ebp + movl %esp,%ebp + subl $12,%esp + pushl %edi + pushl %esi + pushl %ebx + movl 8(%ebp),%esi + movl 12(%ebp),%edi + testl %esi,%esi + jne .L19 + pushl %edi + call icopy + jmp .L68 + .align 16 +.L19: + movl 4(%edi),%ebx + sarl $24,%ebx + movl %ebx,-8(%ebp) + jne .L20 + pushl %esi + call stoi + jmp .L68 + .align 16 +.L20: + testl %esi,%esi + jge .L21 + movl $-1,-4(%ebp) + negl %esi + jns .L23 + pushl %edi + pushl $MOST_NEGS + call addii + jmp .L68 + .align 16 +.L21: + movl $1,-4(%ebp) +.L23: + movzwl 4(%edi),%ebx + movl %ebx,-12(%ebp) + movl -8(%ebp),%ebx + cmpl %ebx,-4(%ebp) + jne .L24 + movl %esi,%edx + movl %edx,%eax + movl -12(%ebp),%ebx + addl -4(%edi,%ebx,4),%eax + movl %eax,%esi + cmpl %edx,%eax + jae .L25 + movl %ebx,%eax + incl %eax + pushl %eax + call cgeti + movl %eax,%ecx + movl %esi,(%ecx,%ebx,4) + movl -12(%ebp),%edx + decl %edx + cmpl $2,%edx + jle .L32 + .align 4 +.L31: + cmpl $-1,-4(%edi,%edx,4) + jne .L27 + movl $0,(%ecx,%edx,4) + decl %edx + cmpl $2,%edx + jg .L31 +.L27: + cmpl $2,%edx + jle .L32 + movl -4(%edi,%edx,4),%ebx + incl %ebx + movl %ebx,(%ecx,%edx,4) + jmp .L69 + .align 16 + .align 4 +.L35: + movl -4(%edi,%edx,4),%eax + movl %eax,(%ecx,%edx,4) +.L69: + decl %edx + cmpl $2,%edx + jg .L35 + movl (%ecx),%eax + decl %eax + movl %eax,4(%ecx) + movl %eax,8(%ecx) + addl $4,%ecx + addl $4,avma + jmp .L38 + .align 16 +.L32: + movl $1,8(%ecx) + movl (%ecx),%eax + movl %eax,4(%ecx) + jmp .L38 + .align 16 +.L25: + movl -12(%ebp),%ebx + pushl %ebx + call cgeti + movl %eax,%ecx + movl %esi,-4(%ecx,%ebx,4) + movl $1,%edx + movl -12(%ebp),%eax + decl %eax + movl %eax,%esi + cmpl %eax,%edx + jge .L38 + .align 4 +.L42: + movl (%edi,%edx,4),%eax + movl %eax,(%ecx,%edx,4) + incl %edx + cmpl %esi,%edx + jl .L42 +.L38: + movb -4(%ebp),%bl + movb %bl,7(%ecx) + jmp .L44 + .align 16 +.L24: + cmpl $3,-12(%ebp) + jne .L45 + cmpl %esi,8(%edi) + jbe .L46 + pushl $3 + call cgeti + movl %eax,%ecx + movl -8(%ebp),%eax + sall $24,%eax + addl $3,%eax + movl %eax,4(%ecx) + movl 8(%edi),%edi + subl %esi,%edi + movl %edi,8(%ecx) + jmp .L44 + .align 16 +.L46: + cmpl %esi,8(%edi) + jne .L47 + movl gzero,%eax + jmp .L68 + .align 16 +.L47: + pushl $3 + call cgeti + movl %eax,%ecx + movl -8(%ebp),%eax + negl %eax + sall $24,%eax + addl $3,%eax + movl %eax,4(%ecx) + subl 8(%edi),%esi + movl %esi,8(%ecx) + jmp .L44 + .align 16 +.L45: + movl -12(%ebp),%ebx + movl -4(%edi,%ebx,4),%edx + movl %esi,%eax + movl %edx,%esi + subl %eax,%esi + cmpl %eax,%edx + jae .L48 + pushl %ebx + call cgeti + movl %eax,%ecx + movl %esi,-4(%ecx,%ebx,4) + movl -12(%ebp),%edx + addl $-2,%edx + cmpl $0,(%edi,%edx,4) + jne .L50 + .align 4 +.L52: + movl $-1,(%ecx,%edx,4) + decl %edx + cmpl $0,(%edi,%edx,4) + je .L52 +.L50: + movl (%edi,%edx,4),%eax + decl %eax + movl %eax,(%ecx,%edx,4) + cmpl $2,%edx + jg .L55 + testl %eax,%eax + je .L54 +.L55: + decl %edx + testl %edx,%edx + jle .L44 + .align 4 +.L59: + movl (%edi,%edx,4),%eax + movl %eax,(%ecx,%edx,4) + decl %edx + testl %edx,%edx + jg .L59 + jmp .L44 + .align 16 +.L54: + movl (%ecx),%eax + decl %eax + movl %eax,4(%ecx) + movl %eax,8(%ecx) + addl $4,%ecx + addl $4,avma + movb -8(%ebp),%bl + movb %bl,7(%ecx) + jmp .L44 + .align 16 +.L48: + movl -12(%ebp),%ebx + pushl %ebx + call cgeti + movl %eax,%ecx + movl %esi,-4(%ecx,%ebx,4) + movl $1,%edx + movl -12(%ebp),%eax + decl %eax + movl %eax,%esi + cmpl %eax,%edx + jge .L44 + .align 4 +.L66: + movl (%edi,%edx,4),%eax + movl %eax,(%ecx,%edx,4) + incl %edx + cmpl %esi,%edx + jl .L66 +.L44: + movl %ecx,%eax +.L68: + leal -24(%ebp),%esp + popl %ebx + popl %esi + popl %edi + movl %ebp,%esp + popl %ebp + ret +.Lfe3: + .size addsi,.Lfe3-addsi + .align 16 +.globl addii + .type addii,@function +addii: + pushl %ebp + movl %esp,%ebp + subl $32,%esp + pushl %edi + pushl %esi + pushl %ebx + movl 8(%ebp),%ecx + movzwl 4(%ecx),%ecx + movl %ecx,-8(%ebp) + movl 12(%ebp),%edi + movzwl 4(%edi),%edi + movl %edi,-12(%ebp) + cmpl %edi,%ecx + jge .L71 + movl 8(%ebp),%ecx + movl %ecx,-16(%ebp) + movl 12(%ebp),%edi + movl %edi,8(%ebp) + movl %ecx,12(%ebp) + movl -8(%ebp),%ecx + movl %ecx,-4(%ebp) + movl -12(%ebp),%edi + movl %edi,-8(%ebp) + movl %ecx,-12(%ebp) +.L71: + movl 12(%ebp),%ecx + movl 4(%ecx),%esi + sarl $24,%esi + jne .L72 + movl 8(%ebp),%edi + pushl %edi + call icopy + jmp .L135 + .align 16 +.L72: + movl 8(%ebp),%ecx + movl 4(%ecx),%ecx + sarl $24,%ecx + movl %ecx,-4(%ebp) + cmpl %esi,%ecx + jne .L73 + movl -8(%ebp),%eax + incl %eax + pushl %eax + call cgeti + movl %eax,-16(%ebp) + movl $0,-24(%ebp) + movl -8(%ebp),%edi + leal 0(,%edi,4),%eax + movl -16(%ebp),%ecx + leal 4(%eax,%ecx),%esi + movl 8(%ebp),%ebx + addl %eax,%ebx + movl -12(%ebp),%edi + movl 12(%ebp),%ecx + leal (%ecx,%edi,4),%edi + movl %edi,-20(%ebp) + movl -12(%ebp),%ecx + addl $-2,%ecx + movl %ecx,-32(%ebp) + je .L75 + .align 4 +.L76: + addl $-4,%esi + addl $-4,%ebx + movl (%ebx),%edi + movl %edi,-28(%ebp) + addl $-4,-20(%ebp) + movl %edi,%edx + movl -20(%ebp),%ecx + addl (%ecx),%edx + cmpl %edi,%edx + jae .L77 + addl -24(%ebp),%edx + movl $1,-24(%ebp) + jmp .L137 + .align 16 +.L77: + addl -24(%ebp),%edx + cmpl %edx,-24(%ebp) + seta %al + andl $255,%eax + movl %eax,-24(%ebp) +.L137: + movl %edx,(%esi) + decl -32(%ebp) + jne .L76 +.L75: + cmpl $0,-24(%ebp) + je .L80 + movl 8(%ebp),%edx + addl $8,%edx +.L81: + addl $-4,%ebx + movl %ebx,%eax + cmpl %edx,%ebx + jb .L82 + cmpl $-1,(%ebx) + jne .L83 + addl $-4,%esi + movl $0,(%esi) + jmp .L81 + .align 16 +.L83: + addl $-4,%esi + movl (%eax),%eax + incl %eax + jmp .L138 + .align 16 + .align 4 +.L87: + addl $-4,%esi + movl (%eax),%eax +.L138: + movl %eax,(%esi) + addl $-4,%ebx + movl %ebx,%eax + cmpl %edx,%ebx + jae .L87 + jmp .L92 + .align 16 +.L82: + movl -16(%ebp),%edi + movl $1,8(%edi) + movl 8(%ebp),%ecx + movl 4(%ecx),%ecx + incl %ecx + movl %ecx,4(%edi) + jmp .L95 + .align 16 +.L80: + movl -8(%ebp),%edx + subl -12(%ebp),%edx + je .L92 + .align 4 +.L93: + addl $-4,%esi + addl $-4,%ebx + movl (%ebx),%eax + movl %eax,(%esi) + decl %edx + jne .L93 +.L92: + movl -16(%ebp),%edi + movl (%edi),%ecx + decl %ecx + movl %ecx,4(%edi) + movl 8(%ebp),%edi + movl 4(%edi),%eax + movl -16(%ebp),%ecx + movl %eax,8(%ecx) + addl $4,%ecx + movl %ecx,-16(%ebp) + addl $4,avma + jmp .L95 + .align 16 +.L73: + movl -12(%ebp),%edi + cmpl %edi,-8(%ebp) + jne .L96 + movl 8(%ebp),%ebx + addl $8,%ebx + movl 12(%ebp),%ecx + addl $8,%ecx + movl %ecx,-20(%ebp) + movl -8(%ebp),%edx + addl $-2,%edx + je .L105 + .align 4 +.L99: + movl (%ebx),%edi + movl %edi,-28(%ebp) + addl $4,%ebx + movl -20(%ebp),%ecx + movl (%ecx),%eax + addl $4,%ecx + movl %ecx,-20(%ebp) + cmpl %edi,%eax + ja .L136 + cmpl %eax,%edi + ja .L96 + decl %edx + jne .L99 +.L105: + movl gzero,%eax + jmp .L135 + .align 16 +.L136: + movl 8(%ebp),%edi + movl %edi,-16(%ebp) + movl 12(%ebp),%ecx + movl %ecx,8(%ebp) + movl %edi,12(%ebp) + movl %esi,-4(%ebp) +.L96: + movl -8(%ebp),%edi + pushl %edi + call cgeti + movl %eax,-16(%ebp) + movl $0,-24(%ebp) + leal 0(,%edi,4),%eax + movl 8(%ebp),%ebx + addl %eax,%ebx + movl -12(%ebp),%ecx + movl 12(%ebp),%edi + leal (%edi,%ecx,4),%ecx + movl %ecx,-20(%ebp) + movl -16(%ebp),%esi + addl %eax,%esi + movl -12(%ebp),%edi + addl $-2,%edi + movl %edi,-32(%ebp) + je .L107 + .align 4 +.L108: + addl $-4,%esi + addl $-4,%ebx + movl (%ebx),%ecx + movl %ecx,-28(%ebp) + addl $-4,-20(%ebp) + movl -20(%ebp),%edi + movl (%edi),%eax + movl %ecx,%edx + subl %eax,%edx + subl -24(%ebp),%edx + cmpl %ecx,%eax + jbe .L109 + movl $1,-24(%ebp) + jmp .L110 + .align 16 +.L109: + cmpl %eax,-28(%ebp) + jbe .L110 + movl $0,-24(%ebp) +.L110: + movl %edx,(%esi) + decl -32(%ebp) + jne .L108 +.L107: + cmpl $0,-24(%ebp) + je .L114 + jmp .L139 + .align 16 + .align 4 +.L117: + addl $-4,%esi + movl $-1,(%esi) +.L139: + addl $-4,%ebx + movl (%ebx),%eax + testl %eax,%eax + je .L117 + movl 8(%ebp),%edx + addl $8,%edx + cmpl %edx,%ebx + jb .L124 + addl $-4,%esi + decl %eax + movl %eax,(%esi) + addl $-4,%ebx + movl %ebx,%eax + cmpl %edx,%ebx + jb .L124 + .align 4 +.L122: + addl $-4,%esi + movl (%eax),%eax + movl %eax,(%esi) + addl $-4,%ebx + movl %ebx,%eax + cmpl %edx,%ebx + jae .L122 + jmp .L124 + .align 16 +.L114: + movl -8(%ebp),%ecx + subl -12(%ebp),%ecx + movl %ecx,-32(%ebp) + je .L124 + .align 4 +.L127: + addl $-4,%esi + addl $-4,%ebx + movl (%ebx),%eax + movl %eax,(%esi) + decl -32(%ebp) + jne .L127 +.L124: + movl -16(%ebp),%edi + cmpl $0,8(%edi) + je .L129 + movl 8(%ebp),%ecx + movl 4(%ecx),%eax + movl %eax,4(%edi) + jmp .L95 + .align 16 +.L129: + movl -16(%ebp),%esi + addl $12,%esi + movl -16(%ebp),%edi + cmpl $0,12(%edi) + jne .L132 + .align 4 +.L133: + addl $4,%esi + cmpl $0,(%esi) + je .L133 +.L132: + addl $-8,%esi + movl %esi,%ecx + subl -16(%ebp),%ecx + sarl $2,%ecx + movl %ecx,-32(%ebp) + movl -16(%ebp),%edi + movl (%edi),%eax + subl %ecx,%eax + movl %eax,(%esi) + movl %eax,4(%esi) + movl %esi,-16(%ebp) + movb -4(%ebp),%cl + movb %cl,7(%esi) + movl -32(%ebp),%edi + leal 0(,%edi,4),%eax + addl %eax,avma +.L95: + movl -16(%ebp),%eax +.L135: + leal -44(%ebp),%esp + popl %ebx + popl %esi + popl %edi + movl %ebp,%esp + popl %ebp + ret +.Lfe4: + .size addii,.Lfe4-addii + .align 16 +.globl mulss + .type mulss,@function +mulss: + pushl %ebp + movl %esp,%ebp + subl $4,%esp + pushl %esi + pushl %ebx + movl 8(%ebp),%edx + movl 12(%ebp),%ebx + testl %edx,%edx + je .L142 + testl %ebx,%ebx + jne .L141 +.L142: + movl gzero,%eax + jmp .L150 + .align 16 +.L141: + movl $1,%esi + testl %edx,%edx + jge .L143 + movl $-1,%esi + negl %edx + jns .L143 + pushl %edx + call stoi + pushl %eax + pushl %ebx + call mulsi + jmp .L150 + .align 16 +.L143: + testl %ebx,%ebx + jge .L145 + negl %esi + negl %ebx + jns .L145 + pushl $ABS_MOST_NEGS + movl %edx,%eax + testl %esi,%esi + jg .L147 + negl %eax +.L147: + pushl %eax + call mulsi + jmp .L150 + .align 16 +.L145: + leal -4(%ebp),%eax + pushl %eax + pushl %ebx + pushl %edx + call mulul3 + movl %eax,%ebx + addl $12,%esp + cmpl $0,-4(%ebp) + je .L148 + pushl $4 + call cgeti + movl %eax,%edx + movl -4(%ebp),%eax + movl %eax,8(%edx) + movl %ebx,12(%edx) + jmp .L149 + .align 16 +.L148: + pushl $3 + call cgeti + movl %eax,%edx + movl %ebx,8(%edx) +.L149: + movl (%edx),%eax + movl %eax,4(%edx) + movl %esi,%ecx + movb %cl,7(%edx) + movl %edx,%eax +.L150: + leal -12(%ebp),%esp + popl %ebx + popl %esi + movl %ebp,%esp + popl %ebp + ret +.Lfe5: + .size mulss,.Lfe5-mulss + .align 16 +.globl mulii + .type mulii,@function +mulii: + pushl %ebp + movl %esp,%ebp + subl $48,%esp + pushl %edi + pushl %esi + pushl %ebx + movl 8(%ebp),%esi + movzwl 4(%esi),%ecx + movl %ecx,-8(%ebp) + movl 12(%ebp),%edi + movzwl 4(%edi),%edi + movl %edi,-12(%ebp) + movl 4(%esi),%ebx + sarl $24,%ebx + je .L177 + movl 12(%ebp),%ecx + movl 4(%ecx),%eax + sarl $24,%eax + jne .L153 +.L177: + movl gzero,%eax + jmp .L176 + .align 16 +.L153: + testl %eax,%eax + jge .L154 + negl %ebx +.L154: + movl -12(%ebp),%edi + cmpl %edi,-8(%ebp) + jle .L155 + movl %esi,-24(%ebp) + movl 12(%ebp),%esi + movl -24(%ebp),%ecx + movl %ecx,12(%ebp) + movl -8(%ebp),%edi + movl %edi,-16(%ebp) + movl -12(%ebp),%ecx + movl %ecx,-8(%ebp) + movl %edi,-12(%ebp) +.L155: + movl -8(%ebp),%edi + movl -12(%ebp),%ecx + leal -2(%ecx,%edi),%edi + movl %edi,-16(%ebp) + cmpl $65535,%edi + jle .L156 + pushl $17 + call err + addl $4,%esp +.L156: + movl -16(%ebp),%edi + pushl %edi + call cgeti + movl %eax,-24(%ebp) + movl (%eax),%eax + movl -24(%ebp),%ecx + movl %eax,4(%ecx) + movb %bl,7(%ecx) + movl -8(%ebp),%edi + leal -4(%esi,%edi,4),%esi + movl %esi,-32(%ebp) + movl (%esi),%ecx + movl %ecx,-20(%ebp) + movl $0,-4(%ebp) + movl -12(%ebp),%edi + movl 12(%ebp),%ecx + leal (%ecx,%edi,4),%edi + movl %edi,-48(%ebp) + movl -16(%ebp),%ecx + movl -24(%ebp),%edi + leal (%edi,%ecx,4),%ecx + movl %ecx,-28(%ebp) + addl $4,%esp + movl -12(%ebp),%esi + addl $-2,%esi + je .L158 + .align 4 +.L159: + addl $-4,-28(%ebp) + movl -4(%ebp),%ebx + leal -4(%ebp),%eax + pushl %eax + addl $-4,-48(%ebp) + movl -48(%ebp),%edi + movl (%edi),%eax + pushl %eax + movl -20(%ebp),%ecx + pushl %ecx + call mulul3 + addl %ebx,%eax + addl $12,%esp + cmpl %ebx,%eax + jae .L161 + incl -4(%ebp) +.L161: + movl -28(%ebp),%edi + movl %eax,(%edi) + decl %esi + jne .L159 +.L158: + movl -4(%ebp),%eax + movl -28(%ebp),%ecx + movl %eax,-4(%ecx) + movl -16(%ebp),%edi + movl -24(%ebp),%ecx + leal (%ecx,%edi,4),%edi + movl %edi,-28(%ebp) + movl -12(%ebp),%ecx + movl 12(%ebp),%edi + leal (%edi,%ecx,4),%ecx + movl %ecx,-36(%ebp) + decl -12(%ebp) + addl $-3,-8(%ebp) + cmpl $0,-8(%ebp) + jle .L164 + .align 4 +.L165: + addl $-4,-32(%ebp) + movl -32(%ebp),%edi + movl (%edi),%edi + movl %edi,-44(%ebp) + movl -36(%ebp),%ecx + movl %ecx,-48(%ebp) + movl -28(%ebp),%ebx + addl $-4,%ebx + movl %ebx,-28(%ebp) + movl $0,-40(%ebp) + movl -12(%ebp),%esi + jmp .L178 + .align 16 + .align 4 +.L168: + addl $-4,-48(%ebp) + movl -48(%ebp),%edi + movl (%edi),%edx + leal -4(%ebp),%eax + pushl %eax + movl -44(%ebp),%ecx + pushl %ecx + pushl %edx + call mulul3 + movl %eax,%edx + addl $-4,%ebx + addl (%ebx),%eax + addl $12,%esp + cmpl %edx,%eax + jae .L170 + incl -4(%ebp) +.L170: + movl %eax,%edx + movl -40(%ebp),%eax + addl %edx,%eax + cmpl %edx,%eax + jae .L172 + incl -4(%ebp) +.L172: + movl %eax,(%ebx) + movl -4(%ebp),%edi + movl %edi,-40(%ebp) +.L178: + decl %esi + jne .L168 + movl -4(%ebp),%eax + movl %eax,-4(%ebx) + decl -8(%ebp) + cmpl $0,-8(%ebp) + jg .L165 +.L164: + movl -24(%ebp),%ecx + cmpl $0,8(%ecx) + jne .L175 + movl -24(%ebp),%ecx + movl 4(%ecx),%edi + decl %edi + movl %edi,8(%ecx) + movl -24(%ebp),%ecx + movl (%ecx),%edi + decl %edi + movl %edi,4(%ecx) + addl $4,%ecx + movl %ecx,-24(%ebp) + addl $4,avma +.L175: + movl -24(%ebp),%eax +.L176: + leal -60(%ebp),%esp + popl %ebx + popl %esi + popl %edi + movl %ebp,%esp + popl %ebp + ret +.Lfe6: + .size mulii,.Lfe6-mulii +.section .rodata + .align 4 +.LC0: + .long 0x55475a32,0x3fd34413 +.text + .align 16 +.globl confrac + .type confrac,@function +confrac: + pushl %ebp + movl %esp,%ebp + subl $76,%esp + pushl %edi + pushl %esi + pushl %ebx + movl 8(%ebp),%eax + movzwl (%eax),%eax + movl %eax,-16(%ebp) + movl 8(%ebp),%edx + movl 4(%edx),%edx + andl $16777215,%edx + movl $8388607,%ecx + subl %edx,%ecx + movl %ecx,-20(%ebp) + movl avma,%eax + movl %eax,-24(%ebp) + movl -16(%ebp),%edx + sall $5,%edx + leal -64(%ecx,%edx),%edx + movl %edx,-32(%ebp) + addl $63,%edx + sarl $5,%edx + movl %edx,-28(%ebp) + pushl %edx + call cgeti + movl %eax,-44(%ebp) + movl -20(%ebp),%esi + sarl $5,%esi + xorl %ebx,%ebx + addl $4,%esp + cmpl %esi,%ebx + jge .L181 + .align 4 +.L183: + movl -44(%ebp),%ecx + movl $0,(%ecx,%ebx,4) + incl %ebx + cmpl %esi,%ebx + jl .L183 +.L181: + andl $31,-20(%ebp) + jne .L185 + movl $2,%edi + cmpl %edi,-16(%ebp) + jle .L191 + .align 4 +.L189: + movl 8(%ebp),%eax + movl (%eax,%edi,4),%eax + movl -44(%ebp),%edx + movl %eax,(%edx,%ebx,4) + incl %ebx + incl %edi + cmpl %edi,-16(%ebp) + jg .L189 + jmp .L191 + .align 16 +.L185: + movl $0,-40(%ebp) + movl $2,%edi + cmpl %edi,-16(%ebp) + jle .L193 + movl $32,%ecx + subl -20(%ebp),%ecx + movl %ecx,-52(%ebp) + .align 4 +.L195: + movl %ebx,-60(%ebp) + movl 8(%ebp),%eax + movl (%eax,%edi,4),%esi + incl %ebx + movl %esi,%eax + movl -52(%ebp),%ecx + sall %cl,%eax + movl %eax,-64(%ebp) + movl %eax,-12(%ebp) + movl -20(%ebp),%ecx + shrl %cl,%esi + movl %esi,%ecx + addl -40(%ebp),%ecx + movl -60(%ebp),%eax + movl -44(%ebp),%edx + movl %ecx,(%edx,%eax,4) + movl -64(%ebp),%eax + movl %eax,-40(%ebp) + incl %edi + cmpl %edi,-16(%ebp) + jg .L195 +.L193: + movl -40(%ebp),%eax + movl -28(%ebp),%edx + movl -44(%ebp),%ecx + movl %eax,-8(%ecx,%edx,4) +.L191: + movl -28(%ebp),%edx + movl -44(%ebp),%ecx + movl $0,-4(%ecx,%edx,4) + fldl .LC0 + fimull -32(%ebp) + fld1 + faddp %st,%st(1) + fnstcw -4(%ebp) + movl -4(%ebp),%eax + movb $12,%ah + movl %eax,-8(%ebp) + fldcw -8(%ebp) + subl $4,%esp + fistpl (%esp) + popl %ebx + fldcw -4(%ebp) + leal 17(%ebx),%edx + movl %edx,-36(%ebp) + movl -36(%ebp),%eax + movl $9,%ecx + cltd + idivl %ecx + movl %eax,-36(%ebp) + pushl %eax + call cgeti + movl %eax,-48(%ebp) + movl %ebx,(%eax) + movl $1,%edi + addl $4,%esp + cmpl %edi,-36(%ebp) + jle .L198 + .align 4 +.L200: + movl $0,-12(%ebp) + movl -28(%ebp),%ebx + decl %ebx + js .L202 + .align 4 +.L204: + movl -12(%ebp),%esi + leal -12(%ebp),%eax + pushl %eax + pushl $1000000000 + movl -44(%ebp),%edx + movl (%edx,%ebx,4),%edx + pushl %edx + call mulul3 + movl %eax,-64(%ebp) + addl %esi,-64(%ebp) + addl $12,%esp + cmpl %esi,-64(%ebp) + jae .L206 + incl -12(%ebp) +.L206: + movl -64(%ebp),%eax + movl -44(%ebp),%ecx + movl %eax,(%ecx,%ebx,4) + decl %ebx + jns .L204 +.L202: + movl -12(%ebp),%edx + movl -48(%ebp),%ecx + movl %edx,(%ecx,%edi,4) + incl %edi + cmpl %edi,-36(%ebp) + jg .L200 +.L198: + movl -24(%ebp),%eax + movl %eax,avma + movl -48(%ebp),%eax + leal -88(%ebp),%esp + popl %ebx + popl %esi + popl %edi + movl %ebp,%esp + popl %ebp + ret +.Lfe7: + .size confrac,.Lfe7-confrac + .align 16 +.globl divss + .type divss,@function +divss: + pushl %ebp + movl %esp,%ebp + pushl %esi + pushl %ebx + movl 8(%ebp),%esi + movl 12(%ebp),%ebx + testl %ebx,%ebx + jne .L210 + pushl $23 + call err + addl $4,%esp +.L210: + cmpl $-2147483648,%esi + jne .L211 + pushl %ebx + pushl $-2147483648 + call stoi + addl $4,%esp + pushl %eax + call divis + jmp .L216 + .align 16 +.L211: + movl $0,hiremainder + pushl $hiremainder + movl %ebx,%eax + testl %ebx,%ebx + jge .L212 + negl %eax +.L212: + pushl %eax + movl %esi,%eax + testl %esi,%esi + jge .L213 + negl %eax +.L213: + pushl %eax + call divul3 + addl $12,%esp + testl %ebx,%ebx + jge .L214 + negl hiremainder + negl %eax +.L214: + testl %esi,%esi + jge .L215 + negl %eax +.L215: + pushl %eax + call stoi +.L216: + leal -8(%ebp),%esp + popl %ebx + popl %esi + movl %ebp,%esp + popl %ebp + ret +.Lfe8: + .size divss,.Lfe8-divss + .align 16 +.globl modss + .type modss,@function +modss: + pushl %ebp + movl %esp,%ebp + subl $4,%esp + pushl %esi + pushl %ebx + movl 8(%ebp),%esi + movl 12(%ebp),%ebx + testl %ebx,%ebx + jne .L218 + pushl $38 + call err + addl $4,%esp +.L218: + cmpl $-2147483648,%esi + jne .L219 + pushl %ebx + pushl $-2147483648 + call stoi + addl $4,%esp + pushl %eax + call modis + jmp .L225 + .align 16 +.L219: + movl $0,-4(%ebp) + leal -4(%ebp),%eax + pushl %eax + testl %ebx,%ebx + jge .L220 + negl %ebx +.L220: + pushl %ebx + movl %esi,%eax + testl %eax,%eax + jge .L221 + negl %eax +.L221: + pushl %eax + call divul3 + addl $12,%esp + cmpl $0,-4(%ebp) + jne .L222 + movl gzero,%eax + jmp .L225 + .align 16 +.L222: + cmpl $0,-4(%ebp) + jge .L223 + movl %ebx,%eax + subl -4(%ebp),%eax + jmp .L226 + .align 16 +.L223: + movl -4(%ebp),%eax +.L226: + pushl %eax + call stoi +.L225: + leal -12(%ebp),%esp + popl %ebx + popl %esi + movl %ebp,%esp + popl %ebp + ret +.Lfe9: + .size modss,.Lfe9-modss + .align 16 +.globl resss + .type resss,@function +resss: + pushl %ebp + movl %esp,%ebp + subl $4,%esp + pushl %ebx + movl 12(%ebp),%ebx + testl %ebx,%ebx + jne .L228 + pushl $40 + call err + addl $4,%esp +.L228: + movl $0,-4(%ebp) + leal -4(%ebp),%eax + pushl %eax + movl %ebx,%eax + testl %ebx,%ebx + jge .L229 + negl %eax +.L229: + pushl %eax + movl 8(%ebp),%eax + testl %eax,%eax + jge .L230 + negl %eax +.L230: + pushl %eax + call divul3 + addl $12,%esp + testl %ebx,%ebx + jge .L231 + movl -4(%ebp),%eax + negl %eax + jmp .L233 + .align 16 +.L231: + movl -4(%ebp),%eax +.L233: + pushl %eax + call stoi + movl -8(%ebp),%ebx + movl %ebp,%esp + popl %ebp + ret +.Lfe10: + .size resss,.Lfe10-resss + .align 16 +.globl divsi + .type divsi,@function +divsi: + pushl %ebp + movl %esp,%ebp + pushl %edi + pushl %esi + pushl %ebx + movl 8(%ebp),%ebx + movl 12(%ebp),%esi + movzwl 4(%esi),%edi + cmpb $0,7(%esi) + jne .L235 + pushl $24 + call err + addl $4,%esp +.L235: + testl %ebx,%ebx + je .L237 + cmpl $3,%edi + jg .L237 + cmpl $0,8(%esi) + jge .L236 +.L237: + movl %ebx,hiremainder + movl gzero,%eax + jmp .L242 + .align 16 +.L236: + cmpl $-2147483648,%ebx + jne .L238 + pushl $0 + pushl %esi + pushl $-2147483648 + call stoi + addl $4,%esp + pushl %eax + call dvmdii + jmp .L242 + .align 16 +.L238: + movl $0,hiremainder + pushl $hiremainder + movl 8(%esi),%eax + pushl %eax + movl %ebx,%eax + testl %ebx,%ebx + jge .L239 + negl %eax +.L239: + pushl %eax + call divul3 + addl $12,%esp + cmpl $0,4(%esi) + jge .L240 + negl hiremainder + negl %eax +.L240: + testl %ebx,%ebx + jge .L241 + negl %eax +.L241: + pushl %eax + call stoi +.L242: + leal -12(%ebp),%esp + popl %ebx + popl %esi + popl %edi + movl %ebp,%esp + popl %ebp + ret +.Lfe11: + .size divsi,.Lfe11-divsi + .align 16 +.globl divis + .type divis,@function +divis: + pushl %ebp + movl %esp,%ebp + subl $24,%esp + pushl %edi + pushl %esi + pushl %ebx + movl 12(%ebp),%edi + movl 8(%ebp),%edx + movl 4(%edx),%edx + sarl $24,%edx + movl %edx,-8(%ebp) + movl 8(%ebp),%ecx + movzwl 4(%ecx),%ecx + movl %ecx,-12(%ebp) + testl %edi,%edi + jne .L244 + pushl $26 + call err + addl $4,%esp +.L244: + cmpl $0,-8(%ebp) + jne .L245 + movl $0,hiremainder + movl gzero,%eax + jmp .L259 + .align 16 +.L245: + testl %edi,%edi + jge .L246 + negl -8(%ebp) + negl %edi + jns .L246 + pushl $0 + pushl %edi + call stoi + addl $4,%esp + pushl %eax + movl 8(%ebp),%edx + pushl %edx + call dvmdii + jmp .L259 + .align 16 +.L246: + movl 8(%ebp),%ecx + cmpl %edi,8(%ecx) + jae .L248 + cmpl $3,-12(%ebp) + jne .L249 + pushl %ecx + call itos + movl %eax,hiremainder + movl gzero,%eax + jmp .L259 + .align 16 +.L249: + movl -12(%ebp),%eax + decl %eax + pushl %eax + call cgeti + movl %eax,%esi + movl $1,-16(%ebp) + movl 8(%ebp),%edx + movl 8(%edx),%eax + movl %eax,-4(%ebp) + jmp .L260 + .align 16 +.L248: + movl -12(%ebp),%ecx + pushl %ecx + call cgeti + movl %eax,%esi + movl $0,-16(%ebp) + movl $0,-4(%ebp) +.L260: + addl $4,%esp + movl -16(%ebp),%ebx + addl $2,%ebx + cmpl %ebx,-12(%ebp) + jle .L253 + leal -4(%ebp),%edx + movl %edx,-20(%ebp) + .align 4 +.L255: + movl -20(%ebp),%ecx + pushl %ecx + pushl %edi + movl 8(%ebp),%edx + movl (%edx,%ebx,4),%eax + pushl %eax + call divul3 + movl %eax,-24(%ebp) + movl %ebx,%eax + subl -16(%ebp),%eax + movl -24(%ebp),%ecx + movl %ecx,(%esi,%eax,4) + addl $12,%esp + incl %ebx + cmpl %ebx,-12(%ebp) + jg .L255 +.L253: + movl (%esi),%eax + movl %eax,4(%esi) + movb -8(%ebp),%dl + movb %dl,7(%esi) + cmpl $0,-8(%ebp) + jge .L257 + movl -4(%ebp),%ecx + negl %ecx + movl %ecx,hiremainder + jmp .L258 + .align 16 +.L257: + movl -4(%ebp),%eax + movl %eax,hiremainder +.L258: + movl %esi,%eax +.L259: + leal -36(%ebp),%esp + popl %ebx + popl %esi + popl %edi + movl %ebp,%esp + popl %ebp + ret +.Lfe12: + .size divis,.Lfe12-divis + .align 16 +.globl dvmdii + .type dvmdii,@function +dvmdii: + pushl %ebp + movl %esp,%ebp + subl $88,%esp + pushl %edi + pushl %esi + pushl %ebx + movl 8(%ebp),%esi + movl 4(%esi),%ecx + sarl $24,%ecx + movl %ecx,-36(%ebp) + movl 12(%ebp),%edi + movl 4(%edi),%edi + sarl $24,%edi + movl %edi,-40(%ebp) + jne .L262 + pushl $36 + call err + addl $4,%esp +.L262: + cmpl $0,-36(%ebp) + jne .L263 + cmpl $-1,16(%ebp) + je .L372 + cmpl $0,16(%ebp) + je .L372 + movl gzero,%eax + movl 16(%ebp),%ecx + movl %eax,(%ecx) +.L372: + movl gzero,%eax + jmp .L367 + .align 16 +.L263: + movzwl 4(%esi),%edi + movl %edi,-12(%ebp) + movl 12(%ebp),%ecx + movzwl 4(%ecx),%ecx + movl %ecx,-16(%ebp) + subl %ecx,%edi + movl %edi,-20(%ebp) + jns .L266 + cmpl $-1,16(%ebp) + jne .L267 + pushl %esi + call icopy + jmp .L367 + .align 16 +.L267: + cmpl $0,16(%ebp) + je .L372 + pushl %esi + call icopy + movl 16(%ebp),%edi + movl %eax,(%edi) + jmp .L372 + .align 16 +.L266: + movl avma,%ecx + movl %ecx,-8(%ebp) + cmpl $0,-36(%ebp) + jge .L269 + negl -40(%ebp) +.L269: + cmpl $3,-16(%ebp) + jne .L270 + movl 12(%ebp),%edi + movl 8(%edi),%edi + movl %edi,-48(%ebp) + leal 8(%esi),%ecx + movl %ecx,-88(%ebp) + cmpl %edi,8(%esi) + jae .L271 + movl -12(%ebp),%ebx + decl %ebx + movl 8(%esi),%eax + movl %eax,-4(%ebp) + addl $12,%esi + movl %esi,-88(%ebp) + jmp .L272 + .align 16 +.L271: + movl -12(%ebp),%ebx + movl $0,-4(%ebp) +.L272: + pushl %ebx + call cgeti + movl %eax,-56(%ebp) + movl %eax,%edi + addl $8,%edi + movl %edi,-72(%ebp) + addl $4,%esp + leal -2(%ebx),%ecx + movl %ecx,-24(%ebp) + testl %ecx,%ecx + je .L274 + leal -4(%ebp),%esi + .align 4 +.L275: + pushl %esi + movl -48(%ebp),%edi + pushl %edi + movl -88(%ebp),%ecx + movl (%ecx),%eax + pushl %eax + addl $4,%ecx + movl %ecx,-88(%ebp) + call divul3 + movl -72(%ebp),%edi + movl %eax,(%edi) + addl $4,%edi + movl %edi,-72(%ebp) + addl $12,%esp + decl -24(%ebp) + jne .L275 +.L274: + cmpl $-1,16(%ebp) + jne .L277 + movl -8(%ebp),%ecx + movl %ecx,avma + cmpl $0,-4(%ebp) + je .L372 + pushl $3 + call cgeti + movl %eax,-60(%ebp) + movl -36(%ebp),%eax + sall $24,%eax + addl $3,%eax + movl -60(%ebp),%edi + movl %eax,4(%edi) + movl -4(%ebp),%eax + movl %eax,8(%edi) + movl -60(%ebp),%eax + jmp .L367 + .align 16 +.L277: + cmpl $2,%ebx + je .L279 + movl -56(%ebp),%ecx + movl (%ecx),%eax + movl %eax,4(%ecx) + movb -40(%ebp),%cl + movl -56(%ebp),%edi + movb %cl,7(%edi) + jmp .L280 + .align 16 +.L279: + movl -8(%ebp),%ecx + movl %ecx,avma + movl gzero,%edi + movl %edi,-56(%ebp) +.L280: + cmpl $0,16(%ebp) + jne .L281 +.L370: + movl -56(%ebp),%eax + jmp .L367 + .align 16 +.L281: + cmpl $0,-4(%ebp) + jne .L282 + movl gzero,%eax + movl 16(%ebp),%ecx + movl %eax,(%ecx) + jmp .L370 + .align 16 +.L282: + pushl $3 + call cgeti + movl %eax,-60(%ebp) + movl -36(%ebp),%eax + sall $24,%eax + addl $3,%eax + movl -60(%ebp),%edi + movl %eax,4(%edi) + movl -4(%ebp),%eax + movl %eax,8(%edi) + movl 16(%ebp),%ecx + movl %edi,(%ecx) + jmp .L370 + .align 16 +.L270: + movl -12(%ebp),%edi + pushl %edi + call cgeti + movl %eax,-56(%ebp) + movl 12(%ebp),%ecx + movl 8(%ecx),%eax + pushl %eax + call bfffo + movl %eax,-28(%ebp) + addl $8,%esp + testl %eax,%eax + je .L285 + movl -16(%ebp),%edi + pushl %edi + call cgeti + movl %eax,-60(%ebp) + movl 12(%ebp),%ecx + movl 8(%ecx),%ebx + movl %ecx,%edx + addl $12,%edx + movl $32,%eax + subl -28(%ebp),%eax + movl %ebx,%edi + movl %eax,%ecx + shrl %cl,%edi + movl %edi,-4(%ebp) + movl -28(%ebp),%ecx + sall %cl,%ebx + movl %ebx,-32(%ebp) + movl -60(%ebp),%eax + addl $8,%eax + addl $4,%esp + movl -16(%ebp),%edi + addl $-3,%edi + movl %edi,-24(%ebp) + je .L287 + movl $32,%edi + subl %ecx,%edi + movl %edi,-88(%ebp) + .align 4 +.L288: + movl (%edx),%ebx + addl $4,%edx + movl %ebx,%edi + movl -88(%ebp),%ecx + shrl %cl,%edi + movl %edi,-4(%ebp) + movl -32(%ebp),%ecx + addl %edi,%ecx + movl %ecx,(%eax) + addl $4,%eax + movl -28(%ebp),%ecx + sall %cl,%ebx + movl %ebx,-32(%ebp) + decl -24(%ebp) + jne .L288 +.L287: + movl -32(%ebp),%edi + movl %edi,(%eax) + movl $0,-32(%ebp) + addl $8,%esi + movl %esi,-88(%ebp) + movl -56(%ebp),%ecx + addl $4,%ecx + movl %ecx,-72(%ebp) + movl -12(%ebp),%edi + addl $-2,%edi + movl %edi,-24(%ebp) + je .L291 + movl $32,%eax + subl -28(%ebp),%eax + .align 4 +.L292: + movl -88(%ebp),%ecx + movl (%ecx),%ebx + addl $4,%ecx + movl %ecx,-88(%ebp) + movl %ebx,%edi + movl %eax,%ecx + shrl %cl,%edi + movl %edi,-4(%ebp) + movl -32(%ebp),%ecx + addl -4(%ebp),%ecx + movl -72(%ebp),%edi + movl %ecx,(%edi) + addl $4,%edi + movl %edi,-72(%ebp) + movl -28(%ebp),%ecx + sall %cl,%ebx + movl %ebx,-32(%ebp) + decl -24(%ebp) + jne .L292 +.L291: + movl -32(%ebp),%ecx + movl -72(%ebp),%edi + movl %ecx,(%edi) + jmp .L294 + .align 16 +.L285: + addl $8,%esi + movl %esi,-88(%ebp) + movl -56(%ebp),%edi + movl $0,4(%edi) + addl $8,%edi + movl %edi,-72(%ebp) + movl -12(%ebp),%esi + addl $-2,%esi + je .L296 + .align 4 +.L297: + movl -88(%ebp),%ecx + movl (%ecx),%eax + movl -72(%ebp),%edi + movl %eax,(%edi) + addl $4,%ecx + movl %ecx,-88(%ebp) + addl $4,%edi + movl %edi,-72(%ebp) + decl %esi + jne .L297 +.L296: + movl 12(%ebp),%ecx + movl %ecx,-60(%ebp) +.L294: + movl -60(%ebp),%edi + movl 8(%edi),%edi + movl %edi,-48(%ebp) + movl -60(%ebp),%ecx + movl 12(%ecx),%ecx + movl %ecx,-44(%ebp) + movl -56(%ebp),%edi + addl $4,%edi + movl %edi,-72(%ebp) + movl -20(%ebp),%ecx + incl %ecx + movl %ecx,-24(%ebp) + je .L300 + movl -16(%ebp),%edi + sall $2,%edi + movl %edi,-80(%ebp) + .align 4 +.L301: + movl -72(%ebp),%ecx + movl (%ecx),%eax + addl $4,%ecx + movl %ecx,-72(%ebp) + cmpl %eax,-48(%ebp) + jne .L302 + movl $-1,-52(%ebp) + movl -48(%ebp),%ebx + movl %ebx,%edi + addl (%ecx),%edi + movl %edi,-84(%ebp) + cmpl %ebx,%edi + setb %al + andl $255,%eax + movl %edi,-32(%ebp) + jmp .L303 + .align 16 +.L302: + movl -72(%ebp),%ecx + movl -4(%ecx),%eax + movl %eax,-4(%ebp) + leal -4(%ebp),%eax + pushl %eax + movl -48(%ebp),%edi + pushl %edi + movl (%ecx),%eax + pushl %eax + call divul3 + movl %eax,-52(%ebp) + xorl %eax,%eax + movl -4(%ebp),%ecx + movl %ecx,-32(%ebp) + addl $12,%esp +.L303: + testl %eax,%eax + jne .L304 + leal -4(%ebp),%eax + pushl %eax + movl -44(%ebp),%edi + pushl %edi + movl -52(%ebp),%ecx + pushl %ecx + call mulul3 + movl %eax,%ebx + movl -72(%ebp),%edi + movl 4(%edi),%edx + addl $12,%esp + cmpl %edx,%ebx + setb %al + andl $255,%eax + movl %ebx,%esi + subl %edx,%esi + movl -4(%ebp),%ebx + movl -32(%ebp),%edx + movl %ebx,%ecx + subl %edx,%ecx + subl %eax,%ecx + movl %ecx,-84(%ebp) + cmpl %ebx,%edx + ja .L373 + jmp .L313 + .align 16 + .align 4 +.L317: + cmpl $0,-88(%ebp) + je .L304 + decl -52(%ebp) + movl %esi,%ebx + movl -44(%ebp),%edx + cmpl %edx,%ebx + setb %al + andl $255,%eax + subl %edx,%esi + movl -88(%ebp),%ebx + movl -48(%ebp),%edx + movl %ebx,%ecx + subl %edx,%ecx + subl %eax,%ecx + movl %ecx,-84(%ebp) + cmpl %ebx,%edx + jbe .L313 +.L373: + movl $1,%eax + jmp .L314 + .align 16 +.L313: + cmpl %ebx,%edx + jae .L314 + xorl %eax,%eax +.L314: + movl -84(%ebp),%edi + movl %edi,-88(%ebp) + testl %eax,%eax + je .L317 +.L304: + movl $0,-4(%ebp) + movl -72(%ebp),%ecx + movl -80(%ebp),%edi + leal -8(%edi,%ecx),%ecx + movl %ecx,-88(%ebp) + movl -60(%ebp),%ecx + addl %edi,%ecx + movl %ecx,-76(%ebp) + movl -16(%ebp),%esi + addl $-2,%esi + je .L319 + .align 4 +.L320: + movl -4(%ebp),%ebx + leal -4(%ebp),%eax + pushl %eax + addl $-4,-76(%ebp) + movl -76(%ebp),%edi + movl (%edi),%eax + pushl %eax + movl -52(%ebp),%ecx + pushl %ecx + call mulul3 + movl %eax,-84(%ebp) + addl %ebx,-84(%ebp) + addl $12,%esp + cmpl %ebx,-84(%ebp) + jae .L322 + incl -4(%ebp) +.L322: + movl -84(%ebp),%edx + addl $-4,-88(%ebp) + movl -88(%ebp),%edi + movl (%edi),%ebx + cmpl %edx,%ebx + setb %al + andl $255,%eax + subl %edx,%ebx + movl %ebx,(%edi) + addl %eax,-4(%ebp) + decl %esi + jne .L320 +.L319: + movl -72(%ebp),%ecx + movl -4(%ecx),%eax + cmpl %eax,-4(%ebp) + jbe .L324 + xorl %eax,%eax + decl -52(%ebp) + movl -80(%ebp),%edi + leal -8(%edi,%ecx),%edi + movl %edi,-88(%ebp) + movl -60(%ebp),%ecx + addl -80(%ebp),%ecx + movl %ecx,-76(%ebp) + movl -16(%ebp),%esi + addl $-2,%esi + je .L324 + .align 4 +.L327: + movl -88(%ebp),%edx + addl $-4,%edx + movl %edx,-88(%ebp) + movl (%edx),%ebx + addl $-4,-76(%ebp) + movl %ebx,%ecx + movl -76(%ebp),%edi + addl (%edi),%ecx + movl %ecx,-84(%ebp) + cmpl %ebx,%ecx + jae .L328 + addl %eax,%ecx + movl %ecx,-84(%ebp) + movl $1,%eax + movl %ecx,(%edx) + jmp .L325 + .align 16 +.L328: + addl %eax,-84(%ebp) + cmpl %eax,-84(%ebp) + setb %al + andl $255,%eax + movl -84(%ebp),%edi + movl %edi,(%edx) +.L325: + decl %esi + jne .L327 +.L324: + movl -52(%ebp),%edi + movl -72(%ebp),%ecx + movl %edi,-4(%ecx) + decl -24(%ebp) + jne .L301 +.L300: + movl avma,%ecx + movl %ecx,-88(%ebp) + cmpl $-1,16(%ebp) + je .L332 + movl -20(%ebp),%ebx + addl $2,%ebx + movl -56(%ebp),%edi + leal (%edi,%ebx,4),%edi + movl %edi,-72(%ebp) + movl -56(%ebp),%ecx + cmpl $0,4(%ecx) + je .L333 + movl -20(%ebp),%ebx + addl $3,%ebx + jmp .L334 + .align 16 +.L333: + cmpl $0,-20(%ebp) + jne .L334 + movl $0,-40(%ebp) +.L334: + pushl %ebx + call cgeti + movl %eax,-64(%ebp) + leal (%eax,%ebx,4),%edx + addl $4,%esp + leal -2(%ebx),%esi + testl %esi,%esi + je .L337 + .align 4 +.L338: + addl $-4,%edx + addl $-4,-72(%ebp) + movl -72(%ebp),%edi + movl (%edi),%eax + movl %eax,(%edx) + decl %esi + jne .L338 +.L337: + cmpl $2,%ebx + ja .L340 + movl -64(%ebp),%ecx + movl $2,4(%ecx) + jmp .L332 + .align 16 +.L340: + movl -64(%ebp),%edi + movl (%edi),%eax + movl %eax,4(%edi) + movb -40(%ebp),%cl + movb %cl,7(%edi) +.L332: + cmpl $0,16(%ebp) + je .L342 + movl -20(%ebp),%esi + addl $2,%esi + cmpl %esi,-12(%ebp) + jle .L344 + movl -56(%ebp),%edi + cmpl $0,(%edi,%esi,4) + jne .L344 + movl -20(%ebp),%esi + addl $3,%esi + cmpl %esi,-12(%ebp) + jle .L344 + cmpl $0,(%edi,%esi,4) + jne .L344 + .align 4 +.L345: + incl %esi + cmpl %esi,-12(%ebp) + jle .L344 + movl -56(%ebp),%ecx + cmpl $0,(%ecx,%esi,4) + je .L345 +.L344: + cmpl %esi,-12(%ebp) + jne .L349 + movl gzero,%eax + pushl %eax + call icopy + movl %eax,-68(%ebp) + addl $4,%esp + jmp .L342 + .align 16 +.L349: + movl -12(%ebp),%eax + subl %esi,%eax + addl $2,%eax + pushl %eax + call cgeti + movl %eax,-68(%ebp) + movl (%eax),%eax + movl -68(%ebp),%edi + movl %eax,4(%edi) + addl $4,%esp + cmpl $0,-28(%ebp) + jne .L351 + movl $2,-24(%ebp) + cmpl %esi,-12(%ebp) + jle .L357 + .align 4 +.L355: + movl -56(%ebp),%ecx + movl (%ecx,%esi,4),%eax + movl -24(%ebp),%edi + movl -68(%ebp),%ecx + movl %eax,(%ecx,%edi,4) + incl %esi + incl %edi + movl %edi,-24(%ebp) + cmpl %esi,-12(%ebp) + jg .L355 + jmp .L357 + .align 16 +.L351: + movl $0,-4(%ebp) + movl -56(%ebp),%edi + movl (%edi,%esi,4),%ebx + incl %esi + movl $32,%eax + subl -28(%ebp),%eax + movl %ebx,%edi + movl %eax,%ecx + sall %cl,%edi + movl %edi,%eax + movl %eax,-4(%ebp) + movl %ebx,%edx + movl -28(%ebp),%ecx + shrl %cl,%edx + movl %eax,-32(%ebp) + testl %edx,%edx + je .L358 + movl -68(%ebp),%edi + movl %edx,8(%edi) + movl $1,%eax + jmp .L359 + .align 16 +.L358: + movl -68(%ebp),%ecx + movl (%ecx),%edi + decl %edi + movl %edi,4(%ecx) + addl $4,%ecx + movl %ecx,-68(%ebp) + addl $4,avma + movl (%ecx),%eax + movl %eax,4(%ecx) + xorl %eax,%eax +.L359: + addl $2,%eax + movl %eax,-24(%ebp) + cmpl %esi,-12(%ebp) + jle .L357 + movl $32,%ecx + subl -28(%ebp),%ecx + movl %ecx,-84(%ebp) + .align 4 +.L363: + movl -56(%ebp),%edi + movl (%edi,%esi,4),%ebx + movl %ebx,%edx + movl -84(%ebp),%ecx + sall %cl,%edx + movl %edx,-4(%ebp) + movl %ebx,%eax + movl -28(%ebp),%ecx + shrl %cl,%eax + addl -32(%ebp),%eax + movl -24(%ebp),%edi + movl -68(%ebp),%ecx + movl %eax,(%ecx,%edi,4) + movl %edx,-32(%ebp) + incl %esi + incl %edi + movl %edi,-24(%ebp) + cmpl %esi,-12(%ebp) + jg .L363 +.L357: + movb -36(%ebp),%cl + movl -68(%ebp),%edi + movb %cl,7(%edi) +.L342: + cmpl $-1,16(%ebp) + jne .L365 + movl -68(%ebp),%ecx + pushl %ecx + movl -88(%ebp),%edi + pushl %edi + movl -8(%ebp),%ecx + pushl %ecx + jmp .L371 + .align 16 +.L365: + cmpl $0,16(%ebp) + je .L366 + pushl $0 + movl -88(%ebp),%edi + pushl %edi + movl -8(%ebp),%ecx + pushl %ecx + call gerepile + andb $252,%al + movl -68(%ebp),%ecx + addl %eax,%ecx + movl 16(%ebp),%edi + movl %ecx,(%edi) + addl -64(%ebp),%eax + jmp .L367 + .align 16 +.L366: + movl -64(%ebp),%edi + pushl %edi + movl -88(%ebp),%ecx + pushl %ecx + movl -8(%ebp),%edi + pushl %edi +.L371: + call gerepile +.L367: + leal -100(%ebp),%esp + popl %ebx + popl %esi + popl %edi + movl %ebp,%esp + popl %ebp + ret +.Lfe13: + .size dvmdii,.Lfe13-dvmdii + .ident "GCC: (GNU) 2.7.2.1" diff --git a/mp/mpi-386d.S b/mp/mpi-386d.S new file mode 100755 index 0000000..5985053 --- /dev/null +++ b/mp/mpi-386d.S @@ -0,0 +1,2323 @@ +# 1 "../mp/mpi-386d.S" + + +# 11 "../mp/mpi-386d.S" + + + + + + + + + + + +# 30 "../mp/mpi-386d.S" + + + + + + + + + + + + + + + + + + .file "mpi.c" +gcc2_compiled.: +___gnu_compiled_c: +.text + .align 4 +.globl _mulsi ; .align 4,0x90 ; _mulsi: + pushl %ebp + movl %esp,%ebp + subl $20,%esp + pushl %edi + pushl %esi + pushl %ebx + movl 12(%ebp),%ebx + movl 4(%ebx),%ecx + sarl $24,%ecx + movl %ecx,-8(%ebp) + movzwl 4(%ebx),%edx + movl %edx,-12(%ebp) + cmpl $0,8(%ebp) + je L3 + testl %ecx,%ecx + jne L2 +L3: + movl _gzero ,%eax + jmp L13 + .align 4,0x90 +L2: + cmpl $0,8(%ebp) + jge L4 + negl -8(%ebp) + negl 8(%ebp) + jns L4 + pushl %ebx + pushl $-2147483648 + call _stoi + addl $4,%esp + pushl %eax + call _mulii + jmp L13 + .align 4,0x90 +L4: + movl -12(%ebp),%eax + incl %eax + pushl %eax + call _cgeti + movl %eax,-16(%ebp) + movl $0,-4(%ebp) + movl -12(%ebp),%ecx + leal 0(,%ecx,4),%eax + addl %eax,%ebx + movl %ebx,-20(%ebp) + movl -16(%ebp),%edx + leal 4(%eax,%edx),%esi + addl $4,%esp + movl %ecx,%edi + addl $-2,%edi + je L7 + .align 2,0x90 +L10: + addl $-4,%esi + movl -4(%ebp),%ebx + leal -4(%ebp),%eax + pushl %eax + addl $-4,-20(%ebp) + movl -20(%ebp),%ecx + movl (%ecx),%ecx + pushl %ecx + movl 8(%ebp),%edx + pushl %edx + call _mulul3 + addl %ebx,%eax + cmpl %ebx,%eax + jae L9 + incl -4(%ebp) +L9: + movl %eax,(%esi) + addl $12,%esp + decl %edi + jne L10 +L7: + cmpl $0,-4(%ebp) + je L11 + movl -4(%ebp),%ecx + movl %ecx,-4(%esi) + movl -16(%ebp),%edx + movl 4(%edx),%eax + andl $-65536,%eax + movl -12(%ebp),%ecx + leal 1(%ecx,%eax),%eax + movl %eax,4(%edx) + jmp L12 + .align 4,0x90 +L11: + addl $4,_avma + movl -16(%ebp),%edx + movl (%edx),%ecx + decl %ecx + movl %ecx,4(%edx) + addl $4,%edx + movl %edx,-16(%ebp) + movw -12(%ebp),%cx + movw %cx,4(%edx) +L12: + movb -8(%ebp),%dl + movl -16(%ebp),%ecx + movb %dl,7(%ecx) + movl -16(%ebp),%eax +L13: + leal -32(%ebp),%esp + popl %ebx + popl %esi + popl %edi + movl %ebp,%esp + popl %ebp + ret + .align 4 +.globl _expi ; .align 4,0x90 ; _expi: + pushl %ebp + movl %esp,%ebp + pushl %ebx + movl 8(%ebp),%eax + movzwl 4(%eax),%ebx + cmpl $2,%ebx + je L15 + movl 8(%eax),%eax + pushl %eax + call _bfffo + leal -2(%ebx),%edx + sall $5,%edx + subl %eax,%edx + decl %edx + jmp L16 + .align 4,0x90 +L15: + movl $-8388608,%edx +L16: + movl %edx,%eax + movl -4(%ebp),%ebx + movl %ebp,%esp + popl %ebp + ret + .align 4 +.globl _addsi ; .align 4,0x90 ; _addsi: + pushl %ebp + movl %esp,%ebp + subl $12,%esp + pushl %edi + pushl %esi + pushl %ebx + movl 8(%ebp),%esi + movl 12(%ebp),%edi + testl %esi,%esi + jne L18 + pushl %edi + call _icopy + jmp L60 + .align 4,0x90 +L18: + movl 4(%edi),%ebx + sarl $24,%ebx + movl %ebx,-8(%ebp) + jne L19 + pushl %esi + call _stoi + jmp L60 + .align 4,0x90 +L19: + testl %esi,%esi + jge L20 + movl $-1,-4(%ebp) + negl %esi + jns L22 + pushl %edi + pushl $ _MOST_NEGS + call _addii + jmp L60 + .align 4,0x90 +L20: + movl $1,-4(%ebp) +L22: + movzwl 4(%edi),%ebx + movl %ebx,-12(%ebp) + movl -8(%ebp),%ebx + cmpl %ebx,-4(%ebp) + jne L23 + movl %esi,%edx + movl %edx,%eax + movl -12(%ebp),%ebx + addl -4(%edi,%ebx,4),%eax + movl %eax,%esi + cmpl %edx,%eax + jae L24 + movl %ebx,%eax + incl %eax + pushl %eax + call _cgeti + movl %eax,%ecx + movl %esi,(%ecx,%ebx,4) + movl %ebx,%edx + jmp L61 + .align 4,0x90 + .align 2,0x90 +L28: + movl $0,(%ecx,%edx,4) +L61: + decl %edx + cmpl $2,%edx + jle L29 + cmpl $-1,-4(%edi,%edx,4) + je L28 + cmpl $2,%edx + jle L29 + movl -4(%edi,%edx,4),%ebx + incl %ebx + jmp L62 + .align 4,0x90 + .align 2,0x90 +L32: + movl -4(%edi,%edx,4),%ebx +L62: + movl %ebx,(%ecx,%edx,4) + decl %edx + cmpl $2,%edx + jg L32 + movl (%ecx),%eax + decl %eax + movl %eax,4(%ecx) + movl %eax,8(%ecx) + addl $4,%ecx + addl $4,_avma + jmp L34 + .align 4,0x90 +L29: + movl $1,8(%ecx) + movl (%ecx),%ebx + movl %ebx,4(%ecx) + jmp L34 + .align 4,0x90 +L24: + movl -12(%ebp),%ebx + pushl %ebx + call _cgeti + movl %eax,%ecx + movl %esi,-4(%ecx,%ebx,4) + movl $1,%edx + movl %ebx,%eax + decl %eax + movl %eax,%esi + cmpl %eax,%edx + jge L34 + .align 2,0x90 +L38: + movl (%edi,%edx,4),%ebx + movl %ebx,(%ecx,%edx,4) + incl %edx + cmpl %esi,%edx + jl L38 +L34: + movb -4(%ebp),%bl + movb %bl,7(%ecx) + jmp L39 + .align 4,0x90 +L23: + cmpl $3,-12(%ebp) + jne L40 + cmpl %esi,8(%edi) + jbe L41 + pushl $3 + call _cgeti + movl %eax,%ecx + movl -8(%ebp),%eax + sall $24,%eax + addl $3,%eax + movl %eax,4(%ecx) + movl 8(%edi),%edi + subl %esi,%edi + movl %edi,8(%ecx) + jmp L39 + .align 4,0x90 +L41: + cmpl %esi,8(%edi) + jne L42 + movl _gzero ,%eax + jmp L60 + .align 4,0x90 +L42: + pushl $3 + call _cgeti + movl %eax,%ecx + movl -8(%ebp),%eax + negl %eax + sall $24,%eax + addl $3,%eax + movl %eax,4(%ecx) + subl 8(%edi),%esi + movl %esi,8(%ecx) + jmp L39 + .align 4,0x90 +L40: + movl -12(%ebp),%ebx + movl -4(%edi,%ebx,4),%edx + movl %esi,%eax + movl %edx,%esi + subl %eax,%esi + cmpl %eax,%edx + jae L43 + pushl %ebx + call _cgeti + movl %eax,%ecx + movl %esi,-4(%ecx,%ebx,4) + movl %ebx,%edx + addl $-2,%edx + cmpl $0,(%edi,%edx,4) + jne L45 + .align 2,0x90 +L47: + movl $-1,(%ecx,%edx,4) + decl %edx + cmpl $0,(%edi,%edx,4) + je L47 +L45: + movl (%edi,%edx,4),%eax + decl %eax + movl %eax,(%ecx,%edx,4) + cmpl $2,%edx + jg L49 + testl %eax,%eax + je L48 +L49: + decl %edx + testl %edx,%edx + jle L39 + .align 2,0x90 +L53: + movl (%edi,%edx,4),%ebx + movl %ebx,(%ecx,%edx,4) + decl %edx + testl %edx,%edx + jg L53 + jmp L39 + .align 4,0x90 +L48: + movl (%ecx),%eax + decl %eax + movl %eax,4(%ecx) + movl %eax,8(%ecx) + addl $4,%ecx + addl $4,_avma + movb -8(%ebp),%bl + movb %bl,7(%ecx) + jmp L39 + .align 4,0x90 +L43: + movl -12(%ebp),%ebx + pushl %ebx + call _cgeti + movl %eax,%ecx + movl %esi,-4(%ecx,%ebx,4) + movl $1,%edx + movl %ebx,%eax + decl %eax + movl %eax,%esi + cmpl %eax,%edx + jge L39 + .align 2,0x90 +L59: + movl (%edi,%edx,4),%ebx + movl %ebx,(%ecx,%edx,4) + incl %edx + cmpl %esi,%edx + jl L59 +L39: + movl %ecx,%eax +L60: + leal -24(%ebp),%esp + popl %ebx + popl %esi + popl %edi + movl %ebp,%esp + popl %ebp + ret + .align 4 +.globl _addii ; .align 4,0x90 ; _addii: + pushl %ebp + movl %esp,%ebp + subl $32,%esp + pushl %edi + pushl %esi + pushl %ebx + movl 12(%ebp),%edi + movl 8(%ebp),%edx + movzwl 4(%edx),%edx + movl %edx,-8(%ebp) + movzwl 4(%edi),%ecx + movl %ecx,-12(%ebp) + cmpl %ecx,%edx + jge L64 + movl 8(%ebp),%edx + movl %edx,-16(%ebp) + movl %edi,8(%ebp) + movl -16(%ebp),%edi + movl -8(%ebp),%ecx + movl %ecx,-4(%ebp) + movl -12(%ebp),%edx + movl %edx,-8(%ebp) + movl %ecx,-12(%ebp) +L64: + movl 4(%edi),%esi + sarl $24,%esi + jne L65 + movl 8(%ebp),%ecx + pushl %ecx + call _icopy + jmp L119 + .align 4,0x90 +L65: + movl 8(%ebp),%edx + movl 4(%edx),%ecx + sarl $24,%ecx + movl %ecx,-4(%ebp) + cmpl %esi,%ecx + jne L66 + movl -8(%ebp),%eax + incl %eax + pushl %eax + call _cgeti + movl %eax,-16(%ebp) + movl $0,-24(%ebp) + movl -8(%ebp),%edx + leal 0(,%edx,4),%eax + movl -16(%ebp),%ecx + leal 4(%eax,%ecx),%esi + movl 8(%ebp),%ebx + addl %eax,%ebx + movl -12(%ebp),%edx + leal (%edi,%edx,4),%edi + movl %edi,-20(%ebp) + movl %edx,%edi + addl $-2,%edi + je L68 + .align 2,0x90 +L71: + addl $-4,%esi + addl $-4,%ebx + movl (%ebx),%ecx + movl %ecx,-28(%ebp) + addl $-4,-20(%ebp) + movl -20(%ebp),%edx + addl (%edx),%ecx + movl %ecx,-32(%ebp) + movl -28(%ebp),%edx + cmpl %edx,%ecx + jae L69 + movl -24(%ebp),%edx + addl %edx,%ecx + movl %ecx,-32(%ebp) + movl $1,-24(%ebp) + movl %ecx,(%esi) + jmp L67 + .align 4,0x90 +L69: + movl -24(%ebp),%ecx + addl %ecx,-32(%ebp) + cmpl %ecx,-32(%ebp) + setb %al + andl $255,%eax + movl %eax,-24(%ebp) + movl -32(%ebp),%edx + movl %edx,(%esi) +L67: + decl %edi + jne L71 +L68: + cmpl $0,-24(%ebp) + je L72 + movl 8(%ebp),%edi + addl $8,%edi +L73: + addl $-4,%ebx + movl %ebx,%eax + cmpl %edi,%ebx + jb L74 + cmpl $-1,(%ebx) + jne L75 + addl $-4,%esi + movl $0,(%esi) + jmp L73 + .align 4,0x90 +L75: + addl $-4,%esi + movl (%eax),%eax + incl %eax + jmp L121 + .align 4,0x90 + .align 2,0x90 +L79: + addl $-4,%esi + movl (%eax),%eax +L121: + movl %eax,(%esi) + addl $-4,%ebx + movl %ebx,%eax + cmpl %edi,%ebx + jae L79 + movl -16(%ebp),%ecx + movl (%ecx),%edx + decl %edx + movl %edx,4(%ecx) + movl 8(%ebp),%ecx + movl 4(%ecx),%edx + movl -16(%ebp),%ecx + movl %edx,8(%ecx) + addl $4,%ecx + movl %ecx,-16(%ebp) + addl $4,_avma + jmp L85 + .align 4,0x90 +L74: + movl -16(%ebp),%ecx + movl $1,8(%ecx) + movl 8(%ebp),%ecx + movl 4(%ecx),%edx + incl %edx + movl -16(%ebp),%ecx + movl %edx,4(%ecx) + jmp L85 + .align 4,0x90 +L72: + movl -8(%ebp),%eax + subl -12(%ebp),%eax + je L83 + .align 2,0x90 +L84: + addl $-4,%esi + addl $-4,%ebx + movl (%ebx),%ecx + movl %ecx,(%esi) + decl %eax + jne L84 +L83: + movl -16(%ebp),%edx + movl (%edx),%ecx + decl %ecx + movl %ecx,4(%edx) + movl 8(%ebp),%edx + movl 4(%edx),%ecx + movl -16(%ebp),%edx + movl %ecx,8(%edx) + addl $4,%edx + movl %edx,-16(%ebp) + addl $4,_avma + jmp L85 + .align 4,0x90 +L66: + movl -12(%ebp),%edx + cmpl %edx,-8(%ebp) + jne L86 + movl 8(%ebp),%ebx + addl $8,%ebx + leal 8(%edi),%ecx + movl %ecx,-20(%ebp) + movl -8(%ebp),%eax + addl $-2,%eax + je L94 + .align 2,0x90 +L93: + movl (%ebx),%edx + movl %edx,-28(%ebp) + addl $4,%ebx + movl -20(%ebp),%ecx + movl (%ecx),%ecx + movl %ecx,-32(%ebp) + addl $4,-20(%ebp) + cmpl %edx,%ecx + ja L120 + cmpl %ecx,%edx + ja L86 + decl %eax + jne L93 +L94: + movl _gzero ,%eax + jmp L119 + .align 4,0x90 +L120: + movl 8(%ebp),%edx + movl %edx,-16(%ebp) + movl %edi,8(%ebp) + movl -16(%ebp),%edi + movl %esi,-4(%ebp) +L86: + movl -8(%ebp),%ecx + pushl %ecx + call _cgeti + movl %eax,-16(%ebp) + movl $0,-24(%ebp) + movl -8(%ebp),%edx + leal 0(,%edx,4),%eax + movl 8(%ebp),%ebx + addl %eax,%ebx + movl -12(%ebp),%ecx + leal (%edi,%ecx,4),%edi + movl %edi,-20(%ebp) + movl -16(%ebp),%esi + addl %eax,%esi + movl %ecx,%edi + addl $-2,%edi + je L96 + .align 2,0x90 +L101: + addl $-4,%esi + addl $-4,%ebx + movl (%ebx),%edx + movl %edx,-28(%ebp) + addl $-4,-20(%ebp) + movl -20(%ebp),%ecx + movl (%ecx),%eax + subl %eax,%edx + movl -24(%ebp),%ecx + subl %ecx,%edx + movl %edx,-32(%ebp) + cmpl %eax,-28(%ebp) + jae L97 + movl $1,-24(%ebp) + jmp L98 + .align 4,0x90 +L97: + cmpl %eax,-28(%ebp) + jbe L98 + movl $0,-24(%ebp) +L98: + movl -32(%ebp),%edx + movl %edx,(%esi) + decl %edi + jne L101 +L96: + cmpl $0,-24(%ebp) + je L102 + jmp L122 + .align 4,0x90 + .align 2,0x90 +L105: + addl $-4,%esi + movl $-1,(%esi) +L122: + addl $-4,%ebx + movl (%ebx),%eax + testl %eax,%eax + je L105 + movl 8(%ebp),%edi + addl $8,%edi + cmpl %edi,%ebx + jb L110 + addl $-4,%esi + decl %eax + movl %eax,(%esi) + addl $-4,%ebx + movl %ebx,%eax + cmpl %edi,%ebx + jb L110 + .align 2,0x90 +L109: + addl $-4,%esi + movl (%eax),%eax + movl %eax,(%esi) + addl $-4,%ebx + movl %ebx,%eax + cmpl %edi,%ebx + jae L109 + jmp L110 + .align 4,0x90 +L102: + movl -8(%ebp),%edi + subl -12(%ebp),%edi + je L110 + .align 2,0x90 +L113: + addl $-4,%esi + addl $-4,%ebx + movl (%ebx),%ecx + movl %ecx,(%esi) + decl %edi + jne L113 +L110: + movl -16(%ebp),%edx + cmpl $0,8(%edx) + je L114 + movl 8(%ebp),%ecx + movl 4(%ecx),%ecx + movl %ecx,4(%edx) + jmp L85 + .align 4,0x90 +L114: + movl -16(%ebp),%esi + addl $12,%esi + movl -16(%ebp),%edx + cmpl $0,12(%edx) + jne L117 + .align 2,0x90 +L118: + addl $4,%esi + cmpl $0,(%esi) + je L118 +L117: + addl $-8,%esi + movl %esi,%edi + subl -16(%ebp),%edi + sarl $2,%edi + movl -16(%ebp),%ecx + movl (%ecx),%eax + subl %edi,%eax + movl %eax,(%esi) + movl %eax,4(%esi) + movl %esi,-16(%ebp) + movb -4(%ebp),%dl + movb %dl,7(%esi) + leal 0(,%edi,4),%eax + addl %eax,_avma +L85: + movl -16(%ebp),%eax +L119: + leal -44(%ebp),%esp + popl %ebx + popl %esi + popl %edi + movl %ebp,%esp + popl %ebp + ret + .align 4 +.globl _mulss ; .align 4,0x90 ; _mulss: + pushl %ebp + movl %esp,%ebp + subl $4,%esp + pushl %esi + pushl %ebx + movl 8(%ebp),%edx + movl 12(%ebp),%ebx + testl %edx,%edx + je L125 + testl %ebx,%ebx + jne L124 +L125: + movl _gzero ,%eax + jmp L133 + .align 4,0x90 +L124: + movl $1,%esi + testl %edx,%edx + jge L126 + movl $-1,%esi + negl %edx + jns L126 + pushl %edx + call _stoi + pushl %eax + pushl %ebx + call _mulsi + jmp L133 + .align 4,0x90 +L126: + testl %ebx,%ebx + jge L128 + negl %esi + negl %ebx + jns L128 + pushl $ _ABS_MOST_NEGS + movl %edx,%eax + testl %esi,%esi + jg L130 + negl %eax +L130: + pushl %eax + call _mulsi + jmp L133 + .align 4,0x90 +L128: + leal -4(%ebp),%eax + pushl %eax + pushl %ebx + pushl %edx + call _mulul3 + movl %eax,%ebx + addl $12,%esp + cmpl $0,-4(%ebp) + je L131 + pushl $4 + call _cgeti + movl -4(%ebp),%ecx + movl %ecx,8(%eax) + movl %ebx,12(%eax) + jmp L132 + .align 4,0x90 +L131: + pushl $3 + call _cgeti + movl %ebx,8(%eax) +L132: + movl (%eax),%ecx + movl %ecx,4(%eax) + movl %esi,%ecx + movb %cl,7(%eax) +L133: + leal -12(%ebp),%esp + popl %ebx + popl %esi + movl %ebp,%esp + popl %ebp + ret + .align 4 +.globl _mulii ; .align 4,0x90 ; _mulii: + pushl %ebp + movl %esp,%ebp + subl $48,%esp + pushl %edi + pushl %esi + pushl %ebx + movl 8(%ebp),%esi + movzwl 4(%esi),%edi + movl %edi,-8(%ebp) + movl 12(%ebp),%ecx + movzwl 4(%ecx),%ecx + movl %ecx,-12(%ebp) + movl 4(%esi),%ebx + sarl $24,%ebx + je L157 + movl 12(%ebp),%edi + movl 4(%edi),%eax + sarl $24,%eax + jne L136 +L157: + movl _gzero ,%eax + jmp L156 + .align 4,0x90 +L136: + testl %eax,%eax + jge L137 + negl %ebx +L137: + movl -12(%ebp),%ecx + cmpl %ecx,-8(%ebp) + jle L138 + movl %esi,-24(%ebp) + movl 12(%ebp),%esi + movl -24(%ebp),%edi + movl %edi,12(%ebp) + movl -8(%ebp),%ecx + movl %ecx,-16(%ebp) + movl -12(%ebp),%edi + movl %edi,-8(%ebp) + movl %ecx,-12(%ebp) +L138: + movl -8(%ebp),%ecx + movl -12(%ebp),%edi + leal -2(%edi,%ecx),%ecx + movl %ecx,-16(%ebp) + cmpl $65535,%ecx + jle L139 + pushl $17 + call _err + addl $4,%esp +L139: + movl -16(%ebp),%ecx + pushl %ecx + call _cgeti + movl %eax,-24(%ebp) + movl (%eax),%edi + movl %edi,4(%eax) + movb %bl,7(%eax) + movl -8(%ebp),%ecx + leal -4(%esi,%ecx,4),%esi + movl %esi,-32(%ebp) + movl (%esi),%edi + movl %edi,-20(%ebp) + movl $0,-4(%ebp) + movl -12(%ebp),%ecx + movl 12(%ebp),%edi + leal (%edi,%ecx,4),%ecx + movl %ecx,-48(%ebp) + movl -16(%ebp),%edi + leal (%eax,%edi,4),%edi + movl %edi,-28(%ebp) + addl $4,%esp + movl -12(%ebp),%esi + addl $-2,%esi + je L141 + .align 2,0x90 +L144: + addl $-4,-28(%ebp) + movl -4(%ebp),%ebx + leal -4(%ebp),%eax + pushl %eax + addl $-4,-48(%ebp) + movl -48(%ebp),%ecx + movl (%ecx),%ecx + pushl %ecx + movl -20(%ebp),%edi + pushl %edi + call _mulul3 + movl %eax,%edx + addl %ebx,%edx + cmpl %ebx,%edx + jae L143 + incl -4(%ebp) +L143: + movl -28(%ebp),%ecx + movl %edx,(%ecx) + addl $12,%esp + decl %esi + jne L144 +L141: + movl -4(%ebp),%ecx + movl -28(%ebp),%edi + movl %ecx,-4(%edi) + movl -16(%ebp),%edi + movl -24(%ebp),%ecx + leal (%ecx,%edi,4),%edi + movl %edi,-28(%ebp) + movl -12(%ebp),%ecx + movl 12(%ebp),%edi + leal (%edi,%ecx,4),%ecx + movl %ecx,-36(%ebp) + decl -12(%ebp) + addl $-3,-8(%ebp) + cmpl $0,-8(%ebp) + jle L146 + .align 2,0x90 +L154: + addl $-4,-32(%ebp) + movl -32(%ebp),%edi + movl (%edi),%edi + movl %edi,-44(%ebp) + movl -36(%ebp),%ecx + movl %ecx,-48(%ebp) + movl -28(%ebp),%ebx + addl $-4,%ebx + movl %ebx,-28(%ebp) + movl $0,-40(%ebp) + movl -12(%ebp),%esi + jmp L158 + .align 4,0x90 + .align 2,0x90 +L153: + addl $-4,-48(%ebp) + leal -4(%ebp),%eax + pushl %eax + movl -44(%ebp),%edi + pushl %edi + movl -48(%ebp),%ecx + movl (%ecx),%ecx + pushl %ecx + call _mulul3 + addl $-4,%ebx + movl %eax,%edx + addl (%ebx),%edx + cmpl %eax,%edx + jae L150 + incl -4(%ebp) +L150: + movl %edx,%eax + movl -40(%ebp),%edx + addl %eax,%edx + cmpl %eax,%edx + jae L152 + incl -4(%ebp) +L152: + movl %edx,(%ebx) + movl -4(%ebp),%edi + movl %edi,-40(%ebp) + addl $12,%esp +L158: + decl %esi + jne L153 + movl -4(%ebp),%ecx + movl %ecx,-4(%ebx) + decl -8(%ebp) + cmpl $0,-8(%ebp) + jg L154 +L146: + movl -24(%ebp),%edi + cmpl $0,8(%edi) + jne L155 + movl -24(%ebp),%edi + movl 4(%edi),%ecx + decl %ecx + movl %ecx,8(%edi) + movl -24(%ebp),%edi + movl (%edi),%ecx + decl %ecx + movl %ecx,4(%edi) + addl $4,%edi + movl %edi,-24(%ebp) + addl $4,_avma +L155: + movl -24(%ebp),%eax +L156: + leal -60(%ebp),%esp + popl %ebx + popl %esi + popl %edi + movl %ebp,%esp + popl %ebp + ret + .align 2 +LC0: + .long 0x55475a32,0x3fd34413 + .align 4 +.globl _confrac ; .align 4,0x90 ; _confrac: + pushl %ebp + movl %esp,%ebp + subl $68,%esp + pushl %edi + pushl %esi + pushl %ebx + movl 8(%ebp),%edx + movzwl (%edx),%edx + movl %edx,-16(%ebp) + movl 8(%ebp),%ecx + movl 4(%ecx),%eax + andl $16777215,%eax + movl $8388607,%edx + subl %eax,%edx + movl %edx,-20(%ebp) + movl _avma ,%ecx + movl %ecx,-24(%ebp) + movl -16(%ebp),%eax + sall $5,%eax + leal -64(%edx,%eax),%eax + movl %eax,-32(%ebp) + addl $63,%eax + sarl $5,%eax + movl %eax,-28(%ebp) + pushl %eax + call _cgeti + movl %eax,-44(%ebp) + movl -20(%ebp),%esi + sarl $5,%esi + xorl %ebx,%ebx + addl $4,%esp + cmpl %esi,%ebx + jge L161 + .align 2,0x90 +L163: + movl -44(%ebp),%edx + movl $0,(%edx,%ebx,4) + incl %ebx + cmpl %esi,%ebx + jl L163 +L161: + andl $31,-20(%ebp) + jne L164 + movl $2,%edi + cmpl %edi,-16(%ebp) + jle L169 + .align 2,0x90 +L168: + movl 8(%ebp),%ecx + movl (%ecx,%edi,4),%eax + movl -44(%ebp),%ecx + movl %eax,(%ecx,%ebx,4) + incl %ebx + incl %edi + cmpl %edi,-16(%ebp) + jg L168 + jmp L169 + .align 4,0x90 +L164: + movl $0,-40(%ebp) + movl $2,%edi + cmpl %edi,-16(%ebp) + jle L171 + movl $32,%edx + subl -20(%ebp),%edx + movl %edx,-52(%ebp) + .align 2,0x90 +L173: + movl %ebx,-64(%ebp) + movl 8(%ebp),%ecx + movl (%ecx,%edi,4),%esi + incl %ebx + movl %esi,%eax + movl -52(%ebp),%ecx + sall %cl,%eax + movl %eax,-68(%ebp) + movl %eax,-12(%ebp) + movl -20(%ebp),%ecx + shrl %cl,%esi + movl %esi,%ecx + addl -40(%ebp),%ecx + movl -64(%ebp),%eax + movl -44(%ebp),%edx + movl %ecx,(%edx,%eax,4) + movl -68(%ebp),%eax + movl %eax,-40(%ebp) + incl %edi + cmpl %edi,-16(%ebp) + jg L173 +L171: + movl -40(%ebp),%eax + movl -28(%ebp),%edx + movl -44(%ebp),%ecx + movl %eax,-8(%ecx,%edx,4) +L169: + movl -28(%ebp),%edx + movl -44(%ebp),%ecx + movl $0,-4(%ecx,%edx,4) + fldl LC0 + fimull -32(%ebp) + fld1 + faddp %st,%st(1) + fnstcw -4(%ebp) + movl -4(%ebp),%eax + movb $12,%ah + movl %eax,-8(%ebp) + fldcw -8(%ebp) + subl $4,%esp + fistpl (%esp) + popl %ebx + fldcw -4(%ebp) + leal 17(%ebx),%edx + movl %edx,-36(%ebp) + movl -36(%ebp),%eax + movl $9,%ecx + cltd + idivl %ecx + movl %eax,-36(%ebp) + pushl %eax + call _cgeti + movl %eax,-48(%ebp) + movl %ebx,(%eax) + movl $1,%edi + addl $4,%esp + cmpl %edi,-36(%ebp) + jle L175 + leal -12(%ebp),%eax + movl %eax,-56(%ebp) + .align 2,0x90 +L183: + movl $0,-12(%ebp) + movl -28(%ebp),%ebx + jmp L184 + .align 4,0x90 + .align 2,0x90 +L182: + movl -12(%ebp),%esi + movl -56(%ebp),%edx + pushl %edx + pushl $1000000000 + movl -44(%ebp),%ecx + movl (%ecx,%ebx,4),%ecx + pushl %ecx + call _mulul3 + movl %eax,-68(%ebp) + addl %esi,-68(%ebp) + cmpl %esi,-68(%ebp) + jae L181 + incl -12(%ebp) +L181: + movl -68(%ebp),%edx + movl -44(%ebp),%eax + movl %edx,(%eax,%ebx,4) + addl $12,%esp +L184: + decl %ebx + jns L182 + movl -12(%ebp),%eax + movl -48(%ebp),%ecx + movl %eax,(%ecx,%edi,4) + incl %edi + cmpl %edi,-36(%ebp) + jg L183 +L175: + movl -24(%ebp),%edx + movl %edx,_avma + movl -48(%ebp),%eax + leal -80(%ebp),%esp + popl %ebx + popl %esi + popl %edi + movl %ebp,%esp + popl %ebp + ret + .align 4 +.globl _divss ; .align 4,0x90 ; _divss: + pushl %ebp + movl %esp,%ebp + pushl %esi + pushl %ebx + movl 8(%ebp),%esi + movl 12(%ebp),%ebx + testl %ebx,%ebx + jne L186 + pushl $23 + call _err + addl $4,%esp +L186: + cmpl $-2147483648,%esi + jne L187 + pushl %ebx + pushl $-2147483648 + call _stoi + addl $4,%esp + pushl %eax + call _divis + jmp L192 + .align 4,0x90 +L187: + movl $0,_hiremainder + pushl $ _hiremainder + movl %ebx,%eax + testl %ebx,%ebx + jge L188 + negl %eax +L188: + pushl %eax + movl %esi,%eax + testl %esi,%esi + jge L189 + negl %eax +L189: + pushl %eax + call _divul3 + addl $12,%esp + testl %ebx,%ebx + jge L190 + negl _hiremainder + negl %eax +L190: + testl %esi,%esi + jge L191 + negl %eax +L191: + pushl %eax + call _stoi +L192: + leal -8(%ebp),%esp + popl %ebx + popl %esi + movl %ebp,%esp + popl %ebp + ret + .align 4 +.globl _modss ; .align 4,0x90 ; _modss: + pushl %ebp + movl %esp,%ebp + subl $4,%esp + pushl %esi + pushl %ebx + movl 8(%ebp),%esi + movl 12(%ebp),%ebx + testl %ebx,%ebx + jne L194 + pushl $38 + call _err + addl $4,%esp +L194: + cmpl $-2147483648,%esi + jne L195 + pushl %ebx + pushl $-2147483648 + call _stoi + addl $4,%esp + pushl %eax + call _modis + jmp L201 + .align 4,0x90 +L195: + movl $0,-4(%ebp) + leal -4(%ebp),%eax + pushl %eax + testl %ebx,%ebx + jge L196 + negl %ebx +L196: + pushl %ebx + movl %esi,%eax + testl %eax,%eax + jge L197 + negl %eax +L197: + pushl %eax + call _divul3 + addl $12,%esp + cmpl $0,-4(%ebp) + jne L198 + movl _gzero ,%eax + jmp L201 + .align 4,0x90 +L198: + cmpl $0,-4(%ebp) + jge L199 + movl %ebx,%eax + subl -4(%ebp),%eax + pushl %eax + jmp L202 + .align 4,0x90 +L199: + movl -4(%ebp),%edx + pushl %edx +L202: + call _stoi +L201: + leal -12(%ebp),%esp + popl %ebx + popl %esi + movl %ebp,%esp + popl %ebp + ret + .align 4 +.globl _resss ; .align 4,0x90 ; _resss: + pushl %ebp + movl %esp,%ebp + subl $4,%esp + pushl %ebx + movl 12(%ebp),%ebx + testl %ebx,%ebx + jne L204 + pushl $40 + call _err + addl $4,%esp +L204: + movl $0,-4(%ebp) + leal -4(%ebp),%eax + pushl %eax + movl %ebx,%eax + testl %ebx,%ebx + jge L205 + negl %eax +L205: + pushl %eax + movl 8(%ebp),%eax + testl %eax,%eax + jge L206 + negl %eax +L206: + pushl %eax + call _divul3 + testl %ebx,%ebx + jge L207 + movl -4(%ebp),%eax + negl %eax + pushl %eax + jmp L209 + .align 4,0x90 +L207: + movl -4(%ebp),%edx + pushl %edx +L209: + call _stoi + movl -8(%ebp),%ebx + movl %ebp,%esp + popl %ebp + ret + .align 4 +.globl _divsi ; .align 4,0x90 ; _divsi: + pushl %ebp + movl %esp,%ebp + pushl %edi + pushl %esi + pushl %ebx + movl 8(%ebp),%ebx + movl 12(%ebp),%esi + movzwl 4(%esi),%edi + cmpb $0,7(%esi) + jne L211 + pushl $24 + call _err + addl $4,%esp +L211: + testl %ebx,%ebx + je L213 + cmpl $3,%edi + jg L213 + cmpl $0,8(%esi) + jge L212 +L213: + movl %ebx,_hiremainder + movl _gzero ,%eax + jmp L218 + .align 4,0x90 +L212: + cmpl $-2147483648,%ebx + jne L214 + pushl $0 + pushl %esi + pushl $-2147483648 + call _stoi + addl $4,%esp + pushl %eax + call _dvmdii + jmp L218 + .align 4,0x90 +L214: + movl $0,_hiremainder + pushl $ _hiremainder + movl 8(%esi),%edx + pushl %edx + movl %ebx,%eax + testl %ebx,%ebx + jge L215 + negl %eax +L215: + pushl %eax + call _divul3 + addl $12,%esp + cmpl $0,4(%esi) + jge L216 + negl _hiremainder + negl %eax +L216: + testl %ebx,%ebx + jge L217 + negl %eax +L217: + pushl %eax + call _stoi +L218: + leal -12(%ebp),%esp + popl %ebx + popl %esi + popl %edi + movl %ebp,%esp + popl %ebp + ret + .align 4 +.globl _divis ; .align 4,0x90 ; _divis: + pushl %ebp + movl %esp,%ebp + subl $24,%esp + pushl %edi + pushl %esi + pushl %ebx + movl 12(%ebp),%edi + movl 8(%ebp),%edx + movl 4(%edx),%ecx + sarl $24,%ecx + movl %ecx,-8(%ebp) + movzwl 4(%edx),%edx + movl %edx,-12(%ebp) + testl %edi,%edi + jne L220 + pushl $26 + call _err + addl $4,%esp +L220: + cmpl $0,-8(%ebp) + jne L221 + movl $0,_hiremainder + movl _gzero ,%eax + jmp L234 + .align 4,0x90 +L221: + testl %edi,%edi + jge L222 + negl -8(%ebp) + negl %edi + jns L222 + pushl $0 + pushl %edi + call _stoi + addl $4,%esp + pushl %eax + movl 8(%ebp),%ecx + pushl %ecx + call _dvmdii + jmp L234 + .align 4,0x90 +L222: + movl 8(%ebp),%edx + cmpl %edi,8(%edx) + jae L224 + cmpl $3,-12(%ebp) + jne L225 + pushl %edx + call _itos + movl %eax,_hiremainder + movl _gzero ,%eax + jmp L234 + .align 4,0x90 +L225: + movl -12(%ebp),%eax + decl %eax + pushl %eax + call _cgeti + movl %eax,%esi + movl $1,-16(%ebp) + movl 8(%ebp),%ecx + movl 8(%ecx),%ecx + movl %ecx,-4(%ebp) + jmp L235 + .align 4,0x90 +L224: + movl -12(%ebp),%edx + pushl %edx + call _cgeti + movl %eax,%esi + movl $0,-16(%ebp) + movl $0,-4(%ebp) +L235: + addl $4,%esp + movl -16(%ebp),%ebx + addl $2,%ebx + cmpl %ebx,-12(%ebp) + jle L229 + leal -4(%ebp),%ecx + movl %ecx,-20(%ebp) + .align 2,0x90 +L231: + movl -20(%ebp),%edx + pushl %edx + pushl %edi + movl 8(%ebp),%ecx + movl (%ecx,%ebx,4),%ecx + pushl %ecx + call _divul3 + movl %ebx,%edx + subl -16(%ebp),%edx + movl %eax,(%esi,%edx,4) + addl $12,%esp + incl %ebx + cmpl %ebx,-12(%ebp) + jg L231 +L229: + movl (%esi),%ecx + movl %ecx,4(%esi) + movb -8(%ebp),%dl + movb %dl,7(%esi) + cmpl $0,-8(%ebp) + jge L232 + movl -4(%ebp),%ecx + negl %ecx + movl %ecx,_hiremainder + jmp L233 + .align 4,0x90 +L232: + movl -4(%ebp),%edx + movl %edx,_hiremainder +L233: + movl %esi,%eax +L234: + leal -36(%ebp),%esp + popl %ebx + popl %esi + popl %edi + movl %ebp,%esp + popl %ebp + ret + .align 4 +.globl _dvmdii ; .align 4,0x90 ; _dvmdii: + pushl %ebp + movl %esp,%ebp + subl $92,%esp + pushl %edi + pushl %esi + pushl %ebx + movl 8(%ebp),%esi + movl 4(%esi),%edx + sarl $24,%edx + movl %edx,-36(%ebp) + movl 12(%ebp),%ecx + movl 4(%ecx),%edi + sarl $24,%edi + movl %edi,-40(%ebp) + jne L237 + pushl $36 + call _err + addl $4,%esp +L237: + cmpl $0,-36(%ebp) + jne L238 + cmpl $-1,16(%ebp) + je L333 + cmpl $0,16(%ebp) + je L333 + movl _gzero ,%ecx + movl 16(%ebp),%edx + movl %ecx,(%edx) +L333: + movl _gzero ,%eax + jmp L328 + .align 4,0x90 +L238: + movzwl 4(%esi),%edi + movl %edi,-12(%ebp) + movl 12(%ebp),%edx + movzwl 4(%edx),%edx + movl %edx,-16(%ebp) + subl %edx,%edi + movl %edi,-20(%ebp) + jns L241 + cmpl $-1,16(%ebp) + jne L242 + pushl %esi + call _icopy + jmp L328 + .align 4,0x90 +L242: + cmpl $0,16(%ebp) + je L333 + pushl %esi + call _icopy + movl 16(%ebp),%ecx + movl %eax,(%ecx) + jmp L333 + .align 4,0x90 +L241: + movl _avma ,%edi + movl %edi,-8(%ebp) + cmpl $0,-36(%ebp) + jge L244 + negl -40(%ebp) +L244: + cmpl $3,-16(%ebp) + jne L245 + movl 12(%ebp),%edx + movl 8(%edx),%edx + movl %edx,-48(%ebp) + leal 8(%esi),%ecx + movl %ecx,-88(%ebp) + cmpl %edx,8(%esi) + jae L246 + movl -12(%ebp),%ebx + decl %ebx + movl 8(%esi),%edi + movl %edi,-4(%ebp) + addl $12,%esi + movl %esi,-88(%ebp) + jmp L247 + .align 4,0x90 +L246: + movl -12(%ebp),%ebx + movl $0,-4(%ebp) +L247: + pushl %ebx + call _cgeti + movl %eax,-56(%ebp) + movl %eax,%edx + addl $8,%edx + movl %edx,-72(%ebp) + addl $4,%esp + leal -2(%ebx),%ecx + movl %ecx,-24(%ebp) + testl %ecx,%ecx + je L249 + leal -4(%ebp),%esi + .align 2,0x90 +L250: + pushl %esi + movl -48(%ebp),%edi + pushl %edi + movl -88(%ebp),%edx + movl (%edx),%edx + pushl %edx + addl $4,-88(%ebp) + call _divul3 + movl -72(%ebp),%ecx + movl %eax,(%ecx) + addl $4,%ecx + movl %ecx,-72(%ebp) + addl $12,%esp + decl -24(%ebp) + jne L250 +L249: + cmpl $-1,16(%ebp) + jne L251 + movl -8(%ebp),%edi + movl %edi,_avma + cmpl $0,-4(%ebp) + je L333 + pushl $3 + call _cgeti + movl %eax,-60(%ebp) + movl -36(%ebp),%eax + sall $24,%eax + addl $3,%eax + movl -60(%ebp),%edx + movl %eax,4(%edx) + movl -4(%ebp),%ecx + movl %ecx,8(%edx) + movl -60(%ebp),%eax + jmp L328 + .align 4,0x90 +L251: + cmpl $2,%ebx + je L253 + movl -56(%ebp),%edi + movl (%edi),%edx + movl %edx,4(%edi) + movb -40(%ebp),%cl + movb %cl,7(%edi) + jmp L254 + .align 4,0x90 +L253: + movl -8(%ebp),%edi + movl %edi,_avma + movl _gzero ,%edx + movl %edx,-56(%ebp) +L254: + cmpl $0,16(%ebp) + jne L255 +L331: + movl -56(%ebp),%eax + jmp L328 + .align 4,0x90 +L255: + cmpl $0,-4(%ebp) + jne L256 + movl _gzero ,%edi + movl 16(%ebp),%ecx + movl %edi,(%ecx) + jmp L331 + .align 4,0x90 +L256: + pushl $3 + call _cgeti + movl %eax,-60(%ebp) + movl -36(%ebp),%eax + sall $24,%eax + addl $3,%eax + movl -60(%ebp),%edx + movl %eax,4(%edx) + movl -4(%ebp),%ecx + movl %ecx,8(%edx) + movl 16(%ebp),%edi + movl %edx,(%edi) + jmp L331 + .align 4,0x90 +L245: + movl -12(%ebp),%edx + pushl %edx + call _cgeti + movl %eax,-56(%ebp) + movl 12(%ebp),%ecx + movl 8(%ecx),%ecx + pushl %ecx + call _bfffo + movl %eax,-28(%ebp) + addl $8,%esp + testl %eax,%eax + je L259 + movl -16(%ebp),%edi + pushl %edi + call _cgeti + movl %eax,-60(%ebp) + movl 12(%ebp),%edx + movl 8(%edx),%ebx + addl $12,%edx + movl %edx,-92(%ebp) + movl $32,%eax + subl -28(%ebp),%eax + movl %ebx,%edi + movl %eax,%ecx + shrl %cl,%edi + movl %edi,-4(%ebp) + movl -28(%ebp),%ecx + sall %cl,%ebx + movl %ebx,-32(%ebp) + movl -60(%ebp),%eax + addl $8,%eax + addl $4,%esp + movl -16(%ebp),%edi + addl $-3,%edi + movl %edi,-24(%ebp) + je L261 + movl $32,%edx + subl %ecx,%edx + movl %edx,-88(%ebp) + .align 2,0x90 +L262: + movl -92(%ebp),%ecx + movl (%ecx),%ebx + addl $4,%ecx + movl %ecx,-92(%ebp) + movl %ebx,%edi + movl -88(%ebp),%ecx + shrl %cl,%edi + movl %edi,-4(%ebp) + movl -32(%ebp),%edx + addl %edi,%edx + movl %edx,(%eax) + addl $4,%eax + movl -28(%ebp),%ecx + sall %cl,%ebx + movl %ebx,-32(%ebp) + decl -24(%ebp) + jne L262 +L261: + movl -32(%ebp),%edi + movl %edi,(%eax) + movl $0,-32(%ebp) + addl $8,%esi + movl %esi,-88(%ebp) + movl -56(%ebp),%edx + addl $4,%edx + movl %edx,-72(%ebp) + movl -12(%ebp),%ecx + addl $-2,%ecx + movl %ecx,-24(%ebp) + je L264 + movl $32,%eax + subl -28(%ebp),%eax + .align 2,0x90 +L265: + movl -88(%ebp),%edi + movl (%edi),%ebx + addl $4,%edi + movl %edi,-88(%ebp) + movl %ebx,%edi + movl %eax,%ecx + shrl %cl,%edi + movl %edi,-4(%ebp) + movl -32(%ebp),%ecx + addl %edi,%ecx + movl -72(%ebp),%edx + movl %ecx,(%edx) + addl $4,%edx + movl %edx,-72(%ebp) + movl -28(%ebp),%ecx + sall %cl,%ebx + movl %ebx,-32(%ebp) + decl -24(%ebp) + jne L265 +L264: + movl -32(%ebp),%edx + movl -72(%ebp),%edi + movl %edx,(%edi) + jmp L266 + .align 4,0x90 +L259: + addl $8,%esi + movl %esi,-88(%ebp) + movl -56(%ebp),%ecx + movl $0,4(%ecx) + addl $8,%ecx + movl %ecx,-72(%ebp) + movl -12(%ebp),%esi + addl $-2,%esi + je L268 + .align 2,0x90 +L269: + movl -88(%ebp),%edi + movl (%edi),%edx + movl -72(%ebp),%edi + movl %edx,(%edi) + addl $4,-88(%ebp) + addl $4,%edi + movl %edi,-72(%ebp) + decl %esi + jne L269 +L268: + movl 12(%ebp),%ecx + movl %ecx,-60(%ebp) +L266: + movl -60(%ebp),%edi + movl 8(%edi),%edi + movl %edi,-48(%ebp) + movl -60(%ebp),%edx + movl 12(%edx),%edx + movl %edx,-44(%ebp) + movl -56(%ebp),%ecx + addl $4,%ecx + movl %ecx,-72(%ebp) + movl -20(%ebp),%edi + incl %edi + movl %edi,-24(%ebp) + je L271 + movl -16(%ebp),%edx + sall $2,%edx + movl %edx,-80(%ebp) + .align 2,0x90 +L297: + movl -72(%ebp),%ecx + movl (%ecx),%eax + addl $4,%ecx + movl %ecx,-72(%ebp) + cmpl %eax,-48(%ebp) + jne L272 + movl $-1,-52(%ebp) + movl -48(%ebp),%ebx + movl %ebx,%edi + addl (%ecx),%edi + movl %edi,-84(%ebp) + cmpl %ebx,%edi + setb %al + andl $255,%eax + movl %edi,-32(%ebp) + jmp L273 + .align 4,0x90 +L272: + movl -72(%ebp),%edx + movl -4(%edx),%edx + movl %edx,-4(%ebp) + leal -4(%ebp),%eax + pushl %eax + movl -48(%ebp),%ecx + pushl %ecx + movl -72(%ebp),%edi + movl (%edi),%edi + pushl %edi + call _divul3 + movl %eax,-52(%ebp) + xorl %eax,%eax + movl -4(%ebp),%edx + movl %edx,-32(%ebp) + addl $12,%esp +L273: + testl %eax,%eax + jne L274 + leal -4(%ebp),%eax + pushl %eax + movl -44(%ebp),%ecx + pushl %ecx + movl -52(%ebp),%edi + pushl %edi + call _mulul3 + movl %eax,%ebx + movl -72(%ebp),%edx + movl 4(%edx),%edx + movl %edx,-92(%ebp) + addl $12,%esp + cmpl %edx,%ebx + setb %al + andl $255,%eax + subl %edx,%ebx + movl %ebx,-88(%ebp) + movl -4(%ebp),%ebx + movl -32(%ebp),%ecx + movl %ecx,-92(%ebp) + movl %ebx,%edi + subl %ecx,%edi + subl %eax,%edi + movl %edi,-84(%ebp) + cmpl %ebx,%ecx + ja L334 + jmp L281 + .align 4,0x90 + .align 2,0x90 +L285: + decl -52(%ebp) + movl -88(%ebp),%ebx + movl -44(%ebp),%edx + movl %edx,-92(%ebp) + cmpl %edx,%ebx + setb %al + andl $255,%eax + subl %edx,%ebx + movl %ebx,-88(%ebp) + movl %esi,%ebx + movl -48(%ebp),%ecx + movl %ecx,-92(%ebp) + movl %ebx,%edi + subl %ecx,%edi + subl %eax,%edi + movl %edi,-84(%ebp) + cmpl %ebx,%ecx + jbe L281 +L334: + movl $1,%eax + jmp L282 + .align 4,0x90 +L281: + cmpl %ebx,-92(%ebp) + jae L282 + xorl %eax,%eax +L282: + movl -84(%ebp),%esi + testl %eax,%eax + jne L274 + testl %esi,%esi + jne L285 +L274: + movl $0,-4(%ebp) + movl -72(%ebp),%edx + movl -80(%ebp),%ecx + leal -8(%ecx,%edx),%edx + movl %edx,-88(%ebp) + movl -60(%ebp),%edi + addl %ecx,%edi + movl %edi,-76(%ebp) + movl -16(%ebp),%esi + addl $-2,%esi + je L287 + .align 2,0x90 +L290: + movl -4(%ebp),%ebx + leal -4(%ebp),%eax + pushl %eax + addl $-4,-76(%ebp) + movl -76(%ebp),%edx + movl (%edx),%edx + pushl %edx + movl -52(%ebp),%ecx + pushl %ecx + call _mulul3 + movl %eax,-84(%ebp) + addl %ebx,-84(%ebp) + cmpl %ebx,-84(%ebp) + jae L289 + incl -4(%ebp) +L289: + movl -84(%ebp),%edi + movl %edi,-92(%ebp) + addl $-4,-88(%ebp) + addl $12,%esp + movl -88(%ebp),%edx + movl (%edx),%ebx + cmpl %edi,%ebx + setb %al + andl $255,%eax + subl %edi,%ebx + movl %ebx,(%edx) + addl %eax,-4(%ebp) + decl %esi + jne L290 +L287: + movl -72(%ebp),%ecx + movl -4(%ecx),%eax + cmpl %eax,-4(%ebp) + jbe L291 + xorl %eax,%eax + decl -52(%ebp) + movl -80(%ebp),%edi + leal -8(%edi,%ecx),%edi + movl %edi,-88(%ebp) + movl -60(%ebp),%edx + addl -80(%ebp),%edx + movl %edx,-76(%ebp) + movl -16(%ebp),%esi + addl $-2,%esi + je L291 + .align 2,0x90 +L296: + movl -88(%ebp),%ecx + addl $-4,%ecx + movl %ecx,-92(%ebp) + movl %ecx,-88(%ebp) + movl (%ecx),%ebx + addl $-4,-76(%ebp) + movl %ebx,%edx + movl -76(%ebp),%edi + addl (%edi),%edx + movl %edx,-84(%ebp) + cmpl %ebx,%edx + jae L294 + addl %eax,%edx + movl %edx,-84(%ebp) + movl $1,%eax + movl %edx,(%ecx) + jmp L292 + .align 4,0x90 +L294: + addl %eax,-84(%ebp) + cmpl %eax,-84(%ebp) + setb %al + andl $255,%eax + movl -84(%ebp),%edi + movl -92(%ebp),%ecx + movl %edi,(%ecx) +L292: + decl %esi + jne L296 +L291: + movl -52(%ebp),%ecx + movl -72(%ebp),%edx + movl %ecx,-4(%edx) + decl -24(%ebp) + jne L297 +L271: + movl _avma ,%edi + movl %edi,-88(%ebp) + cmpl $-1,16(%ebp) + je L298 + movl -20(%ebp),%ebx + addl $2,%ebx + movl -56(%ebp),%edx + leal (%edx,%ebx,4),%edx + movl %edx,-72(%ebp) + movl -56(%ebp),%ecx + cmpl $0,4(%ecx) + je L299 + movl -20(%ebp),%ebx + addl $3,%ebx + jmp L300 + .align 4,0x90 +L299: + cmpl $0,-20(%ebp) + jne L300 + movl $0,-40(%ebp) +L300: + pushl %ebx + call _cgeti + movl %eax,-64(%ebp) + leal (%eax,%ebx,4),%eax + addl $4,%esp + leal -2(%ebx),%esi + testl %esi,%esi + je L303 + .align 2,0x90 +L304: + addl $-4,%eax + addl $-4,-72(%ebp) + movl -72(%ebp),%edi + movl (%edi),%edi + movl %edi,(%eax) + decl %esi + jne L304 +L303: + cmpl $2,%ebx + ja L305 + movl -64(%ebp),%edx + movl $2,4(%edx) + jmp L298 + .align 4,0x90 +L305: + movl -64(%ebp),%ecx + movl (%ecx),%edi + movl %edi,4(%ecx) + movb -40(%ebp),%dl + movb %dl,7(%ecx) +L298: + cmpl $0,16(%ebp) + je L307 + movl -20(%ebp),%esi + addl $2,%esi + cmpl %esi,-12(%ebp) + jle L309 + movl -56(%ebp),%ecx + cmpl $0,(%ecx,%esi,4) + jne L309 + .align 2,0x90 +L310: + incl %esi + cmpl %esi,-12(%ebp) + jle L309 + movl -56(%ebp),%edi + cmpl $0,(%edi,%esi,4) + je L310 +L309: + cmpl %esi,-12(%ebp) + jne L312 + movl _gzero ,%edx + pushl %edx + call _icopy + movl %eax,-68(%ebp) + addl $4,%esp + jmp L307 + .align 4,0x90 +L312: + movl -12(%ebp),%eax + subl %esi,%eax + addl $2,%eax + pushl %eax + call _cgeti + movl %eax,-68(%ebp) + movl (%eax),%ecx + movl %ecx,4(%eax) + addl $4,%esp + cmpl $0,-28(%ebp) + jne L314 + movl $2,-24(%ebp) + cmpl %esi,-12(%ebp) + jle L319 + .align 2,0x90 +L318: + movl -56(%ebp),%edi + movl (%edi,%esi,4),%ecx + movl -24(%ebp),%edi + movl -68(%ebp),%edx + movl %ecx,(%edx,%edi,4) + incl %esi + incl %edi + movl %edi,-24(%ebp) + cmpl %esi,-12(%ebp) + jg L318 + jmp L319 + .align 4,0x90 +L314: + movl $0,-4(%ebp) + movl -56(%ebp),%edi + movl (%edi,%esi,4),%ebx + incl %esi + movl $32,%eax + subl -28(%ebp),%eax + movl %ebx,%edi + movl %eax,%ecx + sall %cl,%edi + movl %edi,%eax + movl %eax,-4(%ebp) + movl -28(%ebp),%ecx + shrl %cl,%ebx + movl %ebx,-92(%ebp) + movl %eax,-32(%ebp) + testl %ebx,%ebx + je L320 + movl -68(%ebp),%edi + movl %ebx,8(%edi) + movl $1,%eax + jmp L321 + .align 4,0x90 +L320: + movl -68(%ebp),%edx + movl (%edx),%ecx + decl %ecx + movl %ecx,4(%edx) + addl $4,%edx + movl %edx,-68(%ebp) + addl $4,_avma + movl -68(%ebp),%edx + movl (%edx),%edi + movl %edi,4(%edx) + xorl %eax,%eax +L321: + addl $2,%eax + movl %eax,-24(%ebp) + cmpl %esi,-12(%ebp) + jle L319 + movl $32,%edx + subl -28(%ebp),%edx + movl %edx,-84(%ebp) + .align 2,0x90 +L325: + movl -56(%ebp),%ecx + movl (%ecx,%esi,4),%ebx + movl %ebx,%edi + movl -84(%ebp),%ecx + sall %cl,%edi + movl %edi,-92(%ebp) + movl %edi,-4(%ebp) + movl %ebx,%eax + movl -28(%ebp),%ecx + shrl %cl,%eax + addl -32(%ebp),%eax + movl -24(%ebp),%edi + movl -68(%ebp),%edx + movl %eax,(%edx,%edi,4) + movl -92(%ebp),%ecx + movl %ecx,-32(%ebp) + incl %esi + incl %edi + movl %edi,-24(%ebp) + cmpl %esi,-12(%ebp) + jg L325 +L319: + movb -36(%ebp),%dl + movl -68(%ebp),%ecx + movb %dl,7(%ecx) +L307: + cmpl $-1,16(%ebp) + jne L326 + movl -68(%ebp),%edi + pushl %edi + movl -88(%ebp),%edx + pushl %edx + movl -8(%ebp),%ecx + pushl %ecx + jmp L332 + .align 4,0x90 +L326: + cmpl $0,16(%ebp) + je L327 + pushl $0 + movl -88(%ebp),%edi + pushl %edi + movl -8(%ebp),%edx + pushl %edx + call _gerepile + andb $252,%al + movl -68(%ebp),%edi + addl %eax,%edi + movl 16(%ebp),%ecx + movl %edi,(%ecx) + addl -64(%ebp),%eax + jmp L328 + .align 4,0x90 +L327: + movl -64(%ebp),%edx + pushl %edx + movl -88(%ebp),%ecx + pushl %ecx + movl -8(%ebp),%edi + pushl %edi +L332: + call _gerepile +L328: + leal -104(%ebp),%esp + popl %ebx + popl %esi + popl %edi + movl %ebp,%esp + popl %ebp + ret +.comm _in_saved_avma ,4 diff --git a/mp/mpi-bsd68k.s b/mp/mpi-bsd68k.s new file mode 100755 index 0000000..e0f10e1 --- /dev/null +++ b/mp/mpi-bsd68k.s @@ -0,0 +1,2164 @@ +#NO_APP +gcc_compiled.: +.text + .even +.globl _mulsi +_mulsi: + link a6,#0 + moveml #0x3f30,sp@- + movel a6@(8),d4 + movel a6@(12),a2 + moveb a2@(4),d6 + extbl d6 + movel a2@(4),d5 + andl #65535,d5 + tstl d4 + jeq L3 + tstl d6 + jne L2 +L3: + movel _gzero,d0 + jra L1 +L2: + tstl d4 + jge L4 + negl d6 + negl d4 + jpl L4 + movel a2,sp@- + movel #-2147483648,sp@- + jbsr _stoi + addqw #4,sp + movel d0,sp@- + jbsr _mulii + jra L1 +L4: + movel d5,a3 + pea a3@(1) + jbsr _cgeti + movel d0,a1 + clrl d2 + movel d5,d0 + asll #2,d0 + addl d0,a2 + lea a1@(4,d0:l),a0 + movel d5,d3 + subql #2,d3 + jra L6 +L8: + movel d2,d0 + movel d4,d1 +#APP + mulul a2@-,d2:d1 +#NO_APP + addl d1,d0 + clrl d7 +#APP + addxl d7,d2 +#NO_APP + movel d0,a0@- +L6: + dbra d3,L8 + clrw d3 + subql #1,d3 + jcc L8 + tstl d2 + jeq L9 + movel d2,a0@- + movel a1@(4),d0 + clrw d0 + movel d0,a3 + lea a3@(1,d5:l),a3 + movel a3,a1@(4) + jra L10 +L9: + addql #4,_avma + movel a1@,d7 + subql #1,d7 + movel d7,a1@(4) + addqw #4,a1 + movel a1@(4),d0 + clrw d0 + addl d5,d0 + movel d0,a1@(4) +L10: + movel a1@(4),d0 + andl #16777215,d0 + movel d6,d1 + moveq #24,d7 + asll d7,d1 + addl d1,d0 + movel d0,a1@(4) + movel a1,d0 +L1: + moveml a6@(-32),#0xcfc + unlk a6 + rts + .even +.globl _expi +_expi: + link a6,#0 + movel d2,sp@- + movel a6@(8),a0 + movel a0@(4),d0 + andl #65535,d0 + moveq #2,d2 + cmpl d0,d2 + jne L12 + movel #-8388608,d0 + jra L13 +L12: + subql #2,d0 + asll #5,d0 +#APP + bfffo a0@(8){#0:#0},d1 +#NO_APP + subl d1,d0 + subql #1,d0 +L13: + movel a6@(-4),d2 + unlk a6 + rts + .even +.globl _addsi +_addsi: + link a6,#0 + moveml #0x3e20,sp@- + movel a6@(8),d3 + movel a6@(12),a2 + jne L15 + movel a2,sp@- + jbsr _icopy + jra L14 +L15: + moveb a2@(4),d4 + extbl d4 + jne L16 + movel d3,sp@- + jbsr _stoi + jra L14 +L16: + tstl d3 + jge L17 + moveq #-1,d5 + negl d3 + jpl L19 + movel a2,sp@- + pea _MOST_NEGS + jbsr _addii + jra L14 +L17: + moveq #1,d5 +L19: + movel a2@(4),d2 + andl #65535,d2 + cmpl d5,d4 + jne L20 + movel d3,d1 + addl a2@(-4,d2:l:4),d3 + cmpl d3,d1 + jls L21 + moveq #1,d0 + jra L22 +L21: + clrl d0 +L22: + tstl d0 + jeq L23 + movel d2,a1 + pea a1@(1) + jbsr _cgeti + movel d0,a0 + movel d3,a0@(d2:l:4) + movel d2,d0 + jra L65 +L27: + moveq #-1,d6 + cmpl a2@(-4,d0:l:4),d6 + jne L25 + clrl a0@(d0:l:4) +L65: + subql #1,d0 + moveq #2,d6 + cmpl d0,d6 + jlt L27 +L25: + moveq #2,d6 + cmpl d0,d6 + jge L28 + movel a2@(-4,d0:l:4),d6 + addql #1,d6 + movel d6,a0@(d0:l:4) + jra L66 +L31: + movel a2@(-4,d0:l:4),a0@(d0:l:4) +L66: + subql #1,d0 + moveq #2,d6 + cmpl d0,d6 + jlt L31 + movel a0@,d0 + subql #1,d0 + movel d0,a0@(4) + movel d0,a0@(8) + addqw #4,a0 + addql #4,_avma + jra L33 +L28: + moveq #1,d6 + movel d6,a0@(8) + movel a0@,a0@(4) + jra L33 +L23: + movel d2,sp@- + jbsr _cgeti + movel d0,a0 + movel d3,a0@(-4,d2:l:4) + moveq #1,d0 + movel d2,d1 + subql #1,d1 + jra L34 +L37: + movel a2@(d0:l:4),a0@(d0:l:4) + addql #1,d0 +L34: + cmpl d0,d1 + jgt L37 +L33: + movel a0@(4),d0 + andl #16777215,d0 + movel d5,d1 + jra L67 +L20: + moveq #3,d6 + cmpl d2,d6 + jne L39 + cmpl a2@(8),d3 + jcc L40 + pea 3:w + jbsr _cgeti + movel d0,a0 + movel d4,d0 + moveq #24,d6 + asll d6,d0 + addql #3,d0 + movel d0,a0@(4) + movel a2@(8),d6 + subl d3,d6 + movel d6,a0@(8) + jra L38 +L40: + cmpl a2@(8),d3 + jne L41 + movel _gzero,d0 + jra L14 +L41: + pea 3:w + jbsr _cgeti + movel d0,a0 + movel d4,d0 + negl d0 + moveq #24,d6 + asll d6,d0 + addql #3,d0 + movel d0,a0@(4) + subl a2@(8),d3 + movel d3,a0@(8) + jra L38 +L39: + movel a2@(-4,d2:l:4),d1 + movel d3,d0 + movel d1,d3 + subl d0,d3 + cmpl d1,d0 + jhi L42 + clrl d0 + jra L43 +L42: + moveq #1,d0 +L43: + tstl d0 + jeq L44 + movel d2,sp@- + jbsr _cgeti + movel d0,a0 + movel d3,a0@(-4,d2:l:4) + movel d2,d0 + subql #2,d0 + tstl a2@(d0:l:4) + jne L62 +L48: + moveq #-1,d6 + movel d6,a0@(d0:l:4) + subql #1,d0 + tstl a2@(d0:l:4) + jeq L48 +L62: + movel a2@(d0:l:4),d1 + subql #1,d1 + movel d1,a0@(d0:l:4) + moveq #2,d6 + cmpl d0,d6 + jlt L50 + tstl d1 + jeq L49 +L50: + subql #1,d0 + tstl d0 + jle L38 +L54: + movel a2@(d0:l:4),a0@(d0:l:4) + subql #1,d0 + tstl d0 + jgt L54 + jra L38 +L49: + movel a0@,d0 + subql #1,d0 + movel d0,a0@(4) + movel d0,a0@(8) + addqw #4,a0 + addql #4,_avma + movel a0@(4),d0 + andl #16777215,d0 + movel d4,d1 +L67: + moveq #24,d6 + asll d6,d1 + addl d1,d0 + movel d0,a0@(4) + jra L38 +L44: + movel d2,sp@- + jbsr _cgeti + movel d0,a0 + movel d3,a0@(-4,d2:l:4) + moveq #1,d0 + movel d2,d1 + subql #1,d1 + jra L57 +L60: + movel a2@(d0:l:4),a0@(d0:l:4) + addql #1,d0 +L57: + cmpl d0,d1 + jgt L60 +L38: + movel a0,d0 +L14: + moveml a6@(-24),#0x47c + unlk a6 + rts + .even +.globl _addii +_addii: + link a6,#-4 + moveml #0x3f3c,sp@- + movel a6@(8),a5 + movel a6@(12),a6@(-4) + movel a5@(4),d4 + andl #65535,d4 + movel a6@(-4),a4 + movel a4@(4),d5 + andl #65535,d5 + cmpl d4,d5 + jle L69 + movel a5,a3 + movel a6@(-4),a5 + movel a3,a6@(-4) + movel d4,d6 + movel d5,d4 + movel d6,d5 +L69: + movel a6@(-4),a4 + moveb a4@(4),d7 + extbl d7 + movel d7,a2 + tstl a2 + jne L70 + movel a5,sp@- + jbsr _icopy + jra L68 +L70: + moveb a5@(4),d6 + extbl d6 + cmpl d6,a2 + jne L71 + movel d4,a4 + pea a4@(1) + jbsr _cgeti + movel d0,a3 + clrl d1 + movel d4,d0 + asll #2,d0 + lea a3@(4,d0:l),a2 + lea a5@(0,d0:l),a1 + movel a6@(-4),a4 + lea a4@(d5:l:4),a0 + movel d5,d2 + subql #2,d2 +L72: +#APP + addl #-1,d1 +#NO_APP + moveq #16,d7 + cmpl d7,d2 + jhi L77 +LI94: + movew pc@(L94-LI94-2:b,d2:l:2),d7 + jmp pc@(2,d7:w) +L94: + .word L93-L94 + .word L92-L94 + .word L91-L94 + .word L90-L94 + .word L89-L94 + .word L88-L94 + .word L87-L94 + .word L86-L94 + .word L85-L94 + .word L84-L94 + .word L83-L94 + .word L82-L94 + .word L81-L94 + .word L80-L94 + .word L79-L94 + .word L78-L94 + .word L77-L94 +L77: + movel a1@-,d7 + movel a0@-,d3 +#APP + addxl d3,d7 +#NO_APP + movel d7,a2@- +L78: + movel a1@-,d7 + movel a0@-,d3 +#APP + addxl d3,d7 +#NO_APP + movel d7,a2@- +L79: + movel a1@-,d7 + movel a0@-,d3 +#APP + addxl d3,d7 +#NO_APP + movel d7,a2@- +L80: + movel a1@-,d7 + movel a0@-,d3 +#APP + addxl d3,d7 +#NO_APP + movel d7,a2@- +L81: + movel a1@-,d7 + movel a0@-,d3 +#APP + addxl d3,d7 +#NO_APP + movel d7,a2@- +L82: + movel a1@-,d7 + movel a0@-,d3 +#APP + addxl d3,d7 +#NO_APP + movel d7,a2@- +L83: + movel a1@-,d7 + movel a0@-,d3 +#APP + addxl d3,d7 +#NO_APP + movel d7,a2@- +L84: + movel a1@-,d7 + movel a0@-,d3 +#APP + addxl d3,d7 +#NO_APP + movel d7,a2@- +L85: + movel a1@-,d7 + movel a0@-,d3 +#APP + addxl d3,d7 +#NO_APP + movel d7,a2@- +L86: + movel a1@-,d7 + movel a0@-,d3 +#APP + addxl d3,d7 +#NO_APP + movel d7,a2@- +L87: + movel a1@-,d7 + movel a0@-,d3 +#APP + addxl d3,d7 +#NO_APP + movel d7,a2@- +L88: + movel a1@-,d7 + movel a0@-,d3 +#APP + addxl d3,d7 +#NO_APP + movel d7,a2@- +L89: + movel a1@-,d7 + movel a0@-,d3 +#APP + addxl d3,d7 +#NO_APP + movel d7,a2@- +L90: + movel a1@-,d7 + movel a0@-,d3 +#APP + addxl d3,d7 +#NO_APP + movel d7,a2@- +L91: + movel a1@-,d7 + movel a0@-,d3 +#APP + addxl d3,d7 +#NO_APP + movel d7,a2@- +L92: + movel a1@-,d7 + movel a0@-,d3 +#APP + addxl d3,d7 +#NO_APP + movel d7,a2@- +L93: +#APP + clrl d1 + addxl d1,d1 +#NO_APP + moveq #-16,d7 + addl d7,d2 + tstl d2 + jgt L72 + tstl d1 + jeq L95 + movel a5,d0 + addql #8,d0 +L96: + subqw #4,a1 + movel a1,a0 + cmpl a1,d0 + jhi L97 + moveq #-1,d7 + cmpl a1@,d7 + jne L98 + clrl a2@- + jra L96 +L98: + movel a0@,d7 + addql #1,d7 + movel d7,a2@- + jra L100 +L102: + movel a0@,a2@- +L100: + subqw #4,a1 + movel a1,a0 + cmpl a1,d0 + jls L102 + jra L160 +L97: + moveq #1,d7 + movel d7,a3@(8) + movel a5@(4),d7 + addql #1,d7 + movel d7,a3@(4) + jra L108 +L95: + movel d4,d1 + subl d5,d1 + jra L105 +L107: + movel a1@-,a2@- +L105: + dbra d1,L107 + clrw d1 + subql #1,d1 + jcc L107 +L160: + movel a3@,d7 + subql #1,d7 + movel d7,a3@(4) + movel a5@(4),a3@(8) + addqw #4,a3 + addql #4,_avma + jra L108 +L71: + cmpl d4,d5 + jne L109 + movel d4,d1 + subql #2,d1 + lea a5@(8),a1 + movel a6@(-4),a0 + addqw #8,a0 + jra L110 +L116: + movel a1@+,d2 + movel a0@+,d0 + cmpl d0,d2 + jcc L112 + movel a5,a3 + movel a6@(-4),a5 + movel a3,a6@(-4) + movel a2,d6 + jra L109 +L112: + cmpl d2,d0 + jcs L109 +L110: + dbra d1,L116 + clrw d1 + subql #1,d1 + jcc L116 + movel _gzero,d0 + jra L68 +L109: + movel d4,sp@- + jbsr _cgeti + movel d0,a3 + clrl d1 + movel d4,d0 + asll #2,d0 + lea a5@(0,d0:l),a1 + movel a6@(-4),a4 + lea a4@(d5:l:4),a0 + lea a3@(0,d0:l),a2 + movel d5,d2 + subql #2,d2 +L118: +#APP + addl #-1,d1 +#NO_APP + moveq #16,d7 + cmpl d7,d2 + jhi L123 +LI140: + movew pc@(L140-LI140-2:b,d2:l:2),d7 + jmp pc@(2,d7:w) +L140: + .word L139-L140 + .word L138-L140 + .word L137-L140 + .word L136-L140 + .word L135-L140 + .word L134-L140 + .word L133-L140 + .word L132-L140 + .word L131-L140 + .word L130-L140 + .word L129-L140 + .word L128-L140 + .word L127-L140 + .word L126-L140 + .word L125-L140 + .word L124-L140 + .word L123-L140 +L123: + movel a1@-,d7 + movel a0@-,d3 +#APP + subxl d3,d7 +#NO_APP + movel d7,a2@- +L124: + movel a1@-,d7 + movel a0@-,d3 +#APP + subxl d3,d7 +#NO_APP + movel d7,a2@- +L125: + movel a1@-,d7 + movel a0@-,d3 +#APP + subxl d3,d7 +#NO_APP + movel d7,a2@- +L126: + movel a1@-,d7 + movel a0@-,d3 +#APP + subxl d3,d7 +#NO_APP + movel d7,a2@- +L127: + movel a1@-,d7 + movel a0@-,d3 +#APP + subxl d3,d7 +#NO_APP + movel d7,a2@- +L128: + movel a1@-,d7 + movel a0@-,d3 +#APP + subxl d3,d7 +#NO_APP + movel d7,a2@- +L129: + movel a1@-,d7 + movel a0@-,d3 +#APP + subxl d3,d7 +#NO_APP + movel d7,a2@- +L130: + movel a1@-,d7 + movel a0@-,d3 +#APP + subxl d3,d7 +#NO_APP + movel d7,a2@- +L131: + movel a1@-,d7 + movel a0@-,d3 +#APP + subxl d3,d7 +#NO_APP + movel d7,a2@- +L132: + movel a1@-,d7 + movel a0@-,d3 +#APP + subxl d3,d7 +#NO_APP + movel d7,a2@- +L133: + movel a1@-,d7 + movel a0@-,d3 +#APP + subxl d3,d7 +#NO_APP + movel d7,a2@- +L134: + movel a1@-,d7 + movel a0@-,d3 +#APP + subxl d3,d7 +#NO_APP + movel d7,a2@- +L135: + movel a1@-,d7 + movel a0@-,d3 +#APP + subxl d3,d7 +#NO_APP + movel d7,a2@- +L136: + movel a1@-,d7 + movel a0@-,d3 +#APP + subxl d3,d7 +#NO_APP + movel d7,a2@- +L137: + movel a1@-,d7 + movel a0@-,d3 +#APP + subxl d3,d7 +#NO_APP + movel d7,a2@- +L138: + movel a1@-,d7 + movel a0@-,d3 +#APP + subxl d3,d7 +#NO_APP + movel d7,a2@- +L139: +#APP + clrl d1 + addxl d1,d1 +#NO_APP + moveq #-16,d7 + addl d7,d2 + tstl d2 + jgt L118 + tstl d1 + jeq L141 + jra L142 +L144: + moveq #-1,d7 + movel d7,a2@- +L142: + movel a1@-,d0 + jeq L144 + movel a5,d1 + addql #8,d1 + cmpl a1,d1 + jhi L149 + subql #1,d0 + movel d0,a2@- + jra L146 +L148: + movel a0@,a2@- +L146: + subqw #4,a1 + movel a1,a0 + cmpl a1,d1 + jls L148 + jra L149 +L141: + movel d4,d2 + subl d5,d2 + jra L150 +L152: + movel a1@-,a2@- +L150: + dbra d2,L152 + clrw d2 + subql #1,d2 + jcc L152 +L149: + tstl a3@(8) + jeq L153 + movel a5@(4),a3@(4) + jra L108 +L153: + lea a3@(12),a2 + tstl a2@ + jne L159 +L157: + addqw #4,a2 + tstl a2@ + jeq L157 +L159: + subqw #8,a2 + movel a2,d2 + subl a3,d2 + jpl L158 + addql #3,d2 +L158: + asrl #2,d2 + movel a3@,d0 + subl d2,d0 + movel d0,a2@ + movel d0,a2@(4) + movel a2,a3 + movel a3@(4),d0 + andl #16777215,d0 + movel d6,d1 + moveq #24,d7 + asll d7,d1 + addl d1,d0 + movel d0,a3@(4) + movel d2,d0 + asll #2,d0 + addl d0,_avma +L108: + movel a3,d0 +L68: + moveml a6@(-44),#0x3cfc + unlk a6 + rts + .even +.globl _mulss +_mulss: + link a6,#0 + moveml #0x3c00,sp@- + movel a6@(8),d0 + movel a6@(12),d2 + tstl d0 + jeq L163 + tstl d2 + jne L162 +L163: + movel _gzero,d0 + jra L161 +L162: + moveq #1,d4 + tstl d0 + jge L164 + moveq #-1,d4 + negl d0 + jpl L164 + movel d0,sp@- + jbsr _stoi + movel d0,sp@- + movel d2,sp@- + jbsr _mulsi + jra L161 +L164: + tstl d2 + jge L166 + negl d4 + negl d2 + jpl L166 + pea _ABS_MOST_NEGS + tstl d4 + jgt L169 + negl d0 +L169: + movel d0,sp@- + jbsr _mulsi + jra L161 +L166: +#APP + mulul d2,d3:d0 +#NO_APP + movel d0,d2 + tstl d3 + jeq L170 + pea 4:w + jbsr _cgeti + movel d0,a0 + movel d3,a0@(8) + movel d2,a0@(12) + jra L171 +L170: + pea 3:w + jbsr _cgeti + movel d0,a0 + movel d2,a0@(8) +L171: + movel a0@,a0@(4) + movel a0@(4),d0 + andl #16777215,d0 + movel d4,d1 + moveq #24,d5 + asll d5,d1 + addl d1,d0 + movel d0,a0@(4) + movel a0,d0 +L161: + moveml a6@(-16),#0x3c + unlk a6 + rts + .even +.globl _mulii +_mulii: + link a6,#-8 + moveml #0x3f3c,sp@- + movel a6@(8),a3 + movel a6@(12),d7 + movel a3@(4),d5 + andl #65535,d5 + movel d7,a5 + movel a5@(4),d6 + andl #65535,d6 + movel d6,a6@(-4) + moveb a3@(4),d2 + extbl d2 + jeq L188 + movel d7,a5 + moveb a5@(4),d0 + extbl d0 + jne L174 +L188: + movel _gzero,d0 + jra L172 +L174: + tstl d0 + jge L175 + negl d2 +L175: + cmpl a6@(-4),d5 + jle L176 + movel a3,a2 + movel d7,a3 + movel a2,d7 + movel d5,a4 + movel a6@(-4),d5 + movel a4,a6@(-4) +L176: + movel a6@(-4),a5 + lea a5@(-2,d5:l),a4 + cmpl #65535,a4 + jle L177 + pea 17:w + jbsr _err + addqw #4,sp +L177: + movel a4,sp@- + jbsr _cgeti + movel d0,a2 + movel a2@,a2@(4) + movel a2@(4),d0 + andl #16777215,d0 + movel d2,d1 + moveq #24,d6 + asll d6,d1 + addl d1,d0 + movel d0,a2@(4) + lea a3@(d5:l:4),a5 + movel a5,a6@(-8) + movel a6@(-8),a5 + subqw #4,a5 + movel a5,a6@(-8) + movel a5@,d4 + clrl d2 + movel a6@(-4),d3 + subql #2,d3 + movel d7,a5 + movel a6@(-4),d6 + lea a5@(d6:l:4),a1 + lea a2@(a4:l:4),a3 + jra L178 +L180: + movel d2,d0 + movel d4,d1 +#APP + mulul a1@-,d2:d1 +#NO_APP + addl d1,d0 + clrl d6 +#APP + addxl d6,d2 +#NO_APP + movel d0,a3@- +L178: + dbra d3,L180 + clrw d3 + subql #1,d3 + jcc L180 + movel d2,a3@- + lea a2@(a4:l:4),a3 + movel d7,a5 + movel a6@(-4),d6 + lea a5@(d6:l:4),a4 + subql #2,a6@(-4) + subql #2,d5 + clrl d7 + jra L181 +L186: + movel a6@(-8),a5 + subqw #4,a5 + movel a5,a6@(-8) + movel a5@,d4 + movel a6@(-4),d3 + movel a4,a1 + lea a3@(-4),a0 + movel a0,a3 + clrl d1 + jra L183 +L185: + movel a1@-,d0 +#APP + mulul d4,d2:d0 +#NO_APP + addl a0@-,d0 +#APP + addxl d7,d2 +#NO_APP + addl d1,d0 +#APP + addxl d7,d2 +#NO_APP + movel d0,a0@ + movel d2,d1 +L183: + dbra d3,L185 + clrw d3 + subql #1,d3 + jcc L185 + movel d2,a0@- +L181: + subql #1,d5 + tstl d5 + jgt L186 + tstl a2@(8) + jne L187 + movel a2@(4),d6 + subql #1,d6 + movel d6,a2@(8) + movel a2@,d6 + subql #1,d6 + movel d6,a2@(4) + addqw #4,a2 + addql #4,_avma +L187: + movel a2,d0 +L172: + moveml a6@(-48),#0x3cfc + unlk a6 + rts + .even +.globl _confrac +_confrac: + link a6,#-8 + moveml #0x3f3c,sp@- + movel a6@(8),a5 + movel a5@,d7 + andl #65535,d7 + movel d7,a6@(-8) + movel a5@(4),d5 + andl #16777215,d5 + addl #-8388608,d5 + moveq #-1,d7 + subl d5,d7 + movel d7,d5 + movel _avma,a6@(-4) + movel a6@(-8),a4 + subqw #2,a4 + movel a4,d7 + asll #5,d7 + movel d7,a4 + addl d5,a4 + lea a4@(63),a3 + movel a3,d7 + asrl #5,d7 + movel d7,a3 + movel a3,sp@- + jbsr _cgeti + movel d0,a2 + movel d5,d0 + asrl #5,d0 + clrl d3 + addqw #4,sp + cmpl d3,d0 + jle L216 +L193: + clrl a2@(d3:l:4) + addql #1,d3 + cmpl d3,d0 + jgt L193 +L216: + moveq #31,d7 + andl d7,d5 + jne L194 + moveq #2,d4 + cmpl a6@(-8),d4 + jge L199 +L198: + movel a5@(d4:l:4),a2@(d3:l:4) + addql #1,d3 + addql #1,d4 + cmpl a6@(-8),d4 + jlt L198 + jra L199 +L194: + clrl d6 + moveq #2,d4 + cmpl a6@(-8),d4 + jge L214 + moveq #32,d7 + subl d5,d7 + movel d7,a0 +L203: + movel d3,d0 + movel a5@(d4:l:4),d2 + addql #1,d3 + movel d2,d1 + lsrl d5,d1 + addl d6,d1 + movel d1,a2@(d0:l:4) + movel d2,d6 + movel a0,d7 + lsll d7,d6 + addql #1,d4 + cmpl a6@(-8),d4 + jlt L203 +L214: + movel d6,a2@(-8,a3:l:4) +L199: + clrl a2@(-4,a3:l:4) + movel a4,d7 + fmovel d7,fp0 + fmuld #0r.30102999999999999758,fp0 + fmovecr #0x32,fp1 + faddx fp1,fp0 + fintrzx fp0,fp0 + fmovel fp0,d2 + moveq #17,d5 + addl d2,d5 + moveq #9,d7 + divsl d7,d5 + movel d5,sp@- + jbsr _cgeti + movel d0,a0 + movel d2,a0@ + moveq #1,d4 + cmpl d4,d5 + jle L213 + movel #1000000000,d6 +L211: + clrl d1 + movel a3,d3 + jra L217 +L210: + movel d1,d2 + movel a2@(d3:l:4),d0 +#APP + mulul d6,d1:d0 +#NO_APP + addl d2,d0 + clrl d7 +#APP + addxl d7,d1 +#NO_APP + movel d0,a2@(d3:l:4) +L217: + subql #1,d3 + jpl L210 + movel d1,a0@(d4:l:4) + addql #1,d4 + cmpl d4,d5 + jgt L211 +L213: + movel a6@(-4),_avma + movel a0,d0 + moveml a6@(-48),#0x3cfc + unlk a6 + rts + .even +.globl _divss +_divss: + link a6,#0 + moveml #0x3820,sp@- + movel a6@(8),d4 + movel a6@(12),d3 + jne L219 + pea 23:w + jbsr _err + addqw #4,sp +L219: + cmpl #-2147483648,d4 + jne L220 + movel d3,sp@- + movel d4,sp@- + jbsr _stoi + addqw #4,sp + movel d0,sp@- + jbsr _divis + jra L218 +L220: + clrl _hiremainder + movel d4,sp@- + lea _abs,a2 + jbsr a2@ + movel d0,d2 + movel d3,sp@- + jbsr a2@ + movel _hiremainder,d1 +#APP + divul d0,d1:d2 +#NO_APP + movel d1,_hiremainder + movel d2,d0 + addqw #8,sp + tstl d3 + jge L221 + negl _hiremainder + negl d0 +L221: + tstl d4 + jge L222 + negl d0 +L222: + movel d0,sp@- + jbsr _stoi +L218: + moveml a6@(-16),#0x41c + unlk a6 + rts + .even +.globl _modss +_modss: + link a6,#0 + moveml #0x3820,sp@- + movel a6@(8),d2 + movel a6@(12),d4 + jne L224 + pea 38:w + jbsr _err + addqw #4,sp +L224: + cmpl #-2147483648,d2 + jne L225 + movel d4,sp@- + movel d2,sp@- + jbsr _stoi + addqw #4,sp + movel d0,sp@- + jbsr _modis + jra L223 +L225: + clrl d3 + movel d2,sp@- + lea _abs,a2 + jbsr a2@ + movel d0,d2 + movel d4,sp@- + jbsr a2@ +#APP + divul d0,d3:d2 +#NO_APP + addqw #8,sp + tstl d3 + jne L226 + movel _gzero,d0 + jra L223 +L226: + tstl d3 + jge L227 + subl d3,d0 + movel d0,sp@- + jra L229 +L227: + movel d3,sp@- +L229: + jbsr _stoi +L223: + moveml a6@(-16),#0x41c + unlk a6 + rts + .even +.globl _resss +_resss: + link a6,#0 + moveml #0x3820,sp@- + movel a6@(12),d4 + jne L231 + pea 40:w + jbsr _err + addqw #4,sp +L231: + clrl d3 + movel a6@(8),sp@- + lea _abs,a2 + jbsr a2@ + movel d0,d2 + movel d4,sp@- + jbsr a2@ +#APP + divul d0,d3:d2 +#NO_APP + addqw #8,sp + tstl d4 + jge L232 + negl d3 +L232: + movel d3,sp@- + jbsr _stoi + moveml a6@(-16),#0x41c + unlk a6 + rts + .even +.globl _divsi +_divsi: + link a6,#0 + moveml #0x3820,sp@- + movel a6@(8),d3 + movel a6@(12),a2 + moveb a2@(4),d0 + extbl d0 + movel a2@(4),d2 + andl #65535,d2 + tstl d0 + jne L235 + pea 24:w + jbsr _err + addqw #4,sp +L235: + tstl d3 + jeq L237 + moveq #3,d4 + cmpl d2,d4 + jlt L237 + tstl a2@(8) + jge L236 +L237: + movel d3,_hiremainder + movel _gzero,d0 + jra L234 +L236: + cmpl #-2147483648,d3 + jne L238 + clrl sp@- + movel a2,sp@- + movel d3,sp@- + jbsr _stoi + addqw #4,sp + movel d0,sp@- + jbsr _dvmdii + jra L234 +L238: + clrl _hiremainder + movel d3,sp@- + jbsr _abs + movel _hiremainder,d4 +#APP + divul a2@(8),d4:d0 +#NO_APP + movel d4,_hiremainder + movel d0,d1 + moveb a2@(4),d0 + extbl d0 + addqw #4,sp + jpl L239 + negl _hiremainder + negl d1 +L239: + tstl d3 + jge L240 + negl d1 +L240: + movel d1,sp@- + jbsr _stoi +L234: + moveml a6@(-16),#0x41c + unlk a6 + rts + .even +.globl _divis +_divis: + link a6,#0 + moveml #0x3f30,sp@- + movel a6@(8),a2 + movel a6@(12),d3 + moveb a2@(4),d7 + extbl d7 + movel a2@(4),d6 + andl #65535,d6 + tstl d3 + jne L242 + pea 26:w + jbsr _err + addqw #4,sp +L242: + tstl d7 + jne L243 + clrl _hiremainder + movel _gzero,d0 + jra L241 +L243: + tstl d3 + jge L244 + negl d7 + negl d3 + jpl L244 + clrl sp@- + movel d3,sp@- + jbsr _stoi + addqw #4,sp + movel d0,sp@- + movel a2,sp@- + jbsr _dvmdii + jra L241 +L244: + cmpl a2@(8),d3 + jls L246 + moveq #3,d5 + cmpl d6,d5 + jne L247 + movel a2,sp@- + jbsr _itos + movel d0,_hiremainder + movel _gzero,d0 + jra L241 +L247: + movel d6,a1 + pea a1@(-1) + jbsr _cgeti + movel d0,a0 + movew #1,a3 + movel a2@(8),d4 + jra L249 +L246: + movel d6,sp@- + jbsr _cgeti + movel d0,a0 + subl a3,a3 + clrl d4 +L249: + movel a3,d2 + addql #2,d2 + cmpl d2,d6 + jle L256 +L253: + movel d2,d1 + subl a3,d1 + movel a2@(d2:l:4),d0 +#APP + divul d3,d4:d0 +#NO_APP + movel d0,a0@(d1:l:4) + addql #1,d2 + cmpl d2,d6 + jgt L253 +L256: + movel a0@,a0@(4) + movel a0@(4),d0 + andl #16777215,d0 + movel d7,d1 + moveq #24,d5 + asll d5,d1 + addl d1,d0 + movel d0,a0@(4) + tstl d7 + jge L254 + movel d4,d0 + negl d0 + jra L255 +L254: + movel d4,d0 +L255: + movel d0,_hiremainder + movel a0,d0 +L241: + moveml a6@(-32),#0xcfc + unlk a6 + rts + .even +.globl _dvmdii +_dvmdii: + link a6,#-60 + moveml #0x3f3c,sp@- + movel a6@(8),a4 + moveb a4@(4),d6 + extbl d6 + movel d6,a6@(-24) + movel a6@(12),a1 + moveb a1@(4),d6 + extbl d6 + movel d6,a6@(-28) + jne L258 + pea 36:w + jbsr _err + addqw #4,sp +L258: + tstl a6@(-24) + jne L259 + moveq #-1,d6 + cmpl a6@(16),d6 + jeq L361 + tstl a6@(16) + jeq L361 + movel a6@(16),a1 + movel _gzero,a1@ +L361: + movel _gzero,d0 + jra L257 +L259: + movel a4@(4),d6 + andl #65535,d6 + movel d6,a6@(-8) + movel a6@(12),a1 + movel a1@(4),d6 + andl #65535,d6 + movel d6,a6@(-12) + movel a6@(-8),d6 + subl a6@(-12),d6 + movel d6,a6@(-16) + jge L262 + moveq #-1,d6 + cmpl a6@(16),d6 + jne L263 + movel a4,sp@- + jbsr _icopy + jra L257 +L263: + tstl a6@(16) + jeq L361 + movel a4,sp@- + jbsr _icopy + movel a6@(16),a1 + movel d0,a1@ + jra L361 +L262: + movel _avma,a6@(-4) + tstl a6@(-24) + jge L265 + negl a6@(-28) +L265: + moveq #3,d6 + cmpl a6@(-12),d6 + jne L266 + movel a6@(12),a1 + movel a1@(8),a6@(-60) + lea a4@(8),a3 + movel a6@(-60),d6 + cmpl a4@(8),d6 + jls L267 + movel a6@(-8),d2 + subql #1,d2 + movel a3@+,d5 + jra L268 +L267: + movel a6@(-8),d2 + clrl d5 +L268: + movel d2,sp@- + jbsr _cgeti + movel d0,a6@(-36) + movel d2,d7 + subql #2,d7 + movel d0,a2 + addqw #8,a2 + addqw #4,sp + jra L269 +L271: + movel a3@+,d0 +#APP + divul a6@(-60),d5:d0 +#NO_APP + movel d0,a2@+ +L269: + dbra d7,L271 + clrw d7 + subql #1,d7 + jcc L271 + moveq #-1,d6 + cmpl a6@(16),d6 + jne L272 + movel a6@(-4),_avma + tstl d5 + jeq L361 + pea 3:w + jbsr _cgeti + movel d0,a6@(-40) + movel a6@(-24),d0 + moveq #24,d6 + asll d6,d0 + movel a6@(-40),a1 + addql #3,d0 + movel d0,a1@(4) + movel d5,a1@(8) + movel a1,d0 + jra L257 +L272: + moveq #2,d6 + cmpl d2,d6 + jeq L274 + movel a6@(-36),a1 + movel a1@,a1@(4) + movel a1@(4),d0 + andl #16777215,d0 + movel a6@(-28),d1 + moveq #24,d6 + asll d6,d1 + addl d1,d0 + movel d0,a1@(4) + jra L275 +L274: + movel a6@(-4),_avma + movel _gzero,a6@(-36) +L275: + tstl a6@(16) + jne L276 +L359: + movel a6@(-36),d0 + jra L257 +L276: + tstl d5 + jne L277 + movel a6@(16),a1 + movel _gzero,a1@ + jra L359 +L277: + pea 3:w + jbsr _cgeti + movel d0,a6@(-40) + movel a6@(-24),d0 + moveq #24,d6 + asll d6,d0 + movel a6@(-40),a1 + addql #3,d0 + movel d0,a1@(4) + movel d5,a1@(8) + movel a6@(16),a1 + movel a6@(-40),a1@ + jra L359 +L266: + movel a6@(-8),sp@- + lea _cgeti,a3 + jbsr a3@ + movel d0,a6@(-36) + movel a6@(12),a1 +#APP + bfffo a1@(8){#0:#0},d6 +#NO_APP + movel d6,a6@(-20) + addqw #4,sp + jeq L280 + movel a1,a2 + addqw #8,a2 + movel a6@(-12),sp@- + jbsr a3@ + movel d0,a6@(-40) + movel a2@+,d1 + moveq #32,d0 + subl d6,d0 + movel d1,d5 + lsrl d0,d5 + lsll d6,d1 + movel d1,a6@(-56) + movel a6@(-40),a0 + addqw #8,a0 + movel a6@(-12),d7 + subql #3,d7 + addqw #4,sp + moveq #32,d0 + subl d6,d0 + jra L281 +L283: + movel a2@+,d1 + movel d1,d5 + lsrl d0,d5 + movel a6@(-56),d6 + addl d5,d6 + movel d6,a0@+ + movel a6@(-20),d6 + lsll d6,d1 + movel d1,a6@(-56) +L281: + dbra d7,L283 + clrw d7 + subql #1,d7 + jcc L283 + movel a6@(-56),a0@ + clrl a6@(-56) + lea a4@(8),a3 + movel a6@(-36),a2 + addqw #4,a2 + movel a6@(-8),d7 + subql #2,d7 + moveq #32,d0 + subl a6@(-20),d0 + jra L284 +L286: + movel a3@+,d1 + movel d1,d5 + lsrl d0,d5 + movel a6@(-56),d6 + addl d5,d6 + movel d6,a2@+ + movel a6@(-20),d6 + lsll d6,d1 + movel d1,a6@(-56) +L284: + dbra d7,L286 + clrw d7 + subql #1,d7 + jcc L286 + movel a6@(-56),a2@ + jra L287 +L280: + lea a4@(8),a3 + movel a6@(-36),a2 + addqw #4,a2 + clrl a2@+ + movel a6@(-8),d4 + subql #2,d4 + jra L288 +L290: + movel a3@+,a2@+ +L288: + dbra d4,L290 + clrw d4 + subql #1,d4 + jcc L290 + movel a6@(12),a6@(-40) +L287: + movel a6@(-40),a1 + movel a1@(8),a6@(-60) + movel a1@(12),a6@(-32) + movel a6@(-36),a2 + addqw #4,a2 + movel a6@(-16),d7 + addql #1,d7 + movel a6@(-12),d6 + asll #2,d6 + movel d6,a6@(-52) + jra L291 +L322: + movel a2@+,d6 + cmpl a6@(-60),d6 + jne L293 + movew #-1,a4 + movel a6@(-60),d1 + movel d1,d3 + addl a2@,d3 + cmpl d3,d1 + jls L294 + moveq #1,d2 + jra L295 +L294: + clrl d2 +L295: + movel d3,a6@(-56) + jra L296 +L293: + movel a2@,d0 + movel a2@(-4),d5 +#APP + divul a6@(-60),d5:d0 +#NO_APP + movel d0,a4 + clrl d2 + movel d5,a6@(-56) +L296: + tstl d2 + jne L297 + movel a4,d0 +#APP + mulul a6@(-32),d5:d0 +#NO_APP + movel d0,d1 + movel a2@(4),d0 + movel d1,d3 + subl d0,d3 + cmpl d1,d0 + jhi L298 + clrl d2 + jra L299 +L298: + moveq #1,d2 +L299: + movel d3,a0 + movel d5,d1 + movel a6@(-56),d0 + movel d5,d3 + subl a6@(-56),d3 + subl d2,d3 + cmpl a6@(-56),d5 + jcs L362 + jra L308 +L312: + tstl d4 + jeq L297 + subqw #1,a4 + movel a0,d1 + movel a6@(-32),d0 + movel d1,d3 + subl d0,d3 + cmpl d1,d0 + jhi L306 + clrl d2 + jra L307 +L306: + moveq #1,d2 +L307: + movel d3,a0 + movel d4,d1 + movel a6@(-60),d0 + movel d1,d3 + subl d0,d3 + subl d2,d3 + cmpl d0,d1 + jcc L308 +L362: + moveq #1,d2 + jra L309 +L308: + cmpl d0,d1 + jls L309 + clrl d2 +L309: + movel d3,d4 + tstl d2 + jeq L312 +L297: + clrl d5 + movel a6@(-12),d4 + subql #2,d4 + movel a6@(-52),d6 + lea a2@(-8,d6:l),a0 + movel a6@(-40),d6 + addl a6@(-52),d6 + movel d6,a6@(-56) + jra L313 +L317: + movel d5,d1 + movel a6@(-56),a1 + subqw #4,a1 + movel a1,a6@(-56) + movel a4,d0 +#APP + mulul a1@,d5:d0 +#NO_APP + movel d0,d3 + movel d1,d0 + addl d3,d0 + clrl d6 +#APP + addxl d6,d5 +#NO_APP + movel d0,d2 + subqw #4,a0 + movel a0,a3 + movel a0@,d1 + movel d1,d3 + subl d2,d3 + cmpl d1,d2 + jhi L315 + clrl d2 + jra L316 +L315: + moveq #1,d2 +L316: + movel d3,a3@ + addl d2,d5 +L313: + dbra d4,L317 + clrw d4 + subql #1,d4 + jcc L317 + cmpl a2@(-4),d5 + jls L318 + clrl d2 + subqw #1,a4 + movel a6@(-12),d4 + subql #2,d4 + movel a6@(-52),d6 + lea a2@(-8,d6:l),a0 + movel a6@(-40),d6 + addl a6@(-52),d6 + movel d6,a6@(-56) + jra L319 +L321: +#APP + addl #-1,d2 +#NO_APP + movel a6@(-56),a1 + subqw #4,a1 + movel a1,a6@(-56) + movel a0@-,d0 + movel a1@,d6 +#APP + addxl d6,d0 +#NO_APP + movel d0,a0@ +#APP + clrl d2 + addxl d2,d2 +#NO_APP +L319: + dbra d4,L321 + clrw d4 + subql #1,d4 + jcc L321 +L318: + movel a4,a2@(-4) +L291: + dbra d7,L322 + clrw d7 + subql #1,d7 + jcc L322 + movel _avma,d3 + moveq #-1,d6 + cmpl a6@(16),d6 + jeq L323 + movel a6@(-16),d2 + addql #2,d2 + movel a6@(-36),a1 + lea a1@(d2:l:4),a2 + tstl a1@(4) + jeq L324 + addql #1,d2 + jra L325 +L324: + tstl a6@(-16) + jne L325 + clrl a6@(-28) +L325: + movel d2,sp@- + jbsr _cgeti + movel d0,a6@(-44) + movel d0,a1 + lea a1@(d2:l:4),a0 + movel d2,d4 + subql #2,d4 + addqw #4,sp + jra L327 +L329: + movel a2@-,a0@- +L327: + dbra d4,L329 + clrw d4 + subql #1,d4 + jcc L329 + moveq #2,d6 + cmpl d2,d6 + jcs L330 + movel a6@(-44),a1 + moveq #2,d6 + movel d6,a1@(4) + jra L323 +L330: + movel a6@(-44),a1 + movel a1@,a1@(4) + movel a1@(4),d0 + andl #16777215,d0 + movel a6@(-28),d1 + moveq #24,d6 + asll d6,d1 + addl d1,d0 + movel d0,a1@(4) +L323: + tstl a6@(16) + jeq L332 + movel a6@(-16),d4 + addql #2,d4 + cmpl a6@(-8),d4 + jge L334 +L336: + movel a6@(-36),a1 + tstl a1@(d4:l:4) + jne L334 + addql #1,d4 + cmpl a6@(-8),d4 + jlt L336 +L334: + cmpl a6@(-8),d4 + jne L337 + movel _gzero,sp@- + jbsr _icopy + movel d0,a6@(-48) + addqw #4,sp + jra L332 +L337: + movel a6@(-8),a0 + subl d4,a0 + pea a0@(2) + jbsr _cgeti + movel d0,a6@(-48) + movel d0,a1 + movel a1@,a1@(4) + addqw #4,sp + tstl a6@(-20) + jne L339 + moveq #2,d7 + cmpl a6@(-8),d4 + jge L344 +L343: + movel a6@(-48),a1 + movel a6@(-36),a5 + movel a5@(d4:l:4),a1@(d7:l:4) + addql #1,d4 + addql #1,d7 + cmpl a6@(-8),d4 + jlt L343 + jra L344 +L339: + movel a6@(-36),a1 + movel a1@(d4:l:4),d1 + addql #1,d4 + moveq #32,d0 + subl a6@(-20),d0 + movel d1,d2 + movel a6@(-20),d6 + lsrl d6,d2 + lsll d0,d1 + movel d1,a6@(-56) + tstl d2 + jeq L345 + movel a6@(-48),a1 + movel d2,a1@(8) + moveq #1,d0 + jra L346 +L345: + movel a6@(-48),a1 + movel a1@,d6 + subql #1,d6 + movel d6,a1@(4) + addql #4,a6@(-48) + addql #4,_avma + movel a6@(-48),a1 + movel a1@,a1@(4) + clrl d0 +L346: + movel d0,d7 + addql #2,d7 + cmpl a6@(-8),d4 + jge L344 + moveq #32,d2 + subl a6@(-20),d2 +L350: + movel a6@(-36),a1 + movel a1@(d4:l:4),d1 + movel d1,d0 + movel a6@(-20),d6 + lsrl d6,d0 + movel a6@(-48),a1 + addl a6@(-56),d0 + movel d0,a1@(d7:l:4) + lsll d2,d1 + movel d1,a6@(-56) + addql #1,d4 + addql #1,d7 + cmpl a6@(-8),d4 + jlt L350 +L344: + movel a6@(-48),a1 + movel a1@(4),d0 + andl #16777215,d0 + movel a6@(-24),d1 + moveq #24,d6 + asll d6,d1 + addl d1,d0 + movel d0,a1@(4) +L332: + moveq #-1,d6 + cmpl a6@(16),d6 + jne L351 + movel a6@(-48),sp@- + jra L360 +L351: + tstl a6@(16) + jne L352 + movel a6@(-44),sp@- +L360: + movel d3,sp@- + movel a6@(-4),sp@- + jbsr _gerepile + jra L257 +L352: + clrl sp@- + movel d3,sp@- + movel a6@(-4),sp@- + jbsr _gerepile + moveq #-4,d6 + andl d6,d0 + movel a6@(16),a1 + movel a6@(-48),d6 + addl d0,d6 + movel d6,a1@ + addl a6@(-44),d0 +L257: + moveml a6@(-100),#0x3cfc + unlk a6 + rts + .even +.globl _mulul3 +_mulul3: + link a6,#0 + movel a6@(16),a0 + movel a6@(8),d0 + movel a0@,d1 +#APP + mulul a6@(12),d1:d0 +#NO_APP + movel d1,a0@ + unlk a6 + rts + .even +.globl _divul3 +_divul3: + link a6,#0 + movel a6@(16),a0 + movel a6@(8),d0 + movel a0@,d1 +#APP + divul a6@(12),d1:d0 +#NO_APP + movel d1,a0@ + unlk a6 + rts +.comm _in_saved_avma,4 diff --git a/mp/mpi-sol-sparc.s b/mp/mpi-sol-sparc.s new file mode 100755 index 0000000..65a5942 --- /dev/null +++ b/mp/mpi-sol-sparc.s @@ -0,0 +1,2848 @@ + .file "mpi.c" +gcc2_compiled.: +.section ".text" + .align 4 + .global mulsi + .type mulsi,#function + .proc 0104 +mulsi: + !#PROLOGUE# 0 + save %sp,-112,%sp + !#PROLOGUE# 1 + ld [%i1+4],%o1 + sra %o1,24,%l1 + sethi %hi(65535),%o0 + or %o0,%lo(65535),%o0 + cmp %i0,0 + be .LL3 + and %o1,%o0,%l0 + cmp %l1,0 + bne .LL2 + cmp %i0,0 +.LL3: + sethi %hi(gzero),%o0 + b .LL12 + ld [%o0+%lo(gzero)],%i0 +.LL2: + bge .LL4 + nop + subcc %g0,%i0,%i0 + bpos .LL4 + sub %g0,%l1,%l1 + call stoi,0 + sethi %hi(-2147483648),%o0 + call mulii,0 + mov %i1,%o1 + b .LL12 + mov %o0,%i0 +.LL4: + call cgeti,0 + add %l0,1,%o0 + mov %o0,%g3 + mov 0,%o2 + sll %l0,2,%o0 + add %i1,%o0,%i1 + add %g3,%o0,%g2 + addcc %l0,-2,%o3 + be .LL7 + add %g2,4,%g2 +.LL8: + add %g2,-4,%g2 + mov %o2,%o1 + add %i1,-4,%i1 + mov %i0,%o0 + ld [%i1],%l2 + + or %o0,%l2,%o4 + mov %o0,%y + andncc %o4,0xfff,%g0 + be 2f + andcc %g0,%g0,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%g0,%o4 + tst %l2 + bl,a 1f + add %o4,%o0,%o4 +1: mov %o4,%o2 + b 3f + rd %y,%o0 +2: clr %o2 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%l2,%o4 + mulscc %o4,%g0,%o4 + rd %y,%o5 + sll %o4,12,%o4 + srl %o5,20,%o5 + or %o5,%o4,%o0 +3: + + addcc %o1,%o0,%l2 + addx %o2,%g0,%o2 + addcc %o3,-1,%o3 + bne .LL8 + st %l2,[%g2] +.LL7: + cmp %o2,0 + be .LL10 + sethi %hi(-65536),%o1 + st %o2,[%g2-4] + ld [%g3+4],%o0 + and %o0,%o1,%o0 + add %o0,%l0,%o0 + b .LL13 + add %o0,1,%o0 +.LL10: + sethi %hi(avma),%o1 + ld [%o1+%lo(avma)],%o0 + add %o0,4,%o0 + st %o0,[%o1+%lo(avma)] + ld [%g3],%o0 + add %o0,-1,%o0 + st %o0,[%g3+4] + add %g3,4,%g3 + ld [%g3+4],%o0 + sethi %hi(-65536),%o1 + and %o0,%o1,%o0 + add %o0,%l0,%o0 +.LL13: + st %o0,[%g3+4] + ld [%g3+4],%o0 + sethi %hi(-16777216),%o1 + andn %o0,%o1,%o1 + sll %l1,24,%o0 + add %o1,%o0,%o1 + st %o1,[%g3+4] + mov %g3,%i0 +.LL12: + ret + restore +.LLfe1: + .size mulsi,.LLfe1-mulsi + .align 4 + .global expi + .type expi,#function + .proc 04 +expi: + !#PROLOGUE# 0 + save %sp,-112,%sp + !#PROLOGUE# 1 + mov %i0,%o2 + ld [%o2+4],%o1 + sethi %hi(65535),%o0 + or %o0,%lo(65535),%o0 + and %o1,%o0,%i0 + cmp %i0,2 + be,a .LL15 + sethi %hi(-8388608),%i0 + call bfffo,0 + ld [%o2+8],%o0 + add %i0,-2,%i0 + sll %i0,5,%i0 + sub %i0,%o0,%i0 + add %i0,-1,%i0 +.LL15: + ret + restore +.LLfe2: + .size expi,.LLfe2-expi + .align 4 + .global addsi + .type addsi,#function + .proc 0104 +addsi: + !#PROLOGUE# 0 + save %sp,-112,%sp + !#PROLOGUE# 1 + orcc %i0,0,%l1 + bne,a .LL18 + ldsb [%i1+4],%l3 + call icopy,0 + mov %i1,%o0 + b .LL67 + mov %o0,%i0 +.LL18: + cmp %l3,0 + bne .LL19 + cmp %l1,0 + call stoi,0 + mov %l1,%o0 + b .LL67 + mov %o0,%i0 +.LL19: + bge .LL20 + mov 1,%l4 + subcc %g0,%l1,%l1 + bpos .LL22 + mov -1,%l4 + sethi %hi(MOST_NEGS),%o0 + or %o0,%lo(MOST_NEGS),%o0 + call addii,0 + mov %i1,%o1 + b .LL67 + mov %o0,%i0 +.LL20: +.LL22: + ld [%i1+4],%o1 + sethi %hi(65535),%o0 + or %o0,%lo(65535),%o0 + cmp %l4,%l3 + bne .LL23 + and %o1,%o0,%l0 + mov %l1,%o1 + sll %l0,2,%l2 + add %l2,%i1,%o0 + ld [%o0-4],%o0 + add %o1,%o0,%o0 + cmp %o0,%o1 + bgeu .LL24 + mov %o0,%l1 + call cgeti,0 + add %l0,1,%o0 + mov %o0,%i0 + add %l0,-1,%o2 + cmp %o2,2 + ble .LL69 + st %l1,[%i0+%l2] +.LL30: + sll %o2,2,%o1 + add %o1,%i1,%o0 + ld [%o0-4],%o0 + cmp %o0,-1 + bne .LL69 + cmp %o2,2 + add %o2,-1,%o2 + cmp %o2,2 + bg .LL30 + st %g0,[%i0+%o1] + cmp %o2,2 +.LL69: + ble .LL31 + sll %o2,2,%o1 + add %o1,%i1,%o0 + ld [%o0-4],%o0 + add %o0,1,%o0 + b .LL68 + st %o0,[%i0+%o1] +.LL34: + add %o0,%i1,%o1 + ld [%o1-4],%o1 + st %o1,[%i0+%o0] +.LL68: + add %o2,-1,%o2 + cmp %o2,2 + bg .LL34 + sll %o2,2,%o0 + ld [%i0],%o0 + add %o0,-1,%o0 + st %o0,[%i0+4] + st %o0,[%i0+8] + add %i0,4,%i0 + sethi %hi(avma),%o1 + ld [%o1+%lo(avma)],%o0 + add %o0,4,%o0 + b .LL37 + st %o0,[%o1+%lo(avma)] +.LL31: + mov 1,%o0 + st %o0,[%i0+8] + ld [%i0],%o0 + b .LL37 + st %o0,[%i0+4] +.LL24: + call cgeti,0 + mov %l0,%o0 + mov %o0,%i0 + sll %l0,2,%o0 + add %o0,%i0,%o0 + st %l1,[%o0-4] + mov 1,%o2 + add %l0,-1,%o0 + cmp %o2,%o0 + bge .LL37 + mov %o0,%o3 +.LL41: + sll %o2,2,%o1 + ld [%i1+%o1],%o0 + add %o2,1,%o2 + cmp %o2,%o3 + bl .LL41 + st %o0,[%i0+%o1] +.LL37: + ld [%i0+4],%o0 + sethi %hi(-16777216),%o1 + andn %o0,%o1,%o1 + sll %l4,24,%o0 + add %o1,%o0,%o1 + b .LL67 + st %o1,[%i0+4] +.LL23: + cmp %l0,3 + bne .LL44 + sll %l0,2,%l2 + ld [%i1+8],%o0 + cmp %o0,%l1 + bleu .LL45 + nop + call cgeti,0 + mov 3,%o0 + mov %o0,%i0 + sll %l3,24,%o0 + add %o0,3,%o0 + st %o0,[%i0+4] + ld [%i1+8],%o0 + sub %o0,%l1,%o0 + b .LL67 + st %o0,[%i0+8] +.LL45: + bne .LL46 + sethi %hi(gzero),%o0 + b .LL67 + ld [%o0+%lo(gzero)],%i0 +.LL46: + call cgeti,0 + mov 3,%o0 + mov %o0,%i0 + sub %g0,%l3,%o0 + sll %o0,24,%o0 + add %o0,3,%o0 + st %o0,[%i0+4] + ld [%i1+8],%o0 + sub %l1,%o0,%o0 + b .LL67 + st %o0,[%i0+8] +.LL44: + add %l2,%i1,%o0 + ld [%o0-4],%o1 + mov %l1,%o0 + cmp %o1,%o0 + bgeu .LL47 + sub %o1,%o0,%l1 + call cgeti,0 + mov %l0,%o0 + mov %o0,%i0 + add %l2,%i0,%o0 + st %l1,[%o0-4] + add %l0,-2,%o2 + sll %o2,2,%o0 + mov %o0,%o1 + ld [%i1+%o0],%o0 + cmp %o0,0 + bne,a .LL70 + sll %o2,2,%o1 + mov -1,%o3 + st %o3,[%i0+%o1] +.LL71: + add %o2,-1,%o2 + sll %o2,2,%o1 + ld [%i1+%o1],%o0 + cmp %o0,0 + be,a .LL71 + st %o3,[%i0+%o1] + sll %o2,2,%o1 +.LL70: + ld [%i1+%o1],%o0 + add %o0,-1,%o0 + cmp %o2,2 + bg .LL54 + st %o0,[%i0+%o1] + cmp %o0,0 + be,a .LL53 + ld [%i0],%o0 +.LL54: + add %o2,-1,%o2 + cmp %o2,0 + ble .LL67 + nop +.LL58: + sll %o2,2,%o1 + ld [%i1+%o1],%o0 + add %o2,-1,%o2 + cmp %o2,0 + bg .LL58 + st %o0,[%i0+%o1] + b,a .LL67 +.LL53: + add %o0,-1,%o0 + st %o0,[%i0+4] + st %o0,[%i0+8] + add %i0,4,%i0 + sethi %hi(avma),%o1 + ld [%o1+%lo(avma)],%o0 + add %o0,4,%o0 + st %o0,[%o1+%lo(avma)] + ld [%i0+4],%o1 + sethi %hi(-16777216),%o0 + andn %o1,%o0,%o0 + sll %l3,24,%o1 + add %o0,%o1,%o0 + b .LL67 + st %o0,[%i0+4] +.LL47: + call cgeti,0 + mov %l0,%o0 + mov %o0,%i0 + sll %l0,2,%o0 + add %o0,%i0,%o0 + st %l1,[%o0-4] + mov 1,%o2 + add %l0,-1,%o0 + cmp %o2,%o0 + bge .LL67 + mov %o0,%o3 +.LL65: + sll %o2,2,%o1 + ld [%i1+%o1],%o0 + add %o2,1,%o2 + cmp %o2,%o3 + bl .LL65 + st %o0,[%i0+%o1] +.LL67: + ret + restore +.LLfe3: + .size addsi,.LLfe3-addsi + .align 4 + .global addii + .type addii,#function + .proc 0104 +addii: + !#PROLOGUE# 0 + save %sp,-112,%sp + !#PROLOGUE# 1 + mov %i0,%l0 + ld [%l0+4],%o0 + sethi %hi(65535),%o1 + or %o1,%lo(65535),%o1 + and %o0,%o1,%l1 + ld [%i1+4],%o0 + and %o0,%o1,%l2 + cmp %l1,%l2 + bge,a .LL236 + ldsb [%i1+4],%o5 + mov %i1,%l0 + mov %i0,%i1 + mov %l1,%l3 + mov %l2,%l1 + mov %l3,%l2 + ldsb [%i1+4],%o5 +.LL236: + cmp %o5,0 + bne,a .LL74 + ldsb [%l0+4],%l3 + call icopy,0 + mov %l0,%o0 + b .LL201 + mov %o0,%i0 +.LL74: + cmp %l3,%o5 + bne .LL75 + cmp %l1,%l2 + call cgeti,0 + add %l1,1,%o0 + mov %o0,%i0 + mov 0,%o2 + sll %l1,2,%o0 + add %i0,%o0,%o4 + add %o4,4,%o4 + add %l0,%o0,%o3 + sll %l2,2,%o0 + add %i1,%o0,%o1 + add %l2,-2,%o5 + sethi %hi(.LL113),%o0 + or %o0,%lo(.LL113),%g2 + add %o5,-1,%o0 +.LL237: + cmp %o0,15 + bgu .LL81 + sll %o0,2,%o0 + ld [%g2+%o0],%o0 + jmp %o0 + nop + .align 4 +.LL113: + .word .LL111 + .word .LL109 + .word .LL107 + .word .LL105 + .word .LL103 + .word .LL101 + .word .LL99 + .word .LL97 + .word .LL95 + .word .LL93 + .word .LL91 + .word .LL89 + .word .LL87 + .word .LL85 + .word .LL83 + .word .LL81 +.LL81: + subcc %g0,%o2,%g0 + b .LL82 + add %o4,-4,%o4 +.LL83: + subcc %g0,%o2,%g0 + b .LL204 + add %o4,-4,%o4 +.LL85: + subcc %g0,%o2,%g0 + b .LL205 + add %o4,-4,%o4 +.LL87: + subcc %g0,%o2,%g0 + b .LL206 + add %o4,-4,%o4 +.LL89: + subcc %g0,%o2,%g0 + b .LL207 + add %o4,-4,%o4 +.LL91: + subcc %g0,%o2,%g0 + b .LL208 + add %o4,-4,%o4 +.LL93: + subcc %g0,%o2,%g0 + b .LL209 + add %o4,-4,%o4 +.LL95: + subcc %g0,%o2,%g0 + b .LL210 + add %o4,-4,%o4 +.LL97: + subcc %g0,%o2,%g0 + b .LL211 + add %o4,-4,%o4 +.LL99: + subcc %g0,%o2,%g0 + b .LL212 + add %o4,-4,%o4 +.LL101: + subcc %g0,%o2,%g0 + b .LL213 + add %o4,-4,%o4 +.LL103: + subcc %g0,%o2,%g0 + b .LL214 + add %o4,-4,%o4 +.LL105: + subcc %g0,%o2,%g0 + b .LL215 + add %o4,-4,%o4 +.LL107: + subcc %g0,%o2,%g0 + b .LL216 + add %o4,-4,%o4 +.LL109: + subcc %g0,%o2,%g0 + b .LL217 + add %o4,-4,%o4 +.LL111: + subcc %g0,%o2,%g0 + b .LL218 + add %o4,-4,%o4 +.LL82: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%g3 + ld [%o1],%l4 + addxcc %g3,%l4,%g3 + st %g3,[%o4] + add %o4,-4,%o4 +.LL204: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%g3 + ld [%o1],%l4 + addxcc %g3,%l4,%g3 + st %g3,[%o4] + add %o4,-4,%o4 +.LL205: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%g3 + ld [%o1],%l4 + addxcc %g3,%l4,%g3 + st %g3,[%o4] + add %o4,-4,%o4 +.LL206: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%g3 + ld [%o1],%l4 + addxcc %g3,%l4,%g3 + st %g3,[%o4] + add %o4,-4,%o4 +.LL207: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%g3 + ld [%o1],%l4 + addxcc %g3,%l4,%g3 + st %g3,[%o4] + add %o4,-4,%o4 +.LL208: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%g3 + ld [%o1],%l4 + addxcc %g3,%l4,%g3 + st %g3,[%o4] + add %o4,-4,%o4 +.LL209: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%g3 + ld [%o1],%l4 + addxcc %g3,%l4,%g3 + st %g3,[%o4] + add %o4,-4,%o4 +.LL210: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%g3 + ld [%o1],%l4 + addxcc %g3,%l4,%g3 + st %g3,[%o4] + add %o4,-4,%o4 +.LL211: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%g3 + ld [%o1],%l4 + addxcc %g3,%l4,%g3 + st %g3,[%o4] + add %o4,-4,%o4 +.LL212: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%g3 + ld [%o1],%l4 + addxcc %g3,%l4,%g3 + st %g3,[%o4] + add %o4,-4,%o4 +.LL213: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%g3 + ld [%o1],%l4 + addxcc %g3,%l4,%g3 + st %g3,[%o4] + add %o4,-4,%o4 +.LL214: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%g3 + ld [%o1],%l4 + addxcc %g3,%l4,%g3 + st %g3,[%o4] + add %o4,-4,%o4 +.LL215: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%g3 + ld [%o1],%l4 + addxcc %g3,%l4,%g3 + st %g3,[%o4] + add %o4,-4,%o4 +.LL216: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%g3 + ld [%o1],%l4 + addxcc %g3,%l4,%g3 + st %g3,[%o4] + add %o4,-4,%o4 +.LL217: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%g3 + ld [%o1],%l4 + addxcc %g3,%l4,%g3 + st %g3,[%o4] + add %o4,-4,%o4 +.LL218: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%g3 + ld [%o1],%l4 + addxcc %g3,%l4,%g3 + st %g3,[%o4] + addx %g0,%g0,%o2 + add %o5,-16,%o5 + cmp %o5,0 + bg .LL237 + add %o5,-1,%o0 + cmp %o2,0 + be .LL115 + add %l0,8,%o2 +.LL116: + add %o3,-4,%o3 + cmp %o3,%o2 + blu .LL117 + mov %o3,%o1 + ld [%o3],%o0 + cmp %o0,-1 + bne .LL118 + add %o4,-4,%o4 + b .LL116 + st %g0,[%o4] +.LL118: + ld [%o1],%o0 + b .LL203 + add %o0,1,%o0 +.LL122: + add %o4,-4,%o4 + ld [%o1],%o0 +.LL203: + st %o0,[%o4] + add %o3,-4,%o3 + cmp %o3,%o2 + bgeu .LL122 + mov %o3,%o1 + b .LL219 + ld [%i0],%o0 +.LL117: + mov 1,%o0 + st %o0,[%i0+8] + ld [%l0+4],%o0 + add %o0,1,%o0 + b .LL201 + st %o0,[%i0+4] +.LL115: + subcc %l1,%l2,%o2 + be,a .LL219 + ld [%i0],%o0 +.LL128: + add %o4,-4,%o4 + add %o3,-4,%o3 + ld [%o3],%o0 + addcc %o2,-1,%o2 + bne .LL128 + st %o0,[%o4] + ld [%i0],%o0 +.LL219: + add %o0,-1,%o0 + st %o0,[%i0+4] + ld [%l0+4],%o0 + st %o0,[%i0+8] + add %i0,4,%i0 + sethi %hi(avma),%o1 + ld [%o1+%lo(avma)],%o0 + add %o0,4,%o0 + b .LL201 + st %o0,[%o1+%lo(avma)] +.LL75: + bne .LL131 + add %l0,8,%o3 + addcc %l1,-2,%o2 + be .LL140 + add %i1,8,%o1 + ld [%o3],%o4 +.LL238: + add %o3,4,%o3 + ld [%o1],%o0 + cmp %o0,%o4 + bgu .LL202 + add %o1,4,%o1 + cmp %o4,%o0 + bgu .LL131 + addcc %o2,-1,%o2 + bne,a .LL238 + ld [%o3],%o4 +.LL140: + sethi %hi(gzero),%o0 + b .LL201 + ld [%o0+%lo(gzero)],%i0 +.LL202: + mov %l0,%i0 + mov %i1,%l0 + mov %i0,%i1 + mov %o5,%l3 +.LL131: + call cgeti,0 + mov %l1,%o0 + mov %o0,%i0 + mov 0,%o2 + sll %l1,2,%o0 + add %l0,%o0,%o3 + sll %l2,2,%o1 + add %i1,%o1,%o1 + add %i0,%o0,%o4 + add %l2,-2,%o5 + sethi %hi(.LL178),%o0 + or %o0,%lo(.LL178),%g2 + add %o5,-1,%o0 +.LL239: + cmp %o0,15 + bgu .LL146 + sll %o0,2,%o0 + ld [%g2+%o0],%o0 + jmp %o0 + nop + .align 4 +.LL178: + .word .LL176 + .word .LL174 + .word .LL172 + .word .LL170 + .word .LL168 + .word .LL166 + .word .LL164 + .word .LL162 + .word .LL160 + .word .LL158 + .word .LL156 + .word .LL154 + .word .LL152 + .word .LL150 + .word .LL148 + .word .LL146 +.LL146: + subcc %g0,%o2,%g0 + b .LL147 + add %o4,-4,%o4 +.LL148: + subcc %g0,%o2,%g0 + b .LL220 + add %o4,-4,%o4 +.LL150: + subcc %g0,%o2,%g0 + b .LL221 + add %o4,-4,%o4 +.LL152: + subcc %g0,%o2,%g0 + b .LL222 + add %o4,-4,%o4 +.LL154: + subcc %g0,%o2,%g0 + b .LL223 + add %o4,-4,%o4 +.LL156: + subcc %g0,%o2,%g0 + b .LL224 + add %o4,-4,%o4 +.LL158: + subcc %g0,%o2,%g0 + b .LL225 + add %o4,-4,%o4 +.LL160: + subcc %g0,%o2,%g0 + b .LL226 + add %o4,-4,%o4 +.LL162: + subcc %g0,%o2,%g0 + b .LL227 + add %o4,-4,%o4 +.LL164: + subcc %g0,%o2,%g0 + b .LL228 + add %o4,-4,%o4 +.LL166: + subcc %g0,%o2,%g0 + b .LL229 + add %o4,-4,%o4 +.LL168: + subcc %g0,%o2,%g0 + b .LL230 + add %o4,-4,%o4 +.LL170: + subcc %g0,%o2,%g0 + b .LL231 + add %o4,-4,%o4 +.LL172: + subcc %g0,%o2,%g0 + b .LL232 + add %o4,-4,%o4 +.LL174: + subcc %g0,%o2,%g0 + b .LL233 + add %o4,-4,%o4 +.LL176: + subcc %g0,%o2,%g0 + b .LL234 + add %o4,-4,%o4 +.LL147: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%g3 + ld [%o1],%l4 + subxcc %g3,%l4,%g3 + st %g3,[%o4] + add %o4,-4,%o4 +.LL220: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%g3 + ld [%o1],%l4 + subxcc %g3,%l4,%g3 + st %g3,[%o4] + add %o4,-4,%o4 +.LL221: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%g3 + ld [%o1],%l4 + subxcc %g3,%l4,%g3 + st %g3,[%o4] + add %o4,-4,%o4 +.LL222: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%g3 + ld [%o1],%l4 + subxcc %g3,%l4,%g3 + st %g3,[%o4] + add %o4,-4,%o4 +.LL223: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%g3 + ld [%o1],%l4 + subxcc %g3,%l4,%g3 + st %g3,[%o4] + add %o4,-4,%o4 +.LL224: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%g3 + ld [%o1],%l4 + subxcc %g3,%l4,%g3 + st %g3,[%o4] + add %o4,-4,%o4 +.LL225: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%g3 + ld [%o1],%l4 + subxcc %g3,%l4,%g3 + st %g3,[%o4] + add %o4,-4,%o4 +.LL226: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%g3 + ld [%o1],%l4 + subxcc %g3,%l4,%g3 + st %g3,[%o4] + add %o4,-4,%o4 +.LL227: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%g3 + ld [%o1],%l4 + subxcc %g3,%l4,%g3 + st %g3,[%o4] + add %o4,-4,%o4 +.LL228: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%g3 + ld [%o1],%l4 + subxcc %g3,%l4,%g3 + st %g3,[%o4] + add %o4,-4,%o4 +.LL229: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%g3 + ld [%o1],%l4 + subxcc %g3,%l4,%g3 + st %g3,[%o4] + add %o4,-4,%o4 +.LL230: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%g3 + ld [%o1],%l4 + subxcc %g3,%l4,%g3 + st %g3,[%o4] + add %o4,-4,%o4 +.LL231: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%g3 + ld [%o1],%l4 + subxcc %g3,%l4,%g3 + st %g3,[%o4] + add %o4,-4,%o4 +.LL232: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%g3 + ld [%o1],%l4 + subxcc %g3,%l4,%g3 + st %g3,[%o4] + add %o4,-4,%o4 +.LL233: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%g3 + ld [%o1],%l4 + subxcc %g3,%l4,%g3 + st %g3,[%o4] + add %o4,-4,%o4 +.LL234: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%g3 + ld [%o1],%l4 + subxcc %g3,%l4,%g3 + st %g3,[%o4] + addx %g0,%g0,%o2 + add %o5,-16,%o5 + cmp %o5,0 + bg .LL239 + add %o5,-1,%o0 + cmp %o2,0 + be,a .LL180 + subcc %l1,%l2,%o5 + add %o3,-4,%o3 + ld [%o3],%o0 + cmp %o0,0 + bne .LL240 + add %l0,8,%o1 + mov -1,%o1 + add %o4,-4,%o4 +.LL241: + st %o1,[%o4] + add %o3,-4,%o3 + ld [%o3],%o0 + cmp %o0,0 + be,a .LL241 + add %o4,-4,%o4 + add %l0,8,%o1 +.LL240: + cmp %o3,%o1 + blu .LL190 + add %o0,-1,%o0 + add %o4,-4,%o4 + st %o0,[%o4] + add %o3,-4,%o3 + cmp %o3,%o1 + blu .LL190 + mov %o3,%o0 +.LL188: + add %o4,-4,%o4 + ld [%o0],%o0 + st %o0,[%o4] + add %o3,-4,%o3 + cmp %o3,%o1 + bgeu .LL188 + mov %o3,%o0 + b .LL235 + ld [%i0+8],%o0 +.LL180: + be,a .LL235 + ld [%i0+8],%o0 +.LL193: + add %o4,-4,%o4 + add %o3,-4,%o3 + ld [%o3],%o0 + addcc %o5,-1,%o5 + bne .LL193 + st %o0,[%o4] +.LL190: + ld [%i0+8],%o0 +.LL235: + cmp %o0,0 + be,a .LL195 + ld [%i0+12],%o0 + ld [%l0+4],%o0 + b .LL201 + st %o0,[%i0+4] +.LL195: + cmp %o0,0 + bne .LL198 + add %i0,12,%o4 + add %o4,4,%o4 +.LL242: + ld [%o4],%o0 + cmp %o0,0 + be,a .LL242 + add %o4,4,%o4 +.LL198: + add %o4,-8,%o4 + sub %o4,%i0,%o5 + sra %o5,2,%o5 + ld [%i0],%o1 + sub %o1,%o5,%o1 + st %o1,[%o4] + st %o1,[%o4+4] + mov %o4,%i0 + sethi %hi(-16777216),%o0 + andn %o1,%o0,%o0 + sll %l3,24,%o1 + add %o0,%o1,%o0 + st %o0,[%i0+4] + sethi %hi(avma),%o2 + sll %o5,2,%o0 + ld [%o2+%lo(avma)],%o1 + add %o0,%o1,%o0 + st %o0,[%o2+%lo(avma)] +.LL201: + ret + restore +.LLfe4: + .size addii,.LLfe4-addii + .align 4 + .global mulss + .type mulss,#function + .proc 0104 +mulss: + !#PROLOGUE# 0 + save %sp,-112,%sp + !#PROLOGUE# 1 + orcc %i0,0,%o0 + be .LL245 + cmp %i1,0 + bne .LL244 + cmp %o0,0 +.LL245: + sethi %hi(gzero),%o0 + b .LL253 + ld [%o0+%lo(gzero)],%i0 +.LL244: + bge .LL246 + mov 1,%l0 + subcc %g0,%o0,%o0 + bpos .LL246 + mov -1,%l0 + call stoi,0 + nop + mov %o0,%o1 + b .LL254 + mov %i1,%o0 +.LL246: + cmp %i1,0 + bge .LL255 + mov %o0,%l1 + subcc %g0,%i1,%i1 + bpos .LL255 + sub %g0,%l0,%l0 + cmp %l0,0 + bg .LL250 + mov %o0,%o1 + sub %g0,%o0,%o1 +.LL250: + mov %o1,%o0 + sethi %hi(ABS_MOST_NEGS),%o1 + or %o1,%lo(ABS_MOST_NEGS),%o1 +.LL254: + call mulsi,0 + nop + b .LL253 + mov %o0,%i0 +.LL255: + + or %l1,%i1,%o4 + mov %l1,%y + andncc %o4,0xfff,%g0 + be 2f + andcc %g0,%g0,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%g0,%o4 + tst %i1 + bl,a 1f + add %o4,%l1,%o4 +1: mov %o4,%o2 + b 3f + rd %y,%l1 +2: clr %o2 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%g0,%o4 + rd %y,%o5 + sll %o4,12,%o4 + srl %o5,20,%o5 + or %o5,%o4,%l1 +3: + + orcc %o2,0,%i1 + be .LL251 + nop + call cgeti,0 + mov 4,%o0 + mov %o0,%i0 + st %i1,[%i0+8] + b .LL252 + st %l1,[%i0+12] +.LL251: + call cgeti,0 + mov 3,%o0 + mov %o0,%i0 + st %l1,[%i0+8] +.LL252: + ld [%i0],%o0 + sethi %hi(-16777216),%o1 + andn %o0,%o1,%o1 + sll %l0,24,%o0 + add %o1,%o0,%o1 + st %o1,[%i0+4] +.LL253: + ret + restore +.LLfe5: + .size mulss,.LLfe5-mulss + .align 4 + .global mulii + .type mulii,#function + .proc 0104 +mulii: + !#PROLOGUE# 0 + save %sp,-112,%sp + !#PROLOGUE# 1 + mov %i0,%l4 + ld [%l4+4],%o0 + sethi %hi(65535),%o1 + or %o1,%lo(65535),%o1 + and %o0,%o1,%l0 + ld [%i1+4],%o2 + sra %o0,24,%l3 + cmp %l3,0 + be .LL276 + and %o2,%o1,%l2 + ldsb [%i1+4],%o0 + cmp %o0,0 + bne .LL258 + nop +.LL276: + sethi %hi(gzero),%o0 + b .LL275 + ld [%o0+%lo(gzero)],%i0 +.LL258: + bl,a .LL259 + sub %g0,%l3,%l3 +.LL259: + cmp %l0,%l2 + ble .LL260 + mov %l4,%i0 + mov %i1,%l4 + mov %i0,%i1 + mov %l0,%l1 + mov %l2,%l0 + mov %l1,%l2 +.LL260: + add %l0,%l2,%l1 + add %l1,-2,%l1 + sethi %hi(65535),%o0 + or %o0,%lo(65535),%o0 + cmp %l1,%o0 + ble .LL261 + nop + call err,0 + mov 17,%o0 +.LL261: + call cgeti,0 + mov %l1,%o0 + mov %o0,%i0 + ld [%i0],%o1 + sethi %hi(-16777216),%o0 + andn %o1,%o0,%o0 + sll %l3,24,%o1 + add %o0,%o1,%o0 + st %o0,[%i0+4] + sll %l0,2,%o0 + add %l4,%o0,%g4 + add %g4,-4,%g4 + ld [%g4],%g2 + mov 0,%o2 + sll %l2,2,%o0 + add %i1,%o0,%g3 + sll %l1,2,%o0 + addcc %l2,-2,%o3 + be .LL263 + add %i0,%o0,%g1 +.LL264: + add %g1,-4,%g1 + mov %o2,%o1 + add %g3,-4,%g3 + mov %g2,%o0 + ld [%g3],%l5 + + or %o0,%l5,%o4 + mov %o0,%y + andncc %o4,0xfff,%g0 + be 2f + andcc %g0,%g0,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%g0,%o4 + tst %l5 + bl,a 1f + add %o4,%o0,%o4 +1: mov %o4,%o2 + b 3f + rd %y,%o0 +2: clr %o2 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%l5,%o4 + mulscc %o4,%g0,%o4 + rd %y,%o5 + sll %o4,12,%o4 + srl %o5,20,%o5 + or %o5,%o4,%o0 +3: + + addcc %o1,%o0,%l5 + addx %o2,%g0,%o2 + addcc %o3,-1,%o3 + bne .LL264 + st %l5,[%g1] +.LL263: + st %o2,[%g1-4] + sll %l1,2,%o0 + add %i0,%o0,%g1 + sll %l2,2,%o0 + add %i1,%o0,%i1 + add %l0,-3,%l0 + cmp %l0,0 + ble .LL267 + add %l2,-1,%l2 +.LL268: + add %g4,-4,%g4 + ld [%g4],%o7 + mov %i1,%g3 + add %g1,-4,%o1 + mov %o1,%g1 + addcc %l2,-1,%o3 + be .LL270 + mov 0,%g2 +.LL271: + add %g3,-4,%g3 + ld [%g3],%o0 + + or %o0,%o7,%o4 + mov %o0,%y + andncc %o4,0xfff,%g0 + be 2f + andcc %g0,%g0,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%g0,%o4 + tst %o7 + bl,a 1f + add %o4,%o0,%o4 +1: mov %o4,%o2 + b 3f + rd %y,%o0 +2: clr %o2 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%g0,%o4 + rd %y,%o5 + sll %o4,12,%o4 + srl %o5,20,%o5 + or %o5,%o4,%o0 +3: + + add %o1,-4,%o1 + ld [%o1],%l5 + addcc %o0,%l5,%o0 + addx %o2,%g0,%o2 + addcc %o0,%g2,%l5 + addx %o2,%g0,%o2 + st %l5,[%o1] + addcc %o3,-1,%o3 + bne .LL271 + mov %o2,%g2 +.LL270: + add %l0,-1,%l0 + cmp %l0,0 + bg .LL268 + st %o2,[%o1-4] +.LL267: + ld [%i0+8],%o0 + cmp %o0,0 + bne .LL275 + sethi %hi(avma),%o1 + ld [%i0+4],%o0 + add %o0,-1,%o0 + st %o0,[%i0+8] + ld [%i0],%o0 + add %o0,-1,%o0 + st %o0,[%i0+4] + add %i0,4,%i0 + ld [%o1+%lo(avma)],%o0 + add %o0,4,%o0 + st %o0,[%o1+%lo(avma)] +.LL275: + ret + restore +.LLfe6: + .size mulii,.LLfe6-mulii + .global .div +.section ".rodata" + .align 8 +.LLC0: + .uaword 0x3fd34413 ! ~3.01030000000000019789e-1 + .uaword 0x55475a32 + .align 8 +.LLC1: + .uaword 0x3ff00000 ! ~1.00000000000000000000e0 + .uaword 0x0 +.section ".text" + .align 4 + .global confrac + .type confrac,#function + .proc 0104 +confrac: + !#PROLOGUE# 0 + save %sp,-120,%sp + !#PROLOGUE# 1 + ld [%i0],%o1 + sethi %hi(65535),%o0 + or %o0,%lo(65535),%o0 + and %o1,%o0,%l2 + ld [%i0+4],%o0 + sethi %hi(-16777216),%o1 + andn %o0,%o1,%o1 + sethi %hi(8388607),%o0 + or %o0,%lo(8388607),%o0 + sub %o0,%o1,%l0 + sethi %hi(avma),%o0 + ld [%o0+%lo(avma)],%l5 + add %l2,-2,%l4 + sll %l4,5,%l4 + add %l4,%l0,%l4 + add %l4,63,%l3 + sra %l3,5,%l3 + call cgeti,0 + mov %l3,%o0 + sra %l0,5,%o1 + mov 0,%g2 + cmp %g2,%o1 + bge .LL279 + mov %o0,%l1 +.LL281: + sll %g2,2,%o0 + add %g2,1,%g2 + cmp %g2,%o1 + bl .LL281 + st %g0,[%l1+%o0] +.LL279: + andcc %l0,31,%l0 + bne .LL283 + mov 2,%g3 + cmp %g3,%l2 + bge .LL305 + sll %l3,2,%o0 +.LL287: + sll %g2,2,%o0 + sll %g3,2,%o1 + ld [%i0+%o1],%o1 + st %o1,[%l1+%o0] + add %g3,1,%g3 + cmp %g3,%l2 + bl .LL287 + add %g2,1,%g2 + b .LL305 + sll %l3,2,%o0 +.LL283: + cmp %g3,%l2 + bge .LL291 + mov 0,%o3 + mov 32,%o0 + sub %o0,%l0,%o4 +.LL293: + sll %g2,2,%o1 + sll %g3,2,%o0 + ld [%i0+%o0],%o2 + add %g2,1,%g2 + srl %o2,%l0,%o0 + add %o0,%o3,%o0 + st %o0,[%l1+%o1] + add %g3,1,%g3 + cmp %g3,%l2 + bl .LL293 + sll %o2,%o4,%o3 +.LL291: + sll %l3,2,%o0 + add %o0,%l1,%o0 + st %o3,[%o0-8] + sll %l3,2,%o0 +.LL305: + add %o0,%l1,%o0 + st %g0,[%o0-4] + st %l4,[%fp-20] + ld [%fp-20],%f6 + fitod %f6,%f2 + sethi %hi(.LLC0),%l6 + ldd [%l6+%lo(.LLC0)],%f4 + fmuld %f2,%f4,%f2 + sethi %hi(.LLC1),%l6 + ldd [%l6+%lo(.LLC1)],%f4 + faddd %f2,%f4,%f2 + fdtoi %f2,%f2 + st %f2,[%fp-20] + ld [%fp-20],%l0 + add %l0,17,%l2 + mov %l2,%o0 + call .div,0 + mov 9,%o1 + call cgeti,0 + mov %o0,%l2 + mov %o0,%i0 + mov 1,%g3 + cmp %g3,%l2 + bge .LL296 + st %l0,[%i0] +.LL298: + addcc %l3,-1,%g2 + bneg .LL300 + mov 0,%o3 + sethi %hi(1000000000),%o0 + or %o0,%lo(1000000000),%o7 +.LL302: + sll %g2,2,%o1 + mov %o3,%o2 + ld [%l1+%o1],%o0 + + or %o0,%o7,%o4 + mov %o0,%y + andncc %o4,0xfff,%g0 + be 2f + andcc %g0,%g0,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%g0,%o4 + tst %o7 + bl,a 1f + add %o4,%o0,%o4 +1: mov %o4,%o3 + b 3f + rd %y,%o0 +2: clr %o3 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%g0,%o4 + rd %y,%o5 + sll %o4,12,%o4 + srl %o5,20,%o5 + or %o5,%o4,%o0 +3: + + addcc %o2,%o0,%l6 + addx %o3,%g0,%o3 + addcc %g2,-1,%g2 + bpos .LL302 + st %l6,[%l1+%o1] +.LL300: + sll %g3,2,%o0 + add %g3,1,%g3 + cmp %g3,%l2 + bl .LL298 + st %o3,[%i0+%o0] +.LL296: + sethi %hi(avma),%o0 + st %l5,[%o0+%lo(avma)] + ret + restore +.LLfe7: + .size confrac,.LLfe7-confrac + .align 4 + .global divss + .type divss,#function + .proc 0104 +divss: + !#PROLOGUE# 0 + save %sp,-112,%sp + !#PROLOGUE# 1 + cmp %i1,0 + bne .LL315 + sethi %hi(-2147483648),%o0 + call err,0 + mov 23,%o0 + sethi %hi(-2147483648),%o0 +.LL315: + cmp %i0,%o0 + bne .LL308 + sethi %hi(hiremainder),%o0 + call stoi,0 + mov %i0,%o0 + call divis,0 + mov %i1,%o1 + b,a .LL314 +.LL308: + st %g0,[%o0+%lo(hiremainder)] + cmp %i0,0 + bge .LL309 + mov %i0,%o0 + sub %g0,%i0,%o0 +.LL309: + cmp %i1,0 + bge .LL310 + mov %i1,%o1 + sub %g0,%i1,%o1 +.LL310: + sethi %hi(hiremainder),%l0 + call divul3,0 + or %l0,%lo(hiremainder),%o2 + cmp %i1,0 + bge .LL311 + mov %o0,%o1 + ld [%l0+%lo(hiremainder)],%o0 + sub %g0,%o0,%o0 + st %o0,[%l0+%lo(hiremainder)] + sub %g0,%o1,%o1 +.LL311: + cmp %i0,0 + bl,a .LL312 + sub %g0,%o1,%o1 +.LL312: + call stoi,0 + mov %o1,%o0 +.LL314: + ret + restore %g0,%o0,%o0 +.LLfe8: + .size divss,.LLfe8-divss + .align 4 + .global modss + .type modss,#function + .proc 0104 +modss: + !#PROLOGUE# 0 + save %sp,-120,%sp + !#PROLOGUE# 1 + cmp %i1,0 + bne .LL326 + sethi %hi(-2147483648),%o0 + call err,0 + mov 38,%o0 + sethi %hi(-2147483648),%o0 +.LL326: + cmp %i0,%o0 + bne .LL318 + mov %i0,%o0 + call stoi,0 + mov %i0,%o0 + call modis,0 + mov %i1,%o1 + b .LL323 + mov %o0,%i0 +.LL318: + cmp %o0,0 + bge .LL319 + st %g0,[%fp-20] + sub %g0,%o0,%o0 +.LL319: + cmp %i1,0 + bl,a .LL320 + sub %g0,%i1,%i1 +.LL320: + mov %i1,%o1 + call divul3,0 + add %fp,-20,%o2 + ld [%fp-20],%o0 + cmp %o0,0 + bne .LL321 + nop + sethi %hi(gzero),%o0 + b .LL323 + ld [%o0+%lo(gzero)],%i0 +.LL321: + bge .LL325 + nop + ld [%fp-20],%o0 + sub %i1,%o0,%o0 +.LL325: + call stoi,0 + nop + mov %o0,%i0 +.LL323: + ret + restore +.LLfe9: + .size modss,.LLfe9-modss + .align 4 + .global resss + .type resss,#function + .proc 0104 +resss: + !#PROLOGUE# 0 + save %sp,-120,%sp + !#PROLOGUE# 1 + cmp %i1,0 + bne .LL334 + mov %i0,%o0 + call err,0 + mov 40,%o0 + mov %i0,%o0 +.LL334: + cmp %o0,0 + bge .LL329 + st %g0,[%fp-20] + sub %g0,%o0,%o0 +.LL329: + cmp %i1,0 + bge .LL330 + mov %i1,%o1 + sub %g0,%i1,%o1 +.LL330: + call divul3,0 + add %fp,-20,%o2 + cmp %i1,0 + bge .LL333 + ld [%fp-20],%o0 + sub %g0,%o0,%o0 +.LL333: + call stoi,0 + nop + ret + restore %g0,%o0,%o0 +.LLfe10: + .size resss,.LLfe10-resss + .align 4 + .global divsi + .type divsi,#function + .proc 0104 +divsi: + !#PROLOGUE# 0 + save %sp,-112,%sp + !#PROLOGUE# 1 + ld [%i1+4],%o0 + sra %o0,24,%o2 + sethi %hi(65535),%o1 + or %o1,%lo(65535),%o1 + cmp %o2,0 + bne .LL336 + and %o0,%o1,%l0 + call err,0 + mov 24,%o0 +.LL336: + cmp %i0,0 + be .LL338 + cmp %l0,3 + bg .LL345 + sethi %hi(hiremainder),%o0 + ld [%i1+8],%o0 + cmp %o0,0 + bge .LL337 + sethi %hi(-2147483648),%o0 +.LL338: + sethi %hi(hiremainder),%o0 +.LL345: + st %i0,[%o0+%lo(hiremainder)] + sethi %hi(gzero),%o0 + b .LL343 + ld [%o0+%lo(gzero)],%i0 +.LL337: + cmp %i0,%o0 + bne .LL339 + sethi %hi(hiremainder),%o0 + call stoi,0 + mov %i0,%o0 + mov %i1,%o1 + call dvmdii,0 + mov 0,%o2 + b .LL343 + mov %o0,%i0 +.LL339: + st %g0,[%o0+%lo(hiremainder)] + cmp %i0,0 + bge .LL340 + mov %i0,%o0 + sub %g0,%i0,%o0 +.LL340: + ld [%i1+8],%o1 + sethi %hi(hiremainder),%l0 + call divul3,0 + or %l0,%lo(hiremainder),%o2 + mov %o0,%o1 + ldsb [%i1+4],%o0 + cmp %o0,0 + bge .LL346 + cmp %i0,0 + ld [%l0+%lo(hiremainder)],%o0 + sub %g0,%o0,%o0 + st %o0,[%l0+%lo(hiremainder)] + sub %g0,%o1,%o1 +.LL346: + bl,a .LL342 + sub %g0,%o1,%o1 +.LL342: + call stoi,0 + mov %o1,%o0 + mov %o0,%i0 +.LL343: + ret + restore +.LLfe11: + .size divsi,.LLfe11-divsi + .align 4 + .global divis + .type divis,#function + .proc 0104 +divis: + !#PROLOGUE# 0 + save %sp,-120,%sp + !#PROLOGUE# 1 + mov %i0,%l3 + ld [%l3+4],%o1 + sra %o1,24,%l4 + sethi %hi(65535),%o0 + or %o0,%lo(65535),%o0 + cmp %i1,0 + bne .LL348 + and %o1,%o0,%l2 + call err,0 + mov 26,%o0 +.LL348: + cmp %l4,0 + bne .LL349 + cmp %i1,0 + sethi %hi(hiremainder),%o0 + b .LL364 + st %g0,[%o0+%lo(hiremainder)] +.LL349: + bge,a .LL365 + ld [%l3+8],%o0 + subcc %g0,%i1,%i1 + bpos .LL350 + sub %g0,%l4,%l4 + call stoi,0 + mov %i1,%o0 + mov %o0,%o1 + mov %l3,%o0 + call dvmdii,0 + mov 0,%o2 + b .LL363 + mov %o0,%i0 +.LL350: + ld [%l3+8],%o0 +.LL365: + cmp %i1,%o0 + bleu .LL352 + cmp %l2,3 + bne .LL353 + sethi %hi(hiremainder),%l0 + call itos,0 + mov %l3,%o0 + st %o0,[%l0+%lo(hiremainder)] +.LL364: + sethi %hi(gzero),%o0 + b .LL363 + ld [%o0+%lo(gzero)],%i0 +.LL353: + call cgeti,0 + add %l2,-1,%o0 + mov %o0,%i0 + mov 1,%l1 + ld [%l3+8],%o0 + b .LL355 + st %o0,[%fp-20] +.LL352: + call cgeti,0 + mov %l2,%o0 + mov %o0,%i0 + mov 0,%l1 + st %l1,[%fp-20] +.LL355: + add %l1,2,%l0 + cmp %l0,%l2 + bge,a .LL366 + ld [%i0],%o0 +.LL359: + sll %l0,2,%o0 + ld [%l3+%o0],%o0 + mov %i1,%o1 + call divul3,0 + add %fp,-20,%o2 + sub %l0,%l1,%o1 + sll %o1,2,%o1 + add %l0,1,%l0 + cmp %l0,%l2 + bl .LL359 + st %o0,[%i0+%o1] + ld [%i0],%o0 +.LL366: + sethi %hi(-16777216),%o1 + andn %o0,%o1,%o1 + sll %l4,24,%o0 + add %o1,%o0,%o1 + st %o1,[%i0+4] + sethi %hi(hiremainder),%o1 + cmp %l4,0 + bge .LL361 + or %o1,%lo(hiremainder),%o2 + ld [%fp-20],%o0 + sub %g0,%o0,%o0 + b .LL363 + st %o0,[%o1+%lo(hiremainder)] +.LL361: + ld [%fp-20],%o0 + st %o0,[%o2] +.LL363: + ret + restore +.LLfe12: + .size divis,.LLfe12-divis + .align 4 + .global dvmdii + .type dvmdii,#function + .proc 0104 +dvmdii: + !#PROLOGUE# 0 + save %sp,-136,%sp + !#PROLOGUE# 1 + mov %i0,%l2 + mov %i2,%i5 + ldsb [%l2+4],%g1 + st %g1,[%fp-28] + ldsb [%i1+4],%g4 + cmp %g4,0 + bne .LL368 + st %g4,[%fp-32] + call err,0 + mov 36,%o0 +.LL368: + ld [%fp-28],%g1 + cmp %g1,0 + bne,a .LL369 + ld [%l2+4],%o0 + cmp %i5,-1 + be .LL470 + cmp %i5,0 + be .LL470 + sethi %hi(gzero),%o1 + ld [%o1+%lo(gzero)],%o0 + st %o0,[%i5] + b .LL469 + ld [%o1+%lo(gzero)],%i0 +.LL369: + sethi %hi(65535),%o1 + or %o1,%lo(65535),%o1 + and %o0,%o1,%l5 + ld [%i1+4],%o0 + and %o0,%o1,%i3 + subcc %l5,%i3,%i4 + bpos .LL372 + sethi %hi(avma),%o0 + cmp %i5,-1 + bne .LL373 + cmp %i5,0 + call icopy,0 + mov %l2,%o0 + b .LL469 + mov %o0,%i0 +.LL373: + be .LL478 + sethi %hi(gzero),%o0 + call icopy,0 + mov %l2,%o0 + b .LL470 + st %o0,[%i5] +.LL372: + ld [%o0+%lo(avma)],%o0 + st %o0,[%fp-24] + ld [%fp-28],%g4 + cmp %g4,0 + bge .LL479 + cmp %i3,3 + ld [%fp-32],%g1 + sub %g0,%g1,%g1 + st %g1,[%fp-32] +.LL479: + bne .LL376 + nop + ld [%i1+8],%i1 + ld [%l2+8],%o0 + cmp %i1,%o0 + bleu .LL377 + add %l2,8,%l1 + add %l5,-1,%l0 + st %o0,[%fp-20] + b .LL378 + add %l2,12,%l1 +.LL377: + mov %l5,%l0 + st %g0,[%fp-20] +.LL378: + call cgeti,0 + mov %l0,%o0 + mov %o0,%l4 + addcc %l0,-2,%l3 + be .LL380 + add %l4,8,%l2 +.LL381: + ld [%l1],%o0 + add %l1,4,%l1 + mov %i1,%o1 + call divul3,0 + add %fp,-20,%o2 + st %o0,[%l2] + addcc %l3,-1,%l3 + bne .LL381 + add %l2,4,%l2 +.LL380: + cmp %i5,-1 + bne .LL383 + cmp %l0,2 + sethi %hi(avma),%o0 + ld [%fp-24],%g4 + st %g4,[%o0+%lo(avma)] + ld [%fp-20],%o0 + cmp %o0,0 + bne .LL384 + nop +.LL470: + sethi %hi(gzero),%o0 +.LL478: + b .LL469 + ld [%o0+%lo(gzero)],%i0 +.LL384: + call cgeti,0 + mov 3,%o0 + mov %o0,%i0 + ld [%fp-28],%g1 + sll %g1,24,%o0 + add %o0,3,%o0 + st %o0,[%i0+4] + ld [%fp-20],%o0 + b .LL469 + st %o0,[%i0+8] +.LL383: + be .LL385 + sethi %hi(-16777216),%o1 + ld [%l4],%o0 + andn %o0,%o1,%o1 + ld [%fp-32],%g4 + sll %g4,24,%o0 + add %o1,%o0,%o1 + b .LL386 + st %o1,[%l4+4] +.LL385: + sethi %hi(avma),%o0 + ld [%fp-24],%g1 + st %g1,[%o0+%lo(avma)] + sethi %hi(gzero),%o0 + ld [%o0+%lo(gzero)],%l4 +.LL386: + cmp %i5,0 + bne .LL387 + ld [%fp-20],%o0 +.LL472: + b .LL469 + mov %l4,%i0 +.LL387: + cmp %o0,0 + bne .LL388 + sethi %hi(gzero),%o0 + ld [%o0+%lo(gzero)],%o0 + b .LL472 + st %o0,[%i5] +.LL388: + call cgeti,0 + mov 3,%o0 + mov %o0,%i0 + ld [%fp-28],%g4 + sll %g4,24,%o0 + add %o0,3,%o0 + st %o0,[%i0+4] + ld [%fp-20],%o0 + st %o0,[%i0+8] + b .LL472 + st %i0,[%i5] +.LL376: + call cgeti,0 + mov %l5,%o0 + mov %o0,%l4 + call bfffo,0 + ld [%i1+8],%o0 + orcc %o0,0,%l7 + be .LL391 + add %l2,8,%l1 + call cgeti,0 + mov %i3,%o0 + mov %o0,%i0 + ld [%i1+8],%o2 + add %i1,12,%o1 + mov 32,%o0 + sub %o0,%l7,%o0 + srl %o2,%o0,%o0 + st %o0,[%fp-20] + sll %o2,%l7,%g2 + addcc %i3,-3,%l3 + be .LL393 + add %i0,8,%o3 + mov 32,%o0 + sub %o0,%l7,%o4 +.LL394: + ld [%o1],%o2 + add %o1,4,%o1 + srl %o2,%o4,%o0 + st %o0,[%fp-20] + add %g2,%o0,%o0 + st %o0,[%o3] + add %o3,4,%o3 + addcc %l3,-1,%l3 + bne .LL394 + sll %o2,%l7,%g2 +.LL393: + st %g2,[%o3] + mov 0,%g2 + add %l2,8,%l1 + addcc %l5,-2,%l3 + be .LL397 + add %l4,4,%l2 + mov 32,%o0 + sub %o0,%l7,%o1 +.LL398: + ld [%l1],%o2 + add %l1,4,%l1 + srl %o2,%o1,%o0 + st %o0,[%fp-20] + add %g2,%o0,%o0 + st %o0,[%l2] + add %l2,4,%l2 + addcc %l3,-1,%l3 + bne .LL398 + sll %o2,%l7,%g2 +.LL397: + b .LL400 + st %g2,[%l2] +.LL391: + st %g0,[%l4+4] + addcc %l5,-2,%l0 + be .LL402 + add %l4,8,%l2 +.LL403: + ld [%l1],%o0 + st %o0,[%l2] + add %l1,4,%l1 + addcc %l0,-1,%l0 + bne .LL403 + add %l2,4,%l2 +.LL402: + mov %i1,%i0 +.LL400: + ld [%i0+8],%i1 + ld [%i0+12],%i2 + addcc %i4,1,%l3 + be .LL406 + add %l4,4,%l2 + sll %i3,2,%l1 +.LL407: + ld [%l2],%o0 + cmp %o0,%i1 + bne .LL408 + add %l2,4,%l2 + mov -1,%o7 + mov %i1,%o2 + ld [%l2],%o0 + add %o2,%o0,%o1 + cmp %o1,%o2 + addx %g0,0,%o3 + b .LL409 + mov %o1,%g2 +.LL408: + ld [%l2-4],%o0 + st %o0,[%fp-20] + ld [%l2],%o0 + mov %i1,%o1 + call divul3,0 + add %fp,-20,%o2 + mov %o0,%o7 + mov 0,%o3 + ld [%fp-20],%g2 +.LL409: + cmp %o3,0 + bne,a .LL480 + st %g0,[%fp-20] + mov %o7,%o2 + + or %o2,%i2,%o4 + mov %o2,%y + andncc %o4,0xfff,%g0 + be 2f + andcc %g0,%g0,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%g0,%o4 + tst %i2 + bl,a 1f + add %o4,%o2,%o4 +1: mov %o4,%g1 + b 3f + rd %y,%o2 +2: clr %g1 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%i2,%o4 + mulscc %o4,%g0,%o4 + rd %y,%o5 + sll %o4,12,%o4 + srl %o5,20,%o5 + or %o5,%o4,%o2 +3: + + st %g1,[%fp-20] + ld [%l2+4],%o0 + cmp %o2,%o0 + addx %g0,0,%o3 + sub %o2,%o0,%o4 + mov %g1,%o2 + mov %g2,%o0 + sub %o2,%g2,%o1 + cmp %g2,%o2 + bgu .LL475 + sub %o1,%o3,%o1 + b .LL476 + cmp %o0,%o2 +.LL423: + be .LL410 + mov %o4,%o2 + add %o7,-1,%o7 + mov %i2,%o0 + cmp %o2,%o0 + addx %g0,0,%o3 + sub %o2,%o0,%o4 + mov %o1,%o2 + mov %i1,%o0 + sub %o2,%o0,%o1 + cmp %o0,%o2 + bleu .LL476 + sub %o1,%o3,%o1 +.LL475: + b .LL420 + mov 1,%o3 +.LL476: + blu,a .LL420 + mov 0,%o3 +.LL420: + cmp %o3,0 + be .LL423 + cmp %o1,0 +.LL410: + st %g0,[%fp-20] +.LL480: + add %l2,%l1,%g2 + add %g2,-8,%g2 + addcc %i3,-2,%l0 + be .LL425 + add %i0,%l1,%g3 +.LL426: + ld [%fp-20],%o2 + add %g3,-4,%g3 + mov %o7,%o1 + ld [%g3],%g1 + + or %o1,%g1,%o4 + mov %o1,%y + andncc %o4,0xfff,%g0 + be 2f + andcc %g0,%g0,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g0,%o4 + tst %g1 + bl,a 1f + add %o4,%o1,%o4 +1: mov %o4,%g4 + b 3f + rd %y,%o1 +2: clr %g4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g0,%o4 + rd %y,%o5 + sll %o4,12,%o4 + srl %o5,20,%o5 + or %o5,%o4,%o1 +3: + + st %g4,[%fp-20] + addcc %o2,%o1,%o3 + addx %g4,%g0,%g4 + st %g4,[%fp-20] + add %g2,-4,%g2 + ld [%g2],%o2 + sub %o2,%o3,%o1 + cmp %o2,%o3 + st %o1,[%g2] + ld [%fp-20],%o0 + addx %g0,%o0,%o0 + addcc %l0,-1,%l0 + bne .LL426 + st %o0,[%fp-20] +.LL425: + ld [%l2-4],%o1 + ld [%fp-20],%o0 + cmp %o1,%o0 + bgeu,a .LL481 + addcc %l3,-1,%l3 + mov 0,%o3 + add %o7,-1,%o7 + add %l2,%l1,%g2 + add %g2,-8,%g2 + addcc %i3,-2,%l0 + be .LL428 + add %i0,%l1,%g3 + add %g2,-4,%g2 +.LL482: + subcc %g0,%o3,%g0 + add %g3,-4,%g3 + ld [%g2],%g1 + ld [%g3],%g4 + addxcc %g1,%g4,%g1 + st %g1,[%g2] + addx %g0,%g0,%o3 + addcc %l0,-1,%l0 + bne,a .LL482 + add %g2,-4,%g2 +.LL428: + addcc %l3,-1,%l3 +.LL481: + bne .LL407 + st %o7,[%l2-4] +.LL406: + sethi %hi(avma),%o0 + cmp %i5,-1 + be .LL434 + ld [%o0+%lo(avma)],%i0 + add %i4,2,%l1 + sll %l1,2,%o0 + add %l4,%o0,%l2 + ld [%l4+4],%o0 + cmp %o0,0 + be .LL435 + cmp %i4,0 + b .LL436 + add %i4,3,%l1 +.LL435: + be,a .LL436 + st %g0,[%fp-32] +.LL436: + call cgeti,0 + mov %l1,%o0 + st %o0,[%fp-36] + sll %l1,2,%o0 + ld [%fp-36],%g1 + addcc %l1,-2,%l0 + be .LL439 + add %g1,%o0,%o1 +.LL440: + add %o1,-4,%o1 + add %l2,-4,%l2 + ld [%l2],%o0 + addcc %l0,-1,%l0 + bne .LL440 + st %o0,[%o1] +.LL439: + cmp %l1,2 + bgu .LL442 + mov 2,%o0 + ld [%fp-36],%g4 + b .LL434 + st %o0,[%g4+4] +.LL442: + ld [%fp-36],%g1 + ld [%g1],%o0 + sethi %hi(-16777216),%o1 + andn %o0,%o1,%o1 + ld [%fp-32],%g4 + sll %g4,24,%o0 + add %o1,%o0,%o1 + st %o1,[%g1+4] +.LL434: + cmp %i5,0 + be .LL483 + cmp %i5,-1 + add %i4,2,%l0 + cmp %l0,%l5 + bge .LL484 + sll %l0,2,%o0 + ld [%l4+%o0],%o0 + cmp %o0,0 + bne .LL484 + cmp %l0,%l5 + add %i4,3,%l0 +.LL447: + cmp %l0,%l5 + bge .LL484 + sll %l0,2,%o0 + ld [%l4+%o0],%o0 + cmp %o0,0 + be,a .LL447 + add %l0,1,%l0 + cmp %l0,%l5 +.LL484: + bne .LL451 + sub %l5,%l0,%o0 + sethi %hi(gzero),%o0 + call icopy,0 + ld [%o0+%lo(gzero)],%o0 + b .LL444 + mov %o0,%l6 +.LL451: + call cgeti,0 + add %o0,2,%o0 + mov %o0,%l6 + ld [%l6],%o0 + cmp %l7,0 + bne .LL453 + st %o0,[%l6+4] + cmp %l0,%l5 + bge .LL459 + mov 2,%l3 +.LL457: + sll %l3,2,%o0 + sll %l0,2,%o1 + ld [%l4+%o1],%o1 + st %o1,[%l6+%o0] + add %l0,1,%l0 + cmp %l0,%l5 + bl .LL457 + add %l3,1,%l3 + b .LL477 + ld [%l6+4],%o0 +.LL453: + st %g0,[%fp-20] + sll %l0,2,%o0 + ld [%l4+%o0],%o2 + add %l0,1,%l0 + mov 32,%o0 + sub %o0,%l7,%o0 + sll %o2,%o0,%o0 + st %o0,[%fp-20] + srl %o2,%l7,%o3 + cmp %o3,0 + be .LL460 + mov %o0,%g2 + st %o3,[%l6+8] + b .LL461 + mov 1,%o0 +.LL460: + ld [%l6],%o0 + add %o0,-1,%o0 + st %o0,[%l6+4] + add %l6,4,%l6 + sethi %hi(avma),%o1 + ld [%o1+%lo(avma)],%o0 + add %o0,4,%o0 + st %o0,[%o1+%lo(avma)] + ld [%l6],%o0 + st %o0,[%l6+4] + mov 0,%o0 +.LL461: + cmp %l0,%l5 + bge .LL459 + add %o0,2,%l3 + mov 32,%o0 + sub %o0,%l7,%o3 +.LL465: + sll %l3,2,%o1 + sll %l0,2,%o0 + ld [%l4+%o0],%o2 + sll %o2,%o3,%o0 + st %o0,[%fp-20] + srl %o2,%l7,%o0 + add %o0,%g2,%o0 + st %o0,[%l6+%o1] + ld [%fp-20],%g2 + add %l0,1,%l0 + cmp %l0,%l5 + bl .LL465 + add %l3,1,%l3 +.LL459: + ld [%l6+4],%o0 +.LL477: + sethi %hi(-16777216),%o1 + andn %o0,%o1,%o1 + ld [%fp-28],%g1 + sll %g1,24,%o0 + add %o1,%o0,%o1 + st %o1,[%l6+4] +.LL444: + cmp %i5,-1 +.LL483: + bne .LL467 + cmp %i5,0 + ld [%fp-24],%o0 + mov %i0,%o1 + b .LL474 + mov %l6,%o2 +.LL467: + be .LL468 + ld [%fp-24],%o0 + mov %i0,%o1 + call gerepile,0 + mov 0,%o2 + and %o0,-4,%o0 + add %l6,%o0,%o1 + st %o1,[%i5] + ld [%fp-36],%g4 + b .LL469 + add %g4,%o0,%i0 +.LL468: + mov %i0,%o1 + ld [%fp-36],%o2 +.LL474: + call gerepile,0 + nop + mov %o0,%i0 +.LL469: + ret + restore +.LLfe13: + .size dvmdii,.LLfe13-dvmdii + .align 4 + .global mulul3 + .type mulul3,#function + .proc 016 +mulul3: + !#PROLOGUE# 0 + save %sp,-112,%sp + !#PROLOGUE# 1 + + or %i0,%i1,%o4 + mov %i0,%y + andncc %o4,0xfff,%g0 + be 2f + andcc %g0,%g0,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%g0,%o4 + tst %i1 + bl,a 1f + add %o4,%i0,%o4 +1: mov %o4,%g2 + b 3f + rd %y,%i0 +2: clr %g2 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%g0,%o4 + rd %y,%o5 + sll %o4,12,%o4 + srl %o5,20,%o5 + or %o5,%o4,%i0 +3: + + st %g2,[%i2] + ret + restore +.LLfe14: + .size mulul3,.LLfe14-mulul3 + .ident "GCC: (GNU) 2.8.1" diff --git a/mp/mpi-sparc.s b/mp/mpi-sparc.s new file mode 100755 index 0000000..d787dc7 --- /dev/null +++ b/mp/mpi-sparc.s @@ -0,0 +1,2808 @@ +gcc2_compiled.: +___gnu_compiled_c: +.text + .align 4 + .global _mulsi + .proc 0104 +_mulsi: + !#PROLOGUE# 0 + save %sp,-104,%sp + !#PROLOGUE# 1 + ld [%i1+4],%o1 + sra %o1,24,%l1 + sethi %hi(65535),%o0 + or %o0,%lo(65535),%o0 + cmp %i0,0 + be L3 + and %o1,%o0,%l0 + cmp %l1,0 + bne L2 + cmp %i0,0 +L3: + sethi %hi(_gzero),%o0 + b L12 + ld [%o0+%lo(_gzero)],%i0 +L2: + bge L4 + nop + subcc %g0,%i0,%i0 + bpos L4 + sub %g0,%l1,%l1 + call _stoi,0 + sethi %hi(-2147483648),%o0 + call _mulii,0 + mov %i1,%o1 + b L12 + mov %o0,%i0 +L4: + call _cgeti,0 + add %l0,1,%o0 + mov %o0,%g3 + mov 0,%o2 + sll %l0,2,%o0 + add %i1,%o0,%i1 + add %g3,%o0,%g2 + addcc %l0,-2,%o3 + be L7 + add %g2,4,%g2 +L8: + add %g2,-4,%g2 + mov %o2,%o0 + add %i1,-4,%i1 + ld [%i1],%o1 + mov %i0,%l2 + + or %l2,%o1,%o4 + mov %l2,%y + andncc %o4,0xfff,%g0 + be 2f + andcc %g0,%g0,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%g0,%o4 + tst %o1 + bl,a 1f + add %o4,%l2,%o4 +1: mov %o4,%o2 + b 3f + rd %y,%l2 +2: clr %o2 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%g0,%o4 + rd %y,%o5 + sll %o4,12,%o4 + srl %o5,20,%o5 + or %o5,%o4,%l2 +3: + + mov %l2,%o1 + addcc %o0,%o1,%l2 + addx %o2,%g0,%o2 + addcc %o3,-1,%o3 + bne L8 + st %l2,[%g2] +L7: + cmp %o2,0 + be L10 + sethi %hi(-65536),%o1 + st %o2,[%g2-4] + ld [%g3+4],%o0 + and %o0,%o1,%o0 + add %o0,%l0,%o0 + b L13 + add %o0,1,%o0 +L10: + sethi %hi(_avma),%o1 + ld [%o1+%lo(_avma)],%o0 + add %o0,4,%o0 + st %o0,[%o1+%lo(_avma)] + ld [%g3],%o0 + add %o0,-1,%o0 + st %o0,[%g3+4] + add %g3,4,%g3 + ld [%g3+4],%o0 + sethi %hi(-65536),%o1 + and %o0,%o1,%o0 + add %o0,%l0,%o0 +L13: + st %o0,[%g3+4] + ld [%g3+4],%o0 + sethi %hi(-16777216),%o1 + andn %o0,%o1,%o1 + sll %l1,24,%o0 + add %o1,%o0,%o1 + st %o1,[%g3+4] + mov %g3,%i0 +L12: + ret + restore + .align 4 + .global _expi + .proc 04 +_expi: + !#PROLOGUE# 0 + save %sp,-104,%sp + !#PROLOGUE# 1 + mov %i0,%o2 + ld [%o2+4],%o1 + sethi %hi(65535),%o0 + or %o0,%lo(65535),%o0 + and %o1,%o0,%i0 + cmp %i0,2 + be,a L16 + sethi %hi(-8388608),%i0 + call _bfffo,0 + ld [%o2+8],%o0 + add %i0,-2,%i0 + sll %i0,5,%i0 + sub %i0,%o0,%i0 + add %i0,-1,%i0 +L16: + ret + restore + .align 4 + .global _addsi + .proc 0104 +_addsi: + !#PROLOGUE# 0 + save %sp,-104,%sp + !#PROLOGUE# 1 + orcc %i0,%g0,%l1 + bne,a L18 + ldsb [%i1+4],%l3 + call _icopy,0 + mov %i1,%o0 + b L67 + mov %o0,%i0 +L18: + cmp %l3,0 + bne L19 + cmp %l1,0 + call _stoi,0 + mov %l1,%o0 + b L67 + mov %o0,%i0 +L19: + bge,a L22 + mov 1,%l4 + subcc %g0,%l1,%l1 + bpos L22 + mov -1,%l4 + sethi %hi(_MOST_NEGS),%o0 + or %o0,%lo(_MOST_NEGS),%o0 + call _addii,0 + mov %i1,%o1 + b L67 + mov %o0,%i0 +L22: + ld [%i1+4],%o1 + sethi %hi(65535),%o0 + or %o0,%lo(65535),%o0 + cmp %l4,%l3 + bne L23 + and %o1,%o0,%l0 + mov %l1,%o1 + sll %l0,2,%l2 + add %l2,%i1,%o0 + ld [%o0-4],%o0 + add %o1,%o0,%o0 + cmp %o0,%o1 + bgeu L24 + mov %o0,%l1 + call _cgeti,0 + add %l0,1,%o0 + mov %o0,%i0 + add %l0,-1,%o2 + cmp %o2,2 + ble L69 + st %l1,[%i0+%l2] +L30: + sll %o2,2,%o1 + add %o1,%i1,%o0 + ld [%o0-4],%o0 + cmp %o0,-1 + bne L69 + cmp %o2,2 + add %o2,-1,%o2 + cmp %o2,2 + bg L30 + st %g0,[%i0+%o1] + cmp %o2,2 +L69: + ble L31 + sll %o2,2,%o1 + add %o1,%i1,%o0 + ld [%o0-4],%o0 + add %o0,1,%o0 + b L68 + st %o0,[%i0+%o1] +L34: + add %o0,%i1,%o1 + ld [%o1-4],%o1 + st %o1,[%i0+%o0] +L68: + add %o2,-1,%o2 + cmp %o2,2 + bg L34 + sll %o2,2,%o0 + ld [%i0],%o0 + add %o0,-1,%o0 + st %o0,[%i0+4] + st %o0,[%i0+8] + add %i0,4,%i0 + sethi %hi(_avma),%o1 + ld [%o1+%lo(_avma)],%o0 + add %o0,4,%o0 + b L37 + st %o0,[%o1+%lo(_avma)] +L31: + mov 1,%o0 + st %o0,[%i0+8] + ld [%i0],%o0 + b L37 + st %o0,[%i0+4] +L24: + call _cgeti,0 + mov %l0,%o0 + mov %o0,%i0 + sll %l0,2,%o0 + add %o0,%i0,%o0 + st %l1,[%o0-4] + mov 1,%o2 + add %l0,-1,%o0 + cmp %o2,%o0 + bge L37 + mov %o0,%o3 +L41: + sll %o2,2,%o1 + ld [%i1+%o1],%o0 + add %o2,1,%o2 + cmp %o2,%o3 + bl L41 + st %o0,[%i0+%o1] +L37: + ld [%i0+4],%o0 + sethi %hi(-16777216),%o1 + andn %o0,%o1,%o1 + sll %l4,24,%o0 + add %o1,%o0,%o1 + b L67 + st %o1,[%i0+4] +L23: + cmp %l0,3 + bne L44 + sll %l0,2,%l2 + ld [%i1+8],%o0 + cmp %o0,%l1 + bleu L45 + nop + call _cgeti,0 + mov 3,%o0 + mov %o0,%i0 + sll %l3,24,%o0 + add %o0,3,%o0 + st %o0,[%i0+4] + ld [%i1+8],%o0 + sub %o0,%l1,%o0 + b L67 + st %o0,[%i0+8] +L45: + bne L46 + sethi %hi(_gzero),%o0 + b L67 + ld [%o0+%lo(_gzero)],%i0 +L46: + call _cgeti,0 + mov 3,%o0 + mov %o0,%i0 + sub %g0,%l3,%o0 + sll %o0,24,%o0 + add %o0,3,%o0 + st %o0,[%i0+4] + ld [%i1+8],%o0 + sub %l1,%o0,%o0 + b L67 + st %o0,[%i0+8] +L44: + add %l2,%i1,%o0 + ld [%o0-4],%o1 + mov %l1,%o0 + cmp %o1,%o0 + bgeu L47 + sub %o1,%o0,%l1 + call _cgeti,0 + mov %l0,%o0 + mov %o0,%i0 + add %l2,%i0,%o0 + st %l1,[%o0-4] + add %l0,-2,%o2 + sll %o2,2,%o0 + mov %o0,%o1 + ld [%i1+%o0],%o0 + cmp %o0,0 + bne,a L70 + sll %o2,2,%o1 + mov -1,%o3 + st %o3,[%i0+%o1] +L71: + add %o2,-1,%o2 + sll %o2,2,%o1 + ld [%i1+%o1],%o0 + cmp %o0,0 + be,a L71 + st %o3,[%i0+%o1] + sll %o2,2,%o1 +L70: + ld [%i1+%o1],%o0 + add %o0,-1,%o0 + cmp %o2,2 + bg L54 + st %o0,[%i0+%o1] + cmp %o0,0 + be,a L53 + ld [%i0],%o0 +L54: + add %o2,-1,%o2 + cmp %o2,0 + ble L67 + nop +L58: + sll %o2,2,%o1 + ld [%i1+%o1],%o0 + add %o2,-1,%o2 + cmp %o2,0 + bg L58 + st %o0,[%i0+%o1] + b,a L67 +L53: + add %o0,-1,%o0 + st %o0,[%i0+4] + st %o0,[%i0+8] + add %i0,4,%i0 + sethi %hi(_avma),%o1 + ld [%o1+%lo(_avma)],%o0 + add %o0,4,%o0 + st %o0,[%o1+%lo(_avma)] + ld [%i0+4],%o1 + sethi %hi(-16777216),%o0 + andn %o1,%o0,%o0 + sll %l3,24,%o1 + add %o0,%o1,%o0 + b L67 + st %o0,[%i0+4] +L47: + call _cgeti,0 + mov %l0,%o0 + mov %o0,%i0 + sll %l0,2,%o0 + add %o0,%i0,%o0 + st %l1,[%o0-4] + mov 1,%o2 + add %l0,-1,%o0 + cmp %o2,%o0 + bge L67 + mov %o0,%o3 +L65: + sll %o2,2,%o1 + ld [%i1+%o1],%o0 + add %o2,1,%o2 + cmp %o2,%o3 + bl L65 + st %o0,[%i0+%o1] +L67: + ret + restore + .align 4 + .global _addii + .proc 0104 +_addii: + !#PROLOGUE# 0 + save %sp,-104,%sp + !#PROLOGUE# 1 + mov %i0,%l0 + ld [%l0+4],%o0 + sethi %hi(65535),%o1 + or %o1,%lo(65535),%o1 + and %o0,%o1,%l1 + ld [%i1+4],%o0 + and %o0,%o1,%l2 + cmp %l1,%l2 + bge,a L204 + ldsb [%i1+4],%o5 + mov %i1,%l0 + mov %i0,%i1 + mov %l1,%l3 + mov %l2,%l1 + mov %l3,%l2 + ldsb [%i1+4],%o5 +L204: + cmp %o5,0 + bne,a L74 + ldsb [%l0+4],%l3 + call _icopy,0 + mov %l0,%o0 + b L201 + mov %o0,%i0 +L74: + cmp %l3,%o5 + bne L75 + cmp %l1,%l2 + call _cgeti,0 + add %l1,1,%o0 + mov %o0,%i0 + mov 0,%o2 + sll %l1,2,%o0 + add %i0,%o0,%o4 + add %o4,4,%o4 + add %l0,%o0,%o3 + sll %l2,2,%o0 + add %i1,%o0,%o1 + add %l2,-2,%o5 + sethi %hi(L113),%o0 + or %o0,%lo(L113),%g2 + add %o5,-1,%o0 +L220: + cmp %o0,15 + bgu L81 + sll %o0,2,%o0 + ld [%o0+%g2],%o0 + jmp %o0 + nop +L113: + .word L111 + .word L109 + .word L107 + .word L105 + .word L103 + .word L101 + .word L99 + .word L97 + .word L95 + .word L93 + .word L91 + .word L89 + .word L87 + .word L85 + .word L83 + .word L81 +L81: + subcc %g0,%o2,%g0 + b L82 + add %o4,-4,%o4 +L83: + subcc %g0,%o2,%g0 + b L205 + add %o4,-4,%o4 +L85: + subcc %g0,%o2,%g0 + b L206 + add %o4,-4,%o4 +L87: + subcc %g0,%o2,%g0 + b L207 + add %o4,-4,%o4 +L89: + subcc %g0,%o2,%g0 + b L208 + add %o4,-4,%o4 +L91: + subcc %g0,%o2,%g0 + b L209 + add %o4,-4,%o4 +L93: + subcc %g0,%o2,%g0 + b L210 + add %o4,-4,%o4 +L95: + subcc %g0,%o2,%g0 + b L211 + add %o4,-4,%o4 +L97: + subcc %g0,%o2,%g0 + b L212 + add %o4,-4,%o4 +L99: + subcc %g0,%o2,%g0 + b L213 + add %o4,-4,%o4 +L101: + subcc %g0,%o2,%g0 + b L214 + add %o4,-4,%o4 +L103: + subcc %g0,%o2,%g0 + b L215 + add %o4,-4,%o4 +L105: + subcc %g0,%o2,%g0 + b L216 + add %o4,-4,%o4 +L107: + subcc %g0,%o2,%g0 + b L217 + add %o4,-4,%o4 +L109: + subcc %g0,%o2,%g0 + b L218 + add %o4,-4,%o4 +L111: + subcc %g0,%o2,%g0 + b L219 + add %o4,-4,%o4 +L82: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%l4 + ld [%o1],%g3 + addxcc %l4,%g3,%o0 + st %o0,[%o4] + add %o4,-4,%o4 +L205: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%l4 + ld [%o1],%g3 + addxcc %l4,%g3,%o0 + st %o0,[%o4] + add %o4,-4,%o4 +L206: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%l4 + ld [%o1],%g3 + addxcc %l4,%g3,%o0 + st %o0,[%o4] + add %o4,-4,%o4 +L207: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%l4 + ld [%o1],%g3 + addxcc %l4,%g3,%o0 + st %o0,[%o4] + add %o4,-4,%o4 +L208: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%l4 + ld [%o1],%g3 + addxcc %l4,%g3,%o0 + st %o0,[%o4] + add %o4,-4,%o4 +L209: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%l4 + ld [%o1],%g3 + addxcc %l4,%g3,%o0 + st %o0,[%o4] + add %o4,-4,%o4 +L210: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%l4 + ld [%o1],%g3 + addxcc %l4,%g3,%o0 + st %o0,[%o4] + add %o4,-4,%o4 +L211: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%l4 + ld [%o1],%g3 + addxcc %l4,%g3,%o0 + st %o0,[%o4] + add %o4,-4,%o4 +L212: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%l4 + ld [%o1],%g3 + addxcc %l4,%g3,%o0 + st %o0,[%o4] + add %o4,-4,%o4 +L213: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%l4 + ld [%o1],%g3 + addxcc %l4,%g3,%o0 + st %o0,[%o4] + add %o4,-4,%o4 +L214: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%l4 + ld [%o1],%g3 + addxcc %l4,%g3,%o0 + st %o0,[%o4] + add %o4,-4,%o4 +L215: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%l4 + ld [%o1],%g3 + addxcc %l4,%g3,%o0 + st %o0,[%o4] + add %o4,-4,%o4 +L216: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%l4 + ld [%o1],%g3 + addxcc %l4,%g3,%o0 + st %o0,[%o4] + add %o4,-4,%o4 +L217: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%l4 + ld [%o1],%g3 + addxcc %l4,%g3,%o0 + st %o0,[%o4] + add %o4,-4,%o4 +L218: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%l4 + ld [%o1],%g3 + addxcc %l4,%g3,%o0 + st %o0,[%o4] + add %o4,-4,%o4 +L219: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%l4 + ld [%o1],%g3 + addxcc %l4,%g3,%o0 + st %o0,[%o4] + addx %g0,%g0,%o2 + add %o5,-16,%o5 + cmp %o5,0 + bg,a L220 + add %o5,-1,%o0 + cmp %o2,0 + be L115 + add %l0,8,%o2 +L116: + add %o3,-4,%o3 + cmp %o3,%o2 + blu L117 + mov %o3,%o1 + ld [%o3],%o0 + cmp %o0,-1 + bne L118 + add %o4,-4,%o4 + b L116 + st %g0,[%o4] +L118: + ld [%o1],%o0 + b L203 + add %o0,1,%o0 +L122: + add %o4,-4,%o4 + ld [%o1],%o0 +L203: + st %o0,[%o4] + add %o3,-4,%o3 + cmp %o3,%o2 + bgeu L122 + mov %o3,%o1 + b L221 + ld [%i0],%o0 +L117: + mov 1,%o0 + st %o0,[%i0+8] + ld [%l0+4],%o0 + add %o0,1,%o0 + b L201 + st %o0,[%i0+4] +L115: + subcc %l1,%l2,%o2 + be,a L221 + ld [%i0],%o0 +L128: + add %o4,-4,%o4 + add %o3,-4,%o3 + ld [%o3],%o0 + addcc %o2,-1,%o2 + bne L128 + st %o0,[%o4] + ld [%i0],%o0 +L221: + add %o0,-1,%o0 + st %o0,[%i0+4] + ld [%l0+4],%o0 + st %o0,[%i0+8] + add %i0,4,%i0 + sethi %hi(_avma),%o1 + ld [%o1+%lo(_avma)],%o0 + add %o0,4,%o0 + b L201 + st %o0,[%o1+%lo(_avma)] +L75: + bne L131 + add %l0,8,%o3 + addcc %l1,-2,%o2 + be L140 + add %i1,8,%o1 + ld [%o3],%o4 +L222: + add %o3,4,%o3 + ld [%o1],%o0 + cmp %o0,%o4 + bgu L202 + add %o1,4,%o1 + cmp %o4,%o0 + bgu L131 + addcc %o2,-1,%o2 + bne,a L222 + ld [%o3],%o4 +L140: + sethi %hi(_gzero),%o0 + b L201 + ld [%o0+%lo(_gzero)],%i0 +L202: + mov %l0,%i0 + mov %i1,%l0 + mov %i0,%i1 + mov %o5,%l3 +L131: + call _cgeti,0 + mov %l1,%o0 + mov %o0,%i0 + mov 0,%o2 + sll %l1,2,%o0 + add %l0,%o0,%o3 + sll %l2,2,%o1 + add %i1,%o1,%o1 + add %i0,%o0,%o4 + add %l2,-2,%o5 + sethi %hi(L178),%o0 + or %o0,%lo(L178),%g2 + add %o5,-1,%o0 +L238: + cmp %o0,15 + bgu L146 + sll %o0,2,%o0 + ld [%o0+%g2],%o0 + jmp %o0 + nop +L178: + .word L176 + .word L174 + .word L172 + .word L170 + .word L168 + .word L166 + .word L164 + .word L162 + .word L160 + .word L158 + .word L156 + .word L154 + .word L152 + .word L150 + .word L148 + .word L146 +L146: + subcc %g0,%o2,%g0 + b L147 + add %o4,-4,%o4 +L148: + subcc %g0,%o2,%g0 + b L223 + add %o4,-4,%o4 +L150: + subcc %g0,%o2,%g0 + b L224 + add %o4,-4,%o4 +L152: + subcc %g0,%o2,%g0 + b L225 + add %o4,-4,%o4 +L154: + subcc %g0,%o2,%g0 + b L226 + add %o4,-4,%o4 +L156: + subcc %g0,%o2,%g0 + b L227 + add %o4,-4,%o4 +L158: + subcc %g0,%o2,%g0 + b L228 + add %o4,-4,%o4 +L160: + subcc %g0,%o2,%g0 + b L229 + add %o4,-4,%o4 +L162: + subcc %g0,%o2,%g0 + b L230 + add %o4,-4,%o4 +L164: + subcc %g0,%o2,%g0 + b L231 + add %o4,-4,%o4 +L166: + subcc %g0,%o2,%g0 + b L232 + add %o4,-4,%o4 +L168: + subcc %g0,%o2,%g0 + b L233 + add %o4,-4,%o4 +L170: + subcc %g0,%o2,%g0 + b L234 + add %o4,-4,%o4 +L172: + subcc %g0,%o2,%g0 + b L235 + add %o4,-4,%o4 +L174: + subcc %g0,%o2,%g0 + b L236 + add %o4,-4,%o4 +L176: + subcc %g0,%o2,%g0 + b L237 + add %o4,-4,%o4 +L147: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%l4 + ld [%o1],%g3 + subxcc %l4,%g3,%o0 + st %o0,[%o4] + add %o4,-4,%o4 +L223: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%l4 + ld [%o1],%g3 + subxcc %l4,%g3,%o0 + st %o0,[%o4] + add %o4,-4,%o4 +L224: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%l4 + ld [%o1],%g3 + subxcc %l4,%g3,%o0 + st %o0,[%o4] + add %o4,-4,%o4 +L225: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%l4 + ld [%o1],%g3 + subxcc %l4,%g3,%o0 + st %o0,[%o4] + add %o4,-4,%o4 +L226: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%l4 + ld [%o1],%g3 + subxcc %l4,%g3,%o0 + st %o0,[%o4] + add %o4,-4,%o4 +L227: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%l4 + ld [%o1],%g3 + subxcc %l4,%g3,%o0 + st %o0,[%o4] + add %o4,-4,%o4 +L228: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%l4 + ld [%o1],%g3 + subxcc %l4,%g3,%o0 + st %o0,[%o4] + add %o4,-4,%o4 +L229: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%l4 + ld [%o1],%g3 + subxcc %l4,%g3,%o0 + st %o0,[%o4] + add %o4,-4,%o4 +L230: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%l4 + ld [%o1],%g3 + subxcc %l4,%g3,%o0 + st %o0,[%o4] + add %o4,-4,%o4 +L231: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%l4 + ld [%o1],%g3 + subxcc %l4,%g3,%o0 + st %o0,[%o4] + add %o4,-4,%o4 +L232: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%l4 + ld [%o1],%g3 + subxcc %l4,%g3,%o0 + st %o0,[%o4] + add %o4,-4,%o4 +L233: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%l4 + ld [%o1],%g3 + subxcc %l4,%g3,%o0 + st %o0,[%o4] + add %o4,-4,%o4 +L234: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%l4 + ld [%o1],%g3 + subxcc %l4,%g3,%o0 + st %o0,[%o4] + add %o4,-4,%o4 +L235: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%l4 + ld [%o1],%g3 + subxcc %l4,%g3,%o0 + st %o0,[%o4] + add %o4,-4,%o4 +L236: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%l4 + ld [%o1],%g3 + subxcc %l4,%g3,%o0 + st %o0,[%o4] + add %o4,-4,%o4 +L237: + add %o3,-4,%o3 + add %o1,-4,%o1 + ld [%o3],%l4 + ld [%o1],%g3 + subxcc %l4,%g3,%o0 + st %o0,[%o4] + addx %g0,%g0,%o2 + add %o5,-16,%o5 + cmp %o5,0 + bg,a L238 + add %o5,-1,%o0 + cmp %o2,0 + be,a L180 + subcc %l1,%l2,%o5 + add %o3,-4,%o3 + ld [%o3],%o0 + cmp %o0,0 + bne L239 + add %l0,8,%o1 + mov -1,%o1 + add %o4,-4,%o4 +L240: + st %o1,[%o4] + add %o3,-4,%o3 + ld [%o3],%o0 + cmp %o0,0 + be,a L240 + add %o4,-4,%o4 + add %l0,8,%o1 +L239: + cmp %o3,%o1 + blu L190 + add %o0,-1,%o0 + add %o4,-4,%o4 + st %o0,[%o4] + add %o3,-4,%o3 + cmp %o3,%o1 + blu L190 + mov %o3,%o0 +L188: + add %o4,-4,%o4 + ld [%o0],%o0 + st %o0,[%o4] + add %o3,-4,%o3 + cmp %o3,%o1 + bgeu L188 + mov %o3,%o0 + b L241 + ld [%i0+8],%o0 +L180: + be,a L241 + ld [%i0+8],%o0 +L193: + add %o4,-4,%o4 + add %o3,-4,%o3 + ld [%o3],%o0 + addcc %o5,-1,%o5 + bne L193 + st %o0,[%o4] +L190: + ld [%i0+8],%o0 +L241: + cmp %o0,0 + be,a L195 + ld [%i0+12],%o0 + ld [%l0+4],%o0 + b L201 + st %o0,[%i0+4] +L195: + cmp %o0,0 + bne L198 + add %i0,12,%o4 + add %o4,4,%o4 +L242: + ld [%o4],%o0 + cmp %o0,0 + be,a L242 + add %o4,4,%o4 +L198: + add %o4,-8,%o4 + sub %o4,%i0,%o5 + sra %o5,2,%o5 + ld [%i0],%o1 + sub %o1,%o5,%o1 + st %o1,[%o4] + st %o1,[%o4+4] + mov %o4,%i0 + sethi %hi(-16777216),%o0 + andn %o1,%o0,%o0 + sll %l3,24,%o1 + add %o0,%o1,%o0 + st %o0,[%i0+4] + sethi %hi(_avma),%o2 + sll %o5,2,%o0 + ld [%o2+%lo(_avma)],%o1 + add %o0,%o1,%o0 + st %o0,[%o2+%lo(_avma)] +L201: + ret + restore + .align 4 + .global _mulss + .proc 0104 +_mulss: + !#PROLOGUE# 0 + save %sp,-104,%sp + !#PROLOGUE# 1 + orcc %i0,%g0,%o0 + be L245 + cmp %i1,0 + bne L244 + cmp %o0,0 +L245: + sethi %hi(_gzero),%o0 + b L253 + ld [%o0+%lo(_gzero)],%i0 +L244: + bge L246 + mov 1,%l0 + subcc %g0,%o0,%o0 + bpos L246 + mov -1,%l0 + call _stoi,0 + nop + mov %o0,%o1 + b L254 + mov %i1,%o0 +L246: + cmp %i1,0 + bge L255 + mov %o0,%l1 + subcc %g0,%i1,%i1 + bpos L255 + sub %g0,%l0,%l0 + cmp %l0,0 + bg L250 + mov %o0,%o1 + sub %g0,%o0,%o1 +L250: + mov %o1,%o0 + sethi %hi(_ABS_MOST_NEGS),%o1 + or %o1,%lo(_ABS_MOST_NEGS),%o1 +L254: + call _mulsi,0 + nop + b L253 + mov %o0,%i0 +L255: + + or %l1,%i1,%o4 + mov %l1,%y + andncc %o4,0xfff,%g0 + be 2f + andcc %g0,%g0,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%g0,%o4 + tst %i1 + bl,a 1f + add %o4,%l1,%o4 +1: mov %o4,%o2 + b 3f + rd %y,%l1 +2: clr %o2 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%g0,%o4 + rd %y,%o5 + sll %o4,12,%o4 + srl %o5,20,%o5 + or %o5,%o4,%l1 +3: + + orcc %o2,%g0,%i1 + be L251 + nop + call _cgeti,0 + mov 4,%o0 + mov %o0,%i0 + st %i1,[%i0+8] + b L252 + st %l1,[%i0+12] +L251: + call _cgeti,0 + mov 3,%o0 + mov %o0,%i0 + st %l1,[%i0+8] +L252: + ld [%i0],%o0 + sethi %hi(-16777216),%o1 + andn %o0,%o1,%o1 + sll %l0,24,%o0 + add %o1,%o0,%o1 + st %o1,[%i0+4] +L253: + ret + restore + .align 4 + .global _mulii + .proc 0104 +_mulii: + !#PROLOGUE# 0 + save %sp,-104,%sp + !#PROLOGUE# 1 + mov %i0,%l4 + ld [%l4+4],%o0 + sethi %hi(65535),%o1 + or %o1,%lo(65535),%o1 + and %o0,%o1,%l0 + ld [%i1+4],%o2 + sra %o0,24,%l2 + cmp %l2,0 + be L276 + and %o2,%o1,%l3 + ldsb [%i1+4],%o0 + cmp %o0,0 + bne L258 + nop +L276: + sethi %hi(_gzero),%o0 + b L275 + ld [%o0+%lo(_gzero)],%i0 +L258: + bl,a L259 + sub %g0,%l2,%l2 +L259: + cmp %l0,%l3 + ble L260 + sethi %hi(65535),%o0 + mov %l4,%i0 + mov %i1,%l4 + mov %i0,%i1 + mov %l0,%l1 + mov %l3,%l0 + mov %l1,%l3 +L260: + add %l0,%l3,%l1 + add %l1,-2,%l1 + or %o0,%lo(65535),%o0 + cmp %l1,%o0 + ble L261 + nop + call _err,0 + mov 17,%o0 +L261: + call _cgeti,0 + mov %l1,%o0 + mov %o0,%i0 + ld [%i0],%o1 + sethi %hi(-16777216),%o0 + andn %o1,%o0,%o0 + sll %l2,24,%o1 + add %o0,%o1,%o0 + st %o0,[%i0+4] + sll %l0,2,%o0 + add %l4,%o0,%l2 + add %l2,-4,%l2 + ld [%l2],%o2 + mov 0,%o3 + sll %l3,2,%o0 + add %i1,%o0,%o7 + sll %l1,2,%o0 + addcc %l3,-2,%g2 + be L263 + add %i0,%o0,%g4 +L264: + add %g4,-4,%g4 + mov %o3,%o0 + add %o7,-4,%o7 + ld [%o7],%o1 + mov %o2,%l5 + + or %l5,%o1,%o4 + mov %l5,%y + andncc %o4,0xfff,%g0 + be 2f + andcc %g0,%g0,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%g0,%o4 + tst %o1 + bl,a 1f + add %o4,%l5,%o4 +1: mov %o4,%o3 + b 3f + rd %y,%l5 +2: clr %o3 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%o1,%o4 + mulscc %o4,%g0,%o4 + rd %y,%o5 + sll %o4,12,%o4 + srl %o5,20,%o5 + or %o5,%o4,%l5 +3: + + mov %l5,%o1 + addcc %o0,%o1,%l5 + addx %o3,%g0,%o3 + addcc %g2,-1,%g2 + bne L264 + st %l5,[%g4] +L263: + st %o3,[%g4-4] + sll %l1,2,%o0 + add %i0,%o0,%g4 + sll %l3,2,%o0 + add %i1,%o0,%i1 + add %l0,-3,%l0 + cmp %l0,0 + ble L267 + add %l3,-1,%l3 +L268: + add %l2,-4,%l2 + ld [%l2],%g1 + mov %i1,%o7 + add %g4,-4,%o2 + mov %o2,%g4 + addcc %l3,-1,%g2 + be L270 + mov 0,%g3 +L271: + add %o7,-4,%o7 + ld [%o7],%o0 + mov %o0,%o1 + + or %o1,%g1,%o4 + mov %o1,%y + andncc %o4,0xfff,%g0 + be 2f + andcc %g0,%g0,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g0,%o4 + tst %g1 + bl,a 1f + add %o4,%o1,%o4 +1: mov %o4,%o3 + b 3f + rd %y,%o1 +2: clr %o3 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g1,%o4 + mulscc %o4,%g0,%o4 + rd %y,%o5 + sll %o4,12,%o4 + srl %o5,20,%o5 + or %o5,%o4,%o1 +3: + + add %o2,-4,%o2 + ld [%o2],%o0 + addcc %o1,%o0,%o0 + addx %o3,%g0,%o3 + addcc %o0,%g3,%l5 + addx %o3,%g0,%o3 + st %l5,[%o2] + addcc %g2,-1,%g2 + bne L271 + mov %o3,%g3 +L270: + add %l0,-1,%l0 + cmp %l0,0 + bg L268 + st %o3,[%o2-4] +L267: + ld [%i0+8],%o0 + cmp %o0,0 + bne L275 + sethi %hi(_avma),%o1 + ld [%i0+4],%o0 + add %o0,-1,%o0 + st %o0,[%i0+8] + ld [%i0],%o0 + add %o0,-1,%o0 + st %o0,[%i0+4] + add %i0,4,%i0 + ld [%o1+%lo(_avma)],%o0 + add %o0,4,%o0 + st %o0,[%o1+%lo(_avma)] +L275: + ret + restore +.data + .align 8 +LC0: + .word 0x3fd34413 + .word 0x55475a32 + .align 8 +LC1: + .word 0x3ff00000 + .word 0x0 +.text + .align 4 + .global _confrac + .proc 0104 +_confrac: + !#PROLOGUE# 0 + save %sp,-112,%sp + !#PROLOGUE# 1 + ld [%i0],%o1 + sethi %hi(65535),%o0 + or %o0,%lo(65535),%o0 + and %o1,%o0,%l2 + ld [%i0+4],%o0 + sethi %hi(-16777216),%o1 + andn %o0,%o1,%o1 + sethi %hi(8388607),%o0 + or %o0,%lo(8388607),%o0 + sub %o0,%o1,%l0 + sethi %hi(_avma),%o0 + ld [%o0+%lo(_avma)],%l5 + add %l2,-2,%l4 + sll %l4,5,%l4 + add %l4,%l0,%l4 + add %l4,63,%l3 + sra %l3,5,%l3 + call _cgeti,0 + mov %l3,%o0 + sra %l0,5,%o1 + mov 0,%g2 + cmp %g2,%o1 + bge L279 + mov %o0,%l1 +L281: + sll %g2,2,%o0 + add %g2,1,%g2 + cmp %g2,%o1 + bl L281 + st %g0,[%l1+%o0] +L279: + andcc %l0,31,%l0 + bne L283 + mov 2,%g3 + cmp %g3,%l2 + bge L305 + sll %l3,2,%o0 +L287: + sll %g2,2,%o0 + sll %g3,2,%o1 + ld [%i0+%o1],%o1 + st %o1,[%l1+%o0] + add %g3,1,%g3 + cmp %g3,%l2 + bl L287 + add %g2,1,%g2 + b L305 + sll %l3,2,%o0 +L283: + cmp %g3,%l2 + bge L291 + mov 0,%o3 + mov 32,%o0 + sub %o0,%l0,%o4 +L293: + sll %g2,2,%o1 + sll %g3,2,%o0 + ld [%i0+%o0],%o2 + add %g2,1,%g2 + srl %o2,%l0,%o0 + add %o0,%o3,%o0 + st %o0,[%l1+%o1] + add %g3,1,%g3 + cmp %g3,%l2 + bl L293 + sll %o2,%o4,%o3 +L291: + sll %l3,2,%o0 + add %o0,%l1,%o0 + st %o3,[%o0-8] + sll %l3,2,%o0 +L305: + add %o0,%l1,%o0 + st %g0,[%o0-4] + st %l4,[%fp-12] + ld [%fp-12],%f6 + fitod %f6,%f2 + sethi %hi(LC0),%l6 + ldd [%l6+%lo(LC0)],%f4 + fmuld %f2,%f4,%f2 + sethi %hi(LC1),%l6 + ldd [%l6+%lo(LC1)],%f4 + faddd %f2,%f4,%f2 + fdtoi %f2,%f2 + st %f2,[%fp-12] + ld [%fp-12],%l0 + add %l0,17,%l2 + mov %l2,%o0 + call .div,0 + mov 9,%o1 + call _cgeti,0 + mov %o0,%l2 + mov %o0,%i0 + mov 1,%g3 + cmp %g3,%l2 + bge L296 + st %l0,[%i0] +L298: + addcc %l3,-1,%g2 + bneg L300 + mov 0,%o3 + sethi %hi(1000000000),%o0 + or %o0,%lo(1000000000),%o7 +L302: + sll %g2,2,%o1 + mov %o3,%o2 + ld [%l1+%o1],%o0 + + or %o0,%o7,%o4 + mov %o0,%y + andncc %o4,0xfff,%g0 + be 2f + andcc %g0,%g0,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%g0,%o4 + tst %o7 + bl,a 1f + add %o4,%o0,%o4 +1: mov %o4,%o3 + b 3f + rd %y,%o0 +2: clr %o3 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%o7,%o4 + mulscc %o4,%g0,%o4 + rd %y,%o5 + sll %o4,12,%o4 + srl %o5,20,%o5 + or %o5,%o4,%o0 +3: + + addcc %o2,%o0,%l6 + addx %o3,%g0,%o3 + addcc %g2,-1,%g2 + bpos L302 + st %l6,[%l1+%o1] +L300: + sll %g3,2,%o0 + add %g3,1,%g3 + cmp %g3,%l2 + bl L298 + st %o3,[%i0+%o0] +L296: + sethi %hi(_avma),%o0 + st %l5,[%o0+%lo(_avma)] + ret + restore + .align 4 + .global _divss + .proc 0104 +_divss: + !#PROLOGUE# 0 + save %sp,-104,%sp + !#PROLOGUE# 1 + cmp %i1,0 + bne L315 + sethi %hi(-2147483648),%o0 + call _err,0 + mov 23,%o0 + sethi %hi(-2147483648),%o0 +L315: + cmp %i0,%o0 + bne L308 + sethi %hi(_hiremainder),%o0 + call _stoi,0 + mov %i0,%o0 + call _divis,0 + mov %i1,%o1 + b L316 + mov %o0,%i0 +L308: + st %g0,[%o0+%lo(_hiremainder)] + cmp %i0,0 + bge L309 + mov %i0,%o0 + sub %g0,%i0,%o0 +L309: + cmp %i1,0 + bge L310 + mov %i1,%o1 + sub %g0,%i1,%o1 +L310: + sethi %hi(_hiremainder),%l0 + call _divul3,0 + or %l0,%lo(_hiremainder),%o2 + cmp %i1,0 + bge L311 + mov %o0,%o1 + ld [%l0+%lo(_hiremainder)],%o0 + sub %g0,%o0,%o0 + st %o0,[%l0+%lo(_hiremainder)] + sub %g0,%o1,%o1 +L311: + cmp %i0,0 + bl,a L312 + sub %g0,%o1,%o1 +L312: + call _stoi,0 + mov %o1,%o0 + mov %o0,%i0 +L316: + ret + restore + .align 4 + .global _modss + .proc 0104 +_modss: + !#PROLOGUE# 0 + save %sp,-112,%sp + !#PROLOGUE# 1 + cmp %i1,0 + bne L327 + sethi %hi(-2147483648),%o0 + call _err,0 + mov 38,%o0 + sethi %hi(-2147483648),%o0 +L327: + cmp %i0,%o0 + bne L319 + mov %i0,%o0 + call _stoi,0 + mov %i0,%o0 + call _modis,0 + mov %i1,%o1 + b L325 + mov %o0,%i0 +L319: + cmp %o0,0 + bge L320 + st %g0,[%fp-12] + sub %g0,%o0,%o0 +L320: + cmp %i1,0 + bl,a L321 + sub %g0,%i1,%i1 +L321: + mov %i1,%o1 + call _divul3,0 + add %fp,-12,%o2 + ld [%fp-12],%o0 + cmp %o0,0 + bne L322 + nop + sethi %hi(_gzero),%o0 + b L325 + ld [%o0+%lo(_gzero)],%i0 +L322: + bge,a L326 + ld [%fp-12],%o0 + sub %i1,%o0,%o0 +L326: + call _stoi,0 + nop + mov %o0,%i0 +L325: + ret + restore + .align 4 + .global _resss + .proc 0104 +_resss: + !#PROLOGUE# 0 + save %sp,-112,%sp + !#PROLOGUE# 1 + cmp %i1,0 + bne L335 + mov %i0,%o0 + call _err,0 + mov 40,%o0 + mov %i0,%o0 +L335: + cmp %o0,0 + bge L330 + st %g0,[%fp-12] + sub %g0,%o0,%o0 +L330: + cmp %i1,0 + bge L331 + mov %i1,%o1 + sub %g0,%i1,%o1 +L331: + call _divul3,0 + add %fp,-12,%o2 + cmp %i1,0 + bge L334 + ld [%fp-12],%o0 + sub %g0,%o0,%o0 +L334: + call _stoi,0 + nop + mov %o0,%i0 + ret + restore + .align 4 + .global _divsi + .proc 0104 +_divsi: + !#PROLOGUE# 0 + save %sp,-104,%sp + !#PROLOGUE# 1 + ld [%i1+4],%o0 + sra %o0,24,%o2 + sethi %hi(65535),%o1 + or %o1,%lo(65535),%o1 + cmp %o2,0 + bne L337 + and %o0,%o1,%l0 + call _err,0 + mov 24,%o0 +L337: + cmp %i0,0 + be L339 + cmp %l0,3 + bg L346 + sethi %hi(_hiremainder),%o0 + ld [%i1+8],%o0 + cmp %o0,0 + bge L338 + sethi %hi(-2147483648),%o0 +L339: + sethi %hi(_hiremainder),%o0 +L346: + st %i0,[%o0+%lo(_hiremainder)] + sethi %hi(_gzero),%o0 + b L344 + ld [%o0+%lo(_gzero)],%i0 +L338: + cmp %i0,%o0 + bne L340 + sethi %hi(_hiremainder),%o0 + call _stoi,0 + mov %i0,%o0 + mov %i1,%o1 + call _dvmdii,0 + mov 0,%o2 + b L344 + mov %o0,%i0 +L340: + st %g0,[%o0+%lo(_hiremainder)] + cmp %i0,0 + bge L341 + mov %i0,%o0 + sub %g0,%i0,%o0 +L341: + ld [%i1+8],%o1 + sethi %hi(_hiremainder),%l0 + call _divul3,0 + or %l0,%lo(_hiremainder),%o2 + mov %o0,%o1 + ldsb [%i1+4],%o0 + cmp %o0,0 + bge L347 + cmp %i0,0 + ld [%l0+%lo(_hiremainder)],%o0 + sub %g0,%o0,%o0 + st %o0,[%l0+%lo(_hiremainder)] + sub %g0,%o1,%o1 +L347: + bl,a L343 + sub %g0,%o1,%o1 +L343: + call _stoi,0 + mov %o1,%o0 + mov %o0,%i0 +L344: + ret + restore + .align 4 + .global _divis + .proc 0104 +_divis: + !#PROLOGUE# 0 + save %sp,-112,%sp + !#PROLOGUE# 1 + ld [%i0+4],%o1 + sra %o1,24,%l4 + sethi %hi(65535),%o0 + or %o0,%lo(65535),%o0 + cmp %i1,0 + bne L349 + and %o1,%o0,%l3 + call _err,0 + mov 26,%o0 +L349: + cmp %l4,0 + bne L350 + cmp %i1,0 + sethi %hi(_hiremainder),%o0 + b L365 + st %g0,[%o0+%lo(_hiremainder)] +L350: + bge,a L366 + ld [%i0+8],%o0 + subcc %g0,%i1,%i1 + bpos L351 + sub %g0,%l4,%l4 + call _stoi,0 + mov %i1,%o0 + mov %o0,%o1 + mov %i0,%o0 + call _dvmdii,0 + mov 0,%o2 + b L364 + mov %o0,%i0 +L351: + ld [%i0+8],%o0 +L366: + cmp %i1,%o0 + bleu L353 + cmp %l3,3 + bne L354 + sethi %hi(_hiremainder),%l0 + call _itos,0 + mov %i0,%o0 + st %o0,[%l0+%lo(_hiremainder)] +L365: + sethi %hi(_gzero),%o0 + b L364 + ld [%o0+%lo(_gzero)],%i0 +L354: + call _cgeti,0 + add %l3,-1,%o0 + mov %o0,%l2 + mov 1,%l1 + ld [%i0+8],%o0 + b L356 + st %o0,[%fp-12] +L353: + call _cgeti,0 + mov %l3,%o0 + mov %o0,%l2 + mov 0,%l1 + st %g0,[%fp-12] +L356: + add %l1,2,%l0 + cmp %l0,%l3 + bge,a L367 + ld [%l2],%o0 +L360: + sll %l0,2,%o0 + ld [%i0+%o0],%o0 + mov %i1,%o1 + call _divul3,0 + add %fp,-12,%o2 + sub %l0,%l1,%o1 + sll %o1,2,%o1 + add %l0,1,%l0 + cmp %l0,%l3 + bl L360 + st %o0,[%l2+%o1] + ld [%l2],%o0 +L367: + sethi %hi(-16777216),%o1 + andn %o0,%o1,%o1 + sll %l4,24,%o0 + add %o1,%o0,%o1 + st %o1,[%l2+4] + sethi %hi(_hiremainder),%o1 + cmp %l4,0 + bge L362 + or %o1,%lo(_hiremainder),%o2 + ld [%fp-12],%o0 + sub %g0,%o0,%o0 + b L363 + st %o0,[%o1+%lo(_hiremainder)] +L362: + ld [%fp-12],%o0 + st %o0,[%o2] +L363: + mov %l2,%i0 +L364: + ret + restore + .align 4 + .global _dvmdii + .proc 0104 +_dvmdii: + !#PROLOGUE# 0 + save %sp,-144,%sp + !#PROLOGUE# 1 + mov %i2,%i4 + ldsb [%i0+4],%g4 + st %g4,[%fp-28] + ldsb [%i1+4],%g1 + cmp %g1,0 + bne L369 + st %g1,[%fp-36] + call _err,0 + mov 36,%o0 +L369: + ld [%fp-28],%g4 + cmp %g4,0 + bne,a L370 + ld [%i0+4],%o0 + cmp %i4,-1 + be L471 + cmp %i4,0 + be L471 + sethi %hi(_gzero),%o1 + ld [%o1+%lo(_gzero)],%o0 + st %o0,[%i4] + b L470 + ld [%o1+%lo(_gzero)],%i0 +L370: + sethi %hi(65535),%o1 + or %o1,%lo(65535),%o1 + and %o0,%o1,%l6 + ld [%i1+4],%o0 + and %o0,%o1,%i3 + subcc %l6,%i3,%i5 + bpos,a L373 + sethi %hi(_avma),%o0 + cmp %i4,-1 + bne L374 + cmp %i4,0 + call _icopy,0 + mov %i0,%o0 + b L470 + mov %o0,%i0 +L374: + be L477 + sethi %hi(_gzero),%o0 + call _icopy,0 + mov %i0,%o0 + b L471 + st %o0,[%i4] +L373: + ld [%o0+%lo(_avma)],%o0 + st %o0,[%fp-20] + ld [%fp-28],%g1 + cmp %g1,0 + bge L478 + cmp %i3,3 + ld [%fp-36],%g4 + sub %g0,%g4,%g4 + st %g4,[%fp-36] +L478: + bne L377 + nop + ld [%i1+8],%i1 + ld [%i0+8],%o0 + cmp %i1,%o0 + bleu L378 + add %i0,8,%l1 + add %l6,-1,%l0 + st %o0,[%fp-12] + b L379 + add %i0,12,%l1 +L378: + mov %l6,%l0 + st %g0,[%fp-12] +L379: + call _cgeti,0 + mov %l0,%o0 + mov %o0,%l5 + addcc %l0,-2,%l3 + be L381 + add %l5,8,%l2 +L382: + ld [%l1],%o0 + add %l1,4,%l1 + mov %i1,%o1 + call _divul3,0 + add %fp,-12,%o2 + st %o0,[%l2] + addcc %l3,-1,%l3 + bne L382 + add %l2,4,%l2 +L381: + cmp %i4,-1 + bne L384 + cmp %l0,2 + sethi %hi(_avma),%o0 + ld [%fp-20],%g1 + st %g1,[%o0+%lo(_avma)] + ld [%fp-12],%o0 + cmp %o0,0 + bne L385 + nop +L471: + sethi %hi(_gzero),%o0 +L477: + b L470 + ld [%o0+%lo(_gzero)],%i0 +L385: + call _cgeti,0 + mov 3,%o0 + mov %o0,%l4 + ld [%fp-28],%g4 + sll %g4,24,%o0 + add %o0,3,%o0 + st %o0,[%l4+4] + ld [%fp-12],%o0 + st %o0,[%l4+8] + b L470 + mov %l4,%i0 +L384: + be L386 + sethi %hi(-16777216),%o1 + ld [%l5],%o0 + andn %o0,%o1,%o1 + ld [%fp-36],%g1 + sll %g1,24,%o0 + add %o1,%o0,%o1 + b L387 + st %o1,[%l5+4] +L386: + sethi %hi(_avma),%o0 + ld [%fp-20],%g4 + st %g4,[%o0+%lo(_avma)] + sethi %hi(_gzero),%o0 + ld [%o0+%lo(_gzero)],%l5 +L387: + cmp %i4,0 + bne L388 + ld [%fp-12],%o0 +L473: + b L470 + mov %l5,%i0 +L388: + cmp %o0,0 + bne L389 + sethi %hi(_gzero),%o0 + ld [%o0+%lo(_gzero)],%o0 + b L473 + st %o0,[%i4] +L389: + call _cgeti,0 + mov 3,%o0 + mov %o0,%l4 + ld [%fp-28],%g1 + sll %g1,24,%o0 + add %o0,3,%o0 + st %o0,[%l4+4] + ld [%fp-12],%o0 + st %o0,[%l4+8] + b L473 + st %l4,[%i4] +L377: + call _cgeti,0 + mov %l6,%o0 + mov %o0,%l5 + call _bfffo,0 + ld [%i1+8],%o0 + orcc %o0,%g0,%i2 + be L392 + add %i0,8,%l1 + call _cgeti,0 + mov %i3,%o0 + mov %o0,%l4 + ld [%i1+8],%o3 + add %i1,12,%o1 + mov 32,%o0 + sub %o0,%i2,%o0 + srl %o3,%o0,%o0 + st %o0,[%fp-12] + sll %o3,%i2,%g2 + addcc %i3,-3,%l3 + be L394 + add %l4,8,%o2 + mov 32,%o0 + sub %o0,%i2,%o4 +L395: + ld [%o1],%o3 + add %o1,4,%o1 + srl %o3,%o4,%o0 + st %o0,[%fp-12] + add %g2,%o0,%o0 + st %o0,[%o2] + add %o2,4,%o2 + addcc %l3,-1,%l3 + bne L395 + sll %o3,%i2,%g2 +L394: + st %g2,[%o2] + mov 0,%g2 + add %i0,8,%l1 + addcc %l6,-2,%l3 + be L398 + add %l5,4,%l2 + mov 32,%o0 + sub %o0,%i2,%o1 +L399: + ld [%l1],%o3 + add %l1,4,%l1 + srl %o3,%o1,%o0 + st %o0,[%fp-12] + add %g2,%o0,%o0 + st %o0,[%l2] + add %l2,4,%l2 + addcc %l3,-1,%l3 + bne L399 + sll %o3,%i2,%g2 +L398: + b L401 + st %g2,[%l2] +L392: + st %g0,[%l5+4] + addcc %l6,-2,%l0 + be L403 + add %l5,8,%l2 +L404: + ld [%l1],%o0 + st %o0,[%l2] + add %l1,4,%l1 + addcc %l0,-1,%l0 + bne L404 + add %l2,4,%l2 +L403: + mov %i1,%l4 +L401: + ld [%l4+8],%i1 + ld [%l4+12],%i0 + addcc %i5,1,%l3 + be L407 + add %l5,4,%l2 + sll %i3,2,%l1 +L408: + ld [%l2],%o0 + cmp %o0,%i1 + bne L409 + add %l2,4,%l2 + mov -1,%o7 + mov %i1,%o3 + ld [%l2],%o0 + add %o3,%o0,%o1 + cmp %o1,%o3 + addx %g0,0,%o2 + b L410 + mov %o1,%g2 +L409: + ld [%l2-4],%o0 + st %o0,[%fp-12] + ld [%l2],%o0 + mov %i1,%o1 + call _divul3,0 + add %fp,-12,%o2 + mov %o0,%o7 + mov 0,%o2 + ld [%fp-12],%g2 +L410: + cmp %o2,0 + bne,a L479 + st %g0,[%fp-12] + mov %o7,%o3 + + or %o3,%i0,%o4 + mov %o3,%y + andncc %o4,0xfff,%g0 + be 2f + andcc %g0,%g0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%g0,%o4 + tst %i0 + bl,a 1f + add %o4,%o3,%o4 +1: mov %o4,%g4 + b 3f + rd %y,%o3 +2: clr %g4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%i0,%o4 + mulscc %o4,%g0,%o4 + rd %y,%o5 + sll %o4,12,%o4 + srl %o5,20,%o5 + or %o5,%o4,%o3 +3: + + st %g4,[%fp-12] + ld [%l2+4],%o0 + cmp %o3,%o0 + addx %g0,0,%o2 + sub %o3,%o0,%o4 + ld [%fp-12],%o3 + mov %g2,%o0 + sub %o3,%g2,%o1 + cmp %g2,%o3 + bgu L476 + sub %o1,%o2,%o1 + b L480 + cmp %o0,%o3 +L424: + be L411 + mov %o4,%o3 + add %o7,-1,%o7 + mov %i0,%o0 + cmp %o3,%o0 + addx %g0,0,%o2 + sub %o3,%o0,%o4 + mov %o1,%o3 + mov %i1,%o0 + sub %o3,%o0,%o1 + cmp %o0,%o3 + bleu L480 + sub %o1,%o2,%o1 +L476: + b L421 + mov 1,%o2 +L480: + blu,a L421 + mov 0,%o2 +L421: + cmp %o2,0 + be L424 + cmp %o1,0 +L411: + st %g0,[%fp-12] +L479: + add %l2,%l1,%g2 + add %g2,-8,%g2 + addcc %i3,-2,%l0 + be L426 + add %l4,%l1,%g3 +L427: + ld [%fp-12],%o3 + add %g3,-4,%g3 + ld [%g3],%o0 + mov %o7,%o1 + + or %o1,%o0,%o4 + mov %o1,%y + andncc %o4,0xfff,%g0 + be 2f + andcc %g0,%g0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%g0,%o4 + tst %o0 + bl,a 1f + add %o4,%o1,%o4 +1: mov %o4,%g1 + b 3f + rd %y,%o1 +2: clr %g1 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%o0,%o4 + mulscc %o4,%g0,%o4 + rd %y,%o5 + sll %o4,12,%o4 + srl %o5,20,%o5 + or %o5,%o4,%o1 +3: + + st %g1,[%fp-12] + mov %g1,%g4 + addcc %o3,%o1,%o2 + addx %g4,%g0,%g4 + st %g4,[%fp-12] + add %g2,-4,%g2 + ld [%g2],%o3 + sub %o3,%o2,%o1 + cmp %o3,%o2 + st %o1,[%g2] + ld [%fp-12],%o0 + addx %g0,%o0,%o0 + addcc %l0,-1,%l0 + bne L427 + st %o0,[%fp-12] +L426: + ld [%l2-4],%o1 + ld [%fp-12],%o0 + cmp %o1,%o0 + bgeu,a L481 + addcc %l3,-1,%l3 + mov 0,%o2 + add %o7,-1,%o7 + add %l2,%l1,%g2 + add %g2,-8,%g2 + addcc %i3,-2,%l0 + be L429 + add %l4,%l1,%g3 + add %g2,-4,%g2 +L482: + subcc %g0,%o2,%g0 + add %g3,-4,%g3 + ld [%g2],%g1 + ld [%g3],%g4 + addxcc %g1,%g4,%o0 + st %o0,[%g2] + addx %g0,%g0,%o2 + addcc %l0,-1,%l0 + bne,a L482 + add %g2,-4,%g2 +L429: + addcc %l3,-1,%l3 +L481: + bne L408 + st %o7,[%l2-4] +L407: + sethi %hi(_avma),%o0 + cmp %i4,-1 + be L435 + ld [%o0+%lo(_avma)],%l4 + add %i5,2,%l1 + sll %l1,2,%o0 + add %l5,%o0,%l2 + ld [%l5+4],%o0 + cmp %o0,0 + be L436 + cmp %i5,0 + b L437 + add %i5,3,%l1 +L436: + be,a L437 + st %g0,[%fp-36] +L437: + call _cgeti,0 + mov %l1,%o0 + st %o0,[%fp-44] + sll %l1,2,%o0 + ld [%fp-44],%g1 + addcc %l1,-2,%l0 + be L440 + add %g1,%o0,%o1 +L441: + add %o1,-4,%o1 + add %l2,-4,%l2 + ld [%l2],%o0 + addcc %l0,-1,%l0 + bne L441 + st %o0,[%o1] +L440: + cmp %l1,2 + bgu L443 + mov 2,%o0 + ld [%fp-44],%g4 + b L435 + st %o0,[%g4+4] +L443: + ld [%fp-44],%g1 + ld [%g1],%o0 + sethi %hi(-16777216),%o1 + andn %o0,%o1,%o1 + ld [%fp-36],%g4 + sll %g4,24,%o0 + add %o1,%o0,%o1 + st %o1,[%g1+4] +L435: + cmp %i4,0 + be L483 + cmp %i4,-1 + add %i5,2,%l0 + cmp %l0,%l6 + bge L484 + sll %l0,2,%o0 + ld [%l5+%o0],%o0 + cmp %o0,0 + bne L484 + cmp %l0,%l6 + add %i5,3,%l0 +L448: + cmp %l0,%l6 + bge L484 + sll %l0,2,%o0 + ld [%l5+%o0],%o0 + cmp %o0,0 + be,a L448 + add %l0,1,%l0 + cmp %l0,%l6 +L484: + bne L452 + sub %l6,%l0,%o0 + sethi %hi(_gzero),%o0 + call _icopy,0 + ld [%o0+%lo(_gzero)],%o0 + b L445 + mov %o0,%l7 +L452: + call _cgeti,0 + add %o0,2,%o0 + mov %o0,%l7 + ld [%l7],%o0 + cmp %i2,0 + bne L454 + st %o0,[%l7+4] + cmp %l0,%l6 + bge L460 + mov 2,%l3 +L458: + sll %l3,2,%o0 + sll %l0,2,%o1 + ld [%l5+%o1],%o1 + st %o1,[%l7+%o0] + add %l0,1,%l0 + cmp %l0,%l6 + bl L458 + add %l3,1,%l3 + b L485 + ld [%l7+4],%o0 +L454: + st %g0,[%fp-12] + sll %l0,2,%o0 + ld [%l5+%o0],%o3 + add %l0,1,%l0 + mov 32,%o0 + sub %o0,%i2,%o0 + sll %o3,%o0,%o0 + st %o0,[%fp-12] + srl %o3,%i2,%o2 + cmp %o2,0 + be L461 + mov %o0,%g2 + st %o2,[%l7+8] + b L462 + mov 1,%o0 +L461: + ld [%l7],%o0 + add %o0,-1,%o0 + st %o0,[%l7+4] + add %l7,4,%l7 + sethi %hi(_avma),%o1 + ld [%o1+%lo(_avma)],%o0 + add %o0,4,%o0 + st %o0,[%o1+%lo(_avma)] + ld [%l7],%o0 + st %o0,[%l7+4] + mov 0,%o0 +L462: + cmp %l0,%l6 + bge L460 + add %o0,2,%l3 + mov 32,%o0 + sub %o0,%i2,%o4 +L466: + sll %l3,2,%o2 + sll %l0,2,%o0 + ld [%l5+%o0],%o3 + sll %o3,%o4,%o1 + st %o1,[%fp-12] + srl %o3,%i2,%o0 + add %o0,%g2,%o0 + st %o0,[%l7+%o2] + mov %o1,%g2 + add %l0,1,%l0 + cmp %l0,%l6 + bl L466 + add %l3,1,%l3 +L460: + ld [%l7+4],%o0 +L485: + sethi %hi(-16777216),%o1 + andn %o0,%o1,%o1 + ld [%fp-28],%g1 + sll %g1,24,%o0 + add %o1,%o0,%o1 + st %o1,[%l7+4] +L445: + cmp %i4,-1 +L483: + bne L468 + cmp %i4,0 + ld [%fp-20],%o0 + mov %l4,%o1 + b L475 + mov %l7,%o2 +L468: + be L469 + ld [%fp-20],%o0 + mov %l4,%o1 + call _gerepile,0 + mov 0,%o2 + and %o0,-4,%o0 + add %l7,%o0,%o1 + st %o1,[%i4] + ld [%fp-44],%g4 + b L470 + add %g4,%o0,%i0 +L469: + mov %l4,%o1 + ld [%fp-44],%o2 +L475: + call _gerepile,0 + nop + mov %o0,%i0 +L470: + ret + restore + .align 4 + .global _mulul3 + .proc 016 +_mulul3: + !#PROLOGUE# 0 + save %sp,-104,%sp + !#PROLOGUE# 1 + + or %i0,%i1,%o4 + mov %i0,%y + andncc %o4,0xfff,%g0 + be 2f + andcc %g0,%g0,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%g0,%o4 + tst %i1 + bl,a 1f + add %o4,%i0,%o4 +1: mov %o4,%g2 + b 3f + rd %y,%i0 +2: clr %g2 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%i1,%o4 + mulscc %o4,%g0,%o4 + rd %y,%o5 + sll %o4,12,%o4 + srl %o5,20,%o5 + or %o5,%o4,%i0 +3: + + st %g2,[%i2] + ret + restore diff --git a/mp/mpi.c b/mp/mpi.c new file mode 100755 index 0000000..b81eac0 --- /dev/null +++ b/mp/mpi.c @@ -0,0 +1,649 @@ + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +/*~ ~*/ +/*~ OPERATIONS DE BASE (NOYAU) ~*/ +/*~ ~*/ +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +/* This file was modified by W. Schelter to be suitable for optimization + and inlining of assembler for maximum speed + */ + +#include "config.h" +#include "genpari.h" +#include "arith.h" + +GEN mulsi(x,y) + plong x; + GEN y; +{ TEMPVARS + plong s=signe(y),ly=lgef(y),i; + GEN z,zp,yp; ulong hiremainder; + + if((!x)||(!s)) return gzero; + if(x<0) {s= -s; + x= -x; + if (x < 0) /* -2^31 */ + {return mulii(stoi(1<<31),y);} + } + z=cgeti(ly+1); + hiremainder=0; + MP_START_LOW(yp,y,ly); MP_START_LOW(zp,z,ly+1); + i = MP_COUNT_LG(ly); + WHILE_COUNT(--i) { MP_NEXT_UP(zp) = addmul(x,MP_NEXT_UP(yp));} + if(hiremainder) {MP_NEXT_UP(zp)=hiremainder; + setlgef(z,ly+1);} + else {avma+=4;z[1]=z[0]-1;z++;setlgef(z,ly);} + setsigne(z,s);return z; +} + +int expi(x) + GEN x; +{ + plong lx=x[1]&0xffff; + + return lx==2 ? -8388608 : ((lx-2)<<5)-bfffo(x[2])-1; +} + +GEN addsi(x,y) + plong x; + GEN y; +{ + plong sx,sy,ly,p,i; + ulong overflow; + GEN z; TEMPVARS + + + if(!x) return icopy(y); + sy=signe(y);if(!sy) return stoi(x); + if(x<0) {sx= -1; + x= -x; + if (x < 0) /* x=-2^31 */ + return addii(MOST_NEGS,y); + } else sx=1; + ly=lgef(y); + if(sx==sy) + { + p=addll(x,y[ly-1]); + if(overflow) + { + z=cgeti(ly+1);z[ly]=p; + for(i=ly-1;(i>2)&&(y[i-1]==0xffffffff);i--) z[i]=0; + if(i>2) + { + z[i]=y[i-1]+1;i--;while(i>=3) {z[i]=y[i-1];i--;} + z[2]=z[1]=z[0]-1;z++;avma+=4; + } + else {z[2]=1;z[1]=z[0];} + } + else + { + z=cgeti(ly);z[ly-1]=p;for(i=1;i(ulong)x) + { + z=cgeti(3);z[1]=(sy<<24)+3;z[2]=y[2]-x;return z; + } + if(y[2]==x) return gzero; + z=cgeti(3);z[1]=((-sy)<<24)+3;z[2]=x-y[2];return z; + } + p=subll(y[ly-1],x); + if(overflow) + { + z=cgeti(ly);z[ly-1]=p; + for(i=ly-2;!(y[i]);i--) z[i]=0xffffffff; + z[i]=y[i]-1; + if((i>2)||z[i]) {i--;for(;i>=1;i--) z[i]=y[i];} + else + { + z[2]=z[1]=z[0]-1;z++;avma+=4;setsigne(z,sy); + } + } + else + { + z=cgeti(ly);z[ly-1]=p;for(i=1;i=ly so sx==0 ==> sy==0 */ + + if (0 == (sy=signe(y))) return icopy(x); + sx = signe(x); + + if(sx==sy) + { + z=cgeti(lx+1);overflow=0; + MP_START_LOW(zp,z,lx+1); + MP_START_LOW(xp,x,lx); + MP_START_LOW(yp,y,ly); + +#ifdef QUICK_LOOP + i = ly - 2; + QUICK_LOOP(i,ADDXCC); +#else + i = MP_COUNT_LG(ly); + WHILE_COUNT(--i) + {ADDLLX(MP_NEXT_UP(xp),MP_NEXT_UP(yp),MP_NEXT_UP(zp));} +#endif + + + if(overflow) + { GEN xhigh = &MP_HIGH(x,lx); + again: + { GEN xpp = &MP_NEXT_UP(xp); + if (xpp >= xhigh) + { if (*xpp == 0xffffffff) + { MP_NEXT_UP(zp)=0; + goto again;} + + else + { MP_NEXT_UP(zp) = *xpp + 1; + while ((xpp = &MP_NEXT_UP(xp)) >= xhigh) + { MP_NEXT_UP(zp) = *xpp ;} + z[1]=z[0]-1;z[2]=x[1];z++;avma+=4;}} + else {z[2]=1;z[1]=x[1]+1;} + }} + else + { j = COUNT(lx - ly); + WHILE_COUNT( --j) + { MP_NEXT_UP(zp) = MP_NEXT_UP(xp);} + z[1]=z[0]-1;z[2]=x[1];z++;avma+=4; + } + } + else + { + if(lx==ly) + /* we have to compare x and y */ + { j = MP_COUNT_LG(lx); + MP_START_HIGH(xp,x,lx); + MP_START_HIGH(yp,y,lx); + WHILE_COUNT(--j) + { ulong tx = MP_NEXT_DOWN(xp); + ulong ty = MP_NEXT_DOWN(yp); + if ( ty > tx) + {z=x;x=y;y=z;sz=sx;sx=sy;sy=sz; + goto DIFFER;} + else + if ( tx > ty) + {goto DIFFER;}} + SAME: return gzero; + DIFFER:; + } + + z=cgeti(lx);overflow=0; + MP_START_LOW(xp,x,lx);MP_START_LOW(yp,y,ly);MP_START_LOW(zp,z,lx); + i = MP_COUNT_LG(ly); + +#ifdef QUICK_LOOP + i = ly - 2; + QUICK_LOOP(i,SUBXCC); +#else + i = MP_COUNT_LG(ly); + WHILE_COUNT(--i) + {SUBLLX(MP_NEXT_UP(xp),MP_NEXT_UP(yp),MP_NEXT_UP(zp));} +#endif + + if(overflow) + { ulong tx ; + while((tx=MP_NEXT_UP(xp)) == 0) + MP_NEXT_UP(zp) = 0xffffffff; + if (xp >= (xhigh = &MP_HIGH(x,lx))) + { MP_NEXT_UP(zp) = tx -1; + while ((xpp = &MP_NEXT_UP(xp)) >= xhigh) + { MP_NEXT_UP(zp) = *xpp;}} + } + else + { i = COUNT(lx - ly); + WHILE_COUNT(--i) + MP_NEXT_UP(zp) = MP_NEXT_UP(xp); + } + if(z[2]) z[1]=x[1]; + else + { zp = &z[3]; + while (*zp ==0){zp++;} /* x was != y by above */ + zp -= 2; + i = zp - z; + zp[1] = (zp[0] = z[0]-i); + z = zp; + setsigne(z,sx); + avma+=(i<<2); + } + } + return z; +} + +GEN mulss(x,y) + plong x,y; +{ + plong s,p1; + GEN z; ulong hiremainder; + + if((!x)||(!y)) return gzero; + s=1; + if(x<0) + {s= -1; + x= -x; + if (x<0) + return mulsi(y,stoi(x)); + } + if(y<0) {s= -s; + y= -y; + if(y<0) + return mulsi((s > 0 ? x : -x),ABS_MOST_NEGS); + } + p1=mulll(x,y); + if(hiremainder) {z=cgeti(4);z[2]=hiremainder;z[3]=p1;} + else {z=cgeti(3);z[2]=p1;} + z[1]=z[0];setsigne(z,s);return z; +} + + +GEN mulii(x,y) + GEN x,y; +{ + plong i,j,lx=lgef(x),ly=lgef(y),sx,sy,lz,p1,p2; + GEN z; TEMPVARS + + GEN zz,yy,zp,xx; + GEN ylow; + ulong hiremainder; + ulong overflow; + + sx=signe(x);if(!sx) return gzero; + sy=signe(y);if(!sy) return gzero; + if(sy<0) sx= -sx; + if(lx>ly) {z=x;x=y;y=z;lz=lx;lx=ly;ly=lz;} + lz=lx+ly-2;if(lz>=0x10000) err(muler1); + z=cgeti(lz);z[1]=z[0];setsigne(z,sx); + + MP_START_LOW(xx,x,lx); + p1 = MP_NEXT_UP(xx); + + hiremainder=0; + i = COUNT(ly-2); + MP_START_LOW(yy,y,ly); + MP_START_LOW(zz,z,lz); + + WHILE_COUNT (--i) + { MP_NEXT_UP(zz) = addmul(p1,MP_NEXT_UP(yy));} + + MP_NEXT_UP(zz) = hiremainder; + + /* restart zz one above bottom */ + MP_START_LOW(zz,z,lz); + + MP_START_LOW(ylow,y,ly); + ly = COUNT(ly - MP_CODE_WORDS); + lx -= MP_CODE_WORDS; + while (--lx > 0) /* one less iteration first term of x, already used */ + { plong tem; + register plong p11; + p11 = MP_NEXT_UP(xx); + i = ly; + yy = ylow; + zp = &MP_NEXT_UP(zz); /* *zp = second from low word of z first time through */ + tem = 0; + /* ZerO is just a 68k kludge to getit to keep 0 in a reg during this loop*/ +#undef ZERO +#define ZERO ZerO + { int ZerO = 0; + WHILE_COUNT(--i) + { p2 = MP_NEXT_UP(yy); + p2 = mulul(p2,p11,hiremainder); + MP_NEXT_UP(zp); + p2 = add_carry(p2,*zp,hiremainder); + p2 = add_carry(p2,tem,hiremainder); + *zp = p2; + tem = hiremainder; + } + } + MP_NEXT_UP(zp) = hiremainder; + +#undef ZERO +#define ZERO 0 + + } + if(!MP_HIGH(z,lz)) + { /* shift header one along decreasing lg and lgef */ + z[2]=z[1]-1;z[1]=z[0]-1;z++;avma+=4; + } + return z; +} + +GEN confrac(x) + GEN x; +{ + plong lx=lg(x),ex= -expo(x)-1,ex1,av=avma,ly,ey; + plong lr,nbdec,k,i,j; ulong hiremainder; + GEN y,res; TEMPVARS + + ey=((lx-2)<<5)+ex;ly=(ey+63)>>5;y=cgeti(ly);ex1=ex>>5; /* 95 dans mp.s faux? */ + for(i=0;i=0;i--) y[i]=addmul(y[i],1000000000); + res[j]=hiremainder; + } + avma=av;return res; +} + +/* x/y : uses hiremainder for return */ +GEN divss(x,y) + plong x,y; +{ + plong p1; + + if(!y) err(diver1); + if (x == (1<<31)) + return divis(stoi(x),y); + hiremainder=0;p1=divll((ulong)abs(x),(ulong)abs(y)); + if(y<0) {hiremainder= -((plong)hiremainder);p1= -p1;} + if(x<0) p1= -p1; + return stoi(p1); +} + +GEN modss(x,y) + plong x,y; +{ + plong y1; ulong hiremainder; + + if(!y) err(moder1); + if (x == (1<<31)) + return modis(stoi(x),y); + hiremainder=0;divll(abs(x),y1=abs(y)); + if(!hiremainder) return gzero; + return (((plong)hiremainder)<0) ? stoi(y1-hiremainder) : stoi(hiremainder); +} + +GEN resss(x,y) + plong x,y; +{ ulong hiremainder; + if(!y) err(reser1); + hiremainder=0;divll(abs(x),abs(y)); + return (y<0) ? stoi(-((plong)hiremainder)) : stoi(hiremainder); +} + +/* uses hiremainder for return */ +GEN divsi(x,y) + plong x; + GEN y; +{ + plong s=signe(y),ly=lgef(y),p1; + + if(!s) err(diver2); + if((!x)||(ly>3)||(y[2]<0)) {hiremainder=x;return gzero;} + if (x== 1<<31) + return divii(stoi(x),y); + hiremainder=0;p1=divll(abs(x),y[2]); + if(signe(y)<0) {hiremainder= -((plong)hiremainder);p1= -p1;} + if(x<0) p1= -p1; + return stoi(p1); +} + +/* this uses the GLOBAL hiremainder to return its remainder + We cannot make it a local. + */ +GEN divis(y,x) + plong x; + GEN y; +{ ulong hi; + plong s=signe(y),ly=lgef(y),i,d; + GEN z; + + if(!x) err(diver4); + if(!s) {hiremainder=0;return gzero;} + if(x<0) {s= -s;x= -x; + if (x < 0) + return divii(y,stoi(x)); + } + if((ulong)x>(ulong)y[2]) + { + if(ly==3) {hiremainder=itos(y);return gzero;} + else {z=cgeti(ly-1);d=1;hi=y[2];} + } + else {z=cgeti(ly);d=0;hi=0;} + for(i=d+2;i (ulong)MP_HIGH(x,lx)) + { lgp1=lx-1; hiremainder= MP_NEXT_DOWN(xp);} + else { lgp1=lx; hiremainder=0;} + p1 = cgeti(lgp1); i = MP_COUNT_LG(lgp1); + MP_START_HIGH(p1p,p1,lgp1); + WHILE_COUNT(--i) { MP_NEXT_DOWN(p1p) = divll(MP_NEXT_DOWN(xp),si);} + + if((plong)z==0xffffffff) + { + avma=av;if(!hiremainder) return gzero; + p2=cgeti(3);p2[1]=(sx<<24)+3;p2[2]=hiremainder;return p2; + } + if(lgp1!= 2) {p1[1]=p1[0];setsigne(p1,sy);} else {avma=av;p1=gzero;} + if(z==0) return p1; + if(!hiremainder) *z=gzero; + else {p2=cgeti(3);p2[1]=(sx<<24)+3;p2[2]=hiremainder;*z=p2;} + return p1; + } + else + { + p1=cgeti(lx); + sh=bfffo(y[2]); + if(sh) + { GEN p2p,yp; + MP_START_HIGH(yp,y,ly); + p2=cgeti(ly); + k=shiftl(MP_NEXT_DOWN(yp),sh); + MP_START_HIGH(p2p,p2,ly); + i = MP_COUNT_LG(ly-1); + WHILE_COUNT(--i) + { + k1=shiftl(MP_NEXT_DOWN(yp),sh); + MP_NEXT_DOWN(p2p) = k + hiremainder; + k = k1; + } + MP_NEXT_DOWN(p2p) = k ; k=0; + + MP_START_HIGH(xp,x,lx); + MP_START_HIGH(p1p,p1,lx); + MP_NEXT_UP(p1p) ; /* yes go out of range !! */ + i = MP_COUNT_LG(lx); + WHILE_COUNT (--i) + { k1 = shiftl(MP_NEXT_DOWN(xp),sh); + MP_NEXT_DOWN(p1p) = k + hiremainder; k = k1; + } + MP_NEXT_DOWN(p1p) = k; + } + else { + MP_START_HIGH(xp,x,lx); + MP_START_HIGH(p1p,p1,lx); + MP_NEXT_UP(p1p) ; /* yes go out of range !! */ + MP_NEXT_DOWN(p1p) = 0; + j = MP_COUNT_LG(lx); + WHILE_COUNT (-- j) + { MP_NEXT_DOWN(p1p) = MP_NEXT_DOWN(xp);} + p2 = y;} + si=p2[2];saux=p2[3]; + MP_START_HIGH(p1p,p1,lx); MP_NEXT_UP(p1p) ; /* out of bound */ + i = COUNT(lz+1); + WHILE_COUNT(--i) + + { GEN pp; + if(MP_NEXT_DOWN(p1p)==si) + { /* Using fact that next_down does post increment */ + qp=0xffffffff;k=addll(si,*p1p); + + } + else + { + hiremainder=p1p[-1];qp=divll(*p1p,si); + overflow=0;k=hiremainder; + } + if(!overflow) + { +/* k1=mulll(qp,saux);k3=subll(k1,p1p[1]);k+=overflow; + flk4=((ulong)hiremainder>(ulong)k);k4=subll(hiremainder,k); + while(flk4) {qp--;k3=subll(k3,saux); + k4-=overflow;flk4=((ulong)k4>(ulong)si); + k4=subll(k4,si);} +*/ + k1=mulll(qp,saux);k3=subll(k1,p1p[1]); + k4=subllx(hiremainder,k); + while((!overflow)&&k4) {qp--;k3=subll(k3,saux);k4=subllx(k4,si);} + + } + hiremainder=0; + + j = MP_COUNT_LG(ly); + MP_START_LOW(pp,p1p,ly-2); + MP_START_LOW(p2p,p2,ly); + WHILE_COUNT(--j) + { GEN ppp; + k1=addmul(qp,MP_NEXT_UP(p2p)); + ppp = &MP_NEXT_UP(pp); + *ppp =subll(*ppp,k1);hiremainder+=overflow; + } + if((ulong)p1p[-1]<(ulong)hiremainder) + { + overflow=0;qp--; + j = MP_COUNT_LG(ly); + MP_START_LOW(pp,p1p,ly-2); + MP_START_LOW(p2p,p2,ly); + WHILE_COUNT(--j){ GEN ppp = &MP_NEXT_UP(pp); + ADDLLX(*ppp,MP_NEXT_UP(p2p),*ppp);} + + } + p1p[-1] = qp; + } + av1=avma; + if((plong)z!=0xffffffff) + {ulong lgp3 = lz + 2; + MP_START_LOW(p1p,p1,lgp3); + if (p1[1]) {lgp3++;} + else if (lz==0) sy=0; + p3 = cgeti(lgp3); + MP_START_LOW(pp,p3,lgp3); + j = MP_COUNT_LG(lgp3); + WHILE_COUNT(--j) + {MP_NEXT_UP(pp) = MP_NEXT_UP(p1p) ;} + if(lgp3<3) {p3[1]=2;} else {p3[1]=p3[0];setsigne(p3,sy);} + } + if(z!=0) + { + for(j=lz+2;(j>2;*z=p4+dec;return p3+dec; + } +} +/* machines which provide an inline version of mulul need + to provide a function for calls where that inlining can't take place + */ +#ifdef NEED_MULUL3 +ulong +mulul3(a,b,c) + ulong a,b,*c; +{ return mulul(a,b,*c);} +#endif + +#ifdef NEED_DIVUL3 +ulong +divul3(a,b,c) + ulong a,b,*c; +{ return divul(a,b,*c);} +#endif + +/* +;;- Local variables: +;;- version-control:t +;;- End: +*/ diff --git a/mp/readme b/mp/readme new file mode 100755 index 0000000..b10c562 --- /dev/null +++ b/mp/readme @@ -0,0 +1,85 @@ +README for multiprecision arithmetic directory. +README by W. Schelter + +The files in this directory + +gencom.h mp.s sparc.s +erreurs.h genport.h + +are from the PARI distribution version 1.34 written by C. Batut, D. +Bernardi, H. Cohen and M. Olivier. + +The file mp.c from the 1.34 distribution has been divided into +mpi.c: The functions benefiting from assembler or assembler macros. +mp2.c: Additional integer arithmetic routines. + +In addition the functions in mpi.c have been somewhat rewritten by +Schelter, to improve the efficiency on machines unable to use the 68k +assembler in the pari file mp.s. By using gcc and assembler macros, +we were able to equal the speed of the excellent pari assembler, on +multiply and addition of 100 word bignums. This distribution +contains .s files produced by gcc for machines where this has +been available. For other machines the functions divul3 +and mulul3 may be provided as assembler functions, or they may +use the code in the libmport.a which is plain C. + +mp_mulul3.c: 64 bit multiply in C +mp_divul3.c: 64 bit multiply in C +mp_bfffo.c: position of first non zero bit in C + +mpi-*.s: are assembler produced by gcc for several machines. + +Full sources for PARI/GP are available by anonymous ftp from (Internet +number 192.33.148.32). + +Authors address: + + Prof. Henri COHEN (re: PARI) + UFR de Mathematiques et Informatique + Universite Bordeaux I + 351 Cours de la Liberation + 33405 TALENCE CEDEX + FRANCE + +e-mail: pari@mizar.greco-prog.fr (Internet number 192.33.148.32) + +The integration of the pari code into AKCL was done by W. Schelter. + +--------------------------------------------------------------------------- +Excerpt from letter from Henri Cohen giving us permission to +redistribute this code with AKCL. + +Received-Date: Fri, 25 Jan 91 12:38:02 -0600 +Date: Fri, 25 Jan 91 19:17:34 +0100 +From: pari@mizar.greco-prog.fr (Systeme PARI) +To: wfs@nicolas.ma.utexas.edu +Subject: Re: AKCL + +Thank you for the clarifications. + +1) -2^31: it was mainly a matter of convenience to exclude that value, so that +in effect I don't know which programs should be affected if one allows it. If +necessary, I can look into it. + +2) Yes, go ahead means that you may modify and rearrange things in your own +way, +and redistribute it, of course keeping us informed. On the other hand, please +tell us as soon as possible of any bug that you discover that we should +eliminate from the main system itself. + +.. + +Sincerely, + +Henri Cohen + + + + + + + + + + + diff --git a/mp/sparcdivul3.s b/mp/sparcdivul3.s new file mode 100755 index 0000000..2cbf0fa --- /dev/null +++ b/mp/sparcdivul3.s @@ -0,0 +1,283 @@ +#ifdef __svr4__ +#define _err err +#define _divul3 divul3 +#endif + .seg "text" + .global _divul3 + +#define SS0(label) \ + addx %o2,%o2,%o2;\ + subcc %o2,%o1,%o3;\ + bcc label;\ + addxcc %o0,%o0,%o0 + +#define SS1(label) \ + addx %o3,%o3,%o3;\ + subcc %o3,%o1,%o2;\ + bcc label;\ + addxcc %o0,%o0,%o0 +_divul3: mov %o2,%o4 + ld [%o2],%o2 + subcc %o2,%o1,%g0 + blu 1f + addcc %o1,%o1,%g0 + mov 0x2f,%o0 + call _err,1 + nop +1: bcc Lsmalldiv + andcc %o1,1,%g0 + be Levendiv + srl %o1,1,%o1 + add %o1,1,%o1 + subcc %o2,%o1,%o3 + bcc Lb01 + addxcc %o0,%o0,%o0 +La01: SS0(Lb02) +La02: SS0(Lb03) +La03: SS0(Lb04) +La04: SS0(Lb05) +La05: SS0(Lb06) +La06: SS0(Lb07) +La07: SS0(Lb08) +La08: SS0(Lb09) +La09: SS0(Lb10) +La10: SS0(Lb11) +La11: SS0(Lb12) +La12: SS0(Lb13) +La13: SS0(Lb14) +La14: SS0(Lb15) +La15: SS0(Lb16) +La16: SS0(Lb17) +La17: SS0(Lb18) +La18: SS0(Lb19) +La19: SS0(Lb20) +La20: SS0(Lb21) +La21: SS0(Lb22) +La22: SS0(Lb23) +La23: SS0(Lb24) +La24: SS0(Lb25) +La25: SS0(Lb26) +La26: SS0(Lb27) +La27: SS0(Lb28) +La28: SS0(Lb29) +La29: SS0(Lb30) +La30: SS0(Lb31) +La31: SS0(Lb32) +La32: addx %o2,%o2,%o2 + xor %o0,-1,%o0 + add %o1,%o1,%o1 + sub %o1,1,%o1 + addcc %o0,%o2,%o2 + bcc 1f + subcc %o2,%o1,%o3 + subcc %o3,%o1,%o2 + bcs 2f + add %o0,1,%o0 + add %o0,1,%o0 +3: retl + st %o2,[%o4] +1: bcs 3b + nop + add %o0,1,%o0 +2: retl + st %o3,[%o4] + +Lb01: SS1(La02) +Lb02: SS1(La03) +Lb03: SS1(La04) +Lb04: SS1(La05) +Lb05: SS1(La06) +Lb06: SS1(La07) +Lb07: SS1(La08) +Lb08: SS1(La09) +Lb09: SS1(La10) +Lb10: SS1(La11) +Lb11: SS1(La12) +Lb12: SS1(La13) +Lb13: SS1(La14) +Lb14: SS1(La15) +Lb15: SS1(La16) +Lb16: SS1(La17) +Lb17: SS1(La18) +Lb18: SS1(La19) +Lb19: SS1(La20) +Lb20: SS1(La21) +Lb21: SS1(La22) +Lb22: SS1(La23) +Lb23: SS1(La24) +Lb24: SS1(La25) +Lb25: SS1(La26) +Lb26: SS1(La27) +Lb27: SS1(La28) +Lb28: SS1(La29) +Lb29: SS1(La30) +Lb30: SS1(La31) +Lb31: SS1(La32) +Lb32: addx %o3,%o3,%o2 + xor %o0,-1,%o0 + add %o1,%o1,%o1 + sub %o1,1,%o1 + addcc %o0,%o2,%o2 + bcc 1f + subcc %o2,%o1,%o3 + subcc %o3,%o1,%o2 + bcs 2f + add %o0,1,%o0 + add %o0,1,%o0 +3: retl + st %o2,[%o4] +1: bcs 3b + nop + add %o0,1,%o0 +2: retl + st %o3,[%o4] + +Lsmalldiv: + addcc %o0,%o0,%o0 +Lc00: SS0(Ld01) +Lc01: SS0(Ld02) +Lc02: SS0(Ld03) +Lc03: SS0(Ld04) +Lc04: SS0(Ld05) +Lc05: SS0(Ld06) +Lc06: SS0(Ld07) +Lc07: SS0(Ld08) +Lc08: SS0(Ld09) +Lc09: SS0(Ld10) +Lc10: SS0(Ld11) +Lc11: SS0(Ld12) +Lc12: SS0(Ld13) +Lc13: SS0(Ld14) +Lc14: SS0(Ld15) +Lc15: SS0(Ld16) +Lc16: SS0(Ld17) +Lc17: SS0(Ld18) +Lc18: SS0(Ld19) +Lc19: SS0(Ld20) +Lc20: SS0(Ld21) +Lc21: SS0(Ld22) +Lc22: SS0(Ld23) +Lc23: SS0(Ld24) +Lc24: SS0(Ld25) +Lc25: SS0(Ld26) +Lc26: SS0(Ld27) +Lc27: SS0(Ld28) +Lc28: SS0(Ld29) +Lc29: SS0(Ld30) +Lc30: SS0(Ld31) +Lc31: SS0(Ld32) +Lc32: xor %o0,-1,%o0 + retl + st %o2,[%o4] + +Ld01: SS1(Lc02) +Ld02: SS1(Lc03) +Ld03: SS1(Lc04) +Ld04: SS1(Lc05) +Ld05: SS1(Lc06) +Ld06: SS1(Lc07) +Ld07: SS1(Lc08) +Ld08: SS1(Lc09) +Ld09: SS1(Lc10) +Ld10: SS1(Lc11) +Ld11: SS1(Lc12) +Ld12: SS1(Lc13) +Ld13: SS1(Lc14) +Ld14: SS1(Lc15) +Ld15: SS1(Lc16) +Ld16: SS1(Lc17) +Ld17: SS1(Lc18) +Ld18: SS1(Lc19) +Ld19: SS1(Lc20) +Ld20: SS1(Lc21) +Ld21: SS1(Lc22) +Ld22: SS1(Lc23) +Ld23: SS1(Lc24) +Ld24: SS1(Lc25) +Ld25: SS1(Lc26) +Ld26: SS1(Lc27) +Ld27: SS1(Lc28) +Ld28: SS1(Lc29) +Ld29: SS1(Lc30) +Ld30: SS1(Lc31) +Ld31: SS1(Lc32) +Ld32: xor %o0,-1,%o0 + retl + st %o3,[%o4] + + +Levendiv: + subcc %o2,%o1,%o3 + bcc Lf01 + addxcc %o0,%o0,%o0 +Le01: SS0(Lf02) +Le02: SS0(Lf03) +Le03: SS0(Lf04) +Le04: SS0(Lf05) +Le05: SS0(Lf06) +Le06: SS0(Lf07) +Le07: SS0(Lf08) +Le08: SS0(Lf09) +Le09: SS0(Lf10) +Le10: SS0(Lf11) +Le11: SS0(Lf12) +Le12: SS0(Lf13) +Le13: SS0(Lf14) +Le14: SS0(Lf15) +Le15: SS0(Lf16) +Le16: SS0(Lf17) +Le17: SS0(Lf18) +Le18: SS0(Lf19) +Le19: SS0(Lf20) +Le20: SS0(Lf21) +Le21: SS0(Lf22) +Le22: SS0(Lf23) +Le23: SS0(Lf24) +Le24: SS0(Lf25) +Le25: SS0(Lf26) +Le26: SS0(Lf27) +Le27: SS0(Lf28) +Le28: SS0(Lf29) +Le29: SS0(Lf30) +Le30: SS0(Lf31) +Le31: SS0(Lf32) +Le32: addx %o2,%o2,%o2 + xor %o0,-1,%o0 + retl + st %o2,[%o4] + +Lf01: SS1(Le02) +Lf02: SS1(Le03) +Lf03: SS1(Le04) +Lf04: SS1(Le05) +Lf05: SS1(Le06) +Lf06: SS1(Le07) +Lf07: SS1(Le08) +Lf08: SS1(Le09) +Lf09: SS1(Le10) +Lf10: SS1(Le11) +Lf11: SS1(Le12) +Lf12: SS1(Le13) +Lf13: SS1(Le14) +Lf14: SS1(Le15) +Lf15: SS1(Le16) +Lf16: SS1(Le17) +Lf17: SS1(Le18) +Lf18: SS1(Le19) +Lf19: SS1(Le20) +Lf20: SS1(Le21) +Lf21: SS1(Le22) +Lf22: SS1(Le23) +Lf23: SS1(Le24) +Lf24: SS1(Le25) +Lf25: SS1(Le26) +Lf26: SS1(Le27) +Lf27: SS1(Le28) +Lf28: SS1(Le29) +Lf29: SS1(Le30) +Lf30: SS1(Le31) +Lf31: SS1(Le32) +Lf32: addx %o3,%o3,%o3 + xor %o0,-1,%o0 + retl + st %o3,[%o4] diff --git a/o/ChangeLog b/o/ChangeLog new file mode 100755 index 0000000..5008433 --- /dev/null +++ b/o/ChangeLog @@ -0,0 +1,1385 @@ +Fri Nov 24 18:42:46 1995 Bill Schelter + + * alloc.c (ONCE_MORE): + * DEFUN("STATICP",.. had accidentally been included in a section + which was '#ifdef'ed out on nexts..., making it not be there + at link time: moved it to where it is always there. + * + + +Nov 11 1995 bill schelter + * gcl-2.2 released + + +Sun Oct 1 19:52:45 1995 Bill Schelter + + * Many changes to gcl 2.1 to support 64 bit machines (eg Dec + alpha). Layout of structures etc changed. + * a gcl-2.2 beta was released in the summer. + since then there have been several bugs fixed. One in cmpfun.lsp + affecting write, and another in init_gcl.lsp to make sure the + link array is a string array (changed from fixnum which are no + longer sufficient to hold pointers). + * changes to fix for PA risc hpux in the hp800.h + * changes to unexec-19.27.c to allow MUCH faster saving in NFS + environment. + * testing with maxima 5.1 + * reworking makefiles + + +Sat Apr 29 08:48:06 1994 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * Changed to release under GNU Public Library license. There + have been a number of other fixes including fixes to bignums. + + +Thu Jan 20 10:38:00 1994 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * version 624 made. + * contains just changes so that compiles on solaris 5.2. The + 623 version compiled on solaris 5.3, but the earlier 5.2 version of solaris + had some differences which needed patches. These are contained + in 624. + +Fri Dec 10 15:02:14 1993 Bill Schelter (wfs at nicolas.ma.utexas.edu) + * version 623 made. + + * the check on string-trim for a list of chars is fixed. + Much earlier the (string-trim '(2) "ab") would run forever. + Then string-trim was broken. + + +Sun Dec 5 15:34:44 1993 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * add solaris version: changes to several C files + and new version of sfasl for elf. + * linux port added. + +Thu Oct 29 13:20:17 1992 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * make sure the signal stack is 8 byte aligned. Needed on sun os 4.1.2 + and higher. + +Thu Jun 4 06:18:20 1992 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * fix allocation of copy space during an sgc for relocatable + +Wed Apr 29 09:02:59 1992 Bill Schelter (wfs at nicolas.ma.utexas.edu) + *cmpnew/lfuns.lsp make load,open, error-set go through lisp + symbol, so users can redefine them (eg when loaded common lisp + condition code stuff). + * defstruct.lsp: put the conc-name in the current package, + so that programs can discover the package in effect when + the defstruct was done, in order to reconstruct accessors. + +Sun Apr 26 23:28:42 1992 Bill Schelter (wfs@sonia.ma.utexas.edu) + + * predicate.c: contains_sharp_comma handle non type t arrays + * co1typep optimize for the '(satifies fun) type. + * cmpinline.lsp, cmplabel.lsp, cmploc.lsp + inline-integer (set-loc unwind-exit get-inline-loc) + fixes by r harris. + +Thu Apr 23 15:09:44 1992 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * cmpenv.lsp fix function return integer proclamation. + +Sat Apr 11 09:25:05 1992 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * numlib.lsp: changes to ensure double accuracy not lost. + +Thu Apr 9 11:21:25 1992 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * log,exp,.. get more accuracy if given a fixnum[don't use short-float] + * cmptop.lsp empty keyword list bug (defun foo(&key) nil) + * many files add hooks for dos port. + +Fri Mar 27 15:59:24 1992 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * (cmpinline.lsp) inline-args of a closure var which changed later, + signalled a compiler error. + +Wed Mar 25 14:38:41 1992 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * (read.d) make read listen to when ':' is a read macro. in read_object + * (cmpfun.lsp,cmpopt.lsp): Fix optimizer for (typep x 'ratio) + * (predicate.c): fix equalp so (equalp (format nil "hi") "hi") -->t + +Wed Mar 11 14:16:59 1992 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * (read.d): fix failure of (read-string "#b1"). Handle eof in + read_constituent + + +Wed Feb 26 21:38:04 1992 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * cmpfun.lsp change read-char optimizer so as to avoid + a C compiler bug on dec3100, which causes an unaligned access + on that machine in calls to read-char. + +Wed Jan 29 08:30:09 1992 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * hp800.{h,defs} changes to run incrementally loaded text in a + separate segment (at 4zillion). Without this hp will only let + you run one image at a time. Unfortunately there will be a slight + degradation in indirect calls (which includes all calls between + user functions). Why do they need to have segments.... + +Thu Jan 23 17:01:37 1992 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * add some save and retore around the terminal interrupt, to + prevent some possible lossage when continuing from an interrupt. + You still may lose if there is a gc during an interrupt. + + +Wed Jan 22 19:08:11 1992 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * support for mac under AUX. Files mac2.h, mac2.defs [by weigert] + * misc small changes to other files for mac. + +Sun Jan 5 21:35:21 1992 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * new definitions for fplus and fminus in cmac.c The ones for + the 68020 were incorrect (since the changeover of the bignum code). + These were only used by maxima. + +Fri Nov 22 08:39:42 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * Change proclaim of function so to turn integer + proclained args into type T. It is not possible to + pass raw integer type since this would cause a problem + with gc. Also currently it would have generated C which + broke the C compilation. + +Tue Oct 29 07:59:02 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * add misc/warn-slow.lsp. If this file is loaded, then the compiler + warns of certain slow constructs, like undeclared arithmetic, + and slow array references. + +Thu Oct 24 21:34:55 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * funlink.c to handle misproclaimed functions better. + * big.c correct one source of "bad length" warning + +Sun Oct 20 12:55:35 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * gbc.c change position of where the C stack is marked from. + This is relevant for sparcs with the register windows, which + are dumped at interrupts. + * cfun,gbc changes as per PCL mods for turbo closures. + * read.d use 1000000000.0 rather than 1/ this , since it gives + more accurate value in read of float. + * cmpfun.lsp add hook for (typep x 'foo) so that can expand + this differently according to a property of 'foo. + * cmpcall.lsp, add a hook so that special code can be emitted + for calls where a super_funcall_no_event would have been emitted. + This code might be used where we expect closures (cf PCL) + + + +Wed Oct 9 21:31:03 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * read.d to make 0.7 and (/ 7.0 10) produce identical results. + when read (at least on 68k,sparc, rios). + We have left the default number of digits printed out as 17, + in spite of the fact that IEE has only 15.95 significant digits. + The reason is that correct rounding to 15 or 16 digits, will + commonly cause things like most-positive-long-float to print + in a form which is not even readable (since it is rounded up above + the most-positive-long-float). + +Mon Oct 7 20:54:35 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * fix LD_COMMAND typo in hp800.h + * fix replace_array to make the new array not live + beyond the call, so that gc won't accidentally mark two + copy two identical array bodies (so maybe overstepping the + the new relblock) + +Fri Oct 4 10:58:59 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * close to work on already closed streams. + * make_pure_array arg fixed (num_log.c) + * estack_buf put in static area on machines like rios. + + +Sun Sep 29 12:43:54 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * fix to relblock allocation in sgc_start + * fix for paths with "~/" + * change default pagesize on sun3 to 4k + + +Sat Sep 7 13:51:24 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * fix bit-array-op to make correct call to si::make-array-pure + (num_log.c) + +Mon Aug 5 18:06:35 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * wt-cvars add declaration for VXXalloc variables + +Tue Jul 30 16:48:09 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * interpreted mapcar not gc protecting when given more than 2 args. + +Sat Jul 27 12:32:35 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * changes to subtypep to make (subtypep 'cons '(and t cons)) + and (subtypep 'simple-array '(not vector)) correct. + +Fri Jul 26 09:25:56 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * change equal and hash_equal not to descend into structures. + A ruling in CLTL2, clarifies that this should be the case. + * alter get-setf-method and friends to accept environment as second + argument. Alter all the complex setf methods to pass the environment + so that local functional and macro bindings can alter the behaviour + of the setf macro. + +Tue Jul 23 06:25:39 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * sharing for fasd files for package operations was disabled. + Otherwise the symbol in a shadow would be shared with the symbol's + later occurrence in the file--It is still a good idea to put + package operations in a separate lisp file at the beginning of + system load. + * adjustable arrays brought into conformance with changes in CLTL + II. You + may now adjust non adjustable arrays, and the fill-pointer argument + to adjust-array does not change the property of having or not having + a fill pointer for the array. + + + +Sun Jul 21 12:44:04 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * fix cmac.c for maxima (error in dblrem) + + * sloop for v on l by 'joe + changed to allow for the possibility that joe is a macro. + [used by maxima]. + +Wed Jul 10 10:45:54 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * littleXlsp is included which provides an interface to some + simple X windows routines. It is not in the image by default + See the file lsp/littleXlsp.lsp for directions. + +Tue Jul 9 16:29:23 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * add VOL declarations for setjmps in format.c to allow to work + with gcc on the sparc. + * add stuff to cmplam.lsp for VOL declarations of &aux variables. + + +Wed Jun 26 20:59:04 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * Change to gc mark of c stack to make sure register windows + are flushed, by calling recursively. + * add special bignum code for rs 6000 and aix 370 + * fix for read suppress and the defstruct reader. + * Source level debugging improved (see doc/DOC and doc/dbl.el) + * Catch infinite recursion of proclaimed functions. Handle + segmentation faults on an alternate stack--so don't play around + to much after a segmentation fault before quitting to top level. + * support for hp800 (and hp700) added. + + +Wed May 22 14:54:29 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * added new slot to struct stream, to hold the buffer. + gbc.c and file.d had been referencing the field in FILE + directly, but that is not reliable on att Sys V 4. + +Thu Apr 11 17:04:54 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * add conc-name to the s-data structure so users may get at + it (defstruct.lsp). + * add install_segmentation_catcher() and also in error() + (ususually arises from real segmentation faults), then turn + off sgc, if it's on, to avoid having the error handler stall + on trying to alter pages which are write protected (since + we are still within the memprotect_handler. + +Thu Apr 4 08:37:50 1991 Bill Schelter (wfs at max.ma.utexas.edu) + + * If HAVE_YP_UNBIND is defined, added to c/main.c the + unbinding of the default yp domain. In sun os 4.1 + we were getting a segmentation fault in _yp_dobind_soft() + on a restarted system. + + +Sat Mar 30 09:01:57 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * Fix listen and clear-input (file.d and read.d). + macros LISTEN_FOR_INPUT and HAVE_IOCTL are defined in + att.h, bsd.h, and for the aix systems. I have tested + it under aix, sun, 4.3bsd, sgi4d and hpux. Not sure about + vannilla sysv (may have to be #undef'd there). + * fixed pathnames such as "~wfs/foo.lisp" to work. + (see unixfsys.c). + + +Mon Mar 25 12:25:34 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * Make sure that long float arrays get allocated on multiple of + sizeof(double ) alignment array.c,gbc.c.. Also unixfasl.c + + * Add to Smakefile an initial execution of xbin/{machine}-fixes + if that file exists. Use this for correction of temporary bug + fixes, such as the bad sgi4d c compiler. + + +Mon Mar 18 12:06:26 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * The structure of bignums and the underlying code was changed + completely. This affected many files including big.c,num_co.c + print.d, read.d, predicate.c, num_arith.c,.. See the file doc/bignum + for a discussion. The compiler was also changed to include + integer as a primitive type with storage allocated on the stack. + * A notion of deducing result type from argument types was + added to the compiler. Initially we are just doing that for + the basic integer functions, but it can be extended to others + * The optimization in cmpopt.lsp have been changed to allow more + flags to accommodate things like the result-type-from-args. + The compiler will normally warn (for the time being) if you + give it old style optimizations. Because of the extensive + changes to the compiler I have changed the default safety + for compiling the cmpnew directory back to 2. + +Thu Feb 14 16:06:42 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * debug.lsp, eval.c: fix break-step-next and break-step-into to pass + the correct environment back so that evaluating variables or + local functions will be done correctly in the debugger. + +Mon Feb 11 16:24:15 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * Fixed *break-points* function to bind the correct enviroment + so that variables will get the right values. + +Mon Jan 7 21:21:22 1991 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * make inline string adjustable (cmptop.lsp) + * multiple changes to lsp/debug.lsp and lsp/top.lsp + to allow source line debugging using si::nload. + * debugger largely redone. :bt new backtrace + function (:b still there). see DOC file + * add xdr-open xdr-write xdr-read to the si package. + * akcl 532 compatible with maxima 4-153 + + +Wed Dec 5 01:49:50 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * check_alist should allow nil, since the CLTL allows nil + in place of a cons in an alist. + * many changes to debug.lsp, eval.c and top.lsp to allow + source level debugging. The emacs file dbl.el was added. + It and the DOC file contain more information, but basically + there is automatic source display when broken in the debugger + (for lisp files loaded with nload). + +Tue Nov 20 20:07:02 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * Changes to all places where function assignments are made + to allow the hook compiler-def-hook, to be run. This hook + is used by the new source code debugger dbl. + * dbl allows debugging of lisp code with a display of an + arrow in the window opposite the line currently broken at + or being executed. + * The safety on the cmpnew files has been changed to safety 0. + Please notify of any places where this causes a problem! It + should result in significantly faster compilation. The error + checks should be in the source. + +Thu Nov 8 05:31:34 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * fix aix3_mprotect/mprotect.c [wrong calculation of overflow] + * fix memory_protect in sgbc.c + + +Wed Nov 7 09:56:30 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * Change compiler-clear-compiler-properties, to take 2 args. This + is to provide compiler-def-hook, which lets you get the code just + before it is installed. + + * Misc support for IBM 370 mainframe running under AIX. (u370) + * change malloc at startup to use some static space, since + the gc may not be initialized before some startup routines need + to malloc (aix3). + + * fix to cmptag.lsp. Tags in cross closure tagobdies were sometimes not + being written out. (bug had been there forever). C compiler would + fail when the tag was not there. + + +Fri Oct 26 15:00:37 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * change call_proc, the routine used to link proclaimed functions. + It was not incrementing vs_top soon enough, so that with args + (t t fixnum), with fast links off, the make_fixnum caused by + the last arg, might cause a gc which zeroed the vs stack above + vs_top, so eliminating arg1. Symptom was an passed + as second arg. This could only happen when functions were proclaimed, + and had type not = t. + +Sat Oct 6 08:08:47 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * change assoc in list.d so (assoc nil '(nil (nil . a))) --> (nil + . a) + also change cmpfun.lsp in the compiler for this. (bug rep mccain) + * Allow #' in the (:print-function #'(lambda (..)) defstruct option + (bug report baxter) + +Thu Sep 20 19:05:05 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * Fix cmpthrow in cmpcatch.lsp so that handles + lexical closures correctly. + + * Fix cmpeval.lsp for incrementing a structure slot + which is fixnum. + * Fix cmpmain.lsp adding support for the floating point + save ops on rios. + + +Sun Sep 2 16:44:24 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * Fix perm_writable. It was leaving out the last page! (Vignaux) + +Mon Aug 20 15:15:03 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * fix acos and asin in numlib.lsp (bug was (acos .5) was complex!) + +Wed Aug 15 14:01:06 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * to fasdump.c: close_fasd was munging the array handed + to it to cleanup. This could cause gc problems later. + + * Several changes to gc. The alloc_relblock function fixed + to take into acount that rb_start - heap_end may not be + holepage anymore [since if sgc_enabled we have a second + `sgc' rb_start after the first]. We ensure that nrbpage + is actually the combined number of pages for relblock, + for sgc and regular gc. (alloc.c) + +Tue Aug 14 16:04:19 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) + * changes to sgc to the way memory protection is turned on. + + * There may be problems with saving an image with (sgc-on t) + These have not been resolved, at least under rios, and perhaps + other machines. + + * many changes for aix 3, for rios + + * for sgi, change the Init_links to come before doinit + * the sgi4d does not need the links stuff. + +Wed Aug 8 21:59:37 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * Change to h/secondary_sun_magic to make it have 8 characters. + * fix use-package so that allows using a package with an external + symbol, if that symbol is shadowed by the current package. + * Several fixes for sun os 4.1 (secondary magic stuff). + +Wed May 23 11:47:34 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * Make traced functions stay traced after redefinition + [change clear_compiler_properties, and its many callers] + * Fix two bugs introduced in trace.lsp when its functionality + was increased. + * fasdump.c (fix coercion). + +Thu Apr 12 15:28:49 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * Change behaviour of proclaimed, compiled keyword argument functions, so that + duplicate keys are allowed, and the leftmost takes precedence. + [bind.c:parse_key_new] + +Mon Apr 9 14:48:43 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * make subtypep (predlib.lsp) handle types of form '(not p) correctly. This + in turn influences compiler optimizer handling of (typep x '(not p)) + * fix read (read.d) so that it allows eof to occur during reading of a semicolon + comment line. + * fix c1values (cmpmulti.lsp) so that (values (truncate a b)) does just + return one value. + +Sun Apr 1 22:11:46 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * make float-digits and float-precision return the significant + digits in terms of float-radix. + * If si::*print-nans* is not nil, then the C printing of Nan's + and infinity surrounded by #< > will be used. + +Fri Mar 30 10:24:35 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * gbc.c, sgbc.c: displaced arrays have been a real headache. + (dotimes (i 5000) (make-array 1 :element-type 'string-char :displaced-to + (format nil "0"))) + would cause bad things to happen in kcl and akcl. I finally decided + that the link between an array and the array it is displaced to should + be made firm. If A is displaced to B, the user can always do adjust-array + on A to destroy the displacement. But from now on, as long as the + displacement exists then if B is marked this will cause marking of A, + and vice versa. + +Wed Mar 28 16:41:17 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * cmpeval.lsp co1structure-predicate: + (defstruct foo a b ..) then foo-p was less efficient + than it had been in some earlier release. + Note:after (si::freeze-defstruct 'foo) you get the fastest foo-p, + since this declares the hierarchy of structures including + foo to be frozen. + + +Wed Mar 7 13:30:57 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * fixed copying of relblock in gc, so that if an array body + is allocated on C stack [the read_fasd does this for a temp array + it needs] then this array will not be copied. In some cases this + could have caused the copied relblock to exceed nrbpage size, which + is all that sbrk had provided. + + * read-fasd could not be recursively entered from the lisp_eval calls which + were possible [from things like require or other package ops]. + Fixed in fasdump.c + + +Mon Mar 5 11:54:49 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * Increase BDSGETA to allow some freedom in the debugger after + a bds overflow. + +Tue Feb 27 09:19:49 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * fix printing NIL relative to a package not using LISP. + +Tue Feb 20 00:10:58 1990 Bill Schelter (wfs at fireant.ma.utexas.edu) + + * Add compiler::*split-files*, to allow convenient splittling of + large lisp files, for C compilers which can't handle infinitely + long C files. See doc/DOC file. + * Fix to fasdump.c. Broke when a .o file was loaded during compilation. + +Fri Feb 16 09:11:08 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * si::*load-pathname* is now bound to the pathname of the current file + being loaded. + + +Sat Feb 10 13:36:44 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * Add the co1special prop check in c1symbol-fun, for fixing macros which + expand into declares in do, do*, prog, prog* (see also cmpfun.lsp) + * Fix level in c2call-local (bug report by harris). + +Tue Jan 23 18:37:58 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * change to siLreplace_array, so that the first word of the old + array header is preserved, so that in case sgc is on, the + array won't be marked SGC_RECENT, and so garbage collected if + there were no pointers to it. + +Sun Jan 21 20:30:48 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * Many changes to the compiler: Only defuns and defmacros are + compiled by default. A flag compiler::*compile-ordinaries* if + t means all forms will be compiled (use this for pcl at the moment). + See doc under compile-file. + * eval-when default behaviour changed to be in line with the X3j13 + CL standard. See compile-file doc. + files: fasdump.c,cmpaux.c,cfun.c, cmptop, cmpwt,cmpenv, cmpspecial, + cmpflet. + * some advantages of the new init scheme. Some files can be substantially + smaller, and there is more flexibility in writing out the init. Things + like closures which are constant, can be set in as constants. + +Thu Jan 4 23:24:46 1990 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * make sublis for eql equal and eq be substantially more efficient. + [list.d, and cmpfun.lsp] + * fix file_exists for AIX (stat returns 0 there even if file + ending in slash is not a directory (ie /u/all/bmt/.login/ would + have existed. + * make boolean be a real type, so that we can distinguish between + calls to a function which want only a boolean reply or calls + which need more. An example is probe-file which can be 30 + times faster when only a boolean reply is needed, not the truename. + This required changes to cmptype,cmpif cmpinline. + * add additional optimizations to cmpopt.lsp. + * fix vector-push-extend optimization [cmpfun, cmpopt] + * various fixes to sgc + + + +Sat Dec 23 18:30:03 1989 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * Fix multiple-value-prog1 in cmpmulti.lsp + (eval-when (compile) (proclaim '(function foo (t t) t))) + (defun jil () (multiple-value-prog1 (values 1 2) (foo 3 4))) + (defun foo (a b) (joe a b) (cons a b)) + (defun joe (a b) (list a b)) + would have (jil) --> 3 4 until this fix. This dates from original kcl. + + +Tue Dec 5 20:22:58 1989 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * changes to alloc.c, gbc.c, page.h, object.h to allow stratified + garbage collection [SGC]. This should help systems with + a large amount of relatively static data. Only pages written + to since sgc-on need be marked and swept. See DOC file. + +Sat Nov 11 07:08:27 1989 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * Add various va_end(ap)'s to match unmatched va_start's. + * add in some changes for hp300's faslink. + * add additional support for cmpnew/collectfn.lsp See the + documentation in the DOC file for emit-fn and friends. + Basically it is for getting proclamation info, who-calls info, + undefined info, from a pass of the compiler on a system. + * add additional undefined warnings for undefined lisp package + functions in addition to the list-undefined-functions. + + + +Tue Oct 31 06:02:18 1989 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * add support of Iris 4d machine. + * Fix COERCE_VA_LIST for non standard machines, to + take the argument n. + * Make sure defun, defmacro,.. clear the accessor property + for defstruct slots. + +Sat Oct 28 11:06:25 1989 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * remove an abort() from rel_sun4.c. This type + of relocation now occurs, and our method has been tested. + + +Fri Oct 27 23:01:42 1989 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * if the *system-directory* directory contains the file sys-init.lsp + then this file will be loaded at startup. This facility + is used for printing the warning message at startup, but + can be used for local modifications. Also by having two + system directories [via links and different commands] + different startups could be loaded. All this is in + addition to the regular init.lsp. The purpose of this + is to allow patches to be loaded, without requiring a + resaving of the image. [Recall the system directory + is the first argument to invoking a saved_kcl, or + the first part of the pathname if there is not a first arg + Typically it is the unixport directory if you use the + xbin/kcl command] + +Tue Oct 24 20:23:56 1989 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * Add packlib to the unixport/boots file so that help* + gets compiled using the new do-symbols macro. + * Add alternate malloc.c file from gnu emacs, if you + define GNU_MALLOC. This runs much faster (15X) if you are + incorporating lots of C code with mallocs. + + +Thu Oct 19 21:28:25 1989 Bill Schelter (wfs at nicolas.ma.utexas.edu) + + * add si::fwrite and si::fread for doing io on file streams. + * Eliminate the need for the separate compiler file cmpinclude.h + This means that only one file is now needed for an executable, + and there won't be confusion over which cmpinclude.h goes with + which version. We store the file as a string, and write it + into the c files as they are compiled [if *cmpinclude-string* is + a string and :system-p t is not given to compile]. The time + difference for doing the extra write is not measurable, even + with tiny compiles. + +Wed Oct 4 23:41:17 1989 Bill Schelter (wfs at rascal) + + * co1eql was causing a double evaluation + in some special circumstances. + + +Mon Oct 2 08:48:30 1989 Bill Schelter (wfs at rascal) + + * Many changes to the compiler to support &optional, &rest + &key args to be passed on the C stack. This is still limited + to functions proclaimed to return one value. + * Allow user to grow the stacks from top level [see *multiply-stacks* + doc] + * Code for making proclamation files and collecting + cross referencing data in cmpnew/collectfn.lisp. This + is to allow a second compile of a system to take advantage + of information obtained in the first compile. + * catch-fatal added. + * read.d float read fixed for little endian machines. + * do,prog,prog* and do* compilation fixed so that declare's + at the beginnning of the bodies which are hidden by macros, are + detected and processed. + * :dynamic-extent declaration recognized to allow &rest + * proclaimed functions with one return value, will now be + compiled to use the C stack even if they have more than 10 args. + + + + +Tue Sep 5 22:15:23 1989 Bill Schelter (wfs at rascal) + + * Change add-function-proclamation to be more efficient + when handed long lists of proclaims. Maxima for example + generates 3871 proclaims of functions. This now takes + 4 seconds instead of 2 minutes. + +Mon Sep 4 00:25:29 1989 Bill Schelter (wfs at rascal) + * cfun_to_combined fixed for t_sfun,t_gfun. + + * ihs_function_name fixed for t_sfun,t_gfun + Mainly used in error handling and printing. + + * compiled-function-name fixed to handle t_sfun,t_gfun + [this is used in the error handler] + +Thu Aug 31 09:57:09 1989 Bill Schelter (wfs at rascal) + + * fix reduce in seqlib.lsp. + +Wed Aug 30 16:44:05 1989 Bill Schelter (wfs at rascal) + + * change cmpeval.lsp,cmploc.lsp to make small fixnums + write out without the indirection through VV + + + + ---------Version 206------------- + +Mon Aug 28 13:44:49 1989 Bill Schelter (wfs at rascal) + + * cmptag.lsp:add-reg changed to handle dotted list case + + * Added new types t_sfun, t_gfun of compiled function + objects to save space and speed funcall. See doc/funcall + for details. Many c files changed as well as compiler. + + * cmpeval.lsp: made #, have the c1special property, + instead of c1, so these will compile properly on safety 3 + + * add si::set-mv, si::mv-ref, to allow people to implement + faster version of multiple values. Someday this way will + be the default [see doc/multiple-values and lsp/fast-mv.lisp] + + + +Thu Aug 10 11:51:05 1989 Bill Schelter (wfs at rascal) + + * Fixed prev fix to print in print.d so that ok if stream = t. + + +Mon Aug 7 10:19:11 1989 Bill Schelter (wfs at rascal) + + * Support for HP300bsd (bsd from mt xinu) added. + * print fixed to add space after printing. + * describe modified to print more information on structures + +Fri Jul 28 09:18:15 1989 Bill Schelter (wfs at rascal) + + * trace.lsp Add keyword args allowing special + entry, exit, conditional and other handling of + traced forms. You can for example specially print + args, or break if args or values are inappropriate. + See file doc/trace. + + * c1decl-body: recognize safety level on first pass. + +Sat Jul 8 15:21:42 1989 Bill Schelter (wfs at rascal) + + * defstruct.lsp and read.d: + Fix patch_sharp to handle structures, and sharp-s-reader + to do its reads recursively. + Allows constructs such as #1=#S(joe a #1#) to work. + + +Fri Jul 7 13:40:45 1989 Bill Schelter (wfs at rascal) + + * make sure the co1 properties are cleared when functions + are defined. + +Mon Jul 3 15:05:51 1989 Bill Schelter (wfs at rascal) + + * Fix sharp-s-reader in defstruct.lsp and remove it + from iolib.lsp + * remove =* and =- from gbc.c package.d + * fix c1value to behave correctly when one value supplied + in cmpmulti.lsp + * change #. and #, to interact correctly when called + after #+ or #- + +Fri Jun 2 20:48:06 1989 Bill Schelter (wfs at rascal) + + * sfasl.c gbc.c change error messages from using stderr + to stdout. Note the first file descriptor the user + opens is typically stderr, so these error messages (which + rarely occurred) did not appear on the screen but rather + caused resetting the file pointer of the user's stream! + +Wed May 31 20:31:04 1989 Bill Schelter (wfs at rascal) + + * package.d,symbol.d, packlib.lsp: Changes + to package hashing and intern. Allow flexibly + sized packages instead of insisting that all + internal and external packages use table with 512 elts. + I recommend a prime number as size. The size of + the internals table is automatically grown when there are 2 x + as many symbols as the table size. + For the byte-reader.im-test file (580K) the read time + went from 24 seconds to 16.8 seconds. (had been 53 seconds). + in-package and make-package take keyword args + :external and :internal to allow specification of the + size of the table for a new package. + +Tue May 30 23:00:46 1989 Bill Schelter (wfs at rascal) + + * fix writing of small and large double floats + in cmpeval.lsp, so that all numbers from smallest + double to largest may be included as constants + in compiled code. + + +Sun May 28 16:22:07 1989 Bill Schelter (wfs at rascal) + + * array.c:array_allocself takes an additional argument, + specifying the default value, or NULL if no initial + value is to be given. + si::make-vector has an additional optional arg of the + default value. + * seqlib also has calls to array_allocself, which take + a 0 final arg, indicating that the initialization + is not to be done. + * array.c: siLcopy_array_portion added, to allow quick copying + from one array to another. + * In top.lsp the *eof* is changed to a local, so as not + to conflict with the si::*eof* which is the value returned + by the system when doing getc. + g + + +Fri May 12 10:57:39 1989 Bill Schelter (wfs at rascal) + + * Add optimization for (type x 'foo) where + foo is a structure. This also affects foo-p. + If you (setq compiler::*frozen-defstructs* t) + this allows the compiler to assume that a given + defstruct will not be extended (by including + it in more structures) by new defstructs loaded + in later files. This can significantly speed + up type checking. + + +Thu May 11 07:43:52 1989 Bill Schelter (wfs at rascal) + + * Fix omission of the extended mul for sun4 in 1.22 + Now a new dependent feature EMUL lets you specify + an assembler file in the o directory, which will + be loaded in at the end. + + * AKCL added to the *features* list. This is + now necessary because of internal differences in structures + between the standard kcl and akcl. + + Structure changes are pretty well complete. + +Wed May 3 12:11:54 1989 Bill Schelter (wfs at rascal) + + * Fix ceiling and floor (num_co.c) by riley + +Mon May 1 08:05:55 1989 Bill Schelter (wfs at rascal) + + * fix to gc of displaced arrays. (bug report + and partial fix by riley). Files gbc.c array.c + undisplace was referrring to possibly freed list + structure. + + * Structures are being completely reworked. + There are two reasons: + + To use much less overhead at compile time of the + original defstruct. + + To allow raw types in defstructs, and allow packing + of these. For example a slot (x 0 :type (mod 50)) will + only require 1 byte. These structs may be made to + coincide with C structs more closely. All ptr or full + fixnum fields will be aligned on a multiple of the size + of ptr however for speed of reference and portability. + + Needless to say recompilation is necessary for most files. + System files affected gbc.c, defstruct.c, predicate.c, print.d + defstruct.lsp cmpfun.lsp cmputil.lsp cmpeval.lsp predlib.lsp + and maybe some other small changes. + + Naturally significant speedups will be gained if one can + keep integers in raw form: + (defstruct ja1 (a #\a :type character)(b 0 :type fixnum)) + (defun joe (x n) (sloop::sloop for i below n do (setf (ja1-b x) i))) + Then (joe (make-ja1) 1000000) takes less than 1 second now, + as opposed to over 50 seconds prior to these changes. + + +Wed Apr 26 11:59:43 1989 Bill Schelter (wfs at rascal) + + * Add message feature for AKCL start up. If unixport/message + exists and unixport/message-suppress does not, then + the file unixport/message will be printed on start up. (top.lsp) + + * make o/akcllib.a, a library containing bcmp .. and other + common functions which are not present in all versions of unix. + The main link puts this after -lc, so that faster implementation + dependent versions will be used if they exist. + +Mon Apr 24 20:28:49 1989 Bill Schelter (wfs at rascal) + + * Change to eliminate char_table.s assembler code. + This change will unfortunately require users to recompile + their object code for use with this system. + + * Fix bug in cmpinline.lsp, which was allowing + (rplacd (cons a b) nil) to give the wrong code. + + * Add timing for gc, and allow have the si::*notify-gbc* + flag cause printing the type of gc. + To time gc's. do (si::gbc-time 0), to set the timer to + 0, (si::gbc-time -1) to reset and turn it off. It + returns an integer in internal time units, similar + to get-internal-run-time. + + * Speed up the lisp reader and intern. On a large file the + read is 2.4 times faster than it was. + + * Many small changes to the include files, to eliminate duplicate + definitions of symbols, (not allowed by some compilers) + and also adding COMM_LENG, which can be null for most compilers + but should be a small integer for the IBM c compiler (it + does not accept external declarations int foo[], so we do + foo[COMM_LENG]; + + +Fri Apr 21 18:13:23 1989 Bill Schelter (wfs at rascal) + + * Fix bug with the new fast read-byte,.... + If the stream argument was supplied, and was not a stream + but rather T or NIL, there was a problem. If you declare + the arg to be of type stream, then you will get identical + code to before; otherwise a typecheck for type stream + will be supplied, branching into the slower code for + non streams. + Files cmpopt.lsp and cmptype.lsp + + +Tue Apr 18 22:56:54 1989 Bill Schelter (wfs at rascal) + + * More changes to read-byte, write-byte, read-char and + write-char. I have removed the :in-file and :out-file + declarations, and the speed up for the undeclared streams + should be virtually the same as obtained with the declarations. + This will affect mainly file streams. Files cmpfun.lsp, + cmpopt.lsp, cmpinclude.h, read.d + + Note that on read-byte it is still advantageous to use an + eof which is a fixnum. + + reads where the eof-error-p arg is not nil are not speeded up. + + It is still the case that two way streams are not speeded up, + however if (si::fp-input-stream str) returns non nil, then + you can use the resulting stream for fast input. + +Thu Apr 13 00:20:11 1989 Bill Schelter (wfs at rascal) + + * fixes to subtypep (as reported by riley) + + * changes to allow faster operation of read-char,write-char, + read-byte and write-byte, when operating on file streams. + In order to use these you should declare the stream + to be :in-file or :out-file. + You can use (typep str :in-file) to + check if it is really valid. + + (defun myread (str) + (declare (:in-file str)) + (the fixnum (read-byte str nil -100))) + + The above changes should work for ansi C style stdio, + in particular for unix io. At the moment it is conditionalized + for +unix. + files: cmpfun.lsp, cmpopt.lsp, cmtype.lsp, file.d, cmpenv.lsp + + The difference in reading speed is substantial: eg 3 microseconds + as opposed to 60 microseconds for read-byte. + + To make your code portable do + (proclaim '(declaration :in-file)) + + In order for the optimizations to cut in, + the read functions must be supplied with 3 args and the + write functions with 2. The second of the read args + must be nil. + Note with read-byte, using an eof value which is a fixnum, + allows you to declare the location you will pass to as a fixnum. + + + +Wed Mar 22 17:19:03 1989 Bill Schelter (wfs at rascal) + + * Change c1fmla-constant in cmpif.lsp. + (if (null 2) x y ) was yielding x not y! + +Sun Mar 19 12:26:21 1989 Bill Schelter (wfs at rascal) + + * fix stream_at_end, so that a stream opened for `io' + does the check, when reading, so that read can + return eof properly. + +Sun Mar 12 01:40:53 1989 Bill Schelter (wfs at rascal) + + * speed up the intern of symbol in pack_hash + computation. + + * psetf bug in case of two args (psetf a 3) + not passing the environment. setf.lsp + + +Fri Feb 24 22:27:22 1989 Bill Schelter (wfs at rascal) + + * add fixes for &environment to allow it to come + anywhere in the lambda list. defmacro.lsp and cmplam + (change from R. Harris). + +Wed Feb 22 17:24:30 1989 Bill Schelter (wfs at rascal) + + * fix tree-equal to save the previous test in list.d + (assoc '(c) '((a b) ((c) d)) :test #'tree-equal) failed. + (by Cooperman) + +Sun Feb 19 17:42:31 1989 Bill Schelter (wfs at rascal) + + * Fix hash_equal in hash.d. It was broken for circular + structures or lists. This would affect sxhash as well + as equal hash tables. + + * Fix obscure bug in compiler in cmptop.lsp, which could + possibly leave out a sup declaration. The c compiler + would catch this. + + * Fix comparison of arrays under equalp in c/predicate.c + It had been broken for rank different from 1. + * Fix the assembler for the sun4 in sun4_chtab.s for + multiply. (bug report by Harris). + +Fri Dec 9 00:47:46 1988 Bill Schelter (wfs at rascal) + + * Made changes to sfasl to make it more portable. + * added structures and characters to the types + handled by fasdump.c + * changed the c stack check in gbc.c to use cs_check. + +Sun Nov 27 12:31:13 1988 Bill Schelter (wfs at rascal) + + * Add si::fp-input-stream, si::fp-output-stream, + Which take one arg a stream, and return a stream + with an strm->sm.sm_fp slot suitable for use with fread and fwrite. + If this is not possible nil is returned. + + +Wed Nov 2 16:09:17 1988 Bill Schelter (wfs at rascal) + + * inline-args fix: + (defun x (c s i) + (declare (optimize (safety 2))) + (declare (fixnum i)) + (setf (char s (setq i (1+ i))) c)) + made c, not just i a fixnum in the char compilation, + fixed in inline-args (by E. Wang) edward@ucbarpa.Berkeley.EDU + file cmpinline.lsp + +Wed Oct 12 17:01:06 1988 Bill Schelter (wfs at rascal) + + * Added new array types: files cmptype,array.c,typespec.c,cmpopt, + predlib.lsp, gbc.c, and maybe some others. + Purpose of the change was to allow programs like CLX which + use lots of numerical arrays, to be much more economical. + Also make-array now coerces the element-type in a reasonable + way, and the same handling is used in the compiler. + + New array element types: + signed-char, unsigned-char, signed-short, unsigned-short + The ranges on a SUN are + ((INTEGER -128 127) (INTEGER 0 255) (INTEGER -32768 32767) + (INTEGER 0 65535)) respectively. + Note that now + make-array will always try to find the `best' array to + accommodate the element-type specified. For example on a SUN + (mod 1) --> bit + (integer 0 10) --> unsigned-char + (integer -3 10) --> signed-char + si::best-array-element-type is the function doing this. It + is also used by the compiler, for coercing array element types. + If you are going to declare an array you should use the same + element type as was used in making it. eg + (setq my-array (make-array 4 :element-type '(integer 0 10))) + (the (array (integer 0 10)) my-array) + + + + .. When wanting to optimize you need to make a reference: + (the fixnum (aref (the (array (integer -3 10)) ar) (the fixnum i))) + if ar were constructed using the (integer -3 10) element-type. + You could of course used signed-char, but since the ranges + may be implementation dependent it is better to use -3 10 range. + make-array needs to do some calculation with the element-type + if you don't provide a primitive data-type. One way of doing + this in a machine independent fashion: + (defvar *my-elt-type* #. (array-element-type (make-array 1 + :element-type '(integer -3 10)))) + Then calls to (make-array n :element-type *my-elt-type*) + will not have to go through a type inclusion computation. + + + +Tue Oct 11 09:52:13 1988 Bill Schelter (wfs at rascal) + + * When using gcc, it could happen that there was + a string in in the init function, which got placed + before the init function. Had to add -fwritable-strings + to stop this. + +Sun Oct 2 13:35:11 1988 Bill Schelter (wfs at rascal) + + * Fix MP386 and att port bugs, introduced with the + new mp386.h, att.h and mp386.defs files. + * Fix unixtime at least for bsd, so that get-internal-real-time + does not wrap every few hours, but will not wrap below 400 days. + * Fix directory problems with compiling in other than the current + directory, in the name of the file specified in the include. + The command on most systems cd 's to the directory to run the + cc, and so the .h file needed to use an unprefixed name. + + +Sat Sep 24 16:02:22 1988 Bill Schelter (wfs at rascal) + + * Changes to the computation of double-float-epsilon + and more generally XX-epsilon. First they did not + satisfy the condition of + (defun fo (e) (not (= (float 1 e) (+ (float 1 e) e)))) + (fo double-float-epsilon) --> t + as per CLtL. As it stands they at least satisfy the + test, although there may be floats slightly smaller which + also do. + + Second on some machines (eg HP) the calculation done + in line, carried more precision than that which would + be normal when passed through eql, so that we changed + the test == in constructing the double float epsilon + to use a function call. Otherwise the epsilon was + ~10^-20 instead of the correct ~10^-16. + +Thu Sep 22 14:08:07 1988 Bill Schelter (wfs at rascal) + + * Fixed hash_equal not to use the cast to int, + in computing hash of a symbol name + since this made sun4's unhappy (file hash.d ). + +Wed Sep 14 12:02:35 1988 Bill Schelter (wfs at rascal) + + * fix to setf to make sure that + (defmacro joe (x) `(progn t (car ,x))) + (defsetf joe rplaca) + work correctly. files changed are assignment.c and setf.lsp + The defsetf'd definition takes precedence in the macroexpansion. + The bad order was introduced when the evaluation of the macros including + their environments was introduced (see below). + +Mon Sep 12 10:09:56 1988 Bill Schelter (wfs at rascal) + + * use varargs.h for bind.c and list.d where + variable length args are passed. We only use + va_arg(ap,object) to access the next arg now. + There are no more indexed references, since that + is less portable. + + * A major change for porting: Each machine type + now has a .h file of its own, and things like alloc.c, + main.c, unixsave.c no longer should be modified for + individual machines. The file config.h is a link + from `your-machine`.h and things like the VSSIZE, + are also specified in that file. There are also + files such as bsd.h , att.h (for system V) which + can be included by the various special machine files. + + * c support for extended_div was added, and will + be used if USE_C_EXTENDED_DIV is defined. The only + function which does not have a C definition on the sun4 + version is extended_mul. Note that the c version + of extended_div is included in big.c rather than earith.c + since the latter is not compiled with the optimize switch. + + * The assembler functions of bitop.c had been being redefined + by macros in gbc.c in an earlier change (this was actually + 4 times faster on a sun3), and now those functions have + dummy definitions, which will go away soon. + +Wed Aug 31 23:38:08 1988 Bill Schelter (wfs at rascal) + + * use varargs for the funlink of proclaimed functions, + This affects cmpcall.lsp, funlink.c and requires + to be included by cmpinclude. + The old variable arg business was not portable to risc + architectures, where args are passed in registers. + + * make print return a value in print.d + Hope there are not more `implicit returns' hidden away. + +Fri Aug 19 15:13:06 1988 Bill Schelter (wfs at rascal) + + * Make (subtypep 'string-char 'character) --> t + +Wed Aug 3 11:33:20 1988 Bill Schelter (wfs at rascal) + + * I have removed the dynamic growing of the special binding + stack which I had added a few months ago (cf bds.h,main.c,bds.c.) + It had ignored + the fact that some functions eg, Levalhook grab a pointer + into the bds rather than just an index. These could easily have + been changed, but until we allow the other stacks to grow + dynamically, it is of questionable value. + +Fri Jul 1 09:41:36 1988 Bill Schelter (wfs at rascal) + + * allow assoc to take key in c/list.d as per mail + 442 23-Jun pc%linus@mitre-bedford.ar KCL Bug: assoc doesn't take :key + + +Wed Jun 15 16:46:40 1988 Bill Schelter (wfs at rascal) + + * Added support for switch construct (see cmpnew/cmptag.lsp + for documentation) + This will allow compiling into the c switch construct + if (the test variable is declared to be a subtype of + fixnum) which can then allow much faster switching on + cases. To do:Should optimize some of case constructs into + switch, where applicable. + +Wed Jun 8 11:43:00 1988 Bill Schelter (wfs at rascal) + + * Altered the marking of the c stack in gbc.c. + Now the current location for the c stack is taken + in a separate function from the one where the environment + is forced onto the stack, so that we don't have to + depend on the c compilers doing things in the expected + order. See mark_stack_carefully. Also added a flag + C_GC_OFFSET which if defined to 2, will mark + the stack twice once on 4m and once on 4m+2. + + * changed the initialization in main.c of bds_org + and bds_limit. + + This is to fit in with the earlier change to + bds_overflow, to allow the bds to grow. bds_org + is now a pointer rather than a hardwired value. + + +Tue Jun 7 04:44:15 1988 Bill Schelter (wfs at rascal) + + * Fix equalp to use the fill-pointer as a limit + when comparing strings,vectors and bitvectors. + + +Mon Jun 6 11:29:08 1988 Bill Schelter (wfs at rascal) + + * Fix rotatef in setf.lsp to return NIL per CLtL + * Fix handling of &rest arg in cmplam.lsp + c2lambda-expr-without-key as per bug fix of Yuasa + 12-Nov yuasa%kurims.kurims.kyoto A bug fix + * Add the fix to quick-sort as per + 67 12-Jan yuasa%tutics.tut.junet%ut Re: sort bug + * Add fix for shadowing-import per + 68 12-Jan yuasa%tutics.tut.junet%ut Re: SHADOWING-IMPORT doesn't + * Fix (random 0) bug, adding TSpositive_number type. as per + 69 12-Jan yuasa%.. Re: (random 0) => losing error message + * Fix (make-array 2 0) bug per + 70 13-Jan yuasa%tutics.tut.junet%ut Re: Nil is a sequence + * Add bogus value (*READ-DEFAULT-FLOAT-FORMAT* t) when + printing a float in a compiled file, so that it will always + add the type in the printing, and we won't get a float + type different from that used at compile time + cf. 80 28-Jan yuasa%tutics.tut.junet%ut Re: float numbers + * Add fix for bug + setf (aref x (decf i)) (aref x 1)) -> + "base[2]= aset1(base[0],V1,fix(base[1]));" + to cmpinline.lsp, as per + 92 8-Feb yuasa%tutics.tut.junet%ut Re: compiler bug? + *All fixes by yuasa in the kcl-mail-archive thru Jun 88 + are now incorporated in akcl + * Altered cmp-macroexpand-1 to use the local macro environment + + + + +Wed Jun 1 13:29:57 1988 Bill Schelter (wfs at rascal) + + * Altered macros.c to pass the function-macro environment + if it is non nil. This is needed so that macro expansion + functions can be called in the correct environment. + Altered cmputil.lsp so that cmp-macroexpand and cmp-macro-expand + both use the current compiler macro environment. + Finally altered setf, so that it looks at the macro + environment when it expands the place. + + Deleted treatment of setf as special form by the compiler, + (introduced yesterday!) + now that macros are handled correctly, and it is defined + correctly as a macro. + + Things like + (macrolet ((ab nil 'a)) (setf (the fixnum (ab)) 3)) + Now work to give (set 'a (the fixnum 3)) as expected. + + + +Mon May 30 11:40:47 1988 Bill Schelter (wfs at rascal) + + * Altered setf to macroexpand the place in the current + lexical environment so that + (macrolet ((joe nil 'bil))(setf (joe) n)) + would behave correctly. This change was in assignment.c + in `setf' and also in cmputils.lsp adding c1setf, to + get analagous treatment for compiler. + To do: + It is still not totally correct: I don't handle + (macrolet ((joe nil 'bil))(setf (the fixnum (joe)) n)) + but + (macrolet ((joe nil '(the fixnum bil)))(setf (joe) n)) + is ok. + +Tue May 24 09:38:58 1988 Bill Schelter (wfs at rascal) + + * Changed float to return single-float if given only one + arg, as per CLtL. + + * Added a dynamic growth feature the bds stack, changing + bds_org to be a variable rather than a macro, and altering + bds_overflow. + + *Enforce substantial constraints on downward closures ,to be relaxed + at a future date: Currently no args, and no cross references + to other types of closures. This is done in check-downward + in t1defun. + + + + + + + + diff --git a/o/NeXTunixfasl.c b/o/NeXTunixfasl.c new file mode 100755 index 0000000..4503172 --- /dev/null +++ b/o/NeXTunixfasl.c @@ -0,0 +1,469 @@ +/* + * FASL loader using rld() for NeXT + * + * Written by Noritake YONEZAWA (yonezawa@lsi.tmg.nec.co.jp) + * February 14, 1992 + * + * Modified by Noritake YONEZAWA (yonezawa@lsi.tmg.nec.co.jp) + * May 1, 1995 + * June 5, 1995 + * June 6, 1995 + */ + +#include +#include +#include + +#include +#include +#include +#include +#include + +static unsigned long object_size, object_start; + +static unsigned long +my_address_func(size, headers_size) + unsigned long size; + unsigned long headers_size; +{ + return (object_start = + (unsigned long)alloc_contblock(object_size = size + headers_size)); +} + +static void +load_mach_o(filename) + char *filename; +{ + FILE *fp; + struct mach_header header; + char *hdrbuf; + struct load_command *load_command; + struct segment_command *segment_command; + struct section *section; + int len, cmd, seg; + + if ((fp = fopen(filename, "r")) == NULL) + FEerror("Can't read Mach-O object file", 0); + len = fread((char *)&header, sizeof(struct mach_header), 1, fp); + if (len == 1 && header.magic == MH_MAGIC) { + hdrbuf = (char *)malloc(header.sizeofcmds); + len = fread(hdrbuf, header.sizeofcmds, 1, fp); + if (len != 1) + FEerror("failure reading Mach-O load commands", 0); + load_command = (struct load_command *) hdrbuf; + for (cmd = 0; cmd < header.ncmds; ++cmd) { + if (load_command->cmd == LC_SEGMENT) { + segment_command = (struct segment_command *) load_command; + section = (struct section *) ((char *)(segment_command + 1)); + for (seg = 0; seg < segment_command->nsects; ++seg, ++section) { + if (section->size != 0 && section->offset != 0) { +#ifdef DEBUG + fprintf(stderr, "section: %s, addr: 0x%08x, size: %d\n", + section->sectname, section->addr, section->size); + fflush(stderr); +#endif + fseek(fp, section->offset, 0); + fread((char *)section->addr, section->size, 1, fp); + } + } + } + load_command = (struct load_command *) + ((char *)load_command + load_command->cmdsize); + } + free(hdrbuf); + } + (void)fclose(fp); +} + +int +seek_to_end_ofile(fp) + FILE *fp; +{ + struct mach_header mach_header; + char *hdrbuf; + struct load_command *load_command; + struct segment_command *segment_command; + struct section *section; + struct symtab_command *symtab_command; + struct symseg_command *symseg_command; + int len, cmd, seg; + int end_sec, end_ofile; + + end_ofile = 0; + fseek(fp, 0L, 0); + len = fread((char *)&mach_header, sizeof(struct mach_header), 1, fp); + if (len == 1 && mach_header.magic == MH_MAGIC) { + hdrbuf = (char *)malloc(mach_header.sizeofcmds); + len = fread(hdrbuf, mach_header.sizeofcmds, 1, fp); + if (len != 1) { + fprintf(stderr, "seek_to_end_ofile(): failure reading Mach-O load commands\n"); + return 0; + } + load_command = (struct load_command *) hdrbuf; + for (cmd = 0; cmd < mach_header.ncmds; ++cmd) { + switch (load_command->cmd) { + case LC_SEGMENT: + segment_command = (struct segment_command *) load_command; + section = (struct section *) ((char *)(segment_command + 1)); + for (seg = 0; seg < segment_command->nsects; ++seg, ++section) { + end_sec = section->offset + section->size; + if (end_sec > end_ofile) + end_ofile = end_sec; + } + break; + case LC_SYMTAB: + symtab_command = (struct symtab_command *) load_command; + end_sec = symtab_command->symoff + symtab_command->nsyms * sizeof(struct nlist); + if (end_sec > end_ofile) + end_ofile = end_sec; + end_sec = symtab_command->stroff + symtab_command->strsize; + if (end_sec > end_ofile) + end_ofile = end_sec; + break; + case LC_SYMSEG: + symseg_command = (struct symseg_command *) load_command; + end_sec = symseg_command->offset + symseg_command->size; + if (end_sec > end_ofile) + end_ofile = end_sec; + break; + } + load_command = (struct load_command *) + ((char *)load_command + load_command->cmdsize); + } + free(hdrbuf); + fseek(fp, end_ofile, 0); + return 1; + } + return 0; +} + +static char *library_search_path[] = +{"/lib", "/usr/lib", "/usr/local/lib", NULL}; + +#define strdup(string) strcpy((char *)malloc(strlen(string)+1),(string)) + +static char * +expand_library_filename(filename) + char *filename; +{ + int fd; + char **dir; + char libname[256]; + char fullname[256]; + + if (filename[0] == '-' && filename[1] == 'l') { + filename++; + filename++; + strcpy(libname, "lib"); + strcat(libname, filename); + strcat(libname, ".a"); + for (dir = library_search_path; *dir; dir++) { + strcpy(fullname, *dir); + strcat(fullname, "/"); + strcat(fullname, libname); +#ifdef DEBUG + fprintf(stderr, "%s\n", fullname); + fflush(stderr); +#endif + if ((fd = open(fullname, O_RDONLY, 0)) > 0) { + close(fd); + return (strdup(fullname)); + } + } + return (strdup(libname)); + } + return (strdup(filename)); +} + +static char ** +make_ofile_list(faslfile, argstr) + char *faslfile, *argstr; +{ + char filename[256]; + char *dst; + int i; + char **ofile_list; + + ofile_list = (char **)calloc(1, sizeof(char *)); + ofile_list[0] = strdup(faslfile); + i = 1; + if (argstr != NULL) { + for (;; i++) { + while ((*argstr == ' ') && (*argstr != '\0')) + argstr++; + if (*argstr == '\0') + break; + dst = filename; + while ((*argstr != ' ') && (*argstr != '\0')) + *dst++ = *argstr++; + *dst = '\0'; + ofile_list = (char **)realloc((void *)ofile_list, + (i + 1) * sizeof(char *)); + ofile_list[i] = expand_library_filename(filename); + } + } + ofile_list = (char **)realloc((void *)ofile_list, (i + 1) * sizeof(char *)); + ofile_list[i] = NULL; + return (ofile_list); +} + +static void +free_ofile_list(ofile_list) + char **ofile_list; +{ + int i; + + for (i = 1;; i++) { + if (ofile_list[i] == NULL) + break; + (void)free(ofile_list[i]); + } + (void)free(ofile_list); +} + +#ifdef DEBUG +static void +print_ofile_list(ofile_list) + char **ofile_list; +{ + int i; + + if (ofile_list == NULL) + return; + fprintf(stderr, "ofiles: "); + for (i = 0;; i++) { + if (ofile_list[i] == NULL) + break; + fprintf(stderr, "(%s)", ofile_list[i]); + } + fprintf(stderr, "\n"); + fflush(stderr); +} + +#endif + +int +fasload(pathname) + object pathname; +{ + FILE *fp; + object *old_vs_base = vs_base; + object *old_vs_top = vs_top; + object memory; + object fasl_data; + object stream; + char entryname[100]; + char filename[256]; + char tempfilename[40]; + char **ofiles; + NXStream *err_stream; + void (*entry) (); + struct mach_header *hdr; + + stream = open_stream(pathname, smm_input, Cnil, sKerror); + fp = stream->sm.sm_fp; + + seek_to_end_ofile(fp); + fasl_data = read_fasl_vector(stream); + vs_push(fasl_data); + + pathname = coerce_to_pathname(stream); + coerce_to_filename(stream, filename); + + if ((err_stream = NXOpenFile(fileno(stderr), NX_WRITEONLY)) == 0) + FEerror("NXOpenFile() failed", 0); + + sprintf(tempfilename, "/tmp/fasltemp%d", getpid()); + rld_address_func(my_address_func); + ofiles = make_ofile_list(filename, NULL); +#ifdef DEBUG + print_ofile_list(ofiles); +#endif + if (!rld_load(err_stream, &hdr, ofiles, tempfilename)) { + free_ofile_list(ofiles); + NXFlush(err_stream); + NXClose(err_stream); + FEerror("rld_load() failed", 0); + } + free_ofile_list(ofiles); + load_mach_o(tempfilename); + unlink(tempfilename); + + strcpy(entryname, "_init_code"); + if (!rld_lookup(err_stream, entryname, (unsigned long *)&entry)) { + strcpy(entryname, "_init_"); + bcopy(pathname->pn.pn_name->st.st_self, + entryname + 6, pathname->pn.pn_name->st.st_fillp); + entryname[6 + pathname->pn.pn_name->st.st_fillp] = 0; + if (!rld_lookup(err_stream, entryname, (unsigned long *)&entry)) { + NXFlush(err_stream); + NXClose(err_stream); + FEerror("Can't find init code", 0); + } + } + (void)rld_unload_all(err_stream, 0); + NXFlush(err_stream); + NXClose(err_stream); + + +#ifdef DEBUG + { + extern char *mach_brkpt, *mach_maplimit, *core_end; + + fprintf(stderr, "mach_brkpt : 0x%08x\n", mach_brkpt); + fprintf(stderr, "mach_maplimit : 0x%08x\n", mach_maplimit); + fprintf(stderr, "core_end : 0x%08x\n", core_end); + fprintf(stderr, "hdr : 0x%08x\n", hdr); + fprintf(stderr, "object_start : 0x%08x\n", object_start); + fprintf(stderr, "object_size : %d\n", object_size); + fprintf(stderr, "&%s : 0x%08x\n", entryname, entry); + fflush(stderr); + } +#endif + + memory = alloc_object(t_cfdata); + memory->cfd.cfd_self = 0; + memory->cfd.cfd_fillp = 0; + memory->cfd.cfd_size = object_size; + memory->cfd.cfd_start = (char *)object_start; + vs_push(memory); + +#ifdef CLEAR_CACHE + CLEAR_CACHE; +#endif + call_init(entry - object_start, memory, fasl_data,0); + + if (symbol_value(sLAload_verboseA) != Cnil) + printf("start address -T 0x%08x ", entry); + + vs_base = old_vs_base; + vs_top = old_vs_top; + close_stream(stream); + return object_size; +} + +int +faslink(pathname, ldargstring) + object pathname, ldargstring; +{ + FILE *fp; + object *old_vs_base = vs_base; + object *old_vs_top = vs_top; + object memory; + object fasl_data; + object stream; + char entryname[100]; + char filename[256]; + char ldargstr[256]; + char tempfilename[40]; + char **ofiles; + NXStream *err_stream; + void (*entry) (); + struct mach_header *hdr; + + stream = open_stream(pathname, smm_input, Cnil, sKerror); + fp = stream->sm.sm_fp; + + seek_to_end_ofile(fp); + fasl_data = read_fasl_vector(stream); + vs_push(fasl_data); + + pathname = coerce_to_pathname(stream); + coerce_to_filename(stream, filename); + coerce_to_filename(ldargstring, ldargstr); + + if ((err_stream = NXOpenFile(fileno(stderr), NX_WRITEONLY)) == 0) + FEerror("NXOpenFile() failed", 0); + + sprintf(tempfilename, "/tmp/fasltemp%d", getpid()); + rld_address_func(my_address_func); + ofiles = make_ofile_list(filename, ldargstr); +#ifdef DEBUG + print_ofile_list(ofiles); +#endif + if (!rld_load(err_stream, &hdr, ofiles, tempfilename)) { + free_ofile_list(ofiles); + NXFlush(err_stream); + NXClose(err_stream); + FEerror("rld_load() failed", 0); + } + free_ofile_list(ofiles); + load_mach_o(tempfilename); + unlink(tempfilename); + + strcpy(entryname, "_init_code"); + if (!rld_lookup(err_stream, entryname, (unsigned long *)&entry)) { + strcpy(entryname, "_init_"); + bcopy(pathname->pn.pn_name->st.st_self, + entryname + 6, pathname->pn.pn_name->st.st_fillp); + entryname[6 + pathname->pn.pn_name->st.st_fillp] = 0; + if (!rld_lookup(err_stream, entryname, (unsigned long *)&entry)) { + NXFlush(err_stream); + NXClose(err_stream); + FEerror("Can't find init code", 0); + } + } + (void)rld_unload_all(err_stream, 0); + NXFlush(err_stream); + NXClose(err_stream); + + +#ifdef DEBUG + { + extern char *mach_brkpt, *mach_maplimit, *core_end; + + fprintf(stderr, "mach_brkpt : 0x%08x\n", mach_brkpt); + fprintf(stderr, "mach_maplimit : 0x%08x\n", mach_maplimit); + fprintf(stderr, "core_end : 0x%08x\n", core_end); + fprintf(stderr, "hdr : 0x%08x\n", hdr); + fprintf(stderr, "object_start : 0x%08x\n", object_start); + fprintf(stderr, "object_size : %d\n", object_size); + fprintf(stderr, "&%s : 0x%08x\n", entryname, entry); + fflush(stderr); + } +#endif + + memory = alloc_object(t_cfdata); + memory->cfd.cfd_self = 0; + memory->cfd.cfd_fillp = 0; + memory->cfd.cfd_size = object_size; + memory->cfd.cfd_start = (char *)object_start; + vs_push(memory); + +#ifdef CLEAR_CACHE + CLEAR_CACHE; +#endif + call_init(entry - object_start, memory, fasl_data,0); + + if (symbol_value(sLAload_verboseA) != Cnil) + printf("start address -T 0x%08x \n", entry); + + vs_base = old_vs_base; + vs_top = old_vs_top; + close_stream(stream); + return object_size; +} + +siLfaslink() +{ + bds_ptr old_bds_top; + int i; + object package; + + check_arg(2); + check_type_or_pathname_string_symbol_stream(&vs_base[0]); + check_type_string(&vs_base[1]); + vs_base[0] = coerce_to_pathname(vs_base[0]); + vs_base[0]->pn.pn_type = FASL_string; + vs_base[0] = namestring(vs_base[0]); + package = symbol_value(sLApackageA); + old_bds_top = bds_top; + bds_bind(sLApackageA, package); + i = faslink(vs_base[0], vs_base[1]); + bds_unwind(old_bds_top); + vs_top = vs_base; + vs_push(make_fixnum(i)); +} + +#define FASLINK diff --git a/o/NeXTunixsave.c b/o/NeXTunixsave.c new file mode 100755 index 0000000..dde9ed0 --- /dev/null +++ b/o/NeXTunixsave.c @@ -0,0 +1,499 @@ +/* + * unexec for the NeXT Mach environment. + * + * Bradley Taylor (btaylor@NeXT.COM) + * February 28, 1990 + * + * Modified by Noritake YONEZAWA (yonezawa@cs.uiuc.edu) + * July 28, 1991 + * + * Modified by Noritake YONEZAWA (yonezawa@lsi.tmg.nec.co.jp) + * February 16, 1992 + * + * Modified by Noritake YONEZAWA (yonezawa@lsi.tmg.nec.co.jp) + * May 1, 1995 + */ +#undef __STRICT_BSD__ + +#include +#include +#include +#include +#include +#include +#include + +#define CEIL(x,quantum) ((((int)(x))+(quantum)-1)&~((quantum)-1)) + +#ifndef BIG_HEAP_SIZE +#define BIG_HEAP_SIZE 0x1000000 +#endif + +int big_heap = BIG_HEAP_SIZE; + +char *mach_maplimit = 0; +char *mach_brkpt = 0; + + +typedef struct region_t { + vm_address_t address; + vm_size_t size; + vm_prot_t protection; + vm_prot_t max_protection; + vm_inherit_t inheritance; + boolean_t shared; + port_t object_name; + vm_offset_t offset; +} region_t; + +char * +my_sbrk(incr) + int incr; +{ + char *temp, *ptr; + kern_return_t rtn; + + if (mach_brkpt == 0) { + if ((rtn = vm_allocate(task_self(), (vm_address_t *) & mach_brkpt, + big_heap, 1)) != KERN_SUCCESS) { + mach_error("my_sbrk(): vm_allocate() failed", rtn); + return ((char *)-1); + } + mach_maplimit = mach_brkpt + big_heap; + } + if (incr == 0) { + return (mach_brkpt); + } else { + ptr = mach_brkpt + incr; + if (ptr <= mach_maplimit) { + temp = mach_brkpt; + mach_brkpt = ptr; + return (temp); + } else { + fprintf(stderr, "my_sbrk(): no more memory\n"); + fflush(stderr); + return ((char *)-1); + } + } +} + +static void +grow( + struct load_command ***the_commands, + unsigned *the_commands_len + ) +{ + if (*the_commands == NULL) { + *the_commands_len = 1; + *the_commands = malloc(sizeof(*the_commands)); + } else { + (*the_commands_len)++; + *the_commands = realloc(*the_commands, + (*the_commands_len * + sizeof(**the_commands))); + } +} + + +static void +save_command( + struct load_command *command, + struct load_command ***the_commands, + unsigned *the_commands_len + ) +{ + struct load_command **tmp; + + grow(the_commands, the_commands_len); + tmp = &(*the_commands)[*the_commands_len - 1]; + *tmp = malloc(command->cmdsize); + bcopy(command, *tmp, command->cmdsize); +} + +static void +fatal_unexec(char *format) +{ + fprintf(stderr, "unexec: "); + fprintf(stderr, format); + fprintf(stderr, "\n"); +} + +static void +fatal_unexec2( + char *format, + char *arg1 + ) +{ + fprintf(stderr, "unexec: "); + fprintf(stderr, format, arg1); + fprintf(stderr, "\n"); +} + +static void +fatal_unexec3( + char *format, + char *arg1, + char *arg2 + ) +{ + fprintf(stderr, "unexec: "); + fprintf(stderr, format, arg1, arg2); + fprintf(stderr, "\n"); +} + +static int +read_macho( + int fd, + struct mach_header *the_header, + struct load_command ***the_commands, + unsigned *the_commands_len + ) +{ + struct load_command command; + struct load_command *buf; + int i; + int size; + + if (read(fd, the_header, sizeof(*the_header)) != sizeof(*the_header)) { + fatal_unexec("cannot read macho header"); + return (0); + } + for (i = 0; i < the_header->ncmds; i++) { + if (read(fd, &command, sizeof(struct load_command)) != + sizeof(struct load_command)) { + fatal_unexec("cannot read macho load command header"); + return (0); + } + size = command.cmdsize - sizeof(struct load_command); + if (size < 0) { + fatal_unexec("bogus load command size"); + return (0); + } + buf = malloc(command.cmdsize); + buf->cmd = command.cmd; + buf->cmdsize = command.cmdsize; + if (read(fd, ((char *)buf + + sizeof(struct load_command)), + size) != size) { + fatal_unexec("cannot read load command data"); + return (0); + } + save_command(buf, the_commands, the_commands_len); + } + return (1); +} + +static int +filldatagap( + vm_address_t start_address, + vm_size_t *size, + vm_address_t end_address + ) +{ + vm_address_t address; + vm_size_t gapsize; + + address = (start_address + *size); + gapsize = end_address - address; + *size += gapsize; + if (vm_allocate(task_self(), &address, gapsize, + FALSE) != KERN_SUCCESS) { + fatal_unexec("cannot vm_allocate"); + return (0); + } + return (1); +} + +static int +get_data_region( + vm_address_t *address, + vm_size_t *size + ) +{ + region_t region; + kern_return_t ret; + struct section *sect; + + sect = getsectbyname(SEG_DATA, SECT_DATA); + region.address = 0; + *address = 0; + for (;;) { + ret = vm_region(task_self(), + ®ion.address, + ®ion.size, + ®ion.protection, + ®ion.max_protection, + ®ion.inheritance, + ®ion.shared, + ®ion.object_name, + ®ion.offset); + if (ret != KERN_SUCCESS || region.address >= mach_maplimit) { + break; + } + if (*address != 0) { + if (region.address > *address + *size) { + if (!filldatagap(*address, size, + region.address)) { + return (0); + } + } + *size += region.size; + } else { + if (region.address == sect->addr) { + *address = region.address; + *size = region.size; + } + } + region.address += region.size; + } + return (1); +} + +static char * +my_malloc( + vm_size_t size + ) +{ + vm_address_t address; + + if (vm_allocate(task_self(), &address, size, TRUE) != KERN_SUCCESS) { + return (NULL); + } + return ((char *)address); +} + +static void +my_free( + char *buf, + vm_size_t size + ) +{ + vm_deallocate(task_self(), (vm_address_t)buf, size); +} + +static int +unexec_doit( + int infd, + int outfd + ) +{ + int i; + struct load_command **the_commands = NULL; + unsigned the_commands_len; + struct mach_header the_header; + int fgrowth; + int fdatastart; + int fdatasize; + int size; + int seg; + struct stat st; + char *buf; + vm_address_t data_address; + vm_size_t data_size, bss_size; + + struct segment_command *segment; + struct section *section; + + if (!read_macho(infd, &the_header, &the_commands, &the_commands_len)) { + return (0); + } + + if (!get_data_region(&data_address, &data_size)) { + return (0); + } + + /* + * DO NOT USE MALLOC IN THIS SECTION + */ + { + /* + * Fix offsets + */ + for (i = 0; i < the_commands_len; i++) { + switch (the_commands[i]->cmd) { + case LC_SEGMENT: + segment = ((struct segment_command *) + the_commands[i]); + if (strcmp(segment->segname, SEG_DATA) == 0) { +/* + data_address = segment->vmaddr; +*/ + data_size = CEIL(mach_brkpt - data_address, getpagesize()); + bss_size = mach_maplimit - mach_brkpt; + fdatastart = segment->fileoff; + fdatasize = segment->filesize; + fgrowth = (data_size - + segment->filesize); + segment->vmsize = data_size + bss_size; + segment->filesize = data_size; + + section = (struct section *) ((char *) (segment + 1)); + for (seg = 0; seg < segment->nsects; ++seg, ++section) { + if (strcmp(section->sectname, SECT_DATA) == 0) { + section->size = data_size; + } + else if (strcmp(section->sectname, SECT_BSS) == 0) { + section->addr = data_address + data_size; + section->size = bss_size; + section->flags = S_ZEROFILL; + } + else if (strcmp(section->sectname, SECT_COMMON) == 0) { + section->addr = data_address + data_size + bss_size; + } + } + } + if (strcmp(segment->segname, SEG_LINKEDIT) == 0) { + segment->vmaddr += CEIL(fgrowth + bss_size, getpagesize()); + segment->fileoff += fgrowth; + } + break; + case LC_SYMTAB: + ((struct symtab_command *) + the_commands[i])->symoff += fgrowth; + ((struct symtab_command *) + the_commands[i])->stroff += fgrowth; + break; + case LC_SYMSEG: + ((struct symseg_command *) + the_commands[i])->offset += fgrowth; + break; + default: + break; + } + } + + /* + * Write header + */ + if (write(outfd, &the_header, + sizeof(the_header)) != sizeof(the_header)) { + fatal_unexec("cannot write header"); + return (0); + } + + /* + * Write commands + */ + for (i = 0; i < the_commands_len; i++) { + if (write(outfd, the_commands[i], + the_commands[i]->cmdsize) != + the_commands[i]->cmdsize) { + fatal_unexec("cannot write commands"); + return (0); + } + } + + /* + * Write original text + */ + if (lseek(infd, the_header.sizeofcmds + sizeof(the_header), + L_SET) < 0) { + fatal_unexec("cannot seek input file"); + return (0); + } + size = fdatastart - (sizeof(the_header) + + the_header.sizeofcmds); + buf = my_malloc(size); + if (read(infd, buf, size) != size) { + my_free(buf, size); + fatal_unexec("cannot read input file"); + } + if (write(outfd, buf, size) != size) { + my_free(buf, size); + fatal_unexec("cannot write original text"); + return (0); + } + my_free(buf, size); + + + /* + * Write new data + */ + if (write(outfd, (char *)data_address, + data_size) != data_size) { + fatal_unexec("cannot write new data"); + return (0); + } + + } + + /* + * OKAY TO USE MALLOC NOW + */ + + /* + * Write rest of file + */ + fstat(infd, &st); + if (lseek(infd, fdatasize, L_INCR) < 0) { + fatal_unexec("cannot seek input file"); + return (0); + } + size = st.st_size - lseek(infd, 0, L_INCR); + + buf = malloc(size); + if (read(infd, buf, size) != size) { + free(buf); + fatal_unexec("cannot read input file"); + return (0); + } + if (write(outfd, buf, size) != size) { + free(buf); + fatal_unexec("cannot write reset of file"); + return (0); + } + free(buf); + return (1); +} + +void +unexec( + char *outfile, + char *infile, + int dummy1, + int dummy2, + int dummy3 + ) +{ + int infd; + int outfd; + char tmpbuf[L_tmpnam]; + char *tmpfile; + + infd = open(infile, O_RDONLY, 0); + if (infd < 0) { + fatal_unexec2("cannot open input file `%s'", infile); + exit(1); + } + + tmpnam(tmpbuf); + tmpfile = rindex(tmpbuf, '/'); + if (tmpfile == NULL) { + tmpfile = tmpbuf; + } else { + tmpfile++; + } + outfd = open(tmpfile, O_WRONLY|O_TRUNC|O_CREAT, 0755); + if (outfd < 0) { + close(infd); + fatal_unexec2("cannot open tmp file `%s'", tmpfile); + exit(1); + } + if (!unexec_doit(infd, outfd)) { + close(infd); + close(outfd); + unlink(tmpfile); + exit(1); + } + close(infd); + close(outfd); + if (rename(tmpfile, outfile) < 0) { + unlink(tmpfile); + fatal_unexec3("cannot rename `%s' to `%s'", tmpfile, outfile); + exit(1); + } +} + +#ifdef UNIXSAVE +#include "save.c" +#endif diff --git a/o/Vmalloc.c b/o/Vmalloc.c new file mode 100755 index 0000000..19caff2 --- /dev/null +++ b/o/Vmalloc.c @@ -0,0 +1,101 @@ +Changes file for /usr/local/src/kcl/c/malloc.c +Created on Tue Oct 24 20:01:59 1989 +Usage \n@s[Original text\n@s|Replacement Text\n@s] +See the file rascal.ics.utexas.edu:/usr2/ftp/merge.c +for a program to merge change files. Anything not between +"\n@s[" and "\n@s]" is a simply a comment. +This file was constructed using emacs and merge.el +Enhancements Copyright (c) W. Schelter All rights reserved. + by (Bill Schelter) wfs@carl.ma.utexas.edu + + +****Change:(orig (131 131 c)) +@s[ * if the power of 2 is correct. + */ + + +@s| * if the power of 2 is correct. + */ +/* Oct 89: wfs@cs.utexas.edu: Created V/ merge file for + * changes for GCL. + * Calls to sbrk replaced by alloc_page. Remove some of the + * additions for emacs. + * NB: According to the gnu license you may only distribute the + * verbatim copy of the gnumalloc.c. Thus we only distribute + * an abbreviated diffs file from that verbatim copy. +*/ + +@s] + + +****Change:(orig (162 162 c)) +@s[#include "getpagesize.h" + +@s|#define getpagesize() 2048 + +@s] + + +****Change:(orig (170 170 c)) +@s[#include + +@s|/* #include */ + +@s] + + +****Change:(orig (202 202 a)) +@s[static char *data_space_start; + + +@s|static char *data_space_start; + +#define PAGEWIDTH 11 +char *alloc_page(); +#define sbrk our_sbrk +char * +our_sbrk(x) +int x; +{return alloc_page((x >> PAGEWIDTH));} + + + + + +@s] + + +****Change:(orig (338 378 d)) +@s[#ifndef VMS + /* Maximum virtual memory on VMS is difficult to calculate since it + * depends on several dynmacially changing things. Also, alignment + * isn't that important. That is why much of the code here is ifdef'ed + +@s, sbrk (1024 - ((int) cp & 0x3ff)); +#endif /* not VMS */ + + +@s| +@s] + + +****Change:(orig (385 385 c)) +@s[ if ((cp = sbrk (1 << (siz + 3))) == (char *) -1) + +@s| if ((cp = sbrk (1 << (siz + 3)))==0) + +@s] + + +****Change:(orig (387 393 d)) +@s[#ifndef VMS + if ((int) cp & 7) + { /* shouldn't happen, but just in case */ + cp = (char *) (((int) cp + 8) & ~7); + +@s, } +#endif /* not VMS */ + +@s| +@s] + diff --git a/o/alloc.c b/o/alloc.c new file mode 100644 index 0000000..996718f --- /dev/null +++ b/o/alloc.c @@ -0,0 +1,1762 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +/* + alloc.c + IMPLEMENTATION-DEPENDENT +*/ + +#include +#include +#include + +#include "include.h" +#include "page.h" + +#ifdef HAVE_MPROTECT +#include +#endif + +static int +t_from_type(object); + + +DEFVAR("*AFTER-GBC-HOOK*",sSAafter_gbc_hookA,SI,sLnil,""); +DEFVAR("*IGNORE-MAXIMUM-PAGES*",sSAignore_maximum_pagesA,SI,sLt,""); +#define IGNORE_MAX_PAGES (sSAignore_maximum_pagesA ==0 || sSAignore_maximum_pagesA->s.s_dbind !=sLnil) + +static void call_after_gbc_hook(int t); + +#ifdef DEBUG_SBRK +int debug; +char * +sbrk1(n) + int n; +{char *ans; + if (debug){ + printf("\n{sbrk(%d)",n); + fflush(stdout);} + ans= (char *)sbrk(n); + if (debug){ + printf("->[0x%x]", ans); + fflush(stdout); + printf("core_end=0x%x,sbrk(0)=0x%x}",core_end,sbrk(0)); + fflush(stdout);} + return ans; +} +#define sbrk sbrk1 +#endif /* DEBUG_SBRK */ + +long starting_hole_div=10; +long starting_relb_heap_mult=2; +long new_holepage; +long resv_pages=40; + +#ifdef BSD +#include +#include +#ifdef RLIMIT_STACK +struct rlimit data_rlimit; +#endif +#endif + +inline void +add_page_to_contblock_list(void *p,fixnum m) { + + struct pageinfo *pp=pageinfo(p); + + bzero(pp,sizeof(*pp)); + pp->type=t_contiguous; + pp->in_use=m; + massert(pp->in_use==m); + pp->magic=PAGE_MAGIC; + + if (contblock_list_head==NULL) + contblock_list_tail=contblock_list_head=p; + else if (pp > contblock_list_tail) { + contblock_list_tail->next=p; + contblock_list_tail=p; + } + + bzero(pagetochar(page(pp)),CB_DATA_START(pp)-(void *)pagetochar(page(pp))); +#ifdef SGC + if (sgc_enabled && tm_table[t_contiguous].tm_sgc) { + memset(CB_SGCF_START(pp),-1,CB_DATA_START(pp)-CB_SGCF_START(pp)); + pp->sgc_flags=SGC_PAGE_FLAG; + } +#endif + + ncbpage+=m; + insert_contblock(CB_DATA_START(pp),CB_DATA_END(pp)-CB_DATA_START(pp)); + +} + +int +icomp(const void *v1,const void *v2) { + const fixnum *f1=v1,*f2=v2; + return *f1<*f2 ? -1 : *f1==*f2 ? 0 : +1; +} + +inline void +maybe_reallocate_page(struct typemanager *ntm,ufixnum count) { + + void **y,**n; + fixnum *pp,*pp1,*ppe,yp; + struct typemanager *tm; + fixnum i,j,e[t_end]; + struct pageinfo *v; + + massert(pp1=pp=alloca(count*sizeof(*pp1))); + ppe=pp1+count; + + for (v=cell_list_head;v && ppnext) { + + if (v->type>=t_end || + (tm=tm_of(v->type))==ntm || +#ifdef SGC + (sgc_enabled && tm->tm_sgc && v->sgc_flags!=SGC_PAGE_FLAG) || +#endif + v->in_use) + continue; + + count--; + *pp++=page(v); + + } + +#define NEXT_LINK(a_) (void *)&((struct freelist *)*(a_))->f_link +#define FREE_PAGE_P(yp_) bsearch(&(yp_),pp1,ppe-pp1,sizeof(*pp1),icomp) + + ppe=pp; + bzero(e,sizeof(e)); + for (pp=pp1;pptype]++; + for (i=0;itm_nfree-=(j=tm->tm_nppage*e[i]); + tm->tm_npage-=e[i]; + set_tm_maxpage(tm,tm->tm_maxpage-e[i]); + set_tm_maxpage(ntm,ntm->tm_maxpage+e[i]); + for (y=(void *)&tm->tm_free;*y!=OBJNULL && j;) { + for (;*y!=OBJNULL && (yp=page(*y)) && !FREE_PAGE_P(yp);y=NEXT_LINK(y)); + if (*y!=OBJNULL) { + for (n=NEXT_LINK(y),j--;*n!=OBJNULL && (yp=page(*n)) && FREE_PAGE_P(yp);n=NEXT_LINK(n),j--); + *y=*n; + } + } + massert(!j); + } + + for (pp=pp1;ppnext; + add_page_to_freelist(pagetochar(*pp),ntm); + pagetoinfo(*pp)->next=pn; + } + +} + + +int reserve_pages_for_signal_handler=30; + +/* If (n >= 0 ) return pointer to n pages starting at heap end, + These must come from the hole, so if that is exhausted you have + to gc and move the hole. + if (n < 0) return pointer to n pages starting at heap end, + but don't worry about the hole. Basically just make sure + the space is available from the Operating system. + If not in_signal_handler then try to keep a minimum of + reserve_pages_for_signal_handler pages on hand in the hole + */ +inline void * +alloc_page(long n) { + + void *e=heap_end; + fixnum d,m; +#ifdef SGC + int in_sgc=sgc_enabled; +#endif + if (n>=0) { + + if (n>(holepage - (in_signal_handler? 0 : + available_pages-n<=reserve_pages_for_signal_handler ? 0 : + reserve_pages_for_signal_handler))) { + + + if (in_signal_handler) { + fprintf(stderr,"Cant do relocatable gc in signal handler. \ +Try to allocate more space to save for allocation during signals: \ +eg to add 20 more do (si::set-hole-size %ld %d)\n...start over ", + new_holepage, 20+ reserve_pages_for_signal_handler); fflush(stderr); exit(1); + } + + + d=available_pages-n; + d*=0.2; + d=d<0.01*real_maxpage ? available_pages-n : d; + d=d<0 ? 0 : d; + d=new_holepagetm_type==t_relocatable,j=tm->tm_maxpage,z=(n-j)*(r ? 2 : 1); + if (z>available_pages) return 0; + if (r && 2*n+page(REAL_RB_START)>real_maxpage) return 0; + available_pages-=z; + tm->tm_adjgbccnt*=((double)j)/n; + tm->tm_maxpage=n; + return n; +} + + +inline void +add_page_to_freelist(char *p, struct typemanager *tm) { + + short t,size; + long i=tm->tm_nppage,fw; + object x,f; + struct pageinfo *pp; + + t=tm->tm_type; + + size=tm->tm_size; + f=tm->tm_free; + pp=pageinfo(p); + bzero(pp,sizeof(*pp)); + pp->type=t; + pp->magic=PAGE_MAGIC; + + if (cell_list_head==NULL) + cell_list_tail=cell_list_head=pp; + else if (pp > cell_list_tail) { + cell_list_tail->next=pp; + cell_list_tail=pp; + } + + x= (object)pagetochar(page(p)); + /* set_type_of(x,t); */ + make_free(x); + +#ifdef SGC + + if (sgc_enabled && tm->tm_sgc) + pp->sgc_flags=SGC_PAGE_FLAG; + if (TYPEWORD_TYPE_P(pp->type)) + x->d.s=(sgc_enabled && tm->tm_sgc) ? SGC_RECENT : SGC_NORMAL; + + /* array headers must be always writable, since a write to the + body does not touch the header. It may be desirable if there + are many arrays in a system to make the headers not writable, + but just SGC_TOUCH the header each time you write to it. this + is what is done with t_structure */ + if (t==(tm_of(t_array)->tm_type)) + pp->sgc_flags|=SGC_PERM_WRITABLE; + +#endif + + fw= *(fixnum *)x; + while (--i >= 0) { + *(fixnum *)x=fw; + SET_LINK(x,f); + f=x; + x= (object) ((char *)x + size); + } + + tm->tm_free=f; + tm->tm_nfree += tm->tm_nppage; + tm->tm_npage++; + +} + +object +type_name(int t) { + return make_simple_string(tm_table[(int)t].tm_name+1); +} + + +static void +call_after_gbc_hook(t) { + if (sSAafter_gbc_hookA && sSAafter_gbc_hookA->s.s_dbind!= Cnil) { + set_up_string_register(tm_table[(int)t].tm_name+1); + ifuncall1(sSAafter_gbc_hookA->s.s_dbind,intern(string_register,system_package)); + } +} + +static fixnum +grow_linear(fixnum old, fixnum fract, fixnum grow_min, fixnum grow_max,fixnum max_delt) { + + fixnum delt; + + delt=(old*(fract ? fract : 50))/100; + + delt= (grow_min && delt < grow_min ? grow_min: + grow_max && delt > grow_max ? grow_max: + delt); + + delt=delt>max_delt ? max_delt : delt; + + return old + delt; + +} + +/* GCL's traditional garbage collecting algorithm placed heavy emphasis + on conserving memory. Maximum page allocations of each object type + were only increased when the objects in use after GBC exceeded a + certain percentage threshold of the current maximum. This allowed + a situation in which a growing heap would experience significant + performance degradation due to GBC runs triggered by types making + only temporary allocations -- the rate of GBC calls would be + constant while the cost for each GBC would grow with the size of + the heap. + + We implement here a strategy designed to approximately optimize the + product of the total GBC call rate times the cost or time taken for + each GBC. The rate is approximated from the actual gbccounts so + far experienced, while the cost is taken to be simply proportional + to the heap size at present. This can be further tuned by taking + into account the number of pointers in each object type in the + future, but at present objects of several different types but + having the same size are grouped together in the type manager + table, so this step becomes more involved. + + After each GBC, we calculate the maximum of the function + (gbc_rate_other_types + gbc_rate_this_type * + current_maxpage/new_maxpage)*(sum_all_maxpages-current_maxpage+new_maxpage). + If the benefit in the product from adopting the new_maxpage is + greater than 5%, we adopt it, and adjust the gbccount for the new + basis. Corrections are put in place for small GBC counts, and the + possibility that GBC calls of only a single type are ever + triggered, in which case the optimum new_maxpage would diverge in + the simple analysis above. + + 20040403 CM */ + +DEFVAR("*OPTIMIZE-MAXIMUM-PAGES*",sSAoptimize_maximum_pagesA,SI,sLnil,""); +#define OPTIMIZE_MAX_PAGES (sSAoptimize_maximum_pagesA ==0 || sSAoptimize_maximum_pagesA->s.s_dbind !=sLnil) +DEFVAR("*NOTIFY-OPTIMIZE-MAXIMUM-PAGES*",sSAnotify_optimize_maximum_pagesA,SI,sLnil,""); +#define MMAX_PG(a_) (a_)->tm_maxpage +inline long +opt_maxpage(struct typemanager *my_tm) { + + double x=0.0,y=0.0,z,r; + long mmax_page; + struct typemanager *tm,*tme; + long mro=0,tro=0; + + if (phys_pages>0 && page(heap_end)-first_data_page+nrbpage>=phys_pages) + return 0; + + if (page(core_end)>0.8*real_maxpage) + return 0; + + for (tm=tm_table,tme=tm+sizeof(tm_table)/sizeof(*tm_table);tmtm_adjgbccnt; + y+=MMAX_PG(tm); + } + mmax_page=MMAX_PG(my_tm); +#if 0 + if (sgc_enabled) { + y-=(tro=sgc_count_read_only_type(-1)); + mmax_page-=(mro=sgc_count_read_only_type(my_tm->tm_type)); + } +#endif + + z=my_tm->tm_adjgbccnt-1; + z/=(1+x-0.9*my_tm->tm_adjgbccnt); + z*=(y-mmax_page)*mmax_page; + z=sqrt(z); + z=z-mmax_page>available_pages ? mmax_page+available_pages : z; + my_tm->tm_opt_maxpage=(long)z>my_tm->tm_opt_maxpage ? (long)z : my_tm->tm_opt_maxpage; + + if (z<=mmax_page) + return 0; + + r=((x-my_tm->tm_adjgbccnt)+ my_tm->tm_adjgbccnt*mmax_page/z)*(y-mmax_page+z); + r/=x*y; + if (sSAnotify_optimize_maximum_pagesA->s.s_dbind!=sLnil) + printf("[type %u max %lu(%lu) opt %lu y %lu(%lu) gbcrat %f sav %f]\n", + my_tm->tm_type,mmax_page,mro,(long)z,(long)y,tro,(my_tm->tm_adjgbccnt-1)/(1+x-0.9*my_tm->tm_adjgbccnt),r); + return r<=0.95 && set_tm_maxpage(my_tm,z+mro) ? 1 : 0; + +} + +static object +exhausted_report(enum type t,struct typemanager *tm) { + + available_pages+=resv_pages; + resv_pages=0; + vs_push(type_name(t)); + vs_push(make_fixnum(tm->tm_npage)); + CEerror("The storage for ~A is exhausted.~%\ +Currently, ~D pages are allocated.~% \ +Use ALLOCATE to expand the space.", + "Continues execution.", + 2, vs_top[-2], vs_top[-1], Cnil, Cnil); + + vs_popp; + vs_popp; + + call_after_gbc_hook(t); + + return alloc_object(t); + +} + +#ifdef SGC +#define TOTAL_THIS_TYPE(tm) (tm->tm_nppage * (sgc_enabled ? sgc_count_type(tm->tm_type) : tm->tm_npage)) +#else +#define TOTAL_THIS_TYPE(tm) (tm->tm_nppage * tm->tm_npage) +#endif +bool prefer_low_mem_contblock=FALSE; + +inline void * +alloc_from_freelist(struct typemanager *tm,fixnum n) { + + void *p,*v,*vp; + struct contblock **cbpp; + fixnum i; + + switch (tm->tm_type) { + + case t_contiguous: + for (cbpp= &cb_pointer,v=(void *)-1,vp=NULL; (*cbpp)!=NULL; cbpp= &(*cbpp)->cb_link) + if ((*cbpp)->cb_size >= n) { + if (!prefer_low_mem_contblock) { + vp=cbpp; + break; + } else if ((void *)(*cbpp)cb_size-n; + *cbpp=(*cbpp)->cb_link; + --ncb; + insert_contblock(p+n,i); + return(p); + } + break; + + case t_relocatable: + if (rb_limit-rb_pointer>=n) + return ((rb_pointer+=n)-n); + break; + + default: + if ((p=tm->tm_free)!=OBJNULL) { + tm->tm_free = OBJ_LINK(p); + tm->tm_nfree--; + return(p); + } + break; + } + + return NULL; + +} + +static inline void +grow_linear1(struct typemanager *tm) { + + fixnum maxgro=resv_pages ? available_pages : 0; + + if (tm->tm_type==t_relocatable) maxgro>>=1; + + set_tm_maxpage(tm,grow_linear(tm->tm_npage,tm->tm_growth_percent,tm->tm_min_grow, tm->tm_max_grow,maxgro)); + +} + +static inline int +too_full_p(struct typemanager *tm) { + + fixnum j,k,pf=tm->tm_percent_free ? tm->tm_percent_free : 30; + struct contblock *cbp; + struct pageinfo *pi; + + switch (tm->tm_type) { + case t_relocatable: + return 100*(rb_limit-rb_pointer)cb_link) k+=cbp->cb_size; + for (pi=contblock_list_head,j=0;pi;pi=pi->next) +#ifdef SGC + if (!sgc_enabled || pi->sgc_flags&SGC_PAGE_FLAG) +#endif + j+=pi->in_use; + return 100*ktm_nfreetm_npage+tpage(tm,n)>=tm->tm_maxpage && GBC_enable) { + + switch (jmp_gmp) { + case 0: /* not in gmp call*/ + GBC(tm->tm_type); + break; + case 1: /* non-in-place gmp call*/ + longjmp(gmp_jmp,tm->tm_type); + break; + case -1: /* in-place gmp call */ + jmp_gmp=-tm->tm_type; + break; + default: + break; + } + + if (IGNORE_MAX_PAGES && too_full_p(tm)) + grow_linear1(tm); + + call_after_gbc_hook(tm->tm_type); + + return alloc_from_freelist(tm,n); + + } else + + return NULL; + +} + +struct pageinfo *contblock_list_head=NULL,*contblock_list_tail=NULL; + +inline void +add_pages(struct typemanager *tm,fixnum m) { + + switch (tm->tm_type) { + case t_contiguous: + + add_page_to_contblock_list(alloc_page(m),m); + + break; + + case t_relocatable: + + nrbpage+=m; + rb_end=heap_end+(holepage+nrbpage)*PAGESIZE; + rb_limit=rb_end-2*RB_GETA; + + alloc_page(-(nrbpage+holepage)); + + break; + + default: + + { + void *p=alloc_page(m),*pe=p+m*PAGESIZE; + for (;ptm_npage+m>tm->tm_maxpage) { + + if (!IGNORE_MAX_PAGES) return NULL; + + grow_linear1(tm); + + if (tm->tm_npage+m>tm->tm_maxpage && !set_tm_maxpage(tm,tm->tm_npage+m)) + return NULL; + + } + + m=tm->tm_maxpage-tm->tm_npage; + add_pages(tm,m); + + return alloc_from_freelist(tm,n); + +} + +inline void * +alloc_after_reclaiming_pages(struct typemanager *tm,fixnum n) { + + fixnum m=tpage(tm,n),reloc_min; + + if (tm->tm_type>=t_end) return NULL; + + reloc_min=npage(rb_pointer-REAL_RB_START); + + if (m<2*(nrbpage-reloc_min)) { + + set_tm_maxpage(tm_table+t_relocatable,reloc_min); + nrbpage=reloc_min; + + GBC(t_relocatable); + tm_table[t_relocatable].tm_adjgbccnt--; + + return alloc_after_adding_pages(tm,n); + + } + + maybe_reallocate_page(tm,tm->tm_percent_free*tm->tm_npage); + + return alloc_from_freelist(tm,n); + +} + +inline void *alloc_mem(struct typemanager *,fixnum); + +#ifdef SGC +inline void * +alloc_after_turning_off_sgc(struct typemanager *tm,fixnum n) { + + if (!sgc_enabled) return NULL; + sgc_quit(); + return alloc_mem(tm,n); + +} +#endif + +inline void * +alloc_mem(struct typemanager *tm,fixnum n) { + + void *p; + + CHECK_INTERRUPT; + + if ((p=alloc_from_freelist(tm,n))) + return p; + if ((p=alloc_after_gc(tm,n))) + return p; + if ((p=alloc_after_adding_pages(tm,n))) + return p; +#ifdef SGC + if ((p=alloc_after_turning_off_sgc(tm,n))) + return p; +#endif + if ((p=alloc_after_reclaiming_pages(tm,n))) + return p; + return exhausted_report(tm->tm_type,tm); +} + +inline object +alloc_object(enum type t) { + + object obj; + struct typemanager *tm=tm_of(t); + + obj=alloc_mem(tm,tm->tm_size); + set_type_of(obj,t); + + pageinfo(obj)->in_use++; + + return(obj); + +} + +inline void * +alloc_contblock(size_t n) { + return alloc_mem(tm_of(t_contiguous),ROUND_UP_PTR_CONT(n)); +} + +inline void * +alloc_relblock(size_t n) { + + return alloc_mem(tm_of(t_relocatable),ROUND_UP_PTR(n)); + +} + +static inline void +load_cons(object p,object a,object d) { +#ifdef WIDE_CONS + set_type_of(p,t_cons); +#endif + p->c.c_cdr=SAFE_CDR(d); + p->c.c_car=a; +} + +inline object +make_cons(object a,object d) { + + static struct typemanager *tm=tm_table+t_cons;/*FIXME*/ + object obj=alloc_mem(tm,tm->tm_size); + + load_cons(obj,a,d); + + pageinfo(obj)->in_use++; + + return(obj); + +} + + + +inline object on_stack_cons(object x, object y) { + object p = (object) alloca_val; + load_cons(p,x,y); + return p; +} + + +DEFUNM_NEW("ALLOCATED",object,fSallocated,SI,1,1,NONE,OO,OO,OO,OO,(object typ),"") +{ struct typemanager *tm=(&tm_table[t_from_type(typ)]); + tm = & tm_table[tm->tm_type]; + if (tm->tm_type == t_relocatable) + { tm->tm_npage = (rb_end-rb_start)/PAGESIZE; + tm->tm_nfree = rb_end -rb_pointer; + } + else if (tm->tm_type == t_contiguous) + { int cbfree =0; + struct contblock **cbpp; + for(cbpp= &cb_pointer; (*cbpp)!=NULL; cbpp= &(*cbpp)->cb_link) + cbfree += (*cbpp)->cb_size ; + tm->tm_nfree = cbfree; + } + + RETURN(6,object,make_fixnum(tm->tm_nfree), + (RV(make_fixnum(tm->tm_npage)), + RV(make_fixnum(tm->tm_maxpage)), + RV(make_fixnum(tm->tm_nppage)), + RV(make_fixnum(tm->tm_gbccount)), + RV(make_fixnum(tm->tm_npage*tm->tm_nppage-tm->tm_nfree)) + )); +} + +/* DEFUN_NEW("RESET-NUMBER-USED",object,fSreset_number_used,SI,0,1,NONE,OO,OO,OO,OO,(object typ),"") */ +/* {int i; */ +/* if (VFUN_NARGS == 1) */ +/* { tm_table[t_from_type(typ)].tm_nused = 0;} */ +/* else */ +/* for (i=0; i <= t_relocatable ; i++) */ +/* { tm_table[i].tm_nused = 0;} */ +/* RETURN1(sLnil); */ +/* } */ + +#define IN_CONTBLOCK_P(p,pi) ((void *)p>=(void *)pi && (void *)p<(void *)pi+pi->in_use*PAGESIZE) + +/* SGC cont pages: explicit free calls can come at any time, and we + must make sure to add the newly deallocated block to the right + list. CM 20030827*/ +#ifdef SGC +void +insert_maybe_sgc_contblock(char *p,int s) { + + struct contblock *tmp_cb_pointer; + struct pageinfo *pi; + + for (pi=contblock_list_head;pi && !IN_CONTBLOCK_P(p,pi);pi=pi->next); + massert(pi); + + if (sgc_enabled && ! (pi->sgc_flags&SGC_PAGE_FLAG)) { + tmp_cb_pointer=cb_pointer; + cb_pointer=old_cb_pointer; + sgc_enabled=0; + insert_contblock(p,s); + sgc_enabled=1; + old_cb_pointer=cb_pointer; + cb_pointer=tmp_cb_pointer; + } else + insert_contblock(p,s); + +} +#endif + +#ifdef SGC_CONT_DEBUG +extern void overlap_check(struct contblock *,struct contblock *); +#endif + +DEFUN_NEW("PRINT-FREE-CONTBLOCK-LIST",object,fSprint_free_contblock_list,SI,0,0,NONE,OO,OO,OO,OO,(void),"") { + + struct contblock *cbp,*cbp1; + + for (cbp=cb_pointer;cbp;cbp=cbp->cb_link) { + printf("%p %d\n",cbp,cbp->cb_size); + for (cbp1=cbp;cbp1;cbp1=cbp1->cb_link) + if ((void *)cbp+cbp->cb_size==(void *)cbp1 || + (void *)cbp1+cbp1->cb_size==(void *)cbp) + printf(" adjacent to %p %d\n",cbp1,cbp1->cb_size); + } + + return Cnil; + +} + +void +insert_contblock(char *p, int s) { + + struct contblock **cbpp, *cbp; + + /* SGC cont pages: This used to return when scb_size = ROUND_UP_PTR_CONT(s); + + for (cbpp=&cb_pointer;*cbpp;) { + if ((void *)(*cbpp)+(*cbpp)->cb_size==(void *)cbp) { + /* printf("Merge contblock %p %d %p %d\n",cbp,cbp->cb_size,*cbpp,(*cbpp)->cb_size); */ + /* fflush(stdout); */ + (*cbpp)->cb_size+=cbp->cb_size; + cbp=*cbpp; + *cbpp=(*cbpp)->cb_link; + } else if ((void *)(*cbpp)==(void *)cbp+cbp->cb_size) { + /* printf("Merge contblock %p %d %p %d\n",cbp,cbp->cb_size,*cbpp,(*cbpp)->cb_size); */ + /* fflush(stdout); */ + cbp->cb_size+=(*cbpp)->cb_size; + *cbpp=(*cbpp)->cb_link; + } else + cbpp=&(*cbpp)->cb_link; + } + s=cbp->cb_size; + + for (cbpp = &cb_pointer; *cbpp; cbpp = &((*cbpp)->cb_link)) + if ((*cbpp)->cb_size >= s) { +#ifdef SGC_CONT_DEBUG + if (*cbpp==cbp) { + fprintf(stderr,"Trying to install a circle at %p\n",cbp); + exit(1); + } + if (sgc_enabled) + overlap_check(old_cb_pointer,cb_pointer); +#endif + cbp->cb_link = *cbpp; + *cbpp = cbp; +#ifdef SGC_CONT_DEBUG + if (sgc_enabled) + overlap_check(old_cb_pointer,cb_pointer); +#endif + return; + } + cbp->cb_link = NULL; + *cbpp = cbp; +#ifdef SGC_CONT_DEBUG + if (sgc_enabled) + overlap_check(old_cb_pointer,cb_pointer); +#endif + +} + +/* Add a tm_distinct field to prevent page type sharing if desired. + Not used now, as its never desirable from an efficiency point of + view, and as the only known place one must separate is cons and + fixnum, which are of different sizes unless PTR_ALIGN is set too + high (e.g. 16 on a 32bit machine). See the ordering of init_tm + calls for these types below -- reversing would wind up merging the + types with the current algorithm. CM 20030827 */ + +static void +init_tm(enum type t, char *name, int elsize, int nelts, int sgc,int distinct) { + + int i, j; + int maxpage; + /* round up to next number of pages */ + maxpage = (((nelts * elsize) + PAGESIZE -1)/PAGESIZE); + tm_table[(int)t].tm_name = name; + j=-1; + if (!distinct) + for (i = 0; i < t_end; i++) + if (tm_table[i].tm_size != 0 && + tm_table[i].tm_size >= elsize && + !tm_table[i].tm_distinct && + (j < 0 || tm_table[j].tm_size > tm_table[i].tm_size)) + j = i; + if (j >= 0) { + tm_table[(int)t].tm_type = (enum type)j; + set_tm_maxpage(tm_table+j,tm_table[j].tm_maxpage+maxpage); +#ifdef SGC + tm_table[j].tm_sgc += sgc; +#endif + return; + } + tm_table[(int)t].tm_type = t; + tm_table[(int)t].tm_size = elsize ? ROUND_UP_PTR(elsize) : 1; + tm_table[(int)t].tm_nppage = (PAGESIZE-sizeof(struct pageinfo))/tm_table[(int)t].tm_size; + tm_table[(int)t].tm_free = OBJNULL; + tm_table[(int)t].tm_nfree = 0; + /* tm_table[(int)t].tm_nused = 0; */ + /*tm_table[(int)t].tm_npage = 0; */ /* dont zero nrbpage.. */ + set_tm_maxpage(tm_table+t,maxpage); + tm_table[(int)t].tm_gbccount = 0; + tm_table[(int)t].tm_adjgbccnt = 0; + tm_table[(int)t].tm_opt_maxpage = 0; + tm_table[(int)t].tm_distinct=distinct; + +#ifdef SGC + tm_table[(int)t].tm_sgc = sgc; + tm_table[(int)t].tm_sgc_max = 3000; + tm_table[(int)t].tm_sgc_minfree = (0.4 * tm_table[(int)t].tm_nppage); +#endif + +} + +/* FIXME this is a work-around for the special MacOSX memory + initialization sequence, which sets heap_end, traditionally + initialized in gcl_init_alloc. Mac and windows have non-std + sbrk-emulating memory subsystems, and their internals need to be + homogenized and integrated into the traditional unix sequence for + simplicity. set_maxpage is overloaded, and the positioning of its + call is too fragile. 20050115 CM*/ +static int gcl_alloc_initialized; + + +#ifdef GCL_GPROF +static unsigned long textstart,textend,textpage; +static void init_textpage() { + + extern void *GCL_GPROF_START; + unsigned long s=(unsigned long)GCL_GPROF_START; + + textstart=(unsigned long)&GCL_GPROF_START; + textend=(unsigned long)&etext; + if (stextend || s>textstart)) + textstart=s; + + textpage=2*(textend-textstart)/PAGESIZE; + +} +#endif + +object malloc_list=Cnil; + +#include + +void +gcl_init_alloc(void *cs_start) { + + fixnum cssize=(1L<<23); + + prelink_init(); + +#ifdef RECREATE_HEAP + if (!raw_image) RECREATE_HEAP; +#endif + +#if defined(DARWIN) + init_darwin_zone_compat (); +#endif + +#ifdef GCL_GPROF + init_textpage(); +#endif + +#if defined(BSD) && defined(RLIMIT_STACK) + { + struct rlimit rl; + + /* Maybe the soft limit for data segment size is lower than the + * hard limit. In that case, we want as much as possible. + */ + massert(!getrlimit(RLIMIT_DATA, &rl)); + if (rl.rlim_cur != RLIM_INFINITY && (rl.rlim_max == RLIM_INFINITY || rl.rlim_max > rl.rlim_cur)) { + rl.rlim_cur = rl.rlim_max; + massert(!setrlimit(RLIMIT_DATA, &rl)); + } + + massert(!getrlimit(RLIMIT_STACK, &rl)); + if (rl.rlim_cur!=RLIM_INFINITY && (rl.rlim_max == RLIM_INFINITY || rl.rlim_max > rl.rlim_cur)) { + rl.rlim_cur = rl.rlim_max == RLIM_INFINITY ? rl.rlim_max : rl.rlim_max/64; + massert(!setrlimit(RLIMIT_STACK,&rl)); + } + cssize = rl.rlim_cur/sizeof(*cs_org) - sizeof(*cs_org)*CSGETA; + + } +#endif + + cs_org = cs_base = cs_start; + cs_limit = cs_org + CSTACK_DIRECTION*cssize; + +#ifdef __ia64__ + { + extern void * __libc_ia64_register_backing_store_base; + cs_org2=cs_base2=__libc_ia64_register_backing_store_base; + } +#endif + +#ifdef HAVE_SIGALTSTACK + { + /* make sure the stack is 8 byte aligned */ + static double estack_buf[32*SIGSTKSZ]; + static stack_t estack; + + estack.ss_sp = estack_buf; + estack.ss_flags = 0; + estack.ss_size = sizeof(estack_buf); + massert(sigaltstack(&estack, 0)>=0); + } +#endif + + install_segmentation_catcher(); + +#ifdef HAVE_MPROTECT + if (data_start) + massert(!gcl_mprotect(data_start,(void *)core_end-data_start,PROT_READ|PROT_WRITE|PROT_EXEC)); +#endif + +#ifdef SGC + + massert(getpagesize()<=PAGESIZE); + memprotect_test_reset(); + if (sgc_enabled) + if (memory_protect(1)) + sgc_quit(); + +#endif + + update_real_maxpage(); + + if (gcl_alloc_initialized) return; + +#ifdef INIT_ALLOC + INIT_ALLOC; +#endif + + data_start=heap_end; + first_data_page=page(data_start); + + holepage=new_holepage; + +#ifdef GCL_GPROF + if (holepageust.ust_self) ? sLt : sLnil)); +} + +/* static void */ +/* cant_get_a_type(void) { */ +/* FEerror("Can't get a type.", 0); */ +/* } */ + +static int +t_from_type(object type) { + + int i; + check_type_or_symbol_string(&type); + for (i= t_start ; i < t_other ; i++) + {struct typemanager *tm = &tm_table[i]; + if(tm->tm_name && + 0==strncmp((tm->tm_name)+1,type->st.st_self,type->st.st_fillp) + ) + return i;} + FEerror("Unrecognized type",0); + return i; + +} +/* When sgc is enabled the TYPE should have at least MIN pages of sgc type, + and at most MAX of them. Each page should be FREE_PERCENT free + when the sgc is turned on. FREE_PERCENT is an integer between 0 and 100. + */ + +DEFUN_NEW("ALLOCATE-SGC",object,fSallocate_sgc,SI + ,4,4,NONE,OO,II,II,OO,(object type,fixnum min,fixnum max,fixnum free_percent),"") { + + int t=t_from_type(type); + struct typemanager *tm; + object res,x,x1,x2; + tm=tm_of(t); + x=make_fixnum(tm->tm_sgc); + x1=make_fixnum(tm->tm_sgc_max); + x2=make_fixnum((100*tm->tm_sgc_minfree)/tm->tm_nppage); + res= list(3,x,x1,x2); + + if(min<0 || max< min || free_percent < 0 || free_percent > 100) + goto END; + tm->tm_sgc_max=max; + tm->tm_sgc=min; + tm->tm_sgc_minfree= (tm->tm_nppage *free_percent) /100; + END: + RETURN1(res); + +} + +/* Growth of TYPE will be by at least MIN pages and at most MAX pages. + It will try to grow PERCENT of the current pages. + */ +DEFUN_NEW("ALLOCATE-GROWTH",object,fSallocate_growth,SI,5,5,NONE,OO,II,II,OO, + (object type,fixnum min,fixnum max,fixnum percent,fixnum percent_free),"") +{int t=t_from_type(type); + struct typemanager *tm=tm_of(t); + object res,x,x1,x2,x3; + x=make_fixnum(tm->tm_min_grow); + x1=make_fixnum(tm->tm_max_grow); + x2=make_fixnum(tm->tm_growth_percent); + x3=make_fixnum(tm->tm_percent_free); + res= list(4,x,x1,x2,x3); + + if(min<0 || max< min || min > 3000 || percent < 0 || percent > 500 + || percent_free <0 || percent_free > 100 + ) + goto END; + tm->tm_max_grow=max; + tm->tm_min_grow=min; + tm->tm_growth_percent=percent; + tm->tm_percent_free=percent_free; + END: + RETURN1(res); +} + + + +DEFUN_NEW("ALLOCATE-CONTIGUOUS-PAGES",object,fSallocate_contiguous_pages,SI,1,2,NONE,OO,OO,OO,OO,(object onpages,...),"") { + + int nargs=VFUN_NARGS; + object really_do; + va_list ap; + fixnum npages=fixint(onpages); + + really_do=Cnil; + if (nargs>=2) { + va_start(ap,onpages); + really_do=va_arg(ap,object); + va_end(ap); + } + + CHECK_ARG_RANGE(1,2); + if (npages < 0) + FEerror("Allocate requires positive argument.", 0); + if (ncbpage > npages) + npages=ncbpage; + if (!set_tm_maxpage(tm_table+t_contiguous,npages)) + FEerror("Can't allocate ~D pages for contiguous blocks.", 1, make_fixnum(npages)); + if (really_do == Cnil) + RETURN1(Ct); + add_pages(tm_of(t_contiguous),npages - ncbpage); + + RETURN1(make_fixnum(npages)); + +} + + +DEFUN_NEW("ALLOCATED-CONTIGUOUS-PAGES",object,fSallocated_contiguous_pages,SI + ,0,0,NONE,OO,OO,OO,OO,(void),"") +{ + /* 0 args */ + RETURN1((make_fixnum(ncbpage))); +} + +DEFUN_NEW("MAXIMUM-CONTIGUOUS-PAGES",object,fSmaximum_contiguous_pages,SI,0,0,NONE,OO,OO,OO,OO,(void),"") { + /* 0 args */ + RETURN1((make_fixnum(maxcbpage))); +} + + +DEFUN_NEW("ALLOCATE-RELOCATABLE-PAGES",object,fSallocate_relocatable_pages,SI,1,2,NONE,OO,OO,OO,OO,(object onpages,...),"") { + + int nargs=VFUN_NARGS; + object really_do; + va_list ap; + fixnum npages=fixint(onpages); + + really_do=Cnil; + if (nargs>=2) { + va_start(ap,onpages); + really_do=va_arg(ap,object); + va_end(ap); + } + + CHECK_ARG_RANGE(1,2); + if (npages <= 0) + FEerror("Requires positive arg",0); + if (npages=3) { + va_start(ap,onpages); + really_do=va_arg(ap,object); + va_end(ap); + } + + CHECK_ARG_RANGE(2,3); + t= t_from_type(type); + if (t == t_contiguous) + RETURN1(FUNCALL(2,FFN(fSallocate_contiguous_pages)(make_fixnum(npages),really_do))); + else if (t==t_relocatable) + RETURN1(FUNCALL(2,FFN(fSallocate_relocatable_pages)(make_fixnum(npages),really_do))); + + + if (npages <= 0) + FEerror("Allocate takes positive argument.", 1,make_fixnum(npages)); + tm = tm_of(t); + if (tm->tm_npage > npages) {npages=tm->tm_npage;} + if (!set_tm_maxpage(tm,npages)) + FEerror("Can't allocate ~D pages for ~A.", 2, make_fixnum(npages), (make_simple_string(tm->tm_name+1))); + if (really_do == Cnil) + RETURN1(Ct); + add_pages(tm,npages - tm->tm_npage); + RETURN1(make_fixnum(npages)); + +} + +DEFUN_NEW("ALLOCATED-RELOCATABLE-PAGES",object,fSallocated_relocatable_pages,SI,0,0,NONE,OO,OO,OO,OO,(void),"") { + /* 0 args */ + RETURN1(make_fixnum(nrbpage)); +} + +DEFUN_NEW("GET-HOLE-SIZE",object,fSget_hole_size,SI,0,0,NONE,OO,OO,OO,OO,(void),"") { + /* 0 args */ + RETURN1((make_fixnum(new_holepage))); +} + + +#ifdef GCL_GPROF + +static unsigned long start,end,gprof_on; +static void *initial_monstartup_pointer; + +void +gprof_cleanup(void) { + + extern void _mcleanup(void); + + if (initial_monstartup_pointer) { + _mcleanup(); + gprof_on=0; + } + + if (gprof_on) { + + char b[PATH_MAX],b1[PATH_MAX]; + + if (!getcwd(b,sizeof(b))) + FEerror("Cannot get working directory", 0); + if (chdir(P_tmpdir)) + FEerror("Cannot change directory to tmpdir", 0); + _mcleanup(); + if (snprintf(b1,sizeof(b1),"gmon.out.%u",getpid())<=0) + FEerror("Cannot write temporary gmon filename", 0); + if (rename("gmon.out",b1)) + FEerror("Cannot rename gmon.out",0); + if (chdir(b)) + FEerror("Cannot restore working directory", 0); + gprof_on=0; + + } + +} + +static inline int +my_monstartup(unsigned long start,unsigned long end) { + + extern void monstartup(unsigned long,unsigned long); + + monstartup(start,end); + + return 0; + +} + +DEFUN_NEW("GPROF-START",object,fSgprof_start,SI,0,0,NONE,OO,OO,OO,OO,(void),"") { + + extern void *GCL_GPROF_START; + static int n; + + if (!gprof_on) { + start=start ? start : textstart; + end=end ? end : textend; + writable_malloc_wrap(my_monstartup,int,start,end); + gprof_on=1; + if (!n && atexit(gprof_cleanup)) { + FEerror("Cannot setup gprof_cleanup on exit", 0); + n=1; + } + } + + return Cnil; + +} + +DEFUN_NEW("GPROF-SET",object,fSgprof_set,SI + ,2,2,NONE,OI,IO,OO,OO,(fixnum dstart,fixnum dend),"") +{ + + start=dstart; + end=dend; + + return Cnil; + +} + +DEFUN_NEW("GPROF-QUIT",object,fSgprof_quit,SI + ,0,0,NONE,OO,OO,OO,OO,(void),"") +{ + extern void _mcleanup(void); + char b[PATH_MAX],b1[PATH_MAX]; + FILE *pp; + unsigned n; + + if (!gprof_on) + return Cnil; + + if (!getcwd(b,sizeof(b))) + FEerror("Cannot get working directory", 0); + if (chdir(P_tmpdir)) + FEerror("Cannot change directory to tmpdir", 0); + _mcleanup(); + if (snprintf(b1,sizeof(b1),"gprof %s",kcl_self)<=0) + FEerror("Cannot write gprof command line", 0); + if (!(pp=popen(b1,"r"))) + FEerror("Cannot open gprof pipe", 0); + while ((n=fread(b1,1,sizeof(b1),pp))) + if (!fwrite(b1,1,n,stdout)) + FEerror("Cannot write gprof output",0); + if (pclose(pp)<0) + FEerror("Cannot close gprof pipe", 0); + if (chdir(b)) + FEerror("Cannot restore working directory", 0); + gprof_on=0; + + return Cnil; + +} + +#endif + +DEFUN_NEW("SET-STARTING-HOLE-DIVISOR",object,fSset_starting_hole_divisor,SI,1,1,NONE,II,OO,OO,OO,(fixnum div),"") { + if (div>0 && div <100) + starting_hole_div=div; + return (object)starting_hole_div; +} + +DEFUN_NEW("SET-STARTING-RELBLOCK-HEAP-MULTIPLE",object,fSset_starting_relb_heap_multiple,SI,1,1,NONE,II,OO,OO,OO,(fixnum mult),"") { + if (mult>=0) + starting_relb_heap_mult=mult; + return (object)starting_relb_heap_mult; +} + +DEFUNM_NEW("SET-HOLE-SIZE",object,fSset_hole_size,SI,1,2,NONE,OO,OO,OO,OO,(object onpages,...),"") { + + printf("This function is obsolete -- use SET-STARTING-HOLE-DIVISOR instead\n"); + + RETURN2(make_fixnum(new_holepage),make_fixnum(reserve_pages_for_signal_handler)); + +} + + +void +gcl_init_alloc_function(void) { + + enter_mark_origin(&malloc_list); + +} + + +#ifndef DONT_NEED_MALLOC + +/* + UNIX malloc simulator. + + Used by + getwd, popen, etc. +*/ + + + +/* If this is defined, substitute the fast gnu malloc for the slower + version below. If you have many calls to malloc this is worth + your while. I have only tested it slightly under 4.3Bsd. There + the difference in a test run with 120K mallocs and frees, + was 29 seconds to 1.9 seconds */ + +#ifdef GNU_MALLOC +#include "malloc.c" +#else + +/* a very young malloc may use this simple baby malloc, for the init + code before we even get to main.c. If this is not defined, then + malloc will try to run the init code which will work on many machines + but some such as WindowsNT under cygwin need this. + + */ +#ifdef BABY_MALLOC_SIZE + +/* by giving an initialization, make it not be in bss, since + bss may not get loaded until main is reached. We may + not even know our own name at this stage. */ +static char baby_malloc_data[BABY_MALLOC_SIZE]={1,0}; +static char *last_baby= baby_malloc_data; + +static char *baby_malloc(n) + int n; +{ + char *res= last_baby; + int m; + n = ROUND_UP_PTR(n); + m = n+ sizeof(int); + if ((res +m-baby_malloc_data) > sizeof(baby_malloc_data)) + { + printf("failed in baby malloc"); + exit(1); + } + last_baby += m; + *((int *)res)=n; + return res+sizeof(int); +} +#endif + +/* #ifdef HAVE_LIBBFD */ + +/* int in_bfd_init=0; */ + +/* configure size, static init ? */ +/* static char bfd_buf[32768]; */ +/* static char *bfd_buf_p=bfd_buf; */ + +/* static void * */ +/* bfd_malloc(int n) { */ + +/* char *c; */ + +/* c=bfd_buf_p; */ +/* n+=7; */ +/* n>>=3; */ +/* n<<=3; */ +/* if (c+n>bfd_buf+sizeof(bfd_buf)) { */ +/* fprintf(stderr,"Not enough space in bfd_buf %d %d\n",n,sizeof(bfd_buf)-(bfd_buf_p-bfd_buf)); */ +/* exit(1); */ +/* } */ +/* bfd_buf_p+=n; */ +/* return (void *)c; */ + +/* } */ +/* #endif */ + +bool writable_malloc=0; + +void * +malloc(size_t size) { + + static bool in_malloc; + + if (in_malloc) + return NULL; + in_malloc=1; + + if (!gcl_alloc_initialized) + gcl_init_alloc(&size); + + CHECK_INTERRUPT; + + malloc_list = make_cons(alloc_simple_string(size), malloc_list); + malloc_list->c.c_car->st.st_self = alloc_contblock(size); + malloc_list->c.c_car->st.st_adjustable=writable_malloc; + + /* FIXME: this is just to handle clean freeing of the + monstartup memory allocated automatically on raw image + startup. In saved images, monstartup memory is only + allocated with gprof-start. 20040804 CM*/ +#ifdef GCL_GPROF + if (raw_image && size>(textend-textstart) && !initial_monstartup_pointer) { + massert(!atexit(gprof_cleanup)); + initial_monstartup_pointer=malloc_list->c.c_car->st.st_self; + } +#endif + + in_malloc=0; + return(malloc_list->c.c_car->st.st_self); + +} + + +void +free(void *ptr) { + + object *p,pp; + + if (ptr == 0) + return; + + for (p = &malloc_list,pp=*p; pp && !endp(pp); p = &((pp)->c.c_cdr),pp=pp->c.c_cdr) + if ((pp)->c.c_car->st.st_self == ptr) { + /* SGC contblock pages: Its possible this is on an old page CM 20030827 */ +#ifdef SGC + insert_maybe_sgc_contblock((pp)->c.c_car->st.st_self,(pp)->c.c_car->st.st_dim); +#else + insert_contblock((pp)->c.c_car->st.st_self,(pp)->c.c_car->st.st_dim); +#endif + (pp)->c.c_car->st.st_self = NULL; + *p = pp->c.c_cdr; +#ifdef GCL_GPROF + if (initial_monstartup_pointer==ptr) { + initial_monstartup_pointer=NULL; + if (core_end-heap_end>=sizeof(ptr)) + *(void **)heap_end=ptr; + } +#endif + return; + } +#ifdef NOFREE_ERR + return; +#else + if (core_end-heap_end= (void*)baby_malloc_data && ptr - (void*)baby_malloc_data size) + return ptr; + else + { char *new= malloc(size); + bcopy(ptr,new,dim); + return new; + } + + } +#endif /* BABY_MALLOC_SIZE */ + + + if(ptr == NULL) return malloc(size); + for (x = malloc_list; !endp(x); x = x->c.c_cdr) + if (x->c.c_car->st.st_self == ptr) { + x = x->c.c_car; + if (x->st.st_dim >= size) { + x->st.st_fillp = size; + return(ptr); + } else { + j = x->st.st_dim; + x->st.st_self = alloc_contblock(size); + x->st.st_fillp = x->st.st_dim = size; + for (i = 0; i < size; i++) + x->st.st_self[i] = ((char *)ptr)[i]; +/* SGC contblock pages: Its possible this is on an old page CM 20030827 */ +#ifdef SGC + insert_maybe_sgc_contblock(ptr, j); +#else + insert_contblock(ptr, j); +#endif + return(x->st.st_self); + } + } + FEerror("realloc(3) error.", 0); + + return NULL; + +} + +#endif /* gnumalloc */ + + +void * +calloc(size_t nelem, size_t elsize) +{ + char *ptr; + long i; + + ptr = malloc(i = nelem*elsize); + while (--i >= 0) + ptr[i] = 0; + return(ptr); +} + + +void +cfree(void *ptr) { + free(ptr); +} + +#endif + + +#ifndef GNUMALLOC +#ifdef WANT_VALLOC +static void * +memalign(size_t align,size_t size) { + object x = alloc_simple_string(size); + x->st.st_self = ALLOC_ALIGNED(alloc_contblock,size,align); + malloc_list = make_cons(x, malloc_list); + return x->st.st_self; +} +void * +valloc(size_t size) +{ return memalign(getpagesize(),size);} +#endif + +#endif diff --git a/o/array.c b/o/array.c new file mode 100755 index 0000000..70362a1 --- /dev/null +++ b/o/array.c @@ -0,0 +1,1520 @@ +/* + Copyright (C) 1994 W. Schelter + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#include +#include +#include "include.h" + +static void +displace(object, object, int); + +static enum aelttype +Iarray_element_type(object); + + +/* #define ARRAY_DIMENSION_LIMIT MOST_POSITIVE_FIXNUM */ + +DEFCONST("ARRAY-RANK-LIMIT", sLarray_rank_limit, LISP, + make_fixnum(ARRAY_RANK_LIMIT),""); + +DEFCONST("ARRAY-DIMENSION-LIMIT", sLarray_dimension_limit, + LISP, make_fixnum(MOST_POSITIVE_FIX),""); +DEFCONST("ARRAY-TOTAL-SIZE-LIMIT", sLarray_total_size_limit, + LISP, make_fixnum(MOST_POSITIVE_FIX),""); + +DEF_ORDINARY("BIT",sLbit,LISP,""); + +/* number of bits in unit of storage of x->bv.bv_self[0] */ + +#define BV_BITS 8 + +#define BITREF(x,i) \ + ((((1 << (BV_BITS -1)) >> (i % BV_BITS)) & (x->bv.bv_self[i/BV_BITS])) \ + ? 1 : 0) + +#define SET_BITREF(x,i) \ + (x->bv.bv_self[i/BV_BITS]) |= ((1 << (BV_BITS -1)) >> (i % BV_BITS)) +#define CLEAR_BITREF(x,i) \ + (x->bv.bv_self[i/BV_BITS]) &= ~(((1 << (BV_BITS -1)) >> (i % BV_BITS))) + +extern short aet_sizes[]; + +#define ARRAY_BODY_PTR(ar,n) \ + (void *)(ar->ust.ust_self + aet_sizes[Iarray_element_type(ar)]*n) + +#define N_FIXNUM_ARGS 6 + +DEFUNO_NEW("AREF", object, fLaref, LISP, 1, ARRAY_RANK_LIMIT, + NONE, OO, OO, OO, OO,void,Laref,(object x,object oi, ...),"") +{ int n = VFUN_NARGS; + int i1; + fixnum i=n>1 ? fix(oi) : 0; + va_list ap; + if (type_of(x) == t_array) + {int m ; + unsigned int k; + int rank = n - 1; + if (x->a.a_rank != rank) + FEerror(" ~a has wrong rank",1,x); + if (rank == 1) return fLrow_major_aref(x,i); + if (rank == 0) return fLrow_major_aref(x,0); + va_start(ap,oi); + m = 0; + k = i; + /* index into 1 dimensional array */ + i1 = 0; + rank-- ; + while(1) + { + if ( k >= x->a.a_dims[m]) + FEerror("Index ~a to array is too large",1,make_fixnum (m)); + i1 += k; + m ++; + if (m <= rank) + { i1 = i1 * x->a.a_dims[m]; + if (m < N_FIXNUM_ARGS) + { k = fixint(va_arg(ap,object));} + else {object x = va_arg(ap,object); + check_type(x,t_fixnum); + k = Mfix(x);} + + } + else break;} + va_end(ap); + return fLrow_major_aref(x,i1); + } + if (n > 2) + { FEerror("Too many args (~a) to aref",1,make_fixnum(n));} + return fLrow_major_aref(x,i); + +} + +static void +fScheck_bounds_bounds(object x, int i) +{ + switch (type_of(x)) { + case t_array: + case t_vector: + case t_bitvector: + case t_string: + if ((unsigned int) i >= x->a.a_dim) + FEerror("Array index ~a out of bounds for ~a", 2, make_fixnum(i),x); + default: + FEerror("not an array",0); + } +} + +DEFUNO_NEW("SVREF", object, fLsvref, LISP, 2, 2, + ONE_VAL, OO, IO, OO,OO,void,Lsvref,(object x,ufixnum i), + "For array X and index I it returns (aref x i) ") +{ + if (type_of(x)==t_vector + && (enum aelttype)x->v.v_elttype == aet_object + && x->v.v_dim > i) + RETURN1(x->v.v_self[i]); + if (x->v.v_dim > i) illegal_index(x,make_fixnum(i)); + FEerror("Bad simple vector ~a",1,x); + return(Cnil); +} + +DEFUN_NEW("ROW-MAJOR-AREF", object, fLrow_major_aref, LISP, 2, 2, + NONE, OO, IO, OO,OO,(object x,fixnum i), + "For array X and index I it returns (aref x i) as if x were \ +1 dimensional, even though its rank may be bigger than 1") +{ + switch (type_of(x)) { + case t_array: + case t_vector: + case t_bitvector: + if (x->v.v_dim <= (unsigned int)i) + /* i = */fScheck_bounds_bounds(x, i); + switch (x->v.v_elttype) { + case aet_object: + return x->v.v_self[i]; + case aet_ch: + return code_char(x->st.st_self[i]); + case aet_bit: + i += BV_OFFSET(x); + return make_fixnum(BITREF(x, i)); + case aet_fix: + return make_fixnum(x->fixa.fixa_self[i]); + case aet_sf: + return make_shortfloat(x->sfa.sfa_self[i]); + case aet_lf: + return make_longfloat(x->lfa.lfa_self[i]); + case aet_char: + return small_fixnum(x->st.st_self[i]); + case aet_uchar: + return small_fixnum(x->ust.ust_self[i]); + case aet_short: + return make_fixnum(SHORT_GCL(x, i)); + case aet_ushort: + return make_fixnum(USHORT_GCL(x, i)); + + default: + FEerror("unknown array type",0); + } + case t_string: + if (x->v.v_dim <= i) + /* i = */fScheck_bounds_bounds(x, i); + return code_char(x->st.st_self[i]); + default: + FEerror("not an array",0); + return(Cnil); + } +} +#ifdef STATIC_FUNCTION_POINTERS +object +fLrow_major_aref(object x,fixnum i) { + return FFN(fLrow_major_aref)(x,i); +} +#endif + +object +aset1(object x,fixnum i,object val) { + return fSaset1(x,i,val); +} + +DEFUN_NEW("ASET1", object, fSaset1, SI, 3, 3, NONE, OO, IO, OO,OO,(object x, fixnum i,object val),"") +{ + switch (type_of(x)) { + case t_array: + case t_vector: + case t_bitvector: + if (x->v.v_dim <= i) + /* i = */fScheck_bounds_bounds(x, i); + switch (x->v.v_elttype) { + case aet_object: + x->v.v_self[i] = val; + break; + case aet_ch: + ASSURE_TYPE(val,t_character); + x->st.st_self[i] = char_code(val); + break; + case aet_bit: + i += BV_OFFSET(x); + AGAIN_BIT: + ASSURE_TYPE(val,t_fixnum); + {int v = Mfix(val); + if (v == 0) CLEAR_BITREF(x,i); + else if (v == 1) SET_BITREF(x,i); + else {val= fSincorrect_type(val,sLbit); + goto AGAIN_BIT;} + break;} + case aet_fix: + ASSURE_TYPE(val,t_fixnum); + (x->fixa.fixa_self[i]) = Mfix(val); + break; + case aet_sf: + ASSURE_TYPE(val,t_shortfloat); + (x->sfa.sfa_self[i]) = Msf(val); + break; + case aet_lf: + ASSURE_TYPE(val,t_longfloat); + (x->lfa.lfa_self[i]) = Mlf(val); + break; + case aet_char: + ASSURE_TYPE(val,t_fixnum); + x->st.st_self[i] = Mfix(val); + break; + case aet_uchar: + ASSURE_TYPE(val,t_fixnum); + (x->ust.ust_self[i])= Mfix(val); + break; + case aet_short: + ASSURE_TYPE(val,t_fixnum); + SHORT_GCL(x, i) = Mfix(val); + break; + case aet_ushort: + ASSURE_TYPE(val,t_fixnum); + USHORT_GCL(x, i) = Mfix(val); + break; + default: + FEerror("unknown array type",0); + } + break; + case t_string: + if (x->v.v_dim <= i) + /* i = */fScheck_bounds_bounds(x, i); + ASSURE_TYPE(val,t_character); + x->st.st_self[i] = char_code(val); + break; + default: + FEerror("not an array",0); + } + return val; +} +#ifdef STATIC_FUNCTION_POINTERS +object +fSaset1(object x, fixnum i,object val) { + return FFN(fSaset1)(x,i,val); +} +#endif + +DEFUNO_NEW("ASET", object, fSaset, SI, 1, ARG_LIMIT, NONE, OO, + OO, OO, OO,void,siLaset,(object x,object ii,object y, ...),"") +{ int i,i1; + int n = VFUN_NARGS; + va_list ap; + if (type_of(x) == t_array) + {int m ; + unsigned int k; + int rank = n - 2; + if (x->a.a_rank != rank) + FEerror(" ~a has wrong rank",1,x); + if (rank == 0) return fSaset1(x,0,ii); + ASSURE_TYPE(ii,t_fixnum); + i = fix(ii); + if (rank == 1) + return fSaset1(x,i,y); + va_start(ap,y); + m = 0; + k = i; + /* index into 1 dimensional array body */ + i1 = 0; + rank-- ; + while(1) + { + if (k >= x->a.a_dims[m]) { + object x,x1; + x=make_fixnum(m); + x1=make_fixnum(k); + FEerror("Index number ~a: ~a to array is out of bounds", + 2,x,x1); + } + i1 += k; + if (m < rank) + {object u; + if (m == 0) + { u = y;} + else + { u = va_arg(ap,object);} + check_type(u,t_fixnum); + k = Mfix(u); + m++ ; + i1 = i1 * x->a.a_dims[m]; + + } + else + { y = va_arg(ap,object); + break ;} + } + va_end(ap); + return fSaset1(x,i1,y); + } + else + { + ASSURE_TYPE(ii,t_fixnum); + i = fix(ii); + return fSaset1(x,i,y); + } + +} + + +DEFUNO_NEW("SVSET", object, fSsvset, SI, 3, 3, NONE, OO, IO, OO, + OO,void,siLsvset,(object x,fixnum i,object val),"") +{ if (TYPE_OF(x) != t_vector + || DISPLACED_TO(x) != Cnil) + Wrong_type_error("simple array",0); + if (i > x->v.v_dim) + { FEerror("out of bounds",0); + } + return x->v.v_self[i] = val; +} + +/* +(proclaim '(ftype (function (fixnum fixnum t *)) make-vector1)) +(defun make-vector1 (n elt-type staticp &optional fillp initial-element + displaced-to (displaced-index-offset 0)) + (declare (fixnum n elt-type displaced-index-offset)) +*/ + + +DEFUN_NEW("MAKE-VECTOR1",object,fSmake_vector1,SI,3,8,NONE,OO, + OO,OO,OO,(object on,object oelt_type,object staticp,...),"") + +{ + int displaced_index_offset=0; + int Inargs = VFUN_NARGS - 3; + fixnum n=fixint(on),elt_type=fixint(oelt_type); + va_list Iap;object fillp;object initial_element;object displaced_to;object V9; + Inargs = VFUN_NARGS - 3 ; + { object x; + BEGIN_NO_INTERRUPT; + switch(elt_type) { + case aet_ch: + x = alloc_object(t_string); + x->ust.ust_adjustable=1; + goto a_string; + break; + case aet_bit: + x = alloc_object(t_bitvector); + x->v.v_elttype = elt_type; + x->v.v_adjustable=1; + break; + default: + x = alloc_object(t_vector);} + x->v.v_elttype = elt_type; + x->v.v_adjustable=1; + a_string: + x->v.v_dim = n; + x->v.v_self = 0; + x->v.v_displaced = Cnil; + + if( --Inargs < 0)goto LA1; + else { + va_start(Iap,staticp); + fillp=va_arg(Iap,object); + if (fillp == Cnil) + {x->v.v_hasfillp = 0; + x->v.v_fillp = n; + } + else + if(type_of(fillp) == t_fixnum) + { + x->v.v_fillp = Mfix(fillp); + if (x->v.v_fillp > n || x->v.v_fillp < 0) FEerror("bad fillp",0); + x->v.v_hasfillp = 1; + } + else + { + x->v.v_fillp = n; + x->v.v_hasfillp = 1; + } + + } + + if( --Inargs < 0)goto LA2; + else { + initial_element=va_arg(Iap,object);} + + if( --Inargs < 0)goto LA4; + else { + displaced_to=va_arg(Iap,object);} + + if( --Inargs < 0)goto LA5; + else { + V9=va_arg(Iap,object); + if (displaced_to != Cnil) + { + ASSURE_TYPE(V9,t_fixnum); + displaced_index_offset=Mfix(V9);}} + goto LA6; + + LA1: + x->v.v_hasfillp = 0; + x->v.v_fillp = n; + LA2: + initial_element=Cnil; + LA4: + displaced_to=Cnil; + LA5: + displaced_index_offset= 0; + LA6: + va_end(Iap); + { if (displaced_to == Cnil) + array_allocself(x,staticp!=Cnil,initial_element); + else { displace(x,displaced_to,displaced_index_offset);} + END_NO_INTERRUPT; + + return x; + } + } + } +object +fSmake_vector1_1(fixnum n,fixnum elt_type,object staticp) { + VFUN_NARGS=3; + return FFN(fSmake_vector1)(make_fixnum(n),make_fixnum(elt_type),staticp); +} + + +static object DFLT_aet_object = Cnil; +static char DFLT_aet_ch = ' '; +static char DFLT_aet_char = 0; +static fixnum DFLT_aet_fix = 0 ; +static short DFLT_aet_short = 0; +static shortfloat DFLT_aet_sf = 0.0; +static longfloat DFLT_aet_lf = 0.0; +static object Iname_t = sLt; +static struct { char * dflt; object *namep;} aet_types[] = +{ {(char *) &DFLT_aet_object, &Iname_t,}, /* t */ + {(char *) &DFLT_aet_ch, &sLstring_char,},/* string-char */ + {(char *) &DFLT_aet_fix, &sLbit,}, /* bit */ + {(char *) &DFLT_aet_fix, &sLfixnum,}, /* fixnum */ + {(char *) &DFLT_aet_sf, &sLshort_float,}, /* short-float */ + {(char *) &DFLT_aet_lf, &sLlong_float,}, /* long-float */ + {(char *) &DFLT_aet_char,&sLsigned_char,}, /* signed char */ + {(char *) &DFLT_aet_char,&sLunsigned_char,}, /* unsigned char */ + {(char *) &DFLT_aet_short,&sLsigned_short,}, /* signed short */ + {(char *) &DFLT_aet_short, &sLunsigned_short}, /* unsigned short */ + }; + +DEFUN_NEW("GET-AELTTYPE",object,fSget_aelttype,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") +{ int i; + for (i=0 ; i < aet_last ; i++) + if (x == * aet_types[i].namep) + return make_fixnum((enum aelttype) i); + if (x == sLlong_float || x == sLsingle_float || x == sLdouble_float) + return make_fixnum(aet_lf); + return make_fixnum(aet_object); +} +#ifdef STATIC_FUNCTION_POINTERS +object +fSget_aelttype(object x) { + return FFN(fSget_aelttype)(x); +} +#endif + +/* backward compatibility only: + (si:make-vector element-type 0 + dimension 1 + adjustable 2 + fill-pointer 3 + displaced-to 4 + displaced-index-offset 5 + static 6 &optional initial-element) +*/ +DEFUNO_NEW("MAKE-VECTOR",object,fSmake_vector,SI,7,8,NONE, + OO,OO,OO,OO,void,siLmake_vector,(object x0,object x1,object x2,object x3,object x4,object x5,object x6,...),"") +{int narg=VFUN_NARGS; + object initial_elt; + va_list ap; + object x; + {va_start(ap,x6); + if (narg>=8) initial_elt=va_arg(ap,object);else goto LDEFAULT8; + goto LEND_VARARG; + LDEFAULT8: initial_elt = Cnil ; + LEND_VARARG: va_end(ap);} + + /* 8 args */ + + VFUN_NARGS = 8; + x = FFN(fSmake_vector1)(x1, /* n */ + fSget_aelttype(x0), /*aelt type */ + x6, /* staticp */ + x3, /* fillp */ + initial_elt, /* initial element */ + x4, /*displaced to */ + x5); /* displaced-index offset */ + x0 = x; + RETURN1(x0); +} + +/* +(proclaim '(ftype (function (fixnum t *)) make-array1)) +(defun make-array1 ( elt-type staticp initial-element + displaced-to displaced-index-offset &optional dim1 dim2 .. ) + (declare (fixnum n elt-type displaced-index-offset)) +*/ + +DEFUN_NEW("MAKE-ARRAY1",object,fSmake_array1,SI,6,6, + NONE,OI,OO,OI,OO, + (fixnum elt_type,object staticp,object initial_element,object displaced_to,fixnum displaced_index_offset, + object dimensions),"") +{ + int rank = length(dimensions); + if (rank > ARRAY_RANK_LIMIT) + FEerror("Array rank limit exceeded.",0); + { object x,v; + char *tmp_alloc; + int dim =1,i; + BEGIN_NO_INTERRUPT; + x = alloc_object(t_array); + x->a.a_elttype = elt_type; + x->a.a_self = 0; + x->a.a_rank = rank; + x->a.a_displaced = Cnil; + x->a.a_dims = AR_ALLOC(alloc_relblock,rank,int); + i = 0; + v = dimensions; + while (i < rank) + { x->a.a_dims[i] = FIX_CHECK(Mcar(v)); + if (x->a.a_dims[i] < 0) + { FEerror("Dimension must be non negative",0);} + if (dim && x->a.a_dims[i]>((1UL<<(sizeof(dim)*8-1))-1)/dim) + FEerror("Total dimension overflow on dimensions ~s",1,dimensions); + dim *= x->a.a_dims[i++]; + v = Mcdr(v);} + x->a.a_dim = dim; + x->a.a_adjustable = 1; + { if (displaced_to == Cnil) + array_allocself(x,staticp!=Cnil,initial_element); + else { displace(x,displaced_to,displaced_index_offset);} + END_NO_INTERRUPT; + return x; + } + }} +#ifdef STATIC_FUNCTION_POINTERS +object +fSmake_array1(fixnum elt_type,object staticp,object initial_element,object displaced_to, + fixnum displaced_index_offset,object dimensions) { + return FFN(fSmake_array1)(elt_type,staticp,initial_element, + displaced_to,displaced_index_offset,dimensions); +} +#endif + + +/* +(proclaim '(ftype (function (object t *)) array-displacement1)) +(defun array-displacement1 ( array ) +*/ + +/* DEFUNO_NEW("ARRAY-DISPLACEMENT1",object,fSarray_displacement,SI,1,1, */ +/* NONE,OO,OO,OO,OO,void,siLarray_displacement,"") */ +/* (object array) { */ + +/* object a; */ +/* int s,n; */ + +/* BEGIN_NO_INTERRUPT; */ +/* if (type_of(array)!=t_array && type_of(array)!=t_vector) */ +/* FEerror("Argument is not an array",0); */ +/* a=array->a.a_displaced->c.c_car; */ +/* if (a==Cnil) { */ +/* END_NO_INTERRUPT; */ +/* return make_cons(Cnil,make_fixnum(0)); */ +/* } */ +/* s=aet_sizes[Iarray_element_type(a)]; */ +/* n=(void *)array->a.a_self-(void *)a->a.a_self; */ +/* if (n%s) */ +/* FEerror("Array is displaced by fractional elements",0); */ +/* END_NO_INTERRUPT; */ +/* return make_cons(a,make_fixnum(n/s)); */ + +/* } */ + +static void +FFN(Larray_displacement)(void) { + + object array,a; + int s,n; + + BEGIN_NO_INTERRUPT; + + n = vs_top - vs_base; + if (n < 1) + FEtoo_few_arguments(vs_base,vs_top); + if (n > 1) + FEtoo_many_arguments(vs_base,vs_top); + array = vs_base[0]; + vs_base=vs_top; + +/* if (type_of(array)!=t_array && type_of(array)!=t_vector && */ +/* type_of(array)!=t_bitvector && type_of(array)!=t_string) */ +/* FEwrong_type_argument(sLarray,array); */ + IisArray(array); + a=array->a.a_displaced->c.c_car; + + if (a==Cnil) { + + vs_push(Cnil); + vs_push(make_fixnum(0)); + END_NO_INTERRUPT; + + return; + + } + + s=aet_sizes[Iarray_element_type(a)]; + n=(void *)array->a.a_self-(void *)a->a.a_self; + if (n%s) + FEerror("Array is displaced by fractional elements",0); + + vs_push(a); + vs_push(make_fixnum(n/s)); + END_NO_INTERRUPT; + + return; + +} + +/* + For the X->a.a_displaced field, the CAR is an array which X + 's body is displaced to (ie body of X is part of Another array) + and the (CDR) is the LIST of arrays whose bodies are displaced + to X + (setq a (make-array 2 :displaced-to (setq b (make-array 4 )))) + ;{ A->displ = (B), B->displ=(nil A)} +(setq w (make-array 3)) ;; w->displaced= (nil y u) +(setq y (make-array 2 :displaced-to w)) ;; y->displaced=(w z z2) +(setq u (make-array 2 :displaced-to w)) ;; u->displaced = (w) +(setq z (make-array 2 :displaced-to y)) ;; z->displaced = (y) +(setq z2 (make-array 2 :displaced-to y)) ;; z2->displaced= (y) +*/ + +static void +displace(object from_array, object dest_array, int offset) +{ + enum aelttype typ; + IisArray(from_array); + IisArray(dest_array); + typ =Iarray_element_type(from_array); + if (typ != Iarray_element_type(dest_array)) + { Wrong_type_error("same element type",0); + } + if (offset + from_array->a.a_dim > dest_array->a.a_dim) + { FEerror("Destination array too small to hold other array",0); + } + /* ensure that we have a cons */ + if (dest_array->a.a_displaced == Cnil) + { dest_array->a.a_displaced = list(2,Cnil,from_array);} + else + Mcdr(dest_array->a.a_displaced) = make_cons(from_array, + Mcdr(dest_array->a.a_displaced)); + from_array->a.a_displaced = make_cons(dest_array,sLnil); + + /* now set the actual body of from_array to be the address + of body in dest_array. If it is a bit array, this cannot carry the + offset information, since the body is only recorded as multiples of + BV_BITS + */ + + + if (typ == aet_bit) + { offset += BV_OFFSET(dest_array); + from_array->bv.bv_self = dest_array->bv.bv_self + offset/BV_BITS; + SET_BV_OFFSET(from_array,offset % BV_BITS); + } + else + from_array->a.a_self = ARRAY_BODY_PTR(dest_array,offset); + +} + + + +static enum aelttype +Iarray_element_type(object x) +{enum aelttype t=aet_last; + switch(TYPE_OF(x)) + { case t_array: + t = (enum aelttype) x->a.a_elttype; + break; + case t_vector: + t = (enum aelttype) x->v.v_elttype; + break; + case t_bitvector: + t = aet_bit; + break; + case t_string: + t = aet_ch; + break; + default: + FEerror("Not an array ~a ",1,x); + } + return t; +} + + /* Make the body of FROM array point to the body of TO + at the DISPLACED_INDEX_OFFSET + */ + +/* static void */ +/* Idisplace_array(object from, object to, int displaced_index_offset) */ +/* { */ +/* enum aelttype t1,t2; */ +/* t1 = Iarray_element_type(from); */ +/* t2 = Iarray_element_type(to); */ +/* if (t1 != t2) */ +/* FEerror("Attempt to displace arrays of one type to arrays of another type",0); */ +/* if (to->a.a_dim > from->a.a_dim - displaced_index_offset) */ +/* FEerror("To array not large enough for displacement",0); */ +/* {BEGIN_NO_INTERRUPT; */ +/* from->a.a_displaced = make_cons(to,Cnil); */ +/* if (to->a.a_displaced == Cnil) */ +/* to->a.a_displaced = make_cons(Cnil,Cnil); */ +/* DISPLACED_FROM(to) = make_cons(from,DISPLACED_FROM(to)); */ + +/* if (t1 == aet_bit) { */ +/* displaced_index_offset += BV_OFFSET(to); */ +/* from->bv.bv_self = to->bv.bv_self + displaced_index_offset/BV_BITS; */ +/* SET_BV_OFFSET(from, displaced_index_offset%BV_BITS); */ +/* } */ +/* else */ +/* from->st.st_self = ARRAY_BODY_PTR(to,displaced_index_offset); */ +/* END_NO_INTERRUPT; */ +/* } */ + +/* } */ + +/* add diff to body of x and arrays diisplaced to it */ + +void +adjust_displaced(object x, long diff) +{ + if (x->ust.ust_self != NULL) + x->ust.ust_self = (unsigned char *)((long)(x->a.a_self) + diff); + for (x = Scdr(x->ust.ust_displaced); x != Cnil; x = Scdr(x)) + adjust_displaced(Mcar(x), diff); +} + + + + + /* RAW_AET_PTR returns a pointer to something of raw type obtained from X + suitable for using GSET for an array of elt type TYP. + If x is the null pointer, return a default for that array element + type. + */ + +static char * +raw_aet_ptr(object x, short int typ) +{ /* doubles are the largest raw type */ + + static union{ + object o;char c;fixnum i;shortfloat f;longfloat d; + unsigned char uc;short s;unsigned short us;} u; + + if (x==Cnil) + return aet_types[typ].dflt; + + switch (typ){ +/* #define STORE_TYPED(pl,type,val) *((type *) pl) = (type) val; break; */ + case aet_object: + /* STORE_TYPED(&u,object,x); */ + u.o=x; + break; + case aet_ch: + /* STORE_TYPED(&u,char, char_code(x)); */ + u.c=char_code(x); + break; + case aet_bit: + /* STORE_TYPED(&u,fixnum, -Mfix(x)); */ + u.i=-Mfix(x); + break; + case aet_fix: + /* STORE_TYPED(&u,fixnum, Mfix(x)); */ + u.i=Mfix(x); + break; + case aet_sf: + /* STORE_TYPED(&u,shortfloat, Msf(x)); */ + u.f=Msf(x); + break; + case aet_lf: + /* STORE_TYPED(&u,longfloat, Mlf(x)); */ + u.d=Mlf(x); + break; + case aet_char: + /* STORE_TYPED(&u, char, Mfix(x)); */ + u.c=(char)Mfix(x); + break; + case aet_uchar: + /* STORE_TYPED(&u, unsigned char, Mfix(x)); */ + u.uc=(unsigned char)Mfix(x); + break; + case aet_short: + /* STORE_TYPED(&u, short, Mfix(x)); */ + u.s=(short)Mfix(x); + break; + case aet_ushort: + /* STORE_TYPED(&u,unsigned short,Mfix(x)); */ + u.us=(unsigned short)Mfix(x); + break; + default: + FEerror("bad elttype",0); + break; + } + return (char *)&u; +} + + + /* GSET copies into array ptr P1, the value + pointed to by the ptr VAL into the next N slots. The + array type is typ. If VAL is the null ptr, use + the default for that element type + NOTE: for type aet_bit n is the number of Words + ie (nbits +WSIZE-1)/WSIZE and the words are set. + */ + +void +gset(void *p1, void *val, int n, int typ) +{ if (val==0) + val = aet_types[typ].dflt; + switch (typ){ + +#define GSET(p,n,typ,val) {typ x = *((typ *) val); GSET1(p,n,typ,x)} +#define GSET1(p,n,typ,val) while (n-- > 0) \ + { *((typ *) p) = val; \ + p = p + sizeof(typ); \ + } break; + + case aet_object: GSET(p1,n,object,val); + case aet_ch: GSET(p1,n,char,val); + /* Note n is number of fixnum WORDS for bit */ + case aet_bit: GSET(p1,n,fixnum,val); + case aet_fix: GSET(p1,n,fixnum,val); + case aet_sf: GSET(p1,n,shortfloat,val); + case aet_lf: GSET(p1,n,longfloat,val); + case aet_char: GSET(p1,n,char,val); + case aet_uchar: GSET(p1,n,unsigned char,val); + case aet_short: GSET(p1,n,short,val); + case aet_ushort: GSET(p1,n,unsigned short,val); + default: FEerror("bad elttype",0); + } + } + + +#define W_SIZE (BV_BITS*sizeof(fixnum)) + + /* + */ + +DEFUN_NEW("COPY-ARRAY-PORTION",object,fScopy_array_portion,SI,4, + 5,NONE,OO,OO,OO,OO,(object x,object y,object oi1,object oi2,object n1o), + "Copy elements from X to Y starting at x[i1] to x[i2] and doing N1 \ +elements if N1 is supplied otherwise, doing the length of X - I1 \ +elements. If the types of the arrays are not the same, this has \ +implementation dependent results.") +{ fixnum i1=fix(oi1),i2=fix(oi2); + enum aelttype typ1=Iarray_element_type(x); + enum aelttype typ2=Iarray_element_type(y); + int n1=fix(n1o),nc; + if (VFUN_NARGS==4) + { n1 = x->v.v_dim - i1;} + if (typ1==aet_bit) + {if (i1 % CHAR_SIZE) + badcopy: + FEerror("Bit copies only if aligned",0); + else + {int rest=n1%CHAR_SIZE; + if (rest!=0 ) + {if (typ2!=aet_bit) + goto badcopy; + {while(rest> 0) + { fSaset1(y,i2+n1-rest,(fLrow_major_aref(x,i1+n1-rest))); + rest--;} + }} + i1=i1/CHAR_SIZE ; + n1=n1/CHAR_SIZE; + typ1=aet_char; + }}; + if (typ2==aet_bit) + {if (i2 % CHAR_SIZE) + goto badcopy; + i2=i2/CHAR_SIZE ;} + if ((typ1 ==aet_object || + typ2 ==aet_object) && typ1 != typ2) + FEerror("Can't copy between different array types",0); + nc=n1 * aet_sizes[(int)typ1]; + if (i1+n1 > x->a.a_dim + || ((y->a.a_dim - i2) *aet_sizes[(int)typ2]) < nc) + FEerror("Copy out of bounds",0); + bcopy(x->ust.ust_self + (i1*aet_sizes[(int)typ1]), + y->ust.ust_self + (i2*aet_sizes[(int)typ2]), + nc); + return x; +} + +/* X is the header of an array. This supplies the body which + will not be relocatable if STATICP. If DFLT is 0, do not + initialize (the caller promises to reset these before the + next gc!). If DFLT == Cnil then initialize to default type + for this array type. Otherwise DFLT is an object and its + value is used to init the array */ + +void +array_allocself(object x, int staticp, object dflt) +{ + int n; + void *(*fun)(size_t),*tmp_alloc; + enum aelttype typ; + fun = (staticp ? alloc_contblock : alloc_relblock); + { /* this must be called from within no interrupt code */ + n = x->a.a_dim; + typ = Iarray_element_type(x); + switch (typ) { + case aet_object: + x->a.a_self = AR_ALLOC(*fun,n,object); + break; + case aet_ch: + case aet_char: + case aet_uchar: + x->st.st_self = AR_ALLOC(*fun,n,char); + break; + case aet_short: + case aet_ushort: + x->ust.ust_self = (unsigned char *) AR_ALLOC(*fun,n,short); + break; + case aet_bit: + n = (n+W_SIZE-1)/W_SIZE; + SET_BV_OFFSET(x,0); + case aet_fix: + x->fixa.fixa_self = AR_ALLOC(*fun,n,fixnum); + break; + case aet_sf: + x->sfa.sfa_self = AR_ALLOC(*fun,n,shortfloat); + break; + case aet_lf: + x->lfa.lfa_self = AR_ALLOC(*fun,n,longfloat); + break; + default: + break; + } + if(dflt!=OBJNULL) gset(x->st.st_self,raw_aet_ptr(dflt,typ),n,typ); + } + +} + +DEFUNO_NEW("FILL-POINTER-SET",object,fSfill_pointer_set,SI,2,2, + NONE,OO,IO,OO,OO,void,siLfill_pointer_set,(object x,fixnum i),"") +{ + + if (!(TS_MEMBER(type_of(x),TS(t_vector)| + TS(t_bitvector)| + TS(t_string)))) + goto no_fillp; + if (x->v.v_hasfillp == 0) + { goto no_fillp;} + if (i < 0 || i > x->a.a_dim) + { FEerror("~a is not suitable for a fill pointer for ~a",2,make_fixnum(i),x);} + x->v.v_fillp = i; + return make_fixnum(i); + + no_fillp: + FEerror("~a does not have a fill pointer",1,x); + + return make_fixnum(0); +} + +DEFUNO_NEW("FILL-POINTER",object,fLfill_pointer,LISP,1,1,NONE,OO, + OO,OO,OO,void,Lfill_pointer,(object x),"") +{ + if (!(TS_MEMBER(type_of(x),TS(t_vector)| + TS(t_bitvector)| + TS(t_string)))) + goto no_fillp; + if (x->v.v_hasfillp == 0) + { goto no_fillp;} + return make_fixnum(x->v.v_fillp) ; + + no_fillp: + FEwrong_type_argument(sLvector,x); + return make_fixnum(0); +} + +DEFUN_NEW("ARRAY-HAS-FILL-POINTER-P",object, + fLarray_has_fill_pointer_p,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") +{ + if (TS_MEMBER(type_of(x),TS(t_vector)| + TS(t_bitvector)| + TS(t_string))) + return (x->v.v_hasfillp == 0 ? Cnil : sLt); + else + if (TYPE_OF(x) == t_array) + { return Cnil;} + else IisArray(x); + return Cnil; +} + + + +/* DEFUN_NEW("MAKE-ARRAY-INTERNAL",object,fSmake_array_internal,SI,0,0,NONE,OO,OO,OO,OO) + (element_type,adjustable,displaced_to,displaced_index_offset,static,initial_element,dimensions) + object element_type,adjustable,displaced_to,displaced_index_offset,static,initial_element,dimensions; + +*/ + +DEFUNO_NEW("ARRAY-ELEMENT-TYPE",object,fLarray_element_type, + LISP,1,1,NONE,OO,OO,OO,OO,void,Larray_element_type,(object x),"") +{ enum aelttype t; + t = Iarray_element_type(x); + return * aet_types[(int)t].namep; +} + +DEFUNO_NEW("ADJUSTABLE-ARRAY-P",object,fLadjustable_array_p, + LISP,1,1,NONE,OO,OO,OO,OO,void,Ladjustable_array_p,(object x),"") +{ + IisArray(x); + return sLt; +} + +DEFUNO_NEW("DISPLACED-ARRAY-P",object,fSdisplaced_array_p,SI,1, + 1,NONE,OO,OO,OO,OO,void,siLdisplaced_array_p,(object x),"") +{ IisArray(x); + return (x->a.a_displaced == Cnil ? Cnil : sLt); +} + +DEFUNO_NEW("ARRAY-RANK",object,fLarray_rank,LISP,1,1,NONE,OO,OO,OO, + OO,void,Larray_rank,(object x),"") +{ if (type_of(x) == t_array) + return make_fixnum(x->a.a_rank); + IisArray(x); + return make_fixnum(1); +} + +DEFUNO_NEW("ARRAY-DIMENSION",object,fLarray_dimension,LISP,2,2, + NONE,OO,IO,OO,OO,void,Larray_dimension,(object x,fixnum i),"") +{ + if (type_of(x) == t_array) + { if ((unsigned int)i >= x->a.a_rank) + FEerror("Index ~a out of bounds for array-dimension",1 + ,make_fixnum(i)); + else { return make_fixnum(x->a.a_dims[i]);}} + IisArray(x); + return make_fixnum(x->v.v_dim); +} + +static void +Icheck_displaced(object displaced_list, object ar, int dim) +{ + while (displaced_list!=Cnil) + { object u = Mcar(displaced_list); + displaced_list = Mcdr(displaced_list); + if (u->a.a_self == NULL) continue; + if ((Iarray_element_type(u) == aet_bit && + (u->bv.bv_self - ar->bv.bv_self)*BV_BITS +u->bv.bv_dim -dim + + BV_OFFSET(u) - BV_OFFSET(ar) > 0) + || (ARRAY_BODY_PTR(u,u->a.a_dim) > ARRAY_BODY_PTR(ar,dim))) + FEerror("Bad displacement",0); + Icheck_displaced(DISPLACED_FROM(u),ar,dim); + } +} + +/* + (setq a (make-array 2 :displaced-to (setq b (make-array 4 )))) + { A->displ = (B), B->displ=(nil A)} +(setq w (make-array 3)) ;; w->displaced= (nil y u) +(setq y (make-array 2 :displaced-to w)) ;; y->displaced=(w z z2) +(setq u (make-array 2 :displaced-to w)) ;; u->displaced = (w) +(setq z (make-array 2 :displaced-to y)) ;; z->displaced = (y) +(setq z2 (make-array 2 :displaced-to y)) ;; z2->displaced= (y) + + + Destroy the displacement from AR + + */ +/* static void */ +/* Iundisplace(object ar) */ +/* { object *p,x; */ + +/* if ((x = DISPLACED_TO(ar)) == Cnil || */ +/* ar->a.a_displaced->d.m == FREE) */ +/* return; */ +/* {BEGIN_NO_INTERRUPT; */ +/* DISPLACED_TO(ar) = Cnil; */ +/* p = &(DISPLACED_FROM(x)) ; */ + /* walk through the displaced from list and delete AR */ +/* while(1) */ +/* { if ((*p)->d.m == FREE */ +/* || *p == Cnil) */ +/* goto retur; */ +/* if((Mcar(*p) == ar)) */ +/* { *p = Mcdr(*p); */ +/* goto retur;} */ +/* p = &(Mcdr(*p)); */ +/* } */ +/* retur: */ +/* END_NO_INTERRUPT; */ +/* return; */ +/* } */ +/* } */ + +DEFUNO_NEW("REPLACE-ARRAY",object,fSreplace_array,SI,2,2,NONE, + OO,OO,OO,OO,void,siLreplace_array,(object old,object new),"") +{ struct dummy fw ; + fw = old->d; + + old = IisArray(old); + + if (TYPE_OF(old) != TYPE_OF(new) + || (TYPE_OF(old) == t_array && old->a.a_rank != new->a.a_rank)) + { + FEerror("Cannot do array replacement ~a by ~a",2,old,new); + } + { int offset = new->ust.ust_self - old->ust.ust_self; + object displaced = make_cons(DISPLACED_TO(new),DISPLACED_FROM(old)); + Icheck_displaced(DISPLACED_FROM(old),old,new->a.a_dim); + adjust_displaced(old,offset); +/* Iundisplace(old); */ + if (TYPE_OF(old) == t_vector && old->v.v_hasfillp) + { new->v.v_hasfillp = 1; + new->v.v_fillp = old->v.v_fillp;} + if (TYPE_OF(old) == t_string) + old->st = new->st; + else + old->a = new ->a; + + /* prevent having two arrays with the same body--which are not related + that would cause the gc to try to copy both arrays and there might + not be enough space. */ + new->a.a_dim = 0; + new->a.a_self = 0; + old->d = fw; + old->a.a_displaced = displaced; + } + return old; +} + +DEFUN_NEW("ARRAY-TOTAL-SIZE",object,fLarray_total_size,LISP,1,1,NONE,IO,OO,OO,OO,(object x),"") +{ x = IisArray(x); + return (object)(fixnum)x->a.a_dim; +} + + + + +DEFUN_NEW("ASET-BY-CURSOR",object,fSaset_by_cursor,SI,3,3, + NONE,OO,OO,OO,OO,(object array,object val,object cursor),"") +{ + object x; + int i; + object ind[ARRAY_RANK_LIMIT]; + /* 3 args */ + ind[0]=array; + if (cursor==sLnil) {fSaset1(array,0,val); RETURN1(array);} + ind[1]=MMcar(cursor); + ASSURE_TYPE(ind[1],t_fixnum); + i = 2; + for (x = MMcdr(cursor); !endp(x); x = MMcdr(x)) + { ind[i++] = MMcar(x);} + ind[i]=val; + VFUN_NARGS=i+1; + + /* FIXME do this with C macros */ + switch(i+1){ + case 3: (*FFN(fSaset))(ind[0],ind[1],ind[2]);break; + case 4: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3]);break; + case 5: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4]);break; + case 6: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5]);break; + case 7: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6]);break; + case 8: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7]);break; + case 9: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8]);break; + case 10: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9]);break; + case 11: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10]);break; + case 12: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11]);break; + case 13: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12]);break; + case 14: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13]);break; + case 15: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14]);break; + case 16: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15]);break; + case 17: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16]);break; + case 18: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17]);break; + case 19: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18]);break; + case 20: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19]);break; + case 21: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20]);break; + case 22: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21]);break; + case 23: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22]);break; + case 24: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23]);break; + case 25: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23],ind[24]);break; + case 26: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23],ind[24],ind[25]);break; + case 27: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23],ind[24],ind[25],ind[26]);break; + case 28: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23],ind[24],ind[25],ind[26],ind[27]);break; + case 29: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28]);break; + case 30: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], + ind[29]);break; + case 31: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], + ind[29],ind[30]);break; + case 32: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], + ind[29],ind[30],ind[31]);break; + case 33: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], + ind[29],ind[30],ind[31],ind[32]);break; + case 34: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], + ind[29],ind[30],ind[31],ind[32],ind[33]);break; + case 35: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], + ind[29],ind[30],ind[31],ind[32],ind[33],ind[34]);break; + case 36: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], + ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35]);break; + case 37: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], + ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], + ind[36]);break; + case 38: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], + ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], + ind[36],ind[37]);break; + case 39: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], + ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], + ind[36],ind[37],ind[38]);break; + case 40: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], + ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], + ind[36],ind[37],ind[38],ind[39]);break; + case 41: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], + ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], + ind[36],ind[37],ind[38],ind[39],ind[40]);break; + case 42: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], + ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], + ind[36],ind[37],ind[38],ind[39],ind[40],ind[41]);break; + case 43: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], + ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], + ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42]);break; + case 44: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], + ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], + ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], + ind[43]);break; + case 45: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], + ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], + ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], + ind[43],ind[44]);break; + case 46: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], + ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], + ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], + ind[43],ind[44],ind[45]);break; + case 47: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], + ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], + ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], + ind[43],ind[44],ind[45],ind[46]);break; + case 48: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], + ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], + ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], + ind[43],ind[44],ind[45],ind[46],ind[47]);break; + case 49: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], + ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], + ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], + ind[43],ind[44],ind[45],ind[46],ind[47],ind[48]);break; + case 50: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], + ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], + ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], + ind[43],ind[44],ind[45],ind[46],ind[47],ind[48],ind[49]);break; + case 51: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], + ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], + ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], + ind[43],ind[44],ind[45],ind[46],ind[47],ind[48],ind[49], + ind[50]);break; + case 52: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], + ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], + ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], + ind[43],ind[44],ind[45],ind[46],ind[47],ind[48],ind[49], + ind[50],ind[51]);break; + case 53: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], + ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], + ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], + ind[43],ind[44],ind[45],ind[46],ind[47],ind[48],ind[49], + ind[50],ind[51],ind[52]);break; + case 54: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], + ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], + ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], + ind[43],ind[44],ind[45],ind[46],ind[47],ind[48],ind[49], + ind[50],ind[51],ind[52],ind[53]);break; + case 55: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], + ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], + ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], + ind[43],ind[44],ind[45],ind[46],ind[47],ind[48],ind[49], + ind[50],ind[51],ind[52],ind[53],ind[54]);break; + case 56: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], + ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], + ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], + ind[43],ind[44],ind[45],ind[46],ind[47],ind[48],ind[49], + ind[50],ind[51],ind[52],ind[53],ind[54],ind[55]);break; + case 57: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], + ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], + ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], + ind[43],ind[44],ind[45],ind[46],ind[47],ind[48],ind[49], + ind[50],ind[51],ind[52],ind[53],ind[54],ind[55],ind[56]);break; + case 58: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], + ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], + ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], + ind[43],ind[44],ind[45],ind[46],ind[47],ind[48],ind[49], + ind[50],ind[51],ind[52],ind[53],ind[54],ind[55],ind[56], + ind[57]);break; + case 59: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], + ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], + ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], + ind[43],ind[44],ind[45],ind[46],ind[47],ind[48],ind[49], + ind[50],ind[51],ind[52],ind[53],ind[54],ind[55],ind[56], + ind[57],ind[58]);break; + case 60: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], + ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], + ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], + ind[43],ind[44],ind[45],ind[46],ind[47],ind[48],ind[49], + ind[50],ind[51],ind[52],ind[53],ind[54],ind[55],ind[56], + ind[57],ind[58],ind[59]);break; + case 61: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], + ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], + ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], + ind[43],ind[44],ind[45],ind[46],ind[47],ind[48],ind[49], + ind[50],ind[51],ind[52],ind[53],ind[54],ind[55],ind[56], + ind[57],ind[58],ind[59],ind[60]);break; + case 62: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], + ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], + ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], + ind[43],ind[44],ind[45],ind[46],ind[47],ind[48],ind[49], + ind[50],ind[51],ind[52],ind[53],ind[54],ind[55],ind[56], + ind[57],ind[58],ind[59],ind[60],ind[61]);break; + case 63: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], + ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], + ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], + ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], + ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], + ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], + ind[43],ind[44],ind[45],ind[46],ind[47],ind[48],ind[49], + ind[50],ind[51],ind[52],ind[53],ind[54],ind[55],ind[56], + ind[57],ind[58],ind[59],ind[60],ind[61],ind[62]);break; +/* case 64: (*FFN(fSaset))(ind[0],ind[1],ind[2],ind[3],ind[4],ind[5],ind[6],ind[7], */ +/* ind[8],ind[9],ind[10],ind[11],ind[12],ind[13],ind[14], */ +/* ind[15],ind[16],ind[17],ind[18],ind[19],ind[20],ind[21], */ +/* ind[22],ind[23],ind[24],ind[25],ind[26],ind[27],ind[28], */ +/* ind[29],ind[30],ind[31],ind[32],ind[33],ind[34],ind[35], */ +/* ind[36],ind[37],ind[38],ind[39],ind[40],ind[41],ind[42], */ +/* ind[43],ind[44],ind[45],ind[46],ind[47],ind[48],ind[49], */ +/* ind[50],ind[51],ind[52],ind[53],ind[54],ind[55],ind[56], */ +/* ind[57],ind[58],ind[59],ind[60],ind[61],ind[62],ind[63]);break; */ + default: FEerror("Exceeded call-arguments-limit ",0); + } + + RETURN1(array); +} + +void +gcl_init_array_function(void) { + make_function("ARRAY-DISPLACEMENT", Larray_displacement); +} + + + + diff --git a/o/array.c.prev b/o/array.c.prev new file mode 100755 index 0000000..522beba --- /dev/null +++ b/o/array.c.prev @@ -0,0 +1,1064 @@ +/* + Copyright (C) 1994 W. Schelter + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#include "include.h" + + +#define ARRAY_DIMENSION_LIMIT MOST_POSITIVE_FIXNUM + +DEFCONST("ARRAY-RANK-LIMIT", sLarray_rank_limit, LISP, + make_fixnum(ARRAY_RANK_LIMIT),""); + +DEFCONST("ARRAY-DIMENSION-LIMIT", sLarray_dimension_limit, + LISP, make_fixnum(MOST_POSITIVE_FIX),""); +DEFCONST("ARRAY-TOTAL-SIZE-LIMIT", sLarray_total_size_limit, + LISP, sLarray_dimension_limit,""); + +DEF_ORDINARY("BIT",sLbit,LISP,""); + +/* number of bits in unit of storage of x->bv.bv_self[0] */ + +#define BV_BITS 8 + +#define BITREF(x,i) \ + ((((1 << (BV_BITS -1)) >> (i % BV_BITS)) & (x->bv.bv_self[i/BV_BITS])) \ + ? 1 : 0) + +#define SET_BITREF(x,i) \ + (x->bv.bv_self[i/BV_BITS]) |= ((1 << (BV_BITS -1)) >> (i % BV_BITS)) +#define CLEAR_BITREF(x,i) \ + (x->bv.bv_self[i/BV_BITS]) &= ~(((1 << (BV_BITS -1)) >> (i % BV_BITS))) + +extern short aet_sizes[]; + +#define ARRAY_BODY_PTR(ar,n) \ + (void *)(ar->ust.ust_self + aet_sizes[Iarray_element_type(ar)]*n) + +#define N_FIXNUM_ARGS 6 + +DEFUNO("AREF", object, fLaref, LISP, 2, ARRAY_RANK_LIMIT, + NONE, OO, II, II, II,Laref,"") +(x, i, va_alist) + object x; + int i; + +{ int n = VFUN_NARGS; + int i1; + va_list ap; + if (type_of(x) == t_array) + {int m,k ; + int rank = n - 1; + if (x->a.a_rank != rank) + FEerror(" ~a has wrong rank",x); + if (rank == 1) return fSaref1(x,i); + va_start(ap); + m = 0; + k = i; + /* index into 1 dimensional array */ + i1 = 0; + rank-- ; + while(1) + { + if (k > x->a.a_dims[m]) + FEerror("Index ~a to array is too large",1,make_fixnum (m)); + i1 += k; + if (m < rank) + { i1 = i1 * x->a.a_dims[m]; + if (m < N_FIXNUM_ARGS) + { k = va_arg(ap,int);} + else {object x = va_arg(ap,object); + check_type(x,t_fixnum); + k = Mfix(x);} + m++;} + else break;} + va_end(ap); + return fSaref1(x,i); + } + if (n > 2) + { FEerror("Too many args (~a) to aref",1,make_fixnum(n));} + return fSaref1(x,i); + +} + +int +fScheck_bounds_bounds(x, i) + object x; + int i; +{ + switch (type_of(x)) { + case t_array: + case t_vector: + case t_string: + if ((unsigned int) i >= x->a.a_dim) + FEerror("Array ref out of bounds ~a ~a", 2, x, make_fixnum(i)); + default: + FEerror("not an array"); + } +} + +DEFUN("SVREF", object, fLsvref, LISP, 2, 2, + ONE_VAL, OO, IO, OO,OO, + "For array X and index I it returns (aref x i) ") + (x, i) + object x; + unsigned int i; +{ + if (type_of(x)==t_vector + && (enum aelttype)x->v.v_elttype == aet_object + && x->v.v_dim > i) + RETURN1(x->v.v_self[i]); + if (x->v.v_dim > i) illegal_index(x,make_fixnum(i)); + FEerror("Bad simple vector ~a",1,x); +} + +DEFUN("AREF1", object, fSaref1, SI, 2, 2, + ONE_VAL, OO, IO, OO,OO, + "For array X and index I it returns (aref x i) as if x were \ +1 dimensional, even though its rank may be bigger than 1") +(x, i) + object x; + int i; +{ + switch (type_of(x)) { + case t_array: + case t_vector: + if (x->v.v_dim <= i) + i = fScheck_bounds_bounds(x, i); + switch (x->v.v_elttype) { + case aet_object: + return x->v.v_self[i]; + case aet_ch: + return code_char(x->st.st_self[i]); + case aet_bit: + i += x->bv.bv_offset; + return make_fixnum(BITREF(x, i)); + case aet_fix: + return make_fixnum(x->fixa.fixa_self[i]); + case aet_sf: + return make_longfloat(x->sfa.sfa_self[i]); + case aet_lf: + return make_longfloat(x->lfa.lfa_self[i]); + case aet_char: + return make_fixnum(x->st.st_self[i]); + case aet_uchar: + return make_fixnum(x->ust.ust_self[i]); + case aet_short: + return make_fixnum(SHORT(x, i)); + case aet_ushort: + return make_fixnum(USHORT(x, i)); + + default: + FEerror("unknown array type"); + } + case t_string: + if (x->v.v_dim <= i) + i = fScheck_bounds_bounds(x, i); + return code_char(x->st.st_self[i]); + default: + FEerror("not an array"); + + ; + } +} + +DEFUN("ASET1", object, fSaset1, SI, 3, 3, NONE, OO, IO, OO,OO,"") +(x, i,val) + object x; + int i; + object val; +{ + switch (type_of(x)) { + case t_array: + case t_vector: + if (x->v.v_dim <= i) + i = fScheck_bounds_bounds(x, i); + switch (x->v.v_elttype) { + case aet_object: + x->v.v_self[i] = val; + break; + case aet_ch: + ASSURE_TYPE(val,t_character); + x->st.st_self[i] = char_code(val); + break; + case aet_bit: + i += x->bv.bv_offset; + AGAIN_BIT: + ASSURE_TYPE(val,t_fixnum); + {int v = Mfix(val); + if (v == 0) CLEAR_BITREF(x,i); + else if (v == 1) SET_BITREF(x,i); + else {val= fSincorrect_type(val,sLbit); + goto AGAIN_BIT;} + break;} + case aet_fix: + ASSURE_TYPE(val,t_fixnum); + (x->fixa.fixa_self[i]) = Mfix(val); + break; + case aet_sf: + ASSURE_TYPE(val,t_shortfloat); + (x->sfa.sfa_self[i]) = Msf(val); + break; + case aet_lf: + ASSURE_TYPE(val,t_longfloat); + (x->lfa.lfa_self[i]) = Mlf(val); + break; + case aet_char: + ASSURE_TYPE(val,t_fixnum); + x->st.st_self[i] = Mfix(val); + break; + case aet_uchar: + ASSURE_TYPE(val,t_fixnum); + (x->ust.ust_self[i])= Mfix(val); + break; + case aet_short: + ASSURE_TYPE(val,t_fixnum); + SHORT(x, i) = Mfix(val); + break; + case aet_ushort: + ASSURE_TYPE(val,t_fixnum); + USHORT(x, i) = Mfix(val); + break; + default: + FEerror("unknown array type"); + } + break; + case t_string: + if (x->v.v_dim <= i) + i = fScheck_bounds_bounds(x, i); + ASSURE_TYPE(val,t_character); + x->st.st_self[i] = char_code(val); + break; + default: + FEerror("not an array",0); + } + return val; +} + +DEFUNO("ASET", object, fSaset, SI, 3, ARG_LIMIT, NONE, OO, + IO, OO, OO,siLaset,"") + (x,i,y, va_alist) + object x,y; + int i; + va_dcl +{ int i1; + int n = VFUN_NARGS; + va_list ap; + if (type_of(x) == t_array) + {int m,k ; + int rank = n - 2; + if (x->a.a_rank != rank) + FEerror(" ~a has wrong rank",x); + if (rank == 1) return fSaset1(x,i,y); + va_start(ap); + m = 0; + k = i; + /* index into 1 dimensional array body */ + i1 = 0; + rank-- ; + while(1) + { + if (k >= x->a.a_dims[m]) + FEerror("Index ~a to array is too large",1,make_fixnum (m)); + i1 += k; + if (m < rank) + {object u; + if (m == 0) + { u = y;} + else + { u = va_arg(ap,object);} + check_type(u,t_fixnum); + k = Mfix(u); + m++ ; + i1 = i1 * x->a.a_dims[m]; + + } + else + { y = va_arg(ap,object); + break ;} + } + va_end(ap); + } + else + { i1 = i ;} + return fSaset1(x,i1,y); + +} + +DEFUNO("SVSET", object, fSsvset, SI, 3, 3, NONE, OO, IO, OO, + OO,siLsvset,"") + (x,i,val) + object x,val; + int i; +{ if (TYPE_OF(x) != t_vector + || DISPLACED_TO(x) != Cnil) + Wrong_type_error("simple array",0); + if (i > x->v.v_dim) + { FEerror("out of bounds",0); + } + return x->v.v_self[i] = val; +} + +/* +(proclaim '(ftype (function (fixnum fixnum t *)) make-vector1)) +(defun make-vector1 (n elt-type staticp &optional fillp initial-element + displaced-to (displaced-index-offset 0)) + (declare (fixnum n elt-type displaced-index-offset)) +*/ + + +DEFUN("MAKE-VECTOR1",object,fSmake_vector1,SI,3,8,NONE,OI, + IO,OO,OO,"") + (n,elt_type,staticp,va_alist) +int n;int elt_type;object staticp;va_dcl +{ + int displaced_index_offset; + int Inargs = VFUN_NARGS - 3; + va_list Iap;object fillp;object initial_element;object displaced_to;object V9; + object V10,V11,V12,V13,V14; + Inargs = VFUN_NARGS - 3 ; + { object x; + BEGIN_NO_INTERRUPT; + switch(elt_type) { + case aet_ch: + x = alloc_object(t_string); + goto a_string; + break; + case aet_bit: + x = alloc_object(t_bitvector); + break; + default: + x = alloc_object(t_vector);} + x->v.v_elttype = elt_type; + a_string: + x->v.v_dim = n; + x->v.v_self = 0; + x->v.v_displaced = Cnil; + + if( --Inargs < 0)goto LA1; + else { + va_start(Iap); + fillp=va_arg(Iap,object); + if (fillp == Cnil) + {x->v.v_hasfillp = 0; + x->v.v_fillp = n; } + else { + ASSURE_TYPE(fillp,t_fixnum); + x->v.v_fillp = Mfix(fillp); + x->v.v_hasfillp = 1; + if (x->v.v_fillp > n) FEerror("bad fillp",0); + } + va_end(Iap); + } + + if( --Inargs < 0)goto LA2; + else { + initial_element=va_arg(Iap,object);} + + if( --Inargs < 0)goto LA4; + else { + displaced_to=va_arg(Iap,object);} + + if( --Inargs < 0)goto LA5; + else { + V9=va_arg(Iap,object); + if (displaced_to != Cnil) + { + ASSURE_TYPE(V9,t_fixnum); + displaced_index_offset=Mfix(V9);}} + goto LA6; + + LA1: + x->v.v_hasfillp = 0; + x->v.v_fillp = n; + LA2: + initial_element=Cnil; + LA4: + displaced_to=Cnil; + LA5: + displaced_index_offset= 0; + LA6: + x->v.v_adjustable = 1; + + { if (displaced_to == Cnil) + array_allocself(x,staticp!=Cnil,initial_element); + else { displace(x,displaced_to,displaced_index_offset);} + END_NO_INTERRUPT; + return x; + } + } + } + + + +static object DFLT_aet_object = Cnil; +static char DFLT_aet_ch = ' '; +static char DFLT_aet_char = 0; +static int DFLT_aet_fix = 0 ; +static short DFLT_aet_short = 0; +static shortfloat DFLT_aet_sf = 0.0; +static longfloat DFLT_aet_lf = 0.0; +static object Iname_t = sLt; +struct { char * dflt; object *namep;} aet_types[] = +{ (char *) &DFLT_aet_object, &Iname_t, /* t */ + (char *) &DFLT_aet_ch, &sLstring_char,/* string-char */ + (char *) &DFLT_aet_fix, &sLbit, /* bit */ + (char *) &DFLT_aet_fix, &sLfixnum, /* fixnum */ + (char *) &DFLT_aet_sf, &sLshort_float, /* short-float */ + (char *) &DFLT_aet_lf, &sLlong_float, /* long-float */ + (char *) &DFLT_aet_char,&sLsigned_char, /* signed char */ + (char *) &DFLT_aet_char,&sLunsigned_char, /* unsigned char */ + (char *) &DFLT_aet_short,&sLsigned_short, /* signed short */ + (char *) &DFLT_aet_short, &sLunsigned_short /* unsigned short */ + }; + +DEFUN("GET-AELTTYPE",enum aelttype,fSget_aelttype,SI,1,1,NONE,IO,OO,OO,OO,"") + (x) +object x; +{ int i; + for (i=0 ; i < aet_last ; i++) + if (x == * aet_types[i].namep) + return (enum aelttype) i; + if (x == sLlong_float || x == sLsingle_float || x == sLdouble_float) + return aet_lf; + return aet_object; +} + +/* backward compatibility only: + (si:make-vector element-type 0 + dimension 1 + adjustable 2 + fill-pointer 3 + displaced-to 4 + displaced-index-offset 5 + static 6 &optional initial-element) +*/ +DEFUNO("MAKE-VECTOR",object,fSmake_vector,SI,7,8,NONE, + OO,OO,OO,OO,siLmake_vector,"")(x0,x1,x2,x3,x4,x5,x6,va_alist) +object x0,x1,x2,x3,x4,x5,x6; +va_dcl +{int narg=VFUN_NARGS; + object initial_elt; + va_list ap; + object x; + {va_start(ap); + if (narg>=8) initial_elt=va_arg(ap,object);else goto LDEFAULT8; + goto LEND_VARARG; + LDEFAULT8: initial_elt = Cnil ; + LEND_VARARG: va_end(ap);} + + /* 8 args */ + + VFUN_NARGS = 8; + x = fSmake_vector1(Mfix(x1), /* n */ + fSget_aelttype(x0), /*aelt type */ + x6, /* staticp */ + x3, /* fillp */ + initial_elt, /* initial element */ + x4, /*displaced to */ + x5); /* displaced-index offset */ + x0 = x; + RETURN1(x0); +} + +/* +(proclaim '(ftype (function (fixnum t *)) make-array1)) +(defun make-array1 ( elt-type staticp initial-element + displaced-to displaced-index-offset &optional dim1 dim2 .. ) + (declare (fixnum n elt-type displaced-index-offset)) +*/ + +DEFUN("MAKE-ARRAY1",object,fSmake_array1,SI,6,6, + NONE,OI,OO,OI,OO,"") + (elt_type,staticp,initial_element,displaced_to, displaced_index_offset, + dimensions) + int elt_type; + object staticp,initial_element,displaced_to; + int displaced_index_offset; + object dimensions; +{ + int rank = length(dimensions); + { object x,v; + char *tmp_alloc; + int dim =1,i; + BEGIN_NO_INTERRUPT; + x = alloc_object(t_array); + x->a.a_elttype = elt_type; + x->a.a_self = 0; + x->a.a_rank = rank; + x->a.a_displaced = Cnil; + x->a.a_dims = AR_ALLOC(alloc_relblock,rank,int); + i = 0; + v = dimensions; + while (i < rank) + { x->a.a_dims[i] = FIX_CHECK(Mcar(v)); + dim *= x->a.a_dims[i++]; + v = Mcdr(v);} + x->a.a_dim = dim; + x->a.a_adjustable = 1; + { if (displaced_to == Cnil) + array_allocself(x,staticp!=Cnil,initial_element); + else { displace(x,displaced_to,displaced_index_offset);} + END_NO_INTERRUPT; + return x; + } + }} + + + + + + + + +/* + (setq a (make-array 2 :displaced-to (setq b (make-array 4 )))) + ;{ A->displ = (B), B->displ=(nil A)} +(setq w (make-array 3)) ;; w->displaced= (nil y u) +(setq y (make-array 2 :displaced-to w)) ;; y->displaced=(w z z2) +(setq u (make-array 2 :displaced-to w)) ;; u->displaced = (w) +(setq z (make-array 2 :displaced-to y)) ;; z->displaced = (y) +(setq z2 (make-array 2 :displaced-to y)) ;; z2->displaced= (y) +*/ + +displace(from_array,dest_array,offset) + object from_array,dest_array; + int offset; +{ + enum aelttype typ; + IisArray(from_array); + IisArray(dest_array); + typ =Iarray_element_type(from_array); + if (typ != Iarray_element_type(dest_array)) + { Wrong_type_error("same element type",0); + } + if (offset + from_array->a.a_dim > dest_array->a.a_dim) + { FEerror("Destination array too small to hold other array",0); + } + /* ensure that we have a cons */ + if (dest_array->a.a_displaced == Cnil) + { dest_array->a.a_displaced = list(2,Cnil,from_array);} + else + Mcdr(dest_array->a.a_displaced) = make_cons(from_array, + Mcdr(dest_array->a.a_displaced)); + from_array->a.a_displaced = make_cons(dest_array,sLnil); + + /* now set the actual body of from_array to be the address + of body in dest_array. If it is a bit array, this cannot carry the + offset information, since the body is only recorded as multiples of + BV_BITS + */ + + + if (typ == aet_bit) + { offset += dest_array->bv.bv_offset; + from_array->bv.bv_self = dest_array->bv.bv_self + offset/BV_BITS; + from_array->bv.bv_offset = offset % BV_BITS; + } + else + from_array->a.a_self = ARRAY_BODY_PTR(dest_array,offset); + +} + + + +enum aelttype +Iarray_element_type(x) + object x; +{enum aelttype t; + switch(TYPE_OF(x)) + { case t_array: + t = (enum aelttype) x->a.a_elttype; + break; + case t_vector: + t = (enum aelttype) x->v.v_elttype; + break; + case t_bitvector: + t = aet_bit; + break; + case t_string: + t = aet_ch; + break; + default: + FEerror("Not an array ~a ",1,x); + } + return t; +} + + /* Make the body of FROM array point to the body of TO + at the DISPLACED_INDEX_OFFSET + */ + +Idisplace_array(from,to,displaced_index_offset) + object from,to; + int displaced_index_offset; +{ + enum aelttype t1,t2; + object tail; + t1 = Iarray_element_type(from); + t2 = Iarray_element_type(to); + if (t1 != t2) + FEerror("Attempt to displace arrays of one type to arrays of another type",0); + if (to->a.a_dim > from->a.a_dim - displaced_index_offset) + FEerror("To array not large enough for displacement",0); + {BEGIN_NO_INTERRUPT; + from->a.a_displaced = make_cons(to,Cnil); + if (to->a.a_displaced == Cnil) + to->a.a_displaced = make_cons(Cnil,Cnil); + DISPLACED_FROM(to) = make_cons(from,DISPLACED_FROM(to)); + + if (t1 == aet_bit) { + displaced_index_offset += to->bv.bv_offset; + from->bv.bv_self = to->bv.bv_self + displaced_index_offset/BV_BITS; + from->bv.bv_offset = displaced_index_offset%BV_BITS; + } + else + from->st.st_self = ARRAY_BODY_PTR(to,displaced_index_offset); + END_NO_INTERRUPT; + } + +} + +/* add diff to body of x and arrays diisplaced to it */ + +adjust_displaced(x, diff) +object x; +int diff; +{ + if (x->ust.ust_self != NULL) + x->ust.ust_self = (char *)((int)(x->a.a_self) + diff); + for (x = Mcdr(x->ust.ust_displaced); x != Cnil; x = Mcdr(x)) + adjust_displaced(Mcar(x), diff); +} + + + + + /* RAW_AET_PTR returns a pointer to something of raw type obtained from X + suitable for using GSET for an array of elt type TYP. + If x is the null pointer, return a default for that array element + type. + */ + +char * +raw_aet_ptr(x,typ) + short typ; + object x; +{ /* doubles are the largest raw type */ + static double u; + if (x==Cnil) return aet_types[typ].dflt; + switch (typ){ +#define STORE_TYPED(pl,type,val) *((type *) pl) = (type) val; break; + case aet_object: STORE_TYPED(&u,object,x); + case aet_ch: STORE_TYPED(&u,char, char_code(x)); + case aet_bit: STORE_TYPED(&u,fixnum, -Mfix(x)); + case aet_fix: STORE_TYPED(&u,fixnum, Mfix(x)); + case aet_sf: STORE_TYPED(&u,shortfloat, Msf(x)); + case aet_lf: STORE_TYPED(&u,longfloat, Mlf(x)); + case aet_char: STORE_TYPED(&u, char, Mfix(x)); + case aet_uchar: STORE_TYPED(&u, unsigned char, Mfix(x)); + case aet_short: STORE_TYPED(&u, short, Mfix(x)); + case aet_ushort: STORE_TYPED(&u,unsigned short,Mfix(x)); + default: FEerror("bad elttype",0); + } + return (char *)&u; +} + + + /* GSET copies into array ptr P1, the value + pointed to by the ptr VAL into the next N slots. The + array type is typ. If VAL is the null ptr, use + the default for that element type + NOTE: for type aet_bit n is the number of Words + ie (nbits +WSIZE-1)/WSIZE and the words are set. + */ + +gset(p1,val,n,typ) + char *p1,*val; + int n; + int typ; +{ if (val==0) + val = aet_types[typ].dflt; + switch (typ){ + +#define GSET(p,n,typ,val) {typ x = *((typ *) val); GSET1(p,n,typ,x)} +#define GSET1(p,n,typ,val) while (n-- > 0) \ + { *((typ *) p) = val; \ + p = p + sizeof(typ); \ + } break; + + case aet_object: GSET(p1,n,object,val); + case aet_ch: GSET(p1,n,char,val); + /* Note n is number of fixnum WORDS for bit */ + case aet_bit: GSET(p1,n,fixnum,val); + case aet_fix: GSET(p1,n,fixnum,val); + case aet_sf: GSET(p1,n,shortfloat,val); + case aet_lf: GSET(p1,n,longfloat,val); + case aet_char: GSET(p1,n,char,val); + case aet_uchar: GSET(p1,n,unsigned char,val); + case aet_short: GSET(p1,n,short,val); + case aet_ushort: GSET(p1,n,unsigned short,val); + default: FEerror("bad elttype",0); + } + } + + +#define W_SIZE (BV_BITS*sizeof(fixnum)) + + /* + */ + +DEFUN("COPY-ARRAY-PORTION",object,fScopy_array_portion,SI,4, + 5,NONE,OO,OI,II,OO, + "Copy elements from X to Y starting at x[i1] to x[i2] and doing N1 \ +elements if N1 is supplied otherwise, doing the length of X - I1 \ +elements. If the types of the arrays are not the same, this has \ +implementation dependent results.") + (x,y,i1,i2,n1) + object x,y; int i1,i2,n1; +{ enum aelttype typ1=Iarray_element_type(x); + enum aelttype typ2=Iarray_element_type(y); + int nc; + if (VFUN_NARGS==4) + { n1 = x->v.v_dim - i1;} + if (typ1==aet_bit) + {if (i1 % CHAR_SIZE) + badcopy: + FEerror("Bit copies only if aligned"); + else + {int rest=n1%CHAR_SIZE; + if (rest!=0 ) + {if (typ2!=aet_bit) + goto badcopy; + {while(rest> 0) + { fSaset1(y,i2+n1-rest,(fSaref1(x,i1+n1-rest))); + rest--;} + }} + i1=i1/CHAR_SIZE ; + n1=n1/CHAR_SIZE; + typ1=aet_char; + }}; + if (typ2==aet_bit) + {if (i2 % CHAR_SIZE) + goto badcopy; + i2=i2/CHAR_SIZE ;} + if ((typ1 ==aet_object || + typ2 ==aet_object) && typ1 != typ2) + FEerror("Can't copy between different array types"); + nc=n1 * aet_sizes[(int)typ1]; + if (i1+n1 > x->a.a_dim + || ((y->a.a_dim - i2) *aet_sizes[(int)typ2]) < nc) + FEerror("Copy out of bounds"); + bcopy(x->ust.ust_self + (i1*aet_sizes[(int)typ1]), + y->ust.ust_self + (i2*aet_sizes[(int)typ2]), + nc); + return x; +} + +/* X is the header of an array. This supplies the body which + will not be relocatable if STATICP. If DFLT is 0, do not + initialize (the caller promises to reset these before the + next gc!). If DFLT == Cnil then initialize to default type + for this array type. Otherwise DFLT is an object and its + value is used to init the array */ + +array_allocself(x, staticp, dflt) +object x,dflt; +int staticp; +{ + int i, d,n; + char *(*fun)(),*tmp_alloc; + enum aelttype typ; + fun = (staticp ? alloc_contblock : alloc_relblock); + { /* this must be called from within no interrupt code */ + n = x->a.a_dim; + typ = Iarray_element_type(x); + switch (typ) { + case aet_object: + x->a.a_self = AR_ALLOC(*fun,n,object); + break; + case aet_ch: + case aet_char: + case aet_uchar: + x->st.st_self = AR_ALLOC(*fun,n,char); + break; + case aet_short: + case aet_ushort: + x->ust.ust_self = (unsigned char *) AR_ALLOC(*fun,n,short); + break; + case aet_bit: + n = (n+W_SIZE-1)/W_SIZE; + x->bv.bv_offset = 0; + case aet_fix: + x->fixa.fixa_self = AR_ALLOC(*fun,n,fixnum); + break; + case aet_sf: + x->sfa.sfa_self = AR_ALLOC(*fun,n,shortfloat); + break; + case aet_lf: + x->lfa.lfa_self = AR_ALLOC(*fun,n,longfloat); + break; + } + if(dflt!=0) gset(x->st.st_self,raw_aet_ptr(dflt,typ),n,typ); + } + +} + +DEFUNO("FILL-POINTER-SET",int,fSfill_pointer_set,SI,2,2, + NONE,IO,IO,OO,OO,siLfill_pointer_set,"") + (x,i) + object x; + int i; +{ + + if (!(TS_MEMBER(type_of(x),TS(t_vector)| + TS(t_bitvector)| + TS(t_string)))) + goto no_fillp; + if (x->v.v_hasfillp == 0) + { goto no_fillp;} + if (i < 0 || i > x->a.a_dim) + { FEerror("~a is not suitable for a fill pointer for ~a",2,make_fixnum(i),x);} + x->v.v_fillp = i; + return i; + + no_fillp: + FEerror("~a does not have a fill pointer",1,x); + + return 0; +} + +DEFUNO("FILL-POINTER",int,fLfill_pointer,LISP,1,1,NONE,IO, + OO,OO,OO,Lfill_pointer,"") + (x) + object x; +{ + if (!(TS_MEMBER(type_of(x),TS(t_vector)| + TS(t_bitvector)| + TS(t_string)))) + goto no_fillp; + if (x->v.v_hasfillp == 0) + { goto no_fillp;} + return x->v.v_fillp ; + + no_fillp: + FEerror("~a does not have a fill pointer",1,x); + return 0; +} + +DEFUN("ARRAY-HAS-FILL-POINTER-P",object, + fLarray_has_fill_pointer_p,LISP,1,1,NONE,OO,OO,OO,OO,"") + (x) + object x; +{ + if (TS_MEMBER(type_of(x),TS(t_vector)| + TS(t_bitvector)| + TS(t_string))) + return (x->v.v_hasfillp == 0 ? Cnil : sLt); + else + if (TYPE_OF(x) == t_array) + { return Cnil;} + else IisArray(x); + return Cnil; +} + + + +/* DEFUN("MAKE-ARRAY-INTERNAL",object,fSmake_array_internal,SI,0,0,NONE,OO,OO,OO,OO) + (element_type,adjustable,displaced_to,displaced_index_offset,static,initial_element,dimensions) + object element_type,adjustable,displaced_to,displaced_index_offset,static,initial_element,dimensions; + +*/ + +DEFUNO("ARRAY-ELEMENT-TYPE",object,fLarray_element_type, + LISP,1,1,NONE,OO,OO,OO,OO,Larray_element_type,"") + (x) + object x; +{ enum aelttype t; + t = Iarray_element_type(x); + return * aet_types[(int)t].namep; +} + +DEFUNO("ADJUSTABLE-ARRAY-P",object,fLadjustable_array_p, + LISP,1,1,NONE,OO,OO,OO,OO,Ladjustable_array_p,"") + (x) + object x; +{ return sLt; +} + +DEFUNO("DISPLACED-ARRAY-P",object,fSdisplaced_array_p,SI,1, + 1,NONE,OO,OO,OO,OO,siLdisplaced_array_p,"") + (x) + object x; +{ IisArray(x); + return (x->a.a_displaced == Cnil ? Cnil : sLt); +} + +DEFUNO("ARRAY-RANK",int,fLarray_rank,LISP,1,1,NONE,IO,OO,OO, + OO,Larray_rank,"") + (x) + object x; +{ if (type_of(x) == t_array) + return x->a.a_rank; + IisArray(x); + return 1; +} + +DEFUNO("ARRAY-DIMENSION",int,fLarray_dimension,LISP,2,2, + NONE,IO,IO,OO,OO,Larray_dimension,"") + (x,i) + object x; int i; +{ + if (type_of(x) == t_array) + { if (i >= x->a.a_rank) FEerror("Index to large for array-dimension"); + else { return x->a.a_dims[i];}} + IisArray(x); + return x->v.v_dim; +} + +Icheck_displaced(displaced_list,ar,dim) + object displaced_list,ar; + int dim; +{ + while (displaced_list!=Cnil) + { object u = Mcar(displaced_list); + if (u->a.a_self == NULL) continue; + if ((Iarray_element_type(u) == aet_bit && + (u->bv.bv_self - ar->bv.bv_self)*BV_BITS +u->bv.bv_dim -dim + + u->bv.bv_offset - ar->bv.bv_offset > 0) + || (ARRAY_BODY_PTR(u,u->a.a_dim) > ARRAY_BODY_PTR(ar,dim))) + FEerror("Bad displacement",0); + Icheck_displaced(DISPLACED_FROM(u),ar,dim); + displaced_list = Mcdr(displaced_list); + } +} + +/* + (setq a (make-array 2 :displaced-to (setq b (make-array 4 )))) + { A->displ = (B), B->displ=(nil A)} +(setq w (make-array 3)) ;; w->displaced= (nil y u) +(setq y (make-array 2 :displaced-to w)) ;; y->displaced=(w z z2) +(setq u (make-array 2 :displaced-to w)) ;; u->displaced = (w) +(setq z (make-array 2 :displaced-to y)) ;; z->displaced = (y) +(setq z2 (make-array 2 :displaced-to y)) ;; z2->displaced= (y) + + + Destroy the displacement from AR + + */ +Iundisplace(ar) +object ar; +{ object *p,x; + + if ((x = DISPLACED_TO(ar)) == Cnil || + ar->a.a_displaced->d.m == FREE) + return; + {BEGIN_NO_INTERRUPT; + DISPLACED_TO(ar) = Cnil; + p = &(DISPLACED_FROM(x)) ; + /* walk through the displaced from list and delete AR */ + while(1) + { if ((*p)->d.m == FREE + || *p == Cnil) + goto retur; + if((Mcar(*p) == ar)) + { *p = Mcdr(*p); + goto retur;} + p = &(Mcdr(*p)); + } + retur: + END_NO_INTERRUPT; + return; + } +} + +DEFUNO("REPLACE-ARRAY",object,fSreplace_array,SI,2,2,NONE, + OO,OO,OO,OO,siLreplace_array,"") + (old,new) + object old,new; +{ struct dummy fw ; + fw = old->d; + + old = IisArray(old); + + if (TYPE_OF(old) != TYPE_OF(new) + || (TYPE_OF(old) == t_array && old->a.a_rank != new->a.a_rank)) + { FAIL: + FEerror("Cannot do array replacement ~a by ~a",2,old,new); + } + { int offset = new->ust.ust_self - old->ust.ust_self; + object old_list = DISPLACED_FROM(old); + object displaced = make_cons(DISPLACED_TO(new),DISPLACED_FROM(old)); + Icheck_displaced(DISPLACED_FROM(old),old,new->a.a_dim); + adjust_displaced(old,offset); +/* Iundisplace(old); */ + if (old->v.v_hasfillp) + { new->v.v_hasfillp = 1; + new->v.v_fillp = old->v.v_fillp;} + if (TYPE_OF(old) == t_string) + old->st = new->st; + else + old->a = new ->a; + + /* prevent having two arrays with the same body--which are not related + that would cause the gc to try to copy both arrays and there might + not be enough space. */ + new->a.a_dim = 0; + new->a.a_self = 0; + old->d = fw; + old->a.a_displaced = displaced; + } + return old; +} + +DEFUNO("ARRAY-TOTAL-SIZE",int,fLarray_total_size,LISP,1,1, + NONE,IO,OO,OO,OO,Larray_total_size,"") + (x) + object x; +{ x = IisArray(x); + return x->a.a_dim; +} + + +DEFUNO("ASET-BY-CURSOR",object,fSaset_by_cursor,SI,3,3, + NONE,OO,OO,OO,OO,siLaset_by_cursor,"")(array,val,cursor) +object array,val,cursor; +{ + object endp_temp; + object x; + int i; + object ind[ARRAY_RANK_LIMIT]; + /* 3 args */ + ind[0]=array; + ind[1]=(object) Mfix(MMcar(cursor)); + i = 2; + for (x = MMcdr(cursor); !endp(x); x = MMcdr(x)) + { ind[i++] = MMcar(x);} + ind[i]=val; + VFUN_NARGS=i+1; + c_apply_n(fSaset,i+1,ind); + RETURN1(array); +} + +init_array_function(){;} + + + + diff --git a/o/array.c1 b/o/array.c1 new file mode 100755 index 0000000..26a9641 --- /dev/null +++ b/o/array.c1 @@ -0,0 +1,1085 @@ +/* + Copyright (C) 1994 W. Schelter + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#include "include.h" + + +#define ARRAY_DIMENSION_LIMIT MOST_POSITIVE_FIXNUM + +DEFCONST("ARRAY-RANK-LIMIT", sLarray_rank_limit, LISP, + make_fixnum(ARRAY_RANK_LIMIT),""); + +DEFCONST("ARRAY-DIMENSION-LIMIT", sLarray_dimension_limit, + LISP, make_fixnum(MOST_POSITIVE_FIX),""); +DEFCONST("ARRAY-TOTAL-SIZE-LIMIT", sLarray_total_size_limit, + LISP, sLarray_dimension_limit,""); + +DEF_ORDINARY("BIT",sLbit,LISP,""); + +/* number of bits in unit of storage of x->bv.bv_self[0] */ + +#define BV_BITS 8 + +#define BITREF(x,i) \ + ((((1 << (BV_BITS -1)) >> (i % BV_BITS)) & (x->bv.bv_self[i/BV_BITS])) \ + ? 1 : 0) + +#define SET_BITREF(x,i) \ + (x->bv.bv_self[i/BV_BITS]) |= ((1 << (BV_BITS -1)) >> (i % BV_BITS)) +#define CLEAR_BITREF(x,i) \ + (x->bv.bv_self[i/BV_BITS]) &= ~(((1 << (BV_BITS -1)) >> (i % BV_BITS))) + +extern short aet_sizes[]; + +#define ARRAY_BODY_PTR(ar,n) \ + (void *)(ar->ust.ust_self + aet_sizes[Iarray_element_type(ar)]*n) + +#define N_FIXNUM_ARGS 6 + +DEFUNO("AREF", object, fLaref, LISP, 1, ARRAY_RANK_LIMIT, + NONE, OO, II, II, II,Laref,"") +(x, i, va_alist) + object x; + int i; + va_dcl +{ int n = VFUN_NARGS; + int i1; + va_list ap; + if (type_of(x) == t_array) + {int m,k ; + int rank = n - 1; + if (x->a.a_rank != rank) + FEerror(" ~a has wrong rank",1,x); + if (rank == 1) return fSaref1(x,i); + if (rank == 0) return fSaref1(x,0); + va_start(ap); + m = 0; + k = i; + /* index into 1 dimensional array */ + i1 = 0; + rank-- ; + while(1) + { + if (k >= x->a.a_dims[m]) + FEerror("Index ~a to array is too large",1,make_fixnum (m)); + i1 += k; + m ++; + if (m <= rank) + { i1 = i1 * x->a.a_dims[m]; + if (m < N_FIXNUM_ARGS) + { k = va_arg(ap,int);} + else {object x = va_arg(ap,object); + check_type(x,t_fixnum); + k = Mfix(x);} + + } + else break;} + va_end(ap); + return fSaref1(x,i1); + } + if (n > 2) + { FEerror("Too many args (~a) to aref",1,make_fixnum(n));} + return fSaref1(x,i); + +} + +int +fScheck_bounds_bounds(x, i) + object x; + int i; +{ + switch (type_of(x)) { + case t_array: + case t_vector: + case t_string: + if ((unsigned int) i >= x->a.a_dim) + FEerror("Array ref out of bounds ~a ~a", 2, x, make_fixnum(i)); + default: + FEerror("not an array"); + } +} + +DEFUN("SVREF", object, fLsvref, LISP, 2, 2, + ONE_VAL, OO, IO, OO,OO, + "For array X and index I it returns (aref x i) ") + (x, i) + object x; + unsigned int i; +{ + if (type_of(x)==t_vector + && (enum aelttype)x->v.v_elttype == aet_object + && x->v.v_dim > i) + RETURN1(x->v.v_self[i]); + if (x->v.v_dim > i) illegal_index(x,make_fixnum(i)); + FEerror("Bad simple vector ~a",1,x); +} + +DEFUN("AREF1", object, fSaref1, SI, 2, 2, + NONE, OO, IO, OO,OO, + "For array X and index I it returns (aref x i) as if x were \ +1 dimensional, even though its rank may be bigger than 1") +(x, i) + object x; + int i; +{ + switch (type_of(x)) { + case t_array: + case t_vector: + case t_bitvector: + if (x->v.v_dim <= i) + i = fScheck_bounds_bounds(x, i); + switch (x->v.v_elttype) { + case aet_object: + return x->v.v_self[i]; + case aet_ch: + return code_char(x->st.st_self[i]); + case aet_bit: + i += x->bv.bv_offset; + return make_fixnum(BITREF(x, i)); + case aet_fix: + return make_fixnum(x->fixa.fixa_self[i]); + case aet_sf: + return make_longfloat(x->sfa.sfa_self[i]); + case aet_lf: + return make_longfloat(x->lfa.lfa_self[i]); + case aet_char: + return make_fixnum(x->st.st_self[i]); + case aet_uchar: + return make_fixnum(x->ust.ust_self[i]); + case aet_short: + return make_fixnum(SHORT(x, i)); + case aet_ushort: + return make_fixnum(USHORT(x, i)); + + default: + FEerror("unknown array type"); + } + case t_string: + if (x->v.v_dim <= i) + i = fScheck_bounds_bounds(x, i); + return code_char(x->st.st_self[i]); + default: + FEerror("not an array"); + + ; + } +} + +DEFUN("ASET1", object, fSaset1, SI, 3, 3, NONE, OO, IO, OO,OO,"") +(x, i,val) + object x; + int i; + object val; +{ + switch (type_of(x)) { + case t_array: + case t_vector: + case t_bitvector: + if (x->v.v_dim <= i) + i = fScheck_bounds_bounds(x, i); + switch (x->v.v_elttype) { + case aet_object: + x->v.v_self[i] = val; + break; + case aet_ch: + ASSURE_TYPE(val,t_character); + x->st.st_self[i] = char_code(val); + break; + case aet_bit: + i += x->bv.bv_offset; + AGAIN_BIT: + ASSURE_TYPE(val,t_fixnum); + {int v = Mfix(val); + if (v == 0) CLEAR_BITREF(x,i); + else if (v == 1) SET_BITREF(x,i); + else {val= fSincorrect_type(val,sLbit); + goto AGAIN_BIT;} + break;} + case aet_fix: + ASSURE_TYPE(val,t_fixnum); + (x->fixa.fixa_self[i]) = Mfix(val); + break; + case aet_sf: + ASSURE_TYPE(val,t_shortfloat); + (x->sfa.sfa_self[i]) = Msf(val); + break; + case aet_lf: + ASSURE_TYPE(val,t_longfloat); + (x->lfa.lfa_self[i]) = Mlf(val); + break; + case aet_char: + ASSURE_TYPE(val,t_fixnum); + x->st.st_self[i] = Mfix(val); + break; + case aet_uchar: + ASSURE_TYPE(val,t_fixnum); + (x->ust.ust_self[i])= Mfix(val); + break; + case aet_short: + ASSURE_TYPE(val,t_fixnum); + SHORT(x, i) = Mfix(val); + break; + case aet_ushort: + ASSURE_TYPE(val,t_fixnum); + USHORT(x, i) = Mfix(val); + break; + default: + FEerror("unknown array type"); + } + break; + case t_string: + if (x->v.v_dim <= i) + i = fScheck_bounds_bounds(x, i); + ASSURE_TYPE(val,t_character); + x->st.st_self[i] = char_code(val); + break; + default: + FEerror("not an array",0); + } + return val; +} + +DEFUNO("ASET", object, fSaset, SI, 1, ARG_LIMIT, NONE, OO, + OO, OO, OO,siLaset,"") + (x,ii,y, va_alist) + object x,y; + object ii; + va_dcl +{ int i1; + int n = VFUN_NARGS; + int i; + va_list ap; + if (type_of(x) == t_array) + {int m,k ; + int rank = n - 2; + if (x->a.a_rank != rank) + FEerror(" ~a has wrong rank",x); + if (rank == 0) return fSaset1(x,0,ii); + ASSURE_TYPE(ii,t_fixnum); + i = fix(ii); + if (rank == 1) + return fSaset1(x,i,y); + va_start(ap); + m = 0; + k = i; + /* index into 1 dimensional array body */ + i1 = 0; + rank-- ; + while(1) + { + if (k >= x->a.a_dims[m]) + FEerror("Index ~a to array is too large",1,make_fixnum (m)); + i1 += k; + if (m < rank) + {object u; + if (m == 0) + { u = y;} + else + { u = va_arg(ap,object);} + check_type(u,t_fixnum); + k = Mfix(u); + m++ ; + i1 = i1 * x->a.a_dims[m]; + + } + else + { y = va_arg(ap,object); + break ;} + } + va_end(ap); + } + else + { ASSURE_TYPE(ii,t_fixnum); + i1 = fix(ii); + } + return fSaset1(x,i1,y); + +} + +DEFUNO("SVSET", object, fSsvset, SI, 3, 3, NONE, OO, IO, OO, + OO,siLsvset,"") + (x,i,val) + object x,val; + int i; +{ if (TYPE_OF(x) != t_vector + || DISPLACED_TO(x) != Cnil) + Wrong_type_error("simple array",0); + if (i > x->v.v_dim) + { FEerror("out of bounds",0); + } + return x->v.v_self[i] = val; +} + +/* +(proclaim '(ftype (function (fixnum fixnum t *)) make-vector1)) +(defun make-vector1 (n elt-type staticp &optional fillp initial-element + displaced-to (displaced-index-offset 0)) + (declare (fixnum n elt-type displaced-index-offset)) +*/ + + +DEFUN("MAKE-VECTOR1",object,fSmake_vector1,SI,3,8,NONE,OI, + IO,OO,OO,"") + (n,elt_type,staticp,va_alist) +int n;int elt_type;object staticp;va_dcl +{ + int displaced_index_offset; + int Inargs = VFUN_NARGS - 3; + va_list Iap;object fillp;object initial_element;object displaced_to;object V9; + object V10,V11,V12,V13,V14; + Inargs = VFUN_NARGS - 3 ; + { object x; + BEGIN_NO_INTERRUPT; + switch(elt_type) { + case aet_ch: + x = alloc_object(t_string); + goto a_string; + break; + case aet_bit: + x = alloc_object(t_bitvector); + break; + default: + x = alloc_object(t_vector);} + x->v.v_elttype = elt_type; + a_string: + x->v.v_dim = n; + x->v.v_self = 0; + x->v.v_displaced = Cnil; + + if( --Inargs < 0)goto LA1; + else { + va_start(Iap); + fillp=va_arg(Iap,object); + if (fillp == Cnil) + {x->v.v_hasfillp = 0; + x->v.v_fillp = n; + } + else + if(type_of(fillp) == t_fixnum) + { + x->v.v_fillp = Mfix(fillp); + if (x->v.v_fillp > n) FEerror("bad fillp",0); + x->v.v_hasfillp = 1; + } + else + { + x->v.v_fillp = n; + x->v.v_hasfillp = 1; + } + + } + + if( --Inargs < 0)goto LA2; + else { + initial_element=va_arg(Iap,object);} + + if( --Inargs < 0)goto LA4; + else { + displaced_to=va_arg(Iap,object);} + + if( --Inargs < 0)goto LA5; + else { + V9=va_arg(Iap,object); + if (displaced_to != Cnil) + { + ASSURE_TYPE(V9,t_fixnum); + displaced_index_offset=Mfix(V9);}} + goto LA6; + + LA1: + x->v.v_hasfillp = 0; + x->v.v_fillp = n; + LA2: + initial_element=Cnil; + LA4: + displaced_to=Cnil; + LA5: + displaced_index_offset= 0; + LA6: + x->v.v_adjustable = 1; + va_end(Iap); + { if (displaced_to == Cnil) + array_allocself(x,staticp!=Cnil,initial_element); + else { displace(x,displaced_to,displaced_index_offset);} + END_NO_INTERRUPT; + + return x; + } + } + } + + + +static object DFLT_aet_object = Cnil; +static char DFLT_aet_ch = ' '; +static char DFLT_aet_char = 0; +static int DFLT_aet_fix = 0 ; +static short DFLT_aet_short = 0; +static shortfloat DFLT_aet_sf = 0.0; +static longfloat DFLT_aet_lf = 0.0; +static object Iname_t = sLt; +struct { char * dflt; object *namep;} aet_types[] = +{ (char *) &DFLT_aet_object, &Iname_t, /* t */ + (char *) &DFLT_aet_ch, &sLstring_char,/* string-char */ + (char *) &DFLT_aet_fix, &sLbit, /* bit */ + (char *) &DFLT_aet_fix, &sLfixnum, /* fixnum */ + (char *) &DFLT_aet_sf, &sLshort_float, /* short-float */ + (char *) &DFLT_aet_lf, &sLlong_float, /* long-float */ + (char *) &DFLT_aet_char,&sLsigned_char, /* signed char */ + (char *) &DFLT_aet_char,&sLunsigned_char, /* unsigned char */ + (char *) &DFLT_aet_short,&sLsigned_short, /* signed short */ + (char *) &DFLT_aet_short, &sLunsigned_short /* unsigned short */ + }; + +DEFUN("GET-AELTTYPE",enum aelttype,fSget_aelttype,SI,1,1,NONE,IO,OO,OO,OO,"") + (x) +object x; +{ int i; + for (i=0 ; i < aet_last ; i++) + if (x == * aet_types[i].namep) + return (enum aelttype) i; + if (x == sLlong_float || x == sLsingle_float || x == sLdouble_float) + return aet_lf; + return aet_object; +} + +/* backward compatibility only: + (si:make-vector element-type 0 + dimension 1 + adjustable 2 + fill-pointer 3 + displaced-to 4 + displaced-index-offset 5 + static 6 &optional initial-element) +*/ +DEFUNO("MAKE-VECTOR",object,fSmake_vector,SI,7,8,NONE, + OO,OO,OO,OO,siLmake_vector,"")(x0,x1,x2,x3,x4,x5,x6,va_alist) +object x0,x1,x2,x3,x4,x5,x6; +va_dcl +{int narg=VFUN_NARGS; + object initial_elt; + va_list ap; + object x; + {va_start(ap); + if (narg>=8) initial_elt=va_arg(ap,object);else goto LDEFAULT8; + goto LEND_VARARG; + LDEFAULT8: initial_elt = Cnil ; + LEND_VARARG: va_end(ap);} + + /* 8 args */ + + VFUN_NARGS = 8; + x = fSmake_vector1(Mfix(x1), /* n */ + fSget_aelttype(x0), /*aelt type */ + x6, /* staticp */ + x3, /* fillp */ + initial_elt, /* initial element */ + x4, /*displaced to */ + x5); /* displaced-index offset */ + x0 = x; + RETURN1(x0); +} + +/* +(proclaim '(ftype (function (fixnum t *)) make-array1)) +(defun make-array1 ( elt-type staticp initial-element + displaced-to displaced-index-offset &optional dim1 dim2 .. ) + (declare (fixnum n elt-type displaced-index-offset)) +*/ + +DEFUN("MAKE-ARRAY1",object,fSmake_array1,SI,6,6, + NONE,OI,OO,OI,OO,"") + (elt_type,staticp,initial_element,displaced_to, displaced_index_offset, + dimensions) + int elt_type; + object staticp,initial_element,displaced_to; + int displaced_index_offset; + object dimensions; +{ + int rank = length(dimensions); + { object x,v; + char *tmp_alloc; + int dim =1,i; + BEGIN_NO_INTERRUPT; + x = alloc_object(t_array); + x->a.a_elttype = elt_type; + x->a.a_self = 0; + x->a.a_rank = rank; + x->a.a_displaced = Cnil; + x->a.a_dims = AR_ALLOC(alloc_relblock,rank,int); + i = 0; + v = dimensions; + while (i < rank) + { x->a.a_dims[i] = FIX_CHECK(Mcar(v)); + dim *= x->a.a_dims[i++]; + v = Mcdr(v);} + x->a.a_dim = dim; + x->a.a_adjustable = 1; + { if (displaced_to == Cnil) + array_allocself(x,staticp!=Cnil,initial_element); + else { displace(x,displaced_to,displaced_index_offset);} + END_NO_INTERRUPT; + return x; + } + }} + + + + + + + + +/* + (setq a (make-array 2 :displaced-to (setq b (make-array 4 )))) + ;{ A->displ = (B), B->displ=(nil A)} +(setq w (make-array 3)) ;; w->displaced= (nil y u) +(setq y (make-array 2 :displaced-to w)) ;; y->displaced=(w z z2) +(setq u (make-array 2 :displaced-to w)) ;; u->displaced = (w) +(setq z (make-array 2 :displaced-to y)) ;; z->displaced = (y) +(setq z2 (make-array 2 :displaced-to y)) ;; z2->displaced= (y) +*/ + +displace(from_array,dest_array,offset) + object from_array,dest_array; + int offset; +{ + enum aelttype typ; + IisArray(from_array); + IisArray(dest_array); + typ =Iarray_element_type(from_array); + if (typ != Iarray_element_type(dest_array)) + { Wrong_type_error("same element type",0); + } + if (offset + from_array->a.a_dim > dest_array->a.a_dim) + { FEerror("Destination array too small to hold other array",0); + } + /* ensure that we have a cons */ + if (dest_array->a.a_displaced == Cnil) + { dest_array->a.a_displaced = list(2,Cnil,from_array);} + else + Mcdr(dest_array->a.a_displaced) = make_cons(from_array, + Mcdr(dest_array->a.a_displaced)); + from_array->a.a_displaced = make_cons(dest_array,sLnil); + + /* now set the actual body of from_array to be the address + of body in dest_array. If it is a bit array, this cannot carry the + offset information, since the body is only recorded as multiples of + BV_BITS + */ + + + if (typ == aet_bit) + { offset += dest_array->bv.bv_offset; + from_array->bv.bv_self = dest_array->bv.bv_self + offset/BV_BITS; + from_array->bv.bv_offset = offset % BV_BITS; + } + else + from_array->a.a_self = ARRAY_BODY_PTR(dest_array,offset); + +} + + + +enum aelttype +Iarray_element_type(x) + object x; +{enum aelttype t; + switch(TYPE_OF(x)) + { case t_array: + t = (enum aelttype) x->a.a_elttype; + break; + case t_vector: + t = (enum aelttype) x->v.v_elttype; + break; + case t_bitvector: + t = aet_bit; + break; + case t_string: + t = aet_ch; + break; + default: + FEerror("Not an array ~a ",1,x); + } + return t; +} + + /* Make the body of FROM array point to the body of TO + at the DISPLACED_INDEX_OFFSET + */ + +Idisplace_array(from,to,displaced_index_offset) + object from,to; + int displaced_index_offset; +{ + enum aelttype t1,t2; + object tail; + t1 = Iarray_element_type(from); + t2 = Iarray_element_type(to); + if (t1 != t2) + FEerror("Attempt to displace arrays of one type to arrays of another type",0); + if (to->a.a_dim > from->a.a_dim - displaced_index_offset) + FEerror("To array not large enough for displacement",0); + {BEGIN_NO_INTERRUPT; + from->a.a_displaced = make_cons(to,Cnil); + if (to->a.a_displaced == Cnil) + to->a.a_displaced = make_cons(Cnil,Cnil); + DISPLACED_FROM(to) = make_cons(from,DISPLACED_FROM(to)); + + if (t1 == aet_bit) { + displaced_index_offset += to->bv.bv_offset; + from->bv.bv_self = to->bv.bv_self + displaced_index_offset/BV_BITS; + from->bv.bv_offset = displaced_index_offset%BV_BITS; + } + else + from->st.st_self = ARRAY_BODY_PTR(to,displaced_index_offset); + END_NO_INTERRUPT; + } + +} + +/* add diff to body of x and arrays diisplaced to it */ + +adjust_displaced(x, diff) +object x; +int diff; +{ + if (x->ust.ust_self != NULL) + x->ust.ust_self = (char *)((int)(x->a.a_self) + diff); + for (x = Mcdr(x->ust.ust_displaced); x != Cnil; x = Mcdr(x)) + adjust_displaced(Mcar(x), diff); +} + + + + + /* RAW_AET_PTR returns a pointer to something of raw type obtained from X + suitable for using GSET for an array of elt type TYP. + If x is the null pointer, return a default for that array element + type. + */ + +char * +raw_aet_ptr(x,typ) + short typ; + object x; +{ /* doubles are the largest raw type */ + static double u; + if (x==Cnil) return aet_types[typ].dflt; + switch (typ){ +#define STORE_TYPED(pl,type,val) *((type *) pl) = (type) val; break; + case aet_object: STORE_TYPED(&u,object,x); + case aet_ch: STORE_TYPED(&u,char, char_code(x)); + case aet_bit: STORE_TYPED(&u,fixnum, -Mfix(x)); + case aet_fix: STORE_TYPED(&u,fixnum, Mfix(x)); + case aet_sf: STORE_TYPED(&u,shortfloat, Msf(x)); + case aet_lf: STORE_TYPED(&u,longfloat, Mlf(x)); + case aet_char: STORE_TYPED(&u, char, Mfix(x)); + case aet_uchar: STORE_TYPED(&u, unsigned char, Mfix(x)); + case aet_short: STORE_TYPED(&u, short, Mfix(x)); + case aet_ushort: STORE_TYPED(&u,unsigned short,Mfix(x)); + default: FEerror("bad elttype",0); + } + return (char *)&u; +} + + + /* GSET copies into array ptr P1, the value + pointed to by the ptr VAL into the next N slots. The + array type is typ. If VAL is the null ptr, use + the default for that element type + NOTE: for type aet_bit n is the number of Words + ie (nbits +WSIZE-1)/WSIZE and the words are set. + */ + +gset(p1,val,n,typ) + char *p1,*val; + int n; + int typ; +{ if (val==0) + val = aet_types[typ].dflt; + switch (typ){ + +#define GSET(p,n,typ,val) {typ x = *((typ *) val); GSET1(p,n,typ,x)} +#define GSET1(p,n,typ,val) while (n-- > 0) \ + { *((typ *) p) = val; \ + p = p + sizeof(typ); \ + } break; + + case aet_object: GSET(p1,n,object,val); + case aet_ch: GSET(p1,n,char,val); + /* Note n is number of fixnum WORDS for bit */ + case aet_bit: GSET(p1,n,fixnum,val); + case aet_fix: GSET(p1,n,fixnum,val); + case aet_sf: GSET(p1,n,shortfloat,val); + case aet_lf: GSET(p1,n,longfloat,val); + case aet_char: GSET(p1,n,char,val); + case aet_uchar: GSET(p1,n,unsigned char,val); + case aet_short: GSET(p1,n,short,val); + case aet_ushort: GSET(p1,n,unsigned short,val); + default: FEerror("bad elttype",0); + } + } + + +#define W_SIZE (BV_BITS*sizeof(fixnum)) + + /* + */ + +DEFUN("COPY-ARRAY-PORTION",object,fScopy_array_portion,SI,4, + 5,NONE,OO,OI,II,OO, + "Copy elements from X to Y starting at x[i1] to x[i2] and doing N1 \ +elements if N1 is supplied otherwise, doing the length of X - I1 \ +elements. If the types of the arrays are not the same, this has \ +implementation dependent results.") + (x,y,i1,i2,n1) + object x,y; int i1,i2,n1; +{ enum aelttype typ1=Iarray_element_type(x); + enum aelttype typ2=Iarray_element_type(y); + int nc; + if (VFUN_NARGS==4) + { n1 = x->v.v_dim - i1;} + if (typ1==aet_bit) + {if (i1 % CHAR_SIZE) + badcopy: + FEerror("Bit copies only if aligned"); + else + {int rest=n1%CHAR_SIZE; + if (rest!=0 ) + {if (typ2!=aet_bit) + goto badcopy; + {while(rest> 0) + { fSaset1(y,i2+n1-rest,(fSaref1(x,i1+n1-rest))); + rest--;} + }} + i1=i1/CHAR_SIZE ; + n1=n1/CHAR_SIZE; + typ1=aet_char; + }}; + if (typ2==aet_bit) + {if (i2 % CHAR_SIZE) + goto badcopy; + i2=i2/CHAR_SIZE ;} + if ((typ1 ==aet_object || + typ2 ==aet_object) && typ1 != typ2) + FEerror("Can't copy between different array types"); + nc=n1 * aet_sizes[(int)typ1]; + if (i1+n1 > x->a.a_dim + || ((y->a.a_dim - i2) *aet_sizes[(int)typ2]) < nc) + FEerror("Copy out of bounds"); + bcopy(x->ust.ust_self + (i1*aet_sizes[(int)typ1]), + y->ust.ust_self + (i2*aet_sizes[(int)typ2]), + nc); + return x; +} + +/* X is the header of an array. This supplies the body which + will not be relocatable if STATICP. If DFLT is 0, do not + initialize (the caller promises to reset these before the + next gc!). If DFLT == Cnil then initialize to default type + for this array type. Otherwise DFLT is an object and its + value is used to init the array */ + +array_allocself(x, staticp, dflt) +object x,dflt; +int staticp; +{ + int i, d,n; + char *(*fun)(),*tmp_alloc; + enum aelttype typ; + fun = (staticp ? alloc_contblock : alloc_relblock); + { /* this must be called from within no interrupt code */ + n = x->a.a_dim; + typ = Iarray_element_type(x); + switch (typ) { + case aet_object: + x->a.a_self = AR_ALLOC(*fun,n,object); + break; + case aet_ch: + case aet_char: + case aet_uchar: + x->st.st_self = AR_ALLOC(*fun,n,char); + break; + case aet_short: + case aet_ushort: + x->ust.ust_self = (unsigned char *) AR_ALLOC(*fun,n,short); + break; + case aet_bit: + n = (n+W_SIZE-1)/W_SIZE; + x->bv.bv_offset = 0; + case aet_fix: + x->fixa.fixa_self = AR_ALLOC(*fun,n,fixnum); + break; + case aet_sf: + x->sfa.sfa_self = AR_ALLOC(*fun,n,shortfloat); + break; + case aet_lf: + x->lfa.lfa_self = AR_ALLOC(*fun,n,longfloat); + break; + } + if(dflt!=0) gset(x->st.st_self,raw_aet_ptr(dflt,typ),n,typ); + } + +} + +DEFUNO("FILL-POINTER-SET",int,fSfill_pointer_set,SI,2,2, + NONE,IO,IO,OO,OO,siLfill_pointer_set,"") + (x,i) + object x; + int i; +{ + + if (!(TS_MEMBER(type_of(x),TS(t_vector)| + TS(t_bitvector)| + TS(t_string)))) + goto no_fillp; + if (x->v.v_hasfillp == 0) + { goto no_fillp;} + if (i < 0 || i > x->a.a_dim) + { FEerror("~a is not suitable for a fill pointer for ~a",2,make_fixnum(i),x);} + x->v.v_fillp = i; + return i; + + no_fillp: + FEerror("~a does not have a fill pointer",1,x); + + return 0; +} + +DEFUNO("FILL-POINTER",int,fLfill_pointer,LISP,1,1,NONE,IO, + OO,OO,OO,Lfill_pointer,"") + (x) + object x; +{ + if (!(TS_MEMBER(type_of(x),TS(t_vector)| + TS(t_bitvector)| + TS(t_string)))) + goto no_fillp; + if (x->v.v_hasfillp == 0) + { goto no_fillp;} + return x->v.v_fillp ; + + no_fillp: + FEerror("~a does not have a fill pointer",1,x); + return 0; +} + +DEFUN("ARRAY-HAS-FILL-POINTER-P",object, + fLarray_has_fill_pointer_p,LISP,1,1,NONE,OO,OO,OO,OO,"") + (x) + object x; +{ + if (TS_MEMBER(type_of(x),TS(t_vector)| + TS(t_bitvector)| + TS(t_string))) + return (x->v.v_hasfillp == 0 ? Cnil : sLt); + else + if (TYPE_OF(x) == t_array) + { return Cnil;} + else IisArray(x); + return Cnil; +} + + + +/* DEFUN("MAKE-ARRAY-INTERNAL",object,fSmake_array_internal,SI,0,0,NONE,OO,OO,OO,OO) + (element_type,adjustable,displaced_to,displaced_index_offset,static,initial_element,dimensions) + object element_type,adjustable,displaced_to,displaced_index_offset,static,initial_element,dimensions; + +*/ + +DEFUNO("ARRAY-ELEMENT-TYPE",object,fLarray_element_type, + LISP,1,1,NONE,OO,OO,OO,OO,Larray_element_type,"") + (x) + object x; +{ enum aelttype t; + t = Iarray_element_type(x); + return * aet_types[(int)t].namep; +} + +DEFUNO("ADJUSTABLE-ARRAY-P",object,fLadjustable_array_p, + LISP,1,1,NONE,OO,OO,OO,OO,Ladjustable_array_p,"") + (x) + object x; +{ return sLt; +} + +DEFUNO("DISPLACED-ARRAY-P",object,fSdisplaced_array_p,SI,1, + 1,NONE,OO,OO,OO,OO,siLdisplaced_array_p,"") + (x) + object x; +{ IisArray(x); + return (x->a.a_displaced == Cnil ? Cnil : sLt); +} + +DEFUNO("ARRAY-RANK",int,fLarray_rank,LISP,1,1,NONE,IO,OO,OO, + OO,Larray_rank,"") + (x) + object x; +{ if (type_of(x) == t_array) + return x->a.a_rank; + IisArray(x); + return 1; +} + +DEFUNO("ARRAY-DIMENSION",int,fLarray_dimension,LISP,2,2, + NONE,IO,IO,OO,OO,Larray_dimension,"") + (x,i) + object x; int i; +{ + if (type_of(x) == t_array) + { if (i >= x->a.a_rank) FEerror("Index to large for array-dimension"); + else { return x->a.a_dims[i];}} + IisArray(x); + return x->v.v_dim; +} + +Icheck_displaced(displaced_list,ar,dim) + object displaced_list,ar; + int dim; +{ + while (displaced_list!=Cnil) + { object u = Mcar(displaced_list); + if (u->a.a_self == NULL) continue; + if ((Iarray_element_type(u) == aet_bit && + (u->bv.bv_self - ar->bv.bv_self)*BV_BITS +u->bv.bv_dim -dim + + u->bv.bv_offset - ar->bv.bv_offset > 0) + || (ARRAY_BODY_PTR(u,u->a.a_dim) > ARRAY_BODY_PTR(ar,dim))) + FEerror("Bad displacement",0); + Icheck_displaced(DISPLACED_FROM(u),ar,dim); + displaced_list = Mcdr(displaced_list); + } +} + +/* + (setq a (make-array 2 :displaced-to (setq b (make-array 4 )))) + { A->displ = (B), B->displ=(nil A)} +(setq w (make-array 3)) ;; w->displaced= (nil y u) +(setq y (make-array 2 :displaced-to w)) ;; y->displaced=(w z z2) +(setq u (make-array 2 :displaced-to w)) ;; u->displaced = (w) +(setq z (make-array 2 :displaced-to y)) ;; z->displaced = (y) +(setq z2 (make-array 2 :displaced-to y)) ;; z2->displaced= (y) + + + Destroy the displacement from AR + + */ +Iundisplace(ar) +object ar; +{ object *p,x; + + if ((x = DISPLACED_TO(ar)) == Cnil || + ar->a.a_displaced->d.m == FREE) + return; + {BEGIN_NO_INTERRUPT; + DISPLACED_TO(ar) = Cnil; + p = &(DISPLACED_FROM(x)) ; + /* walk through the displaced from list and delete AR */ + while(1) + { if ((*p)->d.m == FREE + || *p == Cnil) + goto retur; + if((Mcar(*p) == ar)) + { *p = Mcdr(*p); + goto retur;} + p = &(Mcdr(*p)); + } + retur: + END_NO_INTERRUPT; + return; + } +} + +DEFUNO("REPLACE-ARRAY",object,fSreplace_array,SI,2,2,NONE, + OO,OO,OO,OO,siLreplace_array,"") + (old,new) + object old,new; +{ struct dummy fw ; + fw = old->d; + + old = IisArray(old); + + if (TYPE_OF(old) != TYPE_OF(new) + || (TYPE_OF(old) == t_array && old->a.a_rank != new->a.a_rank)) + { FAIL: + FEerror("Cannot do array replacement ~a by ~a",2,old,new); + } + { int offset = new->ust.ust_self - old->ust.ust_self; + object old_list = DISPLACED_FROM(old); + object displaced = make_cons(DISPLACED_TO(new),DISPLACED_FROM(old)); + Icheck_displaced(DISPLACED_FROM(old),old,new->a.a_dim); + adjust_displaced(old,offset); +/* Iundisplace(old); */ + if (old->v.v_hasfillp) + { new->v.v_hasfillp = 1; + new->v.v_fillp = old->v.v_fillp;} + if (TYPE_OF(old) == t_string) + old->st = new->st; + else + old->a = new ->a; + + /* prevent having two arrays with the same body--which are not related + that would cause the gc to try to copy both arrays and there might + not be enough space. */ + new->a.a_dim = 0; + new->a.a_self = 0; + old->d = fw; + old->a.a_displaced = displaced; + } + return old; +} + +DEFUNO("ARRAY-TOTAL-SIZE",int,fLarray_total_size,LISP,1,1, + NONE,IO,OO,OO,OO,Larray_total_size,"") + (x) + object x; +{ x = IisArray(x); + return x->a.a_dim; +} + + +DEFUNO("ASET-BY-CURSOR",object,fSaset_by_cursor,SI,3,3, + NONE,OO,OO,OO,OO,siLaset_by_cursor,"")(array,val,cursor) +object array,val,cursor; +{ + object endp_temp; + object x; + int i; + object ind[ARRAY_RANK_LIMIT]; + /* 3 args */ + ind[0]=array; + if (cursor==sLnil) {fSaset1(array,0,val); RETURN1(array);} + ind[1]=MMcar(cursor); + i = 2; + for (x = MMcdr(cursor); !endp(x); x = MMcdr(x)) + { ind[i++] = MMcar(x);} + ind[i]=val; + VFUN_NARGS=i+1; + c_apply_n(fSaset,i+1,ind); + RETURN1(array); +} + +init_array_function(){;} + + + + diff --git a/o/assignment.c b/o/assignment.c new file mode 100755 index 0000000..c592259 --- /dev/null +++ b/o/assignment.c @@ -0,0 +1,604 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +/* + + assignment.c + + Assignment +*/ + +#include "include.h" + +static object +setf(object,object); + +object sLsetf; + +object sLget; +object sLgetf; +object sLaref; +object sLsvref; +object sLelt; +object sLchar; +object sLschar; +object sLfill_pointer; +object sLgethash; +object sLcar; +object sLcdr; + +object sLpush; +object sLpop; +object sLincf; +object sLdecf; + +object sSstructure_access; +object sSsetf_lambda; + + + +object sSclear_compiler_properties; + +object sLwarn; + +object sSAinhibit_macro_specialA; + +void +setq(object sym, object val) +{ + object vd; + enum stype type; + + if(type_of(sym) != t_symbol) + not_a_symbol(sym); + type = (enum stype)sym->s.s_stype; + if(type == stp_special) + sym->s.s_dbind = val; + else + if (type == stp_constant) + FEinvalid_variable("Cannot assign to the constant ~S.", sym); + else { + vd = lex_var_sch(sym); + if(MMnull(vd) || endp(MMcdr(vd))) + sym->s.s_dbind = val; + else + MMcadr(vd) = val; + } +} + +static void +FFN(Fsetq)(object form) +{ + object ans; + if (endp(form)) { + vs_base = vs_top; + vs_push(Cnil); + } else { + object *top = vs_top; + do { + vs_top = top; + if (endp(MMcdr(form))) + FEinvalid_form("No value for ~S.", form->c.c_car); + setq(MMcar(form),ans=Ieval(MMcadr(form))); + form = MMcddr(form); + } while (!endp(form)); + top[0]=ans; + vs_base=top; + vs_top= top+1; + } +} + +static void +FFN(Fpsetq)(object arg) +{ + object *old_top = vs_top; + object *top; + object argsv = arg; + for (top = old_top; !endp(arg); arg = MMcddr(arg), top++) { + if(endp(MMcdr(arg))) + FEinvalid_form("No value for ~S.", arg->c.c_car); + + top[0] = Ieval(MMcadr(arg)); + vs_top = top + 1; + } + for (arg = argsv, top = old_top; !endp(arg); arg = MMcddr(arg), top++) + setq(MMcar(arg),top[0]); + vs_base = vs_top = old_top; + vs_push(Cnil); +} + +DEFUNO_NEW("SET",object,fLset,LISP + ,2,2,NONE,OO,OO,OO,OO,void,Lset,(object symbol,object value),"") + +{ + /* 2 args */ + if (type_of(symbol) != t_symbol) + not_a_symbol(symbol); + if ((enum stype)symbol->s.s_stype == stp_constant) + FEinvalid_variable("Cannot assign to the constant ~S.", + symbol); + symbol->s.s_dbind = value; + RETURN1(value); +} + +DEFUNO_NEW("FSET",object,fSfset,SI + ,2,2,NONE,OO,OO,OO,OO,void,siLfset,(object sym,object function),"") + +{ + /* 2 args */ + if (type_of(sym) != t_symbol) + not_a_symbol(sym); + if (sym->s.s_sfdef != NOT_SPECIAL) { + if (sym->s.s_mflag) { + if (symbol_value(sSAinhibit_macro_specialA) != Cnil) + sym->s.s_sfdef = NOT_SPECIAL; + } else if (symbol_value(sSAinhibit_macro_specialA) != Cnil) + FEerror("~S, a special form, cannot be redefined.", + 1, sym); + } + sym = clear_compiler_properties(sym,function); + if (sym->s.s_hpack == lisp_package && + sym->s.s_gfdef != OBJNULL && !raw_image) { + ifuncall2(sLwarn,make_simple_string("~S is being redefined."), + sym); + } + if (type_of(function) == t_cfun || + type_of(function) == t_sfun || + type_of(function) == t_vfun || + type_of(function) == t_gfun || + type_of(function) == t_cclosure|| + type_of(function) == t_closure || + type_of(function) == t_afun + ) { + sym->s.s_gfdef = function; + sym->s.s_mflag = FALSE; + } else if (car(function) == sLspecial) + FEerror("Cannot define a special form.", 0); + else if (function->c.c_car == sLmacro) { + sym->s.s_gfdef = function->c.c_cdr; + sym->s.s_mflag = TRUE; + } else { + sym->s.s_gfdef = function; + sym->s.s_mflag = FALSE; + } + + RETURN1(function); +} +#ifdef STATIC_FUNCTION_POINTERS +object +fSfset(object sym,object function) { + return FFN(fSfset)(sym,function); +} +#endif + +static void +FFN(Fmultiple_value_setq)(object form) +{ + object vars; + int n, i; + + if (endp(form) || endp(form->c.c_cdr) || + !endp(form->c.c_cdr->c.c_cdr)) + FEinvalid_form("~S is an illegal argument to MULTIPLE-VALUE-SETQ", + form); + vars = form->c.c_car; + + fcall.values[0]=Ieval(form->c.c_cdr->c.c_car); + n = fcall.nvalues; + + for (i = 0; !endp(vars); i++, vars = vars->c.c_cdr) + if (i < n) + setq(vars->c.c_car, fcall.values[i]); + else + setq(vars->c.c_car, Cnil); + vs_base[0]=fcall.values[0]; + vs_top = vs_base+1; +} + +DEFUNO_NEW("MAKUNBOUND",object,fLmakunbound,LISP + ,1,1,NONE,OO,OO,OO,OO,void,Lmakunbound,(object sym),"") + +{ + /* 1 args */ + if (type_of(sym) != t_symbol) + not_a_symbol(sym); + if ((enum stype)sym->s.s_stype == stp_constant) + FEinvalid_variable("Cannot unbind the constant ~S.", + sym); + sym->s.s_dbind = OBJNULL; + RETURN1(sym); +} + +object sStraced; + +DEFUNO_NEW("FMAKUNBOUND",object,fLfmakunbound,LISP + ,1,1,NONE,OO,OO,OO,OO,void,Lfmakunbound,(object sym),"") + +{ + /* 1 args */ + if(type_of(sym) != t_symbol) + not_a_symbol(sym); + if (sym->s.s_sfdef != NOT_SPECIAL) { + if (sym->s.s_mflag) { + if (symbol_value(sSAinhibit_macro_specialA) != Cnil) + sym->s.s_sfdef = NOT_SPECIAL; + } else if (symbol_value(sSAinhibit_macro_specialA) != Cnil) + FEerror("~S, a special form, cannot be redefined.", + 1, sym); + } + remf(&(sym->s.s_plist),sStraced); + clear_compiler_properties(sym,Cnil); + if (sym->s.s_hpack == lisp_package && + sym->s.s_gfdef != OBJNULL && !raw_image) { + ifuncall2(sLwarn, make_simple_string( + "~S is being redefined."), sym); + } + sym->s.s_gfdef = OBJNULL; + sym->s.s_mflag = FALSE; + RETURN1(sym); +} + +static void +FFN(Fsetf)(object form) +{ + object result,*t,*t1; + if (endp(form)) { + vs_base = vs_top; + vs_push(Cnil); + } else { + object *top = vs_top; + do { + vs_top = top; + if (endp(MMcdr(form))) + FEinvalid_form("No value for ~S.", form->c.c_car); + result = setf(MMcar(form), MMcadr(form)); + form = MMcddr(form); + } while (!endp(form)); + t=vs_base; + t1=vs_top; + vs_top = vs_base = top; + for (;tc.c_car; + if (type_of(fun) != t_symbol) + goto OTHERWISE; + args = place->c.c_cdr; + if (fun == sLget) { + object sym,val,key; + sym = Ieval(car(args)); + key = Ieval(car(Mcdr(args))); + val = Ieval(form); + return putprop(sym,val,key); + } + if (fun == sLgetf) + Ieval(Mcaddr(args)); + if (fun == sLaref) { f = siLaset; goto EVAL; } + if (fun == sLsvref) { f = siLsvset; goto EVAL; } + if (fun == sLelt) { f = siLelt_set; goto EVAL; } + if (fun == sLchar) { f = siLchar_set; goto EVAL; } + if (fun == sLschar) { f = siLchar_set; goto EVAL; } + if (fun == sLfill_pointer) { f = siLfill_pointer_set; goto EVAL; } + if (fun == sLgethash) { f = siLhash_set; goto EVAL; } + if (fun == sLcar) { + x = Ieval(Mcar(args)); + result = Ieval(form); + if (type_of(x) != t_cons) + FEerror("~S is not a cons.", 1, x); + Mcar(x) = result; + return result; + } + if (fun == sLcdr) { + x = Ieval(Mcar(args)); + result = Ieval(form); + if (type_of(x) != t_cons) + FEerror("~S is not a cons.", 1, x); + Mcdr(x) = result; + return result; + } + + x = getf(fun->s.s_plist, sSstructure_access, Cnil); + if (x == Cnil || type_of(x) != t_cons) + goto OTHERWISE; + if (getf(fun->s.s_plist, sSsetf_lambda, Cnil) == Cnil) + goto OTHERWISE; + if (type_of(x->c.c_cdr) != t_fixnum) + goto OTHERWISE; + i = fix(x->c.c_cdr); +/* + if (i < 0) + goto OTHERWISE; +*/ + x = x->c.c_car; + y = Ieval(Mcar(args)); + result = Ieval(form); + if (x == sLvector) { + if (type_of(y) != t_vector || i >= y->v.v_fillp) + goto OTHERWISE; + y->v.v_self[i] = result; + } else if (x == sLlist) { + for (x = y; i > 0; --i) + x = cdr(x); + if (type_of(x) != t_cons) + goto OTHERWISE; + x->c.c_car = result; + } else { + structure_set(y, x, i, result); + } + return result; + +EVAL: + for (; !endp(args); args = args->c.c_cdr) { + eval_push(args->c.c_car); + } + eval_push(form); + vs_base = vs; + (*f)(); + return vs_base[0]; + +OTHERWISE: + vs_base = vs_top; + vs_push(sLsetf); + vs_push(place); + vs_push(form); + result=vs_top[-1]; + vs_push(Cnil); + stack_cons(); + stack_cons(); + stack_cons(); +/***/ +#define VS_PUSH_ENV \ + if(lex_env[1]){ \ + vs_push(list(3,lex_env[0],lex_env[1],lex_env[2]));} \ + else {vs_push(Cnil);} + VS_PUSH_ENV ; +/***/ + if (!sLsetf->s.s_mflag || sLsetf->s.s_gfdef == OBJNULL) + FEerror("Where is SETF?", 0); + funcall(sLsetf->s.s_gfdef); + return Ieval(vs_base[0]); +} + +static void +FFN(Fpush)(object form) +{ + object var; + + if (endp(form) || endp(MMcdr(form))) + FEtoo_few_argumentsF(form); + if (!endp(MMcddr(form))) + FEtoo_many_argumentsF(form); + var = MMcadr(form); + if (type_of(var) != t_cons) { + eval(MMcar(form)); + form = vs_base[0]; + eval(var); + vs_base[0] = MMcons(form, vs_base[0]); + setq(var, vs_base[0]); + return; + } + vs_base = vs_top; + vs_push(sLpush); + vs_push(form); + stack_cons(); +/***/ + VS_PUSH_ENV ; +/***/ + if (!sLpush->s.s_mflag || sLpush->s.s_gfdef == OBJNULL) + FEerror("Where is PUSH?", 0); + funcall(sLpush->s.s_gfdef); + eval(vs_base[0]); +} + +static void +FFN(Fpop)(object form) +{ + object var; + + if (endp(form)) + FEtoo_few_argumentsF(form); + if (!endp(MMcdr(form))) + FEtoo_many_argumentsF(form); + var = MMcar(form); + if (type_of(var) != t_cons) { + eval(var); + setq(var, cdr(vs_base[0])); + vs_base[0] = car(vs_base[0]); + return; + } + vs_base = vs_top; + vs_push(sLpop); + vs_push(form); + stack_cons(); +/***/ + VS_PUSH_ENV ; +/***/ + if (!sLpop->s.s_mflag || sLpop->s.s_gfdef == OBJNULL) + FEerror("Where is POP?", 0); + funcall(sLpop->s.s_gfdef); + eval(vs_base[0]); +} + +static void +FFN(Fincf)(object form) +{ + object var; + object one_plus(object x), number_plus(object x, object y); + + if (endp(form)) + FEtoo_few_argumentsF(form); + if (!endp(MMcdr(form)) && !endp(MMcddr(form))) + FEtoo_many_argumentsF(form); + var = MMcar(form); + if (type_of(var) != t_cons) { + if (endp(MMcdr(form))) { + eval(var); + vs_base[0] = one_plus(vs_base[0]); + setq(var, vs_base[0]); + return; + } + eval(MMcadr(form)); + form = vs_base[0]; + eval(var); + vs_base[0] = number_plus(vs_base[0], form); + setq(var, vs_base[0]); + return; + } + vs_base = vs_top; + vs_push(sLincf); + vs_push(form); + stack_cons(); +/***/ + VS_PUSH_ENV ; +/***/ + if (!sLincf->s.s_mflag || sLincf->s.s_gfdef == OBJNULL) + FEerror("Where is INCF?", 0); + funcall(sLincf->s.s_gfdef); + eval(vs_base[0]); +} + +static void +FFN(Fdecf)(object form) +{ + object var; + object one_minus(object x), number_minus(object x, object y); + + if (endp(form)) + FEtoo_few_argumentsF(form); + if (!endp(MMcdr(form)) && !endp(MMcddr(form))) + FEtoo_many_argumentsF(form); + var = MMcar(form); + if (type_of(var) != t_cons) { + if (endp(MMcdr(form))) { + eval(var); + vs_base[0] = one_minus(vs_base[0]); + setq(var, vs_base[0]); + return; + } + eval(MMcadr(form)); + form = vs_base[0]; + eval(var); + vs_base[0] = number_minus(vs_base[0], form); + setq(var, vs_base[0]); + return; + } + vs_base = vs_top; + vs_push(sLdecf); + vs_push(form); + stack_cons(); +/***/ + VS_PUSH_ENV ; +/***/ + if (!sLdecf->s.s_mflag || sLdecf->s.s_gfdef == OBJNULL) + FEerror("Where is DECF?", 0); + funcall(sLdecf->s.s_gfdef); + eval(vs_base[0]); +} + + +/* object */ +/* clear_compiler_properties(object sym, object code) */ +/* { object tem; */ +/* VFUN_NARGS=2; fSuse_fast_links(Cnil,sym); */ +/* tem = getf(sym->s.s_plist,sStraced,Cnil); */ +/* if (sSAinhibit_macro_specialA && sSAinhibit_macro_specialA->s.s_dbind != Cnil) */ +/* (void)ifuncall2(sSclear_compiler_properties, sym,code); */ +/* if (tem != Cnil) return tem; */ +/* return sym; */ + +/* } */ + +DEF_ORDINARY("CLEAR-COMPILER-PROPERTIES",sSclear_compiler_properties,SI,""); + +DEFUN_NEW("CLEAR-COMPILER-PROPERTIES",object,fSclear_compiler_properties,SI + ,2,2,NONE,OO,OO,OO,OO,(object x0,object x1),"") + +{ + /* 2 args */ + RETURN1(Cnil); +} + +DEF_ORDINARY("AREF",sLaref,LISP,""); +DEF_ORDINARY("CAR",sLcar,LISP,""); +DEF_ORDINARY("CDR",sLcdr,LISP,""); +DEF_ORDINARY("CHAR",sLchar,LISP,""); +DEF_ORDINARY("DECF",sLdecf,LISP,""); +DEF_ORDINARY("ELT",sLelt,LISP,""); +DEF_ORDINARY("FILL-POINTER",sLfill_pointer,LISP,""); +DEF_ORDINARY("GET",sLget,LISP,""); +DEF_ORDINARY("GETF",sLgetf,LISP,""); +DEF_ORDINARY("GETHASH",sLgethash,LISP,""); +DEF_ORDINARY("INCF",sLincf,LISP,""); +DEF_ORDINARY("POP",sLpop,LISP,""); +DEF_ORDINARY("PUSH",sLpush,LISP,""); +DEF_ORDINARY("SCHAR",sLschar,LISP,""); +DEF_ORDINARY("SETF",sLsetf,LISP,""); +DEF_ORDINARY("SETF-LAMBDA",sSsetf_lambda,SI,""); +DEF_ORDINARY("STRUCTURE-ACCESS",sSstructure_access,SI,""); +DEF_ORDINARY("SVREF",sLsvref,LISP,""); +DEF_ORDINARY("TRACED",sStraced,SI,""); +DEF_ORDINARY("VECTOR",sLvector,LISP,""); + +void +gcl_init_assignment(void) +{ + make_special_form("SETQ", Fsetq); + make_special_form("PSETQ", Fpsetq); + make_special_form("MULTIPLE-VALUE-SETQ", Fmultiple_value_setq); + sLsetf=make_special_form("SETF", Fsetf); + sLpush=make_special_form("PUSH", Fpush); + sLpop=make_special_form("POP", Fpop); + sLincf=make_special_form("INCF", Fincf); + sLdecf=make_special_form("DECF", Fdecf); + +} diff --git a/o/backq.c b/o/backq.c new file mode 100755 index 0000000..2982c9d --- /dev/null +++ b/o/backq.c @@ -0,0 +1,383 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#include "include.h" + +#define attach(x) (vs_head = make_cons(x, vs_head)) +#define make_list (vs_push(Cnil), stack_cons(), stack_cons()) + + +#define QUOTE 1 +#define EVAL 2 +#define LIST 3 +#define LISTA 4 +#define APPEND 5 +#define NCONC 6 + +#define siScomma_at sSYB +#define siScomma_dot sSYZ +object sSYB; +object sSYZ; + +static void +kwote_cdr(void) +{ + object x; + + x = vs_head; + if (type_of(x) == t_symbol) { + if ((enum stype)x->s.s_stype == stp_constant && + x->s.s_dbind == x) + return; + goto KWOTE; + } else if (type_of(x) == t_cons || type_of(x) == t_vector) + goto KWOTE; + return; + +KWOTE: + vs_head = make_cons(vs_head, Cnil); + vs_head = make_cons(sLquote, vs_head); +} + +static void +kwote_car(void) +{ + object x; + + x = vs_top[-2]; + if (type_of(x) == t_symbol) { + if ((enum stype)x->s.s_stype == stp_constant && + x->s.s_dbind == x) + return; + goto KWOTE; + } else if (type_of(x) == t_cons || type_of(x) == t_vector) + goto KWOTE; + return; + +KWOTE: + vs_top[-2] = make_cons(vs_top[-2], Cnil); + vs_top[-2] = make_cons(sLquote, vs_top[-2]); +} + +/* + Backq_cdr(x) pushes a form on vs and returns one of + + QUOTE the form should be quoted + EVAL the form should be evaluated + LIST the form should be applied to LIST + LISTA 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 +backq_cdr(object x) +{ + int a, d; + + cs_check(x); + + if (type_of(x) != t_cons) { + vs_push(x); + return(QUOTE); + } + if (x->c.c_car == siScomma) { + vs_push(x->c.c_cdr); + return(EVAL); + } + if (x->c.c_car == siScomma_at || x->c.c_car == siScomma_dot) + FEerror(",@ or ,. has appeared in an illegal position.", 0); + a = backq_car(x->c.c_car); + d = backq_cdr(x->c.c_cdr); + if (d == QUOTE) + switch (a) { + case QUOTE: + vs_popp; + vs_head = x; + return(QUOTE); + + case EVAL: + if (vs_head == Cnil) { + stack_cons(); + return(LIST); + } + if (type_of(vs_head) == t_cons && + vs_head->c.c_cdr == Cnil) { + vs_head = vs_head->c.c_car; + kwote_cdr(); + make_list; + return(LIST); + } + kwote_cdr(); + make_list; + return(LISTA); + + case APPEND: + if (vs_head == Cnil) { + vs_popp; + return(EVAL); + } + kwote_cdr(); + make_list; + return(APPEND); + + case NCONC: + if (vs_head == Cnil) { + vs_popp; + return(EVAL); + } + kwote_cdr(); + make_list; + return(NCONC); + + default: + error("backquote botch"); + } + if (d == EVAL) + switch (a) { + case QUOTE: + kwote_car(); + make_list; + return(LISTA); + + case EVAL: + make_list; + return(LISTA); + + case APPEND: + make_list; + return(APPEND); + + case NCONC: + make_list; + return(NCONC); + + default: + error("backquote botch"); + } + if (a == d) { + stack_cons(); + return(d); + } + switch (d) { + case LIST: + if (a == QUOTE) { + kwote_car(); + stack_cons(); + return(d); + } + if (a == EVAL) { + stack_cons(); + return(d); + } + attach(sLlist); + break; + + case LISTA: + if (a == QUOTE) { + kwote_car(); + stack_cons(); + return(d); + } + if (a == EVAL) { + stack_cons(); + return(d); + } + attach(sLlistA); + break; + + case APPEND: + attach(sLappend); + break; + + case NCONC: + attach(sLnconc); + break; + + default: + error("backquote botch"); + } + switch (a) { + case QUOTE: + kwote_car(); + make_list; + return(LISTA); + + case EVAL: + make_list; + return(LISTA); + + case APPEND: + make_list; + return(APPEND); + + case NCONC: + make_list; + return(NCONC); + + default: + error("backquote botch"); + return(0); + } +} + +/* + Backq_car(x) pushes a form on vs 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 +*/ +int +backq_car(object x) +{ + int d; + + cs_check(x); + + if (type_of(x) != t_cons) { + vs_push(x); + return(QUOTE); + } + if (x->c.c_car == siScomma) { + vs_push(x->c.c_cdr); + return(EVAL); + } + if (x->c.c_car == siScomma_at) { + vs_push(x->c.c_cdr); + return(APPEND); + } + if (x->c.c_car == siScomma_dot) { + vs_push(x->c.c_cdr); + return(NCONC); + } + d = backq_cdr(x); + switch (d) { + case QUOTE: + return(QUOTE); + + case EVAL: + return(EVAL); + + case LIST: + attach(sLlist); + break; + + case LISTA: + attach(sLlistA); + break; + + case APPEND: + attach(sLappend); + break; + + case NCONC: + attach(sLnconc); + break; + + default: + error("backquote botch"); + } + return(EVAL); +} + +static object +backq(object x) +{ + int a; + + a = backq_car(x); + if (a == APPEND || a == NCONC) + FEerror(",@ or ,. has appeared in an illegal position.", 0); + if (a == QUOTE) + kwote_cdr(); + return(vs_pop); +} + +static object fLcomma_reader(object x0, object x1) +{ object w; + object in, c; + + /* 2 args */ + + in = x0; + if (backq_level <= 0) + FEerror("A comma has appeared out of a backquote.", 0); + c = peek_char(FALSE, in); + if (c == code_char('@')) { + w = siScomma_at; + read_char(in); + } else if (c == code_char('.')) { + w=siScomma_dot; + read_char(in); + } else + w=siScomma; + --backq_level; + x0 = make_cons(w,read_object(in)); + backq_level++; + RETURN1(x0); +} + +static object fLbackquote_reader(object x0, object x1) +{ + object in; + + /* 2 args */ + in = x0; + backq_level++; + x0 = read_object(in); + --backq_level; + x0 = backq(x0); + RETURN1(x0); +} + +#define make_cf(f) make_cfun((f), Cnil, Cnil, NULL, 0); +#define MAKE_AFUN(addr,n) MakeAfun(addr,F_ARGD(n,n,NONE,ARGTYPES(OO,OO,OO,OO)),0); + + +DEF_ORDINARY("Y",sSY,SI,""); +DEF_ORDINARY("YB",sSYB,SI,""); + +DEF_ORDINARY("YZ",sSYZ,SI,""); +DEF_ORDINARY("LIST*",sLlistA,LISP,""); + +DEF_ORDINARY("APPEND",sLappend,LISP,""); +DEF_ORDINARY("NCONC",sLnconc,LISP,""); +DEF_ORDINARY("APPLY",sLapply,LISP,""); +DEF_ORDINARY("VECTOR",sLvector,LISP,""); + + +void +gcl_init_backq(void) +{ + object r; + + + r = standard_readtable; + r->rt.rt_self['`'].rte_chattrib = cat_terminating; + r->rt.rt_self['`'].rte_macro = MAKE_AFUN(fLbackquote_reader,2); + r->rt.rt_self[','].rte_chattrib = cat_terminating; + r->rt.rt_self[','].rte_macro = MAKE_AFUN(fLcomma_reader,2); + + backq_level = 0; +} diff --git a/o/bcmp.c b/o/bcmp.c new file mode 100755 index 0000000..81706f6 --- /dev/null +++ b/o/bcmp.c @@ -0,0 +1,11 @@ +#include +int bcmp(const void *s1, const void *s2, size_t n) +{ const char *c1=s1,*c2=s2; + while (n-- > 0) + {if (*c1++ != *c2++) + return 1;} + return 0; + } + + + diff --git a/o/bcopy.c b/o/bcopy.c new file mode 100755 index 0000000..4b60093 --- /dev/null +++ b/o/bcopy.c @@ -0,0 +1,10 @@ +#include +void bcopy(const void *s1, void *s2, size_t n) +{ const char *c1=s1; + char *c2=s2; + while (n-- > 0) { + *c2++ = *c1++; +} +} + + diff --git a/o/bds.c b/o/bds.c new file mode 100755 index 0000000..24ad1d4 --- /dev/null +++ b/o/bds.c @@ -0,0 +1,37 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +/* + bds.c + + bind stack routines +*/ + +#include "include.h" + +void +bds_unwind(bds_ptr new_bds_top) +{ + for (; bds_top > new_bds_top; bds_top--) + (bds_top->bds_sym)->s.s_dbind = bds_top->bds_val; +} + + diff --git a/o/before_init.c b/o/before_init.c new file mode 100755 index 0000000..e0a3eda --- /dev/null +++ b/o/before_init.c @@ -0,0 +1,53 @@ +#include "all.h" +#include "funlink.h" +#define SI 0 +#define LISP 1 +#define KEYWORD 2 + +#define NONE 0 + +void SI_makefun(),LISP_makefun(),error(); + +#define MAKEFUN(pack,string,fname,argd) \ + (pack == SI ? SI_makefun : pack == LISP ? LISP_makefun : error)(string,fname,argd) + +#undef DEFUN +#define DEFUN(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56) \ + {extern ret fname(); \ + MAKEFUN(pack,string,fname,F_ARGD(min,max,flags,ARGTYPES(ret0a0,a12,a34,a56)));} + +#undef DEFUNO +#define DEFUNO(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,old) \ + {extern ret fname(); \ + MAKEFUN(pack,string,fname,F_ARGD(min,max,flags,ARGTYPES(ret0a0,a12,a34,a56)));} + +#undef DEFCOMP +#define DEFCOMP(type, fun) Ineed_in_image(fun); + + +#undef DEFVAR +#define DEFVAR(name,cname,pack,val) \ + { extern obj cname; \ + cname = (pack == LISP ? make_special(name,val) : \ + pack == SI ? make_si_special(name,val): \ + (error(name,val),(obj)0));} + +#undef DEFCONST +#define DEFCONST(name,cname,pack,val) \ + { extern obj cname; \ + cname = (pack == LISP ? make_constant(name,val) : \ + pack == SI ? make_si_constant(name,val): \ + (error(name,val),(obj)0));} + + +#undef DEF_ORDINARY +#define DEF_ORDINARY(name,cname,pack) \ + { extern obj cname ; cname = (pack == LISP ? make_ordinary(name) : \ + pack == SI ? make_si_ordinary(name): \ + pack == KEYWORD ? make_keyword(name): \ + (error(name),(obj)0));} + + +#undef DEF_INIT +#define DEF_INIT(x) x + diff --git a/o/big.c b/o/big.c new file mode 100755 index 0000000..d66a002 --- /dev/null +++ b/o/big.c @@ -0,0 +1,163 @@ + /* Copyright William F. Schelter 1991 + Bignum routines. + + + +num_arith.c: add_int_big +num_arith.c: big_minus +num_arith.c: big_plus +num_arith.c: big_quotient_remainder +num_arith.c: big_sign +num_arith.c: big_times +num_arith.c: complement_big +num_arith.c: copy_big +num_arith.c: div_int_big +num_arith.c: mul_int_big +num_arith.c: normalize_big +num_arith.c: normalize_big_to_object +num_arith.c: stretch_big +num_arith.c: sub_int_big +num_comp.c: big_compare +num_comp.c: big_sign +num_log.c: big_sign +num_log.c: copy_to_big +num_log.c: normalize_big +num_log.c: normalize_big_to_object +num_log.c: stretch_big +num_pred.c: big_sign +number.c: big_to_double +predicate.c: big_compare +typespec.c: big_sign +print.d: big_minus +print.d: big_sign +print.d: big_zerop +print.d: copy_big +print.d: div_int_big +read.d: add_int_big +read.d: big_to_double +read.d: complement_big +read.d: mul_int_big +read.d: normalize_big +read.d: normalize_big_to_object + + */ + +#define remainder gclremainder +#define NEED_MP_H +#include +#include +#include "include.h" + +#ifdef STATIC_FUNCTION_POINTERS +static void* alloc_relblock_static (size_t n) {return alloc_relblock (n);} +static void* alloc_contblock_static(size_t n) {return alloc_contblock(n);} +#endif + +void* (*gcl_gmp_allocfun)(size_t)=FFN(alloc_relblock); +int gmp_relocatable=1; + + +DEFUN_NEW("SET-GMP-ALLOCATE-RELOCATABLE",object,fSset_gmp_allocate_relocatable,SI,1,1,NONE,OO,OO,OO,OO, + (object flag),"Set the allocation to be relocatble ") +{ + if (flag == Ct) { + gcl_gmp_allocfun = FFN(alloc_relblock); + gmp_relocatable=1; + } else { + gcl_gmp_allocfun = FFN(alloc_contblock); + gmp_relocatable=0; + } + RETURN1(flag); +} + +#ifdef GMP +#include "gmp_big.c" +#else +#include "pari_big.c" +#endif + + + +int big_sign(object x) +{ + return BIG_SIGN(x); +} + +void set_big_sign(object x, int sign) +{ + SET_BIG_SIGN(x,sign); +} + +void zero_big(object x) +{ + ZERO_BIG(x); +} + + +#ifndef HAVE_MP_COERCE_TO_STRING + +double digitsPerBit[37]={ 0,0, +1.0, /* 2 */ +0.6309297535714574, /* 3 */ +0.5, /* 4 */ +0.4306765580733931, /* 5 */ +0.3868528072345416, /* 6 */ +0.3562071871080222, /* 7 */ +0.3333333333333334, /* 8 */ +0.3154648767857287, /* 9 */ +0.3010299956639811, /* 10 */ +0.2890648263178878, /* 11 */ +0.2789429456511298, /* 12 */ +0.2702381544273197, /* 13 */ +0.2626495350371936, /* 14 */ +0.2559580248098155, /* 15 */ +0.25, /* 16 */ +0.244650542118226, /* 17 */ +0.2398124665681315, /* 18 */ +0.2354089133666382, /* 19 */ +0.2313782131597592, /* 20 */ +0.227670248696953, /* 21 */ +0.2242438242175754, /* 22 */ +0.2210647294575037, /* 23 */ +0.2181042919855316, /* 24 */ +0.2153382790366965, /* 25 */ +0.2127460535533632, /* 26 */ +0.2103099178571525, /* 27 */ +0.2080145976765095, /* 28 */ +0.2058468324604345, /* 29 */ +0.2037950470905062, /* 30 */ +0.2018490865820999, /* 31 */ +0.2, /* 32 */ +0.1982398631705605, /* 33 */ +0.1965616322328226, /* 34 */ +0.1949590218937863, /* 35 */ +0.1934264036172708, /* 36 */ +}; + +object +coerce_big_to_string(x,printbase) + int printbase; + object x; +{ int i; + int sign=big_sign(x); + object b; + int size = (int)((ceil(MP_SIZE_IN_BASE2(MP(x))* digitsPerBit[printbase]))+.01); + char *q,*p = alloca(size+5); + q=p; + if(sign<=0) { + *q++ = '-'; + b=big_minus(x); + } else { + b=copy_big(x); + } + while (!big_zerop(b)) + *q++=digit_weight(div_int_big(printbase, b),printbase); + *q++=0; + object ans = alloc_simple_string(q-p); + ans->ust.ust_self=alloc_relblock(ans->ust.ust_dim); + bcopy(ans->ust.ust_self,p,ans->ust.ust_dim); + ans->ust.ust_fillp=ans->ust.ust_dim-1; + return ans; +} + +#endif diff --git a/o/bind.c b/o/bind.c new file mode 100755 index 0000000..50c0fa8 --- /dev/null +++ b/o/bind.c @@ -0,0 +1,1127 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +/* + bind.c +*/ + +#include "include.h" +#include + +static void +illegal_lambda(void); + + +struct nil3 { object nil3_self[3]; } three_nils; +struct nil6 { object nil6_self[6]; } six_nils; + +struct required { + object req_var; + object req_spp; +}; + +struct optional { + object opt_var; + object opt_spp; + object opt_init; + object opt_svar; + object opt_svar_spp; +}; + +struct rest { + object rest_var; + object rest_spp; +}; + +struct keyword { + object key_word; + object key_var; + object key_spp; + object key_init; + object key_svar; + object key_svar_spp; + object key_val; + object key_svar_val; +}; + +struct aux { + object aux_var; + object aux_spp; + object aux_init; +}; + + + + + +#define isdeclare(x) ((x) == sLdeclare) + +void +lambda_bind(object *arg_top) +{ + + object temporary; + object lambda, lambda_list, body, form=Cnil, x, ds, vs, v; + int narg, i, j; + object *base = vs_base; + struct required *required; + int nreq; + struct optional *optional=NULL; + int nopt; + struct rest *rest=NULL; + bool rest_flag; + struct keyword *keyword=NULL; + bool key_flag; + bool allow_other_keys_flag, other_keys_appeared; + int nkey; + struct aux *aux=NULL; + int naux; + bool special_processed; + vs_mark; + + bds_check; + lambda = vs_head; + if (type_of(lambda) != t_cons) + FEerror("No lambda list.", 0); + lambda_list = lambda->c.c_car; + body = lambda->c.c_cdr; + + required = (struct required *)vs_top; + nreq = 0; + for (;;) { + if (endp(lambda_list)) + goto REQUIRED_ONLY; + x = lambda_list->c.c_car; + lambda_list = lambda_list->c.c_cdr; + check_symbol(x); + if (x == ANDallow_other_keys) + illegal_lambda(); + if (x == ANDoptional) { + nopt = nkey = naux = 0; + rest_flag = key_flag = allow_other_keys_flag + = FALSE; + goto OPTIONAL; + } + if (x == ANDrest) { + nopt = nkey = naux = 0; + key_flag = allow_other_keys_flag + = FALSE; + goto REST; + } + if (x == ANDkey) { + nopt = nkey = naux = 0; + rest_flag = allow_other_keys_flag + = FALSE; + goto KEYWORD; + } + if (x == ANDaux) { + nopt = nkey = naux = 0; + rest_flag = key_flag = allow_other_keys_flag + = FALSE; + goto AUX_L; + } + if ((enum stype)x->s.s_stype == stp_constant) + FEerror("~S is not a variable.", 1, x); + vs_push(x); + vs_push(Cnil); + nreq++; + } + +OPTIONAL: + optional = (struct optional *)vs_top; + for (;; nopt++) { + if (endp(lambda_list)) + goto SEARCH_DECLARE; + x = lambda_list->c.c_car; + lambda_list = lambda_list->c.c_cdr; + if (type_of(x) == t_cons) { + check_symbol(x->c.c_car); + check_var(x->c.c_car); + vs_push(x->c.c_car); + x = x->c.c_cdr; + vs_push(Cnil); + if (endp(x)) { + *(struct nil3 *)vs_top = three_nils; + vs_top += 3; + continue; + } + vs_push(x->c.c_car); + x = x->c.c_cdr; + if (endp(x)) { + vs_push(Cnil); + vs_push(Cnil); + continue; + } + check_symbol(x->c.c_car); + check_var(x->c.c_car); + vs_push(x->c.c_car); + vs_push(Cnil); + if (!endp(x->c.c_cdr)) + illegal_lambda(); + } else { + check_symbol(x); + if (x == ANDoptional || + x == ANDallow_other_keys) + illegal_lambda(); + if (x == ANDrest) + goto REST; + if (x == ANDkey) + goto KEYWORD; + if (x == ANDaux) + goto AUX_L; + check_var(x); + vs_push(x); + *(struct nil6 *)vs_top = six_nils; + vs_top += 4; + } + } + +REST: + rest = (struct rest *)vs_top; + if (endp(lambda_list)) + illegal_lambda(); + check_symbol(lambda_list->c.c_car); + check_var(lambda_list->c.c_car); + rest_flag = TRUE; + vs_push(lambda_list->c.c_car); + vs_push(Cnil); + lambda_list = lambda_list->c.c_cdr; + if (endp(lambda_list)) + goto SEARCH_DECLARE; + x = lambda_list->c.c_car; + lambda_list = lambda_list->c.c_cdr; + check_symbol(x); + if (x == ANDoptional || x == ANDrest || + x == ANDallow_other_keys) + illegal_lambda(); + if (x == ANDkey) + goto KEYWORD; + if (x == ANDaux) + goto AUX_L; + illegal_lambda(); + +KEYWORD: + keyword = (struct keyword *)vs_top; + key_flag = TRUE; + for (;; nkey++) { + if (endp(lambda_list)) + goto SEARCH_DECLARE; + x = lambda_list->c.c_car; + lambda_list = lambda_list->c.c_cdr; + if (type_of(x) == t_cons) { + if (type_of(x->c.c_car) == t_cons) { + if (!keywordp(x->c.c_car->c.c_car)) + /* FIXME better message */ + FEunexpected_keyword(x->c.c_car->c.c_car); + vs_push(x->c.c_car->c.c_car); + if (endp(x->c.c_car->c.c_cdr)) + illegal_lambda(); + check_symbol(x->c.c_car + ->c.c_cdr->c.c_car); + vs_push(x->c.c_car->c.c_cdr->c.c_car); + if (!endp(x->c.c_car->c.c_cdr->c.c_cdr)) + illegal_lambda(); + } else { + check_symbol(x->c.c_car); + check_var(x->c.c_car); + vs_push(intern(x->c.c_car, keyword_package)); + vs_push(x->c.c_car); + } + vs_push(Cnil); + x = x->c.c_cdr; + if (endp(x)) { + *(struct nil6 *)vs_top = six_nils; + vs_top += 5; + continue; + } + vs_push(x->c.c_car); + x = x->c.c_cdr; + if (endp(x)) { + *(struct nil6 *)vs_top = six_nils; + vs_top += 4; + continue; + } + check_symbol(x->c.c_car); + check_var(x->c.c_car); + vs_push(x->c.c_car); + vs_push(Cnil); + if (!endp(x->c.c_cdr)) + illegal_lambda(); + vs_push(Cnil); + vs_push(Cnil); + } else { + check_symbol(x); + if (x == ANDallow_other_keys) { + allow_other_keys_flag = TRUE; + if (endp(lambda_list)) + goto SEARCH_DECLARE; + x = lambda_list->c.c_car; + lambda_list = lambda_list->c.c_cdr; + } + if (x == ANDoptional || x == ANDrest || + x == ANDkey || x == ANDallow_other_keys) + illegal_lambda(); + if (x == ANDaux) + goto AUX_L; + check_var(x); + vs_push(intern(x, keyword_package)); + vs_push(x); + *(struct nil6 *)vs_top = six_nils; + vs_top += 6; + } + } + +AUX_L: + aux = (struct aux *)vs_top; + for (;; naux++) { + if (endp(lambda_list)) + goto SEARCH_DECLARE; + x = lambda_list->c.c_car; + lambda_list = lambda_list->c.c_cdr; + if (type_of(x) == t_cons) { + check_symbol(x->c.c_car); + check_var(x->c.c_car); + vs_push(x->c.c_car); + vs_push(Cnil); + x = x->c.c_cdr; + if (endp(x)) { + vs_push(Cnil); + continue; + } + vs_push(x->c.c_car); + if (!endp(x->c.c_cdr)) + illegal_lambda(); + } else { + check_symbol(x); + if (x == ANDoptional || x == ANDrest || + x == ANDkey || x == ANDallow_other_keys || + x == ANDaux) + illegal_lambda(); + check_var(x); + vs_push(x); + vs_push(Cnil); + vs_push(Cnil); + } + } + +SEARCH_DECLARE: + vs_push(Cnil); + for (; !endp(body); body = body->c.c_cdr) { + form = body->c.c_car; + + /* MACRO EXPANSION */ + form = macro_expand(form); + vs_head = form; + + if (type_of(form) == t_string) { + if (endp(body->c.c_cdr)) + break; + continue; + } + if (type_of(form)!=t_cons || !isdeclare(form->c.c_car)) + break; + for (ds = form->c.c_cdr; !endp(ds); ds = ds->c.c_cdr) { + if (type_of(ds->c.c_car) != t_cons) + illegal_declare(form); + if (ds->c.c_car->c.c_car == sLspecial) { + vs = ds->c.c_car->c.c_cdr; + for (; !endp(vs); vs = vs->c.c_cdr) { + v = vs->c.c_car; + check_symbol(v); +/**/ + + special_processed = FALSE; + for (i = 0; i < nreq; i++) + if (required[i].req_var == v) { + required[i].req_spp = Ct; + special_processed = TRUE; + } + for (i = 0; i < nopt; i++) + if (optional[i].opt_var == v) { + optional[i].opt_spp = Ct; + special_processed = TRUE; + } else if (optional[i].opt_svar == v) { + optional[i].opt_svar_spp = Ct; + special_processed = TRUE; + } + if (rest_flag && rest->rest_var == v) { + rest->rest_spp = Ct; + special_processed = TRUE; + } + for (i = 0; i < nkey; i++) + if (keyword[i].key_var == v) { + keyword[i].key_spp = Ct; + special_processed = TRUE; + } else if (keyword[i].key_svar == v) { + keyword[i].key_svar_spp = Ct; + special_processed = TRUE; + } + for (i = 0; i < naux; i++) + if (aux[i].aux_var == v) { + aux[i].aux_spp = Ct; + special_processed = TRUE; + } + if (special_processed) + continue; + /* lex_special_bind(v); */ + lex_env[0] = MMcons(MMcons(v, Cnil), lex_env[0]); + +/**/ + } + } + } + } + + narg = arg_top - base; + if (narg < nreq) { + if (nopt == 0 && !rest_flag && !key_flag) { + vs_base = base; + vs_top = arg_top; + check_arg_failed(nreq); + } + FEtoo_few_arguments(base, arg_top); + } + if (!rest_flag && !key_flag && narg > nreq+nopt) { + if (nopt == 0) { + vs_base = base; + vs_top = arg_top; + check_arg_failed(nreq); + } + FEtoo_many_arguments(base, arg_top); + } + for (i = 0; i < nreq; i++) + bind_var(required[i].req_var, + base[i], + required[i].req_spp); + for (i = 0; i < nopt; i++) + if (nreq+i < narg) { + bind_var(optional[i].opt_var, + base[nreq+i], + optional[i].opt_spp); + if (optional[i].opt_svar != Cnil) + bind_var(optional[i].opt_svar, + Ct, + optional[i].opt_svar_spp); + } else { + eval_assign(temporary, optional[i].opt_init); + bind_var(optional[i].opt_var, + temporary, + optional[i].opt_spp); + if (optional[i].opt_svar != Cnil) + bind_var(optional[i].opt_svar, + Cnil, + optional[i].opt_svar_spp); + } + if (rest_flag) { + vs_push(Cnil); + for (i = narg, j = nreq+nopt; --i >= j; ) + vs_head = make_cons(base[i], vs_head); + bind_var(rest->rest_var, vs_head, rest->rest_spp); + } + if (key_flag) { + i = narg - nreq - nopt; + if (i >= 0 && i%2 != 0) + /* FIXME better message */ + FEunexpected_keyword(Cnil); + other_keys_appeared = FALSE; + for (i = nreq + nopt; i < narg; i += 2) { + if (!keywordp(base[i])) + FEunexpected_keyword(base[i]); + if (base[i] == sKallow_other_keys && + base[i+1] != Cnil) + allow_other_keys_flag = TRUE; + for (j = 0; j < nkey; j++) { + if (keyword[j].key_word == base[i]) { + if (keyword[j].key_svar_val + != Cnil) + goto NEXT_ARG; + keyword[j].key_val + = base[i+1]; + keyword[j].key_svar_val + = Ct; + goto NEXT_ARG; + } + } + other_keys_appeared = TRUE; + + NEXT_ARG: + continue; + } + if (other_keys_appeared && !allow_other_keys_flag) + /* FIXME better message */ + FEunexpected_keyword(Ct); + } + for (i = 0; i < nkey; i++) + if (keyword[i].key_svar_val != Cnil) { + bind_var(keyword[i].key_var, + keyword[i].key_val, + keyword[i].key_spp); + if (keyword[i].key_svar != Cnil) + bind_var(keyword[i].key_svar, + keyword[i].key_svar_val, + keyword[i].key_svar_spp); + } else { + eval_assign(temporary, keyword[i].key_init); + bind_var(keyword[i].key_var, + temporary, + keyword[i].key_spp); + if (keyword[i].key_svar != Cnil) + bind_var(keyword[i].key_svar, + keyword[i].key_svar_val, + keyword[i].key_svar_spp); + } + for (i = 0; i < naux; i++) { + eval_assign(temporary, aux[i].aux_init); + bind_var(aux[i].aux_var, temporary, aux[i].aux_spp); + } + if (type_of(body) != t_cons || body->c.c_car == form) { + vs_reset; + vs_head = body; + } else { + body = make_cons(form, body->c.c_cdr); + vs_reset; + vs_head = body; + } + return; + +REQUIRED_ONLY: + vs_push(Cnil); + for (; !endp(body); body = body->c.c_cdr) { + form = body->c.c_car; + + /* MACRO EXPANSION */ + vs_head = form = macro_expand(form); + + if (type_of(form) == t_string) { + if (endp(body->c.c_cdr)) + break; + continue; + } + if (type_of(form)!=t_cons || !isdeclare(form->c.c_car)) + break; + for (ds = form->c.c_cdr; !endp(ds); ds = ds->c.c_cdr) { + if (type_of(ds->c.c_car) != t_cons) + illegal_declare(form); + if (ds->c.c_car->c.c_car == sLspecial) { + vs = ds->c.c_car->c.c_cdr; + for (; !endp(vs); vs = vs->c.c_cdr) { + v = vs->c.c_car; + check_symbol(v); +/**/ + + special_processed = FALSE; + for (i = 0; i < nreq; i++) + if (required[i].req_var == v) { + required[i].req_spp = Ct; + special_processed = TRUE; + } + if (special_processed) + continue; + /* lex_special_bind(v); */ + temporary = MMcons(v, Cnil); + lex_env[0] = MMcons(temporary, lex_env[0]); + +/**/ + } + } + } + } + + narg = arg_top - base; + if (narg != nreq) { + vs_base = base; + vs_top = arg_top; + check_arg_failed(nreq); + } + for (i = 0; i < nreq; i++) + bind_var(required[i].req_var, + base[i], + required[i].req_spp); + if (type_of(body) != t_cons || body->c.c_car == form) { + vs_reset; + vs_head = body; + } else { + body = make_cons(form, body->c.c_cdr); + vs_reset; + vs_head = body; + } +} + +void +bind_var(object var, object val, object spp) +{ + object temporary; + vs_mark; + + switch (var->s.s_stype) { + case stp_constant: + FEerror("Cannot bind the constant ~S.", 1, var); + + case stp_special: + bds_bind(var, val); + break; + + default: + if (spp != Cnil) { + /* lex_special_bind(var); */ + temporary = MMcons(var, Cnil); + lex_env[0] = MMcons(temporary, lex_env[0]); + bds_bind(var, val); + } else { + /* lex_local_bind(var, val); */ + temporary = MMcons(val, Cnil); + temporary = MMcons(var, temporary); + lex_env[0] = MMcons(temporary, lex_env[0]); + } + break; + } + vs_reset; +} + +static void +illegal_lambda(void) +{ + FEerror("Illegal lambda expression.", 0); +} + +/* +struct bind_temp { + object bt_var; + object bt_spp; + object bt_init; + object bt_aux; +}; +*/ + +object +find_special(object body, struct bind_temp *start, struct bind_temp *end) +{ + object temporary; + object form=Cnil; + object ds, vs, v; + struct bind_temp *bt; + bool special_processed; + vs_mark; + + vs_push(Cnil); + for (; !endp(body); body = body->c.c_cdr) { + form = body->c.c_car; + + /* MACRO EXPANSION */ + form = macro_expand(form); + vs_head = form; + + if (type_of(form) == t_string) { + if (endp(body->c.c_cdr)) + break; + continue; + } + if (type_of(form)!=t_cons || !isdeclare(form->c.c_car)) + break; + for (ds = form->c.c_cdr; !endp(ds); ds = ds->c.c_cdr) { + if (type_of(ds->c.c_car) != t_cons) + illegal_declare(form); + if (ds->c.c_car->c.c_car == sLspecial) { + vs = ds->c.c_car->c.c_cdr; + for (; !endp(vs); vs = vs->c.c_cdr) { + v = vs->c.c_car; + check_symbol(v); +/**/ + special_processed = FALSE; + for (bt = start; bt < end; bt++) + if (bt->bt_var == v) { + bt->bt_spp = Ct; + special_processed = TRUE; + } + if (special_processed) + continue; + /* lex_special_bind(v); */ + temporary = MMcons(v, Cnil); + lex_env[0] = MMcons(temporary, lex_env[0]); +/**/ + } + } + } + } + + if (body != Cnil && body->c.c_car != form) + body = make_cons(form, body->c.c_cdr); + vs_reset; + return(body); +} + +object +let_bind(object body, struct bind_temp *start, struct bind_temp *end) +{ + struct bind_temp *bt; + + bds_check; + vs_push(find_special(body, start, end)); + for (bt = start; bt < end; bt++) { + eval_assign(bt->bt_init, bt->bt_init); + } + for (bt = start; bt < end; bt++) { + bind_var(bt->bt_var, bt->bt_init, bt->bt_spp); + } + return(vs_pop); +} + +object +letA_bind(object body, struct bind_temp *start, struct bind_temp *end) +{ + struct bind_temp *bt; + + bds_check; + vs_push(find_special(body, start, end)); + for (bt = start; bt < end; bt++) { + eval_assign(bt->bt_init, bt->bt_init); + bind_var(bt->bt_var, bt->bt_init, bt->bt_spp); + } + return(vs_pop); +} + + +#ifdef MV + +#endif + +#define NOT_YET 10 +#define FOUND 11 +#define NOT_KEYWORD 1 + +void +parse_key(object *base, bool rest, bool allow_other_keys,int n, ...) +{ + object temporary; + va_list ap; + object other_key = OBJNULL; + int narg, error_flag = 0, allow_other_keys_found=0; + object *v, k, *top; + register int i; + + narg = vs_top - base; + if (narg <= 0) { + if (rest) { + base[0] = Cnil; + base++; + } + top = base + n; + for (i = 0; i < n; i++) { + base[i] = Cnil; + top[i] = Cnil; + } + return; + } + if (narg%2 != 0) + /* FIXME better message */ + FEunexpected_keyword(Cnil); + if (narg == 2) { + k = base[0]; + if (!keywordp(k)) + FEunexpected_keyword(k); + if (k == sKallow_other_keys && ! allow_other_keys_found) { + allow_other_keys_found=1; + if (base[1]!=Cnil) + allow_other_keys=TRUE; + } + temporary = base[1]; + if (rest) + base++; + top = base + n; + other_key = k == sKallow_other_keys ? OBJNULL : k; + va_start(ap,n); + for (i = 0; i < n; i++) { + + if (va_arg(ap,object) == k) { + base[i] = temporary; + top[i] = Ct; + other_key = OBJNULL; + } else { + base[i] = Cnil; + top[i] = Cnil; + } + } + va_end(ap); + if (rest) { + temporary = make_cons(temporary, Cnil); + base[-1] = make_cons(k, temporary); + } + if (other_key != OBJNULL && !allow_other_keys) + FEunexpected_keyword(other_key); + return; + } + va_start(ap,n); + for (i = 0; i < n; i++) { + k = va_arg(ap,object); + k->s.s_stype = NOT_YET; + k->s.s_dbind = Cnil; + } + va_end(ap); + for (v = base; v < vs_top; v += 2) { + k = v[0]; + if (!keywordp(k)) { + error_flag = NOT_KEYWORD; + other_key = k; + continue; + } + if (k->s.s_stype == NOT_YET) { + k->s.s_dbind = v[1]; + k->s.s_stype = FOUND; + } else if (k->s.s_stype == FOUND) { + ; + } else if (other_key == OBJNULL && k!=sKallow_other_keys) + other_key = k; + if (k == sKallow_other_keys && !allow_other_keys_found) { + allow_other_keys_found=1; + if (v[1] != Cnil) + allow_other_keys = TRUE; + } + } + if (rest) { + top = vs_top; + vs_push(Cnil); + base++; + while (base < vs_top) + stack_cons(); + vs_top = top; + } + top = base + n; + va_start(ap,n); + for (i = 0; i < n; i++) { + k = va_arg(ap,object); + base[i] = k->s.s_dbind; + top[i] = k->s.s_stype == FOUND ? Ct : Cnil; + k->s.s_dbind = k; + k->s.s_stype = (short)stp_constant; + } + va_end(ap); + if (error_flag == NOT_KEYWORD) + FEunexpected_keyword(other_key); + if (other_key != OBJNULL && !allow_other_keys) + FEunexpected_keyword(other_key); +} + +void +check_other_key(object l, int n, ...) +{ + va_list ap; + object other_key = OBJNULL; + object k; + int i; + bool allow_other_keys = FALSE; + + for (; !endp(l); l = l->c.c_cdr->c.c_cdr) { + k = l->c.c_car; + if (!keywordp(k)) + FEunexpected_keyword(k); + if (endp(l->c.c_cdr)) + /* FIXME better message */ + FEunexpected_keyword(Cnil); + if (k == sKallow_other_keys && l->c.c_cdr->c.c_car != Cnil) { + allow_other_keys = TRUE; + } else { + char buf [100]; + bzero(buf,n); + va_start(ap,n); + for (i = 0; i < n; i++) + { if (va_arg(ap,object) == k && + buf[i] ==0) {buf[i]=1; break;}} + va_end(ap); + if (i >= n) other_key = k; + } + } + if (other_key != OBJNULL && !allow_other_keys) + FEunexpected_keyword(other_key); +} + + +/* struct key {short n,allow_other_keys; */ +/* iobject *defaults; */ +/* iobject keys[1]; */ +/* }; */ + + +object Cstd_key_defaults[15]={Cnil,Cnil,Cnil,Cnil,Cnil,Cnil,Cnil, + Cnil,Cnil,Cnil,Cnil,Cnil,Cnil,Cnil,Cnil}; + +/* FIXME rewrite this */ +/* static int */ +/* parse_key_new(int n, object *base, struct key *keys, va_list ap) */ +/* {object *new; */ +/* COERCE_VA_LIST(new,ap,n); */ + +/* new = new + n ; */ +/* {int j=keys->n; */ +/* object *p= (object *)(keys->defaults); */ +/* while (--j >=0) base[j]=p[j]; */ +/* } */ +/* {if (n==0){ return 0;} */ +/* {int allow = keys->allow_other_keys; */ +/* object k; */ + +/* if (!allow) { */ +/* int i; */ +/* for (i=n;i>0 && new[-i]!=sKallow_other_keys;i-=2); */ +/* if (i>0 && new[-i+1]!=Cnil) */ +/* allow=1; */ +/* } */ + +/* top: */ +/* while (n>=2) */ +/* {int i= keys->n; */ +/* iobject *ke=keys->keys ; */ +/* new = new -2; */ +/* k = *new; */ +/* while(--i >= 0) */ +/* {if ((*(ke++)).o == k) */ +/* {base[i]= new[1]; */ +/* n=n-2; */ +/* goto top; */ +/* }} */ + /* the key is a new one */ +/* if (allow || k==sKallow_other_keys) */ +/* n=n-2; */ +/* else */ +/* goto error; */ +/* } */ + /* FIXME better message */ +/* if (n!=0) FEunexpected_keyword(Cnil); */ +/* return 0; */ +/* error: */ +/* FEunexpected_keyword(k); */ +/* return -1; */ +/* }}} */ + +int +parse_key_new_new(int n, object *base, struct key *keys, object first, va_list ap) +{object *new; + COERCE_VA_LIST_KR_NEW(new,first,ap,n); + + /* from here down identical to parse_key_rest */ + new = new + n ; + {int j=keys->n; + object *p= (object *)(keys->defaults); + while (--j >=0) base[j]=p[j]; + } + {if (n==0){ return 0;} + {int allow = keys->allow_other_keys; + object k; + + if (!allow) { + int i; + for (i=n;i>0 && new[-i]!=sKallow_other_keys;i-=2); + if (i>0 && new[-i+1]!=Cnil) + allow=1; + } + + top: + while (n>=2) + {int i= keys->n; + iobject *ke=keys->keys ; + new = new -2; + k = *new; + while(--i >= 0) + {if ((*(ke++)).o == k) + {base[i]= new[1]; + n=n-2; + goto top; + }} + /* the key is a new one */ + if (allow || k==sKallow_other_keys) + n=n-2; + else + goto error; + } + /* FIXME better message */ + if (n!=0) FEunexpected_keyword(Cnil); + return 0; + error: + FEunexpected_keyword(k); + return -1; +}}} + +/* static int */ +/* parse_key_rest(object rest, int n, object *base, struct key *keys, va_list ap) */ +/* {object *new; */ +/* COERCE_VA_LIST(new,ap,n); */ + + /* copy the rest arg */ +/* {object *p = new; */ +/* int m = n; */ +/* while (--m >= 0) */ +/* {rest->c.c_car = *p++; */ +/* rest = rest->c.c_cdr;}} */ + +/* new = new + n ; */ +/* {int j=keys->n; */ +/* object *p= (object *)(keys->defaults); */ +/* while (--j >=0) base[j]=p[j]; */ +/* } */ +/* {if (n==0){ return 0;} */ +/* {int allow = keys->allow_other_keys; */ +/* object k; */ + +/* if (!allow) { */ +/* int i; */ +/* for (i=n;i>0 && new[-i]!=sKallow_other_keys;i-=2); */ +/* if (i>0 && new[-i+1]!=Cnil) */ +/* allow=1; */ +/* } */ + +/* top: */ +/* while (n>=2) */ +/* {int i= keys->n; */ +/* iobject *ke=keys->keys ; */ +/* new = new -2; */ +/* k = *new; */ +/* while(--i >= 0) */ +/* {if ((*(ke++)).o == k) */ +/* {base[i]= new[1]; */ +/* n=n-2; */ +/* goto top; */ +/* }} */ + /* the key is a new one */ +/* if (allow || k==sKallow_other_keys) */ +/* n=n-2; */ +/* else */ +/* goto error; */ +/* } */ + /* FIXME better message */ +/* if (n!=0) FEunexpected_keyword(Cnil); */ +/* return 0; */ +/* error: */ +/* FEunexpected_keyword(k); */ +/* return -1; */ +/* }}} */ + +int +parse_key_rest_new(object rest, int n, object *base, struct key *keys, object first,va_list ap) +{object *new; + COERCE_VA_LIST_KR_NEW(new,first,ap,n); + + /* copy the rest arg */ + {object *p = new; + int m = n; + while (--m >= 0) + {rest->c.c_car = *p++; + rest = rest->c.c_cdr;}} + + new = new + n ; + {int j=keys->n; + object *p= (object *)(keys->defaults); + while (--j >=0) base[j]=p[j]; + } + {if (n==0){ return 0;} + {int allow = keys->allow_other_keys; + object k; + + if (!allow) { + int i; + for (i=n;i>0 && new[-i]!=sKallow_other_keys;i-=2); + if (i>0 && new[-i+1]!=Cnil) + allow=1; + } + + top: + while (n>=2) + {int i= keys->n; + iobject *ke=keys->keys ; + new = new -2; + k = *new; + while(--i >= 0) + {if ((*(ke++)).o == k) + {base[i]= new[1]; + n=n-2; + goto top; + }} + /* the key is a new one */ + if (allow || k==sKallow_other_keys) + n=n-2; + else + goto error; + } + /* FIXME better message */ + if (n!=0) FEunexpected_keyword(Cnil); + return 0; + error: + FEunexpected_keyword(k); + return -1; +}}} + + +void +set_key_struct(struct key *ks, object data) +{int i=ks->n; + while (--i >=0) + {ks->keys[i].o = data->cfd.cfd_self[ ks->keys[i].i ]; + if (ks->defaults != (void *)Cstd_key_defaults) + {fixnum m=ks->defaults[i].i; + ks->defaults[i].o= + (m==-2 ? Cnil : + m==-1 ? OBJNULL : + data->cfd.cfd_self[m]);} +}} + +#undef AUX + +DEF_ORDINARY("ALLOW-OTHER-KEYS",sKallow_other_keys,KEYWORD,""); + + +void +gcl_init_bind(void) +{ + ANDoptional = make_ordinary("&OPTIONAL"); + enter_mark_origin(&ANDoptional); + ANDrest = make_ordinary("&REST"); + enter_mark_origin(&ANDrest); + ANDkey = make_ordinary("&KEY"); + enter_mark_origin(&ANDkey); + ANDallow_other_keys = make_ordinary("&ALLOW-OTHER-KEYS"); + enter_mark_origin(&ANDallow_other_keys); + ANDaux = make_ordinary("&AUX"); + enter_mark_origin(&ANDaux); + + make_constant("LAMBDA-LIST-KEYWORDS", + make_cons(ANDoptional, + make_cons(ANDrest, + make_cons(ANDkey, + make_cons(ANDallow_other_keys, + make_cons(ANDaux, + make_cons(make_ordinary("&WHOLE"), + make_cons(make_ordinary("&ENVIRONMENT"), + make_cons(make_ordinary("&BODY"), Cnil))))))))); + + make_constant("LAMBDA-PARAMETERS-LIMIT", + make_fixnum(64)); + + + + three_nils.nil3_self[0] = Cnil; + three_nils.nil3_self[1] = Cnil; + three_nils.nil3_self[2] = Cnil; + + six_nils.nil6_self[0] = Cnil; + six_nils.nil6_self[1] = Cnil; + six_nils.nil6_self[2] = Cnil; + six_nils.nil6_self[3] = Cnil; + six_nils.nil6_self[4] = Cnil; + six_nils.nil6_self[5] = Cnil; +} diff --git a/o/bind.texi b/o/bind.texi new file mode 100755 index 0000000..7b12edd --- /dev/null +++ b/o/bind.texi @@ -0,0 +1 @@ +@setfilename foo.info diff --git a/o/bitop.c b/o/bitop.c new file mode 100755 index 0000000..39911d2 --- /dev/null +++ b/o/bitop.c @@ -0,0 +1,47 @@ +#include "include.h" +/* static void */ +/* get_mark_bit(void) */ +/* {error("get_mark_bit called");} */ +/* static void */ +/* set_mark_bit(void) */ +/* {error("set_mark_bit called");} */ +/* static void */ +/* get_set_mark_bit(void) */ +/* {error("get_set_mark_bit called");} */ + + +/* + These have all been replaced by macros + +extern int *mark_table; +static +get_mark_bit(x) +int x; +{ + int y; + + y = (*(mark_table+(x/4/32)) >> (x/4%32)) & 1; + return(y); +} +static +set_mark_bit(x) +int x; +{ + int y; + + y = 1 << (x/4%32); + y = (*(mark_table+(x/4/32))) | y; + *(mark_table+ (x/4/32))=y; +} +static +get_set_mark_bit(x) +int x; +{ + int y; + + y = get_mark_bit(x); + set_mark_bit(x); + return(y); +} + +*/ diff --git a/o/block.c b/o/block.c new file mode 100755 index 0000000..c466a36 --- /dev/null +++ b/o/block.c @@ -0,0 +1,123 @@ +/* + Copyright (C) 1994 M. Hagiya, W. sLchelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +/* + + block.c + + blocks and exits +*/ + +#include "include.h" + +static void +FFN(Fblock)(VOL object args) +{ + object *oldlex = lex_env; + object id; + object body; + object *top; + + if(endp(args)) + FEtoo_few_argumentsF(args); + lex_copy(); + id = alloc_frame_id(); + vs_push(id); + lex_block_bind(MMcar(args), id); + vs_popp; + frs_push(FRS_CATCH, id); + if (nlj_active) + nlj_active = FALSE; + else { + body = MMcdr(args); + if (endp(body)) { + vs_base = vs_top; + vs_push(Cnil); + } else { + top = vs_top; + do { + vs_top = top; + eval(MMcar(body)); + body = MMcdr(body); + } while (!endp(body)); + } + } + frs_pop(); + lex_env = oldlex; +} + +static void +FFN(Freturn_from)(object args) +{ + object lex_block; + frame_ptr fr; + + if (endp(args)) + FEtoo_few_argumentsF(args); + if (!endp(MMcdr(args)) && !endp(MMcddr(args))) + FEtoo_many_argumentsF(args); + lex_block = lex_block_sch(MMcar(args)); + if (MMnull(lex_block)) + FEerror("The block name ~S is undefined.", 1, MMcar(args)); + fr = frs_sch(MMcaddr(lex_block)); + if(fr == NULL) + FEerror("The block ~S is missing.", 1, MMcar(args)); + if(endp(MMcdr(args))) { + vs_base = vs_top; + vs_push(Cnil); + } + else + eval(MMcadr(args)); + unwind(fr, MMcaddr(lex_block)); + /* never reached */ +} + +static void +FFN(Freturn)(object args) +{ + object lex_block; + frame_ptr fr; + + if(!endp(args) && !endp(MMcdr(args))) + FEtoo_many_argumentsF(args); + lex_block = lex_block_sch(Cnil); + if (MMnull(lex_block)) + FEerror("The block name ~S is undefined.", 1, Cnil); + fr = frs_sch(MMcaddr(lex_block)); + if (fr == NULL) + FEerror("The block ~S is missing.", 1, Cnil); + if(endp(args)) { + vs_base = vs_top; + vs_push(Cnil); + } else + eval(MMcar(args)); + unwind(fr, MMcaddr(lex_block)); + /* never reached */ +} + +void +gcl_init_block(void) +{ + sLblock = make_special_form("BLOCK", Fblock); + enter_mark_origin(&sLblock); + make_special_form("RETURN-FROM", Freturn_from); + make_special_form("RETURN", Freturn); +} diff --git a/o/bsearch.c b/o/bsearch.c new file mode 100755 index 0000000..6f47c8f --- /dev/null +++ b/o/bsearch.c @@ -0,0 +1,30 @@ +#include +void * +bsearch(const void *key, const void *base, size_t nel, size_t keysize, int (*compar)(const void *, const void *)) +{ + char *beg=base; + char *end=base+keysize*(nel-1); + char *mid; + int cmp,tem; + if (nel==0) return 0; + cmp=(*compar)(beg,key); + if (cmp==0) return beg; + if (cmp> 0) return 0; + cmp= (*compar)(key,end); + if (cmp==0) return end; + if (cmp> 0)return 0; + /* key is in range from here on */ + start: + if (nel<=2) return 0; + tem=nel; + nel=nel/2; + mid=beg+(nel)*keysize; + cmp= (*compar)(key,mid); + if (cmp==0) return mid; + if (cmp< 0) {end=mid; nel++; + goto start;; + } + beg=mid; + nel=tem-(nel); + goto start; +} diff --git a/o/bzero.c b/o/bzero.c new file mode 100755 index 0000000..ba045a1 --- /dev/null +++ b/o/bzero.c @@ -0,0 +1,7 @@ +#include +void bzero(void *b, size_t length) +{ char *c=b; + + while(length-->0) + *c++ = 0; +} diff --git a/o/catch.c b/o/catch.c new file mode 100755 index 0000000..7897300 --- /dev/null +++ b/o/catch.c @@ -0,0 +1,165 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +/* + + catch.c + + dynamic non-local exit +*/ + +#include "include.h" + +static void +FFN(Fcatch)(VOL object args) +{ + + object *top = vs_top; + + if (endp(args)) + FEtoo_few_argumentsF(args); + eval(MMcar(args)); + vs_top = top; + vs_push(vs_base[0]); + frs_push(FRS_CATCH, vs_base[0]); + if (nlj_active) + nlj_active = FALSE; + else + Fprogn(MMcdr(args)); + frs_pop(); +} + +DEFUNM_NEW("ERROR-SET",object,fSerror_set,SI + ,1,1,NONE,OO,OO,OO,OO,(volatile object x0), + "Evaluates the FORM in the null environment. If the evaluation \ +of the FORM has successfully completed, SI:ERROR-SET returns NIL as the first \ +value and the result of the evaluation as the rest of the values. If, in the \ +course of the evaluation, a non-local jump from the FORM is atempted, \ +SI:ERROR-SET traps the jump and returns the corresponding jump tag as its \ +value.") + +{ + object *old_lex = lex_env; + + /* 1 args */ + vs_push(Cnil); + frs_push(FRS_CATCHALL, Cnil); + if (nlj_active) { + nlj_active = FALSE; + x0 = nlj_tag; + frs_pop(); + lex_env = old_lex; + RETURN1(x0); + } else { + lex_env = vs_top; + vs_push(Cnil); + vs_push(Cnil); + vs_push(Cnil); + x0 = Ieval(x0); + } + frs_pop(); + lex_env = old_lex; + {int i = fcall.nvalues; + if (i+1>=sizeof(fcall.values)/sizeof(*fcall.values)) + FEerror("Too many function call values",0); + while (i > 0) + { fcall.values[i+1] = fcall.values[i]; + i--;} + fcall.nvalues++; + fcall.values[1] = x0;} + return Cnil; +} + +static void +FFN(Funwind_protect)(VOL object args) +{ + + object *top = vs_top; + object *value_top; + if (endp(args)) + FEtoo_few_argumentsF(args); + frs_push(FRS_PROTECT, Cnil); + if (nlj_active) { + object tag = nlj_tag; + frame_ptr fr = nlj_fr; + + value_top = vs_top; + vs_top = top; + while(vs_bases.s_dbind->v.v_self[fix(i)])) +object sSPinit,sSPmemory; + +object +make_cfun(void (*self)(), object name, object data, char *start, int size) +{ + object cf; + + cf = alloc_object(t_cfun); + cf->cf.cf_self = self; + cf->cf.cf_name = name; + cf->cf.cf_data = data; + if(data && type_of(data)==t_cfdata) + { data->cfd.cfd_start=start; + data->cfd.cfd_size=size;} + else if(size) FEerror("Bad call to make_cfun",0); + return(cf); +} +object +make_sfun(object name, object (*self)(), int argd, object data) + + +/* object (*self)(); */ + +{object sfn; + + sfn = alloc_object(t_sfun); + if(argd >15) sfn->d.t = (int)t_gfun; + sfn->sfn.sfn_self = self; + sfn->sfn.sfn_name = name; + sfn->sfn.sfn_data = data; + sfn->sfn.sfn_argd = argd; + return(sfn); +} + +#define VFUN_MIN_ARGS(argd) (argd & 0xff) +#define VFUN_MAX_ARGS(argd) ((argd) >> 8) + +static object +make_vfun(object name, object (*self)(), int argd, object data) +{object vfn; + + vfn = alloc_object(t_vfun); + vfn->vfn.vfn_self = self; + vfn->vfn.vfn_name = name; + vfn->vfn.vfn_minargs = VFUN_MIN_ARGS(argd); + vfn->vfn.vfn_maxargs = VFUN_MAX_ARGS(argd); + vfn->vfn.vfn_data = data; + return(vfn); +} + +object +make_cclosure_new(void (*self)(), object name, object env, object data) +{ + object cc; + + cc = alloc_object(t_cclosure); + cc->cc.cc_self = self; + cc->cc.cc_name = name; + cc->cc.cc_env = env; + cc->cc.cc_data = data; + cc->cc.cc_turbo = NULL; + turbo_closure(cc); + return(cc); +} + + +object +make_cclosure(void (*self)(), object name, object env, object data, char *start, int size) +{ + if(data && type_of(data)==t_cfdata) + { data->cfd.cfd_start=start; + data->cfd.cfd_size=size;} + else if(size) FEerror("Bad call to make_cclosure",0); + return make_cclosure_new(self,name,env,data); + +} + + +DEFUN_NEW("MC",object,fSmc,SI + ,2,2,NONE,OO,OO,OO,OO,(object name,object address),"") +{ /* 2 args */ + dcheck_type(name,t_symbol); + dcheck_type(address,t_fixnum); + dcheck_type(sSPmemory->s.s_dbind,t_cfdata); + name=make_cclosure_new(PADDR(address),name,Cnil, + sSPmemory->s.s_dbind); + RETURN1(name); +} + +static object +MFsfun(object sym, object (*self)(), int argd, object data) +{object sfn; + if (type_of(sym)!=t_symbol) not_a_symbol(sym); + if (sym->s.s_sfdef != NOT_SPECIAL && sym->s.s_mflag) + sym->s.s_sfdef = NOT_SPECIAL; + sfn = make_sfun(sym,self,argd,data); + sym = clear_compiler_properties(sym,sfn); + sym->s.s_gfdef = sfn; + sym->s.s_mflag = FALSE; + return sym; +} + +DEFUN_NEW("MFSFUN",object,fSmfsfun,SI + ,3,3,NONE,OO,OO,OO,OO,(object name,object address,object argd),"") +{ /* 3 args */ + dcheck_type(address,t_fixnum); + return MFsfun(name,PADDR(address),fix(argd),sSPmemory->s.s_dbind);RETURN1(name); +} + + +static object +MFvfun(object sym, object (*self)(), int argd, object data) +{object vfn; + if (type_of(sym)!=t_symbol) not_a_symbol(sym); + if (sym->s.s_sfdef != NOT_SPECIAL && sym->s.s_mflag) + sym->s.s_sfdef = NOT_SPECIAL; + dcheck_type(data,t_cfdata); + vfn = make_vfun(sym,self,argd,data); + sym = clear_compiler_properties(sym,vfn); + sym->s.s_gfdef = vfn; + sym->s.s_mflag = FALSE; + return sym; +} + +DEFUN_NEW("MFVFUN",object,fSmfvfun,SI + ,3,3,NONE,OO,OO,OO,OO,(object name,object address,object argd),"") + +{ /* 3 args */ + MFvfun(name,PADDR(address),fix(argd),sSPmemory->s.s_dbind); + RETURN1(name); +} + + + +static object +MFvfun_key(object sym, object (*self)(), int argd, object data, struct key *keys) +{if (data) set_key_struct(keys,data); + return MFvfun(sym,self,argd,data); +} + +DEFUN_NEW("MFVFUN-KEY",object,fSmfvfun_key,SI + ,4,4,NONE,OO,OO,OO,OO,(object symbol,object address,object argd,object keys),"") +{ /* 4 args */ + MFvfun_key(symbol,PADDR(address),fix(argd),sSPmemory->s.s_dbind,PADDR(keys)); + RETURN1(symbol); +} + + +static object MFnew(object sym, void (*self)(), object data) +{ + object cf; + + if (type_of(sym) != t_symbol) + not_a_symbol(sym); + if (sym->s.s_sfdef != NOT_SPECIAL && sym->s.s_mflag) + sym->s.s_sfdef = NOT_SPECIAL; + cf = alloc_object(t_cfun); + cf->cf.cf_self = self; + cf->cf.cf_name = sym; + cf->cf.cf_data = data; + sym = clear_compiler_properties(sym,cf); + sym->s.s_gfdef = cf; + sym->s.s_mflag = FALSE; + return sym; +} + +DEFUN_NEW("MF",object,fSmf,SI + ,2,2,NONE,OO,OO,OO,OO,(object name,object addr),"") + +{ /* 2 args */ + MFnew(name,PADDR(addr),sSPmemory->s.s_dbind); + RETURN1(name); +} + + +/* static object */ +/* MF(object sym, void (*self)(), char *start, int size, object data) */ +/* { if(data && type_of(data)==t_cfdata) */ +/* { data->cfd.cfd_start=start; */ +/* data->cfd.cfd_size=size;} */ +/* else if(size) FEerror("Bad call to make_cfun",0); */ +/* return(MFnew(sym,self,data)); */ +/* } */ + +static object +MM(object sym, void (*self)(), char *start, int size, object data) +{ + object cf; + + if (type_of(sym) != t_symbol) + not_a_symbol(sym); + if (sym->s.s_sfdef != NOT_SPECIAL && sym->s.s_mflag) + sym->s.s_sfdef = NOT_SPECIAL; + cf = alloc_object(t_cfun); + cf->cf.cf_self = self; + cf->cf.cf_name = sym; + cf->cf.cf_data = data; + data->cfd.cfd_start=start; + data->cfd.cfd_size=size; + sym = clear_compiler_properties(sym,cf); + sym->s.s_gfdef = cf; + sym->s.s_mflag = TRUE; + return sym; +} + +DEFUN_NEW("MM",object,fSmm,SI + ,2,2,NONE,OO,OO,OO,OO,(object name,object addr),"") + +{ /* 2 args */ + MM(name,PADDR(addr), + /* bit wasteful to pass these in just to be reset to themselves..*/ + sSPmemory->s.s_dbind->cfd.cfd_start, + sSPmemory->s.s_dbind->cfd.cfd_size, + sSPmemory->s.s_dbind + );RETURN1(name); +} + + + +object +make_function_internal(char *s, void (*f)()) +{ + object x; + vs_mark; + + x = make_ordinary(s); + vs_push(x); + x->s.s_gfdef = make_cfun(f, x, Cnil, NULL, 0); + x->s.s_mflag = FALSE; + vs_reset; + return(x); +} + +object +make_si_sfun_internal(char *s, object (*f) (), int argd) { + object x= make_si_ordinary(s); + x->s.s_gfdef = make_sfun( x,f,argd, Cnil); + x->s.s_mflag = FALSE; + return(x); +} + +/* static object */ +/* make_si_vfun1(char *s, object (*f)(), int argd) */ +/* { object x= make_si_ordinary(s); */ +/* x->s.s_gfdef = make_vfun( x,f,argd, Cnil); */ +/* x->s.s_mflag = FALSE; */ +/* return(x); */ +/* } */ + + +object +make_si_function_internal(char *s, void (*f)()) +{ + object x; + vs_mark; + + x = make_si_ordinary(s); + vs_push(x); + x->s.s_gfdef = make_cfun(f, x, Cnil, NULL, 0); + x->s.s_mflag = FALSE; + vs_reset; + return(x); +} + + + + +object +make_special_form_internal(char *s, void (*f)()) +{ + object x; + x = make_ordinary(s); + x->s.s_sfdef = f; + return(x); +} + +DEFUN_NEW("COMPILED-FUNCTION-NAME",object,fScompiled_function_name,SI + ,1,1,NONE,OO,OO,OO,OO,(object fun),"") + +{ + /* 1 args */ + switch(type_of(fun)) { + case t_cfun: + case t_afun: + case t_closure: + case t_sfun: + case t_vfun: + case t_cclosure: + case t_gfun: + fun = fun->cf.cf_name; + break; + default: + FEerror("~S is not a compiled-function.", 1, fun); + }RETURN1(fun); +} + +void +turbo_closure(object fun) +{ + object l,*block; + int n; + + if(1)/*(fun->cc.cc_turbo==NULL)*/ + {BEGIN_NO_INTERRUPT; + for (n = 0, l = fun->cc.cc_env; !endp(l); n++, l = l->c.c_cdr); + { + block= AR_ALLOC(alloc_relblock,(1+n),object); + *block=make_fixnum(n); + fun->cc.cc_turbo = block+1; /* equivalent to &block[1] */ + for (n = 0, l = fun->cc.cc_env; !endp(l); n++, l = l->c.c_cdr) + fun->cc.cc_turbo[n] = l;} + END_NO_INTERRUPT; + } +} + +DEFUN_NEW("TURBO-CLOSURE",object,fSturbo_closure,SI + ,1,1,NONE,OO,OO,OO,OO,(object funobj),"") + +{ + /* 1 args */ + if (type_of(funobj) == t_cclosure) + turbo_closure(funobj); + RETURN1(funobj); +} + + + +void +gcl_init_cfun(void) +{ + +} + diff --git a/o/character.d b/o/character.d new file mode 100755 index 0000000..6d5f1b5 --- /dev/null +++ b/o/character.d @@ -0,0 +1,668 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +*/ + +/* + character.d + + character routines +*/ + +#include "include.h" + +@(defun standard_char_p (c) + int i; +@ + check_type_character(&c); + if (char_font(c) != 0 || char_bits(c) != 0) + @(return Cnil) + i = char_code(c); + if ((' ' <= i && i < '\177') || i == '\n') + @(return Ct) + @(return Cnil) +@) + +@(defun graphic_char_p (c) + int i; +@ + check_type_character(&c); + if (char_font(c) != 0 || char_bits(c) != 0) + @(return Cnil) + i = char_code(c); + if (' ' <= i && i < '\177') + @(return Ct) + @(return Cnil) +@) + +@(defun string_char_p (c) +@ + check_type_character(&c); + if (char_font(c) != 0 || char_bits(c) != 0) + @(return Cnil) + @(return Ct) +@) + +@(defun alpha_char_p (c) + int i; +@ + check_type_character(&c); + if (char_font(c) != 0 || char_bits(c) != 0) + @(return Cnil) + i = char_code(c); + if (isalpha(i)) + @(return Ct) + else + @(return Cnil) +@) + +@(defun upper_case_p (c) +@ + check_type_character(&c); + if (char_font(c) != 0 || char_bits(c) != 0) + @(return Cnil) + if (isUpper(char_code(c))) + @(return Ct) + @(return Cnil) +@) + +@(defun lower_case_p (c) +@ + check_type_character(&c); + if (char_font(c) != 0 || char_bits(c) != 0) + @(return Cnil) + if (isLower(char_code(c))) + @(return Ct) + @(return Cnil) +@) + +@(defun both_case_p (c) +@ + check_type_character(&c); + if (char_font(c) != 0 || char_bits(c) != 0) + @(return Cnil) + if (isUpper(char_code(c)) || isLower(char_code(c))) + @(return Ct) + else + @(return Cnil) +@) + +/* + Digitp(i, r) returns the weight of code i + as a digit of radix r. + If r > 36 or i is not a digit, -1 is returned. +*/ +int +digitp(i, r) +int i, r; +{ + if ('0' <= i && i <= '9' && 1 < r && i < '0' + r) + return(i - '0'); + if ('A' <= i && 10 < r && r <= 36 && i < 'A' + (r - 10)) + return(i - 'A' + 10); + if ('a' <= i && 10 < r && r <= 36 && i < 'a' + (r - 10)) + return(i - 'a' + 10); + return(-1); +} + +@(defun digit_char_p (c &optional (r `make_fixnum(10)`)) + int d; +@ + check_type_character(&c); + check_type_non_negative_integer(&r); + if (type_of(r) == t_bignum) + @(return Cnil) + if (char_font(c) != 0 || char_bits(c) != 0) + @(return Cnil) + d = digitp(char_code(c), fix(r)); + if (d < 0) + @(return Cnil) + @(return `make_fixnum(d)`) +@) + +@(defun alphanumericp (c) + int i; +@ + check_type_character(&c); + if (char_font(c) != 0 || char_bits(c) != 0) + @(return Cnil) + i = char_code(c); + if (isalphanum(i)) + @(return Ct) + else + @(return Cnil) +@) + +bool +char_eq(x, y) +object x, y; +{ + return(char_code(x) == char_code(y) + && char_bits(x) == char_bits(y) + && char_font(x) == char_font(y)); +} + +@(defun char_eq (c &rest) + int i; +@ + check_type_character(&c); + for (i = 0; i < narg; i++) + check_type_character(&vs_base[i]); + for (i = 1; i < narg; i++) + if (!char_eq(vs_base[i-1], vs_base[i])) + @(return Cnil) + @(return Ct) +@) + +@(defun char_neq (c &rest) + int i, j; +@ + check_type_character(&c); + for (i = 0; i < narg; i++) + check_type_character(&vs_base[i]); + if (narg == 0) + @(return Ct) + for (i = 1; i < narg; i++) + for (j = 0; j < i; j++) + if (char_eq(vs_base[j], vs_base[i])) + @(return Cnil) + @(return Ct) +@) + + +static int +char_cmp(x, y) +object x, y; +{ + if (char_font(x) < char_font(y)) + return(-1); + if (char_font(x) > char_font(y)) + return(1); + if (char_bits(x) < char_bits(y)) + return(-1); + if (char_bits(x) > char_bits(y)) + return(1); + if (char_code(x) < char_code(y)) + return(-1); + if (char_code(x) > char_code(y)) + return(1); + return(0); +} + +static void +Lchar_cmp(s, t) +int s, t; +{ + int narg, i; + + narg = vs_top - vs_base; + if (narg == 0) + too_few_arguments(); + for (i = 0; i < narg; i++) + check_type_character(&vs_base[i]); + for (i = 1; i < narg; i++) + if (s*char_cmp(vs_base[i], vs_base[i-1]) < t) { + vs_top = vs_base+1; + vs_base[0] = Cnil; + return; + } + vs_top = vs_base+1; + vs_base[0] = Ct; +} + +LFD(Lchar_l)() { Lchar_cmp( 1, 1); } +LFD(Lchar_g)() { Lchar_cmp(-1, 1); } +LFD(Lchar_le)() { Lchar_cmp( 1, 0); } +LFD(Lchar_ge)() { Lchar_cmp(-1, 0); } + + +bool +char_equal(x, y) +object x, y; +{ + int i, j; + + i = char_code(x); + j = char_code(y); + if (isLower(i)) + i -= 'a' - 'A'; + if (isLower(j)) + j -= 'a' - 'A'; + return(i == j); +} + +@(defun char_equal (c &rest) + int i; +@ + check_type_character(&c); + for (i = 0; i < narg; i++) + check_type_character(&vs_base[i]); + for (i = 1; i < narg; i++) + if (!char_equal(vs_base[i-1], vs_base[i])) + @(return Cnil) + @(return Ct) +@) + +@(defun char_not_equal (c &rest) + int i, j; +@ + check_type_character(&c); + for (i = 0; i < narg; i++) + check_type_character(&vs_base[i]); + for (i = 1; i < narg; i++) + for (j = 0; j < i; j++) + if (char_equal(vs_base[j], vs_base[i])) + @(return Cnil) + @(return Ct) +@) + + +static int +char_compare(x, y) +object x, y; +{ + int i, j; + + i = char_code(x); + j = char_code(y); + if (isLower(i)) + i -= 'a' - 'A'; + if (isLower(j)) + j -= 'a' - 'A'; + if (i < j) + return(-1); + else if (i == j) + return(0); + else + return(1); +} + +static void +Lchar_compare(s, t) +int s, t; +{ + int narg, i; + + narg = vs_top - vs_base; + if (narg == 0) + too_few_arguments(); + for (i = 0; i < narg; i++) + check_type_character(&vs_base[i]); + for (i = 1; i < narg; i++) + if (s*char_compare(vs_base[i], vs_base[i-1]) < t) { + vs_top = vs_base+1; + vs_base[0] = Cnil; + return; + } + vs_top = vs_base+1; + vs_base[0] = Ct; +} + +LFD(Lchar_lessp)() { Lchar_compare( 1, 1); } +LFD(Lchar_greaterp)() { Lchar_compare(-1, 1); } +LFD(Lchar_not_greaterp)() { Lchar_compare( 1, 0); } +LFD(Lchar_not_lessp)() { Lchar_compare(-1, 0); } + + +object +coerce_to_character(x) +object x; +{ +BEGIN: + switch (type_of(x)) { + case t_fixnum: + if (0 <= fix(x) && fix(x) < CHCODELIM) + return(code_char(fix(x))); + break; + + case t_character: + return(x); + + case t_symbol: + case t_string: + if (x->st.st_fillp == 1) + return(code_char(x->ust.ust_self[0])); + break; + default: + break; + } + vs_push(x); + x = wrong_type_argument(sLcharacter, x); + vs_popp; + goto BEGIN; +} + +@(defun character (x) +@ + @(return `coerce_to_character(x)`) +@) + +@(defun char_code (c) +@ + check_type_character(&c); + @(return `make_fixnum(char_code(c))`) +@) + +@(defun char_bits (c) +@ + check_type_character(&c); + @(return `small_fixnum(char_bits(c))`) +@) + +@(defun char_font (c) +@ + check_type_character(&c); + @(return `small_fixnum(char_font(c))`) +@) + +@(defun code_char (c &o (b `make_fixnum(0)`) (f `make_fixnum(0)`)) + object x; +@ + check_type_non_negative_integer(&c); + check_type_non_negative_integer(&b); + check_type_non_negative_integer(&f); + if (type_of(c) == t_bignum) + @(return Cnil) + if (type_of(b) == t_bignum) + @(return Cnil) + if (type_of(f) == t_bignum) + @(return Cnil) + if (fix(c)>=CHCODELIM || fix(b)>=CHBITSLIM || fix(f)>=CHFONTLIM) + @(return Cnil) + if (fix(b) == 0 && fix(f) == 0) + @(return `code_char(fix(c))`) + x = alloc_object(t_character); + char_code(x) = fix(c); + char_bits(x) = fix(b); + char_font(x) = fix(f); + @(return x) +@) + +@(defun make_char (c &o (b `make_fixnum(0)`) (f `make_fixnum(0)`)) + object x; + int code; +@ + check_type_character(&c); + code = char_code(c); + check_type_non_negative_integer(&b); + check_type_non_negative_integer(&f); + if (type_of(b) == t_bignum) + @(return Cnil) + if (type_of(f) == t_bignum) + @(return Cnil) + if (fix(b)>=CHBITSLIM || fix(f)>=CHFONTLIM) + @(return Cnil) + if (fix(b) == 0 && fix(f) == 0) + @(return `code_char(code)`) + x = alloc_object(t_character); + char_code(x) = code; + char_bits(x) = fix(b); + char_font(x) = fix(f); + @(return x) +@) + +@(defun char_upcase (c) +@ + check_type_character(&c); + if (char_font(c) != 0 || char_bits(c) != 0) + @(return c) + if (isLower(char_code(c))) + @(return `code_char(char_code(c) - ('a' - 'A'))`) + else + @(return c) +@) + +@(defun char_downcase (c) +@ + check_type_character(&c); + if (char_font(c) != 0 || char_bits(c) != 0) + @(return Cnil) + if (isUpper(char_code(c))) + @(return `code_char(char_code(c) + ('a' - 'A'))`) + else + @(return c) +@) + +int +digit_weight(w, r) +int w, r; +{ + if (r < 2 || r > 36 || w < 0 || w >= r) + return(-1); + if (w < 10) + return(w + '0'); + else + return(w - 10 + 'A'); +} + +@(defun digit_char (w + &optional + (r `make_fixnum(10)`) + (f `make_fixnum(0)`)) + object x; + int dw; +@ + check_type_non_negative_integer(&w); + check_type_non_negative_integer(&r); + check_type_non_negative_integer(&f); + if (type_of(w) == t_bignum) + @(return Cnil) + if (type_of(r) == t_bignum) + @(return Cnil) + if (type_of(f) == t_bignum) + @(return Cnil) + dw = digit_weight(fix(w), fix(r)); + if (dw < 0) + @(return Cnil) + if (fix(f) >= CHFONTLIM) + @(return Cnil) + if (fix(f) == 0) + @(return `code_char(dw)`) + x = alloc_object(t_character); + char_code(x) = dw; + char_bits(x) = 0; + char_font(x) = fix(f); + @(return x) +@) + +@(defun char_int (c) + int i; +@ + check_type_character(&c); + i = (char_font(c)*CHBITSLIM + char_bits(c))*CHCODELIM + + char_code(c); + @(return `make_fixnum(i)`) +@) + +@(defun int_char (x) + int i, c, b, f; +@ + check_type_non_negative_integer(&x); + if (type_of(x) == t_bignum) + @(return Cnil) + i = fix(x); + c = i % CHCODELIM; + i /= CHCODELIM; + b = i % CHBITSLIM; + i /= CHBITSLIM; + f = i % CHFONTLIM; + i /= CHFONTLIM; + if (i > 0) + @(return Cnil) + if (b == 0 && f == 0) + @(return `code_char(c)`) + x = alloc_object(t_character); + char_code(x) = c; + char_bits(x) = b; + char_font(x) = f; + @(return x) +@) + +@(defun char_name (c) +@ + check_type_character(&c); + if (char_bits(c) != 0 || char_font(c) != 0) + @(return Cnil) + switch (char_code(c)) { + case '\r': + @(return STreturn) + + case ' ': + @(return STspace) + + case '\177': + @(return STrubout) + + case '\f': + @(return STpage) + + case '\t': + @(return STtab) + + case '\b': + @(return STbackspace) + + case '\n': + @(return STnewline) + } + @(return Cnil) +@) + +@(defun name_char (s) +@ + s = coerce_to_string(s); + if (string_equal(s, STreturn)) + @(return `code_char('\r')`) + if (string_equal(s, STspace)) + @(return `code_char(' ')`) + if (string_equal(s, STrubout)) + @(return `code_char('\177')`) + if (string_equal(s, STpage)) + @(return `code_char('\f')`) + if (string_equal(s, STtab)) + @(return `code_char('\t')`) + if (string_equal(s, STbackspace)) + @(return `code_char('\b')`) + if (string_equal(s, STlinefeed) || string_equal(s, STnewline)) + @(return `code_char('\n')`) + @(return Cnil) +@) + +@(defun char_bit (c n) +@ + check_type_character(&c); + FEerror("Cannot get char-bit of ~S.", 1, c); +@) + +@(defun set_char_bit (c n v) +@ + check_type_character(&c); + FEerror("Cannot set char-bit of ~S.", 1, c); +@) + +void +gcl_init_character() +{ + int i; + + for (i = 0; i < CHCODELIM; i++) { + object x=(object)(character_table+i); + x->fw=0; + set_type_of(x,t_character); + /* character_table[i].ch.t = (short)t_character; */ + character_table[i].ch.ch_code = i; + character_table[i].ch.ch_font = 0; + character_table[i].ch.ch_bits = 0; + } +#ifdef AV + for (i = -128; i < 0; i++) { + character_table[i].ch.t = (short)t_character; + character_table[i].ch.ch_code = i+CHCODELIM; + character_table[i].ch.ch_font = 0; + character_table[i].ch.ch_bits = 0; + } +#endif + + make_constant("CHAR-CODE-LIMIT", make_fixnum(CHCODELIM)); + make_constant("CHAR-FONT-LIMIT", make_fixnum(CHFONTLIM)); + make_constant("CHAR-BITS-LIMIT", make_fixnum(CHBITSLIM)); + + STreturn = make_simple_string("Return"); + enter_mark_origin(&STreturn); + STspace = make_simple_string("Space"); + enter_mark_origin(&STspace); + STrubout = make_simple_string("Rubout"); + enter_mark_origin(&STrubout); + STpage = make_simple_string("Page"); + enter_mark_origin(&STpage); + STtab = make_simple_string("Tab"); + enter_mark_origin(&STtab); + STbackspace = make_simple_string("Backspace"); + enter_mark_origin(&STbackspace); + STlinefeed = make_simple_string("Linefeed"); + enter_mark_origin(&STlinefeed); + + STnewline = make_simple_string("Newline"); + enter_mark_origin(&STnewline); + + make_constant("CHAR-CONTROL-BIT", make_fixnum(0)); + make_constant("CHAR-META-BIT", make_fixnum(0)); + make_constant("CHAR-SUPER-BIT", make_fixnum(0)); + make_constant("CHAR-HYPER-BIT", make_fixnum(0)); +} + +void +gcl_init_character_function() +{ + make_function("STANDARD-CHAR-P", Lstandard_char_p); + make_function("GRAPHIC-CHAR-P", Lgraphic_char_p); + make_function("STRING-CHAR-P", Lstring_char_p); + make_function("ALPHA-CHAR-P", Lalpha_char_p); + make_function("UPPER-CASE-P", Lupper_case_p); + make_function("LOWER-CASE-P", Llower_case_p); + make_function("BOTH-CASE-P", Lboth_case_p); + make_function("DIGIT-CHAR-P", Ldigit_char_p); + make_function("ALPHANUMERICP", Lalphanumericp); + make_function("CHAR=", Lchar_eq); + make_function("CHAR/=", Lchar_neq); + make_function("CHAR<", Lchar_l); + make_function("CHAR>", Lchar_g); + make_function("CHAR<=", Lchar_le); + make_function("CHAR>=", Lchar_ge); + make_function("CHAR-EQUAL", Lchar_equal); + make_function("CHAR-NOT-EQUAL", Lchar_not_equal); + make_function("CHAR-LESSP", Lchar_lessp); + make_function("CHAR-GREATERP", Lchar_greaterp); + make_function("CHAR-NOT-GREATERP", Lchar_not_greaterp); + make_function("CHAR-NOT-LESSP", Lchar_not_lessp); + make_function("CHARACTER", Lcharacter); + make_function("CHAR-CODE", Lchar_code); + make_function("CHAR-BITS", Lchar_bits); + make_function("CHAR-FONT", Lchar_font); + make_function("CODE-CHAR", Lcode_char); + make_function("MAKE-CHAR", Lmake_char); + make_function("CHAR-UPCASE", Lchar_upcase); + make_function("CHAR-DOWNCASE", Lchar_downcase); + make_function("DIGIT-CHAR", Ldigit_char); + make_function("CHAR-INT", Lchar_int); + make_function("INT-CHAR", Lint_char); + make_function("CHAR-NAME", Lchar_name); + make_function("NAME-CHAR", Lname_char); + make_function("CHAR-BIT", Lchar_bit); + make_function("SET-CHAR-BIT", Lset_char_bit); +} diff --git a/o/clxsocket.c b/o/clxsocket.c new file mode 100755 index 0000000..a54c72a --- /dev/null +++ b/o/clxsocket.c @@ -0,0 +1,166 @@ +/* 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. + * + * This code was cribbed from lib/X/XConnDis.c. + * Compile using + * % cc -c socket.c -DUNIXCONN + */ + +#include "include.h" + +#ifdef HAVE_X11 + + +#undef PAGESIZE +#undef MAXPATHLEN +#ifndef NO_UNIXCONN +#define UNIXCONN +#endif + +#include +#include +#include +#include +#include + +#include +#include +#include +#include + +#ifndef hpux +#include +#endif + +extern int errno; /* Certain (broken) OS's don't have this */ + /* decl in errno.h */ + +#ifdef UNIXCONN +#include +#ifndef X_UNIX_PATH +#ifdef hpux +#define X_UNIX_PATH "/usr/spool/sockets/X11/" +#define OLD_UNIX_PATH "/tmp/.X11-unix/X" +#else /* hpux */ +#define X_UNIX_PATH "/tmp/.X11-unix/X" +#endif /* hpux */ +#endif /* X_UNIX_PATH */ +#endif /* UNIXCONN */ + + + +/* + * Attempts to connect to server, given host and display. Returns file + * descriptor (network socket) or 0 if connection fails. + */ + +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 hostent *host_ptr; + int addrlen; /* length of address */ +#ifdef UNIXCONN + struct sockaddr_un unaddr; /* UNIX socket address. */ +#endif + extern char *getenv(); + extern struct hostent *gethostbyname(); + 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) { +#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); + 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 +#endif /* hpux */ + 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; +#ifdef hpux + (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)); +#endif /* hpux */ + } + else + { + inaddr.sin_family = AF_INET; + } + addr = (struct sockaddr *) &inaddr; + addrlen = sizeof (struct sockaddr_in); + inaddr.sin_port = display + X_TCP_PORT; + inaddr.sin_port = htons(inaddr.sin_port); + /* + * Open the network connection. + */ + if ((fd = socket((int) addr->sa_family, SOCK_STREAM, 0)) < 0){ + 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)); + } +#endif + } + + /* + * 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 + */ + while (connect(fd, addr, addrlen) == -1) { + if (errno != EINTR) { + (void) close (fd); + return(-1); /* errno set by system call. */ + } + } + } + /* + * Return the id if the connection succeeded. + */ + return(fd); +} +#endif diff --git a/o/cmac.c b/o/cmac.c new file mode 100755 index 0000000..eec704e --- /dev/null +++ b/o/cmac.c @@ -0,0 +1,241 @@ +#define NEED_MP_H +#ifndef FIRSTWORD +#include "include.h" +#endif +#include "num_include.h" + +/* #include "arith.h" */ + + + +/* I believe the instructions used here are ok for 68010.. */ + +#ifdef MC68K +#define MC68020 +#endif + +/* static for gnuwin95 the save routine is not saving statics... */ + +object *gclModulus; +#define FIXNUMP(x) (type_of(x)==t_fixnum) + +/* Note: the gclModulus is guaranteed > 0 */ + +#define FIX_MOD(X,MOD) {register fixnum MOD_2; \ + if (X > (MOD_2=(MOD >>1))) X=X-MOD; else \ + if (X < -MOD_2) X=X+MOD;} + + +object ctimes(object a, object b),cplus(object a, object b),cdifference(object a, object b),cmod(object x); + +object make_integer(__mpz_struct *u); + +#define our_minus(a,b) ((FIXNUMP(a)&&FIXNUMP(b))?fixnum_sub(fix(a),fix(b)): \ + number_minus(a,b)) +#define our_plus(a,b) ((FIXNUMP(a)&&FIXNUMP(b))?fixnum_add(fix(a),fix(b)): \ + number_plus(a,b)) +#define our_times(a,b) number_times(a,b) + +/* fix (and check) this on 64 bit machines, where long is the long long */ +#ifdef HAVE_LONG_LONG +static int +dblrem(int a, int b, int mod) +{ + return (int)(((long long int)a*(long long int)b)%(long long int) mod); +} +#else + +static int +dblrem(a,b,mod) +int a,b,mod; +{int h,sign; + if (a<0) + {a= -a; sign= (b<0)? (b= -b,1) :-1;} + else { sign= (b<0) ? (b= -b,-1) : 1;} + { mp_limb_t ar[2],q[2],aa; + aa = a; + ar[1]=mpn_mul_1(ar,&aa,1,b); + h = mpn_divrem_1(q,0,ar,2,mod); + return ((sign<0) ? -h :h); + } +} +#endif + +/* #if sizeof(fixnum) != sizeof(mp_limb_t) */ +/* #error fixnum mp_limb_t size mismatch */ +/* #endif */ + +static fixnum +fdblrem(fixnum a,fixnum b,fixnum mod) { + + fixnum h,sign; + mp_limb_t ar[2],q[2],aa; + + if (a<0) { + a= -a; + sign= (b<0) ? (b= -b,1) : -1; + } else + sign= (b<0) ? (b= -b,-1) : 1; + + aa = a; + ar[1]=mpn_mul_1(ar,&aa,1,b); + h = mpn_divrem_1(q,0,ar,2,mod); + + return ((sign<0) ? -h :h); + +} + +object +cmod(object x) { + + register object mod = *gclModulus; + + if (mod==Cnil) + return(x); + + else if ((type_of(mod)==t_fixnum && type_of(x)==t_fixnum)) { + + register fixnum xx,mm=fix(mod); + + if (mm==2) + return small_fixnum((fix(x)&1)); + + xx=(fix(x)%mm); + FIX_MOD(xx,mm); + return make_fixnum(xx); + + } else { + + object rp,mod2; + int compare; + + integer_quotient_remainder_1(x,mod,NULL,&rp,0);/*FIXME*/ + mod2=integer_fix_shift(mod,-1); + compare = number_compare(rp,small_fixnum(0)); + if (compare >= 0) { + + compare=number_compare(rp,mod2); + if (compare > 0) rp=number_minus(rp,mod); + + } else if (number_compare(number_negate(mod2), rp) > 0) + rp = number_plus(rp,mod); + + return rp; + + } + +} + + +object +ctimes(object a, object b) { + + object mod = *gclModulus; + + if (FIXNUMP(mod)) { + + register fixnum res, m=fix(mod); + + if (sizeof(fixnum)==sizeof(int) || (m>>(sizeof(int)*8)==(m>>(sizeof(fixnum)*8-1)))) + + res=dblrem(fix(a),fix(b),m); + + else + + res=fdblrem(fix(a),fix(b),m); + + FIX_MOD(res,m); + return make_fixnum(res); + + } else if (mod==Cnil) + return(our_times(a,b)); + + return cmod(number_times(a,b)); + +} + + +#define SMALL_MODULUS_P(mod) (FIXNUMP(mod) && (fix(mod) < (MOST_POSITIVE_FIX)/2)) + +object +cdifference(object a, object b) { + + object mod = *gclModulus; + + if (SMALL_MODULUS_P(mod)) { + + register fixnum res,m; + + res=((fix(a)-fix(b))%(m=fix(mod))); + FIX_MOD(res,m); + return make_fixnum(res); + + } else if (mod==Cnil) + return (our_minus(a,b)); + + else return(cmod(number_minus(a,b))); + +} + +object +cplus(object a, object b) { + + object mod = *gclModulus; + + if (SMALL_MODULUS_P(mod)) { + + register fixnum res,m; + + res=((fix(a)+fix(b))%(m=fix(mod))); + FIX_MOD(res,m); + return make_fixnum(res); + + } else if (mod==Cnil) + return (our_plus(a,b)); + + return(cmod(number_plus(a,b))); + +} + + +DEFUN_NEW("CMOD",object,fScmod,SI,1,1,NONE,OO,OO,OO,OO,(object num),"") { + + /* 1 args */ + num=cmod(num); + RETURN1(num); + +} + + +DEFUN_NEW("CPLUS",object,fScplus,SI,2,2,NONE,OO,OO,OO,OO,(object x0,object x1),"") { + + /* 2 args */ + + x0 = cplus(x0,x1); + RETURN1( x0 ); + +} + + +DEFUN_NEW("CTIMES",object,fSctimes,SI,2,2,NONE,OO,OO,OO,OO,(object x0,object x1),"") { + + /* 2 args */ + x0=ctimes(x0,x1); + RETURN1(x0); +} + + +DEFUN_NEW("CDIFFERENCE",object,fScdifference,SI,2,2,NONE,OO,OO,OO,OO,(object x0,object x1),"") { + + /* 2 args */ + x0=cdifference(x0,x1); + RETURN1(x0); + +} + +void +gcl_init_cmac(void) { + + gclModulus = (&((make_si_special("MODULUS",Cnil))->s.s_dbind)); + +} diff --git a/o/cmpaux.c b/o/cmpaux.c new file mode 100755 index 0000000..d2d75ed --- /dev/null +++ b/o/cmpaux.c @@ -0,0 +1,578 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +/* + + cmpaux.c +*/ + +#include +#include + +#include +#include +#include +#define NEED_MP_H +#include "include.h" +#define dcheck_type(a,b) check_type(a,b) + +#include "page.h" + +DEFUNO_NEW("SPECIALP",object,fSspecialp,SI + ,1,1,NONE,OO,OO,OO,OO,void,siLspecialp,(object sym),"") +{ + /* 1 args */ + if (type_of(sym) == t_symbol && + (enum stype)sym->s.s_stype == stp_special) + sym = Ct; + else + sym = Cnil; + RETURN1(sym); +} + +DEF_ORDINARY("DEBUG",sSdebug,SI,""); + +DEFUN_NEW("DEFVAR1",object,fSdefvar1,SI + ,2,3,NONE,OO,OO,OO,OO,(object sym,object val,...),"") +{ int n=VFUN_NARGS; + object doc; + va_list ap; + { va_start(ap,val); + if (n>=3) doc=va_arg(ap,object);else goto LDEFAULT3; + goto LEND_VARARG; + LDEFAULT3: doc = Cnil; + LEND_VARARG: va_end(ap);} + + CHECK_ARG_RANGE(2,3); + if(sym->s.s_dbind==0 && n > 1) + sym->s.s_dbind= val; + sym->s.s_stype=(short)stp_special; + if(n > 2) + putprop(sym,doc,sSvariable_documentation); + RETURN1(sym); + } + + +DEFUN_NEW("DEBUG",object,fSdebug,SI + ,2,2,NONE,OO,OO,OO,OO,(object sym,object val),"") +{ /* 2 args */ + putprop(sym,val,sSdebug); + RETURN1(sym); +} + + +DEFUN_NEW("SETVV",object,fSsetvv,SI + ,2,2,NONE,OO,OO,OO,OO,(object index,object val),"") +{ /* 2 args */ + if(type_of(sSPmemory->s.s_dbind)==t_cfdata) + sSPmemory->s.s_dbind->cfd.cfd_self[fix(index)]=val; + else FEerror("setvv called outside %init",0); + RETURN1(index); +} + +DEF_ORDINARY("%MEMORY",sSPmemory,SI,""); +DEF_ORDINARY("%INIT",sSPinit,SI,""); + +/* void Lidentity(void); */ +void +gcl_init_cmpaux(void) +{ + + + /* real one defined in predlib.lsp, need this for bootstrap */ +/* make_si_function("WARN-VERSION",Lidentity); */ + +} + + +/* Now inlined directly by optimizer */ +/* int */ +/* ifloor(int x, int y) */ +/* { */ +/* if (y == 0) { */ +/* FEerror("Zero divizor", 0); */ +/* return 0; */ +/* } */ +/* if (y > 0) { */ +/* if (x >= 0) */ +/* return(x/y); */ +/* else */ + /* FIXME, deal with possible overflow here*/ +/* return(-((-x-1))/y-1); */ +/* } */ +/* if (x >= 0) */ + /* FIXME, deal with possible overflow here*/ +/* return(-((x-1)/(-y))-1); */ +/* else */ +/* return((-x)/(-y)); */ +/* } */ + +/* int */ +/* imod(int x, int y) */ +/* { */ +/* return(x - ifloor(x, y)*y); */ +/* } */ + +/* static void */ +/* set_VV(object *, int, object); */ + +/* static void */ +/* set_VV_data(object *VV, int n, object data, char *start, int size) */ +/* {set_VV(VV,n,data); */ +/* data->cfd.cfd_start=start; */ +/* data->cfd.cfd_size = size; */ +/* } */ + +/* static void */ +/* set_VV(object *VV, int n, object data) */ +/* { */ +/* object *p, *q; */ + +/* p = VV; */ +/* q = data->v.v_self; */ +/* while (n-- > 0) */ +/* *p++ = *q++; */ +/* data->cfd.cfd_self = VV; */ +/* } */ + +/* + Conversions to C +*/ + +char +object_to_char(object x) +{ + int c=0; + switch (type_of(x)) { + case t_fixnum: + c = fix(x); break; + case t_bignum: + {object *to = vs_top; + vs_push(x); + vs_push(small_fixnum(0xff)); + Llogand(); + x = vs_base[0]; + vs_top = to; + c = (char) fix(x); + break; + } + case t_character: + c = char_code(x); break; + default: + FEerror("~S cannot be coerce to a C char.", 1, x); + } + return(c); +} + +int +object_to_int(object x) +{ + int i=0; + + switch (type_of(x)) { + case t_character: + i = char_code(x); break; + case t_fixnum: + i = fix(x); break; + case t_bignum: + i = number_to_double(x); + break; + case t_ratio: + i = number_to_double(x); break; + case t_shortfloat: + i = sf(x); break; + case t_longfloat: + i = lf(x); break; + default: + FEerror("~S cannot be coerce to a C int.", 1, x); + } + return(i); +} + +fixnum +object_to_fixnum(object x) +{ + fixnum i=0; + + switch (type_of(x)) { + case t_character: + i = char_code(x); break; + case t_fixnum: + i = fix(x); break; + case t_bignum: + i = number_to_double(x); + break; + case t_ratio: + i = number_to_double(x); break; + case t_shortfloat: + i = sf(x); break; + case t_longfloat: + i = lf(x); break; + default: + FEerror("~S cannot be coerce to a C int.", 1, x); + } + return(i); +} + +float +object_to_float(object x) +{ + float f=0.0; + + switch (type_of(x)) { + case t_character: + f = char_code(x); break; + case t_fixnum: + f = fix(x); break; + case t_bignum: + case t_ratio: + f = number_to_double(x); break; + case t_shortfloat: + f = sf(x); break; + case t_longfloat: + f = lf(x); break; + default: + FEerror("~S cannot be coerce to a C float.", 1, x); + } + return(f); +} + +double +object_to_double(object x) +{ + double d=0.0; + + switch (type_of(x)) { + case t_character: + d = char_code(x); break; + case t_fixnum: + d = fix(x); break; + case t_bignum: + case t_ratio: + d = number_to_double(x); break; + case t_shortfloat: + d = sf(x); break; + case t_longfloat: + d = lf(x); break; + default: + FEerror("~S cannot be coerce to a C double.", 1, x); + } + return(d); +} + +/* this may allocate storage. The user can prevent this + by providing a string will fillpointer < length and + have a null character in the fillpointer position. */ + +char * +object_to_string(object x) { + + unsigned int leng; + char *res; + + if (type_of(x)!=t_string) FEwrong_type_argument(sLstring,x); + leng= x->st.st_fillp; + /* user has thoughtfully provided a null terminated string ! */ + if (leng > 0 && leng < x->st.st_dim && x->st.st_self[leng]==0) + return x->st.st_self; + + if (x->st.st_dim == leng && leng % sizeof(object) && MAYBE_DATA_P(x->st.st_self)) { + x->st.st_self[leng] = 0; + return x->st.st_self; + } + + res=malloc(leng+1); + bcopy(x->st.st_self,res,leng); + res[leng]=0; + return res; + +} + +/* typedef int (*FUNC)(); */ + +/* perform the actual invocation of the init function durint a fasload + init_address is the offset from the place in memory where the code is loaded + in. In most systems this will be 0. + The new style fasl vector MUST end with an entry (si::%init f1 f2 .....) + where f1 f2 are forms to be evaled. +*/ + +/* #ifdef CLEAR_CACHE */ +/* static int */ +/* sigh(int sig,long code,void *scp, char *addr) { */ + +/* fprintf(stderr,"Received SIGILL at %p\n",((siginfo_t *)code)->si_addr); */ +/* exit(1); */ +/* } */ +/* #endif */ + +void +call_init(int init_address, object memory, object fasl_vec, FUNC fptr) +{object form; + FUNC at; +/* #ifdef CLEAR_CACHE */ +/* static int n; */ +/* static sigset_t ss; */ + +/* if (!n) { */ +/* struct sigaction sa={{(void *)sigh},{{0}},SA_RESTART|SA_SIGINFO,NULL}; */ + +/* sigaction(SIGILL,&sa,NULL); */ +/* sigemptyset(&ss); */ +/* sigaddset(&ss,SIGILL); */ +/* sigprocmask(SIG_BLOCK,&ss,NULL); */ +/* n=1; */ +/* } */ +/* #endif */ + + + check_type(fasl_vec,t_vector); + form=(fasl_vec->v.v_self[fasl_vec->v.v_fillp -1]); + + if (fptr) at = fptr; + else + at=(FUNC)(memory->cfd.cfd_start+ init_address ); + +#ifdef VERIFY_INIT + VERIFY_INIT +#endif + + if (type_of(form)==t_cons && + form->c.c_car == sSPinit) + {bds_bind(sSPinit,fasl_vec); + bds_bind(sSPmemory,memory); +/* #ifdef CLEAR_CACHE */ +/* sigprocmask(SIG_UNBLOCK,&ss,NULL); */ +/* #endif */ + (*at)(); +/* #ifdef CLEAR_CACHE */ +/* sigprocmask(SIG_BLOCK,&ss,NULL); */ +/* #endif */ + bds_unwind1; + bds_unwind1; + } + else + /* old style three arg init, with all init being done by C code. */ + {memory->cfd.cfd_self = fasl_vec->v.v_self; + memory->cfd.cfd_fillp = fasl_vec->v.v_fillp; +/* #ifdef CLEAR_CACHE */ +/* sigprocmask(SIG_UNBLOCK,&ss,NULL); */ +/* #endif */ + (*at)(memory->cfd.cfd_start, memory->cfd.cfd_size, memory); +/* #ifdef CLEAR_CACHE */ +/* sigprocmask(SIG_BLOCK,&ss,NULL); */ +/* #endif */ +}} + +/* statVV is the address of some static storage, which is used by the + cfunctions to refer to global variables,.. + Initially it holds a number of addresses. We also have sSPmemory->s.s_dbind + which points to a vector of lisp constants. We switch the + fn addresses and lisp constants. We follow this convoluted path, + since we don't wish to have a separate block of data space allocated + in the object module simply to temporarily have access to the + actual function addresses during load. + + */ + +void +do_init(object *statVV) +{object fasl_vec=sSPinit->s.s_dbind; + object data = sSPmemory->s.s_dbind; + {object *p,*q,y; + int n=fasl_vec->v.v_fillp -1; + int i; + object form; + check_type(fasl_vec,t_vector); + form = fasl_vec->v.v_self[n]; + dcheck_type(form,t_cons); + + + /* switch SPinit to point to a vector of function addresses */ + + fasl_vec->v.v_elttype = aet_fix; + fasl_vec->v.v_dim *= (sizeof(object)/sizeof(fixnum)); + fasl_vec->v.v_fillp *= (sizeof(object)/sizeof(fixnum)); + + /* swap the entries */ + p = fasl_vec->v.v_self; + + q = statVV; + for (i=0; i<=n ; i++) + { y = *p; + *p++ = *q; + *q++ = y; + } + + data->cfd.cfd_self = statVV; + data->cfd.cfd_fillp= n+1; + statVV[n] = data; + + + /* So now the fasl_vec is a fixnum array, containing random addresses of c + functions and other stuff from the compiled code. + data is what it wants to be for the init + */ + /* Now we can run the forms f1 f2 in form= (%init f1 f2 ...) */ + + form=form->c.c_cdr; + {object *top=vs_top; + + for(i=0 ; i< form->v.v_fillp; i++) + { + eval(form->v.v_self[i]); + vs_top=top; + } + } +}} + +#ifdef DOS +#define PATH_LIM 8 +#define TYPE_LIM 3 +char * +fix_path_string_dos(s) +char *s; +{char buf[200]; + char *p=s,*q=buf; + int i=PATH_LIM; + while(*p) + { + if (IS_DIR_SEPARATOR(*p)) i=PATH_LIM; + else if (*p == '.') i = TYPE_LIM; + else i--; + if (i>=0) *q++ = *p; + p++;} + *q = 0; + strcpy(s,buf); + return s; +} + +#endif + +void +gcl_init_or_load1(void (*fn)(void),const char *file) { + + if (file[strlen(file)-1]=='o') { + + object memory; + object fasl_data; + file=FIX_PATH_STRING(file); + + memory=alloc_object(t_cfdata); + memory->cfd.cfd_self=0; + memory->cfd.cfd_fillp=0; + memory->cfd.cfd_size = 0; + memory->cfd.cfd_start= (char *)fn; + printf("Initializing %s\n",file); fflush(stdout); + fasl_data = read_fasl_data(file); + call_init(0,memory,fasl_data,0); + + } else { + printf("loading %s\n",file); + fflush(stdout); + load(file); + } + +} + +DEFUN_NEW("INIT-CMP-ANON", object, fSinit_cmp_anon, SI, 0, 0, + NONE, OO, OO, OO,OO,(void), + "Initialize previously compiled and linked anonymous function from the \ +.text section of the running executable. This function is inherently \ +dangerous, and is meant as a work-around to facilitate the production \ +of an ansi GCL image on systems which must currently link using \ +dlopen. On such systems, it is imposible to compile and load \ +anonymous functions as part of the initialization sequence of the lisp \ +image, as is done in pcl, and preserve that function across a \ +save-system call. The approach here is to provide a flag to GCL's \ +compile function which will direct the algorithm to forgo \ +recompilation and loading in favor of initialization via this \ +function.") +{ + + int i; + + i=gcl_init_cmp_anon(); + if (i<0) + FEerror("No such anonymous function",0); + + return i ? Cnil : Ct; + +} + +object +find_init_name1(char *s,unsigned len) { + +#ifdef _WIN32 + + char *tmp; + + if (len) { + tmp=alloca(len+1); + memcpy(tmp,s,len); + tmp[len]=0; + } else + tmp=s; + + return find_init_string(tmp); + +#else +/* These functions have no relevance on Windows + * as dlopen and friends don't exist in that part of Cyberspace. */ + + struct stat ss; + char *tmp,*q; + FILE *f; + + if (len) { + tmp=alloca(len+1); + memcpy(tmp,s,len); + tmp[len]=0; + } else + tmp=s; + if (stat(tmp,&ss)) + FEerror("File ~a does not exist",1,make_simple_string(tmp)); + if (!(f=fopen(tmp,"rb"))) + FEerror("Cannot open ~a for binary reading",1,make_simple_string(tmp)); + tmp=alloca(ss.st_size+1); + if (fread(tmp,1,ss.st_size,f)!=ss.st_size) + FEerror("Error reading binary file",0); + fclose(f); + for (s=tmp+1;stmp && (s[-1]=='_' ? (s>tmp+1 && s[-2]) : s[-1]))); + q=strstr(s+1,"init_"),s=q ? q : s+strlen(s)+1); + if (strncmp(s,"init_",5)) + FEerror("Init name not found",0); + return make_simple_string(s); +#endif /* _WIN32 */ + +} + + +DEFUN_NEW("FIND-INIT-NAME", object, fSfind_init_name, SI, 1, 1, + NONE, OO, OO, OO,OO,(object namestring),"") +{ + + check_type_string(&namestring); + return find_init_name1(namestring->st.st_self,namestring->st.st_dim); + +} + diff --git a/o/conditional.c b/o/conditional.c new file mode 100755 index 0000000..bee5a05 --- /dev/null +++ b/o/conditional.c @@ -0,0 +1,205 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +/* + + conditional.c + + conditionals +*/ + +#include "include.h" + +object sLotherwise; + +static void +FFN(Fif)(object form) +{ + + object *top = vs_top; + + if (endp(form) || endp(MMcdr(form))) + FEtoo_few_argumentsF(form); + if (!endp(MMcddr(form)) && !endp(MMcdddr(form))) + FEtoo_many_argumentsF(form); + eval(MMcar(form)); + if (vs_base[0] == Cnil) + if (endp(MMcddr(form))) { + vs_top = vs_base = top; + vs_push(Cnil); + } else { + vs_top = top; + eval(MMcaddr(form)); + } + else { + vs_top = top; + eval(MMcadr(form)); + } +} + +static void +FFN(Fcond)(object args) +{ + + object *top = vs_top; + object clause; + object conseq; + + while (!endp(args)) { + clause = MMcar(args); + if (type_of(clause) != t_cons) + FEerror("~S is an illegal COND clause.",1,clause); + eval(MMcar(clause)); + if (vs_base[0] != Cnil) { + conseq = MMcdr(clause); + if (endp(conseq)) { + vs_top = vs_base+1; + return; + } + while (!endp(conseq)) { + vs_top = top; + eval(MMcar(conseq)); + conseq = MMcdr(conseq); + } + return; + } + vs_top = top; + args = MMcdr(args); + } + vs_base = vs_top = top; + vs_push(Cnil); +} + +static void +FFN(Fcase)(object arg) +{ + + object *top = vs_top; + object clause; + object key; + object conseq; + + if (endp(arg)) + FEtoo_few_argumentsF(arg); + eval(MMcar(arg)); + vs_top = top; + vs_push(vs_base[0]); + arg = MMcdr(arg); + while (!endp(arg)) { + clause = MMcar(arg); + if (type_of(clause) != t_cons) + FEerror("~S is an illegal CASE clause.",1,clause); + key = MMcar(clause); + conseq = MMcdr(clause); + if (type_of(key) == t_cons) + do { + if (eql(MMcar(key),top[0])) + goto FOUND; + key = MMcdr(key); + } while (!endp(key)); + else if (key == Cnil) + ; + else if (key == Ct || key == sLotherwise || eql(key,top[0])) + goto FOUND; + arg = MMcdr(arg); + } + vs_base = vs_top = top; + vs_push(Cnil); + return; + +FOUND: + if (endp(conseq)) { + vs_base = vs_top = top; + vs_push(Cnil); + } else + do { + vs_top = top; + eval(MMcar(conseq)); + conseq = MMcdr(conseq); + } while (!endp(conseq)); + return; +} + +static void +FFN(Fwhen)(object form) +{ + + object *top = vs_top; + + if (endp(form)) + FEtoo_few_argumentsF(form); + eval(MMcar(form)); + if (vs_base[0] == Cnil) { + vs_base = vs_top = top; + vs_push(Cnil); + } else { + form = MMcdr(form); + if (endp(form)) { + vs_base = vs_top = top; + vs_push(Cnil); + } else + do { + vs_top = top; + eval(MMcar(form)); + form = MMcdr(form); + } while (!endp(form)); + } +} + +static void +FFN(Funless)(object form) +{ + + object *top = vs_top; + + if (endp(form)) + FEtoo_few_argumentsF(form); + eval(MMcar(form)); + if (vs_base[0] == Cnil) { + vs_top = top; + form = MMcdr(form); + if (endp(form)) { + vs_base = vs_top = top; + vs_push(Cnil); + } else + do { + vs_top = top; + eval(MMcar(form)); + form = MMcdr(form); + } while (!endp(form)); + } else { + vs_base = vs_top = top; + vs_push(Cnil); + } +} + +void +gcl_init_conditional(void) +{ + make_special_form("IF",Fif); + make_special_form("COND",Fcond); + make_special_form("CASE",Fcase); + make_special_form("WHEN",Fwhen); + make_special_form("UNLESS",Funless); + + sLotherwise = make_ordinary("OTHERWISE"); + enter_mark_origin(&sLotherwise); +} diff --git a/o/earith.c b/o/earith.c new file mode 100755 index 0000000..62ebf7f --- /dev/null +++ b/o/earith.c @@ -0,0 +1,6 @@ +#define NEED_MP_H +#include "include.h" + +#ifdef CMAC +#include "cmac.c" +#endif diff --git a/o/egrep-def b/o/egrep-def new file mode 100755 index 0000000..fe863c0 --- /dev/null +++ b/o/egrep-def @@ -0,0 +1,5 @@ +#!/bin/sh +egrep '^(DEFUN\()|^(DEFUNO\()|^(DEFCOMP\()|^(DEFVAR\()|^(DO_INIT\()|^(DEF_ORDINARY\()' $1 +exit 0 + + diff --git a/o/error.c b/o/error.c new file mode 100755 index 0000000..70bb8e4 --- /dev/null +++ b/o/error.c @@ -0,0 +1,537 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +/* + + error.c + + Errors +*/ + +#include +#include "include.h" +object siSuniversal_error_handler; + +object sSterminal_interrupt; + +void +assert_error(const char *a,unsigned l,const char *f,const char *n) { + + if (!raw_image) + FEerror("The assertion ~a on line ~a of ~a in function ~a failed",4, + make_simple_string(a),make_fixnum(l), + make_simple_string(f),make_simple_string(n)); + else { + fprintf(stderr,"The assertion %s on line %d of %s in function %s failed",a,l,f,n); + exit(-1); + } + +} + + +void +terminal_interrupt(int correctable) +{ + signals_allowed = sig_normal; + ifuncall1(sSterminal_interrupt, correctable?Ct:Cnil); +} + +static object +ihs_function_name(object x) +{ + object y; + + switch (type_of(x)) { + case t_symbol: + return(x); + + case t_cons: + y = x->c.c_car; + if (y == sLlambda) + return(sLlambda); + if (y == sLlambda_closure) + return(sLlambda_closure); + if (y == sLlambda_block || y == sSlambda_block_expanded) { + x = x->c.c_cdr; + if (type_of(x) != t_cons) + return(sLlambda_block); + return(x->c.c_car); + } + if (y == sLlambda_block_closure) { + x = x->c.c_cdr; + if (type_of(x) != t_cons) + return(sLlambda_block_closure); + x = x->c.c_cdr; + if (type_of(x) != t_cons) + return(sLlambda_block_closure); + x = x->c.c_cdr; + if (type_of(x) != t_cons) + return(sLlambda_block_closure); + x = x->c.c_cdr; + if (type_of(x) != t_cons) + return(sLlambda_block_closure); + return(x->c.c_car); + } + /* a general special form */ + if (y->s.s_sfdef != NOT_SPECIAL) + return y; + return(Cnil); + + case t_afun: + case t_closure: + case t_cfun: + case t_sfun: + case t_vfun: + case t_cclosure: + case t_gfun: + + return(x->cf.cf_name); + + default: + return(Cnil); + } +} + +object +ihs_top_function_name(ihs_ptr h) +{ + object x; + + + while (h >= ihs_org) { + x = ihs_function_name(h->ihs_function); + if (x != Cnil) + return(x); + h--; + } + return(Cnil); +} + +object +Icall_gen_error_handler(object ci,object cs,object en,object es,ufixnum n,...) { + + object *b; + ufixnum i; + va_list ap; + + n+=5; + b=alloca(n*sizeof(*b)); + b[0]= en; + b[1]= ci; + b[2] = ihs_top_function_name(ihs_top); + b[3] = cs; + b[4] = es; + + va_start(ap,n); + for (i=5;iihs_top ? ihs_top : p; + return p; + ILLEGAL: + FEerror("~S is an illegal ihs index.", 1, x); + return(NULL); + +} + +DEFUN_NEW("IHS-TOP",object,fSihs_top,SI,0,0,NONE,OO,OO,OO,OO,(void),"") { + /* 0 args */ + RETURN1(make_fixnum(ihs_top - ihs_org)); +} + +DEFUN_NEW("IHS-FUN",object,fSihs_fun,SI,1,1,NONE,OO,OO,OO,OO,(object x0),"") +{ + /* 1 args */ + x0 = get_ihs_ptr(x0)->ihs_function; + RETURN1(x0); +} + +DEFUN_NEW("IHS-VS",object,fSihs_vs,SI + ,1,1,NONE,OO,OO,OO,OO,(object x0),"") +{ + /* 1 args */ + x0 = make_fixnum(get_ihs_ptr(x0)->ihs_base - vs_org); + RETURN1(x0); +} + +static frame_ptr get_frame_ptr(object x) { + + frame_ptr p; + + if (type_of(x) != t_fixnum) + goto ILLEGAL; + p = frs_org + fix(x); + if (fix(x)==0) return p; + p=pfrs_top ? frs_top : p; + return p; + ILLEGAL: + FEerror("~S is an illegal frs index.", 1, x); + return NULL; + +} + +DEFUN_NEW("FRS-TOP",object,fSfrs_top,SI + ,0,0,NONE,OO,OO,OO,OO,(void),"") + +{ + /* 0 args */ + RETURN1((make_fixnum(frs_top - frs_org))); +} + +DEFUN_NEW("FRS-VS",object,fSfrs_vs,SI + ,1,1,NONE,OO,OO,OO,OO,(object x0),"") +{ + /* 1 args */ + x0 = make_fixnum(get_frame_ptr(x0)->frs_lex - vs_org); + RETURN1(x0); +} + +DEFUN_NEW("FRS-BDS",object,fSfrs_bds,SI + ,1,1,NONE,OO,OO,OO,OO,(object x0),"") +{ + /* 1 args */ + x0 + = make_fixnum(get_frame_ptr(x0)->frs_bds_top - bds_org); + RETURN1(x0); +} + +DEFUN_NEW("FRS-CLASS",object,fSfrs_class,SI + ,1,1,NONE,OO,OO,OO,OO,(object x0),"") +{ + enum fr_class c; + + /* 1 args */ + + c = get_frame_ptr(x0)->frs_class; + if (c == FRS_CATCH) x0 = sKcatch; + else if (c == FRS_PROTECT) x0 = sKprotect; + else if (c == FRS_CATCHALL) x0 = sKcatchall; + else FEerror("Unknown frs class was detected.", 0); + RETURN1(x0); +} + +DEFUN_NEW("FRS-TAG",object,fSfrs_tag,SI + ,1,1,NONE,OO,OO,OO,OO,(object x0),"") +{ + /* 1 args */ + x0 = get_frame_ptr(x0)->frs_val; + RETURN1(x0); +} + +DEFUN_NEW("FRS-IHS",object,fSfrs_ihs,SI + ,1,1,NONE,OO,OO,OO,OO,(object x0),"") +{ + /* 1 args */ + x0 + = make_fixnum(get_frame_ptr(x0)->frs_ihs - ihs_org); + RETURN1(x0); +} + +static bds_ptr get_bds_ptr(object x) { + + bds_ptr p; + + if (type_of(x) != t_fixnum) + goto ILLEGAL; + p = bds_org + fix(x); + if (0 == fix(x)) return p; + p=pbds_top ? bds_top : p; + return p; + ILLEGAL: + FEerror("~S is an illegal bds index.", 1, x); + return NULL; + +} + +DEFUN_NEW("BDS-TOP",object,fSbds_top,SI + ,0,0,NONE,OO,OO,OO,OO,(void),"") + +{ + /* 0 args */ + RETURN1((make_fixnum(bds_top - bds_org))); +} + +DEFUN_NEW("BDS-VAR",object,fSbds_var,SI + ,1,1,NONE,OO,OO,OO,OO,(object x0),"") +{ + /* 1 args */ + x0 = get_bds_ptr(x0)->bds_sym; + RETURN1(x0); +} + +DEFUN_NEW("BDS-VAL",object,fSbds_val,SI + ,1,1,NONE,OO,OO,OO,OO,(object x0),"") +{ + /* 1 args */ + x0 = get_bds_ptr(x0)->bds_val; + RETURN1(x0); +} + +static object *get_vs_ptr(object x) { + + object *p; + + if (type_of(x) != t_fixnum) + goto ILLEGAL; + p = vs_org + fix(x); + p=p=vs_top ? vs_top-1 : p; + return p; + ILLEGAL: + FEerror("~S is an illegal vs index.", 1, x); + return NULL; + +} + +DEFUN_NEW("VS-TOP",object,fSvs_top,SI + ,0,0,NONE,OO,OO,OO,OO,(void),"") +{ + object x; + /* 0 args */ + x = (make_fixnum(vs_top - vs_org)); + RETURN1(x); +} + +DEFUN_NEW("VS",object,fSvs,SI + ,1,1,NONE,OO,OO,OO,OO,(object x0),"") +{ + /* 1 args */ + x0 = *get_vs_ptr(x0); + RETURN1(x0); +} + +DEFUN_NEW("SCH-FRS-BASE",object,fSsch_frs_base,SI + ,2,2,NONE,OO,OO,OO,OO,(object x0,object x1),"") +{ + frame_ptr x; + ihs_ptr y; + + /* 2 args */ + y = get_ihs_ptr(x1); + for (x = get_frame_ptr(x0); + x <= frs_top && x->frs_ihs < y; + x++); + if (x > frs_top) x0 = Cnil; + else x0 = make_fixnum(x - frs_org); + + RETURN1(x0); +} + +DEFUNM_NEW("INTERNAL-SUPER-GO",object,fSinternal_super_go,SI + ,3,3,NONE,OO,OO,OO,OO,(object tag,object x1,object x2),"") +{ + frame_ptr fr; + + /* 3 args */ + + fr = frs_sch(tag); + if (fr == NULL) + FEerror("The tag ~S is missing.", 1, tag); + if (x2 == Cnil) + tag = x1; + else + tag = MMcons(tag, x1); + unwind(fr,tag); + RETURN0 ; +} + +DEF_ORDINARY("UNIVERSAL-ERROR-HANDLER",sSuniversal_error_handler,SI + ,"Redefined in lisp, this is the function called by the \ +internal error handling mechanism. \ + Args: (error-name correctable function-name \ + continue-format-string error-format-string \ + &rest args)"); +DEFUN_NEW("UNIVERSAL-ERROR-HANDLER",object,fSuniversal_error_handler,SI + ,5,F_ARG_LIMIT,NONE,OO,OO,OO,OO,(object x0,object x1,object x2,object x3,object error_fmt_string),"") +{ + int i; + /* 5 args */ + for (i = 0; i < error_fmt_string->st.st_fillp; i++) + fputc(error_fmt_string->st.st_self[i],stdout); + printf("\nLisp initialization failed.\n"); + exit(0); + RETURN1(x0); +} + +void +check_arg_failed(int n) +{ + if (n 0; n--, x = x->c.c_cdr) + if(endp(x)) + FEerror("APPLY sent too few arguments to LAMBDA.", 0); +} + +void +ck_larg_exactly(int n, object x) { + for(; n > 0; n--, x = x->c.c_cdr) + if(endp(x)) + FEerror("APPLY sent too few arguments to LAMBDA.", 0); + if(!endp(x)) FEerror("APPLY sent too many arguments to LAMBDA.", 0); +} + +void +invalid_macro_call(void) +{ + FEinvalid_macro_call(); +} + +object +wrong_type_argument(object typ, object obj) +{ + FEwrong_type_argument(typ, obj); + /* no return */ + return(Cnil); +} + +void +illegal_declare(object form) +{ + FEinvalid_form("~S is an illegal declaration form.", form); +} + +void +not_a_string_or_symbol(object x) +{ + FEerror("~S is not a string or symbol.", 1, x); +} + +void +not_a_symbol(object obj) +{ +/* FEinvalid_variable("~S is not a symbol.", obj); */ + FEwrong_type_argument(sLsymbol,obj); +} + +int +not_a_variable(object obj) +{ + FEinvalid_variable("~S is not a variable.", obj); + return -1; +} + +void +illegal_index(object x, object i) +{ + FEerror("~S is an illegal index to ~S.", 2, i, x); +} + +void +check_stream(object strm) +{ +if (type_of(strm) != t_stream) + FEwrong_type_argument(sLstream, strm); +} + +void +vfun_wrong_number_of_args(object x) +{ + + FEerror("Expected ~S args but received ~S args",2, + x,make_fixnum(VFUN_NARGS)); +} + + +void +check_arg_range(int n, int m) +{ + object x,x1; + + x=make_fixnum(n); + x1=make_fixnum(VFUN_NARGS); + if (VFUN_NARGS < n) + Icall_error_handler( + sKtoo_few_arguments, + make_simple_string("Needed at least ~D args, but received ~d"), + 2,x,x1); + else if (VFUN_NARGS > m) + Icall_error_handler( + sKtoo_many_arguments, + make_simple_string("Needed no more than ~D args, but received ~d"), + 2,x,x1); + } + + +DEF_ORDINARY("TERMINAL-INTERRUPT",sSterminal_interrupt,SI,""); +DEF_ORDINARY("WRONG-TYPE-ARGUMENT",sKwrong_type_argument,KEYWORD,""); +DEF_ORDINARY("TOO-FEW-ARGUMENTS",sKtoo_few_arguments,KEYWORD,""); +DEF_ORDINARY("TOO-MANY-ARGUMENTS",sKtoo_many_arguments,KEYWORD,""); +DEF_ORDINARY("UNEXPECTED-KEYWORD",sKunexpected_keyword,KEYWORD,""); +DEF_ORDINARY("INVALID-FORM",sKinvalid_form,KEYWORD,""); +DEF_ORDINARY("UNBOUND-VARIABLE",sKunbound_variable,KEYWORD,""); +DEF_ORDINARY("INVALID-VARIABLE",sKinvalid_variable,KEYWORD,""); +DEF_ORDINARY("UNDEFINED-FUNCTION",sKundefined_function,KEYWORD,""); +DEF_ORDINARY("INVALID-FUNCTION",sKinvalid_function,KEYWORD,""); +DEF_ORDINARY("PACKAGE-ERROR",sKpackage_error,KEYWORD,""); +DEF_ORDINARY("DATUM",sKdatum,KEYWORD,""); +DEF_ORDINARY("EXPECTED-TYPE",sKexpected_type,KEYWORD,""); +DEF_ORDINARY("PACKAGE",sKpackage,KEYWORD,""); +DEF_ORDINARY("FORMAT-CONTROL",sKformat_control,KEYWORD,""); +DEF_ORDINARY("FORMAT-ARGUMENTS",sKformat_arguments,KEYWORD,""); +DEF_ORDINARY("CATCH",sKcatch,KEYWORD,""); +DEF_ORDINARY("PROTECT",sKprotect,KEYWORD,""); +DEF_ORDINARY("CATCHALL",sKcatchall,KEYWORD,""); + + +void +gcl_init_error(void) +{ + null_string = make_simple_string(""); + enter_mark_origin(&null_string); +} diff --git a/o/eval.c b/o/eval.c new file mode 100755 index 0000000..0422721 --- /dev/null +++ b/o/eval.c @@ -0,0 +1,1406 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +/* + eval.c +*/ + +#include "include.h" +#include "sfun_argd.h" + +static void +call_applyhook(object); + + +struct nil3 { object nil3_self[3]; } three_nils; + +#ifdef DEBUG_AVMA +#undef DEBUG_AVMA +unsigned long avma,bot; +#define DEBUG_AVMA unsigned long saved_avma = avma; +warn_avma() +{ + print(list(2,make_simple_string("avma changed"),ihs_top_function_name(ihs_top)), + sLAstandard_outputA->s.s_dbind); +} +#define CHECK_AVMA if(avma!= saved_avma) warn_avma(); +#define DEBUGGING_AVMA +#else +#define DEBUG_AVMA +#define CHECK_AVMA +#endif + + + +/* object c_apply_n(long int (*fn)(), int n, object *x); */ + +object sSAbreak_pointsA; +object sSAbreak_stepA; + +#include "apply_n.h" + +/* for t_sfun,t_gfun with args on vs stack */ + +static void +quick_call_sfun(object fun) +{ DEBUG_AVMA + int i=fun->sfn.sfn_argd,n=SFUN_NARGS(i); + enum ftype restype; + object *x,res,*base; + object *temp_ar=alloca(n*sizeof(object)); +/* i=fun->sfn.sfn_argd; */ +/* n=SFUN_NARGS(i); */ + base = vs_base; + if (n != vs_top - base) + {check_arg_failed(n);} + restype = SFUN_RETURN_TYPE(i); + SFUN_START_ARG_TYPES(i); + /* for moment just support object and int */ +#define COERCE_ARG(a,type) (type==f_object ? a : (object)(fix(a))) + if (i==0) + x=vs_base; + else + {int j; + x=temp_ar; + for (j=0; jvfn.vfn_minargs) + {FEtoo_few_arguments(base,vs_top); return;} + if (n > fun->vfn.vfn_maxargs) + {FEtoo_many_arguments(base,vs_top); return;} + VFUN_NARGS = n; + base[0]=c_apply_n_fun(fun,n,base); + vs_top=(vs_base=base)+1; + CHECK_AVMA; + return; +} + + +void +funcall(object fun) +{ + object temporary; + object x; + object * VOL top; + object *lex; + bds_ptr old_bds_top; + VOL bool b; + bool c; + DEBUG_AVMA + TOP: + if (fun == OBJNULL) + FEerror("Undefined function.", 0); + switch (type_of(fun)) { + case t_cfun: + MMcall(fun); + CHECK_AVMA; return; + case t_gfun: + case t_sfun: + { + extern int Rset; + int rset=Rset; + if (!rset) {ihs_check;ihs_push(fun);} + quick_call_sfun(fun); + if (!rset) ihs_pop(); + } + return; + case t_vfun: + { + extern int Rset; + int rset=Rset; + if (!rset) {ihs_check;ihs_push(fun);} + call_vfun(fun); + if (!rset) ihs_pop(); + } + return; + case t_afun: + case t_closure: + { object res,*b = vs_base; + int n = vs_top - b; + res = (object)IapplyVector(fun,n,b); + n = fcall.nvalues; + vs_base = b; + vs_top = b+ n; + while (--n> 0 ) b[n] = fcall.values[n]; + b[0] = res; + return;} + + case t_cclosure: + + MMccall(fun); + CHECK_AVMA; + return; + + case t_symbol: + {object x = fun->s.s_gfdef; + if (x) { fun = x; goto TOP;} + else + FEundefined_function(fun); + } + + case t_cons: + break; + + default: + FEinvalid_function(fun); + } + + /* + This part is the same as that of funcall_no_event. + */ + + /* we may have pushed the calling form if this is called invoked from + eval. A lambda call requires vs_push's, so we can tell + if we pushed by vs_base being the same. + */ + { VOL int not_pushed = 0; + if (vs_base != ihs_top->ihs_base){ + ihs_check; + ihs_push(fun); + } + else + not_pushed = 1; + + ihs_top->ihs_base = lex_env; + x = MMcar(fun); + top = vs_top; + lex = lex_env; + old_bds_top = bds_top; + + /* maybe digest this lambda expression + (lambda-block-expand name ..) has already been + expanded. The value of lambda-block-expand may + be a compiled function in which case we say expand + with it) + */ + + if (x == sSlambda_block_expanded) { + + b = TRUE; + c = FALSE; + fun = fun->c.c_cdr; + + }else if (x == sLlambda_block) { + b = TRUE; + c = FALSE; + if(sSlambda_block_expanded->s.s_dbind!=OBJNULL) + fun = ifuncall1(sSlambda_block_expanded->s.s_dbind,fun); + + fun = fun->c.c_cdr; + + + + } else if (x == sLlambda_closure) { + b = FALSE; + c = TRUE; + fun = fun->c.c_cdr; + } else if (x == sLlambda) { + b = c = FALSE; + fun = fun->c.c_cdr; + } else if (x == sLlambda_block_closure) { + b = c = TRUE; + fun = fun->c.c_cdr; + } else + b = c = TRUE; + if (c) { + vs_push(kar(fun)); + fun = fun->c.c_cdr; + vs_push(kar(fun)); + fun = fun->c.c_cdr; + vs_push(kar(fun)); + fun = fun->c.c_cdr; + } else { + *(struct nil3 *)vs_top = three_nils; + vs_top += 3; + } + if (b) { + x = kar(fun); /* block name */ + fun = fun->c.c_cdr; + } + lex_env = top; + vs_push(fun); + lambda_bind(top); + ihs_top->ihs_base = lex_env; + if (b) { + fun = temporary = alloc_frame_id(); + /* lex_block_bind(x, temporary); */ + temporary = MMcons(temporary, Cnil); + temporary = MMcons(sLblock, temporary); + temporary = MMcons(x, temporary); + lex_env[2] = MMcons(temporary, lex_env[2]); + frs_push(FRS_CATCH, fun); + if (nlj_active) { + nlj_active = FALSE; + goto END; + } + } + x = top[3]; /* body */ + if(endp(x)) { + vs_base = vs_top; + vs_push(Cnil); + } else { + top = vs_top; + for (;;) { + eval(MMcar(x)); + x = MMcdr(x); + if (endp(x)) + break; + vs_top = top; + } + } +END: + if (b) + frs_pop(); + bds_unwind(old_bds_top); + lex_env = lex; + if (not_pushed == 0) {ihs_pop();} + CHECK_AVMA; +}} + +void +funcall_no_event(object fun) +{ + DEBUG_AVMA + if (fun == OBJNULL) + FEerror("Undefined function.", 0); + switch (type_of(fun)) { + case t_cfun: + (*fun->cf.cf_self)(); + break; + + case t_cclosure: + (*fun->cc.cc_self)(fun); + break; + + case t_sfun: +/* call_sfun_no_check(fun); return; */ + case t_gfun: + quick_call_sfun(fun); return; + case t_vfun: + call_vfun(fun); return; + + default: + funcall(fun); + + } +} + +void +lispcall(object *funp, int narg) +{ + DEBUG_AVMA + object fun = *funp; + + vs_base = funp + 1; + vs_top = vs_base + narg; + + if (fun == OBJNULL) + FEerror("Undefined function.", 0); + switch (type_of(fun)) { + case t_cfun: + MMcall(fun); + break; + + case t_cclosure: + MMccall(fun); + break; + + default: + funcall(fun); + + } + CHECK_AVMA; +} + +void +lispcall_no_event(object *funp, int narg) +{ + DEBUG_AVMA + object fun = *funp; + + vs_base = funp + 1; + vs_top = vs_base + narg; + + if (fun == OBJNULL) + FEerror("Undefined function.", 0); + switch (type_of(fun)) { + case t_cfun: + (*fun->cf.cf_self)(); + break; + + case t_cclosure: + + (*fun->cc.cc_self)(fun); + break; + + default: + funcall(fun); + + } + CHECK_AVMA; +} + +void +symlispcall(object sym, object *base, int narg) +{ + DEBUG_AVMA + object fun = symbol_function(sym); + + vs_base = base; + vs_top = vs_base + narg; + + if (fun == OBJNULL) + FEerror("Undefined function.", 0); + switch (type_of(fun)) { + case t_cfun: + MMcall(fun); + break; + + case t_cclosure: + MMccall(fun); + break; + + default: + funcall(fun); + } + CHECK_AVMA; +} + +void +symlispcall_no_event(object sym, object *base, int narg) +{ + DEBUG_AVMA + object fun = symbol_function(sym); + + vs_base = base; + vs_top = vs_base + narg; + + if (fun == OBJNULL) + FEerror("Undefined function.", 0); + switch (type_of(fun)) { + case t_cfun: + (*fun->cf.cf_self)(); + break; + + case t_cclosure: + (*fun->cc.cc_self)(fun); + break; + + default: + funcall(fun); + + } + CHECK_AVMA; +} + +object +simple_lispcall(object *funp, int narg) +{ + DEBUG_AVMA + object fun = *funp; + object *sup = vs_top; + + vs_base = funp + 1; + vs_top = vs_base + narg; + + if (fun == OBJNULL) + FEerror("Undefined function.", 0); + switch (type_of(fun)) { + case t_cfun: + MMcall(fun); + break; + + case t_cclosure: + MMccall(fun); + break; + + default: + funcall(fun); + + } + vs_top = sup; + CHECK_AVMA; + return(vs_base[0]); + +} + +/* static object */ +/* simple_lispcall_no_event(object *funp, int narg) */ +/* { */ +/* DEBUG_AVMA */ +/* object fun = *funp; */ +/* object *sup = vs_top; */ + +/* vs_base = funp + 1; */ +/* vs_top = vs_base + narg; */ + +/* if (fun == OBJNULL) */ +/* FEerror("Undefined function.", 0); */ +/* switch (type_of(fun)) { */ +/* case t_cfun: */ +/* (*fun->cf.cf_self)(); */ +/* break; */ + +/* case t_cclosure: */ +/* { */ +/* object *top, *base, l; */ + +/* if (fun->cc.cc_turbo != NULL) { */ +/* (*fun->cc.cc_self)(fun->cc.cc_turbo); */ +/* break; */ +/* } */ +/* top = vs_top; */ +/* base = vs_base; */ +/* for (l = fun->cc.cc_env; !endp(l); l = l->c.c_cdr) */ +/* vs_push(l); */ +/* vs_base = vs_top; */ +/* while (base < top) */ +/* vs_push(*base++); */ +/* (*fun->cc.cc_self)(top); */ +/* break; */ +/* } */ + +/* default: */ +/* funcall(fun); */ + +/* } */ +/* vs_top = sup; */ +/* CHECK_AVMA; */ +/* return(vs_base[0]); */ +/* } */ + +object +simple_symlispcall(object sym, object *base, int narg) +{ + DEBUG_AVMA + object fun = symbol_function(sym); + object *sup = vs_top; + + vs_base = base; + vs_top = vs_base + narg; + + if (fun == OBJNULL) + FEerror("Undefined function.", 0); + switch (type_of(fun)) { + case t_cfun: + MMcall(fun); + break; + + case t_cclosure: + MMccall(fun); + break; + + default: + funcall(fun); + + } + vs_top = sup; + CHECK_AVMA; + return(vs_base[0]); +} + +/* static object */ +/* simple_symlispcall_no_event(object sym, object *base, int narg) */ +/* { */ +/* DEBUG_AVMA */ +/* object fun = symbol_function(sym); */ +/* object *sup = vs_top; */ + +/* vs_base = base; */ +/* vs_top = vs_base + narg; */ + +/* if (fun == OBJNULL) */ +/* FEerror("Undefined function.", 0); */ +/* switch (type_of(fun)) { */ +/* case t_cfun: */ +/* (*fun->cf.cf_self)(); */ +/* break; */ + +/* case t_cclosure: */ +/* { */ +/* object *top, *base, l; */ + +/* if (fun->cc.cc_turbo != NULL) { */ +/* (*fun->cc.cc_self)(fun->cc.cc_turbo); */ +/* break; */ +/* } */ +/* top = vs_top; */ +/* base = vs_base; */ +/* for (l = fun->cc.cc_env; !endp(l); l = l->c.c_cdr) */ +/* vs_push(l); */ +/* vs_base = vs_top; */ +/* while (base < top) */ +/* vs_push(*base++); */ +/* (*fun->cc.cc_self)(top); */ +/* break; */ +/* } */ + +/* default: */ +/* funcall(fun); */ +/* } */ +/* vs_top = sup; */ +/* CHECK_AVMA; */ +/* return(vs_base[0]); */ +/* } */ + +void +super_funcall(object fun) +{ + if (type_of(fun) == t_symbol) { + if (fun->s.s_sfdef != NOT_SPECIAL || fun->s.s_mflag) + FEinvalid_function(fun); + if (fun->s.s_gfdef == OBJNULL) + FEundefined_function(fun); + fun = fun->s.s_gfdef; + } + funcall(fun); +} + +void +super_funcall_no_event(object fun) +{ +#ifdef DEBUGGING_AVMA + funcall_no_event(fun); return; +#endif + if (type_of(fun)==t_cfun){(*fun->cf.cf_self)();return;} + if (type_of(fun)==t_sfun){call_sfun_no_check(fun); return;} + if (type_of(fun)==t_gfun) + {quick_call_sfun(fun); return;} + if (type_of(fun)==t_vfun) + {call_vfun(fun); return;} + if (type_of(fun) == t_symbol) { + if (fun->s.s_sfdef != NOT_SPECIAL || fun->s.s_mflag) + FEinvalid_function(fun); + if (fun->s.s_gfdef == OBJNULL) + FEundefined_function(fun); + fun = fun->s.s_gfdef; + if (type_of(fun)==t_cfun){(*fun->cf.cf_self)(); + return;} + } + funcall_no_event(fun); +} + +#ifdef USE_BROKEN_IEVAL +object +Ieval(form) +object form; +{ + DEBUG_AVMA + object fun, x; + object *top; + object *base; + object orig_form; + + cs_check(form); + +EVAL: + + vs_check; + + if (Vevalhook->s.s_dbind != Cnil && eval1 == 0) + { + bds_ptr old_bds_top = bds_top; + object hookfun = symbol_value(Vevalhook); + /* check if Vevalhook is unbound */ + + bds_bind(Vevalhook, Cnil); + form = Ifuncall_n(hookfun,2,form,list(3,lex_env[0],lex_env[1],lex_env[2])); + bds_unwind(old_bds_top); + return form; + } else + eval1 = 0; + + if (type_of(form) == t_cons) + goto APPLICATION; + + if (type_of(form) != t_symbol) RETURN1(form); + + switch (form->s.s_stype) { + case stp_constant: + RETURN1((form->s.s_dbind)); + + case stp_special: + if(form->s.s_dbind == OBJNULL) + FEunbound_variable(form); + RETURN1((form->s.s_dbind)); + + default: + /* x = lex_var_sch(form); */ + for (x = lex_env[0]; type_of(x) == t_cons; x = x->c.c_cdr) + if (x->c.c_car->c.c_car == form) { + x = x->c.c_car->c.c_cdr; + if (endp(x)) + break; + RETURN1((x->c.c_car)); + } + if(form->s.s_dbind == OBJNULL) + FEunbound_variable(form); + RETURN1((form->s.s_dbind)); + } + +APPLICATION: + /* Hook for possibly stopping at forms in the break point + list. Also for stepping. We only want to check + one form each time round, so we do *breakpoints* + */ + if (sSAbreak_pointsA->s.s_dbind != Cnil) + { if (sSAbreak_stepA->s.s_dbind == Cnil || + ifuncall2(sSAbreak_stepA->s.s_dbind,form, + list(3,lex_env[0],lex_env[1],lex_env[2])) == Cnil) + {object* bpts = sSAbreak_pointsA->s.s_dbind->v.v_self; + int i = sSAbreak_pointsA->s.s_dbind->v.v_fillp; + while (--i >= 0) + { if((*bpts)->c.c_car == form) + {ifuncall2(sSAbreak_pointsA->s.s_gfdef,form, + list(3,lex_env[0],lex_env[1],lex_env[2])); + + break;} + bpts++;} + }} + + fun = MMcar(form); + if (type_of(fun) != t_symbol) + goto LAMBDA; + if (fun->s.s_sfdef != NOT_SPECIAL) { + ihs_check; + ihs_push(form); + ihs_top->ihs_base = lex_env; + (*fun->s.s_sfdef)(MMcdr(form)); + CHECK_AVMA; + ihs_pop(); + return Ivs_values(); + } + /* x = lex_fd_sch(fun); */ + for (x = lex_env[1]; type_of(x) == t_cons; x = x->c.c_cdr) + if (x->c.c_car->c.c_car == fun) { + x = x->c.c_car; + if (MMcadr(x) == sLmacro) { + x = MMcaddr(x); + goto EVAL_MACRO; + } + x = MMcaddr(x); + goto EVAL_ARGS; + } + + if ((x = fun->s.s_gfdef) == OBJNULL) + FEundefined_function(fun); + + if (fun->s.s_mflag) { + EVAL_MACRO: + + form = Imacro_expand1(x, form); + goto EVAL; + } + + + +EVAL_ARGS: + { int n ; + ihs_check; + ihs_push(form); + ihs_top->ihs_base = lex_env; + form = form->c.c_cdr; + base = vs_top; + top = base ; + while(!endp(form)) { + object ans = Ieval(MMcar(form)); + top[0] = ans; + vs_top = ++top; + form = MMcdr(form);} + n =top - base; /* number of args */ + if (Vapplyhook->s.s_dbind != Cnil) { + base[0]= (object)n; + base[0] = c_apply_n(list,n+1,base); + x = Ifuncall_n(Vapplyhook->s.s_dbind,3, + x, /* the function */ + base[0], /* the arg list */ + list(3,lex_env[0],lex_env[1],lex_env[2])); + vs_top = base; return x; + } + ihs_top->ihs_function = x; + ihs_top->ihs_base = vs_base; + x=IapplyVector(x,n,base+1); + CHECK_AVMA; + ihs_pop(); + vs_top = base; + return x; + } + +LAMBDA: + if (type_of(fun) == t_cons && MMcar(fun) == sLlambda) { + x = listA(4,sLlambda_closure,lex_env[0],lex_env[1],lex_env[2],Mcdr(fun)); + goto EVAL_ARGS; + } + FEinvalid_function(fun); +} + +#else + +object +Ieval(object form) +{ eval(form); + return Ivs_values(); +} +#endif + +void +eval(object form) +{ + object temporary; + DEBUG_AVMA + object fun, x; + object *top; + object *base; + + cs_check(form); + +EVAL: + + vs_check; + + if (Vevalhook->s.s_dbind != Cnil && eval1 == 0) + { + bds_ptr old_bds_top = bds_top; + object hookfun = symbol_value(Vevalhook); + /* check if Vevalhook is unbound */ + + bds_bind(Vevalhook, Cnil); + vs_base = vs_top; + vs_push(form); + vs_push(lex_env[0]); + vs_push(lex_env[1]); + vs_push(lex_env[2]); + vs_push(Cnil); + stack_cons(); + stack_cons(); + stack_cons(); + super_funcall(hookfun); + bds_unwind(old_bds_top); + return; + } else + eval1 = 0; + + if (type_of(form) == t_cons) + goto APPLICATION; + + if (type_of(form) != t_symbol) { + vs_base = vs_top; + vs_push(form); + return; + } + + switch (form->s.s_stype) { + case stp_constant: + vs_base = vs_top; + vs_push(form->s.s_dbind); + return; + + case stp_special: + if(form->s.s_dbind == OBJNULL) + FEunbound_variable(form); + vs_base = vs_top; + vs_push(form->s.s_dbind); + return; + + default: + /* x = lex_var_sch(form); */ + for (x = lex_env[0]; type_of(x) == t_cons; x = x->c.c_cdr) + if (x->c.c_car->c.c_car == form) { + x = x->c.c_car->c.c_cdr; + if (endp(x)) + break; + vs_base = vs_top; + vs_push(x->c.c_car); + return; + } + if(form->s.s_dbind == OBJNULL) + FEunbound_variable(form); + vs_base = vs_top; + vs_push(form->s.s_dbind); + return; + } + +APPLICATION: + /* Hook for possibly stopping at forms in the break point + list. Also for stepping. We only want to check + one form each time round, so we do *breakpoints* + */ + if (sSAbreak_pointsA->s.s_dbind != Cnil) + { if (sSAbreak_stepA->s.s_dbind == Cnil || + ifuncall2(sSAbreak_stepA->s.s_dbind,form, + list(3,lex_env[0],lex_env[1],lex_env[2])) == Cnil) + {object* bpts = sSAbreak_pointsA->s.s_dbind->v.v_self; + int i = sSAbreak_pointsA->s.s_dbind->v.v_fillp; + while (--i >= 0) + { if((*bpts)->c.c_car == form) + {ifuncall2(sSAbreak_pointsA->s.s_gfdef,form, + list(3,lex_env[0],lex_env[1],lex_env[2])); + + break;} + bpts++;} + }} + + fun = MMcar(form); + if (type_of(fun) != t_symbol) + goto LAMBDA; + if (fun->s.s_sfdef != NOT_SPECIAL) { + ihs_check; + ihs_push(form); + ihs_top->ihs_base = lex_env; + (*fun->s.s_sfdef)(MMcdr(form)); + CHECK_AVMA; + ihs_pop(); + return; + } + /* x = lex_fd_sch(fun); */ + for (x = lex_env[1]; type_of(x) == t_cons; x = x->c.c_cdr) + if (x->c.c_car->c.c_car == fun) { + x = x->c.c_car; + if (MMcadr(x) == sLmacro) { + x = MMcaddr(x); + goto EVAL_MACRO; + } + x = MMcaddr(x); + goto EVAL_ARGS; + } + + if ((x = fun->s.s_gfdef) == OBJNULL) + FEundefined_function(fun); + + if (fun->s.s_mflag) { + EVAL_MACRO: + top = vs_top; + form=Imacro_expand1(x, form); + vs_top = top; + vs_push(form); + goto EVAL; + } + + + +EVAL_ARGS: + vs_push(x); + ihs_check; + ihs_push(form); + ihs_top->ihs_base = lex_env; + form = form->c.c_cdr; + base = vs_top; + top = vs_top; + while(!endp(form)) { + eval(MMcar(form)); + top[0] = vs_base[0]; + vs_top = ++top; + form = MMcdr(form); + } + vs_base = base; + if (Vapplyhook->s.s_dbind != Cnil) { + call_applyhook(fun); + return; + } + ihs_top->ihs_function = x; + ihs_top->ihs_base = vs_base; + if (type_of(x) == t_cfun) + (*(x)->cf.cf_self)(); + else + funcall_no_event(x); + CHECK_AVMA; + ihs_pop(); + return; + +LAMBDA: + if (type_of(fun) == t_cons && MMcar(fun) == sLlambda) { + temporary = make_cons(lex_env[2], fun->c.c_cdr); + temporary = make_cons(lex_env[1], temporary); + temporary = make_cons(lex_env[0], temporary); + x = make_cons(sLlambda_closure, temporary); + vs_push(x); + goto EVAL_ARGS; + } + FEinvalid_function(fun); +} + +static void +call_applyhook(object fun) +{ + object ah; + object *v; + + ah = symbol_value(Vapplyhook); + v = vs_base + 1; + vs_push(Cnil); + while (vs_top > v) + stack_cons(); + vs_push(vs_base[0]); + vs_base[0] = fun; + vs_push(lex_env[0]); + vs_push(lex_env[1]); + vs_push(lex_env[2]); + vs_push(Cnil); + stack_cons(); + stack_cons(); + stack_cons(); + super_funcall(ah); +} + + +DEFUNOM_NEW("FUNCALL",object,fLfuncall,LISP + ,1,MAX_ARGS,NONE,OO,OO,OO,OO,void,Lfuncall,(object fun,...),"") +{ va_list ap; + object *new; + int n = VFUN_NARGS; + va_start(ap,fun); + {COERCE_VA_LIST(new,ap,n); + return IapplyVector(fun,n-1,new); + va_end(ap); + } +} + + +DEFUNOM_NEW("APPLY",object,fLapply,LISP + ,2,MAX_ARGS,NONE,OO,OO,OO,OO,void,Lapply,(object fun,...),"") +{ int m,n=VFUN_NARGS; + object l; + object buf[MAX_ARGS]; + object *base=buf; + va_list ap; + va_start(ap,fun); + m = n-1; + while (--m >0) + {*base++ = va_arg(ap,object); + } + m = n-2; + l = va_arg(ap,object); + va_end(ap); + while (!endp(l)) + { if (m >= MAX_ARGS) FEerror(" Lisps arglist maximum surpassed",0); + *base++ = Mcar(l); + l = Mcdr(l); + m++;} + return IapplyVector(fun,m,buf); + } + + +DEFUNOM_NEW("EVAL",object,fLeval,LISP + ,1,1,NONE,OO,OO,OO,OO,void,Leval,(object x0),"") +{ + object *lex = lex_env; + + /* 1 args */ + lex_new(); + /* eval(vs_base[0]); */ + eval(x0); + lex_env = lex; + return Ivs_values(); +} + +LFD(Levalhook)(void) +{ + object env; + bds_ptr old_bds_top = bds_top; + object *lex = lex_env; + int n = vs_top - vs_base; + + lex_env = vs_top; + if (n < 3) + too_few_arguments(); + else if (n == 3) { + *(struct nil3 *)vs_top = three_nils; + vs_top += 3; + } else if (n == 4) { + env = vs_base[3]; + vs_push(car(env)); + env = cdr(env); + vs_push(car(env)); + env = cdr(env); + vs_push(car(env)); + } else + too_many_arguments(); + bds_bind(Vevalhook, vs_base[1]); + bds_bind(Vapplyhook, vs_base[2]); + eval1 = 1; + eval(vs_base[0]); + lex_env = lex; + bds_unwind(old_bds_top); +} + +LFD(Lapplyhook)(void) +{ + + object env; + bds_ptr old_bds_top = bds_top; + object *lex = lex_env; + int n = vs_top - vs_base; + object l, *z; + + lex_env = vs_top; + if (n < 4) + too_few_arguments(); + else if (n == 4) { + *(struct nil3 *)vs_top = three_nils; + vs_top += 3; + } else if (n == 5) { + env = vs_base[4]; + vs_push(car(env)); + env = cdr(env); + vs_push(car(env)); + env = cdr(env); + vs_push(car(env)); + } else + too_many_arguments(); + bds_bind(Vevalhook, vs_base[2]); + bds_bind(Vapplyhook, vs_base[3]); + z = vs_top; + for (l = vs_base[1]; !endp(l); l = l->c.c_cdr) + vs_push(l->c.c_car); + l = vs_base[0]; + vs_base = z; + super_funcall(l); + lex_env = lex; + bds_unwind(old_bds_top); +} + +DEFUNO_NEW("CONSTANTP",object,fLconstantp,LISP + ,1,1,NONE,OO,OO,OO,OO,void,Lconstantp,(object x0),"") +{ + enum type x; + /* 1 args */ + + x = type_of(x0); + if(x == t_cons) + if(x0->c.c_car == sLquote) + x0 = Ct; + else x0 = Cnil; + else if(x == t_symbol) + if((enum stype)x0->s.s_stype == stp_constant) + x0 = Ct; + else + x0 = Cnil; + else + x0 = Ct; + RETURN1(x0); +} + +object +ieval(object x) +{ + object *old_vs_base; + object *old_vs_top; + + old_vs_base = vs_base; + old_vs_top = vs_top; + eval(x); + x = vs_base[0]; + vs_base = old_vs_base; + vs_top = old_vs_top; + return(x); +} + +object +ifuncall1(object fun, object arg1) +{ + object *old_vs_base; + object *old_vs_top; + object x; + + old_vs_base = vs_base; + old_vs_top = vs_top; + vs_base = vs_top; + vs_push(arg1); + super_funcall(fun); + x = vs_base[0]; + vs_top = old_vs_top; + vs_base = old_vs_base; + return(x); +} + +object +ifuncall2(object fun, object arg1, object arg2) +{ + object *old_vs_base; + object *old_vs_top; + object x; + + old_vs_base = vs_base; + old_vs_top = vs_top; + vs_base = vs_top; + vs_push(arg1); + vs_push(arg2); + super_funcall(fun); + x = vs_base[0]; + vs_top = old_vs_top; + vs_base = old_vs_base; + return(x); +} + +object +ifuncall3(object fun, object arg1, object arg2, object arg3) +{ + object *old_vs_base; + object *old_vs_top; + object x; + + old_vs_base = vs_base; + old_vs_top = vs_top; + vs_base = vs_top; + vs_push(arg1); + vs_push(arg2); + vs_push(arg3); + super_funcall(fun); + x = vs_base[0]; + vs_top = old_vs_top; + vs_base = old_vs_base; + return(x); +} + +void +funcall_with_catcher(object fname, object fun) +{ + int n = vs_top - vs_base; + if (n > 64) n = 64; + frs_push(FRS_CATCH, make_cons(fname, make_fixnum(n))); + if (nlj_active) + nlj_active = FALSE; + else + funcall(fun); + frs_pop(); +} + +static object +fcalln_cclosure(object first,va_list ap) +{ +int i=fcall.argd; + {object *base=vs_top,*old_base=base; + DEBUG_AVMA + vs_base=base; + if (i) { + *(base++)=first; + i--; + } + switch(i){ + case 10: *(base++)=va_arg(ap,object); + case 9: *(base++)=va_arg(ap,object); + case 8: *(base++)=va_arg(ap,object); + case 7: *(base++)=va_arg(ap,object); + case 6: *(base++)=va_arg(ap,object); + case 5: *(base++)=va_arg(ap,object); + case 4: *(base++)=va_arg(ap,object); + case 3: *(base++)=va_arg(ap,object); + case 2: *(base++)=va_arg(ap,object); + case 1: *(base++)=va_arg(ap,object); + case 0: break; + default: + FEerror("bad args",0); + } vs_top=base; + base=old_base; + do{object fun=fcall.fun; + object *top, *base, l; + + massert(fun->cc.cc_turbo); + if (fun->cc.cc_turbo != NULL) { + (*fun->cc.cc_self)(fun); + break; + } + top = vs_top; + base = vs_base; + for (l = fun->cc.cc_env; !endp(l); l = l->c.c_cdr) + vs_push(l); + vs_base = vs_top; + while (base < top) + vs_push(*base++); + (*fcall.fun->cc.cc_self)(top); + break; + }while (0); + vs_top=base; + CHECK_AVMA; + return(vs_base[0]); +}} + +static object +fcalln_general(object first,va_list ap) { + int i=fcall.argd; + + { + int n= SFUN_NARGS(i); + /* object *old_vs_base=vs_base; */ + object *old_vs_top=vs_top; + object x; + enum ftype typ,restype=SFUN_RETURN_TYPE(i); + vs_top = vs_base = old_vs_top; + SFUN_START_ARG_TYPES(i); + if (i==0) { + int jj=0; + while (n-- > 0) { + typ= SFUN_NEXT_TYPE(i); + x = + (typ==f_object ? (jj ? va_arg(ap,object) : first): + typ==f_fixnum ? make_fixnum((jj ? va_arg(ap,fixnum) : (fixnum)first)): + (object) (FEerror("bad type",0),Cnil)); + *(vs_top++) = x; + jj++; + } + } else { + object *base=vs_top; + *(base++)=first; + n--; + while (n-- > 0) + *(base++) = va_arg(ap,object); + vs_top=base; + } + funcall(fcall.fun); + x= vs_base[0]; + vs_top=old_vs_top; + /* vs_base=old_vs_base; */ + return (restype== f_object ? x : + restype== f_fixnum ? (object) (fix(x)): + (object) (FEerror("bad type",0),Cnil)); + } +} + +static object +fcalln_vfun(object first,va_list vl) +{object *new,res; + DEBUG_AVMA + COERCE_VA_LIST_NEW(new,first,vl,fcall.argd); + res = c_apply_n_fun(fcall.fun,fcall.argd,new); + CHECK_AVMA; + return res; +} + +object +fcalln1(object first,...) +{ va_list ap; + object fun=fcall.fun; + DEBUG_AVMA + va_start(ap,first); + if(type_of(fun)==t_cfun) + {object *base=vs_top,*old_base=base; + int i=fcall.argd; + vs_base=base; + if (i) { + *(base++)=first; + i--; + } + switch(i){ + case 10: *(base++)=va_arg(ap,object); + case 9: *(base++)=va_arg(ap,object); + case 8: *(base++)=va_arg(ap,object); + case 7: *(base++)=va_arg(ap,object); + case 6: *(base++)=va_arg(ap,object); + case 5: *(base++)=va_arg(ap,object); + case 4: *(base++)=va_arg(ap,object); + case 3: *(base++)=va_arg(ap,object); + case 2: *(base++)=va_arg(ap,object); + case 1: *(base++)=va_arg(ap,object); + case 0: break; + default: + FEerror("bad args",0); + } vs_top=base; + base=old_base; + (*fcall.fun->cf.cf_self)(); + vs_top=base; + CHECK_AVMA; + return(vs_base[0]); + } + if(type_of(fun)==t_cclosure) + return(fcalln_cclosure(first,ap)); + if(type_of(fun)==t_vfun) + return(fcalln_vfun(first,ap)); + return(fcalln_general(first,ap)); + va_end(ap); + } + +/* call a cfun eg funcall_cfun(Lmake_hash_table,2,sKtest,sLeq) */ +/* typedef void (*funcvoid)(); */ + +object +funcall_cfun(funcvoid fn,int n,...) +{object *old_top = vs_top; + object *old_base= vs_base; + object result; + va_list ap; + DEBUG_AVMA + vs_base=vs_top; + va_start(ap,n); + while(n-->0) vs_push(va_arg(ap,object)); + va_end(ap); + (*fn)(); + if(vs_top>vs_base) result=vs_base[0]; + else result=Cnil; + vs_top=old_top; + vs_base=old_base; + CHECK_AVMA; + return result;} + +DEF_ORDINARY("LAMBDA-BLOCK-EXPANDED",sSlambda_block_expanded,SI,""); +DEFVAR("*BREAK-POINTS*",sSAbreak_pointsA,SI,Cnil,""); +DEFVAR("*BREAK-STEP*",sSAbreak_stepA,SI,Cnil,""); + +void +gcl_init_eval(void) +{ + + + + + make_constant("CALL-ARGUMENTS-LIMIT", make_fixnum(64)); + + + Vevalhook = make_special("*EVALHOOK*", Cnil); + Vapplyhook = make_special("*APPLYHOOK*", Cnil); + + + three_nils.nil3_self[0] = Cnil; + three_nils.nil3_self[1] = Cnil; + three_nils.nil3_self[2] = Cnil; + + make_function("EVALHOOK", Levalhook); + make_function("APPLYHOOK", Lapplyhook); + +} diff --git a/o/external_funs.h b/o/external_funs.h new file mode 100755 index 0000000..d3b51c3 --- /dev/null +++ b/o/external_funs.h @@ -0,0 +1,423 @@ +/* for file nfunlink.X */ + +extern object Icall_proc GPR((object fun_name, int link_desk, object (**link_loc) ( ), ...));; +extern float Icall_proc_float GPR((object fun_name, int link_desk, object (**link_loc) ( ), ...));; +extern object IapplyVector GPR((object fun, int nargs, object *base));; +extern int Iinvoke_c_function_from_value_stack GPR((int f, int fargd));; + +/* for file alloc.X */ + +extern char *alloc_page GPR((int n));; +extern void add_page_to_freelist GPR((char *p, struct typemanager *tm));; +extern object alloc_object GPR((enum type t));; +extern int grow_linear GPR((int old, int fract, int grow_min, int grow_max));; +extern object make_cons GPR((object a, object d));; +extern object on_stack_cons GPR((object x, object y));; +extern void call_after_gbc_hook GPR((int t));; +extern object fSallocated GPR((object typ));; +extern char *alloc_contblock GPR((int n));; +extern int insert_contblock GPR((char *p, int s));; +extern int insert_maybe_sgc_contblock GPR((char *p, int s));; +extern char *alloc_relblock GPR((int n));; +extern int init_tm GPR((enum type t, char *name, int elsize, int nelts, int sgc));; +extern int set_maxpage GPR((void));; +extern int init_alloc GPR((void));; +extern int cant_get_a_type GPR((void));; +extern int siLallocate GPR((void));; +extern int t_from_type GPR((object type));; +extern object siSallocate_sgc GPR((object type, int min, int max, int free_percent));; +extern object siSallocate_growth GPR((object type, int min, int max, int percent, int percent_free));; +extern int siLallocated_pages GPR((void));; +extern int siLmaxpage GPR((void));; +extern int siLalloc_contpage GPR((void));; +extern int siLncbpage GPR((void));; +extern int siLmaxcbpage GPR((void));; +extern int siLalloc_relpage GPR((void));; +extern int siLnrbpage GPR((void));; +extern int siLget_hole_size GPR((void));; +extern int siLset_hole_size GPR((void));; +extern int init_alloc_function GPR((void));; +extern char *malloc GPR((int size));; +extern void free GPR((void *ptr));; +extern char *realloc GPR((char *ptr, int size));; +extern char *calloc GPR((int nelem, int elsize));; +extern int cfree GPR((char *ptr));; +extern char *memalign GPR((int align, int size));; +extern char *valloc GPR((int size));; + +/* for file array.X */ + +extern enum aelttype get_aelttype GPR((object x));; +extern enum aelttype array_elttype GPR((object x));; +extern char *array_address GPR((object x, int inc));; +extern char *raw_aet_ptr GPR((object x, short int typ));; +extern int gset GPR((char *p1, char *val, int n, int typ));; +extern int copy_array_portion GPR((object x, object y, int i1, int i2, int n1));; +extern int siLcopy_array_portion GPR((void));; +extern int array_allocself GPR((object x, bool staticp, object dflt));; +extern object aref GPR((object x, int index));; +extern object aset GPR((object x, int index, object value));; +extern object aref1 GPR((object v, int index));; +extern object aset1 GPR((object v, int index, object val));; +extern int displace GPR((object from, object to, object offset));; +extern int undisplace GPR((object from));; +extern int check_displaced GPR((object dlist, object orig, int newdim));; +extern int adjust_displaced GPR((object x, int diff));; +extern int setup_fillp GPR((object x, object fillp));; +extern int siLmake_pure_array GPR((void));; +extern int siLmake_vector GPR((void));; +extern int Laref GPR((void));; +extern int siLaset GPR((void));; +extern int Larray_element_type GPR((void));; +extern int Larray_rank GPR((void));; +extern int Larray_dimension GPR((void));; +extern int Larray_total_size GPR((void));; +extern int Ladjustable_array_p GPR((void));; +extern int siLdisplaced_array_p GPR((void));; +extern int Lsvref GPR((void));; +extern int siLsvset GPR((void));; +extern int Larray_has_fill_pointer_p GPR((void));; +extern int Lfill_pointer GPR((void));; +extern int siLfill_pointer_set GPR((void));; +extern int siLreplace_array GPR((void));; +extern int siLaset_by_cursor GPR((void));; +extern int init_array_function GPR((void));; + +/* for file assignment.X */ + +extern int setq GPR((object sym, object val));; +extern int Fsetq GPR((object form));; +extern int Fpsetq GPR((object arg));; +extern int Lset GPR((void));; +extern int siLfset GPR((void));; +extern int Fmultiple_value_setq GPR((object form));; +extern int Lmakunbound GPR((void));; +extern int Lfmakunbound GPR((void));; +extern int Fsetf GPR((object form));; +extern int setf GPR((object place, object form));; +extern int Fpush GPR((object form));; +extern int Fpop GPR((object form));; +extern int Fincf GPR((object form));; +extern int Fdecf GPR((object form));; +extern object clear_compiler_properties GPR((object sym, object code));; +extern int siLclear_compiler_properties GPR((void));; +extern int init_assignment GPR((void));; + +/* for file backq.X */ + +extern int kwote_cdr GPR((void));; +extern int kwote_car GPR((void));; +extern int backq_cdr GPR((object x));; +extern int backq_car GPR((object x));; +extern object backq GPR((object x));; +extern int Lcomma_reader GPR((void));; +extern int Lbackquote_reader GPR((void));; +extern int init_backq GPR((void));; + +/* for file bcmp.X */ + +extern int bcmp GPR((char *s1, char *s2, int n));; + +/* for file bcopy.X */ + +extern void bcopy GPR((char *s1, char *s2, int n));; + +/* for file bds.X */ + +extern int bds_unwind GPR((bds_ptr new_bds_top));; + +/* for file big.X */ + +extern int bcopy_body GPR((GEN x, GEN y));; +extern object make_integer GPR((GEN u));; +extern object make_bignum GPR((GEN u));; +extern int big_zerop GPR((object x));; +extern int big_compare GPR((object x, object y));; +extern object big_minus GPR((object x));; +extern int gcopy_to_big GPR((GEN res, object x));; +extern int add_int_big GPR((int i, object x));; +extern int sub_int_big GPR((int i, object x));; +extern int mul_int_big GPR((int i, object x));; +extern int div_int_big GPR((int i, object x));; +extern object big_plus GPR((object x, object y));; +extern object big_times GPR((object x, object y));; +extern int big_quotient_remainder GPR((object x0, object y0, object *qp, object *rp));; +extern double big_to_double GPR((object x));; +extern object normalize_big_to_object GPR((object x));; +extern object copy_big GPR((object x));; +extern object copy_to_big GPR((object x));; +extern GEN powerii GPR((GEN x, GEN y));; +extern int replace_copy1 GPR((GEN x, GEN y));; +extern GEN replace_copy2 GPR((GEN x, GEN y));; +extern int obj_replace_copy1 GPR((object x, GEN y));; +extern GEN obj_replace_copy2 GPR((object x, GEN y));; +extern GEN1 otoi GPR((object x));; +extern object alloc_bignum_static GPR((int len));; +extern GEN1 setq_io GPR((GEN x, object *all, object val));; +extern GEN1 setq_ii GPR((GEN x, object *all, GEN val));; +extern void isetq_fix GPR((GEN var, int s));; +extern GEN icopy_bignum GPR((object a, GEN y));; +extern GEN icopy_fixnum GPR((object a, GEN y));; + +/* for file bind.X */ + +extern int lambda_bind GPR((object *arg_top));; +extern int bind_var GPR((object var, object val, object spp));; +extern int illegal_lambda GPR((void));; +extern object find_special GPR((object body, struct bind_temp *start, struct bind_temp *end));; +extern object let_bind GPR((object body, struct bind_temp *start, struct bind_temp *end));; +extern object letA_bind GPR((object body, struct bind_temp *start, struct bind_temp *end));; +extern int parse_key GPR((object *base, bool rest, bool allow_other_keys, register int n, int __builtin_va_alist));; +extern int check_other_key GPR((object l, int n, int __builtin_va_alist));; +extern int parse_key_new GPR((int n, object *base, struct key *keys, ...));; +extern int parse_key_rest GPR((object rest, int n, object *base, struct key *keys, ...));; +extern int set_key_struct GPR((struct key *ks, object data));; +extern int init_bind GPR((void));; + +/* for file bitop.X */ + +extern int get_mark_bit GPR((void));; +extern int set_mark_bit GPR((void));; +extern int get_set_mark_bit GPR((void));; + +/* for file block.X */ + +extern int Fblock GPR((object args));; +extern int Freturn_from GPR((object args));; +extern int Freturn GPR((object args));; +extern int init_block GPR((void));; + +/* for file bzero.X */ + +extern int bzero GPR((char *b, int length));; + +/* for file catch.X */ + +extern int Fcatch GPR((object args));; +extern int siLerror_set GPR((void));; +extern int Funwind_protect GPR((object args));; +extern int Fthrow GPR((object args));; +extern int init_catch GPR((void));; + +/* for file cfun.X */ + +extern object make_cfun GPR((int (*self) ( ), object name, object data, char *start, int size));; +extern object make_sfun GPR((object name, int (*self) ( ), int argd, object data));; +extern object make_vfun GPR((object name, int (*self) ( ), int argd, object data));; +extern object make_cclosure_new GPR((int (*self) ( ), object name, object env, object data));; +extern object make_cclosure GPR((int (*self) ( ), object name, object env, object data, char *start, int size));; +extern int siLmc GPR((void));; +extern object MFsfun GPR((object sym, int (*self) ( ), int argd, object data));; +extern int siLmfsfun GPR((void));; +extern object MFvfun GPR((object sym, int (*self) ( ), int argd, object data));; +extern int siLmfvfun GPR((void));; +extern object MFvfun_key GPR((object sym, int (*self) ( ), int argd, object data, char *keys));; +extern int siLmfvfun_key GPR((void));; +extern object MFnew GPR((object sym, int (*self) ( ), object data));; +extern int siLmf GPR((void));; +extern object MF GPR((object sym, int (*self) ( ), char *start, int size, object data));; +extern object MM GPR((object sym, int (*self) ( ), char *start, int size, object data));; +extern int siLmm GPR((void));; +extern object make_function GPR((char *s, int (*f) ( )));; +extern object make_si_sfun GPR((char *s, int (*f) ( ), int argd));; +extern object make_si_vfun1 GPR((char *s, int (*f) ( ), int argd));; +extern object make_si_function GPR((char *s, int (*f) ( )));; +extern object make_special_form GPR((char *s, int (*f) ( )));; +extern int siLcompiled_function_name GPR((void));; +extern int turbo_closure GPR((object fun));; +extern int siLturbo_closure GPR((void));; +extern int init_cfun GPR((void));; + +/* for file character.X */ + +extern int Lstandard_char_p GPR((void));; +extern int Lgraphic_char_p GPR((void));; +extern int Lstring_char_p GPR((void));; +extern int Lalpha_char_p GPR((void));; +extern int Lupper_case_p GPR((void));; +extern int Llower_case_p GPR((void));; +extern int Lboth_case_p GPR((void));; +extern int digitp GPR((int i, int r));; +extern int Ldigit_char_p GPR((void));; +extern int Lalphanumericp GPR((void));; +extern bool char_eq GPR((object x, object y));; +extern int Lchar_eq GPR((void));; +extern int Lchar_neq GPR((void));; +extern int char_cmp GPR((object x, object y));; +extern int Lchar_cmp GPR((int s, int t));; +extern int Lchar_l GPR((void));; +extern int Lchar_g GPR((void));; +extern int Lchar_le GPR((void));; +extern int Lchar_ge GPR((void));; +extern bool char_equal GPR((object x, object y));; +extern int Lchar_equal GPR((void));; +extern int Lchar_not_equal GPR((void));; +extern int char_compare GPR((object x, object y));; +extern int Lchar_compare GPR((int s, int t));; +extern int Lchar_lessp GPR((void));; +extern int Lchar_greaterp GPR((void));; +extern int Lchar_not_greaterp GPR((void));; +extern int Lchar_not_lessp GPR((void));; +extern object coerce_to_character GPR((object x));; +extern int Lcharacter GPR((void));; +extern int Lchar_code GPR((void));; +extern int Lchar_bits GPR((void));; +extern int Lchar_font GPR((void));; +extern int Lcode_char GPR((void));; +extern int Lmake_char GPR((void));; +extern int Lchar_upcase GPR((void));; +extern int Lchar_downcase GPR((void));; +extern int digit_weight GPR((int w, int r));; +extern int Ldigit_char GPR((void));; +extern int Lchar_int GPR((void));; +extern int Lint_char GPR((void));; +extern int Lchar_name GPR((void));; +extern int Lname_char GPR((void));; +extern int Lchar_bit GPR((void));; +extern int Lset_char_bit GPR((void));; +extern int init_character GPR((void));; +extern int init_character_function GPR((void));; + +/* for file cmpaux.X */ + +extern int siLspecialp GPR((void));; +extern void siLdefvar1 GPR((void));; +extern void siLdebug GPR((void));; +extern void siLsetvv GPR((void));; +extern int init_cmpaux GPR((void));; +extern int ifloor GPR((int x, int y));; +extern int imod GPR((int x, int y));; +extern int set_VV_data GPR((object *VV, int n, object data, char *start, int size));; +extern int set_VV GPR((object *VV, int n, object data));; +extern char object_to_char GPR((object x));; +extern int object_to_int GPR((object x));; +extern float object_to_float GPR((object x));; +extern double object_to_double GPR((object x));; +extern char *object_to_string GPR((object x));; +extern int call_init GPR((int init_address, object memory, object fasl_vec));; +extern int do_init GPR((object *statVV));; +extern void init_or_load1 GPR((int (*fn) ( ), char *file));; + +/* for file conditional.X */ + +extern int Fif GPR((object form));; +extern int Fcond GPR((object args));; +extern int Fcase GPR((object arg));; +extern int Fwhen GPR((object form));; +extern int Funless GPR((object form));; +extern int init_conditional GPR((void));; + +/* for file earith.X */ + +extern int init_cmac GPR((void));; +extern object signed_bignum2 GPR((int hi, int lo));; +extern object fplus GPR((int a, int b));; +extern object fminus GPR((int a, int b));; +extern int dblrem GPR((int a, int b, int mod));; +extern object cmod GPR((object x));; +extern object ctimes GPR((object a, object b));; +extern object cdifference GPR((object a, object b));; +extern object cplus GPR((object a, object b));; +extern void siLcmod GPR((void));; +extern void siLcplus GPR((void));; +extern void siLctimes GPR((void));; +extern void siLcdifference GPR((void));; +extern object memq GPR((register object a, register object b));; + +/* for file error.X */ + +extern int terminal_interrupt GPR((int correctable));; +extern object ihs_function_name GPR((object x));; +extern object ihs_top_function_name GPR((void));; +extern int call_error_handler GPR((void));; +extern int FEerror GPR((char *s, int num, object arg1, object arg2, object arg3, object arg4));; +extern int FEwrong_type_argument GPR((object type, object value));; +extern int FEtoo_few_arguments GPR((object *base, object *top));; +extern int FEtoo_few_argumentsF GPR((object args));; +extern int FEtoo_many_arguments GPR((object *base, object *top));; +extern int FEtoo_many_argumentsF GPR((object args));; +extern int FEinvalid_macro_call GPR((void));; +extern int FEunexpected_keyword GPR((object key));; +extern int FEinvalid_form GPR((char *s, object form));; +extern int FEunbound_variable GPR((object sym));; +extern int FEinvalid_variable GPR((char *s, object obj));; +extern int FEundefined_function GPR((object fname));; +extern int FEinvalid_function GPR((object obj));; +extern int CEerror GPR((char *err_str, char *cont_str, int num, object arg1, object arg2, object arg3, object arg4));; +extern ihs_ptr get_ihs_ptr GPR((object x));; +extern int siLihs_top GPR((void));; +extern int siLihs_fun GPR((void));; +extern int siLihs_vs GPR((void));; +extern frame_ptr get_frame_ptr GPR((object x));; +extern int siLfrs_top GPR((void));; +extern int siLfrs_vs GPR((void));; +extern int siLfrs_bds GPR((void));; +extern int siLfrs_class GPR((void));; +extern int siLfrs_tag GPR((void));; +extern int siLfrs_ihs GPR((void));; +extern bds_ptr get_bds_ptr GPR((object x));; +extern int siLbds_top GPR((void));; +extern int siLbds_var GPR((void));; +extern int siLbds_val GPR((void));; +extern object *get_vs_ptr GPR((object x));; +extern int siLvs_top GPR((void));; +extern int siLvs GPR((void));; +extern int siLsch_frs_base GPR((void));; +extern int siLinternal_super_go GPR((void));; +extern int siLuniversal_error_handler GPR((void));; +extern int check_arg_failed GPR((int n));; +extern int too_few_arguments GPR((void));; +extern int too_many_arguments GPR((void));; +extern int ck_larg_at_least GPR((int n, object x));; +extern int ck_larg_exactly GPR((int n, object x));; +extern int invalid_macro_call GPR((void));; +extern int keyword_value_mismatch GPR((void));; +extern int not_a_keyword GPR((object x));; +extern int unexpected_keyword GPR((object key));; +extern object wrong_type_argument GPR((object typ, object obj));; +extern int illegal_declare GPR((int form));; +extern int not_a_symbol GPR((int obj));; +extern int not_a_variable GPR((int obj));; +extern int illegal_index GPR((object x, object i));; +extern int Lerror GPR((void));; +extern object LVerror GPR((int __builtin_va_alist));; +extern int Lcerror GPR((void));; +extern int vfun_wrong_number_of_args GPR((object x));; +extern int init_error GPR((void));; + +/* for file eval.X */ + +extern int quick_call_sfun GPR((object fun));; +extern int call_sfun_no_check GPR((object fun));; +extern int call_vfun GPR((object fun));; +extern int funcall GPR((object fun));; +extern int funcall_no_event GPR((object fun));; +extern int lispcall GPR((object *funp, int narg));; +extern int lispcall_no_event GPR((object *funp, int narg));; +extern int symlispcall GPR((object sym, object *base, int narg));; +extern int symlispcall_no_event GPR((object sym, object *base, int narg));; +extern object simple_lispcall GPR((object *funp, int narg));; +extern object simple_lispcall_no_event GPR((object *funp, int narg));; +extern object simple_symlispcall GPR((object sym, object *base, int narg));; +extern object simple_symlispcall_no_event GPR((object sym, object *base, int narg));; +extern int super_funcall GPR((object fun));; +extern int super_funcall_no_event GPR((object fun));; +extern int eval GPR((object form));; +extern int call_applyhook GPR((object fun));; +extern int Lfuncall GPR((void));; +extern int Lapply GPR((void));; +extern int Leval GPR((void));; +extern int Levalhook GPR((void));; +extern int Lapplyhook GPR((void));; +extern int Lconstantp GPR((void));; +extern object ieval GPR((object x));; +extern object ifuncall1 GPR((object fun, object arg1));; +extern object ifuncall2 GPR((object fun, object arg1, object arg2));; +extern object ifuncall3 GPR((object fun, object arg1, object arg2, object arg3));; +extern int funcall_with_catcher GPR((object fname, object fun));; +extern object fcalln_cclosure GPR((...));; +extern object fcalln_general GPR((...));; +extern object fcalln_vfun GPR((va_list vl));; +extern object fcalln GPR((int __builtin_va_alist));; +extern object funcall_cfun GPR((funcvoid fn, int n, int __builtin_va_alist));; +extern int init_eval GPR((void));; diff --git a/o/fasdump.c b/o/fasdump.c new file mode 100755 index 0000000..b7821dd --- /dev/null +++ b/o/fasdump.c @@ -0,0 +1,1598 @@ + /* Copyright William F. Schelter All Rights Reserved. + + Utility for writing out lisp objects and reading them in: + Basically it attempts to write out only those things which could + be written out using princ and reread. It just uses less space + and is faster. + + + Primitives for dealing with a `fasd stream'. + Such a stream is really an array containing some state and a lisp file stream. + Note that having *print-circle* == nil wil make this faster. gensyms will + still be dumped correctly in that case. + + open_fasd + write_fasd_top + read_fasd_top + close_fasd + + */ + + + +#ifndef FAT_STRING +#include "include.h" +#endif + +static void +clrhash(object); + + +object coerce_stream(); +static object fasd_patch_sharp(object x, int depth); +object make_pathname (); + + +static int needs_patching; + + +struct fasd { + object stream; /* lisp object of type stream */ + object table; /* hash table used in dumping or vector on input*/ + object eof; /* lisp object to be returned on coming to eof mark */ + object direction; /* holds Cnil or sKinput or sKoutput */ + object package; /* the package symbols are in by default */ + object index; /* integer. The current_dump index on write */ + object filepos; /* nil or the position of the start */ + object table_length; /* On read it is set to the size dump array needed + or 0 + */ + object evald_items; /* a list of items which have been eval'd and must + not be walked by fasd_patch_sharp */ +}; + +struct fasd current_fasd; + + +enum circ_ind { + LATER_INDEX, + NOT_INDEXED, + FIRST_INDEX, + }; + +enum dump_type { + d_nil, /* dnil: nil */ + d_eval_skip, /* deval o1: evaluate o1 after reading it */ + d_delimiter, /* occurs after d_list,d_general and d_new_indexed_items */ + d_enter_vector, /* d_enter_vector o1 o2 .. on d_delimiter , make a cf_data with + this length. Used internally by akcl. Just make + an array in other lisps */ + d_cons, /* d_cons o1 o2: (o1 . o2) */ + d_dot, + d_list, /* list* delimited by d_delimiter d_list,o1,o2, ... ,d_dot,on + for (o1 o2 . on) + or d_list,o1,o2, ... ,on,d_delimiter for (o1 o2 ... on) + */ + d_list1, /* nil terminated length 1 d_list1,o1 */ + d_list2, /* nil terminated length 2 */ + d_list3, + d_list4, + d_eval, + d_short_symbol, + d_short_string, + d_short_fixnum, + d_short_symbol_and_package, + d_bignum, + d_fixnum, + d_string, + d_objnull, + d_structure, + d_package, + d_symbol, + d_symbol_and_package, + d_end_of_file, + d_standard_character, + d_vector, + d_array, + d_begin_dump, + d_general_type, + d_sharp_equals, /* define a sharp */ + d_sharp_value, + d_sharp_value2, + d_new_indexed_item, + d_new_indexed_items, + d_reset_index, + d_macro, + d_reserve1, + d_reserve2, + d_reserve3, + d_reserve4, + d_indexed_item3, /* d_indexed_item3 followed by 3bytes to give index */ + d_indexed_item2, /* d_indexed_item2 followed by 2bytes to give index */ + d_indexed_item1, + d_indexed_item0 /* This must occur last ! */ + +}; + +/* set whole structures! */ +#define SETUP_FASD_IN(fd) do{ \ + fas_stream= (fd)->stream->sm.sm_fp; \ + dump_index = fix((fd)->index) ; \ + current_fasd= * (fd);}while(0) + +#define SAVE_CURRENT_FASD \ + struct fasd old_fd; \ + int old_dump_index = dump_index; \ + FILE *old_fas_stream = fas_stream; \ + int old_needs_patching = needs_patching; \ + old_fd = current_fasd; + + +#define RESTORE_FASD \ + current_fasd =old_fd ; \ + dump_index= old_dump_index ; \ + needs_patching = old_needs_patching ; \ + fas_stream = old_fas_stream + + +#define FASD_SHARP_LIMIT 250 /* less than short_max */ +#define SETUP_FASD_OUT(fasd) SETUP_FASD_IN(fasd) + +#define dump_hash_table (current_fasd.table) + +#define SIZE_D_CODE 8 +#define SIZE_BYTE 8 +#define SIZE_SHORT ((2*SIZE_BYTE) - SIZE_D_CODE) +/* this is not! the maximum short !! It is shorter */ +#define SHORT_MAX ((1<< SIZE_SHORT) -1) + + +/* given SHORT extract top code (say 4 bits) and bottom byte */ +#define TOP(i) (i >> SIZE_BYTE) +#define BOTTOM(i) (i & ~(~0 << SIZE_BYTE)) + +#define FASD_VERSION 2 + +FILE *fas_stream; +int dump_index; +struct htent *gethash(); +static void read_fasd1(int i, object *loc); +object extended_read(); + +/* to enable debugging define the following, + and set debug=1 or debug=2 +*/ +/* #define DEBUG */ + +#ifdef DEBUG + +#define PUT(x) putc1((char)x,fas_stream) +#define GET() getc1() +#define D_FWRITE fwrite1 +#define D_FREAD fread1 + +char *dump_type_names[]={ "d_nil", + "d_eval_skip", + "d_delimiter", + "d_enter_vector", + "d_cons", + "d_dot", + "d_list", + "d_list1", + "d_list2", + "d_list3", + "d_list4", + "d_eval", + "d_short_symbol", + "d_short_string", + "d_short_fixnum", + "d_short_symbol_and_package", + "d_bignum", + "d_fixnum", + "d_string", + "d_objnull", + "d_structure", + "d_package", + "d_symbol", + "d_symbol_and_package", + "d_end_of_file", + "d_standard_character", + "d_vector", + "d_array", + "d_begin_dump", + "d_general_type", + "d_sharp_equals", + "d_sharp_value", + "d_sharp_value2", + "d_new_indexed_item", + "d_new_indexed_items", + "d_reset_index", + "d_macro", + "d_reserve1", + "d_reserve2", + "d_reserve3", + "d_reserve4", + "d_indexed_item3", + "d_indexed_item2", + "d_indexed_item1", + "d_indexed_item0"}; + +int debug; +int +print_op(i) +{if (debug) + {if (i < d_indexed_item0 & i >= 0) + {printf("\n<%s>",dump_type_names[i]);} + else {printf("\n",i -d_indexed_item0);}} + return i; +} + +#define PUTD(str,i) putd(str,i) +void +putd(str,i) +char *str; + int i; +{if (debug) + {printf("{"); + printf(str,i); + printf("}");} + putc(i,fas_stream);} + +void +putc1(x) +int x; +{ if (debug) printf("(%x,%d,%c)",x,x,x); + putc(x,fas_stream); + fflush(stdout); + } + +int +getc1() +{ int x; + x= getc(fas_stream); + if (debug) printf("(%x,%d,%c)",x,x,x); + fflush(stdout); + return x; + } + +int +fread1(p,n1,n2,st) + FILE* st; + char *p; + int n1; + int n2; +{int i,j; + j=SAFE_FREAD(p,n1,n2,st); + if(debug) + {printf("["); + n1=n1*n2; + for(i=0;i> (SIZE_D_CODE)) + /* takes two bytes and reconstructs the SIZE_SHORT int from them after + dropping the code */ + + +/* takes two bytes i and j and returns the SHORT associated */ +#define LENGTH(i,j) MAKE_SHORT(E_TYPE_OF(i),(j)) + +#define MAKE_SHORT(top,bot) (((top)<< SIZE_BYTE) + (bot)) + +#define READ_BYTE1() getc(fas_stream) + +#define GET8(varx ) \ + do{unsigned long var=(unsigned long)READ_BYTE1(); \ + var |= ((unsigned long)READ_BYTE1() << SIZE_BYTE); \ + var |= ((unsigned long)READ_BYTE1() << (2*SIZE_BYTE)); \ + var |= ((unsigned long)READ_BYTE1() << (3*SIZE_BYTE)); \ + var |= ((unsigned long)READ_BYTE1() << (4*SIZE_BYTE)); \ + var |= ((unsigned long)READ_BYTE1() << (5*SIZE_BYTE)); \ + var |= ((unsigned long)READ_BYTE1() << (6*SIZE_BYTE)); \ + var |= ((unsigned long)READ_BYTE1() << (7*SIZE_BYTE)); \ + DPRINTF("{8byte:varx= %ld}", var); \ + varx=var;} while (0) + +#define GET4(varx ) \ + do{int var=READ_BYTE1(); \ + var |= (READ_BYTE1() << SIZE_BYTE); \ + var |= (READ_BYTE1() << (2*SIZE_BYTE)); \ + var |= (READ_BYTE1() << (3*SIZE_BYTE)); \ + DPRINTF("{4byte:varx= %d}", var); \ + varx=var;} while (0) + +#define GET2(varx ) \ + do{int var=READ_BYTE1(); \ + var |= (READ_BYTE1() << SIZE_BYTE); \ + DPRINTF("{2byte:varx= %d}", var); \ + varx=var;} while (0) + +#define GET3(varx ) \ + do{int var=READ_BYTE1(); \ + var |= (READ_BYTE1() << SIZE_BYTE); \ + var |= (READ_BYTE1() << (2*SIZE_BYTE)); \ + DPRINTF("{3byte:varx= %d}", var); \ + varx=var;} while (0) + + + +#define MASK ~(~0 << 8) +#define WRITE_BYTEI(x,i) putc((((x) >> (i*SIZE_BYTE)) & MASK),fas_stream) + +#define PUTFIX(v_) Join(PUT,SIZEOF_LONG)(v_) +#define GETFIX(v_) Join(GET,SIZEOF_LONG)(v_) + +#define PUT8(varx ) \ + do{unsigned long var= varx ; \ + DPRINTF("{8byte:varx= %ld}", var); \ + WRITE_BYTEI(var,0); \ + WRITE_BYTEI(var,1); \ + WRITE_BYTEI(var,2); \ + WRITE_BYTEI(var,3); \ + WRITE_BYTEI(var,4); \ + WRITE_BYTEI(var,5); \ + WRITE_BYTEI(var,6); \ + WRITE_BYTEI(var,7);} while(0) + +#define PUT4(varx ) \ + do{int var= varx ; \ + DPRINTF("{4byte:varx= %d}", var); \ + WRITE_BYTEI(var,0); \ + WRITE_BYTEI(var,1); \ + WRITE_BYTEI(var,2); \ + WRITE_BYTEI(var,3);} while(0) + +#define PUT2(var ) \ + do{int v=var; \ + DPRINTF("{2byte:var= %d}", v); \ + WRITE_BYTEI(v,0); \ + WRITE_BYTEI(v,1); \ + } while(0) + +#define PUT3(var ) \ + do{int v=var; \ + DPRINTF("{3byte:var= %d}", v); \ + WRITE_BYTEI(v,0); \ + WRITE_BYTEI(v,1); \ + WRITE_BYTEI(v,2); \ + } while(0) + + + + + /* constructs the first byte containing ecode and top + top either stands for something in extended codes, or for something + the top part of a SIZE_SHORT int + */ +#define MAKE_CODE(CODE,Top) \ + ((unsigned int)(CODE) | ((unsigned int)(Top) << SIZE_D_CODE)) + + +/* write out two bytes encoding the enum d_code CODE and SHORT SH. */ + + + +#define PUT_CODE_AND_SHORT(CODE,SH) \ + PUT(MAKE_CODE(CODE,TOP(SH))); \ + PUT(BOTTOM(SH)); + +#define READ_SYMBOL(leng,pack,to) \ + do { BEGIN_NO_INTERRUPT;{char *p=alloc_relblock(leng);\ + D_FREAD(p,1,leng,fas_stream); \ + string_register->st.st_fillp = \ + string_register->st.st_dim = leng; \ + string_register->st.st_self = p; \ + to=(pack==Cnil ? make_symbol(string_register) : intern(string_register,pack)); \ + END_NO_INTERRUPT;} \ + }while(0) + +#define READ_STRING(leng,loc) do {BEGIN_NO_INTERRUPT; \ + *loc = alloc_simple_string(leng); \ + (*loc)->st.st_self=alloc_relblock(leng); END_NO_INTERRUPT; \ +/* Now handled in SAFE_FREAD -- CM 20040210 */ \ +/* memset((*loc)->st.st_self,0,leng); */ /* fread won't restart if it triggers an SGC segfault -- CM */ \ + D_FREAD((*loc)->st.st_self,1,leng,fas_stream);} while(0) + +/* if try_hash finds it we don't need to write the object + Otherwise we write the index type and the object + */ +#define NUMBER_ZERO_ITEMS (SHORT_MAX - (int) d_indexed_item0) + + + +static enum circ_ind +do_hash(object obj, int dot) +{ struct htent *e; + int i; + e=gethash(obj,dump_hash_table); + if (e->hte_key==OBJNULL) +/* We won't index things unless they have < -2 in the hash table */ + { if(type_of(obj)!=t_package) return NOT_INDEXED; + sethash(obj,dump_hash_table,make_fixnum(dump_index)); + e=gethash(obj,dump_hash_table); + PUT_OP(d_new_indexed_item); + DPRINTF("{dump_index=%d}",dump_index); + dump_index++; + return FIRST_INDEX;} + + i = fix(e->hte_value); + if (i == -1) return NOT_INDEXED; /* don't want to index this baby */ + + if (dot) PUT_OP(dot); + if ( i < -1) + { e->hte_value = make_fixnum(dump_index); + PUT_OP(d_new_indexed_item); + DPRINTF("{dump_index=%d}",dump_index); + dump_index++; + return FIRST_INDEX; + } + if (i < (NUMBER_ZERO_ITEMS)) + {PUT_OP(i+(int)d_indexed_item0); return LATER_INDEX;} + if (i < (2*SHORT_MAX - (int)d_indexed_item0)) + {PUT_OP((int)d_indexed_item1); + PUTD("n=%d",i- NUMBER_ZERO_ITEMS); + return LATER_INDEX; + } + if (i < SHORT_MAX*SHORT_MAX) + {PUT_OP((int)d_indexed_item2); + PUT2(i); + return LATER_INDEX; + } + if (i < SHORT_MAX*SHORT_MAX*SHORT_MAX) + {PUT_OP((int)d_indexed_item3); + PUT3(i); + return LATER_INDEX; + } + else + FEerror("too large an index",0); + return LATER_INDEX; + } + +static void write_fasd(object obj); +DEFUN_NEW("WRITE-FASD-TOP",object,fSwrite_fasd_top,SI,2,2,NONE,OO,OO,OO,OO,(object obj, object x),"") +/* static object */ +/* FFN(write_fasd_top)(object obj, object x) */ +{struct fasd *fd = (struct fasd *) x->v.v_self; + if (fd->direction == sKoutput) + SETUP_FASD_IN(fd); + else FEerror("bad value for open slot of fasd",0); + + write_fasd(obj); + /* we could really allocate a fixnum and then smash its field if this + is to costly */ + (fd)->index = make_fixnum(dump_index); + return obj; +} + +/* It is assumed that anything passed to eval should be first + sharp patched, and that there will be no more patching afterwards. + The object returned might have arbitrary complexity. +*/ + +#define MAYBE_PATCH(result) \ + if (needs_patching) result =fasd_patch_sharp(result,0) + +DEFUN_NEW("READ-FASD-TOP",object,fSread_fasd_top,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") +/* static object */ +/* FFN(read_fasd_top)(object x) */ +{ struct fasd *fd = (struct fasd *) x->v.v_self; + VOL int e=0; + object result; + SAVE_CURRENT_FASD; + + SETUP_FASD_IN(fd); + + frs_push(FRS_PROTECT, Cnil); + if (nlj_active) { + e = TRUE; + goto L; + } + needs_patching=0; + if (current_fasd.direction == sKinput) + {read_fasd1(GET_OP(),&result); + MAYBE_PATCH(result); + (fd)->index = make_fixnum(dump_index); + fd->direction=current_fasd.direction; + + } + else + if(current_fasd.direction== Cnil) result= current_fasd.eof; + else + FEerror("Stream not open for input",0); + L: + + frs_pop(); + + if (e) { + nlj_active = FALSE; + unwind(nlj_fr, nlj_tag); + fd->direction=Cnil; + RESTORE_FASD; + return Cnil; + } + else + { RESTORE_FASD; + return result;} + } + +object sLeq; +object sSPinit; +void Lmake_hash_table(); + +DEFUN_NEW("OPEN-FASD",object,fSopen_fasd,SI,4,4,NONE,OO,OO,OO,OO,(object stream, object direction, object eof, object tabl),"") +/* static object */ +/* FFN(open_fasd)(object stream, object direction, object eof, object tabl) */ +{ object str=Cnil; + object result; + if(direction==sKinput) + {str=coerce_stream(stream,0); + if (tabl==Cnil) + tabl=alloc_simple_vector(0,aet_object); + else + check_type(tabl,t_vector);} + if(direction==sKoutput) + {str=coerce_stream(stream,1); + if(tabl==Cnil) tabl=funcall_cfun(Lmake_hash_table,2,sKtest,sLeq); + else + check_type(tabl,t_hashtable);} + check_type(str,t_stream); + result=alloc_simple_vector(sizeof(struct fasd)/sizeof(int),aet_object); + array_allocself(result,1,Cnil); + {struct fasd *fd= (struct fasd *)result->v.v_self; + fd->table=tabl; + fd->stream=stream; + fd->direction=direction; + fd->eof=eof; + fd->index=small_fixnum(0); + fd->package=symbol_value(sLApackageA); + fd->filepos = make_fixnum(file_position(stream)); + + SETUP_FASD_IN(fd); + if (direction==sKoutput){ + PUT_OP((int)d_begin_dump); + PUTD("version=%d",FASD_VERSION); + PUT4(0); /* reserve space for the size of index array needed */ + /* equivalent to: write_fasd(current_fasd.package); + except we don't want to index this, so that we can open + with an empty array. + */ + PUT_OP(d_package); + write_fasd(current_fasd.package->p.p_name); + + } + else /* input */ + { object tem; + read_fasd1(GET_OP(),&tem); + if(tem!=current_fasd.table) FEerror("not positioned at beginning of a dump",0); + } + fd->index=make_fixnum(dump_index); + fd->filepos=current_fasd.filepos; + fd->package=current_fasd.package; + return result; + }} + +DEFUN_NEW("CLOSE-FASD",object,fSclose_fasd,SI,1,1,NONE,OO,OO,OO,OO,(object ar),"") +/* static object */ +/* FFN(close_fasd)(object ar) */ +{ struct fasd *fd= (struct fasd *)(ar->v.v_self); + check_type(ar,t_vector); + if (type_of(fd->table)==t_vector) + /* input uses a vector */ + {if (fd->table->v.v_self) + gset(fd->table->v.v_self,0,fix(fd->index),aet_object); + } + else + if(fd->direction==sKoutput) + {clrhash(fd->table); + SETUP_FASD_IN(fd); + PUT_OP(d_end_of_file); + {int i = file_position(fd->stream); + if(type_of(fd->filepos) == t_fixnum) + { file_position_set(fd->stream,fix(fd->filepos) +2); + /* record the length of array needed to read the indices */ + PUT4(fix(fd->index)); + /* move back to where we were */ + file_position_set(fd->stream,i); + }} + + } + /* else FEerror("bad fasd stream",0); */ + fd->direction=Cnil; + return ar; + + } + + +#define HASHP(x) 1 +#define TRY_HASH \ + if(do_hash(obj,0)==LATER_INDEX) return; + +static void +write_fasd(object obj) +{ fixnum j,leng; + + /* hook for writing other data in fasd file */ + + + + /* check if we have already output the object in a hash table. + If so just record the index */ + { + /* if dump_index is too large or the object has not been written before + we output it now */ + + switch(type_of(obj)){ + + case DP(t_cons:) + TRY_HASH; + + /* decide how long we think this list is */ + + {object x=obj->c.c_cdr; + int l=0; + if (obj->c.c_car == siSsharp_comma) + { PUT_OP(d_eval); + write_fasd(x); + break;} + while(1) + { if(x==Cnil) + {PUT_OP(d_list1+l); + break;} + if(type_of(x)==t_cons) + {if ((int) d_list1 + ++l > (int) d_list4) + {PUT_OP(d_list); + break;} + else {x=x->c.c_cdr; + continue;}} + /* 1 to 4 done */ + if(l==0) + {PUT_OP(d_cons); + write_fasd(obj->c.c_car); + write_fasd(obj->c.c_cdr); + return;} + else + {PUT_OP(d_list); + break; + }}} + + /* WRITE_LIST: */ + + write_fasd(obj->c.c_car); + obj=obj->c.c_cdr; + {int l=0; + while(1) + {if (type_of(obj)==t_cons) + { enum circ_ind is_indexed=LATER_INDEX; + if(HASHP(t_cons)){ + is_indexed=do_hash(obj,d_dot); + if (is_indexed == LATER_INDEX) + return; + if (is_indexed==FIRST_INDEX) + { PUT_OP(d_cons); + write_fasd(obj->c.c_car); + write_fasd(obj->c.c_cdr); + return;}} + write_fasd(obj->c.c_car); + l++; + obj=obj->c.c_cdr;} + else + if(obj==Cnil) + {if (l> ((int) d_list4- (int) d_list1)) + {PUT_OP(d_delimiter);} + return;} + else + {PUT_OP(d_dot); + write_fasd(obj); + return;}}} + + case DP(t_symbol:) + + if (obj==Cnil) + {PUT_OP(d_nil); return;} + TRY_HASH; + leng=obj->s.s_fillp; + if (current_fasd.package!=obj->s.s_hpack) + {{ + if (leng< SHORT_MAX) + {PUT_OP(d_short_symbol_and_package); + PUTD("leng=%d",leng);} + else + { j=leng; + PUT_OP(d_symbol_and_package); + PUT4(j);}} + + write_fasd(obj->s.s_hpack);} + else + { if (leng< SHORT_MAX) + { PUT_OP(d_short_symbol); + PUTD("leng=%d",leng);} + else + { j=leng; + PUT_OP(d_symbol); + PUT4(j);} + } + D_FWRITE(obj->s.s_self,1,leng,fas_stream); + break; + case DP(t_fixnum:) + leng=fix(obj); + if ((leng< (SHORT_MAX/2)) + && (leng > -(SHORT_MAX/2))) + {PUT_OP(d_short_fixnum); + PUTD("leng=%d",leng);} + else + {PUT_OP(d_fixnum); + j=leng; + PUTFIX(j);} + break; + case DP(t_character:) + PUT_OP(d_standard_character); + PUTD("char=%c",char_code(obj)); + break; + case DP(t_string:) + leng=(obj)->st.st_fillp; + if (leng< SHORT_MAX) + {PUT_OP(d_short_string); + PUTD("leng=%d",leng);} + else + {j=leng; + PUT_OP(d_string); + PUT4(j);} + D_FWRITE(obj->st.st_self,1,leng,fas_stream); + break; + case DP(t_bignum:) + PUT_OP(d_bignum); +#ifdef GMP + {int l = MP(obj)->_mp_size; + int m = (l >= 0 ? l : -l); + + unsigned long *u = (unsigned long *) MP(obj)->_mp_d; + /* fix this */ + /* if (sizeof(mp_limb_t) != 4) { FEerror("fix for gmp",0);} */ + PUT4(l); + while (-- m >=0) { +#if MP_LIMB_BYTES == 8 + PUT8(*u); +#elif MP_LIMB_BYTES == 4 + PUT4(*u); +#else +#error Bad MP_LIMB_BYTES +#endif + u++; + } + break;} +#else + {int l = obj->big.big_length; + plong *u = obj->big.big_self; + PUT4(l); + while (-- l >=0) + {PUT4(*u) ; u++;} + break;} +#endif + case DP(t_package:) + TRY_HASH; + PUT_OP(d_package); + write_fasd(obj->p.p_name); + break; + case DP(t_structure:) + + TRY_HASH; + {int narg=S_DATA(obj->str.str_def)->length; + int i; + object name= S_DATA(obj->str.str_def)->name; + if(narg >= SHORT_MAX) + FEerror("Only dump structures whose length < ~a",1,make_fixnum(SHORT_MAX)); + PUT_OP(d_structure); + PUTD("narg=%d",narg); + write_fasd(name); + for (i = 0; i < narg; i++) + write_fasd(structure_ref(obj,name,i));} + + break; + + case DP(t_array:) + TRY_HASH; + PUT_OP(d_array); + { int leng=obj->a.a_dim; + int i; + PUT4(leng); + PUTD("elttype=%d",obj->a.a_elttype); + PUTD("rank=%d",obj->a.a_rank); + {int i; + if (obj->a.a_rank > 1) + { + for (i=0; ia.a_rank ; i++) + PUT4(obj->a.a_dims[i]);}} + for(i=0; i< leng ; i++) + write_fasd(aref(obj,i));} + break; + + case DP(t_vector:) + TRY_HASH; + PUT_OP(d_vector); + { int leng=obj->v.v_fillp; + PUT4 (leng); + PUTD("eltype=%d",obj->v.v_elttype); + {int i; + for(i=0; i< leng ; i++) + {write_fasd(aref(obj,i));}}} + break; + + + default: + PUT_OP(d_general_type); + prin1(obj,current_fasd.stream); + PUTD("close general:%c",')'); + + }} + } + + +static void +fasd_patch_sharp_cons(object x, int depth) +{ + for (;;) { + x->c.c_car = fasd_patch_sharp(x->c.c_car,depth+1); + if (type_of(x->c.c_cdr) == t_cons) + x = x->c.c_cdr; + else { + x->c.c_cdr = SAFE_CDR(fasd_patch_sharp(x->c.c_cdr,depth+1)); + break; + } + } +} + +static object +fasd_patch_sharp(object x, int depth) +{ + cs_check(x); + if (++depth > 1000) + { object *p = current_fasd.table->v.v_self; + while(*p) + { if (x== *p++ && type_of(x)!=t_spice) return x;}} + /* eval'd forms are already patched, and they might contain + circular structure */ + { object p = current_fasd.evald_items; + while (p != Cnil) + { if (p->c.c_car == x) return x; + p = p->c.c_cdr;}} + + switch (type_of(x)) { + case DP(t_spice:) + { if (x->spc.spc_dummy >= current_fasd.table->v.v_dim) + FEerror("bad spice ref",0); + return current_fasd.table->v.v_self[x->spc.spc_dummy ]; + + } + case DP(t_cons:) + /* + x->c.c_car = fasd_patch_sharp(x->c.c_car,depth); + x->c.c_cdr = fasd_patch_sharp(x->c.c_cdr,depth); + */ + fasd_patch_sharp_cons(x,depth); + break; + + case DP(t_vector:) + { + int i; + + if ((enum aelttype)x->v.v_elttype != aet_object) + break; + + for (i = 0; i < x->v.v_fillp; i++) + x->v.v_self[i] = fasd_patch_sharp(x->v.v_self[i],depth); + break; + } + case DP(t_array:) + { + int i, j; + + if ((enum aelttype)x->a.a_elttype != aet_object) + break; + + for (i = 0, j = 1; i < x->a.a_rank; i++) + j *= x->a.a_dims[i]; + for (i = 0; i < j; i++) + x->a.a_self[i] = fasd_patch_sharp(x->a.a_self[i],depth); + break; + } + case DP(t_structure:) + {object def = x->str.str_def; + int i; + i=S_DATA(def)->length; + while (i--> 0) + structure_set(x,def,i,fasd_patch_sharp(structure_ref(x,def,i),depth)); + break; + + } + default: + /* dont have to walk other objs */ + break; + + } + return(x); +} + +object sharing_table; +static enum circ_ind +is_it_there(object x) +{ struct htent *e; + object table=sharing_table; + switch(type_of(x)){ + case t_cons: + case t_symbol: + case t_structure: + case t_array: + case t_vector: + case t_package: + e= gethash(x,table); + if (e->hte_key ==OBJNULL) + {sethash(x,table,make_fixnum(-1)); + return FIRST_INDEX; + } + else + {int n=fix(e->hte_value); + if (n <0) + e->hte_value=make_fixnum(n-1); + return LATER_INDEX;} + break; + default: + return NOT_INDEXED;}} + + + +static void +find_sharing(object x) +{ + cs_check(x); + BEGIN: + if(is_it_there(x)!=FIRST_INDEX) return; + + switch (type_of(x)) { + + case DP(t_cons:) + + find_sharing(x->c.c_car); + x=x->c.c_cdr; + goto BEGIN; + + break; + + case DP(t_vector:) + { + int i; + + if ((enum aelttype)x->v.v_elttype != aet_object) + break; + + for (i = 0; i < x->v.v_fillp; i++) + find_sharing(x->v.v_self[i]); + break; + } + case DP(t_array:) + { + int i, j; + + if ((enum aelttype)x->a.a_elttype != aet_object) + break; + + for (i = 0, j = 1; i < x->a.a_rank; i++) + j *= x->a.a_dims[i]; + for (i = 0; i < j; i++) + find_sharing(x->a.a_self[i]); + break; + } + case DP(t_structure:) + {object def = x->str.str_def; + int i; + i=S_DATA(def)->length; + while (i--> 0) + find_sharing(structure_ref(x,def,i)); + break; + } + default: + break; + } + return; +} + +DEFUN_NEW("FIND-SHARING-TOP",object,fSfind_sharing_top,SI,2,2,NONE,OO,OO,OO,OO,(object x, object table),"") +/* static object */ +/* FFN(find_sharing_top)(object x, object table) */ +{sharing_table=table; + find_sharing(x); + return Ct; +} + + + + + +/* static object */ +/* read_fasd(int i) */ +/* {object tem; */ +/* read_fasd1(i,&tem); */ +/* return tem;} */ + + + /* I am not sure if saving vs_top,vs_base is necessary */ +static object +lisp_eval(object x) +{ object *b,*t; + SAVE_CURRENT_FASD; + b=vs_base; + t=vs_top; + vs_base=vs_top; + vs_push(x); + Leval(); + x=vs_base[0]; + vs_base=b; + vs_top=t; + RESTORE_FASD; + return x; + } + + + +#define CHECK_CH(i) do{if ((i)==EOF && feof(fas_stream)) bad_eof();}while (0) +/* grow vector AR of general type */ +static void +grow_vector(object ar) +{ int len=ar->v.v_dim; + int nl=(int) (1.5*len); + {BEGIN_NO_INTERRUPT; + {char *p= (char *)AR_ALLOC(alloc_contblock,nl,object); + bcopy(ar->v.v_self,p,sizeof(object)* len); + ar->v.v_self= (object *)p; + ar->v.v_dim= ar->v.v_fillp=nl; + while(--nl >=len) + ar->v.v_self[nl]=Cnil; + END_NO_INTERRUPT;}} + } + +static void +bad_eof(void) +{ FEerror("Unexpected end of file",0);} + + + +/* read one starting with byte i into location loc */ +static void +read_fasd1(int i, object *loc) +{ object tem; + int leng; + BEGIN: + CHECK_CH(i); + switch(D_TYPE_OF(i)) + {case DP(d_nil:) + *loc=Cnil;return; + case DP(d_cons:) + read_fasd1(GET_OP(),&tem); + *loc=make_cons(tem,Cnil); + loc= &((*loc)->c.c_cdr); + i=GET_OP(); + goto BEGIN; + case DP(d_list1:) i=1;goto READ_LIST; + case DP(d_list2:) i=2;goto READ_LIST; + case DP(d_list3:) i=3;goto READ_LIST; + case DP(d_list4:) i=4;goto READ_LIST; + case DP(d_list:) i=(1<<30) ; goto READ_LIST; + + READ_LIST: + while(1) + {int j; + if (--i < 0) {*loc=Cnil; return;} + j=GET_OP(); + CHECK_CH(j); + if (j==d_delimiter) + {*loc=Cnil; + DPRINTF("{Read end of list(%d)}",i); + return;} + else + if(j==d_dot) + { DPRINTF("{Read end of dotted list(%d)}",i); + read_fasd1(GET_OP(),loc); + + return;} + else + {object tem; + DPRINTF("{Read next item in list(%d)}",i); + read_fasd1(j,&tem); + DPRINTF("{Item=",(debug >= 2 ? pp(tem) : 0)); + DPRINTF("}",0); + *loc=make_cons(tem,Cnil); + loc= &((*loc)->c.c_cdr);}} + + case DP(d_delimiter:) + case DP(d_dot:) + FEerror("Illegal op at top level",0); + break; + case DP(d_eval_skip:) + read_fasd1(GET_OP(),loc); + MAYBE_PATCH(*loc); + lisp_eval(*loc); + read_fasd1(GET_OP(),loc); + break; + + case d_reserve1: + case d_reserve2: + case d_reserve3: + case d_reserve4: + + FEerror("Op reserved for future use",0); + break; + + case DP(d_reset_index:) + dump_index=0; + break; + + case DP(d_short_symbol:) + leng=GETD("leng=%d"); + leng = LENGTH(i,leng); + READ_SYMBOL(leng,current_fasd.package,tem); + *loc=tem; + return ; + case DP(d_short_symbol_and_package:) + {object pack; + leng=GETD("leng=%d"); + leng = LENGTH(i,leng); + read_fasd1(GET_OP(),&pack); + READ_SYMBOL(leng,pack,tem); + *loc=tem; + return;} + case DP(d_short_string:) + leng=GETD("leng=%d"); + leng = LENGTH(i,leng); + READ_STRING(leng,loc); + return; + case DP(d_string:) + {int j; + GET4(j); + READ_STRING(j,loc); + return;} + + case DP(d_indexed_item3:) + GET3(i);goto INDEXED; + case DP(d_indexed_item2:) + GET2(i);goto INDEXED; + case DP(d_indexed_item1:) + i=GET()+ NUMBER_ZERO_ITEMS ; goto INDEXED; + default: + case DP(d_indexed_item0:) + i = i - (int) d_indexed_item0; goto INDEXED; + + INDEXED: + + *loc= current_fasd.table->v.v_self[i]; + /* if object not yet built make pointer to it */ + if(*loc==0) + {*loc=current_fasd.table->v.v_self[i]= alloc_object(t_spice); + (*loc)->spc.spc_dummy= i; + needs_patching=1;} + return; + + /* the item`s' case does not return a value but is simply + a facility to allow convenient dumping of a list of registers + at the beginning, follwed by a delimiter. read continues on. */ + + case DP(d_new_indexed_items:) + case DP(d_new_indexed_item:) + + { + int cindex,k; + k=GET_OP(); + MORE: + cindex =dump_index; + DPRINTF("{dump_index=%d}",dump_index); + if (dump_index >= current_fasd.table->v.v_dim) + grow_vector(current_fasd.table); + /* grow the array */ + current_fasd.table->v.v_self[dump_index++] = 0; + read_fasd1(k,loc); + current_fasd.table->v.v_self[cindex] = *loc; + + if (i==d_new_indexed_items) + {int k=GET_OP(); + if (k==d_delimiter) + { DPRINTF("{Reading last of new indexed items}",0); + read_fasd1(GET_OP(),loc); + return;} + else { + goto MORE; + }} + return; + } + case DP(d_short_fixnum:) + {int leng=GETD("n=%d"); + if (leng & (1 << (SIZE_SHORT -1))) + leng= leng - (1 << (SIZE_SHORT)); + *loc=SAFE_CDR(make_fixnum(leng)); + return;} + + case DP(d_fixnum:) + {fixnum j; + GETFIX(j); + *loc=SAFE_CDR(make_fixnum(j)); + return;} + case DP( d_bignum:) + {int j,m; + object tem; + unsigned long *u; + GET4(j); +#ifdef GMP + tem = new_bignum(); + m = (j >= 0 ? j : -j); + _mpz_realloc(MP(tem),m); + MP(tem)->_mp_size = j; + j = m; + u = (unsigned long *) MP(tem)->_mp_d; +#else + { BEGIN_NO_INTERRUPT; + tem = alloc_object(t_bignum); + tem->big.big_length = j; + tem-> big.big_self = 0; + u = tem-> big.big_self = (plong *) alloc_relblock(j*sizeof(plong)); + END_NO_INTERRUPT; + } + +#endif + while ( --j >=0) { +#if MP_LIMB_BYTES == 8 + GET8(*u); +#elif MP_LIMB_BYTES == 4 + GET4(*u); +#else +#error Bad MP_LIMB_BYTES +#endif + u++; + } + *loc=tem; return;} + case DP(d_objnull:) + + *loc=0; return; + + case DP(d_structure:) + { int narg,i; + object name; + narg=GETD("narg=%d"); + read_fasd1(GET_OP(),& name); + { object *base=vs_top; + object *p = base; + vs_base=base; + vs_top = base + 1 + narg; + *p++ = name; + for (i=0; i < narg ; i++) + read_fasd1(GET_OP(),p++); + vs_base=base; + vs_top = p; + siLmake_structure(); + *loc = vs_base[0]; + vs_top=vs_base=base; + return; + }} + + case DP(d_symbol:) + {int i; object tem; + GET4(i); + READ_SYMBOL(i,current_fasd.package,tem); + *loc=tem; + return ;} + case DP(d_symbol_and_package:) + {int i; object pack; + GET4(i); + read_fasd1(GET_OP(),&pack); + READ_SYMBOL(i,pack,*loc); + return;} + case DP(d_package:) + {object pack,tem; + read_fasd1(GET_OP(),&tem); + pack=find_package(tem); + if (pack==Cnil) FEerror("The package named ~a, does not exist",1,tem); + *loc=pack; + return ;} + case DP(d_standard_character:) + *loc=(code_char(GETD("char=%c"))); + return; + case DP(d_vector:) + {int leng,j; + object y; + object x=alloc_object(t_vector); + GET4(leng); + x->v.v_elttype = GETD("v_elttype=%d"); + x->v.v_dim=x->v.v_fillp=leng; + x->v.v_self=0; + x->v.v_displaced=Cnil; + x->v.v_hasfillp=x->v.v_adjustable=0; + array_allocself(x,0,Cnil); + for (j=0; j< leng ; j++) + { DPRINTF("{vector_elt=%d}",j); + read_fasd1(GET_OP(),&y); + aset(x,j,y);} + *loc=x; + DPRINTF("{End of length %d vector}",leng); + return;} + + + case DP(d_array:) + {BEGIN_NO_INTERRUPT; + + {int leng,i; + object y; + object x=alloc_object(t_array); + GET4(leng); + + x->a.a_elttype = GETD("a_elttype=%d"); + x->a.a_dim=leng; + x->a.a_rank= GETD("a_rank=%d"); + x->a.a_self=0; + x->a.a_displaced=Cnil; + x->a.a_adjustable=0; + if (x->a.a_rank > 0) + { x->a.a_dims = (int *)alloc_relblock(sizeof(int)*(x->a.a_rank)); } + for (i=0; i< x->a.a_rank ; i++) + GET4(x->a.a_dims[i]); + array_allocself(x,0,Cnil); + END_NO_INTERRUPT; + for (i=0; i< leng ; i++) + { read_fasd1(GET_OP(),&y); + aset(x,i,y);} + *loc=x; + return;}} + + case DP(d_end_of_file:) + current_fasd.direction =Cnil; + *loc=current_fasd.eof; + return; + + case DP(d_begin_dump:) + {int vers=GETD("version=%d"); + if(vers!=FASD_VERSION) { + object x,x1; + x=make_fixnum(vers); + x1=make_fixnum(FASD_VERSION); + FEerror("This file was dumped with FASD version ~a not ~a.", + 2,x,x1);}} + {int leng; + GET4(leng); + current_fasd.table_length=make_fixnum(leng);} + read_fasd1(GET_OP(),&tem); + if (type_of(tem)==t_package || tem==Cnil) + {current_fasd.package = tem; + *loc=current_fasd.table;} + else FEerror("expected package",0); + return; + + case DP(d_general_type:) + *loc=read_object_non_recursive(current_fasd.stream); + if(GETD("close general:%c")!=')') FEerror("general type not followed by ')'",0); + return; + + + /* Special type, the forms have been sharp patched separately + It is also arranged that it does not + */ + + case DP(d_enter_vector:) + { + extern object sSPmemory; + int print_only=0; + int n = 0; + object vv = sSPmemory->s.s_dbind,tem; + if (vv == Cnil) print_only = 1; + else + if (type_of(vv)!=t_cfdata) FEerror("bad VectorToEnter",0); + while ((i=GET_OP()) !=d_delimiter) + {int eval=(i==d_eval_skip); + if (print_only) + { if (eval) princ_str("#!",Ct); + else if (i== d_eval) + princ_str("#.",Ct);} + if(eval) i=GET_OP(); + read_fasd1(i, &tem); + MAYBE_PATCH(tem); + /* the eval entries don't enter it */ + + if (print_only) {princ(tem,Ct); + princ_str(";",Ct); + princ(make_fixnum(n),Ct); + if (eval==0) n++; + princ_str("\n",Ct);} + else + { + if(eval) + lisp_eval(tem); + else + {if (n >= vv->cfd.cfd_fillp) FEerror("cfd too small",0); + vv->cfd.cfd_self[n++]=tem;}}} + if (print_only==0) vv->cfd.cfd_fillp = n; + *loc=vv; + return; + } + + case DP(d_eval:) + {object tem; + read_fasd1(GET_OP(),&tem); + MAYBE_PATCH(tem); + *loc = lisp_eval(tem); + current_fasd.evald_items = make_cons(*loc,current_fasd.evald_items); + return; + } + + }} + +static void +clrhash(object table) +{int i; + if (table->ht.ht_nent > 0 ) + for(i = 0; i < table->ht.ht_size; i++) { + table->ht.ht_self[i].hte_key = OBJNULL; + table->ht.ht_self[i].hte_value = OBJNULL;} + table->ht.ht_nent =0;} + + + +object read_fasl_vector1(); +object +read_fasl_vector(object in) +{char ch; + object orig = in; + object d; + int tem; + if (((tem=getc(((FILE *)in->sm.sm_fp))) == EOF) && feof(((FILE *)in->sm.sm_fp))) + { d = coerce_to_pathname(in); + d = make_pathname(d->pn.pn_host, + d->pn.pn_device, + d->pn.pn_directory, + d->pn.pn_name, + make_simple_string("data"), + d->pn.pn_version); + d = coerce_to_namestring(d); + in = open_stream(d,smm_input,Cnil,Cnil); + if (in == Cnil) + FEerror("Can't open file ~s",1,d); + } + else if (tem != EOF) + { ungetc(tem,in->sm.sm_fp);} + while (1) + { ch=readc_stream(in); + if (ch=='#') + {unreadc_stream(ch,in); + return read_fasl_vector1(in);} + if (ch== d_begin_dump){ + unreadc_stream(ch,in); + break;}} + {object ar=FFN(fSopen_fasd)(in,sKinput,0,Cnil); + int n=fix(current_fasd.table_length); + object result,last; + { BEGIN_NO_INTERRUPT; +#ifdef HAVE_ALLOCA + current_fasd.table->v.v_self + = (object *)alloca(n*sizeof(object)); +#else + current_fasd.table->v.v_self + = (object *)alloc_relblock(n*sizeof(object)); +#endif + current_fasd.table->v.v_dim=n; + current_fasd.table->v.v_fillp=n; + gset( current_fasd.table->v.v_self,0,n,aet_object); + END_NO_INTERRUPT; + } + result=FFN(fSread_fasd_top)(ar); + if (type_of(result) !=t_vector) goto ERROR; + last=result->v.v_self[result->v.v_fillp-1]; + if(type_of(last)!=t_cons || last->c.c_car !=sSPinit) + goto ERROR; + current_fasd.table->v.v_self = 0; + FFN(fSclose_fasd)(ar); + if (orig != in) + close_stream(in); + return result; + ERROR: FEerror("Bad fasd stream ~a",1,in); + return Cnil; +}} + +object IfaslInStream; +/* static void */ +/* IreadFasdData(void) */ + + /* While executing this the siPMemory should be bound to the cfdata + and the sSPinit to a vector of addresses. */ +/* {object ar=open_fasd(IfaslInStream,sKinput,0,Cnil); */ +/* int n=fix(current_fasd.table_length); */ +/* object result; */ +/* {BEGIN_NO_INTERRUPT; */ +/* #ifdef HAVE_ALLOCA */ +/* current_fasd.table->v.v_self */ +/* = (object *)alloca(n*sizeof(object)); */ +/* #else */ +/* current_fasd.table->v.v_self */ +/* = (object *)alloc_relblock(n*sizeof(object)); */ +/* #endif */ +/* current_fasd.table->v.v_dim=n; */ +/* current_fasd.table->v.v_fillp=n; */ +/* gset( current_fasd.table->v.v_self,0,n,aet_object); */ +/* END_NO_INTERRUPT; */ +/* } */ +/* result=read_fasd_top(ar); */ + /* make sure there is nothing still pointing into the stack */ +/* current_fasd.table->v.v_self = 0; */ +/* current_fasd.table->v.v_dim=0; */ +/* current_fasd.table->v.v_fillp=0; */ + +/* } */ + + + + +static void +init_fasdump(void) +{ +/* make_si_sfun("READ-FASD-TOP",read_fasd_top,1); */ +/* make_si_sfun("WRITE-FASD-TOP",write_fasd_top,2); */ +/* make_si_sfun("OPEN-FASD",open_fasd,4); */ +/* make_si_sfun("CLOSE-FASD",close_fasd,1); */ +/* /\* make_si_sfun("FASD-I-DATA",fasd_i_macro,1); *\/ */ +/* make_si_sfun("FIND-SHARING-TOP",find_sharing_top,2); */ +} diff --git a/o/fasldlsym.c b/o/fasldlsym.c new file mode 100755 index 0000000..a4a3454 --- /dev/null +++ b/o/fasldlsym.c @@ -0,0 +1,121 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + + +#include +#include +#include +#include +#include +#ifdef HAVE_AOUT +#include HAVE_AOUT +#endif +#if defined(HAVE_ELF_H) +#include +#elif defined(HAVE_ELF_ABI_H) +#include +#endif + +struct name_list { + struct name_list *next; + char name[1]; +}; +static struct name_list *loaded_files; + +static void +unlink_loaded_files(void) { + + while(loaded_files) { + unlink(loaded_files->name); + loaded_files= loaded_files->next; + } + +} + +int +fasload(object faslfile) { + + void *dlp ; + int (*fptr)(); + char buf[MAXPATHLEN],b[MAXPATHLEN],filename[MAXPATHLEN]; + static int count; + object memory,data,faslstream; + struct name_list *nl; + object x; + + bzero(buf,sizeof(buf)); /*GC partial stack hole closing*/ + bzero(b,sizeof(b)); + bzero(filename,sizeof(filename)); + + /* this is just to allow reloading in the same file twice. + */ + coerce_to_filename(truename(faslfile), filename); + if (!count) + count=time(0); + massert(snprintf(buf,sizeof(buf),"/tmp/ufas%dxXXXXXX",count++)>0); + massert(mkstemp(buf)>=0); + + massert((nl=(void *) malloc(strlen(buf)+1+sizeof(nl)))); + massert(loaded_files || !atexit(unlink_loaded_files)); + nl->next = loaded_files; + loaded_files = nl; + strcpy(nl->name,buf); + + faslstream = open_stream(faslfile, smm_input, Cnil, sKerror); + massert(snprintf(b,sizeof(b),"cc -shared %s -o %s",filename,buf)>0); + massert(!psystem(b)); + + if (!(dlp = dlopen(buf,RTLD_NOW))) { + fputs(dlerror(),stderr); + FEerror("Cannot open for dynamic link ~a",1,make_simple_string(filename)); + } + + + x=find_init_name1(buf,0); + massert(x->st.st_fillp+1st.st_self,x->st.st_fillp); + b[x->st.st_fillp]=0; + if (!(fptr=dlsym(dlp,b))) { + fputs(dlerror(),stderr); + FEerror("Cannot lookup ~a in ~a",2,make_simple_string(b),make_simple_string(filename)); + } + + SEEK_TO_END_OFILE(faslstream->sm.sm_fp); + + data = read_fasl_vector(faslstream); + memory = alloc_object(t_cfdata); + memory->cfd.cfd_self = NULL; + memory->cfd.cfd_start = NULL; + memory->cfd.cfd_size = 0; + + if(symbol_value(sLAload_verboseA)!=Cnil) + printf(" start address (dynamic) %p ",fptr); + + call_init(0,memory,data,fptr); + + unlink(buf); + close_stream(faslstream); + + return memory->cfd.cfd_size; + +} + +#include "sfasli.c" diff --git a/o/fasldlsym.c.link b/o/fasldlsym.c.link new file mode 100755 index 0000000..e337d43 --- /dev/null +++ b/o/fasldlsym.c.link @@ -0,0 +1,73 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + + +#include +#ifdef HAVE_ELF +#include +#endif + +/* cc -DVOL=volatile -G 0 -c foo.c ; ld -shared foo.o -o jim.o ; cat foo.data >> jim.o */ +int did_a_dynamic_load; + +fasload(faslfile) + object faslfile; +{ void *dlp ; + int (*fptr)(); + char buf[200]; + static count=0; + object memory; + object data; + char filename[MAXPATHLEN]; + coerce_to_filename(truename(faslfile), filename); + sprintf(buf,"./ufas%dxXXXXXX",count++); + /* this is just to allow reloading in the same file twice. + */ + mktemp(buf); + link(filename,buf); + dlp = dlopen(buf,RTLD_NOW); + if (dlp ==0) + FEerror("Cant open for dynamic link ~a",1,faslfile); + fptr = (int (*)())dlsym(dlp, "init_code"); + if (fptr == 0) + { FEerror("Cant find init_code in ~a",1,make_simple_string(faslfile));} + faslfile = open_stream(faslfile, smm_input, Cnil, sKerror); + SEEK_TO_END_OFILE(faslfile->sm.sm_fp); + data = read_fasl_vector(faslfile); + memory = alloc_object(t_cfdata); + memory->cfd.cfd_self = NULL; + memory->cfd.cfd_start = NULL; + memory->cfd.cfd_size = 0; + if(symbol_value(sLAload_verboseA)!=Cnil) + printf(" start address (dynamic) 0x%x ",fptr); + call_init(0,memory,data,fptr); + /* unlink(buf); */ + did_a_dynamic_load = 1; + return memory->cfd.cfd_size; +} + + + + + + + + diff --git a/o/faslhp800.c b/o/faslhp800.c new file mode 100755 index 0000000..1ffa36f --- /dev/null +++ b/o/faslhp800.c @@ -0,0 +1,163 @@ +/* round up i to be a multiple of (n) */ +#define ROUND_UP(i,n) ((((int) (i) + n-1)/(n)) *(n)) + +#define MAXPATHLEN 512 +int init_address = 0; + +#ifdef HPUX_SOM +#include + + +#define GET_HEADERS(fp) \ + struct header hdr; \ + struct som_exec_auxhdr somhdr; \ + if (sizeof(hdr) !=fread(&hdr,1,sizeof(hdr),fp)) \ + {FEerror("could not read header",0);} \ + if (hdr.aux_header_size) \ + {fseek(fp,hdr.aux_header_location,0); \ + if (sizeof(somhdr) != fread(&somhdr,1,sizeof(somhdr),fp)) \ + {FEerror("could not read header",0);}} \ + else { somhdr.exec_tsize=0;somhdr.exec_dsize=0;somhdr.exec_bsize=0;} + + + +#define SET_TOTAL_SPACE(total,fp) \ + total= ROUND_UP(somhdr.exec_tsize,sizeof(double)) \ + + somhdr.exec_dsize + somhdr.exec_bsize;\ + +#define READ_FASL_TO_MEMORY(memory,fp) \ +do{ char *p = memory->cfd.cfd_start; \ + init_address = ((char *)somhdr.exec_entry - p); \ + if (init_address > 1000) printf("entry is offset at %x(%d)",init_address); \ + fseek(fp,somhdr.exec_tfile,0) ; \ + fread(p,1,somhdr.exec_tsize,fp); \ + fseek(fp,somhdr.exec_dfile,0) ; \ + if ((int)(p + *data_off) != somhdr.exec_dmem) \ + FEerror("bad data offset",0);\ + fread(p+ *data_off,1, \ + somhdr.exec_dsize,fp); \ +}while(0) + +#define TXT_ALIGN 4096 + +#undef BSD +#endif + + +#ifdef BSD +#include +#define GET_HEADERS(fp) \ + struct exec hdr; fseek(fp,0,0);\ + fread(&hdr,1,sizeof(hdr),fp); \ +#define SET_TOTAL_SPACE(total,fp) \ + total = hdr.a_txtsize + hdr.a_datasize + header.a_bss; +#define READ_FASL_TO_MEMORY(memory,fp) \ + fseek(fp,sizeof(struct header) ,0); \ + fread(memory->cfd.cfd_start,1,memory->cfd.cfd_size,fp); \ + +#endif + + + + +read_text_and_data(memory,fp,data_off) + object memory; + FILE *fp; + int *data_off; +{ int total; + GET_HEADERS(fp); + SET_TOTAL_SPACE(total,fp); + *data_off = ROUND_UP(somhdr.exec_tsize,sizeof(double)); + if (total > memory->cfd.cfd_size) + { memory->cfd.cfd_size = total; return 0;} + + READ_FASL_TO_MEMORY(memory,fp); + return 1; +} + +#ifndef TXT_ALIGN +#define TXT_ALIGN sizeof(double) +#endif + +static +fasload_help(faslfile,lib_string) +object faslfile; +char *lib_string; +{ char filename[MAXPATHLEN],tmpfile[MAXPATHLEN]; + char command [2*MAXPATHLEN]; + int total; + object memory ; + FILE *fp; + + faslfile = open_stream(faslfile, smm_input, Cnil, sKerror); + fp = faslfile->sm.sm_fp; + + + { int data_off = 0; + GET_HEADERS(fp); + SET_TOTAL_SPACE(total,fp); + memory=alloc_object(t_cfdata); + memory->cfd.cfd_self = 0; + memory->cfd.cfd_start = 0; + memory->cfd.cfd_size = total; + sprintf(tmpfile,"/tmp/fasl%d",getpid()); + + AGAIN: + + memory->cfd.cfd_start = ALLOC_ALIGNED(alloc_contblock, + memory->cfd.cfd_size,TXT_ALIGN); + + + coerce_to_filename(faslfile, filename); + LD_COMMAND(command, + kcl_self, + memory->cfd.cfd_start, + filename, + (lib_string ? lib_string : " "), + tmpfile); + if (system(command) != 0) + { FEerror("The linkage editor failed.", 0);} + if(symbol_value(sLAload_verboseA)==sLAload_verboseA) + { printf("%s\n",command); fflush(stdout);} + + {FILE *fp1 = fopen(tmpfile,"r"); + if (fp1==0) {FEerror("Couldn't open tmpfile",0);} + if(read_text_and_data(memory,fp1,&data_off) ==0) + {fclose(fp1); goto AGAIN;} + fclose(fp1); + }} + unlink(tmpfile); + SEEK_TO_END_OFILE(fp); + call_init(init_address,memory,read_fasl_vector(faslfile),0); + close_stream (faslfile); + if(symbol_value(sLAload_verboseA)!=Cnil) + printf("start address -T %x ",memory->cfd.cfd_start); + return(memory->cfd.cfd_size); +} + +fasload(faslfile) + object faslfile; +{return fasload_help(faslfile,0);} + +#define FASLINK + +siLfaslink() +{ object *base = vs_base; + check_arg(2); + vs_base[0] = make_fixnum(fasload_help(base[0],object_to_string(base[1]))); + printf("done link"); fflush(stdout); + vs_top = vs_base+1; + return ; +} + + + + + + + +int +faslink(faslfile, ldargstring) +object faslfile, ldargstring; +{printf("later");} + diff --git a/o/faslnt.c b/o/faslnt.c new file mode 100755 index 0000000..777552f --- /dev/null +++ b/o/faslnt.c @@ -0,0 +1,6 @@ +int +fasload(object o) +{ + printf("this is a dummy\n"); + +} diff --git a/o/faslsgi4.c b/o/faslsgi4.c new file mode 100755 index 0000000..072fdd7 --- /dev/null +++ b/o/faslsgi4.c @@ -0,0 +1,463 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + + +/* make sure we do allocate aligned for double */ +/* actually I understand that ld -A wants alignment on + the page. ie multiple of 0x1000 +*/ + +#define ALIGN 12 +char * +alloc_contblock_aligned(size) +int size; +{ + char *tmp_alloc = ALLOC_ALIGNED(alloc_contblock,size,(1<<12)); + bzero(tmp_alloc, size); + return(tmp_alloc); + } + +#define alloc_contblock alloc_contblock_aligned + + + +#ifdef BSD +#include +#endif + +#ifdef ATT +#ifdef mips +#include +#include +#endif +#include +#include +#include +#endif + + + +#define MAXPATHLEN 1024 + + + +#ifdef HAVE_ELF +#include +#endif + + +int +fasload(faslfile) +object faslfile; +{ + +#ifdef BSD + struct exec header, newheader; +#define textsize header.a_text +#define datasize header.a_data +#define bsssize header.a_bss +#define textstart sizeof(header) +#define newbsssize newheader.a_bss +#endif + +#ifdef ATT + struct filehdr fileheader; + struct scnhdr sectionheader; +#ifdef mips + struct aouthdr aouthdr, newaouthdr; + HDRR symhdr; +# define textsize aouthdr.tsize +# define datasize aouthdr.dsize +# define bsssize aouthdr.bsize +# define textstart sectionheader.s_scnptr +# define newdatasize newaouthdr.dsize +# define newbsssize newaouthdr.bsize +#else + int textsize, datasize, bsssize; + int textstart; +#endif /* mips */ +#endif + +#ifdef E15 + struct exec header; +#define textsize header.a_text +#define datasize header.a_data +#define bsssize header.a_bss +#define textstart sizeof(header) +#endif + + object memory, data, tempfile; + FILE *fp; + char filename[MAXPATHLEN]; + char tempfilename[32]; + char command[MAXPATHLEN * 2]; + int i; + object *old_vs_base = vs_base; + object *old_vs_top = vs_top; +#ifdef IBMRT + +#endif + + coerce_to_filename(faslfile, filename); + + faslfile = open_stream(faslfile, smm_input, Cnil, sKerror); + vs_push(faslfile); + fp = faslfile->sm.sm_fp; + +#ifdef BSD + fread(&header, sizeof(header), 1, fp); +#endif +#ifdef ATT + fread(&fileheader, sizeof(fileheader), 1, fp); +#ifdef mips + fread(&aouthdr, AOUTHSZ, 1, fp); +#else +#ifdef S3000 + if(fileheader.f_opthdr != 0) fseek(fp,fileheader.f_opthdr,1); +#endif + fread(§ionheader, sizeof(sectionheader), 1, fp); + textsize = sectionheader.s_size; + textstart = sectionheader.s_scnptr; + fread(§ionheader, sizeof(sectionheader), 1, fp); + datasize = sectionheader.s_size; + fread(§ionheader, sizeof(sectionheader), 1, fp); + if (strcmp(sectionheader.s_name, ".bss") == 0) + bsssize = sectionheader.s_size; + else + bsssize = 0; +#endif /* mips */ +#endif +#ifdef E15 + fread(&header, sizeof(header), 1, fp); +#endif + + memory = alloc_object(t_cfdata); + memory->cfd.cfd_self = NULL; + memory->cfd.cfd_start = NULL; + memory->cfd.cfd_size = textsize + datasize + bsssize; +#ifdef mips +#define MIPS_ROUND 0xC + memory->cfd.cfd_size += MIPS_ROUND; /* room for 'ld' to round text upward */ +#endif + vs_push(memory); + memory->cfd.cfd_start = alloc_contblock(memory->cfd.cfd_size); + +#ifdef BSD + fseek(fp, + header.a_text+header.a_data+ + header.a_syms+header.a_trsize+header.a_drsize, + 1); + fread(&i, sizeof(i), 1, fp); + fseek(fp, i - sizeof(i), 1); +#endif + +#ifdef SYSTYPE_SVR4 + SEEK_TO_END_OFILE(fp); +#else +#ifdef ATT +#ifdef mips + fseek(fp, fileheader.f_symptr, SEEK_SET); + fread(&symhdr, cbHDRR, 1, fp); + fseek(fp, symhdr.cbExtOffset + symhdr.iextMax * cbEXTR, SEEK_SET); +#else + fseek(fp, + fileheader.f_symptr + SYMESZ*fileheader.f_nsyms, + 0); + fread(&i, sizeof(i), 1, fp); + fseek(fp, i - sizeof(i), 1); + while ((i = getc(fp)) == 0) + ; + ungetc(i, fp); +#endif /* mips */ +#endif +#endif + + data = read_fasl_vector(faslfile); + vs_push(data); + close_stream(faslfile); + + sprintf(tempfilename, "/tmp/fasltemp%d", getpid()); + +AGAIN: + +#ifdef BSD + sprintf(command, + "ld -d -N -x -A %s -T %x %s -o %s", + kcl_self, + memory->cfd.cfd_start, + filename, + tempfilename); +#endif +#ifdef ATT +#ifdef mips + sprintf(command, + "ld -s -A %s -N -T %x %s -o %s", + kcl_self, + (long)memory->cfd.cfd_start+SCNROUND-1&~(SCNROUND-1), + filename, + tempfilename); +#else + coerce_to_filename(symbol_value(sSAsystem_directoryA), + system_directory); + sprintf(command, + "%sild %s %d %s %s", + system_directory, + kcl_self, + memory->cfd.cfd_start, + filename, + tempfilename); +#endif /* mips */ +#endif +#ifdef E15 + coerce_to_filename(symbol_value(sSAsystem_directoryA), + system_directory); + sprintf(command, + "%sild %s %d %s %s", + system_directory, + kcl_self, + memory->cfd.cfd_start, + filename, + tempfilename); +#endif + + if (system(command) != 0) + FEerror("The linkage editor failed.", 0); + + tempfile = make_simple_string(tempfilename); + vs_push(tempfile); + tempfile = open_stream(tempfile, smm_input, Cnil, sKerror); + vs_push(tempfile); + fp = tempfile->sm.sm_fp; + +#ifdef BSD + fread(&newheader, sizeof(header), 1, fp); + if (newbsssize != bsssize) { + insert_contblock(memory->cfd.cfd_start, memory->cfd.cfd_size); + bsssize = newbsssize; + memory->cfd.cfd_start = NULL; + memory->cfd.cfd_size = textsize + datasize + bsssize; + memory->cfd.cfd_start = alloc_contblock(memory->cfd.cfd_size); + close_stream(tempfile, TRUE); + unlink(tempfilename); + goto AGAIN; + } +#endif +#ifdef mips + fseek(fp, FILHSZ, SEEK_CUR); + fread(&newaouthdr, AOUTHSZ, 1, fp); + if (newdatasize + newbsssize > datasize + bsssize) { + insert_contblock(memory->cfd.cfd_start, memory->cfd.cfd_size); + datasize = newdatasize; + bsssize = newbsssize; + memory->cfd.cfd_start = NULL; + memory->cfd.cfd_size = textsize + datasize + bsssize + MIPS_ROUND; + memory->cfd.cfd_start = alloc_contblock(memory->cfd.cfd_size); + close_stream(tempfile); + unlink(tempfilename); + goto AGAIN; + } + fread(§ionheader, sizeof sectionheader, 1, fp); +#endif + if (fseek(fp, textstart, 0) < 0) + error("file seek error"); +#ifdef mips + printf("start address -T %x ",memory->cfd.cfd_start); + bzero(memory->cfd.cfd_start, MIPS_ROUND); + fread((void *)sectionheader.s_vaddr, textsize + datasize, 1, fp); +#else + fread(memory->cfd.cfd_start, textsize + datasize, 1, fp); +#endif + close_stream(tempfile); + + unlink(tempfilename); + + call_init(0,memory,data,0); + + vs_base = old_vs_base; + vs_top = old_vs_top; + + return(memory->cfd.cfd_size); +} + +#if defined BSD || defined mips + +int +faslink(faslfile, ldargstring) +object faslfile, ldargstring; +{ +#ifdef mips + struct filehdr faslheader; + struct aouthdr aouthdr; + struct scnhdr sectionheader; + HDRR symhdr; +#define ldcmdfmt "ld -s -A %s -N -T %x %s %s -o %s" +#else + struct exec header, faslheader; +#define textsize header.a_text +#define datasize header.a_data +#define bsssize header.a_bss +#define textstart sizeof(header) +#define ldcmdfmt "ld -d -N -x -A %s -T %x %s %s -o %s" +#endif + + object memory, data, tempfile; + FILE *fp; + char filename[MAXPATHLEN]; + char ldargstr[MAXPATHLEN]; + char tempfilename[32]; + char command[MAXPATHLEN * 2]; + char buf[BUFSIZ]; + int i; + object *old_vs_base = vs_base; + object *old_vs_top = vs_top; +#ifdef IBMRT + +#endif + + coerce_to_filename(ldargstring, ldargstr); + coerce_to_filename(faslfile, filename); + + sprintf(tempfilename, "/tmp/fasltemp%d", getpid()); + + sprintf(command, + ldcmdfmt, + kcl_self, + (int)core_end, + filename, + ldargstr, + tempfilename); + + if (system(command) != 0) + FEerror("The linkage editor failed.", 0); + + fp = fopen(tempfilename, "r"); + setbuf(fp, buf); +#ifdef mips + fseek(fp, FILHSZ, SEEK_CUR); + fread(&aouthdr, AOUTHSZ, 1, fp); +#else + fread(&header, sizeof(header), 1, fp); +#endif + memory = alloc_object(t_cfdata); + memory->cfd.cfd_self = NULL; + memory->cfd.cfd_start = NULL; + memory->cfd.cfd_size = textsize + datasize + bsssize; +#ifdef mips + memory->cfd.cfd_size += MIPS_ROUND; +#endif + vs_push(memory); + memory->cfd.cfd_start = alloc_contblock(memory->cfd.cfd_size); + fclose(fp); + + faslfile = open_stream(faslfile, smm_input, Cnil, sKerror); + vs_push(faslfile); + fp = faslfile->sm.sm_fp; + fread(&faslheader, sizeof(faslheader), 1, fp); +#ifdef mips + fseek(fp, AOUTHSZ, SEEK_CUR); + fread(§ionheader, SCNHSZ, 1, fp); + fseek(fp, faslheader.f_symptr, SEEK_SET); + fread(&symhdr, cbHDRR, 1, fp); + fseek(fp, symhdr.cbExtOffset + symhdr.iextMax * cbEXTR, SEEK_SET); +#else + fseek(fp, + faslheader.a_text+faslheader.a_data+ + faslheader.a_syms+faslheader.a_trsize+faslheader.a_drsize, + 1); + fread(&i, sizeof(i), 1, fp); + fseek(fp, i - sizeof(i), 1); +#endif + data = read_fasl_vector(faslfile); + vs_push(data); + close_stream(faslfile); + + sprintf(command, + ldcmdfmt, + kcl_self, +#ifdef mips + (long)memory->cfd.cfd_start+SCNROUND-1&~(SCNROUND-1), +#else + memory->cfd.cfd_start, +#endif + filename, + ldargstr, + tempfilename); + + if (system(command) != 0) + FEerror("The linkage editor failed.", 0); + + tempfile = make_simple_string(tempfilename); + vs_push(tempfile); + tempfile = open_stream(tempfile, smm_input, Cnil, sKerror); + vs_push(tempfile); + fp = tempfile->sm.sm_fp; + +#ifdef mips + fseek(fp, FILHSZ, SEEK_CUR); + fread(&aouthdr, AOUTHSZ, 1, fp); + fread(§ionheader, sizeof sectionheader, 1, fp); +#endif + + if (fseek(fp, textstart, 0) < 0) + error("file seek error"); +#ifdef mips + printf("start address -T %x ",memory->cfd.cfd_start); + bzero(memory->cfd.cfd_start, MIPS_ROUND); + fread((void *)sectionheader.s_vaddr, textsize + datasize, 1, fp); +#else + fread(memory->cfd.cfd_start, textsize + datasize, 1, fp); +#endif + close_stream(tempfile); + + unlink(tempfilename); + + call_init(0,memory,data,0); + + vs_base = old_vs_base; + vs_top = old_vs_top; + + return(memory->cfd.cfd_size); +} + +siLfaslink() +{ + bds_ptr old_bds_top; + int i; + object package; + + check_arg(2); + check_type_or_pathname_string_symbol_stream(&vs_base[0]); + check_type_string(&vs_base[1]); + vs_base[0] = coerce_to_pathname(vs_base[0]); + vs_base[0]->pn.pn_type = FASL_string; + vs_base[0] = namestring(vs_base[0]); + package = symbol_value(sLApackageA); + old_bds_top = bds_top; + bds_bind(sLApackageA, package); + i = faslink(vs_base[0], vs_base[1]); + bds_unwind(old_bds_top); + vs_top = vs_base; + vs_push(make_fixnum(i)); +} + +#endif + +#define FASLINK diff --git a/o/fat_string.c b/o/fat_string.c new file mode 100755 index 0000000..c9ecb96 --- /dev/null +++ b/o/fat_string.c @@ -0,0 +1,392 @@ +/* +(c) Copyright W. Schelter 1988, All rights reserved. +*/ + +#include +#include +#include + +#include "include.h" +#include "page.h" + +#ifdef HAVE_LIBBFD +#ifdef NEED_CONST +#define CONST const +#endif +#define IN_GCC +#include +#include +#endif + +#define FAT_STRING + + +enum type what_to_collect; + +/* start fasdump stuff */ +#include "fasdump.c" + + + +object sSAprofile_arrayA; +#ifdef NO_PROFILE +#ifdef DARWIN/*FIXME macosx10.8 has a prototype (which must match here) but unlinkable function in 64bit*/ +int profil(char *buf, size_t bufsiz, unsigned long offset, unsigned int scale){return 0;} +#else +void profil(void){;} +#endif +#endif + + +#ifndef NO_PROFILE +DEFUN_NEW("PROFILE",object,fSprofile,SI + ,2,2,NONE,OO,OO,OO,OO,(object start_address,object scale), + "Sets up profiling with START-ADDRESS and SCALE where scale is \ + between 0 and 256") +{ /* 2 args */ + + object ar=sSAprofile_arrayA->s.s_dbind; + void *x; + + if (type_of(ar)!=t_string) + FEerror("si:*Profile-array* not a string",0); + if( type_of(start_address)!=t_fixnum || type_of(scale)!=t_fixnum) + FEerror("Needs start address and scale as args",0); + + x=!(fix(start_address)*fix(scale)) ? NULL : (void *) (ar->ust.ust_self); + profil(x, (ar->ust.ust_dim),fix(start_address),fix(scale) << 8); + RETURN1(start_address); +} + +#endif +DEFUN_NEW("FUNCTION-START",object,fSfunction_start,SI + ,1,1,NONE,OO,OO,OO,OO,(object funobj),"") +{/* 1 args */ + if(type_of(funobj)!=t_cfun + && type_of(funobj)!=t_sfun + && type_of(funobj)!=t_vfun + && type_of(funobj)!=t_afun + && type_of(funobj)!=t_gfun) + FEerror("not compiled function",0); + funobj=make_fixnum((long) (funobj->cf.cf_self)); + RETURN1(funobj); +} + +/* begin fasl stuff*/ +/* this is for windows to not include all of windows.h for this..*/ + +#include "ptable.h" +#ifdef AIX3 +#include +char *data_load_addr =0; +#endif + +#define CFUN_LIM 10000 + +int maxpage; +object sScdefn; + +#define CF_FLAG ((unsigned long)1 << (sizeof(long)*8-1)) + +static void +cfuns_to_combined_table(unsigned int n) /* non zero n will ensure new table length */ + +{int ii=0; + STATIC int j; + STATIC object x; + STATIC char *p,*cf_addr; + STATIC struct typemanager *tm; + if (! (n || combined_table.ptable)) n=CFUN_LIM; + if (n && combined_table.alloc_length < n) + { + (combined_table.ptable)=NULL; + (combined_table.ptable)= (struct node *)malloc(n* sizeof(struct node)); + if(!combined_table.ptable) + FEerror("unable to allocate",0); + combined_table.alloc_length=n;} + + { + struct pageinfo *v; + for (v=cell_list_head;v;v=v->next) { + enum type tp=v->type; + if (tp!=tm_table[(short)t_cfun].tm_type && + tp!=tm_table[(short)t_gfun].tm_type && + tp!=tm_table[(short)t_sfun].tm_type && + tp!=tm_table[(short)t_vfun].tm_type + ) + continue; + tm = tm_of(tp); + p = pagetochar(page(v)); + for (j = tm->tm_nppage; j > 0; --j, p += tm->tm_size) { + x = (object)p; + if (type_of(x)!=t_cfun && + type_of(x)!=t_sfun && + type_of(x)!=t_vfun && + type_of(x)!=t_gfun + ) continue; + if (is_free(x) || x->cf.cf_self == NULL) + continue; + /* the cdefn things are the proclaimed call types. */ + cf_addr=(char * ) ((unsigned long)(x->cf.cf_self)); + + SYM_ADDRESS(combined_table,ii)=(unsigned long)cf_addr; + SYM_STRING(combined_table,ii)= (char *)(CF_FLAG | (unsigned long)x) ; + /* (x->cf.cf_name ? x->cf.cf_name->s.st_self : NULL) ; */ + combined_table.length = ++ii; + if (ii >= combined_table.alloc_length) + FEerror("Need a larger combined_table",0); + } + } + } +} + +static int +address_node_compare(const void *node1, const void *node2) +{unsigned int a1,a2; + a1=((struct node *)node1)->address; + a2=((struct node *)node2)->address; + if (a1> a2) return 1; + if (a1< a2) return -1; + return 0; +} + + +#if defined(HAVE_LIBBFD) && ! defined(SPECIAL_RSYM) + +static int bfd_update; + +static MY_BFD_BOOLEAN +bfd_combined_table_update(struct bfd_link_hash_entry *h,PTR ct) { + + if (ct!=&combined_table) + return MY_BFD_FALSE; + + if (h->type!=bfd_link_hash_defined) + return MY_BFD_TRUE; + + if (!h->u.def.section) { + FEerror("Symbol without section",0); + return MY_BFD_FALSE; + } + + if (bfd_update) { + if (combined_table.length>=combined_table.alloc_length) + FEerror("combined table overflow", 0); + + SYM_ADDRESS(combined_table,combined_table.length)=h->u.def.value+h->u.def.section->vma; + SYM_STRING(combined_table,combined_table.length)=(char *)h->root.string; + } + + combined_table.length++; + + return MY_BFD_TRUE; + +} +#endif + + +DEFUN_NEW("SET-UP-COMBINED",object,fSset_up_combined,SI + ,0,1,NONE,OO,OO,OO,OO,(object first,...),"") +{ + int nargs=VFUN_NARGS; + unsigned int n; + object siz; + + if (nargs>=1) + siz=first; + else + siz = small_fixnum(0); + + CHECK_ARG_RANGE(0,1); + n = (unsigned int) fix(siz); + cfuns_to_combined_table(n); + +#if !defined(HAVE_LIBBFD) && !defined(SPECIAL_RSYM) +#error Need either BFD or SPECIAL_RSYM +#endif + +#if defined(SPECIAL_RSYM) + if (c_table.ptable) { + + int j,k; + + if((k=combined_table.length)+c_table.length >= combined_table.alloc_length) + cfuns_to_combined_table(combined_table.length+c_table.length+20); + + for(j = 0; j < c_table.length;) { + SYM_ADDRESS(combined_table,k) =SYM_ADDRESS(c_table,j); + SYM_STRING(combined_table,k) =SYM_STRING(c_table,j); + k++; + j++; + } + + combined_table.length += c_table.length ; + + } + +#else +#if defined(HAVE_LIBBFD) + if (link_info.hash) { + + bfd_update=0; + bfd_link_hash_traverse(link_info.hash, + bfd_combined_table_update,&combined_table); + + if (combined_table.length >=combined_table.alloc_length) + cfuns_to_combined_table(combined_table.length); + + bfd_update=1; + bfd_link_hash_traverse(link_info.hash, + bfd_combined_table_update,&combined_table); + bfd_update=0; + + } +#endif +#endif + + qsort(combined_table.ptable,combined_table.length,sizeof(*combined_table.ptable),address_node_compare); + + RETURN1(siz); + +} + +static int prof_start; +static int +prof_ind(unsigned int address, int scale) +{address = address - prof_start ; + if (address > 0) return ((address * scale) >> 8) ; + return 0; +} + +/* sum entries AAR up to DIM entries */ +static int +string_sum(register unsigned char *aar, unsigned int dim) +{register unsigned char *endar; + register unsigned int count = 0; +endar=aar+dim; + for ( ; aar< endar; aar++) + count += *aar; + return count; +} + + +DEFUN_NEW("DISPLAY-PROFILE",object,fSdisplay_profile,SI + ,2,2,NONE,OO,OO,OO,OO,(object start_addr,object scal),"") +{if (!combined_table.ptable) + FEerror("must symbols first",0); + /* 2 args */ + {unsigned int prev,next,upto,dim,total; + int j,scale,count; + unsigned char *ar; + object obj_ar; + obj_ar=sSAprofile_arrayA->s.s_dbind; + if (type_of(obj_ar)!=t_string) + FEerror("si:*Profile-array* not a string",0); + ar=obj_ar->ust.ust_self; + scale=fix(scal); + prof_start=fix(start_addr); + vs_top=vs_base; + dim= (obj_ar->ust.ust_dim); + + total=string_sum(ar,dim); + + j=0; + {int i, finish = combined_table.length-1; + for(i =0,prev=SYM_ADDRESS(combined_table,i); i< finish; + prev=next) + { ++i; + next=SYM_ADDRESS(combined_table,i); + if ( prev < prof_start) continue; + upto=prof_ind(next,scale); + if (upto >= dim) upto=dim; + {const char *name; unsigned long uname; + count=0; + for( ; j 0) { + name=SYM_STRING(combined_table,i-1); + uname = (unsigned long) name; + printf("\n%6.2f%% (%5d): ",(100.0*count)/total, count); + fflush(stdout); + if (CF_FLAG & uname) + {if (~CF_FLAG & uname) prin1( ((object) (~CF_FLAG & uname))->cf.cf_name,Cnil);} + else if (name ) printf("%s",name);}; + if (upto==dim) goto TOTALS ; + + }}} + TOTALS: + printf("\nTotal ticks %d",total);fflush(stdout); + } + RETURN1(start_addr); +} + + + +/* end fasl stuff*/ + + +/* These are some low level hacks to allow determining the address + of an array body, and to allow jumping to inside the body + of the array */ + +DEFUN_NEW("ARRAY-ADRESS",object,fSarray_adress,SI + ,1,1,NONE,OO,OO,OO,OO,(object array),"") +{/* 1 args */ + array=make_fixnum((long) (&(array->st.st_self[0]))); + RETURN1(array); +} + +/* This is some very low level code for hacking invokation of + m68k instructions in a lisp array. The index used should be + a byte index. So invoke(ar,3) jmps to byte ar+3. + */ + +#ifdef CLI + +invoke(ar) +char *ar; +{asm("movel a6@(8),a0"); + asm("jmp a0@"); +} +/* save regs (2 3 4 5 6 7 10 11 12 13 14) and invoke restoring them */ +save_regs_invoke(ar) +char *ar; +{asm("moveml #0x3f3e,sp@-"); + invoke(ar); + asm("moveml a6@(-44),#0x7cfc"); +} + +/* DEFUNO_NEW("SAVE-REGS-INVOKE",object,fSsave_regs_invoke,SI + ,2,2,NONE,OO,OO,OO,OO,void,siLsave_regs_invoke,"",(x0,x1)) +object x0,x1; +{int x; + check_type_integer(&x1); + x=save_regs_invoke((x0->st.st_self)+fix(x1)); + x0=make_fixnum(x); + RETURN1(x0); +} +*/ + +#endif + +DEFVAR("*PROFILE-ARRAY*",sSAprofile_arrayA,SI,Cnil,""); +void +gcl_init_fat_string(void) +{ + + make_si_constant("*ASH->>*",(-1==(((int)-1) >> 20))? Ct :Cnil); +/* #ifdef SFASL */ +/* make_si_function("BUILD-SYMBOL-TABLE",build_symbol_table); */ +/* #endif */ + + + init_fasdump(); + +} + + + + + + + diff --git a/o/file.d b/o/file.d new file mode 100755 index 0000000..9885e67 --- /dev/null +++ b/o/file.d @@ -0,0 +1,2743 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +*/ + +/* + file.d + IMPLEMENTATION-DEPENDENT + + The specification of printf may be dependent on the C library, + especially for read-write access, append access, etc. + The file also contains the code to reclaim the I/O buffer + by accessing the FILE structure of C. + It also contains read_fasl_data. +*/ + +#include +#include +#include +#include +#include + +#define IN_FILE +#include "include.h" + +#ifdef HAVE_READLINE +#define kclgetc(FP) rl_getc_em(((FILE *)FP)) +#define kclungetc(C, FP) rl_ungetc_em(C, ((FILE *)FP)) +#define kclputc(C, FP) rl_putc_em(C, ((FILE *)FP)) +#else +#define kclgetc(FP) getc(((FILE *)FP)) +#define kclungetc(C, FP) ungetc(C, ((FILE *)FP)) +#define kclputc(C, FP) putc(C, ((FILE *)FP)) +#endif /* HAVE_READLINE */ + +#define xkclfeof(c,FP) feof(((FILE *)FP)) + +#ifdef HAVE_AOUT +#undef ATT +#undef BSD +#ifndef HAVE_ELF +#ifndef HAVE_FILEHDR +#define BSD +#endif +#endif +#include HAVE_AOUT +#endif + +#ifdef ATT +#include +#include +#define HAVE_FILEHDR +#endif + +#ifdef E15 +#include +#define exec bhdr +#define a_text tsize +#define a_data dsize +#define a_bss bsize +#define a_syms ssize +#define a_trsize rtsize +#define a_drsize rdsize +#endif + +#if defined(HAVE_ELF_H) +#include +#elif defined(HAVE_ELF_ABI_H) +#include +#endif + +#ifndef __MINGW32__ +# include +# include +# include +#else +# include +# include +#endif +#include + +extern void tcpCloseSocket (int fd); + +object terminal_io; + +object Vverbose; +object LSP_string; + + +object sSAignore_eof_on_terminal_ioA; + +static bool +feof1(fp) +FILE *fp; +{ + +#ifdef HAVE_READLINE + if (rl_stream_p(fp) && rl_eof_p(fp)) + return TRUE; +#endif + if (!feof(fp)) + return(FALSE); + if (fp == terminal_io->sm.sm_object0->sm.sm_fp) { + if (symbol_value(sSAignore_eof_on_terminal_ioA) == Cnil) + return(TRUE); +#ifdef UNIX + fp = freopen("/dev/tty", "r", fp); +#endif +#ifdef AOSVS + +#endif + if (fp == NULL) + error("can't reopen the console"); + return(FALSE); + } + return(TRUE); +} + +#undef feof +#define feof feof1 + +void +end_of_stream(strm) +object strm; +{ + FEerror("Unexpected end of ~S.", 1, strm); +} + +/* + Input_stream_p(strm) answers + if stream strm is an input stream or not. + It does not check if it really is possible to read + from the stream, + but only checks the mode of the stream (sm_mode). +*/ +static bool +input_stream_p(strm) +object strm; +{ +BEGIN: + switch (strm->sm.sm_mode) { + case smm_input: + return(TRUE); + + case smm_output: + return(FALSE); + + case smm_io: + case smm_socket: + return(TRUE); + + case smm_probe: + return(FALSE); + + case smm_synonym: + strm = symbol_value(strm->sm.sm_object0); + if (type_of(strm) != t_stream) + FEwrong_type_argument(sLstream, strm); + goto BEGIN; + + case smm_broadcast: + return(FALSE); + + case smm_concatenated: + return(TRUE); + + case smm_two_way: + return(TRUE); + + case smm_echo: + return(TRUE); + + case smm_string_input: + return(TRUE); + + case smm_string_output: + return(FALSE); + + default: + error("illegal stream mode"); + return(FALSE); + } +} + +/* + Output_stream_p(strm) answers + if stream strm is an output stream. + It does not check if it really is possible to write + to the stream, + but only checks the mode of the stream (sm_mode). +*/ +static bool +output_stream_p(strm) +object strm; +{ +BEGIN: + switch (strm->sm.sm_mode) { + case smm_input: + return(FALSE); + + case smm_output: + return(TRUE); + + case smm_io: + case smm_socket: + return(TRUE); + + case smm_probe: + return(FALSE); + + case smm_synonym: + strm = symbol_value(strm->sm.sm_object0); + if (type_of(strm) != t_stream) + FEwrong_type_argument(sLstream, strm); + goto BEGIN; + + case smm_broadcast: + return(TRUE); + + case smm_concatenated: + return(FALSE); + + case smm_two_way: + return(TRUE); + + case smm_echo: + return(TRUE); + + case smm_string_input: + return(FALSE); + + case smm_string_output: + return(TRUE); + + default: + error("illegal stream mode"); + return(FALSE); + } +} + +static object +stream_element_type(strm) +object strm; +{ + object x; + +BEGIN: + switch (strm->sm.sm_mode) { + case smm_input: + case smm_output: + case smm_io: + case smm_probe: + return(strm->sm.sm_object0); + + case smm_socket: + return (sLstring_char); + + case smm_synonym: + strm = symbol_value(strm->sm.sm_object0); + if (type_of(strm) != t_stream) + FEwrong_type_argument(sLstream, strm); + goto BEGIN; + + case smm_broadcast: + x = strm->sm.sm_object0; + if (endp(x)) + return(Ct); + return(stream_element_type(x->c.c_car)); + + case smm_concatenated: + x = strm->sm.sm_object0; + if (endp(x)) + return(Ct); + return(stream_element_type(x->c.c_car)); + + case smm_two_way: + return(stream_element_type(STREAM_INPUT_STREAM(strm))); + + case smm_echo: + return(stream_element_type(STREAM_INPUT_STREAM(strm))); + + case smm_string_input: + return(sLstring_char); + + case smm_string_output: + return(sLstring_char); + + default: + error("illegal stream mode"); + return(FALSE); + } +} + +void +setup_stream_buffer(object x) { +#ifdef NO_SETBUF + massert(!setvbuf(x->sm.sm_fp,x->sm.sm_buffer=NULL,_IONBF,0)); +#else + massert(!setvbuf(x->sm.sm_fp,x->sm.sm_buffer=writable_malloc_wrap(malloc,void *,BUFSIZ),_IOFBF,BUFSIZ)); +#endif +} + +static void +deallocate_stream_buffer(object strm) { + + if (strm->sm.sm_buffer==NULL) + return; + + free(strm->sm.sm_buffer); + + massert(!setvbuf(strm->sm.sm_fp,strm->sm.sm_buffer=NULL,_IONBF,0)); + +} + +DEFVAR("*ALLOW-GZIPPED-FILE*",sSAallow_gzipped_fileA,SI,sLnil,""); + +/* static void */ +/* too_long_file_name(object); */ +static void +cannot_open(object); +static void +cannot_create(object); +/* + Open_stream(fn, smm, if_exists, if_does_not_exist) + opens file fn with mode smm. + Fn is a namestring. +*/ +object +open_stream(fn, smm, if_exists, if_does_not_exist) +object fn; +enum smmode smm; +object if_exists, if_does_not_exist; +{ + object x; + FILE *fp=NULL; + char fname[PATH_MAX]; + object unzipped = 0; + vs_mark; + +/* + if (type_of(fn) != t_string) + FEwrong_type_argument(sLstring, fn); +*/ + /* if (fn->st.st_fillp > BUFSIZ - 1) */ + /* too_long_file_name(fn); */ + /* for (i = 0; i < fn->st.st_fillp; i++) */ + /* fname[i] = fn->st.st_self[i]; */ + + /* fname[i] = '\0'; */ + coerce_to_filename(fn,fname); + if (smm == smm_input || smm == smm_probe) { + if(fname[0]=='|') + fp = popen(fname+1,"r"); + else + fp = fopen_not_dir(fname, "r"); + + AGAIN: + if (fp == NULL) { + if (sSAallow_gzipped_fileA->s.s_dbind != sLnil) + { + static struct string st; + char buf[256]; + if (snprintf(buf,sizeof(buf),"%s.gz",fname)<=0) + FEerror("Cannot write .gz filename",0); + st.st_self=buf; + st.st_dim=st.st_fillp=strlen(buf); + set_type_of(&st,t_string); + if (file_exists((object)&st)) { + FILE *pp; + int n; + if (!(fp=tmpfile())) + FEerror("Cannot create temporary file",0); + if (snprintf(buf,sizeof(buf),"zcat %s.gz",fname)<=0) + FEerror("Cannot write zcat pipe name",0); + if (!(pp=popen(buf,"r"))) + FEerror("Cannot open zcat pipe",0); + while((n=fread(buf,1,sizeof(buf),pp))) + if (!fwrite(buf,1,n,fp)) + FEerror("Cannot write pipe output to temporary file",0); + if (pclose(pp)<0) + FEerror("Cannot close zcat pipe",0); + if (fseek(fp,0,SEEK_SET)) + FEerror("Cannot rewind temporary file\n",0); + goto AGAIN; + } + } + +/* fp = fopen_not_dir(buf,"r"); */ +/* if (fp) */ +/* { */ +/* #ifdef NO_MKSTEMP */ +/* char *tmp; */ +/* #else */ +/* char tmp[200]; */ +/* #endif */ +/* char command [500]; */ +/* fclose(fp); */ +/* #ifdef NO_MKSTEMP */ +/* tmp = tmpnam(0); */ +/* #else */ +/* snprintf(tmp,sizeof(tmp),"uzipXXXXXX"); */ + /* mkstemp(tmp); */ /* fixme: catch errors */ +/* #endif */ +/* unzipped = make_simple_string(tmp); */ +/* sprintf(command,"gzip -dc %s > %s",buf,tmp); */ +/* fp = 0; */ +/* if (0 == system(command)) */ +/* { */ +/* fp = fopen_not_dir(tmp,"r"); */ +/* if (fp) */ +/* goto AGAIN; */ +/* /\* should not get here *\/ */ +/* else { unlink(tmp);}} */ +/* }} */ + if (if_does_not_exist == sKerror) + cannot_open(fn); + else if (if_does_not_exist == sKcreate) { + fp = fopen_not_dir(fname, "w"); + if (fp == NULL) + cannot_create(fn); + fclose(fp); + fp = fopen_not_dir(fname, "r"); + if (fp == NULL) + cannot_open(fn); + } else if (if_does_not_exist == Cnil) + return(Cnil); + else + FEerror("~S is an illegal IF-DOES-NOT-EXIST option.", + 1, if_does_not_exist); + } + } else if (smm == smm_output || smm == smm_io) { + if (if_exists == sKnew_version && if_does_not_exist == sKcreate) + goto CREATE; + fp = fopen_not_dir(fname, "r"); + if (fp != NULL) { + fclose(fp); + if (if_exists == sKerror) + FEerror("The file ~A already exists.", 1, fn); + else if (if_exists == sKrename) { + if (smm == smm_output) + fp = backup_fopen(fname, "w"); + else + fp = backup_fopen(fname, "w+"); + if (fp == NULL) + cannot_create(fn); + } else if (if_exists == sKrename_and_delete || + if_exists == sKnew_version || + if_exists == sKsupersede) { + if (smm == smm_output) + fp = fopen_not_dir(fname, "w"); + else + fp = fopen_not_dir(fname, "w+"); + if (fp == NULL) + cannot_create(fn); + } else if (if_exists == sKoverwrite) { + fp = fopen_not_dir(fname, "r+"); + if (fp == NULL) + cannot_open(fn); + } else if (if_exists == sKappend) { + if (smm == smm_output) + fp = fopen_not_dir(fname, "a"); + else + fp = fopen_not_dir(fname, "a+"); + if (fp == NULL) + FEerror("Cannot append to the file ~A.",1,fn); + } else if (if_exists == Cnil) + return(Cnil); + else + FEerror("~S is an illegal IF-EXISTS option.", + 1, if_exists); + } else { + if (if_does_not_exist == sKerror) + FEerror("The file ~A does not exist.", 1, fn); + else if (if_does_not_exist == sKcreate) { + CREATE: + if (smm == smm_output) + { + if(fname[0]=='|') + fp = popen(fname+1,"w"); + else + fp = fopen_not_dir(fname, "w"); + } + else + fp = fopen_not_dir(fname, "w+"); + if (fp == NULL) + cannot_create(fn); + } else if (if_does_not_exist == Cnil) + return(Cnil); + else + FEerror("~S is an illegal IF-DOES-NOT-EXIST option.", + 1, if_does_not_exist); + } + } else + error("illegal stream mode"); + x = alloc_object(t_stream); + x->sm.sm_mode = (short)smm; + x->sm.sm_fp = fp; + + x->sm.sm_buffer = 0; + x->sm.sm_object0 = (unzipped ? make_cons(sSAallow_gzipped_fileA,unzipped) : sLstring_char); + x->sm.sm_object1 = fn; + x->sm.sm_int0 = x->sm.sm_int1 = 0; + vs_push(x); + setup_stream_buffer(x); + vs_reset; + return(x); +} + +static void +gclFlushSocket(object); +/* + Close_stream(strm) closes stream strm. + The abort_flag is not used now. +*/ +void +close_stream(strm) +object strm; +/*bool abort_flag; */ /* Not used now! */ +{ + object x; + +BEGIN: + switch (strm->sm.sm_mode) { + case smm_output: + if (strm->sm.sm_fp == stdout) + FEerror("Cannot close the standard output.", 0); + if (strm->sm.sm_fp == NULL) break; + fflush(strm->sm.sm_fp); + deallocate_stream_buffer(strm); + fclose(strm->sm.sm_fp); + strm->sm.sm_fp = NULL; + break; + + + case smm_socket: + if (SOCKET_STREAM_FD(strm) < 2) { + fprintf(stderr,"tried Clsing %d ! as scoket \n",SOCKET_STREAM_FD(strm)); + fflush(stderr); + } + else { +#ifdef HAVE_NSOCKET + if (GET_STREAM_FLAG(strm,gcl_sm_output)) + { + gclFlushSocket(strm); + /* there are two for one fd so close only one */ + tcpCloseSocket(SOCKET_STREAM_FD(strm)); + } +#endif + SOCKET_STREAM_FD(strm)=-1; + } + + case smm_input: + if (strm->sm.sm_fp == stdin) + FEerror("Cannot close the standard input.", 0); + + case smm_io: + case smm_probe: + if (strm->sm.sm_fp == NULL) break; + deallocate_stream_buffer(strm); + if (strm->sm.sm_object1 && + type_of(strm->sm.sm_object1)==t_string && + strm->sm.sm_object1->st.st_self[0] =='|') + pclose(strm->sm.sm_fp); + else + fclose(strm->sm.sm_fp); + strm->sm.sm_fp = NULL; + if (type_of(strm->sm.sm_object0 ) == t_cons && + Mcar(strm->sm.sm_object0 ) == sSAallow_gzipped_fileA) + fLdelete_file(Mcdr(strm->sm.sm_object0)); + break; + + case smm_synonym: + strm = symbol_value(strm->sm.sm_object0); + if (type_of(strm) != t_stream) + FEwrong_type_argument(sLstream, strm); + goto BEGIN; + + case smm_broadcast: + for (x = strm->sm.sm_object0; !endp(x); x = x->c.c_cdr) + close_stream(x->c.c_car); + break; + + case smm_concatenated: + for (x = strm->sm.sm_object0; !endp(x); x = x->c.c_cdr) + close_stream(x->c.c_car); + break; + + case smm_two_way: + case smm_echo: + close_stream(STREAM_INPUT_STREAM(strm)); + close_stream(STREAM_OUTPUT_STREAM(strm)); + break; + + case smm_string_input: + break; /* There is nothing to do. */ + + case smm_string_output: + break; /* There is nothing to do. */ + + default: + error("illegal stream mode"); + } +} + +object +make_two_way_stream(istrm, ostrm) +object istrm, ostrm; +{ + object strm; + + strm = alloc_object(t_stream); + strm->sm.sm_mode = (short)smm_two_way; + strm->sm.sm_fp = NULL; + strm->sm.sm_buffer = 0; + STREAM_INPUT_STREAM(strm) = istrm; + STREAM_OUTPUT_STREAM(strm) = ostrm; + strm->sm.sm_int0 = strm->sm.sm_int1 = 0; + return(strm); +} + +static object +make_echo_stream(istrm, ostrm) +object istrm, ostrm; +{ + object strm; + + strm = make_two_way_stream(istrm, ostrm); + strm->sm.sm_mode = (short)smm_echo; + return(strm); +} + +object +make_string_input_stream(strng, istart, iend) +object strng; +int istart, iend; +{ + object strm; + + strm = alloc_object(t_stream); + strm->sm.sm_mode = (short)smm_string_input; + strm->sm.sm_fp = NULL; + strm->sm.sm_buffer = 0; + STRING_STREAM_STRING(strm) = strng; + strm->sm.sm_object1 = OBJNULL; + STRING_INPUT_STREAM_NEXT(strm)= istart; + STRING_INPUT_STREAM_END(strm)= iend; + return(strm); +} + +DEFUN_NEW("STRING-INPUT-STREAM-P",object,fSstring_input_stream_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { + return type_of(x)==t_stream && x->sm.sm_mode == (short)smm_string_input ? Ct : Cnil; +} +DEFUN_NEW("STRING-OUTPUT-STREAM-P",object,fSstring_output_stream_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { + return type_of(x)==t_stream && x->sm.sm_mode == (short)smm_string_output ? Ct : Cnil; +} + +object +make_string_output_stream(line_length) +int line_length; +{ + object strng, strm; + vs_mark; + + strng = alloc_object(t_string); + strng->st.st_hasfillp = TRUE; + strng->st.st_adjustable = TRUE; + strng->st.st_displaced = Cnil; + strng->st.st_dim = line_length; + strng->st.st_fillp = 0; + strng->st.st_self = NULL; + /* For GBC not to go mad. */ + vs_push(strng); + /* Saving for GBC. */ + strng->st.st_self = alloc_relblock(line_length); + strm = alloc_object(t_stream); + strm->sm.sm_mode = (short)smm_string_output; + strm->sm.sm_fp = NULL; + strm->sm.sm_buffer = 0; + STRING_STREAM_STRING(strm) = strng; + strm->sm.sm_object1 = OBJNULL; + strm->sm.sm_int0 = STREAM_FILE_COLUMN(strm) = 0; + vs_reset; + return(strm); +} + +static object +get_output_stream_string(strm) +object strm; +{ + object strng; + + strng = copy_simple_string(STRING_STREAM_STRING(strm)); + STRING_STREAM_STRING(strm)->st.st_fillp = 0; + return(strng); +} + +static void +cannot_read(object); + +static void +closed_stream(object); + int +readc_stream(strm) +object strm; +{ + int c; + +BEGIN: + switch (strm->sm.sm_mode) { +#ifdef HAVE_NSOCKET + case smm_socket: + return (getCharGclSocket(strm,Ct)); +#endif + case smm_input: + case smm_io: + + if (strm->sm.sm_fp == NULL) + closed_stream(strm); + #if (1) + c = kclgetc(strm->sm.sm_fp); + #else + c = getOneChar(strm->sm.sm_fp); + #endif +/* if (c == EOF) { */ +/* if (xkclfeof(c,strm->sm.sm_fp)) */ +/* end_of_stream(strm); */ +/* else c = getOneChar(strm->sm.sm_fp); */ +/* if (c == EOF) end_of_stream(strm); */ +/* } */ + +/* c &= 0377; */ + /* strm->sm.sm_int0++; */ + return(c==EOF ? c : (c&0377)); + + case smm_synonym: + strm = symbol_value(strm->sm.sm_object0); + if (type_of(strm) != t_stream) + FEwrong_type_argument(sLstream, strm); + goto BEGIN; + + case smm_concatenated: + CONCATENATED: + if (endp(strm->sm.sm_object0)) { + end_of_stream(strm); + } + if (stream_at_end(strm->sm.sm_object0->c.c_car)) { + strm->sm.sm_object0 + = strm->sm.sm_object0->c.c_cdr; + goto CONCATENATED; + } + c = readc_stream(strm->sm.sm_object0->c.c_car); + return(c); + + case smm_two_way: +#ifdef UNIX + if (strm == terminal_io) + flush_stream(STREAM_OUTPUT_STREAM(terminal_io)); +#endif + /* strm->sm.sm_int1 = 0; */ + strm = STREAM_INPUT_STREAM(strm); + goto BEGIN; + + case smm_echo: + c = readc_stream(STREAM_INPUT_STREAM(strm)); + if (ECHO_STREAM_N_UNREAD(strm) == 0) + writec_stream(c, STREAM_OUTPUT_STREAM(strm)); + else + --(ECHO_STREAM_N_UNREAD(strm)); + return(c); + + case smm_string_input: + if (STRING_INPUT_STREAM_NEXT(strm)>= STRING_INPUT_STREAM_END(strm)) + end_of_stream(strm); + return(STRING_STREAM_STRING(strm)->st.st_self + [STRING_INPUT_STREAM_NEXT(strm)++]); + + case smm_output: + case smm_probe: + case smm_broadcast: + case smm_string_output: + cannot_read(strm); +#ifdef USER_DEFINED_STREAMS + case smm_user_defined: +#define STM_DATA_STRUCT 0 +#define STM_READ_CHAR 1 +#define STM_WRITE_CHAR 2 +#define STM_UNREAD_CHAR 7 +#define STM_FORCE_OUTPUT 4 +#define STM_PEEK_CHAR 3 +#define STM_CLOSE 5 +#define STM_TYPE 6 +#define STM_NAME 8 +{object val; + object *old_vs_base = vs_base; + object *old_vs_top = vs_top; + vs_base = vs_top; + vs_push(strm); + super_funcall(strm->sm.sm_object1->str.str_self[STM_READ_CHAR]); + val = vs_base[0]; + vs_base = old_vs_base; + vs_top = old_vs_top; + if (type_of(val) == t_fixnum) + return (fix(val)); + if (type_of(val) == t_character) + return (char_code(val)); + } + +#endif + + default: + error("illegal stream mode"); + return(0); + } +} + +int +rl_ungetc_em(int, FILE *); + +void +unreadc_stream(int c, object strm) { +BEGIN: + switch (strm->sm.sm_mode) { + case smm_socket: +#ifdef HAVE_NSOCKET + ungetCharGclSocket(c,strm); + return; +#endif + case smm_input: + case smm_io: + + if (strm->sm.sm_fp == NULL) + closed_stream(strm); + kclungetc(c, strm->sm.sm_fp); + /* --strm->sm.sm_int0; */ /* use ftell now for position */ + break; + + case smm_synonym: + strm = symbol_value(strm->sm.sm_object0); + if (type_of(strm) != t_stream) + FEwrong_type_argument(sLstream, strm); + goto BEGIN; + + case smm_concatenated: + if (endp(strm->sm.sm_object0)) + goto UNREAD_ERROR; + strm = strm->sm.sm_object0->c.c_car; + goto BEGIN; + + case smm_two_way: + strm = STREAM_INPUT_STREAM(strm); + goto BEGIN; + + case smm_echo: + unreadc_stream(c, STREAM_INPUT_STREAM(strm)); + ECHO_STREAM_N_UNREAD(strm)++; + break; + + case smm_string_input: + if (STRING_INPUT_STREAM_NEXT(strm)<= 0) + goto UNREAD_ERROR; + --STRING_INPUT_STREAM_NEXT(strm); + break; + + case smm_output: + case smm_probe: + case smm_broadcast: + case smm_string_output: + goto UNREAD_ERROR; + +#ifdef USER_DEFINED_STREAMS + case smm_user_defined: + {object *old_vs_base = vs_base; + object *old_vs_top = vs_top; + vs_base = vs_top; + vs_push(strm); + /* if there is a file pointer and no define unget function, + * then call ungetc */ + if ((strm->sm.sm_fp != NULL ) && + strm->sm.sm_object1->str.str_self[STM_UNREAD_CHAR] == Cnil) + kclungetc(c, strm->sm.sm_fp); + else + super_funcall(strm->sm.sm_object1->str.str_self[STM_UNREAD_CHAR]); + vs_top = old_vs_top; + vs_base = old_vs_base; + } + break; +#endif + default: + error("illegal stream mode"); + } + return; + +UNREAD_ERROR: + FEerror("Cannot unread the stream ~S.", 1, strm); +} + +static void +putCharGclSocket(object,int); +int +rl_putc_em(int, FILE *); +static void +cannot_write(object); + +int +writec_stream(int c, object strm) { + object x; + char *p; + int i; + +BEGIN: + switch (strm->sm.sm_mode) { + case smm_output: + case smm_io: + case smm_socket: + /* strm->sm.sm_int0++; */ + if (c == '\n') + STREAM_FILE_COLUMN(strm) = 0; + else if (c == '\t') + STREAM_FILE_COLUMN(strm) = (STREAM_FILE_COLUMN(strm)&~07) + 8; + else + STREAM_FILE_COLUMN(strm)++; + if (strm->sm.sm_fp == NULL) + { +#ifdef HAVE_NSOCKET + if (strm->sm.sm_mode == smm_socket && strm->sm.sm_fd>=0) + putCharGclSocket(strm,c); + else +#endif + if (!GET_STREAM_FLAG(strm,gcl_sm_had_error)) + closed_stream(strm); + } else { + + kclputc(c, strm->sm.sm_fp); + } + + break; + + case smm_synonym: + strm = symbol_value(strm->sm.sm_object0); + if (type_of(strm) != t_stream) + FEwrong_type_argument(sLstream, strm); + goto BEGIN; + + case smm_broadcast: + for (x = strm->sm.sm_object0; !endp(x); x = x->c.c_cdr) + writec_stream(c, x->c.c_car); + break; + + case smm_two_way: + /* this should be on the actual streams + strm->sm.sm_int0++; + if (c == '\n') + strm->sm.sm_int1 = 0; + else if (c == '\t') + strm->sm.sm_int1 = (strm->sm.sm_int1&~07) + 8; + else + strm->sm.sm_int1++; + */ + strm = STREAM_OUTPUT_STREAM(strm); + goto BEGIN; + + case smm_echo: + strm = STREAM_OUTPUT_STREAM(strm); + goto BEGIN; + + case smm_string_output: + /* strm->sm.sm_int0++; */ + if (c == '\n') + STREAM_FILE_COLUMN(strm) = 0; + else if (c == '\t') + STREAM_FILE_COLUMN(strm) = (STREAM_FILE_COLUMN(strm)&~07) + 8; + else + STREAM_FILE_COLUMN(strm)++; + x = STRING_STREAM_STRING(strm); + if (x->st.st_fillp >= x->st.st_dim) { + if (!x->st.st_adjustable) + FEerror("The string ~S is not adjustable.", + 1, x); + p = (inheap((long)x->st.st_self) ? alloc_contblock : alloc_relblock) + (x->st.st_dim * 2 + 16); + for (i = 0; i < x->st.st_dim; i++) + p[i] = x->st.st_self[i]; + i = x->st.st_dim * 2 + 16; +#define ADIMLIM 16*1024*1024 + if (i >= ADIMLIM) + FEerror("Can't extend the string.", 0); + x->st.st_dim = i; + adjust_displaced(x, p - x->st.st_self); + } + x->st.st_self[x->st.st_fillp++] = c; + break; + + case smm_input: + case smm_probe: + case smm_concatenated: + case smm_string_input: + cannot_write(strm); + +#ifdef USER_DEFINED_STREAMS + case smm_user_defined: + {object *old_vs_base = vs_base; + object *old_vs_top = vs_top; + vs_base = vs_top; + vs_push(strm); + vs_push(code_char(c)); + super_funcall(strm->sm.sm_object1->str.str_self[2]); + vs_base = old_vs_base; + vs_top = old_vs_top; + break; + } + +#endif + default: + error("illegal stream mode"); + } + return(c); +} + +void +writestr_stream(s, strm) +char *s; +object strm; +{ + while (*s != '\0') + writec_stream(*s++, strm); +} + +void +flush_stream(object strm) { + object x; + +BEGIN: + switch (strm->sm.sm_mode) { + case smm_output: + case smm_io: + if (strm->sm.sm_fp == NULL) + closed_stream(strm); + fflush(strm->sm.sm_fp); + break; + case smm_socket: +#ifdef HAVE_NSOCKET + if (SOCKET_STREAM_FD(strm) >0) + gclFlushSocket(strm); + else +#endif + closed_stream(strm); + break; + case smm_synonym: + strm = symbol_value(strm->sm.sm_object0); + if (type_of(strm) != t_stream) + FEwrong_type_argument(sLstream, strm); + goto BEGIN; + + case smm_broadcast: + for (x = strm->sm.sm_object0; !endp(x); x = x->c.c_cdr) + flush_stream(x->c.c_car); + break; + + case smm_echo: + case smm_two_way: + strm = STREAM_OUTPUT_STREAM(strm); + goto BEGIN; + + + case smm_string_output: + break; + + case smm_input: + case smm_probe: + case smm_concatenated: + case smm_string_input: + FEerror("Cannot flush the stream ~S.", 1, strm); +#ifdef USER_DEFINED_STREAMS + case smm_user_defined: + {object *old_vs_base = vs_base; + object *old_vs_top = vs_top; + vs_base = vs_top; + vs_push(strm); + super_funcall(strm->sm.sm_object1->str.str_self[4]); + vs_base = old_vs_base; + vs_top = old_vs_top; + break; + } + +#endif + + default: + error("illegal stream mode"); + } +} + + +bool +stream_at_end(object strm) { +#define NON_CHAR -1000 + VOL int c = NON_CHAR; + +BEGIN: + switch (strm->sm.sm_mode) { + case smm_socket: + listen_stream(strm); + if (SOCKET_STREAM_FD(strm)>=0) + return(FALSE); + else return(TRUE); + case smm_io: + case smm_input: + if (strm->sm.sm_fp == NULL) + closed_stream(strm); + if (isatty(fileno((FILE *)strm->sm.sm_fp)) && !listen_stream(strm)) + return(feof(strm->sm.sm_fp) ? TRUE : FALSE); + {int prev_signals_allowed = signals_allowed; + AGAIN: + signals_allowed= sig_at_read; + c = kclgetc(strm->sm.sm_fp); + /* blocking getchar for sockets */ + /* if (c==EOF && (strm)->sm.sm_mode ==smm_socket) + c = getOneChar(strm->sm.sm_fp); */ + + + if (c == NON_CHAR) goto AGAIN; + signals_allowed=prev_signals_allowed;} + + if (xkclfeof(c,strm->sm.sm_fp)) + return(TRUE); + else { + if (c>=0) kclungetc(c, strm->sm.sm_fp); + return(FALSE); + } + + case smm_output: + return(FALSE); + + case smm_probe: + return(FALSE); + + case smm_synonym: + strm = symbol_value(strm->sm.sm_object0); + check_stream(strm); + goto BEGIN; + + case smm_broadcast: + return(FALSE); + + case smm_concatenated: + CONCATENATED: + if (endp(strm->sm.sm_object0)) + return(TRUE); + if (stream_at_end(strm->sm.sm_object0->c.c_car)) { + strm->sm.sm_object0 + = strm->sm.sm_object0->c.c_cdr; + goto CONCATENATED; + } else + return(FALSE); + + case smm_two_way: +#ifdef UNIX + if (strm == terminal_io) /**/ + flush_stream(terminal_io->sm.sm_object1); /**/ +#endif + strm = STREAM_INPUT_STREAM(strm); + goto BEGIN; + + case smm_echo: + strm = STREAM_INPUT_STREAM(strm); + goto BEGIN; + + case smm_string_input: + if (STRING_INPUT_STREAM_NEXT(strm)>= STRING_INPUT_STREAM_END(strm)) + return(TRUE); + else + return(FALSE); + + case smm_string_output: + return(FALSE); + +#ifdef USER_DEFINED_STREAMS + case smm_user_defined: + return(FALSE); +#endif + default: + error("illegal stream mode"); + return(FALSE); + } +} + + +#ifdef HAVE_SYS_IOCTL_H +#include +#endif + + +#ifdef LISTEN_USE_FCNTL +#include +#endif + +bool +listen_stream(object strm) { + +BEGIN: + + switch (strm->sm.sm_mode) { +#ifdef HAVE_NSOCKET + case smm_socket: + + if (SOCKET_STREAM_BUFFER(strm)->ust.ust_fillp>0) return TRUE; + + /* { */ + /* fd_set fds; */ + /* struct timeval tv; */ + /* FD_ZERO(&fds); */ + /* FD_SET(SOCKET_STREAM_FD(strm),&fds); */ + /* memset(&tv,0,sizeof(tv)); */ + /* return select(SOCKET_STREAM_FD(strm)+1,&fds,NULL,NULL,&tv)>0 ? TRUE : FALSE; */ + /* } */ + { int ch = getCharGclSocket(strm,Cnil); + if (ch == EOF) return FALSE; + else unreadc_stream(ch,strm); + return TRUE; + } +#endif + + case smm_input: + case smm_io: + +#ifdef HAVE_READLINE + if (rl_stream_p(strm->sm.sm_fp)) + return rl_pending_buffered_input_p(strm->sm.sm_fp); +#endif + if (strm->sm.sm_fp == NULL) + closed_stream(strm); + if (feof(strm->sm.sm_fp)) + return(FALSE); +#ifdef LISTEN_FOR_INPUT + LISTEN_FOR_INPUT(strm->sm.sm_fp); +#else +#ifdef LISTEN_USE_FCNTL + do { int c = 0; + FILE *fp = strm->sm.sm_fp; + int orig; + int res; + if (feof(fp)) return TRUE; + orig = fcntl(fileno(fp), F_GETFL); + if (! (orig & O_NONBLOCK ) ) { + res=fcntl(fileno(fp),F_SETFL,orig | O_NONBLOCK); + } + c = getc(fp); + if (! (orig & O_NONBLOCK ) ){ + fcntl(fileno(fp),F_SETFL,orig ); + } + if (c != EOF) + { + ungetc(c,fp); + return TRUE; + } + return FALSE; + } while (0); +#endif +#endif + return TRUE; + + case smm_synonym: + strm = symbol_value(strm->sm.sm_object0); + if (type_of(strm) != t_stream) + FEwrong_type_argument(sLstream, strm); + goto BEGIN; + + case smm_concatenated: + if (endp(strm->sm.sm_object0)) + return(FALSE); + strm = strm->sm.sm_object0->c.c_car; /* Incomplete! */ + goto BEGIN; + + case smm_two_way: + case smm_echo: + strm = STREAM_INPUT_STREAM(strm); + goto BEGIN; + + case smm_string_input: + if (STRING_INPUT_STREAM_NEXT(strm)< STRING_INPUT_STREAM_END(strm)) + return(TRUE); + else + return(FALSE); + + case smm_output: + case smm_probe: + case smm_broadcast: + case smm_string_output: + FEerror("Can't listen to ~S.", 1, strm); + return(FALSE); + default: + error("illegal stream mode"); + return(FALSE); + } +} + +int +file_position(strm) +object strm; +{ +BEGIN: + switch (strm->sm.sm_mode) { + case smm_input: + case smm_output: + case smm_io: + /* return(strm->sm.sm_int0); */ + if (strm->sm.sm_fp == NULL) + closed_stream(strm); + return(ftell(strm->sm.sm_fp)); + case smm_socket: + return -1; + + + case smm_string_output: + return(STRING_STREAM_STRING(strm)->st.st_fillp); + + case smm_synonym: + strm = symbol_value(strm->sm.sm_object0); + if (type_of(strm) != t_stream) + FEwrong_type_argument(sLstream, strm); + goto BEGIN; + + case smm_probe: + case smm_broadcast: + case smm_concatenated: + case smm_two_way: + case smm_echo: + case smm_string_input: + return(-1); + + default: + error("illegal stream mode"); + return(-1); + } +} + +int +file_position_set(strm, disp) +object strm; +int disp; +{ +BEGIN: + switch (strm->sm.sm_mode) { + case smm_socket: + return -1; + case smm_input: + case smm_output: + case smm_io: + + if (fseek(strm->sm.sm_fp, disp, 0) < 0) + return(-1); + /* strm->sm.sm_int0 = disp; */ + return(0); + + case smm_string_output: + if (disp < STRING_STREAM_STRING(strm)->st.st_fillp) { + STRING_STREAM_STRING(strm)->st.st_fillp = disp; + /* strm->sm.sm_int0 = disp; */ + } else { + disp -= STRING_STREAM_STRING(strm)->st.st_fillp; + while (disp-- > 0) + writec_stream(' ', strm); + } + return(0); + + case smm_synonym: + strm = symbol_value(strm->sm.sm_object0); + if (type_of(strm) != t_stream) + FEwrong_type_argument(sLstream, strm); + goto BEGIN; + + case smm_probe: + case smm_broadcast: + case smm_concatenated: + case smm_two_way: + case smm_echo: + case smm_string_input: + return(-1); + + default: + error("illegal stream mode"); + return(-1); + } +} + +static int +file_length(strm) +object strm; +{ +BEGIN: + switch (strm->sm.sm_mode) { + case smm_input: + case smm_output: + case smm_io: + + if (strm->sm.sm_fp == NULL) + closed_stream(strm); + return(file_len(strm->sm.sm_fp)); + + + + case smm_synonym: + strm = symbol_value(strm->sm.sm_object0); + if (type_of(strm) != t_stream) + FEwrong_type_argument(sLstream, strm); + goto BEGIN; + + case smm_socket: + case smm_probe: + case smm_broadcast: + case smm_concatenated: + case smm_two_way: + case smm_echo: + case smm_string_input: + case smm_string_output: + return(-1); + + default: + error("illegal stream mode"); + return(-1); + } +} + +int +file_column(object strm) { + int i; + object x; + +BEGIN: + switch (strm->sm.sm_mode) { + case smm_output: + case smm_io: + case smm_socket: + case smm_string_output: + return(STREAM_FILE_COLUMN(strm)); + + case smm_echo: + case smm_two_way: + strm=STREAM_OUTPUT_STREAM(strm); + goto BEGIN; + case smm_synonym: + strm = symbol_value(strm->sm.sm_object0); + if (type_of(strm) != t_stream) + FEwrong_type_argument(sLstream, strm); + goto BEGIN; + + + case smm_input: + case smm_probe: + case smm_string_input: + return(-1); + + case smm_concatenated: + if (endp(strm->sm.sm_object0)) + return(-1); + strm = strm->sm.sm_object0->c.c_car; + goto BEGIN; + + case smm_broadcast: + for (x = strm->sm.sm_object0; !endp(x); x = x->c.c_cdr) { + i = file_column(x->c.c_car); + if (i >= 0) + return(i); + } + return(-1); + +#ifdef USER_DEFINED_STREAMS + case smm_user_defined: /* not right but what is? */ + return(-1); + +#endif + default: + error("illegal stream mode"); + return(-1); + } +} + +void +load(const char *s) { + + object filename, strm, x; + vs_mark; + + if (user_match(s,strlen(s))) + return; + filename = make_simple_string(s); + vs_push(filename); + strm = open_stream(filename, smm_input, Cnil, sKerror); + vs_push(strm); + for (;;) { + preserving_whitespace_flag = FALSE; + detect_eos_flag = TRUE; + x = read_object_non_recursive(strm); + if (x == OBJNULL) + break; + vs_push(x); + ieval(x); + vs_popp; + } + close_stream(strm); + vs_reset; + +} + + + +LFD(Lmake_synonym_stream)() +{ + object x; + + check_arg(1); + check_type_sym(&vs_base[0]); + x = alloc_object(t_stream); + x->sm.sm_mode = (short)smm_synonym; + x->sm.sm_fp = NULL; + x->sm.sm_buffer = 0; + x->sm.sm_object0 = vs_base[0]; + x->sm.sm_object1 = OBJNULL; + x->sm.sm_int0 = x->sm.sm_int1 = 0; + vs_base[0] = x; +} + +LFD(Lmake_broadcast_stream)() +{ + object x; + int narg, i; + + narg = vs_top - vs_base; + for (i = 0; i < narg; i++) + if (type_of(vs_base[i]) != t_stream || + !output_stream_p(vs_base[i])) + cannot_write(vs_base[i]); + vs_push(Cnil); + for (i = narg; i > 0; --i) + stack_cons(); + x = alloc_object(t_stream); + x->sm.sm_mode = (short)smm_broadcast; + x->sm.sm_fp = NULL; + x->sm.sm_buffer = 0; + x->sm.sm_object0 = vs_base[0]; + x->sm.sm_object1 = OBJNULL; + x->sm.sm_int0 = x->sm.sm_int1 = 0; + vs_base[0] = x; +} + +LFD(Lmake_concatenated_stream)() +{ + object x; + int narg, i; + + narg = vs_top - vs_base; + for (i = 0; i < narg; i++) + if (type_of(vs_base[i]) != t_stream || + !input_stream_p(vs_base[i])) + cannot_read(vs_base[i]); + vs_push(Cnil); + for (i = narg; i > 0; --i) + stack_cons(); + x = alloc_object(t_stream); + x->sm.sm_mode = (short)smm_concatenated; + x->sm.sm_fp = NULL; + x->sm.sm_buffer = 0; + x->sm.sm_object0 = vs_base[0]; + x->sm.sm_object1 = OBJNULL; + x->sm.sm_int0 = x->sm.sm_int1 = 0; + vs_base[0] = x; +} + +LFD(Lmake_two_way_stream)() +{ + check_arg(2); + + if (type_of(vs_base[0]) != t_stream || + !input_stream_p(vs_base[0])) + cannot_read(vs_base[0]); + if (type_of(vs_base[1]) != t_stream || + !output_stream_p(vs_base[1])) + cannot_write(vs_base[1]); + vs_base[0] = make_two_way_stream(vs_base[0], vs_base[1]); + vs_popp; +} + +LFD(Lmake_echo_stream)() +{ + check_arg(2); + + if (type_of(vs_base[0]) != t_stream || + !input_stream_p(vs_base[0])) + cannot_read(vs_base[0]); + if (type_of(vs_base[1]) != t_stream || + !output_stream_p(vs_base[1])) + cannot_write(vs_base[1]); + vs_base[0] = make_echo_stream(vs_base[0], vs_base[1]); + vs_popp; +} + +@(static defun make_string_input_stream (strng &o istart iend) + int s, e; +@ + check_type_string(&strng); + if (istart == Cnil) + s = 0; + else if (type_of(istart) != t_fixnum) + goto E; + else + s = fix(istart); + if (iend == Cnil) + e = strng->st.st_fillp; + else if (type_of(iend) != t_fixnum) + goto E; + else + e = fix(iend); + if (s < 0 || e > strng->st.st_fillp || s > e) + goto E; + @(return `make_string_input_stream(strng, s, e)`) + +E: + FEerror("~S and ~S are illegal as :START and :END~%\ +for the string ~S.", + 3, istart, iend, strng); +@) + +static void +FFN(Lmake_string_output_stream)() +{ + check_arg(0); + vs_push(make_string_output_stream(64)); +} + +LFD(Lget_output_stream_string)() +{ + check_arg(1); + + if (type_of(vs_base[0]) != t_stream || + (enum smmode)vs_base[0]->sm.sm_mode != smm_string_output) + FEerror("~S is not a string-output stream.", 1, vs_base[0]); + vs_base[0] = get_output_stream_string(vs_base[0]); +} + +/* + (SI:OUTPUT-STREAM-STRING string-output-stream) + + extracts the string associated with the given + string-output-stream. +*/ +LFD(siLoutput_stream_string)() +{ + check_arg(1); + if (type_of(vs_base[0]) != t_stream || + (enum smmode)vs_base[0]->sm.sm_mode != smm_string_output) + FEerror("~S is not a string-output stream.", 1, vs_base[0]); + vs_base[0] = vs_base[0]->sm.sm_object0; +} + +LFD(Lstreamp)() +{ + check_arg(1); + + if (type_of(vs_base[0]) == t_stream) + vs_base[0] = Ct; + else + vs_base[0] = Cnil; +} + +LFD(Linput_stream_p)() +{ + check_arg(1); + + check_type_stream(&vs_base[0]); + if (input_stream_p(vs_base[0])) + vs_base[0] = Ct; + else + vs_base[0] = Cnil; +} + +LFD(Loutput_stream_p)() +{ + check_arg(1); + + check_type_stream(&vs_base[0]); + if (output_stream_p(vs_base[0])) + vs_base[0] = Ct; + else + vs_base[0] = Cnil; +} + +LFD(Lstream_element_type)() +{ + check_arg(1); + + check_type_stream(&vs_base[0]); + vs_base[0] = stream_element_type(vs_base[0]); +} + +@(defun close (strm &key abort) +@ + check_type_stream(&strm); + close_stream(strm); + @(return Ct) +@) + +@(static defun open (filename + &key (direction sKinput) + (element_type sLstring_char) + (if_exists Cnil iesp) + (if_does_not_exist Cnil idnesp) + &aux strm) + enum smmode smm=0; +@ + check_type_or_pathname_string_symbol_stream(&filename); + filename = coerce_to_namestring(filename); + if (direction == sKinput) { + smm = smm_input; + if (!idnesp) + if_does_not_exist = sKerror; + } else if (direction == sKoutput) { + smm = smm_output; + if (!iesp) + if_exists = sKnew_version; + if (!idnesp) { + if (if_exists == sKoverwrite || + if_exists == sKappend) + if_does_not_exist = sKerror; + else + if_does_not_exist = sKcreate; + } + } else if (direction == sKio) { + smm = smm_io; + if (!iesp) + if_exists = sKnew_version; + if (!idnesp) { + if (if_exists == sKoverwrite || + if_exists == sKappend) + if_does_not_exist = sKerror; + else + if_does_not_exist = sKcreate; + } + } else if (direction == sKprobe) { + smm = smm_probe; + if (!idnesp) + if_does_not_exist = Cnil; + } else + FEerror("~S is an illegal DIRECTION for OPEN.", + 1, direction); + strm = open_stream(filename, smm, if_exists, if_does_not_exist); + if (type_of(strm) == t_stream) + strm->sm.sm_object0 = element_type; + @(return strm) +@) + +@(defun file_position (file_stream &o position) + int i=0; +@ + check_type_stream(&file_stream); + if (position == Cnil) { + i = file_position(file_stream); + if (i < 0) + @(return Cnil) + @(return `make_fixnum(i)`) + } else { + if (position == sKstart) + i = 0; + else if (position == sKend) + i = file_length(file_stream); + else if (type_of(position) != t_fixnum || + (i = fix((position))) < 0) + FEerror("~S is an illegal file position~%\ +for the file-stream ~S.", + 2, position, file_stream); + if (file_position_set(file_stream, i) < 0) + @(return Cnil) + @(return Ct) + } +@) + +LFD(Lfile_length)() +{ + int i; + + check_arg(1); + check_type_stream(&vs_base[0]); + i = file_length(vs_base[0]); + if (i < 0) + vs_base[0] = Cnil; + else + vs_base[0] = make_fixnum(i); +} + +object sSAload_pathnameA; +DEFVAR("*COLLECT-BINARY-MODULES*",sSAcollect_binary_modulesA,SI,sLnil,""); +DEFVAR("*BINARY-MODULES*",sSAbinary_modulesA,SI,Cnil,""); + +@(static defun load (pathname + &key (verbose `symbol_value(sLAload_verboseA)`) + print + (if_does_not_exist sKerror) + &aux pntype fasl_filename lsp_filename filename + defaults strm stdoutput x + package) + bds_ptr old_bds_top; + int i; + object strm1; +@ + check_type_or_pathname_string_symbol_stream(&pathname); + pathname = coerce_to_pathname(pathname); + defaults = symbol_value(Vdefault_pathname_defaults); + defaults = coerce_to_pathname(defaults); + pathname = merge_pathnames(pathname, defaults, sKnewest); + pntype = pathname->pn.pn_type; + filename = coerce_to_namestring(pathname); + if (user_match(filename->st.st_self,filename->st.st_fillp)) + @(return Cnil) + old_bds_top=bds_top; + if (pntype == Cnil || pntype == sKwild || + (type_of(pntype) == t_string && +#ifdef UNIX + string_eq(pntype, FASL_string))) { +#endif +#ifdef AOSVS + +#endif + pathname->pn.pn_type = FASL_string; + fasl_filename = coerce_to_namestring(pathname); + } + if (pntype == Cnil || pntype == sKwild || + (type_of(pntype) == t_string && +#ifdef UNIX + string_eq(pntype, LSP_string))) { +#endif +#ifdef AOSVS + +#endif + pathname->pn.pn_type = LSP_string; + lsp_filename = coerce_to_namestring(pathname); + } + if (fasl_filename != Cnil && file_exists(fasl_filename)) { + if (verbose != Cnil) { + SETUP_PRINT_DEFAULT(fasl_filename); + if (file_column(PRINTstream) != 0) + write_str("\n"); + write_str("Loading "); + PRINTescape = FALSE; + write_object(fasl_filename, 0); + write_str("\n"); + CLEANUP_PRINT_DEFAULT; + flush_stream(PRINTstream); + } + package = symbol_value(sLApackageA); + bds_bind(sLApackageA, package); + bds_bind(sSAload_pathnameA,fasl_filename); + if (sSAcollect_binary_modulesA->s.s_dbind==Ct) { + object _x=sSAbinary_modulesA->s.s_dbind; + object _y=Cnil; + while (_x!=Cnil) { + _y=_x; + _x=_x->c.c_cdr; + } + if (_y==Cnil) + sSAbinary_modulesA->s.s_dbind=make_cons(fasl_filename,Cnil); + else + _y->c.c_cdr=make_cons(fasl_filename,Cnil); + } + i = fasload(fasl_filename); + if (print != Cnil) { + SETUP_PRINT_DEFAULT(Cnil); + vs_top = PRINTvs_top; + if (file_column(PRINTstream) != 0) + write_str("\n"); + write_str("Fasload successfully ended."); + write_str("\n"); + CLEANUP_PRINT_DEFAULT; + flush_stream(PRINTstream); + } + bds_unwind(old_bds_top); + if (verbose != Cnil) { + SETUP_PRINT_DEFAULT(fasl_filename); + if (file_column(PRINTstream) != 0) + write_str("\n"); + write_str("Finished loading "); + PRINTescape = FALSE; + write_object(fasl_filename, 0); + write_str("\n"); + CLEANUP_PRINT_DEFAULT; + flush_stream(PRINTstream); + } + @(return `make_fixnum(i)`) + } + if (lsp_filename != Cnil && file_exists(lsp_filename)) { + filename = lsp_filename; + } + if (if_does_not_exist != Cnil) + if_does_not_exist = sKerror; + strm1 = strm + = open_stream(filename, smm_input, Cnil, if_does_not_exist); + if (strm == Cnil) + @(return Cnil) + if (verbose != Cnil) { + SETUP_PRINT_DEFAULT(filename); + if (file_column(PRINTstream) != 0) + write_str("\n"); + write_str("Loading "); + PRINTescape = FALSE; + write_object(filename, 0); + write_str("\n"); + CLEANUP_PRINT_DEFAULT; + flush_stream(PRINTstream); + } + package = symbol_value(sLApackageA); + bds_bind(sSAload_pathnameA,pathname); + bds_bind(sLApackageA, package); + bds_bind(sLAstandard_inputA, strm); + frs_push(FRS_PROTECT, Cnil); + if (nlj_active) { + close_stream(strm1); + nlj_active = FALSE; + frs_pop(); + bds_unwind(old_bds_top); + unwind(nlj_fr, nlj_tag); + } + for (;;) { + preserving_whitespace_flag = FALSE; + detect_eos_flag = TRUE; + x = read_object_non_recursive(strm); + if (x == OBJNULL) + break; + { + object *base = vs_base, *top = vs_top, *lex = lex_env; + object xx; + + lex_new(); + eval(x); + xx = vs_base[0]; + lex_env = lex; + vs_top = top; + vs_base = base; + x = xx; + } + if (print != Cnil) { + SETUP_PRINT_DEFAULT(x); + write_object(x, 0); + write_str("\n"); + CLEANUP_PRINT_DEFAULT; + flush_stream(PRINTstream); + } + } + close_stream(strm); + frs_pop(); + bds_unwind(old_bds_top); + if (verbose != Cnil) { + SETUP_PRINT_DEFAULT(filename); + if (file_column(PRINTstream) != 0) + write_str("\n"); + write_str("Finished loading "); + PRINTescape = FALSE; + write_object(filename, 0); + write_str("\n"); + CLEANUP_PRINT_DEFAULT; + flush_stream(PRINTstream); + } + @(return Ct) +@) + +static void +FFN(siLget_string_input_stream_index)() +{ + check_arg(1); + check_type_stream(&vs_base[0]); + if ((enum smmode)vs_base[0]->sm.sm_mode != smm_string_input) + FEerror("~S is not a string-input stream.", 1, vs_base[0]); + vs_base[0] = make_fixnum(STRING_INPUT_STREAM_NEXT(vs_base[0])); +} + +DEFUN_NEW("TERMINAL-INPUT-STREAM-P",object,fSterminal_input_stream_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { + RETURN1(type_of(x)==t_stream && x->sm.sm_mode==smm_input && x->sm.sm_fp && isatty(fileno((FILE *)x->sm.sm_fp)) ? Ct : Cnil); +} + +LFD(siLmake_string_output_stream_from_string)() +{ + object strng, strm; + + check_arg(1); + strng = vs_base[0]; + if (type_of(strng) != t_string || !strng->st.st_hasfillp) + FEerror("~S is not a string with a fill-pointer.", 1, strng); + strm = alloc_object(t_stream); + strm->sm.sm_mode = (short)smm_string_output; + strm->sm.sm_fp = NULL; + strm->sm.sm_buffer = 0; + STRING_STREAM_STRING(strm) = strng; + strm->sm.sm_object1 = OBJNULL; + /* strm->sm.sm_int0 = strng->st.st_fillp; */ + STREAM_FILE_COLUMN(strm) = 0; + vs_base[0] = strm; +} + +LFD(siLcopy_stream)() +{ + object in, out; + + check_arg(2); + check_type_stream(&vs_base[0]); + check_type_stream(&vs_base[1]); + in = vs_base[0]; + out = vs_base[1]; + while (!stream_at_end(in)) + writec_stream(readc_stream(in), out); + flush_stream(out); + vs_base[0] = Ct; + vs_popp; +#ifdef AOSVS + +#endif +} + +/* static void */ +/* too_long_file_name(fn) */ +/* object fn; */ +/* { */ +/* FEerror("~S is a too long file name.", 1, fn); */ +/* } */ + +static void +cannot_open(fn) +object fn; +{ + FEerror("Cannot open the file ~A.", 1, fn); +} + +static void +cannot_create(fn) +object fn; +{ + FEerror("Cannot create the file ~A.", 1, fn); +} + +static void +cannot_read(strm) +object strm; +{ + FEerror("Cannot read the stream ~S.", 1, strm); +} + +static void +cannot_write(strm) +object strm; +{ + FEerror("Cannot write to the stream ~S.", 1, strm); +} + +#ifdef USER_DEFINED_STREAMS +/* more support for user defined streams */ +static void +FFN(siLuser_stream_state)() +{ + check_arg(1); + + if(vs_base[0]->sm.sm_object1) + vs_base[0] = vs_base[0]->sm.sm_object1->str.str_self[0]; + else + FEerror("sLtream data NULL ~S", 1, vs_base[0]); +} +#endif + +static void +closed_stream(strm) +object strm; +{ + if (!GET_STREAM_FLAG(strm,gcl_sm_had_error)) + { + SET_STREAM_FLAG(strm,gcl_sm_had_error,1); + FEerror("The stream ~S is already closed.", 1, strm); + } + +} + + + +/* returns a stream with which one can safely do fwrite to the x->sm.sm_fp + or nil. + */ + + +/* coerce stream to one so that x->sm.sm_fp is suitable for fread and fwrite, + Return nil if this is not possible. + */ + +object +coerce_stream(strm,out) +object strm; +int out; +{ + BEGIN: + if (type_of(strm) != t_stream) + FEwrong_type_argument(sLstream, strm); + switch (strm->sm.sm_mode){ + case smm_synonym: + strm = symbol_value(strm->sm.sm_object0); + if (type_of(strm) != t_stream) + FEwrong_type_argument(sLstream, strm); + goto BEGIN; + + case smm_two_way: + case smm_echo: + if (out)strm = STREAM_OUTPUT_STREAM(strm); + else strm = STREAM_INPUT_STREAM(strm); + goto BEGIN; + case smm_output: + if (!out) cannot_read(strm); + break; + case smm_input: + if (out) cannot_write(strm); + break; + case smm_io: + /* case smm_socket: */ + break; + + default: + strm=Cnil; + } + if (strm!=Cnil + && (strm->sm.sm_fp == NULL)) + closed_stream(strm); + return(strm); +} + +static void +FFN(siLfp_output_stream)() +{check_arg(1); + vs_base[0]=coerce_stream(vs_base[0],1); +} + +static void +FFN(siLfp_input_stream)() +{check_arg(1); + vs_base[0]=coerce_stream(vs_base[0],0); +} + + +@(static defun fwrite (vector start count stream) + unsigned char *p; + int n,beg; +@ + stream=coerce_stream(stream,1); + if (stream==Cnil) @(return Cnil); + p = vector->ust.ust_self; + beg = ((type_of(start)==t_fixnum) ? fix(start) : 0); + n = ((type_of(count)==t_fixnum) ? fix(count) : (vector->st.st_fillp - beg)); + if (fwrite(p+beg,1,n,stream->sm.sm_fp)) @(return Ct); + @(return Cnil); +@) + +@(static defun fread (vector start count stream) + char *p; + int n,beg; +@ + stream=coerce_stream(stream,0); + if (stream==Cnil) @(return Cnil); + p = vector->st.st_self; + beg = ((type_of(start)==t_fixnum) ? fix(start) : 0); + n = ((type_of(count)==t_fixnum) ? fix(count) : (vector->st.st_fillp - beg)); + if ((n=SAFE_FREAD(p+beg,1,n,stream->sm.sm_fp))) + @(return `make_fixnum(n)`); + @(return Cnil); +@) + +#ifdef HAVE_NSOCKET + +#ifdef DODEBUG +#define dprintf(s,arg) \ + do {fprintf(stderr,s,arg); \ + fflush(stderr); }\ + while(0) +#else +#define dprintf(s,arg) +#endif + + + +/* + putCharGclSocket(strm,ch) -- put one character to a socket + stream. + Results: + Side Effects: The buffer may be filled, and the fill pointer + of the buffer may be changed. + */ +static void +putCharGclSocket(strm,ch) + object strm; + int ch; +{ + object bufp = SOCKET_STREAM_BUFFER(strm); + + AGAIN: + if (bufp->ust.ust_fillp < bufp->ust.ust_dim) { + dprintf("getchar returns (%c)\n",bufp->ust.ust_self[-1+(bufp->ust.ust_fillp)]); + bufp->ust.ust_self[(bufp->ust.ust_fillp)++]=ch; + return; + } + else { + gclFlushSocket(strm); + goto AGAIN; + } +} + +static void +gclFlushSocket(strm) + object strm; + +{ + int fd = SOCKET_STREAM_FD(strm); + object bufp = SOCKET_STREAM_BUFFER(strm); + int i=0; + int err; + int wrote; + if (!GET_STREAM_FLAG(strm,gcl_sm_output) + || GET_STREAM_FLAG(strm,gcl_sm_had_error)) + return; +#define AMT_TO_WRITE 500 + while(i< bufp->ust.ust_fillp) { + wrote =TcpOutputProc ( fd, + &(bufp->st.st_self[i]), + bufp->ust.ust_fillp-i > AMT_TO_WRITE ? AMT_TO_WRITE : bufp->ust.ust_fillp-i, + &err +#ifdef __MINGW32__ + , TRUE /* Wild guess as to whether it should block or not */ +#endif +); + if (wrote < 0) { + SET_STREAM_FLAG(strm,gcl_sm_had_error,1); + close_stream(strm); + FEerror("error writing to socket: errno= ~a",1,make_fixnum(err)); + + } + i+= wrote; + } + bufp->ust.ust_fillp=0; +} + +static +object +make_socket_stream(fd,mode,server,host,port,async) +int fd; +enum gcl_sm_flags mode; +object server; +object host; +object port; +object async; +{ + object x; + if (fd < 0 ) + { + FEerror("Could not connect",0); + } + x = alloc_object(t_stream); + x->sm.sm_mode = smm_socket; + x->sm.sm_buffer = 0; + x->sm.sm_object0 = list(3,server,host,port); + x->sm.sm_object1 = 0; + x->sm.sm_int0 = x->sm.sm_int1 = 0; + x->sm.sm_flags=0; + SOCKET_STREAM_FD(x)= fd; + SET_STREAM_FLAG(x,mode,1); + SET_STREAM_FLAG(x,gcl_sm_tcp_async,(async!=Cnil)); + /* + if (mode == gcl_sm_output) + { fp=fdopen(fd,(mode==gcl_sm_input ? "r" : "w")); + if (fp==NULL) FEerror("Could not connect",0); + x->sm.sm_fp = fp; + setup_stream_buffer(x); + } else + */ + { + object buffer; + x->sm.sm_fp = NULL; + buffer=alloc_simple_string((BUFSIZ < 4096 ? 4096 : BUFSIZ)); + SOCKET_STREAM_BUFFER(x) =buffer; + buffer->ust.ust_self = alloc_contblock(buffer->st.st_dim); + buffer->ust.ust_fillp = 0; + } + return x; +} + +static object +maccept(object x) { + + int fd; + socklen_t n; + struct sockaddr_in addr; + object server,host,port; + + if (type_of(x) != t_stream) + FEerror("~S is not a steam~%",1,x); + if (x->sm.sm_mode!=smm_two_way) + FEerror("~S is not a two-way steam~%",1,x); + fd=accept(SOCKET_STREAM_FD(STREAM_INPUT_STREAM(x)),(struct sockaddr *)&addr,&n); + if (fd <0) { + FEerror("Error ~S on accepting connection to ~S~%",2,make_simple_string(strerror(errno)),x); + x=Cnil; + } else { + server=STREAM_INPUT_STREAM(x)->sm.sm_object0->c.c_car; + host=STREAM_INPUT_STREAM(x)->sm.sm_object0->c.c_cdr->c.c_car; + port=STREAM_INPUT_STREAM(x)->sm.sm_object0->c.c_cdr->c.c_cdr->c.c_car; + x = make_two_way_stream + (make_socket_stream(fd,gcl_sm_input,server,host,port,Cnil), + make_socket_stream(fd,gcl_sm_output,server,host,port,Cnil)); + } + return x; + +} + +#ifdef BSD +#include +#include +#include + +#if defined(DARWIN) +#define on_exit(a,b) +#else +static void +rmc(int e,void *pid) { + + kill((long)pid,SIGTERM); + +} +#endif +#endif + +@(static defun socket (port &key host server async myaddr myport daemon) + /* + HOST is a string then connection is made to that + ip or domain address. + SERVER A function to call if this is to be a server + + ASYNC socket returned immideiately. read or flush + will block till open if in non blocking mode + MYADDR client's ip address. Useful if have several + net interfaces + MYPORT port to use on client side + */ +int fd; +int isServer = 0; +int inPort; +char buf1[500]; +char buf2[500]; +char *myaddrPtr=buf1,*hostPtr=buf2; +object x=Cnil; +@ + if (type_of(host) == t_string) { + hostPtr=lisp_copy_to_null_terminated(host,hostPtr,sizeof(buf1)); + } else { hostPtr = NULL; } + + if (fLfunctionp(server) == Ct) { + isServer=1; + } + + if (myaddr != Cnil) { + myaddrPtr=lisp_copy_to_null_terminated(myaddr,myaddrPtr,sizeof(buf2)); + } else { myaddrPtr = NULL; } + if (isServer == 0 && hostPtr == NULL) { + FEerror("You must supply at least one of :host hostname or :server function",0); + } + Iis_fixnum(port); + inPort = (myport == Cnil ? 0 : fix(Iis_fixnum(myport))); + +#ifdef BSD + if (isServer && daemon != Cnil) { + + long pid,i; + struct rlimit r; + struct sigaction sa; + + sa.sa_handler=SIG_IGN; + sa.sa_flags=SA_NOCLDWAIT; + sigemptyset(&sa.sa_mask); + + sigaction(SIGCHLD,&sa,NULL); + + switch((pid=pfork())) { + case -1: + FEerror("Cannot fork", 0); + break; + case 0: + + if (setsid()<0) + FEerror("setsid error", 0); + + if (daemon == sKpersistent) + switch(pfork()) { + case -1: + FEerror("daemon fork error", 0); + break; + case 0: + break; + default: + exit(0); + break; + } + + memset(&r,0,sizeof(r)); + if (getrlimit(RLIMIT_NOFILE,&r)) + FEerror("Cannot get resourse usage",0); + + for (i=0;i0) { + + y=maccept(x); + + sigaction(SIGCHLD,&sa,NULL); + + switch((pid=pfork())) { + case 0: + ifuncall1(server,y); + exit(0); + break; + case -1: + abort(); + break; + default: + close_stream(y); + break; + } + + } + } + break; + default: + if (daemon != sKpersistent) { + on_exit(rmc,(void *)pid); + x=make_fixnum(pid); + } else + x=Cnil; + break; + } + + } else + +#endif + + { + fd = CreateSocket(fix(port),hostPtr,isServer,myaddrPtr,inPort,(async!=Cnil)); + + x = make_two_way_stream + (make_socket_stream(fd,gcl_sm_input,server,host,port,async), + make_socket_stream(fd,gcl_sm_output,server,host,port,async)); + + } + + @(return `x`); + +@) + +DEF_ORDINARY("MYADDR",sKmyaddr,KEYWORD,""); +DEF_ORDINARY("MYPORT",sKmyport,KEYWORD,""); +DEF_ORDINARY("ASYNC",sKasync,KEYWORD,""); +DEF_ORDINARY("HOST",sKhost,KEYWORD,""); +DEF_ORDINARY("SERVER",sKserver,KEYWORD,""); +DEF_ORDINARY("DAEMON",sKdaemon,KEYWORD,""); +DEF_ORDINARY("PERSISTENT",sKpersistent,KEYWORD,""); +DEF_ORDINARY("SOCKET",sSsocket,SI,""); + + +@(static defun accept (x) +@ + x=maccept(x); + @(return `x`); +@) + +#endif /* HAVE_NSOCKET */ + +object standard_io; +DEFVAR("*STANDARD-INPUT*",sLAstandard_inputA,LISP,(gcl_init_file(),standard_io),""); +DEFVAR("*STANDARD-OUTPUT*",sLAstandard_outputA,LISP,standard_io,""); +DEFVAR("*ERROR-OUTPUT*",sLAerror_outputA,LISP,standard_io,""); +DEFVAR("*TERMINAL-IO*",sLAterminal_ioA,LISP,terminal_io,""); +DEFVAR("*QUERY-IO*",sLAquery_ioA,LISP, + (standard_io->sm.sm_object0 = sLAterminal_ioA, + standard_io),""); +DEFVAR("*DEBUG-IO*",sLAdebug_ioA,LISP,standard_io,""); +DEFVAR("*TRACE-OUTPUT*",sLAtrace_outputA,LISP,standard_io,""); + + +void +gcl_init_file(void) +{ + object standard_input; + object standard_output; + object standard; + object x; + standard_input = alloc_object(t_stream); + standard_input->sm.sm_mode = (short)smm_input; + standard_input->sm.sm_fp = stdin; + standard_input->sm.sm_buffer = 0; + standard_input->sm.sm_object0 = sLstring_char; + standard_input->sm.sm_object1 +#ifdef UNIX + = make_simple_string("stdin"); +#endif + standard_input->sm.sm_int0 = 0; /* unused */ + standard_input->sm.sm_int1 = 0; /* unused */ + + standard_output = alloc_object(t_stream); + standard_output->sm.sm_mode = (short)smm_output; + standard_output->sm.sm_fp = stdout; + standard_output->sm.sm_buffer = 0; + standard_output->sm.sm_object0 = sLstring_char; + standard_output->sm.sm_object1 +#ifdef UNIX + = make_simple_string("stdout"); +#endif + standard_output->sm.sm_int0 = 0; /* unused */ + STREAM_FILE_COLUMN(standard_output) = 0; + + terminal_io = standard + = make_two_way_stream(standard_input, standard_output); + enter_mark_origin(&terminal_io); + + x = alloc_object(t_stream); + x->sm.sm_mode = (short)smm_synonym; + x->sm.sm_fp = NULL; + x->sm.sm_buffer = 0; + x->sm.sm_object0 = sLAterminal_ioA; + x->sm.sm_object1 = OBJNULL; + x->sm.sm_int0 = x->sm.sm_int1 = 0; /* unused */ + standard_io = x; + enter_mark_origin(&standard_io); + +} + +DEFVAR("*IGNORE-EOF-ON-TERMINAL-IO*",sSAignore_eof_on_terminal_ioA,SI,Cnil,""); +DEFVAR("*LOAD-PATHNAME*",sSAload_pathnameA,SI,Cnil,""); +DEFVAR("*LOAD-VERBOSE*",sLAload_verboseA,LISP,Ct,""); + +DEF_ORDINARY("ABORT",sKabort,KEYWORD,""); +DEF_ORDINARY("APPEND",sKappend,KEYWORD,""); +DEF_ORDINARY("CREATE",sKcreate,KEYWORD,""); +DEF_ORDINARY("DEFAULT",sKdefault,KEYWORD,""); +DEF_ORDINARY("DIRECTION",sKdirection,KEYWORD,""); +DEF_ORDINARY("ELEMENT-TYPE",sKelement_type,KEYWORD,""); +DEF_ORDINARY("ERROR",sKerror,KEYWORD,""); +DEF_ORDINARY("IF-DOES-NOT-EXIST",sKif_does_not_exist,KEYWORD,""); +DEF_ORDINARY("IF-EXISTS",sKif_exists,KEYWORD,""); +DEF_ORDINARY("INPUT",sKinput,KEYWORD,""); +DEF_ORDINARY("IO",sKio,KEYWORD,""); +DEF_ORDINARY("NEW-VERSION",sKnew_version,KEYWORD,""); +DEF_ORDINARY("OUTPUT",sKoutput,KEYWORD,""); +DEF_ORDINARY("OVERWRITE",sKoverwrite,KEYWORD,""); +DEF_ORDINARY("PRINT",sKprint,KEYWORD,""); +DEF_ORDINARY("PROBE",sKprobe,KEYWORD,""); +DEF_ORDINARY("RENAME",sKrename,KEYWORD,""); +DEF_ORDINARY("RENAME-AND-DELETE",sKrename_and_delete,KEYWORD,""); +DEF_ORDINARY("SET-DEFAULT-PATHNAME",sKset_default_pathname,KEYWORD,""); +DEF_ORDINARY("SUPERSEDE",sKsupersede,KEYWORD,""); +DEF_ORDINARY("VERBOSE",sKverbose,KEYWORD,""); + + + + +void +gcl_init_file_function() +{ + + +#ifdef UNIX + FASL_string = make_simple_string("o"); + make_si_constant("*EOF*",make_fixnum(EOF)); +#endif +#ifdef AOSVS + +#endif + enter_mark_origin(&FASL_string); +#ifdef UNIX + LSP_string = make_simple_string("lsp"); +#endif +#ifdef AOSVS + +#endif + enter_mark_origin(&LSP_string); + make_si_function("FP-INPUT-STREAM", siLfp_input_stream); + make_si_function("FP-OUTPUT-STREAM", siLfp_output_stream); + + make_function("MAKE-SYNONYM-STREAM", Lmake_synonym_stream); + make_function("MAKE-BROADCAST-STREAM", Lmake_broadcast_stream); + make_function("MAKE-CONCATENATED-STREAM", + Lmake_concatenated_stream); + make_function("MAKE-TWO-WAY-STREAM", Lmake_two_way_stream); + make_function("MAKE-ECHO-STREAM", Lmake_echo_stream); + make_function("MAKE-STRING-INPUT-STREAM", + Lmake_string_input_stream); + make_function("MAKE-STRING-OUTPUT-STREAM", + Lmake_string_output_stream); + make_function("GET-OUTPUT-STREAM-STRING", + Lget_output_stream_string); + + make_si_function("OUTPUT-STREAM-STRING", siLoutput_stream_string); + make_si_function("FWRITE",Lfwrite); + make_si_function("FREAD",Lfread); +#ifdef HAVE_NSOCKET + make_si_function("SOCKET",Lsocket); + make_si_function("ACCEPT",Laccept); +#endif + make_function("STREAMP", Lstreamp); + make_function("INPUT-STREAM-P", Linput_stream_p); + make_function("OUTPUT-STREAM-P", Loutput_stream_p); + make_function("STREAM-ELEMENT-TYPE", Lstream_element_type); + make_function("CLOSE", Lclose); + + make_function("OPEN", Lopen); + + make_function("FILE-POSITION", Lfile_position); + make_function("FILE-LENGTH", Lfile_length); + + make_function("LOAD", Lload); + + make_si_function("GET-STRING-INPUT-STREAM-INDEX", + siLget_string_input_stream_index); + make_si_function("MAKE-STRING-OUTPUT-STREAM-FROM-STRING", + siLmake_string_output_stream_from_string); + make_si_function("COPY-STREAM", siLcopy_stream); + +#ifdef USER_DEFINED_STREAMS + make_si_function("USER-STREAM-STATE", siLuser_stream_state); +#endif + +#ifdef HAVE_READLINE + gcl_init_readline_function(); +#endif +} + + +object +read_fasl_data(const char *str) { + + object faslfile, data; +#ifndef SEEK_TO_END_OFILE +#if defined(BSD) && defined(UNIX) + FILE *fp; + int i; +#ifdef HAVE_AOUT + struct exec header; +#endif +#endif +#ifdef HAVE_FILEHDR + struct filehdr fileheader; +#endif +#ifdef E15 + struct exec header; +#endif +#endif + vs_mark; + + faslfile = make_simple_string(str); + vs_push(faslfile); + faslfile = open_stream(faslfile, smm_input, Cnil, sKerror); + vs_push(faslfile); + +#ifdef SEEK_TO_END_OFILE + SEEK_TO_END_OFILE(faslfile->sm.sm_fp); +#else + +#ifdef BSD + fp = faslfile->sm.sm_fp; + fread(&header, sizeof(header), 1, fp); + fseek(fp, + header.a_text+header.a_data+ + header.a_syms+header.a_trsize+header.a_drsize, + 1); + fread(&i, sizeof(i), 1, fp); + fseek(fp, i - sizeof(i), 1); +#endif + +#ifdef HAVE_FILEHDR + fp = faslfile->sm.sm_fp; + fread(&fileheader, sizeof(fileheader), 1, fp); + fseek(fp, + fileheader.f_symptr+fileheader.f_nsyms*SYMESZ, + 0); + fread(&i, sizeof(i), 1, fp); + fseek(fp, i - sizeof(i), 1); + while ((i = getc(fp)) == 0) + ; + ungetc(i, fp); +#endif + +#ifdef E15 + fp = faslfile->sm.sm_fp; + fread(&header, sizeof(header), 1, fp); + fseek(fp, + header.a_text+header.a_data+ + header.a_syms+header.a_trsize+header.a_drsize, + 1); +#endif +#endif + data = read_fasl_vector(faslfile); + + vs_push(data); + close_stream(faslfile); + vs_reset; + return(data); +} diff --git a/o/firstfile.c b/o/firstfile.c new file mode 100755 index 0000000..4cc5537 --- /dev/null +++ b/o/firstfile.c @@ -0,0 +1,34 @@ +/* Mark beginning of data space to dump as pure, for GNU Emacs. + Copyright (C) 1985 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + + +#include "config.h" + +/* See comments in lastfile.c. */ +char my_begdata[] = "Beginning of Emacs initialized data"; +char my_begbss[1]; /* Do not initialize this variable. */ +static char _my_begbss[1]; +char * my_begbss_static = _my_begbss; + +/* Add a dummy reference to ensure emacs.obj is linked in. */ +#ifdef emacs +extern int initialized; +static int * dummy = &initialized; +#endif diff --git a/o/fix-structref.el b/o/fix-structref.el new file mode 100755 index 0000000..33c546a --- /dev/null +++ b/o/fix-structref.el @@ -0,0 +1,17 @@ +(defun fix-struct-ref () + (interactive) + (while (re-search-forward "->\\([a-z]+\\)+[.]\\([A-Z][a-zA-Z]+\\)") + (sit-for 0) + (cond ((y-or-n-p "do it?") + (downcase-region (match-beginning 2) (match-end 2)) + (let ((xx (buffer-substring (match-beginning 2) (match-end 2))) + (tem (buffer-substring (match-beginning 1) (match-end 1)))) + (delete-region (match-beginning 2) (match-end 2)) + (goto-char (match-beginning 2)) + (insert tem "_") + (let ((u (assoc xx '(("bind" . "dbind") + ("body" . "self") + )))) + (insert (or (cdr u) xx)))))))) + + diff --git a/o/format.c b/o/format.c new file mode 100755 index 0000000..08544b4 --- /dev/null +++ b/o/format.c @@ -0,0 +1,2298 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +/* + format.c +*/ + +#include "include.h" + +static int +fmt_thousand(int,int,bool,bool,int); + +static void +fmt_exponent1(int); + +static void +fmt_write_numeral(int,int); + +static void +fmt_write_ordinal(int,int); + +static int +fmt_nonillion(int,int,bool,bool,int); + +static void +fmt_roman(int,int,int,int,int); + +static void +fmt_integer(object,bool,bool,int,int,int,int); + +static void +fmt_semicolon(bool,bool); + +static void +fmt_up_and_out(bool,bool); + +static void +fmt_justification(volatile bool,bool); + +static void +fmt_iteration(bool,bool); + +static void +fmt_conditional(bool,bool); + +static void +fmt_case(bool,bool); + +static void +fmt_indirection(bool,bool); + +static void +fmt_asterisk(bool,bool); + +static void +fmt_tabulate(bool,bool); + +static void +fmt_newline(bool,bool); + +static void +fmt_tilde(bool,bool); + +static void +fmt_bar(bool,bool); + +static void +fmt_ampersand(bool,bool); + +static void +fmt_percent(bool,bool); + +static void +fmt_dollars_float(bool,bool); + +static void +fmt_general_float(bool,bool); + +static void +fmt_exponential_float(bool,bool); + +static void +fmt_fix_float(bool,bool); + +static void +fmt_character(bool,bool); + +static void +fmt_plural(bool,bool); + +static void +fmt_radix(bool,bool); + +static void +fmt_hexadecimal(bool,bool); + +static void +fmt_octal(bool,bool); + +static void +fmt_binary(bool,bool); + +static void +fmt_error(char *); + +static void +fmt_ascii(bool, bool); + +static void +fmt_S_expression(bool, bool); + +static void +fmt_decimal(bool, bool); + + +object sSAindent_formatted_outputA; + + +#define ctl_string (fmt_string->st.st_self + ctl_origin) + +#define fmt_old VOL object old_fmt_stream; \ + VOL int old_ctl_origin; \ + VOL int old_ctl_index; \ + VOL int old_ctl_end; \ + object * VOL old_fmt_base; \ + VOL int old_fmt_index; \ + VOL int old_fmt_end; \ + jmp_bufp VOL old_fmt_jmp_bufp; \ + VOL int old_fmt_indents; \ + VOL object old_fmt_string ; \ + VOL format_parameter *old_fmt_paramp +#define fmt_save old_fmt_stream = fmt_stream; \ + old_ctl_origin = ctl_origin; \ + old_ctl_index = ctl_index; \ + old_ctl_end = ctl_end; \ + old_fmt_base = fmt_base; \ + old_fmt_index = fmt_index; \ + old_fmt_end = fmt_end; \ + old_fmt_jmp_bufp = fmt_jmp_bufp; \ + old_fmt_indents = fmt_indents; \ + old_fmt_string = fmt_string ; \ + old_fmt_paramp = fmt_paramp +#define fmt_restore fmt_stream = old_fmt_stream; \ + ctl_origin = old_ctl_origin; \ + ctl_index = old_ctl_index; \ + ctl_end = old_ctl_end; \ + fmt_base = old_fmt_base; \ + fmt_index = old_fmt_index; \ + fmt_end = old_fmt_end; \ + fmt_jmp_bufp = old_fmt_jmp_bufp; \ + fmt_indents = old_fmt_indents; \ + fmt_string = old_fmt_string ; \ + fmt_paramp = old_fmt_paramp + +#define fmt_restore1 fmt_stream = old_fmt_stream; \ + ctl_origin = old_ctl_origin; \ + ctl_index = old_ctl_index; \ + ctl_end = old_ctl_end; \ + fmt_jmp_bufp = old_fmt_jmp_bufp; \ + fmt_indents = old_fmt_indents; \ + fmt_string = old_fmt_string ; \ + fmt_paramp = old_fmt_paramp + +typedef struct { + int fmt_param_type; + int fmt_param_value; + } format_parameter; + +format_parameter fmt_param[100]; +VOL format_parameter *fmt_paramp; +#define FMT_PARAM (fmt_paramp) + +#ifndef WRITEC_NEWLINE +#define WRITEC_NEWLINE(strm) (writec_stream('\n',strm)) +#endif + +object fmt_temporary_stream; +object fmt_temporary_string; + +int fmt_nparam; +enum fmt_types { + fmt_null, + fmt_int, + fmt_char}; + +char *fmt_big_numeral[] = { + "thousand", + "million", + "billion", + "trillion", + "quadrillion", + "quintillion", + "sextillion", + "septillion", + "octillion" +}; + +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" +}; + +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" +}; + + +int fmt_spare_spaces; +int fmt_line_length; + + +static int +fmt_tempstr(int s) +{ + return(fmt_temporary_string->st.st_self[s]); +} + +static int +ctl_advance(void) +{ + if (ctl_index >= ctl_end) + fmt_error("unexpected end of control string"); + return(ctl_string[ctl_index++]); +} + +static object +fmt_advance(void) +{ + if (fmt_index >= fmt_end) + fmt_error("arguments exhausted"); + return(fmt_base[fmt_index++]); +} + + +static void +format(object fmt_stream0, int ctl_origin0, int ctl_end0) +{ + int c, i, n; + bool colon, atsign; + object x; + fmt_paramp = fmt_param; + + /* could eliminate the no interrupt if made the + temporary stream on the stack... */ + {BEGIN_NO_INTERRUPT; + fmt_stream = fmt_stream0; + ctl_origin = ctl_origin0; + ctl_index = 0; + ctl_end = ctl_end0; + +LOOP: + if (ctl_index >= ctl_end) + { END_NO_INTERRUPT; + return;} + if ((c = ctl_advance()) != '~') { + writec_stream(c, fmt_stream); + goto LOOP; + } + n = 0; + for (;;) { + switch (c = ctl_advance()) { + case ',': + fmt_param[n].fmt_param_type = fmt_null; + break; + + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + DIGIT: + i = 0; + do { + i = i*10 + (c - '0'); + c = ctl_advance(); + } while (isDigit(c)); + fmt_param[n].fmt_param_type = fmt_int; + fmt_param[n].fmt_param_value = i; + break; + + case '+': + c = ctl_advance(); + if (!isDigit(c)) + fmt_error("digit expected"); + goto DIGIT; + + case '-': + c = ctl_advance(); + if (!isDigit(c)) + fmt_error("digit expected"); + i = 0; + do { + i = i*10 + (c - '0'); + c = ctl_advance(); + } while (isDigit(c)); + fmt_param[n].fmt_param_type = fmt_int; + fmt_param[n].fmt_param_value = -i; + break; + + case '\'': + fmt_param[n].fmt_param_type = fmt_char; + fmt_param[n].fmt_param_value = ctl_advance(); + c = ctl_advance(); + break; + + case 'v': case 'V': + x = fmt_advance(); + if (type_of(x) == t_fixnum) { + fmt_param[n].fmt_param_type = fmt_int; + fmt_param[n].fmt_param_value = fix(x); + } else if (type_of(x) == t_character) { + fmt_param[n].fmt_param_type = fmt_char; + fmt_param[n].fmt_param_value = x->ch.ch_code; + } else if (x == Cnil) { + fmt_param[n].fmt_param_type = fmt_null; + } else + fmt_error("illegal V parameter"); + c = ctl_advance(); + break; + + case '#': + fmt_param[n].fmt_param_type = fmt_int; + fmt_param[n].fmt_param_value = fmt_end - fmt_index; + c = ctl_advance(); + break; + + default: +/* if (n > 0) + fmt_error("illegal ,"); + else +*/ + /* allow (FORMAT NIL "~5,,X" 10) ; ie ,just before directive */ + + goto DIRECTIVE; + } + n++; + if (c != ',') + break; + } + +DIRECTIVE: + colon = atsign = FALSE; + if (c == ':') { + colon = TRUE; + c = ctl_advance(); + } + if (c == '@') { + atsign = TRUE; + c = ctl_advance(); + } + fmt_nparam = n; + switch (c) { + case 'a': case 'A': + fmt_ascii(colon, atsign); + break; + + case 's': case 'S': + fmt_S_expression(colon, atsign); + break; + + case 'd': case 'D': + fmt_decimal(colon, atsign); + break; + + case 'b': case 'B': + fmt_binary(colon, atsign); + break; + + case 'o': case 'O': + fmt_octal(colon, atsign); + break; + + case 'x': case 'X': + fmt_hexadecimal(colon, atsign); + break; + + case 'r': case 'R': + fmt_radix(colon, atsign); + break; + + case 'p': case 'P': + fmt_plural(colon, atsign); + break; + + case 'c': case 'C': + fmt_character(colon, atsign); + break; + + case 'f': case 'F': + fmt_fix_float(colon, atsign); + break; + + case 'e': case 'E': + fmt_exponential_float(colon, atsign); + break; + + case 'g': case 'G': + fmt_general_float(colon, atsign); + break; + + case '$': + fmt_dollars_float(colon, atsign); + break; + + case '%': + fmt_percent(colon, atsign); + break; + + case '&': + fmt_ampersand(colon, atsign); + break; + + case '|': + fmt_bar(colon, atsign); + break; + + case '~': + fmt_tilde(colon, atsign); + break; + + case '\n': + case '\r': + fmt_newline(colon, atsign); + break; + + case 't': case 'T': + fmt_tabulate(colon, atsign); + break; + + case '*': + fmt_asterisk(colon, atsign); + break; + + case '?': + fmt_indirection(colon, atsign); + break; + + case '(': + fmt_case(colon, atsign); + break; + + case '[': + fmt_conditional(colon, atsign); + break; + + case '{': + fmt_iteration(colon, atsign); + break; + + case '<': + fmt_justification(colon, atsign); + break; + + case '^': + fmt_up_and_out(colon, atsign); + break; + + case ';': + fmt_semicolon(colon, atsign); + break; + + default: + {object user_fmt=getf(sSAindent_formatted_outputA->s.s_plist,make_fixnum(c),Cnil); + + if (user_fmt!=Cnil) + {object *oldbase=vs_base; + object *oldtop=vs_top; + vs_base=vs_top; + vs_push(fmt_advance()); + vs_push(fmt_stream); + vs_push(make_fixnum(colon)); + vs_push(make_fixnum(atsign)); + if (type_of(user_fmt)==t_symbol) user_fmt=symbol_function(user_fmt); + funcall(user_fmt); + vs_base=oldbase; vs_top=oldtop; break;}} + fmt_error("illegal directive"); + } + goto LOOP; +}} + + + +static int +fmt_skip(void) +{ + int c, level = 0; + +LOOP: + if (ctl_advance() != '~') + goto LOOP; + for (;;) + switch (c = ctl_advance()) { + case '\'': + ctl_advance(); + + 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; + } + +DIRECTIVE: + switch (c) { + case '(': case '[': case '<': case '{': + level++; + break; + + case ')': case ']': case '>': case '}': + if (level == 0) + return(ctl_index); + else + --level; + break; + + case ';': + if (level == 0) + return(ctl_index); + break; + } + goto LOOP; +} + + +static void +fmt_max_param(int n) +{ + if (fmt_nparam > n) + fmt_error("too many parameters"); +} + +static void +fmt_not_colon(bool colon) +{ + if (colon) + fmt_error("illegal :"); +} + +static void +fmt_not_atsign(bool atsign) +{ + if (atsign) + fmt_error("illegal @"); +} + +static void +fmt_not_colon_atsign(bool colon, bool atsign) +{ + if (colon && atsign) + fmt_error("illegal :@"); +} + +static void +fmt_set_param(int i, int *p, int t, int v) +{ + if (i >= fmt_nparam || FMT_PARAM[i].fmt_param_type == fmt_null) + *p = v; + else if (FMT_PARAM[i].fmt_param_type != t) + fmt_error("illegal parameter type"); + else + *p = FMT_PARAM[i].fmt_param_value; +} + + +static void +fmt_ascii(bool colon, bool atsign) +{ + int mincol=0, colinc=0, minpad=0, padchar=0; + object x; + int l, i; + + fmt_max_param(4); + fmt_set_param(0, &mincol, fmt_int, 0); + fmt_set_param(1, &colinc, fmt_int, 1); + fmt_set_param(2, &minpad, fmt_int, 0); + fmt_set_param(3, &padchar, fmt_char, ' '); + + fmt_temporary_string->st.st_fillp = 0; + /* fmt_temporary_stream->sm.sm_int0 = file_column(fmt_stream); */ + STREAM_FILE_COLUMN(fmt_temporary_stream) = file_column(fmt_stream); + x = fmt_advance(); + if (colon && x == Cnil) + writestr_stream("()", fmt_temporary_stream); + else if (mincol == 0 && minpad == 0) { + princ(x, fmt_stream); + return; + } else + princ(x, fmt_temporary_stream); + l = fmt_temporary_string->st.st_fillp; + for (i = minpad; l + i < mincol; i += colinc) + ; + if (!atsign) { + write_string(fmt_temporary_string, fmt_stream); + while (i-- > 0) + writec_stream(padchar, fmt_stream); + } else { + while (i-- > 0) + writec_stream(padchar, fmt_stream); + write_string(fmt_temporary_string, fmt_stream); + } +} + +static void +fmt_S_expression(bool colon, bool atsign) +{ + int mincol=0, colinc=0, minpad=0, padchar=0; + object x; + int l, i; + + fmt_max_param(4); + fmt_set_param(0, &mincol, fmt_int, 0); + fmt_set_param(1, &colinc, fmt_int, 1); + fmt_set_param(2, &minpad, fmt_int, 0); + fmt_set_param(3, &padchar, fmt_char, ' '); + + fmt_temporary_string->st.st_fillp = 0; + /* fmt_temporary_stream->sm.sm_int0 = file_column(fmt_stream); */ + STREAM_FILE_COLUMN(fmt_temporary_stream) = file_column(fmt_stream); + x = fmt_advance(); + if (colon && x == Cnil) + writestr_stream("()", fmt_temporary_stream); + else if (mincol == 0 && minpad == 0) { + prin1(x, fmt_stream); + return; + } else + prin1(x, fmt_temporary_stream); + l = fmt_temporary_string->st.st_fillp; + for (i = minpad; l + i < mincol; i += colinc) + ; + if (!atsign) { + write_string(fmt_temporary_string, fmt_stream); + while (i-- > 0) + writec_stream(padchar, fmt_stream); + } else { + while (i-- > 0) + writec_stream(padchar, fmt_stream); + write_string(fmt_temporary_string, fmt_stream); + } +} + +static void +fmt_decimal(bool colon, bool atsign) +{ + int mincol=0, padchar=0, commachar=0; + + fmt_max_param(3); + fmt_set_param(0, &mincol, fmt_int, 0); + fmt_set_param(1, &padchar, fmt_char, ' '); + fmt_set_param(2, &commachar, fmt_char, ','); + fmt_integer(fmt_advance(), colon, atsign, + 10, mincol, padchar, commachar); +} + +static void +fmt_binary(bool colon, bool atsign) +{ + int mincol=0, padchar=0, commachar=0; + + fmt_max_param(3); + fmt_set_param(0, &mincol, fmt_int, 0); + fmt_set_param(1, &padchar, fmt_char, ' '); + fmt_set_param(2, &commachar, fmt_char, ','); + fmt_integer(fmt_advance(), colon, atsign, + 2, mincol, padchar, commachar); +} + +static void +fmt_octal(bool colon, bool atsign) +{ + int mincol=0, padchar=0, commachar=0; + + fmt_max_param(3); + fmt_set_param(0, &mincol, fmt_int, 0); + fmt_set_param(1, &padchar, fmt_char, ' '); + fmt_set_param(2, &commachar, fmt_char, ','); + fmt_integer(fmt_advance(), colon, atsign, + 8, mincol, padchar, commachar); +} + +static void +fmt_hexadecimal(bool colon, bool atsign) +{ + int mincol=0, padchar=0, commachar=0; + + fmt_max_param(3); + fmt_set_param(0, &mincol, fmt_int, 0); + fmt_set_param(1, &padchar, fmt_char, ' '); + fmt_set_param(2, &commachar, fmt_char, ','); + fmt_integer(fmt_advance(), colon, atsign, + 16, mincol, padchar, commachar); +} + +static void +fmt_radix(bool colon, bool atsign) +{ + int radix=0, mincol=0, padchar=0, commachar=0; + object x; + int i, j, k; + int s, t; + bool b; + extern void (*write_ch_fun)(int), writec_PRINTstream(int); + + if (fmt_nparam == 0) { + x = fmt_advance(); + check_type_integer(&x); + if (atsign) { + if (type_of(x) == t_fixnum) + i = fix(x); + else + i = -1; + if ((!colon && (i <= 0 || i >= 4000)) || + (colon && (i <= 0 || i >= 5000))) { + fmt_integer(x, FALSE, FALSE, 10, 0, ' ', ','); + return; + } + fmt_roman(i/1000, 'M', '*', '*', colon); + fmt_roman(i%1000/100, 'C', 'D', 'M', colon); + fmt_roman(i%100/10, 'X', 'L', 'C', colon); + fmt_roman(i%10, 'I', 'V', 'X', colon); + return; + } + fmt_temporary_string->st.st_fillp = 0; + /* fmt_temporary_stream->sm.sm_int0 = file_column(fmt_stream); */ + STREAM_FILE_COLUMN(fmt_temporary_stream) = file_column(fmt_stream); + PRINTstream = fmt_temporary_stream; + PRINTradix = FALSE; + PRINTbase = 10; + write_ch_fun = writec_PRINTstream; + write_object(x, 0); + s = 0; + i = fmt_temporary_string->st.st_fillp; + if (i == 1 && fmt_tempstr(s) == '0') { + writestr_stream("zero", fmt_stream); + if (colon) + writestr_stream("th", fmt_stream); + return; + } else if (fmt_tempstr(s) == '-') { + writestr_stream("minus ", fmt_stream); + --i; + s++; + } + t = fmt_temporary_string->st.st_fillp; + for (;;) + if (fmt_tempstr(--t) != '0') + break; + for (b = FALSE; i > 0; i -= j) { + b = fmt_nonillion(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; + } + fmt_max_param(4); + fmt_set_param(0, &radix, fmt_int, 10); + fmt_set_param(1, &mincol, fmt_int, 0); + fmt_set_param(2, &padchar, fmt_char, ' '); + fmt_set_param(3, &commachar, fmt_char, ','); + x = fmt_advance(); + check_type_integer(&x); + if (radix < 0 || radix > 36) { + vs_push(make_fixnum(radix)); + FEerror("~D is illegal as a radix.", 1, vs_head); + } + fmt_integer(x, colon, atsign, radix, mincol, padchar, commachar); +} + +static void +fmt_integer(object x, bool colon, bool atsign, int radix, int mincol, int padchar, int commachar) +{ + int l, l1; + int s; + extern void (*write_ch_fun)(int), writec_PRINTstream(int); + + if (type_of(x) != t_fixnum && type_of(x) != t_bignum) { + fmt_temporary_string->st.st_fillp = 0; + /* fmt_temporary_stream->sm.sm_int0 = file_column(fmt_stream); */ + STREAM_FILE_COLUMN(fmt_temporary_stream) = file_column(fmt_stream); + {SETUP_PRINT_DEFAULT(x); + PRINTstream = fmt_temporary_stream; + PRINTescape = FALSE; + PRINTbase = radix; + write_ch_fun = writec_PRINTstream; + write_object(x, 0); + CLEANUP_PRINT_DEFAULT;} + l = fmt_temporary_string->st.st_fillp; + mincol -= l; + while (mincol-- > 0) + writec_stream(padchar, fmt_stream); + for (s = 0; l > 0; --l, s++) + writec_stream(fmt_tempstr(s), fmt_stream); + return; + } + fmt_temporary_string->st.st_fillp = 0; + /* fmt_temporary_stream->sm.sm_int0 = file_column(fmt_stream);*/ + STREAM_FILE_COLUMN(fmt_temporary_stream) = file_column(fmt_stream); + PRINTstream = fmt_temporary_stream; + PRINTradix = FALSE; + PRINTbase = radix; + write_ch_fun = writec_PRINTstream; + write_object(x, 0); + l = l1 = fmt_temporary_string->st.st_fillp; + s = 0; + if (fmt_tempstr(s) == '-') + --l1; + mincol -= l; + if (colon) + mincol -= (l1 - 1)/3; + if (atsign && fmt_tempstr(s) != '-') + --mincol; + while (mincol-- > 0) + writec_stream(padchar, fmt_stream); + if (fmt_tempstr(s) == '-') { + s++; + writec_stream('-', fmt_stream); + } else if (atsign) + writec_stream('+', fmt_stream); + while (l1-- > 0) { + writec_stream(fmt_tempstr(s++), fmt_stream); + if (colon && l1 > 0 && l1%3 == 0) + writec_stream(commachar, fmt_stream); + } +} + +static int +fmt_nonillion(int s, int i, bool b, bool o, int t) +{ + int j; + + for (; i > 3; i -= j) { + b = fmt_thousand(s, j = (i+2)%3+1, b, FALSE, t); + if (j != 3 || fmt_tempstr(s) != '0' || + fmt_tempstr(s+1) != '0' || fmt_tempstr(s+2) != '0') { + writec_stream(' ', 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(s, i, b, o, t)); +} + +static int +fmt_thousand(int s, int i, bool b, bool o, int t) +{ + if (i == 3 && fmt_tempstr(s) > '0') { + if (b) + writec_stream(' ', fmt_stream); + fmt_write_numeral(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 && fmt_tempstr(s) > '0') { + if (b) + writec_stream(' ', fmt_stream); + if (fmt_tempstr(s) == '1') { + if (o && s + 2 > t) + fmt_write_ordinal(++s, 10); + else + fmt_write_numeral(++s, 10); + return(TRUE); + } else { + if (o && s + 1 > t) + fmt_write_ordinal(s, 20); + else + fmt_write_numeral(s, 20); + s++; + if (fmt_tempstr(s) > '0') { + writec_stream('-', fmt_stream); + if (o && s + 1 > t) + fmt_write_ordinal(s, 0); + else + fmt_write_numeral(s, 0); + } + return(TRUE); + } + } + if (i == 2) + s++; + if (fmt_tempstr(s) > '0') { + if (b) + writec_stream(' ', fmt_stream); + if (o && s + 1 > t) + fmt_write_ordinal(s, 0); + else + fmt_write_numeral(s, 0); + return(TRUE); + } + return(b); +} + +static void +fmt_write_numeral(int s, int i) +{ + writestr_stream(fmt_numeral[fmt_tempstr(s) - '0' + i], fmt_stream); +} + +static void +fmt_write_ordinal(int s, int i) +{ + writestr_stream(fmt_ordinal[fmt_tempstr(s) - '0' + i], fmt_stream); +} + +static void +fmt_roman(int i, int one, int five, int ten, int colon) +{ + int j; + + if (i == 0) + return; + if ((!colon && i < 4) || (colon && i < 5)) + for (j = 0; j < i; j++) + writec_stream(one, fmt_stream); + else if (!colon && i == 4) { + writec_stream(one, fmt_stream); + writec_stream(five, fmt_stream); + } else if ((!colon && i < 9) || colon) { + writec_stream(five, fmt_stream); + for (j = 5; j < i; j++) + writec_stream(one, fmt_stream); + } else if (!colon && i == 9) { + writec_stream(one, fmt_stream); + writec_stream(ten, fmt_stream); + } +} + +static void +fmt_plural(bool colon, bool atsign) +{ + fmt_max_param(0); + if (colon) { + if (fmt_index == 0) + fmt_error("can't back up"); + --fmt_index; + } + if (eql(fmt_advance(), make_fixnum(1))) + if (atsign) + writec_stream('y', fmt_stream); + else + ; + else + if (atsign) + writestr_stream("ies", fmt_stream); + else + writec_stream('s', fmt_stream); +} + +static void +fmt_character(bool colon, bool atsign) +{ + object x; + int i; + + fmt_max_param(0); + fmt_temporary_string->st.st_fillp = 0; + /* fmt_temporary_stream->sm.sm_int0 = 0;*/ + STREAM_FILE_COLUMN(fmt_temporary_stream) = 0; + x = fmt_advance(); + check_type_character(&x); + prin1(x, fmt_temporary_stream); + if (!colon && atsign) + i = 0; + else + i = 2; + for (; i < fmt_temporary_string->st.st_fillp; i++) + writec_stream(fmt_tempstr(i), fmt_stream); +} + +static void +fmt_fix_float(bool colon, bool atsign) +{ + int w=0, d=0, k=0, overflowchar=0, padchar=0; + double f; + int sign; + char *buff, *b, *buff1; + int exp; + int i, j; + object x; + int n, m; + vs_mark; + + massert(buff=alloca(256)); /*from automatic array -- work around for persistent gcc alpha bug*/ + massert(buff1=alloca(256)); + + b = buff1 + 1; + + fmt_not_colon(colon); + fmt_max_param(5); + fmt_set_param(0, &w, fmt_int, 0); + if (w < 0) + fmt_error("illegal width"); + fmt_set_param(0, &w, fmt_int, -1); + fmt_set_param(1, &d, fmt_int, 0); + if (d < 0) + fmt_error("illegal number of digits"); + fmt_set_param(1, &d, fmt_int, -1); + fmt_set_param(2, &k, fmt_int, 0); + fmt_set_param(3, &overflowchar, fmt_char, -1); + fmt_set_param(4, &padchar, fmt_char, ' '); + + x = fmt_advance(); + if (type_of(x) == t_fixnum || + type_of(x) == t_bignum || + type_of(x) == t_ratio) { + x = make_shortfloat((shortfloat)number_to_double(x)); + vs_push(x); + } + if (type_of(x) == t_complex) { + if (w < 0) + prin1(x, fmt_stream); + else { + fmt_nparam = 1; + --fmt_index; + fmt_decimal(colon, atsign); + } + vs_reset; + return; + } + if (type_of(x) == t_longfloat) +/* n = 16; */ + n = 17; + else +/* n = 7; */ + n = 8; + f = number_to_double(x); + edit_double(n, f, &sign, buff, &exp); + if (exp + k > 100 || exp + k < -100 || d > 100) { + prin1(x, fmt_stream); + vs_reset; + 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) + goto OVER; + if (j < w && b[j-1] == '.' && d) { + b[j++] = '0'; + b[j] = '\0'; + } + if (j < w && b[0] == '.') { + *--b = '0'; + j++; + } + for (i = j; i < w; i++) + writec_stream(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) + writec_stream('-', fmt_stream); + else if (atsign) + writec_stream('+', fmt_stream); + writestr_stream(b, fmt_stream); + vs_reset; + return; + +OVER: + fmt_set_param(0, &w, fmt_int, 0); + for (i = 0; i < w; i++) + writec_stream(overflowchar, fmt_stream); + vs_reset; + return; +} + +static int +fmt_exponent_length(int e) +{ + int i; + + if (e == 0) + return(1); + if (e < 0) + e = -e; + for (i = 0; e > 0; i++, e /= 10) + ; + return(i); +} + +static void +fmt_exponent(int e) +{ + if (e == 0) { + writec_stream('0', fmt_stream); + return; + } + if (e < 0) + e = -e; + fmt_exponent1(e); +} + +static void +fmt_exponent1(int e) +{ + if (e == 0) + return; + fmt_exponent1(e/10); + writec_stream('0' + e%10, fmt_stream); +} + +static void +fmt_exponential_float(bool colon, bool atsign) +{ + int w=0, d=0, e=0, k=0, overflowchar=0, padchar=0, exponentchar=0; + double f; + int sign; + char buff[256], *b, buff1[256]; + int exp; + int i, j; + object x, y; + int n, m; + enum type t; + vs_mark; + + b = buff1 + 1; + + fmt_not_colon(colon); + fmt_max_param(7); + fmt_set_param(0, &w, fmt_int, 0); + if (w < 0) + fmt_error("illegal width"); + fmt_set_param(0, &w, fmt_int, -1); + fmt_set_param(1, &d, fmt_int, 0); + if (d < 0) + fmt_error("illegal number of digits"); + fmt_set_param(1, &d, fmt_int, -1); + fmt_set_param(2, &e, fmt_int, 0); + if (e < 0) + fmt_error("illegal number of digits in exponent"); + fmt_set_param(2, &e, fmt_int, -1); + fmt_set_param(3, &k, fmt_int, 1); + fmt_set_param(4, &overflowchar, fmt_char, -1); + fmt_set_param(5, &padchar, fmt_char, ' '); + fmt_set_param(6, &exponentchar, fmt_char, -1); + + x = fmt_advance(); + if (type_of(x) == t_fixnum || + type_of(x) == t_bignum || + type_of(x) == t_ratio) { + x = make_shortfloat((shortfloat)number_to_double(x)); + vs_push(x); + } + if (type_of(x) == t_complex) { + if (w < 0) + prin1(x, fmt_stream); + else { + fmt_nparam = 1; + --fmt_index; + fmt_decimal(colon, atsign); + } + vs_reset; + return; + } + if (type_of(x) == t_longfloat) +/* n = 16; */ + n = 17; + else +/* n = 7; */ + n = 8; + f = number_to_double(x); + edit_double(n, f, &sign, buff, &exp); + if (d >= 0) { + if (k > 0) { + if (!(k < d + 2)) + fmt_error("illegal scale factor"); + m = d + 1; + } else { + if (!(k > -d)) + fmt_error("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[j-1] == '.') { + b[j++] = '0'; + b[j] = '\0'; + } + if (j < w && b[0] == '.') { + *--b = '0'; + j++; + } + for (i = j; i < w; i++) + writec_stream(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) + writec_stream('-', fmt_stream); + else if (atsign) + writec_stream('+', fmt_stream); + writestr_stream(b, fmt_stream); + y = symbol_value(sLAread_default_float_formatA); + if (exponentchar < 0) { + if (y == sLlong_float || y == sLdouble_float + || y == sLsingle_float + + ) + t = t_longfloat; + else + t = t_shortfloat; + if (type_of(x) == t) + exponentchar = 'E'; + else if (type_of(x) == t_shortfloat) + exponentchar = 'S'; + else + exponentchar = 'L'; + } + writec_stream(exponentchar, fmt_stream); + if (exp < 0) + writec_stream('-', fmt_stream); + else + writec_stream('+', fmt_stream); + if (e >= 0) + for (i = e - fmt_exponent_length(exp); i > 0; --i) + writec_stream('0', fmt_stream); + fmt_exponent(exp); + vs_reset; + return; + +OVER: + fmt_set_param(0, &w, fmt_int, -1); + for (i = 0; i < w; i++) + writec_stream(overflowchar, fmt_stream); + vs_reset; + return; +} + +static void +fmt_general_float(bool colon, bool atsign) +{ + int w=0, d=0, e=0, k, overflowchar, padchar=0, exponentchar; + int sign, exp; + char buff[256]; + object x; + int n, ee, ww, q, dd; + vs_mark; + + fmt_not_colon(colon); + fmt_max_param(7); + fmt_set_param(0, &w, fmt_int, 0); + if (w < 0) + fmt_error("illegal width"); + fmt_set_param(0, &w, fmt_int, -1); + fmt_set_param(1, &d, fmt_int, 0); + if (d < 0) + fmt_error("illegal number of digits"); + fmt_set_param(1, &d, fmt_int, -1); + fmt_set_param(2, &e, fmt_int, 0); + if (e < 0) + fmt_error("illegal number of digits in exponent"); + fmt_set_param(2, &e, fmt_int, -1); + fmt_set_param(3, &k, fmt_int, 1); + fmt_set_param(4, &overflowchar, fmt_char, -1); + fmt_set_param(5, &padchar, fmt_char, ' '); + fmt_set_param(6, &exponentchar, fmt_char, -1); + + x = fmt_advance(); + if (type_of(x) == t_complex) { + if (w < 0) + prin1(x, fmt_stream); + else { + fmt_nparam = 1; + --fmt_index; + fmt_decimal(colon, atsign); + } + vs_reset; + return; + } + if (type_of(x) == t_longfloat) +/* q = 16; */ + q = 17; + else +/* q = 7; */ + q = 8; + edit_double(q, number_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_PARAM[0].fmt_param_value = ww; + if (w < 0) FMT_PARAM[0].fmt_param_type = fmt_null; + FMT_PARAM[1].fmt_param_value = dd; + FMT_PARAM[1].fmt_param_type = fmt_int; + FMT_PARAM[2].fmt_param_type = fmt_null; + if (fmt_nparam > 4) + {FMT_PARAM[3] = FMT_PARAM[4]; } + else FMT_PARAM[3].fmt_param_type = fmt_null; + if (fmt_nparam > 5) + {FMT_PARAM[4] = FMT_PARAM[5];} + else FMT_PARAM[4].fmt_param_type = fmt_null; + fmt_nparam = 5; + --fmt_index; + fmt_fix_float(colon, atsign); + if (w >= 0) + while (ww++ < w) + writec_stream(padchar, fmt_stream); + vs_reset; + return; + } + FMT_PARAM[1].fmt_param_value = d; + FMT_PARAM[1].fmt_param_type = fmt_int; + --fmt_index; + fmt_exponential_float(colon, atsign); + vs_reset; +} + +static void +fmt_dollars_float(bool colon, bool atsign) +{ + int d=0, n=0, w=0, padchar=0; + double f; + int sign; + char buff[256]; + int exp; + int q, i; + object x; + vs_mark; + + fmt_max_param(4); + fmt_set_param(0, &d, fmt_int, 2); + if (d < 0) + fmt_error("illegal number of digits"); + fmt_set_param(1, &n, fmt_int, 1); + if (n < 0) + fmt_error("illegal number of digits"); + fmt_set_param(2, &w, fmt_int, 0); + if (w < 0) + fmt_error("illegal width"); + fmt_set_param(3, &padchar, fmt_char, ' '); + x = fmt_advance(); + if (type_of(x) == t_complex) { + if (w < 0) + prin1(x, fmt_stream); + else { + fmt_nparam = 1; + FMT_PARAM[0] = FMT_PARAM[2]; + --fmt_index; + fmt_decimal(colon, atsign); + } + vs_reset; + return; + } +/* q = 7; */ + q = 8; + if (type_of(x) == t_longfloat) +/* q = 16; */ + q = 17; + f = number_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].fmt_param_value = d + n - 1; + FMT_PARAM[1].fmt_param_type = fmt_int; + FMT_PARAM[2].fmt_param_type = + FMT_PARAM[3].fmt_param_type = + FMT_PARAM[4].fmt_param_type = fmt_null; + FMT_PARAM[5] = FMT_PARAM[3]; + --fmt_index; + fmt_exponential_float(colon, atsign); + } + if (exp > n) + n = exp; + if (sign < 0 || atsign) + --w; + if (colon) { + if (sign < 0) + writec_stream('-', fmt_stream); + else if (atsign) + writec_stream('+', fmt_stream); + while (--w > n + d) + writec_stream(padchar, fmt_stream); + } else { + while (--w > n + d) + writec_stream(padchar, fmt_stream); + if (sign < 0) + writec_stream('-', fmt_stream); + else if (atsign) + writec_stream('+', fmt_stream); + } + for (i = n - exp; i > 0; --i) + writec_stream('0', fmt_stream); + for (i = 0; i < exp; i++) + writec_stream((i < q ? buff[i] : '0'), fmt_stream); + writec_stream('.', fmt_stream); + for (d += i; i < d; i++) + writec_stream((i < q ? buff[i] : '0'), fmt_stream); + vs_reset; +} + +static void +fmt_percent(bool colon, bool atsign) +{ + int n=0, i; + + fmt_max_param(1); + fmt_set_param(0, &n, fmt_int, 1); + fmt_not_colon(colon); + fmt_not_atsign(atsign); + while (n-- > 0) { + WRITEC_NEWLINE(fmt_stream); + if (n == 0) + for (i = fmt_indents; i > 0; --i) + writec_stream(' ', fmt_stream); + } +} + +static void +fmt_ampersand(bool colon, bool atsign) +{ + int n=0; + + fmt_max_param(1); + fmt_set_param(0, &n, fmt_int, 1); + fmt_not_colon(colon); + fmt_not_atsign(atsign); + if (n == 0) + return; + if (file_column(fmt_stream) != 0) + WRITEC_NEWLINE(fmt_stream); + while (--n > 0) + WRITEC_NEWLINE(fmt_stream); + fmt_indents = 0; +} + +static void +fmt_bar(bool colon, bool atsign) +{ + int n=0; + + fmt_max_param(1); + fmt_set_param(0, &n, fmt_int, 1); + fmt_not_colon(colon); + fmt_not_atsign(atsign); + while (n-- > 0) + writec_stream('\f', fmt_stream); +} + +static void +fmt_tilde(bool colon, bool atsign) +{ + int n=0; + + fmt_max_param(1); + fmt_set_param(0, &n, fmt_int, 1); + fmt_not_colon(colon); + fmt_not_atsign(atsign); + while (n-- > 0) + writec_stream('~', fmt_stream); +} + +static void +fmt_newline(bool colon, bool atsign) +{ + + fmt_max_param(0); + fmt_not_colon_atsign(colon, atsign); + if (atsign) + WRITEC_NEWLINE(fmt_stream); + while (ctl_index < ctl_end && isspace((int)ctl_string[ctl_index])) { + if (colon) + writec_stream(ctl_string[ctl_index], fmt_stream); + ctl_index++; + } +} + +static void +fmt_tabulate(bool colon, bool atsign) +{ + int colnum=0, colinc=0; + int c, i; + + fmt_max_param(2); + fmt_not_colon(colon); + fmt_set_param(0, &colnum, fmt_int, 1); + fmt_set_param(1, &colinc, fmt_int, 1); + if (!atsign) { + c = 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) + writec_stream(' ', fmt_stream); + } else { + for (i = colnum; i > 0; --i) + writec_stream(' ', fmt_stream); + c = file_column(fmt_stream); + if (c < 0 || colinc <= 0) + return; + colnum = 0; + while (c > colnum) + colnum += colinc; + for (i = colnum - c; i > 0; --i) + writec_stream(' ', fmt_stream); + } +} + +static void +fmt_asterisk(bool colon, bool atsign) +{ + int n=0; + + fmt_max_param(1); + fmt_not_colon_atsign(colon, atsign); + if (atsign) { + fmt_set_param(0, &n, fmt_int, 0); + if (n < 0 || n >= fmt_end) + fmt_error("can't goto"); + fmt_index = n; + } else if (colon) { + fmt_set_param(0, &n, fmt_int, 1); + if (n > fmt_index) + fmt_error("can't back up"); + fmt_index -= n; + } else { + fmt_set_param(0, &n, fmt_int, 1); + while (n-- > 0) + fmt_advance(); + } +} + +static void +fmt_indirection(bool colon, bool atsign) { + object s, l; + fmt_old; + jmp_buf fmt_jmp_buf0; + int up_colon; + + /* to prevent longjmp clobber */ + up_colon=(long)&old_fmt_paramp; + fmt_max_param(0); + fmt_not_colon(colon); + s = fmt_advance(); + if (type_of(s) != t_string) + fmt_error("control string expected"); + if (atsign) { + fmt_save; + fmt_jmp_bufp = &fmt_jmp_buf0; + fmt_string = s; + if ((up_colon = setjmp(*fmt_jmp_bufp))) { + if (--up_colon) + fmt_error("illegal ~:^"); + } else + format(fmt_stream, 0, s->st.st_fillp); + fmt_restore1; + } else { + l = fmt_advance(); + fmt_save; + fmt_base = vs_top; + fmt_index = 0; + for (fmt_end = 0; !endp(l); fmt_end++, l = l->c.c_cdr) + vs_check_push(l->c.c_car); + fmt_jmp_bufp = &fmt_jmp_buf0; + fmt_string = s; + if ((up_colon = setjmp(*fmt_jmp_bufp))) { + if (--up_colon) + fmt_error("illegal ~:^"); + } else + format(fmt_stream, 0, s->st.st_fillp); + vs_top = fmt_base; + fmt_restore; + } +} + +static void +fmt_case(bool colon, bool atsign) +{ + VOL object x; + VOL int i, j; + fmt_old; + jmp_buf fmt_jmp_buf0; + int up_colon; + bool b; + + x = make_string_output_stream(64); + vs_push(x); + i = ctl_index; + j = fmt_skip(); + if (ctl_string[--j] != ')' || ctl_string[--j] != '~') + fmt_error("~) expected"); + fmt_save; + fmt_jmp_bufp = &fmt_jmp_buf0; + if ((up_colon = setjmp(*fmt_jmp_bufp))) + ; + else + format(x, ctl_origin + i, j - i); + fmt_restore1; + x = x->sm.sm_object0; + if (!colon && !atsign) + for (i = 0; i < x->st.st_fillp; i++) { + j = x->st.st_self[i]; + if (isUpper(j)) + j += 'a' - 'A'; + writec_stream(j, fmt_stream); + } + else if (colon && !atsign) + for (b = TRUE, i = 0; i < x->st.st_fillp; i++) { + j = x->st.st_self[i]; + if (isLower(j)) { + if (b) + j -= 'a' - 'A'; + b = FALSE; + } else if (isUpper(j)) { + if (!b) + j += 'a' - 'A'; + b = FALSE; + } else if (!isDigit(j)) + b = TRUE; + writec_stream(j, fmt_stream); + } + else if (!colon && atsign) + for (b = TRUE, i = 0; i < x->st.st_fillp; i++) { + j = x->st.st_self[i]; + if (isLower(j)) { + if (b) + j -= 'a' - 'A'; + b = FALSE; + } else if (isUpper(j)) { + if (!b) + j += 'a' - 'A'; + b = FALSE; + } + writec_stream(j, fmt_stream); + } + else + for (i = 0; i < x->st.st_fillp; i++) { + j = x->st.st_self[i]; + if (isLower(j)) + j -= 'a' - 'A'; + writec_stream(j, fmt_stream); + } + vs_popp; + if (up_colon) + longjmp(*fmt_jmp_bufp, up_colon); +} + +static void +fmt_conditional(bool colon, bool atsign) +{ + int i, j, k; + object x; + int n=0; + bool done; + fmt_old; + + fmt_not_colon_atsign(colon, atsign); + if (colon) { + fmt_max_param(0); + i = ctl_index; + j = fmt_skip(); + if (ctl_string[--j] != ';' || ctl_string[--j] != '~') + fmt_error("~; expected"); + k = fmt_skip(); + if (ctl_string[--k] != ']' || ctl_string[--k] != '~') + fmt_error("~] expected"); + if (fmt_advance() == Cnil) { + fmt_save; + format(fmt_stream, ctl_origin + i, j - i); + fmt_restore1; + } else { + fmt_save; + format(fmt_stream, ctl_origin + j + 2, k - (j + 2)); + fmt_restore1; + } + } else if (atsign) { + i = ctl_index; + j = fmt_skip(); + if (ctl_string[--j] != ']' || ctl_string[--j] != '~') + fmt_error("~] expected"); + if (fmt_advance() == Cnil) + ; + else { + --fmt_index; + fmt_save; + format(fmt_stream, ctl_origin + i, j - i); + fmt_restore1; + } + } else { + fmt_max_param(1); + if (fmt_nparam == 0) { + x = fmt_advance(); + if (type_of(x) != t_fixnum) + fmt_error("illegal argument for conditional"); + n = fix(x); + } else + fmt_set_param(0, &n, fmt_int, 0); + i = ctl_index; + for (done = FALSE;; --n) { + j = fmt_skip(); + for (k = j; ctl_string[--k] != '~';) + ; + if (n == 0) { + fmt_save; + format(fmt_stream, ctl_origin + i, k - i); + fmt_restore1; + done = TRUE; + } + i = j; + if (ctl_string[--j] == ']') { + if (ctl_string[--j] != '~') + fmt_error("~] expected"); + return; + } + if (ctl_string[j] == ';') { + if (ctl_string[--j] == '~') + continue; + if (ctl_string[j] == ':') + goto ELSE; + } + fmt_error("~; or ~] expected"); + } + ELSE: + if (ctl_string[--j] != '~') + fmt_error("~:; expected"); + j = fmt_skip(); + if (ctl_string[--j] != ']' || ctl_string[--j] != '~') + fmt_error("~] expected"); + if (!done) { + fmt_save; + format(fmt_stream, ctl_origin + i, j - i); + fmt_restore1; + } + } +} + +static void +fmt_iteration(bool colon, bool atsign) { + int i,n=0; + VOL int j; + int o; + bool colon_close = FALSE; + object l; + VOL object l0; + fmt_old; + jmp_buf fmt_jmp_buf0; + int up_colon; + + /* to prevent longjmp clobber */ + up_colon=(long)&old_fmt_paramp; + fmt_max_param(1); + fmt_set_param(0, &n, fmt_int, 1000000); + i = ctl_index; + j = fmt_skip(); + if (ctl_string[--j] != '}') + fmt_error("~} expected"); + if (ctl_string[--j] == ':') { + colon_close = TRUE; + --j; + } + if (ctl_string[j] != '~') + fmt_error("syntax error"); + o = ctl_origin; + if (!colon && !atsign) { + l = fmt_advance(); + fmt_save; + fmt_base = vs_top; + fmt_index = 0; + for (fmt_end = 0; !endp(l); fmt_end++, l = l->c.c_cdr) + vs_check_push(l->c.c_car); + fmt_jmp_bufp = &fmt_jmp_buf0; + if (colon_close) + goto L1; + while (fmt_index < fmt_end) { + L1: + if (n-- <= 0) + break; + if ((up_colon = setjmp(*fmt_jmp_bufp))) { + if (--up_colon) + fmt_error("illegal ~:^"); + break; + } + format(fmt_stream, o + i, j - i); + } + vs_top = fmt_base; + fmt_restore; + } else if (colon && !atsign) { + l0 = fmt_advance(); + fmt_save; + fmt_base = vs_top; + fmt_jmp_bufp = &fmt_jmp_buf0; + if (colon_close) + goto L2; + while (!endp(l0)) { + L2: + if (n-- <= 0) + break; + l = l0->c.c_car; + l0 = l0->c.c_cdr; + fmt_index = 0; + for (fmt_end = 0; !endp(l); fmt_end++, l = l->c.c_cdr) + vs_check_push(l->c.c_car); + if ((up_colon = setjmp(*fmt_jmp_bufp))) { + vs_top = fmt_base; + if (--up_colon) + break; + else + continue; + } + format(fmt_stream, o + i, j - i); + vs_top = fmt_base; + } + fmt_restore; + } else if (!colon && atsign) { + fmt_save; + fmt_jmp_bufp = &fmt_jmp_buf0; + if (colon_close) + goto L3; + while (fmt_index < fmt_end) { + L3: + if (n-- <= 0) + break; + if ((up_colon = setjmp(*fmt_jmp_bufp))) { + if (--up_colon) + fmt_error("illegal ~:^"); + break; + } + format(fmt_stream, o + i, j - i); + } + fmt_restore1; + } else if (colon && atsign) { + if (colon_close) + goto L4; + while (fmt_index < fmt_end) { + L4: + if (n-- <= 0) + break; + l = fmt_advance(); + fmt_save; + fmt_base = vs_top; + fmt_index = 0; + for (fmt_end = 0; !endp(l); fmt_end++, l = l->c.c_cdr) + vs_check_push(l->c.c_car); + fmt_jmp_bufp = &fmt_jmp_buf0; + if ((up_colon = setjmp(*fmt_jmp_bufp))) { + vs_top = fmt_base; + fmt_restore; + if (--up_colon) + break; + else + continue; + } + format(fmt_stream, o + i, j - i); + vs_top = fmt_base; + fmt_restore; + } + } +} + +#define FORMAT_DIRECTIVE_LIMIT 100 + +static void +fmt_justification(volatile bool colon, bool atsign) +{ + int mincol=0, colinc=0, minpad=0, padchar=0; + object fields[FORMAT_DIRECTIVE_LIMIT]; + fmt_old; + jmp_buf fmt_jmp_buf0; + VOL int i,j,n,j0; + int k,l,m,l0; + int up_colon; + VOL int special = 0; + volatile int spare_spaces=0, line_length=0; + vs_mark; + + /* to prevent longjmp clobber */ + up_colon=(long)&old_fmt_paramp; + fmt_max_param(4); + fmt_set_param(0, &mincol, fmt_int, 0); + fmt_set_param(1, &colinc, fmt_int, 1); + fmt_set_param(2, &minpad, fmt_int, 0); + fmt_set_param(3, &padchar, fmt_char, ' '); + + n = 0; + for (;;) { + if (n >= FORMAT_DIRECTIVE_LIMIT) + fmt_error("too many fields"); + i = ctl_index; + j0 = j = fmt_skip(); + while (ctl_string[--j] != '~') + ; + fields[n] = make_string_output_stream(64); + vs_push(fields[n]); + fmt_save; + fmt_jmp_bufp = &fmt_jmp_buf0; + if ((up_colon = setjmp(*fmt_jmp_bufp))) { + --n; + if (--up_colon) + fmt_error("illegal ~:^"); + fmt_restore1; + while (ctl_string[--j0] != '>') + j0 = fmt_skip(); + if (ctl_string[--j0] != '~') + fmt_error("~> expected"); + break; + } + format(fields[n++], ctl_origin + i, j - i); + fmt_restore1; + if (ctl_string[--j0] == '>') { + if (ctl_string[--j0] != '~') + fmt_error("~> expected"); + break; + } else if (ctl_string[j0] != ';') + fmt_error("~; expected"); + else if (ctl_string[--j0] == ':') { + if (n != 1) + fmt_error("illegal ~:;"); + special = 1; + for (j = j0; ctl_string[j] != '~'; --j) + ; + fmt_save; + format(fmt_stream, ctl_origin + j, j0 - j + 2); + fmt_restore1; + spare_spaces = fmt_spare_spaces; + line_length = fmt_line_length; + } else if (ctl_string[j0] != '~') + fmt_error("~; expected"); + } + for (i = special, l = 0; i < n; i++) + l += fields[i]->sm.sm_object0->st.st_fillp; + m = n - 1 - special; + if (m <= 0 && !colon && !atsign) { + m = 0; + colon = TRUE; + } + if (colon) + m++; + if (atsign) + m++; + l0 = l; + l += minpad * m; + for (k = 0; mincol + k * colinc < l; k++) + ; + l = mincol + k * colinc; + if (special != 0 && + file_column(fmt_stream) + l + spare_spaces >= line_length) + princ(fields[0]->sm.sm_object0, fmt_stream); + l -= l0; + for (i = special; i < n; i++) { + if (m > 0 && (i > 0 || colon)) + for (j = l / m, l -= j, --m; j > 0; --j) + writec_stream(padchar, fmt_stream); + princ(fields[i]->sm.sm_object0, fmt_stream); + } + if (atsign) + for (j = l; j > 0; --j) + writec_stream(padchar, fmt_stream); + vs_reset; +} + + +static void +fmt_up_and_out(bool colon, bool atsign) +{ + int i=0, j=0, k=0; + + fmt_max_param(3); + fmt_not_atsign(atsign); + if (fmt_nparam == 0) { + if (fmt_index >= fmt_end) + longjmp(*fmt_jmp_bufp, ++colon); + } else if (fmt_nparam == 1) { + fmt_set_param(0, &i, fmt_int, 0); + if (i == 0) + longjmp(*fmt_jmp_bufp, ++colon); + } else if (fmt_nparam == 2) { + fmt_set_param(0, &i, fmt_int, 0); + fmt_set_param(1, &j, fmt_int, 0); + if (i == j) + longjmp(*fmt_jmp_bufp, ++colon); + } else { + fmt_set_param(0, &i, fmt_int, 0); + fmt_set_param(1, &j, fmt_int, 0); + fmt_set_param(2, &k, fmt_int, 0); + if (i <= j && j <= k) + longjmp(*fmt_jmp_bufp, ++colon); + } +} + + +static void +fmt_semicolon(bool colon, bool atsign) +{ + fmt_not_atsign(atsign); + if (!colon) + fmt_error("~:; expected"); + fmt_max_param(2); + fmt_set_param(0, &fmt_spare_spaces, fmt_int, 0); + fmt_set_param(1, &fmt_line_length, fmt_int, 72); +} + +DEFUNO_NEW("FORMAT",object,fLformat,LISP + ,2,F_ARG_LIMIT,NONE,OO,OO,OO,OO,void,Lformat,(object strm, object control,...),"") +{ va_list ap; + VOL int nargs= VFUN_NARGS; + VOL object x = OBJNULL; + jmp_buf fmt_jmp_buf0; + bool colon, e; + fmt_old; + nargs=nargs-2; + if (nargs < 0) + too_few_arguments(); + if (strm == Cnil) { + strm = make_string_output_stream(64); + x = strm->sm.sm_object0; + } else if (strm == Ct) + strm = symbol_value(sLAstandard_outputA); + else if (type_of(strm) == t_string) { + x = strm; + if (!x->st.st_hasfillp) + FEerror("The string ~S doesn't have a fill-pointer.", 1, x); + strm = make_string_output_stream(0); + strm->sm.sm_object0 = x; + } else + check_type_stream(&strm); + check_type_string(&control); + fmt_save; + frs_push(FRS_PROTECT, Cnil); + if (nlj_active) { + e = TRUE; + goto L; + } + + va_start(ap,control); + {object *l; + COERCE_VA_LIST(l,ap,nargs); + fmt_base = l; + fmt_index = 0; + fmt_end = nargs; + fmt_jmp_bufp = & fmt_jmp_buf0; + if (symbol_value(sSAindent_formatted_outputA) != Cnil) + fmt_indents = file_column(strm); + else + fmt_indents = 0; + fmt_string = control; + if ((colon = setjmp(*fmt_jmp_bufp))) { + if (--colon) + fmt_error("illegal ~:^"); + vs_base = vs_top; + if (x != OBJNULL) + vs_push(x); + else + vs_push(Cnil); + e = FALSE; + goto L; + } + format(strm, 0, control->st.st_fillp); + flush_stream(strm); + } + va_end(ap); + e = FALSE; +L: + frs_pop(); + fmt_restore; + if (e) { + nlj_active = FALSE; + unwind(nlj_fr, nlj_tag); + } + RETURN1 (x ==0 ? Cnil : x); +} +object +fLformat_1(object strm, object control,object x) { + VFUN_NARGS=3; + return FFN(fLformat)(strm,control,x); + +} + +/* object c_apply_n(long int (*fn) (), int n, object *x); */ + +static void +fmt_error(char *s) +{ + vs_push(make_simple_string(s)); + vs_push(make_fixnum(&ctl_string[ctl_index] - fmt_string->st.st_self)); + FEerror("Format error: ~A.~%~V@TV~%\"~A\"~%", + 3, vs_top[-2], vs_top[-1], fmt_string); +} + +DEFVAR("*INDENT-FORMATTED-OUTPUT*",sSAindent_formatted_outputA,SI,Cnil,""); +void +gcl_init_format(void) +{ + fmt_temporary_stream = make_string_output_stream(64); + enter_mark_origin(&fmt_temporary_stream); + fmt_temporary_string = fmt_temporary_stream->sm.sm_object0; + + + + +} diff --git a/o/frame.c b/o/frame.c new file mode 100755 index 0000000..8dfc9c1 --- /dev/null +++ b/o/frame.c @@ -0,0 +1,84 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +/* + + frame.c + + frame and non-local jump +*/ + +#include "include.h" + +void +unwind(frame_ptr fr, object tag) +{ + signals_allowed = 0; + nlj_fr = fr; + nlj_tag = tag; + nlj_active = TRUE; + while (frs_top != fr + && frs_top->frs_class == FRS_CATCH + && frs_top >= frs_org + /* + && frs_top->frs_class != FRS_PROTECT + && frs_top->frs_class != FRS_CATCHALL + */ + ) { + --frs_top; + } + if (frs_topfrs_lex; + ihs_top = frs_top->frs_ihs; + bds_unwind(frs_top->frs_bds_top); + in_signal_handler = frs_top->frs_in_signal_handler; + signals_allowed=sig_normal; + longjmp((void *)frs_top->frs_jmpbuf, 0); + /* never reached */ +} + +frame_ptr frs_sch (object frame_id) +{ + frame_ptr top; + + for (top = frs_top; top >= frs_org; top--) + if (top->frs_val == frame_id && top->frs_class == FRS_CATCH) + return(top); + return(NULL); +} + +frame_ptr frs_sch_catch(object frame_id) +{ + frame_ptr top; + + for(top = frs_top; top >= frs_org ;top--) + if ((top->frs_val == frame_id && top->frs_class == FRS_CATCH) + || top->frs_class == FRS_CATCHALL + ) + return(top); + return(NULL); +} + + + diff --git a/o/funlink.c b/o/funlink.c new file mode 100755 index 0000000..5a09d47 --- /dev/null +++ b/o/funlink.c @@ -0,0 +1,621 @@ +/* Copyright William Schelter. All rights reserved. +Fast linking method for kcl by W. Schelter University of Texas + Note there are also changes to + cmpcall.lsp and cmptop.lsp */ + + +#include +#include +#include "include.h" +#include "sfun_argd.h" +#include "page.h" + +static int +clean_link_array(object *,object *); + +object sScdefn; +typedef object (*object_func)(); + +static int +vpush_extend(void *,object); + +object sLAlink_arrayA; +int Rset = 0; + +DEFVAR("*LINK-LIST*",sSAlink_listA,SI,0,""); + +static inline void +append_link_list(object sym,int n) { + + object x; + int i; + + if (!Rset || !sSAlink_listA->s.s_dbind) return; + for (x=sSAlink_listA->s.s_dbind;x!=Cnil && x->c.c_car->c.c_car!=sym;x=x->c.c_cdr); + if (x==Cnil) + sSAlink_listA->s.s_dbind=MMcons((x=list(7,sym,make_fixnum(0),make_fixnum(0),make_fixnum(0),make_fixnum(0),make_fixnum(0),make_fixnum(0))),sSAlink_listA->s.s_dbind); + else + x=x->c.c_car; + x=x->c.c_cdr; + if (listp(sym->s.s_gfdef)) + x->c.c_car=one_plus(x->c.c_car); + for (x=x->c.c_cdr,i=0;ic.c_cdr); + x->c.c_car=one_plus(x->c.c_car); +} + + +/* cleanup link */ +void +call_or_link(object sym, void **link) { + + object fun; + + fun = sym->s.s_gfdef; + if (fun == OBJNULL) { + FEinvalid_function(sym); + return; + } + + if (type_of(fun) == t_cclosure && (fun->cc.cc_turbo)) { + if (Rset==0) + MMccall(fun); + else + fun->cf.cf_self(fun); + return; + } + + if (Rset==0) + funcall(fun); + else if (type_of(fun) == t_cfun) { + (void) vpush_extend( link,sLAlink_arrayA->s.s_dbind); + (void) vpush_extend( *link,sLAlink_arrayA->s.s_dbind); + *link = (void *) (fun->cf.cf_self); + (*(void (*)())(fun->cf.cf_self))(); + } else { + append_link_list(sym,0); + funcall(fun); + } + +} + +void +call_or_link_closure(object sym, void **link, void **ptr) { + + object fun; + fun = sym->s.s_gfdef; + if (fun == OBJNULL) { + FEinvalid_function(sym); + return; + } + if (type_of(fun) == t_cclosure && (fun->cc.cc_turbo)) { + if (Rset) { + (void) vpush_extend( link,sLAlink_arrayA->s.s_dbind); + (void) vpush_extend( *link,sLAlink_arrayA->s.s_dbind); + *ptr = (void *)fun; + *link = (void *) (fun->cf.cf_self); + MMccall(fun); + } else { + append_link_list(sym,1); + MMccall(fun); + } + return; + } + if (Rset==0) + funcall(fun); + /* can't do this if invoking foo(a) is illegal when foo is not defined + to take any arguments. In the majority of C's this is legal */ + else if (type_of(fun) == t_cfun) { + (void) vpush_extend(link,sLAlink_arrayA->s.s_dbind); + (void) vpush_extend(*link,sLAlink_arrayA->s.s_dbind); + *link = (void *)fun->cf.cf_self; + (*(void (*)())fun->cf.cf_self)(); + } else { + append_link_list(sym,2); + funcall(fun); + } +} + +/* for pushing item into an array, where item is an address if array-type = t +or a fixnum if array-type = fixnum */ + +#define SET_ITEM(ar,ind,val) (*((object *)(&((ar)->ust.ust_self[ind]))))= val +static int +vpush_extend(void *item, object ar) +{ register int ind = ar->ust.ust_fillp; + AGAIN: + if (ind < ar->ust.ust_dim) + {SET_ITEM(ar,ind,item); + ind += sizeof(void *); + return(ar->v.v_fillp = ind);} + else + { + int newdim= ROUND_UP_PTR((2 + (int) (1.3 * ind))); + unsigned char *newself; + newself = (void *)alloc_relblock(newdim); + bcopy(ar->ust.ust_self,newself,ind); + ar->ust.ust_dim=newdim; + ar->ust.ust_self=newself; + goto AGAIN; + }} + + +/* if we unlink a bunch of functions, this will mean there are some + holes in the link array, and we should probably go through it and + push them back */ +static int number_unlinked=0; + +static void +delete_link(void *address, object link_ar) +{object *ar,*ar_end,*p; + p=0; + ar = link_ar->v.v_self; + ar_end = (object *)&(link_ar->ust.ust_self[link_ar->v.v_fillp]); + while (ar < ar_end) + { if (*ar && *((void **)*ar)==address) + { p = (object *) *ar; + *ar=0; + *p = *(ar+1); + number_unlinked++;} + ar=ar+2;} + if (number_unlinked > 40) + link_ar->v.v_fillp= + clean_link_array(link_ar->v.v_self,ar_end); } + + +DEFUN_NEW("USE-FAST-LINKS",object,fSuse_fast_links,SI,1,2,NONE,OO,OO,OO,OO,(object flag,...), + "Usage: (use-fast-links {nil,t} &optional fun) turns on or off \ +the fast linking depending on FLAG, so that things will either go \ +faster, or turns it off so that stack information is kept. If SYMBOL \ +is supplied and FLAG is nil, then this function is deleted from the fast links") +{int n = VFUN_NARGS; + object sym; + va_list ap; + object *p,*ar,*ar_end; + object link_ar; + object fun=Cnil; + +{ va_start(ap,flag); + if (n>=2) sym=va_arg(ap,object);else goto LDEFAULT2; + goto LEND_VARARG; + LDEFAULT2: sym = Cnil ; + LEND_VARARG: va_end(ap);} + + if (sLAlink_arrayA ==0) RETURN1(Cnil); + link_ar = sLAlink_arrayA->s.s_dbind; + if (link_ar==Cnil && flag==Cnil) RETURN1(Cnil); + check_type_array(&link_ar); + if (type_of(link_ar) != t_string) + { FEerror("*LINK-ARRAY* must be a string",0);} + ar = link_ar->v.v_self; + ar_end = (object *)&(link_ar->ust.ust_self[link_ar->v.v_fillp]); + switch (n) + { + case 1: + if (flag==Cnil) + { Rset=0; + while ( ar < ar_end) + /* set the link variables back to initial state */ + { + p = (object *) *ar; + if (p) *p = (ar++, *ar); else ar++; + ar++; + } + link_ar->v.v_fillp = 0; + } + else + { Rset=1;} + break; + case 2: + + if ((type_of(sym)==t_symbol)) + fun = sym->s.s_gfdef; + else + if (type_of(sym)==t_cclosure) + fun = sym; + else {FEerror("Second arg: ~a must be symbol or closure",0,sym); + } + if(Rset) + { + if(!fun) RETURN1(Cnil); + switch(type_of(fun)){ + case t_cfun: + case t_sfun: + case t_vfun: + case t_gfun: + case t_cclosure: + case t_closure: + case t_afun: + delete_link(fun->cf.cf_self,link_ar); + /* becoming obsolete + y=getf(sym->s.s_plist,sScdefn,Cnil); + if (y!=Cnil) + delete_link(fix(y),link_ar); + */ + + break; + default: + /* no link for uncompiled functions*/ + break; + } + } + break; + default: + FEerror("Usage: (use-fast-links {nil,t} &optional fun)",0); +} + RETURN1(Cnil); +} +object +fSuse_fast_links_2(object flag,object res) { + VFUN_NARGS=2; + return FFN(fSuse_fast_links)(flag,res); +} + + +object +clear_compiler_properties(object sym, object code) { + object tem; + extern object sSclear_compiler_properties; + + if (sSclear_compiler_properties && sSclear_compiler_properties->s.s_gfdef!=OBJNULL) + if ((sSAinhibit_macro_specialA && sSAinhibit_macro_specialA->s.s_dbind != Cnil) || + sym->s.s_sfdef == NOT_SPECIAL) + (void)ifuncall2(sSclear_compiler_properties,sym,code); + tem = getf(sym->s.s_plist,sStraced,Cnil); + + VFUN_NARGS=2; + FFN(fSuse_fast_links)(Cnil,sym); + return tem!=Cnil ? tem : sym; + +} + +static int +clean_link_array(object *ar, object *ar_end) +{int i=0; + object *orig; + orig=ar; + number_unlinked=0; + while( ars.s_gfdef; + if (fun && (type_of(fun)==t_sfun + || type_of(fun)==t_gfun + || type_of(fun)==t_afun + || type_of(fun)== t_vfun) + && Rset) {/* the && Rset is to allow tracing */ + + object (*fn)()=fun->sfn.sfn_self; + + if (type_of(fun)==t_vfun) { + + /* argd=VFUN_NARGS; */ /*remove this! */ + nargs=SFUN_NARGS(argd); + if (nargs < fun->vfn.vfn_minargs || nargs > fun->vfn.vfn_maxargs + || (argd & (SFUN_ARG_TYPE_MASK | SFUN_RETURN_MASK))) + goto WRONG_ARGS; + if ((VFUN_NARG_BIT & argd) == 0) { + /* don't link */ + VFUN_NARGS = nargs; + goto AFTER_LINK; + } + + } else if (type_of(fun)==t_afun) { + + ufixnum at=F_TYPES(fun->sfn.sfn_argd)>>F_TYPE_WIDTH; + ufixnum ma=F_MIN_ARGS(fun->sfn.sfn_argd); + ufixnum xa=F_MAX_ARGS(fun->sfn.sfn_argd); + ufixnum rt=F_RESULT_TYPE(fun->sfn.sfn_argd); + + nargs=SFUN_NARGS(argd); + if (nargs xa || ((argd>>8)&0x3)!=rt || (argd>>12)!=at) + goto WRONG_ARGS; + + } else {/* t_gfun,t_sfun */ + + nargs= SFUN_NARGS(argd); + if ((argd & (~VFUN_NARG_BIT)) != fun->sfn.sfn_argd) + goto WRONG_ARGS; + + } + + (void) vpush_extend(link,sLAlink_arrayA->s.s_dbind); + (void) vpush_extend(*link,sLAlink_arrayA->s.s_dbind); + *link = (void *)fn; + + AFTER_LINK: + + { + object *new; + COERCE_VA_LIST(new,ll,nargs); + return(c_apply_n_fun(fun,nargs,new)); + } + + } else /* there is no cdefn property */ + WRONG_ARGS: + { + /* regular_call: */ + object fun; + register object *base; + enum ftype result_type; + int i; + /* we check they are valid functions before calling this */ + + append_link_list(sym,3); + + fun=type_of(sym)==t_symbol ? symbol_function(sym) : sym; + vs_base=base=vs_top; + if (fun==OBJNULL) + FEinvalid_function(sym); + + nargs=SFUN_NARGS(argd); + result_type=SFUN_RETURN_TYPE(argd); + SFUN_START_ARG_TYPES(argd); + + + if (argd==0) + for (i=0;is.s_gfdef; + + if (fun && (type_of(fun)==t_sfun + || type_of(fun)==t_gfun + || type_of(fun)==t_afun + || type_of(fun)== t_vfun) + && Rset) {/* the && Rset is to allow tracing */ + + object (*fn)()=fun->sfn.sfn_self; + if (type_of(fun)==t_vfun) { + + nargs=SFUN_NARGS(argd); + if (nargs < fun->vfn.vfn_minargs || nargs > fun->vfn.vfn_maxargs + || (argd & (SFUN_ARG_TYPE_MASK | SFUN_RETURN_MASK))) + goto WRONG_ARGS; + if ((VFUN_NARG_BIT & argd) == 0) { + VFUN_NARGS = nargs; + goto AFTER_LINK; + } + + } else if (type_of(fun)==t_afun) { + + ufixnum at=F_TYPES(fun->sfn.sfn_argd)>>F_TYPE_WIDTH; + ufixnum ma=F_MIN_ARGS(fun->sfn.sfn_argd); + ufixnum xa=F_MAX_ARGS(fun->sfn.sfn_argd); + ufixnum rt=F_RESULT_TYPE(fun->sfn.sfn_argd); + + nargs=SFUN_NARGS(argd); + if (nargs xa || ((argd>>8)&0x3)!=rt || (argd>>12)!=at) + goto WRONG_ARGS; + + } else { /* t_gfun,t_sfun */ + + nargs= SFUN_NARGS(argd); + if ((argd & (~VFUN_NARG_BIT)) != fun->sfn.sfn_argd) + goto WRONG_ARGS; + + } + + (void) vpush_extend(link,sLAlink_arrayA->s.s_dbind); + (void) vpush_extend(*link,sLAlink_arrayA->s.s_dbind); + *link = (void *)fn; + + AFTER_LINK: + + { + object *new; + COERCE_VA_LIST_NEW(new,first,ll,nargs); + return(c_apply_n_fun(fun,nargs,new)); + } + + } else /* there is no cdefn property */ + WRONG_ARGS: + { + /* regular_call: */ + object fun; + register object *base; + enum ftype result_type; + int i; + + append_link_list(sym,4); + + /* we check they are valid functions before calling this */ + fun=type_of(sym)==t_symbol ? symbol_function(sym) : sym; + vs_base=base=vs_top; + if (fun==OBJNULL) + FEinvalid_function(sym); + + nargs=SFUN_NARGS(argd); + result_type=SFUN_RETURN_TYPE(argd); + SFUN_START_ARG_TYPES(argd); + + if (argd==0) + for (i=0;is.s_gfdef)==t_cfun) + (*(sym->s.s_gfdef)->cf.cf_self)(); + else super_funcall(sym); + x = vs_base[0]; + vs_top = old_vs_top; + vs_base = old_vs_base; + return(x); +} + + +/* static object */ +/* imfuncall(object sym,int n,...) */ +/* { va_list ap; */ +/* int i; */ +/* object *old_vs_top; */ +/* old_vs_top = vs_top; */ +/* vs_base = old_vs_top; */ +/* vs_top=old_vs_top+n; */ +/* vs_check; */ +/* va_start(ap,n); */ +/* for(i=0;is.s_gfdef)==t_cfun) */ +/* (*(sym->s.s_gfdef)->cf.cf_self)(); */ +/* else super_funcall(sym); */ +/* return(vs_base[0]); */ +/* } */ + +/* go from beg+1 below limit setting entries equal to 0 until you + come to FRESH 0's . */ + +#define FRESH 40 + +int +clear_stack(object *beg, object *limit) +{int i=0; + while (++beg < limit) + {if (*beg==0) i++; + if (i > FRESH) return 0; + ;*beg=0;} return 0;} + +static object +FFN(set_mv)(int i, object val) +{ if (i >= (sizeof(MVloc)/sizeof(object))) + FEerror("Bad mv index",0); + return(MVloc[i]=val); +} + + +static object +FFN(mv_ref)(unsigned int i) +{ object x; + if (i >= (sizeof(MVloc)/sizeof(object))) + FEerror("Bad mv index",0); + x = MVloc[i]; + return x; +} + + +#include "xdrfuns.c" + +DEF_ORDINARY("CDEFN",sScdefn,SI,""); +DEFVAR("*LINK-ARRAY*",sLAlink_arrayA,LISP,Cnil,""); + +void +gcl_init_links(void) +{ + + make_si_sfun("SET-MV",set_mv, ARGTYPE2(f_fixnum,f_object) | + RESTYPE(f_object)); + make_si_sfun("MV-REF",mv_ref, ARGTYPE1(f_fixnum) | RESTYPE(f_object)); + gcl_init_xdrfuns(); + } + diff --git a/o/funs b/o/funs new file mode 100755 index 0000000..f7ae0e4 --- /dev/null +++ b/o/funs @@ -0,0 +1,24 @@ +array.c:Iarray_element_type(x) +array.c:Idisplace_array(from,to,displaced_index_offset) +array.c:Icheck_displaced(displaced_list,ar,dim) +array.c:Iundisplace(ar) +error.c:Icall_error_handler(error_name,error_format_string,nfmt_args,va_alist) +eval.c:Ieval(form) +fasdump.c:IreadFasdData() +makefun.c:ImakeClosure(addr,argd,n,va_alist) +makefun.c:IsetClosure(x,n,ap) +nfunlink.c:Icall_proc(fun_name,link_desk,link_loc,ap) +nfunlink.c:Icall_proc_float(fun_name,link_desk,link_loc,ap) +nfunlink.c:IapplyVector(fun,nargs,base) +nfunlink.c:Iinvoke_c_function_from_value_stack(fLaref,F_ARGD(2,2,0,ARGTYPES(oo,io,oo,oo))); +nfunlink.c:Iinvoke_c_function_from_value_stack(f,fargd) +utils.c:IisSymbol(f) +utils.c:IisFboundp(f) +utils.c:IisArray(f) +utils.c:Iis_fixnum(f) +utils.c:Iapply_ap(f,ap) +utils.c:Ifuncall_n(fun,n,va_alist) +utils.c:Iapply_fun_n(fun,n,m,va_alist) +utils.c:ImakeStructure(n,p) +utils.c:Icheck_one_type(x,t) +utils.c:Ineed_in_image(foo) diff --git a/o/gbc.c b/o/gbc.c new file mode 100755 index 0000000..6be9f5f --- /dev/null +++ b/o/gbc.c @@ -0,0 +1,1654 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + + This file is part of GNU Common Lisp, herein referred to as GCL + + GCL is free software; you can redistribute it and/or modify it under + the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + GCL is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public + License for more details. + + You should have received a copy of the GNU Library General Public License + along with GCL; see the file COPYING. If not, write to the Free Software + Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +/* + GBC.c + IMPLEMENTATION-DEPENDENT +*/ + +#define DEBUG + +#define IN_GBC +#define NEED_MP_H +#include +#include +#include "include.h" +#include "page.h" + + +#ifdef SGC +static void +sgc_contblock_sweep_phase(void); + +static void +sgc_sweep_phase(void); + +static void +sgc_mark_phase(void); + +static fixnum +sgc_count_writable(void); + +#endif + +static void +mark_c_stack(jmp_buf, int, void (*)(void *,void *,int)); + +static void +mark_contblock(void *, int); + +static void +mark_object(object); + + +/* the following in line definitions seem to be twice as fast (at + least on mc68020) as going to the assembly function calls in bitop.c so + since this is more portable and faster lets use them --W. Schelter + These assume that DBEGIN is divisible by 32, or else we should have + #define Shamt(x) (((((int) x -DBEGIN) >> 2) & ~(~0 << 5))) +*/ +#define LOG_BITS_CHAR 3 + +#if CPTR_SIZE == 8 +#define LOG_BYTES_CONTBLOCK 3 +#elif CPTR_SIZE == 16 +#define LOG_BYTES_CONTBLOCK 4 +#else +#error Do not recognize CPTR_SIZE +#endif + +#ifdef CONTBLOCK_MARK_DEBUG +int +cb_check(void) { + struct contblock **cbpp; + struct pageinfo *v; + void *cbe; + + for (cbpp=&cb_pointer;*cbpp;cbpp=&((*cbpp)->cb_link)) { + v=get_pageinfo(*cbpp); + cbe=((void *)(*cbpp)+(*cbpp)->cb_size-1); + if (cbe>(void *)v+v->in_use*PAGESIZE) + return 1; + } + return 0; +} + +int +m_check(void) { + struct contblock **cbpp; + void *v,*ve,*p,*pe; + extern object malloc_list; + object l; + + for (l=malloc_list;l!=Cnil;l=l->c.c_cdr) { + p=l->c.c_car->st.st_self; + pe=p+l->c.c_car->st.st_dim; + for (cbpp=&cb_pointer;*cbpp;cbpp=&((*cbpp)->cb_link)) { + v=(void *)(*cbpp); + ve=(v+(*cbpp)->cb_size-1); + printf("%p %p %p %p\n",p,pe,v,ve); + if ((v<=p && p < ve)||(v=0); + massert(v+i<(void *)pi+pi->in_use*PAGESIZE); + massert(i<(ve-v)); + return 0; +} +#endif + + +inline struct pageinfo * +get_pageinfo(void *x) { + struct pageinfo *v=contblock_list_head;void *vv; + for (;(vv=v) && (vv>=x || vv+v->in_use*PAGESIZE<=x);v=v->next); + return v; +} + +inline char +get_bit(char *v,struct pageinfo *pi,void *x) { + void *ve=CB_DATA_START(pi); + fixnum off=(x-ve)>>LOG_BYTES_CONTBLOCK,i=off>>LOG_BITS_CHAR,s=off&~(~0UL<>s)&0x1; +} + +inline void +set_bit(char *v,struct pageinfo *pi,void *x) { + void *ve=CB_DATA_START(pi); + fixnum off=(x-ve)>>LOG_BYTES_CONTBLOCK,i=off>>LOG_BITS_CHAR,s=off&~(~0UL<>s)&0x1) +#define bit_set(v,i,s) (v[i]|=(1UL<>LOG_BYTES_CONTBLOCK;i=_o>>LOG_BITS_CHAR;s=_o&~(~0UL<++i1) memset(v+i1,-1,(i2-i1)); + for (;--s2>=0;) + bit_set(v,i2,s2); + +} + +inline void * +get_bits(char *v,struct pageinfo *pi,void *x) { + + void *ds=CB_DATA_START(pi),*de=CB_DATA_END(pi); + fixnum i,s,ie=mbytes(pi->in_use); + bool z; + char cz; + + ptr_set(x,ds,i,s); + z=bit_get(v,i,s); + cz=z?-1:0; + + for (;++s= MARK_ORIGIN_MAX) + error("too many mark origins"); + + mark_origin[mark_origin_max++] = p; + +} + +inline void +mark_cons(object x) { + + do { + object d=x->c.c_cdr; + mark(x); + mark_object(x->c.c_car); + x=d; + if (NULL_OR_ON_C_STACK(x) || is_marked_or_free(x))/*catches Cnil*/ + return; + } while (cdr_listp(x)); + mark_object(x); + +} + +/* Whenever two arrays are linked together by displacement, + if one is live, the other will be made live */ +#define mark_displaced_field(ar) mark_object(ar->a.a_displaced) + +#define LINK_ARRAY_MARKED(x_) ((*(unsigned long *)(x_))&0x1) +#define MARK_LINK_ARRAY(x_) ((*(unsigned long *)(x_))|=1UL) +#define CLEAR_LINK_ARRAY(x_) ((*(unsigned long *)(x_))&=~(1UL)) + +/* #define COLLECT_RELBLOCK_P (what_to_collect == t_relocatable || what_to_collect == t_contiguous) */ +bool collect_both=0; + +#define COLLECT_RELBLOCK_P (what_to_collect == t_relocatable || collect_both) + +static void +mark_link_array(void *v,void *ve) { + + void **p,**pe; + + if (NULL_OR_ON_C_STACK(v)) + return; + + if (sLAlink_arrayA->s.s_dbind==Cnil) + return; + + p=(void *)sLAlink_arrayA->s.s_dbind->v.v_self; + pe=(void *)p+sLAlink_arrayA->s.s_dbind->v.v_fillp; + + if (is_marked(sLAlink_arrayA->s.s_dbind) && COLLECT_RELBLOCK_P +#ifdef SGC + && (!sgc_enabled || SGC_RELBLOCK_P(sLAlink_arrayA->s.s_dbind->v.v_self)) +#endif + ) { + fixnum j=rb_pointer1-rb_pointer; + p=(void *)p+j; + pe=(void *)pe+j; + } + + for (;p=v && *ps.s_dbind==Cnil) + return; + + ne=n=p=(void *)sLAlink_arrayA->s.s_dbind->v.v_self; + pe=(void *)p+sLAlink_arrayA->s.s_dbind->v.v_fillp; + + while (ps.s_dbind->v.v_fillp=(ne-n)*sizeof(*n); + +} + + +static void +sweep_link_array(void) { + + void ***p,***pe; + + if (sLAlink_arrayA->s.s_dbind==Cnil) + return; + + p=(void *)sLAlink_arrayA->s.s_dbind->v.v_self; + pe=(void *)p+sLAlink_arrayA->s.s_dbind->v.v_fillp; + for (;prat.rat_num); + x = x->rat.rat_den; + goto BEGIN; + + case t_shortfloat: + break; + + case t_longfloat: + break; + + case t_complex: + mark_object(x->cmp.cmp_imag); + x = x->cmp.cmp_real; + goto BEGIN; + + case t_character: + break; + + case t_symbol: + mark_object(x->s.s_plist); + mark_object(x->s.s_gfdef); + mark_object(x->s.s_dbind); + if (x->s.s_self == NULL) + break; + if (inheap(x->s.s_self)) { + if (what_to_collect == t_contiguous) + mark_contblock(x->s.s_self,x->s.s_fillp); + } else if (COLLECT_RELBLOCK_P) + x->s.s_self = copy_relblock(x->s.s_self, x->s.s_fillp); + break; + + case t_package: + mark_object(x->p.p_name); + mark_object(x->p.p_nicknames); + mark_object(x->p.p_shadowings); + mark_object(x->p.p_uselist); + mark_object(x->p.p_usedbylist); + if (what_to_collect != t_contiguous) + break; + if (x->p.p_internal != NULL) + mark_contblock((char *)(x->p.p_internal), + x->p.p_internal_size*sizeof(object)); + if (x->p.p_external != NULL) + mark_contblock((char *)(x->p.p_external), + x->p.p_external_size*sizeof(object)); + break; + + case t_hashtable: + mark_object(x->ht.ht_rhsize); + mark_object(x->ht.ht_rhthresh); + if (x->ht.ht_self == NULL) + break; + for (i = 0, j = x->ht.ht_size; i < j; i++) { + mark_object(x->ht.ht_self[i].hte_key); + mark_object(x->ht.ht_self[i].hte_value); + } + if (inheap(x->ht.ht_self)) { + if (what_to_collect == t_contiguous) + mark_contblock((char *)x->ht.ht_self,j*sizeof(struct htent)); + } else if (COLLECT_RELBLOCK_P) + x->ht.ht_self=(void *)copy_relblock((char *)x->ht.ht_self,j*sizeof(struct htent));; + break; + + case t_array: + if ((x->a.a_displaced) != Cnil) + mark_displaced_field(x); + if (x->a.a_dims != NULL) { + if (inheap(x->a.a_dims)) { + if (what_to_collect == t_contiguous) + mark_contblock((char *)(x->a.a_dims),sizeof(int)*x->a.a_rank); + } else if (COLLECT_RELBLOCK_P) + x->a.a_dims = (int *) copy_relblock((char *)(x->a.a_dims),sizeof(int)*x->a.a_rank); + } + if ((enum aelttype)x->a.a_elttype == aet_ch) + goto CASE_STRING; + if ((enum aelttype)x->a.a_elttype == aet_bit) + goto CASE_BITVECTOR; + if ((enum aelttype)x->a.a_elttype == aet_object) + goto CASE_GENERAL; + + CASE_SPECIAL: + cp = (char *)(x->fixa.fixa_self); + if (cp == NULL) + break; + /* set j to the size in char of the body of the array */ + + switch((enum aelttype)x->a.a_elttype){ +#define ROUND_RB_POINTERS_DOUBLE \ +{int tem = ((long)rb_pointer1) & (sizeof(double)-1); \ + if (tem) \ + { rb_pointer += (sizeof(double) - tem); \ + rb_pointer1 += (sizeof(double) - tem); \ + }} + case aet_lf: + j= sizeof(longfloat)*x->lfa.lfa_dim; + if ((COLLECT_RELBLOCK_P) && !(inheap(cp))) + ROUND_RB_POINTERS_DOUBLE;/*FIXME gc space violation*/ + break; + case aet_char: + case aet_uchar: + j=sizeof(char)*x->a.a_dim; + break; + case aet_short: + case aet_ushort: + j=sizeof(short)*x->a.a_dim; + break; + default: + j=sizeof(fixnum)*x->fixa.fixa_dim;} + + goto COPY; + + CASE_GENERAL: + p = x->a.a_self; + if (p == NULL +#ifdef HAVE_ALLOCA + || (char *)p >= core_end +#endif + ) + break; + j=0; + if (x->a.a_displaced->c.c_car == Cnil) + for (i = 0, j = x->a.a_dim; i < j; i++) + mark_object(p[i]); + cp = (char *)p; + j *= sizeof(object); + COPY: + if (inheap(cp)) { + if (what_to_collect == t_contiguous) + mark_contblock(cp, j); + } else if (COLLECT_RELBLOCK_P) { + if (x->a.a_displaced == Cnil) { +#ifdef HAVE_ALLOCA + if (!NULL_OR_ON_C_STACK(cp)) /* only if body of array not on C stack */ +#endif + x->a.a_self = (object *)copy_relblock(cp, j); + } else if (x->a.a_displaced->c.c_car == Cnil) { + i = (long)(object *)copy_relblock(cp, j) - (long)(x->a.a_self); + adjust_displaced(x, i); + } + } + break; + + case t_vector: + if ((x->v.v_displaced) != Cnil) + mark_displaced_field(x); + if ((enum aelttype)x->v.v_elttype == aet_object) + goto CASE_GENERAL; + else + goto CASE_SPECIAL; + + case t_bignum: +#ifndef GMP_USE_MALLOC + if ((int)what_to_collect >= (int)t_contiguous) { + j = MP_ALLOCATED(x); + cp = (char *)MP_SELF(x); + if (cp == 0) + break; +#ifdef PARI + if (j != lg(MP(x)) && + /* we don't bother to zero this register, + and its contents may get over written */ + ! (x == big_register_1 && + (int)(cp) <= top && + (int) cp >= bot)) + printf("bad length 0x%x ",x); +#endif + j = j * MP_LIMB_SIZE; + if (inheap(cp)) { + if (what_to_collect == t_contiguous) + mark_contblock(cp, j); + } else if (COLLECT_RELBLOCK_P) { + MP_SELF(x) = (void *) copy_relblock(cp, j);}} +#endif /* not GMP_USE_MALLOC */ + break; + + CASE_STRING: + case t_string: + if ((x->st.st_displaced) != Cnil) + mark_displaced_field(x); + j = x->st.st_dim; + cp = x->st.st_self; + if (cp == NULL) + break; + COPY_STRING: + if (inheap(cp)) { + if (what_to_collect == t_contiguous) + mark_contblock(cp, j); + } else if (COLLECT_RELBLOCK_P) { + if (x->st.st_displaced == Cnil) + x->st.st_self = copy_relblock(cp, j); + else if (x->st.st_displaced->c.c_car == Cnil) { + i = copy_relblock(cp, j) - cp; + adjust_displaced(x, i); + } + } + break; + + CASE_BITVECTOR: + case t_bitvector: + if ((x->bv.bv_displaced) != Cnil) + mark_displaced_field(x); + /* We make bitvectors multiple of sizeof(int) in size allocated + Assume 8 = number of bits in char */ + +#define W_SIZE (8*sizeof(fixnum)) + j= sizeof(fixnum) * + ((BV_OFFSET(x) + x->bv.bv_dim + W_SIZE -1)/W_SIZE); + cp = x->bv.bv_self; + if (cp == NULL) + break; + goto COPY_STRING; + + case t_structure: + mark_object(x->str.str_def); + p = x->str.str_self; + if (p == NULL) + break; + { + object def=x->str.str_def; + unsigned char * s_type = &SLOT_TYPE(def,0); + unsigned short *s_pos= & SLOT_POS(def,0); + for (i = 0, j = S_DATA(def)->length; i < j; i++) + if (s_type[i]==0) mark_object(STREF(object,x,s_pos[i])); + if (inheap(x->str.str_self)) { + if (what_to_collect == t_contiguous) + mark_contblock((char *)p,S_DATA(def)->size); + } else if (COLLECT_RELBLOCK_P) + x->str.str_self = (object *)copy_relblock((char *)p, S_DATA(def)->size); + } + break; + + case t_stream: + switch (x->sm.sm_mode) { + case smm_input: + case smm_output: + case smm_io: + case smm_socket: + case smm_probe: + mark_object(x->sm.sm_object0); + mark_object(x->sm.sm_object1); + if (what_to_collect == t_contiguous && + x->sm.sm_fp && + x->sm.sm_buffer) + mark_contblock(x->sm.sm_buffer, BUFSIZ); + break; + + case smm_synonym: + mark_object(x->sm.sm_object0); + break; + + case smm_broadcast: + case smm_concatenated: + mark_object(x->sm.sm_object0); + break; + + case smm_two_way: + case smm_echo: + mark_object(x->sm.sm_object0); + mark_object(x->sm.sm_object1); + break; + + case smm_string_input: + case smm_string_output: + mark_object(x->sm.sm_object0); + break; +#ifdef USER_DEFINED_STREAMS + case smm_user_defined: + mark_object(x->sm.sm_object0); + mark_object(x->sm.sm_object1); + break; +#endif + default: + error("mark stream botch"); + } + break; + +#define MARK_CP(a_,b_) {fixnum _t=(b_);if (inheap(a_)) {\ + if (what_to_collect == t_contiguous) mark_contblock((void *)(a_),_t); \ + } else if (COLLECT_RELBLOCK_P) (a_)=(void *)copy_relblock((void *)(a_),_t);} + +#define MARK_MP(a_) {if ((a_)->_mp_d) \ + MARK_CP((a_)->_mp_d,(a_)->_mp_alloc*MP_LIMB_SIZE);} + + case t_random: + if ((int)what_to_collect >= (int)t_contiguous) { + MARK_MP(x->rnd.rnd_state._mp_seed); +#if __GNU_MP_VERSION < 4 || (__GNU_MP_VERSION == 4 && __GNU_MP_VERSION_MINOR < 2) + if (x->rnd.rnd_state._mp_algdata._mp_lc) { + MARK_MP(x->rnd.rnd_state._mp_algdata._mp_lc->_mp_a); + if (!x->rnd.rnd_state._mp_algdata._mp_lc->_mp_m2exp) MARK_MP(x->rnd.rnd_state._mp_algdata._mp_lc->_mp_m); + MARK_CP(x->rnd.rnd_state._mp_algdata._mp_lc,sizeof(*x->rnd.rnd_state._mp_algdata._mp_lc)); + } +#endif + } + break; + + case t_readtable: + if (x->rt.rt_self == NULL) + break; + if (what_to_collect == t_contiguous) + mark_contblock((char *)(x->rt.rt_self), + RTABSIZE*sizeof(struct rtent)); + for (i = 0; i < RTABSIZE; i++) { + mark_object(x->rt.rt_self[i].rte_macro); + if (x->rt.rt_self[i].rte_dtab != NULL) { + /**/ + if (what_to_collect == t_contiguous) + mark_contblock((char *)(x->rt.rt_self[i].rte_dtab), + RTABSIZE*sizeof(object)); + for (j = 0; j < RTABSIZE; j++) + mark_object(x->rt.rt_self[i].rte_dtab[j]); + /**/ + } + } + break; + + case t_pathname: + mark_object(x->pn.pn_host); + mark_object(x->pn.pn_device); + mark_object(x->pn.pn_directory); + mark_object(x->pn.pn_name); + mark_object(x->pn.pn_type); + mark_object(x->pn.pn_version); + break; + + case t_closure: + { + int i ; + for (i= 0 ; i < x->cl.cl_envdim ; i++) + mark_object(x->cl.cl_env[i]); + if (COLLECT_RELBLOCK_P) + x->cl.cl_env=(void *)copy_relblock((void *)x->cl.cl_env,x->cl.cl_envdim*sizeof(object)); + } + + case t_cfun: + case t_sfun: + case t_vfun: + case t_afun: + case t_gfun: + mark_object(x->cf.cf_name); + mark_object(x->cf.cf_data); + break; + + case t_cfdata: + + if (x->cfd.cfd_self != NULL) + {int i=x->cfd.cfd_fillp; + while(i-- > 0) + mark_object(x->cfd.cfd_self[i]);} + if (what_to_collect == t_contiguous) { + mark_contblock(x->cfd.cfd_start, x->cfd.cfd_size); + mark_link_array(x->cfd.cfd_start,x->cfd.cfd_start+x->cfd.cfd_size); + } + break; + case t_cclosure: + mark_object(x->cc.cc_name); + mark_object(x->cc.cc_env); + mark_object(x->cc.cc_data); + if (x->cc.cc_turbo!=NULL) { + mark_object(*(x->cc.cc_turbo-1)); + if (COLLECT_RELBLOCK_P) + x->cc.cc_turbo=(void *)copy_relblock((char *)(x->cc.cc_turbo-1),(1+fix(*(x->cc.cc_turbo-1)))*sizeof(object))+sizeof(object); + } + break; + + case t_spice: + break; + default: +#ifdef DEBUG + if (debug) + printf("\ttype = %d\n", type_of(x)); +#endif + error("mark botch"); + } +} + +static long *c_stack_where; + +void **contblock_stack_list=NULL; + +#define PAGEINFO_P(pi) (pi->magic==PAGE_MAGIC && pi->type<=t_contiguous) + +#ifdef SGC +static void +sgc_mark_object1(object); +#endif + +static void +mark_stack_carefully(void *topv, void *bottomv, int offset) { + + long pageoffset; + long p; + object x; + struct typemanager *tm; + register long *j; + long *top=topv,*bottom=bottomv; + + /* if either of these happens we are marking the C stack + and need to use a local */ + + if (top==0) top = c_stack_where; + if (bottom==0) bottom= c_stack_where; + + /* On machines which align local pointers on multiple of 2 rather + than 4 we need to mark twice + */ + + if (offset) + mark_stack_carefully((((char *) top) +offset),bottom,0); + + for (j=top ; j >= bottom ; j--) { + + void *v=(void *)(*j),**a; + struct pageinfo *pi; + + if (!VALID_DATA_ADDRESS_P(v)) continue; + + if ((p=page(v))type); + if (tm->tm_type>=t_end) continue; + + if (pageoffset<0 || pageoffset>=tm->tm_size*tm->tm_nppage) continue; + + x=(object)(v-pageoffset%tm->tm_size); + + if (is_marked_or_free(x)) continue; + +#ifdef SGC + if (sgc_enabled) + sgc_mark_object(x); + else +#endif + mark_object(x); + } +} + + +static void +mark_phase(void) { + + STATIC fixnum i, j; + STATIC struct package *pp; + STATIC bds_ptr bdp; + STATIC frame_ptr frp; + STATIC ihs_ptr ihsp; + + mark_object(Cnil->s.s_plist); + mark_object(Ct->s.s_plist); + + mark_stack_carefully(vs_top-1,vs_org,0); + mark_stack_carefully(MVloc+(sizeof(MVloc)/sizeof(object)),MVloc,0); + +#ifdef DEBUG + if (debug) { + printf("value stack marked\n"); + fflush(stdout); + } +#endif + + 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); + + for (ihsp = ihs_org; ihsp <= ihs_top; ihsp++) + mark_object(ihsp->ihs_function); + + for (i = 0; i < mark_origin_max; i++) + mark_object(*mark_origin[i]); + for (i = 0; i < mark_origin_block_max; i++) + for (j = 0; j < mark_origin_block[i].mob_size; j++) + mark_object(mark_origin_block[i].mob_addr[j]); + + for (pp = pack_pointer; pp != NULL; pp = pp->p_link) + mark_object((object)pp); +#ifdef KCLOVM + if (ovm_process_created) + mark_all_stacks(); +#endif + +#ifdef DEBUG + if (debug) { + printf("symbol navigation\n"); + fflush(stdout); + } +#endif + + /* + if (what_to_collect != t_symbol && + (int)what_to_collect < (int)t_contiguous) { + */ + + {int size; + + for (pp = pack_pointer; pp != NULL; pp = pp->p_link) { + size = pp->p_internal_size; + if (pp->p_internal != NULL) + for (i = 0; i < size; i++) + mark_object(pp->p_internal[i]); + size = pp->p_external_size; + if (pp->p_external != NULL) + for (i = 0; i < size; i++) + mark_object(pp->p_external[i]); + }} + + /* mark the c stack */ +#ifndef N_RECURSION_REQD +#define N_RECURSION_REQD 2 +#endif + mark_c_stack(0,N_RECURSION_REQD,mark_stack_carefully); + +} + +#if defined(__ia64__) + asm(" .text"); + asm(" .psr abi64"); + asm(" .psr lsb"); + asm(" .lsb"); + asm(""); + asm(" .text"); + asm(" .align 16"); + asm(" .global GC_save_regs_in_stack"); + asm(" .proc GC_save_regs_in_stack"); + asm("GC_save_regs_in_stack:"); + asm(" .body"); + asm(" flushrs"); + asm(" ;;"); + asm(" mov r8=ar.bsp"); + asm(" br.ret.sptk.few rp"); + asm(" .endp GC_save_regs_in_stack"); + +void * GC_save_regs_in_stack(); +#endif + +#if defined(__hppa__) /* Courtesy of Lamont Jones */ +/* the calling sequence */ +struct regs { + void *callee_saves[16]; +}; +void hppa_save_regs(struct regs); + +/* the code */ + + asm(".code"); + asm(".export hppa_save_regs, entry"); + asm(".proc"); + asm(".callinfo"); + asm(".label hppa_save_regs"); + asm(".entry"); + + asm("stw %r3,0(%arg0)"); + asm("stw %r4,4(%arg0)"); + asm("stw %r5,8(%arg0)"); + asm("stw %r6,12(%arg0)"); + asm("stw %r7,16(%arg0)"); + asm("stw %r8,20(%arg0)"); + asm("stw %r9,24(%arg0)"); + asm("stw %r10,28(%arg0)"); + asm("stw %r11,32(%arg0)"); + asm("stw %r12,36(%arg0)"); + asm("stw %r13,40(%arg0)"); + asm("stw %r14,44(%arg0)"); + asm("stw %r15,48(%arg0)"); + asm("stw %r16,52(%arg0)"); + asm("stw %r17,56(%arg0)"); + asm("bv 0(%rp)"); + asm("stw %r18,60(%arg0)"); + + asm(".exit"); + asm(".procend"); + asm(".end"); +#endif + +static void +mark_c_stack(jmp_buf env1, int n, void (*fn)(void *,void *,int)) { + +#if defined(__hppa__) + struct regs hppa_regs; +#endif + jmp_buf env; + int where; + if (n== N_RECURSION_REQD) + c_stack_where = (long *) (void *) &env; + if (n > 0 ) { +#if defined(__hppa__) + hppa_save_regs(hppa_regs); +#else + setjmp(env); +#endif + mark_c_stack(env,n - 1,fn); + } else { + + /* If the locals of type object in a C function could be + aligned other than on multiples of sizeof (char *) + then define this. At the moment 2 is the only other + legitimate value besides 0 */ + +#ifndef C_GC_OFFSET +#define C_GC_OFFSET 0 +#endif + { + struct pageinfo *v,*tv;void **a; + fixnum i; + for (v=contblock_list_head,contblock_stack_list=NULL;v;v=v->next) + for (i=1;iin_use;i++) { + tv=pagetoinfo(page(v)+i); + if (PAGEINFO_P(tv)) { + a=contblock_stack_list; + /* printf("%p\n",tv); */ + contblock_stack_list=alloca(2*sizeof(a)); + contblock_stack_list[0]=tv; + contblock_stack_list[1]=a; + }} + + if (&where > cs_org) + (*fn)(0,cs_org,C_GC_OFFSET); + else + (*fn)(cs_org,0,C_GC_OFFSET); + + contblock_stack_list=NULL; + }} + +#if defined(__ia64__) + { + extern void * __libc_ia64_register_backing_store_base; + void * bst=GC_save_regs_in_stack(); + void * bsb=__libc_ia64_register_backing_store_base; + + if (bsb>bst) + (*fn)(bsb,bst,C_GC_OFFSET); + else + (*fn)(bst,bsb,C_GC_OFFSET); + + } +#endif + +} + +static void +sweep_phase(void) { + + STATIC long j, k; + STATIC object x; + STATIC char *p; + STATIC struct typemanager *tm; + STATIC object f; + STATIC struct pageinfo *v; + + for (v=cell_list_head;v;v=v->next) { + + tm = tm_of((enum type)v->type); + + p = pagetochar(page(v)); + f = tm->tm_free; + k = 0; + for (j = tm->tm_nppage; j > 0; --j, p += tm->tm_size) { + x = (object)p; + if (is_free(x)) + continue; + else if (is_marked(x)) { + unmark(x); + continue; + } + + SET_LINK(x,f); + make_free(x); + f = x; + k++; + } + tm->tm_free = f; + tm->tm_nfree += k; + pagetoinfo(page(v))->in_use-=k; + + } + +} + +static void +contblock_sweep_phase(void) { + + STATIC char *s, *e, *p, *q; + STATIC struct contblock *cbp; + STATIC struct pageinfo *v; + + cb_pointer = NULL; + ncb = 0; + + for (v=contblock_list_head;v;v=v->next) { + bool z; + + s=CB_DATA_START(v); + e=(void *)v+v->in_use*PAGESIZE; + + z=get_mark_bit(v,s); + for (p=s;pcb_link) + printf("%d-byte contblock\n", cbp->cb_size); + fflush(stdout); + } +#endif + + sweep_link_array(); + +} + + +int (*GBC_enter_hook)() = NULL; +int (*GBC_exit_hook)() = NULL; +char *old_rb_start; + +/* void */ +/* ttss(void) { */ + +/* struct typemanager *tm; */ +/* void *x,*y; */ + +/* for (tm=tm_table;tmtm_free;x!=OBJNULL;x=(void *)((struct freelist *)x)->f_link) { */ +/* if (x==Cnil) */ +/* printf("barr\n"); */ +/* /\* for (y=(void *)((struct freelist *)x)->f_link;y!=OBJNULL && y!=x;y=(void *)((struct freelist *)y)->f_link); *\/ */ +/* /\* if (y==x) *\/ */ +/* /\* printf("circle\n"); *\/ */ +/* } */ +/* } */ + +/* } */ + +fixnum fault_pages=0; + +void +GBC(enum type t) { + + long i,j; +#ifdef SGC + int in_sgc = sgc_enabled; +#endif +#ifdef DEBUG + int tm=0; +#endif + + BEGIN_NO_INTERRUPT; + + if (t==t_other) { + collect_both=1; + t=t_contiguous; + } + + if (in_signal_handler && t == t_relocatable) + error("cant gc relocatable in signal handler"); + + if (GBC_enter_hook != NULL) + (*GBC_enter_hook)(); + + if (!GBC_enable) + error("GBC is not enabled"); + interrupt_enable = FALSE; + + if (saving_system) { + + struct pageinfo *v; + void *x; + struct typemanager *tm=tm_of(t_stream); + unsigned j; + + for (v=cell_list_head;v;v=v->next) + if (tm->tm_type==v->type) + for (x=pagetochar(page(v)),j=tm->tm_nppage;j--;x+=tm->tm_size) { + object o=x; + if (type_of(o)==t_stream && !is_free(o) && o->sm.sm_fp && o->sm.sm_fp!=stdin && o->sm.sm_fp!=stdout) + close_stream(o); + } + + t = t_relocatable; gc_time = -1; +#ifdef SGC + if(sgc_enabled) sgc_quit(); +#endif + } + + +#ifdef DEBUG + debug = symbol_value(sSAgbc_messageA) != Cnil; +#endif + + what_to_collect = t; + + tm_table[(int)t].tm_gbccount++; + tm_table[(int)t].tm_adjgbccnt++; + +#ifdef DEBUG + if (debug || (sSAnotify_gbcA->s.s_dbind != Cnil)) { + + if (gc_time < 0) gc_time=0; +#ifdef SGC + printf("[%s for %ld %s pages..", + (sgc_enabled ? "SGC" : "GC"), + (sgc_enabled ? sgc_count_type(t) : tm_of(t)->tm_npage), + (tm_table[(int)t].tm_name)+1); +#else + printf("[%s for %ld %s pages..", + ("GC"), + (tm_of(t)->tm_npage), + (tm_table[(int)t].tm_name)+1); +#endif +#ifdef SGC + if(sgc_enabled) + printf("(%ld faulted pages, %ld writable, %ld read only)..",fault_pages,sgc_count_writable(), + (page(core_end)-first_data_page)-(page(old_rb_start)-page(heap_end))-sgc_count_writable()); +#endif + fflush(stdout); + } +#endif + if (gc_time >=0 && !gc_recursive++) {gc_start=runtime();} + + /* maxpage = page(heap_end); */ + + if (COLLECT_RELBLOCK_P) { + + i=rb_pointer-REAL_RB_START+PAGESIZE;/*FIXME*/ + +#ifdef SGC + if (sgc_enabled==0) +#endif + rb_start = heap_end + PAGESIZE*holepage; + + rb_end = heap_end + (holepage + nrbpage) *PAGESIZE; + + if (rb_start < rb_pointer) + rb_start1 = (char *) + ((long)(rb_pointer + PAGESIZE-1) & -(unsigned long)PAGESIZE); + else + rb_start1 = rb_start; + + /* as we walk through marking data, we replace the + relocatable pointers + in objects by the rb_pointer, advance that + by the size, and copy the actual + data there to rb_pointer1, and advance it by the size + at the end [rb_start1,rb_pointer1] is copied + to [rb_start,rb_pointer] + */ + rb_pointer = rb_start; /* where the new relblock will start */ + rb_pointer1 = rb_start1;/* where we will copy it to during gc*/ + + i = (rb_end < (rb_start1 + i) ? (rb_start1 + i) : rb_end) - heap_end; + alloc_page(-(i + PAGESIZE - 1)/PAGESIZE); + + } + +#ifdef DEBUG + if (debug) { + printf("mark phase\n"); + fflush(stdout); + tm = runtime(); + } +#endif +#ifdef SGC + if(sgc_enabled) + { if (t < t_end && tm_of(t)->tm_sgc == 0) + {sgc_quit(); + if (sSAnotify_gbcA->s.s_dbind != Cnil) + {fprintf(stdout, " (doing full gc)"); + fflush(stdout);} + mark_phase();} + else + sgc_mark_phase();} + else +#endif + mark_phase(); +#ifdef DEBUG + if (debug) { + printf("mark ended (%d)\n", runtime() - tm); + fflush(stdout); + } +#endif + +#ifdef DEBUG + if (debug) { + printf("sweep phase\n"); + fflush(stdout); + tm = runtime(); + } +#endif +#ifdef SGC + if(sgc_enabled) + sgc_sweep_phase(); + else +#endif + sweep_phase(); +#ifdef DEBUG + if (debug) { + printf("sweep ended (%d)\n", runtime() - tm); + fflush(stdout); + } +#endif + + if (COLLECT_RELBLOCK_P) { + + if (rb_start < rb_start1) { + j = (rb_pointer-rb_start + PAGESIZE - 1)/PAGESIZE; + memmove(rb_start,rb_start1,j*PAGESIZE); + } + +#ifdef SGC + if (sgc_enabled) + wrimap=(void *)sSAwritableA->s.s_dbind->v.v_self; +#endif + +#ifdef SGC + /* we don't know which pages have relblock on them */ + if(sgc_enabled) { + fixnum i; + for (i=page(rb_start);i=0 && !--gc_recursive) {gc_time=gc_time+(gc_start=(runtime()-gc_start));} + + if (sSAnotify_gbcA->s.s_dbind != Cnil) { + + if (gc_recursive) + fprintf(stdout, "(T=...).GC finished]\n"); + else + fprintf(stdout, "(T=%d).GC finished]\n",gc_start); + fflush(stdout); + + } + + { + extern long opt_maxpage(struct typemanager *); + +#define IGNORE_MAX_PAGES (sSAignore_maximum_pagesA ==0 || sSAignore_maximum_pagesA->s.s_dbind !=sLnil) +#define OPTIMIZE_MAX_PAGES (sSAoptimize_maximum_pagesA ==0 || sSAoptimize_maximum_pagesA->s.s_dbind !=sLnil) + + if (IGNORE_MAX_PAGES && OPTIMIZE_MAX_PAGES) + opt_maxpage(tm_table+t); + + } + + collect_both=0; + + END_NO_INTERRUPT; + + CHECK_INTERRUPT; + + /* ttss(); */ + +} + +static void +FFN(siLheap_report)(void) { + + int i; + + check_arg(0); + + vs_check_push(make_fixnum(sizeof(fixnum)*CHAR_SIZE)); + vs_push(make_fixnum(PAGESIZE)); + vs_push(make_fixnum((ufixnum)data_start)); + vs_push(make_fixnum((ufixnum)data_start+(real_maxpage<>1)); + vs_push(make_fixnum(CSTACK_ALIGNMENT)); + vs_push(make_fixnum(abs(cs_limit-cs_org)));/*CSSIZE*/ +#if defined(IM_FIX_BASE) && defined(IM_FIX_LIM) +#ifdef LOW_IM_FIX + vs_push(make_fixnum(-LOW_IM_FIX)); + vs_push(make_fixnum(1UL<= 0) */ + /* { *q++ = *p++;} */ + + return res; +} + + +static void +mark_contblock(void *p, int s) { + + STATIC char *q; + STATIC char *x, *y; + struct pageinfo *v; + + if (NULL_OR_ON_C_STACK(p)) + return; + + q = p + s; + /* SGC cont pages: contblock pages must be no smaller than + sizeof(struct contblock). CM 20030827 */ + x = (char *)ROUND_DOWN_PTR_CONT(p); + y = (char *)ROUND_UP_PTR_CONT(q); + v=get_pageinfo(x); +#ifdef SGC + if (!sgc_enabled || (v->sgc_flags&SGC_PAGE_FLAG)) +#endif + set_mark_bits(v,x,y); +} + +DEFUN_NEW("GBC",object,fLgbc,LISP,1,1,NONE,OO,OO,OO,OO,(object x0),"") { + + /* 1 args */ + + if (x0 == Ct) + GBC(t_other); + else if (x0 == Cnil) + GBC(t_cons); + else if (eql(small_fixnum(0),x0)) + GBC(t_contiguous); + else { + x0 = small_fixnum(1); + GBC(t_relocatable); + } + RETURN1(x0); +} + +static void +FFN(siLgbc_time)(void) { + if (vs_top>vs_base) + gc_time=fix(vs_base[0]); + else { + vs_base[0]=make_fixnum(gc_time); + vs_top=vs_base+1; + } +} + +#ifdef SGC +#include "sgbc.c" +#endif + +DEFVAR("*NOTIFY-GBC*",sSAnotify_gbcA,SI,Cnil,""); +#ifdef DEBUG +DEFVAR("*GBC-MESSAGE*",sSAgbc_messageA,SI,Cnil,""); +#endif + +void +gcl_init_GBC(void) { + + make_si_function("HEAP-REPORT", siLheap_report); + make_si_function("ROOM-REPORT", siLroom_report); + make_si_function("RESET-GBC-COUNT", siLreset_gbc_count); + make_si_function("GBC-TIME",siLgbc_time); +#ifdef SGC + make_si_function("SGC-ON",siLsgc_on); +#endif + +} diff --git a/o/gcl_readline.d b/o/gcl_readline.d new file mode 100644 index 0000000..e3fdc1e --- /dev/null +++ b/o/gcl_readline.d @@ -0,0 +1,392 @@ +/* + Copyright (C) 2000 Tuukka Toivonen + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +*/ + +/* + readline.d + + Here we have GNU Readline 4.0 library interface. +*/ + +#define IN_READLINE +#include "include.h" + +#ifdef HAVE_READLINE + +/* Here begins GNU Readline support. It was designed for Maxima, + * but it works with GCL fine too. If you want to include word completion + * code, define RL_COMPLETION, else undefine it. + * Todo: context sensitive completion, optional keywords. + * To support Readline, we define wrappers (emulation) for putc/ungetc. + * by Tuukka Toivonen 2000-07-25, 2000-10-2. + */ + +#define RL_COMPLETION + +#include +#include +#include +#include +#include + +int readline_on = 0; /* On (1) or off (0) */ +static int rl_ungetc_em_char = -1; +static char *rl_putc_em_line = NULL; + +#ifdef RL_COMPLETION + + +/* New completion generator avoids malloc excet where required, and + dynamically searches current package lists -- 20040102 CM */ + +/* FIXME -- consider mapping malloc to alloca for this function only */ + +DEFVAR("*READLINE-PREFIX*",sSAreadline_prefixA,SI,Cnil,""); + +static char * +rl_completion_words(const char *text, int state) { + + static int i,len,internal,size,prefl; + static object package,use,tp,*base,l; + static const char *ftext,*wtext,*pref; + + if (state==0) { + const char *mch,*fmch,*temp,*temp1,*fpref; + int fprefl; + + fpref=pref=fmch=NULL; + fprefl=prefl=0; + if (type_of(sSAreadline_prefixA->s.s_dbind)==t_string) { + pref=fpref=sSAreadline_prefixA->s.s_dbind->st.st_self; + prefl=fprefl=sSAreadline_prefixA->s.s_dbind->st.st_fillp; + if ((fmch=memchr(fpref,':',fprefl))) { + pref=fmch[1]==':' ? fmch+2 : fmch+1; + prefl-=pref-fpref; + } + } + + mch=strchr(text,':'); + if (!mch) { + temp=fmch; + temp1=fpref; + } else { + temp=mch; + temp1=text; + pref=NULL; + prefl=0; + } + + if (!temp) + package=sLApackageA->s.s_dbind; + else { + if (temp==temp1) + package=(temp[1]==':') ? sLApackageA->s.s_dbind : keyword_package; + else { + static struct string st; + set_type_of(&st,t_string); + st.st_self=(char *)temp1; + st.st_fillp=st.st_dim=temp-temp1; + st.st_hasfillp=1; + package=find_package((object)&st); + } + } + + package=package ? package : user_package; + use=package->p.p_uselist; + internal=temp && temp[1]==':' ? 1 : 0; + ftext=text; + wtext=mch ? mch+1 : ftext; + wtext=*wtext==':' ? wtext+1 : wtext; + len=strlen(wtext); + tp=package; + i=0; + base=internal ? tp->p.p_internal : tp->p.p_external; + size=internal ? tp->p.p_internal_size : tp->p.p_external_size; + l=base[i]; + + } + + while (tp && tp != Cnil) { + + while (1) { + while (type_of(l)==t_cons) { + struct symbol sym=l->c.c_car->s; + l=l->c.c_cdr; + if (pref) { + if (sym.s_fillp=len && + !strncasecmp(wtext,sym.s_self,len)) { + static char *c; + c=malloc((wtext-ftext)+sym.s_fillp+1); + memcpy(c,ftext,wtext-ftext); + memcpy(c+(wtext-ftext),sym.s_self,sym.s_fillp); + c[(wtext-ftext)+sym.s_fillp]=0; + return c; + } + } + if (++i==size) + break; + l=base[i]; + } + + tp=use->c.c_car; + use=use->c.c_cdr; + base=internal ? tp->p.p_internal : tp->p.p_external; + size=internal ? tp->p.p_internal_size : tp->p.p_external_size; + i=0; + l=base[i]; + + } + + return NULL; + +} + +#ifndef HAVE_DECL_RL_COMPLETION_MATCHES +/* readline 4.3 has it, readline 4.1 has completion_matches instead */ +#define rl_completion_matches completion_matches +#endif + +#ifndef HAVE_RL_COMPENTRY_FUNC_T +/* same here */ +typedef char *rl_compentry_func_t(const char *, int); +#endif + +#endif + +static int +my_getc(FILE *f) { + int c; + BEGIN_NO_INTERRUPT; + c=getc(f); + END_NO_INTERRUPT; + return c; +} + +static int +my_putc(int c,FILE *f) { + BEGIN_NO_INTERRUPT; + c=putc(c,f); + END_NO_INTERRUPT; + return c; +} + + +int rl_putc_em(int c, FILE *f) { + + static int allocated_length = 0; + static int current_length = 0; + char *old_line; + + if (f!=stdout || !isatty(fileno(f)) ) goto tail; + + if (c=='\r' || c=='\n') { + current_length = 0; + if (allocated_length>0) rl_putc_em_line[0] = 0; + goto tail; + } + + if (current_length+2 > allocated_length) { + allocated_length = (current_length+8)*2; + old_line = rl_putc_em_line; + rl_putc_em_line = realloc(old_line, allocated_length); + if (rl_putc_em_line==NULL) { + free(old_line); + allocated_length = 0; + current_length = 0; + goto tail; + } + } + + rl_putc_em_line[current_length++] = (unsigned char)c; + rl_putc_em_line[current_length] = 0; + + tail: + return my_putc(c, f); + +} + +#include + +static jmp_buf readline_jmp_buf; + +static void +readline_sigint_handler(int c,siginfo_t *i,void *v) { + longjmp(readline_jmp_buf,1); +} + +static char * +call_readline() { + + struct sigaction siga,old_siga; + char *line; + + sigaction(SIGINT,NULL,&old_siga); + siga=old_siga; + siga.sa_sigaction=readline_sigint_handler; + if (setjmp(readline_jmp_buf)) { + sigaction(SIGINT,&old_siga,NULL); + sigint(); + line=malloc(1); + line[0]=0; + } else { + my_putc('\r', stdout); + sigaction(SIGINT,&siga,&old_siga); + line=readline(rl_putc_em_line); + sigaction(SIGINT,&old_siga,NULL); + rl_putc_em('\r', stdout); + } + return line; + +} + +static int line_eof_p,line_eol_p; + +int rl_getc_em(FILE *f) { + + static char *line; + static int linepos; + + if (f!=stdin || !isatty(fileno(f))) return my_getc(f); + + if (rl_ungetc_em_char!=-1) { + int r = rl_ungetc_em_char; + rl_ungetc_em_char = -1; + return r; + } + + line_eof_p=line_eol_p=0; + if (line==NULL) { + + if (readline_on==1) { + + line = call_readline(); + if (line==NULL) {line_eof_p=1;return EOF;} + if (line[0] != 0) add_history(line); + + } else { + + static int c,nlp; + + if (!nlp) { + fd_set fds; + int n=fileno(f); + FD_ZERO(&fds); + FD_SET(n,&fds); + while (select(n+1,&fds,NULL,NULL,NULL)<=0); + nlp=1; + } + + c=my_getc(f); + + if (c==10) nlp=0; + + return c; + + } + } + + if (line[linepos]==0) { + free(line); + line = NULL; + linepos = 0; + line_eol_p=1; + return '\n'; + } + + return line[linepos++]; + +} + +int +rl_stream_p(FILE *f) { + return readline_on && f==stdin && isatty(fileno(f)); +} + +int +rl_pending_buffered_input_p(FILE *f) { + return line_eof_p||line_eol_p ? FALSE :TRUE; +} + +int +rl_eof_p(FILE *f) { + return line_eof_p ? TRUE : FALSE; +} + +int rl_ungetc_em(int c, FILE *f) { + + if (f!=stdin || !isatty(fileno(f)) ) return ungetc(c, f); + rl_ungetc_em_char = ((unsigned char)c); + return c; + +} + +static void +FFN(siLreadline_on)() { + + const char *cp; + + if (!isatty(0)) { + FEerror("GCL is not being run from a terminal", 0); + return; + } + + if ((cp=getenv("TERM")) && !strcmp(cp,"dumb")) { + FEerror("Controlling terminal is not readline capable", 0); + return; + } + + readline_on=1; + return; + +} + +static void +FFN(siLreadline_off)() { + + readline_on=0; + return; + +} + +void +gcl_init_readline_function(void) { + char *cp=getenv("TERM"); + + *my_rl_readline_name_ptr="GCL"; +#ifdef RL_COMPLETION + *my_rl_completion_entry_function_ptr = rl_completion_words; +#endif + if (isatty(0) && (!cp || strcmp(cp,"dumb"))) + readline_on=1; + +} + +void +gcl_init_readline(void) { + make_si_function("READLINE-ON", siLreadline_on); + make_si_function("READLINE-OFF", siLreadline_off); +} + +#endif /* HAVE_READLINE */ diff --git a/o/gdb_commands b/o/gdb_commands new file mode 100755 index 0000000..a839183 --- /dev/null +++ b/o/gdb_commands @@ -0,0 +1,45 @@ +# $ma break in main_signal_handler +# $ra break in raise_pending_signals + +command $ma +silent +echo (main_..)signo= +output signo +echo allowed= +output (enum signals_allowed_values) allowed +echo , +seePending +echo ,\n called in: +fr 2 +continue +end + +define seePending +echo signals_pending= +output (unsigned long)signals_pending +echo [ +output /t signals_pending +echo ] +end + +command $ra +silent +echo (raise..)signo= +output *p +echo ,allowed= +output (enum signals_allowed_values) cond +seePending +echo ,\n called in: +fr 1 +continue +end + +command $in +silent +echo for invoke... +frame 1 +frame 2 +frame 3 +echo ...done\n +continue +end diff --git a/o/gmp.c b/o/gmp.c new file mode 100644 index 0000000..df84d71 --- /dev/null +++ b/o/gmp.c @@ -0,0 +1,34 @@ +#define ALLOCATE(n) (*gcl_gmp_allocfun)(n) + +void *gcl_gmp_alloc(size_t size) +{ + return (void *) ALLOCATE(size); +} + +static void *gcl_gmp_realloc(void *oldmem, size_t oldsize, size_t newsize) +{ + unsigned int *old,*new; + if (!jmp_gmp) { /* No gc in alloc if jmp_gmp */ + if (MP_SELF(big_gcprotect)) abort(); + MP_SELF(big_gcprotect)=oldmem; + MP_ALLOCATED(big_gcprotect)=oldsize/MP_LIMB_SIZE; + } + new = (void *)ALLOCATE(newsize); + old = jmp_gmp ? oldmem : MP_SELF(big_gcprotect); + MP_SELF(big_gcprotect)=0; + bcopy(old,new,oldsize); +/* SGC contblock pages: Its possible this is on an old page CM 20030827 */ + if (inheap(oldmem)) +#ifdef SGC + insert_maybe_sgc_contblock(oldmem,oldsize); +#else + insert_contblock(oldmem,oldsize); +#endif + + return new; +} + +static void gcl_gmp_free(void *old, size_t oldsize) +{ +} + diff --git a/o/gmp_big.c b/o/gmp_big.c new file mode 100755 index 0000000..f1bb283 --- /dev/null +++ b/o/gmp_big.c @@ -0,0 +1,587 @@ + /* Copyright William F. Schelter 1991 + Bignum routines. + + + +num_arith.c: add_int_big +num_arith.c: big_minus +num_arith.c: big_plus +num_arith.c: big_quotient_remainder +num_arith.c: big_sign +num_arith.c: big_times +num_arith.c: complement_big +num_arith.c: copy_big +num_arith.c: div_int_big +num_arith.c: mul_int_big +num_arith.c: normalize_big +num_arith.c: normalize_big_to_object +num_arith.c: stretch_big +num_arith.c: sub_int_big +num_comp.c: big_compare +num_comp.c: big_sign +num_log.c: big_sign +num_log.c: copy_to_big +num_log.c: normalize_big +num_log.c: normalize_big_to_object +num_log.c: stretch_big +num_pred.c: big_sign +number.c: big_to_double +predicate.c: big_compare +typespec.c: big_sign +print.d: big_minus +print.d: big_sign +print.d: big_zerop +print.d: copy_big +print.d: div_int_big +read.d: add_int_big +read.d: big_to_double +read.d: complement_big +read.d: mul_int_big +read.d: normalize_big +read.d: normalize_big_to_object + + */ + + +#include + +#define DEBUG_GMP +#ifdef DEBUG_GMP +#define ABS(x) ((x) < 0 ? -(x) : (x)) +/* static object */ +/* verify_big(object big) */ +/* { int size; */ +/* if(type_of(big)!=t_bignum) FEerror("Not a bignum",0); */ +/* size = MP_SIZE(big); */ +/* if ( size ==0 || (MP_SELF(big))[ABS(size)-1]==0) */ +/* FEerror("badly formed",0); */ +/* return big; */ +/* } */ + +static object verify_big_or_zero(object big) +{ int size; + if(type_of(big)!=t_bignum) FEerror("Not a bignum",0); + size = MP_SIZE(big); + if ( size && (MP_SELF(big))[ABS(size)-1]==0) + FEerror("badly formed",0); + return big; +} + +/* static */ +/* MP_INT* */ +/* verify_mp(MP_INT *u) */ +/* { int size = u->_mp_size; */ +/* if (size != 0 && u->_mp_d[ABS(size)] == 0) */ +/* FEerror("bad mp",0); */ +/* return u; */ +/* } */ +#else +#define verify_mp(x) +#define verify_big(x) +#define verify_big_or_zero(x) +#endif + + + + + +#ifndef GMP_USE_MALLOC +object big_gcprotect; +object big_fixnum1; + +#include "gmp.c" +void +gcl_init_big1(void) { + mp_set_memory_functions( gcl_gmp_alloc,gcl_gmp_realloc,gcl_gmp_free); +} + +#else +gcl_init_big1() +{ +} +#endif + +object +new_bignum(void) +{ object ans; + {BEGIN_NO_INTERRUPT; + ans = alloc_object(t_bignum); + MP_SELF(ans) = 0; + mpz_init(MP(ans)); + END_NO_INTERRUPT; + } + return ans; +} + +/* we have to store the body of a u in a bignum object + so that the garbage collecter will move it and save + it, and then we can copy it back +*/ +#define GCPROTECT(u) \ + MP_INT * __u = MP(big_gcprotect); \ + (__u)->_mp_d = (u)->_mp_d; \ + (__u)->_mp_alloc = (u)->_mp_alloc +#define GC_PROTECTED_SELF (__u)->_mp_d +#define END_GCPROTECT (__u)->_mp_d = 0 + +static object +make_bignum(__mpz_struct *u) { + object ans=alloc_object(t_bignum); + memset(MP(ans),0,sizeof(*MP(ans))); + mpz_init_set(MP(ans),u); + return ans; +} + +/* static object */ +/* make_bignum(__mpz_struct *u) */ +/* { object ans ; */ +/* int size; */ +/* {BEGIN_NO_INTERRUPT; */ +/* /\* make sure we follow the bignum body of u if it gets moved... *\/ */ +/* { GCPROTECT(u); */ +/* ans = alloc_object(t_bignum); */ +/* size = u->_mp_size; */ +/* MP(ans)->_mp_d = 0; */ +/* if (size == 0 ) */ +/* size = 1; */ +/* else if (size < 0) size= -size; */ +/* MP(ans)->_mp_d = (mp_ptr) gcl_gmp_alloc (size*MP_LIMB_SIZE); */ +/* MP(ans)->_mp_alloc = size; */ +/* MP(ans)->_mp_size = u->_mp_size; */ +/* memcpy(MP(ans)->_mp_d,GC_PROTECTED_SELF,size*MP_LIMB_SIZE); */ +/* END_GCPROTECT; */ +/* } */ +/* END_NO_INTERRUPT; */ +/* return ans; */ +/* } */ +/* } */ + +/* coerce a mpz_t to a bignum or fixnum */ + +object +make_integer(__mpz_struct *u) +{ + if ((u)->_mp_size == 0) return small_fixnum(0); + if (mpz_fits_slong_p(u)) { + return make_fixnum(mpz_get_si(u)); + } + return make_bignum(u); +} + +/* like make_integer except that the storage of u is cleared + if it is a fixnum, and if not the storage of u is actually + copied to the new bignum +*/ +#ifdef OBSOLETE +object +make_integer_clear(u) +mpz_t u; +{ object ans; + if ((u)->_mp_size == 0) return small_fixnum(0); + if (mpz_fits_slong_p(u)) { + fixnum x = mpz_get_si(u); + mpz_clear(u); + return make_fixnum(x); + } + {BEGIN_NO_INTERRUPT; + { GCPROTECT(u); + ans = alloc_object(t_bignum); + MP(ans)->_mp_alloc = u->_mp_alloc; + MP(ans)->_mp_size = u->_mp_size; + /* the u->_mp_d may have moved */ + MP_SELF(ans) = GC_PROTECTED_SELF; + mpz_clear(u); + END_GCPROTECT; + } + END_NO_INTERRUPT; + } + return ans; +} +#endif /* obsolete */ + +/* static int */ +/* big_zerop(object x) */ +/* { return (mpz_sgn(MP(x))== 0);} */ + +int +big_compare(object x, object y) +{return mpz_cmp(MP(x),MP(y)); +} + + +object +normalize_big_to_object(object x) +{ + return maybe_replace_big(x); +} + + +/* static void */ +/* gcopy_to_big(__mpz_struct *res, object x) */ +/* { */ +/* mpz_set(MP(x),res); */ +/* } */ + +/* destructively modifies x = i - x; */ +void +add_int_big(int i, object x) +{ + MPOP_DEST(x,addsi,i,MP(x)); +} + +/* static void */ +/* sub_int_big(int i, object x) */ +/* { */ /* SI_TEMP_DECL(mpz_int_temp); */ +/* MPOP_DEST(x,subsi,i,MP(x)); */ +/* } */ + +void +mul_int_big(int i, object x) +{ MPOP_DEST(x,mulsi,i,MP(x)); +} + + + +/* + Div_int_big(i, x) destructively divides non-negative bignum x + by positive int i. + X will hold the quotient from the division. + Div_int_big(i, x) returns the remainder of the division. + I should be positive. + X should be non-negative. +*/ + +/* static int */ +/* div_int_big(int i, object x) */ +/* { */ +/* return mpz_tdiv_q_ui(MP(x),MP(x),i); */ +/* } */ + + +/* static object */ +/* big_plus(object x, object y) */ +/* { */ +/* MPOP(return,addii,MP(x),MP(y)); */ +/* } */ + +/* static object */ +/* big_times(object x, object y) */ +/* { */ +/* MPOP(return,mulii,MP(x),MP(y)); */ + +/* } */ + +/* x is a big, and it is coerced to a fixnum (and the big is cleared) + or it is smashed + +*/ +object +normalize_big(object x) +{ + if (MP_SIZE(x) == 0) return small_fixnum(0); + if (mpz_fits_slong_p(MP(x))) { + MP_INT *u = MP(x); + return make_fixnum(mpz_get_si(u)); + } + else return x; +} + +object +big_minus(object x) +{ object y = new_bignum(); + mpz_neg(MP(y),MP(x)); + return normalize_big(y); +} + + +/* static void */ +/* big_quotient_remainder(object x0, object y0, object *qp, object *rp) */ +/* { */ +/* object res,quot; */ +/* res = new_bignum(); */ +/* quot = new_bignum(); */ +/* mpz_tdiv_qr(MP(quot),MP(res),MP(x0),MP(y0)); */ +/* *qp = normalize_big(quot); */ +/* *rp = normalize_big(res); */ +/* return; */ +/* } */ + + +#ifndef IEEEFLOAT +#error big_to_double requires IEEEFLOAT +#endif + + +static int +double_exponent(double d) { + + union {double d;int i[2];} u; + + if (d == 0.0) + return(0); + + u.d=d; + return (((u.i[HIND] & 0x7ff00000) >> 20) - 1022); + +} + +static double +set_exponent(double d, int e) { + + union {double d;int i[2];} u; + + if (d == 0.0) + return(0.0); + + u.d=d; + u.i[HIND]= (u.i[HIND] & 0x800fffff) | (((e + 1022) << 20) & 0x7ff00000); + return(u.d); + +} + +double +big_to_double(object x) { + + double d=mpz_get_d(MP(x)); + int s=mpz_sizeinbase(MP(x),2); + if (s>=54 && mpz_tstbit(MP(x),s-54)) { + + union {double d;int i[2];} u; + + u.i[HIND]=0; + u.i[LIND]=1; + + d+=(d>0.0 ? 1.0 : -1.0)*set_exponent(u.d,double_exponent(d)-53); + + } + + return d; + +} + + +/* static object copy_big(object x) */ +/* { */ +/* if (type_of(x)==t_bignum) */ +/* return make_bignum(MP(x)); */ +/* else FEerror("bignum expected",0); */ +/* return Cnil; */ + +/* } */ + +/* this differes from old copy_to_big in that it does not alter + copy a bignum. +*/ +/* static object */ +/* copy_to_big(object x) { */ +/* if (type_of(x) == t_fixnum) { */ +/* object ans = new_bignum(); */ +/* mpz_set_si(MP(ans),fix(x)); */ +/* return ans; */ +/* } else { */ +/* return x; */ +/* } */ +/* } */ + + +/* put in to get (declare integer working with existing setup. + should be optimized at some point, as we're just converting + and reconverting integer data, it appears -- CM */ + +int +obj_to_mpz(object x,MP_INT * y) { + + switch(type_of(x)) { + case t_fixnum: + mpz_set_si(y,fix(x)); + break; + case t_bignum: + if (abs(MP(x)->_mp_size)<=y->_mp_alloc) + mpz_set(y,MP(x)); + else + return abs(MP(x)->_mp_size)*sizeof(*y->_mp_d); + break; + default: + FEerror("fixnum or bignum expected",0); + break; + } + + return 0; + +} + +int +obj_to_mpz1(object x,MP_INT * y,void *v) { + + switch(type_of(x)) { + case t_fixnum: + mpz_set_si(y,fix(x)); + break; + case t_bignum: + y->_mp_alloc=abs(MP(x)->_mp_size); + y->_mp_d=v; + mpz_set(y,MP(x)); + break; + default: + FEerror("fixnum or bignum expected",0); + break; + } + + return 0; + +} + +int +mpz_to_mpz(MP_INT * x,MP_INT * y) { + + if (abs(x->_mp_size)<=y->_mp_alloc) + mpz_set(y,x); + else + return abs(x->_mp_size)*sizeof(*y->_mp_d); + + return 0; + +} + +int +mpz_to_mpz1(MP_INT * x,MP_INT * y,void *v) { + + y->_mp_alloc=abs(x->_mp_size); + y->_mp_d=v; + mpz_set(y,x); + return 0; + +} + +void +isetq_fix(MP_INT * var,int s) +{ + mpz_set_si(var,s); +} + +MP_INT * +otoi(object x) { + if (type_of(x)==t_fixnum) { + object y = new_bignum(); + mpz_set_si(MP(y),fix(x)); + return MP(y); + } + if (type_of(x)==t_bignum) + return (MP(x)); + FEwrong_type_argument(sLinteger,x); + return NULL; +} +/* end added section for declare integer -- CM */ + + + + +/* return object like *xpt coercing to a fixnum if necessary, + or return the actual bignum replacing it with another +*/ +object +maybe_replace_big(object x) +{ +/* note mpz_fits_sint_p(MP(x)) returns arbitrary result if + passed 0 in bignum form. + bug or feature of gmp.. +*/ + if (MP_SIZE(x) == 0) return small_fixnum(0); + if (mpz_fits_slong_p(MP(x))) { + MP_INT *u = MP(x); + return make_fixnum(mpz_get_si(u)); + } + return make_bignum(MP(x)); +} + + +object +bignum2(unsigned int h, unsigned int l) +{ + object x = new_bignum(); + mpz_set_ui(MP(x),h); + mpz_mul_2exp(MP(x),MP(x),32); + mpz_add_ui(MP(x),MP(x),l); + return normalize_big(x); +} + +void +integer_quotient_remainder_1(object x, object y, object *qp, object *rp,fixnum d) { + + if (type_of(x)==t_fixnum && type_of(y)==t_fixnum) { + fixnum fx=fix(x),fy=fix(y); + if (fx!=-fx) {/*MOST_NEGATIVE_FIX*/ + if (qp) { + fixnum z=fixnum_div(fx,fy,d); + if (rp) *rp=make_fixnum(fx-fy*z); + *qp=make_fixnum(z); + } else if (rp) + *rp=make_fixnum(fixnum_rem(fx,fy,d)); + return; + } + } + + { + + __mpz_struct *b1=INTEGER_TO_MP(x,big_fixnum1),*b2=INTEGER_TO_MP(y,big_fixnum2); + + if (qp) { + if (rp) { + void (*f)()=d<0 ? mpz_fdiv_qr : (d>0 ? mpz_cdiv_qr : mpz_tdiv_qr); + f(MP(big_fixnum3),MP(big_fixnum4),b1,b2); + *rp=maybe_replace_big(big_fixnum4); + } else { + void (*f)()=d<0 ? mpz_fdiv_q : (d>0 ? mpz_cdiv_q : mpz_tdiv_q); + f(MP(big_fixnum3),b1,b2); + } + *qp=maybe_replace_big(big_fixnum3); + } else if (rp) { + void (*f)()=d<0 ? mpz_fdiv_r : (d>0 ? mpz_cdiv_r : mpz_tdiv_r); + f(MP(big_fixnum4),b1,b2); + *rp=maybe_replace_big(big_fixnum4); + } + + } + +} + + +#define HAVE_MP_COERCE_TO_STRING + +object +coerce_big_to_string(object x, int printbase) +{ int i; + int sign = BIG_SIGN(x); + int ss = mpz_sizeinbase(MP(x),printbase); + char *p; + object ans = alloc_simple_string(ss+2+(sign<0? 1: 0)); + ans->st.st_self=p=alloc_relblock(ans->st.st_dim); + /* if (sign < 0) *p++='-'; */ + mpz_get_str(p, printbase,MP(x)); + i = ans->st.st_dim-5; + if (i <0 ) i=0; + while(ans->st.st_self[i]) { i++;} + ans->st.st_fillp=i; + return ans; +} + + +void +gcl_init_big(void) +{ + gcl_init_big1(); + big_gcprotect=alloc_object(t_bignum); + MP_SELF(big_gcprotect)=0; + MP_ALLOCATED(big_gcprotect)=0; + big_fixnum1=new_bignum(); + big_fixnum2=new_bignum(); + big_fixnum3=new_bignum(); + big_fixnum4=new_bignum(); + enter_mark_origin(&big_fixnum1); + enter_mark_origin(&big_gcprotect); + enter_mark_origin(&big_fixnum2); + enter_mark_origin(&big_fixnum3); + enter_mark_origin(&big_fixnum4); + + +} diff --git a/o/gmp_num_log.c b/o/gmp_num_log.c new file mode 100644 index 0000000..f611c71 --- /dev/null +++ b/o/gmp_num_log.c @@ -0,0 +1,117 @@ +/* + x : fixnum or bignum (may be not normalized) + y : integer + returns + fixnum or bignum ( not normalized ) +*/ + +object big_log_op(); +object normalize_big(object); + +static fixnum +fixnum_log_op2(fixnum op,fixnum x,fixnum y) { + + return fixnum_boole(op,x,y); + +} + +static object +integer_log_op2(fixnum op,object x,enum type tx,object y,enum type ty) { + + object u=big_fixnum1; + object ux=tx==t_bignum ? x : (mpz_set_si(MP(big_fixnum2),fix(x)), big_fixnum2); + object uy=ty==t_bignum ? y : (mpz_set_si(MP(big_fixnum3),fix(y)), big_fixnum3); + + switch(op) { + case BOOLCLR: mpz_set_si(MP(u),0);break; + case BOOLSET: mpz_set_si(MP(u),-1);break; + case BOOL1: mpz_set(MP(u),MP(ux));break; + case BOOL2: mpz_set(MP(u),MP(uy));break; + case BOOLC1: mpz_com(MP(u),MP(ux));break; + case BOOLC2: mpz_com(MP(u),MP(uy));break; + case BOOLAND: mpz_and(MP(u),MP(ux),MP(uy));break; + case BOOLIOR: mpz_ior(MP(u),MP(ux),MP(uy));break; + case BOOLXOR: mpz_xor(MP(u),MP(ux),MP(uy));break; + case BOOLEQV: mpz_xor(MP(u),MP(ux),MP(uy));mpz_com(MP(u),MP(u));break; + case BOOLNAND: mpz_and(MP(u),MP(ux),MP(uy));mpz_com(MP(u),MP(u));break; + case BOOLNOR: mpz_ior(MP(u),MP(ux),MP(uy));mpz_com(MP(u),MP(u));break; + case BOOLANDC1:mpz_com(MP(u),MP(ux));mpz_and(MP(u),MP(u),MP(uy));break; + case BOOLANDC2:mpz_com(MP(u),MP(uy));mpz_and(MP(u),MP(ux),MP(u));break; + case BOOLORC1: mpz_com(MP(u),MP(ux));mpz_ior(MP(u),MP(u),MP(uy));break; + case BOOLORC2: mpz_com(MP(u),MP(uy));mpz_ior(MP(u),MP(ux),MP(u));break; + default:break;/*FIXME error*/ + } + + return u; + +} + +inline object +log_op2(fixnum op,object x,object y) { + + enum type tx=type_of(x),ty=type_of(y); + + if (tx==t_fixnum && ty==t_fixnum) + return make_fixnum(fixnum_log_op2(op,fix(x),fix(y))); + else + return maybe_replace_big(integer_log_op2(op,x,tx,y,ty)); +} + +static object +log_op(fixnum op) { + + fixnum i,n=vs_top-vs_base,fx=0; + enum type tx,ty; + object x,y; + + if ((tx=type_of(x=vs_base[0]))==t_fixnum) {fx=fix(x);x=OBJNULL;} + for (i=1;i= 0) { + return mpz_popcount(x); + } else { + object u = new_bignum(); + mpz_com(MP(u),x); + return mpz_popcount(MP(u)); + } +} + + +static int +mpz_bitlength(__mpz_struct *x) +{ + if (mpz_sgn(x) >= 0) { + return mpz_sizeinbase(x,2); + } else { + object u = new_bignum(); + mpz_com(MP(u),x); + return mpz_sizeinbase(MP(u),2); + } +} + + + diff --git a/o/gmp_wrappers.c b/o/gmp_wrappers.c new file mode 100644 index 0000000..4b86671 --- /dev/null +++ b/o/gmp_wrappers.c @@ -0,0 +1,4 @@ +int jmp_gmp=0; +#define GMP_EXTERN +#define GMP_EXTERN_INLINE +#include "include.h" diff --git a/o/gnumalloc.c b/o/gnumalloc.c new file mode 100755 index 0000000..c7c2759 --- /dev/null +++ b/o/gnumalloc.c @@ -0,0 +1,815 @@ +/* dynamic memory allocation for GNU. + Copyright (C) 1985, 1987 Free Software Foundation, Inc. + + NO WARRANTY + + BECAUSE THIS PROGRAM IS LICENSED FREE OF CHARGE, WE PROVIDE ABSOLUTELY +NO WARRANTY, TO THE EXTENT PERMITTED BY APPLICABLE STATE LAW. EXCEPT +WHEN OTHERWISE STATED IN WRITING, FREE SOFTWARE FOUNDATION, INC, +RICHARD M. STALLMAN AND/OR OTHER PARTIES PROVIDE THIS PROGRAM "AS IS" +WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, +BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY +AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE +DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR +CORRECTION. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW WILL RICHARD M. +STALLMAN, THE FREE SOFTWARE FOUNDATION, INC., AND/OR ANY OTHER PARTY +WHO MAY MODIFY AND REDISTRIBUTE THIS PROGRAM AS PERMITTED BELOW, BE +LIABLE TO YOU FOR DAMAGES, INCLUDING ANY LOST PROFITS, LOST MONIES, OR +OTHER SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR +DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY THIRD PARTIES OR +A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS) THIS +PROGRAM, EVEN IF YOU HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. + + GENERAL PUBLIC LICENSE TO COPY + + 1. You may copy and distribute verbatim copies of this source file +as you receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy a valid copyright notice "Copyright +(C) 1985 Free Software Foundation, Inc."; and include following the +copyright notice a verbatim copy of the above disclaimer of warranty +and of this License. You may charge a distribution fee for the +physical act of transferring a copy. + + 2. You may modify your copy or copies of this source file or +any portion of it, and copy and distribute such modifications under +the terms of Paragraph 1 above, provided that you also do the following: + + a) cause the modified files to carry prominent notices stating + that you changed the files and the date of any change; and + + b) cause the whole of any work that you distribute or publish, + that in whole or in part contains or is a derivative of this + program or any part thereof, to be licensed at no charge to all + third parties on terms identical to those contained in this + License Agreement (except that you may choose to grant more extensive + warranty protection to some or all third parties, at your option). + + c) You may charge a distribution fee for the physical act of + transferring a copy, and you may at your option offer warranty + protection in exchange for a fee. + +Mere aggregation of another unrelated program with this program (or its +derivative) on a volume of a storage or distribution medium does not bring +the other program under the scope of these terms. + + 3. You may copy and distribute this program (or a portion or derivative +of it, under Paragraph 2) in object code or executable form under the terms +of Paragraphs 1 and 2 above provided that you also do one of the following: + + a) accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of + Paragraphs 1 and 2 above; or, + + b) accompany it with a written offer, valid for at least three + years, to give any third party free (except for a nominal + shipping charge) a complete machine-readable copy of the + corresponding source code, to be distributed under the terms of + Paragraphs 1 and 2 above; or, + + c) accompany it with the information you received as to where the + corresponding source code may be obtained. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form alone.) + +For an executable file, complete source code means all the source code for +all modules it contains; but, as a special exception, it need not include +source code for modules which are standard libraries that accompany the +operating system on which the executable file runs. + + 4. You may not copy, sublicense, distribute or transfer this program +except as expressly provided under this License Agreement. Any attempt +otherwise to copy, sublicense, distribute or transfer this program is void and +your rights to use the program under this License agreement shall be +automatically terminated. However, parties who have received computer +software programs from you with this License Agreement will not have +their licenses terminated so long as such parties remain in full compliance. + + 5. If you wish to incorporate parts of this program into other free +programs whose distribution conditions are different, write to the Free +Software Foundation at 675 Mass Ave, Cambridge, MA 02139. We have not yet +worked out a simple rule that can be stated here, but we will often permit +this. We will be guided by the two goals of preserving the free status of +all derivatives of our free software and of promoting the sharing and reuse of +software. + + +In other words, you are welcome to use, share and improve this program. +You are forbidden to forbid anyone else to use, share and improve +what you give them. Help stamp out software-hoarding! */ + + +/* + * @(#)nmalloc.c 1 (Caltech) 2/21/82 + * + * U of M Modified: 20 Jun 1983 ACT: strange hacks for Emacs + * + * Nov 1983, Mike@BRL, Added support for 4.1C/4.2 BSD. + * + * This is a very fast storage allocator. It allocates blocks of a small + * number of different sizes, and keeps free lists of each size. Blocks + * that don't exactly fit are passed up to the next larger size. In this + * implementation, the available sizes are (2^n)-4 (or -16) bytes long. + * This is designed for use in a program that uses vast quantities of + * memory, but bombs when it runs out. To make it a little better, it + * warns the user when he starts to get near the end. + * + * June 84, ACT: modified rcheck code to check the range given to malloc, + * rather than the range determined by the 2-power used. + * + * Jan 85, RMS: calls malloc_warning to issue warning on nearly full. + * No longer Emacs-specific; can serve as all-purpose malloc for GNU. + * You should call malloc_init to reinitialize after loading dumped Emacs. + * Call malloc_stats to get info on memory stats if MSTATS turned on. + * realloc knows how to return same block given, just changing its size, + * if the power of 2 is correct. + */ + +/* + * nextf[i] is the pointer to the next free block of size 2^(i+3). The + * smallest allocatable block is 8 bytes. The overhead information will + * go in the first int of the block, and the returned pointer will point + * to the second. + * +#ifdef MSTATS + * nmalloc[i] is the difference between the number of mallocs and frees + * for a given block size. +#endif /* MSTATS */ + +#ifdef emacs +#include "config.h" +#endif /* emacs */ + +/* Determine which kind of system this is. */ +#include +#ifndef SIGTSTP +#ifndef VMS +#ifndef USG +#define USG +#endif +#endif /* not VMS */ +#else /* SIGTSTP */ +#ifdef SIGIO +#define BSD42 +#endif /* SIGIO */ +#endif /* SIGTSTP */ + +/* Define getpagesize () if the system does not. */ +#include "getpagesize.h" + +#ifndef BSD42 +#ifndef USG +#include /* warn the user when near the end */ +#endif /* not USG */ +#else /* if BSD42 */ +#include +#include +#endif /* BSD42 */ + +extern char *start_of_data (); + +#ifdef BSD +#ifndef DATA_SEG_BITS +#define start_of_data() &etext +#endif +#endif + +#ifndef emacs +#define start_of_data() &etext +#endif + +#define ISALLOC ((char) 0xf7) /* magic byte that implies allocation */ +#define ISFREE ((char) 0x54) /* magic byte that implies free block */ + /* this is for error checking only */ +#define ISMEMALIGN ((char) 0xd6) /* Stored before the value returned by + memalign, with the rest of the word + being the distance to the true + beginning of the block. */ + +extern char etext; + +/* These two are for user programs to look at, when they are interested. */ + +unsigned int malloc_sbrk_used; /* amount of data space used now */ +unsigned int malloc_sbrk_unused; /* amount more we can have */ + +/* start of data space; can be changed by calling init_malloc */ +static char *data_space_start; + +#ifdef MSTATS +static int nmalloc[30]; +static int nmal, nfre; +#endif /* MSTATS */ + +/* If range checking is not turned on, all we have is a flag indicating + whether memory is allocated, an index in nextf[], and a size field; to + realloc() memory we copy either size bytes or 1<<(index+3) bytes depending + on whether the former can hold the exact size (given the value of + 'index'). If range checking is on, we always need to know how much space + is allocated, so the 'size' field is never used. */ + +struct mhead { + char mh_alloc; /* ISALLOC or ISFREE */ + char mh_index; /* index in nextf[] */ +/* Remainder are valid only when block is allocated */ + unsigned short mh_size; /* size, if < 0x10000 */ +#ifdef rcheck + unsigned mh_nbytes; /* number of bytes allocated */ + int mh_magic4; /* should be == MAGIC4 */ +#endif /* rcheck */ +}; + +/* Access free-list pointer of a block. + It is stored at block + 4. + This is not a field in the mhead structure + because we want sizeof (struct mhead) + to describe the overhead for when the block is in use, + and we do not want the free-list pointer to count in that. */ + +#define CHAIN(a) \ + (*(struct mhead **) (sizeof (char *) + (char *) (a))) + +#ifdef rcheck + +/* To implement range checking, we write magic values in at the beginning and + end of each allocated block, and make sure they are undisturbed whenever a + free or a realloc occurs. */ +/* Written in each of the 4 bytes following the block's real space */ +#define MAGIC1 0x55 +/* Written in the 4 bytes before the block's real space */ +#define MAGIC4 0x55555555 +#define ASSERT(p) if (!(p)) botch("p"); else +#define EXTRA 4 /* 4 bytes extra for MAGIC1s */ +#else +#define ASSERT(p) +#define EXTRA 0 +#endif /* rcheck */ + + +/* nextf[i] is free list of blocks of size 2**(i + 3) */ + +static struct mhead *nextf[30]; + +/* busy[i] is nonzero while allocation of block size i is in progress. */ + +static char busy[30]; + +/* Number of bytes of writable memory we can expect to be able to get */ +static unsigned int lim_data; + +/* Level number of warnings already issued. + 0 -- no warnings issued. + 1 -- 75% warning already issued. + 2 -- 85% warning already issued. +*/ +static int warnlevel; + +/* Function to call to issue a warning; + 0 means don't issue them. */ +static void (*warnfunction) (); + +/* nonzero once initial bunch of free blocks made */ +static int gotpool; + +char *_malloc_base; + +static void getpool (void); + +/* Cause reinitialization based on job parameters; + also declare where the end of pure storage is. */ +void +malloc_init (char *start, void (*warnfun) (/* ??? */)) +{ + if (start) + data_space_start = start; + lim_data = 0; + warnlevel = 0; + warnfunction = warnfun; +} + +/* Return the maximum size to which MEM can be realloc'd + without actually requiring copying. */ + +int +malloc_usable_size (char *mem) +{ + int blocksize = 8 << (((struct mhead *) mem) - 1) -> mh_index; + + return blocksize - sizeof (struct mhead) - EXTRA; +} + +static void +morecore (register int nu) /* ask system for more memory */ + /* size index to get more of */ +{ + char *sbrk (int n); + register char *cp; + register int nblks; + register unsigned int siz; + int oldmask; + + #ifdef BSD +#ifndef BSD4_1 +#ifdef SGC + oldmask = sigsetmask (-1 & ~(sigmask(SIGPROTV))); +#else + oldmask = sigsetmask (-1); +#endif +#endif +#endif + + + if (!data_space_start) + { + data_space_start = start_of_data (); + } + + if (lim_data == 0) + get_lim_data (); + + /* On initial startup, get two blocks of each size up to 1k bytes */ + if (!gotpool) + { getpool (); getpool (); gotpool = 1; } + + /* Find current end of memory and issue warning if getting near max */ + +#ifndef VMS + /* Maximum virtual memory on VMS is difficult to calculate since it + * depends on several dynmacially changing things. Also, alignment + * isn't that important. That is why much of the code here is ifdef'ed + * out for VMS systems. + */ + cp = sbrk (0); + siz = cp - data_space_start; + malloc_sbrk_used = siz; + malloc_sbrk_unused = lim_data - siz; + + if (warnfunction) + switch (warnlevel) + { + case 0: + if (siz > (lim_data / 4) * 3) + { + warnlevel++; + (*warnfunction) ("Warning: past 75% of memory limit"); + } + break; + case 1: + if (siz > (lim_data / 20) * 17) + { + warnlevel++; + (*warnfunction) ("Warning: past 85% of memory limit"); + } + break; + case 2: + if (siz > (lim_data / 20) * 19) + { + warnlevel++; + (*warnfunction) ("Warning: past 95% of memory limit"); + } + break; + } + + if ((int) cp & 0x3ff) /* land on 1K boundaries */ + sbrk (1024 - ((int) cp & 0x3ff)); +#endif /* not VMS */ + + /* Take at least 2k, and figure out how many blocks of the desired size + we're about to get */ + nblks = 1; + if ((siz = nu) < 8) + nblks = 1 << ((siz = 8) - nu); + + if ((cp = sbrk (1 << (siz + 3))) == (char *) -1) + return; /* no more room! */ +#ifndef VMS + if ((int) cp & 7) + { /* shouldn't happen, but just in case */ + cp = (char *) (((int) cp + 8) & ~7); + nblks--; + } +#endif /* not VMS */ + + /* save new header and link the nblks blocks together */ + nextf[nu] = (struct mhead *) cp; + siz = 1 << (nu + 3); + while (1) + { + ((struct mhead *) cp) -> mh_alloc = ISFREE; + ((struct mhead *) cp) -> mh_index = nu; + if (--nblks <= 0) break; + CHAIN ((struct mhead *) cp) = (struct mhead *) (cp + siz); + cp += siz; + } + CHAIN ((struct mhead *) cp) = 0; + +#ifdef BSD +#ifndef BSD4_1 + sigsetmask (oldmask); +#endif +#endif +} + +static void +getpool (void) +{ + register int nu; + char * sbrk (int n); + register char *cp = sbrk (0); + + if ((int) cp & 0x3ff) /* land on 1K boundaries */ + sbrk (1024 - ((int) cp & 0x3ff)); + + /* Record address of start of space allocated by malloc. */ + if (_malloc_base == 0) + _malloc_base = cp; + + /* Get 2k of storage */ + + cp = sbrk (04000); + if (cp == (char *) -1) + return; + + /* Divide it into an initial 8-word block + plus one block of size 2**nu for nu = 3 ... 10. */ + + CHAIN (cp) = nextf[0]; + nextf[0] = (struct mhead *) cp; + ((struct mhead *) cp) -> mh_alloc = ISFREE; + ((struct mhead *) cp) -> mh_index = 0; + cp += 8; + + for (nu = 0; nu < 7; nu++) + { + CHAIN (cp) = nextf[nu]; + nextf[nu] = (struct mhead *) cp; + ((struct mhead *) cp) -> mh_alloc = ISFREE; + ((struct mhead *) cp) -> mh_index = nu; + cp += 8 << nu; + } +} + +voi * +malloc(size_t n) /* get a block */ + +{ + register struct mhead *p; + register unsigned int nbytes; + register int nunits = 0; + + /* Figure out how many bytes are required, rounding up to the nearest + multiple of 4, then figure out which nextf[] area to use */ + nbytes = (n + sizeof *p + EXTRA + 3) & ~3; + { + register unsigned int shiftr = (nbytes - 1) >> 2; + + while (shiftr >>= 1) + nunits++; + } + + /* In case this is reentrant use of malloc from signal handler, + pick a block size that no other malloc level is currently + trying to allocate. That's the easiest harmless way not to + interfere with the other level of execution. */ + while (busy[nunits]) nunits++; + busy[nunits] = 1; + + /* If there are no blocks of the appropriate size, go get some */ + /* COULD SPLIT UP A LARGER BLOCK HERE ... ACT */ + if (nextf[nunits] == 0) + morecore (nunits); + + /* Get one block off the list, and set the new list head */ + if ((p = nextf[nunits]) == 0) + { + busy[nunits] = 0; + return 0; + } + nextf[nunits] = CHAIN (p); + busy[nunits] = 0; + + /* Check for free block clobbered */ + /* If not for this check, we would gobble a clobbered free chain ptr */ + /* and bomb out on the NEXT allocate of this size block */ + if (p -> mh_alloc != ISFREE || p -> mh_index != nunits) +#ifdef rcheck + botch ("block on free list clobbered"); +#else /* not rcheck */ + abort (); +#endif /* not rcheck */ + + /* Fill in the info, and if range checking, set up the magic numbers */ + p -> mh_alloc = ISALLOC; +#ifdef rcheck + p -> mh_nbytes = n; + p -> mh_magic4 = MAGIC4; + { + register char *m = (char *) (p + 1) + n; + + *m++ = MAGIC1, *m++ = MAGIC1, *m++ = MAGIC1, *m = MAGIC1; + } +#else /* not rcheck */ + p -> mh_size = n; +#endif /* not rcheck */ +#ifdef MSTATS + nmalloc[nunits]++; + nmal++; +#endif /* MSTATS */ + return (char *) (p + 1); +} + +void +free (void *mem) +{ + register struct mhead *p; + { + register char *ap = mem; + + if (ap == 0) + return; + + p = (struct mhead *) ap - 1; + if (p -> mh_alloc == ISMEMALIGN) + { + ap -= p->mh_size; + p = (struct mhead *) ap - 1; + } + + if (p -> mh_alloc != ISALLOC) + abort (); + +#ifdef rcheck + ASSERT (p -> mh_magic4 == MAGIC4); + ap += p -> mh_nbytes; + ASSERT (*ap++ == MAGIC1); ASSERT (*ap++ == MAGIC1); + ASSERT (*ap++ == MAGIC1); ASSERT (*ap == MAGIC1); +#endif /* rcheck */ + } + { + register int nunits = p -> mh_index; + + ASSERT (nunits <= 29); + p -> mh_alloc = ISFREE; + + /* Protect against signal handlers calling malloc. */ + busy[nunits] = 1; + /* Put this block on the free list. */ + CHAIN (p) = nextf[nunits]; + nextf[nunits] = p; + busy[nunits] = 0; + +#ifdef MSTATS + nmalloc[nunits]--; + nfre++; +#endif /* MSTATS */ + } +} + +void * +realloc (void *mem, register size_t n) +{ + register struct mhead *p; + register unsigned int tocopy; + register unsigned int nbytes; + register int nunits; + + if ((p = (struct mhead *) mem) == 0) + return malloc (n); + p--; + nunits = p -> mh_index; + ASSERT (p -> mh_alloc == ISALLOC); +#ifdef rcheck + ASSERT (p -> mh_magic4 == MAGIC4); + { + register char *m = mem + (tocopy = p -> mh_nbytes); + ASSERT (*m++ == MAGIC1); ASSERT (*m++ == MAGIC1); + ASSERT (*m++ == MAGIC1); ASSERT (*m == MAGIC1); + } +#else /* not rcheck */ + if (p -> mh_index >= 13) + tocopy = (1 << (p -> mh_index + 3)) - sizeof *p; + else + tocopy = p -> mh_size; +#endif /* not rcheck */ + + /* See if desired size rounds to same power of 2 as actual size. */ + nbytes = (n + sizeof *p + EXTRA + 7) & ~7; + + /* If ok, use the same block, just marking its size as changed. */ + if (nbytes > (4 << nunits) && nbytes <= (8 << nunits)) + { +#ifdef rcheck + register char *m = mem + tocopy; + *m++ = 0; *m++ = 0; *m++ = 0; *m++ = 0; + p-> mh_nbytes = n; + m = mem + n; + *m++ = MAGIC1; *m++ = MAGIC1; *m++ = MAGIC1; *m++ = MAGIC1; +#else /* not rcheck */ + p -> mh_size = n; +#endif /* not rcheck */ + return mem; + } + + if (n < tocopy) + tocopy = n; + { + register char *new; + + if ((new = malloc (n)) == 0) + return 0; + bcopy (mem, new, tocopy); + free (mem); + return new; + } +} + +#ifndef VMS + +void * +memalign (long alignment, size_t size) +{ + register char *ptr = malloc (size + alignment); + register char *aligned; + register struct mhead *p; + + if (ptr == 0) + return 0; + /* If entire block has the desired alignment, just accept it. */ + if (((int) ptr & (alignment - 1)) == 0) + return ptr; + /* Otherwise, get address of byte in the block that has that alignment. */ + aligned = (char *) (((int) ptr + alignment - 1) & -alignment); + + /* Store a suitable indication of how to free the block, + so that free can find the true beginning of it. */ + p = (struct mhead *) aligned - 1; + p -> mh_size = aligned - ptr; + p -> mh_alloc = ISMEMALIGN; + return aligned; +} + +#ifndef HPUX +/* This runs into trouble with getpagesize on HPUX. + Patching out seems cleaner than the ugly fix needed. */ +char * +valloc (int size) +{ + return memalign (getpagesize (), size); +} +#endif /* not HPUX */ +#endif /* not VMS */ + +#ifdef MSTATS +/* Return statistics describing allocation of blocks of size 2**n. */ + +struct mstats_value + { + int blocksize; + int nfree; + int nused; + }; + +struct mstats_value +malloc_stats (size) + int size; +{ + struct mstats_value v; + register int i; + register struct mhead *p; + + v.nfree = 0; + + if (size < 0 || size >= 30) + { + v.blocksize = 0; + v.nused = 0; + return v; + } + + v.blocksize = 1 << (size + 3); + v.nused = nmalloc[size]; + + for (p = nextf[size]; p; p = CHAIN (p)) + v.nfree++; + + return v; +} +#endif /* MSTATS */ + +/* + * This function returns the total number of bytes that the process + * will be allowed to allocate via the sbrk(2) system call. On + * BSD systems this is the total space allocatable to stack and + * data. On USG systems this is the data space only. + */ + +#ifdef USG + +get_lim_data () +{ + extern long ulimit (); + + lim_data = ulimit (3, 0); + lim_data -= (long) data_space_start; +} + +#else /* not USG */ +#ifndef BSD42 + +get_lim_data () +{ + lim_data = vlimit (LIM_DATA, -1); +} + +#else /* BSD42 */ + +get_lim_data (void) +{ + struct rlimit XXrlimit; + + getrlimit (RLIMIT_DATA, &XXrlimit); +#ifdef RLIM_INFINITY + lim_data = XXrlimit.rlim_cur & RLIM_INFINITY; /* soft limit */ +#else + lim_data = XXrlimit.rlim_cur; /* soft limit */ +#endif +} + +#endif /* BSD42 */ +#endif /* not USG */ + +#ifdef VMS +/* There is a problem when dumping and restoring things on VMS. Calls + * to SBRK don't necessarily result in contiguous allocation. Dumping + * doesn't work when it isn't. Therefore, we make the initial + * allocation contiguous by allocating a big chunk, and do SBRKs from + * there. Once Emacs has dumped there is no reason to continue + * contiguous allocation, malloc doesn't depend on it. + * + * There is a further problem of using brk and sbrk while using VMS C + * run time library routines malloc, calloc, etc. The documentation + * says that this is a no-no, although I'm not sure why this would be + * a problem. In any case, we remove the necessity to call brk and + * sbrk, by calling calloc (to assure zero filled data) rather than + * sbrk. + * + * VMS_ALLOCATION_SIZE is the size of the allocation array. This + * should be larger than the malloc size before dumping. Making this + * too large will result in the startup procedure slowing down since + * it will require more space and time to map it in. + * + * The value for VMS_ALLOCATION_SIZE in the following define was determined + * by running emacs linked (and a large allocation) with the debugger and + * looking to see how much storage was used. The allocation was 201 pages, + * so I rounded it up to a power of two. + */ +#ifndef VMS_ALLOCATION_SIZE +#define VMS_ALLOCATION_SIZE (512*256) +#endif + +/* Use VMS RTL definitions */ +#undef sbrk +#undef brk +#undef malloc +int vms_out_initial = 0; +char vms_initial_buffer[VMS_ALLOCATION_SIZE]; +static char *vms_current_brk = &vms_initial_buffer; +static char *vms_end_brk = &vms_initial_buffer[VMS_ALLOCATION_SIZE-1]; + +#include + +char * +sys_sbrk (incr) + int incr; +{ + char *sbrk(), *temp, *ptr; + + if (vms_out_initial) + { + /* out of initial allocation... */ + if (!(temp = malloc (incr))) + temp = (char *) -1; + } + else + { + /* otherwise, go out of our area */ + ptr = vms_current_brk + incr; /* new current_brk */ + if (ptr <= vms_end_brk) + { + temp = vms_current_brk; + vms_current_brk = ptr; + } + else + { + vms_out_initial = 1; /* mark as out of initial allocation */ + if (!(temp = malloc (incr))) + temp = (char *) -1; + } + } + return temp; +} +#endif /* VMS */ diff --git a/o/grab_defs.c b/o/grab_defs.c new file mode 100755 index 0000000..5ca65f8 --- /dev/null +++ b/o/grab_defs.c @@ -0,0 +1,98 @@ +/* + Copyright (C) 1994 W. Schelter + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +*/ + +#include +#include +#include + +/* recognize \nDEF ......... ") and output it to stdout + [ie '")' is a two character sequence which ends the def + recognize \nDO_ [^\n]\n and output it to stdout + + Thus the DEF's MUST contain a doc string as last component. + +*/ +int pos = 0; +#define GETC(x) (pos++,getc(x)) +int +read_some(char *buf, int n, int start_ch, int copy) + /* if copy is not 0 then copy characters to stdout while scanning + to find start_ch. When you find it, read n characters into buf, + return the number of characters read into buf, but these characters + MUST be free of start_ch. + */ + + +{ int ch; + int prev = 0; + while (1) + { ch =GETC(stdin); + if (ch == EOF) return -1; + if (copy) {putc(ch,stdout); + if (prev == '\n' && ch == '{') + { fprintf(stderr,"Error(at char %d):found \\n{ inside section to copy\n",pos) ; + exit(1);} + prev = ch; + } + AGAIN: + if (ch == start_ch) + { int i = 0; + while (i < n) + { ch = GETC(stdin); + if (ch == EOF) return i; + if (copy) {putc(ch,stdout); + if (prev == '\n' && ch == '{') + { fprintf(stderr,"Error(at char %d):found \\n{ inside section to copy",pos) ; + exit(1);} + prev = ch; + } + + if (ch == start_ch) goto AGAIN; + buf[i++] = ch; + } + return i; + }}} + + + +int +main(void) +{ + char buf[20]; + while (3==read_some(buf,3,'\n',0)) + { buf[3] = 0; + if (strcmp(buf,"DEF") ==0) + { printf("\n%s",buf); + while(1==read_some(buf,1,'\"',1)) + { if (buf[0] == ')') + break; + }} + if (strcmp(buf,"DO_") ==0) + {printf("\n%s",buf); + read_some(buf,0,'\n',1); + ungetc('\n',stdin); + } + } + printf("\n"); + exit(0); + +} + + + + + diff --git a/o/grab_defs.u b/o/grab_defs.u new file mode 100755 index 0000000..2bbae9f --- /dev/null +++ b/o/grab_defs.u @@ -0,0 +1 @@ +€ diff --git a/o/hash.d b/o/hash.d new file mode 100755 index 0000000..00ebd2a --- /dev/null +++ b/o/hash.d @@ -0,0 +1,574 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +*/ + +#define NEED_MP_H +#include +#include "include.h" + + +object sLeq; +object sLeql; +object sLequal; + +object sKsize; +object sKrehash_size; +object sKrehash_threshold; + +#define MHSH(a_) ((a_) & ~(1UL<<(sizeof(a_)*CHAR_SIZE-1))) + +typedef union {/*FIXME size checks*/ + float f; + unsigned int ul; +} F2ul; + +typedef union { + double d; + unsigned int ul[2]; +} D2ul; + +typedef unsigned char uchar; + +static ufixnum rtb[256]; + +#define MASK(n) (~(~0L << (n))) + +static ufixnum +ufixhash(ufixnum g) { + ufixnum i,h; + for (h=i=0;i>=CHAR_SIZE,i++) + h^=rtb[g&MASK(CHAR_SIZE)]; + return h; +} + +static ufixnum +uarrhash(void *v,void *ve,uchar off,uchar bits) { + + uchar *c=v,*ce=ve-(bits+(off ? off : CHAR_SIZE)>CHAR_SIZE ? 1 : 0),i; + ufixnum h=0,*u=v,*ue=u+(ce-c)/sizeof(*u); + + if (!off) + for (;u>(CHAR_SIZE*sizeof(*c)-off) : 0))]; + + for (i=off;bits--;i=(i+1)%CHAR_SIZE,c=i ? c : c+1) + h^=rtb[((*c)>>(CHAR_SIZE-1-i))&0x1]; + + return h; + +} + +#define hash_eq1(x) ufixhash((ufixnum)x/sizeof(x)) +#define hash_eq(x) MHSH(hash_eq1(x)) + + +static ufixnum +hash_eql(object x) { + + ufixnum h; + + switch (type_of(x)) { + + case t_fixnum: + h=ufixhash(fix(x)); + break; + + case t_character: + h = rtb[char_code(x)]; + break; + + case t_bignum: + { + MP_INT *mp = MP(x); + void *v1=mp->_mp_d,*ve=v1+mpz_size(mp); + + h=uarrhash(v1,ve,0,0); + } + break; + + case t_ratio: + h=hash_eql(x->rat.rat_num) + hash_eql(x->rat.rat_den); + break; + + case t_shortfloat: /*FIXME, sizeof int = sizeof float*/ + { + F2ul u; + u.f=sf(x); + h=ufixhash(u.ul); + } + break; + + case t_longfloat: + { + D2ul u; + u.d=lf(x); + h=ufixhash(u.ul[0])^ufixhash(u.ul[1]); + } + break; + + case t_complex: + h=hash_eql(x->cmp.cmp_real) + hash_eql(x->cmp.cmp_imag); + break; + + default: + h=hash_eq1(x); + break; + + } + + return MHSH(h); + +} + + +ufixnum +ihash_equal(object x,int depth) { + + enum type tx; + ufixnum h=0; + + cs_check(x); + +BEGIN: + if (depth++ <=3) + switch ((tx=type_of(x))) { + case t_cons: + h^=ihash_equal(x->c.c_car,depth)^rtb[abs(depth%(sizeof(rtb)/sizeof(*rtb)))]; + x = x->c.c_cdr; + goto BEGIN; + break; + case t_symbol: + case t_string: + h^=uarrhash(x->st.st_self,x->st.st_self+x->st.st_fillp,0,0); + break; + case t_package: + break; + case t_bitvector: + { + ufixnum l=x->bv.bv_offset+x->bv.bv_fillp; + void *v1=x->bv.bv_self+x->bv.bv_offset/CHAR_SIZE,*ve=v1+l/CHAR_SIZE+(x->bv.bv_fillp && l%CHAR_SIZE ? 1 : 0); + h^=uarrhash(v1,ve,x->bv.bv_offset%CHAR_SIZE,x->bv.bv_fillp%CHAR_SIZE); + } + break; + case t_pathname: + h^=ihash_equal(x->pn.pn_host,depth); + h^=ihash_equal(x->pn.pn_device,depth); + h^=ihash_equal(x->pn.pn_directory,depth); + h^=ihash_equal(x->pn.pn_name,depth); + h^=ihash_equal(x->pn.pn_type,depth); + /* version is ignored unless logical host */ + /* if ((type_of(x->pn.pn_host) == t_string) && */ + /* (pathname_lookup(x->pn.pn_host,sSApathname_logicalA) != Cnil)) */ + /* h^=ihash_equal(x->pn.pn_version,depth); */ + h^=ihash_equal(x->pn.pn_version,depth); + break; + default: + h^=hash_eql(x); + break; + } + + return MHSH(h); + +} + +DEFUN_NEW("HASH-EQUAL",object,fShash_equal,SI,2,2,NONE,OO,IO,OO,OO,(object x,fixnum depth),"") { + RETURN1(make_fixnum(ihash_equal(x,depth))); +} + + +struct htent * +gethash(object key, object hashtable) { + + enum httest htest; + long hsize,j,s,q; + struct htent *e,*first_objnull=NULL; + object hkey; + static struct htent dummy={OBJNULL,OBJNULL}; + + if (!hashtable->ht.ht_size) + return &dummy; + + htest = (enum httest)hashtable->ht.ht_test; + hsize = hashtable->ht.ht_size; + +#define eq(x,y) x==y +#define hash_loop(t_,i_) \ + for (s=i_%hsize,q=hsize,e=first_objnull;s>=0;q=s,s=s?0:-1) \ + for (j=s;jht.ht_self[j]; \ + hkey = e->hte_key; \ + if (hkey==OBJNULL) { \ + if (e->hte_value==OBJNULL) return first_objnull ? first_objnull : e; \ + if (!first_objnull) first_objnull=e; \ + } else if (t_(key,hkey)) return e; \ + } + + switch (htest) { + case htt_eq: + hash_loop(eq,hash_eq(key)); + break; + case htt_eql: + hash_loop(eql,hash_eql(key)); + break; + case htt_equal: + hash_loop(equal,ihash_equal(key,0)); + break; + default: + FEerror( "gethash: Hash table not of type EQ, EQL, or EQUAL." ,0); + return &dummy; + } + + return first_objnull ? first_objnull : (FEerror("No free spot in hashtable ~S.", 1, hashtable),&dummy); + +} + +static void +extend_hashtable(object); + +void +sethash(key, hashtable, value) +object key, hashtable, value; +{ + int i; + bool over=FALSE; + struct htent *e; + + i = hashtable->ht.ht_nent + 1; + if (type_of(hashtable->ht.ht_rhthresh) == t_fixnum) + over = i >= fix(hashtable->ht.ht_rhthresh); + else if (type_of(hashtable->ht.ht_rhthresh) == t_shortfloat) + over = + i >= hashtable->ht.ht_size * sf(hashtable->ht.ht_rhthresh); + else if (type_of(hashtable->ht.ht_rhthresh) == t_longfloat) + over = + i >= hashtable->ht.ht_size * lf(hashtable->ht.ht_rhthresh); + if (over) + extend_hashtable(hashtable); + e = gethash(key, hashtable); + if (e->hte_key == OBJNULL) + hashtable->ht.ht_nent++; + e->hte_key = key; + e->hte_value = value; +} + +static void +extend_hashtable(hashtable) +object hashtable; +{ + object old; + int new_size=0, i; + + if (type_of(hashtable->ht.ht_rhsize) == t_fixnum) + new_size = + hashtable->ht.ht_size + fix(hashtable->ht.ht_rhsize); + else if (type_of(hashtable->ht.ht_rhsize) == t_shortfloat) + new_size = + hashtable->ht.ht_size * sf(hashtable->ht.ht_rhsize); + else if (type_of(hashtable->ht.ht_rhsize) == t_longfloat) + new_size = + hashtable->ht.ht_size * lf(hashtable->ht.ht_rhsize); + {BEGIN_NO_INTERRUPT; + old = alloc_object(t_hashtable); + old->ht = hashtable->ht; + vs_push(old); + hashtable->ht.ht_self = NULL; + hashtable->ht.ht_size = new_size; + if (type_of(hashtable->ht.ht_rhthresh) == t_fixnum) + hashtable->ht.ht_rhthresh = + make_fixnum(fix(hashtable->ht.ht_rhthresh) + + (new_size - old->ht.ht_size)); + hashtable->ht.ht_self = + (struct htent *)alloc_relblock(new_size * sizeof(struct htent)); + for (i = 0; i < new_size; i++) { + hashtable->ht.ht_self[i].hte_key = OBJNULL; + hashtable->ht.ht_self[i].hte_value = OBJNULL; + } + for (i = 0; i < old->ht.ht_size; i++) { + if (old->ht.ht_self[i].hte_key != OBJNULL) + sethash(old->ht.ht_self[i].hte_key, + hashtable, + old->ht.ht_self[i].hte_value); + } + hashtable->ht.ht_nent = old->ht.ht_nent; + vs_popp; + END_NO_INTERRUPT;} +} + +DEFVAR("*DEFAULT-HASH-TABLE-SIZE*",sSAdefault_hash_table_sizeA,SI,make_fixnum(1024),""); +DEFVAR("*DEFAULT-HASH-TABLE-REHASH-SIZE*",sSAdefault_hash_table_rehash_sizeA,SI,make_shortfloat((shortfloat)1.5),""); +DEFVAR("*DEFAULT-HASH-TABLE-REHASH-THRESHOLD*",sSAdefault_hash_table_rehash_thresholdA,SI,make_shortfloat((shortfloat)0.7),""); + +@(defun make_hash_table (&key (test sLeql) + (size `sSAdefault_hash_table_sizeA->s.s_dbind`) + (rehash_size + `sSAdefault_hash_table_rehash_sizeA->s.s_dbind`) + (rehash_threshold + `sSAdefault_hash_table_rehash_thresholdA->s.s_dbind`) + &aux h) + enum httest htt=0; + int i; +@ + if (test == sLeq || test == sLeq->s.s_gfdef) + htt = htt_eq; + else if (test == sLeql || test == sLeql->s.s_gfdef) + htt = htt_eql; + else if (test == sLequal || test == sLequal->s.s_gfdef) + htt = htt_equal; + else + FEerror("~S is an illegal hash-table test function.", + 1, test); + if (type_of(size) != t_fixnum || 0 < fix(size)) + ; + else + FEerror("~S is an illegal hash-table size.", 1, size); + if ((type_of(rehash_size) == t_fixnum && 0 < fix(rehash_size)) || + (type_of(rehash_size) == t_shortfloat && 1.0 < sf(rehash_size)) || + (type_of(rehash_size) == t_longfloat && 1.0 < lf(rehash_size))) + ; + else + FEerror("~S is an illegal hash-table rehash-size.", + 1, rehash_size); + if ((type_of(rehash_threshold) == t_fixnum && + 0 < fix(rehash_threshold) && fix(rehash_threshold) < fix(size)) || + (type_of(rehash_threshold) == t_shortfloat && + 0.0 < sf(rehash_threshold) && sf(rehash_threshold) < 1.0) || + (type_of(rehash_threshold) == t_longfloat && + 0.0 < lf(rehash_threshold) && lf(rehash_threshold) < 1.0)) + ; + else + FEerror("~S is an illegal hash-table rehash-threshold.", + 1, rehash_threshold); + {BEGIN_NO_INTERRUPT; + h = alloc_object(t_hashtable); + h->ht.ht_test = (short)htt; + h->ht.ht_size = fix(size); + h->ht.ht_rhsize = rehash_size; + h->ht.ht_rhthresh = rehash_threshold; + h->ht.ht_nent = 0; + h->ht.ht_self = NULL; + h->ht.ht_self = (struct htent *) + alloc_relblock(fix(size) * sizeof(struct htent)); + for(i = 0; i < fix(size); i++) { + h->ht.ht_self[i].hte_key = OBJNULL; + h->ht.ht_self[i].hte_value = OBJNULL; + } + END_NO_INTERRUPT;} + @(return h) +@) + +LFD(Lhash_table_p)(void) +{ + check_arg(1); + + if(type_of(vs_base[0]) == t_hashtable) + vs_base[0] = Ct; + else + vs_base[0] = Cnil; +} + +LFD(Lgethash)() +{ + int narg; + struct htent *e; + + narg = vs_top - vs_base; + if (narg < 2) + too_few_arguments(); + else if (narg == 2) + vs_push(Cnil); + else if (narg > 3) + too_many_arguments(); + check_type_hash_table(&vs_base[1]); + e = gethash(vs_base[0], vs_base[1]); + if (e->hte_key != OBJNULL) { + vs_base[0] = e->hte_value; + vs_base[1] = Ct; + } else { + vs_base[0] = vs_base[2]; + vs_base[1] = Cnil; + } + vs_popp; +} + +DEFUN_NEW("GETHASH1",object,fSgethash1,SI,2,2,NONE,OO,OO,OO,OO,(object k,object h),"") { + + struct htent *e; + + check_type_hash_table(&h); + e = gethash(k,h); + return e->hte_key != OBJNULL ? e->hte_value : Cnil; + +} + + +LFD(siLhash_set)() +{ + check_arg(3); + + check_type_hash_table(&vs_base[1]); + sethash(vs_base[0], vs_base[1], vs_base[2]); + vs_base += 2; +} + +LFD(Lremhash)() +{ + struct htent *e; + + check_arg(2); + check_type_hash_table(&vs_base[1]); + e = gethash(vs_base[0], vs_base[1]); + if (e->hte_key != OBJNULL) { + e->hte_key = OBJNULL; + e->hte_value = Cnil; + vs_base[1]->ht.ht_nent--; + vs_base[0] = Ct; + } else + vs_base[0] = Cnil; + vs_top = vs_base + 1; +} + +LFD(Lclrhash)() +{ + int i; + + check_arg(1); + check_type_hash_table(&vs_base[0]); + for(i = 0; i < vs_base[0]->ht.ht_size; i++) { + vs_base[0]->ht.ht_self[i].hte_key = OBJNULL; + vs_base[0]->ht.ht_self[i].hte_value = OBJNULL; + } + vs_base[0]->ht.ht_nent = 0; +} + +LFD(Lhash_table_count)() +{ + + check_arg(1); + check_type_hash_table(&vs_base[0]); + vs_base[0] = make_fixnum(vs_base[0]->ht.ht_nent); +} + + +LFD(Lsxhash)() +{ + check_arg(1); + + vs_base[0] = make_fixnum((ihash_equal(vs_base[0],0) & 0x7fffffff)); +} + +LFD(Lmaphash)() +{ + object *base = vs_base; + object hashtable; + int i; + + check_arg(2); + check_type_hash_table(&vs_base[1]); + hashtable = vs_base[1]; + for (i = 0; i < hashtable->ht.ht_size; i++) { + if(hashtable->ht.ht_self[i].hte_key != OBJNULL) + ifuncall2(base[0], + hashtable->ht.ht_self[i].hte_key, + hashtable->ht.ht_self[i].hte_value); + } + vs_base[0] = Cnil; + vs_popp; +} + +DEFUNM_NEW("NEXT-HASH-TABLE-ENTRY",object,fSnext_hash_table_entry,SI,2,2,NONE,OO,OO,OO,OO,(object table,object ind),"For HASH-TABLE and for index I return three values: NEXT-START, the next KEY and its VALUE. NEXT-START will be -1 if there are no more entries, otherwise it will be a value suitable for passing as an index") +{ int i = fix(ind); + check_type_hash_table(&table); + if ( i < 0) { FEerror("needs non negative index",0);} + while ( i < table->ht.ht_size) { + if (table->ht.ht_self[i].hte_key != OBJNULL) { + RETURN(3,object,make_fixnum(i+1), + (RV(table->ht.ht_self[i].hte_key), + RV(table->ht.ht_self[i].hte_value)));} + i++;} + RETURN(3,object,small_fixnum(-1),(RV(sLnil),RV(sLnil))); +} + +DEFUN_NEW("HASH-TABLE-TEST",object,fLhash_table_test,LISP,1,1,NONE,OO,OO,OO,OO,(object table), + "Given a HASH-TABLE return a symbol which specifies the function used in its test") +{ switch(table->ht.ht_test) { + case htt_equal: RETURN1(sLequal); + case htt_eq: RETURN1(sLeq); + case htt_eql: RETURN1(sLeql); + } + FEerror("not able to get hash table test for ~a",1,table); + RETURN1(sLnil); +} + +DEFUN_NEW("HASH-TABLE-SIZE",object,fLhash_table_size,LISP,1,1,NONE,OO,OO,OO,OO,(object table),"") +{ + RETURN1(make_fixnum(table->ht.ht_size)); + +} + +DEFUN_NEW("HASH-TABLE-REHASH-SIZE",object,fLhash_table_rehash_size,LISP,1,1,NONE,OO,OO,OO,OO,(object table),"") +{ + check_type_hash_table(&table); + RETURN1(table->ht.ht_rhsize); +} + +DEFUN_NEW("HASH-TABLE-REHASH-THRESHOLD",object,fLhash_table_rehash_threshold,LISP,1,1,NONE,OO,OO,OO,OO,(object table),"") +{ + check_type_hash_table(&table); + RETURN1(table->ht.ht_rhthresh); +} + + + +void +gcl_init_hash() +{ + sLeq = make_ordinary("EQ"); + sLeql = make_ordinary("EQL"); + sLequal = make_ordinary("EQUAL"); + sKsize = make_keyword("SIZE"); + sKtest = make_keyword("TEST"); + sKrehash_size = make_keyword("REHASH-SIZE"); + sKrehash_threshold = make_keyword("REHASH-THRESHOLD"); + + make_function("MAKE-HASH-TABLE", Lmake_hash_table); + make_function("HASH-TABLE-P", Lhash_table_p); + make_function("GETHASH", Lgethash); + make_function("REMHASH", Lremhash); + make_function("MAPHASH", Lmaphash); + make_function("CLRHASH", Lclrhash); + make_function("HASH-TABLE-COUNT", Lhash_table_count); + make_function("SXHASH", Lsxhash); + /* make_si_sfun("HASH-EQUAL",hash_equal,ARGTYPE2(f_object,f_fixnum) */ + /* | RESTYPE(f_object)); */ + make_si_function("HASH-SET", siLhash_set); + + { + object x=find_symbol(make_simple_string("MOST-NEGATIVE-FIXNUM"),find_package(make_simple_string("SI"))); + int i; + x=number_negate(x->s.s_dbind); + for (i=0;i= (setq i (- i 1)) 0) + (setq tem (cdr (assoc (aref x i) *subs*))) + (if tem (aset x i tem))) + x)) + +(defun defu (x) + (interactive "sc function name: ") + (insert "DEFUN(\"") + (let (pack name beg) + (cond ((eql (aref x 1) ?L) + (setq pack "LISP")) + ((eql (aref x 1 ) ?S) + (setq pack "SI")) + (t (barf))) + (setq name (upcase (mysub (substring x 2 nil)))) + (insert name "\",object," x "," pack ",0,0,NONE,OO,OO,OO,OO,\"\")") + )) + +(defun insert-vararg-preamble () + (interactive) + (let (min beg) + (beginning-of-line) + (looking-at "DEFUN") + (save-excursion + (search-forward "(") + (forward-sexp 5)(forward-sexp -1) + (setq min (string-to-int (buffer-substring (point) (+ (point) 3)))) + (forward-sexp 1)(forward-sexp -1) + (setq max (string-to-int (buffer-substring (point) (+ (point) 3)))) + ) + (forward-sexp 3) + (forward-char -1) + (insert + (if (eql (char-after (- (point) 1)) ?\( ) "" ",") + "va_alist") + (search-forward "\n{" ) + (forward-char -1) + (open-line 1) + (insert "va_dcl") + (search-forward "\n{" ) + (let ((n (read-string "name for n : " "n")) + (vars (read-minibuffer "names for args: ")) + defaults + (beg (point)) + ) + (insert "\tint " n "=VFUN_NARGS;") + (setq vars (mapcar 'symbol-name vars)) + (let ((tem vars)) + (while tem + (insert "\nobject " (car tem) ";") + (setq tem (cdr tem))) + (setq tem vars) + (insert "\nva_list ap;\n{ va_start(ap);\n") + (let ((i (+ min 1))) + (while tem + (setq defaults (cons (format "LDEFAULT%d" i) defaults)) + (insert " if (" n + (format ">=%d) " i) + (car tem) "=va_arg(ap,object);else goto " + (car defaults)";\n") + (setq i (+ i 1)) + (setq tem (cdr tem))) + (insert " goto LEND_VARARG;\n") + (setq tem vars) + (setq defaults (nreverse defaults)) + (while tem + (insert " "(car defaults) ": " (car tem) " = Cnil;\n") + (setq tem (cdr tem)) (setq defaults (cdr defaults))) + (insert " LEND_VARARG: va_end(ap);}\n")) + (c-indent-region beg (point)) + vars)))) + + + + +(defun get-name-from-point () + (beginning-of-line) + (let (name) + (save-excursion + (cond ((looking-at "\\(siL\\|L\\)\\([a-zA-Z0-9_]*\\)") + (setq name (buffer-substring (match-beginning 2) + (match-end 2))) + + (concat (if (looking-at "si") "fS" + "fL") + name)))))) + +;(grep "grep -n '^siL[a-zA-Z_]*()' *.c *.d") +;(grep "grep -n '^L[a-zA-Z_]*()' *.c *.d") +;(grep "grep -n 'make_keywo' *.c *.d") +;(setq-default case-fold-search nil) +;(let (case-fold-search case-replace)(tags-query-replace "\\b[K]\\([a-z]\\)" "sK\\1")) +;(let (case-fold-search case-replace) (tags-query-replace "\\([^a-zA-Z_]\\)[S]\\([a-z]\\)" "\\1sL\\2")) +;(query-replace-regexp "\\([^a-zA-Z_]\\)[S]\\([a-z]\\)" "\\1sL\\2" nil) +;(setq-default case-fold-search nil) + +(defun defo (&optional x n max) + (interactive) + (beginning-of-line) + (let ((old-name (buffer-substring (point) + (save-excursion + (forward-sexp 1)(point))))) + (or x (setq x (read-string "C function name: " + (get-name-from-point)))) + (insert "DEFUNO(\"") + (let (pack name) + (cond ((eql (aref x 1) ?L) + (setq pack "LISP")) + ((eql (aref x 1 ) ?S) + (setq pack "SI")) + (t (barf))) + (setq name (upcase (mysub (substring x 2 nil)))) + (insert name "\",object," x "," pack + (format "\n ,%d,%d" (or n 0) (or max n 0)) + ",NONE,OO,OO,OO,OO," old-name + ",\"\")") + ) + old-name)) + +(defvar end-def (make-marker)) +(setq standard-args '(x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12)) + +(defun convert-one-def () + (interactive) + (make-local-variable 'version-control) + (setq version-control t) + (let ((here (point)) old-name) + (mark-c-function) + (let ((end (region-end)) n max) + (set-marker end-def end) + (save-restriction + (narrow-to-region (region-beginning) (region-end)) + (save-excursion + (cond ((re-search-forward "check_arg(\\([0-9]+\\));" end t) + (setq n (string-to-int + (buffer-substring (match-beginning 1) + (match-end 1)))) + (delete-region (match-beginning 0) + (match-end 0)) + (insert (format "/* %d args */" n))) + ((or (re-search-forward + "if (vs_top - vs_base < \\([0-9]+\\))[ \t\n]+too_few_arguments();[ \t\n]+if (vs_top - vs_base > \\([0-9]+\\))[ \t\n]+too_many_arguments();" nil t) + (re-search-forward "CHECK_ARG_RANGE(\\([0-9]+\\),\\([0-9]+\\));" nil t)) + (setq n (string-to-int + (buffer-substring (match-beginning 1) + (match-end 1)))) + (setq max (string-to-int + (buffer-substring (match-beginning 2) + (match-end 2)))) + + (delete-region (match-beginning 0) + (match-end 0)) + (insert (format "CHECK_ARG_RANGE(%s,%s);" n max)) + )) + (goto-char here) + (setq old-name (defo nil n max)) + (kill-sexp 1) + (search-forward "(") + (or n (setq n 0)) + (let ((i 0) (args "") ok + (standard-args standard-args) + new) + (while (< i n) + (setq new (cons (car standard-args) new)) + (setq standard-args (cdr standard-args)) + (setq i (+ i 1))) + (setq new (reverse new)) + (save-excursion + (while (not ok) + (setq standard-args + (read-minibuffer "New args: " (format "%s" new))) + (setq ok t) + (setq standard-args (mapcar 'symbol-name standard-args)) + (setq i 0) + (while (and ok (< i n)) + (setq args (format "%s%s" args (nth i standard-args))) + (while (search-forward (nth i standard-args) nil t) + (message "conflict %s? space for ok" (nth i standard-args)) + (cond ((member (read-char) '(?y ?\ ))) + (t (setq ok nil)))) + (setq i (+ i 1)) + (if (< i n) (setq args (concat args ",")))) + )) + + (insert args) + (forward-line 1) + (beginning-of-line) + (and standard-args (insert "object " args ";\n")) + (cond (max + (save-excursion + (search-backward "\nDEFUN") + (forward-char 1) + (setq standard-args + (append standard-args + (insert-vararg-preamble)))))) + (goto-char (point-min)) + (while (re-search-forward + "\\(vs_base\\|base\\)[[]\\([0-9]+\\)[]]" nil t) + (let ((m (string-to-int (buffer-substring (match-beginning 2) + (match-end 2))))) + (cond ((and (nth m standard-args) + (my-y-or-n-p (format "replace-> %s" (nth m standard-args)))) + (delete-region (match-beginning 0) + (match-end 0)) + (insert (nth m standard-args)))))) + (goto-char (point-max)) + (search-backward "}") + (open-line 1) + (insert "RETURN1(" (or (nth 0 standard-args) "vs_base[0]") ");") + (c-indent-command) + (goto-char here) + (widen) + (save-excursion + (goto-char (point-max)) + (cond ((search-backward old-name nil t) + (cond ((my-y-or-n-p "Delete line?") + (beginning-of-line) + (delete-region (point) + (progn (forward-line 1) (point))) + (sit-for 1) + ) + + )))) + )))))) + +(defun next-sexp () + (let (beg) + (forward-sexp 1) + (forward-sexp -1) + (setq beg (point)) + (forward-sexp 1) + (buffer-substring beg (point)))) + +(defun mangle-string (v) + (let ((beg (point)) end ans) + (insert v) + (setq end (point)) + (downcase-region beg end) + (do-replace '(("[*]" "A") + ("[---]" "_") + ("[+]" "Q") + ("[*]" "A") + ("[%]" "P") + ("[;]" "X") + ("[.]" "Z") + ("[,]" "Y") + ("[]" "E") + ("[@]" "B") + + ) beg end) + (setq ans (buffer-substring beg end)) + (delete-region beg end) + ans + )) + +(defun do-replace (lis &optional beg end) + (save-excursion + (let ((ma (make-marker))) + (set-marker ma (or end (point-max))) + (setq beg (or beg (point-min))) + (while lis + (goto-char beg) + (setq x (car lis) ) (setq lis (cdr lis)) + (while (re-search-forward (car x) ma t) + (replace-match (nth 1 x) t))) + (set-marker ma nil)))) + +(defun do-var () + (interactive) + (let (na beg old (m (make-marker))) + (save-excursion + (setq beg (point)) + (setq old (next-sexp)) + (cond ((search-forward "(\"" nil t) + (setq pt (point)) + (forward-char -1) + (setq na (next-sexp)) + (cond ((looking-at ")")) + (t + (forward-sexp 1) + (forward-sexp -1) + (setq val (buffer-substring (point) + (progn (search-forward ");") + (- (point) 2)))) + ;(setq val (next-sexp)) + )))) + (let ((pack "L")) + (goto-char beg) + (cond ((search-forward "make_si" pt t) + (setq pack "S")) + ((search-forward "make_keyw" pt t) + (setq pack "K") + )) + (setq na (concat "s" pack + (mangle-string (substring na 1 (- (length na) 1))))) + (goto-char beg) + (open-line 1) + (defva na val) + ) + + ) + (set-marker m (point)) + (save-excursion + (search-forward ");" nil t) + (delete-region m (point))) + (let ((buf (current-buffer))) + (unwind-protect + (cond ((and (not (equal old na)) + (y-or-n-p (format "Replace %s--> %s :" old na))) + (goto-char (point-min)) + (tags-query-replace old na nil))) + (switch-to-buffer buf) + (goto-char m) + (set-marker m nil) +)))) + + + + +(defun my-y-or-n-p (string) + (message (format "%s (Y or Space for yes): " string)) + (member (read-char) '(?y ?\ ))) + + +(defun defva (x &optional val) + (interactive "sc Variable name: ") + (let (pack name special) + (cond ((eql (aref x 1) ?L) + (setq pack "LISP")) + ((eql (aref x 1 ) ?S) + (setq pack "SI")) + ((eql (aref x 1 ) ?K) + (setq pack "KEYWORD")) + (t (barf))) + (cond ((eql (aref x 2) ?A) + (setq special t))) + (insert (if special "DEFVAR(\"" "DEF_ORDINARY(\"")) + (setq name (upcase (mysub (substring x 2 nil)))) + (insert name "\"," x "," pack) + (if special (insert "," (or val "sLnil"))) + (insert ",\"\");") +; (insert "\n#define " x " S" (substring x 2 nil)) + + )) + +;(tags-search "BEGIN_NO_INTERRUPT") +(global-set-key "\C-x'" 'check-interrupt) +(global-set-key "\C-xp" '(lambda()(interactive) (insert "END_NO_INTERRUPT;"))) +(global-set-key "\C-xa" + '(lambda()(interactive) (insert "{BEGIN_NO_INTERRUPT;") + (save-excursion (beginning-of-line) (forward-sexp 1) (insert "}")))) + +(defun check-interrupt ( ) + (interactive) + (let (found at (bil (make-marker)) (ok t)) + (forward-sexp -1) + (setq at (point)) + (mark-c-function) + (goto-char at) + (set-marker bil (region-end)) + (while (and ok (re-search-forward "\\(return\\)\\|\\(END_NO_INTERRUPT\\)" + bil t)) + (cond ((match-beginning 1) + (setq found t) + (if (my-y-or-n-p "replace?") + (replace-match "goto END_INTER " t))) + ((match-beginning 2) + (setq ok nil) + (if (and found (my-y-or-n-p "replace?")) + (replace-match "END_INTER: END_NO_INTERRUPT;\n return " t))) + )) + (set-marker bil nil) + (or found (message "was ok")) + (if ok (message "problem")) + )) + + + +(defun foo() + (interactive) + (let (p tem) + (end-of-line) + (setq p (point)) + (forward-sexp -1) + (forward-char 1) + (setq tem (buffer-substring (point) p)) + (save-excursion + (set-buffer (get-buffer "usig2.c<2>")) + (insert "\t&" tem ",\n")) + (forward-line 1))) + +(defun fa () + (interactive) + (let (p tem) + (end-of-line) + (setq p (point)) + (forward-sexp -1) + (forward-char 1) + (setq tem (buffer-substring (point) p)) + (grep (concat "grep -n " tem " o/*.c o/*.d mp/*.c h/*.h ")))) + +;(let ((case-fold-search nil)) (tags-query-replace "NONE" "VARARG")) + +(defun fa () + (interactive) + (re-search-forward "&\\([a-zA-Z0-9_]+\\)," nil t) + (grep (concat "grep -n " (buffer-substring (match-beginning 1) + (match-end 1)) + " ../o/*c ../o/*.d ../h/*.h ../mp/*.c"))) + +(defun my-grep () + (interactive) + (let (end ) + (save-excursion + (forward-sexp 1) (setq end (point)) + (forward-sexp -1) + (let ((tem (buffer-substring (point) end))) + (setq tem (read-string "Grep: " (concat "grep -n " tem " ../o/*.c ../o/*.d ../h/*.h ../mp/*.c"))) + (grep tem))))) diff --git a/o/init_pari.c b/o/init_pari.c new file mode 100755 index 0000000..f48ab7d --- /dev/null +++ b/o/init_pari.c @@ -0,0 +1,96 @@ +#define IN_INIT_PARI + +#define NEED_MP_H +#ifndef STANDALONE +#include "include.h" +#endif + +#ifdef GMP +/* static void */ +/* init_pari(void) */ +/* { */ +/* ; */ +/* } */ +#else +GEN gnil,gzero,gun,gdeux,ghalf,gi; +plong lontyp[30]={0,0x10000,0x10000,1,1,1,1,2,1,0,2,2,1,1,1,0,1,1,1,1}; +unsigned plong hiremainder,overflow; + +#ifdef STANDALONE +#define FEerror printf +#define make_si_sfun(a,b,c) +#endif + +#define INITIAL_PARI_STACK 400 +char initial_pari_stack[400]; + +our_ulong bot= (our_ulong) initial_pari_stack; +our_ulong top = (our_ulong)(initial_pari_stack+INITIAL_PARI_STACK); +/* not initted */ +our_ulong avma= 0; + + +void +err(s) + int s; +{ switch (s) { + case errpile: + FEerror("Out of bignum stack space, (si::MULTIPLY-BIGNUM-STACK n) to grow",0); + case dvmer1: + case diver4: + case diver2: + case diver1: + FEerror("Divide by zero",0); + case muler1: + FEerror("Multiply overflow",0); + case moder1: + FEerror("Mod by 0",0); + default: + FEerror("Integer Arithmetic error",0); +}} + + + + +multiply_bignum_stack(n) + int n; +{ int parisize = n* (top - bot); + in_saved_avma = 0; + if (n> 1) + { if (bot != (our_ulong)initial_pari_stack) free(bot); + set_pari_stack(parisize); + } + return parisize; +} + +set_pari_stack(parisize) + int parisize; +{ + bot=(plong)malloc(parisize); + top = avma = bot + parisize; +} + +static +init_pari() +{ + if (avma==0) + { + make_si_sfun("MULTIPLY-BIGNUM-STACK",multiply_bignum_stack, + ARGTYPE1(f_fixnum) | RESTYPE(f_fixnum)); + avma = top; + } + /* room for the permanent things */ + + gnil = cgeti(2);gnil[1]=2; setpere(gnil,255); + gzero = cgeti(2);gzero[1]=2; setpere(gzero, 255); + gun = stoi(1); setpere(gun, 255); + gdeux = stoi(2); setpere(gdeux, 255); + ghalf = cgetg(3,4);ghalf[1]=un;ghalf[2]=deux; setpere(ghalf, 255); + gi = cgetg(3,6); gi[1] = zero; gi[2] = un; setpere(gi, 255); + + /* set_pari_stack(BIGNUM_STACK_SIZE);*/ + } + + + +#endif diff --git a/o/internal-calls.lisp b/o/internal-calls.lisp new file mode 100755 index 0000000..eb230e5 --- /dev/null +++ b/o/internal-calls.lisp @@ -0,0 +1,3227 @@ +(setq all-references ( + +;;/* for file nfunlink.X */ + +( "nfunlink.X" +"FEerror" +"FEinvalid_function" +"vpush_extend" +"FEerror" +"vs_overflow" +"ihs_punsh_base" +"ihs_overflow" +"funcall" +"FEerror" +) + +;;/* for file alloc.X */ + +( "alloc.X" +"sgc_quit" +"GBC" +"sgc_start" +"error" +"error" +"alarm" +"terminal_interrupt" +"GBC" +"sgc_count_type" +"call_after_gbc_hook" +"CEerror" +"alarm" +"terminal_interrupt" +"GBC" +"sgc_count_type" +"call_after_gbc_hook" +"CEerror" +"set_up_string_register" +"t_from_type" +"terminal_interrupt" +"insert_contblock" +"GBC" +"CEerror" +"insert_contblock" +"terminal_interrupt" +"GBC" +"FEerror" +"error" +"CEerror" +"getpagesize" +"error" +"bzero" +"getrlimit" +"enter_mark_origin" +"FEerror" +"too_few_arguments" +"too_many_arguments" +"t_from_type" +"FEerror" +"strncmp" +"FEerror" +"check_arg_failed" +"check_arg_failed" +"too_few_arguments" +"too_many_arguments" +"FEerror" +"printf" +"check_arg_failed" +"check_arg_failed" +"too_few_arguments" +"too_many_arguments" +"FEerror" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"fixint" +"FEerror" +"endp1" +"FEerror" +"endp1" +"FEerror" +"getpagesize" +) + +;;/* for file array.X */ + +( "array.X" +"FEwrong_type_argument" +"FEerror" +"FEerror" +"FEerror" +"FEerror" +"FEerror" +"bcopy" +"check_arg_failed" +"FEerror" +"FEerror" +"FEerror" +"FEerror" +"fixint" +"FEerror" +"FEerror" +"FEerror" +"FEerror" +"FEerror" +"FEerror" +"fixnnint" +"FEerror" +"FEerror" +"FEerror" +"fixnnint" +"FEerror" +"too_few_arguments" +"FEerror" +"fixnnint" +"FEerror" +"FEerror" +"check_arg_failed" +"fixnnint" +"FEerror" +"too_few_arguments" +"FEerror" +"fixnnint" +"fixnnint" +"FEwrong_type_argument" +"too_few_arguments" +"FEerror" +"fixnnint" +"fixnnint" +"FEwrong_type_argument" +"check_arg_failed" +"check_arg_failed" +"check_type_array" +"check_arg_failed" +"check_type_array" +"fixnnint" +"FEerror" +"check_arg_failed" +"check_type_array" +"check_arg_failed" +"check_type_array" +"check_arg_failed" +"check_type_array" +"check_arg_failed" +"FEerror" +"illegal_index" +"check_arg_failed" +"FEerror" +"fixnnint" +"illegal_index" +"check_arg_failed" +"check_type_array" +"check_arg_failed" +"check_type_vector" +"FEerror" +"check_arg_failed" +"check_type_vector" +"fixnnint" +"FEerror" +"check_arg_failed" +"FEerror" +"check_arg_failed" +"endp1" +) + +;;/* for file assignment.X */ + +( "assignment.X" +"not_a_symbol" +"FEinvalid_variable" +"endp1" +"endp1" +"FEinvalid_form" +"eval" +"endp1" +"FEinvalid_form" +"eval" +"check_arg_failed" +"not_a_symbol" +"FEinvalid_variable" +"check_arg_failed" +"not_a_symbol" +"FEerror" +"FEerror" +"endp1" +"FEinvalid_form" +"eval" +"check_arg_failed" +"not_a_symbol" +"FEinvalid_variable" +"check_arg_failed" +"not_a_symbol" +"FEerror" +"remf" +"endp1" +"FEinvalid_form" +"setf" +"eval" +"eval" +"eval" +"eval" +"siLputprop" +"eval" +"eval" +"FEerror" +"eval" +"eval" +"FEerror" +"eval" +"eval" +"eval" +"eval" +"eval" +"eval" +"endp1" +"eval" +"eval" +"stack_cons" +"FEerror" +"funcall" +"eval" +"endp1" +"FEtoo_few_argumentsF" +"FEtoo_many_argumentsF" +"eval" +"stack_cons" +"FEerror" +"funcall" +"eval" +"endp1" +"FEtoo_few_argumentsF" +"FEtoo_many_argumentsF" +"eval" +"stack_cons" +"FEerror" +"funcall" +"eval" +"endp1" +"FEtoo_few_argumentsF" +"FEtoo_many_argumentsF" +"eval" +"eval" +"stack_cons" +"FEerror" +"funcall" +"eval" +"endp1" +"FEtoo_few_argumentsF" +"FEtoo_many_argumentsF" +"eval" +"eval" +"stack_cons" +"FEerror" +"funcall" +"eval" +"use_fast_links" +"check_arg_failed" +"enter_mark_origin" +) + +;;/* for file backq.X */ + +( "backq.X" +"FEerror" +"backq_car" +"stack_cons" +"stack_cons" +"stack_cons" +"error" +"stack_cons" +"error" +"stack_cons" +"stack_cons" +"stack_cons" +"stack_cons" +"stack_cons" +"error" +"stack_cons" +"error" +"error" +"FEerror" +"check_arg_failed" +"FEerror" +"stack_cons" +"check_arg_failed" +"enter_mark_origin" +) + +;;/* for file bcmp.X */ + +( "bcmp.X" +) + +;;/* for file bcopy.X */ + +( "bcopy.X" +) + +;;/* for file bds.X */ + +( "bds.X" +) + +;;/* for file big.X */ + +( "big.X" +"cmpii" +"FEerror" +"FEerror" +"FEerror" +"FEwrong_type_argument" +) + +;;/* for file bind.X */ + +( "bind.X" +"bds_overflow" +"FEerror" +"endp1" +"not_a_symbol" +"illegal_lambda" +"endp1" +"not_a_symbol" +"not_a_variable" +"illegal_lambda" +"not_a_symbol" +"illegal_lambda" +"not_a_variable" +"endp1" +"illegal_lambda" +"not_a_symbol" +"not_a_variable" +"keywordp" +"illegal_declare" +"check_arg_failed" +"FEtoo_few_arguments" +"check_arg_failed" +"FEtoo_many_arguments" +"bind_var" +"eval" +"keywordp" +"eval" +"eval" +"illegal_declare" +"check_arg_failed" +"FEerror" +"FEerror" +"endp1" +"illegal_declare" +"not_a_symbol" +"bds_overflow" +"eval" +"bds_overflow" +"eval" +"FEerror" +"keywordp" +"keywordp" +"stack_cons" +"endp1" +"keywordp" +"FEerror" +"bzero" +"FEerror" +"FEerror" +"FEerror" +"enter_mark_origin" +) + +;;/* for file bitop.X */ + +( "bitop.X" +"error" +"error" +"error" +) + +;;/* for file block.X */ + +( "block.X" +"endp1" +"FEtoo_few_argumentsF" +"lex_block_bind" +"frs_overflow" +"eval" +"endp1" +"FEtoo_few_argumentsF" +"FEtoo_many_argumentsF" +"FEerror" +"eval" +"unwind" +"endp1" +"FEtoo_many_argumentsF" +"FEerror" +"eval" +"unwind" +"enter_mark_origin" +) + +;;/* for file bzero.X */ + +( "bzero.X" +) + +;;/* for file catch.X */ + +( "catch.X" +"endp1" +"FEtoo_few_argumentsF" +"eval" +"frs_overflow" +"Fprogn" +"check_arg_failed" +"frs_overflow" +"eval" +"endp1" +"FEtoo_few_argumentsF" +"frs_overflow" +"Fprogn" +"unwind" +"eval" +"Fprogn" +"endp1" +"FEtoo_few_argumentsF" +"FEtoo_many_argumentsF" +"eval" +"FEerror" +"unwind" +) + +;;/* for file cfun.X */ + +( "cfun.X" +"FEerror" +"FEerror" +"check_type" +"error" +"error" +"error" +"not_a_symbol" +"check_type" +"error" +"not_a_symbol" +"check_type" +"error" +"set_key_struct" +"not_a_symbol" +"FEerror" +"not_a_symbol" +"check_arg_failed" +"FEerror" +"endp1" +"check_arg_failed" +) + +;;/* for file character.X */ + +( "character.X" +"check_arg_failed" +"check_type_character" +"check_arg_failed" +"check_type_character" +"check_arg_failed" +"check_type_character" +"check_arg_failed" +"check_type_character" +"check_arg_failed" +"check_type_character" +"check_arg_failed" +"check_type_character" +"check_arg_failed" +"check_type_character" +"too_few_arguments" +"too_many_arguments" +"check_type_character" +"check_type_non_negative_integer" +"check_arg_failed" +"check_type_character" +"too_few_arguments" +"check_type_character" +"too_few_arguments" +"check_type_character" +"too_few_arguments" +"check_type_character" +"too_few_arguments" +"check_type_character" +"too_few_arguments" +"check_type_character" +"too_few_arguments" +"check_type_character" +"check_arg_failed" +"check_arg_failed" +"check_type_character" +"check_arg_failed" +"check_type_character" +"check_arg_failed" +"check_type_character" +"too_few_arguments" +"too_many_arguments" +"check_type_non_negative_integer" +"too_few_arguments" +"too_many_arguments" +"check_type_character" +"check_type_non_negative_integer" +"check_arg_failed" +"check_type_character" +"check_arg_failed" +"check_type_character" +"too_few_arguments" +"too_many_arguments" +"check_type_non_negative_integer" +"check_arg_failed" +"check_type_character" +"check_arg_failed" +"check_type_non_negative_integer" +"check_arg_failed" +"check_type_character" +"check_arg_failed" +"string_equal" +"check_arg_failed" +"check_type_character" +"FEerror" +"check_arg_failed" +"check_type_character" +"FEerror" +"enter_mark_origin" +) + +;;/* for file cmpaux.X */ + +( "cmpaux.X" +"check_arg_failed" +"FEerror" +"FEerror" +"set_VV" +"FEerror" +"FEerror" +"FEerror" +"FEerror" +"FEwrong_type_argument" +"bcopy" +"check_type" +"check_type" +"eval" +"printf" +"fflush" +"printf" +"fflush" +"load" +) + +;;/* for file conditional.X */ + +( "conditional.X" +"endp1" +"FEtoo_few_argumentsF" +"FEtoo_many_argumentsF" +"eval" +"endp1" +"FEerror" +"eval" +"endp1" +"FEtoo_few_argumentsF" +"eval" +"FEerror" +"eql" +"eql" +"endp1" +"FEtoo_few_argumentsF" +"eval" +"endp1" +"FEtoo_few_argumentsF" +"eval" +"enter_mark_origin" +) + +;;/* for file earith.X */ + +( "earith.X" +"divul3" +"integer_quotient_remainder_1" +"number_compare" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +) + +;;/* for file error.X */ + +( "error.X" +"super_funcall" +"keywordp" +"not_a_keyword" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"unwind" +"_flsbuf" +"printf" +"endp1" +"endp1" +"fcalln_general" +"super_funcall" +"enter_mark_origin" +) + +;;/* for file eval.X */ + +( "eval.X" +"check_arg_failed" +"FEerror" +"FEtoo_few_arguments" +"FEtoo_many_arguments" +"FEerror" +"ihs_overflow" +"FEwrong_type_argument" +"FEundefined_function" +"FEinvalid_function" +"ihs_overflow" +"lambda_bind" +"frs_overflow" +"FEwrong_type_argument" +"eval" +"bds_unwind" +"FEerror" +"FEwrong_type_argument" +"FEerror" +"ihs_overflow" +"FEwrong_type_argument" +"FEerror" +"FEwrong_type_argument" +"FEerror" +"ihs_overflow" +"FEwrong_type_argument" +"FEerror" +"FEwrong_type_argument" +"FEerror" +"ihs_overflow" +"FEwrong_type_argument" +"FEerror" +"FEwrong_type_argument" +"FEerror" +"ihs_overflow" +"FEwrong_type_argument" +"FEerror" +"FEwrong_type_argument" +"FEinvalid_function" +"FEundefined_function" +"FEinvalid_function" +"FEundefined_function" +"vs_overflow" +"stack_cons" +"bds_unwind" +"FEunbound_variable" +"FEwrong_type_argument" +"ihs_overflow" +"FEundefined_function" +"macro_expand1" +"ihs_overflow" +"FEwrong_type_argument" +"call_applyhook" +"FEinvalid_function" +"stack_cons" +"too_few_arguments" +"too_few_arguments" +"FEwrong_type_argument" +"check_arg_failed" +"too_few_arguments" +"too_many_arguments" +"bds_unwind" +"too_few_arguments" +"too_many_arguments" +"FEwrong_type_argument" +"bds_unwind" +"check_arg_failed" +"frs_overflow" +"FEerror" +"FEwrong_type_argument" +"FEerror" +"FEerror" +"FEerror" +"enter_mark_origin" +) + +;;/* for file fat_string.X */ + +( "fat_string.X" +"error" +"printf" +"printf" +"printf" +"_flsbuf" +"printf" +"_flsbuf" +"fflush" +"_filbuf" +"printf" +"fflush" +"fread" +"printf" +"_flsbuf" +"fflush" +"fwrite" +"printf" +"_flsbuf" +"_filbuf" +"printf" +"sethash" +"fputc" +"printf" +"fputc" +"printf" +"printf" +"_flsbuf" +"printf" +"_flsbuf" +"FEerror" +"FEerror" +"write_fasd" +"frs_overflow" +"_filbuf" +"FEerror" +"unwind" +"check_type" +"check_type" +"check_type" +"array_allocself" +"file_position" +"fputc" +"printf" +"_flsbuf" +"write_fasd" +"_filbuf" +"FEerror" +"check_type" +"gset" +"clrhash" +"fputc" +"file_position" +"file_position_set" +"printf" +"_flsbuf" +"fputc" +"fputc" +"fputc" +"fputc" +"fputc" +"fputc" +"fputc" +"fputc" +"fputc" +"fputc" +"fputc" +"printf" +"_flsbuf" +"fputc" +"fputc" +"printf" +"_flsbuf" +"fputc" +"fputc" +"printf" +"_flsbuf" +"fputc" +"printf" +"_flsbuf" +"printf" +"_flsbuf" +"printf" +"_flsbuf" +"FEerror" +"printf" +"_flsbuf" +"printf" +"_flsbuf" +"printf" +"_flsbuf" +"FEerror" +"sethash" +"find_sharing" +"Leval" +"bcopy" +"FEerror" +"_filbuf" +"printf" +"printf" +"printf" +"printf" +"pp" +"printf" +"FEerror" +"printf" +"printf" +"printf" +"printf" +"printf" +"printf" +"printf" +"printf" +"siLmake_structure" +"printf" +"printf" +"printf" +"array_allocself" +"printf" +"printf" +"printf" +"printf" +"array_allocself" +"printf" +"princ_str" +"princ_str" +"_filbuf" +"FEerror" +"ungetc" +"readc_stream" +"unreadc_stream" +"unreadc_stream" +"gset" +"close_stream" +"FEerror" +"gset" +"FEerror" +"profil" +"check_arg_failed" +"FEerror" +"perror" +"fread" +"FEerror" +"perror" +"_filbuf" +"fclose" +"check_arg_failed" +"check_type_string" +"strncpy" +"qsort" +"free" +"FEerror" +"FEerror" +"qsort" +"FEerror" +"check_arg_failed" +"printf" +"fflush" +"printf" +"fflush" +"check_arg_failed" +"enter_mark_origin" +) + +;;/* for file file.X */ + +( "file.X" +"error" +"FEerror" +"FEwrong_type_argument" +"error" +"FEwrong_type_argument" +"error" +"FEwrong_type_argument" +"endp1" +"error" +"perm_writable" +"setbuf" +"insert_contblock" +"printf" +"too_long_file_name" +"cannot_open" +"cannot_create" +"fclose" +"FEerror" +"fclose" +"FEerror" +"cannot_create" +"cannot_create" +"cannot_open" +"FEerror" +"cannot_create" +"error" +"FEerror" +"fflush" +"fclose" +"FEwrong_type_argument" +"endp1" +"error" +"closed_stream" +"_filbuf" +"FEwrong_type_argument" +"endp1" +"stream_at_end" +"flush_stream" +"writec_stream" +"cannot_read" +"super_funcall" +"error" +"closed_stream" +"ungetc" +"FEwrong_type_argument" +"endp1" +"super_funcall" +"error" +"FEerror" +"closed_stream" +"_flsbuf" +"FEwrong_type_argument" +"endp1" +"FEerror" +"adjust_displaced" +"cannot_write" +"super_funcall" +"error" +"closed_stream" +"fflush" +"FEwrong_type_argument" +"endp1" +"FEerror" +"super_funcall" +"error" +"closed_stream" +"_filbuf" +"ungetc" +"FEwrong_type_argument" +"endp1" +"error" +"closed_stream" +"ioctl" +"FEwrong_type_argument" +"endp1" +"FEerror" +"error" +"closed_stream" +"FEwrong_type_argument" +"error" +"closed_stream" +"fseek" +"FEwrong_type_argument" +"error" +"closed_stream" +"file_len" +"FEwrong_type_argument" +"error" +"FEwrong_type_argument" +"endp1" +"error" +"check_arg_failed" +"check_type_symbol" +"cannot_write" +"stack_cons" +"cannot_read" +"stack_cons" +"check_arg_failed" +"cannot_read" +"cannot_write" +"check_arg_failed" +"cannot_read" +"cannot_write" +"too_few_arguments" +"too_many_arguments" +"check_type_string" +"FEerror" +"check_arg_failed" +"check_arg_failed" +"FEerror" +"check_arg_failed" +"FEerror" +"check_arg_failed" +"check_arg_failed" +"check_type_stream" +"check_arg_failed" +"check_type_stream" +"check_arg_failed" +"check_type_stream" +"too_few_arguments" +"parse_key" +"check_type_stream" +"too_few_arguments" +"parse_key" +"check_type_or_pathname_string_symbol_stream" +"FEerror" +"too_few_arguments" +"too_many_arguments" +"check_type_stream" +"FEerror" +"check_arg_failed" +"check_type_stream" +"too_few_arguments" +"parse_key" +"check_type_or_pathname_string_symbol_stream" +"string_eq" +"file_exists" +"setupPRINTdefault" +"write_str" +"write_object" +"cleanupPRINT" +"fasload" +"setupPRINTdefault" +"write_str" +"cleanupPRINT" +"bds_unwind" +"setupPRINTdefault" +"write_str" +"write_object" +"cleanupPRINT" +"setupPRINTdefault" +"write_str" +"write_object" +"cleanupPRINT" +"frs_overflow" +"bds_unwind" +"unwind" +"eval" +"setupPRINTdefault" +"write_object" +"write_str" +"cleanupPRINT" +"bds_unwind" +"setupPRINTdefault" +"write_str" +"write_object" +"cleanupPRINT" +"check_arg_failed" +"check_type_stream" +"FEerror" +"check_arg_failed" +"FEerror" +"check_arg_failed" +"check_type_stream" +"FEerror" +"FEerror" +"FEerror" +"FEerror" +"FEerror" +"check_arg_failed" +"FEerror" +"FEerror" +"FEwrong_type_argument" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"fwrite" +"check_arg_failed" +"fread" +"enter_mark_origin" +"enter_mark_origin" +"fread" +"fseek" +) + +;;/* for file format.X */ + +( "format.X" +"fmt_error" +"fmt_error" +"writec_stream" +"fmt_error" +"fmt_ascii" +"fmt_S_expression" +"fmt_decimal" +"fmt_binary" +"fmt_octal" +"fmt_hexadecimal" +"fmt_radix" +"fmt_plural" +"fmt_character" +"fmt_fix_float" +"fmt_exponential_float" +"fmt_general_float" +"fmt_dollars_float" +"fmt_percent" +"fmt_ampersand" +"fmt_bar" +"fmt_tilde" +"fmt_newline" +"fmt_tabulate" +"fmt_asterisk" +"fmt_indirection" +"fmt_case" +"fmt_conditional" +"fmt_iteration" +"fmt_justification" +"fmt_up_and_out" +"fmt_semicolon" +"funcall" +"fmt_error" +"fmt_error" +"fmt_error" +"fmt_error" +"fmt_error" +"fmt_error" +"file_column" +"writestr_stream" +"write_string" +"writec_stream" +"writec_stream" +"write_string" +"file_column" +"writestr_stream" +"write_string" +"writec_stream" +"writec_stream" +"write_string" +"fmt_integer" +"fmt_integer" +"fmt_integer" +"fmt_integer" +"check_type_integer" +"fmt_integer" +"fmt_roman" +"file_column" +"write_object" +"writestr_stream" +"writestr_stream" +"fmt_nonillion" +"writestr_stream" +"check_type_integer" +"FEerror" +"fmt_integer" +"file_column" +"setupPRINTdefault" +"write_object" +"cleanupPRINT" +"writec_stream" +"file_column" +"write_object" +"writec_stream" +"fmt_thousand" +"writec_stream" +"writestr_stream" +"fmt_thousand" +"writec_stream" +"fmt_write_numeral" +"writestr_stream" +"writec_stream" +"fmt_write_ordinal" +"fmt_write_numeral" +"fmt_write_ordinal" +"fmt_write_numeral" +"writec_stream" +"fmt_write_ordinal" +"fmt_write_numeral" +"writestr_stream" +"writestr_stream" +"writec_stream" +"fmt_error" +"eql" +"writec_stream" +"writestr_stream" +"check_type_character" +"writec_stream" +"fmt_error" +"edit_double" +"writec_stream" +"writec_stream" +"writestr_stream" +"writec_stream" +"fmt_exponent1" +"writec_stream" +"fmt_error" +"edit_double" +"writec_stream" +"writec_stream" +"writestr_stream" +"fmt_error" +"edit_double" +"writec_stream" +"fmt_error" +"edit_double" +"writec_stream" +"writec_stream" +"writec_stream" +"writec_stream" +"file_column" +"writec_stream" +"writec_stream" +"writec_stream" +"writec_stream" +"file_column" +"writestr_stream" +"writec_stream" +"writec_stream" +"file_column" +"fmt_error" +"fmt_error" +"fmt_error" +"endp1" +"vs_overflow" +"fmt_error" +"writec_stream" +"writec_stream" +"writec_stream" +"writec_stream" +"fmt_error" +"fmt_error" +"fmt_error" +"fmt_error" +"fmt_error" +"fmt_error" +"fmt_error" +"endp1" +"vs_overflow" +"endp1" +"vs_overflow" +"endp1" +"vs_overflow" +"fmt_error" +"file_column" +"writec_stream" +"writec_stream" +"fmt_error" +"too_few_arguments" +"FEerror" +"check_type_stream" +"check_type_string" +"frs_overflow" +"file_column" +"fmt_error" +"flush_stream" +"unwind" +"FEerror" +"enter_mark_origin" +) + +;;/* for file frame.X */ + +( "frame.X" +"bds_unwind" +) + +;;/* for file funlink.X */ + +( "funlink.X" +"FEinvalid_function" +"ihs_overflow" +"funcall" +"vpush_extend" +"FEinvalid_function" +"vpush_extend" +"ihs_overflow" +"ihs_overflow" +"funcall" +"vpush_extend" +"use_fast_links" +"clean_link_array" +"check_type_array" +"not_a_symbol" +"FEerror" +"FEerror" +"check_type_symbol" +"FEerror" +"FEinvalid_function" +"vs_overflow" +"funcall" +"vs_overflow" +"super_funcall" +"vs_overflow" +"super_funcall" +"FEerror" +"FEerror" +"array_allocself" +"FEerror" +"FEerror" +"FEerror" +"FEerror" +"FEerror" +) + +;;/* for file gbc.X */ + +( "gbc.X" +"error" +"error" +"mark_object" +"mark_contblock" +"mark_contblock" +"adjust_displaced" +"printf" +"adjust_displaced" +"fclose" +"error" +"printf" +"error" +"fprintf" +"fflush" +"clear_stack" +"printf" +"fflush" +"printf" +"fflush" +"mark_c_stack" +"printf" +"_flsbuf" +"fflush" +"insert_contblock" +"printf" +"fflush" +"error" +"sgc_quit" +"printf" +"sgc_count_type" +"sgc_count_writable" +"fflush" +"printf" +"fflush" +"sgc_quit" +"fprintf" +"fflush" +"sgc_mark_phase" +"printf" +"fflush" +"printf" +"fflush" +"sgc_sweep_phase" +"printf" +"fflush" +"printf" +"fflush" +"sgc_contblock_sweep_phase" +"printf" +"printf" +"printf" +"printf" +"fflush" +"sgc_start" +"fprintf" +"fflush" +"sigint" +"check_arg_failed" +"vs_overflow" +"check_arg_failed" +"check_arg_failed" +"sgc_mark_object1" +"sgc_mark_object1" +"adjust_displaced" +"printf" +"adjust_displaced" +"fclose" +"error" +"printf" +"error" +"fprintf" +"fflush" +"clear_stack" +"printf" +"fflush" +"printf" +"fflush" +"printf" +"_flsbuf" +"fflush" +"insert_contblock" +"printf" +"fflush" +"bzero" +"printf" +"fflush" +"add_page_to_freelist" +"printf" +"fflush" +"printf" +"fflush" +"sgc_mprotect" +"mprotect" +"mprotect" +"FEerror" +"check_arg_failed" +"FEerror" +"perror" +) + +;;/* for file hash.X */ + +( "hash.X" +"bzero" +"eql" +"equal" +"extend_hashtable" +"too_few_arguments" +"parse_key" +"FEerror" +"check_arg_failed" +"too_few_arguments" +"too_many_arguments" +"check_type_hash_table" +"check_arg_failed" +"check_type_hash_table" +"check_arg_failed" +"check_type_hash_table" +"check_arg_failed" +"check_type_hash_table" +"check_arg_failed" +"check_type_hash_table" +"check_arg_failed" +"check_arg_failed" +"check_type_hash_table" +) + +;;/* for file init_pari.X */ + +( "init_pari.X" +"FEerror" +"free" +"set_pari_stack" +"malloc" +) + +;;/* for file iteration.X */ + +( "iteration.X" +"lex_block_bind" +"frs_overflow" +"endp1" +"eval" +"eval" +"endp1" +"FEinvalid_form" +"not_a_variable" +"FEerror" +"endp1" +"FEtoo_few_argumentsF" +"FEinvalid_form" +"lex_block_bind" +"frs_overflow" +"eval" +"Ftagbody" +"bds_unwind" +"endp1" +"FEtoo_few_argumentsF" +"FEinvalid_form" +"lex_block_bind" +"frs_overflow" +"eval" +"Ftagbody" +"bds_unwind" +"endp1" +"FEtoo_few_argumentsF" +"FEerror" +"lex_block_bind" +"frs_overflow" +"eval" +"bind_var" +"eval" +"Ftagbody" +"bds_unwind" +"endp1" +"FEtoo_few_argumentsF" +"FEerror" +"lex_block_bind" +"frs_overflow" +"eval" +"FEwrong_type_argument" +"bind_var" +"number_compare" +"eval" +"Ftagbody" +"bds_unwind" +) + +;;/* for file let.X */ + +( "let.X" +"endp1" +"not_a_variable" +"not_a_variable" +"FEerror" +"endp1" +"FEerror" +"Fprogn" +"bds_unwind" +"endp1" +"FEerror" +"Fprogn" +"bds_unwind" +"endp1" +"FEerror" +"eval" +"not_a_variable" +"bind_var" +"Fprogn" +"bds_unwind" +"endp1" +"FEerror" +"eval" +"bind_var" +"Fprogn" +"bds_unwind" +"endp1" +"FEtoo_few_argumentsF" +"FEerror" +"lex_fun_bind" +"Fprogn" +"endp1" +"FEtoo_few_argumentsF" +"FEerror" +"lex_fun_bind" +"Fprogn" +"endp1" +"FEtoo_few_argumentsF" +"FEerror" +"lex_macro_bind" +"Fprogn" +) + +;;/* for file lex.X */ + +( "lex.X" +"endp1" +"endp1" +"eql" +"endp1" +"enter_mark_origin" +) + +;;/* for file list.X */ + +( "list.X" +"eql" +"FEerror" +"FEwrong_type_argument" +"FEwrong_type_argument" +"FEwrong_type_argument" +"FEwrong_type_argument" +"FEwrong_type_argument" +"FEwrong_type_argument" +"FEwrong_type_argument" +"vs_overflow" +"vs_overflow" +"FEwrong_type_argument" +"vs_overflow" +"vs_overflow" +"FEwrong_type_argument" +"check_arg_failed" +"FEwrong_type_argument" +"check_arg_failed" +"FEwrong_type_argument" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"too_few_arguments" +"parse_key" +"frs_overflow" +"unwind" +"check_arg_failed" +"FEwrong_type_argument" +"check_arg_failed" +"FEwrong_type_argument" +"check_arg_failed" +"fixint" +"FEerror" +"FEwrong_type_argument" +"check_arg_failed" +"fixint" +"FEerror" +"FEwrong_type_argument" +"check_arg_failed" +"FEwrong_type_argument" +"too_few_arguments" +"too_few_arguments" +"parse_key" +"check_type_non_negative_integer" +"FEerror" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"FEwrong_type_argument" +"FEwrong_type_argument" +"FEwrong_type_argument" +"check_arg_failed" +"FEwrong_type_argument" +"too_few_arguments" +"too_many_arguments" +"check_type_non_negative_integer" +"FEwrong_type_argument" +"vs_overflow" +"too_few_arguments" +"too_many_arguments" +"check_type_non_negative_integer" +"FEwrong_type_argument" +"check_arg_failed" +"FEwrong_type_argument" +"vs_overflow" +"check_arg_failed" +"check_type_cons" +"check_arg_failed" +"check_type_cons" +"too_few_arguments" +"parse_key" +"frs_overflow" +"unwind" +"too_few_arguments" +"too_few_arguments" +"too_few_arguments" +"parse_key" +"frs_overflow" +"unwind" +"too_few_arguments" +"too_few_arguments" +"FEwrong_type_argument" +"FEerror" +"too_few_arguments" +"parse_key" +"frs_overflow" +"unwind" +"too_few_arguments" +"parse_key" +"frs_overflow" +"unwind" +"too_few_arguments" +"parse_key" +"frs_overflow" +"FEwrong_type_argument" +"unwind" +"too_few_arguments" +"too_few_arguments" +"too_few_arguments" +"parse_key" +"frs_overflow" +"FEwrong_type_argument" +"unwind" +"check_arg_failed" +"FEwrong_type_argument" +"too_few_arguments" +"check_arg_failed" +"too_few_arguments" +"too_many_arguments" +"FEwrong_type_argument" +"FEerror" +"vs_overflow" +"FEerror" +"too_few_arguments" +"parse_key" +"frs_overflow" +"FEwrong_type_argument" +"unwind" +"check_arg_failed" +"FEwrong_type_argument" +"check_arg_failed" +) + +;;/* for file macros.X */ + +( "macros.X" +"check_arg_failed" +"not_a_symbol" +"FEerror" +"endp1" +"FEtoo_few_argumentsF" +"not_a_symbol" +"FEerror" +"super_funcall" +"too_few_arguments" +"too_many_arguments" +"too_few_arguments" +"too_many_arguments" +"super_funcall" +"enter_mark_origin" +) + +;;/* for file main.X */ + +( "main.X" +"setbuf" +"error" +"clear_stack" +"getrlimit" +"set_maxpage" +"bzero" +"sigstack" +"init_interrupt" +"super_funcall" +"multiply_stacks" +"printf" +"fflush" +"initlisp" +"init_init" +"init_interrupt" +"super_funcall" +"sigvec" +"init_alloc" +"init_symbol" +"init_package" +"import" +"export" +"enter_mark_origin" +"NewInit" +"init_typespec" +"init_pari" +"init_number" +"init_character" +"init_file" +"init_read" +"init_bind" +"init_pathname" +"init_print" +"init_GBC" +"init_unixfasl" +"init_unixsys" +"init_unixsave" +"init_alloc_function" +"init_array_function" +"init_character_function" +"init_file_function" +"init_list_function" +"init_package_function" +"init_pathname_function" +"init_predicate_function" +"init_print_function" +"init_read_function" +"init_sequence_function" +"init_socket_function" +"init_structure_function" +"init_string_function" +"init_symbol_function" +"init_typespec_function" +"init_hash" +"init_cfun" +"init_unixfsys" +"init_unixtime" +"init_eval" +"init_lex" +"init_prog" +"init_catch" +"init_block" +"init_macros" +"init_conditional" +"init_reference" +"init_assignment" +"init_multival" +"init_error" +"init_let" +"init_mapfun" +"init_iteration" +"init_toplevel" +"init_cmpaux" +"init_main" +"init_format" +"init_links" +"init_fat_string" +"init_cmac" +"init_interrupt1" +"error" +"FEerror" +"error" +"FEerror" +"error" +"FEerror" +"error" +"FEerror" +"error" +"error" +"FEerror" +"error" +"sgc_quit" +"FEerror" +"printf" +"fflush" +"FEerror" +"too_many_arguments" +"printf" +"check_arg_failed" +"check_arg_failed" +"FEerror" +"check_arg_failed" +"check_type_string" +"FEerror" +"check_arg_failed" +"check_arg_failed" +"FEerror" +"check_arg_failed" +"enter_mark_origin" +"array_allocself" +"bcopy" +"bcopy" +"bcopy" +"bcopy" +"check_arg_failed" +"init_system" +"check_arg_failed" +"check_arg_failed" +"fixint" +"check_arg_failed" +"printf" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"getdomainname" +"yp_unbind" +"GBC" +"brk" +"Lsave" +"enter_mark_origin" +) + +;;/* for file mapfun.X */ + +( "mapfun.X" +"too_few_arguments" +"endp1" +"super_funcall" +"endp1" +"too_few_arguments" +"endp1" +"super_funcall" +"endp1" +"too_few_arguments" +"endp1" +"super_funcall" +"endp1" +"too_few_arguments" +"endp1" +"super_funcall" +"endp1" +"too_few_arguments" +"endp1" +"super_funcall" +"endp1" +"too_few_arguments" +"endp1" +"super_funcall" +"endp1" +) + +;;/* for file multival.X */ + +( "multival.X" +"check_arg_failed" +"endp1" +"endp1" +"FEtoo_few_argumentsF" +"FEtoo_many_argumentsF" +"eval" +"endp1" +"FEtoo_few_argumentsF" +"eval" +"super_funcall" +"endp1" +"FEtoo_few_argumentsF" +"eval" +) + +;;/* for file nfunlink.X */ + +( "nfunlink.X" +"FEerror" +"FEinvalid_function" +"vpush_extend" +"FEerror" +"vs_overflow" +"ihs_punsh_base" +"ihs_overflow" +"funcall" +"FEerror" +) + +;;/* for file num_arith.X */ + +( "num_arith.X" +"FEwrong_type_argument" +"FEwrong_type_argument" +"FEwrong_type_argument" +"FEwrong_type_argument" +"FEwrong_type_argument" +"FEwrong_type_argument" +"FEwrong_type_argument" +"FEwrong_type_argument" +"FEwrong_type_argument" +"FEwrong_type_argument" +"FEwrong_type_argument" +"FEwrong_type_argument" +"FEwrong_type_argument" +"FEwrong_type_argument" +"FEwrong_type_argument" +"FEwrong_type_argument" +"number_zerop" +"zero_divisor" +"number_minusp" +"FEwrong_type_argument" +"number_zerop" +"zero_divisor" +"FEwrong_type_argument" +"zero_divisor" +"number_zerop" +"FEwrong_type_argument" +"number_minusp" +"number_compare" +"check_type_number" +"too_few_arguments" +"check_type_number" +"check_type_number" +"too_few_arguments" +"check_type_number" +"check_arg_failed" +"check_type_number" +"check_arg_failed" +"check_type_number" +"check_arg_failed" +"check_type_number" +"check_type_integer" +"number_minusp" +"too_few_arguments" +"check_type_integer" +"number_minusp" +"number_minusp" +"FEerror" +) + +;;/* for file num_co.X */ + +( "num_co.X" +"too_few_arguments" +"too_many_arguments" +"check_type_float" +"FEwrong_type_argument" +"check_arg_failed" +"check_type_rational" +"check_arg_failed" +"check_type_rational" +"too_few_arguments" +"FEwrong_type_argument" +"too_many_arguments" +"number_zerop" +"integer_quotient_remainder_1" +"number_minusp" +"number_plusp" +"check_type_or_rational_float" +"number_minusp" +"number_compare" +"too_few_arguments" +"FEwrong_type_argument" +"too_many_arguments" +"number_zerop" +"integer_quotient_remainder_1" +"number_plusp" +"number_minusp" +"check_type_or_rational_float" +"number_plusp" +"number_compare" +"too_few_arguments" +"FEwrong_type_argument" +"too_many_arguments" +"integer_quotient_remainder_1" +"check_type_or_rational_float" +"too_few_arguments" +"number_oddp" +"FEwrong_type_argument" +"too_many_arguments" +"check_type_or_rational_float" +"number_compare" +"number_oddp" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_type_float" +"check_arg_failed" +"check_type_float" +"FEerror" +"check_arg_failed" +"check_type_float" +"too_few_arguments" +"too_many_arguments" +"check_type_float" +"check_arg_failed" +"check_type_float" +"check_arg_failed" +"check_type_float" +"check_arg_failed" +"check_type_float" +"too_few_arguments" +"too_many_arguments" +"check_type_or_rational_float" +"check_arg_failed" +"check_type_number" +"check_arg_failed" +"check_type_number" +"enter_mark_origin" +) + +;;/* for file num_comp.X */ + +( "num_comp.X" +"cmpii" +"number_zerop" +"FEwrong_type_argument" +"too_few_arguments" +"check_type_number" +"too_few_arguments" +"check_type_number" +"too_few_arguments" +"check_type_or_rational_float" +"too_few_arguments" +"check_type_or_rational_float" +"too_few_arguments" +"check_type_or_rational_float" +) + +;;/* for file num_log.X */ + +( "num_log.X" +"too_few_arguments" +"gcopy_to_big" +"FEwrong_type_argument" +"FEwrong_type_argument" +"check_type_integer" +"check_type_integer" +"check_type_integer" +"check_type_integer" +"check_arg_failed" +"check_type_integer" +"fixint" +"FEerror" +"check_arg_failed" +"check_type_integer" +"check_arg_failed" +"check_type_integer" +"FEerror" +"check_arg_failed" +"check_type_integer" +"check_arg_failed" +"FEwrong_type_argument" +"check_arg_failed" +"siLmake_vector" +"siLmake_pure_array" +"fixint" +"FEerror" +"FEerror" +) + +;;/* for file num_pred.X */ + +( "num_pred.X" +"FEwrong_type_argument" +"FEwrong_type_argument" +"FEwrong_type_argument" +"FEwrong_type_argument" +"FEwrong_type_argument" +"check_arg_failed" +"check_type_number" +"check_arg_failed" +"check_type_or_rational_float" +"check_arg_failed" +"check_type_or_rational_float" +"check_arg_failed" +"check_type_integer" +"check_arg_failed" +"check_type_integer" +"enter_mark_origin" +) + +;;/* for file num_rand.X */ + +( "num_rand.X" +"number_compare" +"FEwrong_type_argument" +"FEerror" +"time" +"FEwrong_type_argument" +"check_arg_failed" +"check_type_random_state" +"check_arg_failed" +"check_arg_failed" +) + +;;/* for file num_sfun.X */ + +( "num_sfun.X" +"FEwrong_type_argument" +"FEwrong_type_argument" +"number_zerop" +"number_plusp" +"FEerror" +"number_minusp" +"number_plusp" +"number_evenp" +"number_zerop" +"FEerror" +"number_minusp" +"FEwrong_type_argument" +"number_zerop" +"FEerror" +"number_minusp" +"FEwrong_type_argument" +"FEerror" +"FEwrong_type_argument" +"FEwrong_type_argument" +"number_zerop" +"FEerror" +"check_arg_failed" +"check_type_number" +"check_arg_failed" +"check_type_number" +"too_few_arguments" +"check_type_number" +"check_type_number" +"too_many_arguments" +"check_arg_failed" +"check_type_number" +"check_arg_failed" +"check_type_number" +"check_arg_failed" +"check_type_number" +"check_arg_failed" +"check_type_number" +"too_few_arguments" +"check_type_number" +"check_type_or_rational_float" +"too_many_arguments" +"enter_mark_origin" +) + +;;/* for file number.X */ + +( "number.X" +"FEerror" +"FEerror" +"number_zerop" +"FEerror" +"number_minusp" +"enter_mark_origin" +"init_num_pred" +"init_num_comp" +"init_num_arith" +"init_num_co" +"init_num_log" +"init_num_sfun" +"init_num_rand" +) + +;;/* for file package.X */ + +( "package.X" +"string_equal" +"pack_hash" +"package_already" +"endp1" +"no_package" +"endp1" +"package_already" +"use_package" +"equal" +"package_already" +"endp1" +"FEwrong_type_argument" +"string_equal" +"no_package" +"FEerror" +"bcmp" +"bcmp" +"member_eq" +"member_eq" +"FEerror" +"delete_eq" +"import" +"FEerror" +"member_eq" +"delete_eq" +"FEerror" +"delete_eq" +"FEerror" +"member_eq" +"member_eq" +"delete_eq" +"no_package" +"FEerror" +"member_eq" +"no_package" +"delete_eq" +"too_few_arguments" +"parse_key" +"check_type_or_string_symbol" +"too_few_arguments" +"parse_key" +"check_type_or_string_symbol" +"check_arg_failed" +"check_arg_failed" +"check_type_package" +"check_arg_failed" +"too_few_arguments" +"too_many_arguments" +"check_type_or_string_symbol" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"stack_cons" +"too_few_arguments" +"too_many_arguments" +"check_type_string" +"too_few_arguments" +"too_many_arguments" +"check_type_string" +"too_few_arguments" +"too_many_arguments" +"check_type_symbol" +"too_few_arguments" +"too_many_arguments" +"endp1" +"check_type_symbol" +"too_few_arguments" +"too_many_arguments" +"endp1" +"check_type_symbol" +"too_few_arguments" +"too_many_arguments" +"endp1" +"check_type_symbol" +"too_few_arguments" +"too_many_arguments" +"endp1" +"check_type_symbol" +"too_few_arguments" +"too_many_arguments" +"endp1" +"check_type_symbol" +"too_few_arguments" +"too_many_arguments" +"endp1" +"check_type_package" +"too_few_arguments" +"too_many_arguments" +"endp1" +"check_type_package" +"check_arg_failed" +"check_type_package" +"FEerror" +"check_arg_failed" +"check_type_package" +"FEerror" +"FEerror" +"FEerror" +"check_type_package" +"check_arg_failed" +"enter_mark_origin" +) + +;;/* for file pathname.X */ + +( "pathname.X" +"stack_cons" +"FEerror" +"endp1" +"FEerror" +"FEerror" +"check_arg_failed" +"check_type_or_pathname_string_symbol_stream" +"too_few_arguments" +"parse_key" +"check_type_or_pathname_string_symbol_stream" +"get_string_start_end" +"FEerror" +"FEerror" +"FEerror" +"too_few_arguments" +"too_many_arguments" +"check_type_or_pathname_string_symbol_stream" +"too_few_arguments" +"parse_key" +"check_arg_failed" +"check_arg_failed" +"check_type_or_pathname_string_symbol_stream" +"check_arg_failed" +"check_type_or_pathname_string_symbol_stream" +"check_arg_failed" +"check_type_or_pathname_string_symbol_stream" +"check_arg_failed" +"check_type_or_pathname_string_symbol_stream" +"check_arg_failed" +"check_type_or_pathname_string_symbol_stream" +"check_arg_failed" +"check_type_or_pathname_string_symbol_stream" +"check_arg_failed" +"check_type_or_pathname_string_symbol_stream" +"check_arg_failed" +"check_type_or_pathname_string_symbol_stream" +"check_arg_failed" +"check_type_or_pathname_string_symbol_stream" +"check_arg_failed" +"check_type_or_pathname_string_symbol_stream" +"too_few_arguments" +"too_many_arguments" +"check_type_or_pathname_string_symbol_stream" +"equalp" +) + +;;/* for file predicate.X */ + +( "predicate.X" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"big_compare" +"check_arg_failed" +"string_eq" +"check_arg_failed" +"number_compare" +"char_equal" +"check_arg_failed" +"endp1" +"eval" +"eval" +"endp1" +"eval" +"eval" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +) + +;;/* for file print.X */ + +( "print.X" +"flush_queue" +"FEerror" +"file_column" +"writec_stream" +"writec_stream" +"file_column" +"FEerror" +"writec_stream" +"writec_stream" +"write_decimal1" +"FEerror" +"alarm" +"terminal_interrupt" +"frs_overflow" +"bds_unwind" +"unwind" +"digit_weight" +"big_zerop" +"vs_overflow" +"digit_weight" +"div_int_big" +"error" +"FEerror" +"potential_number_p" +"fixint" +"error" +"FEwrong_type_argument" +"error" +"vs_overflow" +"FEwrong_type_argument" +"FEerror" +"FEerror" +"FEerror" +"FEerror" +"flush_stream" +"FEwrong_type_argument" +"writec_stream" +"digitp" +"too_few_arguments" +"parse_key" +"FEerror" +"flush_stream" +"too_few_arguments" +"too_many_arguments" +"too_few_arguments" +"too_many_arguments" +"too_few_arguments" +"too_many_arguments" +"check_type_stream" +"writec_stream" +"flush_stream" +"too_few_arguments" +"too_many_arguments" +"too_few_arguments" +"too_many_arguments" +"check_type_character" +"check_type_stream" +"writec_stream" +"too_few_arguments" +"parse_key" +"get_string_start_end" +"check_type_string" +"check_type_stream" +"writec_stream" +"flush_stream" +"too_few_arguments" +"parse_key" +"get_string_start_end" +"check_type_string" +"check_type_stream" +"writec_stream" +"flush_stream" +"too_few_arguments" +"too_many_arguments" +"too_few_arguments" +"too_many_arguments" +"check_type_stream" +"file_column" +"writec_stream" +"flush_stream" +"too_few_arguments" +"too_many_arguments" +"check_type_stream" +"flush_stream" +"too_few_arguments" +"too_many_arguments" +"check_type_stream" +"flush_stream" +"too_few_arguments" +"too_many_arguments" +"check_type_stream" +"check_arg_failed" +"FEerror" +"check_type_stream" +"writec_stream" +"error" +"enter_mark_origin" +"FEerror" +"FEerror" +"flush_stream" +"FEerror" +"writec_stream" +"flush_stream" +"check_type_string" +"check_type_stream" +"writec_stream" +"flush_stream" +"check_type_stream" +"writestr_stream" +"check_type_stream" +"writec_stream" +"flush_stream" +"writec_stream" +"flush_stream" +) + +;;/* for file prog.X */ + +( "prog.X" +"endp1" +"lex_tag_bind" +"frs_overflow" +"eql" +"FEerror" +"eval" +"endp1" +"FEtoo_few_argumentsF" +"lex_block_bind" +"frs_overflow" +"let_var_list" +"bds_unwind" +"endp1" +"FEtoo_few_argumentsF" +"lex_block_bind" +"frs_overflow" +"let_var_list" +"bds_unwind" +"endp1" +"FEtoo_few_argumentsF" +"FEtoo_many_argumentsF" +"FEerror" +"unwind" +"endp1" +"FEtoo_few_argumentsF" +"eval" +"not_a_symbol" +"FEerror" +"Fprogn" +"bds_unwind" +"endp1" +"eval" +"endp1" +"FEtoo_few_argumentsF" +"eval" +"endp1" +"FEtoo_few_argumentsF" +"eval" +) + +;;/* for file read.X */ + +( "read.X" +"FEerror" +"FEerror" +"readc_stream" +"FEwrong_type_argument" +"unreadc_stream" +"readc_stream" +"readc_stream" +"frs_overflow" +"FEerror" +"FEerror" +"unwind" +"frs_overflow" +"unwind" +"frs_overflow" +"unwind" +"vs_overflow" +"_filbuf" +"end_of_stream" +"stream_at_end" +"end_of_stream" +"readc_stream" +"super_funcall" +"FEerror" +"too_long_token" +"_filbuf" +"stream_at_end" +"readc_stream" +"readc_stream" +"stream_at_end" +"end_of_stream" +"readc_stream" +"FEerror" +"FEerror" +"FEerror" +"FEerror" +"check_arg_failed" +"FEerror" +"readc_stream" +"digitp" +"mul_int_big" +"add_int_big" +"FEerror" +"mul_int_big" +"add_int_big" +"digitp" +"mul_int_big" +"add_int_big" +"readc_stream" +"too_long_string" +"_filbuf" +"stream_at_end" +"readc_stream" +"check_arg_failed" +"check_arg_failed" +"FEerror" +"readc_stream" +"digitp" +"super_funcall" +"check_arg_failed" +"stack_cons" +"check_arg_failed" +"check_arg_failed" +"_filbuf" +"stream_at_end" +"readc_stream" +"check_arg_failed" +"extra_argument" +"readc_stream" +"FEerror" +"contains_sharp_comma" +"check_type_number" +"check_arg_failed" +"FEerror" +"string_equal" +"check_arg_failed" +"extra_argument" +"stack_cons" +"check_arg_failed" +"unreadc_stream" +"backq_car" +"FEerror" +"endp1" +"vs_overflow" +"stack_cons" +"vs_overflow" +"FEerror" +"check_arg_failed" +"stream_at_end" +"readc_stream" +"vs_overflow" +"FEerror" +"error" +"extra_argument" +"readc_stream" +"too_long_token" +"stream_at_end" +"end_of_stream" +"check_arg_failed" +"extra_argument" +"check_arg_failed" +"extra_argument" +"check_arg_failed" +"extra_argument" +"check_arg_failed" +"extra_argument" +"extra_argument" +"FEerror" +"extra_argument" +"FEerror" +"extra_argument" +"FEerror" +"check_arg_failed" +"FEerror" +"FEerror" +"check_arg_failed" +"FEerror" +"eql" +"check_arg_failed" +"FEerror" +"eql" +"check_arg_failed" +"extra_argument" +"readc_stream" +"FEerror" +"check_arg_failed" +"extra_argument" +"check_arg_failed" +"extra_argument" +"FEerror" +"FEerror" +"too_few_arguments" +"too_many_arguments" +"check_type_stream" +"end_of_stream" +"too_few_arguments" +"too_many_arguments" +"check_type_stream" +"stream_at_end" +"readc_stream" +"end_of_stream" +"too_few_arguments" +"too_many_arguments" +"check_type_character" +"check_type_stream" +"frs_overflow" +"unwind" +"too_few_arguments" +"too_many_arguments" +"check_type_stream" +"stream_at_end" +"end_of_stream" +"_filbuf" +"readc_stream" +"too_long_string" +"too_few_arguments" +"too_many_arguments" +"check_type_stream" +"stream_at_end" +"end_of_stream" +"readc_stream" +"too_few_arguments" +"too_many_arguments" +"check_type_character" +"check_type_stream" +"too_few_arguments" +"too_many_arguments" +"check_type_stream" +"stream_at_end" +"end_of_stream" +"readc_stream" +"stream_at_end" +"readc_stream" +"end_of_stream" +"check_type_character" +"stream_at_end" +"readc_stream" +"char_eq" +"end_of_stream" +"too_few_arguments" +"too_many_arguments" +"check_type_stream" +"listen_stream" +"too_few_arguments" +"too_many_arguments" +"check_type_stream" +"listen_stream" +"readc_stream" +"too_few_arguments" +"too_many_arguments" +"check_type_stream" +"listen_stream" +"readc_stream" +"too_few_arguments" +"parse_key" +"check_type_string" +"get_string_start_end" +"FEerror" +"too_few_arguments" +"too_many_arguments" +"check_type_stream" +"stream_at_end" +"end_of_stream" +"readc_stream" +"stream_at_end" +"readc_stream" +"stream_at_end" +"readc_stream" +"too_few_arguments" +"too_many_arguments" +"check_type_readtable" +"check_type_readtable" +"check_arg_failed" +"too_few_arguments" +"too_many_arguments" +"check_type_character" +"check_type_readtable" +"too_few_arguments" +"too_many_arguments" +"check_type_character" +"check_type_readtable" +"too_few_arguments" +"too_many_arguments" +"check_type_character" +"check_type_readtable" +"too_few_arguments" +"too_many_arguments" +"check_type_character" +"check_type_readtable" +"too_few_arguments" +"too_many_arguments" +"check_type_character" +"check_type_readtable" +"FEerror" +"too_few_arguments" +"too_many_arguments" +"check_type_character" +"check_type_readtable" +"FEerror" +"digitp" +"check_arg_failed" +"check_type_string" +"check_arg_failed" +"FEerror" +"enter_mark_origin" +"init_backq" +"frs_overflow" +"readc_stream" +"vs_overflow" +"system_error" +"unwind" +) + +;;/* for file reference.X */ + +( "reference.X" +"check_arg_failed" +"not_a_symbol" +"FEinvalid_function" +"FEundefined_function" +"check_arg_failed" +"not_a_symbol" +"stack_cons" +"FEundefined_function" +"stack_cons" +"endp1" +"FEtoo_few_argumentsF" +"FEtoo_many_argumentsF" +"endp1" +"FEtoo_few_argumentsF" +"FEtoo_many_argumentsF" +"FEundefined_function" +"FEinvalid_function" +"check_arg_failed" +"not_a_symbol" +"FEunbound_variable" +"check_arg_failed" +"not_a_symbol" +"check_arg_failed" +"not_a_symbol" +"check_arg_failed" +"not_a_symbol" +) + +;;/* for file run_process.X */ + +( "run_process.X" +"malloc" +"FEerror" +"bzero" +"bcopy" +"socket" +"FEerror" +"connect" +"close" +"FEerror" +"getpid" +"ioctl" +"FEerror" +"FEerror" +"setup_stream_buffer" +"check_arg_failed" +"socketpair" +"FEerror" +"setup_stream_buffer" +"FEerror" +"fork" +"close" +"dup" +"fprintf" +"execvp" +"fflush" +"object_to_string" +) + +;;/* for file sequence.X */ + +( "sequence.X" +"check_arg_failed" +"fixint" +"FEerror" +"FEwrong_type_argument" +"FEerror" +"FEerror" +"check_arg_failed" +"fixint" +"FEerror" +"FEwrong_type_argument" +"FEerror" +"FEerror" +"too_few_arguments" +"too_many_arguments" +"fixnnint" +"FEwrong_type_argument" +"vs_overflow" +"stack_cons" +"array_allocself" +"FEerror" +"check_arg_failed" +"FEwrong_type_argument" +"check_arg_failed" +"check_arg_failed" +"FEwrong_type_argument" +"array_allocself" +"check_arg_failed" +"FEwrong_type_argument" +) + +;;/* for file sfasl.X */ + +( "sfasl.X" +"printf" +"fflush" +"printf" +"fflush" +"coerce_to_filename" +"fread" +"FEerror" +"fseek" +"_filbuf" +"ungetc" +"build_symbol_table" +"get_extra_bss" +"relocate_symbols" +"close_stream" +"free" +"call_init" +"printf" +"fwrite" +"fclose" +"set_symbol_address" +"fprintf" +"fflush" +"FEerror" +"printf" +"fflush" +"getpid" +"coerce_to_filename" +"system" +"FEerror" +"read_special_symbols" +"unlink" +"qsort" +) + +;;/* for file string.X */ + +( "string.X" +"FEerror" +"check_arg_failed" +"check_type_string" +"illegal_index" +"check_arg_failed" +"check_type_string" +"illegal_index" +"check_type_character" +"FEerror" +"too_few_arguments" +"parse_key" +"too_few_arguments" +"parse_key" +"too_few_arguments" +"parse_key" +"too_few_arguments" +"parse_key" +"too_few_arguments" +"parse_key" +"endp1" +"FEerror" +"Lstring_trim0" +"Lstring_trim0" +"Lstring_trim0" +"check_arg_failed" +"too_few_arguments" +"parse_key" +"too_few_arguments" +"parse_key" +"check_type_string" +"check_arg_failed" +) + +;;/* for file structure.X */ + +( "structure.X" +"FEerror" +"FEerror" +"FEwrong_type_argument" +"FEwrong_type_argument" +"FEerror" +"FEwrong_type_argument" +"FEerror" +"check_arg_failed" +"endp1" +"stack_cons" +"too_few_arguments" +"FEerror" +"bzero" +"too_few_arguments" +"FEwrong_type_argument" +"bcopy" +"check_arg_failed" +"FEwrong_type_argument" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"FEerror" +"endp1" +"check_arg_failed" +"FEerror" +"endp1" +"check_arg_failed" +"check_arg_failed" +"FEwrong_type_argument" +"get_aelttype" +"get_aelttype" +) + +;;/* for file symbol.X */ + +( "symbol.X" +"pack_hash" +"string_eq" +"pack_hash" +"string_eq" +"error" +"pack_hash" +"string_eq" +"FEunbound_variable" +"FEerror" +"not_a_symbol" +"FEerror" +"not_a_symbol" +"not_a_symbol" +"endp1" +"odd_plist" +"not_a_symbol" +"too_few_arguments" +"too_many_arguments" +"check_type_symbol" +"check_arg_failed" +"check_type_symbol" +"check_arg_failed" +"check_type_symbol" +"too_few_arguments" +"too_many_arguments" +"check_arg_failed" +"endp1" +"odd_plist" +"FEerror" +"check_arg_failed" +"check_arg_failed" +"check_type_string" +"too_few_arguments" +"too_many_arguments" +"check_type_symbol" +"too_few_arguments" +"too_many_arguments" +"check_type_non_negative_integer" +"too_few_arguments" +"too_many_arguments" +"check_type_string" +"check_type_package" +"check_arg_failed" +"check_type_symbol" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_arg_failed" +"check_type_symbol" +"check_arg_failed" +"check_type_symbol" +"FEerror" +"enter_mark_origin" +"enter_mark_origin" +) + +;;/* for file toplevel.X */ + +( "toplevel.X" +"endp1" +"FEtoo_few_argumentsF" +"FEerror" +"not_a_symbol" +"check_arg_failed" +"check_type_symbol" +"FEerror" +"check_arg_failed" +"check_type_symbol" +"FEerror" +"endp1" +"FEtoo_few_argumentsF" +"FEinvalid_form" +"eval" +"FEerror" +"Fprogn" +"endp1" +"FEtoo_few_argumentsF" +"FEtoo_many_argumentsF" +"eval" +"FEerror" +"FEwrong_type_argument" +"FEerror" +"FEwrong_type_argument" +"enter_mark_origin" +) + +;;/* for file typespec.X */ + +( "typespec.X" +"FEerror" +"check_arg_failed" +"error" +"enter_mark_origin" +) + +;;/* for file unixfasl.X */ + +( "unixfasl.X" +"coerce_to_filename" +"getpid" +"system" +"FEerror" +"setbuf" +"fread" +"fclose" +"fseek" +"close_stream" +"printf" +"error" +"unlink" +"call_init" +"check_arg_failed" +"check_type_or_pathname_string_symbol_stream" +"check_type_string" +"bds_unwind" +) + +;;/* for file unixfsys.X */ + +( "unixfsys.X" +"bcopy" +"getuid" +"FEerror" +"FEerror" +"bcopy" +"chdir" +"FEerror" +"chdir" +"strcat" +"system" +"check_arg_failed" +"check_type_or_pathname_string_symbol_stream" +"check_arg_failed" +"check_type_or_pathname_string_symbol_stream" +"check_type_or_Pathname_string_symbol" +"rename" +"FEerror" +"check_arg_failed" +"check_type_or_pathname_string_symbol_stream" +"unlink" +"FEerror" +"check_arg_failed" +"check_type_or_pathname_string_symbol_stream" +"check_arg_failed" +"check_type_or_pathname_string_symbol_stream" +"check_arg_failed" +"check_type_or_pathname_string_symbol_stream" +"too_many_arguments" +"getuid" +"check_arg_failed" +"check_type_or_pathname_string_symbol_stream" +"strcat" +"strcat" +"setbuf" +"_filbuf" +"pclose" +"stack_cons" +"check_arg_failed" +"check_type_or_pathname_string_symbol_stream" +"chdir" +"FEerror" +) + +;;/* for file unixint.X */ + +( "unixint.X" +"terminal_interrupt" +"fprintf" +"fflush" +"gcl_signal" +"gcl_signal" +"gcl_signal" +"alarm" +"gcl_signal" +"FEerror" +"error" +"FEerror" +"check_arg_failed" +"gcl_signal" +"check_arg_failed" +"gcl_signal" +"gcl_signal" +) + +;;/* for file unixsave.X */ + +( "unixsave.X" +"fread" +"fwrite" +"fread" +"fwrite" +"fprintf" +"setbuf" +"fclose" +"unlink" +"fprintf" +"fread" +"fwrite" +"fseek" +"check_arg_failed" +"check_type_or_pathname_string_symbol_stream" +"coerce_to_filename" +"_cleanup" +) + +;;/* for file unixsys.X */ + +( "unixsys.X" +"check_arg_failed" +"check_type_string" +"FEerror" +"system" +) + +;;/* for file unixtime.X */ + +( "unixtime.X" +"check_arg_failed" +"time" +"check_arg_failed" +"check_type_or_rational_float" +"number_minusp" +"FEerror" +"Lround" +"sleep" +"check_arg_failed" +"check_arg_failed" +"gettimeofday" +"ftime" +) + +;;/* for file user_init.X */ + +( "user_init.X" +) +)) diff --git a/o/iteration.c b/o/iteration.c new file mode 100755 index 0000000..452ea6d --- /dev/null +++ b/o/iteration.c @@ -0,0 +1,458 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +/* + + iteration.c + +*/ + +#include "include.h" + +static void +FFN(Floop)(object form) +{ + + object x; + object *oldlex = lex_env; + object *top; + + make_nil_block(); + + if (nlj_active) { + nlj_active = FALSE; + frs_pop(); + lex_env = oldlex; + return; + } + + top = vs_top; + + for(x = form; !endp(x); x = MMcdr(x)) { + vs_top = top; + eval(MMcar(x)); + } +LOOP: + /* Just !endp(x) is replaced by x != Cnil. */ + for(x = form; x != Cnil; x = MMcdr(x)) { + vs_top = top; + eval(MMcar(x)); + } + goto LOOP; +} + +/* + use of VS in Fdo and FdoA: + | | + lex_env -> | lex1 | + | lex2 | + | lex3 | + start -> |-------| where each bt is a bind_temp: + | bt1 | + |-------| | var | -- name of DO variable + : | spp | -- T if special + |-------| | init | + | btn | | aux | -- step-form or var (if no + |-------| step-form is given) + end -> | body | + old_top-> |-------| If 'spp' != T, it is NIL during + initialization, and is the pointer to + (var value) in lexical environment + during the main loop. +*/ + +static void +do_var_list(object var_list) +{ + + object is, x, y; + + for (is = var_list; !endp(is); is = MMcdr(is)) { + x = MMcar(is); + if (type_of(x)==t_symbol) + {vs_push(x);vs_push(Cnil);vs_push(Cnil);vs_push(x); + continue;} + + + + + + if (type_of(x) != t_cons) + FEinvalid_form("The index, ~S, is illegal.", x); + y = MMcar(x); + check_var(y); + vs_push(y); + vs_push(Cnil); + if (endp(MMcdr(x))) { + vs_push(Cnil); + vs_push(y); + } else { + x = MMcdr(x); + vs_push(MMcar(x)); + if (endp(MMcdr(x))) + vs_push(y); + else { + x = MMcdr(x); + vs_push(MMcar(x)); + if (!endp(MMcdr(x))) + FEerror("Too many forms to the index ~S.", + 1, y); + } + } + } +} + +static void +FFN(Fdo)(VOL object arg) +{ + + object *oldlex = lex_env; + object *old_top; + struct bind_temp *start, *end, *bt; + object end_test, body; + VOL object result; + bds_ptr old_bds_top = bds_top; + + if (endp(arg) || endp(MMcdr(arg))) + FEtoo_few_argumentsF(arg); + if (endp(MMcadr(arg))) + FEinvalid_form("The DO end-test, ~S, is illegal.", + MMcadr(arg)); + + end_test = MMcaadr(arg); + result = MMcdadr(arg); + + make_nil_block(); + + if (nlj_active) { + nlj_active = FALSE; + goto END; + } + + start = (struct bind_temp *) vs_top; + + do_var_list(MMcar(arg)); + end = (struct bind_temp *)vs_top; + body = let_bind(MMcddr(arg), start, end); + vs_push(body); + + for (bt = start; bt < end; bt++) + if ((enum stype)bt->bt_var->s.s_stype != stp_ordinary) + bt->bt_spp = Ct; + else if (bt->bt_spp == Cnil) + bt->bt_spp = assoc_eq(bt->bt_var, lex_env[0]); + + old_top = vs_top; + +LOOP: /* the main loop */ + vs_top = old_top; + eval(end_test); + if (vs_base[0] != Cnil) { + /* RESULT evaluation */ + if (endp(result)) { + vs_base = vs_top = old_top; + vs_push(Cnil); + } else + do { + vs_top = old_top; + eval(MMcar(result)); + result = MMcdr(result); + } while (!endp(result)); + goto END; + } + + vs_top = old_top; + + Ftagbody(body); + + /* next step */ + for (bt = start; btbt_aux != bt->bt_var) { + eval_assign(bt->bt_init, bt->bt_aux); + } + } + for (bt = start; btbt_aux != bt->bt_var) { + if (bt->bt_spp == Ct) + bt->bt_var->s.s_dbind = bt->bt_init; + else + MMcadr(bt->bt_spp) = bt->bt_init; + } + } + goto LOOP; + +END: + bds_unwind(old_bds_top); + frs_pop(); + lex_env = oldlex; +} + +static void +FFN(FdoA)(VOL object arg) +{ + + object *oldlex = lex_env; + object *old_top; + struct bind_temp *start, *end, *bt; + object end_test, body; + VOL object result; + bds_ptr old_bds_top = bds_top; + + if (endp(arg) || endp(MMcdr(arg))) + FEtoo_few_argumentsF(arg); + if (endp(MMcadr(arg))) + FEinvalid_form("The DO* end-test, ~S, is illegal.", + MMcadr(arg)); + + end_test = MMcaadr(arg); + result = MMcdadr(arg); + + make_nil_block(); + + if (nlj_active) { + nlj_active = FALSE; + goto END; + } + + start = (struct bind_temp *)vs_top; + do_var_list(MMcar(arg)); + end = (struct bind_temp *)vs_top; + body = letA_bind(MMcddr(arg), start, end); + vs_push(body); + + for (bt = start; bt < end; bt++) + if ((enum stype)bt->bt_var->s.s_stype != stp_ordinary) + bt->bt_spp = Ct; + else if (bt->bt_spp == Cnil) + bt->bt_spp = assoc_eq(bt->bt_var, lex_env[0]); + + old_top = vs_top; + +LOOP: /* the main loop */ + eval(end_test); + if (vs_base[0] != Cnil) { + /* RESULT evaluation */ + if (endp(result)) { + vs_base = vs_top = old_top; + vs_push(Cnil); + } else + do { + vs_top = old_top; + eval(MMcar(result)); + result = MMcdr(result); + } while (!endp(result)); + goto END; + } + + vs_top = old_top; + + Ftagbody(body); + + /* next step */ + for (bt = start; bt < end; bt++) + if (bt->bt_aux != bt->bt_var) { + if (bt->bt_spp == Ct) { + eval_assign(bt->bt_var->s.s_dbind, bt->bt_aux); + } else { + eval_assign(MMcadr(bt->bt_spp), bt->bt_aux); + } + } + goto LOOP; + +END: + bds_unwind(old_bds_top); + frs_pop(); + lex_env = oldlex; +} + +static void +FFN(Fdolist)(VOL object arg) +{ + + object *oldlex = lex_env; + object *old_top; + struct bind_temp *start; + object x, listform, body; + VOL object result; + bds_ptr old_bds_top = bds_top; + + if (endp(arg)) + FEtoo_few_argumentsF(arg); + + x = MMcar(arg); + if (endp(x)) + FEerror("No variable.", 0); + start = (struct bind_temp *)vs_top; + vs_push(MMcar(x)); + vs_push(Cnil); + vs_push(Cnil); + vs_push(Cnil); + x = MMcdr(x); + if (endp(x)) + FEerror("No listform.", 0); + listform = MMcar(x); + x = MMcdr(x); + if (endp(x)) + result = Cnil; + else { + result = MMcar(x); + if (!endp(MMcdr(x))) + FEerror("Too many resultforms.", 0); + } + + make_nil_block(); + + if (nlj_active) { + nlj_active = FALSE; + goto END; + } + + eval_assign(start->bt_init, listform); + body = find_special(MMcdr(arg), start, start+1); + vs_push(body); + bind_var(start->bt_var, Cnil, start->bt_spp); + if ((enum stype)start->bt_var->s.s_stype != stp_ordinary) + start->bt_spp = Ct; + else if (start->bt_spp == Cnil) + start->bt_spp = assoc_eq(start->bt_var, lex_env[0]); + + old_top = vs_top; + +LOOP: /* the main loop */ + if (endp(start->bt_init)) { + if (start->bt_spp == Ct) + start->bt_var->s.s_dbind = Cnil; + else + MMcadr(start->bt_spp) = Cnil; + eval(result); + goto END; + } + + if (start->bt_spp == Ct) + start->bt_var->s.s_dbind = MMcar(start->bt_init); + else + MMcadr(start->bt_spp) = MMcar(start->bt_init); + start->bt_init = MMcdr(start->bt_init); + + vs_top = old_top; + + Ftagbody(body); + + goto LOOP; + +END: + bds_unwind(old_bds_top); + frs_pop(); + lex_env = oldlex; +} + +static void +FFN(Fdotimes)(VOL object arg) +{ + + object *oldlex = lex_env; + object *old_top; + struct bind_temp *start; + object x, countform, body; + VOL object result; + bds_ptr old_bds_top = bds_top; + + if (endp(arg)) + FEtoo_few_argumentsF(arg); + + x = MMcar(arg); + if (endp(x)) + FEerror("No variable.", 0); + start = (struct bind_temp *)vs_top; + vs_push(MMcar(x)); + vs_push(Cnil); + vs_push(Cnil); + vs_push(Cnil); + x = MMcdr(x); + if (endp(x)) + FEerror("No countform.", 0); + countform = MMcar(x); + x = MMcdr(x); + if (endp(x)) + result = Cnil; + else { + result = MMcar(x); + if (!endp(MMcdr(x))) + FEerror("Too many resultforms.", 0); + } + + make_nil_block(); + + if (nlj_active) { + nlj_active = FALSE; + goto END; + } + + eval_assign(start->bt_init, countform); + if (type_of(start->bt_init) != t_fixnum && + type_of(start->bt_init) != t_bignum) + FEwrong_type_argument(sLinteger, start->bt_init); + body = find_special(MMcdr(arg), start, start+1); + vs_push(body); + bind_var(start->bt_var, make_fixnum(0), start->bt_spp); + if ((enum stype)start->bt_var->s.s_stype != stp_ordinary) { + start->bt_spp = Ct; + x = start->bt_var->s.s_dbind; + } else if (start->bt_spp == Cnil) { + start->bt_spp = assoc_eq(start->bt_var, lex_env[0]); + x = MMcadr(start->bt_spp); + } else + x = start->bt_var->s.s_dbind; + + old_top = vs_top; + +LOOP: /* the main loop */ + if (number_compare(x, start->bt_init) >= 0) { + eval(result); + goto END; + } + + vs_top = old_top; + + Ftagbody(body); + + if (start->bt_spp == Ct) + x = start->bt_var->s.s_dbind = one_plus(x); + else + x = MMcadr(start->bt_spp) = one_plus(x); + + goto LOOP; + +END: + bds_unwind(old_bds_top); + frs_pop(); + lex_env = oldlex; +} + +void +gcl_init_iteration(void) +{ + make_special_form("LOOP", Floop); + make_special_form("DO", Fdo); + make_special_form("DO*", FdoA); + make_special_form("DOLIST", Fdolist); + make_special_form("DOTIMES", Fdotimes); +} diff --git a/o/lastfile.c b/o/lastfile.c new file mode 100755 index 0000000..126a64b --- /dev/null +++ b/o/lastfile.c @@ -0,0 +1,50 @@ +/* Mark end of data space to dump as pure, for GNU Emacs. + Copyright (C) 1985 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + + +#include "config.h" + +/* How this works: + + Fdump_emacs dumps everything up to my_edata as text space (pure). + + The files of Emacs are written so as to have no initialized + data that can ever need to be altered except at the first startup. + This is so that those words can be dumped as sharable text. + + It is not possible to exercise such control over library files. + So it is necessary to refrain from making their data areas shared. + Therefore, this file is loaded following all the files of Emacs + but before library files. + As a result, the symbol my_edata indicates the point + in data space between data coming from Emacs and data + coming from libraries. +*/ + +char my_edata[] = "End of Emacs initialized data"; + +/* Help unexec locate the end of the .bss area used by Emacs (which + isn't always a separate section in NT executables). */ +char my_endbss[1]; +/* The Alpha MSVC linker globally segregates all static and public bss + data, so we must take both into account to determine the true extent + of the bss area used by Emacs. */ +static char _my_endbss[1]; +char * my_endbss_static = _my_endbss; diff --git a/o/let.c b/o/let.c new file mode 100755 index 0000000..6a656ef --- /dev/null +++ b/o/let.c @@ -0,0 +1,322 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +/* + let.c +*/ + +#include "include.h" + +void +let_var_list(object var_list) +{ + + object x, y; + + for (x = var_list; !endp(x); x = x->c.c_cdr) { + y = x->c.c_car; + if (type_of(y) == t_symbol) { + check_var(y); + vs_push(y); + vs_push(Cnil); + vs_push(Cnil); + vs_push(Cnil); + } else { + endp(y); + check_var(y->c.c_car); + vs_push(y->c.c_car); + vs_push(Cnil); + y = y->c.c_cdr; + if (endp(y)) /* + FEerror("No initial form to the variable ~S.", + 1, vs_top[-2]) */ ; + else if (!endp(y->c.c_cdr)) + FEerror("Too many initial forms to the variable ~S.", + 1, vs_top[-2]); + vs_push(y->c.c_car); + vs_push(Cnil); + } + } +} + +static void +FFN(Flet)(object form) +{ + + object body; + struct bind_temp *start; + object *old_lex; + bds_ptr old_bds_top; + + if (endp(form)) + FEerror("No argument to LET.", 0); + + old_lex = lex_env; + lex_copy(); + old_bds_top = bds_top; + + start = (struct bind_temp *)vs_top; + let_var_list(form->c.c_car); + body = let_bind(form->c.c_cdr, start, (struct bind_temp *)vs_top); + vs_top = (object *)start; + vs_push(body); + + Fprogn(body); + + lex_env = old_lex; + bds_unwind(old_bds_top); +} + +static void +FFN(FletA)(object form) +{ + + object body; + struct bind_temp *start; + object *old_lex; + bds_ptr old_bds_top; + + if (endp(form)) + FEerror("No argument to LET*.", 0); + + old_lex = lex_env; + lex_copy(); + old_bds_top = bds_top; + + start = (struct bind_temp *)vs_top; + let_var_list(form->c.c_car); + body = letA_bind(form->c.c_cdr, start, (struct bind_temp *)vs_top); + vs_top = (object *)start; + vs_push(body); + + Fprogn(body); + + lex_env = old_lex; + bds_unwind(old_bds_top); +} + +static void +FFN(Fmultiple_value_bind)(object form) +{ + + object body, values_form, x, y; + int n, m, i; + object *base; + object *old_lex; + bds_ptr old_bds_top; + struct bind_temp *start; + + if (endp(form)) + FEerror("No argument to MULTIPLE-VALUE-BIND.", 0); + body = form->c.c_cdr; + if (endp(body)) + FEerror("No values-form to MULTIPLE-VALUE-BIND.", 0); + values_form = body->c.c_car; + body = body->c.c_cdr; + + old_lex = lex_env; + lex_copy(); + old_bds_top = bds_top; + + eval(values_form); + base = vs_base; + m = vs_top - vs_base; + + start = (struct bind_temp *)vs_top; + for (n = 0, x = form->c.c_car; !endp(x); n++, x = x->c.c_cdr) { + y = x->c.c_car; + check_var(y); + vs_push(y); + vs_push(Cnil); + vs_push(Cnil); + vs_push(Cnil); + } + { + object *vt = vs_top; + vs_push(find_special(body, start, (struct bind_temp *)vt)); + } + for (i = 0; i < n; i++) + bind_var(start[i].bt_var, + (i < m ? base[i] : Cnil), + start[i].bt_spp); + body = vs_pop; + + vs_top = vs_base = base; + + vs_push(body); + Fprogn(body); + lex_env = old_lex; + bds_unwind(old_bds_top); +} + +static void +FFN(Fcompiler_let)(object form) +{ + + object body; + object *old_lex; + bds_ptr old_bds_top; + struct bind_temp *start, *end, *bt; + + if (endp(form)) + FEerror("No argument to COMPILER-LET.", 0); + + body = form->c.c_cdr; + + old_lex = lex_env; + lex_copy(); + old_bds_top = bds_top; + + start = (struct bind_temp *)vs_top; + let_var_list(form->c.c_car); + end = (struct bind_temp *)vs_top; + for (bt = start; bt < end; bt++) { + eval_assign(bt->bt_init, bt->bt_init); + } + for (bt = start; bt < end; bt++) + bind_var(bt->bt_var, bt->bt_init, Ct); + + vs_top = (object *)start; + + Fprogn(body); + + lex_env = old_lex; + bds_unwind(old_bds_top); +} + +static void +FFN(Fflet)(object args) +{ + + object def_list; + object def; + object *lex = lex_env; + object *top = vs_top; + + vs_push(Cnil); /* space for each closure */ + if (endp(args)) + FEtoo_few_argumentsF(args); + def_list = MMcar(args); + lex_copy(); + while (!endp(def_list)) { + def = MMcar(def_list); + if (endp(def) || endp(MMcdr(def)) || + type_of(MMcar(def)) != t_symbol) + FEerror("~S~%\ +is an illegal function definition in FLET.", + 1, def); + top[0] = MMcons(lex[2], def); + top[0] = MMcons(lex[1], top[0]); + top[0] = MMcons(lex[0], top[0]); + top[0] = MMcons(sLlambda_block_closure, top[0]); + lex_fun_bind(MMcar(def), top[0]); + def_list = MMcdr(def_list); + } + vs_push(find_special(MMcdr(args), NULL, NULL)); + Fprogn(vs_head); + lex_env = lex; +} + +static void +FFN(Flabels)(object args) +{ + + object def_list; + object def; + object closure_list; + object *lex = lex_env; + object *top = vs_top; + + vs_push(Cnil); /* space for each closure */ + vs_push(Cnil); /* space for closure-list */ + if (endp(args)) + FEtoo_few_argumentsF(args); + def_list = MMcar(args); + lex_copy(); + while (!endp(def_list)) { + def = MMcar(def_list); + if (endp(def) || endp(MMcdr(def)) || + type_of(MMcar(def)) != t_symbol) + FEerror("~S~%\ +is an illegal function definition in LABELS.", + 1, def); + top[0] = MMcons(lex[2], def); + top[0] = MMcons(Cnil, top[0]); + top[1] = MMcons(top[0], top[1]); + top[0] = MMcons(lex[0], top[0]); + top[0] = MMcons(sLlambda_block_closure, top[0]); + lex_fun_bind(MMcar(def), top[0]); + def_list = MMcdr(def_list); + } + closure_list = top[1]; + while (!endp(closure_list)) { + MMcaar(closure_list) = lex_env[1]; + closure_list = MMcdr(closure_list); + } + vs_push(find_special(MMcdr(args), NULL, NULL)); + Fprogn(vs_head); + lex_env = lex; +} + +static void +FFN(Fmacrolet)(object args) +{ + + object def_list; + object def; + object *lex = lex_env; + object *top = vs_top; + + vs_push(Cnil); /* space for each macrodef */ + if (endp(args)) + FEtoo_few_argumentsF(args); + def_list = MMcar(args); + lex_copy(); + while (!endp(def_list)) { + def = MMcar(def_list); + if (endp(def) || endp(MMcdr(def)) || + type_of(MMcar(def)) != t_symbol) + FEerror("~S~%\ +is an illegal macro definition in MACROFLET.", + 1, def); + top[0] = ifuncall3(sSdefmacroA, + MMcar(def), + MMcadr(def), + MMcddr(def)); + lex_macro_bind(MMcar(def), MMcaddr(top[0])); + def_list = MMcdr(def_list); + } + vs_push(find_special(MMcdr(args), NULL, NULL)); + Fprogn(vs_head); + lex_env = lex; +} + +void +gcl_init_let(void) +{ + make_special_form("LET", Flet); + make_special_form("LET*", FletA); + make_special_form("MULTIPLE-VALUE-BIND", Fmultiple_value_bind); + make_special_form("COMPILER-LET", Fcompiler_let); + make_special_form("FLET",Fflet); + make_special_form("LABELS",Flabels); + make_special_form("MACROLET",Fmacrolet); +} diff --git a/o/lex.c b/o/lex.c new file mode 100755 index 0000000..a0ecac8 --- /dev/null +++ b/o/lex.c @@ -0,0 +1,129 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +/* + + lex.c + + lexical environment +*/ + +#include "include.h" + + +object +assoc_eq(object key, object alist) +{ + + while (!endp(alist)) { + if (MMcaar(alist) == key) + return(MMcar(alist)); + alist = MMcdr(alist); + } + return(Cnil); +} + +void +lex_fun_bind(object name, object fun) +{ + object *top = vs_top; + + vs_push(make_cons(fun, Cnil)); + top[0] = make_cons(sLfunction, top[0]); + top[0] = make_cons(name, top[0]); + lex_env[1] = make_cons(top[0],lex_env[1]); + vs_top = top; +} + +void +lex_macro_bind(object name, object exp_fun) +{ + object *top = vs_top; + vs_push(make_cons(exp_fun, Cnil)); + top[0] = make_cons(sLmacro, top[0]); + top[0] = make_cons(name, top[0]); + lex_env[1]=make_cons(top[0], lex_env[1]); + vs_top = top; +} + +void +lex_tag_bind(object tag, object id) +{ + object *top = vs_top; + + vs_push(make_cons(id, Cnil)); + top[0] = make_cons(sLtag, top[0]); + top[0] = make_cons(tag, top[0]); + lex_env[2] =make_cons(top[0], lex_env[2]); + vs_top = top; +} + +void +lex_block_bind(object name, object id) +{ + object *top = vs_top; + + vs_push(make_cons(id, Cnil)); + top[0] = make_cons(sLblock, top[0]); + top[0] = make_cons(name, top[0]); + lex_env[2]= make_cons(top[0], lex_env[2]); + vs_top = top; +} + +object +lex_tag_sch(object tag) +{ + + object alist = lex_env[2]; + + while (!endp(alist)) { + if (eql(MMcaar(alist), tag) && MMcadar(alist) == sLtag) + return(MMcar(alist)); + alist = MMcdr(alist); + } + return(Cnil); +} + +object lex_block_sch(object name) +{ + + object alist = lex_env[2]; + + while (!endp(alist)) { + if (MMcaar(alist) == name && MMcadar(alist) == sLblock) + return(MMcar(alist)); + alist = MMcdr(alist); + } + return(Cnil); +} + +void +gcl_init_lex(void) +{ +/* sLfunction = make_ordinary("FUNCTION"); */ +/* enter_mark_origin(&sLfunction); */ + sLmacro = make_ordinary("MACRO"); + enter_mark_origin(&sLmacro); + sLtag = make_ordinary("TAG"); + enter_mark_origin(&sLtag); + sLblock = make_ordinary("BLOCK"); + enter_mark_origin(&sLblock); +} diff --git a/o/list.d b/o/list.d new file mode 100755 index 0000000..26bbdd3 --- /dev/null +++ b/o/list.d @@ -0,0 +1,1535 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +*/ + +/* + list.d + + list manipulating routines +*/ + +#include "include.h" +#include "page.h" + +static int reverse_comparison; + +#define TARG1(a,b) (reverse_comparison ? (b) : (a)) +#define TARG2(a,b) (reverse_comparison ? (a) : (b)) + +object sKinitial_element; + +#define TEST(x) (*tf)(x) + +#define saveTEST \ + object old_test_function = test_function; \ + object old_item_compared = item_compared; \ + bool (*old_tf)() = tf; \ + object old_key_function = key_function; \ + object (*old_kf)() = kf; \ + VOL bool eflag = FALSE + +#define protectTEST \ + frs_push(FRS_PROTECT, Cnil); \ + if (nlj_active) { \ + eflag = TRUE; \ + goto L; \ + } + +#define restoreTEST \ +L: \ + frs_pop(); \ + test_function = old_test_function; \ + item_compared = old_item_compared; \ + tf = old_tf; \ + key_function = old_key_function; \ + kf = old_kf; \ + if (eflag) { \ + nlj_active = FALSE; \ + unwind(nlj_fr, nlj_tag); \ + } + +static bool +test_compare(x) +object x; +{ + object b; + + vs_push((*kf)(x)); + b = ifuncall2(test_function, + TARG1(item_compared, vs_head), + TARG2(item_compared, vs_head)); + vs_popp; + return(b != Cnil); +} + +static bool +test_compare_not(x) +object x; +{ + object b; + + vs_push((*kf)(x)); + b = ifuncall2(test_function, + TARG1(item_compared, vs_head), + TARG2(item_compared, vs_head)); + vs_popp; + return(b == Cnil); +} + +static bool +test_eql(x) +object x; +{ + return(eql(item_compared, (*kf)(x))); +} + +static object +apply_key_function(x) +object x; +{ + return(ifuncall1(key_function, x)); +} + +static object +identity(x) +object x; +{ + return(x); +} + +static void +setupTEST(item, test, test_not, key) +object item, test, test_not, key; +{ + item_compared = item; + if (test != Cnil) { + if (test_not != Cnil) + FEerror("Both :TEST and :TEST-NOT are specified.", 0); + test_function = test; + tf = test_compare; + } else if (test_not != Cnil) { + test_function = test_not; + tf = test_compare_not; + } else + tf = test_eql; + if (key != Cnil) { + key_function = key; + kf = apply_key_function; + } else + kf = identity; +} + +#define PREDICATE(f, f_if, f_if_not, n) \ +LFD(f_if)() \ +{ \ + if (vs_top - vs_base < n) \ + too_few_arguments(); \ + vs_push(sKtest); \ + vs_push(sLfuncall); \ + f(); \ +} \ +\ +LFD(f_if_not)() \ +{ \ + if (vs_top - vs_base < n) \ + too_few_arguments(); \ + vs_push(sKtest_not); \ + vs_push(sLfuncall); \ + f(); \ +} + +/* static bool +endp1(x) +object x; +{ + + if (type_of(x) == t_cons) + return(FALSE); + else * if (x == Cnil) * + return(TRUE); + vs_push(x); + FEwrong_type_argument(sLlist, x); + return(FALSE); +}*/ + +object +car(x) +object x; +{ + if (x == Cnil) + return(x); + if (type_of(x) == t_cons) + return(x->c.c_car); + FEwrong_type_argument(sLlist, x); + return(Cnil); +} + +object +cdr(x) +object x; +{ + if (x == Cnil) + return(x); + if (type_of(x) == t_cons) + return(x->c.c_cdr); + FEwrong_type_argument(sLlist, x); + return(Cnil); +} + +object +kar(x) +object x; +{ + if (type_of(x) == t_cons) + return(x->c.c_car); + FEwrong_type_argument(sLcons, x); + return(Cnil); +} + +/* static object +kdr(x) +object x; +{ + if (type_of(x) == t_cons) + return(x->c.c_cdr); + FEwrong_type_argument(sLcons, x); + return(Cnil); +}*/ + +void +stack_cons(void) +{ + object d=vs_pop,a=vs_pop; + *vs_top++ = make_cons(a,d); +} + +/*static object on_stack_list_vector(n,ap) + int n; + va_list ap; +{object res=(object) alloca_val; + struct cons *p; + object x; + p=(struct cons *) res; + if (n<=0) return Cnil; + TOP: + p->t = (int)t_cons; + p->m=FALSE; + p->c_car= va_arg(ap,object); + if (--n == 0) + {p->c_cdr = Cnil; + return res;} + else + { x= (object) p; + x->c.c_cdr= (object) ( ++p);} + goto TOP; +}*/ + +object on_stack_list_vector_new(int n,object first,va_list ap) +{object res=(object) alloca_val; + struct cons *p; + object x; + int jj=0; + p=(struct cons *) res; + if (n<=0) return Cnil; + TOP: +#ifdef WIDE_CONS + set_type_of(p,t_cons); +#endif + p->c_car= jj||first==OBJNULL ? va_arg(ap,object) : first; + jj=1; + if (--n == 0) + {p->c_cdr = Cnil; + return res;} + else + { x= (object) p; + x->c.c_cdr= (object) ( ++p);} + goto TOP; +} + +/* static object list_vector(n,ap) + int n; + va_list ap; +{object ans,*p; + + if (n == 0) return Cnil; + ans = make_cons(va_arg(ap,object),Cnil); + p = & (ans->c.c_cdr); + while (--n > 0) + { *p = make_cons(va_arg(ap,object),Cnil); + p = & ((*p)->c.c_cdr); + } + return ans; +}*/ + +object list_vector_new(int n,object first,va_list ap) +{object ans,*p; + + if (n == 0) return Cnil; + ans = make_cons(first==OBJNULL ? va_arg(ap,object) : first,Cnil); + p = & (ans->c.c_cdr); + while (--n > 0) + { *p = make_cons(va_arg(ap,object),Cnil); + p = & ((*p)->c.c_cdr); + } + return ans;} + + +/* clean this up */ +/* static object on_stack_list(int n, ...) +{va_list ap; + object res; + va_start(ap,n); + res=on_stack_list_vector(n,ap); + va_end(ap); + return res; +}*/ +#ifdef WIDE_CONS +#define maybe_set_type_of(a,b) set_type_of(a,b) +#else +#define maybe_set_type_of(a,b) +#endif + + +#define multi_cons(n_,next_,last_) \ + ({static struct typemanager *_tm=tm_table+t_cons; \ + object _lis=OBJNULL; \ + \ + if (n<=_tm->tm_nfree) { \ + \ + object _tail=_tm->tm_free; \ + \ + _lis=_tail; \ + \ + BEGIN_NO_INTERRUPT; \ + \ + _tm->tm_nfree -= n_; \ + while (--n_) { \ + pageinfo(_tail)->in_use++; \ + maybe_set_type_of(_tail,t_cons); \ + _tail->c.c_cdr=OBJ_LINK(_tail); \ + _tail->c.c_car=next_; \ + _tail=_tail->c.c_cdr; \ + } \ + _tm->tm_free=OBJ_LINK(_tail); \ + pageinfo(_tail)->in_use++; \ + maybe_set_type_of(_tail,t_cons); \ + _tail->c.c_car=next_; \ + _tail->c.c_cdr=SAFE_CDR(last_); \ + \ + END_NO_INTERRUPT; \ + } \ + _lis;}) + + + +object listqA(int a,int n,va_list ap) { + + object x,*p; + + if (n<=0) return Cnil; + + if ((x=multi_cons(n,va_arg(ap,object),a ? va_arg(ap,object) : Cnil))!=OBJNULL) + return x; + + CHECK_INTERRUPT; + + p = vs_top; + + vs_push(Cnil); + while(--n>=0) { + *p=make_cons(va_arg(ap,object),Cnil); + p= &((*p)->c.c_cdr); + } + if (a) + *p=SAFE_CDR(va_arg(ap,object)); + + return(vs_pop); + +} + +object list(int n,...) { + + va_list ap; + object lis; + + va_start(ap,n); + lis=listqA(0,n,ap); + va_end(ap); + return lis; + +} + +object listA(int n,...) { + + va_list ap; + object lis; + + va_start(ap,n); + lis=listqA(1,n-1,ap); + va_end(ap); + return lis; + +} + + +static bool +tree_equal(x, y) +object x, y; +{ + cs_check(x); + +BEGIN: + if (type_of(x) == t_cons) + if (type_of(y) == t_cons) + if (tree_equal(x->c.c_car, y->c.c_car)) { + x = x->c.c_cdr; + y = y->c.c_cdr; + goto BEGIN; + } else + return(FALSE); + else + return(FALSE); + else { + item_compared = x; + if (TEST(y)) + return(TRUE); + else + return(FALSE); + } +} + +object +append(object x, object y) { + + object z; + fixnum n; + + if (endp(x)) + return(y); + + for (z=x,n=0;!endp(z);z=z->c.c_cdr,n++); + if ((z=multi_cons(n,({object _t=x->c.c_car;x=x->c.c_cdr;_t;}),y))!=OBJNULL) + return z; + + z = make_cons(Cnil, Cnil); + vs_push(z); + for (;;) { + z->c.c_car = x->c.c_car; + x = x->c.c_cdr; + if (endp(x)) + break; + z->c.c_cdr = make_cons(Cnil, Cnil); + z = z->c.c_cdr; + } + z->c.c_cdr = SAFE_CDR(y); + return(vs_pop); +} + + + +/* object */ +/* append(x, y) */ +/* object x, y; */ +/* { */ +/* object z; */ + +/* if (endp(x)) */ +/* return(y); */ +/* z = make_cons(Cnil, Cnil); */ +/* vs_push(z); */ +/* for (;;) { */ +/* z->c.c_car = x->c.c_car; */ +/* x = x->c.c_cdr; */ +/* if (endp(x)) */ +/* break; */ +/* z->c.c_cdr = make_cons(Cnil, Cnil); */ +/* z = z->c.c_cdr; */ +/* } */ +/* z->c.c_cdr = SAFE_CDR(y); */ +/* return(vs_pop); */ +/* } */ + +/* + Copy_list(x) copies list x. +*/ +object +copy_list(x) +object x; +{ + object y; + + if (type_of(x) != t_cons) + return(x); + y = make_cons(x->c.c_car, Cnil); + vs_push(y); + for (x = x->c.c_cdr; type_of(x) == t_cons; x = x->c.c_cdr) { + y->c.c_cdr = make_cons(x->c.c_car, Cnil); + y = y->c.c_cdr; + } + y->c.c_cdr = SAFE_CDR(x); + return(vs_pop); +} + +/* + Copy_alist(x) copies alist x. +*/ +static object +copy_alist(x) +object x; +{ + object y; + + if (endp(x)) + return(Cnil); + y = make_cons(Cnil, Cnil); + vs_push(y); + for (;;) { + y->c.c_car = make_cons(car(x->c.c_car), cdr(x->c.c_car)); + x = x->c.c_cdr; + if (endp(x)) + break; + y->c.c_cdr = make_cons(Cnil, Cnil); + y = y->c.c_cdr; + } + return(vs_pop); +} + +/* + Copy_tree(x) copies tree x + and pushes the result onto vs. +*/ +static void +copy_tree(x) +object x; +{ + cs_check(x); + + if (type_of(x) == t_cons) { + copy_tree(x->c.c_car); + copy_tree(x->c.c_cdr); + stack_cons(); + } else + vs_check_push(x); +} + +/* + Subst(new, tree) pushes + the result of substituting new in tree + onto vs. +*/ +static void +subst(new, tree) +object new, tree; +{ + cs_check(new); + + if (TEST(tree)) + vs_check_push(new); + else if (type_of(tree) == t_cons) { + subst(new, tree->c.c_car); + subst(new, tree->c.c_cdr); + stack_cons(); + } else + vs_check_push(tree); +} + +/* static object */ +/* subst1(object new, object tree) { */ + +/* if (TEST(tree)) */ +/* return new; */ +/* else if (type_of(tree) == t_cons) { */ +/* object oa=tree->c.c_car,a=subst1(new,oa),od=tree->c.c_cdr,d=subst1(new,od); */ +/* return a==oa && d==od ? tree : make_cons(a,d); */ +/* } else */ +/* return tree; */ + +/* } */ + +/* static object */ +/* subst1qi(object new, object tree) { */ + +/* if (item_compared == tree) */ +/* return new; */ +/* else if (type_of(tree) == t_cons) { */ +/* object oa=tree->c.c_car,a=subst1qi(new,oa),od=tree->c.c_cdr,d=subst1qi(new,od); */ +/* return a==oa && d==od ? tree : make_cons(a,d); */ +/* } else */ +/* return tree; */ + +/* } */ + +/* + Nsubst(new, treep) stores + the result of nsubstituting new in *treep + to *treep. +*/ +static void +nsubst(new, treep) +object new, *treep; +{ + cs_check(new); + + if (TEST(*treep)) + *treep = new; + else if (type_of(*treep) == t_cons) { + nsubst(new, &(*treep)->c.c_car); + nsubst(new, &(*treep)->c.c_cdr); + } +} + +/* + Sublis(alist, tree) pushes + result of substituting tree by alist + onto vs. +*/ +static void +sublis(alist, tree) +object alist, tree; +{ + object x; + cs_check(alist); + + + for (x = alist; !endp(x); x = x->c.c_cdr) { + item_compared = car(x->c.c_car); + if (TEST(tree)) { + vs_check_push(cdr(x->c.c_car)); + return; + } + } + if (type_of(tree) == t_cons) { + sublis(alist, tree->c.c_car); + sublis(alist, tree->c.c_cdr); + stack_cons(); + } else + vs_check_push(tree); +} + +/* + Nsublis(alist, treep) stores + the result of substiting *treep by alist + to *treep. +*/ +static void +nsublis(alist, treep) +object alist, *treep; +{ + object x; + + cs_check(alist); + + + for (x = alist; !endp(x); x = x->c.c_cdr) { + item_compared = car(x->c.c_car); + if (TEST(*treep)) { + *treep = x->c.c_car->c.c_cdr; + return; + } + } + if (type_of(*treep) == t_cons) { + nsublis(alist, &(*treep)->c.c_car); + nsublis(alist, &(*treep)->c.c_cdr); + } +} + +LFD(Lcar)() +{ + check_arg(1); + + if (type_of(vs_base[0]) == t_cons || vs_base[0] == Cnil) + vs_base[0] = vs_base[0]->c.c_car; + else + FEwrong_type_argument(sLlist, vs_base[0]); +} + +LFD(Lcdr)() +{ + check_arg(1); + + if (type_of(vs_base[0]) == t_cons || vs_base[0] == Cnil) + vs_base[0] = vs_base[0]->c.c_cdr; + else + FEwrong_type_argument(sLlist, vs_base[0]); +} + +object caar(x) object x; { return(car(car(x))); } +object cadr(x) object x; { return(car(cdr(x))); } +object cdar(x) object x; { return(cdr(car(x))); } +object cddr(x) object x; { return(cdr(cdr(x))); } +object caaar(x) object x; { return(car(car(car(x)))); } +object caadr(x) object x; { return(car(car(cdr(x)))); } +object cadar(x) object x; { return(car(cdr(car(x)))); } +object caddr(x) object x; { return(car(cdr(cdr(x)))); } +object cdaar(x) object x; { return(cdr(car(car(x)))); } +object cdadr(x) object x; { return(cdr(car(cdr(x)))); } +object cddar(x) object x; { return(cdr(cdr(car(x)))); } +object cdddr(x) object x; { return(cdr(cdr(cdr(x)))); } +object caaaar(x) object x; { return(car(car(car(car(x))))); } +object caaadr(x) object x; { return(car(car(car(cdr(x))))); } +object caadar(x) object x; { return(car(car(cdr(car(x))))); } +object caaddr(x) object x; { return(car(car(cdr(cdr(x))))); } +object cadaar(x) object x; { return(car(cdr(car(car(x))))); } +object cadadr(x) object x; { return(car(cdr(car(cdr(x))))); } +object caddar(x) object x; { return(car(cdr(cdr(car(x))))); } +object cadddr(x) object x; { return(car(cdr(cdr(cdr(x))))); } +object cdaaar(x) object x; { return(cdr(car(car(car(x))))); } +object cdaadr(x) object x; { return(cdr(car(car(cdr(x))))); } +object cdadar(x) object x; { return(cdr(car(cdr(car(x))))); } +object cdaddr(x) object x; { return(cdr(car(cdr(cdr(x))))); } +object cddaar(x) object x; { return(cdr(cdr(car(car(x))))); } +object cddadr(x) object x; { return(cdr(cdr(car(cdr(x))))); } +object cdddar(x) object x; { return(cdr(cdr(cdr(car(x))))); } +object cddddr(x) object x; { return(cdr(cdr(cdr(cdr(x))))); } + +LFD(Lcaar)(){ check_arg(1); vs_base[0] = car(car(vs_base[0])); } +LFD(Lcadr)(){ check_arg(1); vs_base[0] = car(cdr(vs_base[0])); } +LFD(Lcdar)(){ check_arg(1); vs_base[0] = cdr(car(vs_base[0])); } +LFD(Lcddr)(){ check_arg(1); vs_base[0] = cdr(cdr(vs_base[0])); } +LFD(Lcaaar)(){ check_arg(1); vs_base[0] = car(car(car(vs_base[0]))); } +LFD(Lcaadr)(){ check_arg(1); vs_base[0] = car(car(cdr(vs_base[0]))); } +LFD(Lcadar)(){ check_arg(1); vs_base[0] = car(cdr(car(vs_base[0]))); } +LFD(Lcaddr)(){ check_arg(1); vs_base[0] = car(cdr(cdr(vs_base[0]))); } +LFD(Lcdaar)(){ check_arg(1); vs_base[0] = cdr(car(car(vs_base[0]))); } +LFD(Lcdadr)(){ check_arg(1); vs_base[0] = cdr(car(cdr(vs_base[0]))); } +LFD(Lcddar)(){ check_arg(1); vs_base[0] = cdr(cdr(car(vs_base[0]))); } +LFD(Lcdddr)(){ check_arg(1); vs_base[0] = cdr(cdr(cdr(vs_base[0]))); } +LFD(Lcaaaar)(){check_arg(1); vs_base[0] = car(car(car(car(vs_base[0]))));} +LFD(Lcaaadr)(){check_arg(1); vs_base[0] = car(car(car(cdr(vs_base[0]))));} +LFD(Lcaadar)(){check_arg(1); vs_base[0] = car(car(cdr(car(vs_base[0]))));} +LFD(Lcaaddr)(){check_arg(1); vs_base[0] = car(car(cdr(cdr(vs_base[0]))));} +LFD(Lcadaar)(){check_arg(1); vs_base[0] = car(cdr(car(car(vs_base[0]))));} +LFD(Lcadadr)(){check_arg(1); vs_base[0] = car(cdr(car(cdr(vs_base[0]))));} +LFD(Lcaddar)(){check_arg(1); vs_base[0] = car(cdr(cdr(car(vs_base[0]))));} +LFD(Lcadddr)(){check_arg(1); vs_base[0] = car(cdr(cdr(cdr(vs_base[0]))));} +LFD(Lcdaaar)(){check_arg(1); vs_base[0] = cdr(car(car(car(vs_base[0]))));} +LFD(Lcdaadr)(){check_arg(1); vs_base[0] = cdr(car(car(cdr(vs_base[0]))));} +LFD(Lcdadar)(){check_arg(1); vs_base[0] = cdr(car(cdr(car(vs_base[0]))));} +LFD(Lcdaddr)(){check_arg(1); vs_base[0] = cdr(car(cdr(cdr(vs_base[0]))));} +LFD(Lcddaar)(){check_arg(1); vs_base[0] = cdr(cdr(car(car(vs_base[0]))));} +LFD(Lcddadr)(){check_arg(1); vs_base[0] = cdr(cdr(car(cdr(vs_base[0]))));} +LFD(Lcdddar)(){check_arg(1); vs_base[0] = cdr(cdr(cdr(car(vs_base[0]))));} +LFD(Lcddddr)(){check_arg(1); vs_base[0] = cdr(cdr(cdr(cdr(vs_base[0]))));} + +int +endp_error(object x) { + FEwrong_type_argument(sLlist,x); + return 0; +} + +DEFUNO_NEW("NTH",object,fLnth,LISP,2,2,NONE,OI,OO,OO,OO,void,Lnth,(fixnum index,object y),"") +{ object x = y; + if (index < 0) + FEerror("Negative index: ~D.", 1, make_fixnum(index)); + while (1) + {if (type_of(x)==t_cons) + { if (index == 0) + RETURN1(Mcar(x)); + else {x = Mcdr(x); index--;}} + else if (x == sLnil) RETURN1(sLnil); + else FEwrong_type_argument(sLlist, y);} +} +#ifdef STATIC_FUNCTION_POINTERS +object +fLnth(fixnum index,object list) { + return FFN(fLnth)(index,list); +} +#endif + +DEFUN_NEW("FIRST",object,fLfirst,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") +{ RETURN1(car(x)) ;} + +DEFUN_NEW("SECOND",object,fLsecond,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") +{ return fLnth(1,x);} +DEFUN_NEW("THIRD",object,fLthird,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") +{ return fLnth(2,x);} +DEFUN_NEW("FOURTH",object,fLfourth,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") +{ return fLnth(3,x);} +DEFUN_NEW("FIFTH",object,fLfifth,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") +{ return fLnth(4,x);} +DEFUN_NEW("SIXTH",object,fLsixth,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") +{ return fLnth(5,x);} +DEFUN_NEW("SEVENTH",object,fLseventh,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") +{ return fLnth(6,x);} +DEFUN_NEW("EIGHTH",object,fLeighth,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") +{ return fLnth(7,x);} +DEFUN_NEW("NINTH",object,fLninth,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") +{ return fLnth(8,x);} +DEFUN_NEW("TENTH",object,fLtenth,LISP,1,1,NONE,OO,OO,OO,OO,(object x),"") +{ return fLnth(9,x);} + +LFD(Lcons)() { + + check_arg(2); + stack_cons(); + +} + +@(defun tree_equal (x y &key test test_not) + saveTEST; +@ + protectTEST; + setupTEST(Cnil, test, test_not, Cnil); + x=(tree_equal(x, y) ? Ct : Cnil); + restoreTEST; + @(return x) +@) + +LFD(Lendp)() +{ + + check_arg(1); + + if (vs_base[0] == Cnil) { + vs_base[0] = Ct; + return; + } + if (type_of(vs_base[0]) == t_cons) { + vs_base[0] = Cnil; + return; + } + FEwrong_type_argument(sLlist, vs_base[0]); +} + +LFD(Llist_length)() +{ + int n; + object fast, slow; + check_arg(1); + n = 0; + fast = slow = vs_base[0]; + for (;;) { + if (endp(fast)) { + vs_base[0] = make_fixnum(n); + return; + } + if (endp(fast->c.c_cdr)) { + vs_base[0] = make_fixnum(n + 1); + return; + } + if (fast == slow && n > 0) { + vs_base[0] = Cnil; + return; + } + n += 2; + fast = fast->c.c_cdr->c.c_cdr; + slow = slow->c.c_cdr; + } +} + + +object +nth(int n, object x) { + + if (n < 0) { + vs_push(make_fixnum(n)); + FEerror("Negative index: ~D.", 1, vs_head); + } + while (n-- > 0) + if (endp(x)) { + return(Cnil); + } else + x = x->c.c_cdr; + if (endp(x)) + return(Cnil); + else + return(x->c.c_car); +} + +LFD(Lnthcdr)() +{ + check_arg(2); + vs_base[0] = nthcdr(fixint(vs_base[0]), vs_base[1]); + vs_popp; +} + +object +nthcdr(int n, object x) { + + if (n < 0) { + vs_push(make_fixnum(n)); + FEwrong_type_argument(sLpositive_fixnum, vs_head); + } + while (n-- > 0) + if (endp_prop(x)) { + return(Cnil); + } else + x = x->c.c_cdr; + return(x); +} + +LFD(Llast)() { + object t; + int n; + + n=vs_top-vs_base; + if (n<1) + FEtoo_few_arguments(vs_base,vs_top); + if (n>2) + FEtoo_many_arguments(vs_base,vs_top); + if (endp(vs_base[0])) + return; + if (n==2) { + if (type_of(vs_base[1])!=t_fixnum || (n=fix(vs_base[1]))<0) + FEwrong_type_argument(sLpositive_fixnum,vs_base[1]); + vs_popp; + } + + if (!n) + while (type_of(vs_base[0]) == t_cons) + vs_base[0]=vs_base[0]->c.c_cdr; + else { + t=vs_base[0]; + while (type_of(vs_base[0]->c.c_cdr) == t_cons && --n) + vs_base[0] = vs_base[0]->c.c_cdr; + while (type_of(vs_base[0]->c.c_cdr) == t_cons) { + t=t->c.c_cdr; + vs_base[0] = vs_base[0]->c.c_cdr; + } + vs_base[0]=t; + } + +} + +LFD(Llist)() +{ + vs_push(Cnil); + while (vs_top > vs_base + 1) + stack_cons(); +} + +LFD(LlistA)() +{ + if (vs_top == vs_base) + too_few_arguments(); + while (vs_top > vs_base + 1) + stack_cons(); +} +/* static object copy_off_stack_tree(x) */ +/* object x; */ +/* {object *p; */ +/* p = &x; */ +/* TOP: */ +/* if (type_of(*p) ==t_cons) */ +/* { if(!inheap(*p)) */ +/* *p=make_cons(copy_off_stack_tree((*p)->c.c_car),(*p)->c.c_cdr); */ +/* else */ +/* (*p)->c.c_car = copy_off_stack_tree((*p)->c.c_car); */ +/* p = &((*p)->c.c_cdr); */ +/* goto TOP;} */ +/* return x; */ +/* } */ + + + +object on_stack_make_list(n) +int n; +{ object res=(object) alloca_val; + struct cons *p = (struct cons *)res; + if (n<=0) return Cnil; + TOP: +#ifdef WIDE_CONS + set_type_of(p,t_cons); +#endif + p->c_car=Cnil; + if (--n == 0) + {p->c_cdr = Cnil; + return res;} + else + {object x= (object) p; + x->c.c_cdr= (object) ( ++p);} + goto TOP; +} + +object make_list(n) +int n; +{object x =Cnil ; + while (n-- > 0) + x = make_cons(Cnil, x); + return x;} + +@(defun make_list (size &key initial_element &aux x) + int i; +@ + check_type_non_negative_integer(&size); + if (type_of(size) != t_fixnum) + FEerror("Cannot make a list of the size ~D.", 1, size); + i = fix(size); + while (i-- > 0) + x = make_cons(initial_element, x); + @(return x) +@) + +LFD(Lappend)() +{ + object x; + + if (vs_top == vs_base) { + vs_push(Cnil); + return; + } + while (vs_top > vs_base + 1) { + x = append(vs_top[-2], vs_top[-1]); + vs_top[-2] = x; + vs_popp; + } +} + +LFD(Lcopy_list)() +{ + check_arg(1); + vs_base[0] = copy_list(vs_base[0]); +} + +LFD(Lcopy_alist)() +{ + check_arg(1); + vs_base[0] = copy_alist(vs_base[0]); +} + +LFD(Lcopy_tree)() +{ + check_arg(1); + copy_tree(vs_base[0]); + vs_base[0] = vs_pop; +} + +LFD(Lrevappend)() { + object x, y; + + check_arg(2); + y = vs_pop; + for (x = vs_base[0]; !endp(x); x = x->c.c_cdr) { + vs_push(x->c.c_car); + vs_push(y); + stack_cons(); + y = vs_pop; + } + vs_base[0] = y; +} + +object +nconc(object x, object y) { + object x1; + + if (endp(x)) + return(y); + for (x1 = x; !endp(x1->c.c_cdr); x1 = x1->c.c_cdr) + ; + x1->c.c_cdr = SAFE_CDR(y); + return(x); +} + +LFD(Lnconc)() { + object x, l, m=Cnil; + int i, narg; + + narg = vs_top - vs_base - 1; + if (narg < 0) { vs_push(Cnil); return; } + x = Cnil; + for (i = 0; i < narg; i++) { + l = vs_base[i]; + if (endp(l)) + continue; + if (x == Cnil) + x = m = l; + else { + m->c.c_cdr = SAFE_CDR(l); + m = l; + } + for (; type_of(m->c.c_cdr)==t_cons; m = m->c.c_cdr); + } + if (x == Cnil) vs_base[0] = vs_top[-1]; + else { + m->c.c_cdr = SAFE_CDR(vs_top[-1]); + vs_base[0] = x; + } + vs_top = vs_base+1; +} + +LFD(Lreconc)() { + object x, y, z; + + check_arg(2); + y = vs_pop; + for (x = vs_base[0]; !endp_prop(x);) { + z = x; + x = x->c.c_cdr; + z->c.c_cdr = SAFE_CDR(y); + y = z; + } + vs_base[0] = y; +} + +@(defun butlast (lis &optional (nn `make_fixnum(1)`)) + int i; +@ + check_type_non_negative_integer(&nn); + if (!listp(lis))/*FIXME checktype*/ + FEwrong_type_argument(sLlist, lis); + if (type_of(nn) != t_fixnum) + @(return Cnil) + for (i = 0; consp(lis); i++, lis = lis->c.c_cdr) + vs_check_push(lis->c.c_car); + if (i <= fix((nn))) { + vs_top -= i; + @(return Cnil) + } + vs_top -= fix((nn)); + i -= fix((nn)); + vs_push(Cnil); + while (i-- > 0) + stack_cons(); + lis = vs_pop; + @(return lis) +@) + +@(defun nbutlast (lis &optional (nn `make_fixnum(1)`)) + int i; + object x; +@ + check_type_non_negative_integer(&nn); + if (!listp(lis))/*FIXME checktype*/ + FEwrong_type_argument(sLlist, lis); + if (type_of(nn) != t_fixnum) + @(return Cnil) + for (i = 0, x = lis; consp(x); i++, x = x->c.c_cdr); + if (i <= fix((nn))) + @(return Cnil) + for (i -= fix((nn)), x = lis; --i > 0; x = x->c.c_cdr) + ; + x->c.c_cdr = Cnil; + @(return lis) +@) + +LFD(Lldiff)() { + fixnum i; + object x; + + check_arg(2); + x = vs_base[0]; + if (!listp(x))/*FIXME checktype*/ + FEwrong_type_argument(sLlist, x); + for (i = 0; consp(x) && x!=vs_base[1] ; i++, x = x->c.c_cdr) + vs_check_push(x->c.c_car); /*FIXME but a segfault breaker at vs_limit*/ + x=eql(x,vs_base[1]) ? Cnil : x; + vs_check_push(x); + while (i-- > 0) + stack_cons(); + vs_base[0] = vs_pop; + vs_popp; +} + +LFD(Lrplaca)() +{ + check_arg(2); + check_type_cons(&vs_base[0]); + take_care(vs_base[1]); + vs_base[0]->c.c_car = vs_base[1]; + vs_popp; +} + +LFD(Lrplacd)() +{ + check_arg(2); + check_type_cons(&vs_base[0]); + vs_base[0]->c.c_cdr = SAFE_CDR(vs_base[1]); + vs_popp; +} + +@(defun subst (new old tree &key test test_not key) + saveTEST; +@ + protectTEST; + setupTEST(old, test, test_not, key); + subst(new, tree); + tree = vs_pop; + /* if (kf==identity && */ + /* tf==test_eql && */ + /* (is_imm_fixnum(item_compared) || */ + /* ({enum type tp=type_of(item_compared);tp>t_complex || tpc.c_cdr) + { if ((*tst)(v->c.c_car->c.c_car ,tree)) + return(v->c.c_car->c.c_cdr);} + if (type_of(tree)==t_cons) + {object ntree=make_cons(sublis1(alist,tree->c.c_car,tst), + tree->c.c_cdr); + ntree->c.c_cdr=sublis1(alist,ntree->c.c_cdr,tst); + return ntree; + } + return tree; +} + +/* static int +eq(x,y) +object x,y; +{return (x==y);}*/ + +void +check_alist(alist) + object alist; +{object v; + for (v=alist ; !endp(v) ; v=v->c.c_cdr) + {if (type_of(v->c.c_car) != t_cons + && v->c.c_car != Cnil) + FEerror("Not alist",0);} + return ; +} + + +@(defun sublis (alist tree &key test test_not key) + + saveTEST; +@ + protectTEST; + setupTEST(Cnil, test, test_not, key); + sublis(alist, tree); + tree = vs_pop; + restoreTEST; + @(return tree) +@) + +@(defun nsublis (alist tree &key test test_not key) + saveTEST; +@ + protectTEST; + setupTEST(Cnil, test, test_not, key); + nsublis(alist, &tree); + restoreTEST; + @(return tree) +@) + +@(defun member (item list &key test test_not key) + saveTEST; + +@ + protectTEST; + setupTEST(item, test, test_not, key); + while (!endp_prop(list)) { + if (TEST(list->c.c_car)) + goto L; + list = list->c.c_cdr; + } + restoreTEST; + @(return list) +@) + +PREDICATE(Lmember,Lmember_if,Lmember_if_not, 2) + +@(static defun member1 (item list &key test test_not key rev) + saveTEST; +@ + protectTEST; + if (key != Cnil) + item = ifuncall1(key, item); + if (rev != Cnil) + reverse_comparison=1; + setupTEST(item, test, test_not, key); + while (!endp(list)) { + if (TEST(list->c.c_car)) + goto L; + list = list->c.c_cdr; + } + restoreTEST; + reverse_comparison=0; + @(return list) +@) + +LFD(Ltailp)() { + object x; + + check_arg(2); + for (x = vs_base[1]; consp(x); x = x->c.c_cdr) + if (x==vs_base[0]) { + vs_base[0] = Ct; + vs_popp; + return; + } + if (eql(x,vs_base[0])) + vs_base[0] = Ct; + else + vs_base[0] = Cnil; + vs_popp; + return; +} + +LFD(Ladjoin)() +{ + object *base = vs_base, *top = vs_top; + + if (vs_top - vs_base < 2) + too_few_arguments(); + while (vs_base < top) + vs_push(*vs_base++); + FFN(Lmember1)(); + if (vs_base[0] == Cnil) + base[1] = make_cons(base[0], base[1]); + vs_base = base+1; + vs_top = base+2; +} + +LFD(Lacons)() +{ + check_arg(3); + + vs_base[0] = make_cons(vs_base[0], vs_base[1]); + vs_base[0] = make_cons(vs_base[0], vs_base[2]); + vs_top -= 2; +} + +@(defun pairlis (keys data &optional a_list) + object *vp, k, d; +@ + vp = vs_top + 1; + k = keys; + d = data; + while (!endp(k)) { + if (endp(d)) + FEerror( + "The keys ~S and the data ~S are not of the same length", + 2, keys, data); + vs_check_push(make_cons(k->c.c_car, d->c.c_car)); + k = k->c.c_cdr; + d = d->c.c_cdr; + } + if (!endp(d)) + FEerror("The keys ~S and the data ~S are not of the same length", + 2, keys, data); + vs_push(a_list); + while (vs_top > vp) + stack_cons(); + @(return `vp[-1]`) +@) + +@(static defun assoc_or_rassoc (item a_list &key test test_not key) + saveTEST; +@ + protectTEST; + setupTEST(item, test, test_not, key); + while (!endp(a_list)) { + if (TEST((*car_or_cdr)(a_list->c.c_car)) && + a_list->c.c_car != Cnil) { + a_list = a_list->c.c_car; + goto L; + } + a_list = a_list->c.c_cdr; + } + restoreTEST; + @(return a_list) +@) + +LFD(Lassoc)() { car_or_cdr = car; FFN(Lassoc_or_rassoc)(); } +LFD(Lrassoc)() { car_or_cdr = cdr; FFN(Lassoc_or_rassoc)(); } + +static bool true_or_false; + +@(static defun assoc_or_rassoc_predicate (predicate a_list &key key) + object x; +@ + while (!endp(a_list)) { + if (a_list->c.c_car!=Cnil) { + x=(*car_or_cdr)(a_list->c.c_car); + if (key!=Cnil) + x=ifuncall1(key,x); + if ((ifuncall1(predicate,x) != Cnil) == true_or_false) + @(return `a_list->c.c_car`) + } + a_list = a_list->c.c_cdr; + } + @(return a_list) +@) + +LFD(Lassoc_if)() { car_or_cdr = car; true_or_false = TRUE; FFN(Lassoc_or_rassoc_predicate)(); } +LFD(Lassoc_if_not)() { car_or_cdr = car; true_or_false = FALSE; FFN(Lassoc_or_rassoc_predicate)(); } +LFD(Lrassoc_if)() { car_or_cdr = cdr; true_or_false = TRUE; FFN(Lassoc_or_rassoc_predicate)(); } +LFD(Lrassoc_if_not)() { car_or_cdr = cdr; true_or_false = FALSE; FFN(Lassoc_or_rassoc_predicate)(); } + +bool +member_eq(x, l) +object x, l; +{ + + for (; type_of(l) == t_cons; l = l->c.c_cdr) + if (x == l->c.c_car) + return(TRUE); + return(FALSE); +} + +static void +FFN(siLmemq)() +{ + object x, l; + + check_arg(2); + + x = vs_base[0]; + l = vs_base[1]; + + for (; type_of(l) == t_cons; l = l->c.c_cdr) + if (x == l->c.c_car) { + vs_base[0] = l; + vs_popp; + return; + } + + vs_base[0] = Cnil; + vs_popp; +} + +void +delete_eq(x, lp) +object x, *lp; +{ + for (; type_of(*lp) == t_cons; lp = &(*lp)->c.c_cdr) + if ((*lp)->c.c_car == x) { + *lp = (*lp)->c.c_cdr; + return; + } +} + +DEFUN_NEW("STATIC-INVERSE-CONS",object,fSstatic_inverse_cons,SI,1,1,NONE,OI,OO,OO,OO,(fixnum x),"") { + + object y=(object)x; + + return is_imm_fixnum(y) ? Cnil : (is_imm_fixnum(y->c.c_cdr) ? y : (y->d.f||y->d.e ? Cnil : y)); + +} + +void +gcl_init_list_function() +{ + + sKtest = make_keyword("TEST"); + sKtest_not = make_keyword("TEST-NOT"); + sKkey = make_keyword("KEY"); + sKrev = make_keyword("REV"); + + sKinitial_element = make_keyword("INITIAL-ELEMENT"); + + make_function("CAR", Lcar); + make_function("CDR", Lcdr); + + make_function("CAAR", Lcaar); + make_function("CADR", Lcadr); + make_function("CDAR", Lcdar); + make_function("CDDR", Lcddr); + make_function("CAAAR", Lcaaar); + make_function("CAADR", Lcaadr); + make_function("CADAR", Lcadar); + make_function("CADDR", Lcaddr); + make_function("CDAAR", Lcdaar); + make_function("CDADR", Lcdadr); + make_function("CDDAR", Lcddar); + make_function("CDDDR", Lcdddr); + make_function("CAAAAR", Lcaaaar); + make_function("CAAADR", Lcaaadr); + make_function("CAADAR", Lcaadar); + make_function("CAADDR", Lcaaddr); + make_function("CADAAR", Lcadaar); + make_function("CADADR", Lcadadr); + make_function("CADDAR", Lcaddar); + make_function("CADDDR", Lcadddr); + make_function("CDAAAR", Lcdaaar); + make_function("CDAADR", Lcdaadr); + make_function("CDADAR", Lcdadar); + make_function("CDADDR", Lcdaddr); + make_function("CDDAAR", Lcddaar); + make_function("CDDADR", Lcddadr); + make_function("CDDDAR", Lcdddar); + make_function("CDDDDR", Lcddddr); + + make_function("CONS", Lcons); + make_function("TREE-EQUAL", Ltree_equal); + make_function("ENDP", Lendp); + make_function("LIST-LENGTH", Llist_length); + + + make_function("REST", Lcdr); + make_function("NTHCDR", Lnthcdr); + make_function("LAST", Llast); + make_function("LIST", Llist); + make_function("LIST*", LlistA); + make_function("MAKE-LIST", Lmake_list); + make_function("APPEND", Lappend); + make_function("COPY-LIST", Lcopy_list); + make_function("COPY-ALIST", Lcopy_alist); + make_function("COPY-TREE", Lcopy_tree); + make_function("REVAPPEND", Lrevappend); + make_function("NCONC", Lnconc); + make_function("NRECONC", Lreconc); + + make_function("BUTLAST", Lbutlast); + make_function("NBUTLAST", Lnbutlast); + make_function("LDIFF", Lldiff); + make_function("RPLACA", Lrplaca); + make_function("RPLACD", Lrplacd); + make_function("SUBST", Lsubst); + make_function("SUBST-IF", Lsubst_if); + make_function("SUBST-IF-NOT", Lsubst_if_not); + make_function("NSUBST", Lnsubst); + make_function("NSUBST-IF", Lnsubst_if); + make_function("NSUBST-IF-NOT", Lnsubst_if_not); + make_function("SUBLIS", Lsublis); + make_function("NSUBLIS", Lnsublis); + make_function("MEMBER", Lmember); + make_function("MEMBER-IF", Lmember_if); + make_function("MEMBER-IF-NOT", Lmember_if_not); + make_si_function("MEMBER1", Lmember1); + make_function("TAILP", Ltailp); + make_function("ADJOIN", Ladjoin); + + make_function("ACONS", Lacons); + make_function("PAIRLIS", Lpairlis); + make_function("ASSOC", Lassoc); + make_function("ASSOC-IF", Lassoc_if); + make_function("ASSOC-IF-NOT", Lassoc_if_not); + make_function("RASSOC", Lrassoc); + make_function("RASSOC-IF", Lrassoc_if); + make_function("RASSOC-IF-NOT", Lrassoc_if_not); + + make_si_function("MEMQ", siLmemq); + +} diff --git a/o/littleXwin.c b/o/littleXwin.c new file mode 100755 index 0000000..b7d907a --- /dev/null +++ b/o/littleXwin.c @@ -0,0 +1,239 @@ +/**************************************************************/ + +#include +#include /* the X library */ +#include /* the X library */ + + /* a few arbitary constants */ +#define START_X 10 +#define START_Y 20 +#define WINDOW_WIDTH 225 +#define WINDOW_HEIGHT 400 +#define BORDER_WIDTH 1 +#define KEY_STR_LENGTH 20 + +Display *the_display; /* the display that will be used */ +int the_screen; /* the screen that will be used */ +Window root_window; /* the root window on the screen */ +XSizeHints size_hints; /* size hints for the window manager */ +XEvent the_event; /* the structure for the input event */ +XSetWindowAttributes attributes;/* the windows attributes */ + +GC the_solid_GC, + the_clear_GC; /* the graphics contexts */ + +XGCValues the_solid_GC_values, + the_clear_GC_values; + +Colormap cmap; +XFontStruct *the_fontstruct; /* the font info to be used */ + +Window open_window(void) +{ + Window the_window; /* the window that will be opened */ + int i, stop; + + /* Set the display to be the default display (ie, your + display as given in the environment variable DISPLAY). */ + + if ((the_display = XOpenDisplay("")) == NULL) + { + printf("can't open display\n"); + return(-1); + } + + /* A few useful values. */ + + the_screen = DefaultScreen(the_display); + root_window = RootWindow(the_display,the_screen); + + /* Set the size hints for the window manager. */ + + size_hints.x = START_X; + size_hints.y = START_Y; + size_hints.width = WINDOW_WIDTH; + size_hints.height = WINDOW_HEIGHT; + size_hints.flags = PSize|PPosition; + + /* Create a window of fixed size, origin, and borderwidth. + The window will have a black border and white background. */ + + the_window = XCreateSimpleWindow(the_display,root_window, + size_hints.x,size_hints.y,size_hints.width, + size_hints.height,BORDER_WIDTH, + BlackPixel(the_display,the_screen), + WhitePixel(the_display,the_screen)); + + XSetStandardProperties(the_display,the_window,"My Window","My Icon", + None,NULL,NULL,&size_hints); + + cmap = DefaultColormap(the_display, the_screen); + + the_solid_GC = XCreateGC(the_display, the_window, None, &the_solid_GC_values); + the_clear_GC = XCreateGC(the_display, the_window, None, &the_clear_GC_values); + + /* for a sun */ + XSetBackground(the_display, the_solid_GC, BlackPixel(the_display,the_screen)); + XSetForeground(the_display, the_solid_GC, BlackPixel(the_display,the_screen)); + + XSetBackground(the_display, the_clear_GC, WhitePixel(the_display,the_screen)); + XSetForeground(the_display, the_clear_GC, WhitePixel(the_display,the_screen)); + + if ((the_fontstruct = XLoadQueryFont(the_display,"8x13")) == NULL) + { + printf("could not open font\n"); + return(-1); + } + /* Put the font into the graphics context for draw operations. */ + XSetFont(the_display, the_solid_GC, the_fontstruct->fid); + XSetFont(the_display, the_clear_GC, the_fontstruct->fid); + + /* Tell the server to make the window visible. */ + + XMapWindow(the_display,the_window); + + attributes.bit_gravity = NorthWestGravity; + XChangeWindowAttributes(the_display, the_window, CWBitGravity, &attributes); + XFlush(the_display); + return(the_window); +} + +int close_window(Window the_window) +{ + XDestroyWindow(the_display, the_window); + XFlush(the_display); + return(1); +} + +int draw_line(Window the_window, int x1, int y1, int x2, int y2) +{ + XDrawLine(the_display, the_window, the_solid_GC, x1, y1, x2, y2); + XFlush(the_display); + return(1); +} + +int draw_arc(Window the_window, int x, int y, int width, int height, int angle1, int angle2) +{ + XDrawArc(the_display, the_window, the_solid_GC, + x, y, width, height, angle1, angle2); + XFlush(the_display); + return(1); +} + +int fill_arc(Window the_window, int x, int y, int width, int height, int angle1, int angle2) +{ + XFillArc(the_display, the_window, the_solid_GC, + x, y, width, height, angle1, angle2); + XFlush(the_display); + return(1); +} + +int clear_arc(Window the_window, int x, int y, int width, int height, int angle1, int angle2) +{ + XFillArc(the_display, the_window, the_clear_GC, + x, y, width, height, angle1, angle2); + XFlush(the_display); + return(1); +} + +int set_arc_mode (int pie_or_chord) +{ + if (pie_or_chord == 0) { + XSetArcMode(the_display, the_solid_GC, ArcChord); + XSetArcMode(the_display, the_clear_GC, ArcChord); + } + else { + XSetArcMode(the_display, the_solid_GC, ArcPieSlice); + XSetArcMode(the_display, the_clear_GC, ArcPieSlice); + } + return(1); +} + +int erase_line(Window the_window, int x1, int y1, int x2, int y2) +{ + XDrawLine(the_display, the_window, the_clear_GC, x1, y1, x2, y2); + XFlush(the_display); + return(1); +} + +int draw_text(Window the_window, char *string, int x, int y) +{ + XDrawString(the_display, the_window, the_solid_GC, x, y, + string, strlen(string)); + XFlush(the_display); + return(1); +} + +int erase_text(Window the_window, char *string, int x, int y) +{ + XDrawString(the_display, the_window, the_clear_GC, x, y, + string, strlen(string)); + XFlush(the_display); + return(1); +} + +int clear_window(Window the_window) +{ + XClearWindow(the_display, the_window); + XFlush(the_display); + return(1); +} + +int resize_window(Window the_window, int width, int height) +{ + XResizeWindow(the_display, the_window, width, height); + XFlush(the_display); + return(1); +} + +int raise_window(Window the_window) +{ + XRaiseWindow(the_display, the_window); + XFlush(the_display); + return(1); +} + +int use_font (char *font_name) +{ + if ((the_fontstruct = XLoadQueryFont(the_display, font_name)) == NULL) + return(-1); + + /* Put the font into the graphics context for draw operations. */ + XSetFont(the_display, the_solid_GC, the_fontstruct->fid); + XSetFont(the_display, the_clear_GC, the_fontstruct->fid); + XFlush(the_display); + return(1); +} + + + +int set_background (Window the_window, char *color_string) +{ + XColor color; + int result; + + if (result = XParseColor(the_display, cmap, color_string, &color)) { + if (result = XAllocColor(the_display, cmap, &color)) { + XSetWindowBackground(the_display, the_window, color.pixel); + XSetBackground(the_display, the_clear_GC, color.pixel); + XSetForeground(the_display, the_clear_GC, color.pixel); + XFlush(the_display); + } + } + return(result); +} + +int set_foreground (char *color_string) +{ + XColor color; + int result; + + if (result = XParseColor(the_display, cmap, color_string, &color)) { + if (result = XAllocColor(the_display, cmap, &color)) { + XSetForeground(the_display, the_solid_GC, color.pixel); + XSetBackground(the_display, the_solid_GC, color.pixel); + XFlush(the_display); + return(1); + } + } +} diff --git a/o/macros.c b/o/macros.c new file mode 100755 index 0000000..033c402 --- /dev/null +++ b/o/macros.c @@ -0,0 +1,348 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +/* + macros.c +*/ +#include "include.h" + + +object sLwarn; + +object sSAinhibit_macro_specialA; + +static void +FFN(siLdefine_macro)(void) +{ + check_arg(2); + if (type_of(vs_base[0]) != t_symbol) + not_a_symbol(vs_base[0]); + if (vs_base[0]->s.s_sfdef != NOT_SPECIAL) { + if (vs_base[0]->s.s_mflag) { + if (symbol_value(sSAinhibit_macro_specialA) != Cnil) + vs_base[0]->s.s_sfdef = NOT_SPECIAL; + } else if (symbol_value(sSAinhibit_macro_specialA) != Cnil) + FEerror("~S, a special form, cannot be redefined.", + 1, vs_base[0]); + } + clear_compiler_properties(vs_base[0],MMcaddr(vs_base[1])); + if (vs_base[0]->s.s_hpack == lisp_package && + vs_base[0]->s.s_gfdef != OBJNULL && !raw_image) { + vs_push(make_simple_string( + "~S is being redefined.")); + ifuncall2(sLwarn, vs_head, vs_base[0]); + vs_popp; + } + vs_base[0]->s.s_gfdef = MMcaddr(vs_base[1]); + vs_base[0]->s.s_mflag = TRUE; + if (MMcar(vs_base[1]) != Cnil) { + vs_base[0]->s.s_plist + = putf(vs_base[0]->s.s_plist, + MMcar(vs_base[1]), + sSfunction_documentation); + } + if (MMcadr(vs_base[1]) != Cnil) { + vs_base[0]->s.s_plist + = putf(vs_base[0]->s.s_plist, + MMcadr(vs_base[1]), + sSpretty_print_format); + } + vs_top = vs_base+1; +} + +static void +FFN(Fdefmacro)(object form) +{ + + object *top = vs_top; + object name; + + if (endp(form) || endp(MMcdr(form))) + FEtoo_few_argumentsF(form); + name = MMcar(form); + if (type_of(name) != t_symbol) + not_a_symbol(name); + vs_push(ifuncall3(sSdefmacroA, + name, + MMcadr(form), + MMcddr(form))); + if (MMcar(top[0]) != Cnil) + name->s.s_plist + = putf(name->s.s_plist, + MMcar(top[0]), + sSfunction_documentation); + if (MMcadr(top[0]) != Cnil) + name->s.s_plist + = putf(name->s.s_plist, + MMcadr(top[0]), + sSpretty_print_format); + if (name->s.s_sfdef != NOT_SPECIAL) { + if (name->s.s_mflag) { + if (symbol_value(sSAinhibit_macro_specialA) != Cnil) + name->s.s_sfdef = NOT_SPECIAL; + } else if (symbol_value(sSAinhibit_macro_specialA) != Cnil) + FEerror("~S, a special form, cannot be redefined.", + 1, name); + } + clear_compiler_properties(name,MMcaddr(top[0])); + if (name->s.s_hpack == lisp_package && + name->s.s_gfdef != OBJNULL && !raw_image) { + vs_push(make_simple_string( + "~S is being redefined.")); + ifuncall2(sLwarn, vs_head, name); + vs_popp; + } + name->s.s_gfdef = MMcaddr(top[0]); + name->s.s_mflag = TRUE; + vs_base = vs_top = top; + vs_push(name); +} + + +/* + Macros may well need their functional environment to expand properly. + For example setf needs to expand the place which may be a local + macro. They are not supposed to need the other parts of the + environment +*/ +#define VS_PUSH_ENV vs_push(MACRO_EXPAND_ENV) +#define MACRO_EXPAND_ENV \ + (lex_env[1]!= sLnil ? \ + list(3,lex_env[0],lex_env[1],lex_env[2]) : sLnil) + +/* + MACRO_EXPAND1 is an internal function which simply applies the + function EXP_FUN to FORM. On return, the expanded form is stored + in VS_BASE[0]. +*/ +object +Imacro_expand1(object exp_fun, object form) +{ + return Ifuncall_n(sLAmacroexpand_hookA->s.s_dbind, + 3,exp_fun,form,MACRO_EXPAND_ENV); +} + +/* + MACRO_DEF is an internal function which, given a form, returns + the expansion function if the form is a macro form. Otherwise, + MACRO_DEF returns NIL. +*/ +static object +macro_def(object form) +{ + object head, fd; + + if (type_of(form) != t_cons) + return(Cnil); + head = MMcar(form); + if (type_of(head) != t_symbol) + return(Cnil); + fd = lex_fd_sch(head); + if (MMnull(fd)) + if (head->s.s_mflag) + return(head->s.s_gfdef); + else + return(Cnil); + else if (MMcadr(fd) == sLmacro) + return(MMcaddr(fd)); + else + return(Cnil); +} + +DEFUNOM_NEW("MACROEXPAND",object,fLmacroexpand,LISP + ,1,2,NONE,OO,OO,OO,OO,void,Lmacroexpand,(object form,...),"") +{ int n=VFUN_NARGS; + object envir; + object exp_fun; + object *lex=lex_env; + object buf[3]; + + va_list ap; + { va_start(ap,form); + if (n>=2) envir=va_arg(ap,object);else goto LDEFAULT2; + goto LEND_VARARG; + LDEFAULT2: envir = Cnil; + LEND_VARARG: va_end(ap);} + + lex_env = buf; + if (n== 1) {buf[0]=sLnil; + buf[1]=sLnil; + buf[2]=sLnil; + } + else if (n==2) + { buf[0]=car(envir); + envir=Mcdr(envir); + buf[1]=car(envir); + envir=Mcdr(envir); + buf[2]=car(envir); + } + else check_arg_range(1,2); + + exp_fun = macro_def(form); + + if (MMnull(exp_fun)) { + lex_env = lex; + RETURN(2,object,form,(RV(sLnil))); + } + else + { + object *top = vs_top; + do { + form= Imacro_expand1(exp_fun, form); + vs_top = top; + exp_fun = macro_def(form); + } while (!MMnull(exp_fun)); + lex_env = lex; + RETURN(2,object,form,(RV(sLt))); + } +} + +LFD(Lmacroexpand_1)(void) +{ + object exp_fun; + object *base=vs_base; + object *lex=lex_env; + + lex_env = vs_top; + if (vs_top-vs_base<1) + too_few_arguments(); + else if (vs_top-vs_base == 1) { + vs_push(Cnil); + vs_push(Cnil); + vs_push(Cnil); + } else if (vs_top-vs_base == 2) { + vs_push(car(vs_base[1])); + vs_push(car(cdr(vs_base[1]))); + vs_push(car(cdr(cdr(vs_base[1])))); + } else + too_many_arguments(); + exp_fun = macro_def(base[0]); + if (MMnull(exp_fun)) { + lex_env = lex; + vs_base = base; + vs_top = base+1; + vs_push(Cnil); + } else { + base[0]=Imacro_expand1(exp_fun, base[0]); + lex_env = lex; + vs_base = base; + vs_top = base+1; + vs_push(Ct); + } +} + +/* + MACRO_EXPAND is an internal function which, given a form, expands it + as many times as possible and returns the finally expanded form. + The argument 'form' need not be marked for GBC and the result is not + marked. +*/ +object +macro_expand(object form) +{ + object exp_fun, head, fd; + object *base = vs_base; + object *top = vs_top; + + /* Check if the given form is a macro form. If not, return + immediately. Macro definitions are superseded by special- + form definitions. + */ + if (type_of(form) != t_cons) + return(form); + head = MMcar(form); + if (type_of(head) != t_symbol) + return(form); + if (head->s.s_sfdef != NOT_SPECIAL) + return(form); + fd = lex_fd_sch(head); + if (MMnull(fd)) + if (head->s.s_mflag) + exp_fun = head->s.s_gfdef; + else + return(form); + else if (MMcadr(fd) == sLmacro) + exp_fun = MMcaddr(fd); + else + return(form); + + vs_top = top; + vs_push(form); /* saves form in top[0] */ + vs_push(exp_fun); /* saves exp_fun in top[1] */ +LOOP: + /* macro_expand1(exp_fun, form); */ + vs_base = vs_top; + vs_push(exp_fun); + vs_push(form); +/***/ +/* vs_push(Cnil); */ + VS_PUSH_ENV ; +/***/ + super_funcall(symbol_value(sLAmacroexpand_hookA)); + if (vs_base == vs_top) + vs_push(Cnil); + top[0] = form = vs_base[0]; + /* Check if the expanded form is again a macro form. If not, + reset the stack and return. + */ + if (type_of(form) != t_cons) + goto END; + head = MMcar(form); + if (type_of(head) != t_symbol) + goto END; + if (head->s.s_sfdef != NOT_SPECIAL) + goto END; + fd=lex_fd_sch(head); + if (MMnull(fd)) + if (head->s.s_mflag) + exp_fun = head->s.s_gfdef; + else + goto END; + else if (MMcadr(fd) == sLmacro) + exp_fun = MMcaddr(fd); + else + goto END; + /* The expanded form is a macro form. Continue expansion. */ + top[1] = exp_fun; + vs_top = top + 2; + goto LOOP; +END: + vs_base = base; + vs_top = top; + return(form); +} + +DEF_ORDINARY("FUNCALL",sLfuncall,LISP,""); +DEFVAR("*MACROEXPAND-HOOK*",sLAmacroexpand_hookA,LISP,sLfuncall,""); +DEF_ORDINARY("DEFMACRO*",sSdefmacroA,SI,""); +DEFVAR("*INHIBIT-MACRO-SPECIAL*",sSAinhibit_macro_specialA,SI,Cnil,""); +void +gcl_init_macros(void) +{ + make_si_function("DEFINE-MACRO", siLdefine_macro); + + + make_function("MACROEXPAND-1", Lmacroexpand_1); + make_special_form("DEFMACRO", Fdefmacro); + + + +} diff --git a/o/main.c b/o/main.c new file mode 100755 index 0000000..41b4ad9 --- /dev/null +++ b/o/main.c @@ -0,0 +1,1208 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +/* + main.c + IMPLEMENTATION-DEPENDENT +*/ + +#include +#include +#include +#include + +static void +init_main(void); + +static void +initlisp(void); + +static int +multiply_stacks(int); + +#define IN_MAIN + +#ifdef KCLOVM +#include +void change_contexts(); +int ovm_process_created; +void initialize_process(); +#endif + +#include "include.h" +#include +#include "page.h" + +bool saving_system=FALSE; + +#ifdef BSD +#include +#ifndef SGI +#include +#endif +#endif + +#ifdef AOSVS + +#endif + +#ifdef _WIN32 +#include +#endif + +#define LISP_IMPLEMENTATION_VERSION "April 1994" + +char *system_directory; + +#define EXTRA_BUFSIZE 8 +char stdin_buf[BUFSIZ + EXTRA_BUFSIZE]; +char stdout_buf[BUFSIZ + EXTRA_BUFSIZE]; + +#include "stacks.h" + +int debug; /* debug switch */ +int raw_image = TRUE; /* raw or saved image -- CYGWIN will only place this in .data and not in .bss if initialized to non-zero */ +bool GBC_enable=FALSE; + +long real_maxpage; +object sSAlisp_maxpagesA; + +object siClisp_pagesize; + +object sStop_level; + + +object sSAmultiply_stacksA; +int stack_multiple=1; +static object stack_space; + +#ifdef _WIN32 +unsigned int _dbegin = 0x10100000; +#endif +#ifdef __CYGWIN__ +unsigned long _dbegin = 0; +#endif + +#ifdef SGC +int sgc_enabled; +#endif +void install_segmentation_catcher(void); + +int +cstack_dir(fixnum j) { + static fixnum n; + if (!n) { + n=1; + return cstack_dir((fixnum)&j); + } + return (fixnum)&jMAX_BRK) return -1; +#endif + + if (uv + +ufixnum +get_phys_pages_no_malloc(void) { + MEMORYSTATUS m; + + m.dwLength=sizeof(m); + GlobalMemoryStatus(&m); + return m.dwTotalPhys>>PAGEWIDTH; + +} + +#elif defined (DARWIN) + +#include + +ufixnum +get_phys_pages_no_malloc(void) { + uint64_t s; + size_t z=sizeof(s); + int m[2]={CTL_HW,HW_MEMSIZE}; + + if (sysctl(m,2,&s,&z,NULL,0)==0) + return s>>PAGEWIDTH; + + return 0; + +} + +#elif defined(__sun__) + +ufixnum +get_phys_pages_no_malloc(void) { + + return sysconf(_SC_PHYS_PAGES); + +} + +#else + +ufixnum +get_phys_pages_no_malloc(void) { + int l; + char b[PAGESIZE],*c; + const char *k="MemTotal:",*f="/proc/meminfo"; + ufixnum res=0,n; + + if ((l=open(f,O_RDONLY))!=-1) { + if ((n=read(l,b,sizeof(b)))>(PAGEWIDTH-10); +} + +#endif + +int +update_real_maxpage(void) { + + ufixnum i,j,k; + void *end,*cur,*beg; +#ifdef __MINGW32__ + static fixnum n; + + if (!n) { + init_shared_memory(); + n=1; + } +#endif + + massert(cur=sbrk(0)); + beg=data_start ? data_start : cur; + for (i=0,j=(1L<PAGESIZE;j>>=1) + if ((end=beg+i+j-PAGESIZE)>cur) + if (!mbrk(end)) { + real_maxpage=page(end); + i+=j; + } + massert(!mbrk(cur)); + + phys_pages=get_phys_pages_no_malloc(); + +#ifdef BRK_DOES_NOT_GUARANTEE_ALLOCATION + if (phys_pages>0 && real_maxpage>phys_pages+page(beg)) real_maxpage=phys_pages+page(beg); +#endif + + available_pages=real_maxpage-page(beg); + for (i=t_start,j=0;i= dend) { + minimize_image(); + log_maxpage_bound=l; + update_real_maxpage(); + } + + return (object)log_maxpage_bound; + +} + +#ifdef NEED_STACK_CHK_GUARD + +unsigned long __stack_chk_guard=0; + +static unsigned long +random_ulong() { + + object y; + + vs_top=vs_base; + vs_push(Ct); + Lmake_random_state(); + y=vs_pop; + vs_push(number_negate(find_symbol(make_simple_string("MOST-NEGATIVE-FIXNUM"),system_package)->s.s_dbind)); + vs_push(y); + Lrandom(); + + return fixint(vs_pop); + +} +#endif + +#ifdef HAVE_MPROTECT +#include +int +gcl_mprotect(void *v,unsigned long l,int p) { + + int i; + char b[80]; + + if ((i=mprotect(v,l,p))) { + snprintf(b,sizeof(b),"mprotect failure: %p %lu %d\b",v,l,p); + perror(b); + } + + return i; + +} +#endif + +int +main(int argc, char **argv, char **envp) { + + gcl_init_alloc(&argv); + +#ifdef GET_FULL_PATH_SELF + GET_FULL_PATH_SELF(kcl_self); +#else + kcl_self = argv[0]; +#endif +#ifdef __MINGW32__ + { + char *s=kcl_self; + for (;*s;s++) if (*s=='\\') *s='/'; + } +#endif + *argv=kcl_self; + +#ifdef CAN_UNRANDOMIZE_SBRK +#include +#include +#include "unrandomize.h" +#endif + +#ifdef LD_BIND_NOW +#include +#include +#include "ld_bind_now.h" +#endif + + setbuf(stdin, stdin_buf); + setbuf(stdout, stdout_buf); +#ifdef _WIN32 + _fmode = _O_BINARY; + _setmode( _fileno( stdin ), _O_BINARY ); + _setmode( _fileno( stdout ), _O_BINARY ); + _setmode( _fileno( stderr ), _O_BINARY ); +#endif + ARGC = argc; + ARGV = argv; + ENVP = envp; + + vs_top = vs_base = vs_org; + ihs_top = ihs_org-1; + bds_top = bds_org-1; + frs_top = frs_org-1; + + if (raw_image) { + + printf("GCL (GNU Common Lisp) %s %ld pages\n",LISP_IMPLEMENTATION_VERSION,real_maxpage); + fflush(stdout); + + if (argc>1) { + massert(argv[1][strlen(argv[1])-1]=='/'); + system_directory=argv[1]; + } + + initlisp(); + lex_new(); + + GBC_enable = TRUE; + + gcl_init_init(); + + sLApackageA->s.s_dbind = user_package; + + } else { + + terminal_io->sm.sm_object0->sm.sm_fp = stdin; + terminal_io->sm.sm_object1->sm.sm_fp = stdout; +#ifdef LD_BIND_NOW /*FIXME currently mips only, verify that these two requirements are the same*/ + reinit_gmp(); +#endif + gcl_init_big1(); +#ifdef HAVE_READLINE + gcl_init_readline_function(); +#endif +#ifdef NEED_STACK_CHK_GUARD + __stack_chk_guard=random_ulong();/*Cannot be safely set inside a function which returns*/ +#endif + + } + +#ifdef _WIN32 + detect_wine(); +#endif + + sSAlisp_maxpagesA->s.s_dbind = make_fixnum(real_maxpage); + + ihs_push(Cnil); + lex_new(); + vs_base = vs_top; + + interrupt_enable = TRUE; + install_default_signals(); + + do + super_funcall(sStop_level); + while (type_of(sSAmultiply_stacksA->s.s_dbind)==t_fixnum && multiply_stacks(fix(sSAmultiply_stacksA->s.s_dbind))); + + return 0; + +} + +/* catch certain signals */ +void install_segmentation_catcher(void) +{ + unblock_signals(SIGSEGV,SIGSEGV); + unblock_signals(SIGBUS,SIGBUS); + (void) gcl_signal(SIGSEGV,segmentation_catcher); + (void) gcl_signal(SIGBUS,segmentation_catcher); +} + +int catch_fatal=1; +void +error(char *s) +{ + if (catch_fatal>0 && interrupt_enable ) + {catch_fatal = -1; +#ifdef SGC + if (sgc_enabled) + { sgc_quit();} + if (sgc_enabled==0) +#endif + { install_segmentation_catcher() ;} + FEerror("Caught fatal error [memory may be damaged]",0); } + printf("\nUnrecoverable error: %s.\n", s); + fflush(stdout); + abort(); +} + +static void +initlisp(void) { + + void *v=&v; + + if (NULL_OR_ON_C_STACK(v) == 0 +#if defined(IM_FIX_BASE) + || NULL_OR_ON_C_STACK(IM_FIX_BASE) == 0 + || NULL_OR_ON_C_STACK((IM_FIX_BASE|IM_FIX_LIM)) == 0 +#endif + /* || NULL_OR_ON_C_STACK(vv) */ + || NULL_OR_ON_C_STACK(pagetoinfo(first_data_page)) + || NULL_OR_ON_C_STACK(core_end-1)) { + /* check person has correct definition of above */ + fprintf(stderr,"%p %d " +#if defined(IM_FIX_BASE) + "%p %d %p %d " +#endif + "%p %d %p %d\n", + v,NULL_OR_ON_C_STACK(v), +#if defined(IM_FIX_BASE) + (void *)IM_FIX_BASE,NULL_OR_ON_C_STACK(IM_FIX_BASE), + (void *)(IM_FIX_BASE|IM_FIX_LIM),NULL_OR_ON_C_STACK(IM_FIX_BASE|IM_FIX_LIM), +#endif + pagetoinfo(first_data_page),NULL_OR_ON_C_STACK(pagetoinfo(first_data_page)), + core_end-1,NULL_OR_ON_C_STACK(core_end-1)); + error("NULL_OR_ON_C_STACK macro invalid"); + } + + Cnil->fw=0; + set_type_of(Cnil,t_symbol); + Cnil->c.c_cdr=Cnil; + Cnil_body.s.s_dbind = Cnil; + Cnil_body.s.s_sfdef = NOT_SPECIAL; + Cnil_body.s.s_fillp = 3; + Cnil_body.s.s_self = "NIL"; + Cnil_body.s.s_gfdef = OBJNULL; + Cnil_body.s.s_plist = Cnil; + Cnil_body.s.s_hpack = Cnil; + Cnil_body.s.s_stype = (short)stp_constant; + Cnil_body.s.s_mflag = FALSE; + + Ct->fw=0; + set_type_of(Ct,t_symbol); + Ct_body.s.s_dbind = Ct; + Ct_body.s.s_sfdef = NOT_SPECIAL; + Ct_body.s.s_fillp = 1; + Ct_body.s.s_self = "T"; + Ct_body.s.s_gfdef = OBJNULL; + Ct_body.s.s_plist = Cnil; + Ct_body.s.s_hpack = Cnil; + Ct_body.s.s_stype = (short)stp_constant; + Ct_body.s.s_mflag = FALSE; + + gcl_init_symbol(); + + gcl_init_package(); + + Cnil->s.s_hpack = lisp_package; + import(Cnil, lisp_package); + export(Cnil, lisp_package); + + Ct->s.s_hpack = lisp_package; + import(Ct, lisp_package); + export(Ct, lisp_package); + +#ifdef ANSI_COMMON_LISP +/* Cnil->s.s_hpack = common_lisp_package; */ + import(Cnil, common_lisp_package); + export(Cnil, common_lisp_package); + +/* Ct->s.s_hpack = common_lisp_package; */ + import(Ct, common_lisp_package); + export(Ct, common_lisp_package); +#endif + +/* sLquote = make_ordinary("QUOTE"); */ +/* sLfunction = make_ordinary("FUNCTION"); */ + sLlambda = make_ordinary("LAMBDA"); + sLlambda_block = make_ordinary("LAMBDA-BLOCK"); + sLlambda_closure = make_ordinary("LAMBDA-CLOSURE"); + sLlambda_block_closure = make_ordinary("LAMBDA-BLOCK-CLOSURE"); + sLspecial = make_ordinary("SPECIAL"); + + + NewInit(); + gcl_init_typespec(); + gcl_init_number(); + gcl_init_character(); + + gcl_init_read(); + gcl_init_bind(); + gcl_init_pathname(); + gcl_init_print(); + gcl_init_GBC(); + + gcl_init_unixfasl(); + gcl_init_unixsys(); + gcl_init_unixsave(); + + gcl_init_alloc_function(); + gcl_init_array_function(); + gcl_init_character_function(); + gcl_init_file_function(); + gcl_init_list_function(); + gcl_init_package_function(); + gcl_init_pathname_function(); + gcl_init_predicate_function(); + gcl_init_print_function(); + gcl_init_read_function(); + gcl_init_sequence_function(); +#if defined(KCLOVM) || defined(RUN_PROCESS) + gcl_init_socket_function(); +#endif + gcl_init_structure_function(); + gcl_init_string_function(); + gcl_init_symbol_function(); + gcl_init_typespec_function(); + gcl_init_hash(); + gcl_init_cfun(); + + gcl_init_unixfsys(); + gcl_init_unixtime(); + gcl_init_eval(); + gcl_init_lex(); + gcl_init_prog(); + gcl_init_catch(); + gcl_init_block(); + gcl_init_macros(); + gcl_init_conditional(); + gcl_init_reference(); + gcl_init_assignment(); + gcl_init_multival(); + gcl_init_error(); + gcl_init_let(); + gcl_init_mapfun(); + gcl_init_iteration(); + gcl_init_toplevel(); + + gcl_init_cmpaux(); + + init_main(); + + gcl_init_format(); + gcl_init_links(); + + gcl_init_fat_string(); + gcl_init_sfasl(); +#ifdef CMAC + gcl_init_cmac(); +#endif +#ifdef HAVE_READLINE + gcl_init_readline(); +#endif + +} +object +vs_overflow(void) +{ + if (vs_limit > vs_org + stack_multiple * VSSIZE) + error("value stack overflow"); + vs_limit += STACK_OVER*VSGETA; + FEerror("Value stack overflow.", 0); + return Cnil; +} + +void +bds_overflow(void) { + --bds_top; + if (bds_limit > bds_org + stack_multiple * BDSSIZE) { + error("bind stack overflow"); + } + bds_limit += STACK_OVER *BDSGETA; + FEerror("Bind stack overflow.", 0); +} + +void +frs_overflow(void) { + --frs_top; + if (frs_limit > frs_org + stack_multiple * FRSSIZE) + error("frame stack overflow"); + frs_limit += STACK_OVER* FRSGETA; + FEerror("Frame stack overflow.", 0); +} + +void +ihs_overflow(void) { + --ihs_top; + if (ihs_limit > ihs_org + stack_multiple * IHSSIZE) + error("invocation history stack overflow"); + ihs_limit += STACK_OVER*IHSGETA; + FEerror("Invocation history stack overflow.", 0); +} + +void +segmentation_catcher(int i) { + error("Segmentation violation."); +} + +/* static void */ +/* cs_overflow(void) { */ +/* #ifdef AV */ +/* if (cs_limit < cs_org - cssize) */ +/* error("control stack overflow"); */ +/* cs_limit -= CSGETA; */ +/* #endif */ +/* #ifdef MV */ + + + +/* #endif */ +/* FEerror("Control stack overflow.", 0); */ +/* } */ + +/* static void */ +/* end_of_file(void) { */ +/* error("end of file"); */ +/* } */ + +DEFUNO_NEW("BYE",object,fLbye,LISP + ,0,1,NONE,OO,OO,OO,OO,void,Lby,(object exitc),"") +{ int n=VFUN_NARGS; + int exit_code; + if (n>=1) exit_code=fix(exitc);else exit_code=0; + +/* printf("Bye.\n"); */ + exit(exit_code); + +} + + +DEFUN_NEW("QUIT",object,fLquit,LISP + ,0,1,NONE,OO,OO,OO,OO,(object exitc),"") +{ return FFN(fLbye)(exitc); } + +/* DEFUN_NEW("EXIT",object,fLexit,LISP */ +/* ,0,1,NONE,OI,OO,OO,OO,(fixnum exitc),"") */ +/* { return fLbye(exitc); } */ + + +/* c_trace(void) */ +/* { */ +/* #ifdef AOSVS */ + +/* #endif */ +/* } */ + +static void +FFN(siLargc)(void) { + check_arg(0); + vs_push(make_fixnum(ARGC)); +} + +static void +FFN(siLargv)(void) { + int i=0; + + check_arg(1); + if (type_of(vs_base[0]) != t_fixnum || + (i = fix(vs_base[0])) < 0 || + i >= ARGC) + FEerror("Illegal argument index: ~S.", 1, vs_base[0]); + vs_base[0] = make_simple_string(ARGV[i]); + +} + +static void +FFN(siLgetenv)(void) { + + char name[256]; + int i; + char *value; + extern char *getenv(const char *); + + check_arg(1); + check_type_string(&vs_base[0]); + if (vs_base[0]->st.st_fillp >= 256) + FEerror("Too long name: ~S.", 1, vs_base[0]); + for (i = 0; i < vs_base[0]->st.st_fillp; i++) + name[i] = vs_base[0]->st.st_self[i]; + name[i] = '\0'; + if ((value = getenv(name)) != NULL) + {vs_base[0] = make_simple_string(value); +#ifdef FREE_GETENV_RESULT + free(value); + +#endif + } + else + vs_base[0] = Cnil; + +} + +object *vs_marker; + +static void +FFN(siLmark_vs)(void) { + check_arg(0); + vs_marker = vs_base; + vs_base[0] = Cnil; +} + +static void +FFN(siLcheck_vs)(void) { + check_arg(0); + if (vs_base != vs_marker) + FEerror("Value stack is flawed.", 0); + vs_base[0] = Cnil; +} + +static object +FFN(siLcatch_fatal)(int i) { + catch_fatal=i; + return Cnil; +} + +LFD(siLreset_stack_limits)(void) +{ + long i=0; + + check_arg(0); + if(catch_fatal <0) catch_fatal=1; +#ifdef SGC + {extern int fault_count ; fault_count = 0;} +#endif + if (vs_top < vs_org + stack_multiple * VSSIZE) + vs_limit = vs_org + stack_multiple * VSSIZE; + else + error("can't reset vs_limit"); + if (bds_top < bds_org + stack_multiple * BDSSIZE) + bds_limit = bds_org + stack_multiple * BDSSIZE; + else + error("can't reset bds_limit"); + if (frs_top < frs_org + stack_multiple * FRSSIZE) + frs_limit = frs_org + stack_multiple * FRSSIZE; + else + error("can't reset frs_limit"); + if (ihs_top < ihs_org + stack_multiple * IHSSIZE) + ihs_limit = ihs_org + stack_multiple * IHSSIZE; + else + error("can't reset ihs_limit"); + if (cs_base==cs_org) + cs_org=(void *)&i; +#ifdef __ia64__ + { + extern void * GC_save_regs_in_stack(); + if (cs_base2==cs_org2) + cs_org2=GC_save_regs_in_stack(); + } +#endif + /* reset_cstack_limit(i); */ + vs_base[0] = Cnil; +} + +#define COPYSTACK(org,p,typ,lim,top,geta,size) \ + {unsigned long topl=top-org;\ + bcopy(org,p,(lim-org)*sizeof(typ));\ + org=p;\ + top=org+topl;\ + lim=org+stack_multiple*size;\ + p=lim+(STACK_OVER+1)*geta;\ + } + +static int +multiply_stacks(int m) { + void *p; + int vs,bd,frs,ihs; + stack_multiple=stack_multiple*m; +#define ELTSIZE(x) (((char *)((x)+1)) - ((char *) x)) + vs = (stack_multiple*VSSIZE + (STACK_OVER+1)*VSGETA)* ELTSIZE(vs_org); + bd = (stack_multiple*BDSSIZE + (STACK_OVER+1)*BDSGETA)*ELTSIZE(bds_org); + frs = (stack_multiple*FRSSIZE + (STACK_OVER+1)*FRSGETA)*ELTSIZE(frs_org); + ihs = (stack_multiple*IHSSIZE + (STACK_OVER+1)*IHSGETA)*ELTSIZE(ihs_org); + if (stack_space==0) {enter_mark_origin(&stack_space);} + stack_space = alloc_simple_string(vs+bd+frs+ihs); + array_allocself(stack_space,1,code_char(0)); + p=stack_space->st.st_self; + COPYSTACK(vs_org,p,object,vs_limit,vs_top,VSGETA,VSSIZE); + COPYSTACK(bds_org,p,struct bds_bd,bds_limit,bds_top,BDSGETA,BDSSIZE); + COPYSTACK(frs_org,p,struct frame,frs_limit,frs_top,FRSGETA,FRSSIZE); + COPYSTACK(ihs_org,p,struct invocation_history,ihs_limit,ihs_top, + IHSGETA,IHSSIZE); + vs_base=vs_top; + return stack_multiple; +} + +DEFVAR("*NO-INIT*",sSAno_initA,SI,Cnil,""); + +LFD(siLinit_system)(void) { + check_arg(0); + gcl_init_system(sSAno_initA); + vs_base[0] = Cnil; +} + +static void +FFN(siLuser_init)(void) { + check_arg(0); + sLApackageA->s.s_dbind = user_package; + user_init(); + vs_base[0] = Cnil; +} + +/* static void */ +/* FFN(siLaddress)(void) { */ +/* check_arg(1); */ +/* vs_base[0] = make_fixnum((long)vs_base[0]); */ +/* } */ + +DEFUN_NEW("NANI",object,fSnani,SI,1,1,NONE,OI,OO,OO,OO,(fixnum address),"") { + + RETURN1((object)address); + +} + +DEFUN_NEW("ADDRESS",object,fSaddress,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") { + + RETURN1(x); + +} + +/* static void */ +/* FFN(siLnani)(void) { */ +/* check_arg(1); */ + +/* switch (type_of(vs_base[0])) { */ +/* case t_fixnum: */ +/* vs_base[0]=(object)fix(vs_base[0]); */ +/* break; */ +/* default: */ +/* FEerror("Cannot coerce ~s to an address",1,vs_base[0]); */ +/* } */ + +/* } */ + +static void +FFN(siLinitialization_failure)(void) { + check_arg(0); + printf("lisp initialization failed\n"); + exit(0); +} + +DEFUNO_NEW("IDENTITY",object,fLidentity,LISP + ,1,1,NONE,OO,OO,OO,OO,void,Lidentity,(object x0),"") +{ + /* 1 args */ + RETURN1 (x0); +} + +DEFUNO_NEW("GCL-COMPILE-TIME",object,fSgcl_compile_time,SI + ,0,0,NONE,OO,OO,OO,OO,void,Lgcl_compile_time,(void),"") +{ + RETURN1 (make_simple_string(__DATE__ " " __TIME__)); +} + +DEFUNO_NEW("LDB1",object,fSldb1,SI + ,3,3,NONE,OI,II,OO,OO,void,Lldb1,(fixnum a,fixnum b, fixnum c),"") +{ + RETURN1 (make_fixnum(((((~(-1 << (a))) << (b)) & (c)) >> (b)))); +} + +DEFUN_NEW("LISP-IMPLEMENTATION-VERSION",object,fLlisp_implementation_version,LISP + ,0,0,NONE,OO,OO,OO,OO,(void),"") +{ + /* 0 args */ + RETURN1((make_simple_string(LISP_IMPLEMENTATION_VERSION))); +} + + +static void +FFN(siLsave_system)(void) { + +#ifdef HAVE_YP_UNBIND + extern object truename(),namestring(); + check_arg(1); + /* prevent subsequent consultation of yp by getting + truename now*/ + vs_base[0]=namestring(truename(vs_base[0])); + {char name[200]; + char *dom = name; + if (0== getdomainname(dom,sizeof(name))) + yp_unbind(dom);} +#endif + +#ifdef DO_BEFORE_SAVE + DO_BEFORE_SAVE +#endif + + saving_system = TRUE; + + minimize_image(); + + saving_system = FALSE; + + Lsave(); + alloc_page(-(holepage+nrbpage)); + +} + +DEFVAR("*LISP-MAXPAGES*",sSAlisp_maxpagesA,SI,make_fixnum(real_maxpage),""); +DEFVAR("*SYSTEM-DIRECTORY*",sSAsystem_directoryA,SI,make_simple_string(system_directory),""); +DEFVAR("*MULTIPLY-STACKS*",sSAmultiply_stacksA,SI,Cnil,""); +DEF_ORDINARY("TOP-LEVEL",sStop_level,SI,""); +DEFVAR("*COMMAND-ARGS*",sSAcommand_argsA,SI,sLnil,""); + +static void +init_main(void) { + + make_function("BY", Lby); + make_si_function("ARGC", siLargc); + make_si_function("ARGV", siLargv); + + make_si_function("GETENV", siLgetenv); + + make_si_function("MARK-VS", siLmark_vs); + make_si_function("CHECK-VS", siLcheck_vs); + make_si_function("RESET-STACK-LIMITS", siLreset_stack_limits); + make_si_function("INIT-SYSTEM", siLinit_system); + make_si_function("USER-INIT", siLuser_init); + /* make_si_function("ADDRESS", siLaddress); */ + /* make_si_function("NANI", siLnani); */ + make_si_function("INITIALIZATION-FAILURE", + siLinitialization_failure); + + siClisp_pagesize = + make_si_constant("LISP-PAGESIZE", make_fixnum(PAGESIZE)); + + + {object features; + +#define ADD_FEATURE(name) \ + features= make_cons(make_keyword(name),features) + + features= make_cons(make_keyword("COMMON"), + make_cons(make_keyword("KCL"), Cnil)); + ADD_FEATURE("AKCL"); + ADD_FEATURE("GCL"); +#ifdef BROKEN_O4_OPT + ADD_FEATURE("BROKEN_O4_OPT"); +#endif +#ifdef GMP + ADD_FEATURE("GMP"); +#endif +#ifdef GCL_GPROF + ADD_FEATURE("GPROF"); +#endif + +#ifndef _WIN32 + ADD_FEATURE("UNIX"); +#endif + +#ifdef _WIN32 + ADD_FEATURE("WINNT"); + ADD_FEATURE("WIN32"); +#endif + +#ifdef IEEEFLOAT + ADD_FEATURE("IEEE-FLOATING-POINT"); +#endif +#ifdef SGC + ADD_FEATURE("SGC"); +#endif +/* #ifdef ADDITIONAL_FEATURES */ +/* ADDITIONAL_FEATURES; */ +/* #endif */ + ADD_FEATURE(HOST_CPU); + ADD_FEATURE(HOST_KERNEL); +#ifdef HOST_SYSTEM + ADD_FEATURE(HOST_SYSTEM); +#endif +#ifdef BSD + ADD_FEATURE("BSD"); +#endif + +#if !defined(DOUBLE_BIGENDIAN) + ADD_FEATURE("CLX-LITTLE-ENDIAN"); +#endif + +#ifndef PECULIAR_MACHINE +#define BIGM (int)((((unsigned int)(-1))/2)) + { +/* int ONEM = -1; */ + int Bigm = BIGM; + int Smallm = -BIGM-1; + int Seven = 7; + int Three = 3; + if ( (Smallm / Seven) < 0 + && (Smallm / (-Seven)) > 0 + && (Bigm / (-Seven)) < 0 + && ((-Seven) / Three) == -2 + && (Seven / (-Three)) == -2 + && ((-Seven)/ (-Three)) == 2) + { ADD_FEATURE("TRUNCATE_USE_C"); + } } +#endif + +#ifdef HAVE_READLINE + ADD_FEATURE("READLINE"); +#endif +#if !defined(USE_DLOPEN) + ADD_FEATURE("NATIVE-RELOC"); +#if defined(HAVE_LIBBFD) + ADD_FEATURE("BFD"); +#endif +#endif + ADD_FEATURE("UNEXEC"); +#ifdef HAVE_XGCL + ADD_FEATURE("XGCL"); +#endif + +#ifdef HAVE_GNU_LD + ADD_FEATURE("GNU-LD"); +#endif + +#ifdef STATIC_LINKING + ADD_FEATURE("STATIC"); +#endif + + make_special("*FEATURES*",features);} + + make_si_function("SAVE-SYSTEM", siLsave_system); + make_si_sfun("CATCH-FATAL",siLcatch_fatal,ARGTYPE1(f_fixnum)); + make_si_function("WARN-VERSION",Lidentity); + +} + +#ifdef SGC +#include "writable.h" +#endif + +#ifdef HAVE_PRINT_INSN_I386 + +#include "dis-asm.h" + +static char b[4096],*bp; + +static int +my_fprintf(void *v,const char *f,...) { + va_list va; + int r; + va_start(va,f); + bp+=(r=vsnprintf(bp,sizeof(b)-(bp-b),f,va)); + va_end(va); + return r; +} + +static int +my_read(bfd_vma memaddr, bfd_byte *myaddr, unsigned int length, struct disassemble_info *dinfo) { + memcpy(myaddr,(void *)(long)memaddr,length); + return 0; +} + +static void +my_pa(bfd_vma addr,struct disassemble_info *dinfo) { + dinfo->fprintf_func(dinfo->stream,"%p",(void *)(long)addr); +} + +#endif + +DEFUN_NEW("DISASSEMBLE-INSTRUCTION",object,fSdisassemble_instruction,SI,1,1,NONE,OI,OO,OO,OO,(fixnum addr),"") { + +#ifdef HAVE_PRINT_INSN_I386 + + static disassemble_info i; + void *v; + int (*s)(); + int j; + + memset(&i,0,sizeof(i)); +#ifdef __i386__ + i.disassembler_options="i386"; +#endif + i.fprintf_func=my_fprintf; + i.read_memory_func=my_read; + i.print_address_func=my_pa; + bp=b; + + if ((v=dlopen("libopcodes.so",RTLD_NOW))) { + if ((s=dlsym(v,"print_insn_i386"))) { + j=s(addr,&i); + my_fprintf(NULL," ;"); + return MMcons(make_simple_string(b),make_fixnum(j)); + } + massert(!dlclose(v)); + } + +#endif + + return MMcons(make_simple_string("fnop ;"),make_fixnum(0)); + +} + +typedef struct { + enum type tt; + struct typemanager *tp; +} Tbl; + +#define Tblof(a_) {(a_),tm_of(a_)} +#define tblookup(a_,b_) ({Tbl *tb=tb1;(b_)=(a_);for (;tb->tt && tb->b_!=(b_);tb++);tb->tt;}) +#define mtm_of(a_) (a_)>=t_other ? NULL : tm_of(a_) + +DEFUN_NEW("FUNCTION-BY-ADDRESS",object,fSfunction_by_address,SI,1,1,NONE,OI,OO,OO,OO,(fixnum ad),"") { + + ufixnum m=-1,mm,j; + void *o; + object x,xx=Cnil; + Tbl tb1[]={Tblof(t_sfun),Tblof(t_cfun),Tblof(t_vfun),Tblof(t_afun),Tblof(t_gfun),Tblof(t_closure),Tblof(t_cclosure),{0}}; + struct typemanager *tp; + enum type tt; + struct pageinfo *v; + + if (VALID_DATA_ADDRESS_P(ad)) + for (v=cell_list_head;v;v=v->next) + if (tblookup(mtm_of(v->type),tp)) + for (o=pagetochar(page(v)),j=tp->tm_nppage;j--;o+=tp->tm_size) + if (tblookup(type_of((x=o)),tt)) + if (!is_free(x) && (mm=ad-(ufixnum)x->sfn.sfn_self) $@ + +boot.h: boot.ini + echo '#include "make-init.h"' > $@ + echo 'void gcl_init_boot(void){' >> $@ + cat $< >> $@ + echo '}' >> $@ + +%.ini: %.c grab_defs + $(CC) -DINICOMP -DNO_DEFUN $(CFLAGS) $(DEFS) -E $*.c |\ + sed -e 's,^.* DEFUNB,DEFUNB,g' -e 's/DEF,//g' -e 's:\"[ ]*):\"):g' | ./grab_defs > $*.ini + +%.ini: %.d $(DPP) grab_defs + $(DPP) $* + $(CC) -DINICOMP -DNO_DEFUN $(CFLAGS) $(DEFS) -E $*.c |\ + sed -e 's,^.* DEFUNB,DEFUNB,g' -e 's/DEF,//g' | sed -e 's:\"[ ]*):\"):g' | ./grab_defs > $*.ini + rm $*.c + +$(DPP): ../bin/dpp.c + ${CC} ${DEFS} -o $@ $< + +new_init.c: ${INI_FILES} + echo '#include "make-init.h"' > new_init.c + echo 'void NewInit(void){' >> new_init.c + cat ${INI_FILES} >> new_init.c + echo '}' >> new_init.c + +ifneq ($(NIFLAGS),) +new_init.o: new_init.c $(DECL) + $(CC) -c $(NIFLAGS) $(DEFS) $< -o $@ +endif + +$(DECL): $(HDIR)/make-decl.h $(INI_FILES) + echo '#include "make-decl.h"' > foo.c + cat ${INI_FILES} |sed 's,DEFBFUN,DEFUN,g' >> foo.c + ${CC} -E -I${HDIR} foo.c | sed -n -e '/#/d' -e '/DO_/d' -e '/[a-zA-Z;]/p' > tmpini + ../xbin/move-if-changed mv tmpini $@ + rm -f foo.c tmpini + +grab_defs: grab_defs.c + ${CC} $(OFLAGS) -o grab_defs grab_defs.c + +$(GCLIB): ${ALIB} + rm -f gcllib.a + $(AR) gcllib.a ${ALIB} + ${RANLIB} gcllib.a + +clean: + rm -f $(OBJS) ${ALIB} new_init.o $(LAST_FILE) $(FIRST_FILE) *.a grab_defs$(EXE) *.ini tmpx foo.c + rm -f cmpinclude.h new_init.c $(DECL) def undef udef.h void.h TAGS boot.h + +.INTERMEDIATE: $(patsubst %.d,%.c,$(shell ls -1 *.d)) diff --git a/o/makefun.c b/o/makefun.c new file mode 100755 index 0000000..f9df057 --- /dev/null +++ b/o/makefun.c @@ -0,0 +1,231 @@ +#include "include.h" +#include "funlink.h" + +#define PADDR(i) ((void *)(sSPinit->s.s_dbind->fixa.fixa_self[Mfix(i)])) +/* eg: +MakeAfun(addr,F_ARGD(min,max,flags,ARGTYPES(a,b,c,d)),0); +MakeAfun(addr,F_ARGD(2,3,NONE,ARGTYPES(OO,OO,OO,OO)),0); +*/ +object MakeAfun(object (*addr)(object,object), unsigned int argd, object data) +{int type = (F_ARG_FLAGS_P(argd,F_requires_fun_passed) ? t_closure : t_afun); + object x = alloc_object(type); + x->sfn.sfn_name = Cnil; + x->sfn.sfn_self = addr; + x->sfn.sfn_argd = argd; + if (type == t_closure) + { x->cl.cl_env = 0; + x->cl.cl_envdim=0;} + x->sfn.sfn_data = data; + return x; +} + + +static object +fSmakefun(object sym, object (*addr) (/* ??? */), unsigned int argd) +{object ans = MakeAfun(addr,argd, + (sSPmemory && sSPmemory->s.s_dbind && + type_of(sSPmemory->s.s_dbind)==t_cfdata) ? + sSPmemory->s.s_dbind : 0); + ans->sfn.sfn_name = sym; + return ans; +} + +/* static object */ +/* ImakeClosure(object (*addr)(),int argd,int n,...) */ +/* { object x = fSmakefun(Cnil,addr,argd); */ +/* va_list ap; */ +/* va_start(ap,n); */ +/* IsetClosure(x,n,ap); */ +/* va_end(ap); */ +/* return x; */ +/* } */ + +static void +IsetClosure(object x, int n, va_list ap) +{ /* this will change so that we can allocate 'hunks' which will be little + blocks the size of an array header say with only one header word. This + will be more economical. Because of gc, we can't allocate relblock, it + might move while in the closure. */ + object *p; + if (type_of(x) != t_closure) + { FEerror("Not a closure",0);} + if (x->cl.cl_envdim < n) + {BEGIN_NO_INTERRUPT; x->cl.cl_env = (object *)alloc_relblock(n); + x->cl.cl_envdim = n; + END_NO_INTERRUPT; + } + p = x->cl.cl_env; + while (--n >= 0) + { *p++ = va_arg(ap,object); + } +} + +DEFUN_NEW("INITFUN",object,fSinitfun,SI,3,ARG_LIMIT,NONE,OO,OO,OO,OO, + (object sym,object addr_ind,object argd,...), + "Store a compiled function on SYMBOL whose body is in the VV array at \ +INDEX, and whose argd descriptor is ARGD. If more arguments IND1, IND2,.. \ +are supplied these are indices in the VV array for the environment of this \ +closure.") +{ int nargs = F_NARGS(VFUN_NARGS) -3; + va_list ap; + object fun = fSmakefun(IisSymbol(sym),PADDR(addr_ind),Mfix(argd)); + if (nargs > 0) + { va_start(ap,argd); + IsetClosure(fun,nargs,ap); + while (--nargs >= 0) + /* the things put in by IsetClosure were only the indices + of the closure variables not the actual variables */ + { fun->cl.cl_env[nargs]= (object) PADDR(fun->cl.cl_env[nargs]);} + va_end(ap); + } + fSfset(sym,fun); + return sym; +} + +#include "apply_n.h" + +DEFUN_NEW("INITMACRO",object,fSinitmacro,SI,4,ARG_LIMIT,NONE,OO,OO,OO,OO,(object first,...), + "Like INITFUN, but makes then sets the 'macro' flag on this symbol") +{va_list ap; + object res; + int n = VFUN_NARGS; + object *new; + va_start(ap,first); + COERCE_VA_LIST_NEW(new,first,ap,n); + res= c_apply_n_f((void *)FFN(fSinitfun),n,new,3,ARG_LIMIT); + va_end(ap); + res->s.s_mflag = 1; + return res; +} + +DEFUN_NEW("SET-KEY-STRUCT",object,fSset_key_struct,SI,1,1,NONE,OO,OO,OO,OO,(object key_struct_ind), + "Called inside the loader. The keystruct is set up in the file with \ + indexes rather than the actual entries. We change these indices to \ + the objects") +{ set_key_struct(PADDR(key_struct_ind),sSPmemory->s.s_dbind); + return Cnil; +} + + +#define collect(top_,next_,val_) ({object _x=MMcons(val_,Cnil);\ + if (top_==Cnil) top_=next_=_x; \ + else next_=next_->c.c_cdr=_x;}) + + +static void +put_fn_procls(object sym,fixnum argd,fixnum oneval,object def,object rdef) { + + unsigned int atypes=F_TYPES(argd) >> F_TYPE_WIDTH; + unsigned int minargs=F_MIN_ARGS(argd); + unsigned int maxargs=F_MAX_ARGS(argd); + unsigned int rettype=F_RESULT_TYPE(argd); + unsigned int i; + object ta=Cnil,na=Cnil; + + for (i=0;i>=F_TYPE_WIDTH) + switch(maxargs!=minargs ? F_object : atypes & MASK_RANGE(0,F_TYPE_WIDTH)) { + case F_object: + collect(ta,na,def); + break; + case F_int: + collect(ta,na,sLfixnum); + break; + case F_shortfloat: + collect(ta,na,sLshort_float); + break; + case F_double_ptr: + collect(ta,na,sLlong_float); + break; + default: + FEerror("Bad sfn declaration",0); + break; + } + if (maxargs!=minargs) + collect(ta,na,sLA); + putprop(sym,ta,sSproclaimed_arg_types); + ta=na=Cnil; + if (oneval) + switch(rettype) { + case F_object: + ta=rdef; + break; + case F_int: + ta=sLfixnum; + break; + case F_shortfloat: + ta=sLshort_float; + break; + case F_double_ptr: + ta=sLlong_float; + break; + default: + FEerror("Bad sfn declaration",0); + break; + } + else +/* ta=MMcons(sLA,Cnil); */ + ta=sLA; + putprop(sym,ta,sSproclaimed_return_type); + if (oneval) + putprop(sym,Ct,sSproclaimed_function); + +} + +void +SI_makefun(char *strg, void *fn, unsigned int argd) +{ object sym = make_si_ordinary(strg); + fSfset(sym, fSmakefun(sym,fn,argd)); + put_fn_procls(sym,argd,1,Ct,Ct); +} + +void +LISP_makefun(char *strg, void *fn, unsigned int argd) +{ object sym = make_ordinary(strg); + fSfset(sym, fSmakefun(sym,fn,argd)); + put_fn_procls(sym,argd,1,Ct,Ct); +} + +void +SI_makefunm(char *strg, void *fn, unsigned int argd) +{ object sym = make_si_ordinary(strg); + fSfset(sym, fSmakefun(sym,fn,argd)); + put_fn_procls(sym,argd,0,Ct,Ct); +} + +void +LISP_makefunm(char *strg, void *fn, unsigned int argd) +{ object sym = make_ordinary(strg); + fSfset(sym, fSmakefun(sym,fn,argd)); + put_fn_procls(sym,argd,0,Ct,Ct); +} + + +/* static object */ +/* MakeClosure(int n,int argd,object data,object (*fn)(),...) */ +/* { object x; */ +/* va_list ap; */ +/* x = alloc_object(t_closure); */ +/* x->cl.cl_name = Cnil; */ +/* x->cl.cl_self = fn; */ +/* x->cl.cl_data = data; */ +/* x->cl.cl_argd = argd; */ +/* x->cl.cl_env = 0; */ +/* x->cl.cl_env = (object *)alloc_contblock(n*sizeof(object)); */ +/* x->cl.cl_envdim=n; */ +/* va_start(ap,fn); */ +/* { object *p = x->cl.cl_env; */ +/* while (--n>= 0) */ +/* { *p++ = va_arg(ap,object);} */ +/* va_end(ap); */ +/* } */ +/* return x; */ +/* } */ + +DEFUN_NEW("INVOKE",object,fSinvoke,SI,1,ARG_LIMIT,NONE,OO,OO,OO,OO,(object x), + "Invoke a C function whose body is at INDEX in the VV array") +{ int (*fn)(); + fn = (void *) PADDR(x); + (*fn)(); + return Cnil; +} + diff --git a/o/malloc.c b/o/malloc.c new file mode 100755 index 0000000..5c37880 --- /dev/null +++ b/o/malloc.c @@ -0,0 +1,788 @@ +/* dynamic memory allocation for GNU. + Copyright (C) 1985, 1987 Free Software Foundation, Inc. + + NO WARRANTY + + BECAUSE THIS PROGRAM IS LICENSED FREE OF CHARGE, WE PROVIDE ABSOLUTELY +NO WARRANTY, TO THE EXTENT PERMITTED BY APPLICABLE STATE LAW. EXCEPT +WHEN OTHERWISE STATED IN WRITING, FREE SOFTWARE FOUNDATION, INC, +RICHARD M. STALLMAN AND/OR OTHER PARTIES PROVIDE THIS PROGRAM "AS IS" +WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, +BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY +AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE +DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR +CORRECTION. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW WILL RICHARD M. +STALLMAN, THE FREE SOFTWARE FOUNDATION, INC., AND/OR ANY OTHER PARTY +WHO MAY MODIFY AND REDISTRIBUTE THIS PROGRAM AS PERMITTED BELOW, BE +LIABLE TO YOU FOR DAMAGES, INCLUDING ANY LOST PROFITS, LOST MONIES, OR +OTHER SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR +DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY THIRD PARTIES OR +A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS) THIS +PROGRAM, EVEN IF YOU HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. + + GENERAL PUBLIC LICENSE TO COPY + + 1. You may copy and distribute verbatim copies of this source file +as you receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy a valid copyright notice "Copyright +(C) 1985 Free Software Foundation, Inc."; and include following the +copyright notice a verbatim copy of the above disclaimer of warranty +and of this License. You may charge a distribution fee for the +physical act of transferring a copy. + + 2. You may modify your copy or copies of this source file or +any portion of it, and copy and distribute such modifications under +the terms of Paragraph 1 above, provided that you also do the following: + + a) cause the modified files to carry prominent notices stating + that you changed the files and the date of any change; and + + b) cause the whole of any work that you distribute or publish, + that in whole or in part contains or is a derivative of this + program or any part thereof, to be licensed at no charge to all + third parties on terms identical to those contained in this + License Agreement (except that you may choose to grant more extensive + warranty protection to some or all third parties, at your option). + + c) You may charge a distribution fee for the physical act of + transferring a copy, and you may at your option offer warranty + protection in exchange for a fee. + +Mere aggregation of another unrelated program with this program (or its +derivative) on a volume of a storage or distribution medium does not bring +the other program under the scope of these terms. + + 3. You may copy and distribute this program (or a portion or derivative +of it, under Paragraph 2) in object code or executable form under the terms +of Paragraphs 1 and 2 above provided that you also do one of the following: + + a) accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of + Paragraphs 1 and 2 above; or, + + b) accompany it with a written offer, valid for at least three + years, to give any third party free (except for a nominal + shipping charge) a complete machine-readable copy of the + corresponding source code, to be distributed under the terms of + Paragraphs 1 and 2 above; or, + + c) accompany it with the information you received as to where the + corresponding source code may be obtained. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form alone.) + +For an executable file, complete source code means all the source code for +all modules it contains; but, as a special exception, it need not include +source code for modules which are standard libraries that accompany the +operating system on which the executable file runs. + + 4. You may not copy, sublicense, distribute or transfer this program +except as expressly provided under this License Agreement. Any attempt +otherwise to copy, sublicense, distribute or transfer this program is void and +your rights to use the program under this License agreement shall be +automatically terminated. However, parties who have received computer +software programs from you with this License Agreement will not have +their licenses terminated so long as such parties remain in full compliance. + + 5. If you wish to incorporate parts of this program into other free +programs whose distribution conditions are different, write to the Free +Software Foundation at 675 Mass Ave, Cambridge, MA 02139. We have not yet +worked out a simple rule that can be stated here, but we will often permit +this. We will be guided by the two goals of preserving the free status of +all derivatives of our free software and of promoting the sharing and reuse of +software. + + +In other words, you are welcome to use, share and improve this program. +You are forbidden to forbid anyone else to use, share and improve +what you give them. Help stamp out software-hoarding! */ + + +/* + * @(#)nmalloc.c 1 (Caltech) 2/21/82 + * + * U of M Modified: 20 Jun 1983 ACT: strange hacks for Emacs + * + * Nov 1983, Mike@BRL, Added support for 4.1C/4.2 BSD. + * + * This is a very fast storage allocator. It allocates blocks of a small + * number of different sizes, and keeps free lists of each size. Blocks + * that don't exactly fit are passed up to the next larger size. In this + * implementation, the available sizes are (2^n)-4 (or -16) bytes long. + * This is designed for use in a program that uses vast quantities of + * memory, but bombs when it runs out. To make it a little better, it + * warns the user when he starts to get near the end. + * + * June 84, ACT: modified rcheck code to check the range given to malloc, + * rather than the range determined by the 2-power used. + * + * Jan 85, RMS: calls malloc_warning to issue warning on nearly full. + * No longer Emacs-specific; can serve as all-purpose malloc for GNU. + * You should call malloc_init to reinitialize after loading dumped Emacs. + * Call malloc_stats to get info on memory stats if MSTATS turned on. + * realloc knows how to return same block given, just changing its size, + * if the power of 2 is correct. + */ +/* Oct 89: wfs@cs.utexas.edu: Created V/ merge file for + * changes for GCL. + * Calls to sbrk replaced by alloc_page. Remove some of the + * additions for emacs. + * NB: According to the gnu license you may only distribute the + * verbatim copy of the gnumalloc.c. Thus we only distribute + * an abbreviated diffs file from that verbatim copy. +*/ +/* + * nextf[i] is the pointer to the next free block of size 2^(i+3). The + * smallest allocatable block is 8 bytes. The overhead information will + * go in the first int of the block, and the returned pointer will point + * to the second. + * +#ifdef MSTATS + * nmalloc[i] is the difference between the number of mallocs and frees + * for a given block size. +#endif /* MSTATS */ + +#ifdef emacs +#include "config.h" +#endif /* emacs */ + +/* Determine which kind of system this is. */ +#include +#ifndef SIGTSTP +#ifndef VMS +#ifndef USG +#define USG +#endif +#endif /* not VMS */ +#else /* SIGTSTP */ +#ifdef SIGIO +#define BSD42 +#endif /* SIGIO */ +#endif /* SIGTSTP */ + +/* Define getpagesize () if the system does not. */ +#define getpagesize() 2048 + +#ifndef BSD42 +#ifndef USG +#include /* warn the user when near the end */ +#endif /* not USG */ +#else /* if BSD42 */ +#include +/* #include */ +#endif /* BSD42 */ + +extern char *start_of_data (); + +#ifdef BSD +#ifndef DATA_SEG_BITS +#define start_of_data() &etext +#endif +#endif + +#ifndef emacs +#define start_of_data() &etext +#endif + +#define ISALLOC ((char) 0xf7) /* magic byte that implies allocation */ +#define ISFREE ((char) 0x54) /* magic byte that implies free block */ + /* this is for error checking only */ +#define ISMEMALIGN ((char) 0xd6) /* Stored before the value returned by + memalign, with the rest of the word + being the distance to the true + beginning of the block. */ + +extern char etext; + +/* These two are for user programs to look at, when they are interested. */ + +unsigned int malloc_sbrk_used; /* amount of data space used now */ +unsigned int malloc_sbrk_unused; /* amount more we can have */ + +/* start of data space; can be changed by calling init_malloc */ +static char *data_space_start; + +#define PAGEWIDTH 11 +char *alloc_page(); +#define sbrk our_sbrk +char * +our_sbrk(x) +int x; +{return alloc_page((x >> PAGEWIDTH));} + + + + +#ifdef MSTATS +static int nmalloc[30]; +static int nmal, nfre; +#endif /* MSTATS */ + +/* If range checking is not turned on, all we have is a flag indicating + whether memory is allocated, an index in nextf[], and a size field; to + realloc() memory we copy either size bytes or 1<<(index+3) bytes depending + on whether the former can hold the exact size (given the value of + 'index'). If range checking is on, we always need to know how much space + is allocated, so the 'size' field is never used. */ + +struct mhead { + char mh_alloc; /* ISALLOC or ISFREE */ + char mh_index; /* index in nextf[] */ +/* Remainder are valid only when block is allocated */ + unsigned short mh_size; /* size, if < 0x10000 */ +#ifdef rcheck + unsigned mh_nbytes; /* number of bytes allocated */ + int mh_magic4; /* should be == MAGIC4 */ +#endif /* rcheck */ +}; + +/* Access free-list pointer of a block. + It is stored at block + 4. + This is not a field in the mhead structure + because we want sizeof (struct mhead) + to describe the overhead for when the block is in use, + and we do not want the free-list pointer to count in that. */ + +#define CHAIN(a) \ + (*(struct mhead **) (sizeof (char *) + (char *) (a))) + +#ifdef rcheck + +/* To implement range checking, we write magic values in at the beginning and + end of each allocated block, and make sure they are undisturbed whenever a + free or a realloc occurs. */ +/* Written in each of the 4 bytes following the block's real space */ +#define MAGIC1 0x55 +/* Written in the 4 bytes before the block's real space */ +#define MAGIC4 0x55555555 +#define ASSERT(p) if (!(p)) botch("p"); else +#define EXTRA 4 /* 4 bytes extra for MAGIC1s */ +#else +#define ASSERT(p) +#define EXTRA 0 +#endif /* rcheck */ + + +/* nextf[i] is free list of blocks of size 2**(i + 3) */ + +static struct mhead *nextf[30]; + +/* busy[i] is nonzero while allocation of block size i is in progress. */ + +static char busy[30]; + +/* Number of bytes of writable memory we can expect to be able to get */ +static unsigned int lim_data; + +/* Level number of warnings already issued. + 0 -- no warnings issued. + 1 -- 75% warning already issued. + 2 -- 85% warning already issued. +*/ +static int warnlevel; + +/* Function to call to issue a warning; + 0 means don't issue them. */ +static void (*warnfunction) (); + +/* nonzero once initial bunch of free blocks made */ +static int gotpool; + +char *_malloc_base; + +static void getpool (); + +/* Cause reinitialization based on job parameters; + also declare where the end of pure storage is. */ +void +malloc_init (start, warnfun) + char *start; + void (*warnfun) (); +{ + if (start) + data_space_start = start; + lim_data = 0; + warnlevel = 0; + warnfunction = warnfun; +} + +/* Return the maximum size to which MEM can be realloc'd + without actually requiring copying. */ + +int +malloc_usable_size (mem) + char *mem; +{ + int blocksize = 8 << (((struct mhead *) mem) - 1) -> mh_index; + + return blocksize - sizeof (struct mhead) - EXTRA; +} + +static void +morecore (nu) /* ask system for more memory */ + register int nu; /* size index to get more of */ +{ + char *sbrk (); + register char *cp; + register int nblks; + register unsigned int siz; + int oldmask; + +#ifdef BSD +#ifndef BSD4_1 + oldmask = sigsetmask (-1); +#endif +#endif + + if (!data_space_start) + { + data_space_start = start_of_data (); + } + + if (lim_data == 0) + get_lim_data (); + + /* On initial startup, get two blocks of each size up to 1k bytes */ + if (!gotpool) + { getpool (); getpool (); gotpool = 1; } + + /* Find current end of memory and issue warning if getting near max */ + + /* Take at least 2k, and figure out how many blocks of the desired size + we're about to get */ + nblks = 1; + if ((siz = nu) < 8) + nblks = 1 << ((siz = 8) - nu); + + if ((cp = sbrk (1 << (siz + 3)))==0) + return; /* no more room! */ + + /* save new header and link the nblks blocks together */ + nextf[nu] = (struct mhead *) cp; + siz = 1 << (nu + 3); + while (1) + { + ((struct mhead *) cp) -> mh_alloc = ISFREE; + ((struct mhead *) cp) -> mh_index = nu; + if (--nblks <= 0) break; + CHAIN ((struct mhead *) cp) = (struct mhead *) (cp + siz); + cp += siz; + } + CHAIN ((struct mhead *) cp) = 0; + +#ifdef BSD +#ifndef BSD4_1 + sigsetmask (oldmask); +#endif +#endif +} + +static void +getpool () +{ + register int nu; + char * sbrk (); + register char *cp = sbrk (0); + + if ((int) cp & 0x3ff) /* land on 1K boundaries */ + sbrk (1024 - ((int) cp & 0x3ff)); + + /* Record address of start of space allocated by malloc. */ + if (_malloc_base == 0) + _malloc_base = cp; + + /* Get 2k of storage */ + + cp = sbrk (04000); + if (cp == (char *) -1) + return; + + /* Divide it into an initial 8-word block + plus one block of size 2**nu for nu = 3 ... 10. */ + + CHAIN (cp) = nextf[0]; + nextf[0] = (struct mhead *) cp; + ((struct mhead *) cp) -> mh_alloc = ISFREE; + ((struct mhead *) cp) -> mh_index = 0; + cp += 8; + + for (nu = 0; nu < 7; nu++) + { + CHAIN (cp) = nextf[nu]; + nextf[nu] = (struct mhead *) cp; + ((struct mhead *) cp) -> mh_alloc = ISFREE; + ((struct mhead *) cp) -> mh_index = nu; + cp += 8 << nu; + } +} + +char * +malloc (n) /* get a block */ + unsigned n; +{ + register struct mhead *p; + register unsigned int nbytes; + register int nunits = 0; + + /* Figure out how many bytes are required, rounding up to the nearest + multiple of 4, then figure out which nextf[] area to use */ + nbytes = (n + sizeof *p + EXTRA + 3) & ~3; + { + register unsigned int shiftr = (nbytes - 1) >> 2; + + while (shiftr >>= 1) + nunits++; + } + + /* In case this is reentrant use of malloc from signal handler, + pick a block size that no other malloc level is currently + trying to allocate. That's the easiest harmless way not to + interfere with the other level of execution. */ + while (busy[nunits]) nunits++; + busy[nunits] = 1; + + /* If there are no blocks of the appropriate size, go get some */ + /* COULD SPLIT UP A LARGER BLOCK HERE ... ACT */ + if (nextf[nunits] == 0) + morecore (nunits); + + /* Get one block off the list, and set the new list head */ + if ((p = nextf[nunits]) == 0) + { + busy[nunits] = 0; + return 0; + } + nextf[nunits] = CHAIN (p); + busy[nunits] = 0; + + /* Check for free block clobbered */ + /* If not for this check, we would gobble a clobbered free chain ptr */ + /* and bomb out on the NEXT allocate of this size block */ + if (p -> mh_alloc != ISFREE || p -> mh_index != nunits) +#ifdef rcheck + botch ("block on free list clobbered"); +#else /* not rcheck */ + abort (); +#endif /* not rcheck */ + + /* Fill in the info, and if range checking, set up the magic numbers */ + p -> mh_alloc = ISALLOC; +#ifdef rcheck + p -> mh_nbytes = n; + p -> mh_magic4 = MAGIC4; + { + register char *m = (char *) (p + 1) + n; + + *m++ = MAGIC1, *m++ = MAGIC1, *m++ = MAGIC1, *m = MAGIC1; + } +#else /* not rcheck */ + p -> mh_size = n; +#endif /* not rcheck */ +#ifdef MSTATS + nmalloc[nunits]++; + nmal++; +#endif /* MSTATS */ + return (char *) (p + 1); +} + +free (mem) + char *mem; +{ + register struct mhead *p; + { + register char *ap = mem; + + if (ap == 0) + return; + + p = (struct mhead *) ap - 1; + if (p -> mh_alloc == ISMEMALIGN) + { + ap -= p->mh_size; + p = (struct mhead *) ap - 1; + } + + if (p -> mh_alloc != ISALLOC) + abort (); + +#ifdef rcheck + ASSERT (p -> mh_magic4 == MAGIC4); + ap += p -> mh_nbytes; + ASSERT (*ap++ == MAGIC1); ASSERT (*ap++ == MAGIC1); + ASSERT (*ap++ == MAGIC1); ASSERT (*ap == MAGIC1); +#endif /* rcheck */ + } + { + register int nunits = p -> mh_index; + + ASSERT (nunits <= 29); + p -> mh_alloc = ISFREE; + + /* Protect against signal handlers calling malloc. */ + busy[nunits] = 1; + /* Put this block on the free list. */ + CHAIN (p) = nextf[nunits]; + nextf[nunits] = p; + busy[nunits] = 0; + +#ifdef MSTATS + nmalloc[nunits]--; + nfre++; +#endif /* MSTATS */ + } +} + +char * +realloc (mem, n) + char *mem; + register unsigned n; +{ + register struct mhead *p; + register unsigned int tocopy; + register unsigned int nbytes; + register int nunits; + + if ((p = (struct mhead *) mem) == 0) + return malloc (n); + p--; + nunits = p -> mh_index; + ASSERT (p -> mh_alloc == ISALLOC); +#ifdef rcheck + ASSERT (p -> mh_magic4 == MAGIC4); + { + register char *m = mem + (tocopy = p -> mh_nbytes); + ASSERT (*m++ == MAGIC1); ASSERT (*m++ == MAGIC1); + ASSERT (*m++ == MAGIC1); ASSERT (*m == MAGIC1); + } +#else /* not rcheck */ + if (p -> mh_index >= 13) + tocopy = (1 << (p -> mh_index + 3)) - sizeof *p; + else + tocopy = p -> mh_size; +#endif /* not rcheck */ + + /* See if desired size rounds to same power of 2 as actual size. */ + nbytes = (n + sizeof *p + EXTRA + 7) & ~7; + + /* If ok, use the same block, just marking its size as changed. */ + if (nbytes > (4 << nunits) && nbytes <= (8 << nunits)) + { +#ifdef rcheck + register char *m = mem + tocopy; + *m++ = 0; *m++ = 0; *m++ = 0; *m++ = 0; + p-> mh_nbytes = n; + m = mem + n; + *m++ = MAGIC1; *m++ = MAGIC1; *m++ = MAGIC1; *m++ = MAGIC1; +#else /* not rcheck */ + p -> mh_size = n; +#endif /* not rcheck */ + return mem; + } + + if (n < tocopy) + tocopy = n; + { + register char *new; + + if ((new = malloc (n)) == 0) + return 0; + bcopy (mem, new, tocopy); + free (mem); + return new; + } +} + +#ifndef VMS + +static char * +memalign (alignment, size) + unsigned alignment, size; +{ + register char *ptr = malloc (size + alignment); + register char *aligned; + register struct mhead *p; + + if (ptr == 0) + return 0; + /* If entire block has the desired alignment, just accept it. */ + if (((int) ptr & (alignment - 1)) == 0) + return ptr; + /* Otherwise, get address of byte in the block that has that alignment. */ + aligned = (char *) (((int) ptr + alignment - 1) & -alignment); + + /* Store a suitable indication of how to free the block, + so that free can find the true beginning of it. */ + p = (struct mhead *) aligned - 1; + p -> mh_size = aligned - ptr; + p -> mh_alloc = ISMEMALIGN; + return aligned; +} + +#ifndef HPUX +/* This runs into trouble with getpagesize on HPUX. + Patching out seems cleaner than the ugly fix needed. */ +static char * +valloc (size) +{ + return memalign (getpagesize (), size); +} +#endif /* not HPUX */ +#endif /* not VMS */ + +#ifdef MSTATS +/* Return statistics describing allocation of blocks of size 2**n. */ + +struct mstats_value + { + int blocksize; + int nfree; + int nused; + }; + +struct mstats_value +malloc_stats (size) + int size; +{ + struct mstats_value v; + register int i; + register struct mhead *p; + + v.nfree = 0; + + if (size < 0 || size >= 30) + { + v.blocksize = 0; + v.nused = 0; + return v; + } + + v.blocksize = 1 << (size + 3); + v.nused = nmalloc[size]; + + for (p = nextf[size]; p; p = CHAIN (p)) + v.nfree++; + + return v; +} +#endif /* MSTATS */ + +/* + * This function returns the total number of bytes that the process + * will be allowed to allocate via the sbrk(2) system call. On + * BSD systems this is the total space allocatable to stack and + * data. On USG systems this is the data space only. + */ + +#ifdef USG + +get_lim_data () +{ + extern long ulimit (); + + lim_data = ulimit (3, 0); + lim_data -= (long) data_space_start; +} + +#else /* not USG */ +#ifndef BSD42 + +get_lim_data () +{ + lim_data = vlimit (LIM_DATA, -1); +} + +#else /* BSD42 */ + +get_lim_data () +{ + struct rlimit XXrlimit; + +#ifdef RLIMIT_DATA + getrlimit (RLIMIT_DATA, &XXrlimit); +#endif +#ifdef RLIM_INFINITY + lim_data = XXrlimit.rlim_cur & RLIM_INFINITY; /* soft limit */ +#else + lim_data = XXrlimit.rlim_cur; /* soft limit */ +#endif +} + +#endif /* BSD42 */ +#endif /* not USG */ + +#ifdef VMS +/* There is a problem when dumping and restoring things on VMS. Calls + * to SBRK don't necessarily result in contiguous allocation. Dumping + * doesn't work when it isn't. Therefore, we make the initial + * allocation contiguous by allocating a big chunk, and do SBRKs from + * there. Once Emacs has dumped there is no reason to continue + * contiguous allocation, malloc doesn't depend on it. + * + * There is a further problem of using brk and sbrk while using VMS C + * run time library routines malloc, calloc, etc. The documentation + * says that this is a no-no, although I'm not sure why this would be + * a problem. In any case, we remove the necessity to call brk and + * sbrk, by calling calloc (to assure zero filled data) rather than + * sbrk. + * + * VMS_ALLOCATION_SIZE is the size of the allocation array. This + * should be larger than the malloc size before dumping. Making this + * too large will result in the startup procedure slowing down since + * it will require more space and time to map it in. + * + * The value for VMS_ALLOCATION_SIZE in the following define was determined + * by running emacs linked (and a large allocation) with the debugger and + * looking to see how much storage was used. The allocation was 201 pages, + * so I rounded it up to a power of two. + */ +#ifndef VMS_ALLOCATION_SIZE +#define VMS_ALLOCATION_SIZE (512*256) +#endif + +/* Use VMS RTL definitions */ +#undef sbrk +#undef brk +#undef malloc +int vms_out_initial = 0; +char vms_initial_buffer[VMS_ALLOCATION_SIZE]; +static char *vms_current_brk = &vms_initial_buffer; +static char *vms_end_brk = &vms_initial_buffer[VMS_ALLOCATION_SIZE-1]; + +#include + +char * +sys_sbrk (incr) + int incr; +{ + char *sbrk(), *temp, *ptr; + + if (vms_out_initial) + { + /* out of initial allocation... */ + if (!(temp = malloc (incr))) + temp = (char *) -1; + } + else + { + /* otherwise, go out of our area */ + ptr = vms_current_brk + incr; /* new current_brk */ + if (ptr <= vms_end_brk) + { + temp = vms_current_brk; + vms_current_brk = ptr; + } + else + { + vms_out_initial = 1; /* mark as out of initial allocation */ + if (!(temp = malloc (incr))) + temp = (char *) -1; + } + } + return temp; +} +#endif /* VMS */ diff --git a/o/mapfun.c b/o/mapfun.c new file mode 100755 index 0000000..dc7a24c --- /dev/null +++ b/o/mapfun.c @@ -0,0 +1,326 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +/* + + mapfun.c + + Mapping +*/ + +#include "include.h" + +/* + +Use of VS in mapfunctions: + + | | + |-------| + base -> | fun | + | list1 | + | : | + | : | + | listn | + top -> | value | ----- the list which should be returned + | arg1 | --| + | : | |-- arguments to FUN. + | : | | On call to FUN, vs_base = top+1 + | argn | --| vs_top = top+n+1 + |-------| + | | + VS +*/ + +LFD(Lmapcar)(void) +{ + + object *top = vs_top; + object *base = vs_base; + object x, handy; + int n = vs_top-vs_base-1; + int i; + + if (n <= 0) + too_few_arguments(); + vs_push(Cnil); + for (i = 1; i <= n; i++) { + x = base[i]; + if (endp(x)) { + base[0] = Cnil; + vs_top = base+1; + vs_base = base; + return; + } + vs_push(MMcar(x)); + base[i] = MMcdr(x); + } + handy = top[0] = MMcons(Cnil,Cnil); +LOOP: + vs_base = top+1; + super_funcall(base[0]); + MMcar(handy) = vs_base[0]; + for (i = 1; i <= n; i++) { + x = base[i]; + if (endp(x)) { + vs_base = top; + vs_top = top+1; + return; + } + top[i] = MMcar(x); + base[i] = MMcdr(x); + } + vs_top = top+n+1; + handy = MMcdr(handy) = MMcons(Cnil,Cnil); + goto LOOP; +} + +LFD(Lmaplist)(void) +{ + + object *top = vs_top; + object *base = vs_base; + object x, handy; + int n = vs_top-vs_base-1; + int i; + + if (n <= 0) + too_few_arguments(); + vs_push(Cnil); + for (i = 1; i <= n; i++) { + x = base[i]; + if (endp(x)) { + base[0] = Cnil; + vs_top = base+1; + vs_base = base; + return; + } + vs_push(x); + base[i] = MMcdr(x); + } + handy = top[0] = MMcons(Cnil,Cnil); +LOOP: + vs_base = top+1; + super_funcall(base[0]); + MMcar(handy) = vs_base[0]; + for (i = 1; i <= n; i++) { + x = base[i]; + if (endp(x)) { + vs_base = top; + vs_top = top+1; + return; + } + top[i] = x; + base[i] = MMcdr(x); + } + vs_top = top+n+1; + handy = MMcdr(handy) = MMcons(Cnil,Cnil); + goto LOOP; +} + +LFD(Lmapc)(void) +{ + + object *top = vs_top; + object *base = vs_base; + object x; + int n = vs_top-vs_base-1; + int i; + + if (n <= 0) + too_few_arguments(); + vs_push(base[1]); + for (i = 1; i <= n; i++) { + x = base[i]; + if (endp(x)) { + vs_top = top+1; + vs_base = top; + return; + } + vs_push(MMcar(x)); + base[i] = MMcdr(x); + } +LOOP: + vs_base = top+1; + super_funcall(base[0]); + for (i = 1; i <= n; i++) { + x = base[i]; + if (endp(x)) { + vs_base = top; + vs_top = top+1; + return; + } + top[i] = MMcar(x); + base[i] = MMcdr(x); + } + vs_top = top+n+1; + goto LOOP; +} + +LFD(Lmapl)(void) +{ + + object *top = vs_top; + object *base = vs_base; + object x; + int n = vs_top-vs_base-1; + int i; + + if (n <= 0) + too_few_arguments(); + vs_push(base[1]); + for (i = 1; i <= n; i++) { + x = base[i]; + if (endp(x)) { + vs_top = top+1; + vs_base = top; + return; + } + vs_push(x); + base[i] = MMcdr(x); + } +LOOP: + vs_base = top+1; + super_funcall(base[0]); + for (i = 1; i <= n; i++) { + x = base[i]; + if (endp(x)) { + vs_base = top; + vs_top = top+1; + return; + } + top[i] = x; + base[i] = MMcdr(x); + } + vs_top = top+n+1; + goto LOOP; +} + +LFD(Lmapcan)(void) +{ + + object *top = vs_top; + object *base = vs_base; + object x, handy; + int n = vs_top-vs_base-1; + int i; + + if (n <= 0) + too_few_arguments(); + vs_push(Cnil); + for (i = 1; i <= n; i++) { + x = base[i]; + if (endp(x)) { + base[0] = Cnil; + vs_top = base+1; + vs_base = base; + return; + } + vs_push(MMcar(x)); + base[i] = MMcdr(x); + } + handy = Cnil; +LOOP: + vs_base = top+1; + super_funcall(base[0]); + if (endp(handy)) handy = top[0] = vs_base[0]; + else { + x = MMcdr(handy); + while(!endp(x)) { + handy = x; + x = MMcdr(x); + } + MMcdr(handy) = vs_base[0]; + } + for (i = 1; i <= n; i++) { + x = base[i]; + if (endp(x)) { + vs_base = top; + vs_top = top+1; + return; + } + top[i] = MMcar(x); + base[i] = MMcdr(x); + } + vs_top = top+n+1; + goto LOOP; +} + +LFD(Lmapcon)(void) +{ + + object *top = vs_top; + object *base = vs_base; + object x, handy; + int n = vs_top-vs_base-1; + int i; + + if (n <= 0) + too_few_arguments(); + vs_push(Cnil); + for (i = 1; i <= n; i++) { + x = base[i]; + if (endp(x)) { + base[0] = Cnil; + vs_top = base+1; + vs_base = base; + return; + } + vs_push(x); + base[i] = MMcdr(x); + } + handy = Cnil; +LOOP: + vs_base = top+1; + super_funcall(base[0]); + if (endp(handy)) + handy = top[0] = vs_base[0]; + else { + x = MMcdr(handy); + while(!endp(x)) { + handy = x; + x = MMcdr(x); + } + MMcdr(handy) = vs_base[0]; + } + for (i = 1; i <= n; i++) { + x = base[i]; + if (endp(x)) { + vs_base = top; + vs_top = top+1; + return; + } + top[i] = x; + base[i] = MMcdr(x); + } + vs_top = top+n+1; + goto LOOP; +} + +void +gcl_init_mapfun(void) +{ + make_function("MAPCAR", Lmapcar); + make_function("MAPLIST", Lmaplist); + make_function("MAPC", Lmapc); + make_function("MAPL", Lmapl); + make_function("MAPCAN", Lmapcan); + make_function("MAPCON", Lmapcon); +} diff --git a/o/mingfile.c b/o/mingfile.c new file mode 100644 index 0000000..26a67f9 --- /dev/null +++ b/o/mingfile.c @@ -0,0 +1,64 @@ +#include "include.h" +#include "windows.h" +#include "winsock2.h" + +extern object truename(object); +extern object make_pathname(); +void Ldirectory ( void ) +{ + char filename[MAXPATHLEN]; + object *top=vs_top; + object path; + check_arg(1); + check_type_or_pathname_string_symbol_stream(&vs_base[0]); + path = vs_base[0] = coerce_to_pathname(vs_base[0]); + + if (vs_base[0]->pn.pn_name==Cnil && vs_base[0]->pn.pn_type==Cnil) { + coerce_to_filename(vs_base[0], filename); + strcat(filename, "*.*"); + } else if (vs_base[0]->pn.pn_name==Cnil) { + vs_base[0]->pn.pn_name = sKwild; + coerce_to_filename(vs_base[0], filename); + vs_base[0]->pn.pn_name = Cnil; + } else if (vs_base[0]->pn.pn_type==Cnil) { + coerce_to_filename(vs_base[0], filename); + strcat(filename, ".*"); + } else + coerce_to_filename(vs_base[0], filename); + { WIN32_FIND_DATA data; + HANDLE dirHandle = FindFirstFile(filename,&data); + + if (dirHandle== INVALID_HANDLE_VALUE) { + vs_base[0]=Cnil; return; + } else { + do { + if (strcmp(data.cFileName,"..") != 0 && strcmp(data.cFileName,".") != 0 ) { + object name = make_simple_string(data.cFileName); + object new = coerce_to_pathname(name); + vs_push(make_pathname(path->pn.pn_host, + path->pn.pn_device, + path->pn.pn_directory, + new->pn.pn_name, + new->pn.pn_type, + new->pn.pn_version)); + } + } while (FindNextFile(dirHandle,&data)); + FindClose(dirHandle); + } + vs_push(Cnil); + while (vs_top > top + 1) + stack_cons(); + vs_base = top; + + } +} + +int +mingwlisten(FILE *fp) { + + int c = 0; + ioctlsocket(fileno(fp), FIONREAD, (void *)&c); + if (c<=0) + return 1; + return 0; +} diff --git a/o/mingwin.c b/o/mingwin.c new file mode 100755 index 0000000..c68cdba --- /dev/null +++ b/o/mingwin.c @@ -0,0 +1,957 @@ +#include "include.h" + + + +#include "windows.h" +#include "errno.h" +#include "signal.h" +#include "stdlib.h" + +#ifdef DODEBUG +#define dprintf(s,arg) \ + do {fprintf(stderr,s,arg); \ + fflush(stderr); }\ + while(0) +#else +#define dprintf(s,arg) +#endif + +#ifndef EWOULDBLOCK +#define EWOULDBLOCK EAGAIN +#endif + + + +#include "errno.h" +#include +#include +#include +#include + + +#define Tcl_GetErrno() errno +#define Tcl_SetErrno(n) errno=n + +/* + * The following structure contains pointers to all of the WinSock API entry + * points used by Tcl. It is initialized by InitSockets. Since we + * dynamically load Winsock.dll on demand, we must use this function table + * to refer to functions in the socket API. + */ + +static struct { + HINSTANCE hInstance; /* Handle to WinSock library. */ + SOCKET (PASCAL FAR *accept)(SOCKET s, struct sockaddr FAR *addr, + int FAR *addrlen); + int (PASCAL FAR *bind)(SOCKET s, const struct sockaddr FAR *addr, + int namelen); + int (PASCAL FAR *closesocket)(SOCKET s); + int (PASCAL FAR *connect)(SOCKET s, const struct sockaddr FAR *name, + int namelen); + int (PASCAL FAR *ioctlsocket)(SOCKET s, long cmd, u_long FAR *argp); + int (PASCAL FAR *getsockopt)(SOCKET s, int level, int optname, + char FAR * optval, int FAR *optlen); + u_short (PASCAL FAR *htons)(u_short hostshort); + unsigned long (PASCAL FAR *inet_addr)(const char FAR * cp); + char FAR * (PASCAL FAR *inet_ntoa)(struct in_addr in); + int (PASCAL FAR *listen)(SOCKET s, int backlog); + u_short (PASCAL FAR *ntohs)(u_short netshort); + int (PASCAL FAR *recv)(SOCKET s, char FAR * buf, int len, int flags); + int (PASCAL FAR *select)(int nfds, fd_set FAR * readfds, + fd_set FAR * writefds, fd_set FAR * exceptfds, + const struct timeval FAR * tiemout); + int (PASCAL FAR *send)(SOCKET s, const char FAR * buf, int len, int flags); + int (PASCAL FAR *setsockopt)(SOCKET s, int level, int optname, + const char FAR * optval, int optlen); + int (PASCAL FAR *shutdown)(SOCKET s, int how); + SOCKET (PASCAL FAR *socket)(int af, int type, int protocol); + struct hostent FAR * (PASCAL FAR *gethostbyname)(const char FAR * name); + struct hostent FAR * (PASCAL FAR *gethostbyaddr)(const char FAR *addr, + int addrlen, int addrtype); + int (PASCAL FAR *gethostname)(char FAR * name, int namelen); + int (PASCAL FAR *getpeername)(SOCKET sock, struct sockaddr FAR *name, + int FAR *namelen); + struct servent FAR * (PASCAL FAR *getservbyname)(const char FAR * name, + const char FAR * proto); + int (PASCAL FAR *getsockname)(SOCKET sock, struct sockaddr FAR *name, + int FAR *namelen); + int (PASCAL FAR *WSAStartup)(WORD wVersionRequired, LPWSADATA lpWSAData); + int (PASCAL FAR *WSACleanup)(void); + int (PASCAL FAR *WSAGetLastError)(void); + int (PASCAL FAR *WSAAsyncSelect)(SOCKET s, HWND hWnd, u_int wMsg, + long lEvent); +} winSock; + +static int SocketsEnabled(); +static void close_winsock(); +extern void doReverse ( char *s, int n ); + + +/* + *---------------------------------------------------------------------- + * + * InitSockets -- + * + * Initialize the socket module. Attempts to load the wsock32.dll + * library and set up the winSock function table. If successful, + * registers the event window for the socket notifier code. + * + * Assumes Mutex is held. + * + * Results: + * None. + * + * Side effects: + * Dynamically loads wsock32.dll, and registers a new window + * class and creates a window for use in asynchronous socket + * notification. + * + *---------------------------------------------------------------------- + */ + + +static void +InitSockets() +{ + WSADATA wsaData; + static int initialized; + if (! initialized) { + initialized = 1; + winSock.hInstance = LoadLibraryA("wsock32.dll"); + + /* + * Initialize the function table. + */ + + if (!SocketsEnabled()) { + return; + } + + winSock.accept = (SOCKET (PASCAL FAR *)(SOCKET s, + struct sockaddr FAR *addr, int FAR *addrlen)) + GetProcAddress(winSock.hInstance, "accept"); + winSock.bind = (int (PASCAL FAR *)(SOCKET s, + const struct sockaddr FAR *addr, int namelen)) + GetProcAddress(winSock.hInstance, "bind"); + winSock.closesocket = (int (PASCAL FAR *)(SOCKET s)) + GetProcAddress(winSock.hInstance, "closesocket"); + winSock.connect = (int (PASCAL FAR *)(SOCKET s, + const struct sockaddr FAR *name, int namelen)) + GetProcAddress(winSock.hInstance, "connect"); + winSock.ioctlsocket = (int (PASCAL FAR *)(SOCKET s, long cmd, + u_long FAR *argp)) + GetProcAddress(winSock.hInstance, "ioctlsocket"); + winSock.getsockopt = (int (PASCAL FAR *)(SOCKET s, + int level, int optname, char FAR * optval, int FAR *optlen)) + GetProcAddress(winSock.hInstance, "getsockopt"); + winSock.htons = (u_short (PASCAL FAR *)(u_short hostshort)) + GetProcAddress(winSock.hInstance, "htons"); + winSock.inet_addr = (unsigned long (PASCAL FAR *)(const char FAR *cp)) + GetProcAddress(winSock.hInstance, "inet_addr"); + winSock.inet_ntoa = (char FAR * (PASCAL FAR *)(struct in_addr in)) + GetProcAddress(winSock.hInstance, "inet_ntoa"); + winSock.listen = (int (PASCAL FAR *)(SOCKET s, int backlog)) + GetProcAddress(winSock.hInstance, "listen"); + winSock.ntohs = (u_short (PASCAL FAR *)(u_short netshort)) + GetProcAddress(winSock.hInstance, "ntohs"); + winSock.recv = (int (PASCAL FAR *)(SOCKET s, char FAR * buf, + int len, int flags)) GetProcAddress(winSock.hInstance, "recv"); + winSock.select = (int (PASCAL FAR *)(int nfds, fd_set FAR * readfds, + fd_set FAR * writefds, fd_set FAR * exceptfds, + const struct timeval FAR * tiemout)) + GetProcAddress(winSock.hInstance, "select"); + winSock.send = (int (PASCAL FAR *)(SOCKET s, const char FAR * buf, + int len, int flags)) GetProcAddress(winSock.hInstance, "send"); + winSock.setsockopt = (int (PASCAL FAR *)(SOCKET s, int level, + int optname, const char FAR * optval, int optlen)) + GetProcAddress(winSock.hInstance, "setsockopt"); + winSock.shutdown = (int (PASCAL FAR *)(SOCKET s, int how)) + GetProcAddress(winSock.hInstance, "shutdown"); + winSock.socket = (SOCKET (PASCAL FAR *)(int af, int type, + int protocol)) GetProcAddress(winSock.hInstance, "socket"); + winSock.gethostbyaddr = (struct hostent FAR * (PASCAL FAR *) + (const char FAR *addr, int addrlen, int addrtype)) + GetProcAddress(winSock.hInstance, "gethostbyaddr"); + winSock.gethostbyname = (struct hostent FAR * (PASCAL FAR *) + (const char FAR *name)) + GetProcAddress(winSock.hInstance, "gethostbyname"); + winSock.gethostname = (int (PASCAL FAR *)(char FAR * name, + int namelen)) GetProcAddress(winSock.hInstance, "gethostname"); + winSock.getpeername = (int (PASCAL FAR *)(SOCKET sock, + struct sockaddr FAR *name, int FAR *namelen)) + GetProcAddress(winSock.hInstance, "getpeername"); + winSock.getservbyname = (struct servent FAR * (PASCAL FAR *) + (const char FAR * name, const char FAR * proto)) + GetProcAddress(winSock.hInstance, "getservbyname"); + winSock.getsockname = (int (PASCAL FAR *)(SOCKET sock, + struct sockaddr FAR *name, int FAR *namelen)) + GetProcAddress(winSock.hInstance, "getsockname"); + winSock.WSAStartup = (int (PASCAL FAR *)(WORD wVersionRequired, + LPWSADATA lpWSAData)) GetProcAddress(winSock.hInstance, "WSAStartup"); + winSock.WSACleanup = (int (PASCAL FAR *)(void)) + GetProcAddress(winSock.hInstance, "WSACleanup"); + winSock.WSAGetLastError = (int (PASCAL FAR *)(void)) + GetProcAddress(winSock.hInstance, "WSAGetLastError"); + winSock.WSAAsyncSelect = (int (PASCAL FAR *)(SOCKET s, HWND hWnd, + u_int wMsg, long lEvent)) + GetProcAddress(winSock.hInstance, "WSAAsyncSelect"); + + /* + * Now check that all fields are properly initialized. If not, return + * zero to indicate that we failed to initialize properly. + */ + + if ((winSock.hInstance == NULL) || + (winSock.accept == NULL) || + (winSock.bind == NULL) || + (winSock.closesocket == NULL) || + (winSock.connect == NULL) || + (winSock.ioctlsocket == NULL) || + (winSock.getsockopt == NULL) || + (winSock.htons == NULL) || + (winSock.inet_addr == NULL) || + (winSock.inet_ntoa == NULL) || + (winSock.listen == NULL) || + (winSock.ntohs == NULL) || + (winSock.recv == NULL) || + (winSock.select == NULL) || + (winSock.send == NULL) || + (winSock.setsockopt == NULL) || + (winSock.socket == NULL) || + (winSock.gethostbyname == NULL) || + (winSock.gethostbyaddr == NULL) || + (winSock.gethostname == NULL) || + (winSock.getpeername == NULL) || + (winSock.getservbyname == NULL) || + (winSock.getsockname == NULL) || + (winSock.WSAStartup == NULL) || + (winSock.WSACleanup == NULL) || + (winSock.WSAGetLastError == NULL) || + (winSock.WSAAsyncSelect == NULL)) { + goto unloadLibrary; + } + + + + /* + * Initialize the winsock library and check the version number. + */ + if ((*winSock.WSAStartup)(MAKEWORD(2,2), &wsaData) != 0) { + fprintf(stderr,"unloading"); + fflush(stderr); + goto unloadLibrary; + } +#ifdef WSA_VERSION_REQD + if (wsaData.wVersion != WSA_VERSION_REQD) { + (*winSock.WSACleanup)(); + goto unloadLibrary; + } +#endif + } + atexit(close_winsock); + + return; + + /* + * Check for per-thread initialization. + */ +unloadLibrary: + + FreeLibrary(winSock.hInstance); + winSock.hInstance = NULL; + return; +} + + + +/* + *---------------------------------------------------------------------- + * + * SocketsEnabled -- + * + * Check that the WinSock DLL is loaded and ready. + * + * Results: + * 1 if it is. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +SocketsEnabled() +{ + int enabled; + + enabled = (winSock.hInstance != NULL); + if (!enabled) { + InitSockets(); + enabled = (winSock.hInstance != NULL); + } + return enabled; +} + +static void close_winsock() +{ + if (winSock.hInstance != NULL) + (*winSock.WSACleanup)(); +} + + + +/* + *---------------------------------------------------------------------- + * + * CreateSocketAddress -- + * + * This function initializes a sockaddr structure for a host and port. + * + * Results: + * 1 if the host was valid, 0 if the host could not be converted to + * an IP address. + * + * Side effects: + * Fills in the *sockaddrPtr structure. + * + *---------------------------------------------------------------------- + */ + +static int +CreateSocketAddress(sockaddrPtr, host, port) + struct sockaddr_in *sockaddrPtr; /* Socket address */ + char *host; /* Host. NULL implies INADDR_ANY */ + int port; /* Port number */ +{ + struct hostent *hostent; /* Host database entry */ + struct in_addr addr; /* For 64/32 bit madness */ + + /* + * Check that WinSock is initialized; do not call it if not, to + * prevent system crashes. This can happen at exit time if the exit + * handler for WinSock ran before other exit handlers that want to + * use sockets. + */ + + if (!SocketsEnabled()) { + Tcl_SetErrno(EFAULT); + return 0; + } + + (void) memset((char *) sockaddrPtr, '\0', sizeof(struct sockaddr_in)); + sockaddrPtr->sin_family = AF_INET; + sockaddrPtr->sin_port = (*winSock.htons)((short) (port & 0xFFFF)); + if (host == NULL) { + addr.s_addr = INADDR_ANY; + } else { + addr.s_addr = (*winSock.inet_addr)(host); + if (addr.s_addr == INADDR_NONE) { + hostent = (*winSock.gethostbyname)(host); + if (hostent != NULL) { + memcpy((char *) &addr, + (char *) hostent->h_addr_list[0], + (size_t) hostent->h_length); + } else { +#ifdef EHOSTUNREACH + Tcl_SetErrno(EHOSTUNREACH); +#else +#ifdef ENXIO + Tcl_SetErrno(ENXIO); +#endif +#endif + return 0; /* Error. */ + } + } + } + + /* + * NOTE: On 64 bit machines the assignment below is rumored to not + * do the right thing. Please report errors related to this if you + * observe incorrect behavior on 64 bit machines such as DEC Alphas. + * Should we modify this code to do an explicit memcpy? + */ + + sockaddrPtr->sin_addr.s_addr = addr.s_addr; + return 1; /* Success. */ +} + +#ifdef DEBUG +static void myerr(char *s,int d) +{ + if (0) { + fprintf(stderr,s,d); + fflush(stderr); + } + +} +#else +#define myerr(a,b) +#endif + + + +/* + *---------------------------------------------------------------------- + * + * CreateSocket -- + * + * This function opens a new socket and initializes the + * return -1 on failure, or else an fd + * + *---------------------------------------------------------------------- + */ +static int myerror; +int +CreateSocket(port, host, server, myaddr, myport, async) + int port; /* Port number to open. */ + char *host; /* Name of host on which to open port. */ + int server; /* 1 if socket should be a server socket, + * else 0 for a client socket. */ + char *myaddr; /* Optional client-side address */ + int myport; /* Optional client-side port */ + int async; /* If nonzero, connect client socket + * asynchronously. */ +{ + u_long flag = 1; /* Indicates nonblocking mode. */ + int asyncConnect = 0; /* Will be 1 if async connect is + * in progress. */ + struct sockaddr_in sockaddr; /* Socket address */ + struct sockaddr_in mysockaddr; /* Socket address for client */ + SOCKET sock = 0; + + /* + * Check that WinSock is initialized; do not call it if not, to + * prevent system crashes. This can happen at exit time if the exit + * handler for WinSock ran before other exit handlers that want to + * use sockets. + */ + + if (!SocketsEnabled()) { + return -1; + } + + if (! CreateSocketAddress(&sockaddr, host, port)) { + goto error; + } + if ((myaddr != NULL || myport != 0) && + ! CreateSocketAddress(&mysockaddr, myaddr, myport)) { + goto error; + } + + sock = (*winSock.socket)(AF_INET, SOCK_STREAM, 0); + if (sock == INVALID_SOCKET) { + goto error; + } + + /* + * Win-NT has a misfeature that sockets are inherited in child + * processes by default. Turn off the inherit bit. + */ + + SetHandleInformation( (HANDLE) sock, HANDLE_FLAG_INHERIT, 0 ); + + /* + * Set kernel space buffering + */ + + /* TclSockMinimumBuffers(sock, TCP_BUFFER_SIZE); */ + + if (server) { + /* + * Bind to the specified port. Note that we must not call setsockopt + * with SO_REUSEADDR because Microsoft allows addresses to be reused + * even if they are still in use. + * + * Bind should not be affected by the socket having already been + * set into nonblocking mode. If there is trouble, this is one place + * to look for bugs. + */ + + if ((*winSock.bind)(sock, (struct sockaddr *) &sockaddr, + sizeof(sockaddr)) == SOCKET_ERROR) { + goto error; + } + + /* + * Set the maximum number of pending connect requests to the + * max value allowed on each platform (Win32 and Win32s may be + * different, and there may be differences between TCP/IP stacks). + */ + + if ((*winSock.listen)(sock, SOMAXCONN) == SOCKET_ERROR) { + goto error; + } + + + } else { + + /* + * Try to bind to a local port, if specified. + */ + + if (myaddr != NULL || myport != 0) { + if ((*winSock.bind)(sock, (struct sockaddr *) &mysockaddr, + sizeof(struct sockaddr)) == SOCKET_ERROR) { + goto error; + } + } + + /* + * Set the socket into nonblocking mode if the connect should be + * done in the background. + */ + + if (async) { + if ((*winSock.ioctlsocket)(sock, FIONBIO, &flag) == SOCKET_ERROR) { + goto error; + } + } + + /* + * Attempt to connect to the remote socket. + */ + + if ((*winSock.connect)(sock, (struct sockaddr *) &sockaddr, + sizeof(sockaddr)) == SOCKET_ERROR) { + myerror = (*winSock.WSAGetLastError)(); + if (myerror != WSAEWOULDBLOCK) { + goto error; + } + } + + /* + * The connection is progressing in the background. + */ + + asyncConnect = 1; + } + + + + /* + * Set up the select mask for read/write events. If the connect + * attempt has not completed, include connect events. + */ + + + + /* + * Register for interest in events in the select mask. Note that this + * automatically places the socket into non-blocking mode. + */ + + (*winSock.ioctlsocket)(sock, FIONBIO, &flag); + /* SendMessage(tsdPtr->hwnd, SOCKET_SELECT, + (WPARAM) SELECT, (LPARAM) infoPtr); + */ + + return sock; + +error: + /* TclWinConvertWSAError((*winSock.WSAGetLastError)()); + if (interp != NULL) { + Tcl_AppendResult(interp, "couldn't open socket: ", + Tcl_PosixError(interp), (char *) NULL); + } + */ + if (sock != INVALID_SOCKET) { + (*winSock.closesocket)(sock); + } + return -1; +} + + + +/* + *---------------------------------------------------------------------- + * + * TcpOutputProc -- + * + * This procedure is called by the generic IO level to write data + * to a socket based channel. + * + * Results: + * The number of bytes written or -1 on failure. + * + * Side effects: + * Produces output on the socket. + * + *---------------------------------------------------------------------- + */ + +int +TcpOutputProc ( int fd, char *buf, int toWrite, int *errorCodePtr, int block ) +{ + int bytesWritten=0; + int error; + int count=1000*30; + + *errorCodePtr = 0; + + /* + * Check that WinSock is initialized; do not call it if not, to + * prevent system crashes. This can happen at exit time if the exit + * handler for WinSock ran before other exit handlers that want to + * use sockets. + */ + + + if (!SocketsEnabled()) { + *errorCodePtr = EFAULT; + return -1; + } + + while (block) { + + AGAIN: + /* + * In the blocking case, wait until the file becomes writable + * or closed and try again. + */ + { fd_set writefds; + int res; + struct timeval timeout; + FD_ZERO(&writefds); + FD_SET(fd,&writefds); + timeout.tv_sec = (block == 0 ? 0 : 60*60*24*30); + timeout.tv_usec = 0; + if (!(res=(*winSock.select)(fd+1,NULL,&writefds,NULL,&timeout)) ) + { bytesWritten = -1; + + break; + } + } + + + + bytesWritten = (*winSock.send)(fd, buf, toWrite, 0); + if (bytesWritten != SOCKET_ERROR) { + /* + * Since Windows won't generate a new write event until we hit + * an overflow condition, we need to force the event loop to + * poll until the condition changes. + */ + break; + } + + /* + * Check for error condition or overflow. In the event of overflow, we + * need to clear the FD_WRITE flag so we can detect the next writable + * event. Note that Windows only sends a new writable event after a + * send fails with WSAEWOULDBLOCK. + */ + + error = (*winSock.WSAGetLastError)(); + + if (error == WSAEWOULDBLOCK) { + *errorCodePtr = EWOULDBLOCK; + CHECK_INTERRUPT; + Sleep(30); + bytesWritten = -1; + if (--count < 0) + break; + else goto AGAIN; + + } else { + /* TclWinConvertWSAError(error); */ + + *errorCodePtr = EINVAL; + bytesWritten = -1; + break; + } + + + } + return bytesWritten; +} + + + + +/* + getCharGclSocket(strm,block) -- get one character from a socket + stream. + Results: a character or EOF if at end of file + Side Effects: The buffer may be filled, and the fill pointer + of the buffer may be changed. + */ +int getCharGclSocket(strm,block) + object strm; + object block; +{ + object bufp = SOCKET_STREAM_BUFFER(strm); + if (!SocketsEnabled()) { + return -1; + } + if (bufp->ust.ust_fillp > 0) { + dprintf("getchar returns (%c)\n",bufp->ust.ust_self[-1+(bufp->ust.ust_fillp)]); + return bufp->ust.ust_self[--(bufp->ust.ust_fillp)]; + } + else { + fd_set readfds; + struct timeval timeout; + int fd = SOCKET_STREAM_FD(strm); + if (1) + { int high; + AGAIN: + /* under cygwin a too large timout like (1<<30) does not work */ + timeout.tv_sec = (block != Ct ? 0 : 0); + timeout.tv_usec = (block != Ct ? 0 : 10000); + FD_ZERO(&readfds); + FD_SET(fd,&readfds); + high = (*winSock.select)(fd+1,&readfds,NULL,NULL,&timeout); + if (high > 0) + { object bufp = SOCKET_STREAM_BUFFER(strm); + int n; + n = (*winSock.recv)(fd,bufp->st.st_self ,bufp->ust.ust_dim,0); + doReverse(bufp->st.st_self,n); + bufp->ust.ust_fillp=n; + if (n > 0) + { + return bufp->ust.ust_self[--(bufp->ust.ust_fillp)]; + } + else + { return EOF; + FEerror("select said there was stuff there but there was not",0); + } + } + CHECK_INTERRUPT; + /* probably a signal interrupted us.. */ + if (block == Ct) + goto AGAIN; + return EOF; + } + } +} + +void tcpCloseSocket(SOCKET fd) +{ + + (*winSock.closesocket)(fd); + +} + +void ungetCharGclSocket ( int c, object strm) +{ object bufp = SOCKET_STREAM_BUFFER(strm); + if (c == EOF) return; + dprintf("pushing back %c\n",c); + if (bufp->ust.ust_fillp < bufp->ust.ust_dim) { + bufp->ust.ust_self[(bufp->ust.ust_fillp)++]=c; + } else { + FEerror("Tried to unget too many chars",0); + } +} + +void doReverse ( char *s, int n ) +{ + char *p=&s[n-1]; + int m = n/2; + while (--m>=0) { + int tem = *s; + *s = *p; + *p = tem; + s++; p--; + } +} + + +/* +void +sigint() +{ + install_default_signals(); + terminal_interrupt(1); +} +*/ + +#if 0 +BOOL WINAPI inthandler(DWORD i) +{ + fprintf(stderr,"in handler %d",i); + fflush(stderr); + terminal_interrupt(1); + return TRUE; +} +#endif + + +void +alarm(int n) { + return; +} + + +/* to do: + + in the lisp: +start a shared named file based on the pid. +Then others will be able to send us messages, eg:interrupt! +and we will check this value in the CHECK_INTERRUPT +places.. + +Then a little program like test4 or test3 can change +the memory. + +*/ + +static struct { + + HANDLE handle; + LPVOID address; + DWORD length ; + char name[20] ; +} sharedMemory = {0,0,0x10000} ; + +void sigterm() +{ + exit(0); +} + +#ifdef SIGABRT +void sigabrt() +{ + exit(SIGABRT); +} +#endif + + +void sigkill() +{ + exit(SIGKILL); +} + + +static void +init_signals_pendingPtr() { + + static unsigned int where; + if (sharedMemory.address) { + signalsPendingPtr = sharedMemory.address; + } else { + signalsPendingPtr = (void *)&where; + } + gcl_signal(SIGKILL,sigkill); + gcl_signal(SIGTERM,sigterm); +#ifdef SIGABRT + gcl_signal(SIGABRT,sigabrt); +#endif + +} + +void +close_shared_memory() { + + if (sharedMemory.handle) + CloseHandle(sharedMemory.handle); + sharedMemory.handle = NULL; + if (sharedMemory.address) + UnmapViewOfFile(sharedMemory.address); + sharedMemory.address = NULL; + init_signals_pendingPtr(); + +} + +void +init_shared_memory (void) { + static int n; + + if (n) return; + n=1; + + sharedMemory.address=0; + init_signals_pendingPtr(); + return; + + sprintf(sharedMemory.name,"gcl-%d",getpid()); + sharedMemory.handle = + CreateFileMapping((HANDLE)-1,NULL,PAGE_READWRITE,0,sharedMemory.length ,TEXT(sharedMemory.name)); + if (sharedMemory.handle == NULL) + error("CreateFileMapping failed"); + sharedMemory.address = + MapViewOfFile(sharedMemory.handle, /* Handle to mapping object. */ + FILE_MAP_WRITE, /* Read/write permission */ + 0, /* Max. object size. */ + 0, /* Size of hFile. */ + 0); /* Map entire file. */ + if (sharedMemory.address == NULL) + error("MapViewOfFile failed"); + init_signals_pendingPtr(); + atexit(close_shared_memory); + +} + +/* The only signal REALLY handled somewhat under mingw is the + SIGINT, and we need to make the following allow blocking of this. + by for example taking the signal and then recording we got it, + but delivering it later in the unblock code time ... ie in the +*/ + +static sigset_t _current_set=0; +void +sigemptyset( sigset_t *set) +{ + *set = 0; +} +void +sigaddset( sigset_t *set, int n) +{ + *set |= (1 << n); +} + +int +sigismember ( sigset_t *set, int n) +{ + return ((*set & (1 << n)) != 0); + +} + +int +sigprocmask (int how , const sigset_t *set,sigset_t *oldset) + +{ + if (oldset) *oldset = _current_set; + if (set) { + switch (how) + { + case SIG_BLOCK: + _current_set |= *set; + break; + case SIG_UNBLOCK: + _current_set &= ~(*set); + break; + case SIG_SETMASK: + _current_set = *set; + break; + } + + } + return 0; +} + +void +fix_filename(object pathname, char *filename1) { + + char *filename=filename1,*p=filename; + extern char *getwd(); + + while (*p) { + if (*p=='\\') *p='/'; + p++; + } + +} + + +char *GCLExeName ( void ) +{ + static char module_name_buf[128]; + char *rv = NULL; + module_name_buf[0] = 0; + DWORD result = GetModuleFileName ( (HMODULE) NULL, (LPTSTR) &module_name_buf, 128 ); + if ( result != 0 ) { + rv = module_name_buf; + } + return ( (char *) rv ); +} diff --git a/o/multival.c b/o/multival.c new file mode 100755 index 0000000..8694cd7 --- /dev/null +++ b/o/multival.c @@ -0,0 +1,139 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +/* + + multival.c + + Multiple Values +*/ + +#include "include.h" + +LFD(Lvalues)(void) +{ + if (vs_base == vs_top) vs_base[0] = Cnil; +} + +LFD(Lvalues_list)(void) +{ + + object list; + + check_arg(1); + list = vs_base[0]; + vs_top = vs_base; + while (!endp_prop(list)) { + vs_push(MMcar(list)); + list = MMcdr(list); + } + if (vs_top == vs_base) vs_base[0] = Cnil; +} + +static void +FFN(Fmultiple_value_list)(object form) +{ + + object *top = vs_top; + + if (endp(form)) + FEtoo_few_argumentsF(form); + if (!endp(MMcdr(form))) + FEtoo_many_argumentsF(form); + vs_push(Cnil); + eval(MMcar(form)); + while (vs_base < vs_top) { + top[0] = MMcons(vs_top[-1],top[0]); + vs_top--; + } + vs_base = top; + vs_top = top+1; +} + +static void +FFN(Fmultiple_value_call)(object form) +{ + + object *top = vs_top; + object *top1; + object *top2; + + if (endp(form)) + FEtoo_few_argumentsF(form); + eval(MMcar(form)); + vs_top = top; + vs_push(vs_base[0]); + form = MMcdr(form); + while (!endp(form)) { + top1 = vs_top; + eval(MMcar(form)); + top2 = vs_top; + vs_top = top1; + while (vs_base < top2) { + vs_push(vs_base[0]); + vs_base++; + } + form = MMcdr(form); + } + vs_base = top+1; + super_funcall(top[0]); +} + +static void +FFN(Fmultiple_value_prog1)(object forms) +{ + + object *top; + object *base = vs_top; + + if (endp(forms)) + FEtoo_few_argumentsF(forms); + eval(MMcar(forms)); + top = vs_top; + vs_top=base; + while (vs_base < top) { + vs_push(vs_base[0]); + vs_base++; + } + top = vs_top; + forms = MMcdr(forms); + while (!endp(forms)) { + eval(MMcar(forms)); + vs_top = top; + forms = MMcdr(forms); + } + vs_base = base; + vs_top = top; + if (vs_base == vs_top) vs_base[0] = Cnil; +} + + +void +gcl_init_multival(void) +{ + make_constant("MULTIPLE-VALUES-LIMIT",make_fixnum(32)); + make_function("VALUES",Lvalues); + make_function("VALUES-LIST",Lvalues_list); + make_special_form("MULTIPLE-VALUE-CALL",Fmultiple_value_call); + make_special_form("MULTIPLE-VALUE-PROG1", + Fmultiple_value_prog1); + make_special_form("MULTIPLE-VALUE-LIST",Fmultiple_value_list); +} diff --git a/o/mych b/o/mych new file mode 100755 index 0000000..14663ca --- /dev/null +++ b/o/mych @@ -0,0 +1,60 @@ +from main.c +#else + kcl_self = find_executable(argv[0]); +#endif + + +#ifdef NeXT +#include +#include + + +static int +is_executable(fn) + char *fn; +{ + struct stat s; + + return stat (fn, &s) != -1 && (s.st_mode & S_IFMT) == S_IFREG + && access (fn, X_OK) != -1; +} + +char * +find_executable(fn) + char *fn; +{ + char *path, *getenv(); + static char buf[MAXPATHLEN+1]; + static char msg[100]; + register char *p; + + for (p = fn; *p; p++) { + if (*p == '/') { + if (is_executable (fn)) + return fn; + else { + sprintf(msg, "%s is not executable", fn); + error(msg); + } + } + } + if ((path = getenv ("PATH")) == 0) + error("PATH is undefined"); + do { + p = buf; + while (*path && *path != ':') + *p++ = *path++; + if (*path) + ++path; + if (p > buf) + *p++ = '/'; + strcpy (p, fn); + if (is_executable (buf)) + return buf; + } while (*path); + sprintf(msg, "cannot find pathname of %s", fn); + error(msg); +} +#endif + + diff --git a/o/ndiv.c b/o/ndiv.c new file mode 100755 index 0000000..5e95822 --- /dev/null +++ b/o/ndiv.c @@ -0,0 +1,118 @@ +/* + Copyright (C) 1994 W. Schelter + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +*/ + + +/* author: William F. Schelter + The following is an implementation of extended_div in C suitable + for a machine which can do 32 bit arithmetic. + The assembler output could be optimized, so that carry tests + were read from the condition codes +*/ + +#include "arith.h" + +/* #define ESTIMATE_LOG_QUOTIENT(x,l,d) estimate_logq(x,l,d) */ +#define ESTIMATE_LOG_QUOTIENT(x,l,d) 31 + +/* +int +estimate_logq(x,l,div) +unsigned int x,div,l; +{ unsigned int logq,w; + if (x==0) {w=0;x=l;} else {w=WSIZ;} + for(logq=0; logq < WSIZ ; logq+=1) + if ((div << logq) >= x) + break; + return 31; + return logq+w;} + +*/ + + +extended_div(divisor,dh,dl,q,r) +unsigned int dh,dl , divisor, *q, *r; +{ unsigned int Rh,Rl,temph,templ; + unsigned int Q; + int iter; +#ifdef DEBUG + char *op; +#endif + Rh=dh; + Rl=dl; + + /* if (dh) printf("\n(di %d %d %d ",divisor,dh,dl); */ + + NORMALIZE(Rh,Rl); + Q=0; + if (dh==0) + {*q=dl/divisor; *r=dl%divisor; + return;} +#ifdef DEBUG + printf("\n%d (Q %d %d) (R %d %d) %s" , -1,0,Q,Rh,Rl,"begin"); +#endif + for (iter=ESTIMATE_LOG_QUOTIENT(dh,dl,divisor); iter >=0 ; iter-= 1) + { + /* assert(Q*divisor+R ==dividend); */ + lshift(divisor,iter,temph,templ); + if ((int)Rh>=0) + {lsub(temph,templ,Rh,Rl); +#ifdef DEBUG + op="add"; +#endif + /* lshift(1,iter,temph,templ); + ladd(temph,templ,Qh,Ql); + */ + /* ladd(0,(1<s.s_gfdef ==0 */ +/* ) */ +/* fun_name = IisFboundp(fun_name); */ +/* if (fun_name->s.s_sfdef != NOT_SPECIAL || fun_name->s.s_mflag) */ +/* FEinvalid_function(fun_name); */ +/* fun = fun_name->s.s_gfdef; */ +/* if (Rset == 0 || */ +/* !( type_of(fun)==t_afun || type_of(fun)==t_closure)) */ +/* goto GENERAL; */ +/* fn = (void *) fun->sfn.sfn_self; */ +/* fargd = fun->sfn.sfn_argd; */ +/* if ( (F_ARG_FLAGS(fargd) & F_ARG_FLAGS(link_desk)) == F_ARG_FLAGS(fargd) */ +/* && F_MIN_ARGS(fargd) <= F_MIN_ARGS(link_desk) */ +/* && F_MAX_ARGS(fargd) >= F_MIN_ARGS(link_desk) */ +/* && F_TYPES(fargd) == F_TYPES(link_desk)) */ +/* { /\* do the link *\/ */ +/* (void) vpush_extend(link_loc,sLAlink_arrayA->s.s_dbind); */ +/* (void) vpush_extend(*link_loc,sLAlink_arrayA->s.s_dbind); */ +/* *link_loc = fn;} */ + /* make this call */ + + /* figure out the true number of args passed */ +/* nargs = (F_ARG_FLAGS_P(link_desk,F_requires_nargs) ? */ +/* F_NARGS(VFUN_NARGS) : F_NARGS(link_desk)); */ +/* {unsigned int atypes = (F_TYPES(link_desk) >> F_TYPE_WIDTH); */ +/* unsigned int ftypes = (F_TYPES(fargd) >> F_TYPE_WIDTH); */ +/* int i; */ +/* object *new ; */ +/* if (atypes==ftypes) */ +/* { */ +/* #ifdef MUST_COPY_VA_LIST */ +/* new = vec; */ +/* for (i=0; i < nargs ; i++) new[i] = va_arg(ap,object); */ +/* #else */ +/* new = (object *) ap; */ +/* #endif */ +/* } */ +/* else */ +/* { new = vec; */ +/* for (i = 0; i < nargs ; i++, atypes >>= F_TYPE_WIDTH, */ +/* ftypes >>= F_TYPE_WIDTH) */ +/* { int atyp = atypes & MASK_RANGE(0,F_TYPE_WIDTH); */ +/* int ftyp = ftypes & MASK_RANGE(0,F_TYPE_WIDTH); */ +/* object next = va_arg(ap,object); */ +/* new [i] = COERCE_F_TYPE(next, atyp ,ftyp); */ +/* }} */ +/* res = c_apply_n(fn,nargs,new); */ +/* { int lret_type = F_TYPES(link_desk) & MASK_RANGE(0,F_TYPE_WIDTH); */ +/* int fret_type = F_TYPES(fargd) & MASK_RANGE(0,F_TYPE_WIDTH); */ +/* return COERCE_F_TYPE(res,fret_type,lret_type); */ +/* }} */ + +/* GENERAL: */ + /* figure out the true number of args passed */ +/* nargs = (F_ARG_FLAGS_P(link_desk,F_requires_nargs) ? */ +/* F_NARGS(VFUN_NARGS) : F_NARGS(link_desk)); */ + +/* { int atypes,i,restype; */ +/* object res; */ +/* object *base = vs_top; */ +/* #define DEBUG */ +/* #ifdef DEBUG */ +/* bds_ptr oldbd = bds_top; */ +/* frame_ptr oldctl = frs_top; */ +/* #endif */ + +/* restype = F_RESULT_TYPE(link_desk); */ +/* atypes = F_TYPES(link_desk)>> F_TYPE_WIDTH; */ + +/* vs_top+= nargs; */ +/* for (i=0; i < nargs ; i++, atypes >>= F_TYPE_WIDTH) */ +/* { object next = va_arg(ap,object); */ +/* int atyp = atypes & MASK_RANGE(0,F_TYPE_WIDTH); */ +/* base[i] = COERCE_F_TYPE(next,atyp,F_object);} */ +/* res = IapplyVector(fun,nargs,base); */ +/* vs_top = base; */ +/* res = COERCE_F_TYPE(res,F_object,restype); */ +/* #ifdef DEBUG */ +/* if (oldctl != frs_top || oldbd != bds_top) */ +/* FEerror("compiler error ? ",0 ); */ +/* #endif */ +/* return res; */ +/* }} */ + +/* for making a link which calls a function returning a double + + */ + +/* static float */ +/* Icall_proc_float(object fun_name, int link_desk, object (**link_loc) (/\* ??? *\/), va_list ap) */ +/* { object val; */ +/* val = Icall_proc(fun_name,link_desk,link_loc,ap); */ +/* { union { void *p; */ +/* float f;} bil; */ +/* bil.p = val; */ +/* return bil.f;} */ +/* } */ + +#include "apply_n.h" + +object +IapplyVector(object fun, int nargs, object *base) + + +/* Call FUN a lisp object on NARGS which are loaded into an array + starting at BASE. This pushes on the CallHist, and puts the args onto + the arg stack, so that debuggers may examine them. It sets + fcall.nvalues appropriately. */ +{ object res,*abase; + int i; + object *oldtop = vs_top; + unsigned int atypes; + if (oldtop == base) vs_top += nargs; + else + { object *b = base; + int n = nargs; + base = vs_top; vs_top +=n; + while (--n>=0) { base[n] = b[n];}} + vs_check; + switch(type_of(fun)) { + case t_closure: + case t_afun: + ihs_push_base(fun,base); + ihs_check; + VFUN_NARGS=nargs; + fcall.fun = fun; + if (nargs < F_MIN_ARGS(fun->sfn.sfn_argd)) + FEtoo_few_arguments(base,vs_top); + if (nargs > F_MAX_ARGS(fun->sfn.sfn_argd) && F_MAX_ARGS(fun->sfn.sfn_argd)) + FEtoo_many_arguments(base,vs_top); + atypes = F_TYPES(fun->sfn.sfn_argd) >> F_TYPE_WIDTH; + if (atypes==0) {abase = base;} + else { abase = vs_top; + for (i=0; i < nargs ; i++, atypes >>= F_TYPE_WIDTH) + { object next = base[i]; + int atyp = atypes & MASK_RANGE(0,F_TYPE_WIDTH); + if (atyp == F_object) + next = next; + else if (atyp == F_int) + { ASSURE_TYPE(next,t_fixnum); + next = COERCE_F_TYPE(next,F_object,F_int);} + else if (atyp == F_shortfloat) + { ASSURE_TYPE(next,t_shortfloat); + next = COERCE_F_TYPE(next,F_object,F_shortfloat);} + else if (atyp == F_double_ptr) + { ASSURE_TYPE(next,t_longfloat); + next = COERCE_F_TYPE(next,F_object,F_double_ptr);} + else {FEerror("cant get here!",0);} + vs_push(next);} + + } + res = c_apply_n_fun(fun,nargs,abase); + res = COERCE_F_TYPE(res,F_RESULT_TYPE(fun->sfn.sfn_argd),F_object); + if (F_ARG_FLAGS_P(fun->sfn.sfn_argd,F_caller_sets_one_val)) + { fcall.nvalues = 1;} + vs_top = oldtop; + ihs_pop(); + return res; + break; + default: + vs_base = base; + funcall(fun); + fcall.nvalues = vs_top - vs_base; + {int i = fcall.nvalues ; + object *p = vs_top; + object *b = &fcall.values[i]; + vs_top = oldtop; + if (i == 0) + return sLnil; + while(--i > 0) *(--b) = *(--p);} + return vs_base[0]; + break; + } +} + +/* use the following to define functions passing on the value stack, + from ones on the C stack. +Laref() +{ +Iinvoke_c_function_from_value_stack(fLaref,F_ARGD(2,2,0,ARGTYPES(oo,io,oo,oo))); + return; +} + +*/ +void +Iinvoke_c_function_from_value_stack(object (*f)(), int fargd) +{ + int atypes = F_TYPES(fargd)>> F_TYPE_WIDTH; + object *base = vs_base; + int i; + int nargs = vs_top - vs_base; + + object x[64],res; + int min,max; + min = F_MIN_ARGS(fargd); + max = F_MAX_ARGS(fargd); + if (nargs < min || nargs > max) + { FEerror("Wrong number of args",0); + } + for (i=0; i < nargs ; i++, atypes >>= F_TYPE_WIDTH) + { object next = base[i]; + int atyp = atypes & MASK_RANGE(0,F_TYPE_WIDTH); + if (atyp == F_object) + x[i] = next; + else if (atyp == F_int) + { ASSURE_TYPE(next,t_fixnum); + x[i] = COERCE_F_TYPE(next,F_object,F_int);} + else if (atyp == F_shortfloat) + { ASSURE_TYPE(next,t_shortfloat); + x[i] = COERCE_F_TYPE(next,F_object,F_shortfloat);} + else if (atyp == F_double_ptr) + { ASSURE_TYPE(next,t_longfloat); + x[i] = COERCE_F_TYPE(next,F_object,F_double_ptr);} + else {FEerror("cant get here!",0);}} + VFUN_NARGS = nargs; + res = c_apply_n_f(f,nargs,x,min,max); + res = COERCE_F_TYPE(res,F_RESULT_TYPE(fargd),F_object); + base[0]=res; + if (F_ARG_FLAGS_P(fargd,F_caller_sets_one_val)) + { vs_top=base+ 1; + } + else + { vs_top=base + fcall.nvalues; + { int nn = fcall.nvalues; + while (--nn > 0) + { base[nn] = fcall.values[nn]; + } + } + } + vs_base=base; + return; +} + +#define TYPE_STRING(i) (i == F_object ? "object" : i == F_int ? "int" : i == F_double_ptr ? "double ptr" : "unknown") + +/* static int */ +/* print_fargd(int fargd) */ +/* { int i; */ +/* int nargs = 7; */ +/* unsigned int ftypes = (F_TYPES(fargd) >> F_TYPE_WIDTH); */ + +/* printf("minargs=%d,maxargs=%d, arg_types=(",F_MIN_ARGS(fargd), */ +/* F_MAX_ARGS(fargd)); */ +/* for (i = 0; i < F_MAX_ARGS(fargd) ; i++, ftypes >>= F_TYPE_WIDTH) */ +/* {int ftyp = ftypes & MASK_RANGE(0,F_TYPE_WIDTH); */ +/* printf(" %s,",TYPE_STRING(ftyp)); */ +/* if (i >= nargs) { printf("...object.."); break;} */ +/* } */ +/* printf(") result_type=%s\n",TYPE_STRING(F_RESULT_TYPE(fargd))); */ +/* fflush(stdout); */ +/* return 0; */ +/* } */ + + + diff --git a/o/nmul.c b/o/nmul.c new file mode 100755 index 0000000..e5ffe03 --- /dev/null +++ b/o/nmul.c @@ -0,0 +1,37 @@ +#include "arith.h" + +extended_mul(a,b,c,h,l) +unsigned int a,b,c, *h, *l; +{unsigned int temph,templ,ah,al,i; + ah=0; + al=0; + /* in case the shift by 32 does not zero an unsigned int.. + we separate out the first step.*/ + {if (b & 1) + {temph=0;templ=a; + ladd(temph,templ,ah,al);} +/* printf("\n%d b=%d a=%d (%d:%d)",i,b,a,ah,al); */ + b=b>>1; +} +i=1; + while(b) + {if (b & 1) + {lshift(a,i,temph,templ); + ladd(temph,templ,ah,al);} + i++;b=b>>1; + } + ladd(0,c,ah,al); + KCLNORMALIZE(ah,al); + *h=ah;*l=al; +} + +#ifndef VSSIZE +try(h,d, h1,l1, qp, rp) +unsigned int d, h, h1,l1,*qp, *rp; +{ +extended_mul (h,d,h1,qp,rp); +} +#endif + + + diff --git a/o/nsocket.c b/o/nsocket.c new file mode 100644 index 0000000..506f0ab --- /dev/null +++ b/o/nsocket.c @@ -0,0 +1,699 @@ +/* the following file compiles under win95 using cygwinb19 */ +#include +#include "include.h" +#include + +#ifdef DODEBUG +#define dprintf(s,arg) \ + do {fprintf(stderr,s,arg); \ + fflush(stderr); }\ + while(0) +#else +#define dprintf(s,arg) +#endif + +#ifdef HAVE_NSOCKET + + + +#include +#include +#include + +#include +#include +#include + + + +/************* for the sockets ******************/ +#include /* struct sockaddr, SOCK_STREAM, ... */ +#ifndef NO_UNAME +# include /* uname system call. */ +#endif +#include /* struct in_addr, struct sockaddr_in */ +#include /* inet_ntoa() */ +#include /* gethostbyname() */ + +/****************end for sockets *******************/ + + + +/* + * These bits may be ORed together into the "flags" field of a TcpState + * structure. + */ + + +#define TCP_ASYNC_SOCKET (1<<0) /* Asynchronous socket. */ +#define TCP_ASYNC_CONNECT (1<<1) /* Async connect in progress. */ + +/* + * The following defines the maximum length of the listen queue. This is + * the number of outstanding yet-to-be-serviced requests for a connection + * on a server socket, more than this number of outstanding requests and + * the connection request will fail. + */ + +#ifndef SOMAXCONN +#define SOMAXCONN 100 +#endif + +#if (SOMAXCONN < 100) +#undef SOMAXCONN +#define SOMAXCONN 100 +#endif + +#define VOID void +#define ERROR_MESSAGE(msg) do{ fprintf(stderr,msg); exit(1) ; } while(0) + +#ifdef STAND + +main(argc,argv) + char *argv[]; + int argc; +{ + char buf[1000]; + char out[1000]; + char op[10]; + int n,fd; + int x,y,ans,errno; + char *bp; + fd_set readfds; + struct timeval timeout; + + + bp = buf; + fd = doConnect(argv[1],atoi(argv[2])); + if (fd < 0) { + perror("cant connect"); + exit(1); + } + + while (1) { int high; + timeout.tv_sec = 20; + timeout.tv_usec = 0; + FD_ZERO(&readfds); + FD_SET(fd,&readfds); + + high = select(fd+1,&readfds,NULL,NULL,&timeout); + if (high > 0) + { + int n; + n = read(fd,buf,sizeof(buf)); + if (3 == sscanf(buf,"%d %s %d",&x,op,&y)) { + switch (op[0]) { + + case '+': sprintf(out,"%d\n",x+y); + break; + case '*': sprintf(out,"%d\n",x*y); + break; + default: + sprintf(out,"bad operation\n"); + } + write(fd,out,strlen(out)); + } + } + } +} + +#endif + + +/* + *---------------------------------------------------------------------- + * + * CreateSocketAddress -- + * + * This function initializes a sockaddr structure for a host and port. + * + * Results: + * 1 if the host was valid, 0 if the host could not be converted to + * an IP address. + * + * Side effects: + * Fills in the *sockaddrPtr structure. + * + *---------------------------------------------------------------------- + */ + +static int +CreateSocketAddress(struct sockaddr_in *sockaddrPtr, char *host, int port) + /* Socket address */ + /* Host. NULL implies INADDR_ANY */ + /* Port number */ +{ + struct hostent *hostent; /* Host database entry */ + struct in_addr addr; /* For 64/32 bit madness */ + + (void) memset((VOID *) sockaddrPtr, '\0', sizeof(struct sockaddr_in)); + sockaddrPtr->sin_family = AF_INET; + sockaddrPtr->sin_port = htons((unsigned short) (port & 0xFFFF)); + if (host == NULL) { + addr.s_addr = INADDR_ANY; + } else { + addr.s_addr = inet_addr(host); + if (addr.s_addr == -1) { + hostent = /* gethostbyname(host); */ +#ifdef STATIC_LINKING + NULL; +#else + gethostbyname(host); +#endif + if (hostent != NULL) { + memcpy((VOID *) &addr, + (VOID *) hostent->h_addr_list[0], + (size_t) hostent->h_length); + } else { +#ifdef EHOSTUNREACH + errno = EHOSTUNREACH; +#else +#ifdef ENXIO + errno = ENXIO; +#endif +#endif + return 0; /* error */ + } + } + } + + /* + * NOTE: On 64 bit machines the assignment below is rumored to not + * do the right thing. Please report errors related to this if you + * observe incorrect behavior on 64 bit machines such as DEC Alphas. + * Should we modify this code to do an explicit memcpy? + */ + + sockaddrPtr->sin_addr.s_addr = addr.s_addr; + return 1; /* Success. */ +} + + + +/* return -1 on failure, or else an fd */ +int +CreateSocket(int port, char *host, int server, char *myaddr, int myport, int async) + /* Port number to open. */ + /* Name of host on which to open port. + * NULL implies INADDR_ANY */ + /* 1 if socket should be a server socket, + * else 0 for a client socket. */ + /* Optional client-side address */ + /* Optional client-side port */ + /* If nonzero and creating a client socket, + * attempt to do an async connect. Otherwise + * do a synchronous connect or bind. */ +{ + int status, sock, asyncConnect, curState, origState; + struct sockaddr_in sockaddr; /* socket address */ + struct sockaddr_in mysockaddr; /* Socket address for client */ + + sock = -1; + origState = 0; + if (! CreateSocketAddress(&sockaddr, host, port)) { + goto addressError; + } + if ((myaddr != NULL || myport != 0) && + ! CreateSocketAddress(&mysockaddr, myaddr, myport)) { + goto addressError; + } + + sock = socket(AF_INET, SOCK_STREAM, 0); + if (sock < 0) { + goto addressError; + } + + /* + * Set the close-on-exec flag so that the socket will not get + * inherited by child processes. + */ + + fcntl(sock, F_SETFD, FD_CLOEXEC); + + asyncConnect = 0; + status = 0; + if (server) { + + /* + * Set up to reuse server addresses automatically and bind to the + * specified port. + */ + + status = 1; + (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR, (char *) &status, + sizeof(status)); + status = bind(sock, (struct sockaddr *) &sockaddr, + sizeof(struct sockaddr)); + if (status != -1) { + status = listen(sock, SOMAXCONN); + } + } else { + if (myaddr != NULL || myport != 0) { + curState = 1; + (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR, + (char *) &curState, sizeof(curState)); + status = bind(sock, (struct sockaddr *) &mysockaddr, + sizeof(struct sockaddr)); + if (status < 0) { + goto bindError; + } + } + + /* + * Attempt to connect. The connect may fail at present with an + * EINPROGRESS but at a later time it will complete. The caller + * will set up a file handler on the socket if she is interested in + * being informed when the connect completes. + */ + + if (async) { +#ifndef USE_FIONBIO + origState = fcntl(sock, F_GETFL); + curState = origState | O_NONBLOCK; + status = fcntl(sock, F_SETFL, curState); +#endif + +#ifdef USE_FIONBIO + curState = 1; + status = ioctl(sock, FIONBIO, &curState); +#endif + } else { + status = 0; + } + if (status > -1) { + status = connect(sock, (struct sockaddr *) &sockaddr, + sizeof(sockaddr)); + if (status < 0) { + if (errno == EINPROGRESS) { + asyncConnect = 1; + status = 0; + } + } + } + } + +bindError: + if (status < 0) { + + ERROR_MESSAGE("couldn't open socket:"); + + if (sock != -1) { + close(sock); + } + return -1; + } + + return sock; + +addressError: + if (sock != -1) { + close(sock); + } + + ERROR_MESSAGE("couldn't open socket:"); + + return -1; +} + + +#ifdef STAND +int +doConnect(host,port) + char *host; /*name of host we are trying to connect to */ + int port; /* port number to use */ +{ + return CreateSocket(port, host, 0 , NULL , 0 , 0); +} +#endif + + + +#define SOCKET_FD(strm) ((strm)->sm.sm_fp ? fileno((strm)->sm.sm_fp) : -1) + +static void +check_socket(object x) +{ + + if (type_of(x) != t_stream || x->sm.sm_mode != smm_socket) + FEwrong_type_argument(sSsocket,x); + +} + +DEFUN_NEW("GETPEERNAME",object,fSgetpeername,SI,1,1,NONE,OO,OO,OO,OO,(object sock), + "Return a list of three elements: the address, the hostname and the port for the other end of the socket. If hostname is not available it will be equal to the address. Invalid on server sockets. Return NIL on failure.") +{ + struct sockaddr_in peername; + socklen_t size = sizeof(struct sockaddr_in); + struct hostent *hostEntPtr; + object address,host; + check_socket(sock); + if (getpeername(SOCKET_FD(sock), (struct sockaddr *) &peername, &size) + >= 0) { + address=make_simple_string(inet_ntoa(peername.sin_addr)); + hostEntPtr = /* gethostbyaddr((char *) &(peername.sin_addr), */ + /* sizeof(peername.sin_addr), AF_INET); */ +#ifdef STATIC_LINKING + NULL; +#else + gethostbyaddr((char *) &(peername.sin_addr), + sizeof(peername.sin_addr), AF_INET); +#endif + + if (hostEntPtr != (struct hostent *) NULL) + host = make_simple_string(hostEntPtr->h_name); + else host = address; + return list(3,address,host,make_fixnum(ntohs(peername.sin_port))); + } else { + return Cnil; + } +} + + +DEFUN_NEW("GETSOCKNAME",object,fSgetsockname,SI,1,1,NONE,OO,OO,OO,OO,(object sock), + "Return a list of three elements: the address, the hostname and the port for the socket. If hostname is not available it will be equal to the address. Return NIL on failure. ") +{ struct sockaddr_in sockname; + socklen_t size = sizeof(struct sockaddr_in); + struct hostent *hostEntPtr; + object address,host; + + check_socket(sock); + if (getsockname(SOCKET_FD(sock), (struct sockaddr *) &sockname, &size) + >= 0) { + address= make_simple_string(inet_ntoa(sockname.sin_addr)); + hostEntPtr = /* gethostbyaddr((char *) &(sockname.sin_addr), */ + /* sizeof(sockname.sin_addr), AF_INET); */ +#ifdef STATIC_LINKING + NULL; +#else + gethostbyaddr((char *) &(sockname.sin_addr), + sizeof(sockname.sin_addr), AF_INET); +#endif + if (hostEntPtr != (struct hostent *) NULL) + host = make_simple_string(hostEntPtr->h_name); + else host=address; + return list(3,address,host,make_fixnum(ntohs(sockname.sin_port))); + } else { + return Cnil; + } +} + +/* + TcpBlocking -- + Use on a tcp socket to alter the blocking or non blocking. + Results 0 if succeeds and errno if fails. + + Side effects: + the channel is setto blocking or nonblocking mode. +*/ + +DEFUN_NEW("SET-BLOCKING",object,fSset_blocking,SI,2,2,NONE,OO,OO,OO,OO,(object sock,object setBlocking), + "Set blocking on if MODE is T otherwise off. Return 0 if succeeds. Otherwise the error number.") +{ + int setting; + int fd ; + AGAIN: + check_stream(sock); + /* set our idea of whether blocking on or off + setBlocking==Cnil <==> blocking turned off. */ + SET_STREAM_FLAG(sock,gcl_sm_tcp_async,setBlocking==Cnil); + if (sock->sm.sm_mode == smm_two_way) { + /* check for case they are sock streams and so + share the same fd */ + if (STREAM_INPUT_STREAM(sock)->sm.sm_fp != NULL + &&STREAM_OUTPUT_STREAM(sock)->sm.sm_fp != NULL + && (SOCKET_FD(STREAM_INPUT_STREAM(sock))== + SOCKET_FD(STREAM_OUTPUT_STREAM(sock)))) + { + SET_STREAM_FLAG(STREAM_OUTPUT_STREAM(sock), + gcl_sm_tcp_async,setBlocking==Cnil); + sock = STREAM_INPUT_STREAM(sock); + /* they share an 'fd' and so only do one. */ + goto AGAIN; + } + else + { + int x1 = fix(FFN(fSset_blocking)(STREAM_INPUT_STREAM(sock),setBlocking)); + int x2 = fix(FFN(fSset_blocking)(STREAM_OUTPUT_STREAM(sock),setBlocking)); + /* if either is negative result return negative. (ie fail) + If either is positive return positive (ie fail) + Zero result means both ok. (ie succeed) + */ + + return make_fixnum((x1 < 0 || x2 < 0 ? -2 : x1 > 0 ? x1 : x2)); + } + } + + if (sock->sm.sm_fp == NULL) + return make_fixnum(-2); + fd = SOCKET_FD(sock); + + +#ifndef USE_FIONBIO + setting = fcntl(fd, F_GETFL); + if (setBlocking != Cnil) { + setting &= (~(O_NONBLOCK)); + } else { + setting |= O_NONBLOCK; + } + if (fcntl(fd, F_SETFL, setting) < 0) { + return make_fixnum(errno); + } +#endif + +#ifdef USE_FIONBIO + if (setBlocking != Cnil) { + setting = 0; + if (ioctl(fd, (int) FIONBIO, &setting) == -1) { + return make_fixnum(errno); + } + } else { + setting = 1; + if (ioctl(fd, (int) FIONBIO, &setting) == -1) { + return make_fixnum(errno); + } + } +#endif + return make_fixnum(0); +} + +/* with 2 args return the function if any. +*/ + +/*setHandler(stream,readable,function) + object stream; stream to watch + object readable; keyword readable,writable + object function; the handler function to be invoked with arg stream +{ + +} +*/ +/* goes through the streams does a select with 0 timeout, and invokes + any handlers */ +/* +update () +{ + +} +*/ + +static int +joe(int x) { return x; } + +/* + get a character from FP but block, if it would return + the EOF, but the stream is not closed. +*/ +int +getOneChar(FILE *fp) +{ + fd_set readfds; + struct timeval timeout; + int fd= fileno(fp); + int high; + /* fprintf(stderr,"",fp); + fflush(stderr); */ + fprintf(stderr,"in getOneChar, fd=%d,fp=%p",fd,fp); + fflush(stderr); + if (fd == 0) + { joe(fd); + return -1; + } + + while (1) { + timeout.tv_sec = 0; + timeout.tv_usec = 200000; + FD_ZERO(&readfds); + FD_SET(fd,&readfds); + CHECK_INTERRUPT; + high = select(fd+1,&readfds,NULL,NULL,&timeout); + if (high > 0) + { + int ch ; + fprintf(stderr,"in getOneChar, fd=%d,fp=%p",fd,fp); + fflush(stderr); + ch = getc(fp); + if ( ch != EOF || feof(fp) ) { + /* fprintf(stderr,"< 0x%x returning %d,%c>\n",fp,ch,ch); + fflush(stderr); + */ + } + fprintf(stderr,"in getOneChar, ch= %c,%d\n",ch,ch); + fflush(stderr); + CHECK_INTERRUPT; + if (ch != EOF) return ch; + if (feof(fp)) return EOF; + } + + } +} + +#ifdef DODEBUG +#define dprintf(s,arg) \ + do {fprintf(stderr,s,arg); \ + fflush(stderr); }\ + while(0) +#else +#define dprintf(s,arg) +#endif + +void +ungetCharGclSocket(int c, object strm) + /* the character to unget */ + /* stream */ +{ object bufp = SOCKET_STREAM_BUFFER(strm); + if (c == EOF) return; + dprintf("pushing back %c\n",c); + if (bufp->ust.ust_fillp < bufp->ust.ust_dim) { + bufp->ust.ust_self[(bufp->ust.ust_fillp)++]=c; + } else { + FEerror("Tried to unget too many chars",0); + } +} + + +/* + *---------------------------------------------------------------------- + * + * TcpOutputProc -- + * + * This procedure is invoked by the generic IO level to write output + * to a TCP socket based channel. + * + * NOTE: We cannot share code with FilePipeOutputProc because here + * we must use send, not write, to get reliable error reporting. + * + * Results: + * The number of bytes written is returned. An output argument is + * set to a POSIX error code if an error occurred, or zero. + * + * Side effects: + * Writes output on the output device of the channel. + * + *---------------------------------------------------------------------- + */ + +int +TcpOutputProc(int fd, char *buf, int toWrite, int *errorCodePtr) + /* Socket state. */ + /* The data buffer. */ + /* How many bytes to write? */ + /* Where to store error code. */ +{ + int written; + + *errorCodePtr = 0; + written = send(fd, buf, (size_t) toWrite, 0); + if (written > -1) { + return written; + } + *errorCodePtr = errno; + return -1; +} + +void +tcpCloseSocket(int fd) +{ + close(fd); + +} + +static void +doReverse(char *s, int n) +{ char *p=&s[n-1]; + int m = n/2; + while (--m>=0) { + int tem = *s; + *s = *p; + *p = tem; + s++; p--; + } +} + + + +/* + getCharGclSocket(strm,block) -- get one character from a socket + stream. + Results: a character or EOF if at end of file + Side Effects: The buffer may be filled, and the fill pointer + of the buffer may be changed. + */ +int +getCharGclSocket(object strm, object block) +{ + object bufp = SOCKET_STREAM_BUFFER(strm); + if (bufp->ust.ust_fillp > 0) { + dprintf("getchar returns (%c)\n",bufp->ust.ust_self[-1+(bufp->ust.ust_fillp)]); + return bufp->ust.ust_self[--(bufp->ust.ust_fillp)]; + } + else { + fd_set readfds; + struct timeval timeout; + int fd = SOCKET_STREAM_FD(strm); + if (1) + { int high; + AGAIN: + /* under cygwin a too large timout like (1<<30) does not work */ + timeout.tv_sec = (block != Ct ? 0 : 0); + timeout.tv_usec = 10000; + FD_ZERO(&readfds); + FD_SET(fd,&readfds); + high = select(fd+1,&readfds,NULL,NULL,&timeout); + if (high > 0) + { object bufp = SOCKET_STREAM_BUFFER(strm); + int n; + n = SAFE_READ(fd,bufp->st.st_self ,bufp->ust.ust_dim); + doReverse(bufp->st.st_self,n); + bufp->ust.ust_fillp=n; + if (n > 0) + { + dprintf("getchar returns (%c)\n",bufp->ust.ust_self[-1+(bufp->ust.ust_fillp)]); + return bufp->ust.ust_self[--(bufp->ust.ust_fillp)]; + } + else + { + SOCKET_STREAM_FD(strm)=-1; + return EOF; + FEerror("select said there was stuff there but there was not",0); + } + } + /* probably a signal interrupted us.. */ + if (block == Ct) + goto AGAIN; + return EOF; + } + } +} + +#else +int +getOneChar(fp) + FILE *fp; +{ + return getc(fp); +} + +#endif + + + diff --git a/o/ntheap.h b/o/ntheap.h new file mode 100755 index 0000000..f7c5e36 --- /dev/null +++ b/o/ntheap.h @@ -0,0 +1,117 @@ +/* Heap management routines (including unexec) for GNU Emacs on Windows NT. + Copyright (C) 1994 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. + + Geoff Voelker (voelker@cs.washington.edu) 7-29-94 +*/ + +#ifndef NTHEAP_H_ +#define NTHEAP_H_ + +#include + +/* + * Heap related stuff. + */ +#define get_reserved_heap_size() reserved_heap_size +#define get_committed_heap_size() (get_data_end () - get_data_start ()) +#define get_heap_start() get_data_start () +#define get_heap_end() get_data_end () +#define get_page_size() sysinfo_cache.dwPageSize +#define get_allocation_unit() sysinfo_cache.dwAllocationGranularity +#define get_processor_type() sysinfo_cache.dwProcessorType +#define get_nt_major_version() nt_major_version +#define get_nt_minor_version() nt_minor_version + +extern unsigned char *get_data_start(); +extern unsigned char *get_data_end(); +extern unsigned long data_region_size; +extern unsigned long reserved_heap_size; +extern SYSTEM_INFO sysinfo_cache; +extern int nt_major_version; +extern int nt_minor_version; + +/* To prevent zero-initialized variables from being placed into the bss + section, use non-zero values to represent an uninitialized state. */ +#define UNINIT_PTR ((void *) 0xF0A0F0A0) +#define UNINIT_LONG (0xF0A0F0A0L) + +enum { + OS_WIN95 = 1, + OS_NT +}; + +extern int os_subtype; + +/* Emulation of Unix sbrk(). */ +extern void *sbrk (ptrdiff_t size); + +/* Recreate the heap created during dumping. */ +extern void recreate_heap (char *executable_path); + +/* Round the heap to this size. */ +extern void round_heap (unsigned long size); + +/* Load in the dumped .bss section. */ +extern void read_in_bss (char *name); + +/* Map in the dumped heap. */ +extern void map_in_heap (char *name); + +/* Cache system info, e.g., the NT page size. */ +extern void cache_system_info (void); + +/* Round ADDRESS up to be aligned with ALIGN. */ +extern unsigned char *round_to_next (unsigned char *address, + unsigned long align); + +/* ----------------------------------------------------------------- */ +/* Useful routines for manipulating memory-mapped files. */ + +typedef struct file_data { + char *name; + unsigned long size; + HANDLE file; + HANDLE file_mapping; + unsigned char *file_base; +} file_data; + +#define OFFSET_TO_RVA(var,section) \ + (section->VirtualAddress + ((DWORD)(var) - section->PointerToRawData)) + +#define RVA_TO_OFFSET(var,section) \ + (section->PointerToRawData + ((DWORD)(var) - section->VirtualAddress)) + +#define RVA_TO_PTR(var,section,filedata) \ + ((void *)(RVA_TO_OFFSET(var,section) + (filedata).file_base)) + +int open_input_file (file_data *p_file, char *name); +int open_output_file (file_data *p_file, char *name, unsigned long size); +void close_file_data (file_data *p_file); + +unsigned long get_section_size (PIMAGE_SECTION_HEADER p_section); + +/* Return pointer to section header for named section. */ +IMAGE_SECTION_HEADER * find_section (char * name, IMAGE_NT_HEADERS * nt_header); + +/* Return pointer to section header for section containing the given + relative virtual address. */ +IMAGE_SECTION_HEADER * rva_to_section (DWORD rva, IMAGE_NT_HEADERS * nt_header); + +#endif /* NTHEAP_H_ */ diff --git a/o/num_arith.c b/o/num_arith.c new file mode 100755 index 0000000..7eabfc3 --- /dev/null +++ b/o/num_arith.c @@ -0,0 +1,1040 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +/* + Arithmetic operations +*/ +#define NEED_MP_H +#include "include.h" + +#include "num_include.h" + +void +zero_divisor(void); + +object fixnum_add(fixnum i, fixnum j) +{ + + if (i>=0) + { if (j<= (MOST_POSITIVE_FIX-i)) + { return make_fixnum(i+j); + } + MPOP(return,addss,i,j); + } else { /* i < 0 */ + if ((MOST_NEGATIVE_FIX -i) <= j) { + return make_fixnum(i+j); + } + MPOP(return,addss,i,j); + } +} +/* return i - j */ +object fixnum_sub(fixnum i, fixnum j) +{ + + if (i>=0) + { if (j >= (i - MOST_POSITIVE_FIX)) + { return make_fixnum(i-j); + } + MPOP(return,subss,i,j); + } else { /* i < 0 */ + if ((MOST_NEGATIVE_FIX -i) <= -j) { + return make_fixnum(i-j); + } + MPOP(return,subss,i,j); + } +} + +inline object +fixnum_times(fixnum i, fixnum j) { + +#ifdef HAVE_CLZL + if (i!=MOST_NEGATIVE_FIX && j!=MOST_NEGATIVE_FIX && fixnum_mul_safe(i,j)) +#else + if (i>=0 ? (j>=0 ? (!i || j<= (MOST_POSITIVE_FIX/i)) : (j==-1 || i<= (MOST_NEGATIVE_FIX/j))) : + (j>=0 ? (i==-1 || j<= (MOST_NEGATIVE_FIX/i)) : (i>MOST_NEGATIVE_FIX && -i<= (MOST_POSITIVE_FIX/-j)))) +#endif + return make_fixnum(i*j); + else + MPOP(return,mulss,i,j); +} + + +static object +number_to_complex(object x) +{ + object z; + + switch (type_of(x)) { + + case t_fixnum: + case t_bignum: + case t_ratio: + case t_shortfloat: + case t_longfloat: + z = alloc_object(t_complex); + z->cmp.cmp_real = x; + z->cmp.cmp_imag = small_fixnum(0); + return(z); + + case t_complex: + return(x); + + default: + FEwrong_type_argument(sLnumber, x); + return(Cnil); + } +} + +object +number_plus(object x, object y) +{ + double dx, dy; + object z; + switch (type_of(x)) { + case t_fixnum: + switch(type_of(y)) { + case t_fixnum: + return fixnum_add(fix(x),fix(y)); + case t_bignum: + MPOP(return, addsi,fix(x),MP(y)); + case t_ratio: + z = number_plus(number_times(x, y->rat.rat_den), + y->rat.rat_num); + return make_ratio(z, y->rat.rat_den); + case t_shortfloat: + dx = (double)(fix(x)); + dy = (double)(sf(y)); + goto SHORTFLOAT; + case t_longfloat: + dx = (double)(fix(x)); + dy = lf(y); + goto LONGFLOAT; + case t_complex: + goto COMPLEX; + default: + FEwrong_type_argument(sLnumber, y); + } + + case t_bignum: + switch (type_of(y)) { + case t_fixnum: + MPOP(return,addsi,fix(y),MP(x)); + case t_bignum: + MPOP(return,addii,MP(y),MP(x)); + case t_ratio: + z = number_plus(number_times(x, y->rat.rat_den), y->rat.rat_num); + return make_ratio(z, y->rat.rat_den); + case t_shortfloat: + dx = number_to_double(x); + dy = (double)(sf(y)); + goto SHORTFLOAT; + case t_longfloat: + dx = number_to_double(x); + dy = lf(y); + goto LONGFLOAT; + case t_complex: + goto COMPLEX; + default: + FEwrong_type_argument(sLnumber, y); + } + + case t_ratio: + switch (type_of(y)) { + case t_fixnum: + case t_bignum: + + z = number_plus(x->rat.rat_num, + number_times(x->rat.rat_den, y)); + z = make_ratio(z, x->rat.rat_den); + return(z); + case t_ratio: + + z = number_plus(number_times(x->rat.rat_num,y->rat.rat_den), + number_times(x->rat.rat_den,y->rat.rat_num)); + z = make_ratio(z,number_times(x->rat.rat_den,y->rat.rat_den)); + return(z); + case t_shortfloat: + dx = number_to_double(x); + dy = (double)(sf(y)); + goto SHORTFLOAT; + case t_longfloat: + dx = number_to_double(x); + dy = lf(y); + goto LONGFLOAT; + case t_complex: + goto COMPLEX; + default: + FEwrong_type_argument(sLnumber, y); + } + + case t_shortfloat: + switch (type_of(y)) { + case t_fixnum: + dx = (double)(sf(x)); + dy = (double)(fix(y)); + goto SHORTFLOAT; + case t_shortfloat: + dx = (double)(sf(x)); + dy = (double)(sf(y)); + goto SHORTFLOAT; + case t_longfloat: + dx = (double)(sf(x)); + dy = lf(y); + goto LONGFLOAT; + case t_complex: + goto COMPLEX; + default: + dx = (double)(sf(x)); + dy = number_to_double(y); + goto SHORTFLOAT; + } + SHORTFLOAT: + z = alloc_object(t_shortfloat); + sf(z) = (shortfloat)(dx + dy); + return(z); + + case t_longfloat: + dx = lf(x); + switch (type_of(y)) { + case t_fixnum: + dy = (double)(fix(y)); + goto LONGFLOAT; + case t_shortfloat: + dy = (double)(sf(y)); + goto LONGFLOAT; + case t_longfloat: + dy = lf(y); + goto LONGFLOAT; + case t_complex: + goto COMPLEX; + default: + dy = number_to_double(y); + goto LONGFLOAT; + } + LONGFLOAT: + z = alloc_object(t_longfloat); + lf(z) = dx + dy; + return(z); + + case t_complex: + COMPLEX: + x = number_to_complex(x); + y = number_to_complex(y); + z = make_complex(number_plus(x->cmp.cmp_real, y->cmp.cmp_real), + number_plus(x->cmp.cmp_imag, y->cmp.cmp_imag)); + return(z); + + default: + FEwrong_type_argument(sLnumber, x); + return(Cnil); + } +} + +object +one_plus(object x) +{ + double dx; + object z; + + + switch (type_of(x)) { + + case t_fixnum: + return fixnum_add(fix(x),1); + case t_bignum: + MPOP(return,addsi,1,MP(x)); + case t_ratio: + z = number_plus(x->rat.rat_num, x->rat.rat_den); + z = make_ratio(z, x->rat.rat_den); + return(z); + + case t_shortfloat: + dx = (double)(sf(x)); + z = alloc_object(t_shortfloat); + sf(z) = (shortfloat)(dx + 1.0); + return(z); + + case t_longfloat: + dx = lf(x); + z = alloc_object(t_longfloat); + lf(z) = dx + 1.0; + return(z); + + case t_complex: + z = make_complex(one_plus(x->cmp.cmp_real), x->cmp.cmp_imag); + return(z); + + default: + FEwrong_type_argument(sLnumber, x); + return(Cnil); + } +} + +object +number_minus(object x, object y) +{ + double dx, dy; + object z; + + + switch (type_of(x)) { + + case t_fixnum: + switch(type_of(y)) { + case t_fixnum: + return fixnum_sub(fix(x),fix(y)); + /* MPOP(return,subss,fix(x),fix(y)); */ + case t_bignum: + MPOP(return, subsi,fix(x),MP(y)); + case t_ratio: + z = number_minus(number_times(x, y->rat.rat_den), y->rat.rat_num); + z = make_ratio(z, y->rat.rat_den); + return(z); + case t_shortfloat: + dx = (double)(fix(x)); + dy = (double)(sf(y)); + goto SHORTFLOAT; + case t_longfloat: + dx = (double)(fix(x)); + dy = lf(y); + goto LONGFLOAT; + case t_complex: + goto COMPLEX; + default: + FEwrong_type_argument(sLnumber, y); + } + + case t_bignum: + switch (type_of(y)) { + case t_fixnum: + MPOP(return,subis,MP(x),fix(y)); + case t_bignum: + MPOP(return,subii,MP(x),MP(y)); + case t_ratio: + z = number_minus(number_times(x, y->rat.rat_den), y->rat.rat_num); + z = make_ratio(z, y->rat.rat_den); + return(z); + case t_shortfloat: + dx = number_to_double(x); + dy = (double)(sf(y)); + goto SHORTFLOAT; + case t_longfloat: + dx = number_to_double(x); + dy = lf(y); + goto LONGFLOAT; + case t_complex: + goto COMPLEX; + default: + FEwrong_type_argument(sLnumber, y); + } + + case t_ratio: + switch (type_of(y)) { + case t_fixnum: + case t_bignum: + z = number_minus(x->rat.rat_num, number_times(x->rat.rat_den, y)); + z = make_ratio(z, x->rat.rat_den); + return(z); + case t_ratio: + z = number_minus(number_times(x->rat.rat_num,y->rat.rat_den), + (number_times(x->rat.rat_den,y->rat.rat_num))); + z = make_ratio(z,number_times(x->rat.rat_den,y->rat.rat_den)); + return(z); + case t_shortfloat: + dx = number_to_double(x); + dy = (double)(sf(y)); + goto SHORTFLOAT; + case t_longfloat: + dx = number_to_double(x); + dy = lf(y); + goto LONGFLOAT; + case t_complex: + goto COMPLEX; + default: + FEwrong_type_argument(sLnumber, y); + } + + case t_shortfloat: + switch (type_of(y)) { + case t_fixnum: + dx = (double)(sf(x)); + dy = (double)(fix(y)); + goto SHORTFLOAT; + case t_shortfloat: + dx = (double)(sf(x)); + dy = (double)(sf(y)); + goto SHORTFLOAT; + case t_longfloat: + dx = (double)(sf(x)); + dy = lf(y); + goto LONGFLOAT; + case t_complex: + goto COMPLEX; + default: + dx = (double)(sf(x)); + dy = number_to_double(y); + goto SHORTFLOAT; + } + SHORTFLOAT: + z = alloc_object(t_shortfloat); + sf(z) = (shortfloat)(dx - dy); + return(z); + + case t_longfloat: + dx = lf(x); + switch (type_of(y)) { + case t_fixnum: + dy = (double)(fix(y)); + goto LONGFLOAT; + case t_shortfloat: + dy = (double)(sf(y)); + goto LONGFLOAT; + case t_longfloat: + dy = lf(y); + goto LONGFLOAT; + case t_complex: + goto COMPLEX; + default: + dy = number_to_double(y); + } + LONGFLOAT: + z = alloc_object(t_longfloat); + lf(z) = dx - dy; + return(z); + + case t_complex: + COMPLEX: + x = number_to_complex(x); + y = number_to_complex(y); + z = make_complex(number_minus(x->cmp.cmp_real, y->cmp.cmp_real), + number_minus(x->cmp.cmp_imag, y->cmp.cmp_imag)); + return(z); + + default: + FEwrong_type_argument(sLnumber, x); + return(Cnil); + } +} + +object +one_minus(object x) +{ + double dx; + object z; + switch (type_of(x)) { + + case t_fixnum: + return fixnum_sub(fix(x),1); + case t_bignum: + MPOP(return,addsi,-1,MP(x)); + case t_ratio: + z = number_minus(x->rat.rat_num, x->rat.rat_den); + z = make_ratio(z, x->rat.rat_den); + return(z); + + case t_shortfloat: + dx = (double)(sf(x)); + z = alloc_object(t_shortfloat); + sf(z) = (shortfloat)(dx - 1.0); + return(z); + + case t_longfloat: + dx = lf(x); + z = alloc_object(t_longfloat); + lf(z) = dx - 1.0; + return(z); + + case t_complex: + z = make_complex(one_minus(x->cmp.cmp_real), x->cmp.cmp_imag); + return(z); + + default: + FEwrong_type_argument(sLnumber, x); + return(Cnil); + } +} + +object +number_negate(object x) +{ + object z, z1; + + switch (type_of(x)) { + + case t_fixnum: + if(fix(x) == MOST_NEGATIVE_FIX) + return fixnum_add(1,MOST_POSITIVE_FIX); + else + return(make_fixnum(-fix(x))); + case t_bignum: + return big_minus(x); + case t_ratio: + z1 = number_negate(x->rat.rat_num); + z = alloc_object(t_ratio); + z->rat.rat_num = z1; + z->rat.rat_den = x->rat.rat_den; + return(z); + + case t_shortfloat: + z = alloc_object(t_shortfloat); + sf(z) = -sf(x); + return(z); + + case t_longfloat: + z = alloc_object(t_longfloat); + lf(z) = -lf(x); + return(z); + + case t_complex: + z = make_complex(number_negate(x->cmp.cmp_real), + number_negate(x->cmp.cmp_imag)); + return(z); + + default: + FEwrong_type_argument(sLnumber, x); + return(Cnil); + } +} + +object +number_times(object x, object y) +{ + object z; + double dx, dy; + + switch (type_of(x)) { + + case t_fixnum: + switch (type_of(y)) { + case t_fixnum: + return fixnum_times(fix(x),fix(y)); + /* MPOP(return,mulss,fix(x),fix(y)); */ + case t_bignum: + MPOP(return,mulsi,fix(x),MP(y)); + case t_ratio: + z = make_ratio(number_times(x, y->rat.rat_num), y->rat.rat_den); + return(z); + case t_shortfloat: + dx = (double)(fix(x)); + dy = (double)(sf(y)); + goto SHORTFLOAT; + case t_longfloat: + dx = (double)(fix(x)); + dy = lf(y); + goto LONGFLOAT; + case t_complex: + goto COMPLEX; + default: + FEwrong_type_argument(sLnumber, y); + } + + case t_bignum: + switch (type_of(y)) { + case t_fixnum: + MPOP(return,mulsi,fix(y),MP(x)); + case t_bignum: + MPOP(return,mulii,MP(y),MP(x)); + case t_ratio: + z = make_ratio(number_times(x, y->rat.rat_num), y->rat.rat_den); + return(z); + case t_shortfloat: + dx = number_to_double(x); + dy = (double)(sf(y)); + goto SHORTFLOAT; + case t_longfloat: + dx = number_to_double(x); + dy = lf(y); + goto LONGFLOAT; + case t_complex: + goto COMPLEX; + default: + FEwrong_type_argument(sLnumber, y); + } + + case t_ratio: + switch (type_of(y)) { + case t_fixnum: + case t_bignum: + z = make_ratio(number_times(x->rat.rat_num, y), x->rat.rat_den); + return(z); + case t_ratio: + z = make_ratio(number_times(x->rat.rat_num,y->rat.rat_num), + number_times(x->rat.rat_den,y->rat.rat_den)); + return(z); + case t_shortfloat: + dx = number_to_double(x); + dy = (double)(sf(y)); + goto SHORTFLOAT; + case t_longfloat: + dx = number_to_double(x); + dy = lf(y); + goto LONGFLOAT; + case t_complex: + goto COMPLEX; + default: + FEwrong_type_argument(sLnumber, y); + } + + case t_shortfloat: + switch (type_of(y)) { + case t_fixnum: + dx = (double)(sf(x)); + dy = (double)(fix(y)); + goto SHORTFLOAT; + case t_shortfloat: + dx = (double)(sf(x)); + dy = (double)(sf(y)); + goto SHORTFLOAT; + case t_longfloat: + dx = (double)(sf(x)); + dy = lf(y); + goto LONGFLOAT; + case t_complex: + goto COMPLEX; + default: + dx = (double)(sf(x)); + dy = number_to_double(y); + break; + } + SHORTFLOAT: + z = alloc_object(t_shortfloat); + sf(z) = (shortfloat)(dx * dy); + return(z); + + case t_longfloat: + dx = lf(x); + switch (type_of(y)) { + case t_fixnum: + dy = (double)(fix(y)); + goto LONGFLOAT; + case t_shortfloat: + dy = (double)(sf(y)); + goto LONGFLOAT; + case t_longfloat: + dy = lf(y); + goto LONGFLOAT; + case t_complex: + goto COMPLEX; + default: + dy = number_to_double(y); + } + LONGFLOAT: + z = alloc_object(t_longfloat); + lf(z) = dx * dy; + return(z); + + case t_complex: + COMPLEX: + { + object z1, z2, z11, z12, z21, z22; + + x = number_to_complex(x); + y = number_to_complex(y); + z11 = number_times(x->cmp.cmp_real, y->cmp.cmp_real); + z12 = number_times(x->cmp.cmp_imag, y->cmp.cmp_imag); + z21 = number_times(x->cmp.cmp_imag, y->cmp.cmp_real); + z22 = number_times(x->cmp.cmp_real, y->cmp.cmp_imag); + z1 = number_minus(z11, z12); + z2 = number_plus(z21, z22); + z = make_complex(z1, z2); + return(z); + } + + default: + FEwrong_type_argument(sLnumber, x); + return(Cnil); + } +} + +object +number_divide(object x, object y) +{ + object z; + double dx, dy; + + switch (type_of(x)) { + + case t_fixnum: + case t_bignum: + switch (type_of(y)) { + case t_fixnum: + case t_bignum: + if(number_zerop(y) == TRUE) + zero_divisor(); + if (number_minusp(y) == TRUE) { + x = number_negate(x); + y = number_negate(y); + } + z = make_ratio(x, y); + return(z); + case t_ratio: + if(number_zerop(y->rat.rat_num)) + zero_divisor(); + z = make_ratio(number_times(x, y->rat.rat_den), y->rat.rat_num); + return(z); + case t_shortfloat: + dx = number_to_double(x); + dy = (double)(sf(y)); + goto SHORTFLOAT; + case t_longfloat: + dx = number_to_double(x); + dy = lf(y); + goto LONGFLOAT; + case t_complex: + goto COMPLEX; + default: + FEwrong_type_argument(sLnumber, y); + } + + case t_ratio: + switch (type_of(y)) { + case t_fixnum: + case t_bignum: + if (number_zerop(y)) + zero_divisor(); + z = make_ratio(x->rat.rat_num, number_times(x->rat.rat_den, y)); + return(z); + case t_ratio: + z = make_ratio(number_times(x->rat.rat_num,y->rat.rat_den), + number_times(x->rat.rat_den,y->rat.rat_num)); + return(z); + case t_shortfloat: + dx = number_to_double(x); + dy = (double)(sf(y)); + goto SHORTFLOAT; + case t_longfloat: + dx = number_to_double(x); + dy = lf(y); + goto LONGFLOAT; + case t_complex: + goto COMPLEX; + default: + FEwrong_type_argument(sLnumber, y); + } + + case t_shortfloat: + switch (type_of(y)) { + case t_fixnum: + dx = (double)(sf(x)); + dy = (double)(fix(y)); + goto SHORTFLOAT; + case t_shortfloat: + dx = (double)(sf(x)); + dy = (double)(sf(y)); + goto SHORTFLOAT; + case t_longfloat: + dx = (double)(sf(x)); + dy = lf(y); + goto LONGFLOAT; + case t_complex: + goto COMPLEX; + default: + dx = (double)(sf(x)); + dy = number_to_double(y); + goto LONGFLOAT; + } + SHORTFLOAT: + z = alloc_object(t_shortfloat); + if (dy == 0.0) + zero_divisor(); + sf(z) = (shortfloat)(dx / dy); + return(z); + + + case t_longfloat: + dx = lf(x); + switch (type_of(y)) { + case t_fixnum: + dy = (double)(fix(y)); + goto LONGFLOAT; + case t_shortfloat: + dy = (double)(sf(y)); + goto LONGFLOAT; + case t_longfloat: + dy = lf(y); + goto LONGFLOAT; + case t_complex: + goto COMPLEX; + default: + dy = number_to_double(y); + } + LONGFLOAT: + z = alloc_object(t_longfloat); + if (dy == 0.0) + zero_divisor(); + lf(z) = dx / dy; + return(z); + + case t_complex: + COMPLEX: + { + object z1, z2, z3; + + x = number_to_complex(x); + y = number_to_complex(y); + z1 = number_times(y->cmp.cmp_real, y->cmp.cmp_real); + z2 = number_times(y->cmp.cmp_imag, y->cmp.cmp_imag); + if (number_zerop(z3 = number_plus(z1, z2))) + zero_divisor(); + z1 = number_times(x->cmp.cmp_real, y->cmp.cmp_real); + z2 = number_times(x->cmp.cmp_imag, y->cmp.cmp_imag); + z1 = number_plus(z1, z2); + z = number_times(x->cmp.cmp_imag, y->cmp.cmp_real); + z2 = number_times(x->cmp.cmp_real, y->cmp.cmp_imag); + z2 = number_minus(z, z2); + z1 = number_divide(z1, z3); + z2 = number_divide(z2, z3); + z = make_complex(z1, z2); + return(z); + } + + default: + FEwrong_type_argument(sLnumber, x); + return(Cnil); + } +} + +object +integer_divide1(object x, object y,fixnum d) { + object q; + + integer_quotient_remainder_1(x, y, &q, NULL,d); + return(q); + +} + +object +integer_divide2(object x, object y,fixnum d,object *r) { + object q; + + integer_quotient_remainder_1(x, y, &q, r,d); + return(q); + +} + +object +get_gcd_abs(object x,object y) { + + object r; + + for (;;) { + + if (type_of(x) == t_fixnum && type_of(y) == t_fixnum) + return make_fixnum(fixnum_gcd(fix(x),fix(y))); + + if (number_compare(x, y) < 0) { + r = x; + x = y; + y = r; + } + if (type_of(y) == t_fixnum && fix(y) == 0) + return(x); + + integer_quotient_remainder_1(x, y, NULL, &r,0); + x = y; + y = r; + + } + +} + + +object +get_gcd(object x, object y) { + + return get_gcd_abs(number_abs(x),number_abs(y)); + +} + +LFD(Lplus)(void) +{ + fixnum i, j; + + j = vs_top - vs_base; + if (j == 0) { + vs_push(small_fixnum(0)); + return; + } + for (i = 0; i < j; i++) + check_type_number(&vs_base[i]); + for (i = 1; i < j; i++) + vs_base[0] = number_plus(vs_base[0], vs_base[i]); + vs_top = vs_base+1; +} + +LFD(Lminus)(void) +{ + fixnum i, j; + + j = vs_top - vs_base; + if (j == 0) + too_few_arguments(); + for (i = 0; i < j ; i++) + check_type_number(&vs_base[i]); + if (j == 1) { + vs_base[0] = number_negate(vs_base[0]); + return; + } + for (i = 1; i < j; i++) + vs_base[0] = number_minus(vs_base[0], vs_base[i]); + vs_top = vs_base+1; +} + +LFD(Ltimes)(void) +{ + fixnum i, j; + + j = vs_top - vs_base; + if (j == 0) { + vs_push(small_fixnum(1)); + return; + } + for (i = 0; i < j; i++) + check_type_number(&vs_base[i]); + for (i = 1; i < j; i++) + vs_base[0] = number_times(vs_base[0], vs_base[i]); + vs_top = vs_base+1; +} + +LFD(Ldivide)(void) +{ + fixnum i, j; + + j = vs_top - vs_base; + if (j == 0) + too_few_arguments(); + for(i = 0; i < j; i++) + check_type_number(&vs_base[i]); + if (j == 1) { + vs_base[0] = number_divide(small_fixnum(1), vs_base[0]); + return; + } + for (i = 1; i < j; i++) + vs_base[0] = number_divide(vs_base[0], vs_base[i]); + vs_top = vs_base+1; +} + +LFD(Lone_plus)(void) +{ + + check_arg(1); + check_type_number(&vs_base[0]); + vs_base[0] = one_plus(vs_base[0]); +} + +LFD(Lone_minus)(void) +{ + + check_arg(1); + check_type_number(&vs_base[0]); + vs_base[0] = one_minus(vs_base[0]); +} + +LFD(Lconjugate)(void) +{ + object c, i; + + check_arg(1); + check_type_number(&vs_base[0]); + c = vs_base[0]; + if (type_of(c) == t_complex) { + i = number_negate(c->cmp.cmp_imag); + vs_push(i); + vs_base[0] = make_complex(c->cmp.cmp_real, i); + vs_popp; + } +} + +LFD(Lgcd)(void) { + + fixnum i, narg=vs_top-vs_base; + + if (narg == 0) { + vs_push(small_fixnum(0)); + return; + } + + for (i = 0; i < narg; i++) + check_type_integer(&vs_base[i]); + + vs_top=vs_base; + vs_push(number_abs(vs_base[0])); + + for (i = 1; i < narg; i++) + vs_base[0] = get_gcd_abs(vs_base[0], number_abs(vs_base[i])); + +} + +object +get_lcm_abs(object x,object y) { + + object g=get_gcd_abs(x,y); + + return number_zerop(g) ? g : number_times(x,integer_divide1(y,g,0)); + +} + +object +get_lcm(object x,object y) { + + return get_lcm_abs(number_abs(x),number_abs(y)); + +} + +LFD(Llcm)(void) { + + fixnum i, narg; + + narg = vs_top - vs_base; + + if (narg == 0) + too_few_arguments(); + + for (i = 0; i < narg; i++) + check_type_integer(&vs_base[i]); + + vs_top=vs_base; + vs_push(number_abs(vs_base[0])); + + for (i=1;i> 20) - 1022 - 53; + h = ((h & 0x000fffff) | 0x00100000); + } else { + *ep = ((h & 0x7fe00000) >> 20) - 1022 - 53 + 1; + h = (h & 0x001fffff); + } + if (32-BIG_RADIX) + /* shift for making bignum */ + { h = h << (32-BIG_RADIX) ; + h |= ((l & (-1 << (32-BIG_RADIX))) >> (32-BIG_RADIX)); + l &= ~(-1 << (32-BIG_RADIX)); + } + *hp = h; + *lp = l; + *sp = (d > 0.0 ? 1 : -1); +} + +static void +integer_decode_float(double d, int *mp, int *ep, int *sp) +{ + float f; + int m; + union {float f;int i;} u; + + f = d; + if (f == 0.0) { + *mp = 0; + *ep = 0; + *sp = 1; + return; + } + u.f=f; + m=u.i; +/* m = *(int *)(&f); */ + if (ISNORMAL(f)) { + *ep = ((m & 0x7f800000) >> 23) - 126 - 24; + *mp = (m & 0x007fffff) | 0x00800000; + } else { + *ep = ((m & 0x7f000000) >> 23) - 126 - 24 + 1; + *mp = m & 0x00ffffff; + } + *sp = (f > 0.0 ? 1 : -1); +} + +static int +double_exponent(double d) +{ + union {double d;int i[2];} u; + + if (d == 0.0) + return(0); + u.d=d; + return (((u.i[HIND] & 0x7ff00000) >> 20) - 1022); +} + +static double +set_exponent(double d, int e) +{ + union {double d;int i[2];} u; + + if (d == 0.0) + return(0.0); + + u.d=d; + u.i[HIND]= (u.i[HIND] & 0x800fffff) | (((e + 1022) << 20) & 0x7ff00000); + return(u.d); +} + + +object +double_to_integer(double d) { + + int h, l, e, s; + object x; + vs_mark; + + if (d == 0.0) + return(small_fixnum(0)); + integer_decode_double(d, &h, &l, &e, &s); + + if (e <= -BIG_RADIX) { + e = (-e) - BIG_RADIX; + if (e >= BIG_RADIX) + return(small_fixnum(0)); + h >>= e; + return(make_fixnum(s*h)); + } + if (h != 0 || l<0) + x = bignum2(h, l); + else + x = make_fixnum(l); + vs_push(x); + x = integer_fix_shift(x, e); + if (s < 0) { + vs_push(x); + x = number_negate(x); + } + vs_reset; + return(x); +} + +static object +num_remainder(object x, object y, object q) +{ + object z; + + z = number_times(q, y); + vs_push(z); + z = number_minus(x, z); + vs_popp; + return(z); +} + +/* Coerce X to single-float if one arg, + otherwise coerce to same float type as second arg */ + +LFD(Lfloat)(void) +{ + double d; + int narg; + object x; + enum type t=t_longfloat; + + narg = vs_top - vs_base; + if (narg < 1) + too_few_arguments(); + else if (narg > 2) + too_many_arguments(); + if (narg == 2) { + check_type_float(&vs_base[1]); + t = type_of(vs_base[1]); + } + x = vs_base[0]; + switch (type_of(x)) { + case t_fixnum: + if (narg > 1 && t == t_shortfloat) + x = make_shortfloat((shortfloat)(fix(x))); + else + x = make_longfloat((double)(fix(x))); + break; + + case t_bignum: + case t_ratio: + d = number_to_double(x); + if (narg > 1 && t == t_shortfloat) + x = make_shortfloat((shortfloat)d); + else + x = make_longfloat(d); + break; + + case t_shortfloat: + if (narg > 1 && t == t_shortfloat); + else + x = make_longfloat((double)(sf(x))); + break; + + case t_longfloat: + if (narg > 1 && t == t_shortfloat) + x = make_shortfloat((shortfloat)(lf(x))); + break; + + default: + FEwrong_type_argument(TSor_rational_float, x); + } + vs_base = vs_top; + vs_push(x); +} + +LFD(Lnumerator)(void) +{ + check_arg(1); + check_type_rational(&vs_base[0]); + if (type_of(vs_base[0]) == t_ratio) + vs_base[0] = vs_base[0]->rat.rat_num; +} + +LFD(Ldenominator)(void) +{ + check_arg(1); + check_type_rational(&vs_base[0]); + if (type_of(vs_base[0]) == t_ratio) + vs_base[0] = vs_base[0]->rat.rat_den; + else + vs_base[0] = small_fixnum(1); +} + +inline void +intdivrem(object x,object y,fixnum d,object *q,object *r) { + + enum type tx=type_of(x),ty=type_of(y); + object z,q2,q1; + + if (number_zerop(y)==TRUE) + zero_divisor(); + + switch(tx) { + case t_fixnum: + case t_bignum: + switch (ty) { + case t_fixnum: + case t_bignum: + integer_quotient_remainder_1(x,y,q,r,d); + return; + case t_ratio: + z=integer_divide1(number_times(y->rat.rat_den,x),y->rat.rat_num,d); + if (q) *q=z; + if (r) *r=num_remainder(x,y,z); + return; + default: + break; + } + break; + case t_ratio: + switch (ty) { + case t_fixnum: + case t_bignum: + z=integer_divide1(x->rat.rat_num,number_times(x->rat.rat_den,y),d); + if (q) *q=z; + if (r) *r=num_remainder(x,y,z); + return; + case t_ratio: + z=integer_divide1(number_times(x->rat.rat_num,y->rat.rat_den),number_times(x->rat.rat_den,y->rat.rat_num),d); + if (q) *q=z; + if (r) *r=num_remainder(x,y,z); + return; + default: + break; + } + break; + default: + break; + } + + q2=number_divide(x,y); + q1=double_to_integer(number_to_double(q2)); + if (d && (d<0 ? number_minusp(q2) : number_plusp(q2)) && number_compare(q2, q1)) + q1 = d<0 ? one_minus(q1) : one_plus(q1); + if (q) *q=q1; + if (r) *r=num_remainder(x,y,q1); + return; + +} + +object +number_ldb(object x,object y) { + return ifuncall2(sLldb,x,y); +} + +object +number_ldbt(object x,object y) { + return ifuncall2(sLldb_test,x,y); +} + +object +number_dpb(object x,object y,object z) { + return ifuncall3(sLdpb,x,y,z); +} + +object +number_dpf(object x,object y,object z) { + return ifuncall3(sLdeposit_field,x,y,z); +} + + +LFD(Lfloor)(void) { + + object x, y; + int n = vs_top - vs_base; + + if (n == 0) + too_few_arguments(); + if (n > 2) + too_many_arguments(); + + x = vs_base[0]; + y = n>1 ? vs_base[1] : small_fixnum(1); + + intdivrem(x,y,-1,&x,&y); + + vs_top=vs_base; + vs_push(x); + vs_push(y); + +} + +LFD(Lceiling)(void) { + + object x, y; + int n = vs_top - vs_base; + + if (n == 0) + too_few_arguments(); + if (n > 2) + too_many_arguments(); + + x = vs_base[0]; + y = n>1 ? vs_base[1] : small_fixnum(1); + + intdivrem(x,y,1,&x,&y); + + vs_top=vs_base; + vs_push(x); + vs_push(y); + +} + +LFD(Ltruncate)(void) { + + object x, y; + int n = vs_top - vs_base; + + if (n == 0) + too_few_arguments(); + if (n > 2) + too_many_arguments(); + + x = vs_base[0]; + y = n>1 ? vs_base[1] : small_fixnum(1); + + intdivrem(x,y,0,&x,&y); + + vs_top=vs_base; + vs_push(x); + vs_push(y); + +} + +LFD(Lround)(void) +{ + object x, y, q, q1, r; + double d; + int n, c; + object one_plus(object x), one_minus(object x); + + n = vs_top - vs_base; + if (n == 0) + too_few_arguments(); + if (n > 1) + goto TWO_ARG; + x = vs_base[0]; + switch (type_of(x)) { + + case t_fixnum: + case t_bignum: + vs_push(small_fixnum(0)); + return; + + case t_ratio: + q = x; + y = small_fixnum(1); + goto RATIO; + + case t_shortfloat: + d = (double)(sf(x)); + if (d >= 0.0) + q = double_to_integer(d + 0.5); + else + q = double_to_integer(d - 0.5); + d -= number_to_double(q); + if (d == 0.5 && number_oddp(q)) { + vs_push(q); + q = one_plus(q); + d = -0.5; + } + if (d == -0.5 && number_oddp(q)) { + vs_push(q); + q = one_minus(q); + d = 0.5; + } + vs_base = vs_top; + vs_push(q); + vs_push(make_shortfloat((shortfloat)d)); + return; + + case t_longfloat: + d = lf(x); + if (d >= 0.0) + q = double_to_integer(d + 0.5); + else + q = double_to_integer(d - 0.5); + d -= number_to_double(q); + if (d == 0.5 && number_oddp(q)) { + vs_push(q); + q = one_plus(q); + d = -0.5; + } + if (d == -0.5 && number_oddp(q)) { + vs_push(q); + q = one_minus(q); + d = 0.5; + } + vs_base = vs_top; + vs_push(q); + vs_push(make_longfloat(d)); + return; + + default: + FEwrong_type_argument(TSor_rational_float, x); + } + +TWO_ARG: + if (n > 2) + too_many_arguments(); + x = vs_base[0]; + y = vs_base[1]; + check_type_or_rational_float(&vs_base[0]); + check_type_or_rational_float(&vs_base[1]); + q = number_divide(x, y); + vs_push(q); + switch (type_of(q)) { + case t_fixnum: + case t_bignum: + vs_base = vs_top; + vs_push(q); + vs_push(small_fixnum(0)); + break; + + case t_ratio: + RATIO: + q1 = integer_divide1(q->rat.rat_num, q->rat.rat_den,0);/*FIXME*/ + vs_push(q1); + r = number_minus(q, q1); + vs_push(r); + if ((c = number_compare(r, plus_half)) > 0 || + (c == 0 && number_oddp(q1))) + q1 = one_plus(q1); + if ((c = number_compare(r, minus_half)) < 0 || + (c == 0 && number_oddp(q1))) + q1 = one_minus(q1); + vs_base = vs_top; + vs_push(q1); + vs_push(num_remainder(x, y, q1)); + return; + + case t_shortfloat: + case t_longfloat: + d = number_to_double(q); + if (d >= 0.0) + q1 = double_to_integer(d + 0.5); + else + q1 = double_to_integer(d - 0.5); + d -= number_to_double(q1); + if (d == 0.5 && number_oddp(q1)) { + vs_push(q1); + q1 = one_plus(q1); + } + if (d == -0.5 && number_oddp(q1)) { + vs_push(q1); + q1 = one_minus(q1); + } + vs_base = vs_top; + vs_push(q1); + vs_push(num_remainder(x, y, q1)); + return; + default: + break; + } +} + + +LFD(Lmod)(void) { + check_arg(2); + intdivrem(vs_base[0],vs_base[1],-1,NULL,vs_base); + vs_top=vs_base+1; +} + + +LFD(Lrem)(void) { + check_arg(2); + intdivrem(vs_base[0],vs_base[1],0,NULL,vs_base); + vs_top=vs_base+1; +} + + +LFD(Ldecode_float)(void) +{ + object x; + double d; + int e, s; + + check_arg(1); + check_type_float(&vs_base[0]); + x = vs_base[0]; + if (type_of(x) == t_shortfloat) + d = sf(x); + else + d = lf(x); + if (d >= 0.0) + s = 1; + else { + d = -d; + s = -1; + } + e=0; + if (!ISNORMAL(d)) { + int hp,lp,sp; + + integer_decode_double(d,&hp,&lp,&e,&sp); + if (hp!=0 || lp<0) + d=number_to_double(bignum2(hp, lp)); + else + d=lp; + } + e += double_exponent(d); + d = set_exponent(d, 0); + vs_top = vs_base; + if (type_of(x) == t_shortfloat) { + vs_push(make_shortfloat((shortfloat)d)); + vs_push(make_fixnum(e)); + vs_push(make_shortfloat((shortfloat)s)); + } else { + vs_push(make_longfloat(d)); + vs_push(make_fixnum(e)); + vs_push(make_longfloat((double)s)); + } +} + +LFD(Lscale_float)(void) +{ + object x; + double d; + int e, k=0; + + check_arg(2); + check_type_float(&vs_base[0]); + x = vs_base[0]; + if (type_of(vs_base[1]) == t_fixnum) + k = fix(vs_base[1]); + else + FEerror("~S is an illegal exponent.", 1, vs_base[1]); + if (type_of(x) == t_shortfloat) + d = sf(x); + else + d = lf(x); + e = double_exponent(d) + k; +#ifdef VAX + if (e <= -128 || e >= 128) +#endif +#ifdef IBMRT + +#endif +#ifdef IEEEFLOAT + /* Upper bound not needed, handled by floating point overflow */ + /* this checks if we're in the denormalized range */ + if (!ISNORMAL(d) || (type_of(x) == t_shortfloat && e <= -126/* || e >= 130 */) || + (type_of(x) == t_longfloat && (e <= -1022 /* || e >= 1026 */))) +#endif +#ifdef MV + +#endif +#ifdef S3000 + if (e < -64 || e >= 64) +#endif +/* FEerror("~S is an illegal exponent.", 1, vs_base[1]); */ + { + for (;k>0;d*=2.0,k--); + for (;k<0;d*=0.5,k++); + } + else + d = set_exponent(d, e); + vs_popp; + if (type_of(x) == t_shortfloat) + vs_base[0] = make_shortfloat((shortfloat)d); + else + vs_base[0] = make_longfloat(d); +} + +LFD(Lfloat_radix)(void) +{ + check_arg(1); + check_type_float(&vs_base[0]); +#ifdef VAX + vs_base[0] = small_fixnum(2); +#endif +#ifdef IBMRT + +#endif +#ifdef IEEEFLOAT + vs_base[0] = small_fixnum(2); +#endif +#ifdef MV + +#endif +#ifdef S3000 + vs_base[0] = small_fixnum(16); +#endif +} + +LFD(Lfloat_sign)(void) +{ + object x; + int narg; + double d, f; + + narg = vs_top - vs_base; + if (narg < 1) + too_few_arguments(); + else if (narg > 2) + too_many_arguments(); + check_type_float(&vs_base[0]); + x = vs_base[0]; + if (type_of(x) == t_shortfloat) + d = sf(x); + else + d = lf(x); + if (narg == 1) + f = 1.0; + else { + check_type_float(&vs_base[1]); + x = vs_base[1]; + if (type_of(x) == t_shortfloat) + f = sf(x); + else + f = lf(x); + if (f < 0.0) + f = -f; + } + if (d < 0.0) + f = -f; + vs_top = vs_base; + if (type_of(x) == t_shortfloat) + vs_push(make_shortfloat((shortfloat)f)); + else + vs_push(make_longfloat(f)); +} + +LFD(Lfloat_digits)(void) +{ + check_arg(1); + check_type_float(&vs_base[0]); + if (type_of(vs_base[0]) == t_shortfloat) + vs_base[0] = small_fixnum(24); + else + vs_base[0] = small_fixnum(53); +} + +LFD(Lfloat_precision)(void) +{ + object x; + + check_arg(1); + check_type_float(&vs_base[0]); + x = vs_base[0]; + if (type_of(x) == t_shortfloat) + if (sf(x) == 0.0) + vs_base[0] = small_fixnum(0); + else + vs_base[0] = small_fixnum(24); + else + if (lf(x) == 0.0) + vs_base[0] = small_fixnum(0); + else +#ifdef VAX + vs_base[0] = small_fixnum(53); +#endif +#ifdef IBMRT + +#endif +#ifdef IEEEFLOAT + vs_base[0] = small_fixnum(53); +#endif +#ifdef MV + +#endif +#ifdef S3000 + vs_base[0] = small_fixnum(53); +#endif +} + +LFD(Linteger_decode_float)(void) +{ + object x; + int h, l, e, s; + + check_arg(1); + check_type_float(&vs_base[0]); + x = vs_base[0]; + vs_base = vs_top; + if (type_of(x) == t_longfloat) { + integer_decode_double(lf(x), &h, &l, &e, &s); + if (h != 0 || l<0) + vs_push(bignum2(h, l)); + else + vs_push(make_fixnum(l)); + vs_push(make_fixnum(e)); + vs_push(make_fixnum(s)); + } else { + integer_decode_float((double)(sf(x)), &h, &e, &s); + vs_push(make_fixnum(h)); + vs_push(make_fixnum(e)); + vs_push(make_fixnum(s)); + } +} + +LFD(Lcomplex)(void) +{ + object r, i; + int narg; + + narg = vs_top - vs_base; + if (narg < 1) + too_few_arguments(); + if (narg > 2) + too_many_arguments(); + check_type_or_rational_float(&vs_base[0]); + r = vs_base[0]; + if (narg == 1) + i = small_fixnum(0); + else { + check_type_or_rational_float(&vs_base[1]); + i = vs_base[1]; + } + vs_top = vs_base; + vs_push(make_complex(r, i)); +} + +LFD(Lrealpart)(void) +{ + object x; + + check_arg(1); + check_type_number(&vs_base[0]); + x = vs_base[0]; + if (type_of(x) == t_complex) + vs_base[0] = x->cmp.cmp_real; +} + +LFD(Limagpart)(void) +{ + object x; + + check_arg(1); + check_type_number(&vs_base[0]); + x = vs_base[0]; + switch (type_of(x)) { + case t_fixnum: + case t_bignum: + case t_ratio: + vs_base[0] = small_fixnum(0); + break; + case t_shortfloat: + vs_base[0] = shortfloat_zero; + break; + case t_longfloat: + vs_base[0] = longfloat_zero; + break; + case t_complex: + vs_base[0] = x->cmp.cmp_imag; + break; + default: + break; + } +} + +void +gcl_init_num_co(void) +{ + float smallest_float, smallest_norm_float, biggest_float; + double smallest_double, smallest_norm_double, biggest_double; + float float_epsilon, float_negative_epsilon; + double double_epsilon, double_negative_epsilon; + union {double d;int i[2];} u; + union {float f;int i;} uf; + + +#ifdef VAX + l[0] = 0x80; + l[1] = 0; + smallest_float = *(float *)l; + smallest_double = *(double *)l; +#endif + +#ifdef IEEEFLOAT +#ifdef NS32K + + + + + +#else + uf.i=1; + u.i[HIND]=0; + u.i[LIND]=1; + smallest_float=uf.f; + smallest_double=u.d; + +/* ((int *) &smallest_float)[0]= 1; */ +/* ((int *) &smallest_double)[HIND] = 0; */ +/* ((int *) &smallest_double)[LIND] = 1; */ + +#endif +#endif + +#ifdef MV + + + + +#endif + +#ifdef S3000 + l[0] = 0x00100000; + l[1] = 0; + smallest_float = *(float *)l; + smallest_double = *(double *)l; +#endif + +#ifdef VAX + l[0] = 0xffff7fff; + l[1] = 0xffffffff; + biggest_float = *(float *)l; + biggest_double = *(double *)l; +#endif + +#ifdef IBMRT + + + + +#endif + +#ifdef IEEEFLOAT +#ifdef NS32K + + + + + +#else + + uf.i=0x7f7fffff; + u.i[HIND]=0x7fefffff; + u.i[LIND]=0xffffffff; + + biggest_float=uf.f; + biggest_double=u.d; + +/* ((int *) &biggest_float)[0]= 0x7f7fffff; */ +/* ((int *) &biggest_double)[HIND] = 0x7fefffff; */ +/* ((int *) &biggest_double)[LIND] = 0xffffffff; */ + +#ifdef BAD_FPCHIP + /* &&&& I am adding junk values to get past debugging */ + biggest_float = 1.0e37; + smallest_float = 1.0e-37; + biggest_double = 1.0e308; + smallest_double = 1.0e-308; + printf("\n Used fake values for float max and mins "); +#endif +#endif +#endif + +#if defined(S3000) && ~defined(DBL_MAX_10_EXP) + l[0] = 0x7fffffff; + l[1] = 0xffffffff; + l[0] = 0x7fffffff; + l[1] = 0xffffffff; + biggest_float = *(float *)l; + biggest_float = *(float *)l; + biggest_float = *(float *)l; + biggest_float = 0.0; + biggest_float = biggest_float + 1.0; + biggest_float = biggest_float + 2.0; + biggest_float = *(float *)l; + biggest_float = *(float *)l; + strcmp("I don't like", "DATA GENERAL."); + biggest_float = *(float *)l; + biggest_double = *(double *)l; + biggest_double = *(double *)l; + biggest_double = *(double *)l; + biggest_double = 0.0; + biggest_double = biggest_double + 1.0; + biggest_double = biggest_double + 2.0; + biggest_double = *(double *)l; + biggest_double = *(double *)l; + strcmp("I don't like", "DATA GENERAL."); + biggest_double = *(double *)l; +#endif + +#ifdef DBL_MAX_10_EXP + biggest_double = DBL_MAX; + smallest_norm_double = DBL_MIN; + smallest_norm_float = FLT_MIN; + biggest_float = FLT_MAX; +#endif + + { + + volatile double rd,dd,td,td1; + volatile float rf,df,tf,tf1; + int i,j; +#define MAX 500 + + for (rf=1.0f,df=0.5f,i=j=0;i y. + + If x or y is complex, 0 or 1 is returned. +*/ +int +number_compare(object x, object y) +{ + int i; + double dx, dy=0.0; + vs_mark; + + switch (type_of(x)) { + + case t_fixnum: + switch (type_of(y)) { + case t_fixnum: + if (fix(x) < fix(y)) + return(-1); + else if (fix(x) == fix(y)) + return(0); + else + return(1); + case t_bignum: + i = big_sign(y); + if (i < 0) + return(1); + else + return(-1); + case t_ratio: + x = number_times(x, y->rat.rat_den); + y = y->rat.rat_num; + vs_push(x); + i = number_compare(x, y); + vs_reset; + return(i); + case t_shortfloat: + dx = (double)(fix(x)); + dy = (double)(sf(y)); + goto LONGFLOAT; + case t_longfloat: + dx = (double)(fix(x)); + dy = lf(y); + goto LONGFLOAT; + case t_complex: + goto Y_COMPLEX; + default: + wrong_type_argument(sLnumber, y); + } + + case t_bignum: + switch (type_of(y)) { + case t_fixnum: + i = big_sign(x); + if (i < 0) + return(-1); + else + return(1); + case t_bignum: + return cmpii(MP(x),MP(y)); + case t_ratio: + x = number_times(x, y->rat.rat_den); + y = y->rat.rat_num; + vs_push(x); + i = number_compare(x, y); + vs_reset; + return(i); + case t_shortfloat: + dx = number_to_double(x); + dy = (double)(sf(y)); + goto LONGFLOAT; + case t_longfloat: + dx = number_to_double(x); + dy = lf(y); + goto LONGFLOAT; + case t_complex: + goto Y_COMPLEX; + default: + wrong_type_argument(sLnumber, y); + } + + case t_ratio: + switch (type_of(y)) { + case t_fixnum: + case t_bignum: + y = number_times(y, x->rat.rat_den); + x = x->rat.rat_num; + vs_push(y); + i = number_compare(x, y); + vs_reset; + return(i); + case t_ratio: + vs_push(number_times(x->rat.rat_num,y->rat.rat_den)); + vs_push(number_times(y->rat.rat_num,x->rat.rat_den)); + i = number_compare(vs_top[-2], vs_top[-1]); + vs_reset; + return(i); + case t_shortfloat: + dx = number_to_double(x); + dy = (double)(sf(y)); + goto LONGFLOAT; + case t_longfloat: + dx = number_to_double(x); + dy = lf(y); + goto LONGFLOAT; + case t_complex: + goto Y_COMPLEX; + default: + wrong_type_argument(sLnumber, y); + } + + case t_shortfloat: + dx = (double)(sf(x)); + goto LONGFLOAT0; + + case t_longfloat: + dx = lf(x); + LONGFLOAT0: + switch (type_of(y)) { + case t_fixnum: + dy = (double)(fix(y)); + goto LONGFLOAT; + case t_bignum: + case t_ratio: + dy = number_to_double(y); + goto LONGFLOAT; + case t_shortfloat: + dy = (double)(sf(y)); + goto LONGFLOAT; + case t_longfloat: + dy = lf(y); + goto LONGFLOAT; + case t_complex: + goto Y_COMPLEX; + default: + break; + } + LONGFLOAT: + if (dx == dy) + return(0); + else if (dx < dy) + return(-1); + else + return(1); + + Y_COMPLEX: + if (number_zerop(y->cmp.cmp_imag)) + if (number_compare(x, y->cmp.cmp_real) == 0) + return(0); + else + return(1); + else + return(1); + + case t_complex: + if (type_of(y) != t_complex) { + if (number_zerop(x->cmp.cmp_imag)) + if (number_compare(x->cmp.cmp_real, y) == 0) + return(0); + else + return(1); + else + return(1); + } + if (number_compare(x->cmp.cmp_real, y->cmp.cmp_real) == 0 && + number_compare(x->cmp.cmp_imag, y->cmp.cmp_imag) == 0 ) + return(0); + else + return(1); + + default: + FEwrong_type_argument(sLnumber, x); + return(0); + } +} + +LFD(Lall_the_same)(void) +{ + int narg, i; + + narg = vs_top - vs_base; + if (narg == 0) + too_few_arguments(); + for (i = 0; i < narg; i++) + check_type_number(&vs_base[i]); + for (i = 1; i < narg; i++) + if (number_compare(vs_base[i-1], vs_base[i]) != 0) { + vs_top = vs_base+1; + vs_base[0] = Cnil; + return; + } + vs_top = vs_base+1; + vs_base[0] = Ct; +} + +LFD(Lall_different)(void) +{ + int narg, i, j; + + narg = vs_top - vs_base; + if (narg == 0) + too_few_arguments(); + else if (narg == 1) { + vs_base[0] = Ct; + return; + } + for (i = 0; i < narg; i++) + check_type_number(&vs_base[i]); + for(i = 1; i < narg; i++) + for(j = 0; j < i; j++) + if (number_compare(vs_base[j], vs_base[i]) == 0) { + vs_top = vs_base+1; + vs_base[0] = Cnil; + return; + } + vs_top = vs_base+1; + vs_base[0] = Ct; +} + +static void +Lnumber_compare(int s, int t) +{ + int narg, i; + + narg = vs_top - vs_base; + if (narg == 0) + too_few_arguments(); + for (i = 0; i < narg; i++) + check_type_or_rational_float(&vs_base[i]); + for (i = 1; i < narg; i++) + if (s*number_compare(vs_base[i], vs_base[i-1]) < t) { + vs_top = vs_base+1; + vs_base[0] = Cnil; + return; + } + vs_top = vs_base+1; + vs_base[0] = Ct; +} + +LFD(Lmonotonically_increasing)(void) { Lnumber_compare( 1, 1); } +LFD(Lmonotonically_decreasing)(void) { Lnumber_compare(-1, 1); } +LFD(Lmonotonically_nondecreasing)(void) { Lnumber_compare( 1, 0); } +LFD(Lmonotonically_nonincreasing)(void) { Lnumber_compare(-1, 0); } + +LFD(Lmax)(void) +{ + object max; + int narg, i; + + narg = vs_top - vs_base; + if (narg == 0) + too_few_arguments(); + for (i = 0; i < narg; i++) + check_type_or_rational_float(&vs_base[i]); + for (i = 1, max = vs_base[0]; i < narg; i++) + if (number_compare(max, vs_base[i]) < 0) + max = vs_base[i]; + vs_top = vs_base+1; + vs_base[0] = max; +} + +LFD(Lmin)(void) +{ + object min; + int narg, i; + + narg = vs_top - vs_base; + if (narg == 0) + too_few_arguments(); + for (i = 0; i < narg; i++) + check_type_or_rational_float(&vs_base[i]); + for (i = 1, min = vs_base[0]; i < narg; i++) + if (number_compare(min, vs_base[i]) > 0) + min = vs_base[i]; + vs_top = vs_base+1; + vs_base[0] = min; +} + +void +gcl_init_num_comp(void) +{ + make_function("=", Lall_the_same); + make_function("/=", Lall_different); + make_function("<", Lmonotonically_increasing); + make_function(">", Lmonotonically_decreasing); + make_function("<=", Lmonotonically_nondecreasing); + make_function(">=", Lmonotonically_nonincreasing); + make_function("MAX", Lmax); + make_function("MIN", Lmin); +} diff --git a/o/num_log.c b/o/num_log.c new file mode 100755 index 0000000..53e50b6 --- /dev/null +++ b/o/num_log.c @@ -0,0 +1,529 @@ + +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +/* + Logical operations on number +*/ +#define NEED_MP_H +#include +#include "include.h" +#include "num_include.h" + + +#ifdef GMP +#include "gmp_num_log.c" +#else +#include "pari_num_log.c" +#endif + + + +inline object +fixnum_big_shift(fixnum x,fixnum w) { + MPOP(return,shifti,SI_TO_MP(x,big_fixnum1),w); +} + +inline object +integer_fix_shift(object x, fixnum w) { + if (type_of(x)==t_fixnum) { + fixnum fx=fix(x); + return (fx!=MOST_NEGATIVE_FIX || w<0) ? fixnum_shft(fx,w) : fixnum_big_shift(fx,w); + } + MPOP(return,shifti,MP(x),w); +} + +inline object +integer_shift(object x,object y) { + enum type tx=type_of(x),ty=type_of(y); + if (ty==t_fixnum) + return integer_fix_shift(x,fix(y)); + else { + if (eql(x,make_fixnum(0))) + return x; + if (big_sign(y)<0) + return make_fixnum((tx==t_fixnum ? fix(x) : big_sign(x))<0 ? -1 : 0); + FEerror("Insufficient memory",0); + return Cnil; + } +} + +inline object +integer_length(object x) { + return make_fixnum(type_of(x)==t_fixnum ? fixnum_length(fix(x)) : MP_SIZE_IN_BASE2(MP(x))); +} + +inline object +integer_count(object x) { + return make_fixnum(type_of(x)==t_fixnum ? fixnum_count(fix(x)) : MP_BITCOUNT(MP(x))); +} + +#define DEFLOG(a_,b_,c_) \ + LFD(a_)(void) { \ + object x; \ + int narg, i; \ + \ + narg = vs_top - vs_base; \ + for (i = 0; i < narg; i++) \ + check_type_integer(&vs_base[i]); \ + if (narg == 0) { \ + vs_top = vs_base; \ + vs_push(c_); \ + return; \ + } \ + if (narg == 1) \ + return; \ + x = log_op(b_); \ + vs_top = vs_base; \ + vs_push(x); \ + } + +DEFLOG(Llogior,BOOLIOR,small_fixnum(0)); +DEFLOG(Llogxor,BOOLXOR,small_fixnum(0)); +DEFLOG(Llogand,BOOLAND,small_fixnum(-1)); +DEFLOG(Llogeqv,BOOLEQV,small_fixnum(-1)); + +LFD(Lboole)(void) +{ + object x; + object o; + + check_arg(3); + check_type_integer(&vs_base[0]); + check_type_integer(&vs_base[1]); + check_type_integer(&vs_base[2]); + o = vs_base[0]; + + vs_base++; + x = log_op(fix(o)); + vs_base--; + vs_top = vs_base; + vs_push(x); + +} + +inline bool +integer_bitp(object p,object x) { + enum type tp=type_of(p),tx=type_of(x); + + if (tp==t_fixnum) { + if (tx==t_fixnum) + return fixnum_bitp(fix(p),fix(x)); + else + return big_bitp(x,fix(p)); + } else if (big_sign(p)<0) + return 0; + else if (tx==t_fixnum)/*fixme integer_minusp*/ + return fix(x)<0; + else return big_sign(x)<0; +} + +LFD(Llogbitp)(void) +{ + check_arg(2); + check_type_integer(&vs_base[0]); + check_type_integer(&vs_base[1]); + vs_top=vs_base; + vs_push(integer_bitp(vs_base[0],vs_base[1])?Ct:Cnil); +} + +LFD(Lash)(void) { + check_arg(2); + check_type_integer(&vs_base[0]); + check_type_integer(&vs_base[1]); + vs_top=vs_base; + vs_push(integer_shift(vs_base[0],vs_base[1])); +} + +LFD(Llogcount)(void) { + check_arg(1); + check_type_integer(&vs_base[0]); + vs_base[0]=integer_count(vs_base[0]); +} + +LFD(Linteger_length)(void) { + check_arg(1); + check_type_integer(&vs_base[0]); + vs_base[0]=integer_length(vs_base[0]); +} + +#define W_SIZE (8*sizeof(int)) + +static fixnum +ior_op(fixnum i, fixnum j) +{ + return(i | j); +} + +static fixnum +xor_op(fixnum i, fixnum j) +{ + return(i ^ j); +} + +static fixnum +and_op(fixnum i, fixnum j) +{ + return(i & j); +} + +static fixnum +eqv_op(fixnum i, fixnum j) +{ + return(~(i ^ j)); +} + +static fixnum +nand_op(fixnum i, fixnum j) +{ + return(~(i & j)); +} + +static fixnum +nor_op(fixnum i, fixnum j) +{ + return(~(i | j)); +} + +static fixnum +andc1_op(fixnum i, fixnum j) +{ + return((~i) & j); +} + +static fixnum +andc2_op(fixnum i, fixnum j) +{ + return(i & (~j)); +} + +static fixnum +orc1_op(fixnum i, fixnum j) +{ + return((~i) | j); +} + +static fixnum +orc2_op(fixnum i, fixnum j) +{ + return(i | (~j)); +} + +static fixnum +b_clr_op(fixnum i, fixnum j) +{ + return(0); +} + +static fixnum +b_set_op(fixnum i, fixnum j) +{ + return(-1); +} + +static fixnum +b_1_op(fixnum i, fixnum j) +{ + return(i); +} + +static fixnum +b_2_op(fixnum i, fixnum j) +{ + return(j); +} + +static fixnum +b_c1_op(fixnum i, fixnum j) +{ + return(~i); +} + +static fixnum +b_c2_op(fixnum i, fixnum j) +{ + return(~j); +} + +LFD(siLbit_array_op)(void) +{ + fixnum i, j, n, d; + object o, x, y, r, r0=Cnil; + fixnum (*op)()=NULL; + bool replace = FALSE; + fixnum xi, yi, ri; + char *xp, *yp, *rp; + fixnum xo, yo, ro; + object *base = vs_base; + + check_arg(4); + o = vs_base[0]; + x = vs_base[1]; + y = vs_base[2]; + r = vs_base[3]; + if (type_of(x) == t_bitvector) { + d = x->bv.bv_dim; + xp = x->bv.bv_self; + xo = BV_OFFSET(x); + if (type_of(y) != t_bitvector) + goto ERROR; + if (d != y->bv.bv_dim) + goto ERROR; + yp = y->bv.bv_self; + yo = BV_OFFSET(y); + if (r == Ct) + r = x; + if (r != Cnil) { + if (type_of(r) != t_bitvector) + goto ERROR; + if (r->bv.bv_dim != d) + goto ERROR; + i = (r->bv.bv_self - xp)*8 + (BV_OFFSET(r) - xo); + if ((i > 0 && i < d) || (i < 0 && -i < d)) { + r0 = r; + r = Cnil; + replace = TRUE; + goto L1; + } + i = (r->bv.bv_self - yp)*8 + (BV_OFFSET(r) - yo); + if ((i > 0 && i < d) || (i < 0 && -i < d)) { + r0 = r; + r = Cnil; + replace = TRUE; + } + } + L1: + if (r == Cnil) { + vs_base = vs_top; + vs_push(sLbit); + vs_push(make_fixnum(d)); + vs_push(Cnil); + vs_push(Cnil); + vs_push(Cnil); + vs_push(Cnil); + vs_push(Cnil); + siLmake_vector(); + r = vs_base[0]; + } + } else { + if (type_of(x) != t_array) + goto ERROR; + if ((enum aelttype)x->a.a_elttype != aet_bit) + goto ERROR; + d = x->a.a_dim; + xp = x->bv.bv_self; + xo = BV_OFFSET(x); + if (type_of(y) != t_array) + goto ERROR; + if ((enum aelttype)y->a.a_elttype != aet_bit) + goto ERROR; + if (x->a.a_rank != y->a.a_rank) + goto ERROR; + yp = y->bv.bv_self; + yo = BV_OFFSET(y); + for (i = 0; i < x->a.a_rank; i++) + if (x->a.a_dims[i] != y->a.a_dims[i]) + goto ERROR; + if (r == Ct) + r = x; + if (r != Cnil) { + if (type_of(r) != t_array) + goto ERROR; + if ((enum aelttype)r->a.a_elttype != aet_bit) + goto ERROR; + if (r->a.a_rank != x->a.a_rank) + goto ERROR; + for (i = 0; i < x->a.a_rank; i++) + if (r->a.a_dims[i] != x->a.a_dims[i]) + goto ERROR; + i = (r->bv.bv_self - xp)*8 + (BV_OFFSET(r) - xo); + if ((i > 0 && i < d) || (i < 0 && -i < d)) { + r0 = r; + r = Cnil; + replace = TRUE; + goto L2; + } + i = (r->bv.bv_self - yp)*8 + (BV_OFFSET(r) - yo); + if ((i > 0 && i < d) || (i < 0 && -i < d)) { + r0 = r; + r = Cnil; + replace = TRUE; + } + } + L2: + if (r == Cnil) { + object b; + struct cons *p=alloca(x->a.a_rank*sizeof(struct cons)); + if (x->a.a_rank) { + object b1; + + b=(object)p; + for (b1=b,i=0;ia.a_rank;i++,b1=b1->c.c_cdr) { +#ifdef WIDE_CONS + set_type_of(b1,t_cons); +#endif + b1->c.c_car=/* x->a.a_dims[i]a.a_dims[i]) : */ + /* now done in a macro */ + make_fixnum(x->a.a_dims[i]); + b1->c.c_cdr=ia.a_rank-1 ? (object)++p : Cnil; + } + } else + b=Cnil; + + r = fSmake_array1(aet_bit,Cnil,small_fixnum(0),Cnil,0,b); + + /* object b[F_ARG_LIMIT]; */ + /* b[0]=Cnil; */ + /* for (i = 0; i < x->a.a_rank; i++) */ + /* b[i] = (make_fixnum(x->a.a_dims[i])); */ + /* r=Iapply_fun_n1(fSmake_array1,5,x->a.a_rank ? x->a.a_rank : 1, */ + /* aet_bit, */ + /* Cnil, */ + /* small_fixnum(0), */ + /* Cnil, */ + /* Cnil, */ + /* b); */ + + } + } + rp = r->bv.bv_self; + ro = BV_OFFSET(r); + switch(fixint(o)) { + case BOOLCLR: op = b_clr_op; break; + case BOOLSET: op = b_set_op; break; + case BOOL1: op = b_1_op; break; + case BOOL2: op = b_2_op; break; + case BOOLC1: op = b_c1_op; break; + case BOOLC2: op = b_c2_op; break; + case BOOLAND: op = and_op; break; + case BOOLIOR: op = ior_op; break; + case BOOLXOR: op = xor_op; break; + case BOOLEQV: op = eqv_op; break; + case BOOLNAND: op = nand_op; break; + case BOOLNOR: op = nor_op; break; + case BOOLANDC1: op = andc1_op; break; + case BOOLANDC2: op = andc2_op; break; + case BOOLORC1: op = orc1_op; break; + case BOOLORC2: op = orc2_op; break; + default: + FEerror("~S is an invalid logical operator.", 1, o); + } + +#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 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))) + + 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) { + vs_top = vs_base = base; + vs_push(r); + return; + } + } 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) { + vs_top = vs_base = base; + vs_push(r); + return; + } + } + rp = r0->bv.bv_self; + ro = BV_OFFSET(r0); + 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->bv.bv_self[n]); + } else + ri = r->bv.bv_self[i]; + store_byte(rp, i, ro, ri); + } + vs_top = vs_base = base; + vs_push(r0); + return; + +ERROR: + FEerror("Illegal arguments for bit-array operation.", 0); +} + +void +gcl_init_num_log(void) +{ +/* int siLbit_array_op(void); */ + + make_constant("BOOLE-CLR", make_fixnum(BOOLCLR)); + make_constant("BOOLE-SET", make_fixnum(BOOLSET)); + make_constant("BOOLE-1", make_fixnum(BOOL1)); + make_constant("BOOLE-2", make_fixnum(BOOL2)); + make_constant("BOOLE-C1", make_fixnum(BOOLC1)); + make_constant("BOOLE-C2", make_fixnum(BOOLC2)); + make_constant("BOOLE-AND", make_fixnum(BOOLAND)); + make_constant("BOOLE-IOR", make_fixnum(BOOLIOR)); + make_constant("BOOLE-XOR", make_fixnum(BOOLXOR)); + make_constant("BOOLE-EQV", make_fixnum(BOOLEQV)); + make_constant("BOOLE-NAND", make_fixnum(BOOLNAND)); + make_constant("BOOLE-NOR", make_fixnum(BOOLNOR)); + make_constant("BOOLE-ANDC1", make_fixnum(BOOLANDC1)); + make_constant("BOOLE-ANDC2", make_fixnum(BOOLANDC2)); + make_constant("BOOLE-ORC1", make_fixnum(BOOLORC1)); + make_constant("BOOLE-ORC2", make_fixnum(BOOLORC2)); + + make_function("LOGIOR", Llogior); + make_function("LOGXOR", Llogxor); + make_function("LOGAND", Llogand); + make_function("LOGEQV", Llogeqv); + make_function("BOOLE", Lboole); + make_function("LOGBITP", Llogbitp); + make_function("ASH", Lash); + make_function("LOGCOUNT", Llogcount); + make_function("INTEGER-LENGTH", Linteger_length); + + sLbit = make_ordinary("BIT"); + make_si_function("BIT-ARRAY-OP", siLbit_array_op); +} + diff --git a/o/num_pred.c b/o/num_pred.c new file mode 100755 index 0000000..5766f05 --- /dev/null +++ b/o/num_pred.c @@ -0,0 +1,253 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +/* + Predicates on numbers +*/ +#define NEED_MP_H +#include "include.h" +#include "num_include.h" + + +int +number_zerop(object x) +{ + switch (type_of(x)) { + + case t_fixnum: + if (fix(x) == 0) + return(1); + else + return(0); + + case t_bignum: + case t_ratio: + return(0); + + case t_shortfloat: + if (sf(x) == 0.0) + return(1); + else + return(0); + + case t_longfloat: + if (lf(x) == 0.0) + return(1); + else + return(0); + + case t_complex: + return(number_zerop(x->cmp.cmp_real) && + number_zerop(x->cmp.cmp_imag)); + + default: + FEwrong_type_argument(sLnumber, x); + return(0); + } +} + +int +number_plusp(object x) +{ + switch (type_of(x)) { + + case t_fixnum: + if (fix(x) > 0) + return(1); + else + return(0); + + case t_bignum: + if (big_sign(x) > 0) + return(1); + else + return(0); + + case t_ratio: + if (number_plusp(x->rat.rat_num)) + return(1); + else + return(0); + + case t_shortfloat: + if (sf(x) > 0.0) + return(1); + else + return(0); + + case t_longfloat: + if (lf(x) > 0.0) + return(1); + else + return(0); + + default: + FEwrong_type_argument(TSor_rational_float,x); + return(0); + } +} + +int +number_minusp(object x) +{ + switch (type_of(x)) { + + case t_fixnum: + if (fix(x) < 0) + return(1); + else + return(0); + + case t_bignum: + if (big_sign(x) < 0) + return(1); + else + return(0); + + case t_ratio: + if (number_minusp(x->rat.rat_num)) + return(1); + else + return(0); + + case t_shortfloat: + if (sf(x) < 0.0) + return(1); + else + return(0); + + case t_longfloat: + if (lf(x) < 0.0) + return(1); + else + return(0); + + default: + FEwrong_type_argument(TSor_rational_float,x); + return(0); + } +} + +int +number_oddp(object x) +{ + int i=0; + + if (type_of(x) == t_fixnum) + i = fix(x); + else if (type_of(x) == t_bignum) + i = MP_LOW(MP(x),lgef(MP(x))); + else + FEwrong_type_argument(sLinteger, x); + return(i & 1); +} + +int +number_evenp(object x) +{ + int i=0; + + if (type_of(x) == t_fixnum) + i = fix(x); + else if (type_of(x) == t_bignum) + i = MP_LOW(MP(x),lgef(MP(x))); + else + FEwrong_type_argument(sLinteger, x); + return(~i & 1); +} + +LFD(Lzerop)(void) +{ + check_arg(1); + check_type_number(&vs_base[0]); + if (number_zerop(vs_base[0])) + vs_base[0] = Ct; + else + vs_base[0] = Cnil; +} + +LFD(Lplusp)(void) +{ + check_arg(1); + check_type_or_rational_float(&vs_base[0]); + if (number_plusp(vs_base[0])) + vs_base[0] = Ct; + else + vs_base[0] = Cnil; +} + +LFD(Lminusp)(void) +{ + check_arg(1); + check_type_or_rational_float(&vs_base[0]); + if (number_minusp(vs_base[0])) + vs_base[0] = Ct; + else + vs_base[0] = Cnil; +} + +LFD(Loddp)(void) +{ + check_arg(1); + check_type_integer(&vs_base[0]); + if (number_oddp(vs_base[0])) + vs_base[0] = Ct; + else + vs_base[0] = Cnil; +} + +LFD(Levenp)(void) +{ + check_arg(1); + check_type_integer(&vs_base[0]); + if (number_evenp(vs_base[0])) + vs_base[0] = Ct; + else + vs_base[0] = Cnil; +} + +/* this is just to force things into memory in num_co.c */ +/* static void _assure_in_memory (void *p) */ +/* { */ +/* ; */ +/* } */ + +/* static int */ +/* lf_eqlp(double *p, double *q) */ +/* { */ +/* return *p == *q; */ +/* } */ + + +void +gcl_init_num_pred(void) +{ +#ifndef GMP + big_register_1 = new_bignum(); + ZERO_BIG(big_register_1); + enter_mark_origin(&big_register_1); +#endif + make_function("ZEROP", Lzerop); + make_function("PLUSP", Lplusp); + make_function("MINUSP", Lminusp); + make_function("ODDP", Loddp); + make_function("EVENP", Levenp); +} diff --git a/o/num_rand.c b/o/num_rand.c new file mode 100755 index 0000000..cd83b20 --- /dev/null +++ b/o/num_rand.c @@ -0,0 +1,250 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +/* + Random numbers +*/ + +#include +#include + +#include "include.h" +#include "num_include.h" + +#ifdef AOSVS + +#endif + +static object +rando(object x, object rs) { + + enum type tx; + object base,out,z; + fixnum fbase; + double d; + + tx = type_of(x); + if (number_compare(x, small_fixnum(0)) != 1) + FEwrong_type_argument(TSpositive_number, x); + + if (tx==t_bignum) { + out=new_bignum(); + base=x; + fbase=-1; + } else { + out=big_fixnum1; + fbase=tx==t_fixnum ? fix(x) : MOST_POSITIVE_FIX; + mpz_set_si(MP(big_fixnum2),fbase); + base=big_fixnum2; + } + + mpz_urandomm(MP(out),&rs->rnd.rnd_state,MP(base)); + + switch (tx) { + + case t_fixnum: + return make_fixnum(mpz_get_si(MP(out))); + case t_bignum: + return normalize_big(out); + case t_shortfloat: case t_longfloat: + d=mpz_get_d(MP(out)); + d/=(double)fbase; + z=alloc_object(tx); + if (tx==t_shortfloat) sf(z)=sf(x)*d; else lf(z)=lf(x)*d; + return z; + default: + FEerror("~S is not an integer nor a floating-point number.", 1, x); + return(Cnil); + } +} + + +#ifdef UNIX +#define RS_DEF_INIT time(0) +#else +#define RS_DEF_INIT 0 +#endif + +#if __GNU_MP_VERSION > 4 || (__GNU_MP_VERSION == 4 && __GNU_MP_VERSION_MINOR >= 2) +extern void * (*gcl_gmp_allocfun) (size_t); +static void * (*old_gcl_gmp_allocfun) (size_t); +static void * trap_result; +static size_t trap_size; + +static void * +trap_gcl_gmp_allocfun(size_t size){ + + size+=size%MP_LIMB_SIZE; + if (trap_size) + return old_gcl_gmp_allocfun(size); + else { + trap_size=size/MP_LIMB_SIZE; + trap_result=old_gcl_gmp_allocfun(size); + return trap_result; + } + +} +#endif + +#if __GNU_MP_VERSION > 4 || (__GNU_MP_VERSION == 4 && __GNU_MP_VERSION_MINOR >= 2) +extern void +__gmp_randget_mt (); +extern void +__gmp_randclear_mt (); +extern void +__gmp_randiset_mt (); + +typedef struct {void *a,*b,*c,*d;} gmp_randfnptr_t; +static gmp_randfnptr_t Mersenne_Twister_Generator_Noseed = { + NULL, + __gmp_randget_mt, + __gmp_randclear_mt, + __gmp_randiset_mt +}; +#endif + +void +reinit_gmp() { + +#if __GNU_MP_VERSION > 4 || (__GNU_MP_VERSION == 4 && __GNU_MP_VERSION_MINOR >= 2) + Mersenne_Twister_Generator_Noseed.b=__gmp_randget_mt; + Mersenne_Twister_Generator_Noseed.c=__gmp_randclear_mt; + Mersenne_Twister_Generator_Noseed.d=__gmp_randiset_mt; +#endif + +} + +void +init_gmp_rnd_state(__gmp_randstate_struct *x) { + + static int n; + + bzero(x,sizeof(*x)); + +#if __GNU_MP_VERSION > 4 || (__GNU_MP_VERSION == 4 && __GNU_MP_VERSION_MINOR >= 2) +/* if (!trap_size) { */ + old_gcl_gmp_allocfun=gcl_gmp_allocfun; + gcl_gmp_allocfun=trap_gcl_gmp_allocfun; +/* } */ +#endif + gmp_randinit_default(x); +#if __GNU_MP_VERSION > 4 || (__GNU_MP_VERSION == 4 && __GNU_MP_VERSION_MINOR >= 2) + if (!n) { + + if (x->_mp_seed->_mp_d!=trap_result) + FEerror("Unknown pointer in rnd_state!",0); +/* #ifndef __hppa__ /\*FIXME*\/ */ +/* if (((gmp_randfnptr_t *)x->_mp_algdata._mp_lc)->b!=Mersenne_Twister_Generator_Noseed.b || */ +/* ((gmp_randfnptr_t *)x->_mp_algdata._mp_lc)->c!=Mersenne_Twister_Generator_Noseed.c || */ +/* ((gmp_randfnptr_t *)x->_mp_algdata._mp_lc)->d!=Mersenne_Twister_Generator_Noseed.d) */ +/* FEerror("Unknown pointer data in rnd_state!",0); */ +/* #endif */ + + n=1; + + } + gcl_gmp_allocfun=old_gcl_gmp_allocfun; + x->_mp_seed->_mp_alloc=x->_mp_seed->_mp_size=trap_size; +#endif + + +} + + + +static object +make_random_state(object rs) { + + object z; + + if (rs==Cnil) + rs=symbol_value(Vrandom_state); + + if (rs!=Ct && type_of(rs) != t_random) { + FEwrong_type_argument(sLrandom_state, rs); + return(Cnil); + } + + z = alloc_object(t_random); + init_gmp_rnd_state(&z->rnd.rnd_state); + + + if (rs == Ct) + gmp_randseed_ui(&z->rnd.rnd_state,RS_DEF_INIT); + else + memcpy(z->rnd.rnd_state._mp_seed->_mp_d,rs->rnd.rnd_state._mp_seed->_mp_d, + rs->rnd.rnd_state._mp_seed->_mp_alloc*sizeof(*z->rnd.rnd_state._mp_seed->_mp_d)); + +#if __GNU_MP_VERSION > 4 || (__GNU_MP_VERSION == 4 && __GNU_MP_VERSION_MINOR >= 2) + z->rnd.rnd_state._mp_algdata._mp_lc=&Mersenne_Twister_Generator_Noseed; +#endif + return(z); + +} + +LFD(Lrandom)(void) +{ + int j; + object x; + + j = vs_top - vs_base; + if (j == 1) + vs_push(symbol_value(Vrandom_state)); + check_arg(2); + check_type_random_state(&vs_base[1]); + x = rando(vs_base[0], vs_base[1]); + vs_top = vs_base; + vs_push(x); +} + +LFD(Lmake_random_state)(void) +{ + int j; + object x; + + j = vs_top - vs_base; + if (j == 0) + vs_push(Cnil); + check_arg(1); + x = make_random_state(vs_head); + vs_top = vs_base; + vs_push(x); +} + +LFD(Lrandom_state_p)(void) +{ + check_arg(1); + if (type_of(vs_pop) == t_random) + vs_push(Ct); + else + vs_push(Cnil); +} + +void +gcl_init_num_rand(void) +{ + Vrandom_state = make_special("*RANDOM-STATE*", + make_random_state(Ct)); + + make_function("RANDOM", Lrandom); + make_function("MAKE-RANDOM-STATE", Lmake_random_state); + make_function("RANDOM-STATE-P", Lrandom_state_p); +} diff --git a/o/num_sfun.c b/o/num_sfun.c new file mode 100755 index 0000000..602fd71 --- /dev/null +++ b/o/num_sfun.c @@ -0,0 +1,765 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#define IN_NUM_CO + +#include "include.h" +#include "num_include.h" + +object imag_unit, minus_imag_unit, imag_two; + +int +fixnum_expt(int x, int y) +{ + int z; + + z = 1; + while (y > 0) + if (y%2 == 0) { + x *= x; + y /= 2; + } else { + z *= x; + --y; + } + return(z); +} + +static object number_sin(object); +static object number_cos(object); +static object number_exp(object); +static object number_nlog(object); +static object number_atan2(object,object); + + +static object +number_exp(object x) +{ + double exp(double); + + switch (type_of(x)) { + + case t_fixnum: + case t_bignum: + case t_ratio: + return(make_longfloat((longfloat)exp(number_to_double(x)))); + + case t_shortfloat: + return(make_shortfloat((shortfloat)exp((double)(sf(x))))); + + case t_longfloat: + return(make_longfloat(exp(lf(x)))); + + case t_complex: + { + object y, y1; + vs_mark; + + y = x->cmp.cmp_imag; + x = x->cmp.cmp_real; + x = number_exp(x); + vs_push(x); + y1 = number_cos(y); + vs_push(y1); + y = number_sin(y); + vs_push(y); + y = make_complex(y1, y); + vs_push(y); + x = number_times(x, y); + vs_reset; + return(x); + } + + default: + FEwrong_type_argument(sLnumber, x); + return(Cnil); + } +} + +inline object +number_fix_iexpt(object x,fixnum y,fixnum ly,fixnum j) { + object z; + + if (j+1==ly) return x; + z=number_fix_iexpt(number_times(x,x),y,ly,j+1); + return fixnum_bitp(j,y) ? number_times(x,z) : z; +} + +inline object +number_big_iexpt(object x,object y,fixnum ly,fixnum j) { + object z; + + if (j+1==ly) return x; + z=number_big_iexpt(number_times(x,x),y,ly,j+1); + return mpz_tstbit(MP(y),j) ? number_times(x,z) : z; + +} + +inline object +number_zero_expt(object x,bool promote_short_p) { + + switch (type_of(x)) { + case t_fixnum: + case t_bignum: + case t_ratio: + return make_fixnum(1); + case t_shortfloat: + return promote_short_p ? make_longfloat(1.0) : make_shortfloat(1.0); + case t_longfloat: + return make_longfloat(1.0); + case t_complex: + return make_complex(number_zero_expt(x->cmp.cmp_real,promote_short_p),small_fixnum(0)); + default: + FEwrong_type_argument(sLnumber,x); + return Cnil; + } + +} + + +inline object +number_ui_expt(object x,fixnum fy) { + + switch (type_of(x)) { + case t_fixnum: + { + fixnum fx=fix(x); + object z; + MPOP(z=,mpz_ui_pow_ui,labs(fx),fy); + if (fx<0&&(fy&0x1)) return number_negate(z); else return z; + } + case t_bignum: + MPOP(return,mpz_pow_ui,MP(x),fy); + case t_ratio: + { + object n=number_ui_expt(x->rat.rat_num,fy),d=number_ui_expt(x->rat.rat_den,fy),z=alloc_object(t_ratio); + z->rat.rat_num=n; + z->rat.rat_den=d;/*No need to make_ratio as no common factors*/ + return z; + } + + case t_shortfloat: + case t_longfloat: + case t_complex: + { + fixnum ly=fixnum_length(fy); + + return ly ? number_fix_iexpt(x,fy,ly,0) : number_zero_expt(x,0); + + } + + default: + FEwrong_type_argument(sLnumber,x); + return Cnil; + } + +} + +inline object +number_ump_expt(object x,object y) { + return number_big_iexpt(x,y,fix(integer_length(y)),0); +} + +inline object +number_log_expt(object x,object y) { + return number_zerop(y) ? number_zero_expt(y,type_of(x)==t_longfloat) : number_exp(number_times(number_nlog(x),y)); +} + +inline object +number_invert(object x,object y,object z) { + + switch (type_of(z)) { + case t_shortfloat: + if (!ISNORMAL(sf(z))) return number_log_expt(x,y); + break; + case t_longfloat: + if (!ISNORMAL(lf(z))) return number_log_expt(x,y); + break; + } + return number_divide(small_fixnum(1),z); +} + + +inline object +number_si_expt(object x,object y) { + switch (type_of(y)) { + case t_fixnum: + { + fixnum fy=fix(y); + if (fy>=0) + return number_ui_expt(x,fy); + if (fy==MOST_NEGATIVE_FIX) + return number_invert(x,y,number_ump_expt(x,number_negate(y))); + return number_invert(x,y,number_ui_expt(x,-fy)); + } + case t_bignum: + return big_sign(y)<0 ? number_invert(x,y,number_ump_expt(x,number_negate(y))) : number_ump_expt(x,y); + case t_ratio: + case t_shortfloat: + case t_longfloat: + case t_complex: + return number_log_expt(x,y); + default: + FEwrong_type_argument(sLnumber,y); + return Cnil; + } +} + +object +number_expt(object x, object y) { + + if (number_zerop(x)&&y!=small_fixnum(0)) { + if (!number_plusp(type_of(y)==t_complex?y->cmp.cmp_real:y)) + FEerror("Cannot raise zero to the power ~S.", 1, y); + return(number_times(x, y)); + } + + return number_si_expt(x,y); + +} + +static object +number_nlog(object x) +{ + double log(double); + object r=Cnil, i=Cnil, a, p; + vs_mark; + + if (type_of(x) == t_complex) { + r = x->cmp.cmp_real; + i = x->cmp.cmp_imag; + goto COMPLEX; + } + if (number_zerop(x)) + FEerror("Zero is the logarithmic singularity.", 0); + if (number_minusp(x)) { + r = x; + i = small_fixnum(0); + goto COMPLEX; + } + switch (type_of(x)) { + case t_fixnum: + case t_bignum: + case t_ratio: + return(make_longfloat(log(number_to_double(x)))); + + case t_shortfloat: + return(make_shortfloat((shortfloat)log((double)(sf(x))))); + + case t_longfloat: + return(make_longfloat(log(lf(x)))); + + default: + FEwrong_type_argument(sLnumber, x); + } + +COMPLEX: + a = number_times(r, r); + vs_push(a); + p = number_times(i, i); + vs_push(p); + a = number_plus(a, p); + vs_push(a); + a = number_nlog(a); + vs_push(a); + a = number_divide(a, small_fixnum(2)); + vs_push(a); + p = number_atan2(i, r); + vs_push(p); + x = make_complex(a, p); + vs_reset; + return(x); +} + +static object +number_log(object x, object y) +{ + object z; + vs_mark; + + if (number_zerop(y)) + FEerror("Zero is the logarithmic singularity.", 0); + if (number_zerop(x)) + return(number_times(x, y)); + x = number_nlog(x); + vs_push(x); + y = number_nlog(y); + vs_push(y); + z = number_divide(y, x); + vs_reset; + return(z); +} + +static object +number_sqrt(object x) +{ + object z; + double sqrt(double); + vs_mark; + + if (type_of(x) == t_complex) + goto COMPLEX; + if (number_minusp(x)) + goto COMPLEX; + switch (type_of(x)) { + case t_fixnum: + case t_bignum: + case t_ratio: + return(make_longfloat( + (longfloat)sqrt(number_to_double(x)))); + + case t_shortfloat: + return(make_shortfloat((shortfloat)sqrt((double)(sf(x))))); + + case t_longfloat: + return(make_longfloat(sqrt(lf(x)))); + + default: + FEwrong_type_argument(sLnumber, x); + } + +COMPLEX: + z = make_ratio(small_fixnum(1), small_fixnum(2)); + vs_push(z); + z = number_expt(x, z); + vs_reset; + return(z); +} + +object +number_abs(object x) { + + object r,i,z; + + switch(type_of(x)) { + + case t_complex: + if (number_zerop(x)) return x->cmp.cmp_real; + r=number_abs(x->cmp.cmp_real); + i=number_abs(x->cmp.cmp_imag); + if (number_compare(r,i)<0) { + object z=i; + i=r; + r=z; + } + z=number_divide(i,r); + return number_times(r,number_sqrt(one_plus(number_times(z,z)))); + + case t_fixnum: + {fixnum fx=fix(x);return fx==MOST_NEGATIVE_FIX ? fixnum_add(1,MOST_POSITIVE_FIX) : (fx<0 ? make_fixnum(-fx) : x);} + + case t_bignum: + return big_sign(x)<0 ? big_minus(x) : x; + + case t_ratio: + {object n=number_abs(x->rat.rat_num);return n==x ? x : make_ratio(n,x->rat.rat_den);} + + case t_shortfloat: + return sf(x)<0.0 ? make_shortfloat(-sf(x)) : x; + + case t_longfloat: + return lf(x)<0.0 ? make_longfloat(-lf(x)) : x; + + default: + FEwrong_type_argument(sLnumber,x); + return(Cnil); + } +} + +object +number_signum(object x) { + + switch (type_of(x)) { + + case t_fixnum: + {fixnum fx=fix(x);return make_fixnum(fx<0 ? -1 : (fx==0 ? 0 : 1));} + + case t_bignum: + return make_fixnum(big_sign(x)<0 ? -1 : 1); + + case t_ratio: + return number_signum(x->rat.rat_num); + + case t_shortfloat: + return make_shortfloat(sf(x)<0.0 ? -1.0 : (sf(x)==0.0 ? 0.0 : 1.0)); + + case t_longfloat: + return make_longfloat(lf(x)<0.0 ? -1.0 : (lf(x)==0.0 ? 0.0 : 1.0)); + + case t_complex: + return number_zerop(x) ? x : number_divide(x,number_abs(x)); + + default: + FEwrong_type_argument(sLnumber,x); + return(Cnil); + + } + +} + +static object +number_atan2(object y, object x) +{ + object z; + double atan(double), dy, dx, dz=0.0; + + dy = number_to_double(y); + dx = number_to_double(x); + if (dx > 0.0) + if (dy > 0.0) + dz = atan(dy / dx); + else if (dy == 0.0) + dz = 0.0; + else + dz = -atan(-dy / dx); + else if (dx == 0.0) + if (dy > 0.0) + dz = PI / 2.0; + else if (dy == 0.0) + FEerror("Logarithmic singularity.", 0); + else + dz = -PI / 2.0; + else + if (dy > 0.0) + dz = PI - atan(dy / -dx); + else if (dy == 0.0) + dz = PI; + else + dz = -PI + atan(-dy / -dx); + if (type_of(x) == t_shortfloat) + z = make_shortfloat((shortfloat)dz); + else + z = make_longfloat(dz); + return(z); +} + +static object +number_atan(object y) +{ + object z, z1; + vs_mark; + + if (type_of(y) == t_complex) { + z = number_times(imag_unit, y); + vs_push(z); + z = one_plus(z); + vs_push(z); + z1 = number_times(y, y); + vs_push(z1); + z1 = one_plus(z1); + vs_push(z1); + z1 = number_sqrt(z1); + vs_push(z1); + z = number_divide(z, z1); + vs_push(z); + z = number_nlog(z); + vs_push(z); + z = number_times(minus_imag_unit, z); + vs_reset; + return(z); + } + return(number_atan2(y, small_fixnum(1))); +} + +static object +number_sin(object x) +{ + double sin(double); + + switch (type_of(x)) { + + case t_fixnum: + case t_bignum: + case t_ratio: + return(make_longfloat((longfloat)sin(number_to_double(x)))); + + case t_shortfloat: + return(make_shortfloat((shortfloat)sin((double)(sf(x))))); + + case t_longfloat: + return(make_longfloat(sin(lf(x)))); + + case t_complex: + { + object r; + object x0, x1, x2; + vs_mark; + + x0 = number_times(imag_unit, x); + vs_push(x0); + x0 = number_exp(x0); + vs_push(x0); + x1 = number_times(minus_imag_unit, x); + vs_push(x1); + x1 = number_exp(x1); + vs_push(x1); + x2 = number_minus(x0, x1); + vs_push(x2); + r = number_divide(x2, imag_two); + + vs_reset; + return(r); + } + + default: + FEwrong_type_argument(sLnumber, x); + return(Cnil); + + } +} + +static object +number_cos(object x) +{ + double cos(double); + + switch (type_of(x)) { + + case t_fixnum: + case t_bignum: + case t_ratio: + return(make_longfloat((longfloat)cos(number_to_double(x)))); + + case t_shortfloat: + return(make_shortfloat((shortfloat)cos((double)(sf(x))))); + + case t_longfloat: + return(make_longfloat(cos(lf(x)))); + + case t_complex: + { + object r; + object x0, x1, x2; + vs_mark; + + x0 = number_times(imag_unit, x); + vs_push(x0); + x0 = number_exp(x0); + vs_push(x0); + x1 = number_times(minus_imag_unit, x); + vs_push(x1); + x1 = number_exp(x1); + vs_push(x1); + x2 = number_plus(x0, x1); + vs_push(x2); + r = number_divide(x2, small_fixnum(2)); + + vs_reset; + return(r); + } + + default: + FEwrong_type_argument(sLnumber, x); + return(Cnil); + + } +} + +static object +number_tan1(object x) +{ + double cos(double); + + switch (type_of(x)) { + + case t_fixnum: + case t_bignum: + case t_ratio: + return(make_longfloat((longfloat)tan(number_to_double(x)))); + + case t_shortfloat: + return(make_shortfloat((shortfloat)tan((double)(sf(x))))); + + case t_longfloat: + return(make_longfloat(tan(lf(x)))); + + case t_complex: + { + object r; + object x0, x1, x2; + vs_mark; + + x0 = number_times(imag_two, x); + vs_push(x0); + x0 = number_exp(x0); + vs_push(x0); + x1 = number_minus(x0,small_fixnum(1)); + vs_push(x1); + x2 = number_plus(x0,small_fixnum(1)); + vs_push(x2); + x2 = number_times(x2,imag_unit); + vs_push(x2); + r = number_divide(x1, x2); + + vs_reset; + return(r); + } + + default: + FEwrong_type_argument(sLnumber, x); + return(Cnil); + + } +} + +static object +number_tan(object x) +{ + object r, c; + vs_mark; + + c = number_cos(x); + vs_push(c); + if (number_zerop(c) == TRUE) + FEerror("Cannot compute the tangent of ~S.", 1, x); + r = number_tan1(x); + vs_reset; + return(r); +} + +LFD(Lexp)(void) +{ + check_arg(1); + check_type_number(&vs_base[0]); + vs_base[0] = number_exp(vs_base[0]); +} + +LFD(Lexpt)(void) +{ + check_arg(2); + check_type_number(&vs_base[0]); + check_type_number(&vs_base[1]); + vs_base[0] = number_expt(vs_base[0], vs_base[1]); + vs_popp; +} + +LFD(Llog)(void) +{ + int narg; + + narg = vs_top - vs_base; + if (narg < 1) + too_few_arguments(); + else if (narg == 1) { + check_type_number(&vs_base[0]); + vs_base[0] = number_nlog(vs_base[0]); + } else if (narg == 2) { + check_type_number(&vs_base[0]); + check_type_number(&vs_base[1]); + vs_base[0] = number_log(vs_base[1], vs_base[0]); + vs_popp; + } else + too_many_arguments(); +} + +LFD(Lsqrt)(void) +{ + check_arg(1); + check_type_number(&vs_base[0]); + vs_base[0] = number_sqrt(vs_base[0]); +} + +LFD(Lsin)(void) +{ + check_arg(1); + check_type_number(&vs_base[0]); + vs_base[0] = number_sin(vs_base[0]); +} + +LFD(Lcos)(void) +{ + check_arg(1); + check_type_number(&vs_base[0]); + vs_base[0] = number_cos(vs_base[0]); +} + +LFD(Ltan)(void) +{ + check_arg(1); + check_type_number(&vs_base[0]); + vs_base[0] = number_tan(vs_base[0]); +} + +LFD(Latan)(void) +{ + int narg; + + narg = vs_top - vs_base; + if (narg < 1) + too_few_arguments(); + if (narg == 1) { + check_type_number(&vs_base[0]); + vs_base[0] = number_atan(vs_base[0]); + } else if (narg == 2) { + check_type_or_rational_float(&vs_base[0]); + check_type_or_rational_float(&vs_base[1]); + vs_base[0] = number_atan2(vs_base[0], vs_base[1]); + vs_popp; + } else + too_many_arguments(); +} + +static void +FFN(siLmodf)(void) +{ + + object x; + double d,ip; + + check_arg(1); + check_type_float(&vs_base[0]); + x=vs_base[0]; + vs_base=vs_top; + d=type_of(x) == t_longfloat ? lf(x) : (double)sf(x); + d=modf(d,&ip); + vs_push(make_fixnum((int)ip)); + vs_push(type_of(x) == t_longfloat ? make_longfloat(d) : make_shortfloat((shortfloat)d)); + +} + +void +gcl_init_num_sfun(void) +{ + imag_unit + = make_complex(make_longfloat((longfloat)0.0), + make_longfloat((longfloat)1.0)); + enter_mark_origin(&imag_unit); + minus_imag_unit + = make_complex(make_longfloat((longfloat)0.0), + make_longfloat((longfloat)-1.0)); + enter_mark_origin(&minus_imag_unit); + imag_two + = make_complex(make_longfloat((longfloat)0.0), + make_longfloat((longfloat)2.0)); + enter_mark_origin(&imag_two); + + make_constant("PI", make_longfloat(PI)); + + make_function("EXP", Lexp); + make_function("EXPT", Lexpt); + make_function("LOG", Llog); + make_function("SQRT", Lsqrt); + make_function("SIN", Lsin); + make_function("COS", Lcos); + make_function("TAN", Ltan); + make_function("ATAN", Latan); + make_si_function("MODF", siLmodf); +} diff --git a/o/number.c b/o/number.c new file mode 100755 index 0000000..dcb36f3 --- /dev/null +++ b/o/number.c @@ -0,0 +1,321 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +/* + number.c + IMPLEMENTATION-DEPENDENT + + This file creates some implementation dependent constants. +*/ + +#define IN_NUM_CO + +#include "include.h" +#include "num_include.h" + + +long +fixint(object x) +{ + if (type_of(x) != t_fixnum) + FEwrong_type_argument(sLfixnum, x); + return(fix(x)); +} + +int +fixnnint(object x) +{ + if (type_of(x) != t_fixnum || fix(x) < 0) + FEerror("~S is not a non-negative fixnum.", 1, x); + return(fix(x)); +} +#if 0 +object small_fixnum ( int i ) { +#include + assert ( ( -SMALL_FIXNUM_LIMIT <= i ) && ( i < SMALL_FIXNUM_LIMIT ) ); + (object) small_fixnum_table + SMALL_FIXNUM_LIMIT + i; +} +#endif + +/* #if !defined(IM_FIX_BASE) */ + +#define BIGGER_FIXNUM_RANGE + +#ifdef BIGGER_FIXNUM_RANGE +struct {int min,max;} bigger_fixnums; + +struct fixnum_struct *bigger_fixnum_table; +DEFUN_NEW("ALLOCATE-BIGGER-FIXNUM-RANGE",object,fSallocate_bigger_fixnum_range,SI,2,2,NONE,OI,IO,OO,OO,(fixnum min,fixnum max),"") { + int j; + if (min > max) FEerror("Need Min <= Max",0); + bigger_fixnum_table=(void *)malloc(sizeof(struct fixnum_struct)*(max - min)); + + for (j=min ; j < max ; j=j+1) { + object x=(object)(bigger_fixnum_table+j-min); + x->fw=0; + set_type_of(x,t_fixnum); + x->FIX.FIXVAL=j; + } + bigger_fixnums.min=min; + bigger_fixnums.max=max; + + return Ct; +} +#endif +/* #endif */ + + +object +make_fixnum1(long i) +{ + object x; + + /* In a macro now */ +/* if (-SMALL_FIXNUM_LIMIT <= i && i < SMALL_FIXNUM_LIMIT) */ +/* return(small_fixnum(i)); */ +#ifdef BIGGER_FIXNUM_RANGE + if (bigger_fixnum_table) + { if (i >= bigger_fixnums.min + && i < bigger_fixnums.max) + return (object)(bigger_fixnum_table +(i -bigger_fixnums.min)); + } +#endif + + x = alloc_object(t_fixnum); + set_fix(x,i); + return(x); +} + +object +make_ratio(object num, object den) +{ + object g, r, get_gcd(object x, object y); + vs_mark; + + if (number_zerop(den)) + FEerror("Zero denominator.", 0); + if (number_zerop(num)) + return(small_fixnum(0)); + if (type_of(den) == t_fixnum && fix(den) == 1) + return(num); + if (number_minusp(den)) { + num = number_negate(num); + vs_push(num); + den = number_negate(den); + vs_push(den); + } + g = get_gcd(num, den); + vs_push(g); + num = integer_divide1(num, g,0); + vs_push(num); + den = integer_divide1(den, g,0); + vs_push(den); + if(type_of(den) == t_fixnum && fix(den) == 1) { + vs_reset; + return(num); + } + if(type_of(den) == t_fixnum && fix(den) == -1) { + num = number_negate(num); + vs_reset; + return(num); + } + r = alloc_object(t_ratio); + r->rat.rat_num = num; + r->rat.rat_den = den; + vs_reset; + return(r); +} + +object +make_shortfloat(double f) +{ + object x; + + if (f == (shortfloat)0.0) + return(shortfloat_zero); + x = alloc_object(t_shortfloat); + sf(x) = (shortfloat)f; + return(x); +} + +object +make_longfloat(longfloat f) +{ + object x; + + if (f == (longfloat)0.0) + return(longfloat_zero); + x = alloc_object(t_longfloat); + lf(x) = f; + return(x); +} + +object +make_complex(object r, object i) +{ + object c; + vs_mark; + + switch (type_of(r)) { + case t_fixnum: + case t_bignum: + case t_ratio: + switch (type_of(i)) { + case t_fixnum: + if (fix(i) == 0) + return(r); + break; + case t_shortfloat: + r = make_shortfloat((shortfloat)number_to_double(r)); + vs_push(r); + break; + case t_longfloat: + r = make_longfloat(number_to_double(r)); + vs_push(r); + break; + default: + break; + } + break; + case t_shortfloat: + switch (type_of(i)) { + case t_fixnum: + case t_bignum: + case t_ratio: + i = make_shortfloat((shortfloat)number_to_double(i)); + vs_push(i); + break; + case t_longfloat: + r = make_longfloat((double)(sf(r))); + vs_push(r); + break; + default: + break; + } + break; + case t_longfloat: + switch (type_of(i)) { + case t_fixnum: + case t_bignum: + case t_ratio: + case t_shortfloat: + i = make_longfloat(number_to_double(i)); + vs_push(i); + break; + default: + break; + } + break; + default: + break; + } + c = alloc_object(t_complex); + c->cmp.cmp_real = r; + c->cmp.cmp_imag = i; + vs_reset; + return(c); +} + +double +number_to_double(object x) +{ + switch(type_of(x)) { + case t_fixnum: + return((double)(fix(x))); + + case t_bignum: + return(big_to_double(/* (struct bignum *) */x)); + + case t_ratio: + + /* vs_base=vs_top; */ + /* vs_push(x); */ + /* Lround(); */ + /* if (vs_base[0]!=small_fixnum(0)) */ + /* return number_to_double(vs_base[0])+number_to_double(vs_base[1]); */ + /* else */ + { + double dx,dy; + object xx,yy; + + for (xx=x->rat.rat_num,yy=x->rat.rat_den,dx=number_to_double(xx),dy=number_to_double(yy); + dx && dy && (!ISNORMAL(dx) || !ISNORMAL(dy));) { + + if (ISNORMAL(dx)) + dx*=0.5; + else { + xx=integer_divide1(xx,small_fixnum(2),0); + dx=number_to_double(xx); + } + + if (ISNORMAL(dy)) + dy*=0.5; + else { + yy=integer_divide1(yy,small_fixnum(2),0); + dy=number_to_double(yy); + } + + } + + return dx/dy; + } + + case t_shortfloat: + return((double)(sf(x))); + + case t_longfloat: + return(lf(x)); + + default: + wrong_type_argument(TSor_rational_float, x); + return(0.0); + } +} + +void +gcl_init_number(void) +{ + +#if !defined(IM_FIX_BASE) || defined(USE_SAFE_CDR) + FFN(fSallocate_bigger_fixnum_range)(-1024,1023); +#endif + + shortfloat_zero = alloc_object(t_shortfloat); + sf(shortfloat_zero) = (shortfloat)0.0; + longfloat_zero = alloc_object(t_longfloat); + lf(longfloat_zero) = (longfloat)0.0; + enter_mark_origin(&shortfloat_zero); + enter_mark_origin(&longfloat_zero); + + make_constant("MOST-POSITIVE-FIXNUM", + make_fixnum(MOST_POSITIVE_FIX)); + make_constant("MOST-NEGATIVE-FIXNUM", + make_fixnum(MOST_NEGATIVE_FIX)); + + gcl_init_big(); + gcl_init_num_pred(); + gcl_init_num_comp(); + gcl_init_num_arith(); + gcl_init_num_co(); + gcl_init_num_log(); + gcl_init_num_sfun(); + gcl_init_num_rand(); +} diff --git a/o/package.d b/o/package.d new file mode 100755 index 0000000..4831d2b --- /dev/null +++ b/o/package.d @@ -0,0 +1,1217 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +*/ + +/* + package.d +*/ + +#include +#include "include.h" + +#define HASHCOEF 12345 /* hashing coefficient */ + +void check_type_or_symbol_string_package(object *); + +#define INTERNAL 1 +#define EXTERNAL 2 +#define INHERITED 3 + +#define P_INTERNAL(x,j) ((x)->p.p_internal[(j) % (x)->p.p_internal_size]) +#define P_EXTERNAL(x,j) ((x)->p.p_external[(j) % (x)->p.p_external_size]) + + + + +static bool +member_string_equal(x, l) +object x, l; +{ + for (; type_of(l) == t_cons; l = l->c.c_cdr) + if (string_equal(x, l->c.c_car)) + return(TRUE); + return(FALSE); +} + +static bool +designate_package(object x,struct package *p) { + + switch(type_of(x)) { + case t_string: case t_symbol: + return string_equal(x,p->p_name) || member_string_equal(x, p->p_nicknames); + break; + case t_character: + return designate_package(coerce_to_string(x),p); + break; + case t_package: + return x==(object)p; + break; + default: + FEwrong_type_argument(TSor_symbol_string_package,x); + break; + } + return FALSE; + +} + +/* #define bad_package_name(a) (type_of(a)==t_string &&\ */ +/* (memchr((a)->st.st_self,'-',(a)->st.st_fillp) || \ */ +/* ((a)->st.st_self[0]=='*' && (a)->st.st_fillp==1))) */ + +#define check_package_designator(a) if (type_of(a)!=t_string && \ + type_of(a)!=t_character && \ + type_of(a)!=t_symbol && \ + type_of(a)!=t_package) \ + FEwrong_type_argument(TSor_symbol_string_package,(a)) +#define check_type_or_symbol_string_package(a) check_package_designator(*a) + +static void +rehash_pack(ptab,n,m) + object **ptab; + int *n,m; +{ object *ntab; + object *tab = *ptab; + object l,ll; + int k,i; + i=0; + k = *n; + {BEGIN_NO_INTERRUPT; + ntab= AR_ALLOC(alloc_contblock,m,object); + *ptab = ntab; + *n=m; + while(ic.c_car)%m; + ll=l->c.c_cdr; + l->c.c_cdr = ntab[j]; + ntab[j]=l; + l=ll; + } + END_NO_INTERRUPT;} +} + +/* some prime numbers suitable for package sizes */ + +static int package_sizes[]={ + 97,251, 509, 1021, 2039, 4093, 8191, 16381, + 32749, 65521, 131071, 262139, 524287, 1048573}; + +static int +suitable_package_size(n) +{int *i=package_sizes; + if (n>= 1000000) return 1048573; + while(*i < n) { i++;} + return *i;} + +/* + Make_package(n, ns, ul, isize , esize) 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 void +package_already(object); +static void +no_package(object); + +static object +make_package(n, ns, ul,isize,esize) +object n, ns, ul; +int isize,esize; +{ + + object x, y; + int i; + vs_mark; + { BEGIN_NO_INTERRUPT; + if (type_of(n) == t_symbol) { + vs_push(alloc_simple_string(n->s.s_fillp)); + vs_head->st.st_self = n->s.s_self; + n = vs_head; + } + if (type_of(n)==t_character) + n=coerce_to_string(n); + if (find_package(n) != Cnil) + package_already(n); + x = alloc_object(t_package); + x->p.p_name = n; + x->p.p_nicknames = Cnil; + x->p.p_shadowings = Cnil; + x->p.p_uselist = Cnil; + x->p.p_usedbylist = Cnil; + x->p.p_internal = NULL; + x->p.p_external = NULL; + x->p.p_internal_size = (isize ? isize : suitable_package_size(200)); + x->p.p_external_size = (esize ? esize : suitable_package_size(60)); + x->p.p_internal_fp =0; + x->p.p_external_fp =0; + + vs_push(x); + for (; !endp(ns); ns = ns->c.c_cdr) { + n = ns->c.c_car; + if (type_of(n) == t_symbol) { + vs_push(alloc_simple_string(n->s.s_fillp)); + vs_head->st.st_self = n->s.s_self; + n = vs_head; + } + if (type_of(n)==t_character) + n=coerce_to_string(n); + if (find_package(n) != Cnil) { + vs_reset; + package_already(n); + } + x->p.p_nicknames = make_cons(n, x->p.p_nicknames); + } + for (; !endp(ul); ul = ul->c.c_cdr) { + if (type_of(ul->c.c_car) == t_package) + y = ul->c.c_car; + else { + y = find_package(ul->c.c_car); + if (y == Cnil) + no_package(ul->c.c_car); + } + x->p.p_uselist = make_cons(y, x->p.p_uselist); + y->p.p_usedbylist = make_cons(x, y->p.p_usedbylist); + } + x->p.p_internal + = AR_ALLOC(alloc_contblock,x->p.p_internal_size,object); + for (i = 0; i < x->p.p_internal_size; i++) + x->p.p_internal[i] = Cnil; + x->p.p_external + = AR_ALLOC(alloc_contblock,x->p.p_external_size,object); + for (i = 0; i < x->p.p_external_size; i++) + x->p.p_external[i] = Cnil; + x->p.p_link = pack_pointer; + pack_pointer = &(x->p); + vs_reset; + END_NO_INTERRUPT;} + return(x); +} + +static void +use_package(object,object); + +static object +in_package(n, ns, ul,isize,esize) +object n, ns, ul; +int isize,esize; +{ + + object x, y; + vs_mark; + + x = find_package(n); + if (x == Cnil) { +#ifdef ANSI_COMMON_LISP + FEpackage_error(n,"No such package"); + return Cnil; +#else + x = make_package(n, ns, ul,isize,esize); + goto L; +#endif + } + if (isize) rehash_pack(&(x->p.p_internal), + &x->p.p_internal_size,isize); + for (; !endp(ns); ns = ns->c.c_cdr) { + n = ns->c.c_car; + if (type_of(n) == t_symbol) { + vs_push(alloc_simple_string(n->s.s_fillp)); + vs_head->st.st_self = n->s.s_self; + n = vs_head; + } + y = find_package(n); + if (x == y) + continue; + if (y != Cnil) + package_already(n); + x->p.p_nicknames = make_cons(n, x->p.p_nicknames); + } + for (; !endp(ul); ul = ul->c.c_cdr) + use_package(ul->c.c_car, x); +#ifndef ANSI_COMMON_LISP +L: +#endif + sLApackageA->s.s_dbind = x; + vs_reset; + return(x); +} + +static object +rename_package(x, n, ns) +object x, n, ns; +{ + + object y; + vs_mark; + + if (type_of(n) == t_symbol) { + vs_push(alloc_simple_string(n->s.s_fillp)); + vs_head->st.st_self = n->s.s_self; + n = vs_head; + } + if (type_of(n)==t_character) + n=coerce_to_string(n); + if (!(equal(x->p.p_name,n)) && + find_package(n) != Cnil) + package_already(n); + x->p.p_name = n; + x->p.p_nicknames = Cnil; + for (; !endp(ns); ns = ns->c.c_cdr) { + n = ns->c.c_car; + if (type_of(n) == t_symbol) { + vs_push(alloc_simple_string(n->s.s_fillp)); + vs_head->st.st_self = n->s.s_self; + n = vs_head; + } + if (type_of(n)==t_character) + n=coerce_to_string(n); + y = find_package(n); + if (x == y) + continue; + if (y != Cnil) + package_already(n); + x->p.p_nicknames = make_cons(n, x->p.p_nicknames); + } + vs_reset; + return(x); +} + + +/* + Find_package(n) seaches for a package with name n, + which is a string or a symbol. + If not so, an error is signaled. +*/ +object +find_package(n) +object n; +{ + struct package *p; + + check_package_designator(n); + for (p = pack_pointer; p != NULL; p = p->p_link) + if (designate_package(n,p)) + return ((object)p); + return(Cnil); +} + +static object +coerce_to_package(p) +object p; +{ + object pp; + + if (type_of(p) == t_package) + return(p); + pp = find_package(p); + if (pp == Cnil) + no_package(p); + return(pp); +} + +object +current_package() +{ + object x; + + x = symbol_value(sLApackageA); + if (type_of(x) != t_package) { + sLApackageA->s.s_dbind = user_package; + FEerror("The value of *PACKAGE*, ~S, was not a package.", + 1, x); + } + return(x); +} + +/* + Pack_hash(st) hashes string st + and returns the index for a hash table of a package. +*/ + +int +pack_hash(x) +object x; +{unsigned int h=0; + {int len=x->st.st_fillp; + char *s; +#define HADD(i,j,k,l) (h+=s[i],h+=s[j]<<8,h+=s[k]<<13,h+=s[l]<<23) +#define HADD2(i,j) (h+=s[i]<<5,h+=s[j]<<15) + s=x->st.st_self; + switch(len) { + case 0: break; + case 10: + case 9: HADD(1,4,6,8); HADD2(5,7); goto END; + case 8: HADD(1,3,5,7); HADD2(2,4); goto END; + case 7: HADD(1,3,4,5); HADD2(6,2); goto END; + case 6: HADD(1,3,4,5); HADD2(0,2); goto END; + case 5: h+= s[4] << 13; + case 4: h+= s[3] << 24; + case 3: h+= s[2]<< 16; + case 2: h+= s[1] << 8; + case 1: h+= s[0] ; + break; + default: + HADD(3,6,len-2,len-4); HADD2(1,len-1); + if (len > 15) {HADD2(7,10); + } + } + END: + h &= 0x7fffffff; + return(h); +}} + + + +/* + Intern(st, p) interns string st in package p. +*/ +object +intern(st, p) +object st, p; +{ + int j; + object x, *ip, *ep, l, ul; + vs_mark; + + {BEGIN_NO_INTERRUPT; + j = pack_hash(st); + ip = &P_INTERNAL(p ,j); +#define string_eq(a,b) \ + ((a)->st.st_fillp==(b)->st.st_fillp && \ + bcmp((a)->st.st_self,(b)->st.st_self,(a)->st.st_fillp)==0) + + for (l = *ip; type_of(l) == t_cons; l = l->c.c_cdr) + if (string_eq(l->c.c_car, st)) { + intern_flag = INTERNAL; + END_NO_INTERRUPT;return(l->c.c_car); + } + ep = &P_EXTERNAL(p,j); + for (l = *ep; type_of(l) == t_cons; l = l->c.c_cdr) + if (string_eq(l->c.c_car, st)) { + intern_flag = EXTERNAL; + END_NO_INTERRUPT;return(l->c.c_car); + } + for (ul=p->p.p_uselist; type_of(ul)==t_cons; ul=ul->c.c_cdr) + for (l = P_EXTERNAL(ul->c.c_car,j); + type_of(l) == t_cons; + l = l->c.c_cdr) + if (string_eq(l->c.c_car, st)) { + intern_flag = INHERITED; + END_NO_INTERRUPT;return(l->c.c_car); + } + x = make_symbol(st); + vs_push(x); + if (p == keyword_package) { + x->s.s_stype = (short)stp_constant; + x->s.s_dbind = x; + *ep = make_cons(x, *ep); + keyword_package->p.p_external_fp ++; + intern_flag = 0; + } else { + *ip = make_cons(x, *ip); + if (p->p.p_internal_fp++>(p->p.p_internal_size << 1)) + rehash_pack(&(p->p.p_internal),&p->p.p_internal_size, + suitable_package_size(p->p.p_internal_fp)); + intern_flag = 0; + } + if (x->s.s_hpack == Cnil) + x->s.s_hpack = p; + vs_reset; + END_NO_INTERRUPT;return(x); +}} + +/* + Find_symbol(st, p) searches for string st in package p. +*/ +object +find_symbol(st, p) +object st, p; +{ + int j; + object *ip, *ep, l, ul; + {BEGIN_NO_INTERRUPT; + if (type_of(st)==t_character) st=coerce_to_string(st); + j = pack_hash(st); + ip = &P_INTERNAL(p ,j); + for (l = *ip; type_of(l) == t_cons; l = l->c.c_cdr) + if (string_eq(l->c.c_car, st)) { + intern_flag = INTERNAL; + END_NO_INTERRUPT;return(l->c.c_car); + } + ep = &P_EXTERNAL(p,j); + for (l = *ep; type_of(l) == t_cons; l = l->c.c_cdr) + if (string_eq(l->c.c_car, st)) { + intern_flag = EXTERNAL; + END_NO_INTERRUPT;return(l->c.c_car); + } + for (ul=p->p.p_uselist; type_of(ul)==t_cons; ul=ul->c.c_cdr) + for (l = P_EXTERNAL(ul->c.c_car,j); + type_of(l) == t_cons; + l = l->c.c_cdr) + if (string_eq(l->c.c_car, st)) { + intern_flag = INHERITED; + END_NO_INTERRUPT;return(l->c.c_car); + } + intern_flag = 0; + END_NO_INTERRUPT;return(Cnil); +}} + +static bool +unintern(s, p) +object s, p; +{ + object x, y, l, *lp; + int j; + {BEGIN_NO_INTERRUPT; + j = pack_hash(s); + x = find_symbol(s, p); + if (intern_flag == INTERNAL && s == x) { + lp = &P_INTERNAL(p ,j); + if (member_eq(s, p->p.p_shadowings)) + goto L; + goto UNINTERN; + } + if (intern_flag == EXTERNAL && s == x) { + lp = &P_EXTERNAL(p,j); + if (member_eq(s, p->p.p_shadowings)) + goto L; + goto UNINTERN; + } + END_NO_INTERRUPT;return(FALSE); + +L: + x = OBJNULL; + for (l = p->p.p_uselist; type_of(l) == t_cons; l = l->c.c_cdr) { + y = find_symbol(s, l->c.c_car); + if (intern_flag == EXTERNAL) { + if (x == OBJNULL) + x = y; + else if (x != y) + FEpackage_error(p,"Cannot unintern the shadowing symbol"\ + "as it will produce a name conflict"); + } + } + delete_eq(s, &p->p.p_shadowings); + +UNINTERN: + delete_eq(s, lp); + if (s->s.s_hpack == p) + s->s.s_hpack = Cnil; + if ((enum stype)s->s.s_stype != stp_ordinary) + uninterned_list = make_cons(s, uninterned_list); + END_NO_INTERRUPT;return(TRUE); +}} + +void +export(s, p) +object s, p; +{ + object x; + int j; + object *ep, *ip, l; + +BEGIN: + ip = NULL; + j = pack_hash(s); + x = find_symbol(s, p); + if (intern_flag) { + if (x != s) { + import(s, p); /* signals an error */ + goto BEGIN; + } + if (intern_flag == INTERNAL) + ip = &P_INTERNAL(p ,j); + else if (intern_flag == EXTERNAL) + return; + } else + FEpackage_error(p,"Symbol not accessible."); + for (l = p->p.p_usedbylist; + type_of(l) == t_cons; + l = l->c.c_cdr) { + x = find_symbol(s, l->c.c_car); + if (intern_flag && s != x && + !member_eq(x, l->c.c_car->p.p_shadowings)) + FEpackage_error(p,"Cannot export symbol as it will produce a name conflict."); + } + if (ip != NULL) + {delete_eq(s, ip); + p->p.p_internal_fp--;} + ep = &P_EXTERNAL(p,j); + p->p.p_external_fp++; + *ep = make_cons(s, *ep); +} + +static void +unexport(s, p) +object s, p; +{ + object x, *ep, *ip; + int j; + + if (p == keyword_package) + FEpackage_error(p,"Cannot unexport a symbol from the keyword."); + x = find_symbol(s, p); + if (/* intern_flag != EXTERNAL || */ x != s) + FEpackage_error(p,"Symbol not in package."); +/* "Cannot unexport the symbol ~S~%\ */ +/* from ~S,~%\ */ +/* because the symbol is not an external symbol~%\ */ +/* of the package.", 2, s, p); */ + j = pack_hash(s); + ep = &P_EXTERNAL(p,j); + delete_eq(s, ep); + ip = &P_INTERNAL(p ,j); + p->p.p_internal_fp++; + *ip = make_cons(s, *ip); +} + +void +import(s, p) +object s, p; +{ + object x; + int j; + object *ip; + + x = find_symbol(s, p); + if (intern_flag) { + if (x != s) + FEpackage_error(p,"Cannot import symbol as it will produce a name conflict"); + if (intern_flag == INTERNAL || intern_flag == EXTERNAL) + return; + } + j = pack_hash(s); + ip = &P_INTERNAL(p ,j); + p->p.p_internal_fp++; + *ip = make_cons(s, *ip); +} + +static void +shadowing_import(s, p) +object s, p; +{ + object x, *ip; + + x = find_symbol(s, p); + if (intern_flag && intern_flag != INHERITED) { + if (x == s) { + if (!member_eq(x, p->p.p_shadowings)) + p->p.p_shadowings + = make_cons(x, p->p.p_shadowings); + return; + } + if(member_eq(x, p->p.p_shadowings)) + delete_eq(x, &p->p.p_shadowings); + if (intern_flag == INTERNAL) + delete_eq(x, &P_INTERNAL(p,pack_hash(x))); + else + delete_eq(x, &P_EXTERNAL(p ,pack_hash(x))); + if (x->s.s_hpack == p) + x->s.s_hpack = Cnil; + if ((enum stype)x->s.s_stype != stp_ordinary) + uninterned_list = make_cons(x, uninterned_list); + } + ip = &P_INTERNAL(p ,pack_hash(s)); + *ip = make_cons(s, *ip); + p->p.p_internal_fp++; + p->p.p_shadowings = make_cons(s, p->p.p_shadowings); +} + +static void +shadow(s, p) +object s, p; +{ + int j; + object *ip; + + if (type_of(s)==t_character) s=coerce_to_string(s); + find_symbol(s, p); + if (intern_flag == INTERNAL || intern_flag == EXTERNAL) { + p->p.p_shadowings = make_cons(s, p->p.p_shadowings); + return; + } + j = pack_hash(s); + ip = &P_INTERNAL(p ,j); + vs_push(make_symbol(s)); + vs_head->s.s_hpack = p; + *ip = make_cons(vs_head, *ip); + p->p.p_internal_fp++; + p->p.p_shadowings = make_cons(vs_head, p->p.p_shadowings); + vs_popp; +} + +static void +use_package(x0, p) +object x0, p; +{ + object x = x0; + int i; + object y, l; + + if (type_of(x) != t_package) { + x = find_package(x); + if (x == Cnil) + no_package(x0); + } + if (x == keyword_package) + FEpackage_error(x,"Cannot use keyword package."); + if (p == x) + return; + if (member_eq(x, p->p.p_uselist)) + return; + for (i = 0; i < x->p.p_external_size; i++) + for (l = P_EXTERNAL(x ,i); + type_of(l) == t_cons; + l = l->c.c_cdr) { + y = find_symbol(l->c.c_car, p); + if (intern_flag && l->c.c_car != y + && ! member_eq(y,p->p.p_shadowings) + ) + FEpackage_error(p,"Cannot use package as it will produce" + " a name conflict"); + } + p->p.p_uselist = make_cons(x, p->p.p_uselist); + x->p.p_usedbylist = make_cons(p, x->p.p_usedbylist); +} + +static void +unuse_package(x0, p) +object x0, p; +{ + object x = x0; + + if (type_of(x) != t_package) { + x = find_package(x); + if (x == Cnil) + no_package(x0); + } + delete_eq(x, &p->p.p_uselist); + delete_eq(p, &x->p.p_usedbylist); +} + + + +static object +delete_package(object n) { + + struct package *p,*pp; + object t; + + for (p = pack_pointer,pp=NULL; p != NULL; pp=p,p = p->p_link) + + if (designate_package(n,p)) { + + if (p->p_usedbylist!=Cnil) { + + FEpackage_error((object)p,"Package used by other packages."); + for (t=p->p_usedbylist;!endp(t);t=t->c.c_cdr) + unuse_package((object)p,t->c.c_car); + } + + if (p->p_uselist!=Cnil) { + for (t=p->p_uselist;!endp(t);t=t->c.c_cdr) + unuse_package(t->c.c_car,(object)p); + } + + p->p_name=Cnil; + + if (pp) + pp->p_link=p->p_link; + else + pack_pointer=p->p_link; + + return(Ct); + + } + + if (type_of(n)!=t_package) + FEpackage_error(n,"No such package."); + + return(Cnil); + +} + +/* (use `make_cons(lisp_package, Cnil)`) */ + + +@(defun make_package (pack_name + &key nicknames + (use Cnil) + (internal `small_fixnum(0)`) + (external `small_fixnum(0)`) + ) +@ + if (type_of(pack_name)==t_character) pack_name=coerce_to_string(pack_name); + check_type_or_string_symbol(&pack_name); + @(return `make_package(pack_name, nicknames, use, + fix(internal),fix(external))`) +@) + +@(defun in_package (pack_name &key nicknames (use Cnil use_sp) + (internal `small_fixnum(0)`) + (external `small_fixnum(0)`) + ) +@ + if (type_of(pack_name)==t_character) pack_name=coerce_to_string(pack_name); + check_type_or_string_symbol(&pack_name); + if (find_package(pack_name) == Cnil && !(use_sp)) + use = make_cons(lisp_package, Cnil); + @(return `in_package(pack_name, nicknames, use,fix(internal),fix(external))`) +@) + +LFD(Lfind_package)() +{ + check_arg(1); + + vs_base[0] = find_package(vs_base[0]); +} + +LFD(Ldelete_package)() +{ + check_arg(1); + + vs_base[0] = delete_package(vs_base[0]); +} + +LFD(Lpackage_name)() +{ + object t; + + check_arg(1); + + check_package_designator(vs_base[0]); + t=coerce_to_package(vs_base[0]); + vs_base[0]=t==Cnil ? t : t->p.p_name; + +} + +LFD(Lpackage_nicknames)() +{ + check_arg(1); + + check_package_designator(vs_base[0]); + vs_base[0] = coerce_to_package(vs_base[0]); + vs_base[0] = vs_base[0]->p.p_nicknames; +} + +@(defun rename_package (pack new_name &o new_nicknames) +@ + check_package_designator(pack); + pack = coerce_to_package(pack); + if (type_of(new_name)==t_character) new_name=coerce_to_string(new_name); + check_type_or_string_symbol(&new_name); + @(return `rename_package(pack, new_name, new_nicknames)`) +@) + +LFD(Lpackage_use_list)() +{ + check_arg(1); + + check_package_designator(vs_base[0]); + vs_base[0] = coerce_to_package(vs_base[0]); + vs_base[0] = vs_base[0]->p.p_uselist; +} + +LFD(Lpackage_used_by_list)() +{ + check_arg(1); + + check_package_designator(vs_base[0]); + vs_base[0] = coerce_to_package(vs_base[0]); + vs_base[0] = vs_base[0]->p.p_usedbylist; +} + +static void +FFN(Lpackage_shadowing_symbols)() +{ + check_arg(1); + + check_package_designator(vs_base[0]); + vs_base[0] = coerce_to_package(vs_base[0]); + vs_base[0] = vs_base[0]->p.p_shadowings; +} + +LFD(Llist_all_packages)() +{ + struct package *p; + int i; + + check_arg(0); + for (p = pack_pointer, i = 0; p != NULL; p = p->p_link, i++) + vs_push((object)p); + vs_push(Cnil); + while (i-- > 0) + stack_cons(); +} + +@(defun intern (strng &optional (p `current_package()`) &aux sym) +@ + check_type_string(&strng); + check_package_designator(p); + p = coerce_to_package(p); + sym = intern(strng, p); + if (intern_flag == INTERNAL) + @(return sym sKinternal) + if (intern_flag == EXTERNAL) + @(return sym sKexternal) + if (intern_flag == INHERITED) + @(return sym sKinherited) + @(return sym Cnil) +@) + +@(defun find_symbol (strng &optional (p `current_package()`)) + object x; +@ + check_type_string(&strng); + check_package_designator(p); + p = coerce_to_package(p); + x = find_symbol(strng, p); + if (intern_flag == INTERNAL) + @(return x sKinternal) + if (intern_flag == EXTERNAL) + @(return x sKexternal) + if (intern_flag == INHERITED) + @(return x sKinherited) + @(return Cnil Cnil) +@) + +@(defun unintern (symbl &optional (p `current_package()`)) +@ + check_type_sym(&symbl); + check_package_designator(p); + p = coerce_to_package(p); + if (unintern(symbl, p)) + @(return Ct) + else + @(return Cnil) +@) + +@(defun export (symbols &o (pack `current_package()`)) + object l; + +@ + check_package_designator(pack); + pack = coerce_to_package(pack); +BEGIN: + switch (type_of(symbols)) { + case t_symbol: + if (symbols == Cnil) + break; + export(symbols, pack); + break; + + case t_cons: + for (l = symbols; !endp(l); l = l->c.c_cdr) + export(l->c.c_car, pack); + break; + + default: + check_type_sym(&symbols); + goto BEGIN; + } + @(return Ct) +@) + +@(defun unexport (symbols &o (pack `current_package()`)) + object l; + +@ + check_package_designator(pack); + pack = coerce_to_package(pack); +BEGIN: + switch (type_of(symbols)) { + case t_symbol: + if (symbols == Cnil) + break; + unexport(symbols, pack); + break; + + case t_cons: + for (l = symbols; !endp(l); l = l->c.c_cdr) + unexport(l->c.c_car, pack); + break; + + default: + check_type_sym(&symbols); + goto BEGIN; + } + @(return Ct) +@) + +@(defun import (symbols &o (pack `current_package()`)) + object l; +@ + check_package_designator(pack); + pack = coerce_to_package(pack); +BEGIN: + switch (type_of(symbols)) { + case t_symbol: + if (symbols == Cnil) + break; + import(symbols, pack); + break; + + case t_cons: + for (l = symbols; !endp(l); l = l->c.c_cdr) + import(l->c.c_car, pack); + break; + + default: + check_type_sym(&symbols); + goto BEGIN; + } + @(return Ct) +@) + +@(defun shadowing_import (symbols &o (pack `current_package()`)) + object l; +@ + check_package_designator(pack); + pack = coerce_to_package(pack); +BEGIN: + switch (type_of(symbols)) { + case t_symbol: + if (symbols == Cnil) + break; + shadowing_import(symbols, pack); + break; + + case t_cons: + for (l = symbols; !endp(l); l = l->c.c_cdr) + shadowing_import(l->c.c_car, pack); + break; + + default: + check_type_sym(&symbols); + goto BEGIN; + } + @(return Ct) +@) + +@(defun shadow (symbols &o (pack `current_package()`)) + object l; +@ + check_package_designator(pack); + pack = coerce_to_package(pack); +BEGIN: + switch (type_of(symbols)) { + case t_symbol: + case t_string: + case t_character: + if (symbols == Cnil) + break; + shadow(symbols, pack); + break; + + case t_cons: + for (l = symbols; !endp(l); l = l->c.c_cdr) + shadow(l->c.c_car, pack); + break; + + default: + check_type_or_symbol_string(&symbols); + goto BEGIN; + } + @(return Ct) +@) + +@(defun use_package (pack &o (pa `current_package()`)) + object l; +@ + check_package_designator(pa); + pa = coerce_to_package(pa); +BEGIN: + switch (type_of(pack)) { + case t_symbol: + if (pack == Cnil) + break; + + case t_string: + case t_package: + case t_character: + use_package(pack, pa); + break; + + case t_cons: + for (l = pack; !endp(l); l = l->c.c_cdr) + use_package(l->c.c_car, pa); + break; + + default: + check_type_package(&pack); + goto BEGIN; + } + @(return Ct) +@) + +@(defun unuse_package (pack &o (pa `current_package()`)) + object l; +@ + check_package_designator(pa); + pa = coerce_to_package(pa); +BEGIN: + switch (type_of(pack)) { + case t_symbol: + if (pack == Cnil) + break; + + case t_string: + case t_package: + case t_character: + unuse_package(pack, pa); + break; + + case t_cons: + for (l = pack; !endp(l); l = l->c.c_cdr) + unuse_package(l->c.c_car, pa); + break; + + default: + check_type_package(&pack); + goto BEGIN; + } + @(return Ct) +@) + +LFD(siLpackage_internal)() +{ + + int j=0; + + check_arg(2); + check_type_package(&vs_base[0]); + if (type_of(vs_base[1]) != t_fixnum || + (j = fix(vs_base[1])) < 0 || j >= vs_base[0]->p.p_internal_size) + FEerror("~S is an illegal index to a package hashtable.", + 1, vs_base[1]); + vs_base[0] = P_INTERNAL(vs_base[0],j); + vs_popp; +} + +LFD(siLpackage_external)() +{ + int j=0; + + check_arg(2); + check_type_package(&vs_base[0]); + if (type_of(vs_base[1]) != t_fixnum || + (j = fix(vs_base[1])) < 0 || j >= vs_base[0]->p.p_external_size) + FEerror("~S is an illegal index to a package hashtable.", + 1, vs_base[1]); + vs_base[0] = P_EXTERNAL(vs_base[0],j); + vs_popp; +} + +static void +no_package(n) +object n; +{ + FEwrong_type_argument(TSor_symbol_string_package,n); +} + +static void +package_already(n) +object n; +{ + FEpackage_error(n,"A package with this name already exists."); +} + +static void +FFN(siLpackage_size)() +{object p; + p=vs_base[0]; + check_type_package(&p); + check_arg(1); + vs_base[0]=make_fixnum(p->p.p_external_size); + vs_base[1]=make_fixnum(p->p.p_internal_size); + vs_top=vs_base+2; + return; +} + +DEF_ORDINARY("EXTERNAL",sKexternal,KEYWORD,""); +DEF_ORDINARY("INHERITED",sKinherited,KEYWORD,""); +DEF_ORDINARY("INTERNAL",sKinternal,KEYWORD,""); +DEF_ORDINARY("NICKNAMES",sKnicknames,KEYWORD,""); +DEF_ORDINARY("USE",sKuse,KEYWORD,""); +DEFVAR("*PACKAGE*",sLApackageA,LISP,lisp_package,""); + + +void +gcl_init_package() +{ + + lisp_package + = make_package(make_simple_string("LISP"), + Cnil, Cnil,47,509); + user_package + = make_package(make_simple_string("USER"), + Cnil, + make_cons(lisp_package, Cnil),509,97); +#ifdef ANSI_COMMON_LISP + common_lisp_package + = make_package(make_simple_string("COMMON-LISP"), + Cnil, Cnil,47,509); +#endif + keyword_package + = make_package(make_simple_string("KEYWORD"), + Cnil, Cnil,11,509); + system_package + = make_package(make_simple_string("SYSTEM"), + make_cons(make_simple_string("SI"), + make_cons(make_simple_string("SYS"), + Cnil)), + make_cons(lisp_package, Cnil),251,157); + + /* There is no need to enter a package as a mark origin. */ + + uninterned_list = Cnil; + enter_mark_origin(&uninterned_list); +} + +void +gcl_init_package_function() +{ + make_function("MAKE-PACKAGE", Lmake_package); + make_function("DELETE-PACKAGE", Ldelete_package); + make_function("IN-PACKAGE", Lin_package); + make_function("FIND-PACKAGE", Lfind_package); + make_function("PACKAGE-NAME", Lpackage_name); + make_function("PACKAGE-NICKNAMES", Lpackage_nicknames); + make_function("RENAME-PACKAGE", Lrename_package); + make_function("PACKAGE-USE-LIST", Lpackage_use_list); + make_function("PACKAGE-USED-BY-LIST", Lpackage_used_by_list); + make_function("PACKAGE-SHADOWING-SYMBOLS",Lpackage_shadowing_symbols); + make_function("LIST-ALL-PACKAGES", Llist_all_packages); + make_function("INTERN", Lintern); + make_function("FIND-SYMBOL", Lfind_symbol); + make_function("UNINTERN", Lunintern); + make_function("EXPORT", Lexport); + make_function("UNEXPORT", Lunexport); + make_function("IMPORT", Limport); + make_function("SHADOWING-IMPORT", Lshadowing_import); + make_function("SHADOW", Lshadow); + make_function("USE-PACKAGE", Luse_package); + make_function("UNUSE-PACKAGE", Lunuse_package); + + make_si_function("PACKAGE-SIZE",siLpackage_size); + make_si_function("PACKAGE-INTERNAL", siLpackage_internal); + make_si_function("PACKAGE-EXTERNAL", siLpackage_external); +} diff --git a/o/pari_big.c b/o/pari_big.c new file mode 100755 index 0000000..73ca34f --- /dev/null +++ b/o/pari_big.c @@ -0,0 +1,565 @@ + /* Copyright William F. Schelter 1991 + Bignum routines. + + + +num_arith.c: add_int_big +num_arith.c: big_minus +num_arith.c: big_plus +num_arith.c: big_quotient_remainder +num_arith.c: big_sign +num_arith.c: big_times +num_arith.c: complement_big +num_arith.c: copy_big +num_arith.c: div_int_big +num_arith.c: mul_int_big +num_arith.c: normalize_big +num_arith.c: normalize_big_to_object +num_arith.c: stretch_big +num_arith.c: sub_int_big +num_comp.c: big_compare +num_comp.c: big_sign +num_log.c: big_sign +num_log.c: copy_to_big +num_log.c: normalize_big +num_log.c: normalize_big_to_object +num_log.c: stretch_big +num_pred.c: big_sign +number.c: big_to_double +predicate.c: big_compare +typespec.c: big_sign +print.d: big_minus +print.d: big_sign +print.d: big_zerop +print.d: copy_big +print.d: div_int_big +read.d: add_int_big +read.d: big_to_double +read.d: complement_big +read.d: mul_int_big +read.d: normalize_big +read.d: normalize_big_to_object + + */ + +#define BCOPY_BODY(x,y) \ +do { int *ucop = (int *)(x); \ + int *vcop = (int *) (y); \ + {int j = lgef(ucop); \ + while(--j >= 0) \ + { *vcop++ = *ucop++;}}}while (0) + +bcopy_body(x,y) + GEN x,y; +{BCOPY_BODY(x,y);} + + + +/* make a bignum with (most <<32 + least) */ +object +bignum2(most, least) +int most, least; +{ static plong u [4] + = {0x01010004 ,0x01010004, 0,0}; + GEN w; + int l; + if(most) {setlgef(u,4),l=4;} + else {l=3; setlgef(u,3);} + MP_START_LOW(w,u,l); + MP_NEXT_UP(w) = least; + if (most) MP_NEXT_UP(w) = most; + return make_integer(u); +} + + + +/* coerce a pari GEN to a bignum or fixnum */ + +object +make_integer(u) +GEN u; +{ int l = lgef(u); + if (l > (MP_CODE_WORDS+1) || + ( l == (MP_CODE_WORDS+1) && + (MP_ONLY_WORD(u) & (1<<31)) != 0 + && (MP_ONLY_WORD(u) == ( 1<<31) ? signe(u) > 0 : 1))) + { object ans ; + GEN w; + + { BEGIN_NO_INTERRUPT; + big_register_1->big.big_length = lg(u); + big_register_1->big.big_self = u; + ans = alloc_object(t_bignum); + ans->big.big_self = 0; + w = (plong *)alloc_relblock(lg(u)*sizeof(plong)); + /* may have been relocated */ + u = (GEN) big_register_1->big.big_self ; + ans->big.big_self = w; + ans->big.big_length = l; + BCOPY_BODY(u , w); + setlg(w,l); + END_NO_INTERRUPT;} + return ans; + } + else + if (signe(u) > 0) return make_fixnum(MP_ONLY_WORD(u)); + else + if (signe(u) < 0) return make_fixnum(-MP_ONLY_WORD(u)); + else + return(small_fixnum(0)); + } + + +static object +make_bignum(u) +GEN u; +{ BEGIN_NO_INTERRUPT; + { object ans = alloc_object(t_bignum); + GEN w; + ans->big.big_length = lg(u); + /* save u */ + ans->big.big_self = u; + w = (plong *)alloc_relblock(lg(u)*sizeof(plong)); + /* restore u */ + u = ans->big.big_self ; + ans->big.big_self = w; + BCOPY_BODY(u , ans->big.big_self); + END_NO_INTERRUPT; + return ans; + }} +static +big_zerop(x) + object x; +{ return (signe(MP(x))== 0);} + +big_compare(x, y) + object x,y; +{return cmpii(MP(x),MP(y));} + +object +big_minus(x) + object x; +{ object y; + setsigne(MP(x),-(signe(MP(x)))); + y = make_integer(MP(x)); + setsigne(MP(x),-(signe(MP(x)))); + return y; +} +static +gcopy_to_big(res,x) + GEN res; + object x; +{int l = (x)->big.big_length; + int lgres = lg(res); + if (l< lgres) + { BEGIN_NO_INTERRUPT; + big_register_1->big.big_length = lgres; + big_register_1->big.big_self = res; + (x)->big.big_self = (GEN) alloc_relblock(lgres*sizeof(int)); + (x)->big.big_length = lgres; + res = big_register_1->big.big_self ; + END_NO_INTERRUPT; + } + BCOPY_BODY(res,(x)->big.big_self); + if (l>lgres) + { setlg((x)->big.big_self, l);} +} + + +add_int_big(i, x) +int i; +object x; +{ + MPOP_DEST(x,addsi,i,MP(x)); +} +static +sub_int_big(i, x) +int i; +object x; +{ MPOP_DEST(x,subsi,i,MP(x)); +} + +mul_int_big(i, x) +int i; +object x; +{ MPOP_DEST(x,mulsi,i,MP(x)); +} + +/* + Div_int_big(i, x) destructively divides non-negative bignum x + by positive int i. + X will hold the quotient from the division. + Div_int_big(i, x) returns the remainder of the division. + I should be positive. + X should be non-negative. +*/ +static +div_int_big(i, x) +int i; +object x; +{ save_avma; + GEN res = divis(MP(x),i); + gcopy_to_big(res,x); + restore_avma; + return hiremainder; +} + + +static object +big_plus(x, y) +object x,y; +{ MPOP(return,addii,MP(x),MP(y)); +} + +static object +big_times(x, y) +object x,y; +{ + MPOP(return,mulii,MP(x),MP(y)); +} + + +static +big_quotient_remainder(x0, y0, qp, rp) + object x0,y0,*qp,*rp; +{ + GEN res,quot; + save_avma; + res = dvmdii(MP(x0),MP(y0),"); + *qp = make_integer(res); + *rp = make_integer(quot); + restore_avma; + return; + +} + + +double +big_to_double(x) + object x; +{ + double d, e; + GEN u = MP(x); + unsigned int *w; + int l; + e = 4.294967296e9; + + l = lgef(u); + MP_START_HIGH(w,(unsigned int *) u,l); + l = l - MP_CODE_WORDS; + + if (l == 0) return 0.0; + + d = (double) MP_NEXT_DOWN(w); + while (--l > 0) + {d = e*d + (double)(MP_NEXT_DOWN(w));} + if (signe(u)>0) return d; + else return -d; + } + + +object +normalize_big_to_object(x) + object x; +{ return make_integer(MP(x));} + + +static object copy_big(x) + object x; +{ + if (type_of(x)==t_bignum) + return make_bignum(MP(x)); + else FEerror("bignum expected",0); + +} + + +static object +copy_to_big(x) + object x; +{object y; + + if (type_of(x) == t_fixnum) { + save_avma; + y = make_bignum(stoi(fix(x))); + restore_avma; + } else if (type_of(x) == t_bignum) + y = copy_big(x); + else + FEerror("integer expected",0); + return(y); + } + + +/* return the power of x */ +GEN +powerii(x,y) + GEN x, y; +{ GEN ans = gun; + if (signe(y) < 0) FEerror("bad",0); + while (lgef(y) > 2){ + if (MP_LOW(y,lgef(y)) & 1) + { ans = mulii(ans,x);} + x = mulii(x,x); + y = shifti(y,-1);} + return ans; + } + + + +replace_copy1(x,y) + GEN y,x; +{ int j = lgef(x); + if (y && j <= lg(y)) + { x++; y++; + while (--j >0) + {*y++ = *x++;} + return 0;} + END: + return j*2*sizeof(GEN); +} + +/* doubles the length ! */ +GEN +replace_copy2(x,y) + GEN y,x; +{GEN yp = y; + int k,j = lgef(x); + k = j; + while (--j >=0) + {*yp++ = *x++;} + y[0] = INT_FLAG + k*2; + return y;} + +#define STOI(x,y) do{ \ + if (x ==0) { y[1]=2;} \ + else if((x)>0) {y[1]=0x1000003;y[2]=x;} \ + else{y[1]=0xff000003;y[2]= -x;}}while (0) + +/* actually y == 0 is not supposed to happen !*/ + +obj_replace_copy1(x,y) + object x; + GEN y; +{ int j ; + GEN xp; + { if (type_of(x) == t_bignum) + { j = lgef(MP(x)); + if (y && j <= lg(y)) + { xp=MP(x); + xp++; y++; + while (--j >0) + {*y++ = *xp++;} + return 0;}} + else + { if (y==0) return 3*2*sizeof(GEN) ; + STOI(fix(x),y); return 0;}} + END: + return j*2*sizeof(GEN); +} + +/* doubles the length ! */ +GEN +obj_replace_copy2(x,y) + object x; + GEN y; +{GEN yp = y; + GEN xp; + int k,j; + if (type_of(x) == t_bignum) + { j = lgef(MP(x)); + k = j; + xp = MP(x); + while (--j >=0) + {*yp++ = *xp++;} + y[0] = INT_FLAG + k*2;} + else {STOI(fix(x),yp); y[0] = INT_FLAG+3*2;} + return y;} + + +static GEN +otoi(x) + object x; +{if (type_of(x)==t_fixnum) return stoi(fix(x)); + if (type_of(x)==t_bignum) + return (MP(x)); + FEwrong_type_argument(sLinteger,x); + return 0; +} + +object +alloc_bignum_static(len) +int len; + { object ans = alloc_object(t_bignum); + GEN w; + ans->big.big_length = len; + ans->big.big_self = 0; + w = (GEN)AR_ALLOC(alloc_contblock,len,unsigned plong); + ans->big.big_self = w; + w[0] = INT_FLAG + len; + return ans; + } + + +GEN +setq_io(x,all,val) + GEN x; + object val; + object *all; +{int n= obj_replace_copy1(val,x); + if (n) + { *all = alloc_bignum_static(n/sizeof(int)); + return obj_replace_copy2(val,MP(*all)); + } + else return x;} + + +GEN +setq_ii(x,all,val) + GEN x; + GEN val; + object *all; +{int n= replace_copy1(val,x); + if (n) + { *all = alloc_bignum_static(n/sizeof(int)); + return replace_copy2(val,MP(*all)); + } + else return x;} + + + + +void +isetq_fix(var,s) + GEN var; + int s; +{/* if (var==0) FEerror("unitialized integer var",0); */ + STOI(s,var); +} + +GEN +icopy_bignum(a,y) + object a; + GEN y; +{ int *ucop = (int *)MP(a); + int *vcop = (int *) (y); + int j = lgef(ucop); + {while(--j >= 0) + { *vcop++ = *ucop++;} + setlg(y,a->big.big_length); + return y;}} + + +GEN +icopy_fixnum(a,y) + object a; + GEN y; + +{ int x= fix(a); + if(!x) return gzero; + y[0]=INT_FLAG+3; + if(x>0) {y[1]=0x1000003;y[2]=x;} + else{y[1]=0xff000003;y[2]= -x;} + return y; +} + + + + +GEN gnil,gzero,gun,gdeux,ghalf,gi; +plong lontyp[30]={0,0x10000,0x10000,1,1,1,1,2,1,0,2,2,1,1,1,0,1,1,1,1}; +unsigned plong hiremainder,overflow; + +#ifdef STANDALONE +#define FEerror printf +#define make_si_sfun(a,b,c) +#endif + +#define INITIAL_PARI_STACK 400 +char initial_pari_stack[400]; + +our_ulong bot= (our_ulong) initial_pari_stack; +our_ulong top = (our_ulong)(initial_pari_stack+INITIAL_PARI_STACK); +/* not initted */ +our_ulong avma= 0; + + +void +err(s) + int s; +{ switch (s) { + case errpile: + FEerror("Out of bignum stack space, (si::MULTIPLY-BIGNUM-STACK n) to grow",0); + case dvmer1: + case diver4: + case diver2: + case diver1: + FEerror("Divide by zero",0); + case muler1: + FEerror("Multiply overflow",0); + case moder1: + FEerror("Mod by 0",0); + default: + FEerror("Integer Arithmetic error",0); +}} + + + + +multiply_bignum_stack(n) + int n; +{ int parisize = n* (top - bot); + in_saved_avma = 0; + if (n> 1) + { if (bot != (our_ulong)initial_pari_stack) free(bot); + set_pari_stack(parisize); + } + return parisize; +} + +set_pari_stack(parisize) + int parisize; +{ + bot=(plong)malloc(parisize); + top = avma = bot + parisize; +} + +/* things to be done every start */ +gcl_init_big1() +{ + +} + +gcl_init_big() +{ + if (avma==0) + { + make_si_sfun("MULTIPLY-BIGNUM-STACK",multiply_bignum_stack, + ARGTYPE1(f_fixnum) | RESTYPE(f_fixnum)); + avma = top; + } + /* room for the permanent things */ + + gnil = cgeti(2);gnil[1]=2; setpere(gnil,255); + gzero = cgeti(2);gzero[1]=2; setpere(gzero, 255); + gun = stoi(1); setpere(gun, 255); + gdeux = stoi(2); setpere(gdeux, 255); + ghalf = cgetg(3,4);ghalf[1]=un;ghalf[2]=deux; setpere(ghalf, 255); + gi = cgetg(3,6); gi[1] = zero; gi[2] = un; setpere(gi, 255); + + /* set_pari_stack(BIGNUM_STACK_SIZE);*/ + } + + + + + + + + + + + + + + diff --git a/o/pari_num_log.c b/o/pari_num_log.c new file mode 100644 index 0000000..aad9408 --- /dev/null +++ b/o/pari_num_log.c @@ -0,0 +1,245 @@ +/* + big_log_op(x, y, op) performs the logical operation op onto + x and y, and return the result in x destructively. + + +*/ + +void minimize_lg(x) +GEN x; +{int j,i,lgx = lgef(x); + GEN u = x+2; + i = lgx; + i -= 2; + while (-- i >= 0) + { if (*u++) break; + } + j = lgx -i -3; + if (j) + { GEN v = x+2; + GEN w = v + j; + GEN lim = x+lgx; + while (w=0) + { unsigned int last = MP_NEXT_UP(w); + MP_NEXT_UP(v) = next - last ; + if (last > next) + { next -= 1 ;}} + return u;}} + +object big_log_op(x0,y0,op) +object x0,y0; + plong (*op)(); +{ int leadx,leady; + int result_length; + int lgx,lgy; + GEN x,y,u,up,result; + save_avma; + x = MP(x0); + y = (type_of(y0)==t_bignum ? MP(y0) : stoi(fix(y0))); + leadx = signe(x); + lgx=lgef(x); + if (leadx < 0) + x = complementi(x); + else leadx = 0; + + lgy = lgef(y); + leady = signe(y); + if (leady < 0) + y=complementi(y); + else leady = 0; + result_length = (lgx > lgy ? lgx : lgy); + u = result = cgeti(result_length); + setlgef(result,result_length); + MP_START_LOW(u,u,result_length); + result_length -= MP_CODE_WORDS; + + x += lgx; + y += lgy; + lgx -= MP_CODE_WORDS; + lgy -= MP_CODE_WORDS; + + while (--lgx >= 0) + { if (--lgy >= 0) + { MP_NEXT_UP(u) = (*op)(MP_NEXT_UP(x),MP_NEXT_UP(y));} + else MP_NEXT_UP(u) = (*op)(MP_NEXT_UP(x),leady); + } + /* lgx is now 0 */ + while (--lgy >= 0) + { MP_NEXT_UP(u) = (*op)(leadx,MP_NEXT_UP(y));} + {int leadresult = (*op)(leadx,leady); + if (leadresult < 0) + { result = complementi(result); + setsigne(result,-1);} + else setsigne(result,1);} + minimize_lg(result); + restore_avma; + gcopy_to_big(result,x0); + return x0; +} + +/* + x : fixnum or bignum (may be not normalized) + y : integer + returns + fixnum or bignum ( not normalized ) +*/ + +object big_log_op(); + +/* + x : fixnum or bignum (may be not normalized) + y : integer + returns + fixnum or bignum ( not normalized ) +*/ + + +static object +log_op(op,ignore) +int (*op)(); +void (*ignore)(); +{ + object x; + int narg, i, j; + + + narg = vs_top - vs_base; + if (narg < 2) too_few_arguments(); + i = narg; + while(--i >= 0) + if (type_of(vs_base[i]) == t_bignum) goto BIG_OP; + j = fix(vs_base[0]); + i = 1; + while (i < narg) { + j = (*op)(j, fix(vs_base[i])); + i++; + } + return(make_fixnum(j)); + +BIG_OP: + x = (object)copy_to_big(vs_base[0]); + vs_push(x); + i = 1; + {save_avma; + while (i < narg) { + x = (object)big_log_op(x, vs_base[i], op); + i++; + } + restore_avma;} + x = normalize_big_to_object(x); + vs_pop; + return(x); +} + + + +static int +big_bitp(x, p) +object x; +int p; +{ GEN u = MP(x); + int ans ; + int i = p /32; + if (signe(u) < 0) + { save_avma; + u = complementi(u); + restore_avma; + } + if (i < lgef(u) -MP_CODE_WORDS) + { ans = ((MP_ITH_WORD(u,i,lgef(u))) & (1 << p%32));} + else if (big_sign(x) < 0) ans = 1; + else ans = 0; + return ans; +} +/* these done without function call in above code ... */ +#define mp_b_clr_op (void *)0 +#define mp_b_set_op (void *)0 +#define mp_b_1_op (void *)0 +#define mp_b_2_op (void *)0 +#define mp_b_c1_op (void *)0 +#define mp_b_c2_op (void *)0 +#define mp_and_op (void *)0 +#define mp_ior_op (void *)0 +#define mp_xor_op (void *)0 +#define mp_eqv_op (void *)0 +#define mp_nand_op (void *)0 +#define mp_nor_op (void *)0 +#define mp_andc1_op (void *)0 +#define mp_andc2_op (void *)0 +#define mp_orc1_op (void *)0 +#define mp_orc2_op (void *)0 + +/* like integer-length in base 2 */ +gen_bitlength(u) + GEN u; +{ + GEN w; + int l = lg(u); + our_ulong high; + w = u; + MP_START_HIGH(u,u,l); + high = MP_NEXT_DOWN(u); + count = int_bit_length(high) ; + + l -= MP_CODE_WORDS; + + if (signe(w) < 0 && + high == (1 << (count -1))) + /* in the case of -(1<< n) + it is one less */ + { int ll = l; + int nzero = 0; + while (--ll > 0) + { if (MP_NEXT_DOWN(u)) + {nzero= 1; break;}} + if (nzero == 0) --count ;} + + count += 32* (l - 1); + return count; +} +/* number of 1's in 2's complement notation */ +gen_bitcount(u) + GEN u; + +{ save_avma; + if (signe(u) < 0) + { u = subsi(-1,u);} + count = 0; + {int leng = lgef(u); + MP_START_LOW(u,u,leng); + leng -= MP_CODE_WORDS; + while (--leng >= 0) + { count += count_int_bits(MP_NEXT_UP(u));}} + restore_avma; + return count; +} + + + + diff --git a/o/pathname.d b/o/pathname.d new file mode 100755 index 0000000..c508bab --- /dev/null +++ b/o/pathname.d @@ -0,0 +1,771 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +*/ + +/* + pathname.d + IMPLEMENTATION-DEPENTENT + + This file contains those functions that interpret namestrings. +*/ + +#include +#include "include.h" + + +object +make_pathname(host, device, directory, name, type, version) +object host, device, directory, name, type, version; +{ + object x; + + x = alloc_object(t_pathname); + x->pn.pn_host = host; + x->pn.pn_device = device; + x->pn.pn_directory = directory; + x->pn.pn_name = name; + x->pn.pn_type = type; + x->pn.pn_version = version; + return(x); +} + +static void +make_one(s, end) +char *s; +int end; +{ + int i; + +#ifdef UNIX + for (i = 0; i < end; i++) + token->st.st_self[i] = s[i]; +#endif +#ifdef AOSVS + + + +#endif + token->st.st_fillp = end; + vs_push(copy_simple_string(token)); +} + +/* The function below does not attempt to handle DOS pathnames + which use backslashes as directory separators. It needs + TLC from someone who feels pedantic. MJT */ + +/* !!!!! Bug Fix. NLG */ +object +parse_namestring(s, start, end, ep) +object s; +int start, end, *ep; +{ + int i, j, k, founddosdev = FALSE, oldstart=start, oldend=end, justdevice = FALSE; + int d; + object *vsp; + object x; + vs_mark; + +#ifndef IS_DIR_SEPARATOR +#define IS_DIR_SEPARATOR(x) (x == '/') +#endif + + *ep=oldend; + vsp = vs_top + 1; + for (;--end >= start && isspace((int)s->st.st_self[end]);); + + /* Check for a DOS path and process later */ + if ( ( (start+1) <= end) && (s->st.st_self[start+1] == ':' )) { + start+=2; + founddosdev = TRUE; + } + if ( start > end ) { + make_one(&s->st.st_self[0], 0); + justdevice = TRUE; + } else { + for (i = j = start; i <= end; ) { +#ifdef UNIX + if (IS_DIR_SEPARATOR(s->st.st_self[i])) { +#endif + if (j == start && i == start) { + i++; + vs_push(sKroot); + j = i; + continue; + } +#ifdef UNIX + if (i-j == 1 && s->st.st_self[j] == '.') { + vs_push(sKcurrent); + } else if (i-j == 1 && s->st.st_self[j] == '*') { + vs_push(sKwild); + } else if (i-j==2 && s->st.st_self[j]=='.' && s->st.st_self[j+1]=='.') { + vs_push(sKparent); + } else { + make_one(&s->st.st_self[j], i-j); + } +#endif + i++; + j = i; + } else { + i++; + } + } + *ep = i; + vs_push(Cnil); + while (vs_top > vsp) + stack_cons(); + if (i == j) { + /* no file and no type */ + vs_push(Cnil); + vs_push(Cnil); + goto L; + } + for (k = j, d = -1; k < i; k++) + if (s->st.st_self[k] == '.') + d = k; + if (d == -1) { + /* no file type */ +#ifdef UNIX + if (i-j == 1 && s->st.st_self[j] == '*') +#endif + vs_push(sKwild); + else + make_one(&s->st.st_self[j], i-j); + + vs_push(Cnil); + } else if (d == j) { + /* no file name */ + vs_push(Cnil); +#ifdef UNIX + if (i-d-1 == 1 && s->st.st_self[d+1] == '*') +#endif + vs_push(sKwild); + else + make_one(&s->st.st_self[d+1], i-d-1); + } else { + /* file name and file type */ +#ifdef UNIX + if (d-j == 1 && s->st.st_self[j] == '*') +#endif + vs_push(sKwild); + else { + make_one(&s->st.st_self[j], d-j); + } +#ifdef UNIX + if (i-d-1 == 1 && s->st.st_self[d+1] == '*') +#endif + vs_push(sKwild); + else + make_one(&s->st.st_self[d+1], i-d-1); + } + } +L: + /* Process DOS device name found earlier, build a string in a list and push it */ + if ( founddosdev ) { + /* Drive letter */ + token->st.st_self[0] = s->st.st_self[oldstart]; + /* Colon */ + token->st.st_self[1] = s->st.st_self[oldstart+1]; + /* Fill pointer */ + token->st.st_fillp = 2; + /* Push */ + vs_push(make_cons(copy_simple_string(token),Cnil)); + } else { + /* No device name */ + vs_push(Cnil); + } + if ( justdevice ) { + x = make_pathname ( Cnil, vs_top[-1], Cnil, Cnil, Cnil, Cnil ); + } else { + x = make_pathname ( Cnil, vs_top[-1], vs_top[-4], vs_top[-3], vs_top[-2], Cnil ); + } + vs_reset; + return(x); +} + +object +coerce_to_pathname(x) +object x; +{ + object y; + int e; + +L: + switch (type_of(x)) { + case t_symbol: + case t_string: + /* !!!!! Bug Fix. NLG */ + y = parse_namestring(x, 0, x->st.st_fillp, &e); + if (y == OBJNULL || e != x->st.st_fillp) + goto CANNOT_COERCE; + return(y); + + case t_pathname: + return(x); + + case t_stream: + switch (x->sm.sm_mode) { + case smm_input: + case smm_output: + case smm_probe: + case smm_io: + x = x->sm.sm_object1; + /* + The file was stored in sm.sm_object1. + See open. + */ + goto L; + + case smm_synonym: + x = symbol_value(x->sm.sm_object0); + goto L; + + default: + goto CANNOT_COERCE; + } + + default: + CANNOT_COERCE: + FEerror("~S cannot be coerced to a pathname.", 1, x); + return(Cnil); + } +} + +static object +default_device(host) +object host; +{ + return(Cnil); + /* not implemented yet */ +} + +object +merge_pathnames(path, defaults, default_version) +object path, defaults, default_version; +{ + object host, device, directory, name, type, version; + + if (path->pn.pn_host == Cnil) + host = defaults->pn.pn_host; + else + host = path->pn.pn_host; + if (path->pn.pn_device == Cnil) + if (path->pn.pn_host == Cnil) + device = defaults->pn.pn_device; + else if (path->pn.pn_host == defaults->pn.pn_host) + device = defaults->pn.pn_device; + else + device = default_device(path->pn.pn_host); + else + device = path->pn.pn_device; + + if (defaults->pn.pn_directory==Cnil || + (type_of(path->pn.pn_directory)==t_cons + && path->pn.pn_directory->c.c_car==sKroot)) + directory=path->pn.pn_directory; + else + directory=path->pn.pn_directory==Cnil ? + defaults->pn.pn_directory : + append(defaults->pn.pn_directory,path->pn.pn_directory); + + if (path->pn.pn_name == Cnil) + name = defaults->pn.pn_name; + else + name = path->pn.pn_name; + if (path->pn.pn_type == Cnil) + type = defaults->pn.pn_type; + else + type = path->pn.pn_type; + version = Cnil; + /* + In this implimentation, version is not counted + */ + return(make_pathname(host,device,directory,name,type,version)); +} + +/* + Namestring(x) converts a pathname to a namestring. +*/ +object +namestring(x) +object x; +{ + + int i, j; + object l, y; + + i = 0; + + l = x->pn.pn_device; + if (endp(l)) { + goto D; + } + y = l->c.c_car; + y = coerce_to_string(y); + for (j = 0; j < y->st.st_fillp; j++) { + token->st.st_self[i++] = y->st.st_self[j]; + } + +D: l = x->pn.pn_directory; + if (endp(l)) + goto L; + y = l->c.c_car; + if (y == sKroot) { +#ifdef UNIX + token->st.st_self[i++] = '/'; +#endif + l = l->c.c_cdr; + } + for (; !endp(l); l = l->c.c_cdr) { + y = l->c.c_car; +#ifdef UNIX + if (y == sKcurrent) { + token->st.st_self[i++] = '.'; + token->st.st_self[i++] = '/'; + continue; + } else if (y == sKwild) { + token->st.st_self[i++] = '*'; + token->st.st_self[i++] = '/'; + continue; + } else if (y == sKparent) { + token->st.st_self[i++] = '.'; + token->st.st_self[i++] = '.'; + token->st.st_self[i++] = '/'; + continue; + } +#endif + y = coerce_to_string(y); + for (j = 0; j < y->st.st_fillp; j++) + token->st.st_self[i++] + = y->st.st_self[j]; +#ifdef UNIX + token->st.st_self[i++] = '/'; +#endif +#ifdef AOSVS + +#endif + } +L: + y = x->pn.pn_name; + if (y == Cnil) + goto M; + if (y == sKwild) { +#ifdef UNIX + token->st.st_self[i++] = '*'; +#endif +#ifdef AOSVS + +#endif + goto M; + } + if (type_of(y) != t_string) + FEerror("~S is an illegal pathname name.", 1, y); + for (j = 0; j < y->st.st_fillp; j++) + token->st.st_self[i++] = y->st.st_self[j]; +M: + y = x->pn.pn_type; + if (y == Cnil) + goto N; + if (y == sKwild) { + token->st.st_self[i++] = '.'; +#ifdef UNIX + token->st.st_self[i++] = '*'; +#endif +#ifdef AOSVS + +#endif + goto N; + } + if (type_of(y) != t_string) + FEerror("~S is an illegal pathname name.", 1, y); + token->st.st_self[i++] = '.'; + for (j = 0; j < y->st.st_fillp; j++) + token->st.st_self[i++] = y->st.st_self[j]; +N: + token->st.st_fillp = i; +#ifdef FIX_FILENAME + {char buf[MAXPATHLEN]; + if (i > MAXPATHLEN-1) i =MAXPATHLEN-1; + memcpy(buf,token->st.st_self,i); + buf[i]=0; + FIX_FILENAME(x,buf); + return (make_simple_string(buf)); + } +#endif + return(copy_simple_string(token)); +} + +object +coerce_to_namestring(x) +object x; +{ + +L: + switch (type_of(x)) { + case t_symbol: + {BEGIN_NO_INTERRUPT; + vs_push(alloc_simple_string(x->s.s_fillp)); + /* By Nick Gall */ + vs_head->st.st_self = alloc_relblock(x->s.s_fillp); + { + int i; + for (i = 0; i < x->s.s_fillp; i++) + vs_head->st.st_self[i] = x->s.s_self[i]; + } + END_NO_INTERRUPT;} + return(vs_pop); + + case t_string: + return(x); + + case t_pathname: + return(namestring(x)); + + case t_stream: + switch (x->sm.sm_mode) { + case smm_input: + case smm_output: + case smm_probe: + case smm_io: + x = x->sm.sm_object1; + /* + The file was stored in sm.sm_object1. + See open. + */ + goto L; + + case smm_synonym: + x = symbol_value(x->sm.sm_object0); + goto L; + + default: + goto CANNOT_COERCE; + } + + default: + CANNOT_COERCE: + FEerror("~S cannot be coerced to a namestring.", 1, x); + return(Cnil); + } +} + +LFD(Lpathname)(void) +{ + check_arg(1); + check_type_or_pathname_string_symbol_stream(&vs_base[0]); + vs_base[0] = coerce_to_pathname(vs_base[0]); +} + +@(defun parse_namestring (thing + &o host + (defaults `symbol_value(Vdefault_pathname_defaults)`) + &k start end junk_allowed + &a x y) + int s, e, ee; +@ + check_type_or_pathname_string_symbol_stream(&thing); + check_type_or_pathname_string_symbol_stream(&defaults); + defaults = coerce_to_pathname(defaults); + x = thing; +L: + switch (type_of(x)) { + case t_symbol: + case t_string: + get_string_start_end(x, start, end, &s, &e); + for (; s < e && isspace((int)x->st.st_self[s]); s++) + ; + y + /* !!!!! Bug Fix. NLG */ + = parse_namestring(x, + s, + e - s, + &ee); + if (junk_allowed == Cnil) { + for (; ee < e - s; ee++) + if (!isspace((int)x->st.st_self[s + ee])) + break; + if (y == OBJNULL || ee != e - s) + FEerror("Cannot parse the namestring ~S~%\ +from ~S to ~S.", + 3, x, start, end); + } else + if (y == OBJNULL) + @(return Cnil `make_fixnum(s + ee)`) + start = make_fixnum(s + ee); + break; + + case t_pathname: + y = x; + break; + + case t_stream: + switch (x->sm.sm_mode) { + case smm_input: + case smm_output: + case smm_probe: + case smm_io: + x = x->sm.sm_object1; + /* + The file was stored in sm.sm_object1. + See open. + */ + goto L; + + case smm_synonym: + x = symbol_value(x->sm.sm_object0); + goto L; + + default: + goto CANNOT_PARSE; + } + + default: + CANNOT_PARSE: + FEerror("Cannot parse the namestring ~S.", 1, x); + } + if (host != Cnil && y->pn.pn_host != Cnil && + host != y->pn.pn_host) + FEerror("The hosts ~S and ~S do not match.", + 2, host, y->pn.pn_host); + @(return y start) +@) + +@(defun merge_pathnames (path + &o (defaults `symbol_value(Vdefault_pathname_defaults)`) + (default_version sKnewest)) +@ + check_type_or_pathname_string_symbol_stream(&path); + check_type_or_pathname_string_symbol_stream(&defaults); + path = coerce_to_pathname(path); + defaults = coerce_to_pathname(defaults); + @(return `merge_pathnames(path, defaults, default_version)`) +@) + +@(defun make_pathname (&key + (host `Cnil` host_supplied_p) + (device `Cnil` device_supplied_p) + (directory `Cnil` directory_supplied_p) + (name `Cnil` name_supplied_p) + (type `Cnil` type_supplied_p) + (version `Cnil` version_supplied_p) + defaults + &aux x) +@ + if ( defaults == Cnil ) { + defaults = symbol_value ( Vdefault_pathname_defaults ); + defaults = coerce_to_pathname ( defaults ); + defaults = make_pathname ( defaults->pn.pn_host, + Cnil, Cnil, Cnil, Cnil, Cnil); + } else { + defaults = coerce_to_pathname(defaults); + } + x = make_pathname(host, device, directory, name, type, version); + x = merge_pathnames(x, defaults, Cnil); + if ( host_supplied_p) x->pn.pn_host = host; + if (device_supplied_p) x->pn.pn_device = device; + if (directory_supplied_p) x->pn.pn_directory = directory; + if (name_supplied_p) x->pn.pn_name = name; + if (type_supplied_p) x->pn.pn_type = type; + if (version_supplied_p) x->pn.pn_version = version; + @(return x) +@) + +LFD(Lpathnamep)(void) +{ + check_arg(1); + + if (type_of(vs_base[0]) == t_pathname) + vs_base[0] = Ct; + else + vs_base[0] = Cnil; +} + +LFD(Lpathname_host)(void) +{ + check_arg(1); + + check_type_or_pathname_string_symbol_stream(&vs_base[0]); + vs_base[0] = coerce_to_pathname(vs_base[0]); + vs_base[0] = vs_base[0]->pn.pn_host; +} + +LFD(Lpathname_device)(void) +{ + check_arg(1); + + check_type_or_pathname_string_symbol_stream(&vs_base[0]); + vs_base[0] = coerce_to_pathname(vs_base[0]); + vs_base[0] = vs_base[0]->pn.pn_device; +} + +LFD(Lpathname_directory)(void) +{ + check_arg(1); + + check_type_or_pathname_string_symbol_stream(&vs_base[0]); + vs_base[0] = coerce_to_pathname(vs_base[0]); + vs_base[0] = vs_base[0]->pn.pn_directory; +} + +LFD(Lpathname_name)(void) +{ + check_arg(1); + + check_type_or_pathname_string_symbol_stream(&vs_base[0]); + vs_base[0] = coerce_to_pathname(vs_base[0]); + vs_base[0] = vs_base[0]->pn.pn_name; +} + +LFD(Lpathname_type)(void) +{ + check_arg(1); + + check_type_or_pathname_string_symbol_stream(&vs_base[0]); + vs_base[0] = coerce_to_pathname(vs_base[0]); + vs_base[0] = vs_base[0]->pn.pn_type; +} + +LFD(Lpathname_version)(void) +{ + check_arg(1); + + check_type_or_pathname_string_symbol_stream(&vs_base[0]); + vs_base[0] = coerce_to_pathname(vs_base[0]); + vs_base[0] = vs_base[0]->pn.pn_version; +} + +LFD(Lnamestring)(void) +{ + check_arg(1); + + check_type_or_pathname_string_symbol_stream(&vs_base[0]); + vs_base[0] = coerce_to_namestring(vs_base[0]); +} + +LFD(Lfile_namestring)(void) +{ + check_arg(1); + + check_type_or_pathname_string_symbol_stream(&vs_base[0]); + vs_base[0] = coerce_to_pathname(vs_base[0]); + vs_base[0] + = make_pathname(Cnil, Cnil, Cnil, + vs_base[0]->pn.pn_name, + vs_base[0]->pn.pn_type, + vs_base[0]->pn.pn_version); + vs_base[0] = namestring(vs_base[0]); +} + +LFD(Ldirectory_namestring)(void) +{ + check_arg(1); + + check_type_or_pathname_string_symbol_stream(&vs_base[0]); + vs_base[0] = coerce_to_pathname(vs_base[0]); + vs_base[0] + = make_pathname(Cnil, Cnil, + vs_base[0]->pn.pn_directory, + Cnil, Cnil, Cnil); + vs_base[0] = namestring(vs_base[0]); +} + +LFD(Lhost_namestring)(void) +{ + check_arg(1); + + check_type_or_pathname_string_symbol_stream(&vs_base[0]); + vs_base[0] = coerce_to_pathname(vs_base[0]); + vs_base[0] = vs_base[0]->pn.pn_host; + if (vs_base[0] == Cnil || vs_base[0] == sKwild) + vs_base[0] = make_simple_string(""); +} + +@(defun enough_namestring (path + &o (defaults `symbol_value(Vdefault_pathname_defaults)`)) +@ + check_type_or_pathname_string_symbol_stream(&path); + check_type_or_pathname_string_symbol_stream(&defaults); + defaults = coerce_to_pathname(defaults); + path = coerce_to_pathname(path); + path + = make_pathname(equalp(path->pn.pn_host, defaults->pn.pn_host) ? + Cnil : path->pn.pn_host, + equalp(path->pn.pn_device, + defaults->pn.pn_device) ? + Cnil : path->pn.pn_device, + equalp(path->pn.pn_directory, + defaults->pn.pn_directory) ? + Cnil : path->pn.pn_directory, + equalp(path->pn.pn_name, defaults->pn.pn_name) ? + Cnil : path->pn.pn_name, + equalp(path->pn.pn_type, defaults->pn.pn_type) ? + Cnil : path->pn.pn_type, + equalp(path->pn.pn_version, + defaults->pn.pn_version) ? + Cnil : path->pn.pn_version); + @(return `namestring(path)`) +@) + +void +gcl_init_pathname(void) +{ + Vdefault_pathname_defaults = + make_special("*DEFAULT-PATHNAME-DEFAULTS*", + make_pathname(Cnil, Cnil, Cnil, Cnil, Cnil, Cnil)); + + sKwild = make_keyword("WILD"); + sKnewest = make_keyword("NEWEST"); + + sKstart = make_keyword("START"); + sKend = make_keyword("END"); + sKjunk_allowed = make_keyword("JUNK-ALLOWED"); + + sKhost = make_keyword("HOST"); + sKdevice = make_keyword("DEVICE"); + sKdirectory = make_keyword("DIRECTORY"); + sKname = make_keyword("NAME"); + sKtype = make_keyword("TYPE"); + sKversion = make_keyword("VERSION"); + sKdefaults = make_keyword("DEFAULTS"); + + sKroot = make_keyword("ROOT"); + sKcurrent = make_keyword("CURRENT"); + sKparent = make_keyword("PARENT"); + sKper = make_keyword("PER"); +} + +void +gcl_init_pathname_function() +{ + make_function("PATHNAME", Lpathname); + make_function("PARSE-NAMESTRING", Lparse_namestring); + make_function("MERGE-PATHNAMES", Lmerge_pathnames); + make_function("MAKE-PATHNAME", Lmake_pathname); + make_function("PATHNAMEP", Lpathnamep); + make_function("PATHNAME-HOST", Lpathname_host); + make_function("PATHNAME-DEVICE", Lpathname_device); + make_function("PATHNAME-DIRECTORY", Lpathname_directory); + make_function("PATHNAME-NAME", Lpathname_name); + make_function("PATHNAME-TYPE", Lpathname_type); + make_function("PATHNAME-VERSION", Lpathname_version); + make_function("NAMESTRING", Lnamestring); + make_function("FILE-NAMESTRING", Lfile_namestring); + make_function("DIRECTORY-NAMESTRING", Ldirectory_namestring); + make_function("HOST-NAMESTRING", Lhost_namestring); + make_function("ENOUGH-NAMESTRING", Lenough_namestring); +} diff --git a/o/peculiar.c b/o/peculiar.c new file mode 100755 index 0000000..d35ef4f --- /dev/null +++ b/o/peculiar.c @@ -0,0 +1,37 @@ +#ifndef PECULIAR_MACHINE + +#define BIGM (int)((((unsigned int)(-1))/2)) + +int ONEM = -1; +int Bigm = BIGM; +int Smallm = -BIGM-1; +int Seven = 7; +int Three = 3; + +main(void) +{ +#define BIGM (int)((((unsigned int)(-1))/2)) + { + int ONEM = -1; + int Bixsgm = BIGM; + int Smallm = -BIGM-1; + int Seven = 7; + int Three = 3; + if ( (Smallm / Seven) < 0 + && (Smallm / (-Seven)) > 0 + && (Bigm / (-Seven)) < 0 + && ((-Seven) / Three) == -2 + && (Seven / (-Three)) == -2 + && ((-Seven)/ (-Three)) == 2) + { printf("#define TRUNCATE_USE_C\n"); + + + } + printf("%d\n",(Smallm/-1)); + }} +#endif + + + + + diff --git a/o/plt.c b/o/plt.c new file mode 100644 index 0000000..1c55af2 --- /dev/null +++ b/o/plt.c @@ -0,0 +1,202 @@ +#include +#include +#include +#include +#include +#include +#include +#include + +#include "include.h" + +typedef struct { + const char *n; + unsigned long ad; +} Plt; + +#ifdef LEADING_UNDERSCORE +#define stn(a_) (*(a_)=='_' ? (a_)+1 : (a_)) +#else +#define stn(a_) a_ +#endif + +static int +pltcomp(const void *v1,const void *v2) { + const Plt *p1=v1,*p2=v2; + + return strcmp(p1->n,p2->n); + +} + +extern int mcount(); +extern int _mcount(); +extern int __divdi3(); +extern int __moddi3(); +extern int __udivdi3(); +extern int __umoddi3(); +extern void sincos(double,double *,double *); +extern int __divsi3(); +extern int __modsi3(); +extern int __udivsi3(); +extern int __umodsi3(); +extern int $$divI(); +extern int $$divU(); +extern int $$remI(); +extern int $$remU(); +extern int __divq(); +extern int __divqu(); +extern int __remq(); +extern int __remqu(); + +#define MY_PLT(a_) {#a_,(unsigned long)(void *)a_} +static Plt mplt[]={ + /* This is an attempt to at least capture the addresses to + which the compiler directly refers in C code. (Some symbols + are not explicitly mentioned in the C source but are + generated by gcc, usually in a platform specific way). At + the time of this writing, these symbols alone are + sufficient for compiling maxima,acl2,and axiom on x86. + This table is not (currently at least) consulted in + actuality -- the mere mention of the symbols here (at + present) ensures that the symbols are assigned values by + the linker, which are used preferentially to these values + in sfasli.c. FIXME -- this should be made synchronous with + compiler changes; sort the list automatically. SORT THIS + LIST BY HAND FOR THE TIME BEING. */ +#ifndef _WIN32 +# include "plt.h" +#endif +}; + +object sSAplt_tableA; +DEFVAR("*PLT-TABLE*",sSAplt_tableA,SI,Cnil,""); + +static int +arsort(const void *v1,const void *v2) { + const object *op1=v1,*op2=v2; + object o1=*op1,o2=*op2; + int j; + + o1=o1->c.c_car; + o2=o2->c.c_car; + if ((j=strncmp(o1->st.st_self, + o2->st.st_self, + o1->st.st_dimst.st_dim ? + o1->st.st_dim : o2->st.st_dim))) + return j; + j=o1->st.st_dim-o2->st.st_dim; + return j>0 ? 1 : (!j ? 0 : -1); + +} + +static int +arsearch(const void *v1,const void *v2) { + const char *s=v1; + const object *op=v2; + + int j; + if ((j=strncmp(s,(*op)->c.c_car->st.st_self,(*op)->c.c_car->st.st_dim))) + return j; + j=strlen(s)-(*op)->c.c_car->st.st_dim; + return j>0 ? 1 : (!j ? 0 : -1); + +} + +int +parse_plt() { + + FILE *f; + char b[1024],b1[1024]; + unsigned i,n,j; + unsigned long u; +#ifdef _WIN32 + char *exe_start = NULL; /* point to start of .exe */ +#endif + char *c,*d; + object st,fi,li,ar,*op; + Plt *p=mplt,*pe=p+sizeof(mplt)/sizeof(*mplt); + struct stat ss; + + if (snprintf(b,sizeof(b),"%s",kcl_self)<=0) + FEerror("Cannot write map filename",0); +#ifdef _WIN32 + exe_start = strstr ( b, ".exe" ); + if ( NULL != exe_start ) *exe_start = '\0'; +#endif + c=b+strlen(b); + if (sizeof(b)-(c-b)<5) + FEerror("Cannot write map filename",0); + strcpy(c,"_map"); + strcpy(b1,b); + if (stat(b1,&ss)) + return 0; + if (!(f=fopen(b1,"r"))) + FEerror("Cannot open map file", 0); + for (i=j=0,li=Cnil;fgets(b,sizeof(b),f);) { + if (!memchr(b,10,sizeof(b)-1)) + FEerror("plt buffer too small", 0); + if (!memcmp(b," .plt",4)) { + i=1; + continue; + } + if (*b!=' ' || b[1]!=' ' || !i) { + i=0; + continue; + } + if (sscanf(b,"%lx%n",&u,&n)!=1) + FEerror("Cannot read address", 0); + for (c=b+n;*c==32;c++); + for (d=c;*d!='@' && *d!='\r' && *d!='\n';d++); + *d=0; + st=make_simple_string(c); + fi=make_fixnum(u); + li=make_cons(make_cons(st,fi),li); + j++; + } + fclose(f); + unlink(b1); + ar=fSmake_vector1_1(j,aet_object,Cnil); + for (;j && !endp(li);li=li->c.c_cdr) + ar->v.v_self[--j]=li->c.c_car; + + if (j || !endp(li)) + FEerror("plt list mismatch", 0); + qsort(ar->v.v_self,ar->v.v_dim,sizeof(*ar->v.v_self),arsort); + + for (;pn,ar->v.v_self,ar->v.v_dim,sizeof(*ar->v.v_self),arsearch)) && + (*op)->c.c_cdr->FIX.FIXVAL != p->ad) + FEerror("plt/ld address mismatch",0); + + sSAplt_tableA->s.s_dbind=ar; + + return 0; + +} + + + +int +my_plt(const char *s,unsigned long *v) { + + Plt *p=mplt,*pe=p+sizeof(mplt)/sizeof(*mplt),tp; + object *op; + + if (sSAplt_tableA->s.s_dbind && + (op=bsearch(s,sSAplt_tableA->s.s_dbind->v.v_self, + sSAplt_tableA->s.s_dbind->v.v_dim, + sizeof(*sSAplt_tableA->s.s_dbind->v.v_self), + arsearch))) { + *v=(*op)->c.c_cdr->FIX.FIXVAL; + return 0; + } + + tp.n=stn(s); + if ((p=bsearch(&tp,p,pe-p,sizeof(*p),pltcomp))) { + *v=p->ad; + return 0; + } + + return -1; + +} diff --git a/o/plttest.c b/o/plttest.c new file mode 100644 index 0000000..1c47dbd --- /dev/null +++ b/o/plttest.c @@ -0,0 +1,86 @@ +#include +#include +#include +#include +#include + +/* We try here to compile in function addresses to which it is known + that the compiler will make *direct* reference. 20040308 CM */ + +#if defined (__APPLE__) && defined (__MACH__) +#define DARWIN +#endif + +#ifndef DARWIN +extern int _mcount(); +#define mmcount _mcount +extern void sincos(double,double *,double *); +#endif + +int +main(int argc,char * argv[],char *envp[]) { + + FILE *f=NULL; + char ch=0; + jmp_buf env; + double d=0.1; + long l; + unsigned long ul; + + sscanf(argv[1],"%lf",&d); + bzero(&env,sizeof(env)); + memset(&env,0,sizeof(env)); + + ul=*(unsigned long *)envp; + ul=ul%(ul>>(ul & 0x3)); + l=*(long *)argv; + l=l%(l<<(l & 0x7)); + l/=ul/l; + l/=((long)ul)/l; + + ch=getc(f); + ch&=putc(ch,f); + ch&=feof(f); + + f=fdopen(l,"r"); + l=read(l,&l,sizeof(l)); + l=write(l,&l,sizeof(l)); + +#ifndef DARWIN + ch&=mmcount(); +#endif + + setjmp(env); + + d=cos(d); + d=sin(d); +#ifndef DARWIN + sincos(d,&d,&d); +#endif + d=tan(d); + + d=acos(d); + d=asin(d); + d=atan(d); + + d=cosh(d); + d=sinh(d); + d=tanh(d); + +#ifndef _WIN32 + d=acosh(d); + d=asinh(d); + d=atanh(d); +#endif + + d=exp(d); + d=log(d); +#ifdef __i386__/*FIXME*/ + d=logl(d); +#endif + + d=sqrt(d); + + return ul & l & ((unsigned long)d) & ch; + +} diff --git a/o/pre_init.c b/o/pre_init.c new file mode 100755 index 0000000..1ff7189 --- /dev/null +++ b/o/pre_init.c @@ -0,0 +1,61 @@ +#include "all.h" +#include "funlink.h" +#define SI 0 +#define LISP 1 +#define KEYWORD 2 + +#define NONE 0 + +void SI_makefun(),LISP_makefun(),error(); + +#define MAKEFUN(pack,string,fname,argd) \ + (pack == SI ? SI_makefun : pack == LISP ? LISP_makefun : error)(string,fname,argd) + +#undef DEFUN +#define DEFUN(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56) \ + {extern ret fname(); \ + MAKEFUN(pack,string,fname,F_ARGD(min,max,flags,ARGTYPES(ret0a0,a12,a34,a56)));} + +#undef DEFUNO +#define DEFUNO(string,ret,fname,pack,min,max, flags, ret0a0,a12,a34,a56,old) \ + {extern ret fname(); \ + MAKEFUN(pack,string,fname,F_ARGD(min,max,flags,ARGTYPES(ret0a0,a12,a34,a56)));} + +#undef DEFCOMP +#define DEFCOMP(type, fun) Ineed_in_image(fun); + + +#undef DEFVAR +#define DEFVAR(name,cname,pack,val) \ + { extern obj cname; \ + cname = (pack == LISP ? make_special(name,val) : \ + pack == SI ? make_si_special(name,val): \ + (error(name,val),(obj)0));} + +#undef DEFCONST +#define DEFCONST(name,cname,pack,val) \ + { extern obj cname; \ + cname = (pack == LISP ? make_constant(name,val) : \ + pack == SI ? make_si_constant(name,val): \ + (error(name,val),(obj)0));} + + +#undef DEF_ORDINARY +#define DEF_ORDINARY(name,cname,pack) \ + { extern obj cname ; cname = (pack == LISP ? make_ordinary(name) : \ + pack == SI ? make_si_ordinary(name): \ + (error(name),(obj)0));} + + +#undef DO_INIT +#define DO_INIT(x) x + + + + + + + + + + diff --git a/o/predicate.c b/o/predicate.c new file mode 100755 index 0000000..4c983bd --- /dev/null +++ b/o/predicate.c @@ -0,0 +1,837 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +/* + predicate.c + + predicates +*/ + +#include +#include +#include "include.h" + +DEFUNO_NEW("NULL",object,fLnull,LISP + ,1,1,NONE,OO,OO,OO,OO,void,Lnull,(object x0),"") +{ + /* 1 args */ + + if (x0 == Cnil) + x0 = Ct; + else + x0 = Cnil; + RETURN1(x0); +} + +DEFUN_NEW("NOT",object,fLnot,LISP + ,1,1,NONE,OO,OO,OO,OO,(object x0),"") + +{ + /* 1 args */ + + if (x0 == Cnil) + x0 = Ct; + else + x0 = Cnil; + RETURN1(x0); +} + +DEFUNO_NEW("SYMBOLP",object,fLsymbolp,LISP + ,1,1,NONE,OO,OO,OO,OO,void,Lsymbolp,(object x0),"") + +{ + /* 1 args */ + + if (type_of(x0) == t_symbol) + x0 = Ct; + else + x0 = Cnil; + RETURN1(x0); +} + +DEFUNO_NEW("ATOM",object,fLatom ,LISP + ,1,1,NONE,OO,OO,OO,OO,void,Latom,(object x0),"") + +{ + /* 1 args */ + + if (type_of(x0) != t_cons) + x0 = Ct; + else + x0 = Cnil; + RETURN1(x0); +} + +DEFUNO_NEW("CONSP",object,fLconsp,LISP + ,1,1,NONE,OO,OO,OO,OO,void,Lconsp,(object x0),"") + +{ + /* 1 args */ + + if (type_of(x0) == t_cons) + x0 = Ct; + else + x0 = Cnil; + RETURN1(x0); +} + +DEFUNO_NEW("LISTP",object,fLlistp,LISP + ,1,1,NONE,OO,OO,OO,OO,void,Llistp,(object x0),"") + +{ + /* 1 args */ + + if (x0 == Cnil || type_of(x0) == t_cons) + x0 = Ct; + else + x0 = Cnil; + RETURN1(x0); +} + +DEFUNO_NEW("NUMBERP",object,fLnumberp,LISP + ,1,1,NONE,OO,OO,OO,OO,void,Lnumberp,(object x0),"") + +{ + enum type t; + /* 1 args */ + + t = type_of(x0); + if (t == t_fixnum || t == t_bignum || t == t_ratio || + t == t_shortfloat || t == t_longfloat || + t == t_complex) + x0 = Ct; + else + x0 = Cnil; + RETURN1(x0); +} + +DEFUNO_NEW("INTEGERP",object,fLintegerp ,LISP + ,1,1,NONE,OO,OO,OO,OO,void,Lintegerp,(object x0),"") + +{ + enum type t; + /* 1 args */ + + t = type_of(x0); + if (t == t_fixnum || t == t_bignum) + x0 = Ct; + else + x0 = Cnil; + RETURN1(x0); +} + +DEFUN_NEW("RATIONALP",object,fLrationalp,LISP + ,1,1,NONE,OO,OO,OO,OO,(object x0),"") + +{ + enum type t; + /* 1 args */ + + t = type_of(x0); + if (t == t_fixnum || t == t_bignum || t == t_ratio) + x0 = Ct; + else + x0 = Cnil; + RETURN1(x0); +} + + +DEFUN_NEW("REALP",object,fLrealp,LISP + ,1,1,NONE,OO,OO,OO,OO,(object x0),"") +{ + enum type t; + t = type_of(x0); + + RETURN1((TS_MEMBER(t,TS(t_fixnum)| TS(t_bignum)| TS(t_ratio)| + TS(t_longfloat)| TS(t_shortfloat)) + ? Ct : Cnil)); + +} + + + + +DEFUNO_NEW("FLOATP",object,fLfloatp,LISP + ,1,1,NONE,OO,OO,OO,OO,void,Lfloatp,(object x0),"") + +{ + enum type t; + /* 1 args */ + + t = type_of(x0); + if (t == t_longfloat || t == t_shortfloat) + x0 = Ct; + else + x0 = Cnil; +RETURN1(x0);} + +DEFUNO_NEW("COMPLEXP",object,fLcomplexp,LISP + ,1,1,NONE,OO,OO,OO,OO,void,Lcomplexp,(object x0),"") + +{ + /* 1 args */ + + if (type_of(x0) == t_complex) + x0 = Ct; + else + x0 = Cnil; +RETURN1(x0);} + +DEFUNO_NEW("CHARACTERP",object,fLcharacterp,LISP + ,1,1,NONE,OO,OO,OO,OO,void,Lcharacterp,(object x0),"") + +{ + /* 1 args */ + + if (type_of(x0) == t_character) + x0 = Ct; + else + x0 = Cnil; +RETURN1(x0);} + +DEFUNO_NEW("STRINGP",object,fLstringp ,LISP + ,1,1,NONE,OO,OO,OO,OO,void,Lstringp,(object x0),"") + +{ + /* 1 args */ + + if (type_of(x0) == t_string) + x0 = Ct; + else + x0 = Cnil; +RETURN1(x0);} + +DEFUNO_NEW("BIT-VECTOR-P",object,fLbit_vector_p,LISP + ,1,1,NONE,OO,OO,OO,OO,void,Lbit_vector_p,(object x0),"") + +{ + /* 1 args */ + + if (type_of(x0) == t_bitvector) + x0 = Ct; + else + x0 = Cnil; +RETURN1(x0);} + +DEFUNO_NEW("VECTORP",object,fLvectorp,LISP + ,1,1,NONE,OO,OO,OO,OO,void,Lvectorp,(object x0),"") + +{ + enum type t; + /* 1 args */ + + t = type_of(x0); + if (t == t_vector || t == t_string || t == t_bitvector) + x0 = Ct; + else + x0 = Cnil; +RETURN1(x0);} + +DEFUNO_NEW("SIMPLE-STRING-P",object,fLsimple_string_p,LISP + ,1,1,NONE,OO,OO,OO,OO,void,Lsimple_string_p,(object x0),"") + +{ + /* 1 args */ + + if (type_of(x0) == t_string && +/* !x0->st.st_adjustable && */ + !x0->st.st_hasfillp && + x0->st.st_displaced->c.c_car == Cnil) + x0 = Ct; + else + x0 = Cnil; +RETURN1(x0);} + +DEFUNO_NEW("SIMPLE-BIT-VECTOR-P",object,fLsimple_bit_vector_p ,LISP + ,1,1,NONE,OO,OO,OO,OO,void,Lsimple_bit_vector_p ,(object x0),"") + +{ + /* 1 args */ + + if (type_of(x0) == t_bitvector && + /* !x0->bv.bv_adjustable && */ + !x0->bv.bv_hasfillp && + x0->bv.bv_displaced->c.c_car == Cnil) + x0 = Ct; + else + x0 = Cnil; +RETURN1(x0);} + +DEFUNO_NEW("SIMPLE-VECTOR-P",object,fLsimple_vector_p ,LISP + ,1,1,NONE,OO,OO,OO,OO,void,Lsimple_vector_p ,(object x0),"") + +{ + enum type t; + /* 1 args */ + + t = type_of(x0); + if (t == t_vector && +/* !x0->v.v_adjustable && */ + !x0->v.v_hasfillp && + x0->v.v_displaced->c.c_car == Cnil && + (enum aelttype)x0->v.v_elttype == aet_object) + x0 = Ct; + else + x0 = Cnil; +RETURN1(x0);} + +DEFUNO_NEW("ARRAYP",object,fLarrayp ,LISP + ,1,1,NONE,OO,OO,OO,OO,void,Larrayp,(object x0),"") + +{ + enum type t; + /* 1 args */ + + t = type_of(x0); + if (t == t_array || + t == t_vector || t == t_string || t == t_bitvector) + x0 = Ct; + else + x0 = Cnil; +RETURN1(x0);} + +DEFUNO_NEW("PACKAGEP",object,fLpackagep ,LISP + ,1,1,NONE,OO,OO,OO,OO,void,Lpackagep ,(object x0),"") + +{ + /* 1 args */ + + if (type_of(x0) == t_package) + x0 = Ct; + else + x0 = Cnil; +RETURN1(x0);} + +DEFUNO_NEW("FUNCTIONP",object,fLfunctionp,LISP + ,1,1,NONE,OO,OO,OO,OO,void,Lfunctionp,(object x0),"") + +{ + enum type t; + object x; + + /* 1 args */ + t = type_of(x0); + if (t == t_cfun || t == t_cclosure || t == t_sfun || t == t_gfun + || t == t_closure|| t == t_afun + || t == t_vfun) + x0 = Ct; + else if (t == t_symbol) { + if (x0->s.s_gfdef != OBJNULL && + x0->s.s_mflag == FALSE) + x0 = Ct; + else + x0 = Cnil; } + else if (t == t_cons) { + x = x0->c.c_car; + if (x == sLlambda || x == sLlambda_block || + x == sSlambda_block_expanded || + x == sLlambda_closure || x == sLlambda_block_closure) + x0 = Ct; + else + x0 = Cnil; + } else + x0 = Cnil; +RETURN1(x0);} +#ifdef STATIC_FUNCTION_POINTERS +object +fLfunctionp(object x) { + return FFN(fLfunctionp)(x); +} +#endif + + +DEFUNO_NEW("COMPILED-FUNCTION-P",object,fLcompiled_function_p,LISP + ,1,1,NONE,OO,OO,OO,OO,void,Lcompiled_function_p,(object x0),"") + +{ + /* 1 args */; + + if (type_of(x0) == t_cfun || + type_of(x0) == t_cclosure || + type_of(x0) == t_sfun || + type_of(x0) == t_gfun || + type_of(x0) == t_afun || + type_of(x0) == t_closure || + type_of(x0) == t_vfun + + + ) + x0 = Ct; + else + x0 = Cnil; +RETURN1(x0);} + +DEFUNO_NEW("COMMONP",object,fLcommonp,LISP + ,1,1,NONE,OO,OO,OO,OO,void,Lcommonp,(object x0),"") + +{ + /* 1 args */; + + if (type_of(x0) != t_spice) + x0 = Ct; + else + x0 = Cnil; +RETURN1(x0);} + +DEFUN_NEW("EQ",object,fLeq,LISP,2,2,NONE,OO,OO,OO,OO,(object x0,object x1),"") { + RETURN1(x0==x1 ? Ct : Cnil); +} + +#define eqlm(x,y) \ +\ + case t_fixnum:\ + return (fix(x)==fix(y)) ? TRUE : FALSE;\ +\ + case t_bignum:\ + return big_compare(x,y) ? FALSE : TRUE;\ +\ + case t_ratio:\ + return (eql(x->rat.rat_num,y->rat.rat_num) &&\ + eql(x->rat.rat_den,y->rat.rat_den)) ? TRUE : FALSE;\ +\ + case t_shortfloat:\ + return sf(x)==sf(y) ? TRUE : FALSE;\ +\ + case t_longfloat:\ + return lf(x)==lf(y) ? TRUE : FALSE;\ +\ + case t_complex:\ + return (eql(x->cmp.cmp_real,y->cmp.cmp_real) &&\ + eql(x->cmp.cmp_imag,y->cmp.cmp_imag)) ? TRUE : FALSE;\ +\ + default:\ + return FALSE; + +bool +eql1(register object x,register object y) { + + /*x and y are not == and not Cnil and not immfix*/ + + if (valid_cdr(x)||valid_cdr(y)||x->d.t!=y->d.t) return FALSE; + + switch (x->d.t) { + + eqlm(x,y); + + } + +} + +/*for sublis1-inline*/ +bool +oeql(object x,object y) { + return eql(x,y) ? TRUE : FALSE; +} + +DEFUN_NEW("EQL",object,fLeql,LISP,2,2,NONE,OO,OO,OO,OO,(object x0,object x1),"") { + RETURN1(eql(x0,x1) ? Ct : Cnil); +} + +bool +equal1(register object x, register object y) { + + /*x and y are not == and not Cnil and not immfix*/ + +#ifdef __MINGW32__ /*FIXME mingw compiler cannot do tail recursion and blows out stack*/ + BEGIN: + if (valid_cdr(x)) { + if (valid_cdr(y)&&equal(x->c.c_car,y->c.c_car)) { + x=x->c.c_cdr; + y=y->c.c_cdr; + if (x==y) return TRUE; + if (IMMNIL(x)||IMMNIL(y)) return FALSE; + goto BEGIN; + } else + return FALSE; + } +#else + + if (valid_cdr(x)) return valid_cdr(y)&&equal(x->c.c_car,y->c.c_car)&&equal(x->c.c_cdr,y->c.c_cdr); + +#endif + + if (valid_cdr(y)) return FALSE; + + if (x->d.t!=y->d.t) + return FALSE; + + switch(x->d.t) { + + case t_string: + return(string_eq(x, y)); + + case t_bitvector: + { + fixnum i, ox, oy; + + if (x->bv.bv_fillp != y->bv.bv_fillp) + return(FALSE); + ox = BV_OFFSET(x); + oy = BV_OFFSET(y); + for (i = 0; i < x->bv.bv_fillp; i++) + if(((x->bv.bv_self[(i+ox)/8] & (0200>>(i+ox)%8)) ? 1 : 0) + !=((y->bv.bv_self[(i+oy)/8] & (0200>>(i+oy)%8)) ? 1 : 0)) + return(FALSE); + return(TRUE); + } + + case t_pathname: + if (equal(x->pn.pn_host, y->pn.pn_host) && + equal(x->pn.pn_device, y->pn.pn_device) && + equal(x->pn.pn_directory, y->pn.pn_directory) && + equal(x->pn.pn_name, y->pn.pn_name) && + equal(x->pn.pn_type, y->pn.pn_type) && + equal(x->pn.pn_version, y->pn.pn_version)) + return(TRUE); + else + return(FALSE); + + eqlm(x,y); + + } + +} + +/*for sublis1-inline*/ +bool +oequal(object x,object y) { + return equal(x,y) ? TRUE : FALSE; +} + +DEFUN_NEW("EQUAL",object,fLequal,LISP,2,2,NONE,OO,OO,OO,OO,(object x0,object x1),"") { + RETURN1(equal(x0, x1) ? Ct : Cnil); +} + +bool +equalp1(register object x, register object y) { + + enum type tx,ty; + fixnum j; + + /*x and y are not == and not Cnil*/ + + if (listp(x)) return listp(y)&&equalp(x->c.c_car,y->c.c_car)&&equalp(x->c.c_cdr,y->c.c_cdr); + + if (listp(y)) return FALSE; + + tx=is_imm_fixnum(x) ? t_fixnum : x->d.t; + ty=is_imm_fixnum(y) ? t_fixnum : y->d.t; + + switch(tx) { + + case t_fixnum: + case t_bignum: + case t_ratio: + case t_shortfloat: + case t_longfloat: + case t_complex: + if (ty==t_fixnum||ty==t_bignum||ty==t_ratio || + ty==t_shortfloat||ty==t_longfloat || + ty==t_complex) + return(!number_compare(x, y)); + else + return(FALSE); + + case t_vector: + case t_string: + case t_bitvector: + if (ty==t_vector||ty==t_string||ty==t_bitvector) { + j = x->v.v_fillp; + if (j != y->v.v_fillp) + return FALSE; + goto ARRAY; + } + else + return(FALSE); + + case t_array: + if (ty==t_array && x->a.a_rank==y->a.a_rank) { + if (x->a.a_rank > 1) { + fixnum i; + for (i=0; i< x->a.a_rank; i++) { + if (x->a.a_dims[i]!=y->a.a_dims[i]) + return(FALSE); + } + } + if (x->a.a_dim != y->a.a_dim) + return(FALSE); + j=x->a.a_dim; + goto ARRAY; + } + else + return(FALSE); + + default: + break; + + } + + if (tx != ty) + return(FALSE); + + switch (tx) { + + case t_character: + return(char_equal(x, y)); + + case t_structure: + { + fixnum i; + if (x->str.str_def != y->str.str_def) + return(FALSE); + { + fixnum leng= S_DATA(x->str.str_def)->length; + unsigned char *s_type= & SLOT_TYPE(x->str.str_def,0); + unsigned short *s_pos= & SLOT_POS(x->str.str_def,0); + for (i = 0; i < leng; i++,s_pos++) { + if (s_type[i]==aet_object) { + if (!equalp(STREF(object,x,*s_pos),STREF(object,y,*s_pos))) + return FALSE; + } + else + /* if (! (*s_pos & (sizeof(object)-1))) */ + switch(s_type[i]) { + case aet_lf: + if((! (*s_pos & (sizeof(longfloat)-1))) && + STREF(longfloat,x,*s_pos) != STREF(longfloat,y,*s_pos)) + return(FALSE); + break; + case aet_sf: + if((! (*s_pos & (sizeof(shortfloat)-1))) && + STREF(shortfloat,x,*s_pos)!=STREF(shortfloat,y,*s_pos)) + return(FALSE); + break; + default: + if((! (*s_pos & (sizeof(fixnum)-1))) && + STREF(fixnum,x,*s_pos)!=STREF(fixnum,y,*s_pos)) + return(FALSE); + break; + } + } + return(TRUE); + } + } + + case t_hashtable: + { + unsigned i; + struct htent *e; + + if (x->ht.ht_nent!=y->ht.ht_nent) + return(FALSE); + if (x->ht.ht_test!=y->ht.ht_test) + return(FALSE); + for (i=0;iht.ht_size;i++) { + if (x->ht.ht_self[i].hte_key==OBJNULL) + continue; + if ((e=gethash(x->ht.ht_self[i].hte_key,y))->hte_key==OBJNULL + ||!equalp(x->ht.ht_self[i].hte_value,e->hte_value)) + return(FALSE); + } + return(TRUE); + break; + } + + case t_pathname: + return(equal(x, y)); + + case t_random: + return(x->rnd.rnd_state._mp_seed->_mp_alloc==y->rnd.rnd_state._mp_seed->_mp_alloc && + !memcmp(x->rnd.rnd_state._mp_seed->_mp_d,y->rnd.rnd_state._mp_seed->_mp_d, + x->rnd.rnd_state._mp_seed->_mp_alloc*sizeof(*x->rnd.rnd_state._mp_seed->_mp_d))); + default: + return(FALSE); + + } + + + ARRAY: + + { + fixnum i; + + for (i = 0; i < j; i++) + if (!equalp(aref(x, i), aref(y, i))) + return(FALSE); + return(TRUE); + } + +} + +/*for sublis1-inline*/ +bool +oequalp(object x,object y) { + return equalp(x,y) ? TRUE : FALSE; +} + + +DEFUN_NEW("EQUALP",object,fLequalp,LISP,2,2,NONE,OO,OO,OO,OO,(object x0,object x1),"") { + RETURN1(equalp(x0,x1) ? Ct : Cnil); +} + + +static void +FFN(Fand)(object args) +{ + + object *top = vs_top; + + if (endp(args)) { + vs_base = vs_top; + vs_push(Ct); + return; + } + while (!endp(MMcdr(args))) { + eval(MMcar(args)); + if (vs_base[0] == Cnil) { + vs_base = vs_top = top; + vs_push(Cnil); + return; + } + vs_top = top; + args = MMcdr(args); + } + eval(MMcar(args)); +} + +static void +FFN(For)(object args) +{ + + object *top = vs_top; + + if (endp(args)) { + vs_base = vs_top; + vs_push(Cnil); + return; + } + while (!endp(MMcdr(args))) { + eval(MMcar(args)); + if (vs_base[0] != Cnil) { + top[0] = vs_base[0]; + vs_base = top; + vs_top = top+1; + return; + } + vs_top = top; + args = MMcdr(args); + } + eval(MMcar(args)); +} + +/* + Contains_sharp_comma returns TRUE, iff the argument contains + a cons whose car is si:|#,| or a STRUCTURE. + Refer to the compiler about this magic. +*/ +bool +contains_sharp_comma(object x) +{ + enum type tx; + + cs_check(x); + +BEGIN: + tx = type_of(x); + if (tx == t_complex) + return(contains_sharp_comma(x->cmp.cmp_real) || + contains_sharp_comma(x->cmp.cmp_imag)); + if (tx == t_vector) + { + int i; + if (x->v.v_elttype == aet_object) + for (i = 0; i < x->v.v_fillp; i++) + if (contains_sharp_comma(x->v.v_self[i])) + return(TRUE); + return(FALSE); + } + if (tx == t_cons) { + if (x->c.c_car == siSsharp_comma) + return(TRUE); + if (contains_sharp_comma(x->c.c_car)) + return(TRUE); + x = x->c.c_cdr; + goto BEGIN; + } + if (tx == t_array) + { + int i, j; + if (x->a.a_elttype == aet_object) { + for (i = 0, j = 1; i < x->a.a_rank; i++) + j *= x->a.a_dims[i]; + for (i = 0; i < j; i++) + if (contains_sharp_comma(x->a.a_self[i])) + return(TRUE); + } + return(FALSE); + } + if (tx == t_structure) + return(TRUE); /* Oh, my god! */ + return(FALSE); +} + +DEFUN_NEW("CONTAINS-SHARP-COMMA",object,fScontains_sharp_comma,SI + ,1,1,NONE,OO,OO,OO,OO,(object x0),"") + +{ + /* 1 args */ + + if (contains_sharp_comma(x0)) + x0 = Ct; + else + x0 = Cnil; + RETURN1(x0); +} + +DEFUN_NEW("SPICEP",object,fSspicep ,SI + ,1,1,NONE,OO,OO,OO,OO,(object x0),"") + +{ + /* 1 args */ + if (type_of(x0) == t_spice) + x0 = Ct; + else + x0 = Cnil; + RETURN1(x0); +} + +DEFUN_NEW("FIXNUMP",object,fSfixnump,SI + ,1,1,NONE,OO,OO,OO,OO,(object x0),"") + +{ + /* 1 args */ + if (type_of(x0) == t_fixnum) + x0 = Ct; + else + x0 = Cnil; + RETURN1(x0); +} + +void +gcl_init_predicate_function(void) +{ + + sLand=make_special_form("AND",Fand); + sLor=make_special_form("OR",For); + + + +} diff --git a/o/prelink.c b/o/prelink.c new file mode 100644 index 0000000..609f72b --- /dev/null +++ b/o/prelink.c @@ -0,0 +1,17 @@ +#define NO_PRELINK_UNEXEC_DIVERSION + +#include "include.h" + +void +prelink_init(void) { + + my_stdin=stdin; + my_stdout=stdout; + my_stderr=stderr; +#ifdef HAVE_READLINE + my_rl_completion_entry_function_ptr=(void *)&rl_completion_entry_function; + my_rl_readline_name_ptr=(void *)&rl_readline_name; +#endif + +} + diff --git a/o/print.d b/o/print.d new file mode 100755 index 0000000..f3b8039 --- /dev/null +++ b/o/print.d @@ -0,0 +1,2203 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +*/ + +/* + print.d +*/ + +#define NEED_ISFINITE + +#include "include.h" +#include +#include "num_include.h" + +#define LINE_LENGTH line_length +int line_length = 72; + +#ifndef WRITEC_NEWLINE +#define WRITEC_NEWLINE(strm) (writec_stream('\n',strm)) +#endif + +#define to_be_escaped(c) \ + (standard_readtable->rt.rt_self[(c)&0377].rte_chattrib \ + != cat_constituent || \ + isLower((c)&0377) || (c) == ':') + + +#define mod(x) ((x)%Q_SIZE) + + +#define queue printStructBufp->p_queue +#define indent_stack printStructBufp->p_indent_stack +#define qh printStructBufp->p_qh +#define qt printStructBufp->p_qt +#define qc printStructBufp->p_qc +#define isp printStructBufp->p_isp +#define iisp printStructBufp->p_iisp + + +object sSAprint_packageA; +object sSAprint_structureA; + + +/* bool RPINcircle; ??typo?? */ + + + +#define write_ch (*write_ch_fun) + + +#define MARK 0400 +#define UNMARK 0401 +#define SET_INDENT 0402 +#define INDENT 0403 +#define INDENT1 0404 +#define INDENT2 0405 + +extern object coerce_stream(object,int); + +static void +flush_queue(int); + +static void +writec_queue(c) +int c; +{ + if (qc >= Q_SIZE) + flush_queue(FALSE); + if (qc >= Q_SIZE) + FEerror("Can't pretty-print.", 0); + queue[qt] = c; + qt = mod(qt+1); + qc++; +} + +static void +flush_queue(int force) +{ + int c, i, j, k, l, i0; + +BEGIN: + while (qc > 0) { + c = queue[qh]; + if (c == MARK) + goto MDO_MARK; + else if (c == UNMARK) + isp -= 2; + else if (c == SET_INDENT) + indent_stack[isp] = file_column(PRINTstream); + else if (c == INDENT) { + goto MDO_INDENT; + } else if (c == INDENT1) { + i = file_column(PRINTstream)-indent_stack[isp]; + if (i < 8 && indent_stack[isp] < LINE_LENGTH/2) { + writec_stream(' ', PRINTstream); + indent_stack[isp] + = file_column(PRINTstream); + } else { + if (indent_stack[isp] < LINE_LENGTH/2) { + indent_stack[isp] + = indent_stack[isp-1] + 4; + } + goto MDO_INDENT; + } + } else if (c == INDENT2) { + indent_stack[isp] = indent_stack[isp-1] + 2; + goto PUT_INDENT; + } else if (c < 0400) + writec_stream(c, PRINTstream); + qh = mod(qh+1); + --qc; + } + return; + +MDO_MARK: + k = LINE_LENGTH - 1 - file_column(PRINTstream); + for (i = 1, j = 0, l = 1; l > 0 && i < qc && j < k; i++) { + c = queue[mod(qh + i)]; + if (c == MARK) + l++; + else if (c == UNMARK) + --l; + else if (c == INDENT || c == INDENT1 || c == INDENT2) + j++; + else if (c < 0400) + j++; + } + if (l == 0) + goto FLUSH; + if (i == qc && !force) + return; + qh = mod(qh+1); + --qc; + if (++isp >= IS_SIZE-1) + FEerror("Can't pretty-print.", 0); + indent_stack[isp++] = file_column(PRINTstream); + indent_stack[isp] = indent_stack[isp-1]; + goto BEGIN; + +MDO_INDENT: + if (iisp > isp) + goto PUT_INDENT; + k = LINE_LENGTH - 1 - file_column(PRINTstream); + for (i0 = 0, i = 1, j = 0, l = 1; i < qc && j < k; i++) { + c = queue[mod(qh + i)]; + if (c == MARK) + l++; + else if (c == UNMARK) { + if (--l == 0) + goto FLUSH; + } else if (c == SET_INDENT) { + if (l == 1) + break; + } else if (c == INDENT) { + if (l == 1) + i0 = i; + j++; + } else if (c == INDENT1) { + if (l == 1) + break; + j++; + } else if (c == INDENT2) { + if (l == 1) { + i0 = i; + break; + } + j++; + } else if (c < 0400) + j++; + } + if (i == qc && !force) + return; + if (i0 == 0) + goto PUT_INDENT; + i = i0; + goto FLUSH; + +PUT_INDENT: + qh = mod(qh+1); + --qc; + + WRITEC_NEWLINE(PRINTstream); + for (i = indent_stack[isp]; i > 0; --i) + writec_stream(' ', PRINTstream); + iisp = isp; + goto BEGIN; + +FLUSH: + for (j = 0; j < i; j++) { + c = queue[qh]; + if (c == INDENT || c == INDENT1 || c == INDENT2) + writec_stream(' ', PRINTstream); + else if (c < 0400) + writec_stream(c, PRINTstream); + qh = mod(qh+1); + --qc; + } + goto BEGIN; +} + +void +writec_PRINTstream(c) +int c; +{ + if (c == INDENT || c == INDENT1) + writec_stream(' ', PRINTstream); + else if (c < 0400) + writec_stream(c, PRINTstream); +} + +void +write_str(s) +char *s; +{ + while (*s != '\0') + write_ch(*s++); +} + +static void +write_decimal1(int); + +static void +write_decimal(i) +int i; +{ + if (i == 0) { + write_ch('0'); + return; + } + write_decimal1(i); +} + +static void +write_decimal1(i) +int i; +{ + if (i == 0) + return; + write_decimal1(i/10); + write_ch(i%10 + '0'); +} + +static void +write_addr(x) +object x; +{ + long i; + int j, k; + + i = (long)x; + for (j = 8*sizeof(i)-4; j >= 0; j -= 4) { + k = (i>>j) & 0xf; + if (k < 10) + write_ch('0' + k); + else + write_ch('a' + k - 10); + } +} + +static void +write_base(void) +{ + if (PRINTbase == 2) + write_str("#b"); + else if (PRINTbase == 8) + write_str("#o"); + else if (PRINTbase == 16) + write_str("#x"); + else if (PRINTbase >= 10) { + write_ch('#'); + write_ch(PRINTbase/10+'0'); + write_ch(PRINTbase%10+'0'); + write_ch('r'); + } else { + write_ch('#'); + write_ch(PRINTbase+'0'); + write_ch('r'); + } +} + +/* The floating point precision required to make the most-positive-long-float + printed expression readable. If this is too small, then the rounded + off fraction, may be too big to read */ + +#ifndef FPRC +#define FPRC 16 +#endif + +object sSAprint_nansA; + +#include + +static int +char_inc(char *b,char *p) { + + if (b==p) { + if (*p=='-') { + p++; + memmove(p+1,p,strlen(p)+1); + } + *p='1'; + } else if (*p=='9') { + *p='0'; + char_inc(b,p-1); + } else if (*p=='.') + char_inc(b,p-1); + else (*p)++; + + return 1; + +} + +#define COMP(a_,b_,c_,d_) ((d_) ? strtod((a_),(b_))==(c_) : strtof((a_),(b_))==(float)(c_)) + +static int +truncate_double(char *b,double d,int dp) { + + char c[FPRC+9],c1[FPRC+9],*p,*pp,*n; + int j,k; + + n=b; + k=strlen(n); + + strcpy(c1,b); + for (p=c1;*p && *p!='e';p++); + pp=p>c1 && p[-1]!='.' ? p-1 : p; + for (;pp>c1 && pp[-1]=='0';pp--); + strcpy(pp,p); + if (pp!=p && COMP(c1,&pp,d,dp)) + k=truncate_double(n=c1,d,dp); + + strcpy(c,n); + for (p=c;*p && *p!='e';p++); + if (p[-1]!='.' && char_inc(c,p-1) && COMP(c,&pp,d,dp)) { + j=truncate_double(c,d,dp); + if (js.s_dbind !=Cnil) { + sprintf(s, "%e",d); + *sp = 2; + return; + } + else + FEerror("Can't print a non-number.",0);} + else + sprintf(b, "%*.*e",FPRC+8,FPRC,d); + if (b[FPRC+3] != 'e') { + sprintf(b, "%*.*e",FPRC+7,FPRC,d); + *ep = (b[FPRC+5]-'0')*10 + (b[FPRC+6]-'0'); + } else + *ep = (b[FPRC+5]-'0')*100 + (b[FPRC+6]-'0')*10 + (b[FPRC+7]-'0'); + + *sp = 1; + if (b[0] == '-') + *sp *= -1; + if (b[FPRC+4] == '-') + *ep *= -1; + + truncate_double(b,d,n!=7); + + if (isdigit(b[0])) { + b[1]=b[0]; + (*ep)++; + } + if (b[2]=='0') (*ep)++; + b[2] = b[1]; + p = b + 2; + for (i=0;i'); + return; + } + if (sign < 0) + write_ch('-'); + if (-3 <= exp && exp < 7) { + if (exp < 0) { + write_ch('0'); + write_ch('.'); + exp = (-exp) - 1; + for (i = 0; i < exp; i++) + write_ch('0'); + for (; n > 0; --n) + if (buff[n-1] != '0' && buff[n-1]) + break; + if (exp == 0 && n == 0) + n = 1; + for (i = 0; i < n; i++) + write_ch(buff[i]); + } else { + exp++; + for (i = 0; i < exp; i++) + if (i < n) + write_ch(buff[i]); + else + write_ch('0'); + write_ch('.'); + if (i < n) + write_ch(buff[i]); + else + write_ch('0'); + i++; + for (; n > i; --n) + if (buff[n-1] != '0' && buff[n-1]) + break; + for (; i < n; i++) + write_ch(buff[i]); + } + exp = 0; + } else { + write_ch(buff[0]); + write_ch('.'); + write_ch(buff[1]); + for (; n > 2; --n) + if (buff[n-1] != '0' && buff[n-1]) + break; + for (i = 2; i < n; i++) + write_ch(buff[i]); + } + if (exp == 0 && e == 0) + return; + if (e == 0) + e = 'E'; + write_ch(e); + if (exp < 0) { + write_ch('-'); + exp *= -1; + } + write_decimal(exp); +} + +static void +call_structure_print_function(x, level) +object x; +int level; +{ + int i; + bool eflag; + bds_ptr old_bds_top; + + void (*wf)(int) = write_ch_fun; + + object *vt = PRINTvs_top; + object *vl = PRINTvs_limit; + bool e = PRINTescape; + bool ra = PRINTreadably; + bool r = PRINTradix; + int b = PRINTbase; + bool c = PRINTcircle; + bool p = PRINTpretty; + int lv = PRINTlevel; + int ln = PRINTlength; + bool g = PRINTgensym; + bool a = PRINTarray; + +/* + short oq[Q_SIZE]; +*/ + short ois[IS_SIZE]; + + VOL int oqh; + VOL int oqt; + VOL int oqc; + VOL int oisp; + VOL int oiisp; + +ONCE_MORE: + if (interrupt_flag) { + interrupt_flag = FALSE; +#ifdef UNIX + alarm(0); +#endif + terminal_interrupt(TRUE); + goto ONCE_MORE; + } + + if (PRINTpretty) + flush_queue(TRUE); + + oqh = qh; + oqt = qt; + oqc = qc; + oisp = isp; + oiisp = iisp; + +/* No need to save the queue, since it is flushed. + for (i = 0; i < Q_SIZE; i++) + oq[i] = queue[i]; +*/ + if (PRINTpretty) + for (i = 0; i <= isp; i++) + ois[i] = indent_stack[i]; + + vs_push(PRINTstream); + vs_push(PRINTcase); + + vs_push(make_fixnum(level)); + + old_bds_top = bds_top; + bds_bind(sLAprint_escapeA, PRINTescape?Ct:Cnil); + bds_bind(sLAprint_readablyA, PRINTreadably?Ct:Cnil); + bds_bind(sLAprint_radixA, PRINTradix?Ct:Cnil); + bds_bind(sLAprint_baseA, make_fixnum(PRINTbase)); + bds_bind(sLAprint_circleA, PRINTcircle?Ct:Cnil); + bds_bind(sLAprint_prettyA, PRINTpretty?Ct:Cnil); + bds_bind(sLAprint_levelA, PRINTlevel<0?Cnil:make_fixnum(PRINTlevel)); + bds_bind(sLAprint_lengthA, PRINTlength<0?Cnil:make_fixnum(PRINTlength)); + bds_bind(sLAprint_gensymA, PRINTgensym?Ct:Cnil); + bds_bind(sLAprint_arrayA, PRINTarray?Ct:Cnil); + bds_bind(sLAprint_caseA, PRINTcase); + + frs_push(FRS_PROTECT, Cnil); + if (nlj_active) { + eflag = TRUE; + goto L; + } + + ifuncall3(S_DATA(x->str.str_def)->print_function, + x, PRINTstream, vs_head); + vs_popp; + eflag = FALSE; + +L: + frs_pop(); + bds_unwind(old_bds_top); + +/* + for (i = 0; i < Q_SIZE; i++) + queue[i] = oq[i]; +*/ + if (PRINTpretty) + for (i = 0; i <= oisp; i++) + indent_stack[i] = ois[i]; + + iisp = oiisp; + isp = oisp; + qc = oqc; + qt = oqt; + qh = oqh; + + PRINTcase = vs_pop; + PRINTstream = vs_pop; + PRINTarray = a; + PRINTgensym = g; + PRINTlength = ln; + PRINTlevel = lv; + PRINTpretty = p; + PRINTcircle = c; + PRINTbase = b; + PRINTradix = r; + PRINTescape = e; + PRINTreadably = ra; + PRINTvs_limit = vl; + PRINTvs_top = vt; + + write_ch_fun = wf; + + if (eflag) { + nlj_active = FALSE; + unwind(nlj_fr, nlj_tag); + } +} +object copy_big(); +object coerce_big_to_string(object,int); + +static bool +potential_number_p(object,int); + +void +write_object(x, level) +object x; +int level; +{ + object r, y; + int i, j, k,lw; + object *vp; + + cs_check(x); + + if (x == OBJNULL) { + write_str("#"); + return; + } + if (is_free(x)) { + write_str("#"); + return; + } + + switch (type_of(x)) { + + case t_fixnum: + { + object *vsp; + /*FIXME 64*/ + fixnum i; + + if (PRINTradix && PRINTbase != 10) + write_base(); + i = fix(x); + if (i == 0) { + write_ch('0'); + if (PRINTradix && PRINTbase == 10) + write_ch('.'); + break; + } + if (i < 0) { + write_ch('-'); + if (i == MOST_NEGATIVE_FIX) { + x = fixnum_add(1,(MOST_POSITIVE_FIX)); + vs_push(x); + i = PRINTradix; + PRINTradix = FALSE; + write_object(x, level); + PRINTradix = i; + vs_popp; + if (PRINTradix && PRINTbase == 10) + write_ch('.'); + break; + } + i = -i; + } + vsp = vs_top; + for (vsp = vs_top; i != 0; i /= PRINTbase) + vs_push(code_char(digit_weight(i%PRINTbase, + PRINTbase))); + while (vs_top > vsp) + write_ch(char_code((vs_pop))); + if (PRINTradix && PRINTbase == 10) + write_ch('.'); + break; + } + + case t_bignum: + { + if (PRINTradix && PRINTbase != 10) + write_base(); + i = big_sign(x); + if (i == 0) { + write_ch('0'); + if (PRINTradix && PRINTbase == 10) + write_ch('.'); + break; + } + { object s = coerce_big_to_string(x,PRINTbase); + int i=0; + while (iust.ust_fillp) { write_ch(s->ust.ust_self[i++]); } + } + if (PRINTradix && PRINTbase == 10) + write_ch('.'); + break; + } + + case t_ratio: + if (PRINTradix) { + write_base(); + PRINTradix = FALSE; + write_object(x->rat.rat_num, level); + write_ch('/'); + write_object(x->rat.rat_den, level); + PRINTradix = TRUE; + } else { + write_object(x->rat.rat_num, level); + write_ch('/'); + write_object(x->rat.rat_den, level); + } + break; + + case t_shortfloat: + r = symbol_value(sLAread_default_float_formatA); + if (r == sLshort_float) + write_double((double)sf(x), 0, TRUE); + else + write_double((double)sf(x), 'S', TRUE); + break; + + case t_longfloat: + r = symbol_value(sLAread_default_float_formatA); + if (r == sLsingle_float || + r == sLlong_float || r == sLdouble_float) + write_double(lf(x), 0, FALSE); + else + write_double(lf(x), 'F', FALSE); + break; + + case t_complex: + write_str("#C("); + write_object(x->cmp.cmp_real, level); + write_ch(' '); + write_object(x->cmp.cmp_imag, level); + write_ch(')'); + break; + + case t_character: + if (!PRINTescape) { + write_ch(char_code(x)); + break; + } + write_str("#\\"); + switch (char_code(x)) { + case '\r': + write_str("Return"); + break; + + case ' ': + write_str("Space"); + break; + + case '\177': + write_str("Rubout"); + break; + + case '\f': + write_str("Page"); + break; + + case '\t': + write_str("Tab"); + break; + + case '\b': + write_str("Backspace"); + break; + + case '\n': + write_str("Newline"); + break; + + default: + if (char_code(x) & 0200) { + write_ch('\\'); + i = char_code(x); + write_ch(((i>>6)&7) + '0'); + write_ch(((i>>3)&7) + '0'); + write_ch(((i>>0)&7) + '0'); + } else if (char_code(x) < 040) { + write_ch('^'); + write_ch(char_code(x) + 0100); + } else + write_ch(char_code(x)); + break; + } + break; + + case t_symbol: + if (!PRINTescape) { + for (lw = 0,i = 0; i < x->s.s_fillp; i++) { + j = x->s.s_self[i]; + if (isUpper(j)) { + if (PRINTcase == sKdowncase || + (PRINTcase == sKcapitalize && i!=lw)) + j += 'a' - 'A'; + } else if (!isLower(j)) + lw = i + 1; + write_ch(j); + + } + break; + } + if (x->s.s_hpack == Cnil) { + if (PRINTcircle) { + for (vp = PRINTvs_top; vp < PRINTvs_limit; vp += 2) + if (x == *vp) { + if (vp[1] != Cnil) { + write_ch('#'); + write_decimal((vp-PRINTvs_top)/2); + write_ch('#'); + return; + } else { + write_ch('#'); + write_decimal((vp-PRINTvs_top)/2); + write_ch('='); + vp[1] = Ct; + } + } + } + if (PRINTgensym) + write_str("#:"); + } else if (x->s.s_hpack == keyword_package) + write_ch(':'); + else if (PRINTpackage||find_symbol(x,current_package())!=x + || intern_flag == 0) + { + k = 0; + for (i = 0; + i < x->s.s_hpack->p.p_name->st.st_fillp; + i++) { + j = x->s.s_hpack->p.p_name + ->st.st_self[i]; + if (to_be_escaped(j)) + k++; + } + if (k > 0) + write_ch('|'); + for (lw = 0, i = 0; + i < x->s.s_hpack->p.p_name->st.st_fillp; + i++) { + j = x->s.s_hpack->p.p_name + ->st.st_self[i]; + if (j == '|' || j == '\\') + write_ch('\\'); + if (k == 0) { + if (isUpper(j)) { + if (PRINTcase == sKdowncase || + (PRINTcase == sKcapitalize && i!=lw)) + j += 'a' - 'A'; + } else if (!isLower(j)) + lw = i + 1; + } + write_ch(j); + } + if (k > 0) + write_ch('|'); + if (find_symbol(x, x->s.s_hpack) != x) + error("can't print symbol"); + if (PRINTpackage || intern_flag == INTERNAL) + write_str("::"); + else if (intern_flag == EXTERNAL) + write_ch(':'); + else + FEerror("Pathological symbol --- cannot print.", 0); + } + k = 0; + if (potential_number_p(x, PRINTbase)) + k++; + for (i = 0; i < x->s.s_fillp; i++) { + j = x->s.s_self[i]; + if (to_be_escaped(j)) + k++; + } + for (i = 0; i < x->s.s_fillp; i++) + if (x->s.s_self[i] != '.') + goto NOT_DOT; + k++; + + NOT_DOT: + if (k > 0) + write_ch('|'); + for (lw = 0, i = 0; i < x->s.s_fillp; i++) { + j = x->s.s_self[i]; + if (j == '|' || j == '\\') + write_ch('\\'); + if (k == 0) { + if (isUpper(j)) { + if (PRINTcase == sKdowncase || + (PRINTcase == sKcapitalize && i != lw)) + j += 'a' - 'A'; + } else if (!isLower(j)) + lw = i + 1; + } + write_ch(j); + } + if (k > 0) + write_ch('|'); + break; + + case t_array: + { + int subscripts[ARANKLIM]; + int n, m; + + if (!PRINTarray) { + write_str("#"); + break; + } + if (PRINTcircle) { + for (vp = PRINTvs_top; vp < PRINTvs_limit; vp += 2) + if (x == *vp) { + if (vp[1] != Cnil) { + write_ch('#'); + write_decimal((vp-PRINTvs_top)/2); + write_ch('#'); + return; + } else { + write_ch('#'); + write_decimal((vp-PRINTvs_top)/2); + write_ch('='); + vp[1] = Ct; + break; + } + } + } + if (PRINTlevel >= 0 && level >= PRINTlevel) { + write_ch('#'); + break; + } + n = x->a.a_rank; + write_ch('#'); + write_decimal(n); + write_ch('A'); + if (PRINTlevel >= 0 && level+n >= PRINTlevel) + n = PRINTlevel - level; + for (i = 0; i < n; i++) + subscripts[i] = 0; + m = 0; + j = 0; + for (;;) { + for (i = j; i < n; i++) { + if (subscripts[i] == 0) { + write_ch(MARK); + write_ch('('); + write_ch(SET_INDENT); + if (x->a.a_dims[i] == 0) { + write_ch(')'); + write_ch(UNMARK); + j = i-1; + k = 0; + goto INC; + } + } + if (subscripts[i] > 0) + write_ch(INDENT); + if (PRINTlength >= 0 && + subscripts[i] >= PRINTlength) { + write_str("...)"); + write_ch(UNMARK); + k=x->a.a_dims[i]-subscripts[i]; + subscripts[i] = 0; + for (j = i+1; j < n; j++) + k *= x->a.a_dims[j]; + j = i-1; + goto INC; + } + } + if (n == x->a.a_rank) { + vs_push(aref(x, m)); + write_object(vs_head, level+n); + vs_popp; + } else + write_ch('#'); + j = n-1; + k = 1; + + INC: + while (j >= 0) { + if (++subscripts[j] < x->a.a_dims[j]) + break; + subscripts[j] = 0; + write_ch(')'); + write_ch(UNMARK); + --j; + } + if (j < 0) + break; + m += k; + } + break; + } + + case t_vector: + if (!PRINTarray) { + write_str("#"); + break; + } + if (PRINTcircle) { + for (vp = PRINTvs_top; vp < PRINTvs_limit; vp += 2) + if (x == *vp) { + if (vp[1] != Cnil) { + write_ch('#'); + write_decimal((vp-PRINTvs_top)/2); + write_ch('#'); + return; + } else { + write_ch('#'); + write_decimal((vp-PRINTvs_top)/2); + write_ch('='); + vp[1] = Ct; + break; + } + } + } + if (PRINTlevel >= 0 && level >= PRINTlevel) { + write_ch('#'); + break; + } + write_ch('#'); + write_ch(MARK); + write_ch('('); + write_ch(SET_INDENT); + if (x->v.v_fillp > 0) { + if (PRINTlength == 0) { + write_str("...)"); + write_ch(UNMARK); + break; + } + vs_push(aref(x, 0)); + write_object(vs_head, level+1); + vs_popp; + for (i = 1; i < x->v.v_fillp; i++) { + write_ch(INDENT); + if (PRINTlength>=0 && i>=PRINTlength){ + write_str("..."); + break; + } + vs_push(aref(x, i)); + write_object(vs_head, level+1); + vs_popp; + } + } + write_ch(')'); + write_ch(UNMARK); + break; + + case t_string: + if (!PRINTescape) { + for (i = 0; i < x->st.st_fillp; i++) + write_ch(x->st.st_self[i]); + break; + } + write_ch('"'); + for (i = 0; i < x->st.st_fillp; i++) { + if (x->st.st_self[i] == '"' || + x->st.st_self[i] == '\\') + write_ch('\\'); + write_ch(x->st.st_self[i]); + } + write_ch('"'); + break; + + case t_bitvector: + if (!PRINTarray) { + write_str("#"); + break; + } + write_str("#*"); + for (i = x->bv.bv_offset; i < x->bv.bv_fillp + x->bv.bv_offset; i++) + if (x->bv.bv_self[i/8] & (0200 >> i%8)) + write_ch('1'); + else + write_ch('0'); + break; + + case t_cons: + if (x->c.c_car == siSsharp_comma) { + write_str("#."); + write_object(x->c.c_cdr, level); + break; + } + if (PRINTcircle) { + for (vp = PRINTvs_top; vp < PRINTvs_limit; vp += 2) + if (x == *vp) { + if (vp[1] != Cnil) { + write_ch('#'); + write_decimal((vp-PRINTvs_top)/2); + write_ch('#'); + return; + } else { + write_ch('#'); + write_decimal((vp-PRINTvs_top)/2); + write_ch('='); + vp[1] = Ct; + break; + } + } + } + if (PRINTpretty) { + if (x->c.c_car == sLquote && + type_of(x->c.c_cdr) == t_cons && + x->c.c_cdr->c.c_cdr == Cnil) { + write_ch('\''); + write_object(x->c.c_cdr->c.c_car, level); + break; + } + if (x->c.c_car == sLfunction && + type_of(x->c.c_cdr) == t_cons && + x->c.c_cdr->c.c_cdr == Cnil) { + write_ch('#'); + write_ch('\''); + write_object(x->c.c_cdr->c.c_car, level); + break; + } + } + if (PRINTlevel >= 0 && level >= PRINTlevel) { + write_ch('#'); + break; + } + write_ch(MARK); + write_ch('('); + write_ch(SET_INDENT); + if (PRINTpretty && x->c.c_car != OBJNULL && + type_of(x->c.c_car) == t_symbol && + (r = getf(x->c.c_car->s.s_plist, + sSpretty_print_format, Cnil)) != Cnil) + goto PRETTY_PRINT_FORMAT; + for (i = 0; ; i++) { + if (PRINTlength >= 0 && i >= PRINTlength) { + write_str("..."); + break; + } + y = x->c.c_car; + x = x->c.c_cdr; + write_object(y, level+1); + if (type_of(x) != t_cons) { + if (x != Cnil) { + write_ch(INDENT); + write_str(". "); + write_object(x, level); + } + break; + } + if (PRINTcircle) { + for (vp = PRINTvs_top; vp < PRINTvs_limit; vp += 2) + if (x == *vp) { + if (vp[1] != Cnil) { + write_str(" . #"); + write_decimal((vp-PRINTvs_top)/2); + write_ch('#'); + goto RIGHT_PAREN; + } else { + write_ch(INDENT); + write_str(". "); + write_object(x, level); + goto RIGHT_PAREN; + } + } + } + if (i == 0 && y != OBJNULL && type_of(y) == t_symbol) + write_ch(INDENT1); + else + write_ch(INDENT); + } + + RIGHT_PAREN: + write_ch(')'); + write_ch(UNMARK); + break; + + PRETTY_PRINT_FORMAT: + j = fixint(r); + for (i = 0; ; i++) { + if (PRINTlength >= 0 && i >= PRINTlength) { + write_str("..."); + break; + } + y = x->c.c_car; + x = x->c.c_cdr; + if (i <= j && y == Cnil) + write_str("()"); + else + write_object(y, level+1); + if (type_of(x) != t_cons) { + if (x != Cnil) { + write_ch(INDENT); + write_str(". "); + write_object(x, level); + } + break; + } + if (i >= j) + write_ch(INDENT2); + else if (i == 0) + write_ch(INDENT1); + else + write_ch(INDENT); + } + goto RIGHT_PAREN; + + case t_package: + write_str("#<"); + write_object(x->p.p_name, level); + write_str(" package>"); + break; + + case t_hashtable: + write_str("#"); + break; + + case t_stream: + switch (x->sm.sm_mode) { + case smm_input: + write_str("#sm.sm_object1, level); + write_ch('>'); + break; + + case smm_output: + write_str("#sm.sm_object1, level); + write_ch('>'); + break; + + case smm_io: + write_str("#sm.sm_object1, level); + write_ch('>'); + break; + + case smm_socket: + write_str("#sm.sm_object0, level); + write_ch('>'); + break; + + + case smm_probe: + write_str("#sm.sm_object1, level); + write_ch('>'); + break; + + case smm_synonym: + write_str("#sm.sm_object0, level); + write_ch('>'); + break; + + case smm_broadcast: + write_str("#"); + break; + + case smm_concatenated: + write_str("#"); + break; + + case smm_two_way: + write_str("#"); + break; + + case smm_echo: + write_str("#"); + break; + + case smm_string_input: + write_str("#sm.sm_object0; + j = y->st.st_fillp; + for (i = 0; i < j && i < 16; i++) + write_ch(y->st.st_self[i]); + if (j > 16) + write_str("..."); + write_str("\">"); + break; +#ifdef USER_DEFINED_STREAMS + case smm_user_defined: + write_str("#"); + break; +#endif + + case smm_string_output: + write_str("#"); + break; + + default: + error("illegal stream mode"); + } + break; + +#define FRESH_COPY(a_,b_) {(b_)->_mp_alloc=(a_)->_mp_alloc;\ + (b_)->_mp_d=gcl_gmp_alloc((b_)->_mp_alloc*sizeof(*(b_)->_mp_d));\ + (b_)->_mp_size=(a_)->_mp_size;\ + memcpy((b_)->_mp_d,(a_)->_mp_d,(b_)->_mp_alloc*sizeof(*(b_)->_mp_d));} + + case t_random: + write_str("#$"); + y = new_bignum(); + FRESH_COPY(x->rnd.rnd_state._mp_seed,MP(y)); + y=normalize_big(y); + vs_push(y); + write_object(y, level); + vs_popp; + break; + + case t_structure: + if (PRINTcircle) { + for (vp = PRINTvs_top; vp < PRINTvs_limit; vp += 2) + if (x == *vp) { + if (vp[1] != Cnil) { + write_ch('#'); + write_decimal((vp-PRINTvs_top)/2); + write_ch('#'); + return; + } else { + write_ch('#'); + write_decimal((vp-PRINTvs_top)/2); + write_ch('='); + vp[1] = Ct; + break; + } + } + } + if (PRINTlevel >= 0 && level >= PRINTlevel) { + write_ch('#'); + break; + } + if (type_of(x->str.str_def) != t_structure) + FEwrong_type_argument(sLstructure, x->str.str_def); + if (PRINTstructure || + S_DATA(x->str.str_def)->print_function == Cnil) + { + write_str("#S"); + x = structure_to_list(x); + vs_push(x); + write_object(x, level); + vs_popp; + break; + } + call_structure_print_function(x, level); + break; + + case t_readtable: + write_str("#"); + break; + + case t_pathname: + if (1 || PRINTescape) { + write_ch('#'); + write_ch('p'); + vs_push(namestring(x)); + write_object(vs_head, level); + vs_popp; + } else { + write_str("#"); + } + break; + case t_sfun: + case t_gfun: + case t_vfun: + case t_afun: + case t_cfun: + write_str("#cf.cf_name != Cnil) + write_object(x->cf.cf_name, level); + else + write_addr(x); + write_str(">"); + break; + + case t_closure: + case t_cclosure: + write_str("#cc.cc_name != Cnil) + write_object(x->cc.cc_name, level); + else + write_addr(x); + write_str(">"); + break; + + case t_spice: + write_str("#<\100"); + for (i = 8*sizeof(long)-4; i >= 0; i -= 4) { + j = ((long)x >> i) & 0xf; + if (j < 10) + write_ch('0' + j); + else + write_ch('A' + (j - 10)); + } + write_ch('>'); + break; + + default: + error("illegal type --- cannot print"); + } +} + +static int dgs; + +#include "page.h" + +static void +travel_push_new(object x) { + + object y; + int i; + + BEGIN: + if (NULL_OR_ON_C_STACK(x)) return; + if (is_marked(x)) { + vs_check_push(x); + vs_check_push(Cnil); + return; + } + switch (type_of(x)) { + case t_symbol: + if (dgs && x->s.s_hpack==Cnil) {mark(x);} + break; + case t_cons: + y=x->c.c_cdr; + mark(x); + travel_push_new(x->c.c_car); + x=y; + goto BEGIN; + break; + case t_array: + mark(x); + if ((enum aelttype)x->a.a_elttype == aet_object) + for (i=0;ia.a_dim;i++) + travel_push_new(x->a.a_self[i]); + break; + case t_vector: + mark(x); + if ((enum aelttype)x->v.v_elttype == aet_object) + for (i=0;iv.v_fillp;i++) + travel_push_new(x->v.v_self[i]); + break; + case t_structure: + mark(x); + for (i = 0; i < S_DATA(x->str.str_def)->length; i++) + travel_push_new(structure_ref(x,x->str.str_def,i)); + break; + default: + break; + + } + +} + + +static void +travel_clear_new(object x) { + + int i; + + BEGIN: + if (NULL_OR_ON_C_STACK(x) || !is_marked(x)) return; + unmark(x); + switch (type_of(x)) { + case t_cons: + travel_clear_new(x->c.c_car); + x=x->c.c_cdr; + goto BEGIN; + break; + case t_array: + if ((enum aelttype)x->a.a_elttype == aet_object) + for (i=0;ia.a_dim;i++) + travel_clear_new(x->a.a_self[i]); + break; + case t_vector: + if ((enum aelttype)x->v.v_elttype == aet_object) + for (i=0;iv.v_fillp;i++) + travel_clear_new(x->v.v_self[i]); + break; + case t_structure: + for (i = 0; i < S_DATA(x->str.str_def)->length; i++) + travel_clear_new(structure_ref(x,x->str.str_def,i)); + break; + default: + break; + + } + +} + + +static void +setupPRINTcircle(object x,int dogensyms) { + + BEGIN_NO_INTERRUPT; + dgs=dogensyms; + travel_push_new(x); + dgs=0; + PRINTvs_limit = vs_top; + travel_clear_new(x); + END_NO_INTERRUPT; + +} + +/* char travel_push_type[32]; */ + +/* static void */ +/* travel_push_object(x) */ +/* object x; */ +/* { */ +/* enum type t; */ +/* int i; */ +/* object *vp; */ + +/* cs_check(x); */ + +/* BEGIN: */ +/* t = type_of(x); */ +/* if(travel_push_type[(int)t]==0) return; */ +/* if(t==t_symbol && x->s.s_hpack != Cnil) return; */ + +/* for (vp = PRINTvs_top; vp < vs_top; vp += 2) */ +/* if (x == *vp) { */ +/* if (vp[1] != Cnil) */ +/* return; */ +/* vp[1] = Ct; */ +/* return; */ +/* } */ +/* vs_check_push(x); */ +/* vs_check_push(Cnil); */ +/* if (t == t_array && (enum aelttype)x->a.a_elttype == aet_object) */ +/* for (i = 0; i < x->a.a_dim; i++) */ +/* travel_push_object(x->a.a_self[i]); */ +/* else if (t == t_vector && (enum aelttype)x->v.v_elttype == aet_object) */ +/* for (i = 0; i < x->v.v_fillp; i++) */ +/* travel_push_object(x->v.v_self[i]); */ +/* else if (t == t_cons) { */ +/* travel_push_object(x->c.c_car); */ +/* x = x->c.c_cdr; */ +/* goto BEGIN; */ +/* } else if (t == t_structure) { */ +/* for (i = 0; i < S_DATA(x->str.str_def)->length; i++) */ +/* travel_push_object(structure_ref(x,x->str.str_def,i)); */ +/* } */ +/* } */ + +/* static void */ +/* setupPRINTcircle(x,dogensyms) */ +/* object x; */ +/* int dogensyms; */ +/* { object *vp,*vq; */ +/* travel_push_type[(int)t_symbol]=dogensyms; */ +/* travel_push_type[(int)t_array]= */ +/* (travel_push_type[(int)t_vector]=PRINTarray); */ +/* travel_push_object(x); */ +/* for (vp = vq = PRINTvs_top; vp < vs_top; vp += 2) */ +/* if (vp[1] != Cnil) { */ +/* vq[0] = vp[0]; */ +/* vq[1] = Cnil; */ +/* vq += 2; */ +/* } */ +/* PRINTvs_limit = vs_top = vq; */ +/* } */ + +void +setupPRINTdefault(x) +object x; +{ + object y; + + PRINTvs_top = vs_top; + PRINTstream = symbol_value(sLAstandard_outputA); + if (type_of(PRINTstream) != t_stream) { + sLAstandard_outputA->s.s_dbind + = symbol_value(sLAterminal_ioA); + vs_push(PRINTstream); + FEwrong_type_argument(sLstream, PRINTstream); + } + PRINTescape = symbol_value(sLAprint_escapeA) != Cnil; + PRINTreadably = symbol_value(sLAprint_readablyA) != Cnil; + PRINTpretty = symbol_value(sLAprint_prettyA) != Cnil; + PRINTcircle = symbol_value(sLAprint_circleA) != Cnil; + y = symbol_value(sLAprint_baseA); + if (type_of(y) != t_fixnum || fix(y) < 2 || fix(y) > 36) { + sLAprint_baseA->s.s_dbind = make_fixnum(10); + vs_push(y); + FEerror("~S is an illegal PRINT-BASE.", 1, y); + } else + PRINTbase = fix(y); + PRINTradix = symbol_value(sLAprint_radixA) != Cnil; + PRINTcase = symbol_value(sLAprint_caseA); + if (PRINTcase != sKupcase && PRINTcase != sKdowncase && + PRINTcase != sKcapitalize) { + sLAprint_caseA->s.s_dbind = sKdowncase; + vs_push(PRINTcase); + FEerror("~S is an illegal PRINT-CASE.", 1, PRINTcase); + } + PRINTgensym = symbol_value(sLAprint_gensymA) != Cnil; + y = symbol_value(sLAprint_levelA); + if (y == Cnil) + PRINTlevel = -1; + else if (type_of(y) != t_fixnum || fix(y) < 0) { + sLAprint_levelA->s.s_dbind = Cnil; + vs_push(y); + FEerror("~S is an illegal PRINT-LEVEL.", 1, y); + } else + PRINTlevel = fix(y); + y = symbol_value(sLAprint_lengthA); + if (y == Cnil) + PRINTlength = -1; + else if (type_of(y) != t_fixnum || fix(y) < 0) { + sLAprint_lengthA->s.s_dbind = Cnil; + vs_push(y); + FEerror("~S is an illegal PRINT-LENGTH.", 1, y); + } else + PRINTlength = fix(y); + PRINTarray = symbol_value(sLAprint_arrayA) != Cnil; + if (PRINTcircle) setupPRINTcircle(x,1); + if (PRINTpretty) { + qh = qt = qc = 0; + isp = iisp = 0; + indent_stack[0] = 0; + write_ch_fun = writec_queue; + } else + write_ch_fun = writec_PRINTstream; + PRINTpackage = symbol_value(sSAprint_packageA) != Cnil; + PRINTstructure = symbol_value(sSAprint_structureA) != Cnil; +} + +void +cleanupPRINT(void) +{ + vs_top = PRINTvs_top; + if (PRINTpretty) + flush_queue(TRUE); +} + +/*static void +write_object_by_default(x) +object x; +{ + SETUP_PRINT_DEFAULT(x); + write_object(x, 0); + flush_stream(PRINTstream); + CLEANUP_PRINT_DEFAULT; +}*/ + +/*static void +terpri_by_default() +{ + PRINTstream = symbol_value(sLAstandard_outputA); + if (type_of(PRINTstream) != t_stream) + FEwrong_type_argument(sLstream, PRINTstream); + WRITEC_NEWLINE(PRINTstream); +}*/ + +static bool +potential_number_p(strng, base) +object strng; +int base; +{ + int i, l, c, dc; + char *s; + + l = strng->st.st_fillp; + if (l == 0) + return(FALSE); + s = strng->st.st_self; + dc = 0; + c = s[0]; + if (digitp(c, base) >= 0) + dc++; + else if (c != '+' && c != '-' && c != '^' && c != '_') + return(FALSE); + if (s[l-1] == '+' || s[l-1] == '-') + return(FALSE); + for (i = 1; i < l; i++) { + c = s[i]; + if (digitp(c, base) >= 0) { + dc++; + continue; + } + if (c != '+' && c != '-' && c != '/' && c != '.' && + c != '^' && c != '_' && + c != 'e' && c != 'E' && + c != 's' && c != 'S' && c != 'l' && c != 'L') + return(FALSE); + } + if (dc == 0) + return(FALSE); + return(TRUE); +} + @(defun write (x + &key ((:stream strm) Cnil) + (escape `symbol_value(sLAprint_escapeA)`) + (readably `symbol_value(sLAprint_readablyA)`) + (radix `symbol_value(sLAprint_radixA)`) + (base `symbol_value(sLAprint_baseA)`) + (circle `symbol_value(sLAprint_circleA)`) + (pretty `symbol_value(sLAprint_prettyA)`) + (level `symbol_value(sLAprint_levelA)`) + (length `symbol_value(sLAprint_lengthA)`) + ((:case cas) `symbol_value(sLAprint_caseA)`) + (gensym `symbol_value(sLAprint_gensymA)`) + (array `symbol_value(sLAprint_arrayA)`)) + struct printStruct printStructBuf; + struct printStruct *old_printStructBufp = printStructBufp; +@ + + printStructBufp = &printStructBuf; + if (strm == Cnil) + strm = symbol_value(sLAstandard_outputA); + else if (strm == Ct) + strm = symbol_value(sLAterminal_ioA); + if (type_of(strm) != t_stream) + FEerror("~S is not a stream.", 1, strm); + PRINTvs_top = vs_top; + PRINTstream = strm; + PRINTreadably = readably != Cnil; + PRINTescape = PRINTreadably || escape != Cnil; + PRINTpretty = pretty != Cnil; + PRINTcircle = circle != Cnil; + if (type_of(base)!=t_fixnum || fix((base))<2 || fix((base))>36) + FEerror("~S is an illegal PRINT-BASE.", 1, base); + else + PRINTbase = fix((base)); + PRINTradix = radix != Cnil; + PRINTcase = cas; + if (PRINTcase != sKupcase && PRINTcase != sKdowncase && + PRINTcase != sKcapitalize) + FEerror("~S is an illegal PRINT-CASE.", 1, cas); + PRINTgensym = PRINTreadably || gensym != Cnil; + if (PRINTreadably || level == Cnil) + PRINTlevel = -1; + else if (type_of(level) != t_fixnum || fix((level)) < 0) + FEerror("~S is an illegal PRINT-LEVEL.", 1, level); + else + PRINTlevel = fix((level)); + if (PRINTreadably || length == Cnil) + PRINTlength = -1; + else if (type_of(length) != t_fixnum || fix((length)) < 0) + FEerror("~S is an illegal PRINT-LENGTH.", 1, length); + else + PRINTlength = fix((length)); + PRINTarray = PRINTreadably || array != Cnil; + if (PRINTcircle) setupPRINTcircle(x,1); + if (PRINTpretty) { + qh = qt = qc = 0; + isp = iisp = 0; + indent_stack[0] = 0; + write_ch_fun = writec_queue; + } else + write_ch_fun = writec_PRINTstream; + PRINTpackage = symbol_value(sSAprint_packageA) != Cnil; + PRINTstructure = symbol_value(sSAprint_structureA) != Cnil; + write_object(x, 0); + CLEANUP_PRINT_DEFAULT; + flush_stream(PRINTstream); + @(return x) +@) + +@(defun prin1 (obj &optional strm) +@ + prin1(obj, strm); + @(return obj) +@) + +@(defun print (obj &optional strm) +@ + print(obj, strm); + @(return obj) +@) + +@(defun pprint (obj &optional strm) +@ + if (strm == Cnil) + strm = symbol_value(sLAstandard_outputA); + else if (strm == Ct) + strm = symbol_value(sLAterminal_ioA); + check_type_stream(&strm); + WRITEC_NEWLINE(strm); + {SETUP_PRINT_DEFAULT(obj); + PRINTstream = strm; + PRINTreadably = FALSE; + PRINTescape = TRUE; + PRINTpretty = TRUE; + qh = qt = qc = 0; + isp = iisp = 0; + indent_stack[0] = 0; + write_ch_fun = writec_queue; + write_object(obj, 0); + CLEANUP_PRINT_DEFAULT; + flush_stream(strm);} + @(return) +@) + +@(defun princ (obj &optional strm) +@ + princ(obj, strm); + @(return obj) +@) + +@(defun write_char (c &optional strm) +@ + if (strm == Cnil) + strm = symbol_value(sLAstandard_outputA); + else if (strm == Ct) + strm = symbol_value(sLAterminal_ioA); + check_type_character(&c); + check_type_stream(&strm); + writec_stream(char_code(c), strm); +/* + flush_stream(strm); +*/ + @(return c) +@) + +@(defun write_string (strng &o strm &k start end) + int s, e, i; +@ + get_string_start_end(strng, start, end, &s, &e); + if (strm == Cnil) + strm = symbol_value(sLAstandard_outputA); + else if (strm == Ct) + strm = symbol_value(sLAterminal_ioA); + check_type_string(&strng); + check_type_stream(&strm); + for (i = s; i < e; i++) + writec_stream(strng->st.st_self[i], strm); + flush_stream(strm); + @(return strng) +@) + +@(defun write_line (strng &o strm &k start end) + int s, e, i; +@ + get_string_start_end(strng, start, end, &s, &e); + if (strm == Cnil) + strm = symbol_value(sLAstandard_outputA); + else if (strm == Ct) + strm = symbol_value(sLAterminal_ioA); + check_type_string(&strng); + check_type_stream(&strm); + for (i = s; i < e; i++) + writec_stream(strng->st.st_self[i], strm); + WRITEC_NEWLINE(strm); + flush_stream(strm); + @(return strng) +@) + +@(defun terpri (&optional strm) +@ + terpri(strm); + @(return Cnil) +@) + +@(defun fresh_line (&optional strm) +@ + if (strm == Cnil) + strm = symbol_value(sLAstandard_outputA); + else if (strm == Ct) + strm = symbol_value(sLAterminal_ioA); + /* we need to get the real output stream, if possible */ + {object tmp=coerce_stream(strm,1); + if(tmp != Cnil) strm = tmp ; + else + check_type_stream(&strm); + } + if (file_column(strm) == 0) + @(return Cnil) + WRITEC_NEWLINE(strm); + flush_stream(strm); + @(return Ct) +@) + +@(defun finish_output (&o strm) +@ + if (strm == Cnil) + strm = symbol_value(sLAstandard_outputA); + else if (strm == Ct) + strm = symbol_value(sLAterminal_ioA); + check_type_stream(&strm); + flush_stream(strm); + @(return Cnil) +@) + +@(defun force_output (&o strm) +@ + if (strm == Cnil) + strm = symbol_value(sLAstandard_outputA); + else if (strm == Ct) + strm = symbol_value(sLAterminal_ioA); + check_type_stream(&strm); + flush_stream(strm); + @(return Cnil) +@) + +@(defun clear_output (&o strm) +@ + if (strm == Cnil) + strm = symbol_value(sLAstandard_outputA); + else if (strm == Ct) + strm = symbol_value(sLAterminal_ioA); + check_type_stream(&strm); + @(return Cnil) +@) + +@(defun write_byte (integer binary_output_stream) +@ + if (type_of(integer) != t_fixnum) + FEerror("~S is not a byte.", 1, integer); + check_type_stream(&binary_output_stream); + writec_stream(fix(integer), binary_output_stream); + @(return integer) +@) + +DEF_ORDINARY("UPCASE",sKupcase,KEYWORD,""); +DEF_ORDINARY("DOWNCASE",sKdowncase,KEYWORD,""); +DEF_ORDINARY("CAPITALIZE",sKcapitalize,KEYWORD,""); +DEF_ORDINARY("STREAM",sKstream,KEYWORD,""); +DEF_ORDINARY("ESCAPE",sKescape,KEYWORD,""); +DEF_ORDINARY("READABLY",sKreadably,KEYWORD,""); +DEF_ORDINARY("PRETTY",sKpretty,KEYWORD,""); +DEF_ORDINARY("CIRCLE",sKcircle,KEYWORD,""); +DEF_ORDINARY("BASE",sKbase,KEYWORD,""); +DEF_ORDINARY("RADIX",sKradix,KEYWORD,""); +DEF_ORDINARY("CASE",sKcase,KEYWORD,""); +DEF_ORDINARY("GENSYM",sKgensym,KEYWORD,""); +DEF_ORDINARY("LEVEL",sKlevel,KEYWORD,""); +DEF_ORDINARY("LENGTH",sKlength,KEYWORD,""); +DEF_ORDINARY("ARRAY",sKarray,KEYWORD,""); +DEFVAR("*PRINT-ESCAPE*",sLAprint_escapeA,LISP,Ct,""); +DEFVAR("*PRINT-READABLY*",sLAprint_readablyA,LISP,Ct,""); +DEFVAR("*PRINT-PRETTY*",sLAprint_prettyA,LISP,Ct,""); +DEFVAR("*PRINT-CIRCLE*",sLAprint_circleA,LISP,Cnil,""); +DEFVAR("*PRINT-BASE*",sLAprint_baseA,LISP,make_fixnum(10),""); +DEFVAR("*PRINT-RADIX*",sLAprint_radixA,LISP,Cnil,""); +DEFVAR("*PRINT-CASE*",sLAprint_caseA,LISP,sKupcase,""); +DEFVAR("*PRINT-GENSYM*",sLAprint_gensymA,LISP,Ct,""); +DEFVAR("*PRINT-LEVEL*",sLAprint_levelA,LISP,Cnil,""); +DEFVAR("*PRINT-LENGTH*",sLAprint_lengthA,LISP,Cnil,""); +DEFVAR("*PRINT-ARRAY*",sLAprint_arrayA,LISP,Ct,""); +DEFVAR("*PRINT-PACKAGE*",sSAprint_packageA,SI,Cnil,""); +DEFVAR("*PRINT-STRUCTURE*",sSAprint_structureA,SI,Cnil,""); +DEF_ORDINARY("PRETTY-PRINT-FORMAT",sSpretty_print_format,SI,""); + +void +gcl_init_print() +{ + + /* travel_push_type[(int)t_array]=1; */ + /* travel_push_type[(int)t_vector]=1; */ + /* travel_push_type[(int)t_structure]=1; */ + /* travel_push_type[(int) t_cons]=1; */ + /* if(sizeof(travel_push_type) < t_other) */ + /* error("travel_push_size to small see print.d"); */ + + PRINTstream = Cnil; + enter_mark_origin(&PRINTstream); + PRINTreadably = FALSE; + PRINTescape = TRUE; + PRINTpretty = FALSE; + PRINTcircle = FALSE; + PRINTbase = 10; + PRINTradix = FALSE; + PRINTcase = sKupcase; + enter_mark_origin(&PRINTcase); + PRINTgensym = TRUE; + PRINTlevel = -1; + PRINTlength = -1; + PRINTarray = FALSE; + + write_ch_fun = writec_PRINTstream; +} + +object +princ(obj, strm) +object obj, strm; +{ + if (strm == Cnil) + strm = symbol_value(sLAstandard_outputA); + else if (strm == Ct) + strm = symbol_value(sLAterminal_ioA); + if (type_of(strm) != t_stream) + FEerror("~S is not a stream.", 1, strm); + if (obj == OBJNULL) + goto SIMPLE_CASE; + switch (type_of(obj)) { + case t_symbol: + PRINTcase = symbol_value(sLAprint_caseA); + PRINTpackage = symbol_value(sSAprint_packageA) != Cnil; + + SIMPLE_CASE: + case t_string: + case t_character: + PRINTstream = strm; + PRINTreadably = FALSE; + PRINTescape = FALSE; + write_ch_fun = writec_PRINTstream; + write_object(obj, 0); + break; + + default: + {SETUP_PRINT_DEFAULT(obj); + PRINTstream = strm; + PRINTreadably = FALSE; + PRINTescape = FALSE; + write_object(obj, 0); + CLEANUP_PRINT_DEFAULT;} + break; + } + return(obj); +} + +object +prin1(obj, strm) +object obj, strm; +{ + if (strm == Cnil) + strm = symbol_value(sLAstandard_outputA); + else if (strm == Ct) + strm = symbol_value(sLAterminal_ioA); + if (type_of(strm) != t_stream) + FEerror("~S is not a stream.", 1, strm); + if (obj == OBJNULL) + goto SIMPLE_CASE; + switch (type_of(obj)) { + SIMPLE_CASE: + case t_string: + case t_character: + PRINTstream = strm; + PRINTreadably = FALSE; + PRINTescape = TRUE; + write_ch_fun = writec_PRINTstream; + write_object(obj, 0); + break; + + default: + {SETUP_PRINT_DEFAULT(obj); + PRINTstream = strm; + PRINTreadably = FALSE; + PRINTescape = TRUE; + write_object(obj, 0); + CLEANUP_PRINT_DEFAULT;} + break; + } + flush_stream(strm); + return(obj); +} + +object +print(obj, strm) +object obj, strm; +{ + terpri(strm); + prin1(obj,strm); + princ(code_char(' '),strm); + return(obj); +} + +object +terpri(strm) +object strm; +{ + if (strm == Cnil) + strm = symbol_value(sLAstandard_outputA); + else if (strm == Ct) + strm = symbol_value(sLAterminal_ioA); + if (type_of(strm) != t_stream) + FEerror("~S is not a stream.", 1, strm); + WRITEC_NEWLINE(strm); + flush_stream(strm); + return(Cnil); +} + +void +write_string(strng, strm) +object strng, strm; +{ + int i; + + if (strm == Cnil) + strm = symbol_value(sLAstandard_outputA); + else if (strm == Ct) + strm = symbol_value(sLAterminal_ioA); + check_type_string(&strng); + check_type_stream(&strm); + for (i = 0; i < strng->st.st_fillp; i++) + writec_stream(strng->st.st_self[i], strm); + flush_stream(strm); +} + +/* + THE ULTRA-SPECIAL-DINNER-SERVICE OPTIMIZATION +*/ +void +princ_str(s, sym) +char *s; +object sym; +{ + sym = symbol_value(sym); + if (sym == Cnil) + sym = symbol_value(sLAstandard_outputA); + else if (sym == Ct) + sym = symbol_value(sLAterminal_ioA); + check_type_stream(&sym); + writestr_stream(s, sym); +} + +void +princ_char(c, sym) +int c; +object sym; +{ + sym = symbol_value(sym); + if (sym == Cnil) + sym = symbol_value(sLAstandard_outputA); + else if (sym == Ct) + sym = symbol_value(sLAterminal_ioA); + check_type_stream(&sym); + if (c == '\n') + {WRITEC_NEWLINE(sym); + flush_stream(sym);} + else + writec_stream(c, sym); + +} + + +void +pp(x) +object x; +{ +princ(x,Cnil); +flush_stream(symbol_value(sLAstandard_outputA)); +} + +static object +FFN(set_line_length)(n) +int n; +{ + line_length=n; + return make_fixnum(line_length); +} + +DEFVAR("*PRINT-NANS*",sSAprint_nansA,SI,Cnil,""); + +void +gcl_init_print_function() +{ + make_function("WRITE", Lwrite); + make_function("PRIN1", Lprin1); + make_function("PRINT", Lprint); + make_function("PPRINT", Lpprint); + make_function("PRINC", Lprinc); + + make_function("WRITE-CHAR", Lwrite_char); + make_function("WRITE-STRING", Lwrite_string); + make_function("WRITE-LINE", Lwrite_line); + make_function("TERPRI", Lterpri); + make_function("FRESH-LINE", Lfresh_line); + make_function("FINISH-OUTPUT", Lfinish_output); + make_function("FORCE-OUTPUT", Lforce_output); + make_function("CLEAR-OUTPUT", Lclear_output); + make_function("WRITE-BYTE", Lwrite_byte); + make_si_sfun("SET-LINE-LENGTH",set_line_length,ARGTYPE1(f_fixnum) + | RESTYPE(f_fixnum)); +} + + + + + diff --git a/o/prog.c b/o/prog.c new file mode 100755 index 0000000..3e4e89b --- /dev/null +++ b/o/prog.c @@ -0,0 +1,304 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +/* + + prog.c +*/ + +#include "include.h" + +/* + use of VS in tagbody: + + old_top -> | id | + | lex0 | + | lex1 | + | lex2 | + tinf_base -> | tag1 | where 'bodyi' is the part of tag-body + | body1 | that follows the tag 'tagi'. + | : | + : i.e. + | : | tag-body + | tagn | = (...tag1..........tagn.............) + | bodyn | | |<- bodyn ->| + new_top -> | | | | + VS |<-------- body1 -------->| +*/ + +FFD(Ftagbody)(object body) +{ + + object *old_top = vs_top; + object * VOL new_top; + object *tinf; + object * VOL tinf_base; + object *env = lex_env; + object id = alloc_frame_id(); + VOL object bodysv = body; + object label; + enum type item_type; + + vs_push(id); + lex_copy(); + tinf_base = vs_top; + while (!endp(body)) { + label = MMcar(body); + item_type = type_of(label); + if (item_type == t_symbol || item_type == t_fixnum || + item_type == t_bignum) { + lex_tag_bind(label, id); + vs_push(label); + vs_push(MMcdr(body)); + } + body = MMcdr(body); + } + + new_top = vs_top; + + frs_push(FRS_CATCH, id); + body = bodysv; + if (nlj_active) { + label = cdr(nlj_tag); + nlj_active = FALSE; + for(tinf = tinf_base; + tinf < new_top && !eql(tinf[0],label); + tinf += 2) + ; + if (tinf >= new_top) + FEerror("Someone tried to RETURN-FROM a TAGBODY.",0); + body = tinf[1]; + } + while (body != Cnil) { + vs_top = new_top; + item_type = type_of(MMcar(body)); + if (item_type != t_symbol && item_type != t_fixnum && + item_type != t_bignum) + eval(MMcar(body)); + body = MMcdr(body); + } + frs_pop(); + lex_env = env; + vs_base = old_top; + vs_top = old_top+1; + vs_base[0] = Cnil; +} + +static void +FFN(Fprog)(VOL object arg) +{ + + object *oldlex = lex_env; + struct bind_temp *start; + object body; + bds_ptr old_bds_top = bds_top; + + if (endp(arg)) + FEtoo_few_argumentsF(arg); + + make_nil_block(); + + if (nlj_active) { + nlj_active = FALSE; + goto END; + } + + start = (struct bind_temp *)vs_top; + let_var_list(arg->c.c_car); + body = let_bind(arg->c.c_cdr, start, (struct bind_temp *)vs_top); + vs_top = (object *)start; + vs_push(body); + + Ftagbody(body); + +END: + bds_unwind(old_bds_top); + frs_pop(); + lex_env = oldlex; +} + +static void +FFN(FprogA)(VOL object arg) +{ + + object *oldlex = lex_env; + struct bind_temp *start; + object body; + bds_ptr old_bds_top = bds_top; + + if (endp(arg)) + FEtoo_few_argumentsF(arg); + + make_nil_block(); + + if (nlj_active) { + nlj_active = FALSE; + goto END; + } + + start = (struct bind_temp *) vs_top; + let_var_list(arg->c.c_car); + body = letA_bind(arg->c.c_cdr, start, (struct bind_temp *)vs_top); + vs_top = (object *)start; + vs_push(body); + + Ftagbody(body); + +END: + bds_unwind(old_bds_top); + frs_pop(); + lex_env = oldlex; +} + +static void +FFN(Fgo)(object args) +{ + + object lex_tag; + frame_ptr fr; + if (endp(args)) + FEtoo_few_argumentsF(args); + if (!endp(MMcdr(args))) + FEtoo_many_argumentsF(args); + lex_tag = lex_tag_sch(MMcar(args)); + if (MMnull(lex_tag)) + FEerror("~S is an undefined tag.", 1, MMcar(args)); + fr = frs_sch(MMcaddr(lex_tag)); + if (fr == NULL) + FEerror("The tag ~S is missing.", 1, MMcar(args)); + vs_push(MMcons(MMcaddr(lex_tag), MMcar(lex_tag))); + vs_base = vs_top; + unwind(fr,vs_top[-1]); + /* never reached */ +} + +static void +FFN(Fprogv)(object args) +{ + + object *top; + object symbols; + object values; + bds_ptr old_bds_top; + object var; + + if (endp(args) || endp(MMcdr(args))) + FEtoo_few_argumentsF(args); + + old_bds_top=bds_top; + + top=vs_top; + eval(MMcar(args)); + vs_top=top; + symbols=vs_base[0]; + vs_push(symbols); + eval(MMcadr(args)); + vs_top=top+1; + values=vs_base[0]; + vs_push(values); + while (!endp(symbols)) { + var = MMcar(symbols); + + if (type_of(var)!=t_symbol) not_a_symbol(var); + if ((enum stype)var->s.s_stype == stp_constant) + FEerror("Cannot bind the constant ~S.", 1, var); + + if (endp(values)) { + bds_bind(var, OBJNULL); + } else { + bds_bind(var, MMcar(values)); + values=MMcdr(values); + } + symbols=MMcdr(symbols); + } + + Fprogn(MMcddr(args)); + + bds_unwind(old_bds_top); +} + +FFD(Fprogn)(object body) +{ + + if(endp(body)) { + vs_base=vs_top; + vs_push(Cnil); + } else { + object *top=vs_top; + do { + vs_top=top; + eval(MMcar(body)); + body=MMcdr(body); + } while (!endp(body)); + } +} + +static void +FFN(Fprog1)(object arg) +{ + + object *top = vs_top; + + if(endp(arg)) + FEtoo_few_argumentsF(arg); + eval(MMcar(arg)); + vs_top = top; + vs_push(vs_base[0]); + for(arg = MMcdr(arg); !endp(arg); vs_top = top+1, arg = MMcdr(arg)) + eval(MMcar(arg)); + vs_base = top; + vs_top = top + 1; +} + +static void +FFN(Fprog2)(object arg) +{ + + object *top = vs_top; + + if(endp(arg) || endp(MMcdr(arg))) + FEtoo_few_argumentsF(arg); + eval(MMcar(arg)); + vs_top = top; + arg = MMcdr(arg); + eval(MMcar(arg)); + vs_top = top; + vs_push(vs_base[0]); + for(arg = MMcdr(arg); !endp(arg); vs_top = top+1, arg = MMcdr(arg)) + eval(MMcar(arg)); + vs_base = top; + vs_top = top+1; +} + +void +gcl_init_prog(void) +{ + make_special_form("TAGBODY", Ftagbody); + make_special_form("PROG", Fprog); + make_special_form("PROG*", FprogA); + make_special_form("GO", Fgo); + + make_special_form("PROGV", Fprogv); + + sLprogn=make_special_form("PROGN",Fprogn); + make_special_form("PROG1",Fprog1); + make_special_form("PROG2",Fprog2); +} diff --git a/o/read.d b/o/read.d new file mode 100755 index 0000000..f00a77a --- /dev/null +++ b/o/read.d @@ -0,0 +1,2550 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +*/ + +/* + read.d +*/ + + +#define NEED_ISFINITE +#include "include.h" + +#include +#include +#include "num_include.h" + +static object +current_readtable(void); + +DEFVAR("PATCH-SHARP",sSpatch_sharp,SI,sLnil,""); +static object +patch_sharp(object x) {return ifuncall1(sSpatch_sharp,x);} + + +#define digitp digitp1 + +static inline int +digitp(int i,int r) { + + if ( r<=10 || i<='9' ) + i-='0'; + else { + i=tolower(i)-'a'; + i=i<0 ? i : i+10; + } + + return i=0;u=0,o=o && f=0;u=0,o=o && fBUGGY_MAXIMUM_SSCANF_LENGTH) { + char *q1=s+BUGGY_MAXIMUM_SSCANF_LENGTH-strlen(q); + memmove(q1,q,strlen(q)+1); + q=q1; + } +#endif + n=sscanf(s,"%lf%n",&f,&m); + *q=c; + if (n!=1||s[m]) return OBJNULL; + + switch (ch=='e' || ch=='E' ? READdefault_float_format : ch) { + case 's':case 'S': + return make_shortfloat((float)f); + case 'f':case 'F':case 'd':case 'D':case 'l':case 'L': + return make_longfloat(f); + default: + return OBJNULL; + } + } +} + +static inline void +too_long_token(void) { + char *q; + int i; + + BEGIN_NO_INTERRUPT; + q = alloc_contblock(token->st.st_dim*2); + for (i = 0; i < token->st.st_dim; i++) + q[i] = token->st.st_self[i]; + token->st.st_self = q; + token->st.st_dim *= 2; + END_NO_INTERRUPT; + +} + +static inline void +null_terminate_token(void) { + + if (token->st.st_fillp==token->st.st_dim) + too_long_token(); + token->st.st_self[token->st.st_fillp]=0; + +} + + +#define token_buffer token->st.st_self +/* the active length of the token */ +int tok_leng; + + + +object dispatch_reader; + + +#define cat(c) (READtable->rt.rt_self[char_code((c))] \ + .rte_chattrib) + +static void +setup_READtable() +{ + READtable = current_readtable(); +} + + +/*bootstrap code*/ +DEFUN_NEW("SHARP-EQ-READER",object,fSsharp_eq_reader,SI,3,3,NONE,OO,OO,OO,OO,(object s,object ch,object ind),"") { + + object x,res; + + if (READsuppress) return Cnil; + if (ind==Cnil) FEerror("The #= readmacro requires an argument.", 0); + for (x=sSAsharp_eq_contextA->s.s_dbind;type_of(x)==t_cons && !(eql(x->c.c_car->c.c_car,ind));x=x->c.c_cdr); + if (x!=Cnil) FEerror("Duplicate definitions for #~D=.",1,ind); + x=x->c.c_car; + sSAsharp_eq_contextA->s.s_dbind=MMcons((x=MMcons(ind,MMcons(Cnil,OBJNULL))),sSAsharp_eq_contextA->s.s_dbind); + res=x->c.c_cdr->c.c_car=read_object(s); + if (res==x->c.c_cdr->c.c_cdr) + FEerror("#~D# is defined by itself.",1,x->c.c_car); + return res; +} + +DEFUN_NEW("SHARP-SHARP-READER",object,fSsharp_sharp_reader,SI,3,3,NONE,OO,OO,OO,OO,(object s,object ch,object ind),"") { + + object x; + + if (READsuppress) return Cnil; + if (ind==Cnil) FEerror("The ## readmacro requires an argument.", 0); + for (x=sSAsharp_eq_contextA->s.s_dbind;type_of(x)==t_cons && !(eql(x->c.c_car->c.c_car,ind));x=x->c.c_cdr); + if (x==Cnil) FEerror("#~D# is undefined.",1,ind); + x=x->c.c_car; + if (x->c.c_cdr->c.c_cdr==OBJNULL) + x->c.c_cdr->c.c_cdr=alloc_object(t_spice); + return x->c.c_cdr->c.c_cdr; +} + + +DEFUN_NEW("PATCH-SHARP",object,fSpatch_sharp,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { + + int i,j; + object y,p; + + switch (type_of(x)) { + + case t_spice: + for (y=sSAsharp_eq_contextA->s.s_dbind;type_of(y)==t_cons && y->c.c_car->c.c_cdr->c.c_cdr!=x;y=y->c.c_cdr); + return y->c.c_car->c.c_cdr->c.c_car; + break; + + case t_cons: + y=x; + do { + y->c.c_car=FFN(fSpatch_sharp)(y->c.c_car); + p=y; + y=y->c.c_cdr; + } while (type_of(y)==t_cons); + p->c.c_cdr=FFN(fSpatch_sharp)(p->c.c_cdr); + break; + + case t_vector: + if ((enum aelttype)x->v.v_elttype==aet_object) + for (i=0;iv.v_fillp;i++) + x->v.v_self[i]=FFN(fSpatch_sharp)(x->v.v_self[i]); + break; + + case t_array: + if ((enum aelttype)x->a.a_elttype==aet_object) { + for (i=0,j=1;ia.a_rank;i++) + j*=x->a.a_dims[i]; + for (i=0;ia.a_self[i]=FFN(fSpatch_sharp)(x->a.a_self[i]); + } + break; + + case t_structure: + y=x->str.str_def; + i=S_DATA(y)->length; + while (i-->0) + structure_set(x,y,i,FFN(fSpatch_sharp)(structure_ref(x,y,i))); + break; + + default: + break; + + } + + return(x); + +} +/*end bootstrap code*/ + +DEFVAR("*SHARP-EQ-CONTEXT*",sSAsharp_eq_contextA,SI,sLnil,""); + +DEFUN_NEW("ALLOC-SPICE",object,fSalloc_spice,SI,0,0,NONE,OO,OO,OO,OO,(void),"") { + return alloc_object(t_spice); +} +DEFUN_NEW("SPICE-P",object,fSspice_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { + return type_of(x)==t_spice ? Ct : Cnil; +} + +static void +setup_READ() +{ + object x; + + READtable = current_readtable(); + x = symbol_value(sLAread_default_float_formatA); + if (x == sLshort_float) + READdefault_float_format = 'S'; + else if (x == sLsingle_float || x == sLdouble_float || x == sLlong_float) + READdefault_float_format = 'F'; + else { + vs_push(x); + sLAread_default_float_formatA->s.s_dbind = sLsingle_float; + FEerror("The value of *READ-DEFAULT-FLOAT-FORMAT*, ~S, was illegal.", + 1, x); + } + x = symbol_value(sLAread_baseA); + if (type_of(x) != t_fixnum || fix(x) < 2 || fix(x) > 36) { + vs_push(x); + sLAread_baseA->s.s_dbind = make_fixnum(10); + FEerror("The value of *READ-BASE*, ~S, was illegal.", 1, x); + } + READbase = fix(x); + READsuppress = symbol_value(sLAread_suppressA) != Cnil; + sSAsharp_eq_contextA->s.s_dbind=Cnil; + + backq_level = 0; +} + +static void +setup_standard_READ() +{ + READtable = standard_readtable; + READdefault_float_format = 'F'; + READbase = 10; + READsuppress = FALSE; + sSAsharp_eq_contextA->s.s_dbind=Cnil; + backq_level = 0; +} + +object +read_char(in) +object in; +{ + return(code_char(readc_stream(in))); +} + +#define read_char(in) code_char(readc_stream(in)) + +static void +unread_char(c, in) +object c, in; +{ + if (type_of(c) != t_character) + FEwrong_type_argument(sLcharacter, c); + unreadc_stream(char_code(c), in); +} + +/* + Peek_char corresponds to COMMON Lisp function PEEK-CHAR. + When pt is TRUE, preceeding whitespaces are ignored. +*/ +object +peek_char(pt, in) +bool pt; +object in; +{ + object c; + + if (pt) { + do + c = read_char(in); + while (cat(c) == cat_whitespace); + unread_char(c, in); + return(c); + } else { + c = read_char(in); + unread_char(c, in); + return(c); + } +} + + +static object +read_object_recursive(in) +object in; +{ + VOL object x; + bool e; + + object old_READtable = READtable; + int old_READdefault_float_format = READdefault_float_format; + int old_READbase = READbase; + bool old_READsuppress = READsuppress; + + /* BUG FIX by Toshiba */ + vs_push(old_READtable); + + frs_push(FRS_PROTECT, Cnil); + if (nlj_active) { + e = TRUE; + goto L; + } + + READtable = current_readtable(); + x = symbol_value(sLAread_default_float_formatA); + if (x == sLshort_float) + READdefault_float_format = 'S'; + else if (x == sLsingle_float || x == sLdouble_float || x == sLlong_float) + READdefault_float_format = 'F'; + else { + vs_push(x); + sLAread_default_float_formatA->s.s_dbind = sLsingle_float; + FEerror("The value of *READ-DEFAULT-FLOAT-FORMAT*, ~S, was illegal.", + 1, x); + } + x = symbol_value(sLAread_baseA); + if (type_of(x) != t_fixnum || fix(x) < 2 || fix(x) > 36) { + vs_push(x); + sLAread_baseA->s.s_dbind = make_fixnum(10); + FEerror("The value of *READ-BASE*, ~S, was illegal.", 1, x); + } + READbase = fix(x); + READsuppress = symbol_value(sLAread_suppressA) != Cnil; + + x = read_object(in); + e = FALSE; + +L: + frs_pop(); + + READtable = old_READtable; + READdefault_float_format = old_READdefault_float_format; + READbase = old_READbase; + READsuppress = old_READsuppress; + + /* BUG FIX by Toshiba */ + vs_popp; + + if (e) { + nlj_active = FALSE; + unwind(nlj_fr, nlj_tag); + } + + return(x); +} + + +object +read_object_non_recursive(in) +object in; +{ + VOL object x; + bool e; + object old_READtable; + int old_READdefault_float_format; + int old_READbase; + int old_READsuppress; + object old_READcontext; + int old_backq_level; + + old_READtable = READtable; + old_READdefault_float_format = READdefault_float_format; + old_READbase = READbase; + old_READsuppress = READsuppress; + + old_READcontext=sSAsharp_eq_contextA->s.s_dbind; + + /* BUG FIX by Toshiba */ + vs_push(old_READtable); + old_backq_level = backq_level; + setup_READ(); + + frs_push(FRS_PROTECT, Cnil); + if (nlj_active) { + e = TRUE; + goto L; + } + + x = read_object(in); + vs_push(x); +#ifndef _WIN32 + while (listen_stream(in)) { + object c=read_char(in); + if (cat(c)!=cat_whitespace) { + unread_char(c,in); + break; + } + } +#endif + if (sSAsharp_eq_contextA->s.s_dbind!=Cnil) + x = vs_head = patch_sharp(x); + + e = FALSE; + +L: + frs_pop(); + + READtable = old_READtable; + READdefault_float_format = old_READdefault_float_format; + READbase = old_READbase; + READsuppress = old_READsuppress; + sSAsharp_eq_contextA->s.s_dbind=old_READcontext; + backq_level = old_backq_level; + if (e) { + nlj_active = FALSE; + unwind(nlj_fr, nlj_tag); + } + vs_popp; + /* BUG FIX by Toshiba */ + vs_popp; + return(x); +} + +#ifdef UNIX /* faster code for inner loop from file stream */ +#define xxxread_char_to(res,in,eof_code) \ + do{FILE *fp; \ + if(fp=in->sm.sm_fp) \ + {int ch = getc(fp); \ + if (ch==EOF) { \ + if (feof(fp)) { eof_code;} \ + else if (in->sm.sm_mode==smm_socket) \ + { ch = getOneChar(fp); \ + if (ch==EOF) { eof_code;}}} \ + else res=code_char(ch);} \ + else \ + { if (stream_at_end(in)) \ + {eof_code;} \ + else res=read_char(in);}} while(0) + +#define read_char_to(res,in,eof_code) \ + do{FILE *fp; \ + if((fp=in->sm.sm_fp)) \ + {int ch = getc(fp); \ + if (ch==EOF && feof(fp)) \ + { eof_code;} \ + else res=code_char(ch);} \ + else \ + {int ch ; \ + if(stream_at_end(in)) {eof_code ;} \ + ch = readc_stream(in); \ + if (ch == EOF) { eof_code;} \ + res = code_char(ch); \ + }} while(0) +#else +#define read_char_to(res,in,eof_code) \ + do {if(stream_at_end(in)) {eof_code ;} \ + else { int ch = readc_stream(in); \ + if (ch == EOF) { eof_code;} \ + res = code_char(ch); \ + } \ + } while(0) +#endif + +/* + Read_object(in) reads an object from stream in. + This routine corresponds to COMMON Lisp function READ. +*/ + +/* FIXME What should this be? Apparently no reliable way to use value stack */ +#define MAX_PACKAGE_STACK 1024 +static object P0[MAX_PACKAGE_STACK],*PP0=P0,LP; + +object +read_object(in) +object in; +{ + object x; + object c=Cnil; + enum chattrib a; + object *old_vs_base; + object result; + object p; + int colon=0, colon_type; + int i; + bool df, ilf; + VOL int length; + vs_mark; + + cs_check(in); + + vs_check_push(delimiting_char); + delimiting_char = OBJNULL; + df = detect_eos_flag; + detect_eos_flag = FALSE; + ilf = in_list_flag; + in_list_flag = FALSE; + dot_flag = FALSE; + +BEGIN: + do { read_char_to(c,in, { + if (df) { + vs_reset; + return(OBJNULL); + } else + end_of_stream(in); + }); + a = cat(c); + } while (a == cat_whitespace); + if (c->ch.ch_code == '(') { /* Loose package extension */ + LP=LP || PP0==P0 ? LP : PP0[-1]; /* push loose packages into nested lists */ + if (LP) { + if (PP0-P0>=MAX_PACKAGE_STACK) + FEerror("Too many nested package specifiers",0); + *PP0++=LP; + LP=NULL; + } + } else if (LP) + FEerror("Loose package prefix must be followed by a list",0); + if (c->ch.ch_code==')' && PP0>P0) PP0--; /* regardless of error behavior, + will pop stack to beginning as parens + must match before the reader starts */ + delimiting_char = vs_head; + if (delimiting_char != OBJNULL && c == delimiting_char) { + delimiting_char = OBJNULL; + vs_reset; + return(OBJNULL); + } + delimiting_char = OBJNULL; + if (a == cat_terminating || a == cat_non_terminating) + { + object *fun_box = vs_top; + + old_vs_base = vs_base; + vs_push(Cnil); + vs_base = vs_top; + vs_push(in); + vs_push(c); + + x = + READtable->rt.rt_self[char_code(c)].rte_macro; + fun_box[0] = x; + super_funcall(x); + + i = vs_top - vs_base; + if (i == 0) { + vs_base = old_vs_base; + vs_top = old_vs_top + 1; + goto BEGIN; + } + if (i > 1) { + vs_push(make_fixnum(i)); + FEerror("The readmacro ~S returned ~D values.", + 2, fun_box[0], vs_top[-1]); + } + result = vs_base[0]; + vs_base = old_vs_base; + vs_reset; + return(result); + } + escape_flag = FALSE; + length = 0; tok_leng=0; + colon_type = 0; + goto L; + for (;;) { + if (length >= token->st.st_dim) + too_long_token(); + token_buffer[(tok_leng++,length++)] = char_code(c); + K: + read_char_to(c,in,goto M); + a = cat(c); + L: + if (a == cat_single_escape) { + c = read_char(in); + a = cat_constituent; + escape_flag = TRUE; + } else if (a == cat_multiple_escape) { + escape_flag = TRUE; + for (;;) { + if (stream_at_end(in)) + end_of_stream(in); + c = read_char(in); + a = cat(c); + if (a == cat_single_escape) { + c = read_char(in); + a = cat_constituent; + } else if (a == cat_multiple_escape) + break; + if (length >= token->st.st_dim) + too_long_token(); + token_buffer[(tok_leng++,length++)] = char_code(c); + } + goto K; + } else if (a == cat_terminating) { + break; + } else if (a == cat_whitespace) { + /* skip all whitespace after trailing colon if no escape seen */ + if (colon+colon_type==length && !escape_flag) + goto K; + else + break; + } + else if ('a' <= char_code(c) && char_code(c) <= 'z') + c = code_char(char_code(c) - ('a' - 'A')); + else if (char_code(c) == ':') { + if (colon_type == 0) { + colon_type = 1; + colon = length; + } else if (colon_type == 1 && colon == length-1) + colon_type = 2; + else + colon_type = -1; + /* Colon has appeared twice. */ + } + } + if (preserving_whitespace_flag || cat(c) != cat_whitespace) + unread_char(c, in); + +M: + if (READsuppress) { + token->st.st_fillp = length; + vs_reset; + return(Cnil); + } + if (ilf && !escape_flag && + length == 1 && token->st.st_self[0] == '.') { + dot_flag = TRUE; + vs_reset; + return(Cnil); + } else if (!escape_flag && length > 0) { + for (i = 0; i < length; i++) + if (token->st.st_self[i] != '.') + goto N; + FEerror("Dots appeared illegally.", 0); + } + +N: + token->st.st_fillp = length; + if (escape_flag || (READbase<=10 && token_buffer[0]>'9')) + goto SYMBOL; + null_terminate_token(); + x = parse_number(token_buffer, READbase); + if (x != OBJNULL) { + vs_reset; + return(x); + } + +SYMBOL: + if (colon_type == 1 /* && length > colon + 1 */) { + if (colon == 0) + p = keyword_package; + else { + token->st.st_fillp = colon; + p = find_package(token); + if (p == Cnil) { + vs_push(copy_simple_string(token)); + FEerror("There is no package with the name \"~A\".", + 1, vs_head); + } + } + for (i = colon + 1; i < length; i++) + token_buffer[i - (colon + 1)] + = token_buffer[i]; + token->st.st_fillp = length - (colon + 1); + if (colon > 0) { + x = find_symbol(token, p); + if (intern_flag != EXTERNAL) { + vs_push(copy_simple_string(token)); + FEerror("Cannot find the external symbol ~A in ~S.", + 2, vs_head, p); + /* no need to push a package */ + } + vs_reset; + return(x); + } + } else if (colon_type == 2 /* && colon > 0 && length > colon + 2 */) { + token->st.st_fillp = colon; + p = find_package(token); + if (p == Cnil) { + vs_push(copy_simple_string(token)); + FEerror("There is no package with the name \"~A\".", + 1, vs_head); + } + for (i = colon + 2; i < length; i++) + token_buffer[i - (colon + 2)] + = token_buffer[i]; + token->st.st_fillp = length - (colon + 2); + } else + p = current_package(); + /* loose package is an empty token following a non-beginning + colon with no escape, to allow for ||*/ + if (!token->st.st_fillp && colon && !escape_flag) { + LP=p; + goto BEGIN; + } + /* unless package specified for this symbol, use loose package if present */ + if (PP0>P0 && !colon_type) + p=PP0[-1]; + vs_push(p); + x = intern(token, p); + vs_push(x); + if (x->s.s_self == token_buffer) { + {BEGIN_NO_INTERRUPT; + x->s.s_self = alloc_relblock(token->st.st_fillp); + for (i = 0; i < token->st.st_fillp; i++) + x->s.s_self[i] = token_buffer[i]; + END_NO_INTERRUPT;} + } + vs_reset; + return(x); +} + +static void +Lleft_parenthesis_reader() +{ + object in, x; + object *p; + + check_arg(2); + in = vs_base[0]; + vs_head = Cnil; + p = &vs_head; + for (;;) { + delimiting_char = code_char(')'); + in_list_flag = TRUE; + x = read_object(in); + if (x == OBJNULL) + goto ENDUP; + if (dot_flag) { + if (p == &vs_head) + FEerror("A dot appeared after a left parenthesis.", 0); + delimiting_char = code_char(')'); + in_list_flag = TRUE; + *p = SAFE_CDR(read_object(in)); + if (dot_flag) + FEerror("Two dots appeared consecutively.", 0); + if (*p==OBJNULL) + FEerror("Object missing after dot.", 0); + delimiting_char = code_char(')'); + in_list_flag = TRUE; + if (read_object(in)!=OBJNULL) + FEerror("Two objects after dot.",0); + goto ENDUP; + } + vs_push(x); + *p = make_cons(x, Cnil); + vs_popp; + p = &((*p)->c.c_cdr); + } + +ENDUP: + vs_base[0] = vs_pop; + return; +} + + +/* + Read_string(delim, in) reads + a simple string terminated by character code delim + and places it in token. + Delim is not included in the string but discarded. +*/ +static void +read_string(delim, in) +int delim; +object in; +{ + int i; + object c; + + i = 0; + for (;;) { + c = read_char(in); + if (char_code(c) == delim) + break; + else if (cat(c) == cat_single_escape) + c = read_char(in); + if (i >= token->st.st_dim) + too_long_token(); + token_buffer[i++] = char_code(c); + } + token->st.st_fillp = i; +} + +/* + Read_constituent(in) reads + a sequence of constituent characters from stream in + and places it in token_buffer. +*/ +static void +read_constituent(in) +object in; +{ + int i, j; + object c; + + i = 0; + for (;;) { + read_char_to(c,in,goto FIN); + if (cat(c) != cat_constituent) { + unread_char(c, in); + break; + } + j = char_code(c); + token_buffer[i++] = j; + } + FIN: + token->st.st_fillp = i; + +} + +static void +Ldouble_quote_reader() +{ + check_arg(2); + vs_popp; + read_string('"', vs_base[0]); + vs_base[0] = copy_simple_string(token); +} + +static void +Ldispatch_reader() +{ + object c, x; + int i, j; + object in; + + check_arg(2); + + in = vs_base[0]; + c = vs_base[1]; + + if (READtable->rt.rt_self[char_code(c)].rte_dtab == NULL) + FEerror("~C is not a dispatching macro character", 1, c); + + + for (i=0;ist.st_dim;i++) { + c=read_char(in); + j=char_code(c); + if (digitp(j,10)<0) + break; + token->st.st_self[i]=j; + } + if (i==token->st.st_dim) + FEerror("Dispatch number too long", 0); + if (i) { + token->st.st_fillp=i; + null_terminate_token(); + x=parse_number(token->st.st_self,10); + if (x == OBJNULL) + FEerror("Cannot parse the dispatch macro number.", 0); + } else + x=Cnil; + vs_push(x); + + x = + READtable->rt.rt_self[char_code(vs_base[1])].rte_dtab[char_code(c)]; + vs_base[1] = c; + super_funcall(x); +} + +static void +Lsingle_quote_reader() +{ + check_arg(2); + vs_popp; + vs_push(sLquote); + vs_push(read_object(vs_base[0])); + vs_push(Cnil); + stack_cons(); + stack_cons(); + vs_base[0] = vs_pop; +} + +static void +Lright_parenthesis_reader() +{ + check_arg(2); + vs_popp; + vs_popp; + /* no result */ +} + +/* +Lcomma_reader(){} +*/ + +static void +Lsemicolon_reader() +{ + object c; + object str= vs_base[0]; + check_arg(2); + vs_popp; + do + { read_char_to(c,str, goto L); } + while (char_code(c) != '\n'); +L: + vs_popp; + vs_base[0] = Cnil; + /* no result */ +} + +/* +Lbackquote_reader(){} +*/ + +/* + sharpmacro routines +*/ +static void +extra_argument(int); + +static void +Lsharp_C_reader() +{ + object x, c; + + check_arg(3); + if (vs_base[2] != Cnil && !READsuppress) + extra_argument('C'); + vs_popp; + vs_popp; + c = read_char(vs_base[0]); + if (char_code(c) != '(') + FEerror("A left parenthesis is expected.", 0); + delimiting_char = code_char(')'); + x = read_object(vs_base[0]); + if (x == OBJNULL) + FEerror("No real part.", 0); + vs_push(x); + delimiting_char = code_char(')'); + x = read_object(vs_base[0]); + if (x == OBJNULL) + FEerror("No imaginary part.", 0); + vs_push(x); + delimiting_char = code_char(')'); + x = read_object(vs_base[0]); + if (x != OBJNULL) + FEerror("A right parenthesis is expected.", 0); + if (READsuppress) vs_base[0]= Cnil ; + else + if (contains_sharp_comma(vs_base[1]) || + contains_sharp_comma(vs_base[2])) { + vs_base[0] = alloc_object(t_complex); + vs_base[0]->cmp.cmp_real = vs_base[1]; + vs_base[0]->cmp.cmp_imag = vs_base[2]; + } else { + check_type_number(&vs_base[1]); + check_type_number(&vs_base[2]); + vs_base[0] = make_complex(vs_base[1], vs_base[2]); + } + vs_top = vs_base + 1; +} + +static void +Lsharp_backslash_reader() +{ + object c; + + check_arg(3); + if (vs_base[2] != Cnil && !READsuppress) + if (type_of(vs_base[2]) != t_fixnum || + fix(vs_base[2]) != 0) + FEerror("~S is an illegal CHAR-FONT.", 1, vs_base[2]); + /* assuming that CHAR-FONT-LIMIT is 1 */ + vs_popp; + vs_popp; + unread_char(code_char('\\'), vs_base[0]); + if (READsuppress) { + (void)read_object(vs_base[0]); + vs_base[0] = Cnil; + return; + } + READsuppress = TRUE; + (void)read_object(vs_base[0]); + READsuppress = FALSE; + c = token; + if (c->s.s_fillp == 1) { + vs_base[0] = code_char(c->ust.ust_self[0]); + return; + } + if (string_equal(c, STreturn)) + vs_base[0] = code_char('\r'); + else if (string_equal(c, STspace)) + vs_base[0] = code_char(' '); + else if (string_equal(c, STrubout)) + vs_base[0] = code_char('\177'); + else if (string_equal(c, STpage)) + vs_base[0] = code_char('\f'); + else if (string_equal(c, STtab)) + vs_base[0] = code_char('\t'); + else if (string_equal(c, STbackspace)) + vs_base[0] = code_char('\b'); + else if (string_equal(c, STlinefeed) || string_equal(c, STnewline)) + vs_base[0] = code_char('\n'); + else if (c->s.s_fillp == 2 && c->s.s_self[0] == '^') + vs_base[0] = code_char(c->s.s_self[1] & 037); + else if (c->s.s_self[0] =='\\' && c->s.s_fillp > 1) { + int i, n; + for (n = 0, i = 1; i < c->s.s_fillp; i++) + if (c->s.s_self[i] < '0' || '7' < c->s.s_self[i]) + FEerror("Octal digit expected.", 0); + else + n = 8*n + c->s.s_self[i] - '0'; + vs_base[0] = code_char(n & 0377); + } else + FEerror("~S is an illegal character name.", 1, c); +} + +static void +Lsharp_single_quote_reader() +{ + + check_arg(3); + if(vs_base[2] != Cnil && !READsuppress) + extra_argument('#'); + vs_popp; + vs_popp; + vs_push(sLfunction); + vs_push(read_object(vs_base[0])); + vs_push(Cnil); + stack_cons(); + stack_cons(); + vs_base[0] = vs_pop; +} + +#define QUOTE 1 +#define EVAL 2 +#define LIST 3 +#define LISTA 4 +#define APPEND 5 +#define NCONC 6 + +object siScomma; + +static void +Lsharp_left_parenthesis_reader() +{ + + int dim=0; + int dimcount; + object in, x; + int a; + object *vsp; + + check_arg(3); + if (vs_base[2] == Cnil || READsuppress) + dim = -1; + else if (type_of(vs_base[2]) == t_fixnum) + dim = fix(vs_base[2]); + vs_popp; + vs_popp; + in = vs_base[0]; + if (backq_level > 0) { + unreadc_stream('(', in); + vs_push(read_object(in)); + a = backq_car(vs_base[1]); + if (a == APPEND || a == NCONC) + FEerror(",at or ,. has appeared in an illegal position.", 0); + if (a == QUOTE) { + vsp = vs_top; + dimcount = 0; + for (x = vs_base[2]; !endp(x); x = x->c.c_cdr) { + vs_check_push(x->c.c_car); + dimcount++; + } + goto L; + } + vs_push(siScomma); + vs_push(sLapply); + vs_push(sLquote); + vs_push(sLvector); + vs_push(Cnil); + stack_cons(); + stack_cons(); + vs_push(vs_base[2]); + vs_push(Cnil); + stack_cons(); + stack_cons(); + stack_cons(); + stack_cons(); + vs_base = vs_top - 1; + return; + } + vsp = vs_top; + dimcount = 0; + for (;;) { + delimiting_char = code_char(')'); + x = read_object(in); + if (x == OBJNULL) + break; + vs_check_push(x); + dimcount++; + } +L: + if (dim >= 0) { + if (dimcount > dim) + FEerror("Too many elements in #(...).", 0); + else { + if (dimcount == 0) + FEerror("Cannot fill the vector #().", 0); + x = vs_head; + for (; dimcount < dim; dimcount++) + vs_push(x); + } + } + {BEGIN_NO_INTERRUPT; + x = alloc_simple_vector(dimcount, aet_object); + vs_push(x); + x->v.v_self + = (object *)alloc_relblock(dimcount * sizeof(object)); + vs_popp; + for (dim = 0; dim < dimcount; dim++) + x->v.v_self[dim] = vsp[dim]; + vs_top = vs_base; + END_NO_INTERRUPT;} + vs_push(x); +} + +static void +Lsharp_asterisk_reader() +{ + int dim=0; + int dimcount; + object in, x; + object *vsp; + + check_arg(3); + if (READsuppress) { + read_constituent(vs_base[0]); + vs_popp; + vs_popp; + vs_base[0] = Cnil; + return; + } + if (vs_head == Cnil) + dim = -1; + else if (type_of(vs_head) == t_fixnum) + dim = fix(vs_head); + vs_popp; + vs_popp; + in = vs_head; + vsp = vs_top; + dimcount = 0; + for (;;) { + if (stream_at_end(in)) + break; + x = read_char(in); + if (char_code(x) != '0' && char_code(x) != '1') { + unread_char(x, in); + break; + } + vs_check_push(x); + dimcount++; + } + if (dim >= 0) { + if (dimcount > dim) + FEerror("Too many elements in #*....", 0); + else { + if (dimcount == 0) + error("Cannot fill the bit-vector #*."); + x = vs_head; + for (; dimcount < dim; dimcount++) + vs_push(x); + } + } + {BEGIN_NO_INTERRUPT; + x = alloc_simple_bitvector(dimcount); + vs_push(x); + x->bv.bv_self = alloc_relblock((dimcount + 7)/8); + vs_popp; + for (dim = 0; dim < dimcount; dim++) + if (char_code(vsp[dim]) == '0') + x->bv.bv_self[dim/8] &= ~(0200 >> dim%8); + else + x->bv.bv_self[dim/8] |= 0200 >> dim%8; + END_NO_INTERRUPT;} + vs_top = vs_base; + vs_push(x); +} + +static void +Lsharp_colon_reader() +{ + object in; + int length; + object c; + enum chattrib a; + + if (vs_base[2] != Cnil && !READsuppress) + extra_argument(':'); + vs_popp; + vs_popp; + in = vs_base[0]; + c = read_char(in); + a = cat(c); + escape_flag = FALSE; + length = 0; tok_leng=0; + goto L; + for (;;) { + if (length >= token->st.st_dim) + too_long_token(); + token_buffer[(tok_leng++,length++)] = char_code(c); + K: + if (stream_at_end(in)) + goto M; + c = read_char(in); + a = cat(c); + L: + if (a == cat_single_escape) { + c = read_char(in); + a = cat_constituent; + escape_flag = TRUE; + } else if (a == cat_multiple_escape) { + escape_flag = TRUE; + for (;;) { + if (stream_at_end(in)) + end_of_stream(in); + c = read_char(in); + a = cat(c); + if (a == cat_single_escape) { + c = read_char(in); + a = cat_constituent; + } else if (a == cat_multiple_escape) + break; + if (length >= token->st.st_dim) + too_long_token(); + token_buffer[(tok_leng++,length++)] = char_code(c); + } + goto K; + } else if ('a' <= char_code(c) && char_code(c) <= 'z') + c = code_char(char_code(c) - ('a' - 'A')); + if (a == cat_whitespace || a == cat_terminating) + break; + } + if (preserving_whitespace_flag || cat(c) != cat_whitespace) + unread_char(c, in); + +M: + if (READsuppress) { + vs_base[0] = Cnil; + return; + } + token->st.st_fillp = length; + vs_base[0] = copy_simple_string(token); + vs_base[0] = make_symbol(vs_base[0]); +} + +static void +Lsharp_dot_reader() +{ + check_arg(3); + if(vs_base[2] != Cnil && !READsuppress) + extra_argument('.'); + vs_popp; + vs_popp; + if (READsuppress) { + read_object(vs_base[0]); + vs_base[0] = Cnil; + return; + } + vs_base[0] = read_object(vs_base[0]); + vs_base[0] = ieval(vs_base[0]); +} + +static void +Lsharp_comma_reader() +{ + check_arg(3); + if(vs_base[2] != Cnil && !READsuppress) + extra_argument(','); + vs_popp; + vs_popp; + if (READsuppress) { + read_object(vs_base[0]); + vs_base[0] = Cnil; + return; + } + vs_base[0] = read_object(vs_base[0]); + vs_base[0] = ieval(vs_base[0]); +} + +static void +FFN(siLsharp_comma_reader_for_compiler)() +{ + check_arg(3); + if(vs_base[2] != Cnil && !READsuppress) + extra_argument(','); + vs_popp; + vs_popp; + if (READsuppress) { + vs_base[0] = Cnil; + return; + } + vs_base[0] = read_object(vs_base[0]); + vs_base[0] = make_cons(siSsharp_comma, vs_base[0]); +} + +/* + For fasload. +*/ +static void +Lsharp_exclamation_reader() +{ + check_arg(3); + if(vs_base[2] != Cnil && !READsuppress) + extra_argument('!'); + vs_popp; + vs_popp; + if (READsuppress) { + vs_base[0] = Cnil; + return; + } + vs_base[0] = read_object(vs_base[0]); + if (sSAsharp_eq_contextA->s.s_dbind!=Cnil) + vs_base[0]=patch_sharp(vs_base[0]); + ieval(vs_base[0]); + vs_popp; +} + +static void +Lsharp_B_reader() +{ + + if(vs_base[2] != Cnil && !READsuppress) + extra_argument('B'); + vs_popp; + vs_popp; + read_constituent(vs_base[0]); + if (READsuppress) { + vs_base[0] = Cnil; + return; + } + null_terminate_token(); + vs_base[0] + = parse_number(token_buffer, 2); + if (vs_base[0] == OBJNULL) + FEerror("Cannot parse the #B readmacro.", 0); + if (type_of(vs_base[0]) == t_shortfloat || + type_of(vs_base[0]) == t_longfloat) + FEerror("The float ~S appeared after the #B readmacro.", + 1, vs_base[0]); +} + +static void +Lsharp_O_reader() +{ + + if(vs_base[2] != Cnil && !READsuppress) + extra_argument('O'); + vs_popp; + vs_popp; + read_constituent(vs_base[0]); + if (READsuppress) { + vs_base[0] = Cnil; + return; + } + null_terminate_token(); + vs_base[0] + = parse_number(token_buffer, 8); + if (vs_base[0] == OBJNULL) + FEerror("Cannot parse the #O readmacro.", 0); + if (type_of(vs_base[0]) == t_shortfloat || + type_of(vs_base[0]) == t_longfloat) + FEerror("The float ~S appeared after the #O readmacro.", + 1, vs_base[0]); +} + +static void +Lsharp_X_reader() +{ + + if(vs_base[2] != Cnil && !READsuppress) + extra_argument('X'); + vs_popp; + vs_popp; + read_constituent(vs_base[0]); + if (READsuppress) { + vs_base[0] = Cnil; + return; + } + null_terminate_token(); + vs_base[0] + = parse_number(token_buffer, 16); + if (vs_base[0] == OBJNULL) + FEerror("Cannot parse the #X readmacro.", 0); + if (type_of(vs_base[0]) == t_shortfloat || + type_of(vs_base[0]) == t_longfloat) + FEerror("The float ~S appeared after the #X readmacro.", + 1, vs_base[0]); +} + +static void +Lsharp_R_reader() +{ + int radix=0; + + check_arg(3); + if (READsuppress) + radix = 10; + else if (type_of(vs_base[2]) == t_fixnum) { + radix = fix(vs_base[2]); + if (radix > 36 || radix < 2) + FEerror("~S is an illegal radix.", 1, vs_base[2]); + } else + FEerror("No radix was supplied in the #R readmacro.", 0); + vs_popp; + vs_popp; + read_constituent(vs_base[0]); + if (READsuppress) { + vs_base[0] = Cnil; + return; + } + null_terminate_token(); + vs_base[0] + = parse_number(token_buffer, radix); + if (vs_base[0] == OBJNULL) + FEerror("Cannot parse the #R readmacro.", 0); + if (type_of(vs_base[0]) == t_shortfloat || + type_of(vs_base[0]) == t_longfloat) + FEerror("The float ~S appeared after the #R readmacro.", + 1, vs_base[0]); +} + +static void Lsharp_plus_reader(){} + +static void Lsharp_minus_reader(){} + +static void +Lsharp_vertical_bar_reader() +{ + int c; + int level = 0; + + check_arg(3); + if (vs_base[2] != Cnil && !READsuppress) + extra_argument('|'); + vs_popp; + vs_popp; + for (;;) { + c = readc_stream(vs_base[0]); + L: + if (c == '#') { + c = readc_stream(vs_base[0]); + if (c == '|') + level++; + } else if (c == '|') { + c = readc_stream(vs_base[0]); + if (c == '#') { + if (level == 0) + break; + else + --level; + } else + goto L; + } + } + vs_popp; + vs_base[0] = Cnil; + /* no result */ +} + +static void +Ldefault_dispatch_macro() +{ + FEerror("The default dispatch macro signalled an error.", 0); +} + +/* + #p" ... " returns the pathname with namestring ... . +*/ +static void +Lsharp_p_reader() +{ + check_arg(3); + if (vs_base[2] != Cnil && !READsuppress) + extra_argument('p'); + vs_popp; + vs_popp; + vs_base[0] = read_object(vs_base[0]); + vs_base[0] = coerce_to_pathname(vs_base[0]); +} + +/* + #" ... " returns the pathname with namestring ... . +*/ +static void +Lsharp_double_quote_reader() +{ + check_arg(3); + + if (vs_base[2] != Cnil && !READsuppress) + extra_argument('"'); + vs_popp; + unread_char(vs_base[1], vs_base[0]); + vs_popp; + vs_base[0] = read_object(vs_base[0]); + vs_base[0] = coerce_to_pathname(vs_base[0]); +} + +/* + #$ fixnum returns a random-state with the fixnum + as its content. +*/ +static void +Lsharp_dollar_reader() +{ + object x; + enum type tx; + + check_arg(3); + if (vs_base[2] != Cnil && !READsuppress) + extra_argument('$'); + vs_popp; + vs_popp; + x = read_object(vs_base[0]); + tx=type_of(x); + vs_base[0] = alloc_object(t_random); + init_gmp_rnd_state(&vs_base[0]->rnd.rnd_state); + if (tx!=t_fixnum || fix(x)) { + if (tx==t_fixnum) { + if (vs_base[0]->rnd.rnd_state._mp_seed->_mp_size!=1) + FEerror("Cannot make a random-state with the value ~S.",1, x); + mpz_set_ui(vs_base[0]->rnd.rnd_state._mp_seed,fix(x)); + } else { + if (x->big.big_mpz_t._mp_size!=vs_base[0]->rnd.rnd_state._mp_seed->_mp_size) + FEerror("Cannot make a random-state with the value ~S.",1, x); + memcpy(vs_base[0]->rnd.rnd_state._mp_seed->_mp_d,x->big.big_mpz_t._mp_d, + vs_base[0]->rnd.rnd_state._mp_seed->_mp_size*sizeof(*vs_base[0]->rnd.rnd_state._mp_seed->_mp_d)); + } + } + +} + +/* + readtable routines +*/ + +static object +copy_readtable(from, to) +object from, to; +{ + struct rtent *rtab; + int i, j; + vs_mark; + {BEGIN_NO_INTERRUPT; + if (to == Cnil) { + to = alloc_object(t_readtable); + to->rt.rt_self = NULL; + /* For GBC not to go mad. */ + vs_push(to); + /* Saving for GBC. */ + to->rt.rt_self + = rtab + = (struct rtent *) + alloc_contblock(RTABSIZE * sizeof(struct rtent)); + for (i = 0; i < RTABSIZE; i++) + rtab[i] = from->rt.rt_self[i]; + /* structure assignment */ + } else + rtab=to->rt.rt_self; + for (i = 0; i < RTABSIZE; i++) + if (from->rt.rt_self[i].rte_dtab != NULL) { + rtab[i].rte_dtab + = (object *) + alloc_contblock(RTABSIZE * sizeof(object)); + for (j = 0; j < RTABSIZE; j++) + rtab[i].rte_dtab[j] + = from->rt.rt_self[i].rte_dtab[j]; + } + vs_reset; + END_NO_INTERRUPT;} + return(to); +} + +static object +current_readtable() +{ + object r; + + r = symbol_value(Vreadtable); + if (type_of(r) != t_readtable) { + Vreadtable->s.s_dbind = copy_readtable(standard_readtable,sLnil); + FEerror("The value of *READTABLE*, ~S, was not a readtable.", + 1, r); + } + return(r); +} + + +@(defun read (&optional (strm `symbol_value(sLAstandard_inputA)`) + (eof_errorp Ct) + eof_value + recursivep + &aux x) +@ + if (strm == Cnil) + strm = symbol_value(sLAstandard_inputA); + else if (strm == Ct) + strm = symbol_value(sLAterminal_ioA); + check_type_stream(&strm); + if (recursivep == Cnil) + preserving_whitespace_flag = FALSE; + detect_eos_flag = TRUE; + if (recursivep == Cnil) + x = read_object_non_recursive(strm); + else + x = read_object_recursive(strm); + if (x == OBJNULL) { + if (eof_errorp == Cnil && recursivep == Cnil) + @(return eof_value) + end_of_stream(strm); + } + @(return x) +@) + +@(static defun read_preserving_whitespace + (&optional (strm `symbol_value(sLAstandard_inputA)`) + (eof_errorp Ct) + eof_value + recursivep + &aux x) + object c; +@ + if (strm == Cnil) + strm = symbol_value(sLAstandard_inputA); + else if (strm == Ct) + strm = symbol_value(sLAterminal_ioA); + check_type_stream(&strm); + while (!stream_at_end(strm)) { + c = read_char(strm); + if (cat(c) != cat_whitespace) { + unread_char(c, strm); + goto READ; + } + } + /* if (eof_errorp == Cnil && recursivep == Cnil) */ + /* @(return eof_value) */ + /* end_of_stream(strm); */ + +READ: + if (recursivep == Cnil) + preserving_whitespace_flag = TRUE; + detect_eos_flag = TRUE; + if (recursivep == Cnil) + x = read_object_non_recursive(strm); + else + x = read_object_recursive(strm); + if (x == OBJNULL) { + if (eof_errorp == Cnil && recursivep == Cnil) + @(return eof_value) + end_of_stream(strm); + } + @(return x) +@) + +@(defun read_delimited_list + (d + &optional (strm `symbol_value(sLAstandard_inputA)`) + recursivep + &aux l x) + + object *p; + + bool e; + volatile object old_READcontext; + volatile int old_backq_level=0; + +@ + + check_type_character(&d); + if (strm == Cnil) + strm = symbol_value(sLAstandard_inputA); + else if (strm == Ct) + strm = symbol_value(sLAterminal_ioA); + check_type_stream(&strm); + if (recursivep == Cnil) { + + old_READcontext=sSAsharp_eq_contextA->s.s_dbind; + old_backq_level = backq_level; + setup_READ(); + frs_push(FRS_PROTECT, Cnil); + if (nlj_active) { + e = TRUE; + goto L; + } + } + l = Cnil; + p = &l; + preserving_whitespace_flag = FALSE; /* necessary? */ + for (;;) { + delimiting_char = d; + x = read_object_recursive(strm); + if (x == OBJNULL) + break; + *p = make_cons(x, Cnil); + p = &((*p)->c.c_cdr); + } + if (recursivep == Cnil) { + if (sSAsharp_eq_contextA->s.s_dbind!=Cnil) + l = patch_sharp(l); + e = FALSE; + L: + frs_pop(); + sSAsharp_eq_contextA->s.s_dbind=old_READcontext; + backq_level = old_backq_level; + if (e) { + nlj_active = FALSE; + unwind(nlj_fr, nlj_tag); + } + } + @(return l) +@) + +@(defun read_line (&optional (strm `symbol_value(sLAstandard_inputA)`) + (eof_errorp Ct) + eof_value + recursivep + &aux c) + int i; +@ + if (strm == Cnil) + strm = symbol_value(sLAstandard_inputA); + else if (strm == Ct) + strm = symbol_value(sLAterminal_ioA); + check_type_stream(&strm); + if (stream_at_end(strm)) { + if (eof_errorp == Cnil && recursivep == Cnil) + @(return eof_value) + else + end_of_stream(strm); + } + i = 0; + for (;;) { + read_char_to(c,strm,c = Ct; goto FINISH); + if (char_code(c) == '\n') { + c = Cnil; + break; + } + if (i >= token->st.st_dim-1) + too_long_token(); + token->st.st_self[i++] = char_code(c); + } + FINISH: +#ifdef DOES_CRLF + if (i > 0 && token->st.st_self[i-1] == '\r') i--; +#endif + token->st.st_fillp = i; + /* no disadvantage to returning an adjustable string */ + + {object uu= copy_simple_string(token); +/* uu->st.st_hasfillp=TRUE; + uu->st.st_adjustable=TRUE; +*/ + @(return uu c) + } +@) + +@(defun read_char (&optional (strm `symbol_value(sLAstandard_inputA)`) + (eof_errorp Ct) + eof_value + recursivep) +@ + if (strm == Cnil) + strm = symbol_value(sLAstandard_inputA); + else if (strm == Ct) + strm = symbol_value(sLAterminal_ioA); + check_type_stream(&strm); + {object x ; + read_char_to(x,strm,goto AT_EOF); + @(return `x`) + AT_EOF: + if (eof_errorp == Cnil && recursivep == Cnil) + @(return eof_value) + else + end_of_stream(strm); + } +@) + +@(defun unread_char (c &optional (strm `symbol_value(sLAstandard_inputA)`)) +@ + check_type_character(&c); + if (strm == Cnil) + strm = symbol_value(sLAstandard_inputA); + else if (strm == Ct) + strm = symbol_value(sLAterminal_ioA); + check_type_stream(&strm); + unread_char(c, strm); + @(return Cnil) +@) + +@(defun peek_char (&optional peek_type + (strm `symbol_value(sLAstandard_inputA)`) + (eof_errorp Ct) + eof_value + recursivep) + object c; +@ + if (strm == Cnil) + strm = symbol_value(sLAstandard_inputA); + else if (strm == Ct) + strm = symbol_value(sLAterminal_ioA); + check_type_stream(&strm); + setup_READtable(); + if (peek_type == Cnil) { + if (stream_at_end(strm)) { + if (eof_errorp == Cnil && recursivep == Cnil) + @(return eof_value) + else + end_of_stream(strm); + } + c = read_char(strm); + unread_char(c, strm); + @(return c) + } + if (peek_type == Ct) { + while (!stream_at_end(strm)) { + c = read_char(strm); + if (cat(c) != cat_whitespace) { + unread_char(c, strm); + @(return c) + } + } + if (eof_errorp == Cnil) + @(return eof_value) + else + end_of_stream(strm); + } + check_type_character(&peek_type); + while (!stream_at_end(strm)) { + c = read_char(strm); + if (char_eq(c, peek_type)) { + unread_char(c, strm); + @(return c) + } + } + if (eof_errorp == Cnil) + @(return eof_value) + else + end_of_stream(strm); +@) + +@(defun listen (&optional (strm `symbol_value(sLAstandard_inputA)`)) +@ + if (strm == Cnil) + strm = symbol_value(sLAstandard_inputA); + else if (strm == Ct) + strm = symbol_value(sLAterminal_ioA); + check_type_stream(&strm); + if (listen_stream(strm)) + @(return Ct) + else + @(return Cnil) +@) + +@(defun read_char_no_hang (&optional (strm `symbol_value(sLAstandard_inputA)`) + (eof_errorp Ct) + eof_value + recursivep) +@ + if (strm == Cnil) + strm = symbol_value(sLAstandard_inputA); + else if (strm == Ct) + strm = symbol_value(sLAterminal_ioA); + check_type_stream(&strm); + if (stream_at_end(strm)) { + if (eof_errorp == Cnil) + @(return eof_value) + else + end_of_stream(strm); + } + if (!listen_stream(strm)) @(return Cnil) + @(return `read_char(strm)`) +@) + +@(defun clear_input (&optional (strm `symbol_value(sLAstandard_inputA)`)) +@ + if (strm == Cnil) + strm = symbol_value(sLAstandard_inputA); + else if (strm == Ct) + strm = symbol_value(sLAterminal_ioA); + check_type_stream(&strm); +#ifdef LISTEN_FOR_INPUT + while(listen_stream(strm)) {readc_stream(strm);} +#endif + @(return Cnil) +@) + +@(defun parse_integer (strng + &key start + end + (radix `make_fixnum(10)`) + junk_allowed + &aux x) + int s, e, ep; +@ + check_type_string(&strng); + get_string_start_end(strng, start, end, &s, &e); + if (type_of(radix) != t_fixnum || + fix(radix) < 2 || fix(radix) > 36) + FEerror("~S is an illegal radix.", 1, radix); + setup_READtable(); + while (READtable->rt.rt_self[(unsigned char)strng->st.st_self[s]].rte_chattrib + == cat_whitespace && s < e) + s++; + if (s >= e) { + if (junk_allowed != Cnil) + @(return Cnil `make_fixnum(s)`) + else + goto CANNOT_PARSE; + } + { + char *q; + while (token->st.st_dimst.st_self,strng->st.st_self+s,e-s); + token->st.st_fillp=e-s; + null_terminate_token(); + x = parse_integer(token->st.st_self, &q, fix(radix)); + ep=q-token->st.st_self; + } + if (x == OBJNULL) { + if (junk_allowed != Cnil) + @(return Cnil `make_fixnum(ep+s)`) + else + goto CANNOT_PARSE; + } + if (junk_allowed != Cnil) + @(return x `make_fixnum(ep+s)`) + for (s += ep ; s < e; s++) + if (READtable->rt.rt_self[(unsigned char)strng->st.st_self[s]] + .rte_chattrib + != cat_whitespace) + goto CANNOT_PARSE; + @(return x `make_fixnum(e)`) + +CANNOT_PARSE: + FEerror("Cannot parse an integer in the string ~S.", 1, strng); +@) + +@(defun read_byte (binary_input_stream + &optional eof_errorp eof_value) + int c; +@ + check_type_stream(&binary_input_stream); + if (stream_at_end(binary_input_stream)) { + if (eof_errorp == Cnil) + @(return eof_value) + else + end_of_stream(binary_input_stream); + } + c = readc_stream(binary_input_stream); + @(return `make_fixnum(c)`) +@) + +object +read_byte1(strm,eof) +object strm,eof; +{ + if (strm == Cnil) + strm = symbol_value(sLAstandard_inputA); + else if (strm == Ct) + strm = symbol_value(sLAterminal_ioA); + if (stream_at_end(strm)) + return eof; + return make_fixnum(readc_stream(strm)); +} + +object +read_char1(strm,eof) +object strm,eof; +{ + if (strm == Cnil) + strm = symbol_value(sLAstandard_inputA); + else if (strm == Ct) + strm = symbol_value(sLAterminal_ioA); + if (stream_at_end(strm)) + return eof; + return code_char(readc_stream(strm)); +} + + @(defun copy_readtable (&optional (from `current_readtable()`) to) +@ + if (from == Cnil) { + from = standard_readtable; + if (to != Cnil) + check_type_readtable(&to); + to = copy_readtable(from, to); + to->rt.rt_self['#'].rte_dtab['!'] + = default_dispatch_macro; + /* We must forget #! macro. */ + @(return to) + } + check_type_readtable(&from); + if (to != Cnil) + check_type_readtable(&to); + @(return `copy_readtable(from, to)`) +@) + +LFD(Lreadtablep)() +{ + check_arg(1); + + if (type_of(vs_base[0]) == t_readtable) + vs_base[0] = Ct; + else + vs_base[0] = Cnil; +} + +@(defun set_syntax_from_char (tochr fromchr + &optional (tordtbl `current_readtable()`) + fromrdtbl) + int i; +@ + check_type_character(&tochr); + check_type_character(&fromchr); + check_type_readtable(&tordtbl); + {BEGIN_NO_INTERRUPT; + if (fromrdtbl == Cnil) + fromrdtbl = standard_readtable; + else + check_type_readtable(&fromrdtbl); + tordtbl->rt.rt_self[char_code(tochr)].rte_chattrib + = fromrdtbl->rt.rt_self[char_code(fromchr)].rte_chattrib; + tordtbl->rt.rt_self[char_code(tochr)].rte_macro + = fromrdtbl->rt.rt_self[char_code(fromchr)].rte_macro; + if ((tordtbl->rt.rt_self[char_code(tochr)].rte_dtab + = fromrdtbl->rt.rt_self[char_code(fromchr)].rte_dtab) + != NULL) { + tordtbl->rt.rt_self[char_code(tochr)].rte_dtab + = (object *) + alloc_contblock(RTABSIZE * sizeof(object)); + for (i = 0; i < RTABSIZE; i++) + tordtbl->rt.rt_self[char_code(tochr)] + .rte_dtab[i] + = fromrdtbl->rt.rt_self[char_code(fromchr)] + .rte_dtab[i]; + } + END_NO_INTERRUPT;} + @(return Ct) +@) + +@(defun set_macro_character (chr fnc + &optional ntp + (rdtbl `current_readtable()`)) + int c; +@ + check_type_character(&chr); + check_type_readtable(&rdtbl); + c = char_code(chr); + if (ntp != Cnil) + rdtbl->rt.rt_self[c].rte_chattrib + = cat_non_terminating; + else + rdtbl->rt.rt_self[c].rte_chattrib + = cat_terminating; + rdtbl->rt.rt_self[c].rte_macro = fnc; + @(return Ct) +@) + +@(defun get_macro_character (chr &optional (rdtbl `current_readtable()`)) + object m; +@ + check_type_character(&chr); + check_type_readtable(&rdtbl); + if ((m = rdtbl->rt.rt_self[char_code(chr)].rte_macro) + == OBJNULL) + @(return Cnil) + if (rdtbl->rt.rt_self[char_code(chr)].rte_chattrib + == cat_non_terminating) + @(return m Ct) + else + @(return m Cnil) +@) + +@(static defun make_dispatch_macro_character (chr + &optional ntp (rdtbl `current_readtable()`)) + int i; +@ + check_type_character(&chr); + check_type_readtable(&rdtbl); + {BEGIN_NO_INTERRUPT; + if (ntp != Cnil) + rdtbl->rt.rt_self[char_code(chr)].rte_chattrib + = cat_non_terminating; + else + rdtbl->rt.rt_self[char_code(chr)].rte_chattrib + = cat_terminating; + rdtbl->rt.rt_self[char_code(chr)].rte_dtab + = (object *) + alloc_contblock(RTABSIZE * sizeof(object)); + for (i = 0; i < RTABSIZE; i++) + rdtbl->rt.rt_self[char_code(chr)].rte_dtab[i] + = default_dispatch_macro; + rdtbl->rt.rt_self[char_code(chr)].rte_macro = dispatch_reader; + END_NO_INTERRUPT;} + @(return Ct) +@) + +@(static defun set_dispatch_macro_character (dspchr subchr fnc + &optional (rdtbl `current_readtable()`)) +@ + check_type_character(&dspchr); + check_type_character(&subchr); + check_type_readtable(&rdtbl); + if (rdtbl->rt.rt_self[char_code(dspchr)].rte_macro != dispatch_reader + || rdtbl->rt.rt_self[char_code(dspchr)].rte_dtab == NULL) + FEerror("~S is not a dispatch character.", 1, dspchr); + rdtbl->rt.rt_self[char_code(dspchr)] + .rte_dtab[char_code(subchr)] = fnc; + if ('a' <= char_code(subchr) && char_code(subchr) <= 'z') + rdtbl->rt.rt_self[char_code(dspchr)] + .rte_dtab[char_code(subchr) - ('a' - 'A')] = fnc; + + @(return Ct) +@) + +@(static defun get_dispatch_macro_character (dspchr subchr + &optional (rdtbl `current_readtable()`)) +@ + check_type_character(&dspchr); + check_type_character(&subchr); + check_type_readtable(&rdtbl); + if (rdtbl->rt.rt_self[char_code(dspchr)].rte_macro != dispatch_reader + || rdtbl->rt.rt_self[char_code(dspchr)].rte_dtab == NULL) + FEerror("~S is not a dispatch character.", 1, dspchr); + if (digitp(char_code(subchr),10) >= 0) @(return Cnil) + else { + object x=rdtbl->rt.rt_self[char_code(dspchr)].rte_dtab[char_code(subchr)]; + @(return `x==default_dispatch_macro ? Cnil : x`) + } +@) + +static object +string_to_object(x) +object x; +{ + object in; + vs_mark; + + in = make_string_input_stream(x, 0, x->st.st_fillp); + vs_push(in); + preserving_whitespace_flag = FALSE; + detect_eos_flag = FALSE; + x = read_object_non_recursive(in); + vs_reset; + return(x); +} + +LFD(siLstring_to_object)() +{ + check_arg(1); + + check_type_string(&vs_base[0]); + vs_base[0] = string_to_object(vs_base[0]); +} + + +static void +FFN(siLstandard_readtable)() +{ + check_arg(0); + + vs_push(standard_readtable); +} + +static void +extra_argument(c) +int c; +{ + FEerror("~S is an extra argument for the #~C readmacro.", + 2, vs_base[2], code_char(c)); +} + + +#define make_cf(f) make_cfun((f), Cnil, Cnil, NULL, 0) + +DEFVAR("*READ-DEFAULT-FLOAT-FORMAT*",sLAread_default_float_formatA, + LISP,sLsingle_float,""); +DEFVAR("*READ-BASE*",sLAread_baseA,LISP,make_fixnum(10),""); +DEFVAR("*READ-SUPPRESS*",sLAread_suppressA,LISP,Cnil,""); + + +void +gcl_init_read() +{ + struct rtent *rtab; + object *dtab; + int i; + + standard_readtable = alloc_object(t_readtable); + enter_mark_origin(&standard_readtable); + + standard_readtable->rt.rt_self + = rtab + = (struct rtent *) + alloc_contblock(RTABSIZE * sizeof(struct rtent)); + for (i = 0; i < RTABSIZE; i++) { + rtab[i].rte_chattrib = cat_constituent; + rtab[i].rte_macro = OBJNULL; + rtab[i].rte_dtab = NULL; + } + + dispatch_reader = make_cf(Ldispatch_reader); + enter_mark_origin(&dispatch_reader); + + rtab['\t'].rte_chattrib = cat_whitespace; + rtab['\n'].rte_chattrib = cat_whitespace; + rtab['\f'].rte_chattrib = cat_whitespace; + rtab['\r'].rte_chattrib = cat_whitespace; + rtab[' '].rte_chattrib = cat_whitespace; + rtab['"'].rte_chattrib = cat_terminating; + rtab['"'].rte_macro = make_cf(Ldouble_quote_reader); + rtab['#'].rte_chattrib = cat_non_terminating; + rtab['#'].rte_macro = dispatch_reader; + rtab['\''].rte_chattrib = cat_terminating; + rtab['\''].rte_macro = make_cf(Lsingle_quote_reader); + rtab['('].rte_chattrib = cat_terminating; + rtab['('].rte_macro = make_cf(Lleft_parenthesis_reader); + rtab[')'].rte_chattrib = cat_terminating; + rtab[')'].rte_macro = make_cf(Lright_parenthesis_reader); +/* + rtab[','].rte_chattrib = cat_terminating; + rtab[','].rte_macro = make_cf(Lcomma_reader); +*/ + rtab[';'].rte_chattrib = cat_terminating; + rtab[';'].rte_macro = make_cf(Lsemicolon_reader); + rtab['\\'].rte_chattrib = cat_single_escape; +/* + rtab['`'].rte_chattrib = cat_terminating; + rtab['`'].rte_macro = make_cf(Lbackquote_reader); +*/ + rtab['|'].rte_chattrib = cat_multiple_escape; +/* + rtab['|'].rte_macro = make_cf(Lvertical_bar_reader); +*/ + + default_dispatch_macro = make_cf(Ldefault_dispatch_macro); + + rtab['#'].rte_dtab + = dtab + = (object *)alloc_contblock(RTABSIZE * sizeof(object)); + for (i = 0; i < RTABSIZE; i++) + dtab[i] = default_dispatch_macro; + dtab['C'] = dtab['c'] = make_cf(Lsharp_C_reader); + dtab['\\'] = make_cf(Lsharp_backslash_reader); + dtab['\''] = make_cf(Lsharp_single_quote_reader); + dtab['('] = make_cf(Lsharp_left_parenthesis_reader); + dtab['*'] = make_cf(Lsharp_asterisk_reader); + dtab[':'] = make_cf(Lsharp_colon_reader); + dtab['.'] = make_cf(Lsharp_dot_reader); + dtab['!'] = make_cf(Lsharp_exclamation_reader); + /* Used for fasload only. */ + dtab[','] = make_cf(Lsharp_comma_reader); + dtab['B'] = dtab['b'] = make_cf(Lsharp_B_reader); + dtab['O'] = dtab['o'] = make_cf(Lsharp_O_reader); + dtab['X'] = dtab['x'] = make_cf(Lsharp_X_reader); + dtab['R'] = dtab['r'] = make_cf(Lsharp_R_reader); +/* + dtab['A'] = dtab['a'] = make_cf(Lsharp_A_reader); + dtab['S'] = dtab['s'] = make_cf(Lsharp_S_reader); +*/ + dtab['A'] = dtab['a'] = make_si_ordinary("SHARP-A-READER"); + dtab['S'] = dtab['s'] = make_si_ordinary("SHARP-S-READER"); + + dtab['='] = make_si_ordinary("SHARP-EQ-READER"); + dtab['#'] = make_si_ordinary("SHARP-SHARP-READER"); + dtab['+'] = make_cf(Lsharp_plus_reader); + dtab['-'] = make_cf(Lsharp_minus_reader); +/* + dtab['<'] = make_cf(Lsharp_less_than_reader); +*/ + dtab['|'] = make_cf(Lsharp_vertical_bar_reader); + dtab['"'] = make_cf(Lsharp_double_quote_reader); + dtab['p'] = make_cf(Lsharp_p_reader); + dtab['P'] = make_cf(Lsharp_p_reader); + /* This is specific to this implimentation */ + dtab['$'] = make_cf(Lsharp_dollar_reader); + /* This is specific to this implimentation */ +/* + dtab[' '] = dtab['\t'] = dtab['\n'] = dtab['\f'] + = make_cf(Lsharp_whitespace_reader); + dtab[')'] = make_cf(Lsharp_right_parenthesis_reader); +*/ + + gcl_init_backq(); + + Vreadtable + = make_special("*READTABLE*", + copy_readtable(standard_readtable, Cnil)); + Vreadtable->s.s_dbind->rt.rt_self['#'].rte_dtab['!'] + = default_dispatch_macro; + /* We must forget #! macro. */ + + + sKstart = make_keyword("START"); + sKend = make_keyword("END"); + sKradix = make_keyword("RADIX"); + sKjunk_allowed = make_keyword("JUNK-ALLOWED"); + + READtable = symbol_value(Vreadtable); + enter_mark_origin(&READtable); + READdefault_float_format = 'F'; + READbase = 10; + READsuppress = FALSE; + + sSAsharp_eq_contextA->s.s_dbind=Cnil; + + siSsharp_comma = make_si_ordinary("#,"); + enter_mark_origin(&siSsharp_comma); + + delimiting_char = OBJNULL; + enter_mark_origin(&delimiting_char); + + detect_eos_flag = FALSE; + in_list_flag = FALSE; + dot_flag = FALSE; + +} + +void +gcl_init_read_function() +{ + make_function("READ", Lread); + make_function("READ-PRESERVING-WHITESPACE", + Lread_preserving_whitespace); + make_function("READ-DELIMITED-LIST", Lread_delimited_list); + make_function("READ-LINE", Lread_line); + make_function("READ-CHAR", Lread_char); + make_function("UNREAD-CHAR", Lunread_char); + make_function("PEEK-CHAR", Lpeek_char); + make_function("LISTEN", Llisten); + make_function("READ-CHAR-NO-HANG", Lread_char_no_hang); + make_function("CLEAR-INPUT", Lclear_input); + + make_function("PARSE-INTEGER", Lparse_integer); + + make_function("READ-BYTE", Lread_byte); + + make_function("COPY-READTABLE", Lcopy_readtable); + make_function("READTABLEP", Lreadtablep); + make_function("SET-SYNTAX-FROM-CHAR", Lset_syntax_from_char); + make_function("SET-MACRO-CHARACTER", Lset_macro_character); + make_function("GET-MACRO-CHARACTER", Lget_macro_character); + make_function("MAKE-DISPATCH-MACRO-CHARACTER", + Lmake_dispatch_macro_character); + make_function("SET-DISPATCH-MACRO-CHARACTER", + Lset_dispatch_macro_character); + make_function("GET-DISPATCH-MACRO-CHARACTER", + Lget_dispatch_macro_character); + + make_si_function("SHARP-COMMA-READER-FOR-COMPILER", + siLsharp_comma_reader_for_compiler); + + make_si_function("STRING-TO-OBJECT", siLstring_to_object); + + make_si_function("STANDARD-READTABLE", siLstandard_readtable); +} + +object sSPinit; + +object +read_fasl_vector1(in) +object in; +{ + int dimcount, dim; + VOL object *vsp; + object vspo; + VOL object x; + long i; + bool e; + object old_READtable; + int old_READdefault_float_format; + int old_READbase; + int old_READsuppress; + volatile object old_READcontext; + int old_backq_level; + + /* to prevent longjmp clobber */ + i=(long)&vsp; + vsp=&vspo; + old_READtable = READtable; + old_READdefault_float_format = READdefault_float_format; + old_READbase = READbase; + old_READsuppress = READsuppress; + old_READcontext=sSAsharp_eq_contextA->s.s_dbind; + /* BUG FIX by Toshiba */ + vs_push(old_READtable); + old_backq_level = backq_level; + + setup_standard_READ(); + + frs_push(FRS_PROTECT, Cnil); + if (nlj_active) { + e = TRUE; + goto L; + } + + while (readc_stream(in) != '#') + ; + while (readc_stream(in) != '(') + ; + vsp = vs_top; + dimcount = 0; + for (;;) { + sSAsharp_eq_contextA->s.s_dbind=Cnil; + backq_level = 0; + delimiting_char = code_char(')'); + preserving_whitespace_flag = FALSE; + detect_eos_flag = FALSE; + x = read_object(in); + if (x == OBJNULL) + break; + vs_check_push(x); + if (sSAsharp_eq_contextA->s.s_dbind!=Cnil) + x = vs_head = patch_sharp(x); + dimcount++; + } + if(dimcount==1 && type_of(vs_head)==t_vector) + {/* new style where all read at once */ + x=vs_head; + goto DONE;} + /* old style separately sharped, and no %init */ + {BEGIN_NO_INTERRUPT; + x=alloc_simple_vector(dimcount,aet_object); + vs_push(x); + x->v.v_self + = (object *)alloc_relblock(dimcount * sizeof(object)); + END_NO_INTERRUPT;} + for (dim = 0; dim < dimcount; dim++) + {SGC_TOUCH(x); + x->cfd.cfd_self[dim] = vsp[dim];} + + + DONE: + e = FALSE; + +L: + frs_pop(); + + READtable = old_READtable; + READdefault_float_format = old_READdefault_float_format; + READbase = old_READbase; + READsuppress = old_READsuppress; + sSAsharp_eq_contextA->s.s_dbind=old_READcontext; + backq_level = old_backq_level; + if (e) { + nlj_active = FALSE; + unwind(nlj_fr, nlj_tag); + } + vs_top = (object *)vsp; + return(x); +} diff --git a/o/readme b/o/readme new file mode 100755 index 0000000..aeadd9f --- /dev/null +++ b/o/readme @@ -0,0 +1,16 @@ +Current scheme: + +All functions which used to start with siL or L have been replaced +by ones which pass arguments on the C stack. + +The special forms + +(eg Fprogn, Fsetq are still the same as before). + +Functions in the Lisp (resp Si package) are named +fL... (respectively fS...) and they all pass arguments on the C stack and return +multiple values, and have DEFUN's which specify their argd. + +eval still passes on the value stack +All functions beginning with I pass on C stack. +` diff --git a/o/reference.c b/o/reference.c new file mode 100755 index 0000000..29c1ba4 --- /dev/null +++ b/o/reference.c @@ -0,0 +1,200 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +/* + + reference.c + + Reference in Constants and Variables +*/ + +#include "include.h" + +LFD(Lfboundp)(void) +{ + object sym; + + check_arg(1); + sym = vs_base[0]; + if (type_of(sym) != t_symbol) + not_a_symbol(sym); + if (sym->s.s_sfdef != NOT_SPECIAL) + vs_base[0] = Ct; + else if (sym->s.s_gfdef == OBJNULL) + vs_base[0]= Cnil; + else + vs_base[0]= Ct; +} + +object +symbol_function(object sym) +{ +/* + if (type_of(sym) != t_symbol) + not_a_symbol(sym); +*/ + if (sym->s.s_sfdef != NOT_SPECIAL || sym->s.s_mflag) + FEinvalid_function(sym); + if (sym->s.s_gfdef == OBJNULL) + FEundefined_function(sym); + return(sym->s.s_gfdef); +} + +/* + Symbol-function returns + function-closure for function + (macro . function-closure) for macros + (special . address) for special forms. +*/ +LFD(Lsymbol_function)(void) +{ + object sym; + + check_arg(1); + sym = vs_base[0]; + if (type_of(sym) != t_symbol) + not_a_symbol(sym); + if (sym->s.s_sfdef != NOT_SPECIAL) { + vs_push(make_fixnum((long)(sym->s.s_sfdef))); + vs_base[0] = sLspecial; + stack_cons(); + return; + } + if (sym->s.s_gfdef==OBJNULL) + FEundefined_function(sym); + if (sym->s.s_mflag) { + vs_push(sym->s.s_gfdef); + vs_base[0] = sLmacro; + stack_cons(); + return; + } + vs_base[0] = sym->s.s_gfdef; +} + +static void +FFN(Fquote)(object form) +{ + + if (endp(form)) + FEtoo_few_argumentsF(form); + if (!endp(MMcdr(form))) + FEtoo_many_argumentsF(form); + vs_base = vs_top; + vs_push(MMcar(form)); +} + +static void +FFN(Ffunction)(object form) +{ + + object fun; + object fd; + if (endp(form)) + FEtoo_few_argumentsF(form); + if (!endp(MMcdr(form))) + FEtoo_many_argumentsF(form); + fun = MMcar(form); + if (type_of(fun) == t_symbol) { + fd = lex_fd_sch(fun); + if (MMnull(fd) || MMcadr(fd) != sLfunction) + if (fun->s.s_gfdef == OBJNULL || fun->s.s_mflag) + FEundefined_function(fun); + else { + vs_base = vs_top; + vs_push(fun->s.s_gfdef); + } + else { + vs_base = vs_top; + vs_push(MMcaddr(fd)); + } + } else if (type_of(fun) == t_cons && MMcar(fun) == sLlambda) { + vs_base = vs_top; + vs_push(MMcdr(fun)); + vs_base[0] = MMcons(lex_env[2], vs_base[0]); + vs_base[0] = MMcons(lex_env[1], vs_base[0]); + vs_base[0] = MMcons(lex_env[0], vs_base[0]); + vs_base[0] = MMcons(sLlambda_closure, vs_base[0]); + } else + FEinvalid_function(fun); +} + +LFD(Lsymbol_value)(void) +{ + object sym; + check_arg(1); + sym = vs_base[0]; + if (type_of(sym) != t_symbol) + not_a_symbol(sym); + if (sym->s.s_dbind == OBJNULL) + FEunbound_variable(sym); + else + vs_base[0] = sym->s.s_dbind; +} + +LFD(Lboundp)(void) +{ + object sym; + check_arg(1); + sym=vs_base[0]; + if (type_of(sym) != t_symbol) + not_a_symbol(sym); + if (sym->s.s_dbind == OBJNULL) + vs_base[0] = Cnil; + else + vs_base[0] = Ct; +} + +LFD(Lmacro_function)(void) +{ + check_arg(1); + if (type_of(vs_base[0]) != t_symbol) + not_a_symbol(vs_base[0]); + if (vs_base[0]->s.s_gfdef != OBJNULL && vs_base[0]->s.s_mflag) + vs_base[0] = vs_base[0]->s.s_gfdef; + else + vs_base[0] = Cnil; +} + +LFD(Lspecial_form_p)(void) +{ + check_arg(1); + if (type_of(vs_base[0]) != t_symbol) + not_a_symbol(vs_base[0]); + if (vs_base[0]->s.s_sfdef != NOT_SPECIAL) + vs_base[0] = Ct; + else + vs_base[0] = Cnil; +} + +void +gcl_init_reference(void) +{ + make_function("SYMBOL-FUNCTION", Lsymbol_function); + make_function("FBOUNDP", Lfboundp); + sLquote=make_special_form("QUOTE", Fquote); + sLfunction = make_special_form("FUNCTION", Ffunction); + make_function("SYMBOL-VALUE", Lsymbol_value); + make_function("BOUNDP", Lboundp); + make_function("MACRO-FUNCTION", Lmacro_function); + make_function("SPECIAL-FORM-P", Lspecial_form_p); + make_function("SPECIAL-OPERATOR-P", Lspecial_form_p); +} + diff --git a/o/regexp.c b/o/regexp.c new file mode 100755 index 0000000..fd27845 --- /dev/null +++ b/o/regexp.c @@ -0,0 +1,1581 @@ +/* original regexp.c file written by Henry Spencer. + many changes made [see below] made by W. Schelter. + These changes Copyright (c) 1994 W. Schelter + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + + Various enhancements made by William Schelter when converting + for use by GCL: + 1) allow case_fold_search: If this variable is not nil, + then 'a' and 'A' are considered equivalent. + 2) Various speed ups, useful when searching a long string + [eg body of a file etc.] + Timings searching a 47k byte file for patterns + + The following table shows how many times longer it took the original + implementation, to search for a given pattern. Comparison is also + made with the re-search-forward function of gnu emacs. For example + in searching for the pattern 'not_there' the search took 20 times + longer in the original implementation, and about the same time in gnu + emacs. + + Pattern: current original gnu emacs + not_there 1 20 1 + not_there|really_not 1 200 30 + not_there|really_not|how is[a-z] 1 115 15 + not_there|really_not|how is[a-z]y 1 30 4 + [a-u]bcdex 1 194 60 + a.bcde 1 10 7.5 + + of a character. + 3). Allow string length to be specified, and string not null + terminated. If length specified as zero, string assumed null + terminated. If string NOT null terminated, then string area + must be writable (commonly strings in non writable area are + already null terminated..). + + To do: 1)Still lots of improvement possible: eg the pattern + x[^x]*nice_pattern, should be searched for by doing search + for nice_pattern, and then backing up. To do easily requires + backward search. eg: "FRONT TAIL" search for TAIL and then + search back for "FRONT $" + 2) do backward search. + + +*/ +#include +#include "string.h" +#include "regexp.h" + +static int +min_initial_branch_length(regexp *, unsigned char *, int); + + +/* + * The "internal use only" fields in regexp.h are present to pass info from + * compile to execute that permits the execute phase to run lots faster on + * simple cases. They are: + * + * regstart char that must begin a match; '\0' if none obvious + * reganch is the match anchored (at beginning-of-line only)? + * regmust string (pointer into program) that match must include, or NULL + * regmlen length of regmust string + * + * Regstart and reganch permit very fast decisions on suitable starting points + * for a match, cutting down the work a lot. Regmust permits fast rejection + * of lines that cannot possibly match. The regmust tests are costly enough + * that regcomp() supplies a regmust only if the r.e. contains something + * potentially expensive (at present, the only such thing detected is * or + + * at the start of the r.e., which can involve a lot of backup). Regmlen is + * supplied because the test in regexec() needs it and regcomp() is + * computing it anyway. + */ + +/* + * Structure for regexp "program". This is essentially a linear encoding + * of a nondeterministic finite-state machine (aka syntax charts or + * "railroad normal form" in parsing technology). Each node is an opcode + * plus a "next" pointer, possibly plus an operand. "Next" pointers of + * all nodes except BRANCH implement concatenation; a "next" pointer with + * a BRANCH on both ends of it is connecting two alternatives. (Here we + * have one of the subtle syntax dependencies: an individual BRANCH (as + * opposed to a collection of them) is never concatenated with anything + * because of operator precedence.) The operand of some types of node is + * a literal string; for others, it is a node leading into a sub-FSM. In + * particular, the operand of a BRANCH node is the first node of the branch. + * (NB this is *not* a tree structure: the tail of the branch connects + * to the thing following the set of BRANCHes.) The opcodes are: + */ + +/* definition number opnd? meaning */ +#define END 0 /* no End of program. */ +#define BOL 1 /* no Match "" at beginning of line. */ +#define EOL 2 /* no Match "" at end of line. */ +#define ANY 3 /* no Match any one character. */ +#define ANYOF 4 /* str Match any character in this string. */ +#define ANYBUT 5 /* str Match any character not in this string. */ +#define BRANCH 6 /* node Match this alternative, or the next... */ +#define BACK 7 /* no Match "", "next" ptr points backward. */ +#define EXACTLY 8 /* str Match this string. */ +#define NOTHING 9 /* no Match empty string. */ +#define STAR 10 /* node Match this (simple) thing 0 or more times. */ +#define PLUS 11 /* node Match this (simple) thing 1 or more times. */ +#define OPEN 20 /* no Mark this point in input as start of #n. */ + /* OPEN+1 is number 1, etc. */ +#define CLOSE 30 /* no Analogous to OPEN. */ + +/* + * Opcode notes: + * + * BRANCH The set of branches constituting a single choice are hooked + * together with their "next" pointers, since precedence prevents + * anything being concatenated to any individual branch. The + * "next" pointer of the last BRANCH in a choice points to the + * thing following the whole choice. This is also where the + * final "next" pointer of each individual branch points; each + * branch starts with the operand node of a BRANCH node. + * + * BACK Normal "next" pointers all implicitly point forward; BACK + * exists to make loop structures possible. + * + * STAR,PLUS '?', and complex '*' and '+', are implemented as circular + * BRANCH structures using BACK. Simple cases (one character + * per match) are implemented with STAR and PLUS for speed + * and to minimize recursive plunges. + * + * OPEN,CLOSE ...are numbered at compile time. + */ + +/* + * A node is one char of opcode followed by two chars of "next" pointer. + * "Next" pointers are stored as two 8-bit pieces, high order first. The + * value is a positive offset from the opcode of the node containing it. + * An operand, if any, simply follows the node. (Note that much of the + * code generation knows about this implicit relationship.) + * + * Using two bytes for the "next" pointer is vast overkill for most things, + * but allows patterns to get big without disasters. + */ +#define OP(p) (*(p)) +#define NEXT(p) (((*((p)+1)&0377)<<8) + (*((p)+2)&0377)) +#define OPERAND(p) ((p) + 3) + +/* + * See regmagic.h for one further detail of program structure. + */ + + +/* + * Utility definitions. + */ +#ifndef CHARBITS +#define UCHARAT(p) ((int)*(unsigned char *)(p)) +#else +#define UCHARAT(p) ((int)*(p)&CHARBITS) +#endif + +#define FAIL(m) { regerror(m); return(NULL); } +#define ISMULT(c) ((c) == '*' || (c) == '+' || (c) == '?') +#undef META +#define META "^$.[()|?+*\\" + +/* + * Flags to be passed up and down. + */ +#define HASWIDTH 01 /* Known never to match null string. */ +#define SIMPLE 02 /* Simple enough to be STAR/PLUS operand. */ +#define SPSTART 04 /* Starts with * or +. */ +#define WORST 0 /* Worst case. */ + +/* + * Global work variables for regcomp(). + */ +static char *regparse; /* Input-scan pointer. */ +static int regnpar; /* () count. */ +static char regdummy; +static char *regcode; /* Code-emit pointer; ®dummy = don't. */ +static long regsize; /* Code size. */ + +/* + * The first byte of the regexp internal "program" is actually this magic + * number; the start node begins in the second byte. + */ +#define MAGIC 0234 + +/* + * Forward declarations for regcomp()'s friends. + */ +#ifndef STATIC +#define STATIC static +#endif +STATIC char *reg(int paren, int *flagp); +STATIC char *regbranch(int *flagp); +STATIC char *regpiece(int *flagp); +STATIC char *regatom(int *flagp); +STATIC char *regnode(char op); +STATIC char *regnext(register char *p); +STATIC void regc(char b); +STATIC void reginsert(char op, char *opnd); +STATIC void regtail(char *p, char *val); +STATIC void regoptail(char *p, char *val); + +int case_fold_search = 0; +/* + - regcomp - compile a regular expression into internal code + * + * We can't allocate space until we know how big the compiled form will be, + * but we can't compile it (and thus know how big it is) until we've got a + * place to put the code. So we cheat: we compile it twice, once with code + * generation turned off and size counting turned on, and once "for real". + * This also means that we don't allocate space until we are sure that the + * thing really will compile successfully, and we never have to move the + * code and thus invalidate pointers into it. (Note that it has to be in + * one piece because free() must be able to free it all.) + * + * Beware that the optimization-preparation code in here knows about some + * of the structure of the compiled regexp. + */ +static regexp * +regcomp(char *exp,int *sz) +{ + register regexp *r; + register char *scan; + register char *longest; + register int len; + int flags; + + if (exp == NULL) + FAIL("NULL argument"); + + /* First pass: determine size, legality. */ + regparse = exp; + regnpar = 1; + regsize = 0L; + regcode = ®dummy; + regc(MAGIC); + if (reg(0, &flags) == NULL) + return(NULL); + + /* Small enough for pointer-storage convention? */ + if (regsize >= 32767L) /* Probably could be 65535L. */ + FAIL("regexp too big"); + + /* Allocate space. */ + *sz=sizeof(regexp) + (unsigned)regsize; + r = (regexp *)alloc_relblock(*sz); + if (r == NULL) + FAIL("out of space"); + + /* Second pass: emit code. */ + regparse = exp; + regnpar = 1; + regcode = r->program; + regc(MAGIC); + if (reg(0, &flags) == NULL) + return(NULL); + + /* Dig out information for optimizations. */ + r->regstart = '\0'; /* Worst-case defaults. */ + r->reganch = 0; + r->regmust = NULL; + r->regmlen = 0; + r->regmaybe_boyer =0; + scan = r->program+1; /* First BRANCH. */ + if (0&& OP(regnext(scan)) == END) { /* Only one top-level choice. */ + scan = OPERAND(scan); + + /* Starting-point info. */ + if (OP(scan) == EXACTLY) + {r->regstart = *OPERAND(scan); + r->regmaybe_boyer = strlen(OPERAND(scan));} + else if (OP(scan) == BOL) + r->reganch++; + + + /* + * If there's something expensive in the r.e., find the + * longest literal string that must appear and make it the + * regmust. Resolve ties in favor of later strings, since + * the regstart check works with the beginning of the r.e. + * and avoiding duplication strengthens checking. Not a + * strong reason, but sufficient in the absence of others. + */ + if (flags&SPSTART) { + longest = NULL; + len = 0; + for (; scan != NULL; scan = regnext(scan)) + if (OP(scan) == EXACTLY && ((int) strlen(OPERAND(scan))) >= len) { + longest = OPERAND(scan); + len = strlen(OPERAND(scan)); + } + r->regmust = longest; + r->regmlen = len; + } + } + else { r->regmaybe_boyer = min_initial_branch_length(r,0,0);} + + + return(r); +} + +/* + - reg - regular expression, i.e. main body or parenthesized thing + * + * Caller must absorb opening parenthesis. + * + * Combining parenthesis handling with the base level of regular expression + * is a trifle forced, but the need to tie the tails of the branches to what + * follows makes it hard to avoid. + */ +static char * +reg(int paren, int *flagp) + /* Parenthesized? */ + +{ + register char *ret; + register char *br; + register char *ender; + register int parno = 0; + int flags; + + *flagp = HASWIDTH; /* Tentatively. */ + + /* Make an OPEN node, if parenthesized. */ + if (paren) { + if (regnpar >= NSUBEXP) + FAIL("too many ()"); + parno = regnpar; + regnpar++; + ret = regnode(OPEN+parno); + } else + ret = NULL; + + /* Pick up the branches, linking them together. */ + br = regbranch(&flags); + if (br == NULL) + return(NULL); + if (ret != NULL) + regtail(ret, br); /* OPEN -> first. */ + else + ret = br; + if (!(flags&HASWIDTH)) + *flagp &= ~HASWIDTH; + *flagp |= flags&SPSTART; + while (*regparse == '|') { + regparse++; + br = regbranch(&flags); + if (br == NULL) + return(NULL); + regtail(ret, br); /* BRANCH -> BRANCH. */ + if (!(flags&HASWIDTH)) + *flagp &= ~HASWIDTH; + *flagp |= flags&SPSTART; + } + + /* Make a closing node, and hook it on the end. */ + ender = regnode((paren) ? CLOSE+parno : END); + regtail(ret, ender); + + /* Hook the tails of the branches to the closing node. */ + for (br = ret; br != NULL; br = regnext(br)) + regoptail(br, ender); + + /* Check for proper termination. */ + if (paren && *regparse++ != ')') { + FAIL("unmatched ()"); + } else if (!paren && *regparse != '\0') { + if (*regparse == ')') { + FAIL("unmatched ()"); + } else + FAIL("junk on end"); /* "Can't happen". */ + /* NOTREACHED */ + } + + return(ret); +} + +/* + - regbranch - one alternative of an | operator + * + * Implements the concatenation operator. + */ +static char * +regbranch(int *flagp) +{ + register char *ret; + register char *chain; + register char *latest; + int flags; + + *flagp = WORST; /* Tentatively. */ + + ret = regnode(BRANCH); + chain = NULL; + while (*regparse != '\0' && *regparse != '|' && *regparse != ')') { + latest = regpiece(&flags); + if (latest == NULL) + return(NULL); + *flagp |= flags&HASWIDTH; + if (chain == NULL) /* First piece. */ + *flagp |= flags&SPSTART; + else + regtail(chain, latest); + chain = latest; + } + if (chain == NULL) /* Loop ran zero times. */ + (void) regnode(NOTHING); + + return(ret); +} + +/* + - regpiece - something followed by possible [*+?] + * + * Note that the branching code sequences used for ? and the general cases + * of * and + are somewhat optimized: they use the same NOTHING node as + * both the endmarker for their branch list and the body of the last branch. + * It might seem that this node could be dispensed with entirely, but the + * endmarker role is not redundant. + */ +static char * +regpiece(int *flagp) +{ + register char *ret; + register char op; + register char *next; + int flags; + + ret = regatom(&flags); + if (ret == NULL) + return(NULL); + + op = *regparse; + if (!ISMULT(op)) { + *flagp = flags; + return(ret); + } + + if (!(flags&HASWIDTH) && op != '?') + FAIL("*+ operand could be empty"); + *flagp = (op != '+') ? (WORST|SPSTART) : (WORST|HASWIDTH); + + if (op == '*' && (flags&SIMPLE)) + reginsert(STAR, ret); + else if (op == '*') { + /* Emit x* as (x&|), where & means "self". */ + reginsert(BRANCH, ret); /* Either x */ + regoptail(ret, regnode(BACK)); /* and loop */ + regoptail(ret, ret); /* back */ + regtail(ret, regnode(BRANCH)); /* or */ + regtail(ret, regnode(NOTHING)); /* null. */ + } else if (op == '+' && (flags&SIMPLE)) + reginsert(PLUS, ret); + else if (op == '+') { + /* Emit x+ as x(&|), where & means "self". */ + next = regnode(BRANCH); /* Either */ + regtail(ret, next); + regtail(regnode(BACK), ret); /* loop back */ + regtail(next, regnode(BRANCH)); /* or */ + regtail(ret, regnode(NOTHING)); /* null. */ + } else if (op == '?') { + /* Emit x? as (x|) */ + reginsert(BRANCH, ret); /* Either x */ + regtail(ret, regnode(BRANCH)); /* or */ + next = regnode(NOTHING); /* null. */ + regtail(ret, next); + regoptail(ret, next); + } + regparse++; + if (ISMULT(*regparse)) + FAIL("nested *?+"); + + return(ret); +} + +/* + - regatom - the lowest level + * + * Optimization: gobbles an entire sequence of ordinary characters so that + * it can turn them into a single node, which is smaller to store and + * faster to run. Backslashed characters are exceptions, each becoming a + * separate node; the code is simpler that way and it's not worth fixing. + */ +static char * +regatom(int *flagp) +{ + register char *ret; + int flags; + + *flagp = WORST; /* Tentatively. */ + + switch (*regparse++) { + case '^': + ret = regnode(BOL); + break; + case '$': + ret = regnode(EOL); + break; + case '.': + ret = regnode(ANY); + *flagp |= HASWIDTH|SIMPLE; + break; + case '[': {char buf[1000]; + char result[256]; + char *regcp=buf; + int matches = 1; +#define REGC(x) (*regcp++ = (x)) + { + register int clss; + register int classend; + ret = regnode(ANYOF); + + if (*regparse == '^') { /* Complement of range. */ + matches = 0; + regparse++;} + if (*regparse == ']' || *regparse == '-') + REGC(*regparse++); + while (*regparse != '\0' && *regparse != ']') { + if (*regparse == '-') { + regparse++; + if (*regparse == ']' || *regparse == '\0') + REGC('-'); + else { + clss = UCHARAT(regparse-2)+1; + classend = UCHARAT(regparse); + if (clss > classend+1) + FAIL("invalid [] range"); + for (; clss <= classend; clss++) + REGC(clss); + regparse++; + } + } else + REGC(*regparse++); + } + REGC('\0'); + if (*regparse != ']') + FAIL("unmatched []"); + regparse++; + *flagp |= HASWIDTH|SIMPLE; + } + if (regcp - buf > sizeof(buf)) + { fprintf(stderr,"wow that is badly defined regexp.."); + exit(1);} + regcp --; + { char *p=buf; + + /* set default vals */ + p = result; + while (p < &result[sizeof(result)]) + *p++ = (!matches ); + + p = buf; + while (p < regcp) + { result[*(unsigned char *)p] = matches; + if (case_fold_search) + {result[tolower(*p)] = matches; + result[toupper(*p)] = matches; p++;} + else + result[*(unsigned char *)p++] = matches; + + } + p = result; + while (p < &result[sizeof(result)]) + { regc(*p++);}} + break; + } + case '(': + ret = reg(1, &flags); + if (ret == NULL) + return(NULL); + *flagp |= flags&(HASWIDTH|SPSTART); + break; + case '\0': + case '|': + case ')': + FAIL("internal urp"); /* Supposed to be caught earlier. */ + /* NOTREACHED */ + break; + case '?': + case '+': + case '*': + FAIL("?+* follows nothing"); + /* NOTREACHED */ + break; + case '\\': + if (*regparse == '\0') + FAIL("trailing \\"); + ret = regnode(EXACTLY); + regc(*regparse++); + regc('\0'); + *flagp |= HASWIDTH|SIMPLE; + break; + default: { + register int len; + register char ender; + + regparse--; + len = strcspn(regparse, META); + if (len <= 0) + FAIL("internal disaster"); + ender = *(regparse+len); + if (len > 1 && ISMULT(ender)) + len--; /* Back off clear of ?+* operand. */ + *flagp |= HASWIDTH; + if (len == 1) + *flagp |= SIMPLE; + ret = regnode(EXACTLY); + while (len > 0) { + regc(*regparse++); + len--; + } + regc('\0'); + } + break; + } + + return(ret); +} + +/* + - regnode - emit a node + */ +static char * /* Location. */ +regnode(char op) +{ + register char *ret; + register char *ptr; + + ret = regcode; + if (ret == ®dummy) { + regsize += 3; + return(ret); + } + + ptr = ret; + *ptr++ = op; + *ptr++ = '\0'; /* Null "next" pointer. */ + *ptr++ = '\0'; + regcode = ptr; + + return(ret); +} + +/* + - regc - emit (if appropriate) a byte of code + */ +static void +regc(char b) +{ + if (regcode != ®dummy) + *regcode++ = b; + else + regsize++; +} + +/* + - reginsert - insert an operator in front of already-emitted operand + * + * Means relocating the operand. + */ +static void +reginsert(char op, char *opnd) +{ + register char *src; + register char *dst; + register char *place; + + if (regcode == ®dummy) { + regsize += 3; + return; + } + + src = regcode; + regcode += 3; + dst = regcode; + while (src > opnd) + *--dst = *--src; + + place = opnd; /* Op node, where operand used to be. */ + *place++ = op; + *place++ = '\0'; + *place++ = '\0'; +} + +/* + - regtail - set the next-pointer at the end of a node chain + */ +static void +regtail(char *p, char *val) +{ + register char *scan; + register char *temp; + register int offset; + + if (p == ®dummy) + return; + + /* Find last node. */ + scan = p; + for (;;) { + temp = regnext(scan); + if (temp == NULL) + break; + scan = temp; + } + + if (OP(scan) == BACK) + offset = scan - val; + else + offset = val - scan; + *(scan+1) = (offset>>8)&0377; + *(scan+2) = offset&0377; +} + +/* + - regoptail - regtail on operand of first argument; nop if operandless + */ +static void +regoptail(char *p, char *val) +{ + /* "Operandless" and "op != BRANCH" are synonymous in practice. */ + if (p == NULL || p == ®dummy || OP(p) != BRANCH) + return; + regtail(OPERAND(p), val); +} + +/* + * regexec and friends + */ + +/* + * Global work variables for regexec(). + */ +static char *reginput; /* String-input pointer. */ +static char *regbol; /* Beginning of input, for ^ check. */ +static char **regstartp; /* Pointer to startp array. */ +static char **regendp; /* Ditto for endp. */ + +/* + * Forwards. + */ +STATIC int regtry(regexp *prog, char *string); +STATIC int regmatch(char *prog); +STATIC int regrepeat(char *p); + +#ifdef DEBUG +int regnarrate = 0; +void regdump(); +STATIC char *regprop(); +#endif + +/* + - regexec - match a regexp against a string + PROG is the compiled regexp and STRING is the string one is searching in + and START is a pointer relative to STRING, to tell if a substring of the + original STRING is being passed. LENGTH can be 0 or the strlen(STRING). + If it is not 0 and is large, then a fast checking will be enabled. + + */ +static int +regexec(register regexp *prog, register char *string, char *start, int length) +{ + register char *s; + char saved,*savedp=NULL; + int value; + + /* Be paranoid... */ + if (prog == NULL || string == NULL) { + regerror("NULL parameter"); + return(0); + } + + /* Check validity of program. */ + if (UCHARAT(prog->program) != MAGIC) { + regerror("corrupted program"); + return(0); + } + + /* If there is a "must appear" string, look for it. */ + /* to do:fix this for case_fold_search, and also to detect + x[^x]*MUST pattern, searching for MUST, and then + backing up to the 'x'. The regmust thing is bad in + case of a long string. */ + if (0 && prog->regmust != NULL) { + s = string; + while ((s = strchr(s, prog->regmust[0])) != NULL) { + if (strncmp(s, prog->regmust, prog->regmlen) == 0) + break; /* Found it. */ + s++; + } + if (s == NULL) /* Not present. */ + return(0); + } + + /* null terminate string */ + if (length) + { savedp = &string[length]; + saved = *savedp; + if (saved) *savedp=0; + } + else saved=0; +#define RETURN_VAL(i) do {value=i; goto DO_RETURN;}while(0) + + /* Mark beginning of line for ^ . */ + regbol = start; + + /* Simplest case: anchored match need be tried only once. */ + if (prog->reganch) + RETURN_VAL(regtry(prog, string)); + + /* Messy cases: unanchored match. */ + s = string; + /* only do if long enough to warrant compile time + really length/prog->regmaybe_boyer > 1000 is + probably better (and >=2 !) + */ + if (length > 2 && prog->regmaybe_boyer>= 1) + { unsigned char buf[256]; + /* int advance= reg_compboyer(prog,buf); */ + int advance=prog->regmaybe_boyer; + + + + int amt; + unsigned char *s = (unsigned char *)string+ advance -1; + min_initial_branch_length(prog, buf,advance); + switch(advance) { + case 1: + while (1) + { if (buf[*s]==0) + { if (*s == 0) RETURN_VAL(0); + else + if (regtry(prog,(char *)s-(1-1))) RETURN_VAL(1);} + s++; } + RETURN_VAL(0); + + case 2: + while (length > 0) + { + amt = (buf[s[0]]); + if (amt == 0) + { + amt = buf[s[-1]]-1; + if (amt <=0) { + if (regtry(prog,(char *)s-(advance-1))) + RETURN_VAL(1); + else + amt =1; + } + } + s += amt; length -= amt; + } + RETURN_VAL(0); + case 3: + while (length > 0) + { amt = (buf[s[0]]); + if (amt == 0) + {amt = buf[s[-1]]-1; + if (amt <=0) + {amt = buf[s[-2]]-2; + if (amt <=0) + {if (regtry(prog,(char *)s-(advance-1))) RETURN_VAL(1); + else amt =1;}}} + s += amt; length -= amt;} + case 4: + while (length > 0) + { amt = (buf[s[0]]); + if (amt == 0) + {amt = buf[s[-1]]-1; + if (amt <=0) + {amt = buf[s[-2]]-2; + if (amt <=0) + {amt = buf[s[-3]]-3; + if (amt <=0) + {if (regtry(prog,(char *)s-(advance-1))) RETURN_VAL(1); + else amt =1;}}}} + s += amt; length -= amt;} + + default: + while (length > 0) + { amt = (buf[s[0]]); + if (amt == 0) + {amt = buf[s[-1]]-1; + if (amt <=0) + {amt = buf[s[-2]]-2; + if (amt <=0) + {amt = buf[s[-3]]-3; + if (amt <=0) + {amt = buf[s[-4]]-4; + if (amt <=0) + {if (regtry(prog,(char *)s-(advance-1))) RETURN_VAL(1); + else amt =1;}}}}} + s += amt; length -= amt;} + } + RETURN_VAL(0); + } + else + if (prog->regstart != '\0') + /* We know what char it must start with. */ + { if (case_fold_search) + {char ch = tolower(prog->regstart); + while (*s) + { if (tolower(*s)==ch) + {if (regtry(prog, s)) + RETURN_VAL(1);} + s++;}} + else + while ((s = strchr(s, prog->regstart)) != NULL) { + if (regtry(prog, s)) + RETURN_VAL(1); + s++; + } + } + else + /* We don't -- general case. */ + do { + if (regtry(prog, s)) + RETURN_VAL(1); + } while (*s++ != '\0'); + + /* Failure. */ + RETURN_VAL(0); + DO_RETURN: + if(saved) *savedp=saved; + return value; + +} + +#ifdef OLD_VERSION +reg_compboyer(r,buf) + regexp *r; + char *buf; +{ + char *scan; + scan = r->program+1; /* First BRANCH. */ + if (OP(regnext(scan)) == END) {/* Only one top-level choice. */ + scan = OPERAND(scan); + /* Starting-point info. */ +#define MIN(n,m) (n > m ? m : n) + if (OP(scan) == EXACTLY) + { char *op = OPERAND(scan); + char *p = buf; + int advance = strlen(op); + int i = 256; + if (advance > 255) advance = 255; + if (advance < 1) regerror("Impossible"); + while (--i >= 0) *p++ = advance; + i = advance; + p = op; + while (--i >= 0) + { if (case_fold_search) + { buf[tolower(*p)] = i; + buf[toupper(*p)] = i; + } + else buf[(*p)] = i; + p++; + + } + buf[0]=0; + return advance; + }} + regerror("Should be impossible"); + return 1; +} +#endif + +/* + - regtry - try match at specific point + */ +static int /* 0 failure, 1 success */ +regtry(regexp *prog, char *string) +{ + register int i; + register char **sp; + register char **ep; + + reginput = string; + regstartp = prog->startp; + regendp = prog->endp; + + sp = prog->startp; + ep = prog->endp; + for (i = NSUBEXP; i > 0; i--) { + *sp++ = NULL; + *ep++ = NULL; + } + if (regmatch(prog->program + 1)) { + prog->startp[0] = string; + prog->endp[0] = reginput; + return(1); + } else + return(0); +} + +/* + - regmatch - main matching routine + * + * Conceptually the strategy is simple: check to see whether the current + * node matches, call self recursively to see whether the rest matches, + * and then act accordingly. In practice we make some effort to avoid + * recursion, in particular by going through "ordinary" nodes (that don't + * need to know whether the rest of the match failed) by a loop instead of + * by recursion. + */ +static int /* 0 failure, 1 success */ +regmatch(char *prog) +{ + register char *scan; /* Current node. */ + char *next; /* Next node. */ + + scan = prog; +#ifdef DEBUG + if (scan != NULL && regnarrate) + fprintf(stderr, "%s(\n", regprop(scan)); +#endif + while (scan != NULL) { +#ifdef DEBUG + if (regnarrate) + fprintf(stderr, "%s...\n", regprop(scan)); +#endif + next = regnext(scan); + + switch (OP(scan)) { + case BOL: + if (reginput != regbol) + return(0); + break; + case EOL: + if (*reginput != '\0') + return(0); + break; + case ANY: + if (*reginput == '\0') + return(0); + reginput++; + break; + case EXACTLY: { + register char *opnd; + char * ch = reginput; + + opnd = OPERAND(scan); + if (case_fold_search) + while (*opnd ) + { if (tolower(*opnd) != tolower(*ch)) + return 0; + else { ch++; opnd++;}} + else + while (*opnd ) + { if (*opnd != *ch) + return 0; + else { ch++; opnd++;}} + /* a match */ + reginput += (opnd - OPERAND(scan)); + } + break; + case ANYOF: + if (*reginput == '\0' || + OPERAND(scan)[*(unsigned char *)reginput] == 0) + return(0); + reginput++; + break; + case ANYBUT: + if (*reginput == '\0' || + OPERAND(scan)[*(unsigned char *)reginput] != 0) + return(0); + reginput++; + break; + case NOTHING: + break; + case BACK: + break; + case OPEN+1: + case OPEN+2: + case OPEN+3: + case OPEN+4: + case OPEN+5: + case OPEN+6: + case OPEN+7: + case OPEN+8: + case OPEN+9: { + register int no; + register char *save; + + no = OP(scan) - OPEN; + save = reginput; + + if (regmatch(next)) { + /* + * Don't set startp if some later + * invocation of the same parentheses + * already has. + */ + if (regstartp[no] == NULL) + regstartp[no] = save; + return(1); + } else + return(0); + } + /* NOTREACHED */ + break; + case CLOSE+1: + case CLOSE+2: + case CLOSE+3: + case CLOSE+4: + case CLOSE+5: + case CLOSE+6: + case CLOSE+7: + case CLOSE+8: + case CLOSE+9: { + register int no; + register char *save; + + no = OP(scan) - CLOSE; + save = reginput; + + if (regmatch(next)) { + /* + * Don't set endp if some later + * invocation of the same parentheses + * already has. + */ + if (regendp[no] == NULL) + regendp[no] = save; + return(1); + } else + return(0); + } + /* NOTREACHED */ + break; + case BRANCH: { + register char *save; + + if (OP(next) != BRANCH) /* No choice. */ + next = OPERAND(scan); /* Avoid recursion. */ + else { + do { + save = reginput; + if (regmatch(OPERAND(scan))) + return(1); + reginput = save; + scan = regnext(scan); + } while (scan != NULL && OP(scan) == BRANCH); + return(0); + /* NOTREACHED */ + } + } + /* NOTREACHED */ + break; + case STAR: + case PLUS: { + register char nextch; + register int no; + register char *save; + register int min; + + /* + * Lookahead to avoid useless match attempts + * when we know what character comes next. + */ + nextch = '\0'; + if (OP(next) == EXACTLY) + nextch = *OPERAND(next); + if (case_fold_search) + nextch = tolower(nextch); + min = (OP(scan) == STAR) ? 0 : 1; + save = reginput; + no = regrepeat(OPERAND(scan)); + while (no >= min) { + /* If it could work, try it. */ + if (nextch == '\0' || + *reginput == nextch + || (case_fold_search && + tolower(*reginput) == nextch)) + if (regmatch(next)) + return(1); + /* Couldn't or didn't -- back up. */ + no--; + reginput = save + no; + } + return(0); + } + /* NOTREACHED */ + break; + case END: + return(1); /* Success! */ + /* NOTREACHED */ + break; + default: + regerror("memory corruption"); + return(0); + /* NOTREACHED */ + break; + } + + scan = next; + } + + /* + * We get here only if there's trouble -- normally "case END" is + * the terminating point. + */ + regerror("corrupted pointers"); + return(0); +} + +/* + - regrepeat - repeatedly match something simple, report how many + */ +static int +regrepeat(char *p) +{ + register int count = 0; + register char *scan; + register char *opnd; + + scan = reginput; + opnd = OPERAND(p); + switch (OP(p)) { + case ANY: + count = strlen(scan); + scan += count; + break; + case EXACTLY: + { char ch = *opnd; + if (case_fold_search) + { ch = tolower(*opnd); + while (ch == tolower(*scan)) + { + count++; + scan++;}} + else + while (ch == *scan) { + count++; + scan++; + }} + break; + case ANYOF: + while (*scan != '\0' && + opnd[*(unsigned char *)scan] != 0) + { + count++; + scan++; + } + break; + case ANYBUT: + while (*scan != '\0' && + opnd[*(unsigned char *)scan] == 0) + { + count++; + scan++; + } + break; + default: /* Oh dear. Called inappropriately. */ + regerror("internal foulup"); + count = 0; /* Best compromise. */ + break; + } + reginput = scan; + + return(count); +} + +/* + - regnext - dig the "next" pointer out of a node + */ +static char * +regnext(register char *p) +{ + register int offset; + + if (p == ®dummy) + return(NULL); + + offset = NEXT(p); + if (offset == 0) + return(NULL); + + if (OP(p) == BACK) + return(p-offset); + else + return(p+offset); +} + +#ifdef DEBUG + +STATIC char *regprop(); + +/* + - regdump - dump a regexp onto stdout in vaguely comprehensible form + */ +void +regdump(r) +regexp *r; +{ + register char *s; + register char op = EXACTLY; /* Arbitrary non-END op. */ + register char *next; + + + s = r->program + 1; + while (op != END) { /* While that wasn't END last time... */ + op = OP(s); + printf("%2d%s", s-r->program, regprop(s)); /* Where, what. */ + next = regnext(s); + if (next == NULL) /* Next ptr. */ + printf("(0)"); + else + printf("(%d)", (s-r->program)+(next-s)); + s += 3; + if (op == ANYOF || op == ANYBUT) + { int i=-1; + while (i++ < 256) + if (s[i]) printf("%c",i); + s +=256; + } + + + else + if (op == EXACTLY) { + /* Literal string, where present. */ + while (*s != '\0') { + putchar(*s); + s++; + } + s++; + } + putchar('\n'); + } + + /* Header fields of interest. */ + if (r->regstart != '\0') + printf("start `%c' ", r->regstart); + if (r->reganch) + printf("anchored "); + if (r->regmust != NULL) + printf("must have \"%s\"", r->regmust); + printf("\n"); +} + +/* + - regprop - printable representation of opcode + */ +static char * +regprop(op) +char *op; +{ + register char *p; + static char buf[50]; + + (void) strcpy(buf, ":"); + + switch (OP(op)) { + case BOL: + p = "BOL"; + break; + case EOL: + p = "EOL"; + break; + case ANY: + p = "ANY"; + break; + case ANYOF: + p = "ANYOF"; + break; + case ANYBUT: + p = "ANYBUT"; + break; + case BRANCH: + p = "BRANCH"; + break; + case EXACTLY: + p = "EXACTLY"; + break; + case NOTHING: + p = "NOTHING"; + break; + case BACK: + p = "BACK"; + break; + case END: + p = "END"; + break; + case OPEN+1: + case OPEN+2: + case OPEN+3: + case OPEN+4: + case OPEN+5: + case OPEN+6: + case OPEN+7: + case OPEN+8: + case OPEN+9: + sprintf(buf+strlen(buf), "OPEN%d", OP(op)-OPEN); + p = NULL; + break; + case CLOSE+1: + case CLOSE+2: + case CLOSE+3: + case CLOSE+4: + case CLOSE+5: + case CLOSE+6: + case CLOSE+7: + case CLOSE+8: + case CLOSE+9: + sprintf(buf+strlen(buf), "CLOSE%d", OP(op)-CLOSE); + p = NULL; + break; + case STAR: + p = "STAR"; + break; + case PLUS: + p = "PLUS"; + break; + default: + regerror("corrupted opcode"); + break; + } + if (p != NULL) + (void) strcat(buf, p); + return(buf); +} +#endif + +/* + * The following is provided for those people who do not have strcspn() in + * their C libraries. They should get off their butts and do something + * about it; at least one public-domain implementation of those (highly + * useful) string routines has been published on Usenet. + */ +/* + * strcspn - find length of initial segment of s1 consisting entirely + * of characters not from s2 + */ + +#ifdef NEVER_WE_PUT_IT_IN_LIB +size_t +strcspn(s1, s2) +char *s1; +char *s2; +{ + register char *scan1; + register char *scan2; + register int count; + + count = 0; + for (scan1 = s1; *scan1 != '\0'; scan1++) { + for (scan2 = s2; *scan2 != '\0';) /* ++ moved down. */ + if (*scan1 == *scan2++) + return(count); + count++; + } + return(count); +} +#endif +/* if min_initial_branch_length(prog,0,0) > 2 + it is possible to have an initial matching routine + This means that each toplevel branch has an initial segment of + characters which is at least 2 and which + */ + +#define MINIMIZE(loc,val) if (val < loc) loc=val +static int +min_initial_branch_length(regexp *x, unsigned char *buf, int advance) +{ char *s = x->program+1; + int overall = 10000; + int i= -1; + char *next ; + char op = EXACTLY; + int n = advance; + if (buf) + { buf[0]=0; + for (i=256; --i>0 ; ){buf[i]=n;}; + } + while(op != END) + { op = OP(s); + next = (s) + NEXT(s); + if (op != END && op != BRANCH) + abort(); + s = s+3; + { int this = 0; + int anythis =0; + int ok = 1; + char op ; + int i; + while (1) + { if (ok == 0) goto LEND; + AGAIN: + if(buf && n <= 0) {break;} + op = OP(s); + advance = n; + s = OPERAND(s); + if (op == EXACTLY) + { int m = strlen(s); + if (buf) + { char *ss = s; + n--; + while(1) + { if (case_fold_search) + {MINIMIZE(buf[tolower(*ss)],n); + MINIMIZE(buf[toupper(*ss)],n); + } + else + { MINIMIZE(buf[*(unsigned char *)ss],n);} + + ss++; + if (*ss==0 || n ==0) break; + --n;}} + else { + this += m + anythis; + anythis = 0;} + + s += m+1;} + else if (op == ANYOF) + { if (buf) + { --n; + for(i=256; --i>0;) + {if (s[i]) MINIMIZE(buf[i],n);}} + else + { + anythis += 1; + /* if this seems like a random choice of letters they + are and they are not */ + if (s['f']==0 || s['a']==0 ||s['y']==0 || s['v']==0) + { this += anythis; + anythis = 0; + }} + + s += 256;} + else if (op == ANY) + {if (buf) + { --n; + for(i=256; --i>0;) + { MINIMIZE(buf[i],n);}} + else + anythis += 1; + } + else if (op == PLUS) + { + ok = 0; goto AGAIN; + } + else + { + LEND: +#ifdef DEBUG + if (buf==0)printf("[Br=%d]",this); +#endif + if (overall > this) { overall = this;} + break;} + }} + s = next; + op = OP(s); + n = advance; + + } +#ifdef DEBUG + if (buf==0) printf("[overall=%d]\n",overall); +#endif + return overall; +} + +#ifndef regerror +void +regerror(char *s) +{ + fprintf(stderr, "regexp error %s\n", s); +} +#endif + diff --git a/o/regexp.h b/o/regexp.h new file mode 100755 index 0000000..e87e9f0 --- /dev/null +++ b/o/regexp.h @@ -0,0 +1,29 @@ +#ifndef _REGEXP +#define _REGEXP 1 + +#define NSUBEXP 10 +typedef struct regexp { + char *startp[NSUBEXP]; + char *endp[NSUBEXP]; + char regstart; /* Internal use only. */ + char reganch; /* Internal use only. */ + char *regmust; /* Internal use only. */ + int regmlen; /* Internal use only. */ + unsigned char regmaybe_boyer; + char program[1]; /* Unwarranted chumminess with compiler. */ +} regexp; + +#if __STDC__ == 1 +#define _ANSI_ARGS_(x) x +#else +#define _ANSI_ARGS_(x) () +#endif + +/* extern regexp *regcomp _ANSI_ARGS_((char *exp)); */ +/* extern int regexec _ANSI_ARGS_((regexp *prog, char *string, char *start,int length )); */ +extern void regsub _ANSI_ARGS_((regexp *prog, char *source, char *dest)); +#ifndef regerror +extern void regerror _ANSI_ARGS_((char *msg)); +#endif + +#endif /* REGEXP */ diff --git a/o/regexpr.c b/o/regexpr.c new file mode 100755 index 0000000..93f177b --- /dev/null +++ b/o/regexpr.c @@ -0,0 +1,191 @@ +/* + Copyright (C) 1994 W. Schelter + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#include +#include "include.h" +#include "page.h" + +#undef STATIC +#define regerror gcl_regerror +static void +gcl_regerror(char *s) +{ + FEerror("Regexp Error: ~a",1,make_simple_string(s)); +} +#undef endp +#include "regexp.c" +#define check_string(x) \ + if (type_of(x) != t_string) \ + not_a_string(x) + + +DEFVAR("*MATCH-DATA*",sSAmatch_dataA,SI,sLnil,""); +DEFVAR("*CASE-FOLD-SEARCH*",sSAcase_fold_searchA,SI,sLnil, + "Non nil means that a string-match should ignore case"); + +DEFUN_NEW("MATCH-BEGINNING",object,fSmatch_beginning,SI,1,1,NONE,OI,OO,OO,OO,(fixnum i), + "Returns the beginning of the I'th match from the previous STRING-MATCH, \ +where the 0th is for the whole regexp and the subsequent ones match parenthetical expressions. -1 is returned if there is no match, or if the *match-data* \ +vector is not a fixnum array.") +{ object v = sSAmatch_dataA->s.s_dbind; + if (type_of(v)==t_vector + && (v->v.v_elttype == aet_fix)) + RETURN1(make_fixnum(sSAmatch_dataA->s.s_dbind->fixa.fixa_self[i])); + RETURN1(make_fixnum(-1)); +} + +DEFUN_NEW("MATCH-END",object,fSmatch_end,SI,1,1,NONE,OI,OO,OO,OO,(fixnum i), + "Returns the end of the I'th match from the previous STRING-MATCH") +{ object v = sSAmatch_dataA->s.s_dbind; + if (type_of(v)==t_vector + && (v->v.v_elttype == aet_fix)) + RETURN1(make_fixnum(sSAmatch_dataA->s.s_dbind->fixa.fixa_self[i+NSUBEXP])); + RETURN1(make_fixnum(-1)); +} + +DEFUN_NEW("COMPILE-REGEXP",object,fScompile_regexp,SI,1,1,NONE,OO,OO,OO,OO,(object p), + "Provide handle to export pre-compiled regexp's to string-match") { + + char *tmp; + object res; + + if (type_of(p)!= t_string && type_of(p)!=t_symbol) + not_a_string_or_symbol(p); + + if (!(tmp=alloca(p->st.st_fillp+1))) + FEerror("out of C stack",0); + memcpy(tmp,p->st.st_self,p->st.st_fillp); + tmp[p->st.st_fillp]=0; + + res=alloc_object(t_vector); + res->v.v_displaced=Cnil; + res->v.v_hasfillp=1; + res->v.v_elttype=aet_uchar; + res->v.v_adjustable=0; + res->v.v_offset=0; + if (!(res->v.v_self=(void *)regcomp(tmp,&res->v.v_dim))) + FEerror("regcomp failure",0); + res->v.v_fillp=res->v.v_dim; + + RETURN1(res); + +} + + +DEFUN_NEW("STRING-MATCH",object,fSstring_match,SI,2,4,NONE,OO,OO,OO,OO,(object pattern,object string,...), + "Match regexp PATTERN in STRING starting in string starting at START \ +and ending at END. Return -1 if match not found, otherwise \ +return the start index of the first matchs. The variable \ +*MATCH-DATA* will be set to a fixnum array of sufficient size to hold \ +the matches, to be obtained with match-beginning and match-end. \ +If it already contains such an array, then the contents of it will \ +be over written. \ +") { + + int i,ans,nargs=VFUN_NARGS,len,start,end; + static char buf[400],case_fold; + static regexp *saved_compiled_regexp; + va_list ap; + object v = sSAmatch_dataA->s.s_dbind; + char **pp,*str,save_c=0; + + if (type_of(pattern)!= t_string && type_of(pattern)!=t_symbol && + (type_of(pattern)!=t_vector || pattern->v.v_elttype!=aet_uchar)) + FEerror("~S is not a regexp pattern", 1 , pattern); + if (type_of(string)!= t_string && type_of(string)!=t_symbol) + not_a_string_or_symbol(string); + + if (type_of(v) != t_vector || v->v.v_elttype != aet_fix || v->v.v_dim < NSUBEXP*2) + v=sSAmatch_dataA->s.s_dbind=fSmake_vector1_1((NSUBEXP *2),aet_fix,sLnil); + + start=0; + end=string->st.st_fillp; + if (nargs>2) { + va_start(ap,string); + start=fixint(va_arg(ap,object)); + if (nargs>3) + end=fixint(va_arg(ap,object)); + va_end(ap); + } + if (start < 0 || end > string->st.st_fillp || start > end) + FEerror("Bad start or end",0); + + len=pattern->ust.ust_fillp; + if (len==0) { + /* trivial case of empty pattern */ + for (i=0;ifixa.fixa_self[i]=i ? -1 : 0; + memcpy(v->fixa.fixa_self+NSUBEXP,v->fixa.fixa_self,NSUBEXP*sizeof(*v->fixa.fixa_self)); + RETURN1(make_fixnum(0)); + } + + { + + regexp *compiled_regexp=saved_compiled_regexp; + + BEGIN_NO_INTERRUPT; + + case_fold_search = sSAcase_fold_searchA->s.s_dbind != sLnil ? 1 : 0; + + if (type_of(pattern)==t_vector) + + compiled_regexp=(void *)pattern->ust.ust_self; + + else if (case_fold != case_fold_search || len != strlen(buf) || memcmp(pattern->ust.ust_self,buf,len)) + + compiled_regexp=saved_compiled_regexp=(regexp *)FFN(fScompile_regexp)(pattern)->v.v_self; + + + str=string->st.st_self; + if (str+end==(void *)core_end || str+end==(void *)compiled_regexp) { + + if (!(str=alloca(string->st.st_fillp+1))) + FEerror("Cannot allocate memory on C stack",0); + memcpy(str,string->st.st_self,string->st.st_fillp); + + } else + save_c=str[end]; + str[end]=0; + + ans = regexec(compiled_regexp,str+start,str,end-start); + + str[end] = save_c; + + if (!ans ) { + END_NO_INTERRUPT; + RETURN1(make_fixnum(-1)); + } + + pp=compiled_regexp->startp; + for (i=0;ifixa.fixa_self[i]=*pp ? *pp-str : -1; + pp=compiled_regexp->endp; + for (;i<2*NSUBEXP;i++,pp++) + v->fixa.fixa_self[i]=*pp ? *pp-str : -1; + + END_NO_INTERRUPT; + RETURN1(make_fixnum(v->fixa.fixa_self[0])); + + } + +} + + diff --git a/o/rel_aix.c b/o/rel_aix.c new file mode 100755 index 0000000..f68b429 --- /dev/null +++ b/o/rel_aix.c @@ -0,0 +1,110 @@ +/* Copyright William Schelter. All rights reserved. This file does +the low level relocation which tends to be very system dependent. +It is included by the file sfasl.c +*/ + +#define EXTERNAL_P(rel) \ + relocation_info.r_type & ) + +#define HI12 0xfff00000 +#define LO20 ~HI12 + +foo(){}; +relocate() +{ + char *where; + + {unsigned int new_value; + char tem [10]; +#ifdef DEBUG + printf("\nEnter relocate:*srelocation_info {r_symndx= %d, r_vaddr = %d,:", + relocation_info.r_symndx, + relocation_info.r_vaddr + );fflush(stdout); +#endif + where = the_start + relocation_info.r_vaddr; + + if(relocation_info.r_symndx < S_BSS){ +#ifdef DEBUG + printf("(relocation_info.r_symndx = %d < S_BSS)",relocation_info.r_symndx + );fflush(stdout); + print_name(&symbol_table[relocation_info.r_symndx]); +#endif + switch(relocation_info.r_type){ + case R_KCALL: + /* instructions like balix take a 20 bit argument + which wants to be the displacement in half words to + from the address of the instruction to the actual + address. */ + {int displ; + unsigned int new; + displ= symbol_table[relocation_info.r_symndx].n_value - + (int)where; + new= *(unsigned int *)where; + + /* *(unsigned int *)where + = (new & HI12) | ((displ >> 1) & LO20); */ + /* need to store the halves separately, because word pointers + must be aligned */ + ((unsigned short *)where)[0]=0x8b00; + ((unsigned short *)where)[1]=0x0c00; + return ;} + case R_PCRBYTE: /* byte (pc relative) */ + case R_PCRWORD: /* word (pc relative) */ + case R_PCRLONG: /* word (pc relative) */ + new_value= - (int)start_address + + symbol_table[relocation_info.r_symndx].n_value; + break; + default: + { new_value= + symbol_table[relocation_info.r_symndx].n_value;}}} + else + { switch(relocation_info.r_symndx){ + case S_DATA: case S_BSS: case S_TEXT: + new_value= (int)start_address; + break; + default: + dprintf(relocation_info.r_type = %d, relocation_info.r_type); +#ifdef DEBUG + printf("\nrelocation_info {r_symndx= %d, r_vaddr = %d, Ignored:", + relocation_info.r_symndx, + relocation_info.r_vaddr + );fflush(stdout); +#endif + goto DONT;} + }; + dprintf((type %d),relocation_info.r_type); + switch(relocation_info.r_type){ + case R_RELBYTE: + case R_PCRBYTE: + *( char *)where = new_value + *( char *) where; + break; + case R_RELWORD: + case R_PCRWORD: + *( short *)where = new_value + *( short *) where; + break; + case R_RELLONG: + case R_PCRLONG: + /* I guess it must be long if in these areas + I don't see how the size can vary. + */ + if (((int)where %4) !=0) FEerror("long alignment not long aligned",0,0); + *( long *)where = new_value + *( long *) where; + break; + default: + printf("(bad type %d)",relocation_info.r_type); + } + DONT:; + } +} + +typedef int (*FUNC)(); + + + +/* #define describe_sym(n) do{if (debug){printf("Sym No %d:",n); print_name(symbol_table+ (n));}}while(0) +*/ + +/* #include "spadutils.c" */ + + diff --git a/o/rel_coff.c b/o/rel_coff.c new file mode 100755 index 0000000..f62c76f --- /dev/null +++ b/o/rel_coff.c @@ -0,0 +1,86 @@ +/* Copyright William Schelter. All rights reserved. This file does +the low level relocation which tends to be very system dependent. +It is included by the file sfasl.c +*/ + +void +relocate() +{ + char *where; + describe_sym(relocation_info.r_symndx); + where = the_start + relocation_info.r_vaddr; + dprintf (where has %x , *where); + dprintf( at %x -->, where ); + + if (relocation_info.r_type == R_ABS) + { dprintf( r_abs ,0) return; } + switch(relocation_info.r_type) + { + case R_DIR32: + dprintf(new val r_dir32 %x , *((int *)where) + + symbol_table[relocation_info.r_symndx].n_value); + *(int *)where= *((int *)where) + + symbol_table[relocation_info.r_symndx].n_value; + break; + case R_PCRLONG: + + dprintf( r_pcrlong new value = %x , + *((int *)where) - (int)start_address + + symbol_table[relocation_info.r_symndx].n_value ); +#ifdef _WIN32 + /* the following is logical, except the address offset is + not where the 'where' is but where the 'call' is just + AFTER the 'where'. + */ + *(int *)where= symbol_table[relocation_info.r_symndx].n_value + - (int) where - sizeof(int *); +#else + *(int *)where= *((int *)where) - (int)start_address + + symbol_table[relocation_info.r_symndx].n_value; +#endif + + break; + default: + fprintf(stdout, "%d: unsupported relocation type.", + relocation_info.r_type); + FEerror("The relocation type was unknown",0,0); + } + +} + + + + +#ifdef DEBUG + +#define describe_sym describe_sym1 +describe_sym1(n) +int n; +{char *str; + char tem[9]; + struct syment *sym; + sym= &symbol_table[n]; + str= sym->n_zeroes == 0 ? + &my_string_table[sym->n_offset] : + (sym->n_name[SYMNMLEN -1] ? + /* MAKE IT NULL TERMINATED */ + (strncpy(tem,sym->n_name, + SYMNMLEN),tem): + sym->n_name ); + printf ("sym-index = %d table entry at %x",n,&symbol_table[n]); + /* + printf("symbol is (%s):\nsymbol_table[n]._n._n_name %s\nsymbol_table[n]._n._n_n._n_zeroes %d\nsymbol_table[n]._n._n_n._n_offset %d\nsymbol_table[n]._n._n_nptr[0] %d\nsymbol_table[n]._n._n_nptr[n] %d\nsymbol_table[n].n_value %d\nsymbol_table[n].n_scnum %d +\nsymbol_table[n].n_type %d\nsymbol_table[n].n_sclass %d\nsymbol_table[n].n_numaux %d", str, + symbol_table[n]._n._n_name, + symbol_table[n]._n._n_n._n_zeroes , + symbol_table[n]._n._n_n._n_offset , + symbol_table[n]._n._n_nptr[0] , + symbol_table[n]._n._n_nptr[1] , + symbol_table[n].n_value , + symbol_table[n].n_scnum , + symbol_table[n].n_type , + symbol_table[n].n_sclass , + symbol_table[n].n_numaux ); */ +} + +#endif diff --git a/o/rel_hp300.c b/o/rel_hp300.c new file mode 100755 index 0000000..e683d22 --- /dev/null +++ b/o/rel_hp300.c @@ -0,0 +1,218 @@ +/* + Copyright (C) 1994 W. Schelter + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +*/ + +#undef NSYMS +#define NSYMS(hdr) count_symbols(&hdr,fp) +#ifndef dprintf +#define dprintf(a,b) +#endif + +/* the routines other than relocate are also used in rsym.c */ + + +#ifdef IN_RSYM +#define temp_malloc malloc +#else + +relocate() +{ + char *where; + { + unsigned int new_value; + where = the_start + relocation_info.r_address; + switch(relocation_info.r_segment){ + case RNOOP: goto DONT; + case REXT: + new_value = symbol_table[relocation_info. + r_symbolnum].n_value; + break; + case RDATA: + case RBSS: + case RTEXT: new_value= (int)start_address; break; + default: + dprintf(relocation_info.r_address = %d, + relocation_info.r_address); + printf( +"\nRel_Info {r_segment = %x, r_symbolnum= %x, r_address = %d} -- Ignored", + relocation_info.r_segment, + relocation_info.r_symbolnum, + relocation_info.r_address); + fflush(stdout); + goto DONT; + }; + switch(relocation_info.r_length){ + case 0: *( char *)where = new_value + *( char *) where; + break; + case 1: *( short *)where = new_value + *( short *) where; + break; + case 2: *( long *)where = new_value + *( long *) where; + break; + } +DONT: ; + } +} + + + +#ifdef PRIVATE_FASLINK + +int +faslink(faslfile, ldargstring) +object faslfile, ldargstring; +{ + struct exec tmpheader, faslheader; + + FILE *fp; TABL *table; + char filename[MAXPATHLEN]; + char ldargstr[MAXPATHLEN]; + char stbfilename[32]; + char tmpfilename[32]; + char command[MAXPATHLEN * 2]; + char buf[BUFSIZ], *p; + int i, res; + object tmpfile, data; + object *old_vs_base = vs_base; + object *old_vs_top = vs_top; + + coerce_to_filename(ldargstring, ldargstr); + coerce_to_filename(faslfile, filename); + +/* Print out symbol table */ + sprintf(stbfilename, "/tmp/stb%d", getpid()); + fp = fopen(stbfilename, "w"); + for(i = 0, p = (char *)&tmpheader; i < sizeof(struct exec); i++) + *p++ = '\0'; + tmpheader.a_magic.system_id = HP9000S200_ID; + tmpheader.a_magic.file_type = RELOC_MAGIC; + tmpheader.a_stamp = 2; + + fwrite(&tmpheader, sizeof(struct exec), 1, fp); + table = c_table.ptable; + for(i = 0; i < c_table.length; i++) { + struct nlist_ nbuf; int len; + char *string; unsigned int address; + string =(*table)[i].string; + address =(*table)[i].address; + len = strlen(string); + if (((strncmp(string,"_end", 4) == NULL) && (len == 4)) || + ((strncmp(string,"_etext",6) == NULL) && (len == 6)) || + ((strncmp(string,"_edata",6) == NULL) && (len == 6))) + continue; + nbuf.n_value = address; + nbuf.n_type = N_ABS | N_EXT; + nbuf.n_length = len; + nbuf.n_almod = 0; + nbuf.n_unused = 0; + fwrite(&nbuf,sizeof(nbuf),1,fp); + fwrite(string,len,1,fp); + tmpheader.a_lesyms += sizeof(struct nlist_) + len; + } + fseek(fp,0,0); + fwrite(&tmpheader, sizeof(struct exec), 1, fp); + fclose(fp); + + sprintf(tmpfilename, "/tmp/fasl%d", getpid()); + sprintf(command, + "ld -r -o %s -x %s %s %s -h _edata -h _etext", + tmpfilename, + stbfilename, + filename, + ldargstr); + + if (system(command) != 0) + FEerror("The linkage editor failed.", 0); + + unlink(stbfilename); + + faslfile = open_stream(faslfile, smm_input, Cnil, sKerror); + vs_push(faslfile); + fp = faslfile->sm.sm_fp; + fread(&faslheader, sizeof(faslheader), 1, fp); + fseek(fp,RDATA_OFFSET(faslheader)+faslheader.a_drsize,0); + + { FILE *tmpfp; + int fpthis,fpend; + fpthis = ftell(fp); + fseek(fp,0,2); + fpend = ftell(fp); + fseek(fp,fpthis,0); + tmpfp = fopen(tmpfilename,"a+"); + fseek(tmpfp,0,2); + filecpy(tmpfp,fp,fpend-fpthis); + fclose(tmpfp); + } + + close_stream(faslfile); + + tmpfile = make_simple_string(tmpfilename); + vs_push(tmpfile); + + res = fasload(tmpfile); + + unlink(tmpfilename); + vs_base = old_vs_base; + vs_top = old_vs_top; + + return(res); +} +#endif +#endif + + +count_symbols(phdr,fp) +struct exec *phdr; +FILE *fp; +{int nsyms,i; + fseek(fp,(int)(LESYM_OFFSET(*phdr)), 0); + for(i = phdr->a_lesyms, nsyms = 0; i > 0; nsyms++) { + struct syment tmp; + fread((char *)&tmp, SYMESZ, 1, fp); i -= SYMESZ; + fseek(fp,(int)tmp.n_length,1); i -= tmp.n_length; + } + return (nsyms); +} + + +#define READ_IN_STRING_TABLE(fp,size) \ + read_in_string_table(fp,&fileheader,size,OUR_ALLOCA(size)) + +char * +read_in_string_table(fp,pfileheader,string_size,buf) +FILE *fp; +struct exec *pfileheader; +int string_size ; +char *buf; + +{ + char *p,*ans; + int slen,i,j; + ans=p = buf; + dprintf( string table leng = %d, string_size); + fseek(fp,LESYM_OFFSET(*pfileheader), 0); + for (i = pfileheader->a_lesyms,j=0; i > 0; i=i- slen-SYMESZ) + { + fseek(fp,SYMESZ, 1); + slen = symbol_table[j++].n_length; + fread(p,slen,1,fp); + *((p)+slen) = '\0'; + dprintf( p %s , p); + dprintf( slen %d,slen); + + p += slen + 1; + } + return (ans); +} diff --git a/o/rel_mac2.c b/o/rel_mac2.c new file mode 100755 index 0000000..6fd3f65 --- /dev/null +++ b/o/rel_mac2.c @@ -0,0 +1,84 @@ +/* Copyright William Schelter. All rights reserved. This file does +the low level relocation which tends to be very system dependent. +It is included by the file sfasl.c +*/ + + +relocate() +{ + char *where; + describe_sym(relocation_info.r_symndx); + where = the_start + relocation_info.r_vaddr; + dprintf (where has %x , *where); + dprintf( at %x -->, where ); + + if (relocation_info.r_type == R_ABS) + { dprintf( r_abs ,0) return; } + switch(relocation_info.r_type) + { int *q; + + case R_RELLONG: + dprintf(new val r_rellong %x , *((int *)where) + + symbol_table[relocation_info.r_symndx].n_value); + *(int *)where= *((int *)where) + + symbol_table[relocation_info.r_symndx].n_value; + break; + + case R_RELWORD: + dprintf(new val r_relword %x , *((short *)where) + + symbol_table[relocation_info.r_symndx].n_value); + *(short *)where= *((short *)where) + + symbol_table[relocation_info.r_symndx].n_value; + break; + case R_PCRLONG: + + dprintf( r_pcrlong new value = %x , + *((int *)where) - (int)start_address + + symbol_table[relocation_info.r_symndx].n_value ); + *(int *)where= *((int *)where) - (int)start_address + + symbol_table[relocation_info.r_symndx].n_value; + break; + + default: + fprintf(stdout, "%d: unsupported relocation type.", + relocation_info.r_type); + FEerror("The relocation type was unknown",0,0); + } + +} + + + + +#ifdef DEBUG + +#define describe_sym describe_sym1 +describe_sym1(n) +int n; +{char *str; + char tem[9]; + struct syment *sym; + sym= &symbol_table[n]; + str= sym->n_zeroes == 0 ? + &my_string_table[sym->n_offset] : + (sym->n_name[SYMNMLEN -1] ? + /* MAKE IT NULL TERMINATED */ + (strncpy(tem,sym->n_name, + SYMNMLEN),tem): + sym->n_name ); + printf ("sym-index = %d table entry at %x",n,&symbol_table[n]); + printf("symbol is (%s):\nsymbol_table[n]._n._n_name %s\nsymbol_table[n]._n._n_n._n_zeroes %d\nsymbol_table[n]._n._n_n._n_offset %d\nsymbol_table[n]._n._n_nptr[0] %d\nsymbol_table[n]._n._n_nptr[n] %d\nsymbol_table[n].n_value %d\nsymbol_table[n].n_scnum %d +\nsymbol_table[n].n_type %d\nsymbol_table[n].n_sclass %d\nsymbol_table[n].n_numaux %d", str, + symbol_table[n]._n._n_name, + symbol_table[n]._n._n_n._n_zeroes , + symbol_table[n]._n._n_n._n_offset , + symbol_table[n]._n._n_nptr[0] , + symbol_table[n]._n._n_nptr[1] , + symbol_table[n].n_value , + symbol_table[n].n_scnum , + symbol_table[n].n_type , + symbol_table[n].n_sclass , + symbol_table[n].n_numaux ); +} + +#endif diff --git a/o/rel_ps2aix.c b/o/rel_ps2aix.c new file mode 100755 index 0000000..5061823 --- /dev/null +++ b/o/rel_ps2aix.c @@ -0,0 +1,91 @@ +/* Copyright William Schelter. All rights reserved. This file does +the low level relocation which tends to be very system dependent. +It is included by the file sfasl.c +*/ + +print_rel(rel,sym) +struct syment *sym; + struct reloc *rel; +{char tem[10]; + printf(" (name = %s)",SYM_NAME(sym)); + printf("{r_type=%d",rel->r_type); + fflush(stdout); +} + + +#ifdef DEBUG + +#define describe_sym describe_sym1 +describe_sym1(n) +int n; +{char *str; + char tem[9]; + struct syment *sym; + sym= &symbol_table[n]; + str = SYM_NAME(sym); + if (debug == 0) return 1; + printf ("sym-index = %d table entry at %x",n,&symbol_table[n]); + printf("symbol is (%s):\nsymbol_table[n]._n._n_name %d\nsymbol_table[n]._n._n_n._n_zeroes %d\nsymbol_table[n]._n._n_n._n_offset %d\nsymbol_table[n]._n._n_nptr[0] %d\nsymbol_table[n]._n._n_nptr[n] %d\nsymbol_table[n].n_value %d\nsymbol_table[n].n_scnum %d " +"\nsymbol_table[n].n_type %d\nsymbol_table[n].n_sclass %d\nsymbol_table[n].n_numaux %d", + symbol_table[n]._n._n_name, + symbol_table[n]._n._n_n._n_zeroes , + symbol_table[n]._n._n_n._n_offset , + symbol_table[n]._n._n_nptr[0] , + symbol_table[n]._n._n_nptr[1] , + symbol_table[n].n_value , + symbol_table[n].n_scnum , + symbol_table[n].n_type , + symbol_table[n].n_sclass , + symbol_table[n].n_numaux ); +} + +#endif + +#define LONG_AT_ADDR(p) LONG_AT_ADDR1(((unsigned char *)p)) +#define LONG_AT_ADDR1(p) (p[0] | (p[1] << 8) | (p[2] << 16) |(p[3] << 24)) +#define STORE_LONG(p,val) STORE_LONG1(((unsigned char *)p),val) +#define STORE_LONG1(p,val) (p[3]=(val >> 24),p[0]=val,p[1]=(val >> 8),p[2]=(val >> 16)) + + + +relocate() +{ + char *where; + int old_val,new_val; +#ifdef DEBUG + if (debug) + {print_rel(&relocation_info,&symbol_table[relocation_info.r_symndx]); + describe_sym(relocation_info.r_symndx);} +#endif + where = the_start + relocation_info.r_vaddr; + dprintf (where has %x , *where); + dprintf( at %x -->, where ); + + if (relocation_info.r_type == R_ABS) + { dprintf( r_abs ,0); return; } + old_val = LONG_AT_ADDR(where); + switch(relocation_info.r_type) + { int *q; + case R_DIR32: + new_val= old_val + symbol_table[relocation_info.r_symndx].n_value; + dprintf(new val r_dir32 %x , new_val); + STORE_LONG(where,new_val); + break; + + case R_PCRLONG: + + new_val = old_val - (int) start_address + + symbol_table[relocation_info.r_symndx].n_value; + dprintf( r_pcrlong new value = %x , new_val) + STORE_LONG(where,new_val); + break; + + default: + fprintf(stderr, "%d: unsupported relocation type.", + relocation_info.r_type); + FEerror("The relocation type was unknown",0,0); + } + +} + + diff --git a/o/rel_rios.c b/o/rel_rios.c new file mode 100755 index 0000000..e10f39a --- /dev/null +++ b/o/rel_rios.c @@ -0,0 +1,284 @@ +/* Copyright William Schelter. All rights reserved. This file does +the low level relocation which tends to be very system dependent. +It is included by the file sfasl.c +*/ + +typedef int (*FUNC)(); +extern int akcltoc; +extern int toc_start; +static int current_toc; +static int ptrgl_offset = 0; +static int ptrgl_text; + +static int akcltoc_used=0; + +/* This is an alternating list of addresses x1,y1,x2,y2,... where + relocation entries for changing value in address x1 shold be read as changing + it in y1 */ + +static int toc_addresses_to_relocate [10]; +static int *next_toc_addresses_to_relocate = toc_addresses_to_relocate ; +static int akcltoc_thisload; +static int begun_relocate = 0; + +static int set_rel_bits(address,bits,val) + char *address; + int val; + int bits; +{ bits += 1; + if ( bits <= 16) + {unsigned short y = *(unsigned short *)address ; + y = y & (~0 << bits) ; + y |= (val & ~(~0 << bits)); + *(unsigned short *)address = val; + } + else + {unsigned int y = *(unsigned int *)address ; + y = y & (~0 << bits) ; + y |= (val & ~(~0 << bits)); + *(unsigned int *)address = y; + } +} + +#ifdef AIX3 +struct syment * +get_symbol(name,scnum,sym_table,length) + char *name; + int scnum,length; + struct syment *sym_table; +{ struct syment *end,*sym; + char tem[SYMNMLEN +1]; + char *na; + end =sym_table + length; + for(sym=sym_table; sym < end; sym += (NUM_AUX(sym) +1)) + {if ((sym)->n_scnum == scnum) + { na=SYM_NAME(sym); + if (strcmp(name,na) == 0) + {return sym;}}} + return 0;} +#endif /* aix3 */ + +/* + 800b0000 l r0,0x0(r11) + 90410014 st r2,0x14(r1) + 7c0903a6 mtctr r0 + 804b0004 l r2,0x4(r11) + 816b0008 l r11,0x8(r11) + 4e800420 bctr +*/ +int myptrgl[6] = { + 0x800b0000, 0x90410014, 0x7c0903a6, 0x804b0004, + 0x816b0008, 0x4e800420}; + +/* 7d8903a6 mtctr r12 + 4e800420 bctr + */ +static int jmp_r12[2] = { 0x7d8903a6, 0x4e800420}; + + +#define SYM_SMC(sym) (((union auxent *)(sym+1))->x_csect.x_smclas) +#define SYM_TOC_ADDR(sym) (((union auxent *)(sym+1))->x_csect.x_parmhash) +/* #define SYM_USED(sym) (((union auxent *)(&sym[1]))->x_csect.x_snhash) */ +#define TC_SYMBOL_P(sym) ((sym)->n_scnum == DATA_NSCN && NUM_AUX((sym)) && \ + (SYM_SMC(sym) == XMC_TC0 || SYM_SMC(sym) == XMC_TC)) + + + +int FIXtemp ; +static int intcmp2(x,y) + int *x,*y; +{ return (*x - *y); +} + +#define TOP6 (~0 << 26) +#define BR_IN_DATA_P(x) (((x) & TOP6) == (DBEGIN & TOP6)) + + +relocate() +{ struct syment *sym = &symbol_table[relocation_info.r_symndx]; + char *where; + describe_sym(relocation_info.r_symndx); + where = the_start + relocation_info.r_vaddr; + dprintf (where has %x , *(int *)where); + dprintf( at %x -->, where ); + + if(begun_relocate == 0) + {int n = next_toc_addresses_to_relocate - toc_addresses_to_relocate; + begun_relocate = 1; + FIXtemp = 0; /* dummy reference for export problem */ + qsort((char *)toc_addresses_to_relocate, n/2 , 2*sizeof(int), intcmp2); + next_toc_addresses_to_relocate + = toc_addresses_to_relocate;} + + switch(RELOC_RTYPE(relocation_info)) + { int *q; + + case R_TOC: /* TOC_ILodx */ + set_rel_bits(where,RELOC_RLEN(relocation_info), sym->n_value - toc_start) ; + break; + case R_POS: /* Pos_Rel */ + + if (where == *next_toc_addresses_to_relocate) + {where = next_toc_addresses_to_relocate [1]; + next_toc_addresses_to_relocate += 2;} + + if ( sym->n_scnum == N_UNDEF || TC_SYMBOL_P(sym)) + set_rel_bits(where,RELOC_RLEN(relocation_info), sym->n_value); + else + set_rel_bits(where,RELOC_RLEN(relocation_info), (*(int *)where)+ sym->n_value); + + break; + case R_BR: /* Brn_Sel */ + case R_RBR: /* Brn_Selx */ + + {int link_bit = ((((int *)where)[0]) & 1); + if (((((int *)where)[0]) & TOP6 ) == 0x48000000) /* bl or b relative */ + { + if (((int *)where)[1] == 0x80410014) /* l r2,0x14(r1) */ + {int x = SYM_TOC_ADDR(sym); + if (x) + { ((int *)where)[0] = 0x81820000 ; /* l r12,0x0(r2) */ + set_rel_bits(where+2,15,x - toc_start); + (((int *)where)[1] = 0x48000000); /* b relative */ + set_rel_bits(where+4, 0x19, ((int) jmp_r12) - ((int) where + 4 )); + ((int *)where)[1] |= link_bit; /* link bit */ + break; + } + else /* must be ptrgl */ + if (BR_IN_DATA_P(sym->n_value)) + {set_rel_bits(where, 0x19, sym->n_value - (int) where); + ((int *)where)[0] |= link_bit; /* link bit */ + break;} + } + else + if (BR_IN_DATA_P(sym->n_value)) + {set_rel_bits(where, 0x19, sym->n_value - (int) where); + ((int *)where)[0] |= link_bit; /* link bit */ + break;}} + else + FEerror("The type of Br_sel was new ",0,0); + } + default: + fprintf(stdout, "%d: unsupported relocation type.", + RELOC_RTYPE(relocation_info) ); + FEerror("The relocation type was unknown",0,0); + } + dprintf( %x,*(int *)where); + +} + +fix_undef_toc_address(answ,sym,str) + char *str; + struct syment *sym; + struct node *answ; + /* undefined sym */ +{ if (BR_IN_DATA_P(answ->address)) return; + if (answ->tc_offset == 0) + { answ->tc_offset = ( akcltoc + akcltoc_used - toc_start); + * ((int *)( akcltoc + akcltoc_used)) = answ->address; + akcltoc_used += sizeof(char *); + } + + if (NUM_AUX(sym)) + SYM_TOC_ADDR(sym) = (toc_start + answ->tc_offset); + else printf("symbol should have aux entry"); + + return; +} + + + + + + +#ifdef DEBUG +#undef describe_sym +#define describe_sym(x) do{if(sfasldebug) describe_sym1(x);} while (0) +describe_sym1(n) +int n; +{char *str; + char tem[9]; + struct syment *sym; + sym= &symbol_table[n]; + str= sym->n_zeroes == 0 ? + &my_string_table[sym->n_offset] : + (sym->n_name[SYMNMLEN -1] ? + /* MAKE IT NULL TERMINATED */ + (strncpy(tem,sym->n_name, + SYMNMLEN),tem): + sym->n_name ); + printf ("sym-index = %d table entry at %x",n,&symbol_table[n]); + printf("symbol is (%s):\nsymbol_table[n]._n._n_name %s\nsymbol_table[n]._n._n_n._n_zeroes %d\nsymbol_table[n]._n._n_n._n_offset %d\nsymbol_table[n]._n._n_nptr[0] %d\nsymbol_table[n]._n._n_nptr[n] %d\nsymbol_table[n].n_value %d\nsymbol_table[n].n_scnum %d nsymbol_table[n].n_type %d\nsymbol_table[n].n_sclass %d\nsymbol_table[n].n_numaux %d", str, + symbol_table[n]._n._n_name, + symbol_table[n]._n._n_n._n_zeroes , + symbol_table[n]._n._n_n._n_offset , + symbol_table[n]._n._n_nptr[0] , + symbol_table[n]._n._n_nptr[1] , + symbol_table[n].n_value , + symbol_table[n].n_scnum , + symbol_table[n].n_type , + symbol_table[n].n_sclass , + symbol_table[n].n_numaux ); +} + +#endif + + + + +/* allocate toc space in the preallocated region starting at akcltoc. + If a symbol already has a toc entry, use that instead + */ + +setup_for_aix_load() +{ bzero(toc_addresses_to_relocate,sizeof(toc_addresses_to_relocate)); + next_toc_addresses_to_relocate= toc_addresses_to_relocate; + akcltoc_thisload = akcltoc + akcltoc_used; + begun_relocate=0; + +} + +char * +sym_name(sym) + struct syment *sym; +{static char tem[SYMNMLEN +1]; + char *name; + tem[SYMNMLEN] = '0'; + name = SYM_NAME(sym); + return name;} + + + +allocate_toc(sym) + struct syment *sym; + /* sym is a symbol in the data section with an aux entry */ +{ if (SYM_SMC(sym) == XMC_TC0) + { sym->n_value = toc_start; return 1;} + if (SYM_SMC(sym) == XMC_TC) + {struct node *answ = find_sym(sym,0); + if (answ && answ->tc_offset) + { sym->n_value = toc_start + answ->tc_offset; + return 1;} + {char *na = sym_name(sym); +#ifdef SYM_USED + if (TC_SYMBOL_P(sym) && SYM_USED(sym) == 0) + return 0; +#endif + if (answ == 0 && *na && *na != '_') + printf("(strange TC synbol %s[%d])",na,sym - symbol_table);} + {int old_value; + (*next_toc_addresses_to_relocate++) = sym->n_value + start_address; + sym->n_value = akcltoc + akcltoc_used; + if (answ) answ->tc_offset = sym->n_value - toc_start; + (*next_toc_addresses_to_relocate++) = sym->n_value; + *((int *)(next_toc_addresses_to_relocate[-1])) = + *((int *)(next_toc_addresses_to_relocate[-2])); + akcltoc_used += sizeof(long int); + if (next_toc_addresses_to_relocate - toc_addresses_to_relocate + >= (sizeof(toc_addresses_to_relocate)/sizeof(int))) + FEerror("ran out",0,0); + if (akcltoc_used > 24000) FEerror("toc exhausted",0,0); + return 1; + }} + return 0; +} diff --git a/o/rel_stand.c b/o/rel_stand.c new file mode 100755 index 0000000..0190d46 --- /dev/null +++ b/o/rel_stand.c @@ -0,0 +1,88 @@ +/* + Copyright (C) 1994 W. Schelter + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +*/ + + +#ifdef STAND + + +#define object char * +#define close_stream(a) +#define coerce_to_filename(a,b) +#define FEerror(a,b,c) printf(a) +#define vs_push(a) +#define read_fasl_vector(a) 0; + +int test; +char *joey="hi bill"; + +char *kcl_self,*system_directory; + +main(argc,argv) +int argc; +char *argv[]; +{argc; + kcl_self=argv[2]; + system_directory=argv[3]; + _fmode = O_BINARY; + + fasload(argv[1]); +} + +node_compare(node1,node2) +char *node1, *node2; +{ return(strcmp( ((struct node *)node1)->string, + ((struct node *)node2)->string));} + + + +read_special_symbols(symfile) +char *symfile; +{FILE *symin; + char *symbols; + int i,jj; + struct lsymbol_table tab; + if (!(symin=fopen(symfile,"r"))) + {perror(symfile);exit(1);}; + if(!fread((char *)&tab,sizeof(tab),1,symin)) + FEerror("No header",0,0); + symbols=malloc(tab.tot_leng); + c_table.alloc_length=( (PTABLE_EXTRA+ tab.n_symbols)); + (c_table.ptable) = (TABL *) malloc(sizeof(struct node) * c_table.alloc_length); + if (!(c_table.ptable)) {perror("could not allocate"); exit(1);}; + i=0; c_table.length=tab.n_symbols; + while(i < tab.n_symbols) + { fread((char *)&jj,sizeof(int),1,symin); + (SYM_ADDRESS(c_table,i))=jj; + SYM_STRING(c_table,i)=symbols; + + while( *(symbols++) = getc(symin)) + {;} +/* dprintf( name %s , SYM_STRING(c_table,i)); + dprintf( addr %d , jj); +*/ + i++; + } + + /* + for(i=0;i< 5;i++) + {printf("Symbol: %d %s %d \n",i,SYM_STRINGN(c_table,i), + SYM_ADDRESS(*ptable,i));} + */ +} + +#endif /* STAND */ + diff --git a/o/rel_sun3.c b/o/rel_sun3.c new file mode 100755 index 0000000..7b3446b --- /dev/null +++ b/o/rel_sun3.c @@ -0,0 +1,44 @@ +/* Copyright William Schelter. All rights reserved. This file does +the low level relocation which tends to be very system dependent. +It is included by the file sfasl.c +*/ + +relocate() +{ + char *where; + + {unsigned int new_value; + where = the_start + relocation_info.r_address; + if(relocation_info.r_extern) + { + if (relocation_info.r_pcrel) + new_value= - (int)start_address + + symbol_table[relocation_info.r_symbolnum].n_value; + else + { new_value= + symbol_table[relocation_info.r_symbolnum].n_value;}} + else + { switch(relocation_info.r_symbolnum){ + case N_DATA: case N_BSS: case N_TEXT: + new_value= (int)start_address; + break; + default: + dprintf(relocation_info.r_extern = %d, relocation_info.r_extern); + printf("\nrelocation_info {r_symbolnum= %d, r_address = %d, r_extern=0 Ignored:",relocation_info.r_address, + relocation_info.r_symbolnum);fflush(stdout); + goto DONT;} + }; + switch(relocation_info.r_length){ + case 0: + *( char *)where = new_value + *( char *) where; break; + case 1: + *( short *)where = new_value + *( short *) where; break; + case 2: + *( long *)where = new_value + *( long *) where; break; + } + DONT:; + } +} + + + diff --git a/o/rel_sun4.c b/o/rel_sun4.c new file mode 100755 index 0000000..45c8320 --- /dev/null +++ b/o/rel_sun4.c @@ -0,0 +1,166 @@ +/* Copyright William Schelter. All rights reserved. This file does +the low level relocation which tends to be very system dependent. +It is included by the file sfasl.c +Thanks to Blewett@research.att.com, for an initial effort on this. +*/ + +/* + Unfortunately the original documentation of the relocation types +was rather sketchy, so I was not able to determine the correct +behaviour of types which were not currently being output. + + These will have to be added later, for the moment an abort will occur. +One way to check your work is to compile sfasl.c defining STAND, and then +compare (using comp.c) the output from it with the output from ld. + */ + +relocate() +{ + char *where; + { + unsigned int new_value; + long x; + where = the_start + relocation_info.r_address; + dprintf (where has %x , *where); + dprintf( at %x -->, where ); +#ifdef DEBUG + dshow(); +#endif + if(relocation_info.r_extern) + { + switch (relocation_info.r_type) + { + case RELOC_DISP8: /* Disp's (pc-rel) */ + case RELOC_DISP16: + case RELOC_DISP32: abort(); + case RELOC_WDISP30: + dprintf ( symbol_table[relocation_info.r_index].n_value %d, + symbol_table[relocation_info.r_index].n_value); + new_value = + symbol_table[relocation_info.r_index].n_value + + relocation_info.r_addend + - (int)start_address; + break; + case RELOC_8: /* simplest relocs */ + case RELOC_16: + case RELOC_32: + case RELOC_HI22: /* SR 22-bit relocs */ + case RELOC_LO10: + dprintf( symbol_table[relocation_info.r_index].n_value = %d , + symbol_table[relocation_info.r_index].n_value); + new_value = + symbol_table[relocation_info.r_index].n_value; + + break; + default: + printf ("extern non-supported relocation_info.r_type=%d\n", + relocation_info.r_type); + fflush (stdout); + goto DONT; + } + dprintf( new value %x , new_value); + dprintf( rtype %x , relocation_info.r_type); + } + else + { + switch(relocation_info.r_index) /* was symbolnum */ + { + case N_DATA: case N_BSS: case N_TEXT: + new_value= (int)start_address; + break; + default: + abort(); + goto DONT; + } + } + + switch (relocation_info.r_type) + { +#define WHERE relocation_info.r_addend + case RELOC_8: /* simplest relocs */ + *(char *)where = x = new_value + WHERE; + break; + case RELOC_16: + *(short *)where = x = new_value + WHERE; + break; + case RELOC_32: + *(int *)where = x = new_value + WHERE; + break; + + case RELOC_DISP8: /* Disp's (pc-rel) */ + abort(); + *(char *)where = x = new_value + *(char *) where; + break; + case RELOC_DISP16: + abort(); + *(short *)where = x = new_value + *(short *) where; + break; + case RELOC_DISP32: + abort(); + *(int *)where = new_value + *(int *) where; + x = new_value + *( int *) where; + break; + + case RELOC_WDISP30: /* SR word disp's */ +#define MASK30BITS 0x3FFFFFFF + *(int *)where = ((((int) new_value) >> 2) & MASK30BITS) + | (~MASK30BITS & ( *(int *) where)); + break; + + case RELOC_WDISP22: + goto Default; + + case RELOC_HI22: /* SR 22-bit relocs */ + x = ((unsigned long) (new_value + relocation_info.r_addend)) >> 10; +#define MASK22 0x3fffff + *(long *) where= (~MASK22 & *(long *)where) | x; + break; + + case RELOC_22: + case RELOC_13: /* SR 13&10-bit relocs*/ + goto Default; + case RELOC_LO10: + x = ((unsigned long) (new_value + relocation_info.r_addend)) & 0x3ff; + *(unsigned short *)(where + 2) |= x; + break; + + case RELOC_SFA_BASE: /* SR S.F.A. relocs */ + case RELOC_SFA_OFF13: + case RELOC_BASE10: /* base_relative pic */ + case RELOC_BASE13: + case RELOC_BASE22: + case RELOC_PC10: /* special pc-rel pic*/ + case RELOC_PC22: + case RELOC_JMP_TBL: /* jmp_tbl_rel in pic */ + case RELOC_SEGOFF16: /* ShLib offset-in-seg*/ + case RELOC_GLOB_DAT: /* rtld relocs */ + case RELOC_JMP_SLOT: + case RELOC_RELATIVE: + + Default: + default: + printf ("non-supported relocation_info.r_type=%d\n", + relocation_info.r_type); + fflush (stdout); + abort(); + } + DONT:; + } + +} + + +#ifdef DEBUG + +dshow() +{ if(debug) + printf("\nrelocation_info:{r_address %d,r_index %d,r_extern %d \n r_type %d, r_addend %d" + , relocation_info.r_address +, relocation_info.r_index +, relocation_info.r_extern +, relocation_info.r_type +, relocation_info.r_addend); + fflush(stdout);} + +#endif /* DEBUG */ + diff --git a/o/rel_u370aix.c b/o/rel_u370aix.c new file mode 100755 index 0000000..3ee2b7e --- /dev/null +++ b/o/rel_u370aix.c @@ -0,0 +1,94 @@ +/* Copyright William Schelter. All rights reserved. This file does +the low level relocation which tends to be very system dependent. +It is included by the file sfasl.c +*/ + +print_rel(rel,sym) +struct syment *sym; + struct reloc *rel; +{char tem[10]; + printf(" (name = %s)",SYM_NAME(sym)); + printf("{r_type=%d",rel->r_type); + fflush(stdout); +} + + +#ifdef DEBUG + +#define describe_sym describe_sym1 +describe_sym1(n) +int n; +{char *str; + char tem[9]; + struct syment *sym; + sym= &symbol_table[n]; + str = SYM_NAME(sym); + if (debug == 0) return 1; + printf ("sym-index = %d table entry at %x",n,&symbol_table[n]); + printf("symbol is (%s):\nsymbol_table[n]._n._n_name %d\nsymbol_table[n]._n._n_n._n_zeroes %d\nsymbol_table[n]._n._n_n._n_offset %d\nsymbol_table[n]._n._n_nptr[0] %d\nsymbol_table[n]._n._n_nptr[n] %d\nsymbol_table[n].n_value %d\nsymbol_table[n].n_scnum %d " +"\nsymbol_table[n].n_type %d\nsymbol_table[n].n_sclass %d\nsymbol_table[n].n_numaux %d", + symbol_table[n]._n._n_name, + symbol_table[n]._n._n_n._n_zeroes , + symbol_table[n]._n._n_n._n_offset , + symbol_table[n]._n._n_nptr[0] , + symbol_table[n]._n._n_nptr[1] , + symbol_table[n].n_value , + symbol_table[n].n_scnum , + symbol_table[n].n_type , + symbol_table[n].n_sclass , + symbol_table[n].n_numaux ); +} + +#endif + +#define LONG_AT_ADDR(p) *((unsigned int *)p) +#define STORE_LONG(p,val) (*((unsigned int *)p)) = (val) + + + + +relocate() +{ + char *where; + int old_val,new_val; +#ifdef DEBUG + if (debug) + {print_rel(&relocation_info,&symbol_table[relocation_info.r_symndx]); + describe_sym(relocation_info.r_symndx);} +#endif + where = the_start + relocation_info.r_vaddr; + dprintf (where has %x , *where); + dprintf( at %x -->, where ); + + if (relocation_info.r_type == R_ABS) + { dprintf( r_abs ,0); return; } + old_val = LONG_AT_ADDR(where); + switch(relocation_info.r_type) + { int *q; + + case R_RELLONG: + case R_DIR32: + new_val= old_val + symbol_table[relocation_info.r_symndx].n_value; + dprintf(new val r_dir32 %x , new_val); + STORE_LONG(where,new_val); + break; + + case R_PCRLONG: + + new_val = old_val - (int) start_address + + symbol_table[relocation_info.r_symndx].n_value; + dprintf( r_pcrlong new value = %x , new_val) + STORE_LONG(where,new_val); + break; + + default: + fprintf(stderr, "%d: unsupported relocation type.", + relocation_info.r_type); + FEerror("The relocation type was unknown",0,0); + } + +} + + + + diff --git a/o/run_process.c b/o/run_process.c new file mode 100755 index 0000000..f6c39c3 --- /dev/null +++ b/o/run_process.c @@ -0,0 +1,630 @@ +/* By Mike Ballantyne */ +/* + Copyright (C) 1994 W. Schelter + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +*/ + +#include + +#define IN_RUN_PROCESS +#include "include.h" + +#ifdef HAVE_SYS_SOCKIO_H +#include +#endif + +#ifdef RUN_PROCESS + +void setup_stream_buffer(object); +object make_two_way_stream(object, object); + +#ifdef __MINGW32__ + +#include +#include +#define PIPE_BUFFER_SIZE 2048 + +void DisplayError ( char *pszAPI ); +void PrepAndLaunchRedirectedChild ( HANDLE hChildStdOut, + HANDLE hChildStdIn, + HANDLE hChildStdErr, + PROCESS_INFORMATION *process_info, + char *name ); + +/* Run a process, with name holding the process name and arguments + * To test: + * + * (setq fp (si::run-process "wish")) + * + */ +void run_process ( char *name ) +{ + object stream_in, stream_out, stream; + HANDLE hChildStdoutReadTmp,hChildStdoutRead,hChildStdoutWrite; + HANDLE hChildStdinWriteTmp,hChildStdinRead,hChildStdinWrite; + HANDLE hChildStderrWrite; + SECURITY_ATTRIBUTES sec_att; + PROCESS_INFORMATION process_info; + int ofd, ifd; + FILE *ofp, *ifp; +#if 0 + DWORD dwRead, dwWritten; + /*CHAR chBuf[1024] = "puts $env(PATH)\n\0";*/ + CHAR chBuf[60] = "button .hello\npack .hello\n\0"; + /*CHAR chBuf[60] = "button .hello\n\0"; */ +#endif + + /* Set up the security attributes struct. */ + sec_att.nLength= sizeof(SECURITY_ATTRIBUTES); + sec_att.lpSecurityDescriptor = NULL; + sec_att.bInheritHandle = TRUE; + + /* Create the child output r/w pipes. The read pipe is temporary. */ + if ( ! CreatePipe ( &hChildStdoutReadTmp, + &hChildStdoutWrite, + &sec_att, + PIPE_BUFFER_SIZE ) ) { + DisplayError ( "CreatePipe stdout" ); + } + + /* Duplicate the output write handle to be used as std error + * avoiding problems when the spawned process closes a + * stdout handle. */ + if ( ! DuplicateHandle ( GetCurrentProcess (), + hChildStdoutWrite, + GetCurrentProcess (), + &hChildStderrWrite, + 0, + TRUE, /* Inheritable */ + DUPLICATE_SAME_ACCESS ) ) { + DisplayError ( "DuplicateHandle stdout/stderr" ); + } + + /* Likewise, the child input pipes. */ + if ( ! CreatePipe ( &hChildStdinRead, + &hChildStdinWriteTmp, + &sec_att, + PIPE_BUFFER_SIZE ) ) { + DisplayError ( "CreatePipe stdin" ); + } + + /* Make uninheritable copies of the output read handle and the + * input write handles. Stops the spawned process from + * inheriting non-closeable pipe handles. */ + if ( ! DuplicateHandle ( GetCurrentProcess(), + hChildStdoutReadTmp, + GetCurrentProcess(), + &hChildStdoutRead, /* The new handle. */ + 0, + FALSE, /* uninheritable. */ + DUPLICATE_SAME_ACCESS ) ) { + DisplayError ( "DuplicateHandle hChildStdoutRead" ); + } + + if ( ! DuplicateHandle ( GetCurrentProcess (), + hChildStdinWriteTmp, + GetCurrentProcess(), + &hChildStdinWrite, /* New handle. */ + 0, + FALSE, /* uninheritable. */ + DUPLICATE_SAME_ACCESS ) ) { + DisplayError ( "DuplicateHandle hChildStdinWrite" ); + } + + /* Kill the inheritable temporary handles. */ + if ( ! CloseHandle(hChildStdoutReadTmp ) ) DisplayError ( "CloseHandle: Temporary output read" ); + if ( ! CloseHandle(hChildStdinWriteTmp ) ) DisplayError ( "CloseHandle: Temporary input write" ); + + PrepAndLaunchRedirectedChild ( hChildStdoutWrite, + hChildStdinRead, + hChildStderrWrite, + &process_info, + name ); + + /* Close pipe handles to ensure that no inappropriately accessible pipe handles + * remain in this process. */ + if ( ! CloseHandle ( hChildStdoutWrite ) ) DisplayError ( "CloseHandle: Output write" ); + if ( ! CloseHandle ( hChildStdinRead ) ) DisplayError ( "CloseHandle: Input read" ); + if ( ! CloseHandle ( hChildStderrWrite ) ) DisplayError ( "CloseHandle: Error write" ); + +#if 0 + fprintf ( stderr, "Before write\n" ); + WriteFile ( hChildStdinWrite, chBuf, strlen ( chBuf ), + &dwWritten, NULL); + FlushFileBuffers ( hChildStdinWrite ); + FlushFileBuffers ( hChildStdoutRead ); + fprintf ( stderr, "Before read\n" ); + if ( ! ReadFile( hChildStdoutRead, chBuf, 2, &dwRead, NULL ) || + dwRead == 0 ) { + DisplayError ( "Nothing read\n" ); + } else { + fprintf ( stderr, "Got Back: %s\n", chBuf ); + } + fprintf ( stderr, "After read\n" ); +#endif + + + /* Connect up the Lisp objects with the pipes. */ + ofd = _open_osfhandle ( (int)hChildStdoutRead, _O_RDONLY | _O_TEXT ); + ofp = _fdopen ( ofd, "r" ); + ifd = _open_osfhandle ( (int)hChildStdinWrite, _O_WRONLY | _O_TEXT ); + ifp = _fdopen ( ifd, "w" ); + +#if 0 + { + char buf[1024]; + fprintf ( ifp, "button .wibble\n" ); + fflush (ifp); + fgets ( buf, 2, ofp ); + fprintf ( stderr, + "run_process: ofd = %x, ofp = %x, ifd = %x, ifp = %x, buf[0] = %x, buf[1] = %x, buf = %s\n", + ofd, ofp, ifd, ifp, buf[0], buf[1], buf ); + } +#endif + + stream_in = (object) alloc_object(t_stream); + stream_in->sm.sm_mode = smm_input; + stream_in->sm.sm_fp = ofp; + stream_in->sm.sm_buffer = 0; + stream_out = (object) alloc_object(t_stream); + stream_out->sm.sm_mode = smm_output; + stream_out->sm.sm_fp = ifp; + stream_out->sm.sm_buffer = 0; + setup_stream_buffer ( stream_in ); + setup_stream_buffer ( stream_out ); + stream = make_two_way_stream ( stream_in, stream_out ); + vs_base[0] = stream; + vs_base[1] = Cnil; + vs_top = vs_base + 1; +} + +/* Set up STARTUPINFO structure and launch redirected child. */ +void PrepAndLaunchRedirectedChild ( + HANDLE hChildStdOut, + HANDLE hChildStdIn, + HANDLE hChildStdErr, + PROCESS_INFORMATION *process_info, + char * name ) +{ + STARTUPINFO startup_info; + + /* Set up the start up info struct. */ + ZeroMemory ( &startup_info, sizeof ( STARTUPINFO ) ); + startup_info.cb = sizeof ( STARTUPINFO ); + startup_info.dwFlags = STARTF_USESTDHANDLES; + startup_info.hStdOutput = hChildStdOut; + startup_info.hStdInput = hChildStdIn; + startup_info.hStdError = hChildStdErr; + + /* Launch the redirected process. */ + if ( ! CreateProcess ( NULL, + name, + NULL, + NULL, + TRUE, + CREATE_NEW_CONSOLE, + NULL, + NULL, + &startup_info, + process_info ) ) { + DisplayError("CreateProcess"); + } + +} + +/* Display the error number and the corresponding Windows message. */ +void DisplayError(char *pszAPI) +{ + LPVOID lpvMessageBuffer; + CHAR szPrintBuffer[512]; + DWORD nCharsWritten; + + FormatMessage ( FORMAT_MESSAGE_ALLOCATE_BUFFER | FORMAT_MESSAGE_FROM_SYSTEM, + NULL, + GetLastError (), + MAKELANGID ( LANG_NEUTRAL, SUBLANG_DEFAULT ), + (LPTSTR) &lpvMessageBuffer, + 0, + NULL ); + + wsprintf ( szPrintBuffer, + "%s:\n error code = %d.\n message = %s.\n", + pszAPI, + GetLastError(), + (char *)lpvMessageBuffer ); + + WriteConsole ( GetStdHandle(STD_OUTPUT_HANDLE), + szPrintBuffer, + lstrlen ( szPrintBuffer ), + &nCharsWritten, + NULL ); + + LocalFree ( lpvMessageBuffer ); + FEerror ( "RUN-PROCESS encountered problems.", 0 ); +} + +void siLrun_process() +{ + char cmdline[20480]; + int i, nargs; + int old = signals_allowed; + int argc = 0; + + nargs = vs_top - vs_base; + for ( i = 0; i < nargs; i++ ) { + check_type_string ( &vs_base[i] ); + } + + cmdline[0]='\0'; + for ( i = 0; i < nargs; i++ ) { + if ( strlen ( cmdline ) + vs_base[i]->st.st_fillp + 2 > 20480 ) { + FEerror ( "RUN-PROCESS command more than 20480 characters long.", 0 ); + } + if ( i != 0 ) { + strcat ( cmdline, " "); + } + strcat ( cmdline, vs_base[i]->st.st_self ); + fprintf ( stderr, "siLrun_process: cmdline=%s\n", cmdline ); + argc++; + } + signals_allowed = sig_at_read; + run_process ( cmdline ); + signals_allowed = old; +} + +void +gcl_init_socket_function() +{ + make_si_function("RUN-PROCESS", siLrun_process); +} + + +#else /* __MINGW32__ */ + +/* + * System Include Files + * + * The system files here each define some part of the information needed to + * compile the inet package. They need to exist of every host you port this + * code to. I have added some comments that I hope will help you "find" + * the file if it does not have the same name of your host. + */ +#undef PAGESIZE +#include /* errno global, error codes for UNIX IO */ +#include /* Data types definitions */ +#include /* Socket definitions with out this forget it */ +#include /* Internet address definition AF_INET etc... */ +#include /* UNIX Signal codes */ +#include /* IO control standard UNIx fair */ +#include +#include /* Function to set socket aync/interrupt */ +#include /* Time for select time out */ +#include /* Data Base interface for network files */ +#include + + + +/* LISP - Lisp Wrapper for the "c" code. + * + * The lisp OBJECT is passed to the code and a string must be extracted + * and null terminated to make it work with the "C" code. + * + * Lisp Interface code. + */ + +static char *lisp_to_string(string) +object string; +{ + int i, len; + char *sself; + char *cstr; + + len = string->st.st_fillp; + + cstr = (char *) malloc (len+1); + sself = &(string->st.st_self[0]); + for (i=0; ih_addr, (char *)&sock_add.sin_addr, hp->h_length); + sock_add.sin_family = hp->h_addrtype; + + sock_add.sin_port = htons((short)server); + + sock = socket( hp->h_addrtype, SOCK_STREAM , 0); + + if(sock < 1) + { + FEerror("No Sockets!",0); + } + + if(connect(sock, (const struct sockaddr *)&sock_add, sizeof(sock_add)) < 0) + { + close(sock); + FEerror("Connection Failed.",0); + } + pid = getpid(); +#ifdef __CYGWIN__ + if(fcntl(sock, F_SETOWN, pid) < 0) +#else + if(ioctl(sock, SIOCSPGRP, (char *)&pid) < 0 ) +#endif + { + FEerror("Could not set process group of socket.",0); + } + +#ifdef OVM_IO + res = fcntl(sock,F_SETFL,FASYNC | FNDELAY); +#else + res = fcntl(sock,F_SETFL,FASYNC); +#endif + return(sock); +} + +object make_stream(host_l,socket,smm) +object host_l; +int socket; +enum smmode smm; +{ + char *mode=NULL; + object stream; + FILE *fp; + vs_mark; + + + switch(smm) + { + case smm_input: + mode = "r"; + break; + case smm_output: + mode = "w"; + break; + default: + FEerror("make_stream : wrong mode",0); + } + + fp = fdopen(socket,mode); + stream = (object) alloc_object(t_stream); + stream->sm.sm_mode = (short)smm; + stream->sm.sm_fp = fp; + stream->sm.sm_buffer = 0; + + stream->sm.sm_object0 = sLstring_char; + stream->sm.sm_object1 = host_l; + stream->sm.sm_int0 = stream->sm.sm_int1 = 0; + vs_push(stream); + setup_stream_buffer(stream); + vs_reset; + return(stream); +} + +object +make_socket_stream(host_l,port) +object host_l; +object port; +{ + char *host = lisp_to_string(host_l); + object stream_in; + object stream_out; + object stream; + int socket; + + socket = open_connection(host, fix(port)); + stream_in = make_stream(host_l,socket, smm_input); + stream_out = make_stream(host_l,socket, smm_output); + + stream = make_two_way_stream(stream_in,stream_out); + + return(stream); +} + +void +FFN(siLmake_socket_stream)() +{ + check_arg(2); + vs_base[0] = make_socket_stream(vs_base[0], vs_base[1]); + vs_popp; +} + +/* + * make 2 two-way streams + */ + +object +make_socket_pair() +{ + int sockets_in[2]; + int sockets_out[2]; + FILE *fp1, *fp2; + object stream_in, stream_out, stream; + + if (socketpair(AF_UNIX, SOCK_STREAM, 0, sockets_in) < 0) + FEerror("Failure to open socket stream pair", 0); + if (socketpair(AF_UNIX, SOCK_STREAM, 0, sockets_out) < 0) + FEerror("Failure to open socket stream pair", 0); + fp1 = fdopen(sockets_in[0], "r"); + fp2 = fdopen(sockets_out[0], "w"); + +#ifdef OVM_IO + {int pid; + pid = getpid(); + ioctl(sockets_in[0], SIOCSPGRP, (char *)&pid); + if( fcntl(sockets_in[0], F_SETFL, FASYNC | FNDELAY) == -1) + perror("Couldn't control socket"); + } +#endif + + + stream_in = (object) alloc_object(t_stream); + stream_in->sm.sm_mode = smm_input; + stream_in->sm.sm_fp = fp1; + stream_in->sm.sm_buffer = 0; + stream_in->sm.sm_int0 = sockets_in[1]; + stream_in->sm.sm_int1 = 0; + stream_out = (object) alloc_object(t_stream); + stream_out->sm.sm_mode = smm_output; + stream_out->sm.sm_fp = fp2; + stream_out->sm.sm_buffer = 0; + setup_stream_buffer(stream_in); + setup_stream_buffer(stream_out); + stream_out->sm.sm_int0 = sockets_out[1]; + stream_out->sm.sm_int1 = 0; + stream = make_two_way_stream(stream_in, stream_out); + return(stream); +} +/* the routines for spawning off a process with streams + * + * Assumes that istream and ostream are both associated + * with "C" type streams. + */ + +void +spawn_process_with_streams(istream, ostream, pname, argv) +object istream; +object ostream; +char *pname; +char **argv; +{ + + int fdin; + int fdout; + if (istream->sm.sm_fp == NULL || ostream->sm.sm_fp == NULL) + FEerror("Cannot spawn process with given stream", 0); + fdin = istream->sm.sm_int0; + fdout = ostream->sm.sm_int0; + if (pfork() == 0) + { /* the child --- replace standard in and out with descriptors given */ + close(0); + massert(dup(fdin)>=0); + close(1); + massert(dup(fdout)>=0); + fprintf(stderr, "\n***** Spawning process %s ", pname); + if (execvp(pname, argv) == -1) + { + fprintf(stderr, "\n***** Error in process spawning *******"); + fflush(stderr); + exit(1); + } + } + +} + + +void +run_process(filename, argv) +char *filename; +char **argv; +{ + object stream = make_socket_pair(); + spawn_process_with_streams(stream->sm.sm_object1, + stream->sm.sm_object0, + filename, argv); + vs_base[0] = stream; + vs_base[1] = Cnil; + vs_top = vs_base + 2; +} + +void +FFN(siLrun_process)() +{ + int i; + object arglist; + char *argv[100]; + + arglist = vs_base[1]; + argv[0] = ""; + for(i = 1; arglist != Cnil; i++) { + argv[i] = lisp_to_string(arglist->c.c_car); + arglist = arglist->c.c_cdr; + } + argv[i] = (char *)0; + run_process(object_to_string(vs_base[0]), argv); +} + +void +FFN(siLmake_socket_pair)() +{ + make_socket_pair(); +} + +void +gcl_init_socket_function() +{ + make_si_function("MAKE-SOCKET-STREAM", siLmake_socket_stream); + make_si_function("MAKE-SOCKET-PAIR", siLmake_socket_pair); + make_si_function("RUN-PROCESS", siLrun_process); +} + +#ifdef MUST_USE_STATIC_LINK +#ifdef __svr4__ +getpagesize() +{ return PAGESIZE; +} + +dlclose() +{fprintf(stderr,"calling 'dl' function sun did not supply..exitting") ;exit(1);} +dgettext() +{dlclose();} +dlopen() +{dlclose();} +dlerror() +{dlclose();} + +dlsym() +{dlclose();} + + + +#endif +#endif /* MUST_USE_STATIC_LINK */ + +#endif /* __MINGW32__ */ + +#else /* no RUN_PROCESS */ +/* static void */ +/* init_socket_function(void) {;} */ + +#endif diff --git a/o/save.c b/o/save.c new file mode 100755 index 0000000..08e605e --- /dev/null +++ b/o/save.c @@ -0,0 +1,46 @@ +#ifndef FIRSTWORD +#include "include.h" +#endif + +static void +memory_save(char *original_file, char *save_file) +{ +#ifdef DO_BEFORE_SAVE + DO_BEFORE_SAVE ; +#endif + + unexec(save_file,original_file,0,0,0); +} + +#ifdef USE_CLEANUP +extern void _cleanup(); +#endif + +LFD(Lsave)(void) { + + char filename[256]; + extern char *kcl_self; + + check_arg(1); + check_type_or_pathname_string_symbol_stream(&vs_base[0]); + coerce_to_filename(vs_base[0], filename); + +#ifdef CLEANUP_CODE + CLEANUP_CODE +#elif defined(USE_CLEANUP) + _cleanup(); +#endif + + raw_image=FALSE; + cs_org=0; + +#ifdef MEMORY_SAVE + MEMORY_SAVE(kcl_self,filename); +#else + memory_save(kcl_self, filename); +#endif + + /* no return */ + exit(0); + +} diff --git a/o/save_sgi4.c b/o/save_sgi4.c new file mode 100755 index 0000000..6fd7ae4 --- /dev/null +++ b/o/save_sgi4.c @@ -0,0 +1,472 @@ +/* for the 4d */ + +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +/* + unixsave.c +*/ + + + +/* When MACHINE is S3000, use fcntl.h */ +#ifdef ATT +#include +#include +#else +#include +#endif + + +#ifdef BSD +#include +#endif + +#ifdef VAX +#define PAGSIZ 1024 +#define SEGSIZ 1024 +#define TXTRELOC 0 +#endif + +#ifdef ISI + + + +#endif + +#ifdef SEQ + + +#endif + +#ifdef NEWS +#define TXTRELOC 0 +#endif + +#ifdef IBMRT + + + +#endif + +#ifdef ATT +#include +#include +#include +#include +#define exec aouthdr +#define a_text tsize +#define a_data dsize +#define a_bss bsize +#endif + +#ifdef E15 +#include +extern etext; +#define exec bhdr +#define a_text tsize +#define a_data dsize +#define a_bss bsize +#define a_syms ssize +#define a_trsize rtsize +#define a_drsize rdsize +#define SEGSIZ (128*1024) +#define TXTRELOC (1024*1024) +#endif + +#ifndef mips +filecpy(to, from, n) +FILE *to, *from; +register int n; +{ + char buffer[BUFSIZ]; + + for (;;) + if (n > BUFSIZ) { + fread(buffer, BUFSIZ, 1, from); + fwrite(buffer, BUFSIZ, 1, to); + n -= BUFSIZ; + } else if (n > 0) { + fread(buffer, 1, n, from); + fwrite(buffer, 1, n, to); + break; + } else + break; +} +#endif + +memory_save(original_file, save_file) +char *original_file, *save_file; +{ + +#ifdef BSD + struct exec header; + int stsize; +#endif +#ifdef ATT +#ifdef mips + struct { + struct filehdr filehdr; + struct aouthdr aouthdr; + struct scnhdr + text_section, + init_section, + rdata_section, + data_section, + lit8_section, + lit4_section, + sdata_section, + sbss_section, + bss_section; + } hdrs; + struct filehdr *pfilehdr; + struct aouthdr *paouthdr; + struct scnhdr *pscnhdr; + char buf[BUFSIZ]; + HDRR symhdr; + int fptr, nbytes, pagesize; +#define setbuf(stream,buf) +#else + struct filehdr fileheader; + struct exec header; +#endif /* mips */ + int diff; +#endif +#ifdef E15 + struct exec header; +#endif + + char *data_begin, *data_end; + int original_data; + FILE *original, *save; + register int n; + register char *p; + extern void *sbrk(); + + fclose(stdin); + original = fopen(original_file, "r"); + if (stdin != original || original->_file != 0) { + fprintf(stderr, "Can't open the original file.\n"); + exit(1); + } + setbuf(original, stdin_buf); + fclose(stdout); + unlink(save_file); + n = open(save_file, O_CREAT|O_WRONLY, 0777); + if (n != 1 || (save = fdopen(n, "w")) != stdout) { + fprintf(stderr, "Can't open the save file.\n"); + exit(1); + } + setbuf(save, stdout_buf); + +#ifdef BSD + fread(&header, sizeof(header), 1, original); + +#ifdef VAX + data_begin + = (char *)((TXTRELOC+header.a_text+(SEGSIZ-1)) & ~(SEGSIZ-1)); +#endif +#ifdef SUN + data_begin + = (char *)((TXTRELOC+header.a_text+(SEGSIZ-1)) & ~(SEGSIZ-1)); +#endif +#ifdef SUN2R3 + data_begin = (char *)N_DATADDR(header); +#endif +#ifdef SUN3 + data_begin = (char *)N_DATADDR(header); +#endif +#ifdef NEWS + data_begin + = (char *)((TXTRELOC+header.a_text+(SEGSIZ-1)) & ~(SEGSIZ-1)); +#endif +#ifdef ISI + + +#endif +#ifdef SEQ + + +#endif +#ifdef IBMRT + + +#endif + + data_end = core_end; + original_data = header.a_data; + header.a_data = data_end - data_begin; + header.a_bss = 0; + fwrite(&header, sizeof(header), 1, save); + +#ifdef VAX + if (header.a_magic == ZMAGIC) + filecpy(save, original, PAGSIZ - sizeof(header)); + filecpy(save, original, header.a_text); +#endif +#ifdef SUN + if (header.a_magic == ZMAGIC) + filecpy(save, original, PAGSIZ - sizeof(header)); + filecpy(save, original, header.a_text); +#endif +#ifdef SUN2R3 + filecpy(save, original, header.a_text - sizeof(header)); +#endif +#ifdef SUN3 + filecpy(save, original, header.a_text - sizeof(header)); +#endif +#ifdef NEWS + if (header.a_magic == ZMAGIC) + filecpy(save, original, PAGSIZ - sizeof(header)); + filecpy(save, original, header.a_text); +#endif +#ifdef ISI + + + + +#endif +#ifdef SEQ + + +#endif +#ifdef IBMRT + + + +#endif +#endif + +#ifdef ATT +#ifdef mips +# define NSCNS 4 + read(0, (char*)&hdrs.filehdr, FILHSZ + AOUTHSZ); + pfilehdr = (struct filehdr*)hdrs.aouthdr.text_start; + paouthdr = (struct aouthdr*)((long)pfilehdr + FILHSZ); + pscnhdr = (struct scnhdr*)((long)paouthdr + AOUTHSZ); + + pagesize = getpagesize(); + + hdrs.aouthdr.dsize = + ((long)core_end - hdrs.aouthdr.data_start + pagesize - 1) + & ~(pagesize - 1); + hdrs.aouthdr.bss_start = + hdrs.aouthdr.data_start + hdrs.aouthdr.dsize; + hdrs.aouthdr.bsize = 0; + + hdrs.filehdr.f_nscns = NSCNS; + hdrs.filehdr.f_timdat = time(NULL); + hdrs.filehdr.f_symptr = hdrs.aouthdr.tsize + hdrs.aouthdr.dsize; + + bcopy((char*)pscnhdr, (char*)&hdrs.text_section, NSCNS * SCNHSZ); + hdrs.data_section.s_size = hdrs.aouthdr.dsize + - hdrs.rdata_section.s_size; + bzero((char*)&hdrs.lit8_section, + sizeof hdrs - FILHSZ - AOUTHSZ - NSCNS * SCNHSZ); + fptr = write(1, &hdrs, AOUTHSZ + FILHSZ + pfilehdr->f_nscns * SCNHSZ); + + p = (char*)hdrs.aouthdr.text_start + fptr; + n = hdrs.aouthdr.tsize - fptr; + nbytes = pagesize - fptr; + write(1, p, nbytes); + p += nbytes; + n -= nbytes; + while ( n > pagesize ) { + write(1, p, pagesize); + p += pagesize; + n -= pagesize; + } + if ( n ) + write(1, p, n); + + lseek(1, hdrs.rdata_section.s_scnptr, SEEK_SET); + p = (char*)hdrs.aouthdr.data_start; + n = hdrs.aouthdr.dsize; + while ( n > pagesize ) { + write(1, p, pagesize); + p += pagesize; + n -= pagesize; + } + if ( n ) + write(1, p, n); + + lseek(0, pfilehdr->f_symptr, SEEK_SET); + diff = hdrs.filehdr.f_symptr - pfilehdr->f_symptr; + read(0, &symhdr, cbHDRR); +#ifndef __STDC__ +#define adjust(field)if(symhdr.cb/**/field/**/Offset)symhdr.cb/**/field/**/Offset+= diff +#else +#define adjust(field)if(symhdr.cb##field##Offset)symhdr.cb##field##Offset+= diff +#endif + adjust(Line); + adjust(Dn); + adjust(Pd); + adjust(Sym); + adjust(Opt); + adjust(Aux); + adjust(Ss); + adjust(SsExt); + adjust(Fd); + adjust(Rfd); + adjust(Ext); +#undef adjust + write(1, &symhdr, cbHDRR); + while ( (n = read(0, buf, sizeof buf)) > 0 ) + write(1, buf, n); +#else + fread(&fileheader, sizeof(fileheader), 1, original); + fread(&header, sizeof(header), 1, original); + data_begin = (char *)header.data_start; + data_end = core_end; + original_data = header.a_data; + header.a_data = data_end - data_begin; + diff = header.a_data - original_data; + header.a_bss = sbrk(0) - core_end; + fileheader.f_symptr += diff; + fwrite(&fileheader, sizeof(fileheader), 1, save); + fwrite(&header, sizeof(header), 1, save); + fread(§ionheader, sizeof(sectionheader), 1, original); + if (sectionheader.s_lnnoptr) + sectionheader.s_lnnoptr += diff; + fwrite(§ionheader, sizeof(sectionheader), 1, save); + fread(§ionheader, sizeof(sectionheader), 1, original); + sectionheader.s_size += diff; + if (sectionheader.s_lnnoptr) + sectionheader.s_lnnoptr += diff; + fwrite(§ionheader, sizeof(sectionheader), 1, save); + fread(§ionheader, sizeof(sectionheader), 1, original); + sectionheader.s_paddr += diff; + sectionheader.s_vaddr += diff; + sectionheader.s_size = header.a_bss; +#ifdef S3000 + if (sectionheader.s_scnptr) + sectionheader.s_scnptr += diff; +#endif + if (sectionheader.s_lnnoptr) + sectionheader.s_lnnoptr += diff; + fwrite(§ionheader, sizeof(sectionheader), 1, save); + for (n = 4; n <= fileheader.f_nscns; n++) { + fread(§ionheader, sizeof(sectionheader), 1, original); + if (sectionheader.s_scnptr) + sectionheader.s_scnptr += diff; + if (sectionheader.s_lnnoptr) + sectionheader.s_lnnoptr += diff; + fwrite(§ionheader, sizeof(sectionheader), 1, save); + } + filecpy(save, original, header.a_text); +#endif /* mips */ +#endif + +#ifdef E15 + fread(&header, sizeof(header), 1, original); + if (header.fmagic != NMAGIC) + data_begin + = (char *)(TXTRELOC+header.a_text); + else + data_begin + = (char *)((TXTRELOC+header.a_text+(SEGSIZ-1)) & ~(SEGSIZ-1)); + data_end = core_end; + original_data = header.a_data; + header.a_data = data_end - data_begin; + header.a_bss = sbrk(0) - core_end; + fwrite(&header, sizeof(header), 1, save); + filecpy(save, original, header.a_text); +#endif + +#ifndef mips + for (n = header.a_data, p = data_begin; ; n -= BUFSIZ, p += BUFSIZ) + if (n > BUFSIZ) + fwrite(p, BUFSIZ, 1, save); + else if (n > 0) { + fwrite(p, 1, n, save); + break; + } else + break; + + fseek(original, original_data, 1); + +#ifdef BSD + filecpy(save, original, header.a_syms+header.a_trsize+header.a_drsize); + fread(&stsize, sizeof(stsize), 1, original); + fwrite(&stsize, sizeof(stsize), 1, save); + filecpy(save, original, stsize - sizeof(stsize)); +#endif + +#ifdef ATT + for (;;) { + n = getc(original); + if (feof(original)) + break; + putc(n, save); + } +#endif + +#ifdef E15 + filecpy(save, original, header.a_syms+header.a_trsize+header.a_drsize); +#endif +#endif /* !mips */ + fclose(original); + fclose(save); +} + +Lsave() +{ + char filename[256]; + + check_arg(1); + check_type_or_pathname_string_symbol_stream(&vs_base[0]); + coerce_to_filename(vs_base[0], filename); +/* + _cleanup(); +*/ + { + FILE *p; + int nfile; + +#ifdef HAVE_GETDTABLESIZE + nfile = getdtablesize(); +#else + nfile = _NFILE; +#endif + for (p = &__iob[3]; p < &__iob[nfile]; p++) + fclose(p); + } + memory_save(kcl_self, filename); +/* + _exit(0); +*/ + exit(0); + /* no return */ +} + + +#ifdef ISI + + + + + + + + + + +#endif diff --git a/o/saveaix3.c b/o/saveaix3.c new file mode 100755 index 0000000..3fab243 --- /dev/null +++ b/o/saveaix3.c @@ -0,0 +1,283 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +(c) Copyright William F. Schelter. + +*/ +/* + unixsave.c +*/ +#ifndef UNIX +#include "include.h" +#endif + +#include +#include +#include +#include +filecpy(to, from, n) +FILE *to, *from; +register int n; +{ + char buffer[BUFSIZ]; + for (;;) + if (n > BUFSIZ) { + fread(buffer, BUFSIZ, 1, from); + fwrite(buffer, BUFSIZ, 1, to); + n -= BUFSIZ; + } + else if (n > 0) { + fread(buffer, 1, n, from); + fwrite(buffer, 1, n, to); + break; + } + else + break; +} +#include +#include +char *__start; +memory_save(original_file, save_file) +char *original_file, *save_file; +{ /* MEM_SAVE_LOCALS; */ + struct filehdr Eheader; + struct aouthdr header; + struct scnhdr shdrs[15]; + int stsize; + int textsize=0; + int after_data; + int orig_data_scnptr; + int orig_debug_scnptr; + + char *data_begin, *data_end; + int original_data; + FILE *original, *save; + register int n; + register char *p; + extern char *sbrk(); + + fclose(stdin); + original = fopen(original_file, "r"); + if (stdin != original || original->_file != 0) { + fprintf(stderr, "Can't open the original file.\n"); + exit(1); + } + setbuf(original, stdin_buf); + fclose(stdout); + unlink(save_file); + n = open(save_file, O_CREAT|O_WRONLY, 0777); + if (n != 1 || (save = fdopen(n, "w")) != stdout) { + fprintf(stderr, "Can't open the save file.\n"); + exit(1); + } + setbuf(save, stdout_buf); + /* READ_HEADER; */ + fread(&Eheader, sizeof(Eheader), 1, original); + fread(&header, sizeof(header), 1, original); + data_begin= 0x20000800; + { + char buf[500]; + struct ld_info * ld; + loadquery(L_GETINFO,buf,sizeof(buf)); + ld = (struct ld_info *)buf; + data_begin = ld->ldinfo_dataorg ; + } + + /* header.data_start = data_begin; */ + + data_end = core_end; + original_data = header.dsize; + header.dsize = data_end - data_begin; + header.bsize = 0; + { + int j,i = Eheader.f_nscns; + int diff; + fread(shdrs +1 ,i,sizeof(struct scnhdr),original); + orig_data_scnptr = shdrs[header.o_sndata].s_scnptr; + orig_debug_scnptr = shdrs[8].s_scnptr; + diff = header.a_data - original_data + - shdrs[header.o_snbss + 1].s_size; + after_data = shdrs[header.o_snbss +2].s_scnptr; + Eheader.f_symptr += diff; + fwrite(&Eheader, sizeof(Eheader), 1, save); + fwrite(&header, sizeof(header), 1, save); + shdrs[header.o_snbss ].s_size = 0; + shdrs[header.o_snbss +1 ].s_size = 0; + /* ex**pect no more than 15 sections, and pad after data */ + if (strcmp(".pad",shdrs[header.o_snbss + 1].s_name) + || i >= 15) + perror("unexpected format of object file"); + shdrs[header.o_sndata ].s_size = header.a_data; + /* shdrs[header.o_sndata].s_paddr = data_begin; + shdrs[header.o_sndata].s_vaddr = data_begin; + */ + for (j=1; j<= i; j++) +#define ADJUST(x) if(x) (x) = (x) + diff + { + ADJUST(shdrs[j].s_lnnoptr); + ADJUST(shdrs[j].s_relptr); + } + for (j= header.o_sndata +1 ; j<= i; j++) + { + ADJUST(shdrs[j].s_scnptr); + ADJUST(shdrs[j].s_vaddr); + ADJUST(shdrs[j].s_paddr); + } + fwrite(shdrs +1 ,i,sizeof(struct scnhdr),save); + + + /* FILECPY_HEADER; */ + filecpy(save, original, + shdrs[header.o_sndata].s_scnptr + - sizeof(header)-sizeof(Eheader) - i*sizeof(struct scnhdr)); + + j= ftell(save); + j= ftell(original); + for (n = header.a_data, p = data_begin; ; n -= BUFSIZ, p += BUFSIZ) + if (n > BUFSIZ) + fwrite(p, BUFSIZ, 1, save); + else if (n > 0) { + fwrite(p, 1, n, save); + break; + } + else + break; + fseek(original, original_data, 1); + fseek(original, after_data, 0); + + /* now positioned at the loader section */ + { + struct ldhdr *ldheader; + struct ldrel * ldreloc_info,*p; + char *space; + space = (char *) sbrk(shdrs[header.o_snloader].s_size + 0x2000); + ldheader = (struct ldhdr *) space; + fread(space,1,shdrs[header.o_snloader].s_size,original); + ldreloc_info = (struct ldrel *) + (space + sizeof(struct ldhdr) + LDSYMSZ * ldheader->l_nsyms); + i = sizeof(struct ldhdr) + LDSYMSZ * (ldheader->l_nsyms); + for(p=ldreloc_info,i=0; i< ldheader->l_nreloc ; i++,p++) + { + if (p->l_rsecnm == header.o_snbss) + (p->l_rsecnm = header.o_sndata); + if (p->l_symndx == 2) /* make bss be data */ + (p->l_symndx = 1); + } + /* p->l_vaddr += data_begin; */ + fwrite(ldheader, 1, shdrs[header.o_snloader].s_size,save); + /* unrelocate */ + { + int j1 = ftell(save); + int j2= ftell(original); + int off=0; + fseek(original,orig_data_scnptr,0); + fseek(save,shdrs[header.o_sndata].s_scnptr,0); + for(p=ldreloc_info,i=0; i< ldheader->l_nreloc ; i++,p++) + if (p->l_rsecnm == header.o_sndata) + { + int x,pos1,y; + int d = p->l_vaddr - off; + if (d) + { + fseek(save,d,1); + fseek(original,d,1); + off += d; + } + pos1 = ftell(original); + pos1 = ftell(save); + fread(&x,1,sizeof(int),original); + y = x; + if (p->l_symndx ==0) + { + int w = *((int *)&__start); + x = ((*(int *)(data_begin+off))); + x = x + header.text_start ; + x = x - w ; + } + if (p->l_symndx ==1 || p->l_symndx ==2) + { + x = ((*(int *)(data_begin + off)) - (int) data_begin); + } + fwrite(&x,1,sizeof(int),save); + off += sizeof(int); + } + fseek(save,j1,0); + fseek(original,j2,0); + + } + } + + sbrk(- (shdrs[header.o_snloader].s_size+ 0x2000)); + filecpy(save,original,Eheader.f_symptr - ftell(save)); + /* now at the beginning of the sym table */ + { + struct syment symbol; + struct syment *sym = &symbol; + int naux; + int nsyms = Eheader.f_nsyms; + while (--nsyms >= 0) + { + fread(&symbol,1,SYMESZ,original); + fwrite(&symbol,1,SYMESZ,save); + naux= sym->n_numaux; + nsyms = nsyms - naux; + if (ISFCN(sym->n_type) + && (naux >= 2)) + { + fread(&symbol,1,SYMESZ,original); + (((union auxent *)(sym))->x_sym.x_fcnary.x_fcn.x_lnnoptr) += diff; + fwrite(&symbol,1,SYMESZ,save); + filecpy(save,original,SYMESZ*(naux -1)); + } + else + filecpy(save,original,SYMESZ*(naux)); + } + } + + + COPY_TO_SAVE; + fclose(original); + fclose(save); + } + } +Lsave() +{ + char filename[256]; + check_arg(1); + check_type_or_pathname_string_symbol_stream(&vs_base[0]); + coerce_to_filename(vs_base[0], filename); + _cleanup(); + /* + { + FILE *p; + int nfile; + nfile = NUMBER_OPEN_FILES; + for (p = &_iob[3]; p < &_iob[nfile]; p++) + fclose(p); + } +*/ + memory_save(kcl_self, filename); + _exit(0); + /* + exit(0); +*/ + /* no return */ +} + diff --git a/o/savedec31.c b/o/savedec31.c new file mode 100755 index 0000000..67d2706 --- /dev/null +++ b/o/savedec31.c @@ -0,0 +1,249 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +/* + unixsave.c +*/ + + +#ifdef HAVE_FCNTL +#include +#else +#include +#endif + +#ifdef HAVE_AOUT +#undef BSD +#undef ATT +#define BSD +#endif + + + +#ifdef BSD +#include +#endif + + +#ifdef ATT +#include +#include +#include +#include +#endif + +#ifdef E15 +#include +extern etext; +#endif + + +filecpy(to, from, n) +FILE *to, *from; +register int n; +{ + char buffer[BUFSIZ]; + + for (;;) + if (n > BUFSIZ) { + fread(buffer, BUFSIZ, 1, from); + fwrite(buffer, BUFSIZ, 1, to); + n -= BUFSIZ; + } else if (n > 0) { + fread(buffer, 1, n, from); + fwrite(buffer, 1, n, to); + break; + } else + break; +} + + +memory_save(original_file, save_file) +char *original_file, *save_file; +{ /* MEM_SAVE_LOCALS; */ + + struct filehdr Ehdr; + struct aouthdr header; + struct scnhdr shdr[10]; + HDRR symhdr; + + struct scnhdr *text_section; + struct scnhdr *rdata_section; + struct scnhdr *data_section; + struct scnhdr *lit8_section; + struct scnhdr *lit4_section; + struct scnhdr *sdata_section; + struct scnhdr *sbss_section; + struct scnhdr *bss_section; + + char *data_begin, *data_end; + int original_data; + FILE *original, *save; + register int n; + register char *p; + extern char *sbrk(); + + + fclose(stdin); + original = fopen(original_file, "r"); + if (stdin != original || original->_file != 0) { + fprintf(stderr, "Can't open the original file.\n"); + exit(1); + } + setbuf(original, stdin_buf); + fclose(stdout); + unlink(save_file); + n = open(save_file, O_CREAT|O_WRONLY, 0777); + if (n != 1 || (save = fdopen(n, "w")) != stdout) { + fprintf(stderr, "Can't open the save file.\n"); + exit(1); + } + setbuf(save, stdout_buf); + + fread(&Ehdr,sizeof(Ehdr),1,original); + fread(&header,Ehdr.f_opthdr, 1,original); + {int i=0; + int pagesize = getpagesize(); +/* core_end = (char *)((int) (core_end + pagesize - 1) & ~(pagesize - 1)); +*/ + +#define READ_SCNHDR(name,str) \ + name = &shdr[i]; \ + fread(name,sizeof(struct scnhdr),1,original); \ + if(strcmp(str,(name)->s_name)) printf("got %s not %s sections", \ + (name)->s_name,str); i++; + READ_SCNHDR(text_section,".text") ; + READ_SCNHDR(rdata_section,".rdata"); + READ_SCNHDR(data_section,".data"); + READ_SCNHDR(lit8_section, ".lit8"); + READ_SCNHDR(lit4_section, ".lit4"); + READ_SCNHDR(sdata_section, ".sdata"); + READ_SCNHDR(sbss_section,".sbss"); + READ_SCNHDR(bss_section,".bss"); + if(i!= Ehdr.f_nscns) printf("wrong number of sections"); + } +/* + READ_HEADER; + FILECPY_HEADER; + */ +#define ALTER_SCN(name,size,addr,scnptr) (name)->s_size = size; \ + (name)->s_paddr = addr; \ + (name)->s_vaddr = addr; \ + (name)->s_scnptr = scnptr; + + original_data = header.a_data; + + data_begin = (char *)rdata_section->s_vaddr; + header.a_data = (int) core_end - rdata_section->s_vaddr; + header.a_bss = 0; + + + ALTER_SCN(data_section, header.a_data - rdata_section->s_size + ,data_section->s_vaddr, data_section->s_scnptr); + ALTER_SCN(lit4_section,0,data_section->s_vaddr,data_section->s_scnptr); + ALTER_SCN(lit8_section,0,data_section->s_vaddr,data_section->s_scnptr); + ALTER_SCN(sbss_section,0,data_section->s_vaddr,data_section->s_scnptr); + ALTER_SCN(sdata_section,0,data_section->s_vaddr,data_section->s_scnptr) +; + ALTER_SCN(bss_section,0, /* sbrk(0) - core_end,*/ + data_section->s_vaddr,data_section->s_scnptr); + + header.bsize = bss_section->s_size; + Ehdr.f_symptr += (header.dsize - original_data); + + fwrite(&Ehdr,1,sizeof(Ehdr),save); + fwrite(&header,1,Ehdr.f_opthdr,save); + fwrite(&shdr[0],sizeof(struct scnhdr),Ehdr.f_nscns,save); + filecpy(save,original,rdata_section->s_scnptr - ftell(save)); +/* p = data_begin; n= header.a_data; + while(--n>=0) + {putc(*p,save); p++;} */ + + for (n = header.a_data, p = data_begin; ; n -= BUFSIZ, p += BUFSIZ) + { {int jj; + jj = ftell(save);} + + + + if (n > BUFSIZ) + fwrite(p, BUFSIZ, 1, save); + else if (n > 0) { + fwrite(p, 1, n, save); + break; + } else + break;} + + fseek(original, original_data, 1); + + + COPY_TO_SAVE; + {int diff = (header.dsize - original_data); + fseek(original,Ehdr.f_symptr - diff,0); + fread(&symhdr,sizeof(symhdr),1,original); + if(symhdr.cbLineOffset)symhdr.cbLineOffset+= diff; + if(symhdr.cbDnOffset)symhdr.cbDnOffset+= diff; + if(symhdr.cbPdOffset)symhdr.cbPdOffset+= diff; + if(symhdr.cbSymOffset)symhdr.cbSymOffset+= diff; + if(symhdr.cbOptOffset)symhdr.cbOptOffset+= diff; + if(symhdr.cbAuxOffset)symhdr.cbAuxOffset+= diff; + if(symhdr.cbSsOffset)symhdr.cbSsOffset+= diff; + if(symhdr.cbSsExtOffset)symhdr.cbSsExtOffset+= diff; + if(symhdr.cbFdOffset)symhdr.cbFdOffset+= diff; + if(symhdr.cbRfdOffset)symhdr.cbRfdOffset+= diff; + if(symhdr.cbExtOffset)symhdr.cbExtOffset+= diff; + fseek(save,Ehdr.f_symptr ,0); + fwrite(&symhdr,sizeof(symhdr),1,save); + } + + fclose(original); + fclose(save); +} + +Lsave() +{ + char filename[256]; + + check_arg(1); + check_type_or_pathname_string_symbol_stream(&vs_base[0]); + coerce_to_filename(vs_base[0], filename); + + _cleanup(); +/* + { + FILE *p; + int nfile; + + + nfile = NUMBER_OPEN_FILES; + + for (p = &_iob[3]; p < &_iob[nfile]; p++) + fclose(p); + } +*/ + memory_save(kcl_self, filename); +/* + _exit(0); +*/ + exit(0); + + /* no return */ +} + diff --git a/o/saveu370.c b/o/saveu370.c new file mode 100755 index 0000000..5f1dde7 --- /dev/null +++ b/o/saveu370.c @@ -0,0 +1,188 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +/* + unixsave.c +*/ + + +#include +#include +#include +#ifdef u370 +#undef u370 +#include + +filecpy(to, from, n) +FILE *to, *from; +register int n; +{ + char buffer[BUFSIZ]; + + for (;;) + if (n > BUFSIZ) { + fread(buffer, BUFSIZ, 1, from); + fwrite(buffer, BUFSIZ, 1, to); + n -= BUFSIZ; + } else if (n > 0) { + fread(buffer, 1, n, from); + fwrite(buffer, 1, n, to); + break; + } else + break; +} + + +memory_save(original_file, save_file) +char *original_file, *save_file; +{ MEM_SAVE_LOCALS; + struct scnhdr shdrs[15]; + char *data_begin, *data_end; + int original_data; + FILE *original, *save; + register int n; + register char *p; + extern char *sbrk(); + + + fclose(stdin); + original = fopen(original_file, "r"); + if (stdin != original || original->_file != 0) { + fprintf(stderr, "Can't open the original file.\n"); + exit(1); + } + setbuf(original, stdin_buf); + fclose(stdout); + unlink(save_file); + n = open(save_file, O_CREAT|O_WRONLY, 0777); + if (n != 1 || (save = fdopen(n, "w")) != stdout) { + fprintf(stderr, "Can't open the save file.\n"); + exit(1); + } + setbuf(save, stdout_buf); + + /* READ_HEADER; */ + fread(&fileheader, sizeof(fileheader), 1, original); + fread(&header, fileheader.f_opthdr, 1, original); + fread(&shdrs[1],sizeof(sectionheader),fileheader.f_nscns,original); + data_begin = (char *) shdrs[2].s_paddr; + data_end = core_end; + original_data = header.a_data; + header.a_data = data_end - data_begin; + diff = header.a_data - original_data; + header.a_bss = sbrk(0) - core_end; + fileheader.f_symptr += diff; + fwrite(&fileheader, sizeof(fileheader), 1, save); + fwrite(&header,fileheader.f_opthdr , 1, save); + + /* .text */ +#define INC_IF(x) if(x) x = x+diff; + + /* .data */ + INC_IF(shdrs[2].s_size); + + /* .bss */ + shdrs[3].s_paddr += diff; + shdrs[3].s_vaddr += diff; + shdrs[3].s_size = header.a_bss; + + for (n = 1; n <= fileheader.f_nscns; n++) { + INC_IF(shdrs[n].s_lnnoptr); + if(n>=3) {INC_IF(shdrs[n].s_scnptr);} + + }; + fwrite(&shdrs[1],sizeof(sectionheader),fileheader.f_nscns,save); + + filecpy(save,original,shdrs[2].s_scnptr - ftell(save)); + + for (n = header.a_data, p = data_begin; ; n -= BUFSIZ, p += BUFSIZ) + if (n > BUFSIZ) + fwrite(p, BUFSIZ, 1, save); + else if (n > 0) { + fwrite(p, 1, n, save); + break; + } else + break; + + fseek(original, original_data, 1); + + COPY_TO_SAVE; + + fclose(original); + fclose(save); +} + +Lsave() +{ + char filename[256]; + + check_arg(1); + check_type_or_pathname_string_symbol_stream(&vs_base[0]); + coerce_to_filename(vs_base[0], filename); + + _cleanup(); +/* + { + FILE *p; + int nfile; + + + nfile = NUMBER_OPEN_FILES; + + for (p = &_iob[3]; p < &_iob[nfile]; p++) + fclose(p); + } +*/ + memory_save(kcl_self, filename); +/* + _exit(0); +*/ + exit(0); + /* no return */ +} + + + +#include "page.h" +#undef sbrk +char *sbrk (); +char * +sbrk1(n) +{ char *m1; + char * m = sbrk(0); +/* printf("Calling sbrk(0x%08x),[cur,rently sbrk(0)=0x%08x,core_end=0x%08x," + ,n,m,core_end); + */ + m1 = sbrk(n); + if (core_end && m1!= m) + { if (m1 < m || + ((int)m1 % PAGESIZE)) + { error("unexpected sbrk"); + } + while ( m < m1) + {type_map[page(m)] = t_other; + m += PAGESIZE; + } + core_end = m;} +/* printf("Returning 0x%08x\n",m); */ + return m;} + + diff --git a/o/sbrk.c b/o/sbrk.c new file mode 100755 index 0000000..5086d9b --- /dev/null +++ b/o/sbrk.c @@ -0,0 +1,28 @@ +#include +extern char end; + +static caddr_t curbrk = &end; +caddr_t sbrk(int n); + +void * +sbrk(int n) { + int res; + if (n==0) return curbrk; + { + void * x=curbrk; + char *p; + p=curbrk; + p=p+n; + res = brk(p); + + if (res==-1) error("can't set brk"); + else curbrk = p; + return (x); + } +} + + + + + + diff --git a/o/sequence.d b/o/sequence.d new file mode 100755 index 0000000..270046f --- /dev/null +++ b/o/sequence.d @@ -0,0 +1,557 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +*/ + +/* + sequence.d + + sequence routines +*/ + +#include "include.h" + +/* + I know the following name is not good. +*/ +object +alloc_simple_vector(l, aet) +int l; +enum aelttype aet; +{ + object x; + + x = alloc_object(t_vector); + x->v.v_hasfillp = FALSE; + x->v.v_adjustable = FALSE; + x->v.v_displaced = Cnil; + x->v.v_dim = x->v.v_fillp = l; + x->v.v_self = NULL; + x->v.v_elttype = (short)aet; + return(x); +} + +object +alloc_simple_bitvector(l) +int l; +{ + object x; + + x = alloc_object(t_bitvector); + x->bv.bv_hasfillp = FALSE; + x->bv.bv_adjustable = FALSE; + x->bv.bv_displaced = Cnil; + x->bv.bv_dim = x->bv.bv_fillp = l; + x->bv.bv_offset = 0; + x->bv.bv_self = NULL; + x->bv.bv_elttype = aet_bit; + return(x); +} + +LFD(Lelt)() +{ + check_arg(2); + vs_base[0] = elt(vs_base[0], fixint(vs_base[1])); + vs_popp; +} + +object +elt(seq, index) +object seq; +int index; +{ + int i; + object l; + + if (index < 0) { + vs_push(make_fixnum(index)); + FEwrong_type_argument(sLpositive_fixnum, vs_head); + } + switch (type_of(seq)) { + case t_cons: + for (i = index, l = seq; i > 0; --i) + if (endp(l)) + goto E; + else + l = l->c.c_cdr; + if (endp(l)) + goto E; + return(l->c.c_car); + + case t_vector: + case t_bitvector: + if (index >= seq->v.v_fillp) + goto E; + return(aref(seq, index)); + + case t_string: + if (index >= seq->st.st_fillp) + goto E; + return(code_char(seq->ust.ust_self[index])); + + default: + if (seq == Cnil) goto E; + FEwrong_type_argument(sLsequence, seq); + } + +E: + vs_push(make_fixnum(index)); + /* FIXME message should indicate out of range */ + TYPE_ERROR(make_fixnum(index),MMcons(sLinteger,MMcons(make_fixnum(0),MMcons(make_fixnum(length(seq)),Cnil)))); + return(Cnil); +} + +LFD(siLelt_set)() +{ + check_arg(3); + vs_base[0] = elt_set(vs_base[0], fixint(vs_base[1]), vs_base[2]); + vs_popp; + vs_popp; +} + +object +elt_set(seq, index, val) +object seq; +int index; +object val; +{ + int i; + object l; + + if (index < 0) { + vs_push(make_fixnum(index)); + FEwrong_type_argument(sLpositive_fixnum, vs_head); + } + switch (type_of(seq)) { + case t_cons: + for (i = index, l = seq; i > 0; --i) + if (endp(l)) + goto E; + else + l = l->c.c_cdr; + if (endp(l)) + goto E; + return(l->c.c_car = val); + + case t_vector: + case t_bitvector: + if (index >= seq->v.v_fillp) + goto E; + return(aset(seq, index, val)); + + case t_string: + if (index >= seq->st.st_fillp) + goto E; + if (type_of(val) != t_character) + FEwrong_type_argument(sLcharacter, val); + seq->st.st_self[index] = val->ch.ch_code; + return(val); + + default: + if (seq == Cnil) goto E; + FEwrong_type_argument(sLsequence, seq); + } + +E: + vs_push(make_fixnum(index)); + /* FIXME error message should indicate value out of range */ + FEwrong_type_argument(sLpositive_fixnum, vs_head); + return(Cnil); +} + +@(defun subseq (sequence start &optional end &aux x) + int s, e; + int i, j; +@ + s = fixnnint(start); + if (end == Cnil) + e = -1; + else + e = fixnnint(end); + switch (type_of(sequence)) { + case t_symbol: + if (sequence == Cnil) { + if (s > 0) + goto ILLEGAL_START_END; + if (e > 0) + goto ILLEGAL_START_END; + @(return Cnil) + } + FEwrong_type_argument(sLsequence, sequence); + + case t_cons: + if (e >= 0) + if ((e -= s) < 0) + goto ILLEGAL_START_END; + while (s-- > 0) { + if (type_of(sequence) != t_cons) + goto ILLEGAL_START_END; + sequence = sequence->c.c_cdr; + } + if (e < 0) + @(return `copy_list(sequence)`) + for (i = 0; i < e; i++) { + if (type_of(sequence) != t_cons) + goto ILLEGAL_START_END; + vs_check_push(sequence->c.c_car); + sequence = sequence->c.c_cdr; + } + vs_push(Cnil); + while (e-- > 0) + stack_cons(); + x = vs_pop; + @(return x) + + case t_vector: + if (s > sequence->v.v_fillp) + goto ILLEGAL_START_END; + if (e < 0) + e = sequence->v.v_fillp; + else if (e < s || e > sequence->v.v_fillp) + goto ILLEGAL_START_END; + x = alloc_simple_vector(e - s, sequence->v.v_elttype); + array_allocself(x, FALSE,OBJNULL); + switch (sequence->v.v_elttype) { + case aet_object: + case aet_fix: + case aet_sf: + for (i = s, j = 0; i < e; i++, j++) + x->v.v_self[j] = sequence->v.v_self[i]; + break; + + case aet_lf: + for (i = s, j = 0; i < e; i++, j++) + x->lfa.lfa_self[j] = + sequence->lfa.lfa_self[i]; + break; + + case aet_short: + case aet_ushort: + for (i = s, j = 0; i < e; i++, j++) + USHORT_GCL(x, j) = USHORT_GCL(sequence, i); + break; + case aet_char: + case aet_uchar: + for (i = s, j = 0; i < e; i++, j++) + x->st.st_self[j] = sequence->st.st_self[i]; + break; + + } + @(return x) + + + case t_string: + if (s > sequence->st.st_fillp) + goto ILLEGAL_START_END; + if (e < 0) + e = sequence->st.st_fillp; + else if (e < s || e > sequence->st.st_fillp) + goto ILLEGAL_START_END; + {BEGIN_NO_INTERRUPT; + x = alloc_simple_string(e - s); + x->st.st_self = alloc_relblock(e - s); + END_NO_INTERRUPT;} + for (i = s, j = 0; i < e; i++, j++) + x->st.st_self[j] = sequence->st.st_self[i]; + @(return x) + + case t_bitvector: + if (s > sequence->bv.bv_fillp) + goto ILLEGAL_START_END; + if (e < 0) + e = sequence->bv.bv_fillp; + else if (e < s || e > sequence->bv.bv_fillp) + goto ILLEGAL_START_END; + {BEGIN_NO_INTERRUPT; + x = alloc_simple_bitvector(e - s); + x->bv.bv_self = alloc_relblock((e-s+7)/8); + s += sequence->bv.bv_offset; + e += sequence->bv.bv_offset; + for (i = s, j = 0; i < e; i++, j++) + if (sequence->bv.bv_self[i/8]&(0200>>i%8)) + x->bv.bv_self[j/8] + |= 0200>>j%8; + else + x->bv.bv_self[j/8] + &= ~(0200>>j%8); + END_NO_INTERRUPT;} + @(return x) + + default: + FEwrong_type_argument(sLsequence, vs_base[0]); + } + +ILLEGAL_START_END: + FEerror("~S and ~S are illegal as :START and :END~%\ +for the sequence ~S.", 3, start, end, sequence); +@) + +LFD(Lcopy_seq)() +{ + check_arg(1); + vs_push(small_fixnum(0)); + Lsubseq(); +} + +int +length(x) +object x; +{ + int i; + + switch (type_of(x)) { + case t_symbol: + if (x == Cnil) + return(0); + FEwrong_type_argument(sLsequence, x); + return(0); + case t_cons: + +#define cendp(obj) ((type_of(obj)!=t_cons)) + for (i = 0; !cendp(x); i++, x = x->c.c_cdr) + ; + if (x==Cnil) return(i); + FEwrong_type_argument(sLlist,x); + return(0); + + + case t_vector: + case t_string: + case t_bitvector: + return(x->v.v_fillp); + + default: + FEwrong_type_argument(sLsequence, x); + return(0); + } +} + +LFD(Llength)() +{ + check_arg(1); + vs_base[0] = make_fixnum(length(vs_base[0])); +} + +LFD(Lreverse)() +{ + check_arg(1); + vs_base[0] = reverse(vs_base[0]); +} + +object +reverse(seq) +object seq; +{ + object x, y, *v; + int i, j, k; + + switch (type_of(seq)) { + case t_symbol: + if (seq == Cnil) + return(Cnil); + FEwrong_type_argument(sLsequence, seq); + + case t_cons: + v = vs_top; + vs_push(Cnil); + for (x = seq; !endp(x); x = x->c.c_cdr) + *v = make_cons(x->c.c_car, *v); + return(vs_pop); + + case t_vector: + x = seq; + k = x->v.v_fillp; + y = alloc_simple_vector(k, x->v.v_elttype); + vs_push(y); + array_allocself(y, FALSE,OBJNULL); + switch (x->v.v_elttype) { + case aet_object: + case aet_fix: + case aet_sf: + for (j = k - 1, i = 0; j >=0; --j, i++) + y->v.v_self[j] = x->v.v_self[i]; + break; + + case aet_lf: + for (j = k - 1, i = 0; j >=0; --j, i++) + y->lfa.lfa_self[j] = x->lfa.lfa_self[i]; + break; + + case aet_short: + case aet_ushort: + for (j = k - 1, i = 0; j >=0; --j, i++) + USHORT_GCL(y, j) = USHORT_GCL(x, i); + break; + case aet_char: + case aet_uchar: + goto TYPE_STRING; + } + return(vs_pop); + + case t_string: + x = seq; + y = alloc_simple_string(x->st.st_fillp); + TYPE_STRING: + {BEGIN_NO_INTERRUPT; + vs_push(y); + y->st.st_self + = alloc_relblock(x->st.st_fillp); + for (j = x->st.st_fillp - 1, i = 0; j >=0; --j, i++) + y->st.st_self[j] = x->st.st_self[i]; + END_NO_INTERRUPT;} + return(vs_pop); + + case t_bitvector: + x = seq; + {BEGIN_NO_INTERRUPT; + y = alloc_simple_bitvector(x->bv.bv_fillp); + vs_push(y); + y->bv.bv_self + = alloc_relblock((x->bv.bv_fillp+7)/8); + for (j = x->bv.bv_fillp - 1, i = x->bv.bv_offset; + j >=0; + --j, i++) + if (x->bv.bv_self[i/8]&(0200>>i%8)) + y->bv.bv_self[j/8] |= 0200>>j%8; + else + y->bv.bv_self[j/8] &= ~(0200>>j%8); + END_NO_INTERRUPT;} + return(vs_pop); + + default: + FEwrong_type_argument(sLsequence, seq); + return(Cnil); + } +} + +LFD(Lnreverse)() +{ + check_arg(1); + vs_base[0] = nreverse(vs_base[0]); +} + +object +nreverse(seq) +object seq; +{ + object x, y, z; + int i, j, k; + + switch (type_of(seq)) { + case t_symbol: + if (seq == Cnil) + return(Cnil); + FEwrong_type_argument(sLsequence, seq); + + case t_cons: + for (x = Cnil, y = seq; !endp(y->c.c_cdr);) { + z = y; + y = y->c.c_cdr; + z->c.c_cdr = x; + x = z; + } + y->c.c_cdr = x; + return(y); + + case t_vector: + x = seq; + k = x->v.v_fillp; + switch (x->v.v_elttype) { + case aet_object: + case aet_fix: + case aet_sf: + for (i = 0, j = k - 1; i < j; i++, --j) { + y = x->v.v_self[i]; + x->v.v_self[i] = x->v.v_self[j]; + x->v.v_self[j] = y; + } + return(seq); + + case aet_lf: + for (i = 0, j = k - 1; i < j; i++, --j) { + longfloat y; + y = x->lfa.lfa_self[i]; + x->lfa.lfa_self[i] = x->lfa.lfa_self[j]; + x->lfa.lfa_self[j] = y; + } + return(seq); + + case aet_short: + case aet_ushort: + for (i = 0, j = k - 1; i < j; i++, --j) { + unsigned short y; + y = USHORT_GCL(x, i); + USHORT_GCL(x, i) = USHORT_GCL(x, j); + USHORT_GCL(x, y) = y; + } + return(seq); + case aet_char: + case aet_uchar: + goto TYPE_STRING; + } + + case t_string: + x = seq; + TYPE_STRING: + for (i = 0, j = x->st.st_fillp - 1; i < j; i++, --j) { + k = x->st.st_self[i]; + x->st.st_self[i] = x->st.st_self[j]; + x->st.st_self[j] = k; + } + return(seq); + + case t_bitvector: + x = seq; + for (i = x->bv.bv_offset, + j = x->bv.bv_fillp + x->bv.bv_offset - 1; + i < j; + i++, --j) { + k = x->bv.bv_self[i/8]&(0200>>i%8); + if (x->bv.bv_self[j/8]&(0200>>j%8)) + x->bv.bv_self[i/8] + |= 0200>>i%8; + else + x->bv.bv_self[i/8] + &= ~(0200>>i%8); + if (k) + x->bv.bv_self[j/8] + |= 0200>>j%8; + else + x->bv.bv_self[j/8] + &= ~(0200>>j%8); + } + return(seq); + + default: + FEwrong_type_argument(sLsequence, seq); + return(Cnil); + } +} + + +void +gcl_init_sequence_function() +{ + make_function("ELT", Lelt); + make_si_function("ELT-SET", siLelt_set); + make_function("SUBSEQ", Lsubseq); + make_function("COPY-SEQ", Lcopy_seq); + make_function("LENGTH", Llength); + make_function("REVERSE", Lreverse); + make_function("NREVERSE", Lnreverse); +} diff --git a/o/sfasl.c b/o/sfasl.c new file mode 100755 index 0000000..4408b4f --- /dev/null +++ b/o/sfasl.c @@ -0,0 +1,700 @@ +/* +Copyright William Schelter. All rights reserved. +There is a companion file rsym.c which is used to build +a list of the external symbols in a COFF or A.OUT object file, for +example saved_kcl. These are loaded into kcl, and the +linking is done directly inside kcl. This saves a good +deal of time. For example a tiny file foo.o with one definition +can be loaded in .04 seconds. This is much faster than +previously possible in kcl. +The function fasload from unixfasl.c is replaced by the fasload +in this file. +this file is included in unixfasl.c +via #include "../c/sfasl.c" +*/ + + +/* for testing in standalone manner define STAND + You may then compile this file cc -g -DSTAND -DDEBUG -I../hn + a.out /tmp/foo.o /public/gcl/unixport/saved_kcl /public/gcl/unixport/ + will write a /tmp/sfasltest file + which you can use comp to compare with one produced by ld. + */ + +#define IN_SFASL + +/* #ifdef STAND */ +/* #include "config.h" */ +/* #include "gclincl.h" */ +/* #define OUR_ALLOCA alloca */ +/* #include */ +/* #include "mdefs.h" */ + +/* #else */ +#include "gclincl.h" +#include "include.h" +#undef S_DATA +/* #endif */ + + +#if defined(SPECIAL_RSYM) && !defined(USE_DLOPEN) + +#include + +#include "ptable.h" + +static int +node_compare(const void *v1,const void *v2) { + const struct node *a1=v1,*a2=v2; + + return strcmp(a1->string,a2->string); + +} + +static struct node * +find_sym_ptable(const char *name) { + + struct node joe; + joe.string=name; + return bsearch(&joe,c_table.ptable,c_table.length,sizeof(joe),node_compare); + +} + +DEFUN_NEW("FIND-SYM-PTABLE",object,fSfind_sym_ptable,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") { + char c; + struct node *a; + + check_type_string(&x); + + c=x->st.st_self[x->st.st_fillp]; + x->st.st_self[x->st.st_fillp]=0; + a=find_sym_ptable(x->st.st_self); + x->st.st_self[x->st.st_fillp]=c; + + return (object)(a ? a->address : 0); + +} + +#endif + +#ifdef SEPARATE_SFASL_FILE +#include SEPARATE_SFASL_FILE +#else + +#include "ext_sym.h" +struct node * find_sym(); +int node_compare(); +#ifndef _WIN32 +void *malloc(); +void *bsearch(); +#endif + +struct reloc relocation_info; +/* next 5 static after debug */ + +int debug; + +#ifdef DEBUG +#define debug sfasldebug +int sfasldebug=0; +#define dprintf(s,ar) if(debug) { printf(" ( s )",ar) ; fflush(stdout);} +#define STAT + +#else /* end debug */ +#define dprintf(s,ar) +#define STAT static +#endif + +#ifndef MAXPATHLEN +#define MAXPATHLEN 256 +#endif +#define PTABLE_EXTRA 20 + +struct sfasl_info { + struct syment *s_symbol_table; + char *s_start_address; + char *s_start_data; + char *s_start_bss; + char *s_my_string_table; + int s_extra_bss; + char *s_the_start; + +}; +struct sfasl_info *sfaslp; + +#define symbol_table sfaslp->s_symbol_table +#define start_address sfaslp->s_start_address +#define my_string_table sfaslp->s_my_string_table +#define extra_bss sfaslp->s_extra_bss +#define the_start sfaslp->s_the_start + + +#ifndef describe_sym +#define describe_sym(a) +#endif + +#ifdef STAND +#include "rel_stand.c" +#endif + +/* begin reloc_file */ +#include RELOC_FILE + +/* end reloc_file */ +int get_extra_bss ( struct syment *sym_table, int length, int start, int *ptr, int bsssize); +void relocate_symbols ( unsigned int length ); +void set_symbol_address ( struct syment *sym, char *string ); + +int +fasload(faslfile) +object faslfile; +{ long fasl_vector_start; + struct filehdr fileheader; + struct sfasl_info sfasl_info_buf; +#ifdef COFF + struct scnhdr section[10]; + struct aouthdr header; +#endif + int textsize, datasize, bsssize,nsyms; +#if defined ( READ_IN_STRING_TABLE ) || defined ( HPUX ) + int string_size=0; +#endif + + object memory, data; + FILE *fp; + char filename[MAXPATHLEN]; + int i; + int init_address=0; +#ifndef STAND + object *old_vs_base = vs_base; + object *old_vs_top = vs_top; +#endif + sfaslp = &sfasl_info_buf; + + extra_bss=0; +#ifdef STAND + strcpy(filename,faslfile); + fp=fopen(filename,"r"); +#else + coerce_to_filename(faslfile, filename); + faslfile = open_stream(faslfile, smm_input, Cnil, sKerror); + vs_push(faslfile); + fp = faslfile->sm.sm_fp; +#endif + + HEADER_SEEK(fp); + if(!fread((char *)&fileheader, sizeof(struct filehdr), 1, fp)) + FEerror("Could not get the header",0,0); + nsyms = NSYMS(fileheader); +#ifdef COFF + +#ifdef AIX3 + setup_for_aix_load(); +#endif + + fread(&header,1,fileheader.f_opthdr,fp); + + fread(§ion[1],fileheader.f_nscns,sizeof (struct scnhdr),fp); + textsize = section[TEXT_NSCN].s_size; + datasize = section[DATA_NSCN].s_size; + if (strcmp(section[BSS_NSCN].s_name, ".bss") == 0) + bsssize=section[BSS_NSCN].s_size; + else bsssize=section[BSS_NSCN].s_size = 0; +#endif + +#ifdef BSD + textsize=fileheader.a_text; + datasize=fileheader.a_data; + bsssize=fileheader.a_bss; +#endif + symbol_table = + (struct syment *) OUR_ALLOCA(sizeof(struct syment)* + (unsigned int)nsyms); + fseek(fp,(int)( N_SYMOFF(fileheader)), 0); + { + for (i = 0; i < nsyms; i++) + { fread((char *)&symbol_table[i], SYMESZ, 1, fp); + dprintf( symbol table %d , i); + if (debug) describe_sym(i); + dprintf( at %d , &symbol_table[i]); +#ifdef HPUX + symbol_table[i].n_un.n_strx = string_size; + dprintf(string_size %d, string_size); + string_size += symbol_table[i].n_length + 1; + fseek(fp,(int)symbol_table[i].n_length,1); +#endif + } + } +/* +on MP386 +The sizeof(struct syment) = 20, while only SYMESZ =18. So we had to read +one at a time. +fread((char *)symbol_table, SYMESZ*fileheader.f_nsyms,1,fp); +*/ + +#ifdef READ_IN_STRING_TABLE + +my_string_table=READ_IN_STRING_TABLE(fp,string_size); + +#else +#ifdef MUST_SEEK_TO_STROFF + fseek(fp,N_STROFF(fileheader),0); +#endif + {int ii=0; + if (!fread((char *)&ii,sizeof(int),1,fp)) + {FEerror("The string table of this file did not have any length",0, + 0);} + fseek(fp,-4,1); + /* at present the string table is located just after the symbols */ + my_string_table=OUR_ALLOCA((unsigned int)ii); + dprintf( string table leng = %d, ii); + + if(ii!=fread(my_string_table,1,ii,fp)) + FEerror("Could not read whole string table",0,0) ; + } +#endif +#ifdef SEEK_TO_END_OFILE +SEEK_TO_END_OFILE(fp); +#else + while ((i = getc(fp)) == 0) + ; + ungetc(i, fp); +#endif + + fasl_vector_start=ftell(fp); + + if (!((c_table.ptable) && *(c_table.ptable))) + build_symbol_table(); + +/* figure out if there is more bss space needed */ + extra_bss=get_extra_bss(symbol_table,nsyms,datasize+textsize+bsssize, + &init_address,bsssize); + +/* allocate some memory */ +#ifndef STAND + {BEGIN_NO_INTERRUPT; + memory = alloc_object(t_cfdata); + memory->cfd.cfd_self = 0; + memory->cfd.cfd_start = 0; + memory->cfd.cfd_size = datasize+textsize+bsssize + extra_bss; + vs_push(memory); + the_start=start_address= + memory->cfd.cfd_start = + alloc_contblock(memory->cfd.cfd_size); + sfaslp->s_start_data = start_address + textsize; + sfaslp->s_start_bss = start_address + textsize + datasize; + END_NO_INTERRUPT; + } +#else + the_start = start_address + = malloc ( datasize + textsize + bsssize + extra_bss ); + sfaslp->s_start_data = start_address + textsize; + sfaslp->s_start_bss = start_address + textsize + datasize; +#endif + + dprintf( code size %d , datasize+textsize+bsssize + extra_bss); + if (fseek(fp,N_TXTOFF(fileheader) ,0) < 0) + FEerror("file seek error",0,0); + SAFE_FREAD(the_start, textsize + datasize, 1, fp); + dprintf(read into memory text +data %d bytes, textsize + datasize); +/* relocate the actual loaded text */ + + dprintf( the_start %x, the_start); + + /* record which symbols are used */ + +#ifdef SYM_USED + {int j=0; + for(j=1; j< BSS_NSCN ; j++) + { dprintf( relocating section %d \n,j); + if (section[j].s_nreloc) fseek(fp,section[j].s_relptr,0); + for(i=0; i < section[j].s_nreloc; i++) + { struct syment *sym; + fread(&relocation_info, RELSZ, 1, fp); + sym = & symbol_table[relocation_info.r_symndx]; + if (TC_SYMBOL_P(sym)) + SYM_USED(sym) = 1; + }}} +#endif + + + /* this looks up symbols in c.ptable and also adds new externals to + that c.table */ + relocate_symbols(NSYMS(fileheader)); + +#ifdef COFF + {int j=0; + for(j=1; j< BSS_NSCN ; j++) + { dprintf( relocating section %d \n,j); + if (section[j].s_nreloc) fseek(fp,section[j].s_relptr,0); +#ifdef ADJUST_RELOC_START +ADJUST_RELOC_START(j) +#endif + for(i=0; i < section[j].s_nreloc; i++) + /* RELSZ = sizeof(relocation_info) */ + {fread(&relocation_info, RELSZ, 1, fp); + dprintf(relocating %d,i); + relocate();}; + }}; +#endif +#ifdef BSD + fseek(fp,N_RELOFF(fileheader),0); + {int nrel = (fileheader.a_trsize/sizeof(struct reloc)); + for (i=0; i < nrel; i++) + {fread((char *)&relocation_info, sizeof(struct reloc), + 1, fp); + dprintf(relocating %d,i); + relocate(); + } + } +#ifdef N_DRELOFF + fseek (fp, N_DRELOFF(fileheader), 0); +#endif + {int nrel = (fileheader.a_drsize/sizeof(struct reloc)); + the_start += fileheader.a_text; + for (i=0; i < nrel; i++) + + {fread((char *)&relocation_info, sizeof(struct reloc), + 1, fp); + dprintf(relocating %d,i); + relocate(); + } + } +#endif + +/* end of relocation */ + dprintf( END OF RELOCATION \n,0); + dprintf( invoking init function at %x, start_address) + dprintf( textsize is %x,textsize); + dprintf( datasize is %x,datasize); + +/* read in the fasl vector */ + fseek(fp,fasl_vector_start,0); + if (feof(fp)) + {data=0;} + else{ + data = read_fasl_vector(faslfile); + vs_push(data); +#ifdef COFF + dprintf( read fasl now symbols %d , fileheader.f_nsyms); +#endif + } + close_stream(faslfile); + +/* + { + int fd; + + fd = creat ("xsgcl.bits", 0777); + write (fd, memory->cfd.cfd_start, textsize + datasize); + close (fd); + + fd = open ("xsl2.bits", 0); + read (fd, memory->cfd.cfd_start, memory->cfd.cfd_size); + close (fd); + } +*/ + +#ifndef STAND + ALLOCA_FREE(my_string_table); + ALLOCA_FREE(symbol_table); + + +#ifdef CLEAR_CACHE + CLEAR_CACHE; +#endif + call_init(init_address,memory,data,0); + + vs_base = old_vs_base; + vs_top = old_vs_top; + if(symbol_value(sLAload_verboseA)!=Cnil) + printf("start address -T %x ", memory->cfd.cfd_start); + return(memory->cfd.cfd_size); +#endif + {FILE *out; + out=fopen("/tmp/sfasltest","w"); + fwrite((char *)&fileheader, sizeof(struct filehdr), 1, out); + fwrite(start_address,sizeof(char),datasize+textsize,out); + fclose(out);} + printf("\n(start %x)\n",start_address); + +} + +int get_extra_bss(sym_table,length,start,ptr,bsssize) + int length,bsssize; + struct syment *sym_table; + int *ptr; /* store init address offset here */ +{ + int result = start; + +#ifdef AIX3 + int next_bss = start - bsssize; +#endif + + struct syment *end,*sym; + +#ifdef BSD + char tem[SYMNMLEN +1]; +#endif + + end =sym_table + length; + for(sym=sym_table; sym < end; sym++) + { + +#ifdef FIND_INIT + FIND_INIT +#endif + +#ifdef AIX3 + /* we later go through the relocation entries making this 1 + for symbols used */ +#ifdef SYM_USED + if(TC_SYMBOL_P(sym)) + {SYM_USED(sym) = 0;} +#endif + + /* fix up the external refer to _ptrgl to be local ref */ + if (sym->n_scnum == 0 && + strcmp(sym->n_name,"_ptrgl")==0) + {struct syment* s = + get_symbol("._ptrgl",TEXT_NSCN,sym_table,length); + if (s ==0) FEerror("bad glue",0,0); + sym->n_value = next_bss ; + ptrgl_offset = next_bss; + ptrgl_text = s->n_value; + next_bss += 0xc; + sym->n_scnum = DATA_NSCN; + ((union auxent *)(sym+1))->x_csect.x_scnlen = 0xc; + + } + + if(sym->n_scnum != BSS_NSCN) goto NEXT; + if(SYM_EXTERNAL_P(sym)) + {int val=sym->n_value; + struct node joe; + if (val && c_table.ptable) + {struct node *answ; + answ= find_sym(sym,0); + if(answ) + {sym->n_value = answ->address ; + sym->n_scnum = N_UNDEF; + val= ((union auxent *)(sym+1))->x_csect.x_scnlen; + result -= val; + goto NEXT; + }} + } + /* reallocate the bss space */ + if (sym->n_value == 0) + {result += ((union auxent *)(sym+1))->x_csect.x_scnlen;} + sym->n_value = next_bss; + next_bss += ((union auxent *)(sym+1))->x_csect.x_scnlen; + NEXT: + ; + /* end aix3 */ +#endif + + + +#ifdef BSD + tem; /* ignored */ + if(SYM_EXTERNAL_P(sym) && SYM_UNDEF_P(sym)) +#endif +#ifdef COFF + if(0) + /* what we really want is + if (sym->n_scnum==0 && sym->n_sclass == C_EXT + && !(bsearch(..in ptable for this symbol))) + Since this won't allow loading in of a new external array + char foo[10] not ok + static foo[10] ok. + for the moment we give undefined symbol warning.. + Should really go through the symbols, recording the external addr + for ones found in ptable, and for the ones not in ptable + set some flag, and add up the extra_bss required. Then + when you have the new memory chunk in hand, + you could make the pass setting the relative addresses. + for the ones you flagged last time. + */ +#endif + /* external bss so not included in size of bss for file */ + {int val=sym->n_value; + if (val && c_table.ptable + && (0== find_sym(sym,0))) + { sym->n_value=result; + result += val;}} + + sym += NUM_AUX(sym); + + } + return (result-start); +} + + + +/* go through the symbol table changing the addresses of the symbols +to reflect the current cfd_start */ + + +void +relocate_symbols(length) +unsigned int length; +{struct syment *end,*sym; + unsigned int typ; + char *str; + char tem[SYMNMLEN +1]; + tem[SYMNMLEN]=0; + int n_value=(int)start_address; + + end =symbol_table + length; + for(sym=symbol_table; sym < end; sym++) { + typ=NTYPE(sym); +#ifdef BSD +#ifdef N_STAB + if (N_STAB & sym->n_type) continue;/* skip: It is for dbx only */ +#endif + typ=N_SECTION(sym); +/* if(sym->n_type & N_EXT) should add the symbol name, + so it would be accessible by future loads */ +#endif + switch (typ) { +#ifdef BSD + case N_ABS : case N_TEXT: case N_DATA: case N_BSS: +#endif +#ifdef COFF + case TEXT_NSCN : case DATA_NSCN: case BSS_NSCN : +#ifdef _WIN32 + if (typ==DATA_NSCN) + n_value = (int)sfaslp->s_start_data; + if (typ==BSS_NSCN) + n_value = (int)sfaslp->s_start_bss; + if (typ==TEXT_NSCN) + n_value = (int)start_address; +#endif /* _WIN32 */ +#endif /* COFF */ + str=SYM_NAME(sym); + dprintf( for sym %s ,str) + dprintf( new value will be start %x, start_address); + +#ifdef AIX3 + if(N_SECTION(sym) == DATA_NSCN + && NUM_AUX(sym) + && allocate_toc(sym)) + break; +#endif + sym->n_value = n_value; + break; + case N_UNDEF: + str=SYM_NAME(sym); + dprintf( undef symbol %s ,str); + dprintf( symbol diff %d , sym - symbol_table); + describe_sym(sym-symbol_table); + set_symbol_address(sym,str); + describe_sym(sym-symbol_table); + break; + default: +#ifdef COFF + dprintf(am ignoring a scnum %d,(sym->n_scnum)); +#endif + break; + } + sym += NUM_AUX(sym); + } +} + +/* +STEPS: +1) read in the symbol table from the file, +2) go through the symbol table, relocating external entries. +3) for i <=2 go thru the relocation information for this section + relocating the text. +4) done. +*/ + +struct node * +find_sym(sym,name) + struct syment *sym; + char *name; +{ char tem[SYMNMLEN +1]; + tem [SYMNMLEN] = 0; + if (name==0) name = SYM_NAME(sym); + return find_sym_ptable(name);} + +void +set_symbol_address(sym,string) +struct syment *sym; +char *string; +{struct node *answ; + if (c_table.ptable) + { + dprintf(string %s, string); + answ = find_sym(sym,string); + dprintf(answ %d , (answ ? answ->address : -1)); + if(answ) + { +#ifdef COFF +#ifdef _AIX370 + if (NTYPE(sym) == N_UNDEF) + sym->n_value = answ->address; + else +#endif + sym->n_value = answ->address -sym->n_value; + /* for symbols in the local data,text and bss this gets added + on when we add the current value */ +#endif +#ifdef BSD + /* the old value of sym->n_value is the length of the common area + starting at this address */ + sym->n_value = answ->address; +#endif +#ifdef AIX3 + fix_undef_toc_address(answ,sym,string); +#endif + +} + else + { +/* +#ifdef BSD + {char *name; + name=malloc(1+strlen(string)); + strcpy(name,string); + sym->n_value = sym->n_value + (unsigned int) the_start; + add_symbol(name,sym->n_value,NULL); + } +#endif +*/ + fprintf(stdout,"undefined %s symbol",string) + ;fflush(stdout); + + }} + + else{FEerror("symbol table not loaded",0,0);}} + +/* include the machine independent stuff */ +#include "sfasli.c" + + +#ifdef DEBUG +print_name(p) + struct syment *p; +{char tem[10],*name; + name=SYM_NAME(p); + name= (((p)->_n._n_n._n_zeroes == 0) ? + &my_string_table[(p)->_n._n_n._n_offset] : + ((p)->_n._n_name[SYMNMLEN -1] ? + (strncpy(tem,(p)->_n._n_name, + SYMNMLEN), + (char *)tem) : + (p)->_n._n_name )); + + printf("(name:|%s|)",name); + printf("(sclass 0x%x)",p->n_sclass); + printf("(external_p 0x%x)",SYM_EXTERNAL_P(p)); + printf("(n_type 0x%x)",p->n_type); + printf("(n_value 0x%x)",p->n_value); + printf("(numaux 0x%x)\n",NUM_AUX(p)); + fflush(stdout); +} +#endif + +#endif /* SEPARATE_SFASL_FILE */ diff --git a/o/sfaslbfd.c b/o/sfaslbfd.c new file mode 100644 index 0000000..61f5f37 --- /dev/null +++ b/o/sfaslbfd.c @@ -0,0 +1,395 @@ +/* + Copyright (C) 1994 W. Schelter + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +*/ + +/* for testing in standalone manner define STAND + You may then compile this file cc -g -DSTAND -DDEBUG -I../hn + a.out /tmp/foo.o /public/gcl/unixport/saved_kcl /public/gcl/unixport/ + will write a /tmp/sfasltest file + which you can use comp to compare with one produced by ld. + */ + +#if defined(SPECIAL_RSYM) || !defined(HAVE_LIBBFD) +#error Cannot use bfd fasloading with SPECIAL_RSYM/without HAVE_LIBBFD defined +#endif + +#ifdef HAVE_LIBBFD +#ifdef NEED_CONST +#define CONST const +#endif +#define IN_GCC +#include +#include +#endif + + +#include "ext_sym.h" +#include "gclincl.h" +#include + +#if defined(DARWIN) +asection * +bfd_mach_o_craft_fp_branch_islands PARAMS ((bfd *)); + +MY_BFD_BOOLEAN +bfd_mach_o_inject_fp_branch_islands PARAMS ((bfd *, asection *, asymbol **)); +#endif + + +/* align for power of two n */ +static void * +round_up(void *address, unsigned long n) +{ + return (void *)(((unsigned long)address + n -1) & ~(n-1)) ; +} +#define ROUND_UP(a,b) round_up(a,b) + + +static MY_BFD_BOOLEAN +madd_archive_element (struct bfd_link_info * link_info, + bfd *abfd, + const char *name) { + +return MY_BFD_FALSE; + +} + +static MY_BFD_BOOLEAN +mmultiple_definition (struct bfd_link_info * link_info, + const char *name, + bfd *obfd, + asection *osec, + bfd_vma oval, + bfd *nbfd, + asection *nsec, + bfd_vma nval) { + +return MY_BFD_FALSE; + +} + +static MY_BFD_BOOLEAN +mmultiple_common (struct bfd_link_info * link_info, + const char *name, + bfd *obfd, + enum bfd_link_hash_type otype, + bfd_vma osize, + bfd *nbfd, + enum bfd_link_hash_type ntype, + bfd_vma nsize) { + +return MY_BFD_FALSE; + +} + +static MY_BFD_BOOLEAN +madd_to_set (struct bfd_link_info * link_info, + struct bfd_link_hash_entry *entry, + bfd_reloc_code_real_type reloc, + bfd *abfd, asection *sec, bfd_vma value) { + +return MY_BFD_FALSE; + +} + +static MY_BFD_BOOLEAN +mconstructor (struct bfd_link_info * link_info,MY_BFD_BOOLEAN constructor, + const char *name, bfd *abfd, asection *sec, + bfd_vma value) { + +return MY_BFD_FALSE; + +} + +static MY_BFD_BOOLEAN +mwarning (struct bfd_link_info * link_info, + const char *warning, const char *symbol, + bfd *abfd, asection *section, + bfd_vma address) { + +return MY_BFD_FALSE; + +} + +static MY_BFD_BOOLEAN +mundefined_symbol (struct bfd_link_info * link_info, + const char *name, bfd *abfd, + asection *section, + bfd_vma address, + MY_BFD_BOOLEAN fatal) { + + printf("%s is undefined\n",name); + return MY_BFD_FALSE; +} + +static MY_BFD_BOOLEAN +mreloc_overflow (struct bfd_link_info * link_info,struct bfd_link_hash_entry *entry, + const char *name, + const char *reloc_name, bfd_vma addend, + bfd *abfd, asection *section, + bfd_vma address) { + + printf("reloc for %s is overflowing\n",name); + return MY_BFD_FALSE; + +} + +static MY_BFD_BOOLEAN +mreloc_dangerous (struct bfd_link_info * link_info, + const char *message, + bfd *abfd, asection *section, + bfd_vma address) { + + printf("reloc is dangerous %s\n",message); + return MY_BFD_FALSE; + +} + +static MY_BFD_BOOLEAN +munattached_reloc (struct bfd_link_info * link_info, + const char *name, + bfd *abfd, asection *section, + bfd_vma address) { + +return MY_BFD_FALSE; + +} + +static MY_BFD_BOOLEAN +mnotice (struct bfd_link_info * link_info, const char *name, + bfd *abfd, asection *section, bfd_vma address) { + +return MY_BFD_FALSE; + +} + +static bfd *bself; + + +int +fasload(object faslfile) { + + object data; + char filename[256]; + int init_address=-1; + object memory; + int max_align=0; + void *current; + unsigned long curr_size; + object *old_vs_base=vs_base; + object *old_vs_top=vs_top; + static int nbfd; + bfd *b; + bfd_error_type myerr; + unsigned u,v; + asymbol **q; + asection *s; + void * the_start,*start_address,*m; + static union lispunion dum; + static struct bfd_link_callbacks link_callbacks; + static struct bfd_link_order link_order; + char entry_name[7]="_init_",*entry_name_ptr; +#if defined(DARWIN) + asection *bi; +#endif + + if (!nbfd) { + + nbfd=1; + + set_type_of(&dum,t_stream); + dum.sm.sm_mode=smm_input; + dum.sm.sm_object0=sLstring_char; + + link_callbacks.add_archive_element=madd_archive_element; + link_callbacks.multiple_definition=mmultiple_definition; + link_callbacks.multiple_common=mmultiple_common; + link_callbacks.add_to_set=madd_to_set; + link_callbacks.constructor=mconstructor; + link_callbacks.warning=mwarning; + link_callbacks.undefined_symbol=mundefined_symbol; + link_callbacks.reloc_overflow=mreloc_overflow; + link_callbacks.reloc_dangerous=mreloc_dangerous; + link_callbacks.unattached_reloc=munattached_reloc; + link_callbacks.notice=mnotice; + link_info.callbacks=&link_callbacks; + + link_order.type=bfd_indirect_link_order; + + } + + coerce_to_filename(faslfile, filename); + + if (!(b=bfd_openr(filename,0))) + FEerror("Cannot open bfd",0); + if ((myerr=bfd_get_error()) && myerr!=3) + FEerror("Unknown bfd error code on openr",0); + if (!bfd_check_format(b,bfd_object)) + FEerror("Unknown bfd format",0); + if ((myerr=bfd_get_error()) && myerr!=3) + FEerror("Unknown bfd error code on check_format",0); + bfd_set_error(0); + +#if defined(DARWIN) + if ((bi = bfd_mach_o_craft_fp_branch_islands (b)) == NULL) + FEerror ("Could not craft fp register preservation stubs",0); +#endif + + current=NULL; + for (s=b->sections;s;s=s->next) { + + s->owner=b; + s->output_section=(s->flags & SEC_ALLOC) ? s : b->sections; + s->output_offset=0; + + if (!(s->flags & SEC_ALLOC)) + continue; + + if (max_alignalignment_power) + max_align=s->alignment_power; + + current=round_up(current,1<alignment_power); + + current+=bfd_section_size(b,s); + + } + curr_size=(unsigned long)current; + max_align=1<cfd.cfd_self = 0; + memory->cfd.cfd_start = 0; + memory->cfd.cfd_size = curr_size + (max_align > sizeof(char *) ? max_align :0); + + memory->cfd.cfd_start=alloc_contblock(memory->cfd.cfd_size); + the_start=start_address=memory->cfd.cfd_start; + + start_address = ROUND_UP(start_address,max_align); + memory->cfd.cfd_size = memory->cfd.cfd_size - (start_address - the_start); + memory->cfd.cfd_start = (void *)start_address; + + for (m=start_address,s=b->sections;s;s=s->next) { + + if (!(s->flags & SEC_ALLOC)) + continue; + + m=round_up(m,1<alignment_power); + s->output_section->vma=(unsigned long)m; + m+=bfd_section_size(b,s); + + } + + if ((u=bfd_get_symtab_upper_bound(b))<0) + FEerror("Cannot get symtab uppoer bound",0); + q=(asymbol **)alloca(u); + if ((v=bfd_canonicalize_symtab(b,q))<0) + FEerror("cannot canonicalize symtab",0); + + *entry_name=bfd_get_symbol_leading_char(b); + entry_name_ptr=*entry_name ? entry_name : entry_name+1; + + for (u=0;uname,5)) { + init_address=q[u]->value+(q[u]->section->output_section->vma-(unsigned long)memory->cfd.cfd_start); + continue; + } + + if (!(h=bfd_link_hash_lookup(link_info.hash,q[u]->name,MY_BFD_FALSE,MY_BFD_FALSE,MY_BFD_TRUE))) + continue; + + if (h->type!=bfd_link_hash_defined) + FEerror("Undefined symbol ~S",1,make_simple_string(q[u]->name)); + + if (h->u.def.section) { + q[u]->value=h->u.def.value+h->u.def.section->vma; + q[u]->flags|=BSF_WEAK; + } else + FEerror("Symbol without section",0); + + } + +#if defined(DARWIN) + if (!bfd_mach_o_inject_fp_branch_islands (b, bi, q)) + FEerror ("Could not inject fp register preservation stubs",0); +#endif + +#ifndef HAVE_ALLOCA +#error Cannot use bfd relocations without alloca at present +#endif + /* We have to do this to avoid the possibility that + bfd_get_relocated_section_contents will run GBC via its alloc, thereby + write protecting the pages of memory->cfd again and causing bfd reads of + the section contents to return an error code after a 'stratified' segfault */ + { + void *v=alloca(memory->cfd.cfd_size); + + if (!v) + FEerror("Cannot alloca for bfd",0); + + for (s=b->sections;s;s=s->next) { + + unsigned long ss=bfd_section_size(b,s); + + if (!(s->flags & SEC_LOAD)) + continue; + + link_order.u.indirect.section=s; + + if (!bfd_get_relocated_section_contents(b,&link_info,&link_order, + v,0,q)) + FEerror("Cannot get relocated section contents\n",0); + + memcpy((void *)(unsigned long)s->output_section->vma,v,ss); + + } + + } + + dum.sm.sm_object1=faslfile; + dum.sm.sm_fp=b->iostream; + + /* Find a way of doing this in bfd -- use this for now. Unfortunately, + we're not always at file end after reading in the sections -- CM */ + SEEK_TO_END_OFILE(dum.sm.sm_fp); + + if (feof(dum.sm.sm_fp)) + data=0; + else + data = read_fasl_vector(&dum); + + bfd_close(b); + +#ifdef CLEAR_CACHE + CLEAR_CACHE; +#endif + + call_init(init_address,memory,data,0); + + vs_base=old_vs_base; + vs_top=old_vs_top; + + if(symbol_value(sLAload_verboseA)!=Cnil) + printf("start address -T %p ",memory->cfd.cfd_start); + + return memory->cfd.cfd_size; + + } + +#include "sfasli.c" + diff --git a/o/sfaslcoff.c b/o/sfaslcoff.c new file mode 100644 index 0000000..9cbbcb0 --- /dev/null +++ b/o/sfaslcoff.c @@ -0,0 +1,447 @@ +#include + +#include "windows.h" + +typedef unsigned char uc; +typedef unsigned short us; +typedef unsigned long ul; + +struct filehdr { + us f_magic; /* magic number */ + us f_nscns; /* number of sections */ + ul f_timdat; /* time & date stamp */ + ul f_ptrsym; /* file pointer to symtab */ + ul f_symnum; /* number of symtab entries */ + us f_opthdr; /* sizeof(optional hdr) */ + us f_flags; /* flags */ +}; + +struct opthdr { + us h_magic; + uc h_mlv; + uc h_nlv; + ul h_tsize; + ul h_dsize; + ul h_bsize; + ul h_maddr; + ul h_tbase; + ul h_dbase; /* = high 32 bits of ibase for PE32+, magic 0x20b*/ + ul h_ibase; +}; + +struct scnhdr { + uc s_name[8]; /* section name */ + ul s_paddr; /* physical address, aliased s_nlib */ + ul s_vaddr; /* virtual address */ + ul s_size; /* section size */ + ul s_scnptr; /* file ptr to raw data for section */ + ul s_relptr; /* file ptr to relocation */ + ul s_lnnoptr; /* file ptr to line numbers */ + us s_nreloc; /* number of relocation entries */ + us s_nlnno; /* number of line number entries*/ + ul s_flags; /* flags */ +}; +#define SEC_CODE 0x20 +#define SEC_DATA 0x40 +#define SEC_BSS 0x80 +#define ALLOC_SEC(sec) (sec->s_flags&(SEC_CODE|SEC_DATA|SEC_BSS)) +#define LOAD_SEC(sec) (sec->s_flags&(SEC_CODE|SEC_DATA)) + +#define STOP(s_,op_) ({char *_s=s_,_c=_s[8];_s[8]=0;op_;_s[8]=_c;}) + +struct reloc { + union { + ul r_vaddr; + ul r_count; /* Set to the real count when IMAGE_SCN_LNK_NRELOC_OVFL is set */ + } r; + ul r_symndx; + us r_type; +} __attribute__ ((packed)); +#define R_ABS 0x0000 /* absolute, no relocation is necessary */ +#define R_DIR32 0x0006 /* Direct 32-bit reference to the symbols virtual address */ +#define R_SECREL32 0x000B /* Currently ignored, used only for debugging strings FIXME */ +#define R_PCRLONG 0x0014 /* 32-bit reference pc relative to the symbols virtual address */ + +struct syment { + union { + char n_name[8]; + struct { + int n_zeroes; + int n_offset; + } n; + } n; + ul n_value; + short n_scnum; + us n_type; + uc n_sclass; + uc n_numaux; +} __attribute__ ((packed)); + + +static int +ovchk(ul v,ul m) { + + m|=m>>1; + v&=m; + + return (!v || v==m); + +} + +static int +store_val(ul *w,ul m,ul v) { + + massert(ovchk(v,~m)); + *w=(v&m)|(*w&~m); + + return 0; + +} + +static int +add_val(ul *w,ul m,ul v) { + + return store_val(w,m,v+(*w&m)); + +} + + +static void +relocate(struct scnhdr *sec,struct reloc *rel,struct syment *sym) { + + ul *where=(void *)(sec->s_paddr+rel->r.r_vaddr); + + switch(rel->r_type) { + + case R_ABS: + case R_SECREL32: + break; + + case R_DIR32: + add_val(where,~0L,sym->n_value); + /* *where+=sym->n_value; */ + break; + + case R_PCRLONG: + store_val(where,~0L,sym->n_value-(ul)(where+1)); + /* *where=sym->n_value-(ul)(where+1); */ + break; + + default: + fprintf(stdout, "%d: unsupported relocation type.", rel->r_type); + FEerror("The relocation type was unknown",0); + + } + +} + + +static void +find_init_address(struct syment *sym,struct syment *sye,ul *ptr,char *st1) { + + for(;symn_scnum == 1 && sym->n_value) + if (!strncmp(sym->n.n.n_zeroes ? sym->n.n_name : st1+sym->n.n.n_offset,"_init_",6)) + *ptr=sym->n_value; + + sym += (sym)->n_numaux; + + } + +} + +static void +relocate_symbols(struct syment *sym,struct syment *sye,struct scnhdr *sec1,char *st1) { + + struct node *answ; + + for (;symn_scnum>0) + sym->n_value = sec1[sym->n_scnum-1].s_paddr; + + else if (!sym->n_scnum) { + + char c=0,*s; + + if (sym->n.n.n_zeroes) { + c=sym->n.n_name[8]; + sym->n.n_name[8]=0; + s=sym->n.n_name; + } else + s=st1+sym->n.n.n_offset; + + if ((answ=find_sym_ptable(s))) + sym->n_value=answ->address; + else + massert(!fprintf(stderr,"Unrelocated non-local symbol: %s\n",s)); + + if (c) + sym->n.n_name[8]=c; + + } + + sym += (sym)->n_numaux; + + } + +} + +static object +load_memory(struct scnhdr *sec1,struct scnhdr *sece,void *st) { + + object memory; + struct scnhdr *sec; + ul sz; + + BEGIN_NO_INTERRUPT; + + for (sec=sec1,sz=0;secs_size,sec++) + if (ALLOC_SEC(sec)) + sec->s_paddr=sz; + + memory = alloc_object(t_cfdata); + memory->cfd.cfd_size=sz; + memory->cfd.cfd_self=0; + memory->cfd.cfd_start=0; + prefer_low_mem_contblock=TRUE; + memory->cfd.cfd_start=alloc_contblock(sz); + prefer_low_mem_contblock=FALSE; + + for (sec=sec1;secs_paddr+=(ul)memory->cfd.cfd_start; + if (LOAD_SEC(sec)) + memcpy((void *)sec->s_paddr,st+sec->s_scnptr,sec->s_size); + } + + END_NO_INTERRUPT; + + return memory; + +} + +static int +load_self_symbols() { + + FILE *f; + void *v1,*v,*ve; + struct filehdr *fhp; + struct syment *sy1,*sye,*sym; + struct scnhdr *sec1,*sec,*sece; + struct opthdr *h; + struct node *a; + char *st1,*st; + ul ns,sl,jj; + + massert(f=fopen(kcl_self,"r")); + massert(v1=get_mmap(f,&ve)); + + v=v1+*(ul *)(v1+0x3c); + massert(!memcmp("PE\0\0",v,4)); + + fhp=v+4; + h=(void *)(fhp+1); + massert(h->h_magic==0x10b || h->h_magic==0x20b); + massert(h->h_magic==0x10b || !h->h_dbase); /*We cannot handle a 64bit load address*/ + + sec1=(void *)(fhp+1)+fhp->f_opthdr; + sece=sec1+fhp->f_nscns; + + sy1=v1+fhp->f_ptrsym; + sye=sy1+fhp->f_symnum; + + st1=(char *)sye; + + for (ns=sl=0,sym=sy1;symn_sclass!=2 || sym->n_scnum<1) + continue; + + ns++; + + if (sym->n.n.n_zeroes) + STOP(sym->n.n_name,sl+=strlen(sym->n.n_name)+1); + else + sl+=strlen(st1+sym->n.n.n_offset)+1; + + sym+=sym->n_numaux; + + } + + c_table.alloc_length=c_table.length=ns; + assert(c_table.ptable=malloc(sizeof(*c_table.ptable)*c_table.alloc_length)); + assert(st=malloc(sl)); + + for (a=c_table.ptable,sym=sy1;symn_sclass!=2 || sym->n_scnum<1) + continue; + + if (sym->n.n.n_zeroes) + STOP(sym->n.n_name,strcpy(st,sym->n.n_name)); + else + strcpy(st,st1+sym->n.n.n_offset); + + sec=sec1+sym->n_scnum-1; + jj=sym->n_value+sec->s_vaddr+h->h_ibase; + +#ifdef FIX_ADDRESS + FIX_ADDRESS(jj); +#endif + + a->address=jj; + a->string=st; + + a++; + st+=strlen(st)+1; + sym+=sym->n_numaux; + + } + + qsort(c_table.ptable,c_table.length,sizeof(*c_table.ptable),node_compare); + + massert(!un_mmap(v1,ve)); + massert(!fclose(f)); + + return 0; + +} + +int +seek_to_end_ofile(FILE *fp) { + + void *st,*ve; + struct filehdr *fhp; + struct scnhdr *sec1,*sece; + struct syment *sy1,*sye; + const char *st1,*ste; + int i; + + massert(st=get_mmap(fp,&ve)); + + fhp=st; + sec1=(void *)(fhp+1)+fhp->f_opthdr; + sece=sec1+fhp->f_nscns; + sy1=st+fhp->f_ptrsym; + sye=sy1+fhp->f_symnum; + st1=(void *)sye; + ste=st1+*(ul *)st1; + + fseek(fp,(void *)ste-st,0); + while (!(i=getc(fp))); + ungetc(i, fp); + + massert(!un_mmap(st,ve)); + + return 0; + +} + +object +find_init_string(const char *s) { + + FILE *f; + struct filehdr *fhp; + struct scnhdr *sec1,*sece; + struct syment *sy1,*sym,*sye; + char *st1,*ste; + void *st,*est; + object o; + + massert(f=fopen(s,"r")); + massert(st=get_mmap(f,&est)); + + fhp=st; + sec1=(void *)(fhp+1)+fhp->f_opthdr; + sece=sec1+fhp->f_nscns; + sy1=st+fhp->f_ptrsym; + sye=sy1+fhp->f_symnum; + st1=(void *)sye; + ste=st1+*(ul *)st1; + + for (sym=sy1;symn.n.n_zeroes ? sym->n.n_name : st1+sym->n.n.n_offset; + + if (!strncmp(s,"_init_",6)) { + if (sym->n.n.n_zeroes) + STOP((char *)s,o=make_simple_string(s)); + else + o=make_simple_string(s); + massert(!un_mmap(st,&est)); + massert(!fclose(f)); + return o; + } + + } + + massert(!un_mmap(st,&est)); + massert(!fclose(f)); + massert(!"init not found"); + + return NULL; + +} + +int +fasload(object faslfile) { + + struct filehdr *fhp; + struct scnhdr *sec1,*sec,*sece; + struct syment *sy1,*sye; + struct reloc *rel,*rele; + object memory, data; + FILE *fp; + char filename[MAXPATHLEN],*st1,*ste; + int i; + ul init_address=0; + void *st,*est; + + coerce_to_filename(faslfile, filename); + faslfile = open_stream(faslfile, smm_input, Cnil, sKerror); + fp = faslfile->sm.sm_fp; + + massert(st=get_mmap(fp,&est)); + + fhp=st; + sec1=(void *)(fhp+1)+fhp->f_opthdr; + sece=sec1+fhp->f_nscns; + sy1=st+fhp->f_ptrsym; + sye=sy1+fhp->f_symnum; + st1=(void *)sye; + ste=st1+*(ul *)st1; + + find_init_address(sy1,sye,&init_address,st1); + + memory=load_memory(sec1,sece,st); + + relocate_symbols(sy1,sye,sec1,st1); + + for (sec=sec1;secs_flags&0xe0) + for (rel=st+sec->s_relptr,rele=rel+(sec->s_flags&0x1000000 ? rel->r.r_count : sec->s_nreloc);relr_symndx); + + fseek(fp,(void *)ste-st,0); + while ((i = getc(fp)) == 0); + ungetc(i, fp); + data = read_fasl_vector(faslfile); + + massert(!un_mmap(st,est)); + close_stream(faslfile); + +#ifdef CLEAR_CACHE + CLEAR_CACHE; +#endif + + call_init(init_address,memory,data,0); + + if(symbol_value(sLAload_verboseA)!=Cnil) + printf("start address -T %p ", memory->cfd.cfd_start); + + return(memory->cfd.cfd_size); + +} + +#include "sfasli.c" diff --git a/o/sfaslelf.c b/o/sfaslelf.c new file mode 100755 index 0000000..247ebdf --- /dev/null +++ b/o/sfaslelf.c @@ -0,0 +1,598 @@ +/* + Copyright (C) 1994 W. Schelter + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +*/ + + +#include +#include +#include +#include +#include +#include +#include +#include + +#include "gclincl.h" + + +#if SIZEOF_LONG == 4 +#define Elfw 32 +#else +#define Elfw 64 +#endif + +#define Elf Mjoin(Elf,Elfw) +#define ELF Mjoin(ELF,Elfw) +#define Ehdr Mjoin(Elf,_Ehdr) +#define Shdr Mjoin(Elf,_Shdr) +#define Sym Mjoin(Elf,_Sym) +#define Rel Mjoin(Elf,_Rel) +#define Rela Mjoin(Elf,_Rela) +#define Word Elf32_Word + +#define ELF_R_SYM(a) Mjoin(ELF,_R_SYM)(a) +#define ELF_R_TYPE(a) Mjoin(ELF,_R_TYPE)(a) +#define ELF_R_INFO(a,b) Mjoin(ELF,_R_INFO)(a,b) +#define ELF_ST_BIND(a) Mjoin(ELF,_ST_BIND)(a) +#define ELF_ST_TYPE(a) Mjoin(ELF,_ST_TYPE)(a) +#define ELF_ST_INFO(a,b) Mjoin(ELF,_ST_INFO)(a,b) +#define ELF_ST_VISIBILITY(a) Mjoin(ELF,_ST_VISIBILITY)(a) + + +#define ulmax(a_,b_) ({ul _a=a_,_b=b_;_a<_b ? _b : _a;}) +#define ALLOC_SEC(sec) (sec->sh_flags&SHF_ALLOC && (sec->sh_type==SHT_PROGBITS || sec->sh_type==SHT_NOBITS)) +#define LOAD_SEC(sec) (sec->sh_flags&SHF_ALLOC && sec->sh_type==SHT_PROGBITS) +#define LOAD_SYM(sym) ({ul _b=ELF_ST_BIND(sym->st_info),_t=ELF_ST_TYPE(sym->st_info); \ + sym->st_value && (_b==STB_GLOBAL || _b==STB_WEAK || (_t>=STT_LOPROC && _t<=STT_HIPROC));}) + +#define MASK(n) (~(~0L << (n))) + + + +typedef unsigned long ul; + + + +static Shdr * +get_section(char *s,Shdr *sec,Shdr *sece,const char *sn) { + + for (;secsh_name,s);sec++); + return sec>1; + v&=m; + + return (!v || v==m); + +} + +static int +ovchku(ul v,ul m) { + + return !(v&=m); + +} + +static char *init_section_name=".text"; + +#ifdef SPECIAL_RELOC_H +#include SPECIAL_RELOC_H +#endif + +int +store_val(ul *w,ul m,ul v) { + + *w=(v&m)|(*w&~m); + + return 0; + +} + +int +store_vals(ul *w,ul m,ul v) { + + massert(ovchks(v,~m)); + return store_val(w,m,v); + +} + +int +store_valu(ul *w,ul m,ul v) { + + massert(ovchku(v,~m)); + return store_val(w,m,v); + +} + + +int +add_val(ul *w,ul m,ul v) { + + return store_val(w,m,v+(*w&m)); + +} + +int +add_valu(ul *w,ul m,ul v) { + + return store_valu(w,m,v+(*w&m)); + +} + +int +add_vals(ul *w,ul m,ul v) { + + ul l=*w&m,mm; + + mm=~m; + mm|=mm>>1; + if (l&mm) l|=mm; + + return store_val(w,m,v+l); + +} + +int +add_valsc(ul *w,ul m,ul v) { + + ul l=*w&m,mm; + + mm=~m; + mm|=mm>>1; + if (l&mm) l|=mm; + + return store_vals(w,m,v+l); + +} + +static void +relocate(Sym *sym1,void *v,ul a,ul start,ul *got,ul *gote) { + + Rel *r=v; + Sym *sym; + ul *where,p,s,tp; + + where=(void *)start+r->r_offset; + p=(ul)where; + + sym=sym1+ELF_R_SYM(r->r_info); + s=sym->st_value; + + switch((tp=ELF_R_TYPE(r->r_info))) { + +#include RELOC_H + + default: + fprintf(stderr, "Unknown reloc type %lu\n", tp); + massert(tp&~tp); + + } + +} + +static int +find_init_address(Sym *sym,Sym *syme,Shdr *sec1,Shdr *sece, + const char *sn,const char *st1,ul *init) { + + Shdr *sec; + + for (;symst_shndx; + + if (sec=sece) + continue; + + if (strcmp(sn+sec->sh_name,init_section_name)) + continue; + + if (memcmp("init_",st1+sym->st_name,4)) + continue; + + *init=sym->st_value; + + return 0; + + } + + return -1; + +} + +static int +relocate_symbols(Sym *sym,Sym *syme,Shdr *sec1,Shdr *sece,const char *st1) { + + Shdr *sec; + struct node *a; + + for (;symst_shndx; + + if (secst_value+=sec->sh_addr; + + else if ((a=find_sym_ptable(st1+sym->st_name))) + sym->st_value=a->address; + + else if (ELF_ST_BIND(sym->st_info)!=STB_LOCAL) + massert(!fprintf(stderr,"Unrelocated non-local symbol: %s\n",st1+sym->st_name)); + + } + + return 0; + +} + +static object +load_memory(Shdr *sec1,Shdr *sece,void *v1,ul **got,ul **gote) { + + object memory; + Shdr *sec; + ul gsz,sz,a,ma; + + BEGIN_NO_INTERRUPT; + + for (sec=sec1,ma=sz=0;secsh_addralign; + ma=ma ? ma : a; + sz=(sz+a-1)&~(a-1); + sec->sh_addr=sz; + sz+=sec->sh_size; + + } + + ma=ma>sizeof(struct contblock) ? ma-1 : 0; + sz+=ma; + + gsz=0; + if (**got) { + gsz=(**got+1)*sizeof(**got)-1; + sz+=gsz; + } + + memory=alloc_object(t_cfdata); + memory->cfd.cfd_size=sz; + memory->cfd.cfd_self=0; + memory->cfd.cfd_start=0; + prefer_low_mem_contblock=TRUE; + memory->cfd.cfd_start=alloc_contblock(sz); + prefer_low_mem_contblock=FALSE; + + a=(ul)memory->cfd.cfd_start; + a=(a+ma)&~ma; + for (sec=sec1;secsh_addr+=a; + if (LOAD_SEC(sec)) + memcpy((void *)sec->sh_addr,v1+sec->sh_offset,sec->sh_size); + } + + if (**got) { + sz=**got; + *got=(void *)memory->cfd.cfd_start+memory->cfd.cfd_size-gsz; + gsz=sizeof(**got)-1; + *got=(void *)(((ul)*got+gsz)&~gsz); + *gote=*got+sz; + } + + END_NO_INTERRUPT; + + return memory; + +} + + +static int +relocate_code(void *v1,Shdr *sec1,Shdr *sece,Sym *sym1,ul *got,ul *gote) { + + Shdr *jsec,*sec; + void *v,*ve; + Rela *ra; + + for (sec=sec1;secsh_info; + + if (jsec=sece) + continue; + if (!ALLOC_SEC(jsec)) + continue; + + if (sec->sh_type!=SHT_REL && sec->sh_type!=SHT_RELA) + continue; + + for (v=v1+sec->sh_offset,ve=v+sec->sh_size,ra=v;vsh_entsize,ra=v) + relocate(sym1,ra,sec->sh_type==SHT_RELA ? ra->r_addend : 0,jsec->sh_addr,got,gote); + + } + + return 0; + +} + +static int +parse_map(void *v1,Shdr **sec1,Shdr **sece, + char **sn,Sym **sym1,Sym **syme,char **st1,ul *end, + Sym **dsym1,Sym **dsyme,char **dst1) { + + Ehdr *fhp; + Shdr *sec; + + fhp=v1; + *sec1=v1+fhp->e_shoff; + *sece=*sec1+fhp->e_shnum; + + *sn=v1+(*sec1)[fhp->e_shstrndx].sh_offset; + + massert(sec=get_section(".symtab",*sec1,*sece,*sn)); + *sym1=v1+sec->sh_offset; + *syme=*sym1+sec->sh_size/sec->sh_entsize; + + massert(sec=get_section(".strtab",*sec1,*sece,*sn)); + *st1=v1+sec->sh_offset; + + *dsym1=*dsyme=NULL; + *dst1=NULL; + if ((sec=get_section(".dynsym",*sec1,*sece,*sn))) { + *dsym1=v1+sec->sh_offset; + *dsyme=*dsym1+sec->sh_size/sec->sh_entsize; + massert(sec=get_section(".dynstr",*sec1,*sece,*sn)); + *dst1=v1+sec->sh_offset; + } + + for (*end=fhp->e_shoff+fhp->e_shnum*fhp->e_shentsize,sec=*sec1;sec<*sece;sec++) + *end=ulmax(*end,sec->sh_offset+sec->sh_size); + + return 0; + +} + + +static int +set_symbol_stubs(void *v,Shdr *sec1,Shdr *sece,const char *sn, + Sym *ds1,Sym *dse,const char *dst1, + Sym *sym1,Sym *syme,const char *st1) { + + Shdr *sec,*psec; + Rel *r; + ul np,ps,p; + void *ve; + +#ifdef SPECIAL_RELOC_H + massert(!find_special_params(v,sec1,sece,sn,st1,ds1,dse,sym1,syme)); +#endif + + if (!(psec=get_section(".plt",sec1,sece,sn))) + return 0; + + massert((sec=get_section( ".rel.plt",sec1,sece,sn)) || + (sec=get_section(".rela.plt",sec1,sece,sn))); + + np=sec->sh_size/sec->sh_entsize; + ps=psec->sh_size/np; + + v+=sec->sh_offset; + ve=v+np*sec->sh_entsize; + + p=psec->sh_addr+psec->sh_size%np; + + for (r=v;vsh_entsize,p+=ps,r=v) + if (!ds1[ELF_R_SYM(r->r_info)].st_value) + ds1[ELF_R_SYM(r->r_info)].st_value=p; + + + return 0; + +} + +static int +calc_space(ul *ns,ul *sl,Sym *sym1,Sym *syme,const char *st1,Sym *d1,Sym *de,const char *ds1) { + + Sym *sym,*d; + + for (sym=sym1;symst_name,ds1+d->st_name);d++); + if (dst_name)+1; + + } + + return 0; + +} + +static int +load_ptable(struct node **a,char **s,Sym *sym1,Sym *syme,const char *st1, + Sym *d1,Sym *de,const char *ds1) { + + Sym *sym,*d; + + for (sym=sym1;symst_name,ds1+d->st_name);d++); + if (daddress=sym->st_value; + (*a)->string=(*s); + strcpy((*s),st1+sym->st_name); + +#ifdef FIX_HIDDEN_SYMBOLS + FIX_HIDDEN_SYMBOLS(st1,a,sym1,sym,syme); +#endif + + (*a)++; + (*s)+=strlen(*s)+1; + + } + + return 0; + +} + + +static int +load_self_symbols() { + + FILE *f; + char *sn,*st1,*s,*dst1; + Shdr *sec1,*sece; + Sym *sym1,*syme,*dsym1,*dsyme; + void *v1,*ve; + ul ns,sl,end; + struct node *a; + + massert(f=fopen(kcl_self,"r")); + massert(v1=get_mmap(f,&ve)); + + massert(!parse_map(v1,&sec1,&sece,&sn,&sym1,&syme,&st1,&end,&dsym1,&dsyme,&dst1)); + +#ifndef STATIC_LINKING + massert(!set_symbol_stubs(v1,sec1,sece,sn,dsym1,dsyme,dst1,sym1,syme,st1)); +#endif + + ns=sl=0; + massert(!calc_space(&ns,&sl,dsym1,dsyme,dst1,NULL,NULL,NULL)); + massert(!calc_space(&ns,&sl,sym1,syme,st1,dsym1,dsyme,dst1)); + + c_table.alloc_length=c_table.length=ns; + massert(c_table.ptable=malloc(sizeof(*c_table.ptable)*c_table.alloc_length)); + massert(s=malloc(sl)); + + a=c_table.ptable; + massert(!load_ptable(&a,&s,dsym1,dsyme,dst1,NULL,NULL,NULL)); + massert(!load_ptable(&a,&s,sym1,syme,st1,dsym1,dsyme,dst1)); + + qsort(c_table.ptable,c_table.length,sizeof(*c_table.ptable),node_compare); + + massert(!un_mmap(v1,ve)); + massert(!fclose(f)); + + return 0; + +} + +int +seek_to_end_ofile(FILE *fp) { + + void *v1,*ve; + Shdr *sec1,*sece; + Sym *sym1,*syme,*dsym1,*dsyme; + char *sn,*st1,*dst1; + ul end; + + massert(v1=get_mmap(fp,&ve)); + + massert(!parse_map(v1,&sec1,&sece,&sn,&sym1,&syme,&st1,&end,&dsym1,&dsyme,&dst1)); + + massert(!fseek(fp,end,SEEK_SET)); + + massert(!un_mmap(v1,ve)); + + return 0; + +} + +static int +clear_protect_memory(object memory) { + + void *p,*pe; + + p=(void *)((unsigned long)memory->cfd.cfd_start & ~(PAGESIZE-1)); + pe=(void *)((unsigned long)(memory->cfd.cfd_start+memory->cfd.cfd_size + PAGESIZE-1) & ~(PAGESIZE-1)); + + return gcl_mprotect(p,pe-p,PROT_READ|PROT_WRITE|PROT_EXEC); + +} + +int +fasload(object faslfile) { + + FILE *fp; + char filename[256],*sn,*st1,*dst1; + ul init_address=0,end,gs=0,*got=&gs,*gote=got+1; + object memory,data; + Shdr *sec1,*sece; + Sym *sym1,*syme,*dsym1,*dsyme; + void *v1,*ve; + + coerce_to_filename(faslfile, filename); + faslfile = open_stream(faslfile, smm_input, Cnil, sKerror); + fp = faslfile->sm.sm_fp; + + massert(v1=get_mmap(fp,&ve)); + + massert(!parse_map(v1,&sec1,&sece,&sn,&sym1,&syme,&st1,&end,&dsym1,&dsyme,&dst1)); + +#ifdef SPECIAL_RELOC_H + massert(!label_got_symbols(v1,sec1,sece,sym1,syme,st1,sn,got)); +#endif + + massert(memory=load_memory(sec1,sece,v1,&got,&gote)); + + massert(!relocate_symbols(sym1,syme,sec1,sece,st1)); + + massert(!find_init_address(sym1,syme,sec1,sece,sn,st1,&init_address)); + + massert(!relocate_code(v1,sec1,sece,sym1,got,gote)); + + massert(!fseek(fp,end,SEEK_SET)); + data=feof(fp) ? 0 : read_fasl_vector(faslfile); + + massert(!un_mmap(v1,ve)); + close_stream(faslfile); + + massert(!clear_protect_memory(memory)); + +#if defined(HAVE_BUILTIN_CLEAR_CACHE) + __builtin___clear_cache((void *)memory->cfd.cfd_start,(void *)memory->cfd.cfd_start+memory->cfd.cfd_size); +#elif defined(CLEAR_CACHE) + CLEAR_CACHE; +#endif + + init_address-=(ul)memory->cfd.cfd_start; + call_init(init_address,memory,data,0); + + if(symbol_value(sLAload_verboseA)!=Cnil) + printf("start address -T %p ",memory->cfd.cfd_start); + + return(memory->cfd.cfd_size); + +} + +#include "sfasli.c" diff --git a/o/sfasli.c b/o/sfasli.c new file mode 100755 index 0000000..e0d6910 --- /dev/null +++ b/o/sfasli.c @@ -0,0 +1,158 @@ +/* +Copyright William Schelter. All rights reserved. */ + +#if !defined(HAVE_LIBBFD) && !defined(SPECIAL_RSYM) +#error Need either BFD or SPECIAL_RSYM +#endif + +#ifndef SPECIAL_RSYM + +/* Replace this with gcl's own hash structure at some point */ +static int +build_symbol_table_bfd(void) { + + int u,v; + unsigned long pa; + asymbol **q; + + bfd_init(); + if (!(bself=bfd_openr(kcl_self,0))) + FEerror("Cannot open self\n",0); + if (!bfd_check_format(bself,bfd_object)) + FEerror("I'm not an object",0); +/* if (link_info.hash) */ +/* bfd_link_hash_table_free(bself,link_info.hash); */ +#ifdef HAVE_OUTPUT_BFD + link_info.output_bfd = bfd_openw("/dev/null", bfd_get_target(bself)); +#endif + if (!(link_info.hash = bfd_link_hash_table_create (bself))) + FEerror("Cannot make hash table",0); + if (!bfd_link_add_symbols(bself,&link_info)) + FEerror("Cannot add self symbols\n",0); + if ((u=bfd_get_symtab_upper_bound(bself))<0) + FEerror("Cannot get self's symtab upper bound",0); + +#ifdef HAVE_ALLOCA + q=(asymbol **)alloca(u); +#else + q=(asymbol **)malloc(u); +#endif + if ((v=bfd_canonicalize_symtab(bself,q))<0) + FEerror("Cannot canonicalize self's symtab",0); + + for (u=0;uname) + continue; + + if (strncmp(q[u]->section->name,"*UND*",5) && !(q[u]->flags & BSF_WEAK)) + continue; + + if ((c=(char *)strstr(q[u]->name,"@@"))) { + *c=0; + if (!(h=bfd_link_hash_lookup(link_info.hash,q[u]->name,MY_BFD_TRUE,MY_BFD_TRUE,MY_BFD_TRUE))) + FEerror("Cannot make new hash entry",0); + h->type=bfd_link_hash_new; + } else if + (!(h=bfd_link_hash_lookup(link_info.hash,q[u]->name,MY_BFD_FALSE,MY_BFD_FALSE,MY_BFD_TRUE)) && + !(h=bfd_link_hash_lookup(link_info.hash,q[u]->name,MY_BFD_TRUE,MY_BFD_TRUE,MY_BFD_TRUE))) + FEerror("Cannot make new hash entry",0); + + if (h->type!=bfd_link_hash_defined) { + if (!q[u]->section) + FEerror("Symbol ~S is missing section",1,make_simple_string(q[u]->name)); + if (!my_plt(q[u]->name,&pa)) { +/* printf("my_plt %s %p\n",q[u]->name,(void *)pa); */ + if (q[u]->value && q[u]->value!=pa) + FEerror("plt address mismatch", 0); + else + q[u]->value=pa; + } + if (q[u]->value) { + h->type=bfd_link_hash_defined; + h->u.def.value=q[u]->value+q[u]->section->vma; + h->u.def.section=q[u]->section; + } + } + + if (c) { + *c='@'; + c=NULL; + } + } + +#ifndef HAVE_ALLOCA + free(q); +#endif + + return 0; + +} + +#endif /* special_rsym */ + +LFD(build_symbol_table)(void) { + + printf("Building symbol table for %s ..\n",kcl_self);fflush(stdout); + +#ifdef SPECIAL_RSYM + +#ifndef USE_DLOPEN + load_self_symbols(); +#endif + +#else + + build_symbol_table_bfd(); + +#endif + +} + +extern int mcount(); +extern int _mcount(); +extern int __divdi3(); +extern int __moddi3(); +extern int __udivdi3(); +extern int __umoddi3(); +extern void sincos(double,double *,double *); +extern int __divsi3(); +extern int __modsi3(); +extern int __udivsi3(); +extern int __umodsi3(); +extern int $$divI(); +extern int $$divU(); +extern int $$remI(); +extern int $$remU(); +extern int __divq(); +extern int __divqu(); +extern int __remq(); +extern int __remqu(); + +#ifndef DARWIN +#ifndef _WIN32 +int +use_symbols(double d,...) { + + sincos(d,&d,&d); + +#ifdef GCL_GPROF + _mcount(); +#endif + + return (int)d; + +} +#endif +#endif + +void +gcl_init_sfasl() { + +#ifdef SFASL + make_si_function("BUILD-SYMBOL-TABLE",build_symbol_table); +#endif + +} diff --git a/o/sfaslmacho.c b/o/sfaslmacho.c new file mode 100644 index 0000000..1c190ea --- /dev/null +++ b/o/sfaslmacho.c @@ -0,0 +1,580 @@ +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#ifdef _LP64 +#define mach_header mach_header_64 +#define nlist nlist_64 +#define segment_command segment_command_64 +#undef LC_SEGMENT +#define LC_SEGMENT LC_SEGMENT_64 +#define section section_64 +#undef MH_MAGIC +#define MH_MAGIC MH_MAGIC_64 +#endif + +#ifndef S_16BYTE_LITERALS +#define S_16BYTE_LITERALS 0 +#endif + +#define ALLOC_SEC(sec) ({ul _fl=sec->flags&SECTION_TYPE;\ + _fl<=S_SYMBOL_STUBS || _fl==S_16BYTE_LITERALS;}) + +#define LOAD_SEC(sec) ({ul _fl=sec->flags&SECTION_TYPE;\ + (_fl<=S_SYMBOL_STUBS || _fl==S_16BYTE_LITERALS) && _fl!=S_ZEROFILL;}) + + +#define MASK(n) (~(~0L << (n))) + + + +typedef unsigned long ul; + + + +#ifdef STATIC_RELOC_VARS +STATIC_RELOC_VARS +#endif + + + +static int +ovchk(ul v,ul m) { + + m|=m>>1; + v&=m; + + return (!v || v==m); + +} + +static int +store_val(ul *w,ul m,ul v) { + + massert(ovchk(v,~m)); + *w=(v&m)|(*w&~m); + + return 0; + +} + +static int +add_val(ul *w,ul m,ul v) { + + return store_val(w,m,v+(*w&m)); + +} + + +#ifndef _LP64 +/*redirect trampolines gcc-4.0 gives no reloc for stub sections on x86 only*/ +static int +redirect_trampoline(struct relocation_info *ri,ul o,ul rel, + struct section *sec1,ul *io1,struct nlist *n1,ul *a) { + + struct section *js=sec1+ri->r_symbolnum-1; + + if (ri->r_extern) + return 0; + + if ((js->flags&SECTION_TYPE)!=S_SYMBOL_STUBS) + return 0; + + if (ri->r_pcrel) o+=rel; + o-=js->addr; + + massert(!(o%js->reserved2)); + o/=js->reserved2; + massert(o>=0 && osize/js->reserved2); + + *a=n1[io1[js->reserved1+o]].n_value; + ri->r_extern=1; + + return 0; + +} +#endif + +static int +relocate(struct relocation_info *ri,struct section *sec, + struct section *sec1,ul start,ul *io1,struct nlist *n1,ul *got,ul *gote) { + + struct scattered_relocation_info *sri=(void *)ri; + ul *q=(void *)(sec->addr+(sri->r_scattered ? sri->r_address : ri->r_address)); + ul a,rel=(ul)(q+1); + + if (sri->r_scattered) + a=sri->r_value; + else if (ri->r_extern) + a=n1[ri->r_symbolnum].n_value; + else + a=start; + + switch(sri->r_scattered ? sri->r_type : ri->r_type) { + +#include RELOC_H + + default: + FEerror("Unknown reloc type\n",0); + break; + + } + + return 0; + +} + +static int +relocate_symbols(struct nlist *n1,struct nlist *ne,char *st1,ul start) { + + struct nlist *n; + struct node *nd; + + for (n=n1;nn_sect) + n->n_value+=start; + else if ((nd=find_sym_ptable(st1+n->n_un.n_strx))) + n->n_value=nd->address; + else if (n->n_type&(N_PEXT|N_EXT)) + massert(!fprintf(stderr,"Unrelocated non-local symbol: %s\n",st1+n->n_un.n_strx)); + + return 0; + +} + +static int +find_init_address(struct nlist *n1,struct nlist *ne,const char *st1,ul *init) { + + struct nlist *n; + + for (n=n1;nn_un.n_strx,5);n++); + massert(nn_value; + + return 0; + +} + + + +static object +load_memory(struct section *sec1,struct section *sece,void *v1, + ul *p,ul **got,ul **gote,ul *start) { + + ul sz,gsz,sa,ma,a,fl; + struct section *sec; + object memory; + + BEGIN_NO_INTERRUPT; + + for (*p=sz=ma=0,sa=-1,sec=sec1;secaddraddr; + ma=1<align; + } + + a=sec->addr+sec->size; + if (szflags&SECTION_TYPE; + if (fl==S_NON_LAZY_SYMBOL_POINTERS || fl==S_LAZY_SYMBOL_POINTERS) + *p+=sec->size*sizeof(struct relocation_info)/sizeof(void *); + + } + + ma=ma>sizeof(struct contblock) ? ma-1 : 0; + sz+=ma; + + gsz=0; + if (**got) { + gsz=(**got+1)*sizeof(**got)-1; + sz+=gsz; + } + + memory=alloc_object(t_cfdata); + memory->cfd.cfd_size=sz; + memory->cfd.cfd_self=0; + memory->cfd.cfd_start=0; + prefer_low_mem_contblock=TRUE; + memory->cfd.cfd_start=alloc_contblock(sz); + prefer_low_mem_contblock=FALSE; + + a=(ul)memory->cfd.cfd_start; + a=(a+ma)&~ma; + for (sec=sec1;secaddr+=a; + if (LOAD_SEC(sec)) + memcpy((void *)sec->addr,v1+sec->offset,sec->size); + } + + if (**got) { + sz=**got; + *got=(void *)memory->cfd.cfd_start+memory->cfd.cfd_size-gsz; + gsz=sizeof(**got)-1; + *got=(void *)(((ul)*got+gsz)&~gsz); + *gote=*got+sz; + } + + *start=a; + + END_NO_INTERRUPT; + + return memory; + +} + + +static int +parse_file(void *v1, + struct section **sec1,struct section **sece, + struct nlist **n1,struct nlist **ne, + char **st1,char **ste,ul **io1) { + + struct mach_header *mh; + struct load_command *lc; + struct symtab_command *sym=NULL; + struct dysymtab_command *dsym=NULL; + struct segment_command *seg; + ul i; + void *v=v1; + + mh=v; + v+=sizeof(*mh); + + for (i=0,*sec1=NULL;(lc=v) && incmds;i++,v+=lc->cmdsize) + + switch(lc->cmd) { + + case LC_SEGMENT: + + if (*sec1 && *sece>*sec1) continue; + + seg=v; + *sec1=(void *)(seg+1); + *sece=*sec1+seg->nsects; + + break; + case LC_SYMTAB: + massert(!sym); + sym=v; + *n1=v1+sym->symoff; + *ne=*n1+sym->nsyms; + *st1=v1+sym->stroff; + *ste=*st1+sym->strsize; + break; + case LC_DYSYMTAB: + massert(!dsym); + dsym=v; + *io1=v1+dsym->indirectsymoff; + break; + } + + return 0; + +} + + +static int +set_symbol_stubs(void *v1,struct nlist *n1,struct nlist *ne,ul *uio,const char *st1) { + + struct mach_header *mh; + struct load_command *lc; + struct segment_command *seg; + struct section *sec1,*sec,*sece; + ul i,ns; + void *v=v1,*vv; + int *io1,*io,*ioe; + + mh=v; + v+=sizeof(*mh); + + for (i=0;(lc=v) && incmds;i++,v+=lc->cmdsize) + + switch(lc->cmd) { + + case LC_SEGMENT: + + for (seg=v,sec1=sec=(void *)(seg+1),sece=sec1+seg->nsects;secflags&SECTION_TYPE; + if (ns!=S_SYMBOL_STUBS && + ns!=S_LAZY_SYMBOL_POINTERS && + ns!=S_NON_LAZY_SYMBOL_POINTERS) + continue; + + io1=(void *)uio; + io1+=sec->reserved1; + if (!sec->reserved2) sec->reserved2=sizeof(void *); + ioe=io1+sec->size/sec->reserved2; + + for (io=io1,vv=(void *)sec->addr;ioreserved2,io++) + if (*io>=0 && *ioflags&SECTION_TYPE,*io; + struct relocation_info *ri,*re; + struct scattered_relocation_info *sri; + + if (fl!=S_NON_LAZY_SYMBOL_POINTERS && fl!=S_LAZY_SYMBOL_POINTERS) + return 0; + + sec->nreloc=sec->size/sizeof(void *); + sec->reloff=*p-v1; + ri=*p; + re=ri+sec->nreloc; + *p=re; + + io1+=sec->reserved1; + for (io=io1;rir_symbolnum=*io; + ri->r_extern=1; + ri->r_address=(io-io1)*sizeof(void *); + ri->r_type=GENERIC_RELOC_VANILLA; + ri->r_pcrel=0; + sri=(void *)ri; + sri->r_scattered=0; + + } + + return 0; + +} + + +static int +relocate_code(void *v1,struct section *sec1,struct section *sece, + void **p,ul *io1,struct nlist *n1,ul *got,ul *gote,ul start) { + + struct section *sec; + struct relocation_info *ri,*re; + + for (sec=sec1;secreloff,re=ri+sec->nreloc;rin_type & N_STAB) + continue; + if (!(sym->n_type & N_EXT)) + continue; + + ns++; + sl+=strlen(sym->n_un.n_strx+strtab)+1; + + } + + c_table.alloc_length=c_table.length=ns; + assert(c_table.ptable=malloc(sizeof(*c_table.ptable)*c_table.alloc_length)); + assert(s=malloc(sl)); + + for (a=c_table.ptable,sym=sym1;symn_type & N_STAB) + continue; + if (!(sym->n_type & N_EXT)) + continue; + + a->address=sym->n_value; + a->string=s; + strcpy(s,sym->n_un.n_strx+strtab); + + a++; + s+=strlen(s)+1; + + } + + qsort(c_table.ptable,c_table.length,sizeof(*c_table.ptable),node_compare); + + massert(!un_mmap(addr,addre)); + massert(!fclose(f)); + + return 0; + +} + +int +seek_to_end_ofile(FILE *f) { + + struct mach_header *mh; + struct load_command *lc; + struct symtab_command *st=NULL; + void *addr,*addre; + int i; + + massert(addr=get_mmap(f,&addre)); + + mh=addr; + lc=addr+sizeof(*mh); + + for (i=0;incmds;i++,lc=(void *)lc+lc->cmdsize) + if (lc->cmd==LC_SYMTAB) { + st=(void *) lc; + break; + } + massert(st); + + fseek(f,st->stroff+st->strsize,SEEK_SET); + + massert(!un_mmap(addr,addre)); + + return 0; + +} + +#ifndef GOT_RELOC +#define GOT_RELOC(a) 0 +#endif + +static int +label_got_symbols(void *v1,struct section *sec,struct nlist *n1,struct nlist *ne,ul *gs) { + + struct relocation_info *ri,*re; + struct nlist *n; + + *gs=0; + for (n=n1;nn_desc=0; + + for (ri=v1+sec->reloff,re=ri+sec->nreloc;rir_extern); + n=n1+ri->r_symbolnum; + if (!n->n_desc) + n->n_desc=++*gs; + + } + + return 0; + +} + +static int +clear_protect_memory(object memory) { + + void *p,*pe; + + p=(void *)((unsigned long)memory->cfd.cfd_start & ~(PAGESIZE-1)); + pe=(void *)((unsigned long)(memory->cfd.cfd_start+memory->cfd.cfd_size + PAGESIZE-1) & ~(PAGESIZE-1)); + + return gcl_mprotect(p,pe-p,PROT_READ|PROT_WRITE|PROT_EXEC); + +} + + +int +fasload(object faslfile) { + + FILE *fp; + object data; + char filename[256]; + ul init_address=-1; + object memory; + void *v1,*ve,*p; + struct section *sec1,*sece=NULL; + struct nlist *n1=NULL,*ne=NULL; + char *st1=NULL,*ste=NULL; + ul gs,*got=&gs,*gote,*io1=NULL,rls,start; + + coerce_to_filename(faslfile, filename); + faslfile = open_stream(faslfile, smm_input, Cnil, sKerror); + fp = faslfile->sm.sm_fp; + + massert(v1=get_mmap(fp,&ve)); + + parse_file(v1,&sec1,&sece,&n1,&ne,&st1,&ste,&io1); + + label_got_symbols(v1,sec1,n1,ne,got); + + massert(memory=load_memory(sec1,sece,v1,&rls,&got,&gote,&start)); + + massert(p=alloca(rls)); + + relocate_symbols(n1,ne,st1,start); + + find_init_address(n1,ne,st1,&init_address); + + relocate_code(v1,sec1,sece,&p,io1,n1,got,gote,start); + + fseek(fp,(void *)ste-v1,SEEK_SET); + data = feof(fp) ? 0 : read_fasl_vector(faslfile); + + massert(!clear_protect_memory(memory)); + +#ifdef CLEAR_CACHE + CLEAR_CACHE; +#endif + + massert(!un_mmap(v1,ve)); + close_stream(faslfile); + + init_address-=(ul)memory->cfd.cfd_start; + call_init(init_address,memory,data,0); + + if(symbol_value(sLAload_verboseA)!=Cnil) + printf("start address -T %p ",memory->cfd.cfd_start); + + return(memory->cfd.cfd_size); + + } + +#include "sfasli.c" diff --git a/o/sfaslmacosx.c b/o/sfaslmacosx.c new file mode 100644 index 0000000..716deda --- /dev/null +++ b/o/sfaslmacosx.c @@ -0,0 +1,264 @@ +/* + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#include +#include +#include +#include +#include +#include +#include + +#include +#include +#include + +#include "ptable.h" + +typedef int (*func) (); + +/* Externalize the command line used to build loadable object files (a.k.a. bundles). */ +object sSAmacosx_ldcmdA = 0L; + +static void sfasl_error (char *format, ...) +{ + va_list ap; + + va_start (ap, format); + fprintf (stderr, "fasload: "); + vfprintf (stderr, format, ap); + fprintf (stderr, "\n"); + va_end (ap); + exit (1); +} + +/* static void get_init_name (object faslfile, char *init_fun) */ +/* { */ +/* object path = coerce_to_pathname (faslfile); */ +/* char *p; */ + +/* strcpy (init_fun, "_init_"); */ +/* coerce_to_filename (path->pn.pn_name, init_fun + 6); */ + +/* for (p = init_fun + 6 ; *p ; p++) */ +/* if (*p == '-') *p = '_'; */ +/* } */ + +static NSSymbol +get_init_sym(NSModule module,object ff) { + + static object inf; + static struct string st; + object x; + char ib[MAXPATHLEN+1]; + NSSymbol v; + + if (!inf) { + + object x; + static struct string st; + set_type_of(&st,t_string); + st.st_self="COMPILER"; + st.st_dim=st.st_fillp=strlen(st.st_self); + if ((x=find_package((object)&st))==Cnil) + sfasl_error("Cannot find compiler package\n"); + st.st_self="INIT-NAME"; + st.st_dim=st.st_fillp=strlen(st.st_self); + if ((inf=find_symbol((object)&st,x))==Cnil) { + inf=NULL; + sfasl_error("Cannot find function COMPILER::INIT-NAME\n"); + } + + } + + set_type_of(&st,t_string); + st.st_self=ff->st.st_self; + st.st_dim=st.st_fillp=ff->st.st_dim; + x=ifuncall1(inf,(object)&st); + if (x->d.t!=t_string) + sfasl_error("INIT-NAME error\n"); + assert(snprintf(ib,sizeof(ib),"_init_%-.*s",x->st.st_dim,x->st.st_self)>0); + + if (!(v=NSLookupSymbolInModule(module, ib))) { + x=ifuncall2(inf,(object)&st,Ct); + if (x->d.t!=t_string) + sfasl_error("INIT-NAME error\n"); + assert(snprintf(ib,sizeof(ib),"_init_%-.*s",x->st.st_dim,x->st.st_self)>0); + if (!(v=NSLookupSymbolInModule(module, ib))) + sfasl_error("Cannot lookup init-name\n"); + } + + return v; + +} + +static func prepare_bundle (object faslfile, char *filename) +{ + NSObjectFileImage image; + NSModule module; + NSSymbol nssym; + int (*fptr) (); + + unsigned long n; + unsigned long vmsize = 0; + unsigned long vmaddr_slide = 0; + unsigned long base_addr = (unsigned long) -1; + + extern void mark_region (unsigned long address, unsigned long size); + + if (NSCreateObjectFileImageFromFile (filename , &image) != NSObjectFileImageSuccess) { + sfasl_error ("cannot create object file image\n"); + } + + if (!(module = NSLinkModule (image, filename, NSLINKMODULE_OPTION_RETURN_ON_ERROR | + NSLINKMODULE_OPTION_PRIVATE | NSLINKMODULE_OPTION_BINDNOW))) { + sfasl_error ("cannot link bundle\n"); + } + + nssym=get_init_sym(module,faslfile); +/* if (!(nssym = NSLookupSymbolInModule (module, "_init_code"))) */ +/* { */ +/* char init_fun [256]; */ + +/* get_init_name (faslfile, init_fun); */ + +/* if (!(nssym = NSLookupSymbolInModule (module, init_fun))) { */ +/* sfasl_error ("cannot retrieve entry point symbol in bundle\n"); */ +/* } */ +/* } */ + + if (!(fptr = (int (*) ()) NSAddressOfSymbol (nssym))) { + sfasl_error ("cannot retrieve entry point address\n"); + } + + for (n = _dyld_image_count () ; --n != (unsigned long) -1 ; ) + { + if (strstr (filename, _dyld_get_image_name (n))) + { + struct mach_header *mh = _dyld_get_image_header (n); + struct load_command *lc = (struct load_command *) (mh+1); + unsigned long i; + + vmsize = 0; + + for (i=0 ; i < mh->ncmds ; i++) { + if (lc->cmd == LC_SEGMENT) { + if (base_addr == (unsigned long) -1) { + base_addr = ((struct segment_command *) lc)->vmaddr; + } + vmsize += ((struct segment_command *) lc)->vmsize; + } + lc = (struct load_command *) ((char *) lc + lc->cmdsize); + } + + vmaddr_slide = _dyld_get_image_vmaddr_slide (n); + + break; + } + } + + if (base_addr != (unsigned long) -1) { + mark_region (vmaddr_slide - base_addr, vmsize); + } else { + sfasl_error ("could not retrieve newly created bundle image\n"); + } + + return (fptr); +} + +int fasload (object faslfile) +{ + object faslstream; + object memory; + object data; + + int (*fptr) (); + + char filename [MAXPATHLEN]; + char tmpfile [MAXPATHLEN]; + + char cmd [256]; + + static int count = 0; + + static char ldfmt [] = "gcc -bind_at_load -bundle -bundle_loader %s -o %s %s"; + + char fmt [MAXPATHLEN]; + + extern int seek_to_end_ofile (FILE *); + + if (count == 0) { + /* DEFVAR ("*MACOSX-LDCMD*",sSAmacosx_ldcmdA,LISP,make_simple_string(ldfmt),""); */ + sSAmacosx_ldcmdA = make_special ("*MACOSX-LDCMD*", make_simple_string (ldfmt)); + count = time (0); + } + + coerce_to_filename (truename (faslfile), filename); + + snprintf (tmpfile, sizeof (tmpfile), "/tmp/ufas%dx.so", count++); + + mkstemp (tmpfile); + symlink (filename, tmpfile); + + faslstream = open_stream (faslfile, smm_input, Cnil, sKerror); + + /* I guess the program will crash if a dumped image is ever dynamically relinked against + a version of a shared library different from the one used at the time the bundle got + loaded (if the bundle makes reference to this shared library). To avoid this, we + would need all external bundle calls to be indirected through the loader image stubs. */ + + coerce_to_filename (symbol_value (sSAmacosx_ldcmdA), fmt); + + snprintf (cmd, sizeof(cmd), fmt, kcl_self, tmpfile, filename); + + if (system (cmd) != 0) { + sfasl_error ("cannot execute command `%s'\n", cmd); + } + + fptr = prepare_bundle (faslfile, tmpfile); + + if (seek_to_end_ofile (faslstream->sm.sm_fp) != 1) { + sfasl_error ("error seeking to end of object file"); + } + + data = read_fasl_vector (faslstream); + + close_stream (faslstream); + + memory = alloc_object (t_cfdata); + memory->cfd.cfd_self = NULL; + memory->cfd.cfd_start = NULL; + memory->cfd.cfd_size = 0; + + if (symbol_value (sLAload_verboseA) != Cnil) + printf (" start address (dynamic) %p ", fptr); + + call_init (0, memory, data, fptr); + + unlink (tmpfile); + + return memory->cfd.cfd_size; +} + +void unlink_loaded_files () { + +} + +#include "sfasli.c" diff --git a/o/sgbc.c b/o/sgbc.c new file mode 100755 index 0000000..9e0f53a --- /dev/null +++ b/o/sgbc.c @@ -0,0 +1,1596 @@ +/* Copyright William Schelter. All rights reserved. + + Stratified Garbage Collection (SGC) + + Write protects pages to tell which ones have been written + to recently, for more efficient garbage collection. + +*/ + +static void +sgc_mark_object1(object); + +#ifdef BSD +/* ulong may have been defined in mp.h but the define is no longer needed */ +#undef ulong +#include +#define PROT_READ_WRITE_EXEC (PROT_READ | PROT_WRITE |PROT_EXEC) +#define PROT_READ_EXEC (PROT_READ|PROT_EXEC) +#endif +#ifdef AIX3 +#include +#define PROT_READ_EXEC RDONLY /*FIXME*/ +#define PROT_READ_WRITE_EXEC UDATAKEY +int mprotect(); +#endif + +#ifdef __MINGW32__ +#include +#define PROT_READ_WRITE_EXEC PAGE_EXECUTE_READWRITE +#define PROT_READ_EXEC PAGE_READONLY /*FIXME*/ + +int gclmprotect ( void *addr, size_t len, int prot ) { + int old, rv; + rv = VirtualProtect ( (LPVOID) addr, len, prot, &old ); + if ( 0 == rv ) { + fprintf ( stderr, "mprotect: VirtualProtect %x %d %d failed\n", addr, len, prot ); + rv = -1; + } else { + rv =0; + } + return (rv); +} +/* Avoid clash with libgcc's mprotect */ +#define mprotect gclmprotect + +#endif + +#if defined(DARWIN) +#include +#endif + +#include + +/* void segmentation_catcher(void); */ + + +#define sgc_mark_pack_list(u) \ +do {register object xtmp = u; \ + while (xtmp != Cnil) \ + {if (ON_WRITABLE_PAGE(xtmp)) {mark(xtmp);} \ + sgc_mark_object(xtmp->c.c_car); \ + xtmp=Scdr(xtmp);}}while(0) + + +#ifdef SDEBUG +object sdebug; +joe1(){;} +joe() {;} +#endif + +/* static void */ +/* sgc_mark_cons(object x) { */ + +/* cs_check(x); */ + +/* /\* x is already marked. *\/ */ + +/* BEGIN: */ +/* #ifdef SDEBUG */ +/* if(x==sdebug) joe1(); */ +/* #endif */ +/* sgc_mark_object(x->c.c_car); */ +/* #ifdef OLD */ +/* IF_WRITABLE(x->c.c_car, goto MARK_CAR;); */ +/* goto MARK_CDR; */ + +/* MARK_CAR: */ +/* if (!is_marked_or_free(x->c.c_car)) { */ +/* if (consp(x->c.c_car)) { */ +/* mark(x->c.c_car); */ +/* sgc_mark_cons(x->c.c_car); */ +/* } else */ +/* sgc_mark_object1(x->c.c_car);} */ +/* MARK_CDR: */ +/* #endif */ +/* /\* if (is_imm_fixnum(x->c.c_cdr)) return; *\/ */ +/* x = Scdr(x); */ +/* IF_WRITABLE(x, goto WRITABLE_CDR;); */ +/* return; */ +/* WRITABLE_CDR: */ +/* if (is_marked_or_free(x)) return; */ +/* if (consp(x)) { */ +/* mark(x); */ +/* goto BEGIN; */ +/* } */ +/* sgc_mark_object1(x); */ +/* } */ + +inline void +sgc_mark_cons(object x) { + + do { + object d=x->c.c_cdr; + mark(x); + sgc_mark_object(x->c.c_car); + x=d; + if (!IS_WRITABLE(page(x)) || is_marked_or_free(x))/*catches Cnil*/ + return; + } while (cdr_listp(x)); + sgc_mark_object(x); + +} + +/* Whenever two arrays are linked together by displacement, + if one is live, the other will be made live */ +#define sgc_mark_displaced_field(ar) sgc_mark_object(ar->a.a_displaced) + + +/* structures and arrays of type t, need to be marked if their + bodies are not write protected even if the headers are. + So we should keep these on pages particular to them. + Actually we will change structure sets to touch the structure + header, that way we won't have to keep the headers in memory. + This takes only 1.47 as opposed to 1.33 microseconds per set. +*/ +static void +sgc_mark_object1(object x) { + + fixnum i,j; + object *p; + char *cp; + enum type tp; + + cs_check(x); + BEGIN: +#ifdef SDEBUG + if (x == OBJNULL || !ON_WRITABLE_PAGE(x)) + return; + IF_WRITABLE(x,goto OK); + joe(); + OK: +#endif + if (is_marked_or_free(x)) + return; +#ifdef SDEBUG + if(x==sdebug) joe1(); +#endif + + tp=type_of(x); + + if (tp==t_cons) { + sgc_mark_cons(x); + return; + } + + mark(x); + + switch (tp) { + + case t_fixnum: + break; + + case t_ratio: + sgc_mark_object(x->rat.rat_num); + x = x->rat.rat_den; + IF_WRITABLE(x,if(!is_marked_or_free(x)) goto BEGIN); + + case t_shortfloat: + break; + + case t_longfloat: + break; + + case t_complex: + sgc_mark_object(x->cmp.cmp_imag); + x = x->cmp.cmp_real; + IF_WRITABLE(x,if(!is_marked_or_free(x)) goto BEGIN); + + case t_character: + break; + + case t_symbol: + IF_WRITABLE(x->s.s_plist,if(!is_marked_or_free(x->s.s_plist)) + {/* mark(x->s.s_plist); */ + sgc_mark_cons(x->s.s_plist);}); + sgc_mark_object(x->s.s_gfdef); + sgc_mark_object(x->s.s_dbind); + if (x->s.s_self == NULL) + break; + /* to do */ + if (inheap(x->s.s_self)) { + if (what_to_collect == t_contiguous) + mark_contblock(x->s.s_self,x->s.s_fillp); + } else if (SGC_RELBLOCK_P(x->s.s_self) && COLLECT_RELBLOCK_P) + x->s.s_self = copy_relblock(x->s.s_self, x->s.s_fillp); + break; + + case t_package: + sgc_mark_object(x->p.p_name); + sgc_mark_object(x->p.p_nicknames); + sgc_mark_object(x->p.p_shadowings); + sgc_mark_object(x->p.p_uselist); + sgc_mark_object(x->p.p_usedbylist); + if (what_to_collect == t_contiguous) { + if (x->p.p_internal != NULL) + mark_contblock((char *)(x->p.p_internal), + x->p.p_internal_size*sizeof(object)); + if (x->p.p_external != NULL) + mark_contblock((char *)(x->p.p_external), + x->p.p_external_size*sizeof(object)); + } + break; + + case t_hashtable: + sgc_mark_object(x->ht.ht_rhsize); + sgc_mark_object(x->ht.ht_rhthresh); + if (x->ht.ht_self == NULL) + break; + for (i = 0, j = x->ht.ht_size; i < j; i++) { + if (ON_WRITABLE_PAGE(&x->ht.ht_self[i])) { + sgc_mark_object(x->ht.ht_self[i].hte_key); + sgc_mark_object(x->ht.ht_self[i].hte_value); + } + } + if (inheap(x->ht.ht_self)) { + if (what_to_collect == t_contiguous) + mark_contblock((char *)(x->ht.ht_self),j * sizeof(struct htent)); + } else if (SGC_RELBLOCK_P(x->ht.ht_self) && COLLECT_RELBLOCK_P) + x->ht.ht_self=(void *)copy_relblock((char *)x->ht.ht_self,j*sizeof(struct htent));; + break; + + case t_array: + if ((x->a.a_displaced) != Cnil) + sgc_mark_displaced_field(x); + if (x->a.a_dims != NULL) { + if (inheap(x->a.a_dims)) { + if (what_to_collect == t_contiguous) + mark_contblock((char *)(x->a.a_dims),sizeof(int)*x->a.a_rank); + } else if (SGC_RELBLOCK_P(x->a.a_dims) && COLLECT_RELBLOCK_P) + x->a.a_dims = (int *) copy_relblock((char *)(x->a.a_dims),sizeof(int)*x->a.a_rank); + } + if ((enum aelttype)x->a.a_elttype == aet_ch) + goto CASE_STRING; + if ((enum aelttype)x->a.a_elttype == aet_bit) + goto CASE_BITVECTOR; + if ((enum aelttype)x->a.a_elttype == aet_object) + goto CASE_GENERAL; + + CASE_SPECIAL: + cp = (char *)(x->fixa.fixa_self); + if (cp == NULL) + break; + /* set j to the size in char of the body of the array */ + + switch((enum aelttype)x->a.a_elttype){ + case aet_lf: + j= sizeof(longfloat)*x->lfa.lfa_dim; + if ((COLLECT_RELBLOCK_P) && !(inheap(cp)) && SGC_RELBLOCK_P(x->a.a_self)) + ROUND_RB_POINTERS_DOUBLE;/*FIXME gc space violation*/ + break; + case aet_char: + case aet_uchar: + j=sizeof(char)*x->a.a_dim; + break; + case aet_short: + case aet_ushort: + j=sizeof(short)*x->a.a_dim; + break; + default: + j=sizeof(fixnum)*x->fixa.fixa_dim;} + + goto COPY; + + CASE_GENERAL: + p = x->a.a_self; + if (p == NULL +#ifdef HAVE_ALLOCA + || (char *)p >= core_end +#endif + + ) + break; + j=0; + if (x->a.a_displaced->c.c_car == Cnil) + for (i = 0, j = x->a.a_dim; i < j; i++) + if (ON_WRITABLE_PAGE(&p[i])) + sgc_mark_object(p[i]); + cp = (char *)p; + j *= sizeof(object); + COPY: + if (inheap(cp)) { + if (what_to_collect == t_contiguous) + mark_contblock(cp, j); + } else if (SGC_RELBLOCK_P(cp) && COLLECT_RELBLOCK_P) { + if (x->a.a_displaced == Cnil) { +#ifdef HAVE_ALLOCA + if (!NULL_OR_ON_C_STACK(cp)) /* only if body of array not on C stack */ +#endif + x->a.a_self = (object *)copy_relblock(cp, j); + } else if (x->a.a_displaced->c.c_car == Cnil) { + i = (long)(object *)copy_relblock(cp, j) - (long)(x->a.a_self); + adjust_displaced(x, i); + } + } + break; + + case t_vector: + if ((x->v.v_displaced) != Cnil) + sgc_mark_displaced_field(x); + if ((enum aelttype)x->v.v_elttype == aet_object) + goto CASE_GENERAL; + else + goto CASE_SPECIAL; + + case t_bignum: +#ifdef SDEBUG + if (TYPE_MAP(page(x->big.big_self)) < t_contiguous) + printf("bad body for %x (%x)\n",x,cp); +#endif +#ifndef GMP_USE_MALLOC + j = MP_ALLOCATED(x); + cp = (char *)MP_SELF(x); + if (cp == 0) + break; + j = j * MP_LIMB_SIZE; + if (inheap(cp)) { + if (what_to_collect == t_contiguous) + mark_contblock(cp, j); + } else if (SGC_RELBLOCK_P(cp) && COLLECT_RELBLOCK_P) + MP_SELF(x) = (void *) copy_relblock(cp, j); +#endif /* not GMP_USE_MALLOC */ + break; + + + CASE_STRING: + case t_string: + if ((x->st.st_displaced) != Cnil) + sgc_mark_displaced_field(x); + j = x->st.st_dim; + cp = x->st.st_self; + if (cp == NULL) + break; + + COPY_STRING: + if (inheap(cp)) { + if (what_to_collect == t_contiguous) + mark_contblock(cp, j); + } else if (SGC_RELBLOCK_P(cp) && COLLECT_RELBLOCK_P) { + if (x->st.st_displaced == Cnil) + x->st.st_self = copy_relblock(cp, j); + else if (x->st.st_displaced->c.c_car == Cnil) { + i = copy_relblock(cp, j) - cp; + adjust_displaced(x, i); + } + } + break; + + CASE_BITVECTOR: + case t_bitvector: + if ((x->bv.bv_displaced) != Cnil) + sgc_mark_displaced_field(x); + /* We make bitvectors multiple of sizeof(int) in size allocated + Assume 8 = number of bits in char */ + +#define W_SIZE (8*sizeof(fixnum)) + j= sizeof(fixnum) * + ((BV_OFFSET(x) + x->bv.bv_dim + W_SIZE -1)/W_SIZE); + cp = x->bv.bv_self; + if (cp == NULL) + break; + goto COPY_STRING; + + case t_structure: + sgc_mark_object(x->str.str_def); + p = x->str.str_self; + if (p == NULL) + break; + { + object def=x->str.str_def; + unsigned char *s_type = &SLOT_TYPE(def,0); + unsigned short *s_pos = &SLOT_POS (def,0); + for (i = 0, j = S_DATA(def)->length; i < j; i++) + if (s_type[i]==0 && ON_WRITABLE_PAGE(&STREF(object,x,s_pos[i]))) + sgc_mark_object(STREF(object,x,s_pos[i])); + if (inheap(x->str.str_self)) { + if (what_to_collect == t_contiguous) + mark_contblock((char *)p,S_DATA(def)->size); + } else if (SGC_RELBLOCK_P(p) && (COLLECT_RELBLOCK_P)) + x->str.str_self = (object *) copy_relblock((char *)p, S_DATA(def)->size); + } + break; + + case t_stream: + switch (x->sm.sm_mode) { + case smm_input: + case smm_output: + case smm_io: + case smm_socket: + case smm_probe: + sgc_mark_object(x->sm.sm_object0); + sgc_mark_object(x->sm.sm_object1); + if (what_to_collect == t_contiguous && + x->sm.sm_fp && + x->sm.sm_buffer) + mark_contblock(x->sm.sm_buffer, BUFSIZ); + break; + + case smm_synonym: + sgc_mark_object(x->sm.sm_object0); + break; + + case smm_broadcast: + case smm_concatenated: + sgc_mark_object(x->sm.sm_object0); + break; + + case smm_two_way: + case smm_echo: + sgc_mark_object(x->sm.sm_object0); + sgc_mark_object(x->sm.sm_object1); + break; + + case smm_string_input: + case smm_string_output: + sgc_mark_object(x->sm.sm_object0); + break; +#ifdef USER_DEFINED_STREAMS + case smm_user_defined: + sgc_mark_object(x->sm.sm_object0); + sgc_mark_object(x->sm.sm_object1); + break; +#endif + default: + error("mark stream botch"); + } + break; + +#define SGC_MARK_CP(a_,b_) {fixnum _t=(b_);if (inheap((a_))) {\ + if (what_to_collect == t_contiguous) mark_contblock((void *)(a_),_t); \ + } else if (SGC_RELBLOCK_P((a_)) && COLLECT_RELBLOCK_P) (a_)=(void *)copy_relblock((void *)(a_),_t);} + +#define SGC_MARK_MP(a_) {if ((a_)->_mp_d) SGC_MARK_CP((a_)->_mp_d,(a_)->_mp_alloc*MP_LIMB_SIZE);} + + case t_random: + SGC_MARK_MP(x->rnd.rnd_state._mp_seed); +#if __GNU_MP_VERSION < 4 || (__GNU_MP_VERSION == 4 && __GNU_MP_VERSION_MINOR < 2) + if (x->rnd.rnd_state._mp_algdata._mp_lc) { + SGC_MARK_MP(x->rnd.rnd_state._mp_algdata._mp_lc->_mp_a); + if (!x->rnd.rnd_state._mp_algdata._mp_lc->_mp_m2exp) SGC_MARK_MP(x->rnd.rnd_state._mp_algdata._mp_lc->_mp_m); + SGC_MARK_CP(x->rnd.rnd_state._mp_algdata._mp_lc,sizeof(*x->rnd.rnd_state._mp_algdata._mp_lc)); + } +#endif + break; + + case t_readtable: + if (x->rt.rt_self == NULL) + break; + if (what_to_collect == t_contiguous) + mark_contblock((char *)(x->rt.rt_self),RTABSIZE*sizeof(struct rtent)); + for (i = 0; i < RTABSIZE; i++) { + sgc_mark_object(x->rt.rt_self[i].rte_macro); + if (x->rt.rt_self[i].rte_dtab != NULL) { + if (what_to_collect == t_contiguous) + mark_contblock((char *)(x->rt.rt_self[i].rte_dtab),RTABSIZE*sizeof(object)); + for (j = 0; j < RTABSIZE; j++) + sgc_mark_object(x->rt.rt_self[i].rte_dtab[j]); + } + } + break; + + case t_pathname: + sgc_mark_object(x->pn.pn_host); + sgc_mark_object(x->pn.pn_device); + sgc_mark_object(x->pn.pn_directory); + sgc_mark_object(x->pn.pn_name); + sgc_mark_object(x->pn.pn_type); + sgc_mark_object(x->pn.pn_version); + break; + + case t_closure: + { + int i ; + for (i= 0 ; i < x->cl.cl_envdim ; i++) + sgc_mark_object(x->cl.cl_env[i]); + if (SGC_RELBLOCK_P(x->cl.cl_env) && COLLECT_RELBLOCK_P) + x->cl.cl_env=(void *)copy_relblock((void *)x->cl.cl_env,x->cl.cl_envdim*sizeof(object)); + + } + + case t_cfun: + case t_sfun: + case t_vfun: + case t_afun: + case t_gfun: + sgc_mark_object(x->cf.cf_name); + sgc_mark_object(x->cf.cf_data); + break; + + case t_cfdata: + + if (x->cfd.cfd_self != NULL) { + int i=x->cfd.cfd_fillp; + while(i-- > 0) + sgc_mark_object(x->cfd.cfd_self[i]); + } + if (what_to_collect == t_contiguous) { + mark_contblock(x->cfd.cfd_start, x->cfd.cfd_size); + mark_link_array(x->cfd.cfd_start,x->cfd.cfd_start+x->cfd.cfd_size); + } + break; + case t_cclosure: + sgc_mark_object(x->cc.cc_name); + sgc_mark_object(x->cc.cc_env); + sgc_mark_object(x->cc.cc_data); + if (x->cc.cc_turbo!=NULL) { + sgc_mark_object(*(x->cc.cc_turbo-1)); + if (SGC_RELBLOCK_P(x->cc.cc_turbo) && COLLECT_RELBLOCK_P) + x->cc.cc_turbo=(void *)copy_relblock((char *)(x->cc.cc_turbo-1),(1+fix(*(x->cc.cc_turbo-1)))*sizeof(object))+sizeof(object); + } + break; + + case t_spice: + break; + + default: +#ifdef DEBUG + if (debug) + printf("\ttype = %d\n", type_of(x)); +#endif + error("mark botch"); + } + +} + +static void +sgc_mark_phase(void) { + + STATIC fixnum i, j; + STATIC struct package *pp; + STATIC bds_ptr bdp; + STATIC frame_ptr frp; + STATIC ihs_ptr ihsp; + STATIC struct pageinfo *v; + + sgc_mark_object(Cnil->s.s_plist); + sgc_mark_object(Ct->s.s_plist); + + /* mark all non recent data on writable pages */ + { + long t,i=page(heap_end); + struct typemanager *tm; + char *p; + + for (v=cell_list_head;v;v=v->next) { + i=page(v); + if (!WRITABLE_PAGE_P(i)) continue; + + t=v->type; + tm=tm_of(t); + p=pagetochar(i); + for (j = tm->tm_nppage; --j >= 0; p += tm->tm_size) { + object x = (object) p; + if (SGC_OR_M(x)) continue; + sgc_mark_object1(x); + } + } + } + + /* mark all non recent data on writable contiguous pages */ + if (what_to_collect == t_contiguous) + for (v=contblock_list_head;v;v=v->next) + if (v->sgc_flags&SGC_PAGE_FLAG) { + void *s=CB_DATA_START(v),*e=CB_DATA_END(v),*p,*q; + bool z=get_sgc_bit(v,s); + for (p=s;pbds_sym); + sgc_mark_object(bdp->bds_val); + } + + for (frp = frs_org; frp <= frs_top; frp++) + sgc_mark_object(frp->frs_val); + + for (ihsp = ihs_org; ihsp <= ihs_top; ihsp++) + sgc_mark_object(ihsp->ihs_function); + + for (i = 0; i < mark_origin_max; i++) + sgc_mark_object(*mark_origin[i]); + for (i = 0; i < mark_origin_block_max; i++) + for (j = 0; j < mark_origin_block[i].mob_size; j++) + sgc_mark_object(mark_origin_block[i].mob_addr[j]); + + for (pp = pack_pointer; pp != NULL; pp = pp->p_link) + sgc_mark_object((object)pp); +#ifdef KCLOVM + if (ovm_process_created) + sgc_mark_all_stacks(); +#endif + +#ifdef DEBUG + if (debug) { + printf("symbol navigation\n"); + fflush(stdout); + } +#endif + { + int size; + + for (pp = pack_pointer; pp != NULL; pp = pp->p_link) { + size = pp->p_internal_size; + if (pp->p_internal != NULL) + for (i = 0; i < size; i++) + sgc_mark_pack_list(pp->p_internal[i]); + size = pp->p_external_size; + if (pp->p_external != NULL) + for (i = 0; i < size; i++) + sgc_mark_pack_list(pp->p_external[i]); + } + } + + mark_c_stack(0,N_RECURSION_REQD,mark_stack_carefully); + +} + +static void +sgc_sweep_phase(void) { + STATIC long j, k; + STATIC object x; + STATIC char *p; + STATIC struct typemanager *tm; + STATIC object f; + int size; + STATIC struct pageinfo *v; + + for (v=cell_list_head;v;v=v->next) { + + tm = tm_of((enum type)v->type); + + if (!WRITABLE_PAGE_P(page(v))) + continue; + + p = pagetochar(page(v)); + f = tm->tm_free; + k = 0; + size=tm->tm_size; + + if (v->sgc_flags&SGC_PAGE_FLAG) { + + for (j = tm->tm_nppage; --j >= 0; p += size) { + + x = (object)p; + + if (is_free(x)) + continue; + else if (is_marked(x)) { + unmark(x); + continue; + } + + if (TYPEWORD_TYPE_P(pageinfo(x)->type) && x->d.s == SGC_NORMAL) + continue; + + /* it is ok to free x */ + + SET_LINK(x,f); + make_free(x); + if (TYPEWORD_TYPE_P(v->type)) x->d.s = SGC_RECENT; + f = x; + k++; + + } + tm->tm_free = f; + tm->tm_nfree += k; + v->in_use-=k; + + } else /*non sgc_page */ + for (j = tm->tm_nppage; --j >= 0; p += size) { + x = (object)p; + if (is_marked(x) && !is_free(x)) { + unmark(x); + } + } + + } +} + + +static void +sgc_contblock_sweep_phase(void) { + + STATIC char *s, *e, *p, *q; + STATIC struct pageinfo *v; + + cb_pointer = NULL; + ncb = 0; + for (v=contblock_list_head;v;v=v->next) { + bool z; + + if (!(v->sgc_flags&SGC_PAGE_FLAG)) continue; + + s=CB_DATA_START(v); + e=CB_DATA_END(v); + + z=get_mark_bit(v,s); + for (p=s;p> PAGEWIDTH))) + +/* char *old_rb_start; */ + +#undef tm + +#ifdef SDEBUG +sgc_count(object yy) { + fixnum count=0; + object y=yy; + while(y) + {count++; + y=OBJ_LINK(y);} + printf("[length %x = %d]",yy,count); + fflush(stdout); +} + +#endif + +fixnum writable_pages=0; + +/* count writable pages excluding the hole */ +static fixnum +sgc_count_writable(void) { + + return page(core_end)-page(rb_start)+writable_pages-(page(old_rb_start)-page(heap_end)); + +} + + +fixnum +sgc_count_type(int t) { + + if (t==t_relocatable) + return page(rb_limit)-page(rb_start); + else + return tm_of(t)->tm_npage-tm_of(t)->tm_alt_npage; + +} + +#ifdef SGC_CONT_DEBUG + +void +pcb(struct contblock *p) { + for (;p;p=p->cb_link) + printf("%p %d\n",p,p->cb_size); +} + +void +overlap_check(struct contblock *t1,struct contblock *t2) { + + struct contblock *p; + + for (;t1;t1=t1->cb_link) { + + if (!inheap(t1)) { + fprintf(stderr,"%p not in heap\n",t1); + exit(1); + } + + for (p=t2;p;p=p->cb_link) { + + if (!inheap(p)) { + fprintf(stderr,"%p not in heap\n",t1); + exit(1); + } + + if ((p<=t1 && (void *)p+p->cb_size>(void *)t1) || + (t1<=p && (void *)t1+t1->cb_size>(void *)p)) { + fprintf(stderr,"Overlap %u %p %u %p\n",t1->cb_size,t1,p->cb_size,p); + exit(1); + } + + if (p==p->cb_link) { + fprintf(stderr,"circle detected at %p\n",p); + exit(1); + } + + } + + if (t1==t1->cb_link) { + fprintf(stderr,"circle detected at %p\n",t1); + exit(1); + } + + } + +} + +void +tcc(struct contblock *t) { + + for (;t;t=t->cb_link) { + + if (!inheap(t)) { + fprintf(stderr,"%p not in heap\n",t); + break; + } + + fprintf(stderr,"%u at %p\n",t->cb_size,t); + + if (t==t->cb_link) { + fprintf(stderr,"circle detected at %p\n",t); + break; + } + + } + +} + +#endif + +typedef enum {memprotect_none,memprotect_cannot_protect,memprotect_sigaction, + memprotect_bad_return,memprotect_no_signal, + memprotect_multiple_invocations,memprotect_no_restart, + memprotect_bad_fault_address,memprotect_success} memprotect_enum; +static volatile memprotect_enum memprotect_result; +static int memprotect_handler_invocations,memprotect_print_enable; +static void *memprotect_test_address; + +#define MEM_ERR_CASE(a_) \ + case a_: \ + fprintf(stderr,"The SGC segfault recovery test failed with %s, SGC disabled\n",#a_); \ + break + +static void +memprotect_print(void) { + + if (!memprotect_print_enable) + return; + + switch(memprotect_result) { + case memprotect_none: case memprotect_success: + break; + + MEM_ERR_CASE(memprotect_cannot_protect); + MEM_ERR_CASE(memprotect_sigaction); + MEM_ERR_CASE(memprotect_bad_return); + MEM_ERR_CASE(memprotect_no_signal); + MEM_ERR_CASE(memprotect_no_restart); + MEM_ERR_CASE(memprotect_bad_fault_address); + MEM_ERR_CASE(memprotect_multiple_invocations); + + } + +} + + +static void +memprotect_handler_test(int sig, long code, void *scp, char *addr) { + + char *faddr; + faddr=GET_FAULT_ADDR(sig,code,scp,addr); + + if (memprotect_handler_invocations) { + memprotect_result=memprotect_multiple_invocations; + exit(-1); + } + memprotect_handler_invocations=1; + if (faddr!=memprotect_test_address) + memprotect_result=memprotect_bad_fault_address; + else + memprotect_result=memprotect_none; + gcl_mprotect(memprotect_test_address,PAGESIZE,PROT_READ_WRITE_EXEC); + +} + +static int +memprotect_test(void) { + + char *b1,*b2; + unsigned long p=PAGESIZE; + struct sigaction sa,sao,saob; + + if (memprotect_result!=memprotect_none) + return memprotect_result!=memprotect_success; + if (atexit(memprotect_print)) { + fprintf(stderr,"Cannot setup memprotect_print on exit\n"); + exit(-1); + } + + if (!(b1=alloca(2*p))) { + memprotect_result=memprotect_cannot_protect; + return -1; + } + + if (!(b2=alloca(p))) { + memprotect_result=memprotect_cannot_protect; + return -1; + } + + memset(b1,32,2*p); + memset(b2,0,p); + memprotect_test_address=(void *)(((unsigned long)b1+p-1) & ~(p-1)); + sa.sa_sigaction=(void *)memprotect_handler_test; + sa.sa_flags=MPROTECT_ACTION_FLAGS; + if (sigaction(SIGSEGV,&sa,&sao)) { + memprotect_result=memprotect_sigaction; + return -1; + } + if (sigaction(SIGBUS,&sa,&saob)) { + sigaction(SIGSEGV,&sao,NULL); + memprotect_result=memprotect_sigaction; + return -1; + } + { /* mips kernel bug test -- SIGBUS with no faddr when floating point is emulated. */ + float *f1=(void *)memprotect_test_address,*f2=(void *)b2,*f1e=f1+p/sizeof(*f1); + + if (gcl_mprotect(memprotect_test_address,p,PROT_READ_EXEC)) { + memprotect_result=memprotect_cannot_protect; + return -1; + } + memprotect_result=memprotect_bad_return; + for (;f1_b ? _a : _b;}) +/* If opt_maxpage is set, don't lose balancing information gained thus + far if we are triggered 'artificially' via a hole overrun. FIXME -- + try to allocate a small working set with the right proportions + later on. 20040804 CM*/ +#define WSGC(tm) ({struct typemanager *_tm=tm;long _t=MMAX(MMIN(_tm->tm_opt_maxpage,_tm->tm_npage),_tm->tm_sgc);_t*scale;}) +/* If opt_maxpage is set, add full pages to the sgc set if needed + too. 20040804 CM*/ +/* #define FSGC(tm) (tm->tm_type==t_cons ? tm->tm_nppage : (tm->tm_opt_maxpage ? 0 : tm->tm_sgc_minfree)) */ +#define FSGC(tm) (!TYPEWORD_TYPE_P(tm->tm_type) ? tm->tm_nppage : tm->tm_sgc_minfree) + +DEFVAR("*WRITABLE*",sSAwritableA,SI,Cnil,""); + +unsigned char *wrimap=NULL; + +int +sgc_start(void) { + + long i,count,minfree,allocate_more_pages=!saving_system && 10*available_pages>2*(real_maxpage-first_data_page); + long np; + struct typemanager *tm; + struct pageinfo *v; + object omp=sSAoptimize_maximum_pagesA->s.s_dbind; + double tmp,scale; + + sSAoptimize_maximum_pagesA->s.s_dbind=Cnil; + + if (memprotect_result!=memprotect_success && do_memprotect_test()) + return 0; + + if (sgc_enabled) + return 1; + + /* Reset maxpage statistics if not invoked automatically on a hole + overrun. 20040804 CM*/ + /* if (!hole_overrun) { */ + /* vs_mark; */ + /* object *old_vs_base=vs_base; */ + /* vs_base=vs_top; */ + /* FFN(siLreset_gbc_count)(); */ + /* vs_base=old_vs_base; */ + /* vs_reset; */ + /* } */ + + for (i=t_start,scale=1.0,tmp=0.0;iavailable_pages/10 ? (float)available_pages/(10*tmp) : 1.0; + + for (i= t_start; i < t_contiguous ; i++) { + + if (!TM_BASE_TYPE_P(i) || !(np=(tm=tm_of(i))->tm_sgc)) continue; + + minfree = FSGC(tm) > 0 ? FSGC(tm) : 1; + count=0; + + FIND_FREE_PAGES: + + for (v=cell_list_head;v && (counttm_sgc_max,WSGC(tm)));v=v->next) { + + if (v->type!=i || tm->tm_nppage-v->in_usesgc_flags|=SGC_PAGE_FLAG; + count++; + + } + + if (counttm_sgc_max,WSGC(tm)));v=v->next) { + + if (v->type!=i || tm->tm_nppage!=v->in_use) continue; + + v->sgc_flags|=SGC_PAGE_FLAG; + count++; + if (count >= MMAX(tm->tm_sgc_max,WSGC(tm))) + break; + } + + /* don't do any more allocations for this type if saving system */ + if (!allocate_more_pages) + continue; + + if (count < WSGC(tm)) { + /* try to get some more free pages of type i */ + long n = WSGC(tm) - count; + long again=0,nfree = tm->tm_nfree; + char *p=alloc_page(n); + if (tm->tm_nfree > nfree) again=1; /* gc freed some objects */ + if (tm->tm_npage+n>tm->tm_maxpage) + if (!set_tm_maxpage(tm,tm->tm_npage+n)) + n=0; + while (n-- > 0) { + /* (sgc_enabled=1,add_page_to_freelist(p,tm),sgc_enabled=0); */ + add_page_to_freelist(p,tm); + p += PAGESIZE; + } + if (again) + goto FIND_FREE_PAGES; + } + + } + + +/* SGC cont pages: Here we implement the contblock page division into + SGC and non-SGC types. Unlike the other types, we need *whole* + free pages for contblock SGC, as there is no persistent data + element (e.g. .m) on an allocated block itself which can indicate + its live status. If anything on a page which is to be marked + read-only points to a live object on an SGC cont page, it will + never be marked and will be erroneously swept. It is also possible + for dead objects to unnecessarily mark dead regions on SGC pages + and delay sweeping until the pointing type is GC'ed if SGC is + turned off for the pointing type, e.g. tm_sgc=0. (This was so by + default for a number of types, including bignums, and has now been + corrected in gcl_init_alloc in alloc.c.) We can't get around this + AFAICT, as old data on (writable) SGC pages must be marked lest it + is lost, and (old) data on now writable non-SGC pages might point + to live regions on SGC pages, yet might not themselves be reachable + from the mark origin through an unbroken chain of writable pages. + In any case, the possibility of a lot of garbage marks on contblock + pages, especially when the blocks are small as in bignums, makes + necessary the sweeping of minimal contblocks to prevent leaks. CM + 20030827 */ + + { + + void *p=NULL,*pe; + struct pageinfo *pi; + fixnum i,j,count=0; + struct contblock **cbpp; + + tm=tm_of(t_contiguous); + + for (pi=contblock_list_head;pi && countnext) { + + p=CB_DATA_START(pi); + pe=CB_DATA_END(pi); + + for (cbpp=&cb_pointer,j=0;*cbpp;cbpp=&(*cbpp)->cb_link) + if ((void*)*cbpp>=p && (void *)*cbppcb_size; + + if (j*tm->tm_nppagesgc_flags=SGC_PAGE_FLAG; + count+=pi->in_use; + + } + i=allocate_more_pages ? WSGC(tm) : (saving_system ? 1 : 0); + + if (i>count) { + /* SGC cont pages: allocate more if necessary, dumping possible + GBC freed pages onto the old contblock list. CM 20030827*/ + unsigned long z=(i-count)+1; + void *old_contblock_list_tail=contblock_list_tail; + + if (maxcbpagesgc_flags=SGC_PAGE_FLAG; + + } + + } + + /* Now allocate the sgc relblock. We do this as the tail + end of the ordinary rb. */ + { + char *new; + tm=tm_of(t_relocatable); + + { + old_rb_start=rb_start; + if(((unsigned long)WSGC(tm)) && allocate_more_pages) { + new=alloc_relblock(((unsigned long)WSGC(tm))*PAGESIZE); + /* the above may cause a gc, shifting the relblock */ + old_rb_start=rb_start; + new= PAGE_ROUND_UP(new); + } else new=PAGE_ROUND_UP(rb_pointer); + rb_start=rb_pointer=new; + } + } + /* the relblock has been allocated */ + + sSAwritableA->s.s_dbind=fSmake_vector1_1((page(rb_start)-first_data_page),aet_bit,Cnil); + wrimap=(void *)sSAwritableA->s.s_dbind->v.v_self; + + /* now move the sgc free lists into place. alt_free should + contain the others */ + for (i= t_start; i < t_contiguous ; i++) + if (TM_BASE_TYPE_P(i) && (np=(tm=tm_of(i))->tm_sgc)) { + object f=tm->tm_free ,x,y,next; + fixnum count=0; + x=y=OBJNULL; + + while (f!=OBJNULL) { + next=OBJ_LINK(f); +#ifdef SDEBUG + if (!is_free(f)) + printf("Not FREE in freelist f=%d",f); +#endif + if (pageinfo(f)->sgc_flags&SGC_PAGE_FLAG) { + SET_LINK(f,x); + if (TYPEWORD_TYPE_P(pageinfo(f)->type)) f->d.s = SGC_RECENT; + x=f; + count++; + } else { + SET_LINK(f,y); + if (TYPEWORD_TYPE_P(pageinfo(f)->type)) f->d.s = SGC_NORMAL; + y=f; + } + f=next; + } + tm->tm_free = x; + tm->tm_alt_free = y; + tm->tm_alt_nfree = tm->tm_nfree - count; + tm->tm_nfree=count; + } + + { + + struct pageinfo *pi; + + { + + struct contblock *new_cb_pointer=NULL,*tmp_cb_pointer=NULL,**cbpp; + void *p=NULL,*pe; + struct pageinfo *pi; + + for (pi=contblock_list_head;pi;pi=pi->next) { + + if (pi->sgc_flags!=SGC_PAGE_FLAG) continue; + + p=CB_DATA_START(pi); + pe=p+CB_DATA_SIZE(pi->in_use); + + for (cbpp=&cb_pointer;*cbpp;) + if ((void *)*cbpp>=p && (void *)*cbppcb_size,*l=(*cbpp)->cb_link; + set_sgc_bits(pi,s,e); + tmp_cb_pointer=cb_pointer; + cb_pointer=new_cb_pointer; + insert_contblock(s,e-s); + new_cb_pointer=cb_pointer; + cb_pointer=tmp_cb_pointer; + *cbpp=l; + } else + cbpp=&(*cbpp)->cb_link; + + } + + /* SGC contblock pages: switch to new free SGC contblock list. CM + 20030827 */ + old_cb_pointer=cb_pointer; + cb_pointer=new_cb_pointer; + +#ifdef SGC_CONT_DEBUG + overlap_check(old_cb_pointer,cb_pointer); +#endif + } + + for (i=t_start;itm_alt_npage=0; + writable_pages=0; + + for (pi=cell_list_head;pi;pi=pi->next) { + if (pi->sgc_flags&SGC_WRITABLE) + SET_WRITABLE(page(pi)); + else + tm_of(pi->type)->tm_alt_npage++; + } + for (pi=contblock_list_head;pi;pi=pi->next)/*FIXME*/ + if (pi->sgc_flags&SGC_WRITABLE) + for (i=0;iin_use;i++) + SET_WRITABLE(page(pi)+i); + else + tm_of(t_contiguous)->tm_alt_npage+=pi->in_use; + { + extern object malloc_list; + object x; + + for (x=malloc_list;x!=Cnil;x=x->c.c_cdr) + if (x->c.c_car->st.st_adjustable) + for (i=page(x->c.c_car->st.st_self);i<=page(x->c.c_car->st.st_self+x->c.c_car->st.st_fillp-1);i++) + SET_WRITABLE(i); + } + + for (i=page(heap_end);itm_alt_npage=page(rb_start)-page(old_rb_start); + for (i=page(rb_start);is.s_dbind != Cnil) { + printf("[SGC on]"); + fflush(stdout); + } + + sSAoptimize_maximum_pagesA->s.s_dbind=omp; + + return 1; + +} + +/* int */ +/* pdebug(void) { */ + +/* extern object malloc_list; */ +/* object x=malloc_list; */ +/* struct pageinfo *v; */ +/* for (;x!=Cnil;x=x->c.c_cdr) */ +/* printf("%p %d\n",x->c.c_car->st.st_self,x->c.c_car->st.st_dim); */ + +/* for (v=contblock_list_head;v;v=v->next) */ +/* printf("%p %ld\n",v,v->in_use<<12); */ +/* return 0; */ +/* } */ + + +int +sgc_quit(void) { + + struct typemanager *tm; + struct contblock *tmp_cb_pointer,*next; + unsigned long i,j,np; + char *p; + struct pageinfo *v; + + memory_protect(0); + + if(sSAnotify_gbcA->s.s_dbind != Cnil) + printf("[SGC off]"); fflush(stdout); + + if (sgc_enabled==0) + return 0; + + sSAwritableA->s.s_dbind=Cnil; + wrimap=NULL; + + sgc_enabled=0; + rb_start = old_rb_start; + + /* SGC cont pages: restore contblocks, each tmp_cb_pointer coming + from the new list is guaranteed not to be on the old. Need to + grab 'next' before insert_contblock writes is. CM 20030827 */ + + if (old_cb_pointer) { +#ifdef SGC_CONT_DEBUG + overlap_check(old_cb_pointer,cb_pointer); +#endif + tmp_cb_pointer=cb_pointer; + cb_pointer=old_cb_pointer; + for (;tmp_cb_pointer; tmp_cb_pointer=next) { + next=tmp_cb_pointer->cb_link; + insert_contblock((void *)tmp_cb_pointer,tmp_cb_pointer->cb_size); + } + } + + for (i= t_start; i < t_contiguous ; i++) + + if (TM_BASE_TYPE_P(i) && (np=(tm=tm_of(i))->tm_sgc)) { + + object f,y; + + f=tm->tm_free; + if (f==OBJNULL) + tm->tm_free=tm->tm_alt_free; + else { + /* tack the alt_free onto the end of free */ +#ifdef SDEBUG + fixnum count=0; + f=tm->tm_free; + while(y= (object) F_LINK(f)) { + if(y->d.s != SGC_RECENT) + printf("[bad %d]",y); + count++; f=y; + } + + count=0; + if (f==tm->tm_alt_free) + while(y= F_LINK(f)) { + if(y->d.s != SGC_NORMAL) + printf("[alt_bad %d]",y); + count++; f=y; + } + +#endif + f=tm->tm_free; + while((y= (object) F_LINK(f))!=OBJNULL) + f=y; + F_LINK(f)= (long)(tm->tm_alt_free); + } + /* tm->tm_free has all of the free objects */ + tm->tm_nfree += tm->tm_alt_nfree; + tm->tm_alt_nfree = 0; + tm->tm_alt_free = OBJNULL; + + } + + /*FIXME*/ + /* remove the recent flag from any objects on sgc pages */ + for (v=cell_list_head;v;v=v->next) + if (v->type==(tm=tm_of(v->type))->tm_type && TYPEWORD_TYPE_P(v->type) && v->sgc_flags & SGC_PAGE_FLAG) + for (p=pagetochar(page(v)),j=tm->tm_nppage;j>0;--j,p+=tm->tm_size) + ((object) p)->d.s=SGC_NORMAL; + + for (v=contblock_list_head;v;v=v->next) + if (v->sgc_flags&SGC_PAGE_FLAG) + bzero(CB_SGCF_START(v),CB_DATA_START(v)-CB_SGCF_START(v)); + + { + struct pageinfo *pi; + for (pi=cell_list_head;pi;pi=pi->next) + pi->sgc_flags&=SGC_PERM_WRITABLE; + for (pi=contblock_list_head;pi;pi=pi->next) + pi->sgc_flags&=SGC_PERM_WRITABLE; + } + + return 0; + +} + +fixnum debug_fault =0; +fixnum fault_count =0; +extern char etext; +static void +memprotect_handler(int sig, long code, void *scp, char *addr) { + + unsigned long p; + void *faddr; /* Needed because we must not modify signal handler + arguments on the stack! */ +#ifdef GET_FAULT_ADDR + faddr=GET_FAULT_ADDR(sig,code,scp,addr); + debug_fault = (long) faddr; +#ifdef DEBUG_MPROTECT + printf("fault:0x%x [%d] (%d) ",faddr,page(faddr),faddr >= core_end); +#endif + if (faddr >= (void *)core_end || faddr < data_start) { + static void *old_faddr; + if (old_faddr==faddr) + if (fault_count++ > 300) error("fault count too high"); + old_faddr=faddr; + INSTALL_MPROTECT_HANDLER; + return; + } +#else + faddr = addr; +#endif + p = page(faddr); + /* p = ROUND_DOWN_PAGE_NO(p); */ + if (p >= first_protectable_page + && faddr < (void *)core_end + && !(WRITABLE_PAGE_P(p))) { + /* CHECK_RANGE(p,1); */ +#ifdef DEBUG_MPROTECT + printf("mprotect(0x%x,0x%x,0x%x)\n", + pagetoinfo(p),PAGESIZE, sbrk(0)); + fflush(stdout); +#endif + +#ifndef BSD + INSTALL_MPROTECT_HANDLER; +#endif + + massert(!gcl_mprotect(pagetoinfo(p),PAGESIZE,PROT_READ_WRITE_EXEC)); + SET_WRITABLE(p); + fault_pages++; + + return; + + } + +#ifndef BSD + INSTALL_MPROTECT_HANDLER; +#endif + + segmentation_catcher(0); + +} + +static int +sgc_mprotect(long pbeg, long n, int writable) { + /* CHECK_RANGE(pbeg,n); */ +#ifdef DEBUG_MPROTECT + printf("prot[%d,%d,(%d),%s]\n",pbeg,pbeg+n,writable & SGC_WRITABLE, + (writable & SGC_WRITABLE ? "writable" : "not writable")); + printf("mprotect(0x%x,0x%x), sbrk(0)=0x%x\n", + pagetoinfo(pbeg), n * PAGESIZE, sbrk(0)); + fflush(stdout); +#endif + if(gcl_mprotect(pagetoinfo(pbeg),n*PAGESIZE,(writable & SGC_WRITABLE ? PROT_READ_WRITE_EXEC : PROT_READ_EXEC))) { + perror("sgc disabled"); + return -1; + } + + return 0; + +} + + + +int +memory_protect(int on) { + + unsigned long i,beg,end= page(core_end); + int writable=1; + extern void install_segmentation_catcher(void); + + + first_protectable_page=first_data_page; + + /* turning it off */ + if (on==0) { + sgc_mprotect(first_protectable_page,end-first_protectable_page,SGC_WRITABLE); + install_segmentation_catcher(); + return 0; + } + + INSTALL_MPROTECT_HANDLER; + + beg=first_protectable_page; + writable = IS_WRITABLE(beg); + for (i=beg ; ++i<= end; ) { + + if (writable==IS_WRITABLE(i) && i<=end) continue; + + if (sgc_mprotect(beg,i-beg,writable)) + return -1; + writable=1-writable; + beg=i; + + } + + return 0; + +} + +static void +FFN(siLsgc_on)(void) { + + if (vs_base==vs_top) { + vs_base[0]=(sgc_enabled ? Ct :Cnil); + vs_top=vs_base+1; return; + } + check_arg(1); + if(vs_base[0]==Cnil) + sgc_quit(); + else + vs_base[0]=sgc_start() ? Ct : Cnil; +} + +void +system_error(void) { + FEerror("System error",0); +} diff --git a/o/sgi4d_emul.s b/o/sgi4d_emul.s new file mode 100755 index 0000000..fbb1e67 --- /dev/null +++ b/o/sgi4d_emul.s @@ -0,0 +1,68 @@ +#include + + /* earith.s for MIPS R2000 processor + by Doug Katzman + version 2.1.d dated 7/13/89 15:31 EDT */ + + # mods 7/13/89: + # emul: never conditionally branch + # ediv: improved code ordering allows jmp delay slot optimization by 'as' + # + .text + .align 2 + + .globl extended_mul + # extended_mul(d, q, r, hp, lp) + # unsigned int d, q, r, *hp, *lp; + # { + .ent extended_mul +extended_mul: + .frame sp, 0, ra + + mult a0, a1 # [hi:lo] = d * q + mfhi a1 + sll a1, 1 + mflo a0 + srl t7, a0, 31 + and a0, 0x7fffffff + or a1, t7 + addu a0, a2 # [a1:a0] += r + srl t7, a0, 31 + and a0, 0x7fffffff + addu a1, t7 + sw a1, 0(a3) # *hp = a1 + lw a3, 16(sp) # fetch fifth actual argument from stack + sw a0, 0(a3) # *lp = a0 + # } + j ra + .end extended_mul + + .globl extended_div + # extended_div(d, h, l, qp, rp) + # unsigned int d, h, l, *qp, *rp; + # { + .ent extended_div +extended_div: + .frame sp, 0, ra + + sll a2, 1 + li v0, 31 # v0 holds number of shifts +loop: + srl t7, a2, 31 + sll a1, 1 + or a1, t7 + sll a2, 1 + subu t7, a1, a0 # t = h - d + bltz t7, underflow + move a1, t7 + or a2, 1 +underflow: + subu v0, 1 + bnez v0, loop + sw a2, 0(a3) # *qp = l + lw a3, 16(sp) # fetch fifth actual argument from stack + sw a1, 0(a3) # *rp = h + # } + j ra + .end extended_div + diff --git a/o/sockets.c b/o/sockets.c new file mode 100755 index 0000000..0a49480 --- /dev/null +++ b/o/sockets.c @@ -0,0 +1,571 @@ +/* + Copyright (C) 1994 Rami el Charif, W. Schelter + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#define IN_SOCKETS +#include +#include "include.h" + +#ifdef HAVE_NSOCKET + +#include "sheader.h" + +#include +#ifndef __MINGW32__ +# include +# include +# include +#else +# include +# include +#endif + +#ifdef __STDC__ +#include +#endif + +#ifndef __MINGW32__ +# include +#endif + +#include +#ifndef NO_UNISTD_H +#include +#endif +#include +/*#include */ + +#include + +static void write_timeout_error(); +static void connection_failure(); + +#ifdef __MINGW32__ +/* Keep track of socket initialisations */ +int w32_socket_initialisations = 0; +WSADATA WSAData; + +int w32_socket_init(void) +{ + int rv = 0; + if (w32_socket_initialisations++) { + rv = 0; + } else { + if (WSAStartup(0x0101, &WSAData)) { + w32_socket_initialisations = 0; + fprintf ( stderr, "WSAStartup failed\n" ); + WSACleanup(); + rv = -1; + } + } + + return rv; +} + +int w32_socket_exit(void) +{ + int rv = 0; + + if ( w32_socket_initialisations == 0 || + --w32_socket_initialisations > 0 ) { + rv = 0; + } else { + rv = WSACleanup(); + } + + return rv; +} + +#endif + +#define BIND_MAX_RETRY 128 +#define BIND_ADDRESS_INCREMENT 16 +#define BIND_INITIAL_ADDRESS 5000 +#define BIND_LAST_ADDRESS 65534 +static unsigned int iLastAddressUsed = BIND_INITIAL_ADDRESS; + +DEFUN_NEW("OPEN-NAMED-SOCKET",object,fSopen_named_socket,SI,1,1,NONE,OI,OO,OO,OO,(fixnum port), +"Open a socket on PORT and return (cons fd portname) where file \ +descriptor is a small fixnum which is the write file descriptor for \ +the socket. If PORT is zero do automatic allocation of port") +{ +#ifdef __MINGW32__ + SOCKET s; +#else + int s; +#endif + int n, rc; + struct sockaddr_in addr; + +#ifdef __MINGW32__ + if ( w32_socket_init() < 0 ) { + perror("ERROR !!! Windows socket DLL initialisation failed in sock_connect_to_name\n"); + return Cnil; + } +#endif + + /* Using TCP layer */ + s = socket(PF_INET, SOCK_STREAM, 0); +#ifdef __MINGW32__ + if ( s == INVALID_SOCKET ) +#else + if (s < 0) +#endif + { + perror("ERROR !!! socket creation failed in sock_connect_to_name\n"); + return Cnil; + } + + addr.sin_family = PF_INET; + addr.sin_addr.s_addr = INADDR_ANY; + memset(addr.sin_zero, 0, 8); + n = sizeof addr; + + if (port == 0) + { +#define MY_HTONS(x) htons((unsigned short)((x) & 0xffff)) + int cRetry = 0; + do { + addr.sin_port = MY_HTONS(iLastAddressUsed); + rc = bind(s, (struct sockaddr *)&addr, n); + + cRetry++; + iLastAddressUsed += BIND_ADDRESS_INCREMENT; + if (iLastAddressUsed > BIND_LAST_ADDRESS) + iLastAddressUsed = BIND_INITIAL_ADDRESS; + } while ((rc < 0) && +#ifdef __MINGW32__ + (errno == WSAEADDRINUSE) && +#else + (errno == EADDRINUSE) && +#endif + (cRetry < BIND_MAX_RETRY)); + if (0) + { + fprintf(stderr, + "\nAssigned automatic address to socket : port(%d), errno(%d), bind_rc(%d), iLastAddressUsed(%d), retries(%d)\n" + , addr.sin_port, errno, rc, iLastAddressUsed, cRetry + ); + fflush(stderr); + } + } + else + { + addr.sin_port = MY_HTONS(port); + rc = bind(s, (struct sockaddr *)&addr, n); + } + if (rc < 0) + { + perror("ERROR !!! Failed to bind socket in sock_open_named_socket\n"); + close(s); + return Cnil; + } + rc = listen(s, 3); + if (rc < 0) + { + perror("ERROR ! listen failed on socket in sock_open_named_socket"); + close(s); + return Cnil; + } + + return make_cons(make_fixnum(s), make_fixnum(ntohs(addr.sin_port))); +} + +DEFUN_NEW("CLOSE-FD",object,fSclose_fd,SI,1,1,NONE,OI,OO,OO,OO,(fixnum fd), + "Close the file descriptor FD") + +{RETURN1(0==close(fd) ? Ct : Cnil);} + +DEFUN_NEW("CLOSE-SD",object,fSclose_sfd,SI,1,1,NONE,OO,OO,OO,OO,(object sfd), + "Close the socket connection sfd") + +{ int res; + free(OBJ_TO_CONNECTION_STATE(sfd)->read_buffer); + res = close(OBJ_TO_CONNECTION_STATE(sfd)->fd); + free (OBJ_TO_CONNECTION_STATE(sfd)); +#ifdef __MINGW32__ + w32_socket_exit(); +#endif + RETURN1(res ? Ct : Cnil); +} + + +DEFUN_NEW("ACCEPT-SOCKET-CONNECTION",object,fSaccept_socket_connection, + SI,1,1,NONE,OO,OO,OO,OO,(object named_socket), + "Given a NAMED_SOCKET it waits for a connection on this \ +and returns (list* named_socket fd name1) when one is established") + +{ + socklen_t n; + int fd; + struct sockaddr_in addr; + object x; + n = sizeof addr; + fd = accept(fix(car(named_socket)) , (struct sockaddr *)&addr, &n); + if (fd < 0) + { + perror("ERROR ! accept on socket failed in sock_accept_connection"); + fflush(stderr); + return Cnil; + } + x = alloc_simple_string(sizeof(struct connection_state)); + x->ust.ust_self = (void *)setup_connection_state(fd); + return make_cons( + make_cons(x + , make_simple_string( + inet_ntoa(addr.sin_addr))), + named_socket + ); +} + +/* static object */ +/* sock_hostname_to_hostid_list(host_name) */ +/* char *host_name; */ +/* { */ +/* struct hostent *h; */ +/* object addr_list = Cnil; */ +/* int i; */ + +/* h = gethostbyname(host_name); */ + +/* for (i = 0; h->h_addr_list[i] != 0; i++) */ +/* { */ +/* addr_list = make_cons(make_simple_string(inet_ntoa(*(struct in_addr *)h->h_addr_list[i])), addr_list); */ +/* } */ +/* return addr_list; */ +/* } */ + + + + +DEFUN_NEW("HOSTNAME-TO-HOSTID",object,fShostname_to_hostid,SI,1,1, + NONE,OO,OO,OO,OO,(object host),"") +{ + struct hostent *h; + char buf[300]; + char *p; + p = lisp_copy_to_null_terminated(host,buf,sizeof(buf)); + h = /* gethostbyname(p); */ +#ifdef STATIC_LINKING + NULL; +#else + gethostbyname(p); +#endif + if (p != buf) free (p); + if (h && h->h_addr_list[0]) + return + make_simple_string(inet_ntoa(*(struct in_addr *)h->h_addr_list[0])); + else return Cnil; +} + +DEFUN_NEW("GETHOSTNAME",object,fSgethostname,SI,0,0,NONE,OO,OO,OO,OO,(void), + "Returns HOSTNAME of the local host") + +{char buf[300]; + if (0 == gethostname(buf,sizeof(buf))) + return make_simple_string(buf); + else return Cnil; +} + +DEFUN_NEW("HOSTID-TO-HOSTNAME",object,fShostid_to_hostname,SI, + 1,10,NONE,OO,OO,OO,OO,(object host_id),"") + +{char *hostid; + struct in_addr addr; + struct hostent *h; + char buf[300]; + hostid = lisp_copy_to_null_terminated(host_id,buf,sizeof(buf)); + addr.s_addr = inet_addr(hostid); + h = /* gethostbyaddr((char *)&addr, 4, AF_INET); */ +#ifdef STATIC_LINKING + NULL; +#else + gethostbyaddr((char *)&addr, 4, AF_INET); +#endif + if (h && h->h_name && *h->h_name) + return make_simple_string(h->h_name); + else + return Cnil; +} + +/* static object */ +/* sock_get_name(s) */ +/* int s; */ +/* { */ +/* struct sockaddr_in addr; */ +/* int m = sizeof(addr); */ +/* getsockname(s, (struct sockaddr *)&addr, &m); */ +/* return make_cons( */ +/* make_cons( */ +/* make_fixnum(addr.sin_port) */ +/* , make_simple_string(inet_ntoa(addr.sin_addr)) */ +/* ) */ +/* ,make_cons(make_fixnum(addr.sin_family) */ +/* , make_fixnum(s)) */ +/* ); */ +/* } */ + +#include "comm.c" + + +DEFUN_NEW("CONNECTION-STATE-FD",object,fSconnection_state_fd,SI,1,1,NONE,OO,OO,OO,OO,(object sfd),"") +{ return make_fixnum(OBJ_TO_CONNECTION_STATE(sfd)->fd); +} + +DEFUN_NEW("OUR-WRITE",object,fSour_write,SI,3,3,NONE,OO,OI,OO,OO,(object sfd,object buffer,fixnum nbytes),"") + +{ return make_fixnum(write1(OBJ_TO_CONNECTION_STATE(sfd),buffer->st.st_self,nbytes)); +} + +DEFUN_NEW("OUR-READ-WITH-OFFSET",object,fSour_read_with_offset,SI,5,5,NONE, + OO,OI,II,OO,(object fd,object buffer,fixnum offset,fixnum nbytes,fixnum timeout), + "Read from STATE-FD into string BUFFER putting data at OFFSET and reading NBYTES, waiting for TIMEOUT before failing") + +{ return make_fixnum(read1(OBJ_TO_CONNECTION_STATE(fd),&((buffer)->ust.ust_self[offset]),nbytes,timeout)); +} + + +enum print_arglist_codes { + normal, + no_leading_space, + join_follows, + end_join, + begin_join, + begin_join_no_leading_space, + no_quote, + no_quote_no_leading_space, + no_quote_downcase, + no_quotes_and_no_leading_space + }; + + /* push object X into the string with fill pointer STR, according to CODE + */ + + +#define PUSH(_c) do{if (--left < 0) goto FAIL; \ + *xx++ = _c;}while(0) + + +#define BEGIN_QUOTE '"' +#define END_QUOTE '"' + +static int needs_quoting[256]; + +DEFUN_NEW("PRINT-TO-STRING1",object,fSprint_to_string1,SI,3,3,NONE,OO,OO,OO,OO,(object str,object x,object the_code), + "Print to STRING the object X according to CODE. The string must have \ +fill pointer, and this will be advanced.") + +{ enum type t = type_of(x); + int fp = str->st.st_fillp; + char *xx = &(str->st.st_self[fp]); + int left = str->st.st_dim - fp; + char buf[30]; + char *p; + enum print_arglist_codes code = fix(the_code); + + if (code==no_quote || code == no_quotes_and_no_leading_space) + { needs_quoting['"']=0; + needs_quoting['$']=0; + needs_quoting['\\']=0; + needs_quoting['[']=0; +/* needs_quoting[']']=0; */ + } + else { needs_quoting['"']=1; + needs_quoting['$']=1; + needs_quoting['\\']=1; + needs_quoting['[']=1; +/* needs_quoting[']']=1; */ + } + { + int downcase ; + int do_end_quote = 0; + if(type_of(str)!=t_string) + FEerror("Must be given string with fill pointer",0); + if (t==t_symbol) downcase=1; + else downcase=0; + + switch (code){ + + case no_quote_downcase: + downcase = 1; + case no_quote: + PUSH(' '); + case no_quotes_and_no_leading_space: + case no_quote_no_leading_space: + break; + + case normal: + PUSH(' '); + case no_leading_space: + if (t==t_string) + { do_end_quote = 1; + PUSH(BEGIN_QUOTE); + } + break; + + case begin_join: + PUSH(' '); + case begin_join_no_leading_space: + PUSH(BEGIN_QUOTE); + break; + case end_join: + do_end_quote=1; + break; + case join_follows: + + + break; + default: abort(); + } + + switch (t) { + case t_symbol: + if (x->s.s_hpack == keyword_package) + {if (code == normal) + PUSH('-');} + case t_string: + {int len = x->st.st_fillp; + p = &x->st.st_self[0]; + if (downcase) + while (--len>=0) + { char c = *p++; + c=tolower(c); + if(needs_quoting[(unsigned char)c]) + PUSH('\\'); + PUSH(c);} + else + while (--len>=0) + { char c = *p++; + if(needs_quoting[(unsigned char)c]) + PUSH('\\'); + PUSH(c);}} + break; + case t_fixnum: + sprintf(buf,"%ld",fix(x)); + p = buf; + while(*p) {PUSH(*p);p++;} + break; + case t_longfloat: + sprintf(buf,"%.2f",lf(x)); + p = buf; + while(*p) {PUSH(*p);p++;} + break; + case t_shortfloat: + sprintf(buf,"%.2f",sf(x)); + p = buf; + while(*p) {PUSH(*p);p++;} + break; + case t_bignum: + goto FAIL; + default: + FEerror("Bad type for print_string ~s",1,x); + } + if(do_end_quote) PUSH('"'); + str->st.st_fillp += (xx - &(str->st.st_self[fp])); + return Ct; + FAIL: + + /* either ran out of storage or tried to print a bignum. + The caller will handle these two cases + */ + return Cnil; + } +} + +static void +not_defined_for_os() +{ FEerror("Function not defined for this operating system",0);} + + +DEFUN_NEW("SET-SIGIO-FOR-FD",object,fSset_sigio_for_fd,SI,1,1,NONE,OI,OO,OO,OO,(fixnum fd),"") + +{ + /* for the moment we will use SIGUSR1 to notify, instead of depending on SIGIO, + since LINUX does not support the latter yet... + So right now this does nothing... + */ +#if !defined(FASYNC) || !defined(SET_FD_TO_GIVE_SIGIO) + not_defined_for_os(); + +#else +#ifdef SET_FD_TO_GIVE_SIGIO + SET_FD_TO_GIVE_SIGIO(fd); +#else + /* want something like this... but wont work on all machines. */ + flags = fcntl(fd,F_GETFL,0); + if (flags == -1 + || ( flags |= FASYNC , 0) + || -1 == fcntl(fd,F_SETFL,flags) + || -1 == fcntl(fd,F_SETOWN,getpid())) + {perror("Could not set ASYNC IO for SIGIO:"); + return Cnil;} +#endif +#endif + + return (Ct); + +} + +DEFUN_NEW("RESET-STRING-INPUT-STREAM",object,fSreset_string_input_stream,SI,4,4,NONE,OO,OI,IO,OO,(object strm,object string,fixnum start,fixnum end), + "Reuse a string output STREAM by setting its output to STRING \ +and positioning the ouput/input to start at START and end at END") + +{ strm->sm.sm_object0 = string; + strm->sm.sm_int0 = start; + strm->sm.sm_int1 = end; + return strm; +} + +DEFUN_NEW("CHECK-STATE-INPUT",object,fScheck_state_input,SI,2,2,NONE,OO,IO,OO,OO,(object osfd,fixnum timeout), + "") +{ + return fScheck_dsfd_for_input(OBJ_TO_CONNECTION_STATE(osfd),timeout); + +} + +DEFUN_NEW("CLEAR-CONNECTION-STATE",object,fSclear_connection_state, + SI,1,1,NONE,OO,OO,OO,OO,(object osfd), + "Read on FD until nothing left to read. Return number of bytes read") + +{ + struct connection_state *sfd = OBJ_TO_CONNECTION_STATE(osfd); + int n=fix(FFN(fSclear_connection)(sfd->fd)); + + sfd->valid_data = sfd->read_buffer; + sfd->valid_data_size = 0; + sfd->bytes_received_not_confirmed += n; + return make_fixnum(n); +} + +#endif + +static void +write_timeout_error(s) + char *s; +{FEerror("Write timeout: ~s",1,make_simple_string(s)); +} + +static void +connection_failure(s) + char *s; +{FEerror("Connect failure: ~s",1,make_simple_string(s)); +} + + diff --git a/o/strcspn.c b/o/strcspn.c new file mode 100755 index 0000000..2448454 --- /dev/null +++ b/o/strcspn.c @@ -0,0 +1,16 @@ +size_t +strcspn(const char *s1, const char *s2) +{ + register char *scan1; + register char *scan2; + register int count; + + count = 0; + for (scan1 = s1; *scan1 != '\0'; scan1++) { + for (scan2 = s2; *scan2 != '\0';) /* ++ moved down. */ + if (*scan1 == *scan2++) + return(count); + count++; + } + return(count); +} diff --git a/o/string.d b/o/string.d new file mode 100755 index 0000000..ee847b5 --- /dev/null +++ b/o/string.d @@ -0,0 +1,633 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +*/ + +/* + string.d + + string routines +*/ + +#include "include.h" + +object sKstart1; +object sKend1; +object sKstart2; +object sKend2; +object sKinitial_element; +object sKelement_type; + +object +alloc_simple_string(l) +int l; +{ + object x; + + x = alloc_object(t_string); + x->st.st_hasfillp = FALSE; + x->st.st_adjustable = FALSE; + x->st.st_displaced = Cnil; + x->st.st_dim = x->st.st_fillp = l; + x->st.st_self = NULL; + return(x); +} + +/* + Make_simple_string(s) makes a simple string from C string s. +*/ +object +make_simple_string(s) +const char *s; +{ + int l, i; + char *p; + object x; + vs_mark; + {BEGIN_NO_INTERRUPT; + for (l = 0; s[l] != '\0'; l++) + ; + x = alloc_simple_string(l); + vs_push(x); + p = alloc_relblock(l); + for (i = 0; i < l; i++) + p[i] = s[i]; + x->st.st_self = p; + vs_reset; + END_NO_INTERRUPT;} + return(x); +} + +/* + This correponds to string= (just the string equality). +*/ +bool +string_eq(x, y) +object x, y; +{ + int i, j; + +/* + if (type_of(x) != t_string || type_of(y) != t_string) + error("string expected"); +*/ + i = x->st.st_fillp; + j = y->st.st_fillp; + if (i != j) + return(FALSE); + for (i = 0; i < j; i++) + if (x->st.st_self[i] != y->st.st_self[i]) + return(FALSE); + return(TRUE); +} + +/* + This corresponds to string-equal + (string equality ignoring the case). +*/ +bool +string_equal(x, y) +object x, y; +{ + int i, j; + char *p, *q; + +/* + if (type_of(x) != t_string || type_of(y) != t_string) + error("string expected"); +*/ + i = x->st.st_fillp; + j = y->st.st_fillp; + if (i != j) + return(FALSE); + p = x->st.st_self; + q = y->st.st_self; + for (i = 0; i < j; i++) + if ((isLower(p[i]) ? p[i] - ('a' - 'A') : p[i]) + != (isLower(q[i]) ? q[i] - ('a' - 'A') : q[i])) + return(FALSE); + return(TRUE); +} + +/* + Copy_simple_string(x) copies string x to a simple string. +*/ +object +copy_simple_string(x) +object x; +{ + object y; + int i; + vs_mark; + + vs_push(x); +/* + if (type_of(x) != t_string) + error("string expected"); +*/ + {BEGIN_NO_INTERRUPT; + y = alloc_object(t_string); + y->st.st_dim = y->st.st_fillp = x->st.st_fillp; + y->st.st_hasfillp = FALSE; + y->st.st_adjustable = FALSE; + y->st.st_displaced = Cnil; + y->st.st_self = NULL; + vs_push(y); + y->st.st_self = alloc_relblock(x->st.st_fillp); + for (i = 0; i < x->st.st_fillp; i++) + y->st.st_self[i] = x->st.st_self[i]; + vs_reset; + END_NO_INTERRUPT; } + return(y); +} + +object +coerce_to_string(x) +object x; +{ + object y; + int i; + vs_mark; + + switch (type_of(x)) { + case t_symbol: + {BEGIN_NO_INTERRUPT; + y = alloc_simple_string(x->s.s_fillp); + vs_push(y); + if (x->s.s_self < heap_end) + y->st.st_self = x->s.s_self; + else { + y->st.st_self = alloc_relblock(x->s.s_fillp); + for (i = 0; i < x->s.s_fillp; i++) + y->st.st_self[i] = x->s.s_self[i]; + } + vs_reset; + END_NO_INTERRUPT;} + return(y); + + case t_fixnum: + x = coerce_to_character(x); + vs_push(x); + + case t_character: + {BEGIN_NO_INTERRUPT; + y = alloc_simple_string(1); + vs_push(y); + y->st.st_self = alloc_relblock(1); + y->st.st_self[0] = char_code(x); + vs_reset; + END_NO_INTERRUPT;} + return(y); + + case t_string: + return(x); + default: + break; + } + vs_push(x); + x=wrong_type_argument(sLstring,x); + vs_popp; + return(Cnil); +} + +@(defun char (s i) + int j; +@ + check_type_string(&s); + if (type_of(i) != t_fixnum) + illegal_index(s, i); + if ((j = fix(i)) < 0 || j >= s->st.st_dim) + illegal_index(s, i); + @(return `code_char(s->ust.ust_self[j])`) +@) + +LFD(siLchar_set)() +{ + int j; + + check_arg(3); + check_type_string(&vs_base[0]); + if (type_of(vs_base[1]) != t_fixnum) + illegal_index(vs_base[0], vs_base[1]); + if ((j = fix(vs_base[1])) < 0 || j >= vs_base[0]->st.st_dim) + illegal_index(vs_base[0], vs_base[1]); + check_type_character(&vs_base[2]); + vs_base[0]->st.st_self[j] = char_code(vs_base[2]); + vs_base += 2; +} + +void +get_string_start_end(string, start, end, ps, pe) +object string, start, end; +int *ps, *pe; +{ + if (start == Cnil) + *ps = 0; + else if (type_of(start) != t_fixnum) + goto E; + else { + *ps = fix(start); + if (*ps < 0) + goto E; + } + if (end == Cnil) { + *pe = string->st.st_fillp; + if (*pe < *ps) + goto E; + } else if (type_of(end) != t_fixnum) + goto E; + else { + *pe = fix(end); + if (*pe < *ps || *pe > string->st.st_fillp) + goto E; + } + return; + +E: + FEerror("~S and ~S are illegal as :START and :END~%\ +for the string ~S.", 3, start, end, string); +} + +@(defun string_eq (string1 string2 + &key start1 end1 start2 end2) + int s1=0, e1=0, s2=0, e2=0; +@ + string1 = coerce_to_string(string1); + string2 = coerce_to_string(string2); + get_string_start_end(string1, start1, end1, &s1, &e1); + get_string_start_end(string2, start2, end2, &s2, &e2); + if (e1 - s1 != e2 - s2) + @(return Cnil) + while (s1 < e1) + if (string1->st.st_self[s1++] != + string2->st.st_self[s2++]) + @(return Cnil) + @(return Ct) +@) + +@(defun string_equal (string1 string2 + &key start1 end1 start2 end2) + int s1=0, e1=0, s2=0, e2=0; + int i1, i2; +@ + string1 = coerce_to_string(string1); + string2 = coerce_to_string(string2); + get_string_start_end(string1, start1, end1, &s1, &e1); + get_string_start_end(string2, start2, end2, &s2, &e2); + if (e1 - s1 != e2 - s2) + @(return Cnil) + while (s1 < e1) { + i1 = string1->st.st_self[s1++]; + i2 = string2->st.st_self[s2++]; + if (isLower(i1)) + i1 -= 'a' - 'A'; + if (isLower(i2)) + i2 -= 'a' - 'A'; + if (i1 != i2) + @(return Cnil) + } + @(return Ct) +@) + + +int string_sign, string_boundary; + +@(static defun string_cmp (string1 string2 + &key start1 end1 start2 end2) + int s1=0, e1=0, s2=0, e2=0; + int i1, i2; + int s; +@ + string1 = coerce_to_string(string1); + string2 = coerce_to_string(string2); + get_string_start_end(string1, start1, end1, &s1, &e1); + get_string_start_end(string2, start2, end2, &s2, &e2); + while (s1 < e1) { + if (s2 == e2) + @(return `string_sign>0 ? Cnil : make_fixnum(s1)`) + i1 = string1->ust.ust_self[s1]; + i2 = string2->ust.ust_self[s2]; + if (string_sign == 0) { + if (i1 != i2) + @(return `make_fixnum(s1)`) + } else { + s = string_sign*(i2-i1); + if (s > 0) + @(return `make_fixnum(s1)`) + if (s < 0) + @(return Cnil) + } + s1++; + s2++; + } + if (s2 == e2) + @(return `string_boundary==0 ? make_fixnum(s1) : Cnil`) + @(return `string_sign>=0 ? make_fixnum(s1) : Cnil`) +@) + +LFD(Lstring_l)() { string_sign = 1; string_boundary = 1; FFN(Lstring_cmp)(); } +LFD(Lstring_g)() { string_sign = -1; string_boundary = 1; FFN(Lstring_cmp)(); } +LFD(Lstring_le)() { string_sign = 1; string_boundary = 0; FFN(Lstring_cmp)(); } +LFD(Lstring_ge)() { string_sign = -1; string_boundary = 0; FFN(Lstring_cmp)(); } +LFD(Lstring_neq)() { string_sign = 0; string_boundary = 1; FFN(Lstring_cmp)(); } + +@(static defun string_compare (string1 string2 + &key start1 end1 start2 end2) + int s1=0, e1=0, s2=0, e2=0; + int i1, i2; + int s; +@ + string1 = coerce_to_string(string1); + string2 = coerce_to_string(string2); + get_string_start_end(string1, start1, end1, &s1, &e1); + get_string_start_end(string2, start2, end2, &s2, &e2); + while (s1 < e1) { + if (s2 == e2) + @(return `string_sign>0 ? Cnil : make_fixnum(s1)`) + i1 = string1->ust.ust_self[s1]; + if (isLower(i1)) + i1 -= 'a' - 'A'; + i2 = string2->ust.ust_self[s2]; + if (isLower(i2)) + i2 -= 'a' - 'A'; + if (string_sign == 0) { + if (i1 != i2) + @(return `make_fixnum(s1)`) + } else { + s = string_sign*(i2-i1); + if (s > 0) + @(return `make_fixnum(s1)`) + if (s < 0) + @(return Cnil) + } + s1++; + s2++; + } + if (s2 == e2) + @(return `string_boundary==0 ? make_fixnum(s1) : Cnil`) + @(return `string_sign>=0 ? make_fixnum(s1) : Cnil`) +@) + +LFD(Lstring_lessp)() { string_sign = 1; string_boundary = 1; FFN(Lstring_compare)(); } +LFD(Lstring_greaterp)() { string_sign = -1; string_boundary = 1; FFN(Lstring_compare)(); } +LFD(Lstring_not_greaterp)(){ string_sign = 1; string_boundary = 0; FFN(Lstring_compare)(); } +LFD(Lstring_not_lessp)() { string_sign = -1; string_boundary = 0; FFN(Lstring_compare)(); } +LFD(Lstring_not_equal)() { string_sign = 0; string_boundary = 1; FFN(Lstring_compare)(); } + +/* element_type is currently ignored -- character == base-char == standard-char */ +@(defun make_string (size + &key (initial_element `code_char(' ')` ) element_type + &aux x) + int i; +@ + while (type_of(size) != t_fixnum || fix(size) < 0) + size + = wrong_type_argument(TSnon_negative_integer, size); + /* bignum not allowed, this is PRACTICAL!! */ + while (type_of(initial_element) != t_character || + char_bits(initial_element) != 0 || + char_font(initial_element) != 0) + initial_element + = wrong_type_argument(sLstring_char, initial_element); + {BEGIN_NO_INTERRUPT; + x = alloc_simple_string(fix(size)); + x->st.st_self = alloc_relblock(fix(size)); + for (i = 0; i < fix(size); i++) + x->st.st_self[i] = char_code(initial_element); + END_NO_INTERRUPT; } + @(return x) +@) + +static bool +member_char(c, char_bag) +int c; +object char_bag; +{ + + int i, f; + + switch (type_of(char_bag)) { + case t_symbol: + case t_cons: + while (!endp(char_bag)) { + if (type_of(char_bag->c.c_car) == t_character + && c == char_code(char_bag->c.c_car)) + return(TRUE); + char_bag = char_bag->c.c_cdr; + } + return(FALSE); + + case t_vector: + for (i = 0, f = char_bag->v.v_fillp; i < f; i++) { + if (type_of(char_bag->v.v_self[i]) == t_character + && c == char_code(char_bag->v.v_self[i])) + return(TRUE); + } + return(FALSE); + + case t_string: + for (i = 0, f = char_bag->st.st_fillp; i < f; i++) { + if (c == char_bag->st.st_self[i]) + return(TRUE); + } + return(FALSE); + + case t_bitvector: + return(FALSE); + + default: + FEerror("~S is not a sequence.", 1, char_bag); + return(FALSE); + } +} + +/*static void Lstring_trim0();*/ + +@(static defun string_trim0 (char_bag strng &aux res) + int i, j, k; +@ + strng = coerce_to_string(strng); + i = 0; + j = strng->st.st_fillp - 1; + if (left_trim) + for (; i <= j; i++) + if (!member_char(strng->st.st_self[i], char_bag)) + break; + if (right_trim) + for (; j >= i; --j) + if (!member_char(strng->st.st_self[j], char_bag)) + break; + k = j - i + 1; + {BEGIN_NO_INTERRUPT; + res = alloc_simple_string(k); + res->st.st_self = alloc_relblock(k); + for (j = 0; j < k; j++) + res->st.st_self[j] = strng->st.st_self[i + j]; + END_NO_INTERRUPT; } + @(return res) +@) + +LFD(Lstring_trim)() { left_trim = right_trim = TRUE; FFN(Lstring_trim0)(); } +LFD(Lstring_left_trim)() { left_trim = TRUE; right_trim = FALSE; FFN(Lstring_trim0)(); } +LFD(Lstring_right_trim)() { left_trim = FALSE; right_trim = TRUE; FFN(Lstring_trim0)();} + +static int char_upcase(c, bp) +int c, *bp; +{ + if (isLower(c)) + return(c - ('a' - 'A')); + else + return(c); +} + +static int char_downcase(c, bp) +int c, *bp; +{ + if (isUpper(c)) + return(c + ('a' - 'A')); + else + return(c); +} + +static int char_capitalize(c, bp) +int c, *bp; +{ + if (isLower(c)) { + if (*bp) + c -= 'a' - 'A'; + *bp = FALSE; + } else if (isUpper(c)) { + if (!*bp) + c += 'a' - 'A'; + *bp = FALSE; + } else if (!isDigit(c)) + *bp = TRUE; + else + *bp = FALSE; + return(c); +} + +@(static defun string_case (strng &key start end &aux conv) + int s=0, e=0, i; + bool b; +@ + strng = coerce_to_string(strng); + get_string_start_end(strng, start, end, &s, &e); + conv = copy_simple_string(strng); + b = TRUE; + for (i = s; i < e; i++) + conv->st.st_self[i] = + (*casefun)(conv->st.st_self[i], &b); + @(return conv) +@) + +LFD(Lstring_upcase)() { casefun = char_upcase; FFN(Lstring_case)(); } +LFD(Lstring_downcase)() { casefun = char_downcase; FFN(Lstring_case)(); } +LFD(Lstring_capitalize)() { casefun = char_capitalize; FFN(Lstring_case)(); } + + +@(static defun nstring_case (strng &key start end) + int s=0, e=0, i; + bool b; +@ + check_type_string(&strng); + get_string_start_end(strng, start, end, &s, &e); + b = TRUE; + for (i = s; i < e; i++) + strng->st.st_self[i] = + (*casefun)(strng->st.st_self[i], &b); + @(return strng) +@) + +LFD(Lnstring_upcase)() { casefun = char_upcase; FFN(Lnstring_case)(); } +LFD(Lnstring_downcase)() { casefun = char_downcase; FFN(Lnstring_case)(); } +LFD(Lnstring_capitalize)() { casefun = char_capitalize; FFN(Lnstring_case)(); } + + +@(defun string (x) +@ + @(return `coerce_to_string(x)`) +@) + +static void +FFN(siLstring_concatenate)() +{ + int narg, i, l, m; + object *v; + + narg = vs_top - vs_base; + for (i = 0, l = 0; i < narg; i++) { + vs_base[i] = coerce_to_string(vs_base[i]); + l += vs_base[i]->st.st_fillp; + } + v = vs_top; + {BEGIN_NO_INTERRUPT; + vs_push(alloc_simple_string(l)); + (*v)->st.st_self = alloc_relblock(l); + for (i = 0, l = 0; i < narg; i++) + for (m = 0; m < vs_base[i]->st.st_fillp; m++) + (*v)->st.st_self[l++] + = vs_base[i]->st.st_self[m]; + vs_base[0] = *v; + vs_top = vs_base + 1; + END_NO_INTERRUPT;} +} + +void +gcl_init_string_function() +{ + sKstart1 = make_keyword("START1"); + sKend1 = make_keyword("END1"); + sKstart2 = make_keyword("START2"); + sKend2 = make_keyword("END2"); + sKinitial_element = make_keyword("INITIAL-ELEMENT"); + sKelement_type = make_keyword("ELEMENT-TYPE"); + sKstart = make_keyword("START"); + sKend = make_keyword("END"); + + make_function("CHAR", Lchar); + make_si_function("CHAR-SET", siLchar_set); + make_function("SCHAR", Lchar); + make_si_function("SCHAR-SET", siLchar_set); + make_function("STRING=", Lstring_eq); + make_function("STRING-EQUAL", Lstring_equal); + make_function("STRING<", Lstring_l); + make_function("STRING>", Lstring_g); + make_function("STRING<=", Lstring_le); + make_function("STRING>=", Lstring_ge); + make_function("STRING/=", Lstring_neq); + make_function("STRING-LESSP", Lstring_lessp); + make_function("STRING-GREATERP", Lstring_greaterp); + make_function("STRING-NOT-LESSP", Lstring_not_lessp); + make_function("STRING-NOT-GREATERP", Lstring_not_greaterp); + make_function("STRING-NOT-EQUAL", Lstring_not_equal); + make_function("MAKE-STRING", Lmake_string); + make_function("STRING-TRIM", Lstring_trim); + make_function("STRING-LEFT-TRIM", Lstring_left_trim); + make_function("STRING-RIGHT-TRIM", Lstring_right_trim); + make_function("STRING-UPCASE", Lstring_upcase); + make_function("STRING-DOWNCASE", Lstring_downcase); + make_function("STRING-CAPITALIZE", Lstring_capitalize); + make_function("NSTRING-UPCASE", Lnstring_upcase); + make_function("NSTRING-DOWNCASE", Lnstring_downcase); + make_function("NSTRING-CAPITALIZE", Lnstring_capitalize); + make_function("STRING", Lstring); + + make_si_function("STRING-CONCATENATE", + siLstring_concatenate); +} diff --git a/o/structure.c b/o/structure.c new file mode 100755 index 0000000..f71d8ae --- /dev/null +++ b/o/structure.c @@ -0,0 +1,468 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +/* + structure.c + + structure interface +*/ + +#include +#include "include.h" + + +#define COERCE_DEF(x) if (type_of(x)==t_symbol) \ + x=getf(x->s.s_plist,sSs_data,Cnil) + +#define check_type_structure(x) \ + if(type_of((x))!=t_structure) \ + FEwrong_type_argument(sLstructure,(x)) + + +static bool +structure_subtypep(object x, object y) +{ if (x==y) return 1; + if (type_of(x)!= t_structure + || type_of(y)!=t_structure) + FEerror("bad call to structure_subtypep",0); + {if (S_DATA(y)->included == Cnil) return 0; + while ((x=S_DATA(x)->includes) != Cnil) + { if (x==y) return 1;} + return 0; + }} + +static void +bad_raw_type(void) +{ FEerror("Bad raw struct type",0);} + + +DEFUN_NEW("STRUCTURE-DEF",object,fSstructure_def,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { + check_type_structure(x); + return (x)->str.str_def; +} + +DEFUN_NEW("STRUCTURE-LENGTH",object,fSstructure_length,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") { + check_type_structure(x); + return (object)S_DATA(x)->length; +} + +DEFUN_NEW("STRUCTURE-REF",object,structure_ref,SI,3,3,NONE,OO,OI,OO,OO,(object x,object name,fixnum i),"") { +/* object */ +/* structure_ref(object x, object name, int i) */ +/* { */ + unsigned short *s_pos; + COERCE_DEF(name); + if (type_of(x) != t_structure || + (type_of(name)!=t_structure) || + !structure_subtypep(x->str.str_def, name)) + FEwrong_type_argument((type_of(name)==t_structure ? + S_DATA(name)->name : name), + x); + s_pos = &SLOT_POS(x->str.str_def,0); + switch((SLOT_TYPE(x->str.str_def,i))) + { + case aet_object: return(STREF(object,x,s_pos[i])); + case aet_fix: return(make_fixnum((STREF(fixnum,x,s_pos[i])))); + case aet_ch: return(code_char(STREF(char,x,s_pos[i]))); + case aet_bit: + case aet_char: return(small_fixnum(STREF(char,x,s_pos[i]))); + case aet_sf: return(make_shortfloat(STREF(shortfloat,x,s_pos[i]))); + case aet_lf: return(make_longfloat(STREF(longfloat,x,s_pos[i]))); + case aet_uchar: return(small_fixnum(STREF(unsigned char,x,s_pos[i]))); + case aet_ushort: return(make_fixnum(STREF(unsigned short,x,s_pos[i]))); + case aet_short: return(make_fixnum(STREF(short,x,s_pos[i]))); + default: + bad_raw_type(); + return 0; + } +} +#ifdef STATIC_FUNCTION_POINTERS +object +structure_ref(object x,object name,fixnum i) { + return FFN(structure_ref)(x,name,i); +} +#endif + + +static void +FFN(siLstructure_ref1)(void) +{object x=vs_base[0]; + int n=fix(vs_base[1]); + object def; + check_type_structure(x); + def=x->str.str_def; + if(n>= S_DATA(def)->length) + FEerror("Structure ref out of bounds",0); + vs_base[0]=structure_ref(x,x->str.str_def,n); + vs_top=vs_base+1; +} + +DEFUN_NEW("STRUCTURE-SET",object,structure_set,SI,4,4,NONE,OO,OI,OO,OO,(object x,object name,fixnum i,object v),"") { +/* object */ +/* structure_set(object x, object name, int i, object v) */ +/* { */ + unsigned short *s_pos; + + COERCE_DEF(name); + if (type_of(x) != t_structure || + type_of(name) != t_structure || + !structure_subtypep(x->str.str_def, name)) + FEwrong_type_argument((type_of(name)==t_structure ? + S_DATA(name)->name : name) + , x); + +#ifdef SGC + /* make sure the structure header is on a writable page */ + if (is_marked(x)) FEerror("bad gc field",0); else unmark(x); +#endif + + s_pos= & SLOT_POS(x->str.str_def,0); + switch(SLOT_TYPE(x->str.str_def,i)){ + + case aet_object: STREF(object,x,s_pos[i])=v; break; + case aet_fix: (STREF(fixnum,x,s_pos[i]))=fix(v); break; + case aet_ch: STREF(char,x,s_pos[i])=char_code(v); break; + case aet_bit: + case aet_char: STREF(char,x,s_pos[i])=fix(v); break; + case aet_sf: STREF(shortfloat,x,s_pos[i])=sf(v); break; + case aet_lf: STREF(longfloat,x,s_pos[i])=lf(v); break; + case aet_uchar: STREF(unsigned char,x,s_pos[i])=fix(v); break; + case aet_ushort: STREF(unsigned short,x,s_pos[i])=fix(v); break; + case aet_short: STREF(short,x,s_pos[i])=fix(v); break; + default: + bad_raw_type(); + + } + return(v); +} +#ifdef STATIC_FUNCTION_POINTERS +object +structure_set(object x,object name,fixnum i,object v) { + return FFN(structure_set)(x,name,i,v); +} +#endif + +static void +FFN(siLstructure_subtype_p)(void) +{object x,y; + check_arg(2); + x=vs_base[0]; + y=vs_base[1]; + if (type_of(x)!=t_structure) + {vs_base[0]=Cnil; goto BOTTOM;} + x=x->str.str_def; + COERCE_DEF(y); + if (structure_subtypep(x,y)) vs_base[0]=Ct; + else vs_base[0]=Cnil; + BOTTOM: + vs_top=vs_base+1; +} + + + +object +structure_to_list(object x) +{ + + object *p, s; + struct s_data *def=S_DATA(x->str.str_def); + int i, n; + + s = def->slot_descriptions; + vs_push(def->name); + vs_push(Cnil); + p = &vs_head; + for (i=0, n=def->length; !endp(s)&&ic.c_cdr, i++) { + *p = make_cons(car(s->c.c_car), Cnil); + p = &((*p)->c.c_cdr); + *p = make_cons(structure_ref(x,x->str.str_def,i), Cnil); + p = &((*p)->c.c_cdr); + } + stack_cons(); + return(vs_pop); +} + +LFD(siLmake_structure)(void) +{ + object x,name,*base; + struct s_data *def=NULL; + int narg, i,size; + base=vs_base; + if ((narg = vs_top - base) == 0) + too_few_arguments(); + {BEGIN_NO_INTERRUPT; + x = alloc_object(t_structure); + name=base[0]; + COERCE_DEF(name); + if (type_of(name)!=t_structure || + (def=S_DATA(name))->length != --narg) + FEerror("Bad make_structure args for type ~a",1,base[0]); + x->str.str_def = name; + x->str.str_self = NULL; + size=S_DATA(name)->size; + base[0] = x; + x->str.str_self = (object *) + (def->staticp == Cnil ? alloc_relblock(size) + : alloc_contblock(size)); + /* There may be holes in the structure. + We want them zero, so that equal can work better. + */ + if (S_DATA(name)->has_holes != Cnil) + bzero(x->str.str_self,size); + {unsigned char *s_type; + unsigned short *s_pos; + s_pos= (&SLOT_POS(x->str.str_def,0)); + s_type = (&(SLOT_TYPE(x->str.str_def,0))); + base=base+1; + for (i = 0; i < narg; i++) + {object v=base[i]; + switch(s_type[i]){ + + case aet_object: STREF(object,x,s_pos[i])=v; break; + case aet_fix: (STREF(fixnum,x,s_pos[i]))=fix(v); break; + case aet_ch: STREF(char,x,s_pos[i])=char_code(v); break; + case aet_bit: + case aet_char: STREF(char,x,s_pos[i])=fix(v); break; + case aet_sf: STREF(shortfloat,x,s_pos[i])=sf(v); break; + case aet_lf: STREF(longfloat,x,s_pos[i])=lf(v); break; + case aet_uchar: STREF(unsigned char,x,s_pos[i])=fix(v); break; + case aet_ushort: STREF(unsigned short,x,s_pos[i])=fix(v); break; + case aet_short: STREF(short,x,s_pos[i])=fix(v); break; + default: + bad_raw_type(); + + }} + vs_top = base; + vs_base=base-1; + END_NO_INTERRUPT;} + } +} + +static void +FFN(siLcopy_structure)(void) +{ + object x, y; + struct s_data *def; + + check_arg(1); +/* if (vs_top-vs_base < 1) too_few_arguments(); */ + x = vs_base[0]; + check_type_structure(x); + {BEGIN_NO_INTERRUPT; + vs_base[0] = y = alloc_object(t_structure); + def=S_DATA(y->str.str_def = x->str.str_def); + y->str.str_self = NULL; + y->str.str_self = (object *)alloc_relblock(def->size); + bcopy(x->str.str_self,y->str.str_self,def->size); + vs_top=vs_base+1; + END_NO_INTERRUPT;} +} + +LFD(siLstructure_name)(void) +{ + check_arg(1); + check_type_structure(vs_base[0]); + vs_base[0] = S_DATA(vs_base[0]->str.str_def)->name; +} + +LFD(siLstructure_ref)(void) +{ + check_arg(3); + vs_base[0]=structure_ref(vs_base[0],vs_base[1],fix(vs_base[2])); + vs_top=vs_base+1; +} + +LFD(siLstructure_set)(void) +{ + check_arg(4); + structure_set(vs_base[0],vs_base[1],fix(vs_base[2]),vs_base[3]); + vs_base = vs_top-1; +} + +LFD(siLstructurep)(void) +{ + check_arg(1); + if (type_of(vs_base[0]) == t_structure) + vs_base[0] = Ct; + else + vs_base[0] = Cnil; +} + +LFD(siLrplaca_nthcdr)(void) +{ + +/* + Used in DEFSETF forms generated by DEFSTRUCT. + (si:rplaca-nthcdr x i v) is equivalent to + (progn (rplaca (nthcdr i x) v) v). +*/ + int i; + object l; + + check_arg(3); + if (type_of(vs_base[1]) != t_fixnum || fix(vs_base[1]) < 0) + FEerror("~S is not a non-negative fixnum.", 1, vs_base[1]); + if (type_of(vs_base[0]) != t_cons) + FEerror("~S is not a cons.", 1, vs_base[0]); + + for (i = fix(vs_base[1]), l = vs_base[0]; i > 0; --i) { + l = l->c.c_cdr; + if (endp(l)) + FEerror("The offset ~S is too big.", 1, vs_base[1]); + } + take_care(vs_base[2]); + l->c.c_car = vs_base[2]; + vs_base = vs_base + 2; +} + +LFD(siLlist_nth)(void) +{ + +/* + Used in structure access functions generated by DEFSTRUCT. + si:list-nth is similar to nth except that + (si:list-nth i x) is error if the length of the list x is less than i. +*/ + int i; + object l; + + check_arg(2); + if (type_of(vs_base[0]) != t_fixnum || fix(vs_base[0]) < 0) + FEerror("~S is not a non-negative fixnum.", 1, vs_base[0]); + if (type_of(vs_base[1]) != t_cons) + FEerror("~S is not a cons.", 1, vs_base[1]); + + for (i = fix(vs_base[0]), l = vs_base[1]; i > 0; --i) { + l = l->c.c_cdr; + if (endp(l)) + FEerror("The offset ~S is too big.", 1, vs_base[0]); + } + + vs_base[0] = l->c.c_car; + vs_popp; +} + + +static void +FFN(siLmake_s_data_structure)(void) +{object x,y,raw,*base; + int i; + check_arg(5); + x=vs_base[0]; + base=vs_base; + raw=vs_base[1]; + y=alloc_object(t_structure); + y->str.str_def=y; + y->str.str_self = (object *)( x->v.v_self); + S_DATA(y)->name =sSs_data; + S_DATA(y)->length=(raw->v.v_dim); + S_DATA(y)->raw =raw; + for(i=3; iv.v_dim; i++) + y->str.str_self[i]=Cnil; + S_DATA(y)->slot_position=base[2]; + S_DATA(y)->slot_descriptions=base[3]; + S_DATA(y)->staticp=base[4]; + S_DATA(y)->size = (raw->v.v_dim)*sizeof(object); + vs_base[0]=y; + vs_top=vs_base+1; +} + +/* static void */ +/* FFN(siLstructure_def)(void) */ +/* {check_arg(1); */ +/* check_type_structure(vs_base[0]); */ +/* vs_base[0]=vs_base[0]->str.str_def; */ +/* } */ + +short aet_sizes [] = { +sizeof(object), /* aet_object t */ +sizeof(char), /* aet_ch string-char */ +sizeof(char), /* aet_bit bit */ +sizeof(fixnum), /* aet_fix fixnum */ +sizeof(float), /* aet_sf short-float */ +sizeof(double), /* aet_lf long-float */ +sizeof(char), /* aet_char signed char */ +sizeof(char), /* aet_uchar unsigned char */ +sizeof(short), /* aet_short signed short */ +sizeof(short) /* aet_ushort unsigned short */ +}; + + + + + +static void +FFN(siLsize_of)(void) +{ object x= vs_base[0]; + int i; + i= aet_sizes[fix(fSget_aelttype(x))]; + vs_base[0]=make_fixnum(i); +} + +static void +FFN(siLaet_type)(void) +{vs_base[0]=fSget_aelttype(vs_base[0]);} + + +/* Return N such that something of type ARG can be aligned on + an address which is a multiple of N */ + + +static void +FFN(siLalignment)(void) +{struct {double x; int y; double z; + float x1; int y1; float z1;} + joe; + joe.z=3.0; + + if (vs_base[0]==sLlong_float) + {vs_base[0]=make_fixnum((long)&joe.z- (long)&joe.y); return;} + else + if (vs_base[0]==sLshort_float) + {vs_base[0]=make_fixnum((long)&(joe.z1)-(long)&(joe.y1)); return;} + else + {FFN(siLsize_of)();} +} + + +DEF_ORDINARY("S-DATA",sSs_data,SI,""); + +void +gcl_init_structure_function(void) +{ + + + make_si_function("MAKE-STRUCTURE", siLmake_structure); + make_si_function("MAKE-S-DATA-STRUCTURE",siLmake_s_data_structure); + make_si_function("COPY-STRUCTURE", siLcopy_structure); + make_si_function("STRUCTURE-NAME", siLstructure_name); + /* make_si_function("STRUCTURE-REF", siLstructure_ref); */ + /* make_si_function("STRUCTURE-DEF", siLstructure_def); */ + make_si_function("STRUCTURE-REF1", siLstructure_ref1); + /* make_si_function("STRUCTURE-SET", siLstructure_set); */ + make_si_function("STRUCTUREP", siLstructurep); + make_si_function("SIZE-OF", siLsize_of); + make_si_function("ALIGNMENT",siLalignment); + make_si_function("STRUCTURE-SUBTYPE-P",siLstructure_subtype_p); + make_si_function("RPLACA-NTHCDR", siLrplaca_nthcdr); + make_si_function("LIST-NTH", siLlist_nth); + make_si_function("AET-TYPE",siLaet_type); +} diff --git a/o/symbol.d b/o/symbol.d new file mode 100755 index 0000000..f1a277c --- /dev/null +++ b/o/symbol.d @@ -0,0 +1,711 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +*/ + +/* + symbol.d +*/ + +#include +#include "include.h" + +/*FIXME this symbol is needed my maxima MAKE_SPECIAL*/ +void +check_type_symbol(object *x) { + check_type_sym(x); +} + +static void +odd_plist(object); + + +object siSpname; + +void +set_up_string_register(char *s) { + string_register->st.st_fillp = + string_register->st.st_dim = strlen(s); + string_register->st.st_self = s; +} + +object +make_symbol(st) +object st; +{ + object x; + int i; + {BEGIN_NO_INTERRUPT; + x = alloc_object(t_symbol); + x->s.s_dbind = OBJNULL; + x->s.s_sfdef = NOT_SPECIAL; + x->s.s_fillp = st->st.st_fillp; + x->s.s_self = NULL; + x->s.s_gfdef = OBJNULL; + x->s.s_plist = Cnil; + x->s.s_hpack = Cnil; + x->s.s_stype = (short)stp_ordinary; + x->s.s_mflag = FALSE; + vs_push(x); + if (raw_image && st->st.st_self < heap_end) + x->s.s_self = st->st.st_self; + else { + x->s.s_self = alloc_relblock(x->s.s_fillp); + for (i = 0; i < x->s.s_fillp; i++) + x->s.s_self[i] = st->st.st_self[i]; + } + END_NO_INTERRUPT;} + return(vs_pop); +} + +/* + Make_ordinary(s) makes an ordinary symbol from C string s + and interns it in lisp package as an external symbol. +*/ + +#define P_EXTERNAL(x,j) ((x)->p.p_external[(j) % (x)->p.p_external_size]) + + +object +make_ordinary(s) +char *s; +{ + int j; + object x, l, *ep; + vs_mark; + + set_up_string_register(s); + j = pack_hash(string_register); + ep = &P_EXTERNAL(lisp_package,j); + for (l = *ep; type_of(l) == t_cons; l = l->c.c_cdr) + if (string_eq(l->c.c_car, string_register)) + return(l->c.c_car); + x = make_symbol(string_register); + vs_push(x); + x->s.s_hpack = lisp_package; + *ep = make_cons(x, *ep); + lisp_package->p.p_external_fp ++; + vs_reset; + return(x); +} + +/* + Make_special(s, v) makes a special variable from C string s + with initial value v in lisp package. +*/ +object +make_special(s, v) +char *s; +object v; +{ + object x; + + x = make_ordinary(s); + x->s.s_stype = (short)stp_special; + x->s.s_dbind = v; + return(x); +} + +/* + Make_constant(s, v) makes a constant from C string s + with constant value v in lisp package. +*/ +object +make_constant(s, v) +char *s; +object v; +{ + object x; + + x = make_ordinary(s); + x->s.s_stype = (short)stp_constant; + x->s.s_dbind = v; + return(x); +} + +/* + Make_si_ordinary(s) makes an ordinary symbol from C string s + and interns it in system package as an external symbol. + It assumes that the (only) package used by system is lisp. +*/ + + + +object +make_si_ordinary(s) +char *s; +{ + int j; + object x, l, *ep; + vs_mark; + + set_up_string_register(s); + j = pack_hash(string_register); + ep = & P_EXTERNAL(system_package,j); + for (l = *ep; type_of(l) == t_cons; l = l->c.c_cdr) + if (string_eq(l->c.c_car, string_register)) + return(l->c.c_car); + for (l = P_EXTERNAL(lisp_package,j); + type_of(l) == t_cons; + l = l->c.c_cdr) + if (string_eq(l->c.c_car, string_register)) + error("name conflict --- can't make_si_ordinary"); + x = make_symbol(string_register); + vs_push(x); + x->s.s_hpack = system_package; + system_package->p.p_external_fp ++; + *ep = make_cons(x, *ep); + vs_reset; + return(x); +} + +/* + Make_si_special(s, v) makes a special variable from C string s + with initial value v in system package. +*/ +object +make_si_special(s, v) +char *s; +object v; +{ + object x; + + x = make_si_ordinary(s); + x->s.s_stype = (short)stp_special; + x->s.s_dbind = v; + return(x); +} + +/* + Make_si_constant(s, v) makes a constant from C string s + with constant value v in system package. +*/ +object +make_si_constant(s, v) +char *s; +object v; +{ + object x; + + x = make_si_ordinary(s); + x->s.s_stype = (short)stp_constant; + x->s.s_dbind = v; + return(x); +} + +/* + Make_keyword(s) makes a keyword from C string s. +*/ +object +make_keyword(s) +char *s; +{ + int j; + object x, l, *ep; + vs_mark; + + set_up_string_register(s); + j = pack_hash(string_register); + ep = &P_EXTERNAL(keyword_package,j); + for (l = *ep; type_of(l) == t_cons; l = l->c.c_cdr) + if (string_eq(l->c.c_car, string_register)) + return(l->c.c_car); + x = make_symbol(string_register); + vs_push(x); + x->s.s_hpack = keyword_package; + x->s.s_stype = (short)stp_constant; + x->s.s_dbind = x; + *ep = make_cons(x, *ep); + keyword_package->p.p_external_fp ++; + vs_reset; + return(x); +} + +object +symbol_value(s) +object s; +{ +/* + if (type_of(s) != t_symbol) + FEinvalid_variable("~S is not a symbol.", s); +*/ + if (s->s.s_dbind == OBJNULL) + FEunbound_variable(s); + return(s->s.s_dbind); +} + +object +getf(place, indicator, deflt) +object place, indicator, deflt; +{ + + object l; +#define cendp(obj) ((type_of(obj)!=t_cons)) + for (l = place; !cendp(l); l = l->c.c_cdr->c.c_cdr) { + if (cendp(l->c.c_cdr)) + break; + if (l->c.c_car == indicator) + return(l->c.c_cdr->c.c_car); + } + if(l==Cnil) return deflt; + FEerror("Bad plist ~a",1,place); + return Cnil; +} + +object +get(s, p, d) +object s, p, d; +{ + if (type_of(s) != t_symbol) + not_a_symbol(s); + return(getf(s->s.s_plist, p, d)); +} + +/* + Putf(p, v, i) puts value v for property i to property list p + and returns the resulting property list. +*/ +object +putf(p, v, i) +object p, v, i; +{ + object l; + + for (l = p; !cendp(l); l = l->c.c_cdr->c.c_cdr) { + if (cendp(l->c.c_cdr)) + break; + if (l->c.c_car == i) { + l->c.c_cdr->c.c_car = v; + return(p); + } + } + if(l!=Cnil) FEerror("Bad plist ~a",1,p); + return listA(3,i,v,p); +} + +object +putprop(s, v, p) +object s, v, p; +{ + if (type_of(s) != t_symbol) + not_a_symbol(s); + s->s.s_plist = putf(s->s.s_plist, v, p); + return(v); +} + + +/* done in the right order for efficient setf.. */ +STATD object +FFN(sputprop)(s, p, v) +object s, v, p; +{ + if (type_of(s) != t_symbol) + not_a_symbol(s); + s->s.s_plist = putf(s->s.s_plist, v, p); + return(v); +} +#ifdef STATIC_FUNCTION_POINTERS +object +sputprop(object s, object p, object v) { + return FFN(sputprop)(s,p,v); +} +#endif + +/* + Remf(p, i) removes property i + from the property list pointed by p, + which is a pointer to an object. + The returned value of remf(p, i) is: + + TRUE if the property existed + FALSE otherwise. +*/ +bool +remf(p, i) +object *p, i; +{ + object l0 = *p; + + for(; !endp(*p); p = &(*p)->c.c_cdr->c.c_cdr) { + if (endp((*p)->c.c_cdr)) + odd_plist(l0); + if ((*p)->c.c_car == i) { + *p = (*p)->c.c_cdr->c.c_cdr; + return(TRUE); + } + } + return(FALSE); +} + +object +remprop(s, p) +object s, p; +{ + if (type_of(s) != t_symbol) + not_a_symbol(s); + if (remf(&s->s.s_plist, p)) + return(Ct); + else + return(Cnil); +} + +bool +keywordp(s) +object s; +{ + return(type_of(s) == t_symbol && s->s.s_hpack == keyword_package); +/* + if (type_of(s) != t_symbol) { + vs_push(s); + check_type_sym(&vs_head); + vs_pop; + } + if (s->s.s_hpack == OBJNULL) + return(FALSE); + return(s->s.s_hpack == keyword_package); +*/ +} + +@(defun get (sym indicator &optional deflt) +@ + check_type_sym(&sym); + @(return `getf(sym->s.s_plist, indicator, deflt)`) +@) + +LFD(Lremprop)() +{ + check_arg(2); + + check_type_sym(&vs_base[0]); + if (remf(&vs_base[0]->s.s_plist, vs_base[1])) + vs_base[0] = Ct; + else + vs_base[0] = Cnil; + vs_popp; +} + +LFD(Lsymbol_plist)() +{ + check_arg(1); + + check_type_sym(&vs_base[0]); + vs_base[0] = vs_base[0]->s.s_plist; +} + +@(defun getf (place indicator &optional deflt) +@ + @(return `getf(place, indicator, deflt)`) +@) + +@(defun get_properties (place indicator_list) + object l, m; + +@ + for (l = place; !endp(l); l = l->c.c_cdr->c.c_cdr) { + if (endp(l->c.c_cdr)) + odd_plist(place); + for (m = indicator_list; !endp(m); m = m->c.c_cdr) + if (l->c.c_car == m->c.c_car) + @(return `l->c.c_car` + `l->c.c_cdr->c.c_car` + l) + } + @(return Cnil Cnil Cnil) +@) + + +object +symbol_name(x) +object x; +{ +object y; + if (type_of(x)!=t_symbol) FEwrong_type_argument(sLsymbol,x); + for (y=x->s.s_plist; type_of(y)==t_cons ; y=y->c.c_cdr->c.c_cdr) + {if(y->c.c_car==siSpname) return(y->c.c_cdr->c.c_car);} + {BEGIN_NO_INTERRUPT; + y = alloc_simple_string(x->s.s_fillp); + vs_push(y); + if (x->s.s_self < heap_end) + y->st.st_self = x->s.s_self; + else {int i; + y->st.st_self = alloc_relblock(x->s.s_fillp); + for (i = 0; i < x->s.s_fillp; i++) + y->st.st_self[i] = x->s.s_self[i]; + } + x->s.s_plist = putf(x->s.s_plist, y, siSpname); + vs_popp; + END_NO_INTERRUPT; } + return(y); +} + +LFD(Lsymbol_name)() +{ + check_arg(1); + vs_base[0]=symbol_name(vs_base[0]); +} + +LFD(Lmake_symbol)() +{ + check_arg(1); + + check_type_string(&vs_base[0]); + vs_base[0] = make_symbol(vs_base[0]); +} + +@(defun copy_symbol (sym &optional cp &aux x) +@ + check_type_sym(&sym); + x = make_symbol(sym); + if (cp == Cnil) + @(return x) + x->s.s_stype = sym->s.s_stype; + x->s.s_dbind = sym->s.s_dbind; + x->s.s_mflag = sym->s.s_mflag; + x->s.s_gfdef = sym->s.s_gfdef; + x->s.s_plist = copy_list(sym->s.s_plist); + @(return x) +@) + +DEFVAR("*GENSYM-COUNTER*",sLgensym_counter,LISP,make_fixnum(0),""); + +@(defun gensym (&optional (x gensym_prefix) &aux sym) + int i, j, sign, size; + fixnum f; + char *q=NULL,*p=NULL; + object this_gensym_prefix,big; + object this_gensym_counter; +@ + if (type_of(x) == t_string) { + this_gensym_prefix = x; + this_gensym_counter=sLgensym_counter->s.s_dbind; + sLgensym_counter->s.s_dbind=number_plus(sLgensym_counter->s.s_dbind,small_fixnum(1)); + } else { + check_type_non_negative_integer(&x); + this_gensym_counter=x; + this_gensym_prefix=gensym_prefix; + } + + switch (type_of(this_gensym_counter)) { + case t_bignum: + big=this_gensym_counter; + sign=BIG_SIGN(big); + size = mpz_sizeinbase(MP(big),10)+2+(sign<0? 1 : 0); + if (!(p=alloca(size))) + FEerror("Cannot alloca gensym name", 0); + mpz_get_str(p,10,MP(big)); + j=size-5; + j=j<0 ? 0 : j; + while (p[j]) j++; + q=p+j; + break; + case t_fixnum: + for (size=1,f=fix(this_gensym_counter);f;f/=10,size++); + q=p=alloca(size+5); + if ((j=snprintf(p,size+5,"%ld",fix(this_gensym_counter)))<=0) + FEerror("Cannot write gensym counter",0); + q=p+j; + break; + default: + FEerror("Bad gensym counter type", 0); + break; + } + +/* FIXME: come up with a better call sequence */ +/* this_gensym_counter_string=fLformat_1(Cnil,make_simple_string("~S"),this_gensym_counter); */ +/* i=this_gensym_counter_string->st.st_fillp; */ + + i = (q-p)+this_gensym_prefix->st.st_fillp; + set_up_string_register(""); + sym = make_symbol(string_register); + {BEGIN_NO_INTERRUPT; + sym->s.s_fillp = i; + sym->s.s_self = alloc_relblock(i); + i=this_gensym_prefix->st.st_fillp; + for (j = 0; j < i; j++) + sym->s.s_self[j] = this_gensym_prefix->st.st_self[j]; + for (;js.s_fillp;j++) + sym->s.s_self[j] = p[j-i]; + END_NO_INTERRUPT;} + @(return sym) +@) + +@(defun gentemp (&optional (prefix gentemp_prefix) + (pack `current_package()`) + &aux smbl) + int i, j; +@ + check_type_string(&prefix); + check_type_package(&pack); +/* + gentemp_counter = 0; +*/ +ONCE_MORE: + for (j = gentemp_counter, i = 0; j > 0; j /= 10) + i++; + if (i == 0) + i++; + i += prefix->st.st_fillp; + set_up_string_register(""); + {BEGIN_NO_INTERRUPT; + string_register->st.st_fillp = string_register->st.st_dim = i; + string_register->st.st_self = alloc_relblock(i); + for (j = 0; j < prefix->st.st_fillp; j++) + string_register->st.st_self[j] = prefix->st.st_self[j]; + if ((j = gentemp_counter) == 0) + string_register->st.st_self[--i] = '0'; + else + for (; j > 0; j /= 10) + string_register->st.st_self[--i] = j%10 + '0'; + gentemp_counter++; + smbl = intern(string_register, pack); + if (intern_flag != 0) + goto ONCE_MORE; + END_NO_INTERRUPT;} + @(return smbl) +@) + +LFD(Lsymbol_package)() +{ + check_arg(1); + + check_type_sym(&vs_base[0]); + vs_base[0] = vs_base[0]->s.s_hpack; +} + +LFD(Lkeywordp)() +{ + check_arg(1); + + if (type_of(vs_base[0]) == t_symbol && keywordp(vs_base[0])) + vs_base[0] = Ct; + else + vs_base[0] = Cnil; +} + +/* + (SI:PUT-F plist value indicator) + returns the new property list with value for property indicator. + It will be used in SETF for GETF. +*/ +LFD(siLput_f)() +{ + check_arg(3); + + vs_base[0] = putf(vs_base[0], vs_base[1], vs_base[2]); + vs_top = vs_base+1; +} + +/* + (SI:REM-F plist indicator) returns two values: + + * the new property list + in which property indcator is removed + + * T if really removed + NIL otherwise. + + It will be used for macro REMF. +*/ +LFD(siLrem_f)() +{ + check_arg(2); + + if (remf(&vs_base[0], vs_base[1])) + vs_base[1] = Ct; + else + vs_base[1] = Cnil; +} + +LFD(siLset_symbol_plist)(void) +{ + check_arg(2); + + check_type_sym(&vs_base[0]); + vs_base[0]->s.s_plist = vs_base[1]; + vs_base[0] = vs_base[1]; + vs_popp; +} + +LFD(siLputprop)() +{ + check_arg(3); + + check_type_sym(&vs_base[0]); + vs_base[0]->s.s_plist + = putf(vs_base[0]->s.s_plist, vs_base[1], vs_base[2]); + vs_base[0] = vs_base[1]; + vs_top = vs_base+1; +} + + +static void +odd_plist(place) +object place; +{ + FEerror("The length of the property-list ~S is odd.", 1, place); +} + + +void +gcl_init_symbol() +{ + string_register = alloc_simple_string(0); + gensym_prefix = make_simple_string("G"); +/* gensym_counter = 0; */ + gentemp_prefix = make_simple_string("T"); + gentemp_counter = 0; + token = alloc_simple_string(INITIAL_TOKEN_LENGTH); + token->st.st_fillp = 0; + token->st.st_self = alloc_contblock(INITIAL_TOKEN_LENGTH); + token->st.st_hasfillp = TRUE; + token->st.st_adjustable = TRUE; + + enter_mark_origin(&string_register); + enter_mark_origin(&gensym_prefix); + enter_mark_origin(&gentemp_prefix); + enter_mark_origin(&token); +} + +void +gcl_init_symbol_function() +{ + make_function("GET", Lget); + make_function("REMPROP", Lremprop); + make_function("SYMBOL-PLIST", Lsymbol_plist); + make_function("GETF", Lgetf); + make_function("GET-PROPERTIES", Lget_properties); + make_function("SYMBOL-NAME", Lsymbol_name); + make_function("MAKE-SYMBOL", Lmake_symbol); + make_function("COPY-SYMBOL", Lcopy_symbol); + make_function("GENSYM", Lgensym); + make_function("GENTEMP", Lgentemp); + make_function("SYMBOL-PACKAGE", Lsymbol_package); + make_function("KEYWORDP", Lkeywordp); + + make_si_function("PUT-F", siLput_f); + make_si_function("REM-F", siLrem_f); + make_si_function("SET-SYMBOL-PLIST", siLset_symbol_plist); + + make_si_function("PUTPROP", siLputprop); + make_si_sfun("SPUTPROP",sputprop,3); + + + siSpname = make_si_ordinary("PNAME"); + enter_mark_origin(&siSpname); +/* enter_mark_origin(&sLgensym_counter); */ +} diff --git a/o/test_memprotect.c b/o/test_memprotect.c new file mode 100755 index 0000000..7e9c1d8 --- /dev/null +++ b/o/test_memprotect.c @@ -0,0 +1,71 @@ +/* + sample usage: +linux14% cd gcl-2.2 +linux14% cd o +linux14% gcc -I../h test_memprotect.c +linux14% a.out +[val=0] +Page violation (sig=b,code=2b,scp=2b,addr=2b,fault_adr=804a005) + +Reading pp[5] (addr=804a005) 10 +linux14% +*/ + +#define IN_GBC +#define NEED_MP_H +#include "include.h" + + + +#ifdef BSD +/* ulong may have been defined in mp.h but the define is no longer needed */ +#undef ulong +#include +#define PROT_READ_WRITE (PROT_READ | PROT_WRITE |PROT_EXEC) +#endif +#ifdef AIX3 +#include +#define PROT_READ RDONLY +#define PROT_READ_WRITE UDATAKEY +int mprotect(); +#endif + +#include + + +char *pp; +int psize; + +char *malloc(); + +#include +#include + +void +handler(sig,code,scp,addr) + int sig,code; + struct sigcontext *scp; + char *addr; +{ + struct sigcontext_struct *bil= (void *) & code; + printf("\nPage violation (sig=%x,code=%x,scp=%x,addr=%x,fault_adr=%x)",sig,code,scp,addr,GET_FAULT_ADDR(sig,code,scp,addr)); + fflush(stdout); + mprotect(pp, psize, PROT_READ | PROT_WRITE); + return; +} + +main() +{ + char *p; + int a; + signal(SIGSEGV, handler); + signal(SIGBUS, handler); + psize = getpagesize(); + p = malloc(3 * psize); + a = (int)p; + pp = (char *)( ((a / psize)+ 1) * psize); + printf("[val=%d]",mprotect(pp, psize, PROT_READ)); + pp[5] = 10; + printf("\n\nReading pp[5] (addr=%x) %d\n",&pp[5], pp[5]); + fflush(stdout); +} diff --git a/o/toplevel.c b/o/toplevel.c new file mode 100755 index 0000000..2d59075 --- /dev/null +++ b/o/toplevel.c @@ -0,0 +1,241 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +/* + + toplevel.c + + Top-Level Forms and Declarations +*/ + +#include "include.h" + +object sLcompile, sLload, sLeval, sKcompile_toplevel, sKload_toplevel, sKexecute; +object sLprogn; + + +object sLwarn; + +object sSAinhibit_macro_specialA; + +object sLtypep; + +static void +FFN(Fdefun)(object args) +{ + + object name; + object body, form; + + if (endp(args) || endp(MMcdr(args))) + FEtoo_few_argumentsF(args); + if (MMcadr(args) != Cnil && type_of(MMcadr(args)) != t_cons) + FEerror("~S is an illegal lambda-list.", 1, MMcadr(args)); + name = MMcar(args); + if (type_of(name) != t_symbol) + not_a_symbol(name); + if (name->s.s_sfdef != NOT_SPECIAL) { + if (name->s.s_mflag) { + if (symbol_value(sSAinhibit_macro_specialA) != Cnil) + name->s.s_sfdef = NOT_SPECIAL; + } else if (symbol_value(sSAinhibit_macro_specialA) != Cnil) + FEerror("~S, a special form, cannot be redefined.", 1, name); + } + if (name->s.s_hpack == lisp_package && + name->s.s_gfdef != OBJNULL && !raw_image) { + vs_push(make_simple_string( + "~S is being redefined.")); + ifuncall2(sLwarn, vs_head, name); + vs_popp; + } + vs_base = vs_top; + if (lex_env[0] == Cnil && lex_env[1] == Cnil && lex_env[2] == Cnil) { + vs_push(MMcons(sLlambda_block, args)); + } else { + vs_push(MMcons(lex_env[2], args)); + vs_base[0] = MMcons(lex_env[1], vs_base[0]); + vs_base[0] = MMcons(lex_env[0], vs_base[0]); + vs_base[0] = MMcons(sLlambda_block_closure, vs_base[0]); + } + {object fname = clear_compiler_properties(name,vs_base[0]); + fname->s.s_gfdef = vs_base[0]; + fname->s.s_mflag = FALSE;} + vs_base[0] = name; + for (body = MMcddr(args); !endp(body); body = body->c.c_cdr) { + form = macro_expand(body->c.c_car); + if (type_of(form) == t_string) { + if (endp(body->c.c_cdr)) + break; + vs_push(form); + name->s.s_plist = + putf(name->s.s_plist, + form, + sSfunction_documentation); + vs_popp; + break; + } + if (type_of(form) != t_cons || form->c.c_car != sLdeclare) + break; + } +} + +static void +FFN(siLAmake_special)(void) +{ + check_arg(1); + check_type_sym(&vs_base[0]); + if ((enum stype)vs_base[0]->s.s_stype == stp_constant) + FEerror("~S is a constant.", 1, vs_base[0]); + vs_base[0]->s.s_stype = (short)stp_special; +} + +static void +FFN(siLAmake_constant)(void) +{ + check_arg(2); + check_type_sym(&vs_base[0]); + if ((enum stype)vs_base[0]->s.s_stype == stp_special) + FEerror( + "The argument ~S to DEFCONSTANT is a special variable.", + 1, vs_base[0]); + vs_base[0]->s.s_stype = (short)stp_constant; + vs_base[0]->s.s_dbind = vs_base[1]; + vs_popp; +} + +static void +FFN(Feval_when)(object arg) +{ + + object *base = vs_base; + object ss; + bool flag = FALSE; + + if(endp(arg)) + FEtoo_few_argumentsF(arg); + for (ss = MMcar(arg); !endp(ss); ss = MMcdr(ss)) + if(MMcar(ss) == sLeval || (MMcar(ss) == sKexecute) ) + flag = TRUE; + else if(MMcar(ss) != sLload && MMcar(ss) != sLcompile && + MMcar(ss) != sKload_toplevel && MMcar(ss) != sKcompile_toplevel ) + FEinvalid_form("~S is an undefined situation for EVAL-WHEN.", + MMcar(ss)); + if(flag) { + vs_push(make_cons(sLprogn, MMcdr(arg))); + eval(vs_head); + } else { + vs_base = base; + vs_top = base+1; + vs_base[0] = Cnil; + } +} + +static void +FFN(Fload_time_value)(object arg) +{ + + if(endp(arg)) + FEtoo_few_argumentsF(arg); + if(!endp(MMcdr(arg)) && !endp(MMcddr(arg))) + FEtoo_many_argumentsF(arg); + vs_push(MMcar(arg)); + eval(vs_head); + +} + +static void +FFN(Fdeclare)(object arg) +{ + FEerror("DECLARE appeared in an invalid position.", 0); +} + +static void +FFN(Flocally)(object body) +{ + object *oldlex = lex_env; + + lex_copy(); + body = find_special(body, NULL, NULL); + vs_push(body); + Fprogn(body); + lex_env = oldlex; +} + +static void +FFN(Fthe)(object args) +{ + + object *vs; + + if(endp(args) || endp(MMcdr(args))) + FEtoo_few_argumentsF(args); + if(!endp(MMcddr(args))) + FEtoo_many_argumentsF(args); + eval(MMcadr(args)); + args = MMcar(args); + if (type_of(args) == t_cons && MMcar(args) == sLvalues) { + vs = vs_base; + for (args=MMcdr(args); !endp(args); args=MMcdr(args), vs++){ + if (vs >= vs_top) + FEerror("Too many return values.", 0); + if (ifuncall2(sLtypep, *vs, MMcar(args)) == Cnil) + FEwrong_type_argument(MMcar(args), *vs); + } + if (vs < vs_top) + FEerror("Too few return values.", 0); + } else { + if (ifuncall2(sLtypep, vs_base[0], args) == Cnil) + FEwrong_type_argument(args, vs_base[0]); + } +} + +DEF_ORDINARY("LDB",sLldb,LISP,""); +DEF_ORDINARY("LDB-TEST",sLldb_test,LISP,""); +DEF_ORDINARY("DPB",sLdpb,LISP,""); +DEF_ORDINARY("DEPOSIT-FIELD",sLdeposit_field,LISP,""); +DEF_ORDINARY("COMPILE",sLcompile,LISP,""); +DEF_ORDINARY("COMPILE-TOPLEVEL",sKcompile_toplevel,KEYWORD,""); +DEF_ORDINARY("DECLARE",sLdeclare,LISP,""); +DEF_ORDINARY("EVAL",sLeval,LISP,""); +DEF_ORDINARY("EXECUTE",sKexecute,KEYWORD,""); +DEF_ORDINARY("FUNCTION-DOCUMENTATION",sSfunction_documentation,SI,""); +DEF_ORDINARY("LOAD",sLload,LISP,""); +DEF_ORDINARY("LOAD-TOPLEVEL",sKload_toplevel,KEYWORD,""); +DEF_ORDINARY("PROGN",sLprogn,LISP,""); +DEF_ORDINARY("TYPEP",sLtypep,LISP,""); +DEF_ORDINARY("VALUES",sLvalues,LISP,""); +DEF_ORDINARY("VARIABLE-DOCUMENTATION",sSvariable_documentation,SI,""); +DEF_ORDINARY("WARN",sLwarn,LISP,""); + +void +gcl_init_toplevel(void) +{ + make_special_form("DEFUN",Fdefun); + make_si_function("*MAKE-SPECIAL", siLAmake_special); + make_si_function("*MAKE-CONSTANT", siLAmake_constant); + make_special_form("EVAL-WHEN", Feval_when); + make_special_form("LOAD-TIME-VALUE", Fload_time_value); + make_special_form("THE", Fthe); + sLdeclare=make_special_form("DECLARE",Fdeclare); + make_special_form("LOCALLY",Flocally); + + +} diff --git a/o/try.c b/o/try.c new file mode 100755 index 0000000..fba3eef --- /dev/null +++ b/o/try.c @@ -0,0 +1,496 @@ +#ifndef UNIXSAVE +#include "config.h" +#endif +/* #include */ /* _fmode */ +#include +#include +#include +#include +#include +#ifdef _GNU_H_WINDOWS_H +#include "cyglacks.h" +#endif +#undef DBEGIN +#define DBEGIN 0x400000 + +#include "ntheap.h" +/* Info for keeping track of our heap. */ +unsigned char *data_region_base = UNINIT_PTR; +unsigned char *data_region_end = UNINIT_PTR; +unsigned char *real_data_region_end = UNINIT_PTR; +unsigned long data_region_size = UNINIT_LONG; +unsigned long reserved_heap_size = UNINIT_LONG; + + +void mymemcpy(void *a, void *b ,int n) +{ + char *p=a; + char *q=b; + while(--n>=0) + { int c = q[0]; + q++; + p[0]=c; + p++; + } +} + +PIMAGE_SECTION_HEADER get_section_named(PIMAGE_NT_HEADERS nt_header,char *name); + +/* Dump out .data and .bss sections into a new executable. */ +void +unexec (char *new_name, char *old_name, void *start_data, void *start_bss, + void *entry_address) +{ + file_data in_file, out_file; + unsigned long size,header_size,file_size,i; + int last,foffset; + PIMAGE_DOS_HEADER old_dos_header,new_dos_header; + PIMAGE_NT_HEADERS old_nt_header,new_nt_header; + PIMAGE_SECTION_HEADER old_section, old_sptr,old_data_section; + PIMAGE_SECTION_HEADER new_section, new_sptr,new_data_section; + PIMAGE_SECTION_HEADER s; + long membase; + char *base; + + if (!get_allocation_unit()) + cache_system_info (); + if (!open_input_file (&in_file, old_name)) { + printf ("Failed to open %s (%d)...bailing.\n", + old_name, GetLastError ()); + exit (1); + } + + old_dos_header = (PIMAGE_DOS_HEADER) in_file.file_base; + if (old_dos_header->e_magic != IMAGE_DOS_SIGNATURE) + { + printf ("Unknown EXE header in %s...bailing.\n", in_file.name); + exit (1); + } + old_nt_header = (PIMAGE_NT_HEADERS) (((unsigned long) old_dos_header) + + old_dos_header->e_lfanew); + if (old_nt_header == NULL) + { + printf ("Failed to find IMAGE_NT_HEADER in %s...bailing.\n", + in_file.name); + exit (1); + } + + /* Check the NT header signature ... */ + if (old_nt_header->Signature != IMAGE_NT_SIGNATURE) + { + printf ("Invalid IMAGE_NT_SIGNATURE 0x%x in %s...bailing.\n", + old_nt_header->Signature, in_file.name); + } + + /* Flip through the sections for .data and .bss ... */ + old_section = (PIMAGE_SECTION_HEADER) IMAGE_FIRST_SECTION (old_nt_header); + old_sptr= get_section_named(old_nt_header,".bss"); + old_data_section= get_section_named(old_nt_header,".data"); + header_size = old_section[0].PointerToRawData ; + + + base = alloca(header_size); + memcpy (base,in_file.file_base, header_size); + new_dos_header = (PIMAGE_DOS_HEADER) base; + new_nt_header = (PIMAGE_NT_HEADERS) (((unsigned long) new_dos_header) + + new_dos_header->e_lfanew); + new_section = (PIMAGE_SECTION_HEADER) IMAGE_FIRST_SECTION (new_nt_header); + /* fix up the .bss section so that it is stored in file and + mark its characteristics to show load. + */ + if (old_sptr->Characteristics != old_data_section->Characteristics) + { + int j; + new_sptr= get_section_named(new_nt_header,".bss"); + new_data_section= get_section_named(new_nt_header,".data"); + new_sptr->Characteristics = old_data_section->Characteristics; + j = new_sptr - new_section; +#define S_ALIGN (1<<3) +#define ROUND_UP(x,n) (((((unsigned int)x)+(n)-1)/(n))*(n)) + new_sptr->PointerToRawData = new_sptr[1].PointerToRawData; + new_sptr->SizeOfRawData = ROUND_UP(new_sptr->Misc.VirtualSize,S_ALIGN); + foffset = new_sptr->SizeOfRawData; + + + + foffset = new_sptr->Misc.VirtualSize; + for(i= new_sptr-new_section+1; i < new_nt_header->FileHeader.NumberOfSections; i++) + {int tem ; + new_section[i].PointerToRawData += foffset; + tem = new_section[i].PointerToRawData + new_section[i].SizeOfRawData; + if (last < tem ) + last = tem; + } + } + + membase = old_nt_header->OptionalHeader.ImageBase; + /* if there is new data from sbrk + add it into .dataX section + */ + if (real_data_region_end - data_region_base) { + s = get_section_named(new_nt_header,".dataX"); + if (s ) { + s->SizeOfRawData = real_data_region_end - data_region_base; + } else { + /* tack in a new section */ + s = &new_section[new_nt_header->FileHeader.NumberOfSections]; + *s = *new_data_section; + strcpy(s->Name,".dataX"); + s->VirtualAddress = data_region_base - (unsigned char *)membase; + s->SizeOfRawData = real_data_region_end - data_region_base; + s->PointerToRawData = ROUND_UP(last,S_ALIGN) ; + new_nt_header->FileHeader.NumberOfSections += 1; + if ((char *)&s[1] -base > header_size) + { printf("unexpected fit"); + /* to do: we will have to recode moving all sections up + */ + exit(1); + } + } + + } + s = &new_section[new_nt_header->FileHeader.NumberOfSections-1]; + file_size = s->PointerToRawData + s->SizeOfRawData; + if (!open_output_file (&out_file, new_name, file_size)) + { + printf ("Failed to open %s (%d)...bailing.\n", + new_name, GetLastError ()); + exit (1); + } + for(i=0; i < file_size; i++) + out_file.file_base[i]='a'; + + + memcpy (out_file.file_base,base, header_size); + + for(i= 0; i < new_nt_header->FileHeader.NumberOfSections; i++) + { PIMAGE_SECTION_HEADER new,old; + new = &new_section[i]; + old = &old_section[i]; + if (new->Characteristics == old_data_section->Characteristics) + { mymemcpy(out_file.file_base + new->PointerToRawData, + (void *) (new->VirtualAddress + membase), + new->SizeOfRawData) + ; + } else if (new->SizeOfRawData) + { + memcpy(out_file.file_base + new->PointerToRawData, + in_file.file_base+ + old->PointerToRawData + ,new->SizeOfRawData); + + } + } + close_file_data (&in_file); + close_file_data (&out_file); +} + +PIMAGE_SECTION_HEADER +get_section_named(PIMAGE_NT_HEADERS nt_header,char *name) +{ + int i; + PIMAGE_SECTION_HEADER section, data_section; + section = (PIMAGE_SECTION_HEADER) IMAGE_FIRST_SECTION (nt_header); + for (i = 0; i < nt_header->FileHeader.NumberOfSections; i++) + { + if (strcmp(section[i].Name,name) == 0) + return §ion[i]; + } + return 0; +} + +int billy; +const char jim[]="before"; +char *jill = jim; +main(int argc,char *argv[]) +{ + printf("billy=%d,jill=%s",billy,jill); + if (billy == 0) { + billy=1; + jill = sbrk(101); + strcpy(jill,"hello"); + } + unexec(argv[1],argv[0],0,0,0); + return 0; +} + + + + + + + + +/* File handling. */ + + +int +open_input_file (file_data *p_file, char *filename) +{ + HANDLE file; + HANDLE file_mapping; + void *file_base; + unsigned long size, upper_size; + + file = CreateFile (filename, GENERIC_READ, FILE_SHARE_READ, NULL, + OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); + if (file == INVALID_HANDLE_VALUE) + return FALSE; + + size = GetFileSize (file, &upper_size); + file_mapping = CreateFileMapping (file, NULL, PAGE_READONLY, + 0, size, NULL); + if (!file_mapping) + return FALSE; + + file_base = MapViewOfFile (file_mapping, FILE_MAP_READ, 0, 0, size); + if (file_base == 0) + return FALSE; + + p_file->name = filename; + p_file->size = size; + p_file->file = file; + p_file->file_mapping = file_mapping; + p_file->file_base = file_base; + + return TRUE; +} + +int +open_output_file (file_data *p_file, char *filename, unsigned long size) +{ + HANDLE file; + HANDLE file_mapping; + void *file_base; + + file = CreateFile (filename, GENERIC_READ | GENERIC_WRITE, 0, NULL, + CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0); + if (file == INVALID_HANDLE_VALUE) + return FALSE; + + file_mapping = CreateFileMapping (file, NULL, PAGE_READWRITE, + 0, size, NULL); + if (!file_mapping) + return FALSE; + + file_base = MapViewOfFile (file_mapping, FILE_MAP_WRITE, 0, 0, size); + if (file_base == 0) + return FALSE; + + p_file->name = filename; + p_file->size = size; + p_file->file = file; + p_file->file_mapping = file_mapping; + p_file->file_base = file_base; + + return TRUE; +} + +/* Close the system structures associated with the given file. */ +void +close_file_data (file_data *p_file) +{ + UnmapViewOfFile (p_file->file_base); + CloseHandle (p_file->file_mapping); + CloseHandle (p_file->file); +} + + + + + +/* #include "lisp.h" */ /* for VALMASK */ +#define VALMASK -1 +/* try for 500 MB of address space */ +#define VALBITS 29 + +static char * +allocate_heap (void) +{ + /* The base address for our GNU malloc heap is chosen in conjuction + with the link settings for temacs.exe which control the stack size, + the initial default process heap size and the executable image base + address. The link settings and the malloc heap base below must all + correspond; the relationship between these values depends on how NT + and Win95 arrange the virtual address space for a process (and on + the size of the code and data segments in temacs.exe). + + The most important thing is to make base address for the executable + image high enough to leave enough room between it and the 4MB floor + of the process address space on Win95 for the primary thread stack, + the process default heap, and other assorted odds and ends + (eg. environment strings, private system dll memory etc) that are + allocated before temacs has a chance to grab its malloc arena. The + malloc heap base can then be set several MB higher than the + executable image base, leaving enough room for the code and data + segments. + + Because some parts of Emacs can use rather a lot of stack space + (for instance, the regular expression routines can potentially + allocate several MB of stack space) we allow 8MB for the stack. + + Allowing 1MB for the default process heap, and 1MB for odds and + ends, we can base the executable at 16MB and still have a generous + safety margin. At the moment, the executable has about 810KB of + code (for x86) and about 550KB of data - on RISC platforms the code + size could be roughly double, so if we allow 4MB for the executable + we will have plenty of room for expansion. + + Thus we would like to set the malloc heap base to 20MB. However, + Win95 refuses to allocate the heap starting at this address, so we + set the base to 27MB to make it happy. Since Emacs now leaves + 28 bits available for pointers, this lets us use the remainder of + the region below the 256MB line for our malloc arena - 229MB is + still a pretty decent arena to play in! */ + + unsigned long base = DBEGIN; /* 27MB */ + /* unsigned long base = 0x01B00000; */ /* 27MB */ + unsigned long end = 1 << VALBITS; /* 256MB */ + void *ptr = NULL; + +#define NTHEAP_PROBE_BASE 1 +#if NTHEAP_PROBE_BASE /* This is never normally defined */ + /* Try various addresses looking for one the kernel will let us have. */ + while (!ptr && (base < end)) + { + reserved_heap_size = end - base; + ptr = VirtualAlloc ((void *) base, + get_reserved_heap_size (), + MEM_RESERVE, + PAGE_NOACCESS); + base += 0x00100000; /* 1MB increment */ + } +#else + reserved_heap_size = end - base; + ptr = VirtualAlloc ((void *) base, + get_reserved_heap_size (), + MEM_RESERVE, + PAGE_NOACCESS); +#endif + + return ptr; +} + +/* This gives us the page size and the size of the allocation unit on NT. */ +SYSTEM_INFO sysinfo_cache; +unsigned long syspage_mask = 0; +int nt_major_version; +int nt_minor_version; +/* Distinguish between Windows NT and Windows 95. */ +int os_subtype; + +/* Cache information describing the NT system for later use. */ +void +cache_system_info (void) +{ + union + { + struct info + { + char major; + char minor; + short platform; + } info; + DWORD data; + } version; + + if (os_subtype) return; + + /* Cache the version of the operating system. */ + version.data = GetVersion (); + nt_major_version = version.info.major; + nt_minor_version = version.info.minor; + + if (version.info.platform & 0x8000) + os_subtype = OS_WIN95; + else + os_subtype = OS_NT; + + /* Cache page size, allocation unit, processor type, etc. */ + GetSystemInfo (&sysinfo_cache); + syspage_mask = sysinfo_cache.dwPageSize - 1; +} + + + +/* Emulate Unix sbrk. */ +void * +sbrk (unsigned long increment) +{ + void *result; + long size = (long) increment; + + cache_system_info(); + + /* Allocate our heap if we haven't done so already. */ + if (data_region_base == UNINIT_PTR) + { + data_region_base = allocate_heap (); + if (!data_region_base) + return NULL; + + /* Ensure that the addresses don't use the upper tag bits since + the Lisp type goes there. */ + if (((unsigned long) data_region_base & ~VALMASK) != 0) + { + printf ("Error: The heap was allocated in upper memory.\n"); + exit (1); + } + + data_region_end = data_region_base; + real_data_region_end = data_region_end; + data_region_size = get_reserved_heap_size (); + } + + result = data_region_end; + + /* If size is negative, shrink the heap by decommitting pages. */ + if (size < 0) + { + int new_size; + unsigned char *new_data_region_end; + + size = -size; + + /* Sanity checks. */ + if ((data_region_end - size) < data_region_base) + return NULL; + + /* We can only decommit full pages, so allow for + partial deallocation [cga]. */ + new_data_region_end = (data_region_end - size); + new_data_region_end = (unsigned char *) + ((long) (new_data_region_end + syspage_mask) & ~syspage_mask); + new_size = real_data_region_end - new_data_region_end; + real_data_region_end = new_data_region_end; + if (new_size > 0) + { + /* Decommit size bytes from the end of the heap. */ + if (!VirtualFree (real_data_region_end, new_size, MEM_DECOMMIT)) + return NULL; + } + + data_region_end -= size; + } + /* If size is positive, grow the heap by committing reserved pages. */ + else if (size > 0) + { + /* Sanity checks. */ + if ((data_region_end + size) > + (data_region_base + get_reserved_heap_size ())) + return NULL; + + /* Commit more of our heap. */ + if (VirtualAlloc (data_region_end, size, MEM_COMMIT, + PAGE_READWRITE) == NULL) + return NULL; + data_region_end += size; + + /* We really only commit full pages, so record where + the real end of committed memory is [cga]. */ + real_data_region_end = (unsigned char *) + ((long) (data_region_end + syspage_mask) & ~syspage_mask); + } + + return result; +} diff --git a/o/typespec.c b/o/typespec.c new file mode 100755 index 0000000..9a8b124 --- /dev/null +++ b/o/typespec.c @@ -0,0 +1,350 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +/* + typespec.c + + type specifier routines +*/ + +#define NEED_MP_H +#include "include.h" + +object sLkeyword; + +enum type t_vtype; +int vtypep_fn(object x) {return type_of(x)==t_vtype;} + +LFD(Ltype_of)(void) +{ + int i; + + check_arg(1); + + switch (type_of(vs_base[0])) { + case t_fixnum: + vs_base[0] = sLfixnum; + break; + + case t_bignum: + vs_base[0] = sLbignum; + break; + + case t_ratio: + vs_base[0] = sLratio; + break; + + case t_shortfloat: + vs_base[0] = sLshort_float; + break; + + case t_longfloat: + vs_base[0] = sLlong_float; + break; + + case t_complex: + vs_base[0] = sLcomplex; + break; + + case t_character: + if (char_font(vs_base[0]) != 0 + || char_bits(vs_base[0]) != 0) + vs_base[0] = sLcharacter; + else { + i = char_code(vs_base[0]); + if ((' ' <= i && i < '\177') || i == '\n') + vs_base[0] = sLstandard_char; + else + vs_base[0] = sLstring_char; + } + break; + + case t_symbol: + if (vs_base[0]->s.s_hpack == keyword_package) + vs_base[0] = sLkeyword; + else + vs_base[0] = sLsymbol; + break; + + case t_package: + vs_base[0] = sLpackage; + break; + + case t_cons: + vs_base[0] = sLcons; + break; + + case t_hashtable: + vs_base[0] = sLhash_table; + break; + + case t_array: + if (vs_base[0]->a.a_adjustable || + vs_base[0]->a.a_displaced->c.c_car == Cnil) + vs_base[0] = sLarray; + else + vs_base[0] = sLsimple_array; + break; + + case t_vector: + if (vs_base[0]->v.v_adjustable || + vs_base[0]->v.v_hasfillp || + vs_base[0]->v.v_displaced->c.c_car == Cnil || + (enum aelttype)vs_base[0]->v.v_elttype != aet_object) + vs_base[0] = sLvector; + else + vs_base[0] = sLsimple_vector; + break; + + case t_string: + if (vs_base[0]->st.st_adjustable || + vs_base[0]->st.st_hasfillp || + vs_base[0]->st.st_displaced->c.c_car == Cnil) + vs_base[0] = sLstring; + else + vs_base[0] = sLsimple_string; + break; + + case t_bitvector: + if (vs_base[0]->bv.bv_adjustable || + vs_base[0]->bv.bv_hasfillp || + vs_base[0]->bv.bv_displaced->c.c_car == Cnil) + vs_base[0] = sLbit_vector; + else + vs_base[0] = sLsimple_bit_vector; + break; + + case t_structure: + + vs_base[0] = S_DATA(vs_base[0]->str.str_def)->name; + break; + + case t_stream: +#ifdef USER_DEFINED_STREAMS + if (vs_base[0]->sm.sm_mode == (int)smm_user_defined) + vs_base[0]= vs_base[0]->sm.sm_object1->str.str_self[8]; + else +#endif + vs_base[0] = sLstream; + break; + + case t_readtable: + vs_base[0] = sLreadtable; + break; + + case t_pathname: + vs_base[0] = sLpathname; + break; + + case t_random: + vs_base[0] = sLrandom_state; + break; + + case t_sfun: + case t_gfun: + case t_cfun: + case t_vfun: + case t_afun: + case t_cclosure: + case t_closure: + vs_base[0] = sLcompiled_function; + break; + + default: + error("not a lisp data object"); + } +} + +DEF_ORDINARY("PROCLAIMED-ARG-TYPES",sSproclaimed_arg_types,SI,""); +DEF_ORDINARY("PROCLAIMED-RETURN-TYPE",sSproclaimed_return_type,SI,""); +DEF_ORDINARY("PROCLAIMED-FUNCTION",sSproclaimed_function,SI,""); +DEF_ORDINARY("COMMON",sLcommon,LISP,""); +DEF_ORDINARY("NULL",sLnull,LISP,""); +DEF_ORDINARY("CONS",sLcons,LISP,""); +DEF_ORDINARY("LIST",sLlist,LISP,""); +DEF_ORDINARY("SYMBOL",sLsymbol,LISP,""); +DEF_ORDINARY("ARRAY",sLarray,LISP,""); +DEF_ORDINARY("VECTOR",sLvector,LISP,""); +DEF_ORDINARY("BIT-VECTOR",sLbit_vector,LISP,""); +DEF_ORDINARY("STRING",sLstring,LISP,""); +DEF_ORDINARY("SEQUENCE",sLsequence,LISP,""); +DEF_ORDINARY("SIMPLE-ARRAY",sLsimple_array,LISP,""); +DEF_ORDINARY("SIMPLE-VECTOR",sLsimple_vector,LISP,""); +DEF_ORDINARY("SIMPLE-BIT-VECTOR",sLsimple_bit_vector,LISP,""); +DEF_ORDINARY("SIMPLE-STRING",sLsimple_string,LISP,""); +DEF_ORDINARY("FUNCTION",sLfunction,LISP,""); +DEF_ORDINARY("COMPILED-FUNCTION",sLcompiled_function,LISP,""); +DEF_ORDINARY("PATHNAME",sLpathname,LISP,""); +DEF_ORDINARY("CHARACTER",sLcharacter,LISP,""); +DEF_ORDINARY("NUMBER",sLnumber,LISP,""); +DEF_ORDINARY("RATIONAL",sLrational,LISP,""); +DEF_ORDINARY("FLOAT",sLfloat,LISP,""); +DEF_ORDINARY("STRING-CHAR",sLstring_char,LISP,""); +DEF_ORDINARY("REAL",sLreal,LISP,""); +DEF_ORDINARY("INTEGER",sLinteger,LISP,""); +DEF_ORDINARY("RATIO",sLratio,LISP,""); +DEF_ORDINARY("SHORT-FLOAT",sLshort_float,LISP,""); +DEF_ORDINARY("STANDARD-CHAR",sLstandard_char,LISP,""); +DEF_ORDINARY("BOOLEAN",sLboolean,LISP,""); +DEF_ORDINARY("FIXNUM",sLfixnum,LISP,""); +DEF_ORDINARY("POSITIVE-FIXNUM",sLpositive_fixnum,LISP,""); +DEF_ORDINARY("COMPLEX",sLcomplex,LISP,""); +DEF_ORDINARY("SINGLE-FLOAT",sLsingle_float,LISP,""); +DEF_ORDINARY("PACKAGE",sLpackage,LISP,""); +DEF_ORDINARY("BIGNUM",sLbignum,LISP,""); +DEF_ORDINARY("RANDOM-STATE",sLrandom_state,LISP,""); +DEF_ORDINARY("DOUBLE-FLOAT",sLdouble_float,LISP,""); +DEF_ORDINARY("STREAM",sLstream,LISP,""); +DEF_ORDINARY("BIT",sLbit,LISP,""); +DEF_ORDINARY("READTABLE",sLreadtable,LISP,""); +DEF_ORDINARY("LONG-FLOAT",sLlong_float,LISP,""); +DEF_ORDINARY("HASH-TABLE",sLhash_table,LISP,""); +DEF_ORDINARY("KEYWORD",sLkeyword,LISP,""); +DEF_ORDINARY("STRUCTURE",sLstructure,LISP,""); +DEF_ORDINARY("SATISFIES",sLsatisfies,LISP,""); +DEF_ORDINARY("MEMBER",sLmember,LISP,""); +DEF_ORDINARY("NOT",sLnot,LISP,""); +DEF_ORDINARY("OR",sLor,LISP,""); +DEF_ORDINARY("AND",sLand,LISP,""); +DEF_ORDINARY("VALUES",sLvalues,LISP,""); +DEF_ORDINARY("MOD",sLmod,LISP,""); +DEF_ORDINARY("SIGNED-BYTE",sLsigned_byte,LISP,""); +DEF_ORDINARY("UNSIGNED-BYTE",sLunsigned_byte,LISP,""); +DEF_ORDINARY("SIGNED-CHAR",sLsigned_char,LISP,""); +DEF_ORDINARY("UNSIGNED-CHAR",sLunsigned_char,LISP,""); +DEF_ORDINARY("SIGNED-SHORT",sLsigned_short,LISP,""); +DEF_ORDINARY("UNSIGNED-SHORT",sLunsigned_short,LISP,""); +DEF_ORDINARY("*",sLA,LISP,""); +DEF_ORDINARY("PLUSP",sLplusp,LISP,""); +DEF_ORDINARY("DIVISION-BY-ZERO",sLdivision_by_zero,LISP,""); +DEF_ORDINARY("FLOATING-POINT-INEXACT",sLfloating_point_inexact,LISP,""); +DEF_ORDINARY("FLOATING-POINT-INVALID-OPERATION",sLfloating_point_invalid_operation,LISP,""); +DEF_ORDINARY("FLOATING-POINT-OVERFLOW",sLfloating_point_overflow,LISP,""); +DEF_ORDINARY("FLOATING-POINT-UNDERFLOW",sLfloating_point_underflow,LISP,""); +DEF_ORDINARY("PROGRAM-ERROR",sLprogram_error,LISP,""); +DEF_ORDINARY("UNDEFINED-FUNCTION",sLundefined_function,LISP,""); +DEF_ORDINARY("UNBOUND-VARIABLE",sLunbound_variable,LISP,""); +DEF_ORDINARY("PACKAGE-ERROR",sLpackage_error,LISP,""); + +/* #ifdef ANSI_COMMON_LISP */ +/* New ansi types */ +DEF_ORDINARY("METHOD-COMBINATION",sLmethod_combination,LISP,""); +DEF_ORDINARY("ARITHMETIC-ERROR",sLarithmetic_error,LISP,""); +DEF_ORDINARY("BASE-CHAR",sLbase_char,LISP,""); +DEF_ORDINARY("BASE-STRING",sLbase_string,LISP,""); +DEF_ORDINARY("BROADCAST-STREAM",sLbroadcast_stream,LISP,""); +DEF_ORDINARY("BUILT-IN-CLASS",sLbuilt_in_class,LISP,""); +DEF_ORDINARY("CELL-ERROR",sLcell_error,LISP,""); +DEF_ORDINARY("CLASS",sLclass,LISP,""); +DEF_ORDINARY("CONCATENATED-STREAM",sLconcatenated_stream,LISP,""); +DEF_ORDINARY("CONDITION",sLcondition,LISP,""); +DEF_ORDINARY("CONTROL-ERROR",sLcontrol_error,LISP,""); +DEF_ORDINARY("ECHO-STREAM",sLecho_stream,LISP,""); +DEF_ORDINARY("END-OF-FILE",sLend_of_file,LISP,""); +DEF_ORDINARY("ERROR",sLerror,LISP,""); +DEF_ORDINARY("EXTENDED-CHAR",sLextended_char,LISP,""); +DEF_ORDINARY("FILE-ERROR",sLfile_error,LISP,""); +DEF_ORDINARY("FILE-STREAM",sLfile_stream,LISP,""); +DEF_ORDINARY("GENERIC-FUNCTION",sLgeneric_function,LISP,""); +DEF_ORDINARY("LOGICAL-PATHNAME",sLlogical_pathname,LISP,""); +DEF_ORDINARY("METHOD",sLmethod,LISP,""); +/* FIXME -- need this for types in predlib.lsp, why can't we use the keyword sKpackage_error ? */ +DEF_ORDINARY("PARSE-ERROR",sLparse_error,LISP,""); +DEF_ORDINARY("PRINT-NOT-READABLE",sLprint_not_readable,LISP,""); +DEF_ORDINARY("READER-ERROR",sLreader_error,LISP,""); +DEF_ORDINARY("SERIOUS-CONDITION",sLserious_condition,LISP,""); +DEF_ORDINARY("SIMPLE-BASE-STRING",sLsimple_base_string,LISP,""); +DEF_ORDINARY("SIMPLE-CONDITION",sLsimple_condition,LISP,""); +DEF_ORDINARY("SIMPLE-TYPE-ERROR",sLsimple_type_error,LISP,""); +DEF_ORDINARY("SIMPLE-WARNING",sLsimple_warning,LISP,""); +DEF_ORDINARY("STANDARD-CLASS",sLstandard_class,LISP,""); +DEF_ORDINARY("STANDARD-GENERIC-FUNCTION",sLstandard_generic_function,LISP,""); +DEF_ORDINARY("STANDARD-METHOD",sLstandard_method,LISP,""); +DEF_ORDINARY("STANDARD-OBJECT",sLstandard_object,LISP,""); +DEF_ORDINARY("STORAGE-CONDITION",sLstorage_condition,LISP,""); +DEF_ORDINARY("STREAM-ERROR",sLstream_error,LISP,""); +DEF_ORDINARY("STRING-STREAM",sLstring_stream,LISP,""); +DEF_ORDINARY("STRUCTURE-CLASS",sLstructure_class,LISP,""); +DEF_ORDINARY("STRUCTURE-OBJECT",sLstructure_object,LISP,""); +DEF_ORDINARY("STYLE-WARNING",sLstyle_warning,LISP,""); +DEF_ORDINARY("SYNONYM-STREAM",sLsynonym_stream,LISP,""); +DEF_ORDINARY("TWO-WAY-STREAM",sLtwo_way_stream,LISP,""); +DEF_ORDINARY("TYPE-ERROR",sLtype_error,LISP,""); +DEF_ORDINARY("UNBOUND-SLOT",sLunbound_slot,LISP,""); +DEF_ORDINARY("WARNING",sLwarning,LISP,""); +/* #endif */ + +DEFCONST("CHAR-SIZE",sSchar_size,SI,small_fixnum(CHAR_SIZE),"Size in bits of a character"); +DEFCONST("SHORT-SIZE",sSshort_size,SI,small_fixnum(CHAR_SIZE*sizeof(short)),"Size in bits of a short integer"); + +void +gcl_init_typespec(void) +{ +} + +void +gcl_init_typespec_function(void) +{ + TSor_symbol_string + = make_cons(sLor, make_cons(sLsymbol, make_cons(sLstring, Cnil))); + enter_mark_origin(&TSor_symbol_string); + TSor_string_symbol + = make_cons(sLor, make_cons(sLstring, make_cons(sLsymbol, Cnil))); + enter_mark_origin(&TSor_string_symbol); + TSor_symbol_string_package + = make_cons(sLor, + make_cons(sLsymbol, + make_cons(sLstring, + make_cons(sLpackage, Cnil)))); + enter_mark_origin(&TSor_symbol_string_package); + + TSnon_negative_integer + = make_cons(sLinteger, + make_cons(make_fixnum(0), make_cons(sLA, Cnil))); + enter_mark_origin(&TSnon_negative_integer); + TSpositive_number = make_cons(sLsatisfies, make_cons(sLplusp, Cnil)); + enter_mark_origin(&TSpositive_number); + TSor_integer_float + = make_cons(sLor, make_cons(sLinteger, make_cons(sLfloat, Cnil))); + enter_mark_origin(&TSor_integer_float); + TSor_rational_float + = make_cons(sLor, make_cons(sLrational, make_cons(sLfloat, Cnil))); + enter_mark_origin(&TSor_rational_float); +#ifdef UNIX + TSor_pathname_string_symbol + = make_cons(sLor, + make_cons(sLpathname, + make_cons(sLstring, + make_cons(sLsymbol, + Cnil)))); + enter_mark_origin(&TSor_pathname_string_symbol); +#endif + TSor_pathname_string_symbol_stream + = make_cons(sLor, + make_cons(sLpathname, + make_cons(sLstring, + make_cons(sLsymbol, + make_cons(sLstream, + Cnil))))); + enter_mark_origin(&TSor_pathname_string_symbol_stream); + + make_function("TYPE-OF", Ltype_of); +} diff --git a/o/u370_emul.s b/o/u370_emul.s new file mode 100755 index 0000000..45bab7e --- /dev/null +++ b/o/u370_emul.s @@ -0,0 +1,82 @@ + file_ tmp.c + entry $oVhc2_1r +$oVhc2_1r equ 0 + entry $oVO +$oVO equ 0 +L$$C0 csect + ds 0d +L00$TEXT equ * + entry _extended_mul +* -------------| extended_mul |-----------------------# + ds 0f + dc al2(0) arglength in words + dc xl2'FFFF' argument regs unknown + dc al4(LE$1-_extended_mul) code size + dc xl2'0000' no flags currently defined + dc al1(5) parmlength in words + dc al1(1) format +_extended_mul ds 0h +LX$011 equ * + using LX$011,12 + stm LR$1,15,x'10'+LV$1(13) + lr 12,13 + la 11,x'60' + slr 13,11 + st 12,4(,13) + lr 12,15 + lr 15,1 + mr 14,0 + alr 15,2 +# branch on carry + bc 3,Loverflow +# store the results +Lresult sldl 14,1(0) + srl 15,1(0) + l 1,x'B8'(,13) # lp + st 15,0(,1) + st 14,0(,3) + lm LR$1,14,x'70'+LV$1(13) + br 14 +Loverflow ah 14,LC$014 + b Lresult +LE$1 equ * +LR$1 equ 2 +LV$1 equ 0 +LC$014 equ * + dc xl2'0001' + end + entry _extended_div +* -------------| extended_div |-----------------------# + ds 0f + dc al2(0) arglength in words + dc xl2'FFFF' argument regs unknown + dc al4(LE$2-_extended_div) code size + dc xl2'0000' no flags currently defined + dc al1(5) parmlength in words + dc al1(1) format +_extended_div ds 0h +LX$021 equ * + using LX$021,12 + stm LR$2,15,x'10'+LV$2(13) + lr 12,13 + la 11,x'60' + slr 13,11 + st 12,4(,13) + lr 12,15 +* put h,l in 14,15 + lr 14,1 + lr 15,2 + sll 15,1 + srdl 14,1 + dr 14,0 +* store the quotient + st 15,0(,3) + l 1,x'B8'(,13) # rp +* store the remainder + st 14,0(,1) + lm LR$2,14,x'70'+LV$2(13) + br 14 +LE$2 equ * +LR$2 equ 2 +LV$2 equ 0 + end diff --git a/o/unexaix.c b/o/unexaix.c new file mode 100644 index 0000000..df1dad6 --- /dev/null +++ b/o/unexaix.c @@ -0,0 +1,936 @@ +/* Modified by Andrew.Vignaux@comp.vuw.ac.nz to get it to work :-) */ + +/* Copyright (C) 1985, 1986, 1987, 1988 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. + +In other words, you are welcome to use, share and improve this program. +You are forbidden to forbid anyone else to use, share and improve +what you give them. Help stamp out software-hoarding! */ + + +/* + * unexec.c - Convert a running program into an a.out file. + * + * Author: Spencer W. Thomas + * Computer Science Dept. + * University of Utah + * Date: Tue Mar 2 1982 + * Modified heavily since then. + * + * Updated for AIX 4.1.3 by Bill_Mann @ PraxisInt.com, Feb 1996 + * As of AIX 4.1, text, data, and bss are pre-relocated by the binder in + * such a way that the file can be mapped with code in one segment and + * data/bss in another segment, without reading or copying the file, by + * the AIX exec loader. Padding sections are omitted, nevertheless + * small amounts of 'padding' still occurs between sections in the file. + * As modified, this code handles both 3.2 and 4.1 conventions. + * + * Synopsis: + * unexec (new_name, a_name, data_start, bss_start, entry_address) + * char *new_name, *a_name; + * unsigned data_start, bss_start, entry_address; + * + * Takes a snapshot of the program and makes an a.out format file in the + * file named by the string argument new_name. + * If a_name is non-NULL, the symbol table will be taken from the given file. + * On some machines, an existing a_name file is required. + * + * The boundaries within the a.out file may be adjusted with the data_start + * and bss_start arguments. Either or both may be given as 0 for defaults. + * + * Data_start gives the boundary between the text segment and the data + * segment of the program. The text segment can contain shared, read-only + * program code and literal data, while the data segment is always unshared + * and unprotected. Data_start gives the lowest unprotected address. + * The value you specify may be rounded down to a suitable boundary + * as required by the machine you are using. + * + * Specifying zero for data_start means the boundary between text and data + * should not be the same as when the program was loaded. + * If NO_REMAP is defined, the argument data_start is ignored and the + * segment boundaries are never changed. + * + * Bss_start indicates how much of the data segment is to be saved in the + * a.out file and restored when the program is executed. It gives the lowest + * unsaved address, and is rounded up to a page boundary. The default when 0 + * is given assumes that the entire data segment is to be stored, including + * the previous data and bss as well as any additional storage allocated with + * break (2). + * + * The new file is set up to start at entry_address. + * + * If you make improvements I'd like to get them too. + * harpo!utah-cs!thomas, thomas@Utah-20 + * + */ + +/* There are several compilation parameters affecting unexec: + +* COFF + +Define this if your system uses COFF for executables. +Otherwise we assume you use Berkeley format. + +* NO_REMAP + +Define this if you do not want to try to save Emacs's pure data areas +as part of the text segment. + +Saving them as text is good because it allows users to share more. + +However, on machines that locate the text area far from the data area, +the boundary cannot feasibly be moved. Such machines require +NO_REMAP. + +Also, remapping can cause trouble with the built-in startup routine +/lib/crt0.o, which defines `environ' as an initialized variable. +Dumping `environ' as pure does not work! So, to use remapping, +you must write a startup routine for your machine in Emacs's crt0.c. +If NO_REMAP is defined, Emacs uses the system's crt0.o. + +* SECTION_ALIGNMENT + +Some machines that use COFF executables require that each section +start on a certain boundary *in the COFF file*. Such machines should +define SECTION_ALIGNMENT to a mask of the low-order bits that must be +zero on such a boundary. This mask is used to control padding between +segments in the COFF file. + +If SECTION_ALIGNMENT is not defined, the segments are written +consecutively with no attempt at alignment. This is right for +unmodified system V. + +* SEGMENT_MASK + +Some machines require that the beginnings and ends of segments +*in core* be on certain boundaries. For most machines, a page +boundary is sufficient. That is the default. When a larger +boundary is needed, define SEGMENT_MASK to a mask of +the bits that must be zero on such a boundary. + +* A_TEXT_OFFSET(HDR) + +Some machines count the a.out header as part of the size of the text +segment (a_text); they may actually load the header into core as the +first data in the text segment. Some have additional padding between +the header and the real text of the program that is counted in a_text. + +For these machines, define A_TEXT_OFFSET(HDR) to examine the header +structure HDR and return the number of bytes to add to `a_text' +before writing it (above and beyond the number of bytes of actual +program text). HDR's standard fields are already correct, except that +this adjustment to the `a_text' field has not yet been made; +thus, the amount of offset can depend on the data in the file. + +* A_TEXT_SEEK(HDR) + +If defined, this macro specifies the number of bytes to seek into the +a.out file before starting to write the text segment.a + +* EXEC_MAGIC + +For machines using COFF, this macro, if defined, is a value stored +into the magic number field of the output file. + +* ADJUST_EXEC_HEADER + +This macro can be used to generate statements to adjust or +initialize nonstandard fields in the file header + +* ADDR_CORRECT(ADDR) + +Macro to correct an int which is the bit pattern of a pointer to a byte +into an int which is the number of a byte. + +This macro has a default definition which is usually right. +This default definition is a no-op on most machines (where a +pointer looks like an int) but not on all machines. + +*/ + +#define XCOFF +#define COFF +#define NO_REMAP + +#ifndef emacs +#define PERROR(arg) perror (arg); return -1 +#else +#include "config.h" +#define PERROR(file) report_error (file, new) +#endif + +#include +/* Define getpagesize () if the system does not. + Note that this may depend on symbols defined in a.out.h + */ +#include "getpagesize.h" + +#ifndef makedev /* Try to detect types.h already loaded */ +#include +#endif +#include +#include +#include + +extern char *start_of_text (); /* Start of text */ +extern char *start_of_data (); /* Start of initialized data */ + +extern int _data; +extern int _edata; +extern int _text; +extern int _etext; +extern int _end; +#ifdef COFF +#ifndef USG +#ifndef STRIDE +#ifndef UMAX +#ifndef sun386 +/* I have a suspicion that these are turned off on all systems + and can be deleted. Try it in version 19. */ +#include +#include +#include +#include +#endif /* not sun386 */ +#endif /* not UMAX */ +#endif /* Not STRIDE */ +#endif /* not USG */ +static struct filehdr f_hdr; /* File header */ +static struct aouthdr f_ohdr; /* Optional file header (a.out) */ +long bias; /* Bias to add for growth */ +long lnnoptr; /* Pointer to line-number info within file */ + +static long text_scnptr; +static long data_scnptr; +#ifdef XCOFF +#define ALIGN(val, pwr) (((val) + ((1L<<(pwr))-1)) & ~((1L<<(pwr))-1)) +static long load_scnptr; +static long orig_load_scnptr; +static long orig_data_scnptr; +#endif +static ulong data_st; /* start of data area written out */ + +#ifndef MAX_SECTIONS +#define MAX_SECTIONS 10 +#endif + +#endif /* COFF */ + +static int pagemask; + +/* Correct an int which is the bit pattern of a pointer to a byte + into an int which is the number of a byte. + This is a no-op on ordinary machines, but not on all. */ + +#ifndef ADDR_CORRECT /* Let m-*.h files override this definition */ +#define ADDR_CORRECT(x) ((char *)(x) - (char*)0) +#endif + +#ifdef emacs +#include "lisp.h" + +static +report_error (file, fd) + char *file; + int fd; +{ + if (fd) + close (fd); + report_file_error ("Cannot unexec", Fcons (build_string (file), Qnil)); +} +#endif /* emacs */ + +#define ERROR0(msg) report_error_1 (new, msg, 0, 0); return -1 +#define ERROR1(msg,x) report_error_1 (new, msg, x, 0); return -1 +#define ERROR2(msg,x,y) report_error_1 (new, msg, x, y); return -1 + +static +report_error_1 (fd, msg, a1, a2) + int fd; + char *msg; + int a1, a2; +{ + close (fd); +#ifdef emacs + error (msg, a1, a2); +#else + fprintf (stderr, msg, a1, a2); + fprintf (stderr, "\n"); +#endif +} + +static int make_hdr (); +static int mark_x (); +static int copy_text_and_data (); +static int copy_sym (); + +/* **************************************************************** + * unexec + * + * driving logic. + */ +unexec (new_name, a_name, data_start, bss_start, entry_address) + char *new_name, *a_name; + unsigned data_start, bss_start, entry_address; +{ + int new, a_out = -1; + + if (a_name && (a_out = open (a_name, 0)) < 0) + { + PERROR (a_name); + } + if ((new = creat (new_name, 0666)) < 0) + { + PERROR (new_name); + } + if (make_hdr (new,a_out,data_start,bss_start,entry_address,a_name,new_name) < 0 + || copy_text_and_data (new) < 0 + || copy_sym (new, a_out, a_name, new_name) < 0 +#ifdef COFF + || adjust_lnnoptrs (new, a_out, new_name) < 0 +#endif +#ifdef XCOFF + || unrelocate_symbols (new, a_out, a_name, new_name) < 0 +#endif + ) + { + close (new); + return -1; + } + + close (new); + if (a_out >= 0) + close (a_out); + mark_x (new_name); + return 0; +} + +/* **************************************************************** + * make_hdr + * + * Make the header in the new a.out from the header in core. + * Modify the text and data sizes. + */ +static int +make_hdr (new, a_out, data_start, bss_start, entry_address, a_name, new_name) + int new, a_out; + unsigned data_start, bss_start, entry_address; + char *a_name; + char *new_name; +{ + register int scns; + unsigned int bss_end; + + struct scnhdr section[MAX_SECTIONS]; + struct scnhdr * f_thdr; /* Text section header */ + struct scnhdr * f_dhdr; /* Data section header */ + struct scnhdr * f_bhdr; /* Bss section header */ + struct scnhdr * f_lhdr; /* Loader section header */ + struct scnhdr * f_tchdr; /* Typechk section header */ + struct scnhdr * f_dbhdr; /* Debug section header */ + struct scnhdr * f_xhdr; /* Except section header */ + + load_scnptr = orig_load_scnptr = lnnoptr = 0; + pagemask = getpagesize () - 1; + + /* Adjust text/data boundary. */ +#ifdef NO_REMAP + data_start = (long) start_of_data (); +#endif /* NO_REMAP */ + data_start = ADDR_CORRECT (data_start); + +#ifdef SEGMENT_MASK + data_start = data_start & ~SEGMENT_MASK; /* (Down) to segment boundary. */ +#else + data_start = data_start & ~pagemask; /* (Down) to page boundary. */ +#endif + + + bss_end = ADDR_CORRECT (sbrk (0)) + pagemask; + bss_end &= ~ pagemask; + /* Adjust data/bss boundary. */ + if (bss_start != 0) + { + bss_start = (ADDR_CORRECT (bss_start) + pagemask); + /* (Up) to page bdry. */ + bss_start &= ~ pagemask; + if (bss_start > bss_end) + { + ERROR1 ("unexec: Specified bss_start (%u) is past end of program", + bss_start); + } + } + else + bss_start = bss_end; + + if (data_start > bss_start) /* Can't have negative data size. */ + { + ERROR2 ("unexec: data_start (%u) can't be greater than bss_start (%u)", + data_start, bss_start); + } + +#ifdef COFF + /* Salvage as much info from the existing file as possible */ + f_thdr = NULL; f_dhdr = NULL; f_bhdr = NULL; + f_lhdr = NULL; f_tchdr = NULL; f_dbhdr = NULL; f_xhdr = NULL; + if (a_out >= 0) + { + if (read (a_out, &f_hdr, sizeof (f_hdr)) != sizeof (f_hdr)) + { + PERROR (a_name); + } + if (f_hdr.f_opthdr > 0) + { + if (read (a_out, &f_ohdr, sizeof (f_ohdr)) != sizeof (f_ohdr)) + { + PERROR (a_name); + } + } + if (f_hdr.f_nscns > MAX_SECTIONS) + { + ERROR0 ("unexec: too many section headers -- increase MAX_SECTIONS"); + } + /* Loop through section headers */ + for (scns = 0; scns < f_hdr.f_nscns; scns++) { + struct scnhdr *s = §ion[scns]; + if (read (a_out, s, sizeof (*s)) != sizeof (*s)) + { + PERROR (a_name); + } + +#define CHECK_SCNHDR(ptr, name, flags) \ + if (strcmp(s->s_name, name) == 0) { \ + if (s->s_flags != flags) { \ + fprintf(stderr, "unexec: %lx flags where %x expected in %s section.\n", \ + (unsigned long)s->s_flags, flags, name); \ + } \ + if (ptr) { \ + fprintf(stderr, "unexec: duplicate section header for section %s.\n", \ + name); \ + } \ + ptr = s; \ + } + CHECK_SCNHDR(f_thdr, _TEXT, STYP_TEXT); + CHECK_SCNHDR(f_dhdr, _DATA, STYP_DATA); + CHECK_SCNHDR(f_bhdr, _BSS, STYP_BSS); + CHECK_SCNHDR(f_lhdr, _LOADER, STYP_LOADER); + CHECK_SCNHDR(f_dbhdr, _DEBUG, STYP_DEBUG); + CHECK_SCNHDR(f_tchdr, _TYPCHK, STYP_TYPCHK); + CHECK_SCNHDR(f_xhdr, _EXCEPT, STYP_EXCEPT); + } + + if (f_thdr == 0) + { + ERROR1 ("unexec: couldn't find \"%s\" section", _TEXT); + } + if (f_dhdr == 0) + { + ERROR1 ("unexec: couldn't find \"%s\" section", _DATA); + } + if (f_bhdr == 0) + { + ERROR1 ("unexec: couldn't find \"%s\" section", _BSS); + } + } + else + { + ERROR0 ("can't build a COFF file from scratch yet"); + } + orig_data_scnptr = f_dhdr->s_scnptr; + orig_load_scnptr = f_lhdr ? f_lhdr->s_scnptr : 0; + + /* Now we alter the contents of all the f_*hdr variables + to correspond to what we want to dump. */ + + /* Indicate that the reloc information is no longer valid for ld (bind); + we only update it enough to fake out the exec-time loader. */ + f_hdr.f_flags |= (F_RELFLG | F_EXEC); + +#ifdef EXEC_MAGIC + f_ohdr.magic = EXEC_MAGIC; +#endif +#ifndef NO_REMAP + f_ohdr.tsize = data_start - f_ohdr.text_start; + f_ohdr.text_start = (long) start_of_text (); +#endif + data_st = f_ohdr.data_start ? f_ohdr.data_start : (ulong) &_data; + f_ohdr.dsize = bss_start - data_st; + f_ohdr.bsize = bss_end - bss_start; + + f_dhdr->s_size = f_ohdr.dsize; + f_bhdr->s_size = f_ohdr.bsize; + f_bhdr->s_paddr = f_ohdr.data_start + f_ohdr.dsize; + f_bhdr->s_vaddr = f_ohdr.data_start + f_ohdr.dsize; + + /* fix scnptr's */ + { + ulong ptr = section[0].s_scnptr; + + bias = -1; + for (scns = 0; scns < f_hdr.f_nscns; scns++) + { + struct scnhdr *s = §ion[scns]; + + if (s->s_flags & STYP_PAD) /* .pad sections omitted in AIX 4.1 */ + { + /* + * the text_start should probably be o_algntext but that doesn't + * seem to change + */ + if (f_ohdr.text_start != 0) /* && scns != 0 */ + { + s->s_size = 512 - (ptr % 512); + if (s->s_size == 512) + s->s_size = 0; + } + s->s_scnptr = ptr; + } + else if (s->s_flags & STYP_DATA) + s->s_scnptr = ptr; + else if (!(s->s_flags & (STYP_TEXT | STYP_BSS))) + { + if (bias == -1) /* if first section after bss */ + bias = ptr - s->s_scnptr; + + s->s_scnptr += bias; + ptr = s->s_scnptr; + } + + ptr = ptr + s->s_size; + } + } + + /* fix other pointers */ + for (scns = 0; scns < f_hdr.f_nscns; scns++) + { + struct scnhdr *s = §ion[scns]; + + if (s->s_relptr != 0) + { + s->s_relptr += bias; + } + if (s->s_lnnoptr != 0) + { + if (lnnoptr == 0) lnnoptr = s->s_lnnoptr; + s->s_lnnoptr += bias; + } + } + + if (f_hdr.f_symptr > 0L) + { + f_hdr.f_symptr += bias; + } + + text_scnptr = f_thdr->s_scnptr; + data_scnptr = f_dhdr->s_scnptr; + load_scnptr = f_lhdr ? f_lhdr->s_scnptr : 0; + +#ifdef ADJUST_EXEC_HEADER + ADJUST_EXEC_HEADER +#endif /* ADJUST_EXEC_HEADER */ + + if (write (new, &f_hdr, sizeof (f_hdr)) != sizeof (f_hdr)) + { + PERROR (new_name); + } + + if (f_hdr.f_opthdr > 0) + { + if (write (new, &f_ohdr, sizeof (f_ohdr)) != sizeof (f_ohdr)) + { + PERROR (new_name); + } + } + + for (scns = 0; scns < f_hdr.f_nscns; scns++) { + struct scnhdr *s = §ion[scns]; + if (write (new, s, sizeof (*s)) != sizeof (*s)) + { + PERROR (new_name); + } + } + + return (0); + +#endif /* COFF */ +} + +/* **************************************************************** + + * + * Copy the text and data segments from memory to the new a.out + */ +static int +copy_text_and_data (new) + int new; +{ + register char *end; + register char *ptr; + + lseek (new, (long) text_scnptr, 0); + ptr = start_of_text () + text_scnptr; + end = ptr + f_ohdr.tsize; + write_segment (new, ptr, end); + + lseek (new, (long) data_scnptr, 0); + ptr = (char *) data_st; + end = ptr + f_ohdr.dsize; + write_segment (new, ptr, end); + + return 0; +} + +#define UnexBlockSz (1<<12) /* read/write block size */ +write_segment (new, ptr, end) + int new; + register char *ptr, *end; +{ + register int i, nwrite, ret; + char buf[80]; + extern int errno; + char zeros[UnexBlockSz]; + + for (i = 0; ptr < end;) + { + /* distance to next block. */ + nwrite = (((int) ptr + UnexBlockSz) & -UnexBlockSz) - (int) ptr; + /* But not beyond specified end. */ + if (nwrite > end - ptr) nwrite = end - ptr; + ret = write (new, ptr, nwrite); + /* If write gets a page fault, it means we reached + a gap between the old text segment and the old data segment. + This gap has probably been remapped into part of the text segment. + So write zeros for it. */ + if (ret == -1 && errno == EFAULT) + { + bzero (zeros, nwrite); + write (new, zeros, nwrite); + } + else if (nwrite != ret) + { + sprintf (buf, + "unexec write failure: addr 0x%lx, fileno %d, size 0x%x, wrote 0x%x, errno %d", + (unsigned long)ptr, new, nwrite, ret, errno); + PERROR (buf); + } + i += nwrite; + ptr += nwrite; + } +} + +/* **************************************************************** + * copy_sym + * + * Copy the relocation information and symbol table from the a.out to the new + */ +static int +copy_sym (new, a_out, a_name, new_name) + int new, a_out; + char *a_name, *new_name; +{ + char page[UnexBlockSz]; + int n; + + if (a_out < 0) + return 0; + + if (orig_load_scnptr == 0L) + return 0; + + if (lnnoptr && lnnoptr < orig_load_scnptr) /* if there is line number info */ + lseek (a_out, lnnoptr, 0); /* start copying from there */ + else + lseek (a_out, orig_load_scnptr, 0); /* Position a.out to symtab. */ + + while ((n = read (a_out, page, sizeof page)) > 0) + { + if (write (new, page, n) != n) + { + PERROR (new_name); + } + } + if (n < 0) + { + PERROR (a_name); + } + return 0; +} + +/* **************************************************************** + * mark_x + * + * After successfully building the new a.out, mark it executable + */ +static int +mark_x (name) + char *name; +{ + struct stat sbuf; + int um; + int new = 0; /* for PERROR */ + + um = umask (777); + umask (um); + if (stat (name, &sbuf) == -1) + { + PERROR (name); + } + sbuf.st_mode |= 0111 & ~um; + if (chmod (name, sbuf.st_mode) == -1) + PERROR (name); +} + +/* + * If the COFF file contains a symbol table and a line number section, + * then any auxiliary entries that have values for x_lnnoptr must + * be adjusted by the amount that the line number section has moved + * in the file (bias computed in make_hdr). The #@$%&* designers of + * the auxiliary entry structures used the absolute file offsets for + * the line number entry rather than an offset from the start of the + * line number section! + * + * When I figure out how to scan through the symbol table and pick out + * the auxiliary entries that need adjustment, this routine will + * be fixed. As it is now, all such entries are wrong and sdb + * will complain. Fred Fish, UniSoft Systems Inc. + * + * I believe this is now fixed correctly. Bill Mann + */ + +#ifdef COFF + +/* This function is probably very slow. Instead of reopening the new + file for input and output it should copy from the old to the new + using the two descriptors already open (WRITEDESC and READDESC). + Instead of reading one small structure at a time it should use + a reasonable size buffer. But I don't have time to work on such + things, so I am installing it as submitted to me. -- RMS. */ + +adjust_lnnoptrs (writedesc, readdesc, new_name) + int writedesc; + int readdesc; + char *new_name; +{ + register int nsyms; + register int naux; + register int new; +#ifdef amdahl_uts + SYMENT symentry; + AUXENT auxentry; +#else + struct syment symentry; + union auxent auxentry; +#endif + + if (!lnnoptr || !f_hdr.f_symptr) + return 0; + + if ((new = open (new_name, 2)) < 0) + { + PERROR (new_name); + return -1; + } + + lseek (new, f_hdr.f_symptr, 0); + for (nsyms = 0; nsyms < f_hdr.f_nsyms; nsyms++) + { + read (new, &symentry, SYMESZ); + if (symentry.n_sclass == C_BINCL || symentry.n_sclass == C_EINCL) + { + symentry.n_value += bias; + lseek (new, -SYMESZ, 1); + write (new, &symentry, SYMESZ); + } + + for (naux = symentry.n_numaux; naux-- != 0; ) + { + read (new, &auxentry, AUXESZ); + nsyms++; + if (naux != 0 /* skip csect auxentry (last entry) */ + && (symentry.n_sclass == C_EXT || symentry.n_sclass == C_HIDEXT)) + { + auxentry.x_sym.x_fcnary.x_fcn.x_lnnoptr += bias; + lseek (new, -AUXESZ, 1); + write (new, &auxentry, AUXESZ); + } + } + } + close (new); +} + +#endif /* COFF */ + +#ifdef XCOFF + +/* It is probably a false economy to optimise this routine (it used to + read one LDREL and do do two lseeks per iteration) but the wrath of + RMS (see above :-) would be too much to bear */ + +unrelocate_symbols (new, a_out, a_name, new_name) + int new, a_out; + char *a_name, *new_name; +{ + register int i; + register int l; + register LDREL *ldrel; + LDHDR ldhdr; + LDREL ldrel_buf [20]; + ulong t_reloc = (ulong) &_text - f_ohdr.text_start; + ulong d_reloc = (ulong) &_data - ALIGN(f_ohdr.data_start, 2); + int * p; + + if (load_scnptr == 0) + return 0; + + lseek (a_out, orig_load_scnptr, 0); + if (read (a_out, &ldhdr, sizeof (ldhdr)) != sizeof (ldhdr)) + { + PERROR (new_name); + } + +#define SYMNDX_TEXT 0 +#define SYMNDX_DATA 1 +#define SYMNDX_BSS 2 + l = 0; + for (i = 0; i < ldhdr.l_nreloc; i++, l--, ldrel++) + { + if (l == 0) { + lseek (a_out, + orig_load_scnptr + LDHDRSZ + LDSYMSZ*ldhdr.l_nsyms + LDRELSZ*i, + 0); + + l = ldhdr.l_nreloc - i; + if (l > sizeof (ldrel_buf) / LDRELSZ) + l = sizeof (ldrel_buf) / LDRELSZ; + + if (read (a_out, ldrel_buf, l * LDRELSZ) != l * LDRELSZ) + { + PERROR (a_name); + } + ldrel = ldrel_buf; + } + + /* move the BSS loader symbols to the DATA segment */ + if (ldrel->l_symndx == SYMNDX_BSS) + { + ldrel->l_symndx = SYMNDX_DATA; + + lseek (new, + load_scnptr + LDHDRSZ + LDSYMSZ*ldhdr.l_nsyms + LDRELSZ*i, + 0); + + if (write (new, ldrel, LDRELSZ) != LDRELSZ) + { + PERROR (new_name); + } + } + + if (ldrel->l_rsecnm == f_ohdr.o_sndata) + { + int orig_int; + + lseek (a_out, + orig_data_scnptr + (ldrel->l_vaddr - f_ohdr.data_start), 0); + + if (read (a_out, (void *) &orig_int, sizeof (orig_int)) != sizeof (orig_int)) + { + PERROR (a_name); + } + + p = (int *) (ldrel->l_vaddr + d_reloc); + + switch (ldrel->l_symndx) { + case SYMNDX_TEXT: + orig_int = * p - t_reloc; + break; + + case SYMNDX_DATA: + case SYMNDX_BSS: + orig_int = * p - d_reloc; + break; + } + + if (orig_int != * p) + { + lseek (new, + data_scnptr + (ldrel->l_vaddr - f_ohdr.data_start), 0); + if (write (new, (void *) &orig_int, sizeof (orig_int)) + != sizeof (orig_int)) + { + PERROR (new_name); + } + } + } + } +} +#endif /* XCOFF */ +#include "save.c" + +#include +#define DATA_START DBEGIN +char * +start_of_data () +{ + char buf[500]; + struct ld_info * ld; + loadquery(L_GETINFO,buf,sizeof(buf)); + ld = (struct ld_info *)buf; + return ld->ldinfo_dataorg; + + + + +#ifdef DATA_START + return ((char *) DATA_START); +#else +#ifdef ORDINARY_LINK + /* + * This is a hack. Since we're not linking crt0.c or pre_crt0.c, + * data_start isn't defined. We take the address of environ, which + * is known to live at or near the start of the system crt0.c, and + * we don't sweat the handful of bytes that might lose. + */ + extern char **environ; + + return((char *) &environ); +#else + extern int data_start; + return ((char *) &data_start); +#endif /* ORDINARY_LINK */ +#endif /* DATA_START */ +} + + +#define TEXT_START 0x10000000 + +char *start_of_text () +{ +#ifdef TEXT_START + return ((char *) TEXT_START); +#else +#ifdef GOULD + extern csrt (); + return ((char *) csrt); +#else /* not GOULD */ + extern int _start (); + return ((char *) _start); +#endif /* GOULD */ +#endif /* TEXT_START */ +} + diff --git a/o/unexec-19.29.c b/o/unexec-19.29.c new file mode 100755 index 0000000..c001878 --- /dev/null +++ b/o/unexec-19.29.c @@ -0,0 +1,1197 @@ +/* Copyright (C) 1985,86,87,88,92,93,94 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs; see the file COPYING. If not, write to +the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ + + +/* + * unexec.c - Convert a running program into an a.out file. + * + * Author: Spencer W. Thomas + * Computer Science Dept. + * University of Utah + * Date: Tue Mar 2 1982 + * Modified heavily since then. + * + * Synopsis: + * unexec (new_name, a_name, data_start, bss_start, entry_address) + * char *new_name, *a_name; + * unsigned data_start, bss_start, entry_address; + * + * Takes a snapshot of the program and makes an a.out format file in the + * file named by the string argument new_name. + * If a_name is non-NULL, the symbol table will be taken from the given file. + * On some machines, an existing a_name file is required. + * + * The boundaries within the a.out file may be adjusted with the data_start + * and bss_start arguments. Either or both may be given as 0 for defaults. + * + * Data_start gives the boundary between the text segment and the data + * segment of the program. The text segment can contain shared, read-only + * program code and literal data, while the data segment is always unshared + * and unprotected. Data_start gives the lowest unprotected address. + * The value you specify may be rounded down to a suitable boundary + * as required by the machine you are using. + * + * Specifying zero for data_start means the boundary between text and data + * should not be the same as when the program was loaded. + * If NO_REMAP is defined, the argument data_start is ignored and the + * segment boundaries are never changed. + * + * Bss_start indicates how much of the data segment is to be saved in the + * a.out file and restored when the program is executed. It gives the lowest + * unsaved address, and is rounded up to a page boundary. The default when 0 + * is given assumes that the entire data segment is to be stored, including + * the previous data and bss as well as any additional storage allocated with + * break (2). + * + * The new file is set up to start at entry_address. + * + * If you make improvements I'd like to get them too. + * harpo!utah-cs!thomas, thomas@Utah-20 + * + */ + +/* Modified to support SysVr3 shared libraries by James Van Artsdalen + * of Dell Computer Corporation. james@bigtex.cactus.org. + */ + +/* There are several compilation parameters affecting unexec: + +* COFF + +Define this if your system uses COFF for executables. + +* COFF_ENCAPSULATE + +Define this if you are using the GNU coff encapsulated a.out format. +This is closer to a.out than COFF. You should *not* define COFF if +you define COFF_ENCAPSULATE + +Otherwise we assume you use Berkeley format. + +* NO_REMAP + +Define this if you do not want to try to save Emacs's pure data areas +as part of the text segment. + +Saving them as text is good because it allows users to share more. + +However, on machines that locate the text area far from the data area, +the boundary cannot feasibly be moved. Such machines require +NO_REMAP. + +Also, remapping can cause trouble with the built-in startup routine +/lib/crt0.o, which defines `environ' as an initialized variable. +Dumping `environ' as pure does not work! So, to use remapping, +you must write a startup routine for your machine in Emacs's crt0.c. +If NO_REMAP is defined, Emacs uses the system's crt0.o. + +* SECTION_ALIGNMENT + +Some machines that use COFF executables require that each section +start on a certain boundary *in the COFF file*. Such machines should +define SECTION_ALIGNMENT to a mask of the low-order bits that must be +zero on such a boundary. This mask is used to control padding between +segments in the COFF file. + +If SECTION_ALIGNMENT is not defined, the segments are written +consecutively with no attempt at alignment. This is right for +unmodified system V. + +* SEGMENT_MASK + +Some machines require that the beginnings and ends of segments +*in core* be on certain boundaries. For most machines, a page +boundary is sufficient. That is the default. When a larger +boundary is needed, define SEGMENT_MASK to a mask of +the bits that must be zero on such a boundary. + +* A_TEXT_OFFSET(HDR) + +Some machines count the a.out header as part of the size of the text +segment (a_text); they may actually load the header into core as the +first data in the text segment. Some have additional padding between +the header and the real text of the program that is counted in a_text. + +For these machines, define A_TEXT_OFFSET(HDR) to examine the header +structure HDR and return the number of bytes to add to `a_text' +before writing it (above and beyond the number of bytes of actual +program text). HDR's standard fields are already correct, except that +this adjustment to the `a_text' field has not yet been made; +thus, the amount of offset can depend on the data in the file. + +* A_TEXT_SEEK(HDR) + +If defined, this macro specifies the number of bytes to seek into the +a.out file before starting to write the text segment. + +* EXEC_MAGIC + +For machines using COFF, this macro, if defined, is a value stored +into the magic number field of the output file. + +* ADJUST_EXEC_HEADER + +This macro can be used to generate statements to adjust or +initialize nonstandard fields in the file header + +* ADDR_CORRECT(ADDR) + +Macro to correct an int which is the bit pattern of a pointer to a byte +into an int which is the number of a byte. + +This macro has a default definition which is usually right. +This default definition is a no-op on most machines (where a +pointer looks like an int) but not on all machines. + +*/ + +#ifndef emacs +#define PERROR(arg) perror (arg); return -1 +#else +#define IN_UNEXEC +#include "config.h" +#define PERROR(file) report_error (file, new) +#endif + +#ifndef CANNOT_DUMP /* all rest of file! */ + +#ifdef COFF_ENCAPSULATE +int need_coff_header = 1; +#include /* The location might be a poor assumption */ +#else +#ifdef MSDOS +#include +#define filehdr external_filehdr +#define scnhdr external_scnhdr +#define syment external_syment +#define auxent external_auxent +#define n_numaux e_numaux +#define n_type e_type +struct aouthdr +{ + unsigned short magic; /* type of file */ + unsigned short vstamp; /* version stamp */ + unsigned long tsize; /* text size in bytes, padded to FW bdry*/ + unsigned long dsize; /* initialized data " " */ + unsigned long bsize; /* uninitialized data " " */ + unsigned long entry; /* entry pt. */ + unsigned long text_start;/* base of text used for this file */ + unsigned long data_start;/* base of data used for this file */ +}; + + +#else /* not MSDOS */ +#include +#endif /* not MSDOS */ +#endif + +/* Define getpagesize if the system does not. + Note that this may depend on symbols defined in a.out.h. */ +#include "getpagesize.h" + +#ifndef makedev /* Try to detect types.h already loaded */ +#include +#endif /* makedev */ +#include +#include +#include + +#include /* Must be after sys/types.h for USG and BSD4_1*/ + +#ifdef USG5 +#include +#endif + +#ifndef O_RDONLY +#define O_RDONLY 0 +#endif +#ifndef O_RDWR +#define O_RDWR 2 +#endif + +#ifdef UNIXSAVE +extern char etext; +#endif + +#ifndef start_of_data +extern char *start_of_text (); /* Start of text */ +extern char *start_of_data (); /* Start of initialized data */ +#endif + +#ifdef COFF +static long block_copy_start; /* Old executable start point */ +static struct filehdr f_hdr; /* File header */ +static struct aouthdr f_ohdr; /* Optional file header (a.out) */ +long bias; /* Bias to add for growth */ +long lnnoptr; /* Pointer to line-number info within file */ +#define SYMS_START block_copy_start + +static long text_scnptr; +static long data_scnptr; + +#else /* not COFF */ + +#ifdef HPUX +extern void *sbrk (); +#else +#if 0 +/* Some systems with __STDC__ compilers still declare this `char *' in some + header file, and our declaration conflicts. The return value is always + cast, so it should be harmless to leave it undefined. Hopefully + machines with different size pointers and ints declare sbrk in a header + file. */ +#ifdef __STDC__ +extern void *sbrk (); +#else +extern char *sbrk (); +#endif /* __STDC__ */ +#endif +#endif /* HPUX */ + +#define SYMS_START ((long) N_SYMOFF (ohdr)) + +/* Some machines override the structure name for an a.out header. */ +#ifndef EXEC_HDR_TYPE +#define EXEC_HDR_TYPE struct exec +#endif + +#ifdef HPUX +#ifdef HP9000S200_ID +#define MY_ID HP9000S200_ID +#else +#include +#define MY_ID MYSYS +#endif /* no HP9000S200_ID */ +static MAGIC OLDMAGIC = {MY_ID, SHARE_MAGIC}; +static MAGIC NEWMAGIC = {MY_ID, DEMAND_MAGIC}; +#define N_TXTOFF(x) TEXT_OFFSET(x) +#define N_SYMOFF(x) LESYM_OFFSET(x) +static EXEC_HDR_TYPE hdr, ohdr; + +#else /* not HPUX */ + +#if defined (USG) && !defined (IBMAIX) && !defined (IRIS) && !defined (COFF_ENCAPSULATE) && !defined (LINUX) +static struct bhdr hdr, ohdr; +#define a_magic fmagic +#define a_text tsize +#define a_data dsize +#define a_bss bsize +#define a_syms ssize +#define a_trsize rtsize +#define a_drsize rdsize +#define a_entry entry +#define N_BADMAG(x) \ + (((x).fmagic)!=OMAGIC && ((x).fmagic)!=NMAGIC &&\ + ((x).fmagic)!=FMAGIC && ((x).fmagic)!=IMAGIC) +#define NEWMAGIC FMAGIC +#else /* IRIS or IBMAIX or not USG */ +static EXEC_HDR_TYPE hdr, ohdr; +#define NEWMAGIC ZMAGIC +#endif /* IRIS or IBMAIX not USG */ +#endif /* not HPUX */ + +static int unexec_text_start; +static int unexec_data_start; + +#ifdef COFF_ENCAPSULATE +/* coffheader is defined in the GNU a.out.encap.h file. */ +struct coffheader coffheader; +#endif + +#endif /* not COFF */ + +static int pagemask; + +/* Correct an int which is the bit pattern of a pointer to a byte + into an int which is the number of a byte. + This is a no-op on ordinary machines, but not on all. */ + +#ifndef ADDR_CORRECT /* Let m-*.h files override this definition */ +#define ADDR_CORRECT(x) ((char *)(x) - (char*)0) +#endif + +#ifdef emacs + +#include "lisp.h" + +static +report_error (file, fd) + char *file; + int fd; +{ + if (fd) + close (fd); + report_file_error ("Cannot unexec", Fcons (build_string (file), Qnil)); +} +#endif /* emacs */ + +#define ERROR0(msg) report_error_1 (new, msg, 0, 0); return -1 +#define ERROR1(msg,x) report_error_1 (new, msg, x, 0); return -1 +#define ERROR2(msg,x,y) report_error_1 (new, msg, x, y); return -1 + +static +report_error_1 (int fd, char *msg, int a1, int a2) +{ + close (fd); +#ifdef emacs + error (msg, a1, a2); +#else + fprintf (stderr, msg, a1, a2); + fprintf (stderr, "\n"); +#endif +} + +static int make_hdr (int new, int a_out, unsigned int data_start, unsigned int bss_start, unsigned int entry_address, char *a_name, char *new_name); +static int copy_text_and_data (int new, int a_out); +static int copy_sym (int new, int a_out, char *a_name, char *new_name); +static void mark_x (char *name); + +/* **************************************************************** + * unexec + * + * driving logic. + */ +unexec (char *new_name, char *a_name, unsigned int data_start, unsigned int bss_start, unsigned int entry_address) +{ + int new, a_out = -1; + + if (a_name && (a_out = open (a_name, O_RDONLY)) < 0) + { + PERROR (a_name); + } + if ((new = creat (new_name, 0666)) < 0) + { + PERROR (new_name); + } + + if (make_hdr (new, a_out, data_start, bss_start, entry_address, a_name, new_name) < 0 + || copy_text_and_data (new, a_out) < 0 + || copy_sym (new, a_out, a_name, new_name) < 0 +#ifdef COFF +#ifndef COFF_BSD_SYMBOLS + || adjust_lnnoptrs (new, a_out, new_name) < 0 +#endif +#endif + ) + { + close (new); + /* unlink (new_name); /* Failed, unlink new a.out */ + return -1; + } + + close (new); + if (a_out >= 0) + close (a_out); + mark_x (new_name); + return 0; +} + +/* **************************************************************** + * make_hdr + * + * Make the header in the new a.out from the header in core. + * Modify the text and data sizes. + */ +static int +make_hdr (int new, int a_out, unsigned int data_start, unsigned int bss_start, unsigned int entry_address, char *a_name, char *new_name) +{ + int tem; +#ifdef COFF + auto struct scnhdr f_thdr; /* Text section header */ + auto struct scnhdr f_dhdr; /* Data section header */ + auto struct scnhdr f_bhdr; /* Bss section header */ + auto struct scnhdr scntemp; /* Temporary section header */ + register int scns; +#endif /* COFF */ +#ifdef USG_SHARED_LIBRARIES + extern unsigned int bss_end; +#else + unsigned int bss_end; +#endif + + pagemask = getpagesize () - 1; + + /* Adjust text/data boundary. */ +#ifdef NO_REMAP + data_start = (int) start_of_data (); +#else /* not NO_REMAP */ + if (!data_start) + data_start = (int) start_of_data (); +#endif /* not NO_REMAP */ + data_start = ADDR_CORRECT (data_start); + +#ifdef SEGMENT_MASK + data_start = data_start & ~SEGMENT_MASK; /* (Down) to segment boundary. */ +#else + data_start = data_start & ~pagemask; /* (Down) to page boundary. */ +#endif + + bss_end = ADDR_CORRECT (sbrk (0)) + pagemask; + bss_end &= ~ pagemask; + + /* Adjust data/bss boundary. */ + if (bss_start != 0) + { + bss_start = (ADDR_CORRECT (bss_start) + pagemask); + /* (Up) to page bdry. */ + bss_start &= ~ pagemask; + if (bss_start > bss_end) + { + ERROR1 ("unexec: Specified bss_start (%u) is past end of program", + bss_start); + } + } + else + bss_start = bss_end; + + if (data_start > bss_start) /* Can't have negative data size. */ + { + ERROR2 ("unexec: data_start (%u) can't be greater than bss_start (%u)", + data_start, bss_start); + } + +#ifdef COFF + /* Salvage as much info from the existing file as possible */ + if (a_out >= 0) + { + if (read (a_out, &f_hdr, sizeof (f_hdr)) != sizeof (f_hdr)) + { + PERROR (a_name); + } + block_copy_start += sizeof (f_hdr); + if (f_hdr.f_opthdr > 0) + { + if (read (a_out, &f_ohdr, sizeof (f_ohdr)) != sizeof (f_ohdr)) + { + PERROR (a_name); + } + block_copy_start += sizeof (f_ohdr); + } + /* Loop through section headers, copying them in */ + lseek (a_out, sizeof (f_hdr) + f_hdr.f_opthdr, 0); + for (scns = f_hdr.f_nscns; scns > 0; scns--) { + if (read (a_out, &scntemp, sizeof (scntemp)) != sizeof (scntemp)) + { + PERROR (a_name); + } + if (scntemp.s_scnptr > 0L) + { + if (block_copy_start < scntemp.s_scnptr + scntemp.s_size) + block_copy_start = scntemp.s_scnptr + scntemp.s_size; + } + if (strcmp (scntemp.s_name, ".text") == 0) + { + f_thdr = scntemp; + } + else if (strcmp (scntemp.s_name, ".data") == 0) + { + f_dhdr = scntemp; + } + else if (strcmp (scntemp.s_name, ".bss") == 0) + { + f_bhdr = scntemp; + } + } + } + else + { + ERROR0 ("can't build a COFF file from scratch yet"); + } + + /* Now we alter the contents of all the f_*hdr variables + to correspond to what we want to dump. */ + +#ifdef USG_SHARED_LIBRARIES + + /* The amount of data we're adding to the file is distance from the + * end of the original .data space to the current end of the .data + * space. + */ + + bias = bss_start - (f_ohdr.data_start + f_dhdr.s_size); + +#endif + + f_hdr.f_flags |= (F_RELFLG | F_EXEC); +#ifdef TPIX + f_hdr.f_nscns = 3; +#endif +#ifdef EXEC_MAGIC + f_ohdr.magic = EXEC_MAGIC; +#endif +#ifndef NO_REMAP + f_ohdr.text_start = (long) start_of_text (); + f_ohdr.tsize = data_start - f_ohdr.text_start; + f_ohdr.data_start = data_start; +#endif /* NO_REMAP */ + f_ohdr.dsize = bss_start - f_ohdr.data_start; + f_ohdr.bsize = bss_end - bss_start; +#ifndef KEEP_OLD_TEXT_SCNPTR + /* On some machines, the old values are right. + ??? Maybe on all machines with NO_REMAP. */ + f_thdr.s_size = f_ohdr.tsize; + f_thdr.s_scnptr = sizeof (f_hdr) + sizeof (f_ohdr); + f_thdr.s_scnptr += (f_hdr.f_nscns) * (sizeof (f_thdr)); +#endif /* KEEP_OLD_TEXT_SCNPTR */ +#ifdef ADJUST_TEXT_SCNHDR_SIZE + /* On some machines, `text size' includes all headers. */ + f_thdr.s_size -= f_thdr.s_scnptr; +#endif /* ADJUST_TEST_SCNHDR_SIZE */ + lnnoptr = f_thdr.s_lnnoptr; +#ifdef SECTION_ALIGNMENT + /* Some systems require special alignment + of the sections in the file itself. */ + f_thdr.s_scnptr + = (f_thdr.s_scnptr + SECTION_ALIGNMENT) & ~SECTION_ALIGNMENT; +#endif /* SECTION_ALIGNMENT */ +#ifdef TPIX + f_thdr.s_scnptr = 0xd0; +#endif + text_scnptr = f_thdr.s_scnptr; +#ifdef ADJUST_TEXTBASE + text_scnptr = sizeof (f_hdr) + sizeof (f_ohdr) + (f_hdr.f_nscns) * (sizeof (f_thdr)); +#endif +#ifndef KEEP_OLD_PADDR + f_dhdr.s_paddr = f_ohdr.data_start; +#endif /* KEEP_OLD_PADDR */ + f_dhdr.s_vaddr = f_ohdr.data_start; + f_dhdr.s_size = f_ohdr.dsize; + f_dhdr.s_scnptr = f_thdr.s_scnptr + f_thdr.s_size; +#ifdef SECTION_ALIGNMENT + /* Some systems require special alignment + of the sections in the file itself. */ + f_dhdr.s_scnptr + = (f_dhdr.s_scnptr + SECTION_ALIGNMENT) & ~SECTION_ALIGNMENT; +#endif /* SECTION_ALIGNMENT */ +#ifdef DATA_SECTION_ALIGNMENT + /* Some systems require special alignment + of the data section only. */ + f_dhdr.s_scnptr + = (f_dhdr.s_scnptr + DATA_SECTION_ALIGNMENT) & ~DATA_SECTION_ALIGNMENT; +#endif /* DATA_SECTION_ALIGNMENT */ + data_scnptr = f_dhdr.s_scnptr; +#ifndef KEEP_OLD_PADDR + f_bhdr.s_paddr = f_ohdr.data_start + f_ohdr.dsize; +#endif /* KEEP_OLD_PADDR */ + f_bhdr.s_vaddr = f_ohdr.data_start + f_ohdr.dsize; + f_bhdr.s_size = f_ohdr.bsize; + f_bhdr.s_scnptr = 0L; +#ifndef USG_SHARED_LIBRARIES + bias = f_dhdr.s_scnptr + f_dhdr.s_size - block_copy_start; +#endif + + if (f_hdr.f_symptr > 0L) + { + f_hdr.f_symptr += bias; + } + + if (f_thdr.s_lnnoptr > 0L) + { + f_thdr.s_lnnoptr += bias; + } + +#ifdef ADJUST_EXEC_HEADER + ADJUST_EXEC_HEADER; +#endif /* ADJUST_EXEC_HEADER */ + + if (write (new, &f_hdr, sizeof (f_hdr)) != sizeof (f_hdr)) + { + PERROR (new_name); + } + + if (write (new, &f_ohdr, sizeof (f_ohdr)) != sizeof (f_ohdr)) + { + PERROR (new_name); + } + +#ifndef USG_SHARED_LIBRARIES + + if (write (new, &f_thdr, sizeof (f_thdr)) != sizeof (f_thdr)) + { + PERROR (new_name); + } + + if (write (new, &f_dhdr, sizeof (f_dhdr)) != sizeof (f_dhdr)) + { + PERROR (new_name); + } + + if (write (new, &f_bhdr, sizeof (f_bhdr)) != sizeof (f_bhdr)) + { + PERROR (new_name); + } + +#else /* USG_SHARED_LIBRARIES */ + + /* The purpose of this code is to write out the new file's section + * header table. + * + * Scan through the original file's sections. If the encountered + * section is one we know (.text, .data or .bss), write out the + * correct header. If it is a section we do not know (such as + * .lib), adjust the address of where the section data is in the + * file, and write out the header. + * + * If any section precedes .text or .data in the file, this code + * will not adjust the file pointer for that section correctly. + */ + + /* This used to use sizeof (f_ohdr) instead of .f_opthdr. + .f_opthdr is said to be right when there is no optional header. */ + lseek (a_out, sizeof (f_hdr) + f_hdr.f_opthdr, 0); + + for (scns = f_hdr.f_nscns; scns > 0; scns--) + { + if (read (a_out, &scntemp, sizeof (scntemp)) != sizeof (scntemp)) + PERROR (a_name); + + if (!strcmp (scntemp.s_name, f_thdr.s_name)) /* .text */ + { + if (write (new, &f_thdr, sizeof (f_thdr)) != sizeof (f_thdr)) + PERROR (new_name); + } + else if (!strcmp (scntemp.s_name, f_dhdr.s_name)) /* .data */ + { + if (write (new, &f_dhdr, sizeof (f_dhdr)) != sizeof (f_dhdr)) + PERROR (new_name); + } + else if (!strcmp (scntemp.s_name, f_bhdr.s_name)) /* .bss */ + { + if (write (new, &f_bhdr, sizeof (f_bhdr)) != sizeof (f_bhdr)) + PERROR (new_name); + } + else + { + if (scntemp.s_scnptr) + scntemp.s_scnptr += bias; + if (write (new, &scntemp, sizeof (scntemp)) != sizeof (scntemp)) + PERROR (new_name); + } + } +#endif /* USG_SHARED_LIBRARIES */ + + return (0); + +#else /* if not COFF */ + + /* Get symbol table info from header of a.out file if given one. */ + if (a_out >= 0) + { +#ifdef COFF_ENCAPSULATE + if (read (a_out, &coffheader, sizeof coffheader) != sizeof coffheader) + { + PERROR(a_name); + } + if (coffheader.f_magic != COFF_MAGIC) + { + ERROR1("%s doesn't have legal coff magic number\n", a_name); + } +#endif + if (read (a_out, &ohdr, sizeof hdr) != sizeof hdr) + { + PERROR (a_name); + } + + if (N_BADMAG (ohdr)) + { + ERROR1 ("invalid magic number in %s", a_name); + } + hdr = ohdr; + } + else + { +#ifdef COFF_ENCAPSULATE + /* We probably could without too much trouble. The code is in gld + * but I don't have that much time or incentive. + */ + ERROR0 ("can't build a COFF file from scratch yet"); +#else +#ifdef MSDOS /* Demacs 1.1.1 91/10/16 HIRANO Satoshi */ + bzero ((void *)&hdr, sizeof hdr); +#else + bzero (&hdr, sizeof hdr); +#endif +#endif + } + + unexec_text_start = (long) start_of_text (); + unexec_data_start = data_start; + + /* Machine-dependent fixup for header, or maybe for unexec_text_start */ +#ifdef ADJUST_EXEC_HEADER + ADJUST_EXEC_HEADER; +#endif /* ADJUST_EXEC_HEADER */ + + hdr.a_trsize = 0; + hdr.a_drsize = 0; + if (entry_address != 0) + hdr.a_entry = entry_address; + + hdr.a_bss = bss_end - bss_start; + hdr.a_data = bss_start - data_start; +#ifdef NO_REMAP + hdr.a_text = ohdr.a_text; +#else /* not NO_REMAP */ + hdr.a_text = data_start - unexec_text_start; + +#ifdef A_TEXT_OFFSET + hdr.a_text += A_TEXT_OFFSET (ohdr); +#endif + +#endif /* not NO_REMAP */ + +#ifdef COFF_ENCAPSULATE + /* We are encapsulating BSD format within COFF format. */ + { + struct coffscn *tp, *dp, *bp; + tp = &coffheader.scns[0]; + dp = &coffheader.scns[1]; + bp = &coffheader.scns[2]; + tp->s_size = hdr.a_text + sizeof(struct exec); + dp->s_paddr = data_start; + dp->s_vaddr = data_start; + dp->s_size = hdr.a_data; + bp->s_paddr = dp->s_vaddr + dp->s_size; + bp->s_vaddr = bp->s_paddr; + bp->s_size = hdr.a_bss; + coffheader.tsize = tp->s_size; + coffheader.dsize = dp->s_size; + coffheader.bsize = bp->s_size; + coffheader.text_start = tp->s_vaddr; + coffheader.data_start = dp->s_vaddr; + } + if (write (new, &coffheader, sizeof coffheader) != sizeof coffheader) + { + PERROR(new_name); + } +#endif /* COFF_ENCAPSULATE */ + + if (write (new, &hdr, sizeof hdr) != sizeof hdr) + { + PERROR (new_name); + } + +#if 0 /* This #ifndef caused a bug on Linux when using QMAGIC. */ + /* This adjustment was done above only #ifndef NO_REMAP, + so only undo it now #ifndef NO_REMAP. */ + /* #ifndef NO_REMAP */ +#endif +#ifdef A_TEXT_OFFSET + hdr.a_text -= A_TEXT_OFFSET (ohdr); +#endif + + return 0; + +#endif /* not COFF */ +} + +/* **************************************************************** + * copy_text_and_data + * + * Copy the text and data segments from memory to the new a.out + */ +static int +copy_text_and_data (int new, int a_out) +{ + register char *end; + register char *ptr; + +#ifdef COFF + +#ifdef USG_SHARED_LIBRARIES + + int scns; + struct scnhdr scntemp; /* Temporary section header */ + + /* The purpose of this code is to write out the new file's section + * contents. + * + * Step through the section table. If we know the section (.text, + * .data) do the appropriate thing. Otherwise, if the section has + * no allocated space in the file (.bss), do nothing. Otherwise, + * the section has space allocated in the file, and is not a section + * we know. So just copy it. + */ + + lseek (a_out, sizeof (struct filehdr) + sizeof (struct aouthdr), 0); + + for (scns = f_hdr.f_nscns; scns > 0; scns--) + { + if (read (a_out, &scntemp, sizeof (scntemp)) != sizeof (scntemp)) + PERROR ("temacs"); + + if (!strcmp (scntemp.s_name, ".text")) + { + lseek (new, (long) text_scnptr, 0); + ptr = (char *) f_ohdr.text_start; + end = ptr + f_ohdr.tsize; + write_segment (new, ptr, end); + } + else if (!strcmp (scntemp.s_name, ".data")) + { + lseek (new, (long) data_scnptr, 0); + ptr = (char *) f_ohdr.data_start; + end = ptr + f_ohdr.dsize; + write_segment (new, ptr, end); + } + else if (!scntemp.s_scnptr) + ; /* do nothing - no data for this section */ + else + { + char page[BUFSIZ]; + int size, n; + long old_a_out_ptr = lseek (a_out, 0, 1); + + lseek (a_out, scntemp.s_scnptr, 0); + for (size = scntemp.s_size; size > 0; size -= sizeof (page)) + { + n = size > sizeof (page) ? sizeof (page) : size; + if (read (a_out, page, n) != n || write (new, page, n) != n) + PERROR ("emacs"); + } + lseek (a_out, old_a_out_ptr, 0); + } + } + +#else /* COFF, but not USG_SHARED_LIBRARIES */ + + lseek (new, (long) text_scnptr, 0); + ptr = (char *) f_ohdr.text_start; +#ifdef HEADER_INCL_IN_TEXT + /* For Gould UTX/32, text starts after headers */ + ptr = (char *) (ptr + text_scnptr); +#endif /* HEADER_INCL_IN_TEXT */ + end = ptr + f_ohdr.tsize; + write_segment (new, ptr, end); + + lseek (new, (long) data_scnptr, 0); + ptr = (char *) f_ohdr.data_start; + end = ptr + f_ohdr.dsize; + write_segment (new, ptr, end); + +#endif /* USG_SHARED_LIBRARIES */ + +#else /* if not COFF */ + +/* Some machines count the header as part of the text segment. + That is to say, the header appears in core + just before the address that start_of_text returns. + For them, N_TXTOFF is the place where the header goes. + We must adjust the seek to the place after the header. + Note that at this point hdr.a_text does *not* count + the extra A_TEXT_OFFSET bytes, only the actual bytes of code. */ + +#ifdef A_TEXT_SEEK + lseek (new, (long) A_TEXT_SEEK (hdr), 0); +#else + lseek (new, (long) N_TXTOFF (hdr), 0); +#endif /* no A_TEXT_SEEK */ + +#ifdef RISCiX + + /* Acorn's RISC-iX has a wacky way of initialising the position of the heap. + * There is a little table in crt0.o that is filled at link time with + * the min and current brk positions, among other things. When start + * runs, it copies the table to where these parameters live during + * execution. This data is in text space, so it cannot be modified here + * before saving the executable, so the data is written manually. In + * addition, the table does not have a label, and the nearest accessable + * label (mcount) is not prefixed with a '_', thus making it inaccessable + * from within C programs. To overcome this, emacs's executable is passed + * through the command 'nm %s | fgrep mcount' into a pipe, and the + * resultant output is then used to find the address of 'mcount'. As far as + * is possible to determine, in RISC-iX releases prior to 1.2, the negative + * offset of the table from mcount is 0x2c, whereas from 1.2 onwards it is + * 0x30. bss_end has been rounded up to page boundary. This solution is + * based on suggestions made by Kevin Welton and Steve Hunt of Acorn, and + * avoids the need for a custom version of crt0.o for emacs which has its + * table in data space. + */ + + { + char command[1024]; + char errbuf[1024]; + char address_text[32]; + int proforma[4]; + FILE *pfile; + char *temp_ptr; + char c; + int mcount_address, mcount_offset, count; + extern char *_execname; + + + /* The use of _execname is incompatible with RISCiX 1.1 */ + sprintf (command, "nm %s | fgrep mcount", _execname); + + if ( (pfile = popen(command, "r")) == NULL) + { + sprintf (errbuf, "Could not open pipe"); + PERROR (errbuf); + } + + count=0; + while ( ((c=getc(pfile)) != EOF) && (c != ' ') && (count < 31)) + address_text[count++]=c; + address_text[count]=0; + + if ((count == 0) || pclose(pfile) != NULL) + { + sprintf (errbuf, "Failed to execute the command '%s'\n", command); + PERROR (errbuf); + } + + sscanf(address_text, "%x", &mcount_address); + ptr = (char *) unexec_text_start; + mcount_offset = (char *)mcount_address - ptr; + +#ifdef RISCiX_1_1 +#define EDATA_OFFSET 0x2c +#else +#define EDATA_OFFSET 0x30 +#endif + + end = ptr + mcount_offset - EDATA_OFFSET; + + write_segment (new, ptr, end); + + proforma[0] = bss_end; /* becomes _edata */ + proforma[1] = bss_end; /* becomes _end */ + proforma[2] = bss_end; /* becomes _minbrk */ + proforma[3] = bss_end; /* becomes _curbrk */ + + write (new, proforma, 16); + + temp_ptr = ptr; + ptr = end + 16; + end = temp_ptr + hdr.a_text; + + write_segment (new, ptr, end); + } + +#else /* !RISCiX */ + ptr = (char *) unexec_text_start; + end = ptr + hdr.a_text; + write_segment (new, ptr, end); +#endif /* RISCiX */ + + ptr = (char *) unexec_data_start; + end = ptr + hdr.a_data; +/* This lseek is certainly incorrect when A_TEXT_OFFSET + and I believe it is a no-op otherwise. + Let's see if its absence ever fails. */ +/* lseek (new, (long) N_TXTOFF (hdr) + hdr.a_text, 0); */ + write_segment (new, ptr, end); + +#endif /* not COFF */ + + return 0; +} + +write_segment (int new, register char *ptr, register char *end) +{ + register int i, nwrite, ret; + char buf[80]; + extern int errno; + char zeros[128]; + int amt_to_write = (1 << 13); + + bzero (zeros, sizeof zeros); + + for (i = 0; ptr < end;) + { + /* distance to next multiple of amt_to_write . */ + AGAIN: + nwrite = (((int) ptr + amt_to_write) & -amt_to_write) - (int) ptr; + /* But not beyond specified end. */ + if (nwrite > end - ptr) nwrite = end - ptr; + ret = write (new, ptr, nwrite); + /* If write gets a page fault, it means we reached + a gap between the old text segment and the old data segment. + This gap has probably been remapped into part of the text segment. + So write zeros for it. */ + if (ret == -1 +#ifdef EFAULT + && errno == EFAULT +#endif + ) + { if (amt_to_write > sizeof(zeros)) + { amt_to_write = sizeof(zeros); + goto AGAIN; + } + write (new, zeros, nwrite); + } + else if (nwrite != ret) + { + sprintf (buf, + "unexec write failure: addr 0x%x, fileno %d, size 0x%x, wrote 0x%x, errno %d", + ptr, new, nwrite, ret, errno); + PERROR (buf); + } + i += nwrite; + ptr += nwrite; + } +} + +/* **************************************************************** + * copy_sym + * + * Copy the relocation information and symbol table from the a.out to the new + */ +static int +copy_sym (int new, int a_out, char *a_name, char *new_name) +{ + char page[1024]; + int n; + + if (a_out < 0) + return 0; + +#ifdef COFF + if (SYMS_START == 0L) + return 0; +#endif /* COFF */ + +#ifdef COFF + if (lnnoptr) /* if there is line number info */ + lseek (a_out, lnnoptr, 0); /* start copying from there */ + else +#endif /* COFF */ + lseek (a_out, SYMS_START, 0); /* Position a.out to symtab. */ + + while ((n = read (a_out, page, sizeof page)) > 0) + { + if (write (new, page, n) != n) + { + PERROR (new_name); + } + } + if (n < 0) + { + PERROR (a_name); + } + return 0; +} + +/* **************************************************************** + * mark_x + * + * After successfully building the new a.out, mark it executable + */ +static void +mark_x (char *name) +{ + struct stat sbuf; + int um; + int new = 0; /* for PERROR */ + + um = umask (777); + umask (um); + if (stat (name, &sbuf) == -1) + { + PERROR (name); + } + sbuf.st_mode |= 0111 & ~um; + if (chmod (name, sbuf.st_mode) == -1) + PERROR (name); +} + +#ifdef COFF +#ifndef COFF_BSD_SYMBOLS + +/* + * If the COFF file contains a symbol table and a line number section, + * then any auxiliary entries that have values for x_lnnoptr must + * be adjusted by the amount that the line number section has moved + * in the file (bias computed in make_hdr). The #@$%&* designers of + * the auxiliary entry structures used the absolute file offsets for + * the line number entry rather than an offset from the start of the + * line number section! + * + * When I figure out how to scan through the symbol table and pick out + * the auxiliary entries that need adjustment, this routine will + * be fixed. As it is now, all such entries are wrong and sdb + * will complain. Fred Fish, UniSoft Systems Inc. + */ + +/* This function is probably very slow. Instead of reopening the new + file for input and output it should copy from the old to the new + using the two descriptors already open (WRITEDESC and READDESC). + Instead of reading one small structure at a time it should use + a reasonable size buffer. But I don't have time to work on such + things, so I am installing it as submitted to me. -- RMS. */ + +adjust_lnnoptrs (writedesc, readdesc, new_name) + int writedesc; + int readdesc; + char *new_name; +{ + register int nsyms; + register int new; +#if defined (amdahl_uts) || defined (pfa) + SYMENT symentry; + AUXENT auxentry; +#else + struct syment symentry; + union auxent auxentry; +#endif + + if (!lnnoptr || !f_hdr.f_symptr) + return 0; + +#ifdef MSDOS + if ((new = writedesc) < 0) +#else + if ((new = open (new_name, O_RDWR)) < 0) +#endif + { + PERROR (new_name); + return -1; + } + + lseek (new, f_hdr.f_symptr, 0); + for (nsyms = 0; nsyms < f_hdr.f_nsyms; nsyms++) + { + read (new, &symentry, SYMESZ); + if (symentry.n_numaux) + { + read (new, &auxentry, AUXESZ); + nsyms++; + if (ISFCN (symentry.n_type) || symentry.n_type == 0x2400) + { + auxentry.x_sym.x_fcnary.x_fcn.x_lnnoptr += bias; + lseek (new, -AUXESZ, 1); + write (new, &auxentry, AUXESZ); + } + } + } +#ifndef MSDOS + close (new); +#endif + return 0; +} + +#endif /* COFF_BSD_SYMBOLS */ + +#endif /* COFF */ + +#endif /* not CANNOT_DUMP */ + + +#ifdef UNIXSAVE +#include "save.c" +#endif diff --git a/o/unexec.c b/o/unexec.c new file mode 100755 index 0000000..cc7a6be --- /dev/null +++ b/o/unexec.c @@ -0,0 +1,1198 @@ +/* Copyright (C) 1985,86,87,88,92,93,94 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs; see the file COPYING. If not, write to +the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ + + +/* + * unexec.c - Convert a running program into an a.out file. + * + * Author: Spencer W. Thomas + * Computer Science Dept. + * University of Utah + * Date: Tue Mar 2 1982 + * Modified heavily since then. + * + * Synopsis: + * unexec (new_name, a_name, data_start, bss_start, entry_address) + * char *new_name, *a_name; + * unsigned data_start, bss_start, entry_address; + * + * Takes a snapshot of the program and makes an a.out format file in the + * file named by the string argument new_name. + * If a_name is non-NULL, the symbol table will be taken from the given file. + * On some machines, an existing a_name file is required. + * + * The boundaries within the a.out file may be adjusted with the data_start + * and bss_start arguments. Either or both may be given as 0 for defaults. + * + * Data_start gives the boundary between the text segment and the data + * segment of the program. The text segment can contain shared, read-only + * program code and literal data, while the data segment is always unshared + * and unprotected. Data_start gives the lowest unprotected address. + * The value you specify may be rounded down to a suitable boundary + * as required by the machine you are using. + * + * Specifying zero for data_start means the boundary between text and data + * should not be the same as when the program was loaded. + * If NO_REMAP is defined, the argument data_start is ignored and the + * segment boundaries are never changed. + * + * Bss_start indicates how much of the data segment is to be saved in the + * a.out file and restored when the program is executed. It gives the lowest + * unsaved address, and is rounded up to a page boundary. The default when 0 + * is given assumes that the entire data segment is to be stored, including + * the previous data and bss as well as any additional storage allocated with + * break (2). + * + * The new file is set up to start at entry_address. + * + * If you make improvements I'd like to get them too. + * harpo!utah-cs!thomas, thomas@Utah-20 + * + */ + +/* Modified to support SysVr3 shared libraries by James Van Artsdalen + * of Dell Computer Corporation. james@bigtex.cactus.org. + */ + +/* There are several compilation parameters affecting unexec: + +* COFF + +Define this if your system uses COFF for executables. + +* COFF_ENCAPSULATE + +Define this if you are using the GNU coff encapsulated a.out format. +This is closer to a.out than COFF. You should *not* define COFF if +you define COFF_ENCAPSULATE + +Otherwise we assume you use Berkeley format. + +* NO_REMAP + +Define this if you do not want to try to save Emacs's pure data areas +as part of the text segment. + +Saving them as text is good because it allows users to share more. + +However, on machines that locate the text area far from the data area, +the boundary cannot feasibly be moved. Such machines require +NO_REMAP. + +Also, remapping can cause trouble with the built-in startup routine +/lib/crt0.o, which defines `environ' as an initialized variable. +Dumping `environ' as pure does not work! So, to use remapping, +you must write a startup routine for your machine in Emacs's crt0.c. +If NO_REMAP is defined, Emacs uses the system's crt0.o. + +* SECTION_ALIGNMENT + +Some machines that use COFF executables require that each section +start on a certain boundary *in the COFF file*. Such machines should +define SECTION_ALIGNMENT to a mask of the low-order bits that must be +zero on such a boundary. This mask is used to control padding between +segments in the COFF file. + +If SECTION_ALIGNMENT is not defined, the segments are written +consecutively with no attempt at alignment. This is right for +unmodified system V. + +* SEGMENT_MASK + +Some machines require that the beginnings and ends of segments +*in core* be on certain boundaries. For most machines, a page +boundary is sufficient. That is the default. When a larger +boundary is needed, define SEGMENT_MASK to a mask of +the bits that must be zero on such a boundary. + +* A_TEXT_OFFSET(HDR) + +Some machines count the a.out header as part of the size of the text +segment (a_text); they may actually load the header into core as the +first data in the text segment. Some have additional padding between +the header and the real text of the program that is counted in a_text. + +For these machines, define A_TEXT_OFFSET(HDR) to examine the header +structure HDR and return the number of bytes to add to `a_text' +before writing it (above and beyond the number of bytes of actual +program text). HDR's standard fields are already correct, except that +this adjustment to the `a_text' field has not yet been made; +thus, the amount of offset can depend on the data in the file. + +* A_TEXT_SEEK(HDR) + +If defined, this macro specifies the number of bytes to seek into the +a.out file before starting to write the text segment. + +* EXEC_MAGIC + +For machines using COFF, this macro, if defined, is a value stored +into the magic number field of the output file. + +* ADJUST_EXEC_HEADER + +This macro can be used to generate statements to adjust or +initialize nonstandard fields in the file header + +* ADDR_CORRECT(ADDR) + +Macro to correct an int which is the bit pattern of a pointer to a byte +into an int which is the number of a byte. + +This macro has a default definition which is usually right. +This default definition is a no-op on most machines (where a +pointer looks like an int) but not on all machines. + +*/ + +#ifndef emacs +#define PERROR(arg) perror (arg); return -1 +#else +#define IN_UNEXEC +#include "config.h" +#define PERROR(file) report_error (file, new) +#endif + +#ifndef CANNOT_DUMP /* all rest of file! */ + +#ifdef COFF_ENCAPSULATE +int need_coff_header = 1; +#include /* The location might be a poor assumption */ +#else +#ifdef MSDOS +#include +#define filehdr external_filehdr +#define scnhdr external_scnhdr +#define syment external_syment +#define auxent external_auxent +#define n_numaux e_numaux +#define n_type e_type +struct aouthdr +{ + unsigned short magic; /* type of file */ + unsigned short vstamp; /* version stamp */ + unsigned long tsize; /* text size in bytes, padded to FW bdry*/ + unsigned long dsize; /* initialized data " " */ + unsigned long bsize; /* uninitialized data " " */ + unsigned long entry; /* entry pt. */ + unsigned long text_start;/* base of text used for this file */ + unsigned long data_start;/* base of data used for this file */ +}; + + +#else /* not MSDOS */ +#include +#endif /* not MSDOS */ +#endif + +/* Define getpagesize if the system does not. + Note that this may depend on symbols defined in a.out.h. */ +#include "getpagesize.h" + +#ifndef makedev /* Try to detect types.h already loaded */ +#include +#endif /* makedev */ +#include +#include +#include + +#include /* Must be after sys/types.h for USG and BSD4_1*/ + +#ifdef USG5 +#include +#endif + +#ifndef O_RDONLY +#define O_RDONLY 0 +#endif +#ifndef O_RDWR +#define O_RDWR 2 +#endif + +#ifdef UNIXSAVE +extern char etext; +#endif + +#ifndef start_of_data +extern char *start_of_text (); /* Start of text */ +extern char *start_of_data (); /* Start of initialized data */ +#endif + +#ifdef COFF +static long block_copy_start; /* Old executable start point */ +static struct filehdr f_hdr; /* File header */ +static struct aouthdr f_ohdr; /* Optional file header (a.out) */ +long bias; /* Bias to add for growth */ +long lnnoptr; /* Pointer to line-number info within file */ +#define SYMS_START block_copy_start + +static long text_scnptr; +static long data_scnptr; + +#else /* not COFF */ + +#ifdef HPUX +extern void *sbrk (); +#else +#if 0 +/* Some systems with __STDC__ compilers still declare this `char *' in some + header file, and our declaration conflicts. The return value is always + cast, so it should be harmless to leave it undefined. Hopefully + machines with different size pointers and ints declare sbrk in a header + file. */ +#ifdef __STDC__ +extern void *sbrk (); +#else +extern char *sbrk (); +#endif /* __STDC__ */ +#endif +#endif /* HPUX */ + +#define SYMS_START ((long) N_SYMOFF (ohdr)) + +/* Some machines override the structure name for an a.out header. */ +#ifndef EXEC_HDR_TYPE +#define EXEC_HDR_TYPE struct exec +#endif + +#ifdef HPUX +#ifdef HP9000S200_ID +#define MY_ID HP9000S200_ID +#else +#include +#define MY_ID MYSYS +#endif /* no HP9000S200_ID */ +static MAGIC OLDMAGIC = {MY_ID, SHARE_MAGIC}; +static MAGIC NEWMAGIC = {MY_ID, DEMAND_MAGIC}; +#define N_TXTOFF(x) TEXT_OFFSET(x) +#define N_SYMOFF(x) LESYM_OFFSET(x) +static EXEC_HDR_TYPE hdr, ohdr; + +#else /* not HPUX */ + +#if defined (USG) && !defined (IBMAIX) && !defined (IRIS) && !defined (COFF_ENCAPSULATE) && !defined (LINUX) +static struct bhdr hdr, ohdr; +#define a_magic fmagic +#define a_text tsize +#define a_data dsize +#define a_bss bsize +#define a_syms ssize +#define a_trsize rtsize +#define a_drsize rdsize +#define a_entry entry +#define N_BADMAG(x) \ + (((x).fmagic)!=OMAGIC && ((x).fmagic)!=NMAGIC &&\ + ((x).fmagic)!=FMAGIC && ((x).fmagic)!=IMAGIC) +#define NEWMAGIC FMAGIC +#else /* IRIS or IBMAIX or not USG */ +static EXEC_HDR_TYPE hdr, ohdr; +#define NEWMAGIC ZMAGIC +#endif /* IRIS or IBMAIX not USG */ +#endif /* not HPUX */ + +static int unexec_text_start; +static int unexec_data_start; + +#ifdef COFF_ENCAPSULATE +/* coffheader is defined in the GNU a.out.encap.h file. */ +struct coffheader coffheader; +#endif + +#endif /* not COFF */ + +static int pagemask; + +/* Correct an int which is the bit pattern of a pointer to a byte + into an int which is the number of a byte. + This is a no-op on ordinary machines, but not on all. */ + +#ifndef ADDR_CORRECT /* Let m-*.h files override this definition */ +#define ADDR_CORRECT(x) ((char *)(x) - (char*)0) +#endif + +#ifdef emacs + +#include "lisp.h" + +static +report_error (file, fd) + char *file; + int fd; +{ + if (fd) + close (fd); + report_file_error ("Cannot unexec", Fcons (build_string (file), Qnil)); +} +#endif /* emacs */ + +#define ERROR0(msg) report_error_1 (new, msg, 0, 0); return -1 +#define ERROR1(msg,x) report_error_1 (new, msg, x, 0); return -1 +#define ERROR2(msg,x,y) report_error_1 (new, msg, x, y); return -1 + +static +report_error_1 (int fd, char *msg, int a1, int a2) +{ + close (fd); +#ifdef emacs + error (msg, a1, a2); +#else + fprintf (stderr, msg, a1, a2); + fprintf (stderr, "\n"); +#endif +} + +static int make_hdr (int new, int a_out, unsigned int data_start, unsigned int bss_start, unsigned int entry_address, char *a_name, char *new_name); +static int copy_text_and_data (int new, int a_out); +static int copy_sym (int new, int a_out, char *a_name, char *new_name); +static void mark_x (char *name); + +/* **************************************************************** + * unexec + * + * driving logic. + */ +void +unexec (char *new_name, char *a_name, unsigned int data_start, unsigned int bss_start, unsigned int entry_address) +{ + int new, a_out = -1; + + if (a_name && (a_out = open (a_name, O_RDONLY)) < 0) + { + PERROR (a_name); + } + if ((new = creat (new_name, 0666)) < 0) + { + PERROR (new_name); + } + + if (make_hdr (new, a_out, data_start, bss_start, entry_address, a_name, new_name) < 0 + || copy_text_and_data (new, a_out) < 0 + || copy_sym (new, a_out, a_name, new_name) < 0 +#ifdef COFF +#ifndef COFF_BSD_SYMBOLS + || adjust_lnnoptrs (new, a_out, new_name) < 0 +#endif +#endif + ) + { + close (new); + /* unlink (new_name); /* Failed, unlink new a.out */ + return -1; + } + + close (new); + if (a_out >= 0) + close (a_out); + mark_x (new_name); + return 0; +} + +/* **************************************************************** + * make_hdr + * + * Make the header in the new a.out from the header in core. + * Modify the text and data sizes. + */ +static int +make_hdr (int new, int a_out, unsigned int data_start, unsigned int bss_start, unsigned int entry_address, char *a_name, char *new_name) +{ + int tem; +#ifdef COFF + auto struct scnhdr f_thdr; /* Text section header */ + auto struct scnhdr f_dhdr; /* Data section header */ + auto struct scnhdr f_bhdr; /* Bss section header */ + auto struct scnhdr scntemp; /* Temporary section header */ + register int scns; +#endif /* COFF */ +#ifdef USG_SHARED_LIBRARIES + extern unsigned int bss_end; +#else + unsigned int bss_end; +#endif + + pagemask = getpagesize () - 1; + + /* Adjust text/data boundary. */ +#ifdef NO_REMAP + data_start = (int) start_of_data (); +#else /* not NO_REMAP */ + if (!data_start) + data_start = (int) start_of_data (); +#endif /* not NO_REMAP */ + data_start = ADDR_CORRECT (data_start); + +#ifdef SEGMENT_MASK + data_start = data_start & ~SEGMENT_MASK; /* (Down) to segment boundary. */ +#else + data_start = data_start & ~pagemask; /* (Down) to page boundary. */ +#endif + + bss_end = ADDR_CORRECT (sbrk (0)) + pagemask; + bss_end &= ~ pagemask; + + /* Adjust data/bss boundary. */ + if (bss_start != 0) + { + bss_start = (ADDR_CORRECT (bss_start) + pagemask); + /* (Up) to page bdry. */ + bss_start &= ~ pagemask; + if (bss_start > bss_end) + { + ERROR1 ("unexec: Specified bss_start (%u) is past end of program", + bss_start); + } + } + else + bss_start = bss_end; + + if (data_start > bss_start) /* Can't have negative data size. */ + { + ERROR2 ("unexec: data_start (%u) can't be greater than bss_start (%u)", + data_start, bss_start); + } + +#ifdef COFF + /* Salvage as much info from the existing file as possible */ + if (a_out >= 0) + { + if (read (a_out, &f_hdr, sizeof (f_hdr)) != sizeof (f_hdr)) + { + PERROR (a_name); + } + block_copy_start += sizeof (f_hdr); + if (f_hdr.f_opthdr > 0) + { + if (read (a_out, &f_ohdr, sizeof (f_ohdr)) != sizeof (f_ohdr)) + { + PERROR (a_name); + } + block_copy_start += sizeof (f_ohdr); + } + /* Loop through section headers, copying them in */ + lseek (a_out, sizeof (f_hdr) + f_hdr.f_opthdr, 0); + for (scns = f_hdr.f_nscns; scns > 0; scns--) { + if (read (a_out, &scntemp, sizeof (scntemp)) != sizeof (scntemp)) + { + PERROR (a_name); + } + if (scntemp.s_scnptr > 0L) + { + if (block_copy_start < scntemp.s_scnptr + scntemp.s_size) + block_copy_start = scntemp.s_scnptr + scntemp.s_size; + } + if (strcmp (scntemp.s_name, ".text") == 0) + { + f_thdr = scntemp; + } + else if (strcmp (scntemp.s_name, ".data") == 0) + { + f_dhdr = scntemp; + } + else if (strcmp (scntemp.s_name, ".bss") == 0) + { + f_bhdr = scntemp; + } + } + } + else + { + ERROR0 ("can't build a COFF file from scratch yet"); + } + + /* Now we alter the contents of all the f_*hdr variables + to correspond to what we want to dump. */ + +#ifdef USG_SHARED_LIBRARIES + + /* The amount of data we're adding to the file is distance from the + * end of the original .data space to the current end of the .data + * space. + */ + + bias = bss_start - (f_ohdr.data_start + f_dhdr.s_size); + +#endif + + f_hdr.f_flags |= (F_RELFLG | F_EXEC); +#ifdef TPIX + f_hdr.f_nscns = 3; +#endif +#ifdef EXEC_MAGIC + f_ohdr.magic = EXEC_MAGIC; +#endif +#ifndef NO_REMAP + f_ohdr.text_start = (long) start_of_text (); + f_ohdr.tsize = data_start - f_ohdr.text_start; + f_ohdr.data_start = data_start; +#endif /* NO_REMAP */ + f_ohdr.dsize = bss_start - f_ohdr.data_start; + f_ohdr.bsize = bss_end - bss_start; +#ifndef KEEP_OLD_TEXT_SCNPTR + /* On some machines, the old values are right. + ??? Maybe on all machines with NO_REMAP. */ + f_thdr.s_size = f_ohdr.tsize; + f_thdr.s_scnptr = sizeof (f_hdr) + sizeof (f_ohdr); + f_thdr.s_scnptr += (f_hdr.f_nscns) * (sizeof (f_thdr)); +#endif /* KEEP_OLD_TEXT_SCNPTR */ +#ifdef ADJUST_TEXT_SCNHDR_SIZE + /* On some machines, `text size' includes all headers. */ + f_thdr.s_size -= f_thdr.s_scnptr; +#endif /* ADJUST_TEST_SCNHDR_SIZE */ + lnnoptr = f_thdr.s_lnnoptr; +#ifdef SECTION_ALIGNMENT + /* Some systems require special alignment + of the sections in the file itself. */ + f_thdr.s_scnptr + = (f_thdr.s_scnptr + SECTION_ALIGNMENT) & ~SECTION_ALIGNMENT; +#endif /* SECTION_ALIGNMENT */ +#ifdef TPIX + f_thdr.s_scnptr = 0xd0; +#endif + text_scnptr = f_thdr.s_scnptr; +#ifdef ADJUST_TEXTBASE + text_scnptr = sizeof (f_hdr) + sizeof (f_ohdr) + (f_hdr.f_nscns) * (sizeof (f_thdr)); +#endif +#ifndef KEEP_OLD_PADDR + f_dhdr.s_paddr = f_ohdr.data_start; +#endif /* KEEP_OLD_PADDR */ + f_dhdr.s_vaddr = f_ohdr.data_start; + f_dhdr.s_size = f_ohdr.dsize; + f_dhdr.s_scnptr = f_thdr.s_scnptr + f_thdr.s_size; +#ifdef SECTION_ALIGNMENT + /* Some systems require special alignment + of the sections in the file itself. */ + f_dhdr.s_scnptr + = (f_dhdr.s_scnptr + SECTION_ALIGNMENT) & ~SECTION_ALIGNMENT; +#endif /* SECTION_ALIGNMENT */ +#ifdef DATA_SECTION_ALIGNMENT + /* Some systems require special alignment + of the data section only. */ + f_dhdr.s_scnptr + = (f_dhdr.s_scnptr + DATA_SECTION_ALIGNMENT) & ~DATA_SECTION_ALIGNMENT; +#endif /* DATA_SECTION_ALIGNMENT */ + data_scnptr = f_dhdr.s_scnptr; +#ifndef KEEP_OLD_PADDR + f_bhdr.s_paddr = f_ohdr.data_start + f_ohdr.dsize; +#endif /* KEEP_OLD_PADDR */ + f_bhdr.s_vaddr = f_ohdr.data_start + f_ohdr.dsize; + f_bhdr.s_size = f_ohdr.bsize; + f_bhdr.s_scnptr = 0L; +#ifndef USG_SHARED_LIBRARIES + bias = f_dhdr.s_scnptr + f_dhdr.s_size - block_copy_start; +#endif + + if (f_hdr.f_symptr > 0L) + { + f_hdr.f_symptr += bias; + } + + if (f_thdr.s_lnnoptr > 0L) + { + f_thdr.s_lnnoptr += bias; + } + +#ifdef ADJUST_EXEC_HEADER + ADJUST_EXEC_HEADER; +#endif /* ADJUST_EXEC_HEADER */ + + if (write (new, &f_hdr, sizeof (f_hdr)) != sizeof (f_hdr)) + { + PERROR (new_name); + } + + if (write (new, &f_ohdr, sizeof (f_ohdr)) != sizeof (f_ohdr)) + { + PERROR (new_name); + } + +#ifndef USG_SHARED_LIBRARIES + + if (write (new, &f_thdr, sizeof (f_thdr)) != sizeof (f_thdr)) + { + PERROR (new_name); + } + + if (write (new, &f_dhdr, sizeof (f_dhdr)) != sizeof (f_dhdr)) + { + PERROR (new_name); + } + + if (write (new, &f_bhdr, sizeof (f_bhdr)) != sizeof (f_bhdr)) + { + PERROR (new_name); + } + +#else /* USG_SHARED_LIBRARIES */ + + /* The purpose of this code is to write out the new file's section + * header table. + * + * Scan through the original file's sections. If the encountered + * section is one we know (.text, .data or .bss), write out the + * correct header. If it is a section we do not know (such as + * .lib), adjust the address of where the section data is in the + * file, and write out the header. + * + * If any section precedes .text or .data in the file, this code + * will not adjust the file pointer for that section correctly. + */ + + /* This used to use sizeof (f_ohdr) instead of .f_opthdr. + .f_opthdr is said to be right when there is no optional header. */ + lseek (a_out, sizeof (f_hdr) + f_hdr.f_opthdr, 0); + + for (scns = f_hdr.f_nscns; scns > 0; scns--) + { + if (read (a_out, &scntemp, sizeof (scntemp)) != sizeof (scntemp)) + PERROR (a_name); + + if (!strcmp (scntemp.s_name, f_thdr.s_name)) /* .text */ + { + if (write (new, &f_thdr, sizeof (f_thdr)) != sizeof (f_thdr)) + PERROR (new_name); + } + else if (!strcmp (scntemp.s_name, f_dhdr.s_name)) /* .data */ + { + if (write (new, &f_dhdr, sizeof (f_dhdr)) != sizeof (f_dhdr)) + PERROR (new_name); + } + else if (!strcmp (scntemp.s_name, f_bhdr.s_name)) /* .bss */ + { + if (write (new, &f_bhdr, sizeof (f_bhdr)) != sizeof (f_bhdr)) + PERROR (new_name); + } + else + { + if (scntemp.s_scnptr) + scntemp.s_scnptr += bias; + if (write (new, &scntemp, sizeof (scntemp)) != sizeof (scntemp)) + PERROR (new_name); + } + } +#endif /* USG_SHARED_LIBRARIES */ + + return (0); + +#else /* if not COFF */ + + /* Get symbol table info from header of a.out file if given one. */ + if (a_out >= 0) + { +#ifdef COFF_ENCAPSULATE + if (read (a_out, &coffheader, sizeof coffheader) != sizeof coffheader) + { + PERROR(a_name); + } + if (coffheader.f_magic != COFF_MAGIC) + { + ERROR1("%s doesn't have legal coff magic number\n", a_name); + } +#endif + if (read (a_out, &ohdr, sizeof hdr) != sizeof hdr) + { + PERROR (a_name); + } + + if (N_BADMAG (ohdr)) + { + ERROR1 ("invalid magic number in %s", a_name); + } + hdr = ohdr; + } + else + { +#ifdef COFF_ENCAPSULATE + /* We probably could without too much trouble. The code is in gld + * but I don't have that much time or incentive. + */ + ERROR0 ("can't build a COFF file from scratch yet"); +#else +#ifdef MSDOS /* Demacs 1.1.1 91/10/16 HIRANO Satoshi */ + bzero ((void *)&hdr, sizeof hdr); +#else + bzero (&hdr, sizeof hdr); +#endif +#endif + } + + unexec_text_start = (long) start_of_text (); + unexec_data_start = data_start; + + /* Machine-dependent fixup for header, or maybe for unexec_text_start */ +#ifdef ADJUST_EXEC_HEADER + ADJUST_EXEC_HEADER; +#endif /* ADJUST_EXEC_HEADER */ + + hdr.a_trsize = 0; + hdr.a_drsize = 0; + if (entry_address != 0) + hdr.a_entry = entry_address; + + hdr.a_bss = bss_end - bss_start; + hdr.a_data = bss_start - data_start; +#ifdef NO_REMAP + hdr.a_text = ohdr.a_text; +#else /* not NO_REMAP */ + hdr.a_text = data_start - unexec_text_start; + +#ifdef A_TEXT_OFFSET + hdr.a_text += A_TEXT_OFFSET (ohdr); +#endif + +#endif /* not NO_REMAP */ + +#ifdef COFF_ENCAPSULATE + /* We are encapsulating BSD format within COFF format. */ + { + struct coffscn *tp, *dp, *bp; + tp = &coffheader.scns[0]; + dp = &coffheader.scns[1]; + bp = &coffheader.scns[2]; + tp->s_size = hdr.a_text + sizeof(struct exec); + dp->s_paddr = data_start; + dp->s_vaddr = data_start; + dp->s_size = hdr.a_data; + bp->s_paddr = dp->s_vaddr + dp->s_size; + bp->s_vaddr = bp->s_paddr; + bp->s_size = hdr.a_bss; + coffheader.tsize = tp->s_size; + coffheader.dsize = dp->s_size; + coffheader.bsize = bp->s_size; + coffheader.text_start = tp->s_vaddr; + coffheader.data_start = dp->s_vaddr; + } + if (write (new, &coffheader, sizeof coffheader) != sizeof coffheader) + { + PERROR(new_name); + } +#endif /* COFF_ENCAPSULATE */ + + if (write (new, &hdr, sizeof hdr) != sizeof hdr) + { + PERROR (new_name); + } + +#if 0 /* This #ifndef caused a bug on Linux when using QMAGIC. */ + /* This adjustment was done above only #ifndef NO_REMAP, + so only undo it now #ifndef NO_REMAP. */ + /* #ifndef NO_REMAP */ +#endif +#ifdef A_TEXT_OFFSET + hdr.a_text -= A_TEXT_OFFSET (ohdr); +#endif + + return 0; + +#endif /* not COFF */ +} + +/* **************************************************************** + * copy_text_and_data + * + * Copy the text and data segments from memory to the new a.out + */ +static int +copy_text_and_data (int new, int a_out) +{ + register char *end; + register char *ptr; + +#ifdef COFF + +#ifdef USG_SHARED_LIBRARIES + + int scns; + struct scnhdr scntemp; /* Temporary section header */ + + /* The purpose of this code is to write out the new file's section + * contents. + * + * Step through the section table. If we know the section (.text, + * .data) do the appropriate thing. Otherwise, if the section has + * no allocated space in the file (.bss), do nothing. Otherwise, + * the section has space allocated in the file, and is not a section + * we know. So just copy it. + */ + + lseek (a_out, sizeof (struct filehdr) + sizeof (struct aouthdr), 0); + + for (scns = f_hdr.f_nscns; scns > 0; scns--) + { + if (read (a_out, &scntemp, sizeof (scntemp)) != sizeof (scntemp)) + PERROR ("temacs"); + + if (!strcmp (scntemp.s_name, ".text")) + { + lseek (new, (long) text_scnptr, 0); + ptr = (char *) f_ohdr.text_start; + end = ptr + f_ohdr.tsize; + write_segment (new, ptr, end); + } + else if (!strcmp (scntemp.s_name, ".data")) + { + lseek (new, (long) data_scnptr, 0); + ptr = (char *) f_ohdr.data_start; + end = ptr + f_ohdr.dsize; + write_segment (new, ptr, end); + } + else if (!scntemp.s_scnptr) + ; /* do nothing - no data for this section */ + else + { + char page[BUFSIZ]; + int size, n; + long old_a_out_ptr = lseek (a_out, 0, 1); + + lseek (a_out, scntemp.s_scnptr, 0); + for (size = scntemp.s_size; size > 0; size -= sizeof (page)) + { + n = size > sizeof (page) ? sizeof (page) : size; + if (read (a_out, page, n) != n || write (new, page, n) != n) + PERROR ("emacs"); + } + lseek (a_out, old_a_out_ptr, 0); + } + } + +#else /* COFF, but not USG_SHARED_LIBRARIES */ + + lseek (new, (long) text_scnptr, 0); + ptr = (char *) f_ohdr.text_start; +#ifdef HEADER_INCL_IN_TEXT + /* For Gould UTX/32, text starts after headers */ + ptr = (char *) (ptr + text_scnptr); +#endif /* HEADER_INCL_IN_TEXT */ + end = ptr + f_ohdr.tsize; + write_segment (new, ptr, end); + + lseek (new, (long) data_scnptr, 0); + ptr = (char *) f_ohdr.data_start; + end = ptr + f_ohdr.dsize; + write_segment (new, ptr, end); + +#endif /* USG_SHARED_LIBRARIES */ + +#else /* if not COFF */ + +/* Some machines count the header as part of the text segment. + That is to say, the header appears in core + just before the address that start_of_text returns. + For them, N_TXTOFF is the place where the header goes. + We must adjust the seek to the place after the header. + Note that at this point hdr.a_text does *not* count + the extra A_TEXT_OFFSET bytes, only the actual bytes of code. */ + +#ifdef A_TEXT_SEEK + lseek (new, (long) A_TEXT_SEEK (hdr), 0); +#else + lseek (new, (long) N_TXTOFF (hdr), 0); +#endif /* no A_TEXT_SEEK */ + +#ifdef RISCiX + + /* Acorn's RISC-iX has a wacky way of initialising the position of the heap. + * There is a little table in crt0.o that is filled at link time with + * the min and current brk positions, among other things. When start + * runs, it copies the table to where these parameters live during + * execution. This data is in text space, so it cannot be modified here + * before saving the executable, so the data is written manually. In + * addition, the table does not have a label, and the nearest accessable + * label (mcount) is not prefixed with a '_', thus making it inaccessable + * from within C programs. To overcome this, emacs's executable is passed + * through the command 'nm %s | fgrep mcount' into a pipe, and the + * resultant output is then used to find the address of 'mcount'. As far as + * is possible to determine, in RISC-iX releases prior to 1.2, the negative + * offset of the table from mcount is 0x2c, whereas from 1.2 onwards it is + * 0x30. bss_end has been rounded up to page boundary. This solution is + * based on suggestions made by Kevin Welton and Steve Hunt of Acorn, and + * avoids the need for a custom version of crt0.o for emacs which has its + * table in data space. + */ + + { + char command[1024]; + char errbuf[1024]; + char address_text[32]; + int proforma[4]; + FILE *pfile; + char *temp_ptr; + char c; + int mcount_address, mcount_offset, count; + extern char *_execname; + + + /* The use of _execname is incompatible with RISCiX 1.1 */ + sprintf (command, "nm %s | fgrep mcount", _execname); + + if ( (pfile = popen(command, "r")) == NULL) + { + sprintf (errbuf, "Could not open pipe"); + PERROR (errbuf); + } + + count=0; + while ( ((c=getc(pfile)) != EOF) && (c != ' ') && (count < 31)) + address_text[count++]=c; + address_text[count]=0; + + if ((count == 0) || pclose(pfile) != NULL) + { + sprintf (errbuf, "Failed to execute the command '%s'\n", command); + PERROR (errbuf); + } + + sscanf(address_text, "%x", &mcount_address); + ptr = (char *) unexec_text_start; + mcount_offset = (char *)mcount_address - ptr; + +#ifdef RISCiX_1_1 +#define EDATA_OFFSET 0x2c +#else +#define EDATA_OFFSET 0x30 +#endif + + end = ptr + mcount_offset - EDATA_OFFSET; + + write_segment (new, ptr, end); + + proforma[0] = bss_end; /* becomes _edata */ + proforma[1] = bss_end; /* becomes _end */ + proforma[2] = bss_end; /* becomes _minbrk */ + proforma[3] = bss_end; /* becomes _curbrk */ + + write (new, proforma, 16); + + temp_ptr = ptr; + ptr = end + 16; + end = temp_ptr + hdr.a_text; + + write_segment (new, ptr, end); + } + +#else /* !RISCiX */ + ptr = (char *) unexec_text_start; + end = ptr + hdr.a_text; + write_segment (new, ptr, end); +#endif /* RISCiX */ + + ptr = (char *) unexec_data_start; + end = ptr + hdr.a_data; +/* This lseek is certainly incorrect when A_TEXT_OFFSET + and I believe it is a no-op otherwise. + Let's see if its absence ever fails. */ +/* lseek (new, (long) N_TXTOFF (hdr) + hdr.a_text, 0); */ + write_segment (new, ptr, end); + +#endif /* not COFF */ + + return 0; +} + +write_segment (int new, register char *ptr, register char *end) +{ + register int i, nwrite, ret; + char buf[80]; + extern int errno; + char zeros[128]; + int amt_to_write = (1 << 13); + + bzero (zeros, sizeof zeros); + + for (i = 0; ptr < end;) + { + /* distance to next multiple of amt_to_write . */ + AGAIN: + nwrite = (((int) ptr + amt_to_write) & -amt_to_write) - (int) ptr; + /* But not beyond specified end. */ + if (nwrite > end - ptr) nwrite = end - ptr; + ret = write (new, ptr, nwrite); + /* If write gets a page fault, it means we reached + a gap between the old text segment and the old data segment. + This gap has probably been remapped into part of the text segment. + So write zeros for it. */ + if (ret == -1 +#ifdef EFAULT + && errno == EFAULT +#endif + ) + { if (amt_to_write > sizeof(zeros)) + { amt_to_write = sizeof(zeros); + goto AGAIN; + } + write (new, zeros, nwrite); + } + else if (nwrite != ret) + { + sprintf (buf, + "unexec write failure: addr 0x%x, fileno %d, size 0x%x, wrote 0x%x, errno %d", + ptr, new, nwrite, ret, errno); + PERROR (buf); + } + i += nwrite; + ptr += nwrite; + } +} + +/* **************************************************************** + * copy_sym + * + * Copy the relocation information and symbol table from the a.out to the new + */ +static int +copy_sym (int new, int a_out, char *a_name, char *new_name) +{ + char page[1024]; + int n; + + if (a_out < 0) + return 0; + +#ifdef COFF + if (SYMS_START == 0L) + return 0; +#endif /* COFF */ + +#ifdef COFF + if (lnnoptr) /* if there is line number info */ + lseek (a_out, lnnoptr, 0); /* start copying from there */ + else +#endif /* COFF */ + lseek (a_out, SYMS_START, 0); /* Position a.out to symtab. */ + + while ((n = read (a_out, page, sizeof page)) > 0) + { + if (write (new, page, n) != n) + { + PERROR (new_name); + } + } + if (n < 0) + { + PERROR (a_name); + } + return 0; +} + +/* **************************************************************** + * mark_x + * + * After successfully building the new a.out, mark it executable + */ +static void +mark_x (char *name) +{ + struct stat sbuf; + int um; + int new = 0; /* for PERROR */ + + um = umask (777); + umask (um); + if (stat (name, &sbuf) == -1) + { + PERROR (name); + } + sbuf.st_mode |= 0111 & ~um; + if (chmod (name, sbuf.st_mode) == -1) + PERROR (name); +} + +#ifdef COFF +#ifndef COFF_BSD_SYMBOLS + +/* + * If the COFF file contains a symbol table and a line number section, + * then any auxiliary entries that have values for x_lnnoptr must + * be adjusted by the amount that the line number section has moved + * in the file (bias computed in make_hdr). The #@$%&* designers of + * the auxiliary entry structures used the absolute file offsets for + * the line number entry rather than an offset from the start of the + * line number section! + * + * When I figure out how to scan through the symbol table and pick out + * the auxiliary entries that need adjustment, this routine will + * be fixed. As it is now, all such entries are wrong and sdb + * will complain. Fred Fish, UniSoft Systems Inc. + */ + +/* This function is probably very slow. Instead of reopening the new + file for input and output it should copy from the old to the new + using the two descriptors already open (WRITEDESC and READDESC). + Instead of reading one small structure at a time it should use + a reasonable size buffer. But I don't have time to work on such + things, so I am installing it as submitted to me. -- RMS. */ + +adjust_lnnoptrs (writedesc, readdesc, new_name) + int writedesc; + int readdesc; + char *new_name; +{ + register int nsyms; + register int new; +#if defined (amdahl_uts) || defined (pfa) + SYMENT symentry; + AUXENT auxentry; +#else + struct syment symentry; + union auxent auxentry; +#endif + + if (!lnnoptr || !f_hdr.f_symptr) + return 0; + +#ifdef MSDOS + if ((new = writedesc) < 0) +#else + if ((new = open (new_name, O_RDWR)) < 0) +#endif + { + PERROR (new_name); + return -1; + } + + lseek (new, f_hdr.f_symptr, 0); + for (nsyms = 0; nsyms < f_hdr.f_nsyms; nsyms++) + { + read (new, &symentry, SYMESZ); + if (symentry.n_numaux) + { + read (new, &auxentry, AUXESZ); + nsyms++; + if (ISFCN (symentry.n_type) || symentry.n_type == 0x2400) + { + auxentry.x_sym.x_fcnary.x_fcn.x_lnnoptr += bias; + lseek (new, -AUXESZ, 1); + write (new, &auxentry, AUXESZ); + } + } + } +#ifndef MSDOS + close (new); +#endif + return 0; +} + +#endif /* COFF_BSD_SYMBOLS */ + +#endif /* COFF */ + +#endif /* not CANNOT_DUMP */ + + +#ifdef UNIXSAVE +#include "save.c" +#endif diff --git a/o/unexelf.c b/o/unexelf.c new file mode 100755 index 0000000..8df244a --- /dev/null +++ b/o/unexelf.c @@ -0,0 +1,1253 @@ +/* Foundation; either version 2, or (at your option) +any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. + +In other words, you are welcome to use, share and improve this program. +You are forbidden to forbid anyone else to use, share and improve +what you give them. Help stamp out software-hoarding! */ + + +/* + * unexec.c - Convert a running program into an a.out file. + * + * Author: Spencer W. Thomas + * Computer Science Dept. + * University of Utah + * Date: Tue Mar 2 1982 + * Modified heavily since then. + * + * Synopsis: + * unexec (new_name, old_name, data_start, bss_start, entry_address) + * char *new_name, *old_name; + * unsigned data_start, bss_start, entry_address; + * + * Takes a snapshot of the program and makes an a.out format file in the + * file named by the string argument new_name. + * If old_name is non-NULL, the symbol table will be taken from the given file. + * On some machines, an existing old_name file is required. + * + * The boundaries within the a.out file may be adjusted with the data_start + * and bss_start arguments. Either or both may be given as 0 for defaults. + * + * Data_start gives the boundary between the text segment and the data + * segment of the program. The text segment can contain shared, read-only + * program code and literal data, while the data segment is always unshared + * and unprotected. Data_start gives the lowest unprotected address. + * The value you specify may be rounded down to a suitable boundary + * as required by the machine you are using. + * + * Bss_start indicates how much of the data segment is to be saved in the + * a.out file and restored when the program is executed. It gives the lowest + * unsaved address, and is rounded up to a page boundary. The default when 0 + * is given assumes that the entire data segment is to be stored, including + * the previous data and bss as well as any additional storage allocated with + * break (2). + * + * The new file is set up to start at entry_address. + * + */ + +/* Even more heavily modified by james@bigtex.cactus.org of Dell Computer Co. + * ELF support added. + * + * Basic theory: the data space of the running process needs to be + * dumped to the output file. Normally we would just enlarge the size + * of .data, scooting everything down. But we can't do that in ELF, + * because there is often something between the .data space and the + * .bss space. + * + * In the temacs dump below, notice that the Global Offset Table + * (.got) and the Dynamic link data (.dynamic) come between .data1 and + * .bss. It does not work to overlap .data with these fields. + * + * The solution is to create a new .data segment. This segment is + * filled with data from the current process. Since the contents of + * various sections refer to sections by index, the new .data segment + * is made the last in the table to avoid changing any existing index. + + * This is an example of how the section headers are changed. "Addr" + * is a process virtual address. "Offset" is a file offset. + +raid:/nfs/raid/src/dist-18.56/src> dump -h temacs + +temacs: + + **** SECTION HEADER TABLE **** +[No] Type Flags Addr Offset Size Name + Link Info Adralgn Entsize + +[1] 1 2 0x80480d4 0xd4 0x13 .interp + 0 0 0x1 0 + +[2] 5 2 0x80480e8 0xe8 0x388 .hash + 3 0 0x4 0x4 + +[3] 11 2 0x8048470 0x470 0x7f0 .dynsym + 4 1 0x4 0x10 + +[4] 3 2 0x8048c60 0xc60 0x3ad .dynstr + 0 0 0x1 0 + +[5] 9 2 0x8049010 0x1010 0x338 .rel.plt + 3 7 0x4 0x8 + +[6] 1 6 0x8049348 0x1348 0x3 .init + 0 0 0x4 0 + +[7] 1 6 0x804934c 0x134c 0x680 .plt + 0 0 0x4 0x4 + +[8] 1 6 0x80499cc 0x19cc 0x3c56f .text + 0 0 0x4 0 + +[9] 1 6 0x8085f3c 0x3df3c 0x3 .fini + 0 0 0x4 0 + +[10] 1 2 0x8085f40 0x3df40 0x69c .rodata + 0 0 0x4 0 + +[11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1 + 0 0 0x4 0 + +[12] 1 3 0x8088330 0x3f330 0x20afc .data + 0 0 0x4 0 + +[13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1 + 0 0 0x4 0 + +[14] 1 3 0x80a96cc 0x606cc 0x1a8 .got + 0 0 0x4 0x4 + +[15] 6 3 0x80a9874 0x60874 0x80 .dynamic + 4 0 0x4 0x8 + +[16] 8 3 0x80a98f4 0x608f4 0x449c .bss + 0 0 0x4 0 + +[17] 2 0 0 0x608f4 0x9b90 .symtab + 18 371 0x4 0x10 + +[18] 3 0 0 0x6a484 0x8526 .strtab + 0 0 0x1 0 + +[19] 3 0 0 0x729aa 0x93 .shstrtab + 0 0 0x1 0 + +[20] 1 0 0 0x72a3d 0x68b7 .comment + 0 0 0x1 0 + +raid:/nfs/raid/src/dist-18.56/src> dump -h xemacs + +xemacs: + + **** SECTION HEADER TABLE **** +[No] Type Flags Addr Offset Size Name + Link Info Adralgn Entsize + +[1] 1 2 0x80480d4 0xd4 0x13 .interp + 0 0 0x1 0 + +[2] 5 2 0x80480e8 0xe8 0x388 .hash + 3 0 0x4 0x4 + +[3] 11 2 0x8048470 0x470 0x7f0 .dynsym + 4 1 0x4 0x10 + +[4] 3 2 0x8048c60 0xc60 0x3ad .dynstr + 0 0 0x1 0 + +[5] 9 2 0x8049010 0x1010 0x338 .rel.plt + 3 7 0x4 0x8 + +[6] 1 6 0x8049348 0x1348 0x3 .init + 0 0 0x4 0 + +[7] 1 6 0x804934c 0x134c 0x680 .plt + 0 0 0x4 0x4 + +[8] 1 6 0x80499cc 0x19cc 0x3c56f .text + 0 0 0x4 0 + +[9] 1 6 0x8085f3c 0x3df3c 0x3 .fini + 0 0 0x4 0 + +[10] 1 2 0x8085f40 0x3df40 0x69c .rodata + 0 0 0x4 0 + +[11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1 + 0 0 0x4 0 + +[12] 1 3 0x8088330 0x3f330 0x20afc .data + 0 0 0x4 0 + +[13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1 + 0 0 0x4 0 + +[14] 1 3 0x80a96cc 0x606cc 0x1a8 .got + 0 0 0x4 0x4 + +[15] 6 3 0x80a9874 0x60874 0x80 .dynamic + 4 0 0x4 0x8 + +[16] 8 3 0x80c6800 0x7d800 0 .bss + 0 0 0x4 0 + +[17] 2 0 0 0x7d800 0x9b90 .symtab + 18 371 0x4 0x10 + +[18] 3 0 0 0x87390 0x8526 .strtab + 0 0 0x1 0 + +[19] 3 0 0 0x8f8b6 0x93 .shstrtab + 0 0 0x1 0 + +[20] 1 0 0 0x8f949 0x68b7 .comment + 0 0 0x1 0 + +[21] 1 3 0x80a98f4 0x608f4 0x1cf0c .data + 0 0 0x4 0 + + * This is an example of how the file header is changed. "Shoff" is + * the section header offset within the file. Since that table is + * after the new .data section, it is moved. "Shnum" is the number of + * sections, which we increment. + * + * "Phoff" is the file offset to the program header. "Phentsize" and + * "Shentsz" are the program and section header entries sizes respectively. + * These can be larger than the apparent struct sizes. + +raid:/nfs/raid/src/dist-18.56/src> dump -f temacs + +temacs: + + **** ELF HEADER **** +Class Data Type Machine Version +Entry Phoff Shoff Flags Ehsize +Phentsize Phnum Shentsz Shnum Shstrndx + +1 1 2 3 1 +0x80499cc 0x34 0x792f4 0 0x34 +0x20 5 0x28 21 19 + +raid:/nfs/raid/src/dist-18.56/src> dump -f xemacs + +xemacs: + + **** ELF HEADER **** +Class Data Type Machine Version +Entry Phoff Shoff Flags Ehsize +Phentsize Phnum Shentsz Shnum Shstrndx + +1 1 2 3 1 +0x80499cc 0x34 0x96200 0 0x34 +0x20 5 0x28 22 19 + + * These are the program headers. "Offset" is the file offset to the + * segment. "Vaddr" is the memory load address. "Filesz" is the + * segment size as it appears in the file, and "Memsz" is the size in + * memory. Below, the third segment is the code and the fourth is the + * data: the difference between Filesz and Memsz is .bss + +raid:/nfs/raid/src/dist-18.56/src> dump -o temacs + +temacs: + ***** PROGRAM EXECUTION HEADER ***** +Type Offset Vaddr Paddr +Filesz Memsz Flags Align + +6 0x34 0x8048034 0 +0xa0 0xa0 5 0 + +3 0xd4 0 0 +0x13 0 4 0 + +1 0x34 0x8048034 0 +0x3f2f9 0x3f2f9 5 0x1000 + +1 0x3f330 0x8088330 0 +0x215c4 0x25a60 7 0x1000 + +2 0x60874 0x80a9874 0 +0x80 0 7 0 + +raid:/nfs/raid/src/dist-18.56/src> dump -o xemacs + +xemacs: + ***** PROGRAM EXECUTION HEADER ***** +Type Offset Vaddr Paddr +Filesz Memsz Flags Align + +6 0x34 0x8048034 0 +0xa0 0xa0 5 0 + +3 0xd4 0 0 +0x13 0 4 0 + +1 0x34 0x8048034 0 +0x3f2f9 0x3f2f9 5 0x1000 + +1 0x3f330 0x8088330 0 +0x3e4d0 0x3e4d0 7 0x1000 + +2 0x60874 0x80a9874 0 +0x80 0 7 0 + + + */ + +/* Modified by wtien@urbana.mcd.mot.com of Motorola Inc. + * + * The above mechanism does not work if the unexeced ELF file is being + * re-layout by other applications (such as `strip'). All the applications + * that re-layout the internal of ELF will layout all sections in ascending + * order of their file offsets. After the re-layout, the data2 section will + * still be the LAST section in the section header vector, but its file offset + * is now being pushed far away down, and causes part of it not to be mapped + * in (ie. not covered by the load segment entry in PHDR vector), therefore + * causes the new binary to fail. + * + * The solution is to modify the unexec algorithm to insert the new data2 + * section header right before the new bss section header, so their file + * offsets will be in the ascending order. Since some of the section's (all + * sections AFTER the bss section) indexes are now changed, we also need to + * modify some fields to make them point to the right sections. This is done + * by macro PATCH_INDEX. All the fields that need to be patched are: + * + * 1. ELF header e_shstrndx field. + * 2. section header sh_link and sh_info field. + * 3. symbol table entry st_shndx field. + * + * The above example now should look like: + + **** SECTION HEADER TABLE **** +[No] Type Flags Addr Offset Size Name + Link Info Adralgn Entsize + +[1] 1 2 0x80480d4 0xd4 0x13 .interp + 0 0 0x1 0 + +[2] 5 2 0x80480e8 0xe8 0x388 .hash + 3 0 0x4 0x4 + +[3] 11 2 0x8048470 0x470 0x7f0 .dynsym + 4 1 0x4 0x10 + +[4] 3 2 0x8048c60 0xc60 0x3ad .dynstr + 0 0 0x1 0 + +[5] 9 2 0x8049010 0x1010 0x338 .rel.plt + 3 7 0x4 0x8 + +[6] 1 6 0x8049348 0x1348 0x3 .init + 0 0 0x4 0 + +[7] 1 6 0x804934c 0x134c 0x680 .plt + 0 0 0x4 0x4 + +[8] 1 6 0x80499cc 0x19cc 0x3c56f .text + 0 0 0x4 0 + +[9] 1 6 0x8085f3c 0x3df3c 0x3 .fini + 0 0 0x4 0 + +[10] 1 2 0x8085f40 0x3df40 0x69c .rodata + 0 0 0x4 0 + +[11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1 + 0 0 0x4 0 + +[12] 1 3 0x8088330 0x3f330 0x20afc .data + 0 0 0x4 0 + +[13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1 + 0 0 0x4 0 + +[14] 1 3 0x80a96cc 0x606cc 0x1a8 .got + 0 0 0x4 0x4 + +[15] 6 3 0x80a9874 0x60874 0x80 .dynamic + 4 0 0x4 0x8 + +[16] 1 3 0x80a98f4 0x608f4 0x1cf0c .data + 0 0 0x4 0 + +[17] 8 3 0x80c6800 0x7d800 0 .bss + 0 0 0x4 0 + +[18] 2 0 0 0x7d800 0x9b90 .symtab + 19 371 0x4 0x10 + +[19] 3 0 0 0x87390 0x8526 .strtab + 0 0 0x1 0 + +[20] 3 0 0 0x8f8b6 0x93 .shstrtab + 0 0 0x1 0 + +[21] 1 0 0 0x8f949 0x68b7 .comment + 0 0 0x1 0 + + */ + +/* We do not use mmap because that fails with NFS. + Instead we read the whole file, modify it, and write it out. */ + +#ifndef emacs +#define fatal(a, b...) fprintf (stderr, a, ##b), exit (1) +#else +#include "config.h" +extern void fatal (char *, ...); +#endif + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#if !defined (__NetBSD__) && !defined (__OpenBSD__) +#include +#endif +#include +#if defined (__sony_news) && defined (_SYSTYPE_SYSV) +#include +#include +#endif /* __sony_news && _SYSTYPE_SYSV */ +#if __sgi +#include /* for HDRR declaration */ +#endif /* __sgi */ + +#ifndef MAP_ANON +#ifdef MAP_ANONYMOUS +#define MAP_ANON MAP_ANONYMOUS +#else +#define MAP_ANON 0 +#endif +#endif + +#ifndef MAP_FAILED +#define MAP_FAILED ((void *) -1) +#endif + +#if defined (__alpha__) && !defined (__NetBSD__) && !defined (__OpenBSD__) +/* Declare COFF debugging symbol table. This used to be in + /usr/include/sym.h, but this file is no longer included in Red Hat + 5.0 and presumably in any other glibc 2.x based distribution. */ +typedef struct { + short magic; + short vstamp; + int ilineMax; + int idnMax; + int ipdMax; + int isymMax; + int ioptMax; + int iauxMax; + int issMax; + int issExtMax; + int ifdMax; + int crfd; + int iextMax; + long cbLine; + long cbLineOffset; + long cbDnOffset; + long cbPdOffset; + long cbSymOffset; + long cbOptOffset; + long cbAuxOffset; + long cbSsOffset; + long cbSsExtOffset; + long cbFdOffset; + long cbRfdOffset; + long cbExtOffset; +} HDRR, *pHDRR; +#define cbHDRR sizeof(HDRR) +#define hdrNil ((pHDRR)0) +#endif + +#ifdef __NetBSD__ +/* + * NetBSD does not have normal-looking user-land ELF support. + */ +# ifdef __alpha__ +# define ELFSIZE 64 +# else +# define ELFSIZE 32 +# endif +# include + +# ifndef PT_LOAD +# define PT_LOAD Elf_pt_load +# define SHT_SYMTAB Elf_sht_symtab +# define SHT_DYNSYM Elf_sht_dynsym +# define SHT_NULL Elf_sht_null +# define SHT_NOBITS Elf_sht_nobits +# define SHT_REL Elf_sht_rel +# define SHT_RELA Elf_sht_rela + +# define SHN_UNDEF Elf_eshn_undefined +# define SHN_ABS Elf_eshn_absolute +# define SHN_COMMON Elf_eshn_common +# endif + +# ifdef __alpha__ +# include +# define HDRR struct ecoff_symhdr +# define pHDRR HDRR * +# endif +#endif /* __NetBSD__ */ + +#ifdef __OpenBSD__ +# include +#endif + +#if __GNU_LIBRARY__ - 0 >= 6 +# include /* get ElfW etc */ +#endif + +#ifndef ElfW +# ifdef __STDC__ +# define ElfBitsW(bits, type) Elf##bits##_##type +# else +# define ElfBitsW(bits, type) Elf/**/bits/**/_/**/type +# endif +# ifdef _LP64 +# define ELFSIZE 64 +# else +# define ELFSIZE 32 +# endif + /* This macro expands `bits' before invoking ElfBitsW. */ +# define ElfExpandBitsW(bits, type) ElfBitsW (bits, type) +# define ElfW(type) ElfExpandBitsW (ELFSIZE, type) +#endif + +#ifndef ELF_BSS_SECTION_NAME +#define ELF_BSS_SECTION_NAME ".bss" +#endif + +/* Get the address of a particular section or program header entry, + * accounting for the size of the entries. + */ +/* + On PPC Reference Platform running Solaris 2.5.1 + the plt section is also of type NOBI like the bss section. + (not really stored) and therefore sections after the bss + section start at the plt offset. The plt section is always + the one just before the bss section. + Thus, we modify the test from + if (NEW_SECTION_H (nn).sh_offset >= new_data2_offset) + to + if (NEW_SECTION_H (nn).sh_offset >= + OLD_SECTION_H (old_bss_index-1).sh_offset) + This is just a hack. We should put the new data section + before the .plt section. + And we should not have this routine at all but use + the libelf library to read the old file and create the new + file. + The changed code is minimal and depends on prep set in m/prep.h + Erik Deumens + Quantum Theory Project + University of Florida + deumens@qtp.ufl.edu + Apr 23, 1996 + */ + +#define OLD_SECTION_H(n) \ + (*(ElfW(Shdr) *) ((byte *) old_section_h + old_file_h->e_shentsize * (n))) +#define NEW_SECTION_H(n) \ + (*(ElfW(Shdr) *) ((byte *) new_section_h + new_file_h->e_shentsize * (n))) +#define OLD_PROGRAM_H(n) \ + (*(ElfW(Phdr) *) ((byte *) old_program_h + old_file_h->e_phentsize * (n))) +#define NEW_PROGRAM_H(n) \ + (*(ElfW(Phdr) *) ((byte *) new_program_h + new_file_h->e_phentsize * (n))) + +#define PATCH_INDEX(n) \ + do { \ + if ((int) (n) >= old_bss_index) \ + (n)++; } while (0) +typedef unsigned char byte; + +/* Round X up to a multiple of Y. */ + +static ElfW(Addr) +round_up (x, y) + ElfW(Addr) x, y; +{ + int rem = x % y; + if (rem == 0) + return x; + return x - rem + y; +} + +/* Return the index of the section named NAME. + SECTION_NAMES, FILE_NAME and FILE_H give information + about the file we are looking in. + + If we don't find the section NAME, that is a fatal error + if NOERROR is 0; we return -1 if NOERROR is nonzero. */ + +static int +find_section (char *name, char *section_names, char *file_name, ElfW(Ehdr) *old_file_h, ElfW(Shdr) *old_section_h, int noerror) +{ + int idx; + + for (idx = 1; idx < old_file_h->e_shnum; idx++) + { +#ifdef DEBUG + fprintf (stderr, "Looking for %s - found %s\n", name, + section_names + OLD_SECTION_H (idx).sh_name); +#endif + if (!strcmp (section_names + OLD_SECTION_H (idx).sh_name, + name)) + break; + } + if (idx == old_file_h->e_shnum) + { + if (noerror) + return -1; + else + fatal ("Can't find %s in %s.\n", name, file_name); + } + + return idx; +} + +/* **************************************************************** + * unexec + * + * driving logic. + * + * In ELF, this works by replacing the old .bss section with a new + * .data section, and inserting an empty .bss immediately afterwards. + * + */ +static void +unexec (char *new_name, char *old_name, unsigned int data_start, unsigned int bss_start, unsigned int entry_address) +{ + int new_file, old_file, new_file_size; + + /* Pointers to the base of the image of the two files. */ + caddr_t old_base, new_base; + +#if MAP_ANON == 0 + int mmap_fd; +#else +# define mmap_fd -1 +#endif + + /* Pointers to the file, program and section headers for the old and + new files. */ + ElfW(Ehdr) *old_file_h, *new_file_h; + ElfW(Phdr) *old_program_h, *new_program_h; + ElfW(Shdr) *old_section_h, *new_section_h; + + /* Point to the section name table in the old file */ + char *old_section_names; + + ElfW(Addr) old_bss_addr, new_bss_addr; + ElfW(Word) old_bss_size, new_data2_size,old_bss_offset; + ElfW(Off) new_data2_offset; + ElfW(Addr) new_data2_addr; + + int n, nn; + int old_bss_index, old_sbss_index; + int old_data_index, new_data2_index; + int old_mdebug_index; + struct stat stat_buf; + int old_file_size; + + /* Open the old file, allocate a buffer of the right size, and read + in the file contents. */ + + old_file = open (old_name, O_RDONLY); + + if (old_file < 0) + fatal ("Can't open %s for reading: errno %d\n", old_name, errno); + + if (fstat (old_file, &stat_buf) == -1) + fatal ("Can't fstat (%s): errno %d\n", old_name, errno); + +#if MAP_ANON == 0 + mmap_fd = open ("/dev/zero", O_RDONLY); + if (mmap_fd < 0) + fatal ("Can't open /dev/zero for reading: errno %d\n", errno); +#endif + + /* We cannot use malloc here because that may use sbrk. If it does, + we'd dump our temporary buffers with Emacs, and we'd have to be + extra careful to use the correct value of sbrk(0) after + allocating all buffers in the code below, which we aren't. */ + old_file_size = stat_buf.st_size; + old_base = mmap (NULL, old_file_size, PROT_READ,MAP_SHARED, old_file, 0); + if (old_base == MAP_FAILED) + fatal ("Can't allocate buffer for %s\n", old_name); + + /* errno=0; */ + /* if (read (old_file, old_base, stat_buf.st_size) != stat_buf.st_size) */ + /* fatal ("Didn't read all of %s: errno %d\n", old_name, errno); */ + + /* Get pointers to headers & section names */ + + old_file_h = (ElfW(Ehdr) *) old_base; + old_program_h = (ElfW(Phdr) *) ((byte *) old_base + old_file_h->e_phoff); + old_section_h = (ElfW(Shdr) *) ((byte *) old_base + old_file_h->e_shoff); + old_section_names = (char *) old_base + + OLD_SECTION_H (old_file_h->e_shstrndx).sh_offset; + + /* Find the mdebug section, if any. */ + + old_mdebug_index = find_section (".mdebug", old_section_names, + old_name, old_file_h, old_section_h, 1); + + /* Find the old .bss section. Figure out parameters of the new + * data2 and bss sections. + */ + + old_bss_index = find_section (".bss", old_section_names, + old_name, old_file_h, old_section_h, 0); + + old_sbss_index = find_section (".sbss", old_section_names, + old_name, old_file_h, old_section_h, 1); + if (old_sbss_index != -1) + if (OLD_SECTION_H (old_sbss_index).sh_type == SHT_PROGBITS) + old_sbss_index = -1; + + if (old_sbss_index == -1) + { + old_bss_addr = OLD_SECTION_H (old_bss_index).sh_addr; + old_bss_offset = OLD_SECTION_H (old_bss_index).sh_offset; + old_bss_size = OLD_SECTION_H (old_bss_index).sh_size; + new_data2_index = old_bss_index; + } + else + { + old_bss_addr = OLD_SECTION_H (old_sbss_index).sh_addr; + old_bss_offset = OLD_SECTION_H (old_sbss_index).sh_offset; + old_bss_size = OLD_SECTION_H (old_bss_index).sh_size + + OLD_SECTION_H (old_sbss_index).sh_size; + new_data2_index = old_sbss_index; + } + + /* Find the old .data section. Figure out parameters of + the new data2 and bss sections. */ + + old_data_index = find_section (".data", old_section_names, + old_name, old_file_h, old_section_h, 0); + +#if defined (emacs) || !defined (DEBUG) + new_bss_addr = (ElfW(Addr)) sbrk (0); +#else + new_bss_addr = old_bss_addr + old_bss_size + 0x1234; +#endif + new_data2_addr = old_bss_addr; + new_data2_size = new_bss_addr - old_bss_addr; + new_data2_offset = OLD_SECTION_H (old_data_index).sh_offset + /*to preserve data offset alignment*/ + (new_data2_addr - OLD_SECTION_H (old_data_index).sh_addr); + +#ifdef DEBUG + fprintf (stderr, "old_bss_index %d\n", old_bss_index); + fprintf (stderr, "old_bss_addr %x\n", old_bss_addr); + fprintf (stderr, "old_bss_size %x\n", old_bss_size); + fprintf (stderr, "new_bss_addr %x\n", new_bss_addr); + fprintf (stderr, "new_data2_addr %x\n", new_data2_addr); + fprintf (stderr, "new_data2_size %x\n", new_data2_size); + fprintf (stderr, "new_data2_offset %x\n", new_data2_offset); +#endif + + if ((unsigned) new_bss_addr < (unsigned) old_bss_addr + old_bss_size) + fatal (".bss shrank when undumping???\n"); + + /* Set the output file to the right size. Allocate a buffer to hold + the image of the new file. Set pointers to various interesting + objects. stat_buf still has old_file data. */ + + new_file = open (new_name, O_RDWR | O_CREAT, 0666); + if (new_file < 0) + fatal ("Can't creat (%s): errno %d\n", new_name, errno); + + new_file_size = stat_buf.st_size + old_file_h->e_shentsize + new_data2_size + (new_data2_offset-old_bss_offset); + + if (ftruncate (new_file, new_file_size)) + fatal ("Can't ftruncate (%s): errno %d\n", new_name, errno); + + new_base = mmap (NULL, new_file_size, PROT_READ | PROT_WRITE,MAP_SHARED, new_file, 0); + if (new_base == MAP_FAILED) + fatal ("Can't allocate buffer for %s\n", old_name); + + new_file_h = (ElfW(Ehdr) *) new_base; + new_program_h = (ElfW(Phdr) *) ((byte *) new_base + old_file_h->e_phoff); + new_section_h = (ElfW(Shdr) *) + ((byte *) new_base + old_file_h->e_shoff + new_data2_size + (new_data2_offset-old_bss_offset)); + + + /* Make our new file, program and section headers as copies of the + * originals. + */ + + memcpy (new_file_h, old_file_h, old_file_h->e_ehsize); + memcpy (new_program_h, old_program_h, + old_file_h->e_phnum * old_file_h->e_phentsize); + + /* Modify the e_shstrndx if necessary. */ + PATCH_INDEX (new_file_h->e_shstrndx); + + /* Fix up file header. We'll add one section. Section header is + * further away now. + */ + + new_file_h->e_shoff += new_data2_size + (new_data2_offset-old_bss_offset); + new_file_h->e_shnum += 1; + +#ifdef DEBUG + fprintf (stderr, "Old section offset %x\n", old_file_h->e_shoff); + fprintf (stderr, "Old section count %d\n", old_file_h->e_shnum); + fprintf (stderr, "New section offset %x\n", new_file_h->e_shoff); + fprintf (stderr, "New section count %d\n", new_file_h->e_shnum); +#endif + + /* Fix up a new program header. Extend the writable data segment so + * that the bss area is covered too. Find that segment by looking + * for a segment that ends just before the .bss area. Make sure + * that no segments are above the new .data2. Put a loop at the end + * to adjust the offset and address of any segment that is above + * data2, just in case we decide to allow this later. + */ + + for (n = new_file_h->e_phnum - 1; n >= 0; n--) + { + /* Compute maximum of all requirements for alignment of section. */ + ElfW(Word) alignment = (NEW_PROGRAM_H (n)).p_align; + if ((OLD_SECTION_H (old_bss_index)).sh_addralign > alignment) + alignment = OLD_SECTION_H (old_bss_index).sh_addralign; + +#ifdef __sgi + /* According to r02kar@x4u2.desy.de (Karsten Kuenne) + and oliva@gnu.org (Alexandre Oliva), on IRIX 5.2, we + always get "Program segment above .bss" when dumping + when the executable doesn't have an sbss section. */ + if (old_sbss_index != -1) +#endif /* __sgi */ + if (NEW_PROGRAM_H (n).p_vaddr + NEW_PROGRAM_H (n).p_filesz + > (old_sbss_index == -1 + ? old_bss_addr + : round_up (old_bss_addr, alignment))) + fatal ("Program segment above .bss in %s\n", old_name); + + if (NEW_PROGRAM_H (n).p_type == PT_LOAD + && (round_up ((NEW_PROGRAM_H (n)).p_vaddr + + (NEW_PROGRAM_H (n)).p_filesz, + alignment) + <= round_up (old_bss_addr, alignment))) + break; + } + if (n < 0) + fatal ("Couldn't find segment next to .bss in %s\n", old_name); + + /* Make sure that the size includes any padding before the old .bss + section. */ + NEW_PROGRAM_H (n).p_filesz = new_bss_addr - NEW_PROGRAM_H (n).p_vaddr; + NEW_PROGRAM_H (n).p_memsz = NEW_PROGRAM_H (n).p_filesz; + +#if 0 /* Maybe allow section after data2 - does this ever happen? */ + for (n = new_file_h->e_phnum - 1; n >= 0; n--) + { + if (NEW_PROGRAM_H (n).p_vaddr + && NEW_PROGRAM_H (n).p_vaddr >= new_data2_addr) + NEW_PROGRAM_H (n).p_vaddr += new_data2_size - old_bss_size; + + if (NEW_PROGRAM_H (n).p_offset >= new_data2_offset) + NEW_PROGRAM_H (n).p_offset += new_data2_size; + } +#endif + + /* Fix up section headers based on new .data2 section. Any section + * whose offset or virtual address is after the new .data2 section + * gets its value adjusted. .bss size becomes zero and new address + * is set. data2 section header gets added by copying the existing + * .data header and modifying the offset, address and size. + */ + for (old_data_index = 1; old_data_index < (int) old_file_h->e_shnum; + old_data_index++) + if (!strcmp (old_section_names + OLD_SECTION_H (old_data_index).sh_name, + ".data")) + break; + if (old_data_index == old_file_h->e_shnum) + fatal ("Can't find .data in %s.\n", old_name); + + /* Walk through all section headers, insert the new data2 section right + before the new bss section. */ + for (n = 1, nn = 1; n < (int) old_file_h->e_shnum; n++, nn++) + { + caddr_t src; + /* If it is (s)bss section, insert the new data2 section before it. */ + /* new_data2_index is the index of either old_sbss or old_bss, that was + chosen as a section for new_data2. */ + if (n == new_data2_index) + { + /* Steal the data section header for this data2 section. */ + memcpy (&NEW_SECTION_H (nn), &OLD_SECTION_H (old_data_index), + new_file_h->e_shentsize); + + NEW_SECTION_H (nn).sh_addr = new_data2_addr; + NEW_SECTION_H (nn).sh_offset = new_data2_offset; + NEW_SECTION_H (nn).sh_size = new_data2_size; + /* Use the bss section's alignment. This will assure that the + new data2 section always be placed in the same spot as the old + bss section by any other application. */ + NEW_SECTION_H (nn).sh_addralign = OLD_SECTION_H (n).sh_addralign; + /* for gcl make the NEW_SECTION_H executable since it will + have code in it. */ + NEW_SECTION_H (nn).sh_flags |= SHF_EXECINSTR; + + /* Now copy over what we have in the memory now. */ + memcpy (NEW_SECTION_H (nn).sh_offset + new_base, + (caddr_t) OLD_SECTION_H (n).sh_addr, + new_data2_size); + nn++; + } + + memcpy (&NEW_SECTION_H (nn), &OLD_SECTION_H (n), + old_file_h->e_shentsize); + + if (n == old_bss_index + /* The new bss and sbss section's size is zero, and its file offset + and virtual address should be off by NEW_DATA2_SIZE. */ + || n == old_sbss_index + ) + { + /* NN should be `old_s?bss_index + 1' at this point. */ + NEW_SECTION_H (nn).sh_offset = + NEW_SECTION_H (new_data2_index).sh_offset + new_data2_size; + NEW_SECTION_H (nn).sh_addr = + NEW_SECTION_H (new_data2_index).sh_addr + new_data2_size; + /* Let the new bss section address alignment be the same as the + section address alignment followed the old bss section, so + this section will be placed in exactly the same place. */ + NEW_SECTION_H (nn).sh_addralign = OLD_SECTION_H (nn).sh_addralign; + NEW_SECTION_H (nn).sh_size = 0; + } + else + { + /* Any section that was originally placed after the .bss + section should now be off by NEW_DATA2_SIZE. If a + section overlaps the .bss section, consider it to be + placed after the .bss section. Overlap can occur if the + section just before .bss has less-strict alignment; this + was observed between .symtab and .bss on Solaris 2.5.1 + (sparc) with GCC snapshot 960602. */ +#ifdef SOLARIS_POWERPC + /* On PPC Reference Platform running Solaris 2.5.1 + the plt section is also of type NOBI like the bss section. + (not really stored) and therefore sections after the bss + section start at the plt offset. The plt section is always + the one just before the bss section. + It would be better to put the new data section before + the .plt section, or use libelf instead. + Erik Deumens, deumens@qtp.ufl.edu. */ + if (NEW_SECTION_H (nn).sh_offset + >= OLD_SECTION_H (old_bss_index-1).sh_offset) + NEW_SECTION_H (nn).sh_offset += new_data2_size; +#else + if (NEW_SECTION_H (nn).sh_offset >= old_bss_offset || + /* solaris has symtab straddling bss offset */ + NEW_SECTION_H (nn).sh_offset+NEW_SECTION_H (nn).sh_size > old_bss_offset) + NEW_SECTION_H (nn).sh_offset += new_data2_size+(new_data2_offset-old_bss_offset); +#endif + /* Any section that was originally placed after the section + header table should now be off by the size of one section + header table entry. */ + if (NEW_SECTION_H (nn).sh_offset > new_file_h->e_shoff) + NEW_SECTION_H (nn).sh_offset += new_file_h->e_shentsize; + } + + /* If any section hdr refers to the section after the new .data + section, make it refer to next one because we have inserted + a new section in between. */ + + PATCH_INDEX (NEW_SECTION_H (nn).sh_link); + /* For symbol tables, info is a symbol table index, + so don't change it. */ + if (NEW_SECTION_H (nn).sh_type != SHT_SYMTAB + && NEW_SECTION_H (nn).sh_type != SHT_DYNSYM) + PATCH_INDEX (NEW_SECTION_H (nn).sh_info); + + if (old_sbss_index != -1) + if (!strcmp (old_section_names + NEW_SECTION_H (nn).sh_name, ".sbss")) + { + NEW_SECTION_H (nn).sh_offset = + round_up (NEW_SECTION_H (nn).sh_offset, + NEW_SECTION_H (nn).sh_addralign); + NEW_SECTION_H (nn).sh_type = SHT_PROGBITS; + } + + /* Now, start to copy the content of sections. */ + if (NEW_SECTION_H (nn).sh_type == SHT_NULL + || NEW_SECTION_H (nn).sh_type == SHT_NOBITS) + continue; + + /* Write out the sections. .data and .data1 (and data2, called + ".data" in the strings table) get copied from the current process + instead of the old file. */ + if (!strcmp (old_section_names + NEW_SECTION_H (nn).sh_name, ".data") + || !strcmp ((old_section_names + NEW_SECTION_H (nn).sh_name), + ".sdata") + || !strcmp ((old_section_names + NEW_SECTION_H (nn).sh_name), + ".lit4") + || !strcmp ((old_section_names + NEW_SECTION_H (nn).sh_name), + ".lit8") + || !strcmp ((old_section_names + NEW_SECTION_H (nn).sh_name), + ".sdata1") + || !strcmp ((old_section_names + NEW_SECTION_H (nn).sh_name), + ".data1") + || !strcmp (old_section_names + NEW_SECTION_H (nn).sh_name, + ".sbss")) + src = (caddr_t) OLD_SECTION_H (n).sh_addr; + else + src = old_base + OLD_SECTION_H (n).sh_offset; + + memcpy (NEW_SECTION_H (nn).sh_offset + new_base, src, + NEW_SECTION_H (nn).sh_size); + +#ifdef __alpha__ + /* Update Alpha COFF symbol table: */ + if (strcmp (old_section_names + OLD_SECTION_H (n).sh_name, ".mdebug") + == 0) + { + pHDRR symhdr = (pHDRR) (NEW_SECTION_H (nn).sh_offset + new_base); + + symhdr->cbLineOffset += new_data2_size; + symhdr->cbDnOffset += new_data2_size; + symhdr->cbPdOffset += new_data2_size; + symhdr->cbSymOffset += new_data2_size; + symhdr->cbOptOffset += new_data2_size; + symhdr->cbAuxOffset += new_data2_size; + symhdr->cbSsOffset += new_data2_size; + symhdr->cbSsExtOffset += new_data2_size; + symhdr->cbFdOffset += new_data2_size; + symhdr->cbRfdOffset += new_data2_size; + symhdr->cbExtOffset += new_data2_size; + } +#endif /* __alpha__ */ + +#if defined (__sony_news) && defined (_SYSTYPE_SYSV) + if (NEW_SECTION_H (nn).sh_type == SHT_MIPS_DEBUG + && old_mdebug_index != -1) + { + int diff = NEW_SECTION_H(nn).sh_offset + - OLD_SECTION_H(old_mdebug_index).sh_offset; + HDRR *phdr = (HDRR *)(NEW_SECTION_H (nn).sh_offset + new_base); + + if (diff) + { + phdr->cbLineOffset += diff; + phdr->cbDnOffset += diff; + phdr->cbPdOffset += diff; + phdr->cbSymOffset += diff; + phdr->cbOptOffset += diff; + phdr->cbAuxOffset += diff; + phdr->cbSsOffset += diff; + phdr->cbSsExtOffset += diff; + phdr->cbFdOffset += diff; + phdr->cbRfdOffset += diff; + phdr->cbExtOffset += diff; + } + } +#endif /* __sony_news && _SYSTYPE_SYSV */ + +#if __sgi + /* Adjust the HDRR offsets in .mdebug and copy the + line data if it's in its usual 'hole' in the object. + Makes the new file debuggable with dbx. + patches up two problems: the absolute file offsets + in the HDRR record of .mdebug (see /usr/include/syms.h), and + the ld bug that gets the line table in a hole in the + elf file rather than in the .mdebug section proper. + David Anderson. davea@sgi.com Jan 16,1994. */ + if (n == old_mdebug_index) + { +#define MDEBUGADJUST(__ct,__fileaddr) \ + if (n_phdrr->__ct > 0) \ + { \ + n_phdrr->__fileaddr += movement; \ + } + + HDRR * o_phdrr = (HDRR *)((byte *)old_base + OLD_SECTION_H (n).sh_offset); + HDRR * n_phdrr = (HDRR *)((byte *)new_base + NEW_SECTION_H (nn).sh_offset); + unsigned movement = new_data2_size; + + MDEBUGADJUST (idnMax, cbDnOffset); + MDEBUGADJUST (ipdMax, cbPdOffset); + MDEBUGADJUST (isymMax, cbSymOffset); + MDEBUGADJUST (ioptMax, cbOptOffset); + MDEBUGADJUST (iauxMax, cbAuxOffset); + MDEBUGADJUST (issMax, cbSsOffset); + MDEBUGADJUST (issExtMax, cbSsExtOffset); + MDEBUGADJUST (ifdMax, cbFdOffset); + MDEBUGADJUST (crfd, cbRfdOffset); + MDEBUGADJUST (iextMax, cbExtOffset); + /* The Line Section, being possible off in a hole of the object, + requires special handling. */ + if (n_phdrr->cbLine > 0) + { + if (o_phdrr->cbLineOffset > (OLD_SECTION_H (n).sh_offset + + OLD_SECTION_H (n).sh_size)) + { + /* line data is in a hole in elf. do special copy and adjust + for this ld mistake. + */ + n_phdrr->cbLineOffset += movement; + + memcpy (n_phdrr->cbLineOffset + new_base, + o_phdrr->cbLineOffset + old_base, n_phdrr->cbLine); + } + else + { + /* somehow line data is in .mdebug as it is supposed to be. */ + MDEBUGADJUST (cbLine, cbLineOffset); + } + } + } +#endif /* __sgi */ + + /* If it is the symbol table, its st_shndx field needs to be patched. */ + if (NEW_SECTION_H (nn).sh_type == SHT_SYMTAB + || NEW_SECTION_H (nn).sh_type == SHT_DYNSYM) + { + ElfW(Shdr) *spt = &NEW_SECTION_H (nn); + unsigned int num = spt->sh_size / spt->sh_entsize; + ElfW(Sym) * sym = (ElfW(Sym) *) (NEW_SECTION_H (nn).sh_offset + + new_base); + for (; num--; sym++) + { + if ((sym->st_shndx == SHN_UNDEF) + || (sym->st_shndx == SHN_ABS) + || (sym->st_shndx == SHN_COMMON)) + continue; + + PATCH_INDEX (sym->st_shndx); + } + } + } + + /* Update the symbol values of _edata and _end. */ + for (n = new_file_h->e_shnum - 1; n; n--) + { + byte *symnames; + ElfW(Sym) *symp, *symendp; + + if (NEW_SECTION_H (n).sh_type != SHT_DYNSYM + && NEW_SECTION_H (n).sh_type != SHT_SYMTAB) + continue; + + symnames = ((byte *) new_base + + NEW_SECTION_H (NEW_SECTION_H (n).sh_link).sh_offset); + symp = (ElfW(Sym) *) (NEW_SECTION_H (n).sh_offset + new_base); + symendp = (ElfW(Sym) *) ((byte *)symp + NEW_SECTION_H (n).sh_size); + + for (; symp < symendp; symp ++) + if (strcmp ((char *) (symnames + symp->st_name), "_end") == 0 + || strcmp ((char *) (symnames + symp->st_name), "end") == 0 + || strcmp ((char *) (symnames + symp->st_name), "_edata") == 0 + || strcmp ((char *) (symnames + symp->st_name), "edata") == 0) + memcpy (&symp->st_value, &new_bss_addr, sizeof (new_bss_addr)); + } + + /* This loop seeks out relocation sections for the data section, so + that it can undo relocations performed by the runtime linker. */ + for (n = new_file_h->e_shnum - 1; n; n--) + { + ElfW(Shdr) section = NEW_SECTION_H (n); + switch (section.sh_type) { + default: + break; + case SHT_REL: + case SHT_RELA: + /* This code handles two different size structs, but there should + be no harm in that provided that r_offset is always the first + member. */ + nn = section.sh_info; + if (nn && (!strcmp (old_section_names + NEW_SECTION_H (nn).sh_name, ".data") + || !strcmp ((old_section_names + NEW_SECTION_H (nn).sh_name), + ".sdata") + || !strcmp ((old_section_names + NEW_SECTION_H (nn).sh_name), + ".lit4") + || !strcmp ((old_section_names + NEW_SECTION_H (nn).sh_name), + ".lit8") + || !strcmp ((old_section_names + NEW_SECTION_H (nn).sh_name), + ".sdata1") + || !strcmp ((old_section_names + NEW_SECTION_H (nn).sh_name), + ".data1"))) + { + ElfW(Addr) offset = NEW_SECTION_H (nn).sh_addr - + NEW_SECTION_H (nn).sh_offset; + caddr_t reloc = old_base + section.sh_offset, end; + for (end = reloc + section.sh_size; reloc < end; + reloc += section.sh_entsize) + { + ElfW(Addr) addr = ((ElfW(Rel) *) reloc)->r_offset - offset; +#ifdef __alpha__ + /* The Alpha ELF binutils currently have a bug that + sometimes results in relocs that contain all + zeroes. Work around this for now... */ + if (((ElfW(Rel) *) reloc)->r_offset == 0) + continue; +#endif + memcpy (new_base + addr, old_base + addr, sizeof(ElfW(Addr))); + } + } + break; + } + } + + /* Write out new_file, and free the buffers. */ + + /* if (write (new_file, new_base, new_file_size) != new_file_size) */ + /* fatal ("Didn't write %d bytes to %s: errno %d\n", */ + /* new_file_size, new_base, errno); */ + + munmap (old_base, old_file_size); + munmap (new_base, new_file_size); + + /* Close the files and make the new file executable. */ + +#if MAP_ANON == 0 + close (mmap_fd); +#endif + + if (close (old_file)) + fatal ("Can't close (%s): errno %d\n", old_name, errno); + + if (close (new_file)) + fatal ("Can't close (%s): errno %d\n", new_name, errno); + + if (stat (new_name, &stat_buf) == -1) + fatal ("Can't stat (%s): errno %d\n", new_name, errno); + + n = umask (777); + umask (n); + stat_buf.st_mode |= 0111 & ~n; + if (chmod (new_name, stat_buf.st_mode) == -1) + fatal ("Can't chmod (%s): errno %d\n", new_name, errno); +} +/* All of the above is from the emacs-20.7 file. This comment and the + following are added for gcl. Also we changed the above (near "for + gcl") we make the NEW_SECTION_H executable since it will have code + in it. NEW_SECTION_H (nn).sh_flags |= SHF_EXECINSTR; + + Partly synchronized with Emacs HEAD of 2004-04-12 by Magnus Henoch. + The files themselves are no longer mmap'ed, but memory is allocated + with mmap, and everything is written to the new file at the end. +*/ +#ifdef UNIXSAVE +#include "save.c" +#endif diff --git a/o/unexelfsgi.c b/o/unexelfsgi.c new file mode 100755 index 0000000..24c01d2 --- /dev/null +++ b/o/unexelfsgi.c @@ -0,0 +1,861 @@ +/* Copyright (C) 1985, 1986, 1987, 1988, 1990, 1992 + Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +In other words, you are welcome to use, share and improve this program. +You are forbidden to forbid anyone else to use, share and improve +what you give them. Help stamp out software-hoarding! */ + + +/* + * unexec.c - Convert a running program into an a.out file. + * + * Author: Spencer W. Thomas + * Computer Science Dept. + * University of Utah + * Date: Tue Mar 2 1982 + * Modified heavily since then. + * + * Synopsis: + * unexec (new_name, a_name, data_start, bss_start, entry_address) + * char *new_name, *a_name; + * unsigned data_start, bss_start, entry_address; + * + * Takes a snapshot of the program and makes an a.out format file in the + * file named by the string argument new_name. + * If a_name is non-NULL, the symbol table will be taken from the given file. + * On some machines, an existing a_name file is required. + * + * The boundaries within the a.out file may be adjusted with the data_start + * and bss_start arguments. Either or both may be given as 0 for defaults. + * + * Data_start gives the boundary between the text segment and the data + * segment of the program. The text segment can contain shared, read-only + * program code and literal data, while the data segment is always unshared + * and unprotected. Data_start gives the lowest unprotected address. + * The value you specify may be rounded down to a suitable boundary + * as required by the machine you are using. + * + * Specifying zero for data_start means the boundary between text and data + * should not be the same as when the program was loaded. + * If NO_REMAP is defined, the argument data_start is ignored and the + * segment boundaries are never changed. + * + * Bss_start indicates how much of the data segment is to be saved in the + * a.out file and restored when the program is executed. It gives the lowest + * unsaved address, and is rounded up to a page boundary. The default when 0 + * is given assumes that the entire data segment is to be stored, including + * the previous data and bss as well as any additional storage allocated with + * break (2). + * + * The new file is set up to start at entry_address. + * + * If you make improvements I'd like to get them too. + * harpo!utah-cs!thomas, thomas@Utah-20 + * + */ + +/* Even more heavily modified by james@bigtex.cactus.org of Dell Computer Co. + * ELF support added. + * + * Basic theory: the data space of the running process needs to be + * dumped to the output file. Normally we would just enlarge the size + * of .data, scooting everything down. But we can't do that in ELF, + * because there is often something between the .data space and the + * .bss space. + * + * In the temacs dump below, notice that the Global Offset Table + * (.got) and the Dynamic link data (.dynamic) come between .data1 and + * .bss. It does not work to overlap .data with these fields. + * + * The solution is to create a new .data segment. This segment is + * filled with data from the current process. Since the contents of + * various sections refer to sections by index, the new .data segment + * is made the last in the table to avoid changing any existing index. + + * This is an example of how the section headers are changed. "Addr" + * is a process virtual address. "Offset" is a file offset. + +raid:/nfs/raid/src/dist-18.56/src> dump -h temacs + +temacs: + + **** SECTION HEADER TABLE **** +[No] Type Flags Addr Offset Size Name + Link Info Adralgn Entsize + +[1] 1 2 0x80480d4 0xd4 0x13 .interp + 0 0 0x1 0 + +[2] 5 2 0x80480e8 0xe8 0x388 .hash + 3 0 0x4 0x4 + +[3] 11 2 0x8048470 0x470 0x7f0 .dynsym + 4 1 0x4 0x10 + +[4] 3 2 0x8048c60 0xc60 0x3ad .dynstr + 0 0 0x1 0 + +[5] 9 2 0x8049010 0x1010 0x338 .rel.plt + 3 7 0x4 0x8 + +[6] 1 6 0x8049348 0x1348 0x3 .init + 0 0 0x4 0 + +[7] 1 6 0x804934c 0x134c 0x680 .plt + 0 0 0x4 0x4 + +[8] 1 6 0x80499cc 0x19cc 0x3c56f .text + 0 0 0x4 0 + +[9] 1 6 0x8085f3c 0x3df3c 0x3 .fini + 0 0 0x4 0 + +[10] 1 2 0x8085f40 0x3df40 0x69c .rodata + 0 0 0x4 0 + +[11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1 + 0 0 0x4 0 + +[12] 1 3 0x8088330 0x3f330 0x20afc .data + 0 0 0x4 0 + +[13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1 + 0 0 0x4 0 + +[14] 1 3 0x80a96cc 0x606cc 0x1a8 .got + 0 0 0x4 0x4 + +[15] 6 3 0x80a9874 0x60874 0x80 .dynamic + 4 0 0x4 0x8 + +[16] 8 3 0x80a98f4 0x608f4 0x449c .bss + 0 0 0x4 0 + +[17] 2 0 0 0x608f4 0x9b90 .symtab + 18 371 0x4 0x10 + +[18] 3 0 0 0x6a484 0x8526 .strtab + 0 0 0x1 0 + +[19] 3 0 0 0x729aa 0x93 .shstrtab + 0 0 0x1 0 + +[20] 1 0 0 0x72a3d 0x68b7 .comment + 0 0 0x1 0 + +raid:/nfs/raid/src/dist-18.56/src> dump -h xemacs + +xemacs: + + **** SECTION HEADER TABLE **** +[No] Type Flags Addr Offset Size Name + Link Info Adralgn Entsize + +[1] 1 2 0x80480d4 0xd4 0x13 .interp + 0 0 0x1 0 + +[2] 5 2 0x80480e8 0xe8 0x388 .hash + 3 0 0x4 0x4 + +[3] 11 2 0x8048470 0x470 0x7f0 .dynsym + 4 1 0x4 0x10 + +[4] 3 2 0x8048c60 0xc60 0x3ad .dynstr + 0 0 0x1 0 + +[5] 9 2 0x8049010 0x1010 0x338 .rel.plt + 3 7 0x4 0x8 + +[6] 1 6 0x8049348 0x1348 0x3 .init + 0 0 0x4 0 + +[7] 1 6 0x804934c 0x134c 0x680 .plt + 0 0 0x4 0x4 + +[8] 1 6 0x80499cc 0x19cc 0x3c56f .text + 0 0 0x4 0 + +[9] 1 6 0x8085f3c 0x3df3c 0x3 .fini + 0 0 0x4 0 + +[10] 1 2 0x8085f40 0x3df40 0x69c .rodata + 0 0 0x4 0 + +[11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1 + 0 0 0x4 0 + +[12] 1 3 0x8088330 0x3f330 0x20afc .data + 0 0 0x4 0 + +[13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1 + 0 0 0x4 0 + +[14] 1 3 0x80a96cc 0x606cc 0x1a8 .got + 0 0 0x4 0x4 + +[15] 6 3 0x80a9874 0x60874 0x80 .dynamic + 4 0 0x4 0x8 + +[16] 8 3 0x80c6800 0x7d800 0 .bss + 0 0 0x4 0 + +[17] 2 0 0 0x7d800 0x9b90 .symtab + 18 371 0x4 0x10 + +[18] 3 0 0 0x87390 0x8526 .strtab + 0 0 0x1 0 + +[19] 3 0 0 0x8f8b6 0x93 .shstrtab + 0 0 0x1 0 + +[20] 1 0 0 0x8f949 0x68b7 .comment + 0 0 0x1 0 + +[21] 1 3 0x80a98f4 0x608f4 0x1cf0c .data + 0 0 0x4 0 + + * This is an example of how the file header is changed. "Shoff" is + * the section header offset within the file. Since that table is + * after the new .data section, it is moved. "Shnum" is the number of + * sections, which we increment. + * + * "Phoff" is the file offset to the program header. "Phentsize" and + * "Shentsz" are the program and section header entries sizes respectively. + * These can be larger than the apparent struct sizes. + +raid:/nfs/raid/src/dist-18.56/src> dump -f temacs + +temacs: + + **** ELF HEADER **** +Class Data Type Machine Version +Entry Phoff Shoff Flags Ehsize +Phentsize Phnum Shentsz Shnum Shstrndx + +1 1 2 3 1 +0x80499cc 0x34 0x792f4 0 0x34 +0x20 5 0x28 21 19 + +raid:/nfs/raid/src/dist-18.56/src> dump -f xemacs + +xemacs: + + **** ELF HEADER **** +Class Data Type Machine Version +Entry Phoff Shoff Flags Ehsize +Phentsize Phnum Shentsz Shnum Shstrndx + +1 1 2 3 1 +0x80499cc 0x34 0x96200 0 0x34 +0x20 5 0x28 22 19 + + * These are the program headers. "Offset" is the file offset to the + * segment. "Vaddr" is the memory load address. "Filesz" is the + * segment size as it appears in the file, and "Memsz" is the size in + * memory. Below, the third segment is the code and the fourth is the + * data: the difference between Filesz and Memsz is .bss + +raid:/nfs/raid/src/dist-18.56/src> dump -o temacs + +temacs: + ***** PROGRAM EXECUTION HEADER ***** +Type Offset Vaddr Paddr +Filesz Memsz Flags Align + +6 0x34 0x8048034 0 +0xa0 0xa0 5 0 + +3 0xd4 0 0 +0x13 0 4 0 + +1 0x34 0x8048034 0 +0x3f2f9 0x3f2f9 5 0x1000 + +1 0x3f330 0x8088330 0 +0x215c4 0x25a60 7 0x1000 + +2 0x60874 0x80a9874 0 +0x80 0 7 0 + +raid:/nfs/raid/src/dist-18.56/src> dump -o xemacs + +xemacs: + ***** PROGRAM EXECUTION HEADER ***** +Type Offset Vaddr Paddr +Filesz Memsz Flags Align + +6 0x34 0x8048034 0 +0xa0 0xa0 5 0 + +3 0xd4 0 0 +0x13 0 4 0 + +1 0x34 0x8048034 0 +0x3f2f9 0x3f2f9 5 0x1000 + +1 0x3f330 0x8088330 0 +0x3e4d0 0x3e4d0 7 0x1000 + +2 0x60874 0x80a9874 0 +0x80 0 7 0 + + + */ + +/* Modified by wtien@urbana.mcd.mot.com of Motorola Inc. + * + * The above mechanism does not work if the unexeced ELF file is being + * re-layout by other applications (such as `strip'). All the applications + * that re-layout the internal of ELF will layout all sections in ascending + * order of their file offsets. After the re-layout, the data2 section will + * still be the LAST section in the section header vector, but its file offset + * is now being pushed far away down, and causes part of it not to be mapped + * in (ie. not covered by the load segment entry in PHDR vector), therefore + * causes the new binary to fail. + * + * The solution is to modify the unexec algorithm to insert the new data2 + * section header right before the new bss section header, so their file + * offsets will be in the ascending order. Since some of the section's (all + * sections AFTER the bss section) indexes are now changed, we also need to + * modify some fields to make them point to the right sections. This is done + * by macro PATCH_INDEX. All the fields that need to be patched are: + * + * 1. ELF header e_shstrndx field. + * 2. section header sh_link and sh_info field. + * 3. symbol table entry st_shndx field. + * + * The above example now should look like: + + **** SECTION HEADER TABLE **** +[No] Type Flags Addr Offset Size Name + Link Info Adralgn Entsize + +[1] 1 2 0x80480d4 0xd4 0x13 .interp + 0 0 0x1 0 + +[2] 5 2 0x80480e8 0xe8 0x388 .hash + 3 0 0x4 0x4 + +[3] 11 2 0x8048470 0x470 0x7f0 .dynsym + 4 1 0x4 0x10 + +[4] 3 2 0x8048c60 0xc60 0x3ad .dynstr + 0 0 0x1 0 + +[5] 9 2 0x8049010 0x1010 0x338 .rel.plt + 3 7 0x4 0x8 + +[6] 1 6 0x8049348 0x1348 0x3 .init + 0 0 0x4 0 + +[7] 1 6 0x804934c 0x134c 0x680 .plt + 0 0 0x4 0x4 + +[8] 1 6 0x80499cc 0x19cc 0x3c56f .text + 0 0 0x4 0 + +[9] 1 6 0x8085f3c 0x3df3c 0x3 .fini + 0 0 0x4 0 + +[10] 1 2 0x8085f40 0x3df40 0x69c .rodata + 0 0 0x4 0 + +[11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1 + 0 0 0x4 0 + +[12] 1 3 0x8088330 0x3f330 0x20afc .data + 0 0 0x4 0 + +[13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1 + 0 0 0x4 0 + +[14] 1 3 0x80a96cc 0x606cc 0x1a8 .got + 0 0 0x4 0x4 + +[15] 6 3 0x80a9874 0x60874 0x80 .dynamic + 4 0 0x4 0x8 + +[16] 1 3 0x80a98f4 0x608f4 0x1cf0c .data + 0 0 0x4 0 + +[17] 8 3 0x80c6800 0x7d800 0 .bss + 0 0 0x4 0 + +[18] 2 0 0 0x7d800 0x9b90 .symtab + 19 371 0x4 0x10 + +[19] 3 0 0 0x87390 0x8526 .strtab + 0 0 0x1 0 + +[20] 3 0 0 0x8f8b6 0x93 .shstrtab + 0 0 0x1 0 + +[21] 1 0 0 0x8f949 0x68b7 .comment + 0 0 0x1 0 + + */ + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include /* for HDRR declaration */ +#include + +#ifndef emacs +#define fatal(a, b, c) fprintf(stderr, a, b, c), exit(1) +#else +fatal() +{exit(1);} +#endif + +/* Get the address of a particular section or program header entry, + * accounting for the size of the entries. + */ + +#define OLD_SECTION_H(n) \ + (*(Elf32_Shdr *) ((byte *) old_section_h + old_file_h->e_shentsize * (n))) +#define NEW_SECTION_H(n) \ + (*(Elf32_Shdr *) ((byte *) new_section_h + new_file_h->e_shentsize * (n))) +#define OLD_PROGRAM_H(n) \ + (*(Elf32_Phdr *) ((byte *) old_program_h + old_file_h->e_phentsize * (n))) +#define NEW_PROGRAM_H(n) \ + (*(Elf32_Phdr *) ((byte *) new_program_h + new_file_h->e_phentsize * (n))) + +#define PATCH_INDEX(n) \ + do { \ + if ((n) >= old_bss_index) \ + (n)++; } while (0) +typedef unsigned char byte; + +/* Round X up to a multiple of Y. */ + +int +round_up (x, y) + int x, y; +{ + int rem = x % y; + if (rem == 0) + return x; + return x - rem + y; +} + +/* **************************************************************** + * unexec + * + * driving logic. + * + * In ELF, this works by replacing the old .bss section with a new + * .data section, and inserting an empty .bss immediately afterwards. + * + */ +void +unexec (new_name, old_name, data_start, bss_start, entry_address) + char *new_name, *old_name; + unsigned data_start, bss_start, entry_address; +{ +/* extern unsigned int bss_end; */ + int new_file, old_file, new_file_size; + + /* Pointers to the base of the image of the two files. */ + caddr_t old_base, new_base; + + /* Pointers to the file, program and section headers for the old and new + files. */ + Elf32_Ehdr *old_file_h, *new_file_h; + Elf32_Phdr *old_program_h, *new_program_h; + Elf32_Shdr *old_section_h, *new_section_h; + + /* Point to the section name table in the old file. */ + char *old_section_names; + + Elf32_Addr old_bss_addr, new_bss_addr; + Elf32_Word old_bss_size, new_data2_size; + Elf32_Off new_data2_offset; + Elf32_Addr new_data2_addr; + + int n, nn, old_bss_index, old_data_index, new_data2_index; + int old_mdebug_index; + struct stat stat_buf; + + /* Open the old file & map it into the address space. */ + + old_file = open (old_name, O_RDONLY); + + if (old_file < 0) + fatal ("Can't open %s for reading: errno %d\n", old_name, errno); + + if (fstat (old_file, &stat_buf) == -1) + fatal ("Can't fstat(%s): errno %d\n", old_name, errno); + + old_base = mmap (0, stat_buf.st_size, PROT_READ, MAP_SHARED, old_file, 0); + + if (old_base == (caddr_t) -1) + fatal ("Can't mmap(%s): errno %d\n", old_name, errno); + +#ifdef DEBUG + fprintf (stderr, "mmap(%s, %x) -> %x\n", old_name, stat_buf.st_size, + old_base); +#endif + + /* Get pointers to headers & section names. */ + + old_file_h = (Elf32_Ehdr *) old_base; + old_program_h = (Elf32_Phdr *) ((byte *) old_base + old_file_h->e_phoff); + old_section_h = (Elf32_Shdr *) ((byte *) old_base + old_file_h->e_shoff); + old_section_names + = (char *) old_base + OLD_SECTION_H (old_file_h->e_shstrndx).sh_offset; + + /* Find the mdebug section, if any. */ + for (old_mdebug_index = 1; old_mdebug_index < old_file_h->e_shnum; old_mdebug_index++) + { +#ifdef DEBUG + fprintf (stderr, "Looking for .mdebug - found %s\n", + old_section_names + OLD_SECTION_H(old_mdebug_index).sh_name); +#endif + if (!strcmp (old_section_names + OLD_SECTION_H(old_mdebug_index).sh_name, + ".mdebug")) + break; + } + if (old_mdebug_index == old_file_h->e_shnum) + old_mdebug_index = -1; /* just means no such section was present */ + + /* Find the old .bss section. Figure out parameters of the new + data2 and bss sections. */ + + for (old_bss_index = 1; old_bss_index < old_file_h->e_shnum; old_bss_index++) + { +#ifdef DEBUG + fprintf (stderr, "Looking for .bss - found %s\n", + old_section_names + OLD_SECTION_H(old_bss_index).sh_name); +#endif + if (!strcmp (old_section_names + OLD_SECTION_H(old_bss_index).sh_name, + ".bss")) + break; + } + if (old_bss_index == old_file_h->e_shnum) + fatal ("Can't find .bss in %s.\n", old_name, 0); + + old_bss_addr = OLD_SECTION_H (old_bss_index).sh_addr; + old_bss_size = OLD_SECTION_H (old_bss_index).sh_size; +#if defined(emacs) || !defined(DEBUG) + bss_end = (unsigned int) sbrk (0); + new_bss_addr = (Elf32_Addr) bss_end; +#else + new_bss_addr = old_bss_addr + old_bss_size + 0x1234; +#endif + new_data2_addr = old_bss_addr; + new_data2_size = new_bss_addr - old_bss_addr; + new_data2_offset = OLD_SECTION_H (old_bss_index).sh_offset; + +#ifdef DEBUG + fprintf (stderr, "old_bss_index %d\n", old_bss_index); + fprintf (stderr, "old_bss_addr %x\n", old_bss_addr); + fprintf (stderr, "old_bss_size %x\n", old_bss_size); + fprintf (stderr, "new_bss_addr %x\n", new_bss_addr); + fprintf (stderr, "new_data2_addr %x\n", new_data2_addr); + fprintf (stderr, "new_data2_size %x\n", new_data2_size); + fprintf (stderr, "new_data2_offset %x\n", new_data2_offset); +#endif + + if ((unsigned) new_bss_addr < (unsigned) old_bss_addr + old_bss_size) + fatal (".bss shrank when undumping???\n", 0, 0); + + /* Set the output file to the right size and mmap it. Set + pointers to various interesting objects. stat_buf still has + old_file data. */ + + new_file = open (new_name, O_RDWR | O_CREAT, 0666); + if (new_file < 0) + fatal ("Can't creat (%s): errno %d\n", new_name, errno); + + new_file_size = stat_buf.st_size + old_file_h->e_shentsize + new_data2_size; + + if (ftruncate (new_file, new_file_size)) + fatal ("Can't ftruncate (%s): errno %d\n", new_name, errno); + + new_base = mmap (0, new_file_size, PROT_READ | PROT_WRITE, MAP_SHARED, + new_file, 0); + + if (new_base == (caddr_t) -1) + fatal ("Can't mmap (%s): errno %d\n", new_name, errno); + + new_file_h = (Elf32_Ehdr *) new_base; + new_program_h = (Elf32_Phdr *) ((byte *) new_base + old_file_h->e_phoff); + new_section_h + = (Elf32_Shdr *) ((byte *) new_base + old_file_h->e_shoff + + new_data2_size); + + /* Make our new file, program and section headers as copies of the + originals. */ + + memcpy (new_file_h, old_file_h, old_file_h->e_ehsize); + memcpy (new_program_h, old_program_h, + old_file_h->e_phnum * old_file_h->e_phentsize); + + /* Modify the e_shstrndx if necessary. */ + PATCH_INDEX (new_file_h->e_shstrndx); + + /* Fix up file header. We'll add one section. Section header is + further away now. */ + + new_file_h->e_shoff += new_data2_size; + new_file_h->e_shnum += 1; + +#ifdef DEBUG + fprintf (stderr, "Old section offset %x\n", old_file_h->e_shoff); + fprintf (stderr, "Old section count %d\n", old_file_h->e_shnum); + fprintf (stderr, "New section offset %x\n", new_file_h->e_shoff); + fprintf (stderr, "New section count %d\n", new_file_h->e_shnum); +#endif + + /* Fix up a new program header. Extend the writable data segment so + that the bss area is covered too. Find that segment by looking + for a segment that ends just before the .bss area. Make sure + that no segments are above the new .data2. Put a loop at the end + to adjust the offset and address of any segment that is above + data2, just in case we decide to allow this later. */ + + for (n = new_file_h->e_phnum - 1; n >= 0; n--) + { + /* Compute maximum of all requirements for alignment of section. */ + int alignment = (NEW_PROGRAM_H (n)).p_align; + if ((OLD_SECTION_H (old_bss_index)).sh_addralign > alignment) + alignment = OLD_SECTION_H (old_bss_index).sh_addralign; + + /* Supposedly this condition is okay for the SGI. */ +#if 0 + if (NEW_PROGRAM_H (n).p_vaddr + NEW_PROGRAM_H (n).p_filesz > old_bss_addr) + fatal ("Program segment above .bss in %s\n", old_name, 0); +#endif + + if (NEW_PROGRAM_H (n).p_type == PT_LOAD + && (round_up ((NEW_PROGRAM_H (n)).p_vaddr + + (NEW_PROGRAM_H (n)).p_filesz, + alignment) + == round_up (old_bss_addr, alignment))) + break; + } + if (n < 0) + fatal ("Couldn't find segment next to .bss in %s\n", old_name, 0); + + NEW_PROGRAM_H (n).p_filesz += new_data2_size; + NEW_PROGRAM_H (n).p_memsz = NEW_PROGRAM_H (n).p_filesz; + +#if 1 /* Maybe allow section after data2 - does this ever happen? */ + for (n = new_file_h->e_phnum - 1; n >= 0; n--) + { + if (NEW_PROGRAM_H (n).p_vaddr + && NEW_PROGRAM_H (n).p_vaddr >= new_data2_addr) + NEW_PROGRAM_H (n).p_vaddr += new_data2_size - old_bss_size; + + if (NEW_PROGRAM_H (n).p_offset >= new_data2_offset) + NEW_PROGRAM_H (n).p_offset += new_data2_size; + } +#endif + + /* Fix up section headers based on new .data2 section. Any section + whose offset or virtual address is after the new .data2 section + gets its value adjusted. .bss size becomes zero and new address + is set. data2 section header gets added by copying the existing + .data header and modifying the offset, address and size. */ + for (old_data_index = 1; old_data_index < old_file_h->e_shnum; + old_data_index++) + if (!strcmp (old_section_names + OLD_SECTION_H (old_data_index).sh_name, + ".data")) + break; + if (old_data_index == old_file_h->e_shnum) + fatal ("Can't find .data in %s.\n", old_name, 0); + + /* Walk through all section headers, insert the new data2 section right + before the new bss section. */ + for (n = 1, nn = 1; n < old_file_h->e_shnum; n++, nn++) + { + caddr_t src; + /* If it is bss section, insert the new data2 section before it. */ + if (n == old_bss_index) + { + /* Steal the data section header for this data2 section. */ + memcpy (&NEW_SECTION_H (nn), &OLD_SECTION_H (old_data_index), + new_file_h->e_shentsize); + + NEW_SECTION_H (nn).sh_addr = new_data2_addr; + NEW_SECTION_H (nn).sh_offset = new_data2_offset; + NEW_SECTION_H (nn).sh_size = new_data2_size; + /* Use the bss section's alignment. This will assure that the + new data2 section always be placed in the same spot as the old + bss section by any other application. */ + NEW_SECTION_H (nn).sh_addralign = OLD_SECTION_H (n).sh_addralign; + + /* Now copy over what we have in the memory now. */ + memcpy (NEW_SECTION_H (nn).sh_offset + new_base, + (caddr_t) OLD_SECTION_H (n).sh_addr, + new_data2_size); + nn++; + } + + memcpy (&NEW_SECTION_H (nn), &OLD_SECTION_H (n), + old_file_h->e_shentsize); + + /* The new bss section's size is zero, and its file offset and virtual + address should be off by NEW_DATA2_SIZE. */ + if (n == old_bss_index) + { + /* NN should be `old_bss_index + 1' at this point. */ + NEW_SECTION_H (nn).sh_offset += new_data2_size; + NEW_SECTION_H (nn).sh_addr += new_data2_size; + /* Let the new bss section address alignment be the same as the + section address alignment followed the old bss section, so + this section will be placed in exactly the same place. */ + NEW_SECTION_H (nn).sh_addralign = OLD_SECTION_H (nn).sh_addralign; + NEW_SECTION_H (nn).sh_size = 0; + } + /* Any section that was original placed AFTER the bss section should now + be off by NEW_DATA2_SIZE. */ + else if (NEW_SECTION_H (nn).sh_offset >= new_data2_offset) + NEW_SECTION_H (nn).sh_offset += new_data2_size; + + /* If any section hdr refers to the section after the new .data + section, make it refer to next one because we have inserted + a new section in between. */ + + PATCH_INDEX (NEW_SECTION_H (nn).sh_link); + /* For symbol tables, info is a symbol table index, + so don't change it. */ + if (NEW_SECTION_H (nn).sh_type != SHT_SYMTAB + && NEW_SECTION_H (nn).sh_type != SHT_DYNSYM) + PATCH_INDEX (NEW_SECTION_H (nn).sh_info); + + /* Now, start to copy the content of sections. */ + if (NEW_SECTION_H (nn).sh_type == SHT_NULL + || NEW_SECTION_H (nn).sh_type == SHT_NOBITS) + continue; + + /* Write out the sections. .data and .data1 (and data2, called + ".data" in the strings table) get copied from the current process + instead of the old file. */ + if (!strcmp (old_section_names + NEW_SECTION_H (n).sh_name, ".data") + || !strcmp ((old_section_names + NEW_SECTION_H (n).sh_name), + ".data1")) + src = (caddr_t) OLD_SECTION_H (n).sh_addr; + else + src = old_base + OLD_SECTION_H (n).sh_offset; + + memcpy (NEW_SECTION_H (nn).sh_offset + new_base, src, + NEW_SECTION_H (nn).sh_size); + + /* Adjust the HDRR offsets in .mdebug and copy the + line data if it's in its usual 'hole' in the object. + Makes the new file debuggable with dbx. + patches up two problems: the absolute file offsets + in the HDRR record of .mdebug (see /usr/include/syms.h), and + the ld bug that gets the line table in a hole in the + elf file rather than in the .mdebug section proper. + David Anderson. davea@sgi.com Jan 16,1994. */ + if (n == old_mdebug_index) + { +#define MDEBUGADJUST(__ct,__fileaddr) \ + if (n_phdrr->__ct > 0) \ + { \ + n_phdrr->__fileaddr += movement; \ + } + + HDRR * o_phdrr = (HDRR *)((byte *)old_base + OLD_SECTION_H (n).sh_offset); + HDRR * n_phdrr = (HDRR *)((byte *)new_base + NEW_SECTION_H (nn).sh_offset); + unsigned movement = new_data2_size; + + MDEBUGADJUST (idnMax, cbDnOffset); + MDEBUGADJUST (ipdMax, cbPdOffset); + MDEBUGADJUST (isymMax, cbSymOffset); + MDEBUGADJUST (ioptMax, cbOptOffset); + MDEBUGADJUST (iauxMax, cbAuxOffset); + MDEBUGADJUST (issMax, cbSsOffset); + MDEBUGADJUST (issExtMax, cbSsExtOffset); + MDEBUGADJUST (ifdMax, cbFdOffset); + MDEBUGADJUST (crfd, cbRfdOffset); + MDEBUGADJUST (iextMax, cbExtOffset); + /* The Line Section, being possible off in a hole of the object, + requires special handling. */ + if (n_phdrr->cbLine > 0) + { + if (o_phdrr->cbLineOffset > (OLD_SECTION_H (n).sh_offset + + OLD_SECTION_H (n).sh_size)) + { + /* line data is in a hole in elf. do special copy and adjust + for this ld mistake. + */ + n_phdrr->cbLineOffset += movement; + + memcpy (n_phdrr->cbLineOffset + new_base, + o_phdrr->cbLineOffset + old_base, n_phdrr->cbLine); + } + else + { + /* somehow line data is in .mdebug as it is supposed to be. */ + MDEBUGADJUST (cbLine, cbLineOffset); + } + } + } + + /* If it is the symbol table, its st_shndx field needs to be patched. */ + if (NEW_SECTION_H (nn).sh_type == SHT_SYMTAB + || NEW_SECTION_H (nn).sh_type == SHT_DYNSYM) + { + Elf32_Shdr *spt = &NEW_SECTION_H (nn); + unsigned int num = spt->sh_size / spt->sh_entsize; + Elf32_Sym * sym = (Elf32_Sym *) (NEW_SECTION_H (nn).sh_offset + + new_base); + for (; num--; sym++) + { + if (sym->st_shndx == SHN_UNDEF + || sym->st_shndx == SHN_ABS + || sym->st_shndx == SHN_COMMON) + continue; + + PATCH_INDEX (sym->st_shndx); + } + } + } + + /* Close the files and make the new file executable. */ + + if (close (old_file)) + fatal ("Can't close (%s): errno %d\n", old_name, errno); + + if (close (new_file)) + fatal ("Can't close (%s): errno %d\n", new_name, errno); + + if (stat (new_name, &stat_buf) == -1) + fatal ("Can't stat (%s): errno %d\n", new_name, errno); + + n = umask (777); + umask (n); + stat_buf.st_mode |= 0111 & ~n; + if (chmod (new_name, stat_buf.st_mode) == -1) + fatal ("Can't chmod (%s): errno %d\n", new_name, errno); +} + + + +#ifdef UNIXSAVE +#include "save.c" +#endif diff --git a/o/unexhp9k800.c b/o/unexhp9k800.c new file mode 100755 index 0000000..1d974b7 --- /dev/null +++ b/o/unexhp9k800.c @@ -0,0 +1,310 @@ +/* Unexec for HP 9000 Series 800 machines. + Bob Desinger + + Note that the GNU project considers support for HP operation a + peripheral activity which should not be allowed to divert effort + from development of the GNU system. Changes in this code will be + installed when users send them in, but aside from that we don't + plan to think about it, or about whether other Emacs maintenance + might break it. + + + Unexec creates a copy of the old a.out file, and replaces the old data + area with the current data area. When the new file is executed, the + process will see the same data structures and data values that the + original process had when unexec was called. + + Unlike other versions of unexec, this one copies symbol table and + debug information to the new a.out file. Thus, the new a.out file + may be debugged with symbolic debuggers. + + If you fix any bugs in this, I'd like to incorporate your fixes. + Send them to uunet!hpda!hpsemc!jmorris or jmorris%hpsemc@hplabs.HP.COM. + + CAVEATS: + This routine saves the current value of all static and external + variables. This means that any data structure that needs to be + initialized must be explicitly reset. Variables will not have their + expected default values. + + Unfortunately, the HP-UX signal handler has internal initialization + flags which are not explicitly reset. Thus, for signals to work in + conjunction with this routine, the following code must executed when + the new process starts up. + + void _sigreturn(); + ... + sigsetreturn(_sigreturn); +*/ + +#include +#include +#include + +#include + +#define NBPG 2048 +#define roundup(x,n) ( ( (x)+(n-1) ) & ~(n-1) ) /* n is power of 2 */ +#define min(x,y) ( ((x)<(y))?(x):(y) ) + + +/* Create a new a.out file, same as old but with current data space */ + +unexec(new_name, old_name, new_end_of_text, dummy1, dummy2) + char new_name[]; /* name of the new a.out file to be created */ + char old_name[]; /* name of the old a.out file */ + char *new_end_of_text; /* ptr to new edata/etext; NOT USED YET */ + int dummy1, dummy2; /* not used by emacs */ +{ + int old, new; + int old_size, new_size; + struct header hdr; + struct som_exec_auxhdr auxhdr; + char stdin_buf[BUFSIZ],stdout_buf[BUFSIZ]; + FILE *original,*tem; + + /* For the greatest flexibility, should create a temporary file in + the same directory as the new file. When everything is complete, + rename the temp file to the new name. + This way, a program could update its own a.out file even while + it is still executing. If problems occur, everything is still + intact. NOT implemented. */ + + /* Open the input and output a.out files */ + _cleanup(); + fclose(stdin); + old = open(old_name, O_RDONLY); + if (old < 0) + { perror(old_name); exit(1); } + if ( old < 0) + {perror("can't open in"); exit(1);} + printf("(%d = old) \n",old); + tem = fdopen(old,"r"); + setbuf(tem,stdin_buf); + fflush(stdout); + fclose(stdout); + new = open(new_name, O_CREAT|O_RDWR|O_TRUNC, 0777); + if (new < 0) + { perror(new_name); exit(1); } + tem = fdopen(new,"w"); + setbuf(tem,stdout_buf); + /* Read the old headers */ + read_header(old, &hdr, &auxhdr); + + /* Decide how large the new and old data areas are */ + old_size = auxhdr.exec_dsize; + new_size = (int)sbrk(0) - auxhdr.exec_dmem; + + /* Copy the old file to the new, up to the data space */ + lseek(old, 0, 0); + copy_file(old, new, auxhdr.exec_dfile); + + /* Skip the old data segment and write a new one */ + lseek(old, old_size, 1); + + save_data_space(new, &hdr, &auxhdr, new_size); + + /* Copy the rest of the file */ + copy_rest(old, new); + + /* Update file pointers since we probably changed size of data area */ + update_file_ptrs(new, &hdr, &auxhdr, auxhdr.exec_dfile, new_size-old_size); + + /* Save the modified header */ + write_header(new, &hdr, &auxhdr); + + /* Close the binary file */ + close(old); + close(new); + exit(0); +} + +/* Save current data space in the file, update header. */ + +save_data_space(file, hdr, auxhdr, size) + int file; + struct header *hdr; + struct som_exec_auxhdr *auxhdr; + int size; +{ + /* Write the entire data space out to the file */ + if (write(file, auxhdr->exec_dmem, size) != size) + { perror("Can't save new data space"); exit(1); } + + /* Update the header to reflect the new data size */ + auxhdr->exec_dsize = size; + auxhdr->exec_bsize = 0; +} + +/* Update the values of file pointers when something is inserted. */ + +update_file_ptrs(file, hdr, auxhdr, location, offset) + int file; + struct header *hdr; + struct som_exec_auxhdr *auxhdr; + unsigned int location; + int offset; +{ + struct subspace_dictionary_record subspace; + int i; + + /* Increase the overall size of the module */ + hdr->som_length += offset; + + /* Update the various file pointers in the header */ +#define update(ptr) if (ptr > location) ptr = ptr + offset + update(hdr->aux_header_location); + update(hdr->space_strings_location); + update(hdr->init_array_location); + update(hdr->compiler_location); + update(hdr->symbol_location); + update(hdr->fixup_request_location); + update(hdr->symbol_strings_location); + update(hdr->unloadable_sp_location); + update(auxhdr->exec_tfile); + update(auxhdr->exec_dfile); + + /* Do for each subspace dictionary entry */ + lseek(file, hdr->subspace_location, 0); + for (i = 0; i < hdr->subspace_total; i++) + { + if (read(file, &subspace, sizeof(subspace)) != sizeof(subspace)) + { perror("Can't read subspace record"); exit(1); } + + /* If subspace has a file location, update it */ + if (subspace.initialization_length > 0 + && subspace.file_loc_init_value > location) + { + subspace.file_loc_init_value += offset; + lseek(file, -sizeof(subspace), 1); + if (write(file, &subspace, sizeof(subspace)) != sizeof(subspace)) + { perror("Can't update subspace record"); exit(1); } + } + } + + /* Do for each initialization pointer record */ + /* (I don't think it applies to executable files, only relocatables) */ +#undef update +} + +/* Read in the header records from an a.out file. */ + +read_header(file, hdr, auxhdr) + int file; + struct header *hdr; + struct som_exec_auxhdr *auxhdr; +{ + + /* Read the header in */ + lseek(file, 0, 0); + if (read(file, hdr, sizeof(*hdr)) != sizeof(*hdr)) + { perror("Couldn't read header from a.out file"); exit(1); } + + if (hdr->a_magic != EXEC_MAGIC && hdr->a_magic != SHARE_MAGIC + && hdr->a_magic != DEMAND_MAGIC) + { + fprintf(stderr, "a.out file doesn't have legal magic number\n"); + exit(1); + } + + lseek(file, hdr->aux_header_location, 0); + if (read(file, auxhdr, sizeof(*auxhdr)) != sizeof(*auxhdr)) + { + perror("Couldn't read auxiliary header from a.out file"); + exit(1); + } +} + +/* Write out the header records into an a.out file. */ + +write_header(file, hdr, auxhdr) + int file; + struct header *hdr; + struct som_exec_auxhdr *auxhdr; +{ + /* Update the checksum */ + hdr->checksum = calculate_checksum(hdr); + + /* Write the header back into the a.out file */ + lseek(file, 0, 0); + if (write(file, hdr, sizeof(*hdr)) != sizeof(*hdr)) + { perror("Couldn't write header to a.out file"); exit(1); } + lseek(file, hdr->aux_header_location, 0); + if (write(file, auxhdr, sizeof(*auxhdr)) != sizeof(*auxhdr)) + { perror("Couldn't write auxiliary header to a.out file"); exit(1); } +} + +/* Calculate the checksum of a SOM header record. */ + +calculate_checksum(hdr) + struct header *hdr; +{ + int checksum, i, *ptr; + + checksum = 0; ptr = (int *) hdr; + + for (i=0; i 0; size -= len) + { + len = min(size, sizeof(buffer)); + if (read(old, buffer, len) != len) + { perror("Read failure on a.out file"); exit(1); } + if (write(new, buffer, len) != len) + { perror("Write failure in a.out file"); exit(1); } + } +} + +/* Copy the rest of the file, up to EOF. */ + +copy_rest(old, new) + int new, old; +{ + int buffer[4096]; + int len; + + /* Copy bytes until end of file or error */ + while ( (len = read(old, buffer, sizeof(buffer))) > 0) + if (write(new, buffer, len) != len) break; + + if (len != 0) + { perror("Unable to copy the rest of the file"); exit(1); } +} + +#ifdef DEBUG +display_header(hdr, auxhdr) + struct header *hdr; + struct som_exec_auxhdr *auxhdr; +{ + /* Display the header information (debug) */ + printf("\n\nFILE HEADER\n"); + printf("magic number %d \n", hdr->a_magic); + printf("text loc %.8x size %d \n", auxhdr->exec_tmem, auxhdr->exec_tsize); + printf("data loc %.8x size %d \n", auxhdr->exec_dmem, auxhdr->exec_dsize); + printf("entry %x \n", auxhdr->exec_entry); + printf("Bss segment size %u\n", auxhdr->exec_bsize); + printf("\n"); + printf("data file loc %d size %d\n", + auxhdr->exec_dfile, auxhdr->exec_dsize); + printf("som_length %d\n", hdr->som_length); + printf("unloadable sploc %d size %d\n", + hdr->unloadable_sp_location, hdr->unloadable_sp_size); +} +#endif /* DEBUG */ + +#ifdef UNIXSAVE +#include "save.c" +#endif diff --git a/o/unexlin.c b/o/unexlin.c new file mode 100755 index 0000000..c8008e2 --- /dev/null +++ b/o/unexlin.c @@ -0,0 +1,969 @@ +/* Copyright (C) 1985, 1986, 1987, 1988 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Library General Public License as published by + the Free Software Foundation; either version 1, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Library General Public License for more details. + + You should have received a copy of the GNU Library General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +In other words, you are welcome to use, share and improve this program. +You are forbidden to forbid anyone else to use, share and improve +what you give them. Help stamp out software-hoarding! */ + +/* MODIFIED by M. Frigo (6 Mar 1993) to work with the linux port + * of akcl-1-615 + */ + +/* + * unexec.c - Convert a running program into an a.out file. + * + * Author: Spencer W. Thomas + * Computer Science Dept. + * University of Utah + * Date: Tue Mar 2 1982 + * Modified heavily since then. + * + * Synopsis: + * unexec (new_name, a_name, data_start, bss_start, entry_address) + * char *new_name, *a_name; + * unsigned data_start, bss_start, entry_address; + * + * Takes a snapshot of the program and makes an a.out format file in the + * file named by the string argument new_name. + * If a_name is non-NULL, the symbol table will be taken from the given file. + * On some machines, an existing a_name file is required. + * + * The boundaries within the a.out file may be adjusted with the data_start + * and bss_start arguments. Either or both may be given as 0 for defaults. + * + * Data_start gives the boundary between the text segment and the data + * segment of the program. The text segment can contain shared, read-only + * program code and literal data, while the data segment is always unshared + * and unprotected. Data_start gives the lowest unprotected address. + * The value you specify may be rounded down to a suitable boundary + * as required by the machine you are using. + * + * Specifying zero for data_start means the boundary between text and data + * should not be the same as when the program was loaded. + * If NO_REMAP is defined, the argument data_start is ignored and the + * segment boundaries are never changed. + * + * Bss_start indicates how much of the data segment is to be saved in the + * a.out file and restored when the program is executed. It gives the lowest + * unsaved address, and is rounded up to a page boundary. The default when 0 + * is given assumes that the entire data segment is to be stored, including + * the previous data and bss as well as any additional storage allocated with + * break (2). + * + * The new file is set up to start at entry_address. + * + * If you make improvements I'd like to get them too. + * harpo!utah-cs!thomas, thomas@Utah-20 + * + */ + +/* Modified to support SysVr3 shared libraries by James Van Artsdalen + * of Dell Computer Corporation. james@bigtex.cactus.org. + */ + +/* There are several compilation parameters affecting unexec: + +* COFF + +Define this if your system uses COFF for executables. +Otherwise we assume you use Berkeley format. + +* NO_REMAP + +Define this if you do not want to try to save Emacs's pure data areas +as part of the text segment. + +Saving them as text is good because it allows users to share more. + +However, on machines that locate the text area far from the data area, +the boundary cannot feasibly be moved. Such machines require +NO_REMAP. + +Also, remapping can cause trouble with the built-in startup routine +/lib/crt0.o, which defines `environ' as an initialized variable. +Dumping `environ' as pure does not work! So, to use remapping, +you must write a startup routine for your machine in Emacs's crt0.c. +If NO_REMAP is defined, Emacs uses the system's crt0.o. + +* SECTION_ALIGNMENT + +Some machines that use COFF executables require that each section +start on a certain boundary *in the COFF file*. Such machines should +define SECTION_ALIGNMENT to a mask of the low-order bits that must be +zero on such a boundary. This mask is used to control padding between +segments in the COFF file. + +If SECTION_ALIGNMENT is not defined, the segments are written +consecutively with no attempt at alignment. This is right for +unmodified system V. + +* SEGMENT_MASK + +Some machines require that the beginnings and ends of segments +*in core* be on certain boundaries. For most machines, a page +boundary is sufficient. That is the default. When a larger +boundary is needed, define SEGMENT_MASK to a mask of +the bits that must be zero on such a boundary. + +* A_TEXT_OFFSET(HDR) + +Some machines count the a.out header as part of the size of the text +segment (a_text); they may actually load the header into core as the +first data in the text segment. Some have additional padding between +the header and the real text of the program that is counted in a_text. + +For these machines, define A_TEXT_OFFSET(HDR) to examine the header +structure HDR and return the number of bytes to add to `a_text' +before writing it (above and beyond the number of bytes of actual +program text). HDR's standard fields are already correct, except that +this adjustment to the `a_text' field has not yet been made; +thus, the amount of offset can depend on the data in the file. + +* A_TEXT_SEEK(HDR) + +If defined, this macro specifies the number of bytes to seek into the +a.out file before starting to write the text segment.a + +* EXEC_MAGIC + +For machines using COFF, this macro, if defined, is a value stored +into the magic number field of the output file. + +* ADJUST_EXEC_HEADER + +This macro can be used to generate statements to adjust or +initialize nonstandard fields in the file header + +* ADDR_CORRECT(ADDR) + +Macro to correct an int which is the bit pattern of a pointer to a byte +into an int which is the number of a byte. + +This macro has a default definition which is usually right. +This default definition is a no-op on most machines (where a +pointer looks like an int) but not on all machines. + +*/ + +#ifndef emacs +#define PERROR(arg) perror (arg); return -1 +#else +#include "config.h" +#define PERROR(file) report_error (file, new) +#endif + +#ifndef CANNOT_DUMP /* all rest of file! */ + +#ifndef CANNOT_UNEXEC /* most of rest of file */ + +#include +/* Define getpagesize () if the system does not. + Note that this may depend on symbols defined in a.out.h + */ + +#ifndef makedev /* Try to detect types.h already loaded */ +#include +#endif +#include +#include +#include + +extern char *start_of_text (); /* Start of text */ +extern char *start_of_data (); /* Start of initialized data */ +#define start_of_data() &etext +#define start_of_text() ( (char *) 0 ) +extern char etext; + +static int make_hdr (int new, int a_out, unsigned int data_start, unsigned int bss_start, unsigned int entry_address, char *a_name, char *new_name), copy_text_and_data (int new, int a_out), copy_sym (int new, int a_out, char *a_name, char *new_name); +static int mark_x (char *name); + +#ifdef COFF +#ifndef USG +#ifndef STRIDE +#ifndef UMAX +#ifndef sun386 +/* I have a suspicion that these are turned off on all systems + and can be deleted. Try it in version 19. */ +#include +#include +#include +#include +#endif /* not sun386 */ +#endif /* not UMAX */ +#endif /* Not STRIDE */ +#endif /* not USG */ +static long block_copy_start; /* Old executable start point */ +static struct filehdr f_hdr; /* File header */ +static struct aouthdr f_ohdr; /* Optional file header (a.out) */ +long bias; /* Bias to add for growth */ +long lnnoptr; /* Pointer to line-number info within file */ +#define SYMS_START block_copy_start + +static long text_scnptr; +static long data_scnptr; + +#else /* not COFF */ + +#define SYMS_START ((long) N_SYMOFF (ohdr)) + +/* Some machines override the structure name for an a.out header. */ +#ifndef EXEC_HDR_TYPE +#define EXEC_HDR_TYPE struct exec +#endif + +#ifdef HPUX +#ifdef HP9000S200_ID +#define MY_ID HP9000S200_ID +#else +#include +#define MY_ID MYSYS +#endif /* no HP9000S200_ID */ +static MAGIC OLDMAGIC = {MY_ID, SHARE_MAGIC}; +static MAGIC NEWMAGIC = {MY_ID, DEMAND_MAGIC}; +#define N_TXTOFF(x) TEXT_OFFSET(x) +#define N_SYMOFF(x) LESYM_OFFSET(x) +static EXEC_HDR_TYPE hdr, ohdr; + +#else /* not HPUX */ + +extern char *sbrk (int n); + +#if defined (USG) && !defined (IBMRTAIX) && !defined (IRIS) && !defined(linux) +static struct bhdr hdr, ohdr; +#define a_magic fmagic +#define a_text tsize +#define a_data dsize +#define a_bss bsize +#define a_syms ssize +#define a_trsize rtsize +#define a_drsize rdsize +#define a_entry entry +#define N_BADMAG(x) \ + (((x).fmagic)!=OMAGIC && ((x).fmagic)!=NMAGIC &&\ + ((x).fmagic)!=FMAGIC && ((x).fmagic)!=IMAGIC) +#define NEWMAGIC FMAGIC +#else /* IRIS or IBMRTAIX or not USG */ +static EXEC_HDR_TYPE hdr, ohdr; +#define NEWMAGIC ZMAGIC +#endif /* IRIS or IBMRTAIX not USG */ +#endif /* not HPUX */ + +static int unexec_text_start; +static int unexec_data_start; + +#endif /* not COFF */ + +static int pagemask; + +/* Correct an int which is the bit pattern of a pointer to a byte + into an int which is the number of a byte. + This is a no-op on ordinary machines, but not on all. */ + +#ifndef ADDR_CORRECT /* Let m-*.h files override this definition */ +#define ADDR_CORRECT(x) ((char *)(x) - (char*)0) +#endif + +#ifdef emacs + +static +report_error (file, fd) + char *file; + int fd; +{ + if (fd) + close (fd); + error ("Failure operating on %s", file); +} +#endif /* emacs */ + +#define ERROR0(msg) report_error_1 (new, msg, 0, 0); return -1 +#define ERROR1(msg,x) report_error_1 (new, msg, x, 0); return -1 +#define ERROR2(msg,x,y) report_error_1 (new, msg, x, y); return -1 + +static +report_error_1 (int fd, char *msg, int a1, int a2) +{ + close (fd); +#ifdef emacs + error (msg, a1, a2); +#else + fprintf (stderr, msg, a1, a2); + fprintf (stderr, "\n"); +#endif +} + +/* **************************************************************** + * unexec + * + * driving logic. + */ +unexec (char *new_name, char *a_name, unsigned int data_start, unsigned int bss_start, unsigned int entry_address) +{ + int new, a_out = -1; + + if (a_name && (a_out = open (a_name, 0)) < 0) + { + PERROR (a_name); + } + if ((new = creat (new_name, 0666)) < 0) + { + PERROR (new_name); + } + + if (make_hdr (new, a_out, data_start, bss_start, entry_address, a_name, new_name) < 0 + || copy_text_and_data (new, a_out) < 0 + || copy_sym (new, a_out, a_name, new_name) < 0 +#ifdef COFF + || adjust_lnnoptrs (new, a_out, new_name) < 0 +#endif + ) + { + close (new); + /* unlink (new_name); /* Failed, unlink new a.out */ + return -1; + } + + close (new); + if (a_out >= 0) + close (a_out); + return mark_x (new_name); +} + +/* **************************************************************** + * make_hdr + * + * Make the header in the new a.out from the header in core. + * Modify the text and data sizes. + */ +static int +make_hdr (int new, int a_out, unsigned int data_start, unsigned int bss_start, unsigned int entry_address, char *a_name, char *new_name) +{ + int tem; +#ifdef COFF + auto struct scnhdr f_thdr; /* Text section header */ + auto struct scnhdr f_dhdr; /* Data section header */ + auto struct scnhdr f_bhdr; /* Bss section header */ + auto struct scnhdr scntemp; /* Temporary section header */ + register int scns; +#endif /* COFF */ +#ifdef USG_SHARED_LIBRARIES + extern unsigned int bss_end; +#else + unsigned int bss_end; +#endif + + pagemask = getpagesize () - 1; + + /* Adjust text/data boundary. */ +#ifdef NO_REMAP + data_start = (int) start_of_data (); +#else /* not NO_REMAP */ + if (!data_start) + data_start = (int) start_of_data (); +#endif /* not NO_REMAP */ + data_start = ADDR_CORRECT (data_start); + +#ifdef SEGMENT_MASK + data_start = data_start & ~SEGMENT_MASK; /* (Down) to segment boundary. */ +#else + data_start = data_start & ~pagemask; /* (Down) to page boundary. */ +#endif + + bss_end = ADDR_CORRECT (sbrk (0)) + pagemask; + bss_end &= ~ pagemask; + + /* Adjust data/bss boundary. */ + if (bss_start != 0) + { + bss_start = (ADDR_CORRECT (bss_start) + pagemask); + /* (Up) to page bdry. */ + bss_start &= ~ pagemask; + if (bss_start > bss_end) + { + ERROR1 ("unexec: Specified bss_start (%u) is past end of program", + bss_start); + } + } + else + bss_start = bss_end; + + if (data_start > bss_start) /* Can't have negative data size. */ + { + ERROR2 ("unexec: data_start (%u) can't be greater than bss_start (%u)", + data_start, bss_start); + } + +#ifdef COFF + /* Salvage as much info from the existing file as possible */ + if (a_out >= 0) + { + if (read (a_out, &f_hdr, sizeof (f_hdr)) != sizeof (f_hdr)) + { + PERROR (a_name); + } + block_copy_start += sizeof (f_hdr); + if (f_hdr.f_opthdr > 0) + { + if (read (a_out, &f_ohdr, sizeof (f_ohdr)) != sizeof (f_ohdr)) + { + PERROR (a_name); + } + block_copy_start += sizeof (f_ohdr); + } + /* Loop through section headers, copying them in */ + for (scns = f_hdr.f_nscns; scns > 0; scns--) { + if (read (a_out, &scntemp, sizeof (scntemp)) != sizeof (scntemp)) + { + PERROR (a_name); + } + if (scntemp.s_scnptr > 0L) + { + if (block_copy_start < scntemp.s_scnptr + scntemp.s_size) + block_copy_start = scntemp.s_scnptr + scntemp.s_size; + } + if (strcmp (scntemp.s_name, ".text") == 0) + { + f_thdr = scntemp; + } + else if (strcmp (scntemp.s_name, ".data") == 0) + { + f_dhdr = scntemp; + } + else if (strcmp (scntemp.s_name, ".bss") == 0) + { + f_bhdr = scntemp; + } + } + } + else + { + ERROR0 ("can't build a COFF file from scratch yet"); + } + + /* Now we alter the contents of all the f_*hdr variables + to correspond to what we want to dump. */ + +#ifdef USG_SHARED_LIBRARIES + + /* The amount of data we're adding to the file is distance from the + * end of the original .data space to the current end of the .data + * space. + */ + + bias = bss_end - (f_ohdr.data_start + f_dhdr.s_size); + +#endif + + f_hdr.f_flags |= (F_RELFLG | F_EXEC); +#ifdef TPIX + f_hdr.f_nscns = 3; +#endif +#ifdef EXEC_MAGIC + f_ohdr.magic = EXEC_MAGIC; +#endif +#ifndef NO_REMAP + f_ohdr.text_start = (long) start_of_text (); + f_ohdr.tsize = data_start - f_ohdr.text_start; + f_ohdr.data_start = data_start; +#endif /* NO_REMAP */ + f_ohdr.dsize = bss_start - f_ohdr.data_start; + f_ohdr.bsize = bss_end - bss_start; + f_thdr.s_size = f_ohdr.tsize; + f_thdr.s_scnptr = sizeof (f_hdr) + sizeof (f_ohdr); + f_thdr.s_scnptr += (f_hdr.f_nscns) * (sizeof (f_thdr)); + lnnoptr = f_thdr.s_lnnoptr; +#ifdef SECTION_ALIGNMENT + /* Some systems require special alignment + of the sections in the file itself. */ + f_thdr.s_scnptr + = (f_thdr.s_scnptr + SECTION_ALIGNMENT) & ~SECTION_ALIGNMENT; +#endif /* SECTION_ALIGNMENT */ +#ifdef TPIX + f_thdr.s_scnptr = 0xd0; +#endif + text_scnptr = f_thdr.s_scnptr; + f_dhdr.s_paddr = f_ohdr.data_start; + f_dhdr.s_vaddr = f_ohdr.data_start; + f_dhdr.s_size = f_ohdr.dsize; + f_dhdr.s_scnptr = f_thdr.s_scnptr + f_thdr.s_size; +#ifdef SECTION_ALIGNMENT + /* Some systems require special alignment + of the sections in the file itself. */ + f_dhdr.s_scnptr + = (f_dhdr.s_scnptr + SECTION_ALIGNMENT) & ~SECTION_ALIGNMENT; +#endif /* SECTION_ALIGNMENT */ +#ifdef DATA_SECTION_ALIGNMENT + /* Some systems require special alignment + of the data section only. */ + f_dhdr.s_scnptr + = (f_dhdr.s_scnptr + DATA_SECTION_ALIGNMENT) & ~DATA_SECTION_ALIGNMENT; +#endif /* DATA_SECTION_ALIGNMENT */ + data_scnptr = f_dhdr.s_scnptr; + f_bhdr.s_paddr = f_ohdr.data_start + f_ohdr.dsize; + f_bhdr.s_vaddr = f_ohdr.data_start + f_ohdr.dsize; + f_bhdr.s_size = f_ohdr.bsize; + f_bhdr.s_scnptr = 0L; +#ifndef USG_SHARED_LIBRARIES + bias = f_dhdr.s_scnptr + f_dhdr.s_size - block_copy_start; +#endif + + if (f_hdr.f_symptr > 0L) + { + f_hdr.f_symptr += bias; + } + + if (f_thdr.s_lnnoptr > 0L) + { + f_thdr.s_lnnoptr += bias; + } + +#ifdef ADJUST_EXEC_HEADER + ADJUST_EXEC_HEADER +#endif /* ADJUST_EXEC_HEADER */ + + if (write (new, &f_hdr, sizeof (f_hdr)) != sizeof (f_hdr)) + { + PERROR (new_name); + } + + if (write (new, &f_ohdr, sizeof (f_ohdr)) != sizeof (f_ohdr)) + { + PERROR (new_name); + } + +#ifndef USG_SHARED_LIBRARIES + + if (write (new, &f_thdr, sizeof (f_thdr)) != sizeof (f_thdr)) + { + PERROR (new_name); + } + + if (write (new, &f_dhdr, sizeof (f_dhdr)) != sizeof (f_dhdr)) + { + PERROR (new_name); + } + + if (write (new, &f_bhdr, sizeof (f_bhdr)) != sizeof (f_bhdr)) + { + PERROR (new_name); + } + +#else /* USG_SHARED_LIBRARIES */ + + /* The purpose of this code is to write out the new file's section + * header table. + * + * Scan through the original file's sections. If the encountered + * section is one we know (.text, .data or .bss), write out the + * correct header. If it is a section we do not know (such as + * .lib), adjust the address of where the section data is in the + * file, and write out the header. + * + * If any section preceeds .text or .data in the file, this code + * will not adjust the file pointer for that section correctly. + */ + + lseek (a_out, sizeof (f_hdr) + sizeof (f_ohdr), 0); + + for (scns = f_hdr.f_nscns; scns > 0; scns--) + { + if (read (a_out, &scntemp, sizeof (scntemp)) != sizeof (scntemp)) + PERROR (a_name); + + if (!strcmp (scntemp.s_name, f_thdr.s_name)) /* .text */ + { + if (write (new, &f_thdr, sizeof (f_thdr)) != sizeof (f_thdr)) + PERROR (new_name); + } + else if (!strcmp (scntemp.s_name, f_dhdr.s_name)) /* .data */ + { + if (write (new, &f_dhdr, sizeof (f_dhdr)) != sizeof (f_dhdr)) + PERROR (new_name); + } + else if (!strcmp (scntemp.s_name, f_bhdr.s_name)) /* .bss */ + { + if (write (new, &f_bhdr, sizeof (f_bhdr)) != sizeof (f_bhdr)) + PERROR (new_name); + } + else + { + if (scntemp.s_scnptr) + scntemp.s_scnptr += bias; + if (write (new, &scntemp, sizeof (scntemp)) != sizeof (scntemp)) + PERROR (new_name); + } + } +#endif /* USG_SHARED_LIBRARIES */ + + return (0); + +#else /* if not COFF */ + + /* Get symbol table info from header of a.out file if given one. */ + if (a_out >= 0) + { + if (read (a_out, &ohdr, sizeof hdr) != sizeof hdr) + { + PERROR (a_name); + } + + if (N_BADMAG (ohdr)) + { + ERROR1 ("invalid magic number in %s", a_name); + } + hdr = ohdr; + } + else + { + bzero (hdr, sizeof hdr); + } + + unexec_text_start = (long) start_of_text (); + unexec_data_start = data_start; + + /* Machine-dependent fixup for header, or maybe for unexec_text_start */ +#ifdef ADJUST_EXEC_HEADER + ADJUST_EXEC_HEADER; +#endif /* ADJUST_EXEC_HEADER */ + + hdr.a_trsize = 0; + hdr.a_drsize = 0; + if (entry_address != 0) + hdr.a_entry = entry_address; + + hdr.a_bss = bss_end - bss_start; + hdr.a_data = bss_start - data_start; +#ifdef NO_REMAP + hdr.a_text = ohdr.a_text; +#else /* not NO_REMAP */ + hdr.a_text = data_start - unexec_text_start; + +#ifdef A_TEXT_OFFSET + hdr.a_text += A_TEXT_OFFSET (ohdr); +#endif + +#endif /* not NO_REMAP */ + + if (write (new, &hdr, sizeof hdr) != sizeof hdr) + { + PERROR (new_name); + } + +#ifdef A_TEXT_OFFSET + hdr.a_text -= A_TEXT_OFFSET (ohdr); +#endif + + return 0; + +#endif /* not COFF */ +} + +/* **************************************************************** + * copy_text_and_data + * + * Copy the text and data segments from memory to the new a.out + */ +static int +copy_text_and_data (int new, int a_out) +{ + register char *end; + register char *ptr; + +#ifdef COFF + +#ifdef USG_SHARED_LIBRARIES + + int scns; + struct scnhdr scntemp; /* Temporary section header */ + + /* The purpose of this code is to write out the new file's section + * contents. + * + * Step through the section table. If we know the section (.text, + * .data) do the appropriate thing. Otherwise, if the section has + * no allocated space in the file (.bss), do nothing. Otherwise, + * the section has space allocated in the file, and is not a section + * we know. So just copy it. + */ + + lseek (a_out, sizeof (struct filehdr) + sizeof (struct aouthdr), 0); + + for (scns = f_hdr.f_nscns; scns > 0; scns--) + { + if (read (a_out, &scntemp, sizeof (scntemp)) != sizeof (scntemp)) + PERROR ("temacs"); + + if (!strcmp (scntemp.s_name, ".text")) + { + lseek (new, (long) text_scnptr, 0); + ptr = (char *) f_ohdr.text_start; + end = ptr + f_ohdr.tsize; + write_segment (new, ptr, end); + } + else if (!strcmp (scntemp.s_name, ".data")) + { + lseek (new, (long) data_scnptr, 0); + ptr = (char *) f_ohdr.data_start; + end = ptr + f_ohdr.dsize; + write_segment (new, ptr, end); + } + else if (!scntemp.s_scnptr) + ; /* do nothing - no data for this section */ + else + { + char page[BUFSIZ]; + int size, n; + long old_a_out_ptr = lseek (a_out, 0, 1); + + lseek (a_out, scntemp.s_scnptr, 0); + for (size = scntemp.s_size; size > 0; size -= sizeof (page)) + { + n = size > sizeof (page) ? sizeof (page) : size; + if (read (a_out, page, n) != n || write (new, page, n) != n) + PERROR ("xemacs"); + } + lseek (a_out, old_a_out_ptr, 0); + } + } + +#else /* COFF, but not USG_SHARED_LIBRARIES */ + + lseek (new, (long) text_scnptr, 0); + ptr = (char *) f_ohdr.text_start; + end = ptr + f_ohdr.tsize; + write_segment (new, ptr, end); + + lseek (new, (long) data_scnptr, 0); + ptr = (char *) f_ohdr.data_start; + end = ptr + f_ohdr.dsize; + write_segment (new, ptr, end); + +#endif /* USG_SHARED_LIBRARIES */ + +#else /* if not COFF */ + +/* Some machines count the header as part of the text segment. + That is to say, the header appears in core + just before the address that start_of_text () returns. + For them, N_TXTOFF is the place where the header goes. + We must adjust the seek to the place after the header. + Note that at this point hdr.a_text does *not* count + the extra A_TEXT_OFFSET bytes, only the actual bytes of code. */ + +#ifdef A_TEXT_SEEK + lseek (new, (long) A_TEXT_SEEK (hdr), 0); +#else +#ifdef A_TEXT_OFFSET + /* Note that on the Sequent machine A_TEXT_OFFSET != sizeof (hdr) + and sizeof (hdr) is the correct amount to add here. */ + /* In version 19, eliminate this case and use A_TEXT_SEEK whenever + N_TXTOFF is not right. */ + lseek (new, (long) N_TXTOFF (hdr) + sizeof (hdr), 0); +#else + lseek (new, (long) N_TXTOFF (hdr), 0); +#endif /* no A_TEXT_OFFSET */ +#endif /* no A_TEXT_SEEK */ + + ptr = (char *) unexec_text_start; + end = ptr + hdr.a_text; + write_segment (new, ptr, end); + + ptr = (char *) unexec_data_start; + end = ptr + hdr.a_data; +/* This lseek is certainly incorrect when A_TEXT_OFFSET + and I believe it is a no-op otherwise. + Let's see if its absence ever fails. */ +/* lseek (new, (long) N_TXTOFF (hdr) + hdr.a_text, 0); */ + write_segment (new, ptr, end); + +#endif /* not COFF */ + + return 0; +} + +write_segment (int new, register char *ptr, register char *end) +{ + register int i, nwrite, ret; + char buf[80]; + extern int errno; + char zeros[128]; + + bzero (zeros, sizeof zeros); + + for (i = 0; ptr < end;) + { + /* distance to next multiple of 128. */ + nwrite = (((int) ptr + 128) & -128) - (int) ptr; + /* But not beyond specified end. */ + if (nwrite > end - ptr) nwrite = end - ptr; + ret = write (new, ptr, nwrite); + /* If write gets a page fault, it means we reached + a gap between the old text segment and the old data segment. + This gap has probably been remapped into part of the text segment. + So write zeros for it. */ + if (ret == -1 && errno == EFAULT) + write (new, zeros, nwrite); + else if (nwrite != ret) + { + sprintf (buf, + "unexec write failure: addr 0x%x, fileno %d, size 0x%x, wrote 0x%x, errno %d", + ptr, new, nwrite, ret, errno); + PERROR (buf); + } + i += nwrite; + ptr += nwrite; + } +} + +/* **************************************************************** + * copy_sym + * + * Copy the relocation information and symbol table from the a.out to the new + */ +static int +copy_sym (int new, int a_out, char *a_name, char *new_name) +{ + char page[1024]; + int n; + + if (a_out < 0) + return 0; + +#ifdef COFF + if (SYMS_START == 0L) + return 0; +#endif /* COFF */ + +#ifdef COFF + if (lnnoptr) /* if there is line number info */ + lseek (a_out, lnnoptr, 0); /* start copying from there */ + else +#endif /* COFF */ + lseek (a_out, SYMS_START, 0); /* Position a.out to symtab. */ + + while ((n = read (a_out, page, sizeof page)) > 0) + { + if (write (new, page, n) != n) + { + PERROR (new_name); + } + } + if (n < 0) + { + PERROR (a_name); + } + return 0; +} + +/* **************************************************************** + * mark_x + * + * After succesfully building the new a.out, mark it executable + */ +static int +mark_x (char *name) +{ + struct stat sbuf; + int um; + int new = 0; /* for PERROR */ + + um = umask (777); + umask (um); + if (stat (name, &sbuf) == -1) + { + PERROR (name); + } + sbuf.st_mode |= 0111 & ~um; + if (chmod (name, sbuf.st_mode) == -1) + PERROR (name); + return 0; +} + +/* + * If the COFF file contains a symbol table and a line number section, + * then any auxiliary entries that have values for x_lnnoptr must + * be adjusted by the amount that the line number section has moved + * in the file (bias computed in make_hdr). The #@$%&* designers of + * the auxiliary entry structures used the absolute file offsets for + * the line number entry rather than an offset from the start of the + * line number section! + * + * When I figure out how to scan through the symbol table and pick out + * the auxiliary entries that need adjustment, this routine will + * be fixed. As it is now, all such entries are wrong and sdb + * will complain. Fred Fish, UniSoft Systems Inc. + */ + +#ifdef COFF + +/* This function is probably very slow. Instead of reopening the new + file for input and output it should copy from the old to the new + using the two descriptors already open (WRITEDESC and READDESC). + Instead of reading one small structure at a time it should use + a reasonable size buffer. But I don't have time to work on such + things, so I am installing it as submitted to me. -- RMS. */ + +adjust_lnnoptrs (writedesc, readdesc, new_name) + int writedesc; + int readdesc; + char *new_name; +{ + register int nsyms; + register int new; +#if defined (amdahl_uts) || defined (pfa) + SYMENT symentry; + AUXENT auxentry; +#else + struct syment symentry; + union auxent auxentry; +#endif + + if (!lnnoptr || !f_hdr.f_symptr) + return 0; + + if ((new = open (new_name, 2)) < 0) + { + PERROR (new_name); + return -1; + } + + lseek (new, f_hdr.f_symptr, 0); + for (nsyms = 0; nsyms < f_hdr.f_nsyms; nsyms++) + { + read (new, &symentry, SYMESZ); + if (symentry.n_numaux) + { + read (new, &auxentry, AUXESZ); + nsyms++; + if (ISFCN (symentry.n_type)) { + auxentry.x_sym.x_fcnary.x_fcn.x_lnnoptr += bias; + lseek (new, -AUXESZ, 1); + write (new, &auxentry, AUXESZ); + } + } + } + close (new); +} + +#endif /* COFF */ + +#endif /* not CANNOT_UNEXEC */ + +#endif /* not CANNOT_DUMP */ + +#ifdef UNIXSAVE +#include "save.c" +#endif diff --git a/o/unexmacosx.c b/o/unexmacosx.c new file mode 100644 index 0000000..ec57e83 --- /dev/null +++ b/o/unexmacosx.c @@ -0,0 +1,1203 @@ +/* Dump Gcl in Mach-O format for use on Mac OS X. + Copyright (C) 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. + +This file is part of GNU Gcl. + +GNU Gcl is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +GNU Gcl is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Gcl. If not, see . */ + +/* Contributed by Andrew Choi (akochoi@mac.com). */ + +/* Documentation note. + + Consult the following documents/files for a description of the + Mach-O format: the file loader.h, man pages for Mach-O and ld, old + NEXTSTEP documents of the Mach-O format. The tool otool dumps the + mach header (-h option) and the load commands (-l option) in a + Mach-O file. The tool nm on Mac OS X displays the symbol table in + a Mach-O file. For examples of unexec for the Mach-O format, see + the file unexnext.c in the GNU Gcl distribution, the file + unexdyld.c in the Darwin port of GNU Gcl 20.7, and unexdyld.c in + the Darwin port of XGcl 21.1. Also the Darwin Libc source + contains the source code for malloc_freezedry and malloc_jumpstart. + Read that to see what they do. This file was written completely + from scratch, making use of information from the above sources. */ + +/* The Mac OS X implementation of unexec makes use of Darwin's `zone' + memory allocator. All calls to malloc, realloc, and free in Gcl + are redirected to unexec_malloc, unexec_realloc, and unexec_free in + this file. When tgcl is run, all memory requests are handled in + the zone GclZone. The Darwin memory allocator library calls + maintain the data structures to manage this zone. Dumping writes + its contents to data segments of the executable file. When gcl + is run, the loader recreates the contents of the zone in memory. + However since the initialization routine of the zone memory + allocator is run again, this `zone' can no longer be used as a + heap. That is why gcl uses the ordinary malloc system call to + allocate memory. Also, when a block of memory needs to be + reallocated and the new size is larger than the old one, a new + block must be obtained by malloc and the old contents copied to + it. */ + +/* Peculiarity of the Mach-O files generated by ld in Mac OS X + (possible causes of future bugs if changed). + + The file offset of the start of the __TEXT segment is zero. Since + the Mach header and load commands are located at the beginning of a + Mach-O file, copying the contents of the __TEXT segment from the + input file overwrites them in the output file. Despite this, + unexec works fine as written below because the segment load command + for __TEXT appears, and is therefore processed, before all other + load commands except the segment load command for __PAGEZERO, which + remains unchanged. + + Although the file offset of the start of the __TEXT segment is + zero, none of the sections it contains actually start there. In + fact, the earliest one starts a few hundred bytes beyond the end of + the last load command. The linker option -headerpad controls the + minimum size of this padding. Its setting can be changed in + s/darwin.h. A value of 0x690, e.g., leaves room for 30 additional + load commands for the newly created __DATA segments (at 56 bytes + each). Unexec fails if there is not enough room for these new + segments. + + The __TEXT segment contains the sections __text, __cstring, + __picsymbol_stub, and __const and the __DATA segment contains the + sections __data, __la_symbol_ptr, __nl_symbol_ptr, __dyld, __bss, + and __common. The other segments do not contain any sections. + These sections are copied from the input file to the output file, + except for __data, __bss, and __common, which are dumped from + memory. The types of the sections __bss and __common are changed + from S_ZEROFILL to S_REGULAR. Note that the number of sections and + their relative order in the input and output files remain + unchanged. Otherwise all n_sect fields in the nlist records in the + symbol table (specified by the LC_SYMTAB load command) will have to + be changed accordingly. +*/ + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#if defined (__ppc__) +#include +#endif +#include +#include +#undef malloc +#undef realloc +#undef free +#include + +#include + +#ifdef _LP64 +#define mach_header mach_header_64 +#define segment_command segment_command_64 +#undef VM_REGION_BASIC_INFO_COUNT +#define VM_REGION_BASIC_INFO_COUNT VM_REGION_BASIC_INFO_COUNT_64 +#undef VM_REGION_BASIC_INFO +#define VM_REGION_BASIC_INFO VM_REGION_BASIC_INFO_64 +#undef LC_SEGMENT +#define LC_SEGMENT LC_SEGMENT_64 +#define vm_region vm_region_64 +#define section section_64 +#undef MH_MAGIC +#define MH_MAGIC MH_MAGIC_64 +#endif + +#define VERBOSE 0 + +/* Size of buffer used to copy data from the input file to the output + file in function unexec_copy. */ +#define UNEXEC_COPY_BUFSZ 1024 + +/* Regions with memory addresses above this value are assumed to be + mapped to dynamically loaded libraries and will not be dumped. */ +#define VM_DATA_TOP (20 * 1024 * 1024) + +/* Type of an element on the list of regions to be dumped. */ +struct region_t { + vm_address_t address; + vm_size_t size; + vm_prot_t protection; + vm_prot_t max_protection; + + struct region_t *next; +}; + +/* Head and tail of the list of regions to be dumped. */ +static struct region_t *region_list_head = 0; +static struct region_t *region_list_tail = 0; + +/* Pointer to array of load commands. */ +static struct load_command **lca; + +/* Number of load commands. */ +static int nlc; + +/* The highest VM address of segments loaded by the input file. + Regions with addresses beyond this are assumed to be allocated + dynamically and thus require dumping. */ +static vm_address_t infile_lc_highest_addr = 0; + +/* The lowest file offset used by the all sections in the __TEXT + segments. This leaves room at the beginning of the file to store + the Mach-O header. Check this value against header size to ensure + the added load commands for the new __DATA segments did not + overwrite any of the sections in the __TEXT segment. */ +static unsigned long text_seg_lowest_offset = 0x10000000; + +/* Mach header. */ +static struct mach_header mh; + +/* Offset at which the next load command should be written. */ +static unsigned long curr_header_offset = sizeof (struct mach_header); + +/* Offset at which the next segment should be written. */ +static unsigned long curr_file_offset = 0; + +static unsigned long pagesize; +#define ROUNDUP_TO_PAGE_BOUNDARY(x) (((x) + pagesize - 1) & ~(pagesize - 1)) + +static int infd, outfd; + +static malloc_zone_t gcl_zone_body,*gcl_zone; + +/* file offset of input file's data segment */ +static off_t data_segment_old_fileoff = 0; + +static struct segment_command *data_segment_scp; + +void +reset_unexec_globals() { + region_list_head=NULL; + region_list_tail=NULL; + lca=NULL; + nlc=0; + infile_lc_highest_addr=0; + text_seg_lowest_offset=0x10000000; + memset(&mh,0,sizeof(mh)); + curr_header_offset=sizeof (struct mach_header); + curr_file_offset=0; + pagesize=0; + infd=0; + outfd=0; + gcl_zone=NULL; + data_segment_old_fileoff=0; + data_segment_scp=NULL; +} + +#define MAX_MARKED_REGIONS 1024 + +vm_range_t marked_regions [MAX_MARKED_REGIONS]; + +unsigned num_marked_regions; + +/* Size of the heap. */ +static unsigned long big_heap; + +/* Start of the heap. */ +char *mach_mapstart = 0; + +/* End of the heap. */ +char *mach_maplimit = 0; + +/* Position ot the break within the heap. */ +char *mach_brkpt = 0; + +/* Read N bytes from infd into memory starting at address DEST. + Return true if successful, false otherwise. */ +static int +unexec_read (void *dest, size_t n) +{ + return n == read (infd, dest, n); +} + +/* Write COUNT bytes from memory starting at address SRC to outfd + starting at offset DEST. Return true if successful, false + otherwise. */ +static int +unexec_write (off_t dest, const void *src, size_t count) +{ + if (lseek (outfd, dest, SEEK_SET) != dest) + return 0; + + return write (outfd, src, count) == count; +} + +/* Write COUNT bytes of zeros to outfd starting at offset DEST. + Return true if successful, false otherwise. */ +static int +unexec_write_zero (off_t dest, size_t count) +{ + char buf[UNEXEC_COPY_BUFSZ]; + ssize_t bytes; + + bzero (buf, UNEXEC_COPY_BUFSZ); + if (lseek (outfd, dest, SEEK_SET) != dest) + return 0; + + while (count > 0) + { + bytes = count > UNEXEC_COPY_BUFSZ ? UNEXEC_COPY_BUFSZ : count; + if (write (outfd, buf, bytes) != bytes) + return 0; + count -= bytes; + } + + return 1; +} + +/* Copy COUNT bytes from starting offset SRC in infd to starting + offset DEST in outfd. Return true if successful, false + otherwise. */ +static int +unexec_copy (off_t dest, off_t src, ssize_t count) +{ + ssize_t bytes_read; + ssize_t bytes_to_read; + + char buf[UNEXEC_COPY_BUFSZ]; + + if (lseek (infd, src, SEEK_SET) != src) + return 0; + + if (lseek (outfd, dest, SEEK_SET) != dest) + return 0; + + while (count > 0) + { + bytes_to_read = count > UNEXEC_COPY_BUFSZ ? UNEXEC_COPY_BUFSZ : count; + bytes_read = read (infd, buf, bytes_to_read); + if (bytes_read <= 0) + return 0; + if (write (outfd, buf, bytes_read) != bytes_read) + return 0; + count -= bytes_read; + } + + return 1; +} + +/* Debugging and informational messages routines. */ + +static void +unexec_error (char *format, ...) +{ + va_list ap; + + va_start (ap, format); + fprintf (stderr, "unexec: "); + vfprintf (stderr, format, ap); + fprintf (stderr, "\n"); + va_end (ap); + exit (1); +} + +/* More informational messages routines. */ + +#if VERBOSE +static void +print_load_command_name (int lc) +{ + switch (lc) + { + case LC_SEGMENT: +#ifndef _LP64 + printf ("LC_SEGMENT "); +#else + printf ("LC_SEGMENT_64 "); +#endif + break; + case LC_LOAD_DYLINKER: + printf ("LC_LOAD_DYLINKER "); + break; + case LC_LOAD_DYLIB: + printf ("LC_LOAD_DYLIB "); + break; + case LC_SYMTAB: + printf ("LC_SYMTAB "); + break; + case LC_DYSYMTAB: + printf ("LC_DYSYMTAB "); + break; + case LC_UNIXTHREAD: + printf ("LC_UNIXTHREAD "); + break; + case LC_PREBOUND_DYLIB: + printf ("LC_PREBOUND_DYLIB"); + break; + case LC_TWOLEVEL_HINTS: + printf ("LC_TWOLEVEL_HINTS"); + break; +#ifdef LC_UUID + case LC_UUID: + printf ("LC_UUID "); + break; +#endif +#ifdef LC_DYLD_INFO + case LC_DYLD_INFO: + printf ("LC_DYLD_INFO "); + break; + case LC_DYLD_INFO_ONLY: + printf ("LC_DYLD_INFO_ONLY"); + break; +#endif + default: + printf ("unknown "); + } +} + +static void +print_load_command (struct load_command *lc) +{ + print_load_command_name (lc->cmd); + printf ("%8d", lc->cmdsize); + + if (lc->cmd == LC_SEGMENT) + { + struct segment_command *scp; + struct section *sectp; + int j; + + scp = (struct segment_command *) lc; + printf (" %-16.16s %#10lx %#8lx\n", + scp->segname, (long) (scp->vmaddr), (long) (scp->vmsize)); + + sectp = (struct section *) (scp + 1); + for (j = 0; j < scp->nsects; j++) + { + printf (" %-16.16s %#10lx %#8lx\n", + sectp->sectname, (long) (sectp->addr), (long) (sectp->size)); + sectp++; + } + } + else + printf ("\n"); +} +#endif + +/* Copy a LC_SEGMENT load command other than the __DATA segment from + the input file to the output file, adjusting the file offset of the + segment and the file offsets of sections contained in it. */ +static void +copy_segment (struct load_command *lc) +{ + struct segment_command *scp = (struct segment_command *) lc; + unsigned long old_fileoff = scp->fileoff; + struct section *sectp; + int j; + + scp->fileoff = curr_file_offset; + + sectp = (struct section *) (scp + 1); + for (j = 0; j < scp->nsects; j++) + { + sectp->offset += curr_file_offset - old_fileoff; + sectp++; + } + +#if VERBOSE + printf ("Writing segment %-16.16s @ %#8lx (%#8lx/%#8lx @ %#10lx)\n", + scp->segname, (long) (scp->fileoff), (long) (scp->filesize), + (long) (scp->vmsize), (long) (scp->vmaddr)); +#endif + + if (!unexec_copy (scp->fileoff, old_fileoff, scp->filesize)) + unexec_error ("cannot copy segment from input to output file"); + curr_file_offset += ROUNDUP_TO_PAGE_BOUNDARY (scp->filesize); + + if (!unexec_write (curr_header_offset, lc, lc->cmdsize)) + unexec_error ("cannot write load command to header"); + + curr_header_offset += lc->cmdsize; +} + +/* Copy a LC_SEGMENT load command for the __DATA segment in the input + file to the output file. We assume that only one such segment load + command exists in the input file and it contains the sections + __data, __bss, __common, __la_symbol_ptr, __nl_symbol_ptr, and + __dyld. The first three of these should be dumped from memory and + the rest should be copied from the input file. Note that the + sections __bss and __common contain no data in the input file + because their flag fields have the value S_ZEROFILL. Dumping these + from memory makes it necessary to adjust file offset fields in + subsequently dumped load commands. Then, create new __DATA segment + load commands for regions on the region list other than the one + corresponding to the __DATA segment in the input file. */ +static void +copy_data_segment (struct load_command *lc) +{ + struct segment_command *scp = (struct segment_command *) lc; + struct section *sectp; + int j; + unsigned long header_offset, old_file_offset; + + /* The new filesize of the segment is set to its vmsize because data + blocks for segments must start at region boundaries. Note that + this may leave unused locations at the end of the segment data + block because the total of the sizes of all sections in the + segment is generally smaller than vmsize. */ + scp->filesize = scp->vmsize; + +#if VERBOSE + printf ("Writing segment %-16.16s @ %#8lx (%#8lx/%#8lx @ %#10lx)\n", + scp->segname, curr_file_offset, (long)(scp->filesize), + (long)(scp->vmsize), (long) (scp->vmaddr)); +#endif + + /* Offsets in the output file for writing the next section structure + and segment data block, respectively. */ + header_offset = curr_header_offset + sizeof (struct segment_command); + + sectp = (struct section *) (scp + 1); + for (j = 0; j < scp->nsects; j++) + { + old_file_offset = sectp->offset; + sectp->offset = sectp->addr - scp->vmaddr + curr_file_offset; + /* The __data section is dumped from memory. The __bss and + __common sections are also dumped from memory but their flag + fields require changing (from S_ZEROFILL to S_REGULAR). The + other three kinds of sections are just copied from the input + file. */ + if (strncmp (sectp->sectname, SECT_DATA, 16) == 0) + { + if (!unexec_write (sectp->offset, (void *) sectp->addr, sectp->size)) + unexec_error ("cannot write section %s", SECT_DATA); + if (!unexec_write (header_offset, sectp, sizeof (struct section))) + unexec_error ("cannot write section %s's header", SECT_DATA); + } + else if (strncmp (sectp->sectname, SECT_COMMON, 16) == 0) + { + sectp->flags = S_REGULAR; + if (!unexec_write (sectp->offset, (void *) sectp->addr, sectp->size)) + unexec_error ("cannot write section %s", sectp->sectname); + if (!unexec_write (header_offset, sectp, sizeof (struct section))) + unexec_error ("cannot write section %s's header", sectp->sectname); + } + else if (strncmp (sectp->sectname, SECT_BSS, 16) == 0) + { + /* extern char *my_endbss_static; */ + unsigned long my_size; + + sectp->flags = S_REGULAR; + + /* Clear uninitialized local variables in statically linked + libraries. In particular, function pointers stored by + libSystemStub.a, which is introduced in Mac OS X 10.4 for + binary compatibility with respect to long double, are + cleared so that they will be reinitialized when the + dumped binary is executed on other versions of OS. */ + my_size = sectp->size;/* (unsigned long)my_endbss_static - sectp->addr; */ + /* if (!(sectp->addr <= (unsigned long)my_endbss_static */ + /* && my_size <= sectp->size)) */ + /* unexec_error ("my_endbss_static is not in section %s", */ + /* sectp->sectname); */ + if (!unexec_write (sectp->offset, (void *) sectp->addr, my_size)) + unexec_error ("cannot write section %s", sectp->sectname); + if (!unexec_write_zero (sectp->offset + my_size, + sectp->size - my_size)) + unexec_error ("cannot write section %s", sectp->sectname); + if (!unexec_write (header_offset, sectp, sizeof (struct section))) + unexec_error ("cannot write section %s's header", sectp->sectname); + } + else if (strncmp (sectp->sectname, "__la_symbol_ptr", 16) == 0 + || strncmp (sectp->sectname, "__nl_symbol_ptr", 16) == 0 + || strncmp (sectp->sectname, "__la_sym_ptr2", 16) == 0 + || strncmp (sectp->sectname, "__dyld", 16) == 0 + || strncmp (sectp->sectname, "__const", 16) == 0 + || strncmp (sectp->sectname, "__cfstring", 16) == 0 + || strncmp (sectp->sectname, "__gcc_except_tab", 16) == 0 + || strncmp (sectp->sectname, "__program_vars", 16) == 0 + || strncmp (sectp->sectname, "__objc_", 7) == 0 + || strncmp (sectp->sectname, "__got", 5) == 0)/*FIXME check this, but appears to work*/ + { + if (!unexec_copy (sectp->offset, old_file_offset, sectp->size)) + unexec_error ("cannot copy section %s", sectp->sectname); + if (!unexec_write (header_offset, sectp, sizeof (struct section))) + unexec_error ("cannot write section %s's header", sectp->sectname); + } + else + unexec_error ("unrecognized section name in __DATA segment"); + +#if VERBOSE + printf (" section %-16.16s at %#8lx - %#8lx (sz: %#8lx)\n", + sectp->sectname, (long) (sectp->offset), + (long) (sectp->offset + sectp->size), (long) (sectp->size)); +#endif + + header_offset += sizeof (struct section); + sectp++; + } + + curr_file_offset += ROUNDUP_TO_PAGE_BOUNDARY (scp->filesize); + + if (!unexec_write (curr_header_offset, scp, sizeof (struct segment_command))) + unexec_error ("cannot write header of __DATA segment"); + curr_header_offset += lc->cmdsize; + + /* Create new __DATA segment load commands for regions on the region + list that do not corresponding to any segment load commands in + the input file. + */ + /* for (j = 0; j < num_unexec_regions; j++) */ + { + struct segment_command sc; + + sc.cmd = LC_SEGMENT; + sc.cmdsize = sizeof (struct segment_command); + /* strncpy (sc.segname, SEG_DATA, 16); */ + strncpy (sc.segname, "__HEAP", 16); + sc.vmaddr = (long)mach_mapstart; + sc.vmsize = mach_maplimit-mach_mapstart; + sc.fileoff = curr_file_offset; + sc.filesize = core_end-mach_mapstart; + sc.maxprot = VM_PROT_READ | VM_PROT_WRITE | VM_PROT_EXECUTE; + sc.initprot = VM_PROT_READ | VM_PROT_WRITE | VM_PROT_EXECUTE; + sc.nsects = 0; + sc.flags = 0; + +#if VERBOSE + printf ("Writing segment %-16.16s @ %#8lx (%#8lx/%#8lx @ %#10lx)\n", + sc.segname, (long) (sc.fileoff), (long) (sc.filesize), + (long) (sc.vmsize), (long) (sc.vmaddr)); +#endif + + if (!unexec_write (sc.fileoff, (void *) sc.vmaddr, sc.filesize)) + unexec_error ("cannot write new __DATA segment"); + curr_file_offset += ROUNDUP_TO_PAGE_BOUNDARY (sc.filesize); + + if (!unexec_write (curr_header_offset, &sc, sc.cmdsize)) + unexec_error ("cannot write new __DATA segment's header"); + curr_header_offset += sc.cmdsize; + mh.ncmds++; + } +} + +/* Copy a LC_SYMTAB load command from the input file to the output + file, adjusting the file offset fields. */ +static void +copy_symtab (struct load_command *lc, long delta) +{ + struct symtab_command *stp = (struct symtab_command *) lc; + + stp->symoff += delta; + stp->stroff += delta; + +#if VERBOSE + printf ("Writing LC_SYMTAB command\n"); +#endif + + if (!unexec_write (curr_header_offset, lc, lc->cmdsize)) + unexec_error ("cannot write symtab command to header"); + + curr_header_offset += lc->cmdsize; +} + +/* Fix up relocation entries. */ +static void +unrelocate (const char *name, off_t reloff, int nrel, vm_address_t base) +{ + int i, unreloc_count; + struct relocation_info reloc_info; + struct scattered_relocation_info *sc_reloc_info + = (struct scattered_relocation_info *) &reloc_info; + vm_address_t location; + + for (unreloc_count = 0, i = 0; i < nrel; i++) + { + if (lseek (infd, reloff, L_SET) != reloff) + unexec_error ("unrelocate: %s:%d cannot seek to reloc_info", name, i); + if (!unexec_read (&reloc_info, sizeof (reloc_info))) + unexec_error ("unrelocate: %s:%d cannot read reloc_info", name, i); + reloff += sizeof (reloc_info); + + if (sc_reloc_info->r_scattered == 0) + switch (reloc_info.r_type) + { + case GENERIC_RELOC_VANILLA: + location = base + reloc_info.r_address; + if (location >= data_segment_scp->vmaddr + && location < (data_segment_scp->vmaddr + + data_segment_scp->vmsize)) + { + off_t src_off = data_segment_old_fileoff + + (location - data_segment_scp->vmaddr); + off_t dst_off = data_segment_scp->fileoff + + (location - data_segment_scp->vmaddr); + + if (!unexec_copy (dst_off, src_off, 1 << reloc_info.r_length)) + unexec_error ("unrelocate: %s:%d cannot copy original value", + name, i); + unreloc_count++; + } + break; + default: + unexec_error ("unrelocate: %s:%d cannot handle type = %d", + name, i, reloc_info.r_type); + } + else + switch (sc_reloc_info->r_type) + { +#if defined (__ppc__) + case PPC_RELOC_PB_LA_PTR: + /* nothing to do for prebound lazy pointer */ + break; +#endif + default: + unexec_error ("unrelocate: %s:%d cannot handle scattered type = %d", + name, i, sc_reloc_info->r_type); + } + } + +#if VERBOSE + if (nrel > 0) + printf ("Fixed up %d/%d %s relocation entries in data segment.\n", + unreloc_count, nrel, name); +#endif + +} + +#if __ppc64__ +/* Rebase r_address in the relocation table. */ +static void +rebase_reloc_address (off_t reloff, int nrel, long linkedit_delta, long diff) +{ + int i; + struct relocation_info reloc_info; + struct scattered_relocation_info *sc_reloc_info + = (struct scattered_relocation_info *) &reloc_info; + + for (i = 0; i < nrel; i++, reloff += sizeof (reloc_info)) + { + if (lseek (infd, reloff - linkedit_delta, L_SET) + != reloff - linkedit_delta) + unexec_error ("rebase_reloc_table: cannot seek to reloc_info"); + if (!unexec_read (&reloc_info, sizeof (reloc_info))) + unexec_error ("rebase_reloc_table: cannot read reloc_info"); + + if (sc_reloc_info->r_scattered == 0 + && reloc_info.r_type == GENERIC_RELOC_VANILLA) + { + reloc_info.r_address -= diff; + if (!unexec_write (reloff, &reloc_info, sizeof (reloc_info))) + unexec_error ("rebase_reloc_table: cannot write reloc_info"); + } + } +} +#endif + +/* Copy a LC_DYSYMTAB load command from the input file to the output + file, adjusting the file offset fields. */ +static void +copy_dysymtab (struct load_command *lc, long delta) +{ + struct dysymtab_command *dstp = (struct dysymtab_command *) lc; + vm_address_t base; + +#ifdef _LP64 +#if __ppc64__ + { + int i; + + base = 0; + for (i = 0; i < nlc; i++) + if (lca[i]->cmd == LC_SEGMENT) + { + struct segment_command *scp = (struct segment_command *) lca[i]; + + if (scp->vmaddr + scp->vmsize > 0x100000000 + && (scp->initprot & VM_PROT_WRITE) != 0) + { + base = data_segment_scp->vmaddr; + break; + } + } + } +#else + /* First writable segment address. */ + base = data_segment_scp->vmaddr; +#endif +#else + /* First segment address in the file (unless MH_SPLIT_SEGS set). */ + base = 0; +#endif + + unrelocate ("local", dstp->locreloff, dstp->nlocrel, base); + unrelocate ("external", dstp->extreloff, dstp->nextrel, base); + + if (dstp->nextrel > 0) { + dstp->extreloff += delta; + } + + if (dstp->nlocrel > 0) { + dstp->locreloff += delta; + } + + if (dstp->nindirectsyms > 0) + dstp->indirectsymoff += delta; + +#if VERBOSE + printf ("Writing LC_DYSYMTAB command\n"); +#endif + + if (!unexec_write (curr_header_offset, lc, lc->cmdsize)) + unexec_error ("cannot write symtab command to header"); + + curr_header_offset += lc->cmdsize; + +#if __ppc64__ + /* Check if the relocation base needs to be changed. */ + if (base == 0) + { + vm_address_t newbase = 0; + int i; + + for (i = 0; i < num_unexec_regions; i++) + if (unexec_regions[i].range.address + unexec_regions[i].range.size + > 0x100000000) + { + newbase = data_segment_scp->vmaddr; + break; + } + + if (newbase) + { + rebase_reloc_address (dstp->locreloff, dstp->nlocrel, delta, newbase); + rebase_reloc_address (dstp->extreloff, dstp->nextrel, delta, newbase); + } + } +#endif +} + +/* Copy a LC_TWOLEVEL_HINTS load command from the input file to the output + file, adjusting the file offset fields. */ +static void +copy_twolevelhints (struct load_command *lc, long delta) +{ + struct twolevel_hints_command *tlhp = (struct twolevel_hints_command *) lc; + + if (tlhp->nhints > 0) { + tlhp->offset += delta; + } + +#if VERBOSE + printf ("Writing LC_TWOLEVEL_HINTS command\n"); +#endif + + if (!unexec_write (curr_header_offset, lc, lc->cmdsize)) + unexec_error ("cannot write two level hint command to header"); + + curr_header_offset += lc->cmdsize; +} + +#ifdef LC_DYLD_INFO +/* Copy a LC_DYLD_INFO(_ONLY) load command from the input file to the output + file, adjusting the file offset fields. */ +static void +copy_dyld_info (struct load_command *lc, long delta) +{ + struct dyld_info_command *dip = (struct dyld_info_command *) lc; + + if (dip->rebase_off > 0) + dip->rebase_off += delta; + if (dip->bind_off > 0) + dip->bind_off += delta; + if (dip->weak_bind_off > 0) + dip->weak_bind_off += delta; + if (dip->lazy_bind_off > 0) + dip->lazy_bind_off += delta; + if (dip->export_off > 0) + dip->export_off += delta; + +#if VERBOSE + printf ("Writing "); + print_load_command_name (lc->cmd); + printf (" command\n"); +#endif + + if (!unexec_write (curr_header_offset, lc, lc->cmdsize)) + unexec_error ("cannot write dyld info command to header"); + + curr_header_offset += lc->cmdsize; +} +#endif + +/* Copy other kinds of load commands from the input file to the output + file, ones that do not require adjustments of file offsets. */ +static void +copy_other (struct load_command *lc) +{ +#if VERBOSE + printf ("Writing "); + print_load_command_name (lc->cmd); + printf (" command\n"); +#endif + + if (!unexec_write (curr_header_offset, lc, lc->cmdsize)) + unexec_error ("cannot write symtab command to header"); + + curr_header_offset += lc->cmdsize; +} + +/* Loop through all load commands and dump them. Then write the Mach + header. */ +static void +dump_it () { + + int i; + long linkedit_delta = 0; + +#if VERBOSE + printf ("--- Load Commands written to Output File ---\n"); +#endif + + for (i = 0; i < nlc; i++) + switch (lca[i]->cmd) { + + case LC_SEGMENT: + { + struct segment_command *scp = (struct segment_command *) lca[i]; + if (strncmp (scp->segname, SEG_DATA, 16) == 0) { + + /* save data segment file offset and segment_command for + unrelocate */ + + if (data_segment_old_fileoff) + unexec_error ("cannot handle multiple DATA segments in input file"); + + data_segment_old_fileoff = scp->fileoff; + data_segment_scp = scp; + + copy_data_segment (lca[i]); + + } else { + + if (strncmp (scp->segname, SEG_LINKEDIT, 16) == 0) { + if (linkedit_delta) + unexec_error ("cannot handle multiple LINKEDIT segments in input file"); + linkedit_delta = curr_file_offset - scp->fileoff; + } + + if (strncmp (scp->segname, "__HEAP", 16) != 0) copy_segment (lca[i]); else mh.ncmds--; + + } + } + break; + case LC_SYMTAB: + copy_symtab (lca[i], linkedit_delta); + break; + case LC_DYSYMTAB: + copy_dysymtab (lca[i], linkedit_delta); + break; + case LC_TWOLEVEL_HINTS: + copy_twolevelhints (lca[i], linkedit_delta); + break; +#ifdef LC_DYLD_INFO + case LC_DYLD_INFO: + case LC_DYLD_INFO_ONLY: + copy_dyld_info (lca[i], linkedit_delta); + break; +#endif + default: + copy_other (lca[i]); + break; + } + + if (curr_header_offset > text_seg_lowest_offset) + unexec_error ("not enough room for load commands for new __DATA segments"); + +#if VERBOSE + printf ("%ld unused bytes follow Mach-O header\n", + text_seg_lowest_offset - curr_header_offset); +#endif + + mh.sizeofcmds = curr_header_offset - sizeof (struct mach_header); + if (!unexec_write (0, &mh, sizeof (struct mach_header))) + unexec_error ("cannot write final header contents"); + +} + +/* Read header and load commands from input file. Store the latter in + the global array lca. Store the total number of load commands in + global variable nlc. */ +static void +read_load_commands_and_dump () { + + int i; + + if (!unexec_read (&mh, sizeof (struct mach_header))) + unexec_error ("cannot read mach-o header"); + + if (mh.magic != MH_MAGIC) + unexec_error ("input file not in Mach-O format"); + + if (mh.filetype != MH_EXECUTE) + unexec_error ("input Mach-O file is not an executable object file"); + +#if VERBOSE + printf ("--- Header Information ---\n"); + printf ("Magic = 0x%08x\n", mh.magic); + printf ("CPUType = %d\n", mh.cputype); + printf ("CPUSubType = %d\n", mh.cpusubtype); + printf ("FileType = 0x%x\n", mh.filetype); + printf ("NCmds = %d\n", mh.ncmds); + printf ("SizeOfCmds = %d\n", mh.sizeofcmds); + printf ("Flags = 0x%08x\n", mh.flags); +#endif + + nlc = mh.ncmds; + lca=alloca(nlc*sizeof(struct load_command *)); + + for (i = 0; i < nlc; i++) { + + struct load_command lc; + + /* Load commands are variable-size: so read the command type and + size first and then read the rest. */ + + if (!unexec_read (&lc, sizeof (struct load_command))) + unexec_error ("cannot read load command"); + + lca[i]=(struct load_command *)alloca(lc.cmdsize); + memcpy (lca[i], &lc, sizeof (struct load_command)); + + if (!unexec_read (lca[i] + 1, lc.cmdsize - sizeof (struct load_command))) + unexec_error ("cannot read content of load command"); + if (lc.cmd == LC_SEGMENT) { + + struct segment_command *scp = (struct segment_command *) lca[i]; + + if (scp->vmaddr + scp->vmsize > infile_lc_highest_addr) + infile_lc_highest_addr = scp->vmaddr + scp->vmsize; + + if (strncmp (scp->segname, SEG_TEXT, 16) == 0) { + + struct section *sectp = (struct section *) (scp + 1); + int j; + + for (j = 0; j < scp->nsects; j++) + if (sectp->offset < text_seg_lowest_offset) + text_seg_lowest_offset = sectp->offset; + } + } + } + +#if VERBOSE + printf ("Highest address of load commands in input file: %#8x\n", + infile_lc_highest_addr); + + printf ("Lowest offset of all sections in __TEXT segment: %#8lx\n", + text_seg_lowest_offset); + + printf ("--- List of Load Commands in Input File ---\n"); + printf ("# cmd cmdsize name address size\n"); + + for (i = 0; i < nlc; i++) { + printf ("%1d ", i); + print_load_command (lca[i]); + } +#endif + + dump_it (); + +} + +/* Take a snapshot of Gcl and make a Mach-O format executable file + from it. The file names of the output and input files are outfile + and infile, respectively. The three other parameters are + ignored. */ +void +unexec (char *outfile, char *infile, void *start_data, void *start_bss, + void *entry_address) { + + reset_unexec_globals(); + + pagesize = getpagesize (); + if ((infd = open (infile, O_RDONLY, 0)) < 0) + unexec_error ("cannot open input file `%s'", infile); + + if ((outfd = open (outfile, O_WRONLY | O_TRUNC | O_CREAT, 0755)) < 0) { + close (infd); + unexec_error ("cannot open output file `%s'", outfile); + } + + read_load_commands_and_dump(); + + close (outfd); + +} + +/* Replacement for broken sbrk(2). */ + +#include +#include +unsigned long +probe_big_heap(unsigned long try,unsigned long inc,unsigned long max) { + + void *r; + + if ((r=mmap(NULL, try, PROT_READ|PROT_WRITE, MAP_PRIVATE | MAP_ANON, -1, 0))==(void *)-1) + return try>inc ? probe_big_heap(try-inc,inc>>1,max) : 0; + munmap(r,try); + return (!inc || try >=max) ? try : probe_big_heap(try+inc,inc,max); + +} + +void *my_sbrk (long incr) +{ + char *temp, *ptr; + + if (mach_brkpt == 0) { + + big_heap=(1UL)<<35; + if (!(big_heap=probe_big_heap(PAGESIZE,big_heap>>1,big_heap))) { + unexec_error("my_sbrk(): probe_big_heap() failed\n"); + return ((char *)-1); + } + + mach_brkpt=mmap(NULL, big_heap, PROT_READ|PROT_WRITE, MAP_PRIVATE | MAP_ANON, -1, 0); + + mach_mapstart = mach_brkpt; + mach_maplimit = mach_brkpt + big_heap; + + } + if (incr == 0) { + return (mach_brkpt); + } else { + ptr = mach_brkpt + incr; + if (ptr mach_maplimit) + return (char *)-1; + temp = mach_brkpt; + mach_brkpt = ptr; + return (temp); + } +} + +static size_t stub_size (malloc_zone_t *zone, const void *ptr) +{ + extern object malloc_list; + object *p; + + for (p = &malloc_list ; *p && !endp(*p) ; p = &((*p)->c.c_cdr)) { + size_t size = (*p)->c.c_car->st.st_dim; + void *base = (*p)->c.c_car->st.st_self; + if (ptr >= base && ptr < base + size) { + return (size); + } + } + return (0); +} + +#ifdef HAVE_MALLOC_ZONE_MEMALIGN +static void * +stub_memalign(size_t boundary, size_t size) { + + extern void *my_malloc (size_t); + void *v=my_malloc(size+boundary-1); + return (void *)(((unsigned long)v+boundary-1)&~(boundary-1)); + +} +#endif + +static void * +stub_malloc(malloc_zone_t *zone, size_t size) { + + extern void *my_malloc (size_t); + return my_malloc (size); + +} + +static void * +stub_calloc(malloc_zone_t *zone, size_t num_items, size_t size) { + + extern void *my_calloc (size_t, size_t); + return my_calloc (num_items, size); + +} + +static void * +stub_valloc(malloc_zone_t *zone, size_t size) { + + extern void *my_valloc (size_t); + return my_valloc (size); + +} + +static void * +stub_realloc(malloc_zone_t *zone, void *ptr, size_t size) { + + extern void *my_realloc (void *, size_t); + return my_realloc (ptr, size); + +} + +static void stub_free (malloc_zone_t *zone, void *ptr) { + + extern void my_free (void *ptr); + my_free (ptr); + +} + +void init_darwin_zone_compat () { + + extern unsigned malloc_num_zones; + extern malloc_zone_t **malloc_zones; + unsigned nmzc; + malloc_zone_t *mzc[10]; + unsigned i; + + nmzc=malloc_num_zones; + assert(nmzc<=sizeof(mzc)/sizeof(*mzc)); + memcpy(mzc,malloc_zones,nmzc*sizeof(*mzc)); + + gcl_zone=&gcl_zone_body; + + gcl_zone->size = (void *) stub_size; + gcl_zone->malloc = (void *) stub_malloc; + gcl_zone->calloc = (void *) stub_calloc; + gcl_zone->valloc = (void *) stub_valloc; + gcl_zone->realloc = (void *) stub_realloc; + gcl_zone->free = (void *) stub_free; + gcl_zone->destroy = (void *) stub_free; + gcl_zone->batch_malloc = (void *) stub_malloc; + gcl_zone->batch_free = (void *) stub_free; + +#ifdef HAVE_MALLOC_ZONE_MEMALIGN + gcl_zone->free_definite_size = (void *) stub_free; + gcl_zone->memalign = (void *) stub_memalign; +#endif + + for (i=0;i +#include +#include +#include +#include +#include +#include +#include + +#if defined (IRIS_4D) || defined (sony) +#include "getpagesize.h" +#include +#endif + +static void fatal_unexec (); +static void mark_x (); + +#define READ(_fd, _buffer, _size, _error_message, _error_arg) \ + errno = EEOF; \ + if (read (_fd, _buffer, _size) != _size) \ + fatal_unexec (_error_message, _error_arg); + +#define WRITE(_fd, _buffer, _size, _error_message, _error_arg) \ + if (write (_fd, _buffer, _size) != _size) \ + fatal_unexec (_error_message, _error_arg); + +#define SEEK(_fd, _position, _error_message, _error_arg) \ + errno = EEOF; \ + if (lseek (_fd, _position, L_SET) != _position) \ + fatal_unexec (_error_message, _error_arg); + +extern int errno; +extern char *strerror (); +#define EEOF -1 + +static struct scnhdr *text_section; +static struct scnhdr *init_section; +static struct scnhdr *finit_section; +static struct scnhdr *rdata_section; +static struct scnhdr *xdata_section; +static struct scnhdr *pdata_section; +static struct scnhdr *data_section; +static struct scnhdr *lit8_section; +static struct scnhdr *lit4_section; +static struct scnhdr *sdata_section; +static struct scnhdr *sbss_section; +static struct scnhdr *bss_section; + + +struct headers { + struct filehdr fhdr; + struct aouthdr aout; + struct scnhdr section[16]; +}; + +/* Define name of label for entry point for the dumped executable. */ + +#ifndef DEFAULT_ENTRY_ADDRESS +#define DEFAULT_ENTRY_ADDRESS __start +#endif + +unexec (new_name, a_name, data_start, bss_start, entry_address) + char *new_name, *a_name; + unsigned long data_start, bss_start, entry_address; +{ + int new, old; + long pagesize, brk; + long newsyms, symrel; + int nread; + struct headers hdr; + int i; + long vaddr, scnptr; +#define BUFSIZE 8192 + char buffer[BUFSIZE]; + + old = open (a_name, O_RDONLY, 0); + if (old < 0) fatal_unexec ("opening %s", a_name); + + new = creat (new_name, 0666); + if (new < 0) fatal_unexec ("creating %s", new_name); + + hdr = *((struct headers *)TEXT_START); +#ifdef MIPS2 + if (hdr.fhdr.f_magic != MIPSELMAGIC + && hdr.fhdr.f_magic != MIPSEBMAGIC + && hdr.fhdr.f_magic != (MIPSELMAGIC | 1) + && hdr.fhdr.f_magic != (MIPSEBMAGIC | 1)) + { + fprintf (stderr, + "unexec: input file magic number is %x, not %x, %x, %x or %x.\n", + hdr.fhdr.f_magic, + MIPSELMAGIC, MIPSEBMAGIC, + MIPSELMAGIC | 1, MIPSEBMAGIC | 1); + exit(1); + } +#else /* not MIPS2 */ +#ifdef __alpha + if (hdr.fhdr.f_magic != ALPHAMAGIC + && hdr.fhdr.f_magic != ALPHAUMAGIC) + { + fprintf(stderr, "unexec: input file magic number is %x, not %x or %x.\n", + hdr.fhdr.f_magic, ALPHAMAGIC, ALPHAUMAGIC); + exit(1); + } +#else /* not alpha */ + if (hdr.fhdr.f_magic != MIPSELMAGIC + && hdr.fhdr.f_magic != MIPSEBMAGIC) + { + fprintf(stderr, "unexec: input file magic number is %x, not %x or %x.\n", + hdr.fhdr.f_magic, MIPSELMAGIC, MIPSEBMAGIC); + exit(1); + } +#endif /* not alpha */ +#endif /* not MIPS2 */ + + if (hdr.fhdr.f_opthdr != sizeof (hdr.aout)) + { + fprintf (stderr, "unexec: input a.out header is %d bytes, not %d.\n", + hdr.fhdr.f_opthdr, sizeof (hdr.aout)); + exit (1); + } + if (hdr.aout.magic != ZMAGIC) + { + fprintf (stderr, "unexec: input file a.out magic number is %o, not %o.\n", + hdr.aout.magic, ZMAGIC); + exit (1); + } + +#define CHECK_SCNHDR(ptr, name, flags) \ +for( i = 0, ptr = NULL; i < hdr.fhdr.f_nscns && !ptr; i++){ \ + if (hdr.section[i].s_name && strcmp (hdr.section[i].s_name, name) == 0){ \ + if (hdr.section[i].s_flags != flags) { \ + fprintf(stderr, "unexec: %x flags (%x expected) in %s section.\n", \ + hdr.section[i].s_flags, flags, name); \ + } \ + ptr = hdr.section + i; \ + } \ + if(ptr) \ + break;\ +} + + + CHECK_SCNHDR (text_section, _TEXT, STYP_TEXT); + CHECK_SCNHDR (init_section, _INIT, STYP_INIT); + CHECK_SCNHDR (rdata_section, _RDATA, STYP_RDATA); +#ifdef _RCONST + if (!rdata_section) /* OSF/1 V3 adds this */ + CHECK_SCNHDR (rdata_section, _RCONST, STYP_RCONST); +#endif +#ifdef _XDATA + CHECK_SCNHDR(xdata_section, _XDATA, STYP_XDATA); + CHECK_SCNHDR(pdata_section, _PDATA, STYP_PDATA); +#endif + CHECK_SCNHDR (data_section, _DATA, STYP_DATA); +#ifdef _LIT8 + CHECK_SCNHDR (lit8_section, _LIT8, STYP_LIT8); + CHECK_SCNHDR (lit4_section, _LIT4, STYP_LIT4); +#endif /* _LIT8 */ + CHECK_SCNHDR (sdata_section, _SDATA, STYP_SDATA); + CHECK_SCNHDR (sbss_section, _SBSS, STYP_SBSS); + CHECK_SCNHDR (bss_section, _BSS, STYP_BSS); +#if 0 /* Apparently this error check goes off on irix 3.3, + but it doesn't indicate a real problem. */ + if (i != hdr.fhdr.f_nscns) + fprintf (stderr, "unexec: %d sections found instead of %d.\n", + i, hdr.fhdr.f_nscns); +#endif + + text_section->s_scnptr = 0; + + pagesize = getpagesize (); + /* Casting to int avoids compiler error on NEWS-OS 5.0.2. */ + brk = (((int) (sbrk (0))) + pagesize - 1) & (-pagesize); + hdr.aout.dsize = brk - DATA_START; + hdr.aout.bsize = 0; + if (entry_address == 0) + { + extern DEFAULT_ENTRY_ADDRESS (); + hdr.aout.entry = (unsigned long)DEFAULT_ENTRY_ADDRESS; + } + else + hdr.aout.entry = entry_address; + + hdr.aout.bss_start = hdr.aout.data_start + hdr.aout.dsize; + rdata_section->s_size = data_start - DATA_START; + + /* Adjust start and virtual addresses of rdata_section, too. */ + rdata_section->s_vaddr = DATA_START; + rdata_section->s_paddr = DATA_START; + rdata_section->s_scnptr = text_section->s_scnptr + hdr.aout.tsize; + + data_section->s_vaddr = data_start; + data_section->s_paddr = data_start; + data_section->s_size = brk - data_start; + data_section->s_scnptr = rdata_section->s_scnptr + rdata_section->s_size; + vaddr = data_section->s_vaddr + data_section->s_size; + scnptr = data_section->s_scnptr + data_section->s_size; + if (lit8_section != NULL) + { + lit8_section->s_vaddr = vaddr; + lit8_section->s_paddr = vaddr; + lit8_section->s_size = 0; + lit8_section->s_scnptr = scnptr; + } + if (lit4_section != NULL) + { + lit4_section->s_vaddr = vaddr; + lit4_section->s_paddr = vaddr; + lit4_section->s_size = 0; + lit4_section->s_scnptr = scnptr; + } + if (sdata_section != NULL) + { + sdata_section->s_vaddr = vaddr; + sdata_section->s_paddr = vaddr; + sdata_section->s_size = 0; + sdata_section->s_scnptr = scnptr; + } + if (sbss_section != NULL) + { + sbss_section->s_vaddr = vaddr; + sbss_section->s_paddr = vaddr; + sbss_section->s_size = 0; + sbss_section->s_scnptr = scnptr; + } + if (bss_section != NULL) + { + bss_section->s_vaddr = vaddr; + bss_section->s_paddr = vaddr; + bss_section->s_size = 0; + bss_section->s_scnptr = scnptr; + } + + WRITE (new, (char *)TEXT_START, hdr.aout.tsize, + "writing text section to %s", new_name); + WRITE (new, (char *)DATA_START, hdr.aout.dsize, + "writing data section to %s", new_name); + + SEEK (old, hdr.fhdr.f_symptr, "seeking to start of symbols in %s", a_name); + errno = EEOF; + nread = read (old, buffer, BUFSIZE); + if (nread < sizeof (HDRR)) fatal_unexec ("reading symbols from %s", a_name); +#define symhdr ((pHDRR)buffer) + newsyms = hdr.aout.tsize + hdr.aout.dsize; + symrel = newsyms - hdr.fhdr.f_symptr; + hdr.fhdr.f_symptr = newsyms; + symhdr->cbLineOffset += symrel; + symhdr->cbDnOffset += symrel; + symhdr->cbPdOffset += symrel; + symhdr->cbSymOffset += symrel; + symhdr->cbOptOffset += symrel; + symhdr->cbAuxOffset += symrel; + symhdr->cbSsOffset += symrel; + symhdr->cbSsExtOffset += symrel; + symhdr->cbFdOffset += symrel; + symhdr->cbRfdOffset += symrel; + symhdr->cbExtOffset += symrel; +#undef symhdr + do + { + if (write (new, buffer, nread) != nread) + fatal_unexec ("writing symbols to %s", new_name); + nread = read (old, buffer, BUFSIZE); + if (nread < 0) fatal_unexec ("reading symbols from %s", a_name); +#undef BUFSIZE + } while (nread != 0); + + SEEK (new, 0, "seeking to start of header in %s", new_name); + WRITE (new, &hdr, sizeof (hdr), + "writing header of %s", new_name); + + close (old); + close (new); + mark_x (new_name); +} + +/* + * mark_x + * + * After successfully building the new a.out, mark it executable + */ + +static void +mark_x (name) + char *name; +{ + struct stat sbuf; + int um = umask (777); + umask (um); + if (stat (name, &sbuf) < 0) + fatal_unexec ("getting protection on %s", name); + sbuf.st_mode |= 0111 & ~um; + if (chmod (name, sbuf.st_mode) < 0) + fatal_unexec ("setting protection on %s", name); +} + +static void +fatal_unexec (const char *s, ...) +{ + va_list ap; + if (errno == EEOF) + fputs ("unexec: unexpected end of file, ", stderr); + else + fprintf (stderr, "unexec: %s, ", strerror (errno)); + va_start (ap,s); + _doprnt (s, ap, stderr); + fputs (".\n", stderr); + exit (1); +} + +#ifdef UNIXSAVE +#include "save.c" +#endif + diff --git a/o/unexnt.c b/o/unexnt.c new file mode 100755 index 0000000..b6cf0b4 --- /dev/null +++ b/o/unexnt.c @@ -0,0 +1,1153 @@ +/* unexec for GNU Emacs on Windows NT. + Copyright (C) 1994 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. + + Geoff Voelker (voelker@cs.washington.edu) 8-12-94 +*/ + +/* #include "gclincl.h" */ + +#ifndef UNIXSAVE +#include +#endif +/* #include */ /* _fmode */ +/* in case the include of config.h defined it */ +#undef va_start +#include +#include +#include +#include +#include /* strrchr */ + +#ifdef _GNU_H_WINDOWS_H +#include "cyglacks.h" +#endif + +/* Include relevant definitions from IMAGEHLP.H, which can be found + in \\win32sdk\mstools\samples\image\include\imagehlp.h. */ + + + +PIMAGE_NT_HEADERS +(__stdcall * pfnCheckSumMappedFile) (LPVOID BaseAddress, + DWORD FileLength, + LPDWORD HeaderSum, + LPDWORD CheckSum); + + + +#include +#include + +#include "ntheap.h" + +/* Info for keeping track of our heap. */ +unsigned char *data_region_base = UNINIT_PTR; +unsigned char *data_region_end = UNINIT_PTR; +unsigned char *real_data_region_end = UNINIT_PTR; +unsigned long data_region_size = UNINIT_LONG; +unsigned long reserved_heap_size = UNINIT_LONG; + +extern BOOL ctrl_c_handler (unsigned long type); + +extern char my_begdata[]; +extern char my_edata[]; +extern char my_begbss[]; +extern char my_endbss[]; +extern char *my_begbss_static; +extern char *my_endbss_static; + +#include "ntheap.h" + +enum { + HEAP_UNINITIALIZED = 1, + HEAP_UNLOADED, + HEAP_LOADED +}; + +/* Basically, our "initialized" flag. */ +int heap_state = HEAP_UNINITIALIZED; + +/* So we can find our heap in the file to recreate it. */ +unsigned long heap_index_in_executable = UNINIT_LONG; + +static void get_section_info (file_data *p_file); +static void copy_executable_and_dump_data_section (file_data *, file_data *); +static void dump_bss_and_heap (file_data *p_infile, file_data *p_outfile); + +/* Cached info about the .data section in the executable. */ +PUCHAR data_start_va = UNINIT_PTR; +DWORD data_start_file = UNINIT_LONG; +DWORD data_size = UNINIT_LONG; + +/* Cached info about the .bss section in the executable. */ +PUCHAR bss_start = UNINIT_PTR; +DWORD bss_size = UNINIT_LONG; + +void recreate_heap1() +{ + char executable_path[MAX_PATH]; + + if (heap_state == HEAP_UNLOADED) { + if (GetModuleFileName (NULL, executable_path, MAX_PATH) == 0) + { + printf ("Failed to find path for executable.\n"); + exit (1); + } + recreate_heap (executable_path); + } + heap_state = HEAP_LOADED; + +} + + +#ifdef HAVE_NTGUI +HINSTANCE hinst = NULL; +HINSTANCE hprevinst = NULL; +LPSTR lpCmdLine = ""; +int nCmdShow = 0; +#endif /* HAVE_NTGUI */ + +#ifndef UNIXSAVE +/* Startup code for running on NT. When we are running as the dumped + version, we need to bootstrap our heap and .bss section into our + address space before we can actually hand off control to the startup + code supplied by NT (primarily because that code relies upon malloc ()). */ +void +_start (void) +{ + extern void mainCRTStartup (void); + +#if 0 + /* Give us a way to debug problems with crashes on startup when + running under the MSVC profiler. */ + if (GetEnvironmentVariable ("EMACS_DEBUG", NULL, 0) > 0) + DebugBreak (); +#endif + + /* Cache system info, e.g., the NT page size. */ + cache_system_info (); + + /* If we're a dumped version of emacs then we need to recreate + our heap and play tricks with our .bss section. Do this before + start up. (WARNING: Do not put any code before this section + that relies upon malloc () and runs in the dumped version. It + won't work.) */ + if (heap_state == HEAP_UNLOADED) + { + char executable_path[MAX_PATH]; + + if (GetModuleFileName (NULL, executable_path, MAX_PATH) == 0) + { + printf ("Failed to find path for executable.\n"); + exit (1); + } + +#if 1 + /* To allow profiling, make sure executable_path names the .exe + file, not the ._xe file created by the profiler which contains + extra code that makes the stored exe offsets incorrect. (This + will not be necessary when unexec properly extends the .bss (or + .data as appropriate) section to include the dumped bss data, + and dumps the heap into a proper section of its own.) */ + { + char * p = strrchr (executable_path, '.'); + if (p && p[1] == '_') + p[1] = 'e'; + } + + /* Using HiProf profiler, exe name is different still. */ + { + char * p = strrchr (executable_path, '\\'); + strcpy (p, "\\emacs.exe"); + } +#endif + + recreate_heap (executable_path); + heap_state = HEAP_LOADED; + } + else + { + /* Grab our malloc arena space now, before CRT starts up. */ + sbrk (0); + } + + /* The default behavior is to treat files as binary and patch up + text files appropriately, in accordance with the MSDOS code. */ + _fmode = O_BINARY; + + /* This prevents ctrl-c's in shells running while we're suspended from + having us exit. */ + SetConsoleCtrlHandler ((PHANDLER_ROUTINE) ctrl_c_handler, TRUE); + + /* Invoke the NT CRT startup routine now that our housecleaning + is finished. */ +#ifdef HAVE_NTGUI + /* determine WinMain args like crt0.c does */ + hinst = GetModuleHandle(NULL); + lpCmdLine = GetCommandLine(); + nCmdShow = SW_SHOWDEFAULT; +#endif + mainCRTStartup (); +} +#endif /* UNIXSAVE */ + +/* Dump out .data and .bss sections into a new executable. */ +void +unexec (char *new_name, char *old_name, void *start_data, void *start_bss, + void *entry_address) +{ +#ifdef __CYGWIN32__ + file_data in_file, out_file; + char out_filename[MAX_PATH], in_filename[MAX_PATH]; + char filename[MAX_PATH]; + unsigned long size; + char *ptr; + extern void cygwin_conv_to_full_win32_path(char *,char *); + + fflush (stdin); + /* copy_stdin = *stdin; */ + setvbuf(stdin,0,_IONBF,0); + setvbuf(stdout,0,_IONBF,0); + + /* stdin->_data->__sdidinit = 0; + */ + + + if (!get_allocation_unit()) + cache_system_info (); + + /* Make sure that the input and output filenames have the + ".exe" extension...patch them up if they don't. */ + ptr = old_name + strlen (old_name) - 4; + strcpy(filename, old_name); + strcat(filename, (strcmp (ptr, ".exe") && strcmp (ptr, ".EXE"))?".exe":""); + cygwin_conv_to_full_win32_path(filename,in_filename); + ptr = new_name + strlen (new_name) - 4; + strcpy(filename, new_name); + strcat(filename, (strcmp (ptr, ".exe") && strcmp (ptr, ".EXE"))?".exe":""); + cygwin_conv_to_full_win32_path(filename,out_filename); +#else + file_data in_file, out_file; + char out_filename[MAX_PATH], in_filename[MAX_PATH]; + unsigned long size; + char *ptr; + + fflush (stdin); + /* copy_stdin = *stdin; */ + setvbuf(stdin,0,_IONBF,0); + setvbuf(stdout,0,_IONBF,0); + + /* stdin->_data->__sdidinit = 0; + */ + + + if (!get_allocation_unit()) + cache_system_info (); + + /* Make sure that the input and output filenames have the + ".exe" extension...patch them up if they don't. */ + strcpy (in_filename, old_name); + ptr = in_filename + strlen (in_filename) - 4; + if (strcmp (ptr, ".exe") && strcmp (ptr, ".EXE") ) + strcat (in_filename, ".exe"); + + strcpy (out_filename, new_name); + ptr = out_filename + strlen (out_filename) - 4; + if (strcmp (ptr, ".exe") && strcmp (ptr, ".EXE") ) + strcat (out_filename, ".exe"); +#endif + /* printf ("Dumping from %s\n", in_filename); */ + /* printf (" to %s\n", out_filename); */ + + /* We need to round off our heap to NT's allocation unit (64KB). */ + round_heap (get_allocation_unit ()); + + /* Open the undumped executable file. */ + if (!open_input_file (&in_file, in_filename)) + { + printf ("Failed to open %s (%ld)...bailing.\n", + in_filename, GetLastError ()); + exit (1); + } + + /* Get the interesting section info, like start and size of .bss... */ + get_section_info (&in_file); + + /* The size of the dumped executable is the size of the original + executable plus the size of the heap and the size of the .bss section. */ + if (heap_index_in_executable==UNINIT_LONG) + heap_index_in_executable = (unsigned long) + round_to_next ((unsigned char *) in_file.size, get_allocation_unit ()); + /* from lisp we know what to use */ +#ifdef IN_UNIXSAVE + data_region_end = round_to_next((unsigned char *)core_end,0x10000); + real_data_region_end = data_region_end; +#endif + size = heap_index_in_executable + get_committed_heap_size () + bss_size; + if (!open_output_file (&out_file, out_filename, size)) + { + printf ("Failed to open %s (%ld)...bailing.\n", + out_filename, GetLastError ()); + exit (1); + } + + /* Set the flag (before dumping). */ + heap_state = HEAP_UNLOADED; + + copy_executable_and_dump_data_section (&in_file, &out_file); + dump_bss_and_heap (&in_file, &out_file); + + /* Patch up header fields; profiler is picky about this. */ + + { + PIMAGE_DOS_HEADER dos_header; + PIMAGE_NT_HEADERS nt_header; + HANDLE hImagehelp = LoadLibrary ("imagehlp.dll"); + DWORD headersum; + DWORD checksum; + + dos_header = (PIMAGE_DOS_HEADER) out_file.file_base; + nt_header = (PIMAGE_NT_HEADERS) ((char *) dos_header + dos_header->e_lfanew); + + + nt_header->OptionalHeader.SizeOfStackReserve=0x800000; + /* nt_header->OptionalHeader.SizeOfHeapReserve=0x80000000; */ + /* nt_header->OptionalHeader.SizeOfHeapCommit=0x80000000; */ + + nt_header->OptionalHeader.CheckSum = 0; +// nt_header->FileHeader.TimeDateStamp = time (NULL); +// dos_header->e_cp = size / 512; +// nt_header->OptionalHeader.SizeOfImage = size; + + pfnCheckSumMappedFile = (void *) GetProcAddress (hImagehelp, "CheckSumMappedFile"); + if (pfnCheckSumMappedFile) + { +// nt_header->FileHeader.TimeDateStamp = time (NULL); + pfnCheckSumMappedFile (out_file.file_base, + out_file.size, + &headersum, + &checksum); + nt_header->OptionalHeader.CheckSum = checksum; + } + FreeLibrary (hImagehelp); + } + + close_file_data (&in_file); + close_file_data (&out_file); +} + + +/* File handling. */ + + +int +open_input_file (file_data *p_file, char *filename) +{ + HANDLE file; + HANDLE file_mapping; + void *file_base; + DWORD size, upper_size; + + file = CreateFile (filename, GENERIC_READ, FILE_SHARE_READ, NULL, + OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); + if (file == INVALID_HANDLE_VALUE) + return FALSE; + + size = GetFileSize (file, &upper_size); + file_mapping = CreateFileMapping (file, NULL, PAGE_READONLY, + 0, size, NULL); + if (!file_mapping) + return FALSE; + + file_base = MapViewOfFile (file_mapping, FILE_MAP_READ, 0, 0, size); + if (file_base == 0) + return FALSE; + + p_file->name = filename; + p_file->size = size; + p_file->file = file; + p_file->file_mapping = file_mapping; + p_file->file_base = file_base; + + return TRUE; +} + +int +open_output_file (file_data *p_file, char *filename, unsigned long size) +{ + HANDLE file; + HANDLE file_mapping; + void *file_base; + + file = CreateFile (filename, GENERIC_READ | GENERIC_WRITE, 0, NULL, + CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0); + if (file == INVALID_HANDLE_VALUE) + return FALSE; + + file_mapping = CreateFileMapping (file, NULL, PAGE_READWRITE, + 0, size, NULL); + if (!file_mapping) + return FALSE; + + file_base = MapViewOfFile (file_mapping, FILE_MAP_WRITE, 0, 0, size); + if (file_base == 0) + return FALSE; + + p_file->name = filename; + p_file->size = size; + p_file->file = file; + p_file->file_mapping = file_mapping; + p_file->file_base = file_base; + + return TRUE; +} + +/* Close the system structures associated with the given file. */ +void +close_file_data (file_data *p_file) +{ + UnmapViewOfFile (p_file->file_base); + CloseHandle (p_file->file_mapping); + CloseHandle (p_file->file); +} + + +/* Routines to manipulate NT executable file sections. */ + +#ifdef SEPARATE_BSS_SECTION +static void +get_bss_info_from_map_file (file_data *p_infile, PUCHAR *p_bss_start, + DWORD *p_bss_size) +{ + int n, start, len; + char map_filename[MAX_PATH]; + char buffer[256]; + FILE *map; + + /* Overwrite the .exe extension on the executable file name with + the .map extension. */ + strcpy (map_filename, p_infile->name); + n = strlen (map_filename) - 3; + strcpy (&map_filename[n], "map"); + + map = fopen (map_filename, "r"); + if (!map) + { + printf ("Failed to open map file %s, error %d...bailing out.\n", + map_filename, GetLastError ()); + exit (-1); + } + + while (fgets (buffer, sizeof (buffer), map)) + { + if (!(strstr (buffer, ".bss") && strstr (buffer, "DATA"))) + continue; + n = sscanf (buffer, " %*d:%x %x", &start, &len); + if (n != 2) + { + printf ("Failed to scan the .bss section line:\n%s", buffer); + exit (-1); + } + break; + } + *p_bss_start = (PUCHAR) start; + *p_bss_size = (DWORD) len; +} +#endif + +unsigned long +get_section_size (PIMAGE_SECTION_HEADER p_section) +{ + /* The true section size, before rounding. Some linkers swap the + meaning of these two values. */ + return min (p_section->SizeOfRawData, + p_section->Misc.VirtualSize); +} + +/* Return pointer to section header for named section. */ +IMAGE_SECTION_HEADER * +find_section (char * name, IMAGE_NT_HEADERS * nt_header) +{ + PIMAGE_SECTION_HEADER section; + int i; + + section = IMAGE_FIRST_SECTION (nt_header); + + for (i = 0; i < nt_header->FileHeader.NumberOfSections; i++) + { + if (strcmp ((char *)section->Name, name) == 0) + return section; + section++; + } + return NULL; +} + +/* Return pointer to section header for section containing the given + relative virtual address. */ +IMAGE_SECTION_HEADER * +rva_to_section (DWORD rva, IMAGE_NT_HEADERS * nt_header) +{ + PIMAGE_SECTION_HEADER section; + int i; + + section = IMAGE_FIRST_SECTION (nt_header); + + for (i = 0; i < nt_header->FileHeader.NumberOfSections; i++) + { + if (rva >= section->VirtualAddress && + rva < section->VirtualAddress + section->SizeOfRawData) + return section; + section++; + } + return NULL; +} + + +/* Flip through the executable and cache the info necessary for dumping. */ +static void +get_section_info (file_data *p_infile) +{ + PIMAGE_DOS_HEADER dos_header; + PIMAGE_NT_HEADERS nt_header; + PIMAGE_SECTION_HEADER section, data_section; + unsigned char *ptr; + int i; + + dos_header = (PIMAGE_DOS_HEADER) p_infile->file_base; + if (dos_header->e_magic != IMAGE_DOS_SIGNATURE) + { + printf ("Unknown EXE header in %s...bailing.\n", p_infile->name); + exit (1); + } + nt_header = (PIMAGE_NT_HEADERS) (((unsigned long) dos_header) + + dos_header->e_lfanew); + if (nt_header == NULL) + { + printf ("Failed to find IMAGE_NT_HEADER in %s...bailing.\n", + p_infile->name); + exit (1); + } + + /* Check the NT header signature ... */ + if (nt_header->Signature != IMAGE_NT_SIGNATURE) + { + printf ("Invalid IMAGE_NT_SIGNATURE 0x%lx in %s...bailing.\n", + nt_header->Signature, p_infile->name); + } + + /* Flip through the sections for .data and .bss ... */ + section = (PIMAGE_SECTION_HEADER) IMAGE_FIRST_SECTION (nt_header); + for (i = 0; i < nt_header->FileHeader.NumberOfSections; i++) + { +#ifdef SEPARATE_BSS_SECTION + if (!strcmp (section->Name, ".bss")) + { + /* The .bss section. */ + ptr = (char *) nt_header->OptionalHeader.ImageBase + + section->VirtualAddress; + bss_start = ptr; + bss_size = get_section_size (section); + } +#endif +#if 0 + if (!strcmp (section->Name, ".data")) + { + /* From lastfile.c */ + extern char my_edata[]; + + /* The .data section. */ + data_section = section; + ptr = (char *) nt_header->OptionalHeader.ImageBase + + section->VirtualAddress; + data_start_va = ptr; + data_start_file = section->PointerToRawData; + + /* We want to only write Emacs data back to the executable, + not any of the library data (if library data is included, + then a dumped Emacs won't run on system versions other + than the one Emacs was dumped on). */ + data_size = my_edata - data_start_va; + } +#else +#ifdef emacs + #define DATA_SECTION "EMDATA" +#else +#define DATA_SECTION ".data" +#endif + if (!strcmp ((char *)section->Name, DATA_SECTION)) + { + /* The Emacs initialized data section. */ + data_section = section; + ptr = (unsigned char *) nt_header->OptionalHeader.ImageBase + + section->VirtualAddress; + data_start_va = ptr; + data_start_file = section->PointerToRawData; + + /* Write back the full section. */ + data_size = get_section_size (section); + } +#endif + section++; + } + +#ifdef SEPARATE_BSS_SECTION + if (bss_start == UNINIT_PTR && bss_size == UNINIT_LONG) + { + /* Starting with MSVC 4.0, the .bss section has been eliminated + and appended virtually to the end of the .data section. Our + only hint about where the .bss section starts in the address + comes from the SizeOfRawData field in the .data section + header. Unfortunately, this field is only approximate, as it + is a rounded number and is typically rounded just beyond the + start of the .bss section. To find the start and size of the + .bss section exactly, we have to peek into the map file. */ + get_bss_info_from_map_file (p_infile, &ptr, &bss_size); + bss_start = ptr + nt_header->OptionalHeader.ImageBase + + data_section->VirtualAddress; + } +#else +/* As noted in lastfile.c, the Alpha (but not the Intel) MSVC linker + globally segregates all static and public bss data (ie. across all + linked modules, not just per module), so we must take both static and + public bss areas into account to determine the true extent of the bss + area used by Emacs. + + To be strictly correct, we should dump the static and public bss + areas used by Emacs separately if non-overlapping (since otherwise we + are dumping bss data belonging to system libraries, eg. the static + bss system data on the Alpha). However, in practice this doesn't + seem to matter, since presumably the system libraries always + reinitialize their bss variables. */ + bss_start = (unsigned char *)min (my_begbss, my_begbss_static); + bss_size = max ((char *)my_endbss, (char *) my_endbss_static) - (char *) bss_start; + +#endif +} + + +/* The dump routines. */ + +static void +copy_executable_and_dump_data_section (file_data *p_infile, + file_data *p_outfile) +{ + unsigned char *data_file, *data_va; + unsigned long size, index; + + /* Get a pointer to where the raw data should go in the executable file. */ + data_file = (unsigned char *) p_outfile->file_base + data_start_file; + + /* Get a pointer to the raw data in our address space. */ + data_va = data_start_va; + + size = (DWORD) data_file - (DWORD) p_outfile->file_base; + /* printf ("Copying executable up to data section...\n"); */ + /* printf ("\t0x%08x Offset in input file.\n", 0); */ + /* printf ("\t0x%08x Offset in output file.\n", 0); */ + /* printf ("\t0x%08lx Size in bytes.\n", size); */ + memcpy (p_outfile->file_base, p_infile->file_base, size); + + size = data_size; + /* printf ("Dumping .data section...\n"); */ + /* printf ("\t0x%p Address in process.\n", data_va); */ + /* printf ("\t0x%08x Offset in output file.\n", */ + /* data_file - p_outfile->file_base); */ + /* printf ("\t0x%08lx Size in bytes.\n", size); */ + memcpy (data_file, data_va, size); + + index = (DWORD) data_file + size - (DWORD) p_outfile->file_base; + size = p_infile->size - index; + /* printf ("Copying rest of executable...\n"); */ + /* printf ("\t0x%08lx Offset in input file.\n", index); */ + /* printf ("\t0x%08lx Offset in output file.\n", index); */ + /* printf ("\t0x%08lx Size in bytes.\n", size); */ + memcpy ((char *) p_outfile->file_base + index, + (char *) p_infile->file_base + index, size); +} + +static void +dump_bss_and_heap (file_data *p_infile, file_data *p_outfile) +{ + unsigned char *heap_data, *bss_data; + unsigned long size, index; + + /* printf ("Dumping heap into executable...\n"); */ + + index = heap_index_in_executable; + size = get_committed_heap_size (); + heap_data = get_heap_start (); + + /* printf ("\t0x%p Heap start in process.\n", heap_data); */ + /* printf ("\t0x%08lx Heap offset in executable.\n", index); */ + /* printf ("\t0x%08lx Heap size in bytes.\n", size); */ + + memcpy ((PUCHAR) p_outfile->file_base + index, heap_data, size); + + /* printf ("Dumping .bss into executable...\n"); */ + + index += size; + size = bss_size; + bss_data = bss_start; + + /* printf ("\t0x%p BSS start in process.\n", bss_data); */ + /* printf ("\t0x%08lx BSS offset in executable.\n", index); */ + /* printf ("\t0x%08lx BSS size in bytes.\n", size); */ + memcpy ((char *) p_outfile->file_base + index, bss_data, size); +} + + +/* Reload and remap routines. */ + + +/* Load the dumped .bss section into the .bss area of our address space. */ +void +read_in_bss (char *filename) +{ + HANDLE file; + DWORD index, n_read; + int i; + + file = CreateFile (filename, GENERIC_READ, FILE_SHARE_READ, NULL, + OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); + if (file == INVALID_HANDLE_VALUE) + { + i = GetLastError (); + exit (1); + } + + /* Seek to where the .bss section is tucked away after the heap... */ + index = heap_index_in_executable + get_committed_heap_size (); + if (SetFilePointer (file, index, NULL, FILE_BEGIN) == 0xFFFFFFFF) + { + i = GetLastError (); + exit (1); + } + + + /* Ok, read in the saved .bss section and initialize all + uninitialized variables. */ + if (!ReadFile (file, bss_start, bss_size, &n_read, (void *)NULL)) + { + i = GetLastError (); + exit (1); + } + + CloseHandle (file); +} + +/* Map the heap dumped into the executable file into our address space. */ +void +map_in_heap (char *filename) +{ + HANDLE file; + HANDLE file_mapping; + void *file_base; + DWORD size, upper_size, n_read; + int i; + + file = CreateFile (filename, GENERIC_READ, FILE_SHARE_READ, NULL, + OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); + if (file == INVALID_HANDLE_VALUE) + { + i = GetLastError (); + exit (1); + } + + size = GetFileSize (file, &upper_size); + file_mapping = CreateFileMapping (file, NULL, PAGE_WRITECOPY, + 0, size, NULL); + if (!file_mapping) + { + i = GetLastError (); + exit (1); + } + + size = get_committed_heap_size (); + file_base = MapViewOfFileEx (file_mapping, FILE_MAP_COPY, 0, + heap_index_in_executable, size, + get_heap_start ()); + if (file_base != 0) + { + return; + } + + /* If we don't succeed with the mapping, then copy from the + data into the heap. */ + + CloseHandle (file_mapping); + + if (VirtualAlloc (get_heap_start (), get_committed_heap_size (), + MEM_RESERVE | MEM_COMMIT, PAGE_READWRITE) == NULL) + { + i = GetLastError (); + exit (1); + } + + /* Seek to the location of the heap data in the executable. */ + i = heap_index_in_executable; + if (SetFilePointer (file, i, NULL, FILE_BEGIN) == 0xFFFFFFFF) + { + i = GetLastError (); + exit (1); + } + + /* Read in the data. */ + if (!ReadFile (file, get_heap_start (), + get_committed_heap_size (), &n_read, (void *)NULL)) + { + i = GetLastError (); + exit (1); + } + + CloseHandle (file); +} + +/* ntheap.c */ +/* Heap management routines for GNU Emacs on Windows NT. + Copyright (C) 1994 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. + + Geoff Voelker (voelker@cs.washington.edu) 7-29-94 +*/ +/* + +*/ +/* #include "lisp.h" */ /* for VALMASK */ +#define VALMASK -1 +/* try for 500 MB of address space */ +#define VALBITS 29 + +/* This gives us the page size and the size of the allocation unit on NT. */ +SYSTEM_INFO sysinfo_cache; +unsigned long syspage_mask = 0; + +/* These are defined to get Emacs to compile, but are not used. */ +int edata; +int etext; + +/* The major and minor versions of NT. */ +int nt_major_version; +int nt_minor_version; + +/* Distinguish between Windows NT and Windows 95. */ +int os_subtype; + +/* Cache information describing the NT system for later use. */ +void +cache_system_info (void) +{ + union + { + struct info + { + char major; + char minor; + short platform; + } info; + DWORD data; + } version; + + /* Cache the version of the operating system. */ + version.data = GetVersion (); + nt_major_version = version.info.major; + nt_minor_version = version.info.minor; + + if (version.info.platform & 0x8000) + os_subtype = OS_WIN95; + else + os_subtype = OS_NT; + + /* Cache page size, allocation unit, processor type, etc. */ + GetSystemInfo (&sysinfo_cache); + syspage_mask = sysinfo_cache.dwPageSize - 1; +} + +/* Round ADDRESS up to be aligned with ALIGN. */ +unsigned char * +round_to_next (unsigned char *address, unsigned long align) +{ + unsigned long tmp; + + tmp = (unsigned long) address; + tmp = (tmp + align - 1) / align; + + return (unsigned char *) (tmp * align); +} + + +/* The start of the data segment. */ +unsigned char * +get_data_start (void) +{ + return data_region_base; +} + +/* The end of the data segment. */ +unsigned char * +get_data_end (void) +{ + return data_region_end; +} + +unsigned long +probe_heap_size(void *base,unsigned long try,unsigned long inc,unsigned long max) { + void *r; + if (!(r=VirtualAlloc(base,try,MEM_RESERVE,PAGE_NOACCESS))) + return try>inc ? probe_heap_size(base,try-inc,inc>>1,max) : 0; + VirtualFree (r, 0, MEM_RELEASE); + return (!inc || try >=max) ? try : probe_heap_size(base,try+inc,inc,max); +} + +static char * +allocate_heap (void) +{ + /* The base address for our GNU malloc heap is chosen in conjuction + with the link settings for temacs.exe which control the stack size, + the initial default process heap size and the executable image base + address. The link settings and the malloc heap base below must all + correspond; the relationship between these values depends on how NT + and Win95 arrange the virtual address space for a process (and on + the size of the code and data segments in temacs.exe). + + The most important thing is to make base address for the executable + image high enough to leave enough room between it and the 4MB floor + of the process address space on Win95 for the primary thread stack, + the process default heap, and other assorted odds and ends + (eg. environment strings, private system dll memory etc) that are + allocated before temacs has a chance to grab its malloc arena. The + malloc heap base can then be set several MB higher than the + executable image base, leaving enough room for the code and data + segments. + + Because some parts of Emacs can use rather a lot of stack space + (for instance, the regular expression routines can potentially + allocate several MB of stack space) we allow 8MB for the stack. + + Allowing 1MB for the default process heap, and 1MB for odds and + ends, we can base the executable at 16MB and still have a generous + safety margin. At the moment, the executable has about 810KB of + code (for x86) and about 550KB of data - on RISC platforms the code + size could be roughly double, so if we allow 4MB for the executable + we will have plenty of room for expansion. + + Thus we would like to set the malloc heap base to 20MB. However, + Win95 refuses to allocate the heap starting at this address, so we + set the base to 27MB to make it happy. Since Emacs now leaves + 28 bits available for pointers, this lets us use the remainder of + the region below the 256MB line for our malloc arena - 229MB is + still a pretty decent arena to play in! */ + +#if defined(__CYGWIN__) +#define PROBE_BASE NULL +#elif defined(__MINGW32__) +#define PROBE_BASE (void *)0x20000000 +#else +#error Need PROBE_BASE +#endif + + void *base = PROBE_BASE,*ptr;/*FIXME, someday figure out how to let the heap start address default *//*(void *)0x10100000*/ + + reserved_heap_size=probe_heap_size(base,PAGESIZE,(1UL<<31),-1); + ptr = VirtualAlloc ((void *) base,get_reserved_heap_size (),MEM_RESERVE,PAGE_NOACCESS); + /* printf("probe results: %lu at %p\n",reserved_heap_size,ptr); */ + + DBEGIN = (DBEGIN_TY) ptr; + + return ptr; + +} + +/* Emulate Unix sbrk. */ +void * +sbrk (ptrdiff_t increment) +{ + void *result; + long size = (long) increment; + + /* Allocate our heap if we haven't done so already. */ + if (data_region_base == UNINIT_PTR) + { + data_region_base = (unsigned char *)allocate_heap (); + if (!data_region_base) + return NULL; + + /* Ensure that the addresses don't use the upper tag bits since + the Lisp type goes there. */ + if (((unsigned long) data_region_base & ~VALMASK) != 0) + { + printf ("Error: The heap was allocated in upper memory.\n"); + exit (1); + } + + data_region_end = data_region_base; + real_data_region_end = data_region_end; + data_region_size = get_reserved_heap_size (); + } + + result = data_region_end; + + /* If size is negative, shrink the heap by decommitting pages. */ + if (size < 0) + { + int new_size; + unsigned char *new_data_region_end; + + size = -size; + + /* Sanity checks. */ + if ((data_region_end - size) < data_region_base) + return NULL; + + /* We can only decommit full pages, so allow for + partial deallocation [cga]. */ + new_data_region_end = (data_region_end - size); + new_data_region_end = (unsigned char *) + ((long) (new_data_region_end + syspage_mask) & ~syspage_mask); + new_size = real_data_region_end - new_data_region_end; + real_data_region_end = new_data_region_end; + if (new_size > 0) + { + /* Decommit size bytes from the end of the heap. */ + if (!VirtualFree (real_data_region_end, new_size, MEM_DECOMMIT)) + return NULL; + } + + data_region_end -= size; + } + /* If size is positive, grow the heap by committing reserved pages. */ + else if (size > 0) + { + /* Sanity checks. */ + if ((data_region_end + size) > + (data_region_base + get_reserved_heap_size ())) + return NULL; + + /* Commit more of our heap. */ + if (VirtualAlloc (data_region_end, size, MEM_COMMIT, + PAGE_READWRITE) == NULL) + return NULL; + data_region_end += size; + + /* We really only commit full pages, so record where + the real end of committed memory is [cga]. */ + real_data_region_end = (unsigned char *) + ((long) (data_region_end + syspage_mask) & ~syspage_mask); + } + + return result; +} + +#ifdef __CYGWIN__ +/* Emulate Unix getpagesize. */ +int getpagesize (void) { return 4096; } +#endif + +/* Recreate the heap from the data that was dumped to the executable. + EXECUTABLE_PATH tells us where to find the executable. */ +void +recreate_heap (char *executable_path) { + + unsigned char *tmp; + + /* First reserve the upper part of our heap. (We reserve first + because there have been problems in the past where doing the + mapping first has loaded DLLs into the VA space of our heap.) */ + tmp = VirtualAlloc ((void *) get_heap_end (), + get_reserved_heap_size () - get_committed_heap_size (), + MEM_RESERVE, + PAGE_NOACCESS); + if (!tmp) + exit (1); + + /* We read in the data for the .bss section from the executable + first and map in the heap from the executable second to prevent + any funny interactions between file I/O and file mapping. */ + + read_in_bss (executable_path); + + map_in_heap (executable_path); + + /* Update system version information to match current system. */ + cache_system_info (); + +} + +/* Round the heap up to the given alignment. */ +void +round_heap (unsigned long align) +{ + unsigned long needs_to_be; + unsigned long need_to_alloc; + + needs_to_be = (unsigned long) round_to_next (get_heap_end (), align); + need_to_alloc = needs_to_be - (unsigned long) get_heap_end (); + + if (need_to_alloc) + sbrk (need_to_alloc); +} + +#if (_MSC_VER >= 1000) + +/* MSVC 4.2 invokes these functions from mainCRTStartup to initialize + a heap via HeapCreate. They are normally defined by the runtime, + but we override them here so that the unnecessary HeapCreate call + is not performed. */ + +int __cdecl +_heap_init (void) +{ + /* Stepping through the assembly indicates that mainCRTStartup is + expecting a nonzero success return value. */ + return 1; +} + +void __cdecl +_heap_term (void) + +#endif + + + +#ifdef UNIXSAVE +BOOL ctrl_c_handler (unsigned long type) +{ + extern void sigint(void); + sigint(); + return 0; + +} +#include "save.c" +#endif diff --git a/o/unexsgi.c b/o/unexsgi.c new file mode 100755 index 0000000..7d0a13e --- /dev/null +++ b/o/unexsgi.c @@ -0,0 +1,896 @@ +/* Copyright (C) 1985, 1986, 1987, 1988, 1990, 1992 + Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. + +In other words, you are welcome to use, share and improve this program. +You are forbidden to forbid anyone else to use, share and improve +what you give them. Help stamp out software-hoarding! */ + + +/* + * unexec.c - Convert a running program into an a.out file. + * + * Author: Spencer W. Thomas + * Computer Science Dept. + * University of Utah + * Date: Tue Mar 2 1982 + * Modified heavily since then. + * + * Synopsis: + * unexec (new_name, a_name, data_start, bss_start, entry_address) + * char *new_name, *a_name; + * unsigned data_start, bss_start, entry_address; + * + * Takes a snapshot of the program and makes an a.out format file in the + * file named by the string argument new_name. + * If a_name is non-NULL, the symbol table will be taken from the given file. + * On some machines, an existing a_name file is required. + * + * The boundaries within the a.out file may be adjusted with the data_start + * and bss_start arguments. Either or both may be given as 0 for defaults. + * + * Data_start gives the boundary between the text segment and the data + * segment of the program. The text segment can contain shared, read-only + * program code and literal data, while the data segment is always unshared + * and unprotected. Data_start gives the lowest unprotected address. + * The value you specify may be rounded down to a suitable boundary + * as required by the machine you are using. + * + * Specifying zero for data_start means the boundary between text and data + * should not be the same as when the program was loaded. + * If NO_REMAP is defined, the argument data_start is ignored and the + * segment boundaries are never changed. + * + * Bss_start indicates how much of the data segment is to be saved in the + * a.out file and restored when the program is executed. It gives the lowest + * unsaved address, and is rounded up to a page boundary. The default when 0 + * is given assumes that the entire data segment is to be stored, including + * the previous data and bss as well as any additional storage allocated with + * break (2). + * + * The new file is set up to start at entry_address. + * + * If you make improvements I'd like to get them too. + * harpo!utah-cs!thomas, thomas@Utah-20 + * + */ + +/* Even more heavily modified by james@bigtex.cactus.org of Dell Computer Co. + * ELF support added. + * + * Basic theory: the data space of the running process needs to be + * dumped to the output file. Normally we would just enlarge the size + * of .data, scooting everything down. But we can't do that in ELF, + * because there is often something between the .data space and the + * .bss space. + * + * In the temacs dump below, notice that the Global Offset Table + * (.got) and the Dynamic link data (.dynamic) come between .data1 and + * .bss. It does not work to overlap .data with these fields. + * + * The solution is to create a new .data segment. This segment is + * filled with data from the current process. Since the contents of + * various sections refer to sections by index, the new .data segment + * is made the last in the table to avoid changing any existing index. + + * This is an example of how the section headers are changed. "Addr" + * is a process virtual address. "Offset" is a file offset. + +raid:/nfs/raid/src/dist-18.56/src> dump -h temacs + +temacs: + + **** SECTION HEADER TABLE **** +[No] Type Flags Addr Offset Size Name + Link Info Adralgn Entsize + +[1] 1 2 0x80480d4 0xd4 0x13 .interp + 0 0 0x1 0 + +[2] 5 2 0x80480e8 0xe8 0x388 .hash + 3 0 0x4 0x4 + +[3] 11 2 0x8048470 0x470 0x7f0 .dynsym + 4 1 0x4 0x10 + +[4] 3 2 0x8048c60 0xc60 0x3ad .dynstr + 0 0 0x1 0 + +[5] 9 2 0x8049010 0x1010 0x338 .rel.plt + 3 7 0x4 0x8 + +[6] 1 6 0x8049348 0x1348 0x3 .init + 0 0 0x4 0 + +[7] 1 6 0x804934c 0x134c 0x680 .plt + 0 0 0x4 0x4 + +[8] 1 6 0x80499cc 0x19cc 0x3c56f .text + 0 0 0x4 0 + +[9] 1 6 0x8085f3c 0x3df3c 0x3 .fini + 0 0 0x4 0 + +[10] 1 2 0x8085f40 0x3df40 0x69c .rodata + 0 0 0x4 0 + +[11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1 + 0 0 0x4 0 + +[12] 1 3 0x8088330 0x3f330 0x20afc .data + 0 0 0x4 0 + +[13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1 + 0 0 0x4 0 + +[14] 1 3 0x80a96cc 0x606cc 0x1a8 .got + 0 0 0x4 0x4 + +[15] 6 3 0x80a9874 0x60874 0x80 .dynamic + 4 0 0x4 0x8 + +[16] 8 3 0x80a98f4 0x608f4 0x449c .bss + 0 0 0x4 0 + +[17] 2 0 0 0x608f4 0x9b90 .symtab + 18 371 0x4 0x10 + +[18] 3 0 0 0x6a484 0x8526 .strtab + 0 0 0x1 0 + +[19] 3 0 0 0x729aa 0x93 .shstrtab + 0 0 0x1 0 + +[20] 1 0 0 0x72a3d 0x68b7 .comment + 0 0 0x1 0 + +raid:/nfs/raid/src/dist-18.56/src> dump -h xemacs + +xemacs: + + **** SECTION HEADER TABLE **** +[No] Type Flags Addr Offset Size Name + Link Info Adralgn Entsize + +[1] 1 2 0x80480d4 0xd4 0x13 .interp + 0 0 0x1 0 + +[2] 5 2 0x80480e8 0xe8 0x388 .hash + 3 0 0x4 0x4 + +[3] 11 2 0x8048470 0x470 0x7f0 .dynsym + 4 1 0x4 0x10 + +[4] 3 2 0x8048c60 0xc60 0x3ad .dynstr + 0 0 0x1 0 + +[5] 9 2 0x8049010 0x1010 0x338 .rel.plt + 3 7 0x4 0x8 + +[6] 1 6 0x8049348 0x1348 0x3 .init + 0 0 0x4 0 + +[7] 1 6 0x804934c 0x134c 0x680 .plt + 0 0 0x4 0x4 + +[8] 1 6 0x80499cc 0x19cc 0x3c56f .text + 0 0 0x4 0 + +[9] 1 6 0x8085f3c 0x3df3c 0x3 .fini + 0 0 0x4 0 + +[10] 1 2 0x8085f40 0x3df40 0x69c .rodata + 0 0 0x4 0 + +[11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1 + 0 0 0x4 0 + +[12] 1 3 0x8088330 0x3f330 0x20afc .data + 0 0 0x4 0 + +[13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1 + 0 0 0x4 0 + +[14] 1 3 0x80a96cc 0x606cc 0x1a8 .got + 0 0 0x4 0x4 + +[15] 6 3 0x80a9874 0x60874 0x80 .dynamic + 4 0 0x4 0x8 + +[16] 8 3 0x80c6800 0x7d800 0 .bss + 0 0 0x4 0 + +[17] 2 0 0 0x7d800 0x9b90 .symtab + 18 371 0x4 0x10 + +[18] 3 0 0 0x87390 0x8526 .strtab + 0 0 0x1 0 + +[19] 3 0 0 0x8f8b6 0x93 .shstrtab + 0 0 0x1 0 + +[20] 1 0 0 0x8f949 0x68b7 .comment + 0 0 0x1 0 + +[21] 1 3 0x80a98f4 0x608f4 0x1cf0c .data + 0 0 0x4 0 + + * This is an example of how the file header is changed. "Shoff" is + * the section header offset within the file. Since that table is + * after the new .data section, it is moved. "Shnum" is the number of + * sections, which we increment. + * + * "Phoff" is the file offset to the program header. "Phentsize" and + * "Shentsz" are the program and section header entries sizes respectively. + * These can be larger than the apparent struct sizes. + +raid:/nfs/raid/src/dist-18.56/src> dump -f temacs + +temacs: + + **** ELF HEADER **** +Class Data Type Machine Version +Entry Phoff Shoff Flags Ehsize +Phentsize Phnum Shentsz Shnum Shstrndx + +1 1 2 3 1 +0x80499cc 0x34 0x792f4 0 0x34 +0x20 5 0x28 21 19 + +raid:/nfs/raid/src/dist-18.56/src> dump -f xemacs + +xemacs: + + **** ELF HEADER **** +Class Data Type Machine Version +Entry Phoff Shoff Flags Ehsize +Phentsize Phnum Shentsz Shnum Shstrndx + +1 1 2 3 1 +0x80499cc 0x34 0x96200 0 0x34 +0x20 5 0x28 22 19 + + * These are the program headers. "Offset" is the file offset to the + * segment. "Vaddr" is the memory load address. "Filesz" is the + * segment size as it appears in the file, and "Memsz" is the size in + * memory. Below, the third segment is the code and the fourth is the + * data: the difference between Filesz and Memsz is .bss + +raid:/nfs/raid/src/dist-18.56/src> dump -o temacs + +temacs: + ***** PROGRAM EXECUTION HEADER ***** +Type Offset Vaddr Paddr +Filesz Memsz Flags Align + +6 0x34 0x8048034 0 +0xa0 0xa0 5 0 + +3 0xd4 0 0 +0x13 0 4 0 + +1 0x34 0x8048034 0 +0x3f2f9 0x3f2f9 5 0x1000 + +1 0x3f330 0x8088330 0 +0x215c4 0x25a60 7 0x1000 + +2 0x60874 0x80a9874 0 +0x80 0 7 0 + +raid:/nfs/raid/src/dist-18.56/src> dump -o xemacs + +xemacs: + ***** PROGRAM EXECUTION HEADER ***** +Type Offset Vaddr Paddr +Filesz Memsz Flags Align + +6 0x34 0x8048034 0 +0xa0 0xa0 5 0 + +3 0xd4 0 0 +0x13 0 4 0 + +1 0x34 0x8048034 0 +0x3f2f9 0x3f2f9 5 0x1000 + +1 0x3f330 0x8088330 0 +0x3e4d0 0x3e4d0 7 0x1000 + +2 0x60874 0x80a9874 0 +0x80 0 7 0 + + + */ + +/* Modified by wtien@urbana.mcd.mot.com of Motorola Inc. + * + * The above mechanism does not work if the unexeced ELF file is being + * re-layout by other applications (such as `strip'). All the applications + * that re-layout the internal of ELF will layout all sections in ascending + * order of their file offsets. After the re-layout, the data2 section will + * still be the LAST section in the section header vector, but its file offset + * is now being pushed far away down, and causes part of it not to be mapped + * in (ie. not covered by the load segment entry in PHDR vector), therefore + * causes the new binary to fail. + * + * The solution is to modify the unexec algorithm to insert the new data2 + * section header right before the new bss section header, so their file + * offsets will be in the ascending order. Since some of the section's (all + * sections AFTER the bss section) indexes are now changed, we also need to + * modify some fields to make them point to the right sections. This is done + * by macro PATCH_INDEX. All the fields that need to be patched are: + * + * 1. ELF header e_shstrndx field. + * 2. section header sh_link and sh_info field. + * 3. symbol table entry st_shndx field. + * + * The above example now should look like: + + **** SECTION HEADER TABLE **** +[No] Type Flags Addr Offset Size Name + Link Info Adralgn Entsize + +[1] 1 2 0x80480d4 0xd4 0x13 .interp + 0 0 0x1 0 + +[2] 5 2 0x80480e8 0xe8 0x388 .hash + 3 0 0x4 0x4 + +[3] 11 2 0x8048470 0x470 0x7f0 .dynsym + 4 1 0x4 0x10 + +[4] 3 2 0x8048c60 0xc60 0x3ad .dynstr + 0 0 0x1 0 + +[5] 9 2 0x8049010 0x1010 0x338 .rel.plt + 3 7 0x4 0x8 + +[6] 1 6 0x8049348 0x1348 0x3 .init + 0 0 0x4 0 + +[7] 1 6 0x804934c 0x134c 0x680 .plt + 0 0 0x4 0x4 + +[8] 1 6 0x80499cc 0x19cc 0x3c56f .text + 0 0 0x4 0 + +[9] 1 6 0x8085f3c 0x3df3c 0x3 .fini + 0 0 0x4 0 + +[10] 1 2 0x8085f40 0x3df40 0x69c .rodata + 0 0 0x4 0 + +[11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1 + 0 0 0x4 0 + +[12] 1 3 0x8088330 0x3f330 0x20afc .data + 0 0 0x4 0 + +[13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1 + 0 0 0x4 0 + +[14] 1 3 0x80a96cc 0x606cc 0x1a8 .got + 0 0 0x4 0x4 + +[15] 6 3 0x80a9874 0x60874 0x80 .dynamic + 4 0 0x4 0x8 + +[16] 1 3 0x80a98f4 0x608f4 0x1cf0c .data + 0 0 0x4 0 + +[17] 8 3 0x80c6800 0x7d800 0 .bss + 0 0 0x4 0 + +[18] 2 0 0 0x7d800 0x9b90 .symtab + 19 371 0x4 0x10 + +[19] 3 0 0 0x87390 0x8526 .strtab + 0 0 0x1 0 + +[20] 3 0 0 0x8f8b6 0x93 .shstrtab + 0 0 0x1 0 + +[21] 1 0 0 0x8f949 0x68b7 .comment + 0 0 0x1 0 + + */ + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include /* for HDRR declaration */ +#include + +#ifndef emacs +#define fatal(a, b, c) fprintf(stderr, a, b, c), exit(1) +#else +extern void fatal(char *, ...); +#endif + +/* Get the address of a particular section or program header entry, + * accounting for the size of the entries. + */ + +#define OLD_SECTION_H(n) \ + (*(Elf32_Shdr *) ((byte *) old_section_h + old_file_h->e_shentsize * (n))) +#define NEW_SECTION_H(n) \ + (*(Elf32_Shdr *) ((byte *) new_section_h + new_file_h->e_shentsize * (n))) +#define OLD_PROGRAM_H(n) \ + (*(Elf32_Phdr *) ((byte *) old_program_h + old_file_h->e_phentsize * (n))) +#define NEW_PROGRAM_H(n) \ + (*(Elf32_Phdr *) ((byte *) new_program_h + new_file_h->e_phentsize * (n))) + +#define PATCH_INDEX(n) \ + do { \ + if ((n) >= old_bss_index) \ + (n)++; } while (0) +typedef unsigned char byte; + +/* Round X up to a multiple of Y. */ + +int +round_up (x, y) + int x, y; +{ + int rem = x % y; + if (rem == 0) + return x; + return x - rem + y; +} + +/* Return the index of the section named NAME. + SECTION_NAMES, FILE_NAME and FILE_H give information + about the file we are looking in. + + If we don't find the section NAME, that is a fatal error + if NOERROR is 0; we return -1 if NOERROR is nonzero. */ + +static int +find_section (name, section_names, file_name, old_file_h, old_section_h, noerror) + char *name; + char *section_names; + char *file_name; + Elf32_Ehdr *old_file_h; + Elf32_Shdr *old_section_h; + int noerror; +{ + int idx; + + for (idx = 1; idx < old_file_h->e_shnum; idx++) + { +#ifdef DEBUG + fprintf (stderr, "Looking for %s - found %s\n", name, + section_names + OLD_SECTION_H (idx).sh_name); +#endif + if (!strcmp (section_names + OLD_SECTION_H (idx).sh_name, + name)) + break; + } + if (idx == old_file_h->e_shnum) + { + if (noerror) + return -1; + else + fatal ("Can't find .bss in %s.\n", file_name, 0); + } + + return idx; +} + +/* **************************************************************** + * unexec + * + * driving logic. + * + * In ELF, this works by replacing the old .bss section with a new + * .data section, and inserting an empty .bss immediately afterwards. + * + */ +void +unexec (new_name, old_name, data_start, bss_start, entry_address) + char *new_name, *old_name; + unsigned data_start, bss_start, entry_address; +{ + extern unsigned int bss_end; + int new_file, old_file, new_file_size; + + /* Pointers to the base of the image of the two files. */ + caddr_t old_base, new_base; + + /* Pointers to the file, program and section headers for the old and new + files. */ + Elf32_Ehdr *old_file_h, *new_file_h; + Elf32_Phdr *old_program_h, *new_program_h; + Elf32_Shdr *old_section_h, *new_section_h; + + /* Point to the section name table in the old file. */ + char *old_section_names; + + Elf32_Addr old_bss_addr, new_bss_addr; + Elf32_Word old_bss_size, new_data2_size; + Elf32_Off new_data2_offset; + Elf32_Addr new_data2_addr; + Elf32_Addr new_offsets_shift; + + int n, nn, old_bss_index, old_data_index, new_data2_index; + int old_mdebug_index; + struct stat stat_buf; + + /* Open the old file & map it into the address space. */ + + old_file = open (old_name, O_RDONLY); + + if (old_file < 0) + fatal ("Can't open %s for reading: errno %d\n", old_name, errno); + + if (fstat (old_file, &stat_buf) == -1) + fatal ("Can't fstat(%s): errno %d\n", old_name, errno); + + old_base = mmap (0, stat_buf.st_size, PROT_READ, MAP_SHARED, old_file, 0); + + if (old_base == (caddr_t) -1) + fatal ("Can't mmap(%s): errno %d\n", old_name, errno); + +#ifdef DEBUG + fprintf (stderr, "mmap(%s, %x) -> %x\n", old_name, stat_buf.st_size, + old_base); +#endif + + /* Get pointers to headers & section names. */ + + old_file_h = (Elf32_Ehdr *) old_base; + old_program_h = (Elf32_Phdr *) ((byte *) old_base + old_file_h->e_phoff); + old_section_h = (Elf32_Shdr *) ((byte *) old_base + old_file_h->e_shoff); + old_section_names + = (char *) old_base + OLD_SECTION_H (old_file_h->e_shstrndx).sh_offset; + + /* Find the mdebug section, if any. */ + + old_mdebug_index = find_section (".mdebug", old_section_names, + old_name, old_file_h, old_section_h, 1); + + /* Find the old .bss section. */ + + old_bss_index = find_section (".bss", old_section_names, + old_name, old_file_h, old_section_h, 0); + + /* Find the old .data section. Figure out parameters of + the new data2 and bss sections. */ + + old_data_index = find_section (".data", old_section_names, + old_name, old_file_h, old_section_h, 0); + + old_bss_addr = OLD_SECTION_H (old_bss_index).sh_addr; + old_bss_size = OLD_SECTION_H (old_bss_index).sh_size; +#if defined(emacs) || !defined(DEBUG) + bss_end = (unsigned int) sbrk (0); + new_bss_addr = (Elf32_Addr) bss_end; + /* add for gcl */ + core_end = (char *) bss_end; +#else + new_bss_addr = old_bss_addr + old_bss_size + 0x1234; +#endif + new_data2_addr = old_bss_addr; + new_data2_size = new_bss_addr - old_bss_addr; + new_data2_offset = OLD_SECTION_H (old_data_index).sh_offset + + (new_data2_addr - OLD_SECTION_H (old_data_index).sh_addr); + new_offsets_shift = new_bss_addr - + ((old_bss_addr & ~0xfff) + ((old_bss_addr & 0xfff) ? 0x1000 : 0)); + +#ifdef DEBUG + fprintf (stderr, "old_bss_index %d\n", old_bss_index); + fprintf (stderr, "old_bss_addr %x\n", old_bss_addr); + fprintf (stderr, "old_bss_size %x\n", old_bss_size); + fprintf (stderr, "new_bss_addr %x\n", new_bss_addr); + fprintf (stderr, "new_data2_addr %x\n", new_data2_addr); + fprintf (stderr, "new_data2_size %x\n", new_data2_size); + fprintf (stderr, "new_data2_offset %x\n", new_data2_offset); + fprintf (stderr, "new_offsets_shift %x\n", new_offsets_shift); +#endif + + if ((unsigned) new_bss_addr < (unsigned) old_bss_addr + old_bss_size) + fatal (".bss shrank when undumping???\n", 0, 0); + + /* Set the output file to the right size and mmap it. Set + pointers to various interesting objects. stat_buf still has + old_file data. */ + + new_file = open (new_name, O_RDWR | O_CREAT, 0666); + if (new_file < 0) + fatal ("Can't creat (%s): errno %d\n", new_name, errno); + + new_file_size = stat_buf.st_size + old_file_h->e_shentsize + new_offsets_shift; + + if (ftruncate (new_file, new_file_size)) + fatal ("Can't ftruncate (%s): errno %d\n", new_name, errno); + + new_base = mmap (0, new_file_size, PROT_READ | PROT_WRITE, MAP_SHARED, + new_file, 0); + + if (new_base == (caddr_t) -1) + fatal ("Can't mmap (%s): errno %d\n", new_name, errno); + + new_file_h = (Elf32_Ehdr *) new_base; + new_program_h = (Elf32_Phdr *) ((byte *) new_base + old_file_h->e_phoff); + new_section_h + = (Elf32_Shdr *) ((byte *) new_base + old_file_h->e_shoff + + new_offsets_shift); + + /* Make our new file, program and section headers as copies of the + originals. */ + + memcpy (new_file_h, old_file_h, old_file_h->e_ehsize); + memcpy (new_program_h, old_program_h, + old_file_h->e_phnum * old_file_h->e_phentsize); + + /* Modify the e_shstrndx if necessary. */ + PATCH_INDEX (new_file_h->e_shstrndx); + + /* Fix up file header. We'll add one section. Section header is + further away now. */ + + new_file_h->e_shoff += new_offsets_shift; + new_file_h->e_shnum += 1; + +#ifdef DEBUG + fprintf (stderr, "Old section offset %x\n", old_file_h->e_shoff); + fprintf (stderr, "Old section count %d\n", old_file_h->e_shnum); + fprintf (stderr, "New section offset %x\n", new_file_h->e_shoff); + fprintf (stderr, "New section count %d\n", new_file_h->e_shnum); +#endif + + /* Fix up a new program header. Extend the writable data segment so + that the bss area is covered too. Find that segment by looking + for a segment that ends just before the .bss area. Make sure + that no segments are above the new .data2. Put a loop at the end + to adjust the offset and address of any segment that is above + data2, just in case we decide to allow this later. */ + + for (n = new_file_h->e_phnum - 1; n >= 0; n--) + { + /* Compute maximum of all requirements for alignment of section. */ + int alignment = (NEW_PROGRAM_H (n)).p_align; + if ((OLD_SECTION_H (old_bss_index)).sh_addralign > alignment) + alignment = OLD_SECTION_H (old_bss_index).sh_addralign; + + /* Supposedly this condition is okay for the SGI. */ +#if 0 + if (NEW_PROGRAM_H (n).p_vaddr + NEW_PROGRAM_H (n).p_filesz > old_bss_addr) + fatal ("Program segment above .bss in %s\n", old_name, 0); +#endif + + if (NEW_PROGRAM_H (n).p_type == PT_LOAD + && (round_up ((NEW_PROGRAM_H (n)).p_vaddr + + (NEW_PROGRAM_H (n)).p_filesz, + alignment) + == round_up (old_bss_addr, alignment))) + break; + } + if (n < 0) + fatal ("Couldn't find segment next to .bss in %s\n", old_name, 0); + + NEW_PROGRAM_H (n).p_filesz += new_offsets_shift; + NEW_PROGRAM_H (n).p_memsz = NEW_PROGRAM_H (n).p_filesz; + +#if 1 /* Maybe allow section after data2 - does this ever happen? */ + for (n = new_file_h->e_phnum - 1; n >= 0; n--) + { + if (NEW_PROGRAM_H (n).p_vaddr + && NEW_PROGRAM_H (n).p_vaddr >= new_data2_addr) + NEW_PROGRAM_H (n).p_vaddr += new_offsets_shift - old_bss_size; + + if (NEW_PROGRAM_H (n).p_offset >= new_data2_offset) + NEW_PROGRAM_H (n).p_offset += new_offsets_shift; + } +#endif + + /* Fix up section headers based on new .data2 section. Any section + whose offset or virtual address is after the new .data2 section + gets its value adjusted. .bss size becomes zero and new address + is set. data2 section header gets added by copying the existing + .data header and modifying the offset, address and size. */ + for (old_data_index = 1; old_data_index < old_file_h->e_shnum; + old_data_index++) + if (!strcmp (old_section_names + OLD_SECTION_H (old_data_index).sh_name, + ".data")) + break; + if (old_data_index == old_file_h->e_shnum) + fatal ("Can't find .data in %s.\n", old_name, 0); + + /* Walk through all section headers, insert the new data2 section right + before the new bss section. */ + for (n = 1, nn = 1; n < old_file_h->e_shnum; n++, nn++) + { + caddr_t src; + + /* If it is bss section, insert the new data2 section before it. */ + if (n == old_bss_index) + { + /* Steal the data section header for this data2 section. */ + memcpy (&NEW_SECTION_H (nn), &OLD_SECTION_H (old_data_index), + new_file_h->e_shentsize); + + NEW_SECTION_H (nn).sh_addr = new_data2_addr; + NEW_SECTION_H (nn).sh_offset = new_data2_offset; + NEW_SECTION_H (nn).sh_size = new_data2_size; + /* Use the bss section's alignment. This will assure that the + new data2 section always be placed in the same spot as the old + bss section by any other application. */ + NEW_SECTION_H (nn).sh_addralign = OLD_SECTION_H (n).sh_addralign; + + /* Now copy over what we have in the memory now. */ + memcpy (NEW_SECTION_H (nn).sh_offset + new_base, + (caddr_t) OLD_SECTION_H (n).sh_addr, + new_data2_size); + nn++; + memcpy (&NEW_SECTION_H (nn), &OLD_SECTION_H (n), + old_file_h->e_shentsize); + + /* The new bss section's size is zero, and its file offset and virtual + address should be off by NEW_OFFSETS_SHIFT. */ + NEW_SECTION_H (nn).sh_offset += new_offsets_shift; + NEW_SECTION_H (nn).sh_addr = new_bss_addr; + /* Let the new bss section address alignment be the same as the + section address alignment followed the old bss section, so + this section will be placed in exactly the same place. */ + NEW_SECTION_H (nn).sh_addralign = OLD_SECTION_H (nn).sh_addralign; + NEW_SECTION_H (nn).sh_size = 0; + } + else + memcpy (&NEW_SECTION_H (nn), &OLD_SECTION_H (n), + old_file_h->e_shentsize); + + /* Any section that was original placed AFTER the bss + section must now be adjusted by NEW_OFFSETS_SHIFT. */ + + if (NEW_SECTION_H (nn).sh_offset >= new_data2_offset) + NEW_SECTION_H (nn).sh_offset += new_offsets_shift; + + /* If any section hdr refers to the section after the new .data + section, make it refer to next one because we have inserted + a new section in between. */ + + PATCH_INDEX (NEW_SECTION_H (nn).sh_link); + /* For symbol tables, info is a symbol table index, + so don't change it. */ + if (NEW_SECTION_H (nn).sh_type != SHT_SYMTAB + && NEW_SECTION_H (nn).sh_type != SHT_DYNSYM) + PATCH_INDEX (NEW_SECTION_H (nn).sh_info); + + /* Now, start to copy the content of sections. */ + if (NEW_SECTION_H (nn).sh_type == SHT_NULL + || NEW_SECTION_H (nn).sh_type == SHT_NOBITS) + continue; + + /* Write out the sections. .data and .data1 (and data2, called + ".data" in the strings table) get copied from the current process + instead of the old file. */ + if (!strcmp (old_section_names + NEW_SECTION_H (n).sh_name, ".data") + || !strcmp (old_section_names + NEW_SECTION_H (n).sh_name, ".data1") + || !strcmp (old_section_names + NEW_SECTION_H (n).sh_name, ".got")) + src = (caddr_t) OLD_SECTION_H (n).sh_addr; + else + src = old_base + OLD_SECTION_H (n).sh_offset; + + memcpy (NEW_SECTION_H (nn).sh_offset + new_base, src, + NEW_SECTION_H (nn).sh_size); + + /* Adjust the HDRR offsets in .mdebug and copy the + line data if it's in its usual 'hole' in the object. + Makes the new file debuggable with dbx. + patches up two problems: the absolute file offsets + in the HDRR record of .mdebug (see /usr/include/syms.h), and + the ld bug that gets the line table in a hole in the + elf file rather than in the .mdebug section proper. + David Anderson. davea@sgi.com Jan 16,1994. */ + if (n == old_mdebug_index) + { +#define MDEBUGADJUST(__ct,__fileaddr) \ + if (n_phdrr->__ct > 0) \ + { \ + n_phdrr->__fileaddr += movement; \ + } + + HDRR * o_phdrr = (HDRR *)((byte *)old_base + OLD_SECTION_H (n).sh_offset); + HDRR * n_phdrr = (HDRR *)((byte *)new_base + NEW_SECTION_H (nn).sh_offset); + unsigned movement = new_offsets_shift; + + MDEBUGADJUST (idnMax, cbDnOffset); + MDEBUGADJUST (ipdMax, cbPdOffset); + MDEBUGADJUST (isymMax, cbSymOffset); + MDEBUGADJUST (ioptMax, cbOptOffset); + MDEBUGADJUST (iauxMax, cbAuxOffset); + MDEBUGADJUST (issMax, cbSsOffset); + MDEBUGADJUST (issExtMax, cbSsExtOffset); + MDEBUGADJUST (ifdMax, cbFdOffset); + MDEBUGADJUST (crfd, cbRfdOffset); + MDEBUGADJUST (iextMax, cbExtOffset); + /* The Line Section, being possible off in a hole of the object, + requires special handling. */ + if (n_phdrr->cbLine > 0) + { + if (o_phdrr->cbLineOffset > (OLD_SECTION_H (n).sh_offset + + OLD_SECTION_H (n).sh_size)) + { + /* line data is in a hole in elf. do special copy and adjust + for this ld mistake. + */ + n_phdrr->cbLineOffset += movement; + + memcpy (n_phdrr->cbLineOffset + new_base, + o_phdrr->cbLineOffset + old_base, n_phdrr->cbLine); + } + else + { + /* somehow line data is in .mdebug as it is supposed to be. */ + MDEBUGADJUST (cbLine, cbLineOffset); + } + } + } + + /* If it is the symbol table, its st_shndx field needs to be patched. */ + if (NEW_SECTION_H (nn).sh_type == SHT_SYMTAB + || NEW_SECTION_H (nn).sh_type == SHT_DYNSYM) + { + Elf32_Shdr *spt = &NEW_SECTION_H (nn); + unsigned int num = spt->sh_size / spt->sh_entsize; + Elf32_Sym * sym = (Elf32_Sym *) (NEW_SECTION_H (nn).sh_offset + + new_base); + for (; num--; sym++) + { + if (sym->st_shndx == SHN_UNDEF + || sym->st_shndx == SHN_ABS + || sym->st_shndx == SHN_COMMON) + continue; + + PATCH_INDEX (sym->st_shndx); + } + } + } + + /* Close the files and make the new file executable. */ + + if (close (old_file)) + fatal ("Can't close (%s): errno %d\n", old_name, errno); + + if (close (new_file)) + fatal ("Can't close (%s): errno %d\n", new_name, errno); + + if (stat (new_name, &stat_buf) == -1) + fatal ("Can't stat (%s): errno %d\n", new_name, errno); + + n = umask (777); + umask (n); + stat_buf.st_mode |= 0111 & ~n; + if (chmod (new_name, stat_buf.st_mode) == -1) + fatal ("Can't chmod (%s): errno %d\n", new_name, errno); +} + + +#ifdef UNIXSAVE +#include "save.c" +#endif + diff --git a/o/unixfasl.c b/o/unixfasl.c new file mode 100755 index 0000000..4db6e26 --- /dev/null +++ b/o/unixfasl.c @@ -0,0 +1,416 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#define IN_UNIXFASL +#include "include.h" + +#ifdef UNIXFASL +#include UNIXFASL +#else + +#ifdef HAVE_AOUT +#undef BSD +#undef ATT +#define BSD +#include HAVE_AOUT +#endif + +#ifdef COFF_ENCAPSULATE +#undef BSD +#undef ATT +#define BSD +#include "a.out.encap.h" +#endif + +#ifdef ATT +#include +#include +#include +#endif + +#ifdef E15 +#include +#define exec bhdr +#define a_text tsize +#define a_data dsize +#define a_bss bsize +#define a_syms ssize +#define a_trsize rtsize +#define a_drsize rdsize +#endif + +#ifdef BSD +#define textsize header.a_text +#define datasize header.a_data +#define bsssize header.a_bss +#ifdef COFF_ENCAPSULATE +#define textstart sizeof(header) +sizeof(struct coffheader) +#else +#define textstart sizeof(header) +#endif +#define newbsssize newheader.a_bss +#endif + +#ifndef HEADER_SEEK +#define HEADER_SEEK +#endif + +#ifndef MAXPATHLEN +# define MAXPATHLEN 1024 +#endif + +#ifndef SFASL +int +fasload(faslfile) +object faslfile; +{ + +#ifdef BSD + struct exec header, newheader; +#endif + +#ifdef ATT + struct filehdr fileheader; + struct scnhdr sectionheader; + int textsize, datasize, bsssize; + int textstart; +#endif + +#ifdef E15 + struct exec header; +#define textsize header.a_text +#define datasize header.a_data +#define bsssize header.a_bss +#define textstart sizeof(header) +#endif + + object memory, data, tempfile; + FILE *fp; + char filename[MAXPATHLEN]; + char tempfilename[32]; + char command[MAXPATHLEN * 2]; + int i; + object *old_vs_base = vs_base; + object *old_vs_top = vs_top; +#ifdef IBMRT + +#endif + + coerce_to_filename(faslfile, filename); + + faslfile = open_stream(faslfile, smm_input, Cnil, sKerror); + vs_push(faslfile); + fp = faslfile->sm.sm_fp; + /* seek to beginning of the header */ + + HEADER_SEEK(fp); + +#ifdef BSD + fread(&header, sizeof(header), 1, fp); +#endif +#ifdef ATT + fread(&fileheader, sizeof(fileheader), 1, fp); +#ifdef S3000 + if(fileheader.f_opthdr != 0) fseek(fp,fileheader.f_opthdr,1); +#endif + fread(§ionheader, sizeof(sectionheader), 1, fp); + textsize = sectionheader.s_size; + textstart = sectionheader.s_scnptr; + fread(§ionheader, sizeof(sectionheader), 1, fp); + datasize = sectionheader.s_size; + fread(§ionheader, sizeof(sectionheader), 1, fp); + if (strcmp(sectionheader.s_name, ".bss") == 0) + bsssize = sectionheader.s_size; + else + bsssize = 0; +#endif +#ifdef E15 + fread(&header, sizeof(header), 1, fp); +#endif + + memory = alloc_object(t_cfdata); + memory->cfd.cfd_self = NULL; + memory->cfd.cfd_start = NULL; + memory->cfd.cfd_size = textsize + datasize + bsssize; + vs_push(memory); + /* If the file is smaller than the space asked for, typically the file + is an invalid object file */ + if (file_len(fp)*4 < memory->cfd.cfd_size) + FEerror("Invalid object file stream: ~a",1,faslfile); + memory->cfd.cfd_start = ALLOC_ALIGNED(alloc_contblock, + memory->cfd.cfd_size,sizeof(double)); + +#ifdef SEEK_TO_END_OFILE +SEEK_TO_END_OFILE(fp); +#else +#ifdef BSD + fseek(fp, + header.a_text+header.a_data+ + header.a_syms+header.a_trsize+header.a_drsize, + 1); + fread(&i, sizeof(i), 1, fp); + fseek(fp, i - sizeof(i), 1); +#endif + +#ifdef ATT + fseek(fp, + fileheader.f_symptr + SYMESZ*fileheader.f_nsyms, + 0); + fread(&i, sizeof(i), 1, fp); + fseek(fp, i - sizeof(i), 1); + while ((i = getc(fp)) == 0) + ; + ungetc(i, fp); +#endif + +#ifdef E15 + fseek(fp, + header.a_text+header.a_data+ + header.a_syms+header.a_trsize+header.a_drsize, + 1); +#endif +#endif + data = read_fasl_vector(faslfile); + vs_push(data); + close_stream(faslfile); + + sprintf(tempfilename, "/tmp/fasltemp%d", getpid()); + +AGAIN: + +#ifdef BSD + LD_COMMAND(command, + kcl_self, + memory->cfd.cfd_start, + filename, + " ", + tempfilename); + if(symbol_value(sLAload_verboseA)!=Cnil) + printf("start address -T %x ",memory->cfd.cfd_start); +#endif +#ifdef ATT + coerce_to_filename(symbol_value(sSAsystem_directoryA), + system_directory); + sprintf(command, + "%sild %s %d %s %s", + system_directory, + kcl_self, + memory->cfd.cfd_start, + filename, + tempfilename); +#endif +#ifdef E15 + coerce_to_filename(symbol_value(sSAsystem_directoryA), + system_directory); + sprintf(command, + "%sild %s %d %s %s", + system_directory, + kcl_self, + memory->cfd.cfd_start, + filename, + tempfilename); +#endif + + if (system(command) != 0) + FEerror("The linkage editor failed.", 0); + + tempfile = make_simple_string(tempfilename); + vs_push(tempfile); + tempfile = open_stream(tempfile, smm_input, Cnil, sKerror); + vs_push(tempfile); + fp = tempfile->sm.sm_fp; + + HEADER_SEEK(fp); + +#ifdef BSD + fread(&newheader, sizeof(header), 1, fp); + if (newbsssize != bsssize) { + insert_contblock(memory->cfd.cfd_start, memory->cfd.cfd_size); + bsssize = newbsssize; + memory->cfd.cfd_start = NULL; + memory->cfd.cfd_size = textsize + datasize + bsssize; + memory->cfd.cfd_start = ALLOC_ALIGNED(alloc_contblock,memory->cfd.cfd_size, + sizeof( double)); + close_stream(tempfile); + unlink(tempfilename); + goto AGAIN; + } +#endif + + if (fseek(fp, textstart, 0) < 0) + error("file seek error"); + + fread(memory->cfd.cfd_start, textsize + datasize, 1, fp); + + close_stream(tempfile); + + unlink(tempfilename); + + call_init(0,memory,data,0); + + vs_base = old_vs_base; + vs_top = old_vs_top; + + return(memory->cfd.cfd_size); +} +#endif /* ifndef SFASL */ + +#ifndef __svr4__ +#ifdef BSD + +#define FASLINK +#ifndef PRIVATE_FASLINK + +static int +faslink(object faslfile, object ldargstring) +{ +#if defined(__ELF__) || defined(DARWIN) + FEerror("faslink() not supported for ELF or DARWIN yet",0); + return 0; +#else + struct exec header, faslheader; + object memory, data, tempfile; + FILE *fp; + char filename[MAXPATHLEN]; + char ldargstr[MAXPATHLEN]; + char tempfilename[32]; + char command[MAXPATHLEN * 2]; + char buf[BUFSIZ]; + int i; + object *old_vs_base = vs_base; + object *old_vs_top = vs_top; + + coerce_to_filename(ldargstring, ldargstr); + coerce_to_filename(faslfile, filename); + + sprintf(tempfilename, "/tmp/fasltemp%d", getpid()); + LD_COMMAND(command, + kcl_self, + (int)core_end, + filename, + ldargstr, + tempfilename); + + if (system(command) != 0) + FEerror("The linkage editor failed.", 0); + + fp = fopen(tempfilename, "r"); + setbuf(fp, buf); + fread(&header, sizeof(header), 1, fp); + {BEGIN_NO_INTERRUPT; + memory = alloc_object(t_cfdata); + memory->cfd.cfd_self=0; + memory->cfd.cfd_start = NULL; + memory->cfd.cfd_size = textsize + datasize + bsssize; + vs_push(memory); + memory->cfd.cfd_start = ALLOC_ALIGNED(alloc_contblock, + memory->cfd.cfd_size, + sizeof(double)); + END_NO_INTERRUPT;} + fclose(fp); + + faslfile = open_stream(faslfile, smm_input, Cnil, sKerror); + vs_push(faslfile); +#ifdef SEEK_TO_END_OFILE +SEEK_TO_END_OFILE(faslfile->sm.sm_fp); +#else + fp = faslfile->sm.sm_fp; + fread(&faslheader, sizeof(faslheader), 1, fp); + fseek(fp, + faslheader.a_text+faslheader.a_data+ + faslheader.a_syms+faslheader.a_trsize+faslheader.a_drsize, + 1); + fread(&i, sizeof(i), 1, fp); + fseek(fp, i - sizeof(i), 1); +#endif + data = read_fasl_vector(faslfile); + vs_push(data); + close_stream(faslfile); + LD_COMMAND(command, + kcl_self, + memory->cfd.cfd_start, + filename, + ldargstr, + tempfilename); + if(symbol_value(sLAload_verboseA)!=Cnil) + printf("start address -T %x ",memory->cfd.cfd_start); + if (system(command) != 0) + FEerror("The linkage editor failed.", 0); + + tempfile = make_simple_string(tempfilename); + vs_push(tempfile); + tempfile = open_stream(tempfile, smm_input, Cnil, sKerror); + vs_push(tempfile); + fp = tempfile->sm.sm_fp; + + if (fseek(fp, textstart, 0) < 0) + error("file seek error"); + + fread(memory->cfd.cfd_start, textsize + datasize, 1, fp); + + close_stream(tempfile); + + unlink(tempfilename); + + call_init(0,memory,data,0); + + vs_base = old_vs_base; + vs_top = old_vs_top; + + return(memory->cfd.cfd_size); +#endif +} + +#endif + +static void +FFN(siLfaslink)(void) +{ + bds_ptr old_bds_top; + int i; + object package; + + check_arg(2); + check_type_or_pathname_string_symbol_stream(&vs_base[0]); + check_type_string(&vs_base[1]); + vs_base[0] = coerce_to_pathname(vs_base[0]); + vs_base[0]->pn.pn_type = FASL_string; + vs_base[0] = namestring(vs_base[0]); + package = symbol_value(sLApackageA); + old_bds_top = bds_top; + bds_bind(sLApackageA, package); + i = faslink(vs_base[0], vs_base[1]); + bds_unwind(old_bds_top); + vs_top = vs_base; + vs_push(make_fixnum(i)); +} + +#endif +#endif/* svr4 */ +#endif /* UNIXFASL */ + +void +gcl_init_unixfasl(void) +{ +#ifdef FASLINK + make_si_function("FASLINK", siLfaslink); +#endif +} diff --git a/o/unixfsys.c b/o/unixfsys.c new file mode 100755 index 0000000..ea2f9dd --- /dev/null +++ b/o/unixfsys.c @@ -0,0 +1,915 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#include +#include +#include +#include + +#define IN_UNIXFSYS +#include "include.h" +#include +#include +#ifndef NO_PWD_H +#include +#endif + +#ifdef __MINGW32__ +# include +/* Windows has no symlink, therefore no lstat. Without symlinks lstat + is equivalent to stat anyway. */ +# define S_ISLNK(a) 0 +# define lstat stat +#endif + +#ifdef BSD +#define HAVE_RENAME +#endif + +void Ldirectory(void); + + + +#ifdef NEED_GETWD +#include + + +#ifndef HAVE_GETCWD +char dotdot[3*16+2] = "../../../../../../../../../../../../../../../../."; +#include +static char *getwd_buf; +static int getwd_bufp; + +static char * +getwd(buffer) +char *buffer; +{ + getwd_buf = buffer; + getwd1(0); + if (getwd_bufp == 0) + getwd_buf[getwd_bufp++] = '/'; + getwd_buf[getwd_bufp] = '\0'; + return(getwd_buf); +} + +getwd1(n) +int n; +{ + struct stat st, dev_st; + struct direct dir; + ino_t ino; + struct mnttab mnt; + FILE *fp; + register int i; + char buf[BUFSIZ]; + static char dev_name[64]; + + if (stat(dotdot+(16-n)*3, &st) < 0) + FEerror("Can't get the current working directory.", 0); + ino = st.st_ino; + if (ino == 2) + goto ROOT; + getwd1(n+1); + fp = fopen(dotdot+(16-n-1)*3, "r"); + if (fp == NULL) + FEerror("Can't get the current working directory.", 0); + setbuf(fp, buf); + fread(&dir, sizeof(struct direct), 1, fp); + fread(&dir, sizeof(struct direct), 1, fp); + for (;;) { + if (fread(&dir, sizeof(struct direct), 1, fp) <= 0) + break; + if (dir.d_ino == ino) + goto FOUND; + } + fclose(fp); + FEerror("Can't get the current working directory.", 0); + +FOUND: + fclose(fp); + getwd_buf[getwd_bufp++] = '/'; + for (i = 0; i < DIRSIZ && dir.d_name[i] != '\0'; i++) + getwd_buf[getwd_bufp++] = dir.d_name[i]; + return; + +ROOT: + fp = fopen("/etc/mnttab", "r"); + if (fp == NULL) + FEerror("Can't get the current working directory.", 0); + setbuf(fp, buf); + for (;;) { + if (fread(&mnt, sizeof(struct mnttab), 1, fp) <= 0) + break; + if (mnt.mt_dev[0] != '/') { + strcpy(dev_name, "/dev/dsk/"); + strcat(dev_name, mnt.mt_dev); + stat(dev_name, &dev_st); + } else + stat(mnt.mt_dev, &dev_st); + if (dev_st.st_rdev == st.st_dev) + goto DEV_FOUND; + } + fclose(fp); + getwd_bufp = 0; + return; + +DEV_FOUND: + fclose(fp); + getwd_bufp = 0; + for (i = 0; mnt.mt_filsys[i] != '\0'; i++) + getwd_buf[i] = mnt.mt_filsys[i]; + /* BUG FIX by Grant J. Munsey */ + if (i == 1 && *getwd_buf == '/') + i = 0; /* don't add an empty directory name */ + /* END OF BUG FIX */ + getwd_bufp = i; +} +#endif /* not HAVE_GETCWD */ +#endif + +#ifndef MAXPATHLEN +#define MAXPATHLEN 512 +#endif + + +#ifdef HAVE_GETCWD +char * +getwd(char *buffer) { +#ifndef _WIN32 + char *getcwd(char *, size_t); +#endif + return(getcwd(buffer, MAXPATHLEN)); +} +#endif + + +#define pcopy(a_,b_,c_,d_) ({\ + unsigned _c=c_,_d=d_;\ + if (_c+_d>=MAXPATHLEN-16) FEerror("Can't expand pathname ~a",1,namestring);\ + bcopy(a_,b_+_c,_d);\ + b_[_c+_d]=0;\ + }) + +void +coerce_to_filename(object pathname,char *p) { + + object namestring=coerce_to_namestring(pathname); + unsigned e=namestring->st.st_fillp; + char *q=namestring->st.st_self,*qe=q+e;; + + if (pathname==Cnil) + FEerror ( "NIL argument.", 1, pathname ); + + if (*q=='~') { + + unsigned m=0; + char *s=++q,*c; + + for (;spw_dir,p,0,m=strlen(pwent->pw_dir)); + + } +#endif + + pcopy(s,p,m,qe-s); + + } else + + pcopy(q,p,0,e); + +#ifdef FIX_FILENAME + FIX_FILENAME(pathname,p); +#endif + +} + +object +truename(object pathname) +{ + register char *p, *q; + char filename[MAXPATHLEN]; + char truefilename[MAXPATHLEN]; + char current_directory[MAXPATHLEN]; + char directory[MAXPATHLEN]; +#ifdef __MINGW32__ + DWORD current_directory_length = + GetCurrentDirectory ( MAXPATHLEN, current_directory ); + if ( MAXPATHLEN < current_directory_length ) { + FEerror ( "truename got a current directory name larger than MAXPATHLEN", 1, "" ); + } + if ( 0 == current_directory_length ) { + FEerror ( "truename could not determine the current directory.", 1, "" ); + } +#else + massert(current_directory==getcwd(current_directory,sizeof(current_directory))); +#endif + + coerce_to_filename(pathname, filename); + +#ifdef S_IFLNK + { + + struct stat filestatus; + int islinkcount=8; + + if (lstat(filename, &filestatus) >= 0) + + while (((filestatus.st_mode&S_IFMT) == S_IFLNK) && (--islinkcount>0)) { + + char newname[MAXPATHLEN]; + int newlen; + + newlen=readlink(filename,newname,MAXPATHLEN-1); + if (newlen < 0) + return((FEerror("Symlink broken at ~S.",1,pathname),Cnil)); + + for (p = filename, q = 0; *p != '\0'; p++) + if (*p == '/') q = p; + if (q == 0 || *newname == '/') + q = filename; + else + q++; + + memcpy(q,newname,newlen); + q[newlen]=0; + if (lstat(filename, &filestatus) < 0) + islinkcount=0; /* It would be ANSI to do the following : + return(file_error("Symlink broken at ~S.",pathname)); + but this would break DIRECTORY if a file points to nowhere */ + } + } +#endif + + for (p = filename, q = 0; *p != '\0'; p++) + if (*p == '/') + q = p; + if (q == filename) { + q++; + p = "/"; + } else if (q == 0) { + q = filename; + p = current_directory; + } else +#ifdef __MINGW32__ + if ( ( q > filename ) && ( q[-1] == ':' ) ) { + int current = (q++, q[0]); + q[0]=0; + if (chdir(filename) < 0) + FEerror("Cannot get the truename of ~S.", 1, pathname); + current_directory_length = + GetCurrentDirectory ( MAXPATHLEN, directory ); + if ( MAXPATHLEN < current_directory_length ) { + FEerror ( "truename got a current directory name larger than MAXPATHLEN", 1, "" ); + } + if ( 0 == current_directory_length ) { + FEerror ( "truename could not determine the current directory.", 1, "" ); + } + p = directory; + if ( p[1]==':' && ( p[2]=='\\' || p[2]=='/' ) && p[3]==0 ) p[2]=0; + q[0]=current; + } + else +#endif + { + *q++ = '\0'; + if (chdir(filename) < 0) + FEerror("Cannot get the truename of ~S.", 1, pathname); +#ifdef __MINGW32__ + current_directory_length = GetCurrentDirectory ( MAXPATHLEN, directory ); + if ( MAXPATHLEN < current_directory_length ) { + FEerror ( "truename got a current directory name larger than MAXPATHLEN", 1, "" ); + } + if ( 0 == current_directory_length ) { + FEerror ( "truename could not determine the current directory.", 1, "" ); + } + p = directory; +#else + p = getcwd(directory,sizeof(directory)); +#endif + } + if (p[0] == '/' && p[1] == '\0') { + if (strcmp(q, "..") == 0) + strcpy(truefilename, "/."); + else + sprintf(truefilename, "/%s", q); + } else if (strcmp(q, ".") == 0) + strcpy(truefilename, p); + else if (strcmp(q, "..") == 0) { + for (q = p + strlen(p); *--q != '/';) ; + if (p == q) + strcpy(truefilename, "/."); + else { + *q = '\0'; + strcpy(truefilename, p); + *q = '/'; + } + } else + sprintf(truefilename, "%s/%s", p, q); + massert(!chdir(current_directory)); + vs_push(make_simple_string(truefilename)); + pathname = coerce_to_pathname(vs_head); + vs_popp; + return(pathname); +} +object sSAallow_gzipped_fileA; + +bool +file_exists(object file) +{ + char filename[MAXPATHLEN]; + struct stat filestatus; + + coerce_to_filename(file, filename); + +#ifdef __MINGW32__ + { + char *p; + for (p = filename; *p != '\0'; p++); + if ( (p > filename) && + ( ( *(p-1) == '/' ) || ( *(p-1) == '\\' ) ) ) { + *(p-1) = '\0'; + } + } +#endif + + if (stat(filename, &filestatus) >= 0 && !S_ISDIR(filestatus.st_mode)) + { +#ifdef AIX + /* if /tmp/foo is not a directory /tmp/foo/ should not exist */ + if (filename[strlen(filename)-1] == '/' && + !( filestatus.st_mode & S_IFDIR)) + return(FALSE); +#endif + + return TRUE; + } + else + if (sSAallow_gzipped_fileA->s.s_dbind != sLnil + && (strcat(filename,".gz"), + stat(filename, &filestatus) >= 0 && !S_ISDIR(filestatus.st_mode))) + + return TRUE; + + else + return(FALSE); +} + +FILE * +fopen_not_dir(char *filename,char * option) { + + struct stat ss; + + if (!stat(filename,&ss) && S_ISDIR(ss.st_mode)) + return NULL; + else + return fopen(filename,option); + +} + +FILE * +backup_fopen(char *filename, char *option) +{ + char backupfilename[MAXPATHLEN]; + char command[MAXPATHLEN * 2]; + + strcat(strcpy(backupfilename, filename), ".BAK"); + sprintf(command, "mv %s %s", filename, backupfilename); + msystem(command); + return(fopen(filename, option)); +} + +int +file_len(FILE *fp) +{ + struct stat filestatus; + + if (fstat(fileno(fp), &filestatus)==0) + return(filestatus.st_size); + else return 0; +} + +LFD(Ltruename)(void) +{ + check_arg(1); + check_type_or_pathname_string_symbol_stream(&vs_base[0]); + vs_base[0] = truename(vs_base[0]); +} + +LFD(Lrename_file)(void) +{ + char filename[MAXPATHLEN]; + char newfilename[MAXPATHLEN]; + + check_arg(2); + check_type_or_pathname_string_symbol_stream(&vs_base[0]); + check_type_or_Pathname_string_symbol(&vs_base[1]); + coerce_to_filename(vs_base[0], filename); + vs_base[0] = coerce_to_pathname(vs_base[0]); + vs_base[1] = coerce_to_pathname(vs_base[1]); + vs_base[1] = merge_pathnames(vs_base[1], vs_base[0], Cnil); + coerce_to_filename(vs_base[1], newfilename); +#ifdef HAVE_RENAME + if (rename(filename, newfilename) < 0) + FEerror("Cannot rename the file ~S to ~S.", + 2, vs_base[0], vs_base[1]); +#else + sprintf(command, "mv %s %s", filename, newfilename); + msystem(command); +#endif + vs_push(vs_base[1]); + vs_push(truename(vs_base[0])); + vs_push(truename(vs_base[1])); + vs_base += 2; +} + + +DEF_ORDINARY("DIRECTORY",sKdirectory,KEYWORD,""); +DEF_ORDINARY("LINK",sKlink,KEYWORD,""); +DEF_ORDINARY("FILE",sKfile,KEYWORD,""); + +/* export these for AXIOM */ +int gcl_putenv(char *s) {return putenv(s);} +char *gcl_strncpy(char *d,const char *s,size_t z) {return strncpy(d,s,z);} +char *gcl_strncpy_chk(size_t z) {char a[10],b[10];return strncpy(a,b,z);}/*compile in __strncpy_chk with FORTIFY_SOURCE*/ +#ifdef __MINGW32__ +#define uid_t int +#endif +uid_t gcl_geteuid(void) { +#ifndef __MINGW32__ + return geteuid(); +#else + return 0; +#endif +} +uid_t gcl_getegid(void) { +#ifndef __MINGW32__ + return getegid(); +#else + return 0; +#endif +} +int gcl_dup2(int o,int n) {return dup2(o,n);} +char *gcl_gets(char *s,int z) {return fgets(s,z,stdin);} +int gcl_puts(const char *s) {int i=fputs(s,stdout);fflush(stdout);return i;} + + +int gcl_feof(void *v) {return feof(((FILE *)v));} +int gcl_getc(void *v) {return getc(((FILE *)v));} +int gcl_putc(int i,void *v) {return putc(i,((FILE *)v));} + + + +DEFUN_NEW("STAT",object,fSstat,SI,1,1,NONE,OO,OO,OO,OO,(object path),"") { + + char filename[4096]; + struct stat ss; + + + bzero(filename,sizeof(filename)); + coerce_to_filename(path,filename); +#ifdef __MINGW32__ + { + char *p=filename+strlen(filename)-1; + for (;p>filename && *p=='/';p--) + *p=0; + } +#endif + if (lstat(filename,&ss)) + RETURN1(Cnil); + else {/* ctime_r insufficiently portable */ + /* int j; + ctime_r(&ss.st_ctime,filename); + j=strlen(filename); + if (isspace(filename[j-1])) + filename[j-1]=0;*/ + RETURN1(list(3,S_ISDIR(ss.st_mode) ? sKdirectory : + (S_ISLNK(ss.st_mode) ? sKlink : sKfile), + make_fixnum(ss.st_size),make_fixnum(ss.st_ctime))); + } +} + +DEFUN_NEW("SETENV",object,fSsetenv,SI,2,2,NONE,OO,OO,OO,OO,(object variable,object value),"Set environment VARIABLE to VALUE") + +{ + + int res = -1; +#ifdef HAVE_SETENV + res = setenv(object_to_string(variable),object_to_string(value),1); +#else +#ifdef HAVE_PUTENV + {char *buf; + char *sym=object_to_string(variable); + char *val=object_to_string(value); + buf = malloc(strlen(sym)+strlen(val)+5); + sprintf(buf,"%s=%s",sym,val); + res=putenv(buf); + free(buf); + } +#endif +#endif + RETURN1((res == 0 ? Ct : Cnil )); +} + +DEFUNO_NEW("DELETE-FILE",object,fLdelete_file,LISP + ,1,1,NONE,OO,OO,OO,OO,void,Ldelete_file,(object path),"") + +{ + char filename[MAXPATHLEN]; + + /* 1 args */ + check_type_or_pathname_string_symbol_stream(&path); + coerce_to_filename(path, filename); + if (unlink(filename) < 0 && rmdir(filename) < 0) + FEerror("Cannot delete the file ~S: ~s.", 2, path, make_simple_string(strerror(errno))); + path = Ct; + RETURN1(path); +} +#ifdef STATIC_FUNCTION_POINTERS +object +fLdelete_file(object path) { + return FFN(fLdelete_file)(path); +} +#endif + +LFD(Lprobe_file)(void) +{ + check_arg(1); + + check_type_or_pathname_string_symbol_stream(&vs_base[0]); + if (file_exists(vs_base[0])) + vs_base[0] = truename(vs_base[0]); + else + vs_base[0] = Cnil; +} + +LFD(Lfile_write_date)(void) +{ + char filename[MAXPATHLEN]; + struct stat filestatus; + + check_arg(1); + check_type_or_pathname_string_symbol_stream(&vs_base[0]); + coerce_to_filename(vs_base[0], filename); + if (stat(filename, &filestatus) < 0 || S_ISDIR(filestatus.st_mode)) + { vs_base[0] = Cnil; return;} + vs_base[0] = unix_time_to_universal_time(filestatus.st_mtime); +} + +LFD(Lfile_author)(void) +{ +#if !defined(NO_PWD_H) && !defined(STATIC_LINKING) + char filename[MAXPATHLEN]; + struct stat filestatus; + struct passwd *pwent; +#ifndef __STDC__ + extern struct passwd *getpwuid(); +#endif + + check_arg(1); + check_type_or_pathname_string_symbol_stream(&vs_base[0]); + coerce_to_filename(vs_base[0], filename); + if (stat(filename, &filestatus) < 0 || S_ISDIR(filestatus.st_mode)) + { vs_base[0] = Cnil; return;} + pwent = getpwuid(filestatus.st_uid); + vs_base[0] = make_simple_string(pwent->pw_name); +#else + vs_base[0] = Cnil; return; +#endif + +} + +static void +FFN(Luser_homedir_pathname)(void) +{ + + char filename[MAXPATHLEN]; + + coerce_to_filename(make_simple_string("~/"),filename); + vs_base[0]=coerce_to_pathname(make_simple_string(filename)); + vs_top = vs_base+1; + +} + + +#ifdef BSD +LFD(Ldirectory)(void) +{ + char filename[MAXPATHLEN]; + char command[MAXPATHLEN * 2]; + FILE *fp; + register int i, c; + object *top = vs_top; + char iobuffer[BUFSIZ]; + extern FILE *popen(const char *, const char *); + + check_arg(1); + + check_type_or_pathname_string_symbol_stream(&vs_base[0]); + vs_base[0] = coerce_to_pathname(vs_base[0]); + if (vs_base[0]->pn.pn_name==Cnil && vs_base[0]->pn.pn_type==Cnil) { + coerce_to_filename(vs_base[0], filename); + strcat(filename, "*"); + } else if (vs_base[0]->pn.pn_name==Cnil) { + vs_base[0]->pn.pn_name = sKwild; + coerce_to_filename(vs_base[0], filename); + vs_base[0]->pn.pn_name = Cnil; + } else if (vs_base[0]->pn.pn_type==Cnil) { + coerce_to_filename(vs_base[0], filename); + strcat(filename, "*"); + } else + coerce_to_filename(vs_base[0], filename); + sprintf(command, "ls -d %s 2> /dev/null", filename); + fp = popen(command, "r"); + setbuf(fp, iobuffer); + for (;;) { + for (i = 0; (c = getc(fp)); i++) + if (c <= 0) + goto L; + else if (c == '\n') + break; + else + filename[i] = c; + filename[i] = '\0'; + vs_push(make_simple_string(filename)); + vs_head = truename(vs_head); + } +L: + pclose(fp); + vs_push(Cnil); + while (vs_top > top + 1) + stack_cons(); + vs_base = top; +} +#endif + + +#ifdef ATT +LFD(Ldirectory)() +{ + object name, type; + char filename[MAXPATHLEN]; + FILE *fp; + object *top = vs_top; + char iobuffer[BUFSIZ]; + struct direct dir; + int i; + + check_arg(1); + + check_type_or_pathname_string_symbol_stream(&vs_base[0]); + vs_base[0] = coerce_to_pathname(vs_base[0]); + vs_push(vs_base[0]->pn.pn_name); + vs_push(vs_base[0]->pn.pn_type); + vs_base[0]->pn.pn_name = Cnil; + vs_base[0]->pn.pn_type = Cnil; + coerce_to_filename(vs_base[0], filename); + type = vs_base[0]->pn.pn_type = vs_pop; + name = vs_base[0]->pn.pn_name = vs_pop; + i = strlen(filename); + if (i > 1 && filename[i-1] == '/') + filename[i-1] = '\0'; + if (i == 0) + strcpy(filename, "."); + fp = fopen(filename, "r"); + if (fp == NULL) { + vs_push(make_simple_string(filename)); + FEerror("Can't open the directory ~S.", 1, vs_head); + } + setbuf(fp, iobuffer); + fread(&dir, sizeof(struct direct), 1, fp); + fread(&dir, sizeof(struct direct), 1, fp); + filename[DIRSIZ] = '\0'; + for (;;) { + if (fread(&dir, sizeof(struct direct), 1, fp) <=0) + break; + if (dir.d_ino == 0) + continue; + strncpy(filename, dir.d_name, DIRSIZ); + vs_push(make_simple_string(filename)); + vs_head = coerce_to_pathname(vs_head); + if ((name == Cnil || name == sKwild || + equal(name, vs_head->pn.pn_name)) && + (type == Cnil || type == sKwild || + equal(type, vs_head->pn.pn_type))) { + vs_head->pn.pn_directory + = vs_base[0]->pn.pn_directory; + vs_head = truename(vs_head); + } else + vs_pop; + } + fclose(fp); + vs_push(Cnil); + while (vs_top > top + 1) + stack_cons(); + vs_base = top; +} +#endif + + +#ifdef E15 +#include + +LFD(Ldirectory)() +{ + object name, type; + char filename[MAXPATHLEN]; + FILE *fp; + object *top = vs_top; + char iobuffer[BUFSIZ]; + struct direct dir; + int i; + + check_arg(1); + + check_type_or_pathname_string_symbol_stream(&vs_base[0]); + vs_base[0] = coerce_to_pathname(vs_base[0]); + vs_push(vs_base[0]->pn.pn_name); + vs_push(vs_base[0]->pn.pn_type); + vs_base[0]->pn.pn_name = Cnil; + vs_base[0]->pn.pn_type = Cnil; + coerce_to_filename(vs_base[0], filename); + type = vs_base[0]->pn.pn_type = vs_pop; + name = vs_base[0]->pn.pn_name = vs_pop; + i = strlen(filename); + if (i > 1 && filename[i-1] == '/') + filename[i-1] = '\0'; + if (i == 0) + strcpy(filename, "."); + fp = fopen(filename, "r"); + if (fp == NULL) { + vs_push(make_simple_string(filename)); + FEerror("Can't open the directory ~S.", 1, vs_head); + } + setbuf(fp, iobuffer); + fread(&dir, sizeof(struct direct), 1, fp); + fread(&dir, sizeof(struct direct), 1, fp); + filename[DIRSIZ] = '\0'; + for (;;) { + if (fread(&dir, sizeof(struct direct), 1, fp) <=0) + break; + if (dir.d_ino == 0) + continue; + strncpy(filename, dir.d_name, DIRSIZ); + vs_push(make_simple_string(filename)); + vs_head = coerce_to_pathname(vs_head); + if ((name == Cnil || name == sKwild || + equal(name, vs_head->pn.pn_name)) && + (type == Cnil || type == sKwild || + equal(type, vs_head->pn.pn_type))) { + vs_head->pn.pn_directory + = vs_base[0]->pn.pn_directory; + vs_head = truename(vs_head); + } else + vs_pop; + } + fclose(fp); + vs_push(Cnil); + while (vs_top > top + 1) + stack_cons(); + vs_base = top; +} +#endif + +#include +#include + +DEFUN_NEW("OPENDIR",object,fSopendir,SI,1,1,NONE,IO,OO,OO,OO,(object x),"") { + DIR *d; + char filename[MAXPATHLEN]; + check_type_string(&x); + memcpy(filename,x->st.st_self,x->st.st_fillp); + filename[x->st.st_fillp]=0; + d=opendir(filename); + return (object)d; +} + +#ifdef HAVE_D_TYPE + +DEFUN_NEW("D-TYPE-LIST",object,fSd_type_list,SI,0,0,NONE,OI,OO,OO,OO,(void),"") { + RETURN1(list(8, + MMcons(make_fixnum(DT_BLK),make_keyword("BLOCK")), + MMcons(make_fixnum(DT_CHR),make_keyword("CHAR")), + MMcons(make_fixnum(DT_DIR),make_keyword("DIRECTORY")), + MMcons(make_fixnum(DT_FIFO),make_keyword("FIFO")), + MMcons(make_fixnum(DT_LNK),make_keyword("LINK")), + MMcons(make_fixnum(DT_REG),make_keyword("FILE")), + MMcons(make_fixnum(DT_SOCK),make_keyword("SOCKET")), + MMcons(make_fixnum(DT_UNKNOWN),make_keyword("UNKNOWN")) + )); +} +#endif + +DEFUN_NEW("READDIR",object,fSreaddir,SI,2,2,NONE,OI,IO,OO,OO,(fixnum x,fixnum y),"") { + struct dirent *e; + object z; + if (!x) RETURN1(Cnil); + e=readdir((DIR *)x); + RETURN1(e ? make_simple_string(e->d_name) : Cnil); +#ifdef HAVE_D_TYPE + for (;(e=readdir((DIR *)x)) && y!=DT_UNKNOWN && e->d_type!=y;); +#endif + if (!e) RETURN1(Cnil); + z=make_simple_string(e->d_name); +#ifdef HAVE_D_TYPE + if (y==DT_UNKNOWN) z=MMcons(z,make_fixnum(e->d_type)); +#endif + RETURN1(z); +} + +DEFUN_NEW("CLOSEDIR",object,fSclosedir,SI,1,1,NONE,OI,OO,OO,OO,(fixnum x),"") { + closedir((DIR *)x); + return Cnil; +} + +DEFUN_NEW("MKDIR",object,fSmkdir,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") { + + char filename[MAXPATHLEN]; + + check_type_string(&x); + + memcpy(filename,x->st.st_self,x->st.st_fillp); + filename[x->st.st_fillp]=0; + +#ifdef __MINGW32__ + if (mkdir(filename) < 0) +#else + if (mkdir(filename,01777) < 0) +#endif + FEerror("Cannot make the directory ~S.", 1, vs_base[0]); + + RETURN1(x); + +} + + + + +static void +FFN(siLchdir)(void) +{ + char filename[MAXPATHLEN]; + + check_arg(1); + check_type_or_pathname_string_symbol_stream(&vs_base[0]); + coerce_to_filename(vs_base[0], filename); + + if (chdir(filename) < 0) + FEerror("Can't change the current directory to ~S.", + 1, vs_base[0]); +} + +void +gcl_init_unixfsys(void) +{ + make_function("TRUENAME", Ltruename); + make_function("RENAME-FILE", Lrename_file); + make_function("DELETE-FILE", Ldelete_file); + make_function("PROBE-FILE", Lprobe_file); + make_function("FILE-WRITE-DATE", Lfile_write_date); + make_function("FILE-AUTHOR", Lfile_author); + make_function("USER-HOMEDIR-PATHNAME", Luser_homedir_pathname); + make_function("DIRECTORY", Ldirectory); + + make_si_function("CHDIR", siLchdir); +} diff --git a/o/unixsave.c b/o/unixsave.c new file mode 100755 index 0000000..6a26100 --- /dev/null +++ b/o/unixsave.c @@ -0,0 +1,164 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +/* + unixsave.c +*/ + +#define IN_UNIXSAVE +#ifndef FIRSTWORD +#include "include.h" +#endif + +#ifdef UNIXSAVE +#include UNIXSAVE +#else + +#ifdef HAVE_FCNTL +#include +#else +#include +#endif + +#ifdef HAVE_AOUT +#undef BSD +#undef ATT +#define BSD +#endif + + + +#ifdef BSD +#include HAVE_AOUT +#endif + +#ifdef DOS +void +binary_file_mode() +{_fmode = O_BINARY;} +#endif + + +#ifdef ATT +#include +#include +#include +#endif + +#ifdef E15 +#include +extern char etext; +#endif + + +filecpy(to, from, n) +FILE *to, *from; +register int n; +{ + char buffer[BUFSIZ]; + + for (;;) + if (n > BUFSIZ) { + fread(buffer, BUFSIZ, 1, from); + fwrite(buffer, BUFSIZ, 1, to); + n -= BUFSIZ; + } else if (n > 0) { + fread(buffer, 1, n, from); + fwrite(buffer, 1, n, to); + break; + } else + break; +} + +static void +memory_save(original_file, save_file) +char *original_file, *save_file; +{ MEM_SAVE_LOCALS; + char *data_begin, *data_end; + int original_data; + FILE *original, *save; + register int n; + register char *p; + extern char *sbrk(); + + original = freopen(original_file,"r",stdin); +/* fclose(stdin); + original = fopen(original_file, "r"); +*/ + + if (stdin != original || original->_file != 0) { + fprintf(stderr, "Can't open the original file.\n"); + exit(1); + } + setbuf(original, stdin_buf); + fclose(stdout); + unlink(save_file); + n = open(save_file, O_CREAT|O_WRONLY, 0777); + if (n != 1 || (save = fdopen(n, "w")) != stdout) { + fprintf(stderr, "Can't open the save file.\n"); + exit(1); + } + setbuf(save, stdout_buf); + + READ_HEADER; + FILECPY_HEADER; + + for (n = header.a_data, p = data_begin; ; n -= BUFSIZ, p += BUFSIZ) + if (n > BUFSIZ) + fwrite(p, BUFSIZ, 1, save); + else if (n > 0) { + fwrite(p, 1, n, save); + break; + } else + break; + + fseek(original, original_data, 1); + + COPY_TO_SAVE; + + fclose(original); + fclose(save); +} + +extern void _cleanup(); + +LFD(Lsave)() { + char filename[256]; + + check_arg(1); + check_type_or_pathname_string_symbol_stream(&vs_base[0]); + coerce_to_filename(vs_base[0], filename); + + _cleanup(); + + memory_save(kcl_self, filename); + exit(0); + /* no return */ +} + +#endif /* UNIXSAVE include */ + +void +gcl_init_unixsave(void) +{ + make_function("SAVE", Lsave); +} + diff --git a/o/unixsys.c b/o/unixsys.c new file mode 100755 index 0000000..30560dd --- /dev/null +++ b/o/unixsys.c @@ -0,0 +1,289 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#include +#include +#include +#include +#include + + +#include "include.h" + +#ifdef _WIN32 +#include +#define sleep(n) Sleep(1000 * n) +#endif + +#ifdef ATT3B2 +#include +int +system(command) +char *command; +{ + char buf[4]; + extern sigint(); + + signal(SIGINT, SIG_IGN); + write(4, command, strlen(command)+1); + read(5, buf, 1); + signal(SIGINT, sigint); + return(buf[0]<<8); +} +#endif + +#ifdef E15 +#include +int +system(command) +char *command; +{ + char buf[4]; + extern sigint(); + + signal(SIGINT, SIG_IGN); + write(4, command, strlen(command)+1); + read(5, buf, 1); + signal(SIGINT, sigint); + return(buf[0]<<8); +} +#endif + +#ifdef _WIN32 + +DEFVAR("*WINE-DETECTED*",sSAwine_detectedA,SI,Cnil,""); + +#include "windows.h" + +static int mpid; + +void +close_msys() { + + msystem(""); + +} + +void +detect_wine() { + + char b[4096]; + struct stat ss; + const char *s="/proc/self/status"; + FILE *f; + object o; + + sSAwine_detectedA->s.s_dbind=Cnil; + + if (stat(s,&ss)) + return; + + massert(f=fopen(s,"r")); + massert(fscanf(f,"%s",b)==1); + massert(fscanf(f,"%s",b)==1); + massert(!fclose(f)); + + if (strncmp("wineserver",b,9)) + return; + + massert(o=sSAsystem_directoryA->s.s_dbind); + massert(o!=Cnil); + mpid=getpid(); + + massert(snprintf(b,sizeof(b),"%-.*smsys /tmp/ out%0d tmp%0d log%0d", + o->st.st_fillp,o->st.st_self,mpid,mpid,mpid)>0); + massert(!psystem(b)); + + sSAwine_detectedA->s.s_dbind=Ct; + + massert(!atexit(close_msys)); + +} +#endif + +int +msystem(const char *s) { + + int r; + +#ifdef _WIN32 + + if (sSAwine_detectedA->s.s_dbind==Ct) { + + char b[4096],b1[4096],c; + FILE *fp; + + massert(snprintf(b,sizeof(b),"/tmp/out%0d",mpid)>0); + massert(snprintf(b1,sizeof(b1),"%s1",b)>0); + + massert(fp=fopen(b1,"w")); + massert(fprintf(fp,"%s",s)>=0); + massert(!fclose(fp)); + + massert(MoveFileEx(b1,b,MOVEFILE_REPLACE_EXISTING)); + + if (!*s) + return 0; + + for (;;Sleep(100)) { + + massert(fp=fopen(b,"r")); + massert((c=fgetc(fp))!=EOF); + if (c!=s[0]) { + massert(ungetc(c,fp)!=EOF); + break; + } + massert(!fclose(fp)); + + } + + massert(fscanf(fp,"%d",&r)==1); + massert(!fclose(fp)); + + } else + +#endif + + r=psystem(s); + + return r; + +} + +static void +FFN(Lsystem)(void) +{ + char command[32768]; + int i; + + check_arg(1); + check_type_string(&vs_base[0]); + if (vs_base[0]->st.st_fillp >= 32768) + FEerror("Too long command line: ~S.", 1, vs_base[0]); + for (i = 0; i < vs_base[0]->st.st_fillp; i++) + command[i] = vs_base[0]->st.st_self[i]; + command[i] = '\0'; + {int old = signals_allowed; + int res; + signals_allowed = sig_at_read; + res = msystem(command) ; + signals_allowed = old; + vs_base[0] = make_fixnum(res >> 8); + vs_base[1] = make_fixnum((res & 0xff)); + vs_top++; + } +} + +DEFUN_NEW("GETPID",object,fSgetpid,SI,0,0,NONE,OO,OO,OO,OO,(void), + "getpid returns the process ID of the current process") +{ return make_fixnum(getpid()); +} + + +DEFVAR("*LOAD-WITH-FREAD*",sSAload_with_freadA,SI,Cnil,""); + +#ifdef _WIN32 + +void * +get_mmap(FILE *fp,void **ve) { + + int n; + void *st; + size_t sz; + HANDLE handle; + + massert((sz=file_len(fp))>0); + if (sSAload_with_freadA->s.s_dbind==Cnil) { + n=fileno(fp); + massert((n=fileno(fp))>2); + massert(handle = CreateFileMapping((HANDLE)_get_osfhandle(n), NULL, PAGE_WRITECOPY, 0, 0, NULL)); + massert(st=MapViewOfFile(handle,FILE_MAP_COPY,0,0,sz)); + CloseHandle(handle); + } else { + massert(st=malloc(sz)); + massert(fread(st,sz,1,fp)==1); + } + + *ve=st+sz; + + return st; + +} + +int +un_mmap(void *v1,void *ve) { + + if (sSAload_with_freadA->s.s_dbind==Cnil) + return UnmapViewOfFile(v1) ? 0 : -1; + else { + free(v1); + return 0; + } + +} + + +#else + +#include + +void * +get_mmap(FILE *fp,void **ve) { + + int n; + void *v1; + struct stat ss; + + massert((n=fileno(fp))>2); + massert(!fstat(n,&ss)); + if (sSAload_with_freadA->s.s_dbind==Cnil) { + massert((v1=mmap(0,ss.st_size,PROT_READ|PROT_WRITE,MAP_PRIVATE,n,0))!=(void *)-1); + } else { + massert(v1=malloc(ss.st_size)); + massert(fread(v1,ss.st_size,1,fp)==1); + } + + *ve=v1+ss.st_size; + return v1; + +} + + +int +un_mmap(void *v1,void *ve) { + + if (sSAload_with_freadA->s.s_dbind==Cnil) + return munmap(v1,ve-v1); + else { + free(v1); + return 0; + } + +} + +#endif + +void +gcl_init_unixsys(void) { + + make_function("SYSTEM", Lsystem); + +} diff --git a/o/unixtime.c b/o/unixtime.c new file mode 100755 index 0000000..ff9d07d --- /dev/null +++ b/o/unixtime.c @@ -0,0 +1,302 @@ +/* + Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +/* + unixtime.c +*/ + +#define IN_UNIXTIME + +#include + +#include "include.h" +#include +#ifdef UNIX +/* all we want from this is HZ the number of clock ticks per second +which is usually 60 maybe 100 or something else. */ +#undef PAGESIZE +#ifndef NO_SYS_PARAM_H +#include +#endif +#endif + +#ifndef HZ +/* #define HZ 60 */ +#define HZ 100 +#endif + +/* #define HZ1 (HZ > 100 ? 100 : HZ) */ +#define HZ1 HZ + +#ifdef USE_ATT_TIME +# undef BSD +# define ATT +#endif + +#if defined __MINGW32__ || !defined NO_SYSTEM_TIME_ZONE + +# ifdef __MINGW32__ +# include +# include +# include + +static struct timeb t0; +int usleep ( unsigned int microseconds ); + +# endif + +#endif /* __MINGW32__ or !defined NO_SYSTEM_TIME_ZONE */ + +#ifdef BSD +#include +#include +#ifndef NO_SYS_TIMES_H +#include +#endif +#include +/* static struct timeb beginning; */ +#endif + +#ifdef ATT +#include +static long beginning; +#endif + +int +runtime(void) +{ + +#ifdef USE_INTERNAL_REAL_TIME_FOR_RUNTIME + +# ifdef __MINGW32__ + struct timeb t; + if ( t0.time == 0 ) { + ftime(&t0); + } + ftime ( &t ); + return ( ( t.time - t0.time ) * HZ1 + ( (t.millitm) * HZ1 ) / 1000 ); +# else +# error Need to return runtime without generating a fixnum (else GBC(t_fixnum) will loop) +# endif + +#else + { + struct tms buf; + times(&buf); + return(buf.tms_utime); + } +#endif +} + +object +unix_time_to_universal_time(int i) +{ + object x; + vs_mark; + + vs_push(make_fixnum(24*60*60)); + vs_push(make_fixnum(70*365+17)); + x = number_times(vs_top[-1], vs_top[-2]); + vs_push(x); + vs_push(make_fixnum(i)); + x = number_plus(vs_top[-1], vs_top[-2]); + vs_reset; + return(x); +} + +DEFUN_NEW("GET-UNIVERSAL-TIME",object,fLget_universal_time,LISP + ,0,0,NONE,OO,OO,OO,OO,(void),"") +{ + /* 0 args */ + RETURN1(unix_time_to_universal_time(time(0))); +} + +LFD(Lsleep)(void) +{ + object z; + + check_arg(1); + check_type_or_rational_float(&vs_base[0]); + if (number_minusp(vs_base[0]) == TRUE) + FEerror("~S is not a non-negative number.", 1, vs_base[0]); + vs_base[0]=number_times(vs_base[0],make_fixnum(1000000)); + Lround(); + z = vs_base[0]; + if (type_of(z) == t_fixnum) + usleep(fix(z)); + else + /* What is this for? -- MJT */ + for(;;) +#ifdef __MINGW32__ + Sleep ( 10000 ); +#else + sleep(1000); +#endif + vs_top = vs_base; + vs_push(Cnil); +} + +LFD(Lget_internal_run_time)(void) +{ + +#ifdef USE_INTERNAL_REAL_TIME_FOR_RUNTIME + vs_push(fLget_internal_real_time()); + vs_push(small_fixnum(0)); + return; +#else + struct tms buf; + + check_arg(0); + times(&buf); + vs_push(make_fixnum(buf.tms_utime)); + vs_push(make_fixnum(buf.tms_cutime)); + vs_push(make_fixnum(buf.tms_stime)); + vs_push(make_fixnum(buf.tms_cstime)); + +#endif + +} + + +DEFUN_NEW("GETTIMEOFDAY",object,fSgettimeofday,SI,0,0,NONE,OO,OO,OO,OO,(void),"Return time with maximum resolution") { +#ifdef __MINGW32__ + LARGE_INTEGER uu,ticks; + if (QueryPerformanceFrequency(&ticks)) { + QueryPerformanceCounter(&uu); + return make_longfloat((longfloat)uu.QuadPart/ticks.QuadPart); + } else { + FEerror("microsecond timing not available",0); + return Cnil; + /* static struct timeb t0; */ + /* static unsigned u; */ + /* struct timeb t; */ + /* ftime(&t); */ + /* if (t.time!=t0.time || t.millitm!=t0.millitm) {t0=t;u=0;} */ + /* u++; */ + /* return make_longfloat(((longfloat)t.time+1.0e-3*t.millitm+1.0e-6*(u%1000))); */ + } +#endif +#ifdef BSD + struct timeval tzp; + gettimeofday(&tzp,0); + return make_longfloat((longfloat)tzp.tv_sec+1.0e-6*tzp.tv_usec); +#endif +#ifdef ATT + return make_longfloat((longfloat)time(0)); +#endif +} + + +DEFUN_NEW("GET-INTERNAL-REAL-TIME",object,fLget_internal_real_time,LISP,0,0,NONE,OO,OO,OO,OO,(void),"Run time relative to beginning") + +{ +#ifdef __MINGW32__ + struct timeb t; + if ( t0.time == 0 ) { + ftime ( &t0 ); + } + ftime(&t); + return ( make_fixnum ( ( t.time - t0.time ) * HZ1 + ( (t.millitm) * HZ1 ) / 1000 ) ); +#endif +#ifdef BSD + static struct timeval begin_tzp; + struct timeval tzp; + if (begin_tzp.tv_sec==0) + gettimeofday(&begin_tzp,0); + gettimeofday(&tzp,0); +/* the value returned will be relative to the first time this is called, + plus the fraction of a second. We must make it relative, so this + will only wrap if the process lasts longer than 818 days + */ + return make_fixnum(((tzp.tv_sec-begin_tzp.tv_sec)*HZ1 + + ((tzp.tv_usec)*HZ1)/1000000)); +#endif +#ifdef ATT + return make_fixnum((time(0) - beginning)*HZ1); +#endif +} + + +void +gcl_init_unixtime(void) { +#ifdef ATT + beginning = time(0); +#endif +# if defined __MINGW32__ + ftime(&t0); +# endif + + make_constant("INTERNAL-TIME-UNITS-PER-SECOND", make_fixnum(HZ1)); + + make_function("SLEEP", Lsleep); + make_function("GET-INTERNAL-RUN-TIME", Lget_internal_run_time); + +} + +#ifdef __MINGW32__ +int usleep ( unsigned int microseconds ) +{ + unsigned int milliseconds = microseconds / 1000; + return ( SleepEx ( milliseconds, TRUE ) ); +} + +#endif + +DEFUN_NEW("CURRENT-TIMEZONE",object,fScurrent_timezone,SI,0,0,NONE,IO,OO,OO,OO,(void),"") { + +#if defined(__MINGW32__) + + TIME_ZONE_INFORMATION tzi; + DWORD TZResult; + + TZResult = GetTimeZoneInformation ( &tzi ); + + /* Now UTC = (local time + bias), in units of minutes, so */ + /*fprintf ( stderr, "Bias = %ld\n", tzi.Bias );*/ + return (object)((tzi.Bias+tzi.DaylightBias)/60); + +#elif defined NO_SYSTEM_TIME_ZONE + return (object)0; +#elif defined __CYGWIN__ + struct tm gt,lt; + fixnum _t=time(0); + gmtime_r(&_t, >); + localtime_r(&_t, <); + return (object)(gt.tm_hour-lt.tm_hour+24*(gt.tm_yday!=lt.tm_yday ? (gt.tm_year>lt.tm_year||gt.tm_yday>lt.tm_yday ? 1 : -1) : 0)); +#else + fixnum _t=time(0); + return (object)(-localtime(&_t)->tm_gmtoff/3600); +#endif +} + +DEFUN_NEW("CURRENT-DSTP",object,fScurrent_dstp,SI,0,0,NONE,OO,OO,OO,OO,(void),"") { + +#if defined(__MINGW32__) + + return Cnil; + +#elif defined NO_SYSTEM_TIME_ZONE /*solaris*/ + return Cnil; +#else + fixnum _t=time(0); + return localtime(&_t)->tm_isdst > 0 ? Ct : Cnil; +#endif +} diff --git a/o/user_init.c b/o/user_init.c new file mode 100755 index 0000000..1487b48 --- /dev/null +++ b/o/user_init.c @@ -0,0 +1,3 @@ +#include "include.h" +object +user_init(void) {return Cnil;} diff --git a/o/user_match.c b/o/user_match.c new file mode 100644 index 0000000..bb030e9 --- /dev/null +++ b/o/user_match.c @@ -0,0 +1,3 @@ +#include "include.h" +int +user_match(const char *s,int n) {return 0;} diff --git a/o/usig.c b/o/usig.c new file mode 100755 index 0000000..4dd780b --- /dev/null +++ b/o/usig.c @@ -0,0 +1,315 @@ +/* + Copyright (C) 1994 W. Schelter + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + +#define _GNU_SOURCE 1 +#include + +#ifdef __MINGW32__ +#include /* sigset_t */ +#endif + +#ifndef IN_UNIXINT +#include "include.h" + + +#include +#endif + +#ifdef USIG +#include USIG +#else + +#ifdef HAVE_SIGACTION +#define HAVE_SIGPROCMASK +#endif + + +#include "usig.h" + +extern char signals_handled[]; + +void +gcl_signal(int signo, void (*handler) (/* ??? */)) +{ + char *p = signals_handled; + while (*p) + { if (*p==signo) + {our_signal_handler[signo] = handler; + handler = main_signal_handler; + break; + } + p++;} + + { + +#ifdef HAVE_SIGACTION + struct sigaction action; + action.sa_handler = handler; +/* action.sa_flags = SA_RESTART | ((signo == SIGSEGV || signo == SIGBUS) ? SV_ONSTACK : 0) */ + action.sa_flags = SA_RESTART | ((signo == SIGSEGV || signo == SIGBUS) ? SA_ONSTACK : 0) +#ifdef SA_SIGINFO + | SA_SIGINFO +#endif + ; + sigemptyset(&action.sa_mask); + /* sigaddset(&action.sa_mask,signo); */ + sigaction(signo,&action,0); +#else +#ifdef HAVE_SIGVEC + struct sigvec vec; + vec.sv_handler = handler; + vec.sv_flags = (signo == SIGSEGV || signo == SIGBUS ? SV_ONSTACK : 0); + vec.sv_mask = sigmask(signo); + sigvec(signo,&vec,0); +#else + signal(signo,handler); +#endif +#endif + } +} + +/* remove the signal n from the signal mask */ +int +unblock_signals(int n, int m) +{ + int result = 0; + int current_mask; +#ifdef SIG_UNBLOCK_SIGNALS + SIG_UNBLOCK_SIGNALS(result,n,n); +#else +#ifdef HAVE_SIGPROCMASK + /* posix */ + { sigset_t set,oset; + sigemptyset(&set); + sigaddset(&set,n); + sigaddset(&set,m); + sigprocmask(SIG_UNBLOCK,&set,&oset); + current_mask=0; + result =((sigismember(&oset,n) ? signal_mask(n) : current_mask) + |(sigismember(&oset,m) ? signal_mask(m) : current_mask)); + } +#else + + current_mask = sigblock(0); + sigsetmask(~(sigmask(m)) & ~(sigmask(n)) & current_mask); + result = (current_mask & sigmask(m) ? signal_mask(m) : 0) + | (current_mask & sigmask(n) ? signal_mask(n) : 0); +#endif +#endif + return result; +} + +void +unblock_sigusr_sigio(void) +{ +#ifdef HAVE_SIGPROCMASK + /* posix */ + { sigset_t set; + sigemptyset(&set); + sigaddset(&set,SIGUSR1); + sigaddset(&set,SIGIO); + sigprocmask( SIG_UNBLOCK,&set,0); + } +#else + int current_mask = sigblock(0); + return sigsetmask(~(sigmask(SIGIO))&~(sigmask(SIGUSR1)) & current_mask); +#endif +} + +DEFCONST("+MC-CONTEXT-OFFSETS+",sSPmc_context_offsetsP,SI,FPE_INIT,""); + +#if defined(__x86_64__) || defined(__i386__) + +#define ASM __asm__ __volatile__ + +DEFUN_NEW("FLD",object,fSfld,SI,1,1,NONE,OI,OO,OO,OO,(fixnum val),"") { + volatile double d; + ASM ("fldt %1;fstpl %0" : "=m" (d): "m" (*(char *)val)); + RETURN1(make_longfloat(d)); +} + +#endif + +DEFUN_NEW("*FIXNUM",fixnum,fSAfixnum,SI,1,1,NONE,II,OO,OO,OO,(fixnum addr),"") { + RETURN1(*(fixnum *)addr); +} +DEFUN_NEW("*FLOAT",object,fSAfloat,SI,1,1,NONE,OI,OO,OO,OO,(fixnum addr),"") { + RETURN1(make_shortfloat(*(float *)addr)); +} +DEFUN_NEW("*DOUBLE",object,fSAdouble,SI,1,1,NONE,OI,OO,OO,OO,(fixnum addr),"") { + RETURN1(make_longfloat(*(double *)addr)); +} + +DEFUN_NEW("FEENABLEEXCEPT",fixnum,fSfeenableexcept,SI,1,1,NONE,II,OO,OO,OO,(fixnum x),"") { + +#ifdef HAVE_FEENABLEEXCEPT + + x=feenableexcept(x); + +#elif defined(__x86_64__) || defined(__i386__) +#define ASM __asm__ __volatile__ + { + volatile unsigned short s=0; + volatile unsigned int i; + ASM("fnstcw %0" :: "m" (s)); + s=(s|FE_ALL_EXCEPT)&(~x); + ASM("fldcw %0" : "=m" (s)); + ASM("stmxcsr %0" :: "m" (i)); + i=(i|(FE_ALL_EXCEPT<<7))&(~(x<<7)); + ASM("ldmxcsr %0" : "=m" (i)); + } +#endif + + RETURN1(x); + +} + +DEFUN_NEW("FEDISABLEEXCEPT",fixnum,fSfedisableexcept,SI,0,0,NONE,IO,OO,OO,OO,(void),"") { + + fixnum x; + +#ifdef HAVE_FEENABLEEXCEPT + + feclearexcept(FE_ALL_EXCEPT); + x=fedisableexcept(FE_ALL_EXCEPT); + +#elif defined(__x86_64__) || defined(__i386__) +#define ASM __asm__ __volatile__ + { + volatile unsigned int i=0; + ASM("fnclex"); + ASM("stmxcsr %0" :: "m" (i)); + i=(i|(FE_ALL_EXCEPT<<7)); + ASM("ldmxcsr %0" : "=m" (i)); + x=0; + } +#endif + + RETURN1(x); +} + +#if defined(__x86_64__) || defined(__i386__) + +#define FE_TEST(x87sw_,mxcsr_,excepts_) ((x87sw_)&(excepts_))|(~((mxcsr_)>>7)&excepts_) + +DEFUN_NEW("FPE_CODE",fixnum,fSfpe_code,SI,2,2,NONE,II,OO,OO,OO,(fixnum x87sw,fixnum mxcsr),"") { + + RETURN1(FE_TEST(x87sw,mxcsr,FE_INVALID) ? FPE_FLTINV : + (FE_TEST(x87sw,mxcsr,FE_DIVBYZERO) ? FPE_FLTDIV : + (FE_TEST(x87sw,mxcsr,FE_OVERFLOW) ? FPE_FLTOVF : + (FE_TEST(x87sw,mxcsr,FE_UNDERFLOW) ? FPE_FLTUND : + (FE_TEST(x87sw,mxcsr,FE_INEXACT) ? FPE_FLTRES : 0))))); +} + +#if defined(__MINGW32__) || defined(__CYGWIN__) + +DEFUN_NEW("FNSTSW",fixnum,fSfnstsw,SI,0,0,NONE,II,OO,OO,OO,(void),"") { + volatile unsigned short t; + ASM ("fnstsw %0" :: "m" (t)); + RETURN1(t); +} +DEFUN_NEW("STMXCSR",fixnum,fSstmxcsr,SI,0,0,NONE,II,OO,OO,OO,(void),"") { + volatile unsigned int t; + ASM ("stmxcsr %0" :: "m" (t)); + RETURN1(t); +} + +#endif +#endif + + +static void +sigfpe3(int sig,void *i,void *v) { + + unblock_signals(SIGFPE,SIGFPE); +#ifdef __MINGW32__ + gcl_signal(SIGFPE,sigfpe3); +#endif + ifuncall3(sSfloating_point_error,FPE_CODE(i,v),FPE_ADDR(i,v),FPE_CTXT(v)); + +} + +DEFCONST("+FE-LIST+",sSPfe_listP,SI,list(5, + list(3,sLdivision_by_zero,make_fixnum(FPE_FLTDIV),make_fixnum(FE_DIVBYZERO)), + list(3,sLfloating_point_overflow,make_fixnum(FPE_FLTOVF),make_fixnum(FE_OVERFLOW)), + list(3,sLfloating_point_underflow,make_fixnum(FPE_FLTUND),make_fixnum(FE_UNDERFLOW)), + list(3,sLfloating_point_inexact,make_fixnum(FPE_FLTRES),make_fixnum(FE_INEXACT)), + list(3,sLfloating_point_invalid_operation,make_fixnum(FPE_FLTINV),make_fixnum(FE_INVALID))),""); + +DEF_ORDINARY("FLOATING-POINT-ERROR",sSfloating_point_error,SI,""); + +static void +sigpipe(void) +{ + gcl_signal(SIGPIPE, sigpipe); + perror(""); + FEerror("Broken pipe", 0); +} + + +void +sigint(void) +{ + unblock_signals(SIGINT,SIGINT); + terminal_interrupt(1); +} + + + +static void +sigalrm(void) +{ + unblock_signals(SIGALRM,SIGALRM); + raise_pending_signals(sig_try_to_delay); +} + +DEFVAR("*INTERRUPT-ENABLE*",sSAinterrupt_enableA,SI,sLt,""); + +DEF_ORDINARY("SIGUSR1-INTERRUPT",sSsigusr1_interrupt,SI,""); +DEF_ORDINARY("SIGIO-INTERRUPT",sSsigio_interrupt,SI,""); + +static void +sigusr1(void) +{ifuncall1(sSsigusr1_interrupt,Cnil);} + +static void +sigio(void) +{ifuncall1(sSsigio_interrupt,Cnil);} + + + +void +install_default_signals(void) +{ gcl_signal(SIGFPE, sigfpe3); + gcl_signal(SIGPIPE, sigpipe); + gcl_signal(SIGINT, sigint); + gcl_signal(SIGUSR1, sigusr1); + gcl_signal(SIGIO, sigio); + gcl_signal(SIGALRM, sigalrm); + + /*install_segmentation_catcher(); */ + signals_allowed = sig_normal; + } + + + + +#endif diff --git a/o/usig2.c b/o/usig2.c new file mode 100755 index 0000000..561d44b --- /dev/null +++ b/o/usig2.c @@ -0,0 +1,427 @@ +/* + Copyright (C) 1994 W. Schelter + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with GCL; see the file COPYING. If not, write to the Free Software +Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +*/ + + +#ifndef IN_UNIXINT +#define NEED_MP_H +#include +#include +#include +#include "include.h" + +static void +invoke_handler(int,int); + + +#ifndef USIG2 +#include +#include "usig.h" +/* #include "arith.h" */ +#endif +#endif + +#ifdef USIG2 +#include USIG2 +#else + + + +/* these sstructure pointers would need their structures provided... + so we just call them void */ +void * sfaslp; + +#ifdef CMAC +EXTER +unsigned long s4_neg_int[4],small_neg_int[3],small_pos_int[3]; +#endif + + +/* + We have two mechanisms for protecting against interrupts. 1] We have a + facility for delaying certain signals during critical regions of code. + This facility will involve BEGIN_NO_INTERRUPT and END_NO_INTERRUPT + +*/ + +handler_function_type our_signal_handler[32]; + +struct save_for_interrupt{ + object free1[32]; + object free2[32]; + object altfree1[32]; + object altfree2[32]; + union lispunion buf[32]; + struct call_data fcall; + object *vs_top,vs_topVAL,*vs_base; + struct bds_bd *bds_top,bds_topVAL; + struct invocation_history *ihs_top,ihs_topVAL; + char *token_bufp; + char token_buf [4*INITIAL_TOKEN_LENGTH]; + int token_st_dim; + /* for storing the XS objects in te usig2_aux.c */ + void *save_objects[75]; + + }; + + +/* note these are the reverse of the ones in unixint.c + ... uggghhh*/ + + +#undef SS1 +#undef RS1 +#define SS1(a,b) a = b ; +#define RS1(a,b) b = a ; + + /* save objects in save_objects list */ + + + +char signals_handled [] = {SIGINT,SIGUSR2,SIGUSR1,SIGIO,SIGALRM, +#ifdef OTHER_SIGNALS_HANDLED + OTHER_SIGNALS_HANDLED +#endif + 0}; + +/* * in_signal_handler: if not zero indicates we are running inside a signal + handler, which may have been invoked at a random intruction, and so + it is not safe to do a relocatable gc. + + * signals_pending: if (signals_pending & signal_mask(signo)) then this + signo 's handler is waiting to be run. + + * signals_allowed: indicates the state we think we were in when + checking to invoke a signal. Values: + + sig_none: definitely dont run handler + sig_normal: In principle `ok', but if desiring maximum safety dont run here. + sig_safe: safe point to run a function (eg make_cons,...) + sig_at_read: interrupting the getc function in read. Should be safe. + + + unwind (used by throw,return etc) resets this to sig_normal just as it + does the longjmp. + + + If we invoke signal handling routines at a storage + allocation pt, it is completely safe: we should save + some of the globals, but the freelists etc dont need + to be saved. pass: sig_safe to raise_pending. + + If we invoke it at end of a No interrupts + region, then it we must look at whether these were nested. + We should probably have two endings for END_NO_INTERRUPTS, + one for when we want to raise, and one for where we are sure + we are at safe place. pass sig_use_signals_allowed_value + + If we invoke a handler when at + signals_allowed == sig_at_read, then we are safe. + */ + + +#define XX sig_safe +/* min safety level required for invoking a given signal handler */ +char safety_required[]={XX,XX,XX,XX,XX,XX,XX,XX, + XX,XX,XX,XX,XX,XX,XX,XX, + XX,XX,XX,XX,XX,XX,XX,XX, + XX,XX,XX,XX,XX,XX,XX,XX}; + +void +gcl_init_safety(void) +{ safety_required[SIGINT]=sig_try_to_delay; + safety_required[SIGALRM]=sig_normal; +} + +DO_INIT(gcl_init_safety();) +DEFUN_NEW("SIGNAL-SAFETY-REQUIRED",object,sSsignal_safety_required,SI,2,2, + NONE,OI,IO,OO,OO,(fixnum signo,fixnum safety), + "Set the safety level required for handling SIGNO to SAFETY, or if \ +SAFETY is negative just return the current safety level for that \ +signal number. Value of 1 means allow interrupt at any place not \ +specifically marked in the code as bad, and value of 2 means allow it \ +only in very SAFE places.") + +{ if (signo > sizeof(safety_required)) + {FEerror("Illegal signo:~a.",1,make_fixnum(signo));} + if (safety >=0) safety_required[signo] = safety; + return small_fixnum(safety_required[signo]) ; +} + + +void +#ifdef __MINGW32__ +main_signal_handler(int signo) +#else +main_signal_handler(int signo, int a, int b) +#endif +{ int allowed = signals_allowed; +#ifdef NEED_TO_REINSTALL_SIGNALS + signal(signo,main_signal_handler); +#endif + if (allowed >= safety_required[signo]) + { signals_allowed = sig_none; + + if (signo == SIGUSR1 || + signo == SIGIO) + { unblock_sigusr_sigio();} + + invoke_handler(signo,allowed); + signals_allowed = allowed; + } + else { + signals_pending |= signal_mask(signo); + alarm(1);} + return; + + } + +static void before_interrupt(struct save_for_interrupt *p, int allowed); +static void after_interrupt(struct save_for_interrupt *p, int allowed); + +/* caller saves and restores the global signals_allowed; */ +static void +invoke_handler(int signo, int allowed) +{struct save_for_interrupt buf; + before_interrupt(&buf,allowed); + signals_pending &= ~(signal_mask(signo)); + {int prev_in_handler = in_signal_handler; + in_signal_handler |= (allowed <= sig_normal ? 1 : 0); + signals_allowed = allowed; + our_signal_handler[signo](signo); + signals_allowed = 0; + in_signal_handler = prev_in_handler; + after_interrupt(&buf,allowed); +}} + +int tok_leng; +static void +before_interrupt(struct save_for_interrupt *p, int allowed) +{int i; + /* all this must be run in no interrupts mode */ + if ( allowed < sig_safe) + { /* save tht tops of the free stacks */ + for(i=0; i < t_end ; i++) + { struct typemanager *ad = &tm_table[i]; + {SS1(p->free1[i],ad->tm_free); + if (p->free1[i]) + { char *beg = (char *) (p->free1[i]); + object x = (object)beg; + int amt = ad->tm_size; + SS1(p->free2[i],OBJ_LINK(p->free1[i])); + ad->tm_nfree --; + bcopy(beg ,&(p->buf[i]), amt); + bzero(beg+sizeof(struct freelist),amt-sizeof(struct freelist)); + make_unfree(x); + if (p->free2[i]) + { x = (object) p->free2[i]; + beg = (char *)x; + make_unfree(x); + bzero(beg+sizeof(struct freelist),amt-sizeof(struct freelist)); + SS1(ad->tm_free,OBJ_LINK(p->free2[i])); + ad->tm_nfree --; + } + else + { SS1(ad->tm_free, OBJ_LINK(p->free1[i])); + }} + }} + } + SS1(p->fcall,fcall); + SS1(p->vs_top,vs_top); + SS1(p->vs_topVAL,*vs_top); + SS1(p->vs_base,vs_base); + SS1(p->bds_top,bds_top); + SS1(p->bds_topVAL,*bds_top); + SS1(p->ihs_top,ihs_top); + SS1(p->ihs_topVAL,*ihs_top); + { void **pp = p->save_objects; +#undef XS +#undef XSI +#define XS(a) *pp++ = (void *) (a); +#define XSI(a) *pp++ = (void *)(long)(a); +/* #define XS(a) *pp++ = * (void **) (&a); */ +#include "usig2_aux.c" + if ((pp - (&(p->save_objects)[0])) >= (sizeof(p->save_objects)/sizeof(void *))) + abort(); + } +#define MINN(a,b) (atoken_st_dim = MINN(token->st.st_dim,tok_leng+1); + if (p->token_st_dim < sizeof(p->token_buf)) + p->token_bufp = p->token_buf; + else { p->token_bufp= (void *)alloca(p->token_st_dim);} + bcopy(token->st.st_self,p->token_bufp,p->token_st_dim); + +} + +static void +after_interrupt(struct save_for_interrupt *p, int allowed) +{int i; + /* all this must be run in no interrupts mode */ + if ( allowed < sig_safe) + { + for(i=0; i < t_end ; i++) + { struct typemanager *ad = &tm_table[i]; + object current_fl = ad->tm_free; + {RS1(p->free1[i],ad->tm_free); + if (p->free1[i]) + { char *beg = (char *) (p->free1[i]); + object x = (object)beg; + int amt = ad->tm_size; + RS1(p->free2[i],(p->free1[i])); + if (is_marked_or_free(x)) error("should not be free"); + bcopy(&(p->buf[i]),beg, amt); + if (p->free2[i]) + { x = (object) p->free2[i]; + if (is_marked_or_free(x)) error("should not be free"); + make_free(x); + F_LINK(F_LINK(ad->tm_free)) = (long )current_fl; + ad->tm_nfree += 2; + } + else + ad->tm_nfree =1; + } + + else ad->tm_nfree =0; + }} + } + RS1(p->fcall,fcall); + RS1(p->vs_top,vs_top); + RS1(p->vs_topVAL,*vs_top); + RS1(p->vs_base,vs_base); + RS1(p->bds_top,bds_top); + RS1(p->bds_topVAL,*bds_top); + RS1(p->ihs_top,ihs_top); + RS1(p->ihs_topVAL,*ihs_top); + { void **pp = p->save_objects; +#undef XS +#undef XSI + + /* #define XS(a) a = (void *)(*pp++) + We store back in the location 'a' the value we have saved. + */ + +/* #define XS(a) do { void **_p = (void **)(&a); *_p = (void *)(*pp++);}while(0) */ +#define XS(a) a = (void *)(*pp++) +#define XSI(a) {union {void *v;long l;}u; u.v=*pp++; a = u.l;} +#include "usig2_aux.c" + } + + bcopy(p->token_bufp,token->st.st_self,p->token_st_dim); +} + + +/* claim the following version of make_cons can be interrupted at any line + and is suitable for inlining. +*/ + +/* static object */ +/* MakeCons(object a, object b) */ +/* { struct typemanager*ad = &tm_table[t_cons]; */ +/* object new = (object) ad->tm_free; */ +/* if (new == 0) */ +/* { new = alloc_object(t_cons); */ +/* new->c.c_car = a; */ +/* goto END; */ +/* } */ + +/* new->c.c_car=a; */ + /* interrupt here and before_interrupt will copy new->c into the + C stack, so that a will be protected */ +/* new->c.t=t_cons; */ +/* new->c.m= 0; */ + /* Make interrupt copy new out to the stack and then zero new. + That way new is certainly gc valid, and its contents are protected. + So the above three operations can occur in any order. + */ + +/* { object tem = OBJ_LINK(new); */ + /* + interrupt here and we see that before_interrupt must save the top of the + free list AND the second thing on the Free list. That way we will be ok + here and an interrupt here could not affect tem. It is possible that tem + == 0, yet a gc happened in between. An interrupt here when tem = 0 would + mean the free list needs to be collected again by second gc. + */ +/* ad->tm_free = tem; */ +/* } */ + /* Whew: we got it safely off so interrupts can't hurt us now. */ +/* ad->tm_nfree --; */ + /* interrupt here and the cdr field will point to a f_link which is + a 'free' and so gc valid. b is still protected since + it is in the stack or a regiseter, and a is protected since it is + in new, and new is not free + */ +/* END: */ +/* new->c.c_cdr=b; */ +/* return new; */ +/* } */ + + +/* COND is the condition where this is raised. + Might be sig_safe (eg at cons). */ + +void +raise_pending_signals(int cond) +{unsigned int allowed = signals_allowed ; + if (cond == sig_use_signals_allowed_value) + if (cond == sig_none || interrupt_enable ==0) return ; + + + AGAIN: + { unsigned int pending = signals_pending; + char *p = signals_handled; + if (pending) + while(*p) + { if (signal_mask(*p) & pending + && cond >= safety_required[(unsigned char)*p]) + { + signals_pending &= ~(signal_mask(*p)); + if (*p == SIGALRM && cond >= sig_safe) + { alarm(0);} + else + invoke_handler(*p,cond); + goto AGAIN; + } + p++; + } + signals_allowed = allowed; + return; + }} + + +DEFUN_NEW("ALLOW-SIGNAL",object,fSallow_signal,SI,1,1,NONE,OI,OO,OO,OO,(fixnum n), + "Install the default signal handler on signal N") + +{ + + signals_allowed |= signal_mask(n); + unblock_signals(n,n); + /* sys v ?? just restore the signal ?? */ + if (our_signal_handler[n]) + {gcl_signal(n,our_signal_handler[n]); + return make_fixnum(1); + } + else + return make_fixnum(0); +} + + + +#endif diff --git a/o/usig2_aux.c b/o/usig2_aux.c new file mode 100755 index 0000000..9262f85 --- /dev/null +++ b/o/usig2_aux.c @@ -0,0 +1,81 @@ +XSI(string_register->st.st_fillp); +XSI(string_register->st.st_fillp); +XSI(string_register->st.st_dim); +XS(string_register->st.st_self); +XSI(token->st.st_fillp); +XSI(in_signal_handler); +XSI(nlj_active); +XS(nlj_fr); +XS(nlj_tag); +XSI(PRINTarray); +XSI(PRINTbase); +XS(PRINTcase); +XSI(PRINTcircle); +XSI(PRINTescape); +XSI(PRINTgensym); +XSI(PRINTlength); +XSI(PRINTlevel); +XSI(PRINTpackage); +XSI(PRINTpretty); +XSI(PRINTradix); +XS(PRINTstream); +XSI(PRINTstructure); +XS(PRINTvs_limit); +XS(PRINTvs_top); +XSI(READbase); +XSI(READdefault_float_format); +XSI(READsuppress); +XS(READtable); +XSI(ctl_end); +XSI(ctl_index); +XSI(ctl_origin); +XS(endp_temp); +XSI(eval1); +XSI(line_length); +XSI(in_list_flag); +XS(kf); +XS(tf); +XSI(left_trim); +XSI(right_trim); +XS(lex_env); +XS(key_function); +XS(test_function); +XS(item_compared); +XSI(intern_flag); +XS(printStructBufp); +XS(sfaslp); +XSI(preserving_whitespace_flag); +XS(sharing_table); +XSI(string_sign); +XSI(string_boundary); +XS(car_or_cdr); +XS(casefun); +XS(tmp_alloc); +#ifndef GMP +#ifdef CMAC +XS(s4_neg_int[3]); +XS(small_neg_int[2]); +XS(small_pos_int[2]); +#endif +XS(overflow); +XS(top); +XS(hiremainder); +XS(in_saved_avma); +XS(avma ); +#endif + +/* put in NO_INTERRUPT +YS(fmt_base); +YS(fmt_end); +YS(fmt_indents); +YS(fmt_index); +YS(fmt_jmp_buf); +YS(fmt_line_length); +YS(fmt_nparam); +YS(fmt_paramp); +YS(fmt_spare_spaces); +YS(fmt_stream); +YS(fmt_string); +YS(fmt_temporary_stream); +YS(fmt_temporary_string); + */ diff --git a/o/utils.c b/o/utils.c new file mode 100755 index 0000000..06a54fd --- /dev/null +++ b/o/utils.c @@ -0,0 +1,229 @@ +#include +#include +#include +#include "include.h" + +/* The functions IisProp check the property holds, and return the + argument. They may in future allow resetting the argument. +*/ + +object +IisSymbol(object f) +{ if (type_of(f) != t_symbol) + { FEerror("Not a symbol ~s",1,f); } + return f; +} + +/* object */ +/* IisFboundp(object f) */ +/* { */ +/* IisSymbol(f); */ +/* if (f->s.s_gfdef ==0) */ +/* { FEerror("Not a fboundp ~s",1,f);} */ +/* return f; */ +/* } */ + +object +IisArray(object f) +{ if (TS_MEMBER(type_of(f), + TS(t_array) + |TS(t_vector) + |TS(t_bitvector) + |TS(t_string))) + return f; + else + { FEwrong_type_argument(sLarray,f); return f; + } +} + +object +Iis_fixnum(object f) +{ if (type_of(f)==t_fixnum) + { return f;} + else + { FEerror("Not a fixnum ~s",1,f); return f; + + } +} + +void Wrong_type_error(char *str,int n,...) { + FEerror("Wrong type error",0); +} + +/* static object */ +/* Iapply_ap(object (*f) (/\* ??? *\/), va_list ap) */ +/* Apply f to the va_list ap, with an implicit number of args + passed in VFUN_NARGS */ + + +/* { int n = VFUN_NARGS; */ +/* object *new; */ +/* COERCE_VA_LIST(new,ap,n); */ +/* return c_apply_n(f,n,new); */ +/* } */ + +object +Ifuncall_n(object fun,int n,...) { +/* call fun on the n optional args supplied, and set the fcall.nvalues etc + return the first value */ + va_list ap; + object *new; + va_start(ap,n); + { + COERCE_VA_LIST(new,ap,n); + } + va_end(ap); + return IapplyVector(fun,n,new); +} + + + +/* For applying FUN to args in VA_LIST, where n are supplied directly + and the last one is itself a va_list */ +/* object */ +/* Iapply_fun_n(object fun,int n,int m,...) { */ + +/* va_list ap1,ap; */ +/* object b[F_ARG_LIMIT]; */ +/* int i = 0; */ + +/* va_start(ap1,m); */ + +/* while (--n >= 0) */ +/* { b[i++] = va_arg(ap1,object);} */ +/* if (m > 0) { */ +/* ap = va_arg(ap1,va_list); */ +/* while (--m >= 0) */ +/* { b[i++] = va_arg(ap,object);} */ +/* } */ + +/* va_end(ap1); */ + +/* return IapplyVector(fun,i,b); */ + +/* } */ + + + +/* For applying FUN to args in VA_LIST, where n are supplied directly + and the last one is itself a va_list */ +/* object */ +/* Iapply_fun_n1(object (*fun)(),int n,int m,...) { */ + +/* va_list ap; */ +/* object b[F_ARG_LIMIT],*bb; */ +/* int i = 0; */ + +/* va_start(ap,m); */ + +/* while (--n >= 0) { */ +/* b[i++] = va_arg(ap,object);} */ +/* if (m > 0) { */ +/* bb = va_arg(ap,object *); */ +/* while (--m >= 0) */ +/* b[i++] = *bb++; */ +/* } */ + +/* va_end(ap); */ + +/* return IapplyVector(make_sfun(Cnil,fun,i,Cnil),i,b); */ +/* } */ + +/* For applying FUN to args in VA_LIST, where n are supplied directly + and the last one is itself a va_list */ +/* object */ +/* Iapply_fun_n2(object fun,int n,int m,...) { */ + +/* va_list ap,*app; */ +/* object b[F_ARG_LIMIT]; */ +/* int i = 0; */ + +/* va_start(ap,m); */ + +/* while (--n >= 0) { */ +/* b[i++] = va_arg(ap,object);} */ +/* if (m > 0) { */ +/* app = va_arg(ap,va_list *); */ +/* while (--m >= 0) */ +/* b[i++] = va_arg(*app,object); */ +/* } */ + +/* va_end(ap); */ + +/* return IapplyVector(fun,i,b); */ +/* } */ + + +/* static object */ +/* ImakeStructure(int n, object *p) */ +/* p[0]= structure name , p[1] = 1'st elt,.... p[n-1] = last elt. */ + + +/* { object * r = vs_top; */ +/* object res; */ +/* if (p+n != r) { FEerror("bad make struct",0);} */ +/* vs_base= p; */ +/* siLmake_structure(); */ +/* res = vs_base[0]; */ +/* vs_top=p; */ +/* return res; */ +/* } */ + +object +Icheck_one_type(object x, enum type t) +{ if (x->d.t != t) + { return CEerror("Expected a ~a ","Supply right type",1,type_name(t),Cnil,Cnil,Cnil); + } + return x; +} + + +object +fSincorrect_type(object val, object type) +{ return CEerror("Got ~a,Expected a ~a","Supply a new one",1,val,type,Cnil,Cnil); +} + +/* static void */ +/* Ineed_in_image(object (*foo) (/\* ??? *\/)) */ +/* {;} */ + +/* Convert a value stack type return to an fcall multiple vaule return + and return the actual value (or nil if no values); */ +object +Ivs_values(void) +{ fixnum n = fcall.nvalues = vs_top - vs_base; + object *b = vs_base,*p=&fcall.values[0]; + object res = (n > 0 ? b[0] : sLnil); + if (n>=(fixnum)(sizeof(fcall.values)/sizeof(*fcall.values))) + FEerror("Too many function call values",0); + while (--n > 0) + { *++p= *++b;} + return res; +} + + +/* static void */ +/* fatal(char *s, int i1, int i2) */ +/* { */ +/* fprintf(stderr,s,i1,i2); */ +/* exit(1); */ +/* } */ + + + +/* Copy STRING to BUF which has N bytes available. + If there is not enough space, malloc some */ +char * +lisp_copy_to_null_terminated(object string, char *buf, int n) +{ if(type_of(string) != t_string + && type_of(string) != t_symbol) + FEerror("Need to give symbol or string",0); + if (string->st.st_fillp +1 > n) + { buf= (void *)malloc(string->st.st_fillp +1); + } + bcopy(string->st.st_self,buf,string->st.st_fillp); + buf[string->st.st_fillp] = 0; + return buf; +} + + diff --git a/o/xdrfuns.c b/o/xdrfuns.c new file mode 100755 index 0000000..f74e7a4 --- /dev/null +++ b/o/xdrfuns.c @@ -0,0 +1,186 @@ +/* + Copyright (C) 1994 W. Schelter + +This file is part of GNU Common Lisp, herein referred to as GCL + +GCL is free software; you can redistribute it and/or modify it under +the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GCL is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +*/ + +#ifdef HAVE_XDR + +#ifdef DARWIN +#undef __LP64__ /*Apple header declaration bug workaround for xdr_long*/ +#endif + +#ifdef AIX3 +#include +#endif +#ifdef __CYGWIN__ +#include +#else /* __CYGWIN__ */ +#include +#endif /* __CYGWIN__ */ + +extern short aet_sizes[]; +static object +FFN(siGxdr_open)(f) + object f; +{ XDR *xdrs; + object ar= alloc_simple_string(sizeof(XDR)); + array_allocself(ar,1,OBJNULL); + xdrs= (XDR *) ar->a.a_self; + if (f->sm.sm_fp == 0) FEerror("stream not ok for xdr io",0); + xdrstdio_create(xdrs, f->sm.sm_fp, + (f->sm.sm_mode == smm_input ? XDR_DECODE : + f->sm.sm_mode == smm_output ? XDR_ENCODE : + (FEerror("stream not input or output",0),XDR_ENCODE))) + ; + return ar; +} + +static object +FFN(siGxdr_write)(object str,object elt) { + + XDR *xdrp= (XDR *) str->ust.ust_self; + xdrproc_t e; + + switch (type_of(elt)) { + case t_fixnum: + { + fixnum e=fix(elt); + if(xdr_long(xdrp,(long *)&e)) goto error; + } + break; + case t_longfloat: + if(xdr_double(xdrp,&lf(elt))) goto error; + break; + case t_shortfloat: + if(xdr_float(xdrp,&sf(elt))) goto error; + break; + case t_vector: + + switch(elt->v.v_elttype) { + case aet_lf: + e=(xdrproc_t)xdr_double; + break; + case aet_sf: + e=(xdrproc_t)xdr_float; + break; + case aet_fix: + e=(xdrproc_t)xdr_long; + break; + case aet_short: + e=(xdrproc_t)xdr_short; + break; + default: + FEerror("unsupported xdr size",0); + goto error; + break; + } + { + u_int tmp=elt->v.v_fillp; + if (tmp!=elt->v.v_fillp) + goto error; + if(xdr_array(xdrp,(void *)&elt->v.v_self, + &tmp, + elt->v.v_dim, + aet_sizes[elt->v.v_elttype], + e)) + goto error; + } + break; + default: + FEerror("unsupported xdr ~a",1,elt); + break; + } + return elt; + error: + FEerror("bad xdr write",0); + return elt; +} + +static object +FFN(siGxdr_read)(object str,object elt) { + + XDR *xdrp= (XDR *) str->ust.ust_self; + xdrproc_t e; + + switch (type_of(elt)) { + case t_fixnum: + {fixnum l; + if(xdr_long(xdrp,(long *)&l)) goto error; + return make_fixnum(l);} + break; + case t_longfloat: + {double x; + if(xdr_double(xdrp,&x)) goto error; + return make_longfloat(x);} + case t_shortfloat: + {float x; + if(xdr_float(xdrp,&x)) goto error; + return make_shortfloat(x);} + case t_vector: + switch(elt->v.v_elttype) { + case aet_lf: + e=(xdrproc_t)xdr_double; + break; + case aet_sf: + e=(xdrproc_t)xdr_float; + break; + case aet_fix: + e=(xdrproc_t)xdr_long; + break; + case aet_short: + e=(xdrproc_t)xdr_short; + break; + default: + FEerror("unsupported xdr size",0); + goto error; + break; + } + + { + u_int tmp=elt->v.v_fillp; + if (tmp!=elt->v.v_fillp) + goto error; + if(xdr_array(xdrp,(void *)&elt->v.v_self, + &tmp, + elt->v.v_dim, + aet_sizes[elt->v.v_elttype], + e)) + goto error; + } + return elt; + break; + default: + FEerror("unsupported xdr ~a",1,elt); + return elt; + break; + } + error: + FEerror("bad xdr read",0); + return elt; +} +static void +gcl_init_xdrfuns() +{ make_si_sfun("XDR-WRITE",siGxdr_write, + ARGTYPE2(f_object,f_object)|RESTYPE(f_object)); + + make_si_sfun("XDR-READ",siGxdr_read, + ARGTYPE2(f_object,f_object)|RESTYPE(f_object)); + make_si_sfun("XDR-OPEN",siGxdr_open, + ARGTYPE1(f_object)|RESTYPE(f_object)); + +} +#else +static void gcl_init_xdrfuns(void) {;} +#endif diff --git a/pcl/README b/pcl/README new file mode 100644 index 0000000..4b42f08 --- /dev/null +++ b/pcl/README @@ -0,0 +1,11 @@ +To install PCL at your site, follow the instructions in the defsys.lisp file. + + +If you use gcl (GNU Common Lisp), follow the instructions in impl/gcl/README. + +If you use cmucl17f, follow the instructions in impl/cmu/README, +then recompile PCL and rebuild the world. + +If you use lucid, just compile and load defsys, +then type (pcl::compile-pcl), or (pcl::load-pcl). + diff --git a/pcl/defsys.lisp b/pcl/defsys.lisp new file mode 100644 index 0000000..9980298 --- /dev/null +++ b/pcl/defsys.lisp @@ -0,0 +1,959 @@ +;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; +;;; Some support stuff for compiling and loading PCL. It would be nice if +;;; there was some portable make-system we could all agree to share for a +;;; while. At least until people really get databases and stuff. +;;; +;;; *** *** +;;; *** DIRECTIONS FOR INSTALLING PCL AT YOUR SITE *** +;;; *** *** +;;; +;;; To get PCL working at your site you should: +;;; +;;; - Get all the PCL source files from Xerox. The complete list of source +;;; file names can be found in the defsystem for PCL which appears towards +;;; the end of this file. +;;; +;;; - Edit the variable *pcl-directory* below to specify the directory at +;;; your site where the pcl sources and binaries will be. This variable +;;; can be found by searching from this point for the string "***" in +;;; this file. +;;; +;;; - Use the function (pcl::compile-pcl) to compile PCL for your site. +;;; +;;; - Once PCL has been compiled it can be loaded with (pcl::load-pcl). +;;; Note that PCL cannot be loaded on top of itself, nor can it be +;;; loaded into the same world it was compiled in. +;;; + +(in-package :user) + +#+kcl (in-package :walker :use '(:lisp)) +#+kcl (in-package :iterate :use '(:lisp :walker)) +#+kcl (in-package :pcl :use '(:walker :iterate :lisp)) + +(eval-when (compile load eval) + +(if (find-package ':walker) + (use-package '(:lisp) ':walker) + (make-package ':walker :use '(:lisp))) + +(if (find-package ':iterate) + (use-package '(:lisp :walker) ':iterate) + (make-package ':iterate :use '(:lisp :walker))) + +(if (find-package ':pcl) + (use-package '(:walker :iterate :lisp) ':pcl) + (make-package ':pcl :use '(:walker :iterate :lisp))) + +(export (intern (symbol-name :iterate) ;Have to do this here, + (find-package :iterate)) ;because in the defsystem + (find-package :iterate)) ;(later in this file) + ;we use the symbol iterate + ;to name the file +) + +(in-package :pcl) + +;;; +;;; Sure, its weird for this to be here, but in order to follow the rules +;;; about order of export and all that stuff, we can't put it in PKG before +;;; we want to use it. +;;; +(defvar *the-pcl-package* (find-package :pcl)) + +(defvar *pcl-system-date* "September 16 92 PCL (g)") + +(eval-when (compile load eval) +(defvar *pcl-proclaim* + '(optimize (speed 3) (safety #+kcl 0 #-kcl 1) (space 0) + #+lucid (compilation-speed 0))) +) + +#-cmu ; see pclcom.lisp +(proclaim *pcl-proclaim*) + +#+cmu +(setf (getf ext:*herald-items* :pcl) + `(" CLOS based on PCL version: " ,*pcl-system-date*)) + +;;; +;;; Various hacks to get people's *features* into better shape. +;;; +(eval-when (compile load eval) + #+(and Symbolics Lispm) + (multiple-value-bind (major minor) (sct:get-release-version) + (etypecase minor + (integer) + (string (setf minor (parse-integer minor :junk-allowed t)))) + (pushnew :genera *features*) + (ecase major + ((6) + (pushnew :genera-release-6 *features*)) + ((7) + (pushnew :genera-release-7 *features*) + (pushnew :copy-&rest-arg *features*) + (ecase minor + ((0 1) (pushnew :genera-release-7-1 *features*)) + ((2) (pushnew :genera-release-7-2 *features*)) + ((3) (pushnew :genera-release-7-3 *features*)) + ((4) (pushnew :genera-release-7-4 *features*)))) + ((8) + (pushnew :genera-release-8 *features*) + (ecase minor + ((0) (pushnew :genera-release-8-0 *features*)) + ((1) (pushnew :genera-release-8-1 *features*)))))) + + #+CLOE-Runtime + (let ((version (lisp-implementation-version))) + (when (string-equal version "2.0" :end1 (min 3 (length version))) + (pushnew :cloe-release-2 *features*))) + + (dolist (feature *features*) + (when (and (symbolp feature) ;3600!! + (equal (symbol-name feature) "CMU")) + (pushnew :CMU *features*))) + + #+TI + (if (eq (si:local-binary-file-type) :xld) + (pushnew ':ti-release-3 *features*) + (pushnew ':ti-release-2 *features*)) + + #+Lucid + (when (search "IBM RT PC" (machine-type)) + (pushnew :ibm-rt-pc *features*)) + + #+ExCL + (cond ((search "sun3" (lisp-implementation-version)) + (push :sun3 *features*)) + ((search "sun4" (lisp-implementation-version)) + (push :sun4 *features*))) + + #+(and HP Lucid) + (push :HP-Lucid *features*) + #+(and HP (not Lucid) (not excl)) + (push :HP-HPLabs *features*) + + #+Xerox + (case il:makesysname + (:lyric (push :Xerox-Lyric *features*)) + (otherwise (push :Xerox-Medley *features*))) +;;; +;;; For KCL and IBCL, push the symbol :turbo-closure on the list *features* +;;; if you have installed turbo-closure patch. See the file kcl-mods.text +;;; for details. +;;; +;;; The xkcl version of KCL has this fixed already. +;;; + + #+xkcl(pushnew :turbo-closure *features*) + + ) + +#+(and excl sun4) +(eval-when (eval compile load) + (pushnew :excl-sun4 *features*)) + + + +;;; Yet Another Sort Of General System Facility and friends. +;;; +;;; The entry points are defsystem and operate-on-system. defsystem is used +;;; to define a new system and the files with their load/compile constraints. +;;; Operate-on-system is used to operate on a system defined that has been +;;; defined by defsystem. For example: +#|| + +(defsystem my-very-own-system + "/usr/myname/lisp/" + ((classes (precom) () ()) + (methods (precom classes) (classes) ()) + (precom () (classes methods) (classes methods)))) + +This defsystem should be read as follows: + +* Define a system named MY-VERY-OWN-SYSTEM, the sources and binaries + should be in the directory "/usr/me/lisp/". There are three files + in the system, there are named classes, methods and precom. (The + extension the filenames have depends on the lisp you are running in.) + +* For the first file, classes, the (precom) in the line means that + the file precom should be loaded before this file is loaded. The + first () means that no other files need to be loaded before this + file is compiled. The second () means that changes in other files + don't force this file to be recompiled. + +* For the second file, methods, the (precom classes) means that both + of the files precom and classes must be loaded before this file + can be loaded. The (classes) means that the file classes must be + loaded before this file can be compiled. The () means that changes + in other files don't force this file to be recompiled. + +* For the third file, precom, the first () means that no other files + need to be loaded before this file is loaded. The first use of + (classes methods) means that both classes and methods must be + loaded before this file can be compiled. The second use of (classes + methods) mean that whenever either classes or methods changes precom + must be recompiled. + +Then you can compile your system with: + + (operate-on-system 'my-very-own-system :compile) + +and load your system with: + + (operate-on-system 'my-very-own-system :load) + +||# + +;;; +(defvar *system-directory*) + +;;; +;;; *port* is a list of symbols (in the PCL package) which represent the +;;; Common Lisp in which we are now running. Many of the facilities in +;;; defsys use the value of *port* rather than #+ and #- to conditionalize +;;; the way they work. +;;; +(defparameter *port+dname-list* + (mapcar #'(lambda (x) + (cons (if (consp x) (car x) x) + (string-downcase (if (consp x) (cadr x) x)))) + '(#+Genera (Genera symbolics) +; #+Genera-Release-6 (Rel-6 symbolics) +; #+Genera-Release-7-1 (Rel-7 symbolics) + #+Genera-Release-7-2 (Rel-7 symbolics) + #+Genera-Release-7-3 (Rel-7 symbolics) + #+Genera-Release-7-1 (Rel-7-1 symbolics) + #+Genera-Release-7-2 (Rel-7-2 symbolics) + #+Genera-Release-7-3 (Rel-7-2 symbolics) ;OK for now + #+Genera-Release-7-4 (Rel-7-2 symbolics) ;OK for now + #+Genera-Release-8 (Rel-8 symbolics) + #+imach (Ivory symbolics) + #+Cloe-Runtime (Cloe symbolics) + #+Lucid Lucid + #+Xerox Xerox + #+Xerox-Lyric (Xerox-Lyric xerox) + #+Xerox-Medley (Xerox-Medley xerox) + #+TI TI + #+(and dec vax common) Vaxlisp + #+KCL KCL + #+IBCL IBCL + #+gcl gcl + #+excl (excl franz) + #+(and excl sun4) (excl-sun4 franz) + #+:CMU CMU + #+HP-HPLabs (HP-HPLabs hp) + #+:gclisp (gclisp gold-hill) + #+pyramid pyramid + #+:coral coral))) + +(defparameter *port* (mapcar #'car *port+dname-list*)) + +(defparameter *put-impl-binaries-in-impl-directory-p* + nil) + +;;; +;;; When you get a copy of PCL (by tape or by FTP), the sources files will +;;; have extensions of ".lisp" in particular, this file will be defsys.lisp. +;;; The preferred way to install pcl is to rename these files to have the +;;; extension which your lisp likes to use for its files. Alternately, it +;;; is possible not to rename the files. See below. +;;; +;;; Note: Something people installing PCL on a machine running Unix +;;; might find useful. If you want to change the extensions +;;; of the source files from ".lisp" to ".lsp", *all* you have +;;; to do is the following: +;;; +;;; % foreach i (*.lisp) +;;; ? mv $i $i:r.lsp +;;; ? end +;;; % +;;; +;;; I am sure that a lot of people already know that, and some +;;; Unix hackers may say, "jeez who doesn't know that". Those +;;; same Unix hackers are invited to fix mv so that I can type +;;; "mv *.lisp *.lsp". +;;; +(defvar *default-pathname-extensions* + (car '(#+(and (not imach) genera) ("lisp" . "bin") + #+(and imach genera) ("lisp" . "ibin") + #+Cloe-Runtime ("l" . "fasl") + #+(and dec common vax (not ultrix)) ("LSP" . "FAS") + #+(and dec common vax ultrix) ("lsp" . "fas") + #+KCL ("lsp" . "o") + #+IBCL ("lsp" . "o") + #+Xerox ("lisp" . "dfasl") + #+(and Lucid MC68000) ("lisp" . "lbin") + #+(and Lucid VAX) ("lisp" . "vbin") + #+(and Lucid Prime) ("lisp" . "pbin") + #+(and Lucid SUNRise) ("lisp" . "sbin") + #+(and Lucid SPARC) ("lisp" . "sbin") + #+(and Lucid IBM-RT-PC) ("lisp" . "bbin") + #+(and Lucid MIPS) ("lisp" . "mbin") + #+(and Lucid PRISM) ("lisp" . "abin") + #+(and Lucid PA) ("lisp" . "hbin") + #+(and excl SPARC) ("cl" . "sparc") + #+(and excl m68k) ("cl" . "m68k") + #+excl ("cl" . "fasl") + #+cmu ("lisp" . #.(c:backend-fasl-file-type c:*backend*)) + #+HP-HPLabs ("l" . "b") + #+TI ("lisp" . #.(string (si::local-binary-file-type))) + #+:gclisp ("LSP" . "F2S") + #+pyramid ("clisp" . "o") + #+:coral ("lisp" . "fasl") + #-(or symbolics (and dec common vax) KCL IBCL Xerox + lucid excl :CMU HP TI :gclisp pyramid coral) + ("lisp" . "lbin")))) + +;;; Note: In previous versions of PCL, the defvar for *pathname-extensions* +;;; assumed that files WERE renamed, (files-renamed-p was bound to t). +;;; Now, this defvar assumes that the files are not renamed, unless the +;;; symbol :pcl-files-renamed-p is put on the *features* list. + +#| ; Remove this line if you have renamed the PCL source files. +(eval-when (compile load eval) (pushnew :pcl-files-renamed-p *features*)) +|# ; Remove this line if you have renamed the PCL source files. + +(defvar *pathname-extensions* + (let ((proper-extensions (or *default-pathname-extensions* + '("lisp" . "lbin")))) + #+pcl-files-renamed-p proper-extensions + #-pcl-files-renamed-p (cons "lisp" (cdr proper-extensions)))) + +(eval-when (compile load eval) + +(defun get-system (name) + (get name 'system-definition)) + +(defun set-system (name new-value) + (setf (get name 'system-definition) new-value)) + +(defmacro defsystem (name directory files) + `(set-system ',name (list #'(lambda () ,directory) + (make-modules ',files) + ',(mapcar #'car files)))) + +) + + +;;; +;;; The internal datastructure used when operating on a system. +;;; +(defstruct (module (:constructor make-module (name)) + (:print-function + (lambda (m s d) + (declare (ignore d)) + (format s "#" (module-name m))))) + name + load-env + comp-env + recomp-reasons + port) + +(defun make-modules (system-description) + (let ((modules ())) + (labels ((get-module (name) + (or (find name modules :key #'module-name) + (progn (setq modules (cons (make-module name) modules)) + (car modules)))) + (parse-spec (spec) + (if (eq spec 't) + (reverse (cdr modules)) + (case (car spec) + (+ (append (reverse (cdr modules)) + (mapcar #'get-module (cdr spec)))) + (- (let ((rem (mapcar #'get-module (cdr spec)))) + (remove-if #'(lambda (m) (member m rem)) + (reverse (cdr modules))))) + (otherwise (mapcar #'get-module spec)))))) + (dolist (file system-description) + (let* ((name (car file)) + (port (car (cddddr file))) + (module nil)) + (when (or (null port) + (member port *port*)) + (setq module (get-module name)) + (setf (module-load-env module) (parse-spec (cadr file)) + (module-comp-env module) (parse-spec (caddr file)) + (module-recomp-reasons module) (parse-spec (cadddr file)) + (module-port module) port)))) + (let ((filenames (mapcar #'car system-description))) + (sort modules #'(lambda (name1 name2) + (member name2 (member name1 filenames))) + :key #'module-name))))) + + +(defun make-transformations (modules filter make-transform) + (declare (type function filter make-transform)) + (let ((transforms (list nil))) + (dolist (m modules) + (when (funcall filter m transforms) + (funcall make-transform m transforms))) + (reverse (cdr transforms)))) + +(defun make-compile-transformation (module transforms) + (unless (dolist (trans transforms) + (and (eq (car trans) ':compile) + (eq (cadr trans) module) + (return t))) + (dolist (c (module-comp-env module)) + (make-load-transformation c transforms)) + (setf (cdr transforms) + (remove-if #'(lambda (trans) (and (eq (car trans) :load) + (eq (cadr trans) module))) + (cdr transforms))) + (push `(:compile ,module) (cdr transforms)))) + +(defvar *being-loaded* ()) + +(defun make-load-transformation (module transforms) + (if (assoc module *being-loaded*) + (throw module (setf (cdr transforms) + (cdr (assoc module *being-loaded*)))) + (let ((*being-loaded* (cons (cons module (cdr transforms)) + *being-loaded*))) + (catch module + (unless (dolist (trans transforms) + (when (and (eq (car trans) ':load) + (eq (cadr trans) module)) + (return t))) + (dolist (l (module-load-env module)) + (make-load-transformation l transforms)) + (push `(:load ,module) (cdr transforms))))))) + +(defun make-load-without-dependencies-transformation (module transforms) + (unless (dolist (trans transforms) + (and (eq (car trans) ':load) + (eq (cadr trans) module) + (return trans))) + (push `(:load ,module) (cdr transforms)))) + +(defun compile-filter (module transforms) + (or (dolist (r (module-recomp-reasons module)) + (when (dolist (transform transforms) + (when (and (eq (car transform) ':compile) + (eq (cadr transform) r)) + (return t))) + (return t))) + (null (probe-file (make-binary-pathname module))) + (> (file-write-date (make-source-pathname module)) + (file-write-date (make-binary-pathname module))))) + +(defun operation-transformations (name mode &optional arg) + (let ((system (get-system name))) + (unless system (error "Can't find system with name ~S." name)) + (let ((*system-directory* (funcall (the function (car system)))) + (modules (cadr system))) + (ecase mode + (:compile + ;; Compile any files that have changed and any other files + ;; that require recompilation when another file has been + ;; recompiled. + (make-transformations + modules + #'compile-filter + #'make-compile-transformation)) + (:recompile + ;; Force recompilation of all files. + (make-transformations + modules + #'true + #'make-compile-transformation)) + (:recompile-some + ;; Force recompilation of some files. Also compile the + ;; files that require recompilation when another file has + ;; been recompiled. + (make-transformations + modules + #'(lambda (m transforms) + (or (member (module-name m) arg) + (compile-filter m transforms))) + #'make-compile-transformation)) + (:query-compile + ;; Ask the user which files to compile. Compile those + ;; and any other files which must be recompiled when + ;; another file has been recompiled. + (make-transformations + modules + #'(lambda (m transforms) + (or (compile-filter m transforms) + (y-or-n-p "Compile ~A?" + (module-name m)))) + #'make-compile-transformation)) + (:confirm-compile + ;; Offer the user a chance to prevent a file from being + ;; recompiled. + (make-transformations + modules + #'(lambda (m transforms) + (and (compile-filter m transforms) + (y-or-n-p "Go ahead and compile ~A?" + (module-name m)))) + #'make-compile-transformation)) + (:load + ;; Load the whole system. + (make-transformations + modules + #'true + #'make-load-transformation)) + (:query-load + ;; Load only those files the user says to load. + (make-transformations + modules + #'(lambda (m transforms) + (declare (ignore transforms)) + (y-or-n-p "Load ~A?" (module-name m))) + #'make-load-without-dependencies-transformation)))))) + +(defun true (&rest ignore) + (declare (ignore ignore)) + 't) + +#+cmu17 +(defparameter *byte-files* '(defclass defcombin iterate env)) + +(defun operate-on-system (name mode &optional arg print-only) + (let ((system (get-system name))) + (unless system (error "Can't find system with name ~S." name)) + (let* ((*system-directory* (funcall (the function (car system)))) + (transformations (operation-transformations name mode arg))) + (labels ((load-binary (name pathname) + (format t "~&Loading binary of ~A...~%" name) + (or print-only (load pathname))) + (load-module (m) + (let* ((name (module-name m)) + (*load-verbose* t) + (binary (make-binary-pathname m))) + (load-binary name binary))) + (compile-module (m) + (format t "~&Compiling ~A...~%" (module-name m)) + (unless print-only + (compile-file (make-source-pathname m) + :output-file + (make-pathname :defaults + (make-binary-pathname m) + :version :newest) + #+cmu17 :byte-compile #+cmu17 + (if (and (member (module-name m) *byte-files*) + (member :small *features*)) + t + :maybe))))) + (#+Genera + compiler:compiler-warnings-context-bind + #+TI + COMPILER:COMPILER-WARNINGS-CONTEXT-BIND + #+:LCL3.0 + lucid-common-lisp:with-deferred-warnings + #+cmu + with-compilation-unit #+cmu () + #-(or Genera TI :LCL3.0 cmu) + progn + (loop (when (null transformations) (return t)) + (let ((transform (pop transformations))) + (ecase (car transform) + (:compile (compile-module (cadr transform))) + (:load (load-module (cadr transform))))))))))) + +(defun make-source-pathname (name) (make-pathname-internal name :source)) +(defun make-binary-pathname (name) (make-pathname-internal name :binary)) + +(defun make-pathname-internal (name-or-module type) + (let* ((name (if (module-p name-or-module) + (module-name name-or-module) + name-or-module)) + (port (if (module-p name-or-module) + (module-port name-or-module) + nil)) + (extension (ecase type + (:source (car *pathname-extensions*)) + (:binary (cdr *pathname-extensions*)))) + (directory (pathname + (etypecase *system-directory* + (string *system-directory*) + (pathname *system-directory*) + (cons (ecase type + (:source (car *system-directory*)) + (:binary (cdr *system-directory*))))))) + (dir (pathname-directory directory)) + (ldir (if (consp dir) + dir + (pathname-directory (truename directory)))) + + (port-dname (when (and port + (or *put-impl-binaries-in-impl-directory-p* + (eq type ':source))) + (cdr (assoc port *port+dname-list*)))) + (port-directory (if port-dname + (append ldir (list "impl" port-dname)) + ldir)) + + (pathname + (make-pathname + :name (string-downcase (string name)) + :type extension + :directory port-directory + :defaults directory))) + + #+Genera + (setq pathname (zl:send pathname :new-raw-name (pathname-name pathname)) + pathname (zl:send pathname :new-raw-type (pathname-type pathname))) + + pathname)) + +(defun system-source-files (name) + (let ((system (get-system name))) + (unless system (error "Can't find system with name ~S." name)) + (let ((*system-directory* (funcall (the function (car system)))) + (modules (cadr system))) + (mapcar #'make-source-pathname modules)))) + +(defun system-binary-files (name) + (let ((system (get-system name))) + (unless system (error "Can't find system with name ~S." name)) + (let ((*system-directory* (funcall (the function (car system)))) + (modules (cadr system))) + (mapcar #'make-binary-pathname modules)))) + +;;; *** SITE SPECIFIC PCL DIRECTORY *** +;;; +;;; *pcl-directory* is a variable which specifies the directory pcl is stored +;;; in at your site. If the value of the variable is a single pathname, the +;;; sources and binaries should be stored in that directory. If the value of +;;; that directory is a cons, the CAR should be the source directory and the +;;; CDR should be the binary directory. +;;; +;;; By default, the value of *pcl-directory* is set to the directory that +;;; this file is loaded from. This makes it simple to keep multiple copies +;;; of PCL in different places, just load defsys from the same directory as +;;; the copy of PCL you want to use. +;;; +;;; Note that the value of *PCL-DIRECTORY* is set using a DEFVAR. This is +;;; done to make it possible for users to set it in their init file and then +;;; load this file. The value set in the init file will override the value +;;; here. +;;; +;;; *** *** + +(defun load-truename (&optional (errorp nil)) + #+cmu (declare (ignore errorp)) + (flet (#+(or Lispm Xerox LUCID) + (bad-time () + (when errorp + (error "LOAD-TRUENAME called but a file isn't being loaded.")))) + #+Lispm (or sys:fdefine-file-pathname (bad-time)) + #+excl excl::*source-pathname* + #+Xerox (pathname (or (il:fullname *standard-input*) (bad-time))) + #+(and dec vax common) (truename (sys::source-file #'load-truename)) + ;; + ;; The following use of `lucid::' is a kludge for 2.1 and 3.0 + ;; compatibility. In 2.1 it was in the SYSTEM package, and i + ;; 3.0 it's in the LUCID-COMMON-LISP package. + ;; + #+LUCID (or lucid::*source-pathname* (bad-time)) + #+akcl si:*load-pathname* + #+cmu17 *load-truename* + #-(or Lispm excl Xerox (and dec vax common) LUCID akcl cmu17) nil)) + +#-(or cmu Symbolics) +(defvar *pcl-directory* (concatenate 'string user::*system-directory* "../pcl/")) +; (or (load-truename t) +; (error "Because load-truename is not implemented in this port~%~ +; of PCL, you must manually edit the definition of the~%~ +; variable *pcl-directory* in the file defsys.lisp."))) + +#+cmu +(defvar *pcl-directory* (pathname "target:pcl/")) + +#+Genera +(defvar *pcl-directory* + (let ((source (load-truename t))) + (flet ((subdir (name) + (scl:send source :new-pathname :raw-directory + (append (scl:send source :raw-directory) + (list name))))) + (cons source + #+genera-release-7-2 (subdir "rel-7-2") + #+genera-release-7-3 (subdir "rel-7-3") + #+genera-release-7-4 (subdir "rel-7-4") + #+genera-release-8-0 (subdir "rel-8-0") + #+genera-release-8-1 (subdir "rel-8-1") + )))) + +#+Cloe-Runtime +(defvar *pcl-directory* (pathname "/usr3/hornig/pcl/")) + +(defsystem pcl + *pcl-directory* + ;; + ;; file load compile files which port + ;; environment environment force the of + ;; recompilation + ;; of this file + ;; + ( +; (rel-6-patches t t () rel-6) +; (rel-7-1-patches t t () rel-7-1) + (rel-7-2-patches t t () rel-7-2) + (rel-8-patches t t () rel-8) + (ti-patches t t () ti) + (pyr-patches t t () pyramid) + (xerox-patches t t () xerox) + (kcl-patches t t () kcl) + (ibcl-patches t t () ibcl) + (gold-patches t t () gclisp) + + (gcl_pcl_pkg t t ()) + (sys-proclaim t t () kcl) + (gcl_pcl_walk (gcl_pcl_pkg) (gcl_pcl_pkg) ()) + (gcl_pcl_iterate t t ()) + (gcl_pcl_macros t t ()) + (gcl_pcl_low (gcl_pcl_pkg gcl_pcl_macros) t (gcl_pcl_macros)) + + + (genera-low (gcl_pcl_low) (gcl_pcl_low) (gcl_pcl_low) Genera) + (cloe-low (gcl_pcl_low) (gcl_pcl_low) (gcl_pcl_low) Cloe) + (lucid-low (gcl_pcl_low) (gcl_pcl_low) (gcl_pcl_low) Lucid) + (Xerox-low (gcl_pcl_low) (gcl_pcl_low) (gcl_pcl_low) Xerox) + (ti-low (gcl_pcl_low) (gcl_pcl_low) (gcl_pcl_low) TI) + (vaxl-low (gcl_pcl_low) (gcl_pcl_low) (gcl_pcl_low) vaxlisp) + (kcl-low (gcl_pcl_low) (gcl_pcl_low) (gcl_pcl_low) KCL) + (ibcl-low (gcl_pcl_low) (gcl_pcl_low) (gcl_pcl_low) IBCL) + (gcl_pcl_impl_low (gcl_pcl_low) (gcl_pcl_low) (gcl_pcl_low) gcl) + (excl-low (gcl_pcl_low) (gcl_pcl_low) (gcl_pcl_low) excl) + (cmu-low (gcl_pcl_low) (gcl_pcl_low) (gcl_pcl_low) CMU) + (hp-low (gcl_pcl_low) (gcl_pcl_low) (gcl_pcl_low) HP-HPLabs) + (gold-low (gcl_pcl_low) (gcl_pcl_low) (gcl_pcl_low) gclisp) + (pyr-low (gcl_pcl_low) (gcl_pcl_low) (gcl_pcl_low) pyramid) + (coral-low (gcl_pcl_low) (gcl_pcl_low) (gcl_pcl_low) coral) + + (gcl_pcl_fin t t (gcl_pcl_low)) + (gcl_pcl_defclass t t (gcl_pcl_low)) + (gcl_pcl_defs t t (gcl_pcl_defclass gcl_pcl_macros gcl_pcl_iterate)) + (gcl_pcl_fngen t t (gcl_pcl_low)) + (gcl_pcl_cache t t (gcl_pcl_low gcl_pcl_defs)) + (gcl_pcl_dlisp t t (gcl_pcl_defs gcl_pcl_low gcl_pcl_fin gcl_pcl_cache)) + (gcl_pcl_dlisp2 t t (gcl_pcl_low gcl_pcl_fin gcl_pcl_cache gcl_pcl_dlisp)) + (gcl_pcl_boot t t (gcl_pcl_defs gcl_pcl_fin)) + (gcl_pcl_vector t t (gcl_pcl_boot gcl_pcl_defs gcl_pcl_cache gcl_pcl_fin)) + (gcl_pcl_slots_boot t t (gcl_pcl_vector gcl_pcl_boot gcl_pcl_defs gcl_pcl_cache gcl_pcl_fin)) + (gcl_pcl_combin t t (gcl_pcl_boot gcl_pcl_defs)) + (gcl_pcl_dfun t t (gcl_pcl_boot gcl_pcl_low gcl_pcl_cache)) + (gcl_pcl_fast_init t t (gcl_pcl_boot gcl_pcl_low)) + (gcl_pcl_braid (+ gcl_pcl_precom1 gcl_pcl_precom2) t (gcl_pcl_boot gcl_pcl_defs gcl_pcl_low gcl_pcl_fin gcl_pcl_cache)) + (gcl_pcl_generic_functions t t (gcl_pcl_boot)) + (gcl_pcl_slots t t (gcl_pcl_vector gcl_pcl_boot gcl_pcl_defs gcl_pcl_low gcl_pcl_cache gcl_pcl_fin)) + (gcl_pcl_init t t (gcl_pcl_vector gcl_pcl_boot gcl_pcl_defs gcl_pcl_low gcl_pcl_fast_init)) + (gcl_pcl_std_class t t (gcl_pcl_vector gcl_pcl_boot gcl_pcl_defs gcl_pcl_low gcl_pcl_cache gcl_pcl_fin gcl_pcl_slots)) + (gcl_pcl_cpl t t (gcl_pcl_vector gcl_pcl_boot gcl_pcl_defs gcl_pcl_low gcl_pcl_cache gcl_pcl_fin gcl_pcl_slots)) + (gcl_pcl_fsc t t (gcl_pcl_defclass gcl_pcl_boot gcl_pcl_defs gcl_pcl_low gcl_pcl_fin gcl_pcl_cache)) + (gcl_pcl_methods t t (gcl_pcl_defclass gcl_pcl_boot gcl_pcl_defs gcl_pcl_low gcl_pcl_fin gcl_pcl_cache)) + (gcl_pcl_fixup t t (gcl_pcl_boot gcl_pcl_defs gcl_pcl_low gcl_pcl_fin)) + (gcl_pcl_defcombin t t (gcl_pcl_defclass gcl_pcl_boot gcl_pcl_defs gcl_pcl_low gcl_pcl_fin)) + (gcl_pcl_ctypes t t (gcl_pcl_defclass gcl_pcl_defcombin)) + (gcl_pcl_env t t (gcl_pcl_defclass gcl_pcl_boot gcl_pcl_defs gcl_pcl_low gcl_pcl_fin)) + (gcl_pcl_compat t t ()) + (gcl_pcl_precom1 (gcl_pcl_dlisp) t (gcl_pcl_defs gcl_pcl_low gcl_pcl_cache gcl_pcl_fin gcl_pcl_dfun)) + (gcl_pcl_precom2 (gcl_pcl_dlisp) t (gcl_pcl_defs gcl_pcl_low gcl_pcl_cache gcl_pcl_fin gcl_pcl_dfun)) + )) + +(defun compile-pcl (&optional m) + (let (#+:coral(ccl::*warn-if-redefine-kernel* nil) + #+Lucid (lcl:*redefinition-action* nil) + #+excl (excl::*redefinition-warnings* nil) + #+Genera (sys:inhibit-fdefine-warnings t) + ) + (cond ((null m) (operate-on-system 'pcl :compile)) + ((eq m :print) (operate-on-system 'pcl :compile () t)) + ((eq m :query) (operate-on-system 'pcl :query-compile)) + ((eq m :confirm) (operate-on-system 'pcl :confirm-compile)) + ((eq m 't) (operate-on-system 'pcl :recompile)) + ((listp m) (operate-on-system 'pcl :compile-from m)) + ((symbolp m) (operate-on-system 'pcl :recompile-some `(,m)))))) + +(defun load-pcl (&optional m) + (let (#+:coral(ccl::*warn-if-redefine-kernel* nil) + #+Lucid (lcl:*redefinition-action* nil) + #+excl (excl::*redefinition-warnings* nil) + #+Genera (sys:inhibit-fdefine-warnings t) + ) + (cond ((null m) (operate-on-system 'pcl :load)) + ((eq m :query) (operate-on-system 'pcl :query-load))))) + +#+Genera +;;; Make sure Genera bug mail contains the PCL bug data. A little +;;; kludgy, but what the heck. If they didn't mean for people to do +;;; this, they wouldn't have made private patch notes be flavored +;;; objects, right? Right. +(progn + (scl:defflavor pcl-private-patch-info ((description)) ()) + (scl:defmethod (sct::private-patch-info-description pcl-private-patch-info) () + (or description + (setf description (string-append "PCL version: " *pcl-system-date*)))) + (scl:defmethod (sct::private-patch-info-pathname pcl-private-patch-info) () + *pcl-directory*) + (unless (find-if #'(lambda (x) (typep x 'pcl-private-patch-info)) + sct::*private-patch-info*) + (push (scl:make-instance 'pcl-private-patch-info) + sct::*private-patch-info*))) + +(defun bug-report-info (&optional (stream *standard-output*)) + (format stream "~&PCL system date: ~A~ + ~&Lisp Implementation type: ~A~ + ~&Lisp Implementation version: ~A~ + ~&*features*: ~S" + *pcl-system-date* + (lisp-implementation-type) + (lisp-implementation-version) + *features*)) + + + +;;;; +;;; +;;; This stuff is not intended for external use. +;;; +(defun rename-pcl () + (dolist (f (cadr (get-system 'pcl))) + (let ((old nil) + (new nil)) + (let ((*system-directory* *default-pathname-defaults*)) + (setq old (make-source-pathname (car f)))) + (setq new (make-source-pathname (car f))) + (rename-file old new)))) + +#+Genera +(defun edit-pcl () + (dolist (f (cadr (get-system 'pcl))) + (let ((*system-directory* *pcl-directory*)) + (zwei:find-file (make-source-pathname (car f)))))) + +#+Genera +(defun hardcopy-pcl (&optional query-p) + (let ((files (mapcar #'(lambda (f) + (setq f (car f)) + (and (or (not query-p) + (y-or-n-p "~A? " f)) + f)) + (cadr (get-system 'pcl)))) + (b zwei:*interval*)) + (unwind-protect + (dolist (f files) + (when f + (multiple-value-bind (ignore b) + (zwei:find-file (make-source-pathname f)) + (zwei:hardcopy-buffer b)))) + (zwei:make-buffer-current b)))) + + +;;; +;;; unido!ztivax!dae@seismo.css.gov +;;; z30083%tansei.cc.u-tokyo.junet@utokyo-relay.csnet +;;; Victor@carmen.uu.se +;;; mcvax!harlqn.co.uk!chris@uunet.UU.NET +;;; +#+Genera +(defun mail-pcl (to) + (let* ((original-buffer zwei:*interval*) + (*system-directory* (pathname "vaxc:/user/ftp/pub/pcl/") + ;(funcall (car (get-system 'pcl))) + ) + (files (list* 'defsys + 'test + (caddr (get-system 'pcl)))) + (total-number (length files)) + (file nil) + (number-of-lines 0) + (i 0) + (mail-buffer nil)) + (unwind-protect + (loop + (when (null files) (return nil)) + (setq file (pop files)) + (incf i) + (multiple-value-bind (ignore b) + (zwei:find-file (make-source-pathname file)) + (setq number-of-lines (zwei:count-lines b)) + (zwei:com-mail-internal t + :initial-to to + :initial-body b + :initial-subject + (format nil + "PCL file ~A (~A of ~A) ~D lines" + file i total-number number-of-lines)) + (setq mail-buffer zwei:*interval*) + (zwei:com-exit-com-mail) + (format t "~&Just sent ~A (~A of ~A)." b i total-number) + (zwei:kill-buffer mail-buffer))) + (zwei:make-buffer-current original-buffer)))) + +(defun reset-pcl-package () ; Try to do this safely + (let* ((vars '(*pcl-directory* + *default-pathname-extensions* + *pathname-extensions* + *redefined-functions*)) + (names (mapcar #'symbol-name vars)) + (values (mapcar #'symbol-value vars))) + (declare (special *redefined-functions*)) + (reset-package "PCL") + (let ((pkg (find-package "SLOT-ACCESSOR-NAME"))) + (when pkg + (do-symbols (sym pkg) + (makunbound sym) + (fmakunbound sym) + (setf (symbol-plist sym) nil)))) + (let ((pcl (find-package "PCL"))) + (mapcar #'(lambda (name value) + (let ((var (intern name pcl))) + (proclaim `(special ,var)) + (set var value))) + names values)) + (dolist (sym *redefined-functions*) + (setf (symbol-function sym) (get sym 'definition-before-pcl))) + nil)) + +(defun reset-package (&optional (package-name "PCL")) + (let ((pkg (find-package package-name))) + (do-symbols (sym pkg) + (when (eq pkg (symbol-package sym)) + (if (or (constantp sym) + #-cmu (member sym '(wrapper cache arg-info pv-table)) + #+cmu + (or (c::info setf inverse sym) + (c::info setf expander sym) + (c::info type kind sym) + (c::info function macro-function sym) + (c::info function compiler-macro-function sym))) + (unintern sym pkg) + (progn + (makunbound sym) + (unless (or (eq sym 'reset-pcl-package) + (eq sym 'reset-package)) + (fmakunbound sym) + #+cmu + (fmakunbound `(setf ,sym))) + (setf (symbol-plist sym) nil))))))) diff --git a/pcl/extensions/extensions.lisp b/pcl/extensions/extensions.lisp new file mode 100644 index 0000000..32231cf --- /dev/null +++ b/pcl/extensions/extensions.lisp @@ -0,0 +1,496 @@ +;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp; -*- + +;;; +;;; ************************************************************************* +;;; +;;; File: extensions.lisp. +;;; +;;; by Trent E. Lange, Effective Date 04-23-92 +;;; +;;; +;;; This file contains a small set of useful extensions to PCL. +;;; +;;; Permission is granted to any individual or institution to use, copy, +;;; modify and distribute this document. +;;; +;;; Suggestions, bugs, criticism and questions to lange@cs.ucla.edu +;;; ************************************************************************* +;;; + +(in-package 'pcl) + +(eval-when (compile load eval) + +(defvar *extensions-exports* + '(set-standard-instance-access + set-funcallable-instance-access + + funcallable-instance-slot-value + set-funcallable-instance-slot-value + funcallable-instance-slot-boundp + standard-instance-slot-value + set-standard-instance-slot-value + standard-instance-slot-boundp + structure-instance-slot-value + set-structure-instance-slot-value + structure-instance-slot-boundp + + #+pcl-user-instances + user-instance-slot-value + #+pcl-user-instances + set-user-instance-slot-value + #+pcl-user-instances + user-instance-slot-boundp + + with-optimized-slots + with-standard-instance-slots + + method-needs-next-methods-p + map-all-classes + finalize-all-classes + + updater + record-updater)) +) + +(defclass updater () + ((dependent :initarg :dependent :reader dependent))) + +(defun record-updater (class dependee dependent &rest initargs) + (let ((updater + (apply #'make-instance class :dependent dependent initargs))) + (add-dependent dependee updater) + updater)) + + +(defun finalize-all-classes (&optional (root-name 't)) + "Makes sure that all classes are finalized. If Root-Name is supplied, + then finalizes Root-Name and all of its subclasses and their subclasses." + (map-all-classes #'(lambda (class) + (unless (class-finalized-p class) + (finalize-inheritance class))) + root-name)) + + +;;; +;;; +;;; + + +(defmacro slot-value-from-index (instance wrapper slot-name slots index) + "Returns instance's slot-value given slot-name's index." + (once-only (index) + `(if ,index + (let ((val (%svref ,slots ,index))) + (if (eq val ',*slot-unbound*) + (slot-unbound (wrapper-class ,wrapper) ,instance ,slot-name) + val)) + (if *safe-to-use-slot-value-wrapper-optimizations-p* + (get-class-slot-value-1 ,instance ,wrapper ,slot-name) + (accessor-slot-value ,instance ,slot-name))))) + +(defmacro set-slot-value-from-index + (instance wrapper slot-name slots index new-value) + "Sets instance's slot-value to new-value given slot-name's index." + (once-only (index) + `(if ,index + (setf (%svref ,slots ,index) ,new-value) + (if *safe-to-use-set-slot-value-wrapper-optimizations-p* + (set-class-slot-value-1 ,instance ,wrapper ,slot-name ,new-value) + (setf (accessor-slot-value ,instance ,slot-name) ,new-value))))) + +(defsetf slot-value-from-index set-slot-value-from-index) + +(defmacro with-slots-slot-value-from-index + (instance wrapper slot-name slots index variable-instance) + "Returns instance's slot-value given slot-name's index." + (cond + ((consp wrapper) + `(let ((wrapper ,wrapper)) + (unless (eq (wrapper-state wrapper) 't) + (setf wrapper (wrapper-state-trap wrapper ,instance))) + (with-slots-slot-value-from-index + ,instance wrapper ,slot-name ,slots ,index ,variable-instance))) + (variable-instance + `(let ((,instance ,variable-instance)) + (with-slots-slot-value-from-index + ,instance ,wrapper ,slot-name ,slots ,index NIL))) + (T `(slot-value-from-index ,instance ,wrapper ,slot-name ,slots ,index)))) + +(defmacro set-with-slots-slot-value-from-index + (instance wrapper slot-name slots index variable-instance new-value) + "Sets instance's slot-value to new-value given slot-name's index." + (cond + ((consp wrapper) + `(let ((wrapper ,wrapper)) + (unless (eq (wrapper-state wrapper) 't) + (setf wrapper (wrapper-state-trap wrapper ,instance))) + (set-with-slots-slot-value-from-index + ,instance wrapper ,slot-name ,slots ,index ,variable-instance + ,new-value))) + (variable-instance + `(let ((,instance ,variable-instance)) + (set-with-slot-slots-value-from-index + ,instance ,wrapper ,slot-name ,slots ,index NIL ,new-value))) + (T + `(setf (slot-value-from-index ,instance ,wrapper ,slot-name ,slots ,index) + ,new-value)))) + +(defsetf with-slots-slot-value-from-index + set-with-slots-slot-value-from-index) + +(defmacro with-slots-slot-value-from-wrapper-and-slots + (instance slot-name wrapper slots-layout slots variable-instance) + (cond + (variable-instance + `(let ((,instance ,variable-instance)) + (with-slots-slot-value-from-wrapper-and-slots + ,instance ,slot-name ,wrapper ,slots-layout ,slots NIL))) + ((consp wrapper) + `(if *safe-to-use-slot-value-wrapper-optimizations-p* + (let ((wrapper ,wrapper)) + (unless (eq (wrapper-state wrapper) 't) + (setf wrapper (wrapper-state-trap wrapper ,instance))) + (slot-value-from-wrapper-and-slots ,instance ,slot-name + wrapper ,slots-layout ,slots NIL)) + (accessor-slot-value ,instance ,slot-name))) + (T + `(if *safe-to-use-slot-value-wrapper-optimizations-p* + (slot-value-from-wrapper-and-slots + ,instance ,slot-name ,wrapper ,slots-layout ,slots NIL) + (accessor-slot-value ,instance ,slot-name))))) + +(defmacro set-with-slots-slot-value-from-wrapper-and-slots + (instance slot-name wrapper slots-layout slots variable-instance new-value) + (cond + (variable-instance + `(let ((,instance ,variable-instance)) + (set-with-slots-slot-value-from-wrapper-and-slots + ,instance ,slot-name ,wrapper ,slots-layout ,slots NIL ,new-value))) + ((consp wrapper) + `(if *safe-to-use-set-slot-value-wrapper-optimizations-p* + (let ((wrapper ,wrapper)) + (unless (eq (wrapper-state wrapper) 't) + (setf wrapper (wrapper-state-trap wrapper ,instance))) + (setf (slot-value-from-wrapper-and-slots ,instance ,slot-name + wrapper ,slots-layout ,slots NIL) + ,new-value)) + (setf (accessor-slot-value ,instance ,slot-name) ,new-value))) + (T + `(if *safe-to-use-set-slot-value-wrapper-optimizations-p* + (setf (slot-value-from-wrapper-and-slots + ,instance ,slot-name ,wrapper ,slots-layout ,slots NIL) + ,new-value) + (setf (accessor-slot-value ,instance ,slot-name) ,new-value))))) + +(defsetf with-slots-slot-value-from-wrapper-and-slots + set-with-slots-slot-value-from-wrapper-and-slots) + +(defun tree-memq-p (item form) + (cond ((consp form) + (or (tree-memq-p item (car form)) + (tree-memq-p item (cdr form)))) + (T (eq item form)))) + +(defmacro with-optimized-slots (slot-entries instance-form &body body) + "Optimized version of With-Slots that is faster because it factors out + functions common to all slot accesses on the instance. It has two + extensions to With-Slots: (1) the second value of slot-entries are + evaluated as forms rather than considered to be hard slot-names, allowing + access of variable slot-names. (2) if a :variable-instance keyword is + the first part of the body, then the instance-form is treated as a variable + form, which is always expected to return an instance of the same class. + The value of the keyword must be an instance that is the same class as + instance-form will always return." + ;; E.g. (with-optimized-slots (foo-slot + ;; (foo-slot-accessor 'foo-slot) + ;; (variable-slot-accessor variable-slot)) + ;; instance + ;; :instance-form (car instances-of-same-class) + ;; (loop for instance in objects-of-same-class + ;; as variable-slot in variable-slots + ;; collect (list foo-slot + ;; foo-slot-accessor + ;; variable-slot-accessor))) + ;; ==> (loop for instance in objects-of-same-class + ;; as variable-slot in variable-slots + ;; collect (list (slot-value instance 'foo-slot) + ;; (slot-value instance 'foo-slot) + ;; (slot-value instance variable-slot))) + (build-with-optimized-slots-form slot-entries instance-form body)) + +(defmacro with-standard-instance-slots (slot-entries instance-form &body body) + "Optimized version of With-Slots that assumes that the instance-form + evaluates to a standard-instance. The result is undefined if it does not. + With-standard-instance-slots is faster than With-Slots because it factors + out functions common to all slot accesses on the instance. It has two + extensions to With-Slots: (1) the second value of slot-entries are + evaluated as forms rather than considered to be hard slot-names, allowing + access of variable slot-names. (2) if a :variable-instance keyword is + the first part of the body, then the instance-form is treated as a variable + form, which is always expected to return an instance of the same class. + The value of the keyword must be an instance that is the same class as + instance-form will always return." + (build-with-optimized-slots-form slot-entries instance-form body 'std-instance)) + +(defun build-with-optimized-slots-form (slot-entries instance-form body + &optional instance-type) + (let* ((variable-instance + (if (eq (car body) :variable-instance) + (prog1 + (cadr body) + (setf body (cddr body))))) + (hard-accessors + (let ((collect NIL)) + (dolist (slot-entry slot-entries (nreverse collect)) + (when (and (symbolp slot-entry) + (tree-memq-p slot-entry body)) + (push (cons slot-entry slot-entry) collect)) + (when (and (consp slot-entry) + (constantp (second slot-entry)) + (tree-memq-p (car slot-entry) body)) + (push (cons (car slot-entry) (second (second slot-entry))) + collect))))) + (variable-accessors + (let ((collect NIL)) + (dolist (slot-entry slot-entries (nreverse collect)) + (when (and (consp slot-entry) + (not (constantp (second slot-entry))) + (tree-memq-p (car slot-entry) body)) + (push slot-entry collect)))))) + (if *safe-to-use-slot-wrapper-optimizations-p* + (build-maybe-safe-w-o-s-v hard-accessors variable-accessors + instance-form body variable-instance + instance-type) + (build-with-accessor-s-v hard-accessors variable-accessors + instance-form body variable-instance)))) + +(defun build-maybe-safe-w-o-s-v (hard-accessors variable-accessors + instance-form body variable-instance + instance-type) + (let* ((instance-string + (if (symbolp instance-form) (symbol-name instance-form) "")) + (instance-form-var + (if (and variable-instance (simple-eval-access-p instance-form)) + instance-form + (gensym + (concatenate 'simple-string instance-string "-INSTANCE-FORM")))) + (prototype-form + (if variable-instance + (if (simple-eval-access-p variable-instance) + variable-instance + (gensym (concatenate 'simple-string "VARIABLE-INSTANCE" + instance-string))) + instance-form-var)) + (wrapper-var + (gensym (concatenate 'simple-string instance-string "-WRAPPER"))) + (slots-var + (unless variable-instance + (gensym (concatenate 'simple-string instance-string "-SLOTS")))) + (type-var + (when (and variable-instance (not instance-type)) + (gensym (concatenate 'simple-string instance-string "-TYPE")))) + (type-var-std 1) + (type-var-fsc 2) + #+pcl-user-instances + (type-var-user 3) + (slot-index-vars + (mapcar #'(lambda (slot-entry) + (list (car slot-entry) + (cdr slot-entry) + (gensym (concatenate + 'simple-string + (if (string= instance-string "") + "INSTANCE-FORM-" + instance-string) + (symbol-name (cdr slot-entry)) + "-INDEX")))) + (remove-duplicates hard-accessors :key #'cdr))) + (slots-layout-var + (gensym (concatenate 'simple-string "SLOTS-LAYOUT-" instance-string))) + (runtime-slots-form + (if variable-instance + (ecase instance-type + (std-instance `(std-instance-slots ,instance-form-var)) + (fsc-instance `(fsc-instance-slots ,instance-form-var)) + #+pcl-user-instances + (user-instance `(get-user-instance-slots ,instance-form-var)) + ((nil) + `(case ,type-var + (,type-var-std (std-instance-slots ,instance-form-var)) + (,type-var-fsc (fsc-instance-slots ,instance-form-var)) + #+pcl-user-instances + (,type-var-user (get-user-instance-slots ,instance-form-var))))) + slots-var)) + (runtime-wrapper-form + (if variable-instance + (ecase instance-type + (std-instance `(std-instance-wrapper ,instance-form-var)) + (fsc-instance `(fsc-instance-wrapper ,instance-form-var)) + #+pcl-user-instances + (user-instance `(get-user-instance-wrapper ,instance-form-var)) + ((nil) + `(case ,type-var + (,type-var-std (std-instance-wrapper ,instance-form-var)) + (,type-var-fsc (fsc-instance-wrapper ,instance-form-var)) + #+pcl-user-instances + (,type-var-user (get-user-instance-wrapper ,instance-form-var))))) + wrapper-var))) + (declare (type simple-string instance-string) + (type list slot-index-vars)) + `(let (,@(unless variable-instance + `((,instance-form-var ,instance-form))) + ,@(when (and variable-instance + (not (eq prototype-form variable-instance))) + `((,prototype-form ,variable-instance))) + ,wrapper-var ,slots-layout-var + ,@(if variable-instance + (if type-var `((type-var 0))) + (list slots-var)) + ,@(mapcar #'third slot-index-vars)) + ,@(when type-var `((declare (type index ,type-var)))) + (when *safe-to-use-slot-wrapper-optimizations-p* + ,@(ecase instance-type + (std-instance + `((setf ,wrapper-var (std-instance-wrapper ,prototype-form)) + ,@(unless variable-instance + `((setf ,slots-var (std-instance-slots ,prototype-form)))))) + (fsc-instance + `((setf ,wrapper-var (fsc-instance-wrapper ,prototype-form)) + ,@(unless variable-instance + `((setf ,slots-var (fsc-instance-slots ,prototype-form)))))) + #+pcl-user-instances + (user-instance + `((setf ,wrapper-var (get-user-instance-wrapper ,prototype-form)) + ,@(unless variable-instance + `((setf ,slots-var (get-user-instance-slots ,prototype-form)))))) + ((nil) + `((cond + ((std-instance-p ,prototype-form) + (setf ,wrapper-var (std-instance-wrapper ,prototype-form)) + ,(if variable-instance + `(setf ,type-var ,type-var-std) + `(setf ,slots-var (std-instance-slots ,prototype-form)))) + ((fsc-instance-p ,prototype-form) + (setf ,wrapper-var (fsc-instance-wrapper ,prototype-form)) + ,(if variable-instance + `(setf ,type-var ,type-var-fsc) + `(setf ,slots-var (fsc-instance-slots ,prototype-form)))) + #+pcl-user-instances + ((get-user-instance-p ,prototype-form) + (setf ,wrapper-var (get-user-instance-wrapper ,prototype-form)) + ,(if variable-instance + `(setf ,type-var ,type-var-user) + `(setf ,slots-var (get-user-instance-slots ,prototype-form)))))))) + ,@(if instance-type + (build-w-s-v-find-slot-indices wrapper-var slots-layout-var + prototype-form slot-index-vars) + `((when ,wrapper-var + ,@(build-w-s-v-find-slot-indices wrapper-var slots-layout-var + prototype-form slot-index-vars))))) + (symbol-macrolet + (,@(mapcar + #'(lambda (slot-cons) + `(,(car slot-cons) + (with-slots-slot-value-from-index + ,instance-form-var + ,runtime-wrapper-form + ',(cdr slot-cons) + ,runtime-slots-form + ,(third (assoc (car slot-cons) slot-index-vars + :test #'eq)) + ,(when (and variable-instance + (not (eq variable-instance + instance-form-var))) + variable-instance)))) + hard-accessors) + ,@(mapcar + #'(lambda (variable-cons) + `(,(car variable-cons) + (with-slots-slot-value-from-wrapper-and-slots + ,instance-form-var + ,(second variable-cons) + ,runtime-wrapper-form + ,slots-layout-var + ,runtime-slots-form + ,(when (and variable-instance + (not (eq variable-instance + instance-form-var))) + variable-instance)))) + variable-accessors)) + ,@body)))) + +(defun build-w-s-v-find-slot-indices (wrapper-var slots-layout-var + prototype-form + slot-index-vars) + (declare (type list slot-index-vars)) + `((unless (eq (wrapper-state ,wrapper-var) 't) + (setf ,wrapper-var + (wrapper-state-trap ,wrapper-var ,prototype-form))) + (setf ,slots-layout-var (wrapper-instance-slots-layout ,wrapper-var)) + ,@(if (<= (length slot-index-vars) 2) + (mapcar + #'(lambda (slot-cons) + `(setf ,(third slot-cons) + (instance-slot-index-from-slots-layout + ,slots-layout-var ',(second slot-cons)))) + slot-index-vars) + ;; More than two slots, so more efficient to search slots-layout-var + ;; only once, rather than once for each with instance-slot-index. + (labels + ((build-comps (slot-vars index) + (if slot-vars + `(if (eq slot-name ',(second (car slot-vars))) + (progn + (setf ,(third (car slot-vars)) ,index) + (if (= matches ,(1- (length slot-index-vars))) + (go end-loop) + (setf matches (the fixnum (1+ matches))))) + ,(build-comps (cdr slot-vars) index))))) + `((block nil + (let ((slots-left ,slots-layout-var) + (slot-name NIL) + (index 0) + (matches 0)) + (declare (type fixnum index matches)) + (when slots-left + (tagbody + begin-instance-slots-loop + (setf slot-name (car slots-left)) + ,(build-comps slot-index-vars 'index) + (setf index (the fixnum (1+ index))) + (if (null (setf slots-left (cdr slots-left))) + (go end-loop)) + (go begin-instance-slots-loop) + end-loop))))))))) + +(defun build-with-accessor-s-v (hard-accessors variable-accessors + instance-form body variable-instance) + ;; Build the body for with-optimized-slot-value when it is unsafe + ;; and accessor-slot-value must be used. + (let ((instance-form-var + (if variable-instance instance-form (gensym "INSTANCE-FORM")))) + `(let (,@(unless variable-instance + `((,instance-form-var ,instance-form)))) + (symbol-macrolet + (,@(mapcar + #'(lambda (slot-cons) + `(,(car slot-cons) + (accessor-slot-value ,instance-form-var + ',(cdr slot-cons)))) + hard-accessors) + ,@(mapcar + #'(lambda (variable-cons) + `(,(car variable-cons) + (accessor-slot-value ,instance-form-var + ,(second variable-cons)))) + variable-accessors)) + ,@body)))) + + +#-(or KCL IBCL) +(export *extensions-exports* *the-pcl-package*) + +#+(or KCL IBCL) +(mapc 'export (list *extensions-exports*) (list *the-pcl-package*)) + diff --git a/pcl/extensions/inline.lisp b/pcl/extensions/inline.lisp new file mode 100644 index 0000000..b884310 --- /dev/null +++ b/pcl/extensions/inline.lisp @@ -0,0 +1,263 @@ +;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- + +(in-package :pcl) + +;; This file contains some of the things that will have to change to support +;; inlining of methods. + +(defun make-method-lambda-internal (method-lambda &optional env) + (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda)) + (error "The method-lambda argument to make-method-lambda, ~S,~ + is not a lambda form" method-lambda)) + (multiple-value-bind (documentation declarations real-body) + (extract-declarations (cddr method-lambda) env) + (let* ((name-decl (get-declaration 'method-name declarations)) + (sll-decl (get-declaration 'method-lambda-list declarations)) + (method-name (when (consp name-decl) (car name-decl))) + (generic-function-name (when method-name (car method-name))) + (specialized-lambda-list (or sll-decl (cadr method-lambda)))) + (multiple-value-bind (parameters lambda-list specializers) + (parse-specialized-lambda-list specialized-lambda-list) + (let* ((required-parameters + (mapcar #'(lambda (r s) (declare (ignore s)) r) + parameters + specializers)) + (slots (mapcar #'list required-parameters)) + (calls (list nil)) + (parameters-to-reference + (make-parameter-references specialized-lambda-list + required-parameters + declarations + method-name + specializers)) + (class-declarations + `(declare + ,@(remove nil + (mapcar #'(lambda (a s) (and (symbolp s) + (neq s 't) + `(class ,a ,s))) + parameters + specializers)))) + (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 + ;; cadr 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 + ,class-declarations + ,@declarations + (progn ,@parameters-to-reference) + (block ,(if (listp generic-function-name) + (cadr generic-function-name) + generic-function-name) + ,@real-body))) + (constant-value-p (and (null (cdr real-body)) + (constantp (car real-body)))) + (constant-value (and constant-value-p + (eval (car real-body)))) + (plist (if (and constant-value-p + (or (typep constant-value '(or number character)) + (and (symbolp constant-value) + (symbol-package constant-value)))) + (list :constant-value constant-value) + ())) + (applyp (dolist (p lambda-list nil) + (cond ((memq p '(&optional &rest &key)) + (return t)) + ((eq p '&aux) + (return nil)))))) + (multiple-value-bind (walked-lambda call-next-method-p closurep + next-method-p-p) + (walk-method-lambda method-lambda required-parameters env + slots calls) + (multiple-value-bind (ignore walked-declarations walked-lambda-body) + (extract-declarations (cddr walked-lambda)) + (declare (ignore ignore)) + (when (or next-method-p-p call-next-method-p) + (setq plist (list* :needs-next-methods-p 't plist))) + (when (some #'cdr slots) + (multiple-value-bind (slot-name-lists call-list) + (slot-name-lists-from-slots slots calls) + (let ((pv-table-symbol (make-symbol "pv-table"))) + (setq plist + `(,@(when slot-name-lists + `(:slot-name-lists ,slot-name-lists)) + ,@(when call-list + `(:call-list ,call-list)) + :pv-table-symbol ,pv-table-symbol + ,@plist)) + (setq walked-lambda-body + `((pv-binding (,required-parameters ,slot-name-lists + ,pv-table-symbol) + ,@walked-lambda-body)))))) + (when (and (memq '&key lambda-list) + (not (memq '&allow-other-keys lambda-list))) + (let ((aux (memq '&aux lambda-list))) + (setq lambda-list (nconc (ldiff lambda-list aux) + (list '&allow-other-keys) + aux)))) + (values `(lambda (.method-args. .next-methods.) + (simple-lexical-method-functions + (,lambda-list .method-args. .next-methods. + :call-next-method-p ,call-next-method-p + :next-method-p-p ,next-method-p-p + :closurep ,closurep + :applyp ,applyp) + ,@walked-declarations + ,@walked-lambda-body)) + `(,@(when plist + `(:plist ,plist)) + ,@(when documentation + `(:documentation ,documentation))))))))))) + +(define-inline-function slot-value (instance slot-name) (form closure-p env) + :predicate (and (not closure-p) (constantp slot-name)) + :inline-arguments (required-parameters slots) + :inline (optimize-slot-value + slots + (can-optimize-access form required-parameters env) + form)) + +;collect information about: +; uses of the required-parameters +; uses of call-next-method and next-method-p: +; called-p +; apply-p +; arglist info +;optimize calls to slot-value, set-slot-value, slot-boundp +;optimize calls to find-class +;optimize generic-function calls +(defun make-walk-function (required-parameters info slots calls) + #'(lambda (form context env) + (cond ((not (eq context ':eval)) form) + ((not (listp form)) form) + ((eq (car form) 'call-next-method) + (setq call-next-method-p 't) + form) + ((eq (car form) 'next-method-p) + (setq next-method-p-p 't) + form) + ((and (eq (car form) 'function) + (cond ((eq (cadr form) 'call-next-method) + (setq call-next-method-p 't) + (setq closurep t) + form) + ((eq (cadr form) 'next-method-p) + (setq next-method-p-p 't) + (setq closurep t) + form) + (t nil)))) + ((and (or (eq (car form) 'slot-value) + (eq (car form) 'set-slot-value) + (eq (car form) 'slot-boundp)) + (constantp (caddr form))) + (let ((parameter + (can-optimize-access form + required-parameters env))) + (ecase (car form) + (slot-value + (optimize-slot-value slots parameter form)) + (set-slot-value + (optimize-set-slot-value slots parameter form)) + (slot-boundp + (optimize-slot-boundp slots parameter form))))) + ((and (or (symbolp (car form)) + (and (consp (car form)) + (eq (caar form) 'setf))) + (gboundp (car form)) + (if (eq *boot-state* 'complete) + (standard-generic-function-p (gdefinition (car form))) + (funcallable-instance-p (gdefinition (car form))))) + (optimize-generic-function-call + form required-parameters env slots calls)) + (t form)))) + +(defun walk-method-lambda (method-lambda required-parameters env slots calls) + (let* ((call-next-method-p nil) ;flag indicating that call-next-method + ;should be in the method definition + (closurep nil) ;flag indicating that #'call-next-method + ;was seen in the body of a method + (next-method-p-p nil) ;flag indicating that next-method-p + ;should be in the method definition + (walk-functions `((call-next-method-p + ,#'(lambda (form closure-p env) + (setq call-next-method-p 't) + (when closure-p + (setq closurep t)) + form)) + (next-method-p + ,#'(lambda (form closure-p env) + (setq next-method-p-p 't) + (when closure-p + (setq closurep t)) + form)) + ((slot-value set-slot-value slot-boundp) + ,#'(lambda (form closure-p env) + (if (and (not closure-p) + (constantp (caddr form))) + + (let ((walked-lambda (walk-form method-lambda env + (make-walk-function + `((call-next-method-p + ,#'(lambda (form closure-p env) + (setq call-next-method-p 't) + (when closure-p + (setq closurep t)) + form)) + (next-method-p + ,#'(lambda (form closure-p env) + (setq next-method-p-p 't) + (when closure-p + (setq closurep t)) + form)) + ((slot-value set-slot-value slot-boundp) + ,#'(lambda (form closure-p env) + ( + (values walked-lambda + call-next-method-p closurep next-method-p-p))))) + +(defun initialize-method-function (initargs &optional return-function-p method) + (let* ((mf (getf initargs ':function)) + (method-spec (getf initargs ':method-spec)) + (plist (getf initargs ':plist)) + (pv-table-symbol (getf plist ':pv-table-symbol)) + (pv-table nil) + (mff (getf initargs ':fast-function))) + (flet ((set-mf-property (p v) + (when mf + (setf (method-function-get mf p) v)) + (when mff + (setf (method-function-get mff p) v)))) + (when method-spec + (when mf + (setq mf (set-function-name mf method-spec))) + (when mff + (let ((name `(,(or (get (car method-spec) 'fast-sym) + (setf (get (car method-spec) 'fast-sym) + (intern (format nil "FAST-~A" + (car method-spec)) + *the-pcl-package*))) + ,@(cdr method-spec)))) + (set-function-name mff name) + (unless mf + (set-mf-property :name name))))) + (when plist + (let ((snl (getf plist :slot-name-lists)) + (cl (getf plist :call-list))) + (when (or snl cl) + (setq pv-table (intern-pv-table :slot-name-lists snl + :call-list cl)) + (when pv-table (set pv-table-symbol pv-table)) + (set-mf-property :pv-table pv-table))) + (loop (when (null plist) (return nil)) + (set-mf-property (pop plist) (pop plist))) + (when method + (set-mf-property :method method)) + (when return-function-p + (or mf (method-function-from-fast-function mff))))))) + + + diff --git a/pcl/extensions/user-instances.lisp b/pcl/extensions/user-instances.lisp new file mode 100644 index 0000000..1600efc --- /dev/null +++ b/pcl/extensions/user-instances.lisp @@ -0,0 +1,684 @@ +;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp; -*- + +;;; +;;; ************************************************************************* +;;; +;;; File: user-instances.lisp. +;;; +;;; by Trent E. Lange, Effective Date 06-02-92 +;;; +;;; +;;; This file contains a metaclass (User-Vector-Class) whose instances +;;; are stored as simple-vectors, saving space over PCL's standard instance +;;; representations of PCL at the cost of some class redefinition flexibiliity. +;;; +;;; Permission is granted to any individual or institution to use, copy, +;;; modify and distribute this document. +;;; +;;; Suggestions, bugs, criticism and questions to lange@cs.ucla.edu +;;; ************************************************************************* +;;; + +(in-package 'pcl) + +;;; This file builds on the PCL-USER-INSTANCES feature of July 92 PCL +;;; to define the USER-VECTOR-CLASS metaclass whose instances are simple +;;; vectors. The first element of the instance vector is the instance's +;;; class wrapper (providing internal PCL information about the instance's +;;; class). The remaining elements of the instance vector are the instance's +;;; slots themselves. +;;; +;;; The space overhead of user-vector-instances is only two vector cells +;;; (one for the vector, one for the wrapper). This is contrast to standard +;;; PCL instances, which have a total overhead of four cells. (Standard +;;; instances in PCL are represented as instances of structure STD-INSTANCE +;;; having two slots, one for the wrapper and one holding a simple-vector +;;; which is the instance's slots). This two-cell space savings per instance +;;; comes at the cost of losing some class redefinition flexibility, since +;;; simple-vectors cannot have their sizes changed dynamically. +;;; All current instances of user-instance-vectors therefore become +;;; permanently obsolete if the classes' instance slots change. +;;; +;;; This code requires July 92 PCL or later compiled with the +;;; PCL-USER-INSTANCES feature turned on (see PCL's low.lisp file). +;;; + +#-pcl-user-instances +(eval-when (compile load eval) +(error "Cannot use user-instances, since PCL was compiled without + PCL-USER-INSTANCES on the *features* list (see pcl file low.lisp.)") +) + +(eval-when (compile load eval) +(defclass user-vector-class-mixin () () + (:documentation + "Use this mixin for metaclasses whose instances are USER-INSTANCES + instantiated as simple-vectors. This saves space over the standard + instances used by standard-class, at the cost of losing the ability to + redefine the slots in a class and still have old instances updated correctly.")) + +(defclass user-vector-class (user-vector-class-mixin standard-class) () + (:documentation + "A metaclass whose instances are USER-INSTANCES instantiated as simple-vectors. + This saves space over the standard instances used by standard-class, at the + cost of losing the ability to redefine the slots in a class and still have old + instances updated correctly.")) + +(defmethod validate-superclass ((class user-vector-class-mixin) + (new-super T)) + (or (typep new-super 'user-vector-class-mixin) + (eq new-super (find-class 'standard-object)))) + +(defclass user-vector-object (standard-object) () + (:metaclass user-vector-class)) +) + +;;; +;;; +;;; Instance allocation stuff. +;;; + +(defmacro user-vector-instance-p (object) + (once-only (object) + `(the boolean + (and (simple-vector-p ,object) + (plusp (length (the simple-vector ,object))) + (wrapper-p (%svref ,object 0)))))) + +(defmacro user-vector-instance-wrapper (object) + `(%svref ,object 0)) + +(defsetf user-vector-instance-wrapper (object) (new-value) + `(setf (%svref ,object 0) ,new-value)) + +(defmacro user-vector-instance-slots (instance) + ;; The slots vector of user-vector instances is the instance itself. + instance) + +(defmacro set-user-vector-instance-slots (instance new-value) + `(progn + (warn "Attempt to set user-vector-instance-slots of ~S to ~S" + ,instance ,new-value) + ,new-value)) + +(defun user-instance-p (x) + "Is X a user instance, specifically a user-vector-instance?" + (user-vector-instance-p x)) + +(defun user-instance-slots (x) + "Return the slots of this user-vector-instance." + (user-vector-instance-slots x)) + +(defun user-instance-wrapper (x) + "Return the wrapper of this user-vector-instance." + (user-vector-instance-wrapper x)) + +(defun set-user-instance-wrapper (x new) + (setf (user-vector-instance-wrapper x) new)) + +(defmacro get-user-instance-p (x) + `(user-vector-instance-p ,x)) + +(defmacro get-user-instance-wrapper (x) + `(user-vector-instance-wrapper ,x)) + +(defmacro get-user-instance-slots (x) + `(user-vector-instance-slots ,x)) + +(eval-when (eval #+cmu load) + (force-compile 'user-instance-p) + (force-compile 'user-instance-slots) + (force-compile 'user-instance-wrapper) + (force-compile 'set-user-instance-wrapper)) + + +;;; +;;; Methods needed for user-vector-class-mixin. +;;; + +(defconstant *not-a-slot* (gensym "NOT-A-SLOT")) + +(defmethod allocate-instance ((class user-vector-class-mixin) &rest initargs) + (declare (ignore initargs)) + (unless (class-finalized-p class) (finalize-inheritance class)) + (let* ((class-wrapper (class-wrapper class)) + (copy-instance (wrapper-allocate-static-slot-storage-copy + class-wrapper)) + (instance (copy-simple-vector copy-instance))) + (declare (type simple-vector copy-instance instance)) + (setf (user-vector-instance-wrapper instance) class-wrapper) + instance)) + +(defmethod make-instances-obsolete ((class user-vector-class-mixin)) + "The slots of user-vector-instances are stored in the instance vector + themselves (a simple-vector), so old instances cannot be updated properly." + (setf (slot-value class 'prototype) NIL) + (warn "Obsoleting user-vector class ~A, all current instances will be invalid..." + class)) + +(defmethod compute-layout :around ((class user-vector-class-mixin) + cpl instance-eslotds) + ;; First element of user-vector-instance is actually its wrapper. + (declare (ignore cpl instance-eslotds)) + (cons *not-a-slot* (call-next-method))) + +(defmethod compute-instance-layout :around ((class user-vector-class-mixin) + instance-eslotds) + ;; First element of user-vector-instance is actually its wrapper. + (declare (ignore instance-eslotds)) + (cons *not-a-slot* (call-next-method))) + +(defmethod wrapper-fetcher ((class user-vector-class-mixin)) + 'user-vector-instance-wrapper) + +(defmethod slots-fetcher ((class user-vector-class-mixin)) + 'user-vector-instance-slots) + +(defmethod raw-instance-allocator ((class user-vector-class-mixin)) + 'allocate-user-vector-instance) + + +;;; +;;; The following functions and methods are not strictly necessary for +;;; user-vector-instances, but do speed things up a bit. +;;; + +;;; Inform PCL that it is still safe to use its standard slot-value +;;; optimizations with user-vector-class-mixin's slot-value-using-class +;;; methods: + +(pushnew + '(user-vector-class-mixin standard-object standard-effective-slot-definition) + *safe-slot-value-using-class-specializers*) + +(pushnew + '(T user-vector-class-mixin standard-object standard-effective-slot-definition) + *safe-set-slot-value-using-class-specializers*) + +(pushnew + '(user-vector-class-mixin standard-object standard-effective-slot-definition) + *safe-slot-boundp-using-class-specializers*) + +(defmethod slot-value-using-class + ((class user-vector-class-mixin) + (object standard-object) + (slotd standard-effective-slot-definition)) + (let* ((location (slot-definition-location slotd)) + (value + (typecase location + (fixnum + (%svref (user-vector-instance-slots object) location)) + (cons + (cdr location)) + (t + (error + "The slot ~s has neither :instance nor :class allocation, ~@ + so it can't be read by the default ~s method." + slotd 'slot-value-using-class))))) + (if (eq value *slot-unbound*) + (slot-unbound class object (slot-definition-name slotd)) + value))) + +(defmethod (setf slot-value-using-class) + (new-value (class user-vector-class-mixin) + (object standard-object) + (slotd standard-effective-slot-definition)) + (let ((location (slot-definition-location slotd))) + (typecase location + (fixnum + (setf (%svref (user-vector-instance-slots object) location) new-value)) + (cons + (setf (cdr location) new-value)) + (t + (error "The slot ~s has neither :instance nor :class allocation, ~@ + so it can't be written by the default ~s method." + slotd '(setf slot-value-using-class)))))) + +(defmethod slot-boundp-using-class + ((class user-vector-class-mixin) + (object standard-object) + (slotd standard-effective-slot-definition)) + (let* ((location (slot-definition-location slotd)) + (value + (typecase location + (fixnum + (%svref (user-vector-instance-slots object) location)) + (cons + (cdr location)) + (t + (error + "The slot ~s has neither :instance nor :class allocation, ~@ + so it can't be read by the default ~s method." + slotd 'slot-boundp-using-class))))) + (not (eq value *slot-unbound*)))) + + + +(defmethod make-optimized-reader-method-function + ((class user-vector-class-mixin) + generic-function + reader-method-prototype + slot-name) + (declare (ignore generic-function reader-method-prototype)) + (make-user-vector-instance-reader-method-function slot-name)) + +(defmethod make-optimized-writer-method-function + ((class user-vector-class-mixin) + generic-function + reader-method-prototype + slot-name) + (declare (ignore generic-function reader-method-prototype)) + (make-user-vector-instance-writer-method-function slot-name)) + +(defmethod make-optimized-method-function + ((class user-vector-class-mixin) + generic-function + boundp-method-prototype + slot-name) + (declare (ignore generic-function boundp-method-prototype)) + (make-user-vector-instance-boundp-method-function slot-name)) + +(defun make-user-vector-instance-reader-method-function (slot-name) + (declare #.*optimize-speed*) + #'(lambda (instance) + (user-instance-slot-value instance slot-name))) + +(defun make-user-vector-instance-writer-method-function (slot-name) + (declare #.*optimize-speed*) + #'(lambda (nv instance) + (setf (user-instance-slot-value instance slot-name) nv))) + +(defun make-user-vector-instance-boundp-method-function (slot-name) + (declare #.*optimize-speed*) + #'(lambda (instance) + (user-instance-slot-boundp instance slot-name))) + + +(defun make-optimized-user-reader-method-function (slot-name index) + (declare #.*optimize-speed*) + (progn slot-name) + #'(lambda (instance) + (let ((value (%svref (user-vector-instance-slots instance) index))) + (if (eq value *slot-unbound*) + (slot-unbound (class-of instance) instance slot-name) + value)))) + +(defun make-optimized-user-writer-method-function (index) + (declare #.*optimize-speed*) + #'(lambda (nv instance) + (setf (%svref (user-vector-instance-slots instance) index) nv))) + +(defun make-optimized-user-boundp-method-function (index) + (declare #.*optimize-speed*) + #'(lambda (instance) + (not (eq (%svref (user-vector-instance-slots instance) index) + *slot-unbound*)))) + + + +(defmacro with-user-instance-slots (slot-entries instance-form &body body) + "Optimized version of With-Slots that assumes that the instance-form + evaluates to a user-vector-instance. The result is undefined if it does not. + With-user-vector-instance-slots is faster than With-Slots because it factors + out functions common to all slot accesses on the instance. It has two + extensions to With-Slots: (1) the second value of slot-entries are + evaluated as forms rather than considered to be hard slot-names, allowing + access of variable slot-names. (2) if a :variable-instance keyword is + the first part of the body, then the instance-form is treated as a variable + form, which is always expected to return an instance of the same class. + The value of the keyword must be an instance that is the same class as + instance-form will always return." + (build-with-optimized-slots-form slot-entries instance-form body 'user-instance)) + + + +;;; +;;; Lisp and CLOS print compatability functions: +;;; +;;; This gets really ugly because most lisps don't use PRINT-OBJECT +;;; for the printed representation of their objects like they're supposed +;;; to. (And if the lisp did, it wouldn't be using PCL.). And since +;;; user-vector-instances are implemented as simple-vectors, the only +;;; way to get their printed representations to look right is to make +;;; PRINT-OBJECT object to work. +;;; We therefore have to patch the standard lisp printing functions. +;;; If all goes well, then everything is honky-dory. If it doesn't, then +;;; debugging can get pretty messy since we were screwing with the standard +;;; printing functions. Things should work, but if they don't, then calling +;;; RESTORE-LISP-PRINTERS will get things back to normal. + +(defvar *old-write* NIL) +(defvar *old-princ* NIL) +(defvar *old-prin1* NIL) +(defvar *old-print* NIL) + +;; Structure dummy-print-instance is a structure whose sole purpose +;; in life is to act as a placeholder to allow the print-object of +;; user-vector-class objects to be printed. + +(defstruct (dummy-print-instance + (:print-function print-dummy-print-instance)) + (print-object-string nil)) + +(declaim (type list *dummy-print-instance-garbage*)) +(defvar *dummy-print-instance-garbage* NIL) +(defconstant *dummy-print-instance-garbage-limit* 100) + +(defmacro pure-array-p (x &optional (test-user-vector-instance-p T)) + "Returns whether item is a 'pure' array -- i.e. not a string, and + not something holding a CLOS instance." + (once-only (x) + `(the boolean + (locally (declare (inline arrayp stringp typep)) + (and (arrayp ,x) + (not (stringp ,x)) + #-(or cmu (and lucid pcl)) + (not (typep ,x 'structure)) + ,@(when test-user-vector-instance-p + `((not (user-vector-instance-p ,x)))) + #-(or cmu (and lucid pcl)) + (not (typep ,x 'standard-object))))))) + +(defun copy-any-array (old-array &rest keys-passed &key key dimensions) + ;; Returns a copy of old-array. If :key is provided, then the + ;; elements of the new-array are the result of key applied to + ;; old-array's elements. If :dimensions is provided, and it is + ;; different than old-array's dimensions, then the new-array is created + ;; with those dimensions, and everything that can be copied from + ;; old-array is copied into it. It is an error if the rank of + ;; the array specified by dimensionss is different than that of the + ;; old-array. + (declare (type array old-array) + (type (or function null) key) + (type list dimensions keys-passed)) + (cond + ((simple-vector-p old-array) + (apply #'copy-array-contents + old-array + (make-array (the index + (if dimensions + (car dimensions) + (length (the simple-vector old-array))))) + keys-passed)) + ((vectorp old-array) + (apply #'copy-array-contents + old-array + (make-array (the index + (if dimensions + (car dimensions) + (length (the vector old-array)))) + :element-type (array-element-type old-array) + :adjustable (adjustable-array-p old-array)) + keys-passed)) + ((arrayp old-array) + (let* ((old-dimensions (array-dimensions old-array)) + (new-dimensions (or dimensions old-dimensions)) + (element-type (array-element-type old-array)) + (new-array + (make-array new-dimensions + :element-type element-type + :adjustable (adjustable-array-p old-array)))) + (declare (type list old-dimensions new-dimensions) + (type array new-array)) + (if (or (null dimensions) (equal new-dimensions old-dimensions)) + (let* ((displaced-old-array + (make-array (array-total-size old-array) + :element-type element-type + :displaced-to old-array)) + (displaced-new-array + (make-array (array-total-size new-array) + :element-type element-type + :displaced-to new-array))) + (declare (type array displaced-old-array displaced-new-array)) + (copy-array-contents displaced-old-array + displaced-new-array + :key key)) + (let ((first-dimension + (min (the index (car new-dimensions)) + (the index (car old-dimensions))))) + (declare (type index first-dimension)) + (walk-dimensions + (mapcar #'min (cdr new-dimensions) (cdr old-dimensions)) + #'(lambda (post-indices) + (copy-array-contents old-array new-array + :key key + :length first-dimension + :post-indices post-indices))))) + new-array)))) + +(defun copy-array-contents + (old-array new-array &key key length post-indices &allow-other-keys) + ;; Copies the contents of old-array into new-array, using key if + ;; supplied. Only the first :length items are copied (defaulting + ;; to the length of the old-array). If :post-indices are passed, then + ;; they are used as "post" indices to an aref. + (macrolet + ((do-copy (aref old new key key-type len post-indices) + (let ((atype (if (eq aref #'svref) 'simple-vector 'array))) + `(dotimes (i (the index ,len)) + (setf ,(if post-indices + `(apply #'aref (the ,atype ,new) i ,post-indices) + `(,aref (the ,atype ,new) i)) + ,(if key-type + `(funcall + (the ,key-type ,key) + ,(if post-indices + `(apply #'aref (the ,atype ,old) + i ,post-indices) + `(,aref (the ,atype ,old) i))) + (if post-indices + `(apply #'aref (the ,atype ,old) i ,post-indices) + `(,aref (the ,atype ,old) i))))))) + (expand-on-key (aref key old new len post-ind) + `(cond + ((null ,key) + (do-copy ,aref ,old ,new ,key NIL ,len ,post-ind)) + ((compiled-function-p ,key) + (do-copy ,aref ,old ,new ,key compiled-function ,len ,post-ind)) + (T + (do-copy ,aref ,old ,new ,key function ,len ,post-ind))))) + (if (simple-vector-p old-array) + (progn + (when post-indices + (error "Can't pass post-indices given to COPY-ARRAY-CONTENTS + from simple-vector")) + + (unless length + (setf length (min (length (the simple-vector old-array)) + (length (the simple-vector new-array))))) + (expand-on-key svref key old-array new-array length NIL)) + (progn + (unless length + (setf length (min (the index (car (array-dimensions old-array))) + (the index (car (array-dimensions new-array)))))) + (if post-indices + (expand-on-key #'aref key old-array new-array length post-indices) + (expand-on-key aref key old-array new-array length NIL))))) + new-array) + +(declaim (ftype (function (list function) T) walk-dimensions)) +(defun walk-dimensions (dimensions fn) + (declare (type list dimensions) + (type function fn)) + ;; Given a list of dimensions (e.g. '(3 2 8)), this function walks + ;; through every possible combination from 0 to 1- each of those + ;; dimensions, and calling fn on each of them. + (let ((compiled-p (compiled-function-p fn))) + (labels + ((doit (dims apply-dims) + (declare (type list dims apply-dims)) + (if (cdr dims) + (let ((last-dim NIL) + (dims-left NIL)) + (loop (when (null (cdr dims)) + (setf last-dim (car dims)) + (return)) + (if dims-left + (nconc dims-left (list (car dims))) + (setf dims-left (list (car dims)))) + (setf dims (cdr dims))) + (dotimes (i (the index last-dim)) + (doit dims-left (cons i apply-dims)))) + (if compiled-p + (dotimes (i (the index (car dims))) + (funcall (the compiled-function fn) (cons i apply-dims))) + (dotimes (i (the index (car dims))) + (funcall fn (cons i apply-dims))))))) + (doit dimensions NIL)))) + +(defmacro funcall-printer (applyer print-function object keys) + `(progn + (if (or (arrayp ,object) (consp ,object)) + (multiple-value-bind (converted-item garbage) + (convert-user-vector-instances-to-dummy-print-instances ,object) + (,applyer (the compiled-function ,print-function) + converted-item ,keys) + (deallocate-dummy-print-instances garbage)) + (,applyer (the compiled-function ,print-function) + ,object ,keys)) + ,object)) + +(defun print-dummy-print-instance (instance stream depth) + (declare (ignore depth)) + (let ((*print-pretty* NIL)) + (funcall (the compiled-function *old-princ*) + (dummy-print-instance-print-object-string instance) + stream))) + +(defun allocate-dummy-print-instance (print-object-string) + (if *dummy-print-instance-garbage* + (let ((instance (pop *dummy-print-instance-garbage*))) + (setf (dummy-print-instance-print-object-string instance) + print-object-string) + instance) + (make-dummy-print-instance :print-object-string print-object-string))) + +(defun dummy-print-instance-of (user-vector-instance) + (allocate-dummy-print-instance + (with-output-to-string (str) + (print-object user-vector-instance str)))) + +(defun deallocate-dummy-print-instances (dummies) + (let ((count (length *dummy-print-instance-garbage*))) + (declare (type index count)) + (dolist (dummy dummies) + (when (> count *dummy-print-instance-garbage-limit*) + (return)) + (push dummy *dummy-print-instance-garbage*) + (setf count (the index (1+ count)))))) + +(defun convert-user-vector-instances-to-dummy-print-instances (item) + (let ((print-length + (or *print-length* 1000)) + (print-level + (or *print-level* 1000)) + (dummy-print-instances-used NIL)) + (declare (fixnum print-length print-level)) + (labels + ((doit (item level length) + (declare (fixnum level length)) + (labels + ((user-vector-instance-visible-within-p (item level length) + (declare (fixnum level length)) + (cond + ((>= length print-length) NIL) + ((> level print-level) NIL) + ((= level print-level) (user-vector-instance-p item)) + (T (cond + ((user-vector-instance-p item) T) + ((consp item) + (or (user-vector-instance-visible-within-p + (car item) (the fixnum (1+ level)) 0) + (user-vector-instance-visible-within-p + (cdr item) level (the fixnum (1+ length))))) + ((and *print-array* (pure-array-p item)) + (let ((next-level (the fixnum (1+ level)))) + (declare (fixnum next-level)) + (dotimes (i (1- (length (the array item))) NIL) + (unless (< i print-length) + (return NIL)) + (if (user-vector-instance-visible-within-p + (aref item i) next-level 0) + (return T)))))))))) + ;; doit body + (cond + ((user-vector-instance-p item) + (let ((dummy (dummy-print-instance-of item))) + (push dummy dummy-print-instances-used) + dummy)) + ((consp item) + (if (user-vector-instance-visible-within-p item level length) + (cons (doit (car item) (the fixnum (1+ level)) length) + (doit (cdr item) level (the fixnum (1+ length)))) + item)) + ((and *print-array* (pure-array-p item NIL)) + (if (user-vector-instance-visible-within-p item level length) + (copy-any-array + item + :key + #'(lambda (item) + (if (user-vector-instance-p item) + (let ((dummy (dummy-print-instance-of item))) + (push dummy dummy-print-instances-used) + dummy) + item)) + :dimensions + (mapcar #'1+ (array-dimensions item))) + item)) + (T item))))) + + ;; convert-user-vector-instances-to-dummy-print-instances body + + (let ((converted (doit item 0 0))) + (values converted dummy-print-instances-used))))) + +(force-compile 'convert-user-vector-instances-to-dummy-print-instances) + +(unless *old-write* (setf *old-write* (symbol-function 'write))) +(defun new-write (object &rest keys-passed) + (declare (list keys-passed)) + (funcall-printer apply *old-write* object keys-passed)) +(force-compile 'write) +(setf (symbol-function 'write) (symbol-function 'new-write)) + +(unless *old-princ* (setf *old-princ* (symbol-function 'princ))) +(defun princ (object &optional stream) + (funcall-printer funcall *old-princ* object stream)) +(force-compile 'princ) + +(unless *old-prin1* (setf *old-prin1* (symbol-function 'prin1))) +(defun prin1 (object &optional stream) + (funcall-printer funcall *old-prin1* object stream)) +(force-compile 'prin1) + +(unless *old-print* (setf *old-print* (symbol-function 'print))) +(defun print (object &optional stream) + (funcall-printer funcall *old-print* object stream)) +(force-compile 'print) + +(defun new-write-to-string (object &rest keys-passed) + (declare (list keys-passed)) + (with-output-to-string (string-stream) + (apply #'write object :stream string-stream keys-passed))) +(force-compile 'write-to-string) +(setf (symbol-function 'write-to-string) + (symbol-function 'new-write-to-string)) + +(defun princ-to-string (object) + (with-output-to-string (string-stream) + (funcall-printer funcall *old-princ* object string-stream) + string-stream)) +(force-compile 'princ-to-string) + +(defun prin1-to-string (object) + (with-output-to-string (string-stream) + (funcall-printer funcall *old-prin1* object string-stream) + string-stream)) +(force-compile 'prin1-to-string) + +(defun restore-lisp-printers () + (setf (symbol-function 'write) *old-write*) + (setf (symbol-function 'princ) *old-princ*) + (setf (symbol-function 'prin1) *old-prin1*) + (setf (symbol-function 'print) *old-print*)) + diff --git a/pcl/gcl_pcl_boot.lisp b/pcl/gcl_pcl_boot.lisp new file mode 100644 index 0000000..d57bd4d --- /dev/null +++ b/pcl/gcl_pcl_boot.lisp @@ -0,0 +1,2195 @@ +;;;-*-Mode: LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; + +(in-package :pcl) + +#| + +The CommonLoops evaluator is meta-circular. + +Most of the code in PCL is methods on generic functions, including most of +the code that actually implements generic functions and method lookup. + +So, we have a classic bootstrapping problem. The solution to this is to +first get a cheap implementation of generic functions running, these are +called early generic functions. These early generic functions and the +corresponding early methods and early method lookup are used to get enough +of the system running that it is possible to create real generic functions +and methods and implement real method lookup. At that point (done in the +file FIXUP) the function fix-early-generic-functions is called to convert +all the early generic functions to real generic functions. + +The cheap generic functions are built using the same funcallable-instance +objects real generic-functions are made out of. This means that as PCL +is being bootstrapped, the cheap generic function objects which are being +created are the same objects which will later be real generic functions. +This is good because: + - we don't cons garbage structure + - we can keep pointers to the cheap generic function objects + during booting because those pointers will still point to + the right object after the generic functions are all fixed + up + + + +This file defines the defmethod macro and the mechanism used to expand it. +This includes the mechanism for processing the body of a method. defmethod +basically expands into a call to load-defmethod, which basically calls +add-method to add the method to the generic-function. These expansions can +be loaded either during bootstrapping or when PCL is fully up and running. + +An important effect of this structure is it means we can compile files with +defmethod forms in them in a completely running PCL, but then load those files +back in during bootstrapping. This makes development easier. It also means +there is only one set of code for processing defmethod. Bootstrapping works +by being sure to have load-method be careful to call only primitives which +work during bootstrapping. + +|# + +(proclaim '(notinline make-a-method + add-named-method + ensure-generic-function-using-class + + add-method + remove-method + )) + +(defvar *early-functions* + '((make-a-method early-make-a-method + real-make-a-method) + (add-named-method early-add-named-method + real-add-named-method) + )) + +;;; +;;; For each of the early functions, arrange to have it point to its early +;;; definition. Do this in a way that makes sure that if we redefine one +;;; of the early definitions the redefinition will take effect. This makes +;;; development easier. +;;; +;;; The function which generates the redirection closure is pulled out into +;;; a separate piece of code because of a bug in ExCL which causes this not +;;; to work if it is inlined. +;;; +(eval-when (load eval) + +(defun redirect-early-function-internal (real early) + (setf (gdefinition real) + (set-function-name + #'(lambda (&rest args) + (apply (the function (symbol-function early)) args)) + real))) + +(dolist (fns *early-functions*) + (let ((name (car fns)) + (early-name (cadr fns))) + (redirect-early-function-internal name early-name))) + +) + + +;;; +;;; *generic-function-fixups* is used by fix-early-generic-functions to +;;; convert the few functions in the bootstrap which are supposed to be +;;; generic functions but can't be early on. +;;; +(defvar *generic-function-fixups* + '((add-method + ((generic-function method) ;lambda-list + (standard-generic-function method) ;specializers + real-add-method)) ;method-function + (remove-method + ((generic-function method) + (standard-generic-function method) + real-remove-method)) + (get-method + ((generic-function qualifiers specializers &optional (errorp t)) + (standard-generic-function t t) + real-get-method)) + (ensure-generic-function-using-class + ((generic-function function-specifier + &key generic-function-class environment + &allow-other-keys) + (generic-function t) + real-ensure-gf-using-class--generic-function) + ((generic-function function-specifier + &key generic-function-class environment + &allow-other-keys) + (null t) + real-ensure-gf-using-class--null)) + (make-method-lambda + ((proto-generic-function proto-method lambda-expression environment) + (standard-generic-function standard-method t t) + real-make-method-lambda)) + (make-method-initargs-form + ((proto-generic-function proto-method lambda-expression lambda-list environment) + (standard-generic-function standard-method t t t) + real-make-method-initargs-form)) + (compute-effective-method + ((generic-function combin applicable-methods) + (generic-function standard-method-combination t) + standard-compute-effective-method)) + )) + + +;;; +;;; +;;; +(defmacro defgeneric (function-specifier lambda-list &body options) + (expand-defgeneric function-specifier lambda-list options)) + +(defun expand-defgeneric (function-specifier lambda-list options) + (when (listp function-specifier) (do-standard-defsetf-1 (cadr function-specifier))) + (let ((initargs ())) + (flet ((duplicate-option (name) + (error "The option ~S appears more than once." name))) + ;; + ;; INITARG takes this screwy new argument to get around a bad + ;; interaction between lexical macros and setf in the Lucid + ;; compiler. + ;; + (macrolet ((initarg (key &optional new) + (if new + `(setf (getf initargs ,key) ,new) + `(getf initargs ,key)))) + (dolist (option options) + (ecase (car option) + (:argument-precedence-order + (if (initarg :argument-precedence-order) + (duplicate-option :argument-precedence-order) + (initarg :argument-precedence-order `',(cdr option)))) + (declare + (initarg :declarations + (append (cdr option) (initarg :declarations)))) + (:documentation + (if (initarg :documentation) + (duplicate-option :documentation) + (initarg :documentation `',(cadr option)))) + (:method-combination + (if (initarg :method-combination) + (duplicate-option :method-combination) + (initarg :method-combination `',(cdr option)))) + (:generic-function-class + (if (initarg :generic-function-class) + (duplicate-option :generic-function-class) + (initarg :generic-function-class `',(cadr option)))) + (:method-class + (if (initarg :method-class) + (duplicate-option :method-class) + (initarg :method-class `',(cadr option)))) + (:method + (error + "DEFGENERIC doesn't support the :METHOD option yet.")))) + + (let ((declarations (initarg :declarations))) + (when declarations (initarg :declarations `',declarations))))) + `(progn + (proclaim-defgeneric ',function-specifier ',lambda-list) + ,(make-top-level-form `(defgeneric ,function-specifier) + *defgeneric-times* + `(load-defgeneric ',function-specifier ',lambda-list ,@initargs))))) + +(defun load-defgeneric (function-specifier lambda-list &rest initargs) + (when (listp function-specifier) (do-standard-defsetf-1 (cadr function-specifier))) + (apply #'ensure-generic-function + function-specifier + :lambda-list lambda-list + :definition-source `((defgeneric ,function-specifier) + ,(load-truename)) + initargs)) + + +;;; +;;; +;;; +(defmacro DEFMETHOD (&rest args &environment env) + #+(or (not :lucid) :lcl3.0) + (declare (arglist name + {method-qualifier}* + specialized-lambda-list + &body body)) + (multiple-value-bind (name qualifiers lambda-list body) + (parse-defmethod args) + (multiple-value-bind (proto-gf proto-method) + (prototypes-for-make-method-lambda name) + (expand-defmethod name proto-gf proto-method + qualifiers lambda-list body env)))) + +(defun prototypes-for-make-method-lambda (name) + (if (not (eq *boot-state* 'complete)) + (values nil nil) + (let ((gf? (and (gboundp name) + (gdefinition name)))) + (if (or (null gf?) + (not (generic-function-p gf?))) + (values (class-prototype (find-class 'standard-generic-function)) + (class-prototype (find-class 'standard-method))) + (values gf? + (class-prototype (or (generic-function-method-class gf?) + (find-class 'standard-method)))))))) + +;;; +;;; takes a name which is either a generic function name or a list specifying +;;; a setf generic function (like: (SETF )). Returns +;;; the prototype instance of the method-class for that generic function. +;;; +;;; If there is no generic function by that name, this returns the default +;;; value, the prototype instance of the class STANDARD-METHOD. This default +;;; value is also returned if the spec names an ordinary function or even a +;;; macro. In effect, this leaves the signalling of the appropriate error +;;; until load time. +;;; +;;; NOTE that during bootstrapping, this function is allowed to return NIL. +;;; +(defun method-prototype-for-gf (name) + (let ((gf? (and (gboundp name) + (gdefinition name)))) + (cond ((neq *boot-state* 'complete) nil) + ((or (null gf?) + (not (generic-function-p gf?))) ;Someone else MIGHT + ;error at load time. + (class-prototype (find-class 'standard-method))) + (t + (class-prototype (or (generic-function-method-class gf?) + (find-class 'standard-method))))))) + + +(defvar *optimize-asv-funcall-p* nil) +(defvar *asv-readers*) +(defvar *asv-writers*) +(defvar *asv-boundps*) + +(defun expand-defmethod (name proto-gf proto-method qualifiers lambda-list body env) + (when (listp name) (do-standard-defsetf-1 (cadr name))) + (let ((*make-instance-function-keys* nil) + (*optimize-asv-funcall-p* t) + (*asv-readers* nil) (*asv-writers* nil) (*asv-boundps* nil)) + (declare (special *make-instance-function-keys*)) + (multiple-value-bind (method-lambda unspecialized-lambda-list specializers) + (add-method-declarations name qualifiers lambda-list body env) + (multiple-value-bind (method-function-lambda initargs) + (make-method-lambda proto-gf proto-method method-lambda env) + (let ((initargs-form (make-method-initargs-form + proto-gf proto-method + method-function-lambda initargs env))) + `(progn + (proclaim-defgeneric ',name ',lambda-list) + ,@(when *make-instance-function-keys* + `((get-make-instance-functions ',*make-instance-function-keys*))) + ,@(when (or *asv-readers* *asv-writers* *asv-boundps*) + `((initialize-internal-slot-gfs* + ',*asv-readers* ',*asv-writers* ',*asv-boundps*))) + ,(make-defmethod-form name qualifiers specializers + unspecialized-lambda-list + (if proto-method + (class-name (class-of proto-method)) + 'standard-method) + initargs-form + (getf (getf initargs ':plist) + ':pv-table-symbol)))))))) + +(defun interned-symbol-p (x) + (and (symbolp x) (symbol-package x))) + +(defun make-defmethod-form (name qualifiers specializers + unspecialized-lambda-list method-class-name + initargs-form &optional pv-table-symbol) + (let (fn fn-lambda) + (if (and (interned-symbol-p (if (consp name) + (and (eq (car name) 'setf) (cadr name)) + name)) + (every #'interned-symbol-p qualifiers) + (every #'(lambda (s) + (if (consp s) + (and (eq (car s) 'eql) + (constantp (cadr s)) + (let ((sv (eval (cadr s)))) + (or (interned-symbol-p sv) + (integerp sv) + (and (characterp sv) + (standard-char-p sv))))) + (interned-symbol-p s))) + specializers) + (consp initargs-form) + (eq (car initargs-form) 'list*) + (memq (cadr initargs-form) '(:function :fast-function)) + (consp (setq fn (caddr initargs-form))) + (eq (car fn) 'function) + (consp (setq fn-lambda (cadr fn))) + (eq (car fn-lambda) 'lambda)) + (let* ((specls (mapcar #'(lambda (specl) + (if (consp specl) + `(,(car specl) ,(eval (cadr specl))) + specl)) + specializers)) + (mname `(,(if (eq (cadr initargs-form) ':function) + 'method 'fast-method) + ,name ,@qualifiers ,specls)) + (mname-sym (intern (let ((*print-pretty* nil)) + (format nil "~S" mname))))) + `(eval-when ,*defmethod-times* + (defun ,mname-sym ,(cadr fn-lambda) + ,@(cddr fn-lambda)) + ,(make-defmethod-form-internal + name qualifiers `',specls + unspecialized-lambda-list method-class-name + `(list* ,(cadr initargs-form) #',mname-sym ,@(cdddr initargs-form)) + pv-table-symbol))) + (make-top-level-form + `(defmethod ,name ,@qualifiers ,specializers) + *defmethod-times* + (make-defmethod-form-internal + name qualifiers + `(list ,@(mapcar #'(lambda (specializer) + (if (consp specializer) + ``(,',(car specializer) ,,(cadr specializer)) + `',specializer)) + specializers)) + unspecialized-lambda-list method-class-name + initargs-form + pv-table-symbol))))) + +(defun make-defmethod-form-internal (name qualifiers specializers-form + unspecialized-lambda-list method-class-name + initargs-form &optional pv-table-symbol) + `(load-defmethod + ',method-class-name + ',name + ',qualifiers + ,specializers-form + ',unspecialized-lambda-list + ,initargs-form + ;;Paper over a bug in KCL by passing the cache-symbol + ;;here in addition to in the list. + ',pv-table-symbol)) + +(defmacro make-method-function (method-lambda &environment env) + (make-method-function-internal method-lambda env)) + +(defun make-method-function-internal (method-lambda &optional env) + (multiple-value-bind (proto-gf proto-method) + (prototypes-for-make-method-lambda nil) + (multiple-value-bind (method-function-lambda initargs) + (make-method-lambda proto-gf proto-method method-lambda env) + (make-method-initargs-form proto-gf proto-method + method-function-lambda initargs env)))) + +(defun add-method-declarations (name qualifiers lambda-list body env) + (multiple-value-bind (parameters unspecialized-lambda-list specializers) + (parse-specialized-lambda-list lambda-list) + (declare (ignore parameters)) + (multiple-value-bind (documentation declarations real-body) + (extract-declarations body env) + (values `(lambda ,unspecialized-lambda-list + ,@(when documentation `(,documentation)) + (declare (method-name ,(list name qualifiers specializers))) + (declare (method-lambda-list ,@lambda-list)) + ,@declarations + ,@real-body) + unspecialized-lambda-list specializers)))) + +(defun real-make-method-initargs-form (proto-gf proto-method + method-lambda initargs env) + (declare (ignore proto-gf proto-method)) + (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda)) + (error "The method-lambda argument to make-method-function, ~S,~ + is not a lambda form" method-lambda)) + (make-method-initargs-form-internal method-lambda initargs env)) + +(unless (fboundp 'make-method-initargs-form) + (setf (gdefinition 'make-method-initargs-form) + (symbol-function 'real-make-method-initargs-form))) + +(defun real-make-method-lambda (proto-gf proto-method method-lambda env) + (declare (ignore proto-gf proto-method)) + (make-method-lambda-internal method-lambda env)) + +(defun make-method-lambda-internal (method-lambda &optional env) + (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda)) + (error "The method-lambda argument to make-method-lambda, ~S,~ + is not a lambda form" method-lambda)) + (multiple-value-bind (documentation declarations real-body) + (extract-declarations (cddr method-lambda) env) + (let* ((name-decl (get-declaration 'method-name declarations)) + (sll-decl (get-declaration 'method-lambda-list declarations)) + (method-name (when (consp name-decl) (car name-decl))) + (generic-function-name (when method-name (car method-name))) + (specialized-lambda-list (or sll-decl (cadr method-lambda)))) + (multiple-value-bind (parameters lambda-list specializers) + (parse-specialized-lambda-list specialized-lambda-list) + (let* ((required-parameters + (mapcar #'(lambda (r s) (declare (ignore s)) r) + parameters + specializers)) + (slots (mapcar #'list required-parameters)) + (calls (list nil)) + (parameters-to-reference + (make-parameter-references specialized-lambda-list + required-parameters + declarations + method-name + specializers)) + (class-declarations + `(declare + ,@(remove nil + (mapcar #'(lambda (a s) (and (symbolp s) + (neq s 't) + `(class ,a ,s))) + parameters + specializers)))) + (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 + ;; cadr 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 + ,class-declarations + ,@declarations + (progn ,@parameters-to-reference) + (block ,(if (listp generic-function-name) + (cadr generic-function-name) + generic-function-name) + ,@real-body))) + (constant-value-p (and (null (cdr real-body)) + (constantp (car real-body)))) + (constant-value (and constant-value-p + (eval (car real-body)))) + (plist (if (and constant-value-p + (or (typep constant-value '(or number character)) + (and (symbolp constant-value) + (symbol-package constant-value)))) + (list :constant-value constant-value) + ())) + (applyp (dolist (p lambda-list nil) + (cond ((memq p '(&optional &rest &key)) + (return t)) + ((eq p '&aux) + (return nil)))))) + (multiple-value-bind (walked-lambda call-next-method-p closurep + next-method-p-p) + (walk-method-lambda method-lambda required-parameters env + slots calls) + (multiple-value-bind (ignore walked-declarations walked-lambda-body) + (extract-declarations (cddr walked-lambda)) + (declare (ignore ignore)) + (when (or next-method-p-p call-next-method-p) + (setq plist (list* :needs-next-methods-p 't plist))) + (when (some #'cdr slots) + (multiple-value-bind (slot-name-lists call-list) + (slot-name-lists-from-slots slots calls) + (let ((pv-table-symbol (make-symbol "pv-table"))) + (setq plist + `(,@(when slot-name-lists + `(:slot-name-lists ,slot-name-lists)) + ,@(when call-list + `(:call-list ,call-list)) + :pv-table-symbol ,pv-table-symbol + ,@plist)) + (setq walked-lambda-body + `((pv-binding (,required-parameters ,slot-name-lists + ,pv-table-symbol) + ,@walked-lambda-body)))))) + (when (and (memq '&key lambda-list) + (not (memq '&allow-other-keys lambda-list))) + (let ((aux (memq '&aux lambda-list))) + (setq lambda-list (nconc (ldiff lambda-list aux) + (list '&allow-other-keys) + aux)))) + (values `(lambda (.method-args. .next-methods.) + (simple-lexical-method-functions + (,lambda-list .method-args. .next-methods. + :call-next-method-p ,call-next-method-p + :next-method-p-p ,next-method-p-p + :closurep ,closurep + :applyp ,applyp) + ,@walked-declarations + ,@walked-lambda-body)) + `(,@(when plist + `(:plist ,plist)) + ,@(when documentation + `(:documentation ,documentation))))))))))) + +(unless (fboundp 'make-method-lambda) + (setf (gdefinition 'make-method-lambda) + (symbol-function 'real-make-method-lambda))) + +(defmacro simple-lexical-method-functions ((lambda-list method-args next-methods + &rest lmf-options) + &body body) + `(progn + ,method-args ,next-methods + (bind-simple-lexical-method-macros (,method-args ,next-methods) + (bind-lexical-method-functions (,@lmf-options) + (bind-args (,lambda-list ,method-args) + ,@body))))) + +(defmacro fast-lexical-method-functions ((lambda-list next-method-call args rest-arg + &rest lmf-options) + &body body) + `(bind-fast-lexical-method-macros (,args ,rest-arg ,next-method-call) + (bind-lexical-method-functions (,@lmf-options) + (bind-args (,(nthcdr (length args) lambda-list) ,rest-arg) + ,@body)))) + +(defmacro bind-simple-lexical-method-macros ((method-args next-methods) &body body) + `(macrolet ((call-next-method-bind (&body body) + `(let ((.next-method. (car ,',next-methods)) + (,',next-methods (cdr ,',next-methods))) + .next-method. ,',next-methods + ,@body)) + (call-next-method-body (cnm-args) + `(if .next-method. + (funcall (the function + (if (std-instance-p .next-method.) + (method-function .next-method.) + .next-method.)) ; for early methods + (or ,cnm-args ,',method-args) + ,',next-methods) + (error "No next method."))) + (next-method-p-body () + `(not (null .next-method.)))) + ,@body)) + +(defstruct method-call + (function #'identity :type function) + call-method-args) + +#+cmu +(declaim (ext:freeze-type method-call)) + +(defmacro invoke-method-call1 (function args cm-args) + `(let ((.function. ,function) + (.args. ,args) + (.cm-args. ,cm-args)) + (declare (type function .function.)) + (if (and .cm-args. (null (cdr .cm-args.))) + (funcall .function. .args. (car .cm-args.)) + (apply .function. .args. .cm-args.)))) + +(defmacro invoke-method-call (method-call restp &rest required-args+rest-arg) + `(invoke-method-call1 (method-call-function ,method-call) + ,(if restp + `(list* ,@required-args+rest-arg) + `(list ,@required-args+rest-arg)) + (method-call-call-method-args ,method-call))) + +(defstruct fast-method-call + (function #'identity :type function) + pv-cell + next-method-call + arg-info) + +#+cmu +(declaim (ext:freeze-type fast-method-call)) + +#-akcl +(defmacro fmc-funcall (fn pv-cell next-method-call &rest args) + `(funcall (the function ,fn) ,pv-cell ,next-method-call ,@args)) + +(defmacro invoke-fast-method-call (method-call &rest required-args+rest-arg) + `(fmc-funcall (fast-method-call-function ,method-call) + (fast-method-call-pv-cell ,method-call) + (fast-method-call-next-method-call ,method-call) + ,@required-args+rest-arg)) + +(defstruct fast-instance-boundp + (index 0 :type fixnum)) + +#+cmu +(declaim (ext:freeze-type fast-instance-boundp)) + +(eval-when (compile load eval) +(defvar *allow-emf-call-tracing-p* nil) +(defvar *enable-emf-call-tracing-p* #-testing nil #+testing t) +) + +(defvar *emf-call-trace-size* 200) +(defvar *emf-call-trace* nil) +(defvar emf-call-trace-index 0) + +(defun show-emf-call-trace () + (when *emf-call-trace* + (let ((j emf-call-trace-index) + (*enable-emf-call-tracing-p* nil)) + (format t "~&(The oldest entries are printed first)~%") + (dotimes (i *emf-call-trace-size*) + (let ((ct (aref *emf-call-trace* j))) + (when ct (print ct))) + (incf j) + (when (= j *emf-call-trace-size*) + (setq j 0)))))) + +(defun trace-emf-call-internal (emf format args) + (unless *emf-call-trace* + (setq *emf-call-trace* (make-array *emf-call-trace-size*))) + (setf (aref *emf-call-trace* emf-call-trace-index) + (list* emf format args)) + (incf emf-call-trace-index) + (when (= emf-call-trace-index *emf-call-trace-size*) + (setq emf-call-trace-index 0))) + +(defmacro trace-emf-call (emf format args) + (when *allow-emf-call-tracing-p* + `(when *enable-emf-call-tracing-p* + (trace-emf-call-internal ,emf ,format ,args)))) + +(defmacro invoke-effective-method-function-fast + (emf restp &rest required-args+rest-arg) + `(progn + (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg)) + (invoke-fast-method-call ,emf ,@required-args+rest-arg))) + +(defmacro invoke-effective-method-function (emf restp &rest required-args+rest-arg) + (unless (constantp restp) + (error "The restp argument to invoke-effective-method-function is not constant")) + (setq restp (eval restp)) + `(progn + (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg)) + (cond (#-(or lucid excl) (typep ,emf 'fast-method-call) + #+(or lucid excl) (fast-method-call-p ,emf) + (invoke-fast-method-call ,emf ,@required-args+rest-arg)) + ,@(when (and (null restp) (= 1 (length required-args+rest-arg))) + `(((typep ,emf 'fixnum) + (let* ((.slots. (get-slots-or-nil + ,(car required-args+rest-arg))) + (value (when .slots. (%instance-ref .slots. ,emf)))) + (if (eq value ',*slot-unbound*) + (slot-unbound-internal ,(car required-args+rest-arg) + ,emf) + value))))) + ,@(when (and (null restp) (= 2 (length required-args+rest-arg))) + `(((typep ,emf 'fixnum) + (let ((.new-value. ,(car required-args+rest-arg)) + (.slots. (get-slots-or-nil + ,(car required-args+rest-arg)))) + (when .slots. ; just to avoid compiler wranings + (setf (%instance-ref .slots. ,emf) .new-value.)))))) + #|| + ,@(when (and (null restp) (= 1 (length required-args+rest-arg))) + `(((typep ,emf 'fast-instance-boundp) + (let ((.slots. (get-slots-or-nil + ,(car required-args+rest-arg)))) + (and .slots. + (not (eq (%instance-ref + .slots. (fast-instance-boundp-index ,emf)) + ',*slot-unbound*))))))) + ||# + (t + (etypecase ,emf + (method-call + (invoke-method-call ,emf ,restp ,@required-args+rest-arg)) + (function + ,(if restp + `(apply (the function ,emf) ,@required-args+rest-arg) + `(funcall (the function ,emf) + ,@required-args+rest-arg)))))))) + +(defun invoke-emf (emf args) + (trace-emf-call emf t args) + (etypecase emf + (fast-method-call + (let* ((arg-info (fast-method-call-arg-info emf)) + (restp (cdr arg-info)) + (nreq (car arg-info))) + (if restp + (let* ((rest-args (nthcdr nreq args)) + (req-args (ldiff args rest-args))) + (apply (the function (fast-method-call-function emf)) + (fast-method-call-pv-cell emf) + (fast-method-call-next-method-call emf) + (nconc req-args (list rest-args)))) + (cond ((null args) + (if (eql nreq 0) + (invoke-fast-method-call emf) + (error "wrong number of args"))) + ((null (cdr args)) + (if (eql nreq 1) + (invoke-fast-method-call emf (car args)) + (error "wrong number of args"))) + ((null (cddr args)) + (if (eql nreq 2) + (invoke-fast-method-call emf (car args) (cadr args)) + (error "wrong number of args"))) + (t + (apply (the function (fast-method-call-function emf)) + (fast-method-call-pv-cell emf) + (fast-method-call-next-method-call emf) + args)))))) + (method-call + (apply (the function (method-call-function emf)) + args + (method-call-call-method-args emf))) + (fixnum + (cond ((null args) (error "1 or 2 args expected")) + ((null (cdr args)) + (let ((value (%instance-ref (get-slots (car args)) emf))) + (if (eq value *slot-unbound*) + (slot-unbound-internal (car args) emf) + value))) + ((null (cddr args)) + (setf (%instance-ref (get-slots (cadr args)) emf) + (car args))) + (t (error "1 or 2 args expected")))) + (fast-instance-boundp + (if (or (null args) (cdr args)) + (error "1 arg expected") + (not (eq (%instance-ref (get-slots (car args)) + (fast-instance-boundp-index emf)) + *slot-unbound*)))) + (function + (apply (the function emf) args)))) + +;; This can be improved alot. +(defun gf-make-function-from-emf (gf emf) + (etypecase emf + (fast-method-call (let* ((arg-info (gf-arg-info gf)) + (nreq (arg-info-number-required arg-info)) + (restp (arg-info-applyp arg-info))) + #'(lambda (&rest args) + #+copy-&rest-arg (setq args (copy-list args)) + (trace-emf-call emf t args) + (apply (fast-method-call-function emf) + (fast-method-call-pv-cell emf) + (fast-method-call-next-method-call emf) + (if restp + (let* ((rest-args (nthcdr nreq args)) + (req-args (ldiff args rest-args))) + (nconc req-args rest-args)) + args))))) + (method-call #'(lambda (&rest args) + #+copy-&rest-arg (setq args (copy-list args)) + (trace-emf-call emf t args) + (apply (method-call-function emf) + args + (method-call-call-method-args emf)))) + (function emf))) + +(defmacro bind-fast-lexical-method-macros ((args rest-arg next-method-call) + &body body) + `(macrolet ((call-next-method-bind (&body body) + `(let () ,@body)) + (call-next-method-body (cnm-args) + `(if ,',next-method-call + ,(if (and (null ',rest-arg) + (consp cnm-args) + (eq (car cnm-args) 'list)) + `(invoke-effective-method-function + ,',next-method-call nil + ,@(cdr cnm-args)) + (let ((call `(invoke-effective-method-function + ,',next-method-call + ,',(not (null rest-arg)) + ,@',args + ,@',(when rest-arg `(,rest-arg))))) + `(if ,cnm-args + (bind-args ((,@',args ,@',(when rest-arg + `(&rest ,rest-arg))) + ,cnm-args) + ,call) + ,call))) + (error "No next method."))) + (next-method-p-body () + `(not (null ,',next-method-call)))) + ,@body)) + +(defmacro bind-lexical-method-functions + ((&key call-next-method-p next-method-p-p closurep applyp) + &body body) + (cond ((and (null call-next-method-p) (null next-method-p-p) + (null closurep) + (null applyp)) + `(let () ,@body)) + ((and (null closurep) + (null applyp)) + ;; OK to use MACROLET, and all args are mandatory + ;; (else APPLYP would be true). + `(call-next-method-bind + (macrolet ((call-next-method (&rest cnm-args) + `(call-next-method-body ,(when cnm-args `(list ,@cnm-args)))) + (next-method-p () + `(next-method-p-body))) + ,@body))) + (t + `(call-next-method-bind + (flet (,@(and call-next-method-p + '((call-next-method (&rest cnm-args) + #+Genera + (declare (dbg:invisible-frame :clos-internal)) + #+copy-&rest-arg (setq args (copy-list args)) + (call-next-method-body cnm-args)))) + ,@(and next-method-p-p + '((next-method-p () + (next-method-p-body))))) + ,@body))))) + +(defmacro bind-args ((lambda-list args) &body body) + #|| ; Lucid and Allegro don't compile the function inline + `(apply #'(lambda ,lambda-list ,@body) ,args) + ||# + (let ((args-tail '.args-tail.) + (key '.key.) + (state 'required)) + (flet ((process-var (var) + (if (memq var lambda-list-keywords) + (progn + (case var + (&optional (setq state 'optional)) + (&key (setq state 'key)) + (&allow-other-keys) + (&rest (setq state 'rest)) + (&aux (setq state 'aux)) + (otherwise + (error "Encountered the non-standard lambda list keyword ~S." + var))) + nil) + (case state + (required `((,var (pop ,args-tail)))) + (optional (cond ((not (consp var)) + `((,var (when ,args-tail (pop ,args-tail))))) + ((null (cddr var)) + `((,(car var) (if ,args-tail + (pop ,args-tail) + ,(cadr var))))) + (t + `((,(caddr var) ,args-tail) + (,(car var) (if ,args-tail + (pop ,args-tail) + ,(cadr var))))))) + (rest `((,var ,args-tail))) + (key (cond ((not (consp var)) + `((,var (get-key-arg ,(make-keyword var) + ,args-tail)))) + ((null (cddr var)) + (multiple-value-bind (keyword variable) + (if (consp (car var)) + (values (caar var) (cadar var)) + (values (make-keyword (car var)) (car var))) + `((,key (get-key-arg1 ,keyword ,args-tail)) + (,variable (if (consp ,key) + (car ,key) + ,(cadr var)))))) + (t + (multiple-value-bind (keyword variable) + (if (consp (car var)) + (values (caar var) (cadar var)) + (values (make-keyword (car var)) (car var))) + `((,key (get-key-arg1 ,keyword ,args-tail)) + (,(caddr var) ,key) + (,variable (if (consp ,key) + (car ,key) + ,(cadr var)))))))) + (aux `(,var)))))) + (let ((bindings (mapcan #'process-var lambda-list))) + `(let* ((,args-tail ,args) + ,@bindings) + ,@(unless bindings `((declare (ignore ,args-tail)))) + ,@body))))) + +(defun get-key-arg (keyword list) + (loop (when (atom list) (return nil)) + (when (eq (car list) keyword) (return (cadr list))) + (setq list (cddr list)))) + +(defun get-key-arg1 (keyword list) + (loop (when (atom list) (return nil)) + (when (eq (car list) keyword) (return (cdr list))) + (setq list (cddr list)))) + +(defun walk-method-lambda (method-lambda required-parameters env slots calls) + (let ((call-next-method-p nil) ;flag indicating that call-next-method + ;should be in the method definition + (closurep nil) ;flag indicating that #'call-next-method + ;was seen in the body of a method + (next-method-p-p nil)) ;flag indicating that next-method-p + ;should be in the method definition + (flet ((walk-function (form context env) + (cond ((not (eq context ':eval)) form) + ((not (listp form)) form) + ((eq (car form) 'call-next-method) + (setq call-next-method-p 't) + form) + ((eq (car form) 'next-method-p) + (setq next-method-p-p 't) + form) + ((and (eq (car form) 'function) + (cond ((eq (cadr form) 'call-next-method) + (setq call-next-method-p 't) + (setq closurep t) + form) + ((eq (cadr form) 'next-method-p) + (setq next-method-p-p 't) + (setq closurep t) + form) + (t nil)))) + ((and (or (eq (car form) 'slot-value) + (eq (car form) 'set-slot-value) + (eq (car form) 'slot-boundp)) + (constantp (caddr form))) + (let ((parameter + (can-optimize-access form + required-parameters env))) + (ecase (car form) + (slot-value + (optimize-slot-value slots parameter form)) + (set-slot-value + (optimize-set-slot-value slots parameter form)) + (slot-boundp + (optimize-slot-boundp slots parameter form))))) + ((and (eq (car form) 'apply) + (consp (cadr form)) + (eq (car (cadr form)) 'function) + (generic-function-name-p (cadr (cadr form)))) + (optimize-generic-function-call + form required-parameters env slots calls)) + ((and (or (symbolp (car form)) + (and (consp (car form)) + (eq (caar form) 'setf))) + (generic-function-name-p (car form))) + (optimize-generic-function-call + form required-parameters env slots calls)) + ((and (eq (car form) 'asv-funcall) + *optimize-asv-funcall-p*) + (case (fourth form) + (reader (push (third form) *asv-readers*)) + (writer (push (third form) *asv-writers*)) + (boundp (push (third form) *asv-boundps*))) + `(,(second form) ,@(cddddr form))) + (t form)))) + + (let ((walked-lambda (walk-form method-lambda env #'walk-function))) + (values walked-lambda + call-next-method-p closurep next-method-p-p))))) + +(defun generic-function-name-p (name) + (and (or (symbolp name) + (and (consp name) + (eq (car name) 'setf) + (consp (cdr name)) + (symbolp (cadr name)) + (null (cddr name)))) + (gboundp name) + (if (eq *boot-state* 'complete) + (standard-generic-function-p (gdefinition name)) + (funcallable-instance-p (gdefinition name))))) + +(defun make-parameter-references (specialized-lambda-list + required-parameters + declarations + method-name + specializers) + (flet ((ignoredp (symbol) + (dolist (decl (cdar declarations)) + (when (and (eq (car decl) 'ignore) + (memq symbol (cdr decl))) + (return t))))) + (gathering ((references (collecting))) + (iterate ((s (list-elements specialized-lambda-list)) + (p (list-elements required-parameters))) + (progn p) + (cond ((not (listp s))) + ((ignoredp (car s)) + (warn "In defmethod ~S, there is a~%~ + redundant ignore declaration for the parameter ~S." + method-name + specializers + (car s))) + (t + (gather (car s) references))))))) + + +(defvar *method-function-plist* (make-hash-table :test #'eq)) +(defvar *mf1* nil) (defvar *mf1p* nil) (defvar *mf1cp* nil) +(defvar *mf2* nil) (defvar *mf2p* nil) (defvar *mf2cp* nil) + +(defun method-function-plist (method-function) + (unless (eq method-function *mf1*) + (rotatef *mf1* *mf2*) + (rotatef *mf1p* *mf2p*) + (rotatef *mf1cp* *mf2cp*)) + (unless (or (eq method-function *mf1*) (null *mf1cp*)) + (setf (gethash *mf1* *method-function-plist*) *mf1p*)) + (unless (eq method-function *mf1*) + (setf *mf1* method-function + *mf1cp* nil + *mf1p* (gethash method-function *method-function-plist*))) + *mf1p*) + +(defun #-setf SETF\ PCL\ METHOD-FUNCTION-PLIST #+setf (setf method-function-plist) + (val method-function) + (unless (eq method-function *mf1*) + (rotatef *mf1* *mf2*) + (rotatef *mf1cp* *mf2cp*) + (rotatef *mf1p* *mf2p*)) + (unless (or (eq method-function *mf1*) (null *mf1cp*)) + (setf (gethash *mf1* *method-function-plist*) *mf1p*)) + (setf *mf1* method-function + *mf1cp* t + *mf1p* val)) + +(defun method-function-get (method-function key &optional default) + (getf (method-function-plist method-function) key default)) + +(defun #-setf SETF\ PCL\ METHOD-FUNCTION-GET #+setf (setf method-function-get) + (val method-function key) + (setf (getf (method-function-plist method-function) key) val)) + + +(defun method-function-pv-table (method-function) + (method-function-get method-function :pv-table)) + +(defun method-function-method (method-function) + (method-function-get method-function :method)) + +(defun method-function-needs-next-methods-p (method-function) + (method-function-get method-function :needs-next-methods-p t)) + + + +(defmacro method-function-closure-generator (method-function) + `(method-function-get ,method-function 'closure-generator)) + +(defun load-defmethod (class name quals specls ll initargs &optional pv-table-symbol) + (when (listp name) (do-standard-defsetf-1 (cadr name))) + (setq initargs (copy-tree initargs)) + (let ((method-spec (or (getf initargs ':method-spec) + (make-method-spec name quals specls)))) + (setf (getf initargs ':method-spec) method-spec) + (record-definition 'method method-spec) + (load-defmethod-internal class name quals specls ll initargs pv-table-symbol))) + +(defun load-defmethod-internal + (method-class gf-spec qualifiers specializers lambda-list + initargs pv-table-symbol) + (when (listp gf-spec) (do-standard-defsetf-1 (cadr gf-spec))) + (when pv-table-symbol + (setf (getf (getf initargs ':plist) :pv-table-symbol) + pv-table-symbol)) + (let ((method (apply #'add-named-method + gf-spec qualifiers specializers lambda-list + :definition-source `((defmethod ,gf-spec + ,@qualifiers + ,specializers) + ,(load-truename)) + initargs))) + (unless (or (eq method-class 'standard-method) + (eq (find-class method-class nil) (class-of method))) + (format *error-output* + "~&At the time the method with qualifiers ~:S and~%~ + specializers ~:S on the generic function ~S~%~ + was compiled, the method-class for that generic function was~%~ + ~S. But, the method class is now ~S, this~%~ + may mean that this method was compiled improperly.~%" + qualifiers specializers gf-spec + method-class (class-name (class-of method)))) + method)) + +(defun make-method-spec (gf-spec qualifiers unparsed-specializers) + `(method ,gf-spec ,@qualifiers ,unparsed-specializers)) + +(defun initialize-method-function (initargs &optional return-function-p method) + (let* ((mf (getf initargs ':function)) + (method-spec (getf initargs ':method-spec)) + (plist (getf initargs ':plist)) + (pv-table-symbol (getf plist ':pv-table-symbol)) + (pv-table nil) + (mff (getf initargs ':fast-function))) + (flet ((set-mf-property (p v) + (when mf + (setf (method-function-get mf p) v)) + (when mff + (setf (method-function-get mff p) v)))) + (when method-spec + (when mf + (setq mf (set-function-name mf method-spec))) + (when mff + (let ((name `(,(or (get (car method-spec) 'fast-sym) + (setf (get (car method-spec) 'fast-sym) + (intern (format nil "FAST-~A" + (car method-spec)) + *the-pcl-package*))) + ,@(cdr method-spec)))) + (set-function-name mff name) + (unless mf + (set-mf-property :name name))))) + (when plist + (let ((snl (getf plist :slot-name-lists)) + (cl (getf plist :call-list))) + (when (or snl cl) + (setq pv-table (intern-pv-table :slot-name-lists snl + :call-list cl)) + (when pv-table (set pv-table-symbol pv-table)) + (set-mf-property :pv-table pv-table))) + (loop (when (null plist) (return nil)) + (set-mf-property (pop plist) (pop plist))) + (when method + (set-mf-property :method method)) + (when return-function-p + (or mf (method-function-from-fast-function mff))))))) + + + +(defun analyze-lambda-list (lambda-list) + ;;(declare (values nrequired noptional keysp restp allow-other-keys-p + ;; keywords keyword-parameters)) + (flet ((parse-keyword-argument (arg) + (if (listp arg) + (if (listp (car arg)) + (caar arg) + (make-keyword (car arg))) + (make-keyword arg)))) + (let ((nrequired 0) + (noptional 0) + (keysp nil) + (restp nil) + (allow-other-keys-p nil) + (keywords ()) + (keyword-parameters ()) + (state 'required)) + (dolist (x lambda-list) + (if (memq x lambda-list-keywords) + (case x + (&optional (setq state 'optional)) + (&key (setq keysp 't + state 'key)) + (&allow-other-keys (setq allow-other-keys-p 't)) + (&rest (setq restp 't + state 'rest)) + (&aux (return t)) + (otherwise + (error "Encountered the non-standard lambda list keyword ~S." x))) + (ecase state + (required (incf nrequired)) + (optional (incf noptional)) + (key (push (parse-keyword-argument x) keywords) + (push x keyword-parameters)) + (rest ())))) + (values nrequired noptional keysp restp allow-other-keys-p + (reverse keywords) + (reverse keyword-parameters))))) + +(defun keyword-spec-name (x) + (let ((key (if (atom x) x (car x)))) + (if (atom key) + (intern (symbol-name key) (find-package "KEYWORD")) + (car key)))) + +(defun ftype-declaration-from-lambda-list (lambda-list #+cmu name) + (multiple-value-bind (nrequired noptional keysp restp allow-other-keys-p + keywords keyword-parameters) + (analyze-lambda-list lambda-list) + (declare (ignore keyword-parameters)) + (let* (#+cmu (old (c::info function type name)) + #+cmu (old-ftype (if (c::function-type-p old) old nil)) + #+cmu (old-restp (and old-ftype (c::function-type-rest old-ftype))) + #+cmu (old-keys (and old-ftype + (mapcar #'c::key-info-name + (c::function-type-keywords old-ftype)))) + #+cmu (old-keysp (and old-ftype (c::function-type-keyp old-ftype))) + #+cmu (old-allowp (and old-ftype (c::function-type-allowp old-ftype))) + (keywords #+cmu (union old-keys (mapcar #'keyword-spec-name keywords)) + #-cmu (mapcar #'keyword-spec-name keywords))) + `(function ,(append (make-list nrequired :initial-element 't) + (when (plusp noptional) + (append '(&optional) + (make-list noptional :initial-element 't))) + (when (or restp #+cmu old-restp) + '(&rest t)) + (when (or keysp #+cmu old-keysp) + (append '(&key) + (mapcar #'(lambda (key) + `(,key t)) + keywords) + (when (or allow-other-keys-p #+cmu old-allowp) + '(&allow-other-keys))))) + *)))) + +(defun proclaim-defgeneric (spec lambda-list) + #-cmu (declare (ignore lambda-list)) + (when (consp spec) + (setq spec (get-setf-function-name (cadr spec)))) + (let (#+cmu + (decl `(ftype ,(ftype-declaration-from-lambda-list lambda-list #+cmu spec) + ,spec))) + #+cmu (proclaim decl) + #+kcl (setf (get spec 'compiler::proclaimed-closure) t))) + +;;;; Early generic-function support +;;; +;;; +(defvar *early-generic-functions* ()) + +(defun ensure-generic-function (function-specifier + &rest all-keys + &key environment + &allow-other-keys) + (declare (ignore environment)) + #+copy-&rest-arg (setq all-keys (copy-list all-keys)) + (let ((existing (and (gboundp function-specifier) + (gdefinition function-specifier)))) + (if (and existing + (eq *boot-state* 'complete) + (null (generic-function-p existing))) + (generic-clobbers-function function-specifier) + (apply #'ensure-generic-function-using-class + existing function-specifier all-keys)))) + +(defun generic-clobbers-function (function-specifier) + #+Lispm (zl:signal 'generic-clobbers-function :name function-specifier) + #-Lispm (error "~S already names an ordinary function or a macro,~%~ + you may want to replace it with a generic function, but doing so~%~ + will require that you decide what to do with the existing function~%~ + definition.~%~ + The PCL-specific function MAKE-SPECIALIZABLE may be useful to you." + function-specifier)) + +#+Lispm +(zl:defflavor generic-clobbers-function (name) (si:error) + :initable-instance-variables) + +#+Lispm +(zl:defmethod #+Genera (dbg:report generic-clobbers-function) + #+ti (generic-clobbers-function :report) + (stream) + (format stream + "~S aready names a ~a" + name + (if (and (symbolp name) (macro-function name)) "macro" "function"))) + +#+Genera +(zl:defmethod (sys:proceed generic-clobbers-function :specialize-it) () + "Make it specializable anyway?" + (make-specializable name)) + +#+ti +(zl:defmethod + (generic-clobbers-function :case :proceed-asking-user :specialize-it) + (continuation ignore) + "Make it specializable anyway?" + (make-specializable name) + (funcall continuation :specialize-it)) + +(defvar *sgf-wrapper* + (#+cmu17 boot-make-wrapper #-cmu17 make-wrapper + (early-class-size 'standard-generic-function) + #+cmu17 'standard-generic-function)) + +(defvar *sgf-slots-init* + (map 'vector + #'(lambda (canonical-slot) + (if (memq (getf canonical-slot :name) '(arg-info source)) + *slot-unbound* + (let ((initfunction (getf canonical-slot :initfunction))) + (if initfunction + (funcall initfunction) + *slot-unbound*)))) + (early-collect-inheritance 'standard-generic-function))) + +(defvar *sgf-method-class-index* + (bootstrap-slot-index 'standard-generic-function 'method-class)) + +(defun early-gf-p (x) + (and (fsc-instance-p x) + (eq (instance-ref (get-slots x) *sgf-method-class-index*) + *slot-unbound*))) + +(defvar *sgf-methods-index* + (bootstrap-slot-index 'standard-generic-function 'methods)) + +(defmacro early-gf-methods (gf) + `(instance-ref (get-slots ,gf) *sgf-methods-index*)) + +(defvar *sgf-arg-info-index* + (bootstrap-slot-index 'standard-generic-function 'arg-info)) + +(defmacro early-gf-arg-info (gf) + `(instance-ref (get-slots ,gf) *sgf-arg-info-index*)) + +(defvar *sgf-dfun-state-index* + (bootstrap-slot-index 'standard-generic-function 'dfun-state)) + +(defstruct (arg-info + (:conc-name nil) + (:constructor make-arg-info ())) + (arg-info-lambda-list :no-lambda-list) + arg-info-precedence + arg-info-metatypes + arg-info-number-optional + arg-info-key/rest-p + arg-info-keywords ;nil no keyword or rest allowed + ;(k1 k2 ..) each method must accept these keyword arguments + ;T must have &key or &rest + + gf-info-simple-accessor-type ; nil, reader, writer, boundp + (gf-precompute-dfun-and-emf-p nil) ; set by set-arg-info + + gf-info-static-c-a-m-emf + (gf-info-c-a-m-emf-std-p t) + gf-info-fast-mf-p) + +#+cmu +(declaim (ext:freeze-type arg-info)) + +(defun arg-info-valid-p (arg-info) + (not (null (arg-info-number-optional arg-info)))) + +(defun arg-info-applyp (arg-info) + (or (plusp (the fixnum (arg-info-number-optional arg-info))) + (arg-info-key/rest-p arg-info))) + +(defun arg-info-number-required (arg-info) + (length (arg-info-metatypes arg-info))) + +(defun arg-info-nkeys (arg-info) + (count-if #'(lambda (x) (neq x 't)) (arg-info-metatypes arg-info))) + +;;; Keep pages clean by not setting if the value is already the same. +(defmacro esetf (pos val) + (let ((valsym (gensym "value"))) + `(let ((,valsym ,val)) + (unless (equal ,pos ,valsym) + (setf ,pos ,valsym))))) + +(defun set-arg-info (gf &key new-method (lambda-list nil lambda-list-p) + argument-precedence-order) + (let* ((arg-info (if (eq *boot-state* 'complete) + (gf-arg-info gf) + (early-gf-arg-info gf))) + (methods (if (eq *boot-state* 'complete) + (generic-function-methods gf) + (early-gf-methods gf))) + (was-valid-p (integerp (arg-info-number-optional arg-info))) + (first-p (and new-method (null (cdr methods))))) + (when (and (not lambda-list-p) methods) + (setq lambda-list (gf-lambda-list gf))) + (when (or lambda-list-p + (and first-p (eq (arg-info-lambda-list arg-info) ':no-lambda-list))) + (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords) + (analyze-lambda-list lambda-list) + (when (and methods (not first-p)) + (let ((gf-nreq (arg-info-number-required arg-info)) + (gf-nopt (arg-info-number-optional arg-info)) + (gf-key/rest-p (arg-info-key/rest-p arg-info))) + (unless (and (= nreq gf-nreq) + (= nopt gf-nopt) + (eq (or keysp restp) gf-key/rest-p)) + (error "The lambda-list ~S is incompatible with ~ + existing methods of ~S." + lambda-list gf)))) + (when lambda-list-p + (esetf (arg-info-lambda-list arg-info) lambda-list)) + (when (or lambda-list-p argument-precedence-order + (null (arg-info-precedence arg-info))) + (esetf (arg-info-precedence arg-info) + (compute-precedence lambda-list nreq + argument-precedence-order))) + (esetf (arg-info-metatypes arg-info) (make-list nreq)) + (esetf (arg-info-number-optional arg-info) nopt) + (esetf (arg-info-key/rest-p arg-info) (not (null (or keysp restp)))) + (esetf (arg-info-keywords arg-info) + (if lambda-list-p + (if allow-other-keys-p t keywords) + (arg-info-key/rest-p arg-info))))) + (when new-method + (check-method-arg-info gf arg-info new-method)) + (set-arg-info1 gf arg-info new-method methods was-valid-p first-p) + arg-info)) + +(defun check-method-arg-info (gf arg-info method) + (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords) + (analyze-lambda-list (if (consp method) + (early-method-lambda-list method) + (method-lambda-list method))) + (flet ((lose (string &rest args) + (error "Attempt to add the method ~S to the generic function ~S.~%~ + But ~A" method gf (apply #'format nil string args))) + (compare (x y) + (if (> x y) "more" "fewer"))) + (let ((gf-nreq (arg-info-number-required arg-info)) + (gf-nopt (arg-info-number-optional arg-info)) + (gf-key/rest-p (arg-info-key/rest-p arg-info)) + (gf-keywords (arg-info-keywords arg-info))) + (unless (= nreq gf-nreq) + (lose "the method has ~A required arguments than the generic function." + (compare nreq gf-nreq))) + (unless (= nopt gf-nopt) + (lose "the method has ~S optional arguments than the generic function." + (compare nopt gf-nopt))) + (unless (eq (or keysp restp) gf-key/rest-p) + (error "the method and generic function differ in whether they accept~%~ + rest or keyword arguments.")) + (when (consp gf-keywords) + (unless (or (and restp (not keysp)) + allow-other-keys-p + (every #'(lambda (k) (memq k keywords)) gf-keywords)) + (lose "the method does not accept each of the keyword arguments~%~ + ~S." gf-keywords))))))) + +(defun set-arg-info1 (gf arg-info new-method methods was-valid-p first-p) + (let* ((existing-p (and methods (cdr methods) new-method)) + (nreq (length (arg-info-metatypes arg-info))) + (metatypes (if existing-p + (arg-info-metatypes arg-info) + (make-list nreq))) + (type (if existing-p + (gf-info-simple-accessor-type arg-info) + nil))) + (when (arg-info-valid-p arg-info) + (dolist (method (if new-method (list new-method) methods)) + (let* ((specializers (if (or (eq *boot-state* 'complete) + (not (consp method))) + (method-specializers method) + (early-method-specializers method t))) + (class (if (or (eq *boot-state* 'complete) (not (consp method))) + (class-of method) + (early-method-class method))) + (new-type (when (and class + (or (not (eq *boot-state* 'complete)) + (eq (generic-function-method-combination gf) + *standard-method-combination*))) + (cond ((eq class *the-class-standard-reader-method*) + 'reader) + ((eq class *the-class-standard-writer-method*) + 'writer) + ((eq class *the-class-standard-boundp-method*) + 'boundp))))) + (setq metatypes (mapcar #'raise-metatype metatypes specializers)) + (setq type (cond ((null type) new-type) + ((eq type new-type) type) + (t nil))))) + (esetf (arg-info-metatypes arg-info) metatypes) + (esetf (gf-info-simple-accessor-type arg-info) type))) + (when (or (not was-valid-p) first-p) + (multiple-value-bind (c-a-m-emf std-p) + (if (early-gf-p gf) + (values t t) + (compute-applicable-methods-emf gf)) + (esetf (gf-info-static-c-a-m-emf arg-info) c-a-m-emf) + (esetf (gf-info-c-a-m-emf-std-p arg-info) std-p) + (unless (gf-info-c-a-m-emf-std-p arg-info) + (esetf (gf-info-simple-accessor-type arg-info) t)))) + (unless was-valid-p + (let ((name (if (eq *boot-state* 'complete) + (generic-function-name gf) + (early-gf-name gf)))) + (esetf (gf-precompute-dfun-and-emf-p arg-info) + (let* ((sym (if (atom name) name (cadr name))) + (pkg-list (cons *the-pcl-package* + (package-use-list *the-pcl-package*)))) + (and sym (symbolp sym) + (not (null (memq (symbol-package sym) pkg-list))) + (not (find #\space (symbol-name sym)))))))) + (esetf (gf-info-fast-mf-p arg-info) + (or (not (eq *boot-state* 'complete)) + (let* ((method-class (generic-function-method-class gf)) + (methods (compute-applicable-methods + #'make-method-lambda + (list gf (class-prototype method-class) + '(lambda) nil)))) + (and methods (null (cdr methods)) + (let ((specls (method-specializers (car methods)))) + (and (classp (car specls)) + (eq 'standard-generic-function + (class-name (car specls))) + (classp (cadr specls)) + (eq 'standard-method + (class-name (cadr specls))))))))) + arg-info) + +;;; +;;; This is the early definition of ensure-generic-function-using-class. +;;; +;;; The static-slots field of the funcallable instances used as early generic +;;; functions is used to store the early methods and early discriminator code +;;; for the early generic function. The static slots field of the fins +;;; contains a list whose: +;;; CAR - a list of the early methods on this early gf +;;; CADR - the early discriminator code for this method +;;; +(defun ensure-generic-function-using-class (existing spec &rest keys + &key (lambda-list nil lambda-list-p) + &allow-other-keys) + (declare (ignore keys)) + (cond ((and existing (early-gf-p existing)) + existing) + ((assoc spec *generic-function-fixups* :test #'equal) + (if existing + (make-early-gf spec lambda-list lambda-list-p existing) + (error "The function ~S is not already defined" spec))) + (existing + (error "~S should be on the list ~S" spec '*generic-function-fixups*)) + (t + (pushnew spec *early-generic-functions* :test #'equal) + (make-early-gf spec lambda-list lambda-list-p)))) + +(defun make-early-gf (spec &optional lambda-list lambda-list-p function) + (let ((fin (allocate-funcallable-instance *sgf-wrapper* *sgf-slots-init*))) + (set-funcallable-instance-function + fin + (or function + (if (eq spec 'print-object) + (fin-lambda-fn (instance stream) + (printing-random-thing (instance stream) + (format stream "std-instance"))) + (fin-lambda-fn (&rest args) + (declare (ignore args)) + (error "The function of the funcallable-instance ~S~ + has not been set" fin))))) + (setf (gdefinition spec) fin) + (bootstrap-set-slot 'standard-generic-function fin 'name spec) + (bootstrap-set-slot 'standard-generic-function fin 'source (load-truename)) + (set-function-name fin spec) + (let ((arg-info (make-arg-info))) + (setf (early-gf-arg-info fin) arg-info) + (when lambda-list-p + (proclaim-defgeneric spec lambda-list) + (set-arg-info fin :lambda-list lambda-list))) + fin)) + +(defun set-dfun (gf &optional dfun cache info) + (when cache + (setf (cache-owner cache) gf)) + (let ((new-state (if (and dfun (or cache info)) + (list* dfun cache info) + dfun))) + (if (eq *boot-state* 'complete) + (setf (gf-dfun-state gf) new-state) + (setf (instance-ref (get-slots gf) *sgf-dfun-state-index*) new-state))) + dfun) + +(defun gf-dfun-cache (gf) + (let ((state (if (eq *boot-state* 'complete) + (gf-dfun-state gf) + (instance-ref (get-slots gf) *sgf-dfun-state-index*)))) + (typecase state + (function nil) + (cons (cadr state))))) + +(defun gf-dfun-info (gf) + (let ((state (if (eq *boot-state* 'complete) + (gf-dfun-state gf) + (instance-ref (get-slots gf) *sgf-dfun-state-index*)))) + (typecase state + (function nil) + (cons (cddr state))))) + +(defvar *sgf-name-index* + (bootstrap-slot-index 'standard-generic-function 'name)) + +(defun early-gf-name (gf) + (instance-ref (get-slots gf) *sgf-name-index*)) + +(defun gf-lambda-list (gf) + (let ((arg-info (if (eq *boot-state* 'complete) + (gf-arg-info gf) + (early-gf-arg-info gf)))) + (if (eq ':no-lambda-list (arg-info-lambda-list arg-info)) + (let ((methods (if (eq *boot-state* 'complete) + (generic-function-methods gf) + (early-gf-methods gf)))) + (if (null methods) + (progn + (warn "No way to determine the lambda list for ~S." gf) + nil) + (let* ((method (car (last methods))) + (ll (if (consp method) + (early-method-lambda-list method) + (method-lambda-list method))) + (k (member '&key ll))) + (if k + (append (ldiff ll (cdr k)) '(&allow-other-keys)) + ll)))) + (arg-info-lambda-list arg-info)))) + +(defmacro real-ensure-gf-internal (gf-class all-keys env) + `(progn + (cond ((symbolp ,gf-class) + (setq ,gf-class (find-class ,gf-class t ,env))) + ((classp ,gf-class)) + (t + (error "The :GENERIC-FUNCTION-CLASS argument (~S) was neither a~%~ + class nor a symbol that names a class." + ,gf-class))) + (remf ,all-keys :generic-function-class) + (remf ,all-keys :environment) + (let ((combin (getf ,all-keys :method-combination '.shes-not-there.))) + (unless (eq combin '.shes-not-there.) + (setf (getf ,all-keys :method-combination) + (find-method-combination (class-prototype ,gf-class) + (car combin) + (cdr combin))))) + )) + +(defun real-ensure-gf-using-class--generic-function + (existing + function-specifier + &rest all-keys + &key environment (lambda-list nil lambda-list-p) + (generic-function-class 'standard-generic-function gf-class-p) + &allow-other-keys) + #+copy-&rest-arg (setq all-keys (copy-list all-keys)) + (real-ensure-gf-internal generic-function-class all-keys environment) + (unless (or (null gf-class-p) + (eq (class-of existing) generic-function-class)) + (change-class existing generic-function-class)) + (prog1 + (apply #'reinitialize-instance existing all-keys) + (when lambda-list-p + (proclaim-defgeneric function-specifier lambda-list)))) + +(defun real-ensure-gf-using-class--null + (existing + function-specifier + &rest all-keys + &key environment (lambda-list nil lambda-list-p) + (generic-function-class 'standard-generic-function) + &allow-other-keys) + (declare (ignore existing)) + #+copy-&rest-arg (setq all-keys (copy-list all-keys)) + (real-ensure-gf-internal generic-function-class all-keys environment) + (prog1 + (setf (gdefinition function-specifier) + (apply #'make-instance generic-function-class + :name function-specifier all-keys)) + (when lambda-list-p + (proclaim-defgeneric function-specifier lambda-list)))) + + + +(defun get-generic-function-info (gf) + ;; values nreq applyp metatypes nkeys arg-info + (multiple-value-bind (applyp metatypes arg-info) + (let* ((arg-info (if (early-gf-p gf) + (early-gf-arg-info gf) + (gf-arg-info gf))) + (metatypes (arg-info-metatypes arg-info))) + (values (arg-info-applyp arg-info) + metatypes + arg-info)) + (values (length metatypes) applyp metatypes + (count-if #'(lambda (x) (neq x 't)) metatypes) + arg-info))) + +(defun early-make-a-method (class qualifiers arglist specializers initargs doc + &optional slot-name) + (initialize-method-function initargs) + (let ((parsed ()) + (unparsed ())) + ;; Figure out whether we got class objects or class names as the + ;; specializers and set parsed and unparsed appropriately. If we + ;; got class objects, then we can compute unparsed, but if we got + ;; class names we don't try to compute parsed. + ;; + ;; Note that the use of not symbolp in this call to every should be + ;; read as 'classp' we can't use classp itself because it doesn't + ;; exist yet. + (if (every #'(lambda (s) (not (symbolp s))) specializers) + (setq parsed specializers + unparsed (mapcar #'(lambda (s) + (if (eq s 't) 't (class-name s))) + specializers)) + (setq unparsed specializers + parsed ())) + (list :early-method ;This is an early method dammit! + + (getf initargs ':function) + (getf initargs ':fast-function) + + parsed ;The parsed specializers. This is used + ;by early-method-specializers to cache + ;the parse. Note that this only comes + ;into play when there is more than one + ;early method on an early gf. + + (list class ;A list to which real-make-a-method + qualifiers ;can be applied to make a real method + arglist ;corresponding to this early one. + unparsed + initargs + doc + slot-name) + ))) + +(defun real-make-a-method + (class qualifiers lambda-list specializers initargs doc + &optional slot-name) + (setq specializers (parse-specializers specializers)) + (apply #'make-instance class + :qualifiers qualifiers + :lambda-list lambda-list + :specializers specializers + :documentation doc + :slot-name slot-name + :allow-other-keys t + initargs)) + +(defun early-method-function (early-method) + (values (cadr early-method) (caddr early-method))) + +(defun early-method-class (early-method) + (find-class (car (fifth early-method)))) + +(defun early-method-standard-accessor-p (early-method) + (let ((class (first (fifth early-method)))) + (or (eq class 'standard-reader-method) + (eq class 'standard-writer-method) + (eq class 'standard-boundp-method)))) + +(defun early-method-standard-accessor-slot-name (early-method) + (seventh (fifth early-method))) + +;;; +;;; Fetch the specializers of an early method. This is basically just a +;;; simple accessor except that when the second argument is t, this converts +;;; the specializers from symbols into class objects. The class objects +;;; are cached in the early method, this makes bootstrapping faster because +;;; the class objects only have to be computed once. +;;; NOTE: +;;; the second argument should only be passed as T by early-lookup-method. +;;; this is to implement the rule that only when there is more than one +;;; early method on a generic function is the conversion from class names +;;; to class objects done. +;;; the corresponds to the fact that we are only allowed to have one method +;;; on any generic function up until the time classes exist. +;;; +(defun early-method-specializers (early-method &optional objectsp) + (if (and (listp early-method) + (eq (car early-method) :early-method)) + (cond ((eq objectsp 't) + (or (fourth early-method) + (setf (fourth early-method) + (mapcar #'find-class (cadddr (fifth early-method)))))) + (t + (cadddr (fifth early-method)))) + (error "~S is not an early-method." early-method))) + +(defun early-method-qualifiers (early-method) + (cadr (fifth early-method))) + +(defun early-method-lambda-list (early-method) + (caddr (fifth early-method))) + +(defun early-add-named-method (generic-function-name + qualifiers + specializers + arglist + &rest initargs) + #+copy-&rest-arg (setq initargs (copy-list initargs)) + (let* ((gf (ensure-generic-function generic-function-name)) + (existing + (dolist (m (early-gf-methods gf)) + (when (and (equal (early-method-specializers m) specializers) + (equal (early-method-qualifiers m) qualifiers)) + (return m)))) + (new (make-a-method 'standard-method + qualifiers + arglist + specializers + initargs + ()))) + (when existing (remove-method gf existing)) + (add-method gf new))) + +;;; +;;; This is the early version of add-method. Later this will become a +;;; generic function. See fix-early-generic-functions which has special +;;; knowledge about add-method. +;;; +(defun add-method (generic-function method) + (when (not (fsc-instance-p generic-function)) + (error "Early add-method didn't get a funcallable instance.")) + (when (not (and (listp method) (eq (car method) :early-method))) + (error "Early add-method didn't get an early method.")) + (push method (early-gf-methods generic-function)) + (set-arg-info generic-function :new-method method) + (unless (assoc (early-gf-name generic-function) *generic-function-fixups* + :test #'equal) + (update-dfun generic-function))) + +;;; +;;; This is the early version of remove method. +;;; +(defun remove-method (generic-function method) + (when (not (fsc-instance-p generic-function)) + (error "Early remove-method didn't get a funcallable instance.")) + (when (not (and (listp method) (eq (car method) :early-method))) + (error "Early remove-method didn't get an early method.")) + (setf (early-gf-methods generic-function) + (remove method (early-gf-methods generic-function))) + (set-arg-info generic-function) + (unless (assoc (early-gf-name generic-function) *generic-function-fixups* + :test #'equal) + (update-dfun generic-function))) + +;;; +;;; And the early version of get-method. +;;; +(defun get-method (generic-function qualifiers specializers + &optional (errorp t)) + (if (early-gf-p generic-function) + (or (dolist (m (early-gf-methods generic-function)) + (when (and (or (equal (early-method-specializers m nil) + specializers) + (equal (early-method-specializers m 't) + specializers)) + (equal (early-method-qualifiers m) qualifiers)) + (return m))) + (if errorp + (error "Can't get early method.") + nil)) + (real-get-method generic-function qualifiers specializers errorp))) + +(defvar *fegf-debug-p* nil) + +(defun fix-early-generic-functions (&optional (noisyp *fegf-debug-p*)) + (setq *fegf-started-p* t) + (let ((accessors nil)) + ;; Rearrange *early-generic-functions* to speed up fix-early-generic-functions. + (dolist (early-gf-spec *early-generic-functions*) + (when (every #'early-method-standard-accessor-p + (early-gf-methods (gdefinition early-gf-spec))) + (push early-gf-spec accessors))) + (dolist (spec (nconc accessors + '(accessor-method-slot-name + generic-function-methods + method-specializers + specializerp + specializer-type + specializer-class + slot-definition-location + slot-definition-name + class-slots + gf-arg-info + class-precedence-list + slot-boundp-using-class + (setf slot-value-using-class) + slot-value-using-class + structure-class-p + standard-class-p + funcallable-standard-class-p + specializerp))) + (setq *early-generic-functions* + (cons spec (delete spec *early-generic-functions* :test #'equal)))) + + (dolist (early-gf-spec *early-generic-functions*) + (when noisyp (format t "~&~S..." early-gf-spec)) + (let* ((gf (gdefinition early-gf-spec)) + (methods (mapcar #'(lambda (early-method) + (let ((args (copy-list (fifth early-method)))) + (setf (fourth args) + (early-method-specializers early-method t)) + (apply #'real-make-a-method args))) + (early-gf-methods gf)))) + (setf (generic-function-method-class gf) *the-class-standard-method*) + (setf (generic-function-method-combination gf) *standard-method-combination*) + (set-methods gf methods))) + + (dolist (fns *early-functions*) + (setf (gdefinition (car fns)) (symbol-function (caddr fns)))) + + (dolist (fixup *generic-function-fixups*) + (let* ((fspec (car fixup)) + (gf (gdefinition fspec)) + (methods (mapcar #'(lambda (method) + (let* ((lambda-list (first method)) + (specializers (second method)) + (method-fn-name (third method)) + (fn-name (or method-fn-name fspec)) + (fn (symbol-function fn-name)) + (initargs + (list :function + (set-function-name + #'(lambda (args next-methods) + (declare (ignore next-methods)) + (apply fn args)) + `(call ,fn-name))))) + (declare (type function fn)) + (make-a-method 'standard-method + () + lambda-list + specializers + initargs + nil))) + (cdr fixup)))) + (setf (generic-function-method-class gf) *the-class-standard-method*) + (setf (generic-function-method-combination gf) *standard-method-combination*) + (set-methods gf methods))))) + + +;;; +;;; parse-defmethod is used by defmethod to parse the &rest argument into +;;; the 'real' arguments. This is where the syntax of defmethod is really +;;; implemented. +;;; +(defun parse-defmethod (cdr-of-form) + ;;(declare (values name qualifiers specialized-lambda-list body)) + (let ((name (pop cdr-of-form)) + (qualifiers ()) + (spec-ll ())) + (loop (if (and (car cdr-of-form) (atom (car cdr-of-form))) + (push (pop cdr-of-form) qualifiers) + (return (setq qualifiers (nreverse qualifiers))))) + (setq spec-ll (pop cdr-of-form)) + (values name qualifiers spec-ll cdr-of-form))) + +(defun parse-specializers (specializers) + (flet ((parse (spec) + (let ((result (specializer-from-type spec))) + (if (specializerp result) + result + (if (symbolp spec) + (error "~S used as a specializer,~%~ + but is not the name of a class." + spec) + (error "~S is not a legal specializer." spec)))))) + (mapcar #'parse specializers))) + +(defun unparse-specializers (specializers-or-method) + (if (listp specializers-or-method) + (flet ((unparse (spec) + (if (specializerp spec) + (let ((type (specializer-type spec))) + (if (and (consp type) + (eq (car type) 'class)) + (let* ((class (cadr type)) + (class-name (class-name class))) + (if (eq class (find-class class-name nil)) + class-name + type)) + type)) + (error "~S is not a legal specializer." spec)))) + (mapcar #'unparse specializers-or-method)) + (unparse-specializers (method-specializers specializers-or-method)))) + +(defun parse-method-or-spec (spec &optional (errorp t)) + ;;(declare (values generic-function method method-name)) + (let (gf method name temp) + (if (method-p spec) + (setq method spec + gf (method-generic-function method) + temp (and gf (generic-function-name gf)) + name (if temp + (intern-function-name + (make-method-spec temp + (method-qualifiers method) + (unparse-specializers + (method-specializers method)))) + (make-symbol (format nil "~S" method)))) + (multiple-value-bind (gf-spec quals specls) + (parse-defmethod spec) + (and (setq gf (and (or errorp (gboundp gf-spec)) + (gdefinition gf-spec))) + (let ((nreq (compute-discriminating-function-arglist-info gf))) + (setq specls (append (parse-specializers specls) + (make-list (- nreq (length specls)) + :initial-element + *the-class-t*))) + (and + (setq method (get-method gf quals specls errorp)) + (setq name + (intern-function-name (make-method-spec gf-spec + quals + specls)))))))) + (values gf method name))) + + + +(defun extract-parameters (specialized-lambda-list) + (multiple-value-bind (parameters ignore1 ignore2) + (parse-specialized-lambda-list specialized-lambda-list) + (declare (ignore ignore1 ignore2)) + parameters)) + +(defun extract-lambda-list (specialized-lambda-list) + (multiple-value-bind (ignore1 lambda-list ignore2) + (parse-specialized-lambda-list specialized-lambda-list) + (declare (ignore ignore1 ignore2)) + lambda-list)) + +(defun extract-specializer-names (specialized-lambda-list) + (multiple-value-bind (ignore1 ignore2 specializers) + (parse-specialized-lambda-list specialized-lambda-list) + (declare (ignore ignore1 ignore2)) + specializers)) + +(defun extract-required-parameters (specialized-lambda-list) + (multiple-value-bind (ignore1 ignore2 ignore3 required-parameters) + (parse-specialized-lambda-list specialized-lambda-list) + (declare (ignore ignore1 ignore2 ignore3)) + required-parameters)) + +(defun parse-specialized-lambda-list (arglist &optional post-keyword) + ;;(declare (values parameters lambda-list specializers required-parameters)) + (let ((arg (car arglist))) + (cond ((null arglist) (values nil nil nil nil)) + ((eq arg '&aux) + (values nil arglist nil)) + ((memq arg lambda-list-keywords) + (unless (memq arg '(&optional &rest &key &allow-other-keys &aux)) + ;; Warn about non-standard lambda-list-keywords, but then + ;; go on to treat them like a standard lambda-list-keyword + ;; what with the warning its probably ok. + (warn "Unrecognized lambda-list keyword ~S in arglist.~%~ + Assuming that the symbols following it are parameters,~%~ + and not allowing any parameter specializers to follow~%~ + to follow it." + arg)) + ;; When we are at a lambda-list-keyword, the parameters don't + ;; include the lambda-list-keyword; the lambda-list does include + ;; the lambda-list-keyword; and no specializers are allowed to + ;; follow the lambda-list-keywords (at least for now). + (multiple-value-bind (parameters lambda-list) + (parse-specialized-lambda-list (cdr arglist) t) + (values parameters + (cons arg lambda-list) + () + ()))) + (post-keyword + ;; After a lambda-list-keyword there can be no specializers. + (multiple-value-bind (parameters lambda-list) + (parse-specialized-lambda-list (cdr arglist) t) + (values (cons (if (listp arg) (car arg) arg) parameters) + (cons arg lambda-list) + () + ()))) + (t + (multiple-value-bind (parameters lambda-list specializers required) + (parse-specialized-lambda-list (cdr arglist)) + (values (cons (if (listp arg) (car arg) arg) parameters) + (cons (if (listp arg) (car arg) arg) lambda-list) + (cons (if (listp arg) (cadr arg) 't) specializers) + (cons (if (listp arg) (car arg) arg) required))))))) + + +(eval-when (load eval) + (setq *boot-state* 'early)) + + +#-cmu ;; CMUCL Has a real symbol-macrolet +(progn +(defmacro symbol-macrolet (bindings &body body &environment env) + (let ((specs (mapcar #'(lambda (binding) + (list (car binding) + (variable-lexical-p (car binding) env) + (cadr binding))) + bindings))) + (walk-form `(progn ,@body) + env + #'(lambda (f c e) + (expand-symbol-macrolet-internal specs f c e))))) + +(defun expand-symbol-macrolet-internal (specs form context env) + (let ((entry nil)) + (cond ((not (eq context :eval)) form) + ((symbolp form) + (if (and (setq entry (assoc form specs)) + (eq (cadr entry) (variable-lexical-p form env))) + (caddr entry) + form)) + ((not (listp form)) form) + ((member (car form) '(setq setf)) + ;; Have to be careful. We must only convert the form to a SETF + ;; form when we convert one of the 'logical' variables to a form + ;; Otherwise we will get looping in implementations where setf + ;; is a macro which expands into setq. + (let ((kind (car form))) + (labels ((scan-setf (tail) + (if (null tail) + nil + (walker::relist* + tail + (if (and (setq entry (assoc (car tail) specs)) + (eq (cadr entry) + (variable-lexical-p (car tail) + env))) + (progn (setq kind 'setf) + (caddr entry)) + (car tail)) + (cadr tail) + (scan-setf (cddr tail)))))) + (let (new-tail) + (setq new-tail (scan-setf (cdr form))) + (walker::recons form kind new-tail))))) + ((eq (car form) 'multiple-value-setq) + (let* ((vars (cadr form)) + (gensyms (mapcar #'(lambda (i) (declare (ignore i)) (gensym)) + vars))) + `(multiple-value-bind ,gensyms + ,(caddr form) + .,(reverse (mapcar #'(lambda (v g) `(setf ,v ,g)) + vars + gensyms))))) + (t form)))) +) + +(defmacro with-slots (slots instance &body body) + (let ((in (gensym))) + `(let ((,in ,instance)) + #+cmu (declare (ignorable ,in)) + ,@(let ((instance (if (and (consp instance) (eq (car instance) 'the)) + (third instance) + instance))) + (and (symbolp instance) + `((declare (variable-rebinding ,in ,instance))))) + ,in + (symbol-macrolet ,(mapcar #'(lambda (slot-entry) + (let ((variable-name + (if (symbolp slot-entry) + slot-entry + (car slot-entry))) + (slot-name + (if (symbolp slot-entry) + slot-entry + (cadr slot-entry)))) + `(,variable-name + (slot-value ,in ',slot-name)))) + slots) + ,@body)))) + +(defmacro with-accessors (slots instance &body body) + (let ((in (gensym))) + `(let ((,in ,instance)) + #+cmu (declare (ignorable ,in)) + ,@(let ((instance (if (and (consp instance) (eq (car instance) 'the)) + (third instance) + instance))) + (and (symbolp instance) + `((declare (variable-rebinding ,in ,instance))))) + ,in + (symbol-macrolet ,(mapcar #'(lambda (slot-entry) + (let ((variable-name (car slot-entry)) + (accessor-name (cadr slot-entry))) + `(,variable-name + (,accessor-name ,in)))) + slots) + ,@body)))) + + + diff --git a/pcl/gcl_pcl_braid.lisp b/pcl/gcl_pcl_braid.lisp new file mode 100644 index 0000000..fe03ca0 --- /dev/null +++ b/pcl/gcl_pcl_braid.lisp @@ -0,0 +1,760 @@ +;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; +;;; Bootstrapping the meta-braid. +;;; +;;; The code in this file takes the early definitions that have been saved +;;; up and actually builds those class objects. This work is largely driven +;;; off of those class definitions, but the fact that STANDARD-CLASS is the +;;; class of all metaclasses in the braid is built into this code pretty +;;; deeply. +;;; +;;; + +(in-package :pcl) + +(defun allocate-standard-instance (wrapper &optional (slots-init nil slots-init-p)) + #-new-kcl-wrapper (declare (special *slot-unbound*)) + #-new-kcl-wrapper + (let ((instance (%%allocate-instance--class))) + (setf (std-instance-wrapper instance) wrapper) + (setf (std-instance-slots instance) + (if slots-init-p + (copy-slots slots-init) + (make-array (wrapper-no-of-instance-slots wrapper) + :initial-element *slot-unbound*))) + instance) + #+new-kcl-wrapper + (apply #'si:make-structure wrapper + (if slots-init-p + slots-init + (let ((no-of-slots (si::s-data-length wrapper))) + (if (< no-of-slots (fill-pointer *init-vector*)) + (aref *init-vector* no-of-slots) + (get-init-list no-of-slots)))))) + +(defmacro allocate-funcallable-instance-slots (wrapper &optional + slots-init-p slots-init) + #-new-kcl-wrapper + `(let ((no-of-slots (wrapper-no-of-instance-slots ,wrapper))) + ,(if slots-init-p + `(if ,slots-init-p + (copy-slots ,slots-init) + (make-array no-of-slots :initial-element *slot-unbound*)) + `(make-array no-of-slots :initial-element *slot-unbound*))) + #+new-kcl-wrapper + (if slots-init-p + `(if ,slots-init-p + (allocate-standard-instance ,wrapper ,slots-init) + (allocate-standard-instance ,wrapper)) + `(allocate-standard-instance ,wrapper))) + +(defun allocate-funcallable-instance (wrapper &optional (slots-init nil slots-init-p)) + (let ((fin (allocate-funcallable-instance-1))) + (set-funcallable-instance-function + fin + (fin-lambda-fn (&rest args) + (declare (ignore args)) + (error "The function of the funcallable-instance ~S has not been set" fin))) + (setf (fsc-instance-wrapper fin) wrapper + (fsc-instance-slots fin) (allocate-funcallable-instance-slots + wrapper slots-init-p slots-init)) + fin)) + +(defun allocate-structure-instance (wrapper &optional (slots-init nil slots-init-p)) + #-new-kcl-wrapper + (let* ((class (wrapper-class wrapper)) + (constructor (class-defstruct-constructor class))) + (if constructor + (let ((instance (funcall constructor)) + (slots (class-slots class))) + (when slots-init-p + (dotimes (i (length slots-init)) + (let ((slot (pop slots))) + (setf (slot-value-using-class class instance slot) + (svref slots-init i))))) + instance) + (error "Can't allocate an instance of class ~S" (class-name class)))) + #+new-kcl-wrapper + (if slots-init-p + (allocate-standard-instance wrapper slots-init) + (allocate-standard-instance wrapper))) + +;;; +;;; bootstrap-meta-braid +;;; +;;; This function builds the base metabraid from the early class definitions. +;;; +(defmacro initial-classes-and-wrappers (&rest classes) + `(progn + ,@(mapcar #'(lambda (class) + (let ((wr (intern (format nil "~A-WRAPPER" class) + *the-pcl-package*))) + `(setf ,wr ,(if (eq class 'standard-generic-function) + '*sgf-wrapper* + #-cmu17 + `(make-wrapper (early-class-size ',class)) + #+cmu17 + `(boot-make-wrapper + (early-class-size ',class) + ',class)) + ,class (allocate-standard-instance + ,(if (eq class 'standard-generic-function) + 'funcallable-standard-class-wrapper + 'standard-class-wrapper)) + (wrapper-class ,wr) ,class + #+new-kcl-wrapper (si::s-data-name ,wr) + #+new-kcl-wrapper ',class + (find-class ',class) ,class))) + classes))) + +(defun bootstrap-meta-braid () + (let* ((name 'class) + (predicate-name (make-type-predicate-name name))) + (setf (gdefinition predicate-name) + #'(lambda (x) (declare (ignore x)) t)) + (do-satisfies-deftype name predicate-name)) + (let* ((*create-classes-from-internal-structure-definitions-p* nil) + standard-class-wrapper standard-class + funcallable-standard-class-wrapper funcallable-standard-class + slot-class-wrapper slot-class + built-in-class-wrapper built-in-class + structure-class-wrapper structure-class + standard-direct-slot-definition-wrapper standard-direct-slot-definition + standard-effective-slot-definition-wrapper standard-effective-slot-definition + class-eq-specializer-wrapper class-eq-specializer + standard-generic-function-wrapper standard-generic-function) + (initial-classes-and-wrappers + standard-class funcallable-standard-class + slot-class built-in-class structure-class + standard-direct-slot-definition standard-effective-slot-definition + class-eq-specializer standard-generic-function) + ;; + ;; First, make a class metaobject for each of the early classes. For + ;; each metaobject we also set its wrapper. Except for the class T, + ;; the wrapper is always that of STANDARD-CLASS. + ;; + (dolist (definition *early-class-definitions*) + (let* ((name (ecd-class-name definition)) + (meta (ecd-metaclass definition)) + (wrapper (ecase meta + (slot-class slot-class-wrapper) + (standard-class standard-class-wrapper) + (funcallable-standard-class funcallable-standard-class-wrapper) + (built-in-class built-in-class-wrapper) + (structure-class structure-class-wrapper))) + (class (or (find-class name nil) + (allocate-standard-instance wrapper)))) + (when (or (eq meta 'standard-class) (eq meta 'funcallable-standard-class)) + (inform-type-system-about-std-class name)) + (setf (find-class name) class))) + ;; + ;; + ;; + (dolist (definition *early-class-definitions*) + (let ((name (ecd-class-name definition)) + (meta (ecd-metaclass definition)) + (source (ecd-source definition)) + (direct-supers (ecd-superclass-names definition)) + (direct-slots (ecd-canonical-slots definition)) + (other-initargs (ecd-other-initargs definition))) + (let ((direct-default-initargs + (getf other-initargs :direct-default-initargs))) + (multiple-value-bind (slots cpl default-initargs direct-subclasses) + (early-collect-inheritance name) + (let* ((class (find-class name)) + (wrapper (cond ((eq class slot-class) + slot-class-wrapper) + ((eq class standard-class) + standard-class-wrapper) + ((eq class funcallable-standard-class) + funcallable-standard-class-wrapper) + ((eq class standard-direct-slot-definition) + standard-direct-slot-definition-wrapper) + ((eq class standard-effective-slot-definition) + standard-effective-slot-definition-wrapper) + ((eq class built-in-class) + built-in-class-wrapper) + ((eq class structure-class) + structure-class-wrapper) + ((eq class class-eq-specializer) + class-eq-specializer-wrapper) + ((eq class standard-generic-function) + standard-generic-function-wrapper) + (t + #-cmu17 + (make-wrapper (length slots) class) + #+cmu17 + (boot-make-wrapper (length slots) name)))) + (proto nil)) + (when (eq name 't) (setq *the-wrapper-of-t* wrapper)) + (set (intern (format nil "*THE-CLASS-~A*" (symbol-name name)) + *the-pcl-package*) + class) + (dolist (slot slots) + (unless (eq (getf slot :allocation :instance) :instance) + (error "Slot allocation ~S not supported in bootstrap."))) + + (when #+cmu17 (typep wrapper 'wrapper) #-cmu17 t + (setf (wrapper-instance-slots-layout wrapper) + (mapcar #'canonical-slot-name slots)) + (setf (wrapper-class-slots wrapper) + ())) + + (setq proto (if (eq meta 'funcallable-standard-class) + (allocate-funcallable-instance wrapper) + (allocate-standard-instance wrapper))) + + (setq direct-slots + (bootstrap-make-slot-definitions + name class direct-slots + standard-direct-slot-definition-wrapper nil)) + (setq slots + (bootstrap-make-slot-definitions + name class slots + standard-effective-slot-definition-wrapper t)) + + (case meta + ((standard-class funcallable-standard-class) + (bootstrap-initialize-class + meta + class name class-eq-specializer-wrapper source + direct-supers direct-subclasses cpl wrapper proto + direct-slots slots direct-default-initargs default-initargs)) + (built-in-class ; *the-class-t* + (bootstrap-initialize-class + meta + class name class-eq-specializer-wrapper source + direct-supers direct-subclasses cpl wrapper proto)) + (slot-class ; *the-class-slot-object* + (bootstrap-initialize-class + meta + class name class-eq-specializer-wrapper source + direct-supers direct-subclasses cpl wrapper proto)) + (structure-class ; *the-class-structure-object* + (bootstrap-initialize-class + meta + class name class-eq-specializer-wrapper source + direct-supers direct-subclasses cpl wrapper)))))))) + + (let* ((smc-class (find-class 'standard-method-combination)) + (smc-wrapper (bootstrap-get-slot 'standard-class smc-class 'wrapper)) + (smc (allocate-standard-instance smc-wrapper))) + (flet ((set-slot (name value) + (bootstrap-set-slot 'standard-method-combination smc name value))) + (set-slot 'source (load-truename)) + (set-slot 'type 'standard) + (set-slot 'documentation "The standard method combination.") + (set-slot 'options ())) + (setq *standard-method-combination* smc)))) + +;;; +;;; Initialize a class metaobject. +;;; +(defun bootstrap-initialize-class + (metaclass-name class name + class-eq-wrapper source direct-supers direct-subclasses cpl wrapper + &optional proto direct-slots slots direct-default-initargs default-initargs) + (flet ((classes (names) (mapcar #'find-class names)) + (set-slot (slot-name value) + (bootstrap-set-slot metaclass-name class slot-name value))) + (set-slot 'name name) + (set-slot 'source source) + (set-slot 'type (if (eq class (find-class 't)) + t + `(class ,class))) + (set-slot 'class-eq-specializer + (let ((spec (allocate-standard-instance class-eq-wrapper))) + (bootstrap-set-slot 'class-eq-specializer spec 'type + `(class-eq ,class)) + (bootstrap-set-slot 'class-eq-specializer spec 'object + class) + spec)) + (set-slot 'class-precedence-list (classes cpl)) + (set-slot 'can-precede-list (classes (cdr cpl))) + (set-slot 'incompatible-superclass-list nil) + (set-slot 'direct-superclasses (classes direct-supers)) + (set-slot 'direct-subclasses (classes direct-subclasses)) + (set-slot 'direct-methods (cons nil nil)) + (set-slot 'wrapper wrapper) + #+new-kcl-wrapper + (setf (si::s-data-name wrapper) name) + (set-slot 'predicate-name (or (cadr (assoc name *early-class-predicates*)) + (make-class-predicate-name name))) + (set-slot 'plist + `(,@(and direct-default-initargs + `(direct-default-initargs ,direct-default-initargs)) + ,@(and default-initargs + `(default-initargs ,default-initargs)))) + (when (memq metaclass-name '(standard-class funcallable-standard-class + structure-class slot-class)) + (set-slot 'direct-slots direct-slots) + (set-slot 'slots slots) + (set-slot 'initialize-info nil)) + (if (eq metaclass-name 'structure-class) + (let ((constructor-sym '|STRUCTURE-OBJECT class constructor|)) + (set-slot 'predicate-name (or (cadr (assoc name *early-class-predicates*)) + (make-class-predicate-name name))) + (set-slot 'defstruct-form + `(defstruct (structure-object (:constructor ,constructor-sym)))) + (set-slot 'defstruct-constructor constructor-sym) + (set-slot 'from-defclass-p t) + (set-slot 'plist nil) + (set-slot 'prototype (funcall constructor-sym))) + (set-slot 'prototype (or proto (allocate-standard-instance wrapper)))) + class)) + +(defun bootstrap-make-slot-definitions (name class slots wrapper effective-p) + (let ((index -1)) + (mapcar #'(lambda (slot) + (incf index) + (bootstrap-make-slot-definition + name class slot wrapper effective-p index)) + slots))) + +(defun bootstrap-make-slot-definition (name class slot wrapper effective-p index) + (let* ((slotd-class-name (if effective-p + 'standard-effective-slot-definition + 'standard-direct-slot-definition)) + (slotd (allocate-standard-instance wrapper)) + (slot-name (getf slot :name))) + (flet ((get-val (name) (getf slot name)) + (set-val (name val) (bootstrap-set-slot slotd-class-name slotd name val))) + (set-val 'name slot-name) + (set-val 'initform (get-val :initform)) + (set-val 'initfunction (get-val :initfunction)) + (set-val 'initargs (get-val :initargs)) + (set-val 'readers (get-val :readers)) + (set-val 'writers (get-val :writers)) + (set-val 'allocation :instance) + (set-val 'type (or (get-val :type) t)) + (set-val 'documentation (or (get-val :documentation) "")) + (set-val 'class class) + (when effective-p + (set-val 'location index) + (let ((fsc-p nil)) + (set-val 'reader-function (make-optimized-std-reader-method-function + fsc-p slot-name index)) + (set-val 'writer-function (make-optimized-std-writer-method-function + fsc-p slot-name index)) + (set-val 'boundp-function (make-optimized-std-boundp-method-function + fsc-p slot-name index))) + (set-val 'accessor-flags 7) + (let ((table (or (gethash slot-name *name->class->slotd-table*) + (setf (gethash slot-name *name->class->slotd-table*) + (make-hash-table :test 'eq :size 5))))) + (setf (gethash class table) slotd))) + (when (and (eq name 'standard-class) + (eq slot-name 'slots) effective-p) + (setq *the-eslotd-standard-class-slots* slotd)) + (when (and (eq name 'funcallable-standard-class) + (eq slot-name 'slots) effective-p) + (setq *the-eslotd-funcallable-standard-class-slots* slotd)) + slotd))) + +(defun bootstrap-accessor-definitions (early-p) + (let ((*early-p* early-p)) + (dolist (definition *early-class-definitions*) + (let ((name (ecd-class-name definition)) + (meta (ecd-metaclass definition))) + (unless (eq meta 'built-in-class) + (let ((direct-slots (ecd-canonical-slots definition))) + (dolist (slotd direct-slots) + (let ((slot-name (getf slotd :name)) + (readers (getf slotd :readers)) + (writers (getf slotd :writers))) + (bootstrap-accessor-definitions1 name slot-name readers writers nil) + (bootstrap-accessor-definitions1 + 'slot-object + slot-name + (list (slot-reader-symbol slot-name)) + (list (slot-writer-symbol slot-name)) + (list (slot-boundp-symbol slot-name))))))))))) + +(defun bootstrap-accessor-definition (class-name accessor-name slot-name type) + (multiple-value-bind (accessor-class make-method-function arglist specls doc) + (ecase type + (reader (values 'standard-reader-method #'make-std-reader-method-function + (list class-name) (list class-name) + "automatically generated reader method")) + (writer (values 'standard-writer-method #'make-std-writer-method-function + (list 'new-value class-name) (list 't class-name) + "automatically generated writer method")) + (boundp (values 'standard-boundp-method #'make-std-boundp-method-function + (list class-name) (list class-name) + "automatically generated boundp method"))) + (let ((gf (ensure-generic-function accessor-name))) + (if (find specls (early-gf-methods gf) + :key #'early-method-specializers + :test #'equal) + (unless (assoc accessor-name *generic-function-fixups* + :test #'equal) + (update-dfun gf)) + (add-method gf + (make-a-method accessor-class + () + arglist specls + (funcall make-method-function + class-name slot-name) + doc + slot-name)))))) + +(defun bootstrap-accessor-definitions1 (class-name slot-name readers writers boundps) + (flet ((do-reader-definition (reader) + (bootstrap-accessor-definition class-name reader slot-name 'reader)) + (do-writer-definition (writer) + (bootstrap-accessor-definition class-name writer slot-name 'writer)) + (do-boundp-definition (boundp) + (bootstrap-accessor-definition class-name boundp slot-name 'boundp))) + (dolist (reader readers) (do-reader-definition reader)) + (dolist (writer writers) (do-writer-definition writer)) + (dolist (boundp boundps) (do-boundp-definition boundp)))) + +(defun bootstrap-class-predicates (early-p) + (let ((*early-p* early-p)) + (dolist (definition *early-class-definitions*) + (let* ((name (ecd-class-name definition)) + (class (find-class name))) + (setf (find-class-predicate name) + (make-class-predicate class (class-predicate-name class))))))) + +(defun bootstrap-built-in-classes () + ;; + ;; First make sure that all the supers listed in *built-in-class-lattice* + ;; are themselves defined by *built-in-class-lattice*. This is just to + ;; check for typos and other sorts of brainos. + ;; + (dolist (e *built-in-classes*) + (dolist (super (cadr e)) + (unless (or (eq super 't) + (assq super *built-in-classes*)) + (error "In *built-in-classes*: ~S has ~S as a super,~%~ + but ~S is not itself a class in *built-in-classes*." + (car e) super super)))) + + ;; + ;; In the first pass, we create a skeletal object to be bound to the + ;; class name. + ;; + (let* ((built-in-class (find-class 'built-in-class)) + (built-in-class-wrapper (class-wrapper built-in-class))) + (dolist (e *built-in-classes*) + (let ((class (allocate-standard-instance built-in-class-wrapper))) + (setf (find-class (car e)) class)))) + + ;; + ;; In the second pass, we initialize the class objects. + ;; + (let ((class-eq-wrapper (class-wrapper (find-class 'class-eq-specializer)))) + (dolist (e *built-in-classes*) + ; FIXME use regular destructuring-bind + (pcl-destructuring-bind (name supers subs cpl prototype) e + (let* ((class (find-class name)) + #+cmu17 + (lclass (lisp:find-class name)) + (wrapper #-cmu17(make-wrapper 0 class) + #+cmu17(kernel:class-layout lclass))) + (set (get-built-in-class-symbol name) class) + (set (get-built-in-wrapper-symbol name) wrapper) + #+cmu17 + (setf (kernel:class-pcl-class lclass) class) + #-cmu17 + (setf (wrapper-instance-slots-layout wrapper) () + (wrapper-class-slots wrapper) ()) + + (bootstrap-initialize-class 'built-in-class class + name class-eq-wrapper nil + supers subs + (cons name cpl) + wrapper prototype))))) + + (dolist (e *built-in-classes*) + (let* ((name (car e)) + (class (find-class name))) + (setf (find-class-predicate name) + (make-class-predicate class (class-predicate-name class)))))) + + +;;; +;;; +;;; +#-(or new-kcl-wrapper cmu17) +(progn +(defvar *built-in-or-structure-wrapper-table* + (make-hash-table :test 'eq)) + +(defvar wft-type1 nil) +(defvar wft-wrapper1 nil) +(defvar wft-type2 nil) +(defvar wft-wrapper2 nil) + +(defun wrapper-for-structure (x) + (let ((type (structure-type x))) + (when (symbolp type) + (cond ((eq type 'std-instance) + (return-from wrapper-for-structure (std-instance-wrapper x))) + ((eq type wft-type1) (return-from wrapper-for-structure wft-wrapper1)) + ((eq type wft-type2) (return-from wrapper-for-structure wft-wrapper2)) + (t (setq wft-type2 wft-type1 wft-wrapper2 wft-wrapper1)))) + (let* ((cell (find-class-cell type)) + (class (or (find-class-cell-class cell) + (let* (#+lucid + (*structure-type* type) + #+lucid + (*structure-length* (structure-length x type))) + (find-class-from-cell type cell)))) + (wrapper (if class (class-wrapper class) *the-wrapper-of-t*))) + (when (symbolp type) + (setq wft-type1 type wft-wrapper1 wrapper)) + wrapper))) + +(defun built-in-or-structure-wrapper1 (x) + (let ((biw (or (built-in-wrapper-of x) *the-wrapper-of-t*))) + (or (and (eq biw *the-wrapper-of-t*) + (structurep x) + (let* ((type (type-of x)) + #+lucid + (*structure-type* type) + #+lucid + (*structure-length* (structure-length x type)) + (class (find-class type nil))) + (and class (class-wrapper class)))) + biw))) +) + +#|| ; moved to low.lisp +(defmacro built-in-or-structure-wrapper (x) + (once-only (x) + (if (structure-functions-exist-p) ; otherwise structurep is too slow for this + `(if (structurep ,x) + (wrapper-for-structure ,x) + (if (symbolp ,x) + (if ,x *the-wrapper-of-symbol* *the-wrapper-of-null*) + (built-in-wrapper-of ,x))) + `(or (and (symbolp ,x) + (if ,x *the-wrapper-of-symbol* *the-wrapper-of-null*)) + (built-in-or-structure-wrapper1 ,x))))) + +#-cmu17 +(defmacro wrapper-of-macro (x) + `(cond ((std-instance-p ,x) + (std-instance-wrapper ,x)) + ((fsc-instance-p ,x) + (fsc-instance-wrapper ,x)) + (t + (#+new-kcl-wrapper built-in-wrapper-of + #-new-kcl-wrapper built-in-or-structure-wrapper + ,x)))) + +#+cmu17 +(defmacro wrapper-of-macro (x) + `(kernel:layout-of ,x)) +||# + +(defun class-of (x) + (wrapper-class* (wrapper-of-macro x))) + +#+cmu17 +(declaim (inline wrapper-of)) +(defun wrapper-of (x) + (wrapper-of-macro x)) + +#-cmu17 +(defun structure-wrapper (x) + (class-wrapper (find-class (structure-type x)))) + +(defvar find-structure-class nil) + +(defun eval-form (form) + #'(lambda () (eval form))) + +(defun slot-initargs-from-structure-slotd (slotd) + `(:name ,(structure-slotd-name slotd) + :defstruct-accessor-symbol ,(structure-slotd-accessor-symbol slotd) + :internal-reader-function ,(structure-slotd-reader-function slotd) + :internal-writer-function ,(structure-slotd-writer-function slotd) + :type ,(or (structure-slotd-type slotd) t) + :initform ,(structure-slotd-init-form slotd) + :initfunction ,(eval-form (structure-slotd-init-form slotd)))) + +(defun find-structure-class (symbol) + (if (structure-type-p symbol) + (unless (eq find-structure-class symbol) + (let ((find-structure-class symbol)) + (ensure-class symbol + :metaclass 'structure-class + :name symbol + :direct-superclasses + (when (structure-type-included-type-name symbol) + (list (structure-type-included-type-name symbol))) + :direct-slots + (mapcar #'slot-initargs-from-structure-slotd + (structure-type-slot-description-list symbol))))) + (error "~S is not a legal structure class name." symbol))) + +#-cmu17 +(eval-when (compile eval) + +(defun make-built-in-class-subs () + (mapcar #'(lambda (e) + (let ((class (car e)) + (class-subs ())) + (dolist (s *built-in-classes*) + (when (memq class (cadr s)) (pushnew (car s) class-subs))) + (cons class class-subs))) + (cons '(t) *built-in-classes*))) + +(defun make-built-in-class-tree () + (let ((subs (make-built-in-class-subs))) + (labels ((descend (class) + (cons class (mapcar #'descend (cdr (assq class subs)))))) + (descend 't)))) + +(defun make-built-in-wrapper-of-body () + (make-built-in-wrapper-of-body-1 (make-built-in-class-tree) + 'x + #'get-built-in-wrapper-symbol)) + +(defun make-built-in-wrapper-of-body-1 (tree var get-symbol) + (let ((*specials* ())) + (declare (special *specials*)) + (let ((inner (make-built-in-wrapper-of-body-2 tree var get-symbol))) + `(locally (declare (special .,*specials*)) ,inner)))) + +(defun make-built-in-wrapper-of-body-2 (tree var get-symbol) + (declare (special *specials*)) + (let ((symbol (funcall get-symbol (car tree)))) + (push symbol *specials*) + (let ((sub-tests + (mapcar #'(lambda (x) + (make-built-in-wrapper-of-body-2 x var get-symbol)) + (cdr tree)))) + `(and (typep ,var ',(car tree)) + ,(if sub-tests + `(or ,.sub-tests ,symbol) + symbol))))) +) + +#-cmu17 +(defun built-in-wrapper-of (x) + #.(when (fboundp 'make-built-in-wrapper-of-body) ; so we can at least read this file + (make-built-in-wrapper-of-body))) + + + +(defun method-function-returning-nil (args next-methods) + (declare (ignore args next-methods)) + nil) + +(defun method-function-returning-t (args next-methods) + (declare (ignore args next-methods)) + t) + +(defun make-class-predicate (class name) + (let* ((gf (ensure-generic-function name)) + (mlist (if (eq *boot-state* 'complete) + (generic-function-methods gf) + (early-gf-methods gf)))) + (unless mlist + (unless (eq class *the-class-t*) + (let* ((default-method-function #'method-function-returning-nil) + (default-method-initargs (list :function + default-method-function)) + (default-method (make-a-method 'standard-method + () + (list 'object) + (list *the-class-t*) + default-method-initargs + "class predicate default method"))) + (setf (method-function-get default-method-function :constant-value) nil) + (add-method gf default-method))) + (let* ((class-method-function #'method-function-returning-t) + (class-method-initargs (list :function + class-method-function)) + (class-method (make-a-method 'standard-method + () + (list 'object) + (list class) + class-method-initargs + "class predicate class method"))) + (setf (method-function-get class-method-function :constant-value) t) + (add-method gf class-method))) + gf)) + + +#+cmu17 +;;; Set inherits from CPL and register layout. This actually installs the +;;; class in the lisp type system. +;;; +(defun update-lisp-class-layout (class layout) + (unless (eq (kernel:class-layout (kernel:layout-class layout)) + layout) + (setf (kernel:layout-inherits layout) + (map 'vector #'class-wrapper + (reverse (rest (class-precedence-list class))))) + + (kernel:register-layout layout :invalidate nil))) + +(eval-when (load eval) + (clrhash *find-class*) + (bootstrap-meta-braid) + (bootstrap-accessor-definitions t) + (bootstrap-class-predicates t) + (bootstrap-accessor-definitions nil) + (bootstrap-class-predicates nil) + (bootstrap-built-in-classes) + + #+cmu17 + (ext:do-hash (name x *find-class*) + (let* ((class (find-class-from-cell name x)) + (layout (class-wrapper class)) + (lclass (kernel:layout-class layout)) + (lclass-pcl-class (kernel:class-pcl-class lclass)) + (olclass (lisp:find-class name nil))) + (if lclass-pcl-class + (assert (eq class lclass-pcl-class)) + (setf (kernel:class-pcl-class lclass) class)) + + (update-lisp-class-layout class layout) + + (cond (olclass + (assert (eq lclass olclass))) + (t + (setf (lisp:find-class name) lclass))))) + + (setq *boot-state* 'braid) + ) + +#-cmu17 +(deftype slot-object () + '(or standard-object structure-object)) + +(defmethod no-applicable-method (generic-function &rest args) + (cerror "Retry call to ~S" + "No matching method for the generic-function ~S,~@ + when called with arguments ~S." + generic-function args) + (apply generic-function args)) diff --git a/pcl/gcl_pcl_cache.lisp b/pcl/gcl_pcl_cache.lisp new file mode 100644 index 0000000..160a2c7 --- /dev/null +++ b/pcl/gcl_pcl_cache.lisp @@ -0,0 +1,1689 @@ +;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; +;;; The basics of the PCL wrapper cache mechanism. +;;; + +(in-package :pcl) +;;; +;;; The caching algorithm implemented: +;;; +;;; << put a paper here >> +;;; +;;; For now, understand that as far as most of this code goes, a cache has +;;; two important properties. The first is the number of wrappers used as +;;; keys in each cache line. Throughout this code, this value is always +;;; called NKEYS. The second is whether or not the cache lines of a cache +;;; store a value. Throughout this code, this always called VALUEP. +;;; +;;; Depending on these values, there are three kinds of caches. +;;; +;;; NKEYS = 1, VALUEP = NIL +;;; +;;; In this kind of cache, each line is 1 word long. No cache locking is +;;; needed since all read's in the cache are a single value. Nevertheless +;;; line 0 (location 0) is reserved, to ensure that invalid wrappers will +;;; not get a first probe hit. +;;; +;;; To keep the code simpler, a cache lock count does appear in location 0 +;;; of these caches, that count is incremented whenever data is written to +;;; the cache. But, the actual lookup code (see make-dlap) doesn't need to +;;; do locking when reading the cache. +;;; +;;; +;;; NKEYS = 1, VALUEP = T +;;; +;;; In this kind of cache, each line is 2 words long. Cache locking must +;;; be done to ensure the synchronization of cache reads. Line 0 of the +;;; cache (location 0) is reserved for the cache lock count. Location 1 +;;; of the cache is unused (in effect wasted). +;;; +;;; NKEYS > 1 +;;; +;;; In this kind of cache, the 0 word of the cache holds the lock count. +;;; The 1 word of the cache is line 0. Line 0 of these caches is not +;;; reserved. +;;; +;;; This is done because in this sort of cache, the overhead of doing the +;;; cache probe is high enough that the 1+ required to offset the location +;;; is not a significant cost. In addition, because of the larger line +;;; sizes, the space that would be wasted by reserving line 0 to hold the +;;; lock count is more significant. +;;; + +;;; +;;; Caches +;;; +;;; A cache is essentially just a vector. The use of the individual `words' +;;; in the vector depends on particular properties of the cache as described +;;; above. +;;; +;;; This defines an abstraction for caches in terms of their most obvious +;;; implementation as simple vectors. But, please notice that part of the +;;; implementation of this abstraction, is the function lap-out-cache-ref. +;;; This means that most port-specific modifications to the implementation +;;; of caches will require corresponding port-specific modifications to the +;;; lap code assembler. +;;; +;; #+gcl(import 'si::non-negative-fixnum) + +(defmacro cache-vector-ref (cache-vector location) + `(svref (the simple-vector ,cache-vector) + (#-cmu the #+cmu ext:truly-the non-negative-fixnum ,location))) + +(defmacro cache-vector-size (cache-vector) + `(array-dimension (the simple-vector ,cache-vector) 0)) + +(defun allocate-cache-vector (size) + (make-array size :adjustable nil)) + +(defmacro cache-vector-lock-count (cache-vector) + `(cache-vector-ref ,cache-vector 0)) + +(defun flush-cache-vector-internal (cache-vector) + (without-interrupts + (fill (the simple-vector cache-vector) nil) + (setf (cache-vector-lock-count cache-vector) 0)) + cache-vector) + +;; FIXME 64 +(defconstant rand-base (- (ash 1 31) 1)) + +(defmacro modify-cache (cache-vector &body body) + `(without-interrupts + (multiple-value-prog1 + (progn ,@body) + (let ((old-count (cache-vector-lock-count ,cache-vector))) + (declare (type non-negative-fixnum old-count)) + (setf (cache-vector-lock-count ,cache-vector) + (if (= old-count rand-base) + 1 (the non-negative-fixnum (1+ old-count)))))))) + +(deftype field-type () + '(integer 0 ;#.(position 'number wrapper-layout) + 7)) ;#.(position 'number wrapper-layout :from-end t) + +(eval-when (compile load eval) +(defun power-of-two-ceiling (x) + (declare (type (and fixnum (integer 1 *)) x)) + ;;(expt 2 (ceiling (log x 2))) + (the non-negative-fixnum (ash 1 (integer-length (1- x))))) + +(defconstant *nkeys-limit* 255) +) + +(defstruct (cache + (:print-function print-cache) + (:constructor make-cache ()) + (:copier copy-cache-internal)) + (owner nil) + (nkeys 1 :type (integer 1 #.*nkeys-limit*)) + (valuep nil :type boolean) + (nlines 0 :type non-negative-fixnum) + (field 0 :type field-type) + (limit-fn #'default-limit-fn :type function) + (mask 0 :type non-negative-fixnum) + (size 0 :type non-negative-fixnum) + (line-size 1 :type (integer 1 #.(power-of-two-ceiling (1+ *nkeys-limit*)))) + (max-location 0 :type non-negative-fixnum) + (vector #() :type simple-vector) + (overflow nil :type list)) + +#+cmu +(declaim (ext:freeze-type cache)) + +(defun print-cache (cache stream depth) + (declare (ignore depth)) + (printing-random-thing (cache stream) + (format stream "cache ~D ~S ~D" + (cache-nkeys cache) (cache-valuep cache) (cache-nlines cache)))) + +#+akcl +(si::freeze-defstruct 'cache) + +(defmacro cache-lock-count (cache) + `(cache-vector-lock-count (cache-vector ,cache))) + + +;;; +;;; Some facilities for allocation and freeing caches as they are needed. +;;; This is done on the assumption that a better port of PCL will arrange +;;; to cons these all the same static area. Given that, the fact that +;;; PCL tries to reuse them should be a win. +;;; +(defvar *free-cache-vectors* (make-hash-table :size 16 :test 'eql)) + +;;; +;;; Return a cache that has had flush-cache-vector-internal called on it. This +;;; returns a cache of exactly the size requested, it won't ever return a +;;; larger cache. +;;; +(defun get-cache-vector (size) + (let ((entry (gethash size *free-cache-vectors*))) + (without-interrupts + (cond ((null entry) + (setf (gethash size *free-cache-vectors*) (cons 0 nil)) + (get-cache-vector size)) + ((null (cdr entry)) + (incf (car entry)) + (flush-cache-vector-internal (allocate-cache-vector size))) + (t + (let ((cache (cdr entry))) + (setf (cdr entry) (cache-vector-ref cache 0)) + (flush-cache-vector-internal cache))))))) + +(defun free-cache-vector (cache-vector) + (let ((entry (gethash (cache-vector-size cache-vector) *free-cache-vectors*))) + (without-interrupts + (if (null entry) + (error "Attempt to free a cache-vector not allocated by GET-CACHE-VECTOR.") + (let ((thread (cdr entry))) + (loop (unless thread (return)) + (when (eq thread cache-vector) (error "Freeing a cache twice.")) + (setq thread (cache-vector-ref thread 0))) + (flush-cache-vector-internal cache-vector) ;Help the GC + (setf (cache-vector-ref cache-vector 0) (cdr entry)) + (setf (cdr entry) cache-vector) + nil))))) + +;;; +;;; This is just for debugging and analysis. It shows the state of the free +;;; cache resource. +;;; +(defun show-free-cache-vectors () + (let ((elements ())) + (maphash #'(lambda (s e) (push (list s e) elements)) *free-cache-vectors*) + (setq elements (sort elements #'< :key #'car)) + (dolist (e elements) + (let* ((size (car e)) + (entry (cadr e)) + (allocated (car entry)) + (head (cdr entry)) + (free 0)) + (loop (when (null head) (return t)) + (setq head (cache-vector-ref head 0)) + (incf free)) + (format t + "~&There ~4D are caches of size ~4D. (~D free ~3D%)" + allocated + size + free + (floor (* 100 (/ free (float allocated))))))))) + + +;;; +;;; Wrapper cache numbers +;;; + +;;; +;;; The constant WRAPPER-CACHE-NUMBER-ADDS-OK controls the number of non-zero +;;; bits wrapper cache numbers will have. +;;; +;;; The value of this constant is the number of wrapper cache numbers which +;;; can be added and still be certain the result will be a fixnum. This is +;;; used by all the code that computes primary cache locations from multiple +;;; wrappers. +;;; +;;; The value of this constant is used to derive the next two which are the +;;; forms of this constant which it is more convenient for the runtime code +;;; to use. +;;; +#-cmu17 +(eval-when (compile load eval) + +(defconstant wrapper-cache-number-adds-ok 4) + +;;; Incorrect. This actually allows 15 or 16 adds, depending on whether +;;; most-positive-fixnum is all-ones. -- Ram +;;; +(defconstant wrapper-cache-number-length + (- (integer-length rand-base) + wrapper-cache-number-adds-ok)) + +(defconstant wrapper-cache-number-mask + (1- (expt 2 wrapper-cache-number-length))) + + +(defvar *get-wrapper-cache-number* (make-random-state)) + +(defun get-wrapper-cache-number () + (let ((n 0)) + (declare (type non-negative-fixnum n)) + (loop + (setq n + (logand wrapper-cache-number-mask + (random rand-base *get-wrapper-cache-number*))) + (unless (zerop n) (return n))))) + + +(unless (> wrapper-cache-number-length 8) + (error "In this implementation of Common Lisp, fixnums are so small that~@ + wrapper cache numbers end up being only ~D bits long. This does~@ + not actually keep PCL from running, but it may degrade cache~@ + performance.~@ + You may want to consider changing the value of the constant~@ + WRAPPER-CACHE-NUMBER-ADDS-OK."))) + +#+cmu17 +(progn + (defconstant wrapper-cache-number-length + (integer-length kernel:layout-hash-max)) + + (defconstant wrapper-cache-number-mask kernel:layout-hash-max) + + (defconstant wrapper-cache-number-adds-ok + (truncate most-positive-fixnum kernel:layout-hash-max))) + + +;;; +;;; wrappers themselves +;;; +;;; This caching algorithm requires that wrappers have more than one wrapper +;;; cache number. You should think of these multiple numbers as being in +;;; columns. That is, for a given cache, the same column of wrapper cache +;;; numbers will be used. +;;; +;;; If at some point the cache distribution of a cache gets bad, the cache +;;; can be rehashed by switching to a different column. +;;; +;;; The columns are referred to by field number which is that number which, +;;; when used as a second argument to wrapper-ref, will return that column +;;; of wrapper cache number. +;;; +;;; This code is written to allow flexibility as to how many wrapper cache +;;; numbers will be in each wrapper, and where they will be located. It is +;;; also set up to allow port specific modifications to `pack' the wrapper +;;; cache numbers on machines where the addressing modes make that a good +;;; idea. +;;; +#-structure-wrapper +(progn +(eval-when (compile load eval) +(defconstant wrapper-layout + '(number + number + number + number + number + number + number + number + state + instance-slots-layout + class-slots + class + no-of-instance-slots)) +) + +(eval-when (compile load eval) + +(defun wrapper-field (type) + (posq type wrapper-layout)) + +(defun next-wrapper-field (field-number) + (position (nth field-number wrapper-layout) + wrapper-layout + :start (1+ field-number))) + +(defmacro first-wrapper-cache-number-index () + `(wrapper-field 'number)) + +(defmacro next-wrapper-cache-number-index (field-number) + `(next-wrapper-field ,field-number)) + +);eval-when + +(defmacro wrapper-cache-number-vector (wrapper) + wrapper) + +(defmacro cache-number-vector-ref (cnv n) + `(svref ,cnv ,n)) + + +(defmacro wrapper-ref (wrapper n) + `(svref ,wrapper ,n)) + +(defmacro wrapper-state (wrapper) + `(wrapper-ref ,wrapper ,(wrapper-field 'state))) + +(defmacro wrapper-instance-slots-layout (wrapper) + `(wrapper-ref ,wrapper ,(wrapper-field 'instance-slots-layout))) + +(defmacro wrapper-class-slots (wrapper) + `(wrapper-ref ,wrapper ,(wrapper-field 'class-slots))) + +(defmacro wrapper-class (wrapper) + `(wrapper-ref ,wrapper ,(wrapper-field 'class))) + +(defmacro wrapper-no-of-instance-slots (wrapper) + `(wrapper-ref ,wrapper ,(wrapper-field 'no-of-instance-slots))) + +(defmacro make-wrapper-internal () + `(let ((wrapper (make-array ,(length wrapper-layout) :adjustable nil))) + ,@(gathering1 (collecting) + (iterate ((i (interval :from 0)) + (desc (list-elements wrapper-layout))) + (ecase desc + (number + (gather1 `(setf (wrapper-ref wrapper ,i) + (get-wrapper-cache-number)))) + ((state instance-slots-layout class-slots class no-of-instance-slots))))) + (setf (wrapper-state wrapper) 't) + wrapper)) + +(defun make-wrapper (no-of-instance-slots &optional class) + (let ((wrapper (make-wrapper-internal))) + (setf (wrapper-no-of-instance-slots wrapper) no-of-instance-slots) + (setf (wrapper-class wrapper) class) + wrapper)) + +) + +; In CMUCL we want to do type checking as early as possible; structures help this. +#+structure-wrapper +(eval-when (compile load eval) + +(defconstant wrapper-cache-number-vector-length + #+cmu17 kernel:layout-hash-length #-cmu17 8) + +#-cmu17 +(deftype cache-number-vector () + `(simple-array fixnum (,wrapper-cache-number-vector-length))) + +(defconstant wrapper-layout (make-list wrapper-cache-number-vector-length + :initial-element 'number)) + +) + +(defmacro mdotimes ((var form &optional ret) &rest body &aux (v (gensym))) + `(do ((,v ,form) + (,var 0 (1+ ,var))) + ((>= ,var ,v) ,ret) + (declare (fixnum ,var ,v)) + ,@body)) + +#+structure-wrapper +(progn + +#-(or new-kcl-wrapper cmu17) +(defun make-wrapper-cache-number-vector () + (let ((cnv (make-array #.wrapper-cache-number-vector-length + :element-type 'fixnum))) + (mdotimes (i #.wrapper-cache-number-vector-length) + (setf (aref cnv i) (get-wrapper-cache-number))) + cnv)) + + +#-cmu17 +(defstruct (wrapper + #+new-kcl-wrapper (:include si::basic-wrapper) + (:print-function print-wrapper) + #-new-kcl-wrapper + (:constructor make-wrapper (no-of-instance-slots &optional class)) + #+new-kcl-wrapper + (:constructor make-wrapper-internal)) + #-new-kcl-wrapper + (cache-number-vector (make-wrapper-cache-number-vector) + :type cache-number-vector) + #-new-kcl-wrapper + (state t :type (or (member t) cons)) + ;; either t or a list (state-sym new-wrapper) + ;; where state-sym is either :flush or :obsolete + (instance-slots-layout nil :type list) + (class-slots nil :type list) + #-new-kcl-wrapper + (no-of-instance-slots 0 :type fixnum) + #-new-kcl-wrapper + (class *the-class-t* :type class)) + + +(unless (boundp '*the-class-t*) (setq *the-class-t* nil)) + +#+new-kcl-wrapper +(defmacro wrapper-no-of-instance-slots (wrapper) + `(si::s-data-length ,wrapper)) + + +;;; Note that for CMU, the WRAPPER of a built-in or structure class will be +;;; some other kind of KERNEL:LAYOUT, but this shouldn't matter, since the only +;;; two slots that WRAPPER adds are meaningless in those cases. +;;; +#+cmu17 +(progn + (defstruct (wrapper + (:include kernel:layout) + (:conc-name %wrapper-) + (:print-function print-wrapper) + (:constructor make-wrapper-internal)) + (instance-slots-layout nil :type list) + (class-slots nil :type list)) + (declaim (ext:freeze-type wrapper)) + + (defmacro wrapper-class (wrapper) + `(kernel:class-pcl-class (kernel:layout-class ,wrapper))) + (defmacro wrapper-no-of-instance-slots (wrapper) + `(kernel:layout-length ,wrapper)) + (declaim (inline wrapper-state (setf wrapper-state))) + + (defun wrapper-state (wrapper) + (let ((invalid (kernel:layout-invalid wrapper))) + (cond ((null invalid) + t) + ((atom invalid) + ;; Some non-pcl object. invalid is probably :INVALID + ;; We should compute the new wrapper here instead + ;; of returning nil, but why bother, since + ;; obsolete-instance-trap can't use it. + '(:obsolete nil)) + (t + invalid)))) + + (defun (setf wrapper-state) (new-value wrapper) + (setf (kernel:layout-invalid wrapper) + (if (eq new-value 't) + nil + new-value))) + + (defmacro wrapper-instance-slots-layout (wrapper) + `(%wrapper-instance-slots-layout ,wrapper)) + (defmacro wrapper-class-slots (wrapper) + `(%wrapper-class-slots ,wrapper)) + (defmacro wrapper-cache-number-vector (x) x)) + + +#+new-kcl-wrapper +(defun make-wrapper (size &optional class) + (multiple-value-bind (raw slot-positions) + (if (< size 50) + (values si::*all-t-s-type* si::*standard-slot-positions*) + (values (make-array size :element-type 'unsigned-char) + (let ((array (make-array size :element-type 'unsigned-short))) + (mdotimes (i size) + (declare (fixnum i)) + (setf (aref array i) (* #.(si::size-of t) i)))))) + (make-wrapper-internal :length size + :raw raw + :print-function 'print-std-instance + :slot-position slot-positions + :size (* size #.(si::size-of t)) + :class class))) + +#+cmu17 +;;; BOOT-MAKE-WRAPPER -- Interface +;;; +;;; Called in BRAID when we are making wrappers for classes whose slots are +;;; not initialized yet, and which may be built-in classes. We pass in the +;;; class name in addition to the class. +;;; +(defun boot-make-wrapper (length name &optional class) + (let ((found (lisp:find-class name nil))) + (cond + (found + (unless (kernel:class-pcl-class found) + (setf (kernel:class-pcl-class found) class)) + (assert (eq (kernel:class-pcl-class found) class)) + (let ((layout (kernel:class-layout found))) + (assert layout) + layout)) + (t + (kernel:initialize-layout-hash + (make-wrapper-internal + :length length + :class (kernel:make-standard-class :name name :pcl-class class))))))) + + +#+cmu17 +;;; MAKE-WRAPPER -- Interface +;;; +;;; In CMU CL, the layouts (a.k.a wrappers) for built-in and structure +;;; classes already exist when PCL is initialized, so we don't necessarily +;;; always make a wrapper. Also, we help maintain the mapping between +;;; lisp:class and pcl::class objects. +;;; +(defun make-wrapper (length class) + (cond + ((typep class 'std-class) + (kernel:initialize-layout-hash + (make-wrapper-internal + :length length + :class + (let ((owrap (class-wrapper class))) + (cond (owrap + (kernel:layout-class owrap)) + ((*subtypep (class-of class) + *the-class-standard-class*) + (kernel:make-standard-class :pcl-class class)) + (t + (kernel:make-random-pcl-class :pcl-class class))))))) + (t + (let* ((found (lisp:find-class (slot-value class 'name))) + (layout (kernel:class-layout found))) + (unless (kernel:class-pcl-class found) + (setf (kernel:class-pcl-class found) class)) + (assert (eq (kernel:class-pcl-class found) class)) + (assert layout) + layout)))) + +(defun print-wrapper (wrapper stream depth) + (declare (ignore depth)) + (printing-random-thing (wrapper stream) + (format stream "Wrapper ~S" (wrapper-class wrapper)))) + +(defmacro first-wrapper-cache-number-index () + 0) + +(defmacro next-wrapper-cache-number-index (field-number) + `(and (< (the field-type ,field-number) + #.(1- wrapper-cache-number-vector-length)) + (the field-type (1+ (the field-type ,field-number))))) + +#-cmu17 +(defmacro cache-number-vector-ref (cnv n) + `(#-kcl svref #+kcl aref ,cnv ,n)) + +#+cmu17 +(defmacro cache-number-vector-ref (cnv n) + `(wrapper-cache-number-vector-ref ,cnv ,n)) + +) + +#-cmu17 +(defmacro wrapper-cache-number-vector-ref (wrapper n) + `(the fixnum + (#-structure-wrapper svref #+structure-wrapper aref + (wrapper-cache-number-vector ,wrapper) ,n))) +#+cmu17 +(defmacro wrapper-cache-number-vector-ref (wrapper n) + `(kernel:layout-hash ,wrapper ,n)) + +(defmacro class-no-of-instance-slots (class) + `(wrapper-no-of-instance-slots (class-wrapper ,class))) + +(defmacro wrapper-class* (wrapper) + #-(or new-kcl-wrapper cmu17) + `(wrapper-class ,wrapper) + #+(or new-kcl-wrapper cmu17) + `(let ((wrapper ,wrapper)) + (or (wrapper-class wrapper) + (find-structure-class + #+new-kcl-wrapper (si::s-data-name wrapper) + #+cmu17 (lisp:class-name (kernel:layout-class wrapper)))))) + +;;; +;;; The wrapper cache machinery provides general mechanism for trapping on +;;; the next access to any instance of a given class. This mechanism is +;;; used to implement the updating of instances when the class is redefined +;;; (make-instances-obsolete). The same mechanism is also used to update +;;; generic function caches when there is a change to the supers of a class. +;;; +;;; Basically, a given wrapper can be valid or invalid. If it is invalid, +;;; it means that any attempt to do a wrapper cache lookup using the wrapper +;;; should trap. Also, methods on slot-value-using-class check the wrapper +;;; validity as well. This is done by calling check-wrapper-validity. +;;; + +(defmacro invalid-wrapper-p (wrapper) + `(neq (wrapper-state ,wrapper) 't)) + +(defvar *previous-nwrappers* (make-hash-table)) + +(defun invalidate-wrapper (owrapper state nwrapper) + (ecase state + ((:flush :obsolete) + (let ((new-previous ())) + ;; + ;; First off, a previous call to invalidate-wrapper may have recorded + ;; owrapper as an nwrapper to update to. Since owrapper is about to + ;; be invalid, it no longer makes sense to update to it. + ;; + ;; We go back and change the previously invalidated wrappers so that + ;; they will now update directly to nwrapper. This corresponds to a + ;; kind of transitivity of wrapper updates. + ;; + (dolist (previous (gethash owrapper *previous-nwrappers*)) + (when (eq state ':obsolete) + (setf (car previous) ':obsolete)) + (setf (cadr previous) nwrapper) + (push previous new-previous)) + + (let ((ocnv (wrapper-cache-number-vector owrapper))) + (iterate ((type (list-elements wrapper-layout)) + (i (interval :from 0))) + (when (eq type 'number) (setf (cache-number-vector-ref ocnv i) 0)))) + (push (setf (wrapper-state owrapper) (list state nwrapper)) + new-previous) + + (setf (gethash owrapper *previous-nwrappers*) () + (gethash nwrapper *previous-nwrappers*) new-previous))))) + +(defun check-wrapper-validity (instance) + (let* ((owrapper (wrapper-of instance)) + (state (wrapper-state owrapper))) + (if (eq state 't) + owrapper + (let ((nwrapper + (ecase (car state) + (:flush + (flush-cache-trap owrapper (cadr state) instance)) + (:obsolete + (obsolete-instance-trap owrapper (cadr state) instance))))) + ;; + ;; This little bit of error checking is superfluous. It only + ;; checks to see whether the person who implemented the trap + ;; handling screwed up. Since that person is hacking internal + ;; PCL code, and is not a user, this should be needless. Also, + ;; since this directly slows down instance update and generic + ;; function cache refilling, feel free to take it out sometime + ;; soon. + ;; + (cond ((neq nwrapper (wrapper-of instance)) + (error "Wrapper returned from trap not wrapper of instance.")) + ((invalid-wrapper-p nwrapper) + (error "Wrapper returned from trap invalid."))) + nwrapper)))) + +#-cmu17 +(defmacro check-wrapper-validity1 (object) + (let ((owrapper (gensym))) + `(let ((,owrapper (cond ((std-instance-p ,object) + (std-instance-wrapper ,object)) + ((fsc-instance-p ,object) + (fsc-instance-wrapper ,object)) + #+new-kcl-wrapper + (t (built-in-wrapper-of ,object)) + #-new-kcl-wrapper + (t (wrapper-of ,object))))) + (if (eq 't (wrapper-state ,owrapper)) + ,owrapper + (check-wrapper-validity ,object))))) + +#+cmu17 +;;; semantically equivalent, but faster. +;;; +(defmacro check-wrapper-validity1 (object) + (let ((owrapper (gensym))) + `(let ((,owrapper (kernel:layout-of object))) + (if (kernel:layout-invalid ,owrapper) + (check-wrapper-validity ,object) + ,owrapper)))) + + +(defvar *free-caches* nil) + +(defun get-cache (nkeys valuep limit-fn nlines) + (declare (type non-negative-fixnum nlines)) + (let ((cache (or (without-interrupts (pop *free-caches*)) (make-cache)))) + (declare (type cache cache)) + (multiple-value-bind (cache-mask actual-size line-size nlines) + (compute-cache-parameters nkeys valuep nlines) + (declare (type non-negative-fixnum + cache-mask actual-size line-size nlines)) + (setf (cache-nkeys cache) nkeys + (cache-valuep cache) valuep + (cache-nlines cache) nlines + (cache-field cache) (first-wrapper-cache-number-index) + (cache-limit-fn cache) limit-fn + (cache-mask cache) cache-mask + (cache-size cache) actual-size + (cache-line-size cache) line-size + (cache-max-location cache) + (let ((line (1- nlines))) + (declare (type non-negative-fixnum line)) + (if (= nkeys 1) + (the fixnum (* line line-size)) + (the fixnum (1+ (the fixnum (* line line-size)))))) + (cache-vector cache) (get-cache-vector actual-size) + (cache-overflow cache) nil) + cache))) + +(defun get-cache-from-cache (old-cache new-nlines + &optional (new-field (first-wrapper-cache-number-index))) + (declare (type non-negative-fixnum new-nlines)) + (let ((nkeys (cache-nkeys old-cache)) + (valuep (cache-valuep old-cache)) + (cache (or (without-interrupts (pop *free-caches*)) (make-cache)))) + (declare (type cache cache)) + (multiple-value-bind (cache-mask actual-size line-size nlines) + (if (= new-nlines (cache-nlines old-cache)) + (values (cache-mask old-cache) (cache-size old-cache) + (cache-line-size old-cache) (cache-nlines old-cache)) + (compute-cache-parameters nkeys valuep new-nlines)) + (declare (type non-negative-fixnum + cache-mask actual-size line-size nlines)) + (setf (cache-owner cache) (cache-owner old-cache) + (cache-nkeys cache) nkeys + (cache-valuep cache) valuep + (cache-nlines cache) nlines + (cache-field cache) new-field + (cache-limit-fn cache) (cache-limit-fn old-cache) + (cache-mask cache) cache-mask + (cache-size cache) actual-size + (cache-line-size cache) line-size + (cache-max-location cache) + (let ((line (1- nlines))) + (declare (type non-negative-fixnum line)) + (if (= nkeys 1) + (the fixnum (* line line-size)) + (the fixnum (1+ (the fixnum (* line line-size)))))) + (cache-vector cache) (get-cache-vector actual-size) + (cache-overflow cache) nil) + cache))) + +(defun copy-cache (old-cache) + (let* ((new-cache (copy-cache-internal old-cache)) + (size (cache-size old-cache)) + (old-vector (cache-vector old-cache)) + (new-vector (get-cache-vector size))) + (declare (simple-vector old-vector new-vector)) + (mdotimes (i size) + (setf (svref new-vector i) (svref old-vector i))) + (setf (cache-vector new-cache) new-vector) + new-cache)) + +(defun free-cache (cache) + (free-cache-vector (cache-vector cache)) + (setf (cache-vector cache) #()) + (setf (cache-owner cache) nil) + (push cache *free-caches*) + nil) + +(defun compute-line-size (x) + (power-of-two-ceiling x)) + +(defun compute-cache-parameters (nkeys valuep nlines-or-cache-vector) + ;;(declare (values cache-mask actual-size line-size nlines)) + (declare (type non-negative-fixnum nkeys)) + (if (= nkeys 1) + (let* ((line-size (if valuep 2 1)) + (cache-size (if (typep nlines-or-cache-vector 'fixnum) + (the non-negative-fixnum + (* line-size + (the non-negative-fixnum + (power-of-two-ceiling + nlines-or-cache-vector)))) + (cache-vector-size nlines-or-cache-vector)))) + (declare (type non-negative-fixnum line-size cache-size)) + (values (logxor (the non-negative-fixnum (1- cache-size)) + (the non-negative-fixnum (1- line-size))) + cache-size + line-size + (the non-negative-fixnum (floor cache-size line-size)))) + (let* ((line-size (power-of-two-ceiling (if valuep (1+ nkeys) nkeys))) + (cache-size (if (typep nlines-or-cache-vector 'fixnum) + (the non-negative-fixnum + (* line-size + (the non-negative-fixnum + (power-of-two-ceiling + nlines-or-cache-vector)))) + (1- (cache-vector-size nlines-or-cache-vector))))) + (declare (type non-negative-fixnum line-size cache-size)) + (values (logxor (the non-negative-fixnum (1- cache-size)) + (the non-negative-fixnum (1- line-size))) + (the non-negative-fixnum (1+ cache-size)) + line-size + (the non-negative-fixnum (floor cache-size line-size)))))) + + + +;;; +;;; The various implementations of computing a primary cache location from +;;; wrappers. Because some implementations of this must run fast there are +;;; several implementations of the same algorithm. +;;; +;;; The algorithm is: +;;; +;;; SUM over the wrapper cache numbers, +;;; ENSURING that the result is a fixnum +;;; MASK the result against the mask argument. +;;; +;;; + +;;; +;;; COMPUTE-PRIMARY-CACHE-LOCATION +;;; +;;; The basic functional version. This is used by the cache miss code to +;;; compute the primary location of an entry. +;;; +(defun compute-primary-cache-location (field mask wrappers) + (declare (type field-type field) (type non-negative-fixnum mask)) + (if (not (listp wrappers)) + (logand mask (the non-negative-fixnum + (wrapper-cache-number-vector-ref wrappers field))) + (let ((location 0) (i 0)) + (declare (type non-negative-fixnum location i)) + (dolist (wrapper wrappers) + ;; + ;; First add the cache number of this wrapper to location. + ;; + (let ((wrapper-cache-number + (wrapper-cache-number-vector-ref wrapper field))) + (declare (type non-negative-fixnum wrapper-cache-number)) + (if (zerop wrapper-cache-number) + (return-from compute-primary-cache-location 0) + (setq location (the non-negative-fixnum + (+ location wrapper-cache-number))))) + ;; + ;; Then, if we are working with lots of wrappers, deal with + ;; the wrapper-cache-number-mask stuff. + ;; + (when (and (not (zerop i)) + (zerop (mod i wrapper-cache-number-adds-ok))) + (setq location + (logand location wrapper-cache-number-mask))) + (incf i)) + (the non-negative-fixnum (1+ (logand mask location)))))) + +;;; +;;; COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION +;;; +;;; This version is called on a cache line. It fetches the wrappers from +;;; the cache line and determines the primary location. Various parts of +;;; the cache filling code call this to determine whether it is appropriate +;;; to displace a given cache entry. +;;; +;;; If this comes across a wrapper whose cache-no is 0, it returns the symbol +;;; invalid to suggest to its caller that it would be provident to blow away +;;; the cache line in question. +;;; +(defun compute-primary-cache-location-from-location (to-cache from-location + &optional (from-cache to-cache)) + (declare (type cache to-cache from-cache) + (type non-negative-fixnum from-location)) + (let ((result 0) + (cache-vector (cache-vector from-cache)) + (field (cache-field to-cache)) + (mask (cache-mask to-cache)) + (nkeys (cache-nkeys to-cache))) + (declare (type field-type field) + (type non-negative-fixnum result mask nkeys) + (simple-vector cache-vector)) + (mdotimes (i nkeys) + (let* ((wrapper (cache-vector-ref cache-vector (+ i from-location))) + (wcn (wrapper-cache-number-vector-ref wrapper field))) + (declare (type non-negative-fixnum wcn)) + (setq result (+ result wcn))) + (when (and (not (zerop i)) + (zerop (mod i wrapper-cache-number-adds-ok))) + (setq result (logand result wrapper-cache-number-mask)))) + (if (= nkeys 1) + (logand mask result) + (the non-negative-fixnum (1+ (logand mask result)))))) + + +;;; +;;; NIL means nothing so far, no actual arg info has NILs +;;; in the metatype +;;; CLASS seen all sorts of metaclasses +;;; (specifically, more than one of the next 4 values) +;;; T means everything so far is the class T +;;; STANDARD-CLASS seen only standard classes +;;; BUILT-IN-CLASS seen only built in classes +;;; STRUCTURE-CLASS seen only structure classes +;;; +(defun raise-metatype (metatype new-specializer) + (let ((slot (find-class 'slot-class)) + (standard (find-class 'standard-class)) + (fsc (find-class 'funcallable-standard-class)) + (structure (find-class 'structure-class)) + (built-in (find-class 'built-in-class))) + (flet ((specializer->metatype (x) + (let ((meta-specializer + (if (eq *boot-state* 'complete) + (class-of (specializer-class x)) + (class-of x)))) + (cond ((eq x *the-class-t*) t) + ((*subtypep meta-specializer standard) 'standard-instance) + ((*subtypep meta-specializer fsc) 'standard-instance) + ((*subtypep meta-specializer structure) 'structure-instance) + ((*subtypep meta-specializer built-in) 'built-in-instance) + ((*subtypep meta-specializer slot) 'slot-instance) + (t (error "PCL can not handle the specializer ~S (meta-specializer ~S)." + new-specializer meta-specializer)))))) + ;; + ;; We implement the following table. The notation is + ;; that X and Y are distinct meta specializer names. + ;; + ;; NIL ===> + ;; X X ===> X + ;; X Y ===> CLASS + ;; + (let ((new-metatype (specializer->metatype new-specializer))) + (cond ((eq new-metatype 'slot-instance) 'class) + ((null metatype) new-metatype) + ((eq metatype new-metatype) new-metatype) + (t 'class)))))) + +(defmacro with-dfun-wrappers ((args metatypes) + (dfun-wrappers invalid-wrapper-p + &optional wrappers classes types) + invalid-arguments-form + &body body) + `(let* ((args-tail ,args) (,invalid-wrapper-p nil) (invalid-arguments-p nil) + (,dfun-wrappers nil) (dfun-wrappers-tail nil) + ,@(when wrappers + `((wrappers-rev nil) (types-rev nil) (classes-rev nil)))) + (dolist (mt ,metatypes) + (unless args-tail + (setq invalid-arguments-p t) + (return nil)) + (let* ((arg (pop args-tail)) + (wrapper nil) + ,@(when wrappers + `((class *the-class-t*) + (type 't)))) + (unless (eq mt 't) + (setq wrapper (wrapper-of arg)) + (when (invalid-wrapper-p wrapper) + (setq ,invalid-wrapper-p t) + (setq wrapper (check-wrapper-validity arg))) + (cond ((null ,dfun-wrappers) + (setq ,dfun-wrappers wrapper)) + ((not (consp ,dfun-wrappers)) + (setq dfun-wrappers-tail (list wrapper)) + (setq ,dfun-wrappers (cons ,dfun-wrappers dfun-wrappers-tail))) + (t + (let ((new-dfun-wrappers-tail (list wrapper))) + (setf (cdr dfun-wrappers-tail) new-dfun-wrappers-tail) + (setf dfun-wrappers-tail new-dfun-wrappers-tail)))) + ,@(when wrappers + `((setq class (wrapper-class* wrapper)) + (setq type `(class-eq ,class))))) + ,@(when wrappers + `((push wrapper wrappers-rev) + (push class classes-rev) + (push type types-rev))))) + (if invalid-arguments-p + ,invalid-arguments-form + (let* (,@(when wrappers + `((,wrappers (nreverse wrappers-rev)) + (,classes (nreverse classes-rev)) + (,types (mapcar #'(lambda (class) + `(class-eq ,class)) + ,classes))))) + ,@body)))) + + +;;; +;;; Some support stuff for getting a hold of symbols that we need when +;;; building the discriminator codes. Its ok for these to be interned +;;; symbols because we don't capture any user code in the scope in which +;;; these symbols are bound. +;;; + +(defvar *dfun-arg-symbols* '(.ARG0. .ARG1. .ARG2. .ARG3.)) + +(defun dfun-arg-symbol (arg-number) + (or (nth arg-number (the list *dfun-arg-symbols*)) + (intern (format nil ".ARG~A." arg-number) *the-pcl-package*))) + +(defvar *slot-vector-symbols* '(.SLOTS0. .SLOTS1. .SLOTS2. .SLOTS3.)) + +(defun slot-vector-symbol (arg-number) + (or (nth arg-number (the list *slot-vector-symbols*)) + (intern (format nil ".SLOTS~A." arg-number) *the-pcl-package*))) + +(defun make-dfun-lambda-list (metatypes applyp) + (gathering1 (collecting) + (iterate ((i (interval :from 0)) + (s (list-elements metatypes))) + (progn s) + (gather1 (dfun-arg-symbol i))) + (when applyp + (gather1 '&rest) + (gather1 '.dfun-rest-arg.)))) + +(defun make-dlap-lambda-list (metatypes applyp) + (gathering1 (collecting) + (iterate ((i (interval :from 0)) + (s (list-elements metatypes))) + (progn s) + (gather1 (dfun-arg-symbol i))) + (when applyp + (gather1 '&rest)))) + +(defun make-emf-call (metatypes applyp fn-variable &optional emf-type) + (let ((required + (gathering1 (collecting) + (iterate ((i (interval :from 0)) + (s (list-elements metatypes))) + (progn s) + (gather1 (dfun-arg-symbol i)))))) + `(,(if (eq emf-type 'fast-method-call) + 'invoke-effective-method-function-fast + 'invoke-effective-method-function) + ,fn-variable ,applyp ,@required ,@(when applyp `(.dfun-rest-arg.))))) + +(defun make-dfun-call (metatypes applyp fn-variable) + (let ((required + (gathering1 (collecting) + (iterate ((i (interval :from 0)) + (s (list-elements metatypes))) + (progn s) + (gather1 (dfun-arg-symbol i)))))) + (if applyp + `(function-apply ,fn-variable ,@required .dfun-rest-arg.) + `(function-funcall ,fn-variable ,@required)))) + +(defun make-dfun-arg-list (metatypes applyp) + (let ((required + (gathering1 (collecting) + (iterate ((i (interval :from 0)) + (s (list-elements metatypes))) + (progn s) + (gather1 (dfun-arg-symbol i)))))) + (if applyp + `(list* ,@required .dfun-rest-arg.) + `(list ,@required)))) + +(defun make-fast-method-call-lambda-list (metatypes applyp) + (gathering1 (collecting) + (gather1 '.pv-cell.) + (gather1 '.next-method-call.) + (iterate ((i (interval :from 0)) + (s (list-elements metatypes))) + (progn s) + (gather1 (dfun-arg-symbol i))) + (when applyp + (gather1 '.dfun-rest-arg.)))) + +(defmacro fin-lambda-fn (arglist &body body) + `#'(#+cmu kernel:instance-lambda #-cmu lambda + ,arglist + ,@body)) + +(defun make-dispatch-lambda (function-p metatypes applyp body) + `(#+cmu ,(if function-p 'kernel:instance-lambda 'lambda) #-cmu lambda + ,(if function-p + (make-dfun-lambda-list metatypes applyp) + (make-fast-method-call-lambda-list metatypes applyp)) + ,@(unless function-p + `((declare (ignore .pv-cell. .next-method-call.)))) + #+cmu (declare (ignorable ,@(cddr (make-fast-method-call-lambda-list + metatypes applyp)))) + #+copy-&rest-arg + ,@(when (and applyp function-p) + `((setq .dfun-rest-arg. (copy-list .dfun-rest-arg.)))) + ,@body)) + + +;;; +;;; Its too bad Common Lisp compilers freak out when you have a defun with +;;; a lot of LABELS in it. If I could do that I could make this code much +;;; easier to read and work with. +;;; +;;; Ahh Scheme... +;;; +;;; In the absence of that, the following little macro makes the code that +;;; follows a little bit more reasonable. I would like to add that having +;;; to practically write my own compiler in order to get just this simple +;;; thing is something of a drag. +;;; +(eval-when (compile load eval) + +(defvar *cache* nil) + +(defconstant *local-cache-functions* + '((cache () .cache.) + (nkeys () (the non-negative-fixnum (cache-nkeys .cache.))) + (line-size () (cache-line-size .cache.)) + (vector () (cache-vector .cache.)) + (valuep () (cache-valuep .cache.)) + (nlines () (cache-nlines .cache.)) + (max-location () (cache-max-location .cache.)) + (limit-fn () (cache-limit-fn .cache.)) + (size () (cache-size .cache.)) + (mask () (cache-mask .cache.)) + (field () (cache-field .cache.)) + (overflow () (cache-overflow .cache.)) + + ;; + ;; Return T IFF this cache location is reserved. The only time + ;; this is true is for line number 0 of an nkeys=1 cache. + ;; + (line-reserved-p (line) + (declare (type non-negative-fixnum line)) + (and (= (nkeys) 1) + (= line 0))) + ;; + (location-reserved-p (location) + (declare (type non-negative-fixnum location)) + (and (= (nkeys) 1) + (= location 0))) + ;; + ;; Given a line number, return the cache location. This is the + ;; value that is the second argument to cache-vector-ref. Basically, + ;; this deals with the offset of nkeys>1 caches and multiplies + ;; by line size. + ;; + (line-location (line) + (declare (type non-negative-fixnum line)) + (when (line-reserved-p line) + (error "line is reserved")) + (if (= (nkeys) 1) + (the non-negative-fixnum (* line (line-size))) + (the non-negative-fixnum + (1+ (the non-negative-fixnum (* line (line-size))))))) + ;; + ;; Given a cache location, return the line. This is the inverse + ;; of LINE-LOCATION. + ;; + (location-line (location) + (declare (type non-negative-fixnum location)) + (if (= (nkeys) 1) + (floor location (line-size)) + (floor (the non-negative-fixnum (1- location)) (line-size)))) + ;; + ;; Given a line number, return the wrappers stored at that line. + ;; As usual, if nkeys=1, this returns a single value. Only when + ;; nkeys>1 does it return a list. An error is signalled if the + ;; line is reserved. + ;; + (line-wrappers (line) + (declare (type non-negative-fixnum line)) + (when (line-reserved-p line) (error "Line is reserved.")) + (location-wrappers (line-location line))) + ;; + (location-wrappers (location) ; avoid multiplies caused by line-location + (declare (type non-negative-fixnum location)) + (if (= (nkeys) 1) + (cache-vector-ref (vector) location) + (let ((list (make-list (nkeys))) + (vector (vector))) + (declare (simple-vector vector)) + (mdotimes (i (nkeys) list) + (setf (nth i list) (cache-vector-ref vector (+ location i))))))) + ;; + ;; Given a line number, return true IFF the line's + ;; wrappers are the same as wrappers. + ;; + (line-matches-wrappers-p (line wrappers) + (declare (type non-negative-fixnum line)) + (and (not (line-reserved-p line)) + (location-matches-wrappers-p (line-location line) wrappers))) + ;; + (location-matches-wrappers-p (loc wrappers) ; must not be reserved + (declare (type non-negative-fixnum loc)) + (let ((cache-vector (vector))) + (declare (simple-vector cache-vector)) + (if (= (nkeys) 1) + (eq wrappers (cache-vector-ref cache-vector loc)) + (mdotimes (i (nkeys) t) + (unless (eq (pop wrappers) + (cache-vector-ref cache-vector (+ loc i))) + (return nil)))))) + ;; + ;; Given a line number, return the value stored at that line. + ;; If valuep is NIL, this returns NIL. As with line-wrappers, + ;; an error is signalled if the line is reserved. + ;; + (line-value (line) + (declare (type non-negative-fixnum line)) + (when (line-reserved-p line) (error "Line is reserved.")) + (location-value (line-location line))) + ;; + (location-value (loc) + (declare (type non-negative-fixnum loc)) + (and (valuep) + (cache-vector-ref (vector) (+ loc (nkeys))))) + ;; + ;; Given a line number, return true IFF that line has data in + ;; it. The state of the wrappers stored in the line is not + ;; checked. An error is signalled if line is reserved. + (line-full-p (line) + (when (line-reserved-p line) (error "Line is reserved.")) + (not (null (cache-vector-ref (vector) (line-location line))))) + ;; + ;; Given a line number, return true IFF the line is full and + ;; there are no invalid wrappers in the line, and the line's + ;; wrappers are different from wrappers. + ;; An error is signalled if the line is reserved. + ;; + (line-valid-p (line wrappers) + (declare (type non-negative-fixnum line)) + (when (line-reserved-p line) (error "Line is reserved.")) + (location-valid-p (line-location line) wrappers)) + ;; + (location-valid-p (loc wrappers) + (declare (type non-negative-fixnum loc)) + (let ((cache-vector (vector)) + (wrappers-mismatch-p (null wrappers))) + (declare (simple-vector cache-vector)) + (mdotimes (i (nkeys) wrappers-mismatch-p) + (let ((wrapper (cache-vector-ref cache-vector (+ loc i)))) + (when (or (null wrapper) + (invalid-wrapper-p wrapper)) + (return nil)) + (unless (and wrappers + (eq wrapper + (if (consp wrappers) (pop wrappers) wrappers))) + (setq wrappers-mismatch-p t)))))) + ;; + ;; How many unreserved lines separate line-1 and line-2. + ;; + (line-separation (line-1 line-2) + (declare (type non-negative-fixnum line-1 line-2)) + (let ((diff (the fixnum (- line-2 line-1)))) + (declare (fixnum diff)) + (when (minusp diff) + (setq diff (+ diff (nlines))) + (when (line-reserved-p 0) + (setq diff (1- diff)))) + diff)) + ;; + ;; Given a cache line, get the next cache line. This will not + ;; return a reserved line. + ;; + (next-line (line) + (declare (type non-negative-fixnum line)) + (if (= line (the fixnum (1- (nlines)))) + (if (line-reserved-p 0) 1 0) + (the non-negative-fixnum (1+ line)))) + ;; + (next-location (loc) + (declare (type non-negative-fixnum loc)) + (if (= loc (max-location)) + (if (= (nkeys) 1) + (line-size) + 1) + (the non-negative-fixnum (+ loc (line-size))))) + ;; + ;; Given a line which has a valid entry in it, this will return + ;; the primary cache line of the wrappers in that line. We just + ;; call COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION, this is an + ;; easier packaging up of the call to it. + ;; + (line-primary (line) + (declare (type non-negative-fixnum line)) + (location-line (line-primary-location line))) + ;; + (line-primary-location (line) + (declare (type non-negative-fixnum line)) + (compute-primary-cache-location-from-location + (cache) (line-location line))) + )) + +(defmacro with-local-cache-functions ((cache) &body body) + `(let ((.cache. ,cache)) + (declare (type cache .cache.)) + (macrolet ,(mapcar #'(lambda (fn) + `(,(car fn) ,(cadr fn) + `(let (,,@(mapcar #'(lambda (var) + ``(,',var ,,var)) + (cadr fn))) + ,@',(cddr fn)))) + *local-cache-functions*) + ,@body))) + +) + +;;; +;;; Here is where we actually fill, recache and expand caches. +;;; +;;; The functions FILL-CACHE and PROBE-CACHE are the ONLY external +;;; entrypoints into this code. +;;; +;;; FILL-CACHE returns 1 value: a new cache +;;; +;;; a wrapper field number +;;; a cache +;;; a mask +;;; an absolute cache size (the size of the actual vector) +;;; It tries to re-adjust the cache every time it makes a new fill. The +;;; intuition here is that we want uniformity in the number of probes needed to +;;; find an entry. Furthermore, adjusting has the nice property of throwing out +;;; any entries that are invalid. +;;; +(defvar *cache-expand-threshold* 1.25) + +(defun fill-cache (cache wrappers value &optional free-cache-p) + ;;(declare (values cache)) + (unless wrappers ; fill-cache won't return if wrappers is nil, might as well check. + (error "fill-cache: wrappers arg is NIL!")) + (or (fill-cache-p nil cache wrappers value) + (and (< (ceiling (* (cache-count cache) 1.25)) + (if (= (cache-nkeys cache) 1) + (1- (cache-nlines cache)) + (cache-nlines cache))) + (adjust-cache cache wrappers value free-cache-p)) + (expand-cache cache wrappers value free-cache-p))) + +(defvar *check-cache-p* nil) + +(defmacro maybe-check-cache (cache) + `(progn + (when *check-cache-p* + (check-cache ,cache)) + ,cache)) + +(defun check-cache (cache) + (with-local-cache-functions (cache) + (let ((location (if (= (nkeys) 1) 0 1)) + (limit (funcall (limit-fn) (nlines)))) + (mdotimes (i (nlines) cache) + (when (and (not (location-reserved-p location)) + (line-full-p i)) + (let* ((home-loc (compute-primary-cache-location-from-location + cache location)) + (home (location-line (if (location-reserved-p home-loc) + (next-location home-loc) + home-loc))) + (sep (when home (line-separation home i)))) + (when (and sep (> sep limit)) + (error "bad cache ~S ~@ + value at location ~D is ~D lines from its home. limit is ~D." + cache location sep limit)))) + (setq location (next-location location)))))) + +(defun probe-cache (cache wrappers &optional default limit-fn) + ;;(declare (values value)) + (unless wrappers (error "probe-cache: wrappers arg is NIL!")) + (with-local-cache-functions (cache) + (let* ((location (compute-primary-cache-location (field) (mask) wrappers)) + (limit (funcall (or limit-fn (limit-fn)) (nlines)))) + (declare (type non-negative-fixnum location limit)) + (when (location-reserved-p location) + (setq location (next-location location))) + (mdotimes (i (the non-negative-fixnum (1+ limit))) + (when (location-matches-wrappers-p location wrappers) + (return-from probe-cache (or (not (valuep)) + (location-value location)))) + (setq location (next-location location))) + (dolist (entry (overflow)) + (when (equal (car entry) wrappers) + (return-from probe-cache (or (not (valuep)) + (cdr entry))))) + default))) + +(defun map-cache (function cache &optional set-p) + (with-local-cache-functions (cache) + (let ((set-p (and set-p (valuep)))) + (mdotimes (i (nlines) cache) + (unless (or (line-reserved-p i) (not (line-valid-p i nil))) + (let ((value (funcall function (line-wrappers i) (line-value i)))) + (when set-p + (setf (cache-vector-ref (vector) (+ (line-location i) (nkeys))) + value))))) + (dolist (entry (overflow)) + (let ((value (funcall function (car entry) (cdr entry)))) + (when set-p + (setf (cdr entry) value)))))) + cache) + +(defun cache-count (cache) + (with-local-cache-functions (cache) + (let ((count 0)) + (declare (type non-negative-fixnum count)) + (mdotimes (i (nlines) count) + (unless (line-reserved-p i) + (when (line-full-p i) + (incf count))))))) + +(defun entry-in-cache-p (cache wrappers value) + (declare (ignore value)) + (with-local-cache-functions (cache) + (mdotimes (i (nlines)) + (unless (line-reserved-p i) + (when (equal (line-wrappers i) wrappers) + (return t)))))) + +;;; +;;; returns T or NIL +;;; +(defun fill-cache-p (forcep cache wrappers value) + (with-local-cache-functions (cache) + (let* ((location (compute-primary-cache-location (field) (mask) wrappers)) + (primary (location-line location))) + (declare (type non-negative-fixnum location primary)) + (multiple-value-bind (free emptyp) + (find-free-cache-line primary cache wrappers) + (when (or forcep emptyp) + (when (not emptyp) + (push (cons (line-wrappers free) (line-value free)) + (cache-overflow cache))) + ;;(fill-line free wrappers value) + (let ((line free)) + (declare (type non-negative-fixnum line)) + (when (line-reserved-p line) + (error "Attempt to fill a reserved line.")) + (let ((loc (line-location line)) + (cache-vector (vector))) + (declare (type non-negative-fixnum loc) + (simple-vector cache-vector)) + (cond ((= (nkeys) 1) + (setf (cache-vector-ref cache-vector loc) wrappers) + (when (valuep) + (setf (cache-vector-ref cache-vector (1+ loc)) value))) + (t + (let ((i 0)) + (declare (type non-negative-fixnum i)) + (dolist (w wrappers) + (setf (cache-vector-ref cache-vector (+ loc i)) w) + (setq i (the non-negative-fixnum (1+ i))))) + (when (valuep) + (setf (cache-vector-ref cache-vector (+ loc (nkeys))) + value)))) + (maybe-check-cache cache)))))))) + +(defun fill-cache-from-cache-p (forcep cache from-cache from-line) + (declare (type non-negative-fixnum from-line)) + (with-local-cache-functions (cache) + (let ((primary (location-line (compute-primary-cache-location-from-location + cache (line-location from-line) from-cache)))) + (declare (type non-negative-fixnum primary)) + (multiple-value-bind (free emptyp) + (find-free-cache-line primary cache) + (when (or forcep emptyp) + (when (not emptyp) + (push (cons (line-wrappers free) (line-value free)) + (cache-overflow cache))) + ;;(transfer-line from-cache-vector from-line cache-vector free) + (let ((from-cache-vector (cache-vector from-cache)) + (to-cache-vector (vector)) + (to-line free)) + (declare (type non-negative-fixnum to-line)) + (if (line-reserved-p to-line) + (error "transferring something into a reserved cache line.") + (let ((from-loc (line-location from-line)) + (to-loc (line-location to-line))) + (declare (type non-negative-fixnum from-loc to-loc)) + (modify-cache to-cache-vector + (mdotimes (i (line-size)) + (setf (cache-vector-ref to-cache-vector + (+ to-loc i)) + (cache-vector-ref from-cache-vector + (+ from-loc i))))))) + (maybe-check-cache cache))))))) + +;;; +;;; Returns NIL or (values ) +;;; +;;; This is only called when it isn't possible to put the entry in the cache +;;; the easy way. That is, this function assumes that FILL-CACHE-P has been +;;; called as returned NIL. +;;; +;;; If this returns NIL, it means that it wasn't possible to find a wrapper +;;; field for which all of the entries could be put in the cache (within the +;;; limit). +;;; +(defun adjust-cache (cache wrappers value free-old-cache-p) + (with-local-cache-functions (cache) + (let ((ncache (get-cache-from-cache cache (nlines) (field)))) + (do ((nfield (cache-field ncache) + (next-wrapper-cache-number-index nfield))) + ((null nfield) (free-cache ncache) nil) + (let ((nfield nfield)) + (declare (type field-type nfield)) + (setf (cache-field ncache) nfield) + (labels ((try-one-fill-from-line (line) + (fill-cache-from-cache-p nil ncache cache line)) + (try-one-fill (wrappers value) + (fill-cache-p nil ncache wrappers value))) + (if (and (mdotimes (i (nlines) t) + (when (and (null (line-reserved-p i)) + (line-valid-p i wrappers)) + (unless (try-one-fill-from-line i) (return nil)))) + (dolist (wrappers+value (cache-overflow cache) t) + (unless (try-one-fill (car wrappers+value) + (cdr wrappers+value)) + (return nil))) + (try-one-fill wrappers value)) + (progn (when free-old-cache-p (free-cache cache)) + (return (maybe-check-cache ncache))) + (flush-cache-vector-internal (cache-vector ncache))))))))) + + +;;; +;;; returns: (values ) +;;; +(defun expand-cache (cache wrappers value free-old-cache-p) + ;;(declare (values cache)) + (with-local-cache-functions (cache) + (let ((ncache (get-cache-from-cache cache (* (nlines) 2)))) + (labels ((do-one-fill-from-line (line) + (unless (fill-cache-from-cache-p nil ncache cache line) + (do-one-fill (line-wrappers line) (line-value line)))) + (do-one-fill (wrappers value) + (setq ncache (or (adjust-cache ncache wrappers value t) + (fill-cache-p t ncache wrappers value)))) + (try-one-fill (wrappers value) + (fill-cache-p nil ncache wrappers value))) + (mdotimes (i (nlines)) + (when (and (null (line-reserved-p i)) + (line-valid-p i wrappers)) + (do-one-fill-from-line i))) + (dolist (wrappers+value (cache-overflow cache)) + (unless (try-one-fill (car wrappers+value) (cdr wrappers+value)) + (do-one-fill (car wrappers+value) (cdr wrappers+value)))) + (unless (try-one-fill wrappers value) + (do-one-fill wrappers value)) + (when free-old-cache-p (free-cache cache)) + (maybe-check-cache ncache))))) + + +;;; +;;; This is the heart of the cache filling mechanism. It implements the decisions +;;; about where entries are placed. +;;; +;;; Find a line in the cache at which a new entry can be inserted. +;;; +;;; +;;; is in fact empty? +;;; +(defun find-free-cache-line (primary cache &optional wrappers) + ;;(declare (values line empty?)) + (declare (type non-negative-fixnum primary)) + (with-local-cache-functions (cache) + (when (line-reserved-p primary) (setq primary (next-line primary))) + (let ((limit (funcall (limit-fn) (nlines))) + (wrappedp nil) + (lines nil) + (p primary) (s primary)) + (declare (type non-negative-fixnum p s limit)) + (block find-free + (loop + ;; Try to find a free line starting at .

    is the + ;; primary line of the entry we are finding a free + ;; line for, it is used to compute the seperations. + (do* ((line s (next-line line)) + (nsep (line-separation p s) (1+ nsep))) + (()) + (declare (type non-negative-fixnum line nsep)) + (when (null (line-valid-p line wrappers)) ;If this line is empty or + (push line lines) ;invalid, just use it. + (return-from find-free)) + (when (and wrappedp (>= line primary)) + ;; have gone all the way around the cache, time to quit + (return-from find-free-cache-line (values primary nil))) + (let ((osep (line-separation (line-primary line) line))) + (when (>= osep limit) + (return-from find-free-cache-line (values primary nil))) + (when (cond ((= nsep limit) t) + ((= nsep osep) (zerop (random 2))) + ((> nsep osep) t) + (t nil)) + ;; See if we can displace what is in this line so that we + ;; can use the line. + (when (= line (the fixnum (1- (nlines)))) (setq wrappedp t)) + (setq p (line-primary line)) + (setq s (next-line line)) + (push line lines) + (return nil))) + (when (= line (the fixnum (1- (nlines)))) (setq wrappedp t))))) + ;; Do all the displacing. + (loop + (when (null (cdr lines)) (return nil)) + (let ((dline (pop lines)) + (line (car lines))) + (declare (type non-negative-fixnum dline line)) + ;;Copy from line to dline (dline is known to be free). + (let ((from-loc (line-location line)) + (to-loc (line-location dline)) + (cache-vector (vector))) + (declare (type non-negative-fixnum from-loc to-loc) + (simple-vector cache-vector)) + (modify-cache cache-vector + (mdotimes (i (line-size)) + (setf (cache-vector-ref cache-vector (+ to-loc i)) + (cache-vector-ref cache-vector (+ from-loc i))) + (setf (cache-vector-ref cache-vector (+ from-loc i)) + nil)))))) + (values (car lines) t)))) + +(defun default-limit-fn (nlines) + (case nlines + ((1 2 4) 1) + ((8 16) 4) + (otherwise 6))) + +(defvar *empty-cache* (make-cache)) ; for defstruct slot initial value forms + +;;; +;;; pre-allocate generic function caches. The hope is that this will put +;;; them nicely together in memory, and that that may be a win. Of course +;;; the first gc copy will probably blow that out, this really wants to be +;;; wrapped in something that declares the area static. +;;; +;;; This preallocation only creates about 25% more caches than PCL itself +;;; uses. Some ports may want to preallocate some more of these. +;;; +(eval-when (load) + (dolist (n-size '((1 513)(3 257)(3 129)(14 128)(6 65)(2 64)(7 33)(16 32) + (16 17)(32 16)(64 9)(64 8)(6 5)(128 4)(35 2))) + (let ((n (car n-size)) + (size (cadr n-size))) + (mapcar #'free-cache-vector + (mapcar #'get-cache-vector + (make-list n :initial-element size)))))) + +(defun caches-to-allocate () + (sort (let ((l nil)) + (maphash #'(lambda (size entry) + (push (list (car entry) size) l)) + pcl::*free-caches*) + l) + #'> :key #'cadr)) + + diff --git a/pcl/gcl_pcl_combin.lisp b/pcl/gcl_pcl_combin.lisp new file mode 100644 index 0000000..eb03697 --- /dev/null +++ b/pcl/gcl_pcl_combin.lisp @@ -0,0 +1,407 @@ +;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; + +(in-package :pcl) + +(defun get-method-function (method &optional method-alist wrappers) + (let ((fn (cadr (assoc method method-alist)))) + (if fn + (values fn nil nil nil) + (multiple-value-bind (mf fmf) + (if (listp method) + (early-method-function method) + (values nil (method-fast-function method))) + (let* ((pv-table (and fmf (method-function-pv-table fmf)))) + (if (and fmf (or (null pv-table) wrappers)) + (let* ((pv-wrappers (when pv-table + (pv-wrappers-from-all-wrappers + pv-table wrappers))) + (pv-cell (when (and pv-table pv-wrappers) + (pv-table-lookup pv-table pv-wrappers)))) + (values mf t fmf pv-cell)) + (values + (or mf (if (listp method) + (setf (cadr method) + (method-function-from-fast-function fmf)) + (method-function method))) + t nil nil))))))) + +(defun make-effective-method-function (generic-function form &optional + method-alist wrappers) + (funcall (the function + (make-effective-method-function1 generic-function form + (not (null method-alist)) + (not (null wrappers)))) + method-alist wrappers)) + +(defun make-effective-method-function1 (generic-function form + method-alist-p wrappers-p) + (if (and (listp form) + (eq (car form) 'call-method)) + (make-effective-method-function-simple generic-function form) + ;; + ;; We have some sort of `real' effective method. Go off and get a + ;; compiled function for it. Most of the real hair here is done by + ;; the GET-FUNCTION mechanism. + ;; + (make-effective-method-function-internal generic-function form + method-alist-p wrappers-p))) + +(defun make-effective-method-function-type (generic-function form + method-alist-p wrappers-p) + (if (and (listp form) + (eq (car form) 'call-method)) + (let* ((cm-args (cdr form)) + (method (car cm-args))) + (when method + (if (if (listp method) + (eq (car method) ':early-method) + (method-p method)) + (if method-alist-p + 't + (multiple-value-bind (mf fmf) + (if (listp method) + (early-method-function method) + (values nil (method-fast-function method))) + (declare (ignore mf)) + (let* ((pv-table (and fmf (method-function-pv-table fmf)))) + (if (and fmf (or (null pv-table) wrappers-p)) + 'fast-method-call + 'method-call)))) + (if (and (consp method) (eq (car method) 'make-method)) + (make-effective-method-function-type + generic-function (cadr method) method-alist-p wrappers-p) + (type-of method))))) + 'fast-method-call)) + +(defun make-effective-method-function-simple (generic-function form + &optional no-fmf-p) + ;; + ;; The effective method is just a call to call-method. This opens up + ;; the possibility of just using the method function of the method as + ;; the effective method function. + ;; + ;; But we have to be careful. If that method function will ask for + ;; the next methods we have to provide them. We do not look to see + ;; if there are next methods, we look at whether the method function + ;; asks about them. If it does, we must tell it whether there are + ;; or aren't to prevent the leaky next methods bug. + ;; + (let* ((cm-args (cdr form)) + (fmf-p (and (null no-fmf-p) + (or (not (eq *boot-state* 'complete)) + (gf-fast-method-function-p generic-function)) + (null (cddr cm-args)))) + (method (car cm-args)) + (cm-args1 (cdr cm-args))) + #'(lambda (method-alist wrappers) + (make-effective-method-function-simple1 generic-function method cm-args1 fmf-p + method-alist wrappers)))) + +(defun make-emf-from-method (method cm-args &optional gf fmf-p method-alist wrappers) + (multiple-value-bind (mf real-mf-p fmf pv-cell) + (get-method-function method method-alist wrappers) + (if fmf + (let* ((next-methods (car cm-args)) + (next (make-effective-method-function-simple1 + gf (car next-methods) + (list* (cdr next-methods) (cdr cm-args)) + fmf-p method-alist wrappers)) + (arg-info (method-function-get fmf ':arg-info))) + (make-fast-method-call :function fmf + :pv-cell pv-cell + :next-method-call next + :arg-info arg-info)) + (if real-mf-p + (make-method-call :function mf + :call-method-args cm-args) + mf)))) + +(defun make-effective-method-function-simple1 (gf method cm-args fmf-p + &optional method-alist wrappers) + (when method + (if (if (listp method) + (eq (car method) ':early-method) + (method-p method)) + (make-emf-from-method method cm-args gf fmf-p method-alist wrappers) + (if (and (consp method) (eq (car method) 'make-method)) + (make-effective-method-function gf (cadr method) method-alist wrappers) + method)))) + +(defvar *global-effective-method-gensyms* ()) +(defvar *rebound-effective-method-gensyms*) + +(defun get-effective-method-gensym () + (or (pop *rebound-effective-method-gensyms*) + (let ((new (intern (format nil "EFFECTIVE-METHOD-GENSYM-~D" + (length *global-effective-method-gensyms*)) + "PCL"))) + (setq *global-effective-method-gensyms* + (append *global-effective-method-gensyms* (list new))) + new))) + +(let ((*rebound-effective-method-gensyms* ())) + (dotimes (i 10) (get-effective-method-gensym))) + +(defun expand-effective-method-function (gf effective-method &optional env) + (declare (ignore env)) + (multiple-value-bind (nreq applyp metatypes nkeys arg-info) + (get-generic-function-info gf) + (declare (ignore nreq nkeys arg-info)) + (let ((args (make-fast-method-call-lambda-list metatypes applyp))) + `(lambda ,args + (declare (ignore .pv-cell. .next-method-call.)) + #+cmu (declare (ignorable ,@(cddr args))) + ,effective-method)))) + +(defun expand-emf-call-method (gf form metatypes applyp env) + (declare (ignore gf metatypes applyp env)) + `(call-method ,(cdr form))) + +(defmacro call-method (&rest args) + (declare (ignore args)) + `(error "~S outside of an effective method form" 'call-method)) + +(defun memf-test-converter (form generic-function method-alist-p wrappers-p) + (cond ((and (consp form) (eq (car form) 'call-method)) + (case (make-effective-method-function-type + generic-function form method-alist-p wrappers-p) + (fast-method-call + '.fast-call-method.) + (t + '.call-method.))) + ((and (consp form) (eq (car form) 'call-method-list)) + (case (if (every #'(lambda (form) + (eq 'fast-method-call + (make-effective-method-function-type + generic-function form + method-alist-p wrappers-p))) + (cdr form)) + 'fast-method-call + 't) + (fast-method-call + '.fast-call-method-list.) + (t + '.call-method-list.))) + (t + (default-test-converter form)))) + +(defun memf-code-converter (form generic-function + metatypes applyp method-alist-p wrappers-p) + (cond ((and (consp form) (eq (car form) 'call-method)) + (let ((gensym (get-effective-method-gensym))) + (values (make-emf-call metatypes applyp gensym + (make-effective-method-function-type + generic-function form method-alist-p wrappers-p)) + (list gensym)))) + ((and (consp form) (eq (car form) 'call-method-list)) + (let ((gensym (get-effective-method-gensym)) + (type (if (every #'(lambda (form) + (eq 'fast-method-call + (make-effective-method-function-type + generic-function form + method-alist-p wrappers-p))) + (cdr form)) + 'fast-method-call + 't))) + (values `(dolist (emf ,gensym nil) + ,(make-emf-call metatypes applyp 'emf type)) + (list gensym)))) + (t + (default-code-converter form)))) + +(defun memf-constant-converter (form generic-function) + (cond ((and (consp form) (eq (car form) 'call-method)) + (list (cons '.meth. + (make-effective-method-function-simple + generic-function form)))) + ((and (consp form) (eq (car form) 'call-method-list)) + (list (cons '.meth-list. + (mapcar #'(lambda (form) + (make-effective-method-function-simple + generic-function form)) + (cdr form))))) + (t + (default-constant-converter form)))) + +(defun make-effective-method-function-internal (generic-function effective-method + method-alist-p wrappers-p) + (multiple-value-bind (nreq applyp metatypes nkeys arg-info) + (get-generic-function-info generic-function) + (declare (ignore nkeys arg-info)) + (let* ((*rebound-effective-method-gensyms* *global-effective-method-gensyms*) + (name (if (early-gf-p generic-function) + (early-gf-name generic-function) + (generic-function-name generic-function))) + (arg-info (cons nreq applyp)) + (effective-method-lambda (expand-effective-method-function + generic-function effective-method))) + (multiple-value-bind (cfunction constants) + (get-function1 effective-method-lambda + #'(lambda (form) + (memf-test-converter form generic-function + method-alist-p wrappers-p)) + #'(lambda (form) + (memf-code-converter form generic-function + metatypes applyp + method-alist-p wrappers-p)) + #'(lambda (form) + (memf-constant-converter form generic-function))) + #'(lambda (method-alist wrappers) + (let* ((constants + (mapcar #'(lambda (constant) + (if (consp constant) + (case (car constant) + (.meth. + (funcall (the function (cdr constant)) + method-alist wrappers)) + (.meth-list. + (mapcar #'(lambda (fn) + (funcall (the function fn) + method-alist wrappers)) + (cdr constant))) + (t constant)) + constant)) + constants)) + (function (set-function-name + (apply cfunction constants) + `(combined-method ,name)))) + (make-fast-method-call :function function + :arg-info arg-info))))))) + +(defmacro call-method-list (&rest calls) + `(progn ,@calls)) + +(defun make-call-methods (methods) + `(call-method-list + ,@(mapcar #'(lambda (method) `(call-method ,method ())) methods))) + +(defun standard-compute-effective-method (generic-function combin applicable-methods) + (declare (ignore combin)) + (let ((before ()) + (primary ()) + (after ()) + (around ())) + (dolist (m applicable-methods) + (let ((qualifiers (if (listp m) + (early-method-qualifiers m) + (method-qualifiers m)))) + (cond ((member ':before qualifiers) (push m before)) + ((member ':after qualifiers) (push m after)) + ((member ':around qualifiers) (push m around)) + (t + (push m primary))))) + (setq before (reverse before) + after (reverse after) + primary (reverse primary) + around (reverse around)) + (cond ((null primary) + `(error "No primary method for the generic function ~S." ',generic-function)) + ((and (null before) (null after) (null around)) + ;; + ;; By returning a single call-method `form' here we enable an important + ;; implementation-specific optimization. + ;; + `(call-method ,(first primary) ,(rest primary))) + (t + (let ((main-effective-method + (if (or before after) + `(multiple-value-prog1 + (progn ,(make-call-methods before) + (call-method ,(first primary) ,(rest primary))) + ,(make-call-methods (reverse after))) + `(call-method ,(first primary) ,(rest primary))))) + (if around + `(call-method ,(first around) + (,@(rest around) (make-method ,main-effective-method))) + main-effective-method)))))) + +;;; +;;; The STANDARD method combination type. This is coded by hand (rather than +;;; with define-method-combination) for bootstrapping and efficiency reasons. +;;; Note that the definition of the find-method-combination-method appears in +;;; the file defcombin.lisp, this is because EQL methods can't appear in the +;;; bootstrap. +;;; +;;; The defclass for the METHOD-COMBINATION and STANDARD-METHOD-COMBINATION +;;; classes has to appear here for this reason. This code must conform to +;;; the code in the file defcombin, look there for more details. +;;; + +(defun compute-effective-method (generic-function combin applicable-methods) + (standard-compute-effective-method generic-function combin applicable-methods)) + +(defvar *invalid-method-error* + #'(lambda (&rest args) + (declare (ignore args)) + (error + "INVALID-METHOD-ERROR was called outside the dynamic scope~%~ + of a method combination function (inside the body of~%~ + DEFINE-METHOD-COMBINATION or a method on the generic~%~ + function COMPUTE-EFFECTIVE-METHOD)."))) + +(defvar *method-combination-error* + #'(lambda (&rest args) + (declare (ignore args)) + (error + "METHOD-COMBINATION-ERROR was called outside the dynamic scope~%~ + of a method combination function (inside the body of~%~ + DEFINE-METHOD-COMBINATION or a method on the generic~%~ + function COMPUTE-EFFECTIVE-METHOD)."))) + +;(defmethod compute-effective-method :around ;issue with magic +; ((generic-function generic-function) ;generic functions +; (method-combination method-combination) +; applicable-methods) +; (declare (ignore applicable-methods)) +; (flet ((real-invalid-method-error (method format-string &rest args) +; (declare (ignore method)) +; (apply #'error format-string args)) +; (real-method-combination-error (format-string &rest args) +; (apply #'error format-string args))) +; (let ((*invalid-method-error* #'real-invalid-method-error) +; (*method-combination-error* #'real-method-combination-error)) +; (call-next-method)))) + +(defun invalid-method-error (&rest args) + (declare (arglist method format-string &rest format-arguments)) + (apply *invalid-method-error* args)) + +(defun method-combination-error (&rest args) + (declare (arglist format-string &rest format-arguments)) + (apply *method-combination-error* args)) + +;This definition appears in defcombin.lisp. +; +;(defmethod find-method-combination ((generic-function generic-function) +; (type (eql 'standard)) +; options) +; (when options +; (method-combination-error +; "The method combination type STANDARD accepts no options.")) +; *standard-method-combination*) + diff --git a/pcl/gcl_pcl_compat.lisp b/pcl/gcl_pcl_compat.lisp new file mode 100644 index 0000000..6069153 --- /dev/null +++ b/pcl/gcl_pcl_compat.lisp @@ -0,0 +1,31 @@ +;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp; -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; + +(in-package :pcl) + +() + diff --git a/pcl/gcl_pcl_cpl.lisp b/pcl/gcl_pcl_cpl.lisp new file mode 100644 index 0000000..cc044c7 --- /dev/null +++ b/pcl/gcl_pcl_cpl.lisp @@ -0,0 +1,314 @@ +;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; + +(in-package :pcl) + +;;; +;;; compute-class-precedence-list +;;; +;;; Knuth section 2.2.3 has some interesting notes on this. +;;; +;;; What appears here is basically the algorithm presented there. +;;; +;;; The key idea is that we use class-precedence-description (CPD) structures +;;; to store the precedence information as we proceed. The CPD structure for +;;; a class stores two critical pieces of information: +;;; +;;; - a count of the number of "reasons" why the class can't go +;;; into the class precedence list yet. +;;; +;;; - a list of the "reasons" this class prevents others from +;;; going in until after it +;; +;;; A "reason" is essentially a single local precedence constraint. If a +;;; constraint between two classes arises more than once it generates more +;;; than one reason. This makes things simpler, linear, and isn't a problem +;;; as long as we make sure to keep track of each instance of a "reason". +;;; +;;; This code is divided into three phases. +;;; +;;; - the first phase simply generates the CPD's for each of the class +;;; and its superclasses. The remainder of the code will manipulate +;;; these CPDs rather than the class objects themselves. At the end +;;; of this pass, the CPD-SUPERS field of a CPD is a list of the CPDs +;;; of the direct superclasses of the class. +;;; +;;; - the second phase folds all the local constraints into the CPD +;;; structure. The CPD-COUNT of each CPD is built up, and the +;;; CPD-AFTER fields are augmented to include precedence constraints +;;; from the CPD-SUPERS field and from the order of classes in other +;;; CPD-SUPERS fields. +;;; +;;; After this phase, the CPD-AFTER field of a class includes all the +;;; direct superclasses of the class plus any class that immediately +;;; follows the class in the direct superclasses of another. There +;;; can be duplicates in this list. The CPD-COUNT field is equal to +;;; the number of times this class appears in the CPD-AFTER field of +;;; all the other CPDs. +;;; +;;; - In the third phase, classes are put into the precedence list one +;;; at a time, with only those classes with a CPD-COUNT of 0 being +;;; candidates for insertion. When a class is inserted , every CPD +;;; in its CPD-AFTER field has its count decremented. +;;; +;;; In the usual case, there is only one candidate for insertion at +;;; any point. If there is more than one, the specified tiebreaker +;;; rule is used to choose among them. +;;; + +(defmethod compute-class-precedence-list ((root slot-class)) + (compute-std-cpl root (class-direct-superclasses root))) + +(defstruct (class-precedence-description + (:conc-name nil) + (:print-function (lambda (obj str depth) + (declare (ignore depth)) + (format str + "#" + (class-name (cpd-class obj)) + (cpd-count obj)))) + (:constructor make-cpd ())) + (cpd-class nil) + (cpd-supers ()) + (cpd-after ()) + (cpd-count 0 :type fixnum)) + +(defun compute-std-cpl (class supers) + (cond ((null supers) ;First two branches of COND + (list class)) ;are implementing the single + ((null (cdr supers)) ;inheritance optimization. + (cons class + (compute-std-cpl (car supers) + (class-direct-superclasses (car supers))))) + (t + (multiple-value-bind (all-cpds nclasses) + (compute-std-cpl-phase-1 class supers) + (compute-std-cpl-phase-2 all-cpds) + (compute-std-cpl-phase-3 class all-cpds nclasses))))) + +(defvar *compute-std-cpl-class->entry-table-size* 60) + +(defun compute-std-cpl-phase-1 (class supers) + (let ((nclasses 0) + (all-cpds ()) + (table (make-hash-table :size *compute-std-cpl-class->entry-table-size* + :test #'eq))) + (declare (fixnum nclasses)) + (labels ((get-cpd (c) + (or (gethash c table) + (setf (gethash c table) (make-cpd)))) + (walk (c supers) + (if (forward-referenced-class-p c) + (cpl-forward-referenced-class-error class c) + (let ((cpd (get-cpd c))) + (unless (cpd-class cpd) ;If we have already done this + ;class before, we can quit. + (setf (cpd-class cpd) c) + (incf nclasses) + (push cpd all-cpds) + (setf (cpd-supers cpd) (mapcar #'get-cpd supers)) + (dolist (super supers) + (walk super (class-direct-superclasses super)))))))) + (walk class supers) + (values all-cpds nclasses)))) + +(defun compute-std-cpl-phase-2 (all-cpds) + (dolist (cpd all-cpds) + (let ((supers (cpd-supers cpd))) + (when supers + (setf (cpd-after cpd) (nconc (cpd-after cpd) supers)) + (incf (cpd-count (car supers)) 1) + (do* ((t1 supers t2) + (t2 (cdr t1) (cdr t1))) + ((null t2)) + (incf (cpd-count (car t2)) 2) + (push (car t2) (cpd-after (car t1)))))))) + +(defun compute-std-cpl-phase-3 (class all-cpds nclasses) + (declare (fixnum nclasses)) + (let ((candidates ()) + (next-cpd nil) + (rcpl ())) + ;; + ;; We have to bootstrap the collection of those CPD's that + ;; have a zero count. Once we get going, we will maintain + ;; this list incrementally. + ;; + (dolist (cpd all-cpds) + (when (zerop (cpd-count cpd)) (push cpd candidates))) + + + (loop + (when (null candidates) + ;; + ;; If there are no candidates, and enough classes have been put + ;; into the precedence list, then we are all done. Otherwise + ;; it means there is a consistency problem. + (if (zerop nclasses) + (return (reverse rcpl)) + (cpl-inconsistent-error class all-cpds))) + ;; + ;; Try to find the next class to put in from among the candidates. + ;; If there is only one, its easy, otherwise we have to use the + ;; famous RPG tiebreaker rule. There is some hair here to avoid + ;; having to call DELETE on the list of candidates. I dunno if + ;; its worth it but what the hell. + ;; + (setq next-cpd + (if (null (cdr candidates)) + (prog1 (car candidates) + (setq candidates ())) + (block tie-breaker + (dolist (c rcpl) + (let ((supers (class-direct-superclasses c))) + (if (memq (cpd-class (car candidates)) supers) + (return-from tie-breaker (pop candidates)) + (do ((loc candidates (cdr loc))) + ((null (cdr loc))) + (let ((cpd (cadr loc))) + (when (memq (cpd-class cpd) supers) + (setf (cdr loc) (cddr loc)) + (return-from tie-breaker cpd)))))))))) + (decf nclasses) + (push (cpd-class next-cpd) rcpl) + (dolist (after (cpd-after next-cpd)) + (when (zerop (decf (cpd-count after))) + (push after candidates)))))) + +;;; +;;; Support code for signalling nice error messages. +;;; + +(defun cpl-error (class format-string &rest format-args) + (error "While computing the class precedence list of the class ~A.~%~A" + (if (class-name class) + (format nil "named ~S" (class-name class)) + class) + (apply #'format nil format-string format-args))) + + +(defun cpl-forward-referenced-class-error (class forward-class) + (flet ((class-or-name (class) + (if (class-name class) + (format nil "named ~S" (class-name class)) + class))) + (let ((names (mapcar #'class-or-name + (cdr (find-superclass-chain class forward-class))))) + (cpl-error class + "The class ~A is a forward referenced class.~@ + The class ~A is ~A." + (class-or-name forward-class) + (class-or-name forward-class) + (if (null (cdr names)) + (format nil + "a direct superclass of the class ~A" + (class-or-name class)) + (format nil + "reached from the class ~A by following~@ + the direct superclass chain through: ~A~ + ~% ending at the class ~A" + (class-or-name class) + (format nil + "~{~% the class ~A,~}" + (butlast names)) + (car (last names)))))))) + +(defun find-superclass-chain (bottom top) + (labels ((walk (c chain) + (if (eq c top) + (return-from find-superclass-chain (nreverse chain)) + (dolist (super (class-direct-superclasses c)) + (walk super (cons super chain)))))) + (walk bottom (list bottom)))) + + +(defun cpl-inconsistent-error (class all-cpds) + (let ((reasons (find-cycle-reasons all-cpds))) + (cpl-error class + "It is not possible to compute the class precedence list because~@ + there ~A in the local precedence relations.~@ + ~A because:~{~% ~A~}." + (if (cdr reasons) "are circularities" "is a circularity") + (if (cdr reasons) "These arise" "This arises") + (format-cycle-reasons (apply #'append reasons))))) + +(defun format-cycle-reasons (reasons) + (flet ((class-or-name (cpd) + (let ((class (cpd-class cpd))) + (if (class-name class) + (format nil "named ~S" (class-name class)) + class)))) + (mapcar + #'(lambda (reason) + (ecase (caddr reason) + (:super + (format + nil + "the class ~A appears in the supers of the class ~A" + (class-or-name (cadr reason)) + (class-or-name (car reason)))) + (:in-supers + (format + nil + "the class ~A follows the class ~A in the supers of the class ~A" + (class-or-name (cadr reason)) + (class-or-name (car reason)) + (class-or-name (cadddr reason)))))) + reasons))) + +(defun find-cycle-reasons (all-cpds) + (let ((been-here ()) ;List of classes we have visited. + (cycle-reasons ())) + + (labels ((chase (path) + (if (memq (car path) (cdr path)) + (record-cycle (memq (car path) (nreverse path))) + (unless (memq (car path) been-here) + (push (car path) been-here) + (dolist (after (cpd-after (car path))) + (chase (cons after path)))))) + (record-cycle (cycle) + (let ((reasons ())) + (do* ((t1 cycle t2) + (t2 (cdr t1) (cdr t1))) + ((null t2)) + (let ((c1 (car t1)) + (c2 (car t2))) + (if (memq c2 (cpd-supers c1)) + (push (list c1 c2 :super) reasons) + (dolist (cpd all-cpds) + (when (memq c2 (memq c1 (cpd-supers cpd))) + (return + (push (list c1 c2 :in-supers cpd) reasons))))))) + (push (nreverse reasons) cycle-reasons)))) + + (dolist (cpd all-cpds) + (unless (zerop (cpd-count cpd)) + (chase (list cpd)))) + + cycle-reasons))) + diff --git a/pcl/gcl_pcl_ctypes.lisp b/pcl/gcl_pcl_ctypes.lisp new file mode 100644 index 0000000..bd2c7a6 --- /dev/null +++ b/pcl/gcl_pcl_ctypes.lisp @@ -0,0 +1,45 @@ +;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; + +(in-package :pcl) + +;;; +;;; The built-in method combination types as taken from page 1-31 of 88-002R. +;;; Note that the STANDARD method combination type is defined by hand in the +;;; file combin.lisp. +;;; + +(define-method-combination + :identity-with-one-argument t) +(define-method-combination and :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 max :identity-with-one-argument t) +(define-method-combination min :identity-with-one-argument t) +(define-method-combination nconc :identity-with-one-argument t) +(define-method-combination or :identity-with-one-argument t) +(define-method-combination progn :identity-with-one-argument t) + diff --git a/pcl/gcl_pcl_defclass.lisp b/pcl/gcl_pcl_defclass.lisp new file mode 100644 index 0000000..6a7f900 --- /dev/null +++ b/pcl/gcl_pcl_defclass.lisp @@ -0,0 +1,467 @@ +;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; + +(in-package :pcl) + +;;; +;;; MAKE-TOP-LEVEL-FORM is used by all PCL macros that appear `at top-level'. +;;; +;;; The original motiviation for this function was to deal with the bug in +;;; the Genera compiler that prevents lambda expressions in top-level forms +;;; other than DEFUN from being compiled. +;;; +;;; Now this function is used to grab other functionality as well. This +;;; includes: +;;; - Preventing the grouping of top-level forms. For example, a +;;; DEFCLASS followed by a DEFMETHOD may not want to be grouped +;;; into the same top-level form. +;;; - Telling the programming environment what the pretty version +;;; of the name of this form is. This is used by WARN. +;;; +(defun make-top-level-form (name times form) + (flet ((definition-name () + (if (and (listp name) + (memq (car name) '(defmethod defclass class method method-combination))) + (format nil "~A~{ ~S~}" + (capitalize-words (car name) ()) (cdr name)) + (format nil "~S" name)))) + (definition-name) + #+Genera + (progn + #-Genera-Release-8 + (let ((thunk-name (gensym "TOP-LEVEL-FORM"))) + `(eval-when ,times + (defun ,thunk-name () + (declare (sys:function-parent + ,(cond ((listp name) + (case (first name) + (defmethod `(method ,@(rest name))) + (otherwise (second name)))) + (t name)) + ,(cond ((listp name) + (case (first name) + ((defmethod defgeneric) 'defun) + ((defclass) 'defclass) + (otherwise (first name)))) + (t 'defun)))) + ,form) + (,thunk-name))) + #+Genera-Release-8 + `(compiler-let ((compiler:default-warning-function ',name)) + (eval-when ,times + (funcall #'(lambda () + (declare ,(cond ((listp name) + (case (first name) + ((defclass) + `(sys:function-parent ,(second name) defclass)) + ((defmethod) + `(sys:function-name (method ,@(rest name)))) + ((defgeneric) + `(sys:function-name ,(second name))) + (otherwise + `(sys:function-name ,name)))) + (t + `(sys:function-name ,name)))) + ,form))))) + #+LCL3.0 + `(compiler-let ((lucid::*compiler-message-string* + (or lucid::*compiler-message-string* + ,(definition-name)))) + (eval-when ,times ,form)) + #+cmu + (if (member 'compile times) + `(eval-when ,times ,form) + form) + #+kcl + (let* ((*print-pretty* nil) + (thunk-name (gensym (definition-name)))) + (gensym "G") ; set the prefix back to something less confusing. + `(eval-when ,times + (defun ,thunk-name () + ,form) + (,thunk-name))) + #-(or Genera LCL3.0 cmu kcl) + (make-progn `',name `(eval-when ,times ,form)))) + +(defun make-progn (&rest forms) + (let ((progn-form nil)) + (labels ((collect-forms (forms) + (unless (null forms) + (collect-forms (cdr forms)) + (if (and (listp (car forms)) + (eq (caar forms) 'progn)) + (collect-forms (cdar forms)) + (push (car forms) progn-form))))) + (collect-forms forms) + (cons 'progn progn-form)))) + + + +;;; +;;; Like the DEFMETHOD macro, the expansion of the DEFCLASS macro is fixed. +;;; DEFCLASS always expands into a call to LOAD-DEFCLASS. Until the meta- +;;; braid is set up, LOAD-DEFCLASS has a special definition which simply +;;; collects all class definitions up, when the metabraid is initialized it +;;; is done from those class definitions. +;;; +;;; After the metabraid has been setup, and the protocol for defining classes +;;; has been defined, the real definition of LOAD-DEFCLASS is installed by the +;;; file defclass.lisp +;;; +(defmacro DEFCLASS (name direct-superclasses direct-slots &rest options) + (declare (indentation 2 4 3 1)) + (expand-defclass name direct-superclasses direct-slots options)) + +(defun expand-defclass (name supers slots options) + (declare (special *defclass-times* *boot-state* *the-class-structure-class*)) + (setq supers (copy-tree supers) + slots (copy-tree slots) + options (copy-tree options)) + (let ((metaclass 'standard-class)) + (dolist (option options) + (if (not (listp option)) + (error "~S is not a legal defclass option." option) + (when (eq (car option) ':metaclass) + (unless (legal-class-name-p (cadr option)) + (error "The value of the :metaclass option (~S) is not a~%~ + legal class name." + (cadr option))) + #-cmu17 + (setq metaclass (cadr option)) + #+cmu17 + (setq metaclass + (case (cadr option) + (lisp:standard-class 'standard-class) + (lisp:structure-class 'structure-class) + (t (cadr option)))) + (setf options (remove option options)) + (return t)))) + + (let ((*initfunctions* ()) + (*accessors* ()) ;Truly a crock, but we got + (*readers* ()) ;to have it to live nicely. + (*writers* ())) + (declare (special *initfunctions* *accessors* *readers* *writers*)) + (let ((canonical-slots + (mapcar #'(lambda (spec) + (canonicalize-slot-specification name spec)) + slots)) + (other-initargs + (mapcar #'(lambda (option) + (canonicalize-defclass-option name option)) + options)) + (defstruct-p (and (eq *boot-state* 'complete) + (let ((mclass (find-class metaclass nil))) + (and mclass + (*subtypep mclass + *the-class-structure-class*)))))) + (do-standard-defsetfs-for-defclass *accessors*) + (let ((defclass-form + (make-top-level-form `(defclass ,name) + (if defstruct-p '(load eval) *defclass-times*) + `(progn + ,@(mapcar #'(lambda (x) + `(declaim (ftype (function (t) t) ,x))) + #+cmu *readers* #-cmu nil) + ,@(mapcar #'(lambda (x) + #-setf (when (consp x) + (setq x (get-setf-function-name (cadr x)))) + `(declaim (ftype (function (t t) t) ,x))) + #+cmu *writers* #-cmu nil) + (let ,(mapcar #'cdr *initfunctions*) + (load-defclass ',name + ',metaclass + ',supers + (list ,@canonical-slots) + (list ,@(apply #'append + (when defstruct-p + '(:from-defclass-p t)) + other-initargs)) + ',*accessors*)))))) + (if defstruct-p + (progn + (eval defclass-form) ; define the class now, so that + `(progn ; the defstruct can be compiled. + ,(class-defstruct-form (find-class name)) + ,defclass-form)) + (progn + (when (and (eq *boot-state* 'complete) + (not (member 'compile *defclass-times*))) + (inform-type-system-about-std-class name)) + defclass-form))))))) + +(defun make-initfunction (initform) + (declare (special *initfunctions*)) + (cond ((or (eq initform 't) + (equal initform ''t)) + '(function true)) + ((or (eq initform 'nil) + (equal initform ''nil)) + '(function false)) + ((or (eql initform '0) + (equal initform ''0)) + '(function zero)) + (t + (let ((entry (assoc initform *initfunctions* :test #'equal))) + (unless entry + (setq entry (list initform + (gensym) + `(function (lambda () ,initform)))) + (push entry *initfunctions*)) + (cadr entry))))) + +(defun canonicalize-slot-specification (class-name spec) + (declare (special *accessors* *readers* *writers*)) + (cond ((and (symbolp spec) + (not (keywordp spec)) + (not (memq spec '(t nil)))) + `'(:name ,spec)) + ((not (consp spec)) + (error "~S is not a legal slot specification." spec)) + ((null (cdr spec)) + `'(:name ,(car spec))) + ((null (cddr spec)) + (error "In DEFCLASS ~S, the slot specification ~S is obsolete.~%~ + Convert it to ~S" + class-name spec (list (car spec) :initform (cadr spec)))) + (t + (let* ((name (pop spec)) + (readers ()) + (writers ()) + (initargs ()) + (unsupplied (list nil)) + (initform (getf spec :initform unsupplied))) + (doplist (key val) spec + (case key + (:accessor (push val *accessors*) + (push val readers) + (push `(setf ,val) writers)) + (:reader (push val readers)) + (:writer (push val writers)) + (:initarg (push val initargs)))) + (loop (unless (remf spec :accessor) (return))) + (loop (unless (remf spec :reader) (return))) + (loop (unless (remf spec :writer) (return))) + (loop (unless (remf spec :initarg) (return))) + (setq *writers* (append writers *writers*)) + (setq *readers* (append readers *readers*)) + (setq spec `(:name ',name + :readers ',readers + :writers ',writers + :initargs ',initargs + ',spec)) + (if (eq initform unsupplied) + `(list* ,@spec) + `(list* :initfunction ,(make-initfunction initform) ,@spec)))))) + +(defun canonicalize-defclass-option (class-name option) + (declare (ignore class-name)) + (case (car option) + (:default-initargs + (let ((canonical ())) + (let (key val (tail (cdr option))) + (loop (when (null tail) (return nil)) + (setq key (pop tail) + val (pop tail)) + (push ``(,',key ,,(make-initfunction val) ,',val) canonical)) + `(':direct-default-initargs (list ,@(nreverse canonical)))))) + (otherwise + `(',(car option) ',(cdr option))))) + + +;;; +;;; This is the early definition of load-defclass. It just collects up all +;;; the class definitions in a list. Later, in the file braid1.lisp, these +;;; are actually defined. +;;; + + +;;; +;;; Each entry in *early-class-definitions* is an early-class-definition. +;;; +;;; +(defparameter *early-class-definitions* ()) + +(defun early-class-definition (class-name) + (or (find class-name *early-class-definitions* :key #'ecd-class-name) + (error "~S is not a class in *early-class-definitions*." class-name))) + +(defun make-early-class-definition + (name source metaclass + superclass-names canonical-slots other-initargs) + (list 'early-class-definition + name source metaclass + superclass-names canonical-slots other-initargs)) + +(defun ecd-class-name (ecd) (nth 1 ecd)) +(defun ecd-source (ecd) (nth 2 ecd)) +(defun ecd-metaclass (ecd) (nth 3 ecd)) +(defun ecd-superclass-names (ecd) (nth 4 ecd)) +(defun ecd-canonical-slots (ecd) (nth 5 ecd)) +(defun ecd-other-initargs (ecd) (nth 6 ecd)) + +(defvar *early-class-slots* nil) + +(defun canonical-slot-name (canonical-slot) + (getf canonical-slot :name)) + +(defun early-class-slots (class-name) + (cdr (or (assoc class-name *early-class-slots*) + (let ((a (cons class-name + (mapcar #'canonical-slot-name + (early-collect-inheritance class-name))))) + (push a *early-class-slots*) + a)))) + +(defun early-class-size (class-name) + (length (early-class-slots class-name))) + +(defun early-collect-inheritance (class-name) + ;;(declare (values slots cpl default-initargs direct-subclasses)) + (let ((cpl (early-collect-cpl class-name))) + (values (early-collect-slots cpl) + cpl + (early-collect-default-initargs cpl) + (gathering1 (collecting) + (dolist (definition *early-class-definitions*) + (when (memq class-name (ecd-superclass-names definition)) + (gather1 (ecd-class-name definition)))))))) + +(defun early-collect-slots (cpl) + (let* ((definitions (mapcar #'early-class-definition cpl)) + (super-slots (mapcar #'ecd-canonical-slots definitions)) + (slots (apply #'append (reverse super-slots)))) + (dolist (s1 slots) + (let ((name1 (canonical-slot-name s1))) + (dolist (s2 (cdr (memq s1 slots))) + (when (eq name1 (canonical-slot-name s2)) + (error "More than one early class defines a slot with the~%~ + name ~S. This can't work because the bootstrap~%~ + object system doesn't know how to compute effective~%~ + slots." + name1))))) + slots)) + +(defun early-collect-cpl (class-name) + (labels ((walk (c) + (let* ((definition (early-class-definition c)) + (supers (ecd-superclass-names definition))) + (cons c + (apply #'append (mapcar #'early-collect-cpl supers)))))) + (remove-duplicates (walk class-name) :from-end nil :test #'eq))) + +(defun early-collect-default-initargs (cpl) + (let ((default-initargs ())) + (dolist (class-name cpl) + (let* ((definition (early-class-definition class-name)) + (others (ecd-other-initargs definition))) + (loop (when (null others) (return nil)) + (let ((initarg (pop others))) + (unless (eq initarg :direct-default-initargs) + (error "The defclass option ~S is not supported by the bootstrap~%~ + object system." + initarg))) + (setq default-initargs + (nconc default-initargs (reverse (pop others))))))) + (reverse default-initargs))) + +(defun bootstrap-slot-index (class-name slot-name) + (or (position slot-name (early-class-slots class-name)) + (error "~S not found" slot-name))) + +;;; +;;; bootstrap-get-slot and bootstrap-set-slot are used to access and change +;;; the values of slots during bootstrapping. During bootstrapping, there +;;; are only two kinds of objects whose slots we need to access, CLASSes +;;; and SLOT-DEFINITIONs. The first argument to these functions tells whether the +;;; object is a CLASS or a SLOT-DEFINITION. +;;; +;;; Note that the way this works it stores the slot in the same place in +;;; memory that the full object system will expect to find it later. This +;;; is critical to the bootstrapping process, the whole changeover to the +;;; full object system is predicated on this. +;;; +;;; One important point is that the layout of standard classes and standard +;;; slots must be computed the same way in this file as it is by the full +;;; object system later. +;;; +(defmacro bootstrap-get-slot (type object slot-name) + `(instance-ref (get-slots ,object) (bootstrap-slot-index ,type ,slot-name))) + +(defun bootstrap-set-slot (type object slot-name new-value) + (setf (bootstrap-get-slot type object slot-name) new-value)) + +(defun early-class-name (class) + (bootstrap-get-slot 'class class 'name)) + +(defun early-class-precedence-list (class) + (bootstrap-get-slot 'pcl-class class 'class-precedence-list)) + +(defun early-class-name-of (instance) + (early-class-name (class-of instance))) + +(defun early-class-slotds (class) + (bootstrap-get-slot 'slot-class class 'slots)) + +(defun early-slot-definition-name (slotd) + (bootstrap-get-slot 'standard-effective-slot-definition slotd 'name)) + +(defun early-slot-definition-location (slotd) + (bootstrap-get-slot 'standard-effective-slot-definition slotd 'location)) + +(defun early-accessor-method-slot-name (method) + (bootstrap-get-slot 'standard-accessor-method method 'slot-name)) + +(unless (fboundp 'class-name-of) + (setf (symbol-function 'class-name-of) + (symbol-function 'early-class-name-of))) + +(defun early-class-direct-subclasses (class) + (bootstrap-get-slot 'class class 'direct-subclasses)) + +(proclaim '(notinline load-defclass)) +(defun load-defclass + (name metaclass supers canonical-slots canonical-options accessor-names) + (setq supers (copy-tree supers) + canonical-slots (copy-tree canonical-slots) + canonical-options (copy-tree canonical-options)) + (do-standard-defsetfs-for-defclass accessor-names) + (when (eq metaclass 'standard-class) + (inform-type-system-about-std-class name)) + (let ((ecd + (make-early-class-definition name + (load-truename) + metaclass + supers + canonical-slots + canonical-options)) + (existing + (find name *early-class-definitions* :key #'ecd-class-name))) + (setq *early-class-definitions* + (cons ecd (remove existing *early-class-definitions*))) + ecd)) + diff --git a/pcl/gcl_pcl_defcombin.lisp b/pcl/gcl_pcl_defcombin.lisp new file mode 100644 index 0000000..61222ad --- /dev/null +++ b/pcl/gcl_pcl_defcombin.lisp @@ -0,0 +1,430 @@ +;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; + +(in-package :pcl) + +;;; +;;; DEFINE-METHOD-COMBINATION +;;; + +(defmacro define-method-combination (&whole form &rest args) + (declare (ignore args)) + (if (and (cddr form) + (listp (caddr form))) + (expand-long-defcombin form) + (expand-short-defcombin form))) + + +;;; +;;; STANDARD method combination +;;; +;;; The STANDARD method combination type is implemented directly by the class +;;; STANDARD-METHOD-COMBINATION. The method on COMPUTE-EFFECTIVE-METHOD does +;;; standard method combination directly and is defined by hand in the file +;;; combin.lisp. The method for FIND-METHOD-COMBINATION must appear in this +;;; file for bootstrapping reasons. +;;; +;;; A commented out copy of this definition appears in combin.lisp. +;;; If you change this definition here, be sure to change it there +;;; also. +;;; +(defmethod find-method-combination ((generic-function generic-function) + (type (eql 'standard)) + options) + (when options + (method-combination-error + "The method combination type STANDARD accepts no options.")) + *standard-method-combination*) + + + +;;; +;;; short method combinations +;;; +;;; Short method combinations all follow the same rule for computing the +;;; effective method. So, we just implement that rule once. Each short +;;; method combination object just reads the parameters out of the object +;;; and runs the same rule. +;;; +;;; +(defclass short-method-combination (standard-method-combination) + ((operator + :reader short-combination-operator + :initarg :operator) + (identity-with-one-argument + :reader short-combination-identity-with-one-argument + :initarg :identity-with-one-argument)) + (:predicate-name short-method-combination-p)) + +(defun expand-short-defcombin (whole) + (let* ((type (cadr whole)) + (documentation + (getf (cddr whole) :documentation "")) + (identity-with-one-arg + (getf (cddr whole) :identity-with-one-argument nil)) + (operator + (getf (cddr whole) :operator type))) + (make-top-level-form `(define-method-combination ,type) + '(load eval) + `(load-short-defcombin + ',type ',operator ',identity-with-one-arg ',documentation)))) + +(defun load-short-defcombin (type operator ioa doc) + (let* ((truename (load-truename)) + (specializers + (list (find-class 'generic-function) + (intern-eql-specializer type) + *the-class-t*)) + (old-method + (get-method #'find-method-combination () specializers nil)) + (new-method nil)) + (setq new-method + (make-instance 'standard-method + :qualifiers () + :specializers specializers + :lambda-list '(generic-function type options) + :function #'(lambda (gf type options) + (declare (ignore gf)) + (do-short-method-combination + type options operator ioa new-method doc)) + :definition-source `((define-method-combination ,type) ,truename))) + (when old-method + (remove-method #'find-method-combination old-method)) + (add-method #'find-method-combination new-method))) + +(defun do-short-method-combination (type options operator ioa method doc) + (cond ((null options) (setq options '(:most-specific-first))) + ((equal options '(:most-specific-first))) + ((equal options '(:most-specific-last))) + (t + (method-combination-error + "Illegal options to a short method combination type.~%~ + The method combination type ~S accepts one option which~%~ + must be either :MOST-SPECIFIC-FIRST or :MOST-SPECIFIC-LAST." + type))) + (make-instance 'short-method-combination + :type type + :options options + :operator operator + :identity-with-one-argument ioa + :definition-source method + :documentation doc)) + +(defmethod compute-effective-method ((generic-function generic-function) + (combin short-method-combination) + applicable-methods) + (let ((type (method-combination-type combin)) + (operator (short-combination-operator combin)) + (ioa (short-combination-identity-with-one-argument combin)) + (around ()) + (primary ())) + (dolist (m applicable-methods) + (let ((qualifiers (method-qualifiers m))) + (flet ((lose (method why) + (invalid-method-error + method + "The method ~S ~A.~%~ + The method combination type ~S was defined with the~%~ + short form of DEFINE-METHOD-COMBINATION and so requires~%~ + all methods have either the single qualifier ~S or the~%~ + single qualifier :AROUND." + method why type type))) + (cond ((null qualifiers) + (lose m "has no qualifiers")) + ((cdr qualifiers) + (lose m "has more than one qualifier")) + ((eq (car qualifiers) :around) + (push m around)) + ((eq (car qualifiers) type) + (push m primary)) + (t + (lose m "has an illegal qualifier")))))) + (setq around (nreverse around) + primary (nreverse primary)) + (let ((main-method + (if (and (null (cdr primary)) + (not (null ioa))) + `(call-method ,(car primary) ()) + `(,operator ,@(mapcar #'(lambda (m) `(call-method ,m ())) + primary))))) + (cond ((null primary) + `(error "No ~S methods for the generic function ~S." + ',type ',generic-function)) + ((null around) main-method) + (t + `(call-method ,(car around) + (,@(cdr around) (make-method ,main-method)))))))) + + +;;; +;;; long method combinations +;;; +;;; + +(defclass long-method-combination (standard-method-combination) + ((function :initarg :function + :reader long-method-combination-function))) + +(defun expand-long-defcombin (form) + (let ((type (cadr form)) + (lambda-list (caddr form)) + (method-group-specifiers (cadddr form)) + (body (cddddr form)) + (arguments-option ()) + (gf-var nil)) + (when (and (consp (car body)) (eq (caar body) :arguments)) + (setq arguments-option (cdr (pop body)))) + (when (and (consp (car body)) (eq (caar body) :generic-function)) + (setq gf-var (cadr (pop body)))) + (multiple-value-bind (documentation function) + (make-long-method-combination-function + type lambda-list method-group-specifiers arguments-option gf-var + body) + (make-top-level-form `(define-method-combination ,type) + '(load eval) + `(load-long-defcombin ',type ',documentation #',function))))) + +(defvar *long-method-combination-functions* (make-hash-table :test #'eq)) + +(defun load-long-defcombin (type doc function) + (let* ((specializers + (list (find-class 'generic-function) + (intern-eql-specializer type) + *the-class-t*)) + (old-method + (get-method #'find-method-combination () specializers nil)) + (new-method + (make-instance 'standard-method + :qualifiers () + :specializers specializers + :lambda-list '(generic-function type options) + :function #'(lambda (generic-function type options) + (declare (ignore generic-function)) + (make-instance 'long-method-combination + :type type + :documentation doc + :options options)) + :definition-source `((define-method-combination ,type) + ,(load-truename))))) + (setf (gethash type *long-method-combination-functions*) function) + (when old-method (remove-method #'find-method-combination old-method)) + (add-method #'find-method-combination new-method))) + +(defmethod compute-effective-method ((generic-function generic-function) + (combin long-method-combination) + applicable-methods) + (funcall (gethash (method-combination-type combin) + *long-method-combination-functions*) + generic-function + combin + applicable-methods)) + +;;; +;;; +;;; +(defun make-long-method-combination-function + (type ll method-group-specifiers arguments-option gf-var body) + ;;(declare (values documentation function)) + (declare (ignore type)) + (multiple-value-bind (documentation declarations real-body) + (extract-declarations body) + + (let ((wrapped-body + (wrap-method-group-specifier-bindings method-group-specifiers + declarations + real-body))) + (when gf-var + (push `(,gf-var .generic-function.) (cadr wrapped-body))) + + (when arguments-option + (setq wrapped-body (deal-with-arguments-option wrapped-body + arguments-option))) + + (when ll + (setq wrapped-body + `(apply #'(lambda ,ll ,wrapped-body) + (method-combination-options .method-combination.)))) + + (values + documentation + `(lambda (.generic-function. .method-combination. .applicable-methods.) + (progn .generic-function. .method-combination. .applicable-methods.) + (block .long-method-combination-function. ,wrapped-body)))))) +;; +;; parse-method-group-specifiers parse the method-group-specifiers +;; + +(defun wrap-method-group-specifier-bindings + (method-group-specifiers declarations real-body) + (with-gathering ((names (collecting)) + (specializer-caches (collecting)) + (cond-clauses (collecting)) + (required-checks (collecting)) + (order-cleanups (collecting))) + (dolist (method-group-specifier method-group-specifiers) + (multiple-value-bind (name tests description order required) + (parse-method-group-specifier method-group-specifier) + (declare (ignore description)) + (let ((specializer-cache (gensym))) + (gather name names) + (gather specializer-cache specializer-caches) + (gather `((or ,@tests) + (if (equal ,specializer-cache .specializers.) + (return-from .long-method-combination-function. + '(error "More than one method of type ~S ~ + with the same specializers." + ',name)) + (setq ,specializer-cache .specializers.)) + (push .method. ,name)) + cond-clauses) + (when required + (gather `(when (null ,name) + (return-from .long-method-combination-function. + '(error "No ~S methods." ',name))) + required-checks)) + (loop (unless (and (constantp order) + (neq order (setq order (eval order)))) + (return t))) + (gather (cond ((eq order :most-specific-first) + `(setq ,name (nreverse ,name))) + ((eq order :most-specific-last) ()) + (t + `(ecase ,order + (:most-specific-first + (setq ,name (nreverse ,name))) + (:most-specific-last)))) + order-cleanups)))) + `(let (,@names ,@specializer-caches) + ,@declarations + (dolist (.method. .applicable-methods.) + (let ((.qualifiers. (method-qualifiers .method.)) + (.specializers. (method-specializers .method.))) + (progn .qualifiers. .specializers.) + (cond ,@cond-clauses))) + ,@required-checks + ,@order-cleanups + ,@real-body))) + +(defun parse-method-group-specifier (method-group-specifier) + ;;(declare (values name tests description order required)) + (let* ((name (pop method-group-specifier)) + (patterns ()) + (tests + (gathering1 (collecting) + (block collect-tests + (loop + (if (or (null method-group-specifier) + (memq (car method-group-specifier) + '(:description :order :required))) + (return-from collect-tests t) + (let ((pattern (pop method-group-specifier))) + (push pattern patterns) + (gather1 (parse-qualifier-pattern name pattern))))))))) + (values name + tests + (getf method-group-specifier :description + (make-default-method-group-description patterns)) + (getf method-group-specifier :order :most-specific-first) + (getf method-group-specifier :required nil)))) + +(defun parse-qualifier-pattern (name pattern) + (cond ((eq pattern '()) `(null .qualifiers.)) + ((eq pattern '*) 't) + ((symbolp pattern) `(,pattern .qualifiers.)) + ((listp pattern) `(qualifier-check-runtime ',pattern .qualifiers.)) + (t (error "In the method group specifier ~S,~%~ + ~S isn't a valid qualifier pattern." + name pattern)))) + +(defun qualifier-check-runtime (pattern qualifiers) + (loop (cond ((and (null pattern) (null qualifiers)) + (return t)) + ((eq pattern '*) (return t)) + ((and pattern qualifiers (eq (car pattern) (car qualifiers))) + (pop pattern) + (pop qualifiers)) + (t (return nil))))) + +(defun make-default-method-group-description (patterns) + (if (cdr patterns) + (format nil + "methods matching one of the patterns: ~{~S, ~} ~S" + (butlast patterns) (car (last patterns))) + (format nil + "methods matching the pattern: ~S" + (car patterns)))) + + + +;;; +;;; This baby is a complete mess. I can't believe we put it in this +;;; way. No doubt this is a large part of what drives MLY crazy. +;;; +;;; At runtime (when the effective-method is run), we bind an intercept +;;; lambda-list to the arguments to the generic function. +;;; +;;; At compute-effective-method time, the symbols in the :arguments +;;; option are bound to the symbols in the intercept lambda list. +;;; +(defun deal-with-arguments-option (wrapped-body arguments-option) + (let* ((intercept-lambda-list + (gathering1 (collecting) + (dolist (arg arguments-option) + (if (memq arg lambda-list-keywords) + (gather1 arg) + (gather1 (gensym)))))) + (intercept-rebindings + (gathering1 (collecting) + (iterate ((arg (list-elements arguments-option)) + (int (list-elements intercept-lambda-list))) + (unless (memq arg lambda-list-keywords) + (gather1 `(,arg ',int))))))) + ;; + ;; + (setf (cadr wrapped-body) + (append intercept-rebindings (cadr wrapped-body))) + ;; + ;; Be sure to fill out the intercept lambda list so that it can + ;; be too short if it wants to. + ;; + (cond ((memq '&rest intercept-lambda-list)) + ((memq '&allow-other-keys intercept-lambda-list)) + ((memq '&key intercept-lambda-list) + (setq intercept-lambda-list + (append intercept-lambda-list '(&allow-other-keys)))) + (t + (setq intercept-lambda-list + (append intercept-lambda-list '(&rest .ignore.))))) + + `(let ((inner-result. ,wrapped-body)) + `(apply #'(lambda ,',intercept-lambda-list + ,,(when (memq '.ignore. intercept-lambda-list) + ''(declare (ignore .ignore.))) + ,inner-result.) + .combined-method-args.)))) + + diff --git a/pcl/gcl_pcl_defs.lisp b/pcl/gcl_pcl_defs.lisp new file mode 100644 index 0000000..fdb8d48 --- /dev/null +++ b/pcl/gcl_pcl_defs.lisp @@ -0,0 +1,973 @@ +;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; + +(in-package :pcl) + +(eval-when (compile load eval) + +(defvar *defclass-times* '(load eval)) ;Probably have to change this + ;if you use defconstructor. +(defvar *defmethod-times* '(load eval)) +(defvar *defgeneric-times* '(load eval)) + +; defvar is now actually in macros +;(defvar *boot-state* ()) ;NIL + ;EARLY + ;BRAID + ;COMPLETE +(defvar *fegf-started-p* nil) + + +) + +(eval-when (load eval) + (when (eq *boot-state* 'complete) + (error "Trying to load (or compile) PCL in an environment in which it~%~ + has already been loaded. This doesn't work, you will have to~%~ + get a fresh lisp (reboot) and then load PCL.")) + (when *boot-state* + (cerror "Try loading (or compiling) PCL anyways." + "Trying to load (or compile) PCL in an environment in which it~%~ + has already been partially loaded. This may not work, you may~%~ + need to get a fresh lisp (reboot) and then load PCL.")) + ) + + + +;;; +;;; This is like fdefinition on the Lispm. If Common Lisp had something like +;;; function specs I wouldn't need this. On the other hand, I don't like the +;;; way this really works so maybe function specs aren't really right either? +;;; +;;; I also don't understand the real implications of a Lisp-1 on this sort of +;;; thing. Certainly some of the lossage in all of this is because these +;;; SPECs name global definitions. +;;; +;;; Note that this implementation is set up so that an implementation which +;;; has a 'real' function spec mechanism can use that instead and in that way +;;; get rid of setf generic function names. +;;; +(defmacro parse-gspec (spec + (non-setf-var . non-setf-case) + (setf-var . setf-case)) + (declare (indentation 1 1)) + #+setf (declare (ignore setf-var setf-case)) + (once-only (spec) + `(cond (#-setf (symbolp ,spec) #+setf t + (let ((,non-setf-var ,spec)) ,@non-setf-case)) + #-setf + ((and (listp ,spec) + (eq (car ,spec) 'setf) + (symbolp (cadr ,spec))) + (let ((,setf-var (cadr ,spec))) ,@setf-case)) + #-setf + (t + (error + "Can't understand ~S as a generic function specifier.~%~ + It must be either a symbol which can name a function or~%~ + a list like ~S, where the car is the symbol ~S and the cadr~%~ + is a symbol which can name a generic function." + ,spec '(setf ) 'setf))))) + +;;; +;;; If symbol names a function which is traced or advised, return the +;;; unadvised, traced etc. definition. This lets me get at the generic +;;; function object even when it is traced. +;;; +(defun unencapsulated-fdefinition (symbol) + #+Lispm (si:fdefinition (si:unencapsulate-function-spec symbol)) + #+Lucid (lucid::get-unadvised-procedure (symbol-function symbol)) + #+excl (or (excl::encapsulated-basic-definition symbol) + (symbol-function symbol)) + #+xerox (il:virginfn symbol) + #+setf (fdefinition symbol) + #+kcl (symbol-function + (let ((sym (get symbol 'si::traced)) first-form) + (if (and sym + (consp (symbol-function symbol)) + (consp (setq first-form (nth 3 (symbol-function symbol)))) + (eq (car first-form) 'si::trace-call)) + sym + symbol))) + #-(or Lispm Lucid excl Xerox setf kcl) (symbol-function symbol)) + +;;; +;;; If symbol names a function which is traced or advised, redefine +;;; the `real' definition without affecting the advise. +;;; +(defun fdefine-carefully (name new-definition) + #+Lispm (si:fdefine name new-definition t t) + #+Lucid (let ((lucid::*redefinition-action* nil)) + (setf (symbol-function name) new-definition)) + #+excl (setf (symbol-function name) new-definition) + #+xerox (let ((advisedp (member name il:advisedfns :test #'eq)) + (brokenp (member name il:brokenfns :test #'eq))) + ;; In XeroxLisp (late of envos) tracing is implemented + ;; as a special case of "breaking". Advising, however, + ;; is treated specially. + (xcl:unadvise-function name :no-error t) + (xcl:unbreak-function name :no-error t) + (setf (symbol-function name) new-definition) + (when brokenp (xcl:rebreak-function name)) + (when advisedp (xcl:readvise-function name))) + #+(and setf (not cmu)) (setf (fdefinition name) new-definition) + #+kcl (setf (symbol-function + (let ((sym (get name 'si::traced)) first-form) + (if (and sym + (consp (symbol-function name)) + (consp (setq first-form + (nth 3 (symbol-function name)))) + (eq (car first-form) 'si::trace-call)) + sym + name))) + new-definition) + #+cmu (progn + (c::%%defun name new-definition nil) + (c::note-name-defined name :function) + new-definition) + #-(or Lispm Lucid excl Xerox setf kcl cmu) + (setf (symbol-function name) new-definition)) + +(defun gboundp (spec) + (parse-gspec spec + (name (fboundp name)) + (name (fboundp (get-setf-function-name name))))) + +(defun gmakunbound (spec) + (parse-gspec spec + (name (fmakunbound name)) + (name (fmakunbound (get-setf-function-name name))))) + +(defun gdefinition (spec) + (parse-gspec spec + (name (or #-setf (macro-function name) ;?? + (unencapsulated-fdefinition name))) + (name (unencapsulated-fdefinition (get-setf-function-name name))))) + +(defun #-setf SETF\ PCL\ GDEFINITION #+setf (setf gdefinition) (new-value spec) + (parse-gspec spec + (name (fdefine-carefully name new-value)) + (name (fdefine-carefully (get-setf-function-name name) new-value)))) + + +(proclaim '(special *the-class-t* + *the-class-vector* *the-class-symbol* + *the-class-string* *the-class-sequence* + *the-class-rational* *the-class-ratio* + *the-class-number* *the-class-null* *the-class-list* + *the-class-integer* *the-class-float* *the-class-cons* + *the-class-complex* *the-class-character* + *the-class-bit-vector* *the-class-array* + + *the-class-slot-object* + *the-class-standard-object* + *the-class-structure-object* + *the-class-class* + *the-class-generic-function* + *the-class-built-in-class* + *the-class-slot-class* + *the-class-structure-class* + *the-class-standard-class* + *the-class-funcallable-standard-class* + *the-class-method* + *the-class-standard-method* + *the-class-standard-reader-method* + *the-class-standard-writer-method* + *the-class-standard-boundp-method* + *the-class-standard-generic-function* + *the-class-standard-effective-slot-definition* + + *the-eslotd-standard-class-slots* + *the-eslotd-funcallable-standard-class-slots*)) + +(proclaim '(special *the-wrapper-of-t* + *the-wrapper-of-vector* *the-wrapper-of-symbol* + *the-wrapper-of-string* *the-wrapper-of-sequence* + *the-wrapper-of-rational* *the-wrapper-of-ratio* + *the-wrapper-of-number* *the-wrapper-of-null* + *the-wrapper-of-list* *the-wrapper-of-integer* + *the-wrapper-of-float* *the-wrapper-of-cons* + *the-wrapper-of-complex* *the-wrapper-of-character* + *the-wrapper-of-bit-vector* *the-wrapper-of-array*)) + +;;;; Type specifier hackery: + +;;; internal to this file. +(defun coerce-to-class (class &optional make-forward-referenced-class-p) + (if (symbolp class) + (or (find-class class (not make-forward-referenced-class-p)) + (ensure-class class)) + class)) + +;;; Interface +(defun specializer-from-type (type &aux args) + (when (consp type) + (setq args (cdr type) type (car type))) + (cond ((symbolp type) + (or (and (null args) (find-class type)) + (ecase type + (class (coerce-to-class (car args))) + (prototype (make-instance 'class-prototype-specializer + :object (coerce-to-class (car args)))) + (class-eq (class-eq-specializer (coerce-to-class (car args)))) + (eql (intern-eql-specializer (car args)))))) + #+cmu17 + ((and (null args) (typep type 'lisp:class)) + (or (kernel:class-pcl-class type) + (find-structure-class (lisp:class-name type)))) + ((specializerp type) type))) + +;;; interface +(defun type-from-specializer (specl) + (cond ((eq specl 't) + 't) + ((consp specl) + (unless (member (car specl) '(class prototype class-eq eql)) + (error "~S is not a legal specializer type" specl)) + specl) + ((progn + (when (symbolp specl) + ;;maybe (or (find-class specl nil) (ensure-class specl)) instead? + (setq specl (find-class specl))) + (or (not (eq *boot-state* 'complete)) + (specializerp specl))) + (specializer-type specl)) + (t + (error "~s is neither a type nor a specializer" specl)))) + +(defun type-class (type) + (declare (special *the-class-t*)) + (setq type (type-from-specializer type)) + (if (atom type) + (if (eq type 't) + *the-class-t* + (error "bad argument to type-class")) + (case (car type) + (eql (class-of (cadr type))) + (prototype (class-of (cadr type))) ;? + (class-eq (cadr type)) + (class (cadr type))))) + +(defun class-eq-type (class) + (specializer-type (class-eq-specializer class))) + +(defun inform-type-system-about-std-class (name) + (let ((predicate-name (make-type-predicate-name name))) + (setf (gdefinition predicate-name) (make-type-predicate name)) + (do-satisfies-deftype name predicate-name))) + +(defun make-type-predicate (name) + (let ((cell (find-class-cell name))) + #'(lambda (x) + (funcall (the function (find-class-cell-predicate cell)) x)))) + + +;This stuff isn't right. Good thing it isn't used. +;The satisfies predicate has to be a symbol. There is no way to +;construct such a symbol from a class object if class names change. +(defun class-predicate (class) + (when (symbolp class) (setq class (find-class class))) + #'(lambda (object) (memq class (class-precedence-list (class-of object))))) + +(defun make-class-eq-predicate (class) + (when (symbolp class) (setq class (find-class class))) + #'(lambda (object) (eq class (class-of object)))) + +(defun make-eql-predicate (eql-object) + #'(lambda (object) (eql eql-object object))) + +#|| ; The argument to satisfies must be a symbol. +(deftype class (&optional class) + (if class + `(satisfies ,(class-predicate class)) + `(satisfies ,(class-predicate 'class)))) + +(deftype class-eq (class) + `(satisfies ,(make-class-eq-predicate class))) +||# + +#-(or excl cmu17) +(deftype eql (type-object) + `(member ,type-object)) + + +;;; Internal to this file. +;;; +;;; These functions are a pale imitiation of their namesake. They accept +;;; class objects or types where they should. +;;; +(defun *normalize-type (type) + (cond ((consp type) + (if (member (car type) '(not and or)) + `(,(car type) ,@(mapcar #'*normalize-type (cdr type))) + (if (null (cdr type)) + (*normalize-type (car type)) + type))) + ((symbolp type) + (let ((class (find-class type nil))) + (if class + (let ((type (specializer-type class))) + (if (listp type) type `(,type))) + `(,type)))) + ((or (not (eq *boot-state* 'complete)) + (specializerp type)) + (specializer-type type)) + (t + (error "~s is not a type" type)))) + +;;; Not used... +#+nil +(defun unparse-type-list (tlist) + (mapcar #'unparse-type tlist)) + +;;; Not used... +#+nil +(defun unparse-type (type) + (if (atom type) + (if (specializerp type) + (unparse-type (specializer-type type)) + type) + (case (car type) + (eql type) + (class-eq `(class-eq ,(class-name (cadr type)))) + (class (class-name (cadr type))) + (t `(,(car type) ,@(unparse-type-list (cdr type))))))) + +;;; internal to this file... +(defun convert-to-system-type (type) + (case (car type) + ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type + (cdr type)))) + ((class class-eq) ; class-eq is impossible to do right + #-cmu17 (class-name (cadr type)) + #+cmu17 (kernel:layout-class (class-wrapper (cadr type)))) + (eql type) + (t (if (null (cdr type)) + (car type) + type)))) + +;;; not used... +#+nil +(defun *typep (object type) + (setq type (*normalize-type type)) + (cond ((member (car type) '(eql wrapper-eq class-eq class)) + (specializer-applicable-using-type-p type `(eql ,object))) + ((eq (car type) 'not) + (not (*typep object (cadr type)))) + (t + (typep object (convert-to-system-type type))))) + + +;;; *SUBTYPEP -- Interface +;;; +;Writing the missing NOT and AND clauses will improve +;the quality of code generated by generate-discrimination-net, but +;calling subtypep in place of just returning (values nil nil) can be +;very slow. *subtypep is used by PCL itself, and must be fast. +(defun *subtypep (type1 type2) + (if (equal type1 type2) + (values t t) + (if (eq *boot-state* 'early) + (values (eq type1 type2) t) + (let ((*in-precompute-effective-methods-p* t)) + (declare (special *in-precompute-effective-methods-p*)) + ;; *in-precompute-effective-methods-p* is not a good name. + ;; It changes the way class-applicable-using-class-p works. + (setq type1 (*normalize-type type1)) + (setq type2 (*normalize-type type2)) + (case (car type2) + (not + (values nil nil)) ; Should improve this. + (and + (values nil nil)) ; Should improve this. + ((eql wrapper-eq class-eq class) + (multiple-value-bind (app-p maybe-app-p) + (specializer-applicable-using-type-p type2 type1) + (values app-p (or app-p (not maybe-app-p))))) + (t + (subtypep (convert-to-system-type type1) + (convert-to-system-type type2)))))))) + +(defun do-satisfies-deftype (name predicate) + #+cmu17 (declare (ignore name predicate)) + #+(or :Genera (and :Lucid (not :Prime)) ExCL :coral) + (let* ((specifier `(satisfies ,predicate)) + (expand-fn #'(lambda (&rest ignore) + (declare (ignore ignore)) + specifier))) + ;; Specific ports can insert their own way of doing this. Many + ;; ports may find the expand-fn defined above useful. + ;; + (or #+:Genera + (setf (get name 'deftype) expand-fn) + #+(and :Lucid (not :Prime)) + (system::define-macro `(deftype ,name) expand-fn nil) + #+ExCL + (setf (get name 'excl::deftype-expander) expand-fn) + #+:coral + (setf (get name 'ccl::deftype-expander) expand-fn))) + #-(or :Genera (and :Lucid (not :Prime)) ExCL :coral cmu17) + ;; This is the default for ports for which we don't know any + ;; better. Note that for most ports, providing this definition + ;; should just speed up class definition. It shouldn't have an + ;; effect on performance of most user code. + (eval `(deftype ,name () '(satisfies ,predicate)))) + +(defun make-type-predicate-name (name &optional kind) + (if (symbol-package name) + (intern (format nil + "~@[~A ~]TYPE-PREDICATE ~A ~A" + kind + (package-name (symbol-package name)) + (symbol-name name)) + *the-pcl-package*) + (make-symbol (format nil + "~@[~A ~]TYPE-PREDICATE ~A" + kind + (symbol-name name))))) + + + +(defvar *built-in-class-symbols* ()) +(defvar *built-in-wrapper-symbols* ()) + +(defun get-built-in-class-symbol (class-name) + (or (cadr (assq class-name *built-in-class-symbols*)) + (let ((symbol (intern (format nil + "*THE-CLASS-~A*" + (symbol-name class-name)) + *the-pcl-package*))) + (push (list class-name symbol) *built-in-class-symbols*) + symbol))) + +(defun get-built-in-wrapper-symbol (class-name) + (or (cadr (assq class-name *built-in-wrapper-symbols*)) + (let ((symbol (intern (format nil + "*THE-WRAPPER-OF-~A*" + (symbol-name class-name)) + *the-pcl-package*))) + (push (list class-name symbol) *built-in-wrapper-symbols*) + symbol))) + + + + +(pushnew 'class *variable-declarations*) +(pushnew 'variable-rebinding *variable-declarations*) + +(defun variable-class (var env) + (caddr (variable-declaration 'class var env))) + +(defvar *name->class->slotd-table* (make-hash-table)) + + +;;; +;;; This is used by combined methods to communicate the next methods to +;;; the methods they call. This variable is captured by a lexical variable +;;; of the methods to give it the proper lexical scope. +;;; +(defvar *next-methods* nil) + +(defvar *not-an-eql-specializer* '(not-an-eql-specializer)) + +(defvar *umi-gfs*) +(defvar *umi-complete-classes*) +(defvar *umi-reorder*) + +(defvar *invalidate-discriminating-function-force-p* ()) +(defvar *invalid-dfuns-on-stack* ()) + + +(defvar *standard-method-combination*) + +(defvar *slotd-unsupplied* (list '*slotd-unsupplied*)) ;*** + + +(defmacro define-gf-predicate (predicate-name &rest classes) + `(progn + (defmethod ,predicate-name ((x t)) nil) + ,@(mapcar #'(lambda (c) `(defmethod ,predicate-name ((x ,c)) t)) + classes))) + +(defun make-class-predicate-name (name) + (intern (format nil "~A::~A class predicate" + (package-name (symbol-package name)) + name) + *the-pcl-package*)) + +(defun plist-value (object name) + (getf (object-plist object) name)) + +(defun #-setf SETF\ PCL\ PLIST-VALUE #+setf (setf plist-value) (new-value object name) + (if new-value + (setf (getf (object-plist object) name) new-value) + (progn + (remf (object-plist object) name) + nil))) + + + +(defvar *built-in-classes* + ;; + ;; name supers subs cdr of cpl + ;; prototype + '(;(t () (number sequence array character symbol) ()) + (number (t) (complex float rational) (t)) + (complex (number) () (number t) + #c(1 1)) + (float (number) () (number t) + 1.0) + (rational (number) (integer ratio) (number t)) + (integer (rational) () (rational number t) + 1) + (ratio (rational) () (rational number t) + 1/2) + + (sequence (t) (list vector) (t)) + (list (sequence) (cons null) (sequence t)) + (cons (list) () (list sequence t) + (nil)) + + + (array (t) (vector) (t) + #2A((NIL))) + (vector (array + sequence) (string bit-vector) (array sequence t) + #()) + (string (vector) () (vector array sequence t) + "") + (bit-vector (vector) () (vector array sequence t) + #*1) + (character (t) () (t) + #\c) + + (symbol (t) (null) (t) + symbol) + (null (symbol + list) () (symbol list sequence t) + nil))) + +#+cmu17 +(labels ((direct-supers (class) + (if (typep class 'lisp:built-in-class) + (kernel:built-in-class-direct-superclasses class) + (let ((inherits (kernel:layout-inherits + (kernel:class-layout class)))) + (list (svref inherits (1- (length inherits))))))) + (direct-subs (class) + (ext:collect ((res)) + (let ((subs (kernel:class-subclasses class))) + (when subs + (ext:do-hash (sub v subs) + (declare (ignore v)) + (when (member class (direct-supers sub)) + (res sub))))) + (res)))) + (ext:collect ((res)) + (dolist (bic kernel::built-in-classes) + (let* ((name (car bic)) + (class (lisp:find-class name))) + (unless (member name '(t kernel:instance kernel:funcallable-instance + function)) + (res `(,name + ,(mapcar #'lisp:class-name (direct-supers class)) + ,(mapcar #'lisp:class-name (direct-subs class)) + ,(map 'list #'(lambda (x) + (lisp:class-name (kernel:layout-class x))) + (reverse + (kernel:layout-inherits + (kernel:class-layout class)))) + ,(let ((found (assoc name *built-in-classes*))) + (if found (fifth found) 42))))))) + (setq *built-in-classes* (res)))) + + +;;; +;;; The classes that define the kernel of the metabraid. +;;; +(defclass t () () + (:metaclass built-in-class)) + +#+cmu17 +(progn + (defclass kernel:instance (t) () + (:metaclass built-in-class)) + + (defclass function (t) () + (:metaclass built-in-class)) + + (defclass kernel:funcallable-instance (function) () + (:metaclass built-in-class))) + +(defclass slot-object (#-cmu17 t #+cmu17 kernel:instance) () + (:metaclass slot-class)) + +(defclass structure-object (slot-object) () + (:metaclass structure-class)) + +(defstruct (#-cmu17 structure-object #+cmu17 dead-beef-structure-object + (:constructor |STRUCTURE-OBJECT class constructor|))) + + +(defclass standard-object (slot-object) ()) + +(defclass metaobject (standard-object) ()) + +(defclass specializer (metaobject) + ((type + :initform nil + :reader specializer-type))) + +(defclass definition-source-mixin (standard-object) + ((source + :initform (load-truename) + :reader definition-source + :initarg :definition-source))) + +(defclass plist-mixin (standard-object) + ((plist + :initform () + :accessor object-plist))) + +(defclass documentation-mixin (plist-mixin) + ()) + +(defclass dependent-update-mixin (plist-mixin) + ()) + +;;; +;;; The class CLASS is a specified basic class. It is the common superclass +;;; of any kind of class. That is any class that can be a metaclass must +;;; have the class CLASS in its class precedence list. +;;; +(defclass class (documentation-mixin dependent-update-mixin definition-source-mixin + specializer) + ((name + :initform nil + :initarg :name + :accessor class-name) + (class-eq-specializer + :initform nil + :reader class-eq-specializer) + (direct-superclasses + :initform () + :reader class-direct-superclasses) + (direct-subclasses + :initform () + :reader class-direct-subclasses) + (direct-methods + :initform (cons nil nil)) + (predicate-name + :initform nil + :reader class-predicate-name))) + +;;; +;;; The class PCL-CLASS is an implementation-specific common superclass of +;;; all specified subclasses of the class CLASS. +;;; +(defclass pcl-class (class) + ((class-precedence-list + :reader class-precedence-list) + (can-precede-list + :initform () + :reader class-can-precede-list) + (incompatible-superclass-list + :initform () + :accessor class-incompatible-superclass-list) + (wrapper + :initform nil + :reader class-wrapper) + (prototype + :initform nil + :reader class-prototype))) + +(defclass slot-class (pcl-class) + ((direct-slots + :initform () + :accessor class-direct-slots) + (slots + :initform () + :accessor class-slots) + (initialize-info + :initform nil + :accessor class-initialize-info))) + +;;; +;;; The class STD-CLASS is an implementation-specific common superclass of +;;; the classes STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS. +;;; +(defclass std-class (slot-class) + ()) + +(defclass standard-class (std-class) + ()) + +(defclass funcallable-standard-class (std-class) + ()) + +(defclass forward-referenced-class (pcl-class) ()) + +(defclass built-in-class (pcl-class) ()) + +(defclass structure-class (slot-class) + ((defstruct-form + :initform () + :accessor class-defstruct-form) + (defstruct-constructor + :initform nil + :accessor class-defstruct-constructor) + (from-defclass-p + :initform nil + :initarg :from-defclass-p))) + + +(defclass specializer-with-object (specializer) ()) + +(defclass exact-class-specializer (specializer) ()) + +(defclass class-eq-specializer (exact-class-specializer specializer-with-object) + ((object :initarg :class :reader specializer-class :reader specializer-object))) + +(defclass class-prototype-specializer (specializer-with-object) + ((object :initarg :class :reader specializer-class :reader specializer-object))) + +(defclass eql-specializer (exact-class-specializer specializer-with-object) + ((object :initarg :object :reader specializer-object + :reader eql-specializer-object))) + +(defvar *eql-specializer-table* (make-hash-table :test 'eql)) + +(defun intern-eql-specializer (object) + (or (gethash object *eql-specializer-table*) + (setf (gethash object *eql-specializer-table*) + (make-instance 'eql-specializer :object object)))) + + +;;; +;;; Slot definitions. +;;; +(defclass slot-definition (metaobject) + ((name + :initform nil + :initarg :name + :accessor slot-definition-name) + (initform + :initform nil + :initarg :initform + :accessor slot-definition-initform) + (initfunction + :initform nil + :initarg :initfunction + :accessor slot-definition-initfunction) + (readers + :initform nil + :initarg :readers + :accessor slot-definition-readers) + (writers + :initform nil + :initarg :writers + :accessor slot-definition-writers) + (initargs + :initform nil + :initarg :initargs + :accessor slot-definition-initargs) + (type + :initform t + :initarg :type + :accessor slot-definition-type) + (documentation + :initform "" + :initarg :documentation) + (class + :initform nil + :initarg :class + :accessor slot-definition-class))) + +(defclass standard-slot-definition (slot-definition) + ((allocation + :initform :instance + :initarg :allocation + :accessor slot-definition-allocation))) + +(defclass structure-slot-definition (slot-definition) + ((defstruct-accessor-symbol + :initform nil + :initarg :defstruct-accessor-symbol + :accessor slot-definition-defstruct-accessor-symbol) + (internal-reader-function + :initform nil + :initarg :internal-reader-function + :accessor slot-definition-internal-reader-function) + (internal-writer-function + :initform nil + :initarg :internal-writer-function + :accessor slot-definition-internal-writer-function))) + +(defclass direct-slot-definition (slot-definition) + ()) + +(defclass effective-slot-definition (slot-definition) + ((reader-function ; #'(lambda (object) ...) + :accessor slot-definition-reader-function) + (writer-function ; #'(lambda (new-value object) ...) + :accessor slot-definition-writer-function) + (boundp-function ; #'(lambda (object) ...) + :accessor slot-definition-boundp-function) + (accessor-flags + :initform 0))) + +(defclass standard-direct-slot-definition (standard-slot-definition + direct-slot-definition) + ()) + +(defclass standard-effective-slot-definition (standard-slot-definition + effective-slot-definition) + ((location ; nil, a fixnum, a cons: (slot-name . value) + :initform nil + :accessor slot-definition-location))) + +(defclass structure-direct-slot-definition (structure-slot-definition + direct-slot-definition) + ()) + +(defclass structure-effective-slot-definition (structure-slot-definition + effective-slot-definition) + ()) + +(defclass method (metaobject) ()) + +(defclass standard-method (definition-source-mixin plist-mixin method) + ((generic-function + :initform nil + :accessor method-generic-function) +; (qualifiers +; :initform () +; :initarg :qualifiers +; :reader method-qualifiers) + (specializers + :initform () + :initarg :specializers + :reader method-specializers) + (lambda-list + :initform () + :initarg :lambda-list + :reader method-lambda-list) + (function + :initform nil + :initarg :function) ;no writer + (fast-function + :initform nil + :initarg :fast-function ;no writer + :reader method-fast-function) +; (documentation +; :initform nil +; :initarg :documentation +; :reader method-documentation) + )) + +(defclass standard-accessor-method (standard-method) + ((slot-name :initform nil + :initarg :slot-name + :reader accessor-method-slot-name) + (slot-definition :initform nil + :initarg :slot-definition + :reader accessor-method-slot-definition))) + +(defclass standard-reader-method (standard-accessor-method) ()) + +(defclass standard-writer-method (standard-accessor-method) ()) + +(defclass standard-boundp-method (standard-accessor-method) ()) + +(defclass generic-function (dependent-update-mixin + definition-source-mixin + documentation-mixin + metaobject + #+cmu17 kernel:funcallable-instance) + () + (:metaclass funcallable-standard-class)) + +(defclass standard-generic-function (generic-function) + ((name + :initform nil + :initarg :name + :accessor generic-function-name) + (methods + :initform () + :accessor generic-function-methods) + (method-class + :initarg :method-class + :accessor generic-function-method-class) + (method-combination + :initarg :method-combination + :accessor generic-function-method-combination) + (arg-info + :initform (make-arg-info) + :reader gf-arg-info) + (dfun-state + :initform () + :accessor gf-dfun-state) + (pretty-arglist + :initform () + :accessor gf-pretty-arglist) + ) + (:metaclass funcallable-standard-class) + (:default-initargs :method-class *the-class-standard-method* + :method-combination *standard-method-combination*)) + +(defclass method-combination (metaobject) ()) + +(defclass standard-method-combination + (definition-source-mixin method-combination) + ((type :reader method-combination-type + :initarg :type) + (documentation :reader method-combination-documentation + :initarg :documentation) + (options :reader method-combination-options + :initarg :options))) + +(defparameter *early-class-predicates* + '((specializer specializerp) + (exact-class-specializer exact-class-specializer-p) + (class-eq-specializer class-eq-specializer-p) + (eql-specializer eql-specializer-p) + (class classp) + (slot-class slot-class-p) + (standard-class standard-class-p) + (funcallable-standard-class funcallable-standard-class-p) + (structure-class structure-class-p) + (forward-referenced-class forward-referenced-class-p) + (method method-p) + (standard-method standard-method-p) + (standard-accessor-method standard-accessor-method-p) + (standard-reader-method standard-reader-method-p) + (standard-writer-method standard-writer-method-p) + (standard-boundp-method standard-boundp-method-p) + (generic-function generic-function-p) + (standard-generic-function standard-generic-function-p) + (method-combination method-combination-p))) + diff --git a/pcl/gcl_pcl_dfun.lisp b/pcl/gcl_pcl_dfun.lisp new file mode 100644 index 0000000..01aca3b --- /dev/null +++ b/pcl/gcl_pcl_dfun.lisp @@ -0,0 +1,1617 @@ +;;; -*- Mode:LISP; Package:PCL; Base:10; Syntax:Common-Lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; + +(in-package :pcl) + +#| + +This implementation of method lookup was redone in early August of 89. + +It has the following properties: + + - It's modularity makes it easy to modify the actual caching algorithm. + The caching algorithm is almost completely separated into the files + cache.lisp and dlap.lisp. This file just contains the various uses + of it. There will be more tuning as we get more results from Luis' + measurements of caching behavior. + + - The metacircularity issues have been dealt with properly. All of + PCL now grounds out properly. Moreover, it is now possible to have + metaobject classes which are themselves not instances of standard + metaobject classes. + +** Modularity of the code ** + +The actual caching algorithm is isolated in a modest number of functions. +The code which generates cache lookup code is all found in cache.lisp and +dlap.lisp. Certain non-wrapper-caching special cases are in this file. + + +** Handling the metacircularity ** + +In CLOS, method lookup is the potential source of infinite metacircular +regress. The metaobject protocol specification gives us wide flexibility +in how to address this problem. PCL uses a technique which handles the +problem not only for the metacircular language described in Chapter 3, but +also for the PCL protocol which includes additional generic functions +which control more aspects of the CLOS implementation. + +The source of the metacircular regress can be seen in a number of ways. +One is that the specified method lookup protocol must, as part of doing +the method lookup (or at least the cache miss case), itself call generic +functions. It is easy to see that if the method lookup for a generic +function ends up calling that same generic function there can be trouble. + +Fortunately, there is an easy solution at hand. The solution is based on +the restriction that portable code cannot change the class of a specified +metaobject. This restriction implies that for specified generic functions, +the method lookup protocol they follow is fixed. + +More precisely, for such specified generic functions, most generic functions +that are called during their own method lookup will not run portable methods. +This allows the implementation to usurp the actual generic function call in +this case. In short, method lookup of a standard generic function, in the +case where the only applicable methods are themselves standard doesn't +have to do any method lookup to implement itself. + +And so, we are saved. + +|# + + +;An alist in which each entry is of the form : +; ( . ( ...)) +;Each subentry is of the form: +; ( ) +(defvar *dfun-constructors* ()) + +;If this is NIL, then the whole mechanism +;for caching dfun constructors is turned +;off. The only time that makes sense is +;when debugging LAP code. +(defvar *enable-dfun-constructor-caching* t) + +(defun show-dfun-constructors () + (format t "~&DFUN constructor caching is ~A." + (if *enable-dfun-constructor-caching* + "enabled" "disabled")) + (dolist (generator-entry *dfun-constructors*) + (dolist (args-entry (cdr generator-entry)) + (format t "~&~S ~S ~A" + (cons (car generator-entry) (car args-entry)) + (caddr args-entry) + (if (cadddr args-entry) "(preliminary)" ""))))) + +(defvar *raise-metatypes-to-class-p* t) + +(defun get-dfun-constructor (generator &rest args) + (when (and *raise-metatypes-to-class-p* + (member generator + '(emit-checking emit-caching + emit-in-checking-cache-p emit-constant-value))) + (setq args (cons (mapcar #'(lambda (mt) + (if (eq mt 't) + mt + 'class)) + (car args)) + (cdr args)))) + (let* ((generator-entry (assq generator *dfun-constructors*)) + (args-entry (assoc args (cdr generator-entry) :test #'equal))) + (if (null *enable-dfun-constructor-caching*) + (apply (the function (symbol-function generator)) args) + (or (cadr args-entry) + (multiple-value-bind (new not-best-p) + (apply (the function (symbol-function generator)) args) + (let ((entry (list (copy-list args) new + (unless not-best-p '+pcl+) + not-best-p))) + (if generator-entry + (push entry (cdr generator-entry)) + (push (list generator entry) + *dfun-constructors*))) + (values new not-best-p)))))) + +(defun load-precompiled-dfun-constructor (generator args system constructor) + (let* ((generator-entry (assq generator *dfun-constructors*)) + (args-entry (assoc args (cdr generator-entry) :test #'equal))) + (if args-entry + (when (fourth args-entry) + (let* ((dfun-type (case generator + (emit-checking 'checking) + (emit-caching 'caching) + (emit-constant-value 'constant-value) + (emit-default-only 'default-method-only))) + (metatypes (car args)) + (gfs (when dfun-type (gfs-of-type dfun-type)))) + (dolist (gf gfs) + (when (and (equal metatypes (arg-info-metatypes (gf-arg-info gf))) + (let ((gf-name (generic-function-name gf))) + (and (not (eq gf-name 'slot-value-using-class)) + (not (equal gf-name '(setf slot-value-using-class))) + (not (eq gf-name 'slot-boundp-using-class))))) + (update-dfun gf))) + (setf (second args-entry) constructor) + (setf (third args-entry) system) + (setf (fourth args-entry) nil))) + (let ((entry (list args constructor system nil))) + (if generator-entry + (push entry (cdr generator-entry)) + (push (list generator entry) *dfun-constructors*)))))) + +(defmacro precompile-dfun-constructors (&optional system) + (let ((*precompiling-lap* t)) + `(progn + ,@(gathering1 (collecting) + (dolist (generator-entry *dfun-constructors*) + (dolist (args-entry (cdr generator-entry)) + (when (or (null (caddr args-entry)) + (eq (caddr args-entry) system)) + (when system (setf (caddr args-entry) system)) + (gather1 + (make-top-level-form `(precompile-dfun-constructor + ,(car generator-entry)) + '(load) + `(load-precompiled-dfun-constructor + ',(car generator-entry) + ',(car args-entry) + ',system + ,(apply (symbol-function (car generator-entry)) + (car args-entry)))))))))))) + + +;;; +;;; When all the methods of a generic function are automatically generated +;;; reader or writer methods a number of special optimizations are possible. +;;; These are important because of the large number of generic functions of +;;; this type. +;;; +;;; There are a number of cases: +;;; +;;; ONE-CLASS-ACCESSOR +;;; In this case, the accessor generic function has only been called +;;; with one class of argument. There is no cache vector, the wrapper +;;; of the one class, and the slot index are stored directly as closure +;;; variables of the discriminating function. This case can convert to +;;; either of the next kind. +;;; +;;; TWO-CLASS-ACCESSOR +;;; Like above, but two classes. This is common enough to do specially. +;;; There is no cache vector. The two classes are stored a separate +;;; closure variables. +;;; +;;; ONE-INDEX-ACCESSOR +;;; In this case, the accessor generic function has seen more than one +;;; class of argument, but the index of the slot is the same for all +;;; the classes that have been seen. A cache vector is used to store +;;; the wrappers that have been seen, the slot index is stored directly +;;; as a closure variable of the discriminating function. This case +;;; can convert to the next kind. +;;; +;;; N-N-ACCESSOR +;;; This is the most general case. In this case, the accessor generic +;;; function has seen more than one class of argument and more than one +;;; slot index. A cache vector stores the wrappers and corresponding +;;; slot indexes. Because each cache line is more than one element +;;; long, a cache lock count is used. +;;; +(defstruct (dfun-info + (:constructor nil) + (:print-function print-dfun-info)) + (cache nil)) + +(defun print-dfun-info (dfun-info stream depth) + (declare (ignore depth) (stream stream)) + (printing-random-thing (dfun-info stream) + (format stream "~A" (type-of dfun-info)))) + +(defstruct (no-methods + (:constructor no-methods-dfun-info ()) + (:include dfun-info))) + +(defstruct (initial + (:constructor initial-dfun-info ()) + (:include dfun-info))) + +(defstruct (initial-dispatch + (:constructor initial-dispatch-dfun-info ()) + (:include dfun-info))) + +(defstruct (dispatch + (:constructor dispatch-dfun-info ()) + (:include dfun-info))) + +(defstruct (default-method-only + (:constructor default-method-only-dfun-info ()) + (:include dfun-info))) + +;without caching: +; dispatch one-class two-class default-method-only + +;with caching: +; one-index n-n checking caching + +;accessor: +; one-class two-class one-index n-n +(defstruct (accessor-dfun-info + (:constructor nil) + (:include dfun-info)) + accessor-type) ; (member reader writer) + +(defmacro dfun-info-accessor-type (di) + `(accessor-dfun-info-accessor-type ,di)) + +(defstruct (one-index-dfun-info + (:constructor nil) + (:include accessor-dfun-info)) + index) + +(defmacro dfun-info-index (di) + `(one-index-dfun-info-index ,di)) + +(defstruct (n-n + (:constructor n-n-dfun-info (accessor-type cache)) + (:include accessor-dfun-info))) + +(defstruct (one-class + (:constructor one-class-dfun-info (accessor-type index wrapper0)) + (:include one-index-dfun-info)) + wrapper0) + +(defmacro dfun-info-wrapper0 (di) + `(one-class-wrapper0 ,di)) + +(defstruct (two-class + (:constructor two-class-dfun-info (accessor-type index wrapper0 wrapper1)) + (:include one-class)) + wrapper1) + +(defmacro dfun-info-wrapper1 (di) + `(two-class-wrapper1 ,di)) + +(defstruct (one-index + (:constructor one-index-dfun-info + (accessor-type index cache)) + (:include one-index-dfun-info))) + +(defstruct (checking + (:constructor checking-dfun-info (function cache)) + (:include dfun-info)) + function) + +(defmacro dfun-info-function (di) + `(checking-function ,di)) + +(defstruct (caching + (:constructor caching-dfun-info (cache)) + (:include dfun-info))) + +(defstruct (constant-value + (:constructor constant-value-dfun-info (cache)) + (:include dfun-info))) + +(defmacro dfun-update (generic-function function &rest args) + `(multiple-value-bind (dfun cache info) + (funcall ,function ,generic-function ,@args) + (update-dfun ,generic-function dfun cache info))) + +(defun accessor-miss-function (gf dfun-info) + (ecase (dfun-info-accessor-type dfun-info) + (reader + #'(lambda (arg) + (declare (pcl-fast-call)) + (accessor-miss gf nil arg dfun-info))) + (writer + #'(lambda (new arg) + (declare (pcl-fast-call)) + (accessor-miss gf new arg dfun-info))))) + +#+cmu +(declaim (ext:freeze-type dfun-info)) + + +;;; +;;; ONE-CLASS-ACCESSOR +;;; +(defun make-one-class-accessor-dfun (gf type wrapper index) + (let ((emit (if (eq type 'reader) 'emit-one-class-reader 'emit-one-class-writer)) + (dfun-info (one-class-dfun-info type index wrapper))) + (values + (funcall (the function (get-dfun-constructor emit (consp index))) + wrapper index + (accessor-miss-function gf dfun-info)) + nil + dfun-info))) + +;;; +;;; TWO-CLASS-ACCESSOR +;;; +(defun make-two-class-accessor-dfun (gf type w0 w1 index) + (let ((emit (if (eq type 'reader) 'emit-two-class-reader 'emit-two-class-writer)) + (dfun-info (two-class-dfun-info type index w0 w1))) + (values + (funcall (the function (get-dfun-constructor emit (consp index))) + w0 w1 index + (accessor-miss-function gf dfun-info)) + nil + dfun-info))) + +;;; +;;; std accessors same index dfun +;;; +(defun make-one-index-accessor-dfun (gf type index &optional cache) + (let* ((emit (if (eq type 'reader) 'emit-one-index-readers 'emit-one-index-writers)) + (cache (or cache (get-cache 1 nil #'one-index-limit-fn 4))) + (dfun-info (one-index-dfun-info type index cache))) + (declare (type cache cache)) + (values + (funcall (the function (get-dfun-constructor emit (consp index))) + cache + index + (accessor-miss-function gf dfun-info)) + cache + dfun-info))) + +(defun make-final-one-index-accessor-dfun (gf type index table) + (let ((cache (fill-dfun-cache table nil 1 #'one-index-limit-fn))) + (make-one-index-accessor-dfun gf type index cache))) + +(defun one-index-limit-fn (nlines) + (default-limit-fn nlines)) + + +(defun make-n-n-accessor-dfun (gf type &optional cache) + (let* ((emit (if (eq type 'reader) 'emit-n-n-readers 'emit-n-n-writers)) + (cache (or cache (get-cache 1 t #'n-n-accessors-limit-fn 2))) + (dfun-info (n-n-dfun-info type cache))) + (declare (type cache cache)) + (values + (funcall (the function (get-dfun-constructor emit)) + cache + (accessor-miss-function gf dfun-info)) + cache + dfun-info))) + +(defun make-final-n-n-accessor-dfun (gf type table) + (let ((cache (fill-dfun-cache table t 1 #'n-n-accessors-limit-fn))) + (make-n-n-accessor-dfun gf type cache))) + +(defun n-n-accessors-limit-fn (nlines) + (default-limit-fn nlines)) + +(defun make-checking-dfun (generic-function function &optional cache) + (unless cache + (when (use-caching-dfun-p generic-function) + (return-from make-checking-dfun (make-caching-dfun generic-function))) + (when (use-dispatch-dfun-p generic-function) + (return-from make-checking-dfun (make-dispatch-dfun generic-function)))) + (multiple-value-bind (nreq applyp metatypes nkeys) + (get-generic-function-info generic-function) + (declare (ignore nreq)) + (if (every #'(lambda (mt) (eq mt 't)) metatypes) + (let ((dfun-info (default-method-only-dfun-info))) + (values + (funcall (the function (get-dfun-constructor + 'emit-default-only metatypes applyp)) + function) + nil + dfun-info)) + (let* ((cache (or cache (get-cache nkeys nil #'checking-limit-fn 2))) + (dfun-info (checking-dfun-info function cache))) + (values + (funcall (the function (get-dfun-constructor + 'emit-checking metatypes applyp)) + cache + function + #'(lambda (&rest args) + (declare (pcl-fast-call)) + #+copy-&rest-arg (setq args (copy-list args)) + (checking-miss generic-function args dfun-info))) + cache + dfun-info))))) + +(defun make-final-checking-dfun (generic-function function + classes-list new-class) + (let ((metatypes (arg-info-metatypes (gf-arg-info generic-function)))) + (if (every #'(lambda (mt) (eq mt 't)) metatypes) + (values #'(lambda (&rest args) + #+copy-&rest-arg (setq args (copy-list args)) + (invoke-emf function args)) + nil (default-method-only-dfun-info)) + (let ((cache (make-final-ordinary-dfun-internal + generic-function nil #'checking-limit-fn + classes-list new-class))) + (make-checking-dfun generic-function function cache))))) + +(defun use-default-method-only-dfun-p (generic-function) + (multiple-value-bind (nreq applyp metatypes nkeys) + (get-generic-function-info generic-function) + (declare (ignore nreq applyp nkeys)) + (every #'(lambda (mt) (eq mt 't)) metatypes))) + +(defun use-caching-dfun-p (generic-function) + (some #'(lambda (method) + (let ((fmf (if (listp method) + (third method) + (method-fast-function method)))) + (method-function-get fmf ':slot-name-lists))) + (if (early-gf-p generic-function) + (early-gf-methods generic-function) + (generic-function-methods generic-function)))) + +(defun checking-limit-fn (nlines) + (default-limit-fn nlines)) + + +;;; +;;; +;;; +(defun make-caching-dfun (generic-function &optional cache) + (unless cache + (when (use-constant-value-dfun-p generic-function) + (return-from make-caching-dfun (make-constant-value-dfun generic-function))) + (when (use-dispatch-dfun-p generic-function) + (return-from make-caching-dfun (make-dispatch-dfun generic-function)))) + (multiple-value-bind (nreq applyp metatypes nkeys) + (get-generic-function-info generic-function) + (declare (ignore nreq)) + (let* ((cache (or cache (get-cache nkeys t #'caching-limit-fn 2))) + (dfun-info (caching-dfun-info cache))) + (values + (funcall (the function (get-dfun-constructor + 'emit-caching metatypes applyp)) + cache + #'(lambda (&rest args) + (declare (pcl-fast-call)) + #+copy-&rest-arg (setq args (copy-list args)) + (caching-miss generic-function args dfun-info))) + cache + dfun-info)))) + +(defun make-final-caching-dfun (generic-function classes-list new-class) + (let ((cache (make-final-ordinary-dfun-internal + generic-function t #'caching-limit-fn + classes-list new-class))) + (make-caching-dfun generic-function cache))) + +(defun caching-limit-fn (nlines) + (default-limit-fn nlines)) + +(defun insure-dfun (gf caching-p) + (multiple-value-bind (nreq applyp metatypes nkeys) + (get-generic-function-info gf) + (declare (ignore nreq nkeys)) + (when (or (null metatypes) + (not (null (car metatypes)))) + (cond ((use-constant-value-dfun-p gf) + (get-dfun-constructor 'emit-constant-value metatypes)) + (caching-p + (get-dfun-constructor 'emit-caching metatypes applyp)) + ((dolist (mt metatypes t) (unless (eq mt 't) (return nil))) + (get-dfun-constructor 'emit-default-only metatypes applyp)) + (t + (get-dfun-constructor 'emit-checking metatypes applyp)))))) + +(defun use-constant-value-dfun-p (gf &optional boolean-values-p) + (multiple-value-bind (nreq applyp metatypes nkeys) + (get-generic-function-info gf) + (declare (ignore nreq metatypes nkeys)) + (let* ((early-p (early-gf-p gf)) + (methods (if early-p + (early-gf-methods gf) + (generic-function-methods gf))) + (default '(unknown))) + (and (null applyp) + (or (not (eq *boot-state* 'complete)) + (compute-applicable-methods-emf-std-p gf)) + (notany #'(lambda (method) + (or (and (eq *boot-state* 'complete) + (some #'eql-specializer-p + (method-specializers method))) + (let ((value (method-function-get + (if early-p + (or (third method) (second method)) + (or (method-fast-function method) + (method-function method))) + :constant-value default))) + (if boolean-values-p + (not (or (eq value 't) (eq value nil))) + (eq value default))))) + methods))))) + +(defun make-constant-value-dfun (generic-function &optional cache) + (multiple-value-bind (nreq applyp metatypes nkeys) + (get-generic-function-info generic-function) + (declare (ignore nreq applyp)) + (let* ((cache (or cache (get-cache nkeys t #'caching-limit-fn 2))) + (dfun-info (constant-value-dfun-info cache))) + (values + (funcall (the function (get-dfun-constructor + 'emit-constant-value metatypes)) + cache + #'(lambda (&rest args) + (declare (pcl-fast-call)) + #+copy-&rest-arg (setq args (copy-list args)) + (constant-value-miss generic-function args dfun-info))) + cache + dfun-info)))) + +(defun make-final-constant-value-dfun (generic-function classes-list new-class) + (let ((cache (make-final-ordinary-dfun-internal + generic-function :constant-value #'caching-limit-fn + classes-list new-class))) + (make-constant-value-dfun generic-function cache))) + +(defun use-dispatch-dfun-p (gf &optional (caching-p (use-caching-dfun-p gf))) + (when (eq *boot-state* 'complete) + (unless caching-p + ;; This should return T when almost all dispatching is by + ;; eql specializers or built-in classes. In other words, + ;; return NIL if we might ever need to do more than + ;; one (non built-in) typep. + ;; Otherwise, it is probably at least as fast to use + ;; a caching dfun first, possibly followed by secondary dispatching. + (let ((caching-cost (caching-dfun-cost gf))) + (< (dispatch-dfun-cost gf caching-cost) caching-cost))))) + +;; Try this on print-object, find-method-combination, and documentation. +;; Look at pcl/generic-functions.lisp for other potential test cases. +(defun show-dfun-costs (gf) + (when (or (symbolp gf) (consp gf)) + (setq gf (gdefinition gf))) + (format t "~&Name ~S caching cost ~D dispatch cost ~D~%" + (generic-function-name gf) + (caching-dfun-cost gf) + (dispatch-dfun-cost gf))) + +(defparameter *non-built-in-typep-cost* 1) +(defparameter *structure-typep-cost* 1) +(defparameter *built-in-typep-cost* 0) + +(defun dispatch-dfun-cost (gf &optional limit) + (generate-discrimination-net-internal + gf (generic-function-methods gf) nil + #'(lambda (methods known-types) + (declare (ignore methods known-types)) + 0) + #'(lambda (position type true-value false-value) + (declare (ignore position)) + (let* ((type-test-cost + (if (eq 'class (car type)) + (let* ((metaclass (class-of (cadr type))) + (mcpl (class-precedence-list metaclass))) + (cond ((memq *the-class-built-in-class* mcpl) + *built-in-typep-cost*) + ((memq *the-class-structure-class* mcpl) + *structure-typep-cost*) + (t + *non-built-in-typep-cost*))) + 0)) + (max-cost-so-far + (+ (max true-value false-value) type-test-cost))) + (when (and limit (<= limit max-cost-so-far)) + (return-from dispatch-dfun-cost max-cost-so-far)) + max-cost-so-far)) + #'identity)) + +(defparameter *cache-lookup-cost* 1) +(defparameter *wrapper-of-cost* 0) +(defparameter *secondary-dfun-call-cost* 1) + +(defun caching-dfun-cost (gf) + (let* ((arg-info (gf-arg-info gf)) + (nreq (length (arg-info-metatypes arg-info)))) + (+ *cache-lookup-cost* + (* *wrapper-of-cost* nreq) + (if (methods-contain-eql-specializer-p + (generic-function-methods gf)) + *secondary-dfun-call-cost* + 0)))) + +#+cmu +(progn + (setq *non-built-in-typep-cost* 100) + (setq *structure-typep-cost* 15) + (setq *built-in-typep-cost* 5) + (setq *cache-lookup-cost* 30) + (setq *wrapper-of-cost* 15) + (setq *secondary-dfun-call-cost* 30)) + + +(defun make-dispatch-dfun (gf) + (values (get-dispatch-function gf) nil (dispatch-dfun-info))) + +(defun get-dispatch-function (gf) + (let ((methods (generic-function-methods gf))) + (function-funcall (get-secondary-dispatch-function1 gf methods nil nil nil + nil nil t) + nil nil))) + +(defun make-final-dispatch-dfun (gf) + (make-dispatch-dfun gf)) + +(defun update-dispatch-dfuns () + (dolist (gf (gfs-of-type '(dispatch initial-dispatch))) + (dfun-update gf #'make-dispatch-dfun))) + +(defun fill-dfun-cache (table valuep nkeys limit-fn &optional cache) + (let ((cache (or cache (get-cache nkeys valuep limit-fn + (+ (hash-table-count table) 3))))) + (maphash #'(lambda (classes value) + (setq cache (fill-cache cache + (class-wrapper classes) + value + t))) + table) + cache)) + +(defun make-final-ordinary-dfun-internal (generic-function valuep limit-fn + classes-list new-class) + (let* ((arg-info (gf-arg-info generic-function)) + (nkeys (arg-info-nkeys arg-info)) + (new-class (and new-class + (equal (type-of (gf-dfun-info generic-function)) + (cond ((eq valuep t) 'caching) + ((eq valuep :constant-value) 'constant-value) + ((null valuep) 'checking))) + new-class)) + (cache (if new-class + (copy-cache (gf-dfun-cache generic-function)) + (get-cache nkeys (not (null valuep)) limit-fn 4)))) + (make-emf-cache generic-function valuep cache classes-list new-class))) + +(defvar *dfun-miss-gfs-on-stack* ()) + +(defmacro dfun-miss ((gf args wrappers invalidp nemf + &optional type index caching-p applicable) + &body body) + (unless applicable (setq applicable (gensym))) + `(multiple-value-bind (,nemf ,applicable ,wrappers ,invalidp + ,@(when type `(,type ,index))) + (cache-miss-values ,gf ,args ',(cond (caching-p 'caching) + (type 'accessor) + (t 'checking))) + (when (and ,applicable (not (memq ,gf *dfun-miss-gfs-on-stack*))) + (let ((*dfun-miss-gfs-on-stack* (cons ,gf *dfun-miss-gfs-on-stack*))) + ,@body)) + (invoke-emf ,nemf ,args))) + +;;; +;;; The dynamically adaptive method lookup algorithm is implemented is +;;; implemented as a kind of state machine. The kinds of discriminating +;;; function is the state, the various kinds of reasons for a cache miss +;;; are the state transitions. +;;; +;;; The code which implements the transitions is all in the miss handlers +;;; for each kind of dfun. Those appear here. +;;; +;;; Note that within the states that cache, there are dfun updates which +;;; simply select a new cache or cache field. Those are not considered +;;; as state transitions. +;;; +(defvar *lazy-dfun-compute-p* t) +(defvar *early-p* nil) + +(defun make-initial-dfun (gf) + (let ((initial-dfun + (fin-lambda-fn (&rest args) + #+copy-&rest-arg (setq args (copy-list args)) + (initial-dfun gf args)))) + (multiple-value-bind (dfun cache info) + (if (and (eq *boot-state* 'complete) + (compute-applicable-methods-emf-std-p gf)) + (let* ((caching-p (use-caching-dfun-p gf)) + (classes-list (precompute-effective-methods + gf caching-p + (not *lazy-dfun-compute-p*)))) + (if *lazy-dfun-compute-p* + (cond ((use-dispatch-dfun-p gf caching-p) + (values initial-dfun nil (initial-dispatch-dfun-info))) + (t + (insure-dfun gf caching-p) + (values initial-dfun nil (initial-dfun-info)))) + (make-final-dfun-internal gf classes-list))) + (let ((arg-info (if (early-gf-p gf) + (early-gf-arg-info gf) + (gf-arg-info gf))) + (type nil)) + (if (and (gf-precompute-dfun-and-emf-p arg-info) + (setq type (final-accessor-dfun-type gf))) + (if *early-p* + (values (make-early-accessor gf type) nil nil) + (make-final-accessor-dfun gf type)) + (values initial-dfun nil (initial-dfun-info))))) + (set-dfun gf dfun cache info)))) + +(defun make-early-accessor (gf type) + (let* ((methods (early-gf-methods gf)) + (slot-name (early-method-standard-accessor-slot-name (car methods)))) + (ecase type + (reader (fin-lambda-fn (instance) + (let* ((class (class-of instance)) + (class-name (bootstrap-get-slot 'class class 'name))) + (bootstrap-get-slot class-name instance slot-name)))) + (writer (fin-lambda-fn (new-value instance) + (let* ((class (class-of instance)) + (class-name (bootstrap-get-slot 'class class 'name))) + (bootstrap-set-slot class-name instance slot-name new-value))))))) + +(defun initial-dfun (gf args) + (dfun-miss (gf args wrappers invalidp nemf ntype nindex) + (cond (invalidp) + ((and ntype nindex) + (dfun-update + gf #'make-one-class-accessor-dfun ntype wrappers nindex)) + ((use-caching-dfun-p gf) + (dfun-update gf #'make-caching-dfun)) + (t + (dfun-update + gf #'make-checking-dfun + ;; nemf is suitable only for caching, have to do this: + (cache-miss-values gf args 'checking)))))) + +(defun make-final-dfun (gf &optional classes-list) + (multiple-value-bind (dfun cache info) + (make-final-dfun-internal gf classes-list) + (set-dfun gf dfun cache info))) + +(defvar *new-class* nil) + +(defvar *free-hash-tables* (mapcar #'list '(eq equal eql))) + +(defmacro with-hash-table ((table test) &body forms) + `(let* ((.free. (assoc ',test *free-hash-tables*)) + (,table (if (cdr .free.) + (pop (cdr .free.)) + (make-hash-table :test ',test)))) + (multiple-value-prog1 + (progn ,@forms) + (clrhash ,table) + (push ,table (cdr .free.))))) + +(defmacro with-eq-hash-table ((table) &body forms) + `(with-hash-table (,table eq) ,@forms)) + +(defun final-accessor-dfun-type (gf) + (let ((methods (if (early-gf-p gf) + (early-gf-methods gf) + (generic-function-methods gf)))) + (cond ((every #'(lambda (method) + (if (consp method) + (eq *the-class-standard-reader-method* + (early-method-class method)) + (standard-reader-method-p method))) + methods) + 'reader) + ((every #'(lambda (method) + (if (consp method) + (eq *the-class-standard-writer-method* + (early-method-class method)) + (standard-writer-method-p method))) + methods) + 'writer)))) + +(defun make-final-accessor-dfun (gf type &optional classes-list new-class) + (with-eq-hash-table (table) + (multiple-value-bind (table all-index first second size no-class-slots-p) + (make-accessor-table gf type table) + (if table + (cond ((= size 1) + (let ((w (class-wrapper first))) + (make-one-class-accessor-dfun gf type w all-index))) + ((and (= size 2) (or (integerp all-index) (consp all-index))) + (let ((w0 (class-wrapper first)) + (w1 (class-wrapper second))) + (make-two-class-accessor-dfun gf type w0 w1 all-index))) + ((or (integerp all-index) (consp all-index)) + (make-final-one-index-accessor-dfun + gf type all-index table)) + (no-class-slots-p + (make-final-n-n-accessor-dfun gf type table)) + (t + (make-final-caching-dfun gf classes-list new-class))) + (make-final-caching-dfun gf classes-list new-class))))) + +(defun make-final-dfun-internal (gf &optional classes-list) + (let ((methods (generic-function-methods gf)) type + (new-class *new-class*) (*new-class* nil) + specls all-same-p) + (cond ((null methods) + (values + (fin-lambda-fn (&rest args) + (apply #'no-applicable-method gf args)) + nil + (no-methods-dfun-info))) + ((setq type (final-accessor-dfun-type gf)) + (make-final-accessor-dfun gf type classes-list new-class)) + ((and (not (and (every #'(lambda (specl) (eq specl *the-class-t*)) + (setq specls (method-specializers (car methods)))) + (setq all-same-p + (every #'(lambda (method) + (and (equal specls + (method-specializers method)))) + methods)))) + (use-constant-value-dfun-p gf)) + (make-final-constant-value-dfun gf classes-list new-class)) + ((use-dispatch-dfun-p gf) + (make-final-dispatch-dfun gf)) + ((and all-same-p (not (use-caching-dfun-p gf))) + (let ((emf (get-secondary-dispatch-function gf methods nil))) + (make-final-checking-dfun gf emf classes-list new-class))) + (t + (make-final-caching-dfun gf classes-list new-class))))) + +(defun accessor-miss (gf new object dfun-info) + (let* ((ostate (type-of dfun-info)) + (otype (dfun-info-accessor-type dfun-info)) + oindex ow0 ow1 cache + (args (ecase otype ;The congruence rules assure + (reader (list object)) ;us that this is safe despite + (writer (list new object))))) ;not knowing the new type yet. + (dfun-miss (gf args wrappers invalidp nemf ntype nindex) + ;; + ;; The following lexical functions change the state of the + ;; dfun to that which is their name. They accept arguments + ;; which are the parameters of the new state, and get other + ;; information from the lexical variables bound above. + ;; + (flet ((two-class (index w0 w1) + (when (zerop (random 2)) (psetf w0 w1 w1 w0)) + (dfun-update gf #'make-two-class-accessor-dfun ntype w0 w1 index)) + (one-index (index &optional cache) + (dfun-update gf #'make-one-index-accessor-dfun ntype index cache)) + (n-n (&optional cache) + (if (consp nindex) + (dfun-update gf #'make-checking-dfun nemf) + (dfun-update gf #'make-n-n-accessor-dfun ntype cache))) + (caching () ; because cached accessor emfs are much faster for accessors + (dfun-update gf #'make-caching-dfun)) + ;; + (do-fill (update-fn) + (declare (type function update-fn)) + (let ((ncache (fill-cache cache wrappers nindex))) + (unless (eq ncache cache) + (funcall update-fn ncache))))) + (cond ((null ntype) + (caching)) + ((or invalidp + (null nindex))) + ((not #-cmu17 + (or (std-instance-p object) + (fsc-instance-p object)) + #+cmu17 + (pcl-instance-p object)) + (caching)) + ((or (neq ntype otype) (listp wrappers)) + (caching)) + (t + (ecase ostate + (one-class + (setq oindex (dfun-info-index dfun-info)) + (setq ow0 (dfun-info-wrapper0 dfun-info)) + (unless (eq ow0 wrappers) + (if (eql nindex oindex) + (two-class nindex ow0 wrappers) + (n-n)))) + (two-class + (setq oindex (dfun-info-index dfun-info)) + (setq ow0 (dfun-info-wrapper0 dfun-info)) + (setq ow1 (dfun-info-wrapper1 dfun-info)) + (unless (or (eq ow0 wrappers) (eq ow1 wrappers)) + (if (eql nindex oindex) + (one-index nindex) + (n-n)))) + (one-index + (setq oindex (dfun-info-index dfun-info)) + (setq cache (dfun-info-cache dfun-info)) + (if (eql nindex oindex) + (do-fill #'(lambda (ncache) + (one-index nindex ncache))) + (n-n))) + (n-n + (setq cache (dfun-info-cache dfun-info)) + (if (consp nindex) + (caching) + (do-fill #'n-n)))))))))) + +(defun checking-miss (generic-function args dfun-info) + (let ((oemf (dfun-info-function dfun-info)) + (cache (dfun-info-cache dfun-info))) + (dfun-miss (generic-function args wrappers invalidp nemf) + (cond (invalidp) + ((eq oemf nemf) + (let ((ncache (fill-cache cache wrappers nil))) + (unless (eq ncache cache) + (dfun-update generic-function #'make-checking-dfun + nemf ncache)))) + (t + (dfun-update generic-function #'make-caching-dfun)))))) + +(defun caching-miss (generic-function args dfun-info) + (let ((ocache (dfun-info-cache dfun-info))) + (dfun-miss (generic-function args wrappers invalidp emf nil nil t) + (cond (invalidp) + (t + (let ((ncache (fill-cache ocache wrappers emf))) + (unless (eq ncache ocache) + (dfun-update generic-function + #'make-caching-dfun ncache)))))))) + +(defun constant-value-miss (generic-function args dfun-info) + (let ((ocache (dfun-info-cache dfun-info))) + (dfun-miss (generic-function args wrappers invalidp emf nil nil t) + (cond (invalidp) + (t + (let* ((function (typecase emf + (fast-method-call (fast-method-call-function emf)) + (method-call (method-call-function emf)))) + (value (method-function-get function :constant-value)) + (ncache (fill-cache ocache wrappers value))) + (unless (eq ncache ocache) + (dfun-update generic-function + #'make-constant-value-dfun ncache)))))))) + +;;; Given a generic function and a set of arguments to that generic function, +;;; returns a mess of values. +;;; +;;; The compiled effective method function for this set of +;;; arguments. +;;; +;;; Sorted list of applicable methods. +;;; +;;; Is a single wrapper if the generic function has only +;;; one key, that is arg-info-nkeys of the arg-info is 1. +;;; Otherwise a list of the wrappers of the specialized +;;; arguments to the generic function. +;;; +;;; Note that all these wrappers are valid. This function +;;; does invalid wrapper traps when it finds an invalid +;;; wrapper and then returns the new, valid wrapper. +;;; +;;; True if any of the specialized arguments had an invalid +;;; wrapper, false otherwise. +;;; +;;; READER or WRITER when the only method that would be run +;;; is a standard reader or writer method. To be specific, +;;; the value is READER when the method combination is eq to +;;; *standard-method-combination*; there are no applicable +;;; :before, :after or :around methods; and the most specific +;;; primary method is a standard reader method. +;;; +;;; If is READER or WRITER, and the slot accessed is +;;; an :instance slot, this is the index number of that slot +;;; in the object argument. +;;; +(defun cache-miss-values (gf args state) + (if (null (if (early-gf-p gf) + (early-gf-methods gf) + (generic-function-methods gf))) + (apply #'no-applicable-method gf args) + (multiple-value-bind (nreq applyp metatypes nkeys arg-info) + (get-generic-function-info gf) + (declare (ignore nreq applyp nkeys)) + (with-dfun-wrappers (args metatypes) + (dfun-wrappers invalid-wrapper-p wrappers classes types) + (error "The function ~S requires at least ~D arguments" + gf (length metatypes)) + (multiple-value-bind (emf methods accessor-type index) + (cache-miss-values-internal gf arg-info wrappers classes types state) + (values emf methods + dfun-wrappers + invalid-wrapper-p + accessor-type index)))))) + +(defun cache-miss-values-internal (gf arg-info wrappers classes types state) + (let* ((for-accessor-p (eq state 'accessor)) + (for-cache-p (or (eq state 'caching) (eq state 'accessor))) + (cam-std-p (or (null arg-info) + (gf-info-c-a-m-emf-std-p arg-info)))) + (multiple-value-bind (methods all-applicable-and-sorted-p) + (if cam-std-p + (compute-applicable-methods-using-types gf types) + (compute-applicable-methods-using-classes gf classes)) + (let ((emf (if (or cam-std-p all-applicable-and-sorted-p) + (function-funcall (get-secondary-dispatch-function1 + gf methods types nil (and for-cache-p wrappers) + all-applicable-and-sorted-p) + nil (and for-cache-p wrappers)) + (default-secondary-dispatch-function gf)))) + (multiple-value-bind (index accessor-type) + (and for-accessor-p all-applicable-and-sorted-p methods + (accessor-values gf arg-info classes methods)) + (values (if (integerp index) index emf) + methods accessor-type index)))))) + +(defun accessor-values (gf arg-info classes methods) + (declare (ignore gf)) + (let* ((accessor-type (gf-info-simple-accessor-type arg-info)) + (accessor-class (case accessor-type + (reader (car classes)) + (writer (cadr classes)) + (boundp (car classes))))) + (accessor-values-internal accessor-type accessor-class methods))) + +(defun accessor-values1 (gf accessor-type accessor-class) + (let* ((type `(class-eq ,accessor-class)) + (types (if (eq accessor-type 'writer) `(t ,type) `(,type))) + (methods (compute-applicable-methods-using-types gf types))) + (accessor-values-internal accessor-type accessor-class methods))) + +(defun accessor-values-internal (accessor-type accessor-class methods) + (dolist (meth methods) + (when (if (consp meth) + (early-method-qualifiers meth) + (method-qualifiers meth)) + (return-from accessor-values-internal (values nil nil)))) + (let* ((meth (car methods)) + (early-p (not (eq *boot-state* 'complete))) + (slot-name (when accessor-class + (if (consp meth) + (and (early-method-standard-accessor-p meth) + (early-method-standard-accessor-slot-name meth)) + (and (member *the-class-standard-object* + (if early-p + (early-class-precedence-list accessor-class) + (class-precedence-list accessor-class))) + (if early-p + (not (eq *the-class-standard-method* + (early-method-class meth))) + (standard-accessor-method-p meth)) + (if early-p + (early-accessor-method-slot-name meth) + (accessor-method-slot-name meth)))))) + (slotd (and accessor-class + (if early-p + (dolist (slot (early-class-slotds accessor-class) nil) + (when (eql slot-name (early-slot-definition-name slot)) + (return slot))) + (find-slot-definition accessor-class slot-name))))) + (when (and slotd + (or early-p + (slot-accessor-std-p slotd accessor-type))) + (values (if early-p + (early-slot-definition-location slotd) + (slot-definition-location slotd)) + accessor-type)))) + +(defun make-accessor-table (gf type &optional table) + (unless table (setq table (make-hash-table :test 'eq))) + (let ((methods (if (early-gf-p gf) + (early-gf-methods gf) + (generic-function-methods gf))) + (all-index nil) + (no-class-slots-p t) + (early-p (not (eq *boot-state* 'complete))) + first second (size 0)) + (declare (fixnum size)) + ;; class -> {(specl slotd)} + (dolist (method methods) + (let* ((specializers (if (consp method) + (early-method-specializers method t) + (method-specializers method))) + (specl (if (eq type 'reader) + (car specializers) + (cadr specializers))) + (specl-cpl (if early-p + (early-class-precedence-list specl) + (and (class-finalized-p specl) + (class-precedence-list specl)))) + (so-p (member *the-class-standard-object* specl-cpl)) + (slot-name (if (consp method) + (and (early-method-standard-accessor-p method) + (early-method-standard-accessor-slot-name method)) + (accessor-method-slot-name method)))) + (when (or (null specl-cpl) + (member *the-class-structure-object* specl-cpl)) + (return-from make-accessor-table nil)) + (maphash #'(lambda (class slotd) + (let ((cpl (if early-p + (early-class-precedence-list class) + (class-precedence-list class)))) + (when (memq specl cpl) + (unless (and (or so-p + (member *the-class-standard-object* cpl)) + (or early-p + (slot-accessor-std-p slotd type))) + (return-from make-accessor-table nil)) + (push (cons specl slotd) (gethash class table))))) + (gethash slot-name *name->class->slotd-table*)))) + (maphash #'(lambda (class specl+slotd-list) + (dolist (sclass (if early-p + (early-class-precedence-list class) + (class-precedence-list class)) + (error "This can't happen")) + (let ((a (assq sclass specl+slotd-list))) + (when a + (let* ((slotd (cdr a)) + (index (if early-p + (early-slot-definition-location slotd) + (slot-definition-location slotd)))) + (unless index (return-from make-accessor-table nil)) + (setf (gethash class table) index) + (when (consp index) (setq no-class-slots-p nil)) + (setq all-index (if (or (null all-index) + (eql all-index index)) + index t)) + (incf size) + (cond ((= size 1) (setq first class)) + ((= size 2) (setq second class))) + (return nil)))))) + table) + (values table all-index first second size no-class-slots-p))) + +(defun compute-applicable-methods-using-types (generic-function types) + (let ((definite-p t) (possibly-applicable-methods nil)) + (dolist (method (if (early-gf-p generic-function) + (early-gf-methods generic-function) + (generic-function-methods generic-function))) + (let ((specls (if (consp method) + (early-method-specializers method t) + (method-specializers method))) + (types types) + (possibly-applicable-p t) (applicable-p t)) + (dolist (specl specls) + (multiple-value-bind (specl-applicable-p specl-possibly-applicable-p) + (specializer-applicable-using-type-p specl (pop types)) + (unless specl-applicable-p + (setq applicable-p nil)) + (unless specl-possibly-applicable-p + (setq possibly-applicable-p nil) + (return nil)))) + (when possibly-applicable-p + (unless applicable-p (setq definite-p nil)) + (push method possibly-applicable-methods)))) + (let ((precedence (arg-info-precedence (if (early-gf-p generic-function) + (early-gf-arg-info generic-function) + (gf-arg-info generic-function))))) + (values (sort-applicable-methods precedence + (nreverse possibly-applicable-methods) + types) + definite-p)))) + +(defun sort-applicable-methods (precedence methods types) + (sort-methods methods + precedence + #'(lambda (class1 class2 index) + (let* ((class (type-class (nth index types))) + (cpl (if (eq *boot-state* 'complete) + (class-precedence-list class) + (early-class-precedence-list class)))) + (if (memq class2 (memq class1 cpl)) + class1 class2))))) + +(defun sort-methods (methods precedence compare-classes-function) + (declare (type function compare-classes-function)) + (flet ((sorter (method1 method2) + (dolist (index precedence) + (let* ((specl1 (nth index (if (listp method1) + (early-method-specializers method1 t) + (method-specializers method1)))) + (specl2 (nth index (if (listp method2) + (early-method-specializers method2 t) + (method-specializers method2)))) + (order (order-specializers + specl1 specl2 index compare-classes-function))) + (when order + (return-from sorter (eq order specl1))))))) + (stable-sort methods #'sorter))) + +(defun order-specializers (specl1 specl2 index compare-classes-function) + (declare (type function compare-classes-function)) + (let ((type1 (if (eq *boot-state* 'complete) + (specializer-type specl1) + (bootstrap-get-slot 'specializer specl1 'type))) + (type2 (if (eq *boot-state* 'complete) + (specializer-type specl2) + (bootstrap-get-slot 'specializer specl2 'type)))) + (cond ((eq specl1 specl2) + nil) + ((atom type1) + specl2) + ((atom type2) + specl1) + (t + (case (car type1) + (class (case (car type2) + (class (funcall compare-classes-function specl1 specl2 index)) + (t specl2))) + (prototype (case (car type2) + (class (funcall compare-classes-function specl1 specl2 index)) + (t specl2))) + (class-eq (case (car type2) + (eql specl2) + (class-eq nil) + (class type1))) + (eql (case (car type2) + (eql nil) + (t specl1)))))))) + +(defun map-all-orders (methods precedence function) + (declare (type function function)) + (let ((choices nil)) + (flet ((compare-classes-function (class1 class2 index) + (declare (ignore index)) + (let ((choice nil)) + (dolist (c choices nil) + (when (or (and (eq (first c) class1) + (eq (second c) class2)) + (and (eq (first c) class2) + (eq (second c) class1))) + (return (setq choice c)))) + (unless choice + (setq choice + (if (class-might-precede-p class1 class2) + (if (class-might-precede-p class2 class1) + (list class1 class2 nil t) + (list class1 class2 t)) + (if (class-might-precede-p class2 class1) + (list class2 class1 t) + (let ((name1 (class-name class1)) + (name2 (class-name class2))) + (if (and name1 name2 (symbolp name1) (symbolp name2) + (string< (symbol-name name1) + (symbol-name name2))) + (list class1 class2 t) + (list class2 class1 t)))))) + (push choice choices)) + (car choice)))) + (loop (funcall function + (sort-methods methods precedence #'compare-classes-function)) + (unless (dolist (c choices nil) + (unless (third c) + (rotatef (car c) (cadr c)) + (return (setf (third c) t)))) + (return nil)))))) + +(defvar *in-precompute-effective-methods-p* nil) + +;used only in map-all-orders +(defun class-might-precede-p (class1 class2) + (if (not *in-precompute-effective-methods-p*) + (not (member class1 (cdr (class-precedence-list class2)))) + (class-can-precede-p class1 class2))) + +(defun compute-precedence (lambda-list nreq argument-precedence-order) + (if (null argument-precedence-order) + (let ((list nil))(dotimes (i nreq list) (push (- (1- nreq) i) list))) + (mapcar #'(lambda (x) (position x lambda-list)) argument-precedence-order))) + +(defun saut-and (specl type) + (let ((applicable nil) + (possibly-applicable t)) + (dolist (type (cdr type)) + (multiple-value-bind (appl poss-appl) + (specializer-applicable-using-type-p specl type) + (when appl (return (setq applicable t))) + (unless poss-appl (return (setq possibly-applicable nil))))) + (values applicable possibly-applicable))) + +(defun saut-not (specl type) + (let ((ntype (cadr type))) + (values nil + (case (car ntype) + (class (saut-not-class specl ntype)) + (class-eq (saut-not-class-eq specl ntype)) + (prototype (saut-not-prototype specl ntype)) + (eql (saut-not-eql specl ntype)) + (t (error "~s cannot handle the second argument ~s" + 'specializer-applicable-using-type-p type)))))) + +(defun saut-not-class (specl ntype) + (let* ((class (type-class specl)) + (cpl (class-precedence-list class))) + (not (memq (cadr ntype) cpl)))) + +(defun saut-not-prototype (specl ntype) + (let* ((class (case (car specl) + (eql (class-of (cadr specl))) + (class-eq (cadr specl)) + (prototype (cadr specl)) + (class (cadr specl)))) + (cpl (class-precedence-list class))) + (not (memq (cadr ntype) cpl)))) + +(defun saut-not-class-eq (specl ntype) + (let ((class (case (car specl) + (eql (class-of (cadr specl))) + (class-eq (cadr specl))))) + (not (eq class (cadr ntype))))) + +(defun saut-not-eql (specl ntype) + (case (car specl) + (eql (not (eql (cadr specl) (cadr ntype)))) + (t t))) + +(defun class-applicable-using-class-p (specl type) + (let ((pred (memq specl (if (eq *boot-state* 'complete) + (class-precedence-list type) + (early-class-precedence-list type))))) + (values pred + (or pred + (if (not *in-precompute-effective-methods-p*) + ;; classes might get common subclass + (superclasses-compatible-p specl type) + ;; worry only about existing classes + (classes-have-common-subclass-p specl type)))))) + +(defun classes-have-common-subclass-p (class1 class2) + (or (eq class1 class2) + (let ((class1-subs (class-direct-subclasses class1))) + (or (memq class2 class1-subs) + (dolist (class1-sub class1-subs nil) + (when (classes-have-common-subclass-p class1-sub class2) + (return t))))))) + +(defun saut-class (specl type) + (case (car specl) + (class (class-applicable-using-class-p (cadr specl) (cadr type))) + (t (values nil (let ((class (type-class specl))) + (memq (cadr type) + (class-precedence-list class))))))) + +(defun saut-class-eq (specl type) + (if (eq (car specl) 'eql) + (values nil (eq (class-of (cadr specl)) (cadr type))) + (let ((pred (case (car specl) + (class-eq + (eq (cadr specl) (cadr type))) + (class + (or (eq (cadr specl) (cadr type)) + (memq (cadr specl) + (if (eq *boot-state* 'complete) + (class-precedence-list (cadr type)) + (early-class-precedence-list (cadr type))))))))) + (values pred pred)))) + +(defun saut-prototype (specl type) + (declare (ignore specl type)) + (values nil nil)) ; fix this someday + +(defun saut-eql (specl type) + (let ((pred (case (car specl) + (eql (eql (cadr specl) (cadr type))) + (class-eq (eq (cadr specl) (class-of (cadr type)))) + (class (memq (cadr specl) + (let ((class (class-of (cadr type)))) + (if (eq *boot-state* 'complete) + (class-precedence-list class) + (early-class-precedence-list class)))))))) + (values pred pred))) + +(defun specializer-applicable-using-type-p (specl type) + (setq specl (type-from-specializer specl)) + (when (eq specl 't) + (return-from specializer-applicable-using-type-p (values t t))) + ;; This is used by c-a-m-u-t and generate-discrimination-net-internal, + ;; and has only what they need. + (if (or (atom type) (eq (car type) 't)) + (values nil t) + (case (car type) + (and (saut-and specl type)) + (not (saut-not specl type)) + (class (saut-class specl type)) + (prototype (saut-prototype specl type)) + (class-eq (saut-class-eq specl type)) + (eql (saut-eql specl type)) + (t (error "~s cannot handle the second argument ~s" + 'specializer-applicable-using-type-p type))))) + +(defun map-all-classes (function &optional (root 't)) + (declare (type function function)) + (let ((braid-p (or (eq *boot-state* 'braid) + (eq *boot-state* 'complete)))) + (labels ((do-class (class) + (mapc #'do-class + (if braid-p + (class-direct-subclasses class) + (early-class-direct-subclasses class))) + (funcall function class))) + (do-class (if (symbolp root) + (find-class root) + root))))) + +;;; +;;; NOTE: We are assuming a restriction on user code that the method +;;; combination must not change once it is connected to the +;;; generic function. +;;; +;;; This has to be legal, because otherwise any kind of method +;;; lookup caching couldn't work. See this by saying that this +;;; cache, is just a backing cache for the fast cache. If that +;;; cache is legal, this one must be too. +;;; +;;; Don't clear this table! +(defvar *effective-method-table* (make-hash-table :test 'eq)) + +(defun get-secondary-dispatch-function (gf methods types &optional + method-alist wrappers) + (function-funcall (get-secondary-dispatch-function1 + gf methods types + (not (null method-alist)) + (not (null wrappers)) + (not (methods-contain-eql-specializer-p methods))) + method-alist wrappers)) + +(defun get-secondary-dispatch-function1 (gf methods types method-alist-p wrappers-p + &optional all-applicable-p + (all-sorted-p t) function-p) + (if (null methods) + (if function-p + #'(lambda (method-alist wrappers) + (declare (ignore method-alist wrappers)) + (fin-lambda-fn (&rest args) + (apply #'no-applicable-method gf args))) + #'(lambda (method-alist wrappers) + (declare (ignore method-alist wrappers)) + #'(lambda (&rest args) + (apply #'no-applicable-method gf args)))) + (let* ((key (car methods)) + (ht-value (or (gethash key *effective-method-table*) + (setf (gethash key *effective-method-table*) + (cons nil nil))))) + (if (and (null (cdr methods)) all-applicable-p ; the most common case + (null method-alist-p) wrappers-p (not function-p)) + (or (car ht-value) + (setf (car ht-value) + (get-secondary-dispatch-function2 + gf methods types method-alist-p wrappers-p + all-applicable-p all-sorted-p function-p))) + (let ((akey (list methods + (if all-applicable-p 'all-applicable types) + method-alist-p wrappers-p function-p))) + (or (cdr (assoc akey (cdr ht-value) :test #'equal)) + (let ((value (get-secondary-dispatch-function2 + gf methods types method-alist-p wrappers-p + all-applicable-p all-sorted-p function-p))) + (push (cons akey value) (cdr ht-value)) + value))))))) + +(defun get-secondary-dispatch-function2 (gf methods types method-alist-p wrappers-p + all-applicable-p all-sorted-p function-p) + (if (and all-applicable-p all-sorted-p (not function-p)) + (if (eq *boot-state* 'complete) + (let* ((combin (generic-function-method-combination gf)) + (effective (compute-effective-method gf combin methods))) + (make-effective-method-function1 gf effective method-alist-p wrappers-p)) + (let ((effective (standard-compute-effective-method gf nil methods))) + (make-effective-method-function1 gf effective method-alist-p wrappers-p))) + (let ((net (generate-discrimination-net + gf methods types all-sorted-p))) + (compute-secondary-dispatch-function1 gf net function-p)))) + +(defun get-effective-method-function (gf methods &optional method-alist wrappers) + (function-funcall (get-secondary-dispatch-function1 gf methods nil + (not (null method-alist)) + (not (null wrappers)) + t) + method-alist wrappers)) + +(defun get-effective-method-function1 (gf methods &optional (sorted-p t)) + (get-secondary-dispatch-function1 gf methods nil nil nil t sorted-p)) + +(defun methods-contain-eql-specializer-p (methods) + (and (eq *boot-state* 'complete) + (dolist (method methods nil) + (when (dolist (spec (method-specializers method) nil) + (when (eql-specializer-p spec) (return t))) + (return t))))) + +(defun update-dfun (generic-function &optional dfun cache info) + (let* ((early-p (early-gf-p generic-function)) + (gf-name (if early-p + (early-gf-name generic-function) + (generic-function-name generic-function))) + (ocache (gf-dfun-cache generic-function))) + (set-dfun generic-function dfun cache info) + (let* ((dfun (if early-p + (or dfun (make-initial-dfun generic-function)) + (compute-discriminating-function generic-function))) + (info (gf-dfun-info generic-function))) + (unless (eq 'default-method-only (type-of info)) + (setq dfun (doctor-dfun-for-the-debugger + generic-function + #+cmu dfun #-cmu (set-function-name dfun gf-name)))) + (set-funcallable-instance-function generic-function dfun) + #+cmu (set-function-name generic-function gf-name) + (when (and ocache (not (eq ocache cache))) (free-cache ocache)) + dfun))) + + +(defvar dfun-count nil) +(defvar dfun-list nil) +(defvar *minimum-cache-size-to-list*) + +(defun list-dfun (gf) + (let* ((sym (type-of (gf-dfun-info gf))) + (a (assq sym dfun-list))) + (unless a + (push (setq a (list sym)) dfun-list)) + (push (generic-function-name gf) (cdr a)))) + +(defun list-all-dfuns () + (setq dfun-list nil) + (map-all-generic-functions #'list-dfun) + dfun-list) + +(defun list-large-cache (gf) + (let* ((sym (type-of (gf-dfun-info gf))) + (cache (gf-dfun-cache gf))) + (when cache + (let ((size (cache-size cache))) + (when (>= size *minimum-cache-size-to-list*) + (let ((a (assoc size dfun-list))) + (unless a + (push (setq a (list size)) dfun-list)) + (push (let ((name (generic-function-name gf))) + (if (eq sym 'caching) name (list name sym))) + (cdr a)))))))) + +(defun list-large-caches (&optional (*minimum-cache-size-to-list* 130)) + (setq dfun-list nil) + (map-all-generic-functions #'list-large-cache) + (setq dfun-list (sort dfun-list #'< :key #'car)) + (mapc #'print dfun-list) + (values)) + + +(defun count-dfun (gf) + (let* ((sym (type-of (gf-dfun-info gf))) + (cache (gf-dfun-cache gf)) + (a (assq sym dfun-count))) + (unless a + (push (setq a (list sym 0 nil)) dfun-count)) + (incf (cadr a)) + (when cache + (let* ((size (cache-size cache)) + (b (assoc size (third a)))) + (unless b + (push (setq b (cons size 0)) (third a))) + (incf (cdr b)))))) + +(defun count-all-dfuns () + (setq dfun-count (mapcar #'(lambda (type) (list type 0 nil)) + '(ONE-CLASS TWO-CLASS DEFAULT-METHOD-ONLY + ONE-INDEX N-N CHECKING CACHING + DISPATCH))) + (map-all-generic-functions #'count-dfun) + (mapc #'(lambda (type+count+sizes) + (setf (third type+count+sizes) + (sort (third type+count+sizes) #'< :key #'car))) + dfun-count) + (mapc #'(lambda (type+count+sizes) + (format t "~&There are ~4d dfuns of type ~s" + (cadr type+count+sizes) (car type+count+sizes)) + (format t "~% ~S~%" (caddr type+count+sizes))) + dfun-count) + (values)) + +(defun gfs-of-type (type) + (unless (consp type) (setq type (list type))) + (let ((gf-list nil)) + (map-all-generic-functions #'(lambda (gf) + (when (memq (type-of (gf-dfun-info gf)) type) + (push gf gf-list)))) + gf-list)) diff --git a/pcl/gcl_pcl_dlisp.lisp b/pcl/gcl_pcl_dlisp.lisp new file mode 100644 index 0000000..4d92600 --- /dev/null +++ b/pcl/gcl_pcl_dlisp.lisp @@ -0,0 +1,425 @@ +;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; + +(in-package :pcl) + +;;; This file is (almost) functionally equivalent to dlap.lisp, +;;; but easier to read. + +;;; Might generate faster code, too, depending on the compiler and +;;; whether an implementation-specific lap assembler was used. + +(defun emit-one-class-reader (class-slot-p) + (emit-reader/writer :reader 1 class-slot-p)) + +(defun emit-one-class-writer (class-slot-p) + (emit-reader/writer :writer 1 class-slot-p)) + +(defun emit-two-class-reader (class-slot-p) + (emit-reader/writer :reader 2 class-slot-p)) + +(defun emit-two-class-writer (class-slot-p) + (emit-reader/writer :writer 2 class-slot-p)) + +;;; -------------------------------- + +(defun emit-one-index-readers (class-slot-p) + (emit-one-or-n-index-reader/writer :reader nil class-slot-p)) + +(defun emit-one-index-writers (class-slot-p) + (emit-one-or-n-index-reader/writer :writer nil class-slot-p)) + +(defun emit-n-n-readers () + (emit-one-or-n-index-reader/writer :reader t nil)) + +(defun emit-n-n-writers () + (emit-one-or-n-index-reader/writer :writer t nil)) + +;;; -------------------------------- + +(defun emit-checking (metatypes applyp) + (emit-checking-or-caching nil nil metatypes applyp)) + +(defun emit-caching (metatypes applyp) + (emit-checking-or-caching t nil metatypes applyp)) + +(defun emit-in-checking-cache-p (metatypes) + (emit-checking-or-caching nil t metatypes nil)) + +(defun emit-constant-value (metatypes) + (emit-checking-or-caching t t metatypes nil)) + +;;; -------------------------------- + +(defvar *precompiling-lap* nil) +(defvar *emit-function-p* t) + +(defun emit-default-only (metatypes applyp) + (when (and (null *precompiling-lap*) *emit-function-p*) + (return-from emit-default-only + (emit-default-only-function metatypes applyp))) + (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)) + (args (remove '&rest dlap-lambda-list)) + (restl (when applyp '(.lap-rest-arg.)))) + (generating-lisp '(emf) + dlap-lambda-list + `(invoke-effective-method-function emf ,applyp ,@args ,@restl)))) + +(defmacro emit-default-only-macro (metatypes applyp) + (let ((*emit-function-p* nil) + (*precompiling-lap* t)) + (values + (emit-default-only metatypes applyp)))) + +;;; -------------------------------- + +(defun generating-lisp (closure-variables args form) + (let* ((rest (memq '&rest args)) + (ldiff (and rest (ldiff args rest))) + (args (if rest (append ldiff '(&rest .lap-rest-arg.)) args)) + (lambda `(lambda ,closure-variables + ,@(when (member 'miss-fn closure-variables) + `((declare (type function miss-fn)))) + (fin-lambda-fn ,args + #+copy-&rest-arg + ,@(when rest + `((setq .lap-rest-arg. (copy-list .lap-rest-arg.)))) + (let () + (declare #.*optimize-speed*) + ,form))))) + (values (if *precompiling-lap* + `#',lambda + (compile-lambda lambda)) + nil))) + +;;; cmu17 note: since std-instance-p is weakened, that branch may run +;;; on non-pcl instances (structures). The result will be the +;;; non-wrapper layout for the structure, which will cause a miss. The "slots" +;;; will be whatever the first slot is, but will be ignored. Similarly, +;;; fsc-instance-p returns true on funcallable structures as well as PCL fins. +;;; +(defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p) + (when (and (null *precompiling-lap*) *emit-function-p*) + (return-from emit-reader/writer + (emit-reader/writer-function reader/writer 1-or-2-class class-slot-p))) + (let ((instance nil) + (arglist ()) + (closure-variables ()) + (field (first-wrapper-cache-number-index)) + (readp (eq reader/writer :reader)) + (read-form (emit-slot-read-form class-slot-p 'index 'slots))) + ;;we need some field to do the fast obsolete check + (ecase reader/writer + (:reader (setq instance (dfun-arg-symbol 0) + arglist (list instance))) + (:writer (setq instance (dfun-arg-symbol 1) + arglist (list (dfun-arg-symbol 0) instance)))) + (ecase 1-or-2-class + (1 (setq closure-variables '(wrapper-0 index miss-fn))) + (2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn)))) + (generating-lisp closure-variables + arglist + `(let* (,@(unless class-slot-p `((slots nil))) + (wrapper (cond ((std-instance-p ,instance) + ,@(unless class-slot-p + `((setq slots (std-instance-slots ,instance)))) + (std-instance-wrapper ,instance)) + ((fsc-instance-p ,instance) + ,@(unless class-slot-p + `((setq slots (fsc-instance-slots ,instance)))) + (fsc-instance-wrapper ,instance)))) + ,@(when readp '(value))) + (if (or (null wrapper) + (zerop (wrapper-cache-number-vector-ref wrapper ,field)) + (not (or (eq wrapper wrapper-0) + ,@(when (eql 2 1-or-2-class) + `((eq wrapper wrapper-1))))) + ,@(when readp `((eq *slot-unbound* (setq value ,read-form))))) + (funcall miss-fn ,@arglist) + ,(if readp + 'value + `(setf ,read-form ,(car arglist)))))))) + +(defun emit-slot-read-form (class-slot-p index slots) + (if class-slot-p + `(cdr ,index) + `(%instance-ref ,slots ,index))) + +(defun emit-boundp-check (value-form miss-fn arglist) + `(let ((value ,value-form)) + (if (eq value *slot-unbound*) + (funcall ,miss-fn ,@arglist) + value))) + +(defun emit-slot-access (reader/writer class-slot-p slots index miss-fn arglist) + (let ((read-form (emit-slot-read-form class-slot-p index slots))) + (ecase reader/writer + (:reader (emit-boundp-check read-form miss-fn arglist)) + (:writer `(setf ,read-form ,(car arglist)))))) + +(defmacro emit-reader/writer-macro (reader/writer 1-or-2-class class-slot-p) + (let ((*emit-function-p* nil) + (*precompiling-lap* t)) + (values + (emit-reader/writer reader/writer 1-or-2-class class-slot-p)))) + +(defun emit-one-or-n-index-reader/writer (reader/writer cached-index-p class-slot-p) + (when (and (null *precompiling-lap*) *emit-function-p*) + (return-from emit-one-or-n-index-reader/writer + (emit-one-or-n-index-reader/writer-function + reader/writer cached-index-p class-slot-p))) + (multiple-value-bind (arglist metatypes) + (ecase reader/writer + (:reader (values (list (dfun-arg-symbol 0)) + '(standard-instance))) + (:writer (values (list (dfun-arg-symbol 0) (dfun-arg-symbol 1)) + '(t standard-instance)))) + (generating-lisp `(cache ,@(unless cached-index-p '(index)) miss-fn) + arglist + `(let (,@(unless class-slot-p '(slots)) + ,@(when cached-index-p '(index))) + ,(emit-dlap arglist metatypes + (emit-slot-access reader/writer class-slot-p + 'slots 'index 'miss-fn arglist) + `(funcall miss-fn ,@arglist) + (when cached-index-p 'index) + (unless class-slot-p '(slots))))))) + +(defmacro emit-one-or-n-index-reader/writer-macro + (reader/writer cached-index-p class-slot-p) + (let ((*emit-function-p* nil) + (*precompiling-lap* t)) + (values + (emit-one-or-n-index-reader/writer reader/writer cached-index-p class-slot-p)))) + +(defun emit-miss (miss-fn args &optional applyp) + (let ((restl (when applyp '(.lap-rest-arg.)))) + (if restl + `(apply ,miss-fn ,@args ,@restl) + `(funcall ,miss-fn ,@args ,@restl)))) + +(defun emit-checking-or-caching (cached-emf-p return-value-p metatypes applyp) + (when (and (null *precompiling-lap*) *emit-function-p*) + (return-from emit-checking-or-caching + (emit-checking-or-caching-function + cached-emf-p return-value-p metatypes applyp))) + (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)) + (args (remove '&rest dlap-lambda-list)) + (restl (when applyp '(.lap-rest-arg.)))) + (generating-lisp `(cache ,@(unless cached-emf-p '(emf)) miss-fn) + dlap-lambda-list + `(let (,@(when cached-emf-p '(emf))) + ,(emit-dlap args + metatypes + (if return-value-p + (if cached-emf-p 'emf t) + `(invoke-effective-method-function emf ,applyp + ,@args ,@restl)) + (emit-miss 'miss-fn args applyp) + (when cached-emf-p 'emf)))))) + +(defmacro emit-checking-or-caching-macro (cached-emf-p return-value-p metatypes applyp) + (let ((*emit-function-p* nil) + (*precompiling-lap* t)) + (values + (emit-checking-or-caching cached-emf-p return-value-p metatypes applyp)))) + +(defun emit-dlap (args metatypes hit miss value-reg &optional slot-regs) + (let* ((index -1) + (wrapper-bindings (mapcan #'(lambda (arg mt) + (unless (eq mt 't) + (incf index) + `((,(intern (format nil "WRAPPER-~D" index) + *the-pcl-package*) + ,(emit-fetch-wrapper mt arg 'miss + (pop slot-regs)))))) + args metatypes)) + (wrappers (mapcar #'car wrapper-bindings))) + (declare (fixnum index)) + (unless wrappers (error "Every metatype is T.")) + `(block dfun + (tagbody + (let ((field (cache-field cache)) + (cache-vector (cache-vector cache)) + (mask (cache-mask cache)) + (size (cache-size cache)) + (overflow (cache-overflow cache)) + ,@wrapper-bindings) + (declare (fixnum size field mask)) + ,(cond ((cdr wrappers) + (emit-greater-than-1-dlap wrappers 'miss value-reg)) + (value-reg + (emit-1-t-dlap (car wrappers) 'miss value-reg)) + (t + (emit-1-nil-dlap (car wrappers) 'miss))) + (return-from dfun ,hit)) + miss + (return-from dfun ,miss))))) + +(defun emit-1-nil-dlap (wrapper miss-label) + `(let* ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper miss-label)) + (location primary)) + (declare (fixnum primary location)) + (block search + (loop (when (eq ,wrapper (cache-vector-ref cache-vector location)) + (return-from search nil)) + (setq location (the fixnum (+ location 1))) + (when (= location size) + (setq location 0)) + (when (= location primary) + (dolist (entry overflow) + (when (eq (car entry) ,wrapper) + (return-from search nil))) + (go ,miss-label)))))) + +(defmacro get-cache-vector-lock-count (cache-vector) + `(let ((lock-count (cache-vector-lock-count ,cache-vector))) + (unless (typep lock-count 'fixnum) + (error "my cache got freed somehow")) + (the fixnum lock-count))) + +(defun emit-1-t-dlap (wrapper miss-label value) + `(let ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper miss-label)) + (initial-lock-count (get-cache-vector-lock-count cache-vector))) + (declare (fixnum primary initial-lock-count)) + (let ((location primary)) + (declare (fixnum location)) + (block search + (loop (when (eq ,wrapper (cache-vector-ref cache-vector location)) + (setq ,value (cache-vector-ref cache-vector (1+ location))) + (return-from search nil)) + (setq location (the fixnum (+ location 2))) + (when (= location size) + (setq location 0)) + (when (= location primary) + (dolist (entry overflow) + (when (eq (car entry) ,wrapper) + (setq ,value (cdr entry)) + (return-from search nil))) + (go ,miss-label)))) + (unless (= initial-lock-count + (get-cache-vector-lock-count cache-vector)) + (go ,miss-label))))) + +(defun emit-greater-than-1-dlap (wrappers miss-label value) + (declare (type list wrappers)) + (let ((cache-line-size (compute-line-size (+ (length wrappers) (if value 1 0))))) + `(let ((primary 0) (size-1 (the fixnum (- size 1)))) + (declare (fixnum primary size-1)) + ,(emit-n-wrapper-compute-primary-cache-location wrappers miss-label) + (let ((initial-lock-count (get-cache-vector-lock-count cache-vector))) + (declare (fixnum initial-lock-count)) + (let ((location primary) (next-location 0)) + (declare (fixnum location next-location)) + (block search + (loop (setq next-location (the fixnum (+ location ,cache-line-size))) + (when (and ,@(mapcar + #'(lambda (wrapper) + `(eq ,wrapper + (cache-vector-ref cache-vector + (setq location + (the fixnum (+ location 1)))))) + wrappers)) + ,@(when value + `((setq location (the fixnum (+ location 1))) + (setq ,value (cache-vector-ref cache-vector location)))) + (return-from search nil)) + (setq location next-location) + (when (= location size-1) + (setq location 0)) + (when (= location primary) + (dolist (entry overflow) + (let ((entry-wrappers (car entry))) + (when (and ,@(mapcar #'(lambda (wrapper) + `(eq ,wrapper (pop entry-wrappers))) + wrappers)) + ,@(when value + `((setq ,value (cdr entry)))) + (return-from search nil)))) + (go ,miss-label)))) + (unless (= initial-lock-count + (get-cache-vector-lock-count cache-vector)) + (go ,miss-label))))))) + +(defun emit-1-wrapper-compute-primary-cache-location (wrapper miss-label) + `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref ,wrapper field))) + (declare (fixnum wrapper-cache-no)) + (when (zerop wrapper-cache-no) (go ,miss-label)) + ,(let ((form `(#+lucid %logand #-lucid logand + mask wrapper-cache-no))) + #+lucid form + #-lucid `(the fixnum ,form)))) + +(defun emit-n-wrapper-compute-primary-cache-location (wrappers miss-label) + (declare (type list wrappers)) + ;; this returns 1 less that the actual location + `(progn + ,@(let ((adds 0) (len (length wrappers))) + (declare (fixnum adds len)) + (mapcar #'(lambda (wrapper) + `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref + ,wrapper field))) + (declare (fixnum wrapper-cache-no)) + (when (zerop wrapper-cache-no) (go ,miss-label)) + (setq primary (the fixnum (+ primary wrapper-cache-no))) + ,@(progn + (incf adds) + (when (or (zerop (mod adds wrapper-cache-number-adds-ok)) + (eql adds len)) + `((setq primary + ,(let ((form `(#+lucid %logand #-lucid logand + primary mask))) + #+lucid form + #-lucid `(the fixnum ,form)))))))) + wrappers)))) + +;;; cmu17 note: since std-instance-p is weakened, that branch may run +;;; on non-pcl instances (structures). The result will be the +;;; non-wrapper layout for the structure, which will cause a miss. The "slots" +;;; will be whatever the first slot is, but will be ignored. Similarly, +;;; fsc-instance-p returns true on funcallable structures as well as PCL fins. +;;; +(defun emit-fetch-wrapper (metatype argument miss-label &optional slot) + (ecase metatype + ((standard-instance #+new-kcl-wrapper structure-instance) + `(cond ((std-instance-p ,argument) + ,@(when slot `((setq ,slot (std-instance-slots ,argument)))) + (std-instance-wrapper ,argument)) + ((fsc-instance-p ,argument) + ,@(when slot `((setq ,slot (fsc-instance-slots ,argument)))) + (fsc-instance-wrapper ,argument)) + (t + (go ,miss-label)))) + (class + (when slot (error "Can't do a slot reg for this metatype.")) + `(wrapper-of-macro ,argument)) + ((built-in-instance #-new-kcl-wrapper structure-instance) + (when slot (error "Can't do a slot reg for this metatype.")) + `(#+new-kcl-wrapper built-in-wrapper-of + #-new-kcl-wrapper built-in-or-structure-wrapper + ,argument)))) + diff --git a/pcl/gcl_pcl_dlisp2.lisp b/pcl/gcl_pcl_dlisp2.lisp new file mode 100644 index 0000000..3b33a31 --- /dev/null +++ b/pcl/gcl_pcl_dlisp2.lisp @@ -0,0 +1,178 @@ +;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; + +(in-package :pcl) + +(defun emit-reader/writer-function (reader/writer 1-or-2-class class-slot-p) + (values + (ecase reader/writer + (:reader (ecase 1-or-2-class + (1 (if class-slot-p + (emit-reader/writer-macro :reader 1 t) + (emit-reader/writer-macro :reader 1 nil))) + (2 (if class-slot-p + (emit-reader/writer-macro :reader 2 t) + (emit-reader/writer-macro :reader 2 nil))))) + (:writer (ecase 1-or-2-class + (1 (if class-slot-p + (emit-reader/writer-macro :writer 1 t) + (emit-reader/writer-macro :writer 1 nil))) + (2 (if class-slot-p + (emit-reader/writer-macro :writer 2 t) + (emit-reader/writer-macro :writer 2 nil)))))) + nil)) + +(defun emit-one-or-n-index-reader/writer-function + (reader/writer cached-index-p class-slot-p) + (values + (ecase reader/writer + (:reader (if cached-index-p + (if class-slot-p + (emit-one-or-n-index-reader/writer-macro :reader t t) + (emit-one-or-n-index-reader/writer-macro :reader t nil)) + (if class-slot-p + (emit-one-or-n-index-reader/writer-macro :reader nil t) + (emit-one-or-n-index-reader/writer-macro :reader nil nil)))) + (:writer (if cached-index-p + (if class-slot-p + (emit-one-or-n-index-reader/writer-macro :writer t t) + (emit-one-or-n-index-reader/writer-macro :writer t nil)) + (if class-slot-p + (emit-one-or-n-index-reader/writer-macro :writer nil t) + (emit-one-or-n-index-reader/writer-macro :writer nil nil))))) + nil)) + +(eval-when (compile load eval) +(defparameter checking-or-caching-list + '() + #|| + '((T NIL (CLASS) NIL) + (T NIL (CLASS CLASS) NIL) + (T NIL (CLASS CLASS CLASS) NIL) + (T NIL (CLASS CLASS T) NIL) + (T NIL (CLASS CLASS T T) NIL) + (T NIL (CLASS CLASS T T T) NIL) + (T NIL (CLASS T) NIL) + (T NIL (CLASS T T) NIL) + (T NIL (CLASS T T T) NIL) + (T NIL (CLASS T T T T) NIL) + (T NIL (CLASS T T T T T) NIL) + (T NIL (CLASS T T T T T T) NIL) + (T NIL (T CLASS) NIL) + (T NIL (T CLASS T) NIL) + (T NIL (T T CLASS) NIL) + (T NIL (CLASS) T) + (T NIL (CLASS CLASS) T) + (T NIL (CLASS T) T) + (T NIL (CLASS T T) T) + (T NIL (CLASS T T T) T) + (T NIL (T CLASS) T) + (T T (CLASS) NIL) + (T T (CLASS CLASS) NIL) + (T T (CLASS CLASS CLASS) NIL) + (NIL NIL (CLASS) NIL) + (NIL NIL (CLASS CLASS) NIL) + (NIL NIL (CLASS CLASS T) NIL) + (NIL NIL (CLASS CLASS T T) NIL) + (NIL NIL (CLASS T) NIL) + (NIL NIL (T CLASS T) NIL) + (NIL NIL (CLASS) T) + (NIL NIL (CLASS CLASS) T)) ||# )) + +(defmacro make-checking-or-caching-function-list () + `(list ,@(mapcar #'(lambda (key) + `(cons ',key (emit-checking-or-caching-macro ,@key))) + checking-or-caching-list))) + +(defvar checking-or-caching-function-list) + +(defun initialize-checking-or-caching-function-list () + (setq checking-or-caching-function-list + (make-checking-or-caching-function-list))) + +(initialize-checking-or-caching-function-list) + +(defmacro emit-checking-or-caching-function-precompiled () + `(cdr (assoc (list cached-emf-p return-value-p metatypes applyp) + checking-or-caching-function-list + :test #'equal))) + +(defun emit-checking-or-caching-function (cached-emf-p return-value-p metatypes applyp) + (let ((fn (emit-checking-or-caching-function-precompiled))) + (if fn + (values fn nil) + (values (emit-checking-or-caching-function-preliminary + cached-emf-p return-value-p metatypes applyp) + t)))) + +(defvar not-in-cache (make-symbol "not in cache")) + +(defun emit-checking-or-caching-function-preliminary + (cached-emf-p return-value-p metatypes applyp) + (declare (ignore applyp)) + (if cached-emf-p + #'(lambda (cache miss-fn) + (declare (type function miss-fn)) + (fin-lambda-fn (&rest args) + (declare #.*optimize-speed*) + #+copy-&rest-arg (setq args (copy-list args)) + (with-dfun-wrappers (args metatypes) (dfun-wrappers invalid-wrapper-p) + (apply miss-fn args) + (if invalid-wrapper-p + (apply miss-fn args) + (let ((emf (probe-cache cache dfun-wrappers not-in-cache))) + (if (eq emf not-in-cache) + (apply miss-fn args) + (if return-value-p + emf + (invoke-emf emf args)))))))) + #'(lambda (cache emf miss-fn) + (declare (type function miss-fn)) + (fin-lambda-fn (&rest args) + (declare #.*optimize-speed*) + #+copy-&rest-arg (setq args (copy-list args)) + (with-dfun-wrappers (args metatypes) (dfun-wrappers invalid-wrapper-p) + (apply miss-fn args) + (if invalid-wrapper-p + (apply miss-fn args) + (let ((found-p (not (eq not-in-cache + (probe-cache cache dfun-wrappers + not-in-cache))))) + (if found-p + (invoke-emf emf args) + (if return-value-p + t + (apply miss-fn args)))))))))) + + +(defun emit-default-only-function (metatypes applyp) + (declare (ignore metatypes applyp)) + (values #'(lambda (emf) + #'(lambda (&rest args) + #+copy-&rest-arg (setq args (copy-list args)) + (invoke-emf emf args))) + t)) diff --git a/pcl/gcl_pcl_env.lisp b/pcl/gcl_pcl_env.lisp new file mode 100644 index 0000000..7c286fa --- /dev/null +++ b/pcl/gcl_pcl_env.lisp @@ -0,0 +1,406 @@ +;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; +;;; Basic environmental stuff. +;;; + +(in-package :pcl) + +#+Lucid +(progn + +(defun pcl-arglist (function &rest other-args) + (let ((defn nil)) + (cond ((and (fsc-instance-p function) + (generic-function-p function)) + (generic-function-pretty-arglist function)) + ((and (symbolp function) + (fboundp function) + (setq defn (symbol-function function)) + (fsc-instance-p defn) + (generic-function-p defn)) + (generic-function-pretty-arglist defn)) + (t (apply (original-definition 'sys::arglist) + function other-args))))) + +(redefine-function 'sys::arglist 'pcl-arglist) + +) + + +;;; +;;; +;;; + +(defgeneric describe-object (object stream)) + +#-Genera +(progn + +(defun pcl-describe (object #+Lispm &optional #+Lispm no-complaints) + (let (#+Lispm (*describe-no-complaints* no-complaints)) + #+Lispm (declare (special *describe-no-complaints*)) + (describe-object object *standard-output*) + (values))) + +(defmethod describe-object (object stream) + #-cmu + (cond ((or #+kcl (packagep object)) + (describe-package object stream)) + (t + (funcall (original-definition 'describe) object))) + #+cmu + (describe object stream)) + +#-cmu +(redefine-function 'describe 'pcl-describe) + +) + +(defmethod describe-object ((object slot-object) stream) + (let* ((class (class-of object)) + (slotds (slots-to-inspect class object)) + (max-slot-name-length 0) + (instance-slotds ()) + (class-slotds ()) + (other-slotds ())) + (flet ((adjust-slot-name-length (name) + (setq max-slot-name-length + (max max-slot-name-length + (length (the string (symbol-name name)))))) + (describe-slot (name value &optional (allocation () alloc-p)) + (if alloc-p + (format stream + "~% ~A ~S ~VT ~S" + name allocation (+ max-slot-name-length 7) value) + (format stream + "~% ~A~VT ~S" + name max-slot-name-length value)))) + ;; Figure out a good width for the slot-name column. + (dolist (slotd slotds) + (adjust-slot-name-length (slot-definition-name slotd)) + (case (slot-definition-allocation slotd) + (:instance (push slotd instance-slotds)) + (:class (push slotd class-slotds)) + (otherwise (push slotd other-slotds)))) + (setq max-slot-name-length (min (+ max-slot-name-length 3) 30)) + (format stream "~%~S is an instance of class ~S:" object class) + + (when instance-slotds + (format stream "~% The following slots have :INSTANCE allocation:") + (dolist (slotd (nreverse instance-slotds)) + (describe-slot (slot-definition-name slotd) + (slot-value-or-default object (slot-definition-name slotd))))) + + (when class-slotds + (format stream "~% The following slots have :CLASS allocation:") + (dolist (slotd (nreverse class-slotds)) + (describe-slot (slot-definition-name slotd) + (slot-value-or-default object (slot-definition-name slotd))))) + + (when other-slotds + (format stream "~% The following slots have allocation as shown:") + (dolist (slotd (nreverse other-slotds)) + (describe-slot (slot-definition-name slotd) + (slot-value-or-default object (slot-definition-name slotd)) + (slot-definition-allocation slotd)))) + (values)))) + +(defmethod slots-to-inspect ((class slot-class) (object slot-object)) + (class-slots class)) + +(defvar *describe-metaobjects-as-objects-p* nil) + +(defmethod describe-object ((fun standard-generic-function) stream) + (format stream "~A is a generic function.~%" fun) + (format stream "Its arguments are:~% ~S~%" + (generic-function-pretty-arglist fun)) + (format stream "Its methods are:") + (dolist (meth (generic-function-methods fun)) + (format stream "~2% ~{~S ~}~:S =>~%" + (method-qualifiers meth) + (unparse-specializers meth)) + (describe-object (or (method-fast-function meth) + (method-function meth)) + stream)) + (when *describe-metaobjects-as-objects-p* + (call-next-method))) + +;;; +;;; +;;; +(defmethod describe-object ((class class) stream) + (flet ((pretty-class (c) (or (class-name c) c))) + (macrolet ((ft (string &rest args) `(format stream ,string ,@args))) + (ft "~&~S is a class, it is an instance of ~S.~%" + class (pretty-class (class-of class))) + (let ((name (class-name class))) + (if name + (if (eq class (find-class name nil)) + (ft "Its proper name is ~S.~%" name) + (ft "Its name is ~S, but this is not a proper name.~%" name)) + (ft "It has no name (the name is NIL).~%"))) + (ft "The direct superclasses are: ~:S, and the direct~%~ + subclasses are: ~:S. The class precedence list is:~%~S~%~ + There are ~D methods specialized for this class." + (mapcar #'pretty-class (class-direct-superclasses class)) + (mapcar #'pretty-class (class-direct-subclasses class)) + (mapcar #'pretty-class (class-precedence-list class)) + (length (specializer-direct-methods class))))) + (when *describe-metaobjects-as-objects-p* + (call-next-method))) + +(defun describe-package (object stream) + (unless (packagep object) (setq object (find-package object))) + (format stream "~&~S is a ~S.~%" object (type-of object)) + (let ((nick (package-nicknames object))) + (when nick + (format stream "You can also call it~@[ ~{~S~^, ~} or~] ~S.~%" + (butlast nick) (first (last nick))))) + (let* (#+cmu (internal (lisp::package-internal-symbols object)) + (internal-count #+cmu (- (lisp::package-hashtable-size internal) + (lisp::package-hashtable-free internal)) + #-cmu 0) + #+cmu (external (lisp::package-external-symbols object)) + (external-count #+cmu (- (lisp::package-hashtable-size external) + (lisp::package-hashtable-free external)) + #-cmu 0)) + #-cmu (do-external-symbols (sym object) + (declare (ignore sym)) + (incf external-count)) + #-cmu (do-symbols (sym object) + (declare (ignore sym)) + (incf internal-count)) + #-cmu (decf internal-count external-count) + (format stream "It has ~D internal and ~D external symbols (~D total).~%" + internal-count external-count (+ internal-count external-count))) + (let ((used (package-use-list object))) + (when used + (format stream "It uses the packages ~{~S~^, ~}.~%" + (mapcar #'package-name used)))) + (let ((users (package-use-list object))) + (when users + (format stream "It is used by the packages ~{~S~^, ~}.~%" + (mapcar #'package-name users))))) + +#+cmu +(defmethod describe-object ((object package) stream) + (describe-package object stream)) + +#+cmu +(defmethod describe-object ((object hash-table) stream) + (format stream "~&~S is an ~a hash table." + object + #-cmu17 (lisp::hash-table-kind object) + #+cmu17 (lisp::hash-table-test object)) + (format stream "~&Its size is ~d buckets." + (lisp::hash-table-size object)) + (format stream "~&Its rehash-size is ~d." + (lisp::hash-table-rehash-size object)) + (format stream "~&Its rehash-threshold is ~d." + (hash-table-rehash-threshold object)) + (format stream "~&It currently holds ~d entries." + (lisp::hash-table-number-entries object))) + + + +;;; +;;; trace-method and untrace-method accept method specs as arguments. A +;;; method-spec should be a list like: +;;; ( qualifiers* (specializers*)) +;;; where should be either a symbol or a list +;;; of (SETF ). +;;; +;;; For example, to trace the method defined by: +;;; +;;; (defmethod foo ((x spaceship)) 'ss) +;;; +;;; You should say: +;;; +;;; (trace-method '(foo (spaceship))) +;;; +;;; You can also provide a method object in the place of the method +;;; spec, in which case that method object will be traced. +;;; +;;; For untrace-method, if an argument is given, that method is untraced. +;;; If no argument is given, all traced methods are untraced. +;;; +(defclass traced-method (method) + ((method :initarg :method) + (function :initarg :function + :reader method-function) + (generic-function :initform nil + :accessor method-generic-function))) + +(defmethod method-lambda-list ((m traced-method)) + (with-slots (method) m (method-lambda-list method))) + +(defmethod method-specializers ((m traced-method)) + (with-slots (method) m (method-specializers method))) + +(defmethod method-qualifiers ((m traced-method)) + (with-slots (method) m (method-qualifiers method))) + +(defmethod accessor-method-slot-name ((m traced-method)) + (with-slots (method) m (accessor-method-slot-name method))) + +(defvar *traced-methods* ()) + +(defun trace-method (spec &rest options) + #+copy-&rest-arg (setq options (copy-list options)) + (multiple-value-bind (gf omethod name) + (parse-method-or-spec spec) + (let* ((tfunction (trace-method-internal (method-function omethod) + name + options)) + (tmethod (make-instance 'traced-method + :method omethod + :function tfunction))) + (remove-method gf omethod) + (add-method gf tmethod) + (pushnew tmethod *traced-methods*) + tmethod))) + +(defun untrace-method (&optional spec) + (flet ((untrace-1 (m) + (let ((gf (method-generic-function m))) + (when gf + (remove-method gf m) + (add-method gf (slot-value m 'method)) + (setq *traced-methods* (remove m *traced-methods*)))))) + (if (not (null spec)) + (multiple-value-bind (gf method) + (parse-method-or-spec spec) + (declare (ignore gf)) + (if (memq method *traced-methods*) + (untrace-1 method) + (error "~S is not a traced method?" method))) + (dolist (m *traced-methods*) (untrace-1 m))))) + +(defun trace-method-internal (ofunction name options) + (eval `(untrace ,name)) + (setf (symbol-function name) ofunction) + (eval `(trace ,name ,@options)) + (symbol-function name)) + + + + +;(defun compile-method (spec) +; (multiple-value-bind (gf method name) +; (parse-method-or-spec spec) +; (declare (ignore gf)) +; (compile name (method-function method)) +; (setf (method-function method) (symbol-function name)))) + +(defmacro undefmethod (&rest args) + #+(or (not :lucid) :lcl3.0) + (declare (arglist name {method-qualifier}* specializers)) + `(undefmethod-1 ',args)) + +(defun undefmethod-1 (args) + (multiple-value-bind (gf method) + (parse-method-or-spec args) + (when (and gf method) + (remove-method gf method) + method))) + + +(pushnew :pcl *features*) +(pushnew :portable-commonloops *features*) +(pushnew :pcl-structures *features*) + +#+cmu +(when (find-package "OLD-PCL") + (setf (symbol-function (find-symbol "PRINT-OBJECT" :old-pcl)) + (symbol-function 'pcl::print-object))) + + +;;;; MAKE-LOAD-FORM + +#+cmu17 +(export '(cl::make-load-form cl::make-load-form-saving-slots) "CL") + +#+cmu17 +(progn + (defgeneric make-load-form (object &optional environment)) + + (defmethod make-load-form ((object structure-object) &optional environment) + (declare (ignore environment)) + (kernel:make-structure-load-form object)) + + (defmethod make-load-form ((object wrapper) &optional env) + (declare (ignore env)) + (let ((pname (kernel:class-proper-name (kernel:layout-class object)))) + (unless pname + (error "Can't dump wrapper for anonymous class:~% ~S" + (kernel:layout-class object))) + `(kernel:class-layout (lisp:find-class ',pname)))) + + (defun make-load-form-saving-slots (object &key slot-names environment) + (declare (ignore environment)) + (when slot-names + (warn ":SLOT-NAMES MAKE-LOAD-FORM option not implemented, dumping all ~ + slots:~% ~S" + object)) + :just-dump-it-normally)) + + +;;; The following are hacks to deal with CMU CL having two different CLASS +;;; classes. +;;; +#+cmu17 +(defun coerce-to-pcl-class (class) + (if (typep class 'lisp:class) + (or (kernel:class-pcl-class class) + (find-structure-class (lisp:class-name class))) + class)) + +#+cmu17 +(progn + (defmethod make-instance ((class lisp:class) &rest stuff) + (apply #'make-instance (coerce-to-pcl-class class) stuff)) + (defmethod change-class (instance (class lisp:class)) + (apply #'change-class instance (coerce-to-pcl-class class)))) + +#+cmu17 +(macrolet ((frob (&rest names) + `(progn + ,@(mapcar #'(lambda (name) + `(defmethod ,name ((class lisp:class)) + (funcall #',name + (coerce-to-pcl-class class)))) + names)))) + (frob + class-direct-slots + class-prototype + class-precedence-list + class-direct-default-initargs + class-direct-superclasses + compute-class-precedence-list + class-default-initargs class-finalized-p + class-direct-subclasses class-slots + make-instances-obsolete)) diff --git a/pcl/gcl_pcl_fast_init.lisp b/pcl/gcl_pcl_fast_init.lisp new file mode 100644 index 0000000..f9c9d45 --- /dev/null +++ b/pcl/gcl_pcl_fast_init.lisp @@ -0,0 +1,1048 @@ +;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; +;;; +;;; This file defines the optimized make-instance functions. +;;; + +(in-package :pcl) + +(defvar *compile-make-instance-functions-p* nil) + +(defun update-make-instance-function-table (&optional (class *the-class-t*)) + (when (symbolp class) (setq class (find-class class))) + (when (eq class *the-class-t*) (setq class *the-class-slot-object*)) + (when (memq *the-class-slot-object* (class-precedence-list class)) + (map-all-classes #'reset-class-initialize-info class))) + +(defun constant-symbol-p (form) + (and (constantp form) + (let ((object (eval form))) + (and (symbolp object) + (symbol-package object))))) + +(defvar *make-instance-function-keys* nil) + +(defun expand-make-instance-form (form) + (let ((class (cadr form)) (initargs (cddr form)) + (keys nil)(allow-other-keys-p nil) key value) + (when (and (constant-symbol-p class) + (let ((initargs-tail initargs)) + (loop (when (null initargs-tail) (return t)) + (unless (constant-symbol-p (car initargs-tail)) + (return nil)) + (setq key (eval (pop initargs-tail))) + (setq value (pop initargs-tail)) + (when (eq ':allow-other-keys key) + (setq allow-other-keys-p value)) + (push key keys)))) + (let* ((class (eval class)) + (keys (nreverse keys)) + (key (list class keys allow-other-keys-p)) + (sym (make-instance-function-symbol key))) + (push key *make-instance-function-keys*) + (when sym + `(,sym ',class ,@initargs)))))) + +(defmacro expanding-make-instance-top-level (&rest forms &environment env) + (let* ((*make-instance-function-keys* nil) + (form (macroexpand `(expanding-make-instance ,@forms) env))) + `(progn + ,@(when *make-instance-function-keys* + `((get-make-instance-functions ',*make-instance-function-keys*))) + ,form))) + +(defmacro expanding-make-instance (&rest forms &environment env) + `(progn + ,@(mapcar #'(lambda (form) + (walk-form form env + #'(lambda (subform context env) + (declare (ignore env)) + (or (and (eq context ':eval) + (consp subform) + (eq (car subform) 'make-instance) + (expand-make-instance-form subform)) + subform)))) + forms))) + +(defmacro defconstructor + (name class lambda-list &rest initialization-arguments) + `(expanding-make-instance-top-level + (defun ,name ,lambda-list + (make-instance ',class ,@initialization-arguments)))) + +(defun get-make-instance-functions (key-list) + (dolist (key key-list) + (let* ((cell (find-class-cell (car key))) + (make-instance-function-keys + (find-class-cell-make-instance-function-keys cell)) + (mif-key (cons (cadr key) (caddr key)))) + (unless (find mif-key make-instance-function-keys + :test #'equal) + (push mif-key (find-class-cell-make-instance-function-keys cell)) + (let ((class (find-class-cell-class cell))) + (when (and class (not (forward-referenced-class-p class))) + (update-initialize-info-internal + (initialize-info class (car mif-key) nil (cdr mif-key)) + 'make-instance-function))))))) + +(defun make-instance-function-symbol (key) + (let* ((class (car key)) + (symbolp (symbolp class))) + (when (or symbolp (classp class)) + (let* ((class-name (if (symbolp class) class (class-name class))) + (keys (cadr key)) + (allow-other-keys-p (caddr key))) + (when (and (or symbolp + (and (symbolp class-name) + (eq class (find-class class-name nil)))) + (symbol-package class-name)) + (let ((*package* *the-pcl-package*) + (*print-length* nil) (*print-level* nil) + (*print-circle* nil) (*print-case* :upcase) + (*print-pretty* nil)) + (intern (format nil "MAKE-INSTANCE ~S ~S ~S" + class-name keys allow-other-keys-p)))))))) + +(defun make-instance-1 (class &rest initargs) + (apply #'make-instance class initargs)) + +(defmacro define-cached-reader (type name trap) + (let ((reader-name (intern (format nil "~A-~A" type name))) + (cached-name (intern (format nil "~A-CACHED-~A" type name)))) + `(defmacro ,reader-name (info) + `(let ((value (,',cached-name ,info))) + (if (eq value ':unknown) + (progn + (,',trap ,info ',',name) + (,',cached-name ,info)) + value))))) + +(eval-when (compile load eval) +(defparameter initialize-info-cached-slots + '(valid-p ; t or (:invalid key) + ri-valid-p + initargs-form-list + combined-initargs-form-list + new-keys + default-initargs-function + shared-initialize-t-function + shared-initialize-nil-function + constants + combined-initialize-function ; allocate-instance + shared-initialize + make-instance-function ; nil means use gf + make-instance-function-symbol))) + +(defmacro define-initialize-info () + (let ((cached-slot-names + (mapcar #'(lambda (name) + (intern (format nil "CACHED-~A" name))) + initialize-info-cached-slots)) + (cached-names + (mapcar #'(lambda (name) + (intern (format nil "~A-CACHED-~A" + 'initialize-info name))) + initialize-info-cached-slots))) + `(progn + (defstruct initialize-info + key wrapper + ,@(mapcar #'(lambda (name) + `(,name :unknown)) + cached-slot-names)) + (defmacro reset-initialize-info-internal (info) + `(progn + ,@(mapcar #'(lambda (cname) + `(setf (,cname ,info) ':unknown)) + ',cached-names))) + (defun initialize-info-bound-slots (info) + (let ((slots nil)) + ,@(mapcar #'(lambda (name cached-name) + `(unless (eq ':unknown (,cached-name info)) + (push ',name slots))) + initialize-info-cached-slots cached-names) + slots)) + ,@(mapcar #'(lambda (name) + `(define-cached-reader initialize-info ,name + update-initialize-info-internal)) + initialize-info-cached-slots)))) + +(define-initialize-info) + +(defvar *initialize-info-cache-class* nil) +(defvar *initialize-info-cache-initargs* nil) +(defvar *initialize-info-cache-info* nil) + +(defvar *revert-initialize-info-p* nil) + +(defun reset-initialize-info (info) + (setf (initialize-info-wrapper info) + (class-wrapper (car (initialize-info-key info)))) + (let ((slots-to-revert (if *revert-initialize-info-p* + (initialize-info-bound-slots info) + '(make-instance-function)))) + (reset-initialize-info-internal info) + (dolist (slot slots-to-revert) + (update-initialize-info-internal info slot)) + info)) + +(defun reset-class-initialize-info (class) + (reset-class-initialize-info-1 (class-initialize-info class))) + +(defun reset-class-initialize-info-1 (cell) + (when (consp cell) + (when (car cell) + (reset-initialize-info (car cell))) + (let ((alist (cdr cell))) + (dolist (a alist) + (reset-class-initialize-info-1 (cdr a)))))) + +(defun initialize-info (class initargs &optional (plist-p t) allow-other-keys-arg) + (let ((info nil)) + (if (and (eq *initialize-info-cache-class* class) + (eq *initialize-info-cache-initargs* initargs)) + (setq info *initialize-info-cache-info*) + (let ((initargs-tail initargs) + (cell (or (class-initialize-info class) + (setf (class-initialize-info class) (cons nil nil))))) + (loop (when (null initargs-tail) (return nil)) + (let ((keyword (pop initargs-tail)) + (alist-cell cell)) + (when plist-p + (if (eq keyword :allow-other-keys) + (setq allow-other-keys-arg (pop initargs-tail)) + (pop initargs-tail))) + (loop (let ((alist (cdr alist-cell))) + (when (null alist) + (setq cell (cons nil nil)) + (setf (cdr alist-cell) (list (cons keyword cell))) + (return nil)) + (when (eql keyword (caar alist)) + (setq cell (cdar alist)) + (return nil)) + (setq alist-cell alist))))) + (setq info (or (car cell) + (setf (car cell) (make-initialize-info)))))) + (let ((wrapper (initialize-info-wrapper info))) + (unless (eq wrapper (class-wrapper class)) + (unless wrapper + (let* ((initargs-tail initargs) + (klist-cell (list nil)) + (klist-tail klist-cell)) + (loop (when (null initargs-tail) (return nil)) + (let ((key (pop initargs-tail))) + (setf (cdr klist-tail) (list key))) + (setf klist-tail (cdr klist-tail)) + (when plist-p (pop initargs-tail))) + (setf (initialize-info-key info) + (list class (cdr klist-cell) allow-other-keys-arg)))) + (reset-initialize-info info))) + (setq *initialize-info-cache-class* class) + (setq *initialize-info-cache-initargs* initargs) + (setq *initialize-info-cache-info* info) + info)) + +(defun update-initialize-info-internal (info name) + (let* ((key (initialize-info-key info)) + (class (car key)) + (keys (cadr key)) + (allow-other-keys-arg (caddr key))) + (ecase name + ((initargs-form-list new-keys) + (multiple-value-bind (initargs-form-list new-keys) + (make-default-initargs-form-list class keys) + (setf (initialize-info-cached-initargs-form-list info) initargs-form-list) + (setf (initialize-info-cached-new-keys info) new-keys))) + ((combined-initargs-form-list) + (multiple-value-bind (initargs-form-list new-keys) + (make-default-initargs-form-list class keys nil) + (setf (initialize-info-cached-combined-initargs-form-list info) + initargs-form-list) + (setf (initialize-info-cached-new-keys info) new-keys))) + ((default-initargs-function) + (let ((initargs-form-list (initialize-info-initargs-form-list info))) + (setf (initialize-info-cached-default-initargs-function info) + (initialize-instance-simple-function + 'default-initargs-function info + class initargs-form-list)))) + ((valid-p ri-valid-p) + (flet ((compute-valid-p (methods) + (or (not (null allow-other-keys-arg)) + (multiple-value-bind (legal allow-other-keys) + (check-initargs-values class methods) + (or (not (null allow-other-keys)) + (dolist (key keys t) + (unless (member key legal) + (return (cons :invalid key))))))))) + (let ((proto (class-prototype class))) + (setf (initialize-info-cached-valid-p info) + (compute-valid-p + (list (list* 'allocate-instance class nil) + (list* 'initialize-instance proto nil) + (list* 'shared-initialize proto t nil)))) + (setf (initialize-info-cached-ri-valid-p info) + (compute-valid-p + (list (list* 'reinitialize-instance proto nil) + (list* 'shared-initialize proto nil nil))))))) + ((shared-initialize-t-function) + (multiple-value-bind (initialize-form-list ignore) + (make-shared-initialize-form-list class keys t nil) + (declare (ignore ignore)) + (setf (initialize-info-cached-shared-initialize-t-function info) + (initialize-instance-simple-function + 'shared-initialize-t-function info + class initialize-form-list)))) + ((shared-initialize-nil-function) + (multiple-value-bind (initialize-form-list ignore) + (make-shared-initialize-form-list class keys nil nil) + (declare (ignore ignore)) + (setf (initialize-info-cached-shared-initialize-nil-function info) + (initialize-instance-simple-function + 'shared-initialize-nil-function info + class initialize-form-list)))) + ((constants combined-initialize-function) + (let ((initargs-form-list (initialize-info-combined-initargs-form-list info)) + (new-keys (initialize-info-new-keys info))) + (multiple-value-bind (initialize-form-list constants) + (make-shared-initialize-form-list class new-keys t t) + (setf (initialize-info-cached-constants info) constants) + (setf (initialize-info-cached-combined-initialize-function info) + (initialize-instance-simple-function + 'combined-initialize-function info + class (append initargs-form-list initialize-form-list)))))) + ((make-instance-function-symbol) + (setf (initialize-info-cached-make-instance-function-symbol info) + (make-instance-function-symbol key))) + ((make-instance-function) + (let* ((function (get-make-instance-function key)) + (symbol (initialize-info-make-instance-function-symbol info))) + (setf (initialize-info-cached-make-instance-function info) function) + (when symbol (setf (gdefinition symbol) + (or function #'make-instance-1))))))) + info) + +(defun get-make-instance-function (key) + (let* ((class (car key)) + (keys (cadr key))) + (unless (eq *boot-state* 'complete) + (return-from get-make-instance-function nil)) + (when (symbolp class) + (setq class (find-class class))) + (when (classp class) + (unless (class-finalized-p class) (finalize-inheritance class))) + (let* ((initargs (mapcan #'(lambda (key) (list key nil)) keys)) + (class-and-initargs (list* class initargs)) + (make-instance (gdefinition 'make-instance)) + (make-instance-methods + (compute-applicable-methods make-instance class-and-initargs)) + (std-mi-meth (find-standard-ii-method make-instance-methods 'class)) + (class+initargs (list class initargs)) + (default-initargs (gdefinition 'default-initargs)) + (default-initargs-methods + (compute-applicable-methods default-initargs class+initargs)) + (proto (and (classp class) (class-prototype class))) + (initialize-instance-methods + (when proto + (compute-applicable-methods (gdefinition 'initialize-instance) + (list* proto initargs)))) + (shared-initialize-methods + (when proto + (compute-applicable-methods (gdefinition 'shared-initialize) + (list* proto t initargs))))) + (when (null make-instance-methods) + (return-from get-make-instance-function + #'(lambda (class &rest initargs) + (apply #'no-applicable-method make-instance class initargs)))) + (unless (and (null (cdr make-instance-methods)) + (eq (car make-instance-methods) std-mi-meth) + (null (cdr default-initargs-methods)) + (eq (car (method-specializers (car default-initargs-methods))) + *the-class-slot-class*) + (flet ((check-meth (meth) + (let ((quals (method-qualifiers meth))) + (if (null quals) + (eq (car (method-specializers meth)) + *the-class-slot-object*) + (and (null (cdr quals)) + (or (eq (car quals) ':before) + (eq (car quals) ':after))))))) + (and (every #'check-meth initialize-instance-methods) + (every #'check-meth shared-initialize-methods)))) + (return-from get-make-instance-function nil)) + (get-make-instance-function-internal + class key (default-initargs class initargs) + initialize-instance-methods shared-initialize-methods)))) + +(defun get-make-instance-function-internal (class key initargs + initialize-instance-methods + shared-initialize-methods) + (let* (#|(class-key (car key))|# + (keys (cadr key)) + (allow-other-keys-p (caddr key)) + (allocate-instance-methods + (compute-applicable-methods (gdefinition 'allocate-instance) + (list* class initargs)))) + (unless allow-other-keys-p + (unless (check-initargs-1 + class initargs + (append allocate-instance-methods + initialize-instance-methods + shared-initialize-methods) + t nil) + (return-from get-make-instance-function-internal nil))) + (cond ((or (cdr allocate-instance-methods) + (some #'complicated-instance-creation-method + initialize-instance-methods) + (some #'complicated-instance-creation-method + shared-initialize-methods)) + (make-instance-function-complex + key class keys + initialize-instance-methods shared-initialize-methods)) + (t #|(or (not (standard-class-p class)) (not (symbolp class-key)) + initialize-instance-methods shared-initialize-methods)|# + (make-instance-function-simple + key class keys + initialize-instance-methods shared-initialize-methods)) + #|(t + (make-instance-function-basic + key class keys))|#))) + +(defun complicated-instance-creation-method (m) + (let ((qual (method-qualifiers m))) + (if qual + (not (and (null (cdr qual)) (eq (car qual) ':after))) + (let ((specl (car (method-specializers m)))) + (or (not (classp specl)) + (not (eq 'slot-object (class-name specl)))))))) + +(defun find-standard-ii-method (methods class-names) + (dolist (m methods) + (when (null (method-qualifiers m)) + (let ((specl (car (method-specializers m)))) + (when (and (classp specl) + (if (listp class-names) + (member (class-name specl) class-names) + (eq (class-name specl) class-names))) + (return m)))))) + +(defmacro call-initialize-function (initialize-function instance initargs) + `(let ((.function. ,initialize-function)) + (if (and (consp .function.) + (eq (car .function.) 'call-initialize-instance-simple)) + (initialize-instance-simple (cadr .function.) (caddr .function.) + ,instance ,initargs) + (funcall (the function .function.) ,instance ,initargs)))) + +(defmacro copy-slots (slots-init) + #-(or lucid cmu17) + `(copy-seq ,slots-init) + #+(or lucid cmu17) + `(let* ((init ,slots-init) + (len (length init)) + (v #+lucid (system:new-simple-vector len) + #+cmu17 (lisp::allocate-vector #.vm:simple-vector-type len len))) + (declare (simple-vector init v) + (type #-cmu fixnum #+cmu lisp::index len)) + (dotimes (i len v) + (declare (type #-cmu fixnum #+cmu lisp::index i)) + (setf (svref v i) (svref init i))))) + +(defmacro allocate-standard-instance--macro (wrapper slots-init) + #-new-kcl-wrapper + `(let ((instance (%%allocate-instance--class))) + (setf (std-instance-wrapper instance) ,wrapper) + (setf (std-instance-slots instance) (copy-slots ,slots-init)) + instance) + #+new-kcl-wrapper + `(allocate-standard-instance ,wrapper ,slots-init)) + +(defmacro with-make-instance-function-valid-p-check (initargs-form &body body) + `(let ((current-class (if class-cell + (find-class-from-cell class-key class-cell) + class-symbol))) + (if (or (not (eq current-class class-symbol)) + (invalid-wrapper-p wrapper)) + (make-instance-function-trap current-class ,initargs-form) + (progn ,@body)))) + +(defun make-instance-function-trap (class-symbol initargs) + (let* ((info (initialize-info class-symbol initargs)) + (fn (initialize-info-make-instance-function info))) + (declare (type function fn)) + (funcall fn class-symbol initargs))) + +(defun make-instance-function-simple (key class keys + initialize-instance-methods + shared-initialize-methods) + (let* ((class-key (car key)) + (class-cell (when (symbolp class-key) + (find-class-cell class-key nil))) + (wrapper (class-wrapper class)) + (lwrapper (list wrapper)) + (allocate-function + (cond ((structure-class-p class) + #'allocate-structure-instance) + ((standard-class-p class) + #'allocate-standard-instance) + ((funcallable-standard-class-p class) + #'allocate-funcallable-instance) + (t + (error "error in make-instance-function-simple")))) + (allocate-macro + (cond ((standard-class-p class) + 'allocate-standard-instance--macro))) + (std-si-meth (find-standard-ii-method shared-initialize-methods + 'slot-object)) + (shared-initfns + (nreverse (mapcar #'(lambda (method) + (make-effective-method-function + #'shared-initialize + `(call-method ,method nil) + nil lwrapper)) + (remove std-si-meth shared-initialize-methods)))) + (std-ii-meth (find-standard-ii-method initialize-instance-methods + 'slot-object)) + (initialize-initfns + (nreverse (mapcar #'(lambda (method) + (make-effective-method-function + #'initialize-instance + `(call-method ,method nil) + nil lwrapper)) + (remove std-ii-meth + initialize-instance-methods))))) + (multiple-value-bind (initialize-function constants) + (get-simple-initialization-function class keys (caddr key)) + (if (eq allocate-macro 'allocate-standard-instance--macro) + #'(lambda (class-symbol &rest initargs) + (with-make-instance-function-valid-p-check initargs + (let ((instance + (allocate-standard-instance--macro wrapper constants))) + (call-initialize-function initialize-function instance initargs) + (dolist (fn shared-initfns) + (invoke-effective-method-function fn t instance t initargs)) + (dolist (fn initialize-initfns) + (invoke-effective-method-function fn t instance initargs)) + instance))) + #'(lambda (class-symbol &rest initargs) + (with-make-instance-function-valid-p-check initargs + (let* ((instance (funcall allocate-function wrapper constants)) + (initargs (call-initialize-function initialize-function + instance initargs))) + (dolist (fn shared-initfns) + (invoke-effective-method-function fn t instance t initargs)) + (dolist (fn initialize-initfns) + (invoke-effective-method-function fn t instance initargs)) + instance))))))) + +(defun make-instance-function-complex (key class keys + initialize-instance-methods + shared-initialize-methods) + (multiple-value-bind (initargs-function initialize-function) + (get-complex-initialization-functions class keys (caddr key)) + (let* ((class-key (car key)) + (class-cell (when (symbolp class-key) + (find-class-cell class-key nil))) + (wrapper (class-wrapper class)) + (shared-initialize + (get-secondary-dispatch-function + #'shared-initialize shared-initialize-methods + `((class-eq ,class) t t) + `((,(find-standard-ii-method shared-initialize-methods 'slot-object) + ,#'(lambda (instance init-type &rest initargs) + (declare (ignore init-type)) + #+copy-&rest-arg (setq initargs (copy-list initargs)) + (call-initialize-function initialize-function + instance initargs) + instance))) + (list wrapper *the-wrapper-of-t* *the-wrapper-of-t*))) + (initialize-instance + (get-secondary-dispatch-function + #'initialize-instance initialize-instance-methods + `((class-eq ,class) t) + `((,(find-standard-ii-method initialize-instance-methods 'slot-object) + ,#'(lambda (instance &rest initargs) + #+copy-&rest-arg (setq initargs (copy-list initargs)) + (invoke-effective-method-function + shared-initialize t instance t initargs)))) + (list wrapper *the-wrapper-of-t*)))) + #'(lambda (class-symbol &rest initargs) + (with-make-instance-function-valid-p-check initargs + (let* ((initargs (call-initialize-function initargs-function + nil initargs)) + (instance (apply #'allocate-instance class initargs))) + (invoke-effective-method-function + initialize-instance t instance initargs) + instance)))))) + +#| +(defmacro call-initialize-function (initialize-function instance initargs) + `(let ((.function. ,initialize-function)) + (if (and (consp .function.) + (eq (car .function.) 'call-initialize-instance-simple)) + (initialize-instance-simple (cadr .function.) (caddr .function.) + ,instance ,initargs) + (funcall (the function .function.) ,instance ,initargs)))) + +(defun make-instance-function-basic (key class keys) + (let* ((class-key (car key)) + (class-cell (find-class-cell class-key nil)) + (wrapper (class-wrapper class))) + (multiple-value-bind (initialize-function constants) + (get-simple-initialization-function class keys (caddr key)) + #'(lambda (class-symbol &rest initargs) + (let ((current-class (find-class-from-cell class-key class-cell))) + (if (or (not (eq current-class class-symbol)) + (invalid-wrapper-p wrapper)) + (make-instance-function-trap current-class initargs-form) + (let ((instance + (allocate-standard-instance--macro wrapper constants))) + (call-initialize-function initialize-function instance initargs) + instance))))))) +|# + +(defun get-simple-initialization-function (class keys &optional allow-other-keys-arg) + (let ((info (initialize-info class keys nil allow-other-keys-arg))) + (values (initialize-info-combined-initialize-function info) + (initialize-info-constants info)))) + +(defun get-complex-initialization-functions (class keys &optional allow-other-keys-arg + separate-p) + (let* ((info (initialize-info class keys nil allow-other-keys-arg)) + (default-initargs-function (initialize-info-default-initargs-function info))) + (if separate-p + (values default-initargs-function + (initialize-info-shared-initialize-t-function info)) + (values default-initargs-function + (initialize-info-shared-initialize-t-function + (initialize-info class (initialize-info-new-keys info) + nil allow-other-keys-arg)))))) + +(defun add-forms (forms forms-list) + (when forms + (setq forms (copy-list forms)) + (if (null (car forms-list)) + (setf (car forms-list) forms) + (setf (cddr forms-list) forms)) + (setf (cdr forms-list) (last forms))) + (car forms-list)) + +(defun make-default-initargs-form-list (class keys &optional (separate-p t)) + (let ((initargs-form-list (cons nil nil)) + (default-initargs (class-default-initargs class)) + (nkeys keys) + (slots-alist + (mapcan #'(lambda (slot) + (mapcar #'(lambda (arg) + (cons arg slot)) + (slot-definition-initargs slot))) + (class-slots class))) + (nslots nil)) + (dolist (key nkeys) + (pushnew (cdr (assoc key slots-alist)) nslots)) + (dolist (default default-initargs) + (let* ((key (car default)) + (slot (cdr (assoc key slots-alist))) + (function (cadr default))) + (unless (member slot nslots) + (add-forms `((funcall ,function) (push-initarg ,key)) + initargs-form-list) + (push key nkeys) + (push slot nslots)))) + (when separate-p + (add-forms `((update-initialize-info-cache + ,class ,(initialize-info class nkeys nil))) + initargs-form-list)) + (add-forms `((finish-pushing-initargs)) + initargs-form-list) + (values (car initargs-form-list) nkeys))) + +(defun make-shared-initialize-form-list (class keys si-slot-names simple-p) + (let* ((initialize-form-list (cons nil nil)) + (type (cond ((structure-class-p class) + 'structure) + ((standard-class-p class) + 'standard) + ((funcallable-standard-class-p class) + 'funcallable) + (t (error "error in make-shared-initialize-form-list")))) + (wrapper (class-wrapper class)) + (constants (when simple-p + (make-array (wrapper-no-of-instance-slots wrapper) + ':initial-element *slot-unbound*))) + (slots (class-slots class)) + (slot-names (mapcar #'slot-definition-name slots)) + (slots-key (mapcar #'(lambda (slot) + (let ((index most-positive-fixnum)) + (dolist (key (slot-definition-initargs slot)) + (let ((pos (position key keys))) + (when pos (setq index (min index pos))))) + (cons slot index))) + slots)) + (slots (stable-sort slots-key #'< :key #'cdr))) + (let ((n-popped 0)) + (declare (fixnum n-popped)) + (dolist (slot+index slots) + (let* ((slot (car slot+index)) + (name (slot-definition-name slot)) + (npop (1+ (- (the fixnum (cdr slot+index)) n-popped)))) + (declare (fixnum npop)) + (unless (eql (cdr slot+index) most-positive-fixnum) + (let* ((pv-offset (1+ (position name slot-names)))) + (add-forms `(,@(when (plusp npop) + `((pop-initargs ,(the fixnum (* 2 npop))))) + (instance-set ,pv-offset ,slot)) + initialize-form-list)) + (incf n-popped npop))))) + (dolist (slot+index slots) + (let* ((slot (car slot+index)) + (name (slot-definition-name slot))) + (when (and (eql (cdr slot+index) most-positive-fixnum) + (or (eq si-slot-names 't) + (member name si-slot-names))) + (let* ((initform (slot-definition-initform slot)) + (initfunction (slot-definition-initfunction slot)) + (location (unless (eq type 'structure) + (slot-definition-location slot))) + (pv-offset (1+ (position name slot-names))) + (forms (cond ((null initfunction) + nil) + ((constantp initform) + (let ((value (funcall initfunction))) + (if (and simple-p (integerp location)) + (progn (setf (svref constants location) value) + nil) + `((const ,value) + (instance-set ,pv-offset ,slot))))) + (t + `((funcall ,(slot-definition-initfunction slot)) + (instance-set ,pv-offset ,slot)))))) + (add-forms `(,@(unless (or simple-p (null forms)) + `((skip-when-instance-boundp ,pv-offset ,slot + ,(length forms)))) + ,@forms) + initialize-form-list))))) + (values (car initialize-form-list) constants))) + +(defvar *class-pv-table-table* (make-hash-table :test 'eq)) + +(defun get-pv-cell-for-class (class) + (let* ((slot-names (mapcar #'slot-definition-name (class-slots class))) + (slot-name-lists (list (cons nil slot-names))) + (pv-table (gethash class *class-pv-table-table*))) + (unless (and pv-table + (equal slot-name-lists (pv-table-slot-name-lists pv-table))) + (setq pv-table (intern-pv-table :slot-name-lists slot-name-lists)) + (setf (gethash class *class-pv-table-table*) pv-table)) + (pv-table-lookup pv-table (class-wrapper class)))) + +(defvar *initialize-instance-simple-alist* nil) +(defvar *note-iis-entry-p* nil) + +(defvar *compiled-initialize-instance-simple-functions* + (make-hash-table :test #'equal)) + +(defun initialize-instance-simple-function (use info class form-list) + (let* ((pv-cell (get-pv-cell-for-class class)) + (key (initialize-info-key info)) + (sf-key (list* use (class-name (car key)) (cdr key)))) + (if (or *compile-make-instance-functions-p* + (gethash sf-key *compiled-initialize-instance-simple-functions*)) + (multiple-value-bind (form args) + (form-list-to-lisp pv-cell form-list) + (let ((entry (assoc form *initialize-instance-simple-alist* + :test #'equal))) + (setf (gethash sf-key + *compiled-initialize-instance-simple-functions*) + t) + (if entry + (setf (cdddr entry) (union (list sf-key) (cdddr entry) + :test #'equal)) + (progn + (setq entry (list* form nil nil (list sf-key))) + (setq *initialize-instance-simple-alist* + (nconc *initialize-instance-simple-alist* + (list entry))))) + (unless (or *note-iis-entry-p* (cadr entry)) + (setf (cadr entry) (compile-lambda (car entry)))) + (if (cadr entry) + (apply (the function (cadr entry)) args) + `(call-initialize-instance-simple ,pv-cell ,form-list)))) + #|| + #'(lambda (instance initargs) + (initialize-instance-simple pv-cell form-list instance initargs)) + ||# + `(call-initialize-instance-simple ,pv-cell ,form-list)))) + +(defun load-precompiled-iis-entry (form function system uses) + (let ((entry (assoc form *initialize-instance-simple-alist* + :test #'equal))) + (unless entry + (setq entry (list* form nil nil nil)) + (setq *initialize-instance-simple-alist* + (nconc *initialize-instance-simple-alist* + (list entry)))) + (setf (cadr entry) function) + (setf (caddr entry) system) + (dolist (use uses) + (setf (gethash use *compiled-initialize-instance-simple-functions*) t)) + (setf (cdddr entry) (union uses (cdddr entry) + :test #'equal)))) + +(defmacro precompile-iis-functions (&optional system) + (let ((index -1)) + `(progn + ,@(gathering1 (collecting) + (dolist (iis-entry *initialize-instance-simple-alist*) + (when (or (null (caddr iis-entry)) + (eq (caddr iis-entry) system)) + (when system (setf (caddr iis-entry) system)) + (gather1 + (make-top-level-form + `(precompile-initialize-instance-simple ,system ,(incf index)) + '(load) + `(load-precompiled-iis-entry + ',(car iis-entry) + #',(car iis-entry) + ',system + ',(cdddr iis-entry)))))))))) + +(defun compile-iis-functions (after-p) + (let ((*compile-make-instance-functions-p* t) + (*revert-initialize-info-p* t) + (*note-iis-entry-p* (not after-p))) + (declare (special *compile-make-instance-functions-p*)) + (when (eq *boot-state* 'complete) + (update-make-instance-function-table)))) + + +;(const const) +;(funcall function) +;(push-initarg const) +;(pop-supplied count) ; a positive odd number +;(instance-set pv-offset slotd) +;(skip-when-instance-boundp pv-offset slotd n) + +(defun initialize-instance-simple (pv-cell form-list instance initargs) + (let ((pv (car pv-cell)) + (initargs-tail initargs) + (slots (get-slots-or-nil instance)) + (class (class-of instance)) + value) + (loop (when (null form-list) (return nil)) + (let ((form (pop form-list))) + (ecase (car form) + (push-initarg + (push value initargs) + (push (cadr form) initargs)) + (const + (setq value (cadr form))) + (funcall + (setq value (funcall (the function (cadr form))))) + (pop-initargs + (setq initargs-tail (nthcdr (1- (cadr form)) initargs-tail)) + (setq value (pop initargs-tail))) + (instance-set + (instance-write-internal + pv slots (cadr form) value + (setf (slot-value-using-class class instance (caddr form)) value))) + (skip-when-instance-boundp + (when (instance-boundp-internal + pv slots (cadr form) + (slot-boundp-using-class class instance (caddr form))) + (dotimes (i (cadddr form)) + (pop form-list)))) + (update-initialize-info-cache + (when (consp initargs) + (setq initargs (cons (car initargs) (cdr initargs)))) + (setq *initialize-info-cache-class* (cadr form)) + (setq *initialize-info-cache-initargs* initargs) + (setq *initialize-info-cache-info* (caddr form))) + (finish-pushing-initargs + (setq initargs-tail initargs))))) + initargs)) + +(defun add-to-cvector (cvector constant) + (or (position constant cvector) + (prog1 (fill-pointer cvector) + (vector-push-extend constant cvector)))) + +(defvar *inline-iis-instance-locations-p* t) + +(defun first-form-to-lisp (forms cvector pv) + (flet ((const (constant) + (cond ((or (numberp constant) (characterp constant)) + constant) + ((and (symbolp constant) (symbol-package constant)) + `',constant) + (t + `(svref cvector ,(add-to-cvector cvector constant)))))) + (let ((form (pop (car forms)))) + (ecase (car form) + (push-initarg + `((push value initargs) + (push ,(const (cadr form)) initargs))) + (const + `((setq value ,(const (cadr form))))) + (funcall + `((setq value (funcall (the function ,(const (cadr form))))))) + (pop-initargs + `((setq initargs-tail (,@(let ((pop (1- (cadr form)))) + (case pop + (1 `(cdr)) + (3 `(cdddr)) + (t `(nthcdr ,pop)))) + initargs-tail)) + (setq value (pop initargs-tail)))) + (instance-set + (let* ((pv-offset (cadr form)) + (location (pvref pv pv-offset)) + (default `(setf (slot-value-using-class class instance + ,(const (caddr form))) + value))) + (if *inline-iis-instance-locations-p* + (typecase location + (fixnum `((setf (%instance-ref slots ,(const location)) value))) + (cons `((setf (cdr ,(const location)) value))) + (t `(,default))) + `((instance-write-internal pv slots ,(const pv-offset) value + ,default + ,(typecase location + (fixnum ':instance) + (cons ':class) + (t ':default))))))) + (skip-when-instance-boundp + (let* ((pv-offset (cadr form)) + (location (pvref pv pv-offset)) + (default `(slot-boundp-using-class class instance + ,(const (caddr form))))) + `((unless ,(if *inline-iis-instance-locations-p* + (typecase location + (fixnum `(not (eq (%instance-ref slots ,(const location)) + ',*slot-unbound*))) + (cons `(not (eq (cdr ,(const location)) ',*slot-unbound*))) + (t default)) + `(instance-boundp-internal pv slots ,(const pv-offset) + ,default + ,(typecase (pvref pv pv-offset) + (fixnum ':instance) + (cons ':class) + (t ':default)))) + ,@(let ((sforms (cons nil nil))) + (dotimes (i (cadddr form) (car sforms)) + (add-forms (first-form-to-lisp forms cvector pv) sforms))))))) + (update-initialize-info-cache + `((when (consp initargs) + (setq initargs (cons (car initargs) (cdr initargs)))) + (setq *initialize-info-cache-class* ,(const (cadr form))) + (setq *initialize-info-cache-initargs* initargs) + (setq *initialize-info-cache-info* ,(const (caddr form))))) + (finish-pushing-initargs + `((setq initargs-tail initargs))))))) + +(defmacro iis-body (&body forms) + (let ((vars '(initargs-tail pv slots wrapper class value))) + `(let ((initargs-tail initargs) + (pv (car pv-cell)) + (slots nil) + (wrapper #+cmu17 (kernel:layout-of instance) #-cmu17 nil) + class + value) + ,@(progn + #-cmu vars + #+cmu `((declare (ignorable ,@vars)))) + #+cmu17 + (cond ((not (typep wrapper 'wrapper))) + ((std-instance-p instance) + (setq slots (std-instance-slots instance))) + (t + (setq slots (fsc-instance-slots instance)))) + #-cmu17 + (cond ((std-instance-p instance) + (setq slots (std-instance-slots instance)) + (setq wrapper (std-instance-wrapper instance))) + ((fsc-instance-p instance) + (setq slots (fsc-instance-slots instance)) + (setq wrapper (fsc-instance-wrapper instance))) + (t + (setq wrapper (wrapper-of instance)))) + (setq class (wrapper-class wrapper)) + ,@forms))) + +(defun form-list-to-lisp (pv-cell form-list) + (let* ((forms (list form-list)) + (cvector (make-array (floor (length form-list) 2) + :fill-pointer 0 :adjustable t)) + (pv (car pv-cell)) + (body (let ((rforms (cons nil nil))) + (loop (when (null (car forms)) (return (car rforms))) + (add-forms (first-form-to-lisp forms cvector pv) + rforms)))) + (cvector-type `(simple-vector ,(length cvector)))) + (values + `(lambda (pv-cell cvector) + (declare (type ,cvector-type cvector)) + #+cmu + (declare (ignorable pv-cell cvector)) + #'(lambda (instance initargs) + (declare #.*optimize-speed*) + #+cmu + (declare (ignorable instance initargs)) + (iis-body ,@body) + initargs)) + (list pv-cell (coerce cvector cvector-type))))) + + +;The effect of this is to cause almost all of the overhead of make-instance +;to happen at load time (or maybe at precompile time, as explained in a +;previous message) rather than the first time make-instance is called with +;a given class-name and sequence of keywords. + +;This optimization applys only when the first argument and all the even +;numbered arguments are constants evaluating to interned symbols. + +#+cmu +(declaim (ftype (function (t) symbol) get-make-instance-function-symbol)) + +; Use this definition in any CL implementation supporting +; both define-compiler-macro and load-time-value. +#+cmu +(define-compiler-macro make-instance (&whole form &rest args) + (declare (ignore args)) + (let* ((*make-instance-function-keys* nil) + (expanded-form (expand-make-instance-form form))) + (if expanded-form + `(funcall (the function + (symbol-function + ;; The symbol is guaranteed to be fbound. + ;; Is there a way to declare this? + (load-time-value + (get-make-instance-function-symbol + ',(first *make-instance-function-keys*))))) + ,@(cdr expanded-form)) + form))) + +(defun get-make-instance-function-symbol (key) + (get-make-instance-functions (list key)) + (make-instance-function-symbol key)) diff --git a/pcl/gcl_pcl_fin.lisp b/pcl/gcl_pcl_fin.lisp new file mode 100644 index 0000000..22f2d7d --- /dev/null +++ b/pcl/gcl_pcl_fin.lisp @@ -0,0 +1,1868 @@ +;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; + + ;; +;;;;;; FUNCALLABLE INSTANCES + ;; + +#| + +Generic functions are instances with meta class funcallable-standard-class. +Instances with this meta class are called funcallable-instances (FINs for +short). They behave something like lexical closures in that they have data +associated with them (which is used to store the slots) and are funcallable. +When a funcallable instance is funcalled, the function that is invoked is +called the funcallable-instance-function. The funcallable-instance-function +of a funcallable instance can be changed. + +This file implements low level code for manipulating funcallable instances. + +It is possible to implement funcallable instances in pure Common Lisp. A +simple implementation which uses lexical closures as the instances and a +hash table to record that the lexical closures are funcallable instances +is easy to write. Unfortunately, this implementation adds significant +overhead: + + to generic-function-invocation (1 function call) + to slot-access (1 function call or one hash table lookup) + to class-of a generic-function (1 hash-table lookup) + +In addition, it would prevent the funcallable instances from being garbage +collected. In short, the pure Common Lisp implementation really isn't +practical. + +Instead, PCL uses a specially tailored implementation for each Common Lisp and +makes no attempt to provide a purely portable implementation. The specially +tailored implementations are based on the lexical closure's provided by that +implementation and are fairly short and easy to write. + +Some of the implementation dependent code in this file was originally written +by someone in the employ of the vendor of that Common Lisp. That code is +explicitly marked saying who wrote it. + +|# + +(in-package :pcl) + +;;; +;;; The first part of the file contains the implementation dependent code to +;;; implement funcallable instances. Each implementation must provide the +;;; following functions and macros: +;;; +;;; ALLOCATE-FUNCALLABLE-INSTANCE-1 () +;;; should create and return a new funcallable instance. The +;;; funcallable-instance-data slots must be initialized to NIL. +;;; This is called by allocate-funcallable-instance and by the +;;; bootstrapping code. +;;; +;;; FUNCALLABLE-INSTANCE-P (x) +;;; the obvious predicate. This should be an INLINE function. +;;; it must be funcallable, but it would be nice if it compiled +;;; open. +;;; +;;; SET-FUNCALLABLE-INSTANCE-FUNCTION (fin new-value) +;;; change the fin so that when it is funcalled, the new-value +;;; function is called. Note that it is legal for new-value +;;; to be copied before it is installed in the fin, specifically +;;; there is no accessor for a FIN's function so this function +;;; does not have to preserve the actual new value. The new-value +;;; argument can be any funcallable thing, a closure, lambda +;;; compiled code etc. This function must coerce those values +;;; if necessary. +;;; NOTE: new-value is almost always a compiled closure. This +;;; is the important case to optimize. +;;; +;;; FUNCALLABLE-INSTANCE-DATA-1 (fin data-name) +;;; should return the value of the data named data-name in the fin. +;;; data-name is one of the symbols in the list which is the value +;;; of funcallable-instance-data. Since data-name is almost always +;;; a quoted symbol and funcallable-instance-data is a constant, it +;;; is possible (and worthwhile) to optimize the computation of +;;; data-name's offset in the data part of the fin. +;;; This must be SETF'able. +;;; + +(eval-when (compile load eval) +(defconstant funcallable-instance-data + '(wrapper slots) + "These are the 'data-slots' which funcallable instances have so that + the meta-class funcallable-standard-class can store class, and static + slots in them.") +) + +(defmacro funcallable-instance-data-position (data) + (if (and (consp data) + (eq (car data) 'quote)) + (or (position (cadr data) funcallable-instance-data :test #'eq) + (progn + (warn "Unknown funcallable-instance data: ~S." (cadr data)) + `(error "Unknown funcallable-instance data: ~S." ',(cadr data)))) + `(position ,data funcallable-instance-data :test #'eq))) + +(proclaim '(notinline called-fin-without-function)) +(defun called-fin-without-function (&rest args) + (declare (ignore args)) + (error "Attempt to funcall a funcallable-instance without first~%~ + setting its funcallable-instance-function.")) + + +;;; +;;; In Lucid Lisp, compiled functions and compiled closures have the same +;;; representation. They are called procedures. A procedure is a basically +;;; just a constants vector, with one slot which points to the CODE. This +;;; means that constants and closure variables are intermixed in the procedure +;;; vector. +;;; +;;; This code was largely written by JonL@Lucid.com. Problems with it should +;;; be referred to him. +;;; +#+Lucid +(progn + +(defconstant procedure-is-funcallable-instance-bit-position 10) + +(defconstant fin-trampoline-fun-index lucid::procedure-literals) + +(defconstant fin-size (+ fin-trampoline-fun-index + (length funcallable-instance-data) + 1)) + +;;; +;;; The inner closure of this function will have its code vector replaced +;;; by a hand-coded fast jump to the function that is stored in the +;;; captured-lexical variable. In effect, that code is a hand- +;;; optimized version of the code for this inner closure function. +;;; +(defun make-trampoline (function) + (declare (optimize (speed 3) (safety 0))) + #'(lambda (&rest args) + (apply function args))) + +(eval-when (eval) + (compile 'make-trampoline) + ) + + +(defun binary-assemble (codes) + (let* ((ncodes (length codes)) + (code-vec #-LCL3.0 (lucid::new-code ncodes) + #+LCL3.0 (lucid::with-current-area + lucid::*READONLY-NON-POINTER-AREA* + (lucid::new-code ncodes)))) + (declare (fixnum ncodes)) + (do ((l codes (cdr l)) + (i 0 (1+ i))) + ((null l) nil) + (declare (fixnum i)) + (setf (lucid::code-ref code-vec i) (car l))) + code-vec)) + +;;; +;;; Egad! Binary patching! +;;; See comment following definition of MAKE-TRAMPOLINE -- this is just +;;; the "hand-optimized" machine instructions to make it work. +;;; +(defvar *mattress-pad-code* + (binary-assemble + #+MC68000 + '(#x2A6D #x11 #x246D #x1 #x4EEA #x5) + #+SPARC + (ecase (lucid::procedure-length #'lucid::false) + (5 + '(#xFA07 #x6012 #xDE07 #x7FFE #x81C3 #xFFFE #x100 #x0)) + (8 + `(#xFA07 #x601E #xDE07 #x7FFE #x81C3 #xFFFE #x100 #x0))) + #+(and BSP (not LCL3.0 )) + '(#xCD33 #x11 #xCDA3 #x1 #xC19A #x5 #xE889) + #+(and BSP LCL3.0) + '(#x7733 #x7153 #xC155 #x5 #xE885) + #+I386 + '(#x87 #xD2 #x8B #x76 #xE #xFF #x66 #xFE) + #+VAX + '(#xD0 #xAC #x11 #x5C #xD0 #xAC #x1 #x57 #x17 #xA7 #x5) + #+PA + '(#x4891 #x3C #xE461 #x6530 #x48BF #x3FF9) + #+MIPS + '(#x8FD4 #x1E #x2785 #x2EEF #xA0 #x8 #x14 #xF000) + #-(or MC68000 SPARC BSP I386 VAX PA MIPS) + '(0 0 0 0))) + + +(lucid::defsubst funcallable-instance-p (x) + (and (lucid::procedurep x) + (lucid::logbitp& procedure-is-funcallable-instance-bit-position + (lucid::procedure-ref x lucid::procedure-flags)))) + +(lucid::defsubst set-funcallable-instance-p (x) + (if (not (lucid::procedurep x)) + (error "Can't make a non-procedure a fin.") + (setf (lucid::procedure-ref x lucid::procedure-flags) + (logior (expt 2 procedure-is-funcallable-instance-bit-position) + (the fixnum + (lucid::procedure-ref x lucid::procedure-flags)))))) + + +(defun allocate-funcallable-instance-1 () + #+Prime + (declare (notinline lucid::new-procedure)) ;fixes a bug in Prime 1.0 in + ;which new-procedure expands + ;incorrectly + (let ((new-fin (lucid::new-procedure fin-size)) + (fin-index fin-size)) + (declare (fixnum fin-index) + (type lucid::procedure new-fin)) + (dotimes (i (length funcallable-instance-data)) + ;; Initialize the new funcallable-instance. As part of our contract, + ;; we have to make sure the initial value of all the funcallable + ;; instance data slots is NIL. + (decf fin-index) + (setf (lucid::procedure-ref new-fin fin-index) nil)) + ;; + ;; "Assemble" the initial function by installing a fast "trampoline" code; + ;; + (setf (lucid::procedure-ref new-fin lucid::procedure-code) + *mattress-pad-code*) + ;; Disable argcount checking in the "mattress-pad" code for + ;; ports that go through standardized trampolines + #+PA (setf (sys:procedure-ref new-fin lucid::procedure-arg-count) -1) + #+MIPS (progn + (setf (sys:procedure-ref new-fin lucid::procedure-min-args) 0) + (setf (sys:procedure-ref new-fin lucid::procedure-max-args) + call-arguments-limit)) + ;; but start out with the function to be run as an error call. + (setf (lucid::procedure-ref new-fin fin-trampoline-fun-index) + #'called-fin-without-function) + ;; Then mark it as a "fin" + (set-funcallable-instance-p new-fin) + new-fin)) + +(defun set-funcallable-instance-function (fin new-value) + (unless (funcallable-instance-p fin) + (error "~S is not a funcallable-instance" fin)) + (if (lucid::procedurep new-value) + (progn + (setf (lucid::procedure-ref fin fin-trampoline-fun-index) new-value) + fin) + (progn + (unless (functionp new-value) + (error "~S is not a function." new-value)) + ;; 'new-value' is an interpreted function. Install a + ;; trampoline to call the interpreted function. + (set-funcallable-instance-function fin + (make-trampoline new-value))))) + +(defmacro funcallable-instance-data-1 (instance data) + `(lucid::procedure-ref + ,instance + (the fixnum + (- (- fin-size 1) + (the fixnum (funcallable-instance-data-position ,data)))))) + +);end of #+Lucid + + +;;; +;;; In Symbolics Common Lisp, a lexical closure is a pair of an environment +;;; and an ordinary compiled function. The environment is represented as +;;; a CDR-coded list. I know of no way to add a special bit to say that the +;;; closure is a FIN, so for now, closures are marked as FINS by storing a +;;; special marker in the last cell of the environment. +;;; +;;; The new structure of a fin is: +;;; (lex-env lex-fun *marker* fin-data0 fin-data1) +;;; The value returned by allocate is a lexical-closure pointing to the start +;;; of the fin list. Benefits are: no longer ever have to copy environments, +;;; fins can be much smaller (5 words instead of 18), old environments never +;;; get destroyed (so running dcodes dont have the lex env change from under +;;; them any longer). +;;; +;;; Most of the fin operations speed up a little (by as much as 30% on a +;;; 3650), at least one nasty bug is fixed, and so far at least I've not +;;; seen any problems at all with this code. - mike thome (mthome@bbn.com) +;;; +#+(and Genera (not Genera-Release-8)) +(progn + +(defvar *funcallable-instance-marker* (list "Funcallable Instance Marker")) + +(defun allocate-funcallable-instance-1 () + (let* ((whole-fin (make-list (+ 3 (length funcallable-instance-data)))) + (new-fin (sys:%make-pointer-offset sys:dtp-lexical-closure + whole-fin + 0))) + ;; + ;; note that we DO NOT turn the real lex-closure part of the fin into + ;; a dotted pair, because (1) the machine doesn't care and (2) if we + ;; did the garbage collector would reclaim everything after the lexical + ;; function. + ;; + (setf (sys:%p-contents-offset new-fin 2) *funcallable-instance-marker*) + (setf (si:lexical-closure-function new-fin) + #'(lambda (ignore &rest ignore-them-too) + (declare (ignore ignore ignore-them-too)) + (called-fin-without-function))) + #+ignore + (setf (si:lexical-closure-environment new-fin) nil) + new-fin)) + +(scl:defsubst funcallable-instance-p (x) + (declare (inline si:lexical-closure-p)) + (and (si:lexical-closure-p x) + (= (sys:%p-cdr-code (sys:%make-pointer-offset sys:dtp-compiled-function x 1)) + sys:cdr-next) + (eq (sys:%p-contents-offset x 2) *funcallable-instance-marker*))) + +(defun set-funcallable-instance-function (fin new-value) + (cond ((not (funcallable-instance-p fin)) + (error "~S is not a funcallable-instance" fin)) + ((not (or (functionp new-value) + (and (consp new-value) + (eq (car new-value) 'si:digested-lambda)))) + (error "~S is not a function." new-value)) + ((and (si:lexical-closure-p new-value) + (compiled-function-p (si:lexical-closure-function new-value))) + (let ((env (si:lexical-closure-environment new-value)) + (fn (si:lexical-closure-function new-value))) + ;; we only have to copy the pointers!! + (setf (si:lexical-closure-environment fin) env + (si:lexical-closure-function fin) fn) +; (dbg:set-env->fin env fin) + )) + (t + (set-funcallable-instance-function fin + (make-trampoline new-value))))) + +(defun make-trampoline (function) + (declare (optimize (speed 3) (safety 0))) + #'(lambda (&rest args) + #+Genera (declare (dbg:invisible-frame :pcl-internals)) + (apply function args))) + +(defmacro funcallable-instance-data-1 (fin data) + `(sys:%p-contents-offset ,fin + (+ 3 (funcallable-instance-data-position ,data)))) + +(defsetf funcallable-instance-data-1 (fin data) (new-value) + `(setf (sys:%p-contents-offset ,fin + (+ 3 (funcallable-instance-data-position ,data))) + ,new-value)) + +;;; +;;; Make funcallable instances print out properly. +;;; +(defvar *print-lexical-closure* nil) + +(defun pcl-print-lexical-closure (exp stream slashify-p &optional (depth 0)) + (declare (ignore depth)) + (declare (special *boot-state*)) + (if (or (eq *print-lexical-closure* exp) + (neq *boot-state* 'complete) + (eq (class-of exp) *the-class-t*)) + (let ((*print-lexical-closure* nil)) + (funcall (original-definition 'si:print-lexical-closure) + exp stream slashify-p)) + (let ((*print-escape* slashify-p) + (*print-lexical-closure* exp)) + (print-object exp stream)))) + +(unless (boundp '*boot-state*) + (setq *boot-state* nil)) + +(redefine-function 'si:print-lexical-closure 'pcl-print-lexical-closure) + +(defvar *function-name-level* 0) + +(defun pcl-function-name (function &rest other-args) + (if (and (eq *boot-state* 'complete) + (funcallable-instance-p function) + (generic-function-p function) + (<= *function-name-level* 2)) + (let ((*function-name-level* (1+ *function-name-level*))) + (generic-function-name function)) + (apply (original-definition 'si:function-name) function other-args))) + +(redefine-function 'si:function-name 'pcl-function-name) + +(defun pcl-arglist (function &rest other-args) + (let ((defn nil)) + (cond ((and (funcallable-instance-p function) + (generic-function-p function)) + (generic-function-pretty-arglist function)) + ((and (sys:validate-function-spec function) + (sys:fdefinedp function) + (setq defn (sys:fdefinition function)) + (funcallable-instance-p defn) + (generic-function-p defn)) + (generic-function-pretty-arglist defn)) + (t (apply (original-definition 'zl:arglist) function other-args))))) + +(redefine-function 'zl:arglist 'pcl-arglist) + + +;;; +;;; This code is adapted from frame-lexical-environment and frame-function. +;;; +#|| +dbg: +(progn + +(defvar *old-frame-function*) + +(defvar *inside-new-frame-function* nil) + +(defun new-frame-function (frame) + (let* ((fn (funcall *old-frame-function* frame)) + (location (%pointer-plus frame #+imach (defstorage-size stack-frame) #-imach 0)) + (env? #+3600 (location-contents location) + #+imach (%memory-read location :cycle-type %memory-scavenge))) + (or (when (cl:consp env?) + (let ((l2 (last2 env?))) + (when (eq (car l2) '.this-is-a-dfun.) + (cadr l2)))) + fn))) + +(defun pcl::doctor-dfun-for-the-debugger (gf dfun) + (when (sys:lexical-closure-p dfun) + (let* ((env (si:lexical-closure-environment dfun)) + (l2 (last2 env))) + (unless (eq (car l2) '.this-is-a-dfun.) + (setf (si:lexical-closure-environment dfun) + (nconc env (list '.this-is-a-dfun. gf)))))) + dfun) + +(defun last2 (l) + (labels ((scan (2ago tail) + (if (null tail) + 2ago + (if (cl:consp tail) + (scan (cdr 2ago) (cdr tail)) + nil)))) + (and (cl:consp l) + (cl:consp (cdr l)) + (scan l (cddr l))))) + +(eval-when (load) + (unless (boundp '*old-frame-function*) + (setq *old-frame-function* #'frame-function) + (setf (cl:symbol-function 'frame-function) 'new-frame-function))) + +) +||# + +);end of #+Genera + + + +;;; +;;; In Genera 8.0, we use a real funcallable instance (from Genera CLOS) for this. +;;; This minimizes the subprimitive mucking around. +;;; +#+(and Genera Genera-Release-8) +(progn + +(clos-internals::ensure-class + 'pcl-funcallable-instance + :direct-superclasses '(clos-internals:funcallable-instance) + :slots `((:name function + :initform #'(lambda (ignore &rest ignore-them-too) + (declare (ignore ignore ignore-them-too)) + (called-fin-without-function)) + :initfunction ,#'(lambda nil + #'(lambda (ignore &rest ignore-them-too) + (declare (ignore ignore ignore-them-too)) + (called-fin-without-function)))) + ,@(mapcar #'(lambda (slot) `(:name ,slot)) funcallable-instance-data)) + :metaclass 'clos:funcallable-standard-class) + +(defun pcl-funcallable-instance-trampoline (extra-arg &rest args) + (apply (sys:%instance-ref (clos-internals::%dispatch-instance-from-extra-argument extra-arg) + 3) + args)) + +(defun allocate-funcallable-instance-1 () + (let ((fin (clos:make-instance 'pcl-funcallable-instance))) + (setf (clos-internals::%funcallable-instance-function fin) + #'pcl-funcallable-instance-trampoline) + (setf (clos-internals::%funcallable-instance-extra-argument fin) + (sys:%make-pointer sys:dtp-instance + (clos-internals::%funcallable-instance-extra-argument fin))) + (setf (clos:slot-value fin 'clos-internals::funcallable-instance) fin) + fin)) + +(scl:defsubst funcallable-instance-p (x) + (and (sys:funcallable-instance-p x) + (eq (clos-internals::%funcallable-instance-function x) + #'pcl-funcallable-instance-trampoline))) + +(defun set-funcallable-instance-function (fin new-value) + (setf (clos:slot-value fin 'function) new-value)) + +(defmacro funcallable-instance-data-1 (fin data) + `(clos-internals:%funcallable-instance-ref + ,fin (+ 4 (funcallable-instance-data-position ,data)))) + +(defsetf funcallable-instance-data-1 (fin data) (new-value) + `(setf (clos-internals:%funcallable-instance-ref + ,fin (+ 4 (funcallable-instance-data-position ,data))) + ,new-value)) + +(clos:defmethod clos:print-object ((fin pcl-funcallable-instance) stream) + (print-object fin stream)) + +(clos:defmethod clos-internals:debugging-information-function ((fin pcl-funcallable-instance)) + nil) + +(clos:defmethod clos-internals:function-name-object ((fin pcl-funcallable-instance)) + (declare (special *boot-state*)) + (if (and (eq *boot-state* 'complete) + (generic-function-p fin)) + (generic-function-name fin) + fin)) + +(clos:defmethod clos-internals:arglist-object ((fin pcl-funcallable-instance)) + (declare (special *boot-state*)) + (if (and (eq *boot-state* 'complete) + (generic-function-p fin)) + (generic-function-pretty-arglist fin) + '(&rest args))) + +);end of #+Genera + + + +#+Cloe-Runtime +(progn + +(defconstant funcallable-instance-closure-slots 5) +(defconstant funcallable-instance-closure-size + (+ funcallable-instance-closure-slots (length funcallable-instance-data) 1)) + +#-CLOE-Release-2 (progn + +(defun allocate-funcallable-instance-1 () + (let ((data (system::make-funcallable-structure 'funcallable-instance + funcallable-instance-closure-size))) + (setf (system::%trampoline-ref data funcallable-instance-closure-slots) + 'funcallable-instance) + (set-funcallable-instance-function + data + #'(lambda (&rest ignore-them-too) + (declare (ignore ignore-them-too)) + (called-fin-without-function))) + data)) + +(proclaim '(inline funcallable-instance-p)) +(defun funcallable-instance-p (x) + (and (typep x 'system::trampoline) + (= (system::%trampoline-data-length x) funcallable-instance-closure-size) + (eq (system::%trampoline-ref x funcallable-instance-closure-slots) + 'funcallable-instance))) + +(defun set-funcallable-instance-function (fin new-value) + (when (not (funcallable-instance-p fin)) + (error "~S is not a funcallable-instance" fin)) + (etypecase new-value + (system::trampoline + (let ((length (system::%trampoline-data-length new-value))) + (cond ((> length funcallable-instance-closure-slots) + (set-funcallable-instance-function + fin + #'(lambda (&rest args) + (declare (sys:downward-rest-argument)) + (apply new-value args)))) + (t + (setf (system::%trampoline-function fin) + (system::%trampoline-function new-value)) + (dotimes (i length) + (setf (system::%trampoline-ref fin i) + (system::%trampoline-ref new-value i))))))) + (compiled-function + (setf (system::%trampoline-function fin) new-value)) + (function + (set-funcallable-instance-function + fin + #'(lambda (&rest args) + (declare (sys:downward-rest-argument)) + (apply new-value args)))))) + +(defmacro funcallable-instance-data-1 (fin data) + `(system::%trampoline-ref ,fin (+ funcallable-instance-closure-slots + 1 (funcallable-instance-data-position ,data)))) + +(defsetf funcallable-instance-data-1 (fin data) (new-value) + `(setf (system::%trampoline-ref ,fin (+ funcallable-instance-closure-slots + 1 (funcallable-instance-data-position ,data))) + ,new-value)) + +) + +#+CLOE-Release-2 (progn + +(defun allocate-funcallable-instance-1 () + (let ((data (si::cons-closure funcallable-instance-closure-size))) + (setf (si::closure-ref data funcallable-instance-closure-slots) 'funcallable-instance) + (set-funcallable-instance-function + data + #'(lambda (&rest ignore-them-too) + (declare (ignore ignore-them-too)) + (error "Called a FIN without first setting its function."))) + data)) + +(proclaim '(inline funcallable-instance-p)) +(defun funcallable-instance-p (x) + (and (si::closurep x) + (= (si::closure-length x) funcallable-instance-closure-size) + (eq (si::closure-ref x funcallable-instance-closure-slots) 'funcallable-instance))) + +(defun set-funcallable-instance-function (fin new-value) + (when (not (funcallable-instance-p fin)) + (error "~S is not a funcallable-instance" fin)) + (etypecase new-value + (si::closure + (let ((length (si::closure-length new-value))) + (cond ((> length funcallable-instance-closure-slots) + (set-funcallable-instance-function + fin + #'(lambda (&rest args) + (declare (sys:downward-rest-argument)) + (apply new-value args)))) + (t + (setf (si::closure-function fin) (si::closure-function new-value)) + (dotimes (i length) + (si::object-set fin (+ i 3) (si::object-ref new-value (+ i 3)))))))) + (compiled-function + (setf (si::closure-function fin) new-value)) + (function + (set-funcallable-instance-function + fin + #'(lambda (&rest args) + (declare (sys:downward-rest-argument)) + (apply new-value args)))))) + +(defmacro funcallable-instance-data-1 (fin data) + `(si::closure-ref ,fin (+ funcallable-instance-closure-slots + 1 (funcallable-instance-data-position ,data)))) + +(defsetf funcallable-instance-data-1 (fin data) (new-value) + `(setf (si::closure-ref ,fin (+ funcallable-instance-closure-slots + 1 (funcallable-instance-data-position ,data))) + ,new-value)) + +) + +) + + +;;; +;;; +;;; In Xerox Common Lisp, a lexical closure is a pair of an environment and +;;; CCODEP. The environment is represented as a block. There is space in +;;; the top 8 bits of the pointers to the CCODE and the environment to use +;;; to mark the closure as being a FIN. +;;; +;;; To help the debugger figure out when it has found a FIN on the stack, we +;;; reserve the last element of the closure environment to use to point back +;;; to the actual fin. +;;; +;;; Note that there is code in xerox-low which lets us access the fields of +;;; compiled-closures and which defines the closure-overlay record. That +;;; code is there because there are some clients of it in that file. +;;; +#+Xerox +(progn + +;; Don't be fooled. We actually allocate one bigger than this to have a place +;; to store the backpointer to the fin. -smL +(defconstant funcallable-instance-closure-size 15) + +;; This is only used in the file PCL-ENV. +(defvar *fin-env-type* + (type-of (il:\\allocblock (1+ funcallable-instance-closure-size) t))) + +;; Well, Gregor may be too proud to hack xpointers, but bvm and I aren't. -smL + +(defstruct fin-env-pointer + (pointer nil :type il:fullxpointer)) + +(defun fin-env-fin (fin-env) + (fin-env-pointer-pointer + (il:\\getbaseptr fin-env (* funcallable-instance-closure-size 2)))) + +(defun |set fin-env-fin| (fin-env new-value) + (il:\\rplptr fin-env (* funcallable-instance-closure-size 2) + (make-fin-env-pointer :pointer new-value)) + new-value) + +(defsetf fin-env-fin |set fin-env-fin|) + +;; The finalization function that will clean up the backpointer from the +;; fin-env to the fin. This needs to be careful to not cons at all. This +;; depends on there being no other finalization function on compiled-closures, +;; since there is only one finalization function per datatype. Too bad. -smL +(defun finalize-fin (fin) + ;; This could use the fn funcallable-instance-p, but if we get here we know + ;; that this is a closure, so we can skip that test. + (when (il:fetch (closure-overlay funcallable-instance-p) il:of fin) + (let ((env (il:fetch (il:compiled-closure il:environment) il:of fin))) + (when env + (setq env + (il:\\getbaseptr env (* funcallable-instance-closure-size 2))) + (when (il:typep env 'fin-env-pointer) + (setf (fin-env-pointer-pointer env) nil))))) + nil) ;Return NIL so GC can proceed + +(eval-when (load) + ;; Install the above finalization function. + (when (fboundp 'finalize-fin) + (il:\\set.finalization.function 'il:compiled-closure 'finalize-fin))) + +(defun allocate-funcallable-instance-1 () + (let* ((env (il:\\allocblock (1+ funcallable-instance-closure-size) t)) + (fin (il:make-compiled-closure nil env))) + (setf (fin-env-fin env) fin) + (il:replace (closure-overlay funcallable-instance-p) il:of fin il:with 't) + (set-funcallable-instance-function fin + #'(lambda (&rest ignore) + (declare (ignore ignore)) + (called-fin-without-function))) + fin)) + +(xcl:definline funcallable-instance-p (x) + (and (typep x 'il:compiled-closure) + (il:fetch (closure-overlay funcallable-instance-p) il:of x))) + +(defun set-funcallable-instance-function (fin new) + (cond ((not (funcallable-instance-p fin)) + (error "~S is not a funcallable-instance" fin)) + ((not (functionp new)) + (error "~S is not a function." new)) + ((typep new 'il:compiled-closure) + (let* ((fin-env + (il:fetch (il:compiled-closure il:environment) il:of fin)) + (new-env + (il:fetch (il:compiled-closure il:environment) il:of new)) + (new-env-size (if new-env (il:\\#blockdatacells new-env) 0)) + (fin-env-size (- funcallable-instance-closure-size + (length funcallable-instance-data)))) + (cond ((and new-env + (<= new-env-size fin-env-size)) + (dotimes (i fin-env-size) + (il:\\rplptr fin-env + (* i 2) + (if (< i new-env-size) + (il:\\getbaseptr new-env (* i 2)) + nil))) + (setf (compiled-closure-fnheader fin) + (compiled-closure-fnheader new))) + (t + (set-funcallable-instance-function + fin + (make-trampoline new)))))) + (t + (set-funcallable-instance-function fin + (make-trampoline new))))) + +(defun make-trampoline (function) + #'(lambda (&rest args) + (apply function args))) + + +(defmacro funcallable-instance-data-1 (fin data) + `(il:\\getbaseptr (il:fetch (il:compiled-closure il:environment) il:of ,fin) + (* (- funcallable-instance-closure-size + (funcallable-instance-data-position ,data) + 1) ;Reserve last element to + ;point back to actual FIN! + 2))) + +(defsetf funcallable-instance-data-1 (fin data) (new-value) + `(il:\\rplptr (il:fetch (il:compiled-closure il:environment) il:of ,fin) + (* (- funcallable-instance-closure-size + (funcallable-instance-data-position ,data) + 1) + 2) + ,new-value)) + +);end of #+Xerox + + +;;; +;;; In Franz Common Lisp ExCL +;;; This code was originally written by: +;;; jkf%franz.uucp@berkeley.edu +;;; and hacked by: +;;; smh%franz.uucp@berkeley.edu + +#+ExCL +(progn + +(defconstant funcallable-instance-flag-bit #x1) + +(defun funcallable-instance-p (x) + (and (excl::function-object-p x) + (eq funcallable-instance-flag-bit + (logand (excl::fn_flags x) + funcallable-instance-flag-bit)))) + +(defun make-trampoline (function) + #'(lambda (&rest args) + (apply function args))) + +;; We initialize a fin's procedure function to this because +;; someone might try to funcall it before it has been set up. +(defun init-fin-fun (&rest ignore) + (declare (ignore ignore)) + (called-fin-without-function)) + + +(eval-when (eval) + (compile 'make-trampoline) + (compile 'init-fin-fun)) + + +;; new style +#+(and gsgc (not sun4) (not cray) (not mips)) +(progn +;; set-funcallable-instance-function must work by overwriting the fin itself +;; because the fin must maintain EQ identity. +;; Because the gsgc time needs several of the fields in the function object +;; at gc time in order to walk the stack frame, it is important never to bash +;; a function object that is active in a frame on the stack. Besides, changing +;; the functions closure vector, not to mention overwriting its constant +;; vector, would scramble it's execution when that stack frame continues. +;; Therefore we represent a fin as a funny compiled-function object. +;; The code vector of this object has some hand-coded instructions which +;; do a very fast jump into the real fin handler function. The function +;; which is the fin object *never* creates a frame on the stack. + + +(defun allocate-funcallable-instance-1 () + (let ((fin (compiler::.primcall 'sys::new-function)) + (init #'init-fin-fun) + (mattress-fun #'funcallable-instance-mattress-pad)) + (setf (excl::fn_symdef fin) 'anonymous-fin) + (setf (excl::fn_constant fin) init) + (setf (excl::fn_code fin) ; this must be before fn_start + (excl::fn_code mattress-fun)) + (setf (excl::fn_start fin) (excl::fn_start mattress-fun)) + (setf (excl::fn_flags fin) (logior (excl::fn_flags init) + funcallable-instance-flag-bit)) + (setf (excl::fn_closure fin) + (make-array (length funcallable-instance-data))) + + fin)) + +;; This function gets its code vector modified with a hand-coded fast jump +;; to the function that is stored in place of its constant vector. +;; This function is never linked in and never appears on the stack. + +(defun funcallable-instance-mattress-pad () + (declare (optimize (speed 3) (safety 0))) + 'nil) + +(eval-when (eval) + (compile 'funcallable-instance-mattress-pad)) + + +#+(and excl (target-class s)) +(eval-when (load eval) + (let ((codevec (excl::fn_code + (symbol-function 'funcallable-instance-mattress-pad)))) + ;; The entire code vector wants to be: + ;; move.l 7(a2),a2 ;#x246a0007 + ;; jmp 1(a2) ;#x4eea0001 + (setf (aref codevec 0) #x246a + (aref codevec 1) #x0007 + (aref codevec 2) #x4eea + (aref codevec 3) #x0001)) +) + +#+(and excl (target-class a)) +(eval-when (load eval) + (let ((codevec (excl::fn_code + (symbol-function 'funcallable-instance-mattress-pad)))) + ;; The entire code vector wants to be: + ;; l r5,15(r5) ;#x5850500f + ;; l r15,11(r5) ;#x58f0500b + ;; br r15 ;#x07ff + (setf (aref codevec 0) #x5850 + (aref codevec 1) #x500f + (aref codevec 2) #x58f0 + (aref codevec 3) #x500b + (aref codevec 4) #x07ff + (aref codevec 5) #x0000)) + ) + +#+(and excl (target-class i)) +(eval-when (load eval) + (let ((codevec (excl::fn_code + (symbol-function 'funcallable-instance-mattress-pad)))) + ;; The entire code vector wants to be: + ;; movl 7(edx),edx ;#x07528b + ;; jmp *3(edx) ;#x0362ff + (setf (aref codevec 0) #x8b + (aref codevec 1) #x52 + (aref codevec 2) #x07 + (aref codevec 3) #xff + (aref codevec 4) #x62 + (aref codevec 5) #x03)) +) + +(defun funcallable-instance-data-1 (instance data) + (let ((constant (excl::fn_closure instance))) + (svref constant (funcallable-instance-data-position data)))) + +(defsetf funcallable-instance-data-1 set-funcallable-instance-data-1) + +(defun set-funcallable-instance-data-1 (instance data new-value) + (let ((constant (excl::fn_closure instance))) + (setf (svref constant (funcallable-instance-data-position data)) + new-value))) + +(defun set-funcallable-instance-function (fin new-function) + (unless (funcallable-instance-p fin) + (error "~S is not a funcallable-instance" fin)) + (unless (functionp new-function) + (error "~S is not a function." new-function)) + (setf (excl::fn_constant fin) + (if (excl::function-object-p new-function) + new-function + ;; The new-function is an interpreted function. + ;; Install a trampoline to call the interpreted function. + (make-trampoline new-function)))) + + +) ;; end sun3 + + +#+(and gsgc (or sun4 mips)) +(progn + +(eval-when (compile load eval) + (defconstant funcallable-instance-constant-count 15) + ) + +(defun allocate-funcallable-instance-1 () + (let ((new-fin (compiler::.primcall + 'sys::new-function + funcallable-instance-constant-count))) + ;; Have to set the procedure function to something for two reasons. + ;; 1. someone might try to funcall it. + ;; 2. the flag bit that says the procedure is a funcallable + ;; instance is set by set-funcallable-instance-function. + (set-funcallable-instance-function new-fin #'init-fin-fun) + new-fin)) + +(defun set-funcallable-instance-function (fin new-value) + ;; we actually only check for a function object since + ;; this is called before the funcallable instance flag is set + (unless (excl::function-object-p fin) + (error "~S is not a funcallable-instance" fin)) + + (cond ((not (functionp new-value)) + (error "~S is not a function." new-value)) + ((not (excl::function-object-p new-value)) + ;; new-value is an interpreted function. Install a + ;; trampoline to call the interpreted function. + (set-funcallable-instance-function fin (make-trampoline new-value))) + ((> (+ (excl::function-constant-count new-value) + (length funcallable-instance-data)) + funcallable-instance-constant-count) + ; can't fit, must trampoline + (set-funcallable-instance-function fin (make-trampoline new-value))) + (t + ;; tack the instance variables at the end of the constant vector + + (setf (excl::fn_code fin) ; this must be before fn_start + (excl::fn_code new-value)) + (setf (excl::fn_start fin) (excl::fn_start new-value)) + + (setf (excl::fn_closure fin) (excl::fn_closure new-value)) + ; only replace the symdef slot if the new value is an + ; interned symbol or some other object (like a function spec) + (let ((newsym (excl::fn_symdef new-value))) + (excl:if* (and newsym (or (not (symbolp newsym)) + (symbol-package newsym))) + then (setf (excl::fn_symdef fin) newsym))) + (setf (excl::fn_formals fin) (excl::fn_formals new-value)) + (setf (excl::fn_cframe-size fin) (excl::fn_cframe-size new-value)) + (setf (excl::fn_locals fin) (excl::fn_locals new-value)) + (setf (excl::fn_flags fin) (logior (excl::fn_flags new-value) + funcallable-instance-flag-bit)) + + ;; on a sun4 we copy over the constants + (dotimes (i (excl::function-constant-count new-value)) + (setf (excl::function-constant fin i) + (excl::function-constant new-value i))) + ;(format t "all done copy from ~s to ~s" new-value fin) + ))) + +(defmacro funcallable-instance-data-1 (instance data) + `(excl::function-constant ,instance + (- funcallable-instance-constant-count + (funcallable-instance-data-position ,data) + 1))) + +) ;; end sun4 or mips + +#+(and gsgc cray) +(progn + +;; The cray is like the sun4 in that the constant vector is included in the +;; function object itself. But a mattress pad must be used anyway, because +;; the function start address is copied in the symbol object, and cannot be +;; updated when the fin is changed. +;; We place the funcallable-instance-function into the first constant slot, +;; and leave enough constant slots after that for the instance data. + +(eval-when (compile load eval) + (defconstant fin-fun-slot 0) + (defconstant fin-instance-data-slot 1) + ) + + +;; We initialize a fin's procedure function to this because +;; someone might try to funcall it before it has been set up. +(defun init-fin-fun (&rest ignore) + (declare (ignore ignore)) + (called-fin-without-function)) + +(defun allocate-funcallable-instance-1 () + (let ((fin (compiler::.primcall 'sys::new-function + (1+ (length funcallable-instance-data)) + "funcallable-instance")) + (init #'init-fin-fun) + (mattress-fun #'funcallable-instance-mattress-pad)) + (setf (excl::fn_symdef fin) 'anonymous-fin) + (setf (excl::function-constant fin fin-fun-slot) init) + (setf (excl::fn_code fin) ; this must be before fn_start + (excl::fn_code mattress-fun)) + (setf (excl::fn_start fin) (excl::fn_start mattress-fun)) + (setf (excl::fn_flags fin) (logior (excl::fn_flags init) + funcallable-instance-flag-bit)) + + fin)) + +;; This function gets its code vector modified with a hand-coded fast jump +;; to the function that is stored in place of its constant vector. +;; This function is never linked in and never appears on the stack. + +(defun funcallable-instance-mattress-pad () + (declare (optimize (speed 3) (safety 0))) + 'nil) + +(eval-when (eval) + (compile 'funcallable-instance-mattress-pad) + (compile 'init-fin-fun)) + +(eval-when (load eval) + (let ((codevec (excl::fn_code + (symbol-function 'funcallable-instance-mattress-pad)))) + ;; The entire code vector wants to be: + ;; a1 b77 + ;; a2 12,a1 + ;; a1 1,a2 + ;; b77 a2 + ;; b76 a1 + ;; j b76 + (setf (aref codevec 0) #o024177 + (aref codevec 1) #o101200 (aref codevec 2) 12 + (aref codevec 3) #o102100 (aref codevec 4) 1 + (aref codevec 5) #o025277 + (aref codevec 6) #o025176 + (aref codevec 7) #o005076 + )) +) + +(defmacro funcallable-instance-data-1 (instance data) + `(excl::function-constant ,instance + (+ (funcallable-instance-data-position ,data) + fin-instance-dtat-slot))) + + +(defun set-funcallable-instance-function (fin new-function) + (unless (funcallable-instance-p fin) + (error "~S is not a funcallable-instance" fin)) + (unless (functionp new-function) + (error "~S is not a function." new-function)) + (setf (excl::function-constant fin fin-fun-slot) + (if (excl::function-object-p new-function) + new-function + ;; The new-function is an interpreted function. + ;; Install a trampoline to call the interpreted function. + (make-trampoline new-function)))) + +) ;; end cray + +#-gsgc +(progn + +(defun allocate-funcallable-instance-1 () + (let ((new-fin (compiler::.primcall 'sys::new-function))) + ;; Have to set the procedure function to something for two reasons. + ;; 1. someone might try to funcall it. + ;; 2. the flag bit that says the procedure is a funcallable + ;; instance is set by set-funcallable-instance-function. + (set-funcallable-instance-function new-fin #'init-fin-fn) + new-fin)) + +(defun set-funcallable-instance-function (fin new-value) + ;; we actually only check for a function object since + ;; this is called before the funcallable instance flag is set + (unless (excl::function-object-p fin) + (error "~S is not a funcallable-instance" fin)) + (cond ((not (functionp new-value)) + (error "~S is not a function." new-value)) + ((not (excl::function-object-p new-value)) + ;; new-value is an interpreted function. Install a + ;; trampoline to call the interpreted function. + (set-funcallable-instance-function fin (make-trampoline new-value))) + (t + ;; tack the instance variables at the end of the constant vector + (setf (excl::fn_start fin) (excl::fn_start new-value)) + (setf (excl::fn_constant fin) (add-instance-vars + (excl::fn_constant new-value) + (excl::fn_constant fin))) + (setf (excl::fn_closure fin) (excl::fn_closure new-value)) + ;; In versions prior to 2.0. comment the next line and any other + ;; references to fn_symdef or fn_locals. + (setf (excl::fn_symdef fin) (excl::fn_symdef new-value)) + (setf (excl::fn_code fin) (excl::fn_code new-value)) + (setf (excl::fn_formals fin) (excl::fn_formals new-value)) + (setf (excl::fn_cframe-size fin) (excl::fn_cframe-size new-value)) + (setf (excl::fn_locals fin) (excl::fn_locals new-value)) + (setf (excl::fn_flags fin) (logior (excl::fn_flags new-value) + funcallable-instance-flag-bit))))) + +(defun add-instance-vars (cvec old-cvec) + ;; create a constant vector containing everything in the given constant + ;; vector plus space for the instance variables + (let* ((nconstants (cond (cvec (length cvec)) (t 0))) + (ndata (length funcallable-instance-data)) + (old-cvec-length (if old-cvec (length old-cvec) 0)) + (new-cvec nil)) + (cond ((<= (+ nconstants ndata) old-cvec-length) + (setq new-cvec old-cvec)) + (t + (setq new-cvec (make-array (+ nconstants ndata))) + (when old-cvec + (dotimes (i ndata) + (setf (svref new-cvec (- (+ nconstants ndata) i 1)) + (svref old-cvec (- old-cvec-length i 1))))))) + + (dotimes (i nconstants) (setf (svref new-cvec i) (svref cvec i))) + + new-cvec)) + +(defun funcallable-instance-data-1 (instance data) + (let ((constant (excl::fn_constant instance))) + (svref constant (- (length constant) + (1+ (funcallable-instance-data-position data)))))) + +(defsetf funcallable-instance-data-1 set-funcallable-instance-data-1) + +(defun set-funcallable-instance-data-1 (instance data new-value) + (let ((constant (excl::fn_constant instance))) + (setf (svref constant (- (length constant) + (1+ (funcallable-instance-data-position data)))) + new-value))) + +);end #-gsgc + +);end of #+ExCL + + +;;; +;;; In Vaxlisp +;;; This code was originally written by: +;;; vanroggen%bach.DEC@DECWRL.DEC.COM +;;; +#+(and dec vax common) +(progn + +;;; The following works only in Version 2 of VAXLISP, and will have to +;;; be replaced for later versions. + +(defun allocate-funcallable-instance-1 () + (list 'system::%compiled-closure% + () + #'(lambda (&rest args) + (declare (ignore args)) + (called-fin-without-function)) + (make-array (length funcallable-instance-data)))) + +(proclaim '(inline funcallable-instance-p)) +(defun funcallable-instance-p (x) + (and (consp x) + (eq (car x) 'system::%compiled-closure%) + (not (null (cdddr x))))) + +(defun set-funcallable-instance-function (fin func) + (cond ((not (funcallable-instance-p fin)) + (error "~S is not a funcallable-instance" fin)) + ((not (functionp func)) + (error "~S is not a function" func)) + ((and (consp func) (eq (car func) 'system::%compiled-closure%)) + (setf (cadr fin) (cadr func) + (caddr fin) (caddr func))) + (t (set-funcallable-instance-function fin + (make-trampoline func))))) + +(defun make-trampoline (function) + #'(lambda (&rest args) + (apply function args))) + +(eval-when (eval) (compile 'make-trampoline)) + +(defmacro funcallable-instance-data-1 (instance data) + `(svref (cadddr ,instance) + (funcallable-instance-data-position ,data))) + +);end of Vaxlisp (and dec vax common) + + +;;;; Implementation of funcallable instances for CMU Common Lisp: +;;; +#+CMU +;;; Note: returns true for non-pcl funcallable structures. +(import 'kernel:funcallable-instance-p) + +#+CMU +(progn + +(defstruct (pcl-funcallable-instance + (:alternate-metaclass kernel:funcallable-instance + kernel:random-pcl-class + kernel:make-random-pcl-class) + (:type kernel:funcallable-structure) + (:constructor allocate-funcallable-instance-1 ()) + (:conc-name nil)) + ;; + ;; PCL wrapper is in the layout slot. + ;; + ;; PCL data vector. + (pcl-funcallable-instance-slots nil) + ;; + ;; The debug-name for this function. + (funcallable-instance-name nil)) + +;;; SET-FUNCALLABLE-INSTANCE-FUNCTION -- Interface +;;; +;;; Set the function that is called when FIN is called. +;;; +(defun set-funcallable-instance-function (fin new-value) + (declare (type function new-value)) + (assert (funcallable-instance-p fin)) + (setf (kernel:funcallable-instance-function fin) new-value)) + + +;;; FUNCALLABLE-INSTANCE-DATA-1 -- Interface +;;; +;;; This "works" on non-PCL FINs, which allows us to weaken +;;; FUNCALLABLE-INSTANCE-P to return trure for all FINs. This is also +;;; necessary for bootstrapping to work, since the layouts for early GFs are +;;; not initially initialized. +;;; +(defmacro funcallable-instance-data-1 (fin slot) + (ecase (eval slot) + (wrapper `(kernel:%funcallable-instance-layout ,fin)) + (slots `(kernel:%funcallable-instance-info ,fin 0)))) + +(defmacro pcl-funcallable-instance-wrapper (x) + `(kernel:%funcallable-instance-layout ,x)) + +); End of #+cmu progn + + +;;; +;;; Kyoto Common Lisp (KCL) +;;; +;;; In KCL, compiled functions and compiled closures are defined as c structs. +;;; This means that in order to access their fields, we have to use C code! +;;; The C code we call and the lisp interface to it is in the file kcl-low. +;;; The lisp interface to this code implements accessors to compiled closures +;;; and compiled functions of about the same level of abstraction as that +;;; which is used by the other implementation dependent versions of FINs in +;;; this file. +;;; + +#+(and KCL (not IBCL)) +(progn + +(defvar *funcallable-instance-marker* (list "Funcallable Instance Marker")) + +(defconstant funcallable-instance-closure-size 15) + +(defconstant funcallable-instance-closure-size1 + (1- funcallable-instance-closure-size)) + +(defconstant funcallable-instance-available-size + (- funcallable-instance-closure-size1 + (length funcallable-instance-data))) + +(defmacro funcallable-instance-marker (x) + `(car (cclosure-env-nthcdr funcallable-instance-closure-size1 ,x))) + +(defun allocate-funcallable-instance-1 () + (let ((fin (allocate-funcallable-instance-2)) + (env (make-list funcallable-instance-closure-size :initial-element nil))) + (setf (%cclosure-env fin) env) + #+:turbo-closure (si:turbo-closure fin) + (setf (funcallable-instance-marker fin) *funcallable-instance-marker*) + fin)) + +(defun allocate-funcallable-instance-2 () + (let ((what-a-dumb-closure-variable ())) + #'(lambda (&rest args) + (declare (ignore args)) + (called-fin-without-function) + (setq what-a-dumb-closure-variable + (dummy-function what-a-dumb-closure-variable))))) + +(defun funcallable-instance-p (x) + (eq *funcallable-instance-marker* (funcallable-instance-marker x))) + +(si:define-compiler-macro funcallable-instance-p (x) + `(eq *funcallable-instance-marker* (funcallable-instance-marker ,x))) + +(defun set-funcallable-instance-function (fin new-value) + (cond ((not (funcallable-instance-p fin)) + (error "~S is not a funcallable-instance" fin)) + ((not (functionp new-value)) + (error "~S is not a function." new-value)) + ((and (cclosurep new-value) + (<= (length (%cclosure-env new-value)) + funcallable-instance-available-size)) + (%set-cclosure fin new-value funcallable-instance-available-size)) + (t + (set-funcallable-instance-function + fin (make-trampoline new-value)))) + fin) + +(defmacro funcallable-instance-data-1 (fin data &environment env) + ;; The compiler won't expand macros before deciding on optimizations, + ;; so we must do it here. + (let* ((pos-form (macroexpand `(funcallable-instance-data-position ,data) + env)) + (index-form (if (constantp pos-form) + (- funcallable-instance-closure-size + (eval pos-form) + 2) + `(- funcallable-instance-closure-size + (funcallable-instance-data-position ,data) + 2)))) + `(car (%cclosure-env-nthcdr ,index-form ,fin)))) + + +#+turbo-closure (clines "#define TURBO_CLOSURE") + +(clines " +static void make_trampoline_internal(); +static void make_turbo_trampoline_internal(); + +static object +make_trampoline(function) + object function; +{ + vs_push(MMcons(function,Cnil)); +#ifdef TURBO_CLOSURE + if(type_of(function)==t_cclosure) + {if(function->cc.cc_turbo==NULL)turbo_closure(function); + vs_head=make_cclosure(make_turbo_trampoline_internal,Cnil,vs_head,Cnil,NULL,0); + return vs_pop;} +#endif + vs_head=make_cclosure(make_trampoline_internal,Cnil,vs_head,Cnil,NULL,0); + return vs_pop; +} + +static void +make_trampoline_internal(fun) + object fun; +{super_funcall_no_event(fun->cc.cc_turbo[0]->c.c_car);} + +static void +make_turbo_trampoline_internal(fun) + object fun; +{ object function=fun->cc.cc_turbo[0]->c.c_car; + (*function->cc.cc_self)(function); +} + +") + +(defentry make-trampoline (object) (compiler::static object make_trampoline)) +) + +#+IBCL +(progn ; From Rainy Day PCL. + +(defvar *funcallable-instance-marker* (list "Funcallable Instance Marker")) + +(defconstant funcallable-instance-closure-size 15) + +(defun allocate-funcallable-instance-1 () + (let ((fin (allocate-funcallable-instance-2)) + (env + (make-list funcallable-instance-closure-size :initial-element nil))) + (set-cclosure-env fin env) + #+:turbo-closure (si:turbo-closure fin) + (dotimes (i (1- funcallable-instance-closure-size)) (pop env)) + (setf (car env) *funcallable-instance-marker*) + fin)) + +(defun allocate-funcallable-instance-2 () + (let ((what-a-dumb-closure-variable ())) + #'(lambda (&rest args) + (declare (ignore args)) + (called-fin-without-function) + (setq what-a-dumb-closure-variable + (dummy-function what-a-dumb-closure-variable))))) + +(defun funcallable-instance-p (x) + (and (cclosurep x) + (let ((env (cclosure-env x))) + (when (listp env) + (dotimes (i (1- funcallable-instance-closure-size)) (pop env)) + (eq (car env) *funcallable-instance-marker*))))) + +(defun set-funcallable-instance-function (fin new-value) + (cond ((not (funcallable-instance-p fin)) + (error "~S is not a funcallable-instance" fin)) + ((not (functionp new-value)) + (error "~S is not a function." new-value)) + ((cclosurep new-value) + (let* ((fin-env (cclosure-env fin)) + (new-env (cclosure-env new-value)) + (new-env-size (length new-env)) + (fin-env-size (- funcallable-instance-closure-size + (length funcallable-instance-data) + 1))) + (cond ((<= new-env-size fin-env-size) + (do ((i 0 (+ i 1)) + (new-env-tail new-env (cdr new-env-tail)) + (fin-env-tail fin-env (cdr fin-env-tail))) + ((= i fin-env-size)) + (setf (car fin-env-tail) + (if (< i new-env-size) + (car new-env-tail) + nil))) + (set-cclosure-self fin (cclosure-self new-value)) + (set-cclosure-data fin (cclosure-data new-value)) + (set-cclosure-start fin (cclosure-start new-value)) + (set-cclosure-size fin (cclosure-size new-value))) + (t + (set-funcallable-instance-function + fin + (make-trampoline new-value)))))) + ((typep new-value 'compiled-function) + ;; Write NILs into the part of the cclosure environment that is + ;; not being used to store the funcallable-instance-data. Then + ;; copy over the parts of the compiled function that need to be + ;; copied over. + (let ((env (cclosure-env fin))) + (dotimes (i (- funcallable-instance-closure-size + (length funcallable-instance-data) + 1)) + (setf (car env) nil) + (pop env))) + (set-cclosure-self fin (cfun-self new-value)) + (set-cclosure-data fin (cfun-data new-value)) + (set-cclosure-start fin (cfun-start new-value)) + (set-cclosure-size fin (cfun-size new-value))) + (t + (set-funcallable-instance-function fin + (make-trampoline new-value)))) + fin) + + +(defun make-trampoline (function) + #'(lambda (&rest args) + (apply function args))) + +;; this replaces funcallable-instance-data-1, set-funcallable-instance-data-1 +;; and the defsetf +(defmacro funcallable-instance-data-1 (fin data &environment env) + ;; The compiler won't expand macros before deciding on optimizations, + ;; so we must do it here. + (let* ((pos-form (macroexpand `(funcallable-instance-data-position ,data) + env)) + (index-form (if (constantp pos-form) + (- funcallable-instance-closure-size + (eval pos-form) + 2) + `(- funcallable-instance-closure-size + (funcallable-instance-data-position ,data) + 2)))) + #+:turbo-closure `(car (tc-cclosure-env-nthcdr ,index-form ,fin)) + #-:turbo-closure `(nth ,index-form (cclosure-env ,fin)))) + +) + + +;;; +;;; In H.P. Common Lisp +;;; This code was originally written by: +;;; kempf@hplabs.hp.com (James Kempf) +;;; dsouza@hplabs.hp.com (Roy D'Souza) +;;; +#+HP-HPLabs +(progn + +(defmacro fin-closure-size ()`(prim::@* 6 prim::bytes-per-word)) + +(defmacro fin-set-mem-hword () + `(prim::@set-mem-hword + (prim::@+ fin (prim::@<< 2 1)) + (prim::@+ (prim::@<< 2 8) + (prim::@fundef-info-parms (prim::@fundef-info fundef))))) + +(defun allocate-funcallable-instance-1() + (let* ((fundef + #'(lambda (&rest ignore) + (declare (ignore ignore)) + (called-fin-without-function))) + (static-link (vector 'lisp::*undefined* NIL NIL NIL NIL NIL)) + (fin (prim::@make-fundef (fin-closure-size)))) + (fin-set-mem-hword) + (prim::@set-svref fin 2 fundef) + (prim::@set-svref fin 3 static-link) + (prim::@set-svref fin 4 0) + (impl::PlantclosureHook fin) + fin)) + +(defmacro funcallable-instance-p (possible-fin) + `(= (fin-closure-size) (prim::@header-inf ,possible-fin))) + +(defun set-funcallable-instance-function (fin new-function) + (cond ((not (funcallable-instance-p fin)) + (error "~S is not a funcallable instance.~%" fin)) + ((not (functionp new-function)) + (error "~S is not a function." new-function)) + (T + (prim::@set-svref fin 2 new-function)))) + +(defmacro funcallable-instance-data-1 (fin data) + `(prim::@svref (prim::@closure-static-link ,fin) + (+ 2 (funcallable-instance-data-position ,data)))) + +(defsetf funcallable-instance-data-1 (fin data) (new-value) + `(prim::@set-svref (prim::@closure-static-link ,fin) + (+ (funcallable-instance-data-position ,data) 2) + ,new-value)) + +(defun funcallable-instance-name (fin) + (prim::@svref (prim::@closure-static-link fin) 1)) + +(defsetf funcallable-instance-name set-funcallable-instance-name) + +(defun set-funcallable-instance-name (fin new-name) + (prim::@set-svref (prim::@closure-static-link fin) 1 new-name)) + +);end #+HP + + + +;;; +;;; In Golden Common Lisp. +;;; This code was originally written by: +;;; dan%acorn@Live-Oak.LCS.MIT.edu (Dan Jacobs) +;;; +;;; GCLISP supports named structures that are specially marked as funcallable. +;;; This allows FUNCALLABLE-INSTANCE-P to be a normal structure predicate, +;;; and allows ALLOCATE-FUNCALLABLE-INSTANCE-1 to be a normal boa-constructor. +;;; +#+GCLISP +(progn + +(defstruct (%funcallable-instance + (:predicate funcallable-instance-p) + (:copier nil) + (:constructor allocate-funcallable-instance-1 ()) + (:print-function + (lambda (struct stream depth) + (declare (ignore depth)) + (print-object struct stream)))) + (function #'(lambda (ignore-this &rest ignore-these-too) + (declare (ignore ignore-this ignore-these-too)) + (called-fin-without-function)) + :type function) + (%hidden% 'gclisp::funcallable :read-only t) + (data (vector nil nil) :type simple-vector :read-only t)) + +(proclaim '(inline set-funcallable-instance-function)) +(defun set-funcallable-instance-function (fin new-value) + (setf (%funcallable-instance-function fin) new-value)) + +(defmacro funcallable-instance-data-1 (fin data) + `(svref (%funcallable-instance-data ,fin) + (funcallable-instance-data-position ,data))) + +) + + +;;; +;;; Explorer Common Lisp +;;; This code was originally written by: +;;; Dussud%Jenner@csl.ti.com +;;; +#+ti +(progn + +#+(or :ti-release-3 (and :ti-release-2 elroy)) +(defmacro lexical-closure-environment (l) + `(cdr (si:%make-pointer si:dtp-list + (cdr (si:%make-pointer si:dtp-list ,l))))) + +#-(or :ti-release-3 elroy) +(defmacro lexical-closure-environment (l) + `(caar (si:%make-pointer si:dtp-list + (cdr (si:%make-pointer si:dtp-list ,l))))) + +(defmacro lexical-closure-function (l) + `(car (si:%make-pointer si:dtp-list ,l))) + + +(defvar *funcallable-instance-marker* (list "Funcallable Instance Marker")) + +(defconstant funcallable-instance-closure-size 15) ; NOTE: In order to avoid + ; hassles with the reader, +(defmacro allocate-funcallable-instance-2 () ; these two 15's are the + (let ((l ())) ; same. Be sure to keep + (dotimes (i 15) ; them consistent. + (push (list (gensym) nil) l)) + `(let ,l + #'(lambda (ignore &rest ignore-them-too) + (declare (ignore ignore ignore-them-too)) + (called-fin-without-function) + (values . ,(mapcar #'car l)))))) + +(defun allocate-funcallable-instance-1 () + (let* ((new-fin (allocate-funcallable-instance-2))) + (setf (car (nthcdr (1- funcallable-instance-closure-size) + (lexical-closure-environment new-fin))) + *funcallable-instance-marker*) + new-fin)) + +(eval-when (eval) (compile 'allocate-funcallable-instance-1)) + +(proclaim '(inline funcallable-instance-p)) +(defun funcallable-instance-p (x) + (and (typep x #+:ti-release-2 'closure + #+:ti-release-3 'si:lexical-closure) + (let ((env (lexical-closure-environment x))) + (eq (nth (1- funcallable-instance-closure-size) env) + *funcallable-instance-marker*)))) + +(defun set-funcallable-instance-function (fin new-value) + (cond ((not (funcallable-instance-p fin)) + (error "~S is not a funcallable-instance")) + ((not (functionp new-value)) + (error "~S is not a function.")) + ((typep new-value 'si:lexical-closure) + (let* ((fin-env (lexical-closure-environment fin)) + (new-env (lexical-closure-environment new-value)) + (new-env-size (length new-env)) + (fin-env-size (- funcallable-instance-closure-size + (length funcallable-instance-data) + 1))) + (cond ((<= new-env-size fin-env-size) + (do ((i 0 (+ i 1)) + (new-env-tail new-env (cdr new-env-tail)) + (fin-env-tail fin-env (cdr fin-env-tail))) + ((= i fin-env-size)) + (setf (car fin-env-tail) + (if (< i new-env-size) + (car new-env-tail) + nil))) + (setf (lexical-closure-function fin) + (lexical-closure-function new-value))) + (t + (set-funcallable-instance-function + fin + (make-trampoline new-value)))))) + (t + (set-funcallable-instance-function fin + (make-trampoline new-value))))) + +(defun make-trampoline (function) + (let ((tmp)) + #'(lambda (&rest args) tmp + (apply function args)))) + +(eval-when (eval) (compile 'make-trampoline)) + +(defmacro funcallable-instance-data-1 (fin data) + `(let ((env (lexical-closure-environment ,fin))) + (nth (- funcallable-instance-closure-size + (funcallable-instance-data-position ,data) + 2) + env))) + + +(defsetf funcallable-instance-data-1 (fin data) (new-value) + `(let ((env (lexical-closure-environment ,fin))) + (setf (car (nthcdr (- funcallable-instance-closure-size + (funcallable-instance-data-position ,data) + 2) + env)) + ,new-value))) + +);end of code for TI + + +;;; Implemented by Bein@pyramid -- Tue Aug 25 19:05:17 1987 +;;; +;;; A FIN is a distinct type of object which FUNCALL,EVAL, and APPLY +;;; recognize as functions. Both Compiled-Function-P and functionp +;;; recognize FINs as first class functions. +;;; +;;; This does not work with PyrLisp versions earlier than 1.1.. + +#+pyramid +(progn + +(defun make-trampoline (function) + #'(lambda (&rest args) (apply function args))) + +(defun un-initialized-fin (&rest trash) + (declare (ignore trash)) + (called-fin-without-function)) + +(eval-when (eval) + (compile 'make-trampoline) + (compile 'un-initialized-fin)) + +(defun allocate-funcallable-instance-1 () + (let ((fin (system::alloc-funcallable-instance))) + (system::set-fin-function fin #'un-initialized-fin) + fin)) + +(defun funcallable-instance-p (object) + (typep object 'lisp::funcallable-instance)) + +(clc::deftransform funcallable-instance-p trans-fin-p (object) + `(typep ,object 'lisp::funcallable-instance)) + +(defun set-funcallable-instance-function (fin new-value) + (or (funcallable-instance-p fin) + (error "~S is not a funcallable-instance." fin)) + (cond ((not (functionp new-value)) + (error "~S is not a function." new-value)) + ((not (lisp::compiled-function-p new-value)) + (set-funcallable-instance-function fin + (make-trampoline new-value))) + (t + (system::set-fin-function fin new-value)))) + +(defun funcallable-instance-data-1 (fin data-name) + (system::get-fin-data fin + (funcallable-instance-data-position data-name))) + +(defun set-funcallable-instance-data-1 (fin data-name value) + (system::set-fin-data fin + (funcallable-instance-data-position data-name) + value)) + +(defsetf funcallable-instance-data-1 set-funcallable-instance-data-1) + +); End of #+pyramid + + +;;; +;;; For Coral Lisp +;;; +#+:coral +(progn + +(defconstant ccl::$v_istruct 22) +(defvar ccl::initial-fin-slots (make-list (length funcallable-instance-data))) +(defconstant ccl::fin-function 1) +(defconstant ccl::fin-data (+ ccl::FIN-function 1)) + +(defun allocate-funcallable-instance-1 () + (apply #'ccl::%gvector + ccl::$v_istruct + 'ccl::funcallable-instance + #'(lambda (&rest ignore) + (declare (ignore ignore)) + (called-fin-without-function)) + ccl::initial-fin-slots)) + +#+:ccl-1.3 +(eval-when (eval compile load) + +;;; Make uvector-based objects (like funcallable instances) print better. +(defun print-uvector-object (obj stream &optional print-level) + (declare (ignore print-level)) + (print-object obj stream)) + +;;; Inform the print system about funcallable instance uvectors. +(pushnew (cons 'ccl::funcallable-instance #'print-uvector-object) + ccl:*write-uvector-alist* + :test #'equal) + +) + +(defun funcallable-instance-p (x) + (and (eq (ccl::%type-of x) 'ccl::internal-structure) + (eq (ccl::%uvref x 0) 'ccl::funcallable-instance))) + +(defun set-funcallable-instance-function (fin new-value) + (unless (funcallable-instance-p fin) + (error "~S is not a funcallable-instance." fin)) + (unless (functionp new-value) + (error "~S is not a function." new-value)) + (ccl::%uvset fin ccl::FIN-function new-value)) + +(defmacro funcallable-instance-data-1 (fin data-name) + `(ccl::%uvref ,fin + (+ (funcallable-instance-data-position ,data-name) + ccl::FIN-data))) + +(defsetf funcallable-instance-data-1 (fin data) (new-value) + `(ccl::%uvset ,fin + (+ (funcallable-instance-data-position ,data) ccl::FIN-data) + ,new-value)) + +); End of #+:coral + + + +;;;; Slightly Higher-Level stuff built on the implementation-dependent stuff. +;;; +;;; + +(defmacro fsc-instance-p (fin) + `(funcallable-instance-p ,fin)) + +(defmacro fsc-instance-class (fin) + `(wrapper-class (funcallable-instance-data-1 ,fin 'wrapper))) + +(defmacro fsc-instance-wrapper (fin) + `(funcallable-instance-data-1 ,fin 'wrapper)) + +(defmacro fsc-instance-slots (fin) + `(funcallable-instance-data-1 ,fin 'slots)) diff --git a/pcl/gcl_pcl_fixup.lisp b/pcl/gcl_pcl_fixup.lisp new file mode 100644 index 0000000..82c4d69 --- /dev/null +++ b/pcl/gcl_pcl_fixup.lisp @@ -0,0 +1,40 @@ +;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; + +(in-package :pcl) + +(fix-early-generic-functions) +(setq *boot-state* 'complete) + +#+Lispm +(eval-when (load eval) + (si:record-source-file-name 'print-std-instance 'defun 't)) + +(defun print-std-instance (instance stream depth) + (declare (ignore depth)) + (print-object instance stream)) + diff --git a/pcl/gcl_pcl_fngen.lisp b/pcl/gcl_pcl_fngen.lisp new file mode 100644 index 0000000..61ae0ac --- /dev/null +++ b/pcl/gcl_pcl_fngen.lisp @@ -0,0 +1,214 @@ +;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; + +(in-package :pcl) + +;;; +;;; GET-FUNCTION is the main user interface to this code. It is like +;;; COMPILE-LAMBDA, only more efficient. It achieves this efficiency by +;;; reducing the number of times that the compiler needs to be called. +;;; Calls to GET-FUNCTION in which the lambda forms differ only by constants +;;; can use the same piece of compiled code. (For example, dispatch dfuns and +;;; combined method functions can often be shared, if they differ only +;;; by referring to different methods.) +;;; +;;; If GET-FUNCTION is called with a lambda expression only, it will return +;;; a corresponding function. The optional constant-converter argument +;;; can be a function which will be called to convert each constant appearing +;;; in the lambda to whatever value should appear in the function. +;;; +;;; There are three internal functions which operate on the lambda argument +;;; to GET-FUNCTION: +;;; compute-test converts the lambda into a key to be used for lookup, +;;; compute-code is used by get-new-function-generator-internal to +;;; generate the actual lambda to be compiled, and +;;; compute-constants is used to generate the argument list that is +;;; to be passed to the compiled function. +;;; +;;; Whether the returned function is actually compiled depends on whether +;;; the compiler is present (see COMPILE-LAMBDA) and whether this shape of +;;; code was precompiled. +;;; +(defun get-function (lambda + &optional (test-converter #'default-test-converter) + (code-converter #'default-code-converter) + (constant-converter #'default-constant-converter)) + (function-apply (get-function-generator lambda test-converter code-converter) + (compute-constants lambda constant-converter))) + +(defun get-function1 (lambda + &optional (test-converter #'default-test-converter) + (code-converter #'default-code-converter) + (constant-converter #'default-constant-converter)) + (values (the function (get-function-generator lambda test-converter code-converter)) + (compute-constants lambda constant-converter))) + +(defun default-constantp (form) + (and (constantp form) + (not (typep (eval form) '(or symbol fixnum))))) + +(defun default-test-converter (form) + (if (default-constantp form) + '.constant. + form)) + +(defun default-code-converter (form) + (if (default-constantp form) + (let ((gensym (gensym))) (values gensym (list gensym))) + form)) + +(defun default-constant-converter (form) + (if (default-constantp form) + (list (eval form)) + nil)) + + +;;; +;;; *fgens* is a list of all the function generators we have so far. Each +;;; element is a FGEN structure as implemented below. Don't ever touch this +;;; list by hand, use STORE-FGEN. +;;; +(defvar *fgens* ()) + +(defun store-fgen (fgen) + (let ((old (lookup-fgen (fgen-test fgen)))) + (if old + (setf (svref old 2) (fgen-generator fgen) + (svref old 4) (or (svref old 4) + (fgen-system fgen))) + (setq *fgens* (nconc *fgens* (list fgen)))))) + +(defun lookup-fgen (test) + (find test (the list *fgens*) :key #'fgen-test :test #'equal)) + +(defun make-fgen (test gensyms generator generator-lambda system) + (let ((new (make-array 6))) + (setf (svref new 0) test + (svref new 1) gensyms + (svref new 2) generator + (svref new 3) generator-lambda + (svref new 4) system) + new)) + +(defun fgen-test (fgen) (svref fgen 0)) +(defun fgen-gensyms (fgen) (svref fgen 1)) +(defun fgen-generator (fgen) (svref fgen 2)) +(defun fgen-generator-lambda (fgen) (svref fgen 3)) +(defun fgen-system (fgen) (svref fgen 4)) + + + +(defun get-function-generator (lambda test-converter code-converter) + (let* ((test (compute-test lambda test-converter)) + (fgen (lookup-fgen test))) + (if fgen + (fgen-generator fgen) + (get-new-function-generator lambda test code-converter)))) + +(defun get-new-function-generator (lambda test code-converter) + (multiple-value-bind (gensyms generator-lambda) + (get-new-function-generator-internal lambda code-converter) + (let* ((generator (compile-lambda generator-lambda)) + (fgen (make-fgen test gensyms generator generator-lambda nil))) + (store-fgen fgen) + generator))) + +(defun get-new-function-generator-internal (lambda code-converter) + (multiple-value-bind (code gensyms) + (compute-code lambda code-converter) + (values gensyms `(lambda ,gensyms (function ,code))))) + + +(defun compute-test (lambda test-converter) + (let ((walk-form-expand-macros-p t)) + (walk-form lambda + nil + #'(lambda (f c e) + (declare (ignore e)) + (if (neq c :eval) + f + (let ((converted (funcall test-converter f))) + (values converted (neq converted f)))))))) + +(defun compute-code (lambda code-converter) + (let ((walk-form-expand-macros-p t) + (gensyms ())) + (values (walk-form lambda + nil + #'(lambda (f c e) + (declare (ignore e)) + (if (neq c :eval) + f + (multiple-value-bind (converted gens) + (funcall code-converter f) + (when gens (setq gensyms (append gensyms gens))) + (values converted (neq converted f)))))) + gensyms))) + +(defun compute-constants (lambda constant-converter) + (let ((walk-form-expand-macros-p t)) ; doesn't matter here. + (macrolet ((appending () + `(let ((result ())) + (values #'(lambda (value) (setq result (append result value))) + #'(lambda ()result))))) + (gathering1 (appending) + (walk-form lambda + nil + #'(lambda (f c e) + (declare (ignore e)) + (if (neq c :eval) + f + (let ((consts (funcall constant-converter f))) + (if consts + (progn (gather1 consts) (values f t)) + f))))))))) + + +;;; +;;; +;;; +(defmacro precompile-function-generators (&optional system) + (let ((index -1)) + `(progn ,@(gathering1 (collecting) + (dolist (fgen *fgens*) + (when (or (null (fgen-system fgen)) + (eq (fgen-system fgen) system)) + (when system (setf (svref fgen 4) system)) + (gather1 + (make-top-level-form + `(precompile-function-generators ,system ,(incf index)) + '(load) + `(load-function-generator + ',(fgen-test fgen) + ',(fgen-gensyms fgen) + (function ,(fgen-generator-lambda fgen)) + ',(fgen-generator-lambda fgen) + ',system))))))))) + +(defun load-function-generator (test gensyms generator generator-lambda system) + (store-fgen (make-fgen test gensyms generator generator-lambda system))) + diff --git a/pcl/gcl_pcl_fsc.lisp b/pcl/gcl_pcl_fsc.lisp new file mode 100644 index 0000000..6d7f28a --- /dev/null +++ b/pcl/gcl_pcl_fsc.lisp @@ -0,0 +1,100 @@ +;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; +;;; This file contains the definition of the FUNCALLABLE-STANDARD-CLASS +;;; metaclass. Much of the implementation of this metaclass is actually +;;; defined on the class STD-CLASS. What appears in this file is a modest +;;; number of simple methods related to the low-level differences in the +;;; implementation of standard and funcallable-standard instances. +;;; +;;; As it happens, none of these differences are the ones reflected in +;;; the MOP specification; STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS +;;; share all their specified methods at STD-CLASS. +;;; +;;; +;;; workings of this metaclass and the standard-class metaclass. +;;; + +(in-package :pcl) + +(defmethod wrapper-fetcher ((class funcallable-standard-class)) + 'fsc-instance-wrapper) + +(defmethod slots-fetcher ((class funcallable-standard-class)) + 'fsc-instance-slots) + +(defmethod raw-instance-allocator ((class funcallable-standard-class)) + 'allocate-funcallable-instance) + +;;; +;;; +;;; + +(defmethod validate-superclass + ((fsc funcallable-standard-class) + (class standard-class)) + t) ; was (null (wrapper-instance-slots-layout (class-wrapper class))) + + +(defmethod allocate-instance + ((class funcallable-standard-class) &rest initargs) + (declare (ignore initargs)) + (unless (class-finalized-p class) (finalize-inheritance class)) + (allocate-funcallable-instance (class-wrapper class))) + +(defmethod make-reader-method-function ((class funcallable-standard-class) + slot-name) + (make-std-reader-method-function (class-name class) slot-name)) + +(defmethod make-writer-method-function ((class funcallable-standard-class) + slot-name) + (make-std-writer-method-function (class-name class) slot-name)) + +;;;; +;;;; See the comment about reader-function--std and writer-function--sdt. +;;;; +;(define-function-template reader-function--fsc () '(slot-name) +; `(function +; (lambda (instance) +; (slot-value-using-class (wrapper-class (get-wrapper instance)) +; instance +; slot-name)))) +; +;(define-function-template writer-function--fsc () '(slot-name) +; `(function +; (lambda (nv instance) +; (setf +; (slot-value-using-class (wrapper-class (get-wrapper instance)) +; instance +; slot-name) +; nv)))) +; +;(eval-when (load) +; (pre-make-templated-function-constructor reader-function--fsc) +; (pre-make-templated-function-constructor writer-function--fsc)) + + + diff --git a/pcl/gcl_pcl_generic_functions.lisp b/pcl/gcl_pcl_generic_functions.lisp new file mode 100644 index 0000000..00d71d7 --- /dev/null +++ b/pcl/gcl_pcl_generic_functions.lisp @@ -0,0 +1,779 @@ +;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*- + +(in-package :pcl) + +;;; class predicates +(defgeneric class-eq-specializer-p (object)) +; (t) +; (class-eq-specializer) + +(defgeneric classp (object)) +; (t) +; (class) + +(defgeneric eql-specializer-p (object)) +; (t) +; (eql-specializer) + +(defgeneric exact-class-specializer-p (object)) +; (t) +; (exact-class-specializer) + +(defgeneric forward-referenced-class-p (object)) +; (t) +; (forward-referenced-class) + +(defgeneric funcallable-standard-class-p (object)) +; (t) +; (funcallable-standard-class) + +(defgeneric generic-function-p (object)) +; (t) +; (generic-function) + +(defgeneric legal-lambda-list-p (object x)) +; (standard-method t) + +(defgeneric method-combination-p (object)) +; (t) +; (method-combination) + +(defgeneric method-p (object)) +; (t) +; (method) + +(defgeneric short-method-combination-p (object)) +; (short-method-combination) +; (t) + +(defgeneric slot-class-p (object)) +; (t) +; (slot-class) + +(defgeneric specializerp (object)) +; (t) +; (specializer) + +(defgeneric standard-accessor-method-p (object)) +; (t) +; (standard-accessor-method) + +(defgeneric standard-boundp-method-p (object)) +; (t) +; (standard-boundp-method) + +(defgeneric standard-class-p (object)) +; (t) +; (standard-class) + +(defgeneric standard-generic-function-p (object)) +; (t) +; (standard-generic-function) + +(defgeneric standard-method-p (object)) +; (t) +; (standard-method) + +(defgeneric standard-reader-method-p (object)) +; (t) +; (standard-reader-method) + +(defgeneric standard-writer-method-p (object)) +; (t) +; (standard-writer-method) + +(defgeneric structure-class-p (object)) +; (t) +; (structure-class) + + +;;; readers +(defgeneric accessor-method-slot-definition (standard-accessor-method)) +; (standard-accessor-method) + +(defgeneric class-can-precede-list (pcl-class)) +; (pcl-class) + +(defgeneric class-defstruct-constructor (structure-class)) +; (structure-class) + +(defgeneric class-defstruct-form (structure-class)) +; (structure-class) + +(defgeneric class-direct-subclasses (class)) +; (class) + +(defgeneric class-direct-superclasses (class)) +; (class) + +(defgeneric class-eq-specializer (class)) +; (class) + +(defgeneric class-incompatible-superclass-list (pcl-class)) +; (pcl-class) + +(defgeneric class-initialize-info (slot-class)) +; (slot-class) + +(defgeneric class-name (class)) +; (class) + +(defgeneric class-precedence-list (pcl-class)) +; (pcl-class) + +(defgeneric class-predicate-name (class)) +; (class) + +(defgeneric class-wrapper (pcl-class)) +; (pcl-class) + +(defgeneric definition-source (definition-source-mixin)) +; (definition-source-mixin) + +(defgeneric eql-specializer-object (eql-specializer)) +; (eql-specializer) + +(defgeneric generic-function-method-class (standard-generic-function)) +; (standard-generic-function) + +(defgeneric generic-function-method-combination (standard-generic-function)) +; (standard-generic-function) + +(defgeneric generic-function-methods (standard-generic-function)) +; (standard-generic-function) + +(defgeneric generic-function-name (standard-generic-function)) +; (standard-generic-function) + +(defgeneric gf-arg-info (standard-generic-function)) +; (standard-generic-function) + +(defgeneric gf-dfun-state (standard-generic-function)) +; (standard-generic-function) + +(defgeneric gf-pretty-arglist (standard-generic-function)) +; (standard-generic-function) + +(defgeneric long-method-combination-function (long-method-combination)) +; (long-method-combination) + +(defgeneric method-combination-documentation (standard-method-combination)) +; (standard-method-combination) + +(defgeneric method-combination-options (standard-method-combination)) +; (standard-method-combination) + +(defgeneric method-combination-type (standard-method-combination)) +; (standard-method-combination) + +(defgeneric method-fast-function (standard-method)) +; (standard-method) + +(defgeneric method-generic-function (standard-method)) +; (traced-method) +; (standard-method) + +(defgeneric object-plist (plist-mixin)) +; (plist-mixin) + +(defgeneric short-combination-identity-with-one-argument (short-method-combination)) +; (short-method-combination) + +(defgeneric short-combination-operator (short-method-combination)) +; (short-method-combination) + +(defgeneric slot-definition-boundp-function (effective-slot-definition)) +; (effective-slot-definition) + +(defgeneric slot-definition-class (slot-definition)) +; (slot-definition) + +(defgeneric slot-definition-defstruct-accessor-symbol (structure-slot-definition)) +; (structure-slot-definition) + +(defgeneric slot-definition-initargs (slot-definition)) +; (slot-definition) + +(defgeneric slot-definition-initform (slot-definition)) +; (slot-definition) + +(defgeneric slot-definition-initfunction (slot-definition)) +; (slot-definition) + +(defgeneric slot-definition-internal-reader-function (structure-slot-definition)) +; (structure-slot-definition) + +(defgeneric slot-definition-internal-writer-function (structure-slot-definition)) +; (structure-slot-definition) + +(defgeneric slot-definition-location (standard-effective-slot-definition)) +; (standard-effective-slot-definition) + +(defgeneric slot-definition-name (slot-definition)) +; (slot-definition) + +(defgeneric slot-definition-reader-function (effective-slot-definition)) +; (effective-slot-definition) + +(defgeneric slot-definition-readers (slot-definition)) +; (slot-definition) + +(defgeneric slot-definition-type (slot-definition)) +; (slot-definition) + +(defgeneric slot-definition-writer-function (effective-slot-definition)) +; (effective-slot-definition) + +(defgeneric slot-definition-writers (slot-definition)) +; (slot-definition) + +(defgeneric specializer-object (class-eq-specializer)) +; (eql-specializer) +; (class-prototype-specializer) +; (class-eq-specializer) + +(defgeneric specializer-type (specializer)) +; (specializer) + + +;;; writers +(defgeneric (setf class-defstruct-constructor) (new-value structure-class)) +; (t structure-class) + +(defgeneric (setf class-defstruct-form) (new-value structure-class)) +; (t structure-class) + +(defgeneric (setf class-direct-slots) (new-value slot-class)) +; (t slot-class) + +(defgeneric (setf class-incompatible-superclass-list) (new-value pcl-class)) +; (t pcl-class) + +(defgeneric (setf class-initialize-info) (new-value slot-class)) +; (t slot-class) + +(defgeneric (setf class-name) (new-value class)) +; (t class) + +(defgeneric (setf class-slots) (new-value slot-class)) +; (t slot-class) + +(defgeneric (setf generic-function-method-class) (new-value standard-generic-function)) +; (t standard-generic-function) + +(defgeneric (setf generic-function-method-combination) (new-value standard-generic-function)) +; (t standard-generic-function) + +(defgeneric (setf generic-function-methods) (new-value standard-generic-function)) +; (t standard-generic-function) + +(defgeneric (setf generic-function-name) (new-value standard-generic-function)) +; (t standard-generic-function) + +(defgeneric (setf gf-dfun-state) (new-value standard-generic-function)) +; (t standard-generic-function) + +(defgeneric (setf gf-pretty-arglist) (new-value standard-generic-function)) +; (t standard-generic-function) + +(defgeneric (setf method-generic-function) (new-value standard-method)) +; (t traced-method) +; (t standard-method) + +(defgeneric (setf object-plist) (new-value plist-mixin)) +; (t plist-mixin) + +(defgeneric (setf slot-definition-allocation) (new-value standard-slot-definition)) +; (t standard-slot-definition) + +(defgeneric (setf slot-definition-boundp-function) (new-value effective-slot-definition)) +; (t effective-slot-definition) + +(defgeneric (setf slot-definition-class) (new-value slot-definition)) +; (t slot-definition) + +(defgeneric (setf slot-definition-defstruct-accessor-symbol) (new-value structure-slot-definition)) +; (t structure-slot-definition) + +(defgeneric (setf slot-definition-initargs) (new-value slot-definition)) +; (t slot-definition) + +(defgeneric (setf slot-definition-initform) (new-value slot-definition)) +; (t slot-definition) + +(defgeneric (setf slot-definition-initfunction) (new-value slot-definition)) +; (t slot-definition) + +(defgeneric (setf slot-definition-internal-reader-function) (new-value structure-slot-definition)) +; (t structure-slot-definition) + +(defgeneric (setf slot-definition-internal-writer-function) (new-value structure-slot-definition)) +; (t structure-slot-definition) + +(defgeneric (setf slot-definition-location) (new-value standard-effective-slot-definition)) +; (t standard-effective-slot-definition) + +(defgeneric (setf slot-definition-name) (new-value slot-definition)) +; (t slot-definition) + +(defgeneric (setf slot-definition-reader-function) (new-value effective-slot-definition)) +; (t effective-slot-definition) + +(defgeneric (setf slot-definition-readers) (new-value slot-definition)) +; (t slot-definition) + +(defgeneric (setf slot-definition-type) (new-value slot-definition)) +; (t slot-definition) + +(defgeneric (setf slot-definition-writer-function) (new-value effective-slot-definition)) +; (t effective-slot-definition) + +(defgeneric (setf slot-definition-writers) (new-value slot-definition)) +; (t slot-definition) + + +;;; 1 argument +(defgeneric accessor-method-class (method)) +; (standard-accessor-method) +; (standard-writer-method) + +(defgeneric accessor-method-slot-name (m)) +; (traced-method) +; (standard-accessor-method) + +(defgeneric class-constructors (class)) +; (slot-class) + +(defgeneric class-default-initargs (class)) +; (slot-class) +; (built-in-class) + +(defgeneric class-direct-default-initargs (class)) +; (slot-class) +; (built-in-class) + +(defgeneric class-direct-slots (class)) +; (slot-class) +; (built-in-class) + +(defgeneric class-finalized-p (class)) +; (pcl-class) + +(defgeneric class-prototype (class)) +; (pcl-class) +; (std-class) +; (structure-class) + +(defgeneric class-slot-cells (class)) +; (std-class) + +(defgeneric class-slots (class)) +; (slot-class) +; (built-in-class) + +(defgeneric compute-class-precedence-list (root)) +; (slot-class) + +(defgeneric compute-default-initargs (class)) +; (slot-class) + +(defgeneric compute-discriminating-function (gf)) +; (standard-generic-function) + +(defgeneric compute-discriminating-function-arglist-info (generic-function)) +; (standard-generic-function) + +(defgeneric compute-slots (class)) +; (std-class) +; :around (std-class) +; (structure-class) +; :around (structure-class) + +(defgeneric finalize-inheritance (class)) +; (structure-class) +; (std-class) + +(defgeneric function-keywords (method)) +; (standard-method) + +(defgeneric generic-function-lambda-list (gf)) +; (generic-function) + +(defgeneric generic-function-pretty-arglist (generic-function)) +; (standard-generic-function) + +(defgeneric gf-fast-method-function-p (gf)) +; (standard-generic-function) + +(defgeneric initialize-internal-slot-functions (slotd)) +; (effective-slot-definition) + +(defgeneric make-instances-obsolete (class)) +; (std-class) +; (symbol) + +(defgeneric method-function (method)) +; (traced-method) +; (standard-method) + +(defgeneric method-lambda-list (m)) +; (traced-method) +; (standard-method) + +(defgeneric method-pretty-arglist (method)) +; (standard-method) + +(defgeneric method-qualifiers (m)) +; (traced-method) +; (standard-method) + +(defgeneric method-specializers (m)) +; (traced-method) +; (standard-method) + +(defgeneric raw-instance-allocator (class)) +; (standard-class) +; (funcallable-standard-class) + +(defgeneric slot-definition-allocation (slotd)) +; (standard-slot-definition) +; (structure-slot-definition) + +(defgeneric slots-fetcher (class)) +; (standard-class) +; (funcallable-standard-class) + +(defgeneric specializer-class (specializer)) +; (class-prototype-specializer) +; (class-eq-specializer) +; (class) +; (eql-specializer) + +(defgeneric specializer-direct-generic-functions (specializer)) +; (class) +; (specializer-with-object) + +(defgeneric specializer-direct-methods (specializer)) +; (class) +; (specializer-with-object) + +(defgeneric specializer-method-table (specializer)) +; (eql-specializer) +; (class-eq-specializer) + +(defgeneric update-constructors (class)) +; (slot-class) +; (class) + +(defgeneric wrapper-fetcher (class)) +; (standard-class) +; (funcallable-standard-class) + + +;;; 2 arguments +(defgeneric add-dependent (metaobject dependent)) +; (dependent-update-mixin t) + +(defgeneric add-direct-method (specializer method)) +; (class method) +; (specializer-with-object method) + +(defgeneric add-direct-subclass (class subclass)) +; (class class) + +(defgeneric add-method (generic-function method)) +; (standard-generic-function method) + +(defgeneric change-class (instance new-class-name)) +; (standard-object standard-class) +; (standard-object funcallable-standard-class) +; (t symbol) + +(defgeneric class-slot-value (class slot-name)) +; (std-class t) + +(defgeneric compatible-meta-class-change-p (class proto-new-class)) +; (t t) + +(defgeneric compute-applicable-methods (generic-function arguments)) +; (generic-function t) + +(defgeneric compute-applicable-methods-using-classes (generic-function classes)) +; (generic-function t) + +(defgeneric compute-effective-slot-definition (class dslotds)) +; (slot-class t) + +(defgeneric compute-effective-slot-definition-initargs (class direct-slotds)) +; (slot-class t) +; :around (structure-class t) + +(defgeneric default-initargs (class supplied-initargs)) +; (slot-class t) + +(defgeneric describe-object (object stream)) +; (class t) +; (standard-generic-function t) +; (slot-object t) +; (t t) + +(defgeneric direct-slot-definition-class (class initargs)) +; (structure-class t) +; (std-class t) + +(defgeneric effective-slot-definition-class (class initargs)) +; (std-class t) +; (structure-class t) + +(defgeneric inform-type-system-about-class (class name)) +; (std-class t) +; (structure-class t) + +(defgeneric legal-documentation-p (object x)) +; (standard-method t) + +(defgeneric legal-method-function-p (object x)) +; (standard-method t) + +(defgeneric legal-qualifier-p (object x)) +; (standard-method t) + +(defgeneric legal-qualifiers-p (object x)) +; (standard-method t) + +(defgeneric legal-slot-name-p (object x)) +; (standard-method t) + +(defgeneric legal-specializer-p (object x)) +; (standard-method t) + +(defgeneric legal-specializers-p (object x)) +; (standard-method t) + +(defgeneric make-boundp-method-function (class slot-name)) +; (slot-class t) + +(defgeneric make-reader-method-function (class slot-name)) +; (slot-class t) +; (funcallable-standard-class t) + +(defgeneric make-writer-method-function (class slot-name)) +; (slot-class t) +; (funcallable-standard-class t) + +(defgeneric map-dependents (metaobject function)) +; (dependent-update-mixin t) + +;(defgeneric maybe-update-constructors (generic-function method)) +; (generic-function method) + +(defgeneric print-object (mc stream)) +; (t t) +; (class t) +; (slot-definition t) +; (standard-method t) +; (standard-accessor-method t) +; (generic-function t) +; (standard-method-combination t) + +(defgeneric remove-boundp-method (class generic-function)) +; (slot-class t) + +(defgeneric remove-dependent (metaobject dependent)) +; (dependent-update-mixin t) + +(defgeneric remove-direct-method (specializer method)) +; (class method) +; (specializer-with-object method) + +(defgeneric remove-direct-subclass (class subclass)) +; (class class) + +(defgeneric remove-method (generic-function method)) +; (standard-generic-function method) + +(defgeneric remove-reader-method (class generic-function)) +; (slot-class t) + +(defgeneric remove-writer-method (class generic-function)) +; (slot-class t) + +(defgeneric same-specializer-p (specl1 specl2)) +; (specializer specializer) +; (class class) +; (class-eq-specializer class-eq-specializer) +; (eql-specializer eql-specializer) + +(defgeneric slot-accessor-function (slotd type)) +; (effective-slot-definition t) + +(defgeneric slot-accessor-std-p (slotd type)) +; (effective-slot-definition t) + +(defgeneric slots-to-inspect (class object)) +; (slot-class slot-object) + +(defgeneric update-gf-dfun (class gf)) +; (std-class t) + +(defgeneric validate-superclass (fsc class)) +; (class class) +; (class built-in-class) +; (slot-class forward-referenced-class) +; (funcallable-standard-class standard-class) + + +;;; 3 arguments +(defgeneric add-boundp-method (class generic-function slot-name)) +; (slot-class t t) + +(defgeneric add-reader-method (class generic-function slot-name)) +; (slot-class t t) + +(defgeneric add-writer-method (class generic-function slot-name)) +; (slot-class t t) + +(defgeneric (setf class-slot-value) (nv class slot-name)) +; (t std-class t) + +(defgeneric compute-effective-method (generic-function combin applicable-methods)) +; (generic-function long-method-combination t) +; (generic-function short-method-combination t) +; (generic-function standard-method-combination t) + +(defgeneric compute-slot-accessor-info (slotd type gf)) +; (effective-slot-definition t t) + +(defgeneric find-method-combination (generic-function type options)) +; (generic-function (eql progn) t) +; (generic-function (eql or) t) +; (generic-function (eql nconc) t) +; (generic-function (eql min) t) +; (generic-function (eql max) t) +; (generic-function (eql list) t) +; (generic-function (eql append) t) +; (generic-function (eql and) t) +; (generic-function (eql +) t) +; (generic-function (eql standard) t) + +(defgeneric (setf slot-accessor-function) (function slotd type)) +; (t effective-slot-definition t) + +(defgeneric (setf slot-accessor-std-p) (value slotd type)) +; (t effective-slot-definition t) + +(defgeneric slot-boundp-using-class (class object slotd)) +; (std-class standard-object standard-effective-slot-definition) +; (structure-class structure-object structure-effective-slot-definition) + +(defgeneric slot-makunbound-using-class (class object slotd)) +; (std-class standard-object standard-effective-slot-definition) +; (structure-class structure-object structure-effective-slot-definition) + +(defgeneric slot-unbound (class instance slot-name)) +; (t t t) + +(defgeneric slot-value-using-class (class object slotd)) +; (std-class standard-object standard-effective-slot-definition) +; (structure-class structure-object structure-effective-slot-definition) + + +;;; 4 arguments +(defgeneric make-method-lambda (proto-generic-function proto-method lambda-expression environment)) +; (standard-generic-function standard-method t t) + +(defgeneric (setf slot-value-using-class) (new-value class object slotd)) +; (t std-class standard-object standard-effective-slot-definition) +; (t structure-class structure-object structure-effective-slot-definition) + + +;;; 5 arguments +(defgeneric make-method-initargs-form (proto-generic-function proto-method lambda-expression lambda-list environment)) +; (standard-generic-function standard-method t t t) + + +;;; optional arguments +(defgeneric (setf documentation) (new-value slotd &optional doc-type)) +; (t t) +; (t documentation-mixin) +; (t standard-slot-definition) + +(defgeneric documentation (slotd &optional doc-type)) +; (t) +; (documentation-mixin) +; (standard-slot-definition) + +(defgeneric get-method (generic-function qualifiers specializers &optional (errorp t))) +; (standard-generic-function t t) + +(defgeneric remove-named-method (generic-function-name argument-specifiers &optional extra)) +; (t t) + +(defgeneric slot-missing (class instance slot-name operation &optional new-value)) +; (t t t t) + + +;;; keyword arguments +(defgeneric allocate-instance (class &rest initargs)) +; (standard-class) +; (structure-class) +; (funcallable-standard-class) + +(defgeneric ensure-class-using-class (name class &rest args &key &allow-other-keys)) +; (t null) +; (t pcl-class) + +(defgeneric ensure-generic-function-using-class (generic-function function-specifier &key &allow-other-keys)) +; (null t) +; (generic-function t) + +(defgeneric initialize-instance (gf &key &allow-other-keys)) +; (slot-object) +; :after (standard-generic-function) + +(defgeneric make-instance (class &rest initargs)) +; (symbol) +; (class) + +(defgeneric no-applicable-method (generic-function &rest args)) +; (t) + +(defgeneric reader-method-class (class direct-slot &rest initargs)) +; (slot-class t) + +(defgeneric reinitialize-instance (gf &rest args &key &allow-other-keys)) +; (slot-object) +; :before (slot-class) +; :after (slot-class) +; (standard-method) +; :after (standard-generic-function) + +(defgeneric shared-initialize (generic-function slot-names &key &allow-other-keys)) +; (slot-object t) +; :after (documentation-mixin t) +; :after (class-eq-specializer t) +; :after (eql-specializer t) +; :after (std-class t) +; :before (class t) +; :after (structure-class t) +; :before (built-in-class t) +; :after (standard-slot-definition t) +; :after (structure-slot-definition t) +; :before (standard-method t) +; :before (standard-accessor-method t) +; :after (standard-method t) +; :after (standard-accessor-method t) +; :before (standard-generic-function t) + +(defgeneric update-dependent (metaobject dependent &rest initargs)) + +(defgeneric update-instance-for-different-class (previous current &rest initargs)) +; (standard-object standard-object) + +(defgeneric update-instance-for-redefined-class (instance added-slots discarded-slots property-list &rest initargs)) +; (standard-object t t t) + +(defgeneric writer-method-class (class direct-slot &rest initargs)) +; (slot-class t) + + diff --git a/pcl/gcl_pcl_init.lisp b/pcl/gcl_pcl_init.lisp new file mode 100644 index 0000000..217cca7 --- /dev/null +++ b/pcl/gcl_pcl_init.lisp @@ -0,0 +1,261 @@ +;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; +;;; +;;; This file defines the initialization and related protocols. +;;; + +(in-package :pcl) + +(defmethod make-instance ((class symbol) &rest initargs) + (apply #'make-instance (find-class class) initargs)) + +(defmethod make-instance ((class class) &rest initargs) + (unless (class-finalized-p class) (finalize-inheritance class)) + (setq initargs (default-initargs class initargs)) + #|| + (check-initargs-1 + class initargs + (list (list* 'allocate-instance class initargs) + (list* 'initialize-instance (class-prototype class) initargs) + (list* 'shared-initialize (class-prototype class) t initargs))) + ||# + (let* ((info (initialize-info class initargs)) + (valid-p (initialize-info-valid-p info))) + (when (and (consp valid-p) (eq (car valid-p) :invalid)) + (error "Invalid initialization argument ~S for class ~S" + (cdr valid-p) (class-name class)))) + (let ((instance (apply #'allocate-instance class initargs))) + (apply #'initialize-instance instance initargs) + instance)) + +(defvar *default-initargs-flag* (list nil)) + +(defmethod default-initargs ((class slot-class) supplied-initargs) + (call-initialize-function + (initialize-info-default-initargs-function + (initialize-info class supplied-initargs)) + nil supplied-initargs) + #|| + ;; This implementation of default initargs is critically dependent + ;; on all-default-initargs not having any duplicate initargs in it. + (let ((all-default (class-default-initargs class)) + (miss *default-initargs-flag*)) + (flet ((getf* (plist key) + (do () + ((null plist) miss) + (if (eq (car plist) key) + (return (cadr plist)) + (setq plist (cddr plist)))))) + (labels ((default-1 (tail) + (if (null tail) + nil + (if (eq (getf* supplied-initargs (caar tail)) miss) + (list* (caar tail) + (funcall (cadar tail)) + (default-1 (cdr tail))) + (default-1 (cdr tail)))))) + (append supplied-initargs (default-1 all-default))))) + ||#) + +(defmethod initialize-instance ((instance slot-object) &rest initargs) + (apply #'shared-initialize instance t initargs)) + +(defmethod reinitialize-instance ((instance slot-object) &rest initargs) + #|| + (check-initargs-1 + (class-of instance) initargs + (list (list* 'reinitialize-instance instance initargs) + (list* 'shared-initialize instance nil initargs))) + ||# + (let* ((class (class-of instance)) + (info (initialize-info class initargs)) + (valid-p (initialize-info-ri-valid-p info))) + (when (and (consp valid-p) (eq (car valid-p) :invalid)) + (error "Invalid initialization argument ~S for class ~S" + (cdr valid-p) (class-name class)))) + (apply #'shared-initialize instance nil initargs) + instance) + +(defmethod update-instance-for-different-class ((previous standard-object) + (current standard-object) + &rest initargs) + ;; First we must compute the newly added slots. The spec defines + ;; newly added slots as "those local slots for which no slot of + ;; the same name exists in the previous class." + (let ((added-slots '()) + (current-slotds (class-slots (class-of current))) + (previous-slot-names (mapcar #'slot-definition-name + (class-slots (class-of previous))))) + (dolist (slotd current-slotds) + (if (and (not (memq (slot-definition-name slotd) previous-slot-names)) + (eq (slot-definition-allocation slotd) ':instance)) + (push (slot-definition-name slotd) added-slots))) + (check-initargs-1 + (class-of current) initargs + (list (list* 'update-instance-for-different-class previous current initargs) + (list* 'shared-initialize current added-slots initargs))) + (apply #'shared-initialize current added-slots initargs))) + +(defmethod update-instance-for-redefined-class ((instance standard-object) + added-slots + discarded-slots + property-list + &rest initargs) + (check-initargs-1 + (class-of instance) initargs + (list (list* 'update-instance-for-redefined-class + instance added-slots discarded-slots property-list initargs) + (list* 'shared-initialize instance added-slots initargs))) + (apply #'shared-initialize instance added-slots initargs)) + +(defmethod shared-initialize + ((instance slot-object) slot-names &rest initargs) + (when (eq slot-names 't) + (return-from shared-initialize + (call-initialize-function + (initialize-info-shared-initialize-t-function + (initialize-info (class-of instance) initargs)) + instance initargs))) + (when (eq slot-names 'nil) + (return-from shared-initialize + (call-initialize-function + (initialize-info-shared-initialize-nil-function + (initialize-info (class-of instance) initargs)) + instance initargs))) + ;; + ;; initialize the instance's slots in a two step process + ;; (1) A slot for which one of the initargs in initargs can set + ;; the slot, should be set by that initarg. If more than + ;; one initarg in initargs can set the slot, the leftmost + ;; one should set it. + ;; + ;; (2) Any slot not set by step 1, may be set from its initform + ;; by step 2. Only those slots specified by the slot-names + ;; argument are set. If slot-names is: + ;; T + ;; any slot not set in step 1 is set from its + ;; initform + ;; + ;; any slot in the list, and not set in step 1 + ;; is set from its initform + ;; + ;; () + ;; no slots are set from initforms + ;; + (let* ((class (class-of instance)) + (slotds (class-slots class)) + #-new-kcl-wrapper + (std-p #+cmu17 + (pcl-instance-p instance) + #-cmu17 + (or (std-instance-p instance) (fsc-instance-p instance)))) + (dolist (slotd slotds) + (let ((slot-name (slot-definition-name slotd)) + (slot-initargs (slot-definition-initargs slotd))) + (unless (progn + ;; Try to initialize the slot from one of the initargs. + ;; If we succeed return T, otherwise return nil. + (doplist (initarg val) initargs + (when (memq initarg slot-initargs) + (setf (slot-value-using-class class instance slotd) + val) + (return 't)))) + ;; Try to initialize the slot from its initform. + (if (and slot-names + (or (eq slot-names 't) + (memq slot-name slot-names)) + (or #-new-kcl-wrapper (and (not std-p) (eq slot-names 't)) + (not (slot-boundp-using-class class instance slotd)))) + (let ((initfunction (slot-definition-initfunction slotd))) + (when initfunction + (setf (slot-value-using-class class instance slotd) + (funcall (the function initfunction))))))))) + instance)) + + +;;; +;;; if initargs are valid return nil, otherwise signal an error +;;; +(defun check-initargs-1 (class initargs call-list &optional (plist-p t) (error-p t)) + (multiple-value-bind (legal allow-other-keys) + (check-initargs-values class call-list) + (unless allow-other-keys + (if plist-p + (check-initargs-2-plist initargs class legal error-p) + (check-initargs-2-list initargs class legal error-p))))) + +(defun check-initargs-values (class call-list) + (let ((methods (mapcan #'(lambda (call) + (if (consp call) + (copy-list (compute-applicable-methods + (gdefinition (car call)) + (cdr call))) + (list call))) + call-list)) + (legal (apply #'append (mapcar #'slot-definition-initargs + (class-slots class))))) + ;; Add to the set of slot-filling initargs the set of + ;; initargs that are accepted by the methods. If at + ;; any point we come across &allow-other-keys, we can + ;; just quit. + (dolist (method methods) + (multiple-value-bind (nreq nopt keysp restp allow-other-keys keys) + (analyze-lambda-list (if (consp method) + (early-method-lambda-list method) + (method-lambda-list method))) + (declare (ignore nreq nopt keysp restp)) + (when allow-other-keys + (return-from check-initargs-values (values nil t))) + (setq legal (append keys legal)))) + (values legal nil))) + +(defun check-initargs-2-plist (initargs class legal &optional (error-p t)) + (unless (getf initargs :allow-other-keys) + ;; Now check the supplied-initarg-names and the default initargs + ;; against the total set that we know are legal. + (doplist (key val) initargs + (unless (memq key legal) + (if error-p + (error "Invalid initialization argument ~S for class ~S" + key + (class-name class)) + (return-from check-initargs-2-plist nil))))) + t) + +(defun check-initargs-2-list (initkeys class legal &optional (error-p t)) + (unless (memq :allow-other-keys initkeys) + ;; Now check the supplied-initarg-names and the default initargs + ;; against the total set that we know are legal. + (dolist (key initkeys) + (unless (memq key legal) + (if error-p + (error "Invalid initialization argument ~S for class ~S" + key + (class-name class)) + (return-from check-initargs-2-list nil))))) + t) + diff --git a/pcl/gcl_pcl_iterate.lisp b/pcl/gcl_pcl_iterate.lisp new file mode 100644 index 0000000..d690a95 --- /dev/null +++ b/pcl/gcl_pcl_iterate.lisp @@ -0,0 +1,1267 @@ +;;;-*- Package: ITERATE; Syntax: Common-Lisp; Base: 10 -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; +;;; Original source {pooh/n}vanmelle>lisp>iterate;4 created 27-Sep-88 12:35:33 + +(in-package :iterate :use '(:lisp :walker)) + + +(export '(iterate iterate* gathering gather with-gathering interval elements + list-elements list-tails plist-elements eachtime while until + collecting joining maximizing minimizing summing + *iterate-warnings*)) + +(defvar *iterate-warnings* :any "Controls whether warnings are issued for iterate/gather forms that aren't optimized. +NIL => never; :USER => those resulting from user code; T => always, even if it's the iteration macro that's suboptimal." + ) + +;;; ITERATE macro + + +(defmacro iterate (clauses &body body &environment env) + (optimize-iterate-form clauses body env)) + +(defun + simple-expand-iterate-form + (clauses body) + + ;; Expand ITERATE. This is the "formal semantics" expansion, which we never + ;; use. + (let* + ((block-name (gensym)) + (bound-var-lists (mapcar #'(lambda (clause) + (let ((names (first clause))) + (if (listp names) + names + (list names)))) + clauses)) + (generator-vars (mapcar #'(lambda (clause) + (declare (ignore clause)) + (gensym)) + clauses))) + `(block ,block-name + (let* + ,(mapcan #'(lambda (gvar clause var-list) + ; For each clause, bind a + ; generator temp to the clause, + ; then bind the specified + ; var(s) + (cons (list gvar (second clause)) + (copy-list var-list))) + generator-vars clauses bound-var-lists) + + ;; Note bug in formal semantics: there can be declarations in the head + ;; of BODY; they go here, rather than inside loop + (loop + ,@(mapcar + #'(lambda (var-list gen-var) + ; Set each bound variable (or + ; set of vars) to the result of + ; calling the corresponding + ; generator + `(multiple-value-setq + ,var-list + (funcall ,gen-var #'(lambda nil (return-from + ,block-name))))) + bound-var-lists generator-vars) + ,@body))))) + +(defparameter *iterate-temp-vars-list* + '(iterate-temp-1 iterate-temp-2 iterate-temp-3 iterate-temp-4 + iterate-temp-5 iterate-temp-6 iterate-temp-7 iterate-temp-8) + "Temp var names used by ITERATE expansions.") + +(defun + optimize-iterate-form + (clauses body iterate-env) + (let* + ((temp-vars *iterate-temp-vars-list*) + (block-name (gensym)) + (finish-form `(return-from ,block-name)) + (bound-vars (mapcan #'(lambda (clause) + (let ((names (first clause))) + (if (listp names) + (copy-list names) + (list names)))) + clauses)) + iterate-decls generator-decls update-forms bindings leftover-body) + (do ((tail bound-vars (cdr tail))) + ((null tail)) + ; Check for duplicates + (when (member (car tail) + (cdr tail)) + (warn "Variable appears more than once in ITERATE: ~S" (car tail)))) + (flet + ((get-iterate-temp nil + + ;; Make temporary var. Note that it is ok to re-use these symbols + ;; in each iterate, because they are not used within BODY. + (or (pop temp-vars) + (gensym)))) + (dolist (clause clauses) + (cond + ((or (not (consp clause)) + (not (consp (cdr clause)))) + (warn "Bad syntax in ITERATE: clause not of form (var iterator): ~S" + clause)) + (t + (unless (null (cddr clause)) + (warn + "Probable parenthesis error in ITERATE clause--more than 2 elements: ~S" + clause)) + (multiple-value-bind + (let-body binding-type let-bindings localdecls otherdecls extra-body) + (expand-into-let (second clause) + 'iterate iterate-env) + + ;; We have expanded the generator clause and parsed it into its LET + ;; pieces. + (prog* + ((vars (first clause)) + gen-args renamed-vars) + (setq vars (if (listp vars) + (copy-list vars) + (list vars))) + ; VARS is now a (fresh) list of + ; all iteration vars bound in + ; this clause + (cond + ((eq let-body :abort) + ; Already issued a warning + ; about malformedness + ) + ((null (setq let-body (function-lambda-p let-body 1))) + ; Not of the expected form + (let ((generator (second clause))) + (cond ((and (consp generator) + (fboundp (car generator))) + ; It looks ok--a macro or + ; function here--so the guy who + ; wrote it just didn't do it in + ; an optimizable way + (maybe-warn :definition "Could not optimize iterate clause ~S because generator not of form (LET[*] ... (FUNCTION (LAMBDA (finish) ...)))" + generator)) + (t ; Perhaps it's just a + ; misspelling? Probably user + ; error + (maybe-warn :user + "Iterate operator in clause ~S is not fboundp." + generator))) + (setq let-body :abort))) + (t + + ;; We have something of the form #'(LAMBDA (finisharg) ...), + ;; possibly with some LET bindings around it. LET-BODY = + ;; ((finisharg) ...). + (setq let-body (cdr let-body)) + (setq gen-args (pop let-body)) + (when let-bindings + + ;; The first transformation we want to perform is + ;; "LET-eversion": turn (let* ((generator (let (..bindings..) + ;; #'(lambda ...)))) ..body..) into (let* (..bindings.. + ;; (generator #'(lambda ...))) ..body..). This + ;; transformation is valid if nothing in body refers to any + ;; of the bindings, something we can assure by + ;; alpha-converting the inner let (substituting new names for + ;; each var). Of course, none of those vars can be special, + ;; but we already checked for that above. + (multiple-value-setq (let-bindings renamed-vars) + (rename-let-bindings let-bindings binding-type + iterate-env leftover-body #'get-iterate-temp)) + (setq leftover-body nil) + ; If there was any leftover + ; from previous, it is now + ; consumed + ) + + ;; The second transformation is substituting the body of the + ;; generator (LAMBDA (finish-arg) . gen-body) for its appearance + ;; in the update form (funcall generator #'(lambda () + ;; finish-form)), then simplifying that form. The requirement + ;; for this part is that the generator body not refer to any + ;; variables that are bound between the generator binding and the + ;; appearance in the loop body. The only variables bound in that + ;; interval are generator temporaries, which have unique names so + ;; are no problem, and the iteration variables remaining for + ;; subsequent clauses. We'll discover the story as we walk the + ;; body. + (multiple-value-bind + (finishdecl other rest) + (parse-declarations let-body gen-args) + (declare (ignore finishdecl)) + ; Pull out declares, if any, + ; separating out the one(s) + ; referring to the finish arg, + ; which we will throw away + (when other + ; Combine remaining decls with + ; decls extracted from the LET, + ; if any + (setq otherdecls (nconc otherdecls other))) + (setq let-body (cond + (otherdecls + ; There are interesting + ; declarations, so have to keep + ; it wrapped. + `(let nil (declare ,@otherdecls) + ,@rest)) + ((null (cdr rest)) + ; Only one form left + (first rest)) + (t `(progn ,@rest))))) + (unless (eq (setq let-body (iterate-transform-body let-body + iterate-env renamed-vars + (first gen-args) + finish-form bound-vars clause)) + :abort) + + ;; Skip the rest if transformation failed. Warning has + ;; already been issued. + + ;; Note possible further optimization: if LET-BODY expanded + ;; into (prog1 oldvalue prepare-for-next-iteration), as so + ;; many do, then we could in most cases split the PROG1 into + ;; two pieces: do the (setq var oldvalue) here, and do the + ;; prepare-for-next-iteration at the bottom of the loop. + ;; This does a slight optimization of the PROG1 and also + ;; rearranges the code in a way that a reasonably clever + ;; compiler might detect how to get rid of redundant + ;; variables altogether (such as happens with INTERVAL and + ;; LIST-TAILS); that would make the whole thing closer to + ;; what you might have coded by hand. However, to do this + ;; optimization, we need to assure that (a) the + ;; prepare-for-next-iteration refers freely to no vars other + ;; than the internal vars we have extracted from the LET, and + ;; (b) that the code has no side effects. These are both + ;; true for all the iterators defined by this module, but how + ;; shall we represent side-effect info and/or tap into the + ;; compiler's knowledge of same? + (when localdecls + ; There were declarations for + ; the generator locals--have to + ; keep them for later, and + ; rename the vars mentioned + (setq + generator-decls + (nconc + generator-decls + (mapcar + #'(lambda + (decl) + (let ((head (car decl))) + (cons head (if (eq head 'type) + (cons (second decl) + (sublis renamed-vars + (cddr decl))) + (sublis renamed-vars + (cdr decl)))))) + localdecls))))))) + + ;; Finished analyzing clause now. LET-BODY is the form which, when + ;; evaluated, returns updated values for the iteration variable(s) + ;; VARS. + (when (eq let-body :abort) + + ;; Some punt case: go with the formal semantics: bind a var to + ;; the generator, then call it in the update section + (let + ((gvar (get-iterate-temp)) + (generator (second clause))) + (setq + let-bindings + (list (list gvar + (cond + (leftover-body + ; Have to use this up + `(progn ,@(prog1 leftover-body (setq + leftover-body + nil)) + generator)) + (t generator))))) + (setq let-body `(funcall ,gvar #'(lambda nil ,finish-form))))) + (push (mv-setq (copy-list vars) + let-body) + update-forms) + (dolist (v vars) + (declare (ignore v)) + ; Pop off the vars we have now + ; bound from the list of vars + ; to watch out for--we'll bind + ; them right now + (pop bound-vars)) + (setq bindings + (nconc bindings let-bindings + (cond (extra-body + ; There was some computation to + ; do after the bindings--here's + ; our chance + (cons (list (first vars) + `(progn ,@extra-body nil)) + (rest vars))) + (t vars)))))))))) + (do ((tail body (cdr tail))) + ((not (and (consp tail) + (consp (car tail)) + (eq (caar tail) + 'declare))) + + ;; TAIL now points at first non-declaration. If there were + ;; declarations, pop them off so they appear in the right place + (unless (eq tail body) + (setq iterate-decls (ldiff body tail)) + (setq body tail)))) + `(block ,block-name + (let* ,bindings ,@(and generator-decls + `((declare ,@generator-decls))) + ,@iterate-decls + ,@leftover-body + (loop ,@(nreverse update-forms) + ,@body))))) + +(defun expand-into-let (clause parent-name env) + + ;; Return values: Body, LET[*], bindings, localdecls, otherdecls, extra + ;; body, where BODY is a single form. If multiple forms in a LET, the + ;; preceding forms are returned as extra body. Returns :ABORT if it + ;; issued a punt warning. + (prog ((expansion clause) + expandedp binding-type let-bindings let-body) + expand + (multiple-value-setq (expansion expandedp) + (macroexpand-1 expansion env)) + (cond ((not (consp expansion)) + ; Shouldn't happen + ) + ((symbolp (setq binding-type (first expansion))) + (case binding-type + ((let let*) + (setq let-bindings (second expansion)) + ; List of variable bindings + (setq let-body (cddr expansion)) + (go handle-let)))) + ((and (consp binding-type) + (eq (car binding-type) + 'lambda) + (not (find-if #'(lambda (x) + (member x lambda-list-keywords) + ) + (setq let-bindings (second binding-type))) + ) + (eql (length (second expansion)) + (length let-bindings)) + (null (cddr expansion))) + ; A simple LAMBDA form can be + ; treated as LET + (setq let-body (cddr binding-type)) + (setq let-bindings (mapcar #'list let-bindings (second + expansion)) + ) + (setq binding-type 'let) + (go handle-let))) + + ;; Fall thru if not a LET + (cond (expandedp ; try expanding again + (go expand)) + (t ; Boring--return form as the + ; body + (return expansion))) + handle-let + (return (let ((locals (variables-from-let let-bindings)) + extra-body specials) + (multiple-value-bind + (localdecls otherdecls let-body) + (parse-declarations let-body locals) + (cond ((setq specials (extract-special-bindings + locals localdecls)) + (maybe-warn (cond ((find-if #'variable-globally-special-p + specials) + ; This could be the fault of a + ; user proclamation + :user) + (t :definition)) + + "Couldn't optimize ~S because expansion of ~S binds specials ~(~S ~)" + parent-name clause specials) + :abort) + (t (values (cond ((not (consp let-body)) + + ; Null body of LET? unlikely, + ; but someone else will likely + ; complain + nil) + ((null (cdr let-body)) + + ; A single expression, which we + ; hope is (function + ; (lambda...)) + (first let-body)) + (t + + ;; More than one expression. These are forms to + ;; evaluate after the bindings but before the + ;; generator form is returned. Save them to + ;; evaluate in the next convenient place. Note that + ;; this is ok, as there is no construct that can + ;; cause a LET to return prematurely (without + ;; returning also from some surrounding construct). + (setq extra-body + (butlast let-body)) + (car (last let-body)))) + binding-type let-bindings localdecls + otherdecls extra-body)))))))) + +(defun variables-from-let (bindings) + + ;; Return a list of the variables bound in the first argument to LET[*]. + (mapcar #'(lambda (binding) + (if (consp binding) + (first binding) + binding)) + bindings)) + +(defun iterate-transform-body (let-body iterate-env renamed-vars finish-arg + finish-form bound-vars clause) + + +;;; This is the second major transformation for a single iterate clause. +;;; LET-BODY is the body of the iterator after we have extracted its local +;;; variables and declarations. We have two main tasks: (1) Substitute +;;; internal temporaries for occurrences of the LET variables; the alist +;;; RENAMED-VARS specifies this transformation. (2) Substitute evaluation of +;;; FINISH-FORM for any occurrence of (funcall FINISH-ARG). Along the way, we +;;; check for forms that would invalidate these transformations: occurrence of +;;; FINISH-ARG outside of a funcall, and free reference to any element of +;;; BOUND-VARS. CLAUSE & TYPE are the original ITERATE clause and its type +;;; (ITERATE or ITERATE*), for purpose of error messages. On success, we +;;; return the transformed body; on failure, :ABORT. + + (walk-form let-body iterate-env + #'(lambda (form context env) + (declare (ignore context)) + + ;; Need to substitute RENAMED-VARS, as well as turn + ;; (FUNCALL finish-arg) into the finish form + (cond ((symbolp form) + (let (renaming) + (cond ((and (eq form finish-arg) + (variable-same-p form env + iterate-env)) + ; An occurrence of the finish + ; arg outside of FUNCALL + ; context--I can't handle this + (maybe-warn :definition "Couldn't optimize iterate form because generator ~S does something with its FINISH arg besides FUNCALL it." + (second clause)) + (return-from iterate-transform-body + :abort)) + ((and (setq renaming (assoc form + renamed-vars + )) + (variable-same-p form env + iterate-env)) + ; Reference to one of the vars + ; we're renaming + (cdr renaming)) + ((and (member form bound-vars) + (variable-same-p form env + iterate-env)) + ; FORM is a var that is bound + ; in this same ITERATE, or + ; bound later in this ITERATE*. + ; This is a conflict. + (maybe-warn :user "Couldn't optimize iterate form because generator ~S is closed over ~S, in conflict with a subsequent iteration variable." + (second clause) + form) + (return-from iterate-transform-body + :abort)) + (t form)))) + ((and (consp form) + (eq (first form) + 'funcall) + (eq (second form) + finish-arg) + (variable-same-p (second form) + env iterate-env)) + ; (FUNCALL finish-arg) => + ; finish-form + (unless (null (cddr form)) + (maybe-warn :definition + "Generator for ~S applied its finish arg to > 0 arguments ~S--ignored." + (second clause) + (cddr form))) + finish-form) + (t form))))) + +(defun + parse-declarations + (tail locals) + + ;; Extract the declarations from the head of TAIL and divide them into 2 + ;; classes: declares about variables in the list LOCALS, and all other + ;; declarations. Returns 3 values: those 2 lists plus the remainder of TAIL. + (let + (localdecls otherdecls form) + (loop + (unless (and tail (consp (setq form (car tail))) + (eq (car form) + 'declare)) + (return (values localdecls otherdecls tail))) + (mapc + #'(lambda + (decl) + (case (first decl) + ((inline notinline optimize) + ; These don't talk about vars + (push decl otherdecls)) + (t ; Assume all other kinds are + ; for vars + (let* ((vars (if (eq (first decl) + 'type) + (cddr decl) + (cdr decl))) + (l (intersection locals vars)) + other) + (cond + ((null l) + ; None talk about LOCALS + (push decl otherdecls)) + ((null (setq other (set-difference vars l))) + ; All talk about LOCALS + (push decl localdecls)) + (t ; Some of each + (let ((head (cons 'type (and (eq (first decl) + 'type) + (list (second decl)))))) + (push (append head other) + otherdecls) + (push (append head l) + localdecls)))))))) + (cdr form)) + (pop tail)))) + +(defun extract-special-bindings (vars decls) + + ;; Return the subset of VARS that are special, either globally or + ;; because of a declaration in DECLS + (let ((specials (remove-if-not #'variable-globally-special-p vars))) + (dolist (d decls) + (when (eq (car d) + 'special) + (setq specials (union specials (intersection vars + (cdr d)))))) + specials)) + +(defun function-lambda-p (form &optional nargs) + + ;; If FORM is #'(LAMBDA bindings . body) and bindings is of length + ;; NARGS, return the lambda expression + (let (args body) + (and (consp form) + (eq (car form) + 'function) + (consp (setq form (cdr form))) + (null (cdr form)) + (consp (setq form (car form))) + (eq (car form) + 'lambda) + (consp (setq body (cdr form))) + (listp (setq args (car body))) + (or (null nargs) + (eql (length args) + nargs)) + form))) + +(defun + rename-let-bindings + (let-bindings binding-type env leftover-body &optional tempvarfn) + + ;; Perform the alpha conversion required for "LET eversion" of (LET[*] + ;; LET-BINDINGS . body)--rename each of the variables to an internal name. + ;; Returns 2 values: a new set of LET bindings and the alist of old var names + ;; to new (so caller can walk the body doing the rest of the renaming). + ;; BINDING-TYPE is one of LET or LET*. LEFTOVER-BODY is optional list of + ;; forms that must be eval'ed before the first binding happens. ENV is the + ;; macro expansion environment, in case we have to walk a LET*. TEMPVARFN is + ;; a function of no args to return a temporary var; if omitted, we use + ;; GENSYM. + (let + (renamed-vars) + (values (mapcar #'(lambda (binding) + (let ((valueform (cond ((not (consp binding)) + + ; No initial value + nil) + ((or (eq binding-type + 'let) + (null renamed-vars)) + + ; All bindings are in parallel, + ; so none can refer to others + (second binding)) + (t + ; In a LET*, have to substitute + ; vars in the 2nd and + ; subsequent initialization + ; forms + (rename-variables + (second binding) + renamed-vars env)))) + (newvar (if tempvarfn + (funcall tempvarfn) + (gensym)))) + (push (cons (if (consp binding) + (first binding) + binding) + newvar) + renamed-vars) + ; Add new variable to the list + ; AFTER we have walked the + ; initial value form + (when leftover-body + + + ;; Previous clause had some computation to do after + ;; its bindings. Here is the first opportunity to + ;; do it + (setq valueform `(progn ,@leftover-body + ,valueform)) + (setq leftover-body nil)) + (list newvar valueform))) + let-bindings) + renamed-vars))) + +(defun rename-variables (form alist env) + + ;; Walks FORM, renaming occurrences of the key variables in ALIST with + ;; their corresponding values. ENV is FORM's environment, so we can + ;; make sure we are talking about the same variables. + (walk-form form env + #'(lambda (form context subenv) + (declare (ignore context)) + (let (pair) + (cond ((and (symbolp form) + (setq pair (assoc form alist)) + (variable-same-p form subenv env)) + (cdr pair)) + (t form)))))) + +(defun + mv-setq + (vars expr) + + ;; Produces (MULTIPLE-VALUE-SETQ vars expr), except that I'll optimize some + ;; of the simple cases for benefit of compilers that don't, and I don't care + ;; what the value is, and I know that the variables need not be set in + ;; parallel, since they can't be used free in EXPR + (cond + ((null vars) + ; EXPR is a side-effect + expr) + ((not (consp vars)) + ; This is an error, but I'll + ; let MULTIPLE-VALUE-SETQ + ; report it + `(multiple-value-setq ,vars ,expr)) + ((and (listp expr) + (eq (car expr) + 'values)) + + ;; (mv-setq (a b c) (values x y z)) can be reduced to a parallel setq + ;; (psetq returns nil, but I don't care about returned value). Do this + ;; even for the single variable case so that we catch (mv-setq (a) (values + ;; x y)) + (pop expr) + ; VALUES + `(setq ,@(mapcon #'(lambda (tail) + (list (car tail) + (cond ((or (cdr tail) + (null (cdr expr))) + ; One result expression for + ; this var + (pop expr)) + (t ; More expressions than vars, + ; so arrange to evaluate all + ; the rest now. + (cons 'prog1 expr))))) + vars))) + ((null (cdr vars)) + ; Simple one variable case + `(setq ,(car vars) + ,expr)) + (t ; General case--I know nothing + `(multiple-value-setq ,vars ,expr)))) + +(defun variable-same-p (var env1 env2) + (eq (variable-lexical-p var env1) + (variable-lexical-p var env2))) + +(defun maybe-warn (type &rest warn-args) + + ;; Issue a warning about not being able to optimize this thing. TYPE + ;; is one of :DEFINITION, meaning the definition is at fault, and + ;; :USER, meaning the user's code is at fault. + (when (case *iterate-warnings* + ((nil) nil) + ((:user) (eq type :user)) + (t t)) + (apply #'warn warn-args))) + + +;; Sample iterators + + +(defmacro + interval + (&whole whole &key from downfrom to downto above below by type) + (cond + ((and from downfrom) + (error "Can't use both FROM and DOWNFROM in ~S" whole)) + ((cdr (remove nil (list to downto above below))) + (error "Can't use more than one limit keyword in ~S" whole)) + (t + (let* + ((down (or downfrom downto above)) + (limit (or to downto above below)) + (inc (cond ((null by) + 1) + ((constantp by) + ; Can inline this increment + by)))) + `(let + ((from ,(or from downfrom 0)) + ,@(and limit `((to ,limit))) + ,@(and (null inc) + `((by ,by)))) + ,@(and type `((declare (type ,type from ,@(and limit '(to)) + ,@(and (null inc) + `(by)))))) + #'(lambda + (finish) + ,@(cond ((null limit) + ; We won't use the FINISH arg + '((declare (ignore finish))))) + (prog1 ,(cond (limit ; Test the limit. If ok, + ; return current value and + ; increment, else quit + `(if (,(cond (above '>) + (below '<) + (down '>=) + (t '<=)) + from to) + from + (funcall finish))) + (t ; No test + 'from)) + (setq from (,(if down + '- + '+) + from + ,(or inc 'by)))))))))) + +(defmacro list-elements (list &key (by '#'cdr)) + `(let ((tail ,list)) + #'(lambda (finish) + (prog1 (if (endp tail) + (funcall finish) + (first tail)) + (setq tail (funcall ,by tail)))))) + +(defmacro list-tails (list &key (by '#'cdr)) + `(let ((tail ,list)) + #'(lambda (finish) + (prog1 (if (endp tail) + (funcall finish) + tail) + (setq tail (funcall ,by tail)))))) + +(defmacro + elements + (sequence) + "Generates successive elements of SEQUENCE, with second value being the index. Use (ELEMENTS (THE type arg)) if you care about the type." + (let* + ((type (and (consp sequence) + (eq (first sequence) + 'the) + (second sequence))) + (accessor (if type + (sequence-accessor type) + 'elt)) + (listp (eq type 'list))) + + ;; If type is given via THE, we may be able to generate a good accessor here + ;; for the benefit of implementations that aren't smart about (ELT (THE + ;; STRING FOO)). I'm not bothering to keep the THE inside the body, + ;; however, since I assume any compiler that would understand (AREF (THE + ;; SIMPLE-ARRAY S)) would also understand that (AREF S) is the same when I + ;; bound S to (THE SIMPLE-ARRAY foo) and never modified it. + + ;; If sequence is declared to be a list, it's better to cdr down it, so we + ;; have some extra cases here. Normally folks would write LIST-ELEMENTS, + ;; but maybe they wanted to get the index for free... + `(let* ((index 0) + (s ,sequence) + ,@(and (not listp) + '((size (length s))))) + #'(lambda (finish) + (values (cond ,(if listp + '((not (endp s)) + (pop s)) + `((< index size) + (,accessor s index))) + (t (funcall finish))) + (prog1 index + (setq index (1+ index)))))))) + +(defmacro + plist-elements + (plist) + "Generates each time 2 items, the indicator and the value." + `(let ((tail ,plist)) + #'(lambda (finish) + (values (if (endp tail) + (funcall finish) + (first tail)) + (prog1 (if (endp (setq tail (cdr tail))) + (funcall finish) + (first tail)) + (setq tail (cdr tail))))))) + +(defun sequence-accessor (type) + + ;; returns the function with which most efficiently to make accesses to + ;; a sequence of type TYPE. + (case (if (consp type) + ; e.g., (VECTOR FLOAT *) + (car type) + type) + ((array simple-array vector) 'aref) + (simple-vector 'svref) + (string 'char) + (simple-string 'schar) + (bit-vector 'bit) + (simple-bit-vector 'sbit) + (t 'elt))) + + +;; These "iterators" may be withdrawn + + +(defmacro eachtime (expr) + `#'(lambda (finish) + (declare (ignore finish)) + ,expr)) + +(defmacro while (expr) + `#'(lambda (finish) + (unless ,expr (funcall finish)))) + +(defmacro until (expr) + `#'(lambda (finish) + (when ,expr (funcall finish)))) + + ; GATHERING macro + + +(defmacro gathering (clauses &body body &environment env) + (or (optimize-gathering-form clauses body env) + (simple-expand-gathering-form clauses body env))) + +(defmacro with-gathering (clauses gather-body &body use-body) + "Binds the variables specified in CLAUSES to the result of (GATHERING clauses gather-body) and evaluates the forms in USE-BODY inside that contour." + + ;; We may optimize this a little better later for those compilers that + ;; don't do a good job on (m-v-bind vars (... (values ...)) ...). + `(multiple-value-bind ,(mapcar #'car clauses) + (gathering ,clauses ,gather-body) + ,@use-body)) + +(defun + simple-expand-gathering-form + (clauses body env) + (declare (ignore env)) + + ;; The "formal semantics" of GATHERING. We use this only in cases that can't + ;; be optimized. + (let + ((acc-names (mapcar #'first (if (symbolp clauses) + ; Shorthand using anonymous + ; gathering site + (setq clauses `((*anonymous-gathering-site* + (,clauses)))) + clauses))) + (realizer-names (mapcar #'(lambda (binding) + (declare (ignore binding)) + (gensym)) + clauses))) + `(multiple-value-call + #'(lambda + ,(mapcan #'list acc-names realizer-names) + (flet ((gather (value &optional (accumulator *anonymous-gathering-site*) + ) + (funcall accumulator value))) + ,@body + (values ,@(mapcar #'(lambda (rname) + `(funcall ,rname)) + realizer-names)))) + ,@(mapcar #'second clauses)))) + +(defvar *active-gatherers* nil + "List of GATHERING bindings currently active during macro expansion)") + +(defvar *anonymous-gathering-site* nil "Variable used in formal expansion of an abbreviated GATHERING form (one with anonymous gathering site)." + ) + +(defun + optimize-gathering-form + (clauses body gathering-env) + (let* + (acc-info leftover-body top-bindings finish-forms top-decls) + (dolist (clause (if (symbolp clauses) + ; A shorthand + `((*anonymous-gathering-site* (,clauses))) + clauses)) + (multiple-value-bind + (let-body binding-type let-bindings localdecls otherdecls extra-body) + (expand-into-let (second clause) + 'gathering gathering-env) + (prog* + ((acc-var (first clause)) + renamed-vars accumulator realizer) + (when (and (consp let-body) + (eq (car let-body) + 'values) + (consp (setq let-body (cdr let-body))) + (setq accumulator (function-lambda-p (car let-body))) + (consp (setq let-body (cdr let-body))) + (setq realizer (function-lambda-p (car let-body) + 0)) + (null (cdr let-body))) + + ;; Macro returned something of the form (VALUES #'(lambda (value) + ;; ...) #'(lambda () ...)), a function to accumulate values and a + ;; function to realize the result. + (when binding-type + + ;; Gatherer expanded into a LET + (cond (otherdecls (maybe-warn :definition "Couldn't optimize GATHERING clause ~S because its expansion carries declarations about more than the bound variables: ~S" + (second clause) + `(declare ,@otherdecls)) + (go punt))) + (when let-bindings + + ;; The first transformation we want to perform is a + ;; variant of "LET-eversion": turn (mv-bind (acc real) + ;; (let (..bindings..) (values #'(lambda ...) #'(lambda + ;; ...))) ..body..) into (let* (..bindings.. (acc + ;; #'(lambda ...)) (real #'(lambda ...))) ..body..). This + ;; transformation is valid if nothing in body refers to + ;; any of the bindings, something we can assure by + ;; alpha-converting the inner let (substituting new names + ;; for each var). Of course, none of those vars can be + ;; special, but we already checked for that above. + (multiple-value-setq (let-bindings renamed-vars) + (rename-let-bindings let-bindings binding-type + gathering-env leftover-body)) + (setq top-bindings (nconc top-bindings let-bindings)) + (setq leftover-body nil) + ; If there was any leftover + ; from previous, it is now + ; consumed + )) + (setq leftover-body (nconc leftover-body extra-body)) + ; Computation to do after these + ; bindings + (push (cons acc-var (rename-and-capture-variables accumulator + renamed-vars gathering-env)) + acc-info) + (setq realizer (rename-variables realizer renamed-vars + gathering-env)) + (push (cond ((null (cdddr realizer)) + ; Simple (LAMBDA () expr) => + ; expr + (third realizer)) + (t ; There could be declarations + ; or something, so leave as a + ; LET + (cons 'let (cdr realizer)))) + finish-forms) + (unless (null localdecls) + ; Declarations about the LET + ; variables also has to + ; percolate up + (setq top-decls (nconc top-decls (sublis renamed-vars + localdecls)))) + (return)) + (maybe-warn :definition "Couldn't optimize GATHERING clause ~S because its expansion is not of the form (VALUES #'(LAMBDA ...) #'(LAMBDA () ...))" + (second clause)) + punt + (let + ((gs (gensym)) + (expansion `(multiple-value-list ,(second clause)))) + ; Slow way--bind gensym to the + ; macro expansion, and we will + ; funcall it in the body + (push (list acc-var gs) + acc-info) + (push `(funcall (cadr ,gs)) + finish-forms) + (setq + top-bindings + (nconc + top-bindings + (list (list gs (cond (leftover-body + `(progn ,@(prog1 leftover-body + (setq leftover-body nil)) + ,expansion)) + (t expansion)))))))))) + (setq body (walk-gathering-body body gathering-env acc-info)) + (cond ((eq body :abort) + ; Couldn't finish expansion + nil) + (t `(let* ,top-bindings + ,@(and top-decls `((declare ,@top-decls))) + ,body + ,(cond ((null (cdr finish-forms)) + ; just a single value + (car finish-forms)) + (t `(values ,@(reverse finish-forms))))))))) + +(defun rename-and-capture-variables (form alist env) + + ;; Walks FORM, renaming occurrences of the key variables in ALIST with + ;; their corresponding values, and capturing any other free variables. + ;; Returns a list of the new form and the list of other closed-over + ;; vars. ENV is FORM's environment, so we can make sure we are talking + ;; about the same variables. + (let (closed) + (list (walk-form + form env + #'(lambda (form context subenv) + (declare (ignore context)) + (let (pair) + (cond ((or (not (symbolp form)) + (not (variable-same-p form subenv + env))) + ; non-variable or one that has + ; been rebound + form) + ((setq pair (assoc form alist)) + ; One to rename + (cdr pair)) + (t ; var is free + (pushnew form closed) + form))))) + closed))) + +(defun + walk-gathering-body + (body gathering-env acc-info) + + ;; Walk the body of (GATHERING (...) . BODY) in environment GATHERING-ENV. + ;; ACC-INFO is a list of information about each of the gathering "bindings" + ;; in the form, in the form (var gatheringfn freevars env) + (let + ((*active-gatherers* (nconc (mapcar #'car acc-info) + *active-gatherers*))) + + ;; *ACTIVE-GATHERERS* tells us what vars are currently legal as GATHER + ;; targets. This is so that when we encounter a GATHER not belonging to us + ;; we can know whether to warn about it. + (walk-form + (cons 'progn body) + gathering-env + #'(lambda + (form context env) + (declare (ignore context)) + (let (info site) + (cond ((consp form) + (cond + ((not (eq (car form) + 'gather)) + ; We only care about GATHER + (when (and (eq (car form) + 'function) + (eq (cadr form) + 'gather)) + ; Passed as functional--can't + ; macroexpand + (maybe-warn :user + "Can't optimize GATHERING because of reference to #'GATHER." + ) + (return-from walk-gathering-body :abort)) + form) + ((setq info (assoc (setq site (if (null (cddr form)) + + ' + *anonymous-gathering-site* + (third form))) + acc-info)) + ; One of ours--expand (GATHER + ; value var). INFO = (var + ; gatheringfn freevars env) + (unless (null (cdddr form)) + (warn "Extra arguments (> 2) in ~S discarded." form) + ) + (let ((fn (second info))) + (cond ((symbolp fn) + ; Unoptimized case--just call + ; the gatherer. FN is the + ; gensym that we bound to the + ; list of two values returned + ; from the gatherer. + `(funcall (car ,fn) + ,(second form))) + (t ; FN = (lambda (value) ...) + (dolist (s (third info)) + (unless (or (variable-same-p s env + gathering-env) + (and (variable-special-p + s env) + (variable-special-p + s gathering-env))) + + + ;; Some var used free in the LAMBDA form has been + ;; rebound between here and the parent GATHERING + ;; form, so can't substitute the lambda. Ok if it's + ;; a special reference both here and in the LAMBDA, + ;; because then it's not closed over. + (maybe-warn :user "Can't optimize GATHERING because the expansion closes over the variable ~S, which is rebound around a GATHER for it." + s) + (return-from walk-gathering-body + :abort))) + + + ;; Return ((lambda (value) ...) actual-value). In + ;; many cases we could simplify this further by + ;; substitution, but we'd have to be careful (for + ;; example, we would need to alpha-convert any LET + ;; we found inside). Any decent compiler will do it + ;; for us. + (list fn (second form)))))) + ((and (setq info (member site *active-gatherers*)) + (or (eq site '*anonymous-gathering-site*) + (variable-same-p site env (fourth info)))) + ; Some other GATHERING will + ; take care of this form, so + ; pass it up for now. + ; Environment check is to make + ; sure nobody shadowed it + ; between here and there + form) + (t ; Nobody's going to handle it + (if (eq site '*anonymous-gathering-site*) + ; More likely that she forgot + ; to mention the site than + ; forget to write an anonymous + ; gathering. + (warn "There is no gathering site specified in ~S." + form) + (warn + "The site ~S in ~S is not defined in an enclosing GATHERING form." + site form)) + ; Turn it into something else + ; so we don't warn twice in the + ; nested case + `(%orphaned-gather ,@(cdr form))))) + ((and (symbolp form) + (setq info (assoc form acc-info)) + (variable-same-p form env gathering-env)) + ; A variable reference to a + ; gather binding from + ; environment TEM + (maybe-warn :user "Can't optimize GATHERING because site variable ~S is used outside of a GATHER form." + form) + (return-from walk-gathering-body :abort)) + (t form))))))) + + +;; Sample gatherers + + +(defmacro + collecting + (&key initial-value) + `(let* ((head ,initial-value) + (tail ,(and initial-value `(last head)))) + (values #'(lambda (value) + (if (null head) + (setq head (setq tail (list value))) + (setq tail (cdr (rplacd tail (list value)))))) + #'(lambda nil head)))) + +(defmacro joining (&key initial-value) + `(let ((result ,initial-value)) + (values #'(lambda (value) + (setq result (nconc result value))) + #'(lambda nil result)))) + +(defmacro + maximizing + (&key initial-value) + `(let ((result ,initial-value)) + (values + #'(lambda (value) + (when ,(cond ((and (constantp initial-value) + (not (null (eval initial-value)))) + ; Initial value is given and we + ; know it's not NIL, so leave + ; out the null check + '(> value result)) + (t '(or (null result) + (> value result)))) + (setq result value))) + #'(lambda nil result)))) + +(defmacro + minimizing + (&key initial-value) + `(let ((result ,initial-value)) + (values + #'(lambda (value) + (when ,(cond ((and (constantp initial-value) + (not (null (eval initial-value)))) + ; Initial value is given and we + ; know it's not NIL, so leave + ; out the null check + '(< value result)) + (t '(or (null result) + (< value result)))) + (setq result value))) + #'(lambda nil result)))) + +(defmacro summing (&key (initial-value 0)) + `(let ((sum ,initial-value)) + (values #'(lambda (value) + (setq sum (+ sum value))) + #'(lambda nil sum)))) + + ; Easier to read expanded code + ; if PROG1 gets left alone + + +(define-walker-template prog1 (nil return walker::repeat (eval))) + diff --git a/pcl/gcl_pcl_low.lisp b/pcl/gcl_pcl_low.lisp new file mode 100644 index 0000000..913fb3b --- /dev/null +++ b/pcl/gcl_pcl_low.lisp @@ -0,0 +1,459 @@ +;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; +;;; This file contains portable versions of low-level functions and macros +;;; which are ripe for implementation specific customization. None of the +;;; code in this file *has* to be customized for a particular Common Lisp +;;; implementation. Moreover, in some implementations it may not make any +;;; sense to customize some of this code. +;;; +;;; But, experience suggests that MOST Common Lisp implementors will want +;;; to customize some of the code in this file to make PCL run better in +;;; their implementation. The code in this file has been separated and +;;; heavily commented to make that easier. +;;; +;;; Implementation-specific version of this file already exist for: +;;; +;;; Symbolics Genera family genera-low.lisp +;;; Lucid Lisp lucid-low.lisp +;;; Xerox 1100 family xerox-low.lisp +;;; ExCL (Franz) excl-low.lisp +;;; Kyoto Common Lisp kcl-low.lisp +;;; Vaxlisp vaxl-low.lisp +;;; CMU Lisp cmu-low.lisp +;;; H.P. Common Lisp hp-low.lisp +;;; Golden Common Lisp gold-low.lisp +;;; Ti Explorer ti-low.lisp +;;; +;;; +;;; These implementation-specific files are loaded after this file. Because +;;; none of the macros defined by this file are used in functions defined by +;;; this file the implementation-specific files can just contain the parts of +;;; this file they want to change. They don't have to copy this whole file +;;; and then change the parts they want. +;;; +;;; If you make changes or improvements to these files, or if you need some +;;; low-level part of PCL re-modularized to make it more portable to your +;;; system please send mail to CommonLoops.pa@Xerox.com. +;;; +;;; Thanks. +;;; + +(in-package :pcl) + +(eval-when (compile load eval) +(defvar *optimize-speed* '(optimize (speed 3) (safety 0))) +) + +(defmacro %svref (vector index) + `(locally (declare #.*optimize-speed* + (inline svref)) + (svref (the simple-vector ,vector) (the fixnum ,index)))) + +(defsetf %svref %set-svref) + +(defmacro %set-svref (vector index new-value) + `(locally (declare #.*optimize-speed* + (inline svref)) + (setf (svref (the simple-vector ,vector) (the fixnum ,index)) + ,new-value))) + + +;;; +;;; without-interrupts +;;; +;;; OK, Common Lisp doesn't have this and for good reason. But For all of +;;; the Common Lisp's that PCL runs on today, there is a meaningful way to +;;; implement this. WHAT I MEAN IS: +;;; +;;; I want the body to be evaluated in such a way that no other code that is +;;; running PCL can be run during that evaluation. I agree that the body +;;; won't take *long* to evaluate. That is to say that I will only use +;;; without interrupts around relatively small computations. +;;; +;;; INTERRUPTS-ON should turn interrupts back on if they were on. +;;; INTERRUPTS-OFF should turn interrupts back off. +;;; These are only valid inside the body of WITHOUT-INTERRUPTS. +;;; +;;; OK? +;;; +(defmacro without-interrupts (&body body) + `(macrolet ((interrupts-on () ()) + (interrupts-off () ())) + (progn ,.body))) + + +;;; +;;; Very Low-Level representation of instances with meta-class standard-class. +;;; +#-new-kcl-wrapper +(progn +#-cmu17 +(defstruct (std-instance (:predicate std-instance-p) + (:conc-name %std-instance-) + (:constructor %%allocate-instance--class ()) + (:print-function print-std-instance)) + (wrapper nil) + (slots nil)) + +(defmacro %instance-ref (slots index) + `(%svref ,slots ,index)) + +(defmacro instance-ref (slots index) + `(svref ,slots ,index)) +) + +#+new-kcl-wrapper +(progn +(defvar *init-vector* (make-array 40 :fill-pointer 1 :adjustable t + :initial-element nil)) + +(defun get-init-list (i) + (declare (fixnum i)(special *slot-unbound*)) + (loop (when (< i (fill-pointer *init-vector*)) + (return (aref *init-vector* i))) + (vector-push-extend + (cons *slot-unbound* + (aref *init-vector* (1- (fill-pointer *init-vector*)))) + *init-vector*))) + +(defmacro %std-instance-wrapper (instance) + `(structure-def ,instance)) + +(defmacro %std-instance-slots (instance) + instance) + +(defmacro std-instance-p (x) + `(structurep ,x)) +) + +(defmacro std-instance-wrapper (x) `(%std-instance-wrapper ,x)) +(defmacro std-instance-slots (x) `(%std-instance-slots ,x)) + +(defmacro get-wrapper (inst) + `(cond ((std-instance-p ,inst) (std-instance-wrapper ,inst)) + ((fsc-instance-p ,inst) (fsc-instance-wrapper ,inst)) + (t (error "What kind of instance is this?")))) + +(defmacro get-instance-wrapper-or-nil (inst) + `(cond ((std-instance-p ,inst) (std-instance-wrapper ,inst)) + ((fsc-instance-p ,inst) (fsc-instance-wrapper ,inst)))) + +(defmacro get-slots (inst) + `(cond ((std-instance-p ,inst) (std-instance-slots ,inst)) + ((fsc-instance-p ,inst) (fsc-instance-slots ,inst)) + (t (error "What kind of instance is this?")))) + +(defmacro get-slots-or-nil (inst) + `(cond ((std-instance-p ,inst) (std-instance-slots ,inst)) + ((fsc-instance-p ,inst) (fsc-instance-slots ,inst)))) + +(defun print-std-instance (instance stream depth) ;A temporary definition used + (declare (ignore depth)) ;for debugging the bootstrap + (printing-random-thing (instance stream) ;code of PCL (See high.lisp). + (let ((class (class-of instance))) + (if (or (eq class (find-class 'standard-class nil)) + (eq class (find-class 'funcallable-standard-class nil)) + (eq class (find-class 'built-in-class nil))) + (format stream "~a ~a" (early-class-name class) + (early-class-name instance)) + (format stream "~a" (early-class-name class)))))) + +;;; +;;; This is the value that we stick into a slot to tell us that it is unbound. +;;; It may seem gross, but for performance reasons, we make this an interned +;;; symbol. That means that the fast check to see if a slot is unbound is to +;;; say (EQ '..SLOT-UNBOUND..). That is considerably faster than looking +;;; at the value of a special variable. Be careful, there are places in the +;;; code which actually use ..slot-unbound.. rather than this variable. So +;;; much for modularity +;;; +(defvar *slot-unbound* '..slot-unbound..) + +(defmacro %allocate-static-slot-storage--class (no-of-slots) + #+new-kcl-wrapper (declare (ignore no-of-slots)) + #-new-kcl-wrapper + `(make-array ,no-of-slots :initial-element *slot-unbound*) + #+new-kcl-wrapper + (error "don't call this")) + +(defmacro std-instance-class (instance) + `(wrapper-class* (std-instance-wrapper ,instance))) + + + ;; +;;;;;; FUNCTION-ARGLIST + ;; +;;; Given something which is functionp, function-arglist should return the +;;; argument list for it. PCL does not count on having this available, but +;;; MAKE-SPECIALIZABLE works much better if it is available. Versions of +;;; function-arglist for each specific port of pcl should be put in the +;;; appropriate xxx-low file. This is what it should look like: +;(defun function-arglist (function) +; ( function)) + +(defun function-pretty-arglist (function) + (declare (ignore function)) + ()) + +(defsetf function-pretty-arglist set-function-pretty-arglist) + +(defun set-function-pretty-arglist (function new-value) + (declare (ignore function)) + new-value) + +;;; +;;; set-function-name +;;; When given a function should give this function the name . +;;; Note that is sometimes a list. Some lisps get the upset +;;; in the tummy when they start thinking about functions which have +;;; lists as names. To deal with that there is set-function-name-intern +;;; which takes a list spec for a function name and turns it into a symbol +;;; if need be. +;;; +;;; When given a funcallable instance, set-function-name MUST side-effect +;;; that FIN to give it the name. When given any other kind of function +;;; set-function-name is allowed to return new function which is the 'same' +;;; except that it has the name. +;;; +;;; In all cases, set-function-name must return the new (or same) function. +;;; +(defun set-function-name (function new-name) + (declare (notinline set-function-name-1 intern-function-name)) + (set-function-name-1 function + (intern-function-name new-name) + new-name)) + +(defun set-function-name-1 (function new-name uninterned-name) + (declare (ignore new-name uninterned-name)) + function) + +(defun intern-function-name (name) + (cond ((symbolp name) name) + ((listp name) + (intern (let ((*package* *the-pcl-package*) + (*print-case* :upcase) + (*print-pretty* nil) + (*print-gensym* 't)) + (format nil "~S" name)) + *the-pcl-package*)))) + + +;;; +;;; COMPILE-LAMBDA +;;; +;;; This is like the Common Lisp function COMPILE. In fact, that is what +;;; it ends up calling. The difference is that it deals with things like +;;; watching out for recursive calls to the compiler or not calling the +;;; compiler in certain cases or allowing the compiler not to be present. +;;; +;;; This starts out with several variables and support functions which +;;; should be conditionalized for any new port of PCL. Note that these +;;; default to reasonable values, many new ports won't need to look at +;;; these values at all. +;;; +;;; *COMPILER-PRESENT-P* NIL means the compiler is not loaded +;;; +;;; *COMPILER-SPEED* one of :FAST :MEDIUM or :SLOW +;;; +;;; *COMPILER-REENTRANT-P* T ==> OK to call compiler recursively +;;; NIL ==> not OK +;;; +;;; function IN-THE-COMPILER-P returns T if in the compiler, NIL otherwise +;;; This is not called if *compiler-reentrant-p* +;;; is T, so it only needs to be implemented for +;;; ports which have non-reentrant compilers. +;;; +;;; +(defvar *compiler-present-p* t) + +(defvar *compiler-speed* + #+(or KCL IBCL GCLisp CMU) :slow + #-(or KCL IBCL GCLisp CMU) :fast) + +(defvar *compiler-reentrant-p* + #+(and (not XKCL) (or KCL IBCL)) nil + #-(and (not XKCL) (or KCL IBCL)) t) + +(defun in-the-compiler-p () + #+(and (not xkcl) (or KCL IBCL))compiler::*compiler-in-use* + #+gclisp (typep (eval '(function (lambda ()))) 'lexical-closure) + ) + +(defvar *compile-lambda-break-p* nil) + +(defun compile-lambda (lambda &optional (desirability :fast)) + (when *compile-lambda-break-p* (break)) + (cond ((null *compiler-present-p*) + (compile-lambda-uncompiled lambda)) + ((and (null *compiler-reentrant-p*) + (in-the-compiler-p)) + (compile-lambda-deferred lambda)) + ((eq desirability :fast) + (compile nil lambda)) + ((and (eq desirability :medium) + (member *compiler-speed* '(:fast :medium))) + (compile nil lambda)) + ((and (eq desirability :slow) + (eq *compiler-speed* ':fast)) + (compile nil lambda)) + (t + (compile-lambda-uncompiled lambda)))) + +(defun compile-lambda-uncompiled (uncompiled) + #'(lambda (&rest args) (apply (coerce uncompiled 'function) args))) + +(defun compile-lambda-deferred (uncompiled) + (let ((function (coerce uncompiled 'function)) + (compiled nil)) + (declare (type (or function null) compiled)) + #'(lambda (&rest args) + (if compiled + (apply compiled args) + (if (in-the-compiler-p) + (apply function args) + (progn (setq compiled (compile nil uncompiled)) + (apply compiled args))))))) + +(defmacro precompile-random-code-segments (&optional system) + `(progn + (eval-when (compile) + (update-dispatch-dfuns) + (compile-iis-functions nil)) + (precompile-function-generators ,system) + (precompile-dfun-constructors ,system) + (precompile-iis-functions ,system) + (eval-when (load) + (compile-iis-functions t)))) + + + +(defun record-definition (type spec &rest args) + (declare (ignore type spec args)) + ()) + +(defun doctor-dfun-for-the-debugger (gf dfun) (declare (ignore gf)) dfun) + +;; From braid.lisp +#-new-kcl-wrapper +(defmacro built-in-or-structure-wrapper (x) + (once-only (x) + (if (structure-functions-exist-p) ; otherwise structurep is too slow for this + `(if (structurep ,x) + (wrapper-for-structure ,x) + (if (symbolp ,x) + (if ,x *the-wrapper-of-symbol* *the-wrapper-of-null*) + (built-in-wrapper-of ,x))) + `(or (and (symbolp ,x) + (if ,x *the-wrapper-of-symbol* *the-wrapper-of-null*)) + (built-in-or-structure-wrapper1 ,x))))) + +#-cmu17 +(defmacro wrapper-of-macro (x) + `(cond ((std-instance-p ,x) + (std-instance-wrapper ,x)) + ((fsc-instance-p ,x) + (fsc-instance-wrapper ,x)) + (t + (#+new-kcl-wrapper built-in-wrapper-of + #-new-kcl-wrapper built-in-or-structure-wrapper + ,x)))) + +#+cmu17 +(defmacro wrapper-of-macro (x) + `(kernel:layout-of ,x)) + +;Low level functions for structures + +;Functions on arbitrary objects + +(defvar *structure-table* (make-hash-table :test 'eq)) + +(defun declare-structure (name included-name slot-description-list) + (setf (gethash name *structure-table*) + (cons included-name slot-description-list))) + +(unless (fboundp 'structure-functions-exist-p) + (setf (symbol-function 'structure-functions-exist-p) + #'(lambda () nil))) + +(defun default-structurep (x) + (structure-type-p (type-of x))) + +(defun default-structure-instance-p (x) + (let ((type (type-of x))) + (and (not (eq type 'std-instance)) + (structure-type-p type)))) + +(defun default-structure-type (x) + (type-of x)) + +(unless (fboundp 'structurep) + (setf (symbol-function 'structurep) #'default-structurep)) + +; excludes std-instance +(unless (fboundp 'structure-instance-p) + (setf (symbol-function 'structure-instance-p) #'default-structure-instance-p)) + +; returns a symbol +(unless (fboundp 'structure-type) + (setf (symbol-function 'structure-type) #'default-structure-type)) + + +;Functions on symbols naming structures + +; Excludes structures types created with the :type option +(defun structure-type-p (symbol) + (not (null (gethash symbol *structure-table*)))) + +(defun structure-type-included-type-name (symbol) + (car (gethash symbol *structure-table*))) + +; direct slots only +; The results of this function are used only by the functions below. +(defun structure-type-slot-description-list (symbol) + (cdr (gethash symbol *structure-table*))) + + +;Functions on slot-descriptions (returned by the function above) + +;returns a symbol +(defun structure-slotd-name (structure-slot-description) + (first structure-slot-description)) + +;returns a symbol +(defun structure-slotd-accessor-symbol (structure-slot-description) + (second structure-slot-description)) + +;returns a symbol or a list or nil +(defun structure-slotd-writer-function (structure-slot-description) + (third structure-slot-description)) + +(defun structure-slotd-type (structure-slot-description) + (fourth structure-slot-description)) + +(defun structure-slotd-init-form (structure-slot-description) + (fifth structure-slot-description)) diff --git a/pcl/gcl_pcl_macros.lisp b/pcl/gcl_pcl_macros.lisp new file mode 100644 index 0000000..26aeb6d --- /dev/null +++ b/pcl/gcl_pcl_macros.lisp @@ -0,0 +1,789 @@ +;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; +;;; Macros global variable definitions, and other random support stuff used +;;; by the rest of the system. +;;; +;;; For simplicity (not having to use eval-when a lot), this file must be +;;; loaded before it can be compiled. +;;; + +(in-package :pcl) + +(proclaim '(declaration + #-Genera values ;I use this so that Zwei can remind + ;me what values a function returns. + + #-Genera arglist ;Tells me what the pretty arglist + ;of something (which probably takes + ;&rest args) is. + + #-Genera indentation ;Tells ZWEI how to indent things + ;like defclass. + class + variable-rebinding + pcl-fast-call + method-name + method-lambda-list + )) + +;;; Age old functions which CommonLisp cleaned-up away. They probably exist +;;; in other packages in all CommonLisp implementations, but I will leave it +;;; to the compiler to optimize into calls to them. +;;; +;;; Common Lisp BUG: +;;; Some Common Lisps define these in the Lisp package which causes +;;; all sorts of lossage. Common Lisp should explictly specify which +;;; symbols appear in the Lisp package. +;;; +(eval-when (compile load eval) + +(defmacro memq (item list) `(member ,item ,list :test #'eq)) +(defmacro assq (item list) `(assoc ,item ,list :test #'eq)) +(defmacro rassq (item list) `(rassoc ,item ,list :test #'eq)) +(defmacro delq (item list) `(delete ,item ,list :test #'eq)) +(defmacro posq (item list) `(position ,item ,list :test #'eq)) +(defmacro neq (x y) `(not (eq ,x ,y))) + + +(defun make-caxr (n form) + (if (< n 4) + `(,(nth n '(car cadr caddr cadddr)) ,form) + (make-caxr (- n 4) `(cddddr ,form)))) + +(defun make-cdxr (n form) + (cond ((zerop n) form) + ((< n 5) `(,(nth n '(identity cdr cddr cdddr cddddr)) ,form)) + (t (make-cdxr (- n 4) `(cddddr ,form))))) +) + +(deftype non-negative-fixnum () + '(and fixnum (integer 0 *))) + +(defun true (&rest ignore) (declare (ignore ignore)) t) +(defun false (&rest ignore) (declare (ignore ignore)) nil) +(defun zero (&rest ignore) (declare (ignore ignore)) 0) + +(defun make-plist (keys vals) + (if (null vals) + () + (list* (car keys) + (car vals) + (make-plist (cdr keys) (cdr vals))))) + +(defun remtail (list tail) + (if (eq list tail) () (cons (car list) (remtail (cdr list) tail)))) + +;;; ONCE-ONLY does the same thing as it does in zetalisp. I should have just +;;; lifted it from there but I am honest. Not only that but this one is +;;; written in Common Lisp. I feel a lot like bootstrapping, or maybe more +;;; like rebuilding Rome. +(defmacro once-only (vars &body body) + (let ((gensym-var (gensym)) + (run-time-vars (gensym)) + (run-time-vals (gensym)) + (expand-time-val-forms ())) + (dolist (var vars) + (push `(if (or (symbolp ,var) + (numberp ,var) + (and (listp ,var) + (member (car ,var) '(quote function)))) + ,var + (let ((,gensym-var (gensym))) + (push ,gensym-var ,run-time-vars) + (push ,var ,run-time-vals) + ,gensym-var)) + expand-time-val-forms)) + `(let* (,run-time-vars + ,run-time-vals + (wrapped-body + (let ,(mapcar #'list vars (reverse expand-time-val-forms)) + ,@body))) + `(let ,(mapcar #'list (reverse ,run-time-vars) + (reverse ,run-time-vals)) + ,wrapped-body)))) + +(eval-when (compile load eval) +(defun extract-declarations (body &optional environment) + ;;(declare (values documentation declarations body)) + (let (documentation declarations form) + (when (and (stringp (car body)) + (cdr body)) + (setq documentation (pop body))) + (block outer + (loop + (when (null body) (return-from outer nil)) + (setq form (car body)) + (when (block inner + (loop (cond ((not (listp form)) + (return-from outer nil)) + ((eq (car form) 'declare) + (return-from inner 't)) + (t + (multiple-value-bind (newform macrop) + (macroexpand-1 form environment) + (if (or (not (eq newform form)) macrop) + (setq form newform) + (return-from outer nil))))))) + (pop body) + (dolist (declaration (cdr form)) + (push declaration declarations))))) + (values documentation + (and declarations `((declare ,.(nreverse declarations)))) + body))) +) + +(defun get-declaration (name declarations &optional default) + (dolist (d declarations default) + (dolist (form (cdr d)) + (when (and (consp form) (eq (car form) name)) + (return-from get-declaration (cdr form)))))) + + +#+Lucid +(eval-when (compile load eval) + (eval `(defstruct ,(intern "FASLESCAPE" (find-package 'lucid))))) + +(defvar *keyword-package* (find-package 'keyword)) + +(defun make-keyword (symbol) + (intern (symbol-name symbol) *keyword-package*)) + +(eval-when (compile load eval) + +(defun string-append (&rest strings) + (setq strings (copy-list strings)) ;The explorer can't even + ;rplaca an &rest arg? + (do ((string-loc strings (cdr string-loc))) + ((null string-loc) + (apply #'concatenate 'string strings)) + (rplaca string-loc (string (car string-loc))))) +) + +(defun symbol-append (sym1 sym2 &optional (package *package*)) + (intern (string-append sym1 sym2) package)) + +(defmacro check-member (place list &key (test #'eql) (pretty-name place)) + (once-only (place list) + `(or (member ,place ,list :test ,test) + (error "The value of ~A, ~S is not one of ~S." + ',pretty-name ,place ,list)))) + +(defmacro alist-entry (alist key make-entry-fn) + (once-only (alist key) + `(or (assq ,key ,alist) + (progn (setf ,alist (cons (,make-entry-fn ,key) ,alist)) + (car ,alist))))) + +;;; A simple version of destructuring-bind. + +;;; This does no more error checking than CAR and CDR themselves do. Some +;;; attempt is made to be smart about preserving intermediate values. It +;;; could be better, although the only remaining case should be easy for +;;; the compiler to spot since it compiles to PUSH POP. +;;; +;;; Common Lisp BUG: +;;; Common Lisp should have destructuring-bind. +;;; +;#-gcl +; FIXME use regular destructuring-bind +(defmacro pcl-destructuring-bind (pattern form &body body) + (multiple-value-bind (ignore declares body) + (extract-declarations body) + (declare (ignore ignore)) + (multiple-value-bind (setqs binds) + (destructure pattern form) + `(let ,binds + ,@declares + ,@setqs + (progn .destructure-form.) + . ,body)))) + +(eval-when (compile load eval) +(defun destructure (pattern form) + ;;(declare (values setqs binds)) + (let ((*destructure-vars* ()) + (setqs ())) + (declare (special *destructure-vars*)) + (setq *destructure-vars* '(.destructure-form.) + setqs (list `(setq .destructure-form. ,form)) + form '.destructure-form.) + (values (nconc setqs (nreverse (destructure-internal pattern form))) + (delete nil *destructure-vars*)))) + +(defun destructure-internal (pattern form) + ;; When we are called, pattern must be a list. Form should be a symbol + ;; which we are free to setq containing the value to be destructured. + ;; Optimizations are performed for the last element of pattern cases. + ;; we assume that the compiler is smart about gensyms which are bound + ;; but only for a short period of time. + (declare (special *destructure-vars*)) + (let ((gensym (gensym)) + (pending-pops 0) + (var nil) + (setqs ())) + (labels + ((make-pop (var form pop-into) + (prog1 + (cond ((zerop pending-pops) + `(progn ,(and var `(setq ,var (car ,form))) + ,(and pop-into `(setq ,pop-into (cdr ,form))))) + ((null pop-into) + (and var `(setq ,var ,(make-caxr pending-pops form)))) + (t + `(progn (setq ,pop-into ,(make-cdxr pending-pops form)) + ,(and var `(setq ,var (pop ,pop-into)))))) + (setq pending-pops 0)))) + (do ((pat pattern (cdr pat))) + ((null pat) ()) + (if (symbolp (setq var (car pat))) + (progn + #-:coral (unless (memq var '(nil ignore)) + (push var *destructure-vars*)) + #+:coral (push var *destructure-vars*) + (cond ((null (cdr pat)) + (push (make-pop var form ()) setqs)) + ((symbolp (cdr pat)) + (push (make-pop var form (cdr pat)) setqs) + (push (cdr pat) *destructure-vars*) + (return ())) + #-:coral + ((memq var '(nil ignore)) (incf pending-pops)) + #-:coral + ((memq (cadr pat) '(nil ignore)) + (push (make-pop var form ()) setqs) + (incf pending-pops 1)) + (t + (push (make-pop var form form) setqs)))) + (progn + (push `(let ((,gensym ())) + ,(make-pop gensym + form + (if (symbolp (cdr pat)) (cdr pat) form)) + ,@(nreverse + (destructure-internal + (if (consp pat) (car pat) pat) + gensym))) + setqs) + (when (symbolp (cdr pat)) + (push (cdr pat) *destructure-vars*) + (return))))) + setqs))) +) + + +(defmacro collecting-once (&key initial-value) + `(let* ((head ,initial-value) + (tail ,(and initial-value `(last head)))) + (values #'(lambda (value) + (if (null head) + (setq head (setq tail (list value))) + (unless (memq value head) + (setq tail + (cdr (rplacd tail (list value))))))) + #'(lambda nil head)))) + +(defmacro doplist ((key val) plist &body body &environment env) + (multiple-value-bind (doc decls bod) + (extract-declarations body env) + (declare (ignore doc)) + `(let ((.plist-tail. ,plist) ,key ,val) + ,@decls + (loop (when (null .plist-tail.) (return nil)) + (setq ,key (pop .plist-tail.)) + (when (null .plist-tail.) + (error "Malformed plist in doplist, odd number of elements.")) + (setq ,val (pop .plist-tail.)) + (progn ,@bod))))) + +(defmacro if* (condition true &rest false) + `(if ,condition ,true (progn ,@false))) + +(defmacro dolist-carefully ((var list improper-list-handler) &body body) + `(let ((,var nil) + (.dolist-carefully. ,list)) + (loop (when (null .dolist-carefully.) (return nil)) + (if (consp .dolist-carefully.) + (progn + (setq ,var (pop .dolist-carefully.)) + ,@body) + (,improper-list-handler))))) + + ;; +;;;;;; printing-random-thing + ;; +;;; Similar to printing-random-object in the lisp machine but much simpler +;;; and machine independent. +(defmacro printing-random-thing ((thing stream) &body body) + #+cmu17 + `(print-unreadable-object (,thing ,stream :identity t) ,@body) + #-cmu17 + (once-only (thing stream) + `(progn + #+cmu + (when *print-readably* + (error "~S cannot be printed readably." ,thing)) + (format ,stream "#<") + ,@body + (format ,stream " ") + (printing-random-thing-internal ,thing ,stream) + (format ,stream ">")))) + +(defun printing-random-thing-internal (thing stream) + (declare (ignore thing stream)) + nil) + + ;; +;;;;;; + ;; + +(defun capitalize-words (string &optional (dashes-p t)) + (let ((string (copy-seq (string string)))) + (declare (string string)) + (do* ((flag t flag) + (length (length string) length) + (char nil char) + (i 0 (+ i 1))) + ((= i length) string) + (setq char (elt string i)) + (cond ((both-case-p char) + (if flag + (and (setq flag (lower-case-p char)) + (setf (elt string i) (char-upcase char))) + (and (not flag) (setf (elt string i) (char-downcase char)))) + (setq flag nil)) + ((char-equal char #\-) + (setq flag t) + (unless dashes-p (setf (elt string i) #\space))) + (t (setq flag nil)))))) + +#-(or lucid kcl) +(eval-when (compile load eval) +;(warn "****** Things will go faster if you fix define-compiler-macro") +) + +#-(or cmu gcl) +(defmacro define-compiler-macro (name arglist &body body) + #+(or lucid kcl) + `(#+lucid lcl:def-compiler-macro #+kcl si::define-compiler-macro + ,name ,arglist + ,@body) + #-(or kcl lucid) + (declare (ignore name arglist body)) + #-(or kcl lucid) + nil) + + +;;; +;;; FIND-CLASS +;;; +;;; This is documented in the CLOS specification. +;;; +(defvar *find-class* (make-hash-table :test #'eq)) + +(defun make-constant-function (value) + #'(lambda (object) + (declare (ignore object)) + value)) + +(defun function-returning-nil (x) + (declare (ignore x)) + nil) + +(defun function-returning-t (x) + (declare (ignore x)) + t) + +(defmacro find-class-cell-class (cell) + `(car ,cell)) + +(defmacro find-class-cell-predicate (cell) + `(cadr ,cell)) + +(defmacro find-class-cell-make-instance-function-keys (cell) + `(cddr ,cell)) + +(defmacro make-find-class-cell (class-name) + (declare (ignore class-name)) + '(list* nil #'function-returning-nil nil)) + +(defun find-class-cell (symbol &optional dont-create-p) + (or (gethash symbol *find-class*) + (unless dont-create-p + (unless (legal-class-name-p symbol) + (error "~S is not a legal class name." symbol)) + (setf (gethash symbol *find-class*) (make-find-class-cell symbol))))) + +(defvar *create-classes-from-internal-structure-definitions-p* t) + +(defun find-class-from-cell (symbol cell &optional (errorp t)) + (or (find-class-cell-class cell) + (and *create-classes-from-internal-structure-definitions-p* + (structure-type-p symbol) + (find-structure-class symbol)) + (cond ((null errorp) nil) + ((legal-class-name-p symbol) + (error "No class named: ~S." symbol)) + (t + (error "~S is not a legal class name." symbol))))) + +(defun find-class-predicate-from-cell (symbol cell &optional (errorp t)) + (unless (find-class-cell-class cell) + (find-class-from-cell symbol cell errorp)) + (find-class-cell-predicate cell)) + +(defun legal-class-name-p (x) + (and (symbolp x) + (not (keywordp x)))) + +(defun find-class (symbol &optional (errorp t) environment) + (declare (ignore environment)) + (find-class-from-cell + symbol (find-class-cell symbol errorp) errorp)) + +(defun find-class-predicate (symbol &optional (errorp t) environment) + (declare (ignore environment)) + (find-class-predicate-from-cell + symbol (find-class-cell symbol errorp) errorp)) + +(defvar *boot-state* nil) ; duplicate defvar to defs.lisp + +; Use this definition in any CL implementation supporting +; both define-compiler-macro and load-time-value. +#+cmu ; Note that in CMU, lisp:find-class /= pcl:find-class +(define-compiler-macro find-class (&whole form + symbol &optional (errorp t) environment) + (declare (ignore environment)) + (if (and (constantp symbol) + (legal-class-name-p (eval symbol)) + (constantp errorp) + (member *boot-state* '(braid complete))) + (let ((symbol (eval symbol)) + (errorp (not (null (eval errorp)))) + (class-cell (make-symbol "CLASS-CELL"))) + `(let ((,class-cell (load-time-value (find-class-cell ',symbol)))) + (or (find-class-cell-class ,class-cell) + #-cmu17 + (find-class-from-cell ',symbol ,class-cell ,errorp) + #+cmu17 + ,(if errorp + `(find-class-from-cell ',symbol ,class-cell t) + `(and (kernel:class-cell-class + ',(kernel:find-class-cell symbol)) + (find-class-from-cell ',symbol ,class-cell nil)))))) + form)) + +#-setf +(defsetf find-class (symbol &optional (errorp t) environment) (new-value) + (declare (ignore errorp environment)) + `(SETF\ PCL\ FIND-CLASS ,new-value ,symbol)) + +(defun #-setf SETF\ PCL\ FIND-CLASS #+setf (setf find-class) (new-value symbol) + (if (legal-class-name-p symbol) + (let ((cell (find-class-cell symbol))) + (setf (find-class-cell-class cell) new-value) + (when (or (eq *boot-state* 'complete) + (eq *boot-state* 'braid)) + #+cmu17 + (let ((lclass (kernel:layout-class (class-wrapper new-value)))) + (setf (lisp:class-name lclass) (class-name new-value)) + (unless (eq (lisp:find-class symbol nil) lclass) + (setf (lisp:find-class symbol) lclass))) + + (setf (find-class-cell-predicate cell) + (symbol-function (class-predicate-name new-value))) + (when (and new-value (not (forward-referenced-class-p new-value))) + + (dolist (keys+aok (find-class-cell-make-instance-function-keys cell)) + (update-initialize-info-internal + (initialize-info new-value (car keys+aok) nil (cdr keys+aok)) + 'make-instance-function))))) + (error "~S is not a legal class name." symbol))) + +#-setf +(defsetf find-class-predicate (symbol &optional (errorp t) environment) (new-value) + (declare (ignore errorp environment)) + `(SETF\ PCL\ FIND-CLASS-PREDICATE ,new-value ,symbol)) + +(defun #-setf SETF\ PCL\ FIND-CLASS-PREDICATE #+setf (setf find-class-predicate) + (new-value symbol) + (if (legal-class-name-p symbol) + (setf (find-class-cell-predicate (find-class-cell symbol)) new-value) + (error "~S is not a legal class name." symbol))) + +(defun find-wrapper (symbol) + (class-wrapper (find-class symbol))) + +#|| ; Anything that used this should use eval instead. +(defun reduce-constant (old) + (let ((new (eval old))) + (if (eq new old) + new + (if (constantp new) + (reduce-constant new) + new)))) +||# + +(defmacro gathering1 (gatherer &body body) + `(gathering ((.gathering1. ,gatherer)) + (macrolet ((gather1 (x) `(gather ,x .gathering1.))) + ,@body))) + +;;; +;;; +;;; +(defmacro vectorizing (&key (size 0)) + `(let* ((limit ,size) + (result (make-array limit)) + (index 0)) + (values #'(lambda (value) + (if (= index limit) + (error "vectorizing more elements than promised.") + (progn + (setf (svref result index) value) + (incf index) + value))) + #'(lambda () result)))) + +;;; +;;; These are augmented definitions of list-elements and list-tails from +;;; iterate.lisp. These versions provide the extra :by keyword which can +;;; be used to specify the step function through the list. +;;; +(defmacro *list-elements (list &key (by #'cdr)) + `(let ((tail ,list)) + #'(lambda (finish) + (if (endp tail) + (funcall finish) + (prog1 (car tail) + (setq tail (funcall ,by tail))))))) + +(defmacro *list-tails (list &key (by #'cdr)) + `(let ((tail ,list)) + #'(lambda (finish) + (prog1 (if (endp tail) + (funcall finish) + tail) + (setq tail (funcall ,by tail)))))) + +(defmacro function-funcall (form &rest args) + #-cmu `(funcall ,form ,@args) + #+cmu `(funcall (the function ,form) ,@args)) + +(defmacro function-apply (form &rest args) + #-cmu `(apply ,form ,@args) + #+cmu `(apply (the function ,form) ,@args)) + + +;;; +;;; Convert a function name to its standard setf function name. We have to +;;; do this hack because not all Common Lisps have yet converted to having +;;; setf function specs. +;;; +;;; In a port that does have setf function specs you can use those just by +;;; making the obvious simple changes to these functions. The rest of PCL +;;; believes that there are function names like (SETF ), this is the +;;; only place that knows about this hack. +;;; +(eval-when (compile load eval) +; In 15e (and also 16c), using the built in setf mechanism costs +; a hash table lookup every time a setf function is called. +; Uncomment the next line to use the built in setf mechanism. +;#+cmu (pushnew :setf *features*) +) + +(eval-when (compile load eval) + +#-setf +(defvar *setf-function-names* (make-hash-table :size 200 :test #'eq)) + +(defun get-setf-function-name (name) + #+setf `(setf ,name) + #-setf + (or (gethash name *setf-function-names*) + (setf (gethash name *setf-function-names*) + (let ((pkg (symbol-package name))) + (if pkg + (intern (format nil + "SETF ~A ~A" + (package-name pkg) + (symbol-name name)) + *the-pcl-package*) + (make-symbol (format nil "SETF ~A" (symbol-name name)))))))) + +;;; +;;; Call this to define a setf macro for a function with the same behavior as +;;; specified by the SETF function cleanup proposal. Specifically, this will +;;; cause: (SETF (FOO a b) x) to expand to (|SETF FOO| x a b). +;;; +;;; do-standard-defsetf A macro interface for use at top level +;;; in files. Unfortunately, users may +;;; have to use this for a while. +;;; +;;; do-standard-defsetfs-for-defclass A special version called by defclass. +;;; +;;; do-standard-defsetf-1 A functional interface called by the +;;; above, defmethod and defgeneric. +;;; Since this is all a crock anyways, +;;; users are free to call this as well. +;;; +(defmacro do-standard-defsetf (&rest function-names) + `(eval-when (compile load eval) + (dolist (fn-name ',function-names) (do-standard-defsetf-1 fn-name)))) + +(defun do-standard-defsetfs-for-defclass (accessors) + (dolist (name accessors) (do-standard-defsetf-1 name))) + +(defun do-standard-defsetf-1 (function-name) + #+setf + (declare (ignore function-name)) + #+setf nil + #-setf + (unless (and (setfboundp function-name) + (get function-name 'standard-setf)) + (setf (get function-name 'standard-setf) t) + (let* ((setf-function-name (get-setf-function-name function-name))) + + #+Genera + (let ((fn #'(lambda (form) + (lt::help-defsetf + '(&rest accessor-args) '(new-value) function-name 'nil + `(`(,',setf-function-name ,new-value .,accessor-args)) + form)))) + (setf (get function-name 'lt::setf-method) fn + (get function-name 'lt::setf-method-internal) fn)) + + #+Lucid + (lucid::set-simple-setf-method + function-name + #'(lambda (form new-value) + (let* ((bindings (mapcar #'(lambda (x) `(,(gensym) ,x)) + (cdr form))) + (vars (mapcar #'car bindings))) + ;; This may wrap spurious LET bindings around some form, + ;; but the PQC compiler will unwrap then. + `(LET (,.bindings) + (,setf-function-name ,new-value . ,vars))))) + + #+kcl + (let ((helper (gensym))) + (setf (macro-function helper) + #'(lambda (form env) + (declare (ignore env)) + (let* ((loc-args (butlast (cdr form))) + (bindings (mapcar #'(lambda (x) `(,(gensym) ,x)) loc-args)) + (vars (mapcar #'car bindings))) + `(let ,bindings + (,setf-function-name ,(car (last form)) ,@vars))))) + (eval `(defsetf ,function-name ,helper))) + #+Xerox + (flet ((setf-expander (body env) + (declare (ignore env)) + (let ((temps + (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) + (cdr body))) + (forms (cdr body)) + (vars (list (gensym)))) + (values temps + forms + vars + `(,setf-function-name ,@vars ,@temps) + `(,function-name ,@temps))))) + (let ((setf-method-expander (intern (concatenate 'string + (symbol-name function-name) + "-setf-expander") + (symbol-package function-name)))) + (setf (get function-name :setf-method-expander) setf-method-expander + (symbol-function setf-method-expander) #'setf-expander))) + + #-(or Genera Lucid kcl Xerox) + (eval `(defsetf ,function-name (&rest accessor-args) (new-value) + (let* ((bindings (mapcar #'(lambda (x) `(,(gensym) ,x)) accessor-args)) + (vars (mapcar #'car bindings))) + `(let ,bindings + (,',setf-function-name ,new-value ,@vars))))) + + ))) + +(defun setfboundp (symbol) + #+Genera (not (null (get-properties (symbol-plist symbol) + 'lt::(derived-setf-function trivial-setf-method + setf-equivalence setf-method)))) + #+Lucid (locally + (declare (special lucid::*setf-inverse-table* + lucid::*simple-setf-method-table* + lucid::*setf-method-expander-table*)) + (or (gethash symbol lucid::*setf-inverse-table*) + (gethash symbol lucid::*simple-setf-method-table*) + (gethash symbol lucid::*setf-method-expander-table*))) + #+kcl (or (get symbol 'si::setf-method) + (get symbol 'si::setf-update-fn) + (get symbol 'si::setf-lambda)) + #+Xerox (or (get symbol :setf-inverse) + (get symbol 'il:setf-inverse) + (get symbol 'il:setfn) + (get symbol :shared-setf-inverse) + (get symbol :setf-method-expander) + (get symbol 'il:setf-method-expander)) + #+:coral (or (get symbol 'ccl::setf-inverse) + (get symbol 'ccl::setf-method-expander)) + #+cmu (fboundp `(setf ,symbol)) + #-(or Genera Lucid KCL Xerox :coral cmu) nil) + +);eval-when + + +;;; +;;; PCL, like user code, must endure the fact that we don't have a properly +;;; working setf. Many things work because they get mentioned by a defclass +;;; or defmethod before they are used, but others have to be done by hand. +;;; +(do-standard-defsetf + class-wrapper ;*** + generic-function-name + method-function-plist + method-function-get + plist-value + object-plist + gdefinition + slot-value-using-class + ) + +(defsetf slot-value set-slot-value) + +(defvar *redefined-functions* nil) + +(defmacro original-definition (name) + `(get ,name 'definition-before-pcl)) + +(defun redefine-function (name new) + (pushnew name *redefined-functions*) + (unless (original-definition name) + (setf (original-definition name) + (symbol-function name))) + (setf (symbol-function name) + (symbol-function new))) + diff --git a/pcl/gcl_pcl_methods.lisp b/pcl/gcl_pcl_methods.lisp new file mode 100644 index 0000000..a8ec01a --- /dev/null +++ b/pcl/gcl_pcl_methods.lisp @@ -0,0 +1,1646 @@ +;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; + +(in-package :pcl) + +(defmethod print-object (instance stream) + (printing-random-thing (instance stream) + (let ((name (class-name (class-of instance)))) + (if name + (format stream "~S" name) + (format stream "Instance"))))) + +(defmethod print-object ((class class) stream) + (named-object-print-function class stream)) + +(defmethod print-object ((slotd slot-definition) stream) + (named-object-print-function slotd stream)) + +(defun named-object-print-function (instance stream + &optional (extra nil extra-p)) + (printing-random-thing (instance stream) + (if extra-p + (format stream "~A ~S ~:S" + (capitalize-words (class-name (class-of instance))) + (slot-value-or-default instance 'name) + extra) + (format stream "~A ~S" + (capitalize-words (class-name (class-of instance))) + (slot-value-or-default instance 'name))))) + +(defmethod print-object ((mc standard-method-combination) stream) + (printing-random-thing (mc stream) + (format stream + "Method-Combination ~S ~S" + (slot-value-or-default mc 'type) + (slot-value-or-default mc 'options)))) + + +;;; +;;; +;;; +(defmethod shared-initialize :after ((slotd standard-slot-definition) slot-names &key) + (declare (ignore slot-names)) + (with-slots (allocation class) + slotd + (setq allocation (if (eq allocation :class) class allocation)))) + +(defmethod shared-initialize :after ((slotd structure-slot-definition) slot-names + &key (allocation :instance)) + (declare (ignore slot-names)) + (unless (eq allocation :instance) + (error "structure slots must have :instance allocation"))) + +(defmethod inform-type-system-about-class ((class structure-class) (name t)) + nil) + +;;; +;;; METHODS +;;; +;;; Methods themselves are simple inanimate objects. Most properties of +;;; methods are immutable, methods cannot be reinitialized. The following +;;; properties of methods can be changed: +;;; METHOD-GENERIC-FUNCTION +;;; METHOD-FUNCTION ?? +;;; +;;; + +(defmethod method-function ((method standard-method)) + (or (slot-value method 'function) + (let ((fmf (slot-value method 'fast-function))) + (unless fmf ; the :before shared-initialize method prevents this + (error "~S doesn't seem to have a method-function" method)) + (setf (slot-value method 'function) + (method-function-from-fast-function fmf))))) + +(defmethod accessor-method-class ((method standard-accessor-method)) + (car (slot-value method 'specializers))) + +(defmethod accessor-method-class ((method standard-writer-method)) + (cadr (slot-value method 'specializers))) + +(defmethod print-object ((method standard-method) stream) + (printing-random-thing (method stream) + (if (slot-boundp method 'generic-function) + (let ((generic-function (method-generic-function method)) + (class-name (capitalize-words (class-name (class-of method))))) + (format stream "~A ~S ~{~S ~}~:S" + class-name + (and generic-function (generic-function-name generic-function)) + (method-qualifiers method) + (unparse-specializers method))) + (call-next-method)))) + +(defmethod print-object ((method standard-accessor-method) stream) + (printing-random-thing (method stream) + (if (slot-boundp method 'generic-function) + (let ((generic-function (method-generic-function method)) + (class-name (capitalize-words (class-name (class-of method))))) + (format stream "~A ~S, slot:~S, ~:S" + class-name + (and generic-function (generic-function-name generic-function)) + (accessor-method-slot-name method) + (unparse-specializers method))) + (call-next-method)))) + +;;; +;;; INITIALIZATION +;;; +;;; Error checking is done in before methods. Because of the simplicity of +;;; standard method objects the standard primary method can fill the slots. +;;; +;;; Methods are not reinitializable. +;;; + +(defmethod reinitialize-instance ((method standard-method) &rest initargs) + (declare (ignore initargs)) + (error "Attempt to reinitialize the method ~S.~%~ + Method objects cannot be reinitialized." + method)) + +(defmethod legal-documentation-p ((object standard-method) x) + (if (or (null x) (stringp x)) + t + "a string or NULL")) + +(defmethod legal-lambda-list-p ((object standard-method) x) + (declare (ignore x)) + t) + +(defmethod legal-method-function-p ((object standard-method) x) + (if (functionp x) + t + "a function")) + +(defmethod legal-qualifiers-p ((object standard-method) x) + (flet ((improper-list () + (return-from legal-qualifiers-p "Is not a proper list."))) + (dolist-carefully (q x improper-list) + (let ((ok (legal-qualifier-p object q))) + (unless (eq ok t) + (return-from legal-qualifiers-p + (format nil "Contains ~S which ~A" q ok))))) + t)) + +(defmethod legal-qualifier-p ((object standard-method) x) + (if (and x (atom x)) + t + "is not a non-null atom")) + +(defmethod legal-slot-name-p ((object standard-method) x) + (cond ((not (symbolp x)) "is not a symbol and so cannot be bound") + ((keywordp x) "is a keyword and so cannot be bound") + ((memq x '(t nil)) "cannot be bound") + ((constantp x) "is a constant and so cannot be bound") + (t t))) + +(defmethod legal-specializers-p ((object standard-method) x) + (flet ((improper-list () + (return-from legal-specializers-p "Is not a proper list."))) + (dolist-carefully (s x improper-list) + (let ((ok (legal-specializer-p object s))) + (unless (eq ok t) + (return-from legal-specializers-p + (format nil "Contains ~S which ~A" s ok))))) + t)) + +(defvar *allow-experimental-specializers-p* nil) + +(defmethod legal-specializer-p ((object standard-method) x) + (if (if *allow-experimental-specializers-p* + (specializerp x) + (or (classp x) + (eql-specializer-p x))) + t + "is neither a class object nor an eql specializer")) + +(defmethod shared-initialize :before ((method standard-method) + slot-names + &key qualifiers + lambda-list + specializers + function + fast-function + documentation) + (declare (ignore slot-names)) + (flet ((lose (initarg value string) + (error "When initializing the method ~S:~%~ + The ~S initialization argument was: ~S.~%~ + which ~A." + method initarg value string))) + (let ((check-qualifiers (legal-qualifiers-p method qualifiers)) + (check-lambda-list (legal-lambda-list-p method lambda-list)) + (check-specializers (legal-specializers-p method specializers)) + (check-function (legal-method-function-p method (or function + fast-function))) + (check-documentation (legal-documentation-p method documentation))) + (unless (eq check-qualifiers t) + (lose :qualifiers qualifiers check-qualifiers)) + (unless (eq check-lambda-list t) + (lose :lambda-list lambda-list check-lambda-list)) + (unless (eq check-specializers t) + (lose :specializers specializers check-specializers)) + (unless (eq check-function t) + (lose :function function check-function)) + (unless (eq check-documentation t) + (lose :documentation documentation check-documentation))))) + +(defmethod shared-initialize :before ((method standard-accessor-method) + slot-names + &key slot-name slot-definition) + (declare (ignore slot-names)) + (unless slot-definition + (let ((legalp (legal-slot-name-p method slot-name))) + (unless (eq legalp t) + (error "The value of the :SLOT-NAME initarg ~A." legalp))))) + +(defmethod shared-initialize :after ((method standard-method) slot-names + &rest initargs + &key qualifiers method-spec plist) + (declare (ignore slot-names method-spec plist)) + (initialize-method-function initargs nil method) + (setf (plist-value method 'qualifiers) qualifiers) + #+ignore + (setf (slot-value method 'closure-generator) + (method-function-closure-generator (slot-value method 'function)))) + +(defmethod shared-initialize :after ((method standard-accessor-method) + slot-names + &key) + (declare (ignore slot-names)) + (with-slots (slot-name slot-definition) + method + (unless slot-definition + (let ((class (accessor-method-class method))) + (when (slot-class-p class) + (setq slot-definition (find slot-name (class-direct-slots class) + :key #'slot-definition-name))))) + (when (and slot-definition (null slot-name)) + (setq slot-name (slot-definition-name slot-definition))))) + +(defmethod method-qualifiers ((method standard-method)) + (plist-value method 'qualifiers)) + + + +(defvar *the-class-generic-function* (find-class 'generic-function)) +(defvar *the-class-standard-generic-function* (find-class 'standard-generic-function)) + + + +(defmethod print-object ((generic-function generic-function) stream) + (named-object-print-function + generic-function + stream + (if (slot-boundp generic-function 'methods) + (list (length (generic-function-methods generic-function))) + "?"))) + +(defmethod shared-initialize :before + ((generic-function standard-generic-function) + slot-names + &key (name nil namep) + (lambda-list () lambda-list-p) + argument-precedence-order + declarations + documentation + (method-class nil method-class-supplied-p) + (method-combination nil method-combination-supplied-p)) + (declare (ignore slot-names + declarations argument-precedence-order documentation + lambda-list lambda-list-p)) + + (when namep + (set-function-name generic-function name)) + + (flet ((initarg-error (initarg value string) + (error "When initializing the generic-function ~S:~%~ + The ~S initialization argument was: ~A.~%~ + It must be ~A." + generic-function initarg value string))) + (cond (method-class-supplied-p + (when (symbolp method-class) + (setq method-class (find-class method-class))) + (unless (and (classp method-class) + (*subtypep (class-eq-specializer method-class) + *the-class-method*)) + (initarg-error :method-class + method-class + "a subclass of the class METHOD")) + (setf (slot-value generic-function 'method-class) method-class)) + ((slot-boundp generic-function 'method-class)) + (t + (initarg-error :method-class + "not supplied" + "a subclass of the class METHOD"))) + (cond (method-combination-supplied-p + (unless (method-combination-p method-combination) + (initarg-error :method-combination + method-combination + "a method combination object"))) + ((slot-boundp generic-function 'method-combination)) + (t + (initarg-error :method-combination + "not supplied" + "a method combination object"))))) + + +#|| +(defmethod reinitialize-instance ((generic-function standard-generic-function) + &rest initargs + &key name + lambda-list + argument-precedence-order + declarations + documentation + method-class + method-combination) + (declare (ignore documentation declarations argument-precedence-order + lambda-list name method-class method-combination)) + (macrolet ((add-initarg (check name slot-name) + `(unless ,check + (push (slot-value generic-function ,slot-name) initargs) + (push ,name initargs)))) +; (add-initarg name :name 'name) +; (add-initarg lambda-list :lambda-list 'lambda-list) +; (add-initarg argument-precedence-order +; :argument-precedence-order +; 'argument-precedence-order) +; (add-initarg declarations :declarations 'declarations) +; (add-initarg documentation :documentation 'documentation) +; (add-initarg method-class :method-class 'method-class) +; (add-initarg method-combination :method-combination 'method-combination) + (apply #'call-next-method generic-function initargs))) +||# + + +;;; +;;; These three are scheduled for demolition. +;;; +(defmethod remove-named-method (generic-function-name argument-specifiers + &optional extra) + (let ((generic-function ()) + (method ())) + (cond ((or (null (fboundp generic-function-name)) + (not (generic-function-p + (setq generic-function + (symbol-function generic-function-name))))) + (error "~S does not name a generic-function." + generic-function-name)) + ((null (setq method (get-method generic-function + extra + (parse-specializers + argument-specifiers) + nil))) + (error "There is no method for the generic-function ~S~%~ + which matches the argument-specifiers ~S." + generic-function + argument-specifiers)) + (t + (remove-method generic-function method))))) + +(defun real-add-named-method (generic-function-name + qualifiers + specializers + lambda-list + &rest other-initargs) + #+copy-&rest-arg (setq other-initargs (copy-list other-initargs)) + ;; What about changing the class of the generic-function if there is + ;; one. Whose job is that anyways. Do we need something kind of + ;; like class-for-redefinition? + (let* ((generic-function + (ensure-generic-function generic-function-name)) + (specs (parse-specializers specializers)) +; (existing (get-method generic-function qualifiers specs nil)) + (proto (method-prototype-for-gf generic-function-name)) + (new (apply #'make-instance (class-of proto) + :qualifiers qualifiers + :specializers specs + :lambda-list lambda-list + other-initargs))) +; (when existing (remove-method generic-function existing)) + (add-method generic-function new))) + + +(defun make-specializable (function-name &key (arglist nil arglistp)) + (cond ((not (null arglistp))) + ((not (fboundp function-name))) + ((fboundp 'function-arglist) + ;; function-arglist exists, get the arglist from it. + (setq arglist (function-arglist function-name))) + (t + (error + "The :arglist argument to make-specializable was not supplied~%~ + and there is no version of FUNCTION-ARGLIST defined for this~%~ + port of Portable CommonLoops.~%~ + You must either define a version of FUNCTION-ARGLIST (which~%~ + should be easy), and send it off to the Portable CommonLoops~%~ + people or you should call make-specializable again with the~%~ + :arglist keyword to specify the arglist."))) + (let ((original (and (fboundp function-name) + (symbol-function function-name))) + (generic-function (make-instance 'standard-generic-function + :name function-name)) + (nrequireds 0)) + (if (generic-function-p original) + original + (progn + (dolist (arg arglist) + (if (memq arg lambda-list-keywords) + (return) + (incf nrequireds))) + (setf (gdefinition function-name) generic-function) + (set-function-name generic-function function-name) + (when arglistp + (setf (gf-pretty-arglist generic-function) arglist)) + (when original + (add-named-method function-name + () + (make-list nrequireds :initial-element 't) + arglist + (list :function + #'(lambda (args next-methods) + (declare (ignore next-methods)) + (apply original args))))) + generic-function)))) + + + +(defun real-get-method (generic-function qualifiers specializers + &optional (errorp t)) + (let ((hit + (dolist (method (generic-function-methods generic-function)) + (when (and (equal qualifiers (method-qualifiers method)) + (every #'same-specializer-p specializers + (method-specializers method))) + (return method))))) + (cond (hit hit) + ((null errorp) nil) + (t + (error "No method on ~S with qualifiers ~:S and specializers ~:S." + generic-function qualifiers specializers))))) + + +;;; +;;; Compute various information about a generic-function's arglist by looking +;;; at the argument lists of the methods. The hair for trying not to use +;;; &rest arguments lives here. +;;; The values returned are: +;;; number-of-required-arguments +;;; the number of required arguments to this generic-function's +;;; discriminating function +;;; &rest-argument-p +;;; whether or not this generic-function's discriminating +;;; function takes an &rest argument. +;;; specialized-argument-positions +;;; a list of the positions of the arguments this generic-function +;;; specializes (e.g. for a classical generic-function this is the +;;; list: (1)). +;;; +(defmethod compute-discriminating-function-arglist-info + ((generic-function standard-generic-function)) + ;;(declare (values number-of-required-arguments &rest-argument-p + ;; specialized-argument-postions)) + (let ((number-required nil) + (restp nil) + (specialized-positions ()) + (methods (generic-function-methods generic-function))) + (dolist (method methods) + (multiple-value-setq (number-required restp specialized-positions) + (compute-discriminating-function-arglist-info-internal + generic-function method number-required restp specialized-positions))) + (values number-required restp (sort specialized-positions #'<)))) + +(defun compute-discriminating-function-arglist-info-internal + (generic-function method number-of-requireds restp + specialized-argument-positions) + (declare (ignore generic-function) (type (or null fixnum) number-of-requireds)) + (let ((requireds 0)) + (declare (fixnum requireds)) + ;; Go through this methods arguments seeing how many are required, + ;; and whether there is an &rest argument. + (dolist (arg (method-lambda-list method)) + (cond ((eq arg '&aux) (return)) + ((memq arg '(&optional &rest &key)) + (return (setq restp t))) + ((memq arg lambda-list-keywords)) + (t (incf requireds)))) + ;; Now go through this method's type specifiers to see which + ;; argument positions are type specified. Treat T specially + ;; in the usual sort of way. For efficiency don't bother to + ;; keep specialized-argument-positions sorted, rather depend + ;; on our caller to do that. + (iterate ((type-spec (list-elements (method-specializers method))) + (pos (interval :from 0))) + (unless (eq type-spec *the-class-t*) + (pushnew pos specialized-argument-positions))) + ;; Finally merge the values for this method into the values + ;; for the exisiting methods and return them. Note that if + ;; num-of-requireds is NIL it means this is the first method + ;; and we depend on that. + (values (min (or number-of-requireds requireds) requireds) + (or restp + (and number-of-requireds (/= number-of-requireds requireds))) + specialized-argument-positions))) + +(defun make-discriminating-function-arglist (number-required-arguments restp) + (nconc (gathering ((args (collecting))) + (iterate ((i (interval :from 0 :below number-required-arguments))) + (gather (intern (format nil "Discriminating Function Arg ~D" i)) + args))) + (when restp + `(&rest ,(intern "Discriminating Function &rest Arg"))))) + + +;;; +;;; +;;; + +(defmethod generic-function-lambda-list ((gf generic-function)) + (gf-lambda-list gf)) + +(defmethod gf-fast-method-function-p ((gf standard-generic-function)) + (gf-info-fast-mf-p (slot-value gf 'arg-info))) + +(defmethod initialize-instance :after ((gf standard-generic-function) + &key (lambda-list nil lambda-list-p) + argument-precedence-order) + (with-slots (arg-info) + gf + (if lambda-list-p + (set-arg-info gf + :lambda-list lambda-list + :argument-precedence-order argument-precedence-order) + (set-arg-info gf)) + (when (arg-info-valid-p arg-info) + (update-dfun gf)))) + +(defmethod reinitialize-instance :after ((gf standard-generic-function) + &rest args + &key (lambda-list nil lambda-list-p) + (argument-precedence-order + nil argument-precedence-order-p)) + (with-slots (arg-info) + gf + (if lambda-list-p + (if argument-precedence-order-p + (set-arg-info gf + :lambda-list lambda-list + :argument-precedence-order argument-precedence-order) + (set-arg-info gf + :lambda-list lambda-list)) + (set-arg-info gf)) + (when (and (arg-info-valid-p arg-info) + args + (or lambda-list-p (cddr args))) + (update-dfun gf)))) + +;;; +;;; +;;; + +(proclaim '(special *lazy-dfun-compute-p*)) + +(defun set-methods (gf methods) + (setf (generic-function-methods gf) nil) + (loop (when (null methods) (return gf)) + (real-add-method gf (pop methods) methods))) + +(defun real-add-method (generic-function method &optional skip-dfun-update-p) + (if (method-generic-function method) + (error "The method ~S is already part of the generic~@ + function ~S. It can't be added to another generic~@ + function until it is removed from the first one." + method (method-generic-function method)) + + (let* ((name (generic-function-name generic-function)) + (qualifiers (method-qualifiers method)) + (specializers (method-specializers method)) + (existing (get-method generic-function qualifiers specializers nil))) + ;; + ;; If there is already a method like this one then we must + ;; get rid of it before proceeding. Note that we call the + ;; generic function remove-method to remove it rather than + ;; doing it in some internal way. + ;; + (when existing (remove-method generic-function existing)) + ;; + (setf (method-generic-function method) generic-function) + (pushnew method (generic-function-methods generic-function)) + (dolist (specializer specializers) + (add-direct-method specializer method)) + (set-arg-info generic-function :new-method method) + (unless skip-dfun-update-p + (when (member name + '(make-instance default-initargs + allocate-instance shared-initialize initialize-instance)) + (update-make-instance-function-table (type-class (car specializers)))) + (update-dfun generic-function)) + method))) + +(defun real-remove-method (generic-function method) + (if (neq generic-function (method-generic-function method)) + (error "The method ~S is attached to the generic function~@ + ~S. It can't be removed from the generic function~@ + to which it is not attached." + method (method-generic-function method)) + (let* ((name (generic-function-name generic-function)) + (specializers (method-specializers method)) + (methods (generic-function-methods generic-function)) + (new-methods (remove method methods))) + (setf (method-generic-function method) nil) + (setf (generic-function-methods generic-function) new-methods) + (dolist (specializer (method-specializers method)) + (remove-direct-method specializer method)) + (set-arg-info generic-function) + (when (member name '(make-instance default-initargs + allocate-instance shared-initialize initialize-instance)) + (update-make-instance-function-table (type-class (car specializers)))) + (update-dfun generic-function) + generic-function))) + + +(defun compute-applicable-methods-function (generic-function arguments) + (values (compute-applicable-methods-using-types + generic-function + (types-from-arguments generic-function arguments 'eql)))) + +(defmethod compute-applicable-methods + ((generic-function generic-function) arguments) + (values (compute-applicable-methods-using-types + generic-function + (types-from-arguments generic-function arguments 'eql)))) + +(defmethod compute-applicable-methods-using-classes + ((generic-function generic-function) classes) + (compute-applicable-methods-using-types + generic-function + (types-from-arguments generic-function classes 'class-eq))) + +(defun proclaim-incompatible-superclasses (classes) + (setq classes (mapcar #'(lambda (class) + (if (symbolp class) + (find-class class) + class)) + classes)) + (dolist (class classes) + (dolist (other-class classes) + (unless (eq class other-class) + (pushnew other-class (class-incompatible-superclass-list class)))))) + +(defun superclasses-compatible-p (class1 class2) + (let ((cpl1 (class-precedence-list class1)) + (cpl2 (class-precedence-list class2))) + (dolist (sc1 cpl1 t) + (dolist (ic (class-incompatible-superclass-list sc1)) + (when (memq ic cpl2) + (return-from superclasses-compatible-p nil)))))) + +(mapc + #'proclaim-incompatible-superclasses + '(;; superclass class + (built-in-class std-class structure-class) ; direct subclasses of pcl-class + (standard-class funcallable-standard-class) + ;; superclass metaobject + (class eql-specializer class-eq-specializer method method-combination + generic-function slot-definition) + ;; metaclass built-in-class + (number sequence character ; direct subclasses of t, but not array + standard-object structure-object) ; or symbol + (number array character symbol ; direct subclasses of t, but not sequence + standard-object structure-object) + (complex float rational) ; direct subclasses of number + (integer ratio) ; direct subclasses of rational + (list vector) ; direct subclasses of sequence + (cons null) ; direct subclasses of list + (string bit-vector) ; direct subclasses of vector + )) + + + + +(defmethod same-specializer-p ((specl1 specializer) (specl2 specializer)) + nil) + +(defmethod same-specializer-p ((specl1 class) (specl2 class)) + (eq specl1 specl2)) + +(defmethod specializer-class ((specializer class)) + specializer) + +(defmethod same-specializer-p ((specl1 class-eq-specializer) + (specl2 class-eq-specializer)) + (eq (specializer-class specl1) (specializer-class specl2))) + +(defmethod same-specializer-p ((specl1 eql-specializer) + (specl2 eql-specializer)) + (eq (specializer-object specl1) (specializer-object specl2))) + +(defmethod specializer-class ((specializer eql-specializer)) + (class-of (slot-value specializer 'object))) + +(defvar *in-gf-arg-info-p* nil) +(setf (gdefinition 'arg-info-reader) + (let ((mf (initialize-method-function + (make-internal-reader-method-function + 'standard-generic-function 'arg-info) + t))) + #'(lambda (&rest args) (funcall mf args nil)))) + +(defun types-from-arguments (generic-function arguments &optional type-modifier) + (multiple-value-bind (nreq applyp metatypes nkeys arg-info) + (get-generic-function-info generic-function) + (declare (ignore applyp metatypes nkeys)) + (let ((types-rev nil)) + (dotimes (i nreq) + i + (unless arguments + (error "The function ~S requires at least ~D arguments" + (generic-function-name generic-function) + nreq)) + (let ((arg (pop arguments))) + (push (if type-modifier `(,type-modifier ,arg) arg) types-rev))) + (values (nreverse types-rev) arg-info)))) + +(defun get-wrappers-from-classes (nkeys wrappers classes metatypes) + (let* ((w wrappers) (w-tail w) (mt-tail metatypes)) + (dolist (class (if (listp classes) classes (list classes))) + (unless (eq 't (car mt-tail)) + (let ((c-w (class-wrapper class))) + (unless c-w (return-from get-wrappers-from-classes nil)) + (if (eql nkeys 1) + (setq w c-w) + (setf (car w-tail) c-w + w-tail (cdr w-tail))))) + (setq mt-tail (cdr mt-tail))) + w)) + +(defun sdfun-for-caching (gf classes) + (let ((types (mapcar #'class-eq-type classes))) + (multiple-value-bind (methods all-applicable-and-sorted-p) + (compute-applicable-methods-using-types gf types) + (function-funcall (get-secondary-dispatch-function1 + gf methods types nil t all-applicable-and-sorted-p) + nil (mapcar #'class-wrapper classes))))) + +(defun value-for-caching (gf classes) + (let ((methods (compute-applicable-methods-using-types + gf (mapcar #'class-eq-type classes)))) + (method-function-get (or (method-fast-function (car methods)) + (method-function (car methods))) + :constant-value))) + +(defun default-secondary-dispatch-function (generic-function) + #'(lambda (&rest args) + #+copy-&rest-arg (setq args (copy-list args)) + (let ((methods (compute-applicable-methods generic-function args))) + (if methods + (let ((emf (get-effective-method-function generic-function methods))) + (invoke-emf emf args)) + (apply #'no-applicable-method generic-function args))))) + +(defun list-eq (x y) + (loop (when (atom x) (return (eq x y))) + (when (atom y) (return nil)) + (unless (eq (car x) (car y)) (return nil)) + (setq x (cdr x) y (cdr y)))) + +(defvar *std-cam-methods* nil) + +(defun compute-applicable-methods-emf (generic-function) + (if (eq *boot-state* 'complete) + (let* ((cam (gdefinition 'compute-applicable-methods)) + (cam-methods (compute-applicable-methods-using-types + cam (list `(eql ,generic-function) t)))) + (values (get-effective-method-function cam cam-methods) + (list-eq cam-methods + (or *std-cam-methods* + (setq *std-cam-methods* + (compute-applicable-methods-using-types + cam (list `(eql ,cam) t))))))) + (values #'compute-applicable-methods-function t))) + +(defun compute-applicable-methods-emf-std-p (gf) + (gf-info-c-a-m-emf-std-p (gf-arg-info gf))) + +(defvar *old-c-a-m-gf-methods* nil) + +(defun update-all-c-a-m-gf-info (c-a-m-gf) + (let ((methods (generic-function-methods c-a-m-gf))) + (if (and *old-c-a-m-gf-methods* + (every #'(lambda (old-method) + (member old-method methods)) + *old-c-a-m-gf-methods*)) + (let ((gfs-to-do nil) + (gf-classes-to-do nil)) + (dolist (method methods) + (unless (member method *old-c-a-m-gf-methods*) + (let ((specl (car (method-specializers method)))) + (if (eql-specializer-p specl) + (pushnew (specializer-object specl) gfs-to-do) + (pushnew (specializer-class specl) gf-classes-to-do))))) + (map-all-generic-functions + #'(lambda (gf) + (when (or (member gf gfs-to-do) + (dolist (class gf-classes-to-do nil) + (member class (class-precedence-list (class-of gf))))) + (update-c-a-m-gf-info gf))))) + (map-all-generic-functions #'update-c-a-m-gf-info)) + (setq *old-c-a-m-gf-methods* methods))) + +(defun update-gf-info (gf) + (update-c-a-m-gf-info gf) + (update-gf-simple-accessor-type gf)) + +(defun update-c-a-m-gf-info (gf) + (unless (early-gf-p gf) + (multiple-value-bind (c-a-m-emf std-p) + (compute-applicable-methods-emf gf) + (let ((arg-info (gf-arg-info gf))) + (setf (gf-info-static-c-a-m-emf arg-info) c-a-m-emf) + (setf (gf-info-c-a-m-emf-std-p arg-info) std-p))))) + +(defun update-gf-simple-accessor-type (gf) + (let ((arg-info (gf-arg-info gf))) + (setf (gf-info-simple-accessor-type arg-info) + (let* ((methods (generic-function-methods gf)) + (class (and methods (class-of (car methods)))) + (type (and class (cond ((eq class *the-class-standard-reader-method*) + 'reader) + ((eq class *the-class-standard-writer-method*) + 'writer) + ((eq class *the-class-standard-boundp-method*) + 'boundp))))) + (when (and (gf-info-c-a-m-emf-std-p arg-info) + type + (dolist (method (cdr methods) t) + (unless (eq class (class-of method)) (return nil))) + (eq (generic-function-method-combination gf) + *standard-method-combination*)) + type))))) + +(defun get-accessor-method-function (gf type class slotd) + (let* ((std-method (standard-svuc-method type)) + (str-method (structure-svuc-method type)) + (types1 `((eql ,class) (class-eq ,class) (eql ,slotd))) + (types (if (eq type 'writer) `(t ,@types1) types1)) + (methods (compute-applicable-methods-using-types gf types)) + (std-p (null (cdr methods)))) + (values + (if std-p + (get-optimized-std-accessor-method-function class slotd type) + (get-accessor-from-svuc-method-function + class slotd + (get-secondary-dispatch-function + gf methods types + `((,(car (or (member std-method methods) + (member str-method methods) + (error "error in get-accessor-method-function"))) + ,(get-optimized-std-slot-value-using-class-method-function + class slotd type))) + (unless (and (eq type 'writer) + (dolist (method methods t) + (unless (eq (car (method-specializers method)) + *the-class-t*) + (return nil)))) + (let ((wrappers (list (wrapper-of class) + (class-wrapper class) + (wrapper-of slotd)))) + (if (eq type 'writer) + (cons (class-wrapper *the-class-t*) wrappers) + wrappers)))) + type)) + std-p))) + +;used by optimize-slot-value-by-class-p (vector.lisp) +(defun update-slot-value-gf-info (gf type) + (unless *new-class* + (update-std-or-str-methods gf type)) + (when (and (standard-svuc-method type) (structure-svuc-method type)) + (flet ((update-class (class) + (when (class-finalized-p class) + (dolist (slotd (class-slots class)) + (compute-slot-accessor-info slotd type gf))))) + (if *new-class* + (update-class *new-class*) + (map-all-classes #'update-class 'slot-object))))) + +(defvar *standard-slot-value-using-class-method* nil) +(defvar *standard-setf-slot-value-using-class-method* nil) +(defvar *standard-slot-boundp-using-class-method* nil) +(defvar *structure-slot-value-using-class-method* nil) +(defvar *structure-setf-slot-value-using-class-method* nil) +(defvar *structure-slot-boundp-using-class-method* nil) + +(defun standard-svuc-method (type) + (case type + (reader *standard-slot-value-using-class-method*) + (writer *standard-setf-slot-value-using-class-method*) + (boundp *standard-slot-boundp-using-class-method*))) + +(defun set-standard-svuc-method (type method) + (case type + (reader (setq *standard-slot-value-using-class-method* method)) + (writer (setq *standard-setf-slot-value-using-class-method* method)) + (boundp (setq *standard-slot-boundp-using-class-method* method)))) + +(defun structure-svuc-method (type) + (case type + (reader *structure-slot-value-using-class-method*) + (writer *structure-setf-slot-value-using-class-method*) + (boundp *structure-slot-boundp-using-class-method*))) + +(defun set-structure-svuc-method (type method) + (case type + (reader (setq *structure-slot-value-using-class-method* method)) + (writer (setq *structure-setf-slot-value-using-class-method* method)) + (boundp (setq *structure-slot-boundp-using-class-method* method)))) + +(defun update-std-or-str-methods (gf type) + (dolist (method (generic-function-methods gf)) + (let ((specls (method-specializers method))) + (when (and (or (not (eq type 'writer)) + (eq (pop specls) *the-class-t*)) + (every #'classp specls)) + (cond ((and (eq (class-name (car specls)) + 'std-class) + (eq (class-name (cadr specls)) + 'standard-object) + (eq (class-name (caddr specls)) + 'standard-effective-slot-definition)) + (set-standard-svuc-method type method)) + ((and (eq (class-name (car specls)) + 'structure-class) + (eq (class-name (cadr specls)) + 'structure-object) + (eq (class-name (caddr specls)) + 'structure-effective-slot-definition)) + (set-structure-svuc-method type method))))))) + +(defun mec-all-classes-internal (spec precompute-p) + (cons (specializer-class spec) + (and (classp spec) + precompute-p + (not (or (eq spec *the-class-t*) + (eq spec *the-class-slot-object*) + (eq spec *the-class-standard-object*) + (eq spec *the-class-structure-object*))) + (let ((sc (class-direct-subclasses spec))) + (when sc + (mapcan #'(lambda (class) + (mec-all-classes-internal class precompute-p)) + sc)))))) + +(defun mec-all-classes (spec precompute-p) + (let ((classes (mec-all-classes-internal spec precompute-p))) + (if (null (cdr classes)) + classes + (let* ((a-classes (cons nil classes)) + (tail classes)) + (loop (when (null (cdr tail)) + (return (cdr a-classes))) + (let ((class (cadr tail)) + (ttail (cddr tail))) + (if (dolist (c ttail nil) + (when (eq class c) (return t))) + (setf (cdr tail) (cddr tail)) + (setf tail (cdr tail))))))))) + +(defun mec-all-class-lists (spec-list precompute-p) + (if (null spec-list) + (list nil) + (let* ((car-all-classes (mec-all-classes (car spec-list) precompute-p)) + (all-class-lists (mec-all-class-lists (cdr spec-list) precompute-p))) + (mapcan #'(lambda (list) + (mapcar #'(lambda (c) (cons c list)) car-all-classes)) + all-class-lists)))) + +(defun make-emf-cache (generic-function valuep cache classes-list new-class) + (let* ((arg-info (gf-arg-info generic-function)) + (nkeys (arg-info-nkeys arg-info)) + (metatypes (arg-info-metatypes arg-info)) + (wrappers (unless (eq nkeys 1) (make-list nkeys))) + (precompute-p (gf-precompute-dfun-and-emf-p arg-info)) + (default '(default))) + (flet ((add-class-list (classes) + (when (or (null new-class) (memq new-class classes)) + (let ((wrappers (get-wrappers-from-classes + nkeys wrappers classes metatypes))) + (when (and wrappers + (eq default (probe-cache cache wrappers default))) + (let ((value (cond ((eq valuep t) + (sdfun-for-caching generic-function classes)) + ((eq valuep :constant-value) + (value-for-caching generic-function classes))))) + (setq cache (fill-cache cache wrappers value t)))))))) + (if classes-list + (mapc #'add-class-list classes-list) + (dolist (method (generic-function-methods generic-function)) + (mapc #'add-class-list + (mec-all-class-lists (method-specializers method) precompute-p)))) + cache))) + +(defmacro class-test (arg class) + (cond ((eq class *the-class-t*) + 't) + ((eq class *the-class-slot-object*) + #-(or new-kcl-wrapper cmu17) + `(not (eq *the-class-built-in-class* + (wrapper-class (std-instance-wrapper (class-of ,arg))))) + #+new-kcl-wrapper + `(or (std-instance-p ,arg) + (fsc-instance-p ,arg)) + #+cmu17 + `(not (lisp:typep (lisp:class-of ,arg) 'lisp:built-in-class))) + #-new-kcl-wrapper + ((eq class *the-class-standard-object*) + `(or (std-instance-p ,arg) (fsc-instance-p ,arg))) + #-cmu17 + ((eq class *the-class-structure-object*) + `(memq ',class (class-precedence-list (class-of ,arg)))) + ;; TYPEP is now sometimes faster than doing memq of the cpl + (t + `(typep ,arg ',(class-name class))))) + +(defmacro class-eq-test (arg class) + `(eq (class-of ,arg) ',class)) + +(defmacro eql-test (arg object) + `(eql ,arg ',object)) + +(defun dnet-methods-p (form) + (and (consp form) + (or (eq (car form) 'methods) + (eq (car form) 'unordered-methods)))) + +(defmacro scase (arg &rest clauses) ; This is case, but without gensyms + `(let ((.case-arg. ,arg)) + (cond ,@(mapcar #'(lambda (clause) + (list* (cond ((null (car clause)) + nil) + ((consp (car clause)) + (if (null (cdar clause)) + `(eql .case-arg. ',(caar clause)) + `(member .case-arg. ',(car clause)))) + ((member (car clause) '(t otherwise)) + `t) + (t + `(eql .case-arg. ',(car clause)))) + nil + (cdr clause))) + clauses)))) + +(defmacro mcase (arg &rest clauses) `(scase ,arg ,@clauses)) + +(defun generate-discrimination-net (generic-function methods types sorted-p) + (let* ((arg-info (gf-arg-info generic-function)) + (precedence (arg-info-precedence arg-info))) + (generate-discrimination-net-internal + generic-function methods types + #'(lambda (methods known-types) + (if (or sorted-p + (block one-order-p + (let ((sorted-methods nil)) + (map-all-orders + (copy-list methods) precedence + #'(lambda (methods) + (when sorted-methods (return-from one-order-p nil)) + (setq sorted-methods methods))) + (setq methods sorted-methods)) + t)) + `(methods ,methods ,known-types) + `(unordered-methods ,methods ,known-types))) + #'(lambda (position type true-value false-value) + (let ((arg (dfun-arg-symbol position))) + (if (eq (car type) 'eql) + (let* ((false-case-p (and (consp false-value) + (or (eq (car false-value) 'scase) + (eq (car false-value) 'mcase)) + (eq arg (cadr false-value)))) + (false-clauses (if false-case-p + (cddr false-value) + `((t ,false-value)))) + (case-sym (if (and (dnet-methods-p true-value) + (if false-case-p + (eq (car false-value) 'mcase) + (dnet-methods-p false-value))) + 'mcase + 'scase)) + (type-sym `(,(cadr type)))) + `(,case-sym ,arg + (,type-sym ,true-value) + ,@false-clauses)) + `(if ,(let ((arg (dfun-arg-symbol position))) + (case (car type) + (class `(class-test ,arg ,(cadr type))) + (class-eq `(class-eq-test ,arg ,(cadr type))))) + ,true-value + ,false-value)))) + #'identity))) + +(defun class-from-type (type) + (if (or (atom type) (eq (car type) 't)) + *the-class-t* + (case (car type) + (and (dolist (type (cdr type) *the-class-t*) + (when (and (consp type) (not (eq (car type) 'not))) + (return (class-from-type type))))) + (not *the-class-t*) + (eql (class-of (cadr type))) + (class-eq (cadr type)) + (class (cadr type))))) + +(defun precompute-effective-methods (gf caching-p &optional classes-list-p) + (let* ((arg-info (gf-arg-info gf)) + (methods (generic-function-methods gf)) + (precedence (arg-info-precedence arg-info)) + (*in-precompute-effective-methods-p* t) + (classes-list nil)) + (generate-discrimination-net-internal + gf methods nil + #'(lambda (methods known-types) + (when methods + (when classes-list-p + (push (mapcar #'class-from-type known-types) classes-list)) + (let ((no-eql-specls-p (not (methods-contain-eql-specializer-p methods)))) + (map-all-orders + methods precedence + #'(lambda (methods) + (get-secondary-dispatch-function1 + gf methods known-types + nil caching-p no-eql-specls-p)))))) + #'(lambda (position type true-value false-value) + (declare (ignore position type true-value false-value)) + nil) + #'(lambda (type) + (if (and (consp type) (eq (car type) 'eql)) + `(class-eq ,(class-of (cadr type))) + type))) + classes-list)) + +; we know that known-type implies neither new-type nor `(not ,new-type) +(defun augment-type (new-type known-type) + (if (or (eq known-type 't) + (eq (car new-type) 'eql)) + new-type + (let ((so-far (if (and (consp known-type) (eq (car known-type) 'and)) + (cdr known-type) + (list known-type)))) + (unless (eq (car new-type) 'not) + (setq so-far + (mapcan #'(lambda (type) + (unless (*subtypep new-type type) + (list type))) + so-far))) + (if (null so-far) + new-type + `(and ,new-type ,@so-far))))) + +#+lcl3.0 (dont-use-production-compiler) + +(defun generate-discrimination-net-internal + (gf methods types methods-function test-function type-function) + #+cmu + (declare (type function methods-function test-function type-function)) + (let* ((arg-info (gf-arg-info gf)) + (precedence (arg-info-precedence arg-info)) + (nreq (arg-info-number-required arg-info)) + (metatypes (arg-info-metatypes arg-info))) + (labels ((do-column (p-tail contenders known-types) + (if p-tail + (let* ((position (car p-tail)) + (known-type (or (nth position types) t))) + (if (eq (nth position metatypes) 't) + (do-column (cdr p-tail) contenders + (cons (cons position known-type) known-types)) + (do-methods p-tail contenders + known-type () known-types))) + (funcall methods-function contenders + (let ((k-t (make-list nreq))) + (dolist (index+type known-types) + (setf (nth (car index+type) k-t) (cdr index+type))) + k-t)))) + (do-methods (p-tail contenders known-type winners known-types) + ;; + ;; + ;; is a (sorted) list of methods that must be discriminated + ;; + ;; is the type of this argument, constructed from tests already made. + ;; + ;; is a (sorted) list of methods that are potentially applicable + ;; after the discrimination has been made. + ;; + (if (null contenders) + (do-column (cdr p-tail) winners + (cons (cons (car p-tail) known-type) known-types)) + (let* ((position (car p-tail)) + (method (car contenders)) + (specl (nth position (method-specializers method))) + (type (funcall type-function (type-from-specializer specl)))) + (multiple-value-bind (app-p maybe-app-p) + (specializer-applicable-using-type-p type known-type) + (flet ((determined-to-be (truth-value) + (if truth-value app-p (not maybe-app-p))) + (do-if (truth &optional implied) + (let ((ntype (if truth type `(not ,type)))) + (do-methods p-tail + (cdr contenders) + (if implied + known-type + (augment-type ntype known-type)) + (if truth + (append winners `(,method)) + winners) + known-types)))) + (cond ((determined-to-be nil) (do-if nil t)) + ((determined-to-be t) (do-if t t)) + (t (funcall test-function position type + (do-if t) (do-if nil)))))))))) + (do-column precedence methods ())))) + +#+lcl3.0 (use-previous-compiler) + +(defun compute-secondary-dispatch-function (generic-function net &optional + method-alist wrappers) + (function-funcall (compute-secondary-dispatch-function1 generic-function net) + method-alist wrappers)) + +(defvar *eq-case-table-limit* 15) +(defvar *case-table-limit* 10) + +(defun compute-mcase-parameters (case-list) + (unless (eq 't (caar (last case-list))) + (error "The key for the last case arg to mcase was not T")) + (let* ((eq-p (dolist (case case-list t) + (unless (or (eq (car case) 't) + (symbolp (caar case))) + (return nil)))) + (len (1- (length case-list))) + (type (cond ((= len 1) + :simple) + ((<= len + (if eq-p + *eq-case-table-limit* + *case-table-limit*)) + :assoc) + (t + :hash-table)))) + (list eq-p type))) + +(defmacro mlookup (key info default &optional eq-p type) + (unless (or (eq eq-p 't) (null eq-p)) + (error "Invalid eq-p argument")) + (ecase type + (:simple + `(if (,(if eq-p 'eq 'eql) ,key (car ,info)) + (cdr ,info) + ,default)) + (:assoc + `(dolist (e ,info ,default) + (when (,(if eq-p 'eq 'eql) (car e) ,key) + (return (cdr e))))) + (:hash-table + `(gethash ,key ,info ,default)))) + +(defun net-test-converter (form) + (if (atom form) + (default-test-converter form) + (case (car form) + ((invoke-effective-method-function invoke-fast-method-call) + '.call.) + (methods + '.methods.) + (unordered-methods + '.umethods.) + (mcase + `(mlookup ,(cadr form) nil nil ,@(compute-mcase-parameters (cddr form)))) + (t (default-test-converter form))))) + +(defun net-code-converter (form) + (if (atom form) + (default-code-converter form) + (case (car form) + ((methods unordered-methods) + (let ((gensym (gensym))) + (values gensym + (list gensym)))) + (mcase + (let ((mp (compute-mcase-parameters (cddr form))) + (gensym (gensym)) (default (gensym))) + (values `(mlookup ,(cadr form) ,gensym ,default ,@mp) + (list gensym default)))) + (t + (default-code-converter form))))) + +(defun net-constant-converter (form generic-function) + (or (let ((c (methods-converter form generic-function))) + (when c (list c))) + (if (atom form) + (default-constant-converter form) + (case (car form) + (mcase + (let* ((mp (compute-mcase-parameters (cddr form))) + (list (mapcar #'(lambda (clause) + (let ((key (car clause)) + (meth (cadr clause))) + (cons (if (consp key) (car key) key) + (methods-converter + meth generic-function)))) + (cddr form))) + (default (car (last list)))) + (list (list* ':mcase mp (nbutlast list)) + (cdr default)))) + (t + (default-constant-converter form)))))) + +(defun methods-converter (form generic-function) + (cond ((and (consp form) (eq (car form) 'methods)) + (cons '.methods. + (get-effective-method-function1 generic-function (cadr form)))) + ((and (consp form) (eq (car form) 'unordered-methods)) + (default-secondary-dispatch-function generic-function)))) + +(defun convert-methods (constant method-alist wrappers) + (if (and (consp constant) + (eq (car constant) '.methods.)) + (funcall (the function (cdr constant)) method-alist wrappers) + constant)) + +(defun convert-table (constant method-alist wrappers) + (cond ((and (consp constant) + (eq (car constant) ':mcase)) + (let ((alist (mapcar #'(lambda (k+m) + (cons (car k+m) + (convert-methods (cdr k+m) + method-alist wrappers))) + (cddr constant))) + (mp (cadr constant))) + (ecase (cadr mp) + (:simple + (car alist)) + (:assoc + alist) + (:hash-table + (let ((table (make-hash-table :test (if (car mp) 'eq 'eql)))) + (dolist (k+m alist) + (setf (gethash (car k+m) table) (cdr k+m))) + table))))))) + +(defun compute-secondary-dispatch-function1 (generic-function net + &optional function-p) + (cond + ((and (eq (car net) 'methods) (not function-p)) + (get-effective-method-function1 generic-function (cadr net))) + (t + (let* ((name (generic-function-name generic-function)) + (arg-info (gf-arg-info generic-function)) + (metatypes (arg-info-metatypes arg-info)) + (applyp (arg-info-applyp arg-info)) + (fmc-arg-info (cons (length metatypes) applyp))) + (multiple-value-bind + (cfunction constants) + (get-function1 (make-dispatch-lambda + function-p metatypes applyp + `((locally (declare #.*optimize-speed*) + (let ((emf ,net)) + ,(make-emf-call metatypes applyp 'emf))))) + #'net-test-converter + #'net-code-converter + #'(lambda (form) + (net-constant-converter form generic-function))) + #'(lambda (method-alist wrappers) + (let* ((alist (list nil)) + (alist-tail alist)) + (dolist (constant constants) + (let* ((a (or (dolist (a alist nil) + (when (eq (car a) constant) + (return a))) + (cons constant + (or (convert-table + constant method-alist wrappers) + (convert-methods + constant method-alist wrappers))))) + (new (list a))) + (setf (cdr alist-tail) new) + (setf alist-tail new))) + (let ((function (apply cfunction (mapcar #'cdr (cdr alist))))) + (if function-p + function + (make-fast-method-call + :function (set-function-name function `(sdfun-method ,name)) + :arg-info fmc-arg-info)))))))))) + +(defvar *show-make-unordered-methods-emf-calls* nil) + +(defun make-unordered-methods-emf (generic-function methods) + (when *show-make-unordered-methods-emf-calls* + (format t "~&make-unordered-methods-emf ~s~%" + (generic-function-name generic-function))) + #'(lambda (&rest args) + #+copy-&rest-arg (setq args (copy-list args)) + (let* ((types (types-from-arguments generic-function args 'eql)) + (smethods (sort-applicable-methods generic-function methods types)) + (emf (get-effective-method-function generic-function smethods))) + (invoke-emf emf args)))) + + +;;; +;;; The value returned by compute-discriminating-function is a function +;;; object. It is called a discriminating function because it is called +;;; when the generic function is called and its role is to discriminate +;;; on the arguments to the generic function and then call appropriate +;;; method functions. +;;; +;;; A discriminating function can only be called when it is installed as +;;; the funcallable instance function of the generic function for which +;;; it was computed. +;;; +;;; More precisely, if compute-discriminating-function is called with an +;;; argument , and returns a result , that result must not be +;;; passed to apply or funcall directly. Rather, must be stored as +;;; the funcallable instance function of the same generic function +;;; (using set-funcallable-instance-function). Then the generic function +;;; can be passed to funcall or apply. +;;; +;;; An important exception is that methods on this generic function are +;;; permitted to return a function which itself ends up calling the value +;;; returned by a more specific method. This kind of `encapsulation' of +;;; discriminating function is critical to many uses of the MOP. +;;; +;;; As an example, the following canonical case is legal: +;;; +;;; (defmethod compute-discriminating-function ((gf my-generic-function)) +;;; (let ((std (call-next-method))) +;;; #'(lambda (arg) +;;; (print (list 'call-to-gf gf arg)) +;;; (funcall std arg)))) +;;; +;;; Because many discriminating functions would like to use a dynamic +;;; strategy in which the precise discriminating function changes with +;;; time it is important to specify how a discriminating function is +;;; permitted itself to change the funcallable instance function of the +;;; generic function. +;;; +;;; Discriminating functions may set the funcallable instance function +;;; of the generic function, but the new value must be generated by making +;;; a call to COMPUTE-DISCRIMINATING-FUNCTION. This is to ensure that any +;;; more specific methods which may have encapsulated the discriminating +;;; function will get a chance to encapsulate the new, inner discriminating +;;; function. +;;; +;;; This implies that if a discriminating function wants to modify itself +;;; it should first store some information in the generic function proper, +;;; and then call compute-discriminating-function. The appropriate method +;;; on compute-discriminating-function will see the information stored in +;;; the generic function and generate a discriminating function accordingly. +;;; +;;; The following is an example of a discriminating function which modifies +;;; itself in accordance with this protocol: +;;; +;;; (defmethod compute-discriminating-function ((gf my-generic-function)) +;;; #'(lambda (arg) +;;; (cond ( +;;; +;;; (set-funcallable-instance-function +;;; gf +;;; (compute-discriminating-function gf)) +;;; (funcall gf arg)) +;;; (t +;;; )))) +;;; +;;; Whereas this code would not be legal: +;;; +;;; (defmethod compute-discriminating-function ((gf my-generic-function)) +;;; #'(lambda (arg) +;;; (cond ( +;;; (set-funcallable-instance-function +;;; gf +;;; #'(lambda (a) ..)) +;;; (funcall gf arg)) +;;; (t +;;; )))) +;;; +;;; NOTE: All the examples above assume that all instances of the class +;;; my-generic-function accept only one argument. +;;; +;;; +;;; +;;; +(defun slot-value-using-class-dfun (class object slotd) + (declare (ignore class)) + (function-funcall (slot-definition-reader-function slotd) object)) + +(defun setf-slot-value-using-class-dfun (new-value class object slotd) + (declare (ignore class)) + (function-funcall (slot-definition-writer-function slotd) new-value object)) + +(defun slot-boundp-using-class-dfun (class object slotd) + (declare (ignore class)) + (function-funcall (slot-definition-boundp-function slotd) object)) + +(defmethod compute-discriminating-function ((gf standard-generic-function)) + (with-slots (dfun-state arg-info) gf + (typecase dfun-state + (null (let ((name (generic-function-name gf))) + (when (eq name 'compute-applicable-methods) + (update-all-c-a-m-gf-info gf)) + (cond ((eq name 'slot-value-using-class) + (update-slot-value-gf-info gf 'reader) + #'slot-value-using-class-dfun) + ((equal name '(setf slot-value-using-class)) + (update-slot-value-gf-info gf 'writer) + #'setf-slot-value-using-class-dfun) + ((eq name 'slot-boundp-using-class) + (update-slot-value-gf-info gf 'boundp) + #'slot-boundp-using-class-dfun) + ((gf-precompute-dfun-and-emf-p arg-info) + (make-final-dfun gf)) + (t + (make-initial-dfun gf))))) + (function dfun-state) + (cons (car dfun-state))))) + +(defmethod update-gf-dfun ((class std-class) gf) + (let ((*new-class* class) + #|| (name (generic-function-name gf)) ||# + (arg-info (gf-arg-info gf))) + (cond #|| + ((eq name 'slot-value-using-class) + (update-slot-value-gf-info gf 'reader)) + ((equal name '(setf slot-value-using-class)) + (update-slot-value-gf-info gf 'writer)) + ((eq name 'slot-boundp-using-class) + (update-slot-value-gf-info gf 'boundp)) + ||# + ((gf-precompute-dfun-and-emf-p arg-info) + (multiple-value-bind (dfun cache info) + (make-final-dfun-internal gf) + (set-dfun gf dfun cache info) ; otherwise cache might get freed twice + (update-dfun gf dfun cache info)))))) + +;;; +;;; +;;; +(defmethod function-keywords ((method standard-method)) + (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords) + (analyze-lambda-list (if (consp method) + (early-method-lambda-list method) + (method-lambda-list method))) + (declare (ignore nreq nopt keysp restp)) + (values keywords allow-other-keys-p))) + +(defun method-ll->generic-function-ll (ll) + (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords keyword-parameters) + (analyze-lambda-list ll) + (declare (ignore nreq nopt keysp restp allow-other-keys-p keywords)) + (remove-if #'(lambda (s) + (or (memq s keyword-parameters) + (eq s '&allow-other-keys))) + ll))) + + +;;; +;;; This is based on the rules of method lambda list congruency defined in +;;; the spec. The lambda list it constructs is the pretty union of the +;;; lambda lists of all the methods. It doesn't take method applicability +;;; into account at all yet. +;;; +(defmethod generic-function-pretty-arglist + ((generic-function standard-generic-function)) + (let ((methods (generic-function-methods generic-function)) + (arglist ())) + (when methods + (multiple-value-bind (required optional rest key allow-other-keys) + (method-pretty-arglist (car methods)) + (dolist (m (cdr methods)) + (multiple-value-bind (method-key-keywords + method-allow-other-keys + method-key) + (function-keywords m) + ;; we've modified function-keywords to return what we want as + ;; the third value, no other change here. + (declare (ignore method-key-keywords)) + (setq key (union key method-key)) + (setq allow-other-keys (or allow-other-keys + method-allow-other-keys)))) + (when allow-other-keys + (setq arglist '(&allow-other-keys))) + (when key + (setq arglist (nconc (list '&key) key arglist))) + (when rest + (setq arglist (nconc (list '&rest rest) arglist))) + (when optional + (setq arglist (nconc (list '&optional) optional arglist))) + (nconc required arglist))))) + + +(defmethod method-pretty-arglist ((method standard-method)) + (let ((required ()) + (optional ()) + (rest nil) + (key ()) + (allow-other-keys nil) + (state 'required) + (arglist (method-lambda-list method))) + (dolist (arg arglist) + (cond ((eq arg '&optional) (setq state 'optional)) + ((eq arg '&rest) (setq state 'rest)) + ((eq arg '&key) (setq state 'key)) + ((eq arg '&allow-other-keys) (setq allow-other-keys 't)) + ((memq arg lambda-list-keywords)) + (t + (ecase state + (required (push arg required)) + (optional (push arg optional)) + (key (push arg key)) + (rest (setq rest arg)))))) + (values (nreverse required) + (nreverse optional) + rest + (nreverse key) + allow-other-keys))) + diff --git a/pcl/gcl_pcl_pkg.lisp b/pcl/gcl_pcl_pkg.lisp new file mode 100644 index 0000000..493f8e1 --- /dev/null +++ b/pcl/gcl_pcl_pkg.lisp @@ -0,0 +1,408 @@ +;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; + +(in-package :user) + +;;; From defsys.lisp +(eval-when (compile load eval) + +(if (find-package ':walker) + (use-package '(:lisp) ':walker) + (make-package ':walker :use '(:lisp))) + +(if (find-package ':iterate) + (use-package '(:lisp :walker) ':iterate) + (make-package ':iterate :use '(:lisp :walker))) + +(if (find-package ':pcl) + (use-package '(:walker :iterate :lisp) ':pcl) + (make-package ':pcl :use '(:walker :iterate :lisp))) + +(export (intern (symbol-name :iterate) ;Have to do this here, + (find-package :iterate)) ;because in the defsystem + (find-package :iterate)) ;(later in this file) + ;we use the symbol iterate + ;to name the file +) + +(in-package :walker) + +(export '(define-walker-template + walk-form + walk-form-expand-macros-p + nested-walk-form + variable-lexical-p + variable-special-p + variable-globally-special-p + *variable-declarations* + variable-declaration + macroexpand-all + )) + +(in-package :iterate) + +(export '(iterate iterate* gathering gather with-gathering interval elements + list-elements list-tails plist-elements eachtime while until + collecting joining maximizing minimizing summing + *iterate-warnings*)) + +(in-package :pcl) + +;;; +;;; Some CommonLisps have more symbols in the Lisp package than the ones that +;;; are explicitly specified in CLtL. This causes trouble. Any Lisp that has +;;; extra symbols in the Lisp package should shadow those symbols in the PCL +;;; package. +;;; +#+TI +(shadow '(string-append once-only destructuring-bind + memq assq delq neq true false + without-interrupts + defmethod) + *the-pcl-package*) + +#+CMU +(shadow '(destructuring-bind) + *the-pcl-package*) +#+cmu17 +(shadow '(find-class class-name class-of + class built-in-class structure-class + standard-class) + *the-pcl-package*) + +#+GCLisp +(shadow '(string-append memq assq delq neq make-instance) + *the-pcl-package*) + +(defun use-package-pcl (&optional (*package* *package*)) + (shadowing-import + (let ((*package* *the-pcl-package*)) + (mapcar #'intern + #+cmu17 '("FIND-CLASS" "CLASS-NAME" "CLASS-OF" + "CLASS" "BUILT-IN-CLASS" "STRUCTURE-CLASS" + "STANDARD-CLASS") + #+TI '("DEFMETHOD") + #+GCLisp '("MAKE-INSTANCE") + #-(or cmu17 TI GCLisp) '()))) + (use-package *the-pcl-package*)) + +#+Genera +(shadowing-import '(zl:arglist zwei:indentation) *the-pcl-package*) + +#+Lucid +(import '(#-LCL3.0 system:arglist #+LCL3.0 lcl:arglist + system:structurep system:structure-type system:structure-length) + *the-pcl-package*) + +#+lucid +(#-LCL3.0 progn #+LCL3.0 lcl:handler-bind + #+LCL3.0 ((lcl:warning #'(lambda (condition) + (declare (ignore condition)) + (lcl:muffle-warning)))) +(let ((importer + #+LCL3.0 #'sys:import-from-lucid-pkg + #-LCL3.0 (let ((x (find-symbol "IMPORT-FROM-LUCID-PKG" "LUCID"))) + (if (and x (fboundp x)) + (symbol-function x) + ;; Only the #'(lambda (x) ...) below is really needed, + ;; but when available, the "internal" function + ;; 'import-from-lucid-pkg' provides better checking. + #'(lambda (name) + (import (intern name "LUCID"))))))) + ;; + ;; We need the following "internal", undocumented Lucid goodies: + (mapc importer '("%POINTER" "DEFSTRUCT-SIMPLE-PREDICATE" + #-LCL3.0 "LOGAND&" "%LOGAND&" #+VAX "LOGAND&-VARIABLE")) + + ;; + ;; For without-interrupts. + ;; + #+LCL3.0 + (mapc importer '("*SCHEDULER-WAKEUP*" "MAYBE-CALL-SCHEDULER")) + + ;; + ;; We import the following symbols, because in 2.1 Lisps they have to be + ;; accessed as SYS:, whereas in 3.0 lisps, they are homed in the + ;; LUCID-COMMON-LISP package. + (mapc importer '("ARGLIST" "NAMED-LAMBDA" "*PRINT-STRUCTURE*")) + ;; + ;; We import the following symbols, because in 2.1 Lisps they have to be + ;; accessed as LUCID::, whereas in 3.0 lisps, they have to be + ;; accessed as SYS: + (mapc importer '( + "NEW-STRUCTURE" "STRUCTURE-REF" + "STRUCTUREP" "STRUCTURE-TYPE" "STRUCTURE-LENGTH" + "PROCEDUREP" "PROCEDURE-SYMBOL" + "PROCEDURE-REF" "SET-PROCEDURE-REF" + )) +; ;; +; ;; The following is for the "patch" to the general defstruct printer. +; (mapc importer '( +; "OUTPUT-STRUCTURE" "DEFSTRUCT-INFO" +; "OUTPUT-TERSE-OBJECT" "DEFAULT-STRUCTURE-PRINT" +; "STRUCTURE-TYPE" "*PRINT-OUTPUT*" +; )) + ;; + ;; The following is for a "patch" affecting compilation of %logand&. + ;; On APOLLO, Domain/CommonLISP 2.10 does not include %logand& whereas + ;; Domain/CommonLISP 2.20 does; Domain/CommonLISP 2.20 includes :DOMAIN/OS + ;; on *FEATURES*, so this conditionalizes correctly for APOLLO. + #-(or (and APOLLO DOMAIN/OS) LCL3.0 VAX) + (mapc importer '("COPY-STRUCTURE" "GET-FDESC" "SET-FDESC")) + + nil)) + +#+kcl +(progn +(import '(si:structurep si:structure-def si:structure-ref)) +(shadow 'lisp:dotimes) +) +#+kcl +(in-package "SI") +#+kcl +(export '(%structure-name + %compiled-function-name + %set-compiled-function-name + %instance-ref + %set-instance-ref)) +#+kcl +(in-package 'pcl) + +#+cmu (shadow 'lisp:dotimes) + +#+cmu +(import '(kernel:funcallable-instance-p) + *the-pcl-package*) + + +(shadow 'documentation) + + +;;; +;;; These come from the index pages of 88-002R. +;;; +;;; +(eval-when (compile load eval) + +(defvar *exports* '(add-method + built-in-class + call-method + call-next-method + change-class + class-name + classp + class-of + compute-applicable-methods + defclass + defgeneric + define-method-combination + defmethod + ensure-generic-function + find-class + find-method + function-keywords + generic-flet + generic-labels + initialize-instance + invalid-method-error + make-instance + make-instances-obsolete + method-combination-error + method-qualifiers + next-method-p + no-applicable-method + no-next-method + print-object + reinitialize-instance + remove-method + shared-initialize + slot-boundp + slot-exists-p + slot-makunbound + slot-missing + slot-unbound + slot-value + standard + standard-class + standard-generic-function + standard-method + standard-object + structure-class + #-cmu17 symbol-macrolet + update-instance-for-different-class + update-instance-for-redefined-class + with-accessors + with-added-methods + with-slots + )) + +);eval-when + +#-(or KCL IBCL CMU) +(export *exports* *the-pcl-package*) + +#+CMU +(export '#.*exports* *the-pcl-package*) + +#+(or KCL IBCL) +(mapc 'export (list *exports*) (list *the-pcl-package*)) + + +(eval-when (compile load eval) + +(defvar *class-exports* + '(standard-instance + funcallable-standard-instance + generic-function + standard-generic-function + method + standard-method + standard-accessor-method + standard-reader-method + standard-writer-method + method-combination + slot-definition + direct-slot-definition + effective-slot-definition + standard-slot-definition + standard-direct-slot-definition + standard-effective-slot-definition + specializer + eql-specializer + built-in-class + forward-referenced-class + standard-class + funcallable-standard-class)) + +(defvar *chapter-6-exports* + '(add-dependent + add-direct-method + add-direct-subclass + add-method + allocate-instance + class-default-initargs + class-direct-default-initargs + class-direct-slots + class-direct-subclasses + class-direct-superclasses + class-finalized-p + class-precedence-list + class-prototype + class-slots + compute-applicable-methods + compute-applicable-methods-using-classes + compute-class-precedence-list + compute-discriminating-function + compute-effective-method + compute-effective-slot-definition + compute-slots + direct-slot-definition-class + effective-slot-definition-class + ensure-class + ensure-class-using-class + ensure-generic-function + ensure-generic-function-using-class + eql-specializer-instance + extract-lambda-list + extract-specializer-names + finalize-inheritance + find-method-combination + funcallable-standard-instance-access + generic-function-argument-precedence-order + generic-function-declarations + generic-function-lambda-list + generic-function-method-class + generic-function-method-combination + generic-function-methods + generic-function-name + intern-eql-specializer + make-instance + make-method-lambda + map-dependents + method-function + method-generic-function + method-lambda-list + method-specializers + method-qualifiers + accessor-method-slot-definition + reader-method-class + remove-dependent + remove-direct-method + remove-direct-subclass + remove-method + set-funcallable-instance-function + slot-boundp-using-class + slot-definition-allocation + slot-definition-initargs + slot-definition-initform + slot-definition-initfunction + slot-definition-location + slot-definition-name + slot-definition-readers + slot-definition-writers + slot-definition-type + slot-makunbound-using-class + slot-value-using-class + specializer-direct-generic-function + specializer-direct-methods + standard-instance-access + update-dependent + validate-superclass + writer-method-class + )) + +);eval-when + +#-(or KCL IBCL) +(export *class-exports* *the-pcl-package*) + +#+(or KCL IBCL) +(mapc 'export (list *class-exports*) (list *the-pcl-package*)) + +#-(or KCL IBCL) +(export *chapter-6-exports* *the-pcl-package*) + +#+(or KCL IBCL) +(mapc 'export (list *chapter-6-exports*) (list *the-pcl-package*)) + +(defvar *slot-accessor-name-package* + (or (find-package :slot-accessor-name) + (make-package :slot-accessor-name + :use '() + :nicknames '(:s-a-n)))) + +#+kcl +(when (get 'si::basic-wrapper 'si::s-data) + (import (mapcar #'(lambda (s) (intern (symbol-name s) "SI")) + '(:copy-structure-header :swap-structure-contents :set-structure-def + :%instance-ref :%set-instance-ref + + :cache-number-vector :cache-number-vector-length + :wrapper-cache-number-adds-ok :wrapper-cache-number-length + :wrapper-cache-number-mask :wrapper-cache-number-vector-length + :wrapper-layout :wrapper-cache-number-vector + :wrapper-state :wrapper-class :wrapper-length)))) diff --git a/pcl/gcl_pcl_precom1.lisp b/pcl/gcl_pcl_precom1.lisp new file mode 100644 index 0000000..0c550d9 --- /dev/null +++ b/pcl/gcl_pcl_precom1.lisp @@ -0,0 +1,51 @@ +;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; + +(in-package :pcl) + +;;; +;;; pre-allocate generic function caches. The hope is that this will put +;;; them nicely together in memory, and that that may be a win. Of course +;;; the first gc copy will probably blow that out, this really wants to be +;;; wrapped in something that declares the area static. +;;; +;;; This preallocation only creates about 25% more caches than PCL itself +;;; uses need. Some ports may want to preallocate some more of these. +;;; +(eval-when (load) + (flet ((allocate (n size) + (mapcar #'free-cache-vector + (mapcar #'get-cache-vector + (make-list n :initial-element size))))) + (allocate 128 4) + (allocate 64 8) + (allocate 64 9) + (allocate 32 16) + (allocate 16 17) + (allocate 16 32) + (allocate 1 64))) + diff --git a/pcl/gcl_pcl_precom2.lisp b/pcl/gcl_pcl_precom2.lisp new file mode 100644 index 0000000..97ab8f9 --- /dev/null +++ b/pcl/gcl_pcl_precom2.lisp @@ -0,0 +1,31 @@ +;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; + +(in-package :pcl) + +(precompile-random-code-segments pcl) + diff --git a/pcl/gcl_pcl_slots.lisp b/pcl/gcl_pcl_slots.lisp new file mode 100644 index 0000000..6cb3c86 --- /dev/null +++ b/pcl/gcl_pcl_slots.lisp @@ -0,0 +1,385 @@ +;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; + +(in-package :pcl) + +(defmethod wrapper-fetcher ((class standard-class)) + 'std-instance-wrapper) + +(defmethod slots-fetcher ((class standard-class)) + 'std-instance-slots) + +(defmethod raw-instance-allocator ((class standard-class)) + 'allocate-standard-instance) + +;;; +;;; These four functions work on std-instances and fsc-instances. These are +;;; instances for which it is possible to change the wrapper and the slots. +;;; +;;; For these kinds of instances, most specified methods from the instance +;;; structure protocol are promoted to the implementation-specific class +;;; std-class. Many of these methods call these four functions. +;;; + +(defun set-wrapper (inst new) + (cond ((std-instance-p inst) + #+new-kcl-wrapper + (set-structure-def inst new) + #-new-kcl-wrapper + (setf (std-instance-wrapper inst) new)) + ((fsc-instance-p inst) + (setf (fsc-instance-wrapper inst) new)) + (t + (error "What kind of instance is this?")))) + +#+ignore ; can't do this when using #+new-kcl-wrapper +(defun set-slots (inst new) + (cond ((std-instance-p inst) + (setf (std-instance-slots inst) new)) + ((fsc-instance-p inst) + (setf (fsc-instance-slots inst) new)) + (t + (error "What kind of instance is this?")))) + +(defun swap-wrappers-and-slots (i1 i2) + (without-interrupts + (cond ((std-instance-p i1) + #+new-kcl-wrapper + (swap-structure-contents i1 i2) + #-new-kcl-wrapper + (let ((w1 (std-instance-wrapper i1)) + (s1 (std-instance-slots i1))) + (setf (std-instance-wrapper i1) (std-instance-wrapper i2)) + (setf (std-instance-slots i1) (std-instance-slots i2)) + (setf (std-instance-wrapper i2) w1) + (setf (std-instance-slots i2) s1))) + ((fsc-instance-p i1) + (let ((w1 (fsc-instance-wrapper i1)) + (s1 (fsc-instance-slots i1))) + (setf (fsc-instance-wrapper i1) (fsc-instance-wrapper i2)) + (setf (fsc-instance-slots i1) (fsc-instance-slots i2)) + (setf (fsc-instance-wrapper i2) w1) + (setf (fsc-instance-slots i2) s1))) + (t + (error "What kind of instance is this?"))))) + + + + + + +(defun get-class-slot-value-1 (object wrapper slot-name) + (let ((entry (assoc slot-name (wrapper-class-slots wrapper)))) + (if (null entry) + (slot-missing (wrapper-class wrapper) object slot-name 'slot-value) + (if (eq (cdr entry) *slot-unbound*) + (slot-unbound (wrapper-class wrapper) object slot-name) + (cdr entry))))) + +(defun set-class-slot-value-1 (new-value object wrapper slot-name) + (let ((entry (assoc slot-name (wrapper-class-slots wrapper)))) + (if (null entry) + (slot-missing (wrapper-class wrapper) + object + slot-name + 'setf + new-value) + (setf (cdr entry) new-value)))) + +(defmethod class-slot-value ((class std-class) slot-name) + (let ((wrapper (class-wrapper class)) + (prototype (class-prototype class))) + (get-class-slot-value-1 prototype wrapper slot-name))) + +(defmethod (setf class-slot-value) (nv (class std-class) slot-name) + (let ((wrapper (class-wrapper class)) + (prototype (class-prototype class))) + (set-class-slot-value-1 nv prototype wrapper slot-name))) + + + +(defun find-slot-definition (class slot-name) + (dolist (slot (class-slots class) nil) + (when (eql slot-name (slot-definition-name slot)) + (return slot)))) + +(defun slot-value (object slot-name) + (let* ((class (class-of object)) + (slot-definition (find-slot-definition class slot-name))) + (if (null slot-definition) + (slot-missing class object slot-name 'slot-value) + (slot-value-using-class class object slot-definition)))) + +(setf (gdefinition 'slot-value-normal) #'slot-value) + +(define-compiler-macro slot-value (object-form slot-name-form) + (if (and (constantp slot-name-form) + (let ((slot-name (eval slot-name-form))) + (and (symbolp slot-name) (symbol-package slot-name)))) + `(accessor-slot-value ,object-form ,slot-name-form) + `(slot-value-normal ,object-form ,slot-name-form))) + +(defun set-slot-value (object slot-name new-value) + (let* ((class (class-of object)) + (slot-definition (find-slot-definition class slot-name))) + (if (null slot-definition) + (slot-missing class object slot-name 'setf) + (setf (slot-value-using-class class object slot-definition) + new-value)))) + +(setf (gdefinition 'set-slot-value-normal) #'set-slot-value) + +(define-compiler-macro set-slot-value (object-form slot-name-form new-value-form) + (if (and (constantp slot-name-form) + (let ((slot-name (eval slot-name-form))) + (and (symbolp slot-name) (symbol-package slot-name)))) + `(accessor-set-slot-value ,object-form ,slot-name-form ,new-value-form) + `(set-slot-value-normal ,object-form ,slot-name-form ,new-value-form))) + +(defconstant *optimize-slot-boundp* nil) + +(defun slot-boundp (object slot-name) + (let* ((class (class-of object)) + (slot-definition (find-slot-definition class slot-name))) + (if (null slot-definition) + (slot-missing class object slot-name 'slot-boundp) + (slot-boundp-using-class class object slot-definition)))) + +(setf (gdefinition 'slot-boundp-normal) #'slot-boundp) + +(define-compiler-macro slot-boundp (object-form slot-name-form) + (if (and (constantp slot-name-form) + (let ((slot-name (eval slot-name-form))) + (and (symbolp slot-name) (symbol-package slot-name)))) + `(accessor-slot-boundp ,object-form ,slot-name-form) + `(slot-boundp-normal ,object-form ,slot-name-form))) + +(defun slot-makunbound (object slot-name) + (let* ((class (class-of object)) + (slot-definition (find-slot-definition class slot-name))) + (if (null slot-definition) + (slot-missing class object slot-name 'slot-makunbound) + (slot-makunbound-using-class class object slot-definition)))) + +(defun slot-exists-p (object slot-name) + (let ((class (class-of object))) + (not (null (find-slot-definition class slot-name))))) + +;;; +;;; This isn't documented, but is used within PCL in a number of print +;;; object methods (see named-object-print-function). +;;; +(defun slot-value-or-default (object slot-name &optional (default "unbound")) + (if (slot-boundp object slot-name) + (slot-value object slot-name) + default)) + + +;;; +;;; +;;; +(defun standard-instance-access (instance location) + (%instance-ref (std-instance-slots instance) location)) + +(defun funcallable-standard-instance-access (instance location) + (%instance-ref (fsc-instance-slots instance) location)) + +(defmethod slot-value-using-class ((class std-class) + (object standard-object) + (slotd standard-effective-slot-definition)) + (let* ((location (slot-definition-location slotd)) + (value (typecase location + (fixnum + (cond ((std-instance-p object) + (unless (eq 't (wrapper-state (std-instance-wrapper object))) + (check-wrapper-validity object)) + (%instance-ref (std-instance-slots object) location)) + ((fsc-instance-p object) + (unless (eq 't (wrapper-state (fsc-instance-wrapper object))) + (check-wrapper-validity object)) + (%instance-ref (fsc-instance-slots object) location)) + (t (error "What kind of instance is this?")))) + (cons + (cdr location)) + (t + (error "The slot ~s has neither :instance nor :class allocation, ~@ + so it can't be read by the default ~s method." + slotd 'slot-value-using-class))))) + (if (eq value *slot-unbound*) + (slot-unbound class object (slot-definition-name slotd)) + value))) + +(defmethod (setf slot-value-using-class) + (new-value (class std-class) + (object standard-object) + (slotd standard-effective-slot-definition)) + (let ((location (slot-definition-location slotd))) + (typecase location + (fixnum + (cond ((std-instance-p object) + (unless (eq 't (wrapper-state (std-instance-wrapper object))) + (check-wrapper-validity object)) + (setf (%instance-ref (std-instance-slots object) location) new-value)) + ((fsc-instance-p object) + (unless (eq 't (wrapper-state (fsc-instance-wrapper object))) + (check-wrapper-validity object)) + (setf (%instance-ref (fsc-instance-slots object) location) new-value)) + (t (error "What kind of instance is this?")))) + (cons + (setf (cdr location) new-value)) + (t + (error "The slot ~s has neither :instance nor :class allocation, ~@ + so it can't be written by the default ~s method." + slotd '(setf slot-value-using-class)))))) + +(defmethod slot-boundp-using-class + ((class std-class) + (object standard-object) + (slotd standard-effective-slot-definition)) + (let* ((location (slot-definition-location slotd)) + (value (typecase location + (fixnum + (cond ((std-instance-p object) + (unless (eq 't (wrapper-state (std-instance-wrapper object))) + (check-wrapper-validity object)) + (%instance-ref (std-instance-slots object) location)) + ((fsc-instance-p object) + (unless (eq 't (wrapper-state (fsc-instance-wrapper object))) + (check-wrapper-validity object)) + (%instance-ref (fsc-instance-slots object) location)) + (t (error "What kind of instance is this?")))) + (cons + (cdr location)) + (t + (error "The slot ~s has neither :instance nor :class allocation, ~@ + so it can't be read by the default ~s method." + slotd 'slot-boundp-using-class))))) + (not (eq value *slot-unbound*)))) + +(defmethod slot-makunbound-using-class + ((class std-class) + (object standard-object) + (slotd standard-effective-slot-definition)) + (let ((location (slot-definition-location slotd))) + (typecase location + (fixnum + (cond ((std-instance-p object) + (unless (eq 't (wrapper-state (std-instance-wrapper object))) + (check-wrapper-validity object)) + (setf (%instance-ref (std-instance-slots object) location) *slot-unbound*)) + ((fsc-instance-p object) + (unless (eq 't (wrapper-state (fsc-instance-wrapper object))) + (check-wrapper-validity object)) + (setf (%instance-ref (fsc-instance-slots object) location) *slot-unbound*)) + (t (error "What kind of instance is this?")))) + (cons + (setf (cdr location) *slot-unbound*)) + (t + (error "The slot ~s has neither :instance nor :class allocation, ~@ + so it can't be written by the default ~s method." + slotd 'slot-makunbound-using-class)))) + nil) + +(defmethod slot-value-using-class + ((class structure-class) + (object structure-object) + (slotd structure-effective-slot-definition)) + (let* ((function (slot-definition-internal-reader-function slotd)) + (value (funcall function object))) + #+cmu (declare (type function function)) + (if (eq value *slot-unbound*) + (slot-unbound class object (slot-definition-name slotd)) + value))) + +(defmethod (setf slot-value-using-class) + (new-value (class structure-class) + (object structure-object) + (slotd structure-effective-slot-definition)) + (let ((function (slot-definition-internal-writer-function slotd))) + #+cmu (declare (type function function)) + (funcall function new-value object))) + +(defmethod slot-boundp-using-class + ((class structure-class) + (object structure-object) + (slotd structure-effective-slot-definition)) + #-new-kcl-wrapper t + #+new-kcl-wrapper + (let* ((function (slot-definition-internal-reader-function slotd)) + (value (funcall function object))) + #+cmu (declare (type function function)) + (not (eq value *slot-unbound*)))) + +(defmethod slot-makunbound-using-class + ((class structure-class) + (object structure-object) + (slotd structure-effective-slot-definition)) + (error "Structure slots can't be unbound")) + + +(defmethod slot-missing + ((class t) instance slot-name operation &optional new-value) + (error "When attempting to ~A,~%the slot ~S is missing from the object ~S." + (ecase operation + (slot-value "read the slot's value (slot-value)") + (setf (format nil + "set the slot's value to ~S (setf of slot-value)" + new-value)) + (slot-boundp "test to see if slot is bound (slot-boundp)") + (slot-makunbound "make the slot unbound (slot-makunbound)")) + slot-name + instance)) + +(defmethod slot-unbound ((class t) instance slot-name) + (error "The slot ~S is unbound in the object ~S." slot-name instance)) + +(defun slot-unbound-internal (instance position) + (slot-unbound (class-of instance) instance + (etypecase position + (fixnum + (nth position + (wrapper-instance-slots-layout (wrapper-of instance)))) + (cons + (car position))))) + + +(defmethod allocate-instance ((class standard-class) &rest initargs) + (declare (ignore initargs)) + (unless (class-finalized-p class) (finalize-inheritance class)) + (allocate-standard-instance (class-wrapper class))) + +(defmethod allocate-instance ((class structure-class) &rest initargs) + (declare (ignore initargs)) + #-new-kcl-wrapper + (let ((constructor (class-defstruct-constructor class))) + (if constructor + (funcall constructor) + (error "Can't allocate an instance of class ~S" (class-name class)))) + #+new-kcl-wrapper + (allocate-standard-instance (class-wrapper class))) + + diff --git a/pcl/gcl_pcl_slots_boot.lisp b/pcl/gcl_pcl_slots_boot.lisp new file mode 100644 index 0000000..48db465 --- /dev/null +++ b/pcl/gcl_pcl_slots_boot.lisp @@ -0,0 +1,406 @@ +;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; + +(in-package :pcl) + +(defmacro slot-symbol (slot-name type) + `(if (symbolp ,slot-name) + (or (get ,slot-name ',(ecase type + (reader 'reader-symbol) + (writer 'writer-symbol) + (boundp 'boundp-symbol))) + (intern (format nil "~A ~A slot ~a" + (if (symbol-package ,slot-name) + (package-name (symbol-package ,slot-name)) + "UNINTERNED") + (symbol-name ,slot-name) + ,(symbol-name type)) + *slot-accessor-name-package*)) + (progn + (error "non-symbol and non-interned symbol slot name accessors~ + are not yet implemented") + ;;(make-symbol (format nil "~a ~a" ,slot-name ,type)) + ))) + +(defun slot-reader-symbol (slot-name) + (slot-symbol slot-name reader)) + +(defun slot-writer-symbol (slot-name) + (slot-symbol slot-name writer)) + +(defun slot-boundp-symbol (slot-name) + (slot-symbol slot-name boundp)) + +(defmacro asv-funcall (sym slot-name type &rest args) + (declare (ignore type)) + `(if (#-akcl fboundp #+akcl %fboundp ',sym) + (,sym ,@args) + (no-slot ',sym ',slot-name))) + +(defun no-slot (sym slot-name) + (error "No class has a slot named ~S (~s has no function binding)." + slot-name sym)) + +(defmacro accessor-slot-value (object slot-name) + (unless (constantp slot-name) + (error "~s requires its slot-name argument to be a constant" + 'accessor-slot-value)) + (let* ((slot-name (eval slot-name)) + (sym (slot-reader-symbol slot-name))) + `(asv-funcall ,sym ,slot-name reader ,object))) + +(defmacro accessor-set-slot-value (object slot-name new-value &environment env) + (unless (constantp slot-name) + (error "~s requires its slot-name argument to be a constant" + 'accessor-set-slot-value)) + (setq object (macroexpand object env)) + (setq slot-name (macroexpand slot-name env)) + (let* ((slot-name (eval slot-name)) + (bindings (unless (or (constantp new-value) (atom new-value)) + (let ((object-var (gensym))) + (prog1 `((,object-var ,object)) + (setq object object-var))))) + (sym (slot-writer-symbol slot-name)) + (form `(asv-funcall ,sym ,slot-name writer ,new-value ,object))) + (if bindings + `(let ,bindings ,form) + form))) + +(defconstant *optimize-slot-boundp* nil) + +(defmacro accessor-slot-boundp (object slot-name) + (unless (constantp slot-name) + (error "~s requires its slot-name argument to be a constant" + 'accessor-slot-boundp)) + (let* ((slot-name (eval slot-name)) + (sym (slot-boundp-symbol slot-name))) + (if (not *optimize-slot-boundp*) + `(slot-boundp-normal ,object ',slot-name) + `(asv-funcall ,sym ,slot-name boundp ,object)))) + + +(defun structure-slot-boundp (object) + (declare (ignore object)) + t) + +(defun make-structure-slot-boundp-function (slotd) + (let* ((reader (slot-definition-internal-reader-function slotd)) + (fun #'(lambda (object) + (not (eq (funcall reader object) *slot-unbound*))))) + (declare (type function reader)) + #+(and kcl turbo-closure) (si:turbo-closure fun) + fun)) + +(defun get-optimized-std-accessor-method-function (class slotd name) + (if (structure-class-p class) + (ecase name + (reader (slot-definition-internal-reader-function slotd)) + (writer (slot-definition-internal-writer-function slotd)) + (boundp (make-structure-slot-boundp-function slotd))) + (let* ((fsc-p (cond ((standard-class-p class) nil) + ((funcallable-standard-class-p class) t) + (t (error "~S is not a standard-class" class)))) + (slot-name (slot-definition-name slotd)) + (index (slot-definition-location slotd)) + (function (ecase name + (reader #'make-optimized-std-reader-method-function) + (writer #'make-optimized-std-writer-method-function) + (boundp #'make-optimized-std-boundp-method-function))) + (value (funcall function fsc-p slot-name index))) + (declare (type function function)) + (values value index)))) + +(defun make-optimized-std-reader-method-function (fsc-p slot-name index) + (declare #.*optimize-speed*) + (set-function-name + (etypecase index + (fixnum (if fsc-p + #'(lambda (instance) + (let ((value (%instance-ref (fsc-instance-slots instance) index))) + (if (eq value *slot-unbound*) + (slot-unbound (class-of instance) instance slot-name) + value))) + #'(lambda (instance) + (let ((value (%instance-ref (std-instance-slots instance) index))) + (if (eq value *slot-unbound*) + (slot-unbound (class-of instance) instance slot-name) + value))))) + (cons #'(lambda (instance) + (let ((value (cdr index))) + (if (eq value *slot-unbound*) + (slot-unbound (class-of instance) instance slot-name) + value))))) + `(reader ,slot-name))) + +(defun make-optimized-std-writer-method-function (fsc-p slot-name index) + (declare #.*optimize-speed*) + (set-function-name + (etypecase index + (fixnum (if fsc-p + #'(lambda (nv instance) + (setf (%instance-ref (fsc-instance-slots instance) index) nv)) + #'(lambda (nv instance) + (setf (%instance-ref (std-instance-slots instance) index) nv)))) + (cons #'(lambda (nv instance) + (declare (ignore instance)) + (setf (cdr index) nv)))) + `(writer ,slot-name))) + +(defun make-optimized-std-boundp-method-function (fsc-p slot-name index) + (declare #.*optimize-speed*) + (set-function-name + (etypecase index + (fixnum (if fsc-p + #'(lambda (instance) + (not (eq *slot-unbound* + (%instance-ref (fsc-instance-slots instance) index)))) + #'(lambda (instance) + (not (eq *slot-unbound* + (%instance-ref (std-instance-slots instance) index)))))) + (cons #'(lambda (instance) + (declare (ignore instance)) + (not (eq *slot-unbound* (cdr index)))))) + `(boundp ,slot-name))) + +(defun make-optimized-structure-slot-value-using-class-method-function (function) + #+cmu (declare (type function function)) + #'(lambda (class object slotd) + (let ((value (funcall function object))) + (if (eq value *slot-unbound*) + (slot-unbound class object (slot-definition-name slotd)) + value)))) + +(defun make-optimized-structure-setf-slot-value-using-class-method-function (function) + #+cmu (declare (type function function)) + #'(lambda (nv class object slotd) + (declare (ignore class slotd)) + (funcall function nv object))) + +(defun make-optimized-structure-slot-boundp-using-class-method-function (function) + #+cmu (declare (type function function)) + #'(lambda (class object slotd) + (declare (ignore class slotd)) + (not (eq (funcall function object) *slot-unbound*)))) + +(defun get-optimized-std-slot-value-using-class-method-function (class slotd name) + (if (structure-class-p class) + (ecase name + (reader (make-optimized-structure-slot-value-using-class-method-function + (slot-definition-internal-reader-function slotd))) + (writer (make-optimized-structure-setf-slot-value-using-class-method-function + (slot-definition-internal-writer-function slotd))) + (boundp (make-optimized-structure-slot-boundp-using-class-method-function + (slot-definition-internal-writer-function slotd)))) + (let* ((fsc-p (cond ((standard-class-p class) nil) + ((funcallable-standard-class-p class) t) + (t (error "~S is not a standard-class" class)))) + (slot-name (slot-definition-name slotd)) + (index (slot-definition-location slotd)) + (function + (ecase name + (reader + #'make-optimized-std-slot-value-using-class-method-function) + (writer + #'make-optimized-std-setf-slot-value-using-class-method-function) + (boundp + #'make-optimized-std-slot-boundp-using-class-method-function)))) + #+cmu (declare (type function function)) + (values (funcall function fsc-p slot-name index) index)))) + +(defun make-optimized-std-slot-value-using-class-method-function + (fsc-p slot-name index) + (declare #.*optimize-speed*) + (etypecase index + (fixnum (if fsc-p + #'(lambda (class instance slotd) + (declare (ignore slotd)) + (unless (fsc-instance-p instance) (error "not fsc")) + (let ((value (%instance-ref (fsc-instance-slots instance) index))) + (if (eq value *slot-unbound*) + (slot-unbound class instance slot-name) + value))) + #'(lambda (class instance slotd) + (declare (ignore slotd)) + (unless (std-instance-p instance) (error "not std")) + (let ((value (%instance-ref (std-instance-slots instance) index))) + (if (eq value *slot-unbound*) + (slot-unbound class instance slot-name) + value))))) + (cons #'(lambda (class instance slotd) + (declare (ignore slotd)) + (let ((value (cdr index))) + (if (eq value *slot-unbound*) + (slot-unbound class instance slot-name) + value)))))) + +(defun make-optimized-std-setf-slot-value-using-class-method-function + (fsc-p slot-name index) + (declare #.*optimize-speed*) + (declare (ignore slot-name)) + (etypecase index + (fixnum (if fsc-p + #'(lambda (nv class instance slotd) + (declare (ignore class slotd)) + (setf (%instance-ref (fsc-instance-slots instance) index) nv)) + #'(lambda (nv class instance slotd) + (declare (ignore class slotd)) + (setf (%instance-ref (std-instance-slots instance) index) nv)))) + (cons #'(lambda (nv class instance slotd) + (declare (ignore class instance slotd)) + (setf (cdr index) nv))))) + +(defun make-optimized-std-slot-boundp-using-class-method-function + (fsc-p slot-name index) + (declare #.*optimize-speed*) + (declare (ignore slot-name)) + (etypecase index + (fixnum (if fsc-p + #'(lambda (class instance slotd) + (declare (ignore class slotd)) + (not (eq *slot-unbound* + (%instance-ref (fsc-instance-slots instance) index)))) + #'(lambda (class instance slotd) + (declare (ignore class slotd)) + (not (eq *slot-unbound* + (%instance-ref (std-instance-slots instance) index)))))) + (cons #'(lambda (class instance slotd) + (declare (ignore class instance slotd)) + (not (eq *slot-unbound* (cdr index))))))) + +(defun get-accessor-from-svuc-method-function (class slotd sdfun name) + (macrolet ((emf-funcall (emf &rest args) + `(invoke-effective-method-function ,emf nil ,@args))) + (set-function-name + (case name + (reader #'(lambda (instance) (emf-funcall sdfun class instance slotd))) + (writer #'(lambda (nv instance) (emf-funcall sdfun nv class instance slotd))) + (boundp #'(lambda (instance) (emf-funcall sdfun class instance slotd)))) + `(,name ,(class-name class) ,(slot-definition-name slotd))))) + +(defun make-internal-reader-method-function (class-name slot-name) + (list* ':method-spec `(internal-reader-method ,class-name ,slot-name) + (make-method-function + (lambda (instance) + (let ((wrapper (get-instance-wrapper-or-nil instance))) + (if wrapper + (let* ((class (wrapper-class* wrapper)) + (index (or (instance-slot-index wrapper slot-name) + (assq slot-name (wrapper-class-slots wrapper))))) + (typecase index + (fixnum + (let ((value (%instance-ref (get-slots instance) index))) + (if (eq value *slot-unbound*) + (slot-unbound (class-of instance) instance slot-name) + value))) + (cons + (let ((value (cdr index))) + (if (eq value *slot-unbound*) + (slot-unbound (class-of instance) instance slot-name) + value))) + (t + (error "The wrapper for class ~S does not have the slot ~S" + class slot-name)))) + (slot-value instance slot-name))))))) + + +(defun make-std-reader-method-function (class-name slot-name) + (let* ((pv-table-symbol (gensym)) + (initargs (copy-tree + (make-method-function + (lambda (instance) + (pv-binding1 (.pv. .calls. + (symbol-value pv-table-symbol) + (instance) (instance-slots)) + (instance-read-internal + .pv. instance-slots 1 + (slot-value instance slot-name)))))))) + (setf (getf (getf initargs ':plist) ':slot-name-lists) + (list (list nil slot-name))) + (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol) + (list* ':method-spec `(reader-method ,class-name ,slot-name) + initargs))) + +(defun make-std-writer-method-function (class-name slot-name) + (let* ((pv-table-symbol (gensym)) + (initargs (copy-tree + (make-method-function + (lambda (nv instance) + (pv-binding1 (.pv. .calls. + (symbol-value pv-table-symbol) + (instance) (instance-slots)) + (instance-write-internal + .pv. instance-slots 1 nv + (setf (slot-value instance slot-name) nv)))))))) + (setf (getf (getf initargs ':plist) ':slot-name-lists) + (list nil (list nil slot-name))) + (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol) + (list* ':method-spec `(writer-method ,class-name ,slot-name) + initargs))) + +(defun make-std-boundp-method-function (class-name slot-name) + (let* ((pv-table-symbol (gensym)) + (initargs (copy-tree + (make-method-function + (lambda (instance) + (pv-binding1 (.pv. .calls. + (symbol-value pv-table-symbol) + (instance) (instance-slots)) + (instance-boundp-internal + .pv. instance-slots 1 + (slot-boundp instance slot-name)))))))) + (setf (getf (getf initargs ':plist) ':slot-name-lists) + (list (list nil slot-name))) + (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol) + (list* ':method-spec `(boundp-method ,class-name ,slot-name) + initargs))) + +(defun initialize-internal-slot-gfs (slot-name &optional type) + (when (or (null type) (eq type 'reader)) + (let* ((name (slot-reader-symbol slot-name)) + (gf (ensure-generic-function name))) + (unless (generic-function-methods gf) + (add-reader-method *the-class-slot-object* gf slot-name)))) + (when (or (null type) (eq type 'writer)) + (let* ((name (slot-writer-symbol slot-name)) + (gf (ensure-generic-function name))) + (unless (generic-function-methods gf) + (add-writer-method *the-class-slot-object* gf slot-name)))) + (when (and *optimize-slot-boundp* + (or (null type) (eq type 'boundp))) + (let* ((name (slot-boundp-symbol slot-name)) + (gf (ensure-generic-function name))) + (unless (generic-function-methods gf) + (add-boundp-method *the-class-slot-object* gf slot-name)))) + nil) + +(defun initialize-internal-slot-gfs* (readers writers boundps) + (dolist (reader readers) + (initialize-internal-slot-gfs reader 'reader)) + (dolist (writer writers) + (initialize-internal-slot-gfs writer 'writer)) + (dolist (boundp boundps) + (initialize-internal-slot-gfs boundp 'boundp))) diff --git a/pcl/gcl_pcl_std_class.lisp b/pcl/gcl_pcl_std_class.lisp new file mode 100644 index 0000000..4c48387 --- /dev/null +++ b/pcl/gcl_pcl_std_class.lisp @@ -0,0 +1,1321 @@ +;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; + +(in-package :pcl) + +(defmethod slot-accessor-function ((slotd effective-slot-definition) type) + (ecase type + (reader (slot-definition-reader-function slotd)) + (writer (slot-definition-writer-function slotd)) + (boundp (slot-definition-boundp-function slotd)))) + +(defmethod (setf slot-accessor-function) (function + (slotd effective-slot-definition) type) + (ecase type + (reader (setf (slot-definition-reader-function slotd) function)) + (writer (setf (slot-definition-writer-function slotd) function)) + (boundp (setf (slot-definition-boundp-function slotd) function)))) + +(defconstant *slotd-reader-function-std-p* 1) +(defconstant *slotd-writer-function-std-p* 2) +(defconstant *slotd-boundp-function-std-p* 4) +(defconstant *slotd-all-function-std-p* 7) + +(defmethod slot-accessor-std-p ((slotd effective-slot-definition) type) + (let ((flags (slot-value slotd 'accessor-flags))) + (declare (type fixnum flags)) + (if (eq type 'all) + (eql *slotd-all-function-std-p* flags) + (let ((mask (ecase type + (reader *slotd-reader-function-std-p*) + (writer *slotd-writer-function-std-p*) + (boundp *slotd-boundp-function-std-p*)))) + (declare (type fixnum mask)) + (not (zerop (the fixnum (logand mask flags)))))))) + +(defmethod (setf slot-accessor-std-p) (value (slotd effective-slot-definition) type) + (let ((mask (ecase type + (reader *slotd-reader-function-std-p*) + (writer *slotd-writer-function-std-p*) + (boundp *slotd-boundp-function-std-p*))) + (flags (slot-value slotd 'accessor-flags))) + (declare (type fixnum mask flags)) + (setf (slot-value slotd 'accessor-flags) + (if value + (the fixnum (logior mask flags)) + (the fixnum (logand (the fixnum (lognot mask)) flags))))) + value) + +(defmethod initialize-internal-slot-functions ((slotd effective-slot-definition)) + (let* ((name (slot-value slotd 'name)) + (class (slot-value slotd 'class))) + (let ((table (or (gethash name *name->class->slotd-table*) + (setf (gethash name *name->class->slotd-table*) + (make-hash-table :test 'eq :size 5))))) + (setf (gethash class table) slotd)) + (dolist (type '(reader writer boundp)) + (let* ((gf-name (ecase type + (reader 'slot-value-using-class) + (writer '(setf slot-value-using-class)) + (boundp 'slot-boundp-using-class))) + (gf (gdefinition gf-name))) + (compute-slot-accessor-info slotd type gf))) + (initialize-internal-slot-gfs name))) + +(defmethod compute-slot-accessor-info ((slotd effective-slot-definition) type gf) + (let* ((name (slot-value slotd 'name)) + (class (slot-value slotd 'class)) + (old-slotd (find-slot-definition class name)) + (old-std-p (and old-slotd (slot-accessor-std-p old-slotd 'all)))) + (multiple-value-bind (function std-p) + (if (eq *boot-state* 'complete) + (get-accessor-method-function gf type class slotd) + (get-optimized-std-accessor-method-function class slotd type)) + #+kcl (si:turbo-closure function) + (setf (slot-accessor-std-p slotd type) std-p) + (setf (slot-accessor-function slotd type) function)) + (when (and old-slotd (not (eq old-std-p (slot-accessor-std-p slotd 'all)))) + (push (cons class name) *pv-table-cache-update-info*)))) + +(defmethod slot-definition-allocation ((slotd structure-slot-definition)) + :instance) + + + +(defmethod shared-initialize :after ((object documentation-mixin) + slot-names + &key (documentation nil documentation-p)) + (declare (ignore slot-names)) + (when documentation-p + (setf (plist-value object 'documentation) documentation))) + +(defmethod documentation (object &optional doc-type) + (lisp:documentation object doc-type)) + +(defmethod (setf documentation) (new-value object &optional doc-type) + (declare (ignore new-value doc-type)) + (error "Can't change the documentation of ~S." object)) + + +(defmethod documentation ((object documentation-mixin) &optional doc-type) + (declare (ignore doc-type)) + (plist-value object 'documentation)) + +(defmethod (setf documentation) (new-value (object documentation-mixin) &optional doc-type) + (declare (ignore doc-type)) + (setf (plist-value object 'documentation) new-value)) + + +(defmethod documentation ((slotd standard-slot-definition) &optional doc-type) + (declare (ignore doc-type)) + (slot-value slotd 'documentation)) + +(defmethod (setf documentation) (new-value (slotd standard-slot-definition) &optional doc-type) + (declare (ignore doc-type)) + (setf (slot-value slotd 'documentation) new-value)) + + +;;; +;;; Various class accessors that are a little more complicated than can be +;;; done with automatically generated reader methods. +;;; +(defmethod class-finalized-p ((class pcl-class)) + (with-slots (wrapper) class + (not (null wrapper)))) + +(defmethod class-prototype ((class std-class)) + (with-slots (prototype) class + (or prototype (setq prototype (allocate-instance class))))) + +(defmethod class-prototype ((class structure-class)) + (with-slots (prototype wrapper defstruct-constructor) class + (or prototype + (setq prototype + (if #-new-kcl-wrapper defstruct-constructor #+new-kcl-wrapper nil + (allocate-instance class) + (allocate-standard-instance wrapper)))))) + +(defmethod class-direct-default-initargs ((class slot-class)) + (plist-value class 'direct-default-initargs)) + +(defmethod class-default-initargs ((class slot-class)) + (plist-value class 'default-initargs)) + +(defmethod class-constructors ((class slot-class)) + (plist-value class 'constructors)) + +(defmethod class-slot-cells ((class std-class)) + (plist-value class 'class-slot-cells)) + + +;;; +;;; Class accessors that are even a little bit more complicated than those +;;; above. These have a protocol for updating them, we must implement that +;;; protocol. +;;; + +;;; +;;; Maintaining the direct subclasses backpointers. The update methods are +;;; here, the values are read by an automatically generated reader method. +;;; +(defmethod add-direct-subclass ((class class) (subclass class)) + (with-slots (direct-subclasses) class + (pushnew subclass direct-subclasses) + subclass)) + +(defmethod remove-direct-subclass ((class class) (subclass class)) + (with-slots (direct-subclasses) class + (setq direct-subclasses (remove subclass direct-subclasses)) + subclass)) + +;;; +;;; Maintaining the direct-methods and direct-generic-functions backpointers. +;;; +;;; There are four generic functions involved, each has one method for the +;;; class case and another method for the damned EQL specializers. All of +;;; these are specified methods and appear in their specified place in the +;;; class graph. +;;; +;;; ADD-DIRECT-METHOD +;;; REMOVE-DIRECT-METHOD +;;; SPECIALIZER-DIRECT-METHODS +;;; SPECIALIZER-DIRECT-GENERIC-FUNCTIONS +;;; +;;; In each case, we maintain one value which is a cons. The car is the list +;;; methods. The cdr is a list of the generic functions. The cdr is always +;;; computed lazily. +;;; + +(defmethod add-direct-method ((specializer class) (method method)) + (with-slots (direct-methods) specializer + (setf (car direct-methods) (adjoin method (car direct-methods)) ;PUSH + (cdr direct-methods) ())) + method) + +(defmethod remove-direct-method ((specializer class) (method method)) + (with-slots (direct-methods) specializer + (setf (car direct-methods) (remove method (car direct-methods)) + (cdr direct-methods) ())) + method) + +(defmethod specializer-direct-methods ((specializer class)) + (with-slots (direct-methods) specializer + (car direct-methods))) + +(defmethod specializer-direct-generic-functions ((specializer class)) + (with-slots (direct-methods) specializer + (or (cdr direct-methods) + (setf (cdr direct-methods) + (gathering1 (collecting-once) + (dolist (m (car direct-methods)) + (gather1 (method-generic-function m)))))))) + + + +;;; +;;; This hash table is used to store the direct methods and direct generic +;;; functions of EQL specializers. Each value in the table is the cons. +;;; +(defvar *eql-specializer-methods* (make-hash-table :test #'eql)) +(defvar *class-eq-specializer-methods* (make-hash-table :test #'eq)) + +(defmethod specializer-method-table ((specializer eql-specializer)) + *eql-specializer-methods*) + +(defmethod specializer-method-table ((specializer class-eq-specializer)) + *class-eq-specializer-methods*) + +(defmethod add-direct-method ((specializer specializer-with-object) (method method)) + (let* ((object (specializer-object specializer)) + (table (specializer-method-table specializer)) + (entry (gethash object table))) + (unless entry + (setq entry + (setf (gethash object table) + (cons nil nil)))) + (setf (car entry) (adjoin method (car entry)) + (cdr entry) ()) + method)) + +(defmethod remove-direct-method ((specializer specializer-with-object) (method method)) + (let* ((object (specializer-object specializer)) + (entry (gethash object (specializer-method-table specializer)))) + (when entry + (setf (car entry) (remove method (car entry)) + (cdr entry) ())) + method)) + +(defmethod specializer-direct-methods ((specializer specializer-with-object)) + (car (gethash (specializer-object specializer) + (specializer-method-table specializer)))) + +(defmethod specializer-direct-generic-functions ((specializer specializer-with-object)) + (let* ((object (specializer-object specializer)) + (entry (gethash object (specializer-method-table specializer)))) + (when entry + (or (cdr entry) + (setf (cdr entry) + (gathering1 (collecting-once) + (dolist (m (car entry)) + (gather1 (method-generic-function m))))))))) + +(defun map-specializers (function) + (declare (type function function)) + (map-all-classes #'(lambda (class) + (funcall function (class-eq-specializer class)) + (funcall function class))) + (maphash #'(lambda (object methods) + (declare (ignore methods)) + (intern-eql-specializer object)) + *eql-specializer-methods*) + (maphash #'(lambda (object specl) + (declare (ignore object)) + (funcall function specl)) + *eql-specializer-table*) + nil) + +(defun map-all-generic-functions (function) + (declare (type function function)) + (let ((all-generic-functions (make-hash-table :test 'eq))) + (map-specializers #'(lambda (specl) + (dolist (gf (specializer-direct-generic-functions specl)) + (unless (gethash gf all-generic-functions) + (setf (gethash gf all-generic-functions) t) + (funcall function gf)))))) + nil) + +(defmethod shared-initialize :after ((specl class-eq-specializer) slot-names &key) + (declare (ignore slot-names)) + (setf (slot-value specl 'type) `(class-eq ,(specializer-class specl)))) + +(defmethod shared-initialize :after ((specl eql-specializer) slot-names &key) + (declare (ignore slot-names)) + (setf (slot-value specl 'type) `(eql ,(specializer-object specl)))) + + + +(defun real-load-defclass (name metaclass-name supers slots other accessors) + (do-standard-defsetfs-for-defclass accessors) ;*** + (let ((res (apply #'ensure-class name :metaclass metaclass-name + :direct-superclasses supers + :direct-slots slots + :definition-source `((defclass ,name) + ,(load-truename)) + other))) + #+cmu17 (kernel:layout-class (class-wrapper res)) + #-cmu17 res)) + +(setf (gdefinition 'load-defclass) #'real-load-defclass) + +(defun ensure-class (name &rest all) + (apply #'ensure-class-using-class name (find-class name nil) all)) + +(defmethod ensure-class-using-class (name (class null) &rest args &key) + (multiple-value-bind (meta initargs) + (ensure-class-values class args) + (inform-type-system-about-class (class-prototype meta) name);*** + (setf class (apply #'make-instance meta :name name initargs) + (find-class name) class) + (inform-type-system-about-class class name) ;*** + class)) + +(defmethod ensure-class-using-class (name (class pcl-class) &rest args &key) + (multiple-value-bind (meta initargs) + (ensure-class-values class args) + (unless (eq (class-of class) meta) (change-class class meta)) + (apply #'reinitialize-instance class initargs) + (setf (find-class name) class) + (inform-type-system-about-class class name) ;*** + class)) + +(defmethod class-predicate-name ((class t)) + 'function-returning-nil) + +(defun ensure-class-values (class args) + (let* ((initargs (copy-list args)) + (unsupplied (list 1)) + (supplied-meta (getf initargs :metaclass unsupplied)) + (supplied-supers (getf initargs :direct-superclasses unsupplied)) + (supplied-slots (getf initargs :direct-slots unsupplied)) + (meta + (cond ((neq supplied-meta unsupplied) + (find-class supplied-meta)) + ((or (null class) + (forward-referenced-class-p class)) + *the-class-standard-class*) + (t + (class-of class))))) + (flet ((fix-super (s) + (cond ((classp s) s) + ((not (legal-class-name-p s)) + (error "~S is not a class or a legal class name." s)) + (t + (or (find-class s nil) + (setf (find-class s) + (make-instance 'forward-referenced-class + :name s))))))) + (loop (unless (remf initargs :metaclass) (return))) + (loop (unless (remf initargs :direct-superclasses) (return))) + (loop (unless (remf initargs :direct-slots) (return))) + (values meta + (list* :direct-superclasses + (and (neq supplied-supers unsupplied) + (mapcar #'fix-super supplied-supers)) + :direct-slots + (and (neq supplied-slots unsupplied) supplied-slots) + initargs))))) + + +;;; +;;; +;;; +#|| ; since it doesn't do anything +(defmethod shared-initialize :before ((class std-class) + slot-names + &key direct-superclasses) + (declare (ignore slot-names)) + ;; *** error checking + ) +||# + +(defmethod shared-initialize :after + ((class std-class) + slot-names + &key (direct-superclasses nil direct-superclasses-p) + (direct-slots nil direct-slots-p) + (direct-default-initargs nil direct-default-initargs-p) + (predicate-name nil predicate-name-p)) + (declare (ignore slot-names)) + (if direct-superclasses-p + (progn + (setq direct-superclasses (or direct-superclasses + (list *the-class-standard-object*))) + (dolist (superclass direct-superclasses) + (unless (validate-superclass class superclass) + (error "The class ~S was specified as a~%super-class of the class ~S;~%~ + but the meta-classes ~S and~%~S are incompatible.~% + Define a method for ~S to avoid this error." + superclass class (class-of superclass) (class-of class) + 'validate-superclass))) + (setf (slot-value class 'direct-superclasses) direct-superclasses)) + (setq direct-superclasses (slot-value class 'direct-superclasses))) + (setq direct-slots + (if direct-slots-p + (setf (slot-value class 'direct-slots) + (mapcar #'(lambda (pl) (make-direct-slotd class pl)) direct-slots)) + (slot-value class 'direct-slots))) + (if direct-default-initargs-p + (setf (plist-value class 'direct-default-initargs) direct-default-initargs) + (setq direct-default-initargs (plist-value class 'direct-default-initargs))) + (setf (plist-value class 'class-slot-cells) + (gathering1 (collecting) + (dolist (dslotd direct-slots) + (when (eq (slot-definition-allocation dslotd) class) + (let ((initfunction (slot-definition-initfunction dslotd))) + (gather1 (cons (slot-definition-name dslotd) + (if initfunction + (funcall initfunction) + *slot-unbound*)))))))) + (setq predicate-name (if predicate-name-p + (setf (slot-value class 'predicate-name) + (car predicate-name)) + (or (slot-value class 'predicate-name) + (setf (slot-value class 'predicate-name) + (make-class-predicate-name (class-name class)))))) + (add-direct-subclasses class direct-superclasses) + (update-class class nil) + (make-class-predicate class predicate-name) + (add-slot-accessors class direct-slots)) + +(defmethod shared-initialize :before ((class class) slot-names &key name) + (declare (ignore slot-names name)) + (setf (slot-value class 'type) `(class ,class)) + (setf (slot-value class 'class-eq-specializer) + (make-instance 'class-eq-specializer :class class))) + +(defmethod reinitialize-instance :before ((class slot-class) &key) + (remove-direct-subclasses class (class-direct-superclasses class)) + (remove-slot-accessors class (class-direct-slots class))) + +(defmethod reinitialize-instance :after ((class slot-class) + &rest initargs + &key) + (map-dependents class + #'(lambda (dependent) + (apply #'update-dependent class dependent initargs)))) + +(defmethod shared-initialize :after + ((class structure-class) + slot-names + &key (direct-superclasses nil direct-superclasses-p) + (direct-slots nil direct-slots-p) + direct-default-initargs + (predicate-name nil predicate-name-p)) + (declare (ignore slot-names direct-default-initargs)) + (if direct-superclasses-p + (setf (slot-value class 'direct-superclasses) + (or direct-superclasses + (setq direct-superclasses + (and (not (eq (class-name class) 'structure-object)) + (list *the-class-structure-object*))))) + (setq direct-superclasses (slot-value class 'direct-superclasses))) + (let* ((name (class-name class)) + (from-defclass-p (slot-value class 'from-defclass-p)) + (defstruct-p (or from-defclass-p (not (structure-type-p name))))) + (if direct-slots-p + (setf (slot-value class 'direct-slots) + (setq direct-slots + (mapcar #'(lambda (pl) + (when defstruct-p + (let* ((slot-name (getf pl :name)) + (acc-name (format nil "~s structure class ~a" + name slot-name)) + (accessor (intern acc-name))) + (setq pl (list* :defstruct-accessor-symbol accessor + pl)))) + (make-direct-slotd class pl)) + direct-slots))) + (setq direct-slots (slot-value class 'direct-slots))) + (when defstruct-p + (let* ((include (car (slot-value class 'direct-superclasses))) + (conc-name (intern (format nil "~s structure class " name))) + (constructor (intern (format nil "~a constructor" conc-name))) + (defstruct `(defstruct (,name + ,@(when include + `((:include ,(class-name include)))) + (:print-function print-std-instance) + (:predicate nil) + (:conc-name ,conc-name) + (:constructor ,constructor ())) + ,@(mapcar #'(lambda (slot) + `(,(slot-definition-name slot) + *slot-unbound*)) + direct-slots))) + (reader-names (mapcar #'(lambda (slotd) + (intern (format nil "~A~A reader" conc-name + (slot-definition-name slotd)))) + direct-slots)) + (writer-names (mapcar #'(lambda (slotd) + (intern (format nil "~A~A writer" conc-name + (slot-definition-name slotd)))) + direct-slots)) + (readers-init + (mapcar #'(lambda (slotd reader-name) + (let ((accessor + (slot-definition-defstruct-accessor-symbol slotd))) + `(defun ,reader-name (obj) + (declare (type ,name obj)) + (,accessor obj)))) + direct-slots reader-names)) + (writers-init + (mapcar #'(lambda (slotd writer-name) + (let ((accessor + (slot-definition-defstruct-accessor-symbol slotd))) + `(defun ,writer-name (nv obj) + (declare (type ,name obj)) + (setf (,accessor obj) nv)))) + direct-slots writer-names)) + (defstruct-form + `(progn + ,defstruct + ,@readers-init ,@writers-init + (declare-structure ',name nil nil)))) + (unless (structure-type-p name) (eval defstruct-form)) + (mapc #'(lambda (dslotd reader-name writer-name) + (let* ((reader (gdefinition reader-name)) + (writer (when (gboundp writer-name) + (gdefinition writer-name)))) + (setf (slot-value dslotd 'internal-reader-function) reader) + (setf (slot-value dslotd 'internal-writer-function) writer))) + direct-slots reader-names writer-names) + (setf (slot-value class 'defstruct-form) defstruct-form) + (setf (slot-value class 'defstruct-constructor) constructor)))) + (add-direct-subclasses class direct-superclasses) + (setf (slot-value class 'class-precedence-list) + (compute-class-precedence-list class)) + (setf (slot-value class 'slots) (compute-slots class)) + #-(or cmu17 new-kcl-wrapper) + (unless (slot-value class 'wrapper) + (setf (slot-value class 'wrapper) (make-wrapper 0 class))) + #+cmu17 + (let ((lclass (lisp:find-class (class-name class)))) + (setf (kernel:class-pcl-class lclass) class) + (setf (slot-value class 'wrapper) (kernel:class-layout lclass))) + #+new-kcl-wrapper + (let ((wrapper (get (class-name class) 'si::s-data))) + (setf (slot-value class 'wrapper) wrapper) + (setf (wrapper-class wrapper) class)) + (update-pv-table-cache-info class) + (setq predicate-name (if predicate-name-p + (setf (slot-value class 'predicate-name) + (car predicate-name)) + (or (slot-value class 'predicate-name) + (setf (slot-value class 'predicate-name) + (make-class-predicate-name (class-name class)))))) + (make-class-predicate class predicate-name) + (add-slot-accessors class direct-slots)) + +(defmethod direct-slot-definition-class ((class structure-class) initargs) + (declare (ignore initargs)) + (find-class 'structure-direct-slot-definition)) + +(defmethod finalize-inheritance ((class structure-class)) + nil) ; always finalized + +(defun add-slot-accessors (class dslotds) + (fix-slot-accessors class dslotds 'add)) + +(defun remove-slot-accessors (class dslotds) + (fix-slot-accessors class dslotds 'remove)) + +(defun fix-slot-accessors (class dslotds add/remove) + (flet ((fix (gfspec name r/w) + (let ((gf (ensure-generic-function gfspec))) + (case r/w + (r (if (eq add/remove 'add) + (add-reader-method class gf name) + (remove-reader-method class gf))) + (w (if (eq add/remove 'add) + (add-writer-method class gf name) + (remove-writer-method class gf))))))) + (dolist (dslotd dslotds) + (let ((slot-name (slot-definition-name dslotd))) + (dolist (r (slot-definition-readers dslotd)) (fix r slot-name 'r)) + (dolist (w (slot-definition-writers dslotd)) (fix w slot-name 'w)))))) + + +(defun add-direct-subclasses (class new) + (dolist (n new) + (unless (memq class (class-direct-subclasses class)) + (add-direct-subclass n class)))) + +(defun remove-direct-subclasses (class new) + (let ((old (class-direct-superclasses class))) + (dolist (o (set-difference old new)) + (remove-direct-subclass o class)))) + + +;;; +;;; +;;; +(defmethod finalize-inheritance ((class std-class)) + (update-class class t)) + + +(defun class-has-a-forward-referenced-superclass-p (class) + (or (forward-referenced-class-p class) + (some #'class-has-a-forward-referenced-superclass-p + (class-direct-superclasses class)))) + +;;; +;;; Called by :after shared-initialize whenever a class is initialized or +;;; reinitialized. The class may or may not be finalized. +;;; +(defun update-class (class finalizep) + (when (or finalizep (class-finalized-p class) + (not (class-has-a-forward-referenced-superclass-p class))) + (update-cpl class (compute-class-precedence-list class)) + (update-slots class (compute-slots class)) + (update-gfs-of-class class) + (update-inits class (compute-default-initargs class)) + (update-make-instance-function-table class)) + (unless finalizep + (dolist (sub (class-direct-subclasses class)) (update-class sub nil)))) + +(defun update-cpl (class cpl) + (when (class-finalized-p class) + (unless (equal (class-precedence-list class) cpl) + (force-cache-flushes class))) + (setf (slot-value class 'class-precedence-list) cpl) + (update-class-can-precede-p cpl)) + +(defun update-class-can-precede-p (cpl) + (when cpl + (let ((first (car cpl))) + (dolist (c (cdr cpl)) + (pushnew c (slot-value first 'can-precede-list)))) + (update-class-can-precede-p (cdr cpl)))) + +(defun class-can-precede-p (class1 class2) + (member class2 (class-can-precede-list class1))) + +(defun update-slots (class eslotds) + (let ((instance-slots ()) + (class-slots ())) + (dolist (eslotd eslotds) + (let ((alloc (slot-definition-allocation eslotd))) + (cond ((eq alloc :instance) (push eslotd instance-slots)) + ((classp alloc) (push eslotd class-slots))))) + ;; + ;; If there is a change in the shape of the instances then the + ;; old class is now obsolete. + ;; + (let* ((nlayout (mapcar #'slot-definition-name + (sort instance-slots #'< :key #'slot-definition-location))) + (nslots (length nlayout)) + (nwrapper-class-slots (compute-class-slots class-slots)) + (owrapper (class-wrapper class)) + (olayout (and owrapper (wrapper-instance-slots-layout owrapper))) + (owrapper-class-slots (and owrapper (wrapper-class-slots owrapper))) + (nwrapper + (cond ((null owrapper) + (make-wrapper nslots class)) + ((and (equal nlayout olayout) + (not + (iterate ((o (list-elements owrapper-class-slots)) + (n (list-elements nwrapper-class-slots))) + (unless (eq (car o) (car n)) (return t))))) + owrapper) + (t + ;; + ;; This will initialize the new wrapper to have the same + ;; state as the old wrapper. We will then have to change + ;; that. This may seem like wasted work (it is), but the + ;; spec requires that we call make-instances-obsolete. + ;; + (make-instances-obsolete class) + (class-wrapper class))))) + + (with-slots (wrapper slots) class + #+new-kcl-wrapper + (setf (si::s-data-name nwrapper) (class-name class)) + #+cmu17 + (update-lisp-class-layout class nwrapper) + (setf slots eslotds + (wrapper-instance-slots-layout nwrapper) nlayout + (wrapper-class-slots nwrapper) nwrapper-class-slots + (wrapper-no-of-instance-slots nwrapper) nslots + wrapper nwrapper)) + + (unless (eq owrapper nwrapper) + (update-pv-table-cache-info class))))) + +(defun compute-class-slots (eslotds) + (gathering1 (collecting) + (dolist (eslotd eslotds) + (gather1 + (assoc (slot-definition-name eslotd) + (class-slot-cells (slot-definition-allocation eslotd))))))) + +(defun compute-layout (cpl instance-eslotds) + (let* ((names + (gathering1 (collecting) + (dolist (eslotd instance-eslotds) + (when (eq (slot-definition-allocation eslotd) :instance) + (gather1 (slot-definition-name eslotd)))))) + (order ())) + (labels ((rwalk (tail) + (when tail + (rwalk (cdr tail)) + (dolist (ss (class-slots (car tail))) + (let ((n (slot-definition-name ss))) + (when (member n names) + (setq order (cons n order) + names (remove n names)))))))) + (rwalk (if (slot-boundp (car cpl) 'slots) + cpl + (cdr cpl))) + (reverse (append names order))))) + +(defun update-gfs-of-class (class) + (when (and (class-finalized-p class) + (let ((cpl (class-precedence-list class))) + (or (member *the-class-slot-class* cpl) + (member *the-class-standard-effective-slot-definition* cpl)))) + (let ((gf-table (make-hash-table :test 'eq))) + (labels ((collect-gfs (class) + (dolist (gf (specializer-direct-generic-functions class)) + (setf (gethash gf gf-table) t)) + (mapc #'collect-gfs (class-direct-superclasses class)))) + (collect-gfs class) + (maphash #'(lambda (gf ignore) + (declare (ignore ignore)) + (update-gf-dfun class gf)) + gf-table))))) + +(defun update-inits (class inits) + (setf (plist-value class 'default-initargs) inits)) + + +;;; +;;; +;;; +(defmethod compute-default-initargs ((class slot-class)) + (let ((cpl (class-precedence-list class)) + (direct (class-direct-default-initargs class))) + (labels ((walk (tail) + (if (null tail) + nil + (let ((c (pop tail))) + (append (if (eq c class) + direct + (class-direct-default-initargs c)) + (walk tail)))))) + (let ((initargs (walk cpl))) + (delete-duplicates initargs :test #'eq :key #'car :from-end t))))) + + +;;; +;;; Protocols for constructing direct and effective slot definitions. +;;; +;;; +;;; +;;; +(defmethod direct-slot-definition-class ((class std-class) initargs) + (declare (ignore initargs)) + (find-class 'standard-direct-slot-definition)) + +(defun make-direct-slotd (class initargs) + (let ((initargs (list* :class class initargs))) + (apply #'make-instance (direct-slot-definition-class class initargs) initargs))) + +;;; +;;; +;;; +(defmethod compute-slots ((class std-class)) + ;; + ;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once + ;; for each different slot name we find in our superclasses. Each + ;; call receives the class and a list of the dslotds with that name. + ;; The list is in most-specific-first order. + ;; + (let ((name-dslotds-alist ())) + (dolist (c (class-precedence-list class)) + (let ((dslotds (class-direct-slots c))) + (dolist (d dslotds) + (let* ((name (slot-definition-name d)) + (entry (assq name name-dslotds-alist))) + (if entry + (push d (cdr entry)) + (push (list name d) name-dslotds-alist)))))) + (mapcar #'(lambda (direct) + (compute-effective-slot-definition class + (nreverse (cdr direct)))) + name-dslotds-alist))) + +(defmethod compute-slots :around ((class std-class)) + (let ((eslotds (call-next-method)) + (cpl (class-precedence-list class)) + (instance-slots ()) + (class-slots ())) + (dolist (eslotd eslotds) + (let ((alloc (slot-definition-allocation eslotd))) + (cond ((eq alloc :instance) (push eslotd instance-slots)) + ((classp alloc) (push eslotd class-slots))))) + (let ((nlayout (compute-layout cpl instance-slots))) + (dolist (eslotd instance-slots) + (setf (slot-definition-location eslotd) + (position (slot-definition-name eslotd) nlayout)))) + (dolist (eslotd class-slots) + (setf (slot-definition-location eslotd) + (assoc (slot-definition-name eslotd) + (class-slot-cells (slot-definition-allocation eslotd))))) + (mapc #'initialize-internal-slot-functions eslotds) + eslotds)) + +(defmethod compute-slots ((class structure-class)) + (mapcan #'(lambda (superclass) + (mapcar #'(lambda (dslotd) + (compute-effective-slot-definition class + (list dslotd))) + (class-direct-slots superclass))) + (reverse (slot-value class 'class-precedence-list)))) + +(defmethod compute-slots :around ((class structure-class)) + (let ((eslotds (call-next-method))) + (mapc #'initialize-internal-slot-functions eslotds) + eslotds)) + +(defmethod compute-effective-slot-definition ((class slot-class) dslotds) + (let* ((initargs (compute-effective-slot-definition-initargs class dslotds)) + (class (effective-slot-definition-class class initargs))) + (apply #'make-instance class initargs))) + +(defmethod effective-slot-definition-class ((class std-class) initargs) + (declare (ignore initargs)) + (find-class 'standard-effective-slot-definition)) + +(defmethod effective-slot-definition-class ((class structure-class) initargs) + (declare (ignore initargs)) + (find-class 'structure-effective-slot-definition)) + +(defmethod compute-effective-slot-definition-initargs + ((class slot-class) direct-slotds) + (let* ((name nil) + (initfunction nil) + (initform nil) + (initargs nil) + (allocation nil) + (type t) + (namep nil) + (initp nil) + (allocp nil)) + + (dolist (slotd direct-slotds) + (when slotd + (unless namep + (setq name (slot-definition-name slotd) + namep t)) + (unless initp + (when (slot-definition-initfunction slotd) + (setq initform (slot-definition-initform slotd) + initfunction (slot-definition-initfunction slotd) + initp t))) + (unless allocp + (setq allocation (slot-definition-allocation slotd) + allocp t)) + (setq initargs (append (slot-definition-initargs slotd) initargs)) + (let ((slotd-type (slot-definition-type slotd))) + (setq type (cond ((eq type 't) slotd-type) + ((*subtypep type slotd-type) type) + (t `(and ,type ,slotd-type))))))) + (list :name name + :initform initform + :initfunction initfunction + :initargs initargs + :allocation allocation + :type type + :class class))) + +(defmethod compute-effective-slot-definition-initargs :around + ((class structure-class) direct-slotds) + (let ((slotd (car direct-slotds))) + (list* :defstruct-accessor-symbol (slot-definition-defstruct-accessor-symbol slotd) + :internal-reader-function (slot-definition-internal-reader-function slotd) + :internal-writer-function (slot-definition-internal-writer-function slotd) + (call-next-method)))) + +;;; +;;; NOTE: For bootstrapping considerations, these can't use make-instance +;;; to make the method object. They have to use make-a-method which +;;; is a specially bootstrapped mechanism for making standard methods. +;;; +(defmethod reader-method-class ((class slot-class) direct-slot &rest initargs) + (declare (ignore direct-slot initargs)) + (find-class 'standard-reader-method)) + +(defmethod add-reader-method ((class slot-class) generic-function slot-name) + (add-method generic-function + (make-a-method 'standard-reader-method + () + (list (or (class-name class) 'object)) + (list class) + (make-reader-method-function class slot-name) + "automatically generated reader method" + slot-name))) + +(defmethod writer-method-class ((class slot-class) direct-slot &rest initargs) + (declare (ignore direct-slot initargs)) + (find-class 'standard-writer-method)) + +(defmethod add-writer-method ((class slot-class) generic-function slot-name) + (add-method generic-function + (make-a-method 'standard-writer-method + () + (list 'new-value (or (class-name class) 'object)) + (list *the-class-t* class) + (make-writer-method-function class slot-name) + "automatically generated writer method" + slot-name))) + +(defmethod add-boundp-method ((class slot-class) generic-function slot-name) + (add-method generic-function + (make-a-method 'standard-boundp-method + () + (list (or (class-name class) 'object)) + (list class) + (make-boundp-method-function class slot-name) + "automatically generated boundp method" + slot-name))) + +(defmethod remove-reader-method ((class slot-class) generic-function) + (let ((method (get-method generic-function () (list class) nil))) + (when method (remove-method generic-function method)))) + +(defmethod remove-writer-method ((class slot-class) generic-function) + (let ((method + (get-method generic-function () (list *the-class-t* class) nil))) + (when method (remove-method generic-function method)))) + +(defmethod remove-boundp-method ((class slot-class) generic-function) + (let ((method (get-method generic-function () (list class) nil))) + (when method (remove-method generic-function method)))) + + +;;; +;;; make-reader-method-function and make-write-method function are NOT part of +;;; the standard protocol. They are however useful, PCL makes uses makes use +;;; of them internally and documents them for PCL users. +;;; +;;; *** This needs work to make type testing by the writer functions which +;;; *** do type testing faster. The idea would be to have one constructor +;;; *** for each possible type test. In order to do this it would be nice +;;; *** to have help from inform-type-system-about-class and friends. +;;; +;;; *** There is a subtle bug here which is going to have to be fixed. +;;; *** Namely, the simplistic use of the template has to be fixed. We +;;; *** have to give the optimize-slot-value method the user might have +;;; *** defined for this metclass a chance to run. +;;; +(defmethod make-reader-method-function ((class slot-class) slot-name) + (make-std-reader-method-function (class-name class) slot-name)) + +(defmethod make-writer-method-function ((class slot-class) slot-name) + (make-std-writer-method-function (class-name class) slot-name)) + +(defmethod make-boundp-method-function ((class slot-class) slot-name) + (make-std-boundp-method-function (class-name class) slot-name)) + + +;;;; inform-type-system-about-class +;;;; make-type-predicate +;;; +;;; These are NOT part of the standard protocol. They are internal mechanism +;;; which PCL uses to *try* and tell the type system about class definitions. +;;; In a more fully integrated implementation of CLOS, the type system would +;;; know about class objects and class names in a more fundamental way and +;;; the mechanism used to inform the type system about new classes would be +;;; different. +;;; +(defmethod inform-type-system-about-class ((class std-class) name) + (inform-type-system-about-std-class name)) + + +(defmethod compatible-meta-class-change-p (class proto-new-class) + (eq (class-of class) (class-of proto-new-class))) + +(defmethod validate-superclass ((class class) (new-super class)) + (or (eq new-super *the-class-t*) + (eq (class-of class) (class-of new-super)))) + + + +;;; +;;; +;;; +(defun force-cache-flushes (class) + (let* ((owrapper (class-wrapper class)) + (state (wrapper-state owrapper))) + ;; + ;; We only need to do something if the state is still T. If the + ;; state isn't T, it will be FLUSH or OBSOLETE, and both of those + ;; will already be doing what we want. In particular, we must be + ;; sure we never change an OBSOLETE into a FLUSH since OBSOLETE + ;; means do what FLUSH does and then some. + ;; + (when (eq state 't) + (let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper) + class))) + (setf (wrapper-instance-slots-layout nwrapper) + (wrapper-instance-slots-layout owrapper)) + (setf (wrapper-class-slots nwrapper) + (wrapper-class-slots owrapper)) + (without-interrupts + #+cmu17 + (update-lisp-class-layout class nwrapper) + (setf (slot-value class 'wrapper) nwrapper) + (invalidate-wrapper owrapper ':flush nwrapper)))))) + +(defun flush-cache-trap (owrapper nwrapper instance) + (declare (ignore owrapper)) + (set-wrapper instance nwrapper)) + + + +;;; +;;; make-instances-obsolete can be called by user code. It will cause the +;;; next access to the instance (as defined in 88-002R) to trap through the +;;; update-instance-for-redefined-class mechanism. +;;; +(defmethod make-instances-obsolete ((class std-class)) + (let* ((owrapper (class-wrapper class)) + (nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper) + class))) + (setf (wrapper-instance-slots-layout nwrapper) + (wrapper-instance-slots-layout owrapper)) + (setf (wrapper-class-slots nwrapper) + (wrapper-class-slots owrapper)) + (without-interrupts + #+cmu17 + (update-lisp-class-layout class nwrapper) + (setf (slot-value class 'wrapper) nwrapper) + (invalidate-wrapper owrapper ':obsolete nwrapper) + class))) + +(defmethod make-instances-obsolete ((class symbol)) + (make-instances-obsolete (find-class class))) + + +;;; +;;; obsolete-instance-trap is the internal trap that is called when we see +;;; an obsolete instance. The times when it is called are: +;;; - when the instance is involved in method lookup +;;; - when attempting to access a slot of an instance +;;; +;;; It is not called by class-of, wrapper-of, or any of the low-level instance +;;; access macros. +;;; +;;; Of course these times when it is called are an internal implementation +;;; detail of PCL and are not part of the documented description of when the +;;; obsolete instance update happens. The documented description is as it +;;; appears in 88-002R. +;;; +;;; This has to return the new wrapper, so it counts on all the methods on +;;; obsolete-instance-trap-internal to return the new wrapper. It also does +;;; a little internal error checking to make sure that the traps are only +;;; happening when they should, and that the trap methods are computing +;;; apropriate new wrappers. +;;; + +;;; obsolete-instance-trap might be called on structure instances +;;; after a structure is redefined. In most cases, obsolete-instance-trap +;;; will not be able to fix the old instance, so it must signal an +;;; error. The hard part of this is that the error system and debugger +;;; might cause obsolete-instance-trap to be called again, so in that +;;; case, we have to return some reasonable wrapper, instead. + +(defvar *in-obsolete-instance-trap* nil) +(defvar *the-wrapper-of-structure-object* + (class-wrapper (find-class 'structure-object))) + +#+cmu17 +(define-condition obsolete-structure (error) + ((datum :reader obsolete-structure-datum :initarg :datum)) + (:report + (lambda (condition stream) + ;; Don't try to print the structure, since it probably + ;; won't work. + (format stream "Obsolete structure error in ~S:~@ + For a structure of type: ~S" + (conditions::condition-function-name condition) + (type-of (obsolete-structure-datum condition)))))) + +(defun obsolete-instance-trap (owrapper nwrapper instance) + (if (not #-(or cmu17 new-kcl-wrapper) + (or (std-instance-p instance) (fsc-instance-p instance)) + #+cmu17 + (pcl-instance-p instance) + #+new-kcl-wrapper + nil) + (if *in-obsolete-instance-trap* + *the-wrapper-of-structure-object* + (let ((*in-obsolete-instance-trap* t)) + #-cmu17 + (error "The structure ~S is obsolete." instance) + #+cmu17 + (error 'obsolete-structure :datum instance))) + (let* ((class (wrapper-class* nwrapper)) + (copy (allocate-instance class)) ;??? allocate-instance ??? + (olayout (wrapper-instance-slots-layout owrapper)) + (nlayout (wrapper-instance-slots-layout nwrapper)) + (oslots (get-slots instance)) + (nslots (get-slots copy)) + (oclass-slots (wrapper-class-slots owrapper)) + (added ()) + (discarded ()) + (plist ())) + ;; local --> local transfer + ;; local --> shared discard + ;; local --> -- discard + ;; shared --> local transfer + ;; shared --> shared discard + ;; shared --> -- discard + ;; -- --> local add + ;; -- --> shared -- + ;; + ;; Go through all the old local slots. + ;; + (iterate ((name (list-elements olayout)) + (opos (interval :from 0))) + (let* ((opos opos) + (npos (posq name nlayout))) + (declare (fixnum opos)) + (if npos + (setf (instance-ref nslots npos) (instance-ref oslots opos)) + (progn + (push name discarded) + (unless (eq (instance-ref oslots opos) *slot-unbound*) + (setf (getf plist name) (instance-ref oslots opos))))))) + ;; + ;; Go through all the old shared slots. + ;; + (iterate ((oclass-slot-and-val (list-elements oclass-slots))) + (let ((name (car oclass-slot-and-val)) + (val (cdr oclass-slot-and-val))) + (let ((npos (posq name nlayout))) + (if npos + (setf (instance-ref nslots npos) (cdr oclass-slot-and-val)) + (progn (push name discarded) + (unless (eq val *slot-unbound*) + (setf (getf plist name) val))))))) + ;; + ;; Go through all the new local slots to compute the added slots. + ;; + (dolist (nlocal nlayout) + (unless (or (memq nlocal olayout) + (assq nlocal oclass-slots)) + (push nlocal added))) + + (swap-wrappers-and-slots instance copy) + + (update-instance-for-redefined-class instance + added + discarded + plist) + nwrapper))) + + +;;; +;;; +;;; +(defmacro copy-instance-internal (instance) + `(#+new-kcl-wrapper if #-new-kcl-wrapper progn + #+new-kcl-wrapper (not (std-instance-p ,instance)) + (let* ((class (class-of instance)) + (copy (allocate-instance class))) + (if (std-instance-p ,instance) + (setf (std-instance-slots ,instance) (std-instance-slots ,instance)) + (setf (fsc-instance-slots ,instance) (fsc-instance-slots ,instance))) + copy) + #+new-kcl-wrapper + (copy-structure-header ,instance))) + +(defun change-class-internal (instance new-class) + (let* ((old-class (class-of instance)) + (copy (allocate-instance new-class)) + (new-wrapper (get-wrapper copy)) + (old-wrapper (class-wrapper old-class)) + (old-layout (wrapper-instance-slots-layout old-wrapper)) + (new-layout (wrapper-instance-slots-layout new-wrapper)) + (old-slots (get-slots instance)) + (new-slots (get-slots copy)) + (old-class-slots (wrapper-class-slots old-wrapper))) + + ;; + ;; "The values of local slots specified by both the class Cto and + ;; Cfrom are retained. If such a local slot was unbound, it remains + ;; unbound." + ;; + (iterate ((new-slot (list-elements new-layout)) + (new-position (interval :from 0))) + (let* ((new-position new-position) + (old-position (posq new-slot old-layout))) + (declare (fixnum new-position)) + (when old-position + (setf (instance-ref new-slots new-position) + (instance-ref old-slots old-position))))) + + ;; + ;; "The values of slots specified as shared in the class Cfrom and + ;; as local in the class Cto are retained." + ;; + (iterate ((slot-and-val (list-elements old-class-slots))) + (let ((position (posq (car slot-and-val) new-layout))) + (when position + (setf (instance-ref new-slots position) (cdr slot-and-val))))) + + ;; Make the copy point to the old instance's storage, and make the + ;; old instance point to the new storage. + (swap-wrappers-and-slots instance copy) + + (update-instance-for-different-class copy instance) + instance)) + +(defmethod change-class ((instance standard-object) + (new-class standard-class)) + (unless (std-instance-p instance) + (error "Can't change the class of ~S to ~S~@ + because it isn't already an instance with metaclass~%~S." + instance + new-class + 'standard-class)) + (change-class-internal instance new-class)) + +(defmethod change-class ((instance standard-object) + (new-class funcallable-standard-class)) + (unless (fsc-instance-p instance) + (error "Can't change the class of ~S to ~S~@ + because it isn't already an instance with metaclass~%~S." + instance + new-class + 'funcallable-standard-class)) + (change-class-internal instance new-class)) + +(defmethod change-class ((instance t) (new-class-name symbol)) + (change-class instance (find-class new-class-name))) + + + +;;; +;;; The metaclass BUILT-IN-CLASS +;;; +;;; This metaclass is something of a weird creature. By this point, all +;;; instances of it which will exist have been created, and no instance +;;; is ever created by calling MAKE-INSTANCE. +;;; +;;; But, there are other parts of the protcol we must follow and those +;;; definitions appear here. +;;; +(defmethod shared-initialize :before + ((class built-in-class) slot-names &rest initargs) + (declare (ignore slot-names initargs)) + (error "Attempt to initialize or reinitialize a built in class.")) + +(defmethod class-direct-slots ((class built-in-class)) ()) +(defmethod class-slots ((class built-in-class)) ()) +(defmethod class-direct-default-initargs ((class built-in-class)) ()) +(defmethod class-default-initargs ((class built-in-class)) ()) + +(defmethod validate-superclass ((c class) (s built-in-class)) + (eq s *the-class-t*)) + + + +;;; +;;; +;;; + +(defmethod validate-superclass ((c slot-class) + (f forward-referenced-class)) + 't) + + +;;; +;;; +;;; + +(defmethod add-dependent ((metaobject dependent-update-mixin) dependent) + (pushnew dependent (plist-value metaobject 'dependents))) + +(defmethod remove-dependent ((metaobject dependent-update-mixin) dependent) + (setf (plist-value metaobject 'dependents) + (delete dependent (plist-value metaobject 'dependents)))) + +(defmethod map-dependents ((metaobject dependent-update-mixin) function) + (dolist (dependent (plist-value metaobject 'dependents)) + (funcall function dependent))) + diff --git a/pcl/gcl_pcl_vector.lisp b/pcl/gcl_pcl_vector.lisp new file mode 100644 index 0000000..010803c --- /dev/null +++ b/pcl/gcl_pcl_vector.lisp @@ -0,0 +1,1109 @@ +;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; +;;; Permutation vectors. +;;; + +(in-package :pcl) + +(defmacro instance-slot-index (wrapper slot-name) + `(let ((pos 0)) + (declare (fixnum pos)) + (block loop + (dolist (sn (wrapper-instance-slots-layout ,wrapper)) + (when (eq ,slot-name sn) (return-from loop pos)) + (incf pos))))) + + +;;; +;;; +;;; +(defun pv-cache-limit-fn (nlines) + (default-limit-fn nlines)) + +(defstruct (pv-table + (:predicate pv-tablep) + (:constructor make-pv-table-internal + (slot-name-lists call-list))) + (cache nil :type (or cache null)) + (pv-size 0 :type fixnum) + (slot-name-lists nil :type list) + (call-list nil :type list)) + +#+cmu +(declaim (ext:freeze-type pv-table)) + +(defvar *initial-pv-table* (make-pv-table-internal nil nil)) + +; help new slot-value-using-class methods affect fast iv access +(defvar *all-pv-table-list* nil) + +(defun make-pv-table (&key slot-name-lists call-list) + (let ((pv-table (make-pv-table-internal slot-name-lists call-list))) + (push pv-table *all-pv-table-list*) + pv-table)) + +(defun make-pv-table-type-declaration (var) + `(type pv-table ,var)) + +(defvar *slot-name-lists-inner* (make-hash-table :test #'equal)) +(defvar *slot-name-lists-outer* (make-hash-table :test #'equal)) + +;entries in this are lists of (table . pv-offset-list) +(defvar *pv-key-to-pv-table-table* (make-hash-table :test 'equal)) + +(defun intern-pv-table (&key slot-name-lists call-list) + (let ((new-p nil)) + (flet ((inner (x) + (or (gethash x *slot-name-lists-inner*) + (setf (gethash x *slot-name-lists-inner*) (copy-list x)))) + (outer (x) + (or (gethash x *slot-name-lists-outer*) + (setf (gethash x *slot-name-lists-outer*) + (let ((snl (copy-list (cdr x))) + (cl (car x))) + (setq new-p t) + (make-pv-table :slot-name-lists snl + :call-list cl)))))) + (let ((pv-table (outer (mapcar #'inner (cons call-list slot-name-lists))))) + (when new-p + (let ((pv-index 1)) + (declare (fixnum pv-index)) + (dolist (slot-name-list slot-name-lists) + (dolist (slot-name (cdr slot-name-list)) + (note-pv-table-reference slot-name pv-index pv-table) + (incf pv-index))) + (dolist (gf-call call-list) + (note-pv-table-reference gf-call pv-index pv-table) + (incf pv-index)) + (setf (pv-table-pv-size pv-table) pv-index))) + pv-table)))) + +(defun note-pv-table-reference (ref pv-offset pv-table) + (let ((entry (gethash ref *pv-key-to-pv-table-table*))) + (when (listp entry) + (let ((table-entry (assq pv-table entry))) + (when (and (null table-entry) + (> (length entry) 8)) + (let ((new-table-table (make-hash-table :size 16 :test 'eq))) + (dolist (table-entry entry) + (setf (gethash (car table-entry) new-table-table) + (cdr table-entry))) + (setf (gethash ref *pv-key-to-pv-table-table*) new-table-table))) + (when (listp entry) + (if (null table-entry) + (let ((new (cons pv-table pv-offset))) + (if (consp entry) + (push new (cdr entry)) + (setf (gethash ref *pv-key-to-pv-table-table*) (list new)))) + (push pv-offset (cdr table-entry))) + (return-from note-pv-table-reference nil)))) + (let ((list (gethash pv-table entry))) + (if (consp list) + (push pv-offset (cdr list)) + (setf (gethash pv-table entry) (list pv-offset))))) + nil) + +(defun map-pv-table-references-of (ref function) + (let ((entry (gethash ref *pv-key-to-pv-table-table*))) + (if (listp entry) + (dolist (table+pv-offset-list entry) + (funcall function + (car table+pv-offset-list) (cdr table+pv-offset-list))) + (maphash function entry))) + ref) + + +(defvar *pvs* (make-hash-table :test #'equal)) + +(defun optimize-slot-value-by-class-p (class slot-name type) + (or (not (eq *boot-state* 'complete)) + (let ((slotd (find-slot-definition class slot-name))) + (and slotd + (slot-accessor-std-p slotd type))))) + +(defun compute-pv-slot (slot-name wrapper class class-slots class-slot-p-cell) + (if (symbolp slot-name) + (when (optimize-slot-value-by-class-p class slot-name 'all) + (or (instance-slot-index wrapper slot-name) + (let ((cell (assq slot-name class-slots))) + (when cell + (setf (car class-slot-p-cell) t) + cell)))) + (when (consp slot-name) + (dolist (type '(reader writer) nil) + (when (eq (car slot-name) type) + (return + (let* ((gf-name (cadr slot-name)) + (gf (gdefinition gf-name)) + (location + (when (eq *boot-state* 'complete) + (accessor-values1 gf type class)))) + (when (consp location) + (setf (car class-slot-p-cell) t)) + location))))))) + +(defun compute-pv (slot-name-lists wrappers) + (unless (listp wrappers) (setq wrappers (list wrappers))) + (let* ((not-simple-p-cell (list nil)) + (elements + (gathering1 (collecting) + (iterate ((slot-names (list-elements slot-name-lists))) + (when slot-names + (let* ((wrapper (pop wrappers)) + (std-p #+cmu17 (typep wrapper 'wrapper) + #-cmu17 t) + (class (wrapper-class* wrapper)) + (class-slots (and std-p (wrapper-class-slots wrapper)))) + (dolist (slot-name (cdr slot-names)) + (gather1 + (when std-p + (compute-pv-slot slot-name wrapper class + class-slots not-simple-p-cell)))))))))) + (if (car not-simple-p-cell) + (make-permutation-vector (cons t elements)) + (or (gethash elements *pvs*) + (setf (gethash elements *pvs*) + (make-permutation-vector (cons nil elements))))))) + +(defun compute-calls (call-list wrappers) + (declare (ignore call-list wrappers)) + #|| + (map 'vector + #'(lambda (call) + (compute-emf-from-wrappers call wrappers)) + call-list) + ||# + '#()) + +#|| ; Need to finish this, then write the maintenance functions. +(defun compute-emf-from-wrappers (call wrappers) + (when call + ; FIXME use regular destructuring-bind + (pcl-destructuring-bind (gf-name nreq restp arg-info) call + (if (eq gf-name 'make-instance) + (error "should not get here") ; there is another mechanism for this. + #'(lambda (&rest args) + (if (not (eq *boot-state* 'complete)) + (apply (gdefinition gf-name) args) + (let* ((gf (gdefinition gf-name)) + (arg-info (arg-info-reader gf)) + (classes '?) + (types '?) + (emf (cache-miss-values-internal gf arg-info + wrappers classes types + 'caching))) + (update-all-pv-tables call wrappers emf) + #+copy-&rest-arg (setq args (copy-list args)) + (invoke-emf emf args)))))))) +||# + +(defun make-permutation-vector (indexes) + (make-array (length indexes) :initial-contents indexes)) + +(defun pv-table-lookup (pv-table pv-wrappers) + (let* ((slot-name-lists (pv-table-slot-name-lists pv-table)) + (call-list (pv-table-call-list pv-table)) + (cache (or (pv-table-cache pv-table) + (setf (pv-table-cache pv-table) + (get-cache (- (length slot-name-lists) + (count nil slot-name-lists)) + t + #'pv-cache-limit-fn + 2))))) + (or (probe-cache cache pv-wrappers) + (let* ((pv (compute-pv slot-name-lists pv-wrappers)) + (calls (compute-calls call-list pv-wrappers)) + (pv-cell (cons pv calls)) + (new-cache (fill-cache cache pv-wrappers pv-cell))) + (unless (eq new-cache cache) + (setf (pv-table-cache pv-table) new-cache) + (free-cache cache)) + pv-cell)))) + +(defun make-pv-type-declaration (var) + `(type simple-vector ,var)) + +(defvar *empty-pv* #()) + +(defmacro pvref (pv index) + `(svref ,pv ,index)) + +(defmacro copy-pv (pv) + `(copy-seq ,pv)) + +(defun make-calls-type-declaration (var) + `(type simple-vector ,var)) + +(defmacro callsref (calls index) + `(svref ,calls ,index)) + +(defvar *pv-table-cache-update-info* nil) + +;called by: +;(method shared-initialize :after (structure-class t)) +;update-slots +(defun update-pv-table-cache-info (class) + (let ((slot-names-for-pv-table-update nil) + (new-icui nil)) + (dolist (icu *pv-table-cache-update-info*) + (if (eq (car icu) class) + (pushnew (cdr icu) slot-names-for-pv-table-update) + (push icu new-icui))) + (setq *pv-table-cache-update-info* new-icui) + (when slot-names-for-pv-table-update + (update-all-pv-table-caches class slot-names-for-pv-table-update)))) + +(defun update-all-pv-table-caches (class slot-names) + (let* ((cwrapper (class-wrapper class)) + (std-p #+cmu17 (typep cwrapper 'wrapper) #-cmu17 t) + (class-slots (and std-p (wrapper-class-slots cwrapper))) + (class-slot-p-cell (list nil)) + (new-values (mapcar #'(lambda (slot-name) + (cons slot-name + (when std-p + (compute-pv-slot + slot-name cwrapper class + class-slots class-slot-p-cell)))) + slot-names)) + (pv-tables nil)) + (dolist (slot-name slot-names) + (map-pv-table-references-of + slot-name + #'(lambda (pv-table pv-offset-list) + (declare (ignore pv-offset-list)) + (pushnew pv-table pv-tables)))) + (dolist (pv-table pv-tables) + (let* ((cache (pv-table-cache pv-table)) + (slot-name-lists (pv-table-slot-name-lists pv-table)) + (pv-size (pv-table-pv-size pv-table)) + (pv-map (make-array pv-size :initial-element nil))) + (let ((map-index 1)(param-index 0)) + (declare (fixnum map-index param-index)) + (dolist (slot-name-list slot-name-lists) + (dolist (slot-name (cdr slot-name-list)) + (let ((a (assoc slot-name new-values))) + (setf (svref pv-map map-index) + (and a (cons param-index (cdr a))))) + (incf map-index)) + (incf param-index))) + (when cache + (map-cache #'(lambda (wrappers pv-cell) + (setf (car pv-cell) + (update-slots-in-pv wrappers (car pv-cell) + cwrapper pv-size pv-map))) + cache)))))) + +(defun update-slots-in-pv (wrappers pv cwrapper pv-size pv-map) + (if (not (if (atom wrappers) + (eq cwrapper wrappers) + (dolist (wrapper wrappers nil) + (when (eq wrapper cwrapper) + (return t))))) + pv + (let* ((old-intern-p (listp (pvref pv 0))) + (new-pv (if old-intern-p + (copy-pv pv) + pv)) + (new-intern-p t)) + (if (atom wrappers) + (dotimes (i pv-size) + (when (consp (let ((map (svref pv-map i))) + (if map + (setf (pvref new-pv i) (cdr map)) + (pvref new-pv i)))) + (setq new-intern-p nil))) + (let ((param 0)) + (declare (fixnum param)) + (dolist (wrapper wrappers) + (when (eq wrapper cwrapper) + (dotimes (i pv-size) + (when (consp (let ((map (svref pv-map i))) + (if (and map (= (car map) param)) + (setf (pvref new-pv i) (cdr map)) + (pvref new-pv i)))) + (setq new-intern-p nil)))) + (incf param)))) + (when new-intern-p + (setq new-pv (let ((list-pv (coerce pv 'list))) + (or (gethash (cdr list-pv) *pvs*) + (setf (gethash (cdr list-pv) *pvs*) + (if old-intern-p + new-pv + (make-permutation-vector list-pv))))))) + new-pv))) + + +(defun maybe-expand-accessor-form (form required-parameters slots env) + (let* ((fname (car form)) + #||(len (length form))||# + (gf (if (symbolp fname) + (unencapsulated-fdefinition fname) + (gdefinition fname)))) + (macrolet ((maybe-optimize-reader () + `(let ((parameter + (can-optimize-access1 (cadr form) + required-parameters env))) + (when parameter + (optimize-reader slots parameter gf-name form)))) + (maybe-optimize-writer () + `(let ((parameter + (can-optimize-access1 (caddr form) + required-parameters env))) + (when parameter + (optimize-writer slots parameter gf-name form))))) + (unless (and (consp (cadr form)) + (eq 'instance-accessor-parameter (caadr form))) + (or #|| + (cond ((and (= len 2) (symbolp fname)) + (let ((gf-name (gethash fname *gf-declared-reader-table*))) + (when gf-name + (maybe-optimize-reader)))) + ((= len 3) + (let ((gf-name (gethash fname *gf-declared-writer-table*))) + (when gf-name + (maybe-optimize-writer))))) + ||# + (when (and (eq *boot-state* 'complete) + (generic-function-p gf)) + (let ((methods (generic-function-methods gf))) + (when methods + (let* ((gf-name (generic-function-name gf)) + (arg-info (gf-arg-info gf)) + (metatypes (arg-info-metatypes arg-info)) + (nreq (length metatypes)) + (applyp (arg-info-applyp arg-info))) + (when (null applyp) + (cond ((= nreq 1) + (when (some #'standard-reader-method-p methods) + (maybe-optimize-reader))) + ((and (= nreq 2) + (consp gf-name) + (eq (car gf-name) 'setf)) + (when (some #'standard-writer-method-p methods) + (maybe-optimize-writer)))))))))))))) + +(defun optimize-generic-function-call (form required-parameters env slots calls) + (declare (ignore required-parameters env slots calls)) + (or (and (eq (car form) 'make-instance) + (expand-make-instance-form form)) + #|| + (maybe-expand-accessor-form form required-parameters slots env) + (let* ((fname (car form)) + (len (length form)) + (gf (if (symbolp fname) + (and (fboundp fname) + (unencapsulated-fdefinition fname)) + (and (gboundp fname) + (gdefinition fname)))) + (gf-name (and (fsc-instance-p gf) + (if (early-gf-p gf) + (early-gf-name gf) + (generic-function-name gf))))) + (when gf-name + (multiple-value-bind (nreq restp) + (get-generic-function-info gf) + (optimize-gf-call slots calls form nreq restp env)))) + ||# + form)) + + + +(defun can-optimize-access (form required-parameters env) + (let ((type (ecase (car form) + (slot-value 'reader) + (set-slot-value 'writer) + (slot-boundp 'boundp))) + (var (cadr form)) + (slot-name (eval (caddr form)))) ; known to be constant + (can-optimize-access1 var required-parameters env type slot-name))) + +(defun can-optimize-access1 (var required-parameters env &optional type slot-name) + (when (and (consp var) (eq 'the (car var))) + (setq var (caddr var))) + (when (symbolp var) + (let* ((rebound? (caddr (variable-declaration 'variable-rebinding var env))) + (parameter-or-nil (car (memq (or rebound? var) required-parameters)))) + (when parameter-or-nil + (let* ((class-name (caddr (variable-declaration + 'class parameter-or-nil env))) + (class (find-class class-name nil))) + (when (or (not (eq *boot-state* 'complete)) + (and class (not (class-finalized-p class)))) + (setq class nil)) + (when (and class-name (not (eq class-name 't))) + (when (or (null type) + (not (and class + (memq *the-class-structure-object* + (class-precedence-list class)))) + (optimize-slot-value-by-class-p class slot-name type)) + (cons parameter-or-nil (or class class-name))))))))) + +(defun optimize-slot-value (slots sparameter form) + (if sparameter + ; FIXME use regular destructuring-bind + (pcl-destructuring-bind (ignore ignore slot-name-form) form + (let ((slot-name (eval slot-name-form))) + (optimize-instance-access slots :read sparameter slot-name nil))) + `(accessor-slot-value ,@(cdr form)))) + +(defun optimize-set-slot-value (slots sparameter form) + (if sparameter + ; FIXME use regular destructuring-bind + (pcl-destructuring-bind (ignore ignore slot-name-form new-value) form + (let ((slot-name (eval slot-name-form))) + (optimize-instance-access slots :write sparameter slot-name new-value))) + `(accessor-set-slot-value ,@(cdr form)))) + +(defun optimize-slot-boundp (slots sparameter form) + (if sparameter + ; FIXME use regular destructuring-bind + (pcl-destructuring-bind (ignore ignore slot-name-form new-value) form + (let ((slot-name (eval slot-name-form))) + (optimize-instance-access slots :boundp sparameter slot-name new-value))) + `(accessor-slot-boundp ,@(cdr form)))) + +(defun optimize-reader (slots sparameter gf-name form) + (if sparameter + (optimize-accessor-call slots :read sparameter gf-name nil) + form)) + +(defun optimize-writer (slots sparameter gf-name form) + (if sparameter + ; FIXME use regular destructuring-bind + (pcl-destructuring-bind (ignore ignore new-value) form + (optimize-accessor-call slots :write sparameter gf-name new-value)) + form)) +;;; +;;; The argument is an alist, the CAR of each entry is the name of +;;; a required parameter to the function. The alist is in order, so the +;;; position of an entry in the alist corresponds to the argument's position +;;; in the lambda list. +;;; +(defun optimize-instance-access (slots read/write sparameter slot-name new-value) + (let ((class (if (consp sparameter) (cdr sparameter) *the-class-t*)) + (parameter (if (consp sparameter) (car sparameter) sparameter))) + (if (and (eq *boot-state* 'complete) + (classp class) + (memq *the-class-structure-object* (class-precedence-list class))) + (let ((slotd (find-slot-definition class slot-name))) + (ecase read/write + (:read + `(,(slot-definition-defstruct-accessor-symbol slotd) ,parameter)) + (:write + `(setf (,(slot-definition-defstruct-accessor-symbol slotd) ,parameter) + ,new-value)) + (:boundp + 'T))) + (let* ((parameter-entry (assq parameter slots)) + (slot-entry (assq slot-name (cdr parameter-entry))) + (position (posq parameter-entry slots)) + (pv-offset-form (list 'pv-offset ''.PV-OFFSET.))) + (unless parameter-entry + (error "Internal error in slot optimization.")) + (unless slot-entry + (setq slot-entry (list slot-name)) + (push slot-entry (cdr parameter-entry))) + (push pv-offset-form (cdr slot-entry)) + (ecase read/write + (:read + `(instance-read ,pv-offset-form ,parameter ,position + ',slot-name ',class)) + (:write + `(let ((.new-value. ,new-value)) + (instance-write ,pv-offset-form ,parameter ,position + ',slot-name ',class .new-value.))) + (:boundp + `(instance-boundp ,pv-offset-form ,parameter ,position + ',slot-name ',class))))))) + +(defun optimize-accessor-call (slots read/write sparameter gf-name new-value) + (let* ((class (if (consp sparameter) (cdr sparameter) *the-class-t*)) + (parameter (if (consp sparameter) (car sparameter) sparameter)) + (parameter-entry (assq parameter slots)) + (name (case read/write + (:read `(reader ,gf-name)) + (:write `(writer ,gf-name)))) + (slot-entry (assoc name (cdr parameter-entry) :test #'equal)) + (position (posq parameter-entry slots)) + (pv-offset-form (list 'pv-offset ''.PV-OFFSET.))) + (unless parameter-entry + (error "Internal error in slot optimization.")) + (unless slot-entry + (setq slot-entry (list name)) + (push slot-entry (cdr parameter-entry))) + (push pv-offset-form (cdr slot-entry)) + (ecase read/write + (:read + `(instance-reader ,pv-offset-form ,parameter ,position ,gf-name ',class)) + (:write + `(let ((.new-value. ,new-value)) + (instance-writer ,pv-offset-form ,parameter ,position ,gf-name ',class + .new-value.)))))) + +(defvar *unspecific-arg* '..unspecific-arg..) + +(defun optimize-gf-call-internal (form slots env) + (when (and (consp form) + (eq (car form) 'the)) + (setq form (caddr form))) + (or (and (symbolp form) + (let* ((rebound? (caddr (variable-declaration 'variable-rebinding + form env))) + (parameter-or-nil (car (assq (or rebound? form) slots)))) + (when parameter-or-nil + (let* ((class-name (caddr (variable-declaration + 'class parameter-or-nil env)))) + (when (and class-name (not (eq class-name 't))) + (position parameter-or-nil slots :key #'car)))))) + (if (constantp form) + (let ((form (eval form))) + (if (symbolp form) + form + *unspecific-arg*)) + *unspecific-arg*))) + +(defun optimize-gf-call (slots calls gf-call-form nreq restp env) + (unless (eq (car gf-call-form) 'make-instance) ; needs more work + (let* ((args (cdr gf-call-form)) + (all-args-p (eq (car gf-call-form) 'make-instance)) + (non-required-args (nthcdr nreq args)) + (required-args (ldiff args non-required-args)) + (call-spec (list (car gf-call-form) nreq restp + (mapcar #'(lambda (form) + (optimize-gf-call-internal form slots env)) + (if all-args-p + args + required-args)))) + (call-entry (assoc call-spec calls :test #'equal)) + (pv-offset-form (list 'pv-offset ''.PV-OFFSET.))) + (unless (some #'integerp + (let ((spec-args (cdr call-spec))) + (if all-args-p + (ldiff spec-args (nthcdr nreq spec-args)) + spec-args))) + (return-from optimize-gf-call nil)) + (unless call-entry + (setq call-entry (list call-spec)) + (push call-entry (cdr calls))) + (push pv-offset-form (cdr call-entry)) + (if (eq (car call-spec) 'make-instance) + `(funcall (pv-ref .pv. ,pv-offset-form) ,@(cdr gf-call-form)) + `(let ((.emf. (pv-ref .pv. ,pv-offset-form))) + (invoke-effective-method-function .emf. ,restp + ,@required-args ,@(when restp `((list ,@non-required-args))))))))) + + +(define-walker-template pv-offset) ; These forms get munged by mutate slots. +(defmacro pv-offset (arg) arg) +(define-walker-template instance-accessor-parameter) +(defmacro instance-accessor-parameter (x) x) + +;; It is safe for these two functions to be wrong. +;; They just try to guess what the most likely case will be. +(defun generate-fast-class-slot-access-p (class-form slot-name-form) + (let ((class (and (constantp class-form) (eval class-form))) + (slot-name (and (constantp slot-name-form) (eval slot-name-form)))) + (and (eq *boot-state* 'complete) + (standard-class-p class) + (not (eq class *the-class-t*)) ; shouldn't happen, though. + (let ((slotd (find-slot-definition class slot-name))) + (and slotd (classp (slot-definition-allocation slotd))))))) + +(defun skip-fast-slot-access-p (class-form slot-name-form type) + (let ((class (and (constantp class-form) (eval class-form))) + (slot-name (and (constantp slot-name-form) (eval slot-name-form)))) + (and (eq *boot-state* 'complete) + (standard-class-p class) + (not (eq class *the-class-t*)) ; shouldn't happen, though. + (let ((slotd (find-slot-definition class slot-name))) + (and slotd (skip-optimize-slot-value-by-class-p class slot-name type)))))) + +(defun skip-optimize-slot-value-by-class-p (class slot-name type) + (let ((slotd (find-slot-definition class slot-name))) + (and slotd + (eq *boot-state* 'complete) + (not (slot-accessor-std-p slotd type))))) + +(defmacro instance-read-internal (pv slots pv-offset default &optional type) + (unless (member type '(nil :instance :class :default)) + (error "Illegal type argument to ~S: ~S" 'instance-read-internal type)) + (if (eq type ':default) + default + (let* ((index (gensym)) + (value index)) + `(locally (declare #.*optimize-speed*) + (let ((,index (pvref ,pv ,pv-offset))) + (setq ,value (typecase ,index + ,@(when (or (null type) (eq type ':instance)) + `((fixnum (%instance-ref ,slots ,index)))) + ,@(when (or (null type) (eq type ':class)) + `((cons (cdr ,index)))) + (t ',*slot-unbound*))) + (if (eq ,value ',*slot-unbound*) + ,default + ,value)))))) + +(defmacro instance-read (pv-offset parameter position slot-name class) + (if (skip-fast-slot-access-p class slot-name 'reader) + `(accessor-slot-value ,parameter ,slot-name) + `(instance-read-internal .pv. ,(slot-vector-symbol position) + ,pv-offset (accessor-slot-value ,parameter ,slot-name) + ,(if (generate-fast-class-slot-access-p class slot-name) + ':class ':instance)))) + +(defmacro instance-reader (pv-offset parameter position gf-name class) + (declare (ignore class)) + `(instance-read-internal .pv. ,(slot-vector-symbol position) + ,pv-offset + (,gf-name (instance-accessor-parameter ,parameter)) + :instance)) + +(defmacro instance-write-internal (pv slots pv-offset new-value default + &optional type) + (unless (member type '(nil :instance :class :default)) + (error "Illegal type argument to ~S: ~S" 'instance-write-internal type)) + (if (eq type ':default) + default + (let* ((index (gensym))) + `(locally (declare #.*optimize-speed*) + (let ((,index (pvref ,pv ,pv-offset))) + (typecase ,index + ,@(when (or (null type) (eq type ':instance)) + `((fixnum (setf (%instance-ref ,slots ,index) ,new-value)))) + ,@(when (or (null type) (eq type ':class)) + `((cons (setf (cdr ,index) ,new-value)))) + (t ,default))))))) + +(defmacro instance-write (pv-offset parameter position slot-name class new-value) + (if (skip-fast-slot-access-p class slot-name 'writer) + `(accessor-set-slot-value ,parameter ,slot-name ,new-value) + `(instance-write-internal .pv. ,(slot-vector-symbol position) + ,pv-offset ,new-value + (accessor-set-slot-value ,parameter ,slot-name ,new-value) + ,(if (generate-fast-class-slot-access-p class slot-name) + ':class ':instance)))) + +(defmacro instance-writer (pv-offset parameter position gf-name class new-value) + (declare (ignore class)) + `(instance-write-internal .pv. ,(slot-vector-symbol position) + ,pv-offset ,new-value + (,(if (consp gf-name) + (get-setf-function-name gf-name) + gf-name) + (instance-accessor-parameter ,parameter) + ,new-value) + :instance)) + +(defmacro instance-boundp-internal (pv slots pv-offset default + &optional type) + (unless (member type '(nil :instance :class :default)) + (error "Illegal type argument to ~S: ~S" 'instance-boundp-internal type)) + (if (eq type ':default) + default + (let* ((index (gensym))) + `(locally (declare #.*optimize-speed*) + (let ((,index (pvref ,pv ,pv-offset))) + (typecase ,index + ,@(when (or (null type) (eq type ':instance)) + `((fixnum (not (eq (%instance-ref ,slots ,index) ',*slot-unbound*))))) + ,@(when (or (null type) (eq type ':class)) + `((cons (not (eq (cdr ,index) ',*slot-unbound*))))) + (t ,default))))))) + +(defmacro instance-boundp (pv-offset parameter position slot-name class) + (if (skip-fast-slot-access-p class slot-name 'boundp) + `(accessor-slot-boundp ,parameter ,slot-name) + `(instance-boundp-internal .pv. ,(slot-vector-symbol position) + ,pv-offset (accessor-slot-boundp ,parameter ,slot-name) + ,(if (generate-fast-class-slot-access-p class slot-name) + ':class ':instance)))) + +;;; +;;; This magic function has quite a job to do indeed. +;;; +;;; The careful reader will recall that contains all of the optimized +;;; slot access forms produced by OPTIMIZE-INSTANCE-ACCESS. Each of these is +;;; a call to either INSTANCE-READ or INSTANCE-WRITE. +;;; +;;; At the time these calls were produced, the first argument was specified as +;;; the symbol .PV-OFFSET.; what we have to do now is convert those pv-offset +;;; arguments into the actual number that is the correct offset into the pv. +;;; +;;; But first, oh but first, we sort a bit so that for each argument +;;; we have the slots in alphabetical order. This canonicalizes the PV-TABLE's a +;;; bit and will hopefully lead to having fewer PV's floating around. Even +;;; if the gain is only modest, it costs nothing. +;;; +(defun slot-name-lists-from-slots (slots calls) + (multiple-value-bind (slots calls) + (mutate-slots-and-calls slots calls) + (let* ((slot-name-lists + (mapcar #'(lambda (parameter-entry) + (cons nil (mapcar #'car (cdr parameter-entry)))) + slots)) + (call-list + (mapcar #'car calls))) + (dolist (call call-list) + (dolist (arg (cdr call)) + (when (integerp arg) + (setf (car (nth arg slot-name-lists)) t)))) + (setq slot-name-lists (mapcar #'(lambda (r+snl) + (when (or (car r+snl) (cdr r+snl)) + r+snl)) + slot-name-lists)) + (let ((cvt (apply #'vector + (let ((i -1)) + (declare (fixnum i)) + (mapcar #'(lambda (r+snl) + (when r+snl (incf i))) + slot-name-lists))))) + (setq call-list (mapcar #'(lambda (call) + (cons (car call) + (mapcar #'(lambda (arg) + (if (integerp arg) + (svref cvt arg) + arg)) + (cdr call)))) + call-list))) + (values slot-name-lists call-list)))) + +(defun mutate-slots-and-calls (slots calls) + (let ((sorted-slots (sort-slots slots)) + (sorted-calls (sort-calls (cdr calls))) + (pv-offset 0)) ; index 0 is for info + (declare (fixnum pv-offset)) + (dolist (parameter-entry sorted-slots) + (dolist (slot-entry (cdr parameter-entry)) + (incf pv-offset) + (dolist (form (cdr slot-entry)) + (setf (cadr form) pv-offset)))) + (dolist (call-entry sorted-calls) + (incf pv-offset) + (dolist (form (cdr call-entry)) + (setf (cadr form) pv-offset))) + (values sorted-slots sorted-calls))) + +(defun symbol-pkg-name (sym) + (let ((pkg (symbol-package sym))) + (if pkg (package-name pkg) ""))) + +(defun symbol-lessp (a b) + (if (eq (symbol-package a) + (symbol-package b)) + (string-lessp (symbol-name a) + (symbol-name b)) + (string-lessp (symbol-pkg-name a) + (symbol-pkg-name b)))) + +(defun symbol-or-cons-lessp (a b) + (etypecase a + (symbol (etypecase b + (symbol (symbol-lessp a b)) + (cons t))) + (cons (etypecase b + (symbol nil) + (cons (if (eq (car a) (car b)) + (symbol-or-cons-lessp (cdr a) (cdr b)) + (symbol-or-cons-lessp (car a) (car b)))))))) + +(defun sort-slots (slots) + (mapcar #'(lambda (parameter-entry) + (cons (car parameter-entry) + (sort (cdr parameter-entry) ;slot entries + #'symbol-or-cons-lessp + :key #'car))) + slots)) + +(defun sort-calls (calls) + (sort calls #'symbol-or-cons-lessp :key #'car)) + + +;;; +;;; This needs to work in terms of metatypes and also needs to work for +;;; automatically generated reader and writer functions. +;;; -- Automatically generated reader and writer functions use this stuff too. + +(defmacro pv-binding ((required-parameters slot-name-lists pv-table-symbol) + &body body) + (with-gathering ((slot-vars (collecting)) + (pv-parameters (collecting))) + (iterate ((slots (list-elements slot-name-lists)) + (required-parameter (list-elements required-parameters)) + (i (interval :from 0))) + (when slots + (gather required-parameter pv-parameters) + (gather (slot-vector-symbol i) slot-vars))) + `(pv-binding1 (.pv. .calls. ,pv-table-symbol ,pv-parameters ,slot-vars) + ,@body))) + +(defmacro pv-binding1 ((pv calls pv-table-symbol pv-parameters slot-vars) + &body body) + `(pv-env (,pv ,calls ,pv-table-symbol ,pv-parameters) + (let (,@(mapcar #'(lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p))) + slot-vars pv-parameters)) + ,@body))) + +;This gets used only when the default make-method-lambda is overriden. +(defmacro pv-env ((pv calls pv-table-symbol pv-parameters) + &rest forms) + `(let* ((.pv-table. ,pv-table-symbol) + (.pv-cell. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters)) + (,pv (car .pv-cell.)) + (,calls (cdr .pv-cell.))) + (declare ,(make-pv-type-declaration pv)) + (declare ,(make-calls-type-declaration calls)) + ,@(when (symbolp pv-table-symbol) + `((declare (special ,pv-table-symbol)))) + ,@(progn + #-cmu `(,pv ,calls) + #+cmu `(declare (ignorable ,pv ,calls))) + ,@forms)) + +(defvar *non-variable-declarations* + '(method-name method-lambda-list + optimize ftype inline notinline)) + +(defvar *variable-declarations-with-argument* + '(class + type)) + +(defvar *variable-declarations-without-argument* + '(ignore special dynamic-extent + array atom base-char bignum bit bit-vector character common compiled-function + complex cons double-float extended-char fixnum float function hash-table integer + keyword list long-float nil null number package pathname random-state ratio + rational readtable sequence short-float signed-byte simple-array + simple-bit-vector simple-string simple-vector single-float standard-char + stream string-char symbol t unsigned-byte vector)) + +(defun split-declarations (body args) + (let ((inner-decls nil) (outer-decls nil) decl) + (loop (when (null body) (return nil)) + (setq decl (car body)) + (unless (and (consp decl) + (eq (car decl) 'declare)) + (return nil)) + (dolist (form (cdr decl)) + (when (consp form) + (let ((declaration-name (car form))) + (if (member declaration-name *non-variable-declarations*) + (push `(declare ,form) outer-decls) + (let ((arg-p + (member declaration-name + *variable-declarations-with-argument*)) + (non-arg-p + (member declaration-name + *variable-declarations-without-argument*)) + (dname (list (pop form))) + (inners nil) (outers nil)) + (unless (or arg-p non-arg-p) + (warn "The declaration ~S is not understood by ~S.~@ + Please put ~S on one of the lists ~S,~%~S, or~%~S.~@ + (Assuming it is a variable declarations without argument)." + declaration-name 'split-declarations + declaration-name + '*non-variable-declarations* + '*variable-declarations-with-argument* + '*variable-declarations-without-argument*) + (push declaration-name + *variable-declarations-without-argument*)) + (when arg-p + (setq dname (append dname (list (pop form))))) + (dolist (var form) + (if (member var args) + (push var outers) + (push var inners))) + (when outers + (push `(declare (,@dname ,@outers)) outer-decls)) + (when inners + (push `(declare (,@dname ,@inners)) inner-decls))))))) + (setq body (cdr body))) + (values outer-decls inner-decls body))) + +(defun make-method-initargs-form-internal (method-lambda initargs env) + (declare (ignore env)) + (let (method-lambda-args lmf lmf-params) + (if (not (and (= 3 (length method-lambda)) + (= 2 (length (setq method-lambda-args (cadr method-lambda)))) + (consp (setq lmf (third method-lambda))) + (eq 'simple-lexical-method-functions (car lmf)) + (eq (car method-lambda-args) (cadr (setq lmf-params (cadr lmf)))) + (eq (cadr method-lambda-args) (caddr lmf-params)))) + `(list* :function #',method-lambda + ',initargs) + (let* ((lambda-list (car lmf-params)) + (nreq 0)(restp nil)(args nil)) + (dolist (arg lambda-list) + (when (member arg '(&optional &rest &key)) + (setq restp t)(return nil)) + (when (eq arg '&aux) (return nil)) + (incf nreq)(push arg args)) + (setq args (nreverse args)) + (setf (getf (getf initargs ':plist) ':arg-info) (cons nreq restp)) + (make-method-initargs-form-internal1 + initargs (cddr lmf) args lmf-params restp))))) + +(defun make-method-initargs-form-internal1 + (initargs body req-args lmf-params restp) + (multiple-value-bind (outer-decls inner-decls body) + (split-declarations body req-args) + (let* ((rest-arg (when restp '.rest-arg.)) + (args+rest-arg (if restp (append req-args (list rest-arg)) req-args))) + `(list* :fast-function + #'(lambda (.pv-cell. .next-method-call. ,@args+rest-arg) + ,@outer-decls + .pv-cell. .next-method-call. + (macrolet ((pv-env ((pv calls pv-table-symbol pv-parameters) + &rest forms) + (declare (ignore pv-table-symbol pv-parameters)) + `(let ((,pv (car .pv-cell.)) + (,calls (cdr .pv-cell.))) + (declare ,(make-pv-type-declaration pv) + ,(make-calls-type-declaration calls)) + ,pv ,calls + ,@forms))) + (fast-lexical-method-functions + (,(car lmf-params) .next-method-call. ,req-args ,rest-arg + ,@(cdddr lmf-params)) + ,@inner-decls + ,@body))) + ',initargs)))) + +;use arrays and hash tables and the fngen stuff to make this much better. +;It doesn't really matter, though, because a function returned by this +;will get called only when the user explicitly funcalls a result of method-function. +;BUT, this is needed to make early methods work. +(defun method-function-from-fast-function (fmf) + (declare (type function fmf)) + (let* ((method-function nil) (pv-table nil) + (arg-info (method-function-get fmf ':arg-info)) + (nreq (car arg-info)) + (restp (cdr arg-info))) + (setq method-function + #'(lambda (method-args next-methods) + (unless pv-table + (setq pv-table (method-function-pv-table fmf))) + (let* ((pv-cell (when pv-table + (get-method-function-pv-cell + method-function method-args pv-table))) + (nm (car next-methods)) + (nms (cdr next-methods)) + (nmc (when nm + (make-method-call :function (if (std-instance-p nm) + (method-function nm) + nm) + :call-method-args (list nms))))) + (if restp + (let* ((rest (nthcdr nreq method-args)) + (args (ldiff method-args rest))) + (apply fmf pv-cell nmc (nconc args (list rest)))) + (apply fmf pv-cell nmc method-args))))) + (let* ((fname (method-function-get fmf :name)) + (name `(,(or (get (car fname) 'method-sym) + (setf (get (car fname) 'method-sym) + (let ((str (symbol-name (car fname)))) + (if (string= "FAST-" str :end2 5) + (intern (subseq str 5) *the-pcl-package*) + (car fname))))) + ,@(cdr fname)))) + (set-function-name method-function name)) + (setf (method-function-get method-function :fast-function) fmf) + method-function)) + +(defun get-method-function-pv-cell (method-function method-args &optional pv-table) + (let ((pv-table (or pv-table (method-function-pv-table method-function)))) + (when pv-table + (let ((pv-wrappers (pv-wrappers-from-all-args pv-table method-args))) + (when pv-wrappers + (pv-table-lookup pv-table pv-wrappers)))))) + +(defun pv-table-lookup-pv-args (pv-table &rest pv-parameters) + (pv-table-lookup pv-table (pv-wrappers-from-pv-args pv-parameters))) + +(defun pv-wrappers-from-pv-args (&rest args) + (let* ((nkeys (length args)) + (pv-wrappers (make-list nkeys)) + w (w-t pv-wrappers)) + (declare (fixnum nkeys)) + (dolist (arg args) + (setq w + #+cmu17 (wrapper-of arg) + #-cmu17 + (cond ((std-instance-p arg) + (std-instance-wrapper arg)) + ((fsc-instance-p arg) + (fsc-instance-wrapper arg)) + (t + #+new-kcl-wrapper + (built-in-wrapper-of arg) + #-new-kcl-wrapper + (built-in-or-structure-wrapper arg)))) + (unless (eq 't (wrapper-state w)) + (setq w (check-wrapper-validity arg))) + (setf (car w-t) w)) + (setq w-t (cdr w-t)) + (when (= nkeys 1) (setq pv-wrappers (car pv-wrappers))) + pv-wrappers)) + +(defun pv-wrappers-from-all-args (pv-table args) + (let ((nkeys 0) + (slot-name-lists (pv-table-slot-name-lists pv-table))) + (declare (fixnum nkeys)) + (dolist (sn slot-name-lists) + (when sn (incf nkeys))) + (let* ((pv-wrappers (make-list nkeys)) + (pv-w-t pv-wrappers)) + (dolist (sn slot-name-lists) + (when sn + (let* ((arg (car args)) + (w (wrapper-of arg))) + (unless w ; can-optimize-access prevents this from happening. + (error "error in pv-wrappers-from-all-args")) + (setf (car pv-w-t) w) + (setq pv-w-t (cdr pv-w-t)))) + (setq args (cdr args))) + (when (= nkeys 1) (setq pv-wrappers (car pv-wrappers))) + pv-wrappers))) + +(defun pv-wrappers-from-all-wrappers (pv-table wrappers) + (let ((nkeys 0) + (slot-name-lists (pv-table-slot-name-lists pv-table))) + (declare (fixnum nkeys)) + (dolist (sn slot-name-lists) + (when sn (incf nkeys))) + (let* ((pv-wrappers (make-list nkeys)) + (pv-w-t pv-wrappers)) + (dolist (sn slot-name-lists) + (when sn + (let ((w (car wrappers))) + (unless w ; can-optimize-access prevents this from happening. + (error "error in pv-wrappers-from-all-wrappers")) + (setf (car pv-w-t) w) + (setq pv-w-t (cdr pv-w-t)))) + (setq wrappers (cdr wrappers))) + (when (= nkeys 1) (setq pv-wrappers (car pv-wrappers))) + pv-wrappers))) diff --git a/pcl/gcl_pcl_walk.lisp b/pcl/gcl_pcl_walk.lisp new file mode 100644 index 0000000..7f2cf6a --- /dev/null +++ b/pcl/gcl_pcl_walk.lisp @@ -0,0 +1,2198 @@ +;;;-*- Mode:LISP; Package:(WALKER LISP 1000); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; +;;; A simple code walker, based IN PART on: (roll the credits) +;;; Larry Masinter's Masterscope +;;; Moon's Common Lisp code walker +;;; Gary Drescher's code walker +;;; Larry Masinter's simple code walker +;;; . +;;; . +;;; boy, thats fair (I hope). +;;; +;;; For now at least, this code walker really only does what PCL needs it to +;;; do. Maybe it will grow up someday. +;;; + +;;; +;;; This code walker used to be completely portable. Now it is just "Real +;;; easy to port". This change had to happen because the hack that made it +;;; completely portable kept breaking in different releases of different +;;; Common Lisps, and in addition it never worked entirely anyways. So, +;;; its now easy to port. To port this walker, all you have to write is one +;;; simple macro and two simple functions. These macros and functions are +;;; used by the walker to manipluate the macroexpansion environments of +;;; the Common Lisp it is running in. +;;; +;;; The code which implements the macroexpansion environment manipulation +;;; mechanisms is in the first part of the file, the real walker follows it. +;;; + +(in-package :walker) + +;;; +;;; The user entry points are walk-form and nested-walked-form. In addition, +;;; it is legal for user code to call the variable information functions: +;;; variable-lexical-p, variable-special-p and variable-class. Some users +;;; will need to call define-walker-template, they will have to figure that +;;; out for themselves. +;;; +(export '(define-walker-template + walk-form + walk-form-expand-macros-p + nested-walk-form + variable-lexical-p + variable-special-p + variable-globally-special-p + *variable-declarations* + variable-declaration + macroexpand-all + )) + + + +;;; +;;; On the following pages are implementations of the implementation specific +;;; environment hacking functions for each of the implementations this walker +;;; has been ported to. If you add a new one, so this walker can run in a new +;;; implementation of Common Lisp, please send the changes back to us so that +;;; others can also use this walker in that implementation of Common Lisp. +;;; +;;; This code just hacks 'macroexpansion environments'. That is, it is only +;;; concerned with the function binding of symbols in the environment. The +;;; walker needs to be able to tell if the symbol names a lexical macro or +;;; function, and it needs to be able to build environments which contain +;;; lexical macro or function bindings. It must be able, when walking a +;;; macrolet, flet or labels form to construct an environment which reflects +;;; the bindings created by that form. Note that the environment created +;;; does NOT have to be sufficient to evaluate the body, merely to walk its +;;; body. This means that definitions do not have to be supplied for lexical +;;; functions, only the fact that that function is bound is important. For +;;; macros, the macroexpansion function must be supplied. +;;; +;;; This code is organized in a way that lets it work in implementations that +;;; stack cons their environments. That is reflected in the fact that the +;;; only operation that lets a user build a new environment is a with-body +;;; macro which executes its body with the specified symbol bound to the new +;;; environment. No code in this walker or in PCL will hold a pointer to +;;; these environments after the body returns. Other user code is free to do +;;; so in implementations where it works, but that code is not considered +;;; portable. +;;; +;;; There are 3 environment hacking tools. One macro which is used for +;;; creating new environments, and two functions which are used to access the +;;; bindings of existing environments. +;;; +;;; WITH-AUGMENTED-ENVIRONMENT +;;; +;;; ENVIRONMENT-FUNCTION +;;; +;;; ENVIRONMENT-MACRO +;;; + +(defun unbound-lexical-function (&rest args) + (declare (ignore args)) + (error "The evaluator was called to evaluate a form in a macroexpansion~%~ + environment constructed by the PCL portable code walker. These~%~ + environments are only useful for macroexpansion, they cannot be~%~ + used for evaluation.~%~ + This error should never occur when using PCL.~%~ + This most likely source of this error is a program which tries to~%~ + to use the PCL portable code walker to build its own evaluator.")) + + +;;; +;;; In Coral Common Lisp, the macroexpansion environment is just a list +;;; of environment entries. The cadr of each element specifies the type +;;; of the element. The only types that interest us are CCL::MACRO and +;;; FUNCTION. In these cases the element is interpreted as follows. +;;; +;;; ( CCL::MACRO . macroexpansion-function) +;;; +;;; ( FUNCTION . ) +;;; +;;; When in the compiler, is a gensym which will be +;;; a variable which bound at run-time to the function. +;;; When in the interpreter, is the actual function. +;;; +;;; +#+:Coral +(progn + +(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)) + +(defun with-augmented-environment-internal (env functions macros) + (dolist (f functions) + (push (list* f 'function (gensym)) env)) + (dolist (m macros) + (push (list* (car m) 'ccl::macro (cadr m)) env)) + env) + +(defun environment-function (env fn) + (let ((entry (assoc fn env :test #'equal))) + (and entry + (eq (cadr entry) 'function) + (cddr entry)))) + +(defun environment-macro (env macro) + (let ((entry (assoc macro env :test #'equal))) + (and entry + (eq (cadr entry) 'ccl::macro) + (cddr entry)))) + +);#+:Coral + + +;;; +;;; Franz Common Lisp is a lot like Coral Lisp. The macroexpansion +;;; environment is just a list of entries. The cadr of each element +;;; specifies the type of the element. The types that interest us +;;; are FUNCTION, EXCL::MACRO, and COMPILER::FUNCTION-VALUE. These +;;; are interpreted as follows: +;;; +;;; ( FUNCTION . ) +;;; +;;; This happens in the interpreter with lexically +;;; bound functions. +;;; +;;; ( COMPILER::FUNCTION-VALUE . ) +;;; +;;; This happens in the compiler. The gensym represents +;;; a variable which will be bound at run time to the +;;; function object. +;;; +;;; ( EXCL::MACRO . ) +;;; +;;; In both interpreter and compiler, this is the +;;; representation used for macro definitions. +;;; +;;; +#+:ExCL +(progn + +(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)) + +(defun with-augmented-environment-internal (env functions macros) + (let (#+allegro-v4.1 (env-tail (cdr env)) #+allegro-v4.1 (env (car env))) + (dolist (f functions) + (push (list* f 'function #'unbound-lexical-function) env)) + (dolist (m macros) + (push (list* (car m) 'excl::macro (cadr m)) env)) + #-allegro-v4.1 env #+allegro-v4.1 (cons env env-tail))) + +(defun environment-function (env fn) + (let* (#+allegro-v4.1 (env (car env)) + (entry (assoc fn env :test #'equal))) + (and entry + (or (eq (cadr entry) 'function) + (eq (cadr entry) 'compiler::function-value)) + (cddr entry)))) + +(defun environment-macro (env macro) + (let* (#+allegro-v4.1 (env (car env)) + (entry (assoc macro env :test #'equal))) + (and entry + (eq (cadr entry) 'excl::macro) + (cddr entry)))) + +);#+:ExCL + + +#+Lucid +(progn + +(proclaim '(inline + %alphalex-p + add-contour-to-env-shape + make-function-variable + make-sfc-contour + sfc-contour-type + sfc-contour-elements + add-sfc-contour + add-function-contour + add-macrolet-contour + find-variable-in-contour + find-alist-element-in-contour + find-macrolet-in-contour)) + +(defun %alphalex-p (object) + #-Prime + (eq (cadddr (cddddr object)) 'lucid::%alphalex) + #+Prime + (eq (caddr (cddddr object)) 'lucid::%alphalex)) + +#+Prime +(defun lucid::augment-lexenv-fvars-dummy (lexical vars) + (lucid::augment-lexenv-fvars-aux lexical vars '() '() 'flet '())) + +#-lcl4.0 ; Maybe this should be #-lcl4.1 +(progn +(defconstant function-contour 1) +(defconstant macrolet-contour 5)) +#+lcl4.0 ; Maybe this should be #+lcl4.1 +(progn +(defconstant function-contour 2) +(defconstant macrolet-contour 6)) + +(defstruct lucid::contour + type + elements) + +(defun add-contour-to-env-shape (contour-type elements env-shape) + (cons (make-contour :type contour-type + :elements elements) + env-shape)) + +(defstruct (variable (:constructor make-variable (name source-type))) + name + (identifier nil) + source-type) + +(defconstant function-sfc-contour 1) +(defconstant macrolet-sfc-contour 8) +(defconstant function-variable-type 1) + +(defun make-function-variable (name) + (make-variable name function-variable-type)) + +(defun make-sfc-contour (type elements) + (cons type elements)) + +(defun sfc-contour-type (sfc-contour) + (car sfc-contour)) + +(defun sfc-contour-elements (sfc-contour) + (cdr sfc-contour)) + +(defun add-sfc-contour (element-list environment type) + (cons (make-sfc-contour type element-list) environment)) + +(defun add-function-contour (variable-list environment) + (add-sfc-contour variable-list environment function-sfc-contour)) + +(defun add-macrolet-contour (alist environment) + (add-sfc-contour alist environment macrolet-sfc-contour)) + +(defun find-variable-in-contour (name contour) + (dolist (element (sfc-contour-elements contour) nil) + (when (eq (variable-name element) name) + (return element)))) + +(defun find-alist-element-in-contour (name contour) + (cdr (assoc name (sfc-contour-elements contour)))) + +(defun find-macrolet-in-contour (name contour) + (find-alist-element-in-contour name contour)) + +(defmacro do-sfc-contours ((contour-var environment &optional result) + &body body) + `(dolist (,contour-var ,environment ,result) ,@body)) + + +(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)) + +;;; +;;; with-augmented-environment-internal is where the real work of augmenting +;;; the environment happens. +;;; +(defun with-augmented-environment-internal (env functions macros) + (let ((function-names (mapcar #'first functions)) + (macro-names (mapcar #'first macros)) + (macro-functions (mapcar #'second macros))) + (cond ((or (null env) + (contour-p (first env))) + (when function-names + (setq env (add-contour-to-env-shape function-contour + function-names + env))) + (when macro-names + (setq env (add-contour-to-env-shape macrolet-contour + (pairlis macro-names + macro-functions) + env)))) + ((%alphalex-p env) + (when function-names + (setq env (lucid::augment-lexenv-fvars-dummy env function-names))) + (when macro-names + (setq env (lucid::augment-lexenv-mvars env + macro-names + macro-functions)))) + (t + (when function-names + (setq env (add-function-contour + (mapcar #'make-function-variable function-names) + env))) + (when macro-names + (setq env (add-macrolet-contour + (pairlis macro-names macro-functions) + env))))) + env)) + + +(defun environment-function (env fn) + (cond ((null env) nil) + ((contour-p (first env)) + (if (lucid::find-lexical-function fn env) + t + nil)) + ((%alphalex-p env) + (if (lucid::lexenv-fvar fn env) + t + nil)) + (t (do-sfc-contours (contour env nil) + (let ((type (sfc-contour-type contour))) + (cond ((eql type function-sfc-contour) + (when (find-variable-in-contour fn contour) + (return t))) + ((eql type macrolet-sfc-contour) + (when (find-macrolet-in-contour fn contour) + (return nil))))))))) + +(defun environment-macro (env macro) + (cond ((null env) nil) + ((contour-p (first env)) + (lucid::find-lexical-macro macro env)) + ((%alphalex-p env) + (lucid::lexenv-mvar macro env)) + (t (do-sfc-contours (contour env nil) + (let ((type (sfc-contour-type contour))) + (cond ((eql type function-sfc-contour) + (when (find-variable-in-contour macro contour) + (return nil))) + ((eql type macrolet-sfc-contour) + (let ((fn (find-macrolet-in-contour macro contour))) + (when fn + (return fn)))))))))) + + +);#+Lucid + + + +;;; +;;; On the 3600, the documentation for how the environments are represented +;;; is in sys:sys;eval.lisp. That total information is not repeated here. +;;; The important points are that: +;;; si:env-variables returns a list of which each element is: +;;; +;;; (symbol value) +;;; or (symbol . locative) +;;; +;;; The first form is for lexical variables, the second for +;;; special and instance variables. In either case CADR of +;;; the entry is the value and SETF of CADR is used to change +;;; the value. Variables are looked up with ASSQ. +;;; +;;; si:env-functions returns a list of which each element is: +;;; +;;; (symbol definition) +;;; +;;; where definition is anything that could go in a function cell. +;;; This is used for both local functions and local macros. +;;; +;;; The 3600 stack conses its environments (at least in the interpreter). +;;; This means that code written using this walker and running on the 3600 +;;; must not hold on to the environment after the walk-function returns. +;;; No code in this walker or in PCL does that. +;;; +#+Genera +(progn + +(defmacro with-augmented-environment + ((new-env old-env &key functions macros) &body body) + (let ((funs (make-symbol "FNS")) + (macs (make-symbol "MACROS")) + (new (make-symbol "NEW"))) + `(let ((,funs ,functions) + (,macs ,macros) + (,new ())) + (dolist (f ,funs) + (push `(,(car f) ,#'unbound-lexical-function) ,new)) + (dolist (m ,macs) + (push `(,(car m) (special ,(cadr m))) ,new)) + (let* ((.old-env. ,old-env) + (.old-vars. (pop .old-env.)) + (.old-funs. (pop .old-env.)) + (.old-blks. (pop .old-env.)) + (.old-tags. (pop .old-env.)) + (.old-dcls. (pop .old-env.))) + (si:with-interpreter-environment (,new-env + .old-env. + .old-vars. + (append ,new .old-funs.) + .old-blks. + .old-tags. + .old-dcls.) + ,@body))))) + + +(defun environment-function (env fn) + (if (null env) + (values nil nil) + (let ((entry (assoc fn (si:env-functions env) :test #'equal))) + (if (and entry + (or (not (listp (cadr entry))) + (not (eq (caadr entry) 'special)))) + (values (cadr entry) t) + (environment-function (si:env-parent env) fn))))) + +(defun environment-macro (env macro) + (if (null env) + (values nil nil) + (let ((entry (assoc macro (si:env-functions env) :test #'equal))) + (if (and entry + (listp (cadr entry)) + (eq (caadr entry) 'special)) + (values (cadadr entry) t) + (environment-macro (si:env-parent env) macro))))) + +);#+Genera + +#+Cloe-Runtime +(progn + +(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)) + +(defun with-augmented-environment-internal (env functions macros) + functions + (dolist (m macros) + (setf env `(,(first m) (compiler::macro . ,(second m)) ,@env))) + env) + +(defun environment-function (env fn) + nil) + +(defun environment-macro (env macro) + (let ((entry (getf env macro))) + (if (and (consp entry) + (eq (car entry) 'compiler::macro)) + (values (cdr entry) t) + (values nil nil)))) + +);#+Cloe-Runtime + + +;;; +;;; In Xerox Lisp, the compiler and interpreter use different structures for +;;; the environment. This doesn't cause a serious problem, the parts of the +;;; environments we are concerned with are fairly similar. +;;; +#+:Xerox +(progn + +(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)) + +;;; +;;; with-augmented-environment-internal is where the real work of augmenting +;;; the environment happens. Before it gets there, env had better not be NIL +;;; anymore because we have to know what kind of environment we are supposed +;;; to be building up. This is probably never a real concern in practice. +;;; It better not be because we don't do anything about it. +;;; +(defun with-augmented-environment-internal (env functions macros) + (cond + ((compiler::env-p env) + (dolist (f functions) + (setq env (compiler::copy-env-with-function + env f :function))) + (dolist (m macros) + (setq env (compiler::copy-env-with-function + env (car m) :macro (cadr m))))) + (t (setq env (if (il:environment-p env) + (il:\\copy-environment env) + (il:\\make-environment))) + ;; The functions field of the environment is a plist of function names + ;; and conses like (:function . fn) or (:macro . expansion-fn). + ;; Note that we can't smash existing entries in this plist since these + ;; are likely shared with older environments. + (dolist (f functions) + (setf (il:environment-functions env) + (list* f (cons :function #'unbound-lexical-function) + (il:environment-functions env)))) + (dolist (m macros) + (setf (il:environment-functions env) + (list* (car m) (cons :macro (cadr m)) + (il:environment-functions env)))))) + env) + +(defun environment-function (env fn) + (cond ((compiler::env-p env) (eq (compiler:env-fboundp env fn) :function)) + ((il:environment-p env) (eq (getf (il:environment-functions env) fn) + :function)) + (t nil))) + +(defun environment-macro (env macro) + (cond ((compiler::env-p env) + (multiple-value-bind (type def) + (compiler:env-fboundp env macro) + (when (eq type :macro) def))) + ((il:environment-p env) + (xcl:destructuring-bind (type . def) + (getf (il:environment-functions env) macro) + (when (eq type :macro) def))) + (t nil))) + +);#+:Xerox + + +;;; +;;; In IBUKI Common Lisp, the macroexpansion environment is a three element +;;; list. The second element describes lexical functions and macros. The +;;; function entries in this list have the form +;;; ( . (FUNCTION . ( . nil)) +;;; The macro entries have the form +;;; ( . (MACRO . ( . nil)). +;;; +;;; +#+(or KCL IBCL) +(progn + +(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)) + +(defun with-augmented-environment-internal (env functions macros) + (let ((first (first env)) + (lexicals (second env)) + (third (third env))) + (dolist (f functions) + (push `(,(car f) . (function . (,#'unbound-lexical-function . nil))) + lexicals)) + (dolist (m macros) + (push `(,(car m) . (macro . ( ,(cadr m) . nil))) + lexicals)) + (list first lexicals third))) + +(defun environment-function (env fn) + (when env + (let ((entry (assoc fn (second env)))) + (and entry + (eq (cadr entry) 'function) + (caddr entry))))) + +(defun environment-macro (env macro) + (when env + (let ((entry (assoc macro (second env)))) + (and entry + (eq (cadr entry) 'macro) + (caddr entry))))) +);#+(or KCL IBCL) + + +;;; --- TI Explorer -- + +;;; An environment is a two element list, whose car we can ignore and +;;; whose cadr is list of the local-definitions-frames. Each +;;; local-definitions-frame holds either macros or functions, but not +;;; both. Each frame is a plist of ... where +;;; is a locative to the function cell of the symbol that names +;;; the function or macro, and is the new def or NIL if this is function +;;; redefinition or (cons 'ticl:macro ) if this is a macro +;;; redefinition. +;;; +;;; Here's an example. For the form: +;;; (defun foo () +;;; (macrolet ((bar (a b) (list a b)) +;;; (bar2 (a b) (list a b))) +;;; (flet ((some-local-fn (c d) (print (list c d))) +;;; (another (c d) (print (list c d)))) +;;; (bar (some-local-fn 1 2) 3)))) + +;;; the environment arg to macroexpand-1 when called on +;;; (bar (some-local-fn 1 2) 3) +;;;is +;;;(NIL ((# NIL +;;; # NIL) +;;; (# +;;; (TICL:MACRO TICL:NAMED-LAMBDA (BAR (:DESCRIPTIVE-ARGLIST (A B))) +;;; (SYS::*MACROARG* &OPTIONAL SYS::*MACROENVIRONMENT*) +;;; (BLOCK BAR ....)) +;;; # +;;; (TICL:MACRO TICL:NAMED-LAMBDA (BAR2 (:DESCRIPTIVE-ARGLIST (A B))) +;;; (SYS::*MACROARG* &OPTIONAL SYS::*MACROENVIRONMENT*) +;;; (BLOCK BAR2 ....)))) +#+TI +(progn + +;;; from sys:site;macros.lisp +(eval-when (compile load eval) + +(DEFMACRO MACRO-DEF? (thing) + `(AND (CONSP ,thing) (EQ (CAR ,thing) 'TICL::MACRO))) + +;; the following macro generates code to check the 'local' environment +;; for a macro definition for THE SYMBOL . Such a definition would +;; be set up only by a MACROLET. If a macro definition for is +;; found, its expander function is returned. + +(DEFMACRO FIND-LOCAL-DEFINITION (name local-function-environment) + `(IF ,local-function-environment + (LET ((vcell (ticl::LOCF (SYMBOL-FUNCTION ,name)))) + (DOLIST (frame ,local-function-environment) + ;; is nil or a locative + (LET ((value (sys::GET-LOCATION-OR-NIL (ticl::LOCF frame) + vcell))) + (When value (RETURN (CAR value)))))) + nil))) + + +;;;Edited by Reed Hastings 13 Jan 88 16:29 +(defun environment-macro (env macro) + "returns what macro-function would, ie. the expansion function" + ;;some code picked off macroexpand-1 + (let* ((local-definitions (cadr env)) + (local-def (find-local-definition macro local-definitions))) + (if (macro-def? local-def) + (cdr local-def)))) + +;;;Edited by Reed Hastings 13 Jan 88 16:29 +;;;Edited by Reed Hastings 7 Mar 88 19:07 +(defun environment-function (env fn) + (let* ((local-definitions (cadr env))) + (dolist (frame local-definitions) + (let ((val (getf frame + (ticl::locf (symbol-function fn)) + :not-found-marker))) + (cond ((eq val :not-found-marker)) + ((functionp val) (return t)) + ((and (listp val) + (eq (car val) 'ticl::macro)) + (return nil)) + (t + (error "we are confused"))))))) + + +;;;Edited by Reed Hastings 13 Jan 88 16:29 +;;;Edited by Reed Hastings 7 Mar 88 19:07 +(defun with-augmented-environment-internal (env functions macros) + (let ((local-definitions (cadr env)) + (new-local-fns-frame + (mapcan #'(lambda (fn) + (list (ticl:locf (symbol-function (car fn))) + #'unbound-lexical-function)) + functions)) + (new-local-macros-frame + (mapcan #'(lambda (m) + (list (ticl:locf (symbol-function (car m))) (cons 'ticl::macro (cadr m)))) + macros))) + (when new-local-fns-frame + (push new-local-fns-frame local-definitions)) + (when new-local-macros-frame + (push new-local-macros-frame local-definitions)) + `(,(car env) ,local-definitions))) + + +;;;Edited by Reed Hastings 7 Mar 88 19:07 +(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)) + +);#+TI + + +#+(and dec vax common) +(progn + +(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)) + +(defun with-augmented-environment-internal (env functions macros) + #'(lambda (op &optional (arg nil arg-p)) + (cond ((eq op :macro-function) + (unless arg-p (error "Invalid environment use.")) + (lookup-macro-function arg env functions macros)) + (arg-p + (error "Invalid environment operation: ~S ~S" op arg)) + (t + (lookup-macro-function op env functions macros))))) + +(defun lookup-macro-function (name env fns macros) + (let ((m (assoc name macros))) + (cond (m (cadr m)) + ((assoc name fns) :function) + (env (funcall env name)) + (t nil)))) + +(defun environment-macro (env macro) + (let ((m (and env (funcall env macro)))) + (and (not (eq m :function)) + m))) + +;;; Nobody calls environment-function. What would it return, anyway? +);#+(and dec vax common) + + +;;; +;;; In Golden Common Lisp, the macroexpansion environment is just a list +;;; of environment entries. Unless the car of the list is :compiler-menv +;;; it is an interpreted environment. The cadr of each element specifies +;;; the type of the element. The only types that interest us are GCL:MACRO +;;; and FUNCTION. In these cases the element is interpreted as follows. +;;; +;;; Compiled: +;;; ( macroexpansion-function) +;;; ( ) +;;; +;;; Interpreted: +;;; ( GCL:MACRO macroexpansion-function) +;;; ( ) +;;; +;;; When in the compiler, is a gensym which will be +;;; a variable which bound at run-time to the function. +;;; When in the interpreter, is the actual function. +;;; +;;; +#+gclisp +(progn + +(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)) + +(defun with-augmented-environment-internal (env functions macros) + (let ((new-entries nil)) + (dolist (f functions) + (push (cons (car f) nil) new-entries)) + (dolist (m macros) + (push (cons (car m) + (if (eq :compiler-menv (car env)) + (if (eq (caadr m) 'lisp::lambda) + `(,(gensym) ,(cadr m)) + `(,(gensym) ,@(cadr m))) + `(gclisp:MACRO ,@(cadr m)))) + new-entries)) + (if (eq :compiler-menv (car env)) + `(:compiler-menv ,@new-entries ,@(cdr env)) + (append new-entries env)))) + +(defun environment-function (env fn) + (let ((entry (lisp::lexical-function fn env))) + (and entry + (eq entry 'lisp::lexical-function) + fn))) + +(defun environment-macro (env macro) + (let ((entry (assoc macro (if (eq :compiler-menv (first env)) + (rest env) + env)))) + (and entry + (consp entry) + (symbolp (car entry)) ;name + (symbolp (cadr entry)) ;gcl:macro or gensym + (nthcdr 2 entry)))) + +);#+gclisp + + +;;;; CMU Common Lisp version of environment frobbing stuff. + +;;; In CMU Common Lisp, the environment is represented with a structure +;;; that holds alists for the functional things, variables, blocks, etc. +;;; Only the c::lexenv-functions slot is relevent. It holds: +;;; Alist (name . what), where What is either a Functional (a local function) +;;; or a list (MACRO . ) (a local macro, with the specifier +;;; expander.) Note that Name may be a (SETF ) function. + +#+:CMU +(progn + +(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)) + +(defun with-augmented-environment-internal (env functions macros) + ;; Note: In order to record the correct function definition, we would + ;; have to create an interpreted closure, but the with-new-definition + ;; macro down below makes no distinction between flet and labels, so + ;; we have no idea what to use for the environment. So we just blow it + ;; off, 'cause anything real we do would be wrong. We still have to + ;; make an entry so we can tell functions from macros. + (let ((env (or env (c::make-null-environment)))) + (c::make-lexenv + :default env + :functions + (append (mapcar #'(lambda (f) + (cons (car f) (c::make-functional :lexenv env))) + functions) + (mapcar #'(lambda (m) + (list* (car m) 'c::macro + (coerce (cadr m) 'function))) + macros))))) + +(defun environment-function (env fn) + (when env + (let ((entry (assoc fn (c::lexenv-functions env) :test #'equal))) + (and entry + (c::functional-p (cdr entry)) + (cdr entry))))) + +(defun environment-macro (env macro) + (when env + (let ((entry (assoc macro (c::lexenv-functions env) :test #'eq))) + (and entry + (eq (cadr entry) 'c::macro) + (function-lambda-expression (cddr entry)))))) + +); end of #+:CMU + + + +(defmacro with-new-definition-in-environment + ((new-env old-env macrolet/flet/labels-form) &body body) + (let ((functions (make-symbol "Functions")) + (macros (make-symbol "Macros"))) + `(let ((,functions ()) + (,macros ())) + (ecase (car ,macrolet/flet/labels-form) + ((flet labels) + (dolist (fn (cadr ,macrolet/flet/labels-form)) + (push fn ,functions))) + ((macrolet) + (dolist (mac (cadr ,macrolet/flet/labels-form)) + (push (list (car mac) + (convert-macro-to-lambda (cadr mac) + (cddr mac) + (string (car mac)))) + ,macros)))) + (with-augmented-environment + (,new-env ,old-env :functions ,functions :macros ,macros) + ,@body)))) + +#-Genera +(defun convert-macro-to-lambda (llist body &optional (name "Dummy Macro")) + (let ((gensym (make-symbol name))) + (eval `(defmacro ,gensym ,llist ,@body)) + (macro-function gensym))) + +#+Genera +(defun convert-macro-to-lambda (llist body &optional (name "Dummy Macro")) + (si:defmacro-1 + 'sys:named-lambda 'sys:special (make-symbol name) llist body)) + + + + + +;;; +;;; Now comes the real walker. +;;; +;;; As the walker walks over the code, it communicates information to itself +;;; about the walk. This information includes the walk function, variable +;;; bindings, declarations in effect etc. This information is inherently +;;; lexical, so the walker passes it around in the actual environment the +;;; walker passes to macroexpansion functions. This is what makes the +;;; nested-walk-form facility work properly. +;;; +(defmacro walker-environment-bind ((var env &rest key-args) + &body body) + `(with-augmented-environment + (,var ,env :macros (walker-environment-bind-1 ,env ,.key-args)) + .,body)) + +(defvar *key-to-walker-environment* (gensym)) + +(defun env-lock (env) + (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)) + (let ((lock (environment-macro env *key-to-walker-environment*))) + (list + (list *key-to-walker-environment* + (list (if wfnp walk-function (car lock)) + (if wfop walk-form (cadr lock)) + (if decp declarations (caddr lock)) + (if lexp lexical-variables (cadddr lock))))))) + +(defun env-walk-function (env) + (car (env-lock env))) + +(defun env-walk-form (env) + (cadr (env-lock env))) + +(defun env-declarations (env) + (caddr (env-lock env))) + +(defun env-lexical-variables (env) + (cadddr (env-lock env))) + + +(defun note-declaration (declaration env) + (push declaration (caddr (env-lock env)))) + +(defun note-lexical-binding (thing env) + (push (list thing :lexical-var) (cadddr (env-lock env)))) + +(defun VARIABLE-LEXICAL-P (var env) + (let ((entry (member var (env-lexical-variables env) :key #'car))) + (when (eq (cadar entry) :lexical-var) + entry))) + +(defun variable-symbol-macro-p (var env) + (let ((entry (member var (env-lexical-variables env) :key #'car))) + (when (eq (cadar entry) :macro) + entry))) + + +(defvar *VARIABLE-DECLARATIONS* '(special)) + +(defun VARIABLE-DECLARATION (declaration var env) + (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) + (eq (cadr decl) id)) + (return decl)))))) + +(defun VARIABLE-SPECIAL-P (var env) + (or (not (null (variable-declaration 'special var env))) + (variable-globally-special-p var))) + +;;; +;;; VARIABLE-GLOBALLY-SPECIAL-P is used to ask if a variable has been +;;; declared globally special. Any particular CommonLisp implementation +;;; should customize this function accordingly and send their customization +;;; back. +;;; +;;; The default version of variable-globally-special-p is probably pretty +;;; slow, so it uses *globally-special-variables* as a cache to remember +;;; variables that it has already figured out are globally special. +;;; +;;; This would need to be reworked if an unspecial declaration got added to +;;; Common Lisp. +;;; +;;; Common Lisp nit: +;;; variable-globally-special-p should be defined in Common Lisp. +;;; +#-(or Genera Cloe-Runtime Lucid Xerox Excl KCL IBCL (and dec vax common) :CMU HP-HPLabs + GCLisp TI pyramid) +(defvar *globally-special-variables* ()) + +(defun variable-globally-special-p (symbol) + #+Genera (si:special-variable-p symbol) + #+Cloe-Runtime (compiler::specialp symbol) + #+Lucid (lucid::proclaimed-special-p symbol) + #+TI (get symbol 'special) + #+Xerox (il:variable-globally-special-p symbol) + #+(and dec vax common) (get symbol 'system::globally-special) + #+(or KCL IBCL) (si:specialp symbol) + #+excl (get symbol 'excl::.globally-special.) + #+:CMU (eq (ext:info variable kind symbol) :special) + #+HP-HPLabs (member (get symbol 'impl:vartype) + '(impl:fluid impl:global) + :test #'eq) + #+:GCLISP (gclisp::special-p symbol) + #+pyramid (or (get symbol 'lisp::globally-special) + (get symbol + 'clc::globally-special-in-compiler)) + #+:CORAL (ccl::proclaimed-special-p symbol) + #-(or Genera Cloe-Runtime Lucid Xerox Excl KCL IBCL (and dec vax common) :CMU HP-HPLabs + GCLisp TI pyramid :CORAL) + (or (not (null (member symbol *globally-special-variables* :test #'eq))) + (when (eval `(flet ((ref () ,symbol)) + (let ((,symbol '#,(list nil))) + (and (boundp ',symbol) (eq ,symbol (ref)))))) + (push symbol *globally-special-variables*) + t))) + + + ;; +;;;;;; Handling of special forms (the infamous 24). + ;; +;;; +;;; and I quote... +;;; +;;; The set of special forms is purposely kept very small because +;;; any program analyzing program (read code walker) must have +;;; special knowledge about every type of special form. Such a +;;; program needs no special knowledge about macros... +;;; +;;; So all we have to do here is a define a way to store and retrieve +;;; templates which describe how to walk the 24 special forms and we are all +;;; set... +;;; +;;; Well, its a nice concept, and I have to admit to being naive enough that +;;; I believed it for a while, but not everyone takes having only 24 special +;;; forms as seriously as might be nice. There are (at least) 3 ways to +;;; lose: +;; +;;; 1 - Implementation x implements a Common Lisp special form as a macro +;;; which expands into a special form which: +;;; - Is a common lisp special form (not likely) +;;; - Is not a common lisp special form (on the 3600 IF --> COND). +;;; +;;; * We can safe ourselves from this case (second subcase really) by +;;; checking to see if there is a template defined for something +;;; before we check to see if we we can macroexpand it. +;;; +;;; 2 - Implementation x implements a Common Lisp macro as a special form. +;;; +;;; * This is a screw, but not so bad, we save ourselves from it by +;;; defining extra templates for the macros which are *likely* to +;;; be implemented as special forms. (DO, DO* ...) +;;; +;;; 3 - Implementation x has a special form which is not on the list of +;;; Common Lisp special forms. +;;; +;;; * This is a bad sort of a screw and happens more than I would like +;;; to think, especially in the implementations which provide more +;;; than just Common Lisp (3600, Xerox etc.). +;;; The fix is not terribly staisfactory, but will have to do for +;;; now. There is a hook in get walker-template which can get a +;;; template from the implementation's own walker. That template +;;; has to be converted, and so it may be that the right way to do +;;; this would actually be for that implementation to provide an +;;; interface to its walker which looks like the interface to this +;;; walker. +;;; + +(eval-when (compile load eval) + +(defmacro get-walker-template-internal (x) ;Has to be inside eval-when because + `(get ,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)))) + `(eval-when (load eval) + (setf (get-walker-template-internal ',name) ',template))) +) + +(defun get-walker-template (x) + (cond ((symbolp x) + (or (get-walker-template-internal x) + (get-implementation-dependent-walker-template x))) + ((and (listp x) + (or (eq (car x) 'lambda) + #+cmu17 (eq (car x) 'kernel:instance-lambda))) + '(lambda repeat (eval))) + (t + (error "Can't get template for ~S" x)))) + +(defun get-implementation-dependent-walker-template (x) + (declare (ignore x)) + ()) + + + ;; +;;;;;; The actual templates + ;; + +(define-walker-template BLOCK (NIL NIL REPEAT (EVAL))) +(define-walker-template CATCH (NIL EVAL REPEAT (EVAL))) +(define-walker-template COMPILER-LET walk-compiler-let) +(define-walker-template DECLARE walk-unexpected-declare) +(define-walker-template EVAL-WHEN (NIL QUOTE REPEAT (EVAL))) +(define-walker-template FLET walk-flet) +(define-walker-template FUNCTION (NIL CALL)) +(define-walker-template GO (NIL QUOTE)) +(define-walker-template IF walk-if) +(define-walker-template LABELS walk-labels) +(define-walker-template LAMBDA walk-lambda) +(define-walker-template LET walk-let) +(define-walker-template LET* walk-let*) +(define-walker-template LOCALLY walk-locally) +(define-walker-template MACROLET walk-macrolet) +(define-walker-template MULTIPLE-VALUE-CALL (NIL EVAL REPEAT (EVAL))) +(define-walker-template MULTIPLE-VALUE-PROG1 (NIL RETURN REPEAT (EVAL))) +(define-walker-template MULTIPLE-VALUE-SETQ walk-multiple-value-setq) +(define-walker-template MULTIPLE-VALUE-BIND walk-multiple-value-bind) +(define-walker-template PROGN (NIL REPEAT (EVAL))) +(define-walker-template PROGV (NIL EVAL EVAL REPEAT (EVAL))) +(define-walker-template QUOTE (NIL QUOTE)) +(define-walker-template RETURN-FROM (NIL QUOTE REPEAT (RETURN))) +(define-walker-template SETQ walk-setq) +(define-walker-template SYMBOL-MACROLET walk-symbol-macrolet) +(define-walker-template TAGBODY walk-tagbody) +(define-walker-template THE (NIL QUOTE EVAL)) +#+cmu(define-walker-template EXT:TRULY-THE (NIL QUOTE EVAL)) +(define-walker-template THROW (NIL EVAL EVAL)) +(define-walker-template UNWIND-PROTECT (NIL RETURN REPEAT (EVAL))) + +;;; The new special form. +;(define-walker-template pcl::LOAD-TIME-EVAL (NIL EVAL)) + +;;; +;;; And the extra templates... +;;; +(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))))) + +#+Genera +(progn + (define-walker-template zl::named-lambda walk-named-lambda) + (define-walker-template SCL:LETF walk-let) + (define-walker-template SCL:LETF* walk-let*) + ) + +#+Lucid +(progn + (define-walker-template #+LCL3.0 lucid-common-lisp:named-lambda + #-LCL3.0 sys:named-lambda walk-named-lambda) + ) + +#+(or KCL IBCL) +(progn + (define-walker-template lambda-block walk-named-lambda);Not really right, + ;we don't hack block + ;names anyways. + ) + +#+TI +(progn + (define-walker-template TICL::LET-IF walk-let-if) + ) + +#+:Coral +(progn + (define-walker-template ccl:%stack-block walk-let) + ) + +#+cmu17 +(progn + (define-walker-template kernel:instance-lambda walk-lambda) + ) + + + +(defvar walk-form-expand-macros-p nil) + +(defun macroexpand-all (form &optional environment) + (let ((walk-form-expand-macros-p t)) + (walk-form form environment))) + +(defun WALK-FORM (form + &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))) + +;;; +;;; nested-walk-form provides an interface that allows nested macros, each +;;; of which must walk their body to just do one walk of the body of the +;;; inner macro. That inner walk is done with a walk function which is the +;;; composition of the two walk functions. +;;; +;;; This facility works by having the walker annotate the environment that +;;; it passes to macroexpand-1 to know which form is being macroexpanded. +;;; If then the &whole argument to the macroexpansion function is eq to +;;; the env-walk-form of the environment, nested-walk-form can be certain +;;; that there are no intervening layers and that a nested walk is alright. +;;; +;;; There are some semantic problems with this facility. In particular, if +;;; the outer walk function returns T as its walk-no-more-p value, this will +;;; prevent the inner walk function from getting a chance to walk the subforms +;;; of the form. This is almost never what you want, since it destroys the +;;; equivalence between this nested-walk-form function and two seperate +;;; walk-forms. +;;; +(defun NESTED-WALK-FORM (whole + 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))))))) + (walk-form form environment walk-function))) + +;;; +;;; WALK-FORM-INTERNAL is the main driving function for the code walker. It +;;; takes a form and the current context and walks the form calling itself or +;;; the appropriate template recursively. +;;; +;;; "It is recommended that a program-analyzing-program process a form +;;; that is a list whose car is a symbol as follows: +;;; +;;; 1. If the program has particular knowledge about the symbol, +;;; process the form using special-purpose code. All of the +;;; standard special forms should fall into this category. +;;; 2. Otherwise, if macro-function is true of the symbol apply +;;; either macroexpand or macroexpand-1 and start over. +;;; 3. Otherwise, assume it is a function call. " +;;; + +(defun walk-form-internal (form context env) + ;; 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... + (catch form + (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))) + (t + (let* ((fn (car newform)) + (template (get-walker-template fn))) + (if template + (if (symbolp template) + (funcall template newform context env) + (walk-template newform template context env)) + (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)) + #+cmu17 + (special-operator-p fn) + #-cmu17 + (special-form-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)))))))))))) + +(defun walk-template (form template context env) + (if (atom template) + (ecase template + ((EVAL FUNCTION TEST EFFECT RETURN) + (walk-form-internal form :EVAL env)) + ((QUOTE NIL) form) + (SET + (walk-form-internal form :SET env)) + ((LAMBDA CALL) + (cond ((or (symbolp form) + (and (listp form) + (= (length form) 2) + (eq (car form) 'setf))) + form) + #+Lispm + ((sys:validate-function-spec form) 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)) + context + env)) + (IF + (walk-template form + (if (if (listp (cadr template)) + (eval (cadr template)) + (funcall (cadr template) form)) + (caddr template) + (cadddr template)) + context + env)) + (REMOTE + (walk-template form (cadr template) context env)) + (otherwise + (cond ((atom form) form) + (t (recons form + (walk-template + (car form) (car template) context env) + (walk-template + (cdr form) (cdr template) context env)))))))) + +(defun walk-template-handle-repeat (form template stop-form context env) + (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))) + +(defun walk-template-handle-repeat-1 (form template repeat-template + stop-form context env) + (cond ((null form) ()) + ((eq form stop-form) + (if (null repeat-template) + (walk-template stop-form (cdr template) context env) + (error "While handling repeat: + ~%~Ran into stop while still in repeat template."))) + ((null repeat-template) + (walk-template-handle-repeat-1 + 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))))) + +(defun walk-repeat-eval (form env) + (and form + (recons form + (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)) + (not (eq (cdr x) cdr))) + (cons car cdr) + x)) + +(defun relist (x &rest args) + (if (null args) + nil + (relist-internal x args nil))) + +(defun relist* (x &rest args) + (relist-internal x args 't)) + +(defun relist-internal (x args *p) + (if (null (cdr args)) + (if *p + (car args) + (recons x (car args) nil)) + (recons x + (car args) + (relist-internal (cdr x) (cdr args) *p)))) + + + ;; +;;;;;; Special walkers + ;; + +(defun walk-declarations (body fn env + &optional doc-string-p declarations old-body + &aux (form (car body)) macrop new-form) + (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 (cadr 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))) + ((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)))) + + +(defun walk-unexpected-declare (form context env) + (declare (ignore context env)) + (warn "Encountered declare ~S in a place where a declare was not expected." + form) + form) + +(defun walk-arglist (arglist context env &optional (destructuringp nil) + &aux arg) + (cond ((null arglist) ()) + ((symbolp (setq arg (car arglist))) + (or (member arg lambda-list-keywords) + (note-lexical-binding arg env)) + (recons arglist + arg + (walk-arglist (cdr arglist) + context + env + (and destructuringp + (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 (cadr 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)) + (or (null (cddr arg)) + (not (symbolp (caddr arg))) + (note-lexical-binding (caddr arg) env)))) + (t + (error "Can't understand something in the arglist ~S" arglist)))) + +(defun walk-let (form context env) + (walk-let/let* form context env nil)) + +(defun walk-let* (form context env) + (walk-let/let* form context env t)) + +(defun walk-prog (form context env) + (walk-prog/prog* form context env nil)) + +(defun walk-prog* (form context env) + (walk-prog/prog* form context env t)) + +(defun walk-do (form context env) + (walk-do/do* form context env nil)) + +(defun walk-do* (form context env) + (walk-do/do* form context env t)) + +(defun walk-let/let* (form context old-env sequentialp) + (walker-environment-bind (new-env old-env) + (let* ((let/let* (car form)) + (bindings (cadr 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)))) + +(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))) + (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))))) + (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))))))) + +(defun walk-do/do* (form context old-env sequentialp) + (walker-environment-bind (new-env old-env) + (let* ((do/do* (car form)) + (bindings (cadr form)) + (end-test (caddr 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)))) + +(defun walk-let-if (form context env) + (let ((test (cadr form)) + (bindings (caddr form)) + (body (cdddr form))) + (walk-form-internal + `(let () + (declare (special ,@(mapcar #'(lambda (x) (if (listp x) (car x) x)) + bindings))) + (flet ((.let-if-dummy. () ,@body)) + (if ,test + (let ,bindings (.let-if-dummy.)) + (.let-if-dummy.)))) + context + env))) + +(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)))) + +(defun walk-multiple-value-bind (form context old-env) + (walker-environment-bind (new-env old-env) + (let* ((mvb (car form)) + (bindings (cadr form)) + (mv-form (walk-template (caddr 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) + (and bindings + (let ((binding (car bindings))) + (recons bindings + (if (symbolp binding) + (prog1 binding + (note-lexical-binding binding new-env)) + (prog1 (relist* binding + (car binding) + (walk-form-internal (cadr 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))))) + +(defun walk-bindings-2 (bindings walked-bindings context env) + (and bindings + (let ((binding (car bindings)) + (walked-binding (car walked-bindings))) + (recons bindings + (if (symbolp binding) + binding + (relist* binding + (car walked-binding) + (cadr walked-binding) + (walk-template (cddr binding) + '(eval) + context + env))) + (walk-bindings-2 (cdr bindings) + (cdr walked-bindings) + context + env))))) + +(defun walk-lambda (form context old-env) + (walker-environment-bind (new-env old-env) + (let* ((arglist (cadr form)) + (body (cddr form)) + (walked-arglist (walk-arglist arglist context new-env)) + (walked-body + (walk-declarations body #'walk-repeat-eval new-env))) + (relist* form + (car form) + walked-arglist + walked-body)))) + +(defun walk-named-lambda (form context old-env) + (walker-environment-bind (new-env old-env) + (let* ((name (cadr form)) + (arglist (caddr 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 + 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))) + (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)))))) + +(defun walk-symbol-macrolet (form context old-env) + (declare (ignore context)) + (let* ((bindings (cadr form))) + (walker-environment-bind + (new-env old-env + :lexical-variables + (append (mapcar #'(lambda (binding) + `(,(car binding) + :macro . ,(cadr binding))) + bindings) + (env-lexical-variables old-env))) + (relist* form 'symbol-macrolet bindings + (walk-repeat-eval (cddr form) new-env))))) + +(defun walk-tagbody (form context env) + (recons form (car form) (walk-tagbody-1 (cdr form) context env))) + +(defun walk-tagbody-1 (form context env) + (and form + (recons form + (walk-form-internal (car form) + (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 ())) + (dolist (binding (cadr form)) + (cond ((symbolp binding) (push binding vars) (push nil vals)) + (t + (push (car binding) vars) + (push (eval (cadr binding)) vals)))) + (relist* form + (car form) + (cadr 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)) + (labels ((walk-definitions (definitions) + (and definitions + (let ((definition (car definitions))) + (recons definitions + (relist* definition + (car definition) + (walk-arglist (cadr definition) + context + macro-env + t) + (walk-declarations (cddr definition) + #'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 (cadr 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)))))) + (recons form + (car form) + (recons (cdr form) + (walk-definitions (cadr 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)))))) + (recons form + (car form) + (recons (cdr form) + (walk-definitions (cadr form)) + (walk-declarations (cddr form) + #'walk-repeat-eval + new-env)))))) + +(defun walk-if (form context env) + (let ((predicate (cadr form)) + (arm1 (caddr 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~%~ + truly legal Common Lisp. For now, this code ~ + walker is interpreting ~%~ + 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))) + (cadddr form)))) + (relist form + 'if + (walk-form-internal predicate context env) + (walk-form-internal arm1 context env) + (walk-form-internal arm2 context env)))) + + +;;; +;;; Tests tests tests +;;; + +#| +;;; +;;; Here are some examples of the kinds of things you should be able to do +;;; with your implementation of the macroexpansion environment hacking +;;; mechanism. +;;; +;;; with-lexical-macros is kind of like macrolet, but it only takes names +;;; of the macros and actual macroexpansion functions to use to macroexpand +;;; them. The win about that is that for macros which want to wrap several +;;; macrolets around their body, they can do this but have the macroexpansion +;;; functions be compiled. See the WITH-RPUSH example. +;;; +;;; If the implementation had a special way of communicating the augmented +;;; environment back to the evaluator that would be totally great. It would +;;; mean that we could just augment the environment then pass control back +;;; to the implementations own compiler or interpreter. We wouldn't have +;;; to call the actual walker. That would make this much faster. Since the +;;; principal client of this is defmethod it would make compiling defmethods +;;; faster and that would certainly be a win. +;;; +(defmacro with-lexical-macros (macros &body body &environment old-env) + (with-augmented-environment (new-env old-env :macros macros) + (walk-form (cons 'progn body) :environment new-env))) + +(defun expand-rpush (form env) + `(push ,(caddr form) ,(cadr form))) + +(defmacro with-rpush (&body body) + `(with-lexical-macros ,(list (list 'rpush #'expand-rpush)) ,@body)) + + +;;; +;;; Unfortunately, I don't have an automatic tester for the walker. +;;; Instead there is this set of test cases with a description of +;;; how each one should go. +;;; +(defmacro take-it-out-for-a-test-walk (form) + `(take-it-out-for-a-test-walk-1 ',form)) + +(defun take-it-out-for-a-test-walk-1 (form) + (terpri) + (terpri) + (let ((copy-of-form (copy-tree form)) + (result (walk-form form nil + #'(lambda (x y env) + (format t "~&Form: ~S ~3T Context: ~A" x y) + (when (symbolp x) + (let ((lexical (variable-lexical-p x env)) + (special (variable-special-p x env))) + (when lexical + (format t ";~3T") + (format t "lexically bound")) + (when special + (format t ";~3T") + (format t "declared special")) + (when (boundp x) + (format t ";~3T") + (format t "bound: ~S " (eval x))))) + x)))) + (cond ((not (equal result copy-of-form)) + (format t "~%Warning: Result not EQUAL to copy of start.")) + ((not (eq result form)) + (format t "~%Warning: Result not EQ to copy of start."))) + (pprint result) + result)) + +(defmacro foo (&rest ignore) ''global-foo) + +(defmacro bar (&rest ignore) ''global-bar) + +(take-it-out-for-a-test-walk (list arg1 arg2 arg3)) +(take-it-out-for-a-test-walk (list (cons 1 2) (list 3 4 5))) + +(take-it-out-for-a-test-walk (progn (foo) (bar 1))) + +(take-it-out-for-a-test-walk (block block-name a b c)) +(take-it-out-for-a-test-walk (block block-name (list a) b c)) + +(take-it-out-for-a-test-walk (catch catch-tag (list a) b c)) +;;; +;;; This is a fairly simple macrolet case. While walking the body of the +;;; macro, x should be lexically bound. In the body of the macrolet form +;;; itself, x should not be bound. +;;; +(take-it-out-for-a-test-walk + (macrolet ((foo (x) (list x) ''inner)) + x + (foo 1))) + +;;; +;;; A slightly more complex macrolet case. In the body of the macro x +;;; should not be lexically bound. In the body of the macrolet form itself +;;; x should be bound. Note that THIS CASE WILL CAUSE AN ERROR when it +;;; tries to macroexpand the call to foo. +;;; +(take-it-out-for-a-test-walk + (let ((x 1)) + (macrolet ((foo () (list x) ''inner)) + x + (foo)))) + +;;; +;;; A truly hairy use of compiler-let and macrolet. In the body of the +;;; macro x should not be lexically bound. In the body of the macrolet +;;; itself x should not be lexically bound. But the macro should expand +;;; into 1. +;;; +(take-it-out-for-a-test-walk + (compiler-let ((x 1)) + (let ((x 2)) + (macrolet ((foo () x)) + x + (foo))))) + + +(take-it-out-for-a-test-walk + (flet ((foo (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))) + (foo 1)))) + +(take-it-out-for-a-test-walk + (labels ((foo (x) (bar x)) + (bar (x) (foo x))) + (foo 1))) + +(take-it-out-for-a-test-walk + (flet ((foo (x) (foo x))) + (foo 1))) + +(take-it-out-for-a-test-walk + (flet ((foo (x) (foo x))) + (flet ((bar (x) (foo x))) + (bar 1)))) + +(take-it-out-for-a-test-walk (compiler-let ((a 1) (b 2)) (foo a) b)) +(take-it-out-for-a-test-walk (prog () (declare (special a b)))) +(take-it-out-for-a-test-walk (let (a b c) + (declare (special a b)) + (foo a) b c)) +(take-it-out-for-a-test-walk (let (a b c) + (declare (special a) (special b)) + (foo a) b c)) +(take-it-out-for-a-test-walk (let (a b c) + (declare (special a)) + (declare (special b)) + (foo a) b c)) +(take-it-out-for-a-test-walk (let (a b c) + (declare (special a)) + (declare (special b)) + (let ((a 1)) + (foo a) b c))) +(take-it-out-for-a-test-walk (eval-when () + a + (foo a))) +(take-it-out-for-a-test-walk (eval-when (eval when load) + a + (foo a))) + +(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))) +(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)) +(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)) + (declare (special a b)) + (list a b c))) +(take-it-out-for-a-test-walk (let* ((a a) (b a) (c b)) + (declare (special a b)) + (list a b c))) +(take-it-out-for-a-test-walk (let ((a 1) (b 2)) + (foo bar) + (declare (special a)) + (foo a b))) +(take-it-out-for-a-test-walk (multiple-value-call #'foo a b c)) +(take-it-out-for-a-test-walk (multiple-value-prog1 a b c)) +(take-it-out-for-a-test-walk (progn a b c)) +(take-it-out-for-a-test-walk (progv vars vals a b c)) +(take-it-out-for-a-test-walk (quote a)) +(take-it-out-for-a-test-walk (return-from block-name a b c)) +(take-it-out-for-a-test-walk (setq a 1)) +(take-it-out-for-a-test-walk (setq a (foo 1) b (bar 2) c 3)) +(take-it-out-for-a-test-walk (tagbody a b c (go a))) +(take-it-out-for-a-test-walk (the foo (foo-form a b c))) +(take-it-out-for-a-test-walk (throw tag-form a)) +(take-it-out-for-a-test-walk (unwind-protect (foo a b) d e f)) + +(defmacro flet-1 (a b) ''outer) +(defmacro labels-1 (a b) ''outer) + +(take-it-out-for-a-test-walk + (flet ((flet-1 (a b) () (flet-1 a b) (list a b))) + (flet-1 1 2) + (foo 1 2))) +(take-it-out-for-a-test-walk + (labels ((label-1 (a b) () (label-1 a b)(list a b))) + (label-1 1 2) + (foo 1 2))) +(take-it-out-for-a-test-walk (macrolet ((macrolet-1 (a b) (list a b))) + (macrolet-1 a b) + (foo 1 2))) + +(take-it-out-for-a-test-walk (macrolet ((foo (a) `(inner-foo-expanded ,a))) + (foo 1))) + +(take-it-out-for-a-test-walk (progn (bar 1) + (macrolet ((bar (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 2)))) + +(take-it-out-for-a-test-walk (cond (a b) + ((foo bar) a (foo a)))) + + +(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)) + (or (and (= (length the-lexical-variables) 3) + (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/pcl/impl/cmu/README b/pcl/impl/cmu/README new file mode 100644 index 0000000..2402793 --- /dev/null +++ b/pcl/impl/cmu/README @@ -0,0 +1,17 @@ +To install, + +put this version of PCL in cmucl's source directory, and name it pcl. +rename the cmucl file tools/pclcom.lisp to tools/pclcom.lisp.original +link the file impl/cmu/pclcom.lisp to cmucl/tools/pclcom.lisp +link the file impl/cmu/pclload.lisp to pclload.lisp + +For example, + +cd cmucl17f +mv pcl pcl.original +<> +cd tools +mv pclcom.lisp pclcom.lisp.original +ln -s ../pcl/impl/cmu/pclcom.lisp pclcom.lisp +cd ../pcl +ln -s impl/cmu/pclload.lisp pclload.lisp diff --git a/pcl/impl/cmu/cmu-low.lisp b/pcl/impl/cmu/cmu-low.lisp new file mode 100644 index 0000000..459c445 --- /dev/null +++ b/pcl/impl/cmu/cmu-low.lisp @@ -0,0 +1,217 @@ +;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; +;;; This is the CMU Lisp version of the file low. +;;; + +(in-package :pcl) + +#+small +(setq *optimize-speed* + '(optimize (speed 3) (safety 0) (debug 0.5) (ext:inhibit-warnings 3))) + +(defmacro dotimes ((var count &optional (result nil)) &body body) + `(lisp:dotimes (,var (the fixnum ,count) ,result) + (declare (fixnum ,var)) + ,@body)) + +;;; Just use our without-interrupts. We don't have the INTERRUPTS-ON/OFF local +;;; macros spec'ed in low.lisp, but they aren't used. +;;; +(defmacro without-interrupts (&rest stuff) + `(sys:without-interrupts ,@stuff)) + +(defun function-arglist (fcn) + "Returns the argument list of a compiled function, if possible." + (cond ((symbolp fcn) + (when (fboundp fcn) + (function-arglist (symbol-function fcn)))) + ((eval:interpreted-function-p fcn) + (eval:interpreted-function-arglist fcn)) + ((functionp fcn) + (let ((lambda-expr (function-lambda-expression fcn))) + (if lambda-expr + (cadr lambda-expr) + (let ((function (kernel:%closure-function fcn))) + (values (read-from-string + (kernel:%function-arglist function))))))))) + + +;;; And returns the function, not the *name*. +(defun set-function-name (fcn new-name) + "Set the name of a compiled function object." + (declare (special *boot-state* *the-class-standard-generic-function*)) + (cond ((symbolp fcn) + (set-function-name (symbol-function fcn) new-name)) + ((funcallable-instance-p fcn) + (if (if (eq *boot-state* 'complete) + (typep fcn 'generic-function) + (eq (class-of fcn) *the-class-standard-generic-function*)) + (setf (kernel:%funcallable-instance-info fcn 1) new-name) + (typecase fcn + (kernel:byte-closure + (set-function-name (kernel:byte-closure-function fcn) new-name)) + (kernel:byte-function + (setf (kernel:byte-function-name fcn) new-name)))) + fcn) + ((eval:interpreted-function-p fcn) + (setf (eval:interpreted-function-name fcn) new-name) + fcn) + (t + (let ((header (kernel:%closure-function fcn))) + #+cmu17 + (setf (c::%function-name header) new-name) + #-cmu17 + (system:%primitive c::set-function-name header new-name)) + fcn))) + +(in-package "C") + +(def-source-context pcl:defmethod (name &rest stuff) + (let ((arg-pos (position-if #'listp stuff))) + (if arg-pos + `(pcl:defmethod ,name ,@(subseq stuff 0 arg-pos) + ,(nth-value 2 (pcl::parse-specialized-lambda-list + (elt stuff arg-pos)))) + `(pcl:defmethod ,name "")))) + + +(in-package "PCL") + +;;;; STD-INSTANCE + +;;; Under CMU17 conditional, STD-INSTANCE-P is only used to discriminate +;;; between functions (including FINs) and normal instances, so we can return +;;; true on structures also. A few uses of (or std-instance-p fsc-instance-p) +;;; are changed to pcl-instance-p. +;;; +(defmacro std-instance-p (x) + `(kernel:%instancep ,x)) +(defmacro pcl-instance-p (x) + `(typep (kernel:layout-of ,x) 'wrapper)) + + +;;; We define this as STANDARD-INSTANCE, since we're going to clobber the +;;; layout with some standard-instance layout as soon as we make it, and we +;;; want the accesor to still be type-correct. +;;; +(defstruct (standard-instance + (:predicate nil) + (:constructor %%allocate-instance--class--fn ()) + (:alternate-metaclass kernel:instance lisp:standard-class + kernel:make-standard-class)) + (slots nil)) + +;;; Must immediately setf the std-instance-wrapper after calling this. +(defmacro %%allocate-instance--class () + `(ext:truly-the standard-instance (kernel:%make-instance 2))) + +;;; Both of these operations "work" on structures, which allows the above +;;; weakening of std-instance-p. +;;; +(defmacro std-instance-slots (x) `(kernel:%instance-ref ,x 1)) +(defmacro std-instance-wrapper (x) `(kernel:%instance-layout ,x)) + +(defmacro built-in-or-structure-wrapper (x) `(kernel:layout-of ,x)) + +(defmacro get-wrapper (inst) + (ext:once-only ((wrapper `(wrapper-of ,inst))) + `(progn + (assert (typep ,wrapper 'wrapper) () "What kind of instance is this?") + ,wrapper))) + +(defmacro get-instance-wrapper-or-nil (inst) + (ext:once-only ((wrapper `(wrapper-of ,inst))) + `(if (typep ,wrapper 'wrapper) + ,wrapper + nil))) + +;;; get-slots harmless + +(defmacro get-slots-or-nil (inst) + (ext:once-only ((n-inst inst)) + `(when (pcl-instance-p ,n-inst) + (if (std-instance-p ,n-inst) + (std-instance-slots ,n-inst) + (fsc-instance-slots ,n-inst))))) + + +;;;; Structure-instance stuff: + +(pushnew :structure-wrapper *features*) + +(defun structure-functions-exist-p () + t) + +(defun structure-instance-p (x) + (typep x 'lisp:structure-object)) + +(defun structurep (x) + (typep x 'lisp:structure-object)) + +(defun structure-type (x) + (lisp:class-name (kernel:layout-class (kernel:%instance-layout x)))) + + +(defun structure-type-p (type) + (and (symbolp type) + (let ((class (lisp:find-class type nil))) + (and class + (typep (kernel:layout-info (kernel:class-layout class)) + 'kernel:defstruct-description))))) + +(defun get-structure-dd (type) + (kernel:layout-info (kernel:class-layout (lisp:find-class type)))) + +(defun structure-type-included-type-name (type) + (let ((include (kernel::dd-include (get-structure-dd type)))) + (if (consp include) + (car include) + include))) + +(defun structure-type-slot-description-list (type) + (nthcdr (length (let ((include (structure-type-included-type-name type))) + (and include (kernel:dd-slots (get-structure-dd include))))) + (kernel:dd-slots (get-structure-dd type)))) + +(defun structure-slotd-name (slotd) + (kernel:dsd-name slotd)) + +(defun structure-slotd-accessor-symbol (slotd) + (kernel:dsd-accessor slotd)) + +(defun structure-slotd-reader-function (slotd) + (fdefinition (kernel:dsd-accessor slotd))) + +(defun structure-slotd-writer-function (slotd) + (unless (kernel:dsd-read-only slotd) + (fdefinition `(setf ,(kernel:dsd-accessor slotd))))) + +(defun structure-slotd-type (slotd) + (kernel:dsd-type slotd)) + +(defun structure-slotd-init-form (slotd) + (kernel::dsd-default slotd)) diff --git a/pcl/impl/cmu/pclcom.lisp b/pcl/impl/cmu/pclcom.lisp new file mode 100644 index 0000000..6be7d94 --- /dev/null +++ b/pcl/impl/cmu/pclcom.lisp @@ -0,0 +1,66 @@ +;; This is "target:tools/pclcom.lisp" + +(in-package "USER") + +(when (find-package "PCL") + (setf (compiler-macro-function 'make-instance) nil) + ;; + ;; Undefine all generic functions exported from Lisp so that bootstrapping + ;; doesn't get confused. + (let ((class (find-class 'generic-function nil))) + (when class + (do-external-symbols (sym "LISP") + (when (and (fboundp sym) + (typep (fdefinition sym) class)) + (fmakunbound sym)) + (let ((ssym `(setf ,sym))) + (when (and (fboundp ssym) + (typep (fdefinition ssym) class)) + (fmakunbound ssym)))))) + + ;; Undefine all PCL classes, and clear CLASS-PCL-CLASS slots. + (let ((wot (find-symbol "*FIND-CLASS*" "PCL"))) + (when (and wot (boundp wot)) + (do-hash (name ignore (symbol-value wot)) + (declare (ignore ignore)) + (let ((class (find-class name nil))) + (cond ((not class)) + ((typep class 'kernel::std-class) + (setf (kernel:class-cell-class + (kernel:find-class-cell name)) + nil) + (setf (info type kind name) nil)) + (t + (setf (kernel:class-pcl-class class) nil))))))) + + (rename-package "PCL" "OLD-PCL") + (make-package "PCL")) + +(when (find-package "SLOT-ACCESSOR-NAME") + (rename-package "SLOT-ACCESSOR-NAME" "OLD-SLOT-ACCESSOR-NAME")) + +(setf c:*suppress-values-declaration* t) +(pushnew :setf *features*) + +(setf (search-list "pcl:") '("target:pcl/")) + +(let ((obj (make-pathname :defaults "pcl:defsys" + :type (c:backend-fasl-file-type c:*backend*)))) + (when (< (or (file-write-date obj) 0) + (file-write-date "pcl:defsys.lisp")) + (compile-file "pcl:defsys" :byte-compile t))) + +(load "pcl:defsys" :verbose t) + +(import 'kernel:funcallable-instance-p (find-package "PCL")) + +(with-compilation-unit + (:optimize '(optimize (debug #+small .5 #-small 2) + (speed 2) (safety #+small 0 #-small 2) + (inhibit-warnings 2)) + :optimize-interface '(optimize-interface #+small (safety 1)) + :context-declarations + '((:external (declare (optimize-interface (safety 2) (debug 1)))) + ((:or :macro (:match "$EARLY-") (:match "$BOOT-")) + (declare (optimize (speed 0)))))) + (pcl::compile-pcl)) diff --git a/pcl/impl/cmu/pclload.lisp b/pcl/impl/cmu/pclload.lisp new file mode 100644 index 0000000..39fb098 --- /dev/null +++ b/pcl/impl/cmu/pclload.lisp @@ -0,0 +1,12 @@ +(in-package "PCL") +(unless (find-package "SLOT-ACCESSOR-NAME") + (make-package "SLOT-ACCESSOR-NAME")) +(rename-package "PCL" "PCL" '("OLD-PCL")) +(rename-package "SLOT-ACCESSOR-NAME" "SLOT-ACCESSOR-NAME" + '("OLD-SLOT-ACCESSOR-NAME")) +(import 'kernel:funcallable-instance-p) +(load "target:pcl/defsys") +(load-pcl) +(rename-package "PCL" "PCL" '()) +(rename-package "SLOT-ACCESSOR-NAME" "SLOT-ACCESSOR-NAME" '()) + diff --git a/pcl/impl/coral/coral-low.lisp b/pcl/impl/coral/coral-low.lisp new file mode 100644 index 0000000..650dd75 --- /dev/null +++ b/pcl/impl/coral/coral-low.lisp @@ -0,0 +1,63 @@ +;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; + +(in-package :pcl) + +#-:ccl-1.3 +(ccl::add-transform 'std-instance-p + :inline + #'(lambda (call) + (ccl::verify-arg-count call 1 1) + (let ((arg (cadr call))) + `(and (eq (ccl::%type-of ,arg) 'structure) + (eq (%svref ,arg 0) 'std-instance))))) + +(eval-when (eval compile load) + (proclaim '(inline std-instance-p))) + +(defun printing-random-thing-internal (thing stream) + (prin1 (ccl::%ptr-to-int thing) stream)) + +(defun set-function-name-1 (function new-name uninterned-name) + (declare (ignore uninterned-name)) + (cond ((ccl::lfunp function) + (ccl::lfun-name function new-name))) + function) + + +(defun doctor-dfun-for-the-debugger (gf dfun) + #+:ccl-1.3 + (let* ((gfspec (and (symbolp (generic-function-name gf)) + (generic-function-name gf))) + (arglist (generic-function-pretty-arglist gf))) + (when gfspec + (setf (get gfspec 'ccl::%lambda-list) + (if (and arglist (listp arglist)) + (format nil "~{~A~^ ~}" arglist) + (format nil "~:A" arglist))))) + dfun) + diff --git a/pcl/impl/franz/cpatch.lisp b/pcl/impl/franz/cpatch.lisp new file mode 100644 index 0000000..23641de --- /dev/null +++ b/pcl/impl/franz/cpatch.lisp @@ -0,0 +1,32 @@ +;; -[Thu Feb 22 08:38:07 1990 by jkf]- +;; cpatch.cl +;; compiler patch for the fast clos +;; +;; copyright (c) 1990 Franz Inc. +;; + +(in-package :comp) + +(def-quad-op tail-funcall qp-end-block + ;; u = (argcount function-object) + ;; + ;; does a tail call to the function-object given + ;; never returns + ) + +(defun-in-runtime sys::copy-function (func)) + +(in-package :hyperion) + +(def-quad-hyp r-tail-funcall comp::tail-funcall (u d quad) + ;; u = (argcount function) + ;; + (r-move-single-to-loc (treg-loc (car u)) *count-reg*) + (r-move-single-to-loc (treg-loc (cadr u)) *fcnin-reg*) + (re restore *zero-reg* *zero-reg*) + (re move.l `(d #.r-function-start-adj #.*fcnout-reg*) '#.*ctr2-reg*) + (re jmpl '(d 0 #.*ctr2-reg*) *zero-reg*) + (re nop)) + + + diff --git a/pcl/impl/franz/excl-low.lisp b/pcl/impl/franz/excl-low.lisp new file mode 100644 index 0000000..54c734b --- /dev/null +++ b/pcl/impl/franz/excl-low.lisp @@ -0,0 +1,136 @@ +;;; -*- Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; +;;; This is the EXCL (Franz) lisp version of the file portable-low. +;;; +;;; This is for version 1.1.2. Many of the special symbols now in the lisp +;;; package (e.g. lisp::pointer-to-fixnum) will be in some other package in +;;; a later release so this will need to be changed. +;;; + +(in-package 'pcl) + +(defmacro without-interrupts (&body body) + `(let ((outer-interrupts excl::*without-interrupts*) + (excl::*without-interrupts* 0)) + (macrolet ((interrupts-on () + '(unless outer-interrupts + (setq excl::*without-interrupts* nil))) + (interrupts-off () + '(setq excl::*without-interrupts* 0))) + ,.body))) + +(eval-when (compile load eval) + (unless (fboundp 'excl::sy_hash) + (setf (symbol-function 'excl::sy_hash) + (symbol-function 'excl::_sy_hash-value))) + ) + +(defmacro memq (item list) + (let ((list-var (gensym)) + (item-var (gensym))) + `(prog ((,list-var ,list) + (,item-var ,item)) + start + (cond ((null ,list-var) + (return nil)) + ((eq (car ,list-var) ,item-var) + (return ,list-var)) + (t + (pop ,list-var) + (go start)))))) + +(defun std-instance-p (x) + (and (excl::structurep x) + (locally + (declare #.*optimize-speed*) + (eq (svref x 0) 'std-instance)))) + +(excl::defcmacro std-instance-p (x) + (once-only (x) + `(and (excl::structurep ,x) + (locally + (declare #.*optimize-speed*) + (eq (svref ,x 0) 'std-instance))))) + +(excl::defcmacro fast-method-call-p (x) + (once-only (x) + `(and (excl::structurep ,x) + (locally + (declare #.*optimize-speed*) + (eq (svref ,x 0) 'fast-method-call))))) + +(defmacro %std-instance-wrapper (x) + `(svref ,x 1)) + +(defmacro %std-instance-slots (x) + `(svref ,x 2)) + +(defun printing-random-thing-internal (thing stream) + (format stream "~O" (excl::pointer-to-fixnum thing))) + +#-vax +(defun set-function-name-1 (fn new-name ignore) + (declare (ignore ignore)) + (cond ((excl::function-object-p fn) + (setf (excl::fn_symdef fn) new-name)) + (t nil)) + fn) + +(defun function-arglist (f) + (excl::arglist f)) + +(defun symbol-append (sym1 sym2 &optional (package *package*)) + ;; This is a version of symbol-append from macros.cl + ;; It insures that all created symbols are of one case and that + ;; case is the current prefered case. + ;; This special version of symbol-append is not necessary if all you + ;; want to do is compile and run pcl in a case-insensitive-upper + ;; version of cl. + ;; + (let ((string (string-append sym1 sym2))) + (case excl::*current-case-mode* + ((:case-insensitive-lower :case-sensitive-lower) + (setq string (string-downcase string))) + ((:case-insensitive-upper :case-sensitive-upper) + (setq string (string-upcase string)))) + (intern string package))) + +;;; Define inspector hooks for PCL object instances. + +(defun (:property pcl::std-instance :inspector-function) (object) + (let ((class (class-of object))) + (cons (inspect::make-field-def "class" #'class-of :lisp) + (mapcar #'(lambda (slot) + (inspect::make-field-def + (string (slot-definition-name slot)) + #'(lambda (x) + (slot-value-using-class class x slot)) + :lisp)) + (slots-to-inspect class object))))) + +(defun (:property pcl::std-instance :inspector-type-function) (x) + (class-name (class-of x))) diff --git a/pcl/impl/franz/quadlap.lisp b/pcl/impl/franz/quadlap.lisp new file mode 100644 index 0000000..3d7507e --- /dev/null +++ b/pcl/impl/franz/quadlap.lisp @@ -0,0 +1,619 @@ +;; -[Thu Mar 1 10:54:27 1990 by jkf]- +;; pcl to quad translation +;; $Header$ +;; +;; copyright (c) 1990 Franz Inc. +;; +(in-package :compiler) + + + + +(defvar *arg-to-treg* nil) +(defvar *cvar-to-index* nil) +(defvar *reg-array* nil) +(defvar *closure-treg* nil) +(defvar *nargs-treg* nil) + +(defvar *debug-sparc* nil) + +(defmacro pcl-make-lambda (&key required) + `(list 'lambda nil :unknown-type 0 compiler::.function-level. + ,required nil nil nil nil nil nil nil nil nil + nil 'compiler::none nil nil nil + nil nil nil nil nil nil 0 nil)) + +(defmacro pcl-make-varrec (&key name loc contour-level) + `(list ,name nil 0 nil ,loc nil t compiler::.function-level. nil nil :unknown-type nil nil ,contour-level)) + +(defmacro pcl-make-lap (&key lap constants cframe-size locals) + `(list nil ,constants ,lap nil nil ,cframe-size ,locals nil nil nil)) + + +(defstruct preg + ;; pseudo reg descritpor + treg ; associated treg + index ; :index if this is an index type reg + ; :vector if this is a vector type reg + ) + + +(defun pcl::excl-lap-closure-generator (closure-vars-names + arg-names + index-regs + vector-regs + fixnum-vector-regs + t-regs + lap-code) + (let ((function (pcl::excl-lap-closure-gen closure-vars-names + arg-names + index-regs + (append vector-regs fixnum-vector-regs) + t-regs + lap-code))) + #'(lambda (&rest closure-vals) + (insert-closure-vals function closure-vals)))) + + +(defun pcl::excl-lap-closure-gen + (closure-vars-names arg-names index-regs vector-regs t-regs lap-code) + (let ((*quads* nil) + (*treg-num* 0) + (*all-tregs* nil) + (*bb-count* 0) + *treg-bv-size* + *treg-vector* + (*next-catch-frame* 0) + (*max-catch-frame* -1) + *catch-labels* + *top-label* + *mv-treg* + *mv-treg-target* + *zero-treg* + *nil-treg* + *bbs* *bb* lap + ;; bbs + *cross-block-regs* + *const-tregs* *move-tregs* + *actuals* + *ignore-argcount* + *binds-specs* + *bvl-current-bv* ; for bitvector cacher + *bvl-used-bvs* + *bvl-index* + (*inhibit-call-count* t) + + ; this fcn + *arg-to-treg* + *cvar-to-index* + *reg-array* + minargs + maxargs + *closure-treg* + + node + otherargregs + + *nargs-treg* + ) + + (if* *debug-sparc* + then (format t ">>** << Generating sparc lap code~%")) + + (setq *nil-treg* + #+allegro-v4.0 (new-reg :global t) + #-allegro-v4.0 (new-reg) + *mv-treg* (new-reg) + *mv-treg-target* (list *mv-treg*) + *zero-treg* (comp::new-reg)) + + ; examine given args + + (setq minargs 0 maxargs 0) + (let (requireds) + (dolist (arg arg-names) + (if* (eq '&rest arg) + then (setq maxargs nil) + else (if* (null arg) + then ; we want a name even though we won't use it + (setq arg (gensym))) + (incf minargs) + (incf maxargs) + (push (cons arg (new-reg)) *arg-to-treg*) + (push (pcl-make-varrec :name arg + :loc (cdr (car *arg-to-treg*)) + :contour-level 0) + requireds) + )) + (setq node (pcl-make-lambda :required (nreverse requireds)))) + (setq *arg-to-treg* (nreverse *arg-to-treg*)) + + ; build closure vector list + (let ((index -1)) + (dolist (cvar closure-vars-names) + (push (cons cvar (incf index)) *cvar-to-index*))) + + (let ((maxreg (max (apply #'max (cons -1 index-regs)) + (apply #'max (cons -1 vector-regs)) + (apply #'max (cons -1 t-regs))))) + (setq *reg-array* (make-array (1+ maxreg)))) + + (dolist (index index-regs) + (setf (svref *reg-array* index) + (make-preg :treg (new-reg) + :index :index))) + + (dolist (vector vector-regs) + (setf (svref *reg-array* vector) + (make-preg :treg (new-reg) + :index :vector))) + + (dolist (tr t-regs) + (setf (svref *reg-array* tr) (make-preg :treg (new-reg)))) + + + (if* closure-vars-names + then (setq *closure-treg* (new-reg))) + (setq *nargs-treg* (new-reg)) + + ;; (md-allocate-global-tregs) + + ; function entry + (qe nop :arg :first-block) + (qe entry) + (qe argcount :arg (list minargs maxargs)) + (qe lambda :d (mapcar #'cdr *arg-to-treg*)) + (qe register :arg :nargs :d (list *nargs-treg*)) + + (if* *closure-treg* + then ; put the first closure vector in *closure-treg* + (qe extract-closure-vec :d (list *closure-treg*)) + (let ((offsetreg (new-reg))) + (qe const :arg (mdparam 'md-cons-car-adj) :d (list offsetreg)) + (qe ref :u (list *closure-treg* offsetreg) + :d (list *closure-treg*) + :arg :long)) + ) + + (excl-gen-quads lap-code) + + (if* *debug-sparc* + then (do-quad-list (quad next *quads*) + (format t "~a~%" quad)) + + (format t "basic blocks~%")) + + (setq *bbs* (qc-compute-basic-blocks *quads*)) + + (excl::target-class-case + ((:r :m) (setq *actuals* (qc-compute-actuals *bbs*)))) + + (qc-live-variable-analysis *bbs*) + + (setq *treg-bv-size* (* 16 (truncate (+ *treg-num* 15) 16))) + + (qc-build-treg-vector) + + + (let ((*dump-bbs* nil) + (r::*local-regs* + ; use the in registers that aren't in use + (append r::*local-regs* + (if* maxargs + then (nthcdr maxargs r::*in-regs* ))))) + (unwind-protect + (progn + ; machine specific code generation + (multiple-value-bind (lap-code literals size-struct locals) + #+(target-class r m e) + (progn + #+allegro-v4.0 + (md-codegen node *bbs* + nil otherargregs) + #-allegro-v4.0 + (md-codegen node *bbs* + *nil-treg* *mv-treg* *zero-treg* + nil otherargregs)) + + #-(target-class r m e) (md-codegen node *bbs*) + (setq lap + (pcl-make-lap :lap lap-code + :constants literals + :cframe-size size-struct + :locals locals))) + + + lap) + (giveback-bvs))) + + #+ignore + (progn (format t "sparc code pre optimization~%") + (dolist (instr (lap-lap lap)) + (format t "> ~a~%" instr))) + (md-optimize lap) ; peephole optimize + (if* *debug-sparc* + then (format t "sparc code post optimization~%") + (dolist (instr (lap-lap lap)) + (format t "> ~a~%" instr))) + (md-assemble lap) + (setq last-lap lap) + + (nl-runtime-make-a-fcnobj lap))) + +(defun qe-slot-access (operand offset dest) + ;; access a slot in a structure + (let ((temp (new-reg))) + (qe const :arg offset :d (list temp)) + (qe ref :u (list (get-treg-of operand) temp) + :d (list (get-treg-of dest)) + :arg :long))) + + +(defun get-treg-of (operand &optional res-operand) + ;; get the appropriate treg for the operand + (let ((prefer-treg (and res-operand (simple-get-treg-of res-operand)))) + (if* (numberp operand) + then (let ((treg (new-reg))) + (qe const :arg operand :d (list treg)) + treg) + elseif (consp operand) + then (ecase (car operand) + (:reg + (preg-treg (svref *reg-array* (cadr operand)))) + (:arg + (let ((x (cdr (assoc (cadr operand) *arg-to-treg* :test #'eq)))) + (if* (null x) + then (error "where is arg ~s" operand) + else x))) + (:cvar + (let ((res-treg (or prefer-treg (new-reg))) + (temp-treg (new-reg))) + (qe const :arg (+ (mdparam 'md-svector-data0-adj) + (* 4 (cdr (assoc (cadr operand) + *cvar-to-index* + :test #'eq)))) + :d (list temp-treg)) + (qe ref :u (list *closure-treg* temp-treg) + :d (list res-treg) + :arg :long) + res-treg)) + (:constant + (let ((treg (or prefer-treg (new-reg)))) + (qe const :arg (if* (fixnump (cadr operand)) + then (* 8 (cadr operand)) ; md!! + else (cadr operand)) + :d (list treg)) + treg)) + (:index-constant + ; operand invented by jkf to denote an index type constant + (let ((treg (or prefer-treg (new-reg)))) + (qe const :arg (if* (fixnump (cadr operand)) + then (* 4 (cadr operand)) ; md!! + else (cadr operand)) + :d (list treg)) + treg))) + else (error "bad operand: ~s" operand)))) + +(defun simple-get-treg-of (operand) + ;; get the treg if it is so simple that we don't have to + ;; emit any instructions to access it. + ;; return nil if we can't do it. + (if* (numberp operand) + then nil + elseif (consp operand) + then (case (car operand) + (:reg + (preg-treg (svref *reg-array* (cadr operand)))) + (:arg + (let ((x (cdr (assoc (cadr operand) *arg-to-treg* :test #'eq)))) + (if* (null x) + then nil + else x)))) + + else nil)) + +(defun index-p (operand) + ;; determine if the result of this operand is an index value + ;* it would be better if conversion between lisp values and + ; index values were made explicit in the lap code + (and (consp operand) + (or (and (eq :reg (car operand)) + (eq :index (preg-index (svref *reg-array* (cadr operand))))) + (member (car operand) + '(:i+ :i- :ilogand :ilogxor :i1+) + :test #'eq)) + t)) + +(defun gen-index-treg (operand) + ;; return the non-index type operand in a index treg + (if* (and (consp operand) + (eq ':constant (car operand))) + then (get-treg-of `(:index-constant ,(cadr operand))) + else (let ((treg (get-treg-of operand)) + (new-reg (new-reg)) + (shift-reg (new-reg))) + (qe const :arg 1 :d (list shift-reg)) + (qe lsr :u (list treg shift-reg) :d (list new-reg)) + new-reg))) + + + + + +(defun vector-preg-p (operand) + (and (consp operand) + (eq :reg (car operand)) + (eq :vector (preg-index (svref *reg-array* (cadr operand)))))) + + + +(defun excl-gen-quads (laps) + ;; generate quads from the lap + (dolist (lap laps) + (if* *debug-sparc* then (format t ">> ~a~%" lap)) + (block again + (let ((opcode (car lap)) + (op1 (cadr lap)) + (op2 (caddr lap))) + (case opcode + (:move + ; can be either simple (both args registers) + ; or one arg can be complex and the other simple + (case (car op2) + ((:iref :instance-ref) + ;; assume that this is a lisp store + ;;(warn "assuming lisp store in ~s" lap) + (let (op1-treg) + (if* (not (vector-preg-p (cadr op2))) + then ; must offset before store + (error "must use vector register in ~s" lap) + else (setq op1-treg (get-treg-of (cadr op2)))) + + + + (qe set :u (list op1-treg + (get-treg-of (caddr op2)) + (get-treg-of op1)) + :arg :lisp) + (return-from again))) + (:cdr + ;; it certainly is a lisp stoer + (let (op1-treg const-reg) + (setq op1-treg (get-treg-of (cadr op2))) + (setq const-reg (new-reg)) + (qe const :arg (mdparam 'md-cons-cdr-adj) + :d (list const-reg)) + + + + (qe set :u (list op1-treg + const-reg + (get-treg-of op1)) + :arg :lisp) + (return-from again)))) + + ; the 'to'address is simple, the from address may not be + + (let ((index1 (index-p op1)) + (index2 (index-p op2)) + (vector1 (vector-preg-p op1)) + (vector2 (vector-preg-p op2))) + (ecase (car op1) + ((:reg :cvar :arg :constant :lisp-symbol) + (qe move + :u (list (get-treg-of op1 op2)) + :d (list (get-treg-of op2)))) + (:std-wrapper + (qe-slot-access (cadr op1) + (+ (* 1 4) + (comp::mdparam 'md-svector-data0-adj)) + op2)) + (:std-slots + (qe-slot-access (cadr op1) + (+ (* 2 4) + (comp::mdparam 'md-svector-data0-adj)) + op2)) + (:fsc-wrapper + (qe-slot-access (cadr op1) + (+ (* (- 15 1) 4) + (comp::mdparam 'md-function-const0-adj)) + op2)) + (:fsc-slots + (qe-slot-access (cadr op1) + (+ (* (- 15 2) 4) + (comp::mdparam 'md-function-const0-adj)) + op2)) + ((:built-in-wrapper :structure-wrapper :built-in-or-structure-wrapper) + (qe call :arg 'pcl::built-in-or-structure-wrapper + :u (list (get-treg-of (cadr op1))) + :d (list (get-treg-of op2)))) + (:other-wrapper + (warn "do other-wrapper")) + ((:i+ :i- :ilogand :ilogxor) + (qe arith :arg (cdr (assoc (car op1) + '((:i+ . :+) + (:i- . :-) + (:ilogand . :logand) + (:ilogxor . :logxor)) + :test #'eq)) + :u (list (get-treg-of (cadr op1)) + (get-treg-of (caddr op1))) + :d (list (get-treg-of op2)))) + (:i1+ + (let ((const-reg (new-reg))) + (qe const :arg 4 ; an index value of 1 + :d (list const-reg)) + (qe arith :arg :+ + :u (list const-reg + (get-treg-of (cadr op1))) + :d (list (get-treg-of op2))))) + + ((:iref :cref :instance-ref) + (let (op1-treg) + (if* (not (vector-preg-p (cadr op1))) + then ; must offset before store + (error "must use vector register in ~s" lap) + else (setq op1-treg (get-treg-of (cadr op1)))) + + (qe ref :u (list op1-treg + (get-treg-of (caddr op1) op2)) + :d (list (get-treg-of op2)) + :arg :long))) + (:cdr + (let ((const-reg (new-reg))) + (qe const :arg (mdparam 'md-cons-cdr-adj) + :d (list const-reg)) + (qe ref :arg :long + :u (list (get-treg-of (cadr op1)) + const-reg) + :d (list (get-treg-of op2)))))) + (if* (not (eq index1 index2)) + then (let ((shiftamt (new-reg))) + (qe const :arg 1 :d (list shiftamt)) + (if* (and index1 (not index2)) + then ; converting from index to non-index + (qe lsl :u (list (get-treg-of op2) shiftamt) + :d (list (get-treg-of op2))) + elseif (and (not index1) index2) + ; converting to an index + then (qe lsr :u (list (get-treg-of op2) shiftamt) + :d (list (get-treg-of op2))))) + elseif (and vector2 (not vector1)) + then ; add vector offset + (let ((tempreg (new-reg)) + (vreg (get-treg-of op2))) + (qe const :arg (mdparam 'md-svector-data0-adj) + :d (list tempreg)) + (qe arith :arg :+ :u (list vreg tempreg) + :d (list vreg)))))) + (:fix= + (let (tr1 tr2) + (if* (index-p op1) + then (setq tr1 (get-treg-of op1)) + (if* (not (index-p op2)) + then (setq tr2 (gen-index-treg op2)) + else (setq tr2 (get-treg-of op2))) + elseif (index-p op2) + then ; assert: op1 isn't an index treg + (setq tr1 (gen-index-treg op1)) + (setq tr2 (get-treg-of op2)) + else (setq tr1 (get-treg-of op1) + tr2 (get-treg-of op2))) + + + + (qe bcc :u (list tr1 tr2) + :arg (cadddr lap) + :arg2 :eq ))) + ((:eq :neq :fix=) + (if* (not (eq (index-p op1) (index-p op2))) + then (error "non matching operands indexwise in: ~s" lap)) + (qe bcc :u (list (get-treg-of op1) + (get-treg-of op2)) + :arg (cadddr lap) + :arg2 (cdr (assoc opcode '((:eq . :eq) + (:neq . :ne)) + :test #'eq)))) + (:izerop + (qe bcc :u (list (get-treg-of op1) + *zero-treg*) + :arg (caddr lap) + :arg2 :eq)) + (:std-instance-p + (let ((treg (get-treg-of op1)) + (tempreg (new-reg)) + (temp2reg (new-reg)) + (offsetreg (new-reg)) + (nope (pc-genlab))) + (qe typecheck :u (list treg) + :arg nope + :arg2 '(not structure)) + (qe const :arg 'pcl::std-instance :d (list tempreg)) + (qe const :arg (mdparam 'md-svector-data0-adj) + :d (list offsetreg)) + (qe ref :u (list treg offsetreg) + :d (list temp2reg) + :arg :long) + (qe bcc :arg2 :eq :u (list tempreg temp2reg) + :arg (caddr lap)) + (qe label :arg nope))) + + (:fsc-instance-p + (let ((treg (get-treg-of op1)) + (nope (pc-genlab)) + (offsetreg (new-reg)) + (tempreg (new-reg)) + (checkreg (new-reg))) + (qe typecheck :u (list treg) + :arg nope + :arg2 '(not compiled-function)) + (qe const :arg (mdparam 'md-function-flags-adj) + :d (list offsetreg)) + (qe ref :u (list treg offsetreg) :d (list tempreg) + :arg :ubyte) + (qe const :arg pcl::funcallable-instance-flag-bit + :d (list checkreg)) + (qe bcc :u (list checkreg tempreg) + :arg (caddr lap) + :arg2 :bit-and) + (qe label :arg nope))) + (:built-in-instance-p + ; always true + (qe bra :arg (caddr lap))) + (:jmp + (qe tail-funcall :u (list *nargs-treg* (get-treg-of op1)))) + (:structure-instance-p + ; always true + (qe bra :arg (caddr lap))) + + (:return + (let (op-treg) + (if* (index-p op1) + then ; convert to lisp before returning + (let ((shiftamt (new-reg))) + (setq op-treg (new-reg)) + (qe const :arg 1 :d (list shiftamt)) + (qe lsl :u (list (get-treg-of op1) shiftamt) + :d (list op-treg))) + else (setq op-treg (get-treg-of op1))) + + (qe move :u (list op-treg) :d *mv-treg-target*) + (qe return :u *mv-treg-target*))) + + (:go + (qe bra :arg (cadr lap))) + + (:label + (qe label :arg (cadr lap))) + + + + (t (warn "ignoring ~s" lap))))))) + + +(defun insert-closure-vals (function closure-vals) + ;; build a fucntion from the lap and insert + (let ((newfun (sys::copy-function function))) + (setf (excl::fn_closure newfun) (list (apply 'vector closure-vals))) + newfun)) + + + +; test case: +; (pcl::defclass foo () (a b c)) +; (pcl::defmethod barx ((a foo) b c) a ) +; (apply 'pcl::excl-lap-closure-generator pcl::*tcase*) +; +; to turn it on + +(if* (not (and (boundp 'user::noquad) + (symbol-value 'user::noquad))) + then (setq pcl::*make-lap-closure-generator* + 'pcl::excl-lap-closure-generator)) + + + + + + + diff --git a/pcl/impl/gcl/README b/pcl/impl/gcl/README new file mode 100644 index 0000000..7948b33 --- /dev/null +++ b/pcl/impl/gcl/README @@ -0,0 +1,14 @@ +Includes changes for gcl version 2.0 by W. Schelter + + +To compile + +ln -s impl/gcl/makefile.gcl makefile.gcl +ln -s impl/gcl/sys-package.lisp sys-package.lisp +ln -s impl/gcl/sys-proclaim.lisp sys-proclaim.lisp +make -f makefile.gcl compile + +Then to make saved version + +make -f makefile.gcl saved_pcl + diff --git a/pcl/impl/gcl/gcl-low.lisp b/pcl/impl/gcl/gcl-low.lisp new file mode 100644 index 0000000..883b32c --- /dev/null +++ b/pcl/impl/gcl/gcl-low.lisp @@ -0,0 +1,316 @@ +(in-package "SI") +(export '(%structure-name + %compiled-function-name + %set-compiled-function-name)) +(in-package 'pcl) +(eval-when (compile eval load) +(setq *EVAL-WHEN-COMPILE* t) +) + +(defmacro memq (item list) `(member ,item ,list :test #'eq)) +(defmacro assq (item list) `(assoc ,item ,list :test #'eq)) +(defmacro posq (item list) `(position ,item ,list :test #'eq)) + +(defmacro dotimes ((var form &optional (val nil)) &rest body &environment env) + (multiple-value-bind (doc decls bod) + (extract-declarations body env) + (declare (ignore doc)) + (let ((limit (gensym)) + (label (gensym))) + `(let ((,limit ,form) + (,var 0)) + (declare (fixnum ,limit ,var)) + ,@decls + (block nil + (tagbody + ,label + (when (>= ,var ,limit) (return-from nil ,val)) + ,@bod + (setq ,var (the fixnum (1+ ,var))) + (go ,label))))))) + +(defun printing-random-thing-internal (thing stream) + (format stream "~O" (si:address thing))) + +(eval-when (compile load eval) +(pushnew :turbo-closure *features*) +(pushnew :turbo-closure-env-size *features*)) +) + +(defmacro %svref (vector index) + `(svref (the simple-vector ,vector) (the fixnum ,index))) + +(defsetf %svref (vector index) (new-value) + `(setf (svref (the simple-vector ,vector) (the fixnum ,index)) + ,new-value)) + +(si::freeze-defstruct 'pcl::std-instance) + +(si::freeze-defstruct 'method-call) +(si::freeze-defstruct 'fast-method-call) + +(defvar *pcl-funcall* `(lambda (loc) + (compiler::wt-nl + "{object _funobj = " loc ";" + "if(type_of(_funobj)==t_cclosure && (_funobj->cc.cc_turbo)) + (*(_funobj->cc.cc_self))(_funobj->cc.cc_turbo); + else if (type_of(_funobj)==t_cfun) (*(_funobj->cc.cc_self))(); + else super_funcall_no_event(_funobj);}"))) + +(setq compiler::*super-funcall* *pcl-funcall*) + +(defmacro fmc-funcall (fn pv-cell next-method-call &rest args) + `(funcall ,fn ,pv-cell ,next-method-call ,@args)) + +(defun pcl::proclaim-defmethod (x y) y + (and (symbolp x) + (setf (get x 'compiler::proclaimed-closure ) t))) + + + +;#+turbo-closure-env-size +(clines " +static +object cclosure_env_nthcdr (n,cc) +int n; object cc; +{ object env,*turbo; + if(n<0)return Cnil; + if(type_of(cc)!=t_cclosure)return Cnil; + if((turbo=cc->cc.cc_turbo)==NULL) + {env=cc->cc.cc_env; + while(n-->0) + {if(type_of(env)!=t_cons)return Cnil; + env=env->c.c_cdr;} + return env;} + else + {if(n>=fix(*(turbo-1)))return Cnil; + return turbo[n];} +}") + +(defentry cclosure-env-nthcdr (int object) (object cclosure_env_nthcdr)) +;; This is the unsafe but fast version. +(defentry %cclosure-env-nthcdr (int object) (object cclosure_env_nthcdr)) + +(eval-when (compile eval load) +(defparameter *gcl-function-inlines* + '( (%fboundp (t) compiler::boolean nil nil "(#0)->s.s_gfdef!=OBJNULL") + (%symbol-function (t) t nil nil "(#0)->s.s_gfdef") + (si:%structure-name (t) t nil nil "(#0)->str.str_def->str.str_self[0]") + (si:%compiled-function-name (t) t nil nil "(#0)->cf.cf_name") + (si:%set-compiled-function-name (t t) t t nil "((#0)->cf.cf_name)=(#1)") + (cclosurep (t) compiler::boolean nil nil "type_of(#0)==t_cclosure") + (sfun-p (t) compiler::boolean nil nil "type_of(#0)==t_sfun") + (%cclosure-env (t) t nil nil "(#0)->cc.cc_env") + (%set-cclosure-env (t t) t t nil "((#0)->cc.cc_env)=(#1)") + #+turbo-closure + (%cclosure-env-nthcdr (fixnum t) t nil nil "(#1)->cc.cc_turbo[#0]") + + (logxor (fixnum fixnum) fixnum nil nil "((#0) ^ (#1))"))) + +(defun make-function-inline (inline) + (setf (get (car inline) 'compiler::inline-always) + (list (if (fboundp 'compiler::flags) + (let ((opt (cdr inline))) + (list (first opt) (second opt) + (logior (if (fourth opt) 1 0) ; allocates-new-storage + (if (third opt) 2 0) ; side-effect + (if nil 4 0) ; constantp + (if (eq (car inline) 'logxor) + 8 0)) ;result type from args + (fifth opt))) + (cdr inline))))) +) + + +(defmacro define-inlines () + `(progn + ,@(mapcan #'(lambda (inline) + (let ((name (intern (format nil "~S inline" (car inline)))) + (vars (mapcar #'(lambda (type) + (declare (ignore type)) + (gensym)) + (cadr inline)))) + `((eval-when (compile eval load) + (make-function-inline + ',(cons name (cdr inline)))) + ,@(when (or (every #'(lambda (type) (eq type 't)) + (cadr inline)) + (char= #\% (aref (symbol-name (car inline)) 0))) + `((defun ,(car inline) ,vars + ,@(mapcan #'(lambda (var var-type) + (unless (eq var-type 't) + `((declare (type ,var-type ,var))))) + vars (cadr inline)) + (the ,(caddr inline) (,name ,@vars))) + (make-function-inline ',inline)))))) + *gcl-function-inlines*))) + +(define-inlines) + +(defsetf si:%compiled-function-name si:%set-compiled-function-name) +(defsetf %cclosure-env %set-cclosure-env) + +(defun set-function-name-1 (fn new-name ignore) + (declare (ignore ignore)) + (cond ((compiled-function-p fn) + (si::turbo-closure fn) + (when (symbolp new-name) (pcl::proclaim-defmethod new-name nil)) + (setf (si:%compiled-function-name fn) new-name)) + ((and (listp fn) + (eq (car fn) 'lambda-block)) + (setf (cadr fn) new-name)) + ((and (listp fn) + (eq (car fn) 'lambda)) + (setf (car fn) 'lambda-block + (cdr fn) (cons new-name (cdr fn))))) + fn) + + +(clines " + + + +object fSuse_fast_links(); +static +object set_cclosure (result_cc,value_cc,available_size) + object result_cc,value_cc; int available_size; +{ + object result_env_tail,value_env_tail; int i; + + /* If we are currently using fast linking, */ + /* make sure to remove the link for result_cc. */ + (VFUN_NARGS=2,fSuse_fast_links(sLnil,result_cc)); + +/* use_fast_links(3,Cnil,result_cc); */ + + result_env_tail=result_cc->cc.cc_env; + value_env_tail=value_cc->cc.cc_env; + for(i=available_size; + result_env_tail!=Cnil && i>0; + result_env_tail=CMPcdr(result_env_tail), value_env_tail=CMPcdr(value_env_tail)) + CMPcar(result_env_tail)=CMPcar(value_env_tail), i--; + result_cc->cc.cc_self=value_cc->cc.cc_self; + result_cc->cc.cc_data=value_cc->cc.cc_data; + + + return result_cc; +}") + +(defentry %set-cclosure (object object int) (object set_cclosure)) + + +(defun structure-functions-exist-p () + t) + +(si:define-compiler-macro structure-instance-p (x) + (once-only (x) + `(and (si:structurep ,x) + (not (eq (si:%structure-name ,x) 'std-instance))))) + +(defun structure-type (x) + (and (si:structurep x) + (si:%structure-name x))) + +(si:define-compiler-macro structure-type (x) + (once-only (x) + `(and (si:structurep ,x) + (si:%structure-name ,x)))) + +(defun structure-type-p (type) + (or (not (null (gethash type *structure-table*))) + (let (#+akcl(s-data nil)) + (and (symbolp type) + (setq s-data (get type 'si::s-data)) + + (null (si::s-data-type s-data) + ))))) + + +(defun structure-type-included-type-name (type) + (or (car (gethash type *structure-table*)) + (let ((includes (si::s-data-includes (get type 'si::s-data)))) + (when includes + (si::s-data-name includes))))) + +(defun structure-type-internal-slotds (type) + (si::s-data-slot-descriptions (get type 'si::s-data)) + ) + +(defun structure-type-slot-description-list (type) + (or (cdr (gethash type *structure-table*)) + (mapcan #'(lambda (slotd) + (when (and slotd (car slotd)) + (let ((offset (fifth slotd))) + (let ((reader #'(lambda (x) + (si:structure-ref1 x offset) + )) + (writer #'(lambda (v x) + (si:structure-set x type offset v)))) + #+turbo-closure (si:turbo-closure reader) + #+turbo-closure (si:turbo-closure writer) + (let* ((reader-sym + (let ((*package* *the-pcl-package*)) + (intern (format nil "~s SLOT~D" type offset)))) + (writer-sym (get-setf-function-name reader-sym)) + (slot-name (first slotd)) + (read-only-p (fourth slotd))) + (setf (symbol-function reader-sym) reader) + (setf (symbol-function writer-sym) writer) + (do-standard-defsetf-1 reader-sym) + (list (list slot-name + reader-sym + (and (not read-only-p) writer)))))))) + (let ((slotds (structure-type-internal-slotds type)) + (inc (structure-type-included-type-name type))) + (if inc + (nthcdr (length (structure-type-internal-slotds inc)) + slotds) + slotds))))) + +(defun structure-slotd-name (slotd) + (first slotd)) + +(defun structure-slotd-accessor-symbol (slotd) + (second slotd)) + +;(defun structure-slotd-writer-function (slotd) +; (third slotd)) + +(defun structure-slotd-reader-function (slotd) + (third slotd)) + +(defun structure-slotd-writer-function (slotd) + (fourth slotd)) + +(defun renew-sys-files() + ;; packages: + (compiler::get-packages "sys-package.lisp") + (with-open-file (st "sys-package.lisp" + :direction :output + :if-exists :append) + (format st "(lisp::in-package \"SI\") +(export '(%structure-name + %compiled-function-name + %set-compiled-function-name)) +(in-package \"PCL\") +")) + + ;; proclaims + (compiler::make-all-proclaims "*.fn") + (with-open-file (st "sys-proclaim.lisp" + :direction :output + :if-exists :append) + (format st "~%(IN-PACKAGE \"PCL\")~%") + (print + `(dolist (v ', + + (sloop::sloop for v in-package "PCL" + when (get v 'compiler::proclaimed-closure) + collect v)) + (setf (get v 'compiler::proclaimed-closure) t)) + st) + (format st "~%") +)) + + + diff --git a/pcl/impl/gcl/gcl-patches.lisp b/pcl/impl/gcl/gcl-patches.lisp new file mode 100644 index 0000000..9e666a6 --- /dev/null +++ b/pcl/impl/gcl/gcl-patches.lisp @@ -0,0 +1,225 @@ +;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; + + +(in-package "COMPILER") + +;; do evaluation of top level forms at compile time. +(eval-when (compile eval load) +(setq *EVAL-WHEN-COMPILE* t) +) + +(pushnew :turbo-closure *features*) +(pushnew :turbo-closure-env-size *features*) +;; patch around compiler bug. + + +(let ((rset "int Rset; +")) + (unless (search rset compiler::*cmpinclude-string*) + (setq compiler::*cmpinclude-string* + (concatenate 'string rset compiler::*cmpinclude-string*)))) + +(when (get 'si::basic-wrapper 'si::s-data) + (pushnew :new-kcl-wrapper *features*) + (pushnew :structure-wrapper *features*)) + + + + +#+akcl +(progn + +(unless (fboundp 'real-c2lambda-expr-with-key) + (setf (symbol-function 'real-c2lambda-expr-with-key) + (symbol-function 'c2lambda-expr-with-key))) + +(defun c2lambda-expr-with-key (lambda-list body) + (declare (special *sup-used*)) + (setq *sup-used* t) + (real-c2lambda-expr-with-key lambda-list body)) + + +;There is a bug in the implementation of *print-circle* that +;causes some akcl debugging commands (including :bt and :bl) +;to cause the following error when PCL is being used: +;Unrecoverable error: value stack overflow. + +;When a CLOS object is printed, travel_push_object ends up +;traversing almost the whole class structure, thereby overflowing +;the value-stack. + +;from lsp/debug.lsp. +;*print-circle* is badly implemented in kcl. +;it has two separate problems that should be fixed: +; 1. it traverses the printed object putting all objects found +; on the value stack (rather than in a hash table or some +; other structure; this is a problem because the size of the value stack +; is fixed, and a potentially unbounded number of objects +; need to be traversed), and +; 2. it blindly traverses all slots of any +; kind of structure including std-object structures. +; This is safe, but not always necessary, and is very time-consuming +; for CLOS objects (because it will always traverse every class). + +;For now, avoid using *print-circle* T when it will cause problems. + + + +(eval-when (compile eval ) +(defmacro si::f (op &rest args) + `(the fixnum (,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) ))) + +(defmacro si::fb (op &rest args) + `(,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) )) +) + +(defun si::display-env (n env) + (do ((v (reverse env) (cdr v))) + ((or (not (consp v)) (si::fb > (fill-pointer si::*display-string*) n))) + (or (and (consp (car v)) + (listp (cdar v))) + (return)) + (let ((*print-circle* (can-use-print-circle-p (cadar v)))) + (format si::*display-string* "~s=~s~@[,~]" (caar v) (cadar v) (cdr v))))) + +(defun si::display-compiled-env ( plength ihs &aux + (base (si::ihs-vs ihs)) + (end (min (si::ihs-vs (1+ ihs)) (si::vs-top)))) + (format si::*display-string* "") + (do ((i base ) + (v (get (si::ihs-fname ihs) 'si::debug) (cdr v))) + ((or (si::fb >= i end)(si::fb > (fill-pointer si::*display-string*) plength))) + (let ((*print-circle* (can-use-print-circle-p (si::vs i)))) + (format si::*display-string* "~a~@[~d~]=~s~@[,~]" + (or (car v) 'si::loc) (if (not (car v)) (si::f - i base)) (si::vs i) + (si::fb < (setq i (si::f + i 1)) end))))) + +(clines "#define objnull_p(x) ((x==OBJNULL)?Ct:Cnil)") +(defentry objnull-p (object) (object "objnull_p")) + +(defun can-use-print-circle-p (x) + (catch 'can-use-print-circle-p + (can-use-print-circle-p1 x nil))) + +(defun can-use-print-circle-p1 (x so-far) + (and (not (objnull-p x)) ; because of deficiencies in the compiler, maybe? + (if (member x so-far) + (throw 'can-use-print-circle-p t) + (let ((so-far (cons x so-far))) + (flet ((can-use-print-circle-p (x) + (can-use-print-circle-p1 x so-far))) + (typecase x + (vector (or (not (eq 't (array-element-type x))) + (every #'can-use-print-circle-p x))) + (cons (and (can-use-print-circle-p (car x)) + (can-use-print-circle-p (cdr x)))) + (array (or (not (eq 't (array-element-type x))) + (let* ((rank (array-rank x)) + (dimensions (make-list rank))) + (dotimes (i rank) + (setf (nth i dimensions) (array-dimension x i))) + (or (member 0 dimensions) + (do ((cursor (make-list rank :initial-element 0))) + (nil) + (declare (:dynamic-extent cursor)) + (unless (can-use-print-circle-p + (apply #'aref x cursor)) + (return nil)) + (when (si::increment-cursor cursor dimensions) + (return t))))))) + (t (or (not (si:structurep x)) + (let* ((def (si:structure-def x)) + (name (si::s-data-name def)) + (len (si::s-data-length def)) + (pfun (si::s-data-print-function def))) + (and (null pfun) + (dotimes (i len t) + (unless (can-use-print-circle-p + (si:structure-ref x name i)) + (return nil))))))))))))) + +(defun si::apply-display-fun (display-fun n lis) + (let ((*print-length* si::*debug-print-level*) + (*print-level* si::*debug-print-level*) + (*print-pretty* nil) + (*PRINT-CASE* :downcase) + (*print-circle* nil) + ) + (setf (fill-pointer si::*display-string*) 0) + (format si::*display-string* "{") + (funcall display-fun n lis) + (when (si::fb > (fill-pointer si::*display-string*) n) + (setf (fill-pointer si::*display-string*) n) + (format si::*display-string* "...")) + + (format si::*display-string* "}") + ) + si::*display-string* + ) + +;The old definition of this had a bug: +;sometimes it returned without calling mv-values. +(defun si::next-stack-frame (ihs &aux line-info li i k na) + (cond ((si::fb < ihs si::*ihs-base*) + (si::mv-values nil nil nil nil nil)) + ((let (fun) + ;; next lower visible ihs + (si::mv-setq (fun i) (si::get-next-visible-fun ihs)) + (setq na fun) + (cond ((and (setq line-info (get fun 'si::line-info)) + (do ((j (si::f + ihs 1) (si::f - j 1)) + (form )) + ((<= j i) nil) + (setq form (si::ihs-fun j)) + (cond ((setq li (si::get-line-of-form form line-info)) + (return-from si::next-stack-frame + (si::mv-values + i fun li + ;; filename + (car (aref line-info 0)) + ;;environment + (list (si::vs (setq k (si::ihs-vs j))) + (si::vs (1+ k)) + (si::vs (+ k 2))))))))))))) + ((and (not (special-form-p na)) + (not (get na 'si::dbl-invisible)) + (fboundp na)) + (si::mv-values i na nil nil + (if (si::ihs-not-interpreted-env i) + nil + (let ((i (si::ihs-vs i))) + (list (si::vs i) (si::vs (1+ i)) (si::vs (si::f + i 2))))))) + (t (si::mv-values nil nil nil nil nil)))) +) + + + + + + + diff --git a/pcl/impl/gcl/gcl_pcl_impl_low.lisp b/pcl/impl/gcl/gcl_pcl_impl_low.lisp new file mode 100644 index 0000000..85c4d42 --- /dev/null +++ b/pcl/impl/gcl/gcl_pcl_impl_low.lisp @@ -0,0 +1,310 @@ +(in-package "SI") +(export '(%structure-name + %compiled-function-name + %set-compiled-function-name)) +(in-package 'pcl) +(eval-when (compile eval load) +(setq *EVAL-WHEN-COMPILE* t) +) + +(defmacro memq (item list) `(member ,item ,list :test #'eq)) +(defmacro assq (item list) `(assoc ,item ,list :test #'eq)) +(defmacro posq (item list) `(position ,item ,list :test #'eq)) + +;; The generic dotimes macro is now sufficient for the performance +;; gains sought here. Even the declaration extraction should be the +;; same as that provided in do* which dotimes invokes. 20040403 CM +;(defmacro dotimes ((var form &optional (val nil)) &rest body &environment env) +; (multiple-value-bind (doc decls bod) +; (extract-declarations body env) +; (declare (ignore doc)) +; (let ((limit (gensym)) +; (label (gensym))) +; `(let ((,limit ,form) +; (,var 0)) +; (declare (fixnum ,limit ,var)) +; ,@decls +; (block nil +; (tagbody +; ,label +; (when (>= ,var ,limit) (return-from nil ,val)) +; ,@bod +; (setq ,var (the fixnum (1+ ,var))) +; (go ,label))))))) + +(defun printing-random-thing-internal (thing stream) + (format stream "~O" (si:address thing))) + +(eval-when (compile load eval) +(pushnew :turbo-closure *features*) +(pushnew :turbo-closure-env-size *features*)) +) + +(defmacro %svref (vector index) + `(svref (the simple-vector ,vector) (the fixnum ,index))) + +(defsetf %svref (vector index) (new-value) + `(setf (svref (the simple-vector ,vector) (the fixnum ,index)) + ,new-value)) + +(si::freeze-defstruct 'pcl::std-instance) + +(si::freeze-defstruct 'method-call) +(si::freeze-defstruct 'fast-method-call) + +(defvar *pcl-funcall* `(lambda (loc) + (compiler::wt-nl + "{object _funobj = " loc ";" + "if(type_of(_funobj)==t_cclosure && (_funobj->cc.cc_turbo)) + (*(_funobj->cc.cc_self))(_funobj); + else if (type_of(_funobj)==t_cfun) (*(_funobj->cc.cc_self))(); + else super_funcall_no_event(_funobj);}"))) + +(setq compiler::*super-funcall* *pcl-funcall*) + +(defmacro fmc-funcall (fn pv-cell next-method-call &rest args) + `(funcall ,fn ,pv-cell ,next-method-call ,@args)) + +(defun pcl::proclaim-defmethod (x y) y + (and (symbolp x) + (setf (get x 'compiler::proclaimed-closure ) t))) + + + +;#+turbo-closure-env-size +(clines " +static object cclosure_env_nthcdr (fixnum n,object cc) { + object env,*turbo; + if(n<0)return Cnil; + if(type_of(cc)!=t_cclosure)return Cnil; + if((turbo=cc->cc.cc_turbo)==NULL) + {env=cc->cc.cc_env; + while(n-->0) + {if(type_of(env)!=t_cons)return Cnil; + env=env->c.c_cdr;} + return env;} + else + {if(n>=fix(*(turbo-1)))return Cnil; + return turbo[n];} +}") + +(defentry cclosure-env-nthcdr (fixnum object) (compiler::static object cclosure_env_nthcdr)) +;; This is the unsafe but fast version. +(defentry %cclosure-env-nthcdr (fixnum object) (compiler::static object cclosure_env_nthcdr)) + +(eval-when (compile eval load) +(defparameter *gcl-function-inlines* + '( (%fboundp (t) compiler::boolean nil nil "(#0)->s.s_gfdef!=OBJNULL") + (%symbol-function (t) t nil nil "(#0)->s.s_gfdef") + (si:%structure-name (t) t nil nil "(#0)->str.str_def->str.str_self[0]") + (si:%compiled-function-name (t) t nil nil "(#0)->cf.cf_name") + (si:%set-compiled-function-name (t t) t t nil "((#0)->cf.cf_name)=(#1)") + (cclosurep (t) compiler::boolean nil nil "type_of(#0)==t_cclosure") + (sfun-p (t) compiler::boolean nil nil "type_of(#0)==t_sfun") + (%cclosure-env (t) t nil nil "(#0)->cc.cc_env") + (%set-cclosure-env (t t) t t nil "((#0)->cc.cc_env)=(#1)") + #+turbo-closure + (%cclosure-env-nthcdr (fixnum t) t nil nil "(#1)->cc.cc_turbo[#0]") + + (logxor (fixnum fixnum) fixnum nil nil "((#0) ^ (#1))"))) + +(defun make-function-inline (inline) + (setf (get (car inline) 'compiler::inline-always) + (list (if (fboundp 'compiler::flags) + (let ((opt (cdr inline))) + (list (first opt) (second opt) + (logior (if (fourth opt) 1 0) ; allocates-new-storage + (if (third opt) 2 0) ; side-effect + (if nil 4 0) ; constantp + (if (eq (car inline) 'logxor) + 8 0)) ;result type from args + (fifth opt))) + (cdr inline)))))) + + +(defmacro define-inlines () + `(progn + ,@(mapcan #'(lambda (inline) + (let ((name (intern (format nil "~S inline" (car inline)))) + (vars (mapcar #'(lambda (type) + (declare (ignore type)) + (gensym)) + (cadr inline)))) + `((eval-when (compile eval load) + (make-function-inline + ',(cons name (cdr inline)))) + ,@(when (or (every #'(lambda (type) (eq type 't)) + (cadr inline)) + (char= #\% (aref (symbol-name (car inline)) 0))) + `((defun ,(car inline) ,vars + ,@(mapcan #'(lambda (var var-type) + (unless (eq var-type 't) + `((declare (type ,var-type ,var))))) + vars (cadr inline)) + (the ,(caddr inline) (,name ,@vars))) + (make-function-inline ',inline)))))) + *gcl-function-inlines*))) + +(define-inlines) + +(defsetf si:%compiled-function-name si:%set-compiled-function-name) +(defsetf %cclosure-env %set-cclosure-env) + +(defun set-function-name-1 (fn new-name ignore) + (declare (ignore ignore)) + (cond ((compiled-function-p fn) + (si::turbo-closure fn) + (when (symbolp new-name) (pcl::proclaim-defmethod new-name nil)) + (setf (si:%compiled-function-name fn) new-name)) + ((and (listp fn) + (eq (car fn) 'lambda-block)) + (setf (cadr fn) new-name)) + ((and (listp fn) + (eq (car fn) 'lambda)) + (setf (car fn) 'lambda-block + (cdr fn) (cons new-name (cdr fn))))) + fn) + + +(clines " +object fSuse_fast_links_2(object,object); +static object set_cclosure (object result_cc,object value_cc,fixnum available_size) { + object result_env_tail,value_env_tail; int i; + + /* If we are currently using fast linking, */ + /* make sure to remove the link for result_cc. */ + /* (VFUN_NARGS=2,fSuse_fast_links_2(Cnil,result_cc));*/ + fSuse_fast_links_2(Cnil,result_cc); + +/* use_fast_links(3,Cnil,result_cc); */ + + result_env_tail=result_cc->cc.cc_env; + value_env_tail=value_cc->cc.cc_env; + for(i=available_size; + result_env_tail!=Cnil && i>0; + result_env_tail=CMPcdr(result_env_tail), value_env_tail=CMPcdr(value_env_tail)) + CMPcar(result_env_tail)=CMPcar(value_env_tail), i--; + result_cc->cc.cc_self=value_cc->cc.cc_self; + result_cc->cc.cc_data=value_cc->cc.cc_data; + + return result_cc; +}") + +(defentry %set-cclosure (object object fixnum) (compiler::static object set_cclosure)) + + +(defun structure-functions-exist-p () + t) + +(si:define-compiler-macro structure-instance-p (x) + (once-only (x) + `(and (si:structurep ,x) + (not (eq (si:%structure-name ,x) 'std-instance))))) + +(defun structure-type (x) + (and (si:structurep x) + (si:%structure-name x))) + +(si:define-compiler-macro structure-type (x) + (once-only (x) + `(and (si:structurep ,x) + (si:%structure-name ,x)))) + +(defun structure-type-p (type) + (or (not (null (gethash type *structure-table*))) + (let (#+akcl(s-data nil)) + (and (symbolp type) + (setq s-data (get type 'si::s-data)) + + (null (si::s-data-type s-data) + ))))) + + +(defun structure-type-included-type-name (type) + (or (car (gethash type *structure-table*)) + (let ((includes (si::s-data-includes (get type 'si::s-data)))) + (when includes + (si::s-data-name includes))))) + +(defun structure-type-internal-slotds (type) + (si::s-data-slot-descriptions (get type 'si::s-data)) + ) + +(defun structure-type-slot-description-list (type) + (or (cdr (gethash type *structure-table*)) + (mapcan #'(lambda (slotd) + (when (and slotd (car slotd)) + (let ((offset (fifth slotd))) + (let ((reader #'(lambda (x) + (si:structure-ref1 x offset) + )) + (writer #'(lambda (v x) + (si:structure-set x type offset v)))) + #+turbo-closure (si:turbo-closure reader) + #+turbo-closure (si:turbo-closure writer) + (let* ((reader-sym + (let ((*package* *the-pcl-package*)) + (intern (format nil "~s SLOT~D" type offset)))) + (writer-sym (get-setf-function-name reader-sym)) + (slot-name (first slotd)) + (read-only-p (fourth slotd))) + (setf (symbol-function reader-sym) reader) + (setf (symbol-function writer-sym) writer) + (do-standard-defsetf-1 reader-sym) + (list (list slot-name + reader-sym + (and (not read-only-p) writer)))))))) + (let ((slotds (structure-type-internal-slotds type)) + (inc (structure-type-included-type-name type))) + (if inc + (nthcdr (length (structure-type-internal-slotds inc)) + slotds) + slotds))))) + +(defun structure-slotd-name (slotd) + (first slotd)) + +(defun structure-slotd-accessor-symbol (slotd) + (second slotd)) + +;(defun structure-slotd-writer-function (slotd) +; (third slotd)) + +(defun structure-slotd-reader-function (slotd) + (third slotd)) + +(defun structure-slotd-writer-function (slotd) + (fourth slotd)) + +(defun renew-sys-files() + ;; packages: + (compiler::get-packages "sys-package.lisp") + (with-open-file (st "sys-package.lisp" + :direction :output + :if-exists :append) + (format st "(lisp::in-package \"SI\") +(export '(%structure-name + %compiled-function-name + %set-compiled-function-name)) +(in-package \"PCL\") +")) + + ;; proclaims + (compiler::make-all-proclaims "*.fn") + (with-open-file (st "sys-proclaim.lisp" + :direction :output + :if-exists :append) + (format st "~%(IN-PACKAGE \"PCL\")~%") + (print + `(dolist (v ', + + (sloop::sloop for v in-package "PCL" + when (get v 'compiler::proclaimed-closure) + collect v)) + (setf (get v 'compiler::proclaimed-closure) t)) + st) + (format st "~%") +)) + + + diff --git a/pcl/impl/gcl/makefile.gcl b/pcl/impl/gcl/makefile.gcl new file mode 100644 index 0000000..46a50be --- /dev/null +++ b/pcl/impl/gcl/makefile.gcl @@ -0,0 +1,38 @@ +# makefile for making pcl -- W. Schelter. + +# Directions: +# make -f makefile.gcl compile +# make -f makefile.gcl saved_pcl + + +LISP=gcl + + +SETUP='(load "sys-package.lisp")' \ + '(setq *features* (delete (quote kcl) *features*))'\ + '(load "defsys.lisp")(push (quote kcl) *features*)' \ + '(setq pcl::*default-pathname-extensions* (cons "lisp" "o"))' \ + '(setq pcl::*pathname-extensions* (cons "lisp" "o"))' \ + '(load "sys-proclaim.lisp")(compiler::emit-fn t)' + +compile: + echo ${SETUP} '(pcl::compile-pcl)' | ${LISP} + +saved_pcl: + echo ${SETUP} '(pcl::load-pcl)(si::save-system "saved_pcl")' | ${LISP} + + +# remake the sys-package.lisp and sys-proclaim.lisp files +# Those files may be empty on a first build. +remake-sys-files: + echo ${SETUP} '(pcl::load-pcl)(in-package "PCL")(renew-sys-files)' | ${LISP} + cp sys-proclaim.lisp xxx + cat xxx | sed -e "s/COMPILER::CMP-ANON//g" > sys-proclaim.lisp + rm xxx + + +tar: + make -f makefile.gcl tar1 DIR=`pwd` + +tar1: + (cd .. ; tar cvf - `basename ${DIR}` | gzip -c > `basename ${DIR}`.tgz) diff --git a/pcl/impl/gcl/sys-package.lisp b/pcl/impl/gcl/sys-package.lisp new file mode 100644 index 0000000..c04430e --- /dev/null +++ b/pcl/impl/gcl/sys-package.lisp @@ -0,0 +1,149 @@ + + +;;; Definitions for package SLOT-ACCESSOR-NAME of type ESTABLISH +(LISP::IN-PACKAGE "SLOT-ACCESSOR-NAME" :USE LISP::NIL :NICKNAMES + '("S-A-N")) + +;;; Definitions for package PCL of type ESTABLISH +(LISP::IN-PACKAGE "PCL" :USE LISP::NIL) + +;;; Definitions for package ITERATE of type ESTABLISH +(LISP::IN-PACKAGE "ITERATE" :USE LISP::NIL) + +;;; Definitions for package WALKER of type ESTABLISH +(LISP::IN-PACKAGE "WALKER" :USE LISP::NIL) + +;;; Definitions for package SLOT-ACCESSOR-NAME of type EXPORT +(LISP::IN-PACKAGE "SLOT-ACCESSOR-NAME" :USE 'LISP::NIL :NICKNAMES + '("S-A-N")) +(LISP::IMPORT 'LISP::NIL) +(LISP::EXPORT 'LISP::NIL) + +;;; Definitions for package PCL of type EXPORT +(LISP::IN-PACKAGE "PCL" :USE '("LISP" "ITERATE" "WALKER")) +(LISP::IMPORT 'LISP::NIL) +(LISP::EXPORT + '(PCL::CLASS-PRECEDENCE-LIST PCL::SLOT-DEFINITION + PCL::COMPUTE-APPLICABLE-METHODS-USING-CLASSES + PCL::SLOT-DEFINITION-WRITERS PCL::CLASS-OF + PCL::NO-APPLICABLE-METHOD PCL::STANDARD-WRITER-METHOD + PCL::ENSURE-CLASS-USING-CLASS PCL::ENSURE-GENERIC-FUNCTION + PCL::FIND-METHOD-COMBINATION PCL::UPDATE-DEPENDENT + PCL::MAP-DEPENDENTS PCL::SLOT-MISSING PCL::SPECIALIZER + PCL::CALL-NEXT-METHOD PCL::ENSURE-GENERIC-FUNCTION-USING-CLASS + PCL::SLOT-MAKUNBOUND-USING-CLASS PCL::MAKE-INSTANCES-OBSOLETE + PCL::INTERN-EQL-SPECIALIZER PCL::REMOVE-DIRECT-SUBCLASS + PCL::METHOD-GENERIC-FUNCTION PCL::METHOD-QUALIFIERS + PCL::FUNCALLABLE-STANDARD-CLASS PCL::EXTRACT-LAMBDA-LIST + PCL::STANDARD-CLASS PCL::PRINT-OBJECT PCL::STRUCTURE-CLASS + PCL::COMPUTE-EFFECTIVE-SLOT-DEFINITION + PCL::GENERIC-FUNCTION-DECLARATIONS PCL::MAKE-INSTANCE + PCL::METHOD-LAMBDA-LIST PCL::DEFGENERIC + PCL::REMOVE-DIRECT-METHOD PCL::STANDARD-DIRECT-SLOT-DEFINITION + PCL::GENERIC-FUNCTION-METHODS PCL::VALIDATE-SUPERCLASS + PCL::REINITIALIZE-INSTANCE PCL::STANDARD-METHOD + PCL::STANDARD-ACCESSOR-METHOD + PCL::FUNCALLABLE-STANDARD-INSTANCE PCL::FUNCTION-KEYWORDS + PCL::STANDARD PCL::FIND-METHOD PCL::EXTRACT-SPECIALIZER-NAMES + PCL::INITIALIZE-INSTANCE PCL::GENERIC-FLET PCL::SLOT-UNBOUND + PCL::STANDARD-INSTANCE PCL::SLOT-DEFINITION-TYPE + PCL::COMPUTE-EFFECTIVE-METHOD PCL::ALLOCATE-INSTANCE + PCL::SYMBOL-MACROLET PCL::GENERIC-FUNCTION + PCL::GENERIC-FUNCTION-METHOD-COMBINATION + PCL::SPECIALIZER-DIRECT-METHODS PCL::ADD-DIRECT-SUBCLASS + PCL::WRITER-METHOD-CLASS PCL::SLOT-DEFINITION-INITARGS + PCL::METHOD-SPECIALIZERS PCL::GENERIC-FUNCTION-METHOD-CLASS + PCL::ADD-METHOD PCL::WITH-ACCESSORS + PCL::SLOT-DEFINITION-ALLOCATION + PCL::SLOT-DEFINITION-INITFUNCTION + PCL::SLOT-DEFINITION-LOCATION PCL::ADD-DIRECT-METHOD + PCL::SLOT-BOUNDP PCL::EQL-SPECIALIZER PCL::SHARED-INITIALIZE + PCL::STANDARD-GENERIC-FUNCTION + PCL::ACCESSOR-METHOD-SLOT-DEFINITION + PCL::SLOT-BOUNDP-USING-CLASS PCL::ADD-DEPENDENT + PCL::SPECIALIZER-DIRECT-GENERIC-FUNCTION + PCL::WITH-ADDED-METHODS PCL::COMPUTE-CLASS-PRECEDENCE-LIST + PCL::REMOVE-DEPENDENT PCL::NEXT-METHOD-P + PCL::GENERIC-FUNCTION-NAME PCL::SLOT-VALUE + PCL::EFFECTIVE-SLOT-DEFINITION PCL::CLASS-FINALIZED-P + PCL::COMPUTE-DISCRIMINATING-FUNCTION PCL::STANDARD-OBJECT + PCL::CLASS-DEFAULT-INITARGS PCL::CLASS-DIRECT-SLOTS + PCL::FUNCALLABLE-STANDARD-INSTANCE-ACCESS PCL::BUILT-IN-CLASS + PCL::NO-NEXT-METHOD PCL::SLOT-MAKUNBOUND + PCL::STANDARD-READER-METHOD PCL::GENERIC-FUNCTION-LAMBDA-LIST + PCL::GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER + PCL::INVALID-METHOD-ERROR PCL::METHOD-COMBINATION-ERROR + PCL::SLOT-EXISTS-P PCL::FINALIZE-INHERITANCE + PCL::SLOT-DEFINITION-NAME + PCL::STANDARD-EFFECTIVE-SLOT-DEFINITION PCL::COMPUTE-SLOTS + PCL::CLASS-SLOTS PCL::EFFECTIVE-SLOT-DEFINITION-CLASS + PCL::STANDARD-INSTANCE-ACCESS PCL::WITH-SLOTS + PCL::DIRECT-SLOT-DEFINITION PCL::DEFINE-METHOD-COMBINATION + PCL::MAKE-METHOD-LAMBDA PCL::ENSURE-CLASS + PCL::DIRECT-SLOT-DEFINITION-CLASS PCL::METHOD-FUNCTION + PCL::STANDARD-SLOT-DEFINITION PCL::CHANGE-CLASS PCL::DEFMETHOD + PCL::UPDATE-INSTANCE-FOR-DIFFERENT-CLASS + PCL::UPDATE-INSTANCE-FOR-REDEFINED-CLASS + PCL::FORWARD-REFERENCED-CLASS PCL::SLOT-DEFINITION-INITFORM + PCL::REMOVE-METHOD PCL::READER-METHOD-CLASS PCL::CALL-METHOD + PCL::CLASS-PROTOTYPE PCL::CLASS-NAME PCL::FIND-CLASS + PCL::DEFCLASS PCL::COMPUTE-APPLICABLE-METHODS + PCL::SLOT-VALUE-USING-CLASS PCL::METHOD-COMBINATION + PCL::EQL-SPECIALIZER-INSTANCE PCL::GENERIC-LABELS PCL::METHOD + PCL::SLOT-DEFINITION-READERS + PCL::CLASS-DIRECT-DEFAULT-INITARGS + PCL::CLASS-DIRECT-SUBCLASSES PCL::CLASS-DIRECT-SUPERCLASSES + PCL::SET-FUNCALLABLE-INSTANCE-FUNCTION)) + +;;; Definitions for package ITERATE of type EXPORT +(LISP::IN-PACKAGE "ITERATE" :USE '("WALKER" "LISP")) +(LISP::IMPORT 'LISP::NIL) +(LISP::EXPORT + '(ITERATE::SUMMING ITERATE::MINIMIZING ITERATE::PLIST-ELEMENTS + ITERATE::ITERATE* ITERATE::MAXIMIZING ITERATE::LIST-TAILS + ITERATE::*ITERATE-WARNINGS* ITERATE::GATHERING + ITERATE::EACHTIME ITERATE::ELEMENTS ITERATE::GATHER + ITERATE::LIST-ELEMENTS ITERATE::WHILE ITERATE::ITERATE + ITERATE::UNTIL ITERATE::JOINING ITERATE::COLLECTING + ITERATE::WITH-GATHERING ITERATE::INTERVAL)) + +;;; Definitions for package WALKER of type EXPORT +(LISP::IN-PACKAGE "WALKER" :USE '("LISP")) +(LISP::IMPORT 'LISP::NIL) +(LISP::EXPORT + '(WALKER::DEFINE-WALKER-TEMPLATE WALKER::*VARIABLE-DECLARATIONS* + WALKER::NESTED-WALK-FORM WALKER::VARIABLE-DECLARATION + WALKER::WALK-FORM-EXPAND-MACROS-P WALKER::VARIABLE-LEXICAL-P + WALKER::VARIABLE-SPECIAL-P WALKER::WALK-FORM + WALKER::MACROEXPAND-ALL WALKER::VARIABLE-GLOBALLY-SPECIAL-P)) + +;;; Definitions for package SLOT-ACCESSOR-NAME of type SHADOW +(LISP::IN-PACKAGE "SLOT-ACCESSOR-NAME") +(LISP::SHADOW 'LISP::NIL) +(LISP::SHADOWING-IMPORT 'LISP::NIL) +(LISP::IMPORT 'LISP::NIL) + +;;; Definitions for package PCL of type SHADOW +(LISP::IN-PACKAGE "PCL") +(LISP::SHADOW '(PCL::DOTIMES PCL::DOCUMENTATION)) +(LISP::SHADOWING-IMPORT 'LISP::NIL) +(LISP::IMPORT + '(SYSTEM::STRUCTURE-REF SYSTEM::STRUCTURE-DEF SYSTEM::STRUCTUREP)) + +;;; Definitions for package ITERATE of type SHADOW +(LISP::IN-PACKAGE "ITERATE") +(LISP::SHADOW 'LISP::NIL) +(LISP::SHADOWING-IMPORT 'LISP::NIL) +(LISP::IMPORT 'LISP::NIL) + +;;; Definitions for package WALKER of type SHADOW +(LISP::IN-PACKAGE "WALKER") +(LISP::SHADOW 'LISP::NIL) +(LISP::SHADOWING-IMPORT 'LISP::NIL) +(LISP::IMPORT 'LISP::NIL) + +(in-package 'SI) +(export '(%structure-name + %compiled-function-name + %set-compiled-function-name)) +(in-package 'pcl) diff --git a/pcl/impl/gcl/sys-proclaim.lisp b/pcl/impl/gcl/sys-proclaim.lisp new file mode 100644 index 0000000..26f8698 --- /dev/null +++ b/pcl/impl/gcl/sys-proclaim.lisp @@ -0,0 +1,1448 @@ + +(IN-PACKAGE "PCL") +(PROCLAIM + '(FTYPE (FUNCTION (T) FIXNUM) ONE-INDEX-LIMIT-FN + N-N-ACCESSORS-LIMIT-FN CHECKING-LIMIT-FN PV-CACHE-LIMIT-FN + ARG-INFO-NUMBER-REQUIRED DEFAULT-LIMIT-FN CACHE-COUNT + CACHING-LIMIT-FN PV-TABLE-PV-SIZE EARLY-CLASS-SIZE + CPD-COUNT FAST-INSTANCE-BOUNDP-INDEX)) +(PROCLAIM '(FTYPE (FUNCTION (T) FIELD-TYPE) CACHE-FIELD)) +(PROCLAIM + '(FTYPE (FUNCTION (T) FUNCTION) CACHE-LIMIT-FN METHOD-CALL-FUNCTION + FAST-METHOD-CALL-FUNCTION)) +(PROCLAIM '(FTYPE (FUNCTION (FIXNUM) T) POWER-OF-TWO-CEILING)) +(PROCLAIM + '(FTYPE (FUNCTION (T) LIST) CACHE-OVERFLOW PV-TABLE-SLOT-NAME-LISTS + PV-TABLE-CALL-LIST)) +(PROCLAIM '(FTYPE (FUNCTION (T) (MEMBER NIL T)) CACHE-VALUEP)) +(PROCLAIM '(FTYPE (FUNCTION (T) SIMPLE-VECTOR) CACHE-VECTOR)) +(PROCLAIM + '(FTYPE (FUNCTION (T) (VALUES T T)) MAKE-CLASS-PREDICATE-NAME + MAKE-KEYWORD)) +(PROCLAIM '(FTYPE (FUNCTION (FIXNUM T) T) %CCLOSURE-ENV-NTHCDR)) +(PROCLAIM + '(FTYPE (FUNCTION (FIXNUM FIXNUM T) FIXNUM) + COMPUTE-PRIMARY-CACHE-LOCATION)) +(PROCLAIM '(FTYPE (FUNCTION (T) (INTEGER 1 256)) CACHE-NKEYS)) +(PROCLAIM '(FTYPE (FUNCTION (T) (INTEGER 1 512)) CACHE-LINE-SIZE)) +(PROCLAIM '(FTYPE (FUNCTION (T) (OR CACHE NULL)) PV-TABLE-CACHE)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T) *) + GET-OPTIMIZED-STD-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION + ITERATE::WALK-GATHERING-BODY CACHE-MISS-VALUES + MAKE-OPTIMIZED-STD-READER-METHOD-FUNCTION + OPTIMIZE-SLOT-VALUE-BY-CLASS-P ACCESSOR-VALUES1 + EMIT-READER/WRITER EMIT-ONE-OR-N-INDEX-READER/WRITER + GENERATING-LISP EMIT-READER/WRITER-FUNCTION + EMIT-ONE-OR-N-INDEX-READER/WRITER-FUNCTION + WALKER::WALK-LET-IF SET-SLOT-VALUE CONVERT-METHODS + |(FAST-METHOD METHOD-LAMBDA-LIST (TRACED-METHOD))| + SLOT-VALUE-USING-CLASS-DFUN SLOT-BOUNDP-USING-CLASS-DFUN + |(FAST-METHOD METHOD-SPECIALIZERS (TRACED-METHOD))| + CHECK-METHOD-ARG-INFO + |(FAST-METHOD METHOD-QUALIFIERS (TRACED-METHOD))| + LOAD-LONG-DEFCOMBIN MAKE-FINAL-N-N-ACCESSOR-DFUN + |(FAST-METHOD ACCESSOR-METHOD-SLOT-NAME (TRACED-METHOD))| + MAKE-FINAL-CACHING-DFUN MAKE-FINAL-CONSTANT-VALUE-DFUN + GET-CLASS-SLOT-VALUE-1 ACCESSOR-VALUES-INTERNAL + MAKE-OPTIMIZED-STD-WRITER-METHOD-FUNCTION + MAKE-OPTIMIZED-STD-BOUNDP-METHOD-FUNCTION + ITERATE::EXPAND-INTO-LET WALKER::WALK-FORM-INTERNAL + ITERATE::RENAME-VARIABLES CONSTANT-VALUE-MISS CACHING-MISS + |(FAST-METHOD COMPUTE-DISCRIMINATING-FUNCTION (STANDARD-GENERIC-FUNCTION))| + CHECKING-MISS GET-OPTIMIZED-STD-ACCESSOR-METHOD-FUNCTION + |(FAST-METHOD FUNCTION-KEYWORDS (STANDARD-METHOD))| + |(FAST-METHOD METHOD-PRETTY-ARGLIST (STANDARD-METHOD))| + |(FAST-METHOD CLASS-PROTOTYPE (STD-CLASS))| + |(FAST-METHOD CLASS-PROTOTYPE (STRUCTURE-CLASS))| + |(FAST-METHOD MAKE-INSTANCES-OBSOLETE (SYMBOL))| + |(FAST-METHOD METHOD-FUNCTION (STANDARD-METHOD))| + |(FAST-METHOD COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO (STANDARD-GENERIC-FUNCTION))|)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T) *) + |(FAST-METHOD COMPUTE-EFFECTIVE-METHOD (GENERIC-FUNCTION LONG-METHOD-COMBINATION T))| + |(FAST-METHOD UPDATE-INSTANCE-FOR-DIFFERENT-CLASS (STANDARD-OBJECT STANDARD-OBJECT))| + |(FAST-METHOD SHARED-INITIALIZE (SLOT-OBJECT T))| + COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO-INTERNAL + ADD-METHOD-DECLARATIONS WALK-METHOD-LAMBDA + MAKE-TWO-CLASS-ACCESSOR-DFUN + |(FAST-METHOD (SETF SLOT-ACCESSOR-FUNCTION) (T EFFECTIVE-SLOT-DEFINITION T))| + |(FAST-METHOD SHARED-INITIALIZE :AFTER (CLASS-EQ-SPECIALIZER T))| + |(FAST-METHOD SHARED-INITIALIZE :AFTER (EQL-SPECIALIZER T))| + |(FAST-METHOD SHARED-INITIALIZE :BEFORE (CLASS T))| + |(FAST-METHOD (SETF DOCUMENTATION) (T STANDARD-SLOT-DEFINITION))| + |(FAST-METHOD ADD-READER-METHOD (SLOT-CLASS T T))| + |(FAST-METHOD ADD-WRITER-METHOD (SLOT-CLASS T T))| + |(FAST-METHOD ADD-BOUNDP-METHOD (SLOT-CLASS T T))| + |(FAST-METHOD (SETF CLASS-SLOT-VALUE) (T STD-CLASS T))| + |(FAST-METHOD SLOT-VALUE-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| + |(FAST-METHOD SLOT-VALUE-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| + |(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-SLOT-DEFINITION T))| + |(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-METHOD T))| + |(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-ACCESSOR-METHOD T))| + |(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-GENERIC-FUNCTION T))|)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T) *) + |(FAST-METHOD ALLOCATE-INSTANCE (STRUCTURE-CLASS))| + |(FAST-METHOD MAKE-INSTANCE (SYMBOL))| + |(FAST-METHOD DEFAULT-INITARGS (SLOT-CLASS T))| + |(FAST-METHOD INITIALIZE-INSTANCE (SLOT-OBJECT))| + |(FAST-METHOD DESCRIBE-OBJECT (T T))| + |(FAST-METHOD DESCRIBE-OBJECT (SLOT-OBJECT T))| + |(FAST-METHOD SLOTS-TO-INSPECT (SLOT-CLASS SLOT-OBJECT))| + |(FAST-METHOD DESCRIBE-OBJECT (STANDARD-GENERIC-FUNCTION T))| + |(FAST-METHOD DESCRIBE-OBJECT (CLASS T))| + |(FAST-METHOD COMPUTE-APPLICABLE-METHODS-USING-CLASSES (GENERIC-FUNCTION T))| + GET-ACCESSOR-FROM-SVUC-METHOD-FUNCTION + |(FAST-METHOD SLOT-ACCESSOR-FUNCTION (EFFECTIVE-SLOT-DEFINITION T))| + BOOTSTRAP-ACCESSOR-DEFINITION GET-ACCESSOR-METHOD-FUNCTION + EMIT-CHECKING-OR-CACHING EMIT-CHECKING-OR-CACHING-FUNCTION + SETF-SLOT-VALUE-USING-CLASS-DFUN LOAD-SHORT-DEFCOMBIN + INITIALIZE-INSTANCE-SIMPLE-FUNCTION + MAKE-SHARED-INITIALIZE-FORM-LIST + MAKE-ONE-CLASS-ACCESSOR-DFUN + MAKE-FINAL-ONE-INDEX-ACCESSOR-DFUN MAKE-FINAL-CHECKING-DFUN + ACCESSOR-VALUES SET-CLASS-SLOT-VALUE-1 + GENERATE-DISCRIMINATION-NET REAL-MAKE-METHOD-LAMBDA + ORDER-SPECIALIZERS ACCESSOR-MISS + |(FAST-METHOD REINITIALIZE-INSTANCE :AFTER (SLOT-CLASS))| + |(FAST-METHOD DOCUMENTATION (STANDARD-SLOT-DEFINITION))| + |(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION (SLOT-CLASS T))| + |(FAST-METHOD NO-APPLICABLE-METHOD (T))| + |(FAST-METHOD CHANGE-CLASS (T SYMBOL))| + |(FAST-METHOD CLASS-SLOT-VALUE (STD-CLASS T))| + |(FAST-METHOD LEGAL-QUALIFIERS-P (STANDARD-METHOD T))| + |(FAST-METHOD LEGAL-SPECIALIZERS-P (STANDARD-METHOD T))|)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T T) *) MEMF-CODE-CONVERTER + CACHE-MISS-VALUES-INTERNAL + GENERATE-DISCRIMINATION-NET-INTERNAL + MAKE-LONG-METHOD-COMBINATION-FUNCTION + DO-SHORT-METHOD-COMBINATION + |(FAST-METHOD (SETF SLOT-VALUE-USING-CLASS) (T STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))|)) +(PROCLAIM '(FTYPE (FUNCTION (T T T T T T *) *) REAL-MAKE-A-METHOD)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T *) *) MAKE-ONE-INDEX-ACCESSOR-DFUN + WALKER::WALK-DECLARATIONS GET-SECONDARY-DISPATCH-FUNCTION)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T *) *) + MAKE-EFFECTIVE-METHOD-FUNCTION-SIMPLE1 + ITERATE::RENAME-LET-BINDINGS)) +(PROCLAIM + '(FTYPE (FUNCTION (T T *) *) NESTED-WALK-FORM SLOT-VALUE-OR-DEFAULT + MAKE-EFFECTIVE-METHOD-FUNCTION + GET-EFFECTIVE-METHOD-FUNCTION MAKE-N-N-ACCESSOR-DFUN + MAKE-CHECKING-DFUN LOAD-DEFGENERIC TYPES-FROM-ARGUMENTS + MAKE-DEFAULT-INITARGS-FORM-LIST MAKE-FINAL-ACCESSOR-DFUN + MAKE-ACCESSOR-TABLE GET-SIMPLE-INITIALIZATION-FUNCTION + GET-COMPLEX-INITIALIZATION-FUNCTIONS + COMPUTE-SECONDARY-DISPATCH-FUNCTION)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T T T) *) + |(FAST-METHOD UPDATE-INSTANCE-FOR-REDEFINED-CLASS (STANDARD-OBJECT T T T))| + ITERATE::ITERATE-TRANSFORM-BODY)) +(PROCLAIM + '(FTYPE (FUNCTION (T) NON-NEGATIVE-FIXNUM) CACHE-NLINES + CACHE-MAX-LOCATION CACHE-SIZE CACHE-MASK)) +(PROCLAIM '(FTYPE (FUNCTION (T STREAM T) T) PRINT-DFUN-INFO)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T) T) + |(FAST-METHOD ALLOCATE-INSTANCE (STANDARD-CLASS))| + |(FAST-METHOD VALIDATE-SUPERCLASS (FUNCALLABLE-STANDARD-CLASS STANDARD-CLASS))| + |(FAST-METHOD ALLOCATE-INSTANCE (FUNCALLABLE-STANDARD-CLASS))| + |(FAST-METHOD MAKE-READER-METHOD-FUNCTION (FUNCALLABLE-STANDARD-CLASS T))| + |(FAST-METHOD MAKE-WRITER-METHOD-FUNCTION (FUNCALLABLE-STANDARD-CLASS T))| + |(FAST-METHOD MAKE-INSTANCE (CLASS))| + |(FAST-METHOD REINITIALIZE-INSTANCE (SLOT-OBJECT))| + MAKE-EFFECTIVE-METHOD-FUNCTION1 + MAKE-EFFECTIVE-METHOD-FUNCTION-INTERNAL + MAKE-EFFECTIVE-METHOD-FUNCTION-TYPE MEMF-TEST-CONVERTER + LOAD-PRECOMPILED-DFUN-CONSTRUCTOR TWO-CLASS-DFUN-INFO + WALKER::WALK-LET/LET* WALKER::WALK-PROG/PROG* + WALKER::WALK-DO/DO* WALKER::WALK-BINDINGS-2 OPTIMIZE-READER + OPTIMIZE-WRITER + |(FAST-METHOD SAME-SPECIALIZER-P (SPECIALIZER SPECIALIZER))| + EMIT-CHECKING-OR-CACHING-FUNCTION-PRELIMINARY + |(FAST-METHOD SAME-SPECIALIZER-P (CLASS CLASS))| + MAYBE-EXPAND-ACCESSOR-FORM + |(FAST-METHOD ADD-DIRECT-SUBCLASS (CLASS CLASS))| + INITIALIZE-INSTANCE-SIMPLE + |(FAST-METHOD SAME-SPECIALIZER-P (CLASS-EQ-SPECIALIZER CLASS-EQ-SPECIALIZER))| + GET-WRAPPERS-FROM-CLASSES + |(FAST-METHOD SAME-SPECIALIZER-P (EQL-SPECIALIZER EQL-SPECIALIZER))| + LOAD-PRECOMPILED-IIS-ENTRY FILL-CACHE-P ADJUST-CACHE + |(FAST-METHOD REMOVE-DIRECT-SUBCLASS (CLASS CLASS))| + EXPAND-CACHE EXPAND-SYMBOL-MACROLET-INTERNAL + |(FAST-METHOD ADD-DIRECT-METHOD (CLASS METHOD))| + BOOTSTRAP-SET-SLOT EXPAND-DEFCLASS + |(FAST-METHOD REMOVE-DIRECT-METHOD (CLASS METHOD))| + |(FAST-METHOD UPDATE-GF-DFUN (STD-CLASS T))| + |(FAST-METHOD ADD-DIRECT-METHOD (SPECIALIZER-WITH-OBJECT METHOD))| + |(FAST-METHOD REMOVE-DIRECT-METHOD (SPECIALIZER-WITH-OBJECT METHOD))| + |(FAST-METHOD SLOT-ACCESSOR-STD-P (EFFECTIVE-SLOT-DEFINITION T))| + WALKER::WALK-TEMPLATE + |(FAST-METHOD REINITIALIZE-INSTANCE :BEFORE (SLOT-CLASS))| + |(FAST-METHOD DOCUMENTATION (T))| + |(FAST-METHOD DOCUMENTATION (DOCUMENTATION-MIXIN))| + |(FAST-METHOD DIRECT-SLOT-DEFINITION-CLASS (STRUCTURE-CLASS T))| + |(FAST-METHOD DIRECT-SLOT-DEFINITION-CLASS (STD-CLASS T))| + |(FAST-METHOD EFFECTIVE-SLOT-DEFINITION-CLASS (STD-CLASS T))| + |(FAST-METHOD EFFECTIVE-SLOT-DEFINITION-CLASS (STRUCTURE-CLASS T))| + |(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS (SLOT-CLASS T))| + |(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS :AROUND (STRUCTURE-CLASS T))| + |(FAST-METHOD REMOVE-READER-METHOD (SLOT-CLASS T))| + |(FAST-METHOD REMOVE-WRITER-METHOD (SLOT-CLASS T))| + |(FAST-METHOD REMOVE-BOUNDP-METHOD (SLOT-CLASS T))| + |(FAST-METHOD MAKE-READER-METHOD-FUNCTION (SLOT-CLASS T))| + |(FAST-METHOD MAKE-WRITER-METHOD-FUNCTION (SLOT-CLASS T))| + |(FAST-METHOD MAKE-BOUNDP-METHOD-FUNCTION (SLOT-CLASS T))| + |(FAST-METHOD INFORM-TYPE-SYSTEM-ABOUT-CLASS (STD-CLASS T))| + |(FAST-METHOD COMPATIBLE-META-CLASS-CHANGE-P (T T))| + |(FAST-METHOD VALIDATE-SUPERCLASS (CLASS CLASS))| + |(FAST-METHOD CHANGE-CLASS (STANDARD-OBJECT STANDARD-CLASS))| + |(FAST-METHOD CHANGE-CLASS (STANDARD-OBJECT FUNCALLABLE-STANDARD-CLASS))| + |(FAST-METHOD VALIDATE-SUPERCLASS (CLASS BUILT-IN-CLASS))| + |(FAST-METHOD VALIDATE-SUPERCLASS (SLOT-CLASS FORWARD-REFERENCED-CLASS))| + |(FAST-METHOD ADD-DEPENDENT (DEPENDENT-UPDATE-MIXIN T))| + |(FAST-METHOD REMOVE-DEPENDENT (DEPENDENT-UPDATE-MIXIN T))| + |(FAST-METHOD MAP-DEPENDENTS (DEPENDENT-UPDATE-MIXIN T))| + |(FAST-METHOD PRINT-OBJECT (T T))| + |(FAST-METHOD PRINT-OBJECT (CLASS T))| + |(FAST-METHOD PRINT-OBJECT (SLOT-DEFINITION T))| + |(FAST-METHOD PRINT-OBJECT (STANDARD-METHOD-COMBINATION T))| + |(FAST-METHOD INFORM-TYPE-SYSTEM-ABOUT-CLASS (STRUCTURE-CLASS T))| + |(FAST-METHOD PRINT-OBJECT (STANDARD-METHOD T))| + |(FAST-METHOD PRINT-OBJECT (STANDARD-ACCESSOR-METHOD T))| + |(FAST-METHOD REINITIALIZE-INSTANCE (STANDARD-METHOD))| + |(FAST-METHOD LEGAL-DOCUMENTATION-P (STANDARD-METHOD T))| + |(FAST-METHOD LEGAL-LAMBDA-LIST-P (STANDARD-METHOD T))| + |(FAST-METHOD LEGAL-METHOD-FUNCTION-P (STANDARD-METHOD T))| + |(FAST-METHOD LEGAL-QUALIFIER-P (STANDARD-METHOD T))| + |(FAST-METHOD LEGAL-SLOT-NAME-P (STANDARD-METHOD T))| + |(FAST-METHOD LEGAL-SPECIALIZER-P (STANDARD-METHOD T))| + |(FAST-METHOD PRINT-OBJECT (GENERIC-FUNCTION T))| + |(FAST-METHOD INITIALIZE-INSTANCE :AFTER (STANDARD-GENERIC-FUNCTION))| + MAKE-DISPATCH-LAMBDA + |(FAST-METHOD REINITIALIZE-INSTANCE :AFTER (STANDARD-GENERIC-FUNCTION))| + |(FAST-METHOD COMPUTE-APPLICABLE-METHODS (GENERIC-FUNCTION T))|)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T) T) + |(FAST-METHOD COMPUTE-CLASS-PRECEDENCE-LIST (SLOT-CLASS))| + CAN-OPTIMIZE-ACCESS + |(FAST-METHOD WRAPPER-FETCHER (FUNCALLABLE-STANDARD-CLASS))| + OPTIMIZE-SLOT-VALUE + |(FAST-METHOD SLOTS-FETCHER (FUNCALLABLE-STANDARD-CLASS))| + OPTIMIZE-SET-SLOT-VALUE + |(FAST-METHOD RAW-INSTANCE-ALLOCATOR (FUNCALLABLE-STANDARD-CLASS))| + DECLARE-STRUCTURE OPTIMIZE-SLOT-BOUNDP PRINT-CACHE + FIRST-FORM-TO-LISP ITERATE::OPTIMIZE-ITERATE-FORM + WRAP-METHOD-GROUP-SPECIFIER-BINDINGS MAKE-TOP-LEVEL-FORM + INVALIDATE-WRAPPER STANDARD-COMPUTE-EFFECTIVE-METHOD + MAKE-OPTIMIZED-STD-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION + MAKE-OPTIMIZED-STD-SETF-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION + MAKE-OPTIMIZED-STD-SLOT-BOUNDP-USING-CLASS-METHOD-FUNCTION + WALKER::RECONS ITERATE::OPTIMIZE-GATHERING-FORM + WALKER::WALK-MULTIPLE-VALUE-SETQ + |(FAST-METHOD CLASS-CONSTRUCTORS (SLOT-CLASS))| + |(FAST-METHOD CLASS-SLOT-CELLS (STD-CLASS))| + |(FAST-METHOD SPECIALIZER-CLASS (CLASS))| + |(FAST-METHOD SPECIALIZER-CLASS (EQL-SPECIALIZER))| + |(FAST-METHOD SPECIALIZER-DIRECT-METHODS (CLASS))| + |(FAST-METHOD SPECIALIZER-DIRECT-GENERIC-FUNCTIONS (CLASS))| + |(FAST-METHOD GENERIC-FUNCTION-PRETTY-ARGLIST (STANDARD-GENERIC-FUNCTION))| + |(FAST-METHOD SPECIALIZER-METHOD-TABLE (EQL-SPECIALIZER))| + |(FAST-METHOD SPECIALIZER-METHOD-TABLE (CLASS-EQ-SPECIALIZER))| + |(FAST-METHOD SPECIALIZER-DIRECT-METHODS (SPECIALIZER-WITH-OBJECT))| + |(FAST-METHOD SPECIALIZER-DIRECT-GENERIC-FUNCTIONS (SPECIALIZER-WITH-OBJECT))| + VARIABLE-DECLARATION + |(FAST-METHOD CLASS-PREDICATE-NAME (T))| + |(FAST-METHOD INITIALIZE-INTERNAL-SLOT-FUNCTIONS (EFFECTIVE-SLOT-DEFINITION))| + |(FAST-METHOD SLOT-DEFINITION-ALLOCATION (STRUCTURE-SLOT-DEFINITION))| + |(FAST-METHOD FINALIZE-INHERITANCE (STRUCTURE-CLASS))| + |(FAST-METHOD FINALIZE-INHERITANCE (STD-CLASS))| + |(FAST-METHOD COMPUTE-DEFAULT-INITARGS (SLOT-CLASS))| + |(FAST-METHOD CLASS-FINALIZED-P (PCL-CLASS))| + |(FAST-METHOD COMPUTE-SLOTS (STD-CLASS))| + |(FAST-METHOD COMPUTE-SLOTS :AROUND (STD-CLASS))| + |(FAST-METHOD COMPUTE-SLOTS (STRUCTURE-CLASS))| + |(FAST-METHOD COMPUTE-SLOTS :AROUND (STRUCTURE-CLASS))| + |(FAST-METHOD CLASS-DIRECT-DEFAULT-INITARGS (SLOT-CLASS))| + |(FAST-METHOD CLASS-DEFAULT-INITARGS (SLOT-CLASS))| + ITERATE::SIMPLE-EXPAND-GATHERING-FORM + ITERATE::RENAME-AND-CAPTURE-VARIABLES + ITERATE::VARIABLE-SAME-P GET-FUNCTION-GENERATOR + GET-NEW-FUNCTION-GENERATOR TRACE-METHOD-INTERNAL + ONE-INDEX-DFUN-INFO ONE-CLASS-DFUN-INFO MAP-ALL-ORDERS + NOTE-PV-TABLE-REFERENCE WALKER::RELIST-INTERNAL + MAKE-DFUN-CALL WALKER::WALK-TAGBODY-1 WALKER::WALK-LAMBDA + OPTIMIZE-GF-CALL-INTERNAL WALKER::WALK-COMPILER-LET + |(FAST-METHOD MAKE-INSTANCES-OBSOLETE (STD-CLASS))| + SKIP-FAST-SLOT-ACCESS-P WALKER::WALK-UNEXPECTED-DECLARE + WALKER::WALK-FLET WALKER::WALK-IF WALKER::WALK-LABELS + WALKER::WALK-LET WALKER::WALK-LET* WALKER::WALK-LOCALLY + |(FAST-METHOD CLASS-DIRECT-SLOTS (BUILT-IN-CLASS))| + WALKER::WALK-MACROLET + |(FAST-METHOD CLASS-SLOTS (BUILT-IN-CLASS))| + |(FAST-METHOD CLASS-DIRECT-DEFAULT-INITARGS (BUILT-IN-CLASS))| + FIX-SLOT-ACCESSORS + |(FAST-METHOD WRAPPER-FETCHER (STANDARD-CLASS))| + WALKER::WALK-MULTIPLE-VALUE-BIND + |(FAST-METHOD CLASS-DEFAULT-INITARGS (BUILT-IN-CLASS))| + WALKER::WALK-SETQ + |(FAST-METHOD SLOTS-FETCHER (STANDARD-CLASS))| + WALKER::WALK-SYMBOL-MACROLET + |(FAST-METHOD RAW-INSTANCE-ALLOCATOR (STANDARD-CLASS))| + EMIT-SLOT-READ-FORM WALKER::WALK-TAGBODY EMIT-BOUNDP-CHECK + WALKER::WALK-DO WALKER::WALK-DO* WALKER::WALK-PROG + WALKER::WALK-NAMED-LAMBDA WALKER::WALK-PROG* + EXPAND-DEFGENERIC EMIT-GREATER-THAN-1-DLAP EMIT-1-T-DLAP + MAKE-METHOD-INITARGS-FORM-INTERNAL ENTRY-IN-CACHE-P + CONVERT-TABLE MAKE-METHOD-SPEC TRACE-EMF-CALL-INTERNAL + FLUSH-CACHE-TRAP SET-FUNCTION-NAME-1 OBSOLETE-INSTANCE-TRAP + COMPUTE-PRECEDENCE PRINT-STD-INSTANCE + |SETF PCL METHOD-FUNCTION-GET| |SETF PCL PLIST-VALUE| + WALKER::WITH-AUGMENTED-ENVIRONMENT-INTERNAL + |(FAST-METHOD ACCESSOR-METHOD-CLASS (STANDARD-ACCESSOR-METHOD))| + |(FAST-METHOD ACCESSOR-METHOD-CLASS (STANDARD-WRITER-METHOD))| + INITIALIZE-INTERNAL-SLOT-GFS* + |(FAST-METHOD METHOD-QUALIFIERS (STANDARD-METHOD))| + SKIP-OPTIMIZE-SLOT-VALUE-BY-CLASS-P + |(FAST-METHOD GENERIC-FUNCTION-LAMBDA-LIST (GENERIC-FUNCTION))| + |(FAST-METHOD GF-FAST-METHOD-FUNCTION-P (STANDARD-GENERIC-FUNCTION))| + COMPUTE-EFFECTIVE-METHOD SORT-APPLICABLE-METHODS + SORT-METHODS)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T) T) + |(FAST-METHOD SLOT-UNBOUND (T T T))| + |(FAST-METHOD FIND-METHOD-COMBINATION (GENERIC-FUNCTION (EQL STANDARD) T))| + |(FAST-METHOD COMPUTE-EFFECTIVE-METHOD (GENERIC-FUNCTION SHORT-METHOD-COMBINATION T))| + LOAD-FUNCTION-GENERATOR EXPAND-EMF-CALL-METHOD MAKE-FGEN + BOOTSTRAP-MAKE-SLOT-DEFINITIONS + BOOTSTRAP-ACCESSOR-DEFINITIONS1 + MAKE-FINAL-ORDINARY-DFUN-INTERNAL + WALKER::WALK-TEMPLATE-HANDLE-REPEAT COMPUTE-PV-SLOT + WALKER::WALK-BINDINGS-1 OPTIMIZE-INSTANCE-ACCESS + OPTIMIZE-ACCESSOR-CALL MAKE-METHOD-INITARGS-FORM-INTERNAL1 + UPDATE-SLOTS-IN-PV MAKE-PARAMETER-REFERENCES MAKE-EMF-CACHE + GET-MAKE-INSTANCE-FUNCTION-INTERNAL + |(FAST-METHOD (SETF SLOT-ACCESSOR-STD-P) (T EFFECTIVE-SLOT-DEFINITION T))| + MAKE-INSTANCE-FUNCTION-COMPLEX + |(FAST-METHOD ENSURE-CLASS-USING-CLASS (T NULL))| + MAKE-INSTANCE-FUNCTION-SIMPLE + |(FAST-METHOD ENSURE-CLASS-USING-CLASS (T PCL-CLASS))| + OPTIMIZE-GENERIC-FUNCTION-CALL + REAL-MAKE-METHOD-INITARGS-FORM + |(FAST-METHOD COMPUTE-SLOT-ACCESSOR-INFO (EFFECTIVE-SLOT-DEFINITION T T))| + |(FAST-METHOD SHARED-INITIALIZE :AFTER (STD-CLASS T))| + |(FAST-METHOD SHARED-INITIALIZE :AFTER (DOCUMENTATION-MIXIN T))| + |(FAST-METHOD (SETF DOCUMENTATION) (T T))| + |(FAST-METHOD SHARED-INITIALIZE :AFTER (STRUCTURE-CLASS T))| + |(FAST-METHOD (SETF DOCUMENTATION) (T DOCUMENTATION-MIXIN))| + |(FAST-METHOD READER-METHOD-CLASS (SLOT-CLASS T))| + |(FAST-METHOD WRITER-METHOD-CLASS (SLOT-CLASS T))| + |(FAST-METHOD SHARED-INITIALIZE :BEFORE (BUILT-IN-CLASS T))| + |(FAST-METHOD SLOT-BOUNDP-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| + |(FAST-METHOD SLOT-MAKUNBOUND-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| + |(FAST-METHOD SHARED-INITIALIZE :AFTER (STRUCTURE-SLOT-DEFINITION T))| + |(FAST-METHOD SLOT-BOUNDP-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| + |(FAST-METHOD SLOT-MAKUNBOUND-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| + |(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-ACCESSOR-METHOD T))| + |(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-METHOD T))| + |(FAST-METHOD REMOVE-NAMED-METHOD (T T))|)) +(PROCLAIM + '(FTYPE (FUNCTION (T T *) T) MAKE-EFFECTIVE-METHOD-FUNCTION-SIMPLE + MAKE-EMF-FROM-METHOD EXPAND-EFFECTIVE-METHOD-FUNCTION + NAMED-OBJECT-PRINT-FUNCTION FIND-CLASS-FROM-CELL + FIND-CLASS-PREDICATE-FROM-CELL INITIALIZE-INFO + GET-EFFECTIVE-METHOD-FUNCTION1 GET-DECLARATION + GET-METHOD-FUNCTION-PV-CELL EMIT-MISS METHOD-FUNCTION-GET + PROBE-CACHE MAP-CACHE PRECOMPUTE-EFFECTIVE-METHODS + RECORD-DEFINITION WALKER::CONVERT-MACRO-TO-LAMBDA CPL-ERROR + REAL-ADD-METHOD + REAL-ENSURE-GF-USING-CLASS--GENERIC-FUNCTION + REAL-ENSURE-GF-USING-CLASS--NULL + COMPUTE-SECONDARY-DISPATCH-FUNCTION1 + ENSURE-GENERIC-FUNCTION-USING-CLASS)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T T) T) REAL-LOAD-DEFCLASS + WALKER::WALK-TEMPLATE-HANDLE-REPEAT-1 + BOOTSTRAP-MAKE-SLOT-DEFINITION EMIT-SLOT-ACCESS + OPTIMIZE-GF-CALL SET-ARG-INFO1 LOAD-DEFCLASS + MAKE-EARLY-CLASS-DEFINITION + |(FAST-METHOD (SETF SLOT-VALUE-USING-CLASS) (T STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))|)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T T T) T) + |(FAST-METHOD SLOT-MISSING (T T T T))| EXPAND-DEFMETHOD + LOAD-DEFMETHOD-INTERNAL)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T FIXNUM) T) GET-CACHE + FILL-CACHE-FROM-CACHE-P)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T *) T) EMIT-DLAP + GET-SECONDARY-DISPATCH-FUNCTION1)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T *) T) CHECK-INITARGS-2-PLIST + CHECK-INITARGS-2-LIST WALKER::WALK-ARGLIST MAKE-EMF-CALL + CAN-OPTIMIZE-ACCESS1 EMIT-FETCH-WRAPPER FILL-CACHE + REAL-GET-METHOD CHECK-INITARGS-1 GET-METHOD)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T T *) T) LOAD-DEFMETHOD + MAKE-DEFMETHOD-FORM MAKE-DEFMETHOD-FORM-INTERNAL + EARLY-MAKE-A-METHOD)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T *) T) FILL-DFUN-CACHE + EARLY-ADD-NAMED-METHOD REAL-ADD-NAMED-METHOD)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T T T T) T) + GET-SECONDARY-DISPATCH-FUNCTION2)) +(PROCLAIM '(FTYPE (FUNCTION (T T FIXNUM) T) COMPUTE-STD-CPL-PHASE-3)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T T T T T *) T) + BOOTSTRAP-INITIALIZE-CLASS)) +(PROCLAIM + '(FTYPE (FUNCTION NIL *) COUNT-ALL-DFUNS EMIT-N-N-READERS + EMIT-N-N-WRITERS)) +(PROCLAIM + '(FTYPE (FUNCTION (*) *) UNTRACE-METHOD LIST-LARGE-CACHES + UPDATE-MAKE-INSTANCE-FUNCTION-TABLE INVALID-METHOD-ERROR + METHOD-COMBINATION-ERROR)) +(PROCLAIM + '(FTYPE (FUNCTION NIL T) RENEW-SYS-FILES + GET-EFFECTIVE-METHOD-GENSYM SHOW-EMF-CALL-TRACE + BOOTSTRAP-META-BRAID BOOTSTRAP-BUILT-IN-CLASSES + LIST-ALL-DFUNS DEFAULT-METHOD-ONLY-DFUN-INFO + INITIALIZE-CHECKING-OR-CACHING-FUNCTION-LIST + CACHES-TO-ALLOCATE UPDATE-DISPATCH-DFUNS MAKE-CACHE + IN-THE-COMPILER-P STRUCTURE-FUNCTIONS-EXIST-P + ALLOCATE-FUNCALLABLE-INSTANCE-2 %%ALLOCATE-INSTANCE--CLASS + ALLOCATE-FUNCALLABLE-INSTANCE-1 DISPATCH-DFUN-INFO + INITIAL-DISPATCH-DFUN-INFO INITIAL-DFUN-INFO + NO-METHODS-DFUN-INFO SHOW-FREE-CACHE-VECTORS MAKE-CPD + MAKE-ARG-INFO SHOW-DFUN-CONSTRUCTORS)) +(PROCLAIM '(FTYPE (FUNCTION (FIXNUM T T) *) COMPUTE-CACHE-PARAMETERS)) +(PROCLAIM '(FTYPE (FUNCTION (FIXNUM T *) *) FIND-FREE-CACHE-LINE)) +(PROCLAIM + '(FTYPE (FUNCTION (*) T) |__si::MAKE-DFUN-INFO| + |__si::MAKE-NO-METHODS| |__si::MAKE-INITIAL| + |__si::MAKE-INITIAL-DISPATCH| |__si::MAKE-DISPATCH| + |__si::MAKE-DEFAULT-METHOD-ONLY| + |__si::MAKE-ACCESSOR-DFUN-INFO| + |__si::MAKE-ONE-INDEX-DFUN-INFO| MAKE-FAST-METHOD-CALL + |__si::MAKE-N-N| MAKE-FAST-INSTANCE-BOUNDP + |__si::MAKE-ONE-CLASS| |__si::MAKE-TWO-CLASS| + |__si::MAKE-ONE-INDEX| |__si::MAKE-CHECKING| + |__si::MAKE-ARG-INFO| FIX-EARLY-GENERIC-FUNCTIONS + STRING-APPEND |__si::MAKE-CACHING| + |__si::MAKE-CONSTANT-VALUE| FALSE + |STRUCTURE-OBJECT class constructor| + PV-WRAPPERS-FROM-PV-ARGS MAKE-PV-TABLE + |__si::MAKE-PV-TABLE| INTERN-PV-TABLE + CALLED-FIN-WITHOUT-FUNCTION |__si::MAKE-STD-INSTANCE| + MAKE-INITIALIZE-INFO |__si::MAKE-CACHE| MAKE-PROGN + WALKER::UNBOUND-LEXICAL-FUNCTION + |__si::MAKE-CLASS-PRECEDENCE-DESCRIPTION| MAKE-METHOD-CALL + TRUE USE-PACKAGE-PCL ZERO)) +(PROCLAIM + '(FTYPE (FUNCTION (T) *) TYPE-FROM-SPECIALIZER *NORMALIZE-TYPE + DEFAULT-CODE-CONVERTER CONVERT-TO-SYSTEM-TYPE + EMIT-CONSTANT-VALUE PCL-DESCRIBE GET-GENERIC-FUNCTION-INFO + EARLY-METHOD-FUNCTION + EARLY-METHOD-STANDARD-ACCESSOR-SLOT-NAME + SPECIALIZER-FROM-TYPE CLASS-EQ-TYPE STRUCTURE-WRAPPER + FIND-STRUCTURE-CLASS MAKE-DISPATCH-DFUN FIND-WRAPPER + PARSE-DEFMETHOD PROTOTYPES-FOR-MAKE-METHOD-LAMBDA + EMIT-ONE-CLASS-READER EMIT-ONE-CLASS-WRITER + EMIT-TWO-CLASS-READER EMIT-TWO-CLASS-WRITER + EMIT-ONE-INDEX-READERS EMIT-ONE-INDEX-WRITERS + NET-CODE-CONVERTER EMIT-IN-CHECKING-CACHE-P + COMPILE-IIS-FUNCTIONS ANALYZE-LAMBDA-LIST + COMPUTE-APPLICABLE-METHODS-EMF GET-DISPATCH-FUNCTION + GENERIC-FUNCTION-NAME-P MAKE-FINAL-DISPATCH-DFUN + STRUCTURE-SLOTD-INIT-FORM PARSE-METHOD-GROUP-SPECIFIER + METHOD-PROTOTYPE-FOR-GF EARLY-COLLECT-INHERITANCE)) +(PROCLAIM + '(FTYPE (FUNCTION (T FIXNUM *) T) GET-CACHE-FROM-CACHE + COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION)) +(PROCLAIM + '(FTYPE (FUNCTION (T) T) COMPILE-LAMBDA-UNCOMPILED GF-LAMBDA-LIST + CACHING-CACHE CONSTANT-VALUE-CACHE COMPILE-LAMBDA-DEFERRED + FUNCALLABLE-INSTANCE-P SHOW-DFUN-COSTS + RESET-CLASS-INITIALIZE-INFO GET-CACHE-VECTOR + CONSTANT-SYMBOL-P FREE-CACHE-VECTOR + EARLY-METHOD-LAMBDA-LIST ARG-INFO-VALID-P DFUN-ARG-SYMBOL + EARLY-METHOD-CLASS EARLY-GF-P EARLY-GF-NAME + CACHING-DFUN-INFO COMPUTE-APPLICABLE-METHODS-EMF-STD-P + CONSTANT-VALUE-DFUN-INFO RESET-CLASS-INITIALIZE-INFO-1 + FREE-CACHE PARSE-SPECIALIZERS RESET-INITIALIZE-INFO + EARLY-METHOD-QUALIFIERS PROCLAIM-INCOMPATIBLE-SUPERCLASSES + WRAPPER-OF EARLY-METHOD-STANDARD-ACCESSOR-P + FUNCTION-PRETTY-ARGLIST GET-MAKE-INSTANCE-FUNCTION + CHECK-WRAPPER-VALIDITY UNPARSE-SPECIALIZERS + %SYMBOL-FUNCTION FINAL-ACCESSOR-DFUN-TYPE + COMPLICATED-INSTANCE-CREATION-METHOD DEFAULT-STRUCTUREP + UPDATE-GF-INFO CACHE-OWNER DEFAULT-STRUCTURE-INSTANCE-P + DEFAULT-STRUCTURE-TYPE STRUCTURE-TYPE + COMPUTE-STD-CPL-PHASE-2 GET-PV-CELL-FOR-CLASS + STRUCTURE-TYPE-INCLUDED-TYPE-NAME + STRUCTURE-TYPE-SLOT-DESCRIPTION-LIST CACHE-P + STRUCTURE-SLOTD-NAME STRUCTURE-SLOTD-ACCESSOR-SYMBOL SFUN-P + DEFAULT-SECONDARY-DISPATCH-FUNCTION + STRUCTURE-SLOTD-WRITER-FUNCTION FIND-CYCLE-REASONS + EARLY-CLASS-DEFINITION ECD-SOURCE STRUCTURE-SLOTD-TYPE + FORMAT-CYCLE-REASONS ECD-METACLASS CPD-CLASS + EARLY-CLASS-PRECEDENCE-LIST + METHODS-CONTAIN-EQL-SPECIALIZER-P MAKE-TYPE-PREDICATE + CPD-SUPERS DEFAULT-TEST-CONVERTER EXPAND-LONG-DEFCOMBIN + INITIAL-P EARLY-CLASS-NAME-OF FORCE-CACHE-FLUSHES CPD-AFTER + EXPAND-SHORT-DEFCOMBIN MAKE-CALL-METHODS + DEFAULT-CONSTANT-CONVERTER EARLY-CLASS-SLOTDS + INITIAL-DISPATCH-P DISPATCH-P EARLY-SLOT-DEFINITION-NAME + SLOT-READER-SYMBOL GBOUNDP GMAKUNBOUND + EARLY-SLOT-DEFINITION-LOCATION WALKER::ENV-LOCK + DEFAULT-CONSTANTP MAKE-INITIAL-DFUN DEFAULT-METHOD-ONLY-P + FGEN-TEST EARLY-ACCESSOR-METHOD-SLOT-NAME + SLOT-WRITER-SYMBOL LOOKUP-FGEN WALKER::ENV-DECLARATIONS + ACCESSOR-DFUN-INFO-P WALKER::ENV-LEXICAL-VARIABLES + FGEN-GENERATOR FGEN-SYSTEM LIST-DFUN %FBOUNDP + SLOT-BOUNDP-SYMBOL ONE-INDEX-DFUN-INFO-P CCLOSUREP + MAP-ALL-GENERIC-FUNCTIONS FAST-METHOD-CALL-P + MAKE-STRUCTURE-SLOT-BOUNDP-FUNCTION N-N-P + EARLY-CLASS-DIRECT-SUBCLASSES FAST-INSTANCE-BOUNDP-P + MAKE-FUNCTION-INLINE METHOD-FUNCTION-PV-TABLE + LIST-LARGE-CACHE METHOD-FUNCTION-METHOD STORE-FGEN + CLASS-PRECEDENCE-DESCRIPTION-P ONE-CLASS-P + INFORM-TYPE-SYSTEM-ABOUT-STD-CLASS + UNENCAPSULATED-FDEFINITION + MAKE-DEFAULT-METHOD-GROUP-DESCRIPTION + METHOD-FUNCTION-NEEDS-NEXT-METHODS-P DFUN-INFO-P + MAKE-OPTIMIZED-STRUCTURE-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION + FTYPE-DECLARATION-FROM-LAMBDA-LIST NO-METHODS-P + WALKER::ENV-WALK-FUNCTION FGEN-GENSYMS + WALKER::GET-IMPLEMENTATION-DEPENDENT-WALKER-TEMPLATE + TWO-CLASS-P COUNT-DFUN ARG-INFO-LAMBDA-LIST + MAKE-INITFUNCTION ARG-INFO-PRECEDENCE + MAKE-OPTIMIZED-STRUCTURE-SETF-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION + ARG-INFO-METATYPES ITERATE::VARIABLES-FROM-LET + FGEN-GENERATOR-LAMBDA WALKER::ENV-WALK-FORM + ARG-INFO-NUMBER-OPTIONAL + MAKE-OPTIMIZED-STRUCTURE-SLOT-BOUNDP-USING-CLASS-METHOD-FUNCTION + ARG-INFO-KEY/REST-P INITIALIZE-INFO-P ONE-INDEX-P + ECD-CLASS-NAME ARG-INFO-KEYWORDS COPY-CACHE + GF-INFO-SIMPLE-ACCESSOR-TYPE COMPUTE-LINE-SIZE + GF-PRECOMPUTE-DFUN-AND-EMF-P CANONICAL-SLOT-NAME + GF-INFO-STATIC-C-A-M-EMF WALKER::GET-WALKER-TEMPLATE + CHECKING-P EARLY-CLASS-SLOTS GF-INFO-C-A-M-EMF-STD-P + STRUCTURE-TYPE-INTERNAL-SLOTDS GF-INFO-FAST-MF-P + UNDEFMETHOD-1 EARLY-COLLECT-CPL EARLY-COLLECT-SLOTS + ARG-INFO-P METHOD-LL->GENERIC-FUNCTION-LL + FAST-METHOD-CALL-ARG-INFO EARLY-COLLECT-DEFAULT-INITARGS + ARG-INFO-NKEYS ECD-SUPERCLASS-NAMES GF-DFUN-CACHE + GF-DFUN-INFO METHOD-CALL-P STRUCTURE-SLOT-BOUNDP + FUNCTION-RETURNING-NIL ITERATE::SEQUENCE-ACCESSOR + ACCESSOR-DFUN-INFO-ACCESSOR-TYPE ECD-CANONICAL-SLOTS + EVAL-FORM ONE-INDEX-DFUN-INFO-INDEX ECD-OTHER-INITARGS + SLOT-INITARGS-FROM-STRUCTURE-SLOTD TYPE-CLASS + ONE-CLASS-WRAPPER0 EXTRACT-PARAMETERS CLASS-PREDICATE + EXTRACT-REQUIRED-PARAMETERS MAKE-CLASS-EQ-PREDICATE + TWO-CLASS-WRAPPER1 MAKE-EQL-PREDICATE CHECKING-FUNCTION + BOOTSTRAP-ACCESSOR-DEFINITIONS INITIALIZE-INFO-KEY + BOOTSTRAP-CLASS-PREDICATES GET-BUILT-IN-CLASS-SYMBOL + INITIALIZE-INFO-WRAPPER GET-BUILT-IN-WRAPPER-SYMBOL + DO-STANDARD-DEFSETF-1 CACHING-P GFS-OF-TYPE + LEGAL-CLASS-NAME-P STRUCTURE-TYPE-P CONSTANT-VALUE-P + USE-DEFAULT-METHOD-ONLY-DFUN-P + INITIALIZE-INFO-CACHED-COMBINED-INITARGS-FORM-LIST + WRAPPER-FIELD NEXT-WRAPPER-FIELD SETFBOUNDP + GET-SETF-FUNCTION-NAME USE-CACHING-DFUN-P + MAKE-PV-TYPE-DECLARATION MAKE-CALLS-TYPE-DECLARATION + MAP-SPECIALIZERS SLOT-VECTOR-SYMBOL MAKE-PERMUTATION-VECTOR + VARIABLE-GLOBALLY-SPECIAL-P STRUCTURE-OBJECT-P + EXPAND-MAKE-INSTANCE-FORM MAKE-CONSTANT-FUNCTION + FUNCTION-RETURNING-T SORT-SLOTS SORT-CALLS SYMBOL-PKG-NAME + CLASS-HAS-A-FORWARD-REFERENCED-SUPERCLASS-P + INITIALIZE-INFO-BOUND-SLOTS INITIALIZE-INFO-CACHED-VALID-P + GET-MAKE-INSTANCE-FUNCTIONS + INITIALIZE-INFO-CACHED-RI-VALID-P + INITIALIZE-INFO-CACHED-INITARGS-FORM-LIST + INITIALIZE-INFO-CACHED-NEW-KEYS UPDATE-C-A-M-GF-INFO + INITIALIZE-INFO-CACHED-DEFAULT-INITARGS-FUNCTION + UPDATE-GF-SIMPLE-ACCESSOR-TYPE UPDATE-GFS-OF-CLASS + INITIALIZE-INFO-CACHED-SHARED-INITIALIZE-T-FUNCTION + DO-STANDARD-DEFSETFS-FOR-DEFCLASS STANDARD-SVUC-METHOD + INITIALIZE-INFO-CACHED-SHARED-INITIALIZE-NIL-FUNCTION + %CCLOSURE-ENV STRUCTURE-SVUC-METHOD + INITIALIZE-INFO-CACHED-CONSTANTS CLASS-OF + METHOD-FUNCTION-PLIST + INITIALIZE-INFO-CACHED-COMBINED-INITIALIZE-FUNCTION + INITIALIZE-INFO-CACHED-MAKE-INSTANCE-FUNCTION + INITIALIZE-INFO-CACHED-MAKE-INSTANCE-FUNCTION-SYMBOL + INTERNED-SYMBOL-P GDEFINITION UPDATE-CLASS-CAN-PRECEDE-P + %STD-INSTANCE-WRAPPER %STD-INSTANCE-SLOTS PV-TABLEP + STD-INSTANCE-P COMPUTE-MCASE-PARAMETERS COMPUTE-CLASS-SLOTS + MAKE-PV-TABLE-TYPE-DECLARATION INTERN-EQL-SPECIALIZER + NET-TEST-CONVERTER MAKE-INSTANCE-FUNCTION-SYMBOL + UPDATE-ALL-C-A-M-GF-INFO UPDATE-PV-TABLE-CACHE-INFO + DFUN-INFO-CACHE EXTRACT-LAMBDA-LIST NO-METHODS-CACHE + ARG-INFO-APPLYP CACHING-DFUN-COST INITIAL-CACHE + SYSTEM:%STRUCTURE-NAME INITIAL-DISPATCH-CACHE + SYSTEM:%COMPILED-FUNCTION-NAME CHECK-CACHE DISPATCH-CACHE + CLASS-FROM-TYPE DEFAULT-METHOD-ONLY-CACHE DNET-METHODS-P + ACCESSOR-DFUN-INFO-CACHE METHOD-FUNCTION-FROM-FAST-FUNCTION + ONE-INDEX-DFUN-INFO-CACHE ONE-INDEX-DFUN-INFO-ACCESSOR-TYPE + METHOD-CALL-CALL-METHOD-ARGS KEYWORD-SPEC-NAME N-N-CACHE + GENERIC-CLOBBERS-FUNCTION N-N-ACCESSOR-TYPE + FAST-METHOD-CALL-PV-CELL WRAPPER-FOR-STRUCTURE + ONE-CLASS-CACHE EXTRACT-SPECIALIZER-NAMES + FAST-METHOD-CALL-NEXT-METHOD-CALL ONE-CLASS-ACCESSOR-TYPE + ONE-CLASS-INDEX BUILT-IN-WRAPPER-OF TWO-CLASS-CACHE + BUILT-IN-OR-STRUCTURE-WRAPPER1 TWO-CLASS-ACCESSOR-TYPE + TWO-CLASS-INDEX GET-MAKE-INSTANCE-FUNCTION-SYMBOL + ALLOCATE-CACHE-VECTOR TWO-CLASS-WRAPPER0 + FLUSH-CACHE-VECTOR-INTERNAL ONE-INDEX-CACHE + EARLY-CLASS-NAME ONE-INDEX-ACCESSOR-TYPE ONE-INDEX-INDEX + INTERN-FUNCTION-NAME CHECKING-CACHE)) +(PROCLAIM + '(FTYPE (FUNCTION (T *) *) COERCE-TO-CLASS GET-METHOD-FUNCTION + GET-FUNCTION GET-FUNCTION1 PARSE-METHOD-OR-SPEC + EXTRACT-DECLARATIONS GET-DFUN-CONSTRUCTOR MAP-ALL-CLASSES + MAKE-CACHING-DFUN MAKE-METHOD-FUNCTION-INTERNAL + PARSE-SPECIALIZED-LAMBDA-LIST MAKE-METHOD-LAMBDA-INTERNAL + MAKE-CONSTANT-VALUE-DFUN MAKE-FINAL-DFUN-INTERNAL + COMPILE-LAMBDA WALK-FORM MACROEXPAND-ALL ENSURE-CLASS + ENSURE-GENERIC-FUNCTION DISPATCH-DFUN-COST)) +(PROCLAIM '(FTYPE (FUNCTION (T T *) (VALUES T T)) SYMBOL-APPEND)) +(PROCLAIM + '(FTYPE (FUNCTION (T *) T) CAPITALIZE-WORDS + INITIALIZE-INTERNAL-SLOT-GFS FIND-CLASS + MAKE-TYPE-PREDICATE-NAME SET-DFUN TRACE-METHOD + FIND-CLASS-CELL MAKE-FINAL-DFUN PV-TABLE-LOOKUP-PV-ARGS + USE-DISPATCH-DFUN-P WALKER::RELIST* WALKER::RELIST + FIND-CLASS-PREDICATE EARLY-METHOD-SPECIALIZERS + USE-CONSTANT-VALUE-DFUN-P MAKE-EARLY-GF + ALLOCATE-FUNCALLABLE-INSTANCE SET-ARG-INFO + INITIALIZE-METHOD-FUNCTION UPDATE-DFUN MAKE-SPECIALIZABLE + ALLOCATE-STRUCTURE-INSTANCE ALLOCATE-STANDARD-INSTANCE + WALKER::WALKER-ENVIRONMENT-BIND-1 + ITERATE::FUNCTION-LAMBDA-P ITERATE::MAYBE-WARN + MAKE-WRAPPER)) +(PROCLAIM + '(FTYPE (FUNCTION (T T) *) SLOT-BOUNDP SLOT-VALUE SAUT-CLASS + SPECIALIZER-APPLICABLE-USING-TYPE-P COMPUTE-TEST + GET-NEW-FUNCTION-GENERATOR-INTERNAL COMPUTE-CODE + CLASS-APPLICABLE-USING-CLASS-P SAUT-AND SAUT-NOT + SAUT-PROTOTYPE DESTRUCTURE ENSURE-CLASS-VALUES + MAKE-DIRECT-SLOTD SLOT-MAKUNBOUND + MAKE-INSTANCE-FUNCTION-TRAP + GENERATE-FAST-CLASS-SLOT-ACCESS-P MUTATE-SLOTS-AND-CALLS + INVOKE-EMF EMIT-DEFAULT-ONLY-FUNCTION SPLIT-DECLARATIONS + EMIT-DEFAULT-ONLY SLOT-NAME-LISTS-FROM-SLOTS EMIT-CHECKING + UPDATE-SLOT-VALUE-GF-INFO EMIT-CACHING SDFUN-FOR-CACHING + SLOT-UNBOUND-INTERNAL MAKE-INSTANCE-1 SET-FUNCTION-NAME + COMPUTE-STD-CPL-PHASE-1 FORM-LIST-TO-LISP + FIND-SUPERCLASS-CHAIN SAUT-CLASS-EQ + COMPUTE-APPLICABLE-METHODS-USING-TYPES + CHECK-INITARGS-VALUES SAUT-EQL INSURE-DFUN *SUBTYPEP + ITERATE::PARSE-DECLARATIONS INITIAL-DFUN)) +(PROCLAIM + '(FTYPE (FUNCTION (T T) T) ADD-METHOD DO-SATISFIES-DEFTYPE + MEMF-CONSTANT-CONVERTER COMPUTE-CONSTANTS + CLASS-CAN-PRECEDE-P SAUT-NOT-CLASS SAUT-NOT-CLASS-EQ + SAUT-NOT-PROTOTYPE GF-MAKE-FUNCTION-FROM-EMF SAUT-NOT-EQL + SUPERCLASSES-COMPATIBLE-P CLASSES-HAVE-COMMON-SUBCLASS-P + DESCRIBE-PACKAGE PRINTING-RANDOM-THING-INTERNAL + MAKE-CLASS-PREDICATE METHOD-FUNCTION-RETURNING-NIL + METHOD-FUNCTION-RETURNING-T VARIABLE-CLASS MAKE-PLIST + REMTAIL DESTRUCTURE-INTERNAL ACCESSOR-MISS-FUNCTION + UPDATE-INITIALIZE-INFO-INTERNAL N-N-DFUN-INFO MAKE-CAXR + MAKE-CDXR CHECKING-DFUN-INFO + FUNCALLABLE-STANDARD-INSTANCE-ACCESS MAKE-PV-TABLE-INTERNAL + FIND-SLOT-DEFINITION WALKER::WALK-REPEAT-EVAL + WALKER::NOTE-DECLARATION MAKE-DFUN-LAMBDA-LIST + WALKER::NOTE-LEXICAL-BINDING MAKE-DLAP-LAMBDA-LIST + ADD-DIRECT-SUBCLASSES COMPUTE-PV MAKE-DFUN-ARG-LIST + COMPUTE-CALLS MAKE-FAST-METHOD-CALL-LAMBDA-LIST + UPDATE-ALL-PV-TABLE-CACHES UPDATE-CLASS + MAP-PV-TABLE-REFERENCES-OF ADD-SLOT-ACCESSORS + WALKER::ENVIRONMENT-FUNCTION REMOVE-DIRECT-SUBCLASSES + REMOVE-SLOT-ACCESSORS SYMBOL-LESSP SYMBOL-OR-CONS-LESSP + |SETF PCL FIND-CLASS| |SETF PCL FIND-CLASS-PREDICATE| + PV-WRAPPERS-FROM-ALL-ARGS PV-TABLE-LOOKUP + PROCLAIM-DEFGENERIC UPDATE-CPL LIST-EQ UPDATE-SLOTS + COMPUTE-APPLICABLE-METHODS-FUNCTION VARIABLE-LEXICAL-P + VARIABLE-SPECIAL-P UPDATE-INITS UPDATE-STD-OR-STR-METHODS + SET-STANDARD-SVUC-METHOD EMIT-1-NIL-DLAP PLIST-VALUE + SET-STRUCTURE-SVUC-METHOD + EMIT-1-WRAPPER-COMPUTE-PRIMARY-CACHE-LOCATION + MEC-ALL-CLASSES-INTERNAL + EMIT-N-WRAPPER-COMPUTE-PRIMARY-CACHE-LOCATION + MEC-ALL-CLASSES %SET-CCLOSURE-ENV MEC-ALL-CLASS-LISTS + REDEFINE-FUNCTION METHODS-CONVERTER COMPUTE-LAYOUT NO-SLOT + PV-WRAPPERS-FROM-ALL-WRAPPERS NET-CONSTANT-CONVERTER + AUGMENT-TYPE CHANGE-CLASS-INTERNAL VALUE-FOR-CACHING + |SETF PCL METHOD-FUNCTION-PLIST| GET-KEY-ARG GET-KEY-ARG1 + SET-METHODS SET-FUNCTION-PRETTY-ARGLIST + FIND-STANDARD-II-METHOD MAKE-EARLY-ACCESSOR + DOCTOR-DFUN-FOR-THE-DEBUGGER COMPUTE-STD-CPL + |SETF PCL GDEFINITION| MAKE-DISCRIMINATING-FUNCTION-ARGLIST + ADD-FORMS CPL-INCONSISTENT-ERROR + REDIRECT-EARLY-FUNCTION-INTERNAL ADD-TO-CVECTOR + BOOTSTRAP-SLOT-INDEX QUALIFIER-CHECK-RUNTIME + CPL-FORWARD-REFERENCED-CLASS-ERROR REAL-REMOVE-METHOD + WALKER::ENVIRONMENT-MACRO CANONICALIZE-SLOT-SPECIFICATION + CANONICALIZE-DEFCLASS-OPTION SET-WRAPPER + DEAL-WITH-ARGUMENTS-OPTION PARSE-QUALIFIER-PATTERN + SWAP-WRAPPERS-AND-SLOTS ITERATE::MV-SETQ + MAKE-UNORDERED-METHODS-EMF CLASS-MIGHT-PRECEDE-P + ITERATE::EXTRACT-SPECIAL-BINDINGS + WALKER::VARIABLE-SYMBOL-MACRO-P RAISE-METATYPE + SLOT-EXISTS-P PROCLAIM-DEFMETHOD STANDARD-INSTANCE-ACCESS + REMOVE-METHOD + SET-FUNCALLABLE-INSTANCE-FUNCTION + SYSTEM:%SET-COMPILED-FUNCTION-NAME FDEFINE-CAREFULLY + MAKE-INTERNAL-READER-METHOD-FUNCTION + MAKE-STD-READER-METHOD-FUNCTION + MAKE-STD-WRITER-METHOD-FUNCTION + ITERATE::SIMPLE-EXPAND-ITERATE-FORM + MAKE-STD-BOUNDP-METHOD-FUNCTION)) +(PROCLAIM '(FTYPE (FUNCTION NIL FIXNUM) GET-WRAPPER-CACHE-NUMBER)) +(IN-PACKAGE "PCL") + +(DOLIST (V '(|(FAST-WRITER-METHOD SLOT-OBJECT DIRECT-METHODS)| + |(FAST-WRITER-METHOD SLOT-OBJECT SLOTS)| + |(FAST-WRITER-METHOD SLOT-CLASS SLOTS)| + |(FAST-WRITER-METHOD SLOT-OBJECT DIRECT-SLOTS)| + |(FAST-WRITER-METHOD SLOT-CLASS DIRECT-SLOTS)| + |(FAST-WRITER-METHOD SLOT-OBJECT FROM-DEFCLASS-P)| + |(FAST-WRITER-METHOD SLOT-OBJECT METHODS)| + |(FAST-WRITER-METHOD STANDARD-GENERIC-FUNCTION METHODS)| + |(FAST-WRITER-METHOD SLOT-OBJECT OPTIONS)| + |(FAST-WRITER-METHOD SLOT-OBJECT DIRECT-SUBCLASSES)| + |(FAST-WRITER-METHOD SLOT-OBJECT DIRECT-SUPERCLASSES)| + ADD-READER-METHOD + SHORT-COMBINATION-IDENTITY-WITH-ONE-ARGUMENT + REMOVE-READER-METHOD |LISP::T class predicate| + EQL-SPECIALIZER-P |(SETF GENERIC-FUNCTION-NAME)| + OBJECT-PLIST SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL + |PCL::STANDARD-OBJECT class predicate| + |PCL::STANDARD-SLOT-DEFINITION class predicate| + |PCL::STANDARD-DIRECT-SLOT-DEFINITION class predicate| + |PCL::STANDARD-EFFECTIVE-SLOT-DEFINITION class predicate| + |PCL::STANDARD-METHOD-COMBINATION class predicate| + |(FAST-READER-METHOD SLOT-OBJECT METHOD)| + |PCL::BUILT-IN-CLASS class predicate| SPECIALIZER-TYPE + |LISP::RATIO class predicate| + |LISP::RATIONAL class predicate| GF-DFUN-STATE + |(SETF GENERIC-FUNCTION-METHOD-CLASS)| + |(FAST-READER-METHOD SLOT-OBJECT DEFSTRUCT-ACCESSOR-SYMBOL)| + |(FAST-READER-METHOD STRUCTURE-SLOT-DEFINITION DEFSTRUCT-ACCESSOR-SYMBOL)| + |(SETF GENERIC-FUNCTION-METHOD-COMBINATION)| + CLASS-DEFSTRUCT-CONSTRUCTOR + |(FAST-READER-METHOD SLOT-OBJECT SOURCE)| + |(FAST-READER-METHOD DEFINITION-SOURCE-MIXIN SOURCE)| + METHOD-FAST-FUNCTION |(SETF GENERIC-FUNCTION-METHODS)| + |(SETF GF-PRETTY-ARGLIST)| + |(FAST-READER-METHOD SLOT-OBJECT INITIALIZE-INFO)| + |(FAST-READER-METHOD SLOT-CLASS INITIALIZE-INFO)| + |(FAST-READER-METHOD SLOT-OBJECT ARG-INFO)| + |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION ARG-INFO)| + SPECIALIZERP EXACT-CLASS-SPECIALIZER-P + |(FAST-READER-METHOD SLOT-OBJECT WRAPPER)| + |(FAST-READER-METHOD PCL-CLASS WRAPPER)| + |(FAST-READER-METHOD SLOT-OBJECT INITARGS)| + |(FAST-READER-METHOD SLOT-DEFINITION INITARGS)| + |(FAST-READER-METHOD SHORT-METHOD-COMBINATION OPERATOR)| + |(FAST-READER-METHOD SLOT-OBJECT OPERATOR)| + |(FAST-READER-METHOD SLOT-OBJECT DEFSTRUCT-CONSTRUCTOR)| + |(FAST-READER-METHOD STRUCTURE-CLASS DEFSTRUCT-CONSTRUCTOR)| + |LISP::CHARACTER class predicate| + COMPATIBLE-META-CLASS-CHANGE-P + |LISP::SEQUENCE class predicate| + |(FAST-READER-METHOD SLOT-OBJECT CLASS-EQ-SPECIALIZER)| + |(FAST-READER-METHOD CLASS CLASS-EQ-SPECIALIZER)| + |(BOUNDP READER-FUNCTION)| |(BOUNDP PREDICATE-NAME)| + |(BOUNDP READERS)| UPDATE-GF-DFUN + |(BOUNDP CLASS-PRECEDENCE-LIST)| + |(BOUNDP ACCESSOR-FLAGS)| |(BOUNDP LOCATION)| + |(BOUNDP DOCUMENTATION)| SPECIALIZER-OBJECT + |(BOUNDP INCOMPATIBLE-SUPERCLASS-LIST)| + ACCESSOR-METHOD-SLOT-NAME |(BOUNDP SPECIALIZERS)| + |(BOUNDP IDENTITY-WITH-ONE-ARGUMENT)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT DEFSTRUCT-ACCESSOR-SYMBOL)| + SPECIALIZER-CLASS |(BOUNDP PRETTY-ARGLIST)| + |PCL::PCL-CLASS class predicate| + |PCL::STD-CLASS class predicate| + |(BOUNDP DEFSTRUCT-FORM)| + |(SETF SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL)| + CLASS-EQ-SPECIALIZER-P + |(FAST-BOUNDP-METHOD SLOT-OBJECT SOURCE)| SLOTS-FETCHER + |(SETF SLOT-ACCESSOR-STD-P)| REMOVE-WRITER-METHOD + |(BOUNDP WRITER-FUNCTION)| |(BOUNDP INITFUNCTION)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT INITIALIZE-INFO)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT ARG-INFO)| + STRUCTURE-CLASS-P |(BOUNDP WRITERS)| + |(BOUNDP INITFORM)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT WRAPPER)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT INITARGS)| + |LISP::BIT-VECTOR class predicate| + |(FAST-BOUNDP-METHOD SLOT-OBJECT DEFSTRUCT-CONSTRUCTOR)| + UPDATE-CONSTRUCTORS |(BOUNDP SLOT-NAME)| + |(SETF SLOT-DEFINITION-INITARGS)| |(BOUNDP ALLOCATION)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT CLASS-EQ-SPECIALIZER)| + DOCUMENTATION |(BOUNDP FUNCTION)| + |(BOUNDP GENERIC-FUNCTION)| |(BOUNDP LAMBDA-LIST)| + METHOD-PRETTY-ARGLIST |(BOUNDP SLOT-DEFINITION)| + |LISP::ARRAY class predicate| + |(BOUNDP CAN-PRECEDE-LIST)| |(BOUNDP PROTOTYPE)| + CLASS-EQ-SPECIALIZER INFORM-TYPE-SYSTEM-ABOUT-CLASS + |PCL::DEFINITION-SOURCE-MIXIN class predicate| + |(BOUNDP DFUN-STATE)| |(BOUNDP FROM-DEFCLASS-P)| + |(READER METHOD)| + |(CALL STANDARD-COMPUTE-EFFECTIVE-METHOD)| + |(BOUNDP FAST-FUNCTION)| + |LISP::COMPLEX class predicate| |(BOUNDP METHOD-CLASS)| + |(READER SOURCE)| |(BOUNDP INTERNAL-WRITER-FUNCTION)| + |(BOUNDP INTERNAL-READER-FUNCTION)| + |(BOUNDP METHOD-COMBINATION)| ACCESSOR-METHOD-CLASS + |(BOUNDP DIRECT-SLOTS)| |(BOUNDP DIRECT-METHODS)| + |(BOUNDP BOUNDP-FUNCTION)| |(BOUNDP DIRECT-SUBCLASSES)| + |(BOUNDP DIRECT-SUPERCLASSES)| |(BOUNDP METHODS)| + |(BOUNDP OPTIONS)| |(WRITER METHOD)| + |PCL::DEPENDENT-UPDATE-MIXIN class predicate| + GENERIC-FUNCTION-PRETTY-ARGLIST |(WRITER SOURCE)| + |(FAST-METHOD SLOTS-TO-INSPECT (SLOT-CLASS SLOT-OBJECT))| + |(FAST-METHOD SPECIALIZER-DIRECT-GENERIC-FUNCTIONS (SPECIALIZER-WITH-OBJECT))| + |(FAST-METHOD SPECIALIZER-DIRECT-METHODS (SPECIALIZER-WITH-OBJECT))| + |(FAST-METHOD UPDATE-INSTANCE-FOR-DIFFERENT-CLASS (STANDARD-OBJECT STANDARD-OBJECT))| + |(FAST-METHOD REINITIALIZE-INSTANCE (SLOT-OBJECT))| + |(FAST-METHOD INITIALIZE-INSTANCE (SLOT-OBJECT))| + |(FAST-METHOD SPECIALIZER-CLASS (EQL-SPECIALIZER))| + |(FAST-METHOD SAME-SPECIALIZER-P (EQL-SPECIALIZER EQL-SPECIALIZER))| + |(FAST-METHOD SAME-SPECIALIZER-P (CLASS-EQ-SPECIALIZER CLASS-EQ-SPECIALIZER))| + |(FAST-METHOD SAME-SPECIALIZER-P (SPECIALIZER SPECIALIZER))| + |(FAST-METHOD SPECIALIZER-METHOD-TABLE (CLASS-EQ-SPECIALIZER))| + |(FAST-METHOD SPECIALIZER-METHOD-TABLE (EQL-SPECIALIZER))| + MAKE-BOUNDP-METHOD-FUNCTION + |LISP::STRING class predicate| + |(FAST-METHOD (SETF DOCUMENTATION) (T DOCUMENTATION-MIXIN))| + |(FAST-METHOD DOCUMENTATION (DOCUMENTATION-MIXIN))| + |PCL::METAOBJECT class predicate| + |(FAST-METHOD ACCESSOR-METHOD-SLOT-NAME (TRACED-METHOD))| + |(FAST-METHOD METHOD-QUALIFIERS (TRACED-METHOD))| + |(FAST-METHOD METHOD-SPECIALIZERS (TRACED-METHOD))| + |(FAST-METHOD METHOD-LAMBDA-LIST (TRACED-METHOD))| + |(FAST-METHOD METHOD-PRETTY-ARGLIST (STANDARD-METHOD))| + |(FAST-METHOD GENERIC-FUNCTION-PRETTY-ARGLIST (STANDARD-GENERIC-FUNCTION))| + |(FAST-METHOD FUNCTION-KEYWORDS (STANDARD-METHOD))| + |(FAST-METHOD COMPUTE-DISCRIMINATING-FUNCTION (STANDARD-GENERIC-FUNCTION))| + |(FAST-METHOD REINITIALIZE-INSTANCE :AFTER (STANDARD-GENERIC-FUNCTION))| + |(FAST-METHOD INITIALIZE-INSTANCE :AFTER (STANDARD-GENERIC-FUNCTION))| + |(FAST-METHOD GF-FAST-METHOD-FUNCTION-P (STANDARD-GENERIC-FUNCTION))| + |(FAST-METHOD GENERIC-FUNCTION-LAMBDA-LIST (GENERIC-FUNCTION))| + |(FAST-METHOD COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO (STANDARD-GENERIC-FUNCTION))| + |(FAST-METHOD METHOD-QUALIFIERS (STANDARD-METHOD))| + |(FAST-METHOD REINITIALIZE-INSTANCE (STANDARD-METHOD))| + |(FAST-METHOD ACCESSOR-METHOD-CLASS (STANDARD-WRITER-METHOD))| + |(FAST-METHOD ACCESSOR-METHOD-CLASS (STANDARD-ACCESSOR-METHOD))| + |(FAST-METHOD METHOD-FUNCTION (STANDARD-METHOD))| + |(FAST-METHOD CHANGE-CLASS (T SYMBOL))| + |(FAST-METHOD MAKE-INSTANCES-OBSOLETE (SYMBOL))| + |(FAST-METHOD REMOVE-DIRECT-METHOD (SPECIALIZER-WITH-OBJECT METHOD))| + |(FAST-METHOD ADD-DIRECT-METHOD (SPECIALIZER-WITH-OBJECT METHOD))| + |(FAST-METHOD REMOVE-DIRECT-METHOD (CLASS METHOD))| + |(FAST-METHOD ADD-DIRECT-METHOD (CLASS METHOD))| + |(FAST-METHOD (SETF DOCUMENTATION) (T STANDARD-SLOT-DEFINITION))| + |(FAST-METHOD DOCUMENTATION (STANDARD-SLOT-DEFINITION))| + |(FAST-METHOD SLOT-DEFINITION-ALLOCATION (STRUCTURE-SLOT-DEFINITION))| + |(FAST-METHOD INITIALIZE-INTERNAL-SLOT-FUNCTIONS (EFFECTIVE-SLOT-DEFINITION))| + |(FAST-METHOD MAKE-INSTANCE (SYMBOL))| + |(FAST-METHOD SLOT-MAKUNBOUND-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| + |(FAST-METHOD SLOT-BOUNDP-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| + |(FAST-METHOD (SETF SLOT-VALUE-USING-CLASS) (T STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| + |(FAST-METHOD SLOT-VALUE-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| + |(FAST-METHOD SLOT-MAKUNBOUND-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| + |(FAST-METHOD SLOT-BOUNDP-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| + |(FAST-METHOD (SETF SLOT-VALUE-USING-CLASS) (T STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| + |(FAST-METHOD SLOT-VALUE-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| + |(FAST-METHOD SPECIALIZER-CLASS (CLASS))| + |(FAST-METHOD SAME-SPECIALIZER-P (CLASS CLASS))| + |(FAST-METHOD ALLOCATE-INSTANCE (FUNCALLABLE-STANDARD-CLASS))| + |(FAST-METHOD VALIDATE-SUPERCLASS (FUNCALLABLE-STANDARD-CLASS STANDARD-CLASS))| + |(FAST-METHOD RAW-INSTANCE-ALLOCATOR (FUNCALLABLE-STANDARD-CLASS))| + |(FAST-METHOD SLOTS-FETCHER (FUNCALLABLE-STANDARD-CLASS))| + |(FAST-METHOD WRAPPER-FETCHER (FUNCALLABLE-STANDARD-CLASS))| + |(FAST-METHOD COMPUTE-CLASS-PRECEDENCE-LIST (SLOT-CLASS))| + |(FAST-METHOD VALIDATE-SUPERCLASS (SLOT-CLASS FORWARD-REFERENCED-CLASS))| + |(FAST-METHOD VALIDATE-SUPERCLASS (CLASS BUILT-IN-CLASS))| + |(FAST-METHOD CLASS-DEFAULT-INITARGS (BUILT-IN-CLASS))| + |(FAST-METHOD CLASS-DIRECT-DEFAULT-INITARGS (BUILT-IN-CLASS))| + |(FAST-METHOD CLASS-SLOTS (BUILT-IN-CLASS))| + |(FAST-METHOD CLASS-DIRECT-SLOTS (BUILT-IN-CLASS))| + |(FAST-METHOD CHANGE-CLASS (STANDARD-OBJECT FUNCALLABLE-STANDARD-CLASS))| + |(FAST-METHOD CHANGE-CLASS (STANDARD-OBJECT STANDARD-CLASS))| + |(FAST-METHOD MAKE-INSTANCES-OBSOLETE (STD-CLASS))| + |(FAST-METHOD VALIDATE-SUPERCLASS (CLASS CLASS))| + |(FAST-METHOD COMPUTE-SLOTS :AROUND (STRUCTURE-CLASS))| + |(FAST-METHOD COMPUTE-SLOTS (STRUCTURE-CLASS))| + |(FAST-METHOD COMPUTE-SLOTS :AROUND (STD-CLASS))| + |(FAST-METHOD COMPUTE-SLOTS (STD-CLASS))| + |(FAST-METHOD COMPUTE-DEFAULT-INITARGS (SLOT-CLASS))| + |(FAST-METHOD FINALIZE-INHERITANCE (STD-CLASS))| + |(FAST-METHOD FINALIZE-INHERITANCE (STRUCTURE-CLASS))| + |(FAST-METHOD REINITIALIZE-INSTANCE :AFTER (SLOT-CLASS))| + |(FAST-METHOD REINITIALIZE-INSTANCE :BEFORE (SLOT-CLASS))| + |(FAST-METHOD ENSURE-CLASS-USING-CLASS (T PCL-CLASS))| + |(FAST-METHOD SPECIALIZER-DIRECT-GENERIC-FUNCTIONS (CLASS))| + |(FAST-METHOD SPECIALIZER-DIRECT-METHODS (CLASS))| + |(FAST-METHOD REMOVE-DIRECT-SUBCLASS (CLASS CLASS))| + |(FAST-METHOD ADD-DIRECT-SUBCLASS (CLASS CLASS))| + |(FAST-METHOD CLASS-SLOT-CELLS (STD-CLASS))| + |(FAST-METHOD CLASS-CONSTRUCTORS (SLOT-CLASS))| + |(FAST-METHOD CLASS-DEFAULT-INITARGS (SLOT-CLASS))| + |(FAST-METHOD CLASS-DIRECT-DEFAULT-INITARGS (SLOT-CLASS))| + |(FAST-METHOD CLASS-PROTOTYPE (STRUCTURE-CLASS))| + |(FAST-METHOD CLASS-PROTOTYPE (STD-CLASS))| + |(FAST-METHOD CLASS-FINALIZED-P (PCL-CLASS))| + |(FAST-METHOD MAKE-INSTANCE (CLASS))| + |(FAST-METHOD ALLOCATE-INSTANCE (STRUCTURE-CLASS))| + |(FAST-METHOD ALLOCATE-INSTANCE (STANDARD-CLASS))| + |(FAST-METHOD RAW-INSTANCE-ALLOCATOR (STANDARD-CLASS))| + |(FAST-METHOD SLOTS-FETCHER (STANDARD-CLASS))| + |(FAST-METHOD WRAPPER-FETCHER (STANDARD-CLASS))| + CLASS-PREDICATE-NAME + |PCL::STRUCTURE-OBJECT class predicate| + |PCL::STRUCTURE-SLOT-DEFINITION class predicate| + |PCL::STRUCTURE-DIRECT-SLOT-DEFINITION class predicate| + |PCL::STRUCTURE-EFFECTIVE-SLOT-DEFINITION class predicate| + |LISP::SYMBOL class predicate| CLASSP + |PCL::EFFECTIVE-SLOT-DEFINITION class predicate| + |(COMBINED-METHOD SHARED-INITIALIZE)| + LEGAL-QUALIFIERS-P ADD-BOUNDP-METHOD + LEGAL-LAMBDA-LIST-P |LISP::VECTOR class predicate| + |SETF PCL GENERIC-FUNCTION-NAME| + |(READER READER-FUNCTION)| |(READER PREDICATE-NAME)| + |(READER READERS)| DESCRIBE-OBJECT + |(READER CLASS-PRECEDENCE-LIST)| + |(READER ACCESSOR-FLAGS)| |(READER LOCATION)| + |(READER DOCUMENTATION)| CLASS-INITIALIZE-INFO + |(SETF CLASS-SLOT-VALUE)| MAKE-WRITER-METHOD-FUNCTION + |SETF PCL GF-DFUN-STATE| + |(READER INCOMPATIBLE-SUPERCLASS-LIST)| + |(READER SPECIALIZERS)| + |(READER IDENTITY-WITH-ONE-ARGUMENT)| + |(SETF CLASS-INITIALIZE-INFO)| + |(READER PRETTY-ARGLIST)| |(READER DEFSTRUCT-FORM)| + |SETF PCL SLOT-DEFINITION-NAME| |SETF PCL CLASS-NAME| + |(WRITER READER-FUNCTION)| + |(SETF CLASS-DEFSTRUCT-CONSTRUCTOR)| + |(WRITER PREDICATE-NAME)| |(WRITER READERS)| + |(READER WRITER-FUNCTION)| |(READER INITFUNCTION)| + INITIALIZE-INTERNAL-SLOT-FUNCTIONS + |SETF PCL SLOT-DEFINITION-TYPE| + |(WRITER CLASS-PRECEDENCE-LIST)| |(READER WRITERS)| + |(WRITER ACCESSOR-FLAGS)| |(READER INITFORM)| + METHOD-COMBINATION-P |(WRITER LOCATION)| + |(WRITER DOCUMENTATION)| + |(CALL REAL-ENSURE-GF-USING-CLASS--GENERIC-FUNCTION)| + |SETF PCL GENERIC-FUNCTION-METHODS| + |SETF PCL GENERIC-FUNCTION-METHOD-COMBINATION| + |SETF PCL METHOD-GENERIC-FUNCTION| |(READER SLOT-NAME)| + |(WRITER INCOMPATIBLE-SUPERCLASS-LIST)| + |SETF PCL SLOT-ACCESSOR-STD-P| + |(CALL REAL-MAKE-METHOD-INITARGS-FORM)| + |(READER ALLOCATION)| |(WRITER SPECIALIZERS)| + |(CALL REAL-ENSURE-GF-USING-CLASS--NULL)| + |(WRITER IDENTITY-WITH-ONE-ARGUMENT)| + |(SETF METHOD-GENERIC-FUNCTION)| + |(WRITER PRETTY-ARGLIST)| LEGAL-SPECIALIZERS-P + |SETF PCL OBJECT-PLIST| |LISP::FLOAT class predicate| + |(WRITER DEFSTRUCT-FORM)| |(READER FUNCTION)| + |(READER GENERIC-FUNCTION)| |(READER LAMBDA-LIST)| + |(READER SLOT-DEFINITION)| + |PCL::CLASS-PROTOTYPE-SPECIALIZER class predicate| + |SETF PCL SLOT-DEFINITION-INITFORM| + |SETF PCL CLASS-DEFSTRUCT-FORM| + |(READER CAN-PRECEDE-LIST)| + |SETF PCL GENERIC-FUNCTION-METHOD-CLASS| + |(READER PROTOTYPE)| |(WRITER WRITER-FUNCTION)| + |(WRITER INITFUNCTION)| |(WRITER WRITERS)| + SLOT-ACCESSOR-STD-P |(WRITER INITFORM)| + |(READER DFUN-STATE)| |(READER FROM-DEFCLASS-P)| + |SETF PCL GF-PRETTY-ARGLIST| + |SETF PCL SLOT-ACCESSOR-FUNCTION| + |SETF PCL SLOT-DEFINITION-LOCATION| + |SETF PCL SLOT-DEFINITION-READER-FUNCTION| + |SETF PCL SLOT-DEFINITION-WRITER-FUNCTION| + |SETF PCL SLOT-DEFINITION-BOUNDP-FUNCTION| + |SETF PCL SLOT-DEFINITION-INTERNAL-READER-FUNCTION| + |SETF PCL SLOT-DEFINITION-INTERNAL-WRITER-FUNCTION| + |SETF PCL SLOT-DEFINITION-ALLOCATION| + |SETF PCL SLOT-DEFINITION-INITFUNCTION| + |(WRITER SLOT-NAME)| |(BOUNDP NAME)| + |(WRITER ALLOCATION)| |(READER FAST-FUNCTION)| + |(READER METHOD-CLASS)| |(SETF OBJECT-PLIST)| + |(READER INTERNAL-WRITER-FUNCTION)| + |(READER INTERNAL-READER-FUNCTION)| + |(READER METHOD-COMBINATION)| + METHOD-COMBINATION-OPTIONS |(READER DIRECT-SLOTS)| + |(READER DIRECT-METHODS)| + |SETF PCL SLOT-DEFINITION-READERS| + |(READER BOUNDP-FUNCTION)| |(WRITER FUNCTION)| + |(WRITER GENERIC-FUNCTION)| + |(READER DIRECT-SUBCLASSES)| + |(READER DIRECT-SUPERCLASSES)| |SETF PCL DOCUMENTATION| + |(WRITER LAMBDA-LIST)| |LISP::LIST class predicate| + FUNCALLABLE-STANDARD-CLASS-P + |(FAST-WRITER-METHOD SLOT-OBJECT METHOD)| + |(BOUNDP CLASS)| |(WRITER SLOT-DEFINITION)| + |(READER METHODS)| |(READER OPTIONS)| + |(WRITER CAN-PRECEDE-LIST)| + |SETF PCL SLOT-DEFINITION-CLASS| + |SETF PCL SLOT-VALUE-USING-CLASS| + |(FAST-WRITER-METHOD SLOT-OBJECT DEFSTRUCT-ACCESSOR-SYMBOL)| + |(FAST-WRITER-METHOD STRUCTURE-SLOT-DEFINITION DEFSTRUCT-ACCESSOR-SYMBOL)| + |(WRITER PROTOTYPE)| |(BOUNDP OBJECT)| |(BOUNDP TYPE)| + CLASS-CAN-PRECEDE-LIST |SETF PCL CLASS-DIRECT-SLOTS| + |SETF PCL CLASS-SLOTS| SLOT-ACCESSOR-FUNCTION + |(BOUNDP PLIST)| + |SETF PCL CLASS-INCOMPATIBLE-SUPERCLASS-LIST| + |SETF PCL SLOT-DEFINITION-WRITERS| + |(FAST-WRITER-METHOD SLOT-OBJECT SOURCE)| + |(WRITER DFUN-STATE)| |(WRITER FROM-DEFCLASS-P)| + |(BOUNDP SLOTS)| SLOT-CLASS-P + MAKE-READER-METHOD-FUNCTION LEGAL-METHOD-FUNCTION-P + |(FAST-WRITER-METHOD SLOT-OBJECT INITIALIZE-INFO)| + |(FAST-WRITER-METHOD SLOT-CLASS INITIALIZE-INFO)| + |(FAST-WRITER-METHOD SLOT-OBJECT ARG-INFO)| + |PCL::PLIST-MIXIN class predicate| + |(WRITER FAST-FUNCTION)| |(WRITER METHOD-CLASS)| + |(FAST-WRITER-METHOD SLOT-OBJECT WRAPPER)| + |(WRITER INTERNAL-WRITER-FUNCTION)| + |(WRITER INTERNAL-READER-FUNCTION)| + |(WRITER METHOD-COMBINATION)| GET-METHOD + |(WRITER DIRECT-SLOTS)| |(WRITER DIRECT-METHODS)| + |(FAST-WRITER-METHOD SLOT-OBJECT INITARGS)| + |(FAST-WRITER-METHOD SLOT-DEFINITION INITARGS)| + |(FAST-WRITER-METHOD SLOT-OBJECT OPERATOR)| + |(FAST-WRITER-METHOD SLOT-OBJECT DEFSTRUCT-CONSTRUCTOR)| + |(FAST-WRITER-METHOD STRUCTURE-CLASS DEFSTRUCT-CONSTRUCTOR)| + |(WRITER BOUNDP-FUNCTION)| |(WRITER DIRECT-SUBCLASSES)| + |(WRITER DIRECT-SUPERCLASSES)| + |(FAST-WRITER-METHOD SLOT-OBJECT CLASS-EQ-SPECIALIZER)| + |(WRITER METHODS)| |(WRITER OPTIONS)| + SHORT-METHOD-COMBINATION-P GF-ARG-INFO + SPECIALIZER-METHOD-TABLE MAKE-METHOD-INITARGS-FORM + CLASS-DEFSTRUCT-FORM |LISP::INTEGER class predicate| + |(FAST-READER-METHOD SLOT-OBJECT PREDICATE-NAME)| + |(FAST-READER-METHOD CLASS PREDICATE-NAME)| + |(FAST-READER-METHOD CLASS NAME)| + |(FAST-READER-METHOD SLOT-DEFINITION NAME)| + |(FAST-READER-METHOD SLOT-OBJECT SLOT-NAME)| + |(FAST-READER-METHOD STANDARD-ACCESSOR-METHOD SLOT-NAME)| + |(FAST-READER-METHOD SLOT-OBJECT DFUN-STATE)| + |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION DFUN-STATE)| + |(FAST-READER-METHOD SLOT-OBJECT NAME)| + |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION NAME)| + GF-PRETTY-ARGLIST SAME-SPECIALIZER-P + SLOT-DEFINITION-BOUNDP-FUNCTION + SLOT-DEFINITION-WRITER-FUNCTION + SLOT-DEFINITION-READER-FUNCTION + SLOT-DEFINITION-INTERNAL-WRITER-FUNCTION + SLOT-DEFINITION-INTERNAL-READER-FUNCTION + |(FAST-READER-METHOD SLOT-OBJECT CLASS)| + |(FAST-READER-METHOD SLOT-DEFINITION CLASS)| + |(FAST-READER-METHOD SLOT-OBJECT ACCESSOR-FLAGS)| + |(FAST-READER-METHOD SLOT-OBJECT METHOD-CLASS)| + |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION METHOD-CLASS)| + |(FAST-READER-METHOD TRACED-METHOD GENERIC-FUNCTION)| + |(FAST-READER-METHOD TRACED-METHOD FUNCTION)| + |(FAST-READER-METHOD LONG-METHOD-COMBINATION FUNCTION)| + |(FAST-READER-METHOD SLOT-OBJECT INITFUNCTION)| + |(FAST-READER-METHOD SLOT-DEFINITION INITFUNCTION)| + |(FAST-READER-METHOD SLOT-OBJECT ALLOCATION)| + |(FAST-READER-METHOD STANDARD-SLOT-DEFINITION ALLOCATION)| + |(FAST-READER-METHOD SLOT-OBJECT INTERNAL-WRITER-FUNCTION)| + |(FAST-READER-METHOD STRUCTURE-SLOT-DEFINITION INTERNAL-WRITER-FUNCTION)| + |(FAST-READER-METHOD SLOT-OBJECT INTERNAL-READER-FUNCTION)| + |(FAST-READER-METHOD STRUCTURE-SLOT-DEFINITION INTERNAL-READER-FUNCTION)| + |(FAST-READER-METHOD SLOT-OBJECT BOUNDP-FUNCTION)| + |(FAST-READER-METHOD EFFECTIVE-SLOT-DEFINITION BOUNDP-FUNCTION)| + |(FAST-READER-METHOD SLOT-OBJECT WRITER-FUNCTION)| + |(FAST-READER-METHOD EFFECTIVE-SLOT-DEFINITION WRITER-FUNCTION)| + |(FAST-READER-METHOD SLOT-OBJECT READER-FUNCTION)| + |(FAST-READER-METHOD EFFECTIVE-SLOT-DEFINITION READER-FUNCTION)| + |(FAST-READER-METHOD SLOT-OBJECT LOCATION)| + |(FAST-READER-METHOD STANDARD-EFFECTIVE-SLOT-DEFINITION LOCATION)| + |(FAST-READER-METHOD SLOT-OBJECT FAST-FUNCTION)| + |(FAST-READER-METHOD STANDARD-METHOD FAST-FUNCTION)| + |(FAST-READER-METHOD SLOT-OBJECT FUNCTION)| + |(FAST-READER-METHOD SLOT-OBJECT GENERIC-FUNCTION)| + |(FAST-READER-METHOD STANDARD-METHOD GENERIC-FUNCTION)| + |(FAST-READER-METHOD SLOT-OBJECT SLOT-DEFINITION)| + |(FAST-READER-METHOD STANDARD-ACCESSOR-METHOD SLOT-DEFINITION)| + |(FAST-READER-METHOD SLOT-OBJECT METHOD-COMBINATION)| + |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION METHOD-COMBINATION)| + |(FAST-READER-METHOD SLOT-OBJECT DOCUMENTATION)| + |(FAST-READER-METHOD STANDARD-METHOD-COMBINATION DOCUMENTATION)| + |(FAST-READER-METHOD SLOT-OBJECT WRITERS)| + |(FAST-READER-METHOD SLOT-DEFINITION WRITERS)| + |(FAST-READER-METHOD SLOT-OBJECT READERS)| + |(FAST-READER-METHOD SLOT-DEFINITION READERS)| + |(FAST-READER-METHOD SLOT-OBJECT SPECIALIZERS)| + |(FAST-READER-METHOD STANDARD-METHOD SPECIALIZERS)| + |(FAST-READER-METHOD SHORT-METHOD-COMBINATION IDENTITY-WITH-ONE-ARGUMENT)| + |(FAST-READER-METHOD SLOT-OBJECT IDENTITY-WITH-ONE-ARGUMENT)| + |(FAST-READER-METHOD SPECIALIZER TYPE)| + |(FAST-READER-METHOD SLOT-OBJECT PROTOTYPE)| + |(FAST-READER-METHOD PCL-CLASS PROTOTYPE)| + |(FAST-READER-METHOD CLASS-EQ-SPECIALIZER OBJECT)| + |(FAST-READER-METHOD CLASS-PROTOTYPE-SPECIALIZER OBJECT)| + |(FAST-READER-METHOD SLOT-OBJECT OBJECT)| + |(FAST-READER-METHOD EQL-SPECIALIZER OBJECT)| + |(FAST-READER-METHOD SLOT-DEFINITION TYPE)| + |(FAST-READER-METHOD SLOT-OBJECT TYPE)| + |(FAST-READER-METHOD STANDARD-METHOD-COMBINATION TYPE)| + |(FAST-READER-METHOD SLOT-OBJECT DEFSTRUCT-FORM)| + |(FAST-READER-METHOD STRUCTURE-CLASS DEFSTRUCT-FORM)| + |(FAST-READER-METHOD SLOT-OBJECT INITFORM)| + |(FAST-READER-METHOD SLOT-DEFINITION INITFORM)| + |(FAST-READER-METHOD SLOT-OBJECT PLIST)| + |(FAST-READER-METHOD PLIST-MIXIN PLIST)| + |(FAST-READER-METHOD SLOT-OBJECT INCOMPATIBLE-SUPERCLASS-LIST)| + |(FAST-READER-METHOD PCL-CLASS INCOMPATIBLE-SUPERCLASS-LIST)| + |(FAST-READER-METHOD SLOT-OBJECT CAN-PRECEDE-LIST)| + |(FAST-READER-METHOD PCL-CLASS CAN-PRECEDE-LIST)| + |(FAST-READER-METHOD SLOT-OBJECT CLASS-PRECEDENCE-LIST)| + |(FAST-READER-METHOD PCL-CLASS CLASS-PRECEDENCE-LIST)| + |(FAST-READER-METHOD SLOT-OBJECT LAMBDA-LIST)| + |(FAST-READER-METHOD STANDARD-METHOD LAMBDA-LIST)| + |(FAST-READER-METHOD SLOT-OBJECT PRETTY-ARGLIST)| + |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION PRETTY-ARGLIST)| + |(FAST-READER-METHOD SLOT-OBJECT DIRECT-METHODS)| + |(FAST-READER-METHOD SLOT-OBJECT SLOTS)| + |(FAST-READER-METHOD SLOT-CLASS SLOTS)| + |(FAST-READER-METHOD SLOT-OBJECT DIRECT-SLOTS)| + |(FAST-READER-METHOD SLOT-CLASS DIRECT-SLOTS)| + |(FAST-READER-METHOD SLOT-OBJECT FROM-DEFCLASS-P)| + |(FAST-READER-METHOD SLOT-OBJECT METHODS)| + |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION METHODS)| + |(FAST-READER-METHOD SLOT-OBJECT OPTIONS)| + |(FAST-READER-METHOD STANDARD-METHOD-COMBINATION OPTIONS)| + |(FAST-READER-METHOD SLOT-OBJECT DIRECT-SUBCLASSES)| + |(FAST-READER-METHOD CLASS DIRECT-SUBCLASSES)| + |(FAST-READER-METHOD SLOT-OBJECT DIRECT-SUPERCLASSES)| + |(FAST-READER-METHOD CLASS DIRECT-SUPERCLASSES)| + SLOT-DEFINITION-CLASS EQL-SPECIALIZER-OBJECT + |PCL::DIRECT-SLOT-DEFINITION class predicate| + CLASS-CONSTRUCTORS |(BOUNDP WRAPPER)| SLOTS-TO-INSPECT + |(FAST-BOUNDP-METHOD SLOT-OBJECT PREDICATE-NAME)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT SLOT-NAME)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT DFUN-STATE)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT NAME)| + |(BOUNDP DEFSTRUCT-ACCESSOR-SYMBOL)| + SPECIALIZER-DIRECT-GENERIC-FUNCTIONS + |(BOUNDP CLASS-EQ-SPECIALIZER)| + |(SETF SLOT-DEFINITION-NAME)| ADD-WRITER-METHOD + |(FAST-BOUNDP-METHOD SLOT-OBJECT CLASS)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT ACCESSOR-FLAGS)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT METHOD-CLASS)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT INITFUNCTION)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT ALLOCATION)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT INTERNAL-WRITER-FUNCTION)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT INTERNAL-READER-FUNCTION)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT BOUNDP-FUNCTION)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT WRITER-FUNCTION)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT READER-FUNCTION)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT LOCATION)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT FAST-FUNCTION)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT FUNCTION)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT GENERIC-FUNCTION)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT SLOT-DEFINITION)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT METHOD-COMBINATION)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT DOCUMENTATION)| + |(BOUNDP OPERATOR)| |(BOUNDP ARG-INFO)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT WRITERS)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT READERS)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT SPECIALIZERS)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT PROTOTYPE)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT OBJECT)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT TYPE)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT DEFSTRUCT-FORM)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT INITFORM)| + |(SETF SLOT-VALUE-USING-CLASS)| + |(SETF SLOT-DEFINITION-CLASS)| + |(SETF SLOT-ACCESSOR-FUNCTION)| + |(SETF SLOT-DEFINITION-INITFUNCTION)| + |(SETF SLOT-DEFINITION-ALLOCATION)| + |(SETF SLOT-DEFINITION-INTERNAL-WRITER-FUNCTION)| + |(SETF SLOT-DEFINITION-INTERNAL-READER-FUNCTION)| + |(SETF SLOT-DEFINITION-BOUNDP-FUNCTION)| + |(SETF SLOT-DEFINITION-WRITER-FUNCTION)| + |(SETF SLOT-DEFINITION-READER-FUNCTION)| + |(SETF SLOT-DEFINITION-LOCATION)| + |(BOUNDP DEFSTRUCT-CONSTRUCTOR)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT PLIST)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT INCOMPATIBLE-SUPERCLASS-LIST)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT CAN-PRECEDE-LIST)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT CLASS-PRECEDENCE-LIST)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT LAMBDA-LIST)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT PRETTY-ARGLIST)| + |(SETF SLOT-DEFINITION-WRITERS)| + |(SETF SLOT-DEFINITION-READERS)| + |(SETF SLOT-DEFINITION-TYPE)| + |(SETF SLOT-DEFINITION-INITFORM)| + |(BOUNDP INITIALIZE-INFO)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT DIRECT-METHODS)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT SLOTS)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT DIRECT-SLOTS)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT FROM-DEFCLASS-P)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT METHODS)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT OPTIONS)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT DIRECT-SUBCLASSES)| + |(FAST-BOUNDP-METHOD SLOT-OBJECT DIRECT-SUPERCLASSES)| + |(FAST-INTERNAL-READER-METHOD STANDARD-GENERIC-FUNCTION ARG-INFO)| + |(BOUNDP INITARGS)| LONG-METHOD-COMBINATION-FUNCTION + GENERIC-FUNCTION-P + |PCL::SLOT-DEFINITION class predicate| + |LISP::NULL class predicate| |(READER NAME)| + |(READER CLASS)| + |(FAST-METHOD DESCRIBE-OBJECT (CLASS T))| + |(FAST-METHOD DESCRIBE-OBJECT (STANDARD-GENERIC-FUNCTION T))| + |(FAST-METHOD DESCRIBE-OBJECT (SLOT-OBJECT T))| + |(FAST-METHOD DESCRIBE-OBJECT (T T))| + |(FAST-METHOD COMPUTE-EFFECTIVE-METHOD (GENERIC-FUNCTION LONG-METHOD-COMBINATION T))| + |(FAST-METHOD COMPUTE-EFFECTIVE-METHOD (GENERIC-FUNCTION SHORT-METHOD-COMBINATION T))| + |(FAST-METHOD FIND-METHOD-COMBINATION (GENERIC-FUNCTION (EQL STANDARD) T))| + |(FAST-METHOD UPDATE-GF-DFUN (STD-CLASS T))| + |(FAST-METHOD COMPUTE-APPLICABLE-METHODS-USING-CLASSES (GENERIC-FUNCTION T))| + |(FAST-METHOD COMPUTE-APPLICABLE-METHODS (GENERIC-FUNCTION T))| + |(FAST-METHOD REMOVE-NAMED-METHOD (T T))| + |(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-GENERIC-FUNCTION T))| + |(FAST-METHOD PRINT-OBJECT (GENERIC-FUNCTION T))| + |(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-ACCESSOR-METHOD T))| + |(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-METHOD T))| + |(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-ACCESSOR-METHOD T))| + |(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-METHOD T))| + |(FAST-METHOD LEGAL-SPECIALIZER-P (STANDARD-METHOD T))| + |(FAST-METHOD LEGAL-SPECIALIZERS-P (STANDARD-METHOD T))| + |(FAST-METHOD LEGAL-SLOT-NAME-P (STANDARD-METHOD T))| + |(FAST-METHOD LEGAL-QUALIFIER-P (STANDARD-METHOD T))| + |(FAST-METHOD LEGAL-QUALIFIERS-P (STANDARD-METHOD T))| + |(FAST-METHOD LEGAL-METHOD-FUNCTION-P (STANDARD-METHOD T))| + |(FAST-METHOD LEGAL-LAMBDA-LIST-P (STANDARD-METHOD T))| + |(FAST-METHOD LEGAL-DOCUMENTATION-P (STANDARD-METHOD T))| + |(FAST-METHOD PRINT-OBJECT (STANDARD-ACCESSOR-METHOD T))| + |(FAST-METHOD PRINT-OBJECT (STANDARD-METHOD T))| + |(FAST-METHOD INFORM-TYPE-SYSTEM-ABOUT-CLASS (STRUCTURE-CLASS T))| + |(FAST-METHOD SHARED-INITIALIZE :AFTER (STRUCTURE-SLOT-DEFINITION T))| + |(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-SLOT-DEFINITION T))| + |(FAST-METHOD PRINT-OBJECT (STANDARD-METHOD-COMBINATION T))| + |(FAST-METHOD PRINT-OBJECT (SLOT-DEFINITION T))| + |(FAST-METHOD PRINT-OBJECT (CLASS T))| + |(FAST-METHOD PRINT-OBJECT (T T))| + |(FAST-METHOD MAKE-WRITER-METHOD-FUNCTION (FUNCALLABLE-STANDARD-CLASS T))| + |(FAST-METHOD MAKE-READER-METHOD-FUNCTION (FUNCALLABLE-STANDARD-CLASS T))| + |(FAST-METHOD MAP-DEPENDENTS (DEPENDENT-UPDATE-MIXIN T))| + |(FAST-METHOD REMOVE-DEPENDENT (DEPENDENT-UPDATE-MIXIN T))| + |(FAST-METHOD ADD-DEPENDENT (DEPENDENT-UPDATE-MIXIN T))| + |(FAST-METHOD SHARED-INITIALIZE :BEFORE (BUILT-IN-CLASS T))| + |(FAST-METHOD COMPATIBLE-META-CLASS-CHANGE-P (T T))| + |(FAST-METHOD INFORM-TYPE-SYSTEM-ABOUT-CLASS (STD-CLASS T))| + |(FAST-METHOD MAKE-BOUNDP-METHOD-FUNCTION (SLOT-CLASS T))| + |(FAST-METHOD MAKE-WRITER-METHOD-FUNCTION (SLOT-CLASS T))| + |(FAST-METHOD MAKE-READER-METHOD-FUNCTION (SLOT-CLASS T))| + |(FAST-METHOD REMOVE-BOUNDP-METHOD (SLOT-CLASS T))| + |(FAST-METHOD REMOVE-WRITER-METHOD (SLOT-CLASS T))| + |(FAST-METHOD REMOVE-READER-METHOD (SLOT-CLASS T))| + |(FAST-METHOD ADD-BOUNDP-METHOD (SLOT-CLASS T T))| + |(FAST-METHOD ADD-WRITER-METHOD (SLOT-CLASS T T))| + |(FAST-METHOD WRITER-METHOD-CLASS (SLOT-CLASS T))| + |(FAST-METHOD ADD-READER-METHOD (SLOT-CLASS T T))| + |(FAST-METHOD READER-METHOD-CLASS (SLOT-CLASS T))| + |(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS :AROUND (STRUCTURE-CLASS T))| + |(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS (SLOT-CLASS T))| + |(FAST-METHOD EFFECTIVE-SLOT-DEFINITION-CLASS (STRUCTURE-CLASS T))| + |(FAST-METHOD EFFECTIVE-SLOT-DEFINITION-CLASS (STD-CLASS T))| + |(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION (SLOT-CLASS T))| + |(FAST-METHOD DIRECT-SLOT-DEFINITION-CLASS (STD-CLASS T))| + |(FAST-METHOD DIRECT-SLOT-DEFINITION-CLASS (STRUCTURE-CLASS T))| + |(FAST-METHOD SHARED-INITIALIZE :AFTER (STRUCTURE-CLASS T))| + |(FAST-METHOD SHARED-INITIALIZE :BEFORE (CLASS T))| + |(FAST-METHOD SHARED-INITIALIZE :AFTER (STD-CLASS T))| + |(FAST-METHOD SHARED-INITIALIZE :AFTER (EQL-SPECIALIZER T))| + |(FAST-METHOD SHARED-INITIALIZE :AFTER (CLASS-EQ-SPECIALIZER T))| + |(FAST-METHOD (SETF DOCUMENTATION) (T T))| + |(FAST-METHOD SHARED-INITIALIZE :AFTER (DOCUMENTATION-MIXIN T))| + |(FAST-METHOD COMPUTE-SLOT-ACCESSOR-INFO (EFFECTIVE-SLOT-DEFINITION T T))| + |(FAST-METHOD (SETF SLOT-ACCESSOR-STD-P) (T EFFECTIVE-SLOT-DEFINITION T))| + |(FAST-METHOD SLOT-ACCESSOR-STD-P (EFFECTIVE-SLOT-DEFINITION T))| + |(FAST-METHOD (SETF SLOT-ACCESSOR-FUNCTION) (T EFFECTIVE-SLOT-DEFINITION T))| + |(FAST-METHOD SLOT-ACCESSOR-FUNCTION (EFFECTIVE-SLOT-DEFINITION T))| + |(FAST-METHOD SHARED-INITIALIZE (SLOT-OBJECT T))| + |(FAST-METHOD UPDATE-INSTANCE-FOR-REDEFINED-CLASS (STANDARD-OBJECT T T T))| + |(FAST-METHOD DEFAULT-INITARGS (SLOT-CLASS T))| + |(FAST-METHOD SLOT-UNBOUND (T T T))| + |(FAST-METHOD SLOT-MISSING (T T T T))| + |(FAST-METHOD (SETF CLASS-SLOT-VALUE) (T STD-CLASS T))| + |(FAST-METHOD CLASS-SLOT-VALUE (STD-CLASS T))| + LEGAL-SLOT-NAME-P |(READER OBJECT)| |(READER TYPE)| + CLASS-WRAPPER |(READER PLIST)| + |(FAST-METHOD CLASS-PREDICATE-NAME (T))| + |(FAST-METHOD DOCUMENTATION (T))| + |(FAST-METHOD NO-APPLICABLE-METHOD (T))| + |(READER SLOTS)| |(WRITER NAME)| DEFINITION-SOURCE + |PCL::SLOT-OBJECT class predicate| DEFAULT-INITARGS + |(WRITER CLASS)| CLASS-SLOT-VALUE |(WRITER OBJECT)| + |(WRITER TYPE)| + |(FAST-METHOD ENSURE-CLASS-USING-CLASS (T NULL))| + |(WRITER PLIST)| |(WRITER SLOTS)| + |PCL::DOCUMENTATION-MIXIN class predicate| + FORWARD-REFERENCED-CLASS-P GF-FAST-METHOD-FUNCTION-P + LEGAL-QUALIFIER-P METHOD-P + |PCL::SPECIALIZER-WITH-OBJECT class predicate| + CLASS-SLOT-CELLS + |(COMBINED-METHOD INITIALIZE-INSTANCE)| + |(COMBINED-METHOD REINITIALIZE-INSTANCE)| + STANDARD-ACCESSOR-METHOD-P |(SETF CLASS-NAME)| + STANDARD-GENERIC-FUNCTION-P STANDARD-READER-METHOD-P + STANDARD-METHOD-P |(READER WRAPPER)| + |(READER DEFSTRUCT-ACCESSOR-SYMBOL)| + |(READER CLASS-EQ-SPECIALIZER)| + COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS + COMPUTE-DEFAULT-INITARGS |(SETF CLASS-DEFSTRUCT-FORM)| + |(CALL REAL-MAKE-METHOD-LAMBDA)| + |(SETF CLASS-INCOMPATIBLE-SUPERCLASS-LIST)| + |SETF PCL CLASS-SLOT-VALUE| |(SETF CLASS-SLOTS)| + |(SETF CLASS-DIRECT-SLOTS)| |(READER OPERATOR)| + |(CALL REAL-GET-METHOD)| |(CALL REAL-REMOVE-METHOD)| + |(CALL REAL-ADD-METHOD)| |(READER ARG-INFO)| + METHOD-COMBINATION-TYPE + |(READER DEFSTRUCT-CONSTRUCTOR)| + |(INTERNAL-READER-METHOD STANDARD-GENERIC-FUNCTION ARG-INFO)| + |(READER INITIALIZE-INFO)| |(WRITER WRAPPER)| + STANDARD-CLASS-P |LISP::NUMBER class predicate| + LEGAL-SPECIALIZER-P + |PCL::LONG-METHOD-COMBINATION class predicate| + |(WRITER DEFSTRUCT-ACCESSOR-SYMBOL)| + COMPUTE-SLOT-ACCESSOR-INFO |(READER INITARGS)| + |(WRITER CLASS-EQ-SPECIALIZER)| + STANDARD-BOUNDP-METHOD-P |(SETF DOCUMENTATION)| + RAW-INSTANCE-ALLOCATOR + |SETF PCL SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL| + |SETF PCL CLASS-INITIALIZE-INFO| |(WRITER OPERATOR)| + |(WRITER ARG-INFO)| + COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO + STANDARD-WRITER-METHOD-P + CLASS-INCOMPATIBLE-SUPERCLASS-LIST + |(WRITER DEFSTRUCT-CONSTRUCTOR)| + |PCL::TRACED-METHOD class predicate| WRAPPER-FETCHER + MAKE-A-METHOD |(WRITER INITIALIZE-INFO)| + METHOD-COMBINATION-DOCUMENTATION + |SETF PCL SLOT-DEFINITION-INITARGS| + REMOVE-BOUNDP-METHOD ADD-NAMED-METHOD + |LISP::CONS class predicate| |(WRITER INITARGS)| + |SETF PCL CLASS-DEFSTRUCT-CONSTRUCTOR| + |(BOUNDP METHOD)| + |(FAST-WRITER-METHOD SLOT-OBJECT PREDICATE-NAME)| + |(FAST-WRITER-METHOD CLASS NAME)| + |(FAST-WRITER-METHOD SLOT-DEFINITION NAME)| + |(FAST-WRITER-METHOD SLOT-OBJECT SLOT-NAME)| + |(FAST-WRITER-METHOD SLOT-OBJECT DFUN-STATE)| + |(FAST-WRITER-METHOD STANDARD-GENERIC-FUNCTION DFUN-STATE)| + |(FAST-WRITER-METHOD SLOT-OBJECT NAME)| + |(FAST-WRITER-METHOD STANDARD-GENERIC-FUNCTION NAME)| + |(BOUNDP SOURCE)| |(SETF GF-DFUN-STATE)| + SHORT-COMBINATION-OPERATOR + |(FAST-WRITER-METHOD SLOT-OBJECT CLASS)| + |(FAST-WRITER-METHOD SLOT-DEFINITION CLASS)| + |(FAST-WRITER-METHOD SLOT-OBJECT ACCESSOR-FLAGS)| + |(FAST-WRITER-METHOD SLOT-OBJECT METHOD-CLASS)| + |(FAST-WRITER-METHOD STANDARD-GENERIC-FUNCTION METHOD-CLASS)| + |(FAST-WRITER-METHOD TRACED-METHOD GENERIC-FUNCTION)| + |(FAST-WRITER-METHOD SLOT-OBJECT INITFUNCTION)| + |(FAST-WRITER-METHOD SLOT-DEFINITION INITFUNCTION)| + |(FAST-WRITER-METHOD SLOT-OBJECT ALLOCATION)| + |(FAST-WRITER-METHOD STANDARD-SLOT-DEFINITION ALLOCATION)| + |(FAST-WRITER-METHOD SLOT-OBJECT INTERNAL-WRITER-FUNCTION)| + |(FAST-WRITER-METHOD STRUCTURE-SLOT-DEFINITION INTERNAL-WRITER-FUNCTION)| + |(FAST-WRITER-METHOD SLOT-OBJECT INTERNAL-READER-FUNCTION)| + |(FAST-WRITER-METHOD STRUCTURE-SLOT-DEFINITION INTERNAL-READER-FUNCTION)| + |(FAST-WRITER-METHOD SLOT-OBJECT BOUNDP-FUNCTION)| + |(FAST-WRITER-METHOD EFFECTIVE-SLOT-DEFINITION BOUNDP-FUNCTION)| + |(FAST-WRITER-METHOD SLOT-OBJECT WRITER-FUNCTION)| + |(FAST-WRITER-METHOD EFFECTIVE-SLOT-DEFINITION WRITER-FUNCTION)| + |(FAST-WRITER-METHOD SLOT-OBJECT READER-FUNCTION)| + |(FAST-WRITER-METHOD EFFECTIVE-SLOT-DEFINITION READER-FUNCTION)| + |(FAST-WRITER-METHOD SLOT-OBJECT LOCATION)| + |(FAST-WRITER-METHOD STANDARD-EFFECTIVE-SLOT-DEFINITION LOCATION)| + |(FAST-WRITER-METHOD SLOT-OBJECT FAST-FUNCTION)| + |(FAST-WRITER-METHOD SLOT-OBJECT FUNCTION)| + |(FAST-WRITER-METHOD SLOT-OBJECT GENERIC-FUNCTION)| + |(FAST-WRITER-METHOD STANDARD-METHOD GENERIC-FUNCTION)| + |(FAST-WRITER-METHOD SLOT-OBJECT SLOT-DEFINITION)| + |(FAST-WRITER-METHOD SLOT-OBJECT METHOD-COMBINATION)| + |(FAST-WRITER-METHOD STANDARD-GENERIC-FUNCTION METHOD-COMBINATION)| + |(FAST-WRITER-METHOD SLOT-OBJECT DOCUMENTATION)| + |(FAST-WRITER-METHOD SLOT-OBJECT WRITERS)| + |(FAST-WRITER-METHOD SLOT-DEFINITION WRITERS)| + |(FAST-WRITER-METHOD SLOT-OBJECT READERS)| + |(FAST-WRITER-METHOD SLOT-DEFINITION READERS)| + |(FAST-WRITER-METHOD SLOT-OBJECT SPECIALIZERS)| + |(FAST-WRITER-METHOD SLOT-OBJECT IDENTITY-WITH-ONE-ARGUMENT)| + |(FAST-WRITER-METHOD SLOT-OBJECT PROTOTYPE)| + |(FAST-WRITER-METHOD SLOT-OBJECT OBJECT)| + |(FAST-WRITER-METHOD SLOT-DEFINITION TYPE)| + |(FAST-WRITER-METHOD SLOT-OBJECT TYPE)| + REMOVE-NAMED-METHOD + |(FAST-WRITER-METHOD SLOT-OBJECT DEFSTRUCT-FORM)| + |(FAST-WRITER-METHOD STRUCTURE-CLASS DEFSTRUCT-FORM)| + |(FAST-WRITER-METHOD SLOT-OBJECT INITFORM)| + |(FAST-WRITER-METHOD SLOT-DEFINITION INITFORM)| + |(FAST-WRITER-METHOD SLOT-OBJECT PLIST)| + |(FAST-WRITER-METHOD PLIST-MIXIN PLIST)| + |(FAST-WRITER-METHOD SLOT-OBJECT INCOMPATIBLE-SUPERCLASS-LIST)| + |(FAST-WRITER-METHOD PCL-CLASS INCOMPATIBLE-SUPERCLASS-LIST)| + |(FAST-WRITER-METHOD SLOT-OBJECT CAN-PRECEDE-LIST)| + |(FAST-WRITER-METHOD SLOT-OBJECT CLASS-PRECEDENCE-LIST)| + |(FAST-WRITER-METHOD SLOT-OBJECT LAMBDA-LIST)| + |(FAST-WRITER-METHOD SLOT-OBJECT PRETTY-ARGLIST)| + |(FAST-WRITER-METHOD STANDARD-GENERIC-FUNCTION PRETTY-ARGLIST)| + LEGAL-DOCUMENTATION-P CLASS-DIRECT-SUPERCLASSES + CLASS-DIRECT-SUBCLASSES CLASS-DIRECT-DEFAULT-INITARGS + SLOT-DEFINITION-READERS SLOT-VALUE-USING-CLASS + COMPUTE-APPLICABLE-METHODS CLASS-NAME CLASS-PROTOTYPE + READER-METHOD-CLASS REMOVE-METHOD + SLOT-DEFINITION-INITFORM + UPDATE-INSTANCE-FOR-REDEFINED-CLASS + UPDATE-INSTANCE-FOR-DIFFERENT-CLASS CHANGE-CLASS + METHOD-FUNCTION DIRECT-SLOT-DEFINITION-CLASS + MAKE-METHOD-LAMBDA EFFECTIVE-SLOT-DEFINITION-CLASS + CLASS-SLOTS COMPUTE-SLOTS SLOT-DEFINITION-NAME + FINALIZE-INHERITANCE GENERIC-FUNCTION-LAMBDA-LIST + CLASS-DIRECT-SLOTS CLASS-DEFAULT-INITARGS + COMPUTE-DISCRIMINATING-FUNCTION CLASS-FINALIZED-P + GENERIC-FUNCTION-NAME REMOVE-DEPENDENT + COMPUTE-CLASS-PRECEDENCE-LIST ADD-DEPENDENT + SLOT-BOUNDP-USING-CLASS ACCESSOR-METHOD-SLOT-DEFINITION + SHARED-INITIALIZE ADD-DIRECT-METHOD + SLOT-DEFINITION-LOCATION SLOT-DEFINITION-INITFUNCTION + SLOT-DEFINITION-ALLOCATION ADD-METHOD + GENERIC-FUNCTION-METHOD-CLASS METHOD-SPECIALIZERS + SLOT-DEFINITION-INITARGS WRITER-METHOD-CLASS + ADD-DIRECT-SUBCLASS SPECIALIZER-DIRECT-METHODS + GENERIC-FUNCTION-METHOD-COMBINATION ALLOCATE-INSTANCE + COMPUTE-EFFECTIVE-METHOD SLOT-DEFINITION-TYPE + SLOT-UNBOUND INITIALIZE-INSTANCE FUNCTION-KEYWORDS + REINITIALIZE-INSTANCE VALIDATE-SUPERCLASS + GENERIC-FUNCTION-METHODS REMOVE-DIRECT-METHOD + METHOD-LAMBDA-LIST MAKE-INSTANCE + COMPUTE-EFFECTIVE-SLOT-DEFINITION PRINT-OBJECT + METHOD-QUALIFIERS METHOD-GENERIC-FUNCTION + REMOVE-DIRECT-SUBCLASS MAKE-INSTANCES-OBSOLETE + SLOT-MAKUNBOUND-USING-CLASS + ENSURE-GENERIC-FUNCTION-USING-CLASS SLOT-MISSING + MAP-DEPENDENTS UPDATE-DEPENDENT FIND-METHOD-COMBINATION + ENSURE-CLASS-USING-CLASS NO-APPLICABLE-METHOD + SLOT-DEFINITION-WRITERS + COMPUTE-APPLICABLE-METHODS-USING-CLASSES + CLASS-PRECEDENCE-LIST)) + (SETF (GET V 'COMPILER::PROCLAIMED-CLOSURE) T)) diff --git a/pcl/impl/gold-hill/gold-low.lisp b/pcl/impl/gold-hill/gold-low.lisp new file mode 100644 index 0000000..ee47b6f --- /dev/null +++ b/pcl/impl/gold-hill/gold-low.lisp @@ -0,0 +1,51 @@ +;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; +;;; +;;; + +(in-package 'pcl) + +;;; fix a bug in gcl macro-expander (or->cond->or->cond->...) +(setf (get 'cond 'lisp::macro-expander) nil) + +;;; fix another bug in gcl3_0 case macro-expander +(defun lisp::eqv (a b) (eql a b)) + +(defun printing-random-thing-internal (thing stream) + (multiple-value-bind (offaddr baseaddr) + (sys:%pointer thing) + (princ baseaddr stream) + (princ ", " stream) + (princ offaddr stream))) + +;;; +;;; This allows the compiler to compile a file with many "DEFMETHODS" +;;; in succession. +;;; +(dolist (x '(defmethod defgeneric defclass precompile-random-code-segments)) + (setf (get x 'gcl::compile-separately) t)) + diff --git a/pcl/impl/gold-hill/gold-patches.lisp b/pcl/impl/gold-hill/gold-patches.lisp new file mode 100644 index 0000000..9f6f4e7 --- /dev/null +++ b/pcl/impl/gold-hill/gold-patches.lisp @@ -0,0 +1,168 @@ +;;; -*- Mode:Lisp; Package:USER; Base:10; Syntax:Common-lisp -*- + +(in-package 'user) + +(setq c::optimize-speed 3) +(setq c::optimize-safety 0) +(setq c::optimize-space 0) + +(remprop 'macroexpand 'c::fdesc) +(remprop 'macroexpand-1 'c::fdesc) + + +;;; this is here to fix the printer so it will find the print +;;; functions on structures that have 'em. + +(in-package 'lisp) + +(defun %write-structure (struct output-stream print-vars level) + (let* ((name (svref struct 0)) + (pfun (or (let ((temp (get name 'structure-descriptor))) + (and temp (dd-print-function temp))) + (get name :print-function)))) + (declare (symbol name)) + (cond + (pfun + (funcall pfun struct output-stream level)) + ((and (pv-level print-vars) (>= level (pv-level print-vars))) + (write-char #\# output-stream)) + ((and (pv-circle print-vars) + (%write-circle struct output-stream (pv-circle print-vars)))) + (t + (let ((pv-length (pv-length print-vars)) + (pv-pretty (pv-pretty print-vars))) + (when pv-pretty + (pp-push-level pv-pretty)) + (incf level) + (write-string "#s(" output-stream) + (cond + ((and pv-length (>= 0 pv-length)) + (write-string "...")) + (t + (%write-symbol name output-stream print-vars) + (do ((i 0 (1+ i)) + (n 0) + (slots (dd-slots (get name 'structure-descriptor)) + (rest slots))) + ((endp slots)) + (declare (fixnum i n) (list slots)) + (when pv-pretty + (pp-insert-break pv-pretty *structure-keyword-slot-spec* t)) + (write-char #\space output-stream) + (when (and pv-length (>= (incf n) pv-length)) + (write-string "..." output-stream) + (return)) + (write-char #\: output-stream) + (%write-symbol-name + (symbol-name (dsd-name (first slots))) output-stream print-vars) + (when pv-pretty + (pp-insert-break pv-pretty *structure-data-slot-spec* nil)) + (write-char #\space output-stream) + (when (and pv-length (>= (incf n) pv-length)) + (write-string "..." output-stream) + (return)) + (%write-object + (svref struct (dsd-index (first slots))) + output-stream print-vars level)))) + (write-char #\) output-stream) + (when pv-pretty + (pp-pop-level pv-pretty))))))) + +(eval-when (eval) (compile '%write-structure)) + +;;; +;;; Apparently, whoever implemented the TIME macro didn't consider that +;;; someone might want to use it in a non-null lexical environment. Of +;;; course this fix is a loser since it binds a whole mess of variables +;;; around the evaluation of form, but it will do for now. +;;; +(in-package 'lisp) + +(DEFmacro TIME (FORM) + `(LET (IGNORE START FINISH S-HSEC F-HSEC S-SEC F-SEC S-MIN F-MIN VALS) + (FORMAT *trace-output* "~&Evaluating: ~A" ,form) + ;; read the start time. + (MULTIPLE-VALUE-SETQ (IGNORE IGNORE IGNORE S-MIN START) + (SYS::%SYSINT #X21 #X2C00 0 0 0)) + ;; Eval the form. + (SETQ VALS (MULTIPLE-VALUE-LIST (progn ,form))) + ;; Read the end time. + (MULTIPLE-VALUE-SETQ (IGNORE IGNORE IGNORE F-MIN FINISH) + (SYS::%SYSINT #X21 #X2C00 0 0 0)) + ;; Unpack start and end times. + (SETQ S-HSEC (LOGAND START #X0FF) + F-HSEC (LOGAND FINISH #X0FF) + S-SEC (LSH START -8) + F-SEC (LSH FINISH -8) + S-MIN (LOGAND #X0FF S-MIN) + F-MIN (LOGAND #X0FF F-MIN)) + (SETQ F-HSEC (- F-HSEC S-HSEC)) ; calc hundreths + (IF (MINUSP F-HSEC) + (SETQ F-HSEC (+ F-HSEC 100) + F-SEC (1- F-SEC))) + (SETQ F-SEC (- F-SEC S-SEC)) ; calc seconds + (IF (MINUSP F-SEC) + (SETQ F-SEC (+ F-SEC 60) + F-MIN (1- F-MIN))) + (SETQ F-MIN (- F-MIN S-MIN)) ; calc minutes + (IF (MINUSP F-MIN) (INCF F-MIN 60)) + (FORMAT *trace-output* "~&Elapsed time: ~D:~:[~D~;0~D~].~:[~D~;0~D~]~%" + F-MIN (< F-SEC 10.) F-SEC (< F-HSEC 10) F-HSEC) + (VALUES-LIST VALS))) + +;;; +;;; Patch to PROGV +;;; +(in-package sys::*compiler-package-load*) + +;;; This is a fully portable (though not very efficient) +;;; implementation of PROGV as a macro. It does its own special +;;; binding (shallow binding) by saving the original values in a +;;; list, and marking things that were originally unbound. + +(defun PORTABLE-PROGV-BIND (symbol old-vals place-holder) + (let ((val-to-save '#:value-to-save)) + `(let ((,val-to-save (if (boundp ,symbol) + (symbol-value ,symbol) + ,place-holder))) + (if ,old-vals + (rplacd (last ,old-vals) (ncons ,val-to-save)) + (setq ,old-vals (ncons ,val-to-save)))))) + +(defun PORTABLE-PROGV-UNBIND (symbol old-vals place-holder) + (let ((val-to-restore '#:value-to-restore)) + `(let ((,val-to-restore (pop ,old-vals))) + (if (eq ,val-to-restore ,place-holder) + (makunbound ,symbol) + (setf (symbol-value ,symbol) ,val-to-restore))))) + + +(deftransform PROGV PORTABLE-PROGV-TRANSFORM + (symbols-form values-form &rest body) + (let ((symbols-lst '#:symbols-list) + (values-lst '#:values-list) + (syms '#:symbols) + (vals '#:values) + (sym '#:symbol) + (old-vals '#:old-values) + (unbound-holder ''#:unbound-holder)) + `(let ((,symbols-lst ,symbols-form) + (,values-lst ,values-form) + (,old-vals nil)) + (unless (and (listp ,symbols-lst) (listp ,values-lst)) + (error "PROGV: Both symbols and values must be lists")) + (unwind-protect + (do ((,syms ,symbols-lst (cdr ,syms)) + (,vals ,values-lst (cdr ,vals)) + (,sym nil)) + ((null ,syms) (progn ,@body)) + (setq ,sym (car ,syms)) + (if (symbolp ,sym) + ,(PORTABLE-PROGV-BIND sym old-vals unbound-holder) + (error "PROGV: Object to be bound not a symbol: ~S" ,sym)) + (if ,vals + (setf (symbol-value ,sym) (first ,vals)) + (makunbound ,sym))) + (dolist (,sym ,symbols-lst) + ,(PORTABLE-PROGV-UNBIND sym old-vals unbound-holder)))))) + diff --git a/pcl/impl/hp/hp-low.lisp b/pcl/impl/hp/hp-low.lisp new file mode 100644 index 0000000..d1e807f --- /dev/null +++ b/pcl/impl/hp/hp-low.lisp @@ -0,0 +1,37 @@ +;;; -*- Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; +;;; This is the HP Common Lisp version of the file low. +;;; +;;; + +(in-package 'pcl) + +(defun printing-random-thing-internal (thing stream) + (format stream "~O" (prim:@inf thing))) + + + diff --git a/pcl/impl/ibcl/ibcl-low.lisp b/pcl/impl/ibcl/ibcl-low.lisp new file mode 100644 index 0000000..2ab3f77 --- /dev/null +++ b/pcl/impl/ibcl/ibcl-low.lisp @@ -0,0 +1,327 @@ +;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; +;;; The version of low for Kyoto Common Lisp (KCL) +(in-package 'pcl) + +;;; +;;; The reason these are here is because the KCL compiler does not allow +;;; LET to return FIXNUM values as values of (c) type int, hence the use +;;; of LOCALLY (which expands into (LET () (DECLARE ...) ...)) forces +;;; conversion of ints to objects. +;;; +(defmacro %logand (&rest args) + (reduce-variadic-to-binary 'logand args 0 t 'fixnum)) + +;(defmacro %logxor (&rest args) +; (reduce-variadic-to-binary 'logxor args 0 t 'fixnum)) + +(defmacro %+ (&rest args) + (reduce-variadic-to-binary '+ args 0 t 'fixnum)) + +;(defmacro %- (x y) +; `(the fixnum (- (the fixnum ,x) (the fixnum ,y)))) + +(defmacro %* (&rest args) + (reduce-variadic-to-binary '* args 1 t 'fixnum)) + +(defmacro %/ (x y) + `(the fixnum (/ (the fixnum ,x) (the fixnum ,y)))) + +(defmacro %1+ (x) + `(the fixnum (1+ (the fixnum ,x)))) + +(defmacro %1- (x) + `(the fixnum (1- (the fixnum ,x)))) + +(defmacro %svref (vector index) + `(svref (the simple-vector ,vector) (the fixnum ,index))) + +(defsetf %svref (vector index) (new-value) + `(setf (svref (the simple-vector ,vector) (the fixnum ,index)) + ,new-value)) + + +;;; +;;; std-instance-p +;;; +(si:define-compiler-macro std-instance-p (x) + (once-only (x) + `(and (si:structurep ,x) + (eq (si:structure-name ,x) 'std-instance)))) + +(dolist (inline '((si:structurep + ((t) compiler::boolean nil nil "type_of(#0)==t_structure") + compiler::inline-always) + (si:structure-name + ((t) t nil nil "(#0)->str.str_name") + compiler::inline-unsafe))) + (setf (get (first inline) (third inline)) (list (second inline)))) + +(setf (get 'cclosure-env 'compiler::inline-always) + (list '((t) t nil nil "(#0)->cc.cc_env"))) + +;;; +;;; turbo-closure patch. See the file kcl-mods.text for details. +;;; +#+:turbo-closure +(progn +(CLines + "object tc_cc_env_nthcdr (n,tc)" + "object n,tc; " + "{return (type_of(tc)==t_cclosure&& " + " tc->cc.cc_turbo!=NULL&& " + " type_of(n)==t_fixnum)? " + " tc->cc.cc_turbo[fix(n)]: " ; assume that n is in bounds + " Cnil; " + "} " + ) + +(defentry tc-cclosure-env-nthcdr (object object) (object tc_cc_env_nthcdr)) + +(setf (get 'tc-cclosure-env-nthcdr 'compiler::inline-unsafe) + '(((fixnum t) t nil nil "(#1)->cc.cc_turbo[#0]"))) +) + + +;;;; low level stuff to hack compiled functions and compiled closures. +;;; +;;; The primary client for this is fsc-low, but since we make some use of +;;; it here (e.g. to implement set-function-name-1) it all appears here. +;;; + +(eval-when (compile eval) + +(defmacro define-cstruct-accessor (accessor structure-type field value-type + field-type tag-name) + (let ((setf (intern (concatenate 'string "SET-" (string accessor)))) + (caccessor (format nil "pcl_get_~A_~A" structure-type field)) + (csetf (format nil "pcl_set_~A_~A" structure-type field)) + (vtype (intern (string-upcase value-type)))) + `(progn + (CLines ,(format nil "~A ~A(~A) ~%~ + object ~A; ~%~ + { return ((~A) ~A->~A.~A); } ~%~ + ~%~ + ~A ~A(~A, new) ~%~ + object ~A; ~%~ + ~A new; ~%~ + { return ((~A)(~A->~A.~A = ~Anew)); } ~%~ + " + value-type caccessor structure-type + structure-type + value-type structure-type tag-name field + value-type csetf structure-type + structure-type + value-type + value-type structure-type tag-name field field-type + )) + + (defentry ,accessor (object) (,vtype ,caccessor)) + (defentry ,setf (object ,vtype) (,vtype ,csetf)) + + + (defsetf ,accessor ,setf) + + ))) +) +;;; +;;; struct cfun { /* compiled function header */ +;;; short t, m; +;;; object cf_name; /* compiled function name */ +;;; int (*cf_self)(); /* entry address */ +;;; object cf_data; /* data the function uses */ +;;; /* for GBC */ +;;; char *cf_start; /* start address of the code */ +;;; int cf_size; /* code size */ +;;; }; +;;; add field-type tag-name +(define-cstruct-accessor cfun-name "cfun" "cf_name" "object" "(object)" "cf") +(define-cstruct-accessor cfun-self "cfun" "cf_self" "int" "(int (*)())" + "cf") +(define-cstruct-accessor cfun-data "cfun" "cf_data" "object" "(object)" "cf") +(define-cstruct-accessor cfun-start "cfun" "cf_start" "int" "(char *)" "cf") +(define-cstruct-accessor cfun-size "cfun" "cf_size" "int" "(int)" "cf") + +(CLines + "object pcl_cfunp (x) " + "object x; " + "{if(x->c.t == (int) t_cfun) " + " return (Ct); " + " else " + " return (Cnil); " + " } " + ) + +(defentry cfunp (object) (object pcl_cfunp)) + +;;; +;;; struct cclosure { /* compiled closure header */ +;;; short t, m; +;;; object cc_name; /* compiled closure name */ +;;; int (*cc_self)(); /* entry address */ +;;; object cc_env; /* environment */ +;;; object cc_data; /* data the closure uses */ +;;; /* for GBC */ +;;; char *cc_start; /* start address of the code */ +;;; int cc_size; /* code size */ +;;; }; +;;; +(define-cstruct-accessor cclosure-name "cclosure" "cc_name" "object" + "(object)" "cc") +(define-cstruct-accessor cclosure-self "cclosure" "cc_self" "int" + "(int (*)())" "cc") +(define-cstruct-accessor cclosure-data "cclosure" "cc_data" "object" + "(object)" "cc") +(define-cstruct-accessor cclosure-start "cclosure" "cc_start" "int" + "(char *)" "cc") +(define-cstruct-accessor cclosure-size "cclosure" "cc_size" "int" + "(int)" "cc") +(define-cstruct-accessor cclosure-env "cclosure" "cc_env" "object" + "(object)" "cc") + + +(CLines + "object pcl_cclosurep (x) " + "object x; " + "{if(x->c.t == (int) t_cclosure) " + " return (Ct); " + " else " + " return (Cnil); " + " } " + ) + +(defentry cclosurep (object) (object pcl_cclosurep)) + + ;; +;;;;;; Load Time Eval + ;; +;;; + +;;; This doesn't work because it looks at a global variable to see if it is +;;; in the compiler rather than looking at the macroexpansion environment. +;;; +;;; The result is that if in the process of compiling a file, we evaluate a +;;; form that has a call to load-time-eval, we will get faked into thinking +;;; that we are compiling that form. +;;; +;;; THIS NEEDS TO BE DONE RIGHT!!! +;;; +;(defmacro load-time-eval (form) +; ;; In KCL there is no compile-to-core case. For things that we are +; ;; "compiling to core" we just expand the same way as if were are +; ;; compiling a file since the form will be evaluated in just a little +; ;; bit when gazonk.o is loaded. +; (if (and (boundp 'compiler::*compiler-input*) ;Hack to see of we are +; compiler::*compiler-input*) ;in the compiler! +; `'(si:|#,| . ,form) +; `(progn ,form))) + +(defmacro load-time-eval (form) + (read-from-string (format nil "'#,~S" form))) + +(defmacro memory-block-ref (block offset) + `(svref (the simple-vector ,block) (the fixnum ,offset))) + + ;; +;;;;;; Generating CACHE numbers + ;; +;;; This needs more work to be sure it is going as fast as possible. +;;; - The calls to si:address should be open-coded. +;;; - The logand should be open coded. +;;; + +;(defmacro symbol-cache-no (symbol mask) +; (if (and (constantp symbol) +; (constantp mask)) +; `(load-time-eval (logand (ash (si:address ,symbol) -2) ,mask)) +; `(logand (ash (the fixnum (si:address ,symbol)) -2) ,mask))) + +(defmacro object-cache-no (object mask) + `(logand (the fixnum (si:address ,object)) ,mask)) + + ;; +;;;;;; printing-random-thing-internal + ;; +(defun printing-random-thing-internal (thing stream) + (format stream "~O" (si:address thing))) + + +(defun set-function-name-1 (fn new-name ignore) + (cond ((cclosurep fn) + (setf (cclosure-name fn) new-name)) + ((cfunp fn) + (setf (cfun-name fn) new-name)) + ((and (listp fn) + (eq (car fn) 'lambda-block)) + (setf (cadr fn) new-name)) + ((and (listp fn) + (eq (car fn) 'lambda)) + (setf (car fn) 'lambda-block + (cdr fn) (cons new-name (cdr fn))))) + fn) + + + + +#| +(defconstant most-positive-small-fixnum 1024) /* should be supplied */ +(defconstant most-negative-small-fixnum -1024) /* by ibuki */ + +(defmacro symbol-cache-no (symbol mask) + (if (constantp mask) + (if (and (> mask 0) + (< mask most-positive-small-fixnum)) + (if (constantp symbol) + `(load-time-eval (coffset ,symbol ,mask 2)) + `(coffset ,symbol ,mask 2)) + (if (constantp symbol) + `(load-time-eval + (logand (ash (the fixnum (si:address ,symbol)) -2) ,mask)) + `(logand (ash (the fixnum (si:address ,symbol)) -2) ,mask))) + `(logand (ash (the fixnum (si:address ,symbol)) -2) ,mask))) + + +(defmacro object-cache-no (object mask) + (if (and (constantp mask) + (> mask 0) + (< mask most-positive-small-fixnum)) + `(coffset ,object ,mask 4) + `(logand (ash (the fixnum (si:address ,object)) -4) ,mask))) + +(CLines + "object pcl_coffset (sym,mask,lshift)" + "object sym,mask,lshift;" + "{" + " return(small_fixnum(((int)sym >> fix(lshift)) & fix(mask)));" + "}" + ) + +(defentry coffset (object object object) (object pcl_coffset)) + + +|# + diff --git a/pcl/impl/ibcl/ibcl-patches.lisp b/pcl/impl/ibcl/ibcl-patches.lisp new file mode 100644 index 0000000..68e071c --- /dev/null +++ b/pcl/impl/ibcl/ibcl-patches.lisp @@ -0,0 +1,129 @@ +;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; + +(in-package 'system) + +;;; This makes DEFMACRO take &WHOLE and &ENVIRONMENT args anywhere +;;; in the lambda-list. The former allows deviation from the CL spec, +;;; but what the heck. + +(eval-when (compile) (proclaim '(optimize (safety 2) (space 3)))) + +(defvar *old-defmacro*) + +(defun new-defmacro (whole env) + (flet ((call-old-definition (new-whole) + (funcall *old-defmacro* new-whole env))) + (if (not (and (consp whole) + (consp (cdr whole)) + (consp (cddr whole)) + (consp (cdddr whole)))) + (call-old-definition whole) + (let* ((ll (caddr whole)) + (env-tail (do ((tail ll (cdr tail))) + ((not (consp tail)) nil) + (when (eq '&environment (car tail)) + (return tail))))) + (if env-tail + (call-old-definition (list* (car whole) + (cadr whole) + (append (list '&environment + (cadr env-tail)) + (ldiff ll env-tail) + (cddr env-tail)) + (cdddr whole))) + (call-old-definition whole)))))) + +(eval-when (load eval) + (unless (boundp '*old-defmacro*) + (setq *old-defmacro* (macro-function 'defmacro)) + (setf (macro-function 'defmacro) #'new-defmacro))) + +;;; +;;; setf patches +;;; + +(in-package 'system) + +(defun get-setf-method (form) + (multiple-value-bind (vars vals stores store-form access-form) + (get-setf-method-multiple-value form) + (unless (listp vars) + (error + "The temporary variables component, ~s, + of the setf-method for ~s is not a list." + vars form)) + (unless (listp vals) + (error + "The values forms component, ~s, + of the setf-method for ~s is not a list." + vals form)) + (unless (listp stores) + (error + "The store variables component, ~s, + of the setf-method for ~s is not a list." + stores form)) + (unless (= (list-length stores) 1) + (error "Multiple store-variables are not allowed.")) + (values vars vals stores store-form access-form))) + +(defun get-setf-method-multiple-value (form) + (cond ((symbolp form) + (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)) + ((get (car form) 'setf-method) + (apply (get (car form) 'setf-method) (cdr form))) + ((get (car form) 'setf-update-fn) + (let ((vars (mapcar #'(lambda (x) + (declare (ignore x)) + (gensym)) + (cdr form))) + (store (gensym))) + (values vars (cdr form) (list store) + `(,(get (car form) 'setf-update-fn) + ,@vars ,store) + (cons (car form) vars)))) + ((get (car form) 'setf-lambda) + (let* ((vars (mapcar #'(lambda (x) + (declare (ignore x)) + (gensym)) + (cdr form))) + (store (gensym)) + (l (get (car form) 'setf-lambda)) + (f `(lambda ,(car l) + (funcall #'(lambda ,(cadr l) ,@(cddr l)) + ',store)))) + (values vars (cdr form) (list store) + (apply f vars) + (cons (car form) vars)))) + ((macro-function (car form)) + (get-setf-method-multiple-value (macroexpand-1 form))) + (t + (error "Cannot expand the SETF form ~S." form)))) + diff --git a/pcl/impl/kcl/kcl-low.lisp b/pcl/impl/kcl/kcl-low.lisp new file mode 100644 index 0000000..77cb4f5 --- /dev/null +++ b/pcl/impl/kcl/kcl-low.lisp @@ -0,0 +1,438 @@ +;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; +;;; The version of low for Kyoto Common Lisp (KCL) +(in-package "SI") +(export '(%structure-name + %compiled-function-name + %set-compiled-function-name + %instance-ref + %set-instance-ref)) +(in-package 'pcl) + +(shadow 'lisp:dotimes) + +(defmacro dotimes ((var form &optional (val nil)) &rest body &environment env) + (multiple-value-bind (doc decls bod) + (extract-declarations body env) + (declare (ignore doc)) + (let ((limit (gensym)) + (label (gensym))) + `(let ((,limit ,form) + (,var 0)) + (declare (fixnum ,limit ,var)) + ,@decls + (block nil + (tagbody + ,label + (when (>= ,var ,limit) (return-from nil ,val)) + ,@bod + (setq ,var (the fixnum (1+ ,var))) + (go ,label))))))) + +(defun memq (item list) (member item list :test #'eq)) +(defun assq (item list) (assoc item list :test #'eq)) +(defun posq (item list) (position item list :test #'eq)) + +(si:define-compiler-macro memq (item list) + (let ((var (gensym))) + (once-only (item) + `(let ((,var ,list)) + (loop (unless ,var (return nil)) + (when (eq ,item (car ,var)) + (return ,var)) + (setq ,var (cdr ,var))))))) + +(si:define-compiler-macro assq (item list) + (let ((var (gensym))) + (once-only (item) + `(dolist (,var ,list nil) + (when (eq ,item (car ,var)) + (return ,var)))))) + +(si:define-compiler-macro posq (item list) + (let ((var (gensym)) (index (gensym))) + (once-only (item) + `(let ((,var ,list) (,index 0)) + (declare (fixnum ,index)) + (dolist (,var ,list nil) + (when (eq ,item ,var) + (return ,index)) + (incf ,index)))))) + +(defun printing-random-thing-internal (thing stream) + (format stream "~X" (si:address thing))) + +(defmacro %svref (vector index) + `(svref (the simple-vector ,vector) (the fixnum ,index))) + +(defsetf %svref (vector index) (new-value) + `(setf (svref (the simple-vector ,vector) (the fixnum ,index)) + ,new-value)) + + +;;; +;;; std-instance-p +;;; +#-akcl +(si:define-compiler-macro std-instance-p (x) + (once-only (x) + `(and (si:structurep ,x) + (eq (si:%structure-name ,x) 'std-instance)))) + +#+akcl +(progn + +#-new-kcl-wrapper +;; declare that std-instance-p may be computed simply, and will not change. +(si::freeze-defstruct 'std-instance) + +(si::freeze-defstruct 'method-call) +(si::freeze-defstruct 'fast-method-call) + +(defvar *pcl-funcall* + `(lambda (loc) + (compiler::wt-nl + "{object _funobj = " loc ";" + "if(Rset&&type_of(_funobj)!=t_symbol)funcall_no_event(_funobj); + else super_funcall(_funobj);}"))) + +(setq compiler::*super-funcall* *pcl-funcall*) + +(defmacro fmc-funcall (fn pv-cell next-method-call &rest args) + `(funcall ,fn ,pv-cell ,next-method-call ,@args)) + +) + +;;; +;;; turbo-closure patch. See the file kcl-mods.text for details. +;;; +#-turbo-closure-env-size +(clines " +object cclosure_env_nthcdr (n,cc) +int n; object cc; +{ object env; + if(n<0)return Cnil; + if(type_of(cc)!=t_cclosure)return Cnil; + env=cc->cc.cc_env; + while(n-->0) + {if(type_of(env)!=t_cons)return Cnil; + env=env->c.c_cdr;} + return env; +}") + +#+turbo-closure-env-size +(clines " +object cclosure_env_nthcdr (n,cc) +int n; object cc; +{ object env,*turbo; + if(n<0)return Cnil; + if(type_of(cc)!=t_cclosure)return Cnil; + if((turbo=cc->cc.cc_turbo)==NULL) + {env=cc->cc.cc_env; + while(n-->0) + {if(type_of(env)!=t_cons)return Cnil; + env=env->c.c_cdr;} + return env;} + else + {if(n>=fix(*(turbo-1)))return Cnil; + return turbo[n];} +}") + +;; This is the completely safe version. +(defentry cclosure-env-nthcdr (int object) (object cclosure_env_nthcdr)) +;; This is the unsafe but fast version. +(defentry %cclosure-env-nthcdr (int object) (object cclosure_env_nthcdr)) + +;;; #+akcl means this is an AKCL newer than 5/11/89 (structures changed) +(eval-when (compile load eval) + +#+new-kcl-wrapper +(progn + +(defun instance-ref (slots index) + (si:structure-ref1 slots index)) + +(defun set-instance-ref (slots index value) + (si:structure-set1 slots index value)) + +(defsetf instance-ref set-instance-ref) +(defsetf %instance-ref %set-instance-ref) +) + +(defsetf structure-def set-structure-def) + +;;((name args-type result-type side-effect-p new-object-p c-expression) ...) +(defparameter *kcl-function-inlines* + '((%fboundp (t) compiler::boolean nil nil "(#0)->s.s_gfdef!=OBJNULL") + (%symbol-function (t) t nil nil "(#0)->s.s_gfdef") + #-akcl (si:structurep (t) compiler::boolean nil nil "type_of(#0)==t_structure") + #-akcl (si:%structure-name (t) t nil nil "(#0)->str.str_name") + #+akcl (si:%structure-name (t) t nil nil "(#0)->str.str_def->str.str_self[0]") + #+new-kcl-wrapper + (si:%instance-ref (t t) t nil nil "(#0)->str.str_self[fix(#1)]") + #+new-kcl-wrapper + (si:%set-instance-ref (t t t) t t nil "(#0)->str.str_self[fix(#1)]=(#2)") + (si:%compiled-function-name (t) t nil nil "(#0)->cf.cf_name") + (si:%set-compiled-function-name (t t) t t nil "((#0)->cf.cf_name)=(#1)") + (cclosurep (t) compiler::boolean nil nil "type_of(#0)==t_cclosure") + #+akcl (sfun-p (t) compiler::boolean nil nil "type_of(#0)==t_sfun") + (%cclosure-env (t) t nil nil "(#0)->cc.cc_env") + (%set-cclosure-env (t t) t t nil "((#0)->cc.cc_env)=(#1)") + #+turbo-closure + (%cclosure-env-nthcdr (fixnum t) t nil nil "(#1)->cc.cc_turbo[#0]") + + (logxor (fixnum fixnum) fixnum nil nil "((#0) ^ (#1))"))) + +(defun make-function-inline (inline) + (setf (get (car inline) 'compiler::inline-always) + (list (if (fboundp 'compiler::flags) + (let ((opt (cdr inline))) + (list (first opt) (second opt) + (logior (if (fourth opt) 1 0) ; allocates-new-storage + (if (third opt) 2 0) ; side-effect + (if nil 4 0) ; constantp + (if (eq (car inline) 'logxor) + 8 0)) ;result type from args + (fifth opt))) + (cdr inline))))) + +(defmacro define-inlines () + `(progn + ,@(mapcan #'(lambda (inline) + (let* ((*package* *the-pcl-package*) + (name (intern (format nil "~S inline" (car inline)))) + (vars (mapcar #'(lambda (type) + (declare (ignore type)) + (gensym)) + (cadr inline)))) + `((make-function-inline ',(cons name (cdr inline))) + ,@(when (or (every #'(lambda (type) (eq type 't)) + (cadr inline)) + (char= #\% (aref (symbol-name (car inline)) 0))) + `((defun ,(car inline) ,vars + ,@(mapcan #'(lambda (var var-type) + (unless (eq var-type 't) + `((declare (type ,var-type ,var))))) + vars (cadr inline)) + (,name ,@vars)) + (make-function-inline ',inline)))))) + *kcl-function-inlines*))) + +(define-inlines) +) + +(defsetf si:%compiled-function-name si:%set-compiled-function-name) +(defsetf %cclosure-env %set-cclosure-env) + +(defun set-function-name-1 (fn new-name ignore) + (declare (ignore ignore)) + (cond ((compiled-function-p fn) + (si::turbo-closure fn) + ;;(when (symbolp new-name) (proclaim-defgeneric new-name nil)) + (setf (si:%compiled-function-name fn) new-name)) + ((and (listp fn) + (eq (car fn) 'lambda-block)) + (setf (cadr fn) new-name)) + ((and (listp fn) + (eq (car fn) 'lambda)) + (setf (car fn) 'lambda-block + (cdr fn) (cons new-name (cdr fn))))) + fn) + + +#+akcl (clines "#define AKCL206") + +(clines " +#ifdef AKCL206 +use_fast_links(); +#endif + +object set_cclosure (result_cc,value_cc,available_size) + object result_cc,value_cc; int available_size; +{ + object result_env_tail,value_env_tail; int i; +#ifdef AKCL206 + /* If we are currently using fast linking, */ + /* make sure to remove the link for result_cc. */ + use_fast_links(3,Cnil,result_cc); +#endif + result_env_tail=result_cc->cc.cc_env; + value_env_tail=value_cc->cc.cc_env; + for(i=available_size; + result_env_tail!=Cnil && i>0; + result_env_tail=CMPcdr(result_env_tail), value_env_tail=CMPcdr(value_env_tail)) + CMPcar(result_env_tail)=CMPcar(value_env_tail), i--; + result_cc->cc.cc_self=value_cc->cc.cc_self; + result_cc->cc.cc_data=value_cc->cc.cc_data; +#ifndef AKCL206 + result_cc->cc.cc_start=value_cc->cc.cc_start; + result_cc->cc.cc_size=value_cc->cc.cc_size; +#endif + return result_cc; +}") + +(defentry %set-cclosure (object object int) (object set_cclosure)) + + +(defun structure-functions-exist-p () + t) + +(si:define-compiler-macro structure-instance-p (x) + (once-only (x) + `(and (si:structurep ,x) + (not (eq (si:%structure-name ,x) 'std-instance))))) + +(defun structure-type (x) + (and (si:structurep x) + (si:%structure-name x))) + +(si:define-compiler-macro structure-type (x) + (once-only (x) + `(and (si:structurep ,x) + (si:%structure-name ,x)))) + +(defun structure-type-p (type) + (or (not (null (gethash type *structure-table*))) + (let (#+akcl(s-data nil)) + (and (symbolp type) + #+akcl (setq s-data (get type 'si::s-data)) + #-akcl (get type 'si::is-a-structure) + (null #+akcl (si::s-data-type s-data) + #-akcl (get type 'si::structure-type)))))) + +(defun structure-type-included-type-name (type) + (or (car (gethash type *structure-table*)) + #+akcl (let ((includes (si::s-data-includes (get type 'si::s-data)))) + (when includes + (si::s-data-name includes))) + #-akcl (get type 'si::structure-include))) + +(defun structure-type-internal-slotds (type) + #+akcl (si::s-data-slot-descriptions (get type 'si::s-data)) + #-akcl (get type 'si::structure-slot-descriptions)) + +(defun structure-type-slot-description-list (type) + (or (cdr (gethash type *structure-table*)) + (mapcan #'(lambda (slotd) + #-new-kcl-wrapper + (when (and slotd (car slotd)) + (let ((offset (fifth slotd))) + (let ((reader #'(lambda (x) + #+akcl (si:structure-ref1 x offset) + #-akcl (si:structure-ref x type offset))) + (writer #'(lambda (v x) + (si:structure-set x type offset v)))) + #+turbo-closure (si:turbo-closure reader) + #+turbo-closure (si:turbo-closure writer) + (let* ((reader-sym + (let ((*package* *the-pcl-package*)) + (intern (format nil "~s SLOT~D" type offset)))) + (writer-sym (get-setf-function-name reader-sym)) + (slot-name (first slotd)) + (read-only-p (fourth slotd))) + (setf (symbol-function reader-sym) reader) + (setf (symbol-function writer-sym) writer) + (do-standard-defsetf-1 reader-sym) + (list (list slot-name + reader-sym + reader + (and (not read-only-p) writer))))))) + #+new-kcl-wrapper + (list slotd)) + (let ((slotds (structure-type-internal-slotds type)) + (inc (structure-type-included-type-name type))) + (if inc + (nthcdr (length (structure-type-internal-slotds inc)) + slotds) + slotds))))) + +#+new-kcl-wrapper +(defun si::slot-reader-function (slot) + (let ((offset (si::slot-offset slot))) + (si:turbo-closure #'(lambda (x) + (si::structure-ref1 x offset))))) + +#+new-kcl-wrapper +(defun si::slot-writer-function (slot) + (let ((offset (si::slot-offset slot))) + (si:turbo-closure #'(lambda (x) + (si::structure-set1 x offset))))) + +(mapcar #'(lambda (fname value) + (setf (symbol-function fname) (symbol-function value))) + '(structure-slotd-name + structure-slotd-accessor-symbol + structure-slotd-reader-function + structure-slotd-writer-function + structure-slotd-type + structure-slotd-init-form) + #-new-kcl-wrapper + '(first second third fourth function-returning-nil function-returning-nil) + #+new-kcl-wrapper + '(si::slot-name si::slot-accessor-name + si::slot-reader-function si::slot-writer-function + si::slot-type si::slot-default-init)) + + +;; Construct files sys-proclaim.lisp and sys-package.lisp +;; The file sys-package.lisp must be loaded first, since the +;; package sys-proclaim.lisp will refer to symbols and they must +;; be in the right packages. sys-proclaim.lisp contains function +;; declarations and declarations that certain things are closures. + +(defun renew-sys-files() + ;; packages: + (compiler::get-packages "sys-package.lisp") + (with-open-file (st "sys-package.lisp" + :direction :output + :if-exists :append) + (format st "(in-package 'SI) +(export '(%structure-name + %compiled-function-name + %set-compiled-function-name)) +(in-package 'pcl) +")) + + ;; proclaims + (compiler::make-all-proclaims "*.fn") + (let ((*package* (find-package 'user))) + (with-open-file (st "sys-proclaim.lisp" + :direction :output + :if-exists :append) + ;;(format st "~%(IN-PACKAGE \"PCL\")~%") + (print + `(dolist (v ', + + (sloop::sloop for v in-package "PCL" + when (get v 'compiler::proclaimed-closure) + collect v)) + (setf (get v 'compiler::proclaimed-closure) t)) + st) + (format st "~%") + ))) + + diff --git a/pcl/impl/kcl/kcl-mods.text b/pcl/impl/kcl/kcl-mods.text new file mode 100644 index 0000000..741e41a --- /dev/null +++ b/pcl/impl/kcl/kcl-mods.text @@ -0,0 +1,224 @@ +If you have akcl version 604 or newer, do not make these patches. + + +(1) Turbo closure patch + +To make the turbo closure stuff work, make the following changes to KCL. +These changes can also work for an IBCL. + +The three patches in this file add two features (reflected in the +value of *features*) to your KCL or IBCL: + a feature named :TURBO-CLOSURE which increases the speed of the + code generated by FUNCALLABLE-INSTANCE-DATA-1 + (previous versions of the file kcl-mods.text had this feature only), +and + a feature named :TURBO-CLOSURE-ENV-SIZE which increases the speed + of the function FUNCALLABLE-INSTANCE-P. + +(This file comprises two features rather than just one to allow the +PCL system to be work in KCL systems that do not have this patch, +or that have the old version of this patch.) + + +The first of these patches changes the turbo_closure function to +store the size of the environment in the turbo structure. + +The second of patch fixes a garbage-collector bug in which +the turbo structure was sometimes ignored, AND also adapts +the garbage-collector to conform to the change made in the +first patch. The bug has been fixed in newer versions of +AKCL, but it is still necessary to apply this patch, if the +first and third patches are applied. + +The third change pushes :turbo-closure and :turbo-closure-env-size +on the *features* list so that PCL will know that turbo closures +are enabled. + + +Note that these changes have to be made before PCL is compiled, and a +PCL which is compiled in a KCL/IBCL with these changes can only be run +in a KCL/IBCL with these changes. + +(1-1) edit the function turbo_closure in the file kcl/c/cfun.c, +change the lines +---------- +turbo_closure(fun) +object fun; +{ + object l; + int n; + + for (n = 0, l = fun->cc.cc_env; !endp(l); n++, l = l->c.c_cdr) + ; + fun->cc.cc_turbo = (object *)alloc_contblock(n*sizeof(object)); + for (n = 0, l = fun->cc.cc_env; !endp(l); n++, l = l->c.c_cdr) + fun->cc.cc_turbo[n] = l; +} +---------- +to +---------- +turbo_closure(fun) +object fun; +{ + object l,*block; + int n; + + if(fun->cc.cc_turbo==NULL) + {for (n = 0, l = fun->cc.cc_env; !endp(l); n++, l = l->c.c_cdr); + block=(object *)alloc_contblock((1+n)*sizeof(object)); + *block=make_fixnum(n); + fun->cc.cc_turbo = block+1; /* equivalent to &block[1] */ + for (n = 0, l = fun->cc.cc_env; !endp(l); n++, l = l->c.c_cdr) + fun->cc.cc_turbo[n] = l;} +} +---------- + + +(1-2) edit the function mark_object in the file kcl/c/gbc.c, +Find the lines following case t_cclosure: in mark_object. +If they look like the ones between the lines marked (KCL), +make the first change, but if the look like the lines marked +(AKCL), apply the second change instead, and if the file +sgbc.c exists, apply the third change to it. +(1-2-1) Change: +(KCL)---------- + case t_cclosure: + mark_object(x->cc.cc_name); + mark_object(x->cc.cc_env); + mark_object(x->cc.cc_data); + if (x->cc.cc_start == NULL) + break; + if (what_to_collect == t_contiguous) { + if (get_mark_bit((int *)(x->cc.cc_start))) + break; + mark_contblock(x->cc.cc_start, x->cc.cc_size); + if (x->cc.cc_turbo != NULL) { + for (i = 0, y = x->cc.cc_env; + type_of(y) == t_cons; + i++, y = y->c.c_cdr); + mark_contblock((char *)(x->cc.cc_turbo), + i*sizeof(object)); + } + } + break; +(KCL)---------- +to +(KCL new)---------- + case t_cclosure: + mark_object(x->cc.cc_name); + mark_object(x->cc.cc_env); + mark_object(x->cc.cc_data); + if (what_to_collect == t_contiguous) + if (x->cc.cc_turbo != NULL) { + mark_contblock((char *)(x->cc.cc_turbo-1), + (1+fix(*(x->cc.cc_turbo-1)))*sizeof(object)); + } + if (x->cc.cc_start == NULL) + break; + if (what_to_collect == t_contiguous) { + if (get_mark_bit((int *)(x->cc.cc_start))) + break; + mark_contblock(x->cc.cc_start, x->cc.cc_size); + } + break; +(KCL new)---------- +(1-2-2) Or, Change: +(AKCL)---------- + case t_cclosure: + mark_object(x->cc.cc_name); + mark_object(x->cc.cc_env); + mark_object(x->cc.cc_data); + if (what_to_collect == t_contiguous) { + if (x->cc.cc_turbo != NULL) { + for (i = 0, y = x->cc.cc_env; + type_of(y) == t_cons; + i++, y = y->c.c_cdr); + mark_contblock((char *)(x->cc.cc_turbo), + i*sizeof(object)); + } + } + break; +(AKCL)---------- +To: +(AKCL new)---------- + case t_cclosure: + mark_object(x->cc.cc_name); + mark_object(x->cc.cc_env); + mark_object(x->cc.cc_data); + if (what_to_collect == t_contiguous) { + if (x->cc.cc_turbo != NULL) + mark_contblock((char *)(x->cc.cc_turbo-1), + (1+fix(*(x->cc.cc_turbo-1)))*sizeof(object)); + } + break; +(AKCL new)---------- +(1-2-3) In sgbc.c (if it exists), Change: +(AKCL)---------- + case t_cclosure: + sgc_mark_object(x->cc.cc_name); + sgc_mark_object(x->cc.cc_env); + sgc_mark_object(x->cc.cc_data); + if (what_to_collect == t_contiguous) { + if (x->cc.cc_turbo != NULL) { + for (i = 0, y = x->cc.cc_env; + type_of(y) == t_cons; + i++, y = y->c.c_cdr); + mark_contblock((char *)(x->cc.cc_turbo), + i*sizeof(object)); + } + } + break; +(AKCL)---------- +To: +(AKCL new)---------- + case t_cclosure: + sgc_mark_object(x->cc.cc_name); + sgc_mark_object(x->cc.cc_env); + sgc_mark_object(x->cc.cc_data); + if (what_to_collect == t_contiguous) { + if (x->cc.cc_turbo != NULL) + mark_contblock((char *)(x->cc.cc_turbo-1), + (1+fix(*(x->cc.cc_turbo-1)))*sizeof(object)); + } + break; +(AKCL new)---------- + + +(1-3) edit the function init_main in the file kcl/c/main.c, +change the lines where setting the value of *features* to add a :turbo-closure +and a :turbo-closure-env-size into the list in your KCL/IBCL. + +For example, in Sun4(SunOS) version of IBCL +changing the lines: +---------- + make_special("*FEATURES*", + make_cons(make_ordinary("SUN4"), + make_cons(make_ordinary("SPARC"), + make_cons(make_ordinary("IEEE-FLOATING-POINT"), + make_cons(make_ordinary("UNIX"), + make_cons(make_ordinary("BSD"), + make_cons(make_ordinary("COMMON"), + make_cons(make_ordinary("IBCL"), Cnil)))))))); +---------- +to +---------- + make_special("*FEATURES*", + make_cons(make_ordinary("SUN4"), + make_cons(make_ordinary("SPARC"), + make_cons(make_ordinary("IEEE-FLOATING-POINT"), + make_cons(make_ordinary("UNIX"), + make_cons(make_ordinary("BSD"), + make_cons(make_ordinary("COMMON"), + make_cons(make_ordinary("IBCL"), + make_cons(make_keyword("TURBO-CLOSURE"), + make_cons(make_keyword("TURBO-CLOSURE-ENV-SIZE"), + Cnil)))))))))); +---------- +But, if the C macro ADD_FEATURE is defined at the end of main.c, +use it instead. +Insert the lines: + ADD_FEATURE("TURBO-CLOSURE"); + ADD_FEATURE("TURBO-CLOSURE-ENV-SIZE"); +After the line: + ADD_FEATURE("AKCL"); + diff --git a/pcl/impl/kcl/kcl-notes.text b/pcl/impl/kcl/kcl-notes.text new file mode 100644 index 0000000..fc8a683 --- /dev/null +++ b/pcl/impl/kcl/kcl-notes.text @@ -0,0 +1,39 @@ + +Some notes on using "5/1/90 May Day PCL (REV 4b)" with KCL and AKCL. + +1. KCL will try to load the PCL file "init" when it starts up, + if you rename the files as is mentioned in defsys.lisp and the + currect directory is the one containing PCL. I suggest that + you do not rename any file except maybe "defsys", and also + that you change the (files-renamed-p t) to (files-renamed-p nil) + in defsys.lisp. + +2. Do not comment out the file kcl-patches.lisp, even if you are + using AKCL. It contins a patch to make compiler messages more + informative for AKCL, and also sets compiler::*compile-ordinaries* + to T, so that methods will get compiled. + +3. While fixup.lisp compiles, there will be a pause, because + KCL's compiler is not reentrant, and some uncompiled + code is run. If you want, you can change the form + (fix-early-generic-functions) to (fix-early-generic-functions t) + in fixup.lisp to see what is happening. + +4. (If you are using AKCL 605 or newer, skip this step.) + If you want, you can apply the changes in kcl-mods.text + to your KCL or AKCL to make PCL run faster. The file kcl-mods.text + is different from what it was in versions of PCL earlier than + May Day PCL. If you do not make these changes, or if you made + the old changes, things will still work. + +5. If you are using AKCL, and you previously used the kcl-low.lisp + file from rascal.ics.utexas.edu, you should not use it this time. + The kcl-low.lisp that comes with May Day PCL works fine. (If you + insist on using an old version of kcl-low.lisp, you will need to + use an old version of the KCL part of fin.lisp as well: this is + what is done for IBCL, by the way.) + +6. I recommend that you use AKCL version 457 or newer rather than using + KCL or an older version of AKCL, because there are some bugs in KCL + that cause problems for May Day PCL. + diff --git a/pcl/impl/kcl/kcl-patches.lisp b/pcl/impl/kcl/kcl-patches.lisp new file mode 100644 index 0000000..c051d9b --- /dev/null +++ b/pcl/impl/kcl/kcl-patches.lisp @@ -0,0 +1,362 @@ +;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; + + +(in-package "COMPILER") + +#+akcl +(eval-when (compile load eval) + +(when (<= system::*akcl-version* 609) + (pushnew :pre_akcl_610 *features*)) + +(if (and (boundp 'si::*akcl-version*) + (>= si::*akcl-version* 604)) + (progn + (pushnew :turbo-closure *features*) + (pushnew :turbo-closure-env-size *features*)) + (when (fboundp 'si::allocate-growth) + (pushnew :turbo-closure *features*))) + +;; patch around compiler bug. +(when (<= si::*akcl-version* 609) + (let ((vcs "static int Vcs; +")) + (unless (search vcs compiler::*cmpinclude-string*) + (setq compiler::*cmpinclude-string* + (concatenate 'string vcs compiler::*cmpinclude-string*))))) + +(let ((rset "int Rset; +")) + (unless (search rset compiler::*cmpinclude-string*) + (setq compiler::*cmpinclude-string* + (concatenate 'string rset compiler::*cmpinclude-string*)))) + +(when (get 'si::basic-wrapper 'si::s-data) + (pushnew :new-kcl-wrapper *features*) + (pushnew :structure-wrapper *features*)) + +) + + +#+akcl +(progn + +(unless (fboundp 'real-c2lambda-expr-with-key) + (setf (symbol-function 'real-c2lambda-expr-with-key) + (symbol-function 'c2lambda-expr-with-key))) + +(defun c2lambda-expr-with-key (lambda-list body) + (declare (special *sup-used*)) + (setq *sup-used* t) + (real-c2lambda-expr-with-key lambda-list body)) + + +;There is a bug in the implementation of *print-circle* that +;causes some akcl debugging commands (including :bt and :bl) +;to cause the following error when PCL is being used: +;Unrecoverable error: value stack overflow. + +;When a CLOS object is printed, travel_push_object ends up +;traversing almost the whole class structure, thereby overflowing +;the value-stack. + +;from lsp/debug.lsp. +;*print-circle* is badly implemented in kcl. +;it has two separate problems that should be fixed: +; 1. it traverses the printed object putting all objects found +; on the value stack (rather than in a hash table or some +; other structure; this is a problem because the size of the value stack +; is fixed, and a potentially unbounded number of objects +; need to be traversed), and +; 2. it blindly traverses all slots of any +; kind of structure including std-object structures. +; This is safe, but not always necessary, and is very time-consuming +; for CLOS objects (because it will always traverse every class). + +;For now, avoid using *print-circle* T when it will cause problems. + +(eval-when (compile eval) +(defmacro si::f (op &rest args) + `(the fixnum (,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) ))) + +(defmacro si::fb (op &rest args) + `(,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) )) +) + +(defun si::display-env (n env) + (do ((v (reverse env) (cdr v))) + ((or (not (consp v)) (si::fb > (fill-pointer si::*display-string*) n))) + (or (and (consp (car v)) + (listp (cdar v))) + (return)) + (let ((*print-circle* (can-use-print-circle-p (cadar v)))) + (format si::*display-string* "~s=~s~@[,~]" (caar v) (cadar v) (cdr v))))) + +(defun si::display-compiled-env ( plength ihs &aux + (base (si::ihs-vs ihs)) + (end (min (si::ihs-vs (1+ ihs)) (si::vs-top)))) + (format si::*display-string* "") + (do ((i base ) + (v (get (si::ihs-fname ihs) 'si::debug) (cdr v))) + ((or (si::fb >= i end)(si::fb > (fill-pointer si::*display-string*) plength))) + (let ((*print-circle* (can-use-print-circle-p (si::vs i)))) + (format si::*display-string* "~a~@[~d~]=~s~@[,~]" + (or (car v) 'si::loc) (if (not (car v)) (si::f - i base)) (si::vs i) + (si::fb < (setq i (si::f + i 1)) end))))) + +(clines "#define objnull_p(x) ((x==OBJNULL)?Ct:Cnil)") +(defentry objnull-p (object) (object "objnull_p")) + +(defun can-use-print-circle-p (x) + (catch 'can-use-print-circle-p + (can-use-print-circle-p1 x nil))) + +(defun can-use-print-circle-p1 (x so-far) + (and (not (objnull-p x)) ; because of deficiencies in the compiler, maybe? + (if (member x so-far) + (throw 'can-use-print-circle-p t) + (let ((so-far (cons x so-far))) + (flet ((can-use-print-circle-p (x) + (can-use-print-circle-p1 x so-far))) + (typecase x + (vector (or (not (eq 't (array-element-type x))) + (every #'can-use-print-circle-p x))) + (cons (and (can-use-print-circle-p (car x)) + (can-use-print-circle-p (cdr x)))) + (array (or (not (eq 't (array-element-type x))) + (let* ((rank (array-rank x)) + (dimensions (make-list rank))) + (dotimes (i rank) + (setf (nth i dimensions) (array-dimension x i))) + (or (member 0 dimensions) + (do ((cursor (make-list rank :initial-element 0))) + (nil) + (declare (:dynamic-extent cursor)) + (unless (can-use-print-circle-p + (apply #'aref x cursor)) + (return nil)) + (when (si::increment-cursor cursor dimensions) + (return t))))))) + (t (or (not (si:structurep x)) + (let* ((def (si:structure-def x)) + (name (si::s-data-name def)) + (len (si::s-data-length def)) + (pfun (si::s-data-print-function def))) + (and (null pfun) + (dotimes (i len t) + (unless (can-use-print-circle-p + (si:structure-ref x name i)) + (return nil))))))))))))) + +(defun si::apply-display-fun (display-fun n lis) + (let ((*print-length* si::*debug-print-level*) + (*print-level* si::*debug-print-level*) + (*print-pretty* nil) + (*PRINT-CASE* :downcase) + (*print-circle* nil) + ) + (setf (fill-pointer si::*display-string*) 0) + (format si::*display-string* "{") + (funcall display-fun n lis) + (when (si::fb > (fill-pointer si::*display-string*) n) + (setf (fill-pointer si::*display-string*) n) + (format si::*display-string* "...")) + + (format si::*display-string* "}") + ) + si::*display-string* + ) + +;The old definition of this had a bug: +;sometimes it returned without calling mv-values. +(defun si::next-stack-frame (ihs &aux line-info li i k na) + (cond ((si::fb < ihs si::*ihs-base*) + (si::mv-values nil nil nil nil nil)) + ((let (fun) + ;; next lower visible ihs + (si::mv-setq (fun i) (si::get-next-visible-fun ihs)) + (setq na fun) + (cond ((and (setq line-info (get fun 'si::line-info)) + (do ((j (si::f + ihs 1) (si::f - j 1)) + (form )) + ((<= j i) nil) + (setq form (si::ihs-fun j)) + (cond ((setq li (si::get-line-of-form form line-info)) + (return-from si::next-stack-frame + (si::mv-values + i fun li + ;; filename + (car (aref line-info 0)) + ;;environment + (list (si::vs (setq k (si::ihs-vs j))) + (si::vs (1+ k)) + (si::vs (+ k 2))))))))))))) + ((and (not (special-form-p na)) + (not (get na 'si::dbl-invisible)) + (fboundp na)) + (si::mv-values i na nil nil + (if (si::ihs-not-interpreted-env i) + nil + (let ((i (si::ihs-vs i))) + (list (si::vs i) (si::vs (1+ i)) (si::vs (si::f + i 2))))))) + (t (si::mv-values nil nil nil nil nil)))) +) + +#+pre_akcl_610 +(progn + +;(proclaim '(optimize (safety 0) (speed 3) (space 1))) + +;Not needed... make-top-level-form generates defuns now. +;(setq compiler::*compile-ordinaries* t) + +(eval-when (compile load eval) +(unless (fboundp 'original-co1typep) + (setf (symbol-function 'original-co1typep) #'co1typep)) +) + +(defun new-co1typep (f args) + (or (original-co1typep f args) + (let ((x (car args)) + (type (cadr args))) + (when (constantp type) + (let ((ntype (si::normalize-type (eval type)))) + (when (and (eq (car ntype) 'satisfies) + (cadr ntype) + (symbolp (cadr ntype)) + (symbol-package (cadr ntype))) + (c1expr `(the boolean (,(cadr ntype) ,x))))))))) + +(setf (symbol-function 'co1typep) #'new-co1typep) + +) + +#-(or akcl xkcl) +(progn +(in-package 'system) + +;;; This makes DEFMACRO take &WHOLE and &ENVIRONMENT args anywhere +;;; in the lambda-list. The former allows deviation from the CL spec, +;;; but what the heck. + +(eval-when (compile) (proclaim '(optimize (safety 2) (space 3)))) + +(defvar *old-defmacro*) + +(defun new-defmacro (whole env) + (flet ((call-old-definition (new-whole) + (funcall *old-defmacro* new-whole env))) + (if (not (and (consp whole) + (consp (cdr whole)) + (consp (cddr whole)) + (consp (cdddr whole)))) + (call-old-definition whole) + (let* ((ll (caddr whole)) + (env-tail (do ((tail ll (cdr tail))) + ((not (consp tail)) nil) + (when (eq '&environment (car tail)) + (return tail))))) + (if env-tail + (call-old-definition (list* (car whole) + (cadr whole) + (append (list '&environment + (cadr env-tail)) + (ldiff ll env-tail) + (cddr env-tail)) + (cdddr whole))) + (call-old-definition whole)))))) + +(eval-when (load eval) + (unless (boundp '*old-defmacro*) + (setq *old-defmacro* (macro-function 'defmacro)) + (setf (macro-function 'defmacro) #'new-defmacro))) + +;;; +;;; setf patches +;;; + +(defun get-setf-method (form) + (multiple-value-bind (vars vals stores store-form access-form) + (get-setf-method-multiple-value form) + (unless (listp vars) + (error + "The temporary variables component, ~s, + of the setf-method for ~s is not a list." + vars form)) + (unless (listp vals) + (error + "The values forms component, ~s, + of the setf-method for ~s is not a list." + vals form)) + (unless (listp stores) + (error + "The store variables component, ~s, + of the setf-method for ~s is not a list." + stores form)) + (unless (= (list-length stores) 1) + (error "Multiple store-variables are not allowed.")) + (values vars vals stores store-form access-form))) + +(defun get-setf-method-multiple-value (form) + (cond ((symbolp form) + (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)) + ((get (car form) 'setf-method) + (apply (get (car form) 'setf-method) (cdr form))) + ((get (car form) 'setf-update-fn) + (let ((vars (mapcar #'(lambda (x) + (declare (ignore x)) + (gensym)) + (cdr form))) + (store (gensym))) + (values vars (cdr form) (list store) + `(,(get (car form) 'setf-update-fn) + ,@vars ,store) + (cons (car form) vars)))) + ((get (car form) 'setf-lambda) + (let* ((vars (mapcar #'(lambda (x) + (declare (ignore x)) + (gensym)) + (cdr form))) + (store (gensym)) + (l (get (car form) 'setf-lambda)) + (f `(lambda ,(car l) + (funcall #'(lambda ,(cadr l) ,@(cddr l)) + ',store)))) + (values vars (cdr form) (list store) + (apply f vars) + (cons (car form) vars)))) + ((macro-function (car form)) + (get-setf-method-multiple-value (macroexpand-1 form))) + (t + (error "Cannot expand the SETF form ~S." form)))) + +) + diff --git a/pcl/impl/kcl/makefile.akcl b/pcl/impl/kcl/makefile.akcl new file mode 100644 index 0000000..057a3f9 --- /dev/null +++ b/pcl/impl/kcl/makefile.akcl @@ -0,0 +1,32 @@ +# makefile for making pcl -- W. Schelter. + +# Directions: +# make -f makefile.akcl compile +# make -f makefile.akcl saved_pcl + +SHELL=/bin/sh + +LISP=akcl + + +SETUP='(load "pkg.lisp")(load "defsys.lisp")' \ + '(setq pcl::*default-pathname-extensions* (cons "lisp" "o"))' \ + '(setq pcl::*pathname-extensions* (cons "lisp" "o"))' \ + '(load "sys-proclaim.lisp")(compiler::emit-fn t)' + +compile: + echo ${SETUP} '(pcl::compile-pcl)' | ${LISP} + +saved_pcl: + echo ${SETUP} '(pcl::load-pcl)(si::save-system "saved_pcl")' | ${LISP} + + +# remake the sys-package.lisp and sys-proclaim.lisp files +# Those files may be empty on a first build. +remake-sys-files: + echo ${SETUP} '(pcl::load-pcl)(in-package "PCL")(renew-sys-files)' | ${LISP} + cp sys-proclaim.lisp xxx + cat xxx | sed -e "s/COMPILER::CMP-ANON//g" > sys-proclaim.lisp + +clean: + rm -f *.o diff --git a/pcl/impl/kcl/misc-kcl-patches.text b/pcl/impl/kcl/misc-kcl-patches.text new file mode 100644 index 0000000..54bb9c7 --- /dev/null +++ b/pcl/impl/kcl/misc-kcl-patches.text @@ -0,0 +1,340 @@ +c/cmpaux.c +*** c/cmpaux.c Mon Jul 6 00:14:55 1992 +--- ../akcl-1-615/c/cmpaux.c Thu Jun 18 20:01:07 1992 +*************** +*** 229,239 **** + if (leng > 0 && leng < x->st.st_dim && x->st.st_self[leng]==0) + return x->st.st_self; + if (x->st.st_dim == leng + && ( leng % sizeof(object)) + ) +! { x->st.st_self[leng] = 0; + return x->st.st_self; + } + else + {char *res=malloc(leng+1); + bcopy(x->st.st_self,res,leng); +--- 229,240 ---- + if (leng > 0 && leng < x->st.st_dim && x->st.st_self[leng]==0) + return x->st.st_self; + if (x->st.st_dim == leng + && ( leng % sizeof(object)) + ) +! { if(x->st.st_self[leng] != 0) +! x->st.st_self[leng] = 0; + return x->st.st_self; + } + else + {char *res=malloc(leng+1); + bcopy(x->st.st_self,res,leng); +c/main.c +*** c/main.c Mon Jul 6 00:14:59 1992 +--- ../akcl-1-615/c/main.c Fri Jul 3 02:19:37 1992 +*************** +*** 611,621 **** + {catch_fatal = -1; + if (sgc_enabled) + { sgc_quit();} + if (sgc_enabled==0) + { install_segmentation_catcher() ;} +! FEerror("Caught fatal error [memory may be damaged]"); } + printf("\nUnrecoverable error: %s.\n", s); + fflush(stdout); + #ifdef UNIX + abort(); + #endif +--- 611,621 ---- + {catch_fatal = -1; + if (sgc_enabled) + { sgc_quit();} + if (sgc_enabled==0) + { install_segmentation_catcher() ;} +! FEerror("Caught fatal error [memory may be damaged] ~A",1,make_simple_string(s)); } + printf("\nUnrecoverable error: %s.\n", s); + fflush(stdout); + #ifdef UNIX + abort(); + #endif +*************** +*** 853,872 **** + + siLsave_system() + { + int i; + +- #ifdef HAVE_YP_UNBIND +- extern object truename(),namestring(); + check_arg(1); +! /* prevent subsequent consultation of yp by getting +! truename now*/ +! vs_base[0]=namestring(truename(vs_base[0])); +! {char name[200]; +! char *dom = name; +! if (0== getdomainname(dom,sizeof(name))) +! yp_unbind(dom);} + #endif + + saving_system = TRUE; + GBC(t_contiguous); + +--- 853,867 ---- + + siLsave_system() + { + int i; + + check_arg(1); +! #ifdef HAVE_YP_UNBIND +! /* see unixsave.c */ +! {char *dname; +! yp_get_default_domain(&dname);} + #endif + + saving_system = TRUE; + GBC(t_contiguous); + +c/num_log.c +*** c/num_log.c Mon Jul 6 00:15:00 1992 +--- ../akcl-1-615/c/num_log.c Mon Jun 15 21:15:59 1992 +*************** +*** 266,286 **** + return(~j); + } + + int + big_bitp(x, p) +! object x; +! int p; + { GEN u = MP(x); + int ans ; + int i = p /32; + if (signe(u) < 0) + { save_avma; + u = complementi(u); + restore_avma; + } +! if (i < lgef(u)) + { ans = ((MP_ITH_WORD(u,i,lgef(u))) & (1 << p%32));} + else if (big_sign(x) < 0) ans = 1; + else ans = 0; + return ans; + } +--- 266,286 ---- + return(~j); + } + + int + big_bitp(x, p) +! object x; +! int p; + { GEN u = MP(x); + int ans ; + int i = p /32; + if (signe(u) < 0) + { save_avma; + u = complementi(u); + restore_avma; + } +! if (i < lgef(u) -MP_CODE_WORDS) + { ans = ((MP_ITH_WORD(u,i,lgef(u))) & (1 << p%32));} + else if (big_sign(x) < 0) ans = 1; + else ans = 0; + return ans; + } +c/unixsave.c +*** c/unixsave.c Mon Jul 6 00:15:07 1992 +--- ../akcl-1-615/c/unixsave.c Fri Jul 3 02:52:36 1992 +*************** +*** 71,81 **** +--- 71,160 ---- + break; + } else + break; + } + ++ #include "page.h" + ++ /* string is aligned on a word boundary */ ++ int ++ find_string_in_memory(string,length,other_p,function) ++ char *string; ++ int length,other_p; ++ int *function(); ++ { ++ int *imem_first,*imem_last,*imem,word; ++ char *mem; ++ int len,page_first,page_last,i; ++ int maxpage = page(heap_end); ++ if(((int)string & 3) == 0 && length >= 4) /* just to be safe */ ++ {word=*(int *)string; ++ for (page_first = 0; page_first < maxpage; page_first++) ++ if ((enum type)type_map[page_first] != t_other) ++ break; ++ for (; page_first < maxpage; page_first++) ++ if (((enum type)type_map[page_first] == t_other)?other_p:!other_p) ++ {for (page_last = page_first+1; page_last < maxpage; page_last++) ++ if ( !(((enum type)type_map[page_last] == t_other)?other_p:!other_p) ) ++ break; ++ imem_first=(int *)pagetochar(page_first); ++ imem_last=(int *)( ( ((int)pagetochar(page_last)) - length) &~3 ); ++ for (imem = imem_first; imem <= imem_last; imem++) ++ if (*imem == word) ++ {mem=(char *)imem; ++ for(i=4; i=length) ++ if((*function)(mem)) ++ return TRUE;}}} ++ return FALSE; ++ } ++ ++ int ++ fsim_first(address) ++ char *address; ++ { ++ return TRUE; ++ } ++ ++ int ++ fsim_reset_pointer(address) ++ char **address; ++ { ++ *address = NULL; ++ return FALSE; ++ } ++ ++ #define t_other_PAGES TRUE ++ #define NOT_t_other_PAGES FALSE ++ ++ int ++ reset_other_pointers(address) ++ char *address; ++ { ++ int word=(int)address; ++ find_string_in_memory(&word,4,t_other_PAGES,fsim_reset_pointer); ++ } ++ ++ int ++ maybe_reset_pointers(address) ++ char *address; ++ { ++ int word=(int)address; ++ if(!find_string_in_memory(&word,4,NOT_t_other_PAGES,fsim_first)) ++ reset_other_pointers(address); ++ return FALSE; ++ } ++ ++ reset_other_pointers_to_string(string) ++ char *string; ++ { ++ int length=strlen(string)+1; ++ find_string_in_memory(string,length,t_other_PAGES,maybe_reset_pointers); ++ } ++ ++ bool saving_system; ++ + memory_save(original_file, save_file) + char *original_file, *save_file; + { MEM_SAVE_LOCALS; + char *data_begin, *data_end; + int original_data; +*************** +*** 100,110 **** +--- 179,206 ---- + n = open(save_file, O_CREAT|O_WRONLY, 0777); + if (n != 1 || (save = fdopen(n, "w")) != stdout) { + fprintf(stderr, "Can't open the save file.\n"); + exit(1); + } ++ + setbuf(save, stdout_buf); ++ ++ #ifdef HAVE_YP_UNBIND ++ /* yp_get_default_domain() caches the result of getdomainname() in ++ a malloc'ed block of memory; and gethostbyname saves the result of ++ yp_get_default_domain() in yet another chunk of memory. These ++ cached values will cause problems if the saved image is run on a ++ machine having a different local domainname. [When getdomainname ++ is called (by CLX, for example) KCL will wait forever.] There doesn't ++ seem to be any way to uncache these things (apparently yp_unbind does ++ not do this), nor any good way to find these blocks of memory. */ ++ ++ if(saving_system) ++ {char *dname; ++ yp_get_default_domain(&dname); ++ reset_other_pointers(dname);} ++ #endif + + READ_HEADER; + FILECPY_HEADER; + + for (n = header.a_data, p = data_begin; ; n -= BUFSIZ, p += BUFSIZ) +cmpnew/cmpcall.lsp +*** cmpnew/cmpcall.lsp Mon Jul 6 00:15:13 1992 +--- ../akcl-1-615/cmpnew/cmpcall.lsp Thu Jun 18 21:43:24 1992 +*************** +*** 118,127 **** +--- 118,128 ---- + ;;; responsible for maintaining this condition. + (let ((*vs* *vs*) (form (caddr funob))) + (declare (object form)) + (cond ((and (listp args) + *use-sfuncall* ++ (<= (length (cdr args)) 10) + ;;Determine if only one value at most is required: + (or + (eq *value-to-go* 'trash) + (and (consp *value-to-go*) + (eq (car *value-to-go*) 'var)) +lsp/autoload.lsp +*** lsp/autoload.lsp Mon Jul 6 00:15:27 1992 +--- ../akcl-1-615/lsp/autoload.lsp Tue Jun 16 02:36:45 1992 +*************** +*** 430,440 **** + '(cons + fixnum bignum ratio short-float long-float complex + character symbol package hash-table + array vector string bit-vector + structure stream random-state readtable pathname +! cfun cclosure sfun gfun cfdata spice fat-string )) + + (defun room (&optional x) + (let ((l (multiple-value-list (si:room-report))) + maxpage leftpage ncbpage maxcbpage ncb cbgbccount npage + rbused rbfree nrbpage +--- 430,440 ---- + '(cons + fixnum bignum ratio short-float long-float complex + character symbol package hash-table + array vector string bit-vector + structure stream random-state readtable pathname +! cfun cclosure sfun gfun vfun cfdata spice fat-string dclosure)) + + (defun room (&optional x) + (let ((l (multiple-value-list (si:room-report))) + maxpage leftpage ncbpage maxcbpage ncb cbgbccount npage + rbused rbfree nrbpage +lsp/cmpinit.lsp +*** lsp/cmpinit.lsp Mon Jul 6 00:15:28 1992 +--- ../akcl-1-615/lsp/cmpinit.lsp Mon Jun 22 17:11:11 1992 +*************** +*** 4,12 **** + (setq compiler::*eval-when-defaults* '(compile eval load)) + (or (fboundp 'si::get-&environment) (load "defmacro.lsp")) + ;(or (get 'si::s-data 'si::s-data) + ; (progn (load "../lsp/setf.lsp") (load "../lsp/defstruct.lsp"))) + (if (probe-file "sys-proclaim.lisp")(load "sys-proclaim.lisp")) +! +! + + ;;;;; +--- 4,13 ---- + (setq compiler::*eval-when-defaults* '(compile eval load)) + (or (fboundp 'si::get-&environment) (load "defmacro.lsp")) + ;(or (get 'si::s-data 'si::s-data) + ; (progn (load "../lsp/setf.lsp") (load "../lsp/defstruct.lsp"))) + (if (probe-file "sys-proclaim.lisp")(load "sys-proclaim.lisp")) +! (unless (get 'si::basic-wrapper 'si::s-data) +! (setf (get 'si::s-data 'si::s-data) nil) +! (load "../lsp/defstruct.lsp")) + + ;;;;; diff --git a/pcl/impl/kcl/new-kcl-wrapper.text b/pcl/impl/kcl/new-kcl-wrapper.text new file mode 100644 index 0000000..7f161a6 --- /dev/null +++ b/pcl/impl/kcl/new-kcl-wrapper.text @@ -0,0 +1,2157 @@ +The new-kcl-wrapper modifications make the storage of standard-objects +and structure objects much more similar than before. These changes should +greatly speed up WRAPPER-OF for structure objects and should speed up +WRAPPER-OF for standard-instances also (but not funcallable instances). + +Look first at the defstructs defined here (scan this file for "(defstruct ("). +Then look at cache.lisp, at the "#+structure-wrapper" for the new definition of +the wrapper structure. Finally, look in low.lisp, at the +"#+new-structure-wrapper" for the definition of %allocate-instance--class. + +You need to have akcl-1-615 to use this file. + +This file contains new versions of the files V/c/structure.c and +V/lsp/defstruct.lsp, as well as small changes to the files c/gbc.c, c/sgbc.c, +cmpnew/cmpinit.lsp, lsp/cmpinit.lsp, and lsp/describe.lsp. + +-- The gbc changes allow the garbage collector to work correctly even when +structures which define other structures (ones which can be the value of +STRUCTURE-DEF) are not allocated in static storage. + + +c/gbc.c +*** c/gbc.c Tue Jun 30 04:11:00 1992 +--- ../akcl-1-615/c/gbc.c Tue Jun 30 02:48:04 1992 +*************** +*** 427,453 **** + break; + goto COPY_STRING; + + case t_structure: + mark_object(x->str.str_def); + p = x->str.str_self; + if (p == NULL) +! break; +! {object def=x->str.str_def; +! unsigned char * s_type = &SLOT_TYPE(def,0); +! unsigned short *s_pos= & SLOT_POS(def,0); +! for (i = 0, j = S_DATA(def)->length; i < j; i++) + if (s_type[i]==0) mark_object(STREF(object,x,s_pos[i])); + if ((int)what_to_collect >= (int)t_contiguous) { + if (inheap(x->str.str_self)) { + if (what_to_collect == t_contiguous) + mark_contblock((char *)p, +! S_DATA(def)->size); + + } else +! x->str.str_self = (object *) +! copy_relblock((char *)p, S_DATA(def)->size); + }} + break; + + case t_stream: + switch (x->sm.sm_mode) { +--- 427,461 ---- + break; + goto COPY_STRING; + + case t_structure: ++ x->d.m = 2; + mark_object(x->str.str_def); + p = x->str.str_self; + if (p == NULL) +! {x->d.m = TRUE; break;} +! {object def=x->str.str_def; +! struct s_data *sdef=S_DATA(def); +! unsigned char *s_type; +! unsigned short *s_pos; +! if((int)what_to_collect >= (int)t_contiguous && +! !inheap(sdef) && def->d.m==TRUE) +! sdef=(struct s_data *)(((char *)sdef)+(rb_start1-rb_start)); +! s_type = sdef->raw->ust.ust_self; +! s_pos = &USHORT(sdef->slot_position,0); +! for (i = 0, j = sdef->length; i < j; i++) + if (s_type[i]==0) mark_object(STREF(object,x,s_pos[i])); + if ((int)what_to_collect >= (int)t_contiguous) { + if (inheap(x->str.str_self)) { + if (what_to_collect == t_contiguous) + mark_contblock((char *)p, +! sdef->size); + + } else +! x->str.str_self = (object *) +! copy_relblock((char *)p, sdef->size); + }} ++ x->d.m = TRUE; + break; + + case t_stream: + switch (x->sm.sm_mode) { +*** c/sgbc.c Mon Jun 15 21:16:01 1992 +--- akcl-1-615/c/sgbc.c Wed Jul 1 18:37:24 1992 +*************** +*** 355,386 **** + if (cp == NULL) + break; + goto COPY_STRING; + + case t_structure: + sgc_mark_object(x->str.str_def); + p = x->str.str_self; + if (p == NULL) +! break; +! {object def=x->str.str_def; +! unsigned char * s_type = &SLOT_TYPE(def,0); +! unsigned short *s_pos= & SLOT_POS(def,0); +! for (i = 0, j = S_DATA(def)->length; i < j; i++) + if (s_type[i]==0 && + ON_WRITABLE_PAGE(& STREF(object,x,s_pos[i])) + ) + sgc_mark_object(STREF(object,x,s_pos[i])); + if ((int)what_to_collect >= (int)t_contiguous) { + if (inheap(x->str.str_self)) { + if (what_to_collect == t_contiguous) + mark_contblock((char *)p, +! S_DATA(def)->size); + + } else if(SGC_RELBLOCK_P(p)) + x->str.str_self = (object *) +! copy_relblock((char *)p, S_DATA(def)->size); + }} + break; + + case t_stream: + switch (x->sm.sm_mode) { + case smm_input: +--- 355,394 ---- + if (cp == NULL) + break; + goto COPY_STRING; + + case t_structure: ++ x->d.m = 2; + sgc_mark_object(x->str.str_def); + p = x->str.str_self; + if (p == NULL) +! {x->d.m = TRUE; break;} +! {object def=x->str.str_def; +! struct s_data *sdef=S_DATA(def); +! unsigned char *s_type; +! unsigned short *s_pos; +! if((int)what_to_collect >= (int)t_contiguous && +! !inheap(sdef) && def->d.m==TRUE) +! sdef=(struct s_data *)(((char *)sdef)+(rb_start1-rb_start)); +! s_type = sdef->raw->ust.ust_self; +! s_pos = &USHORT(sdef->slot_position,0); +! for (i = 0, j = sdef->length; i < j; i++) + if (s_type[i]==0 && + ON_WRITABLE_PAGE(& STREF(object,x,s_pos[i])) + ) + sgc_mark_object(STREF(object,x,s_pos[i])); + if ((int)what_to_collect >= (int)t_contiguous) { + if (inheap(x->str.str_self)) { + if (what_to_collect == t_contiguous) + mark_contblock((char *)p, +! sdef->size); + + } else if(SGC_RELBLOCK_P(p)) + x->str.str_self = (object *) +! copy_relblock((char *)p, sdef->size); + }} ++ x->d.m = TRUE; + break; + + case t_stream: + switch (x->sm.sm_mode) { + case smm_input: +cmpnew/cmpinit.lsp +*** cmpnew/cmpinit.lsp Tue Jun 30 04:11:13 1992 +--- ../akcl-1-615/cmpnew/cmpinit.lsp Mon Jun 22 18:41:51 1992 +*************** +*** 4,7 **** +--- 4,10 ---- + (load "sys-proclaim.lisp") + (setq compiler::*eval-when-defaults* '(compile eval load)) + + ;(dolist (v '( cmpeval cmpopt cmptype cmpbind cmpinline cmploc cmpvar cmptop cmplet cmpcall cmpmulti cmplam cmplabel cmpeval)) (load (format nil "~(~a~).lsp" v))) ++ (unless (get 'si::basic-wrapper 'si::s-data) ++ (setf (get 'si::s-data 'si::s-data) nil) ++ (load "../lsp/defstruct.lsp")) +lsp/cmpinit.lsp +*** lsp/cmpinit.lsp Tue Jun 30 04:11:26 1992 +--- ../akcl-1-615/lsp/cmpinit.lsp Mon Jun 22 17:11:11 1992 +*************** +*** 5,12 **** + (or (fboundp 'si::get-&environment) (load "defmacro.lsp")) + ;(or (get 'si::s-data 'si::s-data) + ; (progn (load "../lsp/setf.lsp") (load "../lsp/defstruct.lsp"))) + (if (probe-file "sys-proclaim.lisp")(load "sys-proclaim.lisp")) +! +! + + ;;;;; +--- 5,13 ---- + (or (fboundp 'si::get-&environment) (load "defmacro.lsp")) + ;(or (get 'si::s-data 'si::s-data) + ; (progn (load "../lsp/setf.lsp") (load "../lsp/defstruct.lsp"))) + (if (probe-file "sys-proclaim.lisp")(load "sys-proclaim.lisp")) +! (unless (get 'si::basic-wrapper 'si::s-data) +! (setf (get 'si::s-data 'si::s-data) nil) +! (load "../lsp/defstruct.lsp")) + + ;;;;; +lsp/describe.lsp +*** lsp/describe.lsp Tue Jun 30 04:11:27 1992 +--- ../akcl-1-615/lsp/describe.lsp Tue Jun 23 16:39:07 1992 +*************** +*** 266,282 **** + + (defun inspect-structure (x &aux name) + (format t "Structure of type ~a ~%Byte:[Slot Type]Slot Name :Slot Value" + (setq name (type-of x))) +! (let* ((sd (get name 'si::s-data)) + (spos (s-data-slot-position sd))) + (dolist (v (s-data-slot-descriptions sd)) + (format t "~%~4d:~@[[~s] ~]~20a:~s" +! (aref spos (nth 4 v)) +! (let ((type (nth 2 v))) + (if (eq t type) nil type)) +! (car v) +! (structure-ref1 x (nth 4 v)))))) + + + (defun inspect-object (object &aux (*inspect-level* *inspect-level*)) + (inspect-indent) +--- 266,282 ---- + + (defun inspect-structure (x &aux name) + (format t "Structure of type ~a ~%Byte:[Slot Type]Slot Name :Slot Value" + (setq name (type-of x))) +! (let* ((sd (structure-def x)) + (spos (s-data-slot-position sd))) + (dolist (v (s-data-slot-descriptions sd)) + (format t "~%~4d:~@[[~s] ~]~20a:~s" +! (aref spos (slot-offset v)) +! (let ((type (slot-type v))) + (if (eq t type) nil type)) +! (slot-name v) +! (structure-ref1 x (slot-offset v)))))) + + + (defun inspect-object (object &aux (*inspect-level* *inspect-level*)) + (inspect-indent) +============================================================================== +=============================== c/structure.c ================================ +Changes file for /kcl/c/structure.c +Usage \n@s[Original text\n@s|Replacement Text\n@s] +See the file rascal.ics.utexas.edu:/usr2/ftp/merge.c +for a program to merge change files. Anything not between + "\n@s[" and "\n@s]" is a simply a comment. +This file was constructed using emacs and merge.el + by (Bill Schelter) wfs@carl.ma.utexas.edu + + +****Change:(orig (15 17 d)) +@s[object siSstructure_print_function; +object siSstructure_slot_descriptions; +object siSstructure_include; + +@s| +@s] + + +****Change:(orig (18 18 a)) +@s[ + +@s| +#define COERCE_DEF(x) if (type_of(x)==t_symbol) \ + x=getf(x->s.s_plist,siLs_data,Cnil) + +#define check_type_structure(x) \ + if(type_of((x))!=t_structure) \ + FEwrong_type_argument(Sstructure,(x)) + + + +@s] + + +****Change:(orig (22 31 c)) +@s[{ + do { + if (type_of(x) != t_symbol) + return(FALSE); + +@s, } while (x != Cnil); + return(FALSE); +} + +@s|{ if (x==y) return 1; + if (type_of(x)!= t_structure + || type_of(y)!=t_structure) + FEerror("bad call to structure_subtypep",0); + {if (S_DATA(y)->included == Cnil) return 0; + while ((x=S_DATA(x)->includes) != Cnil) + { if (x==y) return 1;} + return 0; + }} + +@s] + + +****Change:(orig (32 32 a)) +@s[ + +@s| +static +bad_raw_type() +{ FEerror("Bad raw struct type",0);} + + + +@s] + + +****Change:(orig (34 34 c)) +@s[structure_ref(x, name, n) + +@s|structure_ref(x, name, i) + +@s] + + +****Change:(orig (36 38 c)) +@s[object x, name; +int n; +{ + int i; + +@s|object x, name; +int i; +{unsigned short *s_pos; + COERCE_DEF(name); + if (type_of(x) != t_structure || + (type_of(name)!=t_structure) || + !structure_subtypep(x->str.str_def, name)) + FEwrong_type_argument((type_of(name)==t_structure ? + S_DATA(name)->name : name), + x); + s_pos = &SLOT_POS(x->str.str_def,0); + switch((SLOT_TYPE(x->str.str_def,i))) + { + case aet_object: return(STREF(object,x,s_pos[i])); + case aet_fix: return(make_fixnum((STREF(int,x,s_pos[i])))); + case aet_ch: return(code_char(STREF(char,x,s_pos[i]))); + case aet_bit: + case aet_char: return(make_fixnum(STREF(char,x,s_pos[i]))); + case aet_sf: return(make_shortfloat(STREF(shortfloat,x,s_pos[i]))); + case aet_lf: return(make_longfloat(STREF(longfloat,x,s_pos[i]))); + case aet_uchar: return(make_fixnum(STREF(unsigned char,x,s_pos[i]))); + case aet_ushort: return(make_fixnum(STREF(unsigned short,x,s_pos[i]))); + case aet_short: return(make_fixnum(STREF(short,x,s_pos[i]))); + default: + bad_raw_type(); + return 0; + }} + +@s] + + +****Change:(orig (40 43 c)) +@s[ if (type_of(x) != t_structure || + !structure_subtypep(x->str.str_name, name)) + FEwrong_type_argument(name, x); + return(x->str.str_self[n]); + +@s| +void +siLstructure_ref1() +{object x=vs_base[0]; + int n=fix(vs_base[1]); + object def; + check_type_structure(x); + def=x->str.str_def; + if(n>= S_DATA(def)->length) + FEerror("Structure ref out of bounds",0); + vs_base[0]=structure_ref(x,x->str.str_def,n); + vs_top=vs_base+1; + +@s] + + +****Change:(orig (45 45 a)) +@s[} + + +@s|} + +void +siLstructure_set1() +{object x=vs_base[0]; + int n=fix(vs_base[1]); + object v=vs_base[2]; + object def; + check_type_structure(x); + def=x->str.str_def; + if(n>= S_DATA(def)->length) + FEerror("Structure ref out of bounds",0); + vs_base[0]=structure_set(x,x->str.str_def,n,v); + vs_top=vs_base+1; +} + + + +@s] + + +****Change:(orig (47 47 c)) +@s[structure_set(x, name, n, v) + +@s|structure_set(x, name, i, v) + +@s] + + +****Change:(orig (49 51 c)) +@s[object x, name, v; +int n; +{ + int i; + +@s|object x, name, v; +int i; +{unsigned short *s_pos; + + COERCE_DEF(name); + if (type_of(x) != t_structure || + type_of(name) != t_structure || + !structure_subtypep(x->str.str_def, name)) + FEwrong_type_argument((type_of(name)==t_structure ? + S_DATA(name)->name : name) + , x); + +@s] + + +****Change:(orig (53 57 c)) +@s[ if (type_of(x) != t_structure || + !structure_subtypep(x->str.str_name, name)) + FEwrong_type_argument(name, x); + x->str.str_self[n] = v; + +@s, return(v); + +@s|#ifdef SGC + /* make sure the structure header is on a writable page */ + if (x->d.m) FEerror("bad gc field",0); else x->d.m = 0; +#endif + + s_pos= & SLOT_POS(x->str.str_def,0); + switch(SLOT_TYPE(x->str.str_def,i)){ + + case aet_object: STREF(object,x,s_pos[i])=v; break; + case aet_fix: (STREF(int,x,s_pos[i]))=fix(v); break; + case aet_ch: STREF(char,x,s_pos[i])=char_code(v); break; + case aet_bit: + case aet_char: STREF(char,x,s_pos[i])=fix(v); break; + case aet_sf: STREF(shortfloat,x,s_pos[i])=sf(v); break; + case aet_lf: STREF(longfloat,x,s_pos[i])=lf(v); break; + case aet_uchar: STREF(unsigned char,x,s_pos[i])=fix(v); break; + case aet_ushort: STREF(unsigned short,x,s_pos[i])=fix(v); break; + case aet_short: STREF(short,x,s_pos[i])=fix(v); break; + default: + bad_raw_type(); + + } + return(v); + +@s] + + +****Change:(orig (59 59 a)) +@s[} + + +@s|} + +void +siLstructure_subtype_p() +{object x,y; + check_arg(2); + x=vs_base[0]; + y=vs_base[1]; + if (type_of(x)!=t_structure) + {vs_base[0]=Cnil; goto BOTTOM;} + x=x->str.str_def; + COERCE_DEF(y); + if (structure_subtypep(x,y)) vs_base[0]=Ct; + else vs_base[0]=Cnil; + BOTTOM: + vs_top=vs_base+1; +} + +static object +slot_name(x) + object x; +{ + if(type_of(x)==t_cons) + return car(x); + if(type_of(x)==t_structure) + return x->str.str_self[0]; + return Cnil; +} + + +@s] + + +****Change:(orig (64 64 a)) +@s[object x; +{ + object *p, s; + +@s|object x; +{ + object *p, s; + struct s_data *def=S_DATA(x->str.str_def); + +@s] + + +****Change:(orig (66 69 c)) +@s[ + s = getf(x->str.str_name->s.s_plist, + siSstructure_slot_descriptions, Cnil); + vs_push(x->str.str_name); + +@s| + s = def->slot_descriptions; + vs_push(def->name); + +@s] + + +****Change:(orig (72 73 c)) +@s[ for (i=0, n=x->str.str_length; !endp(s)&&ic.c_cdr, i++) { + *p = make_cons(car(s->c.c_car), Cnil); + +@s| for (i=0, n=def->length; !endp(s)&&ic.c_cdr, i++) { + *p = make_cons(slot_name(s->c.c_car), Cnil); + +@s] + + +****Change:(orig (75 75 c)) +@s[ *p = make_cons(x->str.str_self[i], Cnil); + +@s| *p = make_cons(structure_ref(x,x->str.str_def,i), Cnil); + +@s] + + +****Change:(orig (81 81 a)) +@s[ stack_cons(); + return(vs_pop); +} + + +@s| stack_cons(); + return(vs_pop); +} + +void + +@s] + + +****Change:(orig (84 85 c)) +@s[ object x; + int narg, i; + +@s| object x,name,*base; + struct s_data *def; + int narg, i,size; + base=vs_base; + if ((narg = vs_top - base) == 0) + too_few_arguments(); + x = alloc_object(t_structure); + name=base[0]; + COERCE_DEF(name); + if (type_of(name)!=t_structure || + (def=S_DATA(name))->length != --narg) + FEerror("Bad make_structure args for type ~a",1, + base[0]); + x->str.str_def = name; + x->str.str_self = NULL; + size=S_DATA(name)->size; + base[0] = x; + x->str.str_self = (object *) + (def->staticp == Cnil ? alloc_relblock(size) + : alloc_contblock(size)); + /* There may be holes in the structure. + We want them zero, so that equal can work better. + */ + if (S_DATA(name)->has_holes != Cnil) + bzero(x->str.str_self,size); + {unsigned char *s_type; + unsigned short *s_pos; + s_pos= (&SLOT_POS(x->str.str_def,0)); + s_type = (&(SLOT_TYPE(x->str.str_def,0))); + base=base+1; + for (i = 0; i < narg; i++) + {object v=base[i]; + switch(s_type[i]){ + + case aet_object: STREF(object,x,s_pos[i])=v; break; + case aet_fix: (STREF(int,x,s_pos[i]))=fix(v); break; + case aet_ch: STREF(char,x,s_pos[i])=char_code(v); break; + case aet_bit: + case aet_char: STREF(char,x,s_pos[i])=fix(v); break; + case aet_sf: STREF(shortfloat,x,s_pos[i])=sf(v); break; + case aet_lf: STREF(longfloat,x,s_pos[i])=lf(v); break; + case aet_uchar: STREF(unsigned char,x,s_pos[i])=fix(v); break; + case aet_ushort: STREF(unsigned short,x,s_pos[i])=fix(v); break; + case aet_short: STREF(short,x,s_pos[i])=fix(v); break; + default: + bad_raw_type(); + +@s] + + +****Change:(orig (87 97 c)) +@s[ if ((narg = vs_top - vs_base) == 0) + too_few_arguments(); + x = alloc_object(t_structure); + x->str.str_name = vs_base[0]; + +@s, x->str.str_self[i] = vs_top[i]; + +@s| }} + vs_top = base; + vs_base=base-1; + + } + +@s] + + +****Change:(orig (99 99 a)) +@s[} + + +@s|} + +void + +@s] + + +****Change:(orig (103 103 c)) +@s[ object x, y; + int i, j; + +@s| object x, y; + struct s_data *def; + +@s] + + +****Change:(orig (105 105 c)) +@s[ + check_arg(2); + +@s| + if (vs_top-vs_base < 1) too_few_arguments(); + +@s] + + +****Change:(orig (107 110 c)) +@s[ if (type_of(x) != t_structure || x->str.str_name != vs_base[1]) + FEwrong_type_argument(vs_base[1], x); + vs_base[1] = y = alloc_object(t_structure); + y->str.str_name = x->str.str_name; + +@s| check_type_structure(x); + vs_base[0] = y = alloc_object(t_structure); + def=S_DATA(y->str.str_def = x->str.str_def); + +@s] + + +****Change:(orig (112 116 c)) +@s[ y->str.str_length = j = x->str.str_length; + y->str.str_self = (object *)alloc_relblock(sizeof(object)*j); + for (i = 0; i < j; i++) + y->str.str_self[i] = x->str.str_self[i]; + +@s, vs_base++; + +@s| y->str.str_self = (object *)alloc_relblock(def->size); + bcopy(x->str.str_self,y->str.str_self,def->size); + vs_top=vs_base+1; + +@s] + + +****Change:(orig (118 118 a)) +@s[} + + +@s|} + +void +siLcopy_structure_header() +{ + object x, y; + + if (vs_top-vs_base < 1) too_few_arguments(); + x = vs_base[0]; + check_type_structure(x); + vs_base[0] = y = alloc_object(t_structure); + y->str.str_def = x->str.str_def; + y->str.str_self = x->str.str_self; + vs_top=vs_base+1; +} + + +void + +@s] + + +****Change:(orig (122 124 c)) +@s[ if (type_of(vs_base[0]) != t_structure) + FEwrong_type_argument(Sstructure, vs_base[0]); + vs_base[0] = vs_base[0]->str.str_name; + +@s| check_type_structure(vs_base[0]); + vs_base[0] = S_DATA(vs_base[0]->str.str_def)->name; + +@s] + + +****Change:(orig (127 127 c)) +@s[} + +siLstructure_ref() + +@s|} + +#define FIND_SLOT(str,name) ((type_of(name)==t_fixnum)?fix(name): \ + structure_slot_position(str,name)) + +object +structure_ref_new(x, name, i) + object x,name,i; + +@s] + + +****Change:(orig (129 131 c)) +@s[ object x; + int i; + check_arg(3); + +@s| return structure_ref(x,name,FIND_SLOT(x,i)); +} + +@s] + + +****Change:(orig (133 144 c)) +@s[ x = vs_base[0]; + if (type_of(x) != t_structure || + !structure_subtypep(x->str.str_name, vs_base[1])) + FEwrong_type_argument(vs_base[1], x); + +@s, vs_base[0] = x->str.str_self[i]; + vs_top = vs_base+1; + +@s|object +structure_set_new(x, name, i, v) + object x,name,i,v; +{ + return structure_set(x,name,FIND_SLOT(x,i),v); + +@s] + + +****Change:(orig (146 146 a)) +@s[} + + +@s|} + +void +siLstructure_ref() +{ + check_arg(3); + vs_base[0]=structure_ref_new(vs_base[0],vs_base[1],vs_base[2]); + vs_top=vs_base+1; +} + +void + +@s] + + +****Change:(orig (149 150 d)) +@s[siLstructure_set() +{ + object x; + int i; + +@s|siLstructure_set() +{ + +@s] + + +****Change:(orig (152 163 c)) +@s[ + x = vs_base[0]; + if (type_of(x) != t_structure || + !structure_subtypep(x->str.str_name, vs_base[1])) + +@s, x->str.str_self[i] = vs_base[3]; + +@s| structure_set_new(vs_base[0],vs_base[1],vs_base[2],vs_base[3]); + +@s] + + +****Change:(orig (166 166 a)) +@s[ vs_base = vs_top-1; +} + + +@s| vs_base = vs_top-1; +} + +void + +@s] + + +****Change:(orig (228 228 c)) +@s[init_structure_function() + +@s|void +siLmake_s_data_structure() +{object x,y,raw,*base; + int i; + check_arg(5); + x=vs_base[0]; + base=vs_base; + raw=vs_base[1]; + y=alloc_object(t_structure); + y->str.str_def=y; + y->str.str_self = (object *)( x->v.v_self); + S_DATA(y)->name =siLs_data; + S_DATA(y)->length=(raw->v.v_dim); + S_DATA(y)->raw =raw; + for(i=3; iv.v_dim; i++) + y->str.str_self[i]=Cnil; + S_DATA(y)->slot_position=base[2]; + S_DATA(y)->slot_descriptions=base[3]; + S_DATA(y)->staticp=base[4]; + S_DATA(y)->size = (raw->v.v_dim)*sizeof(object); + vs_base[0]=y; + vs_top=vs_base+1; +} + +object siSstructure_init,siSstructure_init_named; +object siSname,siSdefault_init; +object siSraw,siSslot_position,siSsize,siSstaticp,siSslot_descriptions; + +static object +slot_value(str,name) + object str,name; + +@s] + + +****Change:(orig (230 237 c)) +@s[ siSstructure_print_function + = make_si_ordinary("STRUCTURE-PRINT-FUNCTION"); + enter_mark_origin(&siSstructure_print_function); + siSstructure_slot_descriptions + +@s, enter_mark_origin(&siSstructure_include); + +@s| top: + if(type_of(str)==t_structure) + return structure_ref_new(str,str->str.str_def,name); + if(str->c.c_car==siSstructure_init_named) + {object new=get(str->c.c_cdr,siLs_data); + str->c.c_car=siSstructure_init; + str->c.c_cdr=(type_of(new)==t_structure)?new:cdr(new);} + if(siSstructure_init!=car(str)) + FEerror("Illegal call to SI:MAKE-STRUCTURES 1",0); + {object key=intern(coerce_to_string(name),keyword_package); + object value=getf(cdddr(str),key,NULL); + if(value!=NULL) + return value; + else + {object slots; + if(str==caddr(str)&&name==siSslot_descriptions) + FEerror("Illegal call to SI:MAKE-STRUCTURES 2",0); + slots=slot_value(caddr(str),siSslot_descriptions); + for(;!endp(slots);slots=cdr(slots)) + if(name==slot_value(car(slots),siSname)) + {object result,form=slot_value(car(slots),siSdefault_init); + object *old_vs_base=vs_base,*old_vs_top=vs_top; + vs_base=vs_top;vs_push(form);Leval();result=vs_base[0]; + vs_base=old_vs_base; vs_top=old_vs_top; + return result;} + FEerror("Illegal call to SI:MAKE-STRUCTURES 3",0);}} + return Cnil; +} + +@s] + + +****Change:(orig (238 238 a)) +@s[ + +@s| +int +structure_slot_position(str,name) + object str,name; +{ + if(type_of(name)==t_fixnum) + return fix(name); + else + {object slotd_list; + int pos; + check_type_structure(str); + slotd_list=S_DATA(str->str.str_def)->slot_descriptions; + for(pos=0; type_of(slotd_list)==t_cons; pos++,slotd_list=cdr(slotd_list)) + {object slotd=car(slotd_list); + if(name==((type_of(slotd)==t_structure)? + slotd->str.str_self[0]:slot_value(slotd,siSname))) + return pos;} + FEerror("Slot ~S not found in structure ~S",2,name,str); + return 0;} +} + +static object +make_structures_internal(value) + object value; +{ + object str,def; + int def_index,i,ind; + + switch(type_of(value)) + {case t_cons: + if(value->c.c_car==siSstructure_init_named) + {object new=get(value->c.c_cdr,siLs_data); + value->c.c_car=siSstructure_init; + value->c.c_cdr=(type_of(new)==t_structure)?new:cdr(new);} + if(car(value)!=siSstructure_init) + {value->c.c_car=make_structures_internal(value->c.c_car); + value->c.c_cdr=make_structures_internal(value->c.c_cdr); + break;} + if(type_of(cadr(value))==t_structure) + {value=value->c.c_cdr->c.c_car; + break;} + {object def=caddr(value),plist=cdddr(value),result; + object slots,slots_tail; + int size,staticp,len,i; + if(def!=value)def=make_structures_internal(def); + result=alloc_object(t_structure); + result->str.str_def=(def==value)?result:def; + result->str.str_self=NULL; + value->c.c_cdr->c.c_car=result; + size=fixint(slot_value(def,siSsize)); + staticp=Cnil!=slot_value(def,siSstaticp); + slots=slot_value(def,siSslot_descriptions); + len=length(slots); + result->str.str_self=(object *)(staticp?alloc_contblock(size): + alloc_relblock(size)); + bzero(result->str.str_self,size); + if(def==value) + {S_DATA(result)->raw=slot_value(def,siSraw); + S_DATA(result)->slot_position=slot_value(def,siSslot_position);} + for(i=0,slots_tail=slots; istr.str_def,i,svalue);} + for(i=0,slots_tail=slots; istr.str_def,i); + svalue=make_structures_internal(svalue); + structure_set(result,result->str.str_def,i,svalue);} + value=result; + break;} + case t_vector: + if ((enum aelttype)value->v.v_elttype == aet_object) + {int i,len=value->v.v_dim; + for(i=0; iv.v_self[i]=make_structures_internal(value->v.v_self[i]);} + break; + case t_symbol: + {object plist=value->s.s_plist,next; + for(;!endp(plist);plist=cddr(plist)) + {next=plist->c.c_cdr; + if(plist->c.c_car==siLs_data&& + type_of(next->c.c_car)==t_cons) + next->c.c_car=make_structures_internal(next->c.c_car);} + break;}} + return value; +} + +void +siLmake_structures() +{ + check_arg(1); + vs_base[0]=make_structures_internal(vs_base[0]); +} + +void +siLstructure_def() +{check_arg(1); + check_type_structure(vs_base[0]); + vs_base[0]=vs_base[0]->str.str_def; +} + +short aet_sizes [] = { +sizeof(object), /* aet_object t */ +sizeof(char), /* aet_ch string-char */ +sizeof(char), /* aet_bit bit */ +sizeof(fixnum), /* aet_fix fixnum */ +sizeof(float), /* aet_sf short-float */ +sizeof(double), /* aet_lf long-float */ +sizeof(char), /* aet_char signed char */ +sizeof(char), /* aet_uchar unsigned char */ +sizeof(short), /* aet_short signed short */ +sizeof(short) /* aet_ushort unsigned short */ +}; + + + + + +void +siLsize_of() +{ object x= vs_base[0]; + int i; + i= aet_sizes[get_aelttype(x)]; + vs_base[0]=make_fixnum(i); +} + +void +siLaet_type() +{vs_base[0]=make_fixnum(get_aelttype(vs_base[0]));} + + +/* Return N such that something of type ARG can be aligned on + an address which is a multiple of N */ + + +void +siLalignment() +{struct {double x; int y; double z; + float x1; int y1; float z1;} + joe; + joe.z=3.0; + + if (vs_base[0]==Slong_float) + {vs_base[0]=make_fixnum((int)&joe.z- (int)&joe.y); return;} + else + if (vs_base[0]==Sshort_float) + {vs_base[0]=make_fixnum((int)&(joe.z1)-(int)&(joe.y1)); return;} + else + {siLsize_of();} +} + +void +swap_structure_contents(str1,str2) + object str1,str2; +{ + object def1,*self1; + check_type_structure(str1); + check_type_structure(str2); + def1=str1->str.str_def; + self1=str1->str.str_self; + str1->str.str_def=str2->str.str_def; + str1->str.str_self=str2->str.str_self; + str2->str.str_def=def1; + str2->str.str_self=self1; +} + +void +siLswap_structure_contents() +{ + check_arg(2); + swap_structure_contents(vs_base[0],vs_base[1]); + vs_base[0]=Cnil; + vs_top=vs_base+1; +} + +void +siLset_structure_def() +{check_arg(2); + check_type_structure(vs_base[0]); + check_type_structure(vs_base[1]); + vs_base[0]->str.str_def=vs_base[1]; + vs_base[0]=vs_base[1]; + vs_top=vs_base+1; +} + +init_structure_function() +{ + siLs_data=make_si_ordinary("S-DATA"); + siSstructure_init=make_si_ordinary("STRUCTURE-INIT"); + siSstructure_init_named=make_si_ordinary("STRUCTURE-INIT-NAMED"); + siSname=make_si_ordinary("NAME"); + siSdefault_init=make_si_ordinary("DEFAULT-INIT"); + siSraw=make_si_ordinary("RAW"); + siSslot_position=make_si_ordinary("SLOT-POSITION"); + siSsize=make_si_ordinary("SIZE"); + siSstaticp=make_si_ordinary("STATICP"); + siSslot_descriptions=make_si_ordinary("SLOT-DESCRIPTIONS"); + +@s] + + +****Change:(orig (239 239 a)) +@s[ make_si_function("MAKE-STRUCTURE", siLmake_structure); + +@s| make_si_function("MAKE-STRUCTURE", siLmake_structure); + make_si_function("MAKE-S-DATA-STRUCTURE",siLmake_s_data_structure); + +@s] + + +****Change:(orig (240 240 a)) +@s[ make_si_function("COPY-STRUCTURE", siLcopy_structure); + +@s| make_si_function("COPY-STRUCTURE", siLcopy_structure); + make_si_function("COPY-STRUCTURE-HEADER", siLcopy_structure_header); + +@s] + + +****Change:(orig (242 242 a)) +@s[ make_si_function("STRUCTURE-REF", siLstructure_ref); + +@s| make_si_function("STRUCTURE-REF", siLstructure_ref); + make_si_function("STRUCTURE-DEF", siLstructure_def); + make_si_function("STRUCTURE-REF1", siLstructure_ref1); + make_si_function("STRUCTURE-SET1", siLstructure_set1); + +@s] + + +****Change:(orig (245 245 c)) +@s[ make_si_function("STRUCTUREP", siLstructurep); + + +@s| make_si_function("STRUCTUREP", siLstructurep); + make_si_function("SIZE-OF", siLsize_of); + make_si_function("ALIGNMENT",siLalignment); + make_si_function("STRUCTURE-SUBTYPE-P",siLstructure_subtype_p); + +@s] + + +****Change:(orig (247 247 a)) +@s[ make_si_function("LIST-NTH", siLlist_nth); + +@s| make_si_function("LIST-NTH", siLlist_nth); + make_si_function("AET-TYPE",siLaet_type); + make_si_function("SWAP-STRUCTURE-CONTENTS",siLswap_structure_contents); + make_si_function("SET-STRUCTURE-DEF", siLset_structure_def); + make_si_function("MAKE-STRUCTURES", siLmake_structures); + + +@s] + +============================================================================== +============================== V/lsp/defstruct.lsp ============================= +Changes file for /kcl/lsp/defstruct.lsp +Usage \n@s[Original text\n@s|Replacement Text\n@s] +See the file rascal.ics.utexas.edu:/usr2/ftp/merge.c +for a program to merge change files. Anything not between + "\n@s[" and "\n@s]" is a simply a comment. +This file was constructed using emacs and merge.el + by (Bill Schelter) wfs@carl.ma.utexas.edu + + +****Change:(orig (20 71 c)) +@s[(defun make-access-function (name conc-name type named + slot-name default-init slot-type read-only + offset) + (declare (ignore named default-init slot-type)) + +@s, ((error "~S is an illegal structure type." type))))) + +@s|(defvar *accessors* (make-array 10 :adjustable t)) +(defvar *list-accessors* (make-array 2 :adjustable t)) +(defvar *vector-accessors* (make-array 2 :adjustable t)) + +@s] + + +****Change:(orig (72 72 a)) +@s[ + +@s| +(or (fboundp 'record-fn) (setf (symbol-function 'record-fn) + #'(lambda (&rest l) l nil))) + +@s] + + +****Change:(orig (73 73 a)) +@s[ + +@s| +(defun boot-slot-value (str name) + (if (structurep str) + (structure-ref str (structure-def str) name) + (getf (cdddr str) (intern (string name) :keyword)))) + +(defun boot-set-slot-value (str name new-value) + (if (structurep str) + (structure-set str (structure-def str) name new-value) + (setf (getf (cdddr str) (intern (string name) :keyword)) new-value))) + +(defun boot-subtypep (type1 type2) + (or (eq type1 type2) + (let* ((s-data (get type1 's-data)) + (include (boot-s-data-name (boot-slot-value s-data 'includes)))) + (boot-subtypep include type2)))) + +(defun make-slot-boot (&rest args) + (if (get 's-data 's-data) + (apply #'make-slot args) + (list* 'structure-init + nil + '(structure-init-named . slot) + args))) + +(defun make-s-data-boot (&rest args) + (if (get 's-data 's-data) + (apply #'make-s-data args) + (list* 'structure-init + nil + '(structure-init-named . s-data) + args))) + +(defun make-boot-accessor (slot accessor) + (setf (symbol-function accessor) + #'(lambda (object) + (boot-slot-value object slot))) + (let ((writer (intern (format nil "SET ~A" accessor)))) + (setf (symbol-function writer) + #'(lambda (object value) + (boot-set-slot-value object slot value))) + (eval `(defsetf ,accessor ,writer)))) + +(defmacro defstructboot (name &rest slots) + (let ((conc-name (if (listp name) + (string (second (assoc :conc-name (cdr name)))) + (format nil "~A-" name)))) + `(progn + ,@(mapcar #'(lambda (slot) + (let ((fname (intern (format nil "~A~A" conc-name slot)))) + `(make-boot-accessor ',slot ',fname))) + slots)))) + +(defstructboot (slot (:conc-name boot-slot-)) + name default-init type read-only offset accessor-name type-changed) + +(defstructboot (s-data-internal (:conc-name boot-s-data-)) + name length raw included includes staticp print-function + slot-descriptions slot-position size has-holes) + +(defstructboot (basic-wrapper (:conc-name boot-wrapper-)) + cache-number-vector state class) + +(defstructboot (s-data (:conc-name boot-s-data-)) + frozen documentation constructors offset + named type conc-name) + +(defun make-access-function (name conc-name type named include no-fun slot) + (declare (ignore named)) + + (let* ((slot-name (boot-slot-name slot)) + (slot-type (boot-slot-type slot)) + (read-only (boot-slot-read-only slot)) + (offset (boot-slot-offset slot)) + (access-function + (intern (si:string-concatenate (string conc-name) + (string slot-name)))) + accsrs dont-overwrite) + (unless (boot-slot-accessor-name slot) + (setf (boot-slot-accessor-name slot) access-function)) + (ecase type + ((nil) + (setf accsrs *accessors*)) + (list + (setf accsrs *list-accessors*)) + (vector + (setf accsrs *vector-accessors*))) + (or (> (length accsrs) offset) + (adjust-array accsrs (+ offset 10))) + (unless + dont-overwrite + (record-fn access-function 'defun '(t) slot-type) + (or no-fun + (and (fboundp access-function) + (eq (aref accsrs offset) (symbol-function access-function))) + (setf (symbol-function access-function) + (or (aref accsrs offset) + (setf (aref accsrs offset) + (cond ((eq accsrs *accessors*) + #'(lambda (x) + (or (structurep x) + (error "~a is not a structure" x)) + (structure-ref1 x offset))) + ((eq accsrs *list-accessors*) + #'(lambda(x) + (si:list-nth offset x))) + ((eq accsrs *vector-accessors*) + #'(lambda(x) + (aref x offset))))))))) + (cond (read-only + (remprop access-function 'structure-access) + (setf (get access-function 'struct-read-only) t)) + (t (remprop access-function 'setf-update-fn) + (remprop access-function 'setf-lambda) + (remprop access-function 'setf-documentation) + (let ((tem (get access-function 'structure-access))) + (cond ((and (consp tem) include + (if (consp (get include 's-data)) + (boot-subtypep include (car tem)) + (subtypep include (car tem))) + (eql (cdr tem) offset)) + ;; don't change overwrite accessor of subtype. + (setq dont-overwrite t) + ) + (t (setf (get access-function 'structure-access) + (cons (if type type name) offset))))))) + nil)) + + +@s] + + +****Change:(orig (80 89 c)) +@s[ (cond ((null x) + ;; If the slot-description is NIL, + ;; it is in the padding of initial-offset. + nil) + +@s, (t (car x)))) + +@s| (or (boot-slot-name x) + (and (boot-slot-default-init x) + ;; If the slot name is NIL, + ;; it is the structure name. + ;; This is for typed structures with names. + (list 'quote (boot-slot-default-init x))))) + +@s] + + +****Change:(orig (94 97 c)) +@s[ (cond ((null x) nil) + ((null (car x)) nil) + ((null (cadr x)) (list (car x))) + (t (list (list (car x) (cadr x)))))) + +@s| (when (boot-slot-name x) + (if (boot-slot-default-init x) + (list (list (boot-slot-name x) (boot-slot-default-init x))) + (list (boot-slot-name x))))) + +@s] + + +****Change:(orig (248 248 d)) +@s[ ((error "~S is an illegal structure type" type))))) + + + +@s| ((error "~S is an illegal structure type" type))))) + + +@s] + + +****Change:(orig (252 265 d)) +@s[ +(defun make-copier (name copier type named) + (declare (ignore named)) + (cond ((null type) + +@s, ((error "~S is an illegal structure type." type)))) + + + +@s| +@s] + + +****Change:(orig (267 275 c)) +@s[ (cond ((null type) + ;; If TYPE is NIL, the predicate searches the link + ;; of structure-include, until there is no included structure. + `(defun ,predicate (x) + +@s, (setq n (get n 'structure-include)))))) + +@s| (cond ((null type)) + ; done in define-structure + +@s] + + +****Change:(orig (282 283 c)) +@s[ (> (length x) ,name-offset) + (eq (elt x ,name-offset) ',name)))) + +@s| (> (the fixnum (length x)) ,name-offset) + (eq (aref (the (vector t) x) ,name-offset) ',name)))) + +@s] + + +****Change:(orig (294 294 a)) +@s[ ((= i 0) (and (consp y) (eq (car y) ',name))) + +@s| ((= i 0) (and (consp y) (eq (car y) ',name))) + (declare (fixnum i)) + +@s] + + +****Change:(orig (300 301 c)) +@s[;;; and returns a list of the form: +;;; (slot-name default-init slot-type read-only offset) + +@s|;;; and returns a slot. + +@s] + + +****Change:(orig (325 325 c)) +@s[ (list slot-name default-init slot-type read-only offset))) + +@s| (make-slot-boot :name slot-name + :default-init default-init + :type slot-type + :read-only read-only + :offset offset))) + +@s] + + +****Change:(orig (335 335 c)) +@s[ (let ((sds (member (caar olds) news :key #'car))) + +@s| (let* ((old (car olds)) + (sds (member (boot-slot-name old) news :key #'slot-name)) + (new (car sds))) + +@s] + + +****Change:(orig (337 348 c)) +@s[ (when (and (null (cadddr (car sds))) + (cadddr (car olds))) + ;; If read-only is true in the old + ;; and false in the new, signal an error. + +@s, (car (cddddr (car olds)))) + +@s| (when (and (null (boot-slot-read-only new)) + (boot-slot-read-only old)) + ;; If read-only is true in the old + ;; and false in the new, signal an error. + (error "~S is an illegal include slot-description." + new)) + ;; If + (setf (boot-slot-type new) + (best-array-element-type (boot-slot-type new))) + (when (not (equal (normalize-type (or (boot-slot-type new) t)) + (normalize-type (or (boot-slot-type old) t)))) + (error "Type mismmatch for included slot ~a" new)) + (cons (make-slot :name (boot-slot-name new) + :default-init (boot-slot-default-init new) + :type (boot-slot-type new) + :read-only (boot-slot-read-only new) + :offset (boot-slot-offset old)) + +@s] + + +****Change:(orig (353 353 a)) +@s[ (overwrite-slot-descriptions news (cdr olds)))))))) + + +@s| (overwrite-slot-descriptions news (cdr olds)))))))) + +(defvar *all-t-s-type* (make-array 50 :element-type 'unsigned-char :static t)) + +@s] + + +****Change:(orig (355 355 c)) +@s[;;; The DEFSTRUCT macro. + +@s|(defun make-t-type (n include slot-descriptions &aux i) + (let ((res (make-array n :element-type 'unsigned-char :static t))) + (when include + (let ((tem (get include 's-data))raw) + (or tem (error "Included structure undefined ~a" include)) + (setq raw (boot-s-data-raw tem)) + (dotimes (i (min n (length raw))) + (setf (aref res i) (aref raw i))))) + (dolist (v slot-descriptions) + (setq i (boot-slot-offset v)) + (let ((type (boot-slot-type v))) + (cond ((<= (the fixnum (alignment type)) #. (alignment t)) + (setf (aref res i) (aet-type type)))))) + (cond ((< n (length *all-t-s-type*)) + (dotimes (i n) + (cond ((not (eql (the fixnum (aref res i)) 0)) + (return-from make-t-type res)))) + *all-t-s-type*) + (t res)))) + +@s] + + +****Change:(orig (356 356 a)) +@s[ + +@s| +(defvar *standard-slot-positions* + (let ((ar (make-array 50 :element-type 'unsigned-short + :static t))) + (dotimes (i 50) + (declare (fixnum i)) + (setf (aref ar i)(* #. (size-of t) i))) + ar)) + +(eval-when (compile ) +(proclaim '(function round-up (fixnum fixnum ) fixnum)) +) + +(defun round-up (a b) + (declare (fixnum a b)) + (setq a (ceiling a b)) + (the fixnum (* a b))) + + +(defun get-slot-pos (leng include slot-descriptions &aux type small-types + has-holes) + (declare (special *standard-slot-positions*)) include + (dolist (v slot-descriptions) + (when (boot-slot-name v) + (setf type (best-array-element-type (boot-slot-type v)) + (boot-slot-type v) type) + (let ((val (boot-slot-default-init v))) + (unless (typep val type) + (if (and (symbolp val) + (constantp val)) + (setf val (symbol-value val))) + (and (constantp val) + (setf (boot-slot-default-init v) (coerce val type))))) + (cond ((memq type '(signed-char unsigned-char + short unsigned-short + long-float + bit)) + (setq small-types t))))) + (cond ((and (null small-types) + (< leng (length *standard-slot-positions*)) + (list *standard-slot-positions* (* leng #. (size-of t)) nil))) + (t (let ((ar (make-array leng :element-type 'unsigned-short + :static t)) + (pos 0)(i 0)(align 0)type (next-pos 0)) + (declare (fixnum pos i align next-pos)) + ;; A default array. + + (dolist (v slot-descriptions) + (setq type (boot-slot-type v)) + (setq align (alignment type)) + (unless (<= align #. (alignment t)) + (setq type t) + (setf (boot-slot-type v) t) + (setq align #. (alignment t)) + (setf (boot-slot-type-changed v) t)) + (setq next-pos (round-up pos align)) + (or (eql pos next-pos) (setq has-holes t)) + (setq pos next-pos) + (setf (aref ar i) pos) + (incf pos (size-of type)) + (incf i)) + (list ar (round-up pos (size-of t)) has-holes) + )))) + + +(defun define-structure (name conc-name type named slot-descriptions copier + static include print-function constructors + offset predicate &optional documentation no-funs + &aux leng) + (and (consp type) (eq (car type) 'vector)(setq type 'vector)) + (setq leng (length slot-descriptions)) + (setq slot-descriptions + (mapcar #'(lambda (info) + (make-slot-boot :name (first info) + :default-init (second info) + :type (third info) + :read-only (fourth info) + :offset (fifth info) + :accessor-name (sixth info) + :type-changed (seventh info))) + slot-descriptions)) + (dolist (x slot-descriptions) + (when (boot-slot-name x) + (make-access-function name conc-name type named include no-funs x))) + (when (and copier (not no-funs)) + (setf (symbol-function copier) + (ecase type + ((nil) #'si::copy-structure) + (list #'copy-list) + (vector #'copy-seq)))) + (let ((include-str (and include (get include 's-data)))) + (when (and (eq include 's-data-internal) + (not (eq name 'basic-wrapper))) + (error "only ~s can include ~s" 'basic-wrapper 's-data-internal)) + (when include-str + (cond ((and (not (consp include-str)) + (s-data-frozen include-str) + (or (not (s-data-included include-str)) + (not (let ((te (get name 's-data))) + (and te + (eq (s-data-includes te) + include-str)))))) + (warn " ~a was frozen but now included" + include))) + (let ((old-included (boot-slot-value include-str 'included))) + (unless (member name old-included) + (boot-set-slot-value include-str 'included (cons name old-included))))) + (let* ((tem (get name 's-data)) + (g-s-p (and (null type) + (get-slot-pos leng include slot-descriptions))) + (slot-position (car g-s-p)) + (size (if g-s-p (cadr g-s-p) 0)) + (has-holes (caddr g-s-p)) + (def (make-s-data-boot :name name + :length leng + :raw + (and (null type) + (make-t-type leng include + slot-descriptions)) + :slot-position slot-position + :size size + :has-holes has-holes + :staticp static + :includes include-str + :print-function print-function + :slot-descriptions slot-descriptions + :constructors constructors + :offset offset + :type type + :named named + :documentation documentation + :conc-name conc-name))) + (check-s-data tem def name) + (when (and (consp def) (eq name 's-data)) + (make-structures def)))) + (when documentation + (setf (get name 'structure-documentation) + documentation)) + (when (and (null type) predicate) + (record-fn predicate 'defun '(t) t) + (or no-funs + (setf (symbol-function predicate) + #'(lambda (x) + (si::structure-subtype-p x name)))) + (setf (get predicate 'compiler::co1) + 'compiler::co1structure-predicate) + (setf (get predicate 'struct-predicate) name)) + nil) + +(defun check-s-data (old new name) + (unless (and old (member name '(slot s-data-internal basic-wrapper s-data))) + (when (and old (eq (structure-def old) (get 's-data 's-data))) + (boot-set-slot-value new 'included (boot-slot-value old 'included)) + (boot-set-slot-value new 'frozen (boot-slot-value old 'frozen))) + (unless (and old + (eq (structure-def old) (get 's-data 's-data)) + (let ((new-cnv (boot-slot-value new 'cache-number-vector)) + (old-cnv (boot-slot-value old 'cache-number-vector))) + (boot-set-slot-value new 'cache-number-vector old-cnv) + (prog1 (equalp new old) + (boot-set-slot-value new 'cache-number-vector new-cnv)))) + (when old + (warn "structure ~a is changing" name) + (when (eq (structure-def old) (get 's-data 's-data)) + (boot-set-slot-value old 'state (list ':obsolete new)))) + (setf (get name 's-data) new)))) + + +@s] + + +****Change:(orig (364 364 c)) +@s[ predicate predicate-specified + include + +@s| predicate predicate-specified + include include-s-data + +@s] + + +****Change:(orig (367 367 c)) +@s[ offset name-offset + documentation) + +@s| offset name-offset + documentation + static) + +@s] + + +****Change:(orig (370 370 c)) +@s[ ;; The defstruct options are supplied. + +@s| ;; The defstruct options are supplied. + +@s] + + +****Change:(orig (390 425 c)) +@s[ (cond ((and (consp (car os)) (not (endp (cdar os)))) + (setq o (caar os) v (cadar os)) + (case o + (:conc-name + +@s, (t (error "~S is an illegal defstruct option." o)))))) + +@s| (cond ((and (consp (car os)) (not (endp (cdar os)))) + (setq o (caar os) v (cadar os)) + (case o + (:conc-name + (if (null v) + (setq conc-name "") + (setq conc-name v))) + (:constructor + (if (null v) + (setq no-constructor t) + (if (endp (cddar os)) + (setq constructors (cons v constructors)) + (setq constructors (cons (cdar os) constructors))))) + (:copier (setq copier v)) + (:static (setq static v)) + (:predicate + (setq predicate v) + (setq predicate-specified t)) + (:include + (setq include (cdar os)) + (unless (setq include-s-data (get v 's-data)) + (error "~S is an illegal included structure." v))) + (:print-function + (and (consp v) (eq (car v) 'function) + (setq v (second v))) + (setq print-function v)) + (:type (setq type v)) + (:initial-offset (setq initial-offset v)) + (t (error "~S is an illegal defstruct option." o)))) + (t + (if (consp (car os)) + (setq o (caar os)) + (setq o (car os))) + (case o + (:constructor + (setq constructors + (cons default-constructor constructors))) + ((:conc-name :copier :predicate :print-function)) + (:named (setq named t)) + (t (error "~S is an illegal defstruct option." o)))))) + +@s] + + +****Change:(orig (426 426 a)) +@s[ + +@s| + (setq conc-name (intern (string conc-name))) + + (and include-s-data (not print-function) + (setq print-function (boot-s-data-print-function include-s-data))) + + +@s] + + +****Change:(orig (434 435 c)) +@s[ (when include + (unless (equal type (get (car include) 'structure-type)) + +@s| (when include-s-data + (unless (equal type (boot-s-data-type include-s-data)) + +@s] + + +****Change:(orig (442 443 c)) +@s[ (t + (setq offset (get (car include) 'structure-offset)))) + +@s| (t + (setq offset (boot-s-data-offset include-s-data)))) + +@s] + + +****Change:(orig (457 458 c)) +@s[ (setq sds (cons (parse-slot-description (car ds) offset) sds)) + (setq offset (1+ offset))) + +@s| (setq sds (cons (parse-slot-description (car ds) offset) sds)) + (setq offset (1+ offset))) + +@s] + + +****Change:(orig (464 464 c)) +@s[ (cons (list nil name) slot-descriptions))) + +@s| (cons (make-slot :default-init name) slot-descriptions))) + +@s] + + +****Change:(orig (469 469 c)) +@s[ (append (make-list initial-offset) slot-descriptions))) + +@s| (append (mapcar #'make-named-slot (make-list initial-offset)) + slot-descriptions))) + +@s] + + +****Change:(orig (473 486 c)) +@s[ (cond ((null include)) + ((endp (cdr include)) + (setq slot-descriptions + (append (get (car include) 'structure-slot-descriptions) + +@s, slot-descriptions)))) + +@s| (let ((include-slot-descriptions + (and include + (boot-s-data-slot-descriptions include-s-data)))) + (cond ((null include)) + ((endp (cdr include)) + (setq slot-descriptions + (append include-slot-descriptions + slot-descriptions))) + (t + (setq slot-descriptions + (append (overwrite-slot-descriptions + (mapcar #'(lambda (sd) + (parse-slot-description sd 0)) + (cdr include)) + include-slot-descriptions) + slot-descriptions))))) + +@s] + + +****Change:(orig (489 492 c)) +@s[ ;; If a constructor option is NIL, + ;; no constructor should have been specified. + (when constructors + (error "Contradictory constructor options."))) + +@s| ;; If a constructor option is NIL, + ;; no constructor should have been specified. + (when constructors + (error "Contradictory constructor options."))) + +@s] + + +****Change:(orig (494 495 c)) +@s[ ;; If no constructor is specified, + ;; the default-constructor is made. + +@s| ;; If no constructor is specified, + ;; the default-constructor is made. + +@s] + + +****Change:(orig (497 497 a)) +@s[ (setq constructors (list default-constructor)))) + + +@s| (setq constructors (list default-constructor)))) + + ;; We need a default constructor for the sharp-s-reader + (or (member t (mapcar 'symbolp constructors)) + (push (intern (string-concatenate "__si::" default-constructor)) + constructors)) + + +@s] + + +****Change:(orig (509 509 c)) +@s[ (error "An print function is supplied to a typed structure.")) + +@s| (error "A print function is supplied to a typed structure.")) + + `(progn + (define-structure ',name ',conc-name ',type ',named + ',(mapcar #'(lambda (slotd) + (list (boot-slot-name slotd) + (boot-slot-default-init slotd) + (boot-slot-type slotd) + (boot-slot-read-only slotd) + (boot-slot-offset slotd) + (boot-slot-accessor-name slotd) + (boot-slot-type-changed slotd))) + slot-descriptions) + ',copier ',static ',include ',print-function ',constructors + ',offset ',predicate ',documentation) + +@s] + + +****Change:(orig (511 542 c)) +@s[ `(progn (si:putprop ',name + '(defstruct ,name ,@slots) + 'defstruct-form) + (si:putprop ',name t 'is-a-structure) + +@s, (si:putprop ',name ,documentation 'structure-documentation) + ',name))) + +@s| ,@(mapcar #'(lambda (constructor) + (make-constructor name constructor type named + slot-descriptions)) + constructors) + ,@(if (and type predicate) + (list (make-predicate name predicate type named + name-offset))) + ',name + ))) + +@s] + + +****Change:(orig (544 544 a)) +@s[ + + +@s| + +(eval-when (compile load eval) + +(defconstant wrapper-cache-number-adds-ok 4) + +(defconstant wrapper-cache-number-length + (- (integer-length most-positive-fixnum) + wrapper-cache-number-adds-ok)) + +(defconstant wrapper-cache-number-mask + (1- (expt 2 wrapper-cache-number-length))) + + +(defvar *get-wrapper-cache-number* (make-random-state)) + +(defun get-wrapper-cache-number () + (let ((n 0)) + (declare (fixnum n)) + (loop + (setq n + (logand wrapper-cache-number-mask + (random most-positive-fixnum *get-wrapper-cache-number*))) + (unless (zerop n) (return n))))) + +) + +(eval-when (compile load eval) + +(defconstant wrapper-cache-number-vector-length 8) + +(deftype cache-number-vector () + `(simple-array fixnum (8))) + +(defconstant wrapper-layout (make-list wrapper-cache-number-vector-length + :initial-element 'number)) + +) + +(defun make-wrapper-cache-number-vector () + (let ((cnv (make-array #.wrapper-cache-number-vector-length + :element-type 'fixnum))) + (dotimes (i #.wrapper-cache-number-vector-length) + (setf (aref cnv i) (get-wrapper-cache-number))) + cnv)) + +(defstruct (slot + (:static t) + (:constructor make-slot) + (:constructor make-named-slot (name))) + name + default-init + (type t) + read-only + offset + accessor-name + type-changed) + +;; All of the fields of s-data-internal must coincide with +;; the C structure s_data (see object.h). +(defstruct (s-data-internal + (:conc-name s-data-) + (:constructor nil) + (:static t)) + ;; all of these slots are used by c code + name ; a symbol + (length 0 :type fixnum) ; length of slot-descriptions + raw ; a static array of unsigned-short (enum aelttype) + included ; a list of the names of structures including this one + includes ; nil or a s-data structure + staticp ; t or nil + print-function ; nil, a symbol, or a lambda expression + slot-descriptions ; a list of slots + slot-position ; a static array of unsigned-short + (size 0 :type fixnum) ; total size to allocate + has-holes) ; t or nil + +(defstruct (basic-wrapper (:include s-data-internal) + (:conc-name wrapper-) + (:constructor nil) + (:static t)) + (cache-number-vector (make-wrapper-cache-number-vector)) + (state t) ; either t or a list (state-sym new-wrapper) + ;; where state-sym is either :flush or :obsolete + (class nil)) + +;(get name 'si::s-data) ;returns one of these: +(defstruct (s-data (:include basic-wrapper) + (:static t)) + ;; these slots are used only from lisp + frozen ; t or nil ; t means won't include this + documentation + constructors ; a list of either a symbol or a list symbol, arglist + offset ; the total number of slots and placeholders + named ; t or nil + type ; one of: nil, list, or vector + conc-name) ; an interned symbol + +#|| +(import '(si::wrapper-state si::wrapper-class si::basic-wrapper)) + +(defstruct (wrapper (:include basic-wrapper) + (:print-function print-wrapper) + (:constructor make-wrapper-internal) + (:predicate wrapper-p) + (:conc-name wrapper-)) + (class-slots nil :type list)) + +(defun print-wrapper (instance stream depth) + (printing-random-thing (wrapper stream) + (format stream "Wrapper ~S" (wrapper-class wrapper)))) +||# + +(defun update-wrapper-state (old new same-p) + (unless (consp old) + (setf (wrapper-state old) + (list (if same-p ':flush ':obsolete) new)))) + +(defun freeze-defstruct (name) + (let ((tem (and (symbolp name) (get name 's-data)))) + (if tem (setf (s-data-frozen tem) t)))) + + + +@s] + + +****Change:(orig (551 553 c)) +@s[ (let ((l (read stream))) + (unless (get (car l) 'is-a-structure) + (error "~S is not a structure." (car l))) + +@s| (let* ((l (prog1 (read stream t nil t) + (if *read-suppress* + (return-from sharp-s-reader nil)))) + (sd + (or (get (car l) 's-data) + + (error "~S is not a structure." (car l))))) + + +@s] + + +****Change:(orig (558 558 c)) +@s[ (do ((cs (get (car l) 'structure-constructors) (cdr cs))) + +@s| (do ((cs (s-data-constructors sd) (cdr cs))) + +@s] + + +****Change:(orig (571 571 d)) +@s[(set-dispatch-macro-character #\# #\S 'sharp-s-reader) + + + +@s|(set-dispatch-macro-character #\# #\S 'sharp-s-reader) + + +@s] + + +****Change:(orig (582 582 c)) +@s[(defstruct person name age sex) + +@s|(defstruct person name (age 20 :type signed-char) (eyes 2 :type signed-char) + sex) +(defstruct person name (age 20 :type signed-char) (eyes 2 :type signed-char) + sex) +(defstruct person1 name (age 20 :type fixnum) + sex) + +@s] + + +****Change:(orig (584 584 c)) +@s[(defstruct (astronaut (:include person (age 45)) + +@s|(defstruct joe a (a1 0 :type (mod 30)) (a2 0 :type (mod 30)) + (a3 0 :type (mod 30)) (a4 0 :type (mod 30)) ) + +;(defstruct person name age sex) + +(defstruct (astronaut (:include person (age 45 :type fixnum)) + +@s] + + +****Change:(orig (605 605 a)) +@s[ associative + identity) + +@s| associative + identity) + + +@s] + +============================================================================== diff --git a/pcl/impl/kcl/sys-package.lisp b/pcl/impl/kcl/sys-package.lisp new file mode 100644 index 0000000..427813b --- /dev/null +++ b/pcl/impl/kcl/sys-package.lisp @@ -0,0 +1,149 @@ + + +;;; Definitions for package SLOT-ACCESSOR-NAME of type ESTABLISH +(LISP::IN-PACKAGE "SLOT-ACCESSOR-NAME" :USE LISP::NIL :NICKNAMES + '("S-A-N")) + +;;; Definitions for package PCL of type ESTABLISH +(LISP::IN-PACKAGE "PCL" :USE LISP::NIL) + +;;; Definitions for package ITERATE of type ESTABLISH +(LISP::IN-PACKAGE "ITERATE" :USE LISP::NIL) + +;;; Definitions for package WALKER of type ESTABLISH +(LISP::IN-PACKAGE "WALKER" :USE LISP::NIL) + +;;; Definitions for package SLOT-ACCESSOR-NAME of type EXPORT +(LISP::IN-PACKAGE "SLOT-ACCESSOR-NAME" :USE 'LISP::NIL :NICKNAMES + '("S-A-N")) +(LISP::IMPORT 'LISP::NIL) +(LISP::EXPORT 'LISP::NIL) + +;;; Definitions for package PCL of type EXPORT +(LISP::IN-PACKAGE "PCL" :USE '("LISP" "ITERATE" "WALKER")) +(LISP::IMPORT 'LISP::NIL) +(LISP::EXPORT + '(PCL::CLASS-PRECEDENCE-LIST PCL::SLOT-DEFINITION + PCL::COMPUTE-APPLICABLE-METHODS-USING-CLASSES + PCL::SLOT-DEFINITION-WRITERS PCL::CLASS-OF + PCL::NO-APPLICABLE-METHOD PCL::STANDARD-WRITER-METHOD + PCL::ENSURE-CLASS-USING-CLASS PCL::ENSURE-GENERIC-FUNCTION + PCL::FIND-METHOD-COMBINATION PCL::UPDATE-DEPENDENT + PCL::MAP-DEPENDENTS PCL::SLOT-MISSING PCL::SPECIALIZER + PCL::CALL-NEXT-METHOD PCL::ENSURE-GENERIC-FUNCTION-USING-CLASS + PCL::SLOT-MAKUNBOUND-USING-CLASS PCL::MAKE-INSTANCES-OBSOLETE + PCL::INTERN-EQL-SPECIALIZER PCL::REMOVE-DIRECT-SUBCLASS + PCL::METHOD-GENERIC-FUNCTION PCL::METHOD-QUALIFIERS + PCL::FUNCALLABLE-STANDARD-CLASS PCL::EXTRACT-LAMBDA-LIST + PCL::STANDARD-CLASS PCL::PRINT-OBJECT PCL::STRUCTURE-CLASS + PCL::COMPUTE-EFFECTIVE-SLOT-DEFINITION + PCL::GENERIC-FUNCTION-DECLARATIONS PCL::MAKE-INSTANCE + PCL::METHOD-LAMBDA-LIST PCL::DEFGENERIC + PCL::REMOVE-DIRECT-METHOD PCL::STANDARD-DIRECT-SLOT-DEFINITION + PCL::GENERIC-FUNCTION-METHODS PCL::VALIDATE-SUPERCLASS + PCL::REINITIALIZE-INSTANCE PCL::STANDARD-METHOD + PCL::STANDARD-ACCESSOR-METHOD + PCL::FUNCALLABLE-STANDARD-INSTANCE PCL::FUNCTION-KEYWORDS + PCL::STANDARD PCL::FIND-METHOD PCL::EXTRACT-SPECIALIZER-NAMES + PCL::INITIALIZE-INSTANCE PCL::GENERIC-FLET PCL::SLOT-UNBOUND + PCL::STANDARD-INSTANCE PCL::SLOT-DEFINITION-TYPE + PCL::COMPUTE-EFFECTIVE-METHOD PCL::ALLOCATE-INSTANCE + PCL::SYMBOL-MACROLET PCL::GENERIC-FUNCTION + PCL::GENERIC-FUNCTION-METHOD-COMBINATION + PCL::SPECIALIZER-DIRECT-METHODS PCL::ADD-DIRECT-SUBCLASS + PCL::WRITER-METHOD-CLASS PCL::SLOT-DEFINITION-INITARGS + PCL::METHOD-SPECIALIZERS PCL::GENERIC-FUNCTION-METHOD-CLASS + PCL::ADD-METHOD PCL::WITH-ACCESSORS + PCL::SLOT-DEFINITION-ALLOCATION + PCL::SLOT-DEFINITION-INITFUNCTION + PCL::SLOT-DEFINITION-LOCATION PCL::ADD-DIRECT-METHOD + PCL::SLOT-BOUNDP PCL::EQL-SPECIALIZER PCL::SHARED-INITIALIZE + PCL::STANDARD-GENERIC-FUNCTION + PCL::ACCESSOR-METHOD-SLOT-DEFINITION + PCL::SLOT-BOUNDP-USING-CLASS PCL::ADD-DEPENDENT + PCL::SPECIALIZER-DIRECT-GENERIC-FUNCTION + PCL::WITH-ADDED-METHODS PCL::COMPUTE-CLASS-PRECEDENCE-LIST + PCL::REMOVE-DEPENDENT PCL::NEXT-METHOD-P + PCL::GENERIC-FUNCTION-NAME PCL::SLOT-VALUE + PCL::EFFECTIVE-SLOT-DEFINITION PCL::CLASS-FINALIZED-P + PCL::COMPUTE-DISCRIMINATING-FUNCTION PCL::STANDARD-OBJECT + PCL::CLASS-DEFAULT-INITARGS PCL::CLASS-DIRECT-SLOTS + PCL::FUNCALLABLE-STANDARD-INSTANCE-ACCESS PCL::BUILT-IN-CLASS + PCL::NO-NEXT-METHOD PCL::SLOT-MAKUNBOUND + PCL::STANDARD-READER-METHOD PCL::GENERIC-FUNCTION-LAMBDA-LIST + PCL::GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER + PCL::INVALID-METHOD-ERROR PCL::METHOD-COMBINATION-ERROR + PCL::SLOT-EXISTS-P PCL::FINALIZE-INHERITANCE + PCL::SLOT-DEFINITION-NAME + PCL::STANDARD-EFFECTIVE-SLOT-DEFINITION PCL::COMPUTE-SLOTS + PCL::CLASS-SLOTS PCL::EFFECTIVE-SLOT-DEFINITION-CLASS + PCL::STANDARD-INSTANCE-ACCESS PCL::WITH-SLOTS + PCL::DIRECT-SLOT-DEFINITION PCL::DEFINE-METHOD-COMBINATION + PCL::MAKE-METHOD-LAMBDA PCL::ENSURE-CLASS + PCL::DIRECT-SLOT-DEFINITION-CLASS PCL::METHOD-FUNCTION + PCL::STANDARD-SLOT-DEFINITION PCL::CHANGE-CLASS PCL::DEFMETHOD + PCL::UPDATE-INSTANCE-FOR-DIFFERENT-CLASS + PCL::UPDATE-INSTANCE-FOR-REDEFINED-CLASS + PCL::FORWARD-REFERENCED-CLASS PCL::SLOT-DEFINITION-INITFORM + PCL::REMOVE-METHOD PCL::READER-METHOD-CLASS PCL::CALL-METHOD + PCL::CLASS-PROTOTYPE PCL::CLASS-NAME PCL::FIND-CLASS + PCL::DEFCLASS PCL::COMPUTE-APPLICABLE-METHODS + PCL::SLOT-VALUE-USING-CLASS PCL::METHOD-COMBINATION + PCL::EQL-SPECIALIZER-INSTANCE PCL::GENERIC-LABELS PCL::METHOD + PCL::SLOT-DEFINITION-READERS + PCL::CLASS-DIRECT-DEFAULT-INITARGS + PCL::CLASS-DIRECT-SUBCLASSES PCL::CLASS-DIRECT-SUPERCLASSES + PCL::SET-FUNCALLABLE-INSTANCE-FUNCTION)) + +;;; Definitions for package ITERATE of type EXPORT +(LISP::IN-PACKAGE "ITERATE" :USE '("WALKER" "LISP")) +(LISP::IMPORT 'LISP::NIL) +(LISP::EXPORT + '(ITERATE::SUMMING ITERATE::MINIMIZING ITERATE::PLIST-ELEMENTS + ITERATE::ITERATE* ITERATE::MAXIMIZING ITERATE::LIST-TAILS + ITERATE::*ITERATE-WARNINGS* ITERATE::GATHERING + ITERATE::EACHTIME ITERATE::ELEMENTS ITERATE::GATHER + ITERATE::LIST-ELEMENTS ITERATE::WHILE ITERATE::ITERATE + ITERATE::UNTIL ITERATE::JOINING ITERATE::COLLECTING + ITERATE::WITH-GATHERING ITERATE::INTERVAL)) + +;;; Definitions for package WALKER of type EXPORT +(LISP::IN-PACKAGE "WALKER" :USE '("LISP")) +(LISP::IMPORT 'LISP::NIL) +(LISP::EXPORT + '(WALKER::DEFINE-WALKER-TEMPLATE WALKER::*VARIABLE-DECLARATIONS* + WALKER::NESTED-WALK-FORM WALKER::VARIABLE-DECLARATION + WALKER::WALK-FORM-EXPAND-MACROS-P WALKER::VARIABLE-LEXICAL-P + WALKER::VARIABLE-SPECIAL-P WALKER::WALK-FORM + WALKER::MACROEXPAND-ALL WALKER::VARIABLE-GLOBALLY-SPECIAL-P)) + +;;; Definitions for package SLOT-ACCESSOR-NAME of type SHADOW +(LISP::IN-PACKAGE "SLOT-ACCESSOR-NAME") +(LISP::SHADOW 'LISP::NIL) +(LISP::SHADOWING-IMPORT 'LISP::NIL) +(LISP::IMPORT 'LISP::NIL) + +;;; Definitions for package PCL of type SHADOW +(LISP::IN-PACKAGE "PCL") +(LISP::SHADOW '(PCL::DOTIMES PCL::DOCUMENTATION)) +(LISP::SHADOWING-IMPORT 'LISP::NIL) +(LISP::IMPORT + '(SYSTEM::STRUCTURE-REF SYSTEM::STRUCTURE-DEF SYSTEM::STRUCTUREP)) + +;;; Definitions for package ITERATE of type SHADOW +(LISP::IN-PACKAGE "ITERATE") +(LISP::SHADOW 'LISP::NIL) +(LISP::SHADOWING-IMPORT 'LISP::NIL) +(LISP::IMPORT 'LISP::NIL) + +;;; Definitions for package WALKER of type SHADOW +(LISP::IN-PACKAGE "WALKER") +(LISP::SHADOW 'LISP::NIL) +(LISP::SHADOWING-IMPORT 'LISP::NIL) +(LISP::IMPORT 'LISP::NIL) + +(lisp::in-package 'SI) +(export '(%structure-name + %compiled-function-name + %set-compiled-function-name)) +(in-package 'pcl) diff --git a/pcl/impl/kcl/sys-proclaim.lisp b/pcl/impl/kcl/sys-proclaim.lisp new file mode 100644 index 0000000..c1d1f92 --- /dev/null +++ b/pcl/impl/kcl/sys-proclaim.lisp @@ -0,0 +1,818 @@ + +(IN-PACKAGE "USER") +(PROCLAIM '(FTYPE (FUNCTION (*) FIXNUM) PCL::ZERO)) +(PROCLAIM + '(FTYPE (FUNCTION (T FIXNUM *) FIXNUM) + PCL::COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION)) +(PROCLAIM + '(FTYPE (FUNCTION (T) FIXNUM) PCL::FAST-INSTANCE-BOUNDP-INDEX + PCL::ONE-INDEX-LIMIT-FN PCL::N-N-ACCESSORS-LIMIT-FN + PCL::CHECKING-LIMIT-FN PCL::PV-CACHE-LIMIT-FN + PCL::CACHE-NLINES PCL::CACHE-MAX-LOCATION PCL::CACHE-SIZE + PCL::CACHE-MASK PCL::ARG-INFO-NUMBER-REQUIRED + PCL::DEFAULT-LIMIT-FN PCL::CACHE-COUNT + PCL::CACHING-LIMIT-FN PCL::PV-TABLE-PV-SIZE + PCL::EARLY-CLASS-SIZE)) +(PROCLAIM '(FTYPE (FUNCTION (FIXNUM) T) PCL::POWER-OF-TWO-CEILING)) +(PROCLAIM + '(FTYPE (FUNCTION (T) FUNCTION) PCL::CACHE-LIMIT-FN + PCL::METHOD-CALL-FUNCTION PCL::FAST-METHOD-CALL-FUNCTION)) +(PROCLAIM '(FTYPE (FUNCTION (T) PCL::FIELD-TYPE) PCL::CACHE-FIELD)) +(PROCLAIM + '(FTYPE (FUNCTION (T) LIST) PCL::CACHE-OVERFLOW + PCL::PV-TABLE-SLOT-NAME-LISTS PCL::PV-TABLE-CALL-LIST)) +(PROCLAIM '(FTYPE (FUNCTION (T) (MEMBER NIL T)) PCL::CACHE-VALUEP)) +(PROCLAIM '(FTYPE (FUNCTION (T) SIMPLE-VECTOR) PCL::CACHE-VECTOR)) +(PROCLAIM + '(FTYPE (FUNCTION (T) (VALUES T T)) PCL::MAKE-CLASS-PREDICATE-NAME + PCL::MAKE-KEYWORD)) +(PROCLAIM '(FTYPE (FUNCTION (FIXNUM T) T) PCL::%CCLOSURE-ENV-NTHCDR)) +(PROCLAIM + '(FTYPE (FUNCTION (FIXNUM FIXNUM T) FIXNUM) + PCL::COMPUTE-PRIMARY-CACHE-LOCATION)) +(PROCLAIM '(FTYPE (FUNCTION (T) (INTEGER 1 512)) PCL::CACHE-LINE-SIZE)) +(PROCLAIM '(FTYPE (FUNCTION (T) (INTEGER 1 256)) PCL::CACHE-NKEYS)) +(PROCLAIM + '(FTYPE (FUNCTION (T) (OR PCL::CACHE NULL)) PCL::PV-TABLE-CACHE)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T T) *) PCL::MEMF-CODE-CONVERTER + PCL::REAL-LOAD-DEFCLASS PCL::CACHE-MISS-VALUES-INTERNAL + PCL::GENERATE-DISCRIMINATION-NET-INTERNAL + PCL::MAKE-LONG-METHOD-COMBINATION-FUNCTION + PCL::DO-SHORT-METHOD-COMBINATION + WALKER::WALK-TEMPLATE-HANDLE-REPEAT-1)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T) *) + PCL::GET-OPTIMIZED-STD-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION + ITERATE::WALK-GATHERING-BODY + PCL::CACHE-MISS-VALUES + PCL::MAKE-OPTIMIZED-STD-READER-METHOD-FUNCTION + PCL::OPTIMIZE-SLOT-VALUE-BY-CLASS-P PCL::ACCESSOR-VALUES1 + PCL::EMIT-READER/WRITER + PCL::EMIT-ONE-OR-N-INDEX-READER/WRITER + WALKER::WALK-MULTIPLE-VALUE-SETQ PCL::GENERATING-LISP + PCL::EMIT-READER/WRITER-FUNCTION + PCL::EMIT-ONE-OR-N-INDEX-READER/WRITER-FUNCTION + WALKER::WALK-LET-IF PCL::SET-SLOT-VALUE + PCL::CONVERT-METHODS PCL::SLOT-VALUE-USING-CLASS-DFUN + PCL::SLOT-BOUNDP-USING-CLASS-DFUN + PCL::CHECK-METHOD-ARG-INFO PCL::LOAD-LONG-DEFCOMBIN + PCL::MAKE-FINAL-N-N-ACCESSOR-DFUN + PCL::MAKE-FINAL-CACHING-DFUN + PCL::MAKE-FINAL-CONSTANT-VALUE-DFUN + PCL::GET-CLASS-SLOT-VALUE-1 PCL::ACCESSOR-VALUES-INTERNAL + PCL::MAKE-OPTIMIZED-STD-WRITER-METHOD-FUNCTION + PCL::MAKE-OPTIMIZED-STD-BOUNDP-METHOD-FUNCTION + ITERATE::EXPAND-INTO-LET WALKER::WALK-FORM-INTERNAL + ITERATE::RENAME-VARIABLES + PCL::CONSTANT-VALUE-MISS PCL::CACHING-MISS + PCL::CHECKING-MISS + PCL::GET-OPTIMIZED-STD-ACCESSOR-METHOD-FUNCTION)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T) *) + PCL::COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO-INTERNAL + PCL::ADD-METHOD-DECLARATIONS PCL::WALK-METHOD-LAMBDA + PCL::MAKE-TWO-CLASS-ACCESSOR-DFUN + WALKER::WALK-TEMPLATE-HANDLE-REPEAT)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T) *) + PCL::GET-ACCESSOR-FROM-SVUC-METHOD-FUNCTION + PCL::BOOTSTRAP-ACCESSOR-DEFINITION + PCL::GET-ACCESSOR-METHOD-FUNCTION + PCL::EMIT-CHECKING-OR-CACHING + PCL::EMIT-CHECKING-OR-CACHING-FUNCTION + PCL::SETF-SLOT-VALUE-USING-CLASS-DFUN + PCL::LOAD-SHORT-DEFCOMBIN + PCL::INITIALIZE-INSTANCE-SIMPLE-FUNCTION + PCL::MAKE-SHARED-INITIALIZE-FORM-LIST + PCL::MAKE-ONE-CLASS-ACCESSOR-DFUN + PCL::MAKE-FINAL-ONE-INDEX-ACCESSOR-DFUN + PCL::MAKE-FINAL-CHECKING-DFUN PCL::ACCESSOR-VALUES + PCL::SET-CLASS-SLOT-VALUE-1 + PCL::GENERATE-DISCRIMINATION-NET + PCL::REAL-MAKE-METHOD-LAMBDA + PCL::ORDER-SPECIALIZERS WALKER::WALK-TEMPLATE + PCL::ACCESSOR-MISS)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T T T) *) + ITERATE::ITERATE-TRANSFORM-BODY)) +(PROCLAIM + '(FTYPE (FUNCTION (T T *) *) PCL::SLOT-VALUE-OR-DEFAULT + PCL::MAKE-EFFECTIVE-METHOD-FUNCTION + PCL::GET-EFFECTIVE-METHOD-FUNCTION + PCL::MAKE-N-N-ACCESSOR-DFUN WALKER:NESTED-WALK-FORM + PCL::MAKE-CHECKING-DFUN PCL::LOAD-DEFGENERIC + PCL::TYPES-FROM-ARGUMENTS + PCL::MAKE-DEFAULT-INITARGS-FORM-LIST + PCL::MAKE-FINAL-ACCESSOR-DFUN PCL::MAKE-ACCESSOR-TABLE + PCL::GET-SIMPLE-INITIALIZATION-FUNCTION + PCL::GET-COMPLEX-INITIALIZATION-FUNCTIONS + PCL::COMPUTE-SECONDARY-DISPATCH-FUNCTION)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T *) *) + PCL::MAKE-EFFECTIVE-METHOD-FUNCTION-SIMPLE1 + ITERATE::RENAME-LET-BINDINGS)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T *) *) PCL::MAKE-ONE-INDEX-ACCESSOR-DFUN + WALKER::WALK-DECLARATIONS + PCL::GET-SECONDARY-DISPATCH-FUNCTION)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T T *) *) PCL::REAL-MAKE-A-METHOD)) +(PROCLAIM '(FTYPE (FUNCTION (T STREAM T) T) PCL::PRINT-DFUN-INFO)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T) T) ITERATE::SIMPLE-EXPAND-GATHERING-FORM + ITERATE::RENAME-AND-CAPTURE-VARIABLES + ITERATE::VARIABLE-SAME-P + PCL::GET-FUNCTION-GENERATOR + WALKER:VARIABLE-DECLARATION PCL::GET-NEW-FUNCTION-GENERATOR + PCL::TRACE-METHOD-INTERNAL PCL::ONE-INDEX-DFUN-INFO + PCL::ONE-CLASS-DFUN-INFO + PCL::MAP-ALL-ORDERS SYSTEM::APPLY-DISPLAY-FUN + PCL::NOTE-PV-TABLE-REFERENCE + WALKER::RELIST-INTERNAL + PCL::MAKE-DFUN-CALL + WALKER::WALK-TAGBODY-1 WALKER::WALK-LAMBDA + PCL::OPTIMIZE-GF-CALL-INTERNAL + PCL::SKIP-OPTIMIZE-SLOT-VALUE-BY-CLASS-P + WALKER::WALK-COMPILER-LET PCL::SKIP-FAST-SLOT-ACCESS-P + WALKER::WALK-UNEXPECTED-DECLARE WALKER::WALK-FLET + WALKER::WALK-IF + WALKER::WALK-LABELS WALKER::WALK-LET WALKER::WALK-LET* + WALKER::WALK-LOCALLY + WALKER::WALK-MACROLET + PCL::FIX-SLOT-ACCESSORS WALKER::WALK-MULTIPLE-VALUE-BIND + PCL:COMPUTE-EFFECTIVE-METHOD WALKER::WALK-SETQ + WALKER::WALK-SYMBOL-MACROLET PCL::EMIT-SLOT-READ-FORM + WALKER::WALK-TAGBODY PCL::EMIT-BOUNDP-CHECK WALKER::WALK-DO + WALKER::WALK-DO* WALKER::WALK-PROG + WALKER::WALK-NAMED-LAMBDA WALKER::WALK-PROG* + PCL::EXPAND-DEFGENERIC PCL::EMIT-GREATER-THAN-1-DLAP + PCL::EMIT-1-T-DLAP + PCL::MAKE-METHOD-INITARGS-FORM-INTERNAL + PCL::ENTRY-IN-CACHE-P PCL::CONVERT-TABLE + PCL::MAKE-METHOD-SPEC PCL::TRACE-EMF-CALL-INTERNAL + PCL::FLUSH-CACHE-TRAP PCL::SET-FUNCTION-NAME-1 + PCL::OBSOLETE-INSTANCE-TRAP + PCL::COMPUTE-PRECEDENCE PCL::PRINT-STD-INSTANCE + PCL::|SETF PCL METHOD-FUNCTION-GET| + PCL::|SETF PCL PLIST-VALUE| + WALKER::WITH-AUGMENTED-ENVIRONMENT-INTERNAL + PCL::CAN-OPTIMIZE-ACCESS PCL::OPTIMIZE-SLOT-VALUE + PCL::OPTIMIZE-SET-SLOT-VALUE PCL::DECLARE-STRUCTURE + PCL::OPTIMIZE-SLOT-BOUNDP + PCL::PRINT-CACHE PCL::COMPUTE-STD-CPL-PHASE-3 + PCL::FIRST-FORM-TO-LISP + ITERATE::OPTIMIZE-ITERATE-FORM + PCL::WRAP-METHOD-GROUP-SPECIFIER-BINDINGS + PCL::MAKE-TOP-LEVEL-FORM PCL::INVALIDATE-WRAPPER + PCL::STANDARD-COMPUTE-EFFECTIVE-METHOD + PCL::MAKE-OPTIMIZED-STD-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION + PCL::MAKE-OPTIMIZED-STD-SETF-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION + PCL::MAKE-OPTIMIZED-STD-SLOT-BOUNDP-USING-CLASS-METHOD-FUNCTION + WALKER::RECONS ITERATE::OPTIMIZE-GATHERING-FORM)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T) T) PCL::MAKE-EFFECTIVE-METHOD-FUNCTION1 + PCL::MAKE-EFFECTIVE-METHOD-FUNCTION-INTERNAL + PCL::MAKE-EFFECTIVE-METHOD-FUNCTION-TYPE + PCL::MEMF-TEST-CONVERTER + PCL::LOAD-PRECOMPILED-DFUN-CONSTRUCTOR + PCL::TWO-CLASS-DFUN-INFO + WALKER::WALK-LET/LET* WALKER::WALK-PROG/PROG* + WALKER::WALK-DO/DO* + WALKER::WALK-BINDINGS-2 PCL::OPTIMIZE-READER + PCL::OPTIMIZE-WRITER + PCL::EMIT-CHECKING-OR-CACHING-FUNCTION-PRELIMINARY + PCL::MAYBE-EXPAND-ACCESSOR-FORM + PCL::INITIALIZE-INSTANCE-SIMPLE + PCL::GET-WRAPPERS-FROM-CLASSES + PCL::LOAD-PRECOMPILED-IIS-ENTRY + PCL::FILL-CACHE-P + PCL::ADJUST-CACHE + PCL::EXPAND-CACHE + PCL::EXPAND-SYMBOL-MACROLET-INTERNAL + PCL::BOOTSTRAP-SET-SLOT PCL::EXPAND-DEFCLASS PCL::GET-CACHE + )) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T) T) PCL::LOAD-FUNCTION-GENERATOR + PCL::EXPAND-EMF-CALL-METHOD PCL::MAKE-FGEN + PCL::BOOTSTRAP-MAKE-SLOT-DEFINITIONS + PCL::BOOTSTRAP-ACCESSOR-DEFINITIONS1 + PCL::MAKE-FINAL-ORDINARY-DFUN-INTERNAL PCL::COMPUTE-PV-SLOT + WALKER::WALK-BINDINGS-1 + PCL::OPTIMIZE-INSTANCE-ACCESS + PCL::OPTIMIZE-ACCESSOR-CALL + PCL::MAKE-METHOD-INITARGS-FORM-INTERNAL1 + PCL::UPDATE-SLOTS-IN-PV + PCL::MAKE-PARAMETER-REFERENCES + PCL::MAKE-EMF-CACHE + PCL::GET-MAKE-INSTANCE-FUNCTION-INTERNAL + PCL::MAKE-INSTANCE-FUNCTION-COMPLEX + PCL::MAKE-INSTANCE-FUNCTION-SIMPLE + PCL::OPTIMIZE-GENERIC-FUNCTION-CALL + PCL::REAL-MAKE-METHOD-INITARGS-FORM + )) +(PROCLAIM + '(FTYPE (FUNCTION (T T *) T) + PCL::MAKE-EFFECTIVE-METHOD-FUNCTION-SIMPLE + PCL::MAKE-EMF-FROM-METHOD + PCL::EXPAND-EFFECTIVE-METHOD-FUNCTION + PCL::NAMED-OBJECT-PRINT-FUNCTION PCL::FIND-CLASS-FROM-CELL + PCL::FIND-CLASS-PREDICATE-FROM-CELL PCL::INITIALIZE-INFO + PCL::GET-EFFECTIVE-METHOD-FUNCTION1 PCL::GET-DECLARATION + PCL::GET-METHOD-FUNCTION-PV-CELL + PCL:ENSURE-GENERIC-FUNCTION-USING-CLASS PCL::EMIT-MISS + PCL::METHOD-FUNCTION-GET PCL::PROBE-CACHE PCL::MAP-CACHE + PCL::GET-CACHE-FROM-CACHE PCL::PRECOMPUTE-EFFECTIVE-METHODS + PCL::RECORD-DEFINITION WALKER::CONVERT-MACRO-TO-LAMBDA + PCL::CPL-ERROR PCL::REAL-ADD-METHOD + PCL::REAL-ENSURE-GF-USING-CLASS--GENERIC-FUNCTION + PCL::REAL-ENSURE-GF-USING-CLASS--NULL + PCL::COMPUTE-SECONDARY-DISPATCH-FUNCTION1)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T T T T) T) + PCL::GET-SECONDARY-DISPATCH-FUNCTION2)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T T) T) + PCL::BOOTSTRAP-MAKE-SLOT-DEFINITION PCL::EMIT-SLOT-ACCESS + PCL::OPTIMIZE-GF-CALL PCL::SET-ARG-INFO1 PCL::LOAD-DEFCLASS + PCL::MAKE-EARLY-CLASS-DEFINITION)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T *) T) PCL::FILL-DFUN-CACHE + PCL::EARLY-ADD-NAMED-METHOD PCL::REAL-ADD-NAMED-METHOD)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T T *) T) PCL::LOAD-DEFMETHOD + PCL::MAKE-DEFMETHOD-FORM PCL::MAKE-DEFMETHOD-FORM-INTERNAL + PCL::EARLY-MAKE-A-METHOD)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T *) T) PCL::CHECK-INITARGS-2-PLIST + PCL::CHECK-INITARGS-2-LIST WALKER::WALK-ARGLIST + PCL::MAKE-EMF-CALL PCL::CAN-OPTIMIZE-ACCESS1 + PCL::EMIT-FETCH-WRAPPER PCL::FILL-CACHE + PCL::REAL-GET-METHOD PCL::CHECK-INITARGS-1 PCL::GET-METHOD)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T *) T) PCL::EMIT-DLAP + PCL::GET-SECONDARY-DISPATCH-FUNCTION1)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T FIXNUM) T) PCL::FILL-CACHE-FROM-CACHE-P)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T T T) T) PCL::EXPAND-DEFMETHOD + PCL::LOAD-DEFMETHOD-INTERNAL + )) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T T T T T *) T) + PCL::BOOTSTRAP-INITIALIZE-CLASS)) +(PROCLAIM + '(FTYPE (FUNCTION NIL *) PCL::COUNT-ALL-DFUNS PCL::RENEW-SYS-FILES + PCL::EMIT-N-N-READERS PCL::EMIT-N-N-WRITERS)) +(PROCLAIM + '(FTYPE (FUNCTION NIL T) PCL::GET-EFFECTIVE-METHOD-GENSYM + PCL::SHOW-EMF-CALL-TRACE PCL::BOOTSTRAP-META-BRAID + PCL::BOOTSTRAP-BUILT-IN-CLASSES PCL::LIST-ALL-DFUNS + PCL::DEFAULT-METHOD-ONLY-DFUN-INFO + PCL::INITIALIZE-CHECKING-OR-CACHING-FUNCTION-LIST + PCL::CACHES-TO-ALLOCATE PCL::UPDATE-DISPATCH-DFUNS + PCL::MAKE-CACHE PCL::RESET-PCL-PACKAGE + PCL::IN-THE-COMPILER-P PCL::STRUCTURE-FUNCTIONS-EXIST-P + PCL::ALLOCATE-FUNCALLABLE-INSTANCE-2 + PCL::%%ALLOCATE-INSTANCE--CLASS + PCL::ALLOCATE-FUNCALLABLE-INSTANCE-1 + PCL::DISPATCH-DFUN-INFO PCL::INITIAL-DISPATCH-DFUN-INFO + PCL::INITIAL-DFUN-INFO PCL::NO-METHODS-DFUN-INFO + PCL::SHOW-FREE-CACHE-VECTORS PCL::MAKE-CPD + PCL::MAKE-ARG-INFO PCL::SHOW-DFUN-CONSTRUCTORS)) +(PROCLAIM + '(FTYPE (FUNCTION (*) *) PCL::UNTRACE-METHOD + PCL:INVALID-METHOD-ERROR PCL:METHOD-COMBINATION-ERROR + PCL::LIST-LARGE-CACHES + PCL::UPDATE-MAKE-INSTANCE-FUNCTION-TABLE)) +(PROCLAIM '(FTYPE (FUNCTION (FIXNUM T *) *) PCL::FIND-FREE-CACHE-LINE)) +(PROCLAIM + '(FTYPE (FUNCTION (FIXNUM T T) *) PCL::COMPUTE-CACHE-PARAMETERS)) +(PROCLAIM + '(FTYPE (FUNCTION (*) T) PCL::|__si::MAKE-DFUN-INFO| + PCL::|__si::MAKE-NO-METHODS| PCL::|__si::MAKE-INITIAL| + PCL::|__si::MAKE-INITIAL-DISPATCH| + PCL::|__si::MAKE-DISPATCH| + PCL::|__si::MAKE-DEFAULT-METHOD-ONLY| + PCL::|__si::MAKE-ACCESSOR-DFUN-INFO| + PCL::|__si::MAKE-ONE-INDEX-DFUN-INFO| + PCL::MAKE-FAST-METHOD-CALL PCL::|__si::MAKE-N-N| + PCL::MAKE-FAST-INSTANCE-BOUNDP PCL::|__si::MAKE-ONE-CLASS| + PCL::|__si::MAKE-TWO-CLASS| PCL::|__si::MAKE-ONE-INDEX| + PCL::|__si::MAKE-CHECKING| PCL::|__si::MAKE-ARG-INFO| + PCL::FIX-EARLY-GENERIC-FUNCTIONS PCL::STRING-APPEND + PCL::|__si::MAKE-CACHING| PCL::|__si::MAKE-CONSTANT-VALUE| + PCL::FALSE PCL::|STRUCTURE-OBJECT class constructor| + PCL::PV-WRAPPERS-FROM-PV-ARGS PCL::MAKE-PV-TABLE + PCL::|__si::MAKE-PV-TABLE| PCL::INTERN-PV-TABLE + PCL::CALLED-FIN-WITHOUT-FUNCTION + PCL::|__si::MAKE-STD-INSTANCE| PCL::TRUE + PCL::MAKE-INITIALIZE-INFO PCL::|__si::MAKE-CACHE| + PCL::MAKE-PROGN WALKER::UNBOUND-LEXICAL-FUNCTION + PCL::|__si::MAKE-CLASS-PRECEDENCE-DESCRIPTION| + PCL::MAKE-METHOD-CALL)) +(PROCLAIM + '(FTYPE (FUNCTION (T) *) PCL::TYPE-FROM-SPECIALIZER + PCL::*NORMALIZE-TYPE PCL::UNPARSE-TYPE + PCL::DEFAULT-CODE-CONVERTER PCL::CONVERT-TO-SYSTEM-TYPE + PCL::EMIT-CONSTANT-VALUE PCL::SFUN-P PCL::PCL-DESCRIBE + PCL::GET-GENERIC-FUNCTION-INFO PCL::EARLY-METHOD-FUNCTION + PCL::EARLY-METHOD-STANDARD-ACCESSOR-SLOT-NAME + PCL::SPECIALIZER-FROM-TYPE PCL::CLASS-EQ-TYPE + COMPILER::CAN-USE-PRINT-CIRCLE-P PCL::STRUCTURE-WRAPPER + PCL::FIND-STRUCTURE-CLASS PCL::MAKE-DISPATCH-DFUN + PCL::FIND-WRAPPER PCL::PARSE-DEFMETHOD + PCL::PROTOTYPES-FOR-MAKE-METHOD-LAMBDA + PCL::FORCE-CACHE-FLUSHES PCL::EMIT-ONE-CLASS-READER + PCL::EMIT-ONE-CLASS-WRITER PCL::EMIT-TWO-CLASS-READER + PCL::EMIT-TWO-CLASS-WRITER PCL::EMIT-ONE-INDEX-READERS + PCL::EMIT-ONE-INDEX-WRITERS PCL::NET-CODE-CONVERTER + PCL::EMIT-IN-CHECKING-CACHE-P PCL::COMPILE-IIS-FUNCTIONS + PCL::ANALYZE-LAMBDA-LIST + PCL::COMPUTE-APPLICABLE-METHODS-EMF + PCL::GET-DISPATCH-FUNCTION PCL::INSURE-CACHING-DFUN + PCL::%FBOUNDP PCL::CCLOSUREP PCL::GENERIC-FUNCTION-NAME-P + PCL::MAKE-FINAL-DISPATCH-DFUN + PCL::STRUCTURE-SLOTD-INIT-FORM + PCL::PARSE-METHOD-GROUP-SPECIFIER + PCL::METHOD-PROTOTYPE-FOR-GF + PCL::EARLY-COLLECT-INHERITANCE)) +(PROCLAIM + '(FTYPE (FUNCTION (T) T) PCL::UNENCAPSULATED-FDEFINITION + PCL::DFUN-INFO-P PCL::NO-METHODS-P + PCL::MAKE-TYPE-PREDICATE + PCL::DEFAULT-TEST-CONVERTER PCL::INITIAL-P + PCL::UNPARSE-TYPE-LIST PCL::MAKE-CALL-METHODS + PCL::DEFAULT-CONSTANT-CONVERTER PCL::INITIAL-DISPATCH-P + PCL::DISPATCH-P PCL::GBOUNDP PCL::GMAKUNBOUND + PCL::DEFAULT-CONSTANTP PCL::DEFAULT-METHOD-ONLY-P + PCL::FGEN-TEST PCL::LOOKUP-FGEN PCL::ACCESSOR-DFUN-INFO-P + PCL::FGEN-GENERATOR PCL::FGEN-SYSTEM + PCL::ONE-INDEX-DFUN-INFO-P PCL::FAST-METHOD-CALL-P + PCL::N-N-P PCL::FAST-INSTANCE-BOUNDP-P + PCL::METHOD-FUNCTION-PV-TABLE PCL::METHOD-FUNCTION-METHOD + PCL::STORE-FGEN PCL::ONE-CLASS-P + PCL::METHOD-FUNCTION-NEEDS-NEXT-METHODS-P + PCL::FTYPE-DECLARATION-FROM-LAMBDA-LIST PCL::FGEN-GENSYMS + PCL::TWO-CLASS-P PCL::ARG-INFO-LAMBDA-LIST + PCL::ARG-INFO-PRECEDENCE PCL::ARG-INFO-METATYPES + PCL::FGEN-GENERATOR-LAMBDA SYSTEM:%STRUCTURE-NAME + PCL::ARG-INFO-NUMBER-OPTIONAL + SYSTEM:%COMPILED-FUNCTION-NAME PCL::ARG-INFO-KEY/REST-P + PCL::ONE-INDEX-P PCL::ARG-INFO-KEYWORDS + PCL::GF-INFO-SIMPLE-ACCESSOR-TYPE + PCL::GF-PRECOMPUTE-DFUN-AND-EMF-P + PCL::GF-INFO-STATIC-C-A-M-EMF PCL::CHECKING-P + PCL::GF-INFO-C-A-M-EMF-STD-P PCL::GF-INFO-FAST-MF-P + PCL::UNDEFMETHOD-1 PCL::ARG-INFO-P + PCL::FAST-METHOD-CALL-ARG-INFO PCL::ARG-INFO-NKEYS + PCL::GF-DFUN-CACHE PCL:CLASS-OF PCL::GF-DFUN-INFO + PCL::FUNCTION-RETURNING-NIL + PCL::ACCESSOR-DFUN-INFO-ACCESSOR-TYPE PCL::EVAL-FORM + PCL::ONE-INDEX-DFUN-INFO-INDEX + PCL::SLOT-INITARGS-FROM-STRUCTURE-SLOTD PCL::TYPE-CLASS + PCL::ONE-CLASS-WRAPPER0 PCL::EXTRACT-PARAMETERS + PCL::CLASS-PREDICATE PCL::EXTRACT-REQUIRED-PARAMETERS + PCL::MAKE-CLASS-EQ-PREDICATE PCL::TWO-CLASS-WRAPPER1 + PCL::MAKE-EQL-PREDICATE PCL::CHECKING-FUNCTION + PCL::BOOTSTRAP-ACCESSOR-DEFINITIONS + PCL::INITIALIZE-INFO-KEY PCL::BOOTSTRAP-CLASS-PREDICATES + PCL::GET-BUILT-IN-CLASS-SYMBOL PCL::INITIALIZE-INFO-WRAPPER + PCL::GET-BUILT-IN-WRAPPER-SYMBOL PCL::DO-STANDARD-DEFSETF-1 + PCL::CACHING-P PCL::GFS-OF-TYPE PCL::LEGAL-CLASS-NAME-P + PCL::STRUCTURE-TYPE-P PCL::CONSTANT-VALUE-P + PCL::USE-DEFAULT-METHOD-ONLY-DFUN-P + SYSTEM::NEXT-STACK-FRAME PCL::WRAPPER-FIELD + PCL::NEXT-WRAPPER-FIELD PCL::SETFBOUNDP + PCL::GET-SETF-FUNCTION-NAME PCL::USE-CACHING-DFUN-P + PCL::MAKE-PV-TYPE-DECLARATION + PCL::MAKE-CALLS-TYPE-DECLARATION PCL::MAP-SPECIALIZERS + WALKER:VARIABLE-GLOBALLY-SPECIAL-P PCL::SLOT-VECTOR-SYMBOL + PCL::MAKE-PERMUTATION-VECTOR PCL::STRUCTURE-OBJECT-P + PCL::EXPAND-MAKE-INSTANCE-FORM PCL::MAKE-CONSTANT-FUNCTION + PCL::FUNCTION-RETURNING-T PCL::SORT-SLOTS PCL::SORT-CALLS + PCL::SYMBOL-PKG-NAME + PCL::CLASS-HAS-A-FORWARD-REFERENCED-SUPERCLASS-P + PCL::INITIALIZE-INFO-BOUND-SLOTS + PCL::INITIALIZE-INFO-CACHED-VALID-P + PCL::GET-MAKE-INSTANCE-FUNCTIONS + PCL::INITIALIZE-INFO-CACHED-RI-VALID-P + PCL::INITIALIZE-INFO-CACHED-INITARGS-FORM-LIST + PCL::INITIALIZE-INFO-CACHED-NEW-KEYS + PCL::UPDATE-C-A-M-GF-INFO + PCL::INITIALIZE-INFO-CACHED-DEFAULT-INITARGS-FUNCTION + PCL::UPDATE-GF-SIMPLE-ACCESSOR-TYPE + PCL::UPDATE-GFS-OF-CLASS + PCL::INITIALIZE-INFO-CACHED-SHARED-INITIALIZE-T-FUNCTION + PCL::DO-STANDARD-DEFSETFS-FOR-DEFCLASS + PCL::STANDARD-SVUC-METHOD + PCL::INITIALIZE-INFO-CACHED-SHARED-INITIALIZE-NIL-FUNCTION + PCL:EXTRACT-LAMBDA-LIST PCL::%CCLOSURE-ENV + PCL::STRUCTURE-SVUC-METHOD + PCL::INITIALIZE-INFO-CACHED-CONSTANTS + PCL:EXTRACT-SPECIALIZER-NAMES PCL::METHOD-FUNCTION-PLIST + PCL::INITIALIZE-INFO-CACHED-COMBINED-INITIALIZE-FUNCTION + PCL::INITIALIZE-INFO-CACHED-MAKE-INSTANCE-FUNCTION + PCL::INITIALIZE-INFO-CACHED-MAKE-INSTANCE-FUNCTION-SYMBOL + PCL::INTERNED-SYMBOL-P PCL::GDEFINITION + PCL::UPDATE-CLASS-CAN-PRECEDE-P PCL::%STD-INSTANCE-WRAPPER + PCL::%STD-INSTANCE-SLOTS PCL::PV-TABLEP PCL::STD-INSTANCE-P + PCL::COMPUTE-MCASE-PARAMETERS PCL::COMPUTE-CLASS-SLOTS + PCL::MAKE-PV-TABLE-TYPE-DECLARATION PCL::NET-TEST-CONVERTER + PCL:INTERN-EQL-SPECIALIZER + PCL::MAKE-INSTANCE-FUNCTION-SYMBOL + PCL::UPDATE-ALL-C-A-M-GF-INFO + PCL::UPDATE-PV-TABLE-CACHE-INFO PCL::DFUN-INFO-CACHE + PCL::NO-METHODS-CACHE PCL::ARG-INFO-APPLYP + PCL::INITIAL-CACHE PCL::INITIAL-DISPATCH-CACHE + PCL::CHECK-CACHE PCL::DISPATCH-CACHE PCL::CLASS-FROM-TYPE + PCL::DEFAULT-METHOD-ONLY-CACHE PCL::DNET-METHODS-P + PCL::ACCESSOR-DFUN-INFO-CACHE + PCL::METHOD-FUNCTION-FROM-FAST-FUNCTION + PCL::ONE-INDEX-DFUN-INFO-CACHE + PCL::ONE-INDEX-DFUN-INFO-ACCESSOR-TYPE + PCL::METHOD-CALL-CALL-METHOD-ARGS PCL::KEYWORD-SPEC-NAME + PCL::N-N-CACHE PCL::GENERIC-CLOBBERS-FUNCTION + PCL::N-N-ACCESSOR-TYPE PCL::FAST-METHOD-CALL-PV-CELL + PCL::WRAPPER-FOR-STRUCTURE PCL::ONE-CLASS-CACHE + PCL::FAST-METHOD-CALL-NEXT-METHOD-CALL + PCL::ONE-CLASS-ACCESSOR-TYPE PCL::ONE-CLASS-INDEX + PCL::BUILT-IN-WRAPPER-OF PCL::TWO-CLASS-CACHE + PCL::BUILT-IN-OR-STRUCTURE-WRAPPER1 + PCL::TWO-CLASS-ACCESSOR-TYPE PCL::TWO-CLASS-INDEX + PCL::ALLOCATE-CACHE-VECTOR PCL::TWO-CLASS-WRAPPER0 + PCL::FLUSH-CACHE-VECTOR-INTERNAL PCL::ONE-INDEX-CACHE + PCL::EARLY-CLASS-NAME PCL::ONE-INDEX-ACCESSOR-TYPE + PCL::ONE-INDEX-INDEX PCL::INTERN-FUNCTION-NAME + PCL::CHECKING-CACHE PCL::COMPILE-LAMBDA-UNCOMPILED + PCL::GF-LAMBDA-LIST PCL::CACHING-CACHE + PCL::CONSTANT-VALUE-CACHE PCL::COMPILE-LAMBDA-DEFERRED + PCL::FUNCALLABLE-INSTANCE-P + PCL::RESET-CLASS-INITIALIZE-INFO PCL::GET-CACHE-VECTOR + PCL::CONSTANT-SYMBOL-P PCL::FREE-CACHE-VECTOR + PCL::EARLY-METHOD-LAMBDA-LIST PCL::ARG-INFO-VALID-P + PCL::DFUN-ARG-SYMBOL PCL::EARLY-METHOD-CLASS + PCL::EARLY-GF-P PCL::EARLY-GF-NAME PCL::CACHING-DFUN-INFO + PCL::COMPUTE-APPLICABLE-METHODS-EMF-STD-P + PCL::CONSTANT-VALUE-DFUN-INFO + PCL::RESET-CLASS-INITIALIZE-INFO-1 PCL::FREE-CACHE + PCL::PARSE-SPECIALIZERS PCL::RESET-INITIALIZE-INFO + PCL::EARLY-METHOD-QUALIFIERS + PCL::PROCLAIM-INCOMPATIBLE-SUPERCLASSES PCL::WRAPPER-OF + PCL::EARLY-METHOD-STANDARD-ACCESSOR-P + PCL::FUNCTION-PRETTY-ARGLIST + PCL::GET-MAKE-INSTANCE-FUNCTION PCL::CHECK-WRAPPER-VALIDITY + PCL::UNPARSE-SPECIALIZERS PCL::%SYMBOL-FUNCTION + PCL::FINAL-ACCESSOR-DFUN-TYPE + PCL::COMPLICATED-INSTANCE-CREATION-METHOD + PCL::DEFAULT-STRUCTUREP PCL::UPDATE-GF-INFO + PCL::CACHE-OWNER PCL::DEFAULT-STRUCTURE-INSTANCE-P + PCL::DEFAULT-STRUCTURE-TYPE PCL::STRUCTURE-TYPE + PCL::COMPUTE-STD-CPL-PHASE-2 PCL::GET-PV-CELL-FOR-CLASS + PCL::STRUCTURE-TYPE-INCLUDED-TYPE-NAME + PCL::STRUCTURE-TYPE-SLOT-DESCRIPTION-LIST PCL::CACHE-P + PCL::STRUCTURE-SLOTD-NAME + PCL::STRUCTURE-SLOTD-ACCESSOR-SYMBOL + PCL::DEFAULT-SECONDARY-DISPATCH-FUNCTION + PCL::STRUCTURE-SLOTD-WRITER-FUNCTION + PCL::FIND-CYCLE-REASONS PCL::EARLY-CLASS-DEFINITION + PCL::ECD-SOURCE PCL::STRUCTURE-SLOTD-TYPE + PCL::FORMAT-CYCLE-REASONS PCL::ECD-METACLASS PCL::CPD-CLASS + PCL::EARLY-CLASS-PRECEDENCE-LIST + PCL::METHODS-CONTAIN-EQL-SPECIALIZER-P PCL::CPD-SUPERS + PCL::EXPAND-LONG-DEFCOMBIN PCL::EARLY-CLASS-NAME-OF + PCL::CPD-AFTER PCL::EXPAND-SHORT-DEFCOMBIN + PCL::EARLY-CLASS-SLOTDS PCL::CPD-COUNT + PCL::EARLY-SLOT-DEFINITION-NAME PCL::SLOT-READER-SYMBOL + PCL::EARLY-SLOT-DEFINITION-LOCATION WALKER::ENV-LOCK + PCL::MAKE-INITIAL-DFUN PCL::EARLY-ACCESSOR-METHOD-SLOT-NAME + PCL::SLOT-WRITER-SYMBOL WALKER::ENV-DECLARATIONS + WALKER::ENV-LEXICAL-VARIABLES PCL::LIST-DFUN + PCL::SLOT-BOUNDP-SYMBOL PCL::MAP-ALL-GENERIC-FUNCTIONS + PCL::MAKE-STRUCTURE-SLOT-BOUNDP-FUNCTION + PCL::EARLY-CLASS-DIRECT-SUBCLASSES + PCL::MAKE-FUNCTION-INLINE PCL::LIST-LARGE-CACHE + PCL::CLASS-PRECEDENCE-DESCRIPTION-P + PCL::INFORM-TYPE-SYSTEM-ABOUT-STD-CLASS + PCL::MAKE-DEFAULT-METHOD-GROUP-DESCRIPTION + PCL::MAKE-OPTIMIZED-STRUCTURE-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION + WALKER::ENV-WALK-FUNCTION + WALKER::GET-IMPLEMENTATION-DEPENDENT-WALKER-TEMPLATE + PCL::COUNT-DFUN PCL::MAKE-INITFUNCTION + PCL::MAKE-OPTIMIZED-STRUCTURE-SETF-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION + ITERATE::VARIABLES-FROM-LET WALKER::ENV-WALK-FORM + PCL::MAKE-OPTIMIZED-STRUCTURE-SLOT-BOUNDP-USING-CLASS-METHOD-FUNCTION + PCL::INITIALIZE-INFO-P PCL::ECD-CLASS-NAME PCL::COPY-CACHE + PCL::COMPUTE-LINE-SIZE PCL::CANONICAL-SLOT-NAME + WALKER::GET-WALKER-TEMPLATE PCL::EARLY-CLASS-SLOTS + PCL::STRUCTURE-TYPE-INTERNAL-SLOTDS PCL::EARLY-COLLECT-CPL + PCL::EARLY-COLLECT-SLOTS + PCL::METHOD-LL->GENERIC-FUNCTION-LL + PCL::EARLY-COLLECT-DEFAULT-INITARGS + PCL::ECD-SUPERCLASS-NAMES PCL::METHOD-CALL-P + PCL::STRUCTURE-SLOT-BOUNDP ITERATE::SEQUENCE-ACCESSOR + PCL::ECD-CANONICAL-SLOTS PCL::ECD-OTHER-INITARGS)) +(PROCLAIM + '(FTYPE (FUNCTION (T *) *) PCL::COERCE-TO-CLASS + PCL::GET-METHOD-FUNCTION WALKER:MACROEXPAND-ALL + PCL::GET-FUNCTION PCL::GET-FUNCTION1 + PCL:ENSURE-GENERIC-FUNCTION PCL::PARSE-METHOD-OR-SPEC + PCL::EXTRACT-DECLARATIONS PCL::GET-DFUN-CONSTRUCTOR + PCL::MAP-ALL-CLASSES PCL::MAKE-CACHING-DFUN + WALKER:WALK-FORM PCL:ENSURE-CLASS + PCL::MAKE-METHOD-FUNCTION-INTERNAL + PCL::PARSE-SPECIALIZED-LAMBDA-LIST + PCL::MAKE-METHOD-LAMBDA-INTERNAL + PCL::MAKE-CONSTANT-VALUE-DFUN PCL::MAKE-FINAL-DFUN-INTERNAL + PCL::COMPILE-LAMBDA)) +(PROCLAIM '(FTYPE (FUNCTION (T T *) (VALUES T T)) PCL::SYMBOL-APPEND)) +(PROCLAIM '(FTYPE (FUNCTION (T *) STRING) PCL::CAPITALIZE-WORDS)) +(PROCLAIM + '(FTYPE (FUNCTION (T T) *) PCL::SAUT-CLASS + PCL::SPECIALIZER-APPLICABLE-USING-TYPE-P PCL::*TYPEP + PCL::COMPUTE-TEST PCL::GET-NEW-FUNCTION-GENERATOR-INTERNAL + PCL::COMPUTE-CODE PCL::CLASS-APPLICABLE-USING-CLASS-P + PCL::SAUT-AND PCL::SAUT-NOT PCL::SAUT-PROTOTYPE + COMPILER::CAN-USE-PRINT-CIRCLE-P1 PCL:SLOT-BOUNDP + PCL::DESTRUCTURE PCL:SLOT-MAKUNBOUND PCL:SLOT-VALUE + PCL::ENSURE-CLASS-VALUES PCL::MAKE-DIRECT-SLOTD + PCL::GENERATE-FAST-CLASS-SLOT-ACCESS-P + PCL::MUTATE-SLOTS-AND-CALLS PCL::INVOKE-EMF + PCL::EMIT-DEFAULT-ONLY-FUNCTION PCL::SPLIT-DECLARATIONS + PCL::EMIT-DEFAULT-ONLY COMPILER::C2LAMBDA-EXPR-WITH-KEY + PCL::SLOT-NAME-LISTS-FROM-SLOTS PCL::EMIT-CHECKING + PCL::UPDATE-SLOT-VALUE-GF-INFO PCL::EMIT-CACHING + PCL::SDFUN-FOR-CACHING PCL::SLOT-UNBOUND-INTERNAL + PCL::MAKE-INSTANCE-1 PCL::SET-FUNCTION-NAME + PCL::COMPUTE-STD-CPL-PHASE-1 PCL::FORM-LIST-TO-LISP + PCL::FIND-SUPERCLASS-CHAIN PCL::SAUT-CLASS-EQ + PCL::COMPUTE-APPLICABLE-METHODS-USING-TYPES + PCL::CHECK-INITARGS-VALUES PCL::SAUT-EQL PCL::*SUBTYPEP + ITERATE::PARSE-DECLARATIONS PCL::INITIAL-DFUN)) +(PROCLAIM + '(FTYPE (FUNCTION (T *) T) PCL::MAKE-TYPE-PREDICATE-NAME + PCL::SET-DFUN PCL:FIND-CLASS PCL::TRACE-METHOD + PCL::FIND-CLASS-CELL PCL::MAKE-FINAL-DFUN + PCL::PV-TABLE-LOOKUP-PV-ARGS PCL::USE-DISPATCH-DFUN-P + WALKER::RELIST* WALKER::RELIST PCL::FIND-CLASS-PREDICATE + PCL::EARLY-METHOD-SPECIALIZERS + PCL::USE-CONSTANT-VALUE-DFUN-P PCL::MAKE-EARLY-GF + PCL::ALLOCATE-FUNCALLABLE-INSTANCE PCL::SET-ARG-INFO + PCL::INITIALIZE-METHOD-FUNCTION PCL::UPDATE-DFUN + PCL::MAKE-SPECIALIZABLE PCL::ALLOCATE-STRUCTURE-INSTANCE + PCL::ALLOCATE-STANDARD-INSTANCE + WALKER::WALKER-ENVIRONMENT-BIND-1 + ITERATE::FUNCTION-LAMBDA-P ITERATE::MAYBE-WARN + PCL::MAKE-WRAPPER)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T) (*)) PCL::SORT-APPLICABLE-METHODS + PCL::SORT-METHODS)) +(PROCLAIM + '(FTYPE (FUNCTION (T T) T) PCL::FDEFINE-CAREFULLY + PCL::MAKE-INTERNAL-READER-METHOD-FUNCTION + PCL::MAKE-STD-READER-METHOD-FUNCTION + PCL::MAKE-STD-WRITER-METHOD-FUNCTION + ITERATE::SIMPLE-EXPAND-ITERATE-FORM + PCL::MAKE-STD-BOUNDP-METHOD-FUNCTION + PCL::DO-SATISFIES-DEFTYPE PCL::MEMF-CONSTANT-CONVERTER + PCL::COMPUTE-CONSTANTS PCL::CLASS-CAN-PRECEDE-P + PCL::SAUT-NOT-CLASS PCL::SAUT-NOT-CLASS-EQ + PCL::SAUT-NOT-PROTOTYPE PCL::GF-MAKE-FUNCTION-FROM-EMF + PCL::SAUT-NOT-EQL PCL::SUPERCLASSES-COMPATIBLE-P + PCL::CLASSES-HAVE-COMMON-SUBCLASS-P + SYSTEM:%SET-COMPILED-FUNCTION-NAME PCL:ADD-METHOD + SYSTEM::DISPLAY-ENV PCL::DESCRIBE-PACKAGE + SYSTEM::DISPLAY-COMPILED-ENV + PCL::PRINTING-RANDOM-THING-INTERNAL + PCL::MAKE-CLASS-PREDICATE + PCL::METHOD-FUNCTION-RETURNING-NIL + PCL::METHOD-FUNCTION-RETURNING-T PCL::VARIABLE-CLASS + PCL::MAKE-PLIST PCL::REMTAIL PCL:REMOVE-METHOD + PCL:SLOT-EXISTS-P PCL::DESTRUCTURE-INTERNAL + PCL::ACCESSOR-MISS-FUNCTION + PCL::UPDATE-INITIALIZE-INFO-INTERNAL PCL::N-N-DFUN-INFO + PCL::MAKE-CAXR PCL::MAKE-CDXR WALKER:VARIABLE-LEXICAL-P + WALKER:VARIABLE-SPECIAL-P PCL::CHECKING-DFUN-INFO + PCL::MAKE-PV-TABLE-INTERNAL PCL::FIND-SLOT-DEFINITION + WALKER::WALK-REPEAT-EVAL WALKER::NOTE-DECLARATION + PCL::MAKE-DFUN-LAMBDA-LIST WALKER::NOTE-LEXICAL-BINDING + PCL::MAKE-DLAP-LAMBDA-LIST PCL::ADD-DIRECT-SUBCLASSES + PCL::COMPUTE-PV PCL::MAKE-DFUN-ARG-LIST PCL::COMPUTE-CALLS + PCL::MAKE-FAST-METHOD-CALL-LAMBDA-LIST + PCL::UPDATE-ALL-PV-TABLE-CACHES PCL::UPDATE-CLASS + PCL::MAP-PV-TABLE-REFERENCES-OF PCL::ADD-SLOT-ACCESSORS + WALKER::ENVIRONMENT-FUNCTION PCL::REMOVE-DIRECT-SUBCLASSES + PCL::REMOVE-SLOT-ACCESSORS PCL::SYMBOL-LESSP + PCL::SYMBOL-OR-CONS-LESSP PCL::|SETF PCL FIND-CLASS| + PCL::|SETF PCL FIND-CLASS-PREDICATE| + PCL::PV-WRAPPERS-FROM-ALL-ARGS PCL::PV-TABLE-LOOKUP + PCL::PROCLAIM-DEFGENERIC PCL::UPDATE-CPL PCL::LIST-EQ + PCL::UPDATE-SLOTS PCL::COMPUTE-APPLICABLE-METHODS-FUNCTION + PCL::COMPUTE-EMF-FROM-WRAPPERS PCL::UPDATE-INITS + PCL::UPDATE-STD-OR-STR-METHODS + PCL::SET-STANDARD-SVUC-METHOD PCL::EMIT-1-NIL-DLAP + PCL::PLIST-VALUE PCL::SET-STRUCTURE-SVUC-METHOD + PCL::EMIT-1-WRAPPER-COMPUTE-PRIMARY-CACHE-LOCATION + PCL:FUNCALLABLE-STANDARD-INSTANCE-ACCESS + PCL::MEC-ALL-CLASSES-INTERNAL + PCL::EMIT-N-WRAPPER-COMPUTE-PRIMARY-CACHE-LOCATION + PCL::MEC-ALL-CLASSES PCL::%SET-CCLOSURE-ENV + PCL::MEC-ALL-CLASS-LISTS PCL::REDEFINE-FUNCTION + PCL::METHODS-CONVERTER PCL::COMPUTE-LAYOUT PCL::NO-SLOT + PCL::PV-WRAPPERS-FROM-ALL-WRAPPERS + PCL::NET-CONSTANT-CONVERTER PCL::AUGMENT-TYPE + PCL::CHANGE-CLASS-INTERNAL + PCL:SET-FUNCALLABLE-INSTANCE-FUNCTION + PCL::VALUE-FOR-CACHING PCL:STANDARD-INSTANCE-ACCESS + PCL::|SETF PCL METHOD-FUNCTION-PLIST| PCL::GET-KEY-ARG + PCL::GET-KEY-ARG1 PCL::SET-METHODS + PCL::SET-FUNCTION-PRETTY-ARGLIST + PCL::FIND-STANDARD-II-METHOD PCL::MAKE-EARLY-ACCESSOR + PCL::DOCTOR-DFUN-FOR-THE-DEBUGGER PCL::COMPUTE-STD-CPL + PCL::|SETF PCL GDEFINITION| + PCL::MAKE-DISCRIMINATING-FUNCTION-ARGLIST PCL::ADD-FORMS + PCL::CPL-INCONSISTENT-ERROR + PCL::REDIRECT-EARLY-FUNCTION-INTERNAL PCL::ADD-TO-CVECTOR + PCL::BOOTSTRAP-SLOT-INDEX PCL::QUALIFIER-CHECK-RUNTIME + PCL::CPL-FORWARD-REFERENCED-CLASS-ERROR + PCL::REAL-REMOVE-METHOD WALKER::ENVIRONMENT-MACRO + PCL::CANONICALIZE-SLOT-SPECIFICATION + PCL::CANONICALIZE-DEFCLASS-OPTION PCL::SET-WRAPPER + PCL::DEAL-WITH-ARGUMENTS-OPTION + PCL::PARSE-QUALIFIER-PATTERN PCL::SWAP-WRAPPERS-AND-SLOTS + ITERATE::MV-SETQ PCL::MAKE-UNORDERED-METHODS-EMF + PCL::CLASS-MIGHT-PRECEDE-P + ITERATE::EXTRACT-SPECIAL-BINDINGS + WALKER::VARIABLE-SYMBOL-MACRO-P PCL::RAISE-METATYPE)) +(PROCLAIM '(FTYPE (FUNCTION NIL FIXNUM) PCL::GET-WRAPPER-CACHE-NUMBER)) +(DOLIST (PCL::V '(PCL::ADD-READER-METHOD + PCL::SHORT-COMBINATION-IDENTITY-WITH-ONE-ARGUMENT + PCL::REMOVE-READER-METHOD PCL::EQL-SPECIALIZER-P + PCL::OBJECT-PLIST + PCL::SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL + PCL::SPECIALIZER-TYPE PCL::GF-DFUN-STATE + PCL::CLASS-DEFSTRUCT-CONSTRUCTOR + PCL::METHOD-FAST-FUNCTION PCL::SPECIALIZERP + PCL::EXACT-CLASS-SPECIALIZER-P + PCL::COMPATIBLE-META-CLASS-CHANGE-P + PCL::UPDATE-GF-DFUN PCL::SPECIALIZER-OBJECT + PCL::ACCESSOR-METHOD-SLOT-NAME + PCL::SPECIALIZER-CLASS PCL::CLASS-EQ-SPECIALIZER-P + PCL::SLOTS-FETCHER PCL::REMOVE-WRITER-METHOD + PCL::STRUCTURE-CLASS-P PCL::UPDATE-CONSTRUCTORS + PCL::DOCUMENTATION PCL::METHOD-PRETTY-ARGLIST + PCL::CLASS-EQ-SPECIALIZER + PCL::INFORM-TYPE-SYSTEM-ABOUT-CLASS + PCL::ACCESSOR-METHOD-CLASS + PCL::GENERIC-FUNCTION-PRETTY-ARGLIST + PCL::MAKE-BOUNDP-METHOD-FUNCTION + PCL::CLASS-PREDICATE-NAME PCL::CLASSP + PCL::LEGAL-QUALIFIERS-P PCL::ADD-BOUNDP-METHOD + PCL::LEGAL-LAMBDA-LIST-P + PCL::|SETF PCL GENERIC-FUNCTION-NAME| + PCL::DESCRIBE-OBJECT PCL::CLASS-INITIALIZE-INFO + PCL::MAKE-WRITER-METHOD-FUNCTION + PCL::|SETF PCL GF-DFUN-STATE| + PCL::|SETF PCL SLOT-DEFINITION-NAME| + PCL::|SETF PCL CLASS-NAME| + PCL::INITIALIZE-INTERNAL-SLOT-FUNCTIONS + PCL::|SETF PCL SLOT-DEFINITION-TYPE| + PCL::METHOD-COMBINATION-P + PCL::|SETF PCL GENERIC-FUNCTION-METHODS| + PCL::|SETF PCL GENERIC-FUNCTION-METHOD-COMBINATION| + PCL::|SETF PCL METHOD-GENERIC-FUNCTION| + PCL::|SETF PCL SLOT-ACCESSOR-STD-P| + PCL::LEGAL-SPECIALIZERS-P + PCL::|SETF PCL OBJECT-PLIST| + PCL::|SETF PCL SLOT-DEFINITION-INITFORM| + PCL::|SETF PCL CLASS-DEFSTRUCT-FORM| + PCL::|SETF PCL GENERIC-FUNCTION-METHOD-CLASS| + PCL::SLOT-ACCESSOR-STD-P + PCL::|SETF PCL GF-PRETTY-ARGLIST| + PCL::|SETF PCL SLOT-ACCESSOR-FUNCTION| + PCL::|SETF PCL SLOT-DEFINITION-LOCATION| + PCL::|SETF PCL SLOT-DEFINITION-READER-FUNCTION| + PCL::|SETF PCL SLOT-DEFINITION-WRITER-FUNCTION| + PCL::|SETF PCL SLOT-DEFINITION-BOUNDP-FUNCTION| + PCL::|SETF PCL SLOT-DEFINITION-INTERNAL-READER-FUNCTION| + PCL::|SETF PCL SLOT-DEFINITION-INTERNAL-WRITER-FUNCTION| + PCL::|SETF PCL SLOT-DEFINITION-ALLOCATION| + PCL::|SETF PCL SLOT-DEFINITION-INITFUNCTION| + PCL::METHOD-COMBINATION-OPTIONS + PCL::|SETF PCL SLOT-DEFINITION-READERS| + PCL::|SETF PCL DOCUMENTATION| + PCL::FUNCALLABLE-STANDARD-CLASS-P + PCL::|SETF PCL SLOT-DEFINITION-CLASS| + PCL::|SETF PCL SLOT-VALUE-USING-CLASS| + PCL::CLASS-CAN-PRECEDE-LIST + PCL::|SETF PCL CLASS-DIRECT-SLOTS| + PCL::|SETF PCL CLASS-SLOTS| + PCL::SLOT-ACCESSOR-FUNCTION + PCL::|SETF PCL CLASS-INCOMPATIBLE-SUPERCLASS-LIST| + PCL::|SETF PCL SLOT-DEFINITION-WRITERS| + PCL::SLOT-CLASS-P PCL::MAKE-READER-METHOD-FUNCTION + PCL::LEGAL-METHOD-FUNCTION-P PCL::GET-METHOD + PCL::SHORT-METHOD-COMBINATION-P PCL::GF-ARG-INFO + PCL::SPECIALIZER-METHOD-TABLE + PCL::MAKE-METHOD-INITARGS-FORM + PCL::CLASS-DEFSTRUCT-FORM PCL::GF-PRETTY-ARGLIST + PCL::SAME-SPECIALIZER-P + PCL::SLOT-DEFINITION-BOUNDP-FUNCTION + PCL::SLOT-DEFINITION-WRITER-FUNCTION + PCL::SLOT-DEFINITION-READER-FUNCTION + PCL::SLOT-DEFINITION-INTERNAL-WRITER-FUNCTION + PCL::SLOT-DEFINITION-INTERNAL-READER-FUNCTION + PCL::SLOT-DEFINITION-CLASS + PCL::EQL-SPECIALIZER-OBJECT + PCL::CLASS-CONSTRUCTORS PCL::SLOTS-TO-INSPECT + PCL::SPECIALIZER-DIRECT-GENERIC-FUNCTIONS + PCL::ADD-WRITER-METHOD + PCL::LONG-METHOD-COMBINATION-FUNCTION + PCL::GENERIC-FUNCTION-P PCL::LEGAL-SLOT-NAME-P + PCL::CLASS-WRAPPER PCL::DEFINITION-SOURCE + PCL::DEFAULT-INITARGS PCL::CLASS-SLOT-VALUE + PCL::FORWARD-REFERENCED-CLASS-P + PCL::GF-FAST-METHOD-FUNCTION-P + PCL::LEGAL-QUALIFIER-P PCL::METHOD-P + PCL::CLASS-SLOT-CELLS + PCL::STANDARD-ACCESSOR-METHOD-P + PCL::STANDARD-GENERIC-FUNCTION-P + PCL::STANDARD-READER-METHOD-P + PCL::STANDARD-METHOD-P + PCL::COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS + PCL::COMPUTE-DEFAULT-INITARGS + PCL::|SETF PCL CLASS-SLOT-VALUE| + PCL::METHOD-COMBINATION-TYPE PCL::STANDARD-CLASS-P + PCL::LEGAL-SPECIALIZER-P + PCL::COMPUTE-SLOT-ACCESSOR-INFO + PCL::STANDARD-BOUNDP-METHOD-P + PCL::RAW-INSTANCE-ALLOCATOR + PCL::|SETF PCL SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL| + PCL::|SETF PCL CLASS-INITIALIZE-INFO| + PCL::COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO + PCL::STANDARD-WRITER-METHOD-P + PCL::CLASS-INCOMPATIBLE-SUPERCLASS-LIST + PCL::WRAPPER-FETCHER + PCL::METHOD-COMBINATION-DOCUMENTATION + PCL::|SETF PCL SLOT-DEFINITION-INITARGS| + PCL::REMOVE-BOUNDP-METHOD + PCL::|SETF PCL CLASS-DEFSTRUCT-CONSTRUCTOR| + PCL::SHORT-COMBINATION-OPERATOR + PCL::REMOVE-NAMED-METHOD + PCL::LEGAL-DOCUMENTATION-P + PCL:CLASS-DIRECT-SUPERCLASSES + PCL:CLASS-DIRECT-SUBCLASSES + PCL:CLASS-DIRECT-DEFAULT-INITARGS + PCL:SLOT-DEFINITION-READERS + PCL:SLOT-VALUE-USING-CLASS + PCL:COMPUTE-APPLICABLE-METHODS PCL:CLASS-NAME + PCL:CLASS-PROTOTYPE PCL:READER-METHOD-CLASS + PCL:REMOVE-METHOD PCL:SLOT-DEFINITION-INITFORM + PCL:UPDATE-INSTANCE-FOR-REDEFINED-CLASS + PCL:UPDATE-INSTANCE-FOR-DIFFERENT-CLASS + PCL:CHANGE-CLASS PCL:METHOD-FUNCTION + PCL:DIRECT-SLOT-DEFINITION-CLASS + PCL:MAKE-METHOD-LAMBDA + PCL:EFFECTIVE-SLOT-DEFINITION-CLASS + PCL:CLASS-SLOTS PCL:COMPUTE-SLOTS + PCL:SLOT-DEFINITION-NAME PCL:FINALIZE-INHERITANCE + PCL:GENERIC-FUNCTION-LAMBDA-LIST + PCL:CLASS-DIRECT-SLOTS PCL:CLASS-DEFAULT-INITARGS + PCL:COMPUTE-DISCRIMINATING-FUNCTION + PCL:CLASS-FINALIZED-P PCL:GENERIC-FUNCTION-NAME + PCL:REMOVE-DEPENDENT + PCL:COMPUTE-CLASS-PRECEDENCE-LIST + PCL:ADD-DEPENDENT PCL:SLOT-BOUNDP-USING-CLASS + PCL:ACCESSOR-METHOD-SLOT-DEFINITION + PCL:SHARED-INITIALIZE PCL:ADD-DIRECT-METHOD + PCL:SLOT-DEFINITION-LOCATION + PCL:SLOT-DEFINITION-INITFUNCTION + PCL:SLOT-DEFINITION-ALLOCATION PCL:ADD-METHOD + PCL:GENERIC-FUNCTION-METHOD-CLASS + PCL:METHOD-SPECIALIZERS + PCL:SLOT-DEFINITION-INITARGS + PCL:WRITER-METHOD-CLASS PCL:ADD-DIRECT-SUBCLASS + PCL:SPECIALIZER-DIRECT-METHODS + PCL:GENERIC-FUNCTION-METHOD-COMBINATION + PCL:ALLOCATE-INSTANCE PCL:COMPUTE-EFFECTIVE-METHOD + PCL:SLOT-DEFINITION-TYPE PCL:SLOT-UNBOUND + PCL:INITIALIZE-INSTANCE PCL:FUNCTION-KEYWORDS + PCL:REINITIALIZE-INSTANCE PCL:VALIDATE-SUPERCLASS + PCL:GENERIC-FUNCTION-METHODS + PCL:REMOVE-DIRECT-METHOD PCL:METHOD-LAMBDA-LIST + PCL:MAKE-INSTANCE + PCL:COMPUTE-EFFECTIVE-SLOT-DEFINITION + PCL:PRINT-OBJECT PCL:METHOD-QUALIFIERS + PCL:METHOD-GENERIC-FUNCTION + PCL:REMOVE-DIRECT-SUBCLASS + PCL:MAKE-INSTANCES-OBSOLETE + PCL:SLOT-MAKUNBOUND-USING-CLASS + PCL:ENSURE-GENERIC-FUNCTION-USING-CLASS + PCL:SLOT-MISSING PCL:MAP-DEPENDENTS + PCL:FIND-METHOD-COMBINATION + PCL:ENSURE-CLASS-USING-CLASS + PCL:NO-APPLICABLE-METHOD + PCL:SLOT-DEFINITION-WRITERS + PCL:COMPUTE-APPLICABLE-METHODS-USING-CLASSES + PCL:CLASS-PRECEDENCE-LIST)) + (SETF (GET PCL::V 'COMPILER::PROCLAIMED-CLOSURE) T)) diff --git a/pcl/impl/kcl/sysdef.lisp b/pcl/impl/kcl/sysdef.lisp new file mode 100644 index 0000000..9da68cd --- /dev/null +++ b/pcl/impl/kcl/sysdef.lisp @@ -0,0 +1,121 @@ +;;; -*- Mode: Lisp; Base: 10; Syntax: Common-Lisp; Package: DSYS -*- +;;; File: sysdef.lisp +;;; Author: Richard Harris + +(in-package "DSYS") + +(defvar *pcl-compiled-p* nil) +(defvar *pcl-loaded-p* nil) + +(unless (boundp 'pcl::*redefined-functions*) + (setq pcl::*redefined-functions* nil)) + +(defun reset-pcl-package () + (pcl::reset-pcl-package) + (let ((defsys (subfile '("pcl") :name "defsys"))) + (setq pcl::*pcl-directory* defsys) + (load-file defsys)) + (mapc #'(lambda (path) + (setf (lfi-fwd (get-loaded-file-info path)) 0)) + (pcl-binary-files))) + +(defun pcl-binary-files () + (pcl::system-binary-files 'pcl::pcl)) + +(defun maybe-load-defsys (&optional compile-defsys-p) + (let ((defsys (subfile '("pcl") :name "defsys")) + (*use-default-pathname-type* nil) + (*skip-load-if-loaded-p* t) + (*skip-compile-file-fwd* 0)) + (set 'pcl::*pcl-directory* defsys) + (when compile-defsys-p + (compile-file defsys)) + (let ((b-s 'pcl::*boot-state*)) + (when (and (boundp b-s) (symbol-value b-s)) + #+ignore (reset-pcl-package))) + (load-file defsys))) + +(defun maybe-load-pcl (&optional force-p) + (unless (and (null force-p) + (fboundp 'pcl::system-binary-files) + (every #'(lambda (path) + (let* ((path-fwd (file-write-date path)) + (lfi (get-loaded-file-info path))) + (and lfi path-fwd (= path-fwd (lfi-fwd lfi))))) + (pcl-binary-files))) + (let ((b-s 'pcl::*boot-state*)) + (when (and (boundp b-s) (symbol-value b-s)) + (reset-pcl-package))) + (pcl::load-pcl))) + +(defsystem pcl + (:pretty-name "PCL") + #+akcl + (:forms + :compile (let ((cfn (subfile '("pcl") :name "collectfn" :type "lisp"))) + (unless (probe-file cfn) + (run-unix-command + (format nil "ln -s ~A ~A" + (namestring (merge-pathnames "../cmpnew/collectfn.lsp" + si::*system-directory*)) + (namestring cfn)))))) + + #+akcl + "collectfn" + (:forms + :compile + (progn + (maybe-load-defsys t) + (if (and (fboundp 'pcl::operation-transformations) + (or (null (probe-file (subfile '("pcl") :name "defsys" :type "lisp"))) + (every #'(lambda (trans) + (eq (car trans) :load)) + (pcl::operation-transformations 'pcl::pcl :compile)))) + (maybe-load-pcl) + (let ((b-s 'pcl::*boot-state*)) + (when (and (boundp b-s) (symbol-value b-s)) + (reset-pcl-package)) + #+akcl (compiler::emit-fn t) + #+akcl (load (merge-pathnames "../lsp/sys-proclaim.lisp" + si::*system-directory*)) + (#+cmu with-compilation-unit #-cmu progn + #+cmu (:optimize + '(optimize (user::debug-info #+(and small (not testing)) .5 + #-(and small (not testing)) 2) + (speed #+testing 1 #-testing 2) + (safety #+testing 3 #-testing 0) + #+ignore (user::inhibit-warnings 2)) + :context-declarations + '(#+ignore + (:external (declare (user::optimize-interface + (safety 2) (debug-info 1)))))) + (proclaim #+testing *testing-declaration* + #-testing *fast-declaration*) + (pcl::compile-pcl)) + (reset-pcl-package) + (maybe-load-pcl t))) + #+cmu (purify)) + :load + (progn + (maybe-load-pcl) + #+cmu (purify)))) + +(defparameter *pcl-files* + '((("systems") "lisp" + "pcl") + (("pcl") "lisp" + "sysdef" + "boot" "braid" "cache" "cloe-low" "cmu-low" "combin" "compat" + "construct" "coral-low" "cpatch" "cpl" "ctypes" "defclass" "defcombin" + "defs" "defsys" "dfun" "dlap" "env" "excl-low" "fin" "fixup" "fngen" "fsc" + "gcl-patches" "genera-low" "gold-low" "hp-low" "ibcl-low" "ibcl-patches" + "init" "iterate" "kcl-low" "kcl-patches" "lap" "low" "lucid-low" "macros" + "methods" "pcl-env-internal" "pcl-env" "pkg" "plap" "precom1" "precom2" + "precom4" "pyr-low" "pyr-patches" "quadlap" "rel-7-2-patches" "rel-8-patches" + "slots" "std-class" "sys-proclaim" "ti-low" "ti-patches" "vaxl-low" "vector" "walk" + "xerox-low" "xerox-patches") + (("pcl") "text" + "12-7-88-notes" "3-17-88-notes" "3-19-87-notes" "4-21-87-notes" + "4-29-87-notes" "5-22-87-notes" "5-22-89-notes" "8-28-88-notes" + "get-pcl" "kcl-mods" "kcl-notes" "lap" "notes" "pcl-env" "readme"))) + diff --git a/pcl/impl/lucid/lucid-low.lisp b/pcl/impl/lucid/lucid-low.lisp new file mode 100644 index 0000000..ec47357 --- /dev/null +++ b/pcl/impl/lucid/lucid-low.lisp @@ -0,0 +1,384 @@ +;;; -*- Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; +;;; This is the Lucid lisp version of the file portable-low. +;;; +;;; Lucid: (415)329-8400 +;;; + +(in-package 'pcl) + +;;; First, import some necessary "internal" or Lucid-specific symbols + +(eval-when (eval compile load) + +(#-LCL3.0 progn #+LCL3.0 lcl:handler-bind + #+LCL3.0 ((lcl:warning #'(lambda (condition) + (declare (ignore condition)) + (lcl:muffle-warning)))) +(let ((importer + #+LCL3.0 #'sys:import-from-lucid-pkg + #-LCL3.0 (let ((x (find-symbol "IMPORT-FROM-LUCID-PKG" "LUCID"))) + (if (and x (fboundp x)) + (symbol-function x) + ;; Only the #'(lambda (x) ...) below is really needed, + ;; but when available, the "internal" function + ;; 'import-from-lucid-pkg' provides better checking. + #'(lambda (name) + (import (intern name "LUCID"))))))) + ;; + ;; We need the following "internal", undocumented Lucid goodies: + (mapc importer '("%POINTER" "DEFSTRUCT-SIMPLE-PREDICATE" + #-LCL3.0 "LOGAND&" "%LOGAND&" #+VAX "LOGAND&-VARIABLE")) + + ;; + ;; For without-interrupts. + ;; + #+LCL3.0 + (mapc importer '("*SCHEDULER-WAKEUP*" "MAYBE-CALL-SCHEDULER")) + + ;; + ;; We import the following symbols, because in 2.1 Lisps they have to be + ;; accessed as SYS:, whereas in 3.0 lisps, they are homed in the + ;; LUCID-COMMON-LISP package. + (mapc importer '("ARGLIST" "NAMED-LAMBDA" "*PRINT-STRUCTURE*")) + ;; + ;; We import the following symbols, because in 2.1 Lisps they have to be + ;; accessed as LUCID::, whereas in 3.0 lisps, they have to be + ;; accessed as SYS: + (mapc importer '( + "NEW-STRUCTURE" "STRUCTURE-REF" + "STRUCTUREP" "STRUCTURE-TYPE" "STRUCTURE-LENGTH" + "PROCEDUREP" "PROCEDURE-SYMBOL" + "PROCEDURE-REF" "SET-PROCEDURE-REF" + )) +; ;; +; ;; The following is for the "patch" to the general defstruct printer. +; (mapc importer '( +; "OUTPUT-STRUCTURE" "DEFSTRUCT-INFO" +; "OUTPUT-TERSE-OBJECT" "DEFAULT-STRUCTURE-PRINT" +; "STRUCTURE-TYPE" "*PRINT-OUTPUT*" +; )) + ;; + ;; The following is for a "patch" affecting compilation of %logand&. + ;; On APOLLO, Domain/CommonLISP 2.10 does not include %logand& whereas + ;; Domain/CommonLISP 2.20 does; Domain/CommonLISP 2.20 includes :DOMAIN/OS + ;; on *FEATURES*, so this conditionalizes correctly for APOLLO. + #-(or (and APOLLO DOMAIN/OS) LCL3.0 VAX) + (mapc importer '("COPY-STRUCTURE" "GET-FDESC" "SET-FDESC")) + + nil)) + +;; end of eval-when + +) + + +;;; +;;; Patch up for the fact that the PCL package creation in defsys.lisp +;;; will probably have an explicit :use list ?? +;;; +;;; #+LCL3.0 (use-package *default-make-package-use-list*) + + + + +#+lcl3.0 +(progn + +(defvar *saved-compilation-speed* 3) + +; the production compiler sometimes +; screws up vars within labels + +(defmacro dont-use-production-compiler () + '(eval-when (compile) + (setq *saved-compilation-speed* (if LUCID:*USE-SFC* 3 0)) + (proclaim '(optimize (compilation-speed 3))))) + +(defmacro use-previous-compiler () + `(eval-when (compile) + (proclaim '(optimize (compilation-speed ,*saved-compilation-speed*))))) + +) + +(defmacro %logand (x y) + #-VAX `(%logand& ,x ,y) + #+VAX `(logand&-variable ,x ,y)) + +;;; Fix for VAX LCL +#+VAX +(defun logand&-variable (x y) + (logand&-variable x y)) + +;;; Fix for other LCLs +#-(or (and APOLLO DOMAIN/OS) LCL3.0 VAX) +(eval-when (compile load eval) + +(let* ((logand&-fdesc (get-fdesc 'logand&)) + (%logand&-fdesc (copy-structure logand&-fdesc))) + (setf (structure-ref %logand&-fdesc 0 t) '%logand&) + (setf (structure-ref %logand&-fdesc 7 t) nil) + (setf (structure-ref %logand&-fdesc 8 t) nil) + (set-fdesc '%logand& %logand&-fdesc)) + +(eval-when (load) + (defun %logand& (x y) (%logand& x y))) + +(eval-when (eval) + (compile '%logand& '(lambda (x y) (%logand& x y)))) + +);#-(or LCL3.0 (and APOLLO DOMAIN/OS) VAX) + +;;; +;;; From: JonL +;;; Date: November 28th, 1988 +;;; +;;; Here's a better attempt to do the without-interrupts macro for LCL3.0. +;;; For the 2.1 release, maybe you should just ignore it (i.e, turn it +;;; into a PROGN and "take your chances") since there isn't a uniform way +;;; to do inhibition. 2.1 has interrupts, but no multiprocessing. +;;; +;;; The best bet for protecting the cache is merely to inhibit the +;;; scheduler, since asynchronous interrupts are only run when "scheduled". +;;; Of course, there may be other interrupts, which can cons and which +;;; could cause a GC; but at least they wouldn't be running PCL type code. +;;; +;;; Note that INTERRUPTS-ON shouldn't arbitrarily enable scheduling again, +;;; but rather simply restore it to the state outside the scope of the call +;;; to WITHOUT-INTERRUPTS. Note also that an explicit call to +;;; MAYBE-CALL-SHEDULER must be done when "turning interrupts back on", if +;;; there are any interrupts/schedulings pending; at least the test to see +;;; if any are pending is very fast. + +#+LCL3.0 +(defmacro without-interrupts (&body body) + `(macrolet ((interrupts-on () + `(when (null outer-scheduling-state) + (setq lcl:*inhibit-scheduling* nil) + (when *scheduler-wakeup* (maybe-call-scheduler)))) + (interrupts-off () + '(setq lcl:*inhibit-scheduling* t))) + (let ((outer-scheduling-state lcl:*inhibit-scheduling*)) + (prog1 (let ((lcl:*inhibit-scheduling* t)) . ,body) + (when (and (null outer-scheduling-state) *scheduler-wakeup*) + (maybe-call-scheduler)))))) + + +;;; The following should override the definitions provided by lucid-low. +;;; +#+(or LCL3.0 (and APOLLO DOMAIN/OS)) +(progn +(defstruct-simple-predicate std-instance std-instance-p) +(defstruct-simple-predicate fast-method-call fast-method-call-p) +(defstruct-simple-predicate method-call method-call-p) +) + + + +(defun set-function-name-1 (fn new-name ignore) + (declare (ignore ignore)) + (if (not (procedurep fn)) + (error "~S is not a procedure." fn) + (if (compiled-function-p fn) + ;; This is one of: + ;; compiled-function, funcallable-instance, compiled-closure + ;; or a macro. + ;; So just go ahead and set its name. + ;; Only change the name when necessary: maybe it is read-only. + (unless (eq new-name (procedure-ref fn procedure-symbol)) + (set-procedure-ref fn procedure-symbol new-name)) + ;; This is an interpreted function. + ;; Seems like any number of different things can happen depending + ;; vaguely on what release you are running. Try to do something + ;; reasonable. + (let ((symbol (procedure-ref fn procedure-symbol))) + (cond ((symbolp symbol) + ;; In fact, this is the name of the procedure. + ;; Just set it. + (set-procedure-ref fn procedure-symbol new-name)) + ((and (listp symbol) + (eq (car symbol) 'lambda)) + (setf (car symbol) 'named-lambda + (cdr symbol) (cons new-name (cdr symbol)))) + ((eq (car symbol) 'named-lambda) + (setf (cadr symbol) new-name)))))) + fn) + +(defun function-arglist (fn) + (arglist fn)) + + ;; +;;;;;; printing-random-thing-internal + ;; +(defun printing-random-thing-internal (thing stream) + (format stream "~O" (%pointer thing))) + + +;;; +;;; 16-Feb-90 Jon L White +;;; +;;; A Patch provide specifically for the benefit of PCL, in the Lucid 3.0 +;;; release environment. This adds type optimizers for FUNCALL so that +;;; forms such as: +;;; +;;; (FUNCALL (THE PROCEDURE F) ...) +;;; +;;; and: +;;; +;;; (LET ((F (Frobulate))) +;;; (DECLARE (TYPE COMPILED-FUNCTION F)) +;;; (FUNCALL F ...)) +;;; +;;; will just jump directly to the procedure code, rather than waste time +;;; trying to coerce the functional argument into a procedure. +;;; + + +(in-package "LUCID") + + +;;; (DECLARE-MACHINE-CLASS COMMON) +(set-up-compiler-target 'common) + + +(set-function-descriptor 'FUNCALL + :TYPE 'LISP + :PREDS 'NIL + :EFFECTS 'T + :OPTIMIZER #'(lambda (form &optional environment) + (declare (ignore form environment)) + (let* ((fun (second form)) + (lambdap (and (consp fun) + (eq (car fun) 'function) + (consp (second fun)) + (memq (car (second fun)) + '(lambda internal-lambda))))) + (if (not lambdap) + form + (alphatize + (cons (second fun) (cddr form)) environment)))) + :FUNCTIONTYPE '(function (function &rest t) (values &rest t)) + :TYPE-DISPATCH `(((PROCEDURE &REST T) (VALUES &REST T) + ,#'(lambda (anode fun &rest args) + (declare (ignore anode fun args)) + `(FAST-FUNCALL ,fun ,@args))) + ((COMPILED-FUNCTION &REST T) (VALUES &REST T) + ,#'(lambda (anode fun &rest args) + (declare (ignore anode fun args)) + `(FAST-FUNCALL ,fun ,@args)))) + :LAMBDALIST '(FN &REST ARGUMENTS) + :ARGS '(1 NIL) + :VALUES '(0 NIL) + ) + +(def-compiler-macro fast-funcall (&rest args &environment env) + (if (COMPILER-OPTION-SET-P :READ-SAFETY ENV) + `(FUNCALL-SUBR . ,args) + `(&FUNCALL . ,args))) + + + +(setf (symbol-function 'funcall-subr) #'funcall) + + +;;; (UNDECLARE-MACHINE-CLASS) +(restore-compiler-params) + + +(in-package 'pcl) + +(pushnew :structure-wrapper *features*) + +(defun structure-functions-exist-p () + t) + +(defun structure-instance-p (x) + (and (structurep x) + (not (eq 'std-instance (structure-type x))))) + +(defvar *structure-type* nil) +(defvar *structure-length* nil) + +(defun structure-type-p (type) + (declare (special lucid::*defstructs*)) + (let ((s-data (gethash type lucid::*defstructs*))) + (or (and s-data + (eq 'structure (structure-ref s-data 1 'defstruct))) ; type - Fix this + (and type (eq *structure-type* type))))) + +(defun structure-type-included-type-name (type) + (declare (special lucid::*defstructs*)) + (let ((s-data (gethash type lucid::*defstructs*))) + (and s-data (structure-ref s-data 6 'defstruct)))) ; include - Fix this + +(defun structure-type-slot-description-list (type) + (declare (special lucid::*defstructs*)) + (let ((s-data (gethash type lucid::*defstructs*))) + (if s-data + (nthcdr (let ((include (structure-ref s-data 6 'defstruct))) + (if include + (let ((inc-s-data (gethash include lucid::*defstructs*))) + (if inc-s-data + (length (structure-ref inc-s-data 7 'defstruct)) + 0)) + 0)) + (map 'list + #'(lambda (slotd) + (let* ((ds 'lucid::defstruct-slot) + (slot-name (system:structure-ref slotd 0 ds)) + (position (system:structure-ref slotd 1 ds)) + (accessor (system:structure-ref slotd 2 ds)) + (read-only-p (system:structure-ref slotd 5 ds))) + (list slot-name accessor + #'(lambda (x) + (system:structure-ref x position type)) + (unless read-only-p + #'(lambda (v x) + (setf (system:structure-ref x position type) + v)))))) + (structure-ref s-data 7 'defstruct))) ; slots - Fix this + (let ((result (make-list *structure-length*))) + (dotimes (i *structure-length* result) + (let* ((name (format nil "SLOT~D" i)) + (slot-name (intern name (or (symbol-package type) *package*))) + (i i)) + (setf (elt result i) (list slot-name nil + #'(lambda (x) + (system:structure-ref x i type)) + nil)))))))) + +(defun structure-slotd-name (slotd) + (first slotd)) + +(defun structure-slotd-accessor-symbol (slotd) + (second slotd)) + +(defun structure-slotd-reader-function (slotd) + (third slotd)) + +(defun structure-slotd-writer-function (slotd) + (fourth slotd)) diff --git a/pcl/impl/pyramid/pyr-low.lisp b/pcl/impl/pyramid/pyr-low.lisp new file mode 100644 index 0000000..935a7d3 --- /dev/null +++ b/pcl/impl/pyramid/pyr-low.lisp @@ -0,0 +1,50 @@ +;;; -*- Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; +;;; This is the Pyramid version of low.lisp -- it runs with versions 1.1 +;;; and newer -- Created by David Bein Mon May 4 11:22:30 1987 +;;; +(in-package 'pcl) + + ;; +;;;;;; Cache No's + ;; + +;;; The purpose behind the shift is that the bottom 2 bits are always 0 +;;; We use the same scheme for symbols and objects although a good +;;; case may be made for shifting objects more since they will +;;; be aligned differently... + +;(defmacro symbol-cache-no (symbol mask) +; `(logand (the fixnum (ash (lisp::%sp-make-fixnum ,symbol) -2)) +; (the fixnum ,mask))) + +(defmacro object-cache-no (symbol mask) + `(logand (the fixnum (ash (lisp::%sp-make-fixnum ,symbol) -2)) + (the fixnum ,mask))) + + + diff --git a/pcl/impl/pyramid/pyr-patches.lisp b/pcl/impl/pyramid/pyr-patches.lisp new file mode 100644 index 0000000..32647fe --- /dev/null +++ b/pcl/impl/pyramid/pyr-patches.lisp @@ -0,0 +1,9 @@ +(in-package 'pcl) + +;;; This next kludge disables macro memoization (the default) since somewhere +;;; in PCL, the memoization is getting in the way. + +(eval-when (load eval) + (format t "~&;;; Resetting *MACROEXPAND-HOOK* to #'FUNCALL~%") + (setq lisp::*macroexpand-hook* #'funcall)) + diff --git a/pcl/impl/symbolics/cloe-low.lisp b/pcl/impl/symbolics/cloe-low.lisp new file mode 100644 index 0000000..af7459d --- /dev/null +++ b/pcl/impl/symbolics/cloe-low.lisp @@ -0,0 +1,32 @@ +;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; + +(in-package :pcl) + +(defmacro object-cache-no (object mask) + `(logand (sys::address-of ,object) ,mask)) + diff --git a/pcl/impl/symbolics/genera-low.lisp b/pcl/impl/symbolics/genera-low.lisp new file mode 100644 index 0000000..71c939d --- /dev/null +++ b/pcl/impl/symbolics/genera-low.lisp @@ -0,0 +1,423 @@ +;;; -*- Mode:LISP; Package:(PCL Lisp 1000); Base:10.; Syntax:Common-lisp; Patch-File: Yes -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; +;;; This is the 3600 version of the file portable-low. +;;; + +(in-package 'pcl) + +(pushnew ':pcl-internals dbg:*all-invisible-frame-types*) + +#+IMach ;On the I-Machine these are +(eval-when (compile load eval) ;faster than the versions + ;that use :test #'eq. +(defmacro memq (item list) `(member ,item ,list)) +(defmacro assq (item list) `(assoc ,item ,list)) +(defmacro rassq (item list) `(rassoc ,item ,list)) +(defmacro delq (item list) `(delete ,item ,list)) +(defmacro posq (item list) `(position ,item ,list)) + +) + +compiler:: +(defoptimizer (cl:the the-just-gets-in-the-way-of-optimizers) (form) + (matchp form + (('cl:the type subform) + (ignore type) + subform) + (* form))) + +(defmacro %ash (x count) + (if (and (constantp count) (zerop (eval count))) + x + `(the fixnum (ash (the fixnum ,x ) ,count)))) + +;;; +;;; +;;; + +(defmacro without-interrupts (&body body) + `(let ((outer-scheduling-state si:inhibit-scheduling-flag) + (si:inhibit-scheduling-flag t)) + (macrolet ((interrupts-on () + '(when (null outer-scheduling-state) + (setq si:inhibit-scheduling-flag nil))) + (interrupts-off () + '(setq si:inhibit-scheduling-flag t))) + (progn outer-scheduling-state) + ,.body))) + +;;; +;;; It would appear that #, does not work properly in Genera. At least I can't get it +;;; to work when I use it inside of std-instance-p (defined later in this file). So, +;;; all of this is just to support that. +;;; +;;; WHEN EXPANDS-TO +;;; compile to a file (#:EVAL-AT-LOAD-TIME-MARKER . ) +;;; compile to core ' +;;; not in compiler at all (progn ) +;;; +;;; Believe me when I tell you that I don't know why it is I need both a +;;; transformer and an optimizer to get this to work. Believe me when I +;;; tell you that I don't really care why either. +;;; +(defmacro load-time-eval (form) + ;; The interpreted definition of load-time-eval. This definition + ;; never gets compiled. + (let ((value (gensym))) + `(multiple-value-bind (,value) + (progn ,form) + ,value))) + +(compiler:deftransformer (load-time-eval optimize-load-time-eval) (form) + (compiler-is-a-loser-internal form)) + +(compiler:defoptimizer (load-time-eval transform-load-time-eval) (form) + (compiler-is-a-loser-internal form)) + +(defun compiler-is-a-loser-internal (form) + ;; When compiling a call to load-time-eval the compiler will call + ;; this optimizer before the macro expansion. + (if zl:compiler:(and (boundp '*compile-function*) ;Probably don't need + ;this boundp check + ;but it can't hurt. + (funcall *compile-function* :to-core-p)) + ;; Compiling to core. + ;; Evaluate the form now, and expand into a constant + ;; (the result of evaluating the form). + `',(eval (cadr form)) + ;; Compiling to a file. + ;; Generate the magic which causes the dumper compiler and loader + ;; to do magic and evaluate the form at load time. + `',(cons compiler:eval-at-load-time-marker (cadr form)))) + +;; +;;;;;; Memory Block primitives. *** + ;; + + +(defmacro make-memory-block (size &optional area) + `(make-array ,size :area ,area)) + +(defmacro memory-block-ref (block offset) ;Don't want to go faster yet. + `(aref ,block ,offset)) + +(defvar class-wrapper-area) +(eval-when (load eval) + (si:make-area :name 'class-wrapper-area + :room t + :gc :static)) + +(eval-when (compile load eval) + (remprop '%%allocate-instance--class 'inline)) + +(eval-when (compile load eval) + +(scl:defflavor std-instance + ((wrapper nil) + (slots nil)) + () + (:constructor %%allocate-instance--class()) + :ordered-instance-variables) + +(defvar *std-instance-flavor* (flavor:find-flavor 'std-instance)) + +) + +#-imach +(scl:defsubst pcl-%instance-flavor (instance) + (declare (compiler:do-not-record-macroexpansions)) + (sys::%make-pointer sys:dtp-array + (sys:%p-contents-as-locative + (sys:follow-structure-forwarding instance)))) + +#+imach +(scl:defsubst pcl-%instance-flavor (instance) + (sys:%instance-flavor instance)) + +(scl::defsubst std-instance-p (x) + (and (sys:instancep x) + (eq (pcl-%instance-flavor x) (load-time-eval *std-instance-flavor*)))) + +(scl:defmethod (:print-self std-instance) (stream depth slashify) + (declare (ignore slashify)) + (print-std-instance scl:self stream depth)) + +(scl:defmethod (:describe std-instance) () + (describe-object scl:self *standard-output*)) + +(defmacro %std-instance-wrapper (std-instance) + `(sys:%instance-ref ,std-instance 1)) + +(defmacro %std-instance-slots (std-instance) + `(sys:%instance-ref ,std-instance 2)) + +(scl:compile-flavor-methods std-instance) + + +(defun printing-random-thing-internal (thing stream) + (format stream "~\\si:address\\" (si:%pointer thing))) + +;;; +;;; This is hard, I am sweating. +;;; +(defun function-arglist (function) (zl:arglist function t)) + +(defun function-pretty-arglist (function) (zl:arglist function)) + + +;; New (& complete) fspec handler. +;; 1. uses a single #'equal htable where stored elements are (fn . plist) +;; (maybe we should store the method object instead) +;; 2. also implements the fspec-plist operators here. +;; 3. fdefine not only stores the method, but actually does the loading here! +;; + +;;; +;;; genera-low.lisp (replaces old method-function-spec-handler) +;;; + +;; New (& complete) fspec handler. +;; 1. uses a single #'equal htable where stored elements are (fn . plist) +;; (maybe we should store the method object instead) +;; 2. also implements the fspec-plist operators here. +;; 3. fdefine not only stores the method, but actually does the loading here! +;; + +(defvar *method-htable* (make-hash-table :test #'equal :size 500)) +(sys:define-function-spec-handler method (op spec &optional arg1 arg2) + (if (eq op 'sys:validate-function-spec) + (and (let ((gspec (cadr spec))) + (or (symbolp gspec) + (and (listp gspec) + (eq (car gspec) 'setf) + (symbolp (cadr gspec)) + (null (cddr gspec))))) + (let ((tail (cddr spec))) + (loop (cond ((null tail) (return nil)) + ((listp (car tail)) (return t)) + ((atom (pop tail))) + (t (return nil)))))) + (let ((table *method-htable*) + (key spec)) + (case op + ((si:fdefinedp si:fdefinition) + (car (gethash key table nil))) + (si:fundefine + (remhash key table)) + (si:fdefine + (let ((old (gethash key table nil)) + (quals nil) + (specs nil) + (ptr (cddr spec))) + (setq specs + (loop (cond ((null ptr) (return nil)) + ((listp (car ptr)) (return (car ptr))) + (t (push (pop ptr) quals))))) + (setf (gethash key table) (cons arg1 (cdr old))))) + (si:get + (let ((old (gethash key table nil))) + (getf (cdr old) arg1))) + (si:plist + (let ((old (gethash key table nil))) + (cdr old))) + (si:putprop + (let ((old (gethash key table nil))) + (unless old + (setf old (cons nil nil)) + (setf (gethash key table) old)) + (setf (getf (cdr old) arg2) arg1))) + (si:remprop + (let ((old (gethash key table nil))) + (when old + (remf (cdr old) arg1)))) + (otherwise + (si:function-spec-default-handler op spec arg1 arg2)))))) + + +#|| +;; this guy is just a stub to make the fspec handler simpler (and so I could trace it +;; easier). +(defun pcl-fdefine-helper (gspec qualifiers specializers fn) + (let* ((dlist (scl:debugging-info fn)) + (class (cadr (assoc 'pcl-method-class dlist))) + (lambda-list (let ((ll-stuff (assoc 'pcl-lambda-list dlist))) + (if ll-stuff (cadr ll-stuff) (arglist fn)))) + (doc (cadr (assoc 'pcl-documentation dlist))) + (plist (cadr (assoc 'pcl-plist dlist)))) + (load-defmethod (or class 'standard-method) + gspec + qualifiers + specializers + lambda-list + doc + (getf plist :pv-table-cache-symbol) + plist + fn))) +||# + +;; define a few special declarations to get pushed onto the function's debug-info +;; list... note that we do not need to do a (proclaim (declarations ...)) here. +;; +(eval-when (compile load eval) + (setf (get 'pcl-plist 'si:debug-info) t) + (setf (get 'pcl-documentation 'si:debug-info) t) + (setf (get 'pcl-method-class 'si:debug-info) t) + (setf (get 'pcl-lambda-list 'si:debug-info) t) +) + +(eval-when (load eval) + (setf + (get 'defmethod 'zwei:definition-function-spec-type) 'defun + (get 'defmethod-setf 'zwei:definition-function-spec-type) 'defun + (get 'method 'si:definition-type-name) "method" + (get 'method 'si:definition-type-name) "method" + + (get 'declass 'zwei:definition-function-spec-type) 'defclass + (get 'defclass 'si:definition-type-name) "Class" + (get 'defclass 'zwei:definition-function-spec-finder-template) '(0 1)) + ) + + + +(defun (:property defmethod zwei::definition-function-spec-parser) (bp) + (zwei:parse-pcl-defmethod-for-zwei bp nil)) + +;;; +;;; Previously, if a source file in a PCL-based package contained what looks +;;; like flavor defmethod forms (i.e. an (IN-PACKAGE 'non-pcl-package) form +;;; appears at top level, and then a flavor-style defmethod form) appear, the +;;; parser would break. +;;; +;;; Now, if we can't parse the defmethod form, we send it to the flavor +;;; defmethod parser instead. +;;; +;;; Also now supports multi-line arglist sectionizing. +;;; +zwei: +(defun parse-pcl-defmethod-for-zwei (bp-after-defmethod setfp) + (block parser + (flet ((barf (&optional (error t)) + (return-from parser + (cond ((eq error :flavor) + (funcall (get 'flavor:defmethod + 'zwei::definition-function-spec-parser) + bp-after-defmethod)) + (t + (values nil nil nil error)))))) + (let ((bp-after-generic (forward-sexp bp-after-defmethod)) + (qualifiers ()) + (specializers ()) + (spec nil) + (ignore1 nil) + (ignore2 nil)) + (when bp-after-generic + (multiple-value-bind (generic error-p) + (read-fspec-item-from-interval bp-after-defmethod + bp-after-generic) + (if error-p + (barf) ; error here is really bad.... BARF! + (progn + (when (listp generic) + (if (and (symbolp (car generic)) + (string-equal (cl:symbol-name (car generic)) "SETF")) + (setq generic (second generic) ; is a (setf xxx) form + setfp t) + (barf :flavor))) ; make a last-ditch-effort with flavor parser + (let* ((bp1 bp-after-generic) + (bp2 (forward-sexp bp1))) + (cl:loop + (if (null bp2) + (barf :more) ; item not closed - need another line! + (multiple-value-bind (item error-p) + (read-fspec-item-from-interval bp1 bp2) + (cond (error-p (barf)) ; + ((listp item) + (setq qualifiers (nreverse qualifiers)) + (cl:multiple-value-setq (ignore1 + ignore2 + specializers) + (pcl::parse-specialized-lambda-list item)) + (setq spec (pcl::make-method-spec + (if setfp + `(cl:setf ,generic) + generic) + qualifiers + specializers)) + (return (values spec + 'defun + (string-interval + bp-after-defmethod + bp2)))) + (t (push item qualifiers) + (setq bp1 bp2 + bp2 (forward-sexp bp2)))))))))))))))) + +zwei: +(progn + (defun indent-clos-defmethod (ignore bp defmethod-paren &rest ignore) + (let ((here + (forward-over *whitespace-chars* (forward-word defmethod-paren)))) + (loop until (char-equal (bp-char here) #\() + do (setf here + (forward-over *whitespace-chars* (forward-sexp here)))) + (if (bp-< here bp) + (values defmethod-paren nil 2) + (values defmethod-paren nil 4)))) + + (defindentation (pcl::defmethod . indent-clos-defmethod))) + +;;; +;;; Teach zwei that when it gets the name of a generic function as an argument +;;; it should edit all the methods of that generic function. This works for +;;; ED as well as meta-point. +;;; +(zl:advise (flavor:method :SETUP-FUNCTION-SPECS-TO-EDIT zwei:ZMACS-EDITOR) + :around + setup-function-specs-to-edit-advice + () + (let ((old-definitions (cadddr arglist)) + (new-definitions ()) + (new nil)) + (dolist (old old-definitions) + (setq new (setup-function-specs-to-edit-advice-1 old)) + (push (or new (list old)) new-definitions)) + (setf (cadddr arglist) (apply #'append (reverse new-definitions))) + :do-it)) + +(defun setup-function-specs-to-edit-advice-1 (spec) + (and (or (symbolp spec) + (and (listp spec) (eq (car spec) 'setf))) + (gboundp spec) + (generic-function-p (gdefinition spec)) + (mapcar #'(lambda (m) + (make-method-spec spec + (method-qualifiers m) + (unparse-specializers + (method-specializers m)))) + (generic-function-methods (gdefinition spec))))) + + diff --git a/pcl/impl/symbolics/rel-7-2-patches.lisp b/pcl/impl/symbolics/rel-7-2-patches.lisp new file mode 100644 index 0000000..9c9587b --- /dev/null +++ b/pcl/impl/symbolics/rel-7-2-patches.lisp @@ -0,0 +1,387 @@ +;;; -*- Mode: LISP; Syntax: Common-lisp; Package: ZL-USER; Base: 10; Patch-File: T -*- + +;===================================== +(SYSTEM-INTERNALS:BEGIN-PATCH-SECTION) +(SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:l-COMPILER;OPTIMIZE.LISP.179") +(SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES + "-*- Mode: Lisp; Package: Compiler; Lowercase: T; Base: 8 -*-") + +;;; Does simple constant folding. This works for everything that doesn't have +;;; side-effects. +;;; ALL operands must be constant. +;;; Note that commutative-constant-folder can hack this case perfectly well +;;; by himself for the functions he handles. +(defun constant-fold-optimizer (form) + (let ((eval-when-load-p nil)) + (flet ((constant-form-p (x) + (when (constant-form-p x) + (cond ((and (listp x) + (eq (car x) 'quote) + (listp (cadr x)) + (eq (caadr x) eval-at-load-time-marker)) + (setq eval-when-load-p t) + (cdadr x)) + (t x))))) + (if (every (cdr form) #'constant-form-p) + (if eval-when-load-p + (list 'quote + (list* eval-at-load-time-marker + (car form) + (mapcar #'constant-form-p (cdr form)))) + (condition-case (error-object) + (multiple-value-call #'(lambda (&rest values) + (if (= (length values) 1) + `',(first values) + `(values ,@(mapcar #'(lambda (x) `',x) + values)))) + (eval form)) + (error + (phase-1-warning "Constant form left unoptimized: ~S~%because: ~~A~" + form error-object) + form))) + form)))) + + +;===================================== +(SYSTEM-INTERNALS:BEGIN-PATCH-SECTION) +(SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:L-COMPILER;COMFILE.LISP.85") +(SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES + "-*- Mode: Lisp; Package: Compiler; Lowercase: T; Base: 8 -*-") + +;;; +;;; The damn compiler doesn't compile random forms that appear at top level. +;;; Its difficult to do because you have to get an associated function spec +;;; to go with those forms. This handles that by defining a special form, +;;; top-level-form that compiles its body. It takes a list of eval-when +;;; times just like eval when does. It also takes a name which it uses +;;; to construct a function spec for the top-level-form function it has +;;; to create. +;;; +; +;si:: +;(defvar *top-level-form-fdefinitions* (cl:make-hash-table :test #'equal)) +; +;si:: +;(define-function-spec-handler pcl::top-level-form +; (operation fspec &optional arg1 arg2) +; (let ((name (cadr fspec))) +; (selectq operation +; (validate-function-spec (and (= (length fspec) 2) +; (or (symbolp name) +; (listp name)))) +; (fdefine +; (setf (gethash name *top-level-form-fdefinitions*) arg1)) +; ((fdefinition fdefinedp) +; (gethash name *top-level-form-fdefinitions*)) +; (fdefinition-location +; (ferror "It is not possible to get the fdefinition-location of ~s." +; fspec)) +; (fundefine (remhash name *top-level-form-fdefinitions*)) +; (otherwise (function-spec-default-handler operation fspec arg1 arg2))))) +; +;;; +;;; This is basically stolen from PROGN (surprised?) +;;; +;(si:define-special-form pcl::top-level-form (name times +; &body body +; &environment env) +; (declare lt:(arg-template . body) (ignore name)) +; (si:check-eval-when-times times) +; (when (member 'eval times) (si:eval-body body env))) +; +;(defun (:property pcl::top-level-form lt:mapforms) (original-form form usage) +; (lt::mapforms-list original-form form (cddr form) 'eval usage)) + +;;; This is the normal function for looking at each form read from the file and calling +;;; *COMPILE-FORM-FUNCTION* on the sub-forms of it. +;;; COMPILE-TIME-TOO means override the normal cases that eval at compile time. It is +;;; used for recursive calls under (EVAL-WHEN (COMPILE LOAD) ...). +;(DEFUN COMPILE-FROM-STREAM-1 (FORM &OPTIONAL (COMPILE-TIME-TOO NIL)) +; (CATCH-ERROR-RESTART +; (SYS:ERROR "Skip compiling form ~2,2\COMPILER:SHORT-S-FORMAT\" FORM) +; (LET ((DEFAULT-CONS-AREA (FUNCALL *COMPILE-FUNCTION* ':CONS-AREA))) +; (LET ((ERROR-MESSAGE-HOOK +; #'(LAMBDA () +; (DECLARE (SYS:DOWNWARD-FUNCTION)) +; (FORMAT T "~&While processing ~V,V\COMPILER:SHORT-S-FORMAT\" +; DBG:*ERROR-MESSAGE-PRINLEVEL* +; DBG:*ERROR-MESSAGE-PRINLENGTH* +; FORM)))) +; (SETQ FORM (FUNCALL *COMPILE-FUNCTION* ':MACRO-EXPAND FORM))) +; (WHEN (LISTP FORM) ;Ignore atoms at top-level +; (LET ((FUNCTION (FIRST FORM))) +; (SELECTQ FUNCTION +; ((QUOTE)) ;and quoted constants e.g. 'COMPILE +; ((PROGN) +; (DOLIST (FORM (CDR FORM)) +; (COMPILE-FROM-STREAM-1 FORM COMPILE-TIME-TOO))) +; ((EVAL-WHEN) +; (SI:CHECK-EVAL-WHEN-TIMES (CADR FORM)) +; (LET ((COMPILE-P (OR (MEMQ 'COMPILE (CADR FORM)) +; (AND COMPILE-TIME-TOO (MEMQ 'EVAL (CADR FORM))))) +; (LOAD-P (OR (MEMQ 'LOAD (CADR FORM)) (MEMQ 'CL:LOAD (CADR FORM)))) +; (FORMS (CDDR FORM))) +; (COND (LOAD-P +; (DOLIST (FORM FORMS) +; (COMPILE-FROM-STREAM-1 FORM (AND COMPILE-P ':FORCE)))) +; (COMPILE-P +; (DOLIST (FORM FORMS) +; (FUNCALL *COMPILE-FORM-FUNCTION* FORM ':FORCE NIL)))))) +; ((DEFUN) +; (LET ((TEM (DEFUN-COMPATIBILITY (CDR FORM) :WARN-IF-OBSOLETE T))) +; (IF (EQ (CDR TEM) (CDR FORM)) +; (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T) +; (COMPILE-FROM-STREAM-1 TEM COMPILE-TIME-TOO)))) +; ((MACRO) +; (FUNCALL *COMPILE-FORM-FUNCTION* FORM (OR COMPILE-TIME-TOO T) T)) +; ((DECLARE) +; (DOLIST (FORM (CDR FORM)) +; (FUNCALL *COMPILE-FORM-FUNCTION* FORM (OR COMPILE-TIME-TOO T) +; ;; (DECLARE (SPECIAL ... has load-time action as well. +; ;; All other DECLARE's do not. +; (MEMQ (CAR FORM) '(SPECIAL ZL:UNSPECIAL))))) +; ((COMPILER-LET) +; (COMPILER-LET-INTERNAL (CADR FORM) (CDDR FORM) +; #'COMPILE-FROM-STREAM-1 COMPILE-TIME-TOO)) +; ((SI:DEFINE-SPECIAL-FORM) +; (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T)) +; ((MULTIPLE-DEFINITION) +; (DESTRUCTURING-BIND (NAME TYPE . BODY) (CDR FORM) +; (LET ((NAME-VALID (AND (NOT (NULL NAME)) +; (OR (SYMBOLP NAME) +; (AND (LISTP NAME) (NEQ (CAR NAME) 'QUOTE))))) +; (TYPE-VALID (AND (NOT (NULL TYPE)) (SYMBOLP TYPE)))) +; (UNLESS (AND NAME-VALID TYPE-VALID) +; (WARN "(~S ~S ~S ...) is invalid because~@ +; ~:[~S is not valid as a definition name~;~*~]~ +; ~:[~&~S is not valid as a definition type~;~*~]" +; 'MULTIPLE-DEFINITION NAME TYPE NAME-VALID NAME TYPE-VALID TYPE))) +; (LET* ((COMPILED-BODY NIL) +; (COMPILE-FUNCTION *COMPILE-FUNCTION*) +; (*COMPILE-FUNCTION* +; (LAMBDA (OPERATION &REST ARGS) +; (DECLARE (SYS:DOWNWARD-FUNCTION)) +; (SELECTQ OPERATION +; (:DUMP-FORM +; (PUSH (FUNCALL COMPILE-FUNCTION :OPTIMIZE-TOP-LEVEL-FORM +; (FIRST ARGS)) +; COMPILED-BODY)) +; (:INSTALL-DEFINITION +; (PUSH (FORM-FOR-DEFINE *COMPILER* (FIRST ARGS) (SECOND ARGS)) +; COMPILED-BODY)) +; (OTHERWISE (CL:APPLY COMPILE-FUNCTION OPERATION ARGS))))) +; (LOCAL-DECLARATIONS `((FUNCTION-PARENT ,NAME ,TYPE) +; ,@LOCAL-DECLARATIONS))) +; (DOLIST (FORM BODY) +; (COMPILE-FROM-STREAM-1 FORM COMPILE-TIME-TOO)) +; (FUNCALL COMPILE-FUNCTION :DUMP-FORM +; `(LOAD-MULTIPLE-DEFINITION +; ',NAME ',TYPE ',(NREVERSE COMPILED-BODY) NIL))))) +; ((pcl::top-level-form) +; (destructuring-bind (name times . body) +; (cdr form) +; (si:check-eval-when-times times) +; (let ((compile-p (or (memq 'compile times) +; (and compile-time-too (memq 'eval times)))) +; (load-p (or (memq 'load times) +; (memq 'cl:load times))) +; (fspec `(pcl::top-level-form ,name))) +; (cond (load-p +; (compile-from-stream-1 +; `(progn (defun ,fspec () . ,body) +; (funcall (function ,fspec))) +; (and compile-p ':force))) +; (compile-p +; (dolist (b body) +; (funcall *compile-form-function* form ':force nil))))))) +; (OTHERWISE +; (LET ((TEM (AND (SYMBOLP FUNCTION) (GET FUNCTION 'TOP-LEVEL-FORM)))) +; (IF TEM +; (FUNCALL *COMPILE-FORM-FUNCTION* (FUNCALL TEM FORM) COMPILE-TIME-TOO T) +; (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T)))))))))) +; +; + + +dw:: +(defun symbol-flavor-or-cl-type (symbol) + (declare (values flavor defstruct-p deftype-fun typep-fun atomic-subtype-parent + non-atomic-deftype)) + (multiple-value-bind (result foundp) + (gethash symbol *flavor-or-cl-type-cache*) + (let ((frob + (if foundp result + (setf (gethash symbol *flavor-or-cl-type-cache*) + (or (get symbol 'flavor:flavor) + (not (null (defstruct-type-p symbol))) + (let* ((deftype (get symbol 'deftype)) + (descriptor (symbol-presentation-type-descriptor symbol)) + (typep + (unless (and descriptor + (presentation-type-explicit-type-function + descriptor)) + ;; Don't override the one defined in the presentation-type. + (get symbol 'typep))) + (atomic-subtype-parent (find-atomic-subtype-parent symbol)) + (non-atomic-deftype + (when (and (not descriptor) deftype) + (not (member (first (type-arglist symbol)) + '(&rest &key &optional)))))) + (if (or typep (not (atom deftype)) + non-atomic-deftype + ;; deftype overrides atomic-subtype-parent. + (and (not deftype) atomic-subtype-parent)) + (list-in-area *handler-dynamic-area* + deftype typep atomic-subtype-parent + non-atomic-deftype) + deftype))))))) + (locally (declare (inline compiled-function-p)) + (etypecase frob + (array (values frob)) + (null (values nil)) + ((member t) (values nil t)) + (compiled-function (values nil nil frob)) + (lexical-closure (values nil nil frob)) + (list (destructuring-bind (deftype typep atomic-subtype-parent non-atomic-deftype) + frob + (values nil nil deftype typep atomic-subtype-parent non-atomic-deftype))) + (symbol (values nil nil nil nil frob))))))) + +;;; +;;; The variable zwei::*sectionize-line-lookahead* controls how many lines the parser +;;; is willing to look ahead while trying to parse a definition. Even 2 lines is enough +;;; for just about all cases, but there isn't much overhead, and 10 should be enough +;;; to satisfy pretty much everyone... but feel free to change it. +;;; - MT 880921 +;;; + +zwei: +(defvar *sectionize-line-lookahead* 3) + +zwei: +(DEFMETHOD (:SECTIONIZE-BUFFER MAJOR-MODE :DEFAULT) + (FIRST-BP LAST-BP BUFFER STREAM INT-STREAM ADDED-COMPLETIONS) + ADDED-COMPLETIONS ;ignored, obsolete + (WHEN STREAM + (SEND-IF-HANDLES STREAM :SET-RETURN-DIAGRAMS-AS-LINES T)) + (INCF *SECTIONIZE-BUFFER*) + (LET ((BUFFER-TICK (OR (SEND-IF-HANDLES BUFFER :SAVE-TICK) *TICK*)) + OLD-CHANGED-SECTIONS) + (TICK) + ;; Flush old section nodes. Also collect the names of those that are modified, they are + ;; the ones that will be modified again after a revert buffer. + (DOLIST (NODE (NODE-INFERIORS BUFFER)) + (AND (> (NODE-TICK NODE) BUFFER-TICK) + (PUSH (LIST (SECTION-NODE-FUNCTION-SPEC NODE) + (SECTION-NODE-DEFINITION-TYPE NODE)) + OLD-CHANGED-SECTIONS)) + (FLUSH-BP (INTERVAL-FIRST-BP NODE)) + (FLUSH-BP (INTERVAL-LAST-BP NODE))) + (DO ((LINE (BP-LINE FIRST-BP) (LINE-NEXT INT-LINE)) + (LIMIT (BP-LINE LAST-BP)) + (EOFFLG) + (ABNORMAL T) + (DEFINITION-LIST NIL) + (BP (COPY-BP FIRST-BP)) + (FUNCTION-SPEC) + (DEFINITION-TYPE) + (STR) + (INT-LINE) + (first-time t) + (future-line) ; we actually read into future line + (future-int-line) + (PREV-NODE-START-BP FIRST-BP) + (PREV-NODE-DEFINITION-LINE NIL) + (PREV-NODE-FUNCTION-SPEC NIL) + (PREV-NODE-TYPE 'HEADER) + (PREVIOUS-NODE NIL) + (NODE-LIST NIL) + (STATE (SEND SELF :INITIAL-SECTIONIZATION-STATE))) + (NIL) + ;; If we have a stream, read another line. + (when (AND STREAM (NOT EOFFLG)) + (let ((lookahead (if future-line 1 *sectionize-line-lookahead*))) + (dotimes (i lookahead) ; startup lookahead + (MULTIPLE-VALUE (future-LINE EOFFLG) + (LET ((DEFAULT-CONS-AREA *LINE-AREA*)) + (SEND STREAM ':LINE-IN LINE-LEADER-SIZE))) + (IF future-LINE (SETQ future-INT-LINE (FUNCALL INT-STREAM ':LINE-OUT future-LINE))) + (when first-time + (setq first-time nil) + (setq line future-line) + (setq int-line future-int-line)) + (when eofflg + (return))))) + + (SETQ INT-LINE LINE) + + (when int-line + (MOVE-BP BP INT-LINE 0)) ;Record as potentially start-bp for a section + + ;; See if the line is the start of a defun. + (WHEN (AND LINE + (LET (ERR) + (MULTIPLE-VALUE (FUNCTION-SPEC DEFINITION-TYPE STR ERR STATE) + (SEND SELF ':SECTION-NAME INT-LINE BP STATE)) + (NOT ERR))) + (PUSH (LIST FUNCTION-SPEC DEFINITION-TYPE) DEFINITION-LIST) + (SECTION-COMPLETION FUNCTION-SPEC STR NIL) + ;; List methods under both names for user ease. + (LET ((OTHER-COMPLETION (SEND SELF ':OTHER-SECTION-NAME-COMPLETION + FUNCTION-SPEC INT-LINE))) + (WHEN OTHER-COMPLETION + (SECTION-COMPLETION FUNCTION-SPEC OTHER-COMPLETION NIL))) + (LET ((PREV-NODE-END-BP (BACKWARD-OVER-COMMENT-LINES BP ':FORM-AS-BLANK))) + ;; Don't make a section node if it's completely empty. This avoids making + ;; a useless Buffer Header section node. Just set all the PREV variables + ;; so that the next definition provokes the *right thing* + (UNLESS (BP-= PREV-NODE-END-BP PREV-NODE-START-BP) + (SETQ PREVIOUS-NODE + (ADD-SECTION-NODE PREV-NODE-START-BP + (SETQ PREV-NODE-START-BP PREV-NODE-END-BP) + PREV-NODE-FUNCTION-SPEC PREV-NODE-TYPE + PREV-NODE-DEFINITION-LINE BUFFER PREVIOUS-NODE + (IF (LOOP FOR (FSPEC TYPE) IN OLD-CHANGED-SECTIONS + THEREIS (AND (EQ PREV-NODE-FUNCTION-SPEC FSPEC) + (EQ PREV-NODE-TYPE TYPE))) + *TICK* BUFFER-TICK) + BUFFER-TICK)) + (PUSH PREVIOUS-NODE NODE-LIST))) + (SETQ PREV-NODE-FUNCTION-SPEC FUNCTION-SPEC + PREV-NODE-TYPE DEFINITION-TYPE + PREV-NODE-DEFINITION-LINE INT-LINE)) + ;; After processing the last line, exit. + (WHEN (OR #+ignore EOFFLG (null line) (AND (NULL STREAM) (EQ LINE LIMIT))) + ;; If reading a stream, we should not have inserted a CR + ;; after the eof line. + (WHEN STREAM + (DELETE-INTERVAL (FORWARD-CHAR LAST-BP -1 T) LAST-BP T)) + ;; The rest of the buffer is part of the last node + (UNLESS (SEND SELF ':SECTION-NAME-TRIVIAL-P) + ;; ---oh dear, what sort of section will this be? A non-empty HEADER + ;; ---node. Well, ok for now. + (PUSH (ADD-SECTION-NODE PREV-NODE-START-BP LAST-BP + PREV-NODE-FUNCTION-SPEC PREV-NODE-TYPE + PREV-NODE-DEFINITION-LINE BUFFER PREVIOUS-NODE + (IF (LOOP FOR (FSPEC TYPE) IN OLD-CHANGED-SECTIONS + THEREIS (AND (EQ PREV-NODE-FUNCTION-SPEC FSPEC) + (EQ PREV-NODE-TYPE TYPE))) + *TICK* BUFFER-TICK) + BUFFER-TICK) + NODE-LIST) + (SETF (LINE-NODE (BP-LINE LAST-BP)) (CAR NODE-LIST))) + (SETF (NODE-INFERIORS BUFFER) (NREVERSE NODE-LIST)) + (SETF (NAMED-BUFFER-WITH-SECTIONS-FIRST-SECTION BUFFER) (CAR (NODE-INFERIORS BUFFER))) + (SETQ ABNORMAL NIL) ;timing windows here + ;; Speed up completion if enabled. + (WHEN SI:*ENABLE-AARRAY-SORTING-AFTER-LOADS* + (SI:SORT-AARRAY *ZMACS-COMPLETION-AARRAY*)) + (SETQ *ZMACS-COMPLETION-AARRAY* + (FOLLOW-STRUCTURE-FORWARDING *ZMACS-COMPLETION-AARRAY*)) + (RETURN + (VALUES + (CL:SETF (ZMACS-SECTION-LIST BUFFER) + (NREVERSE DEFINITION-LIST)) + ABNORMAL)))))) + + diff --git a/pcl/impl/symbolics/rel-8-patches.lisp b/pcl/impl/symbolics/rel-8-patches.lisp new file mode 100644 index 0000000..99b85b2 --- /dev/null +++ b/pcl/impl/symbolics/rel-8-patches.lisp @@ -0,0 +1,255 @@ +;;; -*- Mode: LISP; Syntax: Common-lisp; Package: ZL-USER; Base: 10; Patch-File: T -*- + +;===================================== +(SYSTEM-INTERNALS:BEGIN-PATCH-SECTION) +(SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:l-COMPILER;OPTIMIZE.LISP.179") +(SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES + "-*- Mode: Lisp; Package: Compiler; Lowercase: T; Base: 8 -*-") + +;;; Does simple constant folding. This works for everything that doesn't have +;;; side-effects. +;;; ALL operands must be constant. +;;; Note that commutative-constant-folder can hack this case perfectly well +;;; by himself for the functions he handles. +(defun constant-fold-optimizer (form) + (let ((eval-when-load-p nil)) + (flet ((constant-form-p (x) + (when (constant-form-p x) + (cond ((and (listp x) + (eq (car x) 'quote) + (listp (cadr x)) + (eq (caadr x) eval-at-load-time-marker)) + (setq eval-when-load-p t) + (cdadr x)) + (t x))))) + (if (every (cdr form) #'constant-form-p) + (if eval-when-load-p + (list 'quote + (list* eval-at-load-time-marker + (car form) + (mapcar #'constant-form-p (cdr form)))) + (condition-case (error-object) + (multiple-value-call #'(lambda (&rest values) + (if (= (length values) 1) + `',(first values) + `(values ,@(mapcar #'(lambda (x) `',x) + values)))) + (eval form)) + (error + (phase-1-warning "Constant form left unoptimized: ~S~%because: ~~A~" + form error-object) + form))) + form)))) + + +;===================================== +(SYSTEM-INTERNALS:BEGIN-PATCH-SECTION) +(SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:L-COMPILER;COMFILE.LISP.85") +(SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES + "-*- Mode: Lisp; Package: Compiler; Lowercase: T; Base: 8 -*-") + +;;; +;;; The damn compiler doesn't compile random forms that appear at top level. +;;; Its difficult to do because you have to get an associated function spec +;;; to go with those forms. This handles that by defining a special form, +;;; top-level-form that compiles its body. It takes a list of eval-when +;;; times just like eval when does. It also takes a name which it uses +;;; to construct a function spec for the top-level-form function it has +;;; to create. +;;; +; +;si:: +;(defvar *top-level-form-fdefinitions* (cl:make-hash-table :test #'equal)) +; +;si:: +;(define-function-spec-handler pcl::top-level-form +; (operation fspec &optional arg1 arg2) +; (let ((name (cadr fspec))) +; (selectq operation +; (validate-function-spec (and (= (length fspec) 2) +; (or (symbolp name) +; (listp name)))) +; (fdefine +; (setf (gethash name *top-level-form-fdefinitions*) arg1)) +; ((fdefinition fdefinedp) +; (gethash name *top-level-form-fdefinitions*)) +; (fdefinition-location +; (ferror "It is not possible to get the fdefinition-location of ~s." +; fspec)) +; (fundefine (remhash name *top-level-form-fdefinitions*)) +; (otherwise (function-spec-default-handler operation fspec arg1 arg2))))) +; +;;; +;;; This is basically stolen from PROGN (surprised?) +;;; +;(si:define-special-form pcl::top-level-form (name times +; &body body +; &environment env) +; (declare lt:(arg-template . body) (ignore name)) +; (si:check-eval-when-times times) +; (when (member 'eval times) (si:eval-body body env))) +; +;(defun (:property pcl::top-level-form lt:mapforms) (original-form form usage) +; (lt::mapforms-list original-form form (cddr form) 'eval usage)) + +;;; This is the normal function for looking at each form read from the file and calling +;;; *COMPILE-FORM-FUNCTION* on the sub-forms of it. +;;; COMPILE-TIME-TOO means override the normal cases that eval at compile time. It is +;;; used for recursive calls under (EVAL-WHEN (COMPILE LOAD) ...). +;(DEFUN COMPILE-FROM-STREAM-1 (FORM &OPTIONAL (COMPILE-TIME-TOO NIL)) +; (CATCH-ERROR-RESTART +; (SYS:ERROR "Skip compiling form ~2,2\COMPILER:SHORT-S-FORMAT\" FORM) +; (LET ((DEFAULT-CONS-AREA (FUNCALL *COMPILE-FUNCTION* ':CONS-AREA))) +; (LET ((ERROR-MESSAGE-HOOK +; #'(LAMBDA () +; (DECLARE (SYS:DOWNWARD-FUNCTION)) +; (FORMAT T "~&While processing ~V,V\COMPILER:SHORT-S-FORMAT\" +; DBG:*ERROR-MESSAGE-PRINLEVEL* +; DBG:*ERROR-MESSAGE-PRINLENGTH* +; FORM)))) +; (SETQ FORM (FUNCALL *COMPILE-FUNCTION* ':MACRO-EXPAND FORM))) +; (WHEN (LISTP FORM) ;Ignore atoms at top-level +; (LET ((FUNCTION (FIRST FORM))) +; (SELECTQ FUNCTION +; ((QUOTE)) ;and quoted constants e.g. 'COMPILE +; ((PROGN) +; (DOLIST (FORM (CDR FORM)) +; (COMPILE-FROM-STREAM-1 FORM COMPILE-TIME-TOO))) +; ((EVAL-WHEN) +; (SI:CHECK-EVAL-WHEN-TIMES (CADR FORM)) +; (LET ((COMPILE-P (OR (MEMQ 'COMPILE (CADR FORM)) +; (AND COMPILE-TIME-TOO (MEMQ 'EVAL (CADR FORM))))) +; (LOAD-P (OR (MEMQ 'LOAD (CADR FORM)) (MEMQ 'CL:LOAD (CADR FORM)))) +; (FORMS (CDDR FORM))) +; (COND (LOAD-P +; (DOLIST (FORM FORMS) +; (COMPILE-FROM-STREAM-1 FORM (AND COMPILE-P ':FORCE)))) +; (COMPILE-P +; (DOLIST (FORM FORMS) +; (FUNCALL *COMPILE-FORM-FUNCTION* FORM ':FORCE NIL)))))) +; ((DEFUN) +; (LET ((TEM (DEFUN-COMPATIBILITY (CDR FORM) :WARN-IF-OBSOLETE T))) +; (IF (EQ (CDR TEM) (CDR FORM)) +; (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T) +; (COMPILE-FROM-STREAM-1 TEM COMPILE-TIME-TOO)))) +; ((MACRO) +; (FUNCALL *COMPILE-FORM-FUNCTION* FORM (OR COMPILE-TIME-TOO T) T)) +; ((DECLARE) +; (DOLIST (FORM (CDR FORM)) +; (FUNCALL *COMPILE-FORM-FUNCTION* FORM (OR COMPILE-TIME-TOO T) +; ;; (DECLARE (SPECIAL ... has load-time action as well. +; ;; All other DECLARE's do not. +; (MEMQ (CAR FORM) '(SPECIAL ZL:UNSPECIAL))))) +; ((COMPILER-LET) +; (COMPILER-LET-INTERNAL (CADR FORM) (CDDR FORM) +; #'COMPILE-FROM-STREAM-1 COMPILE-TIME-TOO)) +; ((SI:DEFINE-SPECIAL-FORM) +; (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T)) +; ((MULTIPLE-DEFINITION) +; (DESTRUCTURING-BIND (NAME TYPE . BODY) (CDR FORM) +; (LET ((NAME-VALID (AND (NOT (NULL NAME)) +; (OR (SYMBOLP NAME) +; (AND (LISTP NAME) (NEQ (CAR NAME) 'QUOTE))))) +; (TYPE-VALID (AND (NOT (NULL TYPE)) (SYMBOLP TYPE)))) +; (UNLESS (AND NAME-VALID TYPE-VALID) +; (WARN "(~S ~S ~S ...) is invalid because~@ +; ~:[~S is not valid as a definition name~;~*~]~ +; ~:[~&~S is not valid as a definition type~;~*~]" +; 'MULTIPLE-DEFINITION NAME TYPE NAME-VALID NAME TYPE-VALID TYPE))) +; (LET* ((COMPILED-BODY NIL) +; (COMPILE-FUNCTION *COMPILE-FUNCTION*) +; (*COMPILE-FUNCTION* +; (LAMBDA (OPERATION &REST ARGS) +; (DECLARE (SYS:DOWNWARD-FUNCTION)) +; (SELECTQ OPERATION +; (:DUMP-FORM +; (PUSH (FUNCALL COMPILE-FUNCTION :OPTIMIZE-TOP-LEVEL-FORM +; (FIRST ARGS)) +; COMPILED-BODY)) +; (:INSTALL-DEFINITION +; (PUSH (FORM-FOR-DEFINE *COMPILER* (FIRST ARGS) (SECOND ARGS)) +; COMPILED-BODY)) +; (OTHERWISE (CL:APPLY COMPILE-FUNCTION OPERATION ARGS))))) +; (LOCAL-DECLARATIONS `((FUNCTION-PARENT ,NAME ,TYPE) +; ,@LOCAL-DECLARATIONS))) +; (DOLIST (FORM BODY) +; (COMPILE-FROM-STREAM-1 FORM COMPILE-TIME-TOO)) +; (FUNCALL COMPILE-FUNCTION :DUMP-FORM +; `(LOAD-MULTIPLE-DEFINITION +; ',NAME ',TYPE ',(NREVERSE COMPILED-BODY) NIL))))) +; ((pcl::top-level-form) +; (destructuring-bind (name times . body) +; (cdr form) +; (si:check-eval-when-times times) +; (let ((compile-p (or (memq 'compile times) +; (and compile-time-too (memq 'eval times)))) +; (load-p (or (memq 'load times) +; (memq 'cl:load times))) +; (fspec `(pcl::top-level-form ,name))) +; (cond (load-p +; (compile-from-stream-1 +; `(progn (defun ,fspec () . ,body) +; (funcall (function ,fspec))) +; (and compile-p ':force))) +; (compile-p +; (dolist (b body) +; (funcall *compile-form-function* form ':force nil))))))) +; (OTHERWISE +; (LET ((TEM (AND (SYMBOLP FUNCTION) (GET FUNCTION 'TOP-LEVEL-FORM)))) +; (IF TEM +; (FUNCALL *COMPILE-FORM-FUNCTION* (FUNCALL TEM FORM) COMPILE-TIME-TOO T) +; (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T)))))))))) +; +; + + +dw:: +(defun symbol-flavor-or-cl-type (symbol) + (declare (values flavor defstruct-p deftype-fun typep-fun atomic-subtype-parent + non-atomic-deftype)) + (multiple-value-bind (result foundp) + (gethash symbol *flavor-or-cl-type-cache*) + (let ((frob + (if foundp result + (setf (gethash symbol *flavor-or-cl-type-cache*) + (or (get symbol 'flavor:flavor) + (let ((class (get symbol 'clos-internals::class-for-name))) + (when (and class + (not (typep class 'clos:built-in-class))) + class)) + (not (null (defstruct-type-p symbol))) + (let* ((deftype (get symbol 'deftype)) + (descriptor (symbol-presentation-type-descriptor symbol)) + (typep + (unless (and descriptor + (presentation-type-explicit-type-function + descriptor)) + ;; Don't override the one defined in the presentation-type. + (get symbol 'typep))) + (atomic-subtype-parent (find-atomic-subtype-parent symbol)) + (non-atomic-deftype + (when (and (not descriptor) deftype) + (not (member (first (type-arglist symbol)) + '(&rest &key &optional)))))) + (if (or typep (not (atom deftype)) + non-atomic-deftype + ;; deftype overrides atomic-subtype-parent. + (and (not deftype) atomic-subtype-parent)) + (list-in-area *handler-dynamic-area* + deftype typep atomic-subtype-parent + non-atomic-deftype) + deftype))))))) + (locally (declare (inline compiled-function-p)) + (etypecase frob + (array (values frob)) + (instance (values frob)) + (null (values nil)) + ((member t) (values nil t)) + (compiled-function (values nil nil frob)) + (lexical-closure (values nil nil frob)) + (list (destructuring-bind (deftype typep atomic-subtype-parent non-atomic-deftype) + frob + (values nil nil deftype typep atomic-subtype-parent non-atomic-deftype))) + (symbol (values nil nil nil nil frob))))))) + + diff --git a/pcl/impl/ti/ti-low.lisp b/pcl/impl/ti/ti-low.lisp new file mode 100644 index 0000000..95f5e84 --- /dev/null +++ b/pcl/impl/ti/ti-low.lisp @@ -0,0 +1,83 @@ +;;; -*- Mode:LISP; Package:(PCL (Lisp WALKER)); Base:10.; Syntax:Common-lisp; Patch-File: Yes -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; +;;; This is the 3600 version of the file portable-low. +;;; + +(in-package 'pcl) + +(defmacro without-interrupts (&body body) + `(let ((outer-scheduling-state si:inhibit-scheduling-flag) + (si:inhibit-scheduling-flag t)) + (macrolet ((interrupts-on () + '(when (null outer-scheduling-state) + (setq si:inhibit-scheduling-flag nil))) + (interrupts-off () + '(setq si:inhibit-scheduling-flag t))) + ,.body))) + +(si:defsubst std-instance-p (x) + (si:typep-structure-or-flavor x 'std-instance)) + + ;; +;;;;;; printing-random-thing-internal + ;; +(defun printing-random-thing-internal (thing stream) + (format stream "~O" (si:%pointer thing))) + +(eval-when (compile load eval) ;There seems to be some bug with + (setq si::inhibit-displacing-flag t)) ;macrolet'd macros or something. + ;This gets around it but its not + ;really the right fix. + +(defun function-arglist (f) + (sys::arglist f t)) + +(defun record-definition (type spec &rest ignore) + (if (eql type 'method) + (sys:record-source-file-name spec 'defun :no-query) + (sys:record-source-file-name spec type :no-query))) + +(ticl:defprop method method-function-spec-handler sys:function-spec-handler) +(defun method-function-spec-handler + (function function-spec &optional arg1 arg2) + (let ((symbol (second function-spec))) + (case function + (sys:validate-function-spec t) + (otherwise + (sys:function-spec-default-handler + function function-spec arg1 arg2))))) + +;;;Edited by Reed Hastings 13 Aug 87 16:59 +;;;Edited by Reed Hastings 2 Nov 87 22:58 +(defun set-function-name (function new-name) + (when (si:get-debug-info-struct function) + (setf (si:get-debug-info-field (si:get-debug-info-struct function) :name) + new-name)) + function) + + + diff --git a/pcl/impl/ti/ti-patches.lisp b/pcl/impl/ti/ti-patches.lisp new file mode 100644 index 0000000..c189861 --- /dev/null +++ b/pcl/impl/ti/ti-patches.lisp @@ -0,0 +1,105 @@ +;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; + +(in-package 'pcl) + +;;; +;;; This little bit of magic keeps the dumper from dumping the lexical +;;; definition of call-next-method when it dumps method functions that +;;; come from defmethod forms. +;;; +(proclaim '(notinline nil)) + +(eval-when (load) + (setf (get 'function 'si:type-predicate) 'functionp)) + +;; fix defsetf to deal with do-standard-defsetf + +#!C +; From file SETF.LISP#> KERNEL; VIRGO: +#8R SYSTEM#: +(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM")) + (SI:*LISP-MODE* :COMMON-LISP) + (*READTABLE* COMMON-LISP-READTABLE) + (SI:*READER-SYMBOL-SUBSTITUTIONS* *COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) + (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; SETF.#" + + +(defmacro defsetf (access-function arg1 &optional arg2 &environment env &body body) + "Define a SETF expander for ACCESS-FUNCTION. +DEFSETF has two forms: + +The simple form (DEFSETF access-function update-function [doc-string]) +can be used as follows: After (DEFSETF GETFROB PUTFROB), +\(SETF (GETFROB A 3) FOO) ==> (PUTFROB A 3 FOO). + +The complex form is like DEFMACRO: + +\(DEFSETF access-function access-lambda-list newvalue-lambda-list body...) + +except there are TWO lambda-lists. +The first one represents the argument forms to the ACCESS-FUNCTION. +Only &OPTIONAL and &REST are allowed here. +The second has only one argument, representing the value to be stored. +The body of the DEFSETF definition must then compute a +replacement for the SETF form, just as for any other macro. +When the body is executed, the args in the lambda-lists will not +really contain the value-expression or parts of the form to be set; +they will contain gensymmed variables which SETF may or may not +eliminate by substitution." + ;; REF and VAL are arguments to the expansion function + (if (null body) + `(defdecl ,access-function setf-method ,arg1) + (multiple-value-bind (body decls doc-string) + (parse-body body env t) + (let* ((access-ll arg1) + (value-names arg2) + (expansion + (let (all-arg-names) + (dolist (x access-ll) + (cond ((symbolp x) + (if (not (member x lambda-list-keywords :test #'eq)) + (push x all-arg-names) + (when (eq x '&rest) (return)))) ;;9/20/88 clm + (t ; it's a list after &optional + (push (car x) all-arg-names)))) + (setq all-arg-names (reverse all-arg-names)) + `(let ((tempvars (mapcar #'(lambda (ignore) (gensym)) ',all-arg-names)) + (storevar (gensym))) + (values tempvars (list . ,all-arg-names) (list storevar) + (let ((,(car value-names) storevar) + . ,(loop for arg in all-arg-names + for i = 0 then (1+ i) + collect `(,arg (nth ,i tempvars)))) + ,@decls . ,body) + `(,',access-function . ,tempvars)))))) + `(define-setf-method ,access-function ,arg1 + ,@doc-string ,expansion) + )))) +)) + + diff --git a/pcl/impl/vaxlisp/vaxl-low.lisp b/pcl/impl/vaxlisp/vaxl-low.lisp new file mode 100644 index 0000000..ae9383b --- /dev/null +++ b/pcl/impl/vaxlisp/vaxl-low.lisp @@ -0,0 +1,80 @@ +;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; +;;; The version of low for VAXLisp +;;; +(in-package 'pcl) + +(defmacro without-interrupts (&body body) + `(macrolet ((interrupts-on () + `(when (null outer-scheduling-state) + (setq system::*critical-section-p* nil) + (when (system::%sp-interrupt-queued-p) + (system::interrupt-dequeuer t)))) + (interrupts-off () + `(setq system::*critical-section-p* t))) + (let ((outer-scheduling-state system::*critical-section-p*)) + (prog1 (let ((system::*critical-section-p* t)) ,@body) + (when (and (null outer-scheduling-state) + (system::%sp-interrupt-queued-p)) + (system::interrupt-dequeuer t)))))) + + + ;; +;;;;;; Load Time Eval + ;; +(defmacro load-time-eval (form) + `(progn ,form)) + + ;; +;;;;;; Generating CACHE numbers + ;; +;;; How are symbols in VAXLisp actually arranged in memory? +;;; Should we be shifting the address? +;;; Are they relocated? +;;; etc. + +;(defmacro symbol-cache-no (symbol mask) +; `(logand (the fixnum (system::%sp-pointer->fixnum ,symbol)) ,mask)) + +(defmacro object-cache-no (object mask) + `(logand (the fixnum (system::%sp-pointer->fixnum ,object)) ,mask)) + + ;; +;;;;;; printing-random-thing-internal + ;; +(defun printing-random-thing-internal (thing stream) + (format stream "~O" (system::%sp-pointer->fixnum thing))) + + +(defun function-arglist (fn) + (system::function-lambda-vars (symbol-function fn))) + +(defun set-function-name-1 (fn name ignore) + (cond ((system::slisp-compiled-function-p fn) + (system::%sp-b-store fn 3 name))) + fn) + diff --git a/pcl/impl/xerox/pcl-env-internal.lisp b/pcl/impl/xerox/pcl-env-internal.lisp new file mode 100644 index 0000000..86b947b --- /dev/null +++ b/pcl/impl/xerox/pcl-env-internal.lisp @@ -0,0 +1,261 @@ +(DEFINE-FILE-INFO PACKAGE "XCL" READTABLE "XCL") +(il:filecreated "28-Aug-87 18:42:36" il:{phylum}pcl-env-internal.\;1 8356 + + il:|changes| il:|to:| (il:vars il:pcl-env-internalcoms) + (il:props (il:pcl-env-internal il:makefile-environment)) + (il:functions stack-eql stack-pointer-frame stack-frame-valid-p + stack-frame-fn-header stack-frame-pc fnheader-debugging-info + stack-frame-name compiled-closure-fnheader compiled-closure-env) +) + + +; Copyright (c) 1987 by Xerox Corporation. All rights reserved. + +(il:prettycomprint il:pcl-env-internalcoms) + +(il:rpaqq il:pcl-env-internalcoms ( + +(il:* il:|;;;| "***************************************") + + + +(il:* il:|;;;| " Copyright (c) 1987 Xerox Corporation. All rights reserved.") + + + +(il:* il:|;;;| "") + + + +(il:* il:|;;;| "Use and copying of this software and preparation of derivative works based upon this software are permitted. Any distribution of this software or derivative works must comply with all applicable United States export control laws.") + + + +(il:* il:|;;;| " ") + + + +(il:* il:|;;;| "This software is made available AS IS, and Xerox Corporation makes no warranty about the software, its performance or its conformity to any specification.") + + + +(il:* il:|;;;| " ") + + + +(il:* il:|;;;| "Any person obtaining a copy of this software is requested to send their name and post office or electronic mail address to:") + + + +(il:* il:|;;;| " CommonLoops Coordinator") + + + +(il:* il:|;;;| " Xerox Artifical Intelligence Systems") + + + +(il:* il:|;;;| " 2400 Hanover St.") + + + +(il:* il:|;;;| " Palo Alto, CA 94303") + + + +(il:* il:|;;;| "(or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)") + + + +(il:* il:|;;;| "") + + + +(il:* il:|;;;| " Suggestions, comments and requests for improvements are also welcome.") + + + +(il:* il:|;;;| " *************************************************************************") + + + +(il:* il:|;;;| "") + + (il:declare\: il:dontcopy (il:prop il:makefile-environment + il:pcl-env-internal)) + (il:* il:\; + "We're off to hack the system...") + + (il:declare\: il:eval@compile il:dontcopy (il:files pcl::abc) + + + (il:* il:|;;| "The Deltas and The East and The Freeze") +) + (il:functions stack-eql stack-pointer-frame stack-frame-valid-p + stack-frame-fn-header stack-frame-pc + fnheader-debugging-info stack-frame-name + compiled-closure-fnheader compiled-closure-env))) + + + +(il:* il:|;;;| "***************************************") + + + + +(il:* il:|;;;| " Copyright (c) 1987 Xerox Corporation. All rights reserved.") + + + + +(il:* il:|;;;| "") + + + + +(il:* il:|;;;| +"Use and copying of this software and preparation of derivative works based upon this software are permitted. Any distribution of this software or derivative works must comply with all applicable United States export control laws." +) + + + + +(il:* il:|;;;| " ") + + + + +(il:* il:|;;;| +"This software is made available AS IS, and Xerox Corporation makes no warranty about the software, its performance or its conformity to any specification." +) + + + + +(il:* il:|;;;| " ") + + + + +(il:* il:|;;;| +"Any person obtaining a copy of this software is requested to send their name and post office or electronic mail address to:" +) + + + + +(il:* il:|;;;| " CommonLoops Coordinator") + + + + +(il:* il:|;;;| " Xerox Artifical Intelligence Systems") + + + + +(il:* il:|;;;| " 2400 Hanover St.") + + + + +(il:* il:|;;;| " Palo Alto, CA 94303") + + + + +(il:* il:|;;;| "(or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)") + + + + +(il:* il:|;;;| "") + + + + +(il:* il:|;;;| " Suggestions, comments and requests for improvements are also welcome.") + + + + +(il:* il:|;;;| " *************************************************************************") + + + + +(il:* il:|;;;| "") + +(il:declare\: il:dontcopy + +(il:putprops il:pcl-env-internal il:makefile-environment (:package "XCL" :readtable "XCL")) +) + + + +(il:* il:\; "We're off to hack the system...") + +(il:declare\: il:eval@compile il:dontcopy +(il:filesload pcl::abc) +) + +(defun stack-eql (x y) "Test two stack pointers for equality" (and (il:stackp x) + (il:stackp y) + (eql (il:fetch (il:stackp il:edfxp + ) + il:of x) + (il:fetch (il:stackp il:edfxp + ) + il:of y)))) + + +(defun stack-pointer-frame (stack-pointer) (il:|fetch| (il:stackp il:edfxp) il:|of| stack-pointer)) + + +(defun stack-frame-valid-p (frame) (not (il:|fetch| (il:fx il:invalidp) il:|of| frame))) + + +(defun stack-frame-fn-header (frame) (il:|fetch| (il:fx il:fnheader) il:|of| frame)) + + +(defun stack-frame-pc (frame) (il:|fetch| (il:fx il:pc) il:|of| frame)) + + +(defun fnheader-debugging-info (fnheader) (let* ((start-pc (il:fetch (il:fnheader il:startpc) + il:of fnheader)) + (name-table-words + (let ((size (il:fetch (il:fnheader il:ntsize) + il:of fnheader))) + (if (zerop size) + il:wordsperquad + (* size 2)))) + (past-name-table-in-words (+ (il:fetch (il:fnheader + + il:overheadwords + ) + il:of fnheader) + name-table-words))) + (and (= (- start-pc (* il:bytesperword + past-name-table-in-words)) + il:bytespercell) + + (il:* il:|;;| "It's got a debugging-info list.") + + (il:\\getbaseptr fnheader + past-name-table-in-words)))) + + +(defun stack-frame-name (frame) (il:|fetch| (il:fx il:framename) il:|of| frame)) + + +(defun compiled-closure-fnheader (closure) (il:|fetch| (il:compiled-closure il:fnheader) il:|of| + closure)) + + +(defun compiled-closure-env (closure) (il:fetch (il:compiled-closure il:environment) il:of closure)) + +(il:putprops il:pcl-env-internal il:copyright ("Xerox Corporation" 1987)) +(il:declare\: il:dontcopy + (il:filemap (nil))) +il:stop + diff --git a/pcl/impl/xerox/pcl-env.lisp b/pcl/impl/xerox/pcl-env.lisp new file mode 100644 index 0000000..7bf4b47 --- /dev/null +++ b/pcl/impl/xerox/pcl-env.lisp @@ -0,0 +1,1629 @@ +;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.com) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; +;;; Xerox-Lisp specific environment hacking for PCL + +(in-package "PCL") + +;; +;; Protect the Corporation +;; +(eval-when (eval load) + (format *terminal-io* + "~&;PCL-ENV Copyright (c) 1987, 1988, 1989, by ~ + Xerox Corporation. All rights reserved.~%")) + + +;;; Make funcallable instances (FINs) print by calling print-object. + +(eval-when (eval load) + (il:defprint 'il:compiled-closure 'il:print-closure)) + +(defun il:print-closure (x &optional stream depth) + ;; See the IRM, section 25.3.3. Unfortunatly, that documentation is + ;; not correct. In particular, it makes no mention of the third argument. + (cond ((not (funcallable-instance-p x)) + ;; IL:\CCLOSURE.DEFPRINT is the orginal system function for + ;; printing closures + (il:\\cclosure.defprint x stream)) + ((streamp stream) + ;; Use the standard PCL printing method, then return T to tell + ;; the printer that we have done the printing ourselves. + (print-object x stream) + t) + (t + ;; Internal printing (again, see the IRM section 25.3.3). + ;; Return a list containing the string of characters that + ;; would be printed, if the object were being printed for + ;; real. + (with-output-to-string (stream) + (list (print-object x stream)))))) + + +;;; Naming methods + +(defun gf-named (gf-name) + (let ((spec (cond ((symbolp gf-name) gf-name) + ((and (consp gf-name) + (eq (first gf-name) 'setf) + (symbolp (second gf-name)) + (null (cddr gf-name))) + (get-setf-function-name (second gf-name))) + (t nil)))) + (if (and (fboundp spec) + (generic-function-p (symbol-function spec))) + (symbol-function spec) + nil))) + +(defun generic-function-method-names (gf-name hasdefp) + (if hasdefp + (let ((names nil)) + (maphash #'(lambda (key value) + (declare (ignore value)) + (when (and (consp key) (eql (car key) gf-name)) + (pushnew key names))) + (gethash 'methods xcl:*definition-hash-table*)) + names) + (let ((gf (gf-named gf-name))) + (when gf + (mapcar #'full-method-name (generic-function-methods gf)))))) + +(defun full-method-name (method) + "Return the full name of the method" + (let ((specializers (mapcar #'(lambda (x) + (cond ((eq x 't) t) + ((consp x) x) + (t (class-name x)))) + (method-type-specifiers method)))) + ;; Now go through some hair to make sure that specializer is + ;; really right. Once PCL returns the right value for + ;; specializers this can be taken out. + (let* ((arglist (method-arglist method)) + (number-required (or (position-if + #'(lambda (x) (member x lambda-list-keywords)) + arglist) + (length arglist))) + (diff (- number-required (length specializers)))) + (when (> diff 0) + (setq specializers (nconc (copy-list specializers) + (make-list diff :initial-element 't))))) + (make-full-method-name (generic-function-name + (method-generic-function method)) + (method-qualifiers method) + specializers))) + +(defun make-full-method-name (generic-function-name qualifiers arg-types) + "Return the full name of a method, given the generic-function name, the method +qualifiers, and the arg-types" + ;; The name of the method is: + ;; ( .. + ;; (..)) + (labels ((remove-trailing-ts (l) + (if (null l) + nil + (let ((tail (remove-trailing-ts (cdr l)))) + (if (null tail) + (if (eq (car l) 't) + nil + (list (car l))) + (if (eq l tail) + l + (cons (car l) tail))))))) + `(,generic-function-name ,@qualifiers + ,(remove-trailing-ts arg-types)))) + +(defun parse-full-method-name (method-name) + "Parse the method name, returning the gf-name, the qualifiers, and the +arg-types." + (values (first method-name) + (butlast (rest method-name)) + (car (last method-name)))) + +(defun prompt-for-full-method-name (gf-name &optional has-def-p) + "Prompt the user for the full name of a method on the given generic function name" + (let ((method-names (generic-function-method-names gf-name has-def-p))) + (cond ((null method-names) + nil) + ((null (cdr method-names)) + (car method-names)) + (t (il:menu + (il:create + il:menu il:items il:_ ;If HAS-DEF-P, include only + ; those methods that have a + ; symbolic def'n that we can + ; find + (remove-if #'null + (mapcar #'(lambda (m) + (if (or (not has-def-p) + (il:hasdef m 'methods)) + `(,(with-output-to-string (s) + (dolist (x m) + (format s "~A " x)) + s) + ',m) + nil)) + method-names)) + il:title il:_ "Which method?")))))) + + +;;; Converting generic defining macros into DEFDEFINER macros + +(defmacro make-defdefiner (definer-name definer-type type-description &body + definer-options) + "Make the DEFINER-NAME use DEFDEFINER, defining items of type DEFINER-TYPE" + (let ((old-definer-macro-name (intern (string-append definer-name + " old definition") + (symbol-package definer-name))) + (old-definer-macro-expander (intern (string-append definer-name + " old expander") + (symbol-package definer-name)))) + `(progn + ;; First, move the current defining function off to some safe + ;; place + (unmake-defdefiner ',definer-name) + (cond ((not (fboundp ',definer-name)) + (error "~A has no definition!" ',definer-name)) + ((fboundp ',old-definer-macro-name)) + ((macro-function ',definer-name) + ; We have to move the macro + ; expansion function as well, + ; so it won't get clobbered + ; when the original macro is + ; redefined. See AR 7410. + (let* ((expansion-function (macro-function ',definer-name))) + (setf (symbol-function ',old-definer-macro-expander) + (loop (if (symbolp expansion-function) + (setq expansion-function + (symbol-function expansion-function)) + (return expansion-function)))) + (setf (macro-function ',old-definer-macro-name) + ',old-definer-macro-expander) + (setf (get ',definer-name 'make-defdefiner) expansion-function))) + (t (error "~A does not name a macro." ',definer-name))) + ;; Make sure the type is defined + (xcl:def-define-type ,definer-type ,type-description) + ;; Now redefine the definer, using DEFEDFINER and the original def'n + (xcl:defdefiner ,(if definer-options + (cons definer-name definer-options) + definer-name) + ,definer-type (&body b) `(,',old-definer-macro-name ,@,'b))))) + +(defun unmake-defdefiner (definer-name) + (let ((old-expander (get definer-name 'make-defdefiner))) + (when old-expander + (setf (macro-function definer-name old-expander)) + (remprop definer-name 'make-defdefiner)))) + + +;;; For tricking ED into being able to use just the generic-function-name +;;; instead of the full method name + +(defun source-manager-method-edit-fn (name type source editcoms options) + "Edit a method of the given name" + (let ((full-name (if (gf-named name) + ;If given the name of a + ; generic-function, try to get + ; the full method name + (prompt-for-full-method-name name t) + ; Otherwise it should name the + ; method + name))) + (when (not (null full-name)) + (il:default.editdef full-name type source editcoms options)) + (or full-name name))) ;Return the name + +(defun source-manager-method-hasdef-fn (name type &optional source) + "Is there a method defined with the given name?" + (cond ((not (eq type 'methods)) nil) + ((or (symbolp name) + (and (consp name) + (eq (first name) 'setf) + (symbolp (second name)) + (null (cddr name)))) + ;; If passed in the name of a generic-function, pretend that + ;; there is a method by that name if there is a generic function + ;; by that name, and there is a method whose source we can find. + (if (and (not (null (gf-named name))) + (find-if #'(lambda (m) + (il:hasdef m type source)) + (generic-function-method-names name t))) + name + nil)) + ((and (consp name) (>= (length name) 2)) + ;; Standard methods are named (gf-name {qualifiers}* ({specializers}*)) + (when (il:getdef name type source '(il:nocopy il:noerror)) + name)) + (t + ;; Nothing else can name a method + nil))) + +;;; Initialize the PCL env + +(defun initialize-pcl-env nil + "Initialize the Xerox PCL environment" + ;; Set up SourceManager DEFDEFINERS for classes and methods. + ;; + ;; Make sure to define methods before classes, so that (IL:FILES?) will build + ;; filecoms that have classes before methods. + (unless (il:hasdef 'methods 'il:filepkgtype) + (make-defdefiner defmethod methods "methods" + (:name (lambda (form) + (multiple-value-bind (name qualifiers arglist) + (parse-defmethod (cdr form)) + (make-full-method-name name qualifiers + (extract-specializer-names + arglist))))) + (:undefiner + (lambda (method-name) + (multiple-value-bind + (name qualifiers arg-types) + (parse-full-method-name method-name) + (let* ((gf (gf-named name)) + (method (when gf + (get-method gf qualifiers + (mapcar #'find-class + arg-types))))) + (when method (remove-method gf method)))))))) + ;; Include support for DEFGENERIC, if that is defined + (unless (or (not (fboundp 'defgeneric)) + (il:hasdef 'generic-functions 'il:filepkgtype)) + (make-defdefiner defgeneric generic-functions "generic-function definitions")) + ;; DEFCLASS FileManager stuff + (unless (il:hasdef 'classes 'il:filepkgtype) + (make-defdefiner defclass classes "class definitions" + (:undefiner (lambda (name) + (when (find-class name t) + (setf (find-class name) nil))))) + ;; CLASSES "include" TYPES. + (il:filepkgcom 'classes 'il:contents + #'(lambda (com name type &optional reason) + (declare (ignore name reason)) + (if (member type '(il:types classes) :test #'eq) + (cdr com) + nil)))) + ;; Set up the hooks so that ED can be handed the name of a generic function, + ;; and end up editing a method instead + (il:filepkgtype 'methods 'il:editdef 'source-manager-method-edit-fn + 'il:hasdef 'source-manager-method-hasdef-fn) + ;; Set up the inspect macro. The right way to do this is to + ;; (ENSURE-GENERIC-FUNCTION 'IL:INSPECT...), but for now... + (push '((il:function pcl-object-p) . \\internal-inspect-object) + il:inspectmacros) + ;; Unmark any SourceManager changes caused by this loadup + (dolist (com (il:filepkgchanges)) + (dolist (name (cdr com)) + (when (and (symbolp name) + (eq (symbol-package name) (find-package "PCL"))) + (il:unmarkaschanged name (car com)))))) + +(eval-when (eval load) + (initialize-pcl-env)) + + +;;; Inspecting PCL objects + +(defun pcl-object-p (x) + "Is the datum a PCL object?" + (or (std-instance-p x) + (fsc-instance-p x))) + +(defun \\internal-inspect-object (x type where) + (inspect-object x type where)) + +(defun \\internal-inspect-slot-names (x) + (inspect-slot-names x)) + +(defun \\internal-inspect-slot-value (x slot-name) + (inspect-slot-value x slot-name)) + +(defun \\internal-inspect-setf-slot-value (x slot-name value) + (inspect-setf-slot-value x slot-name value)) + +(defun \\internal-inspect-slot-name-command (slot-name x window) + (inspect-slot-name-command slot-name x window)) + +(defun \\internal-inspect-title (x y) + (inspect-title x y)) + +(defmethod inspect-object (x type where) + "Open an insect window on the object x" + (il:inspectw.create x '\\internal-inspect-slot-names + '\\internal-inspect-slot-value + '\\internal-inspect-setf-slot-value + '\\internal-inspect-slot-name-command nil nil + '\\internal-inspect-title nil where + #'(lambda (n v) ;Same effect as NIL, but avoids bug in + (declare (ignore v)) ; INSPECTW.CREATE + n))) + +(defmethod inspect-slot-names (x) + "Return a list of names of slots of the object that should be shown in the +inspector" + (mapcar #'(lambda (slotd) (slot-value slotd 'name)) + (slots-to-inspect (class-of x) x))) + +(defmethod inspect-slot-value (x slot-name) + (cond ((not (slot-exists-p x slot-name)) "** no such slot **") + ((not (slot-boundp x slot-name)) "** slot not bound **") + (t (slot-value x slot-name)))) + +(defmethod inspect-setf-slot-value (x slot-name value) + "Used by the inspector to set the value fo a slot" + ;; Make this UNDO-able + (il:undosave `(inspect-setf-slot-value ,x ,slot-name + ,(slot-value x slot-name))) + ;; Then change the value + (setf (slot-value x slot-name) value)) + +(defmethod inspect-slot-name-command (slot-name x window) + "Allows the user to select a menu item to change a slot value in an inspect +window" + ;; This code is a very slightly hacked version of the system function + ;; DEFAULT.INSPECTW.PROPCOMMANDFN. We have to do this because the + ;; standard version makes some nasty assumptions about + ;; structure-objects that are not true for PCL objects. + (declare (special il:|SetPropertyMenu|)) + (case (il:menu (cond ((typep il:|SetPropertyMenu| 'il:menu) + il:|SetPropertyMenu|) + (t (il:setq il:|SetPropertyMenu| + (il:|create| il:menu il:items il:_ + '((set 'set + "Allows a new value to be entered" + ))))))) + (set + ;; The user want to set the value + (il:ersetq (prog ((il:oldvalueitem (il:itemofpropertyvalue slot-name + window)) + il:newvalue il:pwindow) + (il:ttydisplaystream (il:setq il:pwindow + (il:getpromptwindow window 3))) + (il:clearbuf t t) + (il:resetlst + (il:resetsave (il:\\itemw.flipitem il:oldvalueitem window) + (list 'il:\\itemw.flipitem + il:oldvalueitem window)) + (il:resetsave (il:tty.process (il:this.process))) + (il:resetsave (il:printlevel 4 3)) + (il:|printout| t "Enter the new " + slot-name " for " x t + "The expression read will be EVALuated." + t "> ") + (il:setq il:newvalue (il:lispx (il:lispxread t t) + '>)) + ; clear tty buffer because it + ; sometimes has stuff left. + (il:clearbuf t t)) + (il:closew il:pwindow) + (return (il:inspectw.replace window slot-name il:newvalue))))))) + +(defmethod inspect-title (x window) + "Return the title to use in an inspect window viewing x" + (format nil "Inspecting a ~A" (class-name (class-of x)))) + +(defmethod inspect-title ((x standard-class) window) + (format nil "Inspecting the class ~A" (class-name x))) + + +;;; Debugger support for PCL + + +(il:filesload pcl-env-internal) + +;; Non-PCL specific changes to the debugger + +;; Redefining the standard INTERESTING-FRAME-P function. Now functions can be +;; declared uninteresting to BT by giving them an XCL::UNINTERESTINGP +;; property. + +(dolist (fn '(si::*unwind-protect* il:*env* + evalhook xcl::nohook xcl::undohook + xcl::execa0001 xcl::execa0001a0002 + xcl::|interpret-UNDOABLY| + cl::|interpret-IF| cl::|interpret-FLET| + cl::|interpret-LET| cl::|interpret-LETA0001| + cl::|interpret-BLOCK| cl::|interpret-BLOCKA0001| + il:do-event il:eval-input + apply t)) + (setf (get fn 'xcl::uninterestingp) t)) + +(defun xcl::interesting-frame-p (xcl::pos &optional xcl::interpflg) + "Return TRUE iff the frame should be visible for a short backtrace." + (declare (special il:openfns)) + (let ((xcl::name (if (il:stackp xcl::pos) (il:stkname xcl::pos) xcl::pos))) + (typecase xcl::name + (symbol (case xcl::name + (il:*env* + ;; *ENV* is used by ENVEVAL etc. + nil) + (il:errorset + (or (<= (il:stknargs xcl::pos) 1) + (not (eq (il:stkarg 2 xcl::pos nil) + 'il:internal)))) + (il:eval + (or (<= (il:stknargs xcl::pos) 1) + (not (eq (il:stkarg 2 xcl::pos nil) + 'xcl::internal)))) + (il:apply + (or (<= (il:stknargs xcl::pos) 2) + (not (il:stkarg 3 xcl::pos nil)))) + (otherwise + (cond ((get xcl::name 'xcl::uninterestingp) + ;; Explicitly declared uninteresting. + nil) + ((eq (il:chcon1 xcl::name) (char-code #\\)) + ;; Implicitly declared uninteresting by starting the + ;; name with a "\". + nil) + ((or (member xcl::name il:openfns :test #'eq) + (eq xcl::name 'funcall)) + ;;The function won't be seen when compiled, so only show + ;;it if INTERPFLG it true + xcl::interpflg) + (t + ;; Interesting by default. + t))))) + (cons (case (car xcl::name) + (:broken t) + (otherwise nil))) + (otherwise nil)))) + +(setq il:*short-backtrace-filter* 'xcl::interesting-frame-p) + + +(eval-when (eval compile) + (il:record il:bkmenuitem (il:label (il:bkmenuinfo il:frame-name)))) + + +;; Change the frame inspector to open up lexical environments + + ;; Since the DEFSTRUCT is going to build the accessors in the package that is + ;; current at read-time, and we want the accessors to reside in the IL + ;; package, we have got to make sure that the defstruct happens when the + ;; package is IL. + +(in-package "IL") + +(cl:defstruct (frame-prop-name (:type cl:list)) + (label-fn 'nill) + (value-fn + (function + (lambda (prop-name framespec) + (frame-prop-name-data prop-name)))) + (setf-fn 'nill) + (inspect-fn + (function + (lambda (value prop-name framespec window) + (default.inspectw.valuecommandfn value prop-name (car framespec) window)))) + (data nil)) + +(cl:in-package "PCL") + +(defun il:debugger-stack-frame-prop-names (il:framespec) + ;; Frame prop-names are structures of the form + ;; (LABEL-FN VALUE-FN SETF-FN EDIT-FN DATA) + (let ((il:pos (car il:framespec)) + (il:backtrace-item (cadr il:framespec))) + (il:if (eq 'eval (il:stkname il:pos)) + il:then + (let ((il:expression (il:stkarg 1 il:pos)) + (il:environment (il:stkarg 2 il:pos))) + `(,(il:make-frame-prop-name :inspect-fn + (il:function + (il:lambda (il:value il:prop-name il:framespec il:window) + (il:inspect/as/function il:value (car il:framespec) il:window))) + :data il:expression) + ,(il:make-frame-prop-name :data "ENVIRONMENT") + ,@(il:for il:aspect il:in + `((,(and il:environment (il:environment-vars il:environment)) + "vars") + (,(and il:environment (il:environment-functions il:environment)) + "functions") + (,(and il:environment (il:environment-blocks il:environment)) + "blocks") + (,(and il:environment (il:environment-tagbodies il:environment)) + "tag bodies")) + il:bind il:group-name il:p-list + il:eachtime (il:setq il:group-name (cadr il:aspect)) + (il:setq il:p-list (car il:aspect)) + il:when (not (null il:p-list)) + il:join + `(,(il:make-frame-prop-name :data il:group-name) + ,@(il:for il:p il:on il:p-list il:by cddr il:collect + (il:make-frame-prop-name :label-fn + (il:function (il:lambda (il:prop-name il:framespec) + (car (il:frame-prop-name-data il:prop-name)))) + :value-fn + (il:function (il:lambda (il:prop-name il:framespec) + (cadr (il:frame-prop-name-data il:prop-name)))) + :setf-fn + (il:function (il:lambda (il:prop-name il:framespec il:new-value) + (il:change (cadr (il:frame-prop-name-data + il:prop-name)) + il:new-value))) + :data il:p)))))) + il:else + (flet ((il:build-name (&key il:arg-name il:arg-number) + (il:make-frame-prop-name :label-fn + (il:function (il:lambda (il:prop-name il:framespec) + (car (il:frame-prop-name-data il:prop-name)))) + :value-fn + (il:function (il:lambda (il:prop-name il:framespec) + (il:stkarg (cadr (il:frame-prop-name-data + il:prop-name)) + (car il:framespec)))) + :setf-fn + (il:function (il:lambda (il:prop-name il:framespec il:new-value) + (il:setstkarg (cadr (il:frame-prop-name-data + il:prop-name)) + (car il:framespec) + il:new-value))) + :data + (list il:arg-name il:arg-number)))) + (let ((il:nargs (il:stknargs il:pos t)) + (il:nargs1 (il:stknargs il:pos)) + (il:fnname (il:stkname il:pos)) + il:argname + (il:arglist)) + (and (il:litatom il:fnname) + (il:ccodep il:fnname) + (il:setq il:arglist (il:listp (il:smartarglist il:fnname)))) + `(,(il:make-frame-prop-name :inspect-fn + (il:function (il:lambda (il:value il:prop-name il:framespec + il:window) + (il:inspect/as/function il:value + (car il:framespec) + il:window))) + :data + (il:fetch (il:bkmenuitem il:frame-name) il:of il:backtrace-item)) + ,@(il:bind il:mode il:for il:i il:from 1 il:to il:nargs1 il:collect + (progn (il:while (il:fmemb (il:setq il:argname (il:pop il:arglist)) + lambda-list-keywords) + il:do + (il:setq il:mode il:argname)) + (il:build-name :arg-name + (or (il:stkargname il:i il:pos) + ; special + (if (case il:mode + ((nil &optional) il:argname) + (t nil)) + (string il:argname) + (il:concat "arg " (- il:i 1)))) + :arg-number il:i))) + ,@(let* ((il:novalue "No value") + (il:slots (il:for il:pvar il:from 0 il:as il:i il:from + (il:add1 il:nargs1) + il:to il:nargs il:by 1 il:when + (and (il:neq il:novalue (il:stkarg il:i il:pos + il:novalue)) + (or (il:setq il:argname (il:stkargname + il:i il:pos)) + (il:setq il:argname (il:concat + "local " + il:pvar))) + ) + il:collect + (il:build-name :arg-name il:argname + :arg-number il:i)))) + (and il:slots (cons (il:make-frame-prop-name :data "locals") + il:slots))))))))) + +(defun il:debugger-stack-frame-fetchfn (il:framespec il:prop-name) + (il:apply* (il:frame-prop-name-value-fn il:prop-name) + il:prop-name il:framespec)) + +(defun il:debugger-stack-frame-storefn (il:framespec il:prop-name il:newvalue) + (il:apply* (il:frame-prop-name-setf-fn il:prop-name) + il:prop-name il:framespec il:newvalue)) + +(defun il:debugger-stack-frame-value-command (il:datum il:prop-name + il:framespec il:window) + (il:apply* (il:frame-prop-name-inspect-fn il:prop-name) + il:datum il:prop-name il:framespec il:window)) + +(defun il:debugger-stack-frame-title (il:framespec &optional il:window) + (declare (ignore il:window)) + (il:concat (il:stkname (car il:framespec)) " Frame")) + +(defun il:debugger-stack-frame-property (il:prop-name il:framespec) + (il:apply* (il:frame-prop-name-label-fn il:prop-name) + il:prop-name il:framespec)) + +;; Teaching the debugger that there are other file-manager types that can +;; appear on the stack + +(defvar xcl::*function-types* '(il:fns il:functions) + "Manager types that can appear on the stack") + +;; Redefine a couple of system functions to use the above stuff + +#+Xerox-Lyric +(progn + +(defun il:attach-backtrace-menu (&optional (il:ttywindow + (il:wfromds (il:ttydisplaystream))) + il:skip) + (let ((il:bkmenu (il:|create| il:menu + il:items il:_ + (il:collect-backtrace-items il:ttywindow il:skip) + il:whenselectedfn il:_ + (il:function il:backtrace-item-selected) + il:whenheldfn il:_ + #'(il:lambda (il:item il:menu il:button) + (declare (ignore il:item il:menu)) + (case il:button + (il:left (il:promptprint + "Open a frame inspector on this stack frame" + )) + (il:middle (il:promptprint + "Inspect/Edit this function")) + )) + il:menuoutlinesize il:_ 0 + il:menufont il:_ il:backtracefont + il:menucolumns il:_ 1)) + (il:ttyregion (il:windowprop il:ttywindow 'il:region)) + il:btw) + (cond + ((il:setq il:btw (il:|for| il:atw il:|in| (il:attachedwindows il:ttywindow) + il:|when| (and (il:setq il:btw (il:windowprop il:atw 'il:menu)) + (eql (il:|fetch| (il:menu il:whenselectedfn) + il:|of| (car il:btw)) + (il:function il:backtrace-item-selected))) + il:|do| + (return il:atw))) + (il:deletemenu (car (il:windowprop il:btw 'il:menu)) + nil il:btw) + (il:windowprop il:btw 'il:extent nil) + (il:clearw il:btw)) + ((il:setq il:btw (il:createw (il:region-next-to (il:windowprop il:ttywindow 'il:region) + (il:widthifwindow (il:imin (il:|fetch| (il:menu + il:imagewidth + ) + il:|of| il:bkmenu) + il:|MaxBkMenuWidth|)) + (il:|fetch| (il:region il:height) il:|of| il:ttyregion + ) + 'il:left))) + (il:attachwindow il:btw il:ttywindow (cond + ((il:igreaterp (il:|fetch| (il:region il:left) + il:|of| (il:windowprop + il:btw + 'il:region)) + (il:|fetch| (il:region il:left) + il:|of| il:ttyregion)) + 'il:right) + (t 'il:left)) + nil + 'il:localclose) + (il:windowprop il:btw 'il:process (il:windowprop il:ttywindow 'il:process)) + + )) + (il:addmenu il:bkmenu il:btw (il:|create| il:_ il:position + il:xcoord il:_ 0 + il:ycoord il:_ (il:idifference (il:windowprop + il:btw + 'il:height) + (il:|fetch| (il:menu il:imageheight + ) il:|of| + il:bkmenu + )))))) + +(defun il:backtrace-item-selected (il:item il:menu il:button) + (il:resetlst + (prog (il:olditem il:ttywindow il:bkpos il:pos il:positions il:framewindow + (il:framespecn (il:|fetch| (il:bkmenuitem il:bkmenuinfo) il:|of| il:item) + + )) + (cond + ((il:setq il:olditem (il:|fetch| (il:menu il:menuuserdata) il:|of| il:menu)) + (il:menudeselect il:olditem il:menu) + )) + (il:setq il:ttywindow (il:windowprop (il:wfrommenu il:menu) + 'il:mainwindow)) + (il:setq il:bkpos (il:windowprop il:ttywindow 'il:stack-position)) + (il:setq il:pos (il:stknth (- il:framespecn) + il:bkpos)) + (let ((il:lp (il:windowprop il:ttywindow 'il:lastpos))) + (and il:lp (il:stknth 0 il:pos il:lp))) + (il:menuselect il:item il:menu) + (if (eq il:button 'il:middle) + (progn + + + (il:resetsave nil (list 'il:relstk il:pos)) + (il:inspect/as/function (il:|fetch| (il:bkmenuitem il:frame-name) + il:|of| il:item) + il:pos il:ttywindow)) + (progn + + + (il:setq il:framewindow + (xcl:with-profile (il:process.eval + (il:windowprop il:ttywindow 'il:process) + '(let ((il:profile (xcl:copy-profile (xcl:find-profile + "READ-PRINT")))) + (setf (xcl::profile-entry-value ' + xcl:*eval-function* il:profile) + xcl:*eval-function*) + (xcl:save-profile il:profile)) + t) + (il:inspectw.create (list il:pos il:item) + 'il:debugger-stack-frame-prop-names + 'il:debugger-stack-frame-fetchfn + 'il:debugger-stack-frame-storefn nil ' + il:debugger-stack-frame-value-command nil ' + il:debugger-stack-frame-title nil ( + il:make-frame-inspect-window + il:ttywindow) + 'il:debugger-stack-frame-property))) + (cond + ((not (il:windowprop il:framewindow 'il:mainwindow)) + (il:attachwindow il:framewindow il:ttywindow + (cond + ((il:igreaterp (il:|fetch| (il:region il:bottom) + il:|of| (il:windowprop il:framewindow + 'il:region)) + (il:|fetch| (il:region il:bottom) + il:|of| (il:windowprop il:ttywindow 'il:region))) + 'il:top) + (t 'il:bottom)) + nil + 'il:localclose) + (il:windowaddprop il:framewindow 'il:closefn (il:function il:detachwindow + )))))) + (return)))) + +(defun il:collect-backtrace-items (xcl::tty-window xcl::skip) + (let* ((xcl::items (cons nil nil)) + (xcl::items-tail xcl::items)) + (macrolet ((xcl::collect-item (xcl::new-item) + `(progn (setf (rest xcl::items-tail) + (cons ,xcl::new-item nil)) + (pop xcl::items-tail)))) + (let* ((xcl::filter-fn (cond + ((null xcl::skip) + #'xcl:true) + ((eq xcl::skip t) + il:*short-backtrace-filter*) + (t xcl::skip))) + (xcl::top-frame (il:stknth 0 (il:getwindowprop xcl::tty-window ' + il:stack-position))) + (xcl::next-frame xcl::top-frame) + (xcl::frame-number 0) + xcl::interesting-p xcl::last-frame-consumed xcl::use-frame xcl::label) + (loop (when (null xcl::next-frame) + (return)) + (multiple-value-setq (xcl::interesting-p xcl::last-frame-consumed + xcl::use-frame xcl::label) + (funcall xcl::filter-fn xcl::next-frame)) + (when (null xcl::last-frame-consumed) + + (setf xcl::last-frame-consumed xcl::next-frame)) + (when xcl::interesting-p + (when (null xcl::use-frame) + (setf xcl::use-frame xcl::last-frame-consumed)) + + (when (null xcl::label) + (setf xcl::label (il:stkname xcl::use-frame)) + (if (member xcl::label '(eval il:eval il:apply apply) + :test + 'eq) + (setf xcl::label (il:stkarg 1 xcl::use-frame)))) + + (loop (cond + ((not (typep xcl::next-frame 'il:stackp)) + (error "~%Use-frame ~S not found" xcl::use-frame)) + ((xcl::stack-eql xcl::next-frame xcl::use-frame) + (return)) + (t (incf xcl::frame-number) + (setf xcl::next-frame (il:stknth -1 xcl::next-frame + xcl::next-frame))))) + + (xcl::collect-item (il:|create| il:bkmenuitem + il:label il:_ (let ((*print-level* 2) + (*print-length* 3) + (*print-escape* t) + (*print-gensym* t) + (*print-pretty* nil) + (*print-circle* nil) + (*print-radix* 10) + (*print-array* nil) + (il:*print-structure* + nil)) + (prin1-to-string + xcl::label)) + il:bkmenuinfo il:_ xcl::frame-number + il:frame-name il:_ xcl::label))) + + (loop (cond + ((not (typep xcl::next-frame 'il:stackp)) + (error "~%Last-frame-consumed ~S not found" + xcl::last-frame-consumed)) + ((prog1 (xcl::stack-eql xcl::next-frame xcl::last-frame-consumed + ) + (incf xcl::frame-number) + (setf xcl::next-frame (il:stknth -1 xcl::next-frame + + xcl::next-frame))) + (return))))))) + (rest xcl::items))) + +) +#+Xerox-Medley +(progn + +(defun dbg::attach-backtrace-menu (&optional tty-window skip) + (declare (special il:\\term.ofd il:backtracefont)) + (or tty-window (il:setq tty-window (il:wfromds (il:ttydisplaystream)))) + (prog (btw bkmenu + (tty-region (il:windowprop tty-window 'il:region)) + ;; And, for the FORMAT below... + (*print-level* 2) + (*print-length* 3) + (*print-escape* t) + (*print-gensym* t) + (*print-pretty* nil) + (*print-circle* nil) + (*print-radix* 10) + (*print-array* nil) + (il:*print-structure* nil)) + (setq bkmenu + (il:|create| il:menu + il:items il:_ (dbg::collect-backtrace-items tty-window skip) + il:whenselectedfn il:_ 'dbg::backtrace-item-selected + il:menuoutlinesize il:_ 0 + il:menufont il:_ il:backtracefont + il:menucolumns il:_ 1 + il:whenheldfn il:_ + #'(il:lambda (item menu button) + (declare (ignore item menu)) + (case button + (il:left + (il:promptprint + "Open a frame inspector on this stack frame")) + (il:middle + (il:promptprint "Inspect/Edit this function")))))) + (cond ((setq btw + (dolist (atw (il:attachedwindows tty-window)) + ;; Test for an attached window that has a backtrace menu in + ;; it. + (when (and (setq btw (il:windowprop atw 'il:menu)) + (eq (il:|fetch| (il:menu il:whenselectedfn) + il:|of| (car btw)) + 'dbg::backtrace-item-selected)) + (return atw)))) + ;; If there is alread a backtrace window, delete the old menu from + ;; it. + (il:deletemenu (car (il:windowprop btw 'il:menu)) nil btw) + (il:windowprop btw 'il:extent nil) + (il:clearw btw)) + ((setq btw + (il:createw (dbg::region-next-to + (il:windowprop tty-window 'il:region) + (il:widthifwindow + (il:imin (il:|fetch| (il:menu il:imagewidth) + il:|of| bkmenu) + il:|MaxBkMenuWidth|)) + (il:|fetch| (il:region il:height) + il:|of| tty-region) + :left))) + ; put bt window at left of TTY + ; window unless ttywindow is + ; near left edge. + (il:attachwindow btw tty-window + (if (il:igreaterp (il:|fetch| (il:region il:left) + il:|of| + (il:windowprop btw + 'il:region)) + (il:|fetch| (il:region il:left) + il:|of| tty-region)) + 'il:right + 'il:left) + nil + 'il:localclose) + ;; So that button clicks will switch the TTY + (il:windowprop btw 'il:process + (il:windowprop tty-window 'il:process)))) + (il:addmenu bkmenu btw (il:|create| il:position + il:xcoord il:_ 0 + il:ycoord il:_ (- (il:windowprop btw 'il:height) + (il:|fetch| (il:menu + il:imageheight) + il:|of| bkmenu)))) + ;; IL:ADDMENU sets up buttoneventfn for window that we don't + ;; want. We want to catch middle button events before the menu + ;; handler, so that we can pop up edit/inspect menu for the frame + ;; currently selected. So replace the buttoneventfn, and can + ;; nuke the cursorin and cursormoved guys, cause don't need them. + (il:windowprop btw 'il:buttoneventfn 'dbg::backtrace-menu-buttoneventfn) + (il:windowprop btw 'il:cursorinfn nil) + (il:windowprop btw 'il:cursormovedfn nil))) + +(defun dbg::collect-backtrace-items (tty-window skip) + (xcl:with-collection + ;; + ;; There are a number of possibilities for the values returned by the + ;; filter-fn. + ;; + ;; (1) INTERESTING-P is false, and the other values are all NIL. This + ;; is the simple case where the stack frame NEXT-POS should be ignored + ;; completly, and processing should continue with the next frame. + ;; + ;; (2) INTERESTING-P is true, and the other values are all NIL. This + ;; is the simple case where the stack frame NEXT-POS should appear in + ;; the backtrace as is, and processing should continue with the next + ;; frame. + ;; + ;; [Note that these two cases take care of old values of the + ;; filter-fn.] + ;; + ;; (3) INTERESTING-P is false, and LAST-FRAME-CONSUMED is a stack + ;; frame. In that case, ignore all stack frames from NEXT-POS to + ;; LAST-FRAME-CONSUMED, inclusive. + ;; + ;; (4) INTERESTING-P is true, and LAST-FRAME-CONSUMED is a stack + ;; frame. In this case, the backtrace should include a single entry + ;; coresponding to the frame USE-FRAME (which defaults to + ;; LAST-FRAME-CONSUMED), and processing should continue with the next + ;; frame after LAST-FRAME-CONSUMED. If LABEL is non-NIL, it will be + ;; the label that appears in the backtrace menu; otherwise the name of + ;; USE-FRAME will be used (or the form being EVALed if the frame is an + ;; EVAL frame). + ;; + (let* ((filter (cond ((null skip) #'xcl:true) + ((eq skip t) il:*short-backtrace-filter*) + (t skip))) + (top-frame (il:stknth 0 (il:getwindowprop tty-window + 'dbg::stack-position))) + (next-frame top-frame) + (frame-number 0) + interestingp last-frame-consumed frame-to-use label-to-use) + (loop (when (null next-frame) (return)) + ;; Get the values of INTERSTINGP, LAST-FRAME-CONSUMED, + ;; FRAME-TO-USE, and LABEL-TO-USE + (multiple-value-setq (interestingp last-frame-consumed + frame-to-use label-to-use) + (funcall filter next-frame)) + (when (null last-frame-consumed) + (setf last-frame-consumed next-frame)) + (when interestingp + (when (null frame-to-use) + (setf frame-to-use last-frame-consumed)) + (when (null label-to-use) + (setf label-to-use (il:stkname frame-to-use)) + (if (member label-to-use '(eval il:eval il:apply apply) + :test 'eq) + (setf label-to-use (il:stkarg 1 frame-to-use)))) + + ;; Walk the stack until we find the frame to use + (loop (cond ((not (typep next-frame 'il:stackp)) + (error "~%Use-frame ~S not found" frame-to-use)) + ((xcl::stack-eql next-frame frame-to-use) + (return)) + (t (incf frame-number) + (setf next-frame + (il:stknth -1 next-frame next-frame))))) + + ;; Add the menu item to the list under construction + (xcl:collect (il:|create| il:bkmenuitem + il:label il:_ (let ((*print-level* 2) + (*print-length* 3) + (*print-escape* t) + (*print-gensym* t) + (*print-pretty* nil) + (*print-circle* nil) + (*print-radix* 10) + (*print-array* nil) + (il:*print-structure* nil)) + (prin1-to-string label-to-use)) + il:bkmenuinfo il:_ frame-number + il:frame-name il:_ label-to-use))) + + ;; Update NEXT-POS + (loop (cond ((not (typep next-frame 'il:stackp)) + (error "~%Last-frame-consumed ~S not found" + last-frame-consumed)) + ((prog1 + (xcl::stack-eql next-frame last-frame-consumed) + (incf frame-number) + (setf next-frame (il:stknth -1 next-frame + next-frame))) + (return)))))))) + +(defun dbg::backtrace-menu-buttoneventfn (window &aux menu) + (setq menu (car (il:listp (il:windowprop window 'il:menu)))) + (unless (or (il:lastmousestate il:up) (null menu)) + (il:totopw window) + (cond ((il:lastmousestate il:middle) + ;; look for a selected frame in this menu, and then pop up + ;; the editor invoke menu for that frame. don't change the + ;; selection, just present the edit menu. + (let* ((selection (il:menu.handler menu + (il:windowprop window 'il:dsp))) + (tty-window (il:windowprop window 'il:mainwindow)) + (last-pos (il:windowprop tty-window 'dbg::lastpos))) + + ;; don't have to worry about releasing POS because we + ;; only look at it here (nobody here hangs on to it) + ;; and we will be around for less time than LASTPOS. + ;; The debugger is responsible for releasing LASTPOS. + (il:inspect/as/function (cond + ((and selection + (il:|fetch| (il:bkmenuitem il:frame-name) + il:|of| (car selection)))) + ((and (symbolp (il:stkname last-pos)) + (il:getd (il:stkname last-pos))) + (il:stkname last-pos)) + (t 'il:nill)) + last-pos tty-window))) + (t (let ((selection (il:menu.handler menu + (il:windowprop window 'il:dsp)))) + (when selection + (il:doselecteditem menu (car selection) (cdr selection)))))))) + +;; This function isn't really redefined, but it needs to be recomiled since we +;; changed the def'n of the BKMENUITEM record. + +(defun dbg::backtrace-item-selected (item menu button) + ;;When a frame name is selected in the backtrace menu, this is the function + ;;that gets called. + (declare (special il:brkenv) (ignore button)) + (let* ((frame-spec (il:|fetch| (il:bkmenuitem il:bkmenuinfo) il:|of| item)) + (tty-window (il:windowprop (il:wfrommenu menu) 'il:mainwindow)) + (bkpos (il:windowprop tty-window 'dbg::stack-position)) + (pos (il:stknth (- frame-spec) bkpos))) + (let ((lp (il:windowprop tty-window 'dbg::lastpos))) + (and lp (il:stknth 0 pos lp))) + ;; change the item selected from OLDITEM to ITEM. Only do this on left + ;; buttons now. Middle just pops up the edit menu, doesn't select. -woz + (let ((old-item (il:|fetch| (il:menu il:menuuserdata) il:|of| menu))) + (when old-item (il:menudeselect old-item menu)) + (il:menuselect item menu)) + ;; Change the lexical environment so it is the one in effect as of this + ;; frame. + (il:process.eval (il:windowprop tty-window (quote dbg::process)) + `(setq il:brkenv ',(il:find-lexical-environment pos)) + t) + (let ((frame-window (xcl:with-profile + (il:process.eval (il:windowprop tty-window + 'il:process) + `(let ((profile (xcl:copy-profile + (xcl:find-profile + "READ-PRINT")))) + (setf + (xcl::profile-entry-value + 'xcl:*eval-function* profile) + xcl:*eval-function*) + (xcl:save-profile profile)) + t) + (il:inspectw.create pos + #'(lambda (pos) + (dbg::stack-frame-properties pos t)) + 'dbg::stack-frame-fetchfn + 'dbg::stack-frame-storefn + nil + 'dbg::stack-frame-value-command + nil + (format nil "~S Frame" (il:stkname pos)) + nil (dbg::make-frame-inspect-window + tty-window) + 'dbg::stack-frame-property)))) + (when (not (il:windowprop frame-window 'il:mainwindow)) + (il:attachwindow frame-window tty-window + (if (> (il:|fetch| (il:region il:bottom) il:|of| + (il:windowprop frame-window 'il:region)) + (il:|fetch| (il:region il:bottom) il:|of| + (il:windowprop tty-window 'il:region))) + 'il:top 'il:bottom) + nil 'il:localclose) + (il:windowaddprop frame-window 'il:closefn 'il:detachwindow))))) + +) ;end of Xerox-Medley + +(defun il:select.fns.editor (&optional function) + ;; gives the user a menu choice of editors. + (il:menu (il:|create| il:menu + il:items il:_ (cond ((il:ccodep function) + '((il:|InspectCode| 'il:inspectcode + "Shows the compiled code.") + (il:|DisplayEdit| 'ed + "Edit it with the display editor") + (il:|TtyEdit| 'il:ef + "Edit it with the standard editor"))) + ((il:closure-p function) + '((il:|Inspect| 'inspect + "Inspect this object"))) + (t '((il:|DisplayEdit| 'ed + "Edit it with the display editor") + (il:|TtyEdit| 'il:ef + "Edit it with the standard editor")))) + il:centerflg il:_ t))) + +;; + + +;; PCL specific extensions to the debugger + + +;; There are some new things that act as functions, and that we want to be +;; able to edit from a backtrace window + +(pushnew 'methods xcl::*function-types*) + +(eval-when (eval compile load) + (unless (generic-function-p (symbol-function 'il:inspect/as/function)) + (make-specializable 'il:inspect/as/function))) + +(defmethod il:inspect/as/function (name stack-pointer debugger-window) + ;; Calls an editor on function NAME. STKP and WINDOW are the stack pointer + ;; and window of the break in which this inspect command was called. + (declare (ignore debugger-window)) + (let ((editor (il:select.fns.editor name))) + (case editor + ((nil) + ;; No editor chosen, so don't do anything + nil) + (il:inspectcode + ;; Inspect the compiled code + (let ((frame (xcl::stack-pointer-frame stack-pointer))) + (if (and (il:stackp stack-pointer) + (xcl::stack-frame-valid-p frame)) + (il:inspectcode (let ((code-base (xcl::stack-frame-fn-header frame))) + (cond ((eq (il:\\get-compiled-code-base name) + code-base) + name) + (t + ;; Function executing in this frame is not + ;; the one in the definition cell of its + ;; name, so fetch the real code. Have to + ;; pass a CCODEP + (il:make-compiled-closure code-base)))) + nil nil nil (xcl::stack-frame-pc frame)) + (il:inspectcode name)))) + (ed + ;; Use the standard editor. + ;; This used to take care to apply the editor in the debugger + ;; process, so forms evaluated in the editor happen in the + ;; context of the break. But that doesn't count for much any + ;; more, now that lexical variables are the way to go. Better to + ;; use the LEX debugger command (thank you, Herbie) and + ;; shift-select pieces of code from the editor into the debugger + ;; window. + (ed name `(,@xcl::*function-types* :display))) + (otherwise (funcall editor name))))) + +(defmethod il:inspect/as/function ((name standard-object) stkp window) + (when (il:menu (il:|create| il:menu + il:items il:_ '(("Inspect" t "Inspect this object")))) + (inspect name))) + +(defmethod il:inspect/as/function ((x standard-method) stkp window) + (let* ((generic-function-name (slot-value (slot-value x 'generic-function) + 'name)) + (method-name (full-method-name x)) + (editor (il:select.fns.editor method-name))) + (il:allow.button.events) + (case editor + (ed (ed method-name '(:display methods))) + (il:inspectcode (il:inspectcode (slot-value x 'function))) + ((nil) nil) + (otherwise (funcall editor method-name))))) + +;; A replacement for the vanilla IL:INTERESTING-FRAME-P so we can see methods +;; and generic-functions on the stack. + +(defun interesting-frame-p (stack-pos &optional interp-flag) + ;; Return up to four values: INTERESTING-P LAST-FRAME-CONSUMED USE-FRAME and + ;; LABEL. See the function IL:COLLECT-BACKTRACE-ITEMS for a full description + ;; of how these values are used. + (labels + ((function-matches-frame-p (function frame) + "Is the function being called in this frame?" + (let* ((frame-name (il:stkname frame)) + (code-being-run (cond + ((typep frame-name 'il:closure) + frame-name) + ((and (consp frame-name) + (eq 'il:\\interpreter + (xcl::stack-frame-name + (il:\\stackargptr frame)))) + frame-name) + (t (xcl::stack-frame-fn-header + (il:\\stackargptr frame)))))) + (or (eq function code-being-run) + (and (typep function 'il:compiled-closure) + (eq (xcl::compiled-closure-fnheader function) + code-being-run))))) + (generic-function-from-frame (frame) + "If this the frame of a generic function return the gf, otherwise + return NIL." + ;; Generic functions are implemented as compiled closures. On the + ;; stack, we only see the fnheader for the the closure. This could + ;; be a discriminator code, or in the default method only case it + ;; will be the actual method function. To tell if this is a generic + ;; function frame, we have to check very carefully to see if the + ;; right stuff is on the stack. Specifically, the closure's ccode, + ;; and the first local variable has to be a ptrhunk big enough to be + ;; a FIN environment, and fin-env-fin of that ptrhunk has to point + ;; to a generic function whose ccode and environment match. + (let ((n-args (il:stknargs frame)) + (env nil) + (gf nil)) + (if (and ;; is there at least one local? + (> (il:stknargs frame t) n-args) + ;; and does the local contain something that might be + ;; the closure environment of a funcallable instance? + (setf env (il:stkarg (1+ n-args) frame)) + ;; and does the local contain something that might be + ;; the closure environment of a funcallable instance? + (typep env *fin-env-type*) + (setf gf (fin-env-fin env)) + ;; whose fin-env-fin points to a generic function? + (generic-function-p gf) + ;; whose environment is the same as env? + (eq (xcl::compiled-closure-env gf) env) + ;; and whose code is the same as the code for this + ;; frame? + (function-matches-frame-p gf frame)) + gf + nil)))) + (let ((frame-name (il:stkname stack-pos))) + ;; See if there is a generic-function on the stack at this + ;; location. + (let ((gf (generic-function-from-frame stack-pos))) + (when gf + (return-from interesting-frame-p (values t stack-pos stack-pos gf)))) + ;; See if this is an interpreted method. The method body is + ;; wrapped in a (BLOCK ...). We look for an + ;; interpreted call to BLOCK whose block-name is the name of + ;; generic-function. + (when (and (eq frame-name 'eval) + (consp (il:stkarg 1 stack-pos)) + (eq (first (il:stkarg 1 stack-pos)) 'block) + (symbolp (second (il:stkarg 1 stack-pos))) + (fboundp (second (il:stkarg 1 stack-pos))) + (generic-function-p + (symbol-function (second (il:stkarg 1 stack-pos))))) + (let* ((form (il:stkarg 1 stack-pos)) + (block-name (second form)) + (generic-function (symbol-function block-name)) + (methods (generic-function-methods (symbol-function block-name)))) + ;; If this is really a method being called from a + ;; generic-function, the g-f should be no more than a + ;; few(?) frames up the stack. Check for the method call + ;; by looking for a call to APPLY, where the function + ;; being applied is the code in one of the methods. + (do ((i 100 (1- i)) + (previous-pos stack-pos current-pos) + (current-pos (il:stknth -1 stack-pos) (il:stknth -1 current-pos)) + (found-method nil) + (method-pos)) + ((or (null current-pos) (<= i 0)) nil) + (cond ((equalp generic-function + (generic-function-from-frame current-pos)) + (if found-method + (return-from interesting-frame-p + (values t previous-pos method-pos found-method)) + (return))) + (found-method nil) + ((eq (il:stkname current-pos) 'apply) + (dolist (method methods) + (when (eq (method-function method) + (il:stkarg 1 current-pos)) + (setq method-pos current-pos) + (setq found-method method) + (return)))))))) + ;; Try to handle compiled methods + (when (and (symbolp frame-name) + (not (fboundp frame-name)) + (eq (il:chcon1 frame-name) + (il:charcode il:\()) + (or (string-equal "(method " (symbol-name frame-name) + :start2 0 :end2 13) + (string-equal "(method " (symbol-name frame-name) + :start2 0 :end2 12) + (string-equal "(method " (symbol-name frame-name) + :start2 0 :end2 8))) + ;; Looks like a name that PCL consed up. See if there is a + ;; GF nearby up the stack. If there is, use it to help + ;; determine which method we have. + (do ((i 30 (1- i)) + (current-pos (il:stknth -1 stack-pos) + (il:stknth -1 current-pos)) + (gf)) + ((or (null current-pos) + (<= i 0)) + nil) + (setq gf (generic-function-from-frame current-pos)) + (when gf + (dolist (method (generic-function-methods gf)) + (when (function-matches-frame-p (method-function method) + stack-pos) + (return-from interesting-frame-p + (values t stack-pos stack-pos method)))) + (return)))) + ;; If we haven't already returned, use the default method. + (xcl::interesting-frame-p stack-pos interp-flag)))) + + +(setq il:*short-backtrace-filter* 'interesting-frame-p) + +;;; Support for undo + + (defun undoable-setf-slot-value (object slot-name new-value) + (if (slot-boundp object slot-name) + (il:undosave (list 'undoable-setf-slot-value + object slot-name (slot-value object slot-name))) + (il:undosave (list 'slot-makunbound object slot-name))) + (setf (slot-value object slot-name) new-value)) + + (setf (get 'slot-value :undoable-setf-inverse) 'undoable-setf-slot-value) + + +;;; Support for ?= and friends + +;; The arglists for generic-functions are built using gensyms, and don't reflect +;; any keywords (they are all included in an &REST arg). Rather then use the +;; arglist in the code, we use the one that PCL kindly keeps in the generic-function. + +(xcl:advise-function 'il:smartarglist + '(if (and il:explainflg + (symbolp il:fn) + (fboundp il:fn) + (generic-function-p (symbol-function il:fn))) + (generic-function-pretty-arglist (symbol-function il:fn)) + (xcl:inner)) + :when :around :priority :last) + +(setf (get 'defclass 'il:argnames) + '(nil (class-name (#\{ superclass-name #\} #\*) + (#\{ slot-specifier #\} #\*) + #\{ slot-option #\} #\*))) + +(setf (get 'defmethod 'il:argnames) + '(nil (#\{ name #\| (setf name) #\} #\{ method-qualifier #\} #\* + specialized-lambda-list #\{ declaration #\| doc-string #\} #\* + #\{ form #\} #\*))) + +;;; Prettyprinting support, the result of Harley Davis. + +;; Support the standard Prettyprinter. This is really minimal right now. If +;; anybody wants to fix this, I'd be happy to include their code. In fact, +;; there is almost no support for Commonlisp in the standard Prettyprinter, so +;; the field is wide open to hackers with time on their hands. + + +(setf (get 'defmethod :definition-print-template) ;Not quite right, since it + '(:name :arglist :body)) ; doesn't handle qualifiers, + ; but it will have to do. + +(defun defclass-prettyprint (form) + (let ((left (il:dspxposition)) + (char-width (il:charwidth (il:charcode x) *standard-output*))) + (xcl:destructuring-bind (defclass name supers slots . options) form + (princ "(") + (prin1 defclass) + (princ " ") + (prin1 name) + (princ " ") + (if (null supers) + (princ "()") ;Print "()" instead of "nil" + (il:sequential.prettyprint (list supers) (il:dspxposition))) + (if (null slots) + (progn (il:prinendline (+ left (* 4 char-width)) *standard-output*) + (princ "()")) + (il:sequential.prettyprint (list slots) (+ left (* 4 char-width)))) + (when options + (il:sequential.prettyprint options (+ left (* 2 char-width)))) + (princ ")") + nil))) + +(let ((pprint-macro (assoc 'defclass il:prettyprintmacros))) + (if (null pprint-macro) + (push (cons 'defclass 'defclass-prettyprint) + il:prettyprintmacros) + (setf (cdr pprint-macro) 'defclass-prettyprint))) + +(defun binder-prettyprint (form) + ;; Prettyprints expressions like MULTIPLE-VALUE-BIND and WITH-SLOTS + ;; that are of the form (fn (var ...) form &rest body). + ;; This code is far from correct, but it's better than nothing. + (if (and (consp form) + (not (null (cdddr form)))) + ;; I have no idea what I'm doing here. Seems I can copy and edit somebody + ;; elses code without understanding it. + (let ((body-indent (+ (il:dspxposition) + (* 2 (il:charwidth (il:charcode x) + *standard-output*)))) + (form-indent (+ (il:dspxposition) + (* 4 (il:charwidth (il:charcode x) + *standard-output*))))) + (princ "(") + (prin1 (first form)) + (princ " ") + (il:superprint (second form) form nil *standard-output*) + (il:sequential.prettyprint (list (third form)) form-indent) + (il:sequential.prettyprint (cdddr form) body-indent) + (princ ")") + nil) ;Return NIL to indicate that we did + ; the printing + t)) ;Return true to use default printing + + +(dolist (fn '(multiple-value-bind with-accessors with-slots)) + (let ((pprint-macro (assoc fn 'il:prettyprintmacros))) + (if (null pprint-macro) + (push (cons fn 'binder-prettyprint) + il:prettyprintmacros) + (setf (cdr pprint-macro) 'binder-prettyprint)))) + + + +;; SEdit has its own prettyprinter, so we need to support that too. This is due +;; to Harley Davis. Really. + +(push (cons :slot-spec + '(((sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1) + break sedit::from-indent . 0) + (sedit::set-indent . 1) + (sedit::next-inline? 1 break sedit::from-indent . 1) + (sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1) + break sedit::from-indent . 0)) + ((sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1) + break sedit::from-indent . 0) + (sedit::set-indent . 1) + (sedit::next-inline? 1 break sedit::from-indent . 1) + (sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1) + break sedit::from-indent . 0)))) + sedit:*indent-alist*) + +(setf (sedit:get-format :slot-spec) + '(:indent :slot-spec :inline t)) + +(setf (sedit:get-format :slot-spec-list) + '(:indent :binding-list :args (:slot-spec) :inline nil)) + +(setf (sedit:get-format 'defclass) + '(:indent ((2) 1) + :args (:keyword nil nil :slot-spec-list nil) + :sublists (4))) + +(setf (sedit:get-format 'defmethod) + '(:indent ((2)) + :args (:keyword nil :lambda-list nil) + :sublists (3))) + +(setf (sedit:get-format 'defgeneric) 'defun) + +(setf (sedit:get-format 'generic-flet) 'flet) + +(setf (sedit:get-format 'generic-labels) 'flet) + +(setf (sedit:get-format 'call-next-method) + '(:indent (1) :args (:keyword nil))) + +(setf (sedit:get-format 'symbol-macrolet) 'let) + +(setf (sedit:get-format 'with-accessors) + '(:indent ((1) 1) + :args (:keyword :binding-list nil) + :sublists (2) + :miser :never)) + +(setf (sedit:get-format 'with-slots) 'with-accessors) + +(setf (sedit:get-format 'make-instance) + '(:indent ((1)) + :args (:keyword nil :slot-spec-list))) + +(setf (sedit:get-format '*make-instance) 'make-instance) + +;;; PrettyFileIndex stuff, the product of Harley Davis. + +(defvar *pfi-class-type* '(class defclass pfi-class-namer)) + +(defvar *pfi-method-type* '(method defmethod pfi-method-namer) + "Handles method for prettyfileindex") + +(defvar *pfi-index-accessors* nil + "t -> each slot accessor gets a listing in the index.") + +(defvar *pfi-method-index* :group + ":group, :separate, :both, or nil") + +(defun pfi-add-class-type () + (pushnew *pfi-class-type* il:*pfi-types*)) + +(defun pfi-add-method-type () + (pushnew *pfi-method-type* il:*pfi-types*)) + +(defun pfi-class-namer (expression entry) + (let ((class-name (second expression))) + ;; Following adds all slot readers/writers/accessors as separate entries in + ;; the index. Probably a mistake. + (if *pfi-index-accessors* + (let ((slot-list (fourth expression)) + (accessor-names nil)) + (labels ((add-accessor (method-index name-index) + (push (case *pfi-method-index* + (:group method-index) + (:separate name-index) + ((t :both) (list method-index name-index)) + ((nil) nil) + (otherwise (error "Illegal value for *pfi-method-index*: ~S" + *pfi-method-index*))) + accessor-names)) + (add-reader (reader-name) + (add-accessor `(method (,reader-name (,class-name))) + `(,reader-name (,class-name)))) + (add-writer (writer-name) + (add-accessor `(method ((setf ,writer-name) (t ,class-name))) + `((setf ,writer-name) (t ,class-name))))) + (dolist (slot-def slot-list) + (do* ((rest-slot-args (cdr slot-def) (cddr rest-slot-args)) + (slot-arg (first rest-slot-args) (first rest-slot-args))) + ((null rest-slot-args)) + (case slot-arg + (:reader (add-reader (second rest-slot-args))) + (:writer (add-writer (second rest-slot-args))) + (:accessor (add-reader (second rest-slot-args)) + (add-writer (second rest-slot-args))) + (otherwise nil)))) + (cons `(class (,class-name)) accessor-names))) + class-name))) + +(defun pfi-method-namer (expression entry) + (let ((method-name (second expression)) + (specializers nil) + (qualifiers nil) + lambda-list) + (do* ((rest-qualifiers (cddr expression) (cdr rest-qualifiers)) + (qualifier (first rest-qualifiers) (first rest-qualifiers))) + ((listp qualifier) (setq lambda-list qualifier) + (setq qualifiers (reverse qualifiers)) qualifiers) + (push qualifier qualifiers)) + (do* ((rest-lambda-list lambda-list (cdr rest-lambda-list)) + (arg (first rest-lambda-list) (first rest-lambda-list))) + ((or (member arg lambda-list-keywords) (null rest-lambda-list)) + (setq specializers (reverse specializers))) + (push (if (listp arg) (second arg) t) specializers)) + (let ((method-index `(method (,method-name ,@qualifiers ,specializers))) + (name-index `(,method-name ,@qualifiers ,specializers))) + (case *pfi-method-index* + (:group method-index) + (:separate name-index) + ((t :both) (list method-index name-index)) + ((nil) nil) + (otherwise (error "Illegal value for *pfi-method-index*: ~S" *pfi-method-index*)))))) + +(defun pfi-install-pcl () + (pfi-add-method-type) + (pfi-add-class-type)) + +(eval-when (eval load) + (when (boundp (quote il:*pfi-types*)) + (pfi-install-pcl)) + ) + diff --git a/pcl/impl/xerox/pcl-env.text b/pcl/impl/xerox/pcl-env.text new file mode 100644 index 0000000..25e090f --- /dev/null +++ b/pcl/impl/xerox/pcl-env.text @@ -0,0 +1,105 @@ +A (very) few words about PCL-ENV. If you require more information, consult the +source code. While it is not particularly well documented, it is the final +arbiter of truth regarding its own functionality. + +The file PCL-ENV.LISP defines some low-level facilities to integrate PCL into +the XeroxLisp environment. The first order of business is teaching the +FileManager (nee FilePackage) about CLOS defineing forms. This in turn brings +us to the issue of names. + + +o Names and the FileManager + +For the FileManager to keep track of defining forms, it needs to know how to +extract a (unique) name and FileManager type from the form. PCL-ENV includes +FileManager support for the definers DEFCLASS, DEFGENERIC, and DEFMETHOD. + +DEFCLASS +The name of a DEFCLASS form is the name of the class defined by the form. The +FileManager type is PCL::CLASSES. There is a FileManager "undefiner" provided +for DEFCLASS. + +DEFGENERIC +The name of a DEFGENERIC form is the name of the generic-function defined by the +form. The FileManager type is PCL::GENERIC-FUNCTIONS. + +DEFMETHOD +The name of a DEFMETHOD form is a list of the form +( {}* ({*})). The FileManager type is +PCL::METHODS. There is a FileManager "undefiner" provided for DEFMETHOD. +However, note that if a generic-function was created as a side-effect of the +DEFMETHOD, the undefiner will leave the generic-function defined (albet with no +methods). + +When editing, it would be onerous to require the programmer to type in the full name of a +method. PCL-ENV arranges it so that (ED ) will ask the programmer +which method on that generic-function should be edited. (If there is only one +method, it is assumed that that is the method to be edited.) As of the +Victoria-Day release, EQL specialized methods are handled correctly. + + +o Inspecting CLOS objects (and metaobjects) + +PCL-ENV defines a protocol that is used to inspect objects, and arranges that +the standard INSPECT function uses this protocol. Programmers can use this +protocol by defining additional methods on the following generic-functions. + +INSPECT-SLOT-NAMES object +Returns a list of "slots" to include in the inspector. The default method +returns a list of all slots on the object. + +INSPECT-SLOT-VALUE object slot-name +Returns the value to associated with the slot-name in the inspector. Slot-name +is one of the items returned by INSPECT-SLOT-NAMES. The default method returns +(SLOT-VALUE object slot-name). + +INSPECT-SETF-SLOT-VALUE object slot-name new-value +Sets the value associated with the slot-name in the inspector. Slot-name is one +of the items returned by INSPECT-SLOT-NAMES. The default method executes +(SETF (SLOT-VALUE object slot-name) new-value). + +INSPECT-TITLE object inspect-window +Returns the title to use in the inspect-window when inspecting object. The +default returns the string "Inspecting the class " when the object +is a class, or "Inspecting a " otherwise. + + +o Debugging and the Stack + +Debugging in PCL is complicated by generic-functions and methods appear on the +stack not as single objects, but as collections of functions that the programmer +did not directly call. PCL-ENV redefines a number of internal debugger +functions to simplify the presentation of the stack, and allow the programmer to +access to the original defining forms from the stack. These changes only affect +the "short" display backtrace (brought up by BT in a break window); the full +backtrace (brought up by BT!) is unaffected. + + +o Misc + +Prettyprinting + +The support for standard Prettyprinting is pretty minimal. Only DEFMETHOD, +DEFCLASS, WITH-ACCESSORS, and WITH-SLOTS are supported, and they aren't really +done right. Thanks to Harley Davis, PCL-ENV defines SEdit pretty-print specs +for the forms DEFCLASS, DEFMETHOD, DEFGENERIC, GENERIC-FLET, GENERIC-LABELS, +CALL-NEXT-METHOD, SYMBOL-MACROLET, WITH-ACCESSORS, WITH-SLOTS, and +MAKE-INSTANCE. + +?= + +The function SMARTARGLIST is changed to return appropriate values for the +arglists of generic-functions. The macros DEFCLASS and DEFMETHOD have "pretty" +arglists defined. + +PrettyFileIndex + +Again thanks to Harley Davis, PCL-ENV teaches PRETTY-FILE-INDEX about classes, +methods, and accessors. The variables PCL::*PFI-INDEX-ACCESSORS* and +PCL::*PFI-METHOD-INDEX* may be changed by the user to tailor the computation of +the file index. Note that the file PRETTY-FILE-INDEX must be loaded before +PCL-ENV for this to take effect. + + +--- smL 25-May-89 + diff --git a/pcl/impl/xerox/xerox-low.lisp b/pcl/impl/xerox/xerox-low.lisp new file mode 100644 index 0000000..861884a --- /dev/null +++ b/pcl/impl/xerox/xerox-low.lisp @@ -0,0 +1,173 @@ +;;; -*- Mode:LISP; Package:(PCL Lisp 1000); Base:10.; Syntax:Common-lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; +;;; This is the 1100 (Xerox version) of the file portable-low. +;;; + +(in-package 'pcl) + +(defmacro load-time-eval (form) + `(il:LOADTIMECONSTANT ,form)) + +;;; +;;; make the pointer from an instance to its class wrapper be an xpointer. +;;; this prevents instance creation from spending a lot of time incrementing +;;; the large refcount of the class-wrapper. This is safe because there will +;;; always be some other pointer to the wrapper to keep it around. +;;; +#+Xerox-Medley +(defstruct (std-instance (:predicate std-instance-p) + (:conc-name %std-instance-) + (:constructor %%allocate-instance--class ()) + (:fast-accessors t) + (:print-function %print-std-instance)) + (wrapper nil :type il:fullxpointer) + (slots nil)) + +#+Xerox-Lyric +(eval-when (eval load compile) + (il:datatype std-instance + ((wrapper il:fullxpointer) + slots)) + + (xcl:definline std-instance-p (x) + (typep x 'std-instance)) + + (xcl:definline %%allocate-instance--class () + (il:create std-instance)) + + (xcl:definline %std-instance-wrapper (x) + (il:fetch (std-instance wrapper) il:of x)) + + (xcl:definline %std-instance-slots (x) + (il:fetch (std-instance slots) il:of x)) + + (xcl:definline set-%std-instance-wrapper (x value) + (il:replace (std-instance wrapper) il:of x il:with value)) + + (xcl:definline set-%std-instance-slots (x value) + (il:replace (std-instance slots) il:of x il:with value)) + + (defsetf %std-instance-wrapper set-%std-instance-wrapper) + + (defsetf %std-instance-slots set-%std-instance-slots) + + (il:defprint 'std-instance '%print-std-instance) + + ) + +(defun %print-std-instance (instance &optional stream depth) + ;; See the IRM, section 25.3.3. Unfortunatly, that documentation is + ;; not correct. In particular, it makes no mention of the third argument. + (cond ((streamp stream) + ;; Use the standard PCL printing method, then return T to tell + ;; the printer that we have done the printing ourselves. + (print-std-instance instance stream depth) + t) + (t + ;; Internal printing (again, see the IRM section 25.3.3). + ;; Return a list containing the string of characters that + ;; would be printed, if the object were being printed for + ;; real. + (list (with-output-to-string (stream) + (print-std-instance instance stream depth)))))) + + ;; +;;;;;; FUNCTION-ARGLIST + ;; + +(defun function-arglist (x) + ;; Xerox lisp has the bad habit of returning a symbol to mean &rest, and + ;; strings instead of symbols. How silly. + (let ((arglist (il:arglist x))) + (when (symbolp arglist) + ;; This could be due to trying to extract the arglist of an interpreted + ;; function (though why that should be hard is beyond me). On the other + ;; hand, if the function is compiled, it helps to ask for the "smart" + ;; arglist. + (setq arglist + (if (consp (symbol-function x)) + (second (symbol-function x)) + (il:arglist x t)))) + (if (symbolp arglist) + ;; Probably never get here, but just in case + (list '&rest 'rest) + ;; Make sure there are no strings where there should be symbols + (if (some #'stringp arglist) + (mapcar #'(lambda (a) (if (symbolp a) a (intern a))) arglist) + arglist)))) + +(defun printing-random-thing-internal (thing stream) + (let ((*print-base* 8)) + (princ (il:\\hiloc thing) stream) + (princ "," stream) + (princ (il:\\loloc thing) stream))) + +(defun record-definition (name type &optional parent-name parent-type) + (declare (ignore type parent-name)) + ()) + + +;;; +;;; FIN uses this too! +;;; +(eval-when (compile load eval) + (il:datatype il:compiled-closure (il:fnheader il:environment)) + + (il:blockrecord closure-overlay ((funcallable-instance-p il:flag))) + + ) + +(defun compiled-closure-fnheader (compiled-closure) + (il:fetch (il:compiled-closure il:fnheader) il:of compiled-closure)) + +(defun set-compiled-closure-fnheader (compiled-closure nv) + (il:replace (il:compiled-closure il:fnheader) il:of compiled-closure nv)) + +(defsetf compiled-closure-fnheader set-compiled-closure-fnheader) + +;;; +;;; In Lyric, and until the format of FNHEADER changes, getting the name from +;;; a compiled closure looks like this: +;;; +;;; (fetchfield '(nil 4 pointer) +;;; (fetch (compiled-closure fnheader) closure)) +;;; +;;; Of course this is completely non-robust, but it will work for now. This +;;; is not the place to go into a long tyrade about what is wrong with having +;;; record package definitions go away when you ship the sysout; there isn't +;;; enough diskspace. +;;; +(defun set-function-name-1 (fn new-name uninterned-name) + (cond ((typep fn 'il:compiled-closure) + (il:\\rplptr (compiled-closure-fnheader fn) 4 new-name) + (when (and (consp uninterned-name) + (eq (car uninterned-name) 'method)) + (let ((debug (si::compiled-function-debugging-info fn))) + (when debug (setf (cdr debug) uninterned-name))))) + (t nil)) + fn) + diff --git a/pcl/impl/xerox/xerox-patches.lisp b/pcl/impl/xerox/xerox-patches.lisp new file mode 100644 index 0000000..87ed713 --- /dev/null +++ b/pcl/impl/xerox/xerox-patches.lisp @@ -0,0 +1,248 @@ +;;; -*- Mode: Lisp; Package: XCL-USER; Base: 10.; Syntax: Common-Lisp -*- +;;; +;;; ************************************************************************* +;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Any person obtaining a copy of this software is requested to send their +;;; name and post office or electronic mail address to: +;;; CommonLoops Coordinator +;;; Xerox PARC +;;; 3333 Coyote Hill Rd. +;;; Palo Alto, CA 94304 +;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) +;;; +;;; Suggestions, comments and requests for improvements are also welcome. +;;; ************************************************************************* +;;; +;;; + +(in-package "XCL-USER") + + +;;; Patch a bug with Lambda-substitution + +#+Xerox-Lyric +(defun compiler::meta-call-lambda-substitute (node) + (let* ((fn (compiler::call-fn node)) + (var-list (compiler::lambda-required fn)) + (spec-effects + (il:for var il:in var-list + il:unless (eq (compiler::variable-scope var) :lexical) + il:collect (compiler::effects-representation var))) + ;; Bind *SUBST-OCCURED* just so that META-SUBST-VAR-REF ahs a binding + ;; to set even when nobody cares. + (compiler::*subst-occurred* nil)) + (il:for var il:in var-list + il:as tail il:on (compiler::call-args node) + il:when + (and (eq (compiler::variable-scope var) :lexical) + (compiler::substitutable-p (car tail) var) + (dolist (compiler::spec-effect spec-effects t) + (when + (not (compiler::null-effects-intersection compiler::spec-effect + (compiler::node-affected (car tail)))) + (return nil))) + (dolist (compiler::later-arg (cdr tail) t) + (when (not (compiler::passable (car tail) compiler::later-arg)) + (return nil)))) + il:do + (setf (compiler::lambda-body fn) + (compiler::meta-substitute (car tail) var + (compiler::lambda-body fn)))) + (when (null (compiler::node-meta-p (compiler::lambda-body fn))) + (setf (compiler::node-meta-p fn) nil) + (setq compiler::*made-changes* t)))) + +;;; Some simple optimizations missing from the compiler. + + +;; Shift by a constant. + +;; Unfortunately, these cause the compiler to generate spurious warning +;; messages about "Unknown function IL:LLSH1 called from ..." It's not often +;; you come across a place where COMPILER-LET is really needed. + +#+Xerox-Lyric +(progn + +(defvar *ignore-shift-by-constant-optimization* nil + "Marker used for informing the shift-by-constant optimizers that they are in + the shift function, and should not optimize.") + +(defun il:lrsh1 (x) + (compiler-let ((*ignore-shift-by-constant-optimization* t)) + (il:lrsh x 1))) + +(defun il:lrsh8 (x) + (compiler-let ((*ignore-shift-by-constant-optimization* t)) + (il:lrsh x 8))) + +(defun il:llsh1 (x) + (compiler-let ((*ignore-shift-by-constant-optimization* t)) + (il:llsh x 1))) + +(defun il:llsh8 (x) + (compiler-let ((*ignore-shift-by-constant-optimization* t)) + (il:llsh x 8))) + +(defoptimizer il:lrsh il:right-shift-by-constant (x n &environment env) + (if (and (constantp n) + (not *ignore-shift-by-constant-optimization*)) + (let ((shift-factor (eval n))) + (cond + ((not (numberp shift-factor)) + (error "Non-numeric arg to ~S, ~S" 'il:lrsh shift-factor)) + ((= shift-factor 0) + x) + ((< shift-factor 0) + `(il:llsh ,x ,(- shift-factor))) + ((< shift-factor 8) + `(il:lrsh (il:lrsh1 ,x) ,(1- shift-factor))) + (t `(il:lrsh (il:lrsh8 ,x) ,(- shift-factor 8))))) + 'compiler:pass)) + +(defoptimizer il:llsh il:left-shift-by-constant (x n &environment env) + (if (and (constantp n) + (not *ignore-shift-by-constant-optimization*)) + (let ((shift-factor (eval n))) + (cond + ((not (numberp shift-factor)) + (error "Non-numeric arg to ~S, ~S" 'il:llsh shift-factor)) + ((= shift-factor 0) + x) + ((< shift-factor 0) + `(il:lrsh ,x ,(- shift-factor))) + ((< shift-factor 8) + `(il:llsh (il:llsh1 ,x) ,(1- shift-factor))) + (t `(il:llsh (il:llsh8 ,x) ,(- shift-factor 8))))) + 'compiler:pass)) + +) + + +;; Simple TYPEP optimiziation + +#+Xerox-Lyric +(defoptimizer typep type-t-test (object type) + "Everything is of type T" + (if (and (constantp type) (eq (eval type) t)) + `(progn ,object t) + 'compiler:pass)) + +;;; Declare side-effects (actually, lack of side-effects) info for some +;;; internal arithmetic functions. These are needed because the compiler runs +;;; the optimizers before checking the side-effects, so side-effect +;;; declarations on the "real" functions are oft times ignored. + +#+Xerox-Lyric +(progn + +(il:putprops cl::%+ compiler::side-effects-data (:none . :none)) +(il:putprops cl::%- compiler::side-effects-data (:none . :none)) +(il:putprops cl::%* compiler::side-effects-data (:none . :none)) +(il:putprops cl::%/ compiler::side-effects-data (:none . :none)) +(il:putprops cl::%logior compiler::side-effects-data (:none . :none)) +(il:putprops cl::%logeqv compiler::side-effects-data (:none . :none)) +(il:putprops cl::%= compiler::side-effects-data (:none . :none)) +(il:putprops cl::%> compiler::side-effects-data (:none . :none)) +(il:putprops cl::%< compiler::side-effects-data (:none . :none)) +(il:putprops cl::%>= compiler::side-effects-data (:none . :none)) +(il:putprops cl::%<= compiler::side-effects-data (:none . :none)) +(il:putprops cl::%/= compiler::side-effects-data (:none . :none)) +(il:putprops il:lrsh1 compiler::side-effects-data (:none . :none)) +(il:putprops il:lrsh8 compiler::side-effects-data (:none . :none)) +(il:putprops il:llsh1 compiler::side-effects-data (:none . :none)) +(il:putprops il:llsh8 compiler::side-effects-data (:none . :none)) + +) + +;;; Fix a nit in the compiler +#+Xerox-Lyric +(progn + +(il:unadvise 'compile) +(il:advise 'compile ':around '(let (compiler::*input-stream*) (inner))) + +) + +;;; While no person would generate code like (logor x), macro can (and do). + +(defun optimize-logical-op-1-arg (form env ctxt) + (declare (ignore env ctxt)) + (if (= 2 (length form)) + (second form) + 'compiler::pass)) + +(xcl:defoptimizer logior optimize-logical-op-1-arg) +(xcl:defoptimizer logxor optimize-logical-op-1-arg) +(xcl:defoptimizer logand optimize-logical-op-1-arg) +(xcl:defoptimizer logeqv optimize-logical-op-1-arg) + + +#+Xerox-Medley + +;; A bug compiling LABELS + +(defun compiler::meta-call-labels (compiler::node compiler:context) + ;; This is similar to META-CALL-LAMBDA, but we have some extra information. + ;; There are only required arguments, and we have the correct number of them. + (let ((compiler::*made-changes* nil)) + ;; First, substitute the functions wherever possible. + (dolist (compiler::fn-pair (compiler::labels-funs compiler::node) + (when (null (compiler::node-meta-p (compiler::labels-body compiler::node))) + (setf (compiler::node-meta-p compiler::node) nil) + (setq compiler::*made-changes* t))) + (when (compiler::substitutable-p (cdr compiler::fn-pair) + (car compiler::fn-pair)) + (let ((compiler::*subst-occurred* nil)) + ;; First try substituting into the body. + (setf (compiler::labels-body compiler::node) + (compiler::meta-substitute (cdr compiler::fn-pair) + (car compiler::fn-pair) + (compiler::labels-body compiler::node))) + (when (not compiler::*subst-occurred*) + ;; Wasn't in the body - try the other functions. + (dolist (compiler::target-pair (compiler::labels-funs compiler::node)) + (unless (eq compiler::target-pair compiler::fn-pair) + (setf (cdr compiler::target-pair) + (compiler::meta-substitute (cdr compiler::fn-pair) + (car compiler::fn-pair) + (cdr compiler::target-pair))) + (when compiler::*subst-occurred* ;Found it, we can stop now. + (setf (compiler::node-meta-p compiler::node) nil) + (setq compiler::*made-changes* t) (return))))) + ;; May need to reanalyze the node, since things might have changed. + ;; Note that reanalyzing the parts of the node this way means the the + ;; state in the enclosing loop is not lost. + (dolist (compiler::fns (compiler::labels-funs compiler::node)) + (compiler::meval (cdr compiler::fns) :argument)) + (compiler::meval (compiler::labels-body compiler::node) :return)))) + ;; Now remove any functions that aren't referenced. + (dolist (compiler::fn-pair (prog1 (compiler::labels-funs compiler::node) + (setf (compiler::labels-funs compiler::node) nil))) + (cond ((null (compiler::variable-read-refs (car compiler::fn-pair))) + (compiler::release-tree (cdr compiler::fn-pair)) + (setq compiler::*made-changes* t)) + (t (push compiler::fn-pair (compiler::labels-funs compiler::node))))) + ;; If there aren't any functions left, replace the node with its body. + (when (null (compiler::labels-funs compiler::node)) + (let ((compiler::body (compiler::labels-body compiler::node))) + (setf (compiler::labels-body compiler::node) nil) + (compiler::release-tree compiler::node) + (setq compiler::node compiler::body compiler::*made-changes* t))) + ;; Finally, set the meta-p flag if everythings OK. + (if (null compiler::*made-changes*) + (setf (compiler::node-meta-p compiler::node) compiler:context) + (setf (compiler::node-meta-p compiler::node) nil))) + compiler::node) + diff --git a/pcl/makefile b/pcl/makefile new file mode 100644 index 0000000..9617882 --- /dev/null +++ b/pcl/makefile @@ -0,0 +1,74 @@ +# makefile for making pcl -- W. Schelter. + +-include ../makedefs + +FILES:=$(shell ls -1 gcl_*.lisp | sed 's,\.lisp,,1') gcl_pcl_impl_low + +GFILES1:= 0 1 2 3 4 5 6 7 +GFILES:=$(addprefix gcl_pcl_gazonk,$(GFILES1)) + +AFILES:=$(FILES) $(GFILES) + +SETUP='(load "sys-package.lisp")' \ + '(setq *features* (delete (quote :kcl) *features*))'\ + '(load "defsys.lisp")(push (quote :kcl) *features*)' \ + '(setq pcl::*default-pathname-extensions* (cons "lisp" "o"))' \ + '(setq pcl::*pathname-extensions* (cons "lisp" "o"))' \ + '(load "sys-proclaim.lisp")' \ + '(setq compiler::*default-h-file* t)'\ + '(setq compiler::*default-c-file* t)'\ + '(setq compiler::*default-data-file* t)'\ + '(setq compiler::*default-system-p* t)' \ + '(setq compiler::*keep-gaz* t compiler::*tmp-dir* "")' + +all: $(addsuffix .c,$(AFILES)) $(addsuffix .o,$(AFILES)) + +saved_gcl_pcl: ../unixport/saved_gcl$(EXE) + cp ../h/cmpinclude.h . + echo $(SETUP) '(pcl::compile-pcl)' | $< + echo $(SETUP) '(pcl::load-pcl)(si::save-system "$@")' | $< + +$(addsuffix .c,$(AFILES)) $(addsuffix .data,$(AFILES))\ + $(addsuffix .h,$(AFILES)) $(addsuffix .lsp,$(GFILES)): \ + $(addsuffix .lisp,$(subst gcl_pcl_impl_low,impl/gcl/gcl_pcl_impl_low,$(FILES))) + rm -f *.o *gazonk* + cp ../h/cmpinclude.h . + echo ${SETUP} '(pcl::compile-pcl)' | ../unixport/saved_gcl$(EXE) + for i in gazonk* ; do \ + j=$$(echo $$i | sed 's,\..*$$,,1');k="gazonk$$(echo $$j | cut -f3 -d\_)";\ + l=$$(echo $$i | sed 's,^.*\.,,1');\ + if test "$$l" = "data" ; then\ + cp $$i gcl_pcl_$$k.$$l;\ + else\ + cat $$i | sed -e "s,$$j\.h,gcl_pcl_$$k.h,1"\ + -e "s,init_.*$$j,init_gcl_pcl_$$k,g" >gcl_pcl_$$k.$$l && rm $$i;\ + fi; done + +%.o: %.c %.h %.data + $(CC) $(CFLAGS) -c $< -o $@ + ../xbin/append $*.data $@ + +clean: + rm -f *.o *.fn *.exe *.dll saved_gcl_pcl$(EXE) cmpinclude.h *.c *.h *.data *gazonk* + + +# remake the sys-package.lisp and sys-proclaim.lisp files +# Those files may be empty on a first build. +remake-sys-files: + rm -f *.o *gazonk* + cp ../h/cmpinclude.h . + echo ${SETUP} '(load "../cmpnew/gcl_collectfn.lsp")(compiler::emit-fn t)' \ + '(pcl::compile-pcl)' | ../unixport/saved_gcl$(EXE) ../unixport/ + echo ${SETUP} '(load "../cmpnew/gcl_collectfn.lsp") '\ + '(pcl::load-pcl)(in-package "PCL")(renew-sys-files)' | \ + ../unixport/saved_gcl$(EXE) ../unixport/ + cp sys-proclaim.lisp xxx + cat xxx | sed -e "s/COMPILER::CMP-ANON//g" > sys-proclaim.lisp + rm xxx + + +tar: + $(MAKE) -f makefile.gcl tar1 DIR=`pwd` + +tar1: + (cd .. ; tar cvf - `basename ${DIR}` | gzip -c > `basename ${DIR}`.tgz) diff --git a/pcl/notes/12-7-88-notes.text b/pcl/notes/12-7-88-notes.text new file mode 100644 index 0000000..a940515 --- /dev/null +++ b/pcl/notes/12-7-88-notes.text @@ -0,0 +1,45 @@ +Copyright (c) Xerox Corporation 1988. All rights reserved. + + +These notes correspond to the "12/7/88 Can't think of a cute name PCL" +version of PCL. + +Please read this entire file carefully. You may also be interested in +looking at previous versions of the notes.text file. These are called +xxx-notes.text where xxx is the version of the PCL system the file +corresponds to. At least the last two versions of this file contain +useful information for any PCL user. + +This version of PCL has been tested at PARC in the following Common +Lisps: + + Symbolics 7.2 + Coral 1.2 + Lucid 3.0 + KCL (October 15, 1987) + Allegro 3.0.1 + +These three should work, but haven't been tested just yet. + + EnvOS Medley + TI + +The notes file hasn't yet been fleshed out yet. + +The two major changes in this release are: + + - The generic function cache algorithm has been revised. In addition + generic function caches now expand automatically. Programs that used + to run into problems with lots of cache misses shouldn't run into + those problems anymore. + + - the DEFCONSTRUCTOR hack now works. Please see the construct.lisp + file for details. If you are consing lots of instances, you may be + able to get a tremendous performance boost by using this hack. + + +Another important change is that this version includes some KCL patches +which dramatically improve PCL performance in KCL. See the kcl-mods.text +file for more details. + + diff --git a/pcl/notes/3-17-88-notes.text b/pcl/notes/3-17-88-notes.text new file mode 100644 index 0000000..7602fb0 --- /dev/null +++ b/pcl/notes/3-17-88-notes.text @@ -0,0 +1,167 @@ +Copyright (c) Xerox Corporation 1988. All rights reserved. + +These notes correspond to the beta test release of March 17th 1988. +Later versions of this release will run in the usual lisps, but for the +time being this has only been tested in Symbolics, Lucid, Coral, +Xerox, Ibuki (01/01), TI and VAXLisp Common Lisps. + +Note may not run in all Franz Lisps, I believe it runs on the SUN3 +though. I will get back to this in a few days when I get the needed +code from Franz. + +*** +This release will run in Lucid 3.0 beta 2, with the boolean.lbin patch. + +*** +This release contains a prototype implementation of the make-instance +behavior documented in the CLOS specification (X3J13 document # 88-002). +This prototype implementation does not provide high performance, but it +should conform to the specification with one exception, it does not +check the validity of the initargs. + +All the generic functions in the instance creation protocol are as +specified in the CLOS specification except that make-instance is called +mki instead. This name is a temporary name, it is so that people can +try out the new make-instance protocol without having to convert all +their code at once. In a future release, the name make-instance will be +switched to the new behavior. + +*** +Standard method combination is supported. General declarative +method combination is not yet supported, so define-method-combination does +not yet work, but standard method combination is what generic functions +do by default now. :after :before :around and unqualified methods are +supported. Error checking is minimal. + +*** +call-next-method works with standard-method-combination. +call-next-method is much faster than it was before, and call-next-method +behaves as a lexically defined function. This means it is possible to +pass around funargs which include call-next-method. + +*** +All uses of slot-value within a method body should be optimized. It +should no longer be necessary to use with-slots just to get the +optimization. + +*** +There are new macros with-slots* and with-accessors*. These correspond +to the macros which will appear in the final specification, with-slots +and with-accessors. They work as follows: + +(with-slots* ((x x-slot) + (y y-slot)) ===\ (let ((#:g1 (foo))) + (foo) ===/ (swapf (slot-value #:g1 'x-slot) + (swapf x y)) (slot-value #:g1 'y-slot))) + +(with-accessors* ((x position-x) + (y position-y)) ===\ (let ((#:g1 (foo))) + (foo) ===/ (incf (position-x #:g1)) + (incf x) (incf (position-y #:g1))) + (incf y)) + +As an abbreviation, the ( ) pairs in with-slots* +can be abbreviated to just when the variable +and slot name are the same. This means that: + +(with-slots* (x y z) &body ) + +is equivalent to: + +(with-slots* ((x x) (y y) (z z)) &body ) + +You should begin to convert your code to use these macros as soon as +possible since the old macro with-slots will swap names with with-slots* +sometime soon. + +A trick you may want to use for remembering the order of the first two +arguments to with-slots* and with-accessors* is that it is "like +multiple-value-bind". + +*** +In addition this release includes the beginnings of support for doing +some of the compiling which PCL does a load time at compile time +instead. To use this support, put the form: + + (pcl::precompile-random-code-segments) + +in a file which is compiled after all your other pcl using files are +loaded. Then arrange for that file to be loaded before all your +other pcl using files are loaded. + +For example, if your system has two files called "classes" and "methods", +create a new file called "precom" that contains: + + (in-package 'pcl) + + (pcl::precompile-random-code-segments) + + +Then you can use the defsystem stuff defined in the file defsys to +maintain your system as follows: + +(defsystem my-very-own-system + "/usr/myname/lisp/" + ((classes (precom) () ()) + (methods (precom classes) (classes) ()) + (precom () (classes methods) (classes methods)))) + +This defsystem should be read as follows: + +* Define a system named MY-VERY-OWN-SYSTEM, the sources and binaries + should be in the directory "/usr/me/lisp/". There are three files + in the system, there are named classes, methods and precom. (The + extension the filenames have depends on the lisp you are running in.) + +* For the first file, classes, the (precom) in the line means that + the file precom should be loaded before this file is loaded. The + first () means that no other files need to be loaded before this + file is compiled. The second () means that changes in other files + don't force this file to be recompiled. + +* For the second file, methods, the (precom classes) means that both + of the files precom and classes must be loaded before this file + can be loaded. The (classes) means that the file classes must be + loaded before this file can be compiled. The () means that changes + in other files don't force this file to be recompiled. + +* For the third file, precom, the first () means that no other files + need to be loaded before this file is loaded. The first use of + (classes methods) means that both classes and methods must be + loaded before this file can be compiled. The second use of (classes + methods) mean that whenever either classes or methods changes precom + must be recompiled. + +Then you can compile your system with: + + (operate-on-system 'my-very-own-system :compile) + +and load your system with: + + (operate-on-system 'my-very-own-system :load) + +*** +The code walker has gone through some signigificant revision. The +principle change is that the function walk-form now takes three required +arguments, and the walk-function itself now must accept an environment +argument. There are other changes having to do with the implementation +specific representation of macroexpansion environments. For details see +the file walk.lisp. + +*** +The following functions and macros which used to be supported for +backward compatibility only are now not supported at all: + +WITH* and WITH + +DEFMETH + +GET-SLOT + +MAKE + + +*** +There are other small changes in this release. If you notice one that +causes you problems please send me a message about it. + diff --git a/pcl/notes/3-19-87-notes.text b/pcl/notes/3-19-87-notes.text new file mode 100644 index 0000000..ce332f6 --- /dev/null +++ b/pcl/notes/3-19-87-notes.text @@ -0,0 +1,138 @@ + + +These notes correspond to *pcl-system-date* 3/19/87 prime. + +This release runs in: + ExCL + Lucid + Symbolics Common Lisp (Genera) + Vaxlisp (2.0) + Xerox Common Lisp (Lyric Release) + +CMU Lisp (nee Spice) and KCL should be working soon, I will announce +another release at that time. I figured it was better to get some +people beating on it as soon as possibl. + +Xerox Lisp users should FTP all the source files from /pub/pcl/ as well +as all the dfasl files from /pub/pcl/xerox/. Included in the xerox +specific directory is a file called PCL-ENV, which provides some simple +environment support for using PCL in Xerox Lisp. + + + +Following is a description of some of the things that are different in +this release of PCL. This list isn't in any particular order. There +are a number of incompatible changes in this release, please read the +whole thing carefully. + +As usual, please enjoy, and send bug-reports, questions etc. to +CommonLoops@Xerox.com. + +*** +The single most significant change is that discriminator-objects with +corresponding discriminating functions have been replaced by generic +function objects. What does this mean?? Well, in previous releases of +PCL, if you did: + +(defmethod foo ((x class)) 'class) +(defmethod foo ((x method)) 'method) + +Then (discriminator-named 'foo) returned a discriminator object which +had both of these methods defined on it. (symbol-function 'foo) +returned a discriminating function, which (discriminator-named 'foo) had +put in foo's function cell. + +In this release of PCL, the above defmethod's put a generic-function +object in foo's function cell. This generic-function object is a +combination of the discriminator object and discriminating function of +the previous releases of PCL. This generic-function object is +funcallable, funcalling it causes the appropriate method to be looked up +and called. This generic function object has accessors which return the +methods defined on the generic function. This generic function object +is mutable. It is possible to add and remove methods from it. + +(defmethod foo ((x class)) 'class) +(defmethod foo ((x method)) 'method) + +(generic-function-methods #'foo) +(# #) + +(foo (make 'class)) ==> 'class +(foo (make 'method)) ==> 'method + +(remove-method #'foo (car (generic-function-methods #'foo))) + +(foo (make 'class)) ==> 'class +(foo (make 'method)) ==> no matching method error + + +Note that as part of this change, the name of any function, generic +function or class which included the string "DISCRIMINATOR" has changed. +The name changes that happened were: + The class essential-discriminator was renamed to generic-function, + The class basic-discriminator and the class discrimiantor were + combined and renamed to standard-generic-function. + +If you went through your code and made the following name changes, you +would probably win, (this is what I did to PCL and it worked). + + essential-discriminator ==> generic-function + basic-discriminator ==> standard-generic-function + discriminator + (when it appears as a specializer) + ==> standard-generic-function + discriminator + (when it appears as part of a variable name or something) + ==> generic-function + +*** +In most Lisp implementations, method lookup is at least twice as fast as +it was in the previous release. + +*** +The compiler isn't called when PCL is loaded anymore. In a future +release, the compiler will also not be called when any other method +definitions are loaded. This is part of an effort to get PCL to a state +where the compiler will never be needed when compiled files are loaded. + +*** +PCL now has a mechanism for naming the generic-function's and method +functions defined by defmethod. This means that in ports of PCL which +take advantage of this mechanism, you will see useful function names in +the debugger rather than the useless gensym names that have been in the +past few releases. + +*** +Compiled files containing defmethod forms should be smaller and load +faster. + +*** +Many of the files in the system have been renamed. More files will be +renamed in upcoming releases. + +*** +An important part of the bootstrapping code has been re-written. The +remainder of this code (the BRAID1 and BRAID2 files) will be re-written +sometime soon. + +The changes made to bootstrapping in this release were done to make +early methods more understandable, and as part of implementing generic +function objects. Also, most users should find that PCL loads in less +time than it did before. + +The changes which will be made to bootstrapping in a future release will +make understanding the "Braid" stuff easier, and will make it possible +to implement slot-description objects as described in the CURRENT DRAFT +of the Common Lisp Object System Chapter 3. + +*** +The defsys file has been re-written AGAIN. This shouldn't affect users +since there are still the old familiar variables *pcl-pathname-defaults* +and *pathname-extensions*. + +*** +The specialized foo-notes files are all gone. Most of them were +hopelessly out of date, and installing pcl is now the same operation for +any Lisp. In particular, note that in Vaxlisp, it is no longer +necessary to push lisp:vaxlisp on the *features* list. + diff --git a/pcl/notes/4-21-87-notes.text b/pcl/notes/4-21-87-notes.text new file mode 100644 index 0000000..b1acd73 --- /dev/null +++ b/pcl/notes/4-21-87-notes.text @@ -0,0 +1,53 @@ + + +These notes correspond to *pcl-system-date* "4/21/87 April 21rst 1987". + +The notes from the last release are stored as 3-19-notes.text + +This release runs in: + ExCL + Lucid + Symbolics Common Lisp (Genera) + Vaxlisp (2.0) + Xerox Common Lisp (Lyric Release) + Kyoto Common Lisp (5.2) + +CMU Lisp (nee Spice) should be working soon, I will announce another +release at that time. + +Xerox Lisp users should FTP all the source files from /pub/pcl/ as well +as all the dfasl files from /pub/pcl/xerox/. Included in the xerox +specific directory is a file called PCL-ENV, which provides some simple +environment support for using PCL in Xerox Lisp. + + +The major difference in this release is that defclass conforms to the +CLOS specification (pretty much I hope). Previous warnings about what +would happen when defclass became CLOS defclass now apply. Once major +difference is that PCL currently does require that all a classes +superclasses be defined when a defclass form is evaluated. This will +change sometime soon. + +Other small changes include: + +Some more of the files have been renamed and restructured (as promised). + +the defclass parsing protocol has changed + +slotd datastructures are now instances of the class +standard-slot-description. + +a performance bug in the ExCL port which causes method lookup and slot +access to cons needlessly. + +a bug in the 3600 port which broke the printer for stack consed closures + +make-specializable + +a bug in Lucid lisp which made it impossible to say (compile-pcl) has +been patched around, this is the bug that manifested itself as NAME +being ubound. + + +As usual, please enjoy and send comments. + diff --git a/pcl/notes/4-29-87-notes.text b/pcl/notes/4-29-87-notes.text new file mode 100644 index 0000000..307b86e --- /dev/null +++ b/pcl/notes/4-29-87-notes.text @@ -0,0 +1,80 @@ + + +These notes correspond to *pcl-system-date* "4/29/87 prime April 29, 1987". + +The notes from the last release are stored as 4-21-notes.text + +This release runs in: + ExCL + Lucid + Symbolics Common Lisp (Genera) + Vaxlisp (2.0) + Xerox Common Lisp (Lyric Release) + Kyoto Common Lisp (5.2) + TI Common Lisp (Release 3) + +CMU Lisp (nee Spice) should be working soon, I will announce another +release at that time. + +TI release 2 should also be working soon, I will announce that when it +happens. + + +Note once again, that Xerox Lisp users should FTP all the source files +from /pub/pcl/ as well as all the dfasl files from /pub/pcl/xerox/. +Included in the xerox specific directory is a file called PCL-ENV, which +provides some simple environment support for using PCL in Xerox Lisp. +You must load PCL BEFORE loading pcl-env. + + +MAJOR CHANGES IN THIS RELEASE: + + make has been renamed to make-instance + + make-instance has been renamed to allocate-instance + +for compatibility, make can continue to be used as a synonym for +make-instance. unfortunately, code which used to call make-instance +must be converted. + +I would actually suggest that you do both of these name changes right +away. Two passes through the code using Query Replace seems to work +quite well (changing make-instance to allocate-instance and then make to +make-instance.) I was able to change all of PCL in about 10 minutes +that way. + +--- + +all functions and generic functions whose name included the string +"get-slot" have been renamed. Basically, get-slot was replaced +everywhere it appeared with slot-value. + +get-slot itself still exists for compatibility, but you should start +converting your code to use slot-value. + + + +OTHER CHANGES in this release: + +There is a new file called PKG which does the exports for PCL. PCL now +exports fewer symbols than before. Specifically, PCL now exports only +those symbols documented in the CLOS spec chapters 1 and 2. This means +that some symbols which may be needed by some programs are not exported. + +A good example is print-instance. print-instance is not exported and +since print-instance has not yet been renamed to print-object programs +which define methods on print-instance may want to import that symbol. + +--- + +pcl should load faster in this release. In particular, the file fixup +should load in less than half the time it did before. This release +should load in something like 80% of the time it took in the last +release. Remember, these numbers are only for comparison, your mileage +may vary. + +--- + +This release of PCL, as well as the last one, has *pcl-system-date* +which presents the date in both mm/dd/yy and Month day year format. + diff --git a/pcl/notes/5-22-87-notes.text b/pcl/notes/5-22-87-notes.text new file mode 100644 index 0000000..01aed9f --- /dev/null +++ b/pcl/notes/5-22-87-notes.text @@ -0,0 +1,126 @@ + + +These notes correspond to *pcl-system-date* "5/22/87 May 22nd, 1987". + +The notes from the last release are stored as 4-29-notes.text + +This release runs in: + CMU Lisp + ExCL + Lucid + Symbolics Common Lisp (Genera) + Vaxlisp (2.0) + Xerox Common Lisp (Lyric Release) + Kyoto Common Lisp (5.2) + TI Common Lisp (Release 3) + +TI release 2 should also be working soon, I will announce that when it +happens. + + +Note once again, that Xerox Lisp users should FTP all the source files +from /pub/pcl/ as well as all the dfasl files from /pub/pcl/xerox/. +Included in the xerox specific directory is a file called PCL-ENV, which +provides some simple environment support for using PCL in Xerox Lisp. +You must load PCL BEFORE loading pcl-env. + + +MAJOR CHANGES IN THIS RELEASE: + +--- + it is possible to forward reference classes in a defclass (or + add-named-class) form. This means it is possible to say: + + (defclass foo (bar) (i j k)) + + (defclass bar () (x y z)) + + Rather than having to put the in the "right" order. + + NOTE: the full-on error checking for this is not finished yet. + don't try to break it by doing things like: + + (defclass foo (bar) (i j k)) + (make-instance 'foo) + (defclass bar () (x y z)) + +--- + print-instance has been renamed to print-object + +--- + the defclass and class-definition protocol has changed. some of the +effects of this change are: + +* ADD-NAMED-CLASS is a true functional interface for defclass, so for + example, + + (defclass foo () (x y z) (:accessor-prefix foo-)) + + is equivalent to: + + (add-named-class (class-prototype (class-named 'class)) + 'foo + () + '(x y z) + '((:accessor-prefix foo-))) + +* defclass (and add-named-class) now undefined accessor methods, reader + methods and constructors which 'went away'. For example: + + (defclass foo () (x y z) (:reader-prefix foo-)) + + defines methods on the generic functions foo-x foo-y and foo-z. + + but if you then evaluated the defclass form: + + (defclass foo () (x y z)) + + those reader methods will be removed from the generic functions + foo-x foo-y and foo-z. + + Similarly constructors which 'went away' will be undefined. + +--- + writer methods generated by the :accessor and :accessor-prefix options + now pay attention to the :type slot-option. So, + + (defclass foo () ((x :accessor foo-x :type symbol))) + + (defvar *foo-1* (make-instance 'foo)) + + (setf (foo-x *foo-1*) 'bar) ; is OK + + (setf (foo-x *foo-1*) 10) ; signals an error + +--- + There are fewer built-in classes. Specifically, only the following + Common Lisp types have classes: + + ARRAY BIT-VECTOR CHARACTER COMPLEX CONS FLOAT INTEGER LIST + NULL NUMBER RATIO RATIONAL SEQUENCE STRING SYMBOL T VECTOR + +* In a future release the subtypes of FLOAT may have classes, that issue + is still under discussion. + +* Some ports of PCL also define classes for: + + HASH-TABLE PACKAGE PATHNAME RANDOM-STATE READTABLE STREAM + + it depends on how the type is represented in that Lisp's type system. + + +--- + The with-slots option :use-slot-value is now obsolete. You should use + the :use-accessors option as specified in the CLOS spec instead. + + with-slot forms which did not use the :use-slot-value option are OK, + you don't have to touch them. + + with-slot forms which used :USE-SLOT-VALUE T should be changed to say + :USE-ACCESSORS NIL. + + with-slot forms which used :USE-SLOT-VALUE NIL should be changed to + use neither option, or if you insist :USE-ACCESSORS T + + + diff --git a/pcl/notes/5-22-89-notes.text b/pcl/notes/5-22-89-notes.text new file mode 100644 index 0000000..3f198d8 --- /dev/null +++ b/pcl/notes/5-22-89-notes.text @@ -0,0 +1,152 @@ +Copyright (c) Xerox Corporation 1989. All rights reserved. + +These notes correspond to the "5/22/89 Victoria PCL" version of PCL. + +Please read this entire file carefully. Failure to do so guarantees +that you will have problems porting your code from the previous release +of PCL. + +You may also be interested in looking at previous versions of the +notes.text file. These are called xxx-notes.text where xxx is the +version of the PCL system the file corresponds to. At least the last +two versions of this file contain useful information for any PCL user. + +This version of PCL has been tested at PARC in the following Common +Lisps: + + Symbolics 7.2, 7.4 + Coral 1.2 + Lucid 3.0 + IBCL (October 15, 1987) + Allegro 3.0.1 + Golden Common Lisp 3.1 + EnvOS Medley + +These should work, but haven't been tested yet: + + TI + +This release is similar to Cinco de Mayo and Passover PCL. The major +difference is that this release actually works. + +*** + +*other-exports* flushed. More exports now on *exports* + +The symbol STANDARD is now exported from the PCL package. standard-class +standard-method standard-generic-function standard-object built-in-class +structure-class + +scoping problem with *next-methods* + + +method and generic function initialization protocol + +methods are immutable + +type-specifiers --> specializers + +load-truename etc. + +defgeneric ensure-generic-function define-method-combination + +metabraid changes + +file namings + +*** + +There are a number of minor and one major difference between this +release and No Cute Name PCL. + + +- In the last release there was an implementation of the specified CLOS +initialization protocol. This implementation had the correct behavior, +but some of the generic functions had temporary names (*make-instance, +*initialize-instance and *default-initargs). This was done to give +people time to convert their code to the behavior of the new +initialization protocol. + +In this release, all generic functions in the specified initialization +protocol have their proper names. The implementation of the old, +obsolete initialization protocol has disappeared entirely. + +The following renamings have happened: + + 12/7/88 release this release + + *make-instance make-instance + *initialize-instance initialize-instance + *default-initargs default-initargs + +The functions shared-initialize and reinitialize-instance already had +the proper names. + +The new initialization protocol is documented fully in the 88-002R +specification. + +As part of this change, PCL now uses the new initialization protocol to +create metaobjects internally. That is it calls make-instance to create +these metaobjects. The actual initargs passed are not yet as specified, +that will be in a later release. + +This is the largest change in this release. If you have not already +started using the new initialization protocol (with the temporary *xxx +names) you are going to have to do so now. In most cases, old methods +on the generic functions INITIALIZE, INITIALIZE-FROM-DEFAULTS and +INITIALIZE-FROM-INIT-PLIST must be substantially rewritten to convert +them to methods on INITIALIZE and SHARED-INITIALIZE. + +- slots with :ALLOCATION, :CLASS now inherit properly. As part of this +change, some slot description objects now return a class object as the +result of SLOTD-ALLOCATION. + +- There is now a minimal implementation of the DEFGENERIC macro. This +implementation supports no options, but it does allow you to define a +generic function in one place and put some comments there with it. + +- The following functions and macros have disappeared. This table also + show briefly what you use instead. + + DEFMETHOD-SETF (use DEFMETHOD) + RUN-SUPER (use CALL-NEXT-METHOD) + OBSOLETE-WITH-SLOTS (use WITH-SLOTS or WITH-ACCESSORS) + SYMBOL-CLASS (use FIND-CLASS) + CBOUNDP (use FIND-CLASS) + CLASS-NAMED (use FIND-CLASS) + GET-SETF-GENERIC-FUNCTION (use GDEFINITION) + +- In certain ports, method lookup will be faster because of a new scheme +to deal with interrupts and the cache code. In other ports it will be +slightly slower. In all ports, the cache code now interacts properly +with interrupts. + +- DEFMETHOD should interact properly with TRACE, ADVISE etc. in most +ports. two new port-specific functions (in defs.lisp) implement this. +These are unencapsulated-fdefinition and fdefine-carefully. If this +doesn't work properly in your port, fix the definition of these +functions and send it back so it can be in the next release. + +- This release runs in Golden Common Lisp version 3.0. + +- Previously, the use of slot-value (or with-slots) in the body of a +method which had an illegal specializer gave strange errors. Now it +gives a more reasonable error message. + +- An annoying problem which caused KCL and friends to complain about +*exports* being unbound has been fixed. + +- The walker has been modified to understand the ccl:%stack-block +special form in Coral Common Lisp. + +- The use of defadvice in pre 3.0 releases has been fixed in Lucid Low. + +- multiple-value-setq inside of with-slots now returns the correct +value. + +- A minor bug having to do with macroexpansion environments and the KCL +walker has been fixed. + +- A bug in the parsing of defmethod which caused only symbols (rather +than non-nil atoms) to be used as qualifiers. + diff --git a/pcl/notes/8-28-88-notes.text b/pcl/notes/8-28-88-notes.text new file mode 100644 index 0000000..854a90b --- /dev/null +++ b/pcl/notes/8-28-88-notes.text @@ -0,0 +1,537 @@ +Copyright (c) Xerox Corporation 1988. All rights reserved. + + +These notes correspond to the "8/24/88 (beta) AAAI PCL" version of PCL. + +Please read this entire document carefully. + +There have been a number of changes since the 8/2/88 version of PCL. As +usual, these changes are part of our efforts to make PCL conform with +the CLOS specicification (88-002R). This release contains the big +changes which the 7/7 through 8/2 releases were really getting ready +for. + +This version of PCL has been tested at PARC in the following Common +Lisps: + + Symbolics 7.2 + Coral 1.2 + Lucid 3.0 + Franz ?? + Xerox Lyric + Xerox Medley (aka EnvOS Medley) + KCL (October 15, 1987) + + +Most of the changes in this version of PCL fall into one of two +categories. + +The first major set of changes makes the order of arguments to setf +generic functions and methods conform with the spec. In addition, these +changes allow the first argument to defmethod to be of the form (SETF +). + +The second major set of changes have to do with slot access and instance +structure. Importantly, PCL now checks to see if a slot is bound, and +calls slot-unbound if the slot is unbound. This is a major change from +previous releases in which slot access just returned NIL for slots which +had not yet been set. These changes affect all the functions which +access the slots of an instance. In addition, the generic functions +which are called by the slot access functions in exceptional +circumstances are affected. This set of changes also include the +implemenentation of the real initialization protocol as specified by +88-002R. + +In addition, there are a number of other changes. The most significant +of these has to do with the symbols which the PCL package exports by +default. + +The rest of this document goes on to first describe the slot access +changes, then describe the setf generic function changes, and finally +describe some of the other minor changes. + +At the very end of this file is a new section which lists PCL features +which are scheduled to disappear in future releases. Please read this +section and take it to heart. This features will be disappearing. + + +*** Changes to slot access and instance structure *** + +This release includes a number of changes to the way slot access works +in PCL. Some of these changes are incompatible with old behavior. Code +which was written with the actual CLOS spec in mind should not be +affected by these incompatible changes, but some older code may be +affected. + +The basic thrust of the changes to slot access is to bring the following +functions and generic functions in line with the specification: + + slot-boundp + slot-exists-p + slot-makunbound + slot-missing + slot-unbound + slot-value + + slot-boundp-using-class + slot-exists-p-using-class + slot-makunbound-using-class + slot-value-using-class + + (setf slot-value) + (setf slot-value-using-class) + + change-class + make-instances-obsolete + + make-instance (temporarily called *make-instance) + initialize-instance (temporarily called *initialize-instance) + reinitialize-instance + update-instance-for-different-class + update-instance-for-redefined-class + shared-initialize + +In this release, these functions accept the specified number of +arguments, return the specified values, have the specified effects, and +are called by the rest of PCL in the specified way at the specified +times (with the exception that PCL does not yet call *make-instance to +create its own metaobjects). Because PCL now checks for unbound slots, +you may notice a slight performance degradation in certain applications. + +For complete information, you should of course see the CLOS specification. +The rest of this note is a short summary of how this new behavior is +different from the last release. + +- Dynamic slots are no longer supported. Various functions like + slot-value-always and remove-slot no longer exist. Also, + slot-value-using-class now only accepts the three arguments as + described in the spec. The two extra arguments having to do with + dynamic slots are no longer accepted. + + Shortly, we will release a metaclass which provides the now missing + dynamic slot behavior. + +- slot-missing now receives and accepts different arguments. + +- slot-unbound is now implemented, and is called at the appropriate + times. + +- the initialization protocol specified in 88-002R is now almost + completely implemented. The only difference is that the current + implementation does not currently check the validity of initargs. + So, no errors are signalled in improper initargs are supplied. + + Because of name conflicts with the two other initialization protocols + PCL currently supports, some of the specified initialization functions + do not have their proper name. The mapping between names in the + specification and names in this version of PCL is as follows: + + SPECIFIED IN PCL + + make-instance *make-instance + initialize-instance *initialize-instance + reinitialize-instance + update-instance-for-different-class + update-instance-for-redefined-class + shared-initialize + + + In a future release of PCL, these functions will have their proper + names, and all the old, obsolete initialization protocols will + disappear. + + Convert to using this new wonderful initialization protocol soon. + + Sometime soon we will release a version of PCL which does significant + optimization of calls to make-instance. This should speed up instance + creation dramatically, which should significantly improve the + performance of some programs. + +- The function all-slots no longer exists. There is a new generic + function called slots-to-inspect, which controls the default behavior + of describe. It also controls the default behavior of the inspector + in ports which have connected their inspectors to PCL. It specifies + which slots of a given class should be inspected. See the definition + in the file high.lisp for more. + +- the metaclass obsolete-class no longer exists. The mechanism by which + instances are marked as being obsolete is now internal, as described + in the spec. The generic-function make-instances-obsolete can be used + to force the instances of a class to go through the obsolete instance + update protocol (see update-instance-for-redefined-class). + +- all-std-class-readers-miss-1, a generic function which was part of + the database interface code I sent out a few weeks ago, has a slightly + different argument list. People using the code I sent out a few weeks + ago should replace the definition there with: + + (defmethod all-std-class-readers-miss-1 + ((class db-class) wrapper slot-name) + (declare (ignore wrapper slot-name)) + ()) + +- The implementation of the slot access generic functions have been + considerably streamlined. The impenetrable macrology which used to be + used is now gone. + +- Because the behavior of the underlying slot access generic functions + has changed, it is possible that some user code which hacks the + underlying instance structure may break. Most of this code shouldn't + break though. There have been some questions on the mailing list + about what is the right way to modify the structure of an instance. + I am working on that section of chapter 3 right now, and will answer + those questions sometime soon. + + +*** Changes to SETF generic functions *** + +This release of PCL includes a significant change related to the order +of arguments of setf generic functions. To most user programs, this +change should be invisible. Your program should run just fine in the +new version of PCL. Even so, there is some conversion you should do to +your program, since DEFMETHOD-SETF is now obsolete and will be going +away soon. + +Some programs may take some work to adapt to this change. This will +be particularly true of programs which manipulated methods for setf +generic-functions using make-instance, add-method and friends. + +Included here is a brief overview of this change to PCL. Most people +will find that this is all they need to know about this change. + +The CLOS specification assumes a default behavior for SETF in the +absence of any defsetf or define-modify-macro. The default behavior is +to expand forms like: + + (SETF (FOO x y) a) + +into: + + (FUNCALL #'(SETF FOO) a x y) + +The key point is that by default, setf expands into a call to a function +with a well-defined name, and that in that call, the new value argument +comes before all the other arguments. + +This requires a change in PCL, because previously, PCL arranged for the +new-value argument to be the last required argument. This change +affects the way automatically generated writer methods work, and the way +that defmethod with a first argument of the form (SETF ) works. + +An important point is that I cannot implement function names of the form +(SETF ) portably in PCL. As a result, in PCL, I am using names +of the form |SETF FOO|. Note that the symbol |SETF FOO| is interned in +the home package of the symbol FOO. (See the description of the +GET-SETF-FUNCTION and GET-SETF-FUNCTION-NAME). + + +The user-visible changes are: + +- DEFMETHOD will accept lists of the form (SETF FOO) as a first + argument. This will define methods on the generic function named + by the symbol |SETF FOO|. As specified in the spec, these methods + should expect to receive the new-value as their first argument. + Calls to defmethod of this form will also arrange for SETF of FOO to + expand into an appropriate call to |SETF FOO|. + +- Automatically generated writer methods will expect to receive the new + value as their first argument. + +- DEFMETHOD-SETF will also place the new-value as the first argument. + This is for backward compatibility, since defmethod-setf itself will + be obsolete, and you should convert your code to stop using it. + +- GET-SETF-FUNCTION is a function which takes a function name and + returns the setf function for that function if there is one. Note + that it doesn't take an environment argument. Note that this function + is not specified in Common Lisp or CLOS. PCL will continue to support + it as an extra export indefinetely. + +- GET-SETF-FUNCTION-NAME is a function which takes a function name + and returns the symbol which names the setf function for that + function. Note that this function is not specified in Common Lisp + or CLOS. PCL will continue to support it as an extra export + indefinetely. + +- For convenience, PCL defines a macro called DO-STANDARD-DEFSETF which + can be used to do the appropriate defsetf. This may be helpful for + programs which have calls to setf of a generic-function before any + of the generic function's method definitions. A use of this macro + looks like: + + (do-standard-defsetf position-x) + + Afterwards, a form like (SETF (POSITION-X P) V) will expand into a + form like (|SETF POSITION-X| V P). + + The reason you may have to use do-standard-defsetf is that I cannot + portably change every implementations SETF to have the new default + behavior. The proper way to use this is to take an early file in + your system, and put a bunch of calls to do-standard-defsetf in it. + Note that as soon as PCL sees a defmethod with a name argument of + the form (SETF FOO), or it sees a :accessor in a defclass, it will + do an appropriate do-standard-defsetf for you. + + +In summary, the only things that will need to be changed in most +programs is that uses of defmethod-setf should be converted to +appropriate uses of defmethod. + +Here is an example of a typical user program which is affected by this +change. + +(defclass position () + ((x :initform 0 :accessor pos-x) + (y :initform 0 :accessor pos-y))) + +(defclass monitored-position (position) + ()) + +(defmethod-setf pos-x :before ((p monitored-position)) (new) + (format *trace-output* "~&Changing x coord of ~S to ~D." p new)) + +(defmethod-setf pos-y :before ((p monitored-position)) (new) + (format *trace-output* "~&Changing y coord of ~S to ~D." p new)) + + +To bring this program up to date, you should convert the two +defmethod-setf forms as follows: + +(defmethod (setf pos-x) :before (new (p monitored-position)) + (format *trace-output* "~&Changing x coord of ~S to ~D." p new)) + +(defmethod (setf pos-y) :before (new (p monitored-position)) + (format *trace-output* "~&Changing y coord of ~S to ~D." p new)) + + +*** Other changes in this release *** + +* The symbols exported by the PCL package have now changed. The PCL +package now exports the symbols listed in the table of contents of +chapter 2 of the spec. This list of symbols is the value of the +variable pcl::*exports*. + +Following is the list of symbols which were exported in the 8/2/88 +version but which are not exported in the 8/18/88 version. + +DEFMETHOD-SETF DEFGENERIC-OPTIONS DEFGENERIC-OPTIONS-SETF +CLASS-CHANGED CLASS-NAMED SYMBOL-CLASS +CBOUNDP GET-METHOD GET-SETF-GENERIC-FUNCTION +MAKE-METHOD-CALL + +Following is the list of symbols which are exported in the 8/18/88 +version, but which were not exported in previous versions: + +CALL-METHOD CLASS-NAME COMPUTE-APPLICABLE-METHODS +DEFGENERIC ENSURE-GENERIC-FUNCTION FIND-METHOD +FUNCTION-KEYWORDS GENERIC-FLET GENERIC-LABELS +INITIALIZE-INSTANCE MAKE-INSTANCES-OBSOLETE NO-APPLICABLE-METHOD +NO-NEXT-METHOD REINITIALIZE-INSTANCE SHARED-INITIALIZE +SLOT-BOUNDP SLOT-EXISTS-P SLOT-MAKUNBOUND +SLOT-MISSING SLOT-UNBOUND SYMBOL-MACROLET +UPDATE-INSTANCE-FOR-DIFFERENT-CLASS +UPDATE-INSTANCE-FOR-REDEFINED-CLASS +WITH-ADDED-METHODS + +It should be noted that not all of these newly exported symbols have +been "implemented" yet. + + +* Any program written using PCL will need to be completely recompiled +to run with this release of PCL. + +* The generic-function generic-function-pretty-arglist now returns a +nice arglist for any generic function. It combines all the keyword +arguments accepted by the methods to get the combined set of keywords. +In some ports, the environment specific ARGLIST function has been +connected to this, and so the environments will print out nice arglists +for generic functions. + +* Some bugs in trace-method have been fixed. Trace-method should now +work in all ports of PCL. + +* NO-MATCHING-METHOD has been renamed to NO-APPLICABLE-METHOD. In +addition, it now receives arguments as specified. + +* defmethod has been modified to allow macros which expand into +declarations. + +* The :documentation slot option is now accepted in defclass forms. The +documentation string put here cannot yet be retrieved using the +documentation function. That will happen in a later release. + +* The :writer slot option is now implemented. + +* Some brain damage in high.lisp which caused method lookup to work +incorrectly for built in classes. In addition, it caused the +class-local-supers and class-direct-subclasses of the built in classes +to be strange. People using CLOS browsers should notice this change +dramatically, as it will make the browse of the built in part of the +class lattice look right. + + +*** Older Changes *** + +Following are changes which appeared in release of PCL from 7/7/88 to +8/2/88. Each change is marked with the release it appeared in. + + + +8/2/88 +Loading defclass forms should be much faster now. The bug which caused +all the generic functions in the world to be invalidated whenever a +class was defined has now been fixed. + +Loading defmethod forms should also be much faster. A bug which caused +a tremendous amount of needles computation whenever a method was also +fixed. + + + +8/2/88 +A bug which caused several slots of the classes T, OBJECT, CLASS and +STANDARD-CLASS to be unbound has been fixed. + + + +8/1/88 +load-pcl now adds the symbols :PCL and :PORTABLE-COMMONLOOPS to +*features*. + +PCL still doesn't do any sort of call to PROVIDE because of the total +lack of uniformity in the behavior of require and provide in the various +common lisp implementations. + + +8/1/88 +This version of PCL finally fixes the horrible bug that prevented +the initform for :class allocation slots from being evaluated when the +class was defined. + + +7/20/88 +PCL now converts the function describe into a generic function of one +argument. This is to bring it into conformance with the spec as +described in 88-002. + +In Symbolics Genera, it is actually a function of one required and one +optional argument. This is because the 3600 sometimes calls describe +with more than one argument. + +In Lucid Lisp, describe only takes an optional argument. This argument +defaults to the value of *. PCL converts describe to a generic function +of one required argument so it is not possible to call describe with +only one argument. + + +7/7/88 +class-named and symbol-class have been replaced by find-class. +find-class is documented in 88-002R. + + +7/7/88 +with-slots and with-accessors now conform to 88-002R. + +The old definition of with-slots is now called obsolete-with-slots. The +same is true for with-accessors. + + with-slots ---> obsolete-with-slots + with-accessors --> obsolete-with-accessors + +The temporary correct definition of with-slots, with-slots* is now +called with-slots. The same is true for with-accessors*. + + with-slots* --> with-slots + with-accessors* -> with-accessors + + +7/7/88 +The class-precedence list of the class null now conforms to 88-002R. + +In previous releases of PCL, the class precedence-list of the class +null was: (null list symbol sequence t). In this release the class +precedence list of the class null is: (null symbol list sequence t). + +This change was made to bring PCL into conformance with the spec. + + + +7/7/88 + +print-object now takes only two arguments. + +This changes was made to begin bringing print-object in conformance with +88-002R. print-object conforms to the spec to the extent that is is +called at the approrpiate times for PCL instances. In most +implementations, it is not called at the appropriate times for other +instances. This is not under my control, encourage your vendor to +provide the proper support for print-object. + + +7/7/88 +This version of PCL now includes a beta test version of a new iteration +package. This iteration package was designed by Pavel Curtis and +implemented by Bill vanMelle. This iteration package is defined in the +file iterate.lisp. Please feel free to experiment with it. We are all +very interested in comments on its use. + + + +*** PCL Features that will be disappearing *** + +This section describes features in PCL that will be disappearing in +future releases. For each change, I try to give a release date after +which I will feel free to remove this feature. This list should not be +considered complete. Certain other PCL features will disappear as well. +The items on this list are the user-interface level items that it is +possible to give a lot of warning about. Other changes will have more +subtle effects, for example when the lambda-list congruence rules are +implemented. + +- :accessor-prefix in defclass + +Can disappear anytime after 8/29. + +Warning that this is obsolete has been out for some time. You should +use :accessor in each of the slot specifications of the defclass form. +It is true that this is slightly more cumbersome, but the semantic +difficulties associated with :accesor-prefix are even worse. + +- :constructor in defclass + +Can disappear anytime after 8/29. + +Warning that this is obsolete has been out for some time. It will be +disappearing shortly because the intialization protocol which it goes +with will be disappearing. A future release of PCL will support a +special mechanism for defining functions of the form: + +(defun make-foo (x y &optional z) + (make-instance 'foo 'x x :y y :z z)) + +In the case where there are only :after methods on initialize-instance +and shared-initialize, these functions will run like the wind. We hope +to release this facility by 9/15. + +- old definition of make-instance, intialize, initialize-from-defaults, + initialize-from-init-plist + +Can disappear anytime after 8/29. + +Convert to using the new initialization protocol as described in the +spec and above. + +- mki, old definition of initialize-instance + +Can disappear anytime after 8/29. + +Convert to using the new initialization protocol as described in the +spec and above. + +- defmethod-setf + +Can disappear anytime after 9/15. + +Convert to using (defmethod (setf foo) ... + + diff --git a/pcl/notes/get-pcl.text b/pcl/notes/get-pcl.text new file mode 100644 index 0000000..e743744 --- /dev/null +++ b/pcl/notes/get-pcl.text @@ -0,0 +1,180 @@ +Here is the standard information about PCL. I have also added you to +the CommonLoops@Xerox.com mailing list. + +Portable CommonLoops (PCL) started out as an implementation of +CommonLoops written entirely in CommonLisp. It is in the process of +being converted to an implementation of CLOS. Currently it implements a +only a subset of the CLOS specification. Unfortunately, there is no +detailed description of the differences between PCL and the CLOS +specification, the source code is often the best documentation. + + Currently, PCL runs in the following implementations of + Common Lisp: + + EnvOS Medley + Symbolics (Release 7.2) + Lucid (3.0) + ExCL (Franz Allegro 3.0.1) + KCL (June 3, 1987) + AKCL (1.86, June 30, 1987) + Ibuki Common Lisp (01/01, October 15, 1987) + TI (Release 4.1) + Coral Common Lisp (Allegro 1.2) + Golden Common Lisp (3.1) + CMU + VAXLisp (2.0) + HP Common Lisp + Pyramid Lisp + +There are several ways of obtaining a copy of PCL. + +*** Arpanet Access to PCL *** + +The primary way of getting PCL is by Arpanet FTP. + +The files are stored on arisia.xerox.com. You can copy them using +anonymous FTP (username "anonymous", password "anonymous"). There are +several directories which are of interest: + +/pcl + +This directory contains the PCL sources as well as some rudimentary +documentation (including this file). All of these files are combined +into a single Unix TAR file. The name of this file is "tarfile". + +Extract the individual files from this tarfile by saying: + +tar -xf tarfile * + +where `tarfile' is the name you have given the tarfile in your +directory. Once you have done this, the following files are of special +interest: + +readme.text READ IT + +notes.text contains notes about the current state of PCL, and some + instructions for installing PCL at your site. You should + read this file whenever you get a new version of PCL. + +get-pcl.text contains the latest draft of this message + + +/pcl/doc + +This directory contains TeX source files for the most recent draft of +the CLOS specification. There are TeX source files for two documents +called concep.tex and functi.tex. These correspond to chapter 1 and 2 +of the CLOS specification. + + +/pcl/archive + +This directory contains the joint archives of two important mailings +lists: + + CommonLoops@Xerox.com + + is the mailing list for all PCL users. It carries announcements + of new releases of PCL, bug reports and fixes, and general advice + about how to use PCL and CLOS. + + Common-Lisp-Object-System@Sail.Stanford.edu + + is a small mailing list used by the designers of CLOS. + +The file cloops.text is always the newest of the archive files. + +The file cloops1.text is the oldest of the archive files. Higher +numbered versions are more recent versions of the files. + +*** Getting PCL on Macintosh floppies *** + +PCL is listed in APDAlog. It is distributed on Macintosh floppies. +This makes it possible for people who don't have FTP access to arisia +(but who do have a Macintosh) to get PCL. + +For $40 you receive a version of PCL and a copy of the CLOS spec (X3J13 +document number 88-002R). The APDAlog catalog number is T0259LL/A and +you can order by calling: + + From the U.S. (800)282-2732 + From Canada (800)637-0029 + International (408)562-3910 + FAX (408)562-3971 + + +NOTE: Whenever there is a new release of PCL you want, you should +probably wait a couple of months before ordering it from APDAlog. We +want to let new PCL's stabilize a bit before sending it to them, and it +will take them some time to integrate the new disks into their +distribution. + +*** Using the BITFTP server at Princeton *** + +For people who can't FTP from Internet (Arpanet) hosts, but who have +mail access to the BITNET, there exists a way to get the PCL files using +the BITFTP service provided by Princeton Univerity. If you know exactly +where to find the files that interest you, this is quite easy. In +particular, you have to know: + + * the Internet host name of the host that maintains the files (such + as `arisia.Xerox.COM') + * the directory where to find the files, relative to the root of the + FTP tree (i.E. `pub') + * whether the files are binary or ASCII text. + * the names of the files (say `pcl90.tar.Z' and `pcl90.README') + +To do this, send a message to BITFTP@PUCC (or BITFTP@PUCC.BITNET if you +aren't on BITNET itself). The subject line of the message will be +ignored. The text (body) of the message should be: + + FTP arisia.xerox.com UUENCODE + CD pcl + BINARY + GET tarfile + QUIT + +Then you wait (probably for about a day when you are in Europe) and +eventually you will receive E-Mail messages from BITFTP@PUCC (or +BITFTP2%PUCC...) with subject lines like `uudecoded file tarfile part +13'. Then you have to carefully concatenate the contents of ALL of +these files in the correct order. + + Note: The following works on our Suns and should work on any + Berkeley UNIX machine. If you don't have the `compress' or `zcat' + program, you can get a free version (with MIT's X Window System + distribution, for example). + +The resulting file can be `uudecode'd like this: + + dagobert% uudecode name-of-the-assembled-file + +This will give you a file tarfile.Z (it may actually have a different +name; then you may want to rename it in the first place). The `.Z' at +the end means that the file you now have is compressed. You can +uncompress it with `uncompress tarfile. You can untar the uncompressed +file with `tar -xvf tarfile'. + +This will write all files in the tarfile to the current directory. + +If you want to know more about the BITFTP service, send a letter to +`BITFTP@PUCC' that contains the single line `HELP'. + +*** Xerox Internet Access to PCL *** + +Xerox XNS users can get PCL from {NB:PARC:XEROX} + + + +Send any comments, bug-reports or suggestions for improvements to: + + CommonLoops.pa@Xerox.com + +Send mailing list requests or other administrative stuff to: + + CommonLoops-Request@Xerox.com + + +Thanks for your interest in PCL. +---------- + diff --git a/pcl/notes/lap.text b/pcl/notes/lap.text new file mode 100644 index 0000000..b7419f7 --- /dev/null +++ b/pcl/notes/lap.text @@ -0,0 +1,655 @@ +-*- Mode: Text -*- + +Copyright (c) 1985, 1986, 1987, 1988, 1989 Xerox Corporation. +All rights reserved. + +Use and copying of this document is permitted. Any distribution of this +document must comply with all applicable United States export control +laws. + +Last updated: 6/3/89 by Gregor + 10/26/89 by Gregor -- added :RETURN, removed :ISHIFT + +This file contains documentation of the PCL abstract LAP code. Any port +of PCL is required to implement the abstract LAP code interface. There +is a portable, relatively good performance implementation in the file +lap.lisp, port-specific implementations are in that file as well. + +The PCL abstract LAP code mechanism exists to provide PCL with a way to +create high-performance method lookup functions. Using this mechanism, +PCL can produce "LAP closures" which do the method lookup. By allowing +PCL to specify these closures using abstract LAP code rather that Lisp +code we hope to achieve the following: + + * Better runtime performance. By using abstract LAP code, we + will get better machine instruction sequences than we would + from compiling Lisp code. + + * Better load and update time performance. Because it should + be possible to "assemble" the LAP code more quickly than + compiling Lisp code, PCL will spend less time building the + method lookup code. + + * Ability to use PCL without a compiler. The LAP assembler will + still be required but this should be much smaller than the full + lisp compiler. + +Of course, not all implementations of the LAP code mechanism will +satisfy all of these goals. The first is the most important. + +In particular, many PCL ports will use the portable LAP implementation. +KCL will use the portable implementation in all of its ports. Other +Lisps may have custom LAP implementations for some ports and use the +portable implementation for other ports. + +Some Lisps will have a custom LAP implementation but will nonetheless +require the compiler to be loaded to generate LAP closure constructors. + +An important point is why we have chosen to take this route rather than +have each implementation implement the method lookup codes itself. This +was done because we are, at PARC, just beginning to study cache behavior +for CLOS programs. As we learn more about this we will want to modify +the caching strategy PCL uses. This architecture, because it leaves +PCL to implement caching behavior makes it possible to do this. Once +this study is complete, implementations may want to do their own, ultra +high performance implementations of caching strategies. + + + +Production of LAP closures is a two step process. In the first step, a +port-specific function is called to take abstract LAP code and produce a +a "lap closure generator". Lap closure generators are functions which +are called with a set of closure variable values and return a LAP +closure. + +The intermediary of the lap closure generators provides an important +optimization. Because it is assumed that producing the LAP closure +generator can take much longer than producing a LAP closure from the +generator, PCL attempts to make only one closure generator for each +sequence of LAP code. Because of the way PCL generates the LAP code +sequences, this is quite easy for it to do. + +The rest of this document is divided into six parts. + + * the metatypes std-instance and fsc-instance + + * an abstraction for simple vector indices + + * important optimizations + + * the port specific function for making lap closure generators + + * the actual abstract LAP code + + * examples + +*** The metatypes STD-INSTANCE and FSC-INSTANCE *** + +In PCL, instances with metaclass STANDARD-CLASS are represented using +the metatype STD-INSTANCE. (Note that in Cinco de Mayo PCL, this +metatype is called IWMC-CLASS.) Each port must implement this metatype. +The metatype could be implemented by the following DEFSTRUCT. + + (defstruct (std-instance + (:predicate std-instance-p) + (:conc-name %std-instance-) + (:constructor %allocate-std-instance (wrapper slots)) + (:constructor %allocate-std-instance-1 ()) + (:print-function print-std-instance)) + (wrapper nil) + (slots nil)) + + PCL itself will guarantee correct access to this structure and the + accessors and constructors. With this in mind, the following are + important. + + * Being able to type test this structure quickly is critical. See + the :STD-INSTANCE-P opcode. + + * The allocation functions should compile inline, do no argument + checking and be as fast as possible. + + * The accessor functions should compile inline, do no checking of their + arguments and be as fast as possible. SETF of the accessors should + do the same. + +The port is also required to implement the metatype FSC-INSTANCE (called +FUNCALLABLE-INSTANCE, or FIN for short, in Cinco de Mayo PCL). Objects +with this metatype are used, among other things, to implement generic +functions. These objects have field structure associated with them and +are also functions that can be applied to arguments. The fields are the +same as those for STD-INSTANCE, the FSC-INSTANCE metatype has +predicates, print-functions, constructors and accessors as follows: + + fsc-instance-p + print-fsc-instance + %fsc-instance-wrapper + %fsc-instance-slots + %allocate-fsc-instance (wrapper slots) + %allocate-fsc-instance-1 () + +In addition, objects of metatype FSC-INSTANCE have a property called the +funcallable instance function. When an FSC-INSTANCE is applied to +arguments, the funcallable instance function is what is actually called. +The funcallable instance function of an FSC-INSTANCE can be changed +using the function SET-FUNCALLABLE-INSTANCE-FUNCTION. There is no +mechanism for obtaining the funcallable instance function of an +FSC-INSTANCE. + +It is possible to implement the FSC-INSTANCE metatype in pure Common +Lisp. A simple implementation which uses lexical closures as the +instances and a hash table to record that the lexical closures are of +metatype FSC-INSTANCE is easy to write. Unfortunately, this +implementation adds significant overhead: + + to generic-function-invocation (1 function call) + to slot-access (1 function call or one hash table lookup) + to class-of a generic-function (1 hash-table lookup) + +In addition, it would prevent the FSC-INSTANCEs from being garbage +collected. In short, the pure Common Lisp implementation really isn't +practical. + +Note that previous implementations of FINS were always based on the +lexical closure metatype. In some ports, that provides poor +performance. Those ports may want to consider reimplementing to use the +compiled code metatype. In that implementation strategy, LAP closure +variables would become constants of the compiled code object. + +The following note from JonL is of interest when working on a FIN +implementation: + + Date: Tue, 16 May 89 05:45:56 PDT + From: Jon L White + + This isn't a bug in Lucid's compiler -- it's a lurking bug in PCL + that will "bite" most implementations where different settings of + the compiler optimization switches will produce morphologically + different (but of course functionally equivalent) function objects. + + The difficulty is in how discriminator codes service cache misses. + They "call out" to (potentially) random functions that will in some + cases "smash" the function object that was actually running as the + discriminator code. This is all right providing you don't return to + that function frame, but alas ... + + I know this is a more extensive problem because the code in the + port-independent function 'notice-methods-change' goes out of + its way to do a tail-recursive call to the function that is going + to smash the possibly-executing discriminator code. Here is the + commentary from that code (sic): + + ;; In order to prevent this we take a simple measure: we just + ;; make sure that it doesn't try to reference our its own closure + ;; variables after it makes the dcode change. This is done by + ;; having notice-methods-change-2 do the work of making the change + ;; AND calling the actual generic function (a closure variable) + ;; over. This means that at the time the dcode change is made, + ;; there is a pointer to the generic function on the stack where + ;; it won't be affected by the change to the closure variables. + + + A similar thing should be done in the construction of standard-accessor, + checking, and caching dcodes. In an experimental version here at Lucid, + I rewrote dcode.lisp to do that, and there is no problem with it. + Although that code is somewhat Lucid-specific, it could be of help to + someone who wanted to rewrite the generic dcode.lisp (no pun intended). + Contact me privately if you are interested. + + Doing a tail-recursive call out of dcodes when there is a cache miss + is a good thing, regardless of other problems. I think one might as + well do it. However, I should point out that in the presence of + multiprocessing, there is another more serious problem that cannot be + solved so simply. Think about what happens when one process decides + to update a dcode while another process is still using it; no such + stack-maintenance discipline will fix this case. A tail-recursive + exit from the dcode will *immensely* reduce the likelihood that + another process can sneak in during the interval in which the dcode + requires consistency in its function; but it can't reduce that + likelihood to zero. + + The more desirable thing to do is to put the whole "dcode" down one + more level of indirection through the symbol-function cell of the + generic function. This is effectively what PCL's 'make-trampoline' + function does, but unfortunately that is not a very efficient approach + when you consider how most compilers will compile it. Something akin + to the "mattress-pads" in Steve Haflich's code (in the fin.lisp file) + could probably be done for many other implementations as well. + + +*** Index Operations *** + +Indexes are an abstraction for indexes into a simple vector. This +abstraction is used to make it possible to generate more efficient +code to access simple vectors. The idea being that this may make it +possible to use alternate addressing modes to address these. + +The "index value" of an index is defined to be the fixnum of which that +index is an alternate form. So, using the Lisp function SVREF with the +index value of an index accesses the same element as using the index +with the appropriate access function or operand. + +The format of an index is unspecified, but is assumed to be something +like a fixnum with certain bits ignored. Accessing a vector using an +index must be done using the appropriate special accessor function or +opcode. + +Conversion from index values to indices and vice-versa can be done with +the following functions: + +INDEX-VALUE->INDEX (index-value) +INDEX->INDEX-VALUE (index) + + +The following constant indicates the maximum index value an index can +have in a given port. This must be at least 2^16. + +INDEX-VALUE-LIMIT - a fixnum, must be at least 2^16. + + +MAKE-INDEX-MASK ( ) + +This function is used to make index masks. Because I am lazy, I show an +implementation of it in the common case where indexes are just fixnums: + + (defun make-index-mask (cache-size line-size) + (let ((cache-size-in-bits (floor (log cache-size 2))) + (line-size-in-bits (floor (log line-size 2))) + (mask 0)) + (dotimes (i cache-size-in-bits) (setq mask (dpb 1 (byte 1 i) mask))) + (dotimes (i line-size-in-bits) (setq mask (dpb 0 (byte 1 i) mask))) + mask)) + +*** Optimizations *** + +This section discusses two important optimizations related to LAP +closures. The first relates to calling LAP closures themselves, the +second relates to calling other functions from LAP closures. + +The important point about calling LAP closures is that almost all of the +time, LAP closures will be used as the funcallable-instance-function of +funcallable instances. It is required that LAP closures be funcallable +themselves, but usually they will be stored in a FIN and the fin will +then be funcalled. This brings up several optimizations, including ones +having to do with access to the closure variables of a LAP closure. + +When a LAP closure is used to do method lookup, the function the LAP +closure ends up calling has the same number of required arguments as the +LAP closure itself. Since the LAP closure must check its required +arguments to do the lookup, it is redundant for the function called to +do so as well. Since LAP closures do all calls in a tail recursive way, +it should even be possible to optimize out certain parts of the normal +stack frame initialization. + +A similar situation occurs between effective method functions and the +individual method functions; the difference is that in effective method +functions, the calls are not necessarily tail recursive. + +Consequently, it would be nice to have a way to call certain functions +and inhibit the checking of required arguments. This is made possible +by use of the PCL-FAST-APPLY and PCL-FAST-FUNCALL macros together with +the PCL-FAST-CALL compiler declaration. + +The PCL-FAST-CALL compiler declaration declares that a function may be +fast called. Not all callers of the function will necessarily fast call +it, but most probably will. The :JMP opcode can only be used to call a +function compiled with the PCL-FAST-CALL declaration. + +The PCL-FAST-APPLY and PCL-FAST-FUNCALL macros are used to fast call a +function. The function argument must be a compiled function that has +the PCL-FAST-CALL compiler declaration in its lambda declarations. + +The basic idea is that the PCL-FAST-CALL compiler declaration causes the +compiler to set up an additional entrypoint to the function. This +entrypoint comes after checking of required arguments but before +processing of other arguments. + +Note: When FAST-APPLY is used, the required arguments will be given as +separate arguments and all other arguments will appear as a single +spread argument. For example: + +(let ((fn (compile () '(lambda (a b &optional (c 'z)) + (declare (pcl-fast-call)) + (list a b c))))) + + (pcl-fast-apply fn 'x 'y ()) ;legal + (pcl-fast-apply fn 'x 'y '(foo)) ;legal + (pcl-fast-apply fn '(a b c)) ;illegal + ) + +*** Producing LAP Closure Generators *** + +Each implementation of the LAP code mechanism must provide a port +specific function making lap closure generators. In the portable +implementation, this function is called PLAP-CLOSURE-GENERATOR. In +ExCL it should be called EXCL-LAP-CLOSURE-GENERATOR etc. + +At any time, the value of the variable *make-lap-closure-generator* is a +symbol which names the function currently being used to make lap closure +generators. + +The port specific function must accept arguments as follows: + +PLAP-CLOSURE-GENERATOR ( + + + + ) + +This returns a lap-closure generator. A lap-closure generator is a +function which is called with a number of arguments equal to the length +of . These arguments are the values of the closure +variables for the lap closure. These values cannot be changed once the +LAP closure is created. PCL takes care of keeping track of +lap-closure-generators it already has on hand and reusing them. The +function RESET-LAP-CLOSURE-GENERATORS can be called to force PCL to +forget all the lap closure generators it has remembered. + + + +A list of symbols. This provides a way to name particular arguments to +the LAP closure. Arguments which will not be referenced by name are +given as NIL. All required arguments to the LAP closure are explicitly +included (perhaps as NIL). If &REST appears at the end of arguments it +means that non-required arguments are allowed, these will be processed +by the methods. If &REST does not appear at the end of arguments, the +lap closure should signal an error if more than the indicated number of +arguments are supplied. + +Examples: + + - (obj-0 obj-1) + + Specifies a two argument lap closure. If more or less than + two arguments are supplied an error is signalled. Within + the actual lap code, both arguments can be referenced by + name (see the :ARG operand). + + - (obj-0 nil &rest) + + Specifies a two or more argument lap closure. If less than + two arguments are supplied an error is signalled. Within + the actual lap code, the first argument can be referenced by + name (see the :ARG operand). + + + + +A list of symbols. The closure will have these as closure variables. +Within the lap code these can be accessed using the :CVAR operand. The +lap code cannot change these values. SET-FUNCALLABLE-INSTANCE-FUNCTION +is permitted to have the special knowledge that there are at most ?? of +these and to be prepared to do something special when the funcallable +instance function of a funcallable instance is set to a lap closure. + + + +A list of register numbers. These registers will be used only to hold +indexes. Other registers may be used to hold indexes as well, but the +only values put into these registers will be indexes. + + + +A list of register numbers. These registers will be used only to hold +simple-vectors. Other registers may be used to hold simple-vectors as +well, but the only values put into these registers will be +simple-vectors. + + + + +The actual lap code for this closure. This is a list of LAP code +opcodes. See the section "Abstract LAP Code" for more details. + +Each implementation must also supply a function named PRE-MAKE-xxx where +xxx is the same as the name of its make-lap-closure-generator function. +The macro doesn't evaluate its arguments, and when it appears in a file +it should try to do some of the work at load time. It might appear in a +file like this: + +(eval-when (load) + (setq 1-arg-std-lap + (pre-make-plap-closure-generator ...))) + +*** Abstract LAP Code *** + +Each lap code operand has the form: (opcode operand1 ... operandn). + +In some cases, the distinction between an operand and an opcode is +somewhat arbitrary. In general, opcodes have a significant "action" +component to their behavior. Operands select a piece of data to operate +on. Some operands select their data in a more complex way, but they are +operands anyways. + +All data must be in a register before it can be operated on. This +requirement means that the only place a non-register operand can appear +is as the first argument to the :move opcode. (Actually, there is one +other exception, a :iref operand can be the target of a move as well.) +Moreover, only register operands can appear as the second argument to +the :move opcode and this register must not appear in the +operand. + +>> The operands are: + + (:reg ) + +A pseudo register. is an integer in the range [0 , 31]. + +A particular implementation can map this to a real register, a memory +location or the stack. The abstract LAP code itself does not include +the notion of a stack. + +PCL will attempt to optimize register use in two ways. PCL itself will +attempt to re-use registers whenever possible. That is, the port should +not have to worry with doing live register analysis for the registers. +In addition, PCL will consider lower numbered registers to be "faster" +than higher numbered ones. + + + (:cvar ) + +A closure variable of the lap-closure. is a symbol. + + + (:arg ) + +An argument to the LAP closure. is a symbol. + + (:std-wrapper ) + (:fsc-wrapper ) + (:built-in-wrapper ) + (:structure-wrapper ) + (:other-wrapper ) + +Get the class wrapper of . For std-instances and fsc-instances +this just fetches the wrapper field. The specific port is required to +implement fast access to the wrappers of built-in, structure and other +metatypes. A callback mechanism allows the port to ask PCL to generate +a class and wrapper for objects for which no class and wrapper exists +yet. This mechanism is <>. + + + (:std-slots ) + (:fsc-slots ) + +Fetch the slots field of a std-instance or a fsc-instance. + + (:constant ) + +This just allows inline constants. can be any Lisp object. + +The following operands operate on indexes. Each is patterned after a +Lisp function which would have a corresponding effect on the index value +of the index. + + (:i1+ ) + (:i+ ) + (:i- ) + (:ilogand ) + (:ilogxor ) + +Like the corresponding Lisp functions. + + + (:iref ) + +Like the SVREF function. must be a simple vector. + + (:cref ) + +The :cref operand is for constant vector references. must be +a fixnum. + +>> The opcodes are: + + (:move ) + +A full word move operation. + + + (:eq oO+S;w zu*_EaZ*ZQq6r zu_1oxzWx=P%hBBzO%&6Ps3VGg(8NUc{p-SJ6$ey=g6}lp1QX@*f;N7G``%eb4tj_Y zX^-D#_{MlWC%hCVE2GL$iRrLD`BEp6@tVX3ynr3i1}k2-96tX-0kI{YHVr2sLyfyo zmGG`8I9qTAs4#6?_6k6O*|Ocgp=&SDJCB|6_z+D1JP9 z#OKZA!Vfri0RPmv+<R8bIJSF@~Bk=+efXF@pt;=|KcT6yBCxw0QG2NsRQBv4RqfdxINWd56|03+1VnvC< zGkR>>wr$(CZQIs8wr!t#Y}>YN+r4elCQX|3WwIaUWp*Z$?D@a7K9q(eTGZ!IbN2Qb zi7y6qUH0^LPr2`l@d&yI5}6UXpz$G!8HCnvm{VUO^T}jcCHuk!s=$fMzy68lz-VOM z=eE*mcof?WMj=@|b~t}2A{5genGE?p_C%t%Qf|@jy(N0bDIYiErFhj|5CL-voGZdX zEw<~{AxB%;9!9Jo)w0oVS+OB9Mk0}{|2&M_ky_P>olLSpCXMix`zXA& ze=&r9q>d4Rqby~}QZtLHvJY{(on*%rU+t6`-o#J> z2@KJ}AohQ~jOG0fk3Dc)|5*vd;fRZzdl<^!*tB#j)-)v)qhC}eo!93>B{Sw_Af9~f zq4ti29UWrbv%#(7Y;<(TRV-wt@=A8Gj6lcvh`z+qJE2Z0N-K)qZ^R@= zP7Q~p;&Zk?T`rc1xwH=S#6;ee*J#@ZyBH44|0JNKzDk@R+EQn6&fS z)4uS<+*|qfa1QmPTwL@eCF&@lw zj)7NZv-Y*R%2{G3VP_V+yS|HJ-r!E0*C^*uoqUGr2J4=U!%3Qjo9-?9gh>a~)9~Q} zX+*Q|SY)_yh|Uq@hJzf9M0&bZ zE@Qq2UnV@Ht#uhuSG^$=PdmIo<$kozNtky0I6$Rak(dB`#UME`)hIO{-xM;_4zXcM z73SomB!7po?wm7hBMsD)VL1ItLy##7n2E`=;pUHe}#+p&=W}9@#ST(*J`UzaE@dNf78g~ z*eM`VMZQGgTVT8@K?T=|D8nCWFw88Olpd z|8lnk((x0h_1?ky9;$?usT$_4ark2L*3+TKSIkx)=(R>2ojNbB4RbKt3ux{($Fh<(RMD;*aiRl{q4b-0${E5j9uYv*3G?Z=xtKWg zX3T_5=Cm|xkdEuR%gnIkv>aBwD-K%3NfFx<4tBn&en@yMPg$889gh-`vzF9$E=PHjGLCHtzCY zA-yyn*q!oj#gjNjWaa7HGTE}cBte76!xn5}&sS5J@-FNnhCh9{n*!@V&)`3Y`E)P0 zQ(9K5TpSL<7229#9&vcm{qZJ-yZol>Jwr12cZo^#Fst#WNNQn?KF*r@^3MqxR&D7v zwYigrU*%HDPmAdW1|09=(MV&vBv-6Nfj7zOOqS&00HXhELlyZd`{_N6<$@b|l>UIA zj=UU2qiHX$d|JJ^^=_0T#bp(t*yS~gSs~%LqV8=!jIBx_T+KKbC9$T8JeNa1r}tQg z#BIc%Xq;IwqbLT_Y$D&r$Vl*%F5!^=$vtQ+YO+QMt{y}5a#fx|?LD(2zeUeTOp!07 zt+IZLq%HOp-jFn^p6&4~pFe--B9AMfC$T77Jw&TU@BcD=8~oV*jcQXIzI|+|wz6ha z+p|ZD6Yz4zU^#mT#R>z9sOu10u8r;5bzd8_zjWK=H9oxCh(q-=V{Kk1aG%L;IN?y3 zr$YGKm$D-UT1LOClxKEP$REy4SS->|CKy1ZIEkeRZZdXmscqc!Ax{?ag#9yg6+{q3 zg>h%dqp>;^gy-truwzVu2wC?M7*ZrSD|$%sJDY|4kZo6%dS z@FGS6czW&2f0s-8p?V<1vKN2{Q==+MMuV@wbo%FzA`H=8%CGaIwgj%U6HyZ-U0kFz zLpqlT-4d&EFg-9wL3A-6=MX*U)@TDS;2m?5XMkQKO}nsB+~%Z|GV>!VX1iJ2AG65$ zW=W)^1I`RNuN99jKyjEOd*-JmRBrKlt{%;l2tZsFWalEq+zCo zn6wpR#^^o(elx#Fm4V$8#>`qk%^Yz>!u zS9&{>F_~(7-mc!UL6~<<#K`aUUKq8|-6Sfqb@Ds4|EySy|1S^u24dzR82)GBV2P8P zYBSXywQ~vgF=$+uFZk!CtbrKN6ROSbz?e!~w0-RjbP<33?c`C~wzi-S67BOEg!oao zMgj#*cEZ}>)P459gqL=C{^{6?rxvb&>nXCw2L0ip6-9OjEq#yTAhmj1hQ{!2815FS zhGRW1QMeMD6OzVlMDA0?0^72Y;>_o#wE1-33iX&>3jGC$Iq5bDhdSMfo(CT&vPz1+ zf1PRd=j%ZmeKV$?vzU57|L1$+9c1thqj1FY%?Cxm?|Ka|7#x;1Ur=Z5%j$Wfh@Pp` zd#0UST0*lWCq^l$mJ(&E(~?sE-iYoyy}o@LJ=O{tFq^q%<^IiFy2P#*uOPUxXRK)} z*iL6HoQd0>8k1bv3{KLv&y1@Obd#J!C4Tgf_S(`3lA;IuffOK)9zYN8eM2Z`ik^5P z=q*!=Y?GIxt9ej!{o6@a3`ZJiBXybS4_ZImy?26>oNC-NJsrZpf%ERuCgQD7!;)CN{zBo-ffOkLeI7*}ERwC+US zC&g+t@>~WlM@|y73=<1{M!H`A7L?~0d&~eJejw3sQH@U^)omz;9y`kXl92VB~mcUm5{Q8Q!;MT ztTGsO!806`sgRoKe5^Xd%gd;rkCXTwQ*Crh+vBVN4mKR(xnXPcDlP+6wyv+avMI;I z@PRJv&OxK$+(;)QFt!>5b$v)YNTqr$EstOA$wBZxRV=>iwF?+#o<}Wdj?QocWIREq z24UQ>VQQLwWcvYA`4^Rg7#}7xh<3|Yygx9u?I&y%J!TscY2H+t*E=q1zf%$Di|=cB zR)Z_|CQ@zGWJFTJrhDwuD2L`P5D|zLJfWENMb0V2d9U6o+rx5j44X#xD3MhhAAQqJ zLv@S^We1tI?ZFpPW8#Rm0WWm~qxMGjjsrQT<{~2noIW(+C}H2Mf4WJ-<|<|*^*V^C z*(9HOq08G&4*U0(aYL~C@W^UaV3R1EQd6pEq(z+RjQ3+!SgtA&B zAbBf!%=6*9zb0kYLOTf+c9$sxr}q8i8JXiVYqL4#A6wWJAz?#TRN_lXAMK>^;@CW4 z<|2IX&$~MaXZz{4mok4+_vDGZ@$<{(p~z8qiP4$GsT5F!$qN02y(CHQ9ge*wH)3Q2 z08W_jzhc77~DRFBRqQljwLX^kmj>~u(PpHZ}SQ6OeGM5H{z7VyIwJCDgaayJHtcNHgwbbA*cOY1#cAA49)`NGyE3K$>` zj2NcT=!o0x)qS5%C^Tcv=U4YLgDBnOA1@j9jbB)3rEK>Hr=ARo_s#{kbT}>;d}gnszhQFV$7`jn1#DKJPGbml^l< z7ILa!)~~kAUQz2&_GkZE)cDyrArrm-2LQwy`2aVd8*jKW{E#V1e#MTPcqazvWlGj_ z|H)5yV-wKWoQ;-td?$O?d`UuogL>w?zj8&HKjE+D@) zn*4m4f&)JsfK&4d8ppVqH&e4X`N*j(+Y>S8O&~6^mwbKki>A!_{CO7B8~Q1Qf~j>2 z-PN@Gzxb#jxHn5AXM-2#o*vxpn`vd)kkjrj>H0ko~QP8(5p zy%?TVb0ZbH#94!P(~jJ>$-K+nHkULc^s{IvNyrvo+=8n#9k|M^Ge+?EcAPPYUg*y6 zQp0Ob)LLuvP9xXrS(D2Kzf@`HAXcH^5ctP8lbfZpNKT}@CLogx0woMDDmXC5_^|gH z)G1r0OOGjoU5@a;3;gtHZS^3E-fX%g*>C}Z{mr_foSURJ0ZE69FsNd#77)0 z)~IwLY3#$Z$qW#s8XHKMLIsRZNCd_!?6+Ou z={N8{&wV;o_$H!}V(hu^_qz6`Do<>@n{R=ZyD; z+gma?g{EsqiIe#P>msG>g#Zc}^6pGTAP2Xu#+?QFZw$N4Y=)8T=R4xs4@(j2#JPk9 zN_{ZmsT_4qj>hJfv)kP9GQm8x6g(h{-pp-R!%4#)4#$xvfWl`zX&XLcBYiwomKLxT z=xi_n<-dnGg*A+D9`KPWKR-J0It-5_Hb9IdN-ARdD+gno0GK`WKx$3j`kV@mtqLV3 z?t`(p`Y~ajNgHhOCrvwte0H$cFTmf~8r zT&$$WrEKKY>K9DE!Z>eD#~Zez#z*%{<#qO_E`p=?qJg-(+VS}`sm$SIc(*B3X@g|Z zkMgPdFEsCN5rnULTvF`wKs~s}qjAl*NR5Zl&}29mV8ugSJ9deF;R`cUN7=~r4FYOG zai;&_nivH1Cu`%D&$%98_d@um8jXE+z)+qMD+In+ibu?fk3}6~?y)I4L^bvnekSEH zjuY|?6I3Va*8-LLO4+M7?>;v8FZxMSouhs{3DZeLs9{6vYLjE?Ko4M2ET1B~`7AXj zfJZv7FE_$i%^Q$!CHXx?RXJ+nyvy**NRiJC0aoh4sLG660#Hln_sW!SlBAF6k#n*;p*HY+b_K zWjssg0Zt1O99c$7=_cUNv0?c(i;w!%oJ8crqv4#Ut0asZIVAmdDid`DxzCNY^uL-H zl)avTTP>|0b}vbYIk}^@>wtH5>hBDQAyTO3H3=fYr##jAmXZr z1h*=TO7UV%z;tPeylevsvcCa_>EdgM^;z96Rez-4run%WpMj^!?+)+%giE^o4@N*h zWvR_UdUHUJB~LGqzJ44)ljw_ItD?*TMGkZ?@&WwIb0ukaaNLrh@3kq#xjozDUl(Q= z;%-3|57;A$gO1UtF`f472n0j!XAQ9`&kVBpWP<|Zq)w;&o@y0uN0!7VL^1jC>nwq0 z+do}q<<4dLu>S~Is$kc%#E^m4i&4e$W$GsaGcGFvfxx6ALIr$~Fo<@)PtT5Q8*a4E zpgESxy$4=sn@dAkzElvWUvzC$@KiTMkAGa_4M&(6jHzb6`)sMuTBd5>6XLl4JhL_fjTNtGxG)U8loqYJt-h8u5YUKN9 z^^E)F!sXiMPo@R36Vpa$kLKz_z)NZ$n<89;<$(PQFwPL{Zjp~BhR+nxNrnKVh<|h= zKWq|{8crJpEyexnIDG zS%1d-c~noPh#O^v>b%1yhTFf%_sL>ezz+c&BP zzJj6TrT`Ijj5%GsCC?F~Ag>%q7T(?dU<&ru(?bT!1a9$wu}bI;M;!%srKUFBMoEss zyb}2PSzbn+45o@l-=^Ih5a@+ss~@~to_eM7ZbuT!;|?23Uw!By)`TW}^||_&GjE$* z5F=nu`lHG(Ze{I;$8q57)_vIsVk|zFi685}jJcOUH)^SuRI}*_+s$;4w&a{~nz1pV z7`;U$MQ4x7j%(xEre_MObiEHpA-us3DWdH?-OaO|_hgV|ZhWg4JHKfgd`kFA3zt{t zwUu8)(3tqcN|#OuOM8E19)`$`%TkwTlUeuR13`xRM@3*5KC0*lmrs$a>E<5qG@(Tu zUlJx)u$NT;2iUlKXVk%A3x^+4izwy=K<3E{5ewb5`zaQ(yS4ij+ux z>a5m<>xauqqnwDLTPIHbU$!mBf8?)gCqqL0OvX^TNrCL_2GCh7jm&BXNoB z_zbiCjQE11_J0oumXSB)#bVRVW#j+Ua8^o+Gr$>NL4)7FIv75*%Z$M#F#GNw2%eMT zH|<`MrCEeuUWTx4eA74KY!5OTy5WYIe_``4yTK-8JGQAQ(IN5{B3k3xZ7NP=P;XuH zI_JK?;_2SouCtd~q||lb0o;$Q$vUqvEHK1v5KlW{>bJUy_I`5W3dGEqR&(j|O&ZA7 z+Wxaucwr-8+zIiER0jYFk^2QSg7X$$%ns)Q_;(o+LxMOQxT_%Iym@CrRB%O45FMDK zPC!fFw<=>Cia}qJz-SxuFqj3J2STeXv|uNCnAP})Cr<|@Fyjwm(!`rTzVdsfhM8^+ z)t|JMCA3DKP$XnE*%`c37WZifSvR~|$#+(Mo;QIx?#Rrg%74Lj4m5b}UUslW0cSNx=`A$-^@ z$Tt!$HM1m$T-35o>pf!i2XTVaE8t!!W5S+-R&69m#)NUK zQdSr#oH_-wh`;~@Z;y6L*uN>U@CjzM`G#EAhPsiiYPdK~@(;_5^5&?=bb@NJ$Dqf9^P4!0DaMn&*Ih=PeynZ$~b>Tx-4L1D;r$Lrsg$NDY1D5Q4kVQC96iSleDhcP_LrRbc% ziIO@q&_Ue%CFmNs<2eQK-iYL?On2o|k8sIFE1=zyvlTb*u3=LwDllQ3Dr&Nd-FwCB zW(UJJw7|K;lyAXH3P>1wEeKH!*fcY?O$4J zu8{`6+hu^G6xUv(4WxvvRT~Gco?~>#F|aDl)x2#j?2nk_ z4GCgR+z+uNiC=H*3nmIwke{MVQ`9ooY~O7_#_#$ulnD9K$nEoXfq9qTE^Ll1)fFR77BEbweKh01AzGM)fiom@PXdp7K26cpHEecJO{}HR%^=JaN^l%b$i&6JNz-<>bXs z|4^+oz)_5fJK2aDhW-PdqEMCC%=>(K+TfIDl@-AaJD#ngWpovAE+Hk-F7rIDf*i?x z89ra+;pb~dNzvs+2t*wbRBlp{Hw_DRQFXIeNGYB&a((c{Fq=|t9hQnw zo*YMKYWH_2jcj+YN-Fi8ha#U3;fnJ_v0|Zmu~H1{vv4T`sJg+4w$6BD&)Hc#}oFO84VPEw6# zuz}S%BKK*U)o&HRwj$reW{rCWj;p1y2zS_%Ko4;WxDSagQ2is)ZmL+0K{;JEpAfM5 zY%GqH|2cs_7wATZ($K~WTP5TaH&8p{)5QQ*oysdp&oR<6R28banc0kH#8M+?#G808 zzmE=-K3voHOFxdR7rroHdc;u6cj8HS59n*#lpC1MlQg3unK3=dob3Oo2!2YaRiB0H zeI<~@7uMO&dwq(j>hIUql$-b`B@^9v4VQ7aBQvEA3zeCEO_;3sEqVkavoiSYkl|DP z*hvR9{Owvol&W~KdvJb)nAo0{ARhbH+i$Sw4_Y}^CgFFHn&Mi*QS6noHY1Fq-@zVK z{9Bpyn%M?1 z4_$cq&g4fjk_U`#B%Loki=Mo>ZP0dW$W;Zah7fnq*4bsl#%r`?eIL!=Qx~>3Ds+Jy>J)sdIT1_EUAIHyCi^=h>+@wm7Un#=Y*1R0zb$ois1JW?+bOa`7~ zFEYFx$BR_Oo~1kSs&GiwL*?zn@F)Y+$)0+r1-=_pf@+8;q>>8d5uAn)rLNd$(5Y&B zJy0+Un{pGwPTc?dX&;wkJIy)Rwlu=$IG~sA zyhe#Au->?%wF^GDK0|YwW>&C{7?Y(|euS}zr*Mu}7Vb_MWK{CfCNReZ#lN=wtRbq* zi$#RH5Ou0Sbe=WNq}Y;cx$`e__J|nGbw|1hc9cz6MU=^m1~p;S`*RFqKRLE81b&#j ziikFM18@&5u5>bB8KRUq)@jvAG1x>mK}vzJJus{ zuf_3pkes^ZBh#Hj9yJ)X5VG6{==AnjfByDpa=7*}G?%BloJ}DUMUie3?R(Wx@!^K- zd3v4{h(_9@bS%uN^Sw_Q=j8%nhbWb-M+tY)>w5ioJ+YEa#J1tv&#Z(^G#4qW#i7sw zhyI4Lb98mL0ljWutH`coXeC&YCv2ZqNvkp+=6rR*3Qhjp43-~51eEh_QyS@ zO|gJrsBIgisxbG-vVkbw`%u9+P%TjTcrT`~F;|m~XVTwq%|L6u^altmb&awT=7Yx7 zPr6FW#N^lO;M7 z@X)A@16N6sV|q+~Sn@ac-ZY}brV5Z14<5!~g(?&JCq)Z9ZVcPAvLX~eZDcD_#B?Z1 zvVkd)8&~LbQ^9(q2VKGj;m&F2SE)To>l{pX&P5?iQFB&J%iwsh^qO_D1I!F#eG^3z z+9Z2mwFd(YhGbKFD?zBivp&m0+28{Dx*d_^wh4lWl72Pn{4<-`3v10RF{cufR((16 z%H%(_eVOxx)FDP}@JDJEqqAz}hoXqf_aS|aJo>jd&aj0PRB4lUExz0?Ipeh?M2zcN zhOX&-kt=xA-H-g?Xt*)mDSCBYCBx`pNu$EEjczOhCRN7+G z$~d7s+}zo|r%Nxql$+bre7EnG2EO6Qhv7zVG`rH^TA%=RpodUj0UyYS&+7f=m7HIc7gXb}Wt_vxFDG>2XbM*!nq zW0V}n_;6#7)_wBB5~>i-Gj*2+(k24%5xy#nEL>P&&27Wm<=qdO{J#j~HZBoGO0ctc zvnr&%TVlfD!&rU}Fj9q|Gt7wIQ$q(x-05HpxpJcTsso!V3yiykR3VHBYe6JysL_qi zEnA(OM6paP`23Ncy|HvIsF7oMIGX6wZm!abae}3k(9eBpN1=;%ReBroCLWem0Nmtw ztqj)gL=h9lYZ>q~@aTOOj(cQJ_;RXeiQ)N?+MCu7|M@ZJ{R@wvfM?b4S!e!k;gc;R zfIR`-N7yBpD`D1yt@}5}9{d0$I~?x%c8?L6;68nux@+C37*LKgoC`JN}>zRpGR(^^f#c&Y#Yer`)E=U_9sN59fp_` z%@6IhOcl52P6cF%cH!C4BITWnwU19bCHz_|g>(g0m{6xBN#~83J~Ot6&c8#Kh9;jicK3_Se!-*ne8ERtkb) z4_Tj*V=;`)vN6rVJZwNb5V=C2U@dpgc4+E19L}(VUnx2AfwQ8bVz&ScCrYwj9qQvI zBJ>k}Alyh)mZ&*4-Jt@9;G;D}+oaDAN_kmPmBfpzrLddAH%QG!C59an_DC)xK4m>_oA63sk(Vh(+nM1A*!Iq zpd{RvYBS8=xRP!(SgzywP>ClI9~Knqgw{x#D<+!G@~k{#Of;<(bdK`Q^!zR*ZlH!& zqMgCMfk4ERm&P*!9{#)((YcBmlH2^O@lG!(HCA(yaQT*py-ec1gg#@l-EctQ5Tspp zWn(dWal5*wvRjyRBv|)M(Qe{G)!afXpIs*RZUBAejVY}|nC~!dZWS&V*0*co@e9m? zrf^WF1~!nk!M-D?9Bx`rUxHq>#6yTuoN6TKn|`?G9$8eqffsn3HiGW*4lhypR>wtb z`Lrh19lrXDbaK7N?5tOuA8|8;AnUd|gm9##0G`eAfTV#QQ-Pg&dm{U!=pur>CqIo8 zB|@($E&{RW``JV)AtP1m`C5YMmw~ceMh?xO35hbbD3IE7?Bx?#M@%x&<8oq3WZ4JH z;j)~+wh*xtx1{Siu2jE4+8onZ=SeRf|6ulKe#O#=5>I!KAspRIivbdukJx0*6~n}Q zmG<;Gd9WFy2s%QUM;gg0EUG4oE&=Xo=x@d?snfXmB2)EBZIPn^>|49COT84DV=~kS z&H56y=jFrrlj>l`=*I2vR`HuUm02rXkGqj4`ivLCw?*%o?Q+j-YU7Qlpw9UAj}xMGN+F%_I+#4^!i)4&O>gVThT*nr|;$v z9Ew`p^MHkB!!~bviTIzBlP2!JQu7g?sJg^Bd2 z`-}IaT_;>g9x)VS#xZEDp8mE_k`@=nL86#1H)wejj74%&iGSt=$-NV1(nZI48-8*=s5S21BcK6w2_5*p$%;Ej4K4%1y! zMNBKOyKz=0;42ND_3Gnm?#nFg8~hs3D_;wbfUE>^)(icmo*P`yol#Q++#Q^8tdE5G zQ|NiyP~M#IHzoyjZet$s zYjz5fjPlNYv<>pOX$Is1@|Tf`$;qJ}D8LOMzp8+8Q2&X_uBERxN5(&67uCbBxw#$` zqc;k`D-#oV*T2ulbSZ&(BYeSzuWycVgKt^P2tDe zxE$bDTX5#YHzg2YVmIsGiEqT>?I-5^_wna9=i%4>`q${)fAj0tn}CsAda`#r+5hv` zf9pfdEYF~2AzS*-Ed*zq?iTN%siw2s7$+_X9S5H#>`*oAh#MbD2mo1Ys zBBLEB24xBdR`yr3;8$ipXJ=swtK8tw;AK@CIN#XFi_Xd|4n_FOaM{gH4?B2IKeSHl;KVyf!9C7aXb{dRfPJ5H1rwm}{*b^w) z_R8=llY$#NK=6!ykw4ehAV4;XS4e0H*L)6ek)0tbR8FvX9^gn-Lg; z#E%#aAo$3B2+AP-BW9;+@=NS?+0?)2^}?xl-rM#4muTko0_xuq^mzBIJ7~iGsaEZo z-K*~I{of`3M}O$~X7M*>#~18B?;iXmYH`mih&lcQ_%${({hl;3edhkH8)w4!2HfQa z`I^3~{mg6rz`fgHIo!SD-Fkz6OIy5h=bF@?duPXA)CZf~{plUB&A$3I@P}u32kyyR zeR@6L^)|UMvxaK=AwJkPdja?1|ND-A*R77`-}f4(@dLQqY5E+V{3`clX67y5?5F?4 z|8=Wn>xX~ByME%ob!%kf-?=+(v&+9!O&d7U+c`S%RJZ)&pE>d2XSMl?K6(--__a*c zxf|?D-s;@o2!e&F@dJPO8TFw*`kUC`@O}BN&y2k2J%W#G?q#1pXuo_b2`50^_^XTE z(rXkj#|TAolB>&&!S0ZUQ)$b58Z}42QQHTse)?BXU*m= z6e-NNfYv%%Nf)9Hkh>KaI+2IDCwF8ByEm zz0qmGiS>N}Xp?dz&F0J>WI;mo=baMut>)S~7f%ukJ9WppNL{R#c9%#xC03!yR*Nv2 zQ37MMD2#;!xL;z{iFWFPsp)GLsg*bE0u>tA=+ioh)Sx;n>?uX~#+#~Rswp_#wc<4_ zjW>Kd1u?SmUOz60B-SJEkxLy_N2KCWfxtCB+3Q(dq~f?)NHnWl_Al|smIbx*pr?E#cIVl&Dy+`46jVjo%(t>oB&oDgCrDc=(2?xeC z{e+jtlH(FMvu6Gn4KD9j-U@mj({=?aqJ>?)g_~YSeF&8$770 zRe?Q6PF^`NC8oS#gy2~WtlU2L(>vb5fSmN>!>37a z%`TA-SbrT^g+-=`dLlvd&6PL8$W(%xz$u6I#d3X>Cc&^fWUYn;s zAyek)b+ziPcWkR3Ua|1Q4f=9j|KStnNE8`BFA0(nRSI7|4-Caex# z=}moTuFsS5GAaw^*4|Y~28RnztBOCr{YR>qGUysK7oLB$ zLBodqtYvp5E2Tl@Hj`d)92{d)J4(^`ivsDKZ9&S4QxTaAmvlEor$YQeg8h%03`7c_ zf#e%S@LtM2g==WA_A~02Q89;}y5Y}Ap}5wT47^~3)lb&G#j)27 z;DAE?arCPh&u6kF6?X_3%j1F9pokg_V8KXO4pfMC@+(p7s5)uymc+}>$JBnYyyQI2NuoQ4LQi@> zU-0;pBnQ3gheg4xsELF9co0tY-ynN}Gx6$VM~~|#pZu}_MWOB~N@b|chYDM)RghCf z*V%lnz&pf$5FwfgqR$Npf6mBRSoV1}hSdYw3iKxEC++IkzsTesc+iyvuJRBIbU(D| zc0#$XkfAg#?ik{1i5M3*UH{6s>)s|-lY#7}HKB@Il6ZQQO}cLvA=YXK5ZAFBSskc3 zwhF4e5ann9h_H_yvUTD@B8VFH=4+%S{#d*2GT4)+79&rb;sxq&L;!sGvEfHZXG;Nu z#*fp419GOw5h_ACqerK2@eW?2yPAo?7ZvUy+Hw{?{B;gcRWHPZRyZqXjPD9Da-X2e z(NM1&qB&##tLL$0I4f0vjb1%YOCa8`rJ-M7l=^m8hvS9Ot`u4>H2L89XQ7jDfeS8U zfH5CvqABxe2)(w|HRU6gEU**aEbZ?`A48!#`B^W24l8bR6kHJB&<2jGJ{f2*!W|@? zk4b#fRn(77GYD6cLUk)7aai#I`xW&LE8bW!xjFm}vRgUk{V=ZJs08^{X9MXX+?_ z)<%(OsJ+mZs2pOFQ%E;5cq6WCq@Z0gx04G|dqavNG;rDo1D1r^#i>1s9T2eUN`edF zo}H2q)tDpE%o5<;02V!xMe;t_7Iq39gIuZ^eOAy-cb~X@m3A0sN z|IAOy5&H~NtshCE8a4T`L{yEcNP!Zj8$1%6?E^Q--0hz#c~oq21ec zeFU?{{x*BEc2CFw(TvG5tN?mqIx(Ey$fSD9>W8(-La48f!PLW<4F|^|De+ZW{|yIA zki$Q4M_2szJj|?EEFfd9YJHMWQ_}$pmTGU+N8zAs#V=0t|9j;|ps$0s@|HTD6)O!1 zTU@--{CJ5{;J|4vJKCmrD5NN%#mOeG?u0#_kWKo2?3WVQ=zj?ZWLlwKNpN_E}->Y?#76qQhAs@c40XI7Ok5U4_$wo zQXWr}pJE?mRJKOZw}T_zGF3wiBNYtk0iBq{KcGeAxC|bMm#RMgRo)`KDz+{{vOHIO zzb)&F+fkG*(K+GkC+d*fGhcQDh#PxNf?|?Q$E7Dynk&2Nr)c#0cVK3yt~@fZ&#!k3 z{=CnmNh*+rZwpny&SfcM?KqQ{_{qp)D~)H1D>v!$YuF-%DIk;kaffU{f}Vt3UE)Qt zpMZcUVup*K?d|UbB9B~FaREWo?m~!<1(rs(N}xx)MW0y+mn1Dc)HE8feo>{-M?|;P z`PTSySd}#B2SYHgkQH@y>V|)GoCvefIt?}`?`BW&T`?LSxqTKh&z=QE^(t3Z_i#Ge zvi7C&__*4SXhcKY0Rvr#Bo%5Z6kHk9^Crvg-{ydFTa~5K9$Y88bhYI{M9^h<-4)TV z+uQ|xr%DT~=#w{BnAN3$^-o0%QPvM!OK|-;h5Cw#X*+&^Zor2SSJXvKo0YN9HnZ%! zHNA@058y-{_UeCPy-v}*J`t3iH|@s2Vv9uf$zGSt8uZR5!`|eFqTSOYt#})i4hWac z7n_ydn32~m8!k2zgFSk8#B(OVjWX|;E9+h~9_;>M+r<%iNIk26V~P>C5J-CBj@B&= zVt-J66P1q=t#wLY#6WRrzROOR2x*O)&_#X3#s=nuNs`Bk4jY_M5vww^rv0wVi{{fp z%w06(Bt&1705GOfJc`gD9O~%;LSmunyfg>fF7k1eXmSSQn>As^q48+}Ou`Jx+@xj@ zP)Me&K0G#nSln!w*-QB(Wo;vW=r(!xX&r{w?{RdcTixZ6<@U=R;`bbguD`wWc$gG) zs}*$S)F_!_P!$*XwtdD(&{7DJn z#aikEpzY-p8mV;xMTAIb16#aU*>_G00#M-Mv^hI{M3f$?q1BIEONc*+VdA<3?ZWm$ z7&@e#T#9v&f12k#{+e|`Kgb2tv6=?V8>u8tN5k&xCj6rj?AfLuHoK~9OXds+Sv`R7 zwj&Hc`fD2)6LYv2a92??i^Yhj#Ic+u;2o5CPr7BX{qD{19-cl6b?Cq*3~Jzf^YXWh z*-n+fFaKaEWysF-Kb+>yuSF%WrHaGm!(1mpYSX0|^B*!0dO#!AX;+=b>M*bdwA6!X zjebZSx=%tc8jeAx*gQBIX8yg;@mX=i#VrVNc&@qi)t*3kCM&W(8>h+ZV3BhTNbCTUlR4?WCv-n&7c0F&Tl@eH+Xb#SeDe zYm1BM^Psld11O}G;mrAB{!nM#;*6IXGu>u?QwoXMDFh2EPM!^8=(+2ZxresVw5!kl z55n$gM-(mG5^&jet+H*~wr$(CZQHhO+qP}HcRD#qU!0^b=Mzkg@%=9CF!nW0@s>4P zDk5u9A~ZZ{y}p>@%bbR}?7_r9_E7C!3NyUU@pERn5$viwx~FG*i$}bX97h!|zz{+u zbLi&@`OW0L$Gfj$I#%x?CIzC0VWHC=*9GZPWZO0pX9Ax8f*)I#_NKp z3a)Y(%tQU0_w~$2KiyYoCc)S(O?~M8VEDE^yn-aC?U#`?T|ZB zx)R+NZ|r|2#p|0^Hf3>0H)e$7v{ZLcGF>_H0_)BCpCW0WCi|mDreOb3emL-9Tob_8 zi)I_~!WHr}KJXR>DJ-;S6|lUbab8Ctc>Pe*Ad44wpA2B5(ylvp(r?BrX8o z@UOS*l{WQD(+-Mh%FEJo9AeOX%(hp$nY|3;dDL+Jg>7W}z>N_LBVg*%R$8qelUo6b zy+fYOl_mk?W$q7XvqINt+^)sKAfjs>GU7f(SrXijL7g-3n2^+r((OaAJS)*UVx`j! zvNWJ|*_NB=TFD|2hb3o2964gU0GJKCfJsOLsUznGxr=HTW!FJF$Qe?<&p#ymPSPT+ zw&oJDM3c$Kjjh?Taea<{{PK=m2vP$TwkbSIifiN{@UIcL`Xu4QjH&P((?wZmDnCeE z-H?5t1qm5ZI@B2HUcPNSiy}Rmv$0~D&bnNCtb^FMhoa9SexNR$oQ|+e=YLPF-7Ol) zBnDc4^n%G;5yF+y&x%JsD*aZweQq=8?B6DoGAj1fkWzH%m`L~JqWAv-<5&*c_c=<0 zu~Fzm*eqwvmLz(rp*aw69v@I9Ovur+Ayxd?T_!o`v$~El^ePfyByX(YKqh*s zDydKM&s%FJ@z%Lw%-%UWDLjb<;1rn$z9r}OE!O7>z0oT#5~%2#BrO7?P+ERJ&sv)a zIzDd`_4XWHz z_#5qdo-s+pq@>D=&8oSjj+>VS4buPD7FJxm^<_d;Uu=eIM#cX)$xIs- zhrVqj(?8O6%UErGRB)V=T;C66tL#XkVK9Hh_x2Dv4e4(Y@CuY$3-J(>?LYG4GnojD;rmLdB~iZ1hmPS0=wr z#jh%i5WA!3DoGpNoBJIew&Pl^z$iSsd5SSbFdKG}tGYNt6iO9Gp;0nM%Gm?49YfiU zg!{^~Ar{wLjf-3-mDfcFP^LKZZ%Rrs>ve=}98(WD8%0WCSdaEWW@g6;keL^8w{=Za z>c3l<`2yjkY_NGp#$i1T2-tL^em~Uvj=bgm_xDd{#$sb9m08rhKw^0dqhw$zk|&&T zt5)LqGijmSW*j^P-?zieSe{CIdi^ZQVbpciKlHj56>d+m91NvxHr}aFin}M3v0=aV z#!*n6k%zoSaW8SNo0xBi?16PdhStWQHh4L~NCbFgSn9JPk!*LKx_`e&B0;6t< z0MsNz?qvtx1@~y)EUm%aT+_=JV8Pu%{1D9HC=`Qqj-l5KkyG+gfU)Y?iSDqqc2&;@ zC#3}DPw2z)YHXT=C`jR6`0TpEsz|U7-?8wvOq+^LeifUk!s?RSGf1vN#7Xapt2x0| z>#OL)uR!hpxeh< zDQD+z=B&!%&$%z*=m5R*KWGgXXw!lg-(APq;OmmNN#3L51z{1&Z=|P!RSzh& z17LY5(e72P(9WfW=4JnF2aefhZZ&B7CEzR1Ma= zPz+1sA6PiZb{s+B4MI`7!xp&@62A6A0hP}KU=WQ9K1QZOpd~W=WXjz3+jb| zgq(4SSR^bOUasauipEdlU5sgx__C^2BFB&>PKFusk zwG;pgn?8=1<;e{PLWV#3EkUiMda$pZ7{MoxLn6BonzsA613<$o^wdNrGBkFjSykGH zVK`nA7OZ`PYGwR}Bwj+DeR_@($9hGOc~s&~b%YM}#XFW80J9W6jx zBF;a#N~7#Y=dM%dDp#!*7zzpE?VeiYzy@BoQI}NS$2%E%k>dN_9$feh;O1IHn0Z+C zeERmjB;hScsygO}7K+Z^BRjM6)i6uybRq(*cXBmv?~eirDfaeq>F7GZ?7jAp7EMiG z*Be@heR~FOW2ZeZ5HFI-zw5-d@$nQ`|$r;L@hx54W?0}2jkT_^;5HCL( zG^E)yxYb7&X1;XrEidJO7bT7*PZ1YSa-4XwZ3}q}ELbshWgy;Xrf^d_h{3PPm@xNd z{K5#bP%ZJPVlncVqHwb)n9lEjlks)~jZwoTI}Z}RHH@d0MlU(5MHF%jE|v%@v3o~& z#5Zx>!X36S_e@!~+wn z^kfE7>mbZ_;d#2k89b2LF2*qUJc`CPC_HH?1$)~@(2@c$B?!!0y9BP!w%M7br;~@F zF7FPHJm8hEc|O-mJ%O7X`{~Q~THF(@IhzJV$@35T_}TyYQQv644Oo2>0;McB8QEY2 zEVgALwAoX1Ktu*RB7AD0O0vVsUT?Dr=#p_(%)=6O7E8)^h{y8UESfglAS(eaQBAXL zB#G!9)d?}uIf0Tt#rH7^r$JxSRK0*sEtmu1;rCYSLZP9f2D6U z+ZhTCwFZ@}ijf`1vG!!XPD++FX3gEQC036HqS_JZTZqKwe=yi7>lef|HxT!m!&nIW z0&rQ({;~tcC5P^BwS_XEs)SfuDejG#L>VE|5CXiqqp2ilvkT=rXcC)qd1B zB_Ys!ZG*#K`!46}{-gUb>3eK4_ugYtvK?ca?2W9n%7=A|SCcgTLQ^-mS!>UMoM&XZ zbxvsDin|FVLA}sFam1aB$xC7+))c5$JxfwQHsGmFBP7&niJxrLS1&bsdOBld zj`;jB|Jgu`F`#0B3Whz8MBA}@g4ems94;_NEyXVT(QMi zorDkUv4P7pJv=g352YClzL>cFcxg0ZPREXR*=lira~9Aa>*0k>`tLO9UnuNCKe67C zaVlgx!kOm*#=Mi<)Gs$OM$dWNslT>E;P9V#5mQo1R zSS(i73ha1)S6!Ghs8rG0e+~hfh_eRKTOHcYI7!hm zJ4-2u8MqA`=Z!eU~$AhTEMydr!6LTb{YCz79V2xdaJ2n2PzC`iDS@ zQ2El;B|STu;`GD{H;n%V-vE0go^0R2mJu?mH zt`R=QH8qpBl$xQil~h$(7~U7^8c+ z)&%jp(A9;`Wx=yrfiGW*3|by)RJZ0zh6;8}D2Bc7fvV(XmGh#V!os=(UGKxd}lIy@S%PfyPA!6LaDTbGpv@I*wcShOxLnNd5cxg79G~U}VGH1qm7Iks2V62!Hi$Zalg+`x zrT#UQzQ2}w9##R8!WK+#Z+}G~U}Jna93vGETXSc+00*PMrO=78Y z(>AtZ!7T$+wCRE6a2-yXnRZPFo?~k=E>LCsR*Pxf4TGv{1|Gci{CltFM+bKo{}*ZP z;iiWqA9`WJXcHJdpchOA=%@6QOlqj>nVx5iN|ZM^Z+a(Wo#6~9GhM2%U7V42M23M7rqdnMg*-8hPTWBj=OedSR;o7HCWBJOqiRJ-%!cV&c@o>( z6Mp~9+0&e7Grdpn{fMnb%qDzd$%d+19IxJFi~sw zmEd=y?!&a8B%eG1{2vc!G+BP3(}EJbj+@X0ez)1;F69Z7+6hV>oaK3|GOTon0^lU) z7PLV!r5{>50cdjw!YCmqhy7a{_ZRJl)JFg#HsLf*Wbu}`;beG*4i!%eCo4 z2}u%kfn#3|0Iyk}s9>uT=-v(x&rIJo`SUJVGYR8foWrwz$Ep=i^`>-0Zc?2@YUfOH8n{5&sV7MTZy_PVn?@SlV@ z52)7lTxOoVOpz-3)2NpTOj?@NRps)rNMt9EK zdAI=dkeAS+cA~r(#Z$QVe&HZiyYrVo4xJUTYFLiozWxA zjB!&yVT0c>G`CefX}x41cKQ1Go1Vh~V{kX5|GQMHN5)D!8iOSAkJ2HK~Ng5S$nHNW`)-?HxT zc>|yWykf!N)x?=Qeu7kq#qV%h`<@6(F{%AAegxt^)+?tvI1%G|@tEWb z^x08wxJbYWK3oz|Hu`>y->g#y<S3`fl12FnO0{HUJ#7TH?zkdvwBZHz{)T~fMo_$qUy z)ZGO22wD+=3FNKj$XF->+d%)l8ZXP=3D&|A&``gNCUN&vxgx6x(|bqngfpPaaJSH? z5i==(QcJyR&#QR%tR!;9+P8@1qsuv6^CAIDHQOceK%8=gaZeX)$cJ=9jr}nn6;66U zOF;(aktneDf)?FWy<3uxrBI0jpQ8j2*&m~lS8927Mu^0CIIkrBSVtnWp1tteb+k`| zjnCwt9!gC5FLW1cABQx{ZC}!f!NPDC6g~(9Th+SdYRkNDv=fIS5>Wku z<<}V}yew}bdfO-2wA-!`pf<8vS)OfeVhMV`v6m5m^-@}8rs7E)J+7@azr$`PxYOBz%Ot^@=<(>R( z(b;#A=fY9vdN&|#{KPD#)}KU**Fgk%{e{Lpt@csiUM680L;y}~lE!e+Ga<$&7B7d@ z$d`6;&}McjI@xt04S#si@KzC9MFv)2;f<=NdARjnU-9pENocLx!JULEIAywko_{1`<23%OsB$ARmkCjeI}`{Z++KO*p;3e~v7?iP^GEEFo5jWfF2Ub^Sg74efUP&v%RZmAV8 z$5?-=^VF_7CL|<{32?f6+FEVKw3=V{t8gFPCl+kEZ7E#9O1@s=8Il=Se&8MVMka`! zlR!mPiAvpJn}C8ogPu?%mVgu?iQTE!!;6qkDj7S(RNEYxBg$>({y~1KkO-`X9wN;2 zi86QqNWu9Q;-Kvtc*ReZLmsFns0Zf)4NIb1*g4s}S$J7W@T&N{i$;evX%_>5tA3+l zH*D=`{2E9uv82WcV@uW12#lnf{a!xRFZD~YaVpR4GMiP~_0&&>G z(40U^gly*EE0^LSjDJ))L^igU(jLr>(UX^^mv5syk* zkP>h8nvP$a+1UM*K%o>Dcqp!K>lagN4ZjRvv}=%+CqLs0<9l`3A>5cUQo1apMIu(G z02jW88$8q@*NrSFv4A52IC+sfXg(#J2l2Z7sA2VvTp+ZnBQrwVj1a#b}+$df0SUqFJ@(HWh?V^ z=G*905`pr=`$w{6XeiyA6B{9+7>+H6_L!++$|%gzz52>!lPAiHr$w5bGyX{%q&p`8 zxL1Rf>mrr$E9&M4&xHdQVcKFCz(cMu_%$;MU;9rU*TSYf5Th(J20|9S3a`q2UR@TL z*HFHHir%5DyOpTXUY(4aQ82EB%N#PV1-Zc&1Wiup#Qz^i#ShZq_A&kGmu<$t< zVPxC8^Rcp27qj3?^v>$U+@+HG&}gd2eB<~Kn-LrJH1^=O!V6Tq#$n%c@oPwlw;_$Q zVPtMt0f}Z52sj=#)nj<;Dy#FmcKsBTD$PLw;*8kAOeQJR?OpFafg1k3(;ODnJ#AdT zD_q88k=*D7p{yMBJD7pqwMZ9O-&-ZG^}|@2oS^@*W@5mFi8y*Ybi|-8Pr2{)FQk5s2G$< z#gg+#vNydc#%W04-e$~#qVOlB8HZvkainl(UKpnaY*YbmgGL)6CH+7C;}HusQrSiL zy?>vJ!Vk3YnQ1j6ogptp@0Mn)Y?jPb991FHNS!PLWJ$0n`8g^ch=b`54cl?vHR_Y! zV@kb7+#VZsmxqP+>bpGt`YkGsav&lu294k{o#@Xncs`h4o_0ESR7C2qI^RgCx-aBA zH524d$l?j1lU~s~1<7nC{|zM~am?JbFKhE(ktGn9>TW6sR^1%(n=FuSMd)K0E1H(b zK)G2LyX&m`hXHjs#Y~aCr!P+?7t8`?k%%{*W2CK@LJeYSXcyd8}Y27`+iX^DoNKWm#wQt1SEP03guaZSxnE zkTSGxo$xOXj|2mPPV9?S>BB(RQ1(Q63z+-EqE}F)lva!wzoRyoRtP;@$_fUML9F)Co-q+iZkCD&EJbLn z5=(=%r#e{u`tJK4t_kwPuLkY%m?+Gf<7y9A#=?FsO_m zZJU9A`vhFjOctb?a^`kd`?~wLiG^@3VFi)J=5B_b*@1Vb`n(ugk*fHU0iOF8Ij9z> z#nEL=vH|qYH(&+EWa8&l_R3{T+M@5#Li8s0juezKDEno5} zB4TQHP)zVl&qj8jBfLWX0~eh1snqv;2+U^LQ^`BDTvg-aN+Ut+gpts$>mK{EPhDq@5KACU9IW{m_jlw`t&laO59&Tc~kSO zqNU9X$nZ3c>d`n6F>sRKv2JUN&>Cz})L{sU=)^7r6ADt^`v4dc?Ek)T0#lt+t0;&7MkZ%*yUq%I4+Z5KW2WiUp4qPF_mX(EmN5MIeYR0() z%^O9CI951l-G5x@iE3EoF~#$%hPwCVnK6A`qi^LzTA7^=v^w*Bx>l_1GC`I_(~cn!pb@22Pl+f6UNtO zT98cOVyxs%%!|^g`}N{krLM9-toQhUL^h@153T^!AW4eb3UH;B^^O}d!qHwQb)Y85 zY@4|Rmhnp4K;nvO;?XI~Wynpv6jxqSs^EL3Q~Wh$t4m2X(h6o-=-2l-b$LXplEVSF z2yn4idsoKZ{B5-XCCmG*s zj{g8ed5FFWqgfbjKAiFMZ{}IsBNfqBY0el?eE+I=}+ik z%h*U3nEjJ7hZH8TttdEVEJ*N)Lb+NZzGBVNTtME>Lcu(jW=oCLg3r1)6dd`@j@nAZ zJ?=MfSUU>K0qRvDW|{KTYUx-tQNJeeinV2{p%zB zJr^Rgp8@i#tbe~1x!X*C^^f3Pcv}?5 zu2UG%_=p3BB08#1Ti~uD*;HcorR2cD=%3pJaH;XRwdx!Z70#a-kR+=8D%*CkJk|Y~vJzAHB6K=m+?lv}bb*_Zj>!Can^9t3uVtB~pj}(YOjvF|qj>R`S zD;QEL@@I}LzEsNtnzuIKni(J?iR`RqUj}Cs0qDeYi}&Q(HHq5&jPnCBykyhDSFazQ z?5qnCR1^wesCc{B+hU&52PCY|zfD=~*^m{l$$W==5jzLpo#9mgEG$_PClUS5(-CI8 zsX>iG$sq;o=&U^QLl_!`67PlOH(OZ$h^-GsR8d%8@u`}yYTSj+^Lc4y?kYv3<&Gx< z_Too%-fn8CqSDMB?dY+?fZ;W8}p3ytu;*$t;szmCj#kysjGOpQ&WWR;jOb zermZE*7}K{-vE1pj#YnMJiK4&%9OlJ|H+1RDb`3wP6+0qtS%;Tc9U$djeNm%O zclhbDfbF^nVoKOW*^)YelYnb;>&stO;L#EBf9h1X=s54sR4%)X-j50DqRpb159`hb>1ywRBkDeJ3{G%2B z0hk5#N|0wnp?-iB;*;5jEsPo)t99w4BzH@PGhK(j^(0R?Me?nM-!fBbXL?Y$cuT1%t$_da8p1piO-6N;MLTAOt20P17Hl($+KMbsa|DyeI!K zJ*2Wng)ds7dJJ>DHcTIb?tsi5eo%Dd+WH9c-B#fi9q@8=I^K2^AC~=hM^?P zwAXVw{^;?GtF)Yi>^UxGfPDVGF-s=GvP~XmOcsu9jGjRiq;4~nx;};ev?Yg#nc#nT ztSZ^J3hxQD>9x5y;9}31H_RIh-OL`?CZ>}dD}Mtnkrkh_8B$E;rJI%yLS8F8PtBLd(Y zzR9LCkV3j84r9%I#5O|~(DRrFbePzUjh#WY*b6L{fBdP{_qJ8wQF&}T*SV3=&Mbj? z`0_{cK!O#SjAkq?TH={2M`a~LM@dN-OLHK;jf*gPkgyB11$lpXuKH94)++&uY^Mzg z#^{-~-J6w>o@yv8or*ibl!Fu*jGUKhCGa?>^2_#iT%~W0 zUg-wPAmz+|!{W!^LsbyfxZ)jFgg&>5*Nl`pFXG#88Y|GJUP9OOE(v?9SN6sCbk^cH z(uHJ9#VxPVKt$V#YedL_tv(OrJ<3;y+FURaiJQ4~6yocnR=i(Itc%Rz>Cvf+IbgFF zzE}-?rLi}dhGZZOq$R~~-{O=@4FW>q88=MZXVa+Yx0oyHUH+|c>9n#8ObR?eoYlgR zV9U1zSXyNZjtnEBmz8maT6`?sm_&^w8rAPGUSq2i?dmd_k6Jdh>05cTAyIB4LXr3z zH)y+W7KI-Q8AN}nnC$r>kZg_@Qm#@F@!9N90*ECTQ43$%9JVHdvy$UjwMvcdyhlkh zXUB}!3|wYE)i>H08Gf$j4kmHFLL*O+4eloftk$2XDWT(zv|-m78!SPz-m@VOb-{j_ z_{nVUyw-KHTHPKJHku;?ns4l@YF@N>0RukqS@bDQYXZ9KCyrF+2P1|~Y^|B%OMz5v zE)X_+wfcN-?CqoQS+GC4^vH`l%7324mf-w10H|zrvm`2Lca>o#t2baTyNkCZ-Wu^i zH6Z>jE0dfSVu2-EqDCHO;DU0Nqgyw--iE^_HjP#(XRAQ)&1&}Y<8XZe_QPPHP|K7A zVOCqE&UM`T#zrfR4P%gF^oF@0%k-7U$(tg0$bi=mSqfF*0Y6aUz}z+;30sSRV}bXw z`H*IrK{NBohTnDyvLxEpk2_dHwr(1wyzbs@;=(Vf#cxJbY1Y>k@@ewy8$`@xbY44o z(NzDngI75Wp#!`|>bb~?hN0l=GCF9Dd*(&cG`|rH6Fae=zTx9TE2jp97B! z8W@$KQ@n)uwCdu8*K(JxZHfe;DG55`9ocD#c6v9*Ilu<9uyE94r7geu*EJ7C;rJ#o z95S3^&vZO%Y`kuCBQh0C-3;BCTjpzglPyV6Z^o5Z@4&_R!~mWGHZ}!_tJjQB@Qg$m zhh&mqMmO=74^RfW@tIt2VE9s<)}q2C{SH=Mooi8E@WYS`Q*Qg#H-li(4_DuKZ&H8& zKa?eA5Bi@q%o#Zz`pTm3bTTw%eTh+chaKkdn;VWdAaZJ~^czgf4&g)A7BXZT$~RO2 zm#;9RBM=5Apq2aOI~FqG97j-{YD&`b`^ISdW!8Pu0{$pBsHzno5yp7b1$W_5{&N72JXQtaZQjhPp)LMPgYU2pLcBaUeVbN9|+N?w3E(YrcXAJK= z+`zLg?Eso7hG>{5bEff>XMYB1MtNLqKQ$mfP)b$Sl^FfLtj)eF}`VOTNP zgEm&+WJae7R8IoRMa1);XC5kbl*_)IQTSZQ?GQK&0g2w40(GNsf9!w&cjqY-v)}-S zjA2r}r0;nb=5NFp{7~^x&Q~f}M9)UH8(19`YFUKwyvI=4uSM)HUpVzAPi1hpT~M+y zb|jBw*Nh9-@fXZlpbU5J?*(c60o`=amdsp?99>uu)Wc<%^r+yfKOPb8)pskdUAIIo zl;Va_mb>Y-6H6+Y`)pAdaMf&f{fi76SzwbMlk2v4|Td@PP$ob2&G_NzkTojra|$09nZDHxKbH7a@?fq(``oST!OH z6A*lvsK73+u^Tss|DJ`U<57l6UyPjAqlchK?YO3{G3=T7W*TCvChiy zwRO|rLk7%ug#pyr?wrsT>~k7ToCka-w>&|x|CIQw<6QKy420U|P3-;}iyCn7x^y|E z+|?rwS>+4+>pKY7TFrB9?PvH`fH?8%8#+uGl3_|*wOM_P#9N|*w%gxPW%CSXJ%9J~D~HE0FALC+B0 z{T%DH*M@63asZDrJ1*47ch%>F!N<_7wiu-T^Z~_=8L|zg^DOcXxM@=g6D>T zy}N_R^btSsb~0^GUK*`Yn=2I;Woix=PK-i5h=N5!-(QfaVOMrH<%U1*gBT?HV+6Tu69H zF9&363)`lwS}f&&2I(wPm!B2dy+~@!N%S6{L@C|^|CRCh?!%HRDPpr7nP5@Q$LIzF zJn2{hXXkPhzxtFBx9m&K41`_iR}vsf{@3QZaKUpVUG?}Z{FL{Ef1h|?ffW`00r}76ZxrzNJB@tg!_(03gv)Ds?HRVvi zcQF_g z4nUKj?{6u5Vje?U5o~%0PK$nTjQNW+u(P|6B#+~V*PbGN@lD6 zvo*I<2r06yRTWTu-LEDdLmvA7ncsblpf0rJ-2cS|jeqp0JQrUGosk`&kwIhY%8KPm zc8EoJ=DkV(&@C8AI(;x|`l%QSSQ~IdWmyl0fc$!sJjJyHCr$N!Bjscply{z;{d}-E zZ)i}7iCLb7vezF!y6qwO>~i{)W!=kSQ~_8qz~nd$N_xX$m8zLzn4+OJcVT&A>~pZPH!R zKy#c*rAolNz^ISnK=VB#A^}=#Qo#B9KdGr6#e7-79-LFvwrX2) z_s?Q4v`xqBoz(g73w3d|^w^iYA?p~|)JrOzP7EE7BiD$RLlj)vxdl3Zx;>3VU~{JP zW(>WP_6!^*DG-~TJm#aVIO~xZ3)nQ)+M|hFG!G8VwP*mG#ArlZ4L+kN@190&zLM{t z;QfW|ODM=hGt^R0{5HBXj)dk$3;-5q2yiTmIuS(~3_j6iZc?-m<{tS38KK#vcaZF- ztKj0>Wi(`hnXU=An$?t9t{LmDi#%AN%4>G5hIES3_P8*4#!Gc?6jLC6duNx`P#w6P z=PYmFrNE6}D}lkKPQTUnNI0rmz5q?DyHwLPUt-8X5ZTg!4)Y5Qx}UMt0F#Rr^N?MH zONd26mVm)7wWg$lC&@e_CJoqjiad5Mw;(h-MK6zgQp)I0mJ9b#aj&wVqXbv~u@Ik% z$oW(J*ONQM7D~0?D1x@O)C#HpHYKsio z-mQxq7$@`T29c{-dqIj8ni`ALLRG2e7J*w;`767zHz1uIiTUvNHa}0cn1B-T=khmm zK_x#=;!;+VSm}y(ApgKv9uVdrG*r8cQo?6xK4pTx>?V`Y`0tHCaz9)iVHP4Qa~&p} znJvU9t5J%;-bDjpCNg^xqG?RTd%IYn zC9oC#Jhj(>osK&Y1E*tA94FH%Cjav2K0r5yiNJN;CqF-tOs@YFqmu4AN~yfiLEk2bD9 zynKp7y;We&%vgeHXHEgyJ<#l}Eun>6DjX<+X`9i^<(6L;YXm2y zTGvcS&|p$$4t{?~$t+hl0@-98sxc#zc)1Pgf>1j^Mm62zXDpAJSs9`3_}ZUgw3E7IR6;dW;$JY)ikDa@5iYVj3V)k=z7@E~)c#zr5R z|HWS8_+RWb1|~MP|H0N6@mcAa82)GV|I%x$9IR~rS6;*a|I=$R%Am^2J6Wa0#Zro3 z#a`lo3AeH-&i;U4p_u9Z1p>ug!ipfE#2|nr0>vd-{G1>l!V(iWKbC!ew;Ww&vmY}( zcDrZ2b50!`(b6F)I0vu#uyfM5mntSksnSf%h`fX?&s0P;Wp$*I7T;}H>n!z07Se^9|h#{ic2bm2t& zdLa40VF3xn+m-h4cp$?YpdmMpYe@ZP{qO*jlamlXvf$)hL5K+82r&8Zf*t-l4LCUb z^8OUtfIy-j-&G)cIOr&oLbA%sTU%Nn$FV2@MA>(b(16_p=K zxBGkj!r~o(rnCshc&1A2$dg#X0KoNN)(Hc!<_l~x#h(Xi9tT03(o5p*QHd$I4TEsb_VEC z5}(&TmhmC#fnQgBg#F@HV8Px(KYkiq1N*Uad=UTQ~C%)sZjwSk366 z@JUEXNr|9A{CNQNql2Q(>kdtMargIT_e`%pfWNu-aRJDvLF@sBA)|kYUW5X>`vFjZ zVBzk+?qdD!!~^*KiG~3|>%qB%^o#$L$1(?G{jM95#Q5m}s2Hdp`~e#D`ufyZ)onQj z4dnCu2L0gGmglzxrG(V(+4lQ%C@Jk>`sLIG|KU^9l7In3PJ{y**GKvLseNGm>8<-| z#qh`T&5^#!iP)qgW8;5;gIxb-84g{^$=?4^p!@dsabff~aDxHA{}%MLq$j5XzXE^z zCH=Wg{*8Xff9|CpWg+~X0h zf^!MZ-~L^!hz8V8%7=0Y{q+h%C;|rpa{UvKhokjFIIqLhpAsUVuSdj&{CJrL2o5kb z{5u%3oEd=qO2%(U`n&-$DtW$3y`%?kKcbt7kdgrAhX5H5L*a72mWA2}AC6o?jQ*Ih z@-K&gi5)BjsJ{mSkhKT7sPmAN0u)a1%MkxlSp|&Y*DrbXx?a!qyYajF2Q%uABVI;! z0QVTDQ-#ZxqfFW44qXRJ8SPNF<26Zl%@$)Wnx}|R@}OqSr^$~^QTF1S|JhwQ>sHP@ zPd&1k2G2l*P`~8A;Kg!)e1RfymMJ+>H|{1_z|Vp!F~i zvlqtX!%z`JrkRl1HK#;iG2oU165S6q`pA)=?E7p=Mg-9wlLLbWW8(qd;&a^ndxbUk zLI=Z%+P5R%LLTqHJa_$ZE>y7X{YNckdNw|*-}<9H{KNwTL*(I-#n><{vpGo@x&tw? zE&etr_id39;NqgWc9~bo}gc;*i}X#$~qCkwYe|}MkJO?9;u$iDgBQH z9t1Pb!kMV%JTnXGbSM}}GlFL}%aJ#6BYJ!K;yN##T5fq~_jl2f#X_r+oTR;Jk_!8A z)s#%6ptskoWc$ry9ae%KLux0c2%PU4Ra*h8!nyQj^&IRq=D#ZiscvL5+{ zJ6COzwh(Kll(idH91@{)LFN4-Wn*2Nu`i`^Fn(pa{Zo~Y;Y**zVyk284_)%Nk?l+{ zFWNsj?7?EtS)#!BaN@X5rZz`c+C@?pxbSq>zl40O z{n;#k5cI+F+rJh?e=2n>@`AyI<;OZLjE#-H|H^zi$%H!(zkmJX0gW$4AlP! z#4QZG51YTwq^c!eW5@K;?EUeytrRCEUyd92K~D(1C^UNMDnOM%q|KXcZKaWr5_XBR_~rq!#Bt8} z@45r`WU=uzPsc1WxXp_vEL&J#VskuY9E#Bc6QPW~L$+e0oMa{cwfKZ~Rfa*EWYN0C zCo31EXxl%2V_lX84<(w7sYVs2HemW3dOM~mNWz{zC;1Wtg>b$5o5C1@a0;?R2I15sq zyR~Mg?aM-F@aca#y|Cu6BJ$1^Me}$CeV^-n8BHw?WnGNis-^9f*)(d(s=U~~A8mMA ze3KDgw@Jk(n{CS-uVUrBFq*(EMUp>ULWH^5ddqFhtW|<2$ZQv*z9MT=>`v9!R~QMb)yN z**FJ`m4W^a04CCRZ{NImvlYs%JmR@M$ zk>FLWtCl(ADPrFn8ud7gj|btyZn``-z@A$aH7D^M+>7n`2$n5 zHjjkNiWPp_V}ZPB&d$X26oQi`=c-=ZCSp^8z&Hu2VXn#11h=~MJU^0{*-0oy{*}C} zGSqY50L{Pjy=(e)R*gJ_$k?_Q;@UJaZO!+fC5YUTG#1Q>0#QAI{u+R4cD;ty>5z|R zlJ+wev@Au>B^F%qq@mMC#Z5caYtz8d#_z5xE98VdcWu4eFqxv5XtY#Vad1J^eu;o+ zbHQp$3DQb|152)eLfkT(wbij!@g8_zwzfjk9Li?z)MmxixF`ixfR4B?Y2A8ua$CvO zp=w#TCrEsj-POFbisvA*XkhS`0>{+;LuyhQ{Al`4`-_PGYGg10Xi(65x3QKp$P&x& zDo1&kDV?=9>OpXI>ohFs1x3!YT6Vls(&N6H!O+wXd3}qtX(wRlxo4S$R*Y=yVw^Xx zuI;dS+df$>XIGR}yL_f8qDkU=KodF2nfDZIcR zb%J6^m-EfRG2{xD9ys?uF zADY6l(D{x=Ea>p&6kBzUM^A}Ns?+O#yMz6Bxn?rN&p6lUyby6+?%ng|4PUFPDqwl% z#P?f6&+PjI=2H8u@4jUM-asTESq{T0k_4%2I`hg%sU<<_dzD@bi3cEICRNYe1}e4+ zT;t=sRx%`+C?hgiz2XHtgxQ`hef^7}*VAD(P05RrrEDfFcONQ6|CTfg2lX@1&QhPS zSxK^a1Tpqu3As*G<(!>?D216+-91xnmZEad6pPfh9fJ_qyQIyoW9WMFX|m4rqwlkF zs*IOFq*`5wTI_Fv24iSKFyAtP%Ky-^C<|LNcMG#scnc^qa28?@n0mXo9GF>@2cPM8(EeNtw3j*FCEp&dw^ zR1>JN;hk6ejPrc(Uv4Rnp1vyxv(j0++h|hTyvH6>l<(jg2uJ$h(H1ISRXD+X3|fuI zGm5jFvVnXTRaK$X-oH|)42#s-@v2$fFI%O2>PV1ny$KIdBX{R}b$7qHM!VOCIM1YG z2SVoQF3q54S>Yr}7V8tk1`*YjVwvGxobP2?(v+Dug!M{~c1pfT*-3nPUdaS{O@}bw z0as(^A*|dM*E=DPF4{o3IXxPod^S~`Npo&IXNImLak_gLB$zca@^j3cI1J5wHEMw+ zi-tq8UpsZ(U@YLYrOk;`LV3d*PCeZE{&cGYIf zKA9wEFT^3=6>1YY{CY&Zn`YJ1C0brH_A)hH;wAqT;TGZEam|I_v-cUi;$^A`E(DIooJ7Fm7L~_?dG~iL$oSKlj8@75wrVo{LW0I5kMsS83;CJ0$IaAfNGr>T_iVIAO2Y&rYu*7BQ;*GeSMjBjP);ITNRrJ@ zR`E2TBuWCx+A4}%pYmc4cK`g=)oondQ?w_Xm41q#-_w*Vg?mSdd{a&Y%8h>}P}15Asg# zKQaq(!V^=0*i3*Xxx|HQ<(8Ox|S82*9LCvpA?nYY)OGuqf;Q40rIiC>xm}dG^#T?H!FW2*5mS@%!^JX0%qhDAClsd+K;s3&ge>Z16B{#CR zedY7TvKs#2#p^dTF_Ouya@}mDE{2s>(_gzYTY2XsRNq+}F>9=BK!jG&w_okvCvaZ8 zi9Oe??{?>^3}vb6h(@=mN!tRIBjQUyfb-fKp2N-T`3MLzV%loFe(et?vN~H2b51wp z3~Rf}IFJ0k52TMMG-cqz4&lHvr|GC-3a0}x98IUWDmY0wK`!+Ol0~AAXgt@}3mv^7 z_|~+4#KsFKX^+InizhF&mEw7a$xqPwyCdnSoM8xiQgP`Ox?#Y(WZ|bOzZCEf>t$gA z?nmL76v_7pUY56Sll9Y5h}-uUeGe~QNuzf>w>O*_)aDTlHW6b+x`XzU(OC^9I}ow! zoJXD5ZrJcz% zS$-lyg+H8{yQz7(bXm1SFJZi$fUtkG-v@z*J565rr{LK8ye@rpXr<@BA#BP#SN8<- zv#92d?NMvz1vUhnANzRKJ}c6NR8Tf}0*2su&)Enc6EzwQ6Qq&GieC`Yt(04sR$mjg z=ik+zPP|Uu=Oz?jg#LB2fZNazbc#RSzS?1E3^LzF+fF^zkz)%Onlkj(&oz64vrx$s+GU36e|M;RrX?zLT|QkM2fh$Rx}HTP~!>v>y=A8R<18fZ3FR% zD?e7!5D328C9a&o%9?i(pi>YiMOsw=4-6%45NM10OtNLvsc}3Mcs34JOt6Pp>*=8h zufU+qZ$e(5=oN#mn>kN^xMq?lL&q>#qdH5%qP}C;+akqmv%G>fpmZ*kUP-v7$D4LO zEF)le@-lO0aNg7VR1wPRh-QH>r!Wm0Doegxf?fs|v~Xkh<2(`g)*ApuNZS+$MJ1^C z0kb@|D+ewz=2kMBN=Iy1vVkTQlx)V-;$rBI{1u#1prTFpxVLSWg1xqrZ0P2UVk9OF zky`)H6b(+s(Tr7$9*+J5)>7fJK3=2TqdiH;65Xw~#(*@B$bh!k+OXTBrNwVtCD(JHLGx28tXxvl5 zNVQkr?ppE!CK?O3KK+U24fJll0eK5p*O?=hIG3-X^-gHYe1#0TUYZ*QM;R@xAV)bEY+Sz|A3mcB27&?V=i zaaA66q+cUSLDa6&yPbV75t+m8Rr;Pjw&wda!(r=_1bx2#zQ z2xGfY^Lp(ftE1qNamcvrX%B2~FEuiGvNp}d-D`Q5DyAVVWUD=uB{$F-r5+yAEn?2q zt+>Bk#)syDmrH*v!nz4O;V`R;B&Bop5mD)NHWVcL`U9YJpO>-cSBeHhI`XI*jTdL} z3k^z>c>uY;u{<@DAoTmcW3t6W-wA7OBSG1Sg#le8ZMzx(0}+h!C^QiT!U^gz*`4o< z`n|^szWVc9F8-9)b}DU%-(m;n&_{EQMW~*=y0z0Tzvzjkj103IFNDR_u6;L1l!fb~CijT;<`9_syCI%2sf|99(*iFmqx86nVBcp4F(V zsJKTq+2|d6lnie`dijq~0ezN0*{%fjj5sYD2Hr~m%OydZnLKv!@?4b1#H`N|>-Lg7 zv-M=r3tv}O%O@m*ez<_Vcz0e*Kxjb3k0HlBqLK*phCI?wepjr}F^HbI!crKnLpGb+?RS zSA1IFE9}bLUX}$l-?_$|sZf_>lN%vgP87C41tJLyg?vb!vff`*Dmqm81w9gA z9bUdrwmhsK%YW2r8Vt5zHLza>oA#2}8X<@)oEYz>8 zdf1tI8LH~Rlf9ECGsg?zJuPN@&BexuUh~_b1aFXR`+4H1CcfQzO!M+C@mrBcW2Sv5 zZtZYYrc;<#nld+aIVP`Wno1|E&3*N_iyLLn`&1P@>ZwsEaRqSx#F$X$h*<|c`%za` zF!bCctwKcDj_$o9y#(d6_nWo1`P9)Qv`{HnmF0R=JvubYl@E#K2N=)GUMwEy`1hwe zBR!|iqO(1|kyH%b?5gMY-n`J=$52^*bL*j%Tnm6id9l z>vN;NCarg7zybr2G7v*I-e zb`PmlC_mbr``+LI;AFyLil@&YCfuN(X=5diMq0j)Ery#ZjuAR>b-M4e4n4l+&PjGK z5N7`(rY(#cm_ML(;!R}Xgi2K0j;)hqQe^;xNZ1IHEchyfrIgF3}Z zD+pLmiS4SwNoIE{U6TJ*`!jb1(oOqZ@l5&T-r;A{JB?epU^?(iC8L^Q4_0v+l{iw1 z#;S=BtzR;(4J;5l7sDaQ#l%`V>M=+5ke5hLh3*(+MqagQlh`5aO*e?lU>r?65k;TV z-4r^~V#&XC8Vr2Nh_J*Zvat!Gq08zQj0) zooJR-{85jIvr~=r*u9#Xb=Q8&DaWl=QMBz;@^K@~NwgsHaxApDjF?AT8@RG|L4BgY z!eued&OW9wE#cZ0We9@2v9(ut5X_lQ`E6L>dGZ6S@<_z~|7jgNv`S&)w}vsU6tD9eVU&3ec@?JLbZhxMm8{km;|g0 z5HbuI5%F&XP~k&WfB&KYb{L8%*v3MA2?5A+tU~I;j0o)THj1`+qivG?E80taMC zjsYO}XWV=-=(BTRMIjFKBldAb{zwIJo4SyQpq^Ypi5fB%_q~*XxdjC}oZZrXly%Ta zB$F?`-l4+82KW0e__r5{&cxq`-746$@MC00{M};{r$8fsOioBlL;)7S2g=vgCtuJ5 zmFZcS|8HoA1Ma8C0tM@TU@q`|z(8>uw2Th?=nqtHd#m8L_irW1NtB8V%)fs?-5+=v zF_z@p%{3bn>eDLbst-l3X30BSk0R`#c+wScSElRU|m$_vg?MwJw zPYx9|8NFXkT^o#mh8Ps&AH08Fn7x9Z@%M`Q_BR<+XjcHD!hKz?fuD!uuOi^}?P)0X;GR-{%CFbA*I|JIJw>{+Ef#1h zw2Lq1rmJer^dV(8n@n^2GGdDU3N~fLNruPeRk3t-1?Pjp2;Sr2=sfb!#^U{h1wUHA zP7`7scwJKv+G6u#z58VkHPz?fJMbQy9=Fg2A%*Ff;sv=P^|Duln04~YYVd0J1lrP> z!J-b*RZ3o-p0oby-IO)3HlQfEGL8k!y86j>tj*V$Dvq}Fx?mN!vIC3l>cws8rfCuS zTik&|8I=vA%wD%z^$`;ozpr=F&f2HQVZK0Fm(-;w2Q6~W9B=G)L9s8{$MCgR3ICx2;xdR_snD8zE+~-KMF@Tps83DAH`48M>_?^G8Z2IqjeVV{q}{b+(Gv-pR=^Y@tX#H z_x7VH)1!IOh3uBT+Av?FRa%TM5ye0wuTz&9b%UbT<1ubahkqwZtC$(sip3ay9yULw zes-F)`TAx7rJJ6lscSUzu67{PUb5$?vKubF&TnRlb-Lp|2`XsKlr5#!iFe5IR@vi# z>|=!+P(a*n+>M?h^9Pc=N|WPG`PG)n76^EokD>#TR!(>9r`*fPNB3)e8}dHv7UUT= zl`68}=i(By2NnMe(6zZV9`AV2$WJ)8E`R0TRFiUTOm|$k)I~OgdV|+XYR$K=9*)&V zRRjIbO?SnWuIBTeJjAO7E*PuHC#Ntp;tA|SB5fu9=Xud|^`}6mjkqj{t&W`mtoYve zaJBr2Z5>#F4g2Nu>pcG?US&C;IfaMWkTHp>?m6h=_#0B9XeM}h0{&hBA$ZIRc$7S` z=zX?6Y;hHYXpTo{pp8}SnC!xG%O2~(C;3h_zJ->hy6D~Wr@uTTR1oX!*F8h>+r8xS zqQGTL8&hSI>FdHvXUvE&T8n;cby9Xd2j+R~PzWwd>)mx;}F{ zQHzp~#7IU@S%w8z>j&4?4(9ik!tpt|Uaj*zW9C_9c}|MW3G>*zVg8SSq{hV9_6moI zdjf$pti5%~>O>vlwF9e#C`G>k2#}7;4A}hgdmnUsNs20PYbaDA2<)DOnzkONrqy4R zf^jG`_3-0u9|LTC?T3xhX;$x)OWbY_<+5pgeWF<5PtWP8i8TIII~?pkzs*B(n&T$U zz2BL;ceTTARWQ`|t?90hof}KmdVMKJM#O&c!j`1>3%%1=f?U=vblZ;24HF8lThiXnoaeLr!!_ ztq_I0`6ow%;Cv|%4<8Brc)SRIM~vsE6}r$)tC*Fzq7C4Pw{Tl4EvNPnzYia{e3!ZU z-p6RXlIYq5dly|pRVCb+W_Cb@ciX+@LU+O4N#r1(9abE;GElE5@m6f9=}3z}ONC2# zDNHd=_OK%jzSLMKlTvc8$R#&#rHjQfYFBmxT7rSodtxGqgfd~@gs;Y_{TGw+$lECg zYeOs(d4F?_ub-k{?h#rquo+FIYfk?joZngo*olocN?p#cHvhh=`8ai8IAGLW7Q7BR zw&?hs7?&i%rhm&h!X|2b5ZXa3ol$cooVDq|9Amoqrc%ph0VYcE5d`yL6)xk`Gx)j= z_@xmF5XwHr_j~3Boljl7jwWoxOn{fK>ThAzish!a3;|mZmRfQJ5Z(!Yltym1)o+l56}lkJdbPjAE<3ttb0twK8jl4-lOuVaKY`%?De_CG ziRhRQtVK5221jKj&1{7tLxX@ny$MG?z)~Jb7J+dZ%m*lHbW#KPh%Ao#-%>lrWt4kN zj^B&=-Mr+s(`}72-`W7WPt%D%PNDlNEl^MID+xdGataouGYg@I$q1M~vjM0e z=uCE(9HE{yBzDa>O`HAGPy`zp7UDEsGOl|Z%cX}#sX=k2l|cVFiSE#(#3ZD+n>j~5Nzti6gYWJtT z>Qme-@9eD%bXQT8G`V})7|~w_rCNpsu$&5^(RPcj7cv`?l&U5F&8A6(AC6&3dkSgx zB2>lK=l((WiSn#ceM3-`gJAdN>lT zU`zC+Ev%4a*PFa+%A{#k;D?xbmm_?YhQoj7kYp-R`^OB45>}kKFKk@ zTu3jsj?voCWB_ueIX`{RDZJ7t3;(_2A}34f*H}n@+%@dc!S-zUJ{b*JXQ%}7y;}9I znl)3_ODATPs!UKE*31%$j`#*<1u9mAEI>$82QF!=UlcLe8>16?ptn? z{**C)(~Ez(hEw7i(sS3!aMDJa{{h!YnEBp2@meZ;@>3EHmH01BBQ4V;J6T0JQ@7O+ z9-E0+6Xk8ivqV5Y9j*(gm2QwMu=9tanWYy(bvfYdf(hRt=vziQS}(Jh1aB6Td$k9B z8q_%J8&g?r*QOTYuDBrLkyE>GY3*uFqa2{a`GxJ@aL8pXyW7q0mvO|!zle+YieTyR z&~VR&8f}J}v3G52ZH8DS9Z2|#K7I?yOKF%Mtylx(HBUmsg%ftpqHlJbV=dFx0%yUq z$h<{R0RxiDvg`b;m)mruPXYwhm#EC& zXd*IsE($RLoyS#ViQ%=g@^%(I>=h=^+B^`fHE$fwf9-v_1)BF{bzI_o$g97I&CJ>y zUqCMQc(7LOlHMaU7<2-JeLa#SyNBUYK~kW=E2*cS+`LT zW(ht*RuwuWip1Hh{vN2`m&NR{KJn=oNx}3Nw1${S^8H+l+7rLe%vJ#wKXAGWkRmeV zb^RsXUpCE8WB!joNN6PUVGS}(i8dFfL*=7yHVPFX3uJBb=f^Q#^jT)KdCcg}lKL$@ z0lc_#A`s+uqR*P-d!Dmsg|5=yI`&9dIwgb(x{lgS@wW|UrVNmnf>OkF{AIZW{u99v z$_?HP$-KAfYUg%S$*35*^Cm$D@MDW^QzQ@miP8(>wg$Rnu&9ey|;0OrAZilg+dto!tM{MsLT7MtW{~f@HN=-6uj^7J6w; zZD+&C9_V80oS{t-_r4qN7i|%Jl33t(LSwQ-?RZ&W9{G9m?vwhWCx*XsFB1Qyim%Bw z`;8~PX-(sv^mL@r2uzTjMX14{RG@oOU!CaC(~4DbAyQ|#a*3ojrK>9an5Lvq2^uLY z6$b~I=6OJ9B!;le=vzdNqU;+zg(kAoGq@;Wfb)dZ%5)aMyIzSDT%=Z5rz`~1TtBrY zkpYoLro{ecev7-8WmA?oP7%+I4=rpLUVs%7wHp`7ZS}|PZ)-%`myfYz4Ijj{zdecKB>f`mM z{@pp4D-rxAT}g&+Vv_~oE7rq2=?|6^IG3hs;WX}fy01=D82v_>iv+mE(fT8@>r{_~ zck&qHlsgL8*A+$FGnbd`S|7)Jr@W+XJCg!g>QAW)!nQr*cRX|T0qVp)WX&uAHe;|B zpl7|z=GQ%`Rh(C%(bne7suKXz*Jk{d(jPblyfN z@3WG04i4Rg?*%r)NNb`HWxtR`U&GC4)Fkh%-L9?OZf$F)wt##aWFY&#S5>a50!h1= z3>OOLCvlw3Be*Amp~5T6_K}S!dS0(AL?6l5t>pKXyu$Ks5H|XTE7XHwJFc%1XaJ?-5k^06V$`MXNn2+$dN#* zP@U>_ayXBh1&Z6Uc2iPElaAx5cce|pWRCYvYg9;Odckx!mlo=HfX0&*e_&N*5|p}h z8}F`y{#L_i>18xXn8A8|1$Sn5*;FO`qUQWpF#Vf+ zxUcEf&U7)|eqF|))laU9x}T1GT}X2;Tk@Ad9=N>l%6`S=VP-I&ZqTidOifuuL6;p7 zaA}Q6^T#y9YeT;MY}BH6)0n&^OYF=n45yZh*x(T8)D~GaSN>viWWQtYGBOfJa0uz2 zHo4h_5cN}5*u0chdm)&?-bZ(}S>H(C@1{qLh*WExlO878s9y#xp-eA zt*QqZGAP2uGHoor8lCqQ^9po+BT5gmQdeBtCzUWIfp zJ!9JRy=V4c)&gkFL0jB=Jgomua+edXhekqj>rvCFYE5 z66P`xwQw36AqalCH2uFilT4Tmm#l(+R}aO~2ds&lim5{+rkmQ)Ki8sbxG}~S6+hf^ z?0m@HC$PJBm&jfMT~iNJvVUbKzw5z00Xg?A_%<}my<-j~)!(3QzN5FUxe{U#gG+j_ z=enfUC@oS98)d1L0RD96Bg@_L;qrSCT_ zax-|9`-1{6bAzHzfRRKIc_1)}r_O{z8A*&4S#4rnHAd>JCvSidAu|Ud+T({bwO3ZT z9F#c%TZ9mxN8QndfR^0638$)b6VkhFL}D~jUUc1NqV{Dk`1y&WgF5)eWfa8cM=B6Z zwT}#bvD)BFS!F;Kq#-J&)o!fmkrGY#4{tx*v~Y$y*vulv=y&eErckxHkj3^Q3|)*#0is$XwG`e?r~%QAiQ4o*(Mt1h1rwRid%2UaD|PD8Y=(b9Pc2|a zx}nrwstN%+rJC)%#b3`Xuk9O@dmgb!=_l(PH|TrX95KC8?bu0u+j(d@Xyy|Xs-#z6 zt!=ctTDZ=XDD`^hmxfKwb-E(81gE!7G>W=3;|&)YEW=}9kK(G1cEdl^ArZq;Ou@XqiSZjH72rl$Ro=Q)IZ*Z-5tGL5`0fwfzSQ0;%p%h$*@LQ%Lq6wJg_V` zYuiyz=3>YcHWMVWv<_c#wfV|A8p>np$4d9a&%??5^K(W3!$X{SQW&w3p@h2$ry0>} zdVh1($~!|K$;d^y(`L~iq7|vgDtjiBBCy=VHI@?F{xy_8!Cfm=gnxZh*(nYh79k6x zdy%`w=YrA@V!=XdtaC!>H;ma?nOn_(bGt@hCNHreefkjed41}gQt=Guo;hwxj}eJK zQ}I3=y}{|)kWI17?TLSNz)E@r$0%iN-*;yt{}pbc4YdW0!T^nmmbwhr0HW2HVI( zR;i9XT<0F2@Zqh;Y@_+c2a^3Mab|x-auw;48ux0xh=NY2Tz%Lxm3)jG-tdU-)w|0; zx(D)JwTlLo^O;ZuwTE1_+LOZfs>_x|>qGwjohHH4}-1MaRf^p?lD1T5#V;|BhH&WW-s{ROZ(!sOb<+mur&(=ouG zLU_GpjJ=tDd6}xyfGs-qGBT=NANGy*!)-Zh13Y`?Sx=k~i!6cG8^b--M z?IhdT`nnAKoKaO5)>=4kOG@Wy93v$nrK6CmCQquggt!x=sGhVm$GdGU$o+*~Xnyq5 z6w;w)lFdGRwIjK-QXrXV7Rc+gl79FJ-aSp?%sMkNc9FM=OBAEagny%!MPUAz?IjNY zDKpJCj3?u+3>`2P*Dh-A;*EE{bRr&Bn^%|3RBnd|T_Z3vLSBCIjG@^4(H{`oJgnK&+ZBN}tAykI@@)V6>reauD>Es@jP{~^7Us@dNz zGk9VjRM<`V3Gzff3%e!?;1zO|Qf6xcju#*Ip}U@|!beWn5|T~RN!OKF3k$z!a93B| zEPe43nB{~PNg))jt?xl<1uRduo8@?db7Sj;ewo=sT-;WshPGrYVV7lWCU3n^eBb2& zLMzzfHaqwC&e)8MMJ?mjZ%ZcgPMiSCDb7xSUu_BJI9o<)JguffVuUu_l~W6;T<03b z@2V&SR~&4)8kn+&X~mGFky_Lx``GvzJuR}*1z2dTO7=dkWI<-Jd-fUul(oi#4MEd^ z2dY$g``{E))Y)3a7WF<>{A$ZteOFW-O+J>$Vol>r!Q?x`{A=^;Xxj{0&B{__bx(*s zQK>K*nOZM&gftmM7ANcfxi_%B|o*Ga_|V;x5nqt7|@dJ-|u z5!+tVfFbK*$l&y?Dv^>@B_b_o%%skfe4bVNGk>pEHN-wXEOu<Kb(?+v@vHGt`v>7NHkhAo&0cs6@)g$%)0zV{{7>{1)LiM{ z@)-m)MX`rRU;%(UIQ#`{Wx&8}!mEJa==sTppzEP=fP$cYfeCMb*xY>XC(^t4095o9 z{0p;y{iDG9N9d! z^x^m`;SUFAL)a2FJ{5h8|(dV}T;k?G#-Ppr8(zSR1eET{% z1>}@~^?&;B<$dj?(ZiFdvw`6p-bNCh)H1@1QbRN)hj4HQ6x29Q>t2%r+Wl$qXLq8W z<_{mmM1^ZVX4{4uLX+=6D+i$9F8_7vPKE!AU$kXe}=soVTlk?>ZFf+CVt}7j^~ow_%=2pE^A2$WL6b z_7t9*2(ravo|7A$9z6aPo*#q``~gI(LRg#D=68NkZ^-@p03aZ6#lU{N&g+a28se*N zedtnSlYg7`J}luIE&!kHYR|`{AeEs?k9vG&44%Qwf$?<^gzr2$D-M2t=()a1Rex>| z3EbXMz@QeM(jPq57r-hV`m}BU3KD>0#;?OyOB){O806RH5rCrx_XqI=*k0(z01A); z_m{21A3*M$U&a=oY{^eX_XqsS;F6)rkH8%;o9>qZpP;sH#*eYt*~!799mH4qA>c>v z#LpIOek&MwyOf&Yppo@01kJC)dFX8|G|rJH+yEIudY zDq}0A=S#ePMAu>0xJC@PndSXF6OKlfVP!7Z(yDIsgiDOjwHZX+AW&m1 z0k>=Q;*~8WQy<^RiEkrgax)&q)LX|@*UT$mX1RUVFNPHnBSwylay%dgWs@>(S(8|q zlAUf1yf73;D%MNRpRm<2eU5p2s&$h?ZzLRCZLDy6%jc@ZHM5B-zju3Broe;^EW=Rk zHj$`9&H$d*8Vts$)gRU@vS(#E>O?^fuI{t_e6I&i3c^i!55X6;;pvj>Y=F_IPuIhh zxHYOYbLLDn$?7ZFf1IMto@hIb_nq`Gm?NI}YAX#c8_PW%r&}X>3)R|3+&E4APWhx0l?QrY(t@*? zpx!ITl8wU7}yXi@&hrUANq6VAE=yIrYa7SwTXwdnq4sbt|v zFh%od&SvR=0`tV8B293sm6-d9DDDxf8CCOjWnS-IjP^r@Luwvn=9D^g;Z6!@-kfzL z!B~WC4S~Ha!G$5RmjoQ4yGXQ%v>dS%vO}z`c)47mz!A+9P6<;j%hckrWGw&QPw7%p z5P6B5azFHRV*9lL$+-%(llm?ToJhR1pJO3CnjfQdHIDuYZEAFU0J-pcl@$(>PxIK* zbAhTQI`{GA2=*-LOgvXYa)v-qHv~7$rnqnK55F)(6w^(!T&bq(KvsL!Y z3a!gXrcws;E0Ct;)q6@!fQ6N@vpdR&l!6e(j%ac z^+?=AMdVCzxFyIMs7iTE5PwG73xl(AIPgr0v1v9|6r|D0!ie`p^%zbaH+;PKS|L1J^giXl{?#N#L=lFuMcn(V2j!6R|QQ~tWEn@GZLYu zL8Lh#y;Bd;AIMU*7MYWEifsn-cD3h2F;O`eY|k!jsU=fwcJ5;L`sx%yz<0WmR#^Q8(YW`I z2>N3O_~5v_DXvsOjy*IgaZJyMufa1A6v^64Bsm?|#SasH_yir1>#Z6?i#UKj-D==& zB^ZsN|I-RM*7OXdrM=)=Wg0Y~Tp;qJesW=Nhfa-wGWwbi+f(|ea0Ne+CODy<1${C$HWx2fiWtqdYtwAdM3R(!RX7>w@7K1+3VSri1Z-vu>Bo&Yg1v=e&M-~u2bMTk+#CLO|Vh- z+1AOQqU>a;;X#lHQ#&xgQKC+veuCf0sh_(}z2p2H9j-ak$^_9&e&Wq%pb)uxo=2Jh zL&S$;IGEtH;yao+@le36CY!>Aa1Gs%#%~AB5gepi#=ETufBW7LFA_u)QIKXO@-wF= z6U_^~jT;{Bp~6U??ygxB(Q+E7jC%~>7EnC$1V;$)oM?lDvZf$T`Gt*GceiAu6nqa) zjdDq(F?k&3-b^a)K_e=9omUGGZELRgipK_yV6?gb6>=t5;4QL{f<*DOz-|wX>Swl1 zood-NkMVU2>%pq?c{trwJOI3sxWw0hDCmg&2|uPuwgpB!Fr@m{;gU;Bp%sAP07kwX z=H9igo?|z{SWL!Iz?K0ERq|I`#*qSsrSP^UAT~&%zEe>RH3^@XlgB_lSkQ^HGz4zc z35|Og_9w0~a$*&@%d$C_ZHVHqrksA;CK33_?u(02s}y}JEpq-VWIB}Z?sRrNF8G$; zvVWs{D=PW?BRz>o=w7O<=M-)tHj2=O82ehq_e&W^$Sm2!%ZH z&vOPg<5Hw(ICReo3Vo&k>)0Skfuc1kM7cS2?{s1XB9n$uy19&2)V5y?ZZPTQ_vwdrRpWgZjCIfLzRD-}}`Y(xz$ zj>2`BR6?q^fzyzuxcc2@BD0b5^!s9LqT5;pV`4>7sBwDN4b55T8>Lx6z})b1A$*>X z!OZ5H((H=l`jS#vh7$_6Q zxrQpG;jKz1&%-t8mxE1F-N(!5Naw&}km1g+iiuUY@`e*kMH{JkbabsAlvx4U-IP;d z&S>2W76i00g1y}dhG3HLSniN~zgh;&XX@|}!eI;W^h&*BFFgezWmw@ErcQ&$qJYKV zC3ER?GcioyeQdK(5n#vTMVq;e+tn_<7wj49lo}rWeIZtuVw6fqa1ni@^;G6bNh}PU zncYb0d5}5E9CS^=pmFE>=pWv?Yw>)7&RTQs%^Zpfd&*aW*N*qw1~m2#Cl3`wSDL4X>iRn7faHRc3kU<$YETQ0jDYHEnluunY=zFnKxD zvKDrwGKM-voE^lbpP%YXiOdM^yzw_v2Y-jdVH)Dg5?cncdMqPj55G8b`VN)C^Pzp~4IEXK-2`=IpqYmWb$!n}tGaLOf&A7wwoS zX$q-77+95eLR#-m=bMy4P4E>m6`WOo^_wy3+Fg&W`lUJ^0SCQdffO8j-W2CHZg?cLaWZx6F#-1r4iFkD zI%oEvc6a7M$!&@cKcx)C*a@9_$;m^BGmb?U?vmapY-wBHEIOGTFV5)_bJ`}k>Vq1M za;~;MpeC?xtJRwSgoGG(e_s(dxCoarT#c1v z`r5I@&<~0xD645XNp>HN1(uqspZ5aiWP!o+i%mY+i@!2&ga8Zu7h~rXBTCq;>#=Ry zwr$(CZO^QkHMVWrwr$(CJ#*Inlaq6HvM=^cUv#CDPN#3as;Az^7Q^<$Uc29X5n7iY zk<_@RBA?_W*nU`1V6`@iC4O?pcgBC4+ym2DD)8~d+LY(y=F)m*8{wqN_ z9?wEC>sQ#25 z`AeODFkZq4)@PcS@euP%wO@?*(CBU0c-fbee|S%ahUgS`;g8>oB%$eCw)#e5*ZCi_ zT#hg?75tYjy^EIZ)XYB*x@u3$`_$O7I@NVCQ><0-SivSkc-t!NGy4;E#`2G-Je8w2 zDn*bd!3qXEftPGdaqQ1qn__g}hozdXj?84oN3%>2)!4hmQ*{HsD~e_eeaS0s9X}M- z@VwL0aAzAHs>+LeK!hWh6gqjGA8m_-#Ix^;>yb%t@Qo35o8)LgBEv|kiQBJjRDjmQ zH^$1fSh76%r1(p(v8zHVUnSZ@5%Fk!Ku?GMoq4l^Kjc#zO^S{&0?_Fe*T52iHee1J zyEQ5mb7Se2$;V^Ndk*c>zM^Y=@cwjH!r|bNkQ2dy&Wq#;xcCQ_`S%lBmtC^CXS?Z?qM3lQ9ShW_n0H$<%}`Pq~B~bUG22c`fm|BF)NM zb-RxMtm7N(8io5#{lfmKLZ5kiao?K)X5-Y@gr?)1?y2s}Wq5u`irgzx?-!F8+YRLx zPA*pAKh*AxcX4mrl2ucCZg2n{GWz40C!u4w#i)mmdY?&v!POfQM3WWE%`j*=UH47f zat!$018SvN_2J+v?*b@~{iS5#pKkroiT_>Cd>!%OaWuxZV;!l!RA;UXIq2@hc<6aRa@(mUn$S1}fFJnGBVe?Dr-~MHj2_ z`%PKDJN$3G%-_QaE1Kup;#dA?BCxT%dK9R4g@^zMlwktDMDxVvj5?b3%91kf0V+YI z8qD9x8ItPuBxNy8#C&@Bh}>!zdeX+@M`}Dv*VTXi68vpZ%Dw5S%L5Pgpe&bG&MgoK z#etEmzZvbUO3Wz}7YNA9s}L6pZO{mhIeP_7X%aD4o^3GjrlB&Nuq@jpHfR`;Rm81ql;zqmkE=B2TNL4%i+35V-YHsXs~n@CyR zrEa?L_lhP+%BjZ=SMWNwEDkZ2Vc=yfFGV;G>DqjcWcFe7(4lK!wC(C#`mQ-aDc+Ra zCK~o2F4AZ#?}1&B$B(D6`^AmoGq2bfVqQQuG4C;BmNXSFoNW-SP@O2|ogP3Q6v6}Q z8)BuhP7*3_bIC%2N0a3{_K4os9E=<+h=jhUNfG&J2UZne?TBeb{>bsHzB)nc*ITM5O0)&)*_K0v82u(X`F#EHHu6PaAt=ChmtpS2+qj9e#|C0mejpisHE^vTNu(Nf1!nDS_}W z{GI1LK2JGEH|W0lDrEUQEMu*>)R)vGxLtEXNHZ_Uq5nW%U&JpndCXWxm)XBmH)}$J+H#Lc4m}oT#|axh-+b z&;%D-LUNxka?+!#y3^V6c?Z>GaOH8WmDG+}AKpYnjf~^wMH2ha4Sa;-+qYa!M>pRj zI$KpxCC96y;PiIR1%=T-qVTjIP?SdyRV!`f^!K|IUg1egp0>!+gDJZ+W7({-!-5nueNI85qa9u^}`;@@KgZOFAET2_==EUUc1Tc4$`m7FQo`%@X(+@wHG0aeVx zFZqQ!wRry-`r}JZ&0A;Avh{CbDmDCCQ+tgg95aL9h@`K?VrzWwEH_Mphf;xjb>*ns zCSM~CK>|I5a2da!AC!oEfW9|XPKVb;_&xWx417K~>~T-jL7e>tb-pSg)|v_x84H{}!_ZKVugk+1s9gpynu^p*Dp7_=F`FOU^QAXcEg*^qUv;jIpAJF6uJ)tpo z$=5BmA!opv;m2hRVOt@KQ^$BU@;n@H!lHL?)$a$Ve&<5>79hAZ=Ed8$#(Gkzyj49_ z;{|PZ)(lg?z2zE^rZx&KU1QFta7Th{d#}#6LW9eQRv$>q;Vy77(+`b?Q7bD4a;{5S zY0+up+~=n2ieT+GJtP^0j5RJ;ag(I>TP7!GA)wz+YzFdOry+7((x{5(U4znhDH<>m z*_h>O^ObLzt$p8}GI5T-Mf1{P5tGATb7+-XNOSeRxXk;#aI7W zi{dRSDGF&j$auqzbt&Xeyt%-$$~RZ#=tLyp)oldz%6&r#_aRmLwZi3^K27TQLfWs5 zR%FN(gp}XSU&RW}>}H@|sa0C<0ZX9h=;tp)n!Zd$B~^VGH8tpNuL4iJQm|UcFiEqO zCMtVH=IqBF5`JFFb=Z9 zS;<>+F$B@1ZlIO`rmoB>vXObI`;Xoz^11K1!4$^Xq+$EFm%>9Kyo}aV-(TYEM4bKe zcF>gRd$5Te?c?&19pv3 zV*)2FlCSm?x;C{kIF(17J_rdfADIu3JNx9iP81Y$Bz0FVlNk|J09}kvTf^HADEN_F zi~=(AF+qgW_1C|JaoeiE&&L8=%j!~+UQxnffh%m=J{Gf=>Q6RYDqS7ddgiVxGwp41 z>q~g*de@`Xzw%QVg z;$Yq-ijNVVWnc;cjp7b`gKPH|HT)f0ZkMXR#f2anEz=UJx7mlfVd1HX#!5YT&s#Jak*df0-55~0J+I97c|jM1aF$u2yF{uhH&oOYm{-r{a3 zuiZGj7-S>N!yKFR1=+RI z9m>F4*rJ<|w@WuY$$J|q07Z=mCsC)r64enN4lWj4WzmQ*LFY@{jWNzO^?I@?B<@W+ zc-b6j^W*kS1-pP~@aC*uIyyTwFe>C-MBk;yi1yD(gUW6-2v4${*D0iMSSPYp$7<>y zjq@g%_>MTE7&gXdCyGs&h7@dw4Bd?8YCr3}Sf<}!{=~gkVX#7G_v{G7o{bt~%W5Nf z;OFJi+?{LH-&HQrV0h0t(K8l__%}hs%j7TFqQ@xUJ2L(37NFUBLDn(Jpcj5~!{_0av|SPx5b*Ky<_(AXO1Xd^dabT@)nx#*xmPH0M^H;BVqERrom z8rLPzGt;+vpg8E^k?ikY)0k)$E$C#gbOz()ggKU^<}2%I;!z(mwm+!T!Gw%GT;)U8 z#nxNeu(x;n4#2vJRp1%xA_q}lZOM7dda&NI)!j(0I(xBBVIrCii(xKfjqS>QMG(d) z8ceN3hj=-R|2|r3xXcRfbjecluxy+|-fhN*W;zo0=p+smNl^G$kZ$qjrMDgHd4ouo zy-L3Xtjs>M@SG)P!|v!BNt@E>O@x@2T;Rb2QT$R%3uoZ3gK$@f^pTXy;y)Gb6O?vx zTpt~|g+OQ;73Ojv^9jj5smC;{fv{PI7fK|k!=y3vSIuP^9Eq4Wf3WY=2!XHQ#+hyP z?d;xXIf}?^gj6_zi2aW;xVP0k^3kW+aXX*_+o>XDjTVQW=KWj#Q(-K-vJsgh95S9O zY5s0D@-ry@xRuD^4ZxzB7|X)mqs)q(VbEuR0$`N7opx{W1Aj=Rq<9t$Ad%K3=!*#bH1{ADC{KihSK#1 zj}r79l|6(6J{8K#bX5;P8=*~=@6thTpL8V*H-lY%IV;WZWD8au-mlHwi9Y~)BO2cS zK*+HE4}=WUezrOeg%VBBv{yn+1@7I z)?FZA>_cF7kqC7OO<33_1wvYYAR_&Dcbl~9kn@z&<7c;Z<+Dc9+N=h5HOBk)lU-Q6 zIDeYV60{y*La@)yM&~MP0Kife7njZsfSeqjo1C1T3O5^WY#Q*5pOb1^IxmtM0toGA zP-p|x;sz}FA0Q(Lt4e4PkkI-60GX+A$i0&zl#g7(AyEth;~T&Rpt1(wBm#pxYN~9O zq47;n6XQ#;=*Qk#05NH@{}3{l`ZoZQ;(5?x3pg+etnQ7VTtdYEA!Gm1;o&f zJ=+Jf4Q)&>Zh=AsK;a0a2-Hz84ddE?x&R6k0ym+m0$j)m-0hA~`D51s{aC^UL}p*= zcldYtBme31=gidB62i%z>fa%#gYCmQ0stwSEU)YIY_A8J>R0Q9oyOH6RPc9(ca95c z2VL5$U77}TO2`0kwg~=RI<-0na&mGubqD4As);{jhi#f}Frc;!D(^Mj+7&~Doge{G*W z-S02iFZ<;0<=yXY)X^3$&d&n#kL}%WA-g*Wr^l}`V78e%`6Xww2fyXM9ZE8{OW7)2*A1k6%ETcF=AI{+J< z+{|xbP)$}b?~|NkFy4wj6@g3P54Iwj4P^aCx7U`>7l1Q5y0g8C+?kK#<2|5HTOPL+ z=+lRF6Clo&K^XQDC_wcLyaBAE;J0tlmk$8k_-;WjB7cDJ1>`?crYJX#AVBy85)zQZ zx zs>i=##(xzr{}rwI3H1O%XOII=3O@hlwRin{Qs*fLfu*CrR|2Af`4|0O;E~1MCD3l{ zcJkI=NzVf9q-HK3sC|QCA zoR3ie+TCl}PbOBA#~BGn8u!mWuwIJlJ|?895oQ7hKL%|j^g($EP!#Pq}qrMLyO zZFjcKpFMt>Jf=B(gp8DJe1r|2Pkw?Xo6vt3a(|LZ(CXLlbodLXkee}lFAHD-`Eh}4 z!e2$CQ&4kZiXESxRf-@Q<&tlSRR z>!`+mGg=GNdlkgkIsSp)1!qUW=wAya^d@upAs+>D^*rLU-p9VzO|Y|j@yho+lA1a3 z@m@?J?4t{V8>>%n#-^Cky1C1=!RZyyw^2{w%!3oi_d&pk{U7kZIkBVvUOxR4`6$H8 z`x`L-X~$o{;!~fW6x`Gc*5#dh$={Ae+8y2Ecl*cdOrW;&cfZ$96X1`Yfb>$kWmvI9 znXd0y>7|yWl6=dwqMhE;&tjP~N;j;gQLOE>f#rNAb57uy=6Fqc^;xEBR_<1D?DWeA zNY+aUbRv>ih;eglP+-)RxI;mU_HUxt*@_ z{!c(cUjLiqQh+R*(Ukr~$;YK>JV*4ON|Bm^Sie(9;Ni2Us2dDo5;VA8E$BcHLO$?bQ-jKn<=$D-fz?$ZC0!h*XK_pFSL?gX6m_!V)n{a>iDh<4#fJM&U8B-uW7(;NK%4 zrNW<)eAMS*ifDia^g~M~R}06WXBko#;mc0Jv#et@KFRUzV_j51!N!=)aW4Db{`e*a zs;~fpLHqs^O|BcJL5dxU+wsho&SRZ~S4kIAl`J$!a&{vQDUy1HY}gxd&U0rHdq3VA zh~H!7kF2ECqhcjy+i*5NhRhV9XbvE-*7FzzX+DpX15oL7VzDj}av_=aiRM0^Uy|T- z*`F0(Y;O>av@=mbrEO1-^y5472EVg}s-lE9+C9RVl77N=(j7y1$iT{1Fh|}3`D++0 zS*3qdbcHl7SwK`A4=?XIH}m_$pd2)rOH3FOA^mgCC+OS z);(cbL>{?!MLVXkxvtURY9=|^SNNgX41PeZ#cvdlSK9{=F2{mR z>*ms>MX>S6Wo|qU6EX%OhpX4lBvL_81am`dmR$rq)t-v5ow-i~353&JMyUpCtp>P* zlQn^!x4oCRS9d!2;5-_8gaNyM6D!kY6OKXIazPc(m!7*B5t?4``0zhIwV-DW#6lkp zYv|ETwsBOzY)h*inPOh`=Y@N;OoAc$`f7Ju&?!i7Fdfvh6FQB{O7Be09}PqR+do=N zuZUqcTVuC1T(^Hy+}d@d9@zwdUJYjo>pLB%a8#6KI0 zmf{l1#%}y;FfCX{NNj{BKroh-N5?~+_mEBP2<nnvF)-9qsmk;9D_FI?gK zo*&u4g*eZ=0A%uUtNI%;h?>ou(&xPTm?ytH9Knljtb8|-Owi_o7&qApuT zlZPBC8a_Z)jc`n)+}_8Yf)NQNi)T0lWf@;naE(`@`?eAki?IIA`goLmr-e^(AZa@xRunm z9ed66PNDA2x^;#;bIfJm+#H--mMXG~Ap=VG%iVHR{XsOo>eSQumSku3c*}Wz{}Hn* z5wZCi0NKE?MfFeWYYUKt(*3hdKbU^9JwY{zTyFI}IWri#Dm-WVSqJW2^_{DFg{OYe z@pjKk1jUaeyOGIUJwj${(jWGZGc`$a`}VC$mM!z~r!WCTKfX4Sai64%-4ZMc3dX<* z5XLZ$e6y0-J@*&cayu(BD-Tcf<9+Bgk{58^nO zfVS=1F9Hhk64FyY+AX(J*|vn&B4(Qs_!0SRhqVG_ee|rKdmL{kRfT)@<`5|K<~uLl zyvHaWzfjvE|MjliDtrdlYXOhia>?>7=+~27hTd=t$#m8LM?>oxsBiVd)-icGP^xrq z>-;}u7zwxh_e6UeP;gxnY0h;YZ zHm4zh!p=U{`<(6m44Jl%@b_iSlT3g59J4Y3vo|(^Hs(#%4qpZ;e2iGa5p-@=qcOq8 zE%ZnK9UkR?Ms6P87*_Gu-cW@L(qn>k^f{?#UGW{*3Zv9{zfyOFUaC$f%wH)IY+rBJ$o~%4mx}Z{ z96Ao>@O3~Iad(JEn}RcrskKXFfB&IHHFHYSe7e%MCnRR}7>v7}ec93y*?W59Rf|h| z2Xcs7gEVB$QOfUm&HQ}*_cs*P(PZP0>mvIp>XP9qGI}enDsW2jma%NJ=Lp|wa*<`q!rxg{g{^NxuKh@GHlmc~%+j&o&4+Q=vd25Ghb&T3U z@%f%jQd(-J2K@!JwE@K9%ri}7OJVQInn464Jx3Kwoek(_$ zg*2Sp>hw)knmq`CJkIw-vZ&;|1IT;}=LzV`Vg0cLu(|qBWyGq{5&XM7Qmo;Q9R%!k zoEgA~T&70D!(Uw?@~F=)h|iX9b)Jt}@JSo`O$^ZF{^>2VTc6#crq{y<5a%)uk^+>b zQbX+!$A28%F!ixax^&B7SkOl2xk93gQ_l&;TqyhoLwMY`k;&*e0=G~O?g1bUl(YhGVvo@E@3&kCSKza@PsykR9t&vt`}cFP1Og99v{J> z!SYL~AYP_n@&Q+SPS<(%V$+*tb65l$kbOT9bv3T~SC{;XTyB+5Fewn(eTYeL-54yF zH|L@&q{f*mY;azL?rGOcYzzq@EDmfulw|D4luSs`PKk#f$|2tvrkXr5&^)geeATyf z5)*pH7Z@trlMPp|cxG|07ZYR;s*m&!$a5J>C-?Lzk?xG^SQcrLdcCm|m-xtz(|v4D zyK#~K;RxzTeP`TC+xV%XQQP{<_)>1<1t>5SNDMlBzl`JQ7}DP_aBl45gm=f;$)JRN zY*&1|;XOtKx40zlLwzybRTBK}8s|xP4Y=yd&4WzP0{I9GG7!SpLs{goPA?&Lg>QpN1BtH!#0tm2aN-PV{*r8Qf=h~Rqz<% zhN1SFpD$cEBqK`ww;0|U?upyuJ6Fb6M{Y{DCA%xDXxqB^jraX<73WRz&N`2q5eeex z^$kJS@I2@dFZsPf%iL0@BS;i?!bdnO*Wx*>(JEzL$@Q3WdVkH+@U~p@SlI)?!?HkCU*JeH!O<6Zg&bL_6;Do|cgadK0vHK2iwxcC`Aa_L6NKrGkVo z{l~2gMS$aK>UUgV$W*m!)$^_Y8g{oOZm=lx!(BJ_*ONlAHp4!e?3ap&n6M61RiO{& z4%E!X%1eWP0`ZL&=IWb;!E=mSYCE@1Ki9t1>mZm%wC|MUS=VRk&M_t$B7=jj_mMKO z;w_Y5_2)0vfJQ1!yj8Z2I}Wlz?r4m*`O@8XLSS3Xek&-a(}YyJoj$mQmw#oU&|14f zEyJjVh#H-7$ugs7n^YZH?;3z6+LEX*P%+FHTJsi!t>V5|6nH zJ}KOhg-6~h-TTQir*(FPz+9Zx&fKXjMc!lLOGufJE@Q(+(H!;!9<*8i%=#tS@zN_} z7dt^-wIlwxWy)%-_afa2T8M@jB0`PIi}VTT2!PD%{jnWwasB{e{Mxc|#Axgk1EJg* z4!Jy{=1y&Ik~Cp=Dd>Y?J7_ckH54!_Mc}WAvv^WPqg;ZIbigB&uPNCsy%xt&R+*!n?O?vP!fhgSJyYmI7;>(8JLdOxx=J zyEW{`CTftOhdp>_n`9vWQ47|qHXx~f-lYX-AP;nbWhrrmXPA_gP8t;UU%Y>yjD-ZrB0{ zhYm_j(8Q}c^85A|uT!j$b}-$B^`YT495$0<_7jYTfteQb77wpygR5& z5(1a(Wp|2>9pjI`ZSnHTbspjuY8_kjY90=uW-;s;<^&XXaak^%>ZV4y%L38f_tHC@ zX}o7KlB>{R#^9KH98lr!w*Lz^&7Y zhs&e61|MqL$tr+$xMDhJ_opv_7rL|mvTTgfn+^_&Wk*oHeAaa|gvWUcd{zGzb1WhJ zFp`}(!Ai#?xNxjtI;DUHN<@bL&g*7!xaQoIm=ib9G&gp8qUiR!RV@ zk;??BGkxUdeh6^da`;@uRHj9vPCN{6509ozG?t=iY`@%1nx2{R-misUR=}G+D2Ty{ zrp6hupuI}RbP|)!iTzvKW6<^JP1Z_(f>+dBL6>WTov%U0`aw}w-!^RV=UiA;R26{* zT$qPDLdzDvKCwEhWYQuO5ql!PFMOF?lCv4mPKMirgE(Zp`eV&-0C|Ld8Zel`G=Ui8=k2!$;1A54Kj{h=dkCPA)q(cocbT=WC4`F#4xOxKZm z$=~}3$M1`o=#RL~HXEZtVL5)HsulSp_<950GnDaCMZGKRnmHX%vs?2xH_p&Y>2N^8 z+Ugc8PPg)f=Mt(E+tQiaDK}(Eyn<2tbjq$Wkr$D&9z!9gIiqJk4^)Ejqf84Z9(1Qq zx2iXuX05CSpJAUjF*_(>QhYi-i8R(8kH8hj^;pgUfS_JLz@Dp-*Y4cbr&DJYt7w|g z`(PX|8-FKp6{HqR#n;!=(|o5|0?YKO@E=fUMonQ2c(cF?JmnVQq0JChuda>k>kNb>CGp`Fbd(7X2+8= zoEtw@S2-e!;R^hYK~=3k+#+kA1kN%Vpp#6Pf!C0=^lB6Qo_lu+PhQ)G?d+Nv`UV+# z7f}KX{nX@%BWCm4I&UN)8J>{Wf8Q*w1Y&dOC!Ws_VbmRr)D6YxF8_g3ux}*~EPDxVyKfQXeNNMzUQP6&qoElXZ`43ttO6hIEI;jP7?tA_x(u zln32jo{U>$aiW9gp-_FCxY z6oQ=3x0%W;@7!}V(3@~kEyZ039BC_Ca`GTi?}A#8?k}EdFDfKNMvU6!_xHClaqFy3EA+N2lH5jE5Mnd4T*$30$Jc z^5v(BVqCwSj5p;f3~gLF7KWo?v9XQl-cQH~s9#Et(T^sFAfzc7sTViMV^Yx8bCx1~ zJi<;X8b$p{)6mVi>Uh{9dws_i@0zvdMg@;E(Kc_X9HLo+H8EUPzKg{WsO2znFr=FO zuANuf?NHe)tF?msd0Uk?m+0R7_|}-AA#yjV+J`}E3MuD>vY^m(o)CBT<4!g*W#+c= zN`~OrhfX%(_MKWOmYKv6;L~vEO-fSZ`3a1kG1AX3AI$I=!mY;+h<$OG?CSEZbD(3+ zkG@=%Jd)A%qSmosOLs+4X22|>;402c;Z?)cUKk$?gb|VhT3LXPC2H!%w7L5V#6rsz zllJ$Fhq?7}#4Ir5j#ggweNKedS)rA8lL%YX%(`N*tPzG0Hv2p~o{7x(q<)#aW4mUt zc6DmG{_C6*3F&9X_~~}@qy~I^Kp#@NsN+Qe)W^vJMiR`3kRda7B)U_aeVymEMfcb1 zQ>%wMNVBskT!xkfK%9Kqsm8Ti90n84@-I>Wp3(V`1M@h~&W3VnK?K#wnccRA#hNZf*`Y-W>%qeBc<>7iTUY`%GU*LiMS2F^ zS;JEVwj@9=z05HcV`U@1ZE?gQ0`!bhfi8%J|G8$D^%`rbI<4QF9QXC3(4E<(~25gvfT8$e}R*leyERCSny*K^kWk$ zi%3Rs=a++Z%3KnD@%s;1wo_liA;?*`Xc&;D3$f` zF%WL$evlW$vsf1oGyxUqi?nbQ@%oQJxwsB%-+A`puts(kb8CtGW4P=xBVgRL^2;*$ z#h~gC*52s>am{QcTifJuy#0fW?Q%`EjT*zK&^{k``kU3DiLH%wW%jHwQ+6+0c((96 z;F3`Z(2*8W4^g(IU+lPU;*jrWA7AcxY27-Li9Ft+EbY-QJw&E})M+`?hwO{e%Q0k0Ffs7KuwY?#TUnGmrUSDjeZE z+ZXMI+qOdVsPoSGX7$z*((XZ)l1j|~{nRLx;_b!N`(!vb-phi6%l?D$L%<=C6K zv`P*((RHJj#>Cx3aEf3N%F3@W72ZyG4{9jEOcKFslu~THUwu4}^NP4Tgb#;D#$2=WXSNGR95Sr+gCA0-7zDJGF9#95B3DU8 zB-%e$wfP;4U_J~L0%kQ!!VwK6 z`N%bv6SwVti0yY^o+}@hwHj}}CX9@sxZK)&Bzi(zM~HFZk2WpOPuU_>KQir3k>3>g z;U_9I7%Knb*MYi1VS9BJX9RTOQqi<2Wj>ap14bMuy>f;itlM#a zX6)-i(+Omn3U$TLY^t#G%ytQt{&LO+tN7K*O>7*2JixhAG<$^M*e7!gvb6 z(%l|FPZn<_$uNNA1LZLMa-ND6*eS;lc4KgdccCd$Pj$+o{%Ek zszMjL+cQZaz414}I_!O3iSmyk1fwhNF;qh}`+TpTr=>qu4eEJd%B4mgf0fQVV#waK zs`96tv)v<>v~p8|V|*mK9t)+I3;qQr75GMLij3~uf7M6p=N&WU2qA(jY&){|FstP6 z7+ufVZ7yNKN0i;PJuVN2yjv51XtEY(2#mg(cO1*XBs0vGe>BVtoU2;LhaQP;cs{m!R?#7RXeqiy;2**4@oyq* zy&*WR_Bm_*`s_n$afvN3=fwVFJsOl14~v;y=cbP$AAS1GIkE7VQ7%CCkZx6H?~l1% zpI8hE`vXHCzD$5sA z{cHTR#6i65sI&9uAS$?Ss@3m&;=phfFY%1en4#F*ih+~FE~1WGuiy%8W#k^!(+Krm zK8Q%M@mRf5-;2x*v-~3A`9*j3NivkjWoip*%q_H&4uZNnaX78@L7cFqFn!JD;f$h~ zUJXRyi?AQK?Uqhl5hP;xY3~jgPeY(bhT5-Gq3)b`)Lw3HUI1;devcmU16Oi=|#@0FMUtQ}sM3AZ(-oZGW#It(hgE zuGCg08DdqyNVcH%Ra3|Lk;4dW6cm4rDiE7F0#sPd<}7e4bjsne;x~V32Ml0r*1>+<)PzL2hTC(O6?i|SU>!%#*M$JI@*Go+`&ApUGCPjV0 z+oekk;qVHI`IDy-jTC3(7T)#LN11bnFkoA8Ci2vI_)il!p~13}Bpsa>nh>X8a?c!V z7odHjoAL0w0^Ygl7c6FDe46p`@F$3OC97-O`0Q8Ibd2pgx5%1V5A?>J;@{V#8nf`S zPH@xt+7ISVoJ6l$Vtlxb;!K3QKfO>dajRF2xIsk-S9(zWoVV=P2q~nw(X3$4J9$K} zrJ_k;{$YZLR;U2#-C{*urvoaQ5Om`c7gpD}U|pChk(-n=r*5m02&~KrPSV-WD(X$a z@w)4u@vWYt-Ga$k>cl|PFpp3Tm zfTy-oq7$(V^^rJ?BTQ8QntFCa`o>1lnGn|Ppyey&aKZbTVswN&KEyW?ycIFGxm6G_}EkViH&Drt#lJ^opo=Kbn==bf8UmiJyj!! z)bzkNnK>&8B;j?k?+=6239r*GYU05)r9{V^fjp=sHovl%c8))Zj}uWF_u+ zIJ^&Z;yTI=tV9bf9mktT466!KDJDBd-97A;e40-RS^N@udMm=ZIk2edMWgDXVGe5v ziA{ZVM0l9I7T4g^2mv_9t*7ra6=cha$j~&R~I|?Q5 z2?)zF56}6^SB1$1(+O-ojL8q*b5cqW?NJ*U_sJZd2I0D4U7$^DKB(86C3dr#|38gg zXHXMNw|;FPkq%Ntf&$V*LPvV=|w^Z>0Nqn z7w`SvnQ!L3cfLEbKlYqGJLlQiALq>OK4+)*iCb0Y=~zM(*9=xSY$G`!l-y=^X~W-D zvrB(oVWTxE3a~fgveM^Zxr%#1%{kkh?mQn9@@AJO>53rf;;?296ZoIy+0-=(MZO3@|)FU+1{ zvH~Xnl$=}s%G^XQI6uTJm~a*_ikO14B+zD zv?E)JpEiTo4>B0vcsH@i|A0j#mVnc<=#cjIe2j;g7d6!=-nSaCAUt^GI z6Bqr<`3Kf(iUWsIQ6jo&vVg5v)%m=jyf$@DxI@rdO4qZi9431ni9Z*v5}f5bm__3hqmd<&|)7^t`VsQDHv7PMg*H#Qe<5$oZhvRK~1wpq#Ln zKQC5f*M}80L+PF@{N_(x*;sHsEmd*ofP{%pkmw zXmVZ?-O@{2Lz97+{3yXA^etBQl>yW-P$crNjc-Ms)9YIKYC82Y?<<@J z`R|aSArj1}QL+%Zk%1=S3f~F&{yZsT1%k8-1)Wi4@Z86Q7kihn8~)iR_szUt$*dt6 z56f}CxRe_XA@mFT&DL(R>LcV!_i6#4$b2@RJ2kUXJA~fMmPCx;lH%X*e7z_o;>vOh zQx%IB=O33C(lBp4CI~K+bNV?MkPv`yUKkKMNuK3eTz&5+(+UN+6zTj31~oz}?O)r% zxFHYro-?gkrxS(MF@(x#meDVpFE77&&f(u+M7n2!0yX^N35^k-j!oHZy9?aIuIDpt z6cc?q);gZo@lxtnc@nKy;@_2EDis-qQB(trU>`mU<>;BPO2=^l>RpT@Ntjyp%Dipz za|b$7CFKiFVg7Y$Yc;t%r&OFjpsm9_HlnE-4Bthlp4^Tx^uwA+DwlJ$l?o*Fse2wy zUjP!xs}X!3`Xz0dpM3lJ;C6zyYle?RuFNj{p%$&YbM5XomdR?k)U4A>k`c1ZUvZxd zrDznE6Kx02n{7Dv*Pkv&os{=wa;r;$?3`=&nrJr|OkZT5^YJQpC zs@<#oeC#fz_0_}V)1A`W-N#T^(_w4SW$jlKAp`f>=XROZEP@`w!_&!OyoX(k(d6xS z`ZsC6xrWb4u;xKehgW;vf-7B?vYFvoO5vSjq4UL~(Wm>uIa3L@D*;(9;Zu|i*?9t! zF0=!utAu%UV7i3Cyk$&l_W$R%@+SPaMi z!nYCoH@?j?l#`XKB^(9haJI76gB$UJ`2_j-z=E6rkUR=*fpNMXxmN!zBAgr*EHH2& zhk`hSA1uf(#4iTEt|=fOY;tX(>16eP59*;ToSorTK#-D!JsJ)GJ=0S(;!|?9w})9c zI{xvmXNy1suiO9N-~k%IQRr)TK!IyCU?DMxFfW8p=x=!c4GO4%cm)Su;}8HTz+ngr zM@}Hp*#cvWhFbt%{cE-`AD9o!36PQk!X2%y%kTn3|84Pl?#^%^NE>FSi*W#ew17fF ze^^8)GzKUL7X6!U1O$um3;ch}@NODUI5LWmdyg1ye^#{Ed2`F}=4aiJ-r?{RQxa+W zh45m7xEIAZ@r%<`7Q;a`?$+31YHtppi#vTUPV76A4i@I8O2ZTr{UberTH_AJI5)*+ zkbj;hCdycTzI(L;3wwA=tqiEIY)s>4(^*Q#vn1#5Pud+T3?T_uW6TAcB6|d}t1I+% z*}nQD?(1wrk+01#9U&rd^fGq|@GP|8G27e#n(nXB)O4@kvJjV3UZ14CQ)RmI@+J|v zX@{weIL$6;I?sZn%niy(U1D+}@dSUw?g*!hucg+I07N-=HU`~&o0^mhtHVS_MY^~B z**BG(!g)qs!Cz3YG0=S}^Xz^)A(eP^w|SK?9t zm{Hq$z;=2ew>&f16c(wt6DHtY*s+3eivh)wNjkBDde?y2dDKD;?u`8L_%FDDt?t-PZ-SwZdr zImR#aZ1i( zMGQ|%kYFe6MU5Vw9b3jPxwX-cY*G8Y;&~5|9KR400_~TeE08IhK_InU|DzqslDyU} zpHqVK<4n+nl_40`5-{qDRR18KIPi*n`JFP8bh!;Bi!Eye-Tm;~%j^klo5)Ic2fhsd zuMIEob<37+#TxSM@|~Ovr}&yEa!u&c!`;Ew{WY7bFhZ{77lt{Z3|n%BPdFWfK67G{ zR7W0O*A#6LRM$ROOssTdtHO9K7+M zGWb-`l0CLPR~A@PE5+R9jFyc5@h}dnb)qs95p9Q;tSAy%8tm7}yy&ze8b_;czI@as z>2(idiSO}D{)F~vWAsxUMBM0iHH}<(+=r{~7}gP;iLI33&rQxku6y)TWJOecm05o* z8ne(*iq#q(zW(3XCjW<4On9y`J{y`j?LI_RANoFz;i+C+-gLoLfyf{-)-&_4vgL*F z2S#<#Fx7)vJ%%pgMGvk%hCEvFmlB*Gr)zv9>BIMY=ix5zqK*R32nm}mOOIejje2x+ z)U={_>)zHq5Ui(;!%3*EFYmo{+XJ za?a$_ckeRl$ju4ks=tjk+szK}nM*rOQ@=m$^WF9|%xq`cL(KU#$7Wm`R+^Rq6-i6hY&fv_{&T0f`GKyq8LxB&Z&X>Y zG7;@6M)nHVqV&tz&UiaANq}s1CXtsl$|jt3_nr^*Np!Ue8}nBsmpgz$m|JgX$n^Z$ zQHfRjZj}hfC;alh=R(|iv*xf0|Ah9FH$CtF;&YPH(uon5opXF1yL$8nxemQ6dEp=T zo9ggv-cGJtV4Ne3)>WQs#bZP|?S;X9-b7nl{9!iRgvFRJZ{m9gq3U9h>c#|3T20T- z_DONG-GV~7aji>n@q07T4#Ox@ktsZS!VW#rrE2%1>ZHzL)w<1La`G5;Xat!yL7J3= z9)+}Mytcd#jhK2?mN?~da@u)reANKU3kIK7OGxha#A&4VGtaL^iTC}^dRlCFIwT=k zhDv#=S!LS|?d)M#WH)adD{5a_7hB)bQNGayD2q8Mtow3onp9&5yo%rxH~#)pO5u_q zl>Ekvf2KB~{QrpVMmlh707%u*3ho9p8gyEMR>}^-kGiu$9%*8<8{n-xE*_gW zT6D`;C|Y(QXs@gsxZBeDwU(78_@mSEXCsQPmd&i{%)3EmgSA|0EmN#rFwLUSkWupF z7Vnufz2Fi?b5qtgUJfzMA4{0Zba(Y1gP! dwdoc p. 1 + + +

    + + Interface from GCL to X Windows
    + +

    + +

    +

    + +

    + + +Department of Computer Sciences
    + +University of Texas at Austin
    + +Austin, TX 78712
    + + +

    +Software copyright   by Gordon S. Novak Jr. and +The University of Texas at Austin. Distribution and use are allowed +under the Gnu Public License. Also see the copyright section at the end +of this document for the copyright on X Consortium software. +

    +

    + +

    +

    Introduction

    +

    +This document describes a relatively easy-to-use interface between +XGCL (X version of Gnu Common Lisp) and X windows. The interface +consists of several parts: +

      + +
    1. Hiep Huu Nguyen has written (and adapted from X Consortium software) +an interface between GCL and Xlib, the X library in C. +Xlib functions can be called directly if desired, but most users will find +the dwindow functions easier to use. There is little documentation +of these functions, but the Xlib documentation can be consulted, and +the dwindow functions can be examined as examples. +

      +

    2. The dwindow functions described in this document, which call +the Xlib functions and provide an easier interface for Lisp programs. +

      +

    3. It is possible to make an interactive graphical interface +within a web page; this is described in a section below. +
    + +The source file for the interface (written in GLISP) is + dwindow.lsp; this file is compiled into a file in plain Lisp, + dwtrans.lsp. dwtrans.lsp is compiled as part of XGCL. +

    +The functions in this package use the convention that the coordinate + (0 0) is the lower-left corner of a window, with positive y +being upward. This is different from the convention used by +X, which assumes that (0 0) is the upper left corner and +that positive y is downward. +

    +In the descriptions below, some function arguments are shown with a type, +e.g. arg:type, to indicate the expected type of the argument. +The type vector is a list (x y) of integers. The argument + w that is used with many functions is of type window +( window is a Lisp data structure used by the dwindow functions). +

    +Both the Xlib and dwindow functions are in the package xlib:. +In order to use these functions, the Lisp command (use-package 'xlib) +should be used to import the dwindow symbols. +

    +

    +

    Examples and Utilities

    +

    +

    dwtest

    +

    +The file dwtest.lsp contains example functions that illustrate +the use of the dwindow package. The function call (wtesta) +creates a small window for testing. (wtestb) through + (wtestk) perform drawing and mouse interaction tests using the +window. These functions may be consulted as examples of the use of +commonly used dwindow functions. +

    +

    pcalc

    +

    +The file pcalc.lsp implements +a pocket calculator as a picmenu; its entry is (pcalc). +

    +

    draw

    +

    +The file drawtrans.lsp contains an interactive drawing program; +its entry is (draw 'foo) where foo is the name of the drawing. +The file ice-cream.lsp can be loaded, followed by + (draw 'ice-cream) to examine an example drawing. + draw can produce a Lisp program or a set of commands to +recreate the drawing; use origin to zero before making a program. + (draw-out file names) will write definitions of drawings in the +list names to the file file. +

    +

    editors

    +

    +The file editorstrans.lsp contains some interactive editing programs; +it is a translation of the file editors.lsp . +One useful editor is the color editor; after entering (wtesta) +(in file dwtest.lsp), enter (edit-color myw) to edit a +color. The result is an rgb list as used in window-set-color. +

    +A simple line editor and an Emacs-like text editor are described in sections +texted and emacsed below. +

    +

    Menus

    +

    +The function menu provides an easy interface to make a pop-up menu, +get a selection from it, and destroy it:
    + +

    +

    + +          (menu items &optional title)
    + +

    +

    + +Example: (menu '(red white blue)) +

    +This simple call is all that is needed in most cases. +More sophisticated menu features are described below. +

    +The items in a menu is a list; each item may be a symbol, a cons +of a symbol or string and the corresponding value, or a cons of a +function name and the corresponding value. In the latter case, the function +is expected to draw the corresponding menu item. +

    +If a function name is specified as the first element of a menu item, the +drawing function should have arguments (fn w x y), where w +is the window and x and y are the lower-left corner of the +drawing area. The property list of the function name should have the +property display-size, which should be a list (width height) +in pixels of the displayed symbol. +

    +Menus can be associated with a particular window; if no window is specified, +the menu is associated with the window where the mouse cursor is located +when the menu is initialized (which might not be a Lisp user's window). If a +menu is associated with a user window, it may be permanent (left +displayed after a selection is made) and may be flat (drawn directly +on the containing window, rather than having its own window). +

    +A menu can be created by menu-create :
    + +

    +

    + +          + (menu-create items &optional title w:window x y perm flat font)
    + +

    +

    + + title, if specified, is displayed over the menu. + w is an existing window; if specified, the menu is put +within this window at the x y offsets specified (adjusted if necessary +to keep the menu inside the window). If no w +is specified, or if x is nil, the menu is put where the cursor +is the first time the menu is displayed. + perm is non- nil if the menu is to be permanent, i.e., is to +be left displayed after a selection has been made. + flat is non- nil if the menu is to be drawn directly on the +containing window. + font is a symbol or string that names the font to be used; the +default is a 9x15 typewriter font. +

    +The menu is returned as the value of menu-create. Such a menu can +be saved; selections can be made from a menu m as follows:
    + +

    +

    + +          (menu-select m &optional inside) or +          (menu-select! m)
    + +

    +

    + + menu-select will return nil if the mouse is clicked outside the +menu, or is moved outside after it has been inside (or if inside is +not nil), provided that the menu is contained within a user-created +window. + menu-select! requires that a choice be made. +

    +In order to avoid wasting storage, unused menus should be destroyed: + (menu-destroy m). The simple menu function destroys its +menu after it is used. +

    +          (menu-size m)
    + +          (menu-moveto-xy m x y)
    + +          (menu-reposition m) +

    + menu-reposition will reposition a flat menu within its parent +window by allowing the user to position a ghost box using the mouse. + menu-size returns the size of the menu as a vector, (x y). + menu-moveto-xy adjusts the offsets to move a flat menu to +the specified position within its parent window. These functions and + menu-destroy work for picmenus and barmenus as well. +

    +          (menu-item-position m name &optional location)
    + +

    +

    + + menu-item-position returns a vector (x y) that gives the +coordinates of the menu item whose name is name. location +may be center, left, right, top, or bottom; +the default is the lower-left corner of the menu item. center +specifies the center of the box containing the menu item; the other + location values are at the center of the specified edge of the box. +

    +

    Picmenus

    +

    +A picmenu (picture menu) is analogous to a menu, but involves a +user-defined picture containing sensitive spots or ``buttons''. +The test function (wteste) shows an example of a picmenu. +A picmenu is created by:
    + +

    +

    + +          (picmenu-create buttons width height drawfn
    + +         &optional title dotflg w:window x y perm flat font boxflg)
    + +

    +

    + +

    +If a picmenu is to be used more than once, the common parts can be made +into a picmenu-spec and reused: +

    +

    + +          (picmenu-create-spec buttons width height drawfn
    + +         &optional dotflg font)
    + +

    +

    + +          (picmenu-create-from-spec spec:picmenu-spec
    + +         &optional title w:window x y perm flat boxflg)
    + +

    +

    + + width and height are the size of the area occupied by the +picture. (drawfn w x y) should draw the picture at the offset + x y. Note that the draw utility can be used to +make the drawing function, including picmenu buttons. + dotflg is non- nil if it is desired that small boxes be +automatically added to the sensitive points when the picture is drawn. + boxflg is non- nil if a box is to be drawn around the picmenu +when the picture is drawn (this is only needed for flat +picmenus). If perm is non-nil, the drawing program is not called when +a selection is to be made, so that an external program must draw the + picmenu; this avoids the need to redraw a complex picture. +The remaining arguments are as described for menus. +

    +Each of the buttons in a picmenu is a list:
    + +

    +

    + +          (buttonname offset size highlightfn unhighlightfn)
    + +

    +

    + + buttonname is the name of the button; it is the value returned when that +button is selected. + offset is a vector (x y) that gives the offset of the center +of the button from the lower-left corner of the picture. +The remainder of the button list may be omitted. + size is an optional list (width height) that gives the size of the +sensitive area of the button; the default size is (12 12). + (highlightfn w x y) and (unhighlightfn w x y) (where (x y) +is the center of the button in the coordinates of w) are optional +functions to highlight the button area when the cursor is moved into it and +unhighlight the button when the cursor is moved out; the default is to +display a box of the specified size. +

    +          (picmenu-select m &optional inside)
    + +If the picmenu is not flat, its window should be destroyed +following the selection using menu-destroy. +

    +          (picmenu-item-position m name &optional location)
    + +

    +

    + +          (picmenu-delete-named-button m name:symbol)
    + +This deletes a button from a displayed picmenu. The set of +deleted buttons is reset to nil when the picmenu is drawn. +

    +

    Barmenus

    +

    +A barmenu displays a bar graph whose size can be adjusted using +the mouse. +

    +          +(barmenu-create maxval initval barwidth
    + +         &optional title horizontal subtrackfn subtrackparms
    + +         parentw x y perm flat color)     +

    +A value is selected by: (barmenu-select m:barmenu &optional inside)
    + +If the barmenu is not flat, its window should be destroyed +following the selection using menu-destroy. +

    +The user must first click the mouse in the bar area; then +the size of the displayed bar is adjusted as the user moves the mouse +pointer. In addition, the subtrackfn is called with arguments +of the size of the bar followed by the subtrackparms; this can +be used, for example, to display a numeric value in addition to the +bar size. +

    +

    +

    Menu Sets and Menu Conns

    +

    +A menu-set is a set of multiple menus, picmenus, or barmenus +that are simultaneously active within the same window. Menu-sets +can be used to implement graphical user interfaces. A menu-conns +is a menu-set that includes connections between menus; this can be +used to implement interfaces that allow the user to construct a network +from components. +

    +The source file for menu-sets is the GLISP file menu-set.lsp; +this file is translated as part of the file drawtrans.lsp in +plain Lisp. Examples of the use of menu sets are given at the top +of the file menu-set.lsp. In the following descriptions, + ms is a menu-set and mc is a menu-conns. +

    +          (menu-set-create w) creates a menu set to be displayed +in the window w. +

    +          (menu-set-name symbol) makes a gensym name that +begins with symbol. +

    +          (menu-set-add-menu ms name:symbol sym title items
    + +         &optional offset:vector) +

    +This function adds a menu to a menu-set. sym is arbitrary +information that is saved with the menu. +

    +          (menu-set-add-picmenu ms name sym title spec:picmenu-spec
    + +         &optional offset:vector nobox) +

    +          (menu-set-add-component ms name &optional offset:vector) +

    +This adds a component that has a picmenu-spec defined on the +property list of name. +

    +          (menu-set-add-barmenu ms name sym barmenu title
    + +         &optional offset:vector) +

    +          (menu-set-draw ms) draws all the menus. +

    +          (menu-set-select ms &optional redraw enabled) +

    + menu-set-select gets a selection from a menu-set. If redraw +is non- nil, the menu-set is drawn. enabled may be a list +of names of menus that are enabled for selection. The result is + (selection menu-name), or ((x y) BACKGROUND button) +for a click outside any menu. +

    +

    +          (menu-conns-create ms) creates a menu-conns +from a menu-set. +

    +          (menu-conns-add-conn mc) +

    +This function allows the user to select two ports from menus of the + menu-conns. It then draws a line between the ports and adds the +connection to the connections of the menu-conns. +

    +          (menu-conns-move mc) +

    +This function allows the user to select a menu and move it. +The menu-set and connections are redrawn afterwards. +

    +          (menu-conns-find-conn mc pt:vector)
    + +This finds the connection selected by the point pt, if any. +This is useful to allow the user to delete a connection: +

    +          (menu-conns-delete-conn mc conn) +

    +          (menu-conns-find-conns mc menuname port)
    + +This returns all the connections from the specified port (selection) +of the menu whose name is menuname. +

    +

    +

    Windows

    +

    +          (window-create width height &optional title parentw + x y font)
    + +

    +

    + + window-create makes a new window of the specified width and + height. title, if specified, becomes the displayed title +of the window. If parentw is specified, it should be the + window-parent property of an existing window, which becomes the parent +window of the new window. x and y are the offset of the +new window from the parent window. font is the font to be used +for printing in the window; the default is given by + *window-default-font-name*, initially courier-bold-12. +

    +          (window-open w) causes a window to be displayed +on the screen. +

    +          (window-close w) removes the window from the display; +it can be re-opened. +

    +          (window-destroy w) +

    +          (window-moveto-xy w x y) +

    +          (window-geometry w) queries X for the window geometry. +The result is a list, + (x y width height border-width) . +

    +          (window-size w) returns a list (width height) . +

    +

    + +Note that the width and height are cached within the structure so that no call +to X is needed to examine them. However, if the window is resized, it is +necessary to call (window-reset-geometry w) to reset the local +parameters to their correct values. +

    + + + + + + +

    +The following functions provide access to the parts of the window data +structure; most applications will not need to use them.
    + +

    +

    + +          (window-gcontext w)
    + +          (window-parent w)
    + +          (window-drawable-height w)
    + +          (window-drawable-width w)
    + +          (window-label w)
    + +          (window-font w)
    + +          (window-screen-height)
    + +

    +

    +

    Drawing Functions

    +

    +          (window-clear w) clears the window to the background +color. +

    +          (window-force-output &optional w) +

    +

    + +Communication between the running program and X windows is done through a +stream; actual drawing on the display is done asynchronously. + window-force-output causes the current drawing commands, if any, +to be sent to X. Without this, commands may be left in the stream buffer and +may appear not to have been executed. The argument w is not used. +

    +In all of the drawing functions, the linewidth argument is optional +and defaults to 1. +

    +

    + +          (window-draw-line w from:vector to:vector linewidth)
    + +          + (window-draw-line-xy w x1 y1 x2 y2 &optional linewidth op)
    + +          op may be xor or erase. +

    +

    + +          + (window-draw-arrow-xy w x1 y1 x2 y2 &optional linewidth size)
    + +          + (window-draw-arrow2-xy w x1 y1 x2 y2 &optional linewidth size)
    + +          + (window-draw-arrowhead-xy w x1 y1 x2 y2 &optional linewidth size) +

    +

    + +These draw a line with an arrowhead at the second point, a line with an +arrowhead at both points, or an arrowhead alone at the second point, +respectively. size is the arrowhead size; the default is + (+ 20 (* linewidth 5)). +

    +

    + +          (window-draw-box-xy w x y width height linewidth)
    + +          (window-xor-box-xy w x y width height linewidth)
    + +          (window-draw-box w offset:vector size:vector linewidth)
    + +          (window-draw-box-corners w x1 y1 x2 y2 linewidth)
    + +          where (x1 y1) and (x2 y2) are opposite corners.
    + +          (window-draw-rcbox-xy w x y width height radius linewidth)
    + +          draws a box with rounded corners. +

    +          (window-draw-arc-xy w x y radiusx radiusy anglea angleb linewidth) +

    +

    + + anglea is the angle, in degrees, at which the arc is started. + angleb is the angle, in degrees, that specifies the amount of arc +to be drawn, counterclockwise from the starting position. +

    +

    + +          (window-draw-circle-xy w x y radius linewidth)
    + +          (window-draw-circle w center:vector radius linewidth)
    + +          (window-draw-ellipse-xy w x y radiusx radiusy linewidth)
    + +          (window-draw-dot-xy w x y) +

    +

    + +          (window-erase-area-xy w left bottom width height)
    + +          (window-erase-area w offset:vector size:vector)
    + +          (window-copy-area-xy w fromx fromy tox toy width height)
    + +          (window-invert-area w offset:vector size:vector)
    + +          (window-invert-area-xy w left bottom width height) +

    +

    + +          (window-printat-xy w s x y)
    + +          (window-printat w s at:vector)
    + +          (window-prettyprintat-xy w s x y)
    + +          (window-prettyprintat w s at:vector)
    + +

    +

    + +The argument s is printed at the specified position. + s is stringified if necessary. +Currently, the pretty-print versions are the same as the plain versions. +

    +

    + +          (window-draw-border w) draws a border just +inside a window. +

    +

    Fonts, Operations, Colors

    +

    +          (window-set-font w font) +

    +

    + +The font symbols that are currently defined are courier-bold-12, + 8x10, and 9x15 . The global variable *window-fonts* +contains correspondences between font symbols and font strings. +A font string may also be specified instead of a font symbol. +

    +          (window-string-width w s)
    + +          (window-string-extents w s)
    + +These give the width and the vertical size (ascent descent) in pixels +of the specified string s using the font of the specified window. + s is stringified if necessary. +

    +Operations on a window other than direct drawing are performed by +setting a condition for the window, performing the operation, and then +unsetting the condition with window-unset. window-reset +will reset a window to its ``standard'' setting; it is useful primarily +for cases in which a program bug causes window settings to be in an +undesired state. +

    +

    + +          (window-set-xor w)
    + +          (window-set-erase w)
    + +          (window-set-copy w)
    + +          (window-set-invert w)
    + +          (window-unset w)
    + +          (window-reset w)
    + +

    +          (window-set-line-width w width)
    + +          (window-set-line-attr w width &optional line-style cap-style join-style)
    + +          (window-std-line-attr w)
    + +

    +          (window-foreground w)
    + +          (window-set-foreground w fg-color)
    + +          (window-background w)
    + +          (window-set-background w bg-color)
    + +

    +

    +

    Color

    +

    +The color of the foreground (things that are drawn, such as lines or +characters) is set by: +

    +          (window-set-color w rgb &optional background)
    + +          (window-set-color-rgb w r g b &optional background)
    + +

    + rgb is a list (red green blue) of 16-bit unsigned integers in +the range 0 to 65535. background is non- nil +to set the background color rather than the foreground color. +

    +          (window-reset-color w)
    + + window-reset-color resets a window's colors to the default values. +

    +Colors are a scarce resource; there is only a finite number of +available colors, such as 256 colors. If you only use a small, fixed set +of colors, the finite set of colors will not be a problem. However, +if you create a lot of colors that are used only briefly, it will be +necessary to release them after they are no longer needed. + window-set-color will leave the global variable *window-xcolor* +set to an integer value that denotes an X color; this value should be +saved and used as the argument to window-free-color to release +the color after it is no longer needed. +

    +          (window-free-color w &optional xcolor)
    + +

    + window-free-color frees either the last color used, as given by + *window-xcolor*, or the specified color. +

    +

    +

    Character Input

    texted +

    +Characters can be input within a window by the call: +

    +          (window-input-string w str x y &optional size)
    + +

    + window-input-string will print the initial string str, +if non- nil, +at the specified position in the window; str, if not modified +by the user, will also be the initial part of the result. A caret +is displayed showing the location of the next input character. +Characters are echoed as they are typed; backspacing erases characters, +including those from the initial string str. An area of width + size (default 100) is erased to the right of the initial caret. +

    +

    +

    Emacs-like Editing

    emacsed +

    + window-edit allows editing of text using an Emacs-subset editor. +Only a few simple Emacs commands are implemented. +

    +
+   (window-edit w x y width height optional strings boxflg scroll endp)
+
    + + x y width height specify the offset and size of the editing +area; it is a good idea to draw a box around this area first. + strings is an initial list of strings; the return value is a list +of strings. + scroll is number of lines to scroll down before displaying text, + or T to have one line only and terminate on return. + endp is T to begin editing at the end of the first line. +Example: +
    +
+  (window-draw-box-xy myw 48 48 204 204)
+  (window-edit myw 50 50 200 200 '("Now is the time" "for all" "good"))
+
    + +

    +

    +

    Mouse Interaction

    +

    +          (window-get-point w)
    + +          (window-get-crosshairs w)
    + +          (window-get-cross w)
    + +These functions get a point position by mouse click; they return (x y) . +

    +The following function gets a point position by mouse click. It returns + (button (x y)) where button is 1 for the left button, + 2 for middle, 3 for right. +

    +          (window-get-click w)
    + +

    +The following function gets a point position by mouse click within a specified +region. It returns (button (x y)) or NIL if the mouse leaves +the region. If boxflg is t, a box will be drawn outside the +region while the mouse is being tracked. +

    +          (window-track-mouse-in-region w x y sizex sizey &optional boxflg)
    + +

    +

    +The following functions get a point position indicated by drawing a line +from a specified origin position to the cursor position; they return + (x y) at the cursor position when a mouse button is clicked. +The latex version restricts the slope of the line to be a slope that + can draw; if flg is non- nil, the slope is restricted +to be a vector slope. +

    +          (window-get-line-position w orgx orgy)
    + +          (window-get-latex-position w orgx orgy flg)
    + +

    +The following function gets a position by moving a ``ghost'' icon, +defined by the icon drawing function fn. This allows exact positioning +of an object by the user. +

    +          (window-get-icon-position w fn args &optional (dx 0) + (dy 0))
    + +

    +

    + +The function fn has arguments (fn w x y . args) , where x +and y are the offset within the window w at which the icon is +to be drawn, and args is a list of arbitrary arguments, e.g., the size +of the icon, that are passed through to the drawing function. +The icon is drawn in xor mode, so it must be drawn using +only ``plain'' drawing functions, without resetting window attributes. +The returned value is (x y) at the cursor position when a button +is clicked. dx and dy, if specified, are offsets of x +and y from the cursor position. +

    +The following function gets a position by moving a ``ghost'' box icon. +

    +          (window-get-box-position w width height &optional (dx 0) (dy 0))
    + +

    +

    + +By default, the lower-left corner of the box is placed at the cursor position; + dx and dy may be used to offset the box from the cursor, e.g., +to move the box by a different corner. The returned value is (x y) +at the cursor position when a button is clicked. +

    +The following function gets coordinates of a box of arbitrary size and +position. +

    +          (window-get-region w)
    + +

    +

    + +The user first clicks for one corner of the box, moves the +mouse and clicks again for the opposite corner, then moves the box into +the desired position. The returned value is + ((x y) (width height)), +where (x y) is the lower-left corner of the box. +

    +The following function gets the size of a box by mouse selection, +echoing the size in pixels below the box. offsety +should be at least 30 to leave room to display the size of the box. +

    +          (window-get-box-size w offsetx offsety)
    + +

    +

    +The following function adjusts one side of a box. +

    +          (window-adjust-box-side w x y width height side)
    + +

    +

    + + side specifies the side of the box to be adjusted: left, + right, top, or bottom. The result is + ((x y) (width height)) for the resulting box. +

    +          (window-get-circle w &optional center:vector)
    + +          (window-get-ellipse w &optional center:vector)
    + +These functions interactively get a circle or ellipse. For an ellipse, +a circle is gotten first for the horizontal size; then the vertical +size of the ellipse is adjusted. + window-get-circle returns ((x y) radius). + window-get-ellipse returns ((x y) (xradius yradius)). +

    + + +

    + window-track-mouse is the basic function for following the mouse +and performing some action as it moves. This function is used in +the implementation of menus and the mouse-interaction functions described in +this section. +

    +          (window-track-mouse w fn &optional outflg) + +

    + +Each time the mouse position changes or a mouse button is pressed, +the function fn is called with +arguments (x y code) where x and y are the cursor +position, code is a button code ( 0 if no button, 1 for +the left button, 2 for the middle button, or 3 for the right +button). window-track-mouse continues to track the mouse until fn +returns a value other than nil, at which time window-track-mouse +returns that value. Usually, it is a good idea for fn to return a +value other than nil upon a mouse click. If the argument outflg +is non- nil, the function fn will be called for button clicks +outside the window w; note, however, that such clicks will not be +seen if the containing window intercepts them, so that this feature will +work only if the window w is inside another Lisp user window. +

    +

    +

    Miscellaneous Functions

    +

    +          (stringify x) makes its argument into a string. +

    +          (window-destroy-selected-window) waits 3 seconds, +then destroys the window containing the mouse cursor. This function +should be used with care; it can destroy a non-user window, causing +processes associated with the window to be destroyed. It is useful +primarily in debugging, to get rid of a window that is left on the screen +due to an error. + +

    +

    Examples

    +

    +Several interactive programs using this software for their graphical +interface can be found at http://www.cs.utexas.edu/users/novak/ +under the heading Software Demos. +

    +

    +

    Web Interface

    +

    +This software allows a Lisp program to be used interactively within +a web page. There are two approaches, either using an X server on +the computer of the person viewing the web page, or using WeirdX, a +Java program that emulates an X server. Details can be found at: + http://www.cs.utexas.edu/users/novak/dwindow.html +

    +

    +

    Files

    +

    + + + + + + + + + + + + + + + + + + + + +
    + dec.copyright Copyright and license for DEC/MIT files
    + draw.lsp GLISP source code for interactive drawing utility
    + drawtrans.lsp draw.lsp translated into plain Lisp
    + draw-gates.lsp Code to draw nand gates etc.
    + dwdoc.tex source for this document
    + dwexports.lsp exported symbols
    + dwimportsb.lsp imported symbols
    + dwindow.lsp GLISP source code for dwindow functions
    + dwtest.lsp Examples of use of dwindow functions
    + dwtrans.lsp dwindow.lsp translated into plain Lisp
    + editors.lsp Editors for colors etc.
    + editorstrans.lsp translation of editors.lsp
    + gnu.license GNU General Public License
    + ice-cream.lsp Drawing of an ice cream cone made with draw
    + lispserver.lsp Example web demo: a Lisp server
    + lispservertrans.lsp translation of lispserver.lsp
    + menu-set.lsp GLISP source code for menu-set functions
    + menu-settrans.lsp translation of menu-set.lsp
    + pcalc.lsp Pocket calculator implemented as a picmenu
    +
    + +

    +

    + +Contents    +Next    +Page+10    +Index    + diff --git a/xgcl-2/dwdoc/dwdoc2.html b/xgcl-2/dwdoc/dwdoc2.html new file mode 100644 index 0000000..3ce90ed --- /dev/null +++ b/xgcl-2/dwdoc/dwdoc2.html @@ -0,0 +1,117 @@ + dwdoc p. 2 + + +

    +

    Data Types

    +

    +

    +
+(window (listobject  (parent          drawable)
+                     (gcontext        anything)
+                     (drawable-height integer)
+                     (drawable-width  integer)
+                     (label           string)
+                     (font            anything) )
+
    + +

    +

    + +

    +

    +
+(menu (listobject (menu-window     window)
+                  (flat            boolean)
+                  (parent-window   drawable)
+                  (parent-offset-x integer)
+                  (parent-offset-y integer)
+                  (picture-width   integer)
+                  (picture-height  integer)
+                  (title           string)
+                  (permanent       boolean)
+                  (menu-font       symbol)
+                  (item-width      integer)
+                  (item-height     integer)
+                  (items           (listof symbol)) )
+
    + +

    +

    + +

    +

    +
+(picmenu (listobject (menu-window     window)
+                     (flat            boolean)
+                     (parent-window   drawable)
+                     (parent-offset-x integer)
+                     (parent-offset-y integer)
+                     (picture-width   integer)
+                     (picture-height  integer)
+                     (title           string)
+                     (permanent       boolean)
+                     (spec            (transparent picmenu-spec))
+                     (boxflg          boolean)
+                     (deleted-buttons (listof symbol)) )
+
    + +

    +

    + +

    +

    +
+(picmenu-spec (listobject (drawing-width   integer)
+                          (drawing-height  integer)
+                          (buttons         (listof picmenu-button))
+                          (dotflg          boolean)
+                          (drawfn          anything)
+                          (menu-font       symbol) ))
+
    + +

    +

    + +

    +

    +
+(picmenu-button (list (buttonname     symbol)
+                      (offset         vector)
+                      (size           vector)
+                      (highlightfn    anything)
+                      (unhighlightfn  anything))
+
    + +

    +

    + +

    +

    +
+(barmenu (listobject (menu-window     window)
+                     (flat            boolean)
+                     (parent-window   drawable)
+                     (parent-offset-x integer)
+                     (parent-offset-y integer)
+                     (picture-width   integer)
+                     (picture-height  integer)
+                     (title           string)
+                     (permanent       boolean)
+                     (color           rgb)
+                     (value           integer)
+                     (maxval          integer)
+                     (barwidth        integer)
+                     (horizontal      boolean)
+                     (subtrackfn      anything)
+                     (subtrackparms   (listof anything)))
+
    + +

    +

    + +Contents    +Prev    +Next    +Page+10    +Index    + diff --git a/xgcl-2/dwdoc/dwdoc3.html b/xgcl-2/dwdoc/dwdoc3.html new file mode 100644 index 0000000..cc061b8 --- /dev/null +++ b/xgcl-2/dwdoc/dwdoc3.html @@ -0,0 +1,44 @@ + dwdoc p. 3 + + +

    +

    Copyright

    +

    +The following copyright notice applies to the portions of the software +that were adapted from X Consortium software: +

    +
+;;**********************************************************
+;;Copyright 1987 by Digital Equipment Corporation, Maynard, Massachusetts,
+;;and the Massachusetts Institute of Technology, Cambridge, Massachusetts.
+
+;;                        All Rights Reserved
+
+;;Permission to use, copy, modify, and distribute this software and its 
+;;documentation for any purpose and without fee is hereby granted, 
+;;provided that the above copyright notice appear in all copies and that
+;;both that copyright notice and this permission notice appear in 
+;;supporting documentation, and that the names of Digital or MIT not be
+;;used in advertising or publicity pertaining to distribution of the
+;;software without specific, written prior permission.  
+
+;;DIGITAL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
+;;ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
+;;DIGITAL BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
+;;ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+;;WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
+;;ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
+;;SOFTWARE.
+
+;;*****************************************************************
+
+
    + +

    + +Contents    +Prev    +Next    +Page+10    +Index    + diff --git a/xgcl-2/dwdoc/dwdoccontents.html b/xgcl-2/dwdoc/dwdoccontents.html new file mode 100644 index 0000000..31d9ca3 --- /dev/null +++ b/xgcl-2/dwdoc/dwdoccontents.html @@ -0,0 +1 @@ +1. Interface from GCL to X Windows

    diff --git a/xgcl-2/dwdoc/dwdocindex.html b/xgcl-2/dwdoc/dwdocindex.html new file mode 100644 index 0000000..8b13789 --- /dev/null +++ b/xgcl-2/dwdoc/dwdocindex.html @@ -0,0 +1 @@ + diff --git a/xgcl-2/gcl_X.lsp b/xgcl-2/gcl_X.lsp new file mode 100644 index 0000000..ac7afd4 --- /dev/null +++ b/xgcl-2/gcl_X.lsp @@ -0,0 +1,689 @@ +(in-package :XLIB) +; X.lsp modified by Hiep Huu Nguyen 27 Aug 92 + +; Copyright (c) 1994 Hiep Huu Nguyen and The University of Texas at Austin. + +; See the files gnu.license and dec.copyright . + +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 1, or (at your option) +; any later version. + +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +; Some of the files that interface to the Xlib are adapted from DEC/MIT files. +; See the file dec.copyright for details. + +;; +;; $XConsortium: X.h,v 1.66 88/09/06 15:55:56 jim Exp $ + + +;; Definitions for the X window system likely to be used by applications + + +;;********************************************************** +;;Copyright 1987 by Digital Equipment Corporation, Maynard, Massachusetts, +;;and the Massachusetts Institute of Technology, Cambridge, Massachusetts. + +;;modified by Hiep H Nguyen 28 Jul 91 + +;; All Rights Reserved + +;;Permission to use, copy, modify, and distribute this software and its +;;documentation for any purpose and without fee is hereby granted, +;;provided that the above copyright notice appear in all copies and that +;;both that copyright notice and this permission notice appear in +;;supporting documentation, and that the names of Digital or MIT not be +;;used in advertising or publicity pertaining to distribution of the +;;software without specific, written prior permission. + +;;DIGITAL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING +;;ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL +;;DIGITAL BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR +;;ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, +;;WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, +;;ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS +;;SOFTWARE. + +;;***************************************************************** +(defconstant X_PROTOCOL 11 ) ;; current protocol version +(defconstant X_PROTOCOL_REVISION 0 ) ;; current minor version + +(defconstant True 1) +(defconstant False 0) + +;; Resources + +;;typedef unsigned long XID) ; + +;;typedef XID Window) ; +;;typedef XID Drawable) ; +;;typedef XID Font) ; +;;typedef XID Pixmap) ; +;;typedef XID Cursor) ; +;;typedef XID Colormap) ; +;;typedef XID GContext) ; +;;typedef XID KeySym) ; + +;;typedef unsigned long Mask) ; + +;;typedef unsigned long Atom) ; + +;;typedef unsigned long VisualID) ; + +;;typedef unsigned long Time) ; + +;;typedef unsigned char KeyCode) ; + +;;**************************************************************** +;; * RESERVED RESOURCE AND CONSTANT DEFINITIONS +;; **************************************************************** + +(defconstant None 0 ) ;; universal null resource or null atom + +(defconstant ParentRelative 1 ) ;; background pixmap in CreateWindow + ;;and ChangeWindowAttributes + +(defconstant CopyFromParent 0 ) ;; border pixmap in CreateWindow + ;;and ChangeWindowAttributes + ;;special VisualID and special window + ;; class passed to CreateWindow + +(defconstant PointerWindow 0 ) ;; destination window in SendEvent +(defconstant InputFocus 1 ) ;; destination window in SendEvent + +(defconstant PointerRoot 1 ) ;; focus window in SetInputFocus + +(defconstant AnyPropertyType 0 ) ;; special Atom, passed to GetProperty + +(defconstant AnyKey 0 ) ;; special Key Code, passed to GrabKey + +(defconstant AnyButton 0 ) ;; special Button Code, passed to GrabButton + +(defconstant AllTemporary 0 ) ;; special Resource ID passed to KillClient + +(defconstant CurrentTime 0 ) ;; special Time + +(defconstant NoSymbol 0 ) ;; special KeySym + +;;**************************************************************** +;; * EVENT DEFINITIONS +;; **************************************************************** + +;; Input Event Masks. Used as event-mask window attribute and as arguments +;; to Grab requests. Not to be confused with event names. + +(defconstant NoEventMask 0) +(defconstant KeyPressMask (expt 2 0) ) +(defconstant KeyReleaseMask (expt 2 1) ) +(defconstant ButtonPressMask (expt 2 2) ) +(defconstant ButtonReleaseMask (expt 2 3) ) +(defconstant EnterWindowMask (expt 2 4) ) +(defconstant LeaveWindowMask (expt 2 5) ) +(defconstant PointerMotionMask (expt 2 6) ) +(defconstant PointerMotionHintMask (expt 2 7) ) +(defconstant Button1MotionMask (expt 2 8) ) +(defconstant Button2MotionMask (expt 2 9) ) +(defconstant Button3MotionMask (expt 2 10) ) +(defconstant Button4MotionMask (expt 2 11) ) +(defconstant Button5MotionMask (expt 2 12) ) +(defconstant ButtonMotionMask (expt 2 13) ) +(defconstant KeymapStateMask (expt 2 14)) +(defconstant ExposureMask (expt 2 15) ) +(defconstant VisibilityChangeMask (expt 2 16) ) +(defconstant StructureNotifyMask (expt 2 17) ) +(defconstant ResizeRedirectMask (expt 2 18) ) +(defconstant SubstructureNotifyMask (expt 2 19) ) +(defconstant SubstructureRedirectMask (expt 2 20) ) +(defconstant FocusChangeMask (expt 2 21) ) +(defconstant PropertyChangeMask (expt 2 22) ) +(defconstant ColormapChangeMask (expt 2 23) ) +(defconstant OwnerGrabButtonMask (expt 2 24) ) + +;; Event names. Used in "type" field in XEvent structures. Not to be +;;confused with event masks above. They start from 2 because 0 and 1 +;;are reserved in the protocol for errors and replies. + +(defconstant KeyPress 2) +(defconstant KeyRelease 3) +(defconstant ButtonPress 4) +(defconstant ButtonRelease 5) +(defconstant MotionNotify 6) +(defconstant EnterNotify 7) +(defconstant LeaveNotify 8) +(defconstant FocusIn 9) +(defconstant FocusOut 10) +(defconstant KeymapNotify 11) +(defconstant Expose 12) +(defconstant GraphicsExpose 13) +(defconstant NoExpose 14) +(defconstant VisibilityNotify 15) +(defconstant CreateNotify 16) +(defconstant DestroyNotify 17) +(defconstant UnmapNotify 18) +(defconstant MapNotify 19) +(defconstant MapRequest 20) +(defconstant ReparentNotify 21) +(defconstant ConfigureNotify 22) +(defconstant ConfigureRequest 23) +(defconstant GravityNotify 24) +(defconstant ResizeRequest 25) +(defconstant CirculateNotify 26) +(defconstant CirculateRequest 27) +(defconstant PropertyNotify 28) +(defconstant SelectionClear 29) +(defconstant SelectionRequest 30) +(defconstant SelectionNotify 31) +(defconstant ColormapNotify 32) +(defconstant ClientMessage 33) +(defconstant MappingNotify 34) +(defconstant LASTEvent 35 ) ;; must be bigger than any event # + + +;; Key masks. Used as modifiers to GrabButton and GrabKey, results of QueryPointer, +;; state in various key-, mouse-, and button-related events. + +(defconstant ShiftMask (expt 2 0)) +(defconstant LockMask (expt 2 1)) +(defconstant ControlMask (expt 2 2)) +(defconstant Mod1Mask (expt 2 3)) +(defconstant Mod2Mask (expt 2 4)) +(defconstant Mod3Mask (expt 2 5)) +(defconstant Mod4Mask (expt 2 6)) +(defconstant Mod5Mask (expt 2 7)) + +;; modifier names. Used to build a SetModifierMapping request or +;; to read a GetModifierMapping request. These correspond to the +;; masks defined above. +(defconstant ShiftMapIndex 0) +(defconstant LockMapIndex 1) +(defconstant ControlMapIndex 2) +(defconstant Mod1MapIndex 3) +(defconstant Mod2MapIndex 4) +(defconstant Mod3MapIndex 5) +(defconstant Mod4MapIndex 6) +(defconstant Mod5MapIndex 7) + + +;; button masks. Used in same manner as Key masks above. Not to be confused +;; with button names below. + +(defconstant Button1Mask (expt 2 8)) +(defconstant Button2Mask (expt 2 9)) +(defconstant Button3Mask (expt 2 10)) +(defconstant Button4Mask (expt 2 11)) +(defconstant Button5Mask (expt 2 12)) + +(defconstant AnyModifier (expt 2 15) ) ;; used in GrabButton, GrabKey + + +;; button names. Used as arguments to GrabButton and as detail in ButtonPress +;; and ButtonRelease events. Not to be confused with button masks above. +;; Note that 0 is already defined above as "AnyButton". + +(defconstant Button1 1) +(defconstant Button2 2) +(defconstant Button3 3) +(defconstant Button4 4) +(defconstant Button5 5) + +;; Notify modes + +(defconstant NotifyNormal 0) +(defconstant NotifyGrab 1) +(defconstant NotifyUngrab 2) +(defconstant NotifyWhileGrabbed 3) + +(defconstant NotifyHint 1 ) ;; for MotionNotify events + +;; Notify detail + +(defconstant NotifyAncestor 0) +(defconstant NotifyVirtual 1) +(defconstant NotifyInferior 2) +(defconstant NotifyNonlinear 3) +(defconstant NotifyNonlinearVirtual 4) +(defconstant NotifyPointer 5) +(defconstant NotifyPointerRoot 6) +(defconstant NotifyDetailNone 7) + +;; Visibility notify + +(defconstant VisibilityUnobscured 0) +(defconstant VisibilityPartiallyObscured 1) +(defconstant VisibilityFullyObscured 2) + +;; Circulation request + +(defconstant PlaceOnTop 0) +(defconstant PlaceOnBottom 1) + +;; protocol families + +(defconstant FamilyInternet 0) +(defconstant FamilyDECnet 1) +(defconstant FamilyChaos 2) + +;; Property notification + +(defconstant PropertyNewValue 0) +(defconstant PropertyDelete 1) + +;; Color Map notification + +(defconstant ColormapUninstalled 0) +(defconstant ColormapInstalled 1) + +;; GrabPointer, GrabButton, GrabKeyboard, GrabKey Modes + +(defconstant GrabModeSync 0) +(defconstant GrabModeAsync 1) + +;; GrabPointer, GrabKeyboard reply status + +(defconstant GrabSuccess 0) +(defconstant AlreadyGrabbed 1) +(defconstant GrabInvalidTime 2) +(defconstant GrabNotViewable 3) +(defconstant GrabFrozen 4) + +;; AllowEvents modes + +(defconstant AsyncPointer 0) +(defconstant SyncPointer 1) +(defconstant ReplayPointer 2) +(defconstant AsyncKeyboard 3) +(defconstant SyncKeyboard 4) +(defconstant ReplayKeyboard 5) +(defconstant AsyncBoth 6) +(defconstant SyncBoth 7) + +;; Used in SetInputFocus, GetInputFocus + +(defconstant RevertToNone None) +(defconstant RevertToPointerRoot PointerRoot) +(defconstant RevertToParent 2) + +;;**************************************************************** +;; * ERROR CODES +;; **************************************************************** + +(defconstant Success 0 ) ;; everything's okay +(defconstant BadRequest 1 ) ;; bad request code +(defconstant BadValue 2 ) ;; int parameter out of range +(defconstant BadWindow 3 ) ;; parameter not a Window +(defconstant BadPixmap 4 ) ;; parameter not a Pixmap +(defconstant BadAtom 5 ) ;; parameter not an Atom +(defconstant BadCursor 6 ) ;; parameter not a Cursor +(defconstant BadFont 7 ) ;; parameter not a Font +(defconstant BadMatch 8 ) ;; parameter mismatch +(defconstant BadDrawable 9 ) ;; parameter not a Pixmap or Window +(defconstant BadAccess 10 ) ;; depending on context: + ;;- key/button already grabbed + ;;- attempt to free an illegal + ;; cmap entry + ;;- attempt to store into a read-only + ;; color map entry. + ;;- attempt to modify the access control + ;; list from other than the local host. + +(defconstant BadAlloc 11 ) ;; insufficient resources +(defconstant BadColor 12 ) ;; no such colormap +(defconstant BadGC 13 ) ;; parameter not a GC +(defconstant BadIDChoice 14 ) ;; choice not in range or already used +(defconstant BadName 15 ) ;; font or color name doesn't exist +(defconstant BadLength 16 ) ;; Request length incorrect +(defconstant BadImplementation 17 ) ;; server is defective + +(defconstant FirstExtensionError 128) +(defconstant LastExtensionError 255) + +;;**************************************************************** +;; * WINDOW DEFINITIONS +;; **************************************************************** + +;; Window classes used by CreateWindow +;; Note that CopyFromParent is already defined as 0 above + +(defconstant InputOutput 1) +(defconstant InputOnly 2) + +;; Window attributes for CreateWindow and ChangeWindowAttributes + +(defconstant CWBackPixmap (expt 2 0)) +(defconstant CWBackPixel (expt 2 1)) +(defconstant CWBorderPixmap (expt 2 2)) +(defconstant CWBorderPixel (expt 2 3)) +(defconstant CWBitGravity (expt 2 4)) +(defconstant CWWinGravity (expt 2 5)) +(defconstant CWBackingStore (expt 2 6)) +(defconstant CWBackingPlanes (expt 2 7)) +(defconstant CWBackingPixel (expt 2 8)) +(defconstant CWOverrideRedirect (expt 2 9)) +(defconstant CWSaveUnder (expt 2 10)) +(defconstant CWEventMask (expt 2 11)) +(defconstant CWDontPropagate (expt 2 12)) +(defconstant CWColormap (expt 2 13)) +(defconstant CWCursor (expt 2 14)) + +;; ConfigureWindow structure + +(defconstant CWX (expt 2 0)) +(defconstant CWY (expt 2 1)) +(defconstant CWWidth (expt 2 2)) +(defconstant CWHeight (expt 2 3)) +(defconstant CWBorderWidth (expt 2 4)) +(defconstant CWSibling (expt 2 5)) +(defconstant CWStackMode (expt 2 6)) + + +;; Bit Gravity + +(defconstant ForgetGravity 0) +(defconstant NorthWestGravity 1) +(defconstant NorthGravity 2) +(defconstant NorthEastGravity 3) +(defconstant WestGravity 4) +(defconstant CenterGravity 5) +(defconstant EastGravity 6) +(defconstant SouthWestGravity 7) +(defconstant SouthGravity 8) +(defconstant SouthEastGravity 9) +(defconstant StaticGravity 10) + +;; Window gravity + bit gravity above + +(defconstant UnmapGravity 0) + +;; Used in CreateWindow for backing-store hint + +(defconstant NotUseful 0) +(defconstant WhenMapped 1) +(defconstant Always 2) + +;; Used in GetWindowAttributes reply + +(defconstant IsUnmapped 0) +(defconstant IsUnviewable 1) +(defconstant IsViewable 2) + +;; Used in ChangeSaveSet + +(defconstant SetModeInsert 0) +(defconstant SetModeDelete 1) + +;; Used in ChangeCloseDownMode + +(defconstant DestroyAll 0) +(defconstant RetainPermanent 1) +(defconstant RetainTemporary 2) + +;; Window stacking method (in configureWindow) + +(defconstant Above 0) +(defconstant Below 1) +(defconstant TopIf 2) +(defconstant BottomIf 3) +(defconstant Opposite 4) + +;; Circulation direction + +(defconstant RaiseLowest 0) +(defconstant LowerHighest 1) + +;; Property modes + +(defconstant PropModeReplace 0) +(defconstant PropModePrepend 1) +(defconstant PropModeAppend 2) + +;;**************************************************************** +;; * GRAPHICS DEFINITIONS +;; **************************************************************** + +;; graphics functions, as in GC.alu + +(defconstant GXclear 0 ) ;; 0 +(defconstant GXand 1 ) ;; src AND dst +(defconstant GXandReverse 2 ) ;; src AND NOT dst +(defconstant GXcopy 3 ) ;; src +(defconstant GXandInverted 4 ) ;; NOT src AND dst +(defconstant GXnoop 5 ) ;; dst +(defconstant GXxor 6 ) ;; src XOR dst +(defconstant GXor 7 ) ;; src OR dst +(defconstant GXnor 8 ) ;; NOT src AND NOT dst +(defconstant GXequiv 9 ) ;; NOT src XOR dst +(defconstant GXinvert 10 ) ;; NOT dst +(defconstant GXorReverse 11 ) ;; src OR NOT dst +(defconstant GXcopyInverted 12 ) ;; NOT src +(defconstant GXorInverted 13 ) ;; NOT src OR dst +(defconstant GXnand 14 ) ;; NOT src OR NOT dst +(defconstant GXset 15 ) ;; 1 + +;; LineStyle + +(defconstant LineSolid 0) +(defconstant LineOnOffDash 1) +(defconstant LineDoubleDash 2) + +;; capStyle + +(defconstant CapNotLast 0) +(defconstant CapButt 1) +(defconstant CapRound 2) +(defconstant CapProjecting 3) + +;; joinStyle + +(defconstant JoinMiter 0) +(defconstant JoinRound 1) +(defconstant JoinBevel 2) + +;; fillStyle + +(defconstant FillSolid 0) +(defconstant FillTiled 1) +(defconstant FillStippled 2) +(defconstant FillOpaqueStippled 3) + +;; fillRule + +(defconstant EvenOddRule 0) +(defconstant WindingRule 1) + +;; subwindow mode + +(defconstant ClipByChildren 0) +(defconstant IncludeInferiors 1) + +;; SetClipRectangles ordering + +(defconstant Unsorted 0) +(defconstant YSorted 1) +(defconstant YXSorted 2) +(defconstant YXBanded 3) + +;; CoordinateMode for drawing routines + +(defconstant CoordModeOrigin 0 ) ;; relative to the origin +(defconstant CoordModePrevious 1 ) ;; relative to previous point + +;; Polygon shapes + +;(defconstant Complex 0 ) ;; paths may intersect +(defconstant Nonconvex 1 ) ;; no paths intersect, but not convex +(defconstant Convex 2 ) ;; wholly convex + +;; Arc modes for PolyFillArc + +(defconstant ArcChord 0 ) ;; join endpoints of arc +(defconstant ArcPieSlice 1 ) ;; join endpoints to center of arc + +;; GC components: masks used in CreateGC, CopyGC, ChangeGC, OR'ed into +;; GC.stateChanges + +(defconstant GCFunction (expt 2 0)) +(defconstant GCPlaneMask (expt 2 1)) +(defconstant GCForeground (expt 2 2)) +(defconstant GCBackground (expt 2 3)) +(defconstant GCLineWidth (expt 2 4)) +(defconstant GCLineStyle (expt 2 5)) +(defconstant GCCapStyle (expt 2 6)) +(defconstant GCJoinStyle (expt 2 7)) +(defconstant GCFillStyle (expt 2 8)) +(defconstant GCFillRule (expt 2 9) ) +(defconstant GCTile (expt 2 10)) +(defconstant GCStipple (expt 2 11)) +(defconstant GCTileStipXOrigin (expt 2 12)) +(defconstant GCTileStipYOrigin (expt 2 13)) +(defconstant GCFont (expt 2 14)) +(defconstant GCSubwindowMode (expt 2 15)) +(defconstant GCGraphicsExposures (expt 2 16)) +(defconstant GCClipXOrigin (expt 2 17)) +(defconstant GCClipYOrigin (expt 2 18)) +(defconstant GCClipMask (expt 2 19)) +(defconstant GCDashOffset (expt 2 20)) +(defconstant GCDashList (expt 2 21)) +(defconstant GCArcMode (expt 2 22)) + +(defconstant GCLastBit 22) +;;**************************************************************** +;; * FONTS +;; **************************************************************** + +;; used in QueryFont -- draw direction + +(defconstant FontLeftToRight 0) +(defconstant FontRightToLeft 1) + +(defconstant FontChange 255) + +;;**************************************************************** +;; * IMAGING +;; **************************************************************** + +;; ImageFormat -- PutImage, GetImage + +(defconstant XYBitmap 0 ) ;; depth 1, XYFormat +(defconstant XYPixmap 1 ) ;; depth == drawable depth +(defconstant ZPixmap 2 ) ;; depth == drawable depth + +;;**************************************************************** +;; * COLOR MAP STUFF +;; **************************************************************** + +;; For CreateColormap + +(defconstant AllocNone 0 ) ;; create map with no entries +(defconstant AllocAll 1 ) ;; allocate entire map writeable + + +;; Flags used in StoreNamedColor, StoreColors + +(defconstant DoRed (expt 2 0)) +(defconstant DoGreen (expt 2 1)) +(defconstant DoBlue (expt 2 2)) + +;;**************************************************************** +;; * CURSOR STUFF +;; **************************************************************** + +;; QueryBestSize Class + +(defconstant CursorShape 0 ) ;; largest size that can be displayed +(defconstant TileShape 1 ) ;; size tiled fastest +(defconstant StippleShape 2 ) ;; size stippled fastest + +;;**************************************************************** +;; * KEYBOARD/POINTER STUFF +;; **************************************************************** + +(defconstant AutoRepeatModeOff 0) +(defconstant AutoRepeatModeOn 1) +(defconstant AutoRepeatModeDefault 2) + +(defconstant LedModeOff 0) +(defconstant LedModeOn 1) + +;; masks for ChangeKeyboardControl + +(defconstant KBKeyClickPercent (expt 2 0)) +(defconstant KBBellPercent (expt 2 1)) +(defconstant KBBellPitch (expt 2 2)) +(defconstant KBBellDuration (expt 2 3)) +(defconstant KBLed (expt 2 4)) +(defconstant KBLedMode (expt 2 5)) +(defconstant KBKey (expt 2 6)) +(defconstant KBAutoRepeatMode (expt 2 7)) + +(defconstant MappingSuccess 0) +(defconstant MappingBusy 1) +(defconstant MappingFailed 2) + +(defconstant MappingModifier 0) +(defconstant MappingKeyboard 1) +(defconstant MappingPointer 2) + +;;**************************************************************** +;; * SCREEN SAVER STUFF +;; **************************************************************** + +(defconstant DontPreferBlanking 0) +(defconstant PreferBlanking 1) +(defconstant DefaultBlanking 2) + +(defconstant DisableScreenSaver 0) +(defconstant DisableScreenInterval 0) + +(defconstant DontAllowExposures 0) +(defconstant AllowExposures 1) +(defconstant DefaultExposures 2) + +;; for ForceScreenSaver + +(defconstant ScreenSaverReset 0) +(defconstant ScreenSaverActive 1) + +;;**************************************************************** +;; * HOSTS AND CONNECTIONS +;; **************************************************************** + +;; for ChangeHosts + +(defconstant HostInsert 0) +(defconstant HostDelete 1) + +;; for ChangeAccessControl + +(defconstant EnableAccess 1 ) +(defconstant DisableAccess 0) + +;; Display classes used in opening the connection +;; * Note that the statically allocated ones are even numbered and the +;; * dynamically changeable ones are odd numbered + +(defconstant StaticGray 0) +(defconstant GrayScale 1) +(defconstant StaticColor 2) +(defconstant PseudoColor 3) +(defconstant TrueColor 4) +(defconstant DirectColor 5) + + +;; Byte order used in imageByteOrder and bitmapBitOrder + +(defconstant LSBFirst 0) +(defconstant MSBFirst 1) + + +;(defconstant NULL 0) + + diff --git a/xgcl-2/gcl_X10.lsp b/xgcl-2/gcl_X10.lsp new file mode 100644 index 0000000..db54ff6 --- /dev/null +++ b/xgcl-2/gcl_X10.lsp @@ -0,0 +1,30 @@ +(in-package :XLIB) +; X10.lsp modified by Hiep Huu Nguyen 27 Aug 92 + +; Copyright (c) 1994 Hiep Huu Nguyen and The University of Texas at Austin. + +; See the files gnu.license and dec.copyright . + +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 1, or (at your option) +; any later version. + +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +; Some of the files that interface to the Xlib are adapted from DEC/MIT files. +; See the file dec.copyright for details. + + +(defconstant VertexRelative #x01 ) ;; else absolute +(defconstant VertexDontDraw #x02 ) ;; else draw +(defconstant VertexCurved #x04 ) ;; else straight +(defconstant VertexStartClosed #x08 ) ;; else not +(defconstant VertexEndClosed #x10 ) ;; else not diff --git a/xgcl-2/gcl_XAtom.lsp b/xgcl-2/gcl_XAtom.lsp new file mode 100644 index 0000000..f1ca003 --- /dev/null +++ b/xgcl-2/gcl_XAtom.lsp @@ -0,0 +1,118 @@ +(in-package :XLIB) +; XAtom.lsp modified by Hiep Huu Nguyen 27 Aug 92 + +; Copyright (c) 1994 Hiep Huu Nguyen and The University of Texas at Austin. + +; See the files gnu.license and dec.copyright . + +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 1, or (at your option) +; any later version. + +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +; Some of the files that interface to the Xlib are adapted from DEC/MIT files. +; See the file dec.copyright for details. + + + +;; THIS IS A GENERATED FILE + ;; + ;; Do not change! Changing this file implies a protocol change! + + +(defconstant XA_PRIMARY 1) +(defconstant XA_SECONDARY 2) +(defconstant XA_ARC 3) +(defconstant XA_ATOM 4) +(defconstant XA_BITMAP 5) +(defconstant XA_CARDINAL 6) +(defconstant XA_COLORMAP 7) +(defconstant XA_CURSOR 8) +(defconstant XA_CUT_BUFFER0 9) +(defconstant XA_CUT_BUFFER1 10) +(defconstant XA_CUT_BUFFER2 11) +(defconstant XA_CUT_BUFFER3 12) +(defconstant XA_CUT_BUFFER4 13) +(defconstant XA_CUT_BUFFER5 14) +(defconstant XA_CUT_BUFFER6 15) +(defconstant XA_CUT_BUFFER7 16) +(defconstant XA_DRAWABLE 17) +(defconstant XA_FONT 18) +(defconstant XA_INTEGER 19) +(defconstant XA_PIXMAP 20) +(defconstant XA_POINT 21) +(defconstant XA_RECTANGLE 22) +(defconstant XA_RESOURCE_MANAGER 23) +(defconstant XA_RGB_COLOR_MAP 24) +(defconstant XA_RGB_BEST_MAP 25) +(defconstant XA_RGB_BLUE_MAP 26) +(defconstant XA_RGB_DEFAULT_MAP 27) +(defconstant XA_RGB_GRAY_MAP 28) +(defconstant XA_RGB_GREEN_MAP 29) +(defconstant XA_RGB_RED_MAP 30) +(defconstant XA_STRING 31) +(defconstant XA_VISUALID 32) +(defconstant XA_WINDOW 33) +(defconstant XA_WM_COMMAND 34) +(defconstant XA_WM_HINTS 35) +(defconstant XA_WM_CLIENT_MACHINE 36) +(defconstant XA_WM_ICON_NAME 37) +(defconstant XA_WM_ICON_SIZE 38) +(defconstant XA_WM_NAME 39) +(defconstant XA_WM_NORMAL_HINTS 40) +(defconstant XA_WM_SIZE_HINTS 41) +(defconstant XA_WM_ZOOM_HINTS 42) +(defconstant XA_MIN_SPACE 43) +(defconstant XA_NORM_SPACE 44) +(defconstant XA_MAX_SPACE 45) + + + + + + + + + + + + + + + + +(defconstant XA_END_SPACE 46) +(defconstant XA_SUPERSCRIPT_X 47) +(defconstant XA_SUPERSCRIPT_Y 48) +(defconstant XA_SUBSCRIPT_X 49) +(defconstant XA_SUBSCRIPT_Y 50) +(defconstant XA_UNDERLINE_POSITION 51) +(defconstant XA_UNDERLINE_THICKNESS 52) +(defconstant XA_STRIKEOUT_ASCENT 53) +(defconstant XA_STRIKEOUT_DESCENT 54) +(defconstant XA_ITALIC_ANGLE 55) +(defconstant XA_X_HEIGHT 56) +(defconstant XA_QUAD_WIDTH 57) +(defconstant XA_WEIGHT 58) +(defconstant XA_POINT_SIZE 59) +(defconstant XA_RESOLUTION 60) +(defconstant XA_COPYRIGHT 61) +(defconstant XA_NOTICE 62) +(defconstant XA_FONT_NAME 63) +(defconstant XA_FAMILY_NAME 64) +(defconstant XA_FULL_NAME 65) +(defconstant XA_CAP_HEIGHT 66) +(defconstant XA_WM_CLASS 67) +(defconstant XA_WM_TRANSIENT_FOR 68) + +(defconstant XA_LAST_PREDEFINED 68) + diff --git a/xgcl-2/gcl_XStruct_l_3.lsp b/xgcl-2/gcl_XStruct_l_3.lsp new file mode 100644 index 0000000..e8eebf7 --- /dev/null +++ b/xgcl-2/gcl_XStruct_l_3.lsp @@ -0,0 +1,491 @@ +(in-package :XLIB) +; XStruct-l-3.lsp modified by Hiep Huu Nguyen 27 Aug 92 + +; Copyright (c) 1994 Hiep Huu Nguyen and The University of Texas at Austin. + +; See the files gnu.license and dec.copyright . + +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 1, or (at your option) +; any later version. + +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +; Some of the files that interface to the Xlib are adapted from DEC/MIT files. +; See the file dec.copyright for details. + + + + +;;;;;; XExtCodes funcions ;;;;;; + +(defentry make-XExtCodes () ( fixnum "make_XExtCodes" )) +(defentry XExtCodes-first_error (fixnum) ( fixnum "XExtCodes_first_error" )) +(defentry set-XExtCodes-first_error (fixnum fixnum) ( void "set_XExtCodes_first_error" )) +(defentry XExtCodes-first_event (fixnum) ( fixnum "XExtCodes_first_event" )) +(defentry set-XExtCodes-first_event (fixnum fixnum) ( void "set_XExtCodes_first_event" )) +(defentry XExtCodes-major_opcode (fixnum) ( fixnum "XExtCodes_major_opcode" )) +(defentry set-XExtCodes-major_opcode (fixnum fixnum) ( void "set_XExtCodes_major_opcode" )) +(defentry XExtCodes-extension (fixnum) ( fixnum "XExtCodes_extension" )) +(defentry set-XExtCodes-extension (fixnum fixnum) ( void "set_XExtCodes_extension" )) + + +;;;;;; XPixmapFormatValues funcions ;;;;;; + +(defentry make-XPixmapFormatValues () ( fixnum "make_XPixmapFormatValues" )) +(defentry XPixmapFormatValues-scanline_pad (fixnum) ( fixnum "XPixmapFormatValues_scanline_pad" )) +(defentry set-XPixmapFormatValues-scanline_pad (fixnum fixnum) ( void "set_XPixmapFormatValues_scanline_pad" )) +(defentry XPixmapFormatValues-bits_per_pixel (fixnum) ( fixnum "XPixmapFormatValues_bits_per_pixel" )) +(defentry set-XPixmapFormatValues-bits_per_pixel (fixnum fixnum) ( void "set_XPixmapFormatValues_bits_per_pixel" )) +(defentry XPixmapFormatValues-depth (fixnum) ( fixnum "XPixmapFormatValues_depth" )) +(defentry set-XPixmapFormatValues-depth (fixnum fixnum) ( void "set_XPixmapFormatValues_depth" )) + + +;;;;;; XGCValues funcions ;;;;;; + +(defentry make-XGCValues () ( fixnum "make_XGCValues" )) +(defentry XGCValues-dashes (fixnum) ( char "XGCValues_dashes" )) +(defentry set-XGCValues-dashes (fixnum char) ( void "set_XGCValues_dashes" )) +(defentry XGCValues-dash_offset (fixnum) ( fixnum "XGCValues_dash_offset" )) +(defentry set-XGCValues-dash_offset (fixnum fixnum) ( void "set_XGCValues_dash_offset" )) +(defentry XGCValues-clip_mask (fixnum) ( fixnum "XGCValues_clip_mask" )) +(defentry set-XGCValues-clip_mask (fixnum fixnum) ( void "set_XGCValues_clip_mask" )) +(defentry XGCValues-clip_y_origin (fixnum) ( fixnum "XGCValues_clip_y_origin" )) +(defentry set-XGCValues-clip_y_origin (fixnum fixnum) ( void "set_XGCValues_clip_y_origin" )) +(defentry XGCValues-clip_x_origin (fixnum) ( fixnum "XGCValues_clip_x_origin" )) +(defentry set-XGCValues-clip_x_origin (fixnum fixnum) ( void "set_XGCValues_clip_x_origin" )) +(defentry XGCValues-graphics_exposures (fixnum) ( fixnum "XGCValues_graphics_exposures" )) +(defentry set-XGCValues-graphics_exposures (fixnum fixnum) ( void "set_XGCValues_graphics_exposures" )) +(defentry XGCValues-subwindow_mode (fixnum) ( fixnum "XGCValues_subwindow_mode" )) +(defentry set-XGCValues-subwindow_mode (fixnum fixnum) ( void "set_XGCValues_subwindow_mode" )) +(defentry XGCValues-font (fixnum) ( fixnum "XGCValues_font" )) +(defentry set-XGCValues-font (fixnum fixnum) ( void "set_XGCValues_font" )) +(defentry XGCValues-ts_y_origin (fixnum) ( fixnum "XGCValues_ts_y_origin" )) +(defentry set-XGCValues-ts_y_origin (fixnum fixnum) ( void "set_XGCValues_ts_y_origin" )) +(defentry XGCValues-ts_x_origin (fixnum) ( fixnum "XGCValues_ts_x_origin" )) +(defentry set-XGCValues-ts_x_origin (fixnum fixnum) ( void "set_XGCValues_ts_x_origin" )) +(defentry XGCValues-stipple (fixnum) ( fixnum "XGCValues_stipple" )) +(defentry set-XGCValues-stipple (fixnum fixnum) ( void "set_XGCValues_stipple" )) +(defentry XGCValues-tile (fixnum) ( fixnum "XGCValues_tile" )) +(defentry set-XGCValues-tile (fixnum fixnum) ( void "set_XGCValues_tile" )) +(defentry XGCValues-arc_mode (fixnum) ( fixnum "XGCValues_arc_mode" )) +(defentry set-XGCValues-arc_mode (fixnum fixnum) ( void "set_XGCValues_arc_mode" )) +(defentry XGCValues-fill_rule (fixnum) ( fixnum "XGCValues_fill_rule" )) +(defentry set-XGCValues-fill_rule (fixnum fixnum) ( void "set_XGCValues_fill_rule" )) +(defentry XGCValues-fill_style (fixnum) ( fixnum "XGCValues_fill_style" )) +(defentry set-XGCValues-fill_style (fixnum fixnum) ( void "set_XGCValues_fill_style" )) +(defentry XGCValues-join_style (fixnum) ( fixnum "XGCValues_join_style" )) +(defentry set-XGCValues-join_style (fixnum fixnum) ( void "set_XGCValues_join_style" )) +(defentry XGCValues-cap_style (fixnum) ( fixnum "XGCValues_cap_style" )) +(defentry set-XGCValues-cap_style (fixnum fixnum) ( void "set_XGCValues_cap_style" )) +(defentry XGCValues-line_style (fixnum) ( fixnum "XGCValues_line_style" )) +(defentry set-XGCValues-line_style (fixnum fixnum) ( void "set_XGCValues_line_style" )) +(defentry XGCValues-line_width (fixnum) ( fixnum "XGCValues_line_width" )) +(defentry set-XGCValues-line_width (fixnum fixnum) ( void "set_XGCValues_line_width" )) +(defentry XGCValues-background (fixnum) ( fixnum "XGCValues_background" )) +(defentry set-XGCValues-background (fixnum fixnum) ( void "set_XGCValues_background" )) +(defentry XGCValues-foreground (fixnum) ( fixnum "XGCValues_foreground" )) +(defentry set-XGCValues-foreground (fixnum fixnum) ( void "set_XGCValues_foreground" )) +(defentry XGCValues-plane_mask (fixnum) ( fixnum "XGCValues_plane_mask" )) +(defentry set-XGCValues-plane_mask (fixnum fixnum) ( void "set_XGCValues_plane_mask" )) +(defentry XGCValues-function (fixnum) ( fixnum "XGCValues_function" )) +(defentry set-XGCValues-function (fixnum fixnum) ( void "set_XGCValues_function" )) + + +;;;;;; *GC funcions ;;;;;; + +;;(defentry make-*GC () ( fixnum "make_*GC" )) +;;(defentry *GC-values (fixnum) ( fixnum "*GC_values" )) +;;(defentry set-*GC-values (fixnum fixnum) ( void "set_*GC_values" )) +;;(defentry *GC-dirty (fixnum) ( fixnum "*GC_dirty" )) +;;(defentry set-*GC-dirty (fixnum fixnum) ( void "set_*GC_dirty" )) +;;(defentry *GC-dashes (fixnum) ( fixnum "*GC_dashes" )) +;;(defentry set-*GC-dashes (fixnum fixnum) ( void "set_*GC_dashes" )) +;;(defentry *GC-rects (fixnum) ( fixnum "*GC_rects" )) +;;(defentry set-*GC-rects (fixnum fixnum) ( void "set_*GC_rects" )) +;;(defentry *GC-gid (fixnum) ( fixnum "*GC_gid" )) +;;(defentry set-*GC-gid (fixnum fixnum) ( void "set_*GC_gid" )) +;;(defentry *GC-ext_data (fixnum) ( fixnum "*GC_ext_data" )) +;;(defentry set-*GC-ext_data (fixnum fixnum) ( void "set_*GC_ext_data" )) + + +;;;;;; Visual funcions ;;;;;; + +(defentry make-Visual () ( fixnum "make_Visual" )) +(defentry Visual-map_entries (fixnum) ( fixnum "Visual_map_entries" )) +(defentry set-Visual-map_entries (fixnum fixnum) ( void "set_Visual_map_entries" )) +(defentry Visual-bits_per_rgb (fixnum) ( fixnum "Visual_bits_per_rgb" )) +(defentry set-Visual-bits_per_rgb (fixnum fixnum) ( void "set_Visual_bits_per_rgb" )) +(defentry Visual-blue_mask (fixnum) ( fixnum "Visual_blue_mask" )) +(defentry set-Visual-blue_mask (fixnum fixnum) ( void "set_Visual_blue_mask" )) +(defentry Visual-green_mask (fixnum) ( fixnum "Visual_green_mask" )) +(defentry set-Visual-green_mask (fixnum fixnum) ( void "set_Visual_green_mask" )) +(defentry Visual-red_mask (fixnum) ( fixnum "Visual_red_mask" )) +(defentry set-Visual-red_mask (fixnum fixnum) ( void "set_Visual_red_mask" )) +(defentry Visual-class (fixnum) ( fixnum "Visual_class" )) +(defentry set-Visual-class (fixnum fixnum) ( void "set_Visual_class" )) +(defentry Visual-visualid (fixnum) ( fixnum "Visual_visualid" )) +(defentry set-Visual-visualid (fixnum fixnum) ( void "set_Visual_visualid" )) +(defentry Visual-ext_data (fixnum) ( fixnum "Visual_ext_data" )) +(defentry set-Visual-ext_data (fixnum fixnum) ( void "set_Visual_ext_data" )) + + +;;;;;; Depth funcions ;;;;;; + +(defentry make-Depth () ( fixnum "make_Depth" )) +(defentry Depth-visuals (fixnum) ( fixnum "Depth_visuals" )) +(defentry set-Depth-visuals (fixnum fixnum) ( void "set_Depth_visuals" )) +(defentry Depth-nvisuals (fixnum) ( fixnum "Depth_nvisuals" )) +(defentry set-Depth-nvisuals (fixnum fixnum) ( void "set_Depth_nvisuals" )) +(defentry Depth-depth (fixnum) ( fixnum "Depth_depth" )) +(defentry set-Depth-depth (fixnum fixnum) ( void "set_Depth_depth" )) + + +;;;;;; Screen funcions ;;;;;; + +(defentry make-Screen () ( fixnum "make_Screen" )) +(defentry Screen-root_input_mask (fixnum) ( fixnum "Screen_root_input_mask" )) +(defentry set-Screen-root_input_mask (fixnum fixnum) ( void "set_Screen_root_input_mask" )) +(defentry Screen-save_unders (fixnum) ( fixnum "Screen_save_unders" )) +(defentry set-Screen-save_unders (fixnum fixnum) ( void "set_Screen_save_unders" )) +(defentry Screen-backing_store (fixnum) ( fixnum "Screen_backing_store" )) +(defentry set-Screen-backing_store (fixnum fixnum) ( void "set_Screen_backing_store" )) +(defentry Screen-min_maps (fixnum) ( fixnum "Screen_min_maps" )) +(defentry set-Screen-min_maps (fixnum fixnum) ( void "set_Screen_min_maps" )) +(defentry Screen-max_maps (fixnum) ( fixnum "Screen_max_maps" )) +(defentry set-Screen-max_maps (fixnum fixnum) ( void "set_Screen_max_maps" )) +(defentry Screen-black_pixel (fixnum) ( fixnum "Screen_black_pixel" )) +(defentry set-Screen-black_pixel (fixnum fixnum) ( void "set_Screen_black_pixel" )) +(defentry Screen-white_pixel (fixnum) ( fixnum "Screen_white_pixel" )) +(defentry set-Screen-white_pixel (fixnum fixnum) ( void "set_Screen_white_pixel" )) +(defentry Screen-cmap (fixnum) ( fixnum "Screen_cmap" )) +(defentry set-Screen-cmap (fixnum fixnum) ( void "set_Screen_cmap" )) +(defentry Screen-default_gc (fixnum) ( fixnum "Screen_default_gc" )) +(defentry set-Screen-default_gc (fixnum fixnum) ( void "set_Screen_default_gc" )) +(defentry Screen-root_visual (fixnum) ( fixnum "Screen_root_visual" )) +(defentry set-Screen-root_visual (fixnum fixnum) ( void "set_Screen_root_visual" )) +(defentry Screen-root_depth (fixnum) ( fixnum "Screen_root_depth" )) +(defentry set-Screen-root_depth (fixnum fixnum) ( void "set_Screen_root_depth" )) +(defentry Screen-depths (fixnum) ( fixnum "Screen_depths" )) +(defentry set-Screen-depths (fixnum fixnum) ( void "set_Screen_depths" )) +(defentry Screen-ndepths (fixnum) ( fixnum "Screen_ndepths" )) +(defentry set-Screen-ndepths (fixnum fixnum) ( void "set_Screen_ndepths" )) +(defentry Screen-mheight (fixnum) ( fixnum "Screen_mheight" )) +(defentry set-Screen-mheight (fixnum fixnum) ( void "set_Screen_mheight" )) +(defentry Screen-mwidth (fixnum) ( fixnum "Screen_mwidth" )) +(defentry set-Screen-mwidth (fixnum fixnum) ( void "set_Screen_mwidth" )) +(defentry Screen-height (fixnum) ( fixnum "Screen_height" )) +(defentry set-Screen-height (fixnum fixnum) ( void "set_Screen_height" )) +(defentry Screen-width (fixnum) ( fixnum "Screen_width" )) +(defentry set-Screen-width (fixnum fixnum) ( void "set_Screen_width" )) +(defentry Screen-root (fixnum) ( fixnum "Screen_root" )) +(defentry set-Screen-root (fixnum fixnum) ( void "set_Screen_root" )) +(defentry Screen-display (fixnum) ( fixnum "Screen_display" )) +(defentry set-Screen-display (fixnum fixnum) ( void "set_Screen_display" )) +(defentry Screen-ext_data (fixnum) ( fixnum "Screen_ext_data" )) +(defentry set-Screen-ext_data (fixnum fixnum) ( void "set_Screen_ext_data" )) + + +;;;;;; ScreenFormat funcions ;;;;;; + +(defentry make-ScreenFormat () ( fixnum "make_ScreenFormat" )) +(defentry ScreenFormat-scanline_pad (fixnum) ( fixnum "ScreenFormat_scanline_pad" )) +(defentry set-ScreenFormat-scanline_pad (fixnum fixnum) ( void "set_ScreenFormat_scanline_pad" )) +(defentry ScreenFormat-bits_per_pixel (fixnum) ( fixnum "ScreenFormat_bits_per_pixel" )) +(defentry set-ScreenFormat-bits_per_pixel (fixnum fixnum) ( void "set_ScreenFormat_bits_per_pixel" )) +(defentry ScreenFormat-depth (fixnum) ( fixnum "ScreenFormat_depth" )) +(defentry set-ScreenFormat-depth (fixnum fixnum) ( void "set_ScreenFormat_depth" )) +(defentry ScreenFormat-ext_data (fixnum) ( fixnum "ScreenFormat_ext_data" )) +(defentry set-ScreenFormat-ext_data (fixnum fixnum) ( void "set_ScreenFormat_ext_data" )) + + +;;;;;; XSetWindowAttributes funcions ;;;;;; + +(defentry make-XSetWindowAttributes () ( fixnum "make_XSetWindowAttributes" )) +(defentry XSetWindowAttributes-cursor (fixnum) ( fixnum "XSetWindowAttributes_cursor" )) +(defentry set-XSetWindowAttributes-cursor (fixnum fixnum) ( void "set_XSetWindowAttributes_cursor" )) +(defentry XSetWindowAttributes-colormap (fixnum) ( fixnum "XSetWindowAttributes_colormap" )) +(defentry set-XSetWindowAttributes-colormap (fixnum fixnum) ( void "set_XSetWindowAttributes_colormap" )) +(defentry XSetWindowAttributes-override_redirect (fixnum) ( fixnum "XSetWindowAttributes_override_redirect" )) +(defentry set-XSetWindowAttributes-override_redirect (fixnum fixnum) ( void "set_XSetWindowAttributes_override_redirect" )) +(defentry XSetWindowAttributes-do_not_propagate_mask (fixnum) ( fixnum "XSetWindowAttributes_do_not_propagate_mask" )) +(defentry set-XSetWindowAttributes-do_not_propagate_mask (fixnum fixnum) ( void "set_XSetWindowAttributes_do_not_propagate_mask" )) +(defentry XSetWindowAttributes-event_mask (fixnum) ( fixnum "XSetWindowAttributes_event_mask" )) +(defentry set-XSetWindowAttributes-event_mask (fixnum fixnum) ( void "set_XSetWindowAttributes_event_mask" )) +(defentry XSetWindowAttributes-save_under (fixnum) ( fixnum "XSetWindowAttributes_save_under" )) +(defentry set-XSetWindowAttributes-save_under (fixnum fixnum) ( void "set_XSetWindowAttributes_save_under" )) +(defentry XSetWindowAttributes-backing_pixel (fixnum) ( fixnum "XSetWindowAttributes_backing_pixel" )) +(defentry set-XSetWindowAttributes-backing_pixel (fixnum fixnum) ( void "set_XSetWindowAttributes_backing_pixel" )) +(defentry XSetWindowAttributes-backing_planes (fixnum) ( fixnum "XSetWindowAttributes_backing_planes" )) +(defentry set-XSetWindowAttributes-backing_planes (fixnum fixnum) ( void "set_XSetWindowAttributes_backing_planes" )) +(defentry XSetWindowAttributes-backing_store (fixnum) ( fixnum "XSetWindowAttributes_backing_store" )) +(defentry set-XSetWindowAttributes-backing_store (fixnum fixnum) ( void "set_XSetWindowAttributes_backing_store" )) +(defentry XSetWindowAttributes-win_gravity (fixnum) ( fixnum "XSetWindowAttributes_win_gravity" )) +(defentry set-XSetWindowAttributes-win_gravity (fixnum fixnum) ( void "set_XSetWindowAttributes_win_gravity" )) +(defentry XSetWindowAttributes-bit_gravity (fixnum) ( fixnum "XSetWindowAttributes_bit_gravity" )) +(defentry set-XSetWindowAttributes-bit_gravity (fixnum fixnum) ( void "set_XSetWindowAttributes_bit_gravity" )) +(defentry XSetWindowAttributes-border_pixel (fixnum) ( fixnum "XSetWindowAttributes_border_pixel" )) +(defentry set-XSetWindowAttributes-border_pixel (fixnum fixnum) ( void "set_XSetWindowAttributes_border_pixel" )) +(defentry XSetWindowAttributes-border_pixmap (fixnum) ( fixnum "XSetWindowAttributes_border_pixmap" )) +(defentry set-XSetWindowAttributes-border_pixmap (fixnum fixnum) ( void "set_XSetWindowAttributes_border_pixmap" )) +(defentry XSetWindowAttributes-background_pixel (fixnum) ( fixnum "XSetWindowAttributes_background_pixel" )) +(defentry set-XSetWindowAttributes-background_pixel (fixnum fixnum) ( void "set_XSetWindowAttributes_background_pixel" )) +(defentry XSetWindowAttributes-background_pixmap (fixnum) ( fixnum "XSetWindowAttributes_background_pixmap" )) +(defentry set-XSetWindowAttributes-background_pixmap (fixnum fixnum) ( void "set_XSetWindowAttributes_background_pixmap" )) + + +;;;;;; XWindowAttributes funcions ;;;;;; + +(defentry make-XWindowAttributes () ( fixnum "make_XWindowAttributes" )) +(defentry XWindowAttributes-screen (fixnum) ( fixnum "XWindowAttributes_screen" )) +(defentry set-XWindowAttributes-screen (fixnum fixnum) ( void "set_XWindowAttributes_screen" )) +(defentry XWindowAttributes-override_redirect (fixnum) ( fixnum "XWindowAttributes_override_redirect" )) +(defentry set-XWindowAttributes-override_redirect (fixnum fixnum) ( void "set_XWindowAttributes_override_redirect" )) +(defentry XWindowAttributes-do_not_propagate_mask (fixnum) ( fixnum "XWindowAttributes_do_not_propagate_mask" )) +(defentry set-XWindowAttributes-do_not_propagate_mask (fixnum fixnum) ( void "set_XWindowAttributes_do_not_propagate_mask" )) +(defentry XWindowAttributes-your_event_mask (fixnum) ( fixnum "XWindowAttributes_your_event_mask" )) +(defentry set-XWindowAttributes-your_event_mask (fixnum fixnum) ( void "set_XWindowAttributes_your_event_mask" )) +(defentry XWindowAttributes-all_event_masks (fixnum) ( fixnum "XWindowAttributes_all_event_masks" )) +(defentry set-XWindowAttributes-all_event_masks (fixnum fixnum) ( void "set_XWindowAttributes_all_event_masks" )) +(defentry XWindowAttributes-map_state (fixnum) ( fixnum "XWindowAttributes_map_state" )) +(defentry set-XWindowAttributes-map_state (fixnum fixnum) ( void "set_XWindowAttributes_map_state" )) +(defentry XWindowAttributes-map_installed (fixnum) ( fixnum "XWindowAttributes_map_installed" )) +(defentry set-XWindowAttributes-map_installed (fixnum fixnum) ( void "set_XWindowAttributes_map_installed" )) +(defentry XWindowAttributes-colormap (fixnum) ( fixnum "XWindowAttributes_colormap" )) +(defentry set-XWindowAttributes-colormap (fixnum fixnum) ( void "set_XWindowAttributes_colormap" )) +(defentry XWindowAttributes-save_under (fixnum) ( fixnum "XWindowAttributes_save_under" )) +(defentry set-XWindowAttributes-save_under (fixnum fixnum) ( void "set_XWindowAttributes_save_under" )) +(defentry XWindowAttributes-backing_pixel (fixnum) ( fixnum "XWindowAttributes_backing_pixel" )) +(defentry set-XWindowAttributes-backing_pixel (fixnum fixnum) ( void "set_XWindowAttributes_backing_pixel" )) +(defentry XWindowAttributes-backing_planes (fixnum) ( fixnum "XWindowAttributes_backing_planes" )) +(defentry set-XWindowAttributes-backing_planes (fixnum fixnum) ( void "set_XWindowAttributes_backing_planes" )) +(defentry XWindowAttributes-backing_store (fixnum) ( fixnum "XWindowAttributes_backing_store" )) +(defentry set-XWindowAttributes-backing_store (fixnum fixnum) ( void "set_XWindowAttributes_backing_store" )) +(defentry XWindowAttributes-win_gravity (fixnum) ( fixnum "XWindowAttributes_win_gravity" )) +(defentry set-XWindowAttributes-win_gravity (fixnum fixnum) ( void "set_XWindowAttributes_win_gravity" )) +(defentry XWindowAttributes-bit_gravity (fixnum) ( fixnum "XWindowAttributes_bit_gravity" )) +(defentry set-XWindowAttributes-bit_gravity (fixnum fixnum) ( void "set_XWindowAttributes_bit_gravity" )) +(defentry XWindowAttributes-class (fixnum) ( fixnum "XWindowAttributes_class" )) +(defentry set-XWindowAttributes-class (fixnum fixnum) ( void "set_XWindowAttributes_class" )) +(defentry XWindowAttributes-root (fixnum) ( fixnum "XWindowAttributes_root" )) +(defentry set-XWindowAttributes-root (fixnum fixnum) ( void "set_XWindowAttributes_root" )) +(defentry XWindowAttributes-visual (fixnum) ( fixnum "XWindowAttributes_visual" )) +(defentry set-XWindowAttributes-visual (fixnum fixnum) ( void "set_XWindowAttributes_visual" )) +(defentry XWindowAttributes-depth (fixnum) ( fixnum "XWindowAttributes_depth" )) +(defentry set-XWindowAttributes-depth (fixnum fixnum) ( void "set_XWindowAttributes_depth" )) +(defentry XWindowAttributes-border_width (fixnum) ( fixnum "XWindowAttributes_border_width" )) +(defentry set-XWindowAttributes-border_width (fixnum fixnum) ( void "set_XWindowAttributes_border_width" )) +(defentry XWindowAttributes-height (fixnum) ( fixnum "XWindowAttributes_height" )) +(defentry set-XWindowAttributes-height (fixnum fixnum) ( void "set_XWindowAttributes_height" )) +(defentry XWindowAttributes-width (fixnum) ( fixnum "XWindowAttributes_width" )) +(defentry set-XWindowAttributes-width (fixnum fixnum) ( void "set_XWindowAttributes_width" )) +(defentry XWindowAttributes-y (fixnum) ( fixnum "XWindowAttributes_y" )) +(defentry set-XWindowAttributes-y (fixnum fixnum) ( void "set_XWindowAttributes_y" )) +(defentry XWindowAttributes-x (fixnum) ( fixnum "XWindowAttributes_x" )) +(defentry set-XWindowAttributes-x (fixnum fixnum) ( void "set_XWindowAttributes_x" )) + + +;;;;;; XHostAddress funcions ;;;;;; + +(defentry make-XHostAddress () ( fixnum "make_XHostAddress" )) +(defentry XHostAddress-address (fixnum) ( fixnum "XHostAddress_address" )) +(defentry set-XHostAddress-address (fixnum fixnum) ( void "set_XHostAddress_address" )) +(defentry XHostAddress-length (fixnum) ( fixnum "XHostAddress_length" )) +(defentry set-XHostAddress-length (fixnum fixnum) ( void "set_XHostAddress_length" )) +(defentry XHostAddress-family (fixnum) ( fixnum "XHostAddress_family" )) +(defentry set-XHostAddress-family (fixnum fixnum) ( void "set_XHostAddress_family" )) + + +;;;;;; XImage funcions ;;;;;; + +(defentry make-XImage () ( fixnum "make_XImage" )) +;;(defentry XImage-f (fixnum) ( fixnum "XImage_f" )) +;;(defentry set-XImage-f (fixnum fixnum) ( void "set_XImage_f" )) +(defentry XImage-obdata (fixnum) ( fixnum "XImage_obdata" )) +(defentry set-XImage-obdata (fixnum fixnum) ( void "set_XImage_obdata" )) +(defentry XImage-blue_mask (fixnum) ( fixnum "XImage_blue_mask" )) +(defentry set-XImage-blue_mask (fixnum fixnum) ( void "set_XImage_blue_mask" )) +(defentry XImage-green_mask (fixnum) ( fixnum "XImage_green_mask" )) +(defentry set-XImage-green_mask (fixnum fixnum) ( void "set_XImage_green_mask" )) +(defentry XImage-red_mask (fixnum) ( fixnum "XImage_red_mask" )) +(defentry set-XImage-red_mask (fixnum fixnum) ( void "set_XImage_red_mask" )) +(defentry XImage-bits_per_pixel (fixnum) ( fixnum "XImage_bits_per_pixel" )) +(defentry set-XImage-bits_per_pixel (fixnum fixnum) ( void "set_XImage_bits_per_pixel" )) +(defentry XImage-bytes_per_line (fixnum) ( fixnum "XImage_bytes_per_line" )) +(defentry set-XImage-bytes_per_line (fixnum fixnum) ( void "set_XImage_bytes_per_line" )) +(defentry XImage-depth (fixnum) ( fixnum "XImage_depth" )) +(defentry set-XImage-depth (fixnum fixnum) ( void "set_XImage_depth" )) +(defentry XImage-bitmap_pad (fixnum) ( fixnum "XImage_bitmap_pad" )) +(defentry set-XImage-bitmap_pad (fixnum fixnum) ( void "set_XImage_bitmap_pad" )) +(defentry XImage-bitmap_bit_order (fixnum) ( fixnum "XImage_bitmap_bit_order" )) +(defentry set-XImage-bitmap_bit_order (fixnum fixnum) ( void "set_XImage_bitmap_bit_order" )) +(defentry XImage-bitmap_unit (fixnum) ( fixnum "XImage_bitmap_unit" )) +(defentry set-XImage-bitmap_unit (fixnum fixnum) ( void "set_XImage_bitmap_unit" )) +(defentry XImage-byte_order (fixnum) ( fixnum "XImage_byte_order" )) +(defentry set-XImage-byte_order (fixnum fixnum) ( void "set_XImage_byte_order" )) +(defentry XImage-data (fixnum) ( fixnum "XImage_data" )) +(defentry set-XImage-data (fixnum fixnum) ( void "set_XImage_data" )) +(defentry XImage-format (fixnum) ( fixnum "XImage_format" )) +(defentry set-XImage-format (fixnum fixnum) ( void "set_XImage_format" )) +(defentry XImage-xoffset (fixnum) ( fixnum "XImage_xoffset" )) +(defentry set-XImage-xoffset (fixnum fixnum) ( void "set_XImage_xoffset" )) +(defentry XImage-height (fixnum) ( fixnum "XImage_height" )) +(defentry set-XImage-height (fixnum fixnum) ( void "set_XImage_height" )) +(defentry XImage-width (fixnum) ( fixnum "XImage_width" )) +(defentry set-XImage-width (fixnum fixnum) ( void "set_XImage_width" )) + + +;;;;;; XWindowChanges funcions ;;;;;; + +(defentry make-XWindowChanges () ( fixnum "make_XWindowChanges" )) +(defentry XWindowChanges-stack_mode (fixnum) ( fixnum "XWindowChanges_stack_mode" )) +(defentry set-XWindowChanges-stack_mode (fixnum fixnum) ( void "set_XWindowChanges_stack_mode" )) +(defentry XWindowChanges-sibling (fixnum) ( fixnum "XWindowChanges_sibling" )) +(defentry set-XWindowChanges-sibling (fixnum fixnum) ( void "set_XWindowChanges_sibling" )) +(defentry XWindowChanges-border_width (fixnum) ( fixnum "XWindowChanges_border_width" )) +(defentry set-XWindowChanges-border_width (fixnum fixnum) ( void "set_XWindowChanges_border_width" )) +(defentry XWindowChanges-height (fixnum) ( fixnum "XWindowChanges_height" )) +(defentry set-XWindowChanges-height (fixnum fixnum) ( void "set_XWindowChanges_height" )) +(defentry XWindowChanges-width (fixnum) ( fixnum "XWindowChanges_width" )) +(defentry set-XWindowChanges-width (fixnum fixnum) ( void "set_XWindowChanges_width" )) +(defentry XWindowChanges-y (fixnum) ( fixnum "XWindowChanges_y" )) +(defentry set-XWindowChanges-y (fixnum fixnum) ( void "set_XWindowChanges_y" )) +(defentry XWindowChanges-x (fixnum) ( fixnum "XWindowChanges_x" )) +(defentry set-XWindowChanges-x (fixnum fixnum) ( void "set_XWindowChanges_x" )) + + +;;;;;; XColor funcions ;;;;;; + +(defentry make-XColor () ( fixnum "make_XColor" )) +(defentry XColor-pad (fixnum) ( char "XColor_pad" )) +(defentry set-XColor-pad (fixnum char) ( void "set_XColor_pad" )) +(defentry XColor-flags (fixnum) ( char "XColor_flags" )) +(defentry set-XColor-flags (fixnum char) ( void "set_XColor_flags" )) +(defentry XColor-blue (fixnum) ( fixnum "XColor_blue" )) +(defentry set-XColor-blue (fixnum fixnum) ( void "set_XColor_blue" )) +(defentry XColor-green (fixnum) ( fixnum "XColor_green" )) +(defentry set-XColor-green (fixnum fixnum) ( void "set_XColor_green" )) +(defentry XColor-red (fixnum) ( fixnum "XColor_red" )) +(defentry set-XColor-red (fixnum fixnum) ( void "set_XColor_red" )) +(defentry XColor-pixel (fixnum) ( fixnum "XColor_pixel" )) +(defentry set-XColor-pixel (fixnum fixnum) ( void "set_XColor_pixel" )) + + +;;;;;; XSegment funcions ;;;;;; + +(defentry make-XSegment () ( fixnum "make_XSegment" )) +(defentry XSegment-y2 (fixnum) ( fixnum "XSegment_y2" )) +(defentry set-XSegment-y2 (fixnum fixnum) ( void "set_XSegment_y2" )) +(defentry XSegment-x2 (fixnum) ( fixnum "XSegment_x2" )) +(defentry set-XSegment-x2 (fixnum fixnum) ( void "set_XSegment_x2" )) +(defentry XSegment-y1 (fixnum) ( fixnum "XSegment_y1" )) +(defentry set-XSegment-y1 (fixnum fixnum) ( void "set_XSegment_y1" )) +(defentry XSegment-x1 (fixnum) ( fixnum "XSegment_x1" )) +(defentry set-XSegment-x1 (fixnum fixnum) ( void "set_XSegment_x1" )) + + +;;;;;; XPoint funcions ;;;;;; + +(defentry make-XPoint () ( fixnum "make_XPoint" )) +(defentry XPoint-y (fixnum) ( fixnum "XPoint_y" )) +(defentry set-XPoint-y (fixnum fixnum) ( void "set_XPoint_y" )) +(defentry XPoint-x (fixnum) ( fixnum "XPoint_x" )) +(defentry set-XPoint-x (fixnum fixnum) ( void "set_XPoint_x" )) + + +;;;;;; XRectangle funcions ;;;;;; + +(defentry make-XRectangle () ( fixnum "make_XRectangle" )) +(defentry XRectangle-height (fixnum) ( fixnum "XRectangle_height" )) +(defentry set-XRectangle-height (fixnum fixnum) ( void "set_XRectangle_height" )) +(defentry XRectangle-width (fixnum) ( fixnum "XRectangle_width" )) +(defentry set-XRectangle-width (fixnum fixnum) ( void "set_XRectangle_width" )) +(defentry XRectangle-y (fixnum) ( fixnum "XRectangle_y" )) +(defentry set-XRectangle-y (fixnum fixnum) ( void "set_XRectangle_y" )) +(defentry XRectangle-x (fixnum) ( fixnum "XRectangle_x" )) +(defentry set-XRectangle-x (fixnum fixnum) ( void "set_XRectangle_x" )) + + +;;;;;; XArc funcions ;;;;;; + +(defentry make-XArc () ( fixnum "make_XArc" )) +(defentry XArc-angle2 (fixnum) ( fixnum "XArc_angle2" )) +(defentry set-XArc-angle2 (fixnum fixnum) ( void "set_XArc_angle2" )) +(defentry XArc-angle1 (fixnum) ( fixnum "XArc_angle1" )) +(defentry set-XArc-angle1 (fixnum fixnum) ( void "set_XArc_angle1" )) +(defentry XArc-height (fixnum) ( fixnum "XArc_height" )) +(defentry set-XArc-height (fixnum fixnum) ( void "set_XArc_height" )) +(defentry XArc-width (fixnum) ( fixnum "XArc_width" )) +(defentry set-XArc-width (fixnum fixnum) ( void "set_XArc_width" )) +(defentry XArc-y (fixnum) ( fixnum "XArc_y" )) +(defentry set-XArc-y (fixnum fixnum) ( void "set_XArc_y" )) +(defentry XArc-x (fixnum) ( fixnum "XArc_x" )) +(defentry set-XArc-x (fixnum fixnum) ( void "set_XArc_x" )) + + +;;;;;; XKeyboardControl funcions ;;;;;; + +(defentry make-XKeyboardControl () ( fixnum "make_XKeyboardControl" )) +(defentry XKeyboardControl-auto_repeat_mode (fixnum) ( fixnum "XKeyboardControl_auto_repeat_mode" )) +;;(defentry set-XKeyboardControl-auto_repeat_mode (fixnum fixnum) ( void "set_XKeyboardControl_auto_repeat_mode" )) +(defentry XKeyboardControl-key (fixnum) ( fixnum "XKeyboardControl_key" )) +(defentry set-XKeyboardControl-key (fixnum fixnum) ( void "set_XKeyboardControl_key" )) +(defentry XKeyboardControl-led_mode (fixnum) ( fixnum "XKeyboardControl_led_mode" )) +(defentry set-XKeyboardControl-led_mode (fixnum fixnum) ( void "set_XKeyboardControl_led_mode" )) +(defentry XKeyboardControl-led (fixnum) ( fixnum "XKeyboardControl_led" )) +(defentry set-XKeyboardControl-led (fixnum fixnum) ( void "set_XKeyboardControl_led" )) +(defentry XKeyboardControl-bell_duration (fixnum) ( fixnum "XKeyboardControl_bell_duration" )) +(defentry set-XKeyboardControl-bell_duration (fixnum fixnum) ( void "set_XKeyboardControl_bell_duration" )) +(defentry XKeyboardControl-bell_pitch (fixnum) ( fixnum "XKeyboardControl_bell_pitch" )) +(defentry set-XKeyboardControl-bell_pitch (fixnum fixnum) ( void "set_XKeyboardControl_bell_pitch" )) +(defentry XKeyboardControl-bell_percent (fixnum) ( fixnum "XKeyboardControl_bell_percent" )) +(defentry set-XKeyboardControl-bell_percent (fixnum fixnum) ( void "set_XKeyboardControl_bell_percent" )) +(defentry XKeyboardControl-key_click_percent (fixnum) ( fixnum "XKeyboardControl_key_click_percent" )) +(defentry set-XKeyboardControl-key_click_percent (fixnum fixnum) ( void "set_XKeyboardControl_key_click_percent" )) + + +;;;;;; XKeyboardState funcions ;;;;;; + +(defentry make-XKeyboardState () ( fixnum "make_XKeyboardState" )) +(defentry XKeyboardState-auto_repeats (fixnum) ( fixnum "XKeyboardState_auto_repeats" )) +(defentry set-XKeyboardState-auto_repeats (fixnum object) ( void "set_XKeyboardState_auto_repeats" )) +(defentry XKeyboardState-global_auto_repeat (fixnum) ( fixnum "XKeyboardState_global_auto_repeat" )) +(defentry set-XKeyboardState-global_auto_repeat (fixnum fixnum) ( void "set_XKeyboardState_global_auto_repeat" )) +(defentry XKeyboardState-led_mask (fixnum) ( fixnum "XKeyboardState_led_mask" )) +(defentry set-XKeyboardState-led_mask (fixnum fixnum) ( void "set_XKeyboardState_led_mask" )) +(defentry XKeyboardState-bell_duration (fixnum) ( fixnum "XKeyboardState_bell_duration" )) +(defentry set-XKeyboardState-bell_duration (fixnum fixnum) ( void "set_XKeyboardState_bell_duration" )) +(defentry XKeyboardState-bell_pitch (fixnum) ( fixnum "XKeyboardState_bell_pitch" )) +(defentry set-XKeyboardState-bell_pitch (fixnum fixnum) ( void "set_XKeyboardState_bell_pitch" )) +(defentry XKeyboardState-bell_percent (fixnum) ( fixnum "XKeyboardState_bell_percent" )) +(defentry set-XKeyboardState-bell_percent (fixnum fixnum) ( void "set_XKeyboardState_bell_percent" )) +(defentry XKeyboardState-key_click_percent (fixnum) ( fixnum "XKeyboardState_key_click_percent" )) +(defentry set-XKeyboardState-key_click_percent (fixnum fixnum) ( void "set_XKeyboardState_key_click_percent" )) + + +;;;;;; XTimeCoord funcions ;;;;;; + +(defentry make-XTimeCoord () ( fixnum "make_XTimeCoord" )) +(defentry XTimeCoord-y (fixnum) ( fixnum "XTimeCoord_y" )) +(defentry set-XTimeCoord-y (fixnum fixnum) ( void "set_XTimeCoord_y" )) +(defentry XTimeCoord-x (fixnum) ( fixnum "XTimeCoord_x" )) +(defentry set-XTimeCoord-x (fixnum fixnum) ( void "set_XTimeCoord_x" )) +(defentry XTimeCoord-time (fixnum) ( fixnum "XTimeCoord_time" )) +(defentry set-XTimeCoord-time (fixnum fixnum) ( void "set_XTimeCoord_time" )) + + +;;;;;; XModifierKeymap funcions ;;;;;; + +(defentry make-XModifierKeymap () ( fixnum "make_XModifierKeymap" )) +(defentry XModifierKeymap-modifiermap (fixnum) ( fixnum "XModifierKeymap_modifiermap" )) +(defentry set-XModifierKeymap-modifiermap (fixnum fixnum) ( void "set_XModifierKeymap_modifiermap" )) +(defentry XModifierKeymap-max_keypermod (fixnum) ( fixnum "XModifierKeymap_max_keypermod" )) +(defentry set-XModifierKeymap-max_keypermod (fixnum fixnum) ( void "set_XModifierKeymap_max_keypermod" )) diff --git a/xgcl-2/gcl_Xakcl.example.lsp b/xgcl-2/gcl_Xakcl.example.lsp new file mode 100644 index 0000000..975c5a6 --- /dev/null +++ b/xgcl-2/gcl_Xakcl.example.lsp @@ -0,0 +1,326 @@ +(in-package :XLIB) +; Xakcl.example.lsp Hiep Huu Nguyen 27 Aug 92 + +; Copyright (c) 1994 Hiep Huu Nguyen and The University of Texas at Austin. + +; See the files gnu.license and dec.copyright . + +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 1, or (at your option) +; any later version. + +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +; Some of the files that interface to the Xlib are adapted from DEC/MIT files. +; See the file dec.copyright for details. + +;;;;;;;;;;;;;;;;;;;;;; +;;this is an example of getting a geometry feature of a drawable there +;;is also XGetWindowAttributes for just windows. See reference manual +;;on X lib. it is probably more efficient to use XGetGeometry function +;;once when a lot of geometry information is needed since, XGetGeometry +;;returns many values. also as can be noticed, XGetGeometry needs C +;;Pointers, so it is best to allocate these pointers as globals so that +;;they won't have to be created and destroyed all the time, taking time +;;and fragmenting memory + +(defun drawable-height (a-drawable &key (display *default-display*)) + (XGetGeometry display a-drawable *root-return* *x-return* *y-return* *width-return* + *height-return* *border-width-return* *depth-return*) + (int-pos *height-return* 0)) + + + +;;;;;;;;;;;;;;;;;;;;;; +;;this function is a simple application of line drawing. it uses the +;;drawable-height function and the default globals like +;;*default-display* and *default-GC* + +(defun graph-x-y (info &key (test #'first) (scale 10) (displ 0) (invert t)) + + (let* ((info (sort info #'< :key test)) + (first-x-y (first info)) + (prev-x (* (first first-x-y) scale)) + (mid-height ( / (drawable-height a-window) 2)) + (prev-y (if invert + (- mid-height (* (+ (second first-x-y) displ) scale)) + (* (+ (second first-x-y) displ) scale)))) + (print info) + (dolist (next-x-y (rest info)) + (let ((pres-x (* (first next-x-y) scale)) + (pres-y (if invert + (- mid-height (* (+ (second next-x-y) displ) scale)) + (* (+ (second next-x-y) displ) scale)))) + + ;; (format t "~%prev-x : ~a prev-y: ~a pres-x: ~a pres-y: ~a" prev-x prev-y pres-x pres-y) + (Xdrawline *default-display* a-window *default-GC* + prev-x prev-y pres-x pres-y) + (Xflush *default-display*) + (setq prev-x pres-x) + (setq prev-y pres-y))))) + + + +;;;;;;;;;;;;;;;;;;;;;; +;; here's an example of getting values stored in a certain GC +;; the structure XGCValues contain values for a GC +(defun get-foreground-of-gc (display GC) + (XGetGCValues display GC (+ GCForeground) *GC-Values*) + (XGCValues-foreground *GC-Values*)) + + +;;;;;;;;;;;;;;;;;;;;;; +;;this is an example of changing the graphics context and allocating a +;;color for drawing. this is also an example of setting the line +;;attributes this function changes the graphics context so becareful. +;;also notice that c-types Xcolor is created and freed. again it is +;;possible to make them global, because they could be used often. this +;;function was fixed to have no side effects. Side effects are a danger +;;with passing C structures. the structures could be changed as a side +;;effect if you're not careful + +(defun my-draw-line (&key (display *default-display*) (GC *default-GC*) x1 y1 x2 y2 (width 0) (color "BLACK") + (line-style LineSolid) (cap-style CapRound) (join-style JoinRound) (colormap *default-colormap*) + window) + + (let ((pixel-xcolor (make-Xcolor)) + (exact-rgb (make-Xcolor)) + (prev-fore-pixel (get-foreground-of-gc display GC))) + (XSetLineAttributes display GC width line-style cap-style join-style) + (XAllocNamedColor display colormap (get-c-string color) pixel-xcolor exact-rgb) + (Xsetforeground display GC (Xcolor-pixel pixel-xcolor)) + (XDrawLine display window GC x1 y1 x2 y2) + (Xflush display) + (free pixel-xcolor) + (free exact-rgb) + (XSetForeground display GC prev-fore-pixel))) + + + +(defun colors () + (let ((pixel-xcolor (make-Xcolor)) + (y 0) + (r 0) + (b 0) + (g 0)) + (dotimes (g 65535) +;; (format t "~% ~a ~a ~a" r b g) + (set-Xcolor-red pixel-xcolor r) + (set-Xcolor-blue pixel-xcolor b) + (set-Xcolor-green pixel-xcolor g) + (if (not (eql 0 (XallocColor *default-display* *default-colormap* pixel-xcolor))) + (progn (Xsetforeground *default-display* *default-GC* (Xcolor-pixel pixel-xcolor)) + (XDrawLine *default-display* a-window *default-GC* 0 0 200 y) + (Xflush *default-display*) + (incf y 1)) + ;; (format t "~%error in reading color") + )))) + + +(defun return-r-b-g (color &key (display *default-display*) (GC *default-GC*) (colormap *default-colormap*) + ) + (let ((pixel-xcolor (make-Xcolor)) + (exact-rgb (make-Xcolor))) + (XAllocNamedColor display colormap (get-c-string color) pixel-xcolor pixel-xcolor) + (format t "~% red: ~a blue: ~a green: ~a" (Xcolor-red pixel-xcolor) + (Xcolor-blue pixel-xcolor) (Xcolor-green pixel-xcolor)))) + +;;;;;;;;;;;;;;;;;;;;;; +;;this function tracks the mouse. when the mouse button is pressed a +;;line is drawn from the previous position to the current position. +;;this funciton also shows a way of handling exposure events. the +;;positions are remebered in order to redraw the contents of the window +;;when it is exposed. this function handles events in two windows, the +;;quit window and the draw window. there is an example of setting the +;;input for a window. the draw window can have button press events, +;;pointer motion events and exposure events, while the quit window +;;(button) only needs button press events, and exposure events. notice +;;that the event queue is actually flushed at the beginng of the +;;functions. There is also an example of drawing and inverting text. +;;and handling sub windows. the sub windows are destroyed at the end of +;;the function. + +(defun track-mouse (a-window) + (Xsync *default-display* 1) ;; this clears the event queue so that previous + ;; motion events won't show up + (XClearWindow *default-display* a-window) + + ;; create two sub window + + (let ((quit-window (XCreateSimpleWindow + *default-display* a-window + 2 2 50 20 1 *black-pixel* *white-pixel*)) + (draw-window (XCreateSimpleWindow + *default-display* a-window + 2 32 220 350 1 *black-pixel* *white-pixel*))) + (Xselectinput *default-display* quit-window (+ ButtonpressMask ExposureMask)) + (Xselectinput *default-display* draw-window + (+ ButtonpressMask PointerMotionMask ExposureMask)) + + (XMapWindow *default-display* quit-window) + (XMapWindow *default-display* draw-window) + (Xflush *default-display* ) + (XDrawString *default-display* quit-window *default-GC* 10 15 (get-c-string "Quit") 4) + (Xflush *default-display* ) + (do ((exit nil) + (lines-list nil) + (prev-x nil) + (prev-y nil)) + (exit) + (XNextEvent *default-display* *default-event*) + (let ((type (XAnyEvent-type *default-event*)) + (active-window (XAnyevent-window *default-event*))) + (cond ((eql draw-window active-window) + (cond +;;; draw a line + ((eql type ButtonPress) + (let ((x (XButtonEvent-x *default-event*)) + (y (XButtonEvent-y *default-event*))) + (if prev-x + (XDrawLine *default-display* draw-window *default-GC* prev-x prev-y x y)) + (setq prev-x x) + (setq prev-y y) + (push (list x y) lines-list))) +;;; track the mouse + ((eql type MotionNotify) + (let ((x (XMotionEvent-x *default-event*)) + (y (XMotionEvent-y *default-event*)) + (time (XmotionEvent-time *default-event*))) + ;;trace the mouse + ;;(format t "~% pos-x: ~a pos-y: ~a" x y) + ;;(format t "~%time: ~a" time) + )) + +;;;; redraw window after expose event + + ((eql type Expose) + (let* ((first-xy (first lines-list)) + (prev-x (first first-xy)) + (prev-y (second first-xy))) + (dolist (an-xy (rest lines-list)) + (let ((x (first an-xy)) + (y (second an-xy))) + (XDrawLine *default-display* draw-window *default-GC* prev-x prev-y x y) + (setq prev-x x) + (setq prev-y y))))))) + + ;; exit if the quit button is pressed + + ((eql quit-window active-window) + (cond ((eql type ButtonPress) + (setq exit t) + (XSetForeground *default-display* + *default-GC* *white-pixel*) + (XSetBackground *default-display* + *default-GC* *black-pixel*) + (XDrawImageString *default-display* quit-window *default-GC* 10 15 (get-c-string "Quit") 4) + (Xflush *default-display*) + +;;the drawing goes so fast that you can't see the text invert, so the +;;function wiats for for about .2 seconds. but it would be better to +;;keep the text inverted until the button is released this is done by +;;setting the quit window to have buton release events as well and +;;handling it appropriately + + (dotimes (i 1500)) + + + (XSetForeground *default-display* + *default-GC* *black-pixel*) + (XSetBackground *default-display* + *default-GC* *white-pixel*) + (XDrawImageString *default-display* quit-window *default-GC* 10 15 (get-c-string "Quit") 4) + (Xflush *default-display*)) + +;; do quit window expose event + ((eql type Expose) + (XDrawString *default-display* quit-window *default-GC* 10 15 (get-c-string "Quit") 4))))))) + (XDestroySubWindows *default-display* a-window) + (Xflush *default-display*))) + + +;;;;;;;;;;;;;;;;;;;;;; +;;this function demonstrtes using different fonts of text + +(defun basic-text (a-window &key (display *default-display*) (GC *default-GC* )) + (my-load-font "9x15" :display display :GC GC) + (Xdrawstring display a-window GC 50 100 (get-c-string "hello") 5) + (my-load-font "*-*-courier-bold-r-*-*-12-*-*-*-*-*-iso8859-1" :display display :GC GC) + (Xdrawstring display a-window GC 50 150 (get-c-string "hello") 5) + (Xflush display)) + + +;;;;;;;;;;;;;;;;;;;;;; +;;this function demonstartes getting different fonts and setting them in a GC + +(defun my-load-font (a-string &key (display *default-display*) (GC *default-GC* )) + (let ((font-info (XloadQueryFont display (get-c-string a-string)))) + (if (not (eql 0 font-info)) + (XsetFont display GC (Xfontstruct-fid font-info)) + (format t "~%can't open font ~a" a-string)))) + + +;;;;;;;;;;;;;;;;;;;;;; +;;this function draws a ghst line by setting the X function to GXXor. and the +;;foreground color to th logxor of the back and foreground pixel +;;this function actually changes the graphics context. and does not change it back +;;to use the ghost method and switch back to regular drawing. set the funciton +;;back to GXcopy and the foregorund pixel appropriately + +(defun do-ghost-line-1 (a-window) + (Xsync *default-display* 1);; this clears the event queue so that previous + ;; motion events won't show up + (XClearWindow *default-display* a-window) + + (XdrawRectangle *default-display* a-window *default-GC* + 0 0 100 100) + (Xdrawarc *default-display* a-window *default-GC* 100 200 100 100 0 (* 360 64)) + + (Xsetfunction *default-display* *default-GC* GXxor) + (Xsetforeground *default-display* *default-GC* (logxor *black-pixel* *white-pixel*)) + (Xselectinput *default-display* a-window PointerMotionMask ) + (do ((exit nil) + (prev-x 0) + (prev-y 0)) + (exit) + (XNextEvent *default-display* *default-event*) + (let ((type (XAnyEvent-type *default-event*))) + (cond + + ;;draw ghost line + ((eql type MotionNotify) + (let ((x (XMotionEvent-x *default-event*)) + (y (XMotionEvent-y *default-event*)) + (time (XmotionEvent-time *default-event*))) + (Xdrawline *default-display* a-window *default-GC* 0 0 prev-x prev-y) + (Xdrawline *default-display* a-window *default-GC* 0 0 x y) + (setq prev-x x) + (setq prev-y y) + )))))) + + + + + + ;;example of a circle + ;;position 100 100 diameter 100 + + ;;(XdrawArc *default-display* a-window *default-GC* 100 100 100 100 0 (* 360 64)) + + ;;example of font + + ;;(XloadFont *default-display* (get-c-string "8x10")) + + + + ;; set a pixel + + ;;(XallocNamedColor *default-display* *default-colormap* (get-c-string "aquamarine") a b) diff --git a/xgcl-2/gcl_Xinit.lsp b/xgcl-2/gcl_Xinit.lsp new file mode 100644 index 0000000..597744f --- /dev/null +++ b/xgcl-2/gcl_Xinit.lsp @@ -0,0 +1,147 @@ +(in-package :XLIB) +; Xinit.lsp Hiep Huu Nguyen 27 Aug 92; GSN 07 Mar 95 + +; Copyright (c) 1994 Hiep Huu Nguyen and The University of Texas at Austin. + +; See the files gnu.license and dec.copyright . + +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 1, or (at your option) +; any later version. + +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +; Some of the files that interface to the Xlib are adapted from DEC/MIT files. +; See the file dec.copyright for details. + +;;a word about Xakcl: +;;Since Xakcl is a direct translation of the X library in C to lisp to a +;;large extent. it would be beneficial to use a X 11 version 4, manual +;;in order to look up functions. the only unique functions of Xakcl are those +;;that involove manipulating C structs. all functions involved in creating +;;a C struct in X starts with a 'make' followed by the structure name. all +;;functions involved in getting a field of a C struct strats with the +;;name of the C struct followed by the name of the field. the +;;parameters it excepts is the varaible contaning the structure. all +;;functions to set a field of a C struct starts with 'set' followed by +;;the C struct name followed by the field name. these functions accept +;;as parameter, the varaible containing the struct and the value to be +;;put in the field. + +;;;; +;;contents of this file: +;;;; +;;this files has examples of initializing the display, screen, +;;root-window, pixel value, gc, and colormap. +;;;; +;;gives an example of opening windows, setting size's and sizehints for +;;the window manager getting drawbles' geometry +;;;; +;;drawing lines , drawing in color, changing line, attributes +;;;; +;;tracking the mouse and handling events and manipulating the event +;;queue +;;;; +;;there is also some basic text handling stuff +;;;; + +;;globals +(defvar *default-display* ) +(defvar *default-screen* ) +(defvar *default-colormap*) +(defvar *root-window* ) +(defvar *black-pixel* ) +(defvar *white-pixel* ) +(defvar *default-size-hints* (make-XsizeHints) ) +(defvar *default-GC* ) +(defvar *default-event* (make-XEvent)) +(defvar *pos-x* 10) +(defvar *pos-y* 20) +(defvar *win-width* 225) +(defvar *win-height* 400) +(defvar *border-width* 1) +(defvar *root-return* (int-array 1)) +(defvar *x-return* (int-array 1)) +(defvar *y-return* (int-array 1) ) +(defvar *width-return* (int-array 1)) +(defvar *height-return* (int-array 1)) +(defvar *border-width-return* (int-array 1)) +(defvar *depth-return* (int-array 1)) +(defvar *GC-Values* (make-XGCValues)) + +;;an example window +(defvar a-window) + + +;;;;;;;;;;;;;;;;;;;;;; +;;this function initializes all varaibles needed by most applications. +;;it uses all defaults which is inherited from the root window, and +;;screen. + +(defun Xinit() + (setq *default-display* (XOpenDisplay (get-c-string ""))) + (setq *default-screen* (XdefaultScreen *default-display*)) + (setq *root-window* (XRootWindow *default-display* *default-screen*)) + (setq *black-pixel* (XBlackPixel *default-display* + *default-screen*)) + (setq *white-pixel* (XWhitePixel *default-display* + *default-screen*)) + (setq *default-GC* (XDefaultGC *default-display* *default-screen*)) + (setq *default-colormap* ( XDefaultColormap *default-display* *default-screen*)) + (Xflush *default-display* )) + + + + +;;;;;;;;;;;;;;;;;;;;;; +;;this is an example of creating a window. this function takes care of +;;positioning, size and other attirbutes of the window. + +(defun open-window(&key (pos-x *pos-x* ) (pos-y *pos-y*) (win-width *win-width*) + (win-height *win-height* ) + (border-width *border-width*) (window-name "My Window") + (icon-name "My Icon")) +;;create the window + + (let (( a-window (XCreateSimpleWindow + *default-display* *root-window* + pos-x pos-y win-width win-height border-width *black-pixel* *white-pixel*))) + +;; all children of the root window needs a XSizeHints to tell the window manager +;; how to position it, etc + + (set-Xsizehints-x *default-size-hints* pos-x) + (set-xsizehints-y *default-size-hints* pos-y) + (set-xsizehints-width *default-size-hints* win-width) + (set-xsizehints-height *default-size-hints* win-height) + (set-xsizehints-flags *default-size-hints* (+ Psize Pposition)) + (XsetStandardProperties *default-display* a-window (get-c-string window-name) + (get-c-string icon-name) none 0 0 *default-size-hints*) + +;; the events or input a window can have are set with Xselectinput +;; (Xselectinput *default-display* a-window +;; (+ ButtonpressMask PointerMotionMask ExposureMask)) + +;; the window needs to be mapped + (Xmapwindow *default-display* a-window) + +;;the X server needs to have the output buffer sent to it before it can +;;process requests. this is acomplished with XFlush or functions that +;;read and manipulate the event queue. remember to do this after +;;operations that won't be calling an eventhandling function + + (Xflush *default-display* ) + +;;after flushing the request buffer the X server draws window as requested + + a-window)) + + diff --git a/xgcl-2/gcl_Xlib.lsp b/xgcl-2/gcl_Xlib.lsp new file mode 100644 index 0000000..616d5eb --- /dev/null +++ b/xgcl-2/gcl_Xlib.lsp @@ -0,0 +1,3456 @@ +(in-package :XLIB) +; Xlib.lsp Hiep Huu Nguyen 27 Aug 92 + +; Copyright (c) 1994 Hiep Huu Nguyen and The University of Texas at Austin. + +; See the files gnu.license and dec.copyright . + +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 1, or (at your option) +; any later version. + +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +; Some of the files that interface to the Xlib are adapted from DEC/MIT files. +; See the file dec.copyright for details. + +;;typedef unsigned long XID) ; + +;;typedef XID Window) ; +;;typedef XID Drawable) ; +;;typedef XID Font) ; +;;typedef XID Pixmap) ; +;;typedef XID Cursor) ; +;;typedef XID Colormap) ; +;;typedef XID GContext) ; +;;typedef XID KeySym) ; + +;;typedef unsigned long Mask) ; + +;;typedef unsigned long Atom) ; + +;;typedef unsigned long VisualID) ; + +;;typedef unsigned long Time) ; + +;;typedef unsigned char KeyCode) ; + +(defconstant True 1) +(defconstant False 0) + +(defconstant QueuedAlready 0) +(defconstant QueuedAfterReading 1) +(defconstant QueuedAfterFlush 2) + +(defentry XLoadQueryFont( + + fixnum ;; display + object ;; name + +)( fixnum "XLoadQueryFont")) + + + +(defentry XQueryFont( + + fixnum ;; display + fixnum ;; font_ID + +)( fixnum "XQueryFont")) + + + + +(defentry XGetMotionEvents( + + fixnum ;; display + fixnum ;; w + fixnum ;; start + fixnum ;; stop + fixnum ;; nevents_return + +)( fixnum "XGetMotionEvents")) + + + +(defentry XDeleteModifiermapEntry( + + fixnum ;; modmap + + fixnum ;; keycode_entry + + fixnum ;; modifier + +)( fixnum "XDeleteModifiermapEntry")) + + + +(defentry XGetModifierMapping( + + fixnum ;; display + +)( fixnum "XGetModifierMapping")) + + + +(defentry XInsertModifiermapEntry( + + fixnum ;; modmap + + fixnum ;; keycode_entry + + fixnum ;; modifier + +)( fixnum "XInsertModifiermapEntry")) + + + +(defentry XNewModifiermap( + + fixnum ;; max_keys_per_mod + +)( fixnum "XNewModifiermap")) + + + +(defentry XCreateImage( + + fixnum ;; display + fixnum ;; visual + fixnum ;; depth + fixnum ;; format + fixnum ;; offset + object ;; data + fixnum ;; width + fixnum ;; height + fixnum ;; bitmap_pad + fixnum ;; bytes_per_line + +)( fixnum "XCreateImage")) + + +(defentry XGetImage( + + fixnum ;; display + fixnum ;; d + fixnum ;; x + fixnum ;; y + fixnum ;; width + fixnum ;; height + fixnum ;; plane_mask + fixnum ;; format + +)( fixnum "XGetImage")) + + +(defentry XGetSubImage( + + fixnum ;; display + fixnum ;; d + fixnum ;; x + fixnum ;; y + fixnum ;; width + fixnum ;; height + fixnum ;; plane_mask + fixnum ;; format + fixnum ;; dest_image + fixnum ;; dest_x + fixnum ;; dest_y + +)( fixnum "XGetSubImage")) + +;;Window X function declarations. + + + +(defentry XOpenDisplay( + + object ;; display_name + +)( fixnum "XOpenDisplay")) + + + +(defentry XrmInitialize( + +;; void + +)( void "XrmInitialize")) + + + +(defentry XFetchBytes( + + fixnum ;; display + fixnum ;; nbytes_return + +)( fixnum "XFetchBytes")) + + +(defentry XFetchBuffer( + + fixnum ;; display + fixnum ;; nbytes_return + fixnum ;; buffer + +)( fixnum "XFetchBuffer")) + + +(defentry XGetAtomName( + + fixnum ;; display + fixnum ;; atom + +)( fixnum "XGetAtomName")) + + +(defentry XGetDefault( + + fixnum ;; display + object ;; program + object ;; option + +)( fixnum "XGetDefault")) + + +(defentry XDisplayName( + + object ;; string + +)( fixnum "XDisplayName")) + + +(defentry XKeysymToString( + + fixnum ;; keysym + +)( fixnum "XKeysymToString")) + + + + +(defentry XInternAtom( + + fixnum ;; display + object ;; atom_name + fixnum ;; only_if_exists + +)( fixnum "XInternAtom")) + + +(defentry XCopyColormapAndFree( + + fixnum ;; display + fixnum ;; colormap + +)( fixnum "XCopyColormapAndFree")) + + +(defentry XCreateColormap( + + fixnum ;; display + fixnum ;; w + fixnum ;; visual + fixnum ;; alloc + +)( fixnum "XCreateColormap")) + + +(defentry XCreatePixmapCursor( + + fixnum ;; display + fixnum ;; source + fixnum ;; mask + fixnum ;; foreground_color + fixnum ;; background_color + fixnum ;; x + fixnum ;; y + +)( fixnum "XCreatePixmapCursor")) + + +(defentry XCreateGlyphCursor( + + fixnum ;; display + fixnum ;; source_font + fixnum ;; mask_font + fixnum ;; source_char + fixnum ;; mask_char + fixnum ;; foreground_color + fixnum ;; background_color + +)( fixnum "XCreateGlyphCursor")) + + +(defentry XCreateFontCursor( + + fixnum ;; display + fixnum ;; shape + +)( fixnum "XCreateFontCursor")) + + +(defentry XLoadFont( + + fixnum ;; display + object ;; name + +)( fixnum "XLoadFont")) + + +(defentry XCreateGC( + + fixnum ;; display + fixnum ;; d + fixnum ;; valuemask + fixnum ;; values + +)( fixnum "XCreateGC")) + + +(defentry XGContextFromGC( + + fixnum ;; gc + +)( fixnum "XGContextFromGC")) + + +(defentry XCreatePixmap( + + fixnum ;; display + fixnum ;; d + fixnum ;; width + fixnum ;; height + fixnum ;; depth + +)( fixnum "XCreatePixmap")) + + +(defentry XCreateBitmapFromData( + + fixnum ;; display + fixnum ;; d + object ;; data + fixnum ;; width + fixnum ;; height + +)( fixnum "XCreateBitmapFromData")) + + +(defentry XCreatePixmapFromBitmapData( + + fixnum ;; display + fixnum ;; d + object ;; data + fixnum ;; width + fixnum ;; height + fixnum ;; fg + fixnum ;; bg + fixnum ;; depth + +)( fixnum "XCreatePixmapFromBitmapData")) + + +(defentry XCreateSimpleWindow( + + fixnum ;; display + fixnum ;; parent + fixnum ;; x + fixnum ;; y + fixnum ;; width + fixnum ;; height + fixnum ;; border_width + fixnum ;; border + fixnum ;; background + +)( fixnum "XCreateSimpleWindow")) + + +(defentry XGetSelectionOwner( + + fixnum ;; display + fixnum ;; selection + +)( fixnum "XGetSelectionOwner")) + + +(defentry XCreateWindow( + + fixnum ;; display + fixnum ;; parent + fixnum ;; x + fixnum ;; y + fixnum ;; width + fixnum ;; height + fixnum ;; border_width + fixnum ;; depth + fixnum ;; class + fixnum ;; visual + fixnum ;; valuemask + fixnum ;; attributes + +)( fixnum "XCreateWindow")) + + +(defentry XListInstalledColormaps( + + fixnum ;; display + fixnum ;; w + fixnum ;; num_return + +)( fixnum "XListInstalledColormaps")) + + +(defentry XListFonts( + + fixnum ;; display + object ;; pattern + fixnum ;; maxnames + fixnum ;; actual_count_return + +)( fixnum "XListFonts")) + + +(defentry XListFontsWithInfo( + + fixnum ;; display + object ;; pattern + fixnum ;; maxnames + fixnum ;; count_return + fixnum ;; info_return + +)( fixnum "XListFontsWithInfo")) + + +(defentry XGetFontPath( + + fixnum ;; display + fixnum ;; npaths_return + +)( fixnum "XGetFontPath")) + + +(defentry XListExtensions( + + fixnum ;; display + fixnum ;; nextensions_return + +)( fixnum "XListExtensions")) + + +(defentry XListProperties( + + fixnum ;; display + fixnum ;; w + fixnum ;; num_prop_return + +)( fixnum "XListProperties")) + + +(defentry XListHosts( + + fixnum ;; display + fixnum ;; nhosts_return + fixnum ;; state_return + +)( fixnum "XListHosts")) + + +(defentry XKeycodeToKeysym( + + fixnum ;; display + + fixnum ;; fixnum + + fixnum ;; index + +)( fixnum "XKeycodeToKeysym")) + + +(defentry XLookupKeysym( + + fixnum ;; key_event + fixnum ;; index + +)( fixnum "XLookupKeysym")) + + +(defentry XGetKeyboardMapping( + + fixnum ;; display + + fixnum ;; first_keycode + + fixnum ;; keycode_count + fixnum ;; keysyms_per_keycode_return + +)( fixnum "XGetKeyboardMapping")) + + +(defentry XStringToKeysym( + + object ;; string + +)( fixnum "XStringToKeysym")) + + +(defentry XMaxRequestSize( + + fixnum ;; display + +)( fixnum "XMaxRequestSize")) + + +(defentry XResourceManagerString( + + fixnum ;; display + +)( fixnum "XResourceManagerString")) + + +(defentry XDisplayMotionBufferSize( + + fixnum ;; display + +)( fixnum "XDisplayMotionBufferSize")) + + +(defentry XVisualIDFromVisual( + + fixnum ;; visual + +)( fixnum "XVisualIDFromVisual")) + +;; routines for dealing with extensions + + + +(defentry XInitExtension( + + fixnum ;; display + object ;; name + +)( fixnum "XInitExtension")) + + + +(defentry XAddExtension( + + fixnum ;; display + +)( fixnum "XAddExtension")) + + +(defentry XFindOnExtensionList( + + fixnum ;; structure + fixnum ;; number + +)( fixnum "XFindOnExtensionList")) + + + +;;;fix + + +;(defentry XEHeadOfExtensionList( + +; fixnum ;;object + +;)( fixnum "XEHeadOfExtensionList")) + +;; these are routines for which there are also macros + + +(defentry XRootWindow( + + fixnum ;; display + fixnum ;; screen_number + +)( fixnum "XRootWindow")) + + +(defentry XDefaultRootWindow( + + fixnum ;; display + +)( fixnum "XDefaultRootWindow")) + + +(defentry XRootWindowOfScreen( + + fixnum ;; screen + +)( fixnum "XRootWindowOfScreen")) + + +(defentry XDefaultVisual( + + fixnum ;; display + fixnum ;; screen_number + +)( fixnum "XDefaultVisual")) + + +(defentry XDefaultVisualOfScreen( + + fixnum ;; screen + +)( fixnum "XDefaultVisualOfScreen")) + + +(defentry XDefaultGC( + + fixnum ;; display + fixnum ;; screen_number + +)( fixnum "XDefaultGC")) + + +(defentry XDefaultGCOfScreen( + + fixnum ;; screen + +)( fixnum "XDefaultGCOfScreen")) + + +(defentry XBlackPixel( + + fixnum ;; display + fixnum ;; screen_number + +)( fixnum "XBlackPixel")) + + +(defentry XWhitePixel( + + fixnum ;; display + fixnum ;; screen_number + +)( fixnum "XWhitePixel")) + + +(defentry XAllPlanes( + +;; void + +)( fixnum "XAllPlanes")) + + +(defentry XBlackPixelOfScreen( + + fixnum ;; screen + +)( fixnum "XBlackPixelOfScreen")) + + +(defentry XWhitePixelOfScreen( + + fixnum ;; screen + +)( fixnum "XWhitePixelOfScreen")) + + +(defentry XNextRequest( + + fixnum ;; display + +)( fixnum "XNextRequest")) + + +(defentry XLastKnownRequestProcessed( + + fixnum ;; display + +)( fixnum "XLastKnownRequestProcessed")) + + +(defentry XServerVendor( + + fixnum ;; display + +)( fixnum "XServerVendor")) + + +(defentry XDisplayString( + + fixnum ;; display + +)( fixnum "XDisplayString")) + + +(defentry XDefaultColormap( + + fixnum ;; display + fixnum ;; screen_number + +)( fixnum "XDefaultColormap")) + + +(defentry XDefaultColormapOfScreen( + + fixnum ;; screen + +)( fixnum "XDefaultColormapOfScreen")) + + +(defentry XDisplayOfScreen( + + fixnum ;; screen + +)( fixnum "XDisplayOfScreen")) + + +(defentry XScreenOfDisplay( + + fixnum ;; display + fixnum ;; screen_number + +)( fixnum "XScreenOfDisplay")) + + +(defentry XDefaultScreenOfDisplay( + + fixnum ;; display + +)( fixnum "XDefaultScreenOfDisplay")) + + +(defentry XEventMaskOfScreen( + + fixnum ;; screen + +)( fixnum "XEventMaskOfScreen")) + + + +(defentry XScreenNumberOfScreen( + + fixnum ;; screen + +)( fixnum "XScreenNumberOfScreen")) + + + +(defentry XSetErrorHandler ( + + fixnum ;; handler + +)( fixnum "XSetErrorHandler" )) + + +;;fix + + +(defentry XSetIOErrorHandler ( + + fixnum ;; handler + +)( fixnum "XSetIOErrorHandler" )) + + + + +(defentry XListPixmapFormats( + + fixnum ;; display + fixnum ;; count_return + +)( fixnum "XListPixmapFormats")) + + +(defentry XListDepths( + + fixnum ;; display + fixnum ;; screen_number + fixnum ;; count_return + +)( fixnum "XListDepths")) + +;; ICCCM routines for things that don't require special include files; +;; other declarations are given in Xutil.h + + +(defentry XReconfigureWMWindow( + + fixnum ;; display + fixnum ;; w + fixnum ;; screen_number + fixnum ;; mask + fixnum ;; changes + +)( fixnum "XReconfigureWMWindow")) + + + +(defentry XGetWMProtocols( + + fixnum ;; display + fixnum ;; w + fixnum ;; protocols_return + fixnum ;; count_return + +)( fixnum "XGetWMProtocols")) + + +(defentry XSetWMProtocols( + + fixnum ;; display + fixnum ;; w + fixnum ;; protocols + fixnum ;; count + +)( fixnum "XSetWMProtocols")) + + +(defentry XIconifyWindow( + + fixnum ;; display + fixnum ;; w + fixnum ;; screen_number + +)( fixnum "XIconifyWindow")) + + +(defentry XWithdrawWindow( + + fixnum ;; display + fixnum ;; w + fixnum ;; screen_number + +)( fixnum "XWithdrawWindow")) + +;;;fix + + +(defentry XGetCommand( + + fixnum ;; display + fixnum ;; w + fixnum ;; argv_return + fixnum ;; argc_return + +)( fixnum "XGetCommand")) + + +(defentry XGetWMColormapWindows( + + fixnum ;; display + fixnum ;; w + fixnum ;; windows_return + fixnum ;; count_return + +)( fixnum "XGetWMColormapWindows")) + + +(defentry XSetWMColormapWindows( + + fixnum ;; display + fixnum ;; w + fixnum ;; colormap_windows + fixnum ;; count + +)( fixnum "XSetWMColormapWindows")) + + +(defentry XFreeStringList( + + fixnum ;; list + +)( void "XFreeStringList")) + + +(defentry XSetTransientForHint( + + fixnum ;; display + fixnum ;; w + fixnum ;; prop_window + +)( void "XSetTransientForHint")) + +;; The following are given in alphabetical order + + + +(defentry XActivateScreenSaver( + + fixnum ;; display + +)( void "XActivateScreenSaver")) + + + +(defentry XAddHost( + + fixnum ;; display + fixnum ;; host + +)( void "XAddHost")) + + + +(defentry XAddHosts( + + fixnum ;; display + fixnum ;; hosts + fixnum ;; num_hosts + +)( void "XAddHosts")) + + + +(defentry XAddToExtensionList( + + fixnum ;; structure + fixnum ;; ext_data + +)( void "XAddToExtensionList")) + + + +(defentry XAddToSaveSet( + + fixnum ;; display + fixnum ;; w + +)( void "XAddToSaveSet")) + + + +(defentry XAllocColor( + + fixnum ;; display + fixnum ;; colormap + fixnum ;; screen_in_out + +)( fixnum "XAllocColor")) + +;;;fix + + +(defentry XAllocColorCells( + + fixnum ;; display + fixnum ;; colormap + fixnum ;; contig + fixnum ;; plane_masks_return + fixnum ;; nplanes + fixnum ;; pixels_return + fixnum ;; npixels + +)( fixnum "XAllocColorCells")) + + + +(defentry XAllocColorPlanes( + + fixnum ;; display + fixnum ;; colormap + fixnum ;; contig + fixnum ;; pixels_return + fixnum ;; ncolors + fixnum ;; nreds + fixnum ;; ngreens + fixnum ;; nblues + fixnum ;; rmask_return + fixnum ;; gmask_return + fixnum ;; bmask_return + +)( fixnum "XAllocColorPlanes")) + + + +(defentry XAllocNamedColor( + + fixnum ;; display + fixnum ;; colormap + object ;; color_name + fixnum ;; screen_def_return + fixnum ;; exact_def_return + +)( fixnum "XAllocNamedColor")) + + + +(defentry XAllowEvents( + + fixnum ;; display + fixnum ;; event_mode + fixnum ;; time + +)( void "XAllowEvents")) + + + +(defentry XAutoRepeatOff( + + fixnum ;; display + +)( void "XAutoRepeatOff")) + + + +(defentry XAutoRepeatOn( + + fixnum ;; display + +)( void "XAutoRepeatOn")) + + + +(defentry XBell( + + fixnum ;; display + fixnum ;; percent + +)( void "XBell")) + + + +(defentry XBitmapBitOrder( + + fixnum ;; display + +)( fixnum "XBitmapBitOrder")) + + + +(defentry XBitmapPad( + + fixnum ;; display + +)( fixnum "XBitmapPad")) + + + +(defentry XBitmapUnit( + + fixnum ;; display + +)( fixnum "XBitmapUnit")) + + + +(defentry XCellsOfScreen( + + fixnum ;; screen + +)( fixnum "XCellsOfScreen")) + + + +(defentry XChangeActivePointerGrab( + + fixnum ;; display + fixnum ;; event_mask + fixnum ;; cursor + fixnum ;; time + +)( void "XChangeActivePointerGrab")) + + + +(defentry XChangeGC( + + fixnum ;; display + fixnum ;; gc + fixnum ;; valuemask + fixnum ;; values + +)( void "XChangeGC")) + + + +(defentry XChangeKeyboardControl( + + fixnum ;; display + fixnum ;; value_mask + fixnum ;; values + +)( void "XChangeKeyboardControl")) + + + +(defentry XChangeKeyboardMapping( + + fixnum ;; display + fixnum ;; first_keycode + fixnum ;; keysyms_per_keycode + fixnum ;; keysyms + fixnum ;; num_codes + +)( void "XChangeKeyboardMapping")) + + + +(defentry XChangePointerControl( + + fixnum ;; display + fixnum ;; do_accel + fixnum ;; do_threshold + fixnum ;; accel_numerator + fixnum ;; accel_denominator + fixnum ;; threshold + +)( void "XChangePointerControl")) + + + +(defentry XChangeProperty( + + fixnum ;; display + fixnum ;; w + fixnum ;; property + fixnum ;; type + fixnum ;; format + fixnum ;; mode + fixnum ;; data + fixnum ;; nelements + +)( void "XChangeProperty")) + + + +(defentry XChangeSaveSet( + + fixnum ;; display + fixnum ;; w + fixnum ;; change_mode + +)( void "XChangeSaveSet")) + + + +(defentry XChangeWindowAttributes( + + fixnum ;; display + fixnum ;; w + fixnum ;; valuemask + fixnum ;; attributes + +)( void "XChangeWindowAttributes")) + + + +(defentry XCheckMaskEvent( + + fixnum ;; display + fixnum ;; event_mask + fixnum ;; event_return + +)( fixnum "XCheckMaskEvent")) + + + +(defentry XCheckTypedEvent( + + fixnum ;; display + fixnum ;; event_type + fixnum ;; event_return + +)( fixnum "XCheckTypedEvent")) + + + +(defentry XCheckTypedWindowEvent( + + fixnum ;; display + fixnum ;; w + fixnum ;; event_type + fixnum ;; event_return + +)( fixnum "XCheckTypedWindowEvent")) + + + +(defentry XCheckWindowEvent( + + fixnum ;; display + fixnum ;; w + fixnum ;; event_mask + fixnum ;; event_return + +)( fixnum "XCheckWindowEvent")) + + + +(defentry XCirculateSubwindows( + + fixnum ;; display + fixnum ;; w + fixnum ;; direction + +)( void "XCirculateSubwindows")) + + + +(defentry XCirculateSubwindowsDown( + + fixnum ;; display + fixnum ;; w + +)( void "XCirculateSubwindowsDown")) + + + +(defentry XCirculateSubwindowsUp( + + fixnum ;; display + fixnum ;; w + +)( void "XCirculateSubwindowsUp")) + + + +(defentry XClearArea( + + fixnum ;; display + fixnum ;; w + fixnum ;; x + fixnum ;; y + fixnum ;; width + fixnum ;; height + fixnum ;; exposures + +)( void "XClearArea")) + + + +(defentry XClearWindow( + + fixnum ;; display + fixnum ;; w + +)( void "XClearWindow")) + + + +(defentry XCloseDisplay( + + fixnum ;; display + +)( void "XCloseDisplay")) + + + +(defentry XConfigureWindow( + + fixnum ;; display + fixnum ;; w + fixnum ;; value_mask + fixnum ;; values + +)( void "XConfigureWindow")) + + + +(defentry XConnectionNumber( + + fixnum ;; display + +)( fixnum "XConnectionNumber")) + + + +(defentry XConvertSelection( + + fixnum ;; display + fixnum ;; selection + fixnum ;; target + fixnum ;; property + fixnum ;; requestor + fixnum ;; time + +)( void "XConvertSelection")) + + + +(defentry XCopyArea( + + fixnum ;; display + fixnum ;; src + fixnum ;; dest + fixnum ;; gc + fixnum ;; src_x + fixnum ;; src_y + fixnum ;; width + fixnum ;; height + fixnum ;; dest_x + fixnum ;; dest_y + +)( void "XCopyArea")) + + + +(defentry XCopyGC( + + fixnum ;; display + fixnum ;; src + fixnum ;; valuemask + fixnum ;; dest + +)( void "XCopyGC")) + + + +(defentry XCopyPlane( + + fixnum ;; display + fixnum ;; src + fixnum ;; dest + fixnum ;; gc + fixnum ;; src_x + fixnum ;; src_y + fixnum ;; width + fixnum ;; height + fixnum ;; dest_x + fixnum ;; dest_y + fixnum ;; plane + +)( void "XCopyPlane")) + + + +(defentry XDefaultDepth( + + fixnum ;; display + fixnum ;; screen_number + +)( fixnum "XDefaultDepth")) + + + +(defentry XDefaultDepthOfScreen( + + fixnum ;; screen + +)( fixnum "XDefaultDepthOfScreen")) + + + +(defentry XDefaultScreen( + + fixnum ;; display + +)( fixnum "XDefaultScreen")) + + + +(defentry XDefineCursor( + + fixnum ;; display + fixnum ;; w + fixnum ;; cursor + +)( void "XDefineCursor")) + + + +(defentry XDeleteProperty( + + fixnum ;; display + fixnum ;; w + fixnum ;; property + +)( void "XDeleteProperty")) + + + +(defentry XDestroyWindow( + + fixnum ;; display + fixnum ;; w + +)( void "XDestroyWindow")) + + + +(defentry XDestroySubwindows( + + fixnum ;; display + fixnum ;; w + +)( void "XDestroySubwindows")) + + + +(defentry XDoesBackingStore( + + fixnum ;; screen + +)( fixnum "XDoesBackingStore")) + + + +(defentry XDoesSaveUnders( + + fixnum ;; screen + +)( fixnum "XDoesSaveUnders")) + + + +(defentry XDisableAccessControl( + + fixnum ;; display + +)( void "XDisableAccessControl")) + + + + +(defentry XDisplayCells( + + fixnum ;; display + fixnum ;; screen_number + +)( fixnum "XDisplayCells")) + + + +(defentry XDisplayHeight( + + fixnum ;; display + fixnum ;; screen_number + +)( fixnum "XDisplayHeight")) + + + +(defentry XDisplayHeightMM( + + fixnum ;; display + fixnum ;; screen_number + +)( fixnum "XDisplayHeightMM")) + + + +(defentry XDisplayKeycodes( + + fixnum ;; display + fixnum ;; min_keycodes_return + fixnum ;; max_keycodes_return + +)( void "XDisplayKeycodes")) + + + +(defentry XDisplayPlanes( + + fixnum ;; display + fixnum ;; screen_number + +)( fixnum "XDisplayPlanes")) + + + +(defentry XDisplayWidth( + + fixnum ;; display + fixnum ;; screen_number + +)( fixnum "XDisplayWidth")) + + + +(defentry XDisplayWidthMM( + + fixnum ;; display + fixnum ;; screen_number + +)( fixnum "XDisplayWidthMM")) + + + +(defentry XDrawArc( + + fixnum ;; display + fixnum ;; d + fixnum ;; gc + fixnum ;; x + fixnum ;; y + fixnum ;; width + fixnum ;; height + fixnum ;; angle1 + fixnum ;; angle2 + +)( void "XDrawArc")) + + + +(defentry XDrawArcs( + + fixnum ;; display + fixnum ;; d + fixnum ;; gc + fixnum ;; arcs + fixnum ;; narcs + +)( void "XDrawArcs")) + + + +(defentry XDrawImageString( + + fixnum ;; display + fixnum ;; d + fixnum ;; gc + fixnum ;; x + fixnum ;; y + object ;; string + fixnum ;; length + +)( void "XDrawImageString")) + + + +(defentry XDrawImageString16( + + fixnum ;; display + fixnum ;; d + fixnum ;; gc + fixnum ;; x + fixnum ;; y + fixnum ;; string + fixnum ;; length + +)( void "XDrawImageString16")) + + + +(defentry XDrawLine( + + fixnum ;; display + fixnum ;; d + fixnum ;; gc + fixnum ;; x1 + fixnum ;; x2 + fixnum ;; y1 + fixnum ;; y2 + +)( void "XDrawLine")) + + + +(defentry XDrawLines( + + fixnum ;; display + fixnum ;; d + fixnum ;; gc + fixnum ;; points + fixnum ;; npoints + fixnum ;; mode + +)( void "XDrawLines")) + + + +(defentry XDrawPoint( + + fixnum ;; display + fixnum ;; d + fixnum ;; gc + fixnum ;; x + fixnum ;; y + +)( void "XDrawPoint")) + + + +(defentry XDrawPoints( + + fixnum ;; display + fixnum ;; d + fixnum ;; gc + fixnum ;; points + fixnum ;; npoints + fixnum ;; mode + +)( void "XDrawPoints")) + + + +(defentry XDrawRectangle( + + fixnum ;; display + fixnum ;; d + fixnum ;; gc + fixnum ;; x + fixnum ;; y + fixnum ;; width + fixnum ;; height + +)( void "XDrawRectangle")) + + + +(defentry XDrawRectangles( + + fixnum ;; display + fixnum ;; d + fixnum ;; gc + fixnum ;; rectangles + fixnum ;; nrectangles + +)( void "XDrawRectangles")) + + + +(defentry XDrawSegments( + + fixnum ;; display + fixnum ;; d + fixnum ;; gc + fixnum ;; segments + fixnum ;; nsegments + +)( void "XDrawSegments")) + + + +(defentry XDrawString( + + fixnum ;; display + fixnum ;; d + fixnum ;; gc + fixnum ;; x + fixnum ;; y + object ;; string + fixnum ;; length + +)( void "XDrawString")) + + + +(defentry XDrawString16( + + fixnum ;; display + fixnum ;; d + fixnum ;; gc + fixnum ;; x + fixnum ;; y + fixnum ;; string + fixnum ;; length + +)( void "XDrawString16")) + + + +(defentry XDrawText( + + fixnum ;; display + fixnum ;; d + fixnum ;; gc + fixnum ;; x + fixnum ;; y + fixnum ;; items + fixnum ;; nitems + +)( void "XDrawText")) + + + +(defentry XDrawText16( + + fixnum ;; display + fixnum ;; d + fixnum ;; gc + fixnum ;; x + fixnum ;; y + fixnum ;; items + fixnum ;; nitems + +)( void "XDrawText16")) + + + +(defentry XEnableAccessControl( + + fixnum ;; display + +)( void "XEnableAccessControl")) + + + +(defentry XEventsQueued( + + fixnum ;; display + fixnum ;; mode + +)( fixnum "XEventsQueued")) + + + +(defentry XFetchName( + + fixnum ;; display + fixnum ;; w + fixnum ;; window_name_return + +)( fixnum "XFetchName")) + + + +(defentry XFillArc( + + fixnum ;; display + fixnum ;; d + fixnum ;; gc + fixnum ;; x + fixnum ;; y + fixnum ;; width + fixnum ;; height + fixnum ;; angle1 + fixnum ;; angle2 + +)( void "XFillArc")) + + + +(defentry XFillArcs( + + fixnum ;; display + fixnum ;; d + fixnum ;; gc + fixnum ;; arcs + fixnum ;; narcs + +)( void "XFillArcs")) + + + +(defentry XFillPolygon( + + fixnum ;; display + fixnum ;; d + fixnum ;; gc + fixnum ;; points + fixnum ;; npoints + fixnum ;; shape + fixnum ;; mode + +)( void "XFillPolygon")) + + + +(defentry XFillRectangle( + + fixnum ;; display + fixnum ;; d + fixnum ;; gc + fixnum ;; x + fixnum ;; y + fixnum ;; width + fixnum ;; height + +)( void "XFillRectangle")) + + + +(defentry XFillRectangles( + + fixnum ;; display + fixnum ;; d + fixnum ;; gc + fixnum ;; rectangles + fixnum ;; nrectangles + +)( void "XFillRectangles")) + + + +(defentry XFlush( + + fixnum ;; display + +)( void "XFlush")) + + + +(defentry XForceScreenSaver( + + fixnum ;; display + fixnum ;; mode + +)( void "XForceScreenSaver")) + + + +(defentry XFree( + + object ;; data + +)( void "XFree")) + + + +(defentry XFreeColormap( + + fixnum ;; display + fixnum ;; colormap + +)( void "XFreeColormap")) + + + +(defentry XFreeColors( + + fixnum ;; display + fixnum ;; colormap + fixnum ;; pixels + fixnum ;; npixels + fixnum ;; planes + +)( void "XFreeColors")) + + + +(defentry XFreeCursor( + + fixnum ;; display + fixnum ;; cursor + +)( void "XFreeCursor")) + + + +(defentry XFreeExtensionList( + + fixnum ;; list + +)( void "XFreeExtensionList")) + + + +(defentry XFreeFont( + + fixnum ;; display + fixnum ;; font_struct + +)( void "XFreeFont")) + + + +(defentry XFreeFontInfo( + + fixnum ;; names + fixnum ;; free_info + fixnum ;; actual_count + +)( void "XFreeFontInfo")) + + + +(defentry XFreeFontNames( + + fixnum ;; list + +)( void "XFreeFontNames")) + + + +(defentry XFreeFontPath( + + fixnum ;; list + +)( void "XFreeFontPath")) + + + +(defentry XFreeGC( + + fixnum ;; display + fixnum ;; gc + +)( void "XFreeGC")) + + + +(defentry XFreeModifiermap( + + fixnum ;; modmap + +)( void "XFreeModifiermap")) + + + +(defentry XFreePixmap( + + fixnum ;; display + fixnum ;; fixnum + +)( void "XFreePixmap")) + + + +(defentry XGeometry( + + fixnum ;; display + fixnum ;; screen + object ;; position + object ;; default_position + fixnum ;; bwidth + fixnum ;; fwidth + fixnum ;; fheight + fixnum ;; xadder + fixnum ;; yadder + fixnum ;; x_return + fixnum ;; y_return + fixnum ;; width_return + fixnum ;; height_return + +)( fixnum "XGeometry")) + + + +(defentry XGetErrorDatabaseText( + + fixnum ;; display + object ;; name + object ;; message + object ;; default_string + object ;; buffer_return + fixnum ;; length + +)( void "XGetErrorDatabaseText")) + + + +(defentry XGetErrorText( + + fixnum ;; display + fixnum ;; code + object ;; buffer_return + fixnum ;; length + +)( void "XGetErrorText")) + + + +(defentry XGetFontProperty( + + fixnum ;; font_struct + fixnum ;; atom + fixnum ;; value_return + +)( fixnum "XGetFontProperty")) + + + +(defentry XGetGCValues( + + fixnum ;; display + fixnum ;; gc + fixnum ;; valuemask + fixnum ;; values_return + +)( fixnum "XGetGCValues")) + + + +(defentry XGetGeometry( + + fixnum ;; display + fixnum ;; d + fixnum ;; root_return + fixnum ;; x_return + fixnum ;; y_return + fixnum ;; width_return + fixnum ;; height_return + fixnum ;; border_width_return + fixnum ;; depth_return + +)( fixnum "XGetGeometry")) + + + +(defentry XGetIconName( + + fixnum ;; display + fixnum ;; w + fixnum ;; icon_name_return + +)( fixnum "XGetIconName")) + + + +(defentry XGetInputFocus( + + fixnum ;; display + fixnum ;; focus_return + fixnum ;; revert_to_return + +)( void "XGetInputFocus")) + + + +(defentry XGetKeyboardControl( + + fixnum ;; display + fixnum ;; values_return + +)( void "XGetKeyboardControl")) + + + +(defentry XGetPointerControl( + + fixnum ;; display + fixnum ;; accel_numerator_return + fixnum ;; accel_denominator_return + fixnum ;; threshold_return + +)( void "XGetPointerControl")) + + + +(defentry XGetPointerMapping( + + fixnum ;; display + object ;; map_return + fixnum ;; nmap + +)( fixnum "XGetPointerMapping")) + + + +(defentry XGetScreenSaver( + + fixnum ;; display + fixnum ;; intout_return + fixnum ;; interval_return + fixnum ;; prefer_blanking_return + fixnum ;; allow_exposures_return + +)( void "XGetScreenSaver")) + + + +(defentry XGetTransientForHint( + + fixnum ;; display + fixnum ;; w + fixnum ;; prop_window_return + +)( fixnum "XGetTransientForHint")) + + + +(defentry XGetWindowProperty( + + fixnum ;; display + fixnum ;; w + fixnum ;; property + fixnum ;; int_offset + fixnum ;; int_length + fixnum ;; delete + fixnum ;; req_type + fixnum ;; actual_type_return + fixnum ;; actual_format_return + fixnum ;; nitems_return + fixnum ;; bytes_after_return + fixnum ;; prop_return + +)( fixnum "XGetWindowProperty")) + + + +(defentry XGetWindowAttributes( + + fixnum ;; display + fixnum ;; w + fixnum ;; Window_attributes_return + +)( fixnum "XGetWindowAttributes")) + + + +(defentry XGrabButton( + + fixnum ;; display + fixnum ;; button + fixnum ;; modifiers + fixnum ;; grab_window + fixnum ;; owner_events + fixnum ;; event_mask + fixnum ;; pointer_mode + fixnum ;; keyboard_mode + fixnum ;; confine_to + fixnum ;; cursor + +)( void "XGrabButton")) + + + +(defentry XGrabKey( + + fixnum ;; display + fixnum ;; keycode + fixnum ;; modifiers + fixnum ;; grab_window + fixnum ;; owner_events + fixnum ;; pointer_mode + fixnum ;; keyboard_mode + +)( void "XGrabKey")) + + + +(defentry XGrabKeyboard( + + fixnum ;; display + fixnum ;; grab_window + fixnum ;; owner_events + fixnum ;; pointer_mode + fixnum ;; keyboard_mode + fixnum ;; fixnum + +)( fixnum "XGrabKeyboard")) + + + +(defentry XGrabPointer( + + fixnum ;; display + fixnum ;; grab_window + fixnum ;; owner_events + fixnum ;; event_mask + fixnum ;; pointer_mode + fixnum ;; keyboard_mode + fixnum ;; confine_to + fixnum ;; cursor + fixnum ;; fixnum + +)( fixnum "XGrabPointer")) + + + +(defentry XGrabServer( + + fixnum ;; display + +)( void "XGrabServer")) + + + +(defentry XHeightMMOfScreen( + + fixnum ;; screen + +)( fixnum "XHeightMMOfScreen")) + + + +(defentry XHeightOfScreen( + + fixnum ;; screen + +)( fixnum "XHeightOfScreen")) + + + +(defentry XImageByteOrder( + + fixnum ;; display + +)( fixnum "XImageByteOrder")) + + + +(defentry XInstallColormap( + + fixnum ;; display + fixnum ;; colormap + +)( void "XInstallColormap")) + + + +(defentry XKeysymToKeycode( + + fixnum ;; display + fixnum ;; keysym + +)( fixnum "XKeysymToKeycode")) + + + +(defentry XKillClient( + + fixnum ;; display + fixnum ;; resource + +)( void "XKillClient")) + + + +(defentry XLookupColor( + + fixnum ;; display + fixnum ;; colormap + object ;; color_name + fixnum ;; exact_def_return + fixnum ;; screen_def_return + +)( fixnum "XLookupColor")) + + + +(defentry XLowerWindow( + + fixnum ;; display + fixnum ;; w + +)( void "XLowerWindow")) + + + +(defentry XMapRaised( + + fixnum ;; display + fixnum ;; w + +)( void "XMapRaised")) + + + +(defentry XMapSubwindows( + + fixnum ;; display + fixnum ;; w + +)( void "XMapSubwindows")) + + + +(defentry XMapWindow( + + fixnum ;; display + fixnum ;; w + +)( void "XMapWindow")) + + + +(defentry XMaskEvent( + + fixnum ;; display + fixnum ;; event_mask + fixnum ;; event_return + +)( void "XMaskEvent")) + + + +(defentry XMaxCmapsOfScreen( + + fixnum ;; screen + +)( fixnum "XMaxCmapsOfScreen")) + + + +(defentry XMinCmapsOfScreen( + + fixnum ;; screen + +)( fixnum "XMinCmapsOfScreen")) + + + +(defentry XMoveResizeWindow( + + fixnum ;; display + fixnum ;; w + fixnum ;; x + fixnum ;; y + fixnum ;; width + fixnum ;; height + +)( void "XMoveResizeWindow")) + + + +(defentry XMoveWindow( + + fixnum ;; display + fixnum ;; w + fixnum ;; x + fixnum ;; y + +)( void "XMoveWindow")) + + + +(defentry XNextEvent( + + fixnum ;; display + fixnum ;; event_return + +)( void "XNextEvent")) + + + +(defentry XNoOp( + + fixnum ;; display + +)( void "XNoOp")) + + + +(defentry XParseColor( + + fixnum ;; display + fixnum ;; colormap + object ;; spec + fixnum ;; exact_def_return + +)( fixnum "XParseColor")) + + + +(defentry XParseGeometry( + + object ;; parsestring + fixnum ;; x_return + fixnum ;; y_return + fixnum ;; width_return + fixnum ;; height_return + +)( fixnum "XParseGeometry")) + + + +(defentry XPeekEvent( + + fixnum ;; display + fixnum ;; event_return + +)( void "XPeekEvent")) + + + + +(defentry XPending( + + fixnum ;; display + +)( fixnum "XPending")) + + + +(defentry XPlanesOfScreen( + + fixnum ;; screen + + +)( fixnum "XPlanesOfScreen")) + + + +(defentry XProtocolRevision( + + fixnum ;; display + +)( fixnum "XProtocolRevision")) + + + +(defentry XProtocolVersion( + + fixnum ;; display + +)( fixnum "XProtocolVersion")) + + + + +(defentry XPutBackEvent( + + fixnum ;; display + fixnum ;; event + +)( void "XPutBackEvent")) + + + +(defentry XPutImage( + + fixnum ;; display + fixnum ;; d + fixnum ;; gc + fixnum ;; image + fixnum ;; src_x + fixnum ;; src_y + fixnum ;; dest_x + fixnum ;; dest_y + fixnum ;; width + fixnum ;; height + +)( void "XPutImage")) + + + +(defentry XQLength( + + fixnum ;; display + +)( fixnum "XQLength")) + + + +(defentry XQueryBestCursor( + + fixnum ;; display + fixnum ;; d + fixnum ;; width + fixnum ;; height + fixnum ;; width_return + fixnum ;; height_return + +)( fixnum "XQueryBestCursor")) + + + +(defentry XQueryBestSize( + + fixnum ;; display + fixnum ;; class + fixnum ;; which_screen + fixnum ;; width + fixnum ;; height + fixnum ;; width_return + fixnum ;; height_return + +)( fixnum "XQueryBestSize")) + + + +(defentry XQueryBestStipple( + + fixnum ;; display + fixnum ;; which_screen + fixnum ;; width + fixnum ;; height + fixnum ;; width_return + fixnum ;; height_return + +)( fixnum "XQueryBestStipple")) + + + +(defentry XQueryBestTile( + + fixnum ;; display + fixnum ;; which_screen + fixnum ;; width + fixnum ;; height + fixnum ;; width_return + fixnum ;; height_return + +)( fixnum "XQueryBestTile")) + + + +(defentry XQueryColor( + + fixnum ;; display + fixnum ;; colormap + fixnum ;; def_in_out + +)( void "XQueryColor")) + + + +(defentry XQueryColors( + + fixnum ;; display + fixnum ;; colormap + fixnum ;; defs_in_out + fixnum ;; ncolors + +)( void "XQueryColors")) + + + +(defentry XQueryExtension( + + fixnum ;; display + object ;; name + fixnum ;; major_opcode_return + fixnum ;; first_event_return + fixnum ;; first_error_return + +)( fixnum "XQueryExtension")) + + +;;fix +(defentry XQueryKeymap( + + fixnum ;; display + fixnum ;; keys_return + +)( void "XQueryKeymap")) + + + +(defentry XQueryPointer( + + fixnum ;; display + fixnum ;; w + fixnum ;; root_return + fixnum ;; child_return + fixnum ;; root_x_return + fixnum ;; root_y_return + fixnum ;; win_x_return + fixnum ;; win_y_return + fixnum ;; mask_return + +)( fixnum "XQueryPointer")) + + + +(defentry XQueryTextExtents( + + fixnum ;; display + fixnum ;; font_ID + object ;; string + fixnum ;; nchars + fixnum ;; direction_return + fixnum ;; font_ascent_return + fixnum ;; font_descent_return + fixnum ;; overall_return + +)( void "XQueryTextExtents")) + + + +(defentry XQueryTextExtents16( + + fixnum ;; display + fixnum ;; font_ID + fixnum ;; string + fixnum ;; nchars + fixnum ;; direction_return + fixnum ;; font_ascent_return + fixnum ;; font_descent_return + fixnum ;; overall_return + +)( void "XQueryTextExtents16")) + + + +(defentry XQueryTree( + + fixnum ;; display + fixnum ;; w + fixnum ;; root_return + fixnum ;; parent_return + fixnum ;; children_return + fixnum ;; nchildren_return + +)( fixnum "XQueryTree")) + + + +(defentry XRaiseWindow( + + fixnum ;; display + fixnum ;; w + +)( void "XRaiseWindow")) + + + +(defentry XReadBitmapFile( + + fixnum ;; display + fixnum ;; d + object ;; filename + fixnum ;; width_return + fixnum ;; height_return + fixnum ;; bitmap_return + fixnum ;; x_hot_return + fixnum ;; y_hot_return + +)( fixnum "XReadBitmapFile")) + + + +(defentry XRebindKeysym( + + fixnum ;; display + fixnum ;; keysym + fixnum ;; list + fixnum ;; mod_count + object ;; string + fixnum ;; bytes_string + +)( void "XRebindKeysym")) + + + +(defentry XRecolorCursor( + + fixnum ;; display + fixnum ;; cursor + fixnum ;; foreground_color + fixnum ;; background_color + +)( void "XRecolorCursor")) + + + +(defentry XRefreshKeyboardMapping( + + fixnum ;; event_map + +)( void "XRefreshKeyboardMapping")) + + + +(defentry XRemoveFromSaveSet( + + fixnum ;; display + fixnum ;; w + +)( void "XRemoveFromSaveSet")) + + + +(defentry XRemoveHost( + + fixnum ;; display + fixnum ;; host + +)( void "XRemoveHost")) + + + +(defentry XRemoveHosts( + + fixnum ;; display + fixnum ;; hosts + fixnum ;; num_hosts + +)( void "XRemoveHosts")) + + + +(defentry XReparentWindow( + + fixnum ;; display + fixnum ;; w + fixnum ;; parent + fixnum ;; x + fixnum ;; y + +)( void "XReparentWindow")) + + + +(defentry XResetScreenSaver( + + fixnum ;; display + +)( void "XResetScreenSaver")) + + + +(defentry XResizeWindow( + + fixnum ;; display + fixnum ;; w + fixnum ;; width + fixnum ;; height + +)( void "XResizeWindow")) + + + +(defentry XRestackWindows( + + fixnum ;; display + fixnum ;; windows + fixnum ;; nwindows + +)( void "XRestackWindows")) + + + +(defentry XRotateBuffers( + + fixnum ;; display + fixnum ;; rotate + +)( void "XRotateBuffers")) + + + +(defentry XRotateWindowProperties( + + fixnum ;; display + fixnum ;; w + fixnum ;; properties + fixnum ;; num_prop + fixnum ;; npositions + +)( void "XRotateWindowProperties")) + + + +(defentry XScreenCount( + + fixnum ;; display + +)( fixnum "XScreenCount")) + + + +(defentry XSelectInput( + + fixnum ;; display + fixnum ;; w + fixnum ;; event_mask + +)( void "XSelectInput")) + + + +(defentry XSendEvent( + + fixnum ;; display + fixnum ;; w + fixnum ;; propagate + fixnum ;; event_mask + fixnum ;; event_send + +)( fixnum "XSendEvent")) + + + +(defentry XSetAccessControl( + + fixnum ;; display + fixnum ;; mode + +)( void "XSetAccessControl")) + + + +(defentry XSetArcMode( + + fixnum ;; display + fixnum ;; gc + fixnum ;; arc_mode + +)( void "XSetArcMode")) + + + +(defentry XSetBackground( + + fixnum ;; display + fixnum ;; gc + fixnum ;; background + +)( void "XSetBackground")) + + + +(defentry XSetClipMask( + + fixnum ;; display + fixnum ;; gc + fixnum ;; fixnum + +)( void "XSetClipMask")) + + + +(defentry XSetClipOrigin( + + fixnum ;; display + fixnum ;; gc + fixnum ;; clip_x_origin + fixnum ;; clip_y_origin + +)( void "XSetClipOrigin")) + + + +(defentry XSetClipRectangles( + + fixnum ;; display + fixnum ;; gc + fixnum ;; clip_x_origin + fixnum ;; clip_y_origin + fixnum ;; rectangles + fixnum ;; n + fixnum ;; ordering + +)( void "XSetClipRectangles")) + + + +(defentry XSetCloseDownMode( + + fixnum ;; display + fixnum ;; close_mode + +)( void "XSetCloseDownMode")) + + + +(defentry XSetCommand( + + fixnum ;; display + fixnum ;; w + fixnum ;; argv + fixnum ;; argc + +)( void "XSetCommand")) + + + +(defentry XSetDashes( + + fixnum ;; display + fixnum ;; gc + fixnum ;; dash_offset + object ;; dash_list + fixnum ;; n + +)( void "XSetDashes")) + + + +(defentry XSetFillRule( + + fixnum ;; display + fixnum ;; gc + fixnum ;; fill_rule + +)( void "XSetFillRule")) + + + +(defentry XSetFillStyle( + + fixnum ;; display + fixnum ;; gc + fixnum ;; fill_style + +)( void "XSetFillStyle")) + + + +(defentry XSetFont( + + fixnum ;; display + fixnum ;; gc + fixnum ;; font + +)( void "XSetFont")) + + + +(defentry XSetFontPath( + + fixnum ;; display + fixnum ;; directories + fixnum ;; ndirs + +)( void "XSetFontPath")) + + + +(defentry XSetForeground( + + fixnum ;; display + fixnum ;; gc + fixnum ;; foreground + +)( void "XSetForeground")) + + + +(defentry XSetFunction( + + fixnum ;; display + fixnum ;; gc + fixnum ;; function + +)( void "XSetFunction")) + + + +(defentry XSetGraphicsExposures( + + fixnum ;; display + fixnum ;; gc + fixnum ;; graphics_exposures + +)( void "XSetGraphicsExposures")) + + + +(defentry XSetIconName( + + fixnum ;; display + fixnum ;; w + object ;; icon_name + +)( void "XSetIconName")) + + + +(defentry XSetInputFocus( + + fixnum ;; display + fixnum ;; focus + fixnum ;; revert_to + fixnum ;; fixnum + +)( void "XSetInputFocus")) + + + +(defentry XSetLineAttributes( + + fixnum ;; display + fixnum ;; gc + fixnum ;; line_width + fixnum ;; line_style + fixnum ;; cap_style + fixnum ;; join_style + +)( void "XSetLineAttributes")) + + + +(defentry XSetModifierMapping( + + fixnum ;; display + fixnum ;; modmap + +)( fixnum "XSetModifierMapping")) + + + +(defentry XSetPlaneMask( + + fixnum ;; display + fixnum ;; gc + fixnum ;; plane_mask + +)( void "XSetPlaneMask")) + + + +(defentry XSetPointerMapping( + + fixnum ;; display + object ;; map + fixnum ;; nmap + +)( fixnum "XSetPointerMapping")) + + + +(defentry XSetScreenSaver( + + fixnum ;; display + fixnum ;; intout + fixnum ;; interval + fixnum ;; prefer_blanking + fixnum ;; allow_exposures + +)( void "XSetScreenSaver")) + + + +(defentry XSetSelectionOwner( + + fixnum ;; display + fixnum ;; selection + fixnum ;; owner + fixnum ;; fixnum + +)( void "XSetSelectionOwner")) + + + +(defentry XSetState( + + fixnum ;; display + fixnum ;; gc + fixnum ;; foreground + fixnum ;; background + fixnum ;; function + fixnum ;; plane_mask + +)( void "XSetState")) + + + +(defentry XSetStipple( + + fixnum ;; display + fixnum ;; gc + fixnum ;; stipple + +)( void "XSetStipple")) + + + +(defentry XSetSubwindowMode( + + fixnum ;; display + fixnum ;; gc + fixnum ;; subwindow_mode + +)( void "XSetSubwindowMode")) + + + +(defentry XSetTSOrigin( + + fixnum ;; display + fixnum ;; gc + fixnum ;; ts_x_origin + fixnum ;; ts_y_origin + +)( void "XSetTSOrigin")) + + + +(defentry XSetTile( + + fixnum ;; display + fixnum ;; gc + fixnum ;; tile + +)( void "XSetTile")) + + + +(defentry XSetWindowBackground( + + fixnum ;; display + fixnum ;; w + fixnum ;; background_pixel + +)( void "XSetWindowBackground")) + + + +(defentry XSetWindowBackgroundPixmap( + + fixnum ;; display + fixnum ;; w + fixnum ;; background_pixmap + +)( void "XSetWindowBackgroundPixmap")) + + + +(defentry XSetWindowBorder( + + fixnum ;; display + fixnum ;; w + fixnum ;; border_pixel + +)( void "XSetWindowBorder")) + + + +(defentry XSetWindowBorderPixmap( + + fixnum ;; display + fixnum ;; w + fixnum ;; border_pixmap + +)( void "XSetWindowBorderPixmap")) + + + +(defentry XSetWindowBorderWidth( + + fixnum ;; display + fixnum ;; w + fixnum ;; width + +)( void "XSetWindowBorderWidth")) + + + +(defentry XSetWindowColormap( + + fixnum ;; display + fixnum ;; w + fixnum ;; colormap + +)( void "XSetWindowColormap")) + + + +(defentry XStoreBuffer( + + fixnum ;; display + object ;; bytes + fixnum ;; nbytes + fixnum ;; buffer + +)( void "XStoreBuffer")) + + + +(defentry XStoreBytes( + + fixnum ;; display + object ;; bytes + fixnum ;; nbytes + +)( void "XStoreBytes")) + + + +(defentry XStoreColor( + + fixnum ;; display + fixnum ;; colormap + fixnum ;; color + +)( void "XStoreColor")) + + + +(defentry XStoreColors( + + fixnum ;; display + fixnum ;; colormap + fixnum ;; color + fixnum ;; ncolors + +)( void "XStoreColors")) + + + +(defentry XStoreName( + + fixnum ;; display + fixnum ;; w + object ;; window_name + +)( void "XStoreName")) + + + +(defentry XStoreNamedColor( + + fixnum ;; display + fixnum ;; colormap + object ;; color + fixnum ;; pixel + fixnum ;; flags + +)( void "XStoreNamedColor")) + + + +(defentry XSync( + + fixnum ;; display + fixnum ;; discard + +)( void "XSync")) + + + +(defentry XTextExtents( + + fixnum ;; font_struct + object ;; string + fixnum ;; nchars + fixnum ;; direction_return + fixnum ;; font_ascent_return + fixnum ;; font_descent_return + fixnum ;; overall_return + +)( void "XTextExtents")) + + + +(defentry XTextExtents16( + + fixnum ;; font_struct + fixnum ;; string + fixnum ;; nchars + fixnum ;; direction_return + fixnum ;; font_ascent_return + fixnum ;; font_descent_return + fixnum ;; overall_return + +)( void "XTextExtents16")) + + + +(defentry XTextWidth( + + fixnum ;; font_struct + object ;; string + fixnum ;; count + +)( fixnum "XTextWidth")) + + + +(defentry XTextWidth16( + + fixnum ;; font_struct + fixnum ;; string + fixnum ;; count + +)( fixnum "XTextWidth16")) + + + +(defentry XTranslateCoordinates( + + fixnum ;; display + fixnum ;; src_w + fixnum ;; dest_w + fixnum ;; src_x + fixnum ;; src_y + fixnum ;; dest_x_return + fixnum ;; dest_y_return + fixnum ;; child_return + +)( fixnum "XTranslateCoordinates")) + + + +(defentry XUndefineCursor( + + fixnum ;; display + fixnum ;; w + +)( void "XUndefineCursor")) + + + +(defentry XUngrabButton( + + fixnum ;; display + fixnum ;; button + fixnum ;; modifiers + fixnum ;; grab_window + +)( void "XUngrabButton")) + + + +(defentry XUngrabKey( + + fixnum ;; display + fixnum ;; keycode + fixnum ;; modifiers + fixnum ;; grab_window + +)( void "XUngrabKey")) + + + +(defentry XUngrabKeyboard( + + fixnum ;; display + fixnum ;; fixnum + +)( void "XUngrabKeyboard")) + + + +(defentry XUngrabPointer( + + fixnum ;; display + fixnum ;; fixnum + +)( void "XUngrabPointer")) + + + +(defentry XUngrabServer( + + fixnum ;; display + +)( void "XUngrabServer")) + + + +(defentry XUninstallColormap( + + fixnum ;; display + fixnum ;; colormap + +)( void "XUninstallColormap")) + + + +(defentry XUnloadFont( + + fixnum ;; display + fixnum ;; font + +)( void "XUnloadFont")) + + + +(defentry XUnmapSubwindows( + + fixnum ;; display + fixnum ;; w + +)( void "XUnmapSubwindows")) + + + +(defentry XUnmapWindow( + + fixnum ;; display + fixnum ;; w + +)( void "XUnmapWindow")) + + + +(defentry XVendorRelease( + + fixnum ;; display + +)( fixnum "XVendorRelease")) + + + +(defentry XWarpPointer( + + fixnum ;; display + fixnum ;; src_w + fixnum ;; dest_w + fixnum ;; src_x + fixnum ;; src_y + fixnum ;; src_width + fixnum ;; src_height + fixnum ;; dest_x + fixnum ;; dest_y + +)( void "XWarpPointer")) + + + +(defentry XWidthMMOfScreen( + + fixnum ;; screen + +)( fixnum "XWidthMMOfScreen")) + + + +(defentry XWidthOfScreen( + + fixnum ;; screen + +)( fixnum "XWidthOfScreen")) + + + +(defentry XWindowEvent( + + fixnum ;; display + fixnum ;; w + fixnum ;; event_mask + fixnum ;; event_return + +)( void "XWindowEvent")) + + + +(defentry XWriteBitmapFile( + + fixnum ;; display + object ;; filename + fixnum ;; bitmap + fixnum ;; width + fixnum ;; height + fixnum ;; x_hot + fixnum ;; y_hot + +)( fixnum "XWriteBitmapFile")) + + + +;;;;;;;;;problems + + + + +;;(defentry fixnum (int Synchronize( + +;; fixnum ;; display +;; fixnum ;; onoff + +;;))()()) +;;(defentry fixnum (int SetAfterFunction( + +;; fixnum ;; display +;; fixnum (int ( fixnum ;; display +;; ) ;; procedure + +;;))()()) + + +;;(defentry void XPeekIfEvent( + +;; fixnum ;; display +;; fixnum ;; event_return +;; fixnum (int ( fixnum ;; display +;; fixnum ;; event +;; object ;; arg +;; ) ;; predicate +;; object ;; arg + +;;)()) + +;;(defentry fixnum XCheckIfEvent( + +;; fixnum ;; display +;; fixnum ;; event_return +;; fixnum (int ( fixnum ;; display +;; fixnum ;; event +;; object ;; arg +;; ) ;; predicate +;; object ;; arg + +;;)()) + +;;(defentry void XIfEvent( + +;; fixnum ;; display +;; fixnum ;; event_return +;; fixnum (int ( fixnum ;; display +;; fixnum ;; event +;; object ;; arg +;; ) ;; predicate +;; object ;; arg + +;;)()) diff --git a/xgcl-2/gcl_Xstruct.lsp b/xgcl-2/gcl_Xstruct.lsp new file mode 100644 index 0000000..d8dd1d1 --- /dev/null +++ b/xgcl-2/gcl_Xstruct.lsp @@ -0,0 +1,311 @@ +(in-package :XLIB) +; Xstruct.lsp Hiep Huu Nguyen 27 Aug 92 + +; Copyright (c) 1994 Hiep Huu Nguyen and The University of Texas at Austin. + +; See the files gnu.license and dec.copyright . + +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 1, or (at your option) +; any later version. + +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +; Some of the files that interface to the Xlib are adapted from DEC/MIT files. +; See the file dec.copyright for details. + + + + +;;;;;; _XQEvent funcions ;;;;;; + +(defentry make-_XQEvent () ( fixnum "make__XQEvent" )) +(defentry _XQEvent-event (fixnum) ( fixnum "_XQEvent_event" )) +(defentry set-_XQEvent-event (fixnum fixnum) ( void "set__XQEvent_event" )) +(defentry _XQEvent-next (fixnum) ( fixnum "_XQEvent_next" )) +(defentry set-_XQEvent-next (fixnum fixnum) ( void "set__XQEvent_next" )) + + +;;;;;; XCharStruct funcions ;;;;;; + +(defentry make-XCharStruct () ( fixnum "make_XCharStruct" )) +(defentry XCharStruct-attributes (fixnum) ( fixnum "XCharStruct_attributes" )) +(defentry set-XCharStruct-attributes (fixnum fixnum) ( void "set_XCharStruct_attributes" )) +(defentry XCharStruct-descent (fixnum) ( fixnum "XCharStruct_descent" )) +(defentry set-XCharStruct-descent (fixnum fixnum) ( void "set_XCharStruct_descent" )) +(defentry XCharStruct-ascent (fixnum) ( fixnum "XCharStruct_ascent" )) +(defentry set-XCharStruct-ascent (fixnum fixnum) ( void "set_XCharStruct_ascent" )) +(defentry XCharStruct-width (fixnum) ( fixnum "XCharStruct_width" )) +(defentry set-XCharStruct-width (fixnum fixnum) ( void "set_XCharStruct_width" )) +(defentry XCharStruct-rbearing (fixnum) ( fixnum "XCharStruct_rbearing" )) +(defentry set-XCharStruct-rbearing (fixnum fixnum) ( void "set_XCharStruct_rbearing" )) +(defentry XCharStruct-lbearing (fixnum) ( fixnum "XCharStruct_lbearing" )) +(defentry set-XCharStruct-lbearing (fixnum fixnum) ( void "set_XCharStruct_lbearing" )) + + +;;;;;; XFontProp funcions ;;;;;; + +(defentry make-XFontProp () ( fixnum "make_XFontProp" )) +(defentry XFontProp-card32 (fixnum) ( fixnum "XFontProp_card32" )) +(defentry set-XFontProp-card32 (fixnum fixnum) ( void "set_XFontProp_card32" )) +(defentry XFontProp-name (fixnum) ( fixnum "XFontProp_name" )) +(defentry set-XFontProp-name (fixnum fixnum) ( void "set_XFontProp_name" )) + + +;;;;;; XFontStruct funcions ;;;;;; + +(defentry make-XFontStruct () ( fixnum "make_XFontStruct" )) +(defentry XFontStruct-descent (fixnum) ( fixnum "XFontStruct_descent" )) +(defentry set-XFontStruct-descent (fixnum fixnum) ( void "set_XFontStruct_descent" )) +(defentry XFontStruct-ascent (fixnum) ( fixnum "XFontStruct_ascent" )) +(defentry set-XFontStruct-ascent (fixnum fixnum) ( void "set_XFontStruct_ascent" )) +(defentry XFontStruct-per_char (fixnum) ( fixnum "XFontStruct_per_char" )) +(defentry set-XFontStruct-per_char (fixnum fixnum) ( void "set_XFontStruct_per_char" )) +(defentry XFontStruct-max_bounds (fixnum) ( fixnum "XFontStruct_max_bounds" )) +(defentry set-XFontStruct-max_bounds (fixnum fixnum) ( void "set_XFontStruct_max_bounds" )) +(defentry XFontStruct-min_bounds (fixnum) ( fixnum "XFontStruct_min_bounds" )) +(defentry set-XFontStruct-min_bounds (fixnum fixnum) ( void "set_XFontStruct_min_bounds" )) +(defentry XFontStruct-properties (fixnum) ( fixnum "XFontStruct_properties" )) +(defentry set-XFontStruct-properties (fixnum fixnum) ( void "set_XFontStruct_properties" )) +(defentry XFontStruct-n_properties (fixnum) ( fixnum "XFontStruct_n_properties" )) +(defentry set-XFontStruct-n_properties (fixnum fixnum) ( void "set_XFontStruct_n_properties" )) +(defentry XFontStruct-default_char (fixnum) ( fixnum "XFontStruct_default_char" )) +(defentry set-XFontStruct-default_char (fixnum fixnum) ( void "set_XFontStruct_default_char" )) +(defentry XFontStruct-all_chars_exist (fixnum) ( fixnum "XFontStruct_all_chars_exist" )) +(defentry set-XFontStruct-all_chars_exist (fixnum fixnum) ( void "set_XFontStruct_all_chars_exist" )) +(defentry XFontStruct-max_byte1 (fixnum) ( fixnum "XFontStruct_max_byte1" )) +(defentry set-XFontStruct-max_byte1 (fixnum fixnum) ( void "set_XFontStruct_max_byte1" )) +(defentry XFontStruct-min_byte1 (fixnum) ( fixnum "XFontStruct_min_byte1" )) +(defentry set-XFontStruct-min_byte1 (fixnum fixnum) ( void "set_XFontStruct_min_byte1" )) +(defentry XFontStruct-max_char_or_byte2 (fixnum) ( fixnum "XFontStruct_max_char_or_byte2" )) +(defentry set-XFontStruct-max_char_or_byte2 (fixnum fixnum) ( void "set_XFontStruct_max_char_or_byte2" )) +(defentry XFontStruct-min_char_or_byte2 (fixnum) ( fixnum "XFontStruct_min_char_or_byte2" )) +(defentry set-XFontStruct-min_char_or_byte2 (fixnum fixnum) ( void "set_XFontStruct_min_char_or_byte2" )) +(defentry XFontStruct-direction (fixnum) ( fixnum "XFontStruct_direction" )) +(defentry set-XFontStruct-direction (fixnum fixnum) ( void "set_XFontStruct_direction" )) +(defentry XFontStruct-fid (fixnum) ( fixnum "XFontStruct_fid" )) +(defentry set-XFontStruct-fid (fixnum fixnum) ( void "set_XFontStruct_fid" )) +(defentry XFontStruct-ext_data (fixnum) ( fixnum "XFontStruct_ext_data" )) +(defentry set-XFontStruct-ext_data (fixnum fixnum) ( void "set_XFontStruct_ext_data" )) + + +;;;;;; XTextItem funcions ;;;;;; + +(defentry make-XTextItem () ( fixnum "make_XTextItem" )) +(defentry XTextItem-font (fixnum) ( fixnum "XTextItem_font" )) +(defentry set-XTextItem-font (fixnum fixnum) ( void "set_XTextItem_font" )) +(defentry XTextItem-delta (fixnum) ( fixnum "XTextItem_delta" )) +(defentry set-XTextItem-delta (fixnum fixnum) ( void "set_XTextItem_delta" )) +(defentry XTextItem-nchars (fixnum) ( fixnum "XTextItem_nchars" )) +(defentry set-XTextItem-nchars (fixnum fixnum) ( void "set_XTextItem_nchars" )) +(defentry XTextItem-chars (fixnum) ( fixnum "XTextItem_chars" )) +(defentry set-XTextItem-chars (fixnum fixnum) ( void "set_XTextItem_chars" )) + + +;;;;;; XChar2b funcions ;;;;;; + +(defentry make-XChar2b () ( fixnum "make_XChar2b" )) +(defentry XChar2b-byte2 (fixnum) ( char "XChar2b_byte2" )) +(defentry set-XChar2b-byte2 (fixnum char) ( void "set_XChar2b_byte2" )) +(defentry XChar2b-byte1 (fixnum) ( char "XChar2b_byte1" )) +(defentry set-XChar2b-byte1 (fixnum char) ( void "set_XChar2b_byte1" )) + + +;;;;;; XTextItem16 funcions ;;;;;; + +(defentry make-XTextItem16 () ( fixnum "make_XTextItem16" )) +(defentry XTextItem16-font (fixnum) ( fixnum "XTextItem16_font" )) +(defentry set-XTextItem16-font (fixnum fixnum) ( void "set_XTextItem16_font" )) +(defentry XTextItem16-delta (fixnum) ( fixnum "XTextItem16_delta" )) +(defentry set-XTextItem16-delta (fixnum fixnum) ( void "set_XTextItem16_delta" )) +(defentry XTextItem16-nchars (fixnum) ( fixnum "XTextItem16_nchars" )) +(defentry set-XTextItem16-nchars (fixnum fixnum) ( void "set_XTextItem16_nchars" )) +(defentry XTextItem16-chars (fixnum) ( fixnum "XTextItem16_chars" )) +(defentry set-XTextItem16-chars (fixnum fixnum) ( void "set_XTextItem16_chars" )) + + +;;;;;; XEDataObject funcions ;;;;;; + +(defentry make-XEDataObject () ( fixnum "make_XEDataObject" )) +(defentry XEDataObject-font (fixnum) ( fixnum "XEDataObject_font" )) +(defentry set-XEDataObject-font (fixnum fixnum) ( void "set_XEDataObject_font" )) +(defentry XEDataObject-pixmap_format (fixnum) ( fixnum "XEDataObject_pixmap_format" )) +(defentry set-XEDataObject-pixmap_format (fixnum fixnum) ( void "set_XEDataObject_pixmap_format" )) +(defentry XEDataObject-screen (fixnum) ( fixnum "XEDataObject_screen" )) +(defentry set-XEDataObject-screen (fixnum fixnum) ( void "set_XEDataObject_screen" )) +(defentry XEDataObject-visual (fixnum) ( fixnum "XEDataObject_visual" )) +(defentry set-XEDataObject-visual (fixnum fixnum) ( void "set_XEDataObject_visual" )) +(defentry XEDataObject-gc (fixnum) ( fixnum "XEDataObject_gc" )) +(defentry set-XEDataObject-gc (fixnum fixnum) ( void "set_XEDataObject_gc" )) + + +;;;;;; XSizeHints funcions ;;;;;; + +(defentry make-XSizeHints () ( fixnum "make_XSizeHints" )) +(defentry XSizeHints-win_gravity (fixnum) ( fixnum "XSizeHints_win_gravity" )) +(defentry set-XSizeHints-win_gravity (fixnum fixnum) ( void "set_XSizeHints_win_gravity" )) +(defentry XSizeHints-base_height (fixnum) ( fixnum "XSizeHints_base_height" )) +(defentry set-XSizeHints-base_height (fixnum fixnum) ( void "set_XSizeHints_base_height" )) +(defentry XSizeHints-base_width (fixnum) ( fixnum "XSizeHints_base_width" )) +(defentry set-XSizeHints-base_width (fixnum fixnum) ( void "set_XSizeHints_base_width" )) + +(defentry XSizeHints-max_aspect_x (fixnum) ( fixnum "XSizeHints_max_aspect_x" )) +(defentry set-XSizeHints-max_aspect_x (fixnum fixnum) ( void "set_XSizeHints_max_aspect_x" )) +(defentry XSizeHints-max_aspect_y (fixnum) ( fixnum "XSizeHints_max_aspect_y" )) +(defentry set-XSizeHints-max_aspect_y (fixnum fixnum) ( void "set_XSizeHints_max_aspect_y" )) +(defentry XSizeHints-min_aspect_x (fixnum) ( fixnum "XSizeHints_min_aspect_x" )) +(defentry set-XSizeHints-min_aspect_x (fixnum fixnum) ( void "set_XSizeHints_min_aspect_x" )) +(defentry XSizeHints-min_aspect_y (fixnum) ( fixnum "XSizeHints_min_aspect_y" )) +(defentry set-XSizeHints-min_aspect_y (fixnum fixnum) ( void "set_XSizeHints_min_aspect_y" )) + +(defentry XSizeHints-height_inc (fixnum) ( fixnum "XSizeHints_height_inc" )) +(defentry set-XSizeHints-height_inc (fixnum fixnum) ( void "set_XSizeHints_height_inc" )) +(defentry XSizeHints-width_inc (fixnum) ( fixnum "XSizeHints_width_inc" )) +(defentry set-XSizeHints-width_inc (fixnum fixnum) ( void "set_XSizeHints_width_inc" )) +(defentry XSizeHints-max_height (fixnum) ( fixnum "XSizeHints_max_height" )) +(defentry set-XSizeHints-max_height (fixnum fixnum) ( void "set_XSizeHints_max_height" )) +(defentry XSizeHints-max_width (fixnum) ( fixnum "XSizeHints_max_width" )) +(defentry set-XSizeHints-max_width (fixnum fixnum) ( void "set_XSizeHints_max_width" )) +(defentry XSizeHints-min_height (fixnum) ( fixnum "XSizeHints_min_height" )) +(defentry set-XSizeHints-min_height (fixnum fixnum) ( void "set_XSizeHints_min_height" )) +(defentry XSizeHints-min_width (fixnum) ( fixnum "XSizeHints_min_width" )) +(defentry set-XSizeHints-min_width (fixnum fixnum) ( void "set_XSizeHints_min_width" )) +(defentry XSizeHints-height (fixnum) ( fixnum "XSizeHints_height" )) +(defentry set-XSizeHints-height (fixnum fixnum) ( void "set_XSizeHints_height" )) +(defentry XSizeHints-width (fixnum) ( fixnum "XSizeHints_width" )) +(defentry set-XSizeHints-width (fixnum fixnum) ( void "set_XSizeHints_width" )) +(defentry XSizeHints-y (fixnum) ( fixnum "XSizeHints_y" )) +(defentry set-XSizeHints-y (fixnum fixnum) ( void "set_XSizeHints_y" )) +(defentry XSizeHints-x (fixnum) ( fixnum "XSizeHints_x" )) +(defentry set-XSizeHints-x (fixnum fixnum) ( void "set_XSizeHints_x" )) +(defentry XSizeHints-flags (fixnum) ( fixnum "XSizeHints_flags" )) +(defentry set-XSizeHints-flags (fixnum fixnum) ( void "set_XSizeHints_flags" )) + + +;;;;;; XWMHints funcions ;;;;;; + +(defentry make-XWMHints () ( fixnum "make_XWMHints" )) +(defentry XWMHints-window_group (fixnum) ( fixnum "XWMHints_window_group" )) +(defentry set-XWMHints-window_group (fixnum fixnum) ( void "set_XWMHints_window_group" )) +(defentry XWMHints-icon_mask (fixnum) ( fixnum "XWMHints_icon_mask" )) +(defentry set-XWMHints-icon_mask (fixnum fixnum) ( void "set_XWMHints_icon_mask" )) +(defentry XWMHints-icon_y (fixnum) ( fixnum "XWMHints_icon_y" )) +(defentry set-XWMHints-icon_y (fixnum fixnum) ( void "set_XWMHints_icon_y" )) +(defentry XWMHints-icon_x (fixnum) ( fixnum "XWMHints_icon_x" )) +(defentry set-XWMHints-icon_x (fixnum fixnum) ( void "set_XWMHints_icon_x" )) +(defentry XWMHints-icon_window (fixnum) ( fixnum "XWMHints_icon_window" )) +(defentry set-XWMHints-icon_window (fixnum fixnum) ( void "set_XWMHints_icon_window" )) +(defentry XWMHints-icon_pixmap (fixnum) ( fixnum "XWMHints_icon_pixmap" )) +(defentry set-XWMHints-icon_pixmap (fixnum fixnum) ( void "set_XWMHints_icon_pixmap" )) +(defentry XWMHints-initial_state (fixnum) ( fixnum "XWMHints_initial_state" )) +(defentry set-XWMHints-initial_state (fixnum fixnum) ( void "set_XWMHints_initial_state" )) +(defentry XWMHints-input (fixnum) ( fixnum "XWMHints_input" )) +(defentry set-XWMHints-input (fixnum fixnum) ( void "set_XWMHints_input" )) +(defentry XWMHints-flags (fixnum) ( fixnum "XWMHints_flags" )) +(defentry set-XWMHints-flags (fixnum fixnum) ( void "set_XWMHints_flags" )) + + +;;;;;; XTextProperty funcions ;;;;;; + +(defentry make-XTextProperty () ( fixnum "make_XTextProperty" )) +(defentry XTextProperty-nitems (fixnum) ( fixnum "XTextProperty_nitems" )) +(defentry set-XTextProperty-nitems (fixnum fixnum) ( void "set_XTextProperty_nitems" )) +(defentry XTextProperty-format (fixnum) ( fixnum "XTextProperty_format" )) +(defentry set-XTextProperty-format (fixnum fixnum) ( void "set_XTextProperty_format" )) +(defentry XTextProperty-encoding (fixnum) ( fixnum "XTextProperty_encoding" )) +(defentry set-XTextProperty-encoding (fixnum fixnum) ( void "set_XTextProperty_encoding" )) +(defentry XTextProperty-value (fixnum) ( fixnum "XTextProperty_value" )) +(defentry set-XTextProperty-value (fixnum fixnum) ( void "set_XTextProperty_value" )) + + +;;;;;; XIconSize funcions ;;;;;; + +(defentry make-XIconSize () ( fixnum "make_XIconSize" )) +(defentry XIconSize-height_inc (fixnum) ( fixnum "XIconSize_height_inc" )) +(defentry set-XIconSize-height_inc (fixnum fixnum) ( void "set_XIconSize_height_inc" )) +(defentry XIconSize-width_inc (fixnum) ( fixnum "XIconSize_width_inc" )) +(defentry set-XIconSize-width_inc (fixnum fixnum) ( void "set_XIconSize_width_inc" )) +(defentry XIconSize-max_height (fixnum) ( fixnum "XIconSize_max_height" )) +(defentry set-XIconSize-max_height (fixnum fixnum) ( void "set_XIconSize_max_height" )) +(defentry XIconSize-max_width (fixnum) ( fixnum "XIconSize_max_width" )) +(defentry set-XIconSize-max_width (fixnum fixnum) ( void "set_XIconSize_max_width" )) +(defentry XIconSize-min_height (fixnum) ( fixnum "XIconSize_min_height" )) +(defentry set-XIconSize-min_height (fixnum fixnum) ( void "set_XIconSize_min_height" )) +(defentry XIconSize-min_width (fixnum) ( fixnum "XIconSize_min_width" )) +(defentry set-XIconSize-min_width (fixnum fixnum) ( void "set_XIconSize_min_width" )) + + +;;;;;; XClassHint funcions ;;;;;; + +(defentry make-XClassHint () ( fixnum "make_XClassHint" )) +(defentry XClassHint-res_class (fixnum) ( fixnum "XClassHint_res_class" )) +(defentry set-XClassHint-res_class (fixnum fixnum) ( void "set_XClassHint_res_class" )) +(defentry XClassHint-res_name (fixnum) ( fixnum "XClassHint_res_name" )) +(defentry set-XClassHint-res_name (fixnum fixnum) ( void "set_XClassHint_res_name" )) + + +;;;;;; XComposeStatus funcions ;;;;;; + +(defentry make-XComposeStatus () ( fixnum "make_XComposeStatus" )) +(defentry XComposeStatus-chars_matched (fixnum) ( fixnum "XComposeStatus_chars_matched" )) +(defentry set-XComposeStatus-chars_matched (fixnum fixnum) ( void "set_XComposeStatus_chars_matched" )) +(defentry XComposeStatus-compose_ptr (fixnum) ( fixnum "XComposeStatus_compose_ptr" )) +(defentry set-XComposeStatus-compose_ptr (fixnum fixnum) ( void "set_XComposeStatus_compose_ptr" )) + + +;;;;;; XVisualInfo funcions ;;;;;; + +(defentry make-XVisualInfo () ( fixnum "make_XVisualInfo" )) +(defentry XVisualInfo-bits_per_rgb (fixnum) ( fixnum "XVisualInfo_bits_per_rgb" )) +(defentry set-XVisualInfo-bits_per_rgb (fixnum fixnum) ( void "set_XVisualInfo_bits_per_rgb" )) +(defentry XVisualInfo-colormap_size (fixnum) ( fixnum "XVisualInfo_colormap_size" )) +(defentry set-XVisualInfo-colormap_size (fixnum fixnum) ( void "set_XVisualInfo_colormap_size" )) +(defentry XVisualInfo-blue_mask (fixnum) ( fixnum "XVisualInfo_blue_mask" )) +(defentry set-XVisualInfo-blue_mask (fixnum fixnum) ( void "set_XVisualInfo_blue_mask" )) +(defentry XVisualInfo-green_mask (fixnum) ( fixnum "XVisualInfo_green_mask" )) +(defentry set-XVisualInfo-green_mask (fixnum fixnum) ( void "set_XVisualInfo_green_mask" )) +(defentry XVisualInfo-red_mask (fixnum) ( fixnum "XVisualInfo_red_mask" )) +(defentry set-XVisualInfo-red_mask (fixnum fixnum) ( void "set_XVisualInfo_red_mask" )) +(defentry XVisualInfo-class (fixnum) ( fixnum "XVisualInfo_class" )) +(defentry set-XVisualInfo-class (fixnum fixnum) ( void "set_XVisualInfo_class" )) +(defentry XVisualInfo-depth (fixnum) ( fixnum "XVisualInfo_depth" )) +(defentry set-XVisualInfo-depth (fixnum fixnum) ( void "set_XVisualInfo_depth" )) +(defentry XVisualInfo-screen (fixnum) ( fixnum "XVisualInfo_screen" )) +(defentry set-XVisualInfo-screen (fixnum fixnum) ( void "set_XVisualInfo_screen" )) +(defentry XVisualInfo-visualid (fixnum) ( fixnum "XVisualInfo_visualid" )) +(defentry set-XVisualInfo-visualid (fixnum fixnum) ( void "set_XVisualInfo_visualid" )) +(defentry XVisualInfo-visual (fixnum) ( fixnum "XVisualInfo_visual" )) +(defentry set-XVisualInfo-visual (fixnum fixnum) ( void "set_XVisualInfo_visual" )) + + +;;;;;; XStandardColormap funcions ;;;;;; + +(defentry make-XStandardColormap () ( fixnum "make_XStandardColormap" )) +(defentry XStandardColormap-killid (fixnum) ( fixnum "XStandardColormap_killid" )) +(defentry set-XStandardColormap-killid (fixnum fixnum) ( void "set_XStandardColormap_killid" )) +(defentry XStandardColormap-visualid (fixnum) ( fixnum "XStandardColormap_visualid" )) +(defentry set-XStandardColormap-visualid (fixnum fixnum) ( void "set_XStandardColormap_visualid" )) +(defentry XStandardColormap-base_pixel (fixnum) ( fixnum "XStandardColormap_base_pixel" )) +(defentry set-XStandardColormap-base_pixel (fixnum fixnum) ( void "set_XStandardColormap_base_pixel" )) +(defentry XStandardColormap-blue_mult (fixnum) ( fixnum "XStandardColormap_blue_mult" )) +(defentry set-XStandardColormap-blue_mult (fixnum fixnum) ( void "set_XStandardColormap_blue_mult" )) +(defentry XStandardColormap-blue_max (fixnum) ( fixnum "XStandardColormap_blue_max" )) +(defentry set-XStandardColormap-blue_max (fixnum fixnum) ( void "set_XStandardColormap_blue_max" )) +(defentry XStandardColormap-green_mult (fixnum) ( fixnum "XStandardColormap_green_mult" )) +(defentry set-XStandardColormap-green_mult (fixnum fixnum) ( void "set_XStandardColormap_green_mult" )) +(defentry XStandardColormap-green_max (fixnum) ( fixnum "XStandardColormap_green_max" )) +(defentry set-XStandardColormap-green_max (fixnum fixnum) ( void "set_XStandardColormap_green_max" )) +(defentry XStandardColormap-red_mult (fixnum) ( fixnum "XStandardColormap_red_mult" )) +(defentry set-XStandardColormap-red_mult (fixnum fixnum) ( void "set_XStandardColormap_red_mult" )) +(defentry XStandardColormap-red_max (fixnum) ( fixnum "XStandardColormap_red_max" )) +(defentry set-XStandardColormap-red_max (fixnum fixnum) ( void "set_XStandardColormap_red_max" )) +(defentry XStandardColormap-colormap (fixnum) ( fixnum "XStandardColormap_colormap" )) +(defentry set-XStandardColormap-colormap (fixnum fixnum) ( void "set_XStandardColormap_colormap" )) diff --git a/xgcl-2/gcl_Xutil.lsp b/xgcl-2/gcl_Xutil.lsp new file mode 100644 index 0000000..d27a0aa --- /dev/null +++ b/xgcl-2/gcl_Xutil.lsp @@ -0,0 +1,797 @@ +(in-package :XLIB) +; Xutil.lsp modified by Hiep Huu Nguyen 27 Aug 92 + +; Copyright (c) 1994 Hiep Huu Nguyen and The University of Texas at Austin. + +; See the files gnu.license and dec.copyright . + +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 1, or (at your option) +; any later version. + +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +; Some of the files that interface to the Xlib are adapted from DEC/MIT files. +; See the file dec.copyright for details. + +;; $XConsortium: Xutil.h,v 11.58 89/12/12 20:15:40 jim Exp $ */ + +;;********************************************************** +;;Copyright 1987 by Digital Equipment Corporation, Maynard, Massachusetts, +;;and the Massachusetts Institute of Technology, Cambridge, Massachusetts. + +;;modified by Hiep H Nguyen 28 Jul 91 + +;; All Rights Reserved + +;;Permission to use, copy, modify, and distribute this software and its +;;documentation for any purpose and without fee is hereby granted, +;;provided that the above copyright notice appear in all copies and that +;;both that copyright notice and this permission notice appear in +;;supporting documentation, and that the names of Digital or MIT not be +;;used in advertising or publicity pertaining to distribution of the +;;software without specific, written prior permission. + +;;DIGITAL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING +;;ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL +;;DIGITAL BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR +;;ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, +;;WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, +;;ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS +;;SOFTWARE. + +;;***************************************************************** + +;; +;; * Bitmask returned by XParseGeometry(). Each bit tells if the corresponding) +;; * value (x, y, width, height) was found in the parsed string.) + +(defconstant NoValue 0000) +(defconstant XValue 0001) +(defconstant YValue 0002) +(defconstant WidthValue 0004) +(defconstant HeightValue 0008) +(defconstant AllValues 15) +(defconstant XNegative 16) +(defconstant YNegative 32) + +;; + ;; The next block of definitions are for window manager properties that + ;; clients and applications use for communication. + + +;; flags argument in size hints +(defconstant USPosition (expt 2 0) ) ;; user specified x, y +(defconstant USSize (expt 2 1) ) ;; user specified width, height + +(defconstant PPosition (expt 2 2) ) ;; program specified position +(defconstant PSize (expt 2 3) ) ;; program specified size +(defconstant PMinSize (expt 2 4) ) ;; program specified minimum size +(defconstant PMaxSize (expt 2 5) ) ;; program specified maximum size +(defconstant PResizeInc (expt 2 6) ) ;; program specified resize increments +(defconstant PAspect (expt 2 7) ) ;; program specified min and max aspect ratios +(defconstant PBaseSize (expt 2 8) ) ;; program specified base for incrementing +(defconstant PWinGravity (expt 2 9) ) ;; program specified window gravity + +;; obsolete +(defconstant PAllHints (+ PPosition PSize PMinSize PMaxSize PResizeInc PAspect)) + +;; definition for flags of XWMHints + +(defconstant InputHint (expt 2 0)) +(defconstant StateHint (expt 2 1)) +(defconstant IconPixmapHint (expt 2 2)) +(defconstant IconWindowHint (expt 2 3)) +(defconstant IconPositionHint (expt 2 4)) +(defconstant IconMaskHint (expt 2 5)) +(defconstant WindowGroupHint (expt 2 6)) +(defconstant AllHints ( + InputHint StateHint IconPixmapHint IconWindowHint +IconPositionHint IconMaskHint WindowGroupHint)) + +;; definitions for initial window state +(defconstant WithdrawnState 0 ) ;; for windows that are not mapped +(defconstant NormalState 1 ) ;; most applications want to start this way +(defconstant IconicState 3 ) ;; application wants to start as an icon + +;; + ;; Obsolete states no longer defined by ICCCM + +(defconstant DontCareState 0 ) ;; don't know or care +(defconstant ZoomState 2 ) ;; application wants to start zoomed +(defconstant InactiveState 4 ) ;; application believes it is seldom used; + ;; some wm's may put it on inactive menu + + + +;; + ;; opaque reference to Region data type + +;;typedef struct _XRegion *Region; + +;; Return values from XRectInRegion() + +(defconstant RectangleOut 0) +(defconstant RectangleIn 1) +(defconstant RectanglePart 2) + + +(defconstant VisualNoMask 0) +(defconstant VisualIDMask 1) +(defconstant VisualScreenMask 2) +(defconstant VisualDepthMask 4) +(defconstant VisualClassMask 8) +(defconstant VisualRedMaskMask 16) +(defconstant VisualGreenMaskMask 32) +(defconstant VisualBlueMaskMask 64) +(defconstant VisualColormapSizeMask 128) +(defconstant VisualBitsPerRGBMask 256) +(defconstant VisualAllMask 511) + +(defconstant ReleaseByFreeingColormap 1) ;; for killid field above + + +;; +;; return codes for XReadBitmapFile and XWriteBitmapFile + +(defconstant BitmapSuccess 0) +(defconstant BitmapOpenFailed 1) +(defconstant BitmapFileInvalid 2) +(defconstant BitmapNoMemory 3) +;; + ;; Declare the routines that don't return int. + + +;; *************************************************************** +;; * +;; * Context Management +;; * +;; *************************************************************** + + +;; Associative lookup table return codes + +(defconstant XCSUCCESS 0 ) ;; No error. +(defconstant XCNOMEM 1 ) ;; Out of memory +(defconstant XCNOENT 2 ) ;; No entry in table + +;;typedef fixnum XContext; + +(defentry XSaveContext( + + fixnum ;; display + fixnum ;; w + fixnum ;; context + fixnum ;; data + +)( fixnum "XSaveContext")) + + + +(defentry XFindContext( + + fixnum ;; display + fixnum ;; w + fixnum ;; context + fixnum ;; data_return + +)( fixnum "XFindContext")) + + + +(defentry XDeleteContext( + + fixnum ;; display + fixnum ;; w + fixnum ;; context + +)( fixnum "XDeleteContext")) + + + + +(defentry XGetWMHints( + + fixnum ;; display + fixnum ;; w + +)( fixnum "XGetWMHints")) + + +(defentry XCreateRegion( + +;; void + +)( fixnum "XCreateRegion")) + + +(defentry XPolygonRegion( + + fixnum ;; points + fixnum ;; n + fixnum ;; fill_rule + +)( fixnum "XPolygonRegion")) + + + +(defentry XGetVisualInfo( + + fixnum ;; display + fixnum ;; vinfo_mask + fixnum ;; vinfo_template + fixnum ;; nitems_return + +)( fixnum "XGetVisualInfo")) + +;; Allocation routines for properties that may get longer + + +(defentry XAllocSizeHints ( + +;; void + +)( fixnum "XAllocSizeHints" )) + + +(defentry XAllocStandardColormap ( + +;; void + +)( fixnum "XAllocStandardColormap" )) + + +(defentry XAllocWMHints ( + +;; void + +)( fixnum "XAllocWMHints" )) + + +(defentry XAllocClassHint ( + +;; void + +)( fixnum "XAllocClassHint" )) + + +(defentry XAllocIconSize ( + +;; void + +)( fixnum "XAllocIconSize" )) + +;; ICCCM routines for data structures defined in this file + + +(defentry XGetWMSizeHints( + + fixnum ;; display + fixnum ;; w + fixnum ;; hints_return + fixnum ;; supplied_return + fixnum ;; property + +)( fixnum "XGetWMSizeHints")) + + +(defentry XGetWMNormalHints( + + fixnum ;; display + fixnum ;; w + fixnum ;; hints_return + fixnum ;; supplied_return + +)( fixnum "XGetWMNormalHints")) + + +(defentry XGetRGBColormaps( + + fixnum ;; display + fixnum ;; w + fixnum ;; stdcmap_return + fixnum ;; count_return + fixnum ;; property + +)( fixnum "XGetRGBColormaps")) + + +(defentry XGetTextProperty( + + fixnum ;; display + fixnum ;; window + fixnum ;; text_prop_return + fixnum ;; property + +)( fixnum "XGetTextProperty")) + + +(defentry XGetWMName( + + fixnum ;; display + fixnum ;; w + fixnum ;; text_prop_return + +)( fixnum "XGetWMName")) + + +(defentry XGetWMIconName( + + fixnum ;; display + fixnum ;; w + fixnum ;; text_prop_return + +)( fixnum "XGetWMIconName")) + + +(defentry XGetWMClientMachine( + + fixnum ;; display + fixnum ;; w + fixnum ;; text_prop_return + +)( fixnum "XGetWMClientMachine")) + + +(defentry XSetWMProperties( + + fixnum ;; display + fixnum ;; w + fixnum ;; window_name + fixnum ;; icon_name + fixnum ;; argv + fixnum ;; argc + fixnum ;; normal_hints + fixnum ;; wm_hints + fixnum ;; class_hints + +)( void "XSetWMProperties")) + + +(defentry XSetWMSizeHints( + + fixnum ;; display + fixnum ;; w + fixnum ;; hints + fixnum ;; property + +)( void "XSetWMSizeHints")) + + +(defentry XSetWMNormalHints( + + fixnum ;; display + fixnum ;; w + fixnum ;; hints + +)( void "XSetWMNormalHints")) + + +(defentry XSetRGBColormaps( + + fixnum ;; display + fixnum ;; w + fixnum ;; stdcmaps + fixnum ;; count + fixnum ;; property + +)( void "XSetRGBColormaps")) + + +(defentry XSetTextProperty( + + fixnum ;; display + fixnum ;; w + fixnum ;; text_prop + fixnum ;; property + +)( void "XSetTextProperty")) + + +(defentry XSetWMName( + + fixnum ;; display + fixnum ;; w + fixnum ;; text_prop + +)( void "XSetWMName")) + + +(defentry XSetWMIconName( + + fixnum ;; display + fixnum ;; w + fixnum ;; text_prop + +)( void "XSetWMIconName")) + + +(defentry XSetWMClientMachine( + + fixnum ;; display + fixnum ;; w + fixnum ;; text_prop + +)( void "XSetWMClientMachine")) + + +(defentry XStringListToTextProperty( + + fixnum ;; list + fixnum ;; count + fixnum ;; text_prop_return + +)( fixnum "XStringListToTextProperty")) + + +(defentry XTextPropertyToStringList( + + fixnum ;; text_prop + fixnum ;; list_return + fixnum ;; count_return + +)( fixnum "XTextPropertyToStringList")) + +;; The following declarations are alphabetized. + + + +(defentry XClipBox( + + fixnum ;; r + fixnum ;; rect_return + +)( void "XClipBox")) + + + +(defentry XDestroyRegion( + + fixnum ;; r + +)( void "XDestroyRegion")) + + + +(defentry XEmptyRegion( + + fixnum ;; r + +)( void "XEmptyRegion")) + + + +(defentry XEqualRegion( + + fixnum ;; r1 + fixnum ;; r2 + +)( void "XEqualRegion")) + + + +(defentry XGetClassHint( + + fixnum ;; display + fixnum ;; w + fixnum ;; class_hints_return + +)( fixnum "XGetClassHint")) + + + +(defentry XGetIconSizes( + + fixnum ;; display + fixnum ;; w + fixnum ;; size_list_return + fixnum ;; count_return + +)( fixnum "XGetIconSizes")) + + + +(defentry XGetNormalHints( + + fixnum ;; display + fixnum ;; w + fixnum ;; hints_return + +)( fixnum "XGetNormalHints")) + + + +(defentry XGetSizeHints( + + fixnum ;; display + fixnum ;; w + fixnum ;; hints_return + fixnum ;; property + +)( fixnum "XGetSizeHints")) + + + +(defentry XGetStandardColormap( + + fixnum ;; display + fixnum ;; w + fixnum ;; colormap_return + fixnum ;; property + +)( fixnum "XGetStandardColormap")) + + + +(defentry XGetZoomHints( + + fixnum ;; display + fixnum ;; w + fixnum ;; zhints_return + +)( fixnum "XGetZoomHints")) + + + +(defentry XIntersectRegion( + + fixnum ;; sra + fixnum ;; srb + fixnum ;; dr_return + +)( void "XIntersectRegion")) + + + +(defentry XLookupString( + + fixnum ;; event_struct + object ;; buffer_return + fixnum ;; bytes_buffer + fixnum ;; keysym_return + fixnum ;; int_in_out + +)( fixnum "XLookupString")) + + + +(defentry XMatchVisualInfo( + + fixnum ;; display + fixnum ;; screen + fixnum ;; depth + fixnum ;; class + fixnum ;; vinfo_return + +)( fixnum "XMatchVisualInfo")) + + + +(defentry XOffsetRegion( + + fixnum ;; r + fixnum ;; dx + fixnum ;; dy + +)( void "XOffsetRegion")) + + + +(defentry XPointInRegion( + + fixnum ;; r + fixnum ;; x + fixnum ;; y + +)( fixnum "XPointInRegion")) + + + +(defentry XRectInRegion( + + fixnum ;; r + fixnum ;; x + fixnum ;; y + fixnum ;; width + fixnum ;; height + +)( fixnum "XRectInRegion")) + + + +(defentry XSetClassHint( + + fixnum ;; display + fixnum ;; w + fixnum ;; class_hints + +)( void "XSetClassHint")) + + + +(defentry XSetIconSizes( + + fixnum ;; display + fixnum ;; w + fixnum ;; size_list + fixnum ;; count + +)( void "XSetIconSizes")) + + + +(defentry XSetNormalHints( + + fixnum ;; display + fixnum ;; w + fixnum ;; hints + +)( void "XSetNormalHints")) + + + +(defentry XSetSizeHints( + + fixnum ;; display + fixnum ;; w + fixnum ;; hints + fixnum ;; property + +)( void "XSetSizeHints")) + + + +(defentry XSetStandardProperties( + + fixnum ;; display + fixnum ;; w + object ;; window_name + object ;; icon_name + fixnum ;; icon_pixmap + fixnum ;; argv + fixnum ;; argc + fixnum ;; hints + +)( void "XSetStandardProperties")) + + + +(defentry XSetWMHints( + + fixnum ;; display + fixnum ;; w + fixnum ;; wm_hints + +)( void "XSetWMHints")) + + + +(defentry XSetRegion( + + fixnum ;; display + fixnum ;; gc + fixnum ;; r + +)( void "XSetRegion")) + + + +(defentry XSetStandardColormap( + + fixnum ;; display + fixnum ;; w + fixnum ;; colormap + fixnum ;; property + +)( void "XSetStandardColormap")) + + + +(defentry XSetZoomHints( + + fixnum ;; display + fixnum ;; w + fixnum ;; zhints + +)( void "XSetZoomHints")) + + + +(defentry XShrinkRegion( + + fixnum ;; r + fixnum ;; dx + fixnum ;; dy + +)( void "XShrinkRegion")) + + + +(defentry XSubtractRegion( + + fixnum ;; sra + fixnum ;; srb + fixnum ;; dr_return + +)( void "XSubtractRegion")) + + + +(defentry XUnionRectWithRegion( + + fixnum ;; rectangle + fixnum ;; src_region + fixnum ;; dest_region_return + +)( void "XUnionRectWithRegion")) + + + +(defentry XUnionRegion( + + fixnum ;; sra + fixnum ;; srb + fixnum ;; dr_return + +)( void "XUnionRegion")) + + + +(defentry XWMGeometry( + + fixnum ;; display + fixnum ;; screen_number + object ;; user_geometry + object ;; default_geometry + fixnum ;; border_width + fixnum ;; hints + fixnum ;; x_return + fixnum ;; y_return + fixnum ;; width_return + fixnum ;; height_return + fixnum ;; gravity_return + +)( fixnum "XWMGeometry")) + + + +(defentry XXorRegion( + + fixnum ;; sra + fixnum ;; srb + fixnum ;; dr_return + +)( void "XXorRegion")) +;; + ;; These macros are used to give some sugar to the image routines so that + ;; naive people are more comfortable with them. + +(defentry XDestroyImage(fixnum) (fixnum "XDestroyImage")) +(defentry XGetPixel(fixnum fixnum fixnum) (fixnum "XGetPixel" )) +(defentry XPutPixel(fixnum fixnum int fixnum) ( fixnum "XPutPixel")) +(defentry XSubImage(fixnum fixnum int fixnum fixnum) (fixnum "XSubImage")) +(defentry XAddPixel(fixnum fixnum) (fixnum "XAddPixel")) +;; + ;; Keysym macros, used on Keysyms to test for classes of symbols + +(defentry IsKeypadKey(fixnum) (fixnum "IsKeypadKey")) + +(defentry IsCursorKey(fixnum) (fixnum "IsCursorKey")) + +(defentry IsPFKey(fixnum) (fixnum "IsPFKey")) + +(defentry IsFunctionKey(fixnum) (fixnum "IsFunctionKey")) + +(defentry IsMiscFunctionKey(fixnum) (fixnum "IsMiscFunctionKey")) + +(defentry IsModifierKey(fixnum) (fixnum "IsModifierKey")) +(defentry XUniqueContext() (fixnum "XUniqueContext")) +(defentry XStringToContext(object) (fixnum "XStringToContext")) + diff --git a/xgcl-2/gcl_defentry_events.lsp b/xgcl-2/gcl_defentry_events.lsp new file mode 100644 index 0000000..a561d02 --- /dev/null +++ b/xgcl-2/gcl_defentry_events.lsp @@ -0,0 +1,817 @@ +(in-package :XLIB) +; defentry-events.lsp Hiep Huu Nguyen 27 Aug 92 + +; Copyright (c) 1994 Hiep Huu Nguyen and The University of Texas at Austin. + +; See the files gnu.license and dec.copyright . + +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 1, or (at your option) +; any later version. + +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +; Some of the files that interface to the Xlib are adapted from DEC/MIT files. +; See the file dec.copyright for details. + + +;;;;;; XKeyEvent funcions ;;;;;; + +(defentry make-XKeyEvent () ( fixnum "make_XKeyEvent" )) +(defentry XKeyEvent-same_screen (fixnum) ( fixnum "XKeyEvent_same_screen" )) +(defentry set-XKeyEvent-same_screen (fixnum fixnum) ( void "set_XKeyEvent_same_screen" )) +(defentry XKeyEvent-keycode (fixnum) ( fixnum "XKeyEvent_keycode" )) +(defentry set-XKeyEvent-keycode (fixnum fixnum) ( void "set_XKeyEvent_keycode" )) +(defentry XKeyEvent-state (fixnum) ( fixnum "XKeyEvent_state" )) +(defentry set-XKeyEvent-state (fixnum fixnum) ( void "set_XKeyEvent_state" )) +(defentry XKeyEvent-y_root (fixnum) ( fixnum "XKeyEvent_y_root" )) +(defentry set-XKeyEvent-y_root (fixnum fixnum) ( void "set_XKeyEvent_y_root" )) +(defentry XKeyEvent-x_root (fixnum) ( fixnum "XKeyEvent_x_root" )) +(defentry set-XKeyEvent-x_root (fixnum fixnum) ( void "set_XKeyEvent_x_root" )) +(defentry XKeyEvent-y (fixnum) ( fixnum "XKeyEvent_y" )) +(defentry set-XKeyEvent-y (fixnum fixnum) ( void "set_XKeyEvent_y" )) +(defentry XKeyEvent-x (fixnum) ( fixnum "XKeyEvent_x" )) +(defentry set-XKeyEvent-x (fixnum fixnum) ( void "set_XKeyEvent_x" )) +(defentry XKeyEvent-time (fixnum) ( fixnum "XKeyEvent_time" )) +(defentry set-XKeyEvent-time (fixnum fixnum) ( void "set_XKeyEvent_time" )) +(defentry XKeyEvent-subwindow (fixnum) ( fixnum "XKeyEvent_subwindow" )) +(defentry set-XKeyEvent-subwindow (fixnum fixnum) ( void "set_XKeyEvent_subwindow" )) +(defentry XKeyEvent-root (fixnum) ( fixnum "XKeyEvent_root" )) +(defentry set-XKeyEvent-root (fixnum fixnum) ( void "set_XKeyEvent_root" )) +(defentry XKeyEvent-window (fixnum) ( fixnum "XKeyEvent_window" )) +(defentry set-XKeyEvent-window (fixnum fixnum) ( void "set_XKeyEvent_window" )) +(defentry XKeyEvent-display (fixnum) ( fixnum "XKeyEvent_display" )) +(defentry set-XKeyEvent-display (fixnum fixnum) ( void "set_XKeyEvent_display" )) +(defentry XKeyEvent-send_event (fixnum) ( fixnum "XKeyEvent_send_event" )) +(defentry set-XKeyEvent-send_event (fixnum fixnum) ( void "set_XKeyEvent_send_event" )) +(defentry XKeyEvent-serial (fixnum) ( fixnum "XKeyEvent_serial" )) +(defentry set-XKeyEvent-serial (fixnum fixnum) ( void "set_XKeyEvent_serial" )) +(defentry XKeyEvent-type (fixnum) ( fixnum "XKeyEvent_type" )) +(defentry set-XKeyEvent-type (fixnum fixnum) ( void "set_XKeyEvent_type" )) + + +;;;;;; XButtonEvent funcions ;;;;;; + +(defentry make-XButtonEvent () ( fixnum "make_XButtonEvent" )) +(defentry XButtonEvent-same_screen (fixnum) ( fixnum "XButtonEvent_same_screen" )) +(defentry set-XButtonEvent-same_screen (fixnum fixnum) ( void "set_XButtonEvent_same_screen" )) +(defentry XButtonEvent-button (fixnum) ( fixnum "XButtonEvent_button" )) +(defentry set-XButtonEvent-button (fixnum fixnum) ( void "set_XButtonEvent_button" )) +(defentry XButtonEvent-state (fixnum) ( fixnum "XButtonEvent_state" )) +(defentry set-XButtonEvent-state (fixnum fixnum) ( void "set_XButtonEvent_state" )) +(defentry XButtonEvent-y_root (fixnum) ( fixnum "XButtonEvent_y_root" )) +(defentry set-XButtonEvent-y_root (fixnum fixnum) ( void "set_XButtonEvent_y_root" )) +(defentry XButtonEvent-x_root (fixnum) ( fixnum "XButtonEvent_x_root" )) +(defentry set-XButtonEvent-x_root (fixnum fixnum) ( void "set_XButtonEvent_x_root" )) +(defentry XButtonEvent-y (fixnum) ( fixnum "XButtonEvent_y" )) +(defentry set-XButtonEvent-y (fixnum fixnum) ( void "set_XButtonEvent_y" )) +(defentry XButtonEvent-x (fixnum) ( fixnum "XButtonEvent_x" )) +(defentry set-XButtonEvent-x (fixnum fixnum) ( void "set_XButtonEvent_x" )) +(defentry XButtonEvent-time (fixnum) ( fixnum "XButtonEvent_time" )) +(defentry set-XButtonEvent-time (fixnum fixnum) ( void "set_XButtonEvent_time" )) +(defentry XButtonEvent-subwindow (fixnum) ( fixnum "XButtonEvent_subwindow" )) +(defentry set-XButtonEvent-subwindow (fixnum fixnum) ( void "set_XButtonEvent_subwindow" )) +(defentry XButtonEvent-root (fixnum) ( fixnum "XButtonEvent_root" )) +(defentry set-XButtonEvent-root (fixnum fixnum) ( void "set_XButtonEvent_root" )) +(defentry XButtonEvent-window (fixnum) ( fixnum "XButtonEvent_window" )) +(defentry set-XButtonEvent-window (fixnum fixnum) ( void "set_XButtonEvent_window" )) +(defentry XButtonEvent-display (fixnum) ( fixnum "XButtonEvent_display" )) +(defentry set-XButtonEvent-display (fixnum fixnum) ( void "set_XButtonEvent_display" )) +(defentry XButtonEvent-send_event (fixnum) ( fixnum "XButtonEvent_send_event" )) +(defentry set-XButtonEvent-send_event (fixnum fixnum) ( void "set_XButtonEvent_send_event" )) +(defentry XButtonEvent-serial (fixnum) ( fixnum "XButtonEvent_serial" )) +(defentry set-XButtonEvent-serial (fixnum fixnum) ( void "set_XButtonEvent_serial" )) +(defentry XButtonEvent-type (fixnum) ( fixnum "XButtonEvent_type" )) +(defentry set-XButtonEvent-type (fixnum fixnum) ( void "set_XButtonEvent_type" )) + + +;;;;;; XMotionEvent funcions ;;;;;; + +(defentry make-XMotionEvent () ( fixnum "make_XMotionEvent" )) +(defentry XMotionEvent-same_screen (fixnum) ( fixnum "XMotionEvent_same_screen" )) +(defentry set-XMotionEvent-same_screen (fixnum fixnum) ( void "set_XMotionEvent_same_screen" )) +(defentry XMotionEvent-is_hint (fixnum) ( char "XMotionEvent_is_hint" )) +(defentry set-XMotionEvent-is_hint (fixnum char) ( void "set_XMotionEvent_is_hint" )) +(defentry XMotionEvent-state (fixnum) ( fixnum "XMotionEvent_state" )) +(defentry set-XMotionEvent-state (fixnum fixnum) ( void "set_XMotionEvent_state" )) +(defentry XMotionEvent-y_root (fixnum) ( fixnum "XMotionEvent_y_root" )) +(defentry set-XMotionEvent-y_root (fixnum fixnum) ( void "set_XMotionEvent_y_root" )) +(defentry XMotionEvent-x_root (fixnum) ( fixnum "XMotionEvent_x_root" )) +(defentry set-XMotionEvent-x_root (fixnum fixnum) ( void "set_XMotionEvent_x_root" )) +(defentry XMotionEvent-y (fixnum) ( fixnum "XMotionEvent_y" )) +(defentry set-XMotionEvent-y (fixnum fixnum) ( void "set_XMotionEvent_y" )) +(defentry XMotionEvent-x (fixnum) ( fixnum "XMotionEvent_x" )) +(defentry set-XMotionEvent-x (fixnum fixnum) ( void "set_XMotionEvent_x" )) +(defentry XMotionEvent-time (fixnum) ( fixnum "XMotionEvent_time" )) +(defentry set-XMotionEvent-time (fixnum fixnum) ( void "set_XMotionEvent_time" )) +(defentry XMotionEvent-subwindow (fixnum) ( fixnum "XMotionEvent_subwindow" )) +(defentry set-XMotionEvent-subwindow (fixnum fixnum) ( void "set_XMotionEvent_subwindow" )) +(defentry XMotionEvent-root (fixnum) ( fixnum "XMotionEvent_root" )) +(defentry set-XMotionEvent-root (fixnum fixnum) ( void "set_XMotionEvent_root" )) +(defentry XMotionEvent-window (fixnum) ( fixnum "XMotionEvent_window" )) +(defentry set-XMotionEvent-window (fixnum fixnum) ( void "set_XMotionEvent_window" )) +(defentry XMotionEvent-display (fixnum) ( fixnum "XMotionEvent_display" )) +(defentry set-XMotionEvent-display (fixnum fixnum) ( void "set_XMotionEvent_display" )) +(defentry XMotionEvent-send_event (fixnum) ( fixnum "XMotionEvent_send_event" )) +(defentry set-XMotionEvent-send_event (fixnum fixnum) ( void "set_XMotionEvent_send_event" )) +(defentry XMotionEvent-serial (fixnum) ( fixnum "XMotionEvent_serial" )) +(defentry set-XMotionEvent-serial (fixnum fixnum) ( void "set_XMotionEvent_serial" )) +(defentry XMotionEvent-type (fixnum) ( fixnum "XMotionEvent_type" )) +(defentry set-XMotionEvent-type (fixnum fixnum) ( void "set_XMotionEvent_type" )) + + +;;;;;; XCrossingEvent funcions ;;;;;; + +(defentry make-XCrossingEvent () ( fixnum "make_XCrossingEvent" )) +(defentry XCrossingEvent-state (fixnum) ( fixnum "XCrossingEvent_state" )) +(defentry set-XCrossingEvent-state (fixnum fixnum) ( void "set_XCrossingEvent_state" )) +(defentry XCrossingEvent-focus (fixnum) ( fixnum "XCrossingEvent_focus" )) +(defentry set-XCrossingEvent-focus (fixnum fixnum) ( void "set_XCrossingEvent_focus" )) +(defentry XCrossingEvent-same_screen (fixnum) ( fixnum "XCrossingEvent_same_screen" )) +(defentry set-XCrossingEvent-same_screen (fixnum fixnum) ( void "set_XCrossingEvent_same_screen" )) +(defentry XCrossingEvent-detail (fixnum) ( fixnum "XCrossingEvent_detail" )) +(defentry set-XCrossingEvent-detail (fixnum fixnum) ( void "set_XCrossingEvent_detail" )) +(defentry XCrossingEvent-mode (fixnum) ( fixnum "XCrossingEvent_mode" )) +(defentry set-XCrossingEvent-mode (fixnum fixnum) ( void "set_XCrossingEvent_mode" )) +(defentry XCrossingEvent-y_root (fixnum) ( fixnum "XCrossingEvent_y_root" )) +(defentry set-XCrossingEvent-y_root (fixnum fixnum) ( void "set_XCrossingEvent_y_root" )) +(defentry XCrossingEvent-x_root (fixnum) ( fixnum "XCrossingEvent_x_root" )) +(defentry set-XCrossingEvent-x_root (fixnum fixnum) ( void "set_XCrossingEvent_x_root" )) +(defentry XCrossingEvent-y (fixnum) ( fixnum "XCrossingEvent_y" )) +(defentry set-XCrossingEvent-y (fixnum fixnum) ( void "set_XCrossingEvent_y" )) +(defentry XCrossingEvent-x (fixnum) ( fixnum "XCrossingEvent_x" )) +(defentry set-XCrossingEvent-x (fixnum fixnum) ( void "set_XCrossingEvent_x" )) +(defentry XCrossingEvent-time (fixnum) ( fixnum "XCrossingEvent_time" )) +(defentry set-XCrossingEvent-time (fixnum fixnum) ( void "set_XCrossingEvent_time" )) +(defentry XCrossingEvent-subwindow (fixnum) ( fixnum "XCrossingEvent_subwindow" )) +(defentry set-XCrossingEvent-subwindow (fixnum fixnum) ( void "set_XCrossingEvent_subwindow" )) +(defentry XCrossingEvent-root (fixnum) ( fixnum "XCrossingEvent_root" )) +(defentry set-XCrossingEvent-root (fixnum fixnum) ( void "set_XCrossingEvent_root" )) +(defentry XCrossingEvent-window (fixnum) ( fixnum "XCrossingEvent_window" )) +(defentry set-XCrossingEvent-window (fixnum fixnum) ( void "set_XCrossingEvent_window" )) +(defentry XCrossingEvent-display (fixnum) ( fixnum "XCrossingEvent_display" )) +(defentry set-XCrossingEvent-display (fixnum fixnum) ( void "set_XCrossingEvent_display" )) +(defentry XCrossingEvent-send_event (fixnum) ( fixnum "XCrossingEvent_send_event" )) +(defentry set-XCrossingEvent-send_event (fixnum fixnum) ( void "set_XCrossingEvent_send_event" )) +(defentry XCrossingEvent-serial (fixnum) ( fixnum "XCrossingEvent_serial" )) +(defentry set-XCrossingEvent-serial (fixnum fixnum) ( void "set_XCrossingEvent_serial" )) +(defentry XCrossingEvent-type (fixnum) ( fixnum "XCrossingEvent_type" )) +(defentry set-XCrossingEvent-type (fixnum fixnum) ( void "set_XCrossingEvent_type" )) + + +;;;;;; XFocusChangeEvent funcions ;;;;;; + +(defentry make-XFocusChangeEvent () ( fixnum "make_XFocusChangeEvent" )) +(defentry XFocusChangeEvent-detail (fixnum) ( fixnum "XFocusChangeEvent_detail" )) +(defentry set-XFocusChangeEvent-detail (fixnum fixnum) ( void "set_XFocusChangeEvent_detail" )) +(defentry XFocusChangeEvent-mode (fixnum) ( fixnum "XFocusChangeEvent_mode" )) +(defentry set-XFocusChangeEvent-mode (fixnum fixnum) ( void "set_XFocusChangeEvent_mode" )) +(defentry XFocusChangeEvent-window (fixnum) ( fixnum "XFocusChangeEvent_window" )) +(defentry set-XFocusChangeEvent-window (fixnum fixnum) ( void "set_XFocusChangeEvent_window" )) +(defentry XFocusChangeEvent-display (fixnum) ( fixnum "XFocusChangeEvent_display" )) +(defentry set-XFocusChangeEvent-display (fixnum fixnum) ( void "set_XFocusChangeEvent_display" )) +(defentry XFocusChangeEvent-send_event (fixnum) ( fixnum "XFocusChangeEvent_send_event" )) +(defentry set-XFocusChangeEvent-send_event (fixnum fixnum) ( void "set_XFocusChangeEvent_send_event" )) +(defentry XFocusChangeEvent-serial (fixnum) ( fixnum "XFocusChangeEvent_serial" )) +(defentry set-XFocusChangeEvent-serial (fixnum fixnum) ( void "set_XFocusChangeEvent_serial" )) +(defentry XFocusChangeEvent-type (fixnum) ( fixnum "XFocusChangeEvent_type" )) +(defentry set-XFocusChangeEvent-type (fixnum fixnum) ( void "set_XFocusChangeEvent_type" )) + + +;;;;;; XKeymapEvent funcions ;;;;;; + +(defentry make-XKeymapEvent () ( fixnum "make_XKeymapEvent" )) +;;(defentry XKeymapEvent-key_vector[32] (fixnum) ( char "XKeymapEvent_key_vector[32]" )) +;;(defentry set-XKeymapEvent-key_vector[32] (fixnum char) ( void "set_XKeymapEvent_key_vector[32]" )) +(defentry XKeymapEvent-window (fixnum) ( fixnum "XKeymapEvent_window" )) +(defentry set-XKeymapEvent-window (fixnum fixnum) ( void "set_XKeymapEvent_window" )) +(defentry XKeymapEvent-display (fixnum) ( fixnum "XKeymapEvent_display" )) +(defentry set-XKeymapEvent-display (fixnum fixnum) ( void "set_XKeymapEvent_display" )) +(defentry XKeymapEvent-send_event (fixnum) ( fixnum "XKeymapEvent_send_event" )) +(defentry set-XKeymapEvent-send_event (fixnum fixnum) ( void "set_XKeymapEvent_send_event" )) +(defentry XKeymapEvent-serial (fixnum) ( fixnum "XKeymapEvent_serial" )) +(defentry set-XKeymapEvent-serial (fixnum fixnum) ( void "set_XKeymapEvent_serial" )) +(defentry XKeymapEvent-type (fixnum) ( fixnum "XKeymapEvent_type" )) +(defentry set-XKeymapEvent-type (fixnum fixnum) ( void "set_XKeymapEvent_type" )) + + +;;;;;; XExposeEvent funcions ;;;;;; + +(defentry make-XExposeEvent () ( fixnum "make_XExposeEvent" )) +(defentry XExposeEvent-count (fixnum) ( fixnum "XExposeEvent_count" )) +(defentry set-XExposeEvent-count (fixnum fixnum) ( void "set_XExposeEvent_count" )) +(defentry XExposeEvent-height (fixnum) ( fixnum "XExposeEvent_height" )) +(defentry set-XExposeEvent-height (fixnum fixnum) ( void "set_XExposeEvent_height" )) +(defentry XExposeEvent-width (fixnum) ( fixnum "XExposeEvent_width" )) +(defentry set-XExposeEvent-width (fixnum fixnum) ( void "set_XExposeEvent_width" )) +(defentry XExposeEvent-y (fixnum) ( fixnum "XExposeEvent_y" )) +(defentry set-XExposeEvent-y (fixnum fixnum) ( void "set_XExposeEvent_y" )) +(defentry XExposeEvent-x (fixnum) ( fixnum "XExposeEvent_x" )) +(defentry set-XExposeEvent-x (fixnum fixnum) ( void "set_XExposeEvent_x" )) +(defentry XExposeEvent-window (fixnum) ( fixnum "XExposeEvent_window" )) +(defentry set-XExposeEvent-window (fixnum fixnum) ( void "set_XExposeEvent_window" )) +(defentry XExposeEvent-display (fixnum) ( fixnum "XExposeEvent_display" )) +(defentry set-XExposeEvent-display (fixnum fixnum) ( void "set_XExposeEvent_display" )) +(defentry XExposeEvent-send_event (fixnum) ( fixnum "XExposeEvent_send_event" )) +(defentry set-XExposeEvent-send_event (fixnum fixnum) ( void "set_XExposeEvent_send_event" )) +(defentry XExposeEvent-serial (fixnum) ( fixnum "XExposeEvent_serial" )) +(defentry set-XExposeEvent-serial (fixnum fixnum) ( void "set_XExposeEvent_serial" )) +(defentry XExposeEvent-type (fixnum) ( fixnum "XExposeEvent_type" )) +(defentry set-XExposeEvent-type (fixnum fixnum) ( void "set_XExposeEvent_type" )) + + +;;;;;; XGraphicsExposeEvent funcions ;;;;;; + +(defentry make-XGraphicsExposeEvent () ( fixnum "make_XGraphicsExposeEvent" )) +(defentry XGraphicsExposeEvent-minor_code (fixnum) ( fixnum "XGraphicsExposeEvent_minor_code" )) +(defentry set-XGraphicsExposeEvent-minor_code (fixnum fixnum) ( void "set_XGraphicsExposeEvent_minor_code" )) +(defentry XGraphicsExposeEvent-major_code (fixnum) ( fixnum "XGraphicsExposeEvent_major_code" )) +(defentry set-XGraphicsExposeEvent-major_code (fixnum fixnum) ( void "set_XGraphicsExposeEvent_major_code" )) +(defentry XGraphicsExposeEvent-count (fixnum) ( fixnum "XGraphicsExposeEvent_count" )) +(defentry set-XGraphicsExposeEvent-count (fixnum fixnum) ( void "set_XGraphicsExposeEvent_count" )) +(defentry XGraphicsExposeEvent-height (fixnum) ( fixnum "XGraphicsExposeEvent_height" )) +(defentry set-XGraphicsExposeEvent-height (fixnum fixnum) ( void "set_XGraphicsExposeEvent_height" )) +(defentry XGraphicsExposeEvent-width (fixnum) ( fixnum "XGraphicsExposeEvent_width" )) +(defentry set-XGraphicsExposeEvent-width (fixnum fixnum) ( void "set_XGraphicsExposeEvent_width" )) +(defentry XGraphicsExposeEvent-y (fixnum) ( fixnum "XGraphicsExposeEvent_y" )) +(defentry set-XGraphicsExposeEvent-y (fixnum fixnum) ( void "set_XGraphicsExposeEvent_y" )) +(defentry XGraphicsExposeEvent-x (fixnum) ( fixnum "XGraphicsExposeEvent_x" )) +(defentry set-XGraphicsExposeEvent-x (fixnum fixnum) ( void "set_XGraphicsExposeEvent_x" )) +(defentry XGraphicsExposeEvent-drawable (fixnum) (fixnum "XGraphicsExposeEvent_drawable" )) +(defentry set-XGraphicsExposeEvent-drawable (fixnum fixnum) ( void "set_XGraphicsExposeEvent_drawable" )) +(defentry XGraphicsExposeEvent-display (fixnum) ( fixnum "XGraphicsExposeEvent_display" )) +(defentry set-XGraphicsExposeEvent-display (fixnum fixnum) ( void "set_XGraphicsExposeEvent_display" )) +(defentry XGraphicsExposeEvent-send_event (fixnum) ( fixnum "XGraphicsExposeEvent_send_event" )) +(defentry set-XGraphicsExposeEvent-send_event (fixnum fixnum) ( void "set_XGraphicsExposeEvent_send_event" )) +(defentry XGraphicsExposeEvent-serial (fixnum) ( fixnum "XGraphicsExposeEvent_serial" )) +(defentry set-XGraphicsExposeEvent-serial (fixnum fixnum) ( void "set_XGraphicsExposeEvent_serial" )) +(defentry XGraphicsExposeEvent-type (fixnum) ( fixnum "XGraphicsExposeEvent_type" )) +(defentry set-XGraphicsExposeEvent-type (fixnum fixnum) ( void "set_XGraphicsExposeEvent_type" )) + + +;;;;;; XNoExposeEvent funcions ;;;;;; + +(defentry make-XNoExposeEvent () ( fixnum "make_XNoExposeEvent" )) +(defentry XNoExposeEvent-minor_code (fixnum) ( fixnum "XNoExposeEvent_minor_code" )) +(defentry set-XNoExposeEvent-minor_code (fixnum fixnum) ( void "set_XNoExposeEvent_minor_code" )) +(defentry XNoExposeEvent-major_code (fixnum) ( fixnum "XNoExposeEvent_major_code" )) +(defentry set-XNoExposeEvent-major_code (fixnum fixnum) ( void "set_XNoExposeEvent_major_code" )) +(defentry XNoExposeEvent-drawable (fixnum) ( fixnum "XNoExposeEvent_drawable" )) +(defentry set-XNoExposeEvent-drawable (fixnum fixnum) ( void "set_XNoExposeEvent_drawable" )) +(defentry XNoExposeEvent-display (fixnum) ( fixnum "XNoExposeEvent_display" )) +(defentry set-XNoExposeEvent-display (fixnum fixnum) ( void "set_XNoExposeEvent_display" )) +(defentry XNoExposeEvent-send_event (fixnum) ( fixnum "XNoExposeEvent_send_event" )) +(defentry set-XNoExposeEvent-send_event (fixnum fixnum) ( void "set_XNoExposeEvent_send_event" )) +(defentry XNoExposeEvent-serial (fixnum) ( fixnum "XNoExposeEvent_serial" )) +(defentry set-XNoExposeEvent-serial (fixnum fixnum) ( void "set_XNoExposeEvent_serial" )) +(defentry XNoExposeEvent-type (fixnum) ( fixnum "XNoExposeEvent_type" )) +(defentry set-XNoExposeEvent-type (fixnum fixnum) ( void "set_XNoExposeEvent_type" )) + + +;;;;;; XVisibilityEvent funcions ;;;;;; + +(defentry make-XVisibilityEvent () ( fixnum "make_XVisibilityEvent" )) +(defentry XVisibilityEvent-state (fixnum) ( fixnum "XVisibilityEvent_state" )) +(defentry set-XVisibilityEvent-state (fixnum fixnum) ( void "set_XVisibilityEvent_state" )) +(defentry XVisibilityEvent-window (fixnum) ( fixnum "XVisibilityEvent_window" )) +(defentry set-XVisibilityEvent-window (fixnum fixnum) ( void "set_XVisibilityEvent_window" )) +(defentry XVisibilityEvent-display (fixnum) ( fixnum "XVisibilityEvent_display" )) +(defentry set-XVisibilityEvent-display (fixnum fixnum) ( void "set_XVisibilityEvent_display" )) +(defentry XVisibilityEvent-send_event (fixnum) ( fixnum "XVisibilityEvent_send_event" )) +(defentry set-XVisibilityEvent-send_event (fixnum fixnum) ( void "set_XVisibilityEvent_send_event" )) +(defentry XVisibilityEvent-serial (fixnum) ( fixnum "XVisibilityEvent_serial" )) +(defentry set-XVisibilityEvent-serial (fixnum fixnum) ( void "set_XVisibilityEvent_serial" )) +(defentry XVisibilityEvent-type (fixnum) ( fixnum "XVisibilityEvent_type" )) +(defentry set-XVisibilityEvent-type (fixnum fixnum) ( void "set_XVisibilityEvent_type" )) + + +;;;;;; XCreateWindowEvent funcions ;;;;;; + +(defentry make-XCreateWindowEvent () ( fixnum "make_XCreateWindowEvent" )) +(defentry XCreateWindowEvent-override_redirect (fixnum) ( fixnum "XCreateWindowEvent_override_redirect" )) +(defentry set-XCreateWindowEvent-override_redirect (fixnum fixnum) ( void "set_XCreateWindowEvent_override_redirect" )) +(defentry XCreateWindowEvent-border_width (fixnum) ( fixnum "XCreateWindowEvent_border_width" )) +(defentry set-XCreateWindowEvent-border_width (fixnum fixnum) ( void "set_XCreateWindowEvent_border_width" )) +(defentry XCreateWindowEvent-height (fixnum) ( fixnum "XCreateWindowEvent_height" )) +(defentry set-XCreateWindowEvent-height (fixnum fixnum) ( void "set_XCreateWindowEvent_height" )) +(defentry XCreateWindowEvent-width (fixnum) ( fixnum "XCreateWindowEvent_width" )) +(defentry set-XCreateWindowEvent-width (fixnum fixnum) ( void "set_XCreateWindowEvent_width" )) +(defentry XCreateWindowEvent-y (fixnum) ( fixnum "XCreateWindowEvent_y" )) +(defentry set-XCreateWindowEvent-y (fixnum fixnum) ( void "set_XCreateWindowEvent_y" )) +(defentry XCreateWindowEvent-x (fixnum) ( fixnum "XCreateWindowEvent_x" )) +(defentry set-XCreateWindowEvent-x (fixnum fixnum) ( void "set_XCreateWindowEvent_x" )) +(defentry XCreateWindowEvent-window (fixnum) ( fixnum "XCreateWindowEvent_window" )) +(defentry set-XCreateWindowEvent-window (fixnum fixnum) ( void "set_XCreateWindowEvent_window" )) +(defentry XCreateWindowEvent-parent (fixnum) ( fixnum "XCreateWindowEvent_parent" )) +(defentry set-XCreateWindowEvent-parent (fixnum fixnum) ( void "set_XCreateWindowEvent_parent" )) +(defentry XCreateWindowEvent-display (fixnum) ( fixnum "XCreateWindowEvent_display" )) +(defentry set-XCreateWindowEvent-display (fixnum fixnum) ( void "set_XCreateWindowEvent_display" )) +(defentry XCreateWindowEvent-send_event (fixnum) ( fixnum "XCreateWindowEvent_send_event" )) +(defentry set-XCreateWindowEvent-send_event (fixnum fixnum) ( void "set_XCreateWindowEvent_send_event" )) +(defentry XCreateWindowEvent-serial (fixnum) ( fixnum "XCreateWindowEvent_serial" )) +(defentry set-XCreateWindowEvent-serial (fixnum fixnum) ( void "set_XCreateWindowEvent_serial" )) +(defentry XCreateWindowEvent-type (fixnum) ( fixnum "XCreateWindowEvent_type" )) +(defentry set-XCreateWindowEvent-type (fixnum fixnum) ( void "set_XCreateWindowEvent_type" )) + + +;;;;;; XDestroyWindowEvent funcions ;;;;;; + +(defentry make-XDestroyWindowEvent () ( fixnum "make_XDestroyWindowEvent" )) +(defentry XDestroyWindowEvent-window (fixnum) ( fixnum "XDestroyWindowEvent_window" )) +(defentry set-XDestroyWindowEvent-window (fixnum fixnum) ( void "set_XDestroyWindowEvent_window" )) +(defentry XDestroyWindowEvent-event (fixnum) ( fixnum "XDestroyWindowEvent_event" )) +(defentry set-XDestroyWindowEvent-event (fixnum fixnum) ( void "set_XDestroyWindowEvent_event" )) +(defentry XDestroyWindowEvent-display (fixnum) ( fixnum "XDestroyWindowEvent_display" )) +(defentry set-XDestroyWindowEvent-display (fixnum fixnum) ( void "set_XDestroyWindowEvent_display" )) +(defentry XDestroyWindowEvent-send_event (fixnum) ( fixnum "XDestroyWindowEvent_send_event" )) +(defentry set-XDestroyWindowEvent-send_event (fixnum fixnum) ( void "set_XDestroyWindowEvent_send_event" )) +(defentry XDestroyWindowEvent-serial (fixnum) ( fixnum "XDestroyWindowEvent_serial" )) +(defentry set-XDestroyWindowEvent-serial (fixnum fixnum) ( void "set_XDestroyWindowEvent_serial" )) +(defentry XDestroyWindowEvent-type (fixnum) ( fixnum "XDestroyWindowEvent_type" )) +(defentry set-XDestroyWindowEvent-type (fixnum fixnum) ( void "set_XDestroyWindowEvent_type" )) + + +;;;;;; XUnmapEvent funcions ;;;;;; + +(defentry make-XUnmapEvent () ( fixnum "make_XUnmapEvent" )) +(defentry XUnmapEvent-from_configure (fixnum) ( fixnum "XUnmapEvent_from_configure" )) +(defentry set-XUnmapEvent-from_configure (fixnum fixnum) ( void "set_XUnmapEvent_from_configure" )) +(defentry XUnmapEvent-window (fixnum) ( fixnum "XUnmapEvent_window" )) +(defentry set-XUnmapEvent-window (fixnum fixnum) ( void "set_XUnmapEvent_window" )) +(defentry XUnmapEvent-event (fixnum) ( fixnum "XUnmapEvent_event" )) +(defentry set-XUnmapEvent-event (fixnum fixnum) ( void "set_XUnmapEvent_event" )) +(defentry XUnmapEvent-display (fixnum) ( fixnum "XUnmapEvent_display" )) +(defentry set-XUnmapEvent-display (fixnum fixnum) ( void "set_XUnmapEvent_display" )) +(defentry XUnmapEvent-send_event (fixnum) ( fixnum "XUnmapEvent_send_event" )) +(defentry set-XUnmapEvent-send_event (fixnum fixnum) ( void "set_XUnmapEvent_send_event" )) +(defentry XUnmapEvent-serial (fixnum) ( fixnum "XUnmapEvent_serial" )) +(defentry set-XUnmapEvent-serial (fixnum fixnum) ( void "set_XUnmapEvent_serial" )) +(defentry XUnmapEvent-type (fixnum) ( fixnum "XUnmapEvent_type" )) +(defentry set-XUnmapEvent-type (fixnum fixnum) ( void "set_XUnmapEvent_type" )) + + +;;;;;; XMapEvent funcions ;;;;;; + +(defentry make-XMapEvent () ( fixnum "make_XMapEvent" )) +(defentry XMapEvent-override_redirect (fixnum) ( fixnum "XMapEvent_override_redirect" )) +(defentry set-XMapEvent-override_redirect (fixnum fixnum) ( void "set_XMapEvent_override_redirect" )) +(defentry XMapEvent-window (fixnum) ( fixnum "XMapEvent_window" )) +(defentry set-XMapEvent-window (fixnum fixnum) ( void "set_XMapEvent_window" )) +(defentry XMapEvent-event (fixnum) ( fixnum "XMapEvent_event" )) +(defentry set-XMapEvent-event (fixnum fixnum) ( void "set_XMapEvent_event" )) +(defentry XMapEvent-display (fixnum) ( fixnum "XMapEvent_display" )) +(defentry set-XMapEvent-display (fixnum fixnum) ( void "set_XMapEvent_display" )) +(defentry XMapEvent-send_event (fixnum) ( fixnum "XMapEvent_send_event" )) +(defentry set-XMapEvent-send_event (fixnum fixnum) ( void "set_XMapEvent_send_event" )) +(defentry XMapEvent-serial (fixnum) ( fixnum "XMapEvent_serial" )) +(defentry set-XMapEvent-serial (fixnum fixnum) ( void "set_XMapEvent_serial" )) +(defentry XMapEvent-type (fixnum) ( fixnum "XMapEvent_type" )) +(defentry set-XMapEvent-type (fixnum fixnum) ( void "set_XMapEvent_type" )) + + +;;;;;; XMapRequestEvent funcions ;;;;;; + +(defentry make-XMapRequestEvent () ( fixnum "make_XMapRequestEvent" )) +(defentry XMapRequestEvent-window (fixnum) ( fixnum "XMapRequestEvent_window" )) +(defentry set-XMapRequestEvent-window (fixnum fixnum) ( void "set_XMapRequestEvent_window" )) +(defentry XMapRequestEvent-parent (fixnum) ( fixnum "XMapRequestEvent_parent" )) +(defentry set-XMapRequestEvent-parent (fixnum fixnum) ( void "set_XMapRequestEvent_parent" )) +(defentry XMapRequestEvent-display (fixnum) ( fixnum "XMapRequestEvent_display" )) +(defentry set-XMapRequestEvent-display (fixnum fixnum) ( void "set_XMapRequestEvent_display" )) +(defentry XMapRequestEvent-send_event (fixnum) ( fixnum "XMapRequestEvent_send_event" )) +(defentry set-XMapRequestEvent-send_event (fixnum fixnum) ( void "set_XMapRequestEvent_send_event" )) +(defentry XMapRequestEvent-serial (fixnum) ( fixnum "XMapRequestEvent_serial" )) +(defentry set-XMapRequestEvent-serial (fixnum fixnum) ( void "set_XMapRequestEvent_serial" )) +(defentry XMapRequestEvent-type (fixnum) ( fixnum "XMapRequestEvent_type" )) +(defentry set-XMapRequestEvent-type (fixnum fixnum) ( void "set_XMapRequestEvent_type" )) + + +;;;;;; XReparentEvent funcions ;;;;;; + +(defentry make-XReparentEvent () ( fixnum "make_XReparentEvent" )) +(defentry XReparentEvent-override_redirect (fixnum) ( fixnum "XReparentEvent_override_redirect" )) +(defentry set-XReparentEvent-override_redirect (fixnum fixnum) ( void "set_XReparentEvent_override_redirect" )) +(defentry XReparentEvent-y (fixnum) ( fixnum "XReparentEvent_y" )) +(defentry set-XReparentEvent-y (fixnum fixnum) ( void "set_XReparentEvent_y" )) +(defentry XReparentEvent-x (fixnum) ( fixnum "XReparentEvent_x" )) +(defentry set-XReparentEvent-x (fixnum fixnum) ( void "set_XReparentEvent_x" )) +(defentry XReparentEvent-parent (fixnum) ( fixnum "XReparentEvent_parent" )) +(defentry set-XReparentEvent-parent (fixnum fixnum) ( void "set_XReparentEvent_parent" )) +(defentry XReparentEvent-window (fixnum) ( fixnum "XReparentEvent_window" )) +(defentry set-XReparentEvent-window (fixnum fixnum) ( void "set_XReparentEvent_window" )) +(defentry XReparentEvent-event (fixnum) ( fixnum "XReparentEvent_event" )) +(defentry set-XReparentEvent-event (fixnum fixnum) ( void "set_XReparentEvent_event" )) +(defentry XReparentEvent-display (fixnum) ( fixnum "XReparentEvent_display" )) +(defentry set-XReparentEvent-display (fixnum fixnum) ( void "set_XReparentEvent_display" )) +(defentry XReparentEvent-send_event (fixnum) ( fixnum "XReparentEvent_send_event" )) +(defentry set-XReparentEvent-send_event (fixnum fixnum) ( void "set_XReparentEvent_send_event" )) +(defentry XReparentEvent-serial (fixnum) ( fixnum "XReparentEvent_serial" )) +(defentry set-XReparentEvent-serial (fixnum fixnum) ( void "set_XReparentEvent_serial" )) +(defentry XReparentEvent-type (fixnum) ( fixnum "XReparentEvent_type" )) +(defentry set-XReparentEvent-type (fixnum fixnum) ( void "set_XReparentEvent_type" )) + + +;;;;;; XConfigureEvent funcions ;;;;;; + +(defentry make-XConfigureEvent () ( fixnum "make_XConfigureEvent" )) +(defentry XConfigureEvent-override_redirect (fixnum) ( fixnum "XConfigureEvent_override_redirect" )) +(defentry set-XConfigureEvent-override_redirect (fixnum fixnum) ( void "set_XConfigureEvent_override_redirect" )) +(defentry XConfigureEvent-above (fixnum) ( fixnum "XConfigureEvent_above" )) +(defentry set-XConfigureEvent-above (fixnum fixnum) ( void "set_XConfigureEvent_above" )) +(defentry XConfigureEvent-border_width (fixnum) ( fixnum "XConfigureEvent_border_width" )) +(defentry set-XConfigureEvent-border_width (fixnum fixnum) ( void "set_XConfigureEvent_border_width" )) +(defentry XConfigureEvent-height (fixnum) ( fixnum "XConfigureEvent_height" )) +(defentry set-XConfigureEvent-height (fixnum fixnum) ( void "set_XConfigureEvent_height" )) +(defentry XConfigureEvent-width (fixnum) ( fixnum "XConfigureEvent_width" )) +(defentry set-XConfigureEvent-width (fixnum fixnum) ( void "set_XConfigureEvent_width" )) +(defentry XConfigureEvent-y (fixnum) ( fixnum "XConfigureEvent_y" )) +(defentry set-XConfigureEvent-y (fixnum fixnum) ( void "set_XConfigureEvent_y" )) +(defentry XConfigureEvent-x (fixnum) ( fixnum "XConfigureEvent_x" )) +(defentry set-XConfigureEvent-x (fixnum fixnum) ( void "set_XConfigureEvent_x" )) +(defentry XConfigureEvent-window (fixnum) ( fixnum "XConfigureEvent_window" )) +(defentry set-XConfigureEvent-window (fixnum fixnum) ( void "set_XConfigureEvent_window" )) +(defentry XConfigureEvent-event (fixnum) ( fixnum "XConfigureEvent_event" )) +(defentry set-XConfigureEvent-event (fixnum fixnum) ( void "set_XConfigureEvent_event" )) +(defentry XConfigureEvent-display (fixnum) ( fixnum "XConfigureEvent_display" )) +(defentry set-XConfigureEvent-display (fixnum fixnum) ( void "set_XConfigureEvent_display" )) +(defentry XConfigureEvent-send_event (fixnum) ( fixnum "XConfigureEvent_send_event" )) +(defentry set-XConfigureEvent-send_event (fixnum fixnum) ( void "set_XConfigureEvent_send_event" )) +(defentry XConfigureEvent-serial (fixnum) ( fixnum "XConfigureEvent_serial" )) +(defentry set-XConfigureEvent-serial (fixnum fixnum) ( void "set_XConfigureEvent_serial" )) +(defentry XConfigureEvent-type (fixnum) ( fixnum "XConfigureEvent_type" )) +(defentry set-XConfigureEvent-type (fixnum fixnum) ( void "set_XConfigureEvent_type" )) + + +;;;;;; XGravityEvent funcions ;;;;;; + +(defentry make-XGravityEvent () ( fixnum "make_XGravityEvent" )) +(defentry XGravityEvent-y (fixnum) ( fixnum "XGravityEvent_y" )) +(defentry set-XGravityEvent-y (fixnum fixnum) ( void "set_XGravityEvent_y" )) +(defentry XGravityEvent-x (fixnum) ( fixnum "XGravityEvent_x" )) +(defentry set-XGravityEvent-x (fixnum fixnum) ( void "set_XGravityEvent_x" )) +(defentry XGravityEvent-window (fixnum) ( fixnum "XGravityEvent_window" )) +(defentry set-XGravityEvent-window (fixnum fixnum) ( void "set_XGravityEvent_window" )) +(defentry XGravityEvent-event (fixnum) ( fixnum "XGravityEvent_event" )) +(defentry set-XGravityEvent-event (fixnum fixnum) ( void "set_XGravityEvent_event" )) +(defentry XGravityEvent-display (fixnum) ( fixnum "XGravityEvent_display" )) +(defentry set-XGravityEvent-display (fixnum fixnum) ( void "set_XGravityEvent_display" )) +(defentry XGravityEvent-send_event (fixnum) ( fixnum "XGravityEvent_send_event" )) +(defentry set-XGravityEvent-send_event (fixnum fixnum) ( void "set_XGravityEvent_send_event" )) +(defentry XGravityEvent-serial (fixnum) ( fixnum "XGravityEvent_serial" )) +(defentry set-XGravityEvent-serial (fixnum fixnum) ( void "set_XGravityEvent_serial" )) +(defentry XGravityEvent-type (fixnum) ( fixnum "XGravityEvent_type" )) +(defentry set-XGravityEvent-type (fixnum fixnum) ( void "set_XGravityEvent_type" )) + + +;;;;;; XResizeRequestEvent funcions ;;;;;; + +(defentry make-XResizeRequestEvent () ( fixnum "make_XResizeRequestEvent" )) +(defentry XResizeRequestEvent-height (fixnum) ( fixnum "XResizeRequestEvent_height" )) +(defentry set-XResizeRequestEvent-height (fixnum fixnum) ( void "set_XResizeRequestEvent_height" )) +(defentry XResizeRequestEvent-width (fixnum) ( fixnum "XResizeRequestEvent_width" )) +(defentry set-XResizeRequestEvent-width (fixnum fixnum) ( void "set_XResizeRequestEvent_width" )) +(defentry XResizeRequestEvent-window (fixnum) ( fixnum "XResizeRequestEvent_window" )) +(defentry set-XResizeRequestEvent-window (fixnum fixnum) ( void "set_XResizeRequestEvent_window" )) +(defentry XResizeRequestEvent-display (fixnum) ( fixnum "XResizeRequestEvent_display" )) +(defentry set-XResizeRequestEvent-display (fixnum fixnum) ( void "set_XResizeRequestEvent_display" )) +(defentry XResizeRequestEvent-send_event (fixnum) ( fixnum "XResizeRequestEvent_send_event" )) +(defentry set-XResizeRequestEvent-send_event (fixnum fixnum) ( void "set_XResizeRequestEvent_send_event" )) +(defentry XResizeRequestEvent-serial (fixnum) ( fixnum "XResizeRequestEvent_serial" )) +(defentry set-XResizeRequestEvent-serial (fixnum fixnum) ( void "set_XResizeRequestEvent_serial" )) +(defentry XResizeRequestEvent-type (fixnum) ( fixnum "XResizeRequestEvent_type" )) +(defentry set-XResizeRequestEvent-type (fixnum fixnum) ( void "set_XResizeRequestEvent_type" )) + + +;;;;;; XConfigureRequestEvent funcions ;;;;;; + +(defentry make-XConfigureRequestEvent () ( fixnum "make_XConfigureRequestEvent" )) +(defentry XConfigureRequestEvent-value_mask (fixnum) ( fixnum "XConfigureRequestEvent_value_mask" )) +(defentry set-XConfigureRequestEvent-value_mask (fixnum fixnum) ( void "set_XConfigureRequestEvent_value_mask" )) +(defentry XConfigureRequestEvent-detail (fixnum) ( fixnum "XConfigureRequestEvent_detail" )) +(defentry set-XConfigureRequestEvent-detail (fixnum fixnum) ( void "set_XConfigureRequestEvent_detail" )) +(defentry XConfigureRequestEvent-above (fixnum) ( fixnum "XConfigureRequestEvent_above" )) +(defentry set-XConfigureRequestEvent-above (fixnum fixnum) ( void "set_XConfigureRequestEvent_above" )) +(defentry XConfigureRequestEvent-border_width (fixnum) ( fixnum "XConfigureRequestEvent_border_width" )) +(defentry set-XConfigureRequestEvent-border_width (fixnum fixnum) ( void "set_XConfigureRequestEvent_border_width" )) +(defentry XConfigureRequestEvent-height (fixnum) ( fixnum "XConfigureRequestEvent_height" )) +(defentry set-XConfigureRequestEvent-height (fixnum fixnum) ( void "set_XConfigureRequestEvent_height" )) +(defentry XConfigureRequestEvent-width (fixnum) ( fixnum "XConfigureRequestEvent_width" )) +(defentry set-XConfigureRequestEvent-width (fixnum fixnum) ( void "set_XConfigureRequestEvent_width" )) +(defentry XConfigureRequestEvent-y (fixnum) ( fixnum "XConfigureRequestEvent_y" )) +(defentry set-XConfigureRequestEvent-y (fixnum fixnum) ( void "set_XConfigureRequestEvent_y" )) +(defentry XConfigureRequestEvent-x (fixnum) ( fixnum "XConfigureRequestEvent_x" )) +(defentry set-XConfigureRequestEvent-x (fixnum fixnum) ( void "set_XConfigureRequestEvent_x" )) +(defentry XConfigureRequestEvent-window (fixnum) ( fixnum "XConfigureRequestEvent_window" )) +(defentry set-XConfigureRequestEvent-window (fixnum fixnum) ( void "set_XConfigureRequestEvent_window" )) +(defentry XConfigureRequestEvent-parent (fixnum) ( fixnum "XConfigureRequestEvent_parent" )) +(defentry set-XConfigureRequestEvent-parent (fixnum fixnum) ( void "set_XConfigureRequestEvent_parent" )) +(defentry XConfigureRequestEvent-display (fixnum) ( fixnum "XConfigureRequestEvent_display" )) +(defentry set-XConfigureRequestEvent-display (fixnum fixnum) ( void "set_XConfigureRequestEvent_display" )) +(defentry XConfigureRequestEvent-send_event (fixnum) ( fixnum "XConfigureRequestEvent_send_event" )) +(defentry set-XConfigureRequestEvent-send_event (fixnum fixnum) ( void "set_XConfigureRequestEvent_send_event" )) +(defentry XConfigureRequestEvent-serial (fixnum) ( fixnum "XConfigureRequestEvent_serial" )) +(defentry set-XConfigureRequestEvent-serial (fixnum fixnum) ( void "set_XConfigureRequestEvent_serial" )) +(defentry XConfigureRequestEvent-type (fixnum) ( fixnum "XConfigureRequestEvent_type" )) +(defentry set-XConfigureRequestEvent-type (fixnum fixnum) ( void "set_XConfigureRequestEvent_type" )) + + +;;;;;; XCirculateEvent funcions ;;;;;; + +(defentry make-XCirculateEvent () ( fixnum "make_XCirculateEvent" )) +(defentry XCirculateEvent-place (fixnum) ( fixnum "XCirculateEvent_place" )) +(defentry set-XCirculateEvent-place (fixnum fixnum) ( void "set_XCirculateEvent_place" )) +(defentry XCirculateEvent-window (fixnum) ( fixnum "XCirculateEvent_window" )) +(defentry set-XCirculateEvent-window (fixnum fixnum) ( void "set_XCirculateEvent_window" )) +(defentry XCirculateEvent-event (fixnum) ( fixnum "XCirculateEvent_event" )) +(defentry set-XCirculateEvent-event (fixnum fixnum) ( void "set_XCirculateEvent_event" )) +(defentry XCirculateEvent-display (fixnum) ( fixnum "XCirculateEvent_display" )) +(defentry set-XCirculateEvent-display (fixnum fixnum) ( void "set_XCirculateEvent_display" )) +(defentry XCirculateEvent-send_event (fixnum) ( fixnum "XCirculateEvent_send_event" )) +(defentry set-XCirculateEvent-send_event (fixnum fixnum) ( void "set_XCirculateEvent_send_event" )) +(defentry XCirculateEvent-serial (fixnum) ( fixnum "XCirculateEvent_serial" )) +(defentry set-XCirculateEvent-serial (fixnum fixnum) ( void "set_XCirculateEvent_serial" )) +(defentry XCirculateEvent-type (fixnum) ( fixnum "XCirculateEvent_type" )) +(defentry set-XCirculateEvent-type (fixnum fixnum) ( void "set_XCirculateEvent_type" )) + + +;;;;;; XCirculateRequestEvent funcions ;;;;;; + +(defentry make-XCirculateRequestEvent () ( fixnum "make_XCirculateRequestEvent" )) +(defentry XCirculateRequestEvent-place (fixnum) ( fixnum "XCirculateRequestEvent_place" )) +(defentry set-XCirculateRequestEvent-place (fixnum fixnum) ( void "set_XCirculateRequestEvent_place" )) +(defentry XCirculateRequestEvent-window (fixnum) ( fixnum "XCirculateRequestEvent_window" )) +(defentry set-XCirculateRequestEvent-window (fixnum fixnum) ( void "set_XCirculateRequestEvent_window" )) +(defentry XCirculateRequestEvent-parent (fixnum) ( fixnum "XCirculateRequestEvent_parent" )) +(defentry set-XCirculateRequestEvent-parent (fixnum fixnum) ( void "set_XCirculateRequestEvent_parent" )) +(defentry XCirculateRequestEvent-display (fixnum) ( fixnum "XCirculateRequestEvent_display" )) +(defentry set-XCirculateRequestEvent-display (fixnum fixnum) ( void "set_XCirculateRequestEvent_display" )) +(defentry XCirculateRequestEvent-send_event (fixnum) ( fixnum "XCirculateRequestEvent_send_event" )) +(defentry set-XCirculateRequestEvent-send_event (fixnum fixnum) ( void "set_XCirculateRequestEvent_send_event" )) +(defentry XCirculateRequestEvent-serial (fixnum) ( fixnum "XCirculateRequestEvent_serial" )) +(defentry set-XCirculateRequestEvent-serial (fixnum fixnum) ( void "set_XCirculateRequestEvent_serial" )) +(defentry XCirculateRequestEvent-type (fixnum) ( fixnum "XCirculateRequestEvent_type" )) +(defentry set-XCirculateRequestEvent-type (fixnum fixnum) ( void "set_XCirculateRequestEvent_type" )) + + +;;;;;; XPropertyEvent funcions ;;;;;; + +(defentry make-XPropertyEvent () ( fixnum "make_XPropertyEvent" )) +(defentry XPropertyEvent-state (fixnum) ( fixnum "XPropertyEvent_state" )) +(defentry set-XPropertyEvent-state (fixnum fixnum) ( void "set_XPropertyEvent_state" )) +(defentry XPropertyEvent-time (fixnum) ( fixnum "XPropertyEvent_time" )) +(defentry set-XPropertyEvent-time (fixnum fixnum) ( void "set_XPropertyEvent_time" )) +(defentry XPropertyEvent-atom (fixnum) ( fixnum "XPropertyEvent_atom" )) +(defentry set-XPropertyEvent-atom (fixnum fixnum) ( void "set_XPropertyEvent_atom" )) +(defentry XPropertyEvent-window (fixnum) ( fixnum "XPropertyEvent_window" )) +(defentry set-XPropertyEvent-window (fixnum fixnum) ( void "set_XPropertyEvent_window" )) +(defentry XPropertyEvent-display (fixnum) ( fixnum "XPropertyEvent_display" )) +(defentry set-XPropertyEvent-display (fixnum fixnum) ( void "set_XPropertyEvent_display" )) +(defentry XPropertyEvent-send_event (fixnum) ( fixnum "XPropertyEvent_send_event" )) +(defentry set-XPropertyEvent-send_event (fixnum fixnum) ( void "set_XPropertyEvent_send_event" )) +(defentry XPropertyEvent-serial (fixnum) ( fixnum "XPropertyEvent_serial" )) +(defentry set-XPropertyEvent-serial (fixnum fixnum) ( void "set_XPropertyEvent_serial" )) +(defentry XPropertyEvent-type (fixnum) ( fixnum "XPropertyEvent_type" )) +(defentry set-XPropertyEvent-type (fixnum fixnum) ( void "set_XPropertyEvent_type" )) + + +;;;;;; XSelectionClearEvent funcions ;;;;;; + +(defentry make-XSelectionClearEvent () ( fixnum "make_XSelectionClearEvent" )) +(defentry XSelectionClearEvent-time (fixnum) ( fixnum "XSelectionClearEvent_time" )) +(defentry set-XSelectionClearEvent-time (fixnum fixnum) ( void "set_XSelectionClearEvent_time" )) +(defentry XSelectionClearEvent-selection (fixnum) ( fixnum "XSelectionClearEvent_selection" )) +(defentry set-XSelectionClearEvent-selection (fixnum fixnum) ( void "set_XSelectionClearEvent_selection" )) +(defentry XSelectionClearEvent-window (fixnum) ( fixnum "XSelectionClearEvent_window" )) +(defentry set-XSelectionClearEvent-window (fixnum fixnum) ( void "set_XSelectionClearEvent_window" )) +(defentry XSelectionClearEvent-display (fixnum) ( fixnum "XSelectionClearEvent_display" )) +(defentry set-XSelectionClearEvent-display (fixnum fixnum) ( void "set_XSelectionClearEvent_display" )) +(defentry XSelectionClearEvent-send_event (fixnum) ( fixnum "XSelectionClearEvent_send_event" )) +(defentry set-XSelectionClearEvent-send_event (fixnum fixnum) ( void "set_XSelectionClearEvent_send_event" )) +(defentry XSelectionClearEvent-serial (fixnum) ( fixnum "XSelectionClearEvent_serial" )) +(defentry set-XSelectionClearEvent-serial (fixnum fixnum) ( void "set_XSelectionClearEvent_serial" )) +(defentry XSelectionClearEvent-type (fixnum) ( fixnum "XSelectionClearEvent_type" )) +(defentry set-XSelectionClearEvent-type (fixnum fixnum) ( void "set_XSelectionClearEvent_type" )) + + +;;;;;; XSelectionRequestEvent funcions ;;;;;; + +(defentry make-XSelectionRequestEvent () ( fixnum "make_XSelectionRequestEvent" )) +(defentry XSelectionRequestEvent-time (fixnum) ( fixnum "XSelectionRequestEvent_time" )) +(defentry set-XSelectionRequestEvent-time (fixnum fixnum) ( void "set_XSelectionRequestEvent_time" )) +(defentry XSelectionRequestEvent-property (fixnum) ( fixnum "XSelectionRequestEvent_property" )) +(defentry set-XSelectionRequestEvent-property (fixnum fixnum) ( void "set_XSelectionRequestEvent_property" )) +(defentry XSelectionRequestEvent-target (fixnum) ( fixnum "XSelectionRequestEvent_target" )) +(defentry set-XSelectionRequestEvent-target (fixnum fixnum) ( void "set_XSelectionRequestEvent_target" )) +(defentry XSelectionRequestEvent-selection (fixnum) ( fixnum "XSelectionRequestEvent_selection" )) +(defentry set-XSelectionRequestEvent-selection (fixnum fixnum) ( void "set_XSelectionRequestEvent_selection" )) +(defentry XSelectionRequestEvent-requestor (fixnum) ( fixnum "XSelectionRequestEvent_requestor" )) +(defentry set-XSelectionRequestEvent-requestor (fixnum fixnum) ( void "set_XSelectionRequestEvent_requestor" )) +(defentry XSelectionRequestEvent-owner (fixnum) ( fixnum "XSelectionRequestEvent_owner" )) +(defentry set-XSelectionRequestEvent-owner (fixnum fixnum) ( void "set_XSelectionRequestEvent_owner" )) +(defentry XSelectionRequestEvent-display (fixnum) ( fixnum "XSelectionRequestEvent_display" )) +(defentry set-XSelectionRequestEvent-display (fixnum fixnum) ( void "set_XSelectionRequestEvent_display" )) +(defentry XSelectionRequestEvent-send_event (fixnum) ( fixnum "XSelectionRequestEvent_send_event" )) +(defentry set-XSelectionRequestEvent-send_event (fixnum fixnum) ( void "set_XSelectionRequestEvent_send_event" )) +(defentry XSelectionRequestEvent-serial (fixnum) ( fixnum "XSelectionRequestEvent_serial" )) +(defentry set-XSelectionRequestEvent-serial (fixnum fixnum) ( void "set_XSelectionRequestEvent_serial" )) +(defentry XSelectionRequestEvent-type (fixnum) ( fixnum "XSelectionRequestEvent_type" )) +(defentry set-XSelectionRequestEvent-type (fixnum fixnum) ( void "set_XSelectionRequestEvent_type" )) + + +;;;;;; XSelectionEvent funcions ;;;;;; + +(defentry make-XSelectionEvent () ( fixnum "make_XSelectionEvent" )) +(defentry XSelectionEvent-time (fixnum) ( fixnum "XSelectionEvent_time" )) +(defentry set-XSelectionEvent-time (fixnum fixnum) ( void "set_XSelectionEvent_time" )) +(defentry XSelectionEvent-property (fixnum) ( fixnum "XSelectionEvent_property" )) +(defentry set-XSelectionEvent-property (fixnum fixnum) ( void "set_XSelectionEvent_property" )) +(defentry XSelectionEvent-target (fixnum) ( fixnum "XSelectionEvent_target" )) +(defentry set-XSelectionEvent-target (fixnum fixnum) ( void "set_XSelectionEvent_target" )) +(defentry XSelectionEvent-selection (fixnum) ( fixnum "XSelectionEvent_selection" )) +(defentry set-XSelectionEvent-selection (fixnum fixnum) ( void "set_XSelectionEvent_selection" )) +(defentry XSelectionEvent-requestor (fixnum) ( fixnum "XSelectionEvent_requestor" )) +(defentry set-XSelectionEvent-requestor (fixnum fixnum) ( void "set_XSelectionEvent_requestor" )) +(defentry XSelectionEvent-display (fixnum) ( fixnum "XSelectionEvent_display" )) +(defentry set-XSelectionEvent-display (fixnum fixnum) ( void "set_XSelectionEvent_display" )) +(defentry XSelectionEvent-send_event (fixnum) ( fixnum "XSelectionEvent_send_event" )) +(defentry set-XSelectionEvent-send_event (fixnum fixnum) ( void "set_XSelectionEvent_send_event" )) +(defentry XSelectionEvent-serial (fixnum) ( fixnum "XSelectionEvent_serial" )) +(defentry set-XSelectionEvent-serial (fixnum fixnum) ( void "set_XSelectionEvent_serial" )) +(defentry XSelectionEvent-type (fixnum) ( fixnum "XSelectionEvent_type" )) +(defentry set-XSelectionEvent-type (fixnum fixnum) ( void "set_XSelectionEvent_type" )) + + +;;;;;; XColormapEvent funcions ;;;;;; + +(defentry make-XColormapEvent () ( fixnum "make_XColormapEvent" )) +(defentry XColormapEvent-state (fixnum) ( fixnum "XColormapEvent_state" )) +(defentry set-XColormapEvent-state (fixnum fixnum) ( void "set_XColormapEvent_state" )) +(defentry XColormapEvent-new (fixnum) ( fixnum "XColormapEvent_new" )) +(defentry set-XColormapEvent-new (fixnum fixnum) ( void "set_XColormapEvent_new" )) +(defentry XColormapEvent-colormap (fixnum) ( fixnum "XColormapEvent_colormap" )) +(defentry set-XColormapEvent-colormap (fixnum fixnum) ( void "set_XColormapEvent_colormap" )) +(defentry XColormapEvent-window (fixnum) ( fixnum "XColormapEvent_window" )) +(defentry set-XColormapEvent-window (fixnum fixnum) ( void "set_XColormapEvent_window" )) +(defentry XColormapEvent-display (fixnum) ( fixnum "XColormapEvent_display" )) +(defentry set-XColormapEvent-display (fixnum fixnum) ( void "set_XColormapEvent_display" )) +(defentry XColormapEvent-send_event (fixnum) ( fixnum "XColormapEvent_send_event" )) +(defentry set-XColormapEvent-send_event (fixnum fixnum) ( void "set_XColormapEvent_send_event" )) +(defentry XColormapEvent-serial (fixnum) ( fixnum "XColormapEvent_serial" )) +(defentry set-XColormapEvent-serial (fixnum fixnum) ( void "set_XColormapEvent_serial" )) +(defentry XColormapEvent-type (fixnum) ( fixnum "XColormapEvent_type" )) +(defentry set-XColormapEvent-type (fixnum fixnum) ( void "set_XColormapEvent_type" )) + + +;;;;;; XClientMessageEvent funcions ;;;;;; + +(defentry make-XClientMessageEvent () ( fixnum "make_XClientMessageEvent" )) +(defentry XClientMessageEvent-format (fixnum) ( fixnum "XClientMessageEvent_format" )) +(defentry set-XClientMessageEvent-format (fixnum fixnum) ( void "set_XClientMessageEvent_format" )) +(defentry XClientMessageEvent-message_type (fixnum) ( fixnum "XClientMessageEvent_message_type" )) +(defentry set-XClientMessageEvent-message_type (fixnum fixnum) ( void "set_XClientMessageEvent_message_type" )) +(defentry XClientMessageEvent-window (fixnum) ( fixnum "XClientMessageEvent_window" )) +(defentry set-XClientMessageEvent-window (fixnum fixnum) ( void "set_XClientMessageEvent_window" )) +(defentry XClientMessageEvent-display (fixnum) ( fixnum "XClientMessageEvent_display" )) +(defentry set-XClientMessageEvent-display (fixnum fixnum) ( void "set_XClientMessageEvent_display" )) +(defentry XClientMessageEvent-send_event (fixnum) ( fixnum "XClientMessageEvent_send_event" )) +(defentry set-XClientMessageEvent-send_event (fixnum fixnum) ( void "set_XClientMessageEvent_send_event" )) +(defentry XClientMessageEvent-serial (fixnum) ( fixnum "XClientMessageEvent_serial" )) +(defentry set-XClientMessageEvent-serial (fixnum fixnum) ( void "set_XClientMessageEvent_serial" )) +(defentry XClientMessageEvent-type (fixnum) ( fixnum "XClientMessageEvent_type" )) +(defentry set-XClientMessageEvent-type (fixnum fixnum) ( void "set_XClientMessageEvent_type" )) + + +;;;;;; XMappingEvent funcions ;;;;;; + +(defentry make-XMappingEvent () ( fixnum "make_XMappingEvent" )) +(defentry XMappingEvent-count (fixnum) ( fixnum "XMappingEvent_count" )) +(defentry set-XMappingEvent-count (fixnum fixnum) ( void "set_XMappingEvent_count" )) +(defentry XMappingEvent-first_keycode (fixnum) ( fixnum "XMappingEvent_first_keycode" )) +(defentry set-XMappingEvent-first_keycode (fixnum fixnum) ( void "set_XMappingEvent_first_keycode" )) +(defentry XMappingEvent-request (fixnum) ( fixnum "XMappingEvent_request" )) +(defentry set-XMappingEvent-request (fixnum fixnum) ( void "set_XMappingEvent_request" )) +(defentry XMappingEvent-window (fixnum) ( fixnum "XMappingEvent_window" )) +(defentry set-XMappingEvent-window (fixnum fixnum) ( void "set_XMappingEvent_window" )) +(defentry XMappingEvent-display (fixnum) ( fixnum "XMappingEvent_display" )) +(defentry set-XMappingEvent-display (fixnum fixnum) ( void "set_XMappingEvent_display" )) +(defentry XMappingEvent-send_event (fixnum) ( fixnum "XMappingEvent_send_event" )) +(defentry set-XMappingEvent-send_event (fixnum fixnum) ( void "set_XMappingEvent_send_event" )) +(defentry XMappingEvent-serial (fixnum) ( fixnum "XMappingEvent_serial" )) +(defentry set-XMappingEvent-serial (fixnum fixnum) ( void "set_XMappingEvent_serial" )) +(defentry XMappingEvent-type (fixnum) ( fixnum "XMappingEvent_type" )) +(defentry set-XMappingEvent-type (fixnum fixnum) ( void "set_XMappingEvent_type" )) + + +;;;;;; XErrorEvent funcions ;;;;;; + +(defentry make-XErrorEvent () ( fixnum "make_XErrorEvent" )) +(defentry XErrorEvent-minor_code (fixnum) ( char "XErrorEvent_minor_code" )) +(defentry set-XErrorEvent-minor_code (fixnum char) ( void "set_XErrorEvent_minor_code" )) +(defentry XErrorEvent-request_code (fixnum) ( char "XErrorEvent_request_code" )) +(defentry set-XErrorEvent-request_code (fixnum char) ( void "set_XErrorEvent_request_code" )) +(defentry XErrorEvent-error_code (fixnum) ( char "XErrorEvent_error_code" )) +(defentry set-XErrorEvent-error_code (fixnum char) ( void "set_XErrorEvent_error_code" )) +(defentry XErrorEvent-serial (fixnum) ( fixnum "XErrorEvent_serial" )) +(defentry set-XErrorEvent-serial (fixnum fixnum) ( void "set_XErrorEvent_serial" )) +(defentry XErrorEvent-resourceid (fixnum) ( fixnum "XErrorEvent_resourceid" )) +(defentry set-XErrorEvent-resourceid (fixnum fixnum) ( void "set_XErrorEvent_resourceid" )) +(defentry XErrorEvent-display (fixnum) ( fixnum "XErrorEvent_display" )) +(defentry set-XErrorEvent-display (fixnum fixnum) ( void "set_XErrorEvent_display" )) +(defentry XErrorEvent-type (fixnum) ( fixnum "XErrorEvent_type" )) +(defentry set-XErrorEvent-type (fixnum fixnum) ( void "set_XErrorEvent_type" )) + + +;;;;;; XAnyEvent funcions ;;;;;; + +(defentry make-XAnyEvent () ( fixnum "make_XAnyEvent" )) +(defentry XAnyEvent-window (fixnum) ( fixnum "XAnyEvent_window" )) +(defentry set-XAnyEvent-window (fixnum fixnum) ( void "set_XAnyEvent_window" )) +(defentry XAnyEvent-display (fixnum) ( fixnum "XAnyEvent_display" )) +(defentry set-XAnyEvent-display (fixnum fixnum) ( void "set_XAnyEvent_display" )) +(defentry XAnyEvent-send_event (fixnum) ( fixnum "XAnyEvent_send_event" )) +(defentry set-XAnyEvent-send_event (fixnum fixnum) ( void "set_XAnyEvent_send_event" )) +(defentry XAnyEvent-serial (fixnum) ( fixnum "XAnyEvent_serial" )) +(defentry set-XAnyEvent-serial (fixnum fixnum) ( void "set_XAnyEvent_serial" )) +(defentry XAnyEvent-type (fixnum) ( fixnum "XAnyEvent_type" )) +(defentry set-XAnyEvent-type (fixnum fixnum) ( void "set_XAnyEvent_type" )) + + +;;;;;; XEvent funcions ;;;;;; + +(defentry make-XEvent () ( fixnum "make_XEvent" )) +;;(defentry XEvent-pad[24] (fixnum) ( fixnum "XEvent_pad[24]" )) +;;(defentry set-XEvent-pad[24] (fixnum fixnum) ( void "set_XEvent_pad[24]" )) +;;(defentry XEvent-xkeymap (fixnum) ( XKeymapEvent "XEvent_xkeymap" )) +;;(defentry set-XEvent-xkeymap (fixnum XKeymapEvent) ( void "set_XEvent_xkeymap" )) +;;(defentry XEvent-xerror (fixnum) ( XErrorEvent "XEvent_xerror" )) +;;(defentry set-XEvent-xerror (fixnum XErrorEvent) ( void "set_XEvent_xerror" )) +;;(defentry XEvent-xmapping (fixnum) ( XMappingEvent "XEvent_xmapping" )) +;;(defentry set-XEvent-xmapping (fixnum XMappingEvent) ( void "set_XEvent_xmapping" )) +;;(defentry XEvent-xclient (fixnum) ( XClientMessageEvent "XEvent_xclient" )) +;;(defentry set-XEvent-xclient (fixnum XClientMessageEvent) ( void "set_XEvent_xclient" )) +;;(defentry XEvent-xcolormap (fixnum) ( XColormapEvent "XEvent_xcolormap" )) +;;(defentry set-XEvent-xcolormap (fixnum XColormapEvent) ( void "set_XEvent_xcolormap" )) +;;(defentry XEvent-xselection (fixnum) ( XSelectionEvent "XEvent_xselection" )) +;;(defentry set-XEvent-xselection (fixnum XSelectionEvent) ( void "set_XEvent_xselection" )) +;;(defentry XEvent-xselectionrequest (fixnum) ( XSelectionRequestEvent "XEvent_xselectionrequest" )) +;;(defentry set-XEvent-xselectionrequest (fixnum XSelectionRequestEvent) ( void "set_XEvent_xselectionrequest" )) +;;(defentry XEvent-xselectionclear (fixnum) ( XSelectionClearEvent "XEvent_xselectionclear" )) +;;(defentry set-XEvent-xselectionclear (fixnum XSelectionClearEvent) ( void "set_XEvent_xselectionclear" )) +;;(defentry XEvent-xproperty (fixnum) ( XPropertyEvent "XEvent_xproperty" )) +;;(defentry set-XEvent-xproperty (fixnum XPropertyEvent) ( void "set_XEvent_xproperty" )) +;;(defentry XEvent-xcirculaterequest (fixnum) ( XCirculateRequestEvent "XEvent_xcirculaterequest" )) +;;(defentry set-XEvent-xcirculaterequest (fixnum XCirculateRequestEvent) ( void "set_XEvent_xcirculaterequest" )) +;;(defentry XEvent-xcirculate (fixnum) ( XCirculateEvent "XEvent_xcirculate" )) +;;(defentry set-XEvent-xcirculate (fixnum XCirculateEvent) ( void "set_XEvent_xcirculate" )) +;;(defentry XEvent-xconfigurerequest (fixnum) ( XConfigureRequestEvent "XEvent_xconfigurerequest" )) +;;(defentry set-XEvent-xconfigurerequest (fixnum XConfigureRequestEvent) ( void "set_XEvent_xconfigurerequest" )) +;;(defentry XEvent-xresizerequest (fixnum) ( XResizeRequestEvent "XEvent_xresizerequest" )) +;;(defentry set-XEvent-xresizerequest (fixnum XResizeRequestEvent) ( void "set_XEvent_xresizerequest" )) +;;(defentry XEvent-xgravity (fixnum) ( XGravityEvent "XEvent_xgravity" )) +;;(defentry set-XEvent-xgravity (fixnum XGravityEvent) ( void "set_XEvent_xgravity" )) +;;(defentry XEvent-xconfigure (fixnum) ( XConfigureEvent "XEvent_xconfigure" )) +;;(defentry set-XEvent-xconfigure (fixnum XConfigureEvent) ( void "set_XEvent_xconfigure" )) +;;(defentry XEvent-xreparent (fixnum) ( XReparentEvent "XEvent_xreparent" )) +;;(defentry set-XEvent-xreparent (fixnum XReparentEvent) ( void "set_XEvent_xreparent" )) +;;(defentry XEvent-xmaprequest (fixnum) ( XMapRequestEvent "XEvent_xmaprequest" )) +;;(defentry set-XEvent-xmaprequest (fixnum XMapRequestEvent) ( void "set_XEvent_xmaprequest" )) +;;(defentry XEvent-xmap (fixnum) ( XMapEvent "XEvent_xmap" )) +;;(defentry set-XEvent-xmap (fixnum XMapEvent) ( void "set_XEvent_xmap" )) +;;(defentry XEvent-xunmap (fixnum) ( XUnmapEvent "XEvent_xunmap" )) +;;(defentry set-XEvent-xunmap (fixnum XUnmapEvent) ( void "set_XEvent_xunmap" )) +;;(defentry XEvent-xdestroywindow (fixnum) ( XDestroyWindowEvent "XEvent_xdestroywindow" )) +;;(defentry set-XEvent-xdestroywindow (fixnum XDestroyWindowEvent) ( void "set_XEvent_xdestroywindow" )) +;;(defentry XEvent-xcreatewindow (fixnum) ( XCreateWindowEvent "XEvent_xcreatewindow" )) +;;(defentry set-XEvent-xcreatewindow (fixnum XCreateWindowEvent) ( void "set_XEvent_xcreatewindow" )) +;;(defentry XEvent-xvisibility (fixnum) ( XVisibilityEvent "XEvent_xvisibility" )) +;;(defentry set-XEvent-xvisibility (fixnum XVisibilityEvent) ( void "set_XEvent_xvisibility" )) +;;(defentry XEvent-xnoexpose (fixnum) ( XNoExposeEvent "XEvent_xnoexpose" )) +;;(defentry set-XEvent-xnoexpose (fixnum XNoExposeEvent) ( void "set_XEvent_xnoexpose" )) +;;(defentry XEvent-xgraphicsexpose (fixnum) ( XGraphicsExposeEvent "XEvent_xgraphicsexpose" )) +;;(defentry set-XEvent-xgraphicsexpose (fixnum XGraphicsExposeEvent) ( void "set_XEvent_xgraphicsexpose" )) +;;(defentry XEvent-xexpose (fixnum) ( XExposeEvent "XEvent_xexpose" )) +;;(defentry set-XEvent-xexpose (fixnum XExposeEvent) ( void "set_XEvent_xexpose" )) +;;(defentry XEvent-xfocus (fixnum) ( XFocusChangeEvent "XEvent_xfocus" )) +;;(defentry set-XEvent-xfocus (fixnum XFocusChangeEvent) ( void "set_XEvent_xfocus" )) +;;(defentry XEvent-xcrossing (fixnum) ( XCrossingEvent "XEvent_xcrossing" )) +;;(defentry set-XEvent-xcrossing (fixnum XCrossingEvent) ( void "set_XEvent_xcrossing" )) +;;(defentry XEvent-xmotion (fixnum) ( XMotionEvent "XEvent_xmotion" )) +;;(defentry set-XEvent-xmotion (fixnum XMotionEvent) ( void "set_XEvent_xmotion" )) +;;(defentry XEvent-xbutton (fixnum) ( XButtonEvent "XEvent_xbutton" )) +;;(defentry set-XEvent-xbutton (fixnum XButtonEvent) ( void "set_XEvent_xbutton" )) +;;(defentry XEvent-xkey (fixnum) ( XKeyEvent "XEvent_xkey" )) +;;(defentry set-XEvent-xkey (fixnum XKeyEvent) ( void "set_XEvent_xkey" )) +;;(defentry XEvent-xany (fixnum) ( XAnyEvent "XEvent_xany" )) +;;(defentry set-XEvent-xany (fixnum XAnyEvent) ( void "set_XEvent_xany" )) +;;(defentry XEvent-type (fixnum) ( fixnum "XEvent_type" )) +;;(defentry set-XEvent-type (fixnum fixnum) ( void "set_XEvent_type" )) + + diff --git a/xgcl-2/gcl_dispatch-events.lsp b/xgcl-2/gcl_dispatch-events.lsp new file mode 100644 index 0000000..872381a --- /dev/null +++ b/xgcl-2/gcl_dispatch-events.lsp @@ -0,0 +1,50 @@ +(in-package :XLIB) +; dispatch-events.lsp Hiep Huu Nguyen 27 Aug 92 + +; Copyright (c) 1994 Hiep Huu Nguyen and The University of Texas at Austin. + +; See the files gnu.license and dec.copyright . + +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 1, or (at your option) +; any later version. + +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +; Some of the files that interface to the Xlib are adapted from DEC/MIT files. +; See the file dec.copyright for details. + + +;;have to make each type have it's own eventlist +;;and eventmask +(defun dispatch-events () + (setq *exit* nil) + (mapcar #'(lambda (x) + (Xsync x 1)) + *display-list*) + (do ((window nil) + (call-back-fn nil) + (type nil)) + (*exit*) + (dolist (a-display *display-list*) + (unless (= (XPending a-display) 0) + (XNextEvent a-display *default-event*) + (setq type (XAnyEvent-type *default-event*)) + (setq window + (gethash (XAnyEvent-window *default-event*) + *window-table*)) + (setq call-back-fns + (rest (assoc type (slot-value window 'eventlist)))) + (if call-back-fns + (dolist (call-back-fn call-back-fns) + (eval `(,call-back-fn ',window)))))))) + + diff --git a/xgcl-2/gcl_draw-gates.lsp b/xgcl-2/gcl_draw-gates.lsp new file mode 100644 index 0000000..52b004a --- /dev/null +++ b/xgcl-2/gcl_draw-gates.lsp @@ -0,0 +1,101 @@ +; draw-gates.lsp Gordon S. Novak Jr. 20 Oct 94 + +; Copyright (c) 1995 Gordon S. Novak Jr. and The University of Texas at Austin. + +; See the file gnu.license . + +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 1, or (at your option) +; any later version. + +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +; Written by: Gordon S. Novak Jr., Department of Computer Sciences, +; University of Texas at Austin 78712. novak@cs.utexas.edu + +(defun draw-nand (w x y) + (window-draw-arc-xy w (+ x 24) (+ y 16) 16 16 -90 180) + (window-draw-circle-xy w (+ x 45) (+ y 16) 4) + (window-draw-line-xy w (+ x 24) (+ y 32) x (+ y 32)) + (window-draw-line-xy w x (+ y 32) x y) + (window-draw-line-xy w x y (+ x 24) y) + (window-force-output w)) + +(setf (get 'nand 'picmenu-spec) + '(picmenu-spec 52 32 ((in1 (0 26)) (in2 (0 6)) (out (50 16))) t + draw-nand 9x15)) + +(defun draw-and (w x y) + (window-draw-arc-xy w (+ x 24) (+ y 16) 16 16 -90 180) + (window-draw-line-xy w (+ x 24) (+ y 32) x (+ y 32)) + (window-draw-line-xy w x (+ y 32) x y) + (window-draw-line-xy w x y (+ x 24) y) + (window-force-output w)) + +(setf (get 'and 'picmenu-spec) + '(picmenu-spec 40 32 ((in1 (0 26)) (in2 (0 6)) (out (40 16))) t + draw-and 9x15)) + +(defun draw-not (w x y) + (window-draw-line-xy w x (+ y 24) (+ x 21) (+ y 12)) + (window-draw-line-xy w x y (+ x 21) (+ y 12)) + (window-draw-line-xy w x y x (+ y 24)) + (window-draw-circle-xy w (+ x 23) (+ y 12) 3) + (window-force-output w)) + +(setf (get 'not 'picmenu-spec) + '(picmenu-spec 27 24 ((in (0 12)) (out (27 12))) t + draw-not 9x15)) + +(defun draw-or (w x y) + (window-draw-arc-xy w x (- y 26) 58 58 46.4 43.6) + (window-draw-arc-xy w x (+ y 58) 58 58 270.0 43.6) + (window-draw-arc-xy w (- x 16) (+ y 16) 23 23 315 90) + (window-force-output w) ) + +(setf (get 'or 'picmenu-spec) + '(picmenu-spec 40 32 ((in1 (6 26)) (in2 (6 6)) (out (40 16))) t + draw-or 9x15)) + +(defun draw-xor (w x y) + (window-draw-arc-xy w (- x 16) (+ y 16) 23 23 315 90) + (draw-or w (+ x 6) y))) + +(setf (get 'xor 'picmenu-spec) + '(picmenu-spec 46 32 ((in1 (6 26)) (in2 (6 6)) (out (46 16))) t + draw-xor 9x15)) + +(defun draw-nor (w x y) + (window-draw-circle-xy w (+ x 44) (+ y 16) 4) + (draw-or w x y))) + +(setf (get 'nor 'picmenu-spec) + '(picmenu-spec 48 32 ((in1 (0 26)) (in2 (0 6)) (out (48 16))) t + draw-nor 9x15)) + + +(defun draw-nor2 (w x y) + (window-draw-circle-xy w (+ x 4) (+ y 6) 4) + (window-draw-circle-xy w (+ x 4) (+ y 26) 4) + (draw-and w (+ x 8) y))) + +(setf (get 'nor2 'picmenu-spec) + '(picmenu-spec 48 32 ((in1 (0 26)) (in2 (0 6)) (out (48 16))) t + draw-nor2 9x15)) + +(defun draw-nand2 (w x y) + (window-draw-circle-xy w (+ x 4) (+ y 6) 4) + (window-draw-circle-xy w (+ x 4) (+ y 26) 4) + (draw-or w (+ x 4) y))) + +(setf (get 'nand2 'picmenu-spec) + '(picmenu-spec 44 32 ((in1 (0 26)) (in2 (0 6)) (out (44 16))) t + draw-nand2 9x15)) diff --git a/xgcl-2/gcl_draw.lsp b/xgcl-2/gcl_draw.lsp new file mode 100644 index 0000000..662698f --- /dev/null +++ b/xgcl-2/gcl_draw.lsp @@ -0,0 +1,1089 @@ +; draw.lsp Gordon S. Novak Jr. ; 06 Dec 07 + +; Functions to make drawings interactively + +; Copyright (c) 2007 Gordon S. Novak Jr. and The University of Texas at Austin. + +; 11 Nov 94; 05 Jan 95; 15 Jan 98; 09 Feb 99; 04 Dec 00; 28 Feb 02; 05 Jan 04 +; 27 Jan 06 + +; See the file gnu.license + +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 1, or (at your option) +; any later version. + +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +; Written by: Gordon S. Novak Jr., Department of Computer Sciences, +; University of Texas at Austin 78712. novak@cs.utexas.edu + + +; Use (draw 'foo) to make a drawing named foo. +; When finished with the drawing, give commands "Origin - to zero", "Program". +; This will produce a program (DRAW-FOO w x y) to make the drawing. +; The LaTex command will print Latex input to make the drawing +; (but LaTex cannot draw things as well as the draw program). +; (draw-output &optional names) will save things in a file for later. + +; The small square in the drawing menu is a "button" for picture menus. +; If buttons are used, a picmenu-spec will be produced with the program. + +(defvar *draw-window* nil) +(defvar *draw-window-width* 600) +(defvar *draw-window-height* 600) +(defvar *draw-leave-window* nil) ; t to leave window displayed at end +(defvar *draw-menu-set* nil) +(defvar *draw-zero-vector* '(0 0) ) +(defvar *draw-latex-factor* 1) ; multiplier from pixels to LaTex +(defvar *draw-snap-flag* t) +(defvar *draw-objects* nil) +(defvar *draw-latex-mode* nil) + +(glispglobals (*draw-window* window) ) + +(defmacro draw-descr (name) `(get ,name 'draw-descr)) + +(glispobjects + +(draw-desc (listobject (name symbol) + (objects (listof draw-object)) + (offset vector) + (size vector)) + prop ((fnname draw-desc-fnname) + (refpt draw-desc-refpt)) + msg ((draw draw-desc-draw) + (snap draw-desc-snap) + (find draw-desc-find) + (delete draw-desc-delete)) ) + +(draw-object (listobject (offset vector) + (size vector) + (contents anything) + (linewidth integer)) + default ((linewidth 1)) + prop ((region ((virtual region with start = offset size = size))) + (vregion ((virtual region with start = vstart size = vsize))) + (vstart ((virtual vector with + x = (min (x offset) ((x offset) + (x size))) - 2 + y = (min (y offset) ((y offset) + (y size))) - 2))) + (vsize ((virtual vector with x = (abs (x size)) + 4 + y = (abs (y size)) + 4))) ) + msg ((erase draw-object-erase) + (draw draw-object-draw) + (snap draw-object-snap) + (selectedp draw-object-selectedp) + (move draw-object-move)) ) + +(draw-line (listobject (offset vector) + (size vector) + (contents anything) + (linewidth integer)) + prop ((line ((virtual line-segment with p1 = offset + p2 = (offset + size))))) + msg ((draw draw-line-draw) + (snap draw-line-snap) + (selectedp draw-line-selectedp) ) + supers (draw-object) ) + +(draw-arrow (listobject (offset vector) + (size vector) + (contents anything) + (linewidth integer)) + prop ((line ((virtual line-segment with p1 = offset + p2 = (offset + size))))) + msg ((draw draw-arrow-draw) + (snap draw-line-snap) + (selectedp draw-line-selectedp) ) + supers (draw-object) ) + +(draw-box (listobject (offset vector) + (size vector) + (contents anything) + (linewidth integer)) + msg ((draw draw-box-draw) + (snap draw-box-snap) + (selectedp draw-box-selectedp) ) + supers (draw-object) ) + +(draw-rcbox (listobject (offset vector) + (size vector) + (contents anything) + (linewidth integer)) + msg ((draw draw-rcbox-draw) + (snap draw-rcbox-snap) + (selectedp draw-rcbox-selectedp) ) + supers (draw-object) ) + +(draw-erase (listobject (offset vector) + (size vector) + (contents anything) + (linewidth integer)) + msg ((draw draw-erase-draw) + (snap draw-no-snap) + (selectedp draw-erase-selectedp) ) + supers (draw-object) ) + +(draw-circle (listobject (offset vector) + (size vector) + (contents anything) + (linewidth integer)) + prop ((radius ((x size) / 2)) + (center (offset + size / 2))) + msg ((draw draw-circle-draw) + (snap draw-circle-snap) + (selectedp draw-circle-selectedp) ) + supers (draw-object) ) + +(draw-ellipse (listobject (offset vector) + (size vector) + (contents anything) + (linewidth integer)) + prop ((radiusx ((x size) / 2)) + (radiusy ((y size) / 2)) + (radius ((max radiusx radiusy))) + (center (offset + size / 2)) + (delta ((sqrt (abs (radiusx ^ 2 - radiusy ^ 2))))) + (p1 ((if (radiusx > radiusy) ; 05 Jan 04 + (a vector x = (x center) - delta + y = (y center)) + (a vector x = (x center) + y = (y center) - delta)))) + (p2 ((if (radiusx > radiusy) + (a vector x = (x center) + delta + y = (y center)) + (a vector x = (x center) + y = (y center) + delta)))) ) + msg ((draw draw-ellipse-draw) + (snap draw-ellipse-snap) + (selectedp draw-ellipse-selectedp) ) + supers (draw-object) ) + +(draw-dot (listobject (offset vector) + (size vector) + (contents anything) + (linewidth integer)) + msg ((draw draw-dot-draw) + (snap draw-dot-snap) + (selectedp draw-button-selectedp) ) + supers (draw-object) ) + +(draw-button (listobject (offset vector) + (size vector) + (contents anything) + (linewidth integer)) + msg ((draw draw-button-draw) + (snap draw-dot-snap) + (selectedp draw-button-selectedp) ) + supers (draw-object) ) + +(draw-text (listobject (offset vector) + (size vector) + (contents anything) + (linewidth integer)) + msg ((draw draw-text-draw) + (snap draw-no-snap) + (selectedp draw-text-selectedp) ) + supers (draw-object) ) + +; null object: no image, cannot be selected. +(draw-null (listobject (offset vector) + (size vector) + (contents anything) + (linewidth integer)) + msg ((draw draw-null-draw) + (snap draw-no-snap) + (selectedp draw-null-selectedp) ) + supers (draw-object) ) + +(draw-refpt (listobject (offset vector) + (size vector) + (contents anything) + (linewidth integer)) + msg ((draw draw-refpt-draw) + (snap draw-refpt-snap) + (selectedp draw-refpt-selectedp) ) + supers (draw-object) ) + +; multi-item drawing group +(draw-multi (listobject (offset vector) + (size vector) + (contents (listof draw-object)) + (linewidth integer)) + msg ((draw draw-multi-draw) + (snap draw-no-snap) + (selectedp draw-multi-selectedp) ) + supers (draw-object) ) + + +) ; glispobjects + +; 05 Jan 04 +; Get drawing description associated with name +(gldefun draw-desc ((name symbol)) + (result draw-desc) + (let ((dd draw-desc)) + (dd = (draw-descr name)) + (if ~ dd (progn (dd = (a draw-desc with name = name)) + (setf (draw-descr name) dd))) + dd)) + +; Make a window to draw in. +(setf (glfnresulttype 'draw-window) 'window) +(defun draw-window () + (or *draw-window* + (setq *draw-window* + (window-create *draw-window-width* *draw-window-height* + "Draw window"))) ) + +; 09 Sep 92; 11 Sep 92; 14 Sep 92; 16 Sep 92; 21 Oct 92; 21 May 93; 17 Dec 93 +; 05 Jan 04 +(gldefun draw ((name symbol)) + (let (w dd done sel (redraw t) (new draw-object)) + (w = (draw-window)) + (open w) + (or *draw-menu-set* (draw-init-menus)) + (dd = (draw-desc name)) + (unless (member name *draw-objects*) + (setq *draw-objects* (nconc *draw-objects* (list name)))) + (draw dd w) + (while ~ done do + (sel = (menu-set-select *draw-menu-set* redraw)) + (redraw = nil) + (case (menu-name sel) + (command + (case (port sel) + (done (done = t)) + (move (draw-desc-move dd w)) + (delete (draw-desc-delete dd w)) + (copy (draw-desc-copy dd w)) + (redraw (clear w) + (setq redraw t) + (draw dd w)) + (origin (draw-desc-origin dd w) + (clear w) + (setq redraw t) + (draw dd w)) + (program (draw-desc-program dd)) + (latex (draw-desc-latex dd)) + (latexmode (setq *draw-latex-mode* (not *draw-latex-mode*)) + (format t "Latex Mode is now ~A~%" *draw-latex-mode*)) + )) + (draw + (new = nil) + (case (port sel) + (rectangle (new = (draw-box-get dd w))) + (rcbox (new = (draw-rcbox-get dd w))) + (circle (new = (draw-circle-get dd w))) + (ellipse (new = (draw-ellipse-get dd w))) + (line (new = (draw-line-get dd w))) + (arrow (new = (draw-arrow-get dd w))) + (dot (new = (draw-dot-get dd w))) + (erase (new = (draw-erase-get dd w))) + (button (new = (draw-button-get dd w))) + (text (new = (draw-text-get dd w))) + (refpt (new = (draw-refpt-get dd w)))) + (if new + (progn ((offset new) _- (offset dd)) + ((objects dd) _+ new) + (draw new w (offset dd))))) + (background nil)) ) + (setf (draw-descr name) dd) + (unless *draw-leave-window* (close w)) + name )) + +; 06 Dec 07 +; Copy a draw description to another name +(defun copy-draw-desc (from to) + (let (old) + (setq old (copy-tree (get from 'draw-descr))) + (setf (get to 'draw-descr) + (cons (car old) (cons to (cddr old))) ) )) + +; 09 Sep 92 +(gldefun draw-desc-draw ((dd draw-desc) (w window)) + (let ( (off (offset dd)) ) + (clear w) + (for obj in (objects dd) (draw obj w off)) + (force-output w) )) + +; 11 Sep 92; 12 Sep 92; 06 Oct 92; 05 Jan 04 +; Find a draw-object such that point p selects it +(gldefun draw-desc-selected ((dd draw-desc) (p vector)) + (result draw-object) + (let (objs objsb obj) + (objs = (for obj in objects when (selectedp obj p (offset dd)) + collect obj)) + (if objs + (if (null (rest objs)) + (obj = (first objs)) + (progn (objsb = (for z in objs + when (member (first z) + '(draw-button draw-dot)) + collect z)) + (if (and objsb (null (rest objsb))) + (obj = (first objsb)))) ) ) + obj)) + +; 11 Sep 92; 12 Sep 92; 13 Sep 92; 05 Jan 04 +; Find a draw-object such that point p selects it +(gldefun draw-desc-find ((dd draw-desc) (w window) &optional (crossflg boolean)) + (result draw-object) + (let (p obj) + (while ~ obj do + (p = (if crossflg (draw-get-cross dd w) + (draw-get-crosshairs dd w))) + (obj = (draw-desc-selected dd p)) ) + obj)) + +; 15 Sep 92 +(gldefun draw-get-cross ((dd draw-desc) (w window)) + (result vector) + (draw-desc-snap dd (window-get-cross w))) + +; 15 Sep 92 +(gldefun draw-get-crosshairs ((dd draw-desc) (w window)) + (result vector) + (draw-desc-snap dd (window-get-crosshairs w))) + +; 12 Sep 92; 14 Sep 92; 06 Oct 92 +; Delete selected object +(gldefun draw-desc-delete ((dd draw-desc) (w window)) + (let (obj) + (obj = (draw-desc-find dd w t)) + (erase obj w (offset dd)) + ((objects dd) _- obj) )) + +; 12 Sep 92; 07 Oct 92 +; Copy selected object +(gldefun draw-desc-copy ((dd draw-desc) (w window)) + (let (obj (objb draw-object)) + (obj = (draw-desc-find dd w)) + (objb = (copy-tree obj)) + (draw-get-object-pos objb w) + ((offset objb) _- (offset dd)) + (draw objb w (offset dd)) + (force-output w) + ((objects dd) _+ objb) )) + +; 12 Sep 92; 13 Sep 92; 07 Oct 92; 05 Jan 04 +; Move selected object +(gldefun draw-desc-move ((dd draw-desc) (w window)) + (let (obj) + (if (obj = (draw-desc-find dd w)) + (move obj w (offset dd))) )) + +; 14 Sep 92; 28 Feb 02; 05 Jan 04; 27 Jan 06 +; Reset origin of object group +(gldefun draw-desc-origin ((dd draw-desc) (w window)) + (let (sel) + (draw-desc-bounds dd) + (sel = (menu '(("To zero" . tozero) ("Select" . select)))) + (if (sel == 'select) + ((offset dd) = (get-box-position w (x (size dd)) (y (size dd)))) + (if (sel == 'tozero) ((offset dd) = (a vector x 0 y 0)) ) ))) + +; 14 Sep 92 +; Compute boundaries of objects in a drawing; set offset and size of +; the draw-desc and reset offsets of items relative to it. +(gldefun draw-desc-bounds ((dd draw-desc)) + (let ((xmin 9999) (ymin 9999) (xmax 0) (ymax 0) basev) + (for obj in objects do + (xmin = (min xmin (x (offset obj)) + ((x (offset obj)) + (x (size obj))))) + (ymin = (min ymin (y (offset obj)) + ((y (offset obj)) + (y (size obj))))) + (xmax = (max xmax (x (offset obj)) + ((x (offset obj)) + (x (size obj))))) + (ymax = (max ymax (y (offset obj)) + ((y (offset obj)) + (y (size obj))))) ) + ((x (size dd)) = (xmax - xmin)) + ((y (size dd)) = (ymax - ymin)) + (basev = (a vector with x = xmin y = ymin)) + ((offset dd) = basev) + (for obj in objects do ((offset obj) _- basev)) )) + +; 14 Sep 92; 16 Sep 92; 19 Dec 93; 15 Jan 98; 06 Dec 07 +; Produce LaTex output for object group. +; LaTex can only *approximately* reproduce the picture. +(gldefun draw-desc-latex ((dd draw-desc)) + (let (base bx by sx sy) + (format t " \\begin{picture}(~5,0F,~5,0F)(0,0)~%" + (* (x (size dd)) *draw-latex-factor*) + (* (y (size dd)) *draw-latex-factor*) ) + (for obj in (objects dd) do + (base = (offset dd) + (offset obj)) + (bx = (x base) * *draw-latex-factor*) + (by = (y base) * *draw-latex-factor*) + (sx = (x (size obj)) * *draw-latex-factor*) + (sy = (y (size obj)) * *draw-latex-factor*) + (case (first obj) + (draw-line (latex-line (x base) (y base) + ((x base) + sx) ((y base) + sy))) + (draw-arrow (latex-line (x base) (y base) + ((x base) + sx) ((y base) + sy) t) ) + (draw-box + (format t " \\put(~5,0F,~5,0F) {\\framebox(~5,0F,~5,0F)}~%" + bx by sx sy)) + (draw-rcbox + (format t " \\put(~5,0F,~5,0F) {\\oval(~5,0F,~5,0F)}~%" + (bx + sx / 2) (by + sy / 2) sx sy)) + (draw-circle + (format t " \\put(~5,0F,~5,0F) {\\circle{~5,0F}}~%" + (bx + sx / 2) (by + sy / 2) sx)) + (draw-ellipse + (format t " \\put(~5,0F,~5,0F) {\\oval(~5,0F,~5,0F)}~%" + (bx + sx / 2) (by + sy / 2) sx sy)) + (draw-button + (format t " \\put(~5,0F,~5,0F) {\\framebox(~5,0F,~5,0F)}~%" + bx by sx sy)) + (draw-erase ) + (draw-dot + (format t " \\put(~5,0F,~5,0F) {\\circle*{~5,0F}}~%" + (bx + sx / 2) (by + sy / 2) sx)) + (draw-text + (format t " \\put(~5,0F,~5,0F) {~A}~%" + bx (by + 4 * *draw-latex-factor*) (contents obj)) ) ) ) + (format t " \\end{picture}~%") )) + +; 14 Sep 92; 15 Sep 92; 16 Sep 92; 05 Oct 92; 17 Dec 93; 21 Dec 93; 28 Feb 02 +; 05 Jan 04 +; Produce program to draw object group +(gldefun draw-desc-program ((dd draw-desc)) + (let (base bx by sx sy tox toy r rx ry s code fncode fnname cd) + (code = (for obj in (objects dd) when + (cd = (progn + (base = (offset dd) + (offset obj) - (refpt dd)) + (bx = (x base)) + (by = (y base)) + (sx = (x (size obj))) + (sy = (y (size obj))) + (tox = bx + sx) + (toy = by + sy) + (if ((car obj) == 'draw-circle) + (r = (x (size obj)) / 2)) + (if ((car obj) == 'draw-ellipse) + (progn (rx = (x (size obj)) / 2) + (ry = (y (size obj)) / 2))) + (draw-optimize + (case (first obj) + (draw-line `(window-draw-line-xy w (+ x ,bx) (+ y ,by) + (+ x ,tox) (+ y ,toy))) + (draw-arrow `(window-draw-arrow-xy w (+ x ,bx) (+ y ,by) + (+ x ,tox) (+ y ,toy))) + (draw-box `(window-draw-box-xy w (+ x ,bx) (+ y ,by) + ,sx ,sy)) + (draw-rcbox `(window-draw-rcbox-xy w (+ x ,bx) (+ y ,by) + ,sx ,sy 8)) + (draw-circle `(window-draw-circle-xy w (+ x ,(+ r bx)) + (+ y ,(+ r by)) ,r)) + (draw-ellipse `(window-draw-ellipse-xy w (+ x ,(+ rx bx)) + (+ y ,(+ ry by)) + ,rx ,ry)) + ((draw-button draw-refpt) + nil) ; let picmenu draw the buttons + (draw-erase `(window-erase-area-xy w (+ x ,bx) (+ y ,by) + ,sx ,sy)) + (draw-dot `(window-draw-dot-xy w (+ x ,(+ 2 bx)) + (+ y ,(+ 2 by)))) + (draw-text (s = (stringify (contents obj))) + `(window-printat-xy w ,s (+ x ,bx) (+ y ,by))) + )) )) + collect cd)) + (fncode = (cons 'lambda (cons (list 'w 'x 'y) + (nconc code + (list (list 'window-force-output + 'w)))))) + (fnname = (fnname dd)) + (setf (symbol-function fnname) fncode) + (format t "Constructed program (~A w x y)~%" fnname) + (draw-desc-picmenu dd) + )) + +; 21 Dec 93 +; Optimize code if GLISP is present +(defun draw-optimize (x) (if (fboundp 'glunwrap) (glunwrap x nil) x)) + +; 14 Sep 92 +(gldefun draw-desc-fnname ((dd draw-desc)) + (intern (concatenate 'string "DRAW-" (symbol-name (name dd)))) ) + +; 14 Sep 92; 06 Oct 92; 08 Apr 93; 28 Feb 02; 05 Jan 04 +; Produce a picmenu-spec from the buttons of a drawing description +(gldefun draw-desc-picmenu ((dd draw-desc)) + (let (buttons) + (buttons = (for obj in (objects dd) when ((first obj) == 'draw-button) + collect (list (contents obj) + ((a vector x 2 y 2) + (offset obj) + + (offset dd) )) ) ) + (if buttons + (setf (get (name dd) 'picmenu-spec) + (list 'picmenu-spec (x (size dd)) (y (size dd)) buttons + t (fnname dd) '9x15))) )) + +; 15 Sep 92; 05 Jan 04 +(gldefun draw-desc-snap ((dd draw-desc) (p vector)) + (result vector) + (let (psnap obj (objs (objects dd)) ) + (if *draw-snap-flag* + (while objs and ~ psnap do + (obj = (pop objs)) + (psnap = (draw-object-snap obj p (offset dd))) ) ) + (or psnap p) )) + +; 10 Sep 92; 12 Sep 92 +; Move specified object +(gldefun draw-object-move ((d draw-object) (w window) (off vector)) + (let () + (erase d w off) + (draw-get-object-pos d w) + ((offset d) _- off) + (draw d w off) + (force-output w) )) + +; 12 Sep 92; 13 Sep 92; 15 Sep 92 +; Draw an object at specified (x y) by calling its drawing function +(defun draw-object-draw-at (w x y d) + (setf (second d) (list x y)) + (draw-object-draw d w *draw-zero-vector*) ) + +; 15 Sep 92 +; Simulate glsend of draw message to an object +(defun draw-object-draw (d w off) + (funcall (glmethod (car d) 'draw) d w off) ) + +; 15 Sep 92 +; Simulate glsend of snap message to an object +(defun draw-object-snap (d p off) + (funcall (glmethod (car d) 'snap) d p off) ) + +; 15 Sep 92 +; Simulate glsend of selectedp message to an object +(defun draw-object-selectedp (d w off) + (funcall (glmethod (car d) 'selectedp) d w off) ) + +; 12 Sep 92; 07 Oct 92; 28 Feb 02; 05 Jan 04; 06 Dec 07 +(gldefun draw-get-object-pos ((d draw-object) (w window)) + (window-get-icon-position w + (if ((first d) == 'draw-text) #'draw-text-draw-outline + #'draw-object-draw-at) + (list d)) ) + +; 10 Sep 92; 15 Sep 92; 05 Jan 04 +(gldefun draw-object-erase ((d draw-object) (w window) (off vector)) + (let () + (if ((first d) <> 'draw-erase) + (progn (set-xor w) + (draw d w off) + (unset w)) ))) + +; 09 Sep 92; 17 Dec 93; 19 Dec 93; 04 Dec 00 +(gldefun draw-line-draw ((d draw-line) (w window) (off vector)) + (let ((from (off + (offset d))) (to ((off + (offset d)) + (size d))) ) + (draw-line-xy w (x from) (y from) (x to) (y to)) )) + +; 11 Sep 92; 17 Dec 93; 19 Dec 93; 04 Dec 00 +(gldefun draw-arrow-draw ((d draw-arrow) (w window) (off vector)) + (let ((from (off + (offset d))) (to ((off + (offset d)) + (size d))) ) + (draw-arrow-xy w (x from) (y from) (x to) (y to)) )) + +; 09 Sep 92; 10 Sep 92; 12 Sep 92 +(gldefun draw-line-selectedp ((d draw-line) (pt vector) (off vector)) + (let ((ptp (pt - off))) + (and (contains? (vregion d) ptp) + ((distance (line d) ptp) < 5) ) )) + +; 09 Sep 92; 10 Sep 92; 15 Sep 92; 17 Dec 93; 05 Jan 04 +(gldefun draw-line-get ((dd draw-desc) (w window)) + (let (from to) + (from = (draw-get-crosshairs dd w)) + (to = (if *draw-latex-mode* + (window-get-latex-position w (x from) (y from) nil) + (draw-desc-snap dd + (window-get-line-position w (x from) (y from))))) + (a draw-line with offset = from size = (to - from)) )) + +; 11 Sep 92; 15 Sep 92; 17 Dec 93; 05 Jan 04 +(gldefun draw-arrow-get ((dd draw-desc) (w window)) + (let (from to) + (from = (draw-get-crosshairs dd w)) + (to = (if *draw-latex-mode* + (window-get-latex-position w (x from) (y from) nil) + (draw-desc-snap dd + (window-get-line-position w (x from) (y from))))) + (a draw-arrow with offset = from size = (to - from)) )) + +; 09 Sep 92 +(gldefun draw-box-draw ((d draw-box) (w window) (off vector)) + (draw-box w (off + (offset d)) (size d)) ) + +; 09 Sep 92; 11 Sep 92 +(gldefun draw-box-selectedp ((d draw-box) (p vector) (off vector)) + (let ((pt (p - off))) + (or (and ((y pt) < (top (vregion d)) + 5) + ((y pt) > (bottom (vregion d)) - 5) + (or ((abs (x pt) - (left (vregion d))) < 5) + ((abs (x pt) - (right (vregion d))) < 5))) + (and ((x pt) < (right (vregion d)) + 5) + ((x pt) > (left (vregion d)) - 5) + (or ((abs (y pt) - (top (vregion d))) < 5) + ((abs (y pt) - (bottom (vregion d))) < 5))) ) )) + +; 11 Sep 92 +(gldefun draw-box-get ((dd draw-desc) (w window)) + (let (box) + (box = (window-get-region w)) + (a draw-box with offset = (start box) size = (size box)) )) + +; (dotimes (i 10) (print (draw-box-selectedp db (window-get-point dw)))) + +; 16 Sep 92 +(gldefun draw-rcbox-draw ((d draw-box) (w window) (off vector)) + (draw-rcbox-xy w ((x off) + (x (offset d))) ((y off) + (y (offset d))) + (x (size d)) (y (size d)) 8) ) + +; 16 Sep 92 +(gldefun draw-rcbox-selectedp ((d draw-box) (p vector) (off vector)) + (let ((pt (p - off))) + (or (and ((y pt) < (top (vregion d)) - 3) + ((y pt) > (bottom (vregion d)) + 3) + (or ((abs (x pt) - (left (vregion d))) < 5) + ((abs (x pt) - (right (vregion d))) < 5))) + (and ((x pt) < (right (vregion d)) - 3) + ((x pt) > (left (vregion d)) + 3) + (or ((abs (y pt) - (top (vregion d))) < 5) + ((abs (y pt) - (bottom (vregion d))) < 5))) ) )) + +; 16 Sep 92 +(gldefun draw-rcbox-get ((dd draw-desc) (w window)) + (let (box) + (box = (window-get-region w)) + (a draw-rcbox with offset = (start box) size = (size box)) )) + +; 09 Sep 92 +(gldefun draw-circle-draw ((d draw-circle) (w window) (off vector)) + (draw-circle w (off + (center d)) (radius d)) ) + +; 09 Sep 92; 11 Sep 92; 17 Sep 92 +(gldefun draw-circle-selectedp ((d draw-circle) (p vector) (off vector)) + ((abs (radius d) - (magnitude ((center d) + off) - p)) < 5) ) + +; 11 Sep 92; 15 Sep 92 +(gldefun draw-circle-get ((dd draw-desc) (w window)) + (let (cir cent) + (cent = (draw-get-crosshairs dd w)) + (cir = (window-get-circle w cent)) + (a draw-circle with + offset = (a vector with x = ( (x (center cir)) - (radius cir) ) + y = ( (y (center cir)) - (radius cir) )) + size = (a vector with x = 2 * (radius cir) y = 2 * (radius cir))) )) + +; 11 Sep 92 +(gldefun draw-ellipse-draw ((d draw-ellipse) (w window) (off vector)) + (let ((c (off + (center d)))) + (draw-ellipse-xy w (x c) (y c) (radiusx d) (radiusy d)) )) + +; 11 Sep 92; 15 Sep 92; 17 Sep 92 +; Uses the fact that sum of distances from foci is constant. +(gldefun draw-ellipse-selectedp ((d draw-ellipse) (p vector) (off vector)) + (let ((pt (p - off))) + ( (abs ( (magnitude ((p1 d) - pt)) + (magnitude ((p2 d) - pt)) ) + - 2 * (radius d)) < 2) )) + +; print out what the "boundary" of an ellipse looks like via selectedp +(defun draw-test-ellipse-selectedp (e) + (let ( (size (third e)) (offset (second e)) ) + (dotimes (y (+ (cadr size) 10)) + (dotimes (x (+ (car size) 10)) + (princ (if (draw-ellipse-selectedp e + (list (+ x (car offset) -5) (+ y (cadr offset) -5)) + (list 0 0)) + "T" " "))) + (terpri)) )) + +; 11 Sep 92 +(gldefun draw-ellipse-get ((dd draw-desc) (w window)) + (let (ell cent) + (cent = (draw-get-crosshairs dd w)) + (ell = (window-get-ellipse w cent)) + (a draw-ellipse with + offset = (a vector with x = ( (x (center ell)) - (x (halfsize ell)) ) + y = ( (y (center ell)) - (y (halfsize ell)) )) + size = (a vector with x = 2 * (x (halfsize ell)) + y = 2 * (y (halfsize ell)))) )) + +; 10 Sep 92 +(gldefun draw-null-draw ((d draw-null) (w window) (off vector)) nil) + +; 10 Sep 92; 11 Sep 92 +(gldefun draw-null-selectedp ((d draw-null) (pt vector) (off vector)) nil) + +; 11 Sep 92 +(gldefun draw-button-draw ((d draw-button) (w window) (off vector)) + (draw-box w (off + (offset d)) (a vector x = 4 y = 4)) ) + +; 11 Sep 92 +(gldefun draw-button-selectedp ((d draw-button) (p vector) (off vector)) + (let ( (ptx (((x p) - (x off)) - (x (offset d)))) + (pty (((y p) - (y off)) - (y (offset d)))) ) + (and (ptx > -2) (ptx < 6) (pty > -2) (pty < 6) ) )) + )) + +; 11 Sep 92 +(gldefun draw-button-get ((dd draw-desc) (w window)) + (let (cent var) + (princ "Enter button name: ") + (var = (read)) + (cent = (draw-get-crosshairs dd w)) + (a draw-button with + offset = (a vector with x = ((x cent) - 2) y = ((y cent) - 2)) + size = (a vector with x = 4 y = 4) + contents = var) )) + +; 14 Sep 92 +(gldefun draw-erase-draw ((d draw-box) (w window) (off vector)) + (erase-area w (off + (offset d)) (size d)) ) + +; 14 Sep 92 +(gldefun draw-erase-selectedp ((d draw-box) (p vector) (off vector)) + (let ((pt (p - off))) + (contains? (region d) pt) )) + +; 14 Sep 92 +(gldefun draw-erase-get ((dd draw-desc) (w window)) + (let (box) + (box = (window-get-region w)) + (a draw-erase with offset = (start box) size = (size box)) )) + +; 11 Sep 92; 14 Sep 92 +(gldefun draw-dot-draw ((d draw-dot) (w window) (off vector)) + (window-draw-dot-xy w ((x off) + (x (offset d)) + 2) + ((y off) + (y (offset d)) + 2) ) ) + +; 11 Sep 92; 15 Sep 92 +(gldefun draw-dot-get ((dd draw-desc) (w window)) + (let (cent) + (cent = (draw-get-crosshairs dd w)) + (a draw-dot with + offset = (a vector with x = ((x cent) - 2) y = ((y cent) - 2)) + size = (a vector with x = 4 y = 4)) )) + +; 17 Dec 93 +(gldefun draw-refpt-draw ((d draw-refpt) (w window) (off vector)) + (window-draw-crosshairs-xy w ((x off) + (x (offset d))) + ((y off) + (y (offset d))) ) ) + +; 17 Dec 93 +(gldefun draw-refpt-selectedp ((d draw-button) (p vector) (off vector)) + (let ( (ptx (((x p) - (x off)) - (x (offset d)))) + (pty (((y p) - (y off)) - (y (offset d)))) ) + (and (ptx > -3) (ptx < 3) (pty > -3) (pty < 3) ) )) + +; 17 Dec 93; 05 Jan 04 +(gldefun draw-refpt-get ((dd draw-desc) (w window)) + (let (cent refpt) + (if (refpt = (assoc 'draw-refpt (objects dd))) + (progn (set-erase *draw-window*) + (draw refpt *draw-window* (a vector with x = 0 y = 0)) + (unset *draw-window*) + ((objects dd) _- refpt) ) ) + (cent = (draw-get-crosshairs dd w)) + (a draw-refpt with offset = cent + size = (a vector with x = 0 y = 0)) )) + +; 17 Dec 93; 05 Jan 04 +(gldefun draw-desc-refpt ((dd draw-desc)) (result vector) + (let (refpt) + (refpt = (assoc 'draw-refpt (objects dd))) + (if refpt (offset refpt) + (a vector x = 0 y = 0)) )) + +; 11 Sep 92; 06 Oct 92; 19 Dec 93; 11 Nov 94 +(gldefun draw-text-draw ((d draw-text) (w window) (off vector)) + (printat-xy w (contents d) ((x off) + (x (offset d))) + ((y off) + (y (offset d)))) ) + +; 07 Oct 92 +(gldefun draw-text-draw-outline ((w window) (x integer) (y integer) (d draw-text)) + (setf (second d) (list x y)) + (draw-box-xy w x (y + 2) (x (size d)) (y (size d))) ) + +; define compiled version directly to avoid repeated recompilation +(defun draw-text-draw-outline (W X Y D) + (SETF (SECOND D) (LIST X Y)) + (WINDOW-DRAW-BOX-XY W X (+ 2 Y) (CAADDR D) (CADR (CADDR D)))) + +; 11 Sep 92 +(gldefun draw-text-selectedp ((d draw-text) (pt vector) (off vector)) + (let ((ptp (pt - off))) + (contains? (vregion d) ptp))) + +; 11 Sep 92; 17 Sep 92; 06 Oct 92; 11 Nov 94 +(gldefun draw-text-get ((dd draw-desc) (w window)) + (let (txt lng off) + (princ "Enter text string: ") + (txt = (stringify (read))) + (lng = (string-width w txt)) + (off = (get-box-position w lng 14)) + (a draw-text with offset = (off + (a vector x 0 y 4)) + size = (a vector with x = lng y = 14) + contents = txt) )) + +; 15 Sep 92; 05 Jan 04 +; Test if a point p1 is close to a point p2. If so, result is p2, else nil. +(gldefun draw-snapp ((p1 vector) (off vector) (p2x integer) (p2y integer)) + (if (and ((abs ((x p1) - (x off) - p2x)) < 4) + ((abs ((y p1) - (y off) - p2y)) < 4) ) + (a vector with x = ((x off) + p2x) y = ((y off) + p2y)) )) + +; 15 Sep 92 +(gldefun draw-dot-snap ((d draw-dot) (p vector) (off vector)) + (draw-snapp p off ((x (offset d)) + 2) + ((y (offset d)) + 2) ) ) + +; 17 Dec 93 +(gldefun draw-refpt-snap ((d draw-refpt) (p vector) (off vector)) + (draw-snapp p off (x (offset d)) (y (offset d)) ) ) + +; 15 Sep 92 +(gldefun draw-line-snap ((d draw-line) (p vector) (off vector)) + (or (draw-snapp p off (x (offset d)) (y (offset d))) + (draw-snapp p off ( (x (offset d)) + (x (size d)) ) + ( (y (offset d)) + (y (size d)) ) ) )) + +; 15 Sep 92; 19 Dec 93 +; Snap for square: corners, middle of sides. +(gldefun draw-box-snap ((d draw-box) (p vector) (off vector)) + (let ((xoff (x (offset d))) (yoff (y (offset d))) + (xsize (x (size d)) ) (ysize (y (size d)) ) ) + (or (draw-snapp p off xoff yoff) + (draw-snapp p off (xoff + xsize) (yoff + ysize)) + (draw-snapp p off (xoff + xsize) yoff) + (draw-snapp p off xoff (yoff + ysize)) + (draw-snapp p off (xoff + xsize / 2) yoff) + (draw-snapp p off xoff (yoff + ysize / 2)) + (draw-snapp p off (xoff + xsize / 2) (yoff + ysize)) + (draw-snapp p off (xoff + xsize) (yoff + ysize / 2)) ) )) + +; 15 Sep 92 +(gldefun draw-circle-snap ((d draw-circle) (p vector) (off vector)) + (or (draw-snapp p off ( (x (offset d)) + (radius d) ) + ( (y (offset d)) + (radius d) ) ) + (draw-snapp p off ( (x (offset d)) + (radius d) ) + (y (offset d)) ) + (draw-snapp p off (x (offset d)) + ( (y (offset d)) + (radius d) ) ) + (draw-snapp p off ( (x (offset d)) + (radius d) ) + ( (y (offset d)) + (y (size d)) ) ) + (draw-snapp p off ( (x (offset d)) + (x (size d)) ) + ( (y (offset d)) + (radius d) ) ) )) + +; 15 Sep 92 +(gldefun draw-ellipse-snap ((d draw-ellipse) (p vector) (off vector)) + (or (draw-snapp p off ( (x (offset d)) + (radiusx d) ) + ( (y (offset d)) + (radiusy d) ) ) + (draw-snapp p off ( (x (offset d)) + (radiusx d) ) + (y (offset d)) ) + (draw-snapp p off (x (offset d)) + ( (y (offset d)) + (radiusy d) ) ) + (draw-snapp p off ( (x (offset d)) + (radiusx d) ) + ( (y (offset d)) + (y (size d)) ) ) + (draw-snapp p off ( (x (offset d)) + (x (size d)) ) + ( (y (offset d)) + (radiusy d) ) ) )) + +; 16 Sep 92 +(gldefun draw-rcbox-snap ((d draw-rcbox) (p vector) (off vector)) + (let ( (rx ((x (size d)) / 2)) (ry ((y (size d)) / 2)) ) + (or (draw-snapp p off ( (x (offset d)) + rx ) (y (offset d)) ) + (draw-snapp p off (x (offset d)) ( (y (offset d)) + ry ) ) + (draw-snapp p off ( (x (offset d)) + rx ) + ( (y (offset d)) + (y (size d)) ) ) + (draw-snapp p off ( (x (offset d)) + (x (size d)) ) + ( (y (offset d)) + ry ) ) ) )) + +; 15 Sep 92 +(gldefun draw-no-snap ((d draw-ellipse) (p vector) (off vector)) nil) + +; 11 Sep 92 +(gldefun draw-multi-draw ((d draw-multi) (w window) (off vector)) + (let ( (totaloff ((offset d) + off)) ) + (for subd in (contents d) do + (draw subd w totaloff)) )) + +; 11 Sep 92; 13 Sep 92; 15 Sep 92; 16 Sep 92; 29 Sep 92; 17 Dec 93; 07 Jan 94 +; Initialize drawing and command menus +(defun draw-init-menus () + (let ((w (draw-window))) + (window-clear w) + (dolist (fn '(draw-menu-rectangle draw-menu-circle draw-menu-ellipse + draw-menu-line draw-menu-arrow draw-menu-dot + draw-menu-button draw-menu-text)) + (setf (get fn 'display-size) '(30 20)) ) + (setq *draw-menu-set* (menu-set-create w nil)) + (menu-set-add-menu *draw-menu-set* 'draw nil "Draw" + '((draw-menu-rectangle . rectangle) + (draw-menu-rcbox . rcbox) + (draw-menu-circle . circle) + (draw-menu-ellipse . ellipse) + (draw-menu-line . line) + (draw-menu-arrow . arrow) + (draw-menu-dot . dot) + (" " . erase) + (draw-menu-button . button) + (draw-menu-text . text) + (draw-menu-refpt . refpt)) + (list 0 0)) + (menu-set-adjust *draw-menu-set* 'draw 'top nil 1) + (menu-set-adjust *draw-menu-set* 'draw 'right nil 2) + (menu-set-add-menu *draw-menu-set* 'command nil "Commands" + '(("Done" . done) ("Move" . move) + ("Delete" . delete) ("Copy" . copy) + ("Redraw" . redraw) ("Origin" . origin) + ("LaTex Mode" . latexmode) + ("Make Program" . program) ("Make LaTex" . latex)) + (list 0 0)) + (menu-set-adjust *draw-menu-set* 'command 'top 'draw 5) + (menu-set-adjust *draw-menu-set* 'command 'right nil 2) )) + + +; 10 Sep 92 +(defun draw-menu-rectangle (w x y) + (window-draw-box-xy w (+ x 3) (+ y 3) 24 14 1)) +(defun draw-menu-rcbox (w x y) + (window-draw-rcbox-xy w (+ x 3) (+ y 3) 24 14 3 1)) +(defun draw-menu-circle (w x y) + (window-draw-circle-xy w (+ x 15) (+ y 10) 8 1)) +(defun draw-menu-ellipse (w x y) + (window-draw-ellipse-xy w (+ x 15) (+ y 10) 12 8 1)) +(defun draw-menu-line (w x y) + (window-draw-line-xy w (+ x 4) (+ y 4) (+ x 26) (+ y 16) 1)) +(defun draw-menu-arrow (w x y) + (window-draw-arrow-xy w (+ x 4) (+ y 4) (+ x 26) (+ y 16) 1)) +(defun draw-menu-dot (w x y) (window-draw-dot-xy w (+ x 15) (+ y 10)) ) +(defun draw-menu-button (w x y) + (window-draw-box-xy w (+ x 14) (+ y 5) 4 4 1)) +(defun draw-menu-text (w x y) + (window-printat-xy w "A" (+ x 12) (+ y 5))) +(defun draw-menu-refpt (w x y) + (window-draw-crosshairs-xy w (+ x 15) (+ y 9)) + (window-draw-circle-xy w (+ x 15) (+ y 9) 2)) + +; 14 Sep 92; 15 Jan 98 +; Draw a line or arrow in LaTex form +(defun latex-line (fromx fromy x y &optional arrowflg) + (let (dx dy sx sy siz err errb) + (setq dx (- x fromx)) + (setq dy (- y fromy)) + (if (= dx 0) + (progn (setq sx 0) + (setq sy (if (>= dy 0) 1 -1)) + (setq siz (* (abs dy) *draw-latex-factor*))) + (if (= dy 0) + (progn (setq sx (if (>= dx 0) 1 -1)) + (setq sy 0) + (setq siz (* (abs dx) *draw-latex-factor*))) + (progn + (setq err 9999) + (setq siz (* (abs dx) *draw-latex-factor*)) + (dotimes (i (if arrowflg 4 6)) + (dotimes (j (if arrowflg 4 6)) + (setq errb (abs (- (/ (float (1+ i)) + (float (1+ j))) + (abs (/ (float dx) + (float dy)))))) + (if (and (= (gcd (1+ i) (1+ j)) 1) + (< errb err)) + (progn (setq err errb) + (setq sx (1+ i)) + (setq sy (1+ j)))))) + (setq sx (* sx (latex-sign dx))) + (setq sy (* sy (latex-sign dy))) ))) + (format t " \\put(~5,0F,~5,0F) {\\~A(~D,~D){~5,0F}}~%" + (* fromx *draw-latex-factor*) (* fromy *draw-latex-factor*) + (if arrowflg "vector" "line") sx sy siz) )) + +(defun latex-sign (x) (if (>= x 0) 1 -1)) + + +; 16 Sep 92; 30 Sep 92; 02 Oct 92; 07 Oct 92 +(defun draw-output (outfilename &optional names) + (prog (prettysave lengthsave d fnname code) + (or names (setq names *draw-objects*)) + (if (symbolp names) (setq names (list names))) + (with-open-file (outfile outfilename + :direction :output + :if-exists :supersede) + (setq prettysave *print-pretty*) + (setq lengthsave *print-length*) + (setq *print-pretty* t) + (setq *print-length* 80) + (format outfile "; ~A ~A~%" + outfilename (draw-get-time-string)) + (dolist (name names) + (if (setq d (get name 'draw-descr)) + (progn (terpri outfile) + (print `(setf (get ',name 'draw-descr) ',d) outfile) + (if (and (setq fnname (draw-desc-fnname d)) + (setq code (symbol-function fnname))) + (progn (terpri outfile) + (print (cons 'defun + (if (eq (car code) 'lambda-block) + (cdr code) + (cons fnname (cdr code)))) + outfile)) ))) + (if (setq d (get name 'picmenu-spec)) + (progn (terpri outfile) + (print `(setf (get ',name 'picmenu-spec) ',d) outfile)))) + (terpri outfile) + (setq *print-pretty* prettysave) + (setq *print-length* lengthsave) ) + (return outfilename) )) + +; 09 Sep 92 +(defun draw-get-time-string () + (let (second minute hour date month year) + (multiple-value-setq (second minute hour date month year) + (get-decoded-time)) + (format nil "~2D ~A ~4D ~2D:~2D:~2D" + date (nth (1- month) '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" + "Aug" "Sep" "Oct" "Nov" "Dec")) + year hour minute second) )) + +; 14 Sep 92; 16 Sep 92; 13 July 93 +; Compile the draw.lsp and menu-set files into a plain Lisp file +(defun compile-draw () + (glcompfiles *directory* + '("glisp/vector.lsp" ; auxiliary files + "X/dwindow.lsp") + '("glisp/menu-set.lsp" ; translated files + "glisp/draw.lsp") + "glisp/drawtrans.lsp" ; output file + "glisp/draw-header.lsp") ; header file + (cf drawtrans) ) + +(defun compile-drawb () + (glcompfiles *directory* + '("glisp/vector.lsp" ; auxiliary files + "X/dwindow.lsp" "X/dwnoopen.lsp") + '("glisp/menu-set.lsp" ; translated files + "glisp/draw.lsp") + "glisp/drawtrans.lsp" ; output file + "glisp/draw-header.lsp") ; header file + ) + +; 16 Nov 92; 08 Apr 93; 08 Oct 93; 20 Apr 94; 29 Oct 94; 09 Feb 99 +; Output drawing descriptions and functions to the specified file +(defun draw-out (&optional names file) + (or names (setq names *draw-objects*)) + (if (not (consp names)) (setq names (list names))) + (draw-output (or file "glisp/draw.del") names) + (setq *draw-objects* (set-difference *draw-objects* names)) + names ) diff --git a/xgcl-2/gcl_drawtrans.lsp b/xgcl-2/gcl_drawtrans.lsp new file mode 100644 index 0000000..26ecd90 --- /dev/null +++ b/xgcl-2/gcl_drawtrans.lsp @@ -0,0 +1,1890 @@ +; 07 Jan 2010 16:40:19 EST +; drawtrans.lsp -- translation of draw.lsp Gordon S. Novak Jr. + +; Copyright (c) 2006 Gordon S. Novak Jr. and The University of Texas at Austin. + +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 2 of the License, or +; (at your option) any later version. + +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + +; Written by: Gordon S. Novak Jr., Department of Computer Sciences, +; University of Texas at Austin 78712. novak@cs.utexas.edu + +(IN-PACKAGE :USER) + +(defmacro while (test &rest forms) `(loop (unless ,test (return)) ,@forms) ) + +(defmacro nconc1 (lst x) `(nconc ,lst (cons ,x nil))) + +(defmacro glmethod (class selector) + `(cadr (assoc ,selector (getf (cdr (get ,class 'glstructure)) 'msg))) ) + +(SETF (GET 'MENU-SET 'GLSTRUCTURE) + '((LISTOBJECT (WINDOW WINDOW) (MENU-ITEMS (LISTOF MENU-SET-ITEM)) + (COMMANDFN ANYTHING)) + MSG + ((DRAW MENU-SET-DRAW) (SELECT MENU-SET-SELECT) + (NAMED-MENU MENU-SET-NAMED-MENU) + (NAMED-ITEM MENU-SET-NAMED-ITEM) (ADD-MENU MENU-SET-ADD-MENU) + (ADD-PICMENU MENU-SET-ADD-PICMENU) + (ADD-COMPONENT MENU-SET-ADD-COMPONENT) + (ADD-BARMENU MENU-SET-ADD-BARMENU) + (ADD-ITEM MENU-SET-ADD-ITEM) (FIND-ITEM MENU-SET-FIND-ITEM) + (DELETE-ITEM MENU-SET-DELETE-ITEM) + (REMOVE-ITEMS MENU-SET-REMOVE-ITEMS) + (ITEM-POSITION MENU-SET-ITEM-POSITION) (ITEMP MENU-SET-ITEMP) + (ADJUST MENU-SET-ADJUST) (MOVE MENU-SET-MOVE) + (DRAW-CONN MENU-SET-DRAW-CONN)))) +(SETF (GET 'MENU-SET-ITEM 'GLSTRUCTURE) + '((LIST (MENU-NAME SYMBOL) (SYM ANYTHING) (MENU MENU-SET-MENU)) + PROP + ((LEFT ((PARENT-OFFSET-X MENU))) + (BOTTOM ((PARENT-OFFSET-Y MENU))) + (WIDTH ((PICTURE-WIDTH MENU))) + (HEIGHT ((PICTURE-HEIGHT MENU)))) + SUPERS (REGION))) +(SETF (GET 'MENU-SET-MENU 'GLSTRUCTURE) + '((TRANSPARENT MENU) MSG ((DRAW MENU-MDRAW)))) +(SETF (GET 'MENU-PORT 'GLSTRUCTURE) + '((LIST (PORT SYMBOL) (MENU-NAME SYMBOL)))) +(SETF (GET 'MENU-SELECTION 'GLSTRUCTURE) + '((LIST (PORT SYMBOL) (MENU-NAME SYMBOL) (BUTTON INTEGER)))) +(SETF (GET 'MENU-SET-CONN 'GLSTRUCTURE) + '((LIST (FROM MENU-PORT) (TO MENU-PORT)))) +(SETF (GET 'MENU-CONNS 'GLSTRUCTURE) + '((LISTOBJECT (MENU-SET MENU-SET) + (CONNECTIONS (LISTOF MENU-SET-CONN))) + PROP ((WINDOW ((WINDOW (MENU-SET SELF))))) MSG + ((DRAW MENU-CONNS-DRAW) (REDRAW MENU-CONNS-REDRAW) + (MOVE MENU-CONNS-MOVE) (ADD-CONN MENU-CONNS-ADD-CONN) + (ADD-ITEM MENU-CONNS-ADD-ITEM OPEN T) + (FIND-CONN MENU-CONNS-FIND-CONN) + (FIND-ITEM MENU-CONNS-FIND-ITEM) + (DELETE-ITEM MENU-CONNS-DELETE-ITEM) + (DELETE-CONN MENU-CONNS-DELETE-CONN) + (REMOVE-ITEMS MENU-CONNS-REMOVE-ITEMS) + (FIND-CONNS MENU-CONNS-FIND-CONNS) + (CONNECTED-PORTS MENU-CONNS-CONNECTED-PORTS) + (NEW-CONN MENU-CONNS-NEW-CONN) + (NAMED-MENU MENU-CONNS-NAMED-MENU) + (NAMED-ITEM MENU-CONNS-NAMED-ITEM)))) + + +(DEFUN MENU-SET-CREATE (W &OPTIONAL FN) (LIST 'MENU-SET W NIL FN)) +(SETF (GET 'MENU-SET-CREATE 'GLARGUMENTS) + '((W WINDOW) (&OPTIONAL NIL))) +(SETF (GET 'MENU-SET-CREATE 'GLFNRESULTTYPE) 'MENU-SET) + + +(DEFUN MENU-SET-SELECT (MS &OPTIONAL REDRAW ENABLED) + (LET (RES RESB ITM SEL LASTX LASTY) + (IF REDRAW (MENU-SET-DRAW MS)) + (WHILE (NOT (OR RES RESB)) + (SETQ ITM + (WINDOW-TRACK-MOUSE (CADR MS) + #'(LAMBDA (X Y CODE) + (OR (AND (PLUSP CODE) (SETQ LASTX X) + (SETQ LASTY Y) CODE) + (SOME #'(LAMBDA (GLVAR128) + (IF + (AND + (BETWEEN X + (FIFTH (CADDR GLVAR128)) + (+ (FIFTH (CADDR GLVAR128)) + (SEVENTH (CADDR GLVAR128)))) + (BETWEEN Y + (SIXTH (CADDR GLVAR128)) + (+ (SIXTH (CADDR GLVAR128)) + (EIGHTH (CADDR GLVAR128))))) + GLVAR128)) + (CADDR MS)))))) + (IF (NUMBERP ITM) + (SETQ RESB (LIST (LIST LASTX LASTY) 'BACKGROUND ITM)) + (WHEN (OR (ATOM ENABLED) (MEMBER (CAR ITM) ENABLED)) + (SETQ SEL (MENU-MSELECT (CADDR ITM) (EQ ENABLED T))) + (IF SEL + (SETQ RES (LIST SEL (CAR ITM) *WINDOW-MENU-CODE*)) + (IF (AND *WINDOW-MENU-CODE* + (NOT (ZEROP *WINDOW-MENU-CODE*))) + (SETQ RES + (LIST NIL (CAR ITM) *WINDOW-MENU-CODE*))))))) + (XFLUSH *WINDOW-DISPLAY*) + (OR RES RESB))) +(SETF (GET 'MENU-SET-SELECT 'GLARGUMENTS) + '((MS MENU-SET) (&OPTIONAL BOOLEAN) (REDRAW (LISTOF SYMBOL)))) +(SETF (GET 'MENU-SET-SELECT 'GLFNRESULTTYPE) 'MENU-SELECTION) + + +(DEFUN MENU-SET-ADD-MENU (MS NAME SYM TITLE ITEMS &OPTIONAL OFFSET) + (LET (MENU) + (SETQ MENU + (MENU-CREATE ITEMS TITLE (CADR MS) (CAR OFFSET) (CADR OFFSET) + T T)) + (MENU-INIT MENU) + (IF (NOT OFFSET) + (SETQ OFFSET + (WINDOW-GET-BOX-POSITION (CADR MS) (SEVENTH MENU) + (EIGHTH MENU)))) + (SETF (FIFTH MENU) (CAR OFFSET)) + (SETF (SIXTH MENU) (CADR OFFSET)) + (MENU-SET-ADD-ITEM MS NAME SYM MENU))) +(SETF (GET 'MENU-SET-ADD-MENU 'GLARGUMENTS) + '((MS MENU-SET) (NAME SYMBOL) (SYM SYMBOL) (TITLE STRING) + (ITEMS NIL) (&OPTIONAL VECTOR))) +(SETF (GET 'MENU-SET-ADD-MENU 'GLFNRESULTTYPE) '(LISTOF MENU-SET-ITEM)) + + +(DEFUN MENU-SET-ADD-ITEM (MS NAME SYM MENU) + (SETF (CADDR MS) (NCONC (CADDR MS) (CONS (LIST NAME SYM MENU) NIL)))) +(SETF (GET 'MENU-SET-ADD-ITEM 'GLARGUMENTS) + '((MS MENU-SET) (NAME SYMBOL) (SYM SYMBOL) (MENU MENU))) +(SETF (GET 'MENU-SET-ADD-ITEM 'GLFNRESULTTYPE) '(LISTOF MENU-SET-ITEM)) + + +(DEFUN MENU-SET-REMOVE-ITEMS (MS) (SETF (CADDR MS) NIL)) +(SETF (GET 'MENU-SET-REMOVE-ITEMS 'GLARGUMENTS) '((MS MENU-SET))) +(SETF (GET 'MENU-SET-REMOVE-ITEMS 'GLFNRESULTTYPE) + '(LISTOF MENU-SET-ITEM)) + + +(DEFUN MENU-SET-ADD-PICMENU + (MS NAME SYM TITLE SPEC &OPTIONAL OFFSET NOBOX) + (LET (MENU MAXWIDTH MAXHEIGHT) + (IF (AND SPEC (SYMBOLP SPEC)) (SETQ SPEC (GET SPEC 'PICMENU-SPEC))) + (SETQ MENU + (PICMENU-CREATE-FROM-SPEC SPEC TITLE (CADR MS) (CAR OFFSET) + (CADR OFFSET) T T (NOT NOBOX))) + (SETQ MAXWIDTH + (MAX (IF TITLE (+ 6 (* 9 (LENGTH TITLE))) 0) (CADR SPEC))) + (SETQ MAXHEIGHT (+ (IF TITLE 15 0) (CADDR SPEC))) + (IF (NOT OFFSET) + (SETQ OFFSET + (WINDOW-GET-BOX-POSITION (CADR MS) MAXWIDTH MAXHEIGHT))) + (SETF (FIFTH MENU) (CAR OFFSET)) + (SETF (SIXTH MENU) (CADR OFFSET)) + (MENU-SET-ADD-ITEM MS NAME SYM MENU))) +(SETF (GET 'MENU-SET-ADD-PICMENU 'GLARGUMENTS) + '((MS MENU-SET) (NAME SYMBOL) (SYM SYMBOL) (TITLE STRING) + (SPEC PICMENU-SPEC) (&OPTIONAL VECTOR) (OFFSET BOOLEAN))) +(SETF (GET 'MENU-SET-ADD-PICMENU 'GLFNRESULTTYPE) + '(LISTOF MENU-SET-ITEM)) + + +(DEFUN MENU-SET-ADD-COMPONENT (MS NAME &OPTIONAL OFFSET) + (MENU-SET-ADD-PICMENU MS (MENU-SET-NAME NAME) NAME NIL NAME OFFSET T)) +(SETF (GET 'MENU-SET-ADD-COMPONENT 'GLARGUMENTS) + '((MS MENU-SET) (NAME SYMBOL) (&OPTIONAL VECTOR))) +(SETF (GET 'MENU-SET-ADD-COMPONENT 'GLFNRESULTTYPE) + '(LISTOF MENU-SET-ITEM)) + + +(DEFUN MENU-SET-ADD-BARMENU (MS NAME SYM MENU TITLE &OPTIONAL OFFSET) + (BARMENU-INIT MENU) + (IF (NOT OFFSET) + (SETQ OFFSET + (WINDOW-GET-BOX-POSITION (CADR MS) (SEVENTH MENU) + (EIGHTH MENU)))) + (SETF (FIFTH MENU) (CAR OFFSET)) + (SETF (SIXTH MENU) (CADR OFFSET)) + (MENU-SET-ADD-ITEM MS NAME SYM MENU)) +(SETF (GET 'MENU-SET-ADD-BARMENU 'GLARGUMENTS) + '((MS MENU-SET) (NAME SYMBOL) (SYM SYMBOL) (MENU BARMENU) + (TITLE STRING) (&OPTIONAL VECTOR))) +(SETF (GET 'MENU-SET-ADD-BARMENU 'GLFNRESULTTYPE) + '(LISTOF MENU-SET-ITEM)) + + +(DEFUN MENU-SET-NAME (NM) + (INTERN (SYMBOL-NAME (GENSYM (SYMBOL-NAME NM))))) +(SETF (GET 'MENU-SET-NAME 'GLARGUMENTS) '((NM SYMBOL))) +(SETF (GET 'MENU-SET-NAME 'GLFNRESULTTYPE) 'SYMBOL) + + +(DEFUN MENU-SET-NAMED-ITEM (MS NAME) (ASSOC NAME (CADDR MS))) +(SETF (GET 'MENU-SET-NAMED-ITEM 'GLARGUMENTS) + '((MS MENU-SET) (NAME SYMBOL))) +(SETF (GET 'MENU-SET-NAMED-ITEM 'GLFNRESULTTYPE) 'MENU-SET-ITEM) + + +(DEFUN MENU-SET-NAMED-MENU (MS NAME) + (CADDR (MENU-SET-NAMED-ITEM MS NAME))) +(SETF (GET 'MENU-SET-NAMED-MENU 'GLARGUMENTS) + '((MS MENU-SET) (NAME SYMBOL))) +(SETF (GET 'MENU-SET-NAMED-MENU 'GLFNRESULTTYPE) 'MENU-SET-MENU) + + +(DEFUN MENU-SET-ITEMP (MS NAME ITEMNAME) + (LET ((THISMENU (MENU-SET-NAMED-MENU MS NAME))) + (IF (EQ (FIRST THISMENU) 'MENU) + (SOME #'(LAMBDA (X) + (OR (EQ X ITEMNAME) + (AND (CONSP X) (EQ (CAR X) ITEMNAME)))) + (NTH 13 THISMENU)) + (IF (EQ (FIRST THISMENU) 'PICMENU) + (ASSOC ITEMNAME (CADDDR (NTH 10 THISMENU))))))) +(SETF (GET 'MENU-SET-ITEMP 'GLARGUMENTS) + '((MS MENU-SET) (NAME SYMBOL) (ITEMNAME SYMBOL))) +(SETF (GET 'MENU-SET-ITEMP 'GLFNRESULTTYPE) 'BOOLEAN) + + +(DEFUN MENU-CONNS-NAMED-ITEM (MC NAME) + (MENU-SET-NAMED-ITEM (CADR MC) NAME)) +(SETF (GET 'MENU-CONNS-NAMED-ITEM 'GLARGUMENTS) + '((MC MENU-CONNS) (NAME SYMBOL))) +(SETF (GET 'MENU-CONNS-NAMED-ITEM 'GLFNRESULTTYPE) 'MENU-SET-ITEM) + + +(DEFUN MENU-CONNS-NAMED-MENU (MC NAME) + (MENU-SET-NAMED-MENU (CADR MC) NAME)) +(SETF (GET 'MENU-CONNS-NAMED-MENU 'GLARGUMENTS) + '((MC MENU-CONNS) (NAME SYMBOL))) +(SETF (GET 'MENU-CONNS-NAMED-MENU 'GLFNRESULTTYPE) 'MENU-SET-MENU) + + +(DEFUN MENU-SET-FIND-ITEM (MS POS) + (LET (MITEM) + (DOLIST (MI (CADDR MS)) + (IF (AND (BETWEEN (CAR POS) + (LET ((SELF (CADDR MI))) + (IF (CADDR SELF) (FIFTH SELF) 0)) + (+ (LET ((SELF (CADDR MI))) + (IF (CADDR SELF) (FIFTH SELF) 0)) + (SEVENTH (CADDR MI)))) + (BETWEEN (CADR POS) + (LET ((SELF (CADDR MI))) + (IF (CADDR SELF) (SIXTH SELF) 0)) + (+ (LET ((SELF (CADDR MI))) + (IF (CADDR SELF) (SIXTH SELF) 0)) + (EIGHTH (CADDR MI))))) + (SETQ MITEM MI))) + MITEM)) +(SETF (GET 'MENU-SET-FIND-ITEM 'GLARGUMENTS) + '((MS MENU-SET) (POS VECTOR))) +(SETF (GET 'MENU-SET-FIND-ITEM 'GLFNRESULTTYPE) 'MENU-SET-ITEM) + + +(DEFUN MENU-SET-DELETE-ITEM (MS MI) + (SETF (CADDR MS) (REMOVE MI (CADDR MS)))) +(SETF (GET 'MENU-SET-DELETE-ITEM 'GLARGUMENTS) + '((MS MENU-SET) (MI MENU-SET-ITEM))) +(SETF (GET 'MENU-SET-DELETE-ITEM 'GLFNRESULTTYPE) + '(LISTOF MENU-SET-ITEM)) + + +(DEFUN MENU-SET-MOVE (MS) + (LET (SEL M) + (SETQ SEL (MENU-SET-SELECT MS NIL T)) + (SETQ M (MENU-SET-NAMED-MENU MS (CADR SEL))) + (MENU-REPOSITION M))) + +(DEFUN MENU-MDRAW (M) + (CASE (FIRST M) + (MENU (MENU-DRAW M)) + (PICMENU (PICMENU-DRAW M)) + (BARMENU (BARMENU-DRAW M)) + (TEXTMENU (TEXTMENU-DRAW M)) + (EDITMENU (EDITMENU-DRAW M)) + (T (GLSEND M DRAW)))) + +(DEFUN MENU-MSELECT (M &OPTIONAL ANYCLICK) + (CASE (FIRST M) + (MENU (MENU-SELECT M T)) + (PICMENU (PICMENU-SELECT M T ANYCLICK)) + (BARMENU (BARMENU-SELECT M)) + (TEXTMENU (TEXTMENU-SELECT M T)) + (EDITMENU (EDITMENU-SELECT M T)) + (T (GLSEND M SELECT)))) + +(DEFUN MENU-MITEM-POSITION (M NAME LOC) + (CASE (FIRST M) + (MENU (MENU-ITEM-POSITION M NAME LOC)) + (PICMENU (PICMENU-ITEM-POSITION M NAME LOC)) + (T (GLSEND M ITEM-POSITION NAME LOC)))) + +(DEFUN MENU-SET-DRAW (MS) + (XMAPWINDOW *WINDOW-DISPLAY* (CADADR MS)) + (XFLUSH *WINDOW-DISPLAY*) + (WINDOW-WAIT-EXPOSURE (CADR MS)) + (DOLIST (ITEM (CADDR MS)) (MENU-MDRAW (CADDR ITEM)))) + +(DEFUN MENU-SET-ITEM-POSITION (MS DESC &OPTIONAL LOC) + (LET (M) + (SETQ M (MENU-SET-NAMED-MENU MS (CADR DESC))) + (OR (MENU-MITEM-POSITION M (CAR DESC) LOC) + (MENU-MITEM-POSITION M NIL LOC)))) +(SETF (GET 'MENU-SET-ITEM-POSITION 'GLARGUMENTS) + '((MS MENU-SET) (DESC MENU-PORT) (&OPTIONAL SYMBOL))) +(SETF (GET 'MENU-SET-ITEM-POSITION 'GLFNRESULTTYPE) 'VECTOR) + + +(DEFUN MENU-SET-DRAW-CONN (MS CONN) + (LET (PA PB TMP (DESCA (CAR CONN)) (DESCB (CADR CONN))) + (SETQ PA (MENU-SET-ITEM-POSITION MS DESCA 'CENTER)) + (SETQ PB (MENU-SET-ITEM-POSITION MS DESCB 'CENTER)) + (WHEN (> (CAR PA) (CAR PB)) + (SETQ TMP DESCA) + (SETQ DESCA DESCB) + (SETQ DESCB TMP)) + (SETQ PA (MENU-SET-ITEM-POSITION MS DESCA 'RIGHT)) + (SETQ PB (MENU-SET-ITEM-POSITION MS DESCB 'LEFT)) + (WINDOW-DRAW-CIRCLE-XY (CADR MS) (CAR PA) (CADR PA) 3 NIL) + (WINDOW-DRAW-LINE-XY (CADR MS) (CAR PA) (CADR PA) (CAR PB) + (CADR PB) NIL) + (WINDOW-DRAW-CIRCLE-XY (CADR MS) (CAR PB) (CADR PB) 3 NIL) + (XFLUSH *WINDOW-DISPLAY*))) + +(DEFUN MENU-SET-ADJUST (MS NAME EDGE FROM OFFSET) + (LET (M FROMM PLACE) + (WHEN (SETQ M (MENU-SET-NAMED-ITEM MS NAME)) + (IF FROM + (PROGN + (SETQ FROMM (MENU-SET-NAMED-ITEM MS FROM)) + (SETQ PLACE + (CASE EDGE + (TOP (SIXTH (CADDR FROMM))) + (BOTTOM (+ (SIXTH (CADDR FROMM)) + (EIGHTH (CADDR FROMM)))) + (LEFT (+ (FIFTH (CADDR FROMM)) + (SEVENTH (CADDR FROMM)))) + (RIGHT (FIFTH (CADDR FROMM)))))) + (SETQ PLACE + (CASE EDGE + (TOP (CADDDR (CADR MS))) + ((BOTTOM LEFT) 0) + (RIGHT (FIFTH (CADR MS)))))) + (CASE EDGE + (TOP (SETF (SIXTH (CADDR M)) + (- (- PLACE (EIGHTH (CADDR M))) OFFSET))) + (BOTTOM (SETF (SIXTH (CADDR M)) (+ PLACE OFFSET))) + (LEFT (SETF (FIFTH (CADDR M)) (+ PLACE OFFSET))) + (RIGHT (SETF (FIFTH (CADDR M)) + (- (- PLACE (SEVENTH (CADDR M))) OFFSET))))))) +(SETF (GET 'MENU-SET-ADJUST 'GLARGUMENTS) + '((MS MENU-SET) (NAME SYMBOL) (EDGE SYMBOL) (FROM SYMBOL) + (OFFSET INTEGER))) +(SETF (GET 'MENU-SET-ADJUST 'GLFNRESULTTYPE) 'INTEGER) + + +(DEFUN VECTOR-SNAP (FIXED APPROX &OPTIONAL TOLERANCE) + (OR TOLERANCE (SETQ TOLERANCE 10)) + (IF (< (ABS (- (CAR FIXED) (CAR APPROX))) TOLERANCE) + (LIST (CAR FIXED) (CADR APPROX)) + (IF (< (ABS (- (CADR FIXED) (CADR APPROX))) TOLERANCE) + (LIST (CAR APPROX) (CADR FIXED)) APPROX))) +(SETF (GET 'VECTOR-SNAP 'GLARGUMENTS) + '((FIXED VECTOR) (APPROX VECTOR) (&OPTIONAL NIL))) +(SETF (GET 'VECTOR-SNAP 'GLFNRESULTTYPE) 'VECTOR) + + +(DEFUN MENU-CONNS-CREATE (MS) (LIST 'MENU-CONNS MS NIL)) +(SETF (GET 'MENU-CONNS-CREATE 'GLARGUMENTS) '((MS MENU-SET))) +(SETF (GET 'MENU-CONNS-CREATE 'GLFNRESULTTYPE) 'MENU-CONNS) + + +(DEFUN MENU-CONNS-DRAW (MC) + (MENU-SET-DRAW (CADR MC)) + (DOLIST (C (CADDR MC)) (MENU-SET-DRAW-CONN (CADR MC) C))) + +(DEFUN MENU-CONNS-MOVE (MC) + (MENU-SET-MOVE (CADR MC)) + (XCLEARWINDOW *WINDOW-DISPLAY* (CADR (CADADR MC))) + (XFLUSH *WINDOW-DISPLAY*) + (MENU-CONNS-DRAW MC)) + +(DEFUN MENU-CONNS-REDRAW (MC) + (XCLEARWINDOW *WINDOW-DISPLAY* (CADR (CADADR MC))) + (XFLUSH *WINDOW-DISPLAY*) + (MENU-CONNS-DRAW MC)) + +(DEFUN MENU-CONNS-ADD-CONN (MC) + (LET (SEL SELB CONN) + (SETQ SEL (MENU-SET-SELECT (CADR MC))) + (IF (EQ (CADR SEL) 'BACKGROUND) SEL + (PROGN + (SETQ SELB (MENU-SET-SELECT (CADR MC))) + (WHEN (NOT (EQ (CADR SELB) 'BACKGROUND)) + (SETQ CONN (LIST SEL SELB)) + (MENU-SET-DRAW-CONN (CADR MC) CONN) + (SETF (CADDR MC) (NCONC (CADDR MC) (CONS CONN NIL)))) + NIL)))) +(SETF (GET 'MENU-CONNS-ADD-CONN 'GLARGUMENTS) '((MC MENU-CONNS))) +(SETF (GET 'MENU-CONNS-ADD-CONN 'GLFNRESULTTYPE) 'MENU-SELECTION) + + +(DEFUN MENU-CONNS-NEW-CONN (MC FROMNAME FROMPORT TONAME TOPORT) + (LET (CONN) + (SETQ CONN (LIST (LIST FROMPORT FROMNAME) (LIST TOPORT TONAME))) + (SETF (CADDR MC) (NCONC (CADDR MC) (CONS CONN NIL))))) +(SETF (GET 'MENU-CONNS-NEW-CONN 'GLARGUMENTS) + '((MC MENU-CONNS) (FROMNAME SYMBOL) (FROMPORT SYMBOL) + (TONAME SYMBOL) (TOPORT SYMBOL))) +(SETF (GET 'MENU-CONNS-NEW-CONN 'GLFNRESULTTYPE) + '(LISTOF MENU-SET-CONN)) + + +(DEFUN MENU-CONNS-ADD-ITEM (MC NAME SYM MENU) + (MENU-SET-ADD-ITEM (CADR MC) NAME SYM MENU)) +(SETF (GET 'MENU-CONNS-ADD-ITEM 'GLARGUMENTS) + '((MC MENU-CONNS) (NAME SYMBOL) (SYM SYMBOL) (MENU MENU))) +(SETF (GET 'MENU-CONNS-ADD-ITEM 'GLFNRESULTTYPE) + '(LISTOF MENU-SET-ITEM)) + + +(DEFUN MENU-CONNS-FIND-CONN (MC PT) + (LET (MS LS FOUND RES PA PB TMP DESCA DESCB) + (SETQ LS (LIST (COPY-LIST '(0 0)) (COPY-LIST '(0 0)))) + (SETQ MS (CADR MC)) + (DOLIST (CONN (CADDR MC)) + (UNLESS FOUND + (SETQ DESCA (CAR CONN)) + (SETQ DESCB (CADR CONN)) + (SETQ PA (MENU-SET-ITEM-POSITION MS DESCA 'CENTER)) + (SETQ PB (MENU-SET-ITEM-POSITION MS DESCB 'CENTER)) + (WHEN (> (CAR PA) (CAR PB)) + (SETQ TMP DESCA) + (SETQ DESCA DESCB) + (SETQ DESCB TMP)) + (SETF (CAR LS) (MENU-SET-ITEM-POSITION MS DESCA 'RIGHT)) + (SETF (CADR LS) (MENU-SET-ITEM-POSITION MS DESCB 'LEFT)) + (WHEN (< (ABS (/ (- (* (- (CAADR LS) (CAAR LS)) + (- (CADR PT) (CADAR LS))) + (* (- (CADADR LS) (CADAR LS)) + (- (CAR PT) (CAAR LS)))) + (SQRT (+ (EXPT (- (CAADR LS) (CAAR LS)) 2) + (EXPT (- (CADADR LS) (CADAR LS)) 2))))) + 5) + (SETQ FOUND T) + (SETQ RES CONN)))) + RES)) +(SETF (GET 'MENU-CONNS-FIND-CONN 'GLARGUMENTS) + '((MC MENU-CONNS) (PT VECTOR))) +(SETF (GET 'MENU-CONNS-FIND-CONN 'GLFNRESULTTYPE) 'MENU-SET-CONN) + + +(DEFUN MENU-CONNS-FIND-ITEM (MC PT) (MENU-SET-FIND-ITEM (CADR MC) PT)) +(SETF (GET 'MENU-CONNS-FIND-ITEM 'GLARGUMENTS) + '((MC MENU-CONNS) (PT VECTOR))) +(SETF (GET 'MENU-CONNS-FIND-ITEM 'GLFNRESULTTYPE) 'MENU-SET-ITEM) + + +(DEFUN MENU-CONNS-DELETE-CONN (MC CONN) + (SETF (CADDR MC) (REMOVE CONN (CADDR MC)))) +(SETF (GET 'MENU-CONNS-DELETE-CONN 'GLARGUMENTS) + '((MC MENU-CONNS) (CONN MENU-SET-CONN))) +(SETF (GET 'MENU-CONNS-DELETE-CONN 'GLFNRESULTTYPE) + '(LISTOF MENU-SET-CONN)) + + +(DEFUN MENU-CONNS-DELETE-ITEM (MC MI) + (LET (MS) + (SETQ MS (CADR MC)) + (MENU-SET-DELETE-ITEM MS MI) + (DOLIST (CONN (CADDR MC)) + (IF (OR (EQ (CADAR CONN) (CAR MI)) (EQ (CADADR CONN) (CAR MI))) + (MENU-CONNS-DELETE-CONN MC CONN))))) + +(DEFUN MENU-CONNS-REMOVE-ITEMS (MC) + (MENU-SET-REMOVE-ITEMS (CADR MC)) + (SETF (CADDR MC) NIL)) +(SETF (GET 'MENU-CONNS-REMOVE-ITEMS 'GLARGUMENTS) '((MC MENU-CONNS))) +(SETF (GET 'MENU-CONNS-REMOVE-ITEMS 'GLFNRESULTTYPE) + '(LISTOF MENU-SET-CONN)) + + +(DEFUN MENU-CONNS-CONNECTED-PORTS (MC BOXNAME) + (LET (PORTS) + (DOLIST (CONN (CADDR MC)) + (IF (EQ BOXNAME (CADADR CONN)) (PUSHNEW (CAADR CONN) PORTS) + (IF (EQ BOXNAME (CADAR CONN)) (PUSHNEW (CAAR CONN) PORTS)))) + PORTS)) + +(DEFUN MENU-CONNS-FIND-CONNS (MC BOXNAME PORT) + (LET (RES) + (DOLIST (CONN (CADDR MC)) + (IF (AND (EQ BOXNAME (CADADR CONN)) (EQ PORT (CAADR CONN))) + (SETQ RES (NCONC RES (CONS (CAR CONN) NIL)))) + (IF (AND (EQ BOXNAME (CADAR CONN)) (EQ PORT (CAAR CONN))) + (SETQ RES (NCONC RES (CONS (CADR CONN) NIL))))) + RES)) +(SETF (GET 'MENU-CONNS-FIND-CONNS 'GLARGUMENTS) + '((MC MENU-CONNS) (BOXNAME SYMBOL) (PORT SYMBOL))) +(SETF (GET 'MENU-CONNS-FIND-CONNS 'GLFNRESULTTYPE) '(LISTOF MENU-PORT)) + + +(DEFUN COMPILE-MENU-SET () + (GLCOMPFILES *DIRECTORY* '("glisp/vector.lsp" "X/dwindow.lsp") + '("glisp/menu-set.lsp") "glisp/menu-settrans.lsp" + "glisp/menu-set-header.lsp") + (COMPILE-FILE "glisp/menu-settrans.lsp")) + +(DEFUN COMPILE-MENU-SETB () + (GLCOMPFILES *DIRECTORY* + '("glisp/vector.lsp" "X/dwindow.lsp" "X/dwnoopen.lsp") + '("glisp/menu-set.lsp") "glisp/menu-settrans.lsp" + "glisp/menu-set-header.lsp")) + +(DEFVAR *DRAW-WINDOW* NIL) + +(DEFVAR *DRAW-WINDOW-WIDTH* 600) + +(DEFVAR *DRAW-WINDOW-HEIGHT* 600) + +(DEFVAR *DRAW-LEAVE-WINDOW* NIL) + +(DEFVAR *DRAW-MENU-SET* NIL) + +(DEFVAR *DRAW-ZERO-VECTOR* '(0 0)) + +(DEFVAR *DRAW-LATEX-FACTOR* 1) + +(DEFVAR *DRAW-SNAP-FLAG* T) + +(DEFVAR *DRAW-OBJECTS* NIL) + +(DEFVAR *DRAW-LATEX-MODE* NIL) + +(DEFVAR *DRAW-WINDOW*) +(SETF (GET '*DRAW-WINDOW* 'GLISPGLOBALVAR) T) +(SETF (GET '*DRAW-WINDOW* 'GLISPGLOBALVARTYPE) 'WINDOW) + + +(DEFMACRO DRAW-DESCR (NAME) (LIST 'GET NAME ''DRAW-DESCR)) + +(SETF (GET 'DRAW-DESC 'GLSTRUCTURE) + '((LISTOBJECT (NAME SYMBOL) (OBJECTS (LISTOF DRAW-OBJECT)) + (OFFSET VECTOR) (SIZE VECTOR)) + PROP ((FNNAME DRAW-DESC-FNNAME) (REFPT DRAW-DESC-REFPT)) MSG + ((DRAW DRAW-DESC-DRAW) (SNAP DRAW-DESC-SNAP) + (FIND DRAW-DESC-FIND) (DELETE DRAW-DESC-DELETE)))) +(SETF (GET 'DRAW-OBJECT 'GLSTRUCTURE) + '((LISTOBJECT (OFFSET VECTOR) (SIZE VECTOR) (CONTENTS ANYTHING) + (LINEWIDTH INTEGER)) + DEFAULT ((LINEWIDTH 1)) PROP + ((REGION ((VIRTUAL REGION WITH START = OFFSET SIZE = SIZE))) + (VREGION ((VIRTUAL REGION WITH START = VSTART SIZE = VSIZE))) + (VSTART ((VIRTUAL VECTOR WITH X = + (MIN (X OFFSET) ((X OFFSET) + (X SIZE))) - 2 + Y = (MIN (Y OFFSET) ((Y OFFSET) + (Y SIZE))) + - 2))) + (VSIZE ((VIRTUAL VECTOR WITH X = (ABS (X SIZE)) + 4 Y = + (ABS (Y SIZE)) + 4)))) + MSG + ((ERASE DRAW-OBJECT-ERASE) (DRAW DRAW-OBJECT-DRAW) + (SNAP DRAW-OBJECT-SNAP) (SELECTEDP DRAW-OBJECT-SELECTEDP) + (MOVE DRAW-OBJECT-MOVE)))) +(SETF (GET 'DRAW-LINE 'GLSTRUCTURE) + '((LISTOBJECT (OFFSET VECTOR) (SIZE VECTOR) (CONTENTS ANYTHING) + (LINEWIDTH INTEGER)) + PROP + ((LINE ((VIRTUAL LINE-SEGMENT WITH P1 = OFFSET P2 = + (OFFSET + SIZE))))) + MSG + ((DRAW DRAW-LINE-DRAW) (SNAP DRAW-LINE-SNAP) + (SELECTEDP DRAW-LINE-SELECTEDP)) + SUPERS (DRAW-OBJECT))) +(SETF (GET 'DRAW-ARROW 'GLSTRUCTURE) + '((LISTOBJECT (OFFSET VECTOR) (SIZE VECTOR) (CONTENTS ANYTHING) + (LINEWIDTH INTEGER)) + PROP + ((LINE ((VIRTUAL LINE-SEGMENT WITH P1 = OFFSET P2 = + (OFFSET + SIZE))))) + MSG + ((DRAW DRAW-ARROW-DRAW) (SNAP DRAW-LINE-SNAP) + (SELECTEDP DRAW-LINE-SELECTEDP)) + SUPERS (DRAW-OBJECT))) +(SETF (GET 'DRAW-BOX 'GLSTRUCTURE) + '((LISTOBJECT (OFFSET VECTOR) (SIZE VECTOR) (CONTENTS ANYTHING) + (LINEWIDTH INTEGER)) + MSG + ((DRAW DRAW-BOX-DRAW) (SNAP DRAW-BOX-SNAP) + (SELECTEDP DRAW-BOX-SELECTEDP)) + SUPERS (DRAW-OBJECT))) +(SETF (GET 'DRAW-RCBOX 'GLSTRUCTURE) + '((LISTOBJECT (OFFSET VECTOR) (SIZE VECTOR) (CONTENTS ANYTHING) + (LINEWIDTH INTEGER)) + MSG + ((DRAW DRAW-RCBOX-DRAW) (SNAP DRAW-RCBOX-SNAP) + (SELECTEDP DRAW-RCBOX-SELECTEDP)) + SUPERS (DRAW-OBJECT))) +(SETF (GET 'DRAW-ERASE 'GLSTRUCTURE) + '((LISTOBJECT (OFFSET VECTOR) (SIZE VECTOR) (CONTENTS ANYTHING) + (LINEWIDTH INTEGER)) + MSG + ((DRAW DRAW-ERASE-DRAW) (SNAP DRAW-NO-SNAP) + (SELECTEDP DRAW-ERASE-SELECTEDP)) + SUPERS (DRAW-OBJECT))) +(SETF (GET 'DRAW-CIRCLE 'GLSTRUCTURE) + '((LISTOBJECT (OFFSET VECTOR) (SIZE VECTOR) (CONTENTS ANYTHING) + (LINEWIDTH INTEGER)) + PROP ((RADIUS ((X SIZE) / 2)) (CENTER (OFFSET + SIZE / 2))) MSG + ((DRAW DRAW-CIRCLE-DRAW) (SNAP DRAW-CIRCLE-SNAP) + (SELECTEDP DRAW-CIRCLE-SELECTEDP)) + SUPERS (DRAW-OBJECT))) +(SETF (GET 'DRAW-ELLIPSE 'GLSTRUCTURE) + '((LISTOBJECT (OFFSET VECTOR) (SIZE VECTOR) (CONTENTS ANYTHING) + (LINEWIDTH INTEGER)) + PROP + ((RADIUSX ((X SIZE) / 2)) (RADIUSY ((Y SIZE) / 2)) + (RADIUS ((MAX RADIUSX RADIUSY))) (CENTER (OFFSET + SIZE / 2)) + (DELTA ((SQRT (ABS (RADIUSX ^ 2 - RADIUSY ^ 2))))) + (P1 ((IF (RADIUSX > RADIUSY) + (A VECTOR X = (X CENTER) - DELTA Y = (Y CENTER)) + (A VECTOR X = (X CENTER) Y = (Y CENTER) - DELTA)))) + (P2 ((IF (RADIUSX > RADIUSY) + (A VECTOR X = (X CENTER) + DELTA Y = (Y CENTER)) + (A VECTOR X = (X CENTER) Y = (Y CENTER) + DELTA))))) + MSG + ((DRAW DRAW-ELLIPSE-DRAW) (SNAP DRAW-ELLIPSE-SNAP) + (SELECTEDP DRAW-ELLIPSE-SELECTEDP)) + SUPERS (DRAW-OBJECT))) +(SETF (GET 'DRAW-DOT 'GLSTRUCTURE) + '((LISTOBJECT (OFFSET VECTOR) (SIZE VECTOR) (CONTENTS ANYTHING) + (LINEWIDTH INTEGER)) + MSG + ((DRAW DRAW-DOT-DRAW) (SNAP DRAW-DOT-SNAP) + (SELECTEDP DRAW-BUTTON-SELECTEDP)) + SUPERS (DRAW-OBJECT))) +(SETF (GET 'DRAW-BUTTON 'GLSTRUCTURE) + '((LISTOBJECT (OFFSET VECTOR) (SIZE VECTOR) (CONTENTS ANYTHING) + (LINEWIDTH INTEGER)) + MSG + ((DRAW DRAW-BUTTON-DRAW) (SNAP DRAW-DOT-SNAP) + (SELECTEDP DRAW-BUTTON-SELECTEDP)) + SUPERS (DRAW-OBJECT))) +(SETF (GET 'DRAW-TEXT 'GLSTRUCTURE) + '((LISTOBJECT (OFFSET VECTOR) (SIZE VECTOR) (CONTENTS ANYTHING) + (LINEWIDTH INTEGER)) + MSG + ((DRAW DRAW-TEXT-DRAW) (SNAP DRAW-NO-SNAP) + (SELECTEDP DRAW-TEXT-SELECTEDP)) + SUPERS (DRAW-OBJECT))) +(SETF (GET 'DRAW-NULL 'GLSTRUCTURE) + '((LISTOBJECT (OFFSET VECTOR) (SIZE VECTOR) (CONTENTS ANYTHING) + (LINEWIDTH INTEGER)) + MSG + ((DRAW DRAW-NULL-DRAW) (SNAP DRAW-NO-SNAP) + (SELECTEDP DRAW-NULL-SELECTEDP)) + SUPERS (DRAW-OBJECT))) +(SETF (GET 'DRAW-REFPT 'GLSTRUCTURE) + '((LISTOBJECT (OFFSET VECTOR) (SIZE VECTOR) (CONTENTS ANYTHING) + (LINEWIDTH INTEGER)) + MSG + ((DRAW DRAW-REFPT-DRAW) (SNAP DRAW-REFPT-SNAP) + (SELECTEDP DRAW-REFPT-SELECTEDP)) + SUPERS (DRAW-OBJECT))) +(SETF (GET 'DRAW-MULTI 'GLSTRUCTURE) + '((LISTOBJECT (OFFSET VECTOR) (SIZE VECTOR) + (CONTENTS (LISTOF DRAW-OBJECT)) (LINEWIDTH INTEGER)) + MSG + ((DRAW DRAW-MULTI-DRAW) (SNAP DRAW-NO-SNAP) + (SELECTEDP DRAW-MULTI-SELECTEDP)) + SUPERS (DRAW-OBJECT))) + + +(DEFUN DRAW-DESC (NAME) + (LET (DD) + (SETQ DD (DRAW-DESCR NAME)) + (WHEN (NOT DD) + (SETQ DD + (LIST 'DRAW-DESC NAME NIL (COPY-LIST '(0 0)) + (COPY-LIST '(0 0)))) + (SETF (DRAW-DESCR NAME) DD)) + DD)) +(SETF (GET 'DRAW-DESC 'GLARGUMENTS) '((NAME SYMBOL))) +(SETF (GET 'DRAW-DESC 'GLFNRESULTTYPE) 'DRAW-DESC) + + +(SETF (GET 'DRAW-WINDOW 'GLFNRESULTTYPE) 'WINDOW) + +(DEFUN DRAW-WINDOW () + (OR *DRAW-WINDOW* + (SETQ *DRAW-WINDOW* + (WINDOW-CREATE *DRAW-WINDOW-WIDTH* *DRAW-WINDOW-HEIGHT* + "Draw window")))) + +(DEFUN DRAW (NAME) + (LET (W DD DONE SEL (REDRAW T) NEW) + (SETQ W (DRAW-WINDOW)) + (XMAPWINDOW *WINDOW-DISPLAY* (CADR W)) + (XFLUSH *WINDOW-DISPLAY*) + (WINDOW-WAIT-EXPOSURE W) + (OR *DRAW-MENU-SET* (DRAW-INIT-MENUS)) + (SETQ DD (DRAW-DESC NAME)) + (UNLESS (MEMBER NAME *DRAW-OBJECTS*) + (SETQ *DRAW-OBJECTS* (NCONC *DRAW-OBJECTS* (LIST NAME)))) + (DRAW-DESC-DRAW DD W) + (WHILE (NOT DONE) + (SETQ SEL (MENU-SET-SELECT *DRAW-MENU-SET* REDRAW)) + (SETQ REDRAW NIL) + (CASE (CADR SEL) + (COMMAND (CASE (CAR SEL) + (DONE (SETQ DONE T)) + (MOVE (DRAW-DESC-MOVE DD W)) + (DELETE (DRAW-DESC-DELETE DD W)) + (COPY (DRAW-DESC-COPY DD W)) + (REDRAW (XCLEARWINDOW *WINDOW-DISPLAY* + (CADR W)) + (XFLUSH *WINDOW-DISPLAY*) + (SETQ REDRAW T) (DRAW-DESC-DRAW DD W)) + (ORIGIN (DRAW-DESC-ORIGIN DD W) + (XCLEARWINDOW *WINDOW-DISPLAY* + (CADR W)) + (XFLUSH *WINDOW-DISPLAY*) + (SETQ REDRAW T) (DRAW-DESC-DRAW DD W)) + (PROGRAM (DRAW-DESC-PROGRAM DD)) + (LATEX (DRAW-DESC-LATEX DD)) + (LATEXMODE + (SETQ *DRAW-LATEX-MODE* + (NOT *DRAW-LATEX-MODE*)) + (FORMAT T "Latex Mode is now ~A~%" + *DRAW-LATEX-MODE*)))) + (DRAW (SETQ NEW NIL) + (CASE (CAR SEL) + (RECTANGLE (SETQ NEW (DRAW-BOX-GET DD W))) + (RCBOX (SETQ NEW (DRAW-RCBOX-GET DD W))) + (CIRCLE (SETQ NEW (DRAW-CIRCLE-GET DD W))) + (ELLIPSE (SETQ NEW (DRAW-ELLIPSE-GET DD W))) + (LINE (SETQ NEW (DRAW-LINE-GET DD W))) + (ARROW (SETQ NEW (DRAW-ARROW-GET DD W))) + (DOT (SETQ NEW (DRAW-DOT-GET DD W))) + (ERASE (SETQ NEW (DRAW-ERASE-GET DD W))) + (BUTTON (SETQ NEW (DRAW-BUTTON-GET DD W))) + (TEXT (SETQ NEW (DRAW-TEXT-GET DD W))) + (REFPT (SETQ NEW (DRAW-REFPT-GET DD W)))) + (WHEN NEW + (SETF (CADR NEW) + (LIST (- (CAADR NEW) (CAR (CADDDR DD))) + (- (CADADR NEW) (CADR (CADDDR DD))))) + (SETF (CADDR DD) + (NCONC (CADDR DD) (CONS NEW NIL))) + (DRAW-OBJECT-DRAW NEW W (CADDDR DD)))) + (BACKGROUND))) + (SETF (DRAW-DESCR NAME) DD) + (UNLESS *DRAW-LEAVE-WINDOW* + (PROGN + (XUNMAPWINDOW *WINDOW-DISPLAY* (CADR W)) + (XFLUSH *WINDOW-DISPLAY*) + (WINDOW-WAIT-UNMAP W))) + NAME)) +(SETF (GET 'DRAW 'GLARGUMENTS) '((NAME SYMBOL))) +(SETF (GET 'DRAW 'GLFNRESULTTYPE) 'SYMBOL) + + +(DEFUN COPY-DRAW-DESC (FROM TO) + (LET (OLD) + (SETQ OLD (COPY-TREE (GET FROM 'DRAW-DESCR))) + (SETF (GET TO 'DRAW-DESCR) (CONS (CAR OLD) (CONS TO (CDDR OLD)))))) + +(DEFUN DRAW-DESC-DRAW (DD W) + (LET ((OFF (CADDDR DD))) + (XCLEARWINDOW *WINDOW-DISPLAY* (CADR W)) + (XFLUSH *WINDOW-DISPLAY*) + (DOLIST (OBJ (CADDR DD)) (DRAW-OBJECT-DRAW OBJ W OFF)) + (XFLUSH *WINDOW-DISPLAY*))) + +(DEFUN DRAW-DESC-SELECTED (DD P) + (LET (OBJS OBJSB OBJ) + (SETQ OBJS + (MAPCAN #'(LAMBDA (OBJ) + (AND (DRAW-OBJECT-SELECTEDP OBJ P (CADDDR DD)) + (CONS OBJ NIL))) + (CADDR DD))) + (IF OBJS + (IF (NULL (REST OBJS)) (SETQ OBJ (FIRST OBJS)) + (PROGN + (SETQ OBJSB + (MAPCAN #'(LAMBDA (Z) + (AND (MEMBER (FIRST Z) + '(DRAW-BUTTON DRAW-DOT)) + (CONS Z NIL))) + OBJS)) + (IF (AND OBJSB (NULL (REST OBJSB))) + (SETQ OBJ (FIRST OBJSB)))))) + OBJ)) +(SETF (GET 'DRAW-DESC-SELECTED 'GLARGUMENTS) + '((DD DRAW-DESC) (P VECTOR))) +(SETF (GET 'DRAW-DESC-SELECTED 'GLFNRESULTTYPE) 'DRAW-OBJECT) + + +(DEFUN DRAW-DESC-FIND (DD W &OPTIONAL CROSSFLG) + (LET (P OBJ) + (WHILE (NOT OBJ) + (SETQ P + (IF CROSSFLG (DRAW-GET-CROSS DD W) + (DRAW-GET-CROSSHAIRS DD W))) + (SETQ OBJ (DRAW-DESC-SELECTED DD P))) + OBJ)) +(SETF (GET 'DRAW-DESC-FIND 'GLARGUMENTS) + '((DD DRAW-DESC) (W WINDOW) (&OPTIONAL BOOLEAN))) +(SETF (GET 'DRAW-DESC-FIND 'GLFNRESULTTYPE) 'DRAW-OBJECT) + + +(DEFUN DRAW-GET-CROSS (DD W) (DRAW-DESC-SNAP DD (WINDOW-GET-CROSS W))) +(SETF (GET 'DRAW-GET-CROSS 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW))) +(SETF (GET 'DRAW-GET-CROSS 'GLFNRESULTTYPE) 'VECTOR) + + +(DEFUN DRAW-GET-CROSSHAIRS (DD W) + (DRAW-DESC-SNAP DD (WINDOW-GET-CROSSHAIRS W))) +(SETF (GET 'DRAW-GET-CROSSHAIRS 'GLARGUMENTS) + '((DD DRAW-DESC) (W WINDOW))) +(SETF (GET 'DRAW-GET-CROSSHAIRS 'GLFNRESULTTYPE) 'VECTOR) + + +(DEFUN DRAW-DESC-DELETE (DD W) + (LET (OBJ) + (SETQ OBJ (DRAW-DESC-FIND DD W T)) + (DRAW-OBJECT-ERASE OBJ W (CADDDR DD)) + (SETF (CADDR DD) (REMOVE OBJ (CADDR DD))))) +(SETF (GET 'DRAW-DESC-DELETE 'GLARGUMENTS) + '((DD DRAW-DESC) (W WINDOW))) +(SETF (GET 'DRAW-DESC-DELETE 'GLFNRESULTTYPE) '(LISTOF DRAW-OBJECT)) + + +(DEFUN DRAW-DESC-COPY (DD W) + (LET (OBJ OBJB) + (SETQ OBJ (DRAW-DESC-FIND DD W)) + (SETQ OBJB (COPY-TREE OBJ)) + (DRAW-GET-OBJECT-POS OBJB W) + (SETF (CADR OBJB) + (LIST (- (CAADR OBJB) (CAR (CADDDR DD))) + (- (CADADR OBJB) (CADR (CADDDR DD))))) + (DRAW-OBJECT-DRAW OBJB W (CADDDR DD)) + (XFLUSH *WINDOW-DISPLAY*) + (SETF (CADDR DD) (NCONC (CADDR DD) (CONS OBJB NIL))))) +(SETF (GET 'DRAW-DESC-COPY 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW))) +(SETF (GET 'DRAW-DESC-COPY 'GLFNRESULTTYPE) '(LISTOF DRAW-OBJECT)) + + +(DEFUN DRAW-DESC-MOVE (DD W) + (LET (OBJ) + (IF (SETQ OBJ (DRAW-DESC-FIND DD W)) + (DRAW-OBJECT-MOVE OBJ W (CADDDR DD))))) + +(DEFUN DRAW-DESC-ORIGIN (DD W) + (LET (SEL) + (DRAW-DESC-BOUNDS DD) + (SETQ SEL (MENU '(("To zero" . TOZERO) ("Select" . SELECT)))) + (IF (EQ SEL 'SELECT) + (SETF (CADDDR DD) + (WINDOW-GET-BOX-POSITION W (CAR (FIFTH DD)) + (CADR (FIFTH DD)))) + (IF (EQ SEL 'TOZERO) (SETF (CADDDR DD) (COPY-LIST '(0 0))))))) +(SETF (GET 'DRAW-DESC-ORIGIN 'GLARGUMENTS) + '((DD DRAW-DESC) (W WINDOW))) +(SETF (GET 'DRAW-DESC-ORIGIN 'GLFNRESULTTYPE) 'VECTOR) + + +(DEFUN DRAW-DESC-BOUNDS (DD) + (LET ((XMIN 9999) (YMIN 9999) (XMAX 0) (YMAX 0) BASEV) + (DOLIST (OBJ (CADDR DD)) + (SETQ XMIN (MIN XMIN (CAADR OBJ) (+ (CAADR OBJ) (CAADDR OBJ)))) + (SETQ YMIN + (MIN YMIN (CADADR OBJ) (+ (CADADR OBJ) (CADR (CADDR OBJ))))) + (SETQ XMAX (MAX XMAX (CAADR OBJ) (+ (CAADR OBJ) (CAADDR OBJ)))) + (SETQ YMAX + (MAX YMAX (CADADR OBJ) (+ (CADADR OBJ) (CADR (CADDR OBJ)))))) + (SETF (CAR (FIFTH DD)) (- XMAX XMIN)) + (SETF (CADR (FIFTH DD)) (- YMAX YMIN)) + (SETQ BASEV (LIST XMIN YMIN)) + (SETF (CADDDR DD) BASEV) + (DOLIST (OBJ (CADDR DD)) + (SETF (CADR OBJ) + (LIST (- (CAADR OBJ) (CAR BASEV)) + (- (CADADR OBJ) (CADR BASEV))))))) + +(DEFUN DRAW-DESC-LATEX (DD) + (LET (BASE BX BY SX SY) + (FORMAT T " \\begin{picture}(~5,0F,~5,0F)(0,0)~%" + (* (CAR (FIFTH DD)) *DRAW-LATEX-FACTOR*) + (* (CADR (FIFTH DD)) *DRAW-LATEX-FACTOR*)) + (DOLIST (OBJ (CADDR DD)) + (SETQ BASE + (LIST (+ (CAR (CADDDR DD)) (CAADR OBJ)) + (+ (CADR (CADDDR DD)) (CADADR OBJ)))) + (SETQ BX (* (CAR BASE) *DRAW-LATEX-FACTOR*)) + (SETQ BY (* (CADR BASE) *DRAW-LATEX-FACTOR*)) + (SETQ SX (* (CAADDR OBJ) *DRAW-LATEX-FACTOR*)) + (SETQ SY (* (CADR (CADDR OBJ)) *DRAW-LATEX-FACTOR*)) + (CASE (FIRST OBJ) + (DRAW-LINE + (LATEX-LINE (CAR BASE) (CADR BASE) (+ (CAR BASE) SX) + (+ (CADR BASE) SY))) + (DRAW-ARROW + (LATEX-LINE (CAR BASE) (CADR BASE) (+ (CAR BASE) SX) + (+ (CADR BASE) SY) T)) + (DRAW-BOX + (FORMAT T + " \\put(~5,0F,~5,0F) {\\framebox(~5,0F,~5,0F)}~%" + BX BY SX SY)) + (DRAW-RCBOX + (FORMAT T " \\put(~5,0F,~5,0F) {\\oval(~5,0F,~5,0F)}~%" + (+ BX (* 1/2 SX)) (+ BY (* 1/2 SY)) SX SY)) + (DRAW-CIRCLE + (FORMAT T " \\put(~5,0F,~5,0F) {\\circle{~5,0F}}~%" + (+ BX (* 1/2 SX)) (+ BY (* 1/2 SY)) SX)) + (DRAW-ELLIPSE + (FORMAT T " \\put(~5,0F,~5,0F) {\\oval(~5,0F,~5,0F)}~%" + (+ BX (* 1/2 SX)) (+ BY (* 1/2 SY)) SX SY)) + (DRAW-BUTTON + (FORMAT T + " \\put(~5,0F,~5,0F) {\\framebox(~5,0F,~5,0F)}~%" + BX BY SX SY)) + (DRAW-ERASE) + (DRAW-DOT + (FORMAT T " \\put(~5,0F,~5,0F) {\\circle*{~5,0F}}~%" + (+ BX (* 1/2 SX)) (+ BY (* 1/2 SY)) SX)) + (DRAW-TEXT + (FORMAT T " \\put(~5,0F,~5,0F) {~A}~%" BX + (+ BY (* 4 *DRAW-LATEX-FACTOR*)) (CADDDR OBJ))))) + (FORMAT T " \\end{picture}~%"))) + +(DEFUN DRAW-DESC-PROGRAM (DD) + (LET (BASE BX BY SX SY TOX TOY R RX RY S CODE FNCODE FNNAME CD) + (SETQ CODE + (MAPCAN #'(LAMBDA (OBJ) + (AND (SETQ CD + (PROGN + (SETQ BASE + (LET + ((GLVAR133 + (LIST + (+ (CAR (CADDDR DD)) + (CAADR OBJ)) + (+ (CADR (CADDDR DD)) + (CADADR OBJ)))) + (GLVAR134 (DRAW-DESC-REFPT DD))) + (LIST + (- (CAR GLVAR133) + (CAR GLVAR134)) + (- (CADR GLVAR133) + (CADR GLVAR134))))) + (SETQ BX (CAR BASE)) + (SETQ BY (CADR BASE)) + (SETQ SX (CAADDR OBJ)) + (SETQ SY (CADR (CADDR OBJ))) + (SETQ TOX (+ BX SX)) + (SETQ TOY (+ BY SY)) + (IF (EQ (CAR OBJ) 'DRAW-CIRCLE) + (SETQ R (* 1/2 (CAADDR OBJ)))) + (WHEN (EQ (CAR OBJ) 'DRAW-ELLIPSE) + (SETQ RX (* 1/2 (CAADDR OBJ))) + (SETQ RY + (* 1/2 (CADR (CADDR OBJ))))) + (DRAW-OPTIMIZE + (CASE (FIRST OBJ) + (DRAW-LINE + (LIST 'WINDOW-DRAW-LINE-XY 'W + (LIST '+ 'X BX) (LIST '+ 'Y BY) + (LIST '+ 'X TOX) + (LIST '+ 'Y TOY))) + (DRAW-ARROW + (LIST 'WINDOW-DRAW-ARROW-XY 'W + (LIST '+ 'X BX) (LIST '+ 'Y BY) + (LIST '+ 'X TOX) + (LIST '+ 'Y TOY))) + (DRAW-BOX + (LIST 'WINDOW-DRAW-BOX-XY 'W + (LIST '+ 'X BX) (LIST '+ 'Y BY) + SX SY)) + (DRAW-RCBOX + (LIST 'WINDOW-DRAW-RCBOX-XY 'W + (LIST '+ 'X BX) (LIST '+ 'Y BY) + SX SY 8)) + (DRAW-CIRCLE + (LIST 'WINDOW-DRAW-CIRCLE-XY 'W + (LIST '+ 'X (+ R BX)) + (LIST '+ 'Y (+ R BY)) R)) + (DRAW-ELLIPSE + (LIST 'WINDOW-DRAW-ELLIPSE-XY 'W + (LIST '+ 'X (+ RX BX)) + (LIST '+ 'Y (+ RY BY)) RX RY)) + ((DRAW-BUTTON DRAW-REFPT) NIL) + (DRAW-ERASE + (LIST 'WINDOW-ERASE-AREA-XY 'W + (LIST '+ 'X BX) (LIST '+ 'Y BY) + SX SY)) + (DRAW-DOT + (LIST 'WINDOW-DRAW-DOT-XY 'W + (LIST '+ 'X (+ 2 BX)) + (LIST '+ 'Y (+ 2 BY)))) + (DRAW-TEXT + (SETQ S + (STRINGIFY (CADDDR OBJ))) + (LIST 'WINDOW-PRINTAT-XY 'W S + (LIST '+ 'X BX) + (LIST '+ 'Y BY))))))) + (CONS CD NIL))) + (CADDR DD))) + (SETQ FNCODE + (CONS 'LAMBDA + (CONS (LIST 'W 'X 'Y) + (NCONC CODE + (LIST (LIST 'WINDOW-FORCE-OUTPUT 'W)))))) + (SETQ FNNAME (DRAW-DESC-FNNAME DD)) + (SETF (SYMBOL-FUNCTION FNNAME) FNCODE) + (FORMAT T "Constructed program (~A w x y)~%" FNNAME) + (DRAW-DESC-PICMENU DD))) + +(DEFUN DRAW-OPTIMIZE (X) (IF (FBOUNDP 'GLUNWRAP) (GLUNWRAP X NIL) X)) + +(DEFUN DRAW-DESC-FNNAME (DD) + (INTERN (CONCATENATE 'STRING "DRAW-" (SYMBOL-NAME (CADR DD))))) +(SETF (GET 'DRAW-DESC-FNNAME 'GLARGUMENTS) '((DD DRAW-DESC))) +(SETF (GET 'DRAW-DESC-FNNAME 'GLFNRESULTTYPE) 'SYMBOL) + + +(DEFUN DRAW-DESC-PICMENU (DD) + (LET (BUTTONS) + (SETQ BUTTONS + (MAPCAN #'(LAMBDA (OBJ) + (AND (EQ (FIRST OBJ) 'DRAW-BUTTON) + (CONS (LIST (CADDDR OBJ) + (LET + ((GLVAR136 + (LET + ((GLVAR135 + (COPY-LIST '(2 2)))) + (LIST + (+ (CAR GLVAR135) + (CAADR OBJ)) + (+ (CADR GLVAR135) + (CADADR OBJ)))))) + (LIST + (+ (CAR GLVAR136) + (CAR (CADDDR DD))) + (+ (CADR GLVAR136) + (CADR (CADDDR DD)))))) + NIL))) + (CADDR DD))) + (IF BUTTONS + (SETF (GET (CADR DD) 'PICMENU-SPEC) + (LIST 'PICMENU-SPEC (CAR (FIFTH DD)) (CADR (FIFTH DD)) + BUTTONS T (DRAW-DESC-FNNAME DD) '9X15))))) +(SETF (GET 'DRAW-DESC-PICMENU 'GLARGUMENTS) '((DD DRAW-DESC))) +(SETF (GET 'DRAW-DESC-PICMENU 'GLFNRESULTTYPE) + '(LIST GLTYPE INTEGER INTEGER (LISTOF (LIST ANYTHING VECTOR)) + BOOLEAN SYMBOL SYMBOL)) + + +(DEFUN DRAW-DESC-SNAP (DD P) + (LET (PSNAP OBJ (OBJS (CADDR DD))) + (IF *DRAW-SNAP-FLAG* + (WHILE (AND OBJS (NOT PSNAP)) (SETQ OBJ (POP OBJS)) + (SETQ PSNAP (DRAW-OBJECT-SNAP OBJ P (CADDDR DD))))) + (OR PSNAP P))) +(SETF (GET 'DRAW-DESC-SNAP 'GLARGUMENTS) '((DD DRAW-DESC) (P VECTOR))) +(SETF (GET 'DRAW-DESC-SNAP 'GLFNRESULTTYPE) 'VECTOR) + + +(DEFUN DRAW-OBJECT-MOVE (D W OFF) + (DRAW-OBJECT-ERASE D W OFF) + (DRAW-GET-OBJECT-POS D W) + (SETF (CADR D) + (LIST (- (CAADR D) (CAR OFF)) (- (CADADR D) (CADR OFF)))) + (DRAW-OBJECT-DRAW D W OFF) + (XFLUSH *WINDOW-DISPLAY*)) + +(DEFUN DRAW-OBJECT-DRAW-AT (W X Y D) + (SETF (SECOND D) (LIST X Y)) + (DRAW-OBJECT-DRAW D W *DRAW-ZERO-VECTOR*)) + +(DEFUN DRAW-OBJECT-DRAW (D W OFF) + (FUNCALL (GLMETHOD (CAR D) 'DRAW) D W OFF)) + +(DEFUN DRAW-OBJECT-SNAP (D P OFF) + (FUNCALL (GLMETHOD (CAR D) 'SNAP) D P OFF)) + +(DEFUN DRAW-OBJECT-SELECTEDP (D W OFF) + (FUNCALL (GLMETHOD (CAR D) 'SELECTEDP) D W OFF)) + +(DEFUN DRAW-GET-OBJECT-POS (D W) + (WINDOW-GET-ICON-POSITION W + (IF (EQ (FIRST D) 'DRAW-TEXT) #'DRAW-TEXT-DRAW-OUTLINE + #'DRAW-OBJECT-DRAW-AT) + (LIST D))) +(SETF (GET 'DRAW-GET-OBJECT-POS 'GLARGUMENTS) + '((D DRAW-OBJECT) (W WINDOW))) +(SETF (GET 'DRAW-GET-OBJECT-POS 'GLFNRESULTTYPE) 'VECTOR) + + +(DEFUN DRAW-OBJECT-ERASE (D W OFF) + (WHEN (NOT (EQ (FIRST D) 'DRAW-ERASE)) + (LET ((GC (CADDR W))) + (SETQ *WINDOW-SAVE-FUNCTION* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 1 *GC-VALUES*) + (XGCVALUES-FUNCTION *GC-VALUES*))) + (XSETFUNCTION *WINDOW-DISPLAY* GC 6) + (SETQ *WINDOW-SAVE-FOREGROUND* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 4 *GC-VALUES*) + (XGCVALUES-FOREGROUND *GC-VALUES*))) + (XSETFOREGROUND *WINDOW-DISPLAY* GC + (LOGXOR *WINDOW-SAVE-FOREGROUND* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 8 + *GC-VALUES*) + (XGCVALUES-BACKGROUND *GC-VALUES*))))) + (DRAW-OBJECT-DRAW D W OFF) + (LET ((GC (CADDR W))) + (XSETFUNCTION *WINDOW-DISPLAY* GC *WINDOW-SAVE-FUNCTION*) + (XSETFOREGROUND *WINDOW-DISPLAY* GC *WINDOW-SAVE-FOREGROUND*)))) + +(DEFUN DRAW-LINE-DRAW (D W OFF) + (LET ((FROM (LIST (+ (CAR OFF) (CAADR D)) (+ (CADR OFF) (CADADR D)))) + (TO (LET ((GLVAR137 + (LIST (+ (CAR OFF) (CAADR D)) + (+ (CADR OFF) (CADADR D))))) + (LIST (+ (CAR GLVAR137) (CAADDR D)) + (+ (CADR GLVAR137) (CADR (CADDR D))))))) + (LET ((QQWHEIGHT (CADDDR W))) + (XDRAWLINE *WINDOW-DISPLAY* (CADR W) (CADDR W) (CAR FROM) + (- QQWHEIGHT (CADR FROM)) (CAR TO) (- QQWHEIGHT (CADR TO))) + NIL))) + +(DEFUN DRAW-ARROW-DRAW (D W OFF) + (LET ((FROM (LIST (+ (CAR OFF) (CAADR D)) (+ (CADR OFF) (CADADR D)))) + (TO (LET ((GLVAR138 + (LIST (+ (CAR OFF) (CAADR D)) + (+ (CADR OFF) (CADADR D))))) + (LIST (+ (CAR GLVAR138) (CAADDR D)) + (+ (CADR GLVAR138) (CADR (CADDR D))))))) + (WINDOW-DRAW-ARROW-XY W (CAR FROM) (CADR FROM) (CAR TO) (CADR TO)))) + +(DEFUN DRAW-LINE-SELECTEDP (D PT OFF) + (LET ((PTP (LIST (- (CAR PT) (CAR OFF)) (- (CADR PT) (CADR OFF))))) + (AND (BETWEEN (CAR PTP) (+ -2 (+ (CAADR D) (MIN 0 (CAADDR D)))) + (+ 2 + (+ (+ (CAADR D) (MIN 0 (CAADDR D))) + (ABS (CAADDR D))))) + (BETWEEN (CADR PTP) + (+ -2 (+ (CADADR D) (MIN 0 (CADR (CADDR D))))) + (+ 2 + (+ (+ (CADADR D) (MIN 0 (CADR (CADDR D)))) + (ABS (CADR (CADDR D)))))) + (< (ABS (/ (- (* (CAADDR D) (- (CADR PTP) (CADADR D))) + (* (CADR (CADDR D)) (- (CAR PTP) (CAADR D)))) + (SQRT (+ (EXPT (CAADDR D) 2) + (EXPT (CADR (CADDR D)) 2))))) + 5)))) +(SETF (GET 'DRAW-LINE-SELECTEDP 'GLARGUMENTS) + '((D DRAW-LINE) (PT VECTOR) (OFF VECTOR))) +(SETF (GET 'DRAW-LINE-SELECTEDP 'GLFNRESULTTYPE) 'BOOLEAN) + + +(DEFUN DRAW-LINE-GET (DD W) + (LET (FROM TO) + (SETQ FROM (DRAW-GET-CROSSHAIRS DD W)) + (SETQ TO + (IF *DRAW-LATEX-MODE* + (WINDOW-GET-LATEX-POSITION W (CAR FROM) (CADR FROM) NIL) + (DRAW-DESC-SNAP DD + (WINDOW-GET-LINE-POSITION W (CAR FROM) (CADR FROM))))) + (LIST 'DRAW-LINE FROM + (LIST (- (CAR TO) (CAR FROM)) (- (CADR TO) (CADR FROM))) NIL + 1))) +(SETF (GET 'DRAW-LINE-GET 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW))) +(SETF (GET 'DRAW-LINE-GET 'GLFNRESULTTYPE) 'DRAW-LINE) + + +(DEFUN DRAW-ARROW-GET (DD W) + (LET (FROM TO) + (SETQ FROM (DRAW-GET-CROSSHAIRS DD W)) + (SETQ TO + (IF *DRAW-LATEX-MODE* + (WINDOW-GET-LATEX-POSITION W (CAR FROM) (CADR FROM) NIL) + (DRAW-DESC-SNAP DD + (WINDOW-GET-LINE-POSITION W (CAR FROM) (CADR FROM))))) + (LIST 'DRAW-ARROW FROM + (LIST (- (CAR TO) (CAR FROM)) (- (CADR TO) (CADR FROM))) NIL + 1))) +(SETF (GET 'DRAW-ARROW-GET 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW))) +(SETF (GET 'DRAW-ARROW-GET 'GLFNRESULTTYPE) 'DRAW-ARROW) + + +(DEFUN DRAW-BOX-DRAW (D W OFF) + (LET ((GLVAR139 + (LIST (+ (CAR OFF) (CAADR D)) (+ (CADR OFF) (CADADR D))))) + (WINDOW-DRAW-BOX-XY W (CAR GLVAR139) (CADR GLVAR139) (CAADDR D) + (CADR (CADDR D)) NIL))) + +(DEFUN DRAW-BOX-SELECTEDP (D P OFF) + (LET ((PT (LIST (- (CAR P) (CAR OFF)) (- (CADR P) (CADR OFF))))) + (OR (AND (< (CADR PT) + (+ 7 + (+ (+ (CADADR D) (MIN 0 (CADR (CADDR D)))) + (ABS (CADR (CADDR D)))))) + (> (CADR PT) + (+ -7 (+ (CADADR D) (MIN 0 (CADR (CADDR D)))))) + (OR (< (ABS (+ 2 + (- (CAR PT) + (+ (CAADR D) (MIN 0 (CAADDR D)))))) + 5) + (< (ABS (+ -2 + (- (CAR PT) + (+ (+ (CAADR D) (MIN 0 (CAADDR D))) + (ABS (CAADDR D)))))) + 5))) + (AND (< (CAR PT) + (+ 7 + (+ (+ (CAADR D) (MIN 0 (CAADDR D))) + (ABS (CAADDR D))))) + (> (CAR PT) (+ -7 (+ (CAADR D) (MIN 0 (CAADDR D))))) + (OR (< (ABS (+ -2 + (- (CADR PT) + (+ (+ (CADADR D) + (MIN 0 (CADR (CADDR D)))) + (ABS (CADR (CADDR D))))))) + 5) + (< (ABS (+ 2 + (- (CADR PT) + (+ (CADADR D) (MIN 0 (CADR (CADDR D))))))) + 5)))))) +(SETF (GET 'DRAW-BOX-SELECTEDP 'GLARGUMENTS) + '((D DRAW-BOX) (P VECTOR) (OFF VECTOR))) +(SETF (GET 'DRAW-BOX-SELECTEDP 'GLFNRESULTTYPE) 'BOOLEAN) + + +(DEFUN DRAW-BOX-GET (DD W) + (LET (BOX) + (SETQ BOX (WINDOW-GET-REGION W)) + (LIST 'DRAW-BOX (CAR BOX) (CADR BOX) NIL 1))) +(SETF (GET 'DRAW-BOX-GET 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW))) +(SETF (GET 'DRAW-BOX-GET 'GLFNRESULTTYPE) 'DRAW-BOX) + + +(DEFUN DRAW-RCBOX-DRAW (D W OFF) + (WINDOW-DRAW-RCBOX-XY W (+ (CAR OFF) (CAADR D)) + (+ (CADR OFF) (CADADR D)) (CAADDR D) (CADR (CADDR D)) 8)) + +(DEFUN DRAW-RCBOX-SELECTEDP (D P OFF) + (LET ((PT (LIST (- (CAR P) (CAR OFF)) (- (CADR P) (CADR OFF))))) + (OR (AND (< (CADR PT) + (1- (+ (+ (CADADR D) (MIN 0 (CADR (CADDR D)))) + (ABS (CADR (CADDR D)))))) + (> (CADR PT) (1+ (+ (CADADR D) (MIN 0 (CADR (CADDR D)))))) + (OR (< (ABS (+ 2 + (- (CAR PT) + (+ (CAADR D) (MIN 0 (CAADDR D)))))) + 5) + (< (ABS (+ -2 + (- (CAR PT) + (+ (+ (CAADR D) (MIN 0 (CAADDR D))) + (ABS (CAADDR D)))))) + 5))) + (AND (< (CAR PT) + (1- (+ (+ (CAADR D) (MIN 0 (CAADDR D))) + (ABS (CAADDR D))))) + (> (CAR PT) (1+ (+ (CAADR D) (MIN 0 (CAADDR D))))) + (OR (< (ABS (+ -2 + (- (CADR PT) + (+ (+ (CADADR D) + (MIN 0 (CADR (CADDR D)))) + (ABS (CADR (CADDR D))))))) + 5) + (< (ABS (+ 2 + (- (CADR PT) + (+ (CADADR D) (MIN 0 (CADR (CADDR D))))))) + 5)))))) +(SETF (GET 'DRAW-RCBOX-SELECTEDP 'GLARGUMENTS) + '((D DRAW-BOX) (P VECTOR) (OFF VECTOR))) +(SETF (GET 'DRAW-RCBOX-SELECTEDP 'GLFNRESULTTYPE) 'BOOLEAN) + + +(DEFUN DRAW-RCBOX-GET (DD W) + (LET (BOX) + (SETQ BOX (WINDOW-GET-REGION W)) + (LIST 'DRAW-RCBOX (CAR BOX) (CADR BOX) NIL 1))) +(SETF (GET 'DRAW-RCBOX-GET 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW))) +(SETF (GET 'DRAW-RCBOX-GET 'GLFNRESULTTYPE) 'DRAW-RCBOX) + + +(DEFUN DRAW-CIRCLE-DRAW (D W OFF) + (LET ((GLVAR142 + (LET ((GLVAR141 + (LET ((GLVAR140 + (LIST (* 1/2 (CAADDR D)) + (* 1/2 (CADR (CADDR D)))))) + (LIST (+ (CAADR D) (CAR GLVAR140)) + (+ (CADADR D) (CADR GLVAR140)))))) + (LIST (+ (CAR OFF) (CAR GLVAR141)) + (+ (CADR OFF) (CADR GLVAR141)))))) + (WINDOW-DRAW-CIRCLE-XY W (CAR GLVAR142) (CADR GLVAR142) + (* 1/2 (CAADDR D)) NIL))) + +(DEFUN DRAW-CIRCLE-SELECTEDP (D P OFF) + (< (ABS (- (* 1/2 (CAADDR D)) + (LET ((SELF (LET ((GLVAR146 + (LET + ((GLVAR145 + (LET + ((GLVAR144 + (LIST (* 1/2 (CAADDR D)) + (* 1/2 (CADR (CADDR D)))))) + (LIST + (+ (CAADR D) (CAR GLVAR144)) + (+ (CADADR D) (CADR GLVAR144)))))) + (LIST (+ (CAR GLVAR145) (CAR OFF)) + (+ (CADR GLVAR145) (CADR OFF)))))) + (LIST (- (CAR GLVAR146) (CAR P)) + (- (CADR GLVAR146) (CADR P)))))) + (SQRT (+ (EXPT (CAR SELF) 2) (EXPT (CADR SELF) 2)))))) + 5)) +(SETF (GET 'DRAW-CIRCLE-SELECTEDP 'GLARGUMENTS) + '((D DRAW-CIRCLE) (P VECTOR) (OFF VECTOR))) +(SETF (GET 'DRAW-CIRCLE-SELECTEDP 'GLFNRESULTTYPE) 'BOOLEAN) + + +(DEFUN DRAW-CIRCLE-GET (DD W) + (LET (CIR CENT) + (SETQ CENT (DRAW-GET-CROSSHAIRS DD W)) + (SETQ CIR (WINDOW-GET-CIRCLE W CENT)) + (LIST 'DRAW-CIRCLE + (LIST (- (CAAR CIR) (CADR CIR)) (- (CADAR CIR) (CADR CIR))) + (LIST (* 2 (CADR CIR)) (* 2 (CADR CIR))) NIL 1))) +(SETF (GET 'DRAW-CIRCLE-GET 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW))) +(SETF (GET 'DRAW-CIRCLE-GET 'GLFNRESULTTYPE) 'DRAW-CIRCLE) + + +(DEFUN DRAW-ELLIPSE-DRAW (D W OFF) + (LET ((C (LET ((GLVAR148 + (LET ((GLVAR147 + (LIST (* 1/2 (CAADDR D)) + (* 1/2 (CADR (CADDR D)))))) + (LIST (+ (CAADR D) (CAR GLVAR147)) + (+ (CADADR D) (CADR GLVAR147)))))) + (LIST (+ (CAR OFF) (CAR GLVAR148)) + (+ (CADR OFF) (CADR GLVAR148)))))) + (LET ((GLVAR149 (* 1/2 (CAADDR D))) + (GLVAR150 (* 1/2 (CADR (CADDR D))))) + (XDRAWARC *WINDOW-DISPLAY* (CADR W) (CADDR W) + (- (CAR C) GLVAR149) (- (CADDDR W) (+ (CADR C) GLVAR150)) + (* 2 GLVAR149) (* 2 GLVAR150) 0 23040) + NIL))) + +(DEFUN DRAW-ELLIPSE-SELECTEDP (D P OFF) + (LET ((PT (LIST (- (CAR P) (CAR OFF)) (- (CADR P) (CADR OFF))))) + (< (ABS (- (+ (LET ((SELF (LET ((GLVAR156 + (IF + (> (CAADDR D) (CADR (CADDR D))) + (LIST + (ROUND + (- + (+ (CAADR D) + (* 1/2 (CAADDR D))) + (SQRT + (ABS + (* 1/4 + (- (EXPT (CAADDR D) 2) + (EXPT (CADR (CADDR D)) 2))))))) + (+ (CADADR D) + (* 1/2 (CADR (CADDR D))))) + (LIST + (+ (CAADR D) (* 1/2 (CAADDR D))) + (ROUND + (- + (+ (CADADR D) + (* 1/2 (CADR (CADDR D)))) + (SQRT + (ABS + (* 1/4 + (- (EXPT (CAADDR D) 2) + (EXPT (CADR (CADDR D)) 2))))))))))) + (LIST (- (CAR GLVAR156) (CAR PT)) + (- (CADR GLVAR156) (CADR PT)))))) + (SQRT (+ (EXPT (CAR SELF) 2) (EXPT (CADR SELF) 2)))) + (LET ((SELF (LET ((GLVAR161 + (IF + (> (CAADDR D) (CADR (CADDR D))) + (LIST + (ROUND + (+ + (+ (CAADR D) + (* 1/2 (CAADDR D))) + (SQRT + (ABS + (* 1/4 + (- (EXPT (CAADDR D) 2) + (EXPT (CADR (CADDR D)) 2))))))) + (+ (CADADR D) + (* 1/2 (CADR (CADDR D))))) + (LIST + (+ (CAADR D) (* 1/2 (CAADDR D))) + (ROUND + (+ + (+ (CADADR D) + (* 1/2 (CADR (CADDR D)))) + (SQRT + (ABS + (* 1/4 + (- (EXPT (CAADDR D) 2) + (EXPT (CADR (CADDR D)) 2))))))))))) + (LIST (- (CAR GLVAR161) (CAR PT)) + (- (CADR GLVAR161) (CADR PT)))))) + (SQRT (+ (EXPT (CAR SELF) 2) (EXPT (CADR SELF) 2))))) + (* 2 (MAX (* 1/2 (CAADDR D)) (* 1/2 (CADR (CADDR D))))))) + 2))) +(SETF (GET 'DRAW-ELLIPSE-SELECTEDP 'GLARGUMENTS) + '((D DRAW-ELLIPSE) (P VECTOR) (OFF VECTOR))) +(SETF (GET 'DRAW-ELLIPSE-SELECTEDP 'GLFNRESULTTYPE) 'BOOLEAN) + + +(DEFUN DRAW-TEST-ELLIPSE-SELECTEDP (E) + (LET ((SIZE (THIRD E)) (OFFSET (SECOND E))) + (DOTIMES (Y (+ (CADR SIZE) 10)) + (DOTIMES (X (+ (CAR SIZE) 10)) + (PRINC (IF (DRAW-ELLIPSE-SELECTEDP E + (LIST (+ X (CAR OFFSET) -5) + (+ Y (CADR OFFSET) -5)) + (LIST 0 0)) + "T" " "))) + (TERPRI)))) + +(DEFUN DRAW-ELLIPSE-GET (DD W) + (LET (ELL CENT) + (SETQ CENT (DRAW-GET-CROSSHAIRS DD W)) + (SETQ ELL (WINDOW-GET-ELLIPSE W CENT)) + (LIST 'DRAW-ELLIPSE + (LIST (- (CAAR ELL) (CAADR ELL)) + (- (CADAR ELL) (CADADR ELL))) + (LIST (* 2 (CAADR ELL)) (* 2 (CADADR ELL))) NIL 1))) +(SETF (GET 'DRAW-ELLIPSE-GET 'GLARGUMENTS) + '((DD DRAW-DESC) (W WINDOW))) +(SETF (GET 'DRAW-ELLIPSE-GET 'GLFNRESULTTYPE) 'DRAW-ELLIPSE) + + +(DEFUN DRAW-NULL-DRAW (D W OFF) NIL) + +(DEFUN DRAW-NULL-SELECTEDP (D PT OFF) NIL) + +(DEFUN DRAW-BUTTON-DRAW (D W OFF) + (LET ((GLVAR162 + (LIST (+ (CAR OFF) (CAADR D)) (+ (CADR OFF) (CADADR D)))) + (GLVAR163 (COPY-LIST '(4 4)))) + (WINDOW-DRAW-BOX-XY W (CAR GLVAR162) (CADR GLVAR162) (CAR GLVAR163) + (CADR GLVAR163) NIL))) + +(DEFUN DRAW-BUTTON-SELECTEDP (D P OFF) + (LET ((PTX (- (- (CAR P) (CAR OFF)) (CAADR D))) + (PTY (- (- (CADR P) (CADR OFF)) (CADADR D)))) + (AND (> PTX -2) (< PTX 6) (> PTY -2) (< PTY 6)))) +(SETF (GET 'DRAW-BUTTON-SELECTEDP 'GLARGUMENTS) + '((D DRAW-BUTTON) (P VECTOR) (OFF VECTOR))) +(SETF (GET 'DRAW-BUTTON-SELECTEDP 'GLFNRESULTTYPE) 'BOOLEAN) + + +(DEFUN DRAW-BUTTON-GET (DD W) + (LET (CENT VAR) + (PRINC "Enter button name: ") + (SETQ VAR (READ)) + (SETQ CENT (DRAW-GET-CROSSHAIRS DD W)) + (LIST 'DRAW-BUTTON (LIST (+ -2 (CAR CENT)) (+ -2 (CADR CENT))) + (COPY-LIST '(4 4)) VAR 1))) +(SETF (GET 'DRAW-BUTTON-GET 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW))) +(SETF (GET 'DRAW-BUTTON-GET 'GLFNRESULTTYPE) 'DRAW-BUTTON) + + +(DEFUN DRAW-ERASE-DRAW (D W OFF) + (LET ((GLVAR164 + (LIST (+ (CAR OFF) (CAADR D)) (+ (CADR OFF) (CADADR D))))) + (WINDOW-ERASE-AREA-XY W (CAR GLVAR164) (CADR GLVAR164) (CAADDR D) + (CADR (CADDR D))))) + +(DEFUN DRAW-ERASE-SELECTEDP (D P OFF) + (LET ((PT (LIST (- (CAR P) (CAR OFF)) (- (CADR P) (CADR OFF))))) + (AND (BETWEEN (CAR PT) (CAADR D) (+ (CAADR D) (CAADDR D))) + (BETWEEN (CADR PT) (CADADR D) (+ (CADADR D) (CADR (CADDR D))))))) +(SETF (GET 'DRAW-ERASE-SELECTEDP 'GLARGUMENTS) + '((D DRAW-BOX) (P VECTOR) (OFF VECTOR))) +(SETF (GET 'DRAW-ERASE-SELECTEDP 'GLFNRESULTTYPE) 'BOOLEAN) + + +(DEFUN DRAW-ERASE-GET (DD W) + (LET (BOX) + (SETQ BOX (WINDOW-GET-REGION W)) + (LIST 'DRAW-ERASE (CAR BOX) (CADR BOX) NIL 1))) +(SETF (GET 'DRAW-ERASE-GET 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW))) +(SETF (GET 'DRAW-ERASE-GET 'GLFNRESULTTYPE) 'DRAW-ERASE) + + +(DEFUN DRAW-DOT-DRAW (D W OFF) + (WINDOW-DRAW-DOT-XY W (+ 2 (+ (CAR OFF) (CAADR D))) + (+ 2 (+ (CADR OFF) (CADADR D))))) + +(DEFUN DRAW-DOT-GET (DD W) + (LET (CENT) + (SETQ CENT (DRAW-GET-CROSSHAIRS DD W)) + (LIST 'DRAW-DOT (LIST (+ -2 (CAR CENT)) (+ -2 (CADR CENT))) + (COPY-LIST '(4 4)) NIL 1))) +(SETF (GET 'DRAW-DOT-GET 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW))) +(SETF (GET 'DRAW-DOT-GET 'GLFNRESULTTYPE) 'DRAW-DOT) + + +(DEFUN DRAW-REFPT-DRAW (D W OFF) + (WINDOW-DRAW-CROSSHAIRS-XY W (+ (CAR OFF) (CAADR D)) + (+ (CADR OFF) (CADADR D)))) + +(DEFUN DRAW-REFPT-SELECTEDP (D P OFF) + (LET ((PTX (- (- (CAR P) (CAR OFF)) (CAADR D))) + (PTY (- (- (CADR P) (CADR OFF)) (CADADR D)))) + (AND (> PTX -3) (< PTX 3) (> PTY -3) (< PTY 3)))) +(SETF (GET 'DRAW-REFPT-SELECTEDP 'GLARGUMENTS) + '((D DRAW-BUTTON) (P VECTOR) (OFF VECTOR))) +(SETF (GET 'DRAW-REFPT-SELECTEDP 'GLFNRESULTTYPE) 'BOOLEAN) + + +(DEFUN DRAW-REFPT-GET (DD W) + (LET (CENT REFPT) + (WHEN (SETQ REFPT (ASSOC 'DRAW-REFPT (CADDR DD))) + (LET ((GC (CADDR *DRAW-WINDOW*))) + (SETQ *WINDOW-SAVE-FUNCTION* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR *DRAW-WINDOW*) 1 + *GC-VALUES*) + (XGCVALUES-FUNCTION *GC-VALUES*))) + (XSETFUNCTION *WINDOW-DISPLAY* GC 3) + (SETQ *WINDOW-SAVE-FOREGROUND* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR *DRAW-WINDOW*) 4 + *GC-VALUES*) + (XGCVALUES-FOREGROUND *GC-VALUES*))) + (XSETFOREGROUND *WINDOW-DISPLAY* GC + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR *DRAW-WINDOW*) 8 + *GC-VALUES*) + (XGCVALUES-BACKGROUND *GC-VALUES*)))) + (DRAW-OBJECT-DRAW REFPT *DRAW-WINDOW* (COPY-LIST '(0 0))) + (LET ((GC (CADDR *DRAW-WINDOW*))) + (XSETFUNCTION *WINDOW-DISPLAY* GC *WINDOW-SAVE-FUNCTION*) + (XSETFOREGROUND *WINDOW-DISPLAY* GC *WINDOW-SAVE-FOREGROUND*)) + (SETF (CADDR DD) (REMOVE REFPT (CADDR DD)))) + (SETQ CENT (DRAW-GET-CROSSHAIRS DD W)) + (LIST 'DRAW-REFPT CENT (COPY-LIST '(0 0)) NIL 1))) +(SETF (GET 'DRAW-REFPT-GET 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW))) +(SETF (GET 'DRAW-REFPT-GET 'GLFNRESULTTYPE) 'DRAW-REFPT) + + +(DEFUN DRAW-DESC-REFPT (DD) + (LET (REFPT) + (SETQ REFPT (ASSOC 'DRAW-REFPT (CADDR DD))) + (IF REFPT (CADR REFPT) (COPY-LIST '(0 0))))) +(SETF (GET 'DRAW-DESC-REFPT 'GLARGUMENTS) '((DD DRAW-DESC))) +(SETF (GET 'DRAW-DESC-REFPT 'GLFNRESULTTYPE) 'VECTOR) + + +(DEFUN DRAW-TEXT-DRAW (D W OFF) + (LET ((SSTR (STRINGIFY (CADDDR D)))) + (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) + (+ (CAR OFF) (CAADR D)) + (- (CADDDR W) (+ (CADR OFF) (CADADR D))) (GET-C-STRING SSTR) + (LENGTH SSTR)))) + +(DEFUN DRAW-TEXT-DRAW-OUTLINE (W X Y D) + (SETF (SECOND D) (LIST X Y)) + (WINDOW-DRAW-BOX-XY W X (+ 2 Y) (CAADDR D) (CADR (CADDR D)))) + +(DEFUN DRAW-TEXT-DRAW-OUTLINE (W X Y D) + (SETF (SECOND D) (LIST X Y)) + (WINDOW-DRAW-BOX-XY W X (+ 2 Y) (CAADDR D) (CADR (CADDR D)))) + +(DEFUN DRAW-TEXT-SELECTEDP (D PT OFF) + (LET ((PTP (LIST (- (CAR PT) (CAR OFF)) (- (CADR PT) (CADR OFF))))) + (AND (BETWEEN (CAR PTP) (+ -2 (+ (CAADR D) (MIN 0 (CAADDR D)))) + (+ 2 + (+ (+ (CAADR D) (MIN 0 (CAADDR D))) + (ABS (CAADDR D))))) + (BETWEEN (CADR PTP) + (+ -2 (+ (CADADR D) (MIN 0 (CADR (CADDR D))))) + (+ 2 + (+ (+ (CADADR D) (MIN 0 (CADR (CADDR D)))) + (ABS (CADR (CADDR D))))))))) +(SETF (GET 'DRAW-TEXT-SELECTEDP 'GLARGUMENTS) + '((D DRAW-TEXT) (PT VECTOR) (OFF VECTOR))) +(SETF (GET 'DRAW-TEXT-SELECTEDP 'GLFNRESULTTYPE) 'BOOLEAN) + + +(DEFUN DRAW-TEXT-GET (DD W) + (LET (TXT LNG OFF) + (PRINC "Enter text string: ") + (SETQ TXT (STRINGIFY (READ))) + (SETQ LNG + (LET ((SSTR (STRINGIFY TXT))) + (XTEXTWIDTH (SEVENTH W) (GET-C-STRING SSTR) (LENGTH SSTR)))) + (SETQ OFF (WINDOW-GET-BOX-POSITION W LNG 14)) + (LIST 'DRAW-TEXT + (LET ((GLVAR167 (COPY-LIST '(0 4)))) + (LIST (+ (CAR OFF) (CAR GLVAR167)) + (+ (CADR OFF) (CADR GLVAR167)))) + (LIST LNG 14) TXT 1))) +(SETF (GET 'DRAW-TEXT-GET 'GLARGUMENTS) '((DD DRAW-DESC) (W WINDOW))) +(SETF (GET 'DRAW-TEXT-GET 'GLFNRESULTTYPE) 'DRAW-TEXT) + + +(DEFUN DRAW-SNAPP (P1 OFF P2X P2Y) + (IF (AND (< (ABS (- (- (CAR P1) (CAR OFF)) P2X)) 4) + (< (ABS (- (- (CADR P1) (CADR OFF)) P2Y)) 4)) + (LIST (+ (CAR OFF) P2X) (+ (CADR OFF) P2Y)))) +(SETF (GET 'DRAW-SNAPP 'GLARGUMENTS) + '((P1 VECTOR) (OFF VECTOR) (P2X INTEGER) (P2Y INTEGER))) +(SETF (GET 'DRAW-SNAPP 'GLFNRESULTTYPE) 'VECTOR) + + +(DEFUN DRAW-DOT-SNAP (D P OFF) + (DRAW-SNAPP P OFF (+ 2 (CAADR D)) (+ 2 (CADADR D)))) +(SETF (GET 'DRAW-DOT-SNAP 'GLARGUMENTS) + '((D DRAW-DOT) (P VECTOR) (OFF VECTOR))) +(SETF (GET 'DRAW-DOT-SNAP 'GLFNRESULTTYPE) 'VECTOR) + + +(DEFUN DRAW-REFPT-SNAP (D P OFF) + (DRAW-SNAPP P OFF (CAADR D) (CADADR D))) +(SETF (GET 'DRAW-REFPT-SNAP 'GLARGUMENTS) + '((D DRAW-REFPT) (P VECTOR) (OFF VECTOR))) +(SETF (GET 'DRAW-REFPT-SNAP 'GLFNRESULTTYPE) 'VECTOR) + + +(DEFUN DRAW-LINE-SNAP (D P OFF) + (OR (DRAW-SNAPP P OFF (CAADR D) (CADADR D)) + (DRAW-SNAPP P OFF (+ (CAADR D) (CAADDR D)) + (+ (CADADR D) (CADR (CADDR D)))))) +(SETF (GET 'DRAW-LINE-SNAP 'GLARGUMENTS) + '((D DRAW-LINE) (P VECTOR) (OFF VECTOR))) +(SETF (GET 'DRAW-LINE-SNAP 'GLFNRESULTTYPE) 'VECTOR) + + +(DEFUN DRAW-BOX-SNAP (D P OFF) + (LET ((XOFF (CAADR D)) (YOFF (CADADR D)) (XSIZE (CAADDR D)) + (YSIZE (CADR (CADDR D)))) + (OR (DRAW-SNAPP P OFF XOFF YOFF) + (DRAW-SNAPP P OFF (+ XOFF XSIZE) (+ YOFF YSIZE)) + (DRAW-SNAPP P OFF (+ XOFF XSIZE) YOFF) + (DRAW-SNAPP P OFF XOFF (+ YOFF YSIZE)) + (DRAW-SNAPP P OFF (+ XOFF (* 1/2 XSIZE)) YOFF) + (DRAW-SNAPP P OFF XOFF (+ YOFF (* 1/2 YSIZE))) + (DRAW-SNAPP P OFF (+ XOFF (* 1/2 XSIZE)) (+ YOFF YSIZE)) + (DRAW-SNAPP P OFF (+ XOFF XSIZE) (+ YOFF (* 1/2 YSIZE)))))) +(SETF (GET 'DRAW-BOX-SNAP 'GLARGUMENTS) + '((D DRAW-BOX) (P VECTOR) (OFF VECTOR))) +(SETF (GET 'DRAW-BOX-SNAP 'GLFNRESULTTYPE) 'VECTOR) + + +(DEFUN DRAW-CIRCLE-SNAP (D P OFF) + (OR (DRAW-SNAPP P OFF (+ (CAADR D) (* 1/2 (CAADDR D))) + (+ (CADADR D) (* 1/2 (CAADDR D)))) + (DRAW-SNAPP P OFF (+ (CAADR D) (* 1/2 (CAADDR D))) (CADADR D)) + (DRAW-SNAPP P OFF (CAADR D) (+ (CADADR D) (* 1/2 (CAADDR D)))) + (DRAW-SNAPP P OFF (+ (CAADR D) (* 1/2 (CAADDR D))) + (+ (CADADR D) (CADR (CADDR D)))) + (DRAW-SNAPP P OFF (+ (CAADR D) (CAADDR D)) + (+ (CADADR D) (* 1/2 (CAADDR D)))))) +(SETF (GET 'DRAW-CIRCLE-SNAP 'GLARGUMENTS) + '((D DRAW-CIRCLE) (P VECTOR) (OFF VECTOR))) +(SETF (GET 'DRAW-CIRCLE-SNAP 'GLFNRESULTTYPE) 'VECTOR) + + +(DEFUN DRAW-ELLIPSE-SNAP (D P OFF) + (OR (DRAW-SNAPP P OFF (+ (CAADR D) (* 1/2 (CAADDR D))) + (+ (CADADR D) (* 1/2 (CADR (CADDR D))))) + (DRAW-SNAPP P OFF (+ (CAADR D) (* 1/2 (CAADDR D))) (CADADR D)) + (DRAW-SNAPP P OFF (CAADR D) + (+ (CADADR D) (* 1/2 (CADR (CADDR D))))) + (DRAW-SNAPP P OFF (+ (CAADR D) (* 1/2 (CAADDR D))) + (+ (CADADR D) (CADR (CADDR D)))) + (DRAW-SNAPP P OFF (+ (CAADR D) (CAADDR D)) + (+ (CADADR D) (* 1/2 (CADR (CADDR D))))))) +(SETF (GET 'DRAW-ELLIPSE-SNAP 'GLARGUMENTS) + '((D DRAW-ELLIPSE) (P VECTOR) (OFF VECTOR))) +(SETF (GET 'DRAW-ELLIPSE-SNAP 'GLFNRESULTTYPE) 'VECTOR) + + +(DEFUN DRAW-RCBOX-SNAP (D P OFF) + (LET ((RX (* 1/2 (CAADDR D))) (RY (* 1/2 (CADR (CADDR D))))) + (OR (DRAW-SNAPP P OFF (+ (CAADR D) RX) (CADADR D)) + (DRAW-SNAPP P OFF (CAADR D) (+ (CADADR D) RY)) + (DRAW-SNAPP P OFF (+ (CAADR D) RX) + (+ (CADADR D) (CADR (CADDR D)))) + (DRAW-SNAPP P OFF (+ (CAADR D) (CAADDR D)) (+ (CADADR D) RY))))) +(SETF (GET 'DRAW-RCBOX-SNAP 'GLARGUMENTS) + '((D DRAW-RCBOX) (P VECTOR) (OFF VECTOR))) +(SETF (GET 'DRAW-RCBOX-SNAP 'GLFNRESULTTYPE) 'VECTOR) + + +(DEFUN DRAW-NO-SNAP (D P OFF) NIL) + +(DEFUN DRAW-MULTI-DRAW (D W OFF) + (LET ((TOTALOFF + (LIST (+ (CAADR D) (CAR OFF)) (+ (CADADR D) (CADR OFF))))) + (DOLIST (SUBD (CADDDR D)) (DRAW-OBJECT-DRAW SUBD W TOTALOFF)))) + +(DEFUN DRAW-INIT-MENUS () + (LET ((W (DRAW-WINDOW))) + (WINDOW-CLEAR W) + (DOLIST (FN '(DRAW-MENU-RECTANGLE DRAW-MENU-CIRCLE + DRAW-MENU-ELLIPSE DRAW-MENU-LINE DRAW-MENU-ARROW + DRAW-MENU-DOT DRAW-MENU-BUTTON DRAW-MENU-TEXT)) + (SETF (GET FN 'DISPLAY-SIZE) '(30 20))) + (SETQ *DRAW-MENU-SET* (MENU-SET-CREATE W NIL)) + (MENU-SET-ADD-MENU *DRAW-MENU-SET* 'DRAW NIL "Draw" + '((DRAW-MENU-RECTANGLE . RECTANGLE) (DRAW-MENU-RCBOX . RCBOX) + (DRAW-MENU-CIRCLE . CIRCLE) (DRAW-MENU-ELLIPSE . ELLIPSE) + (DRAW-MENU-LINE . LINE) (DRAW-MENU-ARROW . ARROW) + (DRAW-MENU-DOT . DOT) (" " . ERASE) + (DRAW-MENU-BUTTON . BUTTON) (DRAW-MENU-TEXT . TEXT) + (DRAW-MENU-REFPT . REFPT)) + (LIST 0 0)) + (MENU-SET-ADJUST *DRAW-MENU-SET* 'DRAW 'TOP NIL 1) + (MENU-SET-ADJUST *DRAW-MENU-SET* 'DRAW 'RIGHT NIL 2) + (MENU-SET-ADD-MENU *DRAW-MENU-SET* 'COMMAND NIL "Commands" + '(("Done" . DONE) ("Move" . MOVE) ("Delete" . DELETE) + ("Copy" . COPY) ("Redraw" . REDRAW) ("Origin" . ORIGIN) + ("LaTex Mode" . LATEXMODE) ("Make Program" . PROGRAM) + ("Make LaTex" . LATEX)) + (LIST 0 0)) + (MENU-SET-ADJUST *DRAW-MENU-SET* 'COMMAND 'TOP 'DRAW 5) + (MENU-SET-ADJUST *DRAW-MENU-SET* 'COMMAND 'RIGHT NIL 2))) + +(DEFUN DRAW-MENU-RECTANGLE (W X Y) + (WINDOW-DRAW-BOX-XY W (+ X 3) (+ Y 3) 24 14 1)) + +(DEFUN DRAW-MENU-RCBOX (W X Y) + (WINDOW-DRAW-RCBOX-XY W (+ X 3) (+ Y 3) 24 14 3 1)) + +(DEFUN DRAW-MENU-CIRCLE (W X Y) + (WINDOW-DRAW-CIRCLE-XY W (+ X 15) (+ Y 10) 8 1)) + +(DEFUN DRAW-MENU-ELLIPSE (W X Y) + (WINDOW-DRAW-ELLIPSE-XY W (+ X 15) (+ Y 10) 12 8 1)) + +(DEFUN DRAW-MENU-LINE (W X Y) + (WINDOW-DRAW-LINE-XY W (+ X 4) (+ Y 4) (+ X 26) (+ Y 16) 1)) + +(DEFUN DRAW-MENU-ARROW (W X Y) + (WINDOW-DRAW-ARROW-XY W (+ X 4) (+ Y 4) (+ X 26) (+ Y 16) 1)) + +(DEFUN DRAW-MENU-DOT (W X Y) (WINDOW-DRAW-DOT-XY W (+ X 15) (+ Y 10))) + +(DEFUN DRAW-MENU-BUTTON (W X Y) + (WINDOW-DRAW-BOX-XY W (+ X 14) (+ Y 5) 4 4 1)) + +(DEFUN DRAW-MENU-TEXT (W X Y) + (WINDOW-PRINTAT-XY W "A" (+ X 12) (+ Y 5))) + +(DEFUN DRAW-MENU-REFPT (W X Y) + (WINDOW-DRAW-CROSSHAIRS-XY W (+ X 15) (+ Y 9)) + (WINDOW-DRAW-CIRCLE-XY W (+ X 15) (+ Y 9) 2)) + +(DEFUN LATEX-LINE (FROMX FROMY X Y &OPTIONAL ARROWFLG) + (LET (DX DY SX SY SIZ ERR ERRB) + (SETQ DX (- X FROMX)) + (SETQ DY (- Y FROMY)) + (IF (= DX 0) + (PROGN + (SETQ SX 0) + (SETQ SY (IF (>= DY 0) 1 -1)) + (SETQ SIZ (* (ABS DY) *DRAW-LATEX-FACTOR*))) + (IF (= DY 0) + (PROGN + (SETQ SX (IF (>= DX 0) 1 -1)) + (SETQ SY 0) + (SETQ SIZ (* (ABS DX) *DRAW-LATEX-FACTOR*))) + (PROGN + (SETQ ERR 9999) + (SETQ SIZ (* (ABS DX) *DRAW-LATEX-FACTOR*)) + (DOTIMES (I (IF ARROWFLG 4 6)) + (DOTIMES (J (IF ARROWFLG 4 6)) + (SETQ ERRB + (ABS (- (/ (FLOAT (1+ I)) (FLOAT (1+ J))) + (ABS (/ (FLOAT DX) (FLOAT DY)))))) + (IF (AND (= (GCD (1+ I) (1+ J)) 1) (< ERRB ERR)) + (PROGN + (SETQ ERR ERRB) + (SETQ SX (1+ I)) + (SETQ SY (1+ J)))))) + (SETQ SX (* SX (LATEX-SIGN DX))) + (SETQ SY (* SY (LATEX-SIGN DY)))))) + (FORMAT T " \\put(~5,0F,~5,0F) {\\~A(~D,~D){~5,0F}}~%" + (* FROMX *DRAW-LATEX-FACTOR*) (* FROMY *DRAW-LATEX-FACTOR*) + (IF ARROWFLG "vector" "line") SX SY SIZ))) + +(DEFUN LATEX-SIGN (X) (IF (>= X 0) 1 -1)) + +(DEFUN DRAW-OUTPUT (OUTFILENAME &OPTIONAL NAMES) + (PROG (PRETTYSAVE LENGTHSAVE D FNNAME CODE) + (OR NAMES (SETQ NAMES *DRAW-OBJECTS*)) + (IF (SYMBOLP NAMES) (SETQ NAMES (LIST NAMES))) + (WITH-OPEN-FILE + (OUTFILE OUTFILENAME :DIRECTION :OUTPUT :IF-EXISTS :SUPERSEDE) + (SETQ PRETTYSAVE *PRINT-PRETTY*) + (SETQ LENGTHSAVE *PRINT-LENGTH*) + (SETQ *PRINT-PRETTY* T) + (SETQ *PRINT-LENGTH* 80) + (FORMAT OUTFILE "; ~A ~A~%" OUTFILENAME (DRAW-GET-TIME-STRING)) + (DOLIST (NAME NAMES) + (IF (SETQ D (GET NAME 'DRAW-DESCR)) + (PROGN + (TERPRI OUTFILE) + (PRINT (LIST 'SETF + (LIST 'GET (LIST 'QUOTE NAME) ''DRAW-DESCR) + (LIST 'QUOTE D)) + OUTFILE) + (IF (AND (SETQ FNNAME (DRAW-DESC-FNNAME D)) + (SETQ CODE (SYMBOL-FUNCTION FNNAME))) + (PROGN + (TERPRI OUTFILE) + (PRINT (CONS 'DEFUN + (IF (EQ (CAR CODE) 'LAMBDA-BLOCK) + (CDR CODE) + (CONS FNNAME (CDR CODE)))) + OUTFILE))))) + (IF (SETQ D (GET NAME 'PICMENU-SPEC)) + (PROGN + (TERPRI OUTFILE) + (PRINT (LIST 'SETF + (LIST 'GET (LIST 'QUOTE NAME) + ''PICMENU-SPEC) + (LIST 'QUOTE D)) + OUTFILE)))) + (TERPRI OUTFILE) + (SETQ *PRINT-PRETTY* PRETTYSAVE) + (SETQ *PRINT-LENGTH* LENGTHSAVE)) + (RETURN OUTFILENAME))) + +(DEFUN DRAW-GET-TIME-STRING () + (LET (SECOND MINUTE HOUR DATE MONTH YEAR) + (MULTIPLE-VALUE-SETQ (SECOND MINUTE HOUR DATE MONTH YEAR) + (GET-DECODED-TIME)) + (FORMAT NIL "~2D ~A ~4D ~2D:~2D:~2D" DATE + (NTH (1- MONTH) + '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" + "Sep" "Oct" "Nov" "Dec")) + YEAR HOUR MINUTE SECOND))) + +(DEFUN COMPILE-DRAW () + (GLCOMPFILES *DIRECTORY* '("glisp/vector.lsp" "X/dwindow.lsp") + '("glisp/menu-set.lsp" "glisp/draw.lsp") "glisp/drawtrans.lsp" + "glisp/draw-header.lsp") + (CF DRAWTRANS)) + +(DEFUN COMPILE-DRAWB () + (GLCOMPFILES *DIRECTORY* + '("glisp/vector.lsp" "X/dwindow.lsp" "X/dwnoopen.lsp") + '("glisp/menu-set.lsp" "glisp/draw.lsp") "glisp/drawtrans.lsp" + "glisp/draw-header.lsp")) + +(DEFUN DRAW-OUT (&OPTIONAL NAMES FILE) + (OR NAMES (SETQ NAMES *DRAW-OBJECTS*)) + (IF (NOT (CONSP NAMES)) (SETQ NAMES (LIST NAMES))) + (DRAW-OUTPUT (OR FILE "glisp/draw.del") NAMES) + (SETQ *DRAW-OBJECTS* (SET-DIFFERENCE *DRAW-OBJECTS* NAMES)) + NAMES) diff --git a/xgcl-2/gcl_dwexports.lsp b/xgcl-2/gcl_dwexports.lsp new file mode 100644 index 0000000..cf30668 --- /dev/null +++ b/xgcl-2/gcl_dwexports.lsp @@ -0,0 +1,153 @@ +; dwexports.lsp Gordon S. Novak Jr. 26 Jan 2006 + + +(setf (get 'xlib::int-pos 'user::glfnresulttype) 'lisp::integer) + +(in-package :xlib) + +; exported symbols: from dwimports.lsp +(dolist (x '( menu stringify window picmenu textmenu editmenu barmenu + window-get-mouse-position window-create window-set-font + window-font-info window-gcontext window-parent + window-drawable-height window-drawable-width window-label + window-font window-foreground window-set-foreground + window-background window-set-background window-wfunction + window-get-geometry window-get-geometry-b window-sync + window-screen-height window-geometry window-size + window-left window-top-neg-y window-reset-geometry + window-force-output window-query-pointer window-set-xor + window-unset window-reset window-set-erase + window-set-copy window-set-invert window-set-line-width + window-set-line-attr window-std-line-attr window-draw-line + window-draw-line-xy window-draw-arrowhead-xy + window-draw-arrow-xy window-draw-arrow2-xy window-draw-box + window-draw-box-xy window-xor-box-xy window-draw-box-corners + window-draw-rcbox-xy window-draw-arc-xy + window-draw-circle-xy window-draw-circle window-erase-area + window-erase-area-xy window-erase-box-xy + window-draw-ellipse-xy window-copy-area-xy window-invertarea + window-invert-area window-invert-area-xy + window-prettyprintat window-prettyprintat-xy window-printat + window-printat-xy window-string-width window-string-height + window-string-extents window-font-string-width + window-yposition window-centeroffset dowindowcom + window-menu window-close window-unmap window-open + window-map window-destroy window-destroy-selected-window + window-clear window-moveto-xy window-paint + window-move window-draw-border window-track-mouse + window-wait-exposure window-wait-unmap + window-init-mouse-poll window-poll-mouse menu-init + menu-calculate-size menu-adjust-offset menu-draw + menu-item-value menu-find-item-width menu-find-item-height + menu-clear menu-display-item menu-choose menu-box-item + menu-unbox-item menu-item-position menu-select + menu-select! menu-select-b menu-destroy + menu-create menu-offset menu-size menu-moveto-xy + menu-reposition picmenu-create picmenu-create-spec + picmenu-create-from-spec picmenu-calculate-size picmenu-init + picmenu-draw picmenu-draw-button picmenu-delete-named-button + picmenu-select picmenu-box-item picmenu-unbox-item + picmenu-destroy picmenu-button-containsxy? + picmenu-item-position barmenu-create + barmenu-calculate-size barmenu-init barmenu-draw + barmenu-select barmenu-update-value window-get-point + window-get-click window-get-line-position + window-get-latex-position window-get-box-position + window-get-icon-position window-get-region + window-get-box-size window-track-mouse-in-region + window-adjust-box-side window-adj-box-xy window-get-circle + window-circle-radius window-draw-circle-pt + window-get-ellipse window-draw-ellipse-pt + window-draw-vector-pt window-get-vector-end + window-get-crosshairs window-draw-crosshairs-xy + window-get-cross window-draw-cross-xy window-draw-dot-xy + window-draw-latex-xy window-reset-color + window-set-color-rgb window-set-xcolor window-set-color + window-set-color window-free-color window-get-chars + window-process-char-event window-input-string + window-input-char-fn window-draw-carat window-init-keymap + window-set-cursor window-positive-y window-code-char + window-get-raw-char + window-print-line window-print-lines textmenu-create + textmenu-calculate-size textmenu-init textmenu-draw + textmenu-select textmenu-set-text textmenu + editmenu editmenu-create editmenu-calculate-size + editmenu-init editmenu-draw editmenu-display + window-edit + window-edit-display editmenu-carat editmenu-erase + window-edit-erase editmenu-select editmenu-edit-fn + window-edit-fn editmenu-setxy editmenu-char + editmenu-edit + *window-editmenu-kill-strings* +*window-add-menu-title* +*window-menu* +*mouse-x* +*mouse-y* +*mouse-window* +*window-fonts* +*window-display* +*window-screen* +*root-window* +*black-pixel* +*white-pixel* +*default-fg-color* +*default-bg-color* +*default-size-hints* +*default-GC* +*default-colormap* +*window-event* +*window-default-pos-x* +*window-default-pos-y* +*window-default-border* +*window-default-font-name* +*window-default-cursor* +*window-save-foreground* +*window-save-function* +*window-attributes* +*window-attr* +*menu-title-pad* +*root-return* +*child-return* +*root-x-return* +*root-y-return* +*win-x-return* +*win-y-return* +*mask-return* +*x-return* +*y-return* +*width-return* +*height-return* +*depth-return* +*border-width-return* +*text-width-return* +*direction-return* +*ascent-return* +*descent-return* +*overall-return* +*GC-Values* +*window-xcolor* +*window-menu-code* + +*window-keymap* +*window-shiftkeymap* +*window-keyinit* +*window-meta* +*window-ctrl* +*window-shift* +*window-string* +*window-string-count* +*window-string-max* +*window-input-string-x* +*window-input-string-y* +*window-input-string-charwidth* + +*window-shift-keys* +*window-control-keys* +*window-meta-keys* +*barmenu-update-value-cons* +*picmenu-no-selection* +*min-keycodes-return* +*max-keycodes-return* +*keycodes-return* + )) + (export x)) ; export the above symbols diff --git a/xgcl-2/gcl_dwimports.lsp b/xgcl-2/gcl_dwimports.lsp new file mode 100644 index 0000000..2d570cc --- /dev/null +++ b/xgcl-2/gcl_dwimports.lsp @@ -0,0 +1,77 @@ +; dwimports.lsp Gordon S. Novak Jr. 08 Sep 06 + +; Copyright (c) 2006 Gordon S. Novak Jr. and The University of Texas at Austin. + +; This file imports symbols of the XGCL package; these symbols may be +; needed by a more serious user of some of the XGCL functions. + +; See the file gnu.license . + +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 2 of the License, or +; (at your option) any later version. + +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + +; Some of the files that interface to the Xlib are adapted from DEC/MIT files. +; See the file dec.copyright for details. + +; This file should be loaded immediately after starting Lisp: +; If Lisp has seen any of these symbols, loading this file will cause an error. + +(dolist (x '( xlib::picmenu-spec xlib::picmenu-button xlib::rgb + xlib::menu-window xlib::flat xlib::parent-window xlib::parent-offset-x + xlib::parent-offset-y xlib::picture-width xlib::picture-height + xlib::title xlib::permanent xlib::menu-font xlib::item-width xlib::item-height + xlib::items xlib::menuw xlib::title-present xlib::width xlib::height + xlib::base-x xlib::base-y xlib::offset xlib::size xlib::region xlib::voffset + xlib::vsize xlib::init xlib::init? xlib::contains? xlib::create xlib::clear + xlib::select xlib::select! xlib::choose xlib::draw xlib::destroy + xlib::moveto-xy xlib::reposition xlib::box-item xlib::unbox-item + xlib::display-item xlib::item-value xlib::item-position xlib::find-item-width + xlib::find-item-height xlib::adjust-offset xlib::calculate-size + xlib::menu-x xlib::menu-y xlib::spec xlib::boxflg xlib::deleted-buttons + xlib::draw-button xlib::delete-named-button xlib::drawing-width + xlib::drawing-height xlib::buttons xlib::dotflg xlib::drawfn xlib::menu-font + xlib::offset xlib::size xlib::highlightfn xlib::unhighlightfn + xlib::containsxy? xlib::color xlib::value xlib::maxval xlib::barwidth + xlib::horizontal xlib::subtrackfn xlib::subtrackparms xlib::update-value + xlib::gcontext xlib::parent xlib::drawable-height xlib::drawable-width + xlib::label xlib::font xlib::width xlib::height xlib::left xlib::right + xlib::top-neg-y xlib::leftmargin xlib::rightmargin xlib::yposition + xlib::wfunction xlib::foreground xlib::background xlib::force-output + xlib::set-font xlib::set-foreground xlib::set-background + xlib::set-cursor xlib::set-erase xlib::set-xor xlib::set-invert xlib::set-copy + xlib::set-line-width xlib::set-line-attr xlib::std-line-attr xlib::unset + xlib::reset xlib::sync xlib::geometry xlib::size xlib::get-geometry + xlib::reset-geometry xlib::query-pointer xlib::wait-exposure xlib::wait-unmap + xlib::clear xlib::mapw xlib::unmap xlib::destroy + xlib::positive-y xlib::drawline xlib::draw-line xlib::draw-line-xy + xlib::draw-latex-xy xlib::draw-arrow-xy xlib::draw-arrow2-xy + xlib::draw-arrowhead-xy xlib::draw-box xlib::draw-box-xy + xlib::draw-box-corners xlib::draw-rcbox-xy xlib::xor-box-xy xlib::draw-circle + xlib::draw-circle-xy xlib::draw-ellipse-xy xlib::draw-arc-xy xlib::invertarea + xlib::invert-area xlib::invert-area-xy xlib::copy-area-xy xlib::printat + xlib::printat-xy xlib::prettyprintat-xy xlib::prettyprintat xlib::string-width + xlib::string-extents xlib::erase-area xlib::erase-area-xy xlib::erase-box-xy + xlib::moveto-xy xlib::move xlib::paint xlib::centeroffset xlib::draw-border + xlib::track-mouse xlib::track-mouse-in-region xlib::init-mouse-poll + xlib::poll-mouse xlib::get-point xlib::get-click xlib::get-line-position + xlib::get-latex-position xlib::get-icon-position xlib::get-box-position + xlib::get-box-size xlib::get-region xlib::adjust-box-side + xlib::get-mouse-position xlib::get-circle xlib::get-ellipse + xlib::get-crosshairs xlib::draw-crosshairs-xy xlib::get-cross + xlib::draw-cross-xy xlib::draw-dot-xy xlib::draw-vector-pt + xlib::get-vector-end xlib::reset-color xlib::set-color-rgb xlib::set-color + xlib::set-xcolor xlib::free-color xlib::get-chars xlib::input-string + xlib::courier-bold-12 xlib::8x10 xlib::9x15 xlib::center xlib::top + xlib::bottom xlib::xor xlib::erase xlib::copy xlib::buttonname + )) (import x)) diff --git a/xgcl-2/gcl_dwimportsb.lsp b/xgcl-2/gcl_dwimportsb.lsp new file mode 100644 index 0000000..1f7e5a5 --- /dev/null +++ b/xgcl-2/gcl_dwimportsb.lsp @@ -0,0 +1,76 @@ +; dwimportsb.lsp Gordon S. Novak Jr. 11 Sep 06 + +; Copyright (c) 2006 Gordon S. Novak Jr. and The University of Texas at Austin. + +; This file imports symbols of the XGCL package; these symbols may be +; needed by a hard-core user of the Xlib functions. + +; See the file gnu.license . + +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 1, or (at your option) +; any later version. + +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +; This file imports symbols from the dwindow.lsp file (in XLIB: package) +; to the current package (such as the :USER package). +; This will allow the dwindow.lsp functions to be called by just their +; names and without any package qualifier. + +; This file should be loaded immediately after starting Lisp: +; If Lisp has seen any of these symbols, loading this file will cause an error. + +(dolist (x '(xlib::XRecolorCursor +xlib::XFlush xlib::XUnMapWindow xlib::XClearWindow xlib::XMapWindow +xlib::XTextWidth xlib::XOpenDisplay xlib::XdefaultScreen xlib::XRootWindow +xlib::XBlackPixel xlib::XWhitePixel xlib::XDefaultGC xlib::XDefaultColormap +xlib::make-XsetWindowAttributes xlib::set-XsetWindowAttributes-backing_store +xlib::set-XsetWindowAttributes-save_under xlib::make-XWindowAttributes +xlib::make-XsizeHints xlib::make-XEvent xlib::make-XGCValues +xlib::XQueryPointer xlib::XCreateSimpleWindow xlib::XsetStandardProperties +xlib::XCreateGC xlib::CWSaveUnder xlib::CWBackingStore +xlib::XloadQueryFont xlib::XsetFont xlib::XGetGCValues +xlib::XGCValues-foreground xlib::XsetForeground xlib::XGCValues-Background +xlib::XsetBackground xlib::XGCValues-function xlib::XCreateFontCursor +xlib::XDefineCursor xlib::XGetGeometry +xlib::Xsync xlib::XsetFunction xlib::GXxor xlib::GXcopy +xlib::XsetLineAttributes xlib::LineSolid xlib::CapButt xlib::JoinMiter +xlib::XDrawLine xlib::XdrawArc xlib::XClearArea xlib::XCopyArea +xlib::XFillRectangle xlib::XdrawImageString xlib::XTextExtents +xlib::XDestroyWindow xlib::XFreeGC xlib::XMoveWindow xlib::Xsync +xlib::Xselectinput xlib::ButtonPressMask xlib::PointerMotionMask +xlib::XNextEvent xlib::XAnyEvent-type xlib::XAnyEvent-window +xlib::MotionNotify xlib::ButtonPress +xlib::XMotionEvent-x xlib::XMotionEvent-y xlib::XButtonEvent-button +xlib::XAnyEvent-window +xlib::XButtonEvent-button xlib::XWindowAttributes-map_state +xlib::ISUnmapped xlib::XPending +xlib::Expose xlib::XAllocColor xlib::XColor-Pixel xlib::XFreeColors +xlib::KeyPressMask xlib::KeyReleaseMask xlib::KeyRelease +xlib::KeyPress xlib::ButtonPress xlib::XDisplayKeycodes +xlib::XGetKeyboardMapping +xlib::XFree xlib::XK_Shift_R xlib::XK_Shift_L xlib::XK_Control_L +xlib::XK_Control_R xlib::XK_Alt_R xlib::XK_Alt_L xlib::XK_Return +xlib::XK_Tab xlib::XK_BackSpace xlib::get-c-string xlib::int-pos +xlib::fixnum-array xlib::int-array xlib::fixnum-pos +xlib::set-xsizehints-x xlib::set-xsizehints-y xlib::set-xsizehints-width +xlib::set-xsizehints-height xlib::set-xsizehints-flags xlib::set-foreground +xlib::set-background xlib::set-font +xlib::set-cursor xlib::set-line-width xlib::set-line-attr +xlib::set-Xcolor-red xlib::set-Xcolor-green xlib::set-Xcolor-blue +xlib::WhenMapped xlib::Psize xlib::Pposition xlib::CWSaveUnder +xlib::CWBackingStore xlib::NoSymbol +xlib::leavewindowmask xlib::buttonreleasemask xlib::exposuremask +xlib::GCForeground xlib::GCBackground xlib::GCFunction +xlib::None xlib::Xfontstruct-fid xlib::XChangeWindowAttributes +xlib::XGetWindowAttributes lisp::null xlib::Make-Xcolor + )) (import x) ) diff --git a/xgcl-2/gcl_dwindow.lsp b/xgcl-2/gcl_dwindow.lsp new file mode 100644 index 0000000..15864f0 --- /dev/null +++ b/xgcl-2/gcl_dwindow.lsp @@ -0,0 +1,3020 @@ +; dwindow.lsp Gordon S. Novak Jr. ; 13 Jan 10 + +; Window types and interface functions for using X windows from GNU Common Lisp + +; Copyright (c) 2010 Gordon S. Novak Jr. and The University of Texas at Austin. + +; 08 Jan 97; 17 May 02; 17 May 04; 18 May 04; 01 Jun 04; 18 Aug 04; 21 Jan 06 +; 24 Jan 06; 24 Jun 06; 25 Jun 06; 17 Jul 06; 23 Aug 06; 08 Sep 06; 21 May 09 +; 28 Aug 09; 31 Aug 09; 28 Oct 09; 07 Nov 09; 12 Jan 10 + +; See the files gnu.license and dec.copyright . + +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 2 of the License, or +; (at your option) any later version. + +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + +; Some of the files that interface to the Xlib are adapted from DEC/MIT files. +; See the file dec.copyright for details. + +; Written by: Gordon S. Novak Jr., Department of Computer Sciences, +; University of Texas at Austin 78712. novak@cs.utexas.edu + +; These functions use the convention that positive y is upwards, +; (0 0) is the lower-left corner of a window. + +; derived from {DSK}DWINDOW.CL;1 1-Mar-89 13:16:20 +; Modified for AKCL/X using Hiep Huu Nguyen's interfaces from AKCL -> C -> X. +; Parts of Nguyen's file Xinit.lsp are included. + + +(defvar *window-add-menu-title* nil) ; t to add title bar within menu area +(defvar *window-menu* nil) +(defvar *mouse-x* nil) +(defvar *mouse-y* nil) +(defvar *mouse-window* nil) + +(defvar *window-fonts* (list + (list 'courier-bold-12 + "*-*-courier-bold-r-*-*-12-*-*-*-*-*-iso8859-1") + (list 'courier-medium-12 + "*-*-courier-medium-r-*-*-12-*-*-*-*-*-iso8859-1") + (list '6x12 "6x12") + (list '8x13 "8x13") + (list '9x15 "9x15"))) + +(glispglobals (*window-menu* menu) + (*mouse-x* integer) + (*mouse-y* integer) + (*mouse-window* window) + (*picmenu-no-selection* picmenu-button) ) + +(defvar *window-display* nil) +(defvar *window-screen* nil) +(defvar *root-window*) +(defvar *black-pixel*) +(defvar *white-pixel*) +(defvar *default-fg-color*) +(defvar *default-bg-color*) +(defvar *default-size-hints*) +(defvar *default-GC*) +(defvar *default-colormap*) +(defvar *window-event*) +(defvar *window-default-pos-x* 10) +(defvar *window-default-pos-y* 20) +(defvar *window-default-border* 1) +(defvar *window-default-font-name* 'courier-bold-12) +(defvar *window-default-cursor* 68) +(defvar *window-save-foreground*) +(defvar *window-save-function*) +(defvar *window-attributes*) +(defvar *window-attr*) +(defvar *menu-title-pad* 30) ; extra space for title bar of menu +; The following -return globals are used in calls to Xlib +; routines. +; Where the Xlib parameter is int*, the parameter must be +; initialized to (int-array 1) and is accessed with +; (int-pos param 0). +; The following X types are CARD32: (from Xproto.h) +; Window Drawable Font Pixmap Cursor Colormap GContext +; Atom VisualID Time KeySym +; KeyCode = CARD8 +(defvar *root-return* (fixnum-array 1)) +(defvar *child-return* (fixnum-array 1)) +(defvar *root-x-return* (int-array 1)) +(defvar *root-y-return* (int-array 1)) +(defvar *win-x-return* (int-array 1)) +(defvar *win-y-return* (int-array 1)) +(defvar *mask-return* (int-array 1)) +(defvar *x-return* (int-array 1)) +(defvar *y-return* (int-array 1)) +(defvar *width-return* (int-array 1)) +(defvar *height-return* (int-array 1)) +(defvar *depth-return* (int-array 1)) +(defvar *border-width-return* (int-array 1)) +(defvar *text-width-return* (int-array 1)) +(defvar *direction-return* (int-array 1)) +(defvar *ascent-return* (int-array 1)) +(defvar *descent-return* (int-array 1)) +(defvar *overall-return* (int-array 1)) +(defvar *GC-Values*) +(defvar *window-xcolor* nil) +(defvar *window-menu-code* nil) + +(defvar *window-keymap* (make-array 256)) +(defvar *window-shiftkeymap* (make-array 256)) +(defvar *window-keyinit* nil) +(defvar *window-meta*) ; set if meta down when char is pressed +(defvar *window-ctrl*) ; set if ctrl down when char is pressed +(defvar *window-shift*) ; set if shift down when char is pressed + +(defvar *window-shift-keys* nil) +(defvar *window-control-keys* nil) +(defvar *window-meta-keys* nil) +(defvar *min-keycodes-return* (int-array 1)) +(defvar *max-keycodes-return* (int-array 1)) +(defvar *keycodes-return* (int-array 1)) + +(setq *window-keyinit* nil) + +(defmacro picmenu-spec (symbol) `(get ,symbol 'picmenu-spec)) + +(glispobjects + +(drawable anything) + +(menu (listobject (menu-window window) + (flat boolean) + (parent-window drawable) + (parent-offset-x integer) + (parent-offset-y integer) + (picture-width integer) + (picture-height integer) + (title string) + (permanent boolean) + (menu-font symbol) + (item-width integer) + (items (listof symbol)) ) + prop ((menuw (menu-window or (menu-init self)) result window) + (title-present (title and ((length title) > 0))) + (width (picture-width)) + (height (picture-height)) + (base-x ((if flat parent-offset-x 0))) + (base-y ((if flat parent-offset-y 0))) + (offset menu-offset) + (size menu-size) + (region ((virtual region with start = voffset size = vsize))) + (voffset ((virtual vector with x = base-x y = base-y))) + (vsize ((virtual vector with x = picture-width + y = picture-height))) ) + msg ((init menu-init) + (init? ((menu-window and (picture-height > 0)) or (init self))) + (contains? (glambda (m p) (contains? (region m) p))) + (create menu-create result menu) + (clear menu-clear) + (select menu-select) + (select! menu-select!) + (choose menu-choose) + (draw menu-draw) + (destroy menu-destroy) + (moveto-xy menu-moveto-xy) + (reposition menu-reposition) + (reposition-line menu-reposition-line) + (box-item menu-box-item) + (unbox-item menu-box-item) ; same since it uses xor + (display-item menu-display-item) + (item-value menu-item-value open t) + (item-position menu-item-position result vector) + (find-item-width menu-find-item-width) + (find-item-height menu-find-item-height) + (adjust-offset menu-adjust-offset) + (calculate-size menu-calculate-size) + (menu-x (glambda (m x) ((base-x m) + x))) + (menu-y (glambda (m y) ((base-y m) + y))) ) ) + +; picture menu: a drawn object with "hot buttons" at certain points. +; note: the first 10 data items of picmenu must be the same as in menu. +(picmenu (listobject (menu-window window) + (flat boolean) + (parent-window drawable) + (parent-offset-x integer) + (parent-offset-y integer) + (picture-width integer) + (picture-height integer) + (title string) + (permanent boolean) + (spec (transparent picmenu-spec)) + (boxflg boolean) + (deleted-buttons (listof symbol)) + (button-colors (listof (list (name symbol) (color rgb)))) + ) + prop ((menuw (menu-window or (picmenu-init self)) result window) ) + msg ((init picmenu-init) + (init? ((menu-window and (picture-height > 0)) or (init self))) + (create picmenu-create result picmenu) + (select picmenu-select) + (draw picmenu-draw) + (draw-button picmenu-draw-button) + (draw-named-button picmenu-draw-named-button) + (set-named-button-color picmenu-set-named-button-color) + (delete-named-button picmenu-delete-named-button) + (box-item picmenu-box-item) + (unbox-item picmenu-unbox-item) + (calculate-size picmenu-calculate-size) + (item-position picmenu-item-position result vector) ) + supers (menu) ) + +(picmenu-spec (listobject (drawing-width integer) + (drawing-height integer) + (buttons (listof picmenu-button)) + (dotflg boolean) + (drawfn anything) + (menu-font symbol) )) + +(picmenu-button (list (buttonname symbol) + (offset vector) + (size vector) + (highlightfn anything) + (unhighlightfn anything)) + msg ((containsxy? picmenu-button-containsxy?)) ) + +(barmenu (listobject (menu-window window) + (flat boolean) + (parent-window drawable) + (parent-offset-x integer) + (parent-offset-y integer) + (picture-width integer) + (picture-height integer) + (title string) + (permanent boolean) + (color rgb) + (value integer) + (maxval integer) + (barwidth integer) + (horizontal boolean) + (subtrackfn anything) + (subtrackparms (listof anything))) + prop ((menuw (menu-window or (barmenu-init self)) result window) + (picture-width ((if (horizontal m) (maxval m) + (barwidth m)) )) + (picture-height ((if (horizontal m) (barwidth m) + (maxval m)) )) ) + msg ((init barmenu-init) + (init? ((menu-window and (picture-height > 0)) + or (init self))) + (create barmenu-create result barmenu) + (select barmenu-select) + (draw barmenu-draw) + (update-value barmenu-update-value) + (calculate-size barmenu-calculate-size) ) +supers (menu)) + +; Note: data through 'permanent' must be same as in menu. +(textmenu (listobject (menu-window window) + (flat boolean) + (parent-window drawable) + (parent-offset-x integer) + (parent-offset-y integer) + (picture-width integer) + (picture-height integer) + (title string) + (permanent boolean) + (text string) + (drawing-width integer) + (drawing-height integer) + (boxflg boolean) + (menu-font symbol) ) + + prop ((menuw (menu-window or (textmenu-init self)) result window) ) + msg ((init textmenu-init) + (init? ((menu-window and (picture-height > 0)) or (init self))) + (create textmenu-create result textmenu) + (select textmenu-select) + (draw textmenu-draw) + (calculate-size textmenu-calculate-size) + (set-text textmenu-set-text open t) ) + supers (menu) ) + +; Note: data through 'permanent' must be same as in menu. +(editmenu (listobject (menu-window window) + (flat boolean) + (parent-window drawable) + (parent-offset-x integer) + (parent-offset-y integer) + (picture-width integer) + (picture-height integer) + (title string) + (permanent boolean) + (text (listof string)) + (drawing-width integer) + (drawing-height integer) + (boxflg boolean) + (menu-font symbol) + (column integer) + (line integer) + (scrollval integer) ) + prop ((menuw (menu-window or (editmenu-init self)) result window) + (scroll ((if (numberp scrollval) + scrollval + 0))) ) + + msg ((init editmenu-init) + (init? ((menu-window and (picture-height > 0)) or (init self))) + (create editmenu-create result editmenu) + (select editmenu-select) + (draw editmenu-draw) + (edit editmenu-edit) + (carat editmenu-carat) + (display editmenu-display) + (calculate-size editmenu-calculate-size) + (line-y editmenu-line-y open t) ) + supers (menu) ) + +(window (listobject (parent drawable) + (gcontext anything) + (drawable-height integer) + (drawable-width integer) + (label string) + (font anything) ) +default ((self nil)) +prop ((width (drawable-width)) + (height (drawable-height)) + (left window-left open t result integer) + (right (left + width)) + (top-neg-y window-top-neg-y open t result integer) + (leftmargin (1)) + (rightmargin (width - 1)) + (yposition window-yposition result integer open t) + (wfunction window-wfunction open t) + (foreground window-foreground open t) + (background window-background open t) + (font-width ((string-width self "W"))) + (font-height ((string-height self "Tg"))) ) +msg ((force-output window-force-output open t) + (set-font window-set-font) + (set-foreground window-set-foreground open t) + (set-background window-set-background open t) + (set-cursor window-set-cursor open t) + (set-erase window-set-erase open t) + (set-xor window-set-xor open t) + (set-invert window-set-invert open t) + (set-copy window-set-copy open t) + (set-line-width window-set-line-width open t) + (set-line-attr window-set-line-attr open t) + (std-line-attr window-std-line-attr open t) + (unset window-unset open t) + (reset window-reset open t) + (sync window-sync open t) + (geometry window-geometry open t) + (size window-size) + (get-geometry window-get-geometry open t) + (reset-geometry window-reset-geometry open t) + (query-pointer window-query-pointer open t) + (wait-exposure window-wait-exposure) + (wait-unmap window-wait-unmap) + (clear window-clear open t) + (mapw window-map open t) + (unmap window-unmap open t) + (open window-open open t) + (close window-close open t) + (destroy window-destroy open t) + (positive-y window-positive-y open t) + (drawline window-draw-line open t) + (draw-line window-draw-line open t) + (draw-line-xy window-draw-line-xy open t) + (draw-latex-xy window-draw-latex-xy) + (draw-arrow-xy window-draw-arrow-xy ) + (draw-arrow2-xy window-draw-arrow2-xy ) + (draw-arrowhead-xy window-draw-arrowhead-xy ) + (draw-box window-draw-box open t) + (draw-box-xy window-draw-box-xy) + (draw-box-corners window-draw-box-corners open t) + (draw-rcbox-xy window-draw-rcbox-xy) + (draw-box-line-xy window-draw-box-line-xy) + (xor-box-xy window-xor-box-xy open t) + (draw-circle window-draw-circle open t) + (draw-circle-xy window-draw-circle-xy open t) + (draw-ellipse-xy window-draw-ellipse-xy open t) + (draw-arc-xy window-draw-arc-xy open t) + (invertarea window-invertarea open t) + (invert-area window-invert-area open t) + (invert-area-xy window-invert-area-xy open t) + (copy-area-xy window-copy-area-xy open t) + (printat window-printat open t) + (printat-xy window-printat-xy open t) + (print-line window-print-line) + (print-lines window-print-lines) + (prettyprintat window-prettyprintat open t) + (prettyprintat-xy window-prettyprintat-xy open t) + (string-width window-string-width open t) + (string-extents window-string-extents open t) + (erase-area window-erase-area open t) + (erase-area-xy window-erase-area-xy open t) + (erase-box-xy window-erase-box-xy open t) + (moveto-xy window-moveto-xy) + (move window-move) + (paint window-paint) + (centeroffset window-centeroffset open t) + (draw-border window-draw-border open t) + (track-mouse window-track-mouse) + (track-mouse-in-region window-track-mouse-in-region) + (init-mouse-poll window-init-mouse-poll) + (poll-mouse window-poll-mouse) + (get-point window-get-point) + (get-click window-get-click) + (get-line-position window-get-line-position) + (get-latex-position window-get-latex-position) + (get-icon-position window-get-icon-position) + (get-box-position window-get-box-position) + (get-box-line-position window-get-box-line-position) + (get-box-size window-get-box-size) + (get-region window-get-region) + (adjust-box-side window-adjust-box-side) + (get-mouse-position window-get-mouse-position) + (get-circle window-get-circle) + (get-ellipse window-get-ellipse) + (get-crosshairs window-get-crosshairs) + (draw-crosshairs-xy window-draw-crosshairs-xy) + (get-cross window-get-cross) + (draw-cross-xy window-draw-cross-xy) + (draw-dot-xy window-draw-dot-xy) + (draw-vector-pt window-draw-vector-pt) + (get-vector-end window-get-vector-end) + (reset-color window-reset-color) + (set-color-rgb window-set-color-rgb) + (set-color window-set-color) + (set-xcolor window-set-xcolor) + (free-color window-free-color) + (get-chars window-get-chars) + (input-string window-input-string) + (string-width window-string-width) + (string-extents window-string-extents) + (string-height window-string-height) + (draw-carat window-draw-carat) + )) + +(rgb (list (red integer) (green integer) (blue integer))) + + ) ; glispobjects + +(glispconstants ; used by GEV + (windowcharwidth 9 integer) + (windowlineyspacing 17 integer) +) + +(defvar *picmenu-no-selection* '(no-selection (0 0) (0 0) nil nil)) + +; 14 Mar 95 +; Make something into a string. +; The copy-seq avoids an error with get-c-string on Sun. +(defun stringify (x) + (cond ((stringp x) x) + ((symbolp x) (copy-seq (symbol-name x))) + (t (princ-to-string x)))) + +; 24 Jun 06 +; This function initializes variables needed by most applications. +; It uses all defaults inherited from the root window, and screen. ; H. Nguyen +(defun window-Xinit () + (setq *window-display* (XOpenDisplay (get-c-string ""))) + (if (or (not (numberp *window-display*)) ; 22 Jun 06 + (< *window-display* 10000)) + (error "DISPLAY did not open: return value ~A~%" *window-display*)) + (setq *window-screen* (XdefaultScreen *window-display*)) + (setq *root-window* (XRootWindow *window-display* *window-screen*)) + (setq *black-pixel* (XBlackPixel *window-display* *window-screen*)) + (setq *white-pixel* (XWhitePixel *window-display* *window-screen*)) + (setq *default-fg-color* *black-pixel*) + (setq *default-bg-color* *white-pixel*) + (setq *default-GC* (XDefaultGC *window-display* *window-screen*)) + (setq *default-colormap* (XDefaultColormap *window-display* + *window-screen*)) + (setq *window-attributes* (make-XsetWindowAttributes)) + (set-XsetWindowAttributes-backing_store *window-attributes* + WhenMapped) + (set-XsetWindowAttributes-save_under *window-attributes* 1) ; True + (setq *window-attr* (make-XWindowAttributes)) + (Xflush *window-display*) + (setq *default-size-hints* (make-XsizeHints)) + (setq *window-event* (make-XEvent)) + (setq *GC-Values* (make-XGCValues)) ) + +(defun window-get-mouse-position () + (XQueryPointer *window-display* *root-window* + *root-return* *child-return* *root-x-return* *root-y-return* + *win-x-return* *win-y-return* *mask-return*) + (setq *mouse-x* (int-pos *root-x-return* 0)) + (setq *mouse-y* (int-pos *root-y-return* 0)) + (setq *mouse-window* (fixnum-pos *child-return* 0)) ) ; 22 Jun 06 + +; 13 Aug 91; 14 Aug 91; 06 Sep 91; 12 Sep 91; 06 Dec 91; 01 May 92; 01 Sep 92 +; 08 Sep 06 +(setf (glfnresulttype 'window-create) 'window) +(gldefun window-create (width height &optional str parentw pos-x pos-y font) + (let (w pw fg-color bg-color (null 0)) + (or *window-display* (window-Xinit)) + (setq fg-color *default-fg-color*) + (setq bg-color *default-bg-color*) + (unless pos-x (pos-x = *window-default-pos-x*)) + (unless pos-y (pos-y = *window-default-pos-y*)) + (w = (a window with + drawable-width = width + drawable-height = height + label = (if str (stringify str) " ") )) + (pw = (or parentw *root-window*)) + (window-get-geometry-b pw) + ((parent w) = + (XCreateSimpleWindow *window-display* pw + pos-x + ((int-pos *height-return* 0) + - pos-y - height) + width height + *window-default-border* + fg-color bg-color)) + (set-xsizehints-x *default-size-hints* pos-x) + (set-xsizehints-y *default-size-hints* pos-y) + (set-xsizehints-width *default-size-hints* (width w)) + (set-xsizehints-height *default-size-hints* (height w)) + (set-xsizehints-flags *default-size-hints* + (+ Psize Pposition)) + (XsetStandardProperties *window-display* (parent w) + (get-c-string (label w)) + (get-c-string (label w)) ; icon name + none null null + *default-size-hints*) + ((gcontext w) = (XCreateGC *window-display* (parent w) 0 null)) + (set-foreground w fg-color) + (set-background w bg-color) + (set-font w (or font *window-default-font-name*)) + (set-cursor w *window-default-cursor*) + (set-line-width w 1) + (XChangeWindowAttributes *window-display* (parent w) + (+ CWSaveUnder CWBackingStore) + *window-attributes*) + (Xselectinput *window-display* (parent w) + (+ leavewindowmask buttonpressmask + buttonreleasemask + pointermotionmask exposuremask)) + (open w) + w )) + +; 06 Aug 91; 17 May 04 +; Set the font for a window to the one specified by fontsymbol. +; derived from Nguyen's my-load-font. +(gldefun window-set-font ((w window) (fontsymbol symbol)) + (let (fontstring font-info (display *window-display*)) + (fontstring = (or (cadr (assoc fontsymbol *window-fonts*)) + (stringify fontsymbol))) + (font-info = (XloadQueryFont display + (get-c-string fontstring))) + (if (eql 0 font-info) + (format t "~%can't open font ~a ~a~%" fontsymbol fontstring) + (progn (XsetFont display (gcontext w) (Xfontstruct-fid font-info)) + ((font w) = font-info)) ) )) + +; 15 Oct 91 +(defun window-font-info (fontsymbol) + (XloadQueryFont *window-display* + (get-c-string + (or (cadr (assoc fontsymbol *window-fonts*)) + (stringify fontsymbol))))) + + +; Functions to allow access to window properties from plain Lisp +(gldefun window-gcontext ((w window)) (gcontext w)) +(gldefun window-parent ((w window)) (parent w)) +(gldefun window-drawable-height ((w window)) (drawable-height w)) +(gldefun window-drawable-width ((w window)) (drawable-width w)) +(gldefun window-label ((w window)) (label w)) +(gldefun window-font ((w window)) (font w)) + +; 07 Aug 91; 14 Aug 91 +(gldefun window-foreground ((w window)) + (XGetGCValues *window-display* (gcontext w) GCForeground + *GC-Values*) + (XGCValues-foreground *GC-Values*) ) + +(gldefun window-set-foreground ((w window) (fg-color integer)) + (XsetForeground *window-display* (gcontext w) fg-color)) + +(gldefun window-background ((w window)) + (XGetGCValues *window-display* (gcontext w) GCBackground + *GC-Values*) + (XGCValues-Background *GC-Values*) ) + +(gldefun window-set-background ((w window) (bg-color integer)) + (XsetBackground *window-display* (gcontext w) bg-color)) + +; 08 Aug 91 +(gldefun window-wfunction ((w window)) + (XGetGCValues *window-display* (gcontext w) GCFunction + *GC-Values*) + (XGCValues-function *GC-Values*) ) + +; 08 Aug 91 +; Get the geometry parameters of a window into global variables +(gldefun window-get-geometry ((w window)) (window-get-geometry-b (parent w))) + +; 06 Dec 91 +; Set cursor to a selected cursor number +(gldefun window-set-cursor ((w window) (n integer)) + (let (c) + (c = (XCreateFontCursor *window-display* n) ) + (XDefineCursor *window-display* (parent w) c) )) + +(defun window-get-geometry-b (w) + (XGetGeometry *window-display* w + *root-return* *x-return* *y-return* *width-return* + *height-return* *border-width-return* *depth-return*) ) + +; 15 Aug 91 +; clear event queue of previous motion events +(gldefun window-sync ((w window)) + (Xsync *window-display* 1) ) + +; 03 Oct 91; 06 Oct 94 +(gldefun window-screen-height () + (window-get-geometry-b *root-window*) + (int-pos *height-return* 0) ) + +; 08 Aug 91; 12 Sep 91; 28 Oct 91 +; Make a list of window geometry, (x y width height border-width). +(gldefun window-geometry ((w window)) + (let (sh) + (sh = (window-screen-height)) + (get-geometry w) + ((drawable-width w) = (int-pos *width-return* 0)) + ((drawable-height w) = (int-pos *height-return* 0)) + (list (int-pos *x-return* 0) + (sh - (int-pos *y-return* 0) + - (int-pos *height-return* 0)) + (int-pos *width-return* 0) + (int-pos *height-return* 0) + (int-pos *border-width-return* 0)) )) + +; 27 Nov 91 +(gldefun window-size ((w window)) (result vector) + (get-geometry w) + (list ((drawable-width w) = (int-pos *width-return* 0)) + ((drawable-height w) = (int-pos *height-return* 0)) ) ) + +(gldefun window-left ((w window)) + (get-geometry w) + (int-pos *x-return* 0)) + +; Get top of window in X (y increasing downwards) coordinates. +(gldefun window-top-neg-y ((w window)) + (get-geometry w) + (int-pos *y-return* 0)) + +; 08 Aug 91 +; Reset the local geometry parameters of a window from its X values. +; Needed, for example, if the user resizes the window by mouse command. +(gldefun window-reset-geometry ((w window)) + (get-geometry w) + ((drawable-width w) = (int-pos *width-return* 0)) + ((drawable-height w) = (int-pos *height-return* 0)) ) + +(gldefun window-force-output (&optional (w window)) + (Xflush *window-display*)) + +(gldefun window-query-pointer ((w window)) + (window-query-pointer-b (parent w)) ) + +(defun window-query-pointer-b (w) + (XQueryPointer *window-display* w + *root-return* *child-return* *root-x-return* *root-y-return* + *win-x-return* *win-y-return* *mask-return*) ) + +(gldefun window-positive-y ((w window) (y integer)) ((height w) - y)) + +; 08 Aug 91 +; Set parameters of a window for drawing by XOR, saving old values. +(gldefun window-set-xor ((w window)) + (let ((gc (gcontext w)) ) + (setq *window-save-function* (wfunction w)) + (XsetFunction *window-display* gc GXxor) + (setq *window-save-foreground* (foreground w)) + (XsetForeground *window-display* gc + (logxor *window-save-foreground* (background w))) )) + +; 08 Aug 91 +; Reset parameters of a window after change, using saved values. +(gldefun window-unset ((w window)) + (let ((gc (gcontext w)) ) + (XsetFunction *window-display* gc *window-save-function*) + (XsetForeground *window-display* gc *window-save-foreground*) )) + +; 04 Sep 91 +; Reset parameters of a window, using default values. +(gldefun window-reset ((w window)) + (let ((gc (gcontext w)) ) + (XsetFunction *window-display* gc GXcopy) + (XsetForeground *window-display* gc *default-fg-color*) + (XsetBackground *window-display* gc *default-bg-color*) )) + +; 09 Aug 91; 03 Sep 92 +; Set parameters of a window for erasing, saving old values. +(gldefun window-set-erase ((w window)) + (let ((gc (gcontext w)) ) + (setq *window-save-function* (wfunction w)) + (XsetFunction *window-display* gc GXcopy) + (setq *window-save-foreground* (foreground w)) + (XsetForeground *window-display* gc (background w)) )) + +(gldefun window-set-copy ((w window)) + (let ((gc (gcontext w)) ) + (setq *window-save-function* (wfunction w)) + (XsetFunction *window-display* gc GXcopy) + (setq *window-save-foreground* (foreground w)) )) + +; 12 Aug 91 +; Set parameters of a window for inversion, saving old values. +(gldefun window-set-invert ((w window)) + (let ((gc (gcontext w)) ) + (setq *window-save-function* (wfunction w)) + (XsetFunction *window-display* gc GXxor) + (setq *window-save-foreground* (foreground w)) + (XsetForeground *window-display* gc + (logxor *window-save-foreground* (background w))) )) + +; 13 Aug 91 +(gldefun window-set-line-width ((w window) (width integer)) + (set-line-attr w width nil nil nil)) + +; 13 Aug 91; 12 Sep 91 +(gldefun window-set-line-attr + (w\:window width &optional line-style cap-style join-style) + (XsetLineAttributes *window-display* (gcontext w) + (or width 1) + (or line-style LineSolid) + (or cap-style CapButt) + (or join-style JoinMiter) ) ) + +; 13 Aug 91 +; Set standard line attributes +(gldefun window-std-line-attr ((w window)) + (XsetLineAttributes *window-display* (gcontext w) + 1 LineSolid CapButt JoinMiter) ) + +; 06 Aug 91; 08 Aug 91; 12 Sep 91 +(gldefun window-draw-line ((w window) (from vector) (to vector) + &optional linewidth) + (window-draw-line-xy w (x from) (y from) (x to) (y to) linewidth) ) + +; 19 Dec 90; 07 Aug 91; 08 Aug 91; 09 Aug 91; 13 Aug 91; 12 Sep 91; 28 Sep 94 +(gldefun window-draw-line-xy ((w window) (fromx integer) + (fromy integer) + (tox integer) (toy integer) + &optional linewidth + (operation atom)) + (let ( (qqwheight (drawable-height w)) ) + (if (linewidth and (linewidth <> 1)) (set-line-width w linewidth)) + (case operation + (xor (set-xor w)) + (erase (set-erase w)) + (t nil)) + (XDrawLine *window-display* (parent w) (gcontext w) + fromx (- qqwheight fromy) tox (- qqwheight toy) ) + (case operation + ((xor erase) (unset w)) + (t nil)) + (if (linewidth and (linewidth <> 1)) (set-line-width w 1)) )) + +; 09 Oct 91 +(defun window-draw-arrowhead-xy (w x1 y1 x2 y2 &optional (linewidth 1) size) + (let (th theta ysth ycth (y2dela 0) (y2delb 0) (x2dela 0) (x2delb 0)) + (or size (setq size (+ 20 (* linewidth 5)))) + (setq th (atan (- y2 y1) (- x2 x1))) + (setq theta (* th (/ 180.0 pi))) + (setq ysth (round (* (1+ size) (sin th)))) + (setq ycth (round (* (1+ size) (cos th)))) + (if (and (eql y1 y2) (evenp linewidth)) ; correct for even-size lines + (if (> x2 x1) (setq y2delb 1) (setq y2dela 1))) + (if (and (eql x1 x2) (evenp linewidth)) ; correct for even-size lines + (if (> y2 y1) (setq x2delb 1) (setq x2dela 1))) + (window-draw-arc-xy w (- (- x2 ysth) x2dela) + (+ (+ y2 ycth) y2dela) size size + (+ 240 theta) 30 linewidth) + (window-draw-arc-xy w (- (+ x2 ysth) x2delb) + (+ (- y2 ycth) y2delb) size size + (+ 90 theta) 30 linewidth) )) + +(defun window-draw-arrow-xy (w x1 y1 x2 y2 + &optional (linewidth 1) size) + (window-draw-line-xy w x1 y1 x2 y2 linewidth) + (window-draw-arrowhead-xy w x1 y1 x2 y2 linewidth size) ) + +(defun window-draw-arrow2-xy (w x1 y1 x2 y2 + &optional (linewidth 1) size) + (window-draw-line-xy w x1 y1 x2 y2 linewidth) + (window-draw-arrowhead-xy w x1 y1 x2 y2 linewidth size) + (window-draw-arrowhead-xy w x2 y2 x1 y1 linewidth size) ) + +; 08 Aug 91; 14 Aug 91; 12 Sep 91 +(gldefun window-draw-box + ((w window) (offset vector) (size vector) &optional linewidth) + (window-draw-box-xy w (x offset) (y offset) (x size) (y size) linewidth) ) + +; 08 Aug 91; 12 Sep 91; 11 Dec 91; 01 Sep 92; 02 Sep 92; 17 Jul 06 +; New version avoids XDrawRectangle, which messes up when used with XOR. +; was (XDrawRectangle *window-display* (parent w) (gcontext w) +; offsetx (- qqwheight (offsety + sizey)) sizex sizey) +(gldefun window-draw-box-xy + ((w window) (offsetx integer) (offsety integer) + (sizex integer) (sizey integer) &optional linewidth) + (let ((qqwheight (drawable-height w)) lw lw2 lw2b (pw (parent w)) + (gc (gcontext w))) + (if (linewidth and (linewidth <> 1)) (set-line-width w linewidth)) + (lw = (or linewidth 1)) + (lw2 = (truncate lw 2)) + (lw2b = (truncate (lw + 1) 2)) + (XdrawLine *window-display* pw gc + (- offsetx lw2) (- qqwheight offsety) + (- (+ offsetx sizex) lw2) (- qqwheight offsety)) + (XdrawLine *window-display* pw gc + (+ offsetx sizex) (- qqwheight (- offsety lw2b)) + (+ offsetx sizex) (- qqwheight (+ sizey (- offsety lw2b)))) + (XdrawLine *window-display* pw gc + (+ offsetx sizex lw2b) (- qqwheight (+ offsety sizey)) + (+ offsetx lw2b) (- qqwheight (+ offsety sizey))) + (XdrawLine *window-display* pw gc + offsetx (- qqwheight (+ offsety sizey lw2)) + offsetx (- qqwheight (+ offsety lw2)) ) + (if (linewidth and (linewidth <> 1)) (set-line-width w 1)) )) + +; 26 Nov 91 +(gldefun window-xor-box-xy + ((w window) (offsetx integer) (offsety integer) + (sizex integer) (sizey integer) + &optional linewidth) + (window-set-xor w) + (window-draw-box-xy w offsetx offsety sizex sizey linewidth) + (window-unset w)) + +; 15 Aug 91; 12 Sep 91 +; Draw a box whose corners are specified +(gldefun window-draw-box-corners ((w window) (xa integer) (ya integer) + (xb integer) (yb integer) + &optional lw) + (draw-box-xy w (min xa xb) (min ya yb) (abs (- xa xb)) (abs (- ya yb)) lw) ) + +; 13 Sep 91; 17 Jul 06 +; Draw a box with round corners +(gldefun window-draw-rcbox-xy ((w window) (x integer) (y integer) + (width integer) + (height integer) (radius integer) + &optional linewidth) + (let (x1 x2 y1 y2 r lw2 lw2b fudge) + (r = (max 0 (min radius (truncate (abs width) 2) + (truncate (abs height) 2)))) + (if (not (numberp linewidth)) (linewidth = 1)) + (lw2 = (truncate linewidth 2)) + (lw2b = (truncate (1+ linewidth) 2)) + (fudge = (if (oddp linewidth) 0 1)) + (x1 = x + r) + (x2 = x + width - r) + (y1 = y + r) + (y2 = y + height - r) + (draw-line-xy w (- (- x1 1) lw2) y x2 y linewidth) ; bottom + (draw-line-xy w (x + width) (- y1 lw2b) (x + width) (+ y2 1) + linewidth) ; right + (draw-line-xy w (- x1 1) (+ y height) (+ x2 lw2) (+ y height) linewidth) + (draw-line-xy w x y1 x (+ y2 1) linewidth) ; left + (draw-arc-xy w (- x1 fudge) y1 r r 180 90 linewidth) + (draw-arc-xy w x2 y1 r r 270 90 linewidth) + (draw-arc-xy w x2 (+ y2 fudge) r r 0 90 linewidth) + (draw-arc-xy w (- x1 fudge) (+ y2 fudge) r r 90 90 linewidth) )) + +; 13 Aug 91; 15 Aug 91; 12 Sep 91 +(gldefun window-draw-arc-xy ((w window) (x integer) (y integer) + (radiusx integer) (radiusy integer) + (anglea number) (angleb number) + &optional linewidth) + (if (linewidth and (linewidth <> 1)) (set-line-width w linewidth)) + (XdrawArc *window-display* (parent w) (gcontext w) + (x - radiusx) (positive-y w (y + radiusy)) + (radiusx * 2) (radiusy * 2) + (truncate (* anglea 64)) (truncate (* angleb 64))) + (if (linewidth and (linewidth <> 1)) (set-line-width w 1)) ) + +; 08 Aug 91; 12 Sep 91 +(gldefun window-draw-circle-xy ((w window) (x integer) (y integer) + (radius integer) + &optional linewidth) + (if (linewidth and (linewidth <> 1)) (set-line-width w linewidth)) + (XdrawArc *window-display* (parent w) (gcontext w) + (x - radius) (positive-y w (y + radius)) + (radius * 2) (radius * 2) 0 (* 360 64)) + (if (linewidth and (linewidth <> 1)) (set-line-width w 1)) ) + +; 06 Aug 91; 14 Aug 91; 12 Sep 91 +(gldefun window-draw-circle ((w window) (pos vector) (radius integer) + &optional linewidth) + (window-draw-circle-xy w (x pos) (y pos) radius linewidth) ) + +; 08 Aug 91; 09 Sep 91 +(gldefun window-erase-area ((w window) (offset vector) (size vector)) + (window-erase-area-xy w (x offset) (y offset) (x size) (y size))) + +; 09 Sep 91; 11 Dec 91 +(gldefun window-erase-area-xy ((w window) (xoff integer) (yoff integer) + (xsize integer) (ysize integer)) + (XClearArea *window-display* (parent w) + xoff (positive-y w (yoff + ysize - 1)) + xsize ysize + 0 )) ; exposures + +; 21 Dec 93; 08 Sep 06 +(gldefun window-erase-box-xy ((w window) (xoff integer) (yoff integer) + (xsize integer) (ysize integer) + &optional (linewidth integer)) + (XClearArea *window-display* (parent w) + (xoff - (truncate (or linewidth 1) 2)) + (positive-y w (+ yoff ysize (truncate (or linewidth 1) 2))) + (xsize + (or linewidth 1)) + (ysize + (or linewidth 1)) + 0 )) ; exposures + +; 15 Aug 91; 12 Sep 91 +(gldefun window-draw-ellipse-xy ((w window) (x integer) (y integer) + (rx integer) (ry integer) &optional lw) + (draw-arc-xy w x y rx ry 0 360 lw)) + +; 09 Aug 91 +(gldefun window-copy-area-xy ((w window) fromx (fromy integer) + tox (toy integer) width height) + (let ((qqwheight (drawable-height w))) + (set-copy w) + (XCopyArea *window-display* (parent w) (parent w) (gcontext w) + fromx (- qqwheight (+ fromy height)) + width height + tox (- qqwheight (+ toy height))) + (unset w) )) + +; 07 Dec 90; 09 Aug 91; 12 Sep 91 +(gldefun window-invertarea ((w window) (area region)) + (window-invert-area-xy w (left area) (bottom area) + (width area) (height area))) + +; 07 Dec 90; 09 Aug 91; 12 Sep 91 +(gldefun window-invert-area ((w window) (offset vector) (size vector)) + (window-invert-area-xy w (x offset) (y offset) (x size) (y size)) ) + +; 12 Aug 91; 15 Aug 91; 13 Dec 91 +(gldefun window-invert-area-xy ((w window) left (bottom integer) width height) + (set-invert w) + (XFillRectangle *window-display* (parent w) (gcontext w) + left (- (drawable-height w) (bottom + height - 1)) + width height) + (unset w) ) + +; 05 Dec 90; 15 Aug 91 +(gldefun window-prettyprintat ((w window) (s string) (pos vector)) + (printat w s pos) ) + +(gldefun window-prettyprintat-xy ((w window) (s string) (x integer) + (y integer)) + (printat-xy w s x y)) + +; 06 Aug 91; 08 Aug 91; 15 Aug 91 +(gldefun window-printat ((w window) (s string) (pos vector)) + (printat-xy w s (x pos) (y pos)) ) + +; 06 Aug 91; 08 Aug 91; 12 Aug 91 +(gldefun window-printat-xy ((w window) (s string) (x integer) (y integer)) + (let ( (sstr (stringify s)) ) + (XdrawImageString *window-display* (parent w) (gcontext w) + x (- (drawable-height w) y) + (get-c-string sstr) (length sstr)) )) + +; 19 Apr 95; 02 May 95; 17 May 04 +; Print a string that may contain #\Newline characters in a window. +(gldefun window-print-line ((w window) (str string) (x integer) (y integer) + &optional (deltay integer)) + (let ((lng (length str)) (n 0) end strb done) + (while ~done + (end = (position #\Newline str :test #'char= :start n)) + (strb = (subseq str n end)) + (printat-xy w strb x y) + (if (numberp end) + (n = (1+ end)) + (done = t)) + (y _- (or deltay 16)) + (if (y < 0) (done = t))) + (force-output w) )) + +; 02 May 95; 08 May 95 +; Print a list of strings in a window. +(gldefun window-print-lines ((w window) (lines (listof string)) + (x integer) (y integer) + &optional (deltay integer)) + (for str in lines when (y > 0) (printat-xy w str x y) (y _- (or deltay 16))) ) + +; 08 Aug 91 +; Find the width of a string when printed in a given window +(gldefun window-string-width ((w window) (s string)) + (let ((sstr (stringify s))) + (XTextWidth (font w) (get-c-string sstr) (length sstr)) )) + +; 01 Dec 93 +; Find the ascent and descent of a string when printed in a given window +(gldefun window-string-extents ((w window) (s string)) + (let ((sstr (stringify s))) + (XTextExtents (font w) (get-c-string sstr) (length sstr) + *direction-return* *ascent-return* *descent-return* *overall-return*) + (list (int-pos *ascent-return* 0) + (int-pos *descent-return* 0)) )) + +; Find the height (ascent + descent) of a string when printed in a given window +(gldefun window-string-height ((w window) (s string)) + (let ((sstr (stringify s))) + (XTextExtents (font w) (get-c-string sstr) (length sstr) + *direction-return* *ascent-return* *descent-return* *overall-return*) + (+ (int-pos *ascent-return* 0) + (int-pos *descent-return* 0)) )) + +; 15 Oct 91 +(gldefun window-font-string-width (font (s string)) + (let ((sstr (stringify s))) + (XTextWidth font (get-c-string sstr) (length sstr)) )) + +(gldefun window-yposition ((w window)) + (window-get-mouse-position) + (positive-y w (- *mouse-y* (top-neg-y w))) ) + +(gldefun window-centeroffset ((w window) (v vector)) + (a vector with x = (truncate ((width w) - (x v)) 2) + y = (truncate ((height w) - (y v)) 2))) + +; 18 Aug 89; 15 Aug 91 +; Command to a window display manager +(gldefun dowindowcom ((w window)) + (let (comm) + (comm = (select (window-menu)) ) + (case comm + (close (close w)) + (paint (paint w)) + (clear (clear w)) + (move (move w)) + (t (when comm + (princ "This command not implemented.") (terpri))) ) )) + +(gldefun window-menu () + (result menu) + (or *window-menu* + (setq *window-menu* + (a menu with items = '(close paint clear move)))) ) + +; 06 Dec 90; 11 Mar 93 +(gldefun window-close ((w window)) + (unmap w) + (force-output w) + (window-wait-unmap w)) + +(gldefun window-unmap ((w window)) + (XUnMapWindow *window-display* (parent w)) ) + +; 06 Aug 91; 22 Aug 91 +(gldefun window-open ((w window)) + (mapw w) + (force-output w) + (wait-exposure w) ) + +(gldefun window-map ((w window)) + (XMapWindow *window-display* (parent w)) ) + +; 08 Aug 91; 02 Sep 91 +(gldefun window-destroy ((w window)) + (XDestroyWindow *window-display* (parent w)) + (force-output w) + ((parent w) = nil) + (XFreeGC *window-display* (gcontext w)) + ((gcontext w) = nil) ) + +; 09 Sep 91 +; Wait 3 seconds, then destroy the window where the mouse is. Use with care. +(defun window-destroy-selected-window () + (prog (ww child) + (sleep 3) + (setq ww *root-window*) + lp (window-query-pointer-b ww) + (setq child (fixnum-pos *child-return* 0)) ; 22 Jun 06 + (if (> child 0) + (progn (setq ww child) (go lp))) + (if (/= ww *root-window*) + (progn (XDestroyWindow *window-display* ww) + (Xflush *window-display*))) )) + +; 07 Aug 91 +(gldefun window-clear ((w window)) + (XClearWindow *window-display* (parent w)) + (force-output w) ) + +; 08 Aug 91 +(gldefun window-moveto-xy ((w window) (x integer) (y integer)) + (XMoveWindow *window-display* (parent w) + x (- (window-screen-height) y)) ) + +; 15 Aug 91; 05 Sep 91 +; Paint in window with mouse: Left paints, Middle erases, Right quits. +(defun window-paint (window) + (let (state) + (window-track-mouse window + #'(lambda (x y code) + (if (= code 1) (if (= state 1) (setq state 0) (setq state 1)) + (if (= code 2) (if (= state 2) (setq state 0) (setq state 2)))) + (if (= state 1) (window-draw-line-xy window x y x y 1 'paint) + (if (= state 2) (window-draw-line-xy window x y x y 1 'erase))) + (= code 3)) ) )) + +; 15 Aug 91; 06 May 93 +; Move a window. +(gldefun window-move ((w window)) + (window-get-mouse-position) + (XMoveWindow *window-display* (parent w) + *mouse-x* (- (window-screen-height) *mouse-y*)) ) + +; 15 Sep 93; 06 Jan 94 +(gldefun window-draw-border ((w window)) + (draw-box-xy w 0 1 ((x (size w)) - 1) ((y (size w)) - 1)) + (force-output w) ) + +; 13 Aug 91; 22 Aug 91; 27 Aug 91; 14 Oct 91 +; Track the mouse within a window, calling function fn with args (x y event). +; event is 0 = no button, 1 = left button, 2 = middle, 3 = right button. +; Tracking continues until fn returns non-nil; result is that value. +; Partly adapted from Hiep Nguyen's code. +(defun window-track-mouse (w fn &optional outflg) + (let (win h) + (setq win (window-parent w)) + (setq h (window-drawable-height w)) + (Xsync *window-display* 1) ; clear event queue of prev motion events + (Xselectinput *window-display* win + (+ ButtonPressMask PointerMotionMask)) + ;; Event processing loop: stop when function returns non-nil. + (do ((res nil)) (res res) + (XNextEvent *window-display* *window-event*) + (let ((type (XAnyEvent-type *window-event*)) + (eventwindow (XAnyEvent-window *window-event*))) + (when (or (and (eql eventwindow win) + (or (eql type MotionNotify) + (eql type ButtonPress))) + (and outflg (eql type ButtonPress))) + (let ((x (XMotionEvent-x *window-event*)) + (y (XMotionEvent-y *window-event*)) + (code (if (eql type ButtonPress) + (XButtonEvent-button *window-event*) + 0))) + (setq res (if (eql eventwindow win) + (funcall fn x (- h y) code) + (funcall fn -1 -1 code))) ) ) ) ) )) + +; 22 Aug 91; 23 Aug 91; 27 Aug 91; 04 Sep 92; 11 Mar 93 +; Wait for a window to become exposed, but not more than 1 second. +(defun window-wait-exposure (w) + (prog (win start-time max-time eventwindow type) + (setq win (window-parent w)) + (XGetWindowAttributes *window-display* win *window-attr*) + (unless (eql (XWindowAttributes-map_state *window-attr*) + ISUnmapped) + (return t)) + (setq start-time (get-internal-real-time)) + (setq max-time internal-time-units-per-second) + (Xselectinput *window-display* win (+ ExposureMask)) + ; Event processing loop: stop when exposure is seen or time out + lp (cond ((> (XPending *window-display*) 0) + (XNextEvent *window-display* *window-event*) + (setq type (XAnyEvent-type *window-event*)) + (setq eventwindow (XAnyEvent-window *window-event*)) + (if (and (eql eventwindow win) + (eql type Expose)) + (return t))) + ((> (- (get-internal-real-time) start-time) + max-time) + (return nil)) ) + (go lp) )) + +; 11 Mar 93; 06 May 93 +; Wait for a window to become unmapped, but not more than 1 second. +(defun window-wait-unmap (w) + (prog (win start-time max-time) + (setq win (window-parent w)) + (setq start-time (get-internal-real-time)) + (setq max-time internal-time-units-per-second) +lp (XGetWindowAttributes *window-display* win *window-attr*) + (if (eql (XWindowAttributes-map_state *window-attr*) + ISUnmapped) + (return t) + (if (> (- (get-internal-real-time) start-time) max-time) + (return nil))) + (go lp) )) + +; 07 Oct 93 +; Initialize to poll the mouse for a specified window +(defun window-init-mouse-poll (w) + (let (win) + (setq win (window-parent w)) + (Xsync *window-display* 1) ; clear event queue of prev motion events + (Xselectinput *window-display* win + (+ ButtonPressMask PointerMotionMask)) )) + +; 07 Oct 93 +; Poll the mouse for a position change or button push +; Returns nil if no mouse activity, +; else (x y code), where x and y are positions, or nil if no movement, +; and code is 0 if no button else button number +(defun window-poll-mouse (w) + (let (win h eventtype eventwindow x y cd (code 0)) + (setq win (window-parent w)) + (setq h (window-drawable-height w)) + (while (> (XPending *window-display*) 0) + (XNextEvent *window-display* *window-event*) + (setq eventtype (XAnyEvent-type *window-event*)) + (setq eventwindow (XAnyEvent-window *window-event*)) + (if (eql eventwindow win) + (if (eql eventtype MotionNotify) + (progn (setq x (XMotionEvent-x *window-event*)) + (setq y (XMotionEvent-y *window-event*))) + (if (eql eventtype ButtonPress) + (if (> (setq cd (XButtonEvent-button *window-event*)) + 0) + (setq code cd))))) ) + (if (or x (> code 0)) (list x (if y (- h y)) code)) )) + +; 14 Dec 90; 17 Dec 90; 13 Aug 91; 20 Aug 91; 30 Aug 91; 09 Sep 91; 11 Sep 91 +; 15 Oct 91; 16 Oct 91; 10 Feb 92; 25 Sep 92; 26 Sep 92 +; Initialize a menu +(gldefun menu-init ((m menu)) + (let () + (or *window-display* (window-Xinit)) ; init windows if necessary + (calculate-size m) + (if ~ (flat m) + ((menu-window m) = (window-create (picture-width m) + (picture-height m) + ((title m) or "") + (parent-window m) + (parent-offset-x m) + (parent-offset-y m) + (menu-font m) )) ) )) + +; 25 Sep 92; 26 Sep 92; 11 Mar 93; 05 Oct 93; 08 Oct 93; 17 May 04; 12 Jan 10 +; Calculate the displayed size of a menu +(gldefun menu-calculate-size ((m menu)) + (let (maxwidth totalheight nitems) + (or (menu-font m) ((menu-font m) = '9x15)) + (maxwidth = (find-item-width m (title m)) + + (if (or (flat m) *window-add-menu-title*) + 0 + *menu-title-pad*)) + (nitems = (if (and (title-present m) + (or (flat m) *window-add-menu-title*)) + 1 0)) + (totalheight = (* nitems 13)) ; ***** fix for font + (for item in (items m) do + (nitems _+ 1) + (maxwidth = (max maxwidth (find-item-width m item))) + (totalheight =+ (menu-find-item-height m item)) ) + ((item-width m) = maxwidth + 6) + ((picture-width m) = (item-width m) + 1) + ((picture-height m) = totalheight + 2) + (adjust-offset m) )) + +; 06 Sep 91; 09 Sep 91; 10 Sep 91; 21 May 93; 30 May 02; 17 May 04; 08 Sep 06 +; Adjust a menu's offset position if necessary to keep it in parent window. +(gldefun menu-adjust-offset ((m menu)) + (let (xbase ybase wbase hbase xoff yoff wgm width height) + (width = (picture-width m)) + (height = (picture-height m)) + (if ~ (parent-window m) + (progn (window-get-mouse-position) ; put it where the mouse is + (wgm = t) ; set flag that we got mouse position + ((parent-window m) = *root-window*))) ; 21 May 93 was *mouse-window* + (window-get-geometry-b (parent-window m)) + (setq xbase (int-pos *x-return* 0)) + (setq ybase (int-pos *y-return* 0)) + (setq wbase (int-pos *width-return* 0)) + (setq hbase (int-pos *height-return* 0)) + (if (~ (parent-offset-x m) or (parent-offset-x m) == 0) + (progn (or wgm (window-get-mouse-position)) + (xoff = ((*mouse-x* - xbase) - (truncate width 2) - 4)) + (yoff = ((hbase - (*mouse-y* - ybase)) - (truncate height 2)))) + (progn (xoff = (parent-offset-x m)) + (yoff = (parent-offset-y m)))) + ((parent-offset-x m) = (max 0 (min xoff (wbase - width)))) + ((parent-offset-y m) = (max 0 (min yoff (hbase - height)))) )) + +; 07 Dec 90; 14 Dec 90; 12 Aug 91; 22 Aug 91; 09 Sep 91; 10 Sep 91; 28 Jan 92; +; 10 Feb 92; 26 Sep 92; 11 Mar 93; 08 Oct 93; 17 May 04; 12 Jan 10 +(gldefun menu-draw ((m menu)) + (let (mw xzero yzero bottom) + (init? m) + (xzero = (menu-x m 0)) + (yzero = (menu-y m 0)) + (mw = (menu-window m)) + (open mw) + (clear m) + (if (flat m) (draw-box-xy mw (xzero - 1) yzero ((picture-width m) + 2) + ((picture-height m) + 1) 1)) + (bottom = (yzero + (picture-height m) + 3)) + (if (and (title-present m) + (or (flat m) *window-add-menu-title*)) + (progn (bottom _- 15) ; ***** fix for font + (printat-xy mw (stringify (title m)) (+ xzero 3) bottom) + (invert-area-xy mw xzero (bottom - 2) + ((picture-width m) + 1) 15))) + (for item in (items m) do + (bottom _- (menu-find-item-height m item)) + (display-item m item (+ xzero 3) bottom) ) + (force-output mw) )) + +; 17 May 04 +(gldefun menu-item-value (self item) + (if (consp item) (cdr item) item)) + +; 06 Sep 91; 11 Sep 91; 15 Oct 91; 16 Oct 91; 23 Oct 91; 17 May 04 +(gldefun menu-find-item-width ((self menu) item) + (let ((tmp vector)) + (if (and (consp item) + (symbolp (car item)) + (fboundp (car item))) + (or (and (tmp = (get (car item) 'display-size)) + (x tmp)) + 40) + (window-font-string-width + (or (and (flat self) + (menu-window self) + (font (menu-window self))) + (window-font-info (menu-font self))) + (stringify (if (consp item) (car item) item)))) )) + + +; 09 Sep 91; 10 Sep 91; 11 Sep 91; 17 mAY 04 +(gldefun menu-find-item-height ((self menu) item) ; ***** fix for font + (let ((tmp vector)) + (if (and (consp item) + (symbolp (car item)) + (tmp = (get (car item) 'display-size))) + ((y tmp) + 3) + 15) )) + +; 09 Sep 91; 10 Sep 91; 10 Feb 92; 17 May 04 +(gldefun menu-clear ((m menu)) + (if (flat m) + (erase-area-xy (menu-window m) ((base-x m) - 1) ((base-y m) - 1) + ((picture-width m) + 3) ((picture-height m) + 3)) + (clear (menu-window m))) ) + +; 06 Sep 91; 04 Dec 91; 17 May 04 +(gldefun menu-display-item ((self menu) item x y) + (let ((mw (menu-window self))) + (if (consp item) + (if (and (symbolp (car item)) + (fboundp (car item))) + (funcall (car item) mw x y) + (if (or (stringp (car item)) (symbolp (car item)) + (numberp (car item))) + (printat-xy mw (car item) x y) + (printat-xy mw (stringify item) x y))) + (printat-xy mw (stringify item) x y)) )) + +; 07 Dec 90; 18 Dec 90; 15 Aug 91; 27 Aug 91; 06 Sep 91; 10 Sep 91; 29 Sep 92 +; 04 Aug 93; 07 Jan 94; 17 May 04; 18 May 04; 12 Jan 10; 13 Jan 10 +(gldefun menu-choose ((m menu) (inside boolean)) + (let (mw current-item ybase itemh val maxx maxy xzero yzero) + (init? m) + (mw = (menu-window m)) + (draw m) + (xzero = (menu-x m 0)) + (yzero = (menu-y m 0)) + (maxx = (+ xzero (picture-width m))) + (maxy = (+ yzero (picture-height m))) + (if (and (title-present m) + (or (flat m) *window-add-menu-title*)) + (maxy =- 15)) + (track-mouse mw + #'(lambda (x y code) + (setq *window-menu-code* code) + (if (and (>= x xzero) (<= x maxx) ; is mouse in menu area? + (>= y yzero) (<= y maxy)) + (if (or (null current-item) ; is mouse in a new item? + (< y ybase) + (> y (+ ybase itemh)) ) + (progn + (if current-item + (unbox-item m current-item ybase)) + (current-item = (menu-find-item-y m (- y yzero))) + (if current-item + (progn (ybase = (menu-item-y m current-item)) + (itemh = (menu-find-item-height + m current-item)) + (box-item m current-item ybase) + (inside = t))) + (if (> code 0) ; same item: click? + (progn (unbox-item m current-item ybase) + (val = 1)))) + (if (> code 0) ; same item: click? + (progn (unbox-item m current-item ybase) + (val = 1)))) + (progn (if current-item ; mouse outside area + (progn (unbox-item m current-item ybase) + (current-item = nil))) + (if (or (> code 0) + (and inside + (or (< x xzero) (> x maxx) + (< y yzero) (> y maxy)))) + (val = -777))))) + t) + (if (not (eql val -777)) (item-value m current-item)) )) + +; 07 Dec 90; 12 Aug 91; 10 Sep 91; 05 Oct 92; 12 Jan 10 +(gldefun menu-box-item ((m menu) (item menu-item) (ybase integer)) + (let ( (mw (menuw m)) ) + (set-xor mw) + (draw-box-xy mw (menu-x m 1) ((menu-y m ybase) + 2) + ((item-width m) - 2) + (menu-find-item-height m item) + 1) + (unset mw) )) + +; 07 Dec 90; 12 Aug 91; 14 Aug 91; 15 Aug 91; 05 Oct 92; 12 Jan 10 +(gldefun menu-unbox-item ((m menu) (item menu-item) (ybase integer)) + (box-item m item ybase) ) + +; 11 Sep 91; 08 Sep 92; 28 Sep 92; 18 Jan 94; 08 Sep 06; 12 Jan 10; 13 Jan 10 +(gldefun menu-item-position ((m menu) (itemname symbol) + &optional (place symbol)) + (let ( (xsize (item-width m)) ybase item ysize) + (item = (menu-find-item m itemname)) + (ysize = (menu-find-item-height m item)) + (ybase = (menu-item-y m item)) + (a vector with + x = ((menu-x m 0) + + (case place + ((center top bottom) (truncate xsize 2)) + (left -1) + (right xsize + 2) + else 0)) + y = ((menu-y m ybase) + + (case place + ((center right left) (truncate ysize 2)) + (bottom 0) + (top ysize) + else 0)) ) )) + +; 13 Jan 10 +; find the y position of bottom of item with given name +(gldefun menu-find-item ((m menu) (itemname symbol)) + (let (found itms item) + (itms = (items m)) + (found = (null itemname)) + (while (and itms (not found)) + (item -_ itms) + (if (or (eq item itemname) + (and (consp item) + (or (eq itemname (car item)) + (and (stringp (car item)) + (string= (stringify itemname) (car item))) + (eq (cdr item) itemname) + (and (consp (cdr item)) + (eq (cadr item) itemname))))) + (found = t))) + item)) + +; 12 Jan 10 +; find the y position of bottom of a given item +(gldefun menu-item-y ((m menu) (item menu-item)) + (let (found itms itm ybase) + (ybase = (picture-height m) - 1) + (if (and (title-present m) + (or (flat m) *window-add-menu-title*)) + (ybase =- 15)) + (itms = (items m)) + (while (and itms (not found)) + (itm -_ itms) + (ybase =- (menu-find-item-height m itm)) + (found = (eq item itm)) ) + ybase)) + +; 12 Jan 10 +; find item based on y position +(gldefun menu-find-item-y ((m menu) (y integer)) + (let (found itms itm ybase) + (ybase = (picture-height m) - 1) + (if (and (title-present m) + (or (flat m) *window-add-menu-title*)) + (ybase =- 15)) + (itms = (items m)) + (while (and itms (not found)) + (itm -_ itms) + (ybase =- (menu-find-item-height m itm)) + (found = (and (>= y ybase) + (<= y (+ ybase (menu-find-item-height m itm)))))) + (and found itm))) + +; 10 Dec 90; 13 Dec 90; 10 Sep 91; 29 Sep 92; 17 May 04 +; Choose from menu, then close it +(gldefun menu-select ((m menu) &optional inside) (menu-select-b m nil inside)) +(gldefun menu-select! ((m menu)) (menu-select-b m t nil)) +(gldefun menu-select-b ((m menu) (flg boolean) (inside boolean)) + (prog (res) +lp (res = (choose m inside)) + (if (flg and ~res) (go lp)) + (if ~(permanent m) + (if (flat m) + (progn (clear m) + (force-output (menu-window m))) + (close (menu-window m)))) + (return res))) + +; 12 Aug 91; 17 May 04 +(gldefun menu-destroy ((m menu)) + (if ~ (flat m) + (progn (destroy (menu-window m)) + ((menu-window m) = nil) ))) + +; 19 Aug 91; 02 Sep 91 +; Easy interface to make a menu, select from it, and destroy it. +(defun menu (items &optional title) + (let (m res) + (setq m (menu-create items title)) + (setq res (menu-select m)) + (menu-destroy m) + res )) + +; 12 Aug 91; 15 Aug 91; 06 Sep 91; 09 Sep 91; 12 Sep 91; 23 Oct 91; 17 May 04 +; Simple call from plain Lisp to make a menu. +(setf (glfnresulttype 'menu-create) 'menu) +(gldefun menu-create (items &optional title (parentw window) x y + (perm boolean) (flat boolean) (font symbol)) + (a menu with title = (if title (stringify title) "") + menu-window = (if flat parentw) + items = items + parent-window = (parent parentw) + parent-offset-x = x + parent-offset-y = y + permanent = perm + flat = flat + menu-font = font )) + +; 15 Oct 91; 30 Oct 91 +(gldefun menu-offset ((m menu)) + (result vector) + (a vector with x = (base-x m) y = (base-y m))) + +; 15 Oct 91; 30 Oct 91; 25 Sep 92; 29 Sep 92; 18 Apr 95; 25 Jul 96 +(gldefun menu-size ((m menu)) + (result vector) + (if ((picture-width m) <= 0) + (case (first m) + (picmenu (picmenu-calculate-size m)) + (barmenu (barmenu-calculate-size m)) + (textmenu (textmenu-calculate-size m)) + (editmenu (editmenu-calculate-size m)) + (t (menu-calculate-size m)))) + (a vector with x = (picture-width m) y = (picture-height m)) ) + +; 15 Oct 91; 17 May 04 +(gldefun menu-moveto-xy ((m menu) (x integer) (y integer)) + (if (flat m) + (progn ((parent-offset-x m) = x) + ((parent-offset-y m) = y) + (adjust-offset m)) )) + +; 27 Nov 92; 17 May 04 +; Reposition a menu to a position specified by the user by mouse click +(gldefun menu-reposition ((m menu)) + (let (sizev pos) + (if (flat m) + (progn (sizev = (size m)) + (pos = (get-box-position (menu-window m) (x sizev) (y sizev))) + (moveto-xy m (x pos) (y pos)) ) ))) + +; 31 Aug 09 +; Reposition a menu to a position specified by the user by mouse click +(gldefun menu-reposition-line ((m menu) (offset vector) (target vector)) + (let (sizev pos) + (if (flat m) + (progn (sizev = (size m)) + (pos = (get-box-line-position (menu-window m) + (x sizev) (y sizev) (x offset) (y offset) + (x target) (y target))) + (moveto-xy m (x pos) (y pos)) ) ))) + +; 09 Sep 91; 11 Sep 91; 12 Sep 91; 14 Sep 91 +; Simple call from plain Lisp to make a picture menu. +(setf (glfnresulttype 'picmenu-create) 'picmenu) +(gldefun picmenu-create + (buttons (width integer) (height integer) drawfn + &optional title (dotflg boolean) (parentw window) x y (perm boolean) + (flat boolean) (font symbol) (boxflg boolean)) + (picmenu-create-from-spec + (picmenu-create-spec buttons width height drawfn dotflg font) + title parentw x y perm flat boxflg)) + +; 14 Sep 91 +(setf (glfnresulttype 'picmenu-create-spec) 'picmenu-spec) +(gldefun picmenu-create-spec (buttons (width integer) (height integer) drawfn + &optional (dotflg boolean) (font symbol)) + (a picmenu-spec with drawing-width = width + drawing-height = height + buttons = buttons + dotflg = dotflg + drawfn = drawfn + menu-font = (font or '9x15))) + +; 14 Sep 91; 17 May 04 +(setf (glfnresulttype 'picmenu-create-from-spec) 'picmenu) +(gldefun picmenu-create-from-spec + ((spec picmenu-spec) &optional title (parentw window) x y + (perm boolean) (flat boolean) (boxflg boolean)) + (a picmenu with title = (if title (stringify title) "") + menu-window = (if flat parentw) + parent-window = (if parentw (parent parentw)) + parent-offset-x = x + parent-offset-y = y + permanent = perm + flat = flat + spec = spec + boxflg = boxflg +)) + +; 29 Sep 92; 13 Oct 93; 17 May 04 +(gldefun picmenu-calculate-size ((m picmenu)) + (let (maxwidth maxheight) + (maxwidth = (max (if (title m) ((* 9 (length (title m))) + 6) + 0) + (drawing-width m))) + (maxheight = (if (and (title-present m) + (or (flat m) *window-add-menu-title*)) + 15 0) + + (drawing-height m)) + ((picture-width m) = maxwidth) + ((picture-height m) = maxheight) )) + +; 09 Sep 91; 10 Sep 91; 29 Sep 92 +; Initialize a picture menu +(gldefun picmenu-init ((m picmenu)) + (let () + (calculate-size m) + (adjust-offset m) + (if ~ (flat m) + ((menu-window m) = (window-create (picture-width m) + (picture-height m) + ((title m) or "") + (parent-window m) + (parent-offset-x m) + (parent-offset-y m) + (menu-font m) )) ) )) + +; 09 Sep 91; 10 Sep 91; 11 Sep 91; 10 Feb 92; 05 Oct 92; 30 Oct 92; 13 Oct 93 +; 17 May 04 +; Draw a picture menu +(gldefun picmenu-draw ((m picmenu)) + (let (mw bottom xzero yzero) + (init? m) + (mw = (menu-window m)) + (open mw) + (clear m) + (xzero = (menu-x m 0)) + (yzero = (menu-y m 0)) + (bottom = yzero + (picture-height m)) + (if (and (title-present m) + (or (flat m) *window-add-menu-title*)) + (progn (printat-xy mw (stringify (title m)) (xzero + 3) (bottom - 13)) + (invert-area-xy mw xzero (bottom - 15) (picture-width m) 16))) + (funcall (drawfn m) mw xzero yzero) + (if (boxflg m) (draw-box-xy mw xzero yzero + (picture-width m) (picture-height m) 1)) + (if (dotflg m) + (for b in (buttons m) do (draw-button m b)) ) + ((deleted-buttons m) = nil) + (force-output mw) )) + +; 28 Oct 09 +(gldefun picmenu-draw-named-button ((m picmenu) (nm symbol)) + (draw-button m (assoc nm (buttons m)))) + +; 28 Oct 09 +(gldefun picmenu-set-named-button-color ((m picmenu) (nm symbol) (color rgb)) + (let (lst) + (if (lst = (assoc nm (button-colors m))) + ((color lst) = color) + ((button-colors m) +_ (list nm color)) ) )) + +; 05 Oct 92; 28 Oct 09 +(gldefun picmenu-draw-button ((m picmenu) (b picmenu-button)) + (let ((mw (menu-window m)) col) + (set-invert mw) + (draw-box-xy mw ((menu-x m 0) + (x (offset b)) - 2) + ((menu-y m 0) + (y (offset b)) - 2) + 4 4 1) + (unset mw) + (if (setq col (assoc (buttonname b) (button-colors m))) + (progn (window-set-color-rgb mw (red (color col)) (green (color col)) + (blue (color col))) + (draw-box-xy mw ((menu-x m 0) + (x (offset b)) - 1) + ((menu-y m 0) + (y (offset b)) - 1) + 3 3 2) + (window-reset-color mw)) ) )) + +; 05 Oct 92; 30 Oct 92; 17 May 04 +; Delete a button and erase it from the display +(gldefun picmenu-delete-named-button ((m picmenu) (name symbol)) + (let (b) + (if (and (b = (assoc name (buttons m))) + ~ (name <= (deleted-buttons m))) + (progn (if (dotflg m) (draw-button m b)) + ((deleted-buttons m) +_ name) )) + (force-output (menu-window m)) )) + +; 09 Sep 91; 10 Sep 91; 18 Sep 91; 29 Sep 92; 26 Oct 92; 30 Oct 92; 06 May 93 +; 04 Aug 93; 07 Jan 94; 30 May 02; 17 May 04; 18 May 04; 01 Jun 04; 24 Jan 06 +; inside = t if the mouse is already inside the menu area +; anyclick = value to return for a mouse click that is not on a button. +(gldefun picmenu-select ((m picmenu) &optional inside anyclick) + (let (mw (current-button picmenu-button) item items (val picmenu-button) + xzero yzero codeval) + (mw = (menuw m)) + (if ~ (permanent m) (draw m)) + (xzero = (menu-x m 0)) + (yzero = (menu-y m 0)) + (track-mouse mw + #'(lambda (x y code) + (setq *window-menu-code* code) + (x = (x - xzero)) + (y = (y - yzero)) + (if ((x >= 0) and (x <= (picture-width m)) + and (y >= 0) and (y <= (picture-height m))) + (inside = t)) + (if current-button + (if ~ (containsxy? current-button x y) + (progn (unbox-item m current-button) + (current-button = nil)))) + (if ~ current-button + (progn (items = (buttons m)) + (while ~ current-button and (item -_ items) do + (if (and (containsxy? item x y) + (not ((buttonname item) <= + (deleted-buttons m)))) + (progn (box-item m item) + (current-button = item)))))) + (if (or (> code 0) + (and inside (or (x < 0) (x > (picture-width m)) + (y < 0) (y > (picture-height m))))) + (progn (if current-button (unbox-item m current-button)) + (codeval = code) + (val = (if (and (> code 0) current-button) + current-button + *picmenu-no-selection*)) ))) + t) + (if ~(permanent m) + (if (flat m) (progn (clear m) + (force-output (menu-window m))) + (close (menu-window m)))) + (if (val == *picmenu-no-selection*) + (and (> codeval 0) anyclick) + (buttonname val)) )) + + +; 09 Sep 91; 10 Sep 91; 17 May 04; 08 Sep 06 +(gldefun picmenu-box-item ((m picmenu) (item picmenu-button)) + (let ((mw (menuw m)) xoff yoff siz) + (xoff = (menu-x m (x (offset item)))) + (yoff = (menu-y m (y (offset item)))) + (if (highlightfn item) + (funcall (highlightfn item) (menuw m) xoff yoff) + (progn (set-xor mw) + (if (siz = (size item)) + (draw-box-xy mw (xoff - (truncate (x siz) 2)) + (yoff - (truncate (y siz) 2)) + (x siz) (y siz) 1) + (draw-box-xy mw (xoff - 6) (yoff - 6) 12 12 1)) + (unset mw) + (force-output mw) ) ))) + +; 09 Sep 91; 06 May 93; 17 May 04 +(gldefun picmenu-unbox-item ((m picmenu) (item picmenu-button)) + (let ((mw (menuw m))) + (if (unhighlightfn item) + (progn (funcall (unhighlightfn item) (menuw m) + (x (offset item)) (y (offset item))) + (force-output mw)) + (box-item m item) ) )) + +(defun picmenu-destroy (m) (menu-destroy m)) + +; 09 Sep 91; 10 Sep 91; 11 Sep 91; 08 Sep 06 +(gldefun picmenu-button-containsxy? ((b picmenu-button) (x integer) + (y integer)) + (let ((xsize 6) (ysize 6)) + (if (size b) (progn (xsize = (truncate (x (size b)) 2)) + (ysize = (truncate (y (size b)) 2)))) + ((x >= ((x (offset b)) - xsize)) and (x <= ((x (offset b)) + xsize)) and + (y >= ((y (offset b)) - ysize)) and (y <= ((y (offset b)) + ysize)) ) )) + +; 11 Sep 91; 08 Sep 92; 18 Jan 94; 30 May 02; 17 May 04; 24 Jan 06; 08 Sep 06 +(gldefun picmenu-item-position ((m picmenu) (itemname symbol) + &optional (place symbol)) + (let ((b picmenu-button) (xsize 0) (ysize 0) xoff yoff) + (if (null itemname) + (progn (xsize = (picture-width m)) + (ysize = (truncate ((picture-height m) - (drawing-height m)) 2)) + (xoff = (truncate xsize 2)) + (yoff = (drawing-height m) + (truncate ysize 2))) + (if (b = (that (buttons m) with buttonname == itemname)) + (progn (if (size b) + (progn (xsize = (x (size b))) + (ysize = (y (size b))))) + (xoff = (x (offset b))) + (yoff = (y (offset b))) ) )) + (if xoff (a vector with + x = ((menu-x m xoff) + (case place + ((center top bottom) 0) + (left (- (truncate xsize 2))) + (right (truncate xsize 2)) + else 0)) + y = ((menu-y m yoff) + (case place + ((center right left) 0) + (bottom (- (truncate ysize 2))) + (top (truncate ysize 2)) + else 0))) ) )) + +; 03 Jan 94; 18 Jan 94; 17 May 04 +; Simple call from plain Lisp to make a picture menu. +(setf (glfnresulttype 'barmenu-create) 'barmenu) +(gldefun barmenu-create + ((maxval integer) (initval integer) (barwidth integer) + &optional title (horizontal boolean) subtrackfn subtrackparms + (parentw window) x y (perm boolean) (flat boolean) (color rgb)) + (a barmenu with title = (if title (stringify title) "") + menu-window = (if flat parentw) + parent-window = (if parentw (parent parentw)) + parent-offset-x = (or x 0) + parent-offset-y = (or y 0) + permanent = perm + flat = flat + value = initval + maxval = maxval + barwidth = barwidth + horizontal = horizontal + subtrackfn = subtrackfn + subtrackparms = subtrackparms + color = color) ) + +; 03 Jan 94; 17 May 04 +(gldefun barmenu-calculate-size ((m barmenu)) + (let (maxwidth maxheight) + (maxwidth = (max (if (title m) ((* 9 (length (title m))) + 6) + 0) + (barwidth m))) + (maxheight = (if (and (title-present m) + (or (flat m) *window-add-menu-title*)) + 15 0) + + (maxval m)) + ((picture-width m) = maxwidth) + ((picture-height m) = maxheight) )) + +; 03 Jan 94 +; Initialize a picture menu +(gldefun barmenu-init ((m barmenu)) + (let () + (calculate-size m) + (adjust-offset m) + (if ~ (flat m) + ((menu-window m) = (window-create (picture-width m) + (picture-height m) + ((title m) or "") + (parent-window m) + (parent-offset-x m) + (parent-offset-y m) )) ) )) + +; 03 Jan 94; 18 Jan 94; 17 May 04; 18 May 04; 08 Sep 06 +; Draw a picture menu +(gldefun barmenu-draw ((m barmenu)) + (let (mw xzero yzero) + (init? m) + (mw = (menu-window m)) + (open mw) + (clear m) + (xzero = (menu-x m (truncate (picture-width m) 2))) + (yzero = (menu-y m 0)) + (if (color m) (window-set-color mw (color m))) + (if (horizontal m) + (draw-line-xy (menu-window m) xzero yzero + (xzero + (value m)) yzero (barwidth m)) + (draw-line-xy (menu-window m) xzero yzero + xzero (+ yzero (value m)) (barwidth m)) ) + (if (color m) (window-reset-color mw)) + (force-output mw) )) + +; 03 Jan 94; 04 Jan 94; 07 Jan 94; 18 Jan 94; 08 Sep 06 +; inside = t if the mouse is already inside the menu area +(gldefun barmenu-select ((m barmenu) &optional inside) + (let (mw xzero yzero val) + (mw = (menuw m)) + (if ~ (permanent m) (draw m)) + (xzero = (menu-x m (truncate (picture-width m) 2))) + (yzero = (menu-y m 0)) + (when (window-track-mouse-in-region mw (menu-x m 0) yzero + (picture-width m) (picture-height m) t t) + (track-mouse mw + #'(lambda (x y code) + (setq *window-menu-code* code) + (val = (if (horizontal m) (x - xzero) (y - yzero))) + (update-value m val) + (if (> code 0) code) )) + val) )) + +; 03 Jan 93; 17 May 04; 08 Sep 06 +(defvar *barmenu-update-value-cons* (cons nil nil)) ; reusable cons +(gldefun barmenu-update-value ((m barmenu) (val integer)) + (let ((mw (menuw m)) xzero yzero) + (val = (max 0 (min val (maxval m)))) + (if (val <> (value m)) + (progn (if (val < (value m)) + (set-erase mw) + (if (color m) (window-set-color mw (color m)))) + (xzero = (menu-x m (truncate (picture-width m) 2))) + (yzero = (menu-y m 0)) + (if (horizontal m) + (draw-line-xy (menu-window m) + (+ xzero (value m)) yzero + (+ xzero val) yzero (barwidth m)) + (draw-line-xy (menu-window m) + xzero (+ yzero (value m)) + xzero (+ yzero val) (barwidth m)) ) + (if (val < (value m)) + (unset mw) + (if (color m) (window-reset-color mw)) ) + ((value m) = val) + (if (subtrackfn m) + (progn ((car *barmenu-update-value-cons*) = val) + ((cdr *barmenu-update-value-cons*) = (subtrackparms m)) + (apply (subtrackfn m) *barmenu-update-value-cons*))) + (force-output mw) ) ))) + +; Functions for text input "menus". Derived from picmenu code. +; Making text input analogous to menus allows use with menu-sets. + +; 18 Apr 95; 17 May 04 +; (setq tm (textmenu-create 200 30 nil myw 50 50 t t '9x15 t "Rutabagas")) +; Simple call from plain Lisp to make a text menu. +(setf (glfnresulttype 'textmenu-create) 'textmenu) +(gldefun textmenu-create ((width integer) (height integer) + &optional title (parentw window) x y + (perm boolean) (flat boolean) + (font symbol) (boxflg boolean) + (initial-text string)) + (a textmenu with title = (if title (stringify title) "") + menu-window = (if flat parentw) + parent-window = (if parentw (parent parentw)) + parent-offset-x = (or x 0) + parent-offset-y = (or y 0) + permanent = perm + flat = flat + drawing-width = width + drawing-height = height + menu-font = (font or '9x15) + boxflg = boxflg + text = initial-text) ) + +; 18 Apr 95; 17 May 04 +(gldefun textmenu-calculate-size ((m textmenu)) + (let (maxwidth maxheight) + (maxwidth = (max (if (title m) ((* 9 (length (title m))) + 6) + 0) + (drawing-width m))) + (maxheight = (if (and (title-present m) + (or (flat m) *window-add-menu-title*)) + 15 0) + + (drawing-height m)) + ((picture-width m) = maxwidth) + ((picture-height m) = maxheight) )) + +; 18 Apr 95 +; Initialize a picture menu +(gldefun textmenu-init ((m textmenu)) + (let () + (calculate-size m) + (adjust-offset m) + (if ~ (flat m) + ((menu-window m) = + (window-create (picture-width m) (picture-height m) + ((title m) or "") (parent-window m) + (parent-offset-x m) (parent-offset-y m) + (menu-font m) )) ) )) + +; 18 Apr 95; 14 Aug 96; 17 May 04; 08 Sep 06 +; Draw a picture menu +(gldefun textmenu-draw ((m textmenu)) + (let (mw bottom xzero yzero) + (init? m) + (mw = (menu-window m)) + (open mw) + (clear m) + (xzero = (menu-x m 0)) + (yzero = (menu-y m 0)) + (bottom = yzero + (picture-height m)) + (if (and (title-present m) + (or (flat m) *window-add-menu-title*)) + (progn (printat-xy mw (stringify (title m)) (xzero + 3) (bottom - 13)) + (invert-area-xy mw xzero (bottom - 15) (picture-width m) 16))) + (if (text m) + (printat-xy mw (text m) (xzero + 10) + (yzero + (truncate (picture-height m) 2) - 8))) + (if (boxflg m) (draw-box-xy mw xzero yzero + (picture-width m) (picture-height m) 1)) + (force-output mw) )) + +; 18 Apr 95; 20 Apr 95; 21 Apr 95; 14 Aug 96; 17 May 04; 01 Jun 04; 08 Sep 06 +(gldefun textmenu-select ((m textmenu) &optional inside) + (let (mw xzero yzero codeval res) + (mw = (menuw m)) + (if ~ (permanent m) (draw m)) + (xzero = (menu-x m 0)) + (yzero = (menu-y m 0)) + (track-mouse mw + #'(lambda (x y code) + (setq *window-menu-code* code) + (x = (x - xzero)) + (y = (y - yzero)) + (if (or (> code 0) + (or (x < 0) (x > (picture-width m)) + (y < 0) (y > (picture-height m)))) + (codeval = code)) ) + t) + (if (and (not (permanent m)) (not (flat m))) + (close (menu-window m))) + (if (codeval > 0) + (progn (draw m) + (input-string mw (text m) (xzero + 10) + (yzero + (truncate (picture-height m) 2) - 8) + ((picture-width m) - 12)) ) ))) + +(gldefun textmenu-set-text ((m textmenu) &optional (s string)) + ((text m) = (or s ""))) + +; 15 Aug 91 +; Get a point position by mouse click. Returns (x y). +(setf (glfnresulttype 'window-get-point) 'vector) +(defun window-get-point (w) + (let (orgx orgy) + (window-track-mouse w ; get one point + #'(lambda (x y code) + (when (not (zerop code)) + (setq orgx x) + (setq orgy y)))) + (list orgx orgy) )) + +; 23 Aug 91 +; Get a point position by mouse click. Returns (button (x y)). +(setf (glfnresulttype 'window-get-click) + '(list (button integer) (pos vector))) +(defun window-get-click (w) + (let (orgx orgy button) + (window-track-mouse w ; get one point + #'(lambda (x y code) + (when (not (zerop code)) + (setq button code) + (setq orgx x) + (setq orgy y)))) + (list button (list orgx orgy)) )) + +; 13 Aug 91; 06 Aug 91 +; Get a position indicated by a line from a specified origin position. +; Returns (x y) at end of line. +(setf (glfnresulttype 'window-get-line-position) 'vector) +(defun window-get-line-position (w orgx orgy) + (window-get-icon-position w #'window-draw-line-xy (list orgx orgy 1 'paint))) + +; 17 Dec 93 +; Get a position indicated by a line from a specified origin position. +; The visual feedback is restricted to lines that LaTex can draw. +; Returns (x y) at end of line. flg is T for a vector position, nil for line. +(setf (glfnresulttype 'window-get-latex-position) 'vector) +(defun window-get-latex-position (w orgx orgy &optional flg) + (window-get-icon-position w #'window-draw-latex-xy (list orgx orgy flg))) + +; 13 Aug 91; 15 Aug 91; 05 Sep 91 +; Get a position indicated by a box of a specified size. +; (dx dy) is offset of lower-left corner of box from mouse +; Returns (x y) of lower-left corner of box. +(setf (glfnresulttype 'window-get-box-position) 'vector) +(defun window-get-box-position (w width height &optional (dx 0) (dy 0)) + (window-get-icon-position w #'window-draw-box-xy + (list width height 1) dx dy)) + +; 28 Aug 09 +; Get a position indicated by a box and line to a specified point +(setf (glfnresulttype 'window-get-box-line-position) 'vector) +(defun window-get-box-line-position (w width height offx offy tox toy + &optional (dx 0) (dy 0)) + (window-get-icon-position w #'window-draw-box-line-xy + (list width height offx offy tox toy) dx dy)) + +; 01 Sep 09 +(defun window-draw-box-line-xy (w x y width height offx offy tox toy) + (window-draw-box-xy w x y width height) + (window-draw-line-xy w (+ x offx) (+ y offy) tox toy)) + +; 05 Sep 91 +; Get a position indicated by an icon. +; fn is the function to draw the icon: (fn w x y . args) . +; fn must simply draw the icon, not set window parameters. +; (dx dy) is offset of lower-left corner of icon (x y) from mouse. +; Returns (x y) of mouse. +(setf (glfnresulttype 'window-get-icon-position) 'vector) +(defun window-get-icon-position (w fn args &optional (dx 0) (dy 0)) + (let (lastx lasty argl) + (setq argl (cons w (cons 0 (cons 0 args)))) ; arg list for fn + (window-set-xor w) + (window-track-mouse w + #'(lambda (x y code) + (when (or (null lastx) (/= x lastx) (/= y lasty)) + (if lastx (apply fn argl)) ; undraw + (rplaca (cdr argl) (+ x dx)) + (rplaca (cddr argl) (+ y dy)) + (apply fn argl) ; draw + (setq lastx x) + (setq lasty y)) + (not (zerop code)) )) + (apply fn argl) ; undraw + (window-unset w) + (window-force-output w) + (list lastx lasty) )) + +; 13 Aug 91; 06 Sep 91; 06 Nov 91 +; Get a box size and position. +; Click for top right, then click for bottom left, then move it. +; Returns ((x y) (width height)) where (x y) is lower-left corner of box. +(setf (glfnresulttype 'window-get-region) 'region) +(defun window-get-region (w &optional wid ht) + (let (lastx lasty start end width height place offx offy stx sty) + (if (and (numberp wid) (numberp ht)) + (progn (setq start (window-get-box-position w wid ht (- wid) (- ht))) + (setq stx (- (car start) wid)) + (setq sty (- (cadr start) ht)) ) + (progn (setq start (window-get-point w)) + (setq stx (car start)) + (setq sty (cadr start)))) + (setq end (window-get-icon-position w #'window-draw-box-corners + (list stx sty 1))) + (setq lastx (car end)) + (setq lasty (cadr end)) + (setq width (abs (- stx lastx))) + (setq height (abs (- sty lasty))) + (setq offx (- (min stx lastx) lastx)) + (setq offy (- (min sty lasty) lasty)) + (setq place (window-get-box-position w width height offx offy)) + (list (list (+ offx (first place)) + (+ offy (second place))) + (list width height)) )) + +; 27 Nov 91; 10 Sep 92 +; Get box size and echo the size in pixels. Click for top right. +; Returns (width height) of box. +(setf (glfnresulttype 'window-get-box-size) 'vector) +(defun window-get-box-size (w offsetx offsety) + (let (legendy lastx lasty dx dy) + (setq offsety (max offsety 30)) + (setq legendy (- offsety 25)) + (window-erase-area-xy w offsetx legendy 71 21) + (window-draw-box-xy w offsetx legendy 70 20) + (window-track-mouse w + #'(lambda (x y code) + (when (or (null lastx) (/= x lastx) (/= y lasty)) + (if lastx (window-xor-box-xy w offsetx offsety + (- lastx offsetx) + (- lasty offsety))) + (setq lastx nil) + (setq dx (- x offsetx)) + (setq dy (- y offsety)) + (when (and (> dx 0) (> dy 0)) + (window-xor-box-xy w offsetx offsety dx dy) + (window-printat-xy w (format nil "~3D x ~3D" dx dy) + (+ offsetx 3) (+ legendy 5)) + (setq lastx x) + (setq lasty y))) + (not (zerop code)) )) + (if lastx (window-xor-box-xy w offsetx offsety (- lastx offsetx) + (- lasty offsety))) + (window-erase-area-xy w offsetx legendy 71 21) + (window-force-output w) + (list dx dy) )) + +; 29 Oct 91; 30 Oct 91; 04 Jan 94 +; Track mouse until a button is pressed or it leaves specified region. +; Returns (x y code) or nil. boxflg is T to box the region. +(setf (glfnresulttype 'window-track-mouse-in-region) + '(list (code integer) + (position (transparent vector)))) +(defun window-track-mouse-in-region (w offsetx offsety sizex sizey + &optional boxflg inside) + (let (res) + (when boxflg + (window-set-xor w) + (window-draw-box-xy w (- offsetx 4) (- offsety 4) + (+ sizex 8) (+ sizey 8)) + (window-unset w) + (window-force-output w) ) + (setq res (window-track-mouse w + #'(lambda (x y code) + (if (> code 0) + (if inside (list code (list x y)) t) + (if (or (< x offsetx) + (> x (+ offsetx sizex)) + (< y offsety) + (> y (+ offsety sizey))) + inside + (and (setq inside t) nil)))) ) ) + (when boxflg + (window-set-xor w) + (window-draw-box-xy w (- offsetx 4) (- offsety 4) + (+ sizex 8) (+ sizey 8)) + (window-unset w) + (window-force-output w) ) + (if (consp res) res) )) + +; 04 Nov 91 +; Adjust one side of a box by mouse movement. Returns ((x y) (width height)). +(setf (glfnresulttype 'window-adjust-box-side) 'region) +(defun window-adjust-box-side (w orgx orgy width height side) + (let (new (xx orgx) (yy orgy) (ww width) (hh height)) + (setq new (window-get-icon-position w #'window-adj-box-xy + (list orgx orgy width height side))) + (case side (left (setq xx (car new)) + (setq ww (+ width (- orgx (car new))))) + (right (setq ww (- (car new) orgx))) + (top (setq hh (- (cadr new) orgy))) + (bottom (setq yy (cadr new)) + (setq hh (+ height (- orgy (cadr new))))) ) + (list (list xx yy) (list ww hh)) )) + +; 04 Nov 91 +(defun window-adj-box-xy (w x y orgx orgy width height side) + (let ((xx orgx) (yy orgy) (ww width) (hh height)) + (case side (left (setq xx x) (setq ww (+ width (- orgx x)))) + (right (setq ww (- x orgx))) + (top (setq hh (- y orgy))) + (bottom (setq yy y) (setq hh (+ height (- orgy y)))) ) + (window-draw-box-xy w xx yy ww hh) )) + + +; 10 Sep 92 +; Get a circle with a specified center and size. +; center is initial center position, if specified. +; Returns ((x y) radius) +(setf (glfnresulttype 'window-get-circle) + '(list (center vector) (radius integer))) +(defun window-get-circle (w &optional center) + (let (pt) + (or center (setq center (window-get-crosshairs w))) + (setq pt (window-get-icon-position w #'window-draw-circle-pt + (list center))) + (list center (window-circle-radius (car pt) (cadr pt) center)) )) + +; 10 Sep 92 +(defun window-circle-radius (x y center) + (let ((dx (- x (car center))) (dy (- y (cadr center)))) + (truncate (+ 0.5 (sqrt (+ (* dx dx) (* dy dy))))) )) + +; 10 Sep 92 +(defun window-draw-circle-pt (w x y center) + (window-draw-circle w center (window-circle-radius x y center) 1)) + +; 10 Sep 92; 15 Sep 92; 06 Nov 92 +; Get an ellipse with a specified center and sizes. +; center is initial center position, if specified. +; First gets a circle whose radius is x size, then adjusts it. +; Returns ((x y) (radiusx radiusy)) +(setf (glfnresulttype 'window-get-ellipse) + '(list (center vector) (halfsize vector))) +(defun window-get-ellipse (w &optional center) + (let (cir radiusx pt) + (setq cir (window-get-circle w center)) + (setq center (car cir)) + (setq radiusx (cadr cir)) + (setq pt (window-get-icon-position w #'window-draw-ellipse-pt + (list center radiusx))) + (list center (list radiusx (abs (- (cadr pt) (cadr center))))) )) + +; 10 Sep 92 +(defun window-draw-ellipse-pt (w x y center radiusx) + (window-draw-ellipse-xy w (car center) (cadr center) + radiusx (abs (- y (cadr center)))) ) + +; 30 Dec 93 +(defun window-draw-vector-pt (w x y center radius) + (let (dx dy theta) + (setq dy (- y (cadr center))) + (setq dx (- x (car center))) + (when (or (/= dx 0) (/= dy 0)) + (setq theta (atan (- y (cadr center)) (- x (car center)))) + (window-draw-line-xy w (car center) (cadr center) + (+ (car center) (* radius (cos theta))) + (+ (cadr center) (* radius (sin theta))) ) ) )) + +; 30 Dec 93 +(setf (glfnresulttype 'window-get-vector-end) 'vector) +(defun window-get-vector-end (w center radius) + (window-get-icon-position w #'window-draw-vector-pt (list center radius)) ) + +; 12 Sep 92 +(setf (glfnresulttype 'window-get-crosshairs) 'vector) +(defun window-get-crosshairs (w) + (window-get-icon-position w #'window-draw-crosshairs-xy nil) ) + +; 12 Sep 92 +(defun window-draw-crosshairs-xy (w x y) + (window-draw-line-xy w (- x 12) y (- x 3) y) + (window-draw-line-xy w (+ x 3) y (+ x 12) y) + (window-draw-line-xy w x (- y 12) x (- y 3)) + (window-draw-line-xy w x (+ y 3) x (+ y 12)) ) + +; 12 Sep 92 +(setf (glfnresulttype 'window-get-cross) 'vector) +(defun window-get-cross (w) + (window-get-icon-position w #'window-draw-cross-xy nil) ) + +; 12 Sep 92 +(defun window-draw-cross-xy (w x y) + (window-draw-line-xy w (- x 10) (- y 10) (+ x 10) (+ y 10) 2) + (window-draw-line-xy w (+ x 10) (- y 10) (- x 10) (+ y 10) 2) ) + +; 11 Sep 92; 14 Sep 92 +; Draw a dot whose center is at (x y) +(defun window-draw-dot-xy (w x y) + (window-draw-circle-xy w x y 1) + (window-draw-circle-xy w x y 2) + (window-draw-line-xy w x y (+ x 1) y 1) ) + +; 17 Dec 93; 19 Dec 93 +; Draw a line close to the specified coordinates, but restricted to slopes +; that can be drawn by LaTex. flg = T to restrict slopes for vector. +(defun window-draw-latex-xy (w x y orgx orgy flg) + (let (dx dy delx dely n ratio cd nrat) + (setq dx (- x orgx)) + (setq dy (- y orgy)) + (if (or (= dx 0) (= dy 0)) + (window-draw-line-xy w x y orgx orgy) + (progn (setq n (if flg 4 6)) + (if (> (abs dy) (abs dx)) + (progn (setq ratio (round (/ (* (abs dx) n) (abs dy)))) + (setq cd (gcd n ratio)) + (setq n (/ n cd)) + (setq ratio (/ ratio cd)) + (setq nrat (round (/ (abs dy) n))) + (setq dely (* (signum dy) nrat n)) + (setq delx (* (signum dx) nrat ratio)) ) + (progn (setq ratio (round (/ (* (abs dy) n) (abs dx)))) + (setq cd (gcd n ratio)) + (setq n (/ n cd)) + (setq ratio (/ ratio cd)) + (setq nrat (round (/ (abs dx) n))) + (setq delx (* (signum dx) nrat n)) + (setq dely (* (signum dy) nrat ratio)) )) + (window-draw-line-xy w (+ orgx delx) (+ orgy dely) orgx orgy)) ) + )) + +; 31 Dec 93 +; Reset window colors to default foreground and background. +(gldefun window-reset-color ((w window)) + (XSetForeground *window-display* (gcontext w) *default-fg-color*) + (XSetBackground *window-display* (gcontext w) *default-bg-color*) ) + +; 31 Dec 93; 04 Jan 94; 05 Jan 94 +; Set color to be used in a window to specified red/green/blue values. +; Values of r, g, b are integers on scale of 65535. +; Background is t if the background color is to be set, else foreground is set. +; Returns an xcolor. +(defun window-set-color-rgb (w r g b &optional background) + (let (ret) + (or *window-xcolor* (setq *window-xcolor* (Make-Xcolor))) + (set-Xcolor-red *window-xcolor* (+ r 0)) + (set-Xcolor-green *window-xcolor* (+ g 0)) + (set-Xcolor-blue *window-xcolor* (+ b 0)) + (setq ret (XAllocColor *window-display* + *default-colormap* *window-xcolor*)) + (if (not (eql ret 0)) + (window-set-xcolor w *window-xcolor* background)) )) + +; 05 Jan 94 +(defun window-set-xcolor (w &optional xcolor background) + (if background + (window-set-background w (XColor-Pixel xcolor)) + (window-set-foreground w (XColor-Pixel xcolor))) + xcolor) + +; 03 Jan 94 +(defun window-set-color (w rgb &optional background) + (window-set-color-rgb w (first rgb) (second rgb) (third rgb) background) ) + +; 31 Dec 93; 03 Jan 94; 05 Jan 94 +; Free the last xcolor used +(defun window-free-color (w &optional xcolor) + (or xcolor (setq xcolor *window-xcolor*)) + (if xcolor + (unless (or (eql xcolor *default-fg-color*) + (eql xcolor *default-bg-color*)) + (XFreeColors *window-display* + *default-colormap* xcolor 1 0)) ) ) + +; 31 Dec 93; 18 Jul 96; 25 Jul 96 +; Get characters or mouse clicks within a window, calling function fn +; with arguments (char button x y args). +; Tracking continues until fn returns non-nil; result is that value. +(defun window-get-chars (w fn &optional args) + (let (win res) + (or *window-keyinit* (window-init-keymap)) + (setq *window-shift* nil) + (setq *window-ctrl* nil) + (setq *window-meta* nil) + (setq win (window-parent w)) + (Xsync *window-display* 1) ; clear event queue of prev motion events + (Xselectinput *window-display* win + (+ KeyPressMask KeyReleaseMask ButtonPressMask)) + ;; Event processing loop: stop when function returns non-nil. + (while (null res) + (XNextEvent *window-display* *window-event*) + (let ((type (XAnyEvent-type *window-event*)) + (eventwindow (XAnyEvent-window *window-event*))) + (if (eql eventwindow win) + (setq res (window-process-char-event w type fn args))) )) + res)) + +; 31 Dec 93; 18 Jan 94; 04 Oct 94; 18 Jul 96; 19 Jul 96; 22 Jul 96; 23 Jul 96 +; 25 Jul 96; 08 Sep 06 +; Process a character event. type is event type. +; For Control, Shift, and Meta, global flags are set. +; (fn char button x y) is called for other characters. +(defun window-process-char-event (w type fn args) + (let (code) + (if (eql type KeyRelease) + (progn + (setq code (XButtonEvent-button *window-event*)) + (if (member code *window-shift-keys*) + (setq *window-shift* nil) + (if (member code *window-control-keys*) + (setq *window-ctrl* nil) + (if (member code *window-meta-keys*) + (setq *window-meta* nil))))) + (if (eql type KeyPress ) + (progn + (setq code (XButtonEvent-button *window-event*)) + (if (member code *window-shift-keys*) + (progn (setq *window-shift* t) nil) + (if (member code *window-control-keys*) + (progn (setq *window-ctrl* t) nil) + (if (member code *window-meta-keys*) + (progn (setq *window-meta* t) nil) + (funcall fn w (window-char-decode code) 0 0 0 + args) )))) + (if (eql type ButtonPress) + (funcall fn w 0 (XButtonEvent-button *window-event*) + (XMotionEvent-x *window-event*) + (- (window-drawable-height w) + (XMotionEvent-y *window-event*)) + args)) ) ) )) + +; 23 Jul 96; 23 Dec 96 +; Change keyboard code into character; assumes ASCII for control chars +(defun window-char-decode (code) + (let (char) + (setq char (aref (if *window-shift* *window-shiftkeymap* *window-keymap*) + code)) + (if (and char *window-ctrl*) + (setq char (code-char (- (char-code (char-upcase char)) 64)))) + (if (and char *window-meta*) ; simulate meta using 128 + (setq char (code-char (+ (char-code (char-upcase char)) 128)))) + (or char #\Space) )) + +; 31 Dec 93; 04 Oct 94; 16 Nov 94 +; Get character within a window, calling function fn with arg (char). +; Tracking continues until fn returns non-nil; result is that value. +(defun window-get-raw-char (w) + (let (win res) + (or *window-keyinit* (window-init-keymap)) + (setq *window-shift* nil) + (setq *window-ctrl* nil) + (setq *window-meta* nil) + (setq win (window-parent w)) + (Xsync *window-display* 1) ; clear event queue of prev motion events + (Xselectinput *window-display* win + (+ KeyPressMask KeyReleaseMask)) + ;; Event processing loop: stop when function returns non-nil. + (while (null res) + (XNextEvent *window-display* *window-event*) + (let ((type (XAnyEvent-type *window-event*)) + (eventwindow (XAnyEvent-window *window-event*))) + (if (and (eql eventwindow win) + (eql type KeyPress)) + (setq res (XButtonEvent-button *window-event*)) ) )) + res)) + +; 31 Dec 93; 19 Jul 96; 12 Aug 96; 13 Aug 96 +; Input a string from keyboard, echo in window. str is initial string. +; Backspace is handled; terminate with return. Size is max width in pixels. +(defun window-input-string (w str x y &optional size) + (car (window-edit w x y (or size 100) 16 (list (or str "")) nil t t) ) ) + +; 19 Jul 96; 22 Jul 96; 12 Aug 96; 13 Aug 96 +; Edit strings in a window area with Emacs-subset editor +; strings is a list of strings, which is the return value +; scroll is number of lines to scroll down before displaying text, +; or t to have one line only and terminate on return. +; endp is T to begin edit at end of first line +; e.g. (window-draw-box-xy myw 48 48 204 204) +; (window-edit myw 50 50 200 200 '("Now is the time" "for all" "good")) +(gldefun window-edit (w x y width height &optional strings boxflg scroll endp) + (let (em) + (em = (editmenu-create width height nil w x y nil t '9x15 boxflg + strings scroll endp)) + (edit em) + (carat em) ; erase the carat + (text em) )) + +; 25 Jul 96; 26 Jul 96; 12 Aug 96; 13 Aug 96; 15 Aug 96; 17 May 04 +; (setq em (editmenu-create 200 30 nil myw 50 50 t t '9x15 t ("Rutabagas"))) +; Simple call from plain Lisp to make an edit menu. +(setf (glfnresulttype 'editmenu-create) 'editmenu) +(gldefun editmenu-create ((width integer) (height integer) + &optional title (parentw window) x y + (perm boolean) (flat boolean) + (font symbol) (boxflg boolean) + (initial-text (listof string)) + scrollval (endp boolean)) + (an editmenu with title = (if title (stringify title) "") + menu-window = (if flat parentw) + parent-window = (if parentw (parent parentw)) + parent-offset-x = (or x 0) + parent-offset-y = (or y 0) + permanent = perm + flat = flat + drawing-width = width + drawing-height = height + menu-font = (font or '9x15) + boxflg = boxflg + text = (or initial-text (list "")) + scrollval = (or scrollval 0) + line = (if (numberp scrollval) + scrollval + 0) + column = (if endp + (length (car (nthcdr + (if (numberp scrollval) + scrollval + 0) + initial-text))) + 0)) ) + +; 25 Jul 96 +(gldefun editmenu-calculate-size ((m editmenu)) + ((picture-width m) = (drawing-width m)) + ((picture-height m) = (drawing-height m)) ) + +; 18 Apr 95 +; Initialize a picture menu +(gldefun editmenu-init ((m editmenu)) + (let () + (calculate-size m) + (adjust-offset m) + (if ~ (flat m) + ((menu-window m) = + (window-create (picture-width m) (picture-height m) + ((title m) or "") (parent-window m) + (parent-offset-x m) (parent-offset-y m) + (menu-font m) )) ) )) + +; 25 Jul 96; 31 July 96; 14 Aug 96 +(gldefun editmenu-draw ((m editmenu)) + (let (mw xzero yzero) + (init? m) + (mw = (menu-window m)) + (open mw) + (clear m) + (xzero = (menu-x m 0)) + (yzero = (menu-y m 0)) + (if (boxflg m) (draw-box-xy mw xzero yzero + (picture-width m) (picture-height m) 1)) + (display m 0 0 (not (numberp scrollval))) )) + +; 19 Jul 96; 22 Jul 96; 23 Jul 96; 25 Jul 96; 31 July 96; 01 Aug 96; 17 May 04 +; 18 Aug 04; 27 Jan 06 +; Display contents of edit area +; Begin with the specified line and char number; one line only if only is T. +(gldefun editmenu-display ((m editmenu) line char only) + (let (lines y maxwidth linewidth (w (menuw m))) + (setq lines (nthcdr line (text m))) + (setq y (line-y m (- line (scroll m)))) + (setq maxwidth (truncate (- (picture-width m) 6) (font-width (menuw m)))) + (while (and lines (>= y (menu-y m 4))) + (when (< char maxwidth) + (if (> char 0) + (printat-xy w (subseq (first lines) char + (min maxwidth (length (first lines)))) + (menu-x m (+ 2 (* char (font-width (menuw m))))) + y) + (printat-xy w (if (<= (length (first lines)) maxwidth) + (first lines) + (subseq (first lines) 0 maxwidth)) + (menu-x m 2) y))) + (setq linewidth (+ 2 (* (font-width (menuw m)) (length (first lines))))) + (window-erase-area-xy w (menu-x m linewidth) + (- y 2) + (- (picture-width m) (+ linewidth 2)) + (font-height (menuw m))) + (y _- (font-height (menuw m))) + (if only (setq lines nil) + (progn (pop lines) + (if (and (null lines) (>= y (menu-y m 4))) + ; erase an extra line at the end + (window-erase-area-xy w (menu-x m 2) + (- y 2) + (- (picture-width m) 4) + (font-height (menuw m))) ) )) + (setq char 0) ) + (force-output w) )) + +; 19 Jul 96; 22 Jul 96; 25 Jul 96; 31 Jul 96; 01 Aug 96 +; draw/erase carat at the specified position +(gldefun editmenu-carat ((m editmenu)) + (let ((w (menuw m))) + (draw-carat w (menu-x m (+ 2 (* (column m) (font-width (menuw m))))) + (- (line-y m (line m)) 2)) + (force-output w) )) + +; 19 Jul 96; 25 Jul 96; 31 Jul 96; 01 Aug 96; 17 May 04 +; erase at the current position. onep = t to erase only one char +(gldefun editmenu-erase ((m editmenu) onep) + (let ((w (menuw m)) xw) + (xw = (+ 2 (* (font-width w) (column m)))) + (erase-area-xy w (menu-x m xw) + (- (line-y m (line m)) (cadr (string-extents w "Tg"))) + (if onep (font-width w) + (- (picture-width m) xw)) + (font-height w)) + (force-output w) )) + +; 01 Aug 96 +; Calculate the y position of the current line +(gldefun editmenu-line-y ((m editmenu) (line integer)) + (menu-y m (- (picture-height m) + (+ -1 (* (font-height (menuw m)) + (1+ (- line (scroll m))))))) ) + +; 25 Jul 96; 30 Jul 96; 31 Jul 96; 01 Aug 96; 13 Aug 96; 24 Sep 96; 08 Jan 97 +; 17 May 04 +(gldefun editmenu-select ((m editmenu) &optional inside) + (let (mw codeval res xval yval) + (mw = (menuw m)) + (if ~ (permanent m) (draw m)) + (track-mouse mw + #'(lambda (x y code) + (setq *window-menu-code* code) + (if (or (> code 0) + (x < (parent-offset-x m)) + (x > (+ (parent-offset-x m) (picture-width m))) + (y < (parent-offset-y m)) + (y > (+ (parent-offset-y m) (picture-height m)))) + (progn (codeval = code) + (xval = x) + (yval = y)) )) + t) +; (if (and (not (permanent m)) (not (flat m)) (close (menu-window m)))) ; ?? + (if (codeval > 0) + (editmenu-edit m codeval xval yval)) )) + +(defvar *window-editmenu-kill-strings* nil) + +; 13 Aug 96; 15 Aug 96 +; begin active editing of an editmenu. +; (code x y), if present, represent a mouse click in the window. +(gldefun editmenu-edit ((m editmenu) &optional code x y) + (let ((mw (menuw m))) + (draw m) + (carat m) + (if code (editmenu-edit-fn mw nil code x y (list m)) ) + (setq *window-editmenu-kill-strings* nil) + (window-get-chars mw #'editmenu-edit-fn (list m)) + (text m) )) + + +; 31 Dec 93; 18 Jul 96; 19 Jul 96; 22 Jul 96; 23 Jul 96; 25 Jul 96; 26 Jul 96 +; 30 Jul 96; 13 Aug 96; 14 Aug 96; 23 Dec 96; 17 May 04; 18 May 04 +; Process input characters and mouse clicks for editmenu eidting +(gldefun editmenu-edit-fn ((w window) char (button integer) (buttonx integer) + (buttony integer) args) + (let (m\:editmenu inside done) + (m = (car args)) + (carat m) ; erase carat + (if (and (numberp button) + (not (zerop button))) + (progn (inside = (editmenu-setxy m buttonx buttony)) + (case button + (1 (if inside + (progn (carat m) nil) ; return nil to continue input + t)) ; quit on click outside the editing area + (2 (if inside + (progn (editmenu-yank m) + (carat m) + nil)) ))) + (progn (if (< (char-code char) 32) + (case char of + (#\Return (if (numberp (scrollval m)) + (editmenu-return m) + (done = t)) ) + (#\Backspace (editmenu-backspace m)) + (#\^D (editmenu-delete m)) + (#\^N (if (numberp (scrollval m)) + (editmenu-next m))) + (#\^P (editmenu-previous m)) + (#\^F (editmenu-forward m)) + (#\^B (editmenu-backward m)) + (#\^A (editmenu-beginning m)) + (#\^E (editmenu-end m)) + (#\^K (editmenu-kill m)) + (#\^Y (editmenu-yank m)) + else nil) + (if (> (char-code char) 128) + (progn (setq char (code-char + (- (char-code char) 128))) + (case char of + (#\B (editmenu-meta-b m)) + (#\F (editmenu-meta-f m)) + else nil)) + (editmenu-char m char))) + (carat m) + done) ))) ; return nil to continue input + +; 31 Jul 96; 15 Aug 96; 17 May 04 +; Set cursor location based on mouse click; returns T if inside menu region +(gldefun editmenu-setxy ((m editmenu) (buttonx integer) (buttony integer)) + (let (linecons okay) + (setq okay + (and (>= buttonx (parent-offset-x m)) + (<= buttonx (+ (parent-offset-x m) (picture-width m))) + (>= buttony (parent-offset-y m)) + (<= buttony (+ (parent-offset-y m) (picture-height m))) )) + (if okay + (progn ((line m) = (min (1- (length (text m))) + (+ (scroll m) + (truncate (- (menu-y m (- (picture-height m) 6)) + buttony) + (font-height (menuw m)))))) + (linecons = (nthcdr (line m) (text m))) + ((column m) = (min (length (car linecons)) + (truncate (- buttonx (menu-x m 2)) + (font-width (menuw m))))) )) + okay)) + +; 19 Jul 96; 22 Jul 96; 25 Jul 96; 17 May 04 +; Process an ordinary input character +(gldefun editmenu-char ((m editmenu) char) + (let ((linecons (nthcdr (line m) (text m))) ) + (if (<= (length (car linecons)) (column m)) + ((car linecons) = ; insert char at end of line + (concatenate 'string (car linecons) (string char))) + ((car linecons) = ; insert char in middle of line + (concatenate 'string + (subseq (car linecons) 0 (column m)) + (string char) + (subseq (car linecons) (column m)))) ) + (display m (line m) (column m) t) + ((column m) _+ 1) )) + +; 23 Dec 96 +; Get the current character in an editment +(gldefun editmenu-current-char ((m editmenu)) + (let ((linecons (nthcdr (line m) (text m))) ) + (char (car linecons) (column m)) )) + +; 19 Jul 96; 22 Jul 96; 25 Jul 96; 17 May 04 +; Process a Return character +(gldefun editmenu-return ((m editmenu)) + (let ((linecons (nthcdr (line m) (text m)))) + (if (<= (length (car linecons)) (column m)) + ((cdr linecons) = (cons "" (cdr linecons))) ; end of line + (progn ((cdr linecons) = (cons (subseq (car linecons) (column m)) + (cdr linecons))) + ((car linecons) = (subseq (car linecons) 0 (column m))))) + (display m (line m) 0 nil) + ((line m) _+ 1) + ((column m) = 0) )) + +; 19 Jul 96; 22 Jul 96; 25 Jul 96; 30 Jul 96; 31 Jul 96; 17 May 04 +; Process a backspace +(gldefun editmenu-backspace ((m editmenu)) + (let (tmp linedel (linecons (nthcdr (line m) (text m)))) + (if (> (column m) 0) + (progn ((column m) _- 1) ; middle/end of line + ((car linecons) = + (concatenate 'string + (subseq (car linecons) 0 (column m)) + (subseq (car linecons) + (1+ (column m)))))) + (if (> (line m) 0) + (progn ((line m) _- 1) + (linedel = t) + (linecons = (nthcdr (line m) (text m))) + ((column m) = (length (car linecons))) + (tmp = (concatenate 'string (car linecons) + (cadr linecons))) + ((cdr linecons) = (cddr linecons)) + ((car linecons) = tmp) ) )) + (display m (line m) (column m) (not linedel)) )) + +; 23 Jul 96; 25 Jul 96 +; Move cursor to end of line: C-E +(gldefun editmenu-end ((m editmenu)) + (let ((linecons (nthcdr (line m) (text m))) ) + ((column m) = (length (car linecons))) )) + +; 23 Jul 96; 25 Jul 96 +; Move cursor to beginning of line: C-A +(gldefun editmenu-beginning ((m editmenu)) + ((column m) = 0)) + +; 22 Jul 96; 25 Jul 96; 14 Aug 96; 17 May 04 +; Move cursor forward: C-F +(gldefun editmenu-forward ((m editmenu)) + (let ((linecons (nthcdr (line m) (text m)))) + (if (< (column m) (length (car linecons))) + ((column m) _+ 1) + (if (numberp (scrollval m)) + (progn ((line m) _+ 1) + (if (null (cdr linecons)) + ((cdr linecons) = (list ""))) + ((column m) = 0)) ) ))) + +; 23 Dec 96; 17 May 04 +; Move cursor forward over a word: M-F +(gldefun editmenu-meta-f ((m editmenu)) + (let (found done) + (while (and (or (< (line m) (1- (length (text m)))) + (< (column m) (length (nth (line m) (text m))))) + (not found)) + (if (editmenu-alphanumbericp (editmenu-current-char m)) + (found = t) + (editmenu-forward m) ) ) + (if found + (while (and (or (< (line m) (1- (length (text m)))) + (< (column m) (length (nth (line m) (text m))))) + (not done)) + (if (editmenu-alphanumbericp (editmenu-current-char m)) + (editmenu-forward m) + (done = t) )) ) )) + +; 23 Dec 96 +; alphanumbericp not defined in gcl +(defun editmenu-alphanumbericp (x) + (or (alpha-char-p x) (not (null (digit-char-p x)))) ) + +; 22 Jul 96; 25 Jul 96 +; Move cursor to next line: C-N +(gldefun editmenu-next ((m editmenu)) + (let ((linecons (nthcdr (line m) (text m)))) + ((line m)_+ 1) + (if (null (cdr linecons)) + ((cdr linecons) = (list ""))) + (setq linecons (cdr linecons)) + ((column m) = (min (column m) (length (car linecons)))) )) + +; 22 Jul 96; 23 Jul 96; 25 Jul 96; 30 Jul 96; 17 May 04 +; Move cursor backward: C-B +(gldefun editmenu-backward ((m editmenu)) + (if (> (column m) 0) + ((column m) _- 1) + (if (> (line m) 0) + (progn ((line m) _- 1) + ((column m) = (length (nth (line m) (text m)))) ) ) )) + +; 23 Dec 96; 17 May 04 +; Move cursor backward over a word: M-B +(gldefun editmenu-meta-b ((m editmenu)) + (let (found done) + (while (and (or (> (column m) 0) (> (line m) 0)) + (not found)) + (editmenu-backward m) + (if (editmenu-alphanumbericp (editmenu-current-char m)) + (found = t))) + (if found + (progn (while (and (or (> (column m) 0) (> (line m) 0)) + (not done)) + (if (editmenu-alphanumbericp (editmenu-current-char m)) + (editmenu-backward m) + (done = t) )) + (unless (editmenu-alphanumbericp (editmenu-current-char m)) + (editmenu-forward m)) ) ))) + +; 22 Jul 96; 23 Jul 96; 25 Jul 96; 17 May 04 +; Move cursor to previous line: C-P +(gldefun editmenu-previous ((m editmenu)) + (if (> (line m) 0) + (progn ((line m) _- 1) + ((column m) = (min (column m) + (length (nth (line m) (text m)))))))) + +; 23 Jul 96; 25 Jul 96 +; Delete character ahead of cursor: C-D +(gldefun editmenu-delete ((m editmenu)) + (editmenu-forward m) + (editmenu-backspace m)) + +; 31 Jul 96; 17 May 04 +(gldefun editmenu-kill ((m editmenu)) + (let ((linecons (nthcdr (line m) (text m)))) + (if ((column m) < (length (car linecons))) + (progn (setq *window-editmenu-kill-strings* + (list (subseq (car linecons) (column m)))) + ((car linecons) = (subseq (car linecons) 0 (column m))) + (display m (line m) (column m) t)) + (editmenu-delete m) ) )) + +; 31 Jul 96; 01 Aug 96; 17 May 04 +(gldefun editmenu-yank ((m editmenu)) + (let ((linecons (nthcdr (line m) (text m))) (col (column m))) + (when *window-editmenu-kill-strings* + (if (<= (length (car linecons)) (column m)) + (progn ((car linecons) = ; insert at end of line + (concatenate 'string (car linecons) + (car *window-editmenu-kill-strings*))) + ((column m) = (length (car linecons)))) + (progn ((car linecons) = ; insert in middle of line + (concatenate 'string + (subseq (car linecons) 0 col) + (car *window-editmenu-kill-strings*) + (subseq (car linecons) col))) + ((column m) _+ (length (car *window-editmenu-kill-strings*))) )) + (display m (line m) col t) ) )) + +; 31 Dec 93; 19 Jul 96 +; Draw a carat symbol /\ centered at x and with top at y. +(defun window-draw-carat (w x y) + (window-set-xor w) + (window-draw-line-xy w (- x 5) (- y 2) x y) + (window-draw-line-xy w x y (+ x 5) (- y 2)) + (window-unset w) + (window-force-output w) ) + +; 31 Dec 93; 04 Oct 94; 15 Nov 94; 16 Nov 94; 14 Mar 95; 25 Jun 06 +; Initialize mapping between keys and ASCII. +(defun window-init-keymap () + (let (mincode maxcode keycode keysym keynum shiftkeynum char) + ; Get the min and max keycodes for this keyboard + (XDisplayKeycodes *window-display* *min-keycodes-return* + *max-keycodes-return*) + (setq mincode (int-pos *min-keycodes-return* 0)) + (setq maxcode (int-pos *max-keycodes-return* 0)) + (setq *window-keymap* (make-array (1+ maxcode) :initial-element nil)) + (setq *window-shiftkeymap* (make-array (1+ maxcode) :initial-element nil)) + (setq *window-shift-keys* nil) + (setq *window-control-keys* nil) + (setq *window-meta-keys* nil) + ; Get the ASCII corresponding to these keycodes + (dotimes (i (1+ (- maxcode mincode))) + (setq keycode (+ i mincode)) + (setq keysym (XGetKeyboardMapping *window-display* keycode 1 + *keycodes-return*)) + (setq keynum (fixnum-pos keysym 0)) ; ascii integer code + (setq shiftkeynum (fixnum-pos keysym 1)) + ; (XFree keysym) ; ***** commented out -- causes error on Sun + ; Following is a Kludge (TM) for Sun keyboard + (if (and (>= keynum 65) (<= keynum 90) (eql shiftkeynum NoSymbol)) + (progn (setq shiftkeynum keynum) + (setq keynum (+ keynum 32)))) + (if (> keynum 0) + (if (setq char (window-code-char keynum)) + (setf (aref *window-keymap* keycode) char) + (if (> keynum 256) + (cond ((or (eql keynum XK_Shift_R) (eql keynum XK_Shift_L)) + (push keycode *window-shift-keys*)) + ((or (eql keynum XK_Control_L) (eql keynum XK_Control_R)) + (push keycode *window-control-keys*)) + ((or (eql keynum XK_Alt_R) (eql keynum XK_Alt_L)) + (push keycode *window-meta-keys*)))))) + (if (> shiftkeynum 0) + (if (setq char (window-code-char shiftkeynum)) + (setf (aref *window-shiftkeymap* keycode) char) + )) ) + (setq *window-keyinit* t) )) ; signify initialization done + +; 15 Nov 94 +(defun window-code-char (code) + (if (> code 0) + (if (< code 256) + (code-char code) + (cond ((eql code XK_Return) #\Return) + ((eql code XK_Tab) #\Tab) + ((eql code XK_BackSpace) #\Backspace)) ) ) ) + +; 14 Dec 90; 12 Aug 91; 09 Oct 91; 09 Sep 92; 04 Aug 93; 06 Oct 94 +; Compile the dwindow file into a plain Lisp file +(defun compile-dwindow () + (glcompfiles *directory* + '("glisp/vector.lsp") ; auxiliary files + '("X/dwindow.lsp") ; translated files + "X/dwtrans.lsp" ; output file + "X/dwhead.lsp" ; header file + '(glfnresulttype glmacro glispobjects + glispconstants glispglobals compile-dwindow compile-dwindowb)) + (compile-file (concatenate 'string *directory* "X/dwtrans.lsp")) ) + +(defun compile-dwindowb () + (glcompfiles *directory* + '("glisp/vector.lsp") ; auxiliary files + '("X/dwindow.lsp") ; translated files + "X/dwtransb.lsp") ; output file + (compile-file (concatenate 'string *directory* "X/dwtransb.lsp")) ) + +; Note: when compiling dwtrans.lsp, be sure glmacros.lsp is loaded. diff --git a/xgcl-2/gcl_dwsyms.lsp b/xgcl-2/gcl_dwsyms.lsp new file mode 100644 index 0000000..dba3257 --- /dev/null +++ b/xgcl-2/gcl_dwsyms.lsp @@ -0,0 +1,148 @@ +; dwsyms.lsp Gordon S. Novak Jr. 14 Mar 95 + +; Copyright (c) 1995 Gordon S. Novak Jr. and The University of Texas at Austin. + +; See the file gnu.license . + +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 1, or (at your option) +; any later version. + +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +; This file imports symbols from the X library (in XLIB: package) +; to the current package (such as the :USER package). +; This will allow these symbols to be accessed by just their +; names and without any package qualifier. +; This file may be useful if you wish to modify dwindow.lsp or dwtrans.lsp . + +; This file should be loaded immediately after starting Lisp: +; If Lisp has seen any of these symbols, loading this file will cause an error. + +(import '( +xlib::BUTTONPRESS +xlib::BUTTONPRESSMASK +xlib::BUTTONRELEASEMASK +xlib::CAPBUTT +xlib::CWBACKINGSTORE +xlib::CWSAVEUNDER +xlib::EXPOSE +xlib::EXPOSUREMASK +xlib::GCBACKGROUND +xlib::GCFOREGROUND +xlib::GCFUNCTION +xlib::GET-C-STRING +xlib::GXCOPY +xlib::GXXOR +xlib::INT-ARRAY +xlib::INT-POS +xlib::ISUNMAPPED +xlib::JOINMITER +xlib::KEYPRESS +xlib::KEYPRESSMASK +xlib::KEYRELEASE +xlib::KEYRELEASEMASK +xlib::LEAVEWINDOWMASK +xlib::LINESOLID +xlib::MAKE-XCOLOR +xlib::MAKE-XEVENT +xlib::MAKE-XGCVALUES +xlib::MAKE-XSETWINDOWATTRIBUTES +xlib::MAKE-XSIZEHINTS +xlib::MAKE-XWINDOWATTRIBUTES +xlib::MOTIONNOTIFY +xlib::NONE +xlib::NoSymbol +xlib::POINTERMOTIONMASK +xlib::PPOSITION +xlib::PSIZE +xlib::SET-XCOLOR-BLUE +xlib::SET-XCOLOR-GREEN +xlib::SET-XCOLOR-RED +xlib::SET-XSETWINDOWATTRIBUTES-BACKING_STORE +xlib::SET-XSETWINDOWATTRIBUTES-SAVE_UNDER +xlib::SET-XSIZEHINTS-HEIGHT +xlib::SET-XSIZEHINTS-FLAGS +xlib::SET-XSIZEHINTS-WIDTH +xlib::SET-XSIZEHINTS-X +xlib::SET-XSIZEHINTS-Y +xlib::WHENMAPPED +xlib::XALLOCCOLOR +xlib::XANYEVENT-TYPE +xlib::XANYEVENT-WINDOW +xlib::XBLACKPIXEL +xlib::XBUTTONEVENT-BUTTON +xlib::XCHANGEWINDOWATTRIBUTES +xlib::XCLEARAREA +xlib::XCLEARWINDOW +xlib::XCOLOR-PIXEL +xlib::XCOPYAREA +xlib::XCREATEFONTCURSOR +xlib::XCREATEGC +xlib::XCREATESIMPLEWINDOW +xlib::XDEFAULTCOLORMAP +xlib::XDEFAULTGC +xlib::XDEFAULTSCREEN +xlib::XDEFINECURSOR +xlib::XDESTROYWINDOW +xlib::XDRAWARC +xlib::XDRAWIMAGESTRING +xlib::XDRAWLINE +xlib::XFILLRECTANGLE +xlib::XFONTSTRUCT-FID +xlib::XFLUSH +xlib::XFREECOLORS +xlib::XFREEGC +xlib::XGCVALUES-BACKGROUND +xlib::XGCVALUES-FOREGROUND +xlib::XGCVALUES-FUNCTION +xlib::XGETGCVALUES +xlib::XGETGEOMETRY +xlib::XGETWINDOWATTRIBUTES +xlib::XLOADQUERYFONT +xlib::XMAPWINDOW +xlib::XMOTIONEVENT-X +xlib::XMOTIONEVENT-Y +xlib::XMOVEWINDOW +xlib::XNEXTEVENT +xlib::XOPENDISPLAY +xlib::XPENDING +xlib::XQUERYPOINTER +xlib::XRECOLORCURSOR +xlib::XROOTWINDOW +xlib::XSELECTINPUT +xlib::XSETBACKGROUND +xlib::XSETFONT +xlib::XSETFOREGROUND +xlib::XSETFUNCTION +xlib::XSETLINEATTRIBUTES +xlib::XSETSTANDARDPROPERTIES +xlib::XSYNC +xlib::XTEXTEXTENTS +xlib::XTEXTWIDTH +xlib::XUNMAPWINDOW +xlib::XWHITEPIXEL +xlib::XWINDOWATTRIBUTES-MAP_STATE +xlib::XDisplayKeycodes +xlib::XGetKeyboardMapping +xlib::XFree +xlib::XK_Shift_R +xlib::XK_Shift_L +xlib::XK_Control_L +xlib::XK_Control_R +xlib::XK_Alt_R +xlib::XK_Alt_L +xlib::XK_Return +xlib::XK_Tab +xlib::XK_BackSpace +)) + +(setf (get 'xlib::int-pos 'glfnresulttype) 'integer) diff --git a/xgcl-2/gcl_dwtest.lsp b/xgcl-2/gcl_dwtest.lsp new file mode 100644 index 0000000..340961e --- /dev/null +++ b/xgcl-2/gcl_dwtest.lsp @@ -0,0 +1,192 @@ +; dwtest.lsp Gordon S. Novak Jr. 10 Jan 96 + +; Some examples for testing the window interface in dwindow.lsp / dwtrans.lsp + +; Copyright (c) 1996 Gordon S. Novak Jr. and The University of Texas at Austin. + +; See the file gnu.license . + +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 1, or (at your option) +; any later version. + +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +; Written by: Gordon S. Novak Jr., Department of Computer Sciences, +; University of Texas at Austin 78712. novak@cs.utexas.edu + +(use-package :xlib) +(defun user::xgcl-demo nil + (wtesta) + (wtestb) + (format t "Try (wtestc) ... (wtestk) for more examples.")) + +(defmacro while (test &rest forms) + `(loop (unless ,test (return)) ,@forms) ) + +(defvar *myw*) ; my window +(defvar myw) + +; Make a window to play in. +(defun wtesta () + (setq myw (setq *myw* (window-create 300 300 "test window"))) ) + +; 15 Aug 91; 12 Sep 91; 05 Oct 94; 06 Oct 94 +; Draw some basic things in the window +(defun wtestb () + (window-clear *myw*) + (window-draw-box-xy *myw* 50 50 50 20 1) + (window-printat *myw* "howdy" '(58 55)) + (window-draw-line *myw* '(100 70) '(200 170)) + (window-draw-arrow-xy *myw* 200 170 165 205) + (window-draw-circle-xy *myw* 200 170 50 2) + (window-draw-ellipse-xy *myw* 100 170 40 20 1) + (window-printat-xy *myw* "ellipse" 70 165) + (window-draw-arc-xy *myw* 100 250 20 20 0 90 1) + (window-draw-arc-xy *myw* 100 250 20 20 0 -90 1) + (window-printat-xy *myw* "arcs" 80 244) + (window-printat-xy *myw* "invert" 54 200) + (window-invert-area-xy *myw* 50 160 60 60) + (window-copy-area-xy *myw* 40 150 200 50 60 40) + (window-printat-xy *myw* "copy" 210 100) + (window-set-color-rgb *myw* 65535 0 0) ; red foreground + (window-printat-xy *myw* "Red" 20 20) + (window-draw-rcbox-xy *myw* 15 15 32 20 5) + (window-set-color-rgb *myw* 0 0 65535 t) ; blue background + (window-set-color-rgb *myw* 0 65535 0) ; green foreground + (window-printat-xy *myw* "Green" 120 20) + (window-set-color-rgb *myw* 0 65535 0 t) ; green background + (window-set-color-rgb *myw* 0 0 65535) ; blue foreground + (window-printat-xy *myw* "Blue" 220 20) + (window-reset-color *myw*) + (window-force-output *myw*) ) + +; 15 Aug 91; 19 Aug 91; 03 Sep 91; 21 Apr 95 +; Illustrate mouse interaction: +; click in window *myw* (2 times for line, 3 times for region). +(defun wtestc () + (let (mymenu result start done) + (setq mymenu (menu-create '(quit point line box region) "Choose One:")) + (while (not done) + (setq result + (case (menu-select mymenu) + (quit (setq done t)) + (point (window-get-point *myw*)) + (line (setq start (window-get-point *myw*)) + (list start + (window-get-line-position *myw* (car start) + (cadr start)))) + (box (window-get-box-position *myw* 40 20)) + (region (window-get-region *myw*)) )) + (format t "Result: ~A~%" result) ) + (menu-destroy mymenu) )) + +; 09 Sep 91 +; Illustrate icons in menus +(defun wtestd () + (menu '(("Triangle" . triangle) + (dwtest-square . square) + (dwtest-circle . circle) + hexagon) + "Icons in Menu") ) + +(defun dwtest-square (w x y) (window-draw-box-xy w x y 20 20 1)) +(setf (get 'dwtest-square 'display-size) '(20 20)) + +(defun dwtest-circle (w x y) (window-draw-circle-xy w (+ x 10) (+ y 10) 10 1)) +(setf (get 'dwtest-circle 'display-size) '(20 20)) + +(defvar mypms nil) +; 09 Sep 91; 11 Sep 91; 12 Sep 91; 14 Sep 91 +; Illustrate a diagrammatic menu-like object: square with sensitive spots +(defun wteste () + (let (pm val) + (or mypms (mypms-init)) + (setq pm (picmenu-create-from-spec mypms "Points on Square")) + (setq val (picmenu-select pm)) + (picmenu-destroy pm) + val )) + +; 14 Sep 91 +(defun mypms-init () + (setq mypms (picmenu-create-spec + '((bottom-left ( 20 20)) + (center-left ( 20 70)) + (top-left ( 20 120)) + (bottom-center ( 70 20)) + (center ( 70 70) (20 20)) ; larger + (top-center ( 70 120)) + (bottom-right (120 20)) + (center-right (120 70)) + (top-right (120 120))) + 140 140 'wteste-draw-square t)) ) + +(defvar mypm nil) +; 10 Sep 91; 11 Sep 91; 12 Sep 91; 14 Sep 91; 17 Sep 91 +; A picmenu that is "flat" within another window, in this case *myw*. +; Must do (wtesta) first. +(defun wtestf () + (or mypms (mypms-init)) + (or mypm (setq mypm (picmenu-create-from-spec mypms "Points on Square" + *myw* 50 50 nil t t))) + (picmenu-select mypm)) + +(defun wteste-draw-square (w x y) + (window-draw-box-xy w (+ x 20) (+ y 20) 100 100 1)) + +(defvar mym nil) +; 10 Sep 91; 17 Sep 91 +; A menu that is "flat" within another window, in this case *myw*. +; Must do (wtesta) first. +(defun wtestg () + (or mym (setq mym (menu-create '(red white blue) "Flag" *myw* 50 50 nil t))) + (menu-select mym)) + +; 09 Oct 91 +; Demonstrate arrows. Optional arg is line width. +(defun wtesth ( &optional (lw 1)) + (window-clear *myw*) + (dotimes (i 5) (window-draw-arrow-xy *myw* 100 100 (+ 40 (* i 30)) 160 lw)) + (dotimes (i 5) (window-draw-arrow-xy *myw* 100 100 (+ 40 (* i 30)) 40 lw)) + (dotimes (i 5) (window-draw-arrow-xy *myw* 100 100 40 (+ 40 (* i 30)) lw)) + (dotimes (i 5) (window-draw-arrow-xy *myw* 100 100 160 (+ 40 (* i 30)) lw)) + (dotimes (i 5) (window-draw-arrow-xy *myw* 200 (+ 40 (* i 30)) + 240 (+ 40 (* i 30)) + (1+ i) )) + (window-force-output *myw*) ) + +; 04 Jan 94 +; Redo some of the arrows from wtesth in color +(defun wtesti () + (window-set-color-rgb *myw* 65535 0 0) + (window-draw-arrow-xy *myw* 200 70 240 70 2) + (window-set-color-rgb *myw* 0 65535 0) + (window-draw-arrow-xy *myw* 200 100 240 100 3) + (window-set-color-rgb *myw* 0 0 65535) + (window-draw-arrow-xy *myw* 200 130 240 130 4) + (window-reset-color *myw*) + (window-force-output *myw*) ) + +; 04 Jan 94 +; Get text from a window. Move mouse pointer into test window. +; Add characters and/or backspace, Return. +; Note: it might be necessary to change the keyboard mapping, using +; (window-init-keyboard-mapping *myw*) and (window-print-keyboard-mapping) +(defun wtestj () (window-input-string *myw* "Foo" 50 200 200)) + +; 04 Jan 94 +; Change foreground and background colors and input a string +(defun wtestk () + (window-set-color-rgb *myw* 0 65535 0) ; green foreground + (window-set-color-rgb *myw* 0 0 65535 t) ; blue background + (prog1 (window-input-string *myw* "Foo" 50 200 200) + (window-reset-color *myw*) + (window-force-output *myw*) ) ) diff --git a/xgcl-2/gcl_dwtestcases.lsp b/xgcl-2/gcl_dwtestcases.lsp new file mode 100644 index 0000000..ca2cc1a --- /dev/null +++ b/xgcl-2/gcl_dwtestcases.lsp @@ -0,0 +1,32 @@ +(load "/stage/ftp/pub/novak/xgcl-4/gcl_dwtrans.lsp") +(use-package 'xlib) +(load "/stage/ftp/pub/novak/xgcl-4/gcl_drawtrans.lsp") +(load "/stage/ftp/pub/novak/xgcl-4/gcl_editorstrans.lsp") +(load "/stage/ftp/pub/novak/xgcl-4/gcl_lispservertrans.lsp") +(load "/stage/ftp/pub/novak/xgcl-4/gcl_menu-settrans.lsp") +(load "/stage/ftp/pub/novak/xgcl-4/gcl_dwtest.lsp") +(load "/stage/ftp/pub/novak/xgcl-4/gcl_draw-gates.lsp") + +(wtesta) +(wtestb) +(wtestc) +(wtestd) +(wteste) +(wtestf) +(wtestg) +(wtesth) +(wtesti) +(wtestj) +(wtestk) + +(window-clear myw) +(edit-color myw) + +(lisp-server) + +(draw 'foo) + +(window-draw-box-xy myw 48 48 204 204) +(window-edit myw 50 50 200 200 '("Now is the time" "for all" "good")) + +(draw-nand myw 50 50) diff --git a/xgcl-2/gcl_dwtrans.lsp b/xgcl-2/gcl_dwtrans.lsp new file mode 100644 index 0000000..1e96ca4 --- /dev/null +++ b/xgcl-2/gcl_dwtrans.lsp @@ -0,0 +1,2894 @@ +; 13 Jan 2010 17:40:33 EST +; dwtrans.lsp -- translation of dwindow.lsp ; 07 Jan 10 + +; Copyright (c) 2010 Gordon S. Novak Jr. and The University of Texas at Austin. + +; See the files gnu.license and dec.copyright . + +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 2 of the License, or +; (at your option) any later version. + +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + +; Some of the files that interface to the Xlib are adapted from DEC/MIT files. +; See the file dec.copyright for details. + +; Written by: Gordon S. Novak Jr., Department of Computer Sciences, +; University of Texas at Austin 78712. novak@cs.utexas.edu + + +(in-package :xlib) + +(defmacro while (test &rest forms) `(loop (unless ,test (return)) ,@forms) ) + +(setf (get 'xlib::int-pos 'user::glfnresulttype) 'lisp::integer) +(setf (get 'xlib::fixnum-pos 'user::glfnresulttype) 'lisp::integer) + +; exported symbols: from dwimports.lsp +(dolist (x '( menu stringify window picmenu textmenu editmenu barmenu + display-size + window-get-mouse-position window-create window-set-font + window-font-info window-gcontext window-parent + window-drawable-height window-drawable-width window-label + window-font window-foreground window-set-foreground + window-background window-set-background window-wfunction + window-get-geometry window-get-geometry-b window-sync + window-screen-height window-geometry window-size + window-left window-top-neg-y window-reset-geometry + window-force-output window-query-pointer window-set-xor + window-unset window-reset window-set-erase + window-set-copy window-set-invert window-set-line-width + window-set-line-attr window-std-line-attr window-draw-line + window-draw-line-xy window-draw-arrowhead-xy + window-draw-arrow-xy window-draw-arrow2-xy window-draw-box + window-draw-box-xy window-xor-box-xy window-draw-box-corners + window-draw-rcbox-xy window-draw-arc-xy + window-draw-circle-xy window-draw-circle window-erase-area + window-erase-area-xy window-erase-box-xy + window-draw-ellipse-xy window-copy-area-xy window-invertarea + window-invert-area window-invert-area-xy + window-prettyprintat window-prettyprintat-xy window-printat + window-printat-xy window-string-width window-string-height + window-string-extents window-font-string-width + window-yposition window-centeroffset dowindowcom + window-menu window-close window-unmap window-open + window-map window-destroy window-destroy-selected-window + window-clear window-moveto-xy window-paint + window-move window-draw-border window-track-mouse + window-wait-exposure window-wait-unmap + window-init-mouse-poll window-poll-mouse menu-init + menu-calculate-size menu-adjust-offset menu-draw + menu-item-value menu-find-item-width menu-find-item-height + menu-clear menu-display-item menu-choose menu-box-item + menu-unbox-item menu-item-position menu-select + menu-select! menu-select-b menu-destroy + menu-create menu-offset menu-size menu-moveto-xy + menu-reposition picmenu-create picmenu-create-spec + picmenu-create-from-spec picmenu-calculate-size picmenu-init + picmenu-draw picmenu-draw-button picmenu-delete-named-button + picmenu-select picmenu-box-item picmenu-unbox-item + picmenu-destroy picmenu-button-containsxy? + picmenu-item-position barmenu-create + barmenu-calculate-size barmenu-init barmenu-draw + barmenu-select barmenu-update-value window-get-point + window-get-click window-get-line-position + window-get-latex-position window-get-box-position + window-get-icon-position window-get-region + window-get-box-size window-track-mouse-in-region + window-adjust-box-side window-adj-box-xy window-get-circle + window-circle-radius window-draw-circle-pt + window-get-ellipse window-draw-ellipse-pt + window-draw-vector-pt window-get-vector-end + window-get-crosshairs window-draw-crosshairs-xy + window-get-cross window-draw-cross-xy window-draw-dot-xy + window-draw-latex-xy window-reset-color + window-set-color-rgb window-set-xcolor window-set-color + window-set-color window-free-color window-get-chars + window-process-char-event window-input-string + window-input-char-fn window-draw-carat window-init-keymap + window-set-cursor window-positive-y window-code-char + window-get-raw-char + window-print-line window-print-lines textmenu-create + textmenu-calculate-size textmenu-init textmenu-draw + textmenu-select textmenu-set-text textmenu + editmenu editmenu-create editmenu-calculate-size + editmenu-init editmenu-draw editmenu-display + window-edit + window-edit-display editmenu-carat editmenu-erase + window-edit-erase editmenu-select editmenu-edit-fn + window-edit-fn editmenu-setxy editmenu-char + editmenu-edit + *window-editmenu-kill-strings* +*window-add-menu-title* +*window-menu* +*mouse-x* +*mouse-y* +*mouse-window* +*window-fonts* +*window-display* +*window-screen* +*root-window* +*black-pixel* +*white-pixel* +*default-fg-color* +*default-bg-color* +*default-size-hints* +*default-GC* +*default-colormap* +*window-event* +*window-default-pos-x* +*window-default-pos-y* +*window-default-border* +*window-default-font-name* +*window-default-cursor* +*window-save-foreground* +*window-save-function* +*window-attributes* +*window-attr* +*menu-title-pad* +*root-return* +*child-return* +*root-x-return* +*root-y-return* +*win-x-return* +*win-y-return* +*mask-return* +*x-return* +*y-return* +*width-return* +*height-return* +*depth-return* +*border-width-return* +*text-width-return* +*direction-return* +*ascent-return* +*descent-return* +*overall-return* +*GC-Values* +*window-xcolor* +*window-menu-code* + +*window-keymap* +*window-shiftkeymap* +*window-keyinit* +*window-meta* +*window-ctrl* +*window-shift* +*window-string* +*window-string-count* +*window-string-max* +*window-input-string-x* +*window-input-string-y* +*window-input-string-charwidth* + +*window-shift-keys* +*window-control-keys* +*window-meta-keys* +*barmenu-update-value-cons* +*picmenu-no-selection* +*min-keycodes-return* +*max-keycodes-return* +*keycodes-return* + )) + (export x)) ; export the above symbols + +(DEFVAR *WINDOW-ADD-MENU-TITLE* NIL) + +(DEFVAR *WINDOW-MENU* NIL) + +(DEFVAR *MOUSE-X* NIL) + +(DEFVAR *MOUSE-Y* NIL) + +(DEFVAR *MOUSE-WINDOW* NIL) + +(DEFVAR *WINDOW-FONTS* + (LIST (LIST 'COURIER-BOLD-12 + "*-*-courier-bold-r-*-*-12-*-*-*-*-*-iso8859-1") + (LIST 'COURIER-MEDIUM-12 + "*-*-courier-medium-r-*-*-12-*-*-*-*-*-iso8859-1") + (LIST '6X12 "6x12") (LIST '8X13 "8x13") + (LIST '9X15 "9x15"))) + + + +(DEFVAR *WINDOW-DISPLAY* NIL) + +(DEFVAR *WINDOW-SCREEN* NIL) + +(DEFVAR *ROOT-WINDOW*) + +(DEFVAR *BLACK-PIXEL*) + +(DEFVAR *WHITE-PIXEL*) + +(DEFVAR *DEFAULT-FG-COLOR*) + +(DEFVAR *DEFAULT-BG-COLOR*) + +(DEFVAR *DEFAULT-SIZE-HINTS*) + +(DEFVAR *DEFAULT-GC*) + +(DEFVAR *DEFAULT-COLORMAP*) + +(DEFVAR *WINDOW-EVENT*) + +(DEFVAR *WINDOW-DEFAULT-POS-X* 10) + +(DEFVAR *WINDOW-DEFAULT-POS-Y* 20) + +(DEFVAR *WINDOW-DEFAULT-BORDER* 1) + +(DEFVAR *WINDOW-DEFAULT-FONT-NAME* 'COURIER-BOLD-12) + +(DEFVAR *WINDOW-DEFAULT-CURSOR* 68) + +(DEFVAR *WINDOW-SAVE-FOREGROUND*) + +(DEFVAR *WINDOW-SAVE-FUNCTION*) + +(DEFVAR *WINDOW-ATTRIBUTES*) + +(DEFVAR *WINDOW-ATTR*) + +(DEFVAR *MENU-TITLE-PAD* 30) + +(DEFVAR *ROOT-RETURN* (FIXNUM-ARRAY 1)) + +(DEFVAR *CHILD-RETURN* (FIXNUM-ARRAY 1)) + +(DEFVAR *ROOT-X-RETURN* (INT-ARRAY 1)) + +(DEFVAR *ROOT-Y-RETURN* (INT-ARRAY 1)) + +(DEFVAR *WIN-X-RETURN* (INT-ARRAY 1)) + +(DEFVAR *WIN-Y-RETURN* (INT-ARRAY 1)) + +(DEFVAR *MASK-RETURN* (INT-ARRAY 1)) + +(DEFVAR *X-RETURN* (INT-ARRAY 1)) + +(DEFVAR *Y-RETURN* (INT-ARRAY 1)) + +(DEFVAR *WIDTH-RETURN* (INT-ARRAY 1)) + +(DEFVAR *HEIGHT-RETURN* (INT-ARRAY 1)) + +(DEFVAR *DEPTH-RETURN* (INT-ARRAY 1)) + +(DEFVAR *BORDER-WIDTH-RETURN* (INT-ARRAY 1)) + +(DEFVAR *TEXT-WIDTH-RETURN* (INT-ARRAY 1)) + +(DEFVAR *DIRECTION-RETURN* (INT-ARRAY 1)) + +(DEFVAR *ASCENT-RETURN* (INT-ARRAY 1)) + +(DEFVAR *DESCENT-RETURN* (INT-ARRAY 1)) + +(DEFVAR *OVERALL-RETURN* (INT-ARRAY 1)) + +(DEFVAR *GC-VALUES*) + +(DEFVAR *WINDOW-XCOLOR* NIL) + +(DEFVAR *WINDOW-MENU-CODE* NIL) + +(DEFVAR *WINDOW-KEYMAP* (MAKE-ARRAY 256)) + +(DEFVAR *WINDOW-SHIFTKEYMAP* (MAKE-ARRAY 256)) + +(DEFVAR *WINDOW-KEYINIT* NIL) + +(DEFVAR *WINDOW-META*) + +(DEFVAR *WINDOW-CTRL*) + +(DEFVAR *WINDOW-SHIFT*) + +(DEFVAR *WINDOW-SHIFT-KEYS* NIL) + +(DEFVAR *WINDOW-CONTROL-KEYS* NIL) + +(DEFVAR *WINDOW-META-KEYS* NIL) + +(DEFVAR *MIN-KEYCODES-RETURN* (INT-ARRAY 1)) + +(DEFVAR *MAX-KEYCODES-RETURN* (INT-ARRAY 1)) + +(DEFVAR *KEYCODES-RETURN* (INT-ARRAY 1)) + +(SETQ *WINDOW-KEYINIT* NIL) + +(DEFMACRO PICMENU-SPEC (SYMBOL) (LIST 'GET SYMBOL ''PICMENU-SPEC)) + + + + + +(DEFVAR *PICMENU-NO-SELECTION* '(NO-SELECTION (0 0) (0 0) NIL NIL)) + +(DEFUN STRINGIFY (X) + (COND + ((STRINGP X) X) + ((SYMBOLP X) (COPY-SEQ (SYMBOL-NAME X))) + (T (PRINC-TO-STRING X)))) + +(DEFUN WINDOW-XINIT () + (SETQ *WINDOW-DISPLAY* (XOPENDISPLAY (GET-C-STRING ""))) + (IF (OR (NOT (NUMBERP *WINDOW-DISPLAY*)) (< *WINDOW-DISPLAY* 10000)) + (ERROR "DISPLAY did not open: return value ~A~%" + *WINDOW-DISPLAY*)) + (SETQ *WINDOW-SCREEN* (XDEFAULTSCREEN *WINDOW-DISPLAY*)) + (SETQ *ROOT-WINDOW* (XROOTWINDOW *WINDOW-DISPLAY* *WINDOW-SCREEN*)) + (SETQ *BLACK-PIXEL* (XBLACKPIXEL *WINDOW-DISPLAY* *WINDOW-SCREEN*)) + (SETQ *WHITE-PIXEL* (XWHITEPIXEL *WINDOW-DISPLAY* *WINDOW-SCREEN*)) + (SETQ *DEFAULT-FG-COLOR* *BLACK-PIXEL*) + (SETQ *DEFAULT-BG-COLOR* *WHITE-PIXEL*) + (SETQ *DEFAULT-GC* (XDEFAULTGC *WINDOW-DISPLAY* *WINDOW-SCREEN*)) + (SETQ *DEFAULT-COLORMAP* + (XDEFAULTCOLORMAP *WINDOW-DISPLAY* *WINDOW-SCREEN*)) + (SETQ *WINDOW-ATTRIBUTES* (MAKE-XSETWINDOWATTRIBUTES)) + (SET-XSETWINDOWATTRIBUTES-BACKING_STORE *WINDOW-ATTRIBUTES* + WHENMAPPED) + (SET-XSETWINDOWATTRIBUTES-SAVE_UNDER *WINDOW-ATTRIBUTES* 1) + (SETQ *WINDOW-ATTR* (MAKE-XWINDOWATTRIBUTES)) + (XFLUSH *WINDOW-DISPLAY*) + (SETQ *DEFAULT-SIZE-HINTS* (MAKE-XSIZEHINTS)) + (SETQ *WINDOW-EVENT* (MAKE-XEVENT)) + (SETQ *GC-VALUES* (MAKE-XGCVALUES))) + +(DEFUN WINDOW-GET-MOUSE-POSITION () + (XQUERYPOINTER *WINDOW-DISPLAY* *ROOT-WINDOW* *ROOT-RETURN* + *CHILD-RETURN* *ROOT-X-RETURN* *ROOT-Y-RETURN* *WIN-X-RETURN* + *WIN-Y-RETURN* *MASK-RETURN*) + (SETQ *MOUSE-X* (INT-POS *ROOT-X-RETURN* 0)) + (SETQ *MOUSE-Y* (INT-POS *ROOT-Y-RETURN* 0)) + (SETQ *MOUSE-WINDOW* (FIXNUM-POS *CHILD-RETURN* 0))) + + + +(DEFUN WINDOW-CREATE + (WIDTH HEIGHT &OPTIONAL STR PARENTW POS-X POS-Y FONT) + (LET (W PW FG-COLOR BG-COLOR) + (OR *WINDOW-DISPLAY* (WINDOW-XINIT)) + (SETQ FG-COLOR *DEFAULT-FG-COLOR*) + (SETQ BG-COLOR *DEFAULT-BG-COLOR*) + (UNLESS POS-X (SETQ POS-X *WINDOW-DEFAULT-POS-X*)) + (UNLESS POS-Y (SETQ POS-Y *WINDOW-DEFAULT-POS-Y*)) + (SETQ W + (LIST 'WINDOW NIL NIL HEIGHT WIDTH + (IF STR (STRINGIFY STR) " ") NIL)) + (SETQ PW (OR PARENTW *ROOT-WINDOW*)) + (WINDOW-GET-GEOMETRY-B PW) + (SETF (CADR W) + (XCREATESIMPLEWINDOW *WINDOW-DISPLAY* PW POS-X + (- (- (INT-POS *HEIGHT-RETURN* 0) POS-Y) HEIGHT) WIDTH + HEIGHT *WINDOW-DEFAULT-BORDER* FG-COLOR BG-COLOR)) + (SET-XSIZEHINTS-X *DEFAULT-SIZE-HINTS* POS-X) + (SET-XSIZEHINTS-Y *DEFAULT-SIZE-HINTS* POS-Y) + (SET-XSIZEHINTS-WIDTH *DEFAULT-SIZE-HINTS* (FIFTH W)) + (SET-XSIZEHINTS-HEIGHT *DEFAULT-SIZE-HINTS* (CADDDR W)) + (SET-XSIZEHINTS-FLAGS *DEFAULT-SIZE-HINTS* 12) + (XSETSTANDARDPROPERTIES *WINDOW-DISPLAY* (CADR W) + (GET-C-STRING (SIXTH W)) (GET-C-STRING (SIXTH W)) 0 0 0 + *DEFAULT-SIZE-HINTS*) + (SETF (CADDR W) (XCREATEGC *WINDOW-DISPLAY* (CADR W) 0 0)) + (XSETFOREGROUND *WINDOW-DISPLAY* (CADDR W) FG-COLOR) + (XSETBACKGROUND *WINDOW-DISPLAY* (CADDR W) BG-COLOR) + (WINDOW-SET-FONT W (OR FONT *WINDOW-DEFAULT-FONT-NAME*)) + (LET (C) + (SETQ C + (XCREATEFONTCURSOR *WINDOW-DISPLAY* + *WINDOW-DEFAULT-CURSOR*)) + (XDEFINECURSOR *WINDOW-DISPLAY* (CADR W) C)) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0) + (XCHANGEWINDOWATTRIBUTES *WINDOW-DISPLAY* (CADR W) 1088 + *WINDOW-ATTRIBUTES*) + (XSELECTINPUT *WINDOW-DISPLAY* (CADR W) 32876) + (XMAPWINDOW *WINDOW-DISPLAY* (CADR W)) + (XFLUSH *WINDOW-DISPLAY*) + (WINDOW-WAIT-EXPOSURE W) + W)) + +(DEFUN WINDOW-SET-FONT (W FONTSYMBOL) + (LET (FONTSTRING FONT-INFO) + (SETQ FONTSTRING + (OR (CADR (ASSOC FONTSYMBOL *WINDOW-FONTS*)) + (STRINGIFY FONTSYMBOL))) + (SETQ FONT-INFO + (XLOADQUERYFONT *WINDOW-DISPLAY* (GET-C-STRING FONTSTRING))) + (IF (ZEROP FONT-INFO) + (FORMAT T "~%can't open font ~a ~a~%" FONTSYMBOL FONTSTRING) + (PROGN + (XSETFONT *WINDOW-DISPLAY* (CADDR W) + (XFONTSTRUCT-FID FONT-INFO)) + (SETF (SEVENTH W) FONT-INFO))))) + +(DEFUN WINDOW-FONT-INFO (FONTSYMBOL) + (XLOADQUERYFONT *WINDOW-DISPLAY* + (GET-C-STRING + (OR (CADR (ASSOC FONTSYMBOL *WINDOW-FONTS*)) + (STRINGIFY FONTSYMBOL))))) + +(DEFUN WINDOW-GCONTEXT (W) (CADDR W)) + +(DEFUN WINDOW-PARENT (W) (CADR W)) + +(DEFUN WINDOW-DRAWABLE-HEIGHT (W) (CADDDR W)) + +(DEFUN WINDOW-DRAWABLE-WIDTH (W) (FIFTH W)) + +(DEFUN WINDOW-LABEL (W) (SIXTH W)) + +(DEFUN WINDOW-FONT (W) (SEVENTH W)) + +(DEFUN WINDOW-FOREGROUND (W) + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 4 *GC-VALUES*) + (XGCVALUES-FOREGROUND *GC-VALUES*)) + +(DEFUN WINDOW-SET-FOREGROUND (W FG-COLOR) + (XSETFOREGROUND *WINDOW-DISPLAY* (CADDR W) FG-COLOR)) + +(DEFUN WINDOW-BACKGROUND (W) + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 8 *GC-VALUES*) + (XGCVALUES-BACKGROUND *GC-VALUES*)) + +(DEFUN WINDOW-SET-BACKGROUND (W BG-COLOR) + (XSETBACKGROUND *WINDOW-DISPLAY* (CADDR W) BG-COLOR)) + +(DEFUN WINDOW-WFUNCTION (W) + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 1 *GC-VALUES*) + (XGCVALUES-FUNCTION *GC-VALUES*)) + +(DEFUN WINDOW-GET-GEOMETRY (W) (WINDOW-GET-GEOMETRY-B (CADR W))) + +(DEFUN WINDOW-SET-CURSOR (W N) + (LET (C) + (SETQ C (XCREATEFONTCURSOR *WINDOW-DISPLAY* N)) + (XDEFINECURSOR *WINDOW-DISPLAY* (CADR W) C))) + +(DEFUN WINDOW-GET-GEOMETRY-B (W) + (XGETGEOMETRY *WINDOW-DISPLAY* W *ROOT-RETURN* *X-RETURN* *Y-RETURN* + *WIDTH-RETURN* *HEIGHT-RETURN* *BORDER-WIDTH-RETURN* + *DEPTH-RETURN*)) + +(DEFUN WINDOW-SYNC (W) (declare (ignore w)) (XSYNC *WINDOW-DISPLAY* 1)) + +(DEFUN WINDOW-SCREEN-HEIGHT () + (WINDOW-GET-GEOMETRY-B *ROOT-WINDOW*) + (INT-POS *HEIGHT-RETURN* 0)) + +(DEFUN WINDOW-GEOMETRY (W) + (LET (SH) + (SETQ SH (WINDOW-SCREEN-HEIGHT)) + (WINDOW-GET-GEOMETRY-B (CADR W)) + (SETF (FIFTH W) (INT-POS *WIDTH-RETURN* 0)) + (SETF (CADDDR W) (INT-POS *HEIGHT-RETURN* 0)) + (LIST (INT-POS *X-RETURN* 0) + (- (- SH (INT-POS *Y-RETURN* 0)) (INT-POS *HEIGHT-RETURN* 0)) + (INT-POS *WIDTH-RETURN* 0) (INT-POS *HEIGHT-RETURN* 0) + (INT-POS *BORDER-WIDTH-RETURN* 0)))) + +(DEFUN WINDOW-SIZE (W) + (WINDOW-GET-GEOMETRY-B (CADR W)) + (LIST (SETF (FIFTH W) (INT-POS *WIDTH-RETURN* 0)) + (SETF (CADDDR W) (INT-POS *HEIGHT-RETURN* 0)))) + +(DEFUN WINDOW-LEFT (W) + (WINDOW-GET-GEOMETRY-B (CADR W)) + (INT-POS *X-RETURN* 0)) + +(DEFUN WINDOW-TOP-NEG-Y (W) + (WINDOW-GET-GEOMETRY-B (CADR W)) + (INT-POS *Y-RETURN* 0)) + +(DEFUN WINDOW-RESET-GEOMETRY (W) + (WINDOW-GET-GEOMETRY-B (CADR W)) + (SETF (FIFTH W) (INT-POS *WIDTH-RETURN* 0)) + (SETF (CADDDR W) (INT-POS *HEIGHT-RETURN* 0))) + +(DEFUN WINDOW-FORCE-OUTPUT (&OPTIONAL W) (declare (ignore w)) (XFLUSH *WINDOW-DISPLAY*)) + +(DEFUN WINDOW-QUERY-POINTER (W) (WINDOW-QUERY-POINTER-B (CADR W))) + +(DEFUN WINDOW-QUERY-POINTER-B (W) + (XQUERYPOINTER *WINDOW-DISPLAY* W *ROOT-RETURN* *CHILD-RETURN* + *ROOT-X-RETURN* *ROOT-Y-RETURN* *WIN-X-RETURN* *WIN-Y-RETURN* + *MASK-RETURN*)) + +(DEFUN WINDOW-POSITIVE-Y (W Y) (- (CADDDR W) Y)) + +(DEFUN WINDOW-SET-XOR (W) + (LET ((GC (CADDR W))) + (SETQ *WINDOW-SAVE-FUNCTION* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 1 *GC-VALUES*) + (XGCVALUES-FUNCTION *GC-VALUES*))) + (XSETFUNCTION *WINDOW-DISPLAY* GC 6) + (SETQ *WINDOW-SAVE-FOREGROUND* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 4 *GC-VALUES*) + (XGCVALUES-FOREGROUND *GC-VALUES*))) + (XSETFOREGROUND *WINDOW-DISPLAY* GC + (LOGXOR *WINDOW-SAVE-FOREGROUND* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 8 + *GC-VALUES*) + (XGCVALUES-BACKGROUND *GC-VALUES*)))))) + +(DEFUN WINDOW-UNSET (W) + (LET ((GC (CADDR W))) + (XSETFUNCTION *WINDOW-DISPLAY* GC *WINDOW-SAVE-FUNCTION*) + (XSETFOREGROUND *WINDOW-DISPLAY* GC *WINDOW-SAVE-FOREGROUND*))) + +(DEFUN WINDOW-RESET (W) + (LET ((GC (CADDR W))) + (XSETFUNCTION *WINDOW-DISPLAY* GC 3) + (XSETFOREGROUND *WINDOW-DISPLAY* GC *DEFAULT-FG-COLOR*) + (XSETBACKGROUND *WINDOW-DISPLAY* GC *DEFAULT-BG-COLOR*))) + +(DEFUN WINDOW-SET-ERASE (W) + (LET ((GC (CADDR W))) + (SETQ *WINDOW-SAVE-FUNCTION* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 1 *GC-VALUES*) + (XGCVALUES-FUNCTION *GC-VALUES*))) + (XSETFUNCTION *WINDOW-DISPLAY* GC 3) + (SETQ *WINDOW-SAVE-FOREGROUND* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 4 *GC-VALUES*) + (XGCVALUES-FOREGROUND *GC-VALUES*))) + (XSETFOREGROUND *WINDOW-DISPLAY* GC + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 8 *GC-VALUES*) + (XGCVALUES-BACKGROUND *GC-VALUES*))))) + +(DEFUN WINDOW-SET-COPY (W) + (SETQ *WINDOW-SAVE-FUNCTION* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 1 *GC-VALUES*) + (XGCVALUES-FUNCTION *GC-VALUES*))) + (XSETFUNCTION *WINDOW-DISPLAY* (CADDR W) 3) + (SETQ *WINDOW-SAVE-FOREGROUND* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 4 *GC-VALUES*) + (XGCVALUES-FOREGROUND *GC-VALUES*)))) + +(DEFUN WINDOW-SET-INVERT (W) + (LET ((GC (CADDR W))) + (SETQ *WINDOW-SAVE-FUNCTION* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 1 *GC-VALUES*) + (XGCVALUES-FUNCTION *GC-VALUES*))) + (XSETFUNCTION *WINDOW-DISPLAY* GC 6) + (SETQ *WINDOW-SAVE-FOREGROUND* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 4 *GC-VALUES*) + (XGCVALUES-FOREGROUND *GC-VALUES*))) + (XSETFOREGROUND *WINDOW-DISPLAY* GC + (LOGXOR *WINDOW-SAVE-FOREGROUND* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 8 + *GC-VALUES*) + (XGCVALUES-BACKGROUND *GC-VALUES*)))))) + +(DEFUN WINDOW-SET-LINE-WIDTH (W WIDTH) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) (OR WIDTH 1) 0 1 0)) + +(DEFUN WINDOW-SET-LINE-ATTR + (W WIDTH &OPTIONAL LINE-STYLE CAP-STYLE JOIN-STYLE) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) (OR WIDTH 1) + (OR LINE-STYLE 0) (OR CAP-STYLE 1) (OR JOIN-STYLE 0))) + +(DEFUN WINDOW-STD-LINE-ATTR (W) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0)) + +(DEFUN WINDOW-DRAW-LINE (W FROM TO &OPTIONAL LINEWIDTH) + (WINDOW-DRAW-LINE-XY W (CAR FROM) (CADR FROM) (CAR TO) (CADR TO) + LINEWIDTH)) + +(DEFUN WINDOW-DRAW-LINE-XY + (W FROMX FROMY TOX TOY &OPTIONAL LINEWIDTH OPERATION) + (LET ((QQWHEIGHT (CADDDR W))) + (IF (AND LINEWIDTH (NOT (EQL LINEWIDTH 1))) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) (OR LINEWIDTH 1) + 0 1 0)) + (CASE OPERATION + (XOR (LET ((GC (CADDR W))) + (SETQ *WINDOW-SAVE-FUNCTION* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 1 + *GC-VALUES*) + (XGCVALUES-FUNCTION *GC-VALUES*))) + (XSETFUNCTION *WINDOW-DISPLAY* GC 6) + (SETQ *WINDOW-SAVE-FOREGROUND* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 4 + *GC-VALUES*) + (XGCVALUES-FOREGROUND *GC-VALUES*))) + (XSETFOREGROUND *WINDOW-DISPLAY* GC + (LOGXOR *WINDOW-SAVE-FOREGROUND* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 8 + *GC-VALUES*) + (XGCVALUES-BACKGROUND *GC-VALUES*)))))) + (ERASE (LET ((GC (CADDR W))) + (SETQ *WINDOW-SAVE-FUNCTION* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 1 + *GC-VALUES*) + (XGCVALUES-FUNCTION *GC-VALUES*))) + (XSETFUNCTION *WINDOW-DISPLAY* GC 3) + (SETQ *WINDOW-SAVE-FOREGROUND* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 4 + *GC-VALUES*) + (XGCVALUES-FOREGROUND *GC-VALUES*))) + (XSETFOREGROUND *WINDOW-DISPLAY* GC + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 8 + *GC-VALUES*) + (XGCVALUES-BACKGROUND *GC-VALUES*))))) + (T)) + (XDRAWLINE *WINDOW-DISPLAY* (CADR W) (CADDR W) FROMX + (- QQWHEIGHT FROMY) TOX (- QQWHEIGHT TOY)) + (CASE OPERATION + ((XOR ERASE) + (LET ((GC (CADDR W))) + (XSETFUNCTION *WINDOW-DISPLAY* GC *WINDOW-SAVE-FUNCTION*) + (XSETFOREGROUND *WINDOW-DISPLAY* GC *WINDOW-SAVE-FOREGROUND*))) + (T)) + (IF (AND LINEWIDTH (NOT (EQL LINEWIDTH 1))) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0)))) + +(DEFUN WINDOW-DRAW-ARROWHEAD-XY + (W X1 Y1 X2 Y2 &OPTIONAL (LINEWIDTH 1) SIZE) + (LET (TH THETA YSTH YCTH (Y2DELA 0) (Y2DELB 0) (X2DELA 0) (X2DELB 0)) + (OR SIZE (SETQ SIZE (+ 20 (* LINEWIDTH 5)))) + (SETQ TH (ATAN (- Y2 Y1) (- X2 X1))) + (SETQ THETA (* TH (/ 180.0 PI))) + (SETQ YSTH (ROUND (* (1+ SIZE) (SIN TH)))) + (SETQ YCTH (ROUND (* (1+ SIZE) (COS TH)))) + (IF (AND (EQL Y1 Y2) (EVENP LINEWIDTH)) + (IF (> X2 X1) (SETQ Y2DELB 1) (SETQ Y2DELA 1))) + (IF (AND (EQL X1 X2) (EVENP LINEWIDTH)) + (IF (> Y2 Y1) (SETQ X2DELB 1) (SETQ X2DELA 1))) + (WINDOW-DRAW-ARC-XY W (- (- X2 YSTH) X2DELA) (+ (+ Y2 YCTH) Y2DELA) + SIZE SIZE (+ 240 THETA) 30 LINEWIDTH) + (WINDOW-DRAW-ARC-XY W (- (+ X2 YSTH) X2DELB) (+ (- Y2 YCTH) Y2DELB) + SIZE SIZE (+ 90 THETA) 30 LINEWIDTH))) + +(DEFUN WINDOW-DRAW-ARROW-XY + (W X1 Y1 X2 Y2 &OPTIONAL (LINEWIDTH 1) SIZE) + (WINDOW-DRAW-LINE-XY W X1 Y1 X2 Y2 LINEWIDTH) + (WINDOW-DRAW-ARROWHEAD-XY W X1 Y1 X2 Y2 LINEWIDTH SIZE)) + +(DEFUN WINDOW-DRAW-ARROW2-XY + (W X1 Y1 X2 Y2 &OPTIONAL (LINEWIDTH 1) SIZE) + (WINDOW-DRAW-LINE-XY W X1 Y1 X2 Y2 LINEWIDTH) + (WINDOW-DRAW-ARROWHEAD-XY W X1 Y1 X2 Y2 LINEWIDTH SIZE) + (WINDOW-DRAW-ARROWHEAD-XY W X2 Y2 X1 Y1 LINEWIDTH SIZE)) + +(DEFUN WINDOW-DRAW-BOX (W OFFSET SIZE &OPTIONAL LINEWIDTH) + (WINDOW-DRAW-BOX-XY W (CAR OFFSET) (CADR OFFSET) (CAR SIZE) + (CADR SIZE) LINEWIDTH)) + +(DEFUN WINDOW-DRAW-BOX-XY + (W OFFSETX OFFSETY SIZEX SIZEY &OPTIONAL LINEWIDTH) + (LET ((QQWHEIGHT (CADDDR W)) LW LW2 LW2B (PW (CADR W)) + (GC (CADDR W))) + (IF (AND LINEWIDTH (NOT (EQL LINEWIDTH 1))) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) (OR LINEWIDTH 1) + 0 1 0)) + (SETQ LW (OR LINEWIDTH 1)) + (SETQ LW2 (TRUNCATE LW 2)) + (SETQ LW2B (TRUNCATE (1+ LW) 2)) + (XDRAWLINE *WINDOW-DISPLAY* PW GC (- OFFSETX LW2) + (- QQWHEIGHT OFFSETY) (- (+ OFFSETX SIZEX) LW2) + (- QQWHEIGHT OFFSETY)) + (XDRAWLINE *WINDOW-DISPLAY* PW GC (+ OFFSETX SIZEX) + (- QQWHEIGHT (- OFFSETY LW2B)) (+ OFFSETX SIZEX) + (- QQWHEIGHT (+ SIZEY (- OFFSETY LW2B)))) + (XDRAWLINE *WINDOW-DISPLAY* PW GC (+ OFFSETX SIZEX LW2B) + (- QQWHEIGHT (+ OFFSETY SIZEY)) (+ OFFSETX LW2B) + (- QQWHEIGHT (+ OFFSETY SIZEY))) + (XDRAWLINE *WINDOW-DISPLAY* PW GC OFFSETX + (- QQWHEIGHT (+ OFFSETY SIZEY LW2)) OFFSETX + (- QQWHEIGHT (+ OFFSETY LW2))) + (IF (AND LINEWIDTH (NOT (EQL LINEWIDTH 1))) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0)))) + +(DEFUN WINDOW-XOR-BOX-XY + (W OFFSETX OFFSETY SIZEX SIZEY &OPTIONAL LINEWIDTH) + (WINDOW-SET-XOR W) + (WINDOW-DRAW-BOX-XY W OFFSETX OFFSETY SIZEX SIZEY LINEWIDTH) + (WINDOW-UNSET W)) + +(DEFUN WINDOW-DRAW-BOX-CORNERS (W XA YA XB YB &OPTIONAL LW) + (WINDOW-DRAW-BOX-XY W (MIN XA XB) (MIN YA YB) (ABS (- XA XB)) + (ABS (- YA YB)) LW)) + +(DEFUN WINDOW-DRAW-RCBOX-XY + (W X Y WIDTH HEIGHT RADIUS &OPTIONAL LINEWIDTH) + (LET (X1 X2 Y1 Y2 R LW2 LW2B FUDGE) + (SETQ R + (MAX 0 + (MIN RADIUS (TRUNCATE (ABS WIDTH) 2) + (TRUNCATE (ABS HEIGHT) 2)))) + (IF (NOT (NUMBERP LINEWIDTH)) (SETQ LINEWIDTH 1)) + (SETQ LW2 (TRUNCATE LINEWIDTH 2)) + (SETQ LW2B (TRUNCATE (1+ LINEWIDTH) 2)) + (SETQ FUDGE (IF (ODDP LINEWIDTH) 0 1)) + (SETQ X1 (+ X R)) + (SETQ X2 (- (+ X WIDTH) R)) + (SETQ Y1 (+ Y R)) + (SETQ Y2 (- (+ Y HEIGHT) R)) + (LET ((QQWHEIGHT (CADDDR W))) + (IF (AND LINEWIDTH (/= LINEWIDTH 1)) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) + (OR LINEWIDTH 1) 0 1 0)) + (XDRAWLINE *WINDOW-DISPLAY* (CADR W) (CADDR W) (- (1- X1) LW2) + (- QQWHEIGHT Y) X2 (- QQWHEIGHT Y)) + (IF (AND LINEWIDTH (/= LINEWIDTH 1)) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0))) + (LET ((QQWHEIGHT (CADDDR W))) + (IF (AND LINEWIDTH (/= LINEWIDTH 1)) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) + (OR LINEWIDTH 1) 0 1 0)) + (XDRAWLINE *WINDOW-DISPLAY* (CADR W) (CADDR W) (+ X WIDTH) + (- QQWHEIGHT (- Y1 LW2B)) (+ X WIDTH) (- QQWHEIGHT (1+ Y2))) + (IF (AND LINEWIDTH (/= LINEWIDTH 1)) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0))) + (LET ((QQWHEIGHT (CADDDR W))) + (IF (AND LINEWIDTH (/= LINEWIDTH 1)) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) + (OR LINEWIDTH 1) 0 1 0)) + (XDRAWLINE *WINDOW-DISPLAY* (CADR W) (CADDR W) (1- X1) + (- QQWHEIGHT (+ Y HEIGHT)) (+ X2 LW2) + (- QQWHEIGHT (+ Y HEIGHT))) + (IF (AND LINEWIDTH (/= LINEWIDTH 1)) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0))) + (LET ((QQWHEIGHT (CADDDR W))) + (IF (AND LINEWIDTH (/= LINEWIDTH 1)) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) + (OR LINEWIDTH 1) 0 1 0)) + (XDRAWLINE *WINDOW-DISPLAY* (CADR W) (CADDR W) X (- QQWHEIGHT Y1) + X (- QQWHEIGHT (1+ Y2))) + (IF (AND LINEWIDTH (/= LINEWIDTH 1)) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0))) + (IF (AND LINEWIDTH (/= LINEWIDTH 1)) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) (OR LINEWIDTH 1) + 0 1 0)) + (XDRAWARC *WINDOW-DISPLAY* (CADR W) (CADDR W) (- (- X1 FUDGE) R) + (- (CADDDR W) (+ Y1 R)) (* 2 R) (* 2 R) 11520 5760) + (IF (AND LINEWIDTH (/= LINEWIDTH 1)) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0)) + (IF (AND LINEWIDTH (/= LINEWIDTH 1)) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) (OR LINEWIDTH 1) + 0 1 0)) + (XDRAWARC *WINDOW-DISPLAY* (CADR W) (CADDR W) (- X2 R) + (- (CADDDR W) (+ Y1 R)) (* 2 R) (* 2 R) 17280 5760) + (IF (AND LINEWIDTH (/= LINEWIDTH 1)) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0)) + (IF (AND LINEWIDTH (/= LINEWIDTH 1)) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) (OR LINEWIDTH 1) + 0 1 0)) + (XDRAWARC *WINDOW-DISPLAY* (CADR W) (CADDR W) (- X2 R) + (- (CADDDR W) (+ (+ Y2 FUDGE) R)) (* 2 R) (* 2 R) 0 5760) + (IF (AND LINEWIDTH (/= LINEWIDTH 1)) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0)) + (IF (AND LINEWIDTH (/= LINEWIDTH 1)) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) (OR LINEWIDTH 1) + 0 1 0)) + (XDRAWARC *WINDOW-DISPLAY* (CADR W) (CADDR W) (- (- X1 FUDGE) R) + (- (CADDDR W) (+ (+ Y2 FUDGE) R)) (* 2 R) (* 2 R) 5760 5760) + (IF (AND LINEWIDTH (/= LINEWIDTH 1)) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0)))) + +(DEFUN WINDOW-DRAW-ARC-XY + (W X Y RADIUSX RADIUSY ANGLEA ANGLEB &OPTIONAL LINEWIDTH) + (IF (AND LINEWIDTH (NOT (EQL LINEWIDTH 1))) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) (OR LINEWIDTH 1) 0 + 1 0)) + (XDRAWARC *WINDOW-DISPLAY* (CADR W) (CADDR W) (- X RADIUSX) + (- (CADDDR W) (+ Y RADIUSY)) (* 2 RADIUSX) (* 2 RADIUSY) + (TRUNCATE (* 64 ANGLEA)) (TRUNCATE (* 64 ANGLEB))) + (IF (AND LINEWIDTH (NOT (EQL LINEWIDTH 1))) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0))) + +(DEFUN WINDOW-DRAW-CIRCLE-XY (W X Y RADIUS &OPTIONAL LINEWIDTH) + (IF (AND LINEWIDTH (NOT (EQL LINEWIDTH 1))) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) (OR LINEWIDTH 1) 0 + 1 0)) + (XDRAWARC *WINDOW-DISPLAY* (CADR W) (CADDR W) (- X RADIUS) + (- (CADDDR W) (+ Y RADIUS)) (* 2 RADIUS) (* 2 RADIUS) 0 23040) + (IF (AND LINEWIDTH (NOT (EQL LINEWIDTH 1))) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0))) + +(DEFUN WINDOW-DRAW-CIRCLE (W POS RADIUS &OPTIONAL LINEWIDTH) + (WINDOW-DRAW-CIRCLE-XY W (CAR POS) (CADR POS) RADIUS LINEWIDTH)) + +(DEFUN WINDOW-ERASE-AREA (W OFFSET SIZE) + (WINDOW-ERASE-AREA-XY W (CAR OFFSET) (CADR OFFSET) (CAR SIZE) + (CADR SIZE))) + +(DEFUN WINDOW-ERASE-AREA-XY (W XOFF YOFF XSIZE YSIZE) + (XCLEARAREA *WINDOW-DISPLAY* (CADR W) XOFF + (- (CADDDR W) (1- (+ YOFF YSIZE))) XSIZE YSIZE 0)) + +(DEFUN WINDOW-ERASE-BOX-XY + (W XOFF YOFF XSIZE YSIZE &OPTIONAL LINEWIDTH) + (XCLEARAREA *WINDOW-DISPLAY* (CADR W) + (- XOFF (TRUNCATE (OR LINEWIDTH 1) 2)) + (- (CADDDR W) (+ YOFF YSIZE (TRUNCATE (OR LINEWIDTH 1) 2))) + (+ XSIZE (OR LINEWIDTH 1)) (+ YSIZE (OR LINEWIDTH 1)) 0)) + +(DEFUN WINDOW-DRAW-ELLIPSE-XY (W X Y RX RY &OPTIONAL LW) + (IF (AND LW (NOT (EQL LW 1))) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) (OR LW 1) 0 1 0)) + (XDRAWARC *WINDOW-DISPLAY* (CADR W) (CADDR W) (- X RX) + (- (CADDDR W) (+ Y RY)) (* 2 RX) (* 2 RY) 0 23040) + (IF (AND LW (NOT (EQL LW 1))) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0))) + +(DEFUN WINDOW-COPY-AREA-XY (W FROMX FROMY TOX TOY WIDTH HEIGHT) + (LET ((QQWHEIGHT (CADDDR W))) + (SETQ *WINDOW-SAVE-FUNCTION* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 1 *GC-VALUES*) + (XGCVALUES-FUNCTION *GC-VALUES*))) + (XSETFUNCTION *WINDOW-DISPLAY* (CADDR W) 3) + (SETQ *WINDOW-SAVE-FOREGROUND* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 4 *GC-VALUES*) + (XGCVALUES-FOREGROUND *GC-VALUES*))) + (XCOPYAREA *WINDOW-DISPLAY* (CADR W) (CADR W) (CADDR W) FROMX + (- QQWHEIGHT (+ FROMY HEIGHT)) WIDTH HEIGHT TOX + (- QQWHEIGHT (+ TOY HEIGHT))) + (LET ((GC (CADDR W))) + (XSETFUNCTION *WINDOW-DISPLAY* GC *WINDOW-SAVE-FUNCTION*) + (XSETFOREGROUND *WINDOW-DISPLAY* GC *WINDOW-SAVE-FOREGROUND*)))) + +(DEFUN WINDOW-INVERTAREA (W AREA) + (WINDOW-INVERT-AREA-XY W (CAAR AREA) (CADAR AREA) (CAADR AREA) + (CADADR AREA))) + +(DEFUN WINDOW-INVERT-AREA (W OFFSET SIZE) + (WINDOW-INVERT-AREA-XY W (CAR OFFSET) (CADR OFFSET) (CAR SIZE) + (CADR SIZE))) + +(DEFUN WINDOW-INVERT-AREA-XY (W LEFT BOTTOM WIDTH HEIGHT) + (LET ((GC (CADDR W))) + (SETQ *WINDOW-SAVE-FUNCTION* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 1 *GC-VALUES*) + (XGCVALUES-FUNCTION *GC-VALUES*))) + (XSETFUNCTION *WINDOW-DISPLAY* GC 6) + (SETQ *WINDOW-SAVE-FOREGROUND* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 4 *GC-VALUES*) + (XGCVALUES-FOREGROUND *GC-VALUES*))) + (XSETFOREGROUND *WINDOW-DISPLAY* GC + (LOGXOR *WINDOW-SAVE-FOREGROUND* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 8 + *GC-VALUES*) + (XGCVALUES-BACKGROUND *GC-VALUES*))))) + (XFILLRECTANGLE *WINDOW-DISPLAY* (CADR W) (CADDR W) LEFT + (- (CADDDR W) (1- (+ BOTTOM HEIGHT))) WIDTH HEIGHT) + (LET ((GC (CADDR W))) + (XSETFUNCTION *WINDOW-DISPLAY* GC *WINDOW-SAVE-FUNCTION*) + (XSETFOREGROUND *WINDOW-DISPLAY* GC *WINDOW-SAVE-FOREGROUND*))) + +(DEFUN WINDOW-PRETTYPRINTAT (W S POS) + (LET ((SSTR (STRINGIFY S))) + (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) (CAR POS) + (- (CADDDR W) (CADR POS)) (GET-C-STRING SSTR) (LENGTH SSTR)))) + +(DEFUN WINDOW-PRETTYPRINTAT-XY (W S X Y) + (LET ((SSTR (STRINGIFY S))) + (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) X + (- (CADDDR W) Y) (GET-C-STRING SSTR) (LENGTH SSTR)))) + +(DEFUN WINDOW-PRINTAT (W S POS) + (LET ((SSTR (STRINGIFY S))) + (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) (CAR POS) + (- (CADDDR W) (CADR POS)) (GET-C-STRING SSTR) (LENGTH SSTR)))) + +(DEFUN WINDOW-PRINTAT-XY (W S X Y) + (LET ((SSTR (STRINGIFY S))) + (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) X + (- (CADDDR W) Y) (GET-C-STRING SSTR) (LENGTH SSTR)))) + +(DEFUN WINDOW-PRINT-LINE (W STR X Y &OPTIONAL DELTAY) + (LET ((N 0) END STRB DONE) + (WHILE (NOT DONE) + (SETQ END (POSITION #\Newline STR :TEST #'CHAR= :START N)) + (SETQ STRB (SUBSEQ STR N END)) + (LET ((SSTR (STRINGIFY STRB))) + (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) X + (- (CADDDR W) Y) (GET-C-STRING SSTR) (LENGTH SSTR))) + (IF (NUMBERP END) (SETQ N (1+ END)) (SETQ DONE T)) + (DECF Y (OR DELTAY 16)) (IF (MINUSP Y) (SETQ DONE T))) + (XFLUSH *WINDOW-DISPLAY*))) + +(DEFUN WINDOW-PRINT-LINES (W LINES X Y &OPTIONAL DELTAY) + (DOLIST (STR LINES) + (WHEN (PLUSP Y) + (LET ((SSTR (STRINGIFY STR))) + (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) X + (- (CADDDR W) Y) (GET-C-STRING SSTR) (LENGTH SSTR))) + (DECF Y (OR DELTAY 16))))) + +(DEFUN WINDOW-STRING-WIDTH (W S) + (LET ((SSTR (STRINGIFY S))) + (XTEXTWIDTH (SEVENTH W) (GET-C-STRING SSTR) (LENGTH SSTR)))) + +(DEFUN WINDOW-STRING-EXTENTS (W S) + (LET ((SSTR (STRINGIFY S))) + (XTEXTEXTENTS (SEVENTH W) (GET-C-STRING SSTR) (LENGTH SSTR) + *DIRECTION-RETURN* *ASCENT-RETURN* *DESCENT-RETURN* + *OVERALL-RETURN*) + (LIST (INT-POS *ASCENT-RETURN* 0) (INT-POS *DESCENT-RETURN* 0)))) + +(DEFUN WINDOW-STRING-HEIGHT (W S) + (LET ((SSTR (STRINGIFY S))) + (XTEXTEXTENTS (SEVENTH W) (GET-C-STRING SSTR) (LENGTH SSTR) + *DIRECTION-RETURN* *ASCENT-RETURN* *DESCENT-RETURN* + *OVERALL-RETURN*) + (+ (INT-POS *ASCENT-RETURN* 0) (INT-POS *DESCENT-RETURN* 0)))) + +(DEFUN WINDOW-FONT-STRING-WIDTH (FONT S) + (LET ((SSTR (STRINGIFY S))) + (XTEXTWIDTH FONT (GET-C-STRING SSTR) (LENGTH SSTR)))) + +(DEFUN WINDOW-YPOSITION (W) + (WINDOW-GET-MOUSE-POSITION) + (- (CADDDR W) + (- *MOUSE-Y* + (PROGN + (WINDOW-GET-GEOMETRY-B (CADR W)) + (INT-POS *Y-RETURN* 0))))) + +(DEFUN WINDOW-CENTEROFFSET (W V) + (LIST (TRUNCATE (- (FIFTH W) (CAR V)) 2) + (TRUNCATE (- (CADDDR W) (CADR V)) 2))) + +(DEFUN DOWINDOWCOM (W) + (LET (COMM) + (SETQ COMM (MENU-SELECT (WINDOW-MENU))) + (CASE COMM + (CLOSE (XUNMAPWINDOW *WINDOW-DISPLAY* (CADR W)) + (XFLUSH *WINDOW-DISPLAY*) (WINDOW-WAIT-UNMAP W)) + (PAINT (WINDOW-PAINT W)) + (CLEAR (XCLEARWINDOW *WINDOW-DISPLAY* (CADR W)) + (XFLUSH *WINDOW-DISPLAY*)) + (MOVE (WINDOW-MOVE W)) + (T (WHEN COMM (PRINC "This command not implemented.") (TERPRI)))))) + +(DEFUN WINDOW-MENU () + (OR *WINDOW-MENU* + (SETQ *WINDOW-MENU* + (LIST 'MENU (COPY-LIST '(WINDOW NIL NIL 0 0 "" NIL)) NIL + NIL 0 0 0 0 "" NIL NIL 0 '(CLOSE PAINT CLEAR MOVE))))) + +(DEFUN WINDOW-CLOSE (W) + (XUNMAPWINDOW *WINDOW-DISPLAY* (CADR W)) + (XFLUSH *WINDOW-DISPLAY*) + (WINDOW-WAIT-UNMAP W)) + +(DEFUN WINDOW-UNMAP (W) (XUNMAPWINDOW *WINDOW-DISPLAY* (CADR W))) + +(DEFUN WINDOW-OPEN (W) + (XMAPWINDOW *WINDOW-DISPLAY* (CADR W)) + (XFLUSH *WINDOW-DISPLAY*) + (WINDOW-WAIT-EXPOSURE W)) + +(DEFUN WINDOW-MAP (W) (XMAPWINDOW *WINDOW-DISPLAY* (CADR W))) + +(DEFUN WINDOW-DESTROY (W) + (XDESTROYWINDOW *WINDOW-DISPLAY* (CADR W)) + (XFLUSH *WINDOW-DISPLAY*) + (SETF (CADR W) NIL) + (XFREEGC *WINDOW-DISPLAY* (CADDR W)) + (SETF (CADDR W) NIL)) + +(DEFUN WINDOW-DESTROY-SELECTED-WINDOW () + (PROG (WW CHILD) + (SLEEP 3) + (SETQ WW *ROOT-WINDOW*) + LP + (WINDOW-QUERY-POINTER-B WW) + (SETQ CHILD (FIXNUM-POS *CHILD-RETURN* 0)) + (IF (> CHILD 0) (PROGN (SETQ WW CHILD) (GO LP))) + (IF (/= WW *ROOT-WINDOW*) + (PROGN + (XDESTROYWINDOW *WINDOW-DISPLAY* WW) + (XFLUSH *WINDOW-DISPLAY*))))) + +(DEFUN WINDOW-CLEAR (W) + (XCLEARWINDOW *WINDOW-DISPLAY* (CADR W)) + (XFLUSH *WINDOW-DISPLAY*)) + +(DEFUN WINDOW-MOVETO-XY (W X Y) + (XMOVEWINDOW *WINDOW-DISPLAY* (CADR W) X + (- (WINDOW-SCREEN-HEIGHT) Y))) + +(DEFUN WINDOW-PAINT (WINDOW) + (LET (STATE) + (WINDOW-TRACK-MOUSE WINDOW + #'(LAMBDA (X Y CODE) + (IF (= CODE 1) + (IF (= STATE 1) (SETQ STATE 0) (SETQ STATE 1)) + (IF (= CODE 2) + (IF (= STATE 2) (SETQ STATE 0) (SETQ STATE 2)))) + (IF (= STATE 1) + (WINDOW-DRAW-LINE-XY WINDOW X Y X Y 1 'PAINT) + (IF (= STATE 2) + (WINDOW-DRAW-LINE-XY WINDOW X Y X Y 1 'ERASE))) + (= CODE 3))))) + +(DEFUN WINDOW-MOVE (W) + (WINDOW-GET-MOUSE-POSITION) + (XMOVEWINDOW *WINDOW-DISPLAY* (CADR W) *MOUSE-X* + (- (WINDOW-SCREEN-HEIGHT) *MOUSE-Y*))) + +(DEFUN WINDOW-DRAW-BORDER (W) + (WINDOW-DRAW-BOX-XY W 0 1 (1- (CAR (WINDOW-SIZE W))) + (1- (CADR (WINDOW-SIZE W)))) + (XFLUSH *WINDOW-DISPLAY*)) + +(DEFUN WINDOW-TRACK-MOUSE (W FN &OPTIONAL OUTFLG) + (LET (WIN H) + (SETQ WIN (WINDOW-PARENT W)) + (SETQ H (WINDOW-DRAWABLE-HEIGHT W)) + (XSYNC *WINDOW-DISPLAY* 1) + (XSELECTINPUT *WINDOW-DISPLAY* WIN + (+ BUTTONPRESSMASK POINTERMOTIONMASK)) + (DO ((RES NIL)) (RES RES) + (XNEXTEVENT *WINDOW-DISPLAY* *WINDOW-EVENT*) + (LET ((TYPE (XANYEVENT-TYPE *WINDOW-EVENT*)) + (EVENTWINDOW (XANYEVENT-WINDOW *WINDOW-EVENT*))) + (WHEN (OR (AND (EQL EVENTWINDOW WIN) + (OR (EQL TYPE MOTIONNOTIFY) + (EQL TYPE BUTTONPRESS))) + (AND OUTFLG (EQL TYPE BUTTONPRESS))) + (LET ((X (XMOTIONEVENT-X *WINDOW-EVENT*)) + (Y (XMOTIONEVENT-Y *WINDOW-EVENT*)) + (CODE (IF (EQL TYPE BUTTONPRESS) + (XBUTTONEVENT-BUTTON *WINDOW-EVENT*) 0))) + (SETQ RES + (IF (EQL EVENTWINDOW WIN) (FUNCALL FN X (- H Y) CODE) + (FUNCALL FN -1 -1 CODE))))))))) + +(DEFUN WINDOW-WAIT-EXPOSURE (W) + (PROG (WIN START-TIME MAX-TIME EVENTWINDOW TYPE) + (SETQ WIN (WINDOW-PARENT W)) + (XGETWINDOWATTRIBUTES *WINDOW-DISPLAY* WIN *WINDOW-ATTR*) + (UNLESS (EQL (XWINDOWATTRIBUTES-MAP_STATE *WINDOW-ATTR*) + ISUNMAPPED) + (RETURN T)) + (SETQ START-TIME (GET-INTERNAL-REAL-TIME)) + (SETQ MAX-TIME INTERNAL-TIME-UNITS-PER-SECOND) + (XSELECTINPUT *WINDOW-DISPLAY* WIN (+ EXPOSUREMASK)) + LP + (COND + ((> (XPENDING *WINDOW-DISPLAY*) 0) + (XNEXTEVENT *WINDOW-DISPLAY* *WINDOW-EVENT*) + (SETQ TYPE (XANYEVENT-TYPE *WINDOW-EVENT*)) + (SETQ EVENTWINDOW (XANYEVENT-WINDOW *WINDOW-EVENT*)) + (IF (AND (EQL EVENTWINDOW WIN) (EQL TYPE EXPOSE)) (RETURN T))) + ((> (- (GET-INTERNAL-REAL-TIME) START-TIME) MAX-TIME) + (RETURN NIL))) + (GO LP))) + +(DEFUN WINDOW-WAIT-UNMAP (W) + (PROG (WIN START-TIME MAX-TIME) + (SETQ WIN (WINDOW-PARENT W)) + (SETQ START-TIME (GET-INTERNAL-REAL-TIME)) + (SETQ MAX-TIME INTERNAL-TIME-UNITS-PER-SECOND) + LP + (XGETWINDOWATTRIBUTES *WINDOW-DISPLAY* WIN *WINDOW-ATTR*) + (IF (EQL (XWINDOWATTRIBUTES-MAP_STATE *WINDOW-ATTR*) ISUNMAPPED) + (RETURN T) + (IF (> (- (GET-INTERNAL-REAL-TIME) START-TIME) MAX-TIME) + (RETURN NIL))) + (GO LP))) + +(DEFUN WINDOW-INIT-MOUSE-POLL (W) + (LET (WIN) + (SETQ WIN (WINDOW-PARENT W)) + (XSYNC *WINDOW-DISPLAY* 1) + (XSELECTINPUT *WINDOW-DISPLAY* WIN + (+ BUTTONPRESSMASK POINTERMOTIONMASK)))) + +(DEFUN WINDOW-POLL-MOUSE (W) + (LET (WIN H EVENTTYPE EVENTWINDOW X Y CD (CODE 0)) + (SETQ WIN (WINDOW-PARENT W)) + (SETQ H (WINDOW-DRAWABLE-HEIGHT W)) + (WHILE (> (XPENDING *WINDOW-DISPLAY*) 0) + (XNEXTEVENT *WINDOW-DISPLAY* *WINDOW-EVENT*) + (SETQ EVENTTYPE (XANYEVENT-TYPE *WINDOW-EVENT*)) + (SETQ EVENTWINDOW (XANYEVENT-WINDOW *WINDOW-EVENT*)) + (IF (EQL EVENTWINDOW WIN) + (IF (EQL EVENTTYPE MOTIONNOTIFY) + (PROGN + (SETQ X (XMOTIONEVENT-X *WINDOW-EVENT*)) + (SETQ Y (XMOTIONEVENT-Y *WINDOW-EVENT*))) + (IF (EQL EVENTTYPE BUTTONPRESS) + (IF (> (SETQ CD + (XBUTTONEVENT-BUTTON + *WINDOW-EVENT*)) + 0) + (SETQ CODE CD)))))) + (IF (OR X (> CODE 0)) (LIST X (IF Y (- H Y)) CODE)))) + +(DEFUN MENU-INIT (M) + (OR *WINDOW-DISPLAY* (WINDOW-XINIT)) + (MENU-CALCULATE-SIZE M) + (IF (NOT (CADDR M)) + (SETF (CADR M) + (WINDOW-CREATE (SEVENTH M) (EIGHTH M) (OR (NINTH M) "") + (CADDDR M) (FIFTH M) (SIXTH M) (NTH 10 M))))) + +(DEFUN MENU-CALCULATE-SIZE (M) + (LET (MAXWIDTH TOTALHEIGHT NITEMS) + (OR (NTH 10 M) (SETF (NTH 10 M) '9X15)) + (SETQ MAXWIDTH + (+ (MENU-FIND-ITEM-WIDTH M (NINTH M)) + (IF (OR (CADDR M) *WINDOW-ADD-MENU-TITLE*) 0 + *MENU-TITLE-PAD*))) + (SETQ NITEMS + (IF (AND (NINTH M) (PLUSP (LENGTH (NINTH M))) + (OR (CADDR M) *WINDOW-ADD-MENU-TITLE*)) + 1 0)) + (SETQ TOTALHEIGHT (* 13 NITEMS)) + (DOLIST (ITEM (NTH 12 M)) + (INCF NITEMS) + (SETQ MAXWIDTH (MAX MAXWIDTH (MENU-FIND-ITEM-WIDTH M ITEM))) + (INCF TOTALHEIGHT (MENU-FIND-ITEM-HEIGHT M ITEM))) + (SETF (NTH 11 M) (+ 6 MAXWIDTH)) + (SETF (SEVENTH M) (1+ (NTH 11 M))) + (SETF (EIGHTH M) (+ 2 TOTALHEIGHT)) + (MENU-ADJUST-OFFSET M))) + +(DEFUN MENU-ADJUST-OFFSET (M) + (LET (XBASE YBASE WBASE HBASE XOFF YOFF WGM WIDTH HEIGHT) + (SETQ WIDTH (SEVENTH M)) + (SETQ HEIGHT (EIGHTH M)) + (WHEN (NOT (CADDDR M)) + (WINDOW-GET-MOUSE-POSITION) + (SETQ WGM T) + (SETF (CADDDR M) *ROOT-WINDOW*)) + (WINDOW-GET-GEOMETRY-B (CADDDR M)) + (SETQ XBASE (INT-POS *X-RETURN* 0)) + (SETQ YBASE (INT-POS *Y-RETURN* 0)) + (SETQ WBASE (INT-POS *WIDTH-RETURN* 0)) + (SETQ HBASE (INT-POS *HEIGHT-RETURN* 0)) + (IF (OR (NOT (FIFTH M)) (ZEROP (FIFTH M))) + (PROGN + (OR WGM (WINDOW-GET-MOUSE-POSITION)) + (SETQ XOFF (+ -4 (- (- *MOUSE-X* XBASE) (TRUNCATE WIDTH 2)))) + (SETQ YOFF + (- (- HBASE (- *MOUSE-Y* YBASE)) (TRUNCATE HEIGHT 2)))) + (PROGN (SETQ XOFF (FIFTH M)) (SETQ YOFF (SIXTH M)))) + (SETF (FIFTH M) (MAX 0 (MIN XOFF (- WBASE WIDTH)))) + (SETF (SIXTH M) (MAX 0 (MIN YOFF (- HBASE HEIGHT)))))) + +(DEFUN MENU-DRAW (M) + (LET (MW XZERO YZERO BOTTOM) + (OR (AND (CADR M) (PLUSP (EIGHTH M))) (MENU-INIT M)) + (SETQ XZERO (IF (CADDR M) (FIFTH M) 0)) + (SETQ YZERO (IF (CADDR M) (SIXTH M) 0)) + (SETQ MW (CADR M)) + (XMAPWINDOW *WINDOW-DISPLAY* (CADR MW)) + (XFLUSH *WINDOW-DISPLAY*) + (WINDOW-WAIT-EXPOSURE MW) + (MENU-CLEAR M) + (IF (CADDR M) + (WINDOW-DRAW-BOX-XY MW (1- XZERO) YZERO (+ 2 (SEVENTH M)) + (1+ (EIGHTH M)) 1)) + (SETQ BOTTOM (+ 3 (+ YZERO (EIGHTH M)))) + (WHEN (AND (NINTH M) (PLUSP (LENGTH (NINTH M))) + (OR (CADDR M) *WINDOW-ADD-MENU-TITLE*)) + (INCF BOTTOM -15) + (LET ((SSTR (STRINGIFY (STRINGIFY (NINTH M))))) + (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR MW) (CADDR MW) + (+ 3 XZERO) (- (CADDDR MW) BOTTOM) (GET-C-STRING SSTR) + (LENGTH SSTR))) + (LET ((GC (CADDR MW))) + (SETQ *WINDOW-SAVE-FUNCTION* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 1 + *GC-VALUES*) + (XGCVALUES-FUNCTION *GC-VALUES*))) + (XSETFUNCTION *WINDOW-DISPLAY* GC 6) + (SETQ *WINDOW-SAVE-FOREGROUND* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 4 + *GC-VALUES*) + (XGCVALUES-FOREGROUND *GC-VALUES*))) + (XSETFOREGROUND *WINDOW-DISPLAY* GC + (LOGXOR *WINDOW-SAVE-FOREGROUND* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 8 + *GC-VALUES*) + (XGCVALUES-BACKGROUND *GC-VALUES*))))) + (XFILLRECTANGLE *WINDOW-DISPLAY* (CADR MW) (CADDR MW) XZERO + (+ -12 (- (CADDDR MW) BOTTOM)) (1+ (SEVENTH M)) 15) + (LET ((GC (CADDR MW))) + (XSETFUNCTION *WINDOW-DISPLAY* GC *WINDOW-SAVE-FUNCTION*) + (XSETFOREGROUND *WINDOW-DISPLAY* GC *WINDOW-SAVE-FOREGROUND*))) + (DOLIST (ITEM (NTH 12 M)) + (DECF BOTTOM (MENU-FIND-ITEM-HEIGHT M ITEM)) + (MENU-DISPLAY-ITEM M ITEM (+ 3 XZERO) BOTTOM)) + (XFLUSH *WINDOW-DISPLAY*))) + +(DEFUN MENU-ITEM-VALUE (SELF ITEM) (declare (ignore self)) (IF (CONSP ITEM) (CDR ITEM) ITEM)) + +(DEFUN MENU-FIND-ITEM-WIDTH (SELF ITEM) + (LET (TMP) + (IF (AND (CONSP ITEM) (SYMBOLP (CAR ITEM)) (FBOUNDP (CAR ITEM))) + (OR (AND (SETQ TMP (GET (CAR ITEM) 'DISPLAY-SIZE)) (CAR TMP)) + 40) + (WINDOW-FONT-STRING-WIDTH + (OR (AND (CADDR SELF) (CADR SELF) (SEVENTH (CADR SELF))) + (WINDOW-FONT-INFO (NTH 10 SELF))) + (STRINGIFY (IF (CONSP ITEM) (CAR ITEM) ITEM)))))) + +(DEFUN MENU-FIND-ITEM-HEIGHT (SELF ITEM) + (declare (ignore self)) + (LET (TMP) + (IF (AND (CONSP ITEM) (SYMBOLP (CAR ITEM)) + (SETQ TMP (GET (CAR ITEM) 'DISPLAY-SIZE))) + (+ 3 (CADR TMP)) 15))) + +(DEFUN MENU-CLEAR (M) + (IF (CADDR M) + (LET ((GLVAR386 (+ 3 (EIGHTH M)))) + (XCLEARAREA *WINDOW-DISPLAY* (CADADR M) + (1- (IF (CADDR M) (FIFTH M) 0)) + (- (CADDDR (CADR M)) + (1- (+ (1- (IF (CADDR M) (SIXTH M) 0)) GLVAR386))) + (+ 3 (SEVENTH M)) GLVAR386 0)) + (PROGN + (XCLEARWINDOW *WINDOW-DISPLAY* (CADADR M)) + (XFLUSH *WINDOW-DISPLAY*)))) + +(DEFUN MENU-DISPLAY-ITEM (SELF ITEM X Y) + (LET ((MW (CADR SELF))) + (IF (CONSP ITEM) + (IF (AND (SYMBOLP (CAR ITEM)) (FBOUNDP (CAR ITEM))) + (FUNCALL (CAR ITEM) MW X Y) + (IF (OR (STRINGP (CAR ITEM)) (SYMBOLP (CAR ITEM)) + (NUMBERP (CAR ITEM))) + (LET ((SSTR (STRINGIFY (CAR ITEM)))) + (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR MW) + (CADDR MW) X (- (CADDDR MW) Y) + (GET-C-STRING SSTR) (LENGTH SSTR))) + (LET ((SSTR (STRINGIFY (STRINGIFY ITEM)))) + (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR MW) + (CADDR MW) X (- (CADDDR MW) Y) + (GET-C-STRING SSTR) (LENGTH SSTR))))) + (LET ((SSTR (STRINGIFY (STRINGIFY ITEM)))) + (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR MW) (CADDR MW) X + (- (CADDDR MW) Y) (GET-C-STRING SSTR) (LENGTH SSTR)))))) + +(DEFUN MENU-CHOOSE (M INSIDE) + (LET (MW CURRENT-ITEM YBASE ITEMH VAL MAXX MAXY XZERO YZERO) + (OR (AND (CADR M) (PLUSP (EIGHTH M))) (MENU-INIT M)) + (SETQ MW (CADR M)) + (MENU-DRAW M) + (SETQ XZERO (IF (CADDR M) (FIFTH M) 0)) + (SETQ YZERO (IF (CADDR M) (SIXTH M) 0)) + (SETQ MAXX (+ XZERO (SEVENTH M))) + (SETQ MAXY (+ YZERO (EIGHTH M))) + (IF (AND (NINTH M) (PLUSP (LENGTH (NINTH M))) + (OR (CADDR M) *WINDOW-ADD-MENU-TITLE*)) + (INCF MAXY -15)) + (WINDOW-TRACK-MOUSE MW + #'(LAMBDA (X Y CODE) + (SETQ *WINDOW-MENU-CODE* CODE) + (IF (AND (>= X XZERO) (<= X MAXX) (>= Y YZERO) (<= Y MAXY)) + (IF (OR (NULL CURRENT-ITEM) (< Y YBASE) + (> Y (+ YBASE ITEMH))) + (PROGN + (IF CURRENT-ITEM + (MENU-BOX-ITEM M CURRENT-ITEM YBASE)) + (SETQ CURRENT-ITEM + (MENU-FIND-ITEM-Y M (- Y YZERO))) + (WHEN CURRENT-ITEM + (SETQ YBASE (MENU-ITEM-Y M CURRENT-ITEM)) + (SETQ ITEMH + (MENU-FIND-ITEM-HEIGHT M CURRENT-ITEM)) + (MENU-BOX-ITEM M CURRENT-ITEM YBASE) + (SETQ INSIDE T)) + (WHEN (PLUSP CODE) + (MENU-BOX-ITEM M CURRENT-ITEM YBASE) + (SETQ VAL 1))) + (WHEN (PLUSP CODE) + (MENU-BOX-ITEM M CURRENT-ITEM YBASE) + (SETQ VAL 1))) + (PROGN + (WHEN CURRENT-ITEM + (MENU-BOX-ITEM M CURRENT-ITEM YBASE) + (SETQ CURRENT-ITEM NIL)) + (IF (OR (PLUSP CODE) + (AND INSIDE + (OR (< X XZERO) (> X MAXX) (< Y YZERO) + (> Y MAXY)))) + (SETQ VAL -777))))) + T) + (IF (NOT (EQL VAL -777)) + (IF (CONSP CURRENT-ITEM) (CDR CURRENT-ITEM) CURRENT-ITEM)))) + +(DEFUN MENU-BOX-ITEM (M ITEM YBASE) + (LET ((MW (OR (CADR M) (MENU-INIT M)))) + (LET ((GC (CADDR MW))) + (SETQ *WINDOW-SAVE-FUNCTION* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 1 *GC-VALUES*) + (XGCVALUES-FUNCTION *GC-VALUES*))) + (XSETFUNCTION *WINDOW-DISPLAY* GC 6) + (SETQ *WINDOW-SAVE-FOREGROUND* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 4 *GC-VALUES*) + (XGCVALUES-FOREGROUND *GC-VALUES*))) + (XSETFOREGROUND *WINDOW-DISPLAY* GC + (LOGXOR *WINDOW-SAVE-FOREGROUND* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 8 + *GC-VALUES*) + (XGCVALUES-BACKGROUND *GC-VALUES*))))) + (WINDOW-DRAW-BOX-XY MW (1+ (IF (CADDR M) (FIFTH M) 0)) + (+ 2 (+ (IF (CADDR M) (SIXTH M) 0) YBASE)) (+ -2 (NTH 11 M)) + (MENU-FIND-ITEM-HEIGHT M ITEM) 1) + (LET ((GC (CADDR MW))) + (XSETFUNCTION *WINDOW-DISPLAY* GC *WINDOW-SAVE-FUNCTION*) + (XSETFOREGROUND *WINDOW-DISPLAY* GC *WINDOW-SAVE-FOREGROUND*)))) + +(DEFUN MENU-UNBOX-ITEM (M ITEM YBASE) (MENU-BOX-ITEM M ITEM YBASE)) + +(DEFUN MENU-ITEM-POSITION (M ITEMNAME &OPTIONAL PLACE) + (LET ((XSIZE (NTH 11 M)) YBASE ITEM YSIZE) + (SETQ ITEM (MENU-FIND-ITEM M ITEMNAME)) + (SETQ YSIZE (MENU-FIND-ITEM-HEIGHT M ITEM)) + (SETQ YBASE (MENU-ITEM-Y M ITEM)) + (LIST (+ (IF (CADDR M) (FIFTH M) 0) + (CASE PLACE + ((CENTER TOP BOTTOM) (TRUNCATE XSIZE 2)) + (LEFT -1) + (RIGHT (+ 2 XSIZE)) + (T 0))) + (+ (+ (IF (CADDR M) (SIXTH M) 0) YBASE) + (CASE PLACE + ((CENTER RIGHT LEFT) (TRUNCATE YSIZE 2)) + (BOTTOM 0) + (TOP YSIZE) + (T 0)))))) + +(DEFUN MENU-FIND-ITEM (M ITEMNAME) + (LET (FOUND ITMS ITEM) + (SETQ ITMS (NTH 12 M)) + (SETQ FOUND (NULL ITEMNAME)) + (WHILE (AND ITMS (NOT FOUND)) (SETQ ITEM (POP ITMS)) + (IF (OR (EQ ITEM ITEMNAME) + (AND (CONSP ITEM) + (OR (EQ ITEMNAME (CAR ITEM)) + (AND (STRINGP (CAR ITEM)) + (STRING= (STRINGIFY ITEMNAME) + (CAR ITEM))) + (EQ (CDR ITEM) ITEMNAME) + (AND (CONSP (CDR ITEM)) + (EQ (CADR ITEM) ITEMNAME))))) + (SETQ FOUND T))) + ITEM)) + +(DEFUN MENU-ITEM-Y (M ITEM) + (LET (FOUND ITMS ITM YBASE) + (SETQ YBASE (1- (EIGHTH M))) + (IF (AND (NINTH M) (PLUSP (LENGTH (NINTH M))) + (OR (CADDR M) *WINDOW-ADD-MENU-TITLE*)) + (INCF YBASE -15)) + (SETQ ITMS (NTH 12 M)) + (WHILE (AND ITMS (NOT FOUND)) (SETQ ITM (POP ITMS)) + (DECF YBASE (MENU-FIND-ITEM-HEIGHT M ITM)) + (SETQ FOUND (EQ ITEM ITM))) + YBASE)) + +(DEFUN MENU-FIND-ITEM-Y (M Y) + (LET (FOUND ITMS ITM YBASE) + (SETQ YBASE (1- (EIGHTH M))) + (IF (AND (NINTH M) (PLUSP (LENGTH (NINTH M))) + (OR (CADDR M) *WINDOW-ADD-MENU-TITLE*)) + (INCF YBASE -15)) + (SETQ ITMS (NTH 12 M)) + (WHILE (AND ITMS (NOT FOUND)) (SETQ ITM (POP ITMS)) + (DECF YBASE (MENU-FIND-ITEM-HEIGHT M ITM)) + (SETQ FOUND + (AND (>= Y YBASE) + (<= Y (+ YBASE (MENU-FIND-ITEM-HEIGHT M ITM)))))) + (AND FOUND ITM))) + +(DEFUN MENU-SELECT (M &OPTIONAL INSIDE) (MENU-SELECT-B M NIL INSIDE)) + +(DEFUN MENU-SELECT! (M) (MENU-SELECT-B M T NIL)) + +(DEFUN MENU-SELECT-B (M FLG INSIDE) + (PROG (RES) + LP + (SETQ RES (MENU-CHOOSE M INSIDE)) + (IF (AND FLG (NOT RES)) (GO LP)) + (IF (NOT (TENTH M)) + (IF (CADDR M) (PROGN (MENU-CLEAR M) (XFLUSH *WINDOW-DISPLAY*)) + (PROGN + (XUNMAPWINDOW *WINDOW-DISPLAY* (CADADR M)) + (XFLUSH *WINDOW-DISPLAY*) + (WINDOW-WAIT-UNMAP (CADR M))))) + (RETURN RES))) + +(DEFUN MENU-DESTROY (M) + (WHEN (NOT (CADDR M)) + (XDESTROYWINDOW *WINDOW-DISPLAY* (CADADR M)) + (XFLUSH *WINDOW-DISPLAY*) + (SETF (CADADR M) NIL) + (XFREEGC *WINDOW-DISPLAY* (CADDR (CADR M))) + (SETF (CADDR (CADR M)) NIL) + (SETF (CADR M) NIL))) + +(DEFUN MENU (ITEMS &OPTIONAL TITLE) + (LET (M RES) + (SETQ M (MENU-CREATE ITEMS TITLE)) + (SETQ RES (MENU-SELECT M)) + (MENU-DESTROY M) + RES)) + + + +(DEFUN MENU-CREATE (ITEMS &OPTIONAL TITLE PARENTW X Y PERM FLAT FONT) + (LIST 'MENU (IF FLAT PARENTW) FLAT (CADR PARENTW) X Y 0 0 + (IF TITLE (STRINGIFY TITLE) "") PERM FONT 0 ITEMS)) + +(DEFUN MENU-OFFSET (M) + (LIST (IF (CADDR M) (FIFTH M) 0) (IF (CADDR M) (SIXTH M) 0))) + +(DEFUN MENU-SIZE (M) + (IF (<= (SEVENTH M) 0) + (CASE (FIRST M) + (PICMENU (PICMENU-CALCULATE-SIZE M)) + (BARMENU (BARMENU-CALCULATE-SIZE M)) + (TEXTMENU (TEXTMENU-CALCULATE-SIZE M)) + (EDITMENU (EDITMENU-CALCULATE-SIZE M)) + (T (MENU-CALCULATE-SIZE M)))) + (LIST (SEVENTH M) (EIGHTH M))) + +(DEFUN MENU-MOVETO-XY (M X Y) + (WHEN (CADDR M) + (SETF (FIFTH M) X) + (SETF (SIXTH M) Y) + (MENU-ADJUST-OFFSET M))) + +(DEFUN MENU-REPOSITION (M) + (LET (SIZEV POS) + (WHEN (CADDR M) + (SETQ SIZEV (MENU-SIZE M)) + (SETQ POS + (WINDOW-GET-BOX-POSITION (CADR M) (CAR SIZEV) (CADR SIZEV))) + (MENU-MOVETO-XY M (CAR POS) (CADR POS))))) + +(DEFUN MENU-REPOSITION-LINE (M OFFSET TARGET) + (LET (SIZEV POS) + (WHEN (CADDR M) + (SETQ SIZEV (MENU-SIZE M)) + (SETQ POS + (WINDOW-GET-BOX-LINE-POSITION (CADR M) (CAR SIZEV) + (CADR SIZEV) (CAR OFFSET) (CADR OFFSET) (CAR TARGET) + (CADR TARGET))) + (MENU-MOVETO-XY M (CAR POS) (CADR POS))))) + + + +(DEFUN PICMENU-CREATE + (BUTTONS WIDTH HEIGHT DRAWFN &OPTIONAL TITLE DOTFLG PARENTW X Y + PERM FLAT FONT BOXFLG) + (PICMENU-CREATE-FROM-SPEC + (PICMENU-CREATE-SPEC BUTTONS WIDTH HEIGHT DRAWFN DOTFLG FONT) + TITLE PARENTW X Y PERM FLAT BOXFLG)) + + + +(DEFUN PICMENU-CREATE-SPEC + (BUTTONS WIDTH HEIGHT DRAWFN &OPTIONAL DOTFLG FONT) + (LIST 'PICMENU-SPEC WIDTH HEIGHT BUTTONS DOTFLG DRAWFN + (OR FONT '9X15))) + + + +(DEFUN PICMENU-CREATE-FROM-SPEC + (SPEC &OPTIONAL TITLE PARENTW X Y PERM FLAT BOXFLG) + (LIST 'PICMENU (IF FLAT PARENTW) FLAT (IF PARENTW (CADR PARENTW)) X Y + 0 0 (IF TITLE (STRINGIFY TITLE) "") PERM SPEC BOXFLG NIL NIL)) + +(DEFUN PICMENU-CALCULATE-SIZE (M) + (LET (MAXWIDTH MAXHEIGHT) + (SETQ MAXWIDTH + (MAX (IF (NINTH M) (+ 6 (* 9 (LENGTH (NINTH M)))) 0) + (CADR (NTH 10 M)))) + (SETQ MAXHEIGHT + (+ (IF (AND (NINTH M) (PLUSP (LENGTH (NINTH M))) + (OR (CADDR M) *WINDOW-ADD-MENU-TITLE*)) + 15 0) + (CADDR (NTH 10 M)))) + (SETF (SEVENTH M) MAXWIDTH) + (SETF (EIGHTH M) MAXHEIGHT))) + +(DEFUN PICMENU-INIT (M) + (PICMENU-CALCULATE-SIZE M) + (MENU-ADJUST-OFFSET M) + (IF (NOT (CADDR M)) + (SETF (CADR M) + (WINDOW-CREATE (SEVENTH M) (EIGHTH M) (OR (NINTH M) "") + (CADDDR M) (FIFTH M) (SIXTH M) (SEVENTH (NTH 10 M)))))) + +(DEFUN PICMENU-DRAW (M) + (LET (MW BOTTOM XZERO YZERO) + (OR (AND (CADR M) (PLUSP (EIGHTH M))) (PICMENU-INIT M)) + (SETQ MW (CADR M)) + (XMAPWINDOW *WINDOW-DISPLAY* (CADR MW)) + (XFLUSH *WINDOW-DISPLAY*) + (WINDOW-WAIT-EXPOSURE MW) + (MENU-CLEAR M) + (SETQ XZERO (IF (CADDR M) (FIFTH M) 0)) + (SETQ YZERO (IF (CADDR M) (SIXTH M) 0)) + (SETQ BOTTOM (+ YZERO (EIGHTH M))) + (WHEN (AND (NINTH M) (PLUSP (LENGTH (NINTH M))) + (OR (CADDR M) *WINDOW-ADD-MENU-TITLE*)) + (LET ((SSTR (STRINGIFY (STRINGIFY (NINTH M))))) + (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR MW) (CADDR MW) + (+ 3 XZERO) (+ 13 (- (CADDDR MW) BOTTOM)) + (GET-C-STRING SSTR) (LENGTH SSTR))) + (LET ((GC (CADDR MW))) + (SETQ *WINDOW-SAVE-FUNCTION* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 1 + *GC-VALUES*) + (XGCVALUES-FUNCTION *GC-VALUES*))) + (XSETFUNCTION *WINDOW-DISPLAY* GC 6) + (SETQ *WINDOW-SAVE-FOREGROUND* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 4 + *GC-VALUES*) + (XGCVALUES-FOREGROUND *GC-VALUES*))) + (XSETFOREGROUND *WINDOW-DISPLAY* GC + (LOGXOR *WINDOW-SAVE-FOREGROUND* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 8 + *GC-VALUES*) + (XGCVALUES-BACKGROUND *GC-VALUES*))))) + (XFILLRECTANGLE *WINDOW-DISPLAY* (CADR MW) (CADDR MW) XZERO + (- (CADDDR MW) BOTTOM) (SEVENTH M) 16) + (LET ((GC (CADDR MW))) + (XSETFUNCTION *WINDOW-DISPLAY* GC *WINDOW-SAVE-FUNCTION*) + (XSETFOREGROUND *WINDOW-DISPLAY* GC *WINDOW-SAVE-FOREGROUND*))) + (FUNCALL (SIXTH (NTH 10 M)) MW XZERO YZERO) + (IF (NTH 11 M) + (WINDOW-DRAW-BOX-XY MW XZERO YZERO (SEVENTH M) (EIGHTH M) 1)) + (IF (FIFTH (NTH 10 M)) + (DOLIST (B (CADDDR (NTH 10 M))) (PICMENU-DRAW-BUTTON M B))) + (SETF (NTH 12 M) NIL) + (XFLUSH *WINDOW-DISPLAY*))) + +(DEFUN PICMENU-DRAW-NAMED-BUTTON (M NM) + (PICMENU-DRAW-BUTTON M (ASSOC NM (CADDDR (NTH 10 M))))) + +(DEFUN PICMENU-SET-NAMED-BUTTON-COLOR (M NM COLOR) + (LET (LST) + (IF (SETQ LST (ASSOC NM (NTH 13 M))) (SETF (CADR LST) COLOR) + (PUSH (LIST NM COLOR) (NTH 13 M))))) + +(DEFUN PICMENU-DRAW-BUTTON (M B) + (LET ((MW (CADR M)) COL) + (LET ((GC (CADDR MW))) + (SETQ *WINDOW-SAVE-FUNCTION* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 1 *GC-VALUES*) + (XGCVALUES-FUNCTION *GC-VALUES*))) + (XSETFUNCTION *WINDOW-DISPLAY* GC 6) + (SETQ *WINDOW-SAVE-FOREGROUND* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 4 *GC-VALUES*) + (XGCVALUES-FOREGROUND *GC-VALUES*))) + (XSETFOREGROUND *WINDOW-DISPLAY* GC + (LOGXOR *WINDOW-SAVE-FOREGROUND* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 8 + *GC-VALUES*) + (XGCVALUES-BACKGROUND *GC-VALUES*))))) + (WINDOW-DRAW-BOX-XY MW + (+ -2 (+ (IF (CADDR M) (FIFTH M) 0) (CAADR B))) + (+ -2 (+ (IF (CADDR M) (SIXTH M) 0) (CADADR B))) 4 4 1) + (LET ((GC (CADDR MW))) + (XSETFUNCTION *WINDOW-DISPLAY* GC *WINDOW-SAVE-FUNCTION*) + (XSETFOREGROUND *WINDOW-DISPLAY* GC *WINDOW-SAVE-FOREGROUND*)) + (WHEN (SETQ COL (ASSOC (CAR B) (NTH 13 M))) + (WINDOW-SET-COLOR-RGB MW (CAADR COL) (CADADR COL) + (CADDR (CADR COL))) + (WINDOW-DRAW-BOX-XY MW + (1- (+ (IF (CADDR M) (FIFTH M) 0) (CAADR B))) + (1- (+ (IF (CADDR M) (SIXTH M) 0) (CADADR B))) 3 3 2) + (WINDOW-RESET-COLOR MW)))) + +(DEFUN PICMENU-DELETE-NAMED-BUTTON (M NAME) + (LET (B) + (WHEN (AND (SETQ B (ASSOC NAME (CADDDR (NTH 10 M)))) + (NOT (MEMBER NAME (NTH 12 M) :TEST #'EQUAL))) + (IF (FIFTH (NTH 10 M)) (PICMENU-DRAW-BUTTON M B)) + (PUSH NAME (NTH 12 M))) + (XFLUSH *WINDOW-DISPLAY*))) + +(DEFUN PICMENU-SELECT (M &OPTIONAL INSIDE ANYCLICK) + (LET (MW CURRENT-BUTTON ITEM ITEMS VAL XZERO YZERO CODEVAL) + (SETQ MW (OR (CADR M) (PICMENU-INIT M))) + (IF (NOT (TENTH M)) (PICMENU-DRAW M)) + (SETQ XZERO (IF (CADDR M) (FIFTH M) 0)) + (SETQ YZERO (IF (CADDR M) (SIXTH M) 0)) + (WINDOW-TRACK-MOUSE MW + #'(LAMBDA (X Y CODE) + (SETQ *WINDOW-MENU-CODE* CODE) + (DECF X XZERO) + (DECF Y YZERO) + (IF (AND (>= X 0) (<= X (SEVENTH M)) (>= Y 0) + (<= Y (EIGHTH M))) + (SETQ INSIDE T)) + (IF CURRENT-BUTTON + (WHEN (NOT (PICMENU-BUTTON-CONTAINSXY? CURRENT-BUTTON X + Y)) + (PICMENU-UNBOX-ITEM M CURRENT-BUTTON) + (SETQ CURRENT-BUTTON NIL))) + (WHEN (NOT CURRENT-BUTTON) + (SETQ ITEMS (CADDDR (NTH 10 M))) + (WHILE (AND (NOT CURRENT-BUTTON) (SETQ ITEM (POP ITEMS))) + (WHEN (AND (PICMENU-BUTTON-CONTAINSXY? ITEM X Y) + (NOT (MEMBER (CAR ITEM) (NTH 12 M) + :TEST #'EQUAL))) + (PICMENU-BOX-ITEM M ITEM) + (SETQ CURRENT-BUTTON ITEM)))) + (WHEN (OR (PLUSP CODE) + (AND INSIDE + (OR (MINUSP X) (> X (SEVENTH M)) (MINUSP Y) + (> Y (EIGHTH M))))) + (IF CURRENT-BUTTON (PICMENU-UNBOX-ITEM M CURRENT-BUTTON)) + (SETQ CODEVAL CODE) + (SETQ VAL + (IF (AND (PLUSP CODE) CURRENT-BUTTON) + CURRENT-BUTTON *PICMENU-NO-SELECTION*)))) + T) + (IF (NOT (TENTH M)) + (IF (CADDR M) (PROGN (MENU-CLEAR M) (XFLUSH *WINDOW-DISPLAY*)) + (PROGN + (XUNMAPWINDOW *WINDOW-DISPLAY* (CADADR M)) + (XFLUSH *WINDOW-DISPLAY*) + (WINDOW-WAIT-UNMAP (CADR M))))) + (IF (EQUAL VAL *PICMENU-NO-SELECTION*) + (AND (PLUSP CODEVAL) ANYCLICK) (CAR VAL)))) + +(DEFUN PICMENU-BOX-ITEM (M ITEM) + (LET ((MW (OR (CADR M) (PICMENU-INIT M))) XOFF YOFF SIZ) + (SETQ XOFF (+ (IF (CADDR M) (FIFTH M) 0) (CAADR ITEM))) + (SETQ YOFF (+ (IF (CADDR M) (SIXTH M) 0) (CADADR ITEM))) + (IF (CADDDR ITEM) + (FUNCALL (CADDDR ITEM) (OR (CADR M) (PICMENU-INIT M)) XOFF + YOFF) + (PROGN + (LET ((GC (CADDR MW))) + (SETQ *WINDOW-SAVE-FUNCTION* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 1 + *GC-VALUES*) + (XGCVALUES-FUNCTION *GC-VALUES*))) + (XSETFUNCTION *WINDOW-DISPLAY* GC 6) + (SETQ *WINDOW-SAVE-FOREGROUND* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 4 + *GC-VALUES*) + (XGCVALUES-FOREGROUND *GC-VALUES*))) + (XSETFOREGROUND *WINDOW-DISPLAY* GC + (LOGXOR *WINDOW-SAVE-FOREGROUND* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 8 + *GC-VALUES*) + (XGCVALUES-BACKGROUND *GC-VALUES*))))) + (IF (SETQ SIZ (CADDR ITEM)) + (WINDOW-DRAW-BOX-XY MW (- XOFF (TRUNCATE (CAR SIZ) 2)) + (- YOFF (TRUNCATE (CADR SIZ) 2)) (CAR SIZ) (CADR SIZ) + 1) + (WINDOW-DRAW-BOX-XY MW (+ -6 XOFF) (+ -6 YOFF) 12 12 1)) + (LET ((GC (CADDR MW))) + (XSETFUNCTION *WINDOW-DISPLAY* GC *WINDOW-SAVE-FUNCTION*) + (XSETFOREGROUND *WINDOW-DISPLAY* GC + *WINDOW-SAVE-FOREGROUND*)) + (XFLUSH *WINDOW-DISPLAY*))))) + +(DEFUN PICMENU-UNBOX-ITEM (M ITEM) + (IF (FIFTH ITEM) + (PROGN + (FUNCALL (FIFTH ITEM) (OR (CADR M) (PICMENU-INIT M)) + (CAADR ITEM) (CADADR ITEM)) + (XFLUSH *WINDOW-DISPLAY*)) + (PICMENU-BOX-ITEM M ITEM))) + +(DEFUN PICMENU-DESTROY (M) (MENU-DESTROY M)) + +(DEFUN PICMENU-BUTTON-CONTAINSXY? (B X Y) + (LET ((XSIZE 6) (YSIZE 6)) + (WHEN (CADDR B) + (SETQ XSIZE (TRUNCATE (CAADDR B) 2)) + (SETQ YSIZE (TRUNCATE (CADR (CADDR B)) 2))) + (AND (>= X (- (CAADR B) XSIZE)) (<= X (+ (CAADR B) XSIZE)) + (>= Y (- (CADADR B) YSIZE)) (<= Y (+ (CADADR B) YSIZE))))) + +(DEFUN PICMENU-ITEM-POSITION (M ITEMNAME &OPTIONAL PLACE) + (LET (B (XSIZE 0) (YSIZE 0) XOFF YOFF) + (IF (NULL ITEMNAME) + (PROGN + (SETQ XSIZE (SEVENTH M)) + (SETQ YSIZE (TRUNCATE (- (EIGHTH M) (CADDR (NTH 10 M))) 2)) + (SETQ XOFF (TRUNCATE XSIZE 2)) + (SETQ YOFF (+ (CADDR (NTH 10 M)) (TRUNCATE YSIZE 2)))) + (WHEN (SETQ B (ASSOC ITEMNAME (CADDDR (NTH 10 M)))) + (WHEN (CADDR B) + (SETQ XSIZE (CAADDR B)) + (SETQ YSIZE (CADR (CADDR B)))) + (SETQ XOFF (CAADR B)) + (SETQ YOFF (CADADR B)))) + (IF XOFF + (LIST (+ (+ (IF (CADDR M) (FIFTH M) 0) XOFF) + (CASE PLACE + ((CENTER TOP BOTTOM) 0) + (LEFT (- (TRUNCATE XSIZE 2))) + (RIGHT (TRUNCATE XSIZE 2)) + (T 0))) + (+ (+ (IF (CADDR M) (SIXTH M) 0) YOFF) + (CASE PLACE + ((CENTER RIGHT LEFT) 0) + (BOTTOM (- (TRUNCATE YSIZE 2))) + (TOP (TRUNCATE YSIZE 2)) + (T 0))))))) + + + +(DEFUN BARMENU-CREATE + (MAXVAL INITVAL BARWIDTH &OPTIONAL TITLE HORIZONTAL SUBTRACKFN + SUBTRACKPARMS PARENTW X Y PERM FLAT COLOR) + (LIST 'BARMENU (IF FLAT PARENTW) FLAT (IF PARENTW (CADR PARENTW)) + (OR X 0) (OR Y 0) 0 0 (IF TITLE (STRINGIFY TITLE) "") PERM + COLOR INITVAL MAXVAL BARWIDTH HORIZONTAL SUBTRACKFN + SUBTRACKPARMS)) + +(DEFUN BARMENU-CALCULATE-SIZE (M) + (LET (MAXWIDTH MAXHEIGHT) + (SETQ MAXWIDTH + (MAX (IF (NINTH M) (+ 6 (* 9 (LENGTH (NINTH M)))) 0) + (NTH 13 M))) + (SETQ MAXHEIGHT + (+ (IF (AND (NINTH M) (PLUSP (LENGTH (NINTH M))) + (OR (CADDR M) *WINDOW-ADD-MENU-TITLE*)) + 15 0) + (NTH 12 M))) + (SETF (SEVENTH M) MAXWIDTH) + (SETF (EIGHTH M) MAXHEIGHT))) + +(DEFUN BARMENU-INIT (M) + (BARMENU-CALCULATE-SIZE M) + (MENU-ADJUST-OFFSET M) + (IF (NOT (CADDR M)) + (SETF (CADR M) + (WINDOW-CREATE (SEVENTH M) (EIGHTH M) (OR (NINTH M) "") + (CADDDR M) (FIFTH M) (SIXTH M))))) + +(DEFUN BARMENU-DRAW (M) + (LET (MW XZERO YZERO) + (OR (AND (CADR M) (PLUSP (EIGHTH M))) (BARMENU-INIT M)) + (SETQ MW (CADR M)) + (XMAPWINDOW *WINDOW-DISPLAY* (CADR MW)) + (XFLUSH *WINDOW-DISPLAY*) + (WINDOW-WAIT-EXPOSURE MW) + (MENU-CLEAR M) + (SETQ XZERO + (+ (IF (CADDR M) (FIFTH M) 0) (TRUNCATE (SEVENTH M) 2))) + (SETQ YZERO (IF (CADDR M) (SIXTH M) 0)) + (IF (NTH 10 M) (WINDOW-SET-COLOR MW (NTH 10 M))) + (IF (NTH 14 M) + (LET ((QQWHEIGHT (CADDDR (CADR M)))) + (IF (AND (NTH 13 M) (/= (NTH 13 M) 1)) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR (CADR M)) + (OR (NTH 13 M) 1) 0 1 0)) + (XDRAWLINE *WINDOW-DISPLAY* (CADADR M) (CADDR (CADR M)) XZERO + (- QQWHEIGHT YZERO) (+ XZERO (NTH 11 M)) + (- QQWHEIGHT YZERO)) + (IF (AND (NTH 13 M) (/= (NTH 13 M) 1)) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR (CADR M)) 1 0 + 1 0))) + (LET ((QQWHEIGHT (CADDDR (CADR M)))) + (IF (AND (NTH 13 M) (/= (NTH 13 M) 1)) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR (CADR M)) + (OR (NTH 13 M) 1) 0 1 0)) + (XDRAWLINE *WINDOW-DISPLAY* (CADADR M) (CADDR (CADR M)) XZERO + (- QQWHEIGHT YZERO) XZERO + (- QQWHEIGHT (+ YZERO (NTH 11 M)))) + (IF (AND (NTH 13 M) (/= (NTH 13 M) 1)) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR (CADR M)) 1 0 + 1 0)))) + (IF (NTH 10 M) (WINDOW-RESET-COLOR MW)) + (XFLUSH *WINDOW-DISPLAY*))) + +(DEFUN BARMENU-SELECT (M &OPTIONAL INSIDE) + (declare (ignore inside)) + (LET (MW XZERO YZERO VAL) + (SETQ MW (OR (CADR M) (BARMENU-INIT M))) + (IF (NOT (TENTH M)) (BARMENU-DRAW M)) + (SETQ XZERO + (+ (IF (CADDR M) (FIFTH M) 0) (TRUNCATE (SEVENTH M) 2))) + (SETQ YZERO (IF (CADDR M) (SIXTH M) 0)) + (WHEN (WINDOW-TRACK-MOUSE-IN-REGION MW (IF (CADDR M) (FIFTH M) 0) + YZERO (SEVENTH M) (EIGHTH M) T T) + (WINDOW-TRACK-MOUSE MW + #'(LAMBDA (X Y CODE) + (SETQ *WINDOW-MENU-CODE* CODE) + (SETQ VAL (IF (NTH 14 M) (- X XZERO) (- Y YZERO))) + (BARMENU-UPDATE-VALUE M VAL) + (IF (PLUSP CODE) CODE))) + VAL))) + +(DEFVAR *BARMENU-UPDATE-VALUE-CONS* (CONS NIL NIL)) + +(DEFUN BARMENU-UPDATE-VALUE (M VAL) + (LET ((MW (OR (CADR M) (BARMENU-INIT M))) XZERO YZERO) + (SETQ VAL (MAX 0 (MIN VAL (NTH 12 M)))) + (WHEN (/= VAL (NTH 11 M)) + (IF (< VAL (NTH 11 M)) + (LET ((GC (CADDR MW))) + (SETQ *WINDOW-SAVE-FUNCTION* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 1 + *GC-VALUES*) + (XGCVALUES-FUNCTION *GC-VALUES*))) + (XSETFUNCTION *WINDOW-DISPLAY* GC 3) + (SETQ *WINDOW-SAVE-FOREGROUND* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 4 + *GC-VALUES*) + (XGCVALUES-FOREGROUND *GC-VALUES*))) + (XSETFOREGROUND *WINDOW-DISPLAY* GC + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 8 + *GC-VALUES*) + (XGCVALUES-BACKGROUND *GC-VALUES*)))) + (IF (NTH 10 M) (WINDOW-SET-COLOR MW (NTH 10 M)))) + (SETQ XZERO + (+ (IF (CADDR M) (FIFTH M) 0) (TRUNCATE (SEVENTH M) 2))) + (SETQ YZERO (IF (CADDR M) (SIXTH M) 0)) + (IF (NTH 14 M) + (LET ((QQWHEIGHT (CADDDR (CADR M)))) + (IF (AND (NTH 13 M) (/= (NTH 13 M) 1)) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR (CADR M)) + (OR (NTH 13 M) 1) 0 1 0)) + (XDRAWLINE *WINDOW-DISPLAY* (CADADR M) (CADDR (CADR M)) + (+ XZERO (NTH 11 M)) (- QQWHEIGHT YZERO) (+ XZERO VAL) + (- QQWHEIGHT YZERO)) + (IF (AND (NTH 13 M) (/= (NTH 13 M) 1)) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR (CADR M)) 1 + 0 1 0))) + (LET ((QQWHEIGHT (CADDDR (CADR M)))) + (IF (AND (NTH 13 M) (/= (NTH 13 M) 1)) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR (CADR M)) + (OR (NTH 13 M) 1) 0 1 0)) + (XDRAWLINE *WINDOW-DISPLAY* (CADADR M) (CADDR (CADR M)) + XZERO (- QQWHEIGHT (+ YZERO (NTH 11 M))) XZERO + (- QQWHEIGHT (+ YZERO VAL))) + (IF (AND (NTH 13 M) (/= (NTH 13 M) 1)) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR (CADR M)) 1 + 0 1 0)))) + (IF (< VAL (NTH 11 M)) + (LET ((GC (CADDR MW))) + (XSETFUNCTION *WINDOW-DISPLAY* GC *WINDOW-SAVE-FUNCTION*) + (XSETFOREGROUND *WINDOW-DISPLAY* GC + *WINDOW-SAVE-FOREGROUND*)) + (IF (NTH 10 M) (WINDOW-RESET-COLOR MW))) + (SETF (NTH 11 M) VAL) + (WHEN (NTH 15 M) + (SETF (CAR *BARMENU-UPDATE-VALUE-CONS*) VAL) + (SETF (CDR *BARMENU-UPDATE-VALUE-CONS*) (NTH 16 M)) + (APPLY (NTH 15 M) *BARMENU-UPDATE-VALUE-CONS*)) + (XFLUSH *WINDOW-DISPLAY*)))) + + + +(DEFUN TEXTMENU-CREATE + (WIDTH HEIGHT &OPTIONAL TITLE PARENTW X Y PERM FLAT FONT BOXFLG + INITIAL-TEXT) + (LIST 'TEXTMENU (IF FLAT PARENTW) FLAT (IF PARENTW (CADR PARENTW)) + (OR X 0) (OR Y 0) 0 0 (IF TITLE (STRINGIFY TITLE) "") PERM + INITIAL-TEXT WIDTH HEIGHT BOXFLG (OR FONT '9X15))) + +(DEFUN TEXTMENU-CALCULATE-SIZE (M) + (LET (MAXWIDTH MAXHEIGHT) + (SETQ MAXWIDTH + (MAX (IF (NINTH M) (+ 6 (* 9 (LENGTH (NINTH M)))) 0) + (NTH 11 M))) + (SETQ MAXHEIGHT + (+ (IF (AND (NINTH M) (PLUSP (LENGTH (NINTH M))) + (OR (CADDR M) *WINDOW-ADD-MENU-TITLE*)) + 15 0) + (NTH 12 M))) + (SETF (SEVENTH M) MAXWIDTH) + (SETF (EIGHTH M) MAXHEIGHT))) + +(DEFUN TEXTMENU-INIT (M) + (TEXTMENU-CALCULATE-SIZE M) + (MENU-ADJUST-OFFSET M) + (IF (NOT (CADDR M)) + (SETF (CADR M) + (WINDOW-CREATE (SEVENTH M) (EIGHTH M) (OR (NINTH M) "") + (CADDDR M) (FIFTH M) (SIXTH M) (NTH 14 M))))) + +(DEFUN TEXTMENU-DRAW (M) + (LET (MW BOTTOM XZERO YZERO) + (OR (AND (CADR M) (PLUSP (EIGHTH M))) (TEXTMENU-INIT M)) + (SETQ MW (CADR M)) + (XMAPWINDOW *WINDOW-DISPLAY* (CADR MW)) + (XFLUSH *WINDOW-DISPLAY*) + (WINDOW-WAIT-EXPOSURE MW) + (MENU-CLEAR M) + (SETQ XZERO (IF (CADDR M) (FIFTH M) 0)) + (SETQ YZERO (IF (CADDR M) (SIXTH M) 0)) + (SETQ BOTTOM (+ YZERO (EIGHTH M))) + (WHEN (AND (NINTH M) (PLUSP (LENGTH (NINTH M))) + (OR (CADDR M) *WINDOW-ADD-MENU-TITLE*)) + (LET ((SSTR (STRINGIFY (STRINGIFY (NINTH M))))) + (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR MW) (CADDR MW) + (+ 3 XZERO) (+ 13 (- (CADDDR MW) BOTTOM)) + (GET-C-STRING SSTR) (LENGTH SSTR))) + (LET ((GC (CADDR MW))) + (SETQ *WINDOW-SAVE-FUNCTION* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 1 + *GC-VALUES*) + (XGCVALUES-FUNCTION *GC-VALUES*))) + (XSETFUNCTION *WINDOW-DISPLAY* GC 6) + (SETQ *WINDOW-SAVE-FOREGROUND* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 4 + *GC-VALUES*) + (XGCVALUES-FOREGROUND *GC-VALUES*))) + (XSETFOREGROUND *WINDOW-DISPLAY* GC + (LOGXOR *WINDOW-SAVE-FOREGROUND* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR MW) 8 + *GC-VALUES*) + (XGCVALUES-BACKGROUND *GC-VALUES*))))) + (XFILLRECTANGLE *WINDOW-DISPLAY* (CADR MW) (CADDR MW) XZERO + (- (CADDDR MW) BOTTOM) (SEVENTH M) 16) + (LET ((GC (CADDR MW))) + (XSETFUNCTION *WINDOW-DISPLAY* GC *WINDOW-SAVE-FUNCTION*) + (XSETFOREGROUND *WINDOW-DISPLAY* GC *WINDOW-SAVE-FOREGROUND*))) + (IF (NTH 10 M) + (LET ((SSTR (STRINGIFY (NTH 10 M)))) + (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR MW) (CADDR MW) + (+ 10 XZERO) + (+ 8 (- (CADDDR MW) (+ YZERO (TRUNCATE (EIGHTH M) 2)))) + (GET-C-STRING SSTR) (LENGTH SSTR)))) + (IF (NTH 13 M) + (WINDOW-DRAW-BOX-XY MW XZERO YZERO (SEVENTH M) (EIGHTH M) 1)) + (XFLUSH *WINDOW-DISPLAY*))) + +(DEFUN TEXTMENU-SELECT (M &OPTIONAL INSIDE) + (declare (ignore inside)) + (LET (MW XZERO YZERO CODEVAL) + (SETQ MW (OR (CADR M) (TEXTMENU-INIT M))) + (IF (NOT (TENTH M)) (TEXTMENU-DRAW M)) + (SETQ XZERO (IF (CADDR M) (FIFTH M) 0)) + (SETQ YZERO (IF (CADDR M) (SIXTH M) 0)) + (WINDOW-TRACK-MOUSE MW + #'(LAMBDA (X Y CODE) + (SETQ *WINDOW-MENU-CODE* CODE) + (DECF X XZERO) + (DECF Y YZERO) + (IF (OR (PLUSP CODE) (MINUSP X) (> X (SEVENTH M)) + (MINUSP Y) (> Y (EIGHTH M))) + (SETQ CODEVAL CODE))) + T) + (WHEN (AND (NOT (TENTH M)) (NOT (CADDR M))) + (XUNMAPWINDOW *WINDOW-DISPLAY* (CADADR M)) + (XFLUSH *WINDOW-DISPLAY*) + (WINDOW-WAIT-UNMAP (CADR M))) + (WHEN (PLUSP CODEVAL) + (TEXTMENU-DRAW M) + (WINDOW-INPUT-STRING MW (NTH 10 M) (+ 10 XZERO) + (+ -8 (+ YZERO (TRUNCATE (EIGHTH M) 2))) (+ -12 (SEVENTH M)))))) + +(DEFUN TEXTMENU-SET-TEXT (M &OPTIONAL S) (SETF (NTH 10 M) (OR S ""))) + + + +(DEFUN WINDOW-GET-POINT (W) + (LET (ORGX ORGY) + (WINDOW-TRACK-MOUSE W + #'(LAMBDA (X Y CODE) + (WHEN (NOT (ZEROP CODE)) (SETQ ORGX X) (SETQ ORGY Y)))) + (LIST ORGX ORGY))) + + + +(DEFUN WINDOW-GET-CLICK (W) + (LET (ORGX ORGY BUTTON) + (WINDOW-TRACK-MOUSE W + #'(LAMBDA (X Y CODE) + (WHEN (NOT (ZEROP CODE)) + (SETQ BUTTON CODE) + (SETQ ORGX X) + (SETQ ORGY Y)))) + (LIST BUTTON (LIST ORGX ORGY)))) + + + +(DEFUN WINDOW-GET-LINE-POSITION (W ORGX ORGY) + (WINDOW-GET-ICON-POSITION W #'WINDOW-DRAW-LINE-XY + (LIST ORGX ORGY 1 'PAINT))) + + + +(DEFUN WINDOW-GET-LATEX-POSITION (W ORGX ORGY &OPTIONAL FLG) + (WINDOW-GET-ICON-POSITION W #'WINDOW-DRAW-LATEX-XY + (LIST ORGX ORGY FLG))) + + + +(DEFUN WINDOW-GET-BOX-POSITION (W WIDTH HEIGHT &OPTIONAL (DX 0) (DY 0)) + (WINDOW-GET-ICON-POSITION W #'WINDOW-DRAW-BOX-XY + (LIST WIDTH HEIGHT 1) DX DY)) + + + +(DEFUN WINDOW-GET-BOX-LINE-POSITION + (W WIDTH HEIGHT OFFX OFFY TOX TOY &OPTIONAL (DX 0) (DY 0)) + (WINDOW-GET-ICON-POSITION W #'WINDOW-DRAW-BOX-LINE-XY + (LIST WIDTH HEIGHT OFFX OFFY TOX TOY) DX DY)) + +(DEFUN WINDOW-DRAW-BOX-LINE-XY (W X Y WIDTH HEIGHT OFFX OFFY TOX TOY) + (WINDOW-DRAW-BOX-XY W X Y WIDTH HEIGHT) + (WINDOW-DRAW-LINE-XY W (+ X OFFX) (+ Y OFFY) TOX TOY)) + + + +(DEFUN WINDOW-GET-ICON-POSITION (W FN ARGS &OPTIONAL (DX 0) (DY 0)) + (LET (LASTX LASTY ARGL) + (SETQ ARGL (CONS W (CONS 0 (CONS 0 ARGS)))) + (WINDOW-SET-XOR W) + (WINDOW-TRACK-MOUSE W + #'(LAMBDA (X Y CODE) + (WHEN (OR (NULL LASTX) (/= X LASTX) (/= Y LASTY)) + (IF LASTX (APPLY FN ARGL)) + (RPLACA (CDR ARGL) (+ X DX)) + (RPLACA (CDDR ARGL) (+ Y DY)) + (APPLY FN ARGL) + (SETQ LASTX X) + (SETQ LASTY Y)) + (NOT (ZEROP CODE)))) + (APPLY FN ARGL) + (WINDOW-UNSET W) + (WINDOW-FORCE-OUTPUT W) + (LIST LASTX LASTY))) + + + +(DEFUN WINDOW-GET-REGION (W &OPTIONAL WID HT) + (LET (LASTX LASTY START END WIDTH HEIGHT PLACE OFFX OFFY STX STY) + (IF (AND (NUMBERP WID) (NUMBERP HT)) + (PROGN + (SETQ START + (WINDOW-GET-BOX-POSITION W WID HT (- WID) (- HT))) + (SETQ STX (- (CAR START) WID)) + (SETQ STY (- (CADR START) HT))) + (PROGN + (SETQ START (WINDOW-GET-POINT W)) + (SETQ STX (CAR START)) + (SETQ STY (CADR START)))) + (SETQ END + (WINDOW-GET-ICON-POSITION W #'WINDOW-DRAW-BOX-CORNERS + (LIST STX STY 1))) + (SETQ LASTX (CAR END)) + (SETQ LASTY (CADR END)) + (SETQ WIDTH (ABS (- STX LASTX))) + (SETQ HEIGHT (ABS (- STY LASTY))) + (SETQ OFFX (- (MIN STX LASTX) LASTX)) + (SETQ OFFY (- (MIN STY LASTY) LASTY)) + (SETQ PLACE (WINDOW-GET-BOX-POSITION W WIDTH HEIGHT OFFX OFFY)) + (LIST (LIST (+ OFFX (FIRST PLACE)) (+ OFFY (SECOND PLACE))) + (LIST WIDTH HEIGHT)))) + + + +(DEFUN WINDOW-GET-BOX-SIZE (W OFFSETX OFFSETY) + (LET (LEGENDY LASTX LASTY DX DY) + (SETQ OFFSETY (MAX OFFSETY 30)) + (SETQ LEGENDY (- OFFSETY 25)) + (WINDOW-ERASE-AREA-XY W OFFSETX LEGENDY 71 21) + (WINDOW-DRAW-BOX-XY W OFFSETX LEGENDY 70 20) + (WINDOW-TRACK-MOUSE W + #'(LAMBDA (X Y CODE) + (WHEN (OR (NULL LASTX) (/= X LASTX) (/= Y LASTY)) + (IF LASTX + (WINDOW-XOR-BOX-XY W OFFSETX OFFSETY + (- LASTX OFFSETX) (- LASTY OFFSETY))) + (SETQ LASTX NIL) + (SETQ DX (- X OFFSETX)) + (SETQ DY (- Y OFFSETY)) + (WHEN (AND (> DX 0) (> DY 0)) + (WINDOW-XOR-BOX-XY W OFFSETX OFFSETY DX DY) + (WINDOW-PRINTAT-XY W (FORMAT NIL "~3D x ~3D" DX DY) + (+ OFFSETX 3) (+ LEGENDY 5)) + (SETQ LASTX X) + (SETQ LASTY Y))) + (NOT (ZEROP CODE)))) + (IF LASTX + (WINDOW-XOR-BOX-XY W OFFSETX OFFSETY (- LASTX OFFSETX) + (- LASTY OFFSETY))) + (WINDOW-ERASE-AREA-XY W OFFSETX LEGENDY 71 21) + (WINDOW-FORCE-OUTPUT W) + (LIST DX DY))) + + + +(DEFUN WINDOW-TRACK-MOUSE-IN-REGION + (W OFFSETX OFFSETY SIZEX SIZEY &OPTIONAL BOXFLG INSIDE) + (LET (RES) + (WHEN BOXFLG + (WINDOW-SET-XOR W) + (WINDOW-DRAW-BOX-XY W (- OFFSETX 4) (- OFFSETY 4) (+ SIZEX 8) + (+ SIZEY 8)) + (WINDOW-UNSET W) + (WINDOW-FORCE-OUTPUT W)) + (SETQ RES + (WINDOW-TRACK-MOUSE W + #'(LAMBDA (X Y CODE) + (IF (> CODE 0) (IF INSIDE (LIST CODE (LIST X Y)) T) + (IF (OR (< X OFFSETX) (> X (+ OFFSETX SIZEX)) + (< Y OFFSETY) (> Y (+ OFFSETY SIZEY))) + INSIDE (AND (SETQ INSIDE T) NIL)))))) + (WHEN BOXFLG + (WINDOW-SET-XOR W) + (WINDOW-DRAW-BOX-XY W (- OFFSETX 4) (- OFFSETY 4) (+ SIZEX 8) + (+ SIZEY 8)) + (WINDOW-UNSET W) + (WINDOW-FORCE-OUTPUT W)) + (IF (CONSP RES) RES))) + + + +(DEFUN WINDOW-ADJUST-BOX-SIDE (W ORGX ORGY WIDTH HEIGHT SIDE) + (LET (NEW (XX ORGX) (YY ORGY) (WW WIDTH) (HH HEIGHT)) + (SETQ NEW + (WINDOW-GET-ICON-POSITION W #'WINDOW-ADJ-BOX-XY + (LIST ORGX ORGY WIDTH HEIGHT SIDE))) + (CASE SIDE + (LEFT (SETQ XX (CAR NEW)) (SETQ WW (+ WIDTH (- ORGX (CAR NEW))))) + (RIGHT (SETQ WW (- (CAR NEW) ORGX))) + (TOP (SETQ HH (- (CADR NEW) ORGY))) + (BOTTOM (SETQ YY (CADR NEW)) + (SETQ HH (+ HEIGHT (- ORGY (CADR NEW)))))) + (LIST (LIST XX YY) (LIST WW HH)))) + +(DEFUN WINDOW-ADJ-BOX-XY (W X Y ORGX ORGY WIDTH HEIGHT SIDE) + (LET ((XX ORGX) (YY ORGY) (WW WIDTH) (HH HEIGHT)) + (CASE SIDE + (LEFT (SETQ XX X) (SETQ WW (+ WIDTH (- ORGX X)))) + (RIGHT (SETQ WW (- X ORGX))) + (TOP (SETQ HH (- Y ORGY))) + (BOTTOM (SETQ YY Y) (SETQ HH (+ HEIGHT (- ORGY Y))))) + (WINDOW-DRAW-BOX-XY W XX YY WW HH))) + + + +(DEFUN WINDOW-GET-CIRCLE (W &OPTIONAL CENTER) + (LET (PT) + (OR CENTER (SETQ CENTER (WINDOW-GET-CROSSHAIRS W))) + (SETQ PT + (WINDOW-GET-ICON-POSITION W #'WINDOW-DRAW-CIRCLE-PT + (LIST CENTER))) + (LIST CENTER (WINDOW-CIRCLE-RADIUS (CAR PT) (CADR PT) CENTER)))) + +(DEFUN WINDOW-CIRCLE-RADIUS (X Y CENTER) + (LET ((DX (- X (CAR CENTER))) (DY (- Y (CADR CENTER)))) + (TRUNCATE (+ 0.5 (SQRT (+ (* DX DX) (* DY DY))))))) + +(DEFUN WINDOW-DRAW-CIRCLE-PT (W X Y CENTER) + (WINDOW-DRAW-CIRCLE W CENTER (WINDOW-CIRCLE-RADIUS X Y CENTER) 1)) + + + +(DEFUN WINDOW-GET-ELLIPSE (W &OPTIONAL CENTER) + (LET (CIR RADIUSX PT) + (SETQ CIR (WINDOW-GET-CIRCLE W CENTER)) + (SETQ CENTER (CAR CIR)) + (SETQ RADIUSX (CADR CIR)) + (SETQ PT + (WINDOW-GET-ICON-POSITION W #'WINDOW-DRAW-ELLIPSE-PT + (LIST CENTER RADIUSX))) + (LIST CENTER (LIST RADIUSX (ABS (- (CADR PT) (CADR CENTER))))))) + +(DEFUN WINDOW-DRAW-ELLIPSE-PT (W X Y CENTER RADIUSX) + (declare (ignore x)) + (WINDOW-DRAW-ELLIPSE-XY W (CAR CENTER) (CADR CENTER) RADIUSX + (ABS (- Y (CADR CENTER))))) + +(DEFUN WINDOW-DRAW-VECTOR-PT (W X Y CENTER RADIUS) + (LET (DX DY THETA) + (SETQ DY (- Y (CADR CENTER))) + (SETQ DX (- X (CAR CENTER))) + (WHEN (OR (/= DX 0) (/= DY 0)) + (SETQ THETA (ATAN (- Y (CADR CENTER)) (- X (CAR CENTER)))) + (WINDOW-DRAW-LINE-XY W (CAR CENTER) (CADR CENTER) + (+ (CAR CENTER) (* RADIUS (COS THETA))) + (+ (CADR CENTER) (* RADIUS (SIN THETA))))))) + + + +(DEFUN WINDOW-GET-VECTOR-END (W CENTER RADIUS) + (WINDOW-GET-ICON-POSITION W #'WINDOW-DRAW-VECTOR-PT + (LIST CENTER RADIUS))) + + + +(DEFUN WINDOW-GET-CROSSHAIRS (W) + (WINDOW-GET-ICON-POSITION W #'WINDOW-DRAW-CROSSHAIRS-XY NIL)) + +(DEFUN WINDOW-DRAW-CROSSHAIRS-XY (W X Y) + (WINDOW-DRAW-LINE-XY W (- X 12) Y (- X 3) Y) + (WINDOW-DRAW-LINE-XY W (+ X 3) Y (+ X 12) Y) + (WINDOW-DRAW-LINE-XY W X (- Y 12) X (- Y 3)) + (WINDOW-DRAW-LINE-XY W X (+ Y 3) X (+ Y 12))) + + + +(DEFUN WINDOW-GET-CROSS (W) + (WINDOW-GET-ICON-POSITION W #'WINDOW-DRAW-CROSS-XY NIL)) + +(DEFUN WINDOW-DRAW-CROSS-XY (W X Y) + (WINDOW-DRAW-LINE-XY W (- X 10) (- Y 10) (+ X 10) (+ Y 10) 2) + (WINDOW-DRAW-LINE-XY W (+ X 10) (- Y 10) (- X 10) (+ Y 10) 2)) + +(DEFUN WINDOW-DRAW-DOT-XY (W X Y) + (WINDOW-DRAW-CIRCLE-XY W X Y 1) + (WINDOW-DRAW-CIRCLE-XY W X Y 2) + (WINDOW-DRAW-LINE-XY W X Y (+ X 1) Y 1)) + +(DEFUN WINDOW-DRAW-LATEX-XY (W X Y ORGX ORGY FLG) + (LET (DX DY DELX DELY N RATIO CD NRAT) + (SETQ DX (- X ORGX)) + (SETQ DY (- Y ORGY)) + (IF (OR (= DX 0) (= DY 0)) (WINDOW-DRAW-LINE-XY W X Y ORGX ORGY) + (PROGN + (SETQ N (IF FLG 4 6)) + (IF (> (ABS DY) (ABS DX)) + (PROGN + (SETQ RATIO (ROUND (/ (* (ABS DX) N) (ABS DY)))) + (SETQ CD (GCD N RATIO)) + (SETQ N (/ N CD)) + (SETQ RATIO (/ RATIO CD)) + (SETQ NRAT (ROUND (/ (ABS DY) N))) + (SETQ DELY (* (SIGNUM DY) NRAT N)) + (SETQ DELX (* (SIGNUM DX) NRAT RATIO))) + (PROGN + (SETQ RATIO (ROUND (/ (* (ABS DY) N) (ABS DX)))) + (SETQ CD (GCD N RATIO)) + (SETQ N (/ N CD)) + (SETQ RATIO (/ RATIO CD)) + (SETQ NRAT (ROUND (/ (ABS DX) N))) + (SETQ DELX (* (SIGNUM DX) NRAT N)) + (SETQ DELY (* (SIGNUM DY) NRAT RATIO)))) + (WINDOW-DRAW-LINE-XY W (+ ORGX DELX) (+ ORGY DELY) ORGX ORGY))))) + +(DEFUN WINDOW-RESET-COLOR (W) + (XSETFOREGROUND *WINDOW-DISPLAY* (CADDR W) *DEFAULT-FG-COLOR*) + (XSETBACKGROUND *WINDOW-DISPLAY* (CADDR W) *DEFAULT-BG-COLOR*)) + +(DEFUN WINDOW-SET-COLOR-RGB (W R G B &OPTIONAL BACKGROUND) + (LET (RET) + (OR *WINDOW-XCOLOR* (SETQ *WINDOW-XCOLOR* (MAKE-XCOLOR))) + (SET-XCOLOR-RED *WINDOW-XCOLOR* (+ R 0)) + (SET-XCOLOR-GREEN *WINDOW-XCOLOR* (+ G 0)) + (SET-XCOLOR-BLUE *WINDOW-XCOLOR* (+ B 0)) + (SETQ RET + (XALLOCCOLOR *WINDOW-DISPLAY* *DEFAULT-COLORMAP* + *WINDOW-XCOLOR*)) + (IF (NOT (EQL RET 0)) + (WINDOW-SET-XCOLOR W *WINDOW-XCOLOR* BACKGROUND)))) + +(DEFUN WINDOW-SET-XCOLOR (W &OPTIONAL XCOLOR BACKGROUND) + (IF BACKGROUND (WINDOW-SET-BACKGROUND W (XCOLOR-PIXEL XCOLOR)) + (WINDOW-SET-FOREGROUND W (XCOLOR-PIXEL XCOLOR))) + XCOLOR) + +(DEFUN WINDOW-SET-COLOR (W RGB &OPTIONAL BACKGROUND) + (WINDOW-SET-COLOR-RGB W (FIRST RGB) (SECOND RGB) (THIRD RGB) + BACKGROUND)) + +(DEFUN WINDOW-FREE-COLOR (W &OPTIONAL XCOLOR) + (declare (ignore w)) + (OR XCOLOR (SETQ XCOLOR *WINDOW-XCOLOR*)) + (IF XCOLOR + (UNLESS (OR (EQL XCOLOR *DEFAULT-FG-COLOR*) + (EQL XCOLOR *DEFAULT-BG-COLOR*)) + (XFREECOLORS *WINDOW-DISPLAY* *DEFAULT-COLORMAP* XCOLOR 1 0)))) + +(DEFUN WINDOW-GET-CHARS (W FN &OPTIONAL ARGS) + (LET (WIN RES) + (OR *WINDOW-KEYINIT* (WINDOW-INIT-KEYMAP)) + (SETQ *WINDOW-SHIFT* NIL) + (SETQ *WINDOW-CTRL* NIL) + (SETQ *WINDOW-META* NIL) + (SETQ WIN (WINDOW-PARENT W)) + (XSYNC *WINDOW-DISPLAY* 1) + (XSELECTINPUT *WINDOW-DISPLAY* WIN + (+ KEYPRESSMASK KEYRELEASEMASK BUTTONPRESSMASK)) + (WHILE (NULL RES) (XNEXTEVENT *WINDOW-DISPLAY* *WINDOW-EVENT*) + (LET ((TYPE (XANYEVENT-TYPE *WINDOW-EVENT*)) + (EVENTWINDOW (XANYEVENT-WINDOW *WINDOW-EVENT*))) + (IF (EQL EVENTWINDOW WIN) + (SETQ RES (WINDOW-PROCESS-CHAR-EVENT W TYPE FN ARGS))))) + RES)) + +(DEFUN WINDOW-PROCESS-CHAR-EVENT (W TYPE FN ARGS) + (LET (CODE) + (IF (EQL TYPE KEYRELEASE) + (PROGN + (SETQ CODE (XBUTTONEVENT-BUTTON *WINDOW-EVENT*)) + (IF (MEMBER CODE *WINDOW-SHIFT-KEYS*) + (SETQ *WINDOW-SHIFT* NIL) + (IF (MEMBER CODE *WINDOW-CONTROL-KEYS*) + (SETQ *WINDOW-CTRL* NIL) + (IF (MEMBER CODE *WINDOW-META-KEYS*) + (SETQ *WINDOW-META* NIL))))) + (IF (EQL TYPE KEYPRESS) + (PROGN + (SETQ CODE (XBUTTONEVENT-BUTTON *WINDOW-EVENT*)) + (IF (MEMBER CODE *WINDOW-SHIFT-KEYS*) + (PROGN (SETQ *WINDOW-SHIFT* T) NIL) + (IF (MEMBER CODE *WINDOW-CONTROL-KEYS*) + (PROGN (SETQ *WINDOW-CTRL* T) NIL) + (IF (MEMBER CODE *WINDOW-META-KEYS*) + (PROGN (SETQ *WINDOW-META* T) NIL) + (FUNCALL FN W (WINDOW-CHAR-DECODE CODE) 0 0 0 + ARGS))))) + (IF (EQL TYPE BUTTONPRESS) + (FUNCALL FN W 0 (XBUTTONEVENT-BUTTON *WINDOW-EVENT*) + (XMOTIONEVENT-X *WINDOW-EVENT*) + (- (WINDOW-DRAWABLE-HEIGHT W) + (XMOTIONEVENT-Y *WINDOW-EVENT*)) + ARGS)))))) + +(DEFUN WINDOW-CHAR-DECODE (CODE) + (LET (CHAR) + (SETQ CHAR + (AREF (IF *WINDOW-SHIFT* *WINDOW-SHIFTKEYMAP* + *WINDOW-KEYMAP*) + CODE)) + (IF (AND CHAR *WINDOW-CTRL*) + (SETQ CHAR (CODE-CHAR (- (CHAR-CODE (CHAR-UPCASE CHAR)) 64)))) + (IF (AND CHAR *WINDOW-META*) + (SETQ CHAR (CODE-CHAR (+ (CHAR-CODE (CHAR-UPCASE CHAR)) 128)))) + (OR CHAR #\Space))) + +(DEFUN WINDOW-GET-RAW-CHAR (W) + (LET (WIN RES) + (OR *WINDOW-KEYINIT* (WINDOW-INIT-KEYMAP)) + (SETQ *WINDOW-SHIFT* NIL) + (SETQ *WINDOW-CTRL* NIL) + (SETQ *WINDOW-META* NIL) + (SETQ WIN (WINDOW-PARENT W)) + (XSYNC *WINDOW-DISPLAY* 1) + (XSELECTINPUT *WINDOW-DISPLAY* WIN (+ KEYPRESSMASK KEYRELEASEMASK)) + (WHILE (NULL RES) (XNEXTEVENT *WINDOW-DISPLAY* *WINDOW-EVENT*) + (LET ((TYPE (XANYEVENT-TYPE *WINDOW-EVENT*)) + (EVENTWINDOW (XANYEVENT-WINDOW *WINDOW-EVENT*))) + (IF (AND (EQL EVENTWINDOW WIN) (EQL TYPE KEYPRESS)) + (SETQ RES (XBUTTONEVENT-BUTTON *WINDOW-EVENT*))))) + RES)) + +(DEFUN WINDOW-INPUT-STRING (W STR X Y &OPTIONAL SIZE) + (CAR (WINDOW-EDIT W X Y (OR SIZE 100) 16 (LIST (OR STR "")) NIL T T))) + +(DEFUN WINDOW-EDIT + (W X Y WIDTH HEIGHT &OPTIONAL STRINGS BOXFLG SCROLL ENDP) + (LET (EM) + (SETQ EM + (EDITMENU-CREATE WIDTH HEIGHT NIL W X Y NIL T '9X15 BOXFLG + STRINGS SCROLL ENDP)) + (EDITMENU-EDIT EM) + (EDITMENU-CARAT EM) + (NTH 10 EM))) + + + +(DEFUN EDITMENU-CREATE + (WIDTH HEIGHT &OPTIONAL TITLE PARENTW X Y PERM FLAT FONT BOXFLG + INITIAL-TEXT SCROLLVAL ENDP) + (LIST 'EDITMENU (IF FLAT PARENTW) FLAT (IF PARENTW (CADR PARENTW)) + (OR X 0) (OR Y 0) 0 0 (IF TITLE (STRINGIFY TITLE) "") PERM + (OR INITIAL-TEXT (LIST "")) WIDTH HEIGHT BOXFLG (OR FONT '9X15) + (IF ENDP + (LENGTH (NTH (IF (NUMBERP SCROLLVAL) SCROLLVAL 0) + INITIAL-TEXT)) + 0) + (IF (NUMBERP SCROLLVAL) SCROLLVAL 0) (OR SCROLLVAL 0))) + +(DEFUN EDITMENU-CALCULATE-SIZE (M) + (SETF (SEVENTH M) (NTH 11 M)) + (SETF (EIGHTH M) (NTH 12 M))) + +(DEFUN EDITMENU-INIT (M) + (EDITMENU-CALCULATE-SIZE M) + (MENU-ADJUST-OFFSET M) + (IF (NOT (CADDR M)) + (SETF (CADR M) + (WINDOW-CREATE (SEVENTH M) (EIGHTH M) (OR (NINTH M) "") + (CADDDR M) (FIFTH M) (SIXTH M) (NTH 14 M))))) + +(DEFUN EDITMENU-DRAW (M) + (LET (MW XZERO YZERO) + (OR (AND (CADR M) (PLUSP (EIGHTH M))) (EDITMENU-INIT M)) + (SETQ MW (CADR M)) + (XMAPWINDOW *WINDOW-DISPLAY* (CADR MW)) + (XFLUSH *WINDOW-DISPLAY*) + (WINDOW-WAIT-EXPOSURE MW) + (MENU-CLEAR M) + (SETQ XZERO (IF (CADDR M) (FIFTH M) 0)) + (SETQ YZERO (IF (CADDR M) (SIXTH M) 0)) + (IF (NTH 13 M) + (WINDOW-DRAW-BOX-XY MW XZERO YZERO (SEVENTH M) (EIGHTH M) 1)) + (EDITMENU-DISPLAY M 0 0 (NOT (NUMBERP (NTH 17 M)))))) + +(DEFUN EDITMENU-DISPLAY (M LINE CHAR ONLY) + (LET (LINES Y MAXWIDTH LINEWIDTH (W (OR (CADR M) (EDITMENU-INIT M)))) + (SETQ LINES (NTHCDR LINE (NTH 10 M))) + (SETQ Y + (+ (IF (CADDR M) (SIXTH M) 0) + (- (EIGHTH M) + (1- (* (WINDOW-STRING-HEIGHT + (OR (CADR M) (EDITMENU-INIT M)) "Tg") + (1+ (- (- LINE + (IF (NUMBERP (NTH 17 M)) (NTH 17 M) 0)) + (IF (NUMBERP (NTH 17 M)) (NTH 17 M) 0)))))))) + (SETQ MAXWIDTH + (TRUNCATE (+ -6 (SEVENTH M)) + (LET ((SSTR (STRINGIFY "W"))) + (XTEXTWIDTH (SEVENTH (OR (CADR M) (EDITMENU-INIT M))) + (GET-C-STRING SSTR) (LENGTH SSTR))))) + (WHILE (AND LINES (>= Y (+ 4 (IF (CADDR M) (SIXTH M) 0)))) + (IF (< CHAR MAXWIDTH) + (IF (PLUSP CHAR) + (LET ((SSTR (STRINGIFY + (SUBSEQ (FIRST LINES) CHAR + (MIN MAXWIDTH + (LENGTH (FIRST LINES))))))) + (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) + (CADDR W) + (+ (IF (CADDR M) (FIFTH M) 0) + (+ 2 + (* CHAR + (LET ((SSTR (STRINGIFY "W"))) + (XTEXTWIDTH + (SEVENTH + (OR (CADR M) (EDITMENU-INIT M))) + (GET-C-STRING SSTR) (LENGTH SSTR)))))) + (- (CADDDR W) Y) (GET-C-STRING SSTR) + (LENGTH SSTR))) + (LET ((SSTR (STRINGIFY + (IF + (<= (LENGTH (FIRST LINES)) + MAXWIDTH) + (FIRST LINES) + (SUBSEQ (FIRST LINES) 0 MAXWIDTH))))) + (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) + (CADDR W) (+ 2 (IF (CADDR M) (FIFTH M) 0)) + (- (CADDDR W) Y) (GET-C-STRING SSTR) + (LENGTH SSTR))))) + (SETQ LINEWIDTH + (+ 2 + (* (LET ((SSTR (STRINGIFY "W"))) + (XTEXTWIDTH + (SEVENTH (OR (CADR M) (EDITMENU-INIT M))) + (GET-C-STRING SSTR) (LENGTH SSTR))) + (LENGTH (FIRST LINES))))) + (WINDOW-ERASE-AREA-XY W + (+ (IF (CADDR M) (FIFTH M) 0) LINEWIDTH) (+ -2 Y) + (+ -2 (- (SEVENTH M) LINEWIDTH)) + (WINDOW-STRING-HEIGHT (OR (CADR M) (EDITMENU-INIT M)) + "Tg")) + (DECF Y + (WINDOW-STRING-HEIGHT (OR (CADR M) (EDITMENU-INIT M)) + "Tg")) + (IF ONLY (SETQ LINES NIL) + (PROGN + (POP LINES) + (IF (AND (NULL LINES) + (>= Y (+ 4 (IF (CADDR M) (SIXTH M) 0)))) + (WINDOW-ERASE-AREA-XY W + (+ 2 (IF (CADDR M) (FIFTH M) 0)) (+ -2 Y) + (+ -4 (SEVENTH M)) + (WINDOW-STRING-HEIGHT + (OR (CADR M) (EDITMENU-INIT M)) "Tg"))))) + (SETQ CHAR 0)) + (XFLUSH *WINDOW-DISPLAY*))) + +(DEFUN EDITMENU-CARAT (M) + (WINDOW-DRAW-CARAT (OR (CADR M) (EDITMENU-INIT M)) + (+ (IF (CADDR M) (FIFTH M) 0) + (+ 2 + (* (NTH 15 M) + (LET ((SSTR (STRINGIFY "W"))) + (XTEXTWIDTH (SEVENTH (OR (CADR M) (EDITMENU-INIT M))) + (GET-C-STRING SSTR) (LENGTH SSTR)))))) + (+ -2 + (+ (IF (CADDR M) (SIXTH M) 0) + (- (EIGHTH M) + (1- (* (WINDOW-STRING-HEIGHT + (OR (CADR M) (EDITMENU-INIT M)) "Tg") + (1+ (- (NTH 16 M) + (IF (NUMBERP (NTH 17 M)) (NTH 17 M) 0))))))))) + (XFLUSH *WINDOW-DISPLAY*)) + +(DEFUN EDITMENU-ERASE (M ONEP) + (LET ((W (OR (CADR M) (EDITMENU-INIT M))) XW) + (SETQ XW + (+ 2 + (* (LET ((SSTR (STRINGIFY "W"))) + (XTEXTWIDTH (SEVENTH W) (GET-C-STRING SSTR) + (LENGTH SSTR))) + (NTH 15 M)))) + (LET ((GLVAR423 (WINDOW-STRING-HEIGHT W "Tg"))) + (XCLEARAREA *WINDOW-DISPLAY* (CADR W) + (+ (IF (CADDR M) (FIFTH M) 0) XW) + (- (CADDDR W) + (1- (+ (- (+ (IF (CADDR M) (SIXTH M) 0) + (- (EIGHTH M) + (1- (* (WINDOW-STRING-HEIGHT + (OR (CADR M) (EDITMENU-INIT M)) + "Tg") + (1+ + (- (NTH 16 M) + (IF (NUMBERP (NTH 17 M)) + (NTH 17 M) 0))))))) + (CADR (LET ((SSTR (STRINGIFY "Tg"))) + (XTEXTEXTENTS (SEVENTH W) + (GET-C-STRING SSTR) (LENGTH SSTR) + *DIRECTION-RETURN* *ASCENT-RETURN* + *DESCENT-RETURN* *OVERALL-RETURN*) + (LIST (INT-POS *ASCENT-RETURN* 0) + (INT-POS *DESCENT-RETURN* 0))))) + GLVAR423))) + (IF ONEP + (LET ((SSTR (STRINGIFY "W"))) + (XTEXTWIDTH (SEVENTH W) (GET-C-STRING SSTR) + (LENGTH SSTR))) + (- (SEVENTH M) XW)) + GLVAR423 0)) + (XFLUSH *WINDOW-DISPLAY*))) + +(DEFUN EDITMENU-LINE-Y (M LINE) + (+ (IF (CADDR M) (SIXTH M) 0) + (- (EIGHTH M) + (1- (* (WINDOW-STRING-HEIGHT (OR (CADR M) (EDITMENU-INIT M)) + "Tg") + (1+ (- LINE (IF (NUMBERP (NTH 17 M)) (NTH 17 M) 0)))))))) + +(DEFUN EDITMENU-SELECT (M &OPTIONAL INSIDE) + (declare (ignore inside)) + (LET (MW CODEVAL XVAL YVAL) + (SETQ MW (OR (CADR M) (EDITMENU-INIT M))) + (IF (NOT (TENTH M)) (EDITMENU-DRAW M)) + (WINDOW-TRACK-MOUSE MW + #'(LAMBDA (X Y CODE) + (SETQ *WINDOW-MENU-CODE* CODE) + (WHEN (OR (PLUSP CODE) (< X (FIFTH M)) + (> X (+ (FIFTH M) (SEVENTH M))) (< Y (SIXTH M)) + (> Y (+ (SIXTH M) (EIGHTH M)))) + (SETQ CODEVAL CODE) + (SETQ XVAL X) + (SETQ YVAL Y))) + T) + (IF (PLUSP CODEVAL) (EDITMENU-EDIT M CODEVAL XVAL YVAL)))) + +(DEFVAR *WINDOW-EDITMENU-KILL-STRINGS* NIL) + +(DEFUN EDITMENU-EDIT (M &OPTIONAL CODE X Y) + (LET ((MW (OR (CADR M) (EDITMENU-INIT M)))) + (EDITMENU-DRAW M) + (EDITMENU-CARAT M) + (IF CODE (EDITMENU-EDIT-FN MW NIL CODE X Y (LIST M))) + (SETQ *WINDOW-EDITMENU-KILL-STRINGS* NIL) + (WINDOW-GET-CHARS MW #'EDITMENU-EDIT-FN (LIST M)) + (NTH 10 M))) + +(DEFUN EDITMENU-EDIT-FN (W CHAR BUTTON BUTTONX BUTTONY ARGS) + (declare (ignore w)) + (LET (M INSIDE DONE) + (SETQ M (CAR ARGS)) + (EDITMENU-CARAT M) + (IF (AND (NUMBERP BUTTON) (NOT (ZEROP BUTTON))) + (PROGN + (SETQ INSIDE (EDITMENU-SETXY M BUTTONX BUTTONY)) + (CASE BUTTON + (1 (IF INSIDE (PROGN (EDITMENU-CARAT M) NIL) T)) + (2 (WHEN INSIDE (EDITMENU-YANK M) (EDITMENU-CARAT M) NIL)))) + (PROGN + (IF (< (CHAR-CODE CHAR) 32) + (CASE CHAR + (#\Return + (IF (NUMBERP (NTH 17 M)) (EDITMENU-RETURN M) + (SETQ DONE T))) + (#\Backspace (EDITMENU-BACKSPACE M)) + (#\^D (EDITMENU-DELETE M)) + (#\^N (IF (NUMBERP (NTH 17 M)) (EDITMENU-NEXT M))) + (#\^P (EDITMENU-PREVIOUS M)) + (#\^F (EDITMENU-FORWARD M)) + (#\^B (EDITMENU-BACKWARD M)) + (#\^A (EDITMENU-BEGINNING M)) + (#\^E (EDITMENU-END M)) + (#\^K (EDITMENU-KILL M)) + (#\^Y (EDITMENU-YANK M)) + (T NIL)) + (IF (> (CHAR-CODE CHAR) 128) + (PROGN + (SETQ CHAR (CODE-CHAR (+ -128 (CHAR-CODE CHAR)))) + (CASE CHAR + (#\B (EDITMENU-META-B M)) + (#\F (EDITMENU-META-F M)) + (T NIL))) + (EDITMENU-CHAR M CHAR))) + (EDITMENU-CARAT M) + DONE)))) + +(DEFUN EDITMENU-SETXY (M BUTTONX BUTTONY) + (LET (LINECONS OKAY) + (SETQ OKAY + (AND (>= BUTTONX (FIFTH M)) + (<= BUTTONX (+ (FIFTH M) (SEVENTH M))) + (>= BUTTONY (SIXTH M)) + (<= BUTTONY (+ (SIXTH M) (EIGHTH M))))) + (WHEN OKAY + (SETF (NTH 16 M) + (MIN (1- (LENGTH (NTH 10 M))) + (+ (IF (NUMBERP (NTH 17 M)) (NTH 17 M) 0) + (TRUNCATE + (- (+ (IF (CADDR M) (SIXTH M) 0) + (+ -6 (EIGHTH M))) + BUTTONY) + (WINDOW-STRING-HEIGHT + (OR (CADR M) (EDITMENU-INIT M)) "Tg"))))) + (SETQ LINECONS (NTHCDR (NTH 16 M) (NTH 10 M))) + (SETF (NTH 15 M) + (MIN (LENGTH (CAR LINECONS)) + (TRUNCATE + (+ -2 (- BUTTONX (IF (CADDR M) (FIFTH M) 0))) + (LET ((SSTR (STRINGIFY "W"))) + (XTEXTWIDTH + (SEVENTH (OR (CADR M) (EDITMENU-INIT M))) + (GET-C-STRING SSTR) (LENGTH SSTR))))))) + OKAY)) + +(DEFUN EDITMENU-CHAR (M CHAR) + (LET ((LINECONS (NTHCDR (NTH 16 M) (NTH 10 M)))) + (IF (<= (LENGTH (CAR LINECONS)) (NTH 15 M)) + (SETF (CAR LINECONS) + (CONCATENATE 'STRING (CAR LINECONS) (STRING CHAR))) + (SETF (CAR LINECONS) + (CONCATENATE 'STRING (SUBSEQ (CAR LINECONS) 0 (NTH 15 M)) + (STRING CHAR) (SUBSEQ (CAR LINECONS) (NTH 15 M))))) + (EDITMENU-DISPLAY M (NTH 16 M) (NTH 15 M) T) + (INCF (NTH 15 M)))) + +(DEFUN EDITMENU-CURRENT-CHAR (M) + (CHAR (NTH (NTH 16 M) (NTH 10 M)) (NTH 15 M))) + +(DEFUN EDITMENU-RETURN (M) + (LET ((LINECONS (NTHCDR (NTH 16 M) (NTH 10 M)))) + (IF (<= (LENGTH (CAR LINECONS)) (NTH 15 M)) + (PUSH "" (CDR LINECONS)) + (PROGN + (PUSH (SUBSEQ (CAR LINECONS) (NTH 15 M)) (CDR LINECONS)) + (SETF (CAR LINECONS) (SUBSEQ (CAR LINECONS) 0 (NTH 15 M))))) + (EDITMENU-DISPLAY M (NTH 16 M) 0 NIL) + (INCF (NTH 16 M)) + (SETF (NTH 15 M) 0))) + +(DEFUN EDITMENU-BACKSPACE (M) + (LET (TMP LINEDEL (LINECONS (NTHCDR (NTH 16 M) (NTH 10 M)))) + (IF (PLUSP (NTH 15 M)) + (PROGN + (DECF (NTH 15 M)) + (SETF (CAR LINECONS) + (CONCATENATE 'STRING + (SUBSEQ (CAR LINECONS) 0 (NTH 15 M)) + (SUBSEQ (CAR LINECONS) (1+ (NTH 15 M)))))) + (WHEN (PLUSP (NTH 16 M)) + (DECF (NTH 16 M)) + (SETQ LINEDEL T) + (SETQ LINECONS (NTHCDR (NTH 16 M) (NTH 10 M))) + (SETF (NTH 15 M) (LENGTH (CAR LINECONS))) + (SETQ TMP + (CONCATENATE 'STRING (CAR LINECONS) (CADR LINECONS))) + (SETF (CDR LINECONS) (CDDR LINECONS)) + (SETF (CAR LINECONS) TMP))) + (EDITMENU-DISPLAY M (NTH 16 M) (NTH 15 M) (NOT LINEDEL)))) + +(DEFUN EDITMENU-END (M) + (SETF (NTH 15 M) (LENGTH (NTH (NTH 16 M) (NTH 10 M))))) + +(DEFUN EDITMENU-BEGINNING (M) (SETF (NTH 15 M) 0)) + +(DEFUN EDITMENU-FORWARD (M) + (LET ((LINECONS (NTHCDR (NTH 16 M) (NTH 10 M)))) + (IF (< (NTH 15 M) (LENGTH (CAR LINECONS))) (INCF (NTH 15 M)) + (WHEN (NUMBERP (NTH 17 M)) + (INCF (NTH 16 M)) + (IF (NULL (CDR LINECONS)) (SETF (CDR LINECONS) (LIST ""))) + (SETF (NTH 15 M) 0))))) + +(DEFUN EDITMENU-META-F (M) + (LET (FOUND DONE) + (WHILE (AND (OR (< (NTH 16 M) (1- (LENGTH (NTH 10 M)))) + (< (NTH 15 M) (LENGTH (NTH (NTH 16 M) (NTH 10 M))))) + (NOT FOUND)) + (IF (EDITMENU-ALPHANUMBERICP (EDITMENU-CURRENT-CHAR M)) + (SETQ FOUND T) (EDITMENU-FORWARD M))) + (IF FOUND + (WHILE (AND (OR (< (NTH 16 M) (1- (LENGTH (NTH 10 M)))) + (< (NTH 15 M) + (LENGTH (NTH (NTH 16 M) (NTH 10 M))))) + (NOT DONE)) + (IF (EDITMENU-ALPHANUMBERICP (EDITMENU-CURRENT-CHAR M)) + (EDITMENU-FORWARD M) (SETQ DONE T)))))) + +(DEFUN EDITMENU-ALPHANUMBERICP (X) + (OR (ALPHA-CHAR-P X) (NOT (NULL (DIGIT-CHAR-P X))))) + +(DEFUN EDITMENU-NEXT (M) + (LET ((LINECONS (NTHCDR (NTH 16 M) (NTH 10 M)))) + (INCF (NTH 16 M)) + (IF (NULL (CDR LINECONS)) (SETF (CDR LINECONS) (LIST ""))) + (SETQ LINECONS (CDR LINECONS)) + (SETF (NTH 15 M) (MIN (NTH 15 M) (LENGTH (CAR LINECONS)))))) + +(DEFUN EDITMENU-BACKWARD (M) + (IF (PLUSP (NTH 15 M)) (DECF (NTH 15 M)) + (WHEN (PLUSP (NTH 16 M)) + (DECF (NTH 16 M)) + (SETF (NTH 15 M) (LENGTH (NTH (NTH 16 M) (NTH 10 M))))))) + +(DEFUN EDITMENU-META-B (M) + (LET (FOUND DONE) + (WHILE (AND (OR (PLUSP (NTH 15 M)) (PLUSP (NTH 16 M))) (NOT FOUND)) + (EDITMENU-BACKWARD M) + (IF (EDITMENU-ALPHANUMBERICP (EDITMENU-CURRENT-CHAR M)) + (SETQ FOUND T))) + (WHEN FOUND + (WHILE (AND (OR (PLUSP (NTH 15 M)) (PLUSP (NTH 16 M))) + (NOT DONE)) + (IF (EDITMENU-ALPHANUMBERICP (EDITMENU-CURRENT-CHAR M)) + (EDITMENU-BACKWARD M) (SETQ DONE T))) + (UNLESS (EDITMENU-ALPHANUMBERICP (EDITMENU-CURRENT-CHAR M)) + (EDITMENU-FORWARD M))))) + +(DEFUN EDITMENU-PREVIOUS (M) + (WHEN (PLUSP (NTH 16 M)) + (DECF (NTH 16 M)) + (SETF (NTH 15 M) + (MIN (NTH 15 M) (LENGTH (NTH (NTH 16 M) (NTH 10 M))))))) + +(DEFUN EDITMENU-DELETE (M) + (EDITMENU-FORWARD M) + (EDITMENU-BACKSPACE M)) + +(DEFUN EDITMENU-KILL (M) + (LET ((LINECONS (NTHCDR (NTH 16 M) (NTH 10 M)))) + (IF (< (NTH 15 M) (LENGTH (CAR LINECONS))) + (PROGN + (SETQ *WINDOW-EDITMENU-KILL-STRINGS* + (LIST (SUBSEQ (CAR LINECONS) (NTH 15 M)))) + (SETF (CAR LINECONS) (SUBSEQ (CAR LINECONS) 0 (NTH 15 M))) + (EDITMENU-DISPLAY M (NTH 16 M) (NTH 15 M) T)) + (EDITMENU-DELETE M)))) + +(DEFUN EDITMENU-YANK (M) + (LET ((LINECONS (NTHCDR (NTH 16 M) (NTH 10 M))) (COL (NTH 15 M))) + (WHEN *WINDOW-EDITMENU-KILL-STRINGS* + (IF (<= (LENGTH (CAR LINECONS)) (NTH 15 M)) + (PROGN + (SETF (CAR LINECONS) + (CONCATENATE 'STRING (CAR LINECONS) + (CAR *WINDOW-EDITMENU-KILL-STRINGS*))) + (SETF (NTH 15 M) (LENGTH (CAR LINECONS)))) + (PROGN + (SETF (CAR LINECONS) + (CONCATENATE 'STRING (SUBSEQ (CAR LINECONS) 0 COL) + (CAR *WINDOW-EDITMENU-KILL-STRINGS*) + (SUBSEQ (CAR LINECONS) COL))) + (INCF (NTH 15 M) + (LENGTH (CAR *WINDOW-EDITMENU-KILL-STRINGS*))))) + (EDITMENU-DISPLAY M (NTH 16 M) COL T)))) + +(DEFUN WINDOW-DRAW-CARAT (W X Y) + (WINDOW-SET-XOR W) + (WINDOW-DRAW-LINE-XY W (- X 5) (- Y 2) X Y) + (WINDOW-DRAW-LINE-XY W X Y (+ X 5) (- Y 2)) + (WINDOW-UNSET W) + (WINDOW-FORCE-OUTPUT W)) + +(DEFUN WINDOW-INIT-KEYMAP () + (LET (MINCODE MAXCODE KEYCODE KEYSYM KEYNUM SHIFTKEYNUM CHAR) + (XDISPLAYKEYCODES *WINDOW-DISPLAY* *MIN-KEYCODES-RETURN* + *MAX-KEYCODES-RETURN*) + (SETQ MINCODE (INT-POS *MIN-KEYCODES-RETURN* 0)) + (SETQ MAXCODE (INT-POS *MAX-KEYCODES-RETURN* 0)) + (SETQ *WINDOW-KEYMAP* + (MAKE-ARRAY (1+ MAXCODE) :INITIAL-ELEMENT NIL)) + (SETQ *WINDOW-SHIFTKEYMAP* + (MAKE-ARRAY (1+ MAXCODE) :INITIAL-ELEMENT NIL)) + (SETQ *WINDOW-SHIFT-KEYS* NIL) + (SETQ *WINDOW-CONTROL-KEYS* NIL) + (SETQ *WINDOW-META-KEYS* NIL) + (DOTIMES (I (1+ (- MAXCODE MINCODE))) + (SETQ KEYCODE (+ I MINCODE)) + (SETQ KEYSYM + (XGETKEYBOARDMAPPING *WINDOW-DISPLAY* KEYCODE 1 + *KEYCODES-RETURN*)) + (SETQ KEYNUM (FIXNUM-POS KEYSYM 0)) + (SETQ SHIFTKEYNUM (FIXNUM-POS KEYSYM 1)) + (IF (AND (>= KEYNUM 65) (<= KEYNUM 90) + (EQL SHIFTKEYNUM NOSYMBOL)) + (PROGN + (SETQ SHIFTKEYNUM KEYNUM) + (SETQ KEYNUM (+ KEYNUM 32)))) + (IF (> KEYNUM 0) + (IF (SETQ CHAR (WINDOW-CODE-CHAR KEYNUM)) + (SETF (AREF *WINDOW-KEYMAP* KEYCODE) CHAR) + (IF (> KEYNUM 256) + (COND + ((OR (EQL KEYNUM XK_SHIFT_R) + (EQL KEYNUM XK_SHIFT_L)) + (PUSH KEYCODE *WINDOW-SHIFT-KEYS*)) + ((OR (EQL KEYNUM XK_CONTROL_L) + (EQL KEYNUM XK_CONTROL_R)) + (PUSH KEYCODE *WINDOW-CONTROL-KEYS*)) + ((OR (EQL KEYNUM XK_ALT_R) (EQL KEYNUM XK_ALT_L)) + (PUSH KEYCODE *WINDOW-META-KEYS*)))))) + (IF (> SHIFTKEYNUM 0) + (IF (SETQ CHAR (WINDOW-CODE-CHAR SHIFTKEYNUM)) + (SETF (AREF *WINDOW-SHIFTKEYMAP* KEYCODE) CHAR)))) + (SETQ *WINDOW-KEYINIT* T))) + +(DEFUN WINDOW-CODE-CHAR (CODE) + (IF (> CODE 0) + (IF (< CODE 256) (CODE-CHAR CODE) + (COND + ((EQL CODE XK_RETURN) #\Return) + ((EQL CODE XK_TAB) #\Tab) + ((EQL CODE XK_BACKSPACE) #\Backspace))))) + + + + diff --git a/xgcl-2/gcl_editors.lsp b/xgcl-2/gcl_editors.lsp new file mode 100644 index 0000000..5dacb57 --- /dev/null +++ b/xgcl-2/gcl_editors.lsp @@ -0,0 +1,483 @@ +; editors.lsp Gordon S. Novak Jr. ; 08 Dec 08 + +; Copyright (c) 2008 Gordon S. Novak Jr. and The University of Texas at Austin. + +; 13 Apr 95; 02 Jan 97; 28 Feb 02; 08 Jan 04; 03 Mar 04; 26 Jan 06; 27 Jan 06 + +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 2 of the License, or +; (at your option) any later version. + +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + +; Graphical editor functions + +; (edit-thermom 75 myw 20 20 150 250) +; (window-draw-thermometer myw 0 20 5 50 50 50 232) +; (window-adjust-thermometer myw 0 20 5 50 50 50 232) + +; 20 Nov 91; 03 Dec 91; 27 Dec 91; 26 Dec 93; 28 Feb 02; 08 Jan 04 +; Edit an integer with a thermometer-like display +(gldefun edit-thermom ((num number) (w window) + &optional (offsetx integer) (offsety integer) + (sizex integer) (sizey integer)) + (prog (nmin ndel ndiv range pten drange pair neww (res num) off) + (if ~ sizex (progn (sizex = 150) (sizey = 250))) + (if ~ offsetx + (progn (off = (centeroffset w (a vector with x = sizex y = sizey))) + (offsetx = (x off)) + (offsety = (y off)))) + (neww = (window-create sizex sizey nil (parent w) offsetx offsety)) + (window-draw-button neww "Typein" 80 20 50 25) + (window-draw-button neww "Adjust" 80 70 50 25) + (window-draw-button neww "Done" 80 120 50 25) + rn (range = (abs res) * 2) + (if (range == 0) (range = 50)) + (if ((range < 8) and (integerp num)) (range = 10)) + (pten = (expt 10 (truncate (log range 10)))) + (drange = (range * 10) / pten) + (setq pair (car (some #'(lambda (x) (> (car x) drange)) + '((14 2) (20 4) (40 5) (70 10) (101 20))))) + (setq ndel ((cadr pair) * pten / 10)) + (setq ndiv (ceiling (range / ndel))) + (setq nmin (if (>= res 0) + 0 + (- ndel * ndiv))) + (window-draw-thermometer neww nmin ndel ndiv res 10 10 (sizey - 20)) + lp (case (button-select neww '((done (84 124) (42 17)) + (adjust (84 74) (42 17)) + (typein (84 24) (42 17)))) + (done (destroy neww) (return res)) + (adjust (setq res (window-adjust-thermometer neww nmin ndel ndiv res + 10 10 (sizey - 20))) + (go lp)) + (typein (princ "Enter new value: ") + (setq res (read)) + (if ((res >= nmin) and (res <= (nmin + ndel * ndiv))) + (progn (window-set-thermometer neww nmin ndel ndiv res + 10 10 (sizey - 20)) + (go lp)) + (go rn)) ) ) )) + +; 20 Nov 91; 04 Dec 91 +; Draw a button-like icon +(gldefun window-draw-button ((w window) (s string) + (offsetx integer) (offsety integer) + (sizex integer) (sizey integer)) + (let (sw) + (erase-area-xy w offsetx offsety sizex sizey 8) + (draw-rcbox-xy w offsetx offsety sizex sizey 8) + (sw = (string-width w s)) + (printat-xy w s (offsetx + (sizex - sw) / 2) (offsety + 8)) + (force-output w))) + +; 17 Dec 91 +; Print in the center of a specified region +(gldefun window-center-print ((w window) (s string) + (offsetx integer) (offsety integer) + (sizex integer) (sizey integer)) + (let (sw) + (erase-area-xy w offsetx offsety sizex sizey 8) + (sw = (string-width w s)) + (printat-xy w s (offsetx + (sizex - sw) / 2) + (offsety + (sizey - 10) / 2) ) + (force-output w))) + +; 20 Nov 91; 03 Dec 91; 26 Dec 93 +; Draw a thermometer-like icon +(gldefun window-draw-thermometer ((w window) (nmin integer) (ndel integer) + (ndiv integer) (val number) + (offsetx integer) (offsety integer) + (sizey integer)) + (let (hdel marky) + (erase-area-xy w offsetx offsety 66 sizey) + (editors-print-in-box val w offsetx offsety 40 20) + (draw-arc-xy w (offsetx + 12) (offsety + 36) 12 12 132 276) + (draw-line-xy w (offsetx + 4) (offsety + 44) + (offsetx + 4) (offsety + sizey - 8) ) + (draw-line-xy w (offsetx + 20) (offsety + 44) + (offsetx + 20) (offsety + sizey - 8) ) + (draw-arc-xy w (offsetx + 12) (offsety + sizey - 8) 8 8 0 180) + (draw-circle-xy w (offsetx + 12) (offsety + 36) 4 7) + (hdel = (sizey - 56) / ndiv) + (draw-line-xy w (offsetx + 12) (offsety + 35) + (offsetx + 12) + (offsety + 48 + hdel * ((val - nmin) / ndel)) 7) + (dotimes (i (1+ ndiv)) + (marky = (offsety + 48 + i * hdel)) + (draw-line-xy w (offsetx + 24) marky (offsetx + 34) marky) + (printat-xy w (nmin + i * ndel) (offsetx + 36) (marky - 6)) ) + (force-output w))) + + +; 20 Nov 91; 03 Dec 91; 13 Apr 95 +; Draw value for a thermometer-like icon +(gldefun window-set-thermometer ((w window) (nmin integer) (ndel integer) + (ndiv integer) (val number) + (offsetx integer) (offsety integer) + (sizey integer)) + (let (hdel) + (hdel = (sizey - 56) / ndiv) + (erase-area-xy w (offsetx + 7) (offsety + 48) + 10 (sizey - 56)) + (draw-line-xy w (offsetx + 12) (offsety + 35) + (offsetx + 12) + (offsety + 48 + hdel * ((val - nmin) / ndel)) 7) + (editors-update-in-box val w offsetx offsety 40 20)))) + + +; 20 Nov 91; 03 Dec 91; 15 Oct 93; 02 Dec 93; 08 Jan 04 +; Adjust a thermometer-like icon with the mouse. Returns new value. +(gldefun window-adjust-thermometer ((w window) (nmin integer) (ndel integer) + (ndiv integer) (val number) + (offsetx integer) (offsety integer) + (sizey integer)) + (let (hdel (lasty integer) xmin xmax ymin ymax inside (newval number)) + (hdel = (sizey - 56) / ndiv) + (lasty = (truncate (offsety + 48 + hdel * ((val - nmin) / ndel)))) + (xmin = offsetx + 4) + (xmax = offsetx + 20) + (ymin = offsety + 48) + (ymax = offsety + sizey - 8) + (window-track-mouse w + #'(lambda (x y code) + (inside = (and (>= x xmin) (<= x xmax) + (>= y ymin) (<= y ymax))) + (when (and inside (/= y lasty)) + (if (> y lasty) + (draw-line-xy w (offsetx + 12) lasty (offsetx + 12) y 7) + (erase-area-xy w (offsetx + 7) (y + 1) + 10 (- lasty y))) + (lasty = y) + (newval = ( ( (lasty - (offsety + 48)) + / (float hdel)) * ndel) + nmin) + (if (integerp val) (newval = (truncate newval))) + (editors-update-in-box newval w offsetx offsety 40 20)) + (not (zerop code)))) + (if inside + newval + val) )) + +; 20 Nov 91; 15 Oct 93; 08 Jan 04; 26 Jan 06 +; Get a mouse selection from a button area. cf. picmenu-select +(gldefun button-select ((mw window) (buttons (listof picmenu-button))) + (let ((current-button picmenu-button) item items (val picmenu-button) + xzero yzero inside) + (xzero = 0) ; (menu-x m 0) + (yzero = 0) ; (menu-y m 0) + (track-mouse mw + #'(lambda (x y code) + (x = (x - xzero)) + (y = (y - yzero)) + (if ((x >= 0) and (y >= 0)) + (inside = t)) + (if current-button + (if ~ (button-containsxy? current-button x y) + (progn (button-invert mw current-button) + (current-button = nil)))) + (if ~ current-button + (progn (items = buttons) + (while ~ current-button and (item -_ items) do + (if (button-containsxy? item x y) + (progn (current-button = item) + (button-invert mw current-button) ))))) + (if (> code 0) + (progn (if current-button + (button-invert mw current-button) ) + (val = (or current-button *picmenu-no-selection*)) ))) + t) + (if (val <> *picmenu-no-selection*) (buttonname val)) )) + +; 03 Dec 91 +(gldefun button-invert ((w window) (button picmenu-button)) + (window-invert-area w (offset button) (size button)) ) + +(gldefun window-undraw-box ((w window) offset size &optional lw) + (set-erase w) + (window-draw-box w offset size lw) + (unset w) ) + +; 20 Nov 91; 08 Jan 04 +(gldefun button-containsxy? ((b picmenu-button) (x integer) (y integer)) + (let ((xsize 6) (ysize 6)) + (if (size b) + (progn (xsize = (x (size b))) + (ysize = (y (size b))))) + ((x >= (x (offset b))) and (x <= ((x (offset b)) + xsize)) and + (y >= (y (offset b))) and (y <= ((y (offset b)) + ysize)) ) )) + + +(glispobjects + +(menu-item (z anything) + prop ((value ((if z is atomic + z + (cdr z)))) ) + msg ((print-size menu-item-print-size) + (draw menu-item-draw)) ) + +) ; glispobjects + +(gldefun menu-item-print-size ((item menu-item) (w window)) + (result vector) + (let (siz) + (if item is atomic + (a vector with x = (string-width w item) y = 11) + (if (car item) is a string + (a vector with x = (string-width w (car item)) y = 11) + (if ((symbolp (car item)) + and (siz = (get (car item) 'display-size))) + siz + (a vector with x = 50 y = 11)))) )) + +; 17 Dec 91; 08 Jan 04 +(gldefun menu-item-draw ((item menu-item) (w window) + (offsetx integer) (offsety integer) + (sizex integer) (sizey integer)) + (if item is atomic + (window-center-print w item offsetx offsety sizex sizey) + (if ((symbolp (car item)) and (fboundp (car item))) + (funcall (car item) w offsetx offsety) + (window-center-print w (car item) offsetx offsety + sizex sizey))) ) + +; 03 Dec 91; 26 Dec 93; 08 Jan 04 +(gldefun pick-one-size ((items (listof menu-item)) (w window)) + (let (wid) + (for item in items do + (wid = (if wid + (max wid (x (print-size item w))) + (x (print-size item w))) ) ) + (a vector with x = wid y = 11) )) + +; 03 Dec 91; 26 Dec 93; 29 Jul 94; 28 Feb 02 +(gldefun draw-pick-one ((items (listof menu-item)) (val anything) (w window) + &optional (offsetx integer) (offsety integer) + (sizex integer) (sizey integer)) + (let (itm) + (if (itm = (that item with (value (that item)) == val)) + (draw itm w offsetx offsety sizex sizey)))) + +; 04 Dec 91; 26 Dec 93; 29 Jul 94; 08 Jan 04 +(gldefun edit-pick-one ((items (listof menu-item)) (val anything) (w window) + &optional (offsetx integer) (offsety integer) + (sizex integer) (sizey integer)) + (let (newval) + (if ((length items) <= 3) + (if (equal val (value (first items))) + (newval = (value (second items))) + (if (equal val (value (second items))) + (newval = (if (third items) + (value (third items)) + (value (first items)))) + (newval = (value (first items))))) + (newval = (menu items)) ) + (draw-pick-one newval w items offsetx offsety sizex sizey) + newval )) + + +; 13 Dec 91; 26 Dec 93; 28 Jul 94; 28 Feb 02; 08 Jan 04 +(gldefun draw-black-white ((items (listof menu-item)) (val anything) (w window) + &optional (offsetx integer) (offsety integer) + (sizex integer) (sizey integer)) + (let (itm) + (erase-area-xy w offsetx offsety sizex sizey) + (if (itm = (that item with (value (that item)) == val)) + (if (eql (if (consp itm) + (car itm) + itm) + 1) + (invert-area-xy w offsetx offsety sizex sizey)) ) )) + +; 13 Dec 91; 15 Dec 91; 26 Dec 93; 28 Jul 94; 08 Jan 04 +(gldefun edit-black-white ((items (listof menu-item)) (val anything) (w window) + &optional (offsetx integer) (offsety integer) + (sizex integer) (sizey integer)) + (let (newval) + (if (equal val (value (first items))) + (newval = (value (second items))) + (if (equal val (value (second items))) + (newval = (value (first items))))) + (draw-black-white items newval w offsetx offsety sizex sizey) + newval )) + +; 23 Dec 91; 26 Dec 93 +(gldefun draw-integer ((val integer) (w window) + &optional (offsetx integer) (offsety integer) + (sizex integer) (sizey integer)) + (editors-anything-print val w offsetx offsety sizex sizey) ) + +; 24 Dec 91; 26 Dec 93 +(defun draw-real (val w &optional offsetx offsety sizex sizey) + (let (str nc lng fmt) + (if (null sizex) (setq sizex 50)) + (setq nc (max 1 (truncate sizex 7))) + (setq str (princ-to-string val)) + (setq lng (length str)) + (if (> lng nc) + (if (or (find #\. str :start nc) + (find #\E str) + (find #\L str)) + (if (>= nc 8) + (progn (setq fmt (cadr (or (assoc nc '((8 "~8,2E") + (9 "~9,2E") (10 "~10,2E") + (11 "~11,2E") (12 "~12,2E") + (13 "~13,2E") (14 "~14,2E"))) + '(15 "~15,2E")))) + (setq str (format nil fmt val))) + (setq str "*******")) + (setq str (subseq str 0 nc)) )) + (editors-anything-print w str offsetx offsety sizex sizey) )) + +; 09 Dec 91; 10 Dec 91; 23 Dec 91; 26 Dec 93; 22 Jul 94 +; Display function for use when a more specific one is not found. +(gldefun editors-anything-print (obj (w window) offsetx offsety sizex sizey) + (let ((s (stringify obj)) swidth smax dx dy) + (erase-area-xy w offsetx offsety sizex sizey) + (swidth = (string-width w s)) + (smax = (min swidth sizex)) + (dx = (sizex - smax) / 2) + (dy = (max 0 ((sizey - 10) / 2))) + (printat-xy w (editors-string-limit obj w smax) + (offsetx + dx) (offsety + dy)) + )) + +; 26 Dec 93 +(gldefun editors-print-in-box (obj (w window) offsetx offsety sizex sizey) + (printat-xy w (editors-string-limit obj w sizex) + (offsetx + 4) (offsety + (sizey - 10) / 2)) + (draw-box-xy w offsetx offsety sizex sizey) ) + +; 26 Dec 93 +(gldefun editors-update-in-box (obj (w window) offsetx offsety sizex sizey) + (erase-area-xy w (offsetx + 3) (offsety + 3) (sizex - 6) (sizey - 6)) + (printat-xy w (editors-string-limit obj w sizex) + (offsetx + 4) (offsety + (sizey - 10) / 2)) ) + +; 28 Oct 91; 26 Dec 93; 08 Jan 04 +; Limit string to a specified number of pixels +(gldefun editors-string-limit ((s string) (w window) (max integer)) + (result string) + (let ((str (stringify s)) (lng integer) (nc integer)) + (lng = (string-width w str)) + (if (lng > max) + (progn (nc = (((length str) * max) / lng)) + (subseq str 0 nc)) + str) )) + +(defvar *edit-color-menu-set* nil) +(defvar *edit-color-rmenu* nil) +(defvar *edit-color-old-color* nil) +(glispglobals (*edit-color-menu-set* menu-set) + (*edit-color-rmenu* barmenu)) + +; 03 Jan 94; 04 Jan 94; 05 Jan 94; 08 Dec 08 +(gldefun edit-color-init ((w window)) + (let (rm gm bm rgb) + (rgb = (a rgb)) + (glcc 'edit-color-red) + (glcc 'edit-color-green) + (glcc 'edit-color-blue) + (*edit-color-menu-set* = (menu-set-create w nil)) + (rm = (barmenu-create 256 200 10 "" nil #'edit-color-red (list rgb) w + 120 40 nil t (a rgb with red = 65535))) + (*edit-color-rmenu* = rm) + (gm = (barmenu-create 256 50 10 "" nil #'edit-color-green (list rgb) w + 170 40 nil t (a rgb with green = 65535))) + (bm = (barmenu-create 256 250 10 "" nil #'edit-color-blue (list rgb) w + 220 40 nil t (a rgb with blue = 65535))) + (add-barmenu *edit-color-menu-set* 'red nil rm "Red" '(120 40)) + (add-barmenu *edit-color-menu-set* 'green nil gm "Green" '(170 40)) + (add-barmenu *edit-color-menu-set* 'blue nil bm "Blue" '(220 40)) + (add-menu *edit-color-menu-set* 'done nil "" '(("Done" . done)) '(30 150)) + (edit-color-red 200 rgb) + (edit-color-green 50 rgb) + (edit-color-blue 250 rgb) + )) + +; 03 Jan 94; 04 Jan 94 +(gldefun edit-color-red ((val integer) (color rgb)) + (let ((w (window *edit-color-menu-set*))) + (printat-xy w (format nil "~3D" val) 113 20) + ((red color) = (max 0 (val * 256 - 1))) + (edit-display-color w color) )) + +; 03 Jan 94; 04 Jan 94 +(gldefun edit-color-green ((val integer) (color rgb)) + (let ((w (window *edit-color-menu-set*))) + (printat-xy w (format nil "~3D" val) 163 20) + ((green color) = (max 0 (val * 256 - 1))) + (edit-display-color w color) )) + +; 03 Jan 94; 04 Jan 94 +(gldefun edit-color-blue ((val integer) (color rgb)) + (let ((w (window *edit-color-menu-set*))) + (printat-xy w (format nil "~3D" val) 213 20) + ((blue color) = (max 0 (val * 256 - 1))) + (edit-display-color w color) )) + +; 03 Jan 94 +(gldefun edit-display-color ((w window) (color rgb)) + (window-set-color w color) + (window-draw-line-xy w 50 40 50 100 60) + (window-reset-color w) + (if *edit-color-old-color* (window-free-color w *edit-color-old-color*)) + (*edit-color-old-color* = *window-xcolor*) ) + +; 03 Jan 94; 04 Jan 94; 05 Jan 94; 28 Feb 02 +(gldefun edit-color ((w window)) + (let (done (color rgb) sel) + (if (or (null *edit-color-menu-set*) + (not (eq w (menu-window (menu (first (menu-items + *edit-color-menu-set*))))))) + (edit-color-init w)) + (color = (first (subtrackparms *edit-color-rmenu*))) + (draw *edit-color-menu-set*) + (edit-color-red (truncate (1+ (red color)) 256) color) + (edit-color-green (truncate (1+ (green color)) 256) color) + (edit-color-blue (truncate (1+ (blue color)) 256) color) + (while ~ done + (sel = (select *edit-color-menu-set*)) + (done = (and sel ((first sel) == 'done))) ) + color)) + +; 08 Dec 08 +(gldefun color-dot ((w window) (x integer) (y integer) (color symbol)) + (let (rgb) + (setq rgb (cdr (assoc color '((red 65535 0 0) + (yellow 65535 57600 0) + (green 0 50175 12287) + (blue 0 0 65535))))) + (or rgb (setq rgb '(30000 30000 30000))) + (set-color w rgb) + (draw-dot-xy w x y) + (reset-color w) )) + +; 15 Oct 93; 26 Jan 06 +; Compile the editors.lsp file into a plain Lisp file +(defun compile-editors () + (glcompfiles *directory* + '("glisp/vector.lsp" ; auxiliary files + "X/dwindow.lsp") + '("glisp/editors.lsp") ; translated files + "glisp/editorstrans.lsp" ; output file + "glisp/gpl.txt") ; header file + (cf editorstrans) ) + +; Compile the editors.lsp file into a plain Lisp file for XGCL +(defun compile-editorsb () + (glcompfiles *directory* + '("glisp/vector.lsp" ; auxiliary files + "X/dwindow.lsp" "X/dwnoopen.lsp") + '("glisp/editors.lsp") ; translated files + "glisp/editorstrans.lsp" ; output file + "glisp/gpl.txt") ; header file + ) diff --git a/xgcl-2/gcl_editorstrans.lsp b/xgcl-2/gcl_editorstrans.lsp new file mode 100644 index 0000000..a93a2e7 --- /dev/null +++ b/xgcl-2/gcl_editorstrans.lsp @@ -0,0 +1,589 @@ +; 07 Jan 2010 16:43:40 EST +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 2 of the License, or +; (at your option) any later version. + +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this program; if not, see . + + +(DEFUN EDIT-THERMOM (NUM W &OPTIONAL OFFSETX OFFSETY SIZEX SIZEY) + (PROG (NMIN NDEL NDIV RANGE PTEN DRANGE PAIR NEWW (RES NUM) OFF) + (WHEN (NOT SIZEX) (SETQ SIZEX 150) (SETQ SIZEY 250)) + (WHEN (NOT OFFSETX) + (SETQ OFF + (LET ((GLVAR168 (LIST SIZEX SIZEY))) + (LIST (TRUNCATE (- (FIFTH W) (CAR GLVAR168)) 2) + (TRUNCATE (- (CADDDR W) (CADR GLVAR168)) 2)))) + (SETQ OFFSETX (CAR OFF)) + (SETQ OFFSETY (CADR OFF))) + (SETQ NEWW + (WINDOW-CREATE SIZEX SIZEY NIL (CADR W) OFFSETX OFFSETY)) + (WINDOW-DRAW-BUTTON NEWW "Typein" 80 20 50 25) + (WINDOW-DRAW-BUTTON NEWW "Adjust" 80 70 50 25) + (WINDOW-DRAW-BUTTON NEWW "Done" 80 120 50 25) + RN + (SETQ RANGE (* 2 (ABS RES))) + (IF (ZEROP RANGE) (SETQ RANGE 50)) + (IF (AND (< RANGE 8) (INTEGERP NUM)) (SETQ RANGE 10)) + (SETQ PTEN (EXPT 10 (TRUNCATE (LOG RANGE 10)))) + (SETQ DRANGE (/ (* 10 RANGE) PTEN)) + (SETQ PAIR + (CAR (SOME #'(LAMBDA (X) (> (CAR X) DRANGE)) + '((14 2) (20 4) (40 5) (70 10) (101 20))))) + (SETQ NDEL (* 1/10 (* (CADR PAIR) PTEN))) + (SETQ NDIV (CEILING (/ RANGE NDEL))) + (SETQ NMIN (IF (>= RES 0) 0 (- (* NDEL NDIV)))) + (WINDOW-DRAW-THERMOMETER NEWW NMIN NDEL NDIV RES 10 10 + (+ -20 SIZEY)) + LP + (CASE (BUTTON-SELECT NEWW + '((DONE (84 124) (42 17)) (ADJUST (84 74) (42 17)) + (TYPEIN (84 24) (42 17)))) + (DONE (XDESTROYWINDOW *WINDOW-DISPLAY* (CADR NEWW)) + (XFLUSH *WINDOW-DISPLAY*) (SETF (CADR NEWW) NIL) + (XFREEGC *WINDOW-DISPLAY* (CADDR NEWW)) + (SETF (CADDR NEWW) NIL) (RETURN RES)) + (ADJUST (SETQ RES + (WINDOW-ADJUST-THERMOMETER NEWW NMIN NDEL NDIV RES + 10 10 (+ -20 SIZEY))) + (GO LP)) + (TYPEIN (PRINC "Enter new value: ") (SETQ RES (READ)) + (IF (AND (>= RES NMIN) (<= RES (+ NMIN (* NDEL NDIV)))) + (PROGN + (WINDOW-SET-THERMOMETER NEWW NMIN NDEL NDIV RES 10 + 10 (+ -20 SIZEY)) + (GO LP)) + (GO RN)))))) +(SETF (GET 'EDIT-THERMOM 'GLARGUMENTS) + '((NUM NUMBER) (W WINDOW) (&OPTIONAL INTEGER) (OFFSETX INTEGER) + (OFFSETY INTEGER) (SIZEX INTEGER))) +(SETF (GET 'EDIT-THERMOM 'GLFNRESULTTYPE) 'NUMBER) + + +(DEFUN WINDOW-DRAW-BUTTON (W S OFFSETX OFFSETY SIZEX SIZEY) + (LET (SW) + (XCLEARAREA *WINDOW-DISPLAY* (CADR W) OFFSETX + (- (CADDDR W) (1- (+ OFFSETY SIZEY))) SIZEX SIZEY 0) + (WINDOW-DRAW-RCBOX-XY W OFFSETX OFFSETY SIZEX SIZEY 8) + (SETQ SW + (LET ((SSTR (STRINGIFY S))) + (XTEXTWIDTH (SEVENTH W) (GET-C-STRING SSTR) (LENGTH SSTR)))) + (LET ((SSTR (STRINGIFY S))) + (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) + (+ OFFSETX (* 1/2 (- SIZEX SW))) + (+ -8 (- (CADDDR W) OFFSETY)) (GET-C-STRING SSTR) + (LENGTH SSTR))) + (XFLUSH *WINDOW-DISPLAY*))) + +(DEFUN WINDOW-CENTER-PRINT (W S OFFSETX OFFSETY SIZEX SIZEY) + (LET (SW) + (XCLEARAREA *WINDOW-DISPLAY* (CADR W) OFFSETX + (- (CADDDR W) (1- (+ OFFSETY SIZEY))) SIZEX SIZEY 0) + (SETQ SW + (LET ((SSTR (STRINGIFY S))) + (XTEXTWIDTH (SEVENTH W) (GET-C-STRING SSTR) (LENGTH SSTR)))) + (LET ((SSTR (STRINGIFY S))) + (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) + (+ OFFSETX (* 1/2 (- SIZEX SW))) + (- (CADDDR W) (+ OFFSETY (+ -5 (* 1/2 SIZEY)))) + (GET-C-STRING SSTR) (LENGTH SSTR))) + (XFLUSH *WINDOW-DISPLAY*))) + +(DEFUN WINDOW-DRAW-THERMOMETER + (W NMIN NDEL NDIV VAL OFFSETX OFFSETY SIZEY) + (LET (HDEL MARKY) + (XCLEARAREA *WINDOW-DISPLAY* (CADR W) OFFSETX + (- (CADDDR W) (1- (+ OFFSETY SIZEY))) 66 SIZEY 0) + (EDITORS-PRINT-IN-BOX VAL W OFFSETX OFFSETY 40 20) + (XDRAWARC *WINDOW-DISPLAY* (CADR W) (CADDR W) OFFSETX + (+ -48 (- (CADDDR W) OFFSETY)) 24 24 8448 17664) + (LET ((QQWHEIGHT (CADDDR W))) + (XDRAWLINE *WINDOW-DISPLAY* (CADR W) (CADDR W) (+ 4 OFFSETX) + (+ -44 (- QQWHEIGHT OFFSETY)) (+ 4 OFFSETX) + (+ 8 (- QQWHEIGHT (+ OFFSETY SIZEY))))) + (LET ((QQWHEIGHT (CADDDR W))) + (XDRAWLINE *WINDOW-DISPLAY* (CADR W) (CADDR W) (+ 20 OFFSETX) + (+ -44 (- QQWHEIGHT OFFSETY)) (+ 20 OFFSETX) + (+ 8 (- QQWHEIGHT (+ OFFSETY SIZEY))))) + (XDRAWARC *WINDOW-DISPLAY* (CADR W) (CADDR W) (+ 4 OFFSETX) + (- (CADDDR W) (+ OFFSETY SIZEY)) 16 16 0 11520) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 7 0 1 0) + (XDRAWARC *WINDOW-DISPLAY* (CADR W) (CADDR W) (+ 8 OFFSETX) + (+ -40 (- (CADDDR W) OFFSETY)) 8 8 0 23040) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0) + (SETQ HDEL (/ (+ -56 SIZEY) NDIV)) + (LET ((QQWHEIGHT (CADDDR W))) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 7 0 1 0) + (XDRAWLINE *WINDOW-DISPLAY* (CADR W) (CADDR W) (+ 12 OFFSETX) + (+ -35 (- QQWHEIGHT OFFSETY)) (+ 12 OFFSETX) + (- QQWHEIGHT + (+ (+ 48 OFFSETY) (* HDEL (/ (- VAL NMIN) NDEL))))) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0)) + (DOTIMES (I (1+ NDIV)) + (SETQ MARKY (+ (+ 48 OFFSETY) (* I HDEL))) + (LET ((QQWHEIGHT (CADDDR W))) + (XDRAWLINE *WINDOW-DISPLAY* (CADR W) (CADDR W) (+ 24 OFFSETX) + (- QQWHEIGHT MARKY) (+ 34 OFFSETX) (- QQWHEIGHT MARKY)) + NIL) + (LET ((SSTR (STRINGIFY (+ NMIN (* I NDEL))))) + (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) + (+ 36 OFFSETX) (+ 6 (- (CADDDR W) MARKY)) + (GET-C-STRING SSTR) (LENGTH SSTR)))) + (XFLUSH *WINDOW-DISPLAY*))) + +(DEFUN WINDOW-SET-THERMOMETER + (W NMIN NDEL NDIV VAL OFFSETX OFFSETY SIZEY) + (LET (HDEL) + (SETQ HDEL (/ (+ -56 SIZEY) NDIV)) + (LET ((GLVAR204 (+ -56 SIZEY))) + (XCLEARAREA *WINDOW-DISPLAY* (CADR W) (+ 7 OFFSETX) + (- (CADDDR W) (1- (+ (+ 48 OFFSETY) GLVAR204))) 10 GLVAR204 + 0)) + (LET ((QQWHEIGHT (CADDDR W))) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 7 0 1 0) + (XDRAWLINE *WINDOW-DISPLAY* (CADR W) (CADDR W) (+ 12 OFFSETX) + (+ -35 (- QQWHEIGHT OFFSETY)) (+ 12 OFFSETX) + (- QQWHEIGHT + (+ (+ 48 OFFSETY) (* HDEL (/ (- VAL NMIN) NDEL))))) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0)) + (EDITORS-UPDATE-IN-BOX VAL W OFFSETX OFFSETY 40 20))) + +(DEFUN WINDOW-ADJUST-THERMOMETER + (W NMIN NDEL NDIV VAL OFFSETX OFFSETY SIZEY) + (LET (HDEL LASTY XMIN XMAX YMIN YMAX INSIDE NEWVAL) + (SETQ HDEL (/ (+ -56 SIZEY) NDIV)) + (SETQ LASTY + (TRUNCATE (+ (+ 48 OFFSETY) (* HDEL (/ (- VAL NMIN) NDEL))))) + (SETQ XMIN (+ 4 OFFSETX)) + (SETQ XMAX (+ 20 OFFSETX)) + (SETQ YMIN (+ 48 OFFSETY)) + (SETQ YMAX (+ -8 (+ OFFSETY SIZEY))) + (WINDOW-TRACK-MOUSE W + #'(LAMBDA (X Y CODE) + (SETQ INSIDE + (AND (>= X XMIN) (<= X XMAX) (>= Y YMIN) (<= Y YMAX))) + (WHEN (AND INSIDE (/= Y LASTY)) + (IF (> Y LASTY) + (LET ((QQWHEIGHT (CADDDR W))) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 7 0 + 1 0) + (XDRAWLINE *WINDOW-DISPLAY* (CADR W) (CADDR W) + (+ 12 OFFSETX) (- QQWHEIGHT LASTY) + (+ 12 OFFSETX) (- QQWHEIGHT Y)) + (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 + 1 0)) + (LET ((GLVAR214 (- LASTY Y))) + (XCLEARAREA *WINDOW-DISPLAY* (CADR W) (+ 7 OFFSETX) + (- (CADDDR W) (1- (+ (1+ Y) GLVAR214))) 10 + GLVAR214 0))) + (SETQ LASTY Y) + (SETQ NEWVAL + (+ (* (/ (+ -48 (- LASTY OFFSETY)) (FLOAT HDEL)) + NDEL) + NMIN)) + (IF (INTEGERP VAL) (SETQ NEWVAL (TRUNCATE NEWVAL))) + (EDITORS-UPDATE-IN-BOX NEWVAL W OFFSETX OFFSETY 40 20)) + (NOT (ZEROP CODE)))) + (IF INSIDE NEWVAL VAL))) +(SETF (GET 'WINDOW-ADJUST-THERMOMETER 'GLARGUMENTS) + '((W WINDOW) (NMIN INTEGER) (NDEL INTEGER) (NDIV INTEGER) + (VAL NUMBER) (OFFSETX INTEGER) (OFFSETY INTEGER) + (SIZEY INTEGER))) +(SETF (GET 'WINDOW-ADJUST-THERMOMETER 'GLFNRESULTTYPE) 'NUMBER) + + +(DEFUN BUTTON-SELECT (MW BUTTONS) + (LET (CURRENT-BUTTON ITEM ITEMS VAL XZERO YZERO) + (SETQ XZERO 0) + (SETQ YZERO 0) + (WINDOW-TRACK-MOUSE MW + #'(LAMBDA (X Y CODE) + (DECF X XZERO) + (DECF Y YZERO) + (AND (>= X 0) (>= Y 0)) + (IF CURRENT-BUTTON + (WHEN (NOT (BUTTON-CONTAINSXY? CURRENT-BUTTON X Y)) + (BUTTON-INVERT MW CURRENT-BUTTON) + (SETQ CURRENT-BUTTON NIL))) + (WHEN (NOT CURRENT-BUTTON) + (SETQ ITEMS BUTTONS) + (WHILE (AND (NOT CURRENT-BUTTON) (SETQ ITEM (POP ITEMS))) + (WHEN (BUTTON-CONTAINSXY? ITEM X Y) + (SETQ CURRENT-BUTTON ITEM) + (BUTTON-INVERT MW CURRENT-BUTTON)))) + (WHEN (PLUSP CODE) + (IF CURRENT-BUTTON (BUTTON-INVERT MW CURRENT-BUTTON)) + (SETQ VAL (OR CURRENT-BUTTON *PICMENU-NO-SELECTION*)))) + T) + (IF (NOT (EQUAL VAL *PICMENU-NO-SELECTION*)) (CAR VAL)))) +(SETF (GET 'BUTTON-SELECT 'GLARGUMENTS) + '((MW WINDOW) (BUTTONS (LISTOF PICMENU-BUTTON)))) +(SETF (GET 'BUTTON-SELECT 'GLFNRESULTTYPE) 'SYMBOL) + + +(DEFUN BUTTON-INVERT (W BUTTON) + (WINDOW-INVERT-AREA W (CADR BUTTON) (CADDR BUTTON))) + +(DEFUN WINDOW-UNDRAW-BOX (W OFFSET SIZE &OPTIONAL LW) + (LET ((GC (CADDR W))) + (SETQ *WINDOW-SAVE-FUNCTION* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 1 *GC-VALUES*) + (XGCVALUES-FUNCTION *GC-VALUES*))) + (XSETFUNCTION *WINDOW-DISPLAY* GC 3) + (SETQ *WINDOW-SAVE-FOREGROUND* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 4 *GC-VALUES*) + (XGCVALUES-FOREGROUND *GC-VALUES*))) + (XSETFOREGROUND *WINDOW-DISPLAY* GC + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 8 *GC-VALUES*) + (XGCVALUES-BACKGROUND *GC-VALUES*)))) + (WINDOW-DRAW-BOX W OFFSET SIZE LW) + (LET ((GC (CADDR W))) + (XSETFUNCTION *WINDOW-DISPLAY* GC *WINDOW-SAVE-FUNCTION*) + (XSETFOREGROUND *WINDOW-DISPLAY* GC *WINDOW-SAVE-FOREGROUND*))) + +(DEFUN BUTTON-CONTAINSXY? (B X Y) + (LET ((XSIZE 6) (YSIZE 6)) + (WHEN (CADDR B) + (SETQ XSIZE (CAADDR B)) + (SETQ YSIZE (CADR (CADDR B)))) + (AND (>= X (CAADR B)) (<= X (+ (CAADR B) XSIZE)) (>= Y (CADADR B)) + (<= Y (+ (CADADR B) YSIZE))))) +(SETF (GET 'BUTTON-CONTAINSXY? 'GLARGUMENTS) + '((B PICMENU-BUTTON) (X INTEGER) (Y INTEGER))) +(SETF (GET 'BUTTON-CONTAINSXY? 'GLFNRESULTTYPE) 'BOOLEAN) + + +(SETF (GET 'MENU-ITEM 'GLSTRUCTURE) + '((Z ANYTHING) PROP ((VALUE ((IF Z IS ATOMIC Z (CDR Z))))) MSG + ((PRINT-SIZE MENU-ITEM-PRINT-SIZE) (DRAW MENU-ITEM-DRAW)))) + + +(DEFUN MENU-ITEM-PRINT-SIZE (ITEM W) + (LET (SIZ) + (IF (ATOM ITEM) + (LIST (LET ((SSTR (STRINGIFY ITEM))) + (XTEXTWIDTH (SEVENTH W) (GET-C-STRING SSTR) + (LENGTH SSTR))) + 11) + (IF (STRINGP (CAR ITEM)) + (LIST (LET ((SSTR (STRINGIFY (CAR ITEM)))) + (XTEXTWIDTH (SEVENTH W) (GET-C-STRING SSTR) + (LENGTH SSTR))) + 11) + (IF (AND (SYMBOLP (CAR ITEM)) + (SETQ SIZ (GET (CAR ITEM) 'DISPLAY-SIZE))) + SIZ (COPY-LIST '(50 11))))))) +(SETF (GET 'MENU-ITEM-PRINT-SIZE 'GLARGUMENTS) + '((ITEM MENU-ITEM) (W WINDOW))) +(SETF (GET 'MENU-ITEM-PRINT-SIZE 'GLFNRESULTTYPE) 'VECTOR) + + +(DEFUN MENU-ITEM-DRAW (ITEM W OFFSETX OFFSETY SIZEX SIZEY) + (IF (ATOM ITEM) + (WINDOW-CENTER-PRINT W ITEM OFFSETX OFFSETY SIZEX SIZEY) + (IF (AND (SYMBOLP (CAR ITEM)) (FBOUNDP (CAR ITEM))) + (FUNCALL (CAR ITEM) W OFFSETX OFFSETY) + (WINDOW-CENTER-PRINT W (CAR ITEM) OFFSETX OFFSETY SIZEX + SIZEY)))) + +(DEFUN PICK-ONE-SIZE (ITEMS W) + (LET (WID) + (DOLIST (ITEM ITEMS) + (SETQ WID + (IF WID (MAX WID (CAR (MENU-ITEM-PRINT-SIZE ITEM W))) + (CAR (MENU-ITEM-PRINT-SIZE ITEM W))))) + (LIST WID 11))) +(SETF (GET 'PICK-ONE-SIZE 'GLARGUMENTS) + '((ITEMS (LISTOF MENU-ITEM)) (W WINDOW))) +(SETF (GET 'PICK-ONE-SIZE 'GLFNRESULTTYPE) 'VECTOR) + + +(DEFUN DRAW-PICK-ONE + (ITEMS VAL W &OPTIONAL OFFSETX OFFSETY SIZEX SIZEY) + (LET (ITM) + (IF (SETQ ITM + (SOME #'(LAMBDA (GLVAR216) + (IF (EQUAL (IF (ATOM GLVAR216) GLVAR216 + (CDR GLVAR216)) + VAL) + GLVAR216)) + ITEMS)) + (MENU-ITEM-DRAW ITM W OFFSETX OFFSETY SIZEX SIZEY)))) + +(DEFUN EDIT-PICK-ONE + (ITEMS VAL W &OPTIONAL OFFSETX OFFSETY SIZEX SIZEY) + (LET (NEWVAL) + (IF (<= (LENGTH ITEMS) 3) + (IF (EQUAL VAL + (LET ((SELF (FIRST ITEMS))) + (IF (ATOM SELF) SELF (CDR SELF)))) + (SETQ NEWVAL + (LET ((SELF (SECOND ITEMS))) + (IF (ATOM SELF) SELF (CDR SELF)))) + (IF (EQUAL VAL + (LET ((SELF (SECOND ITEMS))) + (IF (ATOM SELF) SELF (CDR SELF)))) + (SETQ NEWVAL + (IF (THIRD ITEMS) + (LET ((SELF (THIRD ITEMS))) + (IF (ATOM SELF) SELF (CDR SELF))) + (LET ((SELF (FIRST ITEMS))) + (IF (ATOM SELF) SELF (CDR SELF))))) + (SETQ NEWVAL + (LET ((SELF (FIRST ITEMS))) + (IF (ATOM SELF) SELF (CDR SELF)))))) + (SETQ NEWVAL (MENU ITEMS))) + (DRAW-PICK-ONE NEWVAL W ITEMS OFFSETX OFFSETY SIZEX SIZEY) + NEWVAL)) + +(DEFUN DRAW-BLACK-WHITE + (ITEMS VAL W &OPTIONAL OFFSETX OFFSETY SIZEX SIZEY) + (LET (ITM) + (XCLEARAREA *WINDOW-DISPLAY* (CADR W) OFFSETX + (- (CADDDR W) (1- (+ OFFSETY SIZEY))) SIZEX SIZEY 0) + (IF (SETQ ITM + (SOME #'(LAMBDA (GLVAR218) + (IF (EQUAL (IF (ATOM GLVAR218) GLVAR218 + (CDR GLVAR218)) + VAL) + GLVAR218)) + ITEMS)) + (WHEN (EQL (IF (CONSP ITM) (CAR ITM) ITM) 1) + (LET ((GC (CADDR W))) + (SETQ *WINDOW-SAVE-FUNCTION* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 1 + *GC-VALUES*) + (XGCVALUES-FUNCTION *GC-VALUES*))) + (XSETFUNCTION *WINDOW-DISPLAY* GC 6) + (SETQ *WINDOW-SAVE-FOREGROUND* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 4 + *GC-VALUES*) + (XGCVALUES-FOREGROUND *GC-VALUES*))) + (XSETFOREGROUND *WINDOW-DISPLAY* GC + (LOGXOR *WINDOW-SAVE-FOREGROUND* + (PROGN + (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 8 + *GC-VALUES*) + (XGCVALUES-BACKGROUND *GC-VALUES*))))) + (XFILLRECTANGLE *WINDOW-DISPLAY* (CADR W) (CADDR W) OFFSETX + (- (CADDDR W) (1- (+ OFFSETY SIZEY))) SIZEX SIZEY) + (LET ((GC (CADDR W))) + (XSETFUNCTION *WINDOW-DISPLAY* GC *WINDOW-SAVE-FUNCTION*) + (XSETFOREGROUND *WINDOW-DISPLAY* GC + *WINDOW-SAVE-FOREGROUND*)))))) + +(DEFUN EDIT-BLACK-WHITE + (ITEMS VAL W &OPTIONAL OFFSETX OFFSETY SIZEX SIZEY) + (LET (NEWVAL) + (IF (EQUAL VAL + (LET ((SELF (FIRST ITEMS))) + (IF (ATOM SELF) SELF (CDR SELF)))) + (SETQ NEWVAL + (LET ((SELF (SECOND ITEMS))) + (IF (ATOM SELF) SELF (CDR SELF)))) + (IF (EQUAL VAL + (LET ((SELF (SECOND ITEMS))) + (IF (ATOM SELF) SELF (CDR SELF)))) + (SETQ NEWVAL + (LET ((SELF (FIRST ITEMS))) + (IF (ATOM SELF) SELF (CDR SELF)))))) + (DRAW-BLACK-WHITE ITEMS NEWVAL W OFFSETX OFFSETY SIZEX SIZEY) + NEWVAL)) + +(DEFUN DRAW-INTEGER (VAL W &OPTIONAL OFFSETX OFFSETY SIZEX SIZEY) + (EDITORS-ANYTHING-PRINT VAL W OFFSETX OFFSETY SIZEX SIZEY)) + +(DEFUN DRAW-REAL (VAL W &OPTIONAL OFFSETX OFFSETY SIZEX SIZEY) + (LET (STR NC LNG FMT) + (IF (NULL SIZEX) (SETQ SIZEX 50)) + (SETQ NC (MAX 1 (TRUNCATE SIZEX 7))) + (SETQ STR (PRINC-TO-STRING VAL)) + (SETQ LNG (LENGTH STR)) + (IF (> LNG NC) + (IF (OR (FIND #\. STR :START NC) (FIND #\E STR) (FIND #\L STR)) + (IF (>= NC 8) + (PROGN + (SETQ FMT + (CADR (OR (ASSOC NC + '((8 "~8,2E") (9 "~9,2E") + (10 "~10,2E") (11 "~11,2E") + (12 "~12,2E") (13 "~13,2E") + (14 "~14,2E"))) + '(15 "~15,2E")))) + (SETQ STR (FORMAT NIL FMT VAL))) + (SETQ STR "*******")) + (SETQ STR (SUBSEQ STR 0 NC)))) + (EDITORS-ANYTHING-PRINT W STR OFFSETX OFFSETY SIZEX SIZEY))) + +(DEFUN EDITORS-ANYTHING-PRINT (OBJ W OFFSETX OFFSETY SIZEX SIZEY) + (LET (SWIDTH SMAX DX DY) + (XCLEARAREA *WINDOW-DISPLAY* (CADR W) OFFSETX + (- (CADDDR W) (1- (+ OFFSETY SIZEY))) SIZEX SIZEY 0) + (SETQ SWIDTH + (LET ((SSTR (STRINGIFY (STRINGIFY OBJ)))) + (XTEXTWIDTH (SEVENTH W) (GET-C-STRING SSTR) (LENGTH SSTR)))) + (SETQ SMAX (MIN SWIDTH SIZEX)) + (SETQ DX (* 1/2 (- SIZEX SMAX))) + (SETQ DY (MAX 0 (+ -5 (* 1/2 SIZEY)))) + (LET ((SSTR (STRINGIFY (EDITORS-STRING-LIMIT OBJ W SMAX)))) + (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) + (+ OFFSETX DX) (- (CADDDR W) (+ OFFSETY DY)) + (GET-C-STRING SSTR) (LENGTH SSTR))))) + +(DEFUN EDITORS-PRINT-IN-BOX (OBJ W OFFSETX OFFSETY SIZEX SIZEY) + (LET ((SSTR (STRINGIFY (EDITORS-STRING-LIMIT OBJ W SIZEX)))) + (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) (+ 4 OFFSETX) + (- (CADDDR W) (+ OFFSETY (+ -5 (* 1/2 SIZEY)))) + (GET-C-STRING SSTR) (LENGTH SSTR))) + (WINDOW-DRAW-BOX-XY W OFFSETX OFFSETY SIZEX SIZEY)) + +(DEFUN EDITORS-UPDATE-IN-BOX (OBJ W OFFSETX OFFSETY SIZEX SIZEY) + (LET ((GLVAR229 (+ -6 SIZEY))) + (XCLEARAREA *WINDOW-DISPLAY* (CADR W) (+ 3 OFFSETX) + (- (CADDDR W) (1- (+ (+ 3 OFFSETY) GLVAR229))) (+ -6 SIZEX) + GLVAR229 0)) + (LET ((SSTR (STRINGIFY (EDITORS-STRING-LIMIT OBJ W SIZEX)))) + (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) (+ 4 OFFSETX) + (- (CADDDR W) (+ OFFSETY (+ -5 (* 1/2 SIZEY)))) + (GET-C-STRING SSTR) (LENGTH SSTR)))) + +(DEFUN EDITORS-STRING-LIMIT (S W MAX) + (LET ((STR (STRINGIFY S)) LNG NC) + (SETQ LNG + (LET ((SSTR (STRINGIFY STR))) + (XTEXTWIDTH (SEVENTH W) (GET-C-STRING SSTR) (LENGTH SSTR)))) + (IF (> LNG MAX) + (PROGN + (SETQ NC (/ (* (LENGTH STR) MAX) LNG)) + (SUBSEQ STR 0 NC)) + STR))) +(SETF (GET 'EDITORS-STRING-LIMIT 'GLARGUMENTS) + '((S STRING) (W WINDOW) (MAX INTEGER))) +(SETF (GET 'EDITORS-STRING-LIMIT 'GLFNRESULTTYPE) 'STRING) + + +(DEFVAR *EDIT-COLOR-MENU-SET* NIL) + +(DEFVAR *EDIT-COLOR-RMENU* NIL) + +(DEFVAR *EDIT-COLOR-OLD-COLOR* NIL) + +(DEFVAR *EDIT-COLOR-MENU-SET*) +(SETF (GET '*EDIT-COLOR-MENU-SET* 'GLISPGLOBALVAR) T) +(SETF (GET '*EDIT-COLOR-MENU-SET* 'GLISPGLOBALVARTYPE) 'MENU-SET) +(DEFVAR *EDIT-COLOR-RMENU*) +(SETF (GET '*EDIT-COLOR-RMENU* 'GLISPGLOBALVAR) T) +(SETF (GET '*EDIT-COLOR-RMENU* 'GLISPGLOBALVARTYPE) 'BARMENU) + + +(DEFUN EDIT-COLOR-INIT (W) + (LET (RM GM BM RGB) + (SETQ RGB (COPY-LIST '(0 0 0))) + (GLCC 'EDIT-COLOR-RED) + (GLCC 'EDIT-COLOR-GREEN) + (GLCC 'EDIT-COLOR-BLUE) + (SETQ *EDIT-COLOR-MENU-SET* (MENU-SET-CREATE W NIL)) + (SETQ RM + (BARMENU-CREATE 256 200 10 "" NIL #'EDIT-COLOR-RED (LIST RGB) + W 120 40 NIL T (COPY-LIST '(65535 0 0)))) + (SETQ *EDIT-COLOR-RMENU* RM) + (SETQ GM + (BARMENU-CREATE 256 50 10 "" NIL #'EDIT-COLOR-GREEN + (LIST RGB) W 170 40 NIL T (COPY-LIST '(0 65535 0)))) + (SETQ BM + (BARMENU-CREATE 256 250 10 "" NIL #'EDIT-COLOR-BLUE + (LIST RGB) W 220 40 NIL T (COPY-LIST '(0 0 65535)))) + (MENU-SET-ADD-BARMENU *EDIT-COLOR-MENU-SET* 'RED NIL RM "Red" + '(120 40)) + (MENU-SET-ADD-BARMENU *EDIT-COLOR-MENU-SET* 'GREEN NIL GM "Green" + '(170 40)) + (MENU-SET-ADD-BARMENU *EDIT-COLOR-MENU-SET* 'BLUE NIL BM "Blue" + '(220 40)) + (MENU-SET-ADD-MENU *EDIT-COLOR-MENU-SET* 'DONE NIL "" + '(("Done" . DONE)) '(30 150)) + (EDIT-COLOR-RED 200 RGB) + (EDIT-COLOR-GREEN 50 RGB) + (EDIT-COLOR-BLUE 250 RGB))) + +(DEFUN EDIT-COLOR-RED (VAL COLOR) + (LET ((W (CADR *EDIT-COLOR-MENU-SET*))) + (LET ((SSTR (STRINGIFY (FORMAT NIL "~3D" VAL)))) + (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) 113 + (+ -20 (CADDDR W)) (GET-C-STRING SSTR) (LENGTH SSTR))) + (SETF (CAR COLOR) (MAX 0 (1- (* 256 VAL)))) + (EDIT-DISPLAY-COLOR W COLOR))) + +(DEFUN EDIT-COLOR-GREEN (VAL COLOR) + (LET ((W (CADR *EDIT-COLOR-MENU-SET*))) + (LET ((SSTR (STRINGIFY (FORMAT NIL "~3D" VAL)))) + (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) 163 + (+ -20 (CADDDR W)) (GET-C-STRING SSTR) (LENGTH SSTR))) + (SETF (CADR COLOR) (MAX 0 (1- (* 256 VAL)))) + (EDIT-DISPLAY-COLOR W COLOR))) + +(DEFUN EDIT-COLOR-BLUE (VAL COLOR) + (LET ((W (CADR *EDIT-COLOR-MENU-SET*))) + (LET ((SSTR (STRINGIFY (FORMAT NIL "~3D" VAL)))) + (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) 213 + (+ -20 (CADDDR W)) (GET-C-STRING SSTR) (LENGTH SSTR))) + (SETF (CADDR COLOR) (MAX 0 (1- (* 256 VAL)))) + (EDIT-DISPLAY-COLOR W COLOR))) + +(DEFUN EDIT-DISPLAY-COLOR (W COLOR) + (WINDOW-SET-COLOR W COLOR) + (WINDOW-DRAW-LINE-XY W 50 40 50 100 60) + (WINDOW-RESET-COLOR W) + (IF *EDIT-COLOR-OLD-COLOR* + (WINDOW-FREE-COLOR W *EDIT-COLOR-OLD-COLOR*)) + (SETQ *EDIT-COLOR-OLD-COLOR* *WINDOW-XCOLOR*)) + +(DEFUN EDIT-COLOR (W) + (LET (DONE COLOR SEL) + (IF (OR (NULL *EDIT-COLOR-MENU-SET*) + (NOT (EQ W (CADR (CADDR (CAADDR *EDIT-COLOR-MENU-SET*)))))) + (EDIT-COLOR-INIT W)) + (SETQ COLOR (FIRST (NTH 16 *EDIT-COLOR-RMENU*))) + (MENU-SET-DRAW *EDIT-COLOR-MENU-SET*) + (EDIT-COLOR-RED (TRUNCATE (1+ (CAR COLOR)) 256) COLOR) + (EDIT-COLOR-GREEN (TRUNCATE (1+ (CADR COLOR)) 256) COLOR) + (EDIT-COLOR-BLUE (TRUNCATE (1+ (CADDR COLOR)) 256) COLOR) + (WHILE (NOT DONE) + (SETQ SEL (MENU-SET-SELECT *EDIT-COLOR-MENU-SET*)) + (SETQ DONE (AND SEL (EQ (FIRST SEL) 'DONE)))) + COLOR)) +(SETF (GET 'EDIT-COLOR 'GLARGUMENTS) '((W WINDOW))) +(SETF (GET 'EDIT-COLOR 'GLFNRESULTTYPE) 'RGB) + + +(DEFUN COLOR-DOT (W X Y COLOR) + (LET (RGB) + (SETQ RGB + (CDR (ASSOC COLOR + '((RED 65535 0 0) (YELLOW 65535 57600 0) + (GREEN 0 50175 12287) (BLUE 0 0 65535))))) + (OR RGB (SETQ RGB '(30000 30000 30000))) + (WINDOW-SET-COLOR W RGB) + (WINDOW-DRAW-DOT-XY W X Y) + (WINDOW-RESET-COLOR W))) + +(DEFUN COMPILE-EDITORS () + (GLCOMPFILES *DIRECTORY* '("glisp/vector.lsp" "X/dwindow.lsp") + '("glisp/editors.lsp") "glisp/editorstrans.lsp" "glisp/gpl.txt") + (CF EDITORSTRANS)) + +(DEFUN COMPILE-EDITORSB () + (GLCOMPFILES *DIRECTORY* + '("glisp/vector.lsp" "X/dwindow.lsp" "X/dwnoopen.lsp") + '("glisp/editors.lsp") "glisp/editorstrans.lsp" "glisp/gpl.txt")) diff --git a/xgcl-2/gcl_general.lsp b/xgcl-2/gcl_general.lsp new file mode 100644 index 0000000..8a6be1f --- /dev/null +++ b/xgcl-2/gcl_general.lsp @@ -0,0 +1,86 @@ +(in-package :XLIB) +; general.lsp Hiep Huu Nguyen ; 24 Jun 06 +; 15 Sep 05; 24 Jan 06 + +; Copyright (c) 1994 Hiep Huu Nguyen and The University of Texas at Austin. + +; See the files gnu.license and dec.copyright . + +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 1, or (at your option) +; any later version. + +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +; Some of the files that interface to the Xlib are adapted from DEC/MIT files. +; See the file dec.copyright for details. + +; 27 Aug 92 +; 15 Sep 05: Edited by G. Novak to change C function headers to new form +; 24 Jan 06: Edited by G. Novak to remove vertex-array entries. +; 22 Jun 06: Edited by G. Novak to fix entry types + +;(defentry free (string) (void free)) +;(defentry calloc(fixnum fixnum) (string calloc)) +(defentry char-array (int) (fixnum char_array)) +(defentry char-pos (fixnum int) (char char_pos)) +(defentry set-char-array (fixnum int char) (void set_char_array)) + +(defentry int-array (int) (fixnum int_array)) +(defentry int-pos (fixnum int) (int int_pos)) +(defentry set-int-array (fixnum int int) (void set_int_array)) + +(defentry fixnum-array (int) (fixnum fixnum_array)) +(defentry fixnum-pos (fixnum int) (fixnum fixnum_pos)) +(defentry set-fixnum-array (fixnum int fixnum) (void set_fixnum_array)) + +;;from mark ring's function +;; General routines. +(defCfun "object get_c_string(object s)" 0 + " return((object)s->st.st_self);" + ) +(defCfun "object get_c_string1(object s)" 0 + " return((object)object_to_string(s));" + ) +(defCfun "fixnum get_c_string2(object s)" 0 + " return((fixnum)get_c_string(s));" + ) +(defentry get_c_string_2 (object) (object get_c_string)) + +;; make sure string is null terminated + +(defentry get-c-string (object) (object get_c_string1));"(object)object_to_string")) + +;; General routines. +(defCfun "object lisp_string(object a_string, fixnum c_string) " 0 + "extern long strlen(const char *);" + "fixnum len = strlen((void *)c_string);" + "a_string->st.st_dim = len;" + "a_string->st.st_fillp = len;" + "a_string->st.st_self = (void *)c_string;" + "return(a_string);" + ) + +(defentry lisp-string-2 (object fixnum ) (object lisp_string)) +(defun lisp-string (a-string ) + (lisp-string-2 "" a-string )) + +;;modified from mark ring's function +;; General routines. +(defCfun "fixnum get_st_point(object s)" 0 + " return((fixnum) s->st.st_self);" + ) +(defentry get-st-point2 (object) (fixnum get_c_string2));"(fixnum)get_c_string")) + +;; make sure string is null terminated +(defun get-st-point (string) + ( get-st-point2 (concatenate 'string string ""))) + diff --git a/xgcl-2/gcl_ice-cream.lsp b/xgcl-2/gcl_ice-cream.lsp new file mode 100644 index 0000000..dcf51a9 --- /dev/null +++ b/xgcl-2/gcl_ice-cream.lsp @@ -0,0 +1,37 @@ +; ice-cream.lsp 14 Nov 1994 16:16:15 + + +(SETF (GET 'ICE-CREAM 'DRAW-DESCR) + '(DRAW-DESC ICE-CREAM + ((DRAW-DOT (79 294) (4 4) NIL 0) + (DRAW-CIRCLE (7 222) (148 148) NIL 0) + (DRAW-ELLIPSE (7 274) (148 44) NIL 0) + (DRAW-LINE (81 296) (0 -278) NIL 0) + (DRAW-LINE (81 18) (74 278) NIL 0) + (DRAW-LINE (81 18) (-74 278) NIL 0) + (DRAW-ELLIPSE (0 269) (162 54) NIL 0) + (DRAW-ARROW (154 391) (-27 -35) NIL 0) + (DRAW-TEXT (140 395) (63 14) "Ice Cream" 0) + (DRAW-ARROW (81 296) (-74 0) NIL 0) + (DRAW-TEXT (47 299) (7 14) "r" 0) + (DRAW-TEXT (86 186) (7 14) "h" 0) + (DRAW-LINE (81 0) (81 296) NIL 0) + (DRAW-LINE (81 0) (-81 296) NIL 0)) + (0 0) (203 409))) + +(DEFUN DRAW-ICE-CREAM (W X Y) + (WINDOW-DRAW-DOT-XY W (+ 81 X) (+ 296 Y)) + (WINDOW-DRAW-CIRCLE-XY W (+ 81 X) (+ 296 Y) 74) + (WINDOW-DRAW-ELLIPSE-XY W (+ 81 X) (+ 296 Y) 74 22) + (WINDOW-DRAW-LINE-XY W (+ 81 X) (+ 296 Y) (+ 81 X) (+ 18 Y)) + (WINDOW-DRAW-LINE-XY W (+ 81 X) (+ 18 Y) (+ 155 X) (+ 296 Y)) + (WINDOW-DRAW-LINE-XY W (+ 81 X) (+ 18 Y) (+ 7 X) (+ 296 Y)) + (WINDOW-DRAW-ELLIPSE-XY W (+ 81 X) (+ 296 Y) 81 27) + (WINDOW-DRAW-ARROW-XY W (+ 154 X) (+ 391 Y) (+ 127 X) (+ 356 Y)) + (WINDOW-PRINTAT-XY W "Ice Cream" (+ 140 X) (+ 395 Y)) + (WINDOW-DRAW-ARROW-XY W (+ 81 X) (+ 296 Y) (+ 7 X) (+ 296 Y)) + (WINDOW-PRINTAT-XY W "r" (+ 47 X) (+ 299 Y)) + (WINDOW-PRINTAT-XY W "h" (+ 86 X) (+ 186 Y)) + (WINDOW-DRAW-LINE-XY W (+ 81 X) Y (+ 162 X) (+ 296 Y)) + (WINDOW-DRAW-LINE-XY W (+ 81 X) Y X (+ 296 Y)) + (WINDOW-FORCE-OUTPUT W)) diff --git a/xgcl-2/gcl_imports.lsp b/xgcl-2/gcl_imports.lsp new file mode 100644 index 0000000..3fee7b9 --- /dev/null +++ b/xgcl-2/gcl_imports.lsp @@ -0,0 +1,728 @@ +; From: Bill Schelter imports.lsp 16 Nov 94 + +; Copyright (c) 1994 William Schelter and The University of Texas at Austin. + +; See the file gnu.license . + +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 1, or (at your option) +; any later version. + +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + +; The following will make ALL currently defined functions and special variables +; in the xlib package be imported into user. + +(in-package :XLIB) + +(import '(SET-XGCVALUES-SUBWINDOW_MODE SET-XGCVALUES-ARC_MODE WINDOW-SET-CURSOR + MAKE-XVISUALINFO XCOLORMAPEVENT-SERIAL XGCVALUES-LINE_WIDTH + WINDOW-CIRCLE-RADIUS XVISIBILITYEVENT-SERIAL XCOLOR-GREEN + XTEXTPROPERTY-VALUE XCREATEREGION XGCVALUES-SUBWINDOW_MODE + MAKE-XTEXTPROPERTY PICMENU-CREATE XDISPLAYKEYCODES XGCVALUES-DASHES + WINDOW-CLOSE SET-XGCVALUES-BACKGROUND SET-XGCVALUES-FOREGROUND + XUNIONRECTWITHREGION XTEXTITEM-DELTA XCONNECTIONNUMBER + MAKE-XEXTCODES SCREENFORMAT-SCANLINE_PAD XFREEGC XARC-HEIGHT + XPARSECOLOR XKEYCODETOKEYSYM XBUTTONEVENT-TIME WINDOW-SET-INVERT + XPROTOCOLREVISION XPROTOCOLVERSION SET-XFOCUSCHANGEEVENT-TYPE + BARMENU-INIT XSTANDARDCOLORMAP-BLUE_MULT + XSTANDARDCOLORMAP-GREEN_MULT XSTANDARDCOLORMAP-RED_MULT + SET-XCOLOR-FLAGS XQUERYTREE XQUERYCOLOR MAKE-DEPTH XCHANGESAVESET + XCOLORMAPEVENT-COLORMAP SET-XRECTANGLE-HEIGHT XBUTTONEVENT-TYPE + XALLOWEVENTS XDRAWRECTANGLES XSETFILLRULE + XGCVALUES-GRAPHICS_EXPOSURES XSETFILLSTYLE XCOLOR-FLAGS + SET-XKEYBOARDCONTROL-LED_MODE XSETSTATE XBUTTONEVENT-STATE + XQUERYTEXTEXTENTS SCREEN-DEPTHS SCREEN-NDEPTHS MENU-INIT + SET-XGCVALUES-LINE_WIDTH SCREENFORMAT-DEPTH XINSTALLCOLORMAP XARC-Y + SET-XFOCUSCHANGEEVENT-SERIAL XOFFSETREGION SET-XFONTPROP-CARD32 + XIMAGE-BITMAP_BIT_ORDER SET-XWMHINTS-INITIAL_STATE XSTORECOLOR + MAKE-XMAPEVENT XBUTTONEVENT-SERIAL SET-XKEYBOARDCONTROL-BELL_PITCH + SET-XKEYBOARDSTATE-BELL_PITCH SET-XKEYEVENT-KEYCODE + SCREENFORMAT-BITS_PER_PIXEL XKEYSYMTOSTRING + SET-XCLIENTMESSAGEEVENT-FORMAT SET-XRESIZEREQUESTEVENT-WIDTH + WINDOW-DRAW-LINE XGCVALUES-PLANE_MASK XFILLRECTANGLES XDRAWSEGMENTS + WINDOW-DRAW-CIRCLE SET-XUNMAPEVENT-TYPE XEXPOSEEVENT-HEIGHT + XSTANDARDCOLORMAP-BLUE_MAX XSTANDARDCOLORMAP-GREEN_MAX + XSTANDARDCOLORMAP-RED_MAX XSETWMSIZEHINTS XKEYEVENT-KEYCODE + WINDOW-FORCE-OUTPUT WINDOW-UNMAP XCHARSTRUCT-WIDTH + XDEFAULTCOLORMAPOFSCREEN SET-XFOCUSCHANGEEVENT-DETAIL XSEGMENT-X1 + SCREEN-ROOT XEDATAOBJECT-SCREEN XSEGMENT-Y1 + SET-XMODIFIERKEYMAP-MAX_KEYPERMOD SET-XGCVALUES-CLIP_Y_ORIGIN + SET-XGCVALUES-CLIP_X_ORIGIN SET-XGCVALUES-TS_Y_ORIGIN + SET-XGCVALUES-TS_X_ORIGIN SET-XGCVALUES-CLIP_MASK + SET-XGCVALUES-PLANE_MASK XCHECKMASKEVENT XDEFAULTCOLORMAP + XSEGMENT-X2 SCREEN-DISPLAY XBUTTONEVENT-SAME_SCREEN XSEGMENT-Y2 + XCREATEWINDOWEVENT-BORDER_WIDTH XCREATEWINDOWEVENT-WIDTH + WINDOW-CLEAR SET-SCREEN-EXT_DATA XEXPOSEEVENT-COUNT + SET-XUNMAPEVENT-SERIAL SET-XCLIENTMESSAGEEVENT-SEND_EVENT + XGCVALUES-TS_Y_ORIGIN XGCVALUES-TS_X_ORIGIN XDRAWARCS + XDEFAULTGCOFSCREEN XIMAGE-XOFFSET SET-SCREEN-DEFAULT_GC + SET-XCLIENTMESSAGEEVENT-DISPLAY XCOLORMAPEVENT-SEND_EVENT + XHOSTADDRESS-FAMILY XPROPERTYEVENT-ATOM XMAPPINGEVENT-TYPE + WINDOW-PRINTAT XVISIBILITYEVENT-SEND_EVENT XCOLORMAPEVENT-DISPLAY + XCHANGEPROPERTY XDEFAULTDEPTHOFSCREEN XBUTTONEVENT-BUTTON + XSETWINDOWATTRIBUTES-BACKING_STORE SET-XCLIENTMESSAGEEVENT-WINDOW + XIMAGE-FORMAT XVISIBILITYEVENT-DISPLAY WINDOW-LEFT WINDOW-UNSET + VERTEX-ARRAY XCOLORMAPEVENT-WINDOW XBUTTONEVENT-X + SET-XWMHINTS-ICON_PIXMAP XEDATAOBJECT-PIXMAP_FORMAT + XSELECTIONEVENT-REQUESTOR WINDOW-FONT PICMENU-INIT WINDOW-SET-FONT + XEDATAOBJECT-GC XVISIBILITYEVENT-WINDOW XDELETEPROPERTY + XFINDONEXTENSIONLIST XGETFONTPATH XBUTTONEVENT-Y + WINDOW-CENTEROFFSET SET-XKEYBOARDSTATE-LED_MASK XEDATAOBJECT-FONT + XREBINDKEYSYM SCREEN-SAVE_UNDERS SET-XGCVALUES-DASHES + XMAPPINGEVENT-SERIAL SET-XARC-Y SET-XARC-X WINDOW-INPUT-STRING + SET-XGCVALUES-GRAPHICS_EXPOSURES SET-XCOLOR-BLUE + XDEFAULTVISUALOFSCREEN SET-XWMHINTS-FLAGS VISUAL-CLASS + SET-XRESIZEREQUESTEVENT-HEIGHT WINDOW-PARENT XMATCHVISUALINFO + SET-SCREEN-BACKING_STORE WINDOW-XOR-BOX-XY XFONTSTRUCT-PER_CHAR + XFONTSTRUCT-DEFAULT_CHAR SET-XMODIFIERKEYMAP-MODIFIERMAP + SET-XWMHINTS-WINDOW_GROUP FREE + SET-XSETWINDOWATTRIBUTES-BACKING_PIXEL + SET-XSETWINDOWATTRIBUTES-BORDER_PIXEL + SET-XSETWINDOWATTRIBUTES-BACKGROUND_PIXEL XMOTIONEVENT-TIME + XCHARSTRUCT-DESCENT XCHARSTRUCT-ASCENT SET-XNOEXPOSEEVENT-TYPE + XCHARSTRUCT-ATTRIBUTES XARC-WIDTH SET-XFOCUSCHANGEEVENT-SEND_EVENT + WINDOW-INIT-MOUSE-POLL XBUTTONEVENT-ROOT XBUTTONEVENT-X_ROOT + XBUTTONEVENT-Y_ROOT XMOTIONEVENT-TYPE XCOPYCOLORMAPANDFREE + SET-XFOCUSCHANGEEVENT-DISPLAY XBUTTONEVENT-SEND_EVENT + XCREATEWINDOWEVENT-HEIGHT XSETWINDOWATTRIBUTES-COLORMAP + SET-XKEYBOARDCONTROL-KEY XCHANGEWINDOWATTRIBUTES WINDOW-GCONTEXT + WINDOW-DRAW-BORDER XBUTTONEVENT-DISPLAY XSELECTIONEVENT-PROPERTY + XNOOP XERROREVENT-MINOR_CODE XERROREVENT-REQUEST_CODE + XERROREVENT-ERROR_CODE XMOTIONEVENT-STATE XERROREVENT-RESOURCEID + XFREEMODIFIERMAP SET-XFOCUSCHANGEEVENT-WINDOW XGETATOMNAME + XGETICONNAME SET-XCONFIGUREEVENT-ABOVE + SET-XCONFIGUREREQUESTEVENT-ABOVE WINDOW-INPUT-CHAR-FN + WINDOW-PROCESS-CHAR-EVENT XSETWINDOWATTRIBUTES-BORDER_PIXMAP + XSETWINDOWATTRIBUTES-BACKGROUND_PIXMAP MAKE-XMOTIONEVENT + SET-XKEYBOARDCONTROL-BELL_PERCENT + SET-XKEYBOARDCONTROL-KEY_CLICK_PERCENT + SET-XKEYBOARDSTATE-BELL_PERCENT + SET-XKEYBOARDSTATE-KEY_CLICK_PERCENT XBUTTONEVENT-WINDOW + XBUTTONEVENT-SUBWINDOW SET-XWMHINTS-INPUT SET-XNOEXPOSEEVENT-SERIAL + SET-XSETWINDOWATTRIBUTES-DO_NOT_PROPAGATE_MASK + SET-XSETWINDOWATTRIBUTES-EVENT_MASK SET-XTEXTITEM-DELTA + SET-XTEXTITEM16-DELTA XSETWINDOWCOLORMAP XSETWINDOWBACKGROUNDPIXMAP + XSETWINDOWBORDERPIXMAP XSETWINDOWATTRIBUTES-SAVE_UNDER + XVISUALINFO-SCREEN SET-XKEYBOARDSTATE-AUTO_REPEATS + XMOTIONEVENT-SERIAL XGETDEFAULT XQUERYEXTENSION DEPTH-VISUALS + SET-XSELECTIONREQUESTEVENT-OWNER XMAPWINDOW WINDOW-DESTROY + SET-XCONFIGUREEVENT-TYPE SET-XCONFIGUREREQUESTEVENT-TYPE + XCELLSOFSCREEN SET-XWMHINTS-ICON_WINDOW XFONTSTRUCT-MAX_BOUNDS + XFONTSTRUCT-MIN_BOUNDS XDEFAULTROOTWINDOW XFONTSTRUCT-DESCENT + XFONTSTRUCT-ASCENT SET-XTEXTPROPERTY-VALUE WINDOW-DRAW-BOX-CORNERS + SET-XUNMAPEVENT-EVENT SET-XUNMAPEVENT-SEND_EVENT + WINDOW-DESTROY-SELECTED-WINDOW WINDOW-POSITIVE-Y XFREEFONTPATH + XSETWINDOWBORDER SET-XSETWINDOWATTRIBUTES-BACKING_PLANES + XWMHINTS-ICON_MASK SET-XSELECTIONREQUESTEVENT-REQUESTOR + SET-XSELECTIONEVENT-REQUESTOR SET-XUNMAPEVENT-DISPLAY XGETWMNAME + XSETWINDOWATTRIBUTES-OVERRIDE_REDIRECT WINDOW-DRAW-VECTOR-PT + SET-XANYEVENT-TYPE XREMOVEFROMSAVESET XSETWMNAME + XDEFAULTSCREENOFDISPLAY XMOTIONEVENT-SAME_SCREEN + SET-XUNMAPEVENT-WINDOW XSETWINDOWATTRIBUTES-CURSOR + SET-XCONFIGUREEVENT-SERIAL SET-XCONFIGUREREQUESTEVENT-SERIAL + WINDOW-DRAW-ARROW2-XY XSELECTIONREQUESTEVENT-OWNER + SET-XCOLORMAPEVENT-TYPE MAKE-XPIXMAPFORMATVALUES XNEXTREQUEST + MAKE-XWMHINTS SET-XCOLORMAPEVENT-STATE XALLOCWMHINTS SET-XPOINT-X + XFREECOLORMAP SET-XANYEVENT-SERIAL XSELECTIONREQUESTEVENT-REQUESTOR + XMAPPINGEVENT-SEND_EVENT SET-XCONFIGUREREQUESTEVENT-DETAIL + SET-SCREEN-DEPTHS SET-SCREEN-NDEPTHS XFONTPROP-CARD32 + SET-SCREEN-SAVE_UNDERS XMAPPINGEVENT-DISPLAY SET-XPOINT-Y + SET-XCOLORMAPEVENT-SERIAL XMOTIONEVENT-X WINDOW-DRAW-ARROWHEAD-XY + SET-XHOSTADDRESS-LENGTH XMAPPINGEVENT-WINDOW XVISUALINFO-CLASS + XREMOVEHOSTS SET-XFONTSTRUCT-EXT_DATA + SET-XSELECTIONREQUESTEVENT-PROPERTY SET-XSELECTIONEVENT-PROPERTY + XMOTIONEVENT-Y WINDOW-ERASE-BOX-XY MENU-CHOOSE + XCONFIGUREEVENT-BORDER_WIDTH XCONFIGUREEVENT-WIDTH XGRABPOINTER + SET-XCHARSTRUCT-WIDTH XSETFONTPATH MAKE-XWINDOWATTRIBUTES + WINDOW-QUERY-POINTER XMOTIONEVENT-IS_HINT MAKE-XIMAGE + SET-XCONFIGUREEVENT-X SET-XCONFIGUREREQUESTEVENT-X + SET-XFONTPROP-NAME WINDOW-DRAW-DOT-XY XCOPYAREA SET-SCREEN-DISPLAY + SET-XEXTCODES-MAJOR_OPCODE WINDOW-DRAW-RCBOX-XY + WINDOW-DRAW-LATEX-XY WINDOW-DRAW-BOX-XY SET-XCONFIGUREEVENT-Y + SET-XCONFIGUREREQUESTEVENT-Y SET-XCOLORMAPEVENT-COLORMAP + MAKE-XNOEXPOSEEVENT XDRAWLINE XDRAWLINES XSCREENNUMBEROFSCREEN + WINDOW-PRETTYPRINTAT XSELECTIONREQUESTEVENT-PROPERTY + XWMHINTS-ICON_X SET-XNOEXPOSEEVENT-SEND_EVENT XFREECOLORS + XMOTIONEVENT-ROOT XMOTIONEVENT-X_ROOT XMOTIONEVENT-Y_ROOT + SET-XCONFIGUREEVENT-OVERRIDE_REDIRECT XMOTIONEVENT-SEND_EVENT + SET-XNOEXPOSEEVENT-DISPLAY XWMHINTS-ICON_Y + XSETWINDOWATTRIBUTES-WIN_GRAVITY XSETWINDOWATTRIBUTES-BIT_GRAVITY + XBLACKPIXELOFSCREEN XRECTANGLE-X XMOTIONEVENT-DISPLAY + XDESTROYWINDOW WINDOW-WFUNCTION XRECTANGLE-Y XADDPIXEL + SET-SCREENFORMAT-EXT_DATA XGETPIXEL XMOTIONEVENT-WINDOW + XMOTIONEVENT-SUBWINDOW SET-XEXPOSEEVENT-WIDTH + XWINDOWCHANGES-STACK_MODE XPUTPIXEL XBITMAPBITORDER + XDOESBACKINGSTORE XSETFUNCTION XSETICONNAME + SET-XCONFIGUREREQUESTEVENT-PARENT SET-XMOTIONEVENT-TIME + MAKE-XICONSIZE SET-XCONFIGUREEVENT-EVENT + SET-XCONFIGUREEVENT-SEND_EVENT + SET-XCONFIGUREREQUESTEVENT-SEND_EVENT SET-XMOTIONEVENT-TYPE + XALLOCICONSIZE XDISPLAYNAME XFINDCONTEXT XSIZEHINTS-HEIGHT_INC + XSIZEHINTS-WIDTH_INC SET-XCONFIGUREEVENT-DISPLAY + SET-XCONFIGUREREQUESTEVENT-DISPLAY XKEYMAPEVENT-TYPE MAKE-VISUAL + WINDOW-WAIT-UNMAP SET-XMOTIONEVENT-STATE XTIMECOORD-TIME + WINDOW-PRINTAT-XY SET-XCONFIGUREEVENT-WINDOW + SET-XCONFIGUREREQUESTEVENT-WINDOW SET-XGRAPHICSEXPOSEEVENT-TYPE + SET-XANYEVENT-SEND_EVENT XCONFIGUREEVENT-HEIGHT + SET-XANYEVENT-DISPLAY SET-XCHARSTRUCT-DESCENT + SET-XCHARSTRUCT-ASCENT XEHEADOFEXTENSIONLIST + SET-XCHARSTRUCT-ATTRIBUTES XSIZEHINTS-BASE_WIDTH + XSIZEHINTS-MAX_WIDTH XSIZEHINTS-MIN_WIDTH XSIZEHINTS-WIDTH + SET-XMOTIONEVENT-SERIAL SET-XIMAGE-BITMAP_PAD XBELL + SET-XCREATEWINDOWEVENT-TYPE SET-XHOSTADDRESS-ADDRESS XLOOKUPSTRING + XDISPLAYSTRING SET-XCOLORMAPEVENT-SEND_EVENT XKEYMAPEVENT-SERIAL + SET-XANYEVENT-WINDOW XRESIZEREQUESTEVENT-WIDTH + SET-XCOLORMAPEVENT-DISPLAY VISUAL-MAP_ENTRIES + SET-XGRAPHICSEXPOSEEVENT-SERIAL XWINDOWCHANGES-BORDER_WIDTH + XWINDOWCHANGES-WIDTH SET-XCOLORMAPEVENT-WINDOW SET-VISUAL-EXT_DATA + ISPFKEY WINDOW-YPOSITION XWIDTHMMOFSCREEN XWINDOWATTRIBUTES-DEPTH + SET-XCREATEWINDOWEVENT-SERIAL SET-XMOTIONEVENT-SAME_SCREEN + XGRAPHICSEXPOSEEVENT-MINOR_CODE XGRAPHICSEXPOSEEVENT-MAJOR_CODE + XCONFIGUREREQUESTEVENT-BORDER_WIDTH XCONFIGUREREQUESTEVENT-WIDTH + XWINDOWATTRIBUTES-BORDER_WIDTH XWINDOWATTRIBUTES-WIDTH + MAKE-XRECTANGLE XWINDOWATTRIBUTES-BACKING_PIXEL XINITEXTENSION + SET-XFONTSTRUCT-DIRECTION SET-XIMAGE-DEPTH SET-XMAPEVENT-TYPE + XDESTROYWINDOWEVENT-TYPE XWINDOWATTRIBUTES-VISUAL + SET-XEXPOSEEVENT-HEIGHT WINDOW-PRETTYPRINTAT-XY + XGRAPHICSEXPOSEEVENT-DRAWABLE SET-XIMAGE-WIDTH XDESTROYSUBWINDOWS + SET-XIMAGE-BITS_PER_PIXEL XUNMAPEVENT-FROM_CONFIGURE XGETWMHINTS + GET_C_STRING_2 XGETIMAGE SET-XMOTIONEVENT-X + SET-XFONTSTRUCT-PROPERTIES SET-XFONTSTRUCT-N_PROPERTIES + XDISPLAYWIDTHMM SET-XEXTCODES-EXTENSION XPUTIMAGE + XCONFIGUREREQUESTEVENT-VALUE_MASK XDRAWSTRING16 XSUBIMAGE + XWINDOWATTRIBUTES-DO_NOT_PROPAGATE_MASK + XWINDOWATTRIBUTES-YOUR_EVENT_MASK MAKE-XPROPERTYEVENT + SET-XMAPEVENT-SERIAL XDESTROYWINDOWEVENT-SERIAL + SET-XEXPOSEEVENT-COUNT SET-XMOTIONEVENT-Y XWINDOWCHANGES-X + SET-XSTANDARDCOLORMAP-KILLID SET-XGRAPHICSEXPOSEEVENT-X + WINDOW-GET-VECTOR-END SET-XIMAGE-BLUE_MASK SET-XIMAGE-GREEN_MASK + SET-XIMAGE-RED_MASK _XQEVENT-EVENT XRECOLORCURSOR XWINDOWCHANGES-Y + XWIDTHOFSCREEN XWINDOWATTRIBUTES-X SET-XVISUALINFO-VISUALID + XTIMECOORD-X XSIZEHINTS-BASE_HEIGHT XSIZEHINTS-MAX_HEIGHT + XSIZEHINTS-MIN_HEIGHT XSIZEHINTS-HEIGHT MENU-DISPLAY-ITEM + LISP-STRING-2 SET-XGRAPHICSEXPOSEEVENT-Y + XWINDOWATTRIBUTES-BACKING_PLANES MENU-FIND-ITEM-WIDTH + XSTRINGTOKEYSYM _XQEVENT-NEXT SET-XCREATEWINDOWEVENT-X + SET-XMOTIONEVENT-IS_HINT MAKE-XANYEVENT XWINDOWATTRIBUTES-Y + SET-XGRAVITYEVENT-TYPE XTIMECOORD-Y XRESIZEREQUESTEVENT-HEIGHT + XDOESSAVEUNDERS SET-XCREATEWINDOWEVENT-Y + XWINDOWATTRIBUTES-ALL_EVENT_MASKS XFONTPROP-NAME XSCREENOFDISPLAY + XLISTEXTENSIONS XWINDOWCHANGES-HEIGHT XGRAPHICSEXPOSEEVENT-WIDTH + SET-XCREATEWINDOWEVENT-OVERRIDE_REDIRECT XPARSEGEOMETRY + SET-XMOTIONEVENT-ROOT SET-XMOTIONEVENT-X_ROOT + SET-XMOTIONEVENT-Y_ROOT PICMENU-DRAW-BUTTON + SET-XFONTSTRUCT-ALL_CHARS_EXIST SET-XVISUALINFO-BITS_PER_RGB + SET-VERTEX-ARRAY SET-XMOTIONEVENT-SEND_EVENT + XCONFIGUREREQUESTEVENT-HEIGHT XWINDOWATTRIBUTES-HEIGHT XWARPPOINTER + XKEYMAPEVENT-SEND_EVENT SET-XMOTIONEVENT-DISPLAY + SET-XGRAVITYEVENT-SERIAL XCROSSINGEVENT-MODE SET-XMAPPINGEVENT-TYPE + XKEYMAPEVENT-DISPLAY SET-_XQEVENT-EVENT XRESOURCEMANAGERSTRING + SET-XIMAGE-HEIGHT SET-XGRAPHICSEXPOSEEVENT-SEND_EVENT + SET-XMOTIONEVENT-WINDOW SET-XMOTIONEVENT-SUBWINDOW + SET-XCREATEWINDOWEVENT-PARENT XKEYMAPEVENT-WINDOW + SET-XGRAPHICSEXPOSEEVENT-DISPLAY SET-_XQEVENT-NEXT XQUERYPOINTER + SET-CHAR-ARRAY ISCURSORKEY SET-XCREATEWINDOWEVENT-SEND_EVENT + XSAVECONTEXT SET-XWINDOWCHANGES-STACK_MODE + SET-XMAPEVENT-OVERRIDE_REDIRECT XGETCLASSHINT WINDOW-GET-ELLIPSE + PICMENU-ITEM-POSITION SET-XCREATEWINDOWEVENT-DISPLAY + XQUERYTEXTEXTENTS16 SET-XMAPPINGEVENT-SERIAL + SET-XMAPREQUESTEVENT-TYPE SET-XIMAGE-BITMAP_UNIT + SET-XVISUALINFO-DEPTH SET-XCROSSINGEVENT-TIME + SET-XCREATEWINDOWEVENT-WINDOW XNOEXPOSEEVENT-TYPE + SET-XVISUALINFO-COLORMAP_SIZE SET-XCROSSINGEVENT-TYPE + SET-XERROREVENT-TYPE XSIZEHINTS-MAX_ASPECT_X + XSIZEHINTS-MIN_ASPECT_X XGETTRANSIENTFORHINT MENU-FIND-ITEM-HEIGHT + XADDHOSTS SET-XVISUALINFO-VISUAL SET-XCROSSINGEVENT-STATE + XSIZEHINTS-MAX_ASPECT_Y XSIZEHINTS-MIN_ASPECT_Y SET-XMAPEVENT-EVENT + SET-XMAPEVENT-SEND_EVENT SET-XMAPREQUESTEVENT-SERIAL + XDESTROYWINDOWEVENT-EVENT XDESTROYWINDOWEVENT-SEND_EVENT + SET-XGRAVITYEVENT-X XFOCUSCHANGEEVENT-TYPE + SET-XSTANDARDCOLORMAP-COLORMAP SET-VISUAL-MAP_ENTRIES XDRAWTEXT16 + WINDOW-GET-BOX-SIZE MAKE-XSELECTIONCLEAREVENT + MAKE-XSELECTIONREQUESTEVENT MAKE-XSELECTIONEVENT + SET-XMAPEVENT-DISPLAY XDESTROYWINDOWEVENT-DISPLAY + XNOEXPOSEEVENT-SERIAL SET-XGRAVITYEVENT-Y XFETCHBUFFER + XGRAPHICSEXPOSEEVENT-HEIGHT WINDOW-SET-COLOR-RGB + SET-XCROSSINGEVENT-SERIAL SET-XERROREVENT-SERIAL + SET-XVISUALINFO-BLUE_MASK SET-XVISUALINFO-GREEN_MASK + SET-XVISUALINFO-RED_MASK SET-XWINDOWATTRIBUTES-DEPTH + SET-XMAPEVENT-WINDOW XDESTROYWINDOWEVENT-WINDOW + SET-XSIZEHINTS-HEIGHT_INC SET-XSIZEHINTS-WIDTH_INC XPOINTINREGION + GET-ST-POINT2 SET-XWINDOWATTRIBUTES-BORDER_WIDTH + SET-XWINDOWATTRIBUTES-WIDTH SET-XWINDOWCHANGES-BORDER_WIDTH + SET-XWINDOWCHANGES-WIDTH SET-VISUAL-CLASS GET-C-STRING XSETWMHINTS + SET-XWINDOWATTRIBUTES-BACKING_PIXEL MAKE-SCREEN SET-XEDATAOBJECT-GC + XFOCUSCHANGEEVENT-SERIAL XWHITEPIXELOFSCREEN XTEXTEXTENTS + SET-XWINDOWATTRIBUTES-VISUAL PICMENU-DELETE-NAMED-BUTTON + XARC-ANGLE1 SET-XCROSSINGEVENT-DETAIL XGRAPHICSEXPOSEEVENT-COUNT + XWRITEBITMAPFILE XMINCMAPSOFSCREEN + SET-XPIXMAPFORMATVALUES-SCANLINE_PAD WINDOW-GET-REGION + SET-XCROSSINGEVENT-SAME_SCREEN XMAXCMAPSOFSCREEN + SET-XSIZEHINTS-BASE_WIDTH SET-XSIZEHINTS-MAX_WIDTH + SET-XSIZEHINTS-MIN_WIDTH SET-XSIZEHINTS-WIDTH SET-XSEGMENT-X1 + XARC-ANGLE2 MAKE-XREPARENTEVENT SET-XSEGMENT-Y1 SET-SCREEN-ROOT + XFOCUSCHANGEEVENT-DETAIL XSETCLIPORIGIN SET-XSEGMENT-X2 + SET-XGRAVITYEVENT-EVENT SET-XGRAVITYEVENT-SEND_EVENT XPOINT-Y + XSETCLIPMASK SET-XSEGMENT-Y2 + SET-XWINDOWATTRIBUTES-DO_NOT_PROPAGATE_MASK + SET-XWINDOWATTRIBUTES-YOUR_EVENT_MASK XFILLARCS XDISPLAYHEIGHTMM + SET-XGRAVITYEVENT-DISPLAY XGETSTANDARDCOLORMAP XQUERYBESTTILE + XIMAGEBYTEORDER SET-XPROPERTYEVENT-TIME SCREEN-BLACK_PIXEL + SET-XGRAVITYEVENT-WINDOW SET-XPROPERTYEVENT-TYPE + SET-XCROSSINGEVENT-X XICONSIZE-HEIGHT_INC SET-XWINDOWATTRIBUTES-X + SET-XWINDOWCHANGES-X SET-XPIXMAPFORMATVALUES-DEPTH XGETSIZEHINTS + SET-XWINDOWATTRIBUTES-BACKING_PLANES XQUERYBESTCURSOR + SET-XPROPERTYEVENT-STATE SET-XCROSSINGEVENT-Y XSETWMPROPERTIES + WINDOW-GET-CROSSHAIRS SET-XWINDOWATTRIBUTES-Y SET-XWINDOWCHANGES-Y + SET-XMAPPINGEVENT-SEND_EVENT SET-XPIXMAPFORMATVALUES-BITS_PER_PIXEL + MAKE-XCLASSHINT XCREATEBITMAPFROMDATA XALLOCCLASSHINT + SET-XMAPPINGEVENT-DISPLAY SET-XWINDOWATTRIBUTES-ALL_EVENT_MASKS + XQUERYBESTSTIPPLE SET-XPROPERTYEVENT-SERIAL + SET-XMAPPINGEVENT-WINDOW SET-XMAPREQUESTEVENT-PARENT + WINDOW-SET-FOREGROUND WINDOW-SET-BACKGROUND WINDOW-GET-POINT + SET-XWINDOWATTRIBUTES-HEIGHT SET-XWINDOWCHANGES-HEIGHT + XGETWMCLIENTMACHINE XGETERRORDATABASETEXT XSTRINGLISTTOTEXTPROPERTY + SET-XMAPREQUESTEVENT-SEND_EVENT XGETERRORTEXT XSETCLIPRECTANGLES + XGETTEXTPROPERTY XSETCLASSHINT XCROSSINGEVENT-FOCUS + SET-XMAPREQUESTEVENT-DISPLAY XDRAWSTRING XNOEXPOSEEVENT-SEND_EVENT + MAKE-XRESIZEREQUESTEVENT XGETMODIFIERMAPPING XDEFAULTDEPTH + SET-XCROSSINGEVENT-ROOT SET-XCROSSINGEVENT-X_ROOT + SET-XCROSSINGEVENT-Y_ROOT XLISTPROPERTIES SET-XEDATAOBJECT-SCREEN + XSTANDARDCOLORMAP-KILLID MAKE-XEDATAOBJECT XNOEXPOSEEVENT-DISPLAY + SET-XSIZEHINTS-BASE_HEIGHT SET-XSIZEHINTS-MAX_HEIGHT + SET-XSIZEHINTS-MIN_HEIGHT SET-XSIZEHINTS-HEIGHT + SET-XCROSSINGEVENT-SEND_EVENT MAKE-XSTANDARDCOLORMAP + XALLOCSTANDARDCOLORMAP SET-XMAPREQUESTEVENT-WINDOW CALLOC + XNEXTEVENT ISKEYPADKEY XSENDEVENT SET-XCROSSINGEVENT-DISPLAY + SET-XERROREVENT-DISPLAY WINDOW-INVERT-AREA WINDOW-INVERTAREA + XADDHOST XSETFONT XGCVALUES-CAP_STYLE XDEFAULTVISUAL + XFOCUSCHANGEEVENT-SEND_EVENT XSETTRANSIENTFORHINT MENU + SET-XCROSSINGEVENT-WINDOW SET-XCROSSINGEVENT-SUBWINDOW + XICONSIZE-MAX_WIDTH XICONSIZE-MIN_WIDTH XENABLEACCESSCONTROL + XMAPSUBWINDOWS XFOCUSCHANGEEVENT-DISPLAY WINDOW-GET-GEOMETRY + XCONVERTSELECTION WINDOW-SET-LINE-WIDTH MENU-CLEAR + XKEYBOARDCONTROL-BELL_DURATION XFOCUSCHANGEEVENT-WINDOW + XSETACCESSCONTROL MAKE-XCHARSTRUCT XCHANGEKEYBOARDMAPPING + XDISPLAYOFSCREEN XGCVALUES-FILL_RULE XAUTOREPEATOFF + XEXTCODES-FIRST_ERROR XGCVALUES-FILL_STYLE + SET-XEDATAOBJECT-PIXMAP_FORMAT WINDOW-FOREGROUND XSETERRORHANDLER + XSTOREBUFFER XFILLARC WINDOW-BACKGROUND SET-XEDATAOBJECT-FONT + XMAPREQUESTEVENT-TYPE XANYEVENT-TYPE MENU-DRAW MAKE-XCONFIGUREEVENT + MAKE-XCONFIGUREREQUESTEVENT XEXTCODES-FIRST_EVENT LISP-STRING + XDRAWRECTANGLE XIMAGE-BITMAP_PAD XIMAGE-BLUE_MASK + MAKE-XCLIENTMESSAGEEVENT XTEXTITEM16-FONT VISUAL-BLUE_MASK + XKEYBOARDSTATE-BELL_DURATION XGCVALUES-JOIN_STYLE + XGETSELECTIONOWNER XTEXTITEM16-NCHARS XTEXTITEM16-CHARS + XUNGRABBUTTON XMAPREQUESTEVENT-SERIAL SET-XCOLOR-PIXEL + SET-XSIZEHINTS-MAX_ASPECT_X SET-XSIZEHINTS-MIN_ASPECT_X + XUNGRABPOINTER SET-XPROPERTYEVENT-SEND_EVENT XSETSTANDARDCOLORMAP + XSERVERVENDOR XRECTANGLE-WIDTH XCLASSHINT-RES_NAME SCREEN-MWIDTH + SCREEN-WIDTH XICONSIZE-WIDTH_INC XPLANESOFSCREEN + XCIRCULATESUBWINDOWSUP WINDOW-ERASE-AREA XUNGRABSERVER + MAKE-XBUTTONEVENT XCHANGEKEYBOARDCONTROL + SET-XSIZEHINTS-MAX_ASPECT_Y SET-XSIZEHINTS-MIN_ASPECT_Y + SET-XPROPERTYEVENT-DISPLAY XKEYBOARDSTATE-GLOBAL_AUTO_REPEAT + VISUAL-VISUALID XFILLRECTANGLE XHEIGHTOFSCREEN XCOLOR-PIXEL + XLOADFONT XLISTFONTS XHOSTADDRESS-LENGTH XEXPOSEEVENT-TYPE + XGCVALUES-LINE_STYLE WINDOW-TOP-NEG-Y MAKE-XCIRCULATEEVENT + MAKE-XCIRCULATEREQUESTEVENT XTRANSLATECOORDINATES + MENU-ITEM-POSITION XSETSIZEHINTS XSTANDARDCOLORMAP-COLORMAP + SET-XPROPERTYEVENT-WINDOW XICONSIZE-MAX_HEIGHT XICONSIZE-MIN_HEIGHT + XGETCOMMAND WINDOW-STD-LINE-ATTR WINDOW-SET-LINE-ATTR + XUNINSTALLCOLORMAP MAKE-SCREENFORMAT XGRAVITYEVENT-X SCREEN-CMAP + XSELECTIONCLEAREVENT-TIME XALLOCNAMEDCOLOR XHEIGHTMMOFSCREEN + XQUERYFONT SCREENFORMAT-EXT_DATA SET-XFOCUSCHANGEEVENT-MODE + WINDOW-SET-XCOLOR WINDOW-SET-COLOR XBITMAPPAD + XCLIENTMESSAGEEVENT-MESSAGE_TYPE XCLIENTMESSAGEEVENT-TYPE + XGRAVITYEVENT-Y XSELECTIONCLEAREVENT-TYPE MAKE-XDESTROYWINDOWEVENT + WINDOW-SYNC XGCVALUES-TILE XCLOSEDISPLAY XGCVALUES-DASH_OFFSET + XEXPOSEEVENT-SERIAL XQUERYKEYMAP WINDOW-ADJUST-BOX-SIDE + VISUAL-BITS_PER_RGB WINDOW-CREATE XSETSTANDARDPROPERTIES + XSELECTIONEVENT-TIME XIMAGE-GREEN_MASK XGCVALUES-FUNCTION + XSETWMCLIENTMACHINE SET-XREPARENTEVENT-TYPE XSELECTIONEVENT-TYPE + XTEXTPROPERTY-ENCODING XCREATECOLORMAP XSHRINKREGION SET-INT-ARRAY + VISUAL-GREEN_MASK XCREATEPIXMAPFROMBITMAPDATA CHAR-ARRAY + SET-XRECTANGLE-X XSETTEXTPROPERTY XCLIENTMESSAGEEVENT-SERIAL + MAKE-XCOLORMAPEVENT SET-XGCVALUES-STIPPLE XFREESTRINGLIST + XSELECTIONCLEAREVENT-SERIAL XSETMODIFIERMAPPING WINDOW-MOVE + XCREATEPIXMAP BARMENU-SELECT SET-XGCVALUES-FILL_RULE + SET-XRECTANGLE-Y WINDOW-LABEL SET-XGCVALUES-TILE + SET-XGCVALUES-FILL_STYLE SET-XGCVALUES-JOIN_STYLE + SET-XGCVALUES-CAP_STYLE SET-XGCVALUES-LINE_STYLE XPENDING + XIMAGE-DEPTH XGCVALUES-STIPPLE BARMENU-DRAW XSYNC XIMAGE-WIDTH + SET-XREPARENTEVENT-SERIAL XSELECTIONEVENT-SERIAL WINDOW-SIZE + XLISTHOSTS XIMAGE-BITS_PER_PIXEL XQUERYCOLORS MAKE-XMODIFIERKEYMAP + XCOLORMAPEVENT-NEW XLISTPIXMAPFORMATS XFONTSTRUCT-EXT_DATA + XRMINITIALIZE XRECTANGLE-HEIGHT XKEYEVENT-TIME SCREEN-MHEIGHT + SCREEN-HEIGHT SET-XRESIZEREQUESTEVENT-TYPE SET-XKEYEVENT-X + SET-XCOLOR-PAD WINDOW-FREE-COLOR XEDATAOBJECT-VISUAL + XMAPPINGEVENT-FIRST_KEYCODE XARC-X XPUTBACKEVENT XKEYEVENT-TYPE + SET-XUNMAPEVENT-FROM_CONFIGURE XNEWMODIFIERMAP XGRAVITYEVENT-TYPE + SET-XKEYEVENT-Y SET-XCOLOR-RED XRESTACKWINDOWS XWITHDRAWWINDOW + XCHANGEGC MENU-REPOSITION XMAPREQUESTEVENT-PARENT MAKE-XEVENT + XEXPOSEEVENT-X VERTEX-POS-X SCREEN-MIN_MAPS SCREEN-MAX_MAPS + XKEYEVENT-STATE XPROPERTYEVENT-TIME WINDOW-QUERY-POINTER-B + MAKE-XCROSSINGEVENT XFREEFONT XKILLCLIENT + XMAPREQUESTEVENT-SEND_EVENT WINDOW-OPEN XIMAGE-RED_MASK + WINDOW-SET-XOR XCHARSTRUCT-RBEARING XCHARSTRUCT-LBEARING + XGETWINDOWATTRIBUTES XEXPOSEEVENT-Y XPROPERTYEVENT-TYPE + VERTEX-POS-Y XSTORECOLORS XCREATEWINDOWEVENT-TYPE + XMAPREQUESTEVENT-DISPLAY MENU-SELECT XSELECTIONCLEAREVENT-SELECTION + MAKE-XCREATEWINDOWEVENT SET-XRESIZEREQUESTEVENT-SERIAL + XDEFINECURSOR XMAPEVENT-TYPE VISUAL-RED_MASK XTEXTWIDTH XGRABBUTTON + XREFRESHKEYBOARDMAPPING XHOSTADDRESS-ADDRESS XGETWMCOLORMAPWINDOWS + XPROPERTYEVENT-STATE MENU-ADJUST-OFFSET XGRAVITYEVENT-SERIAL + XMAPREQUESTEVENT-WINDOW XVISUALINFO-VISUALID GET-ST-POINT + XGRABSERVER XANYEVENT-DISPLAY XIMAGE-BITMAP_UNIT + XCLIENTMESSAGEEVENT-FORMAT XSELECTIONEVENT-SELECTION + SET-XSELECTIONCLEAREVENT-TIME SET-XSELECTIONREQUESTEVENT-TIME + SET-XSELECTIONEVENT-TIME MAKE-XVISIBILITYEVENT XKEYSYMTOKEYCODE + SET-XREPARENTEVENT-X WINDOW-TRACK-MOUSE XPROPERTYEVENT-SERIAL + XCREATEWINDOWEVENT-SERIAL XSETWINDOWBACKGROUND + SET-XSELECTIONCLEAREVENT-TYPE SET-XSELECTIONREQUESTEVENT-TYPE + SET-XSELECTIONEVENT-TYPE WINDOW-FONT-STRING-WIDTH XFREECURSOR + XCREATEGLYPHCURSOR XSETSELECTIONOWNER SET-XWMHINTS-ICON_MASK + XCREATEWINDOW WINDOW-DRAWABLE-WIDTH STRINGIFY XCLASSHINT-RES_CLASS + SET-XREPARENTEVENT-Y XQLENGTH WINDOW-RESET MENU-UNBOX-ITEM + SET-XNOEXPOSEEVENT-MINOR_CODE SET-XNOEXPOSEEVENT-MAJOR_CODE + XEXPOSEEVENT-SEND_EVENT XANYEVENT-SERIAL XGEOMETRY + XVISUALINFO-BITS_PER_RGB MAKE-XFONTPROP XGCVALUES-FONT + SET-XKEYEVENT-TIME XEXPOSEEVENT-DISPLAY + SET-XREPARENTEVENT-OVERRIDE_REDIRECT SET-XGCVALUES-FUNCTION + XIMAGE-HEIGHT XDELETECONTEXT PICMENU-SELECT WINDOW-PAINT + SET-XFONTSTRUCT-MAX_BYTE1 SET-XFONTSTRUCT-MIN_BYTE1 + XSELECTIONEVENT-TARGET SET-XKEYEVENT-TYPE WINDOW-XINIT + SET-XNOEXPOSEEVENT-DRAWABLE SET-XGCVALUES-DASH_OFFSET + XSELECTIONREQUESTEVENT-TIME XCREATEFONTCURSOR WINDOW-DRAW-BOX + XSETCOMMAND XEXPOSEEVENT-WINDOW XTEXTPROPERTY-FORMAT + SET-XSELECTIONCLEAREVENT-SERIAL SET-XSELECTIONREQUESTEVENT-SERIAL + SET-XSELECTIONEVENT-SERIAL XCLIENTMESSAGEEVENT-SEND_EVENT + WINDOW-POLL-MOUSE PICMENU-DRAW SET-XFONTSTRUCT-MAX_CHAR_OR_BYTE2 + SET-XFONTSTRUCT-MIN_CHAR_OR_BYTE2 XDESTROYIMAGE + XSELECTIONCLEAREVENT-SEND_EVENT SET-XKEYEVENT-STATE + XSELECTIONREQUESTEVENT-TYPE WINDOW-FONT-INFO + XSETWINDOWATTRIBUTES-BACKING_PIXEL + XSETWINDOWATTRIBUTES-BORDER_PIXEL + XSETWINDOWATTRIBUTES-BACKGROUND_PIXEL XCLIENTMESSAGEEVENT-DISPLAY + XSELECTIONCLEAREVENT-DISPLAY XCHECKTYPEDEVENT + XCHECKTYPEDWINDOWEVENT SET-XBUTTONEVENT-TIME XKEYEVENT-X + XCHANGEPOINTERCONTROL XSETWINDOWBORDERWIDTH + SET-XDESTROYWINDOWEVENT-TYPE SET-XREPARENTEVENT-PARENT + SET-XBUTTONEVENT-TYPE SET-XGCVALUES-FONT XCLIENTMESSAGEEVENT-WINDOW + XSELECTIONCLEAREVENT-WINDOW SET-XSETWINDOWATTRIBUTES-BACKING_STORE + XKEYEVENT-Y XTEXTPROPERTY-NITEMS SET-XREPARENTEVENT-EVENT + SET-XREPARENTEVENT-SEND_EVENT SET-XKEYEVENT-SERIAL + XSELECTIONEVENT-SEND_EVENT WINDOW-MENU WINDOW-INVERT-AREA-XY + SET-XBUTTONEVENT-STATE XVISUALINFO-DEPTH SET-XREPARENTEVENT-DISPLAY + XSELECTIONEVENT-DISPLAY WINDOW-TRACK-MOUSE-IN-REGION + XINSERTMODIFIERMAPENTRY WINDOW-DRAW-CARAT XCREATEWINDOWEVENT-X + XTEXTPROPERTYTOSTRINGLIST SET-SCREEN-ROOT_DEPTH + XSELECTIONREQUESTEVENT-SERIAL WINDOW-STRING-WIDTH MENU-DESTROY + XSETWINDOWATTRIBUTES-DO_NOT_PROPAGATE_MASK + XSETWINDOWATTRIBUTES-EVENT_MASK SET-XREPARENTEVENT-WINDOW + XVISUALINFO-COLORMAP_SIZE SET-SCREEN-MWIDTH SET-SCREEN-WIDTH + XINTERNATOM SET-XKEYBOARDCONTROL-BELL_DURATION + SET-XKEYBOARDSTATE-BELL_DURATION XCREATEWINDOWEVENT-Y MENU-OFFSET + SET-XDESTROYWINDOWEVENT-SERIAL SET-SCREEN-BLACK_PIXEL + SET-SCREEN-WHITE_PIXEL SCREEN-ROOT_DEPTH XLISTDEPTHS XLOADQUERYFONT + SET-XBUTTONEVENT-SERIAL XVISUALINFO-VISUAL XFREE WINDOW-SET-COPY + SET-SCREEN-ROOT_VISUAL XTEXTITEM-NCHARS SET-XKEYEVENT-SAME_SCREEN + XTEXTITEM-FONT XCREATEWINDOWEVENT-OVERRIDE_REDIRECT XTEXTITEM-CHARS + SET-XSELECTIONCLEAREVENT-SELECTION + SET-XSELECTIONREQUESTEVENT-SELECTION SET-XSELECTIONEVENT-SELECTION + SET-XKEYBOARDSTATE-GLOBAL_AUTO_REPEAT XFONTSTRUCT-DIRECTION + WINDOW-GEOMETRY XCREATEPIXMAPCURSOR + XSETWINDOWATTRIBUTES-BACKING_PLANES XUNLOADFONT SCREEN-ROOT_VISUAL + SET-XRESIZEREQUESTEVENT-SEND_EVENT MAKE-XUNMAPEVENT + WINDOW-DRAWABLE-HEIGHT XKEYEVENT-ROOT XDELETEMODIFIERMAPENTRY + XSELECTINPUT SET-XRESIZEREQUESTEVENT-DISPLAY XWMHINTS-FLAGS + XGETGCVALUES XVISUALINFO-BLUE_MASK XVISUALINFO-GREEN_MASK + XVISUALINFO-RED_MASK XGRAVITYEVENT-EVENT XGRAVITYEVENT-SEND_EVENT + CHAR-POS WINDOW-INIT-KEYMAP SET-SCREEN-ROOT_INPUT_MASK + WINDOW-DRAW-ELLIPSE-PT WINDOW-DRAW-CIRCLE-PT + SET-XBUTTONEVENT-SAME_SCREEN XVISUALIDFROMVISUAL DEPTH-NVISUALS + XGRAVITYEVENT-DISPLAY WINDOW-RESET-COLOR + SET-XRESIZEREQUESTEVENT-WINDOW ISFUNCTIONKEY + XCREATEWINDOWEVENT-PARENT WINDOW-SCREEN-HEIGHT + XFONTSTRUCT-PROPERTIES XFONTSTRUCT-N_PROPERTIES MENU-BOX-ITEM + SET-XSETWINDOWATTRIBUTES-COLORMAP SCREEN-ROOT_INPUT_MASK + PICMENU-DESTROY XPROPERTYEVENT-SEND_EVENT + XCREATEWINDOWEVENT-SEND_EVENT SET-XSELECTIONREQUESTEVENT-TARGET + SET-XSELECTIONEVENT-TARGET XGRAVITYEVENT-WINDOW XSTORENAMEDCOLOR + MAKE-XGCVALUES XKEYEVENT-DISPLAY XSELECTIONREQUESTEVENT-SELECTION + XMAPEVENT-EVENT XPROPERTYEVENT-DISPLAY SET-XTEXTPROPERTY-ENCODING + XCREATEWINDOWEVENT-DISPLAY SET-XSETWINDOWATTRIBUTES-BORDER_PIXMAP + SET-XSETWINDOWATTRIBUTES-BACKGROUND_PIXMAP XGETWMNORMALHINTS + SET-XCONFIGUREEVENT-BORDER_WIDTH SET-XCONFIGUREEVENT-WIDTH + SET-XCONFIGUREREQUESTEVENT-BORDER_WIDTH + SET-XCONFIGUREREQUESTEVENT-WIDTH XANYEVENT-SEND_EVENT + XDESTROYREGION SET-XKEYMAPEVENT-TYPE SET-XARC-ANGLE1 + WINDOW-MOVETO-XY XPROPERTYEVENT-WINDOW SET-XBUTTONEVENT-BUTTON + XCREATEWINDOWEVENT-WINDOW XSETWMCOLORMAPWINDOWS + SET-XSETWINDOWATTRIBUTES-SAVE_UNDER SET-XBUTTONEVENT-X + SET-XFONTSTRUCT-FID WINDOW-ERASE-AREA-XY XMAPEVENT-DISPLAY + XKEYEVENT-SERIAL XFREEFONTINFO SET-XARC-ANGLE2 XMAPPINGEVENT-COUNT + SET-XCOMPOSESTATUS-CHARS_MATCHED XCHAR2B-BYTE1 + SET-XSELECTIONCLEAREVENT-SEND_EVENT + SET-XSELECTIONREQUESTEVENT-SEND_EVENT + SET-XSELECTIONEVENT-SEND_EVENT XERROREVENT-TYPE SET-XBUTTONEVENT-Y + XWMHINTS-INPUT XWMHINTS-ICON_PIXMAP SCREEN-WHITE_PIXEL + XCONFIGUREEVENT-ABOVE XUNMAPSUBWINDOWS + XSELECTIONREQUESTEVENT-TARGET SET-XSELECTIONCLEAREVENT-DISPLAY + SET-XSELECTIONREQUESTEVENT-DISPLAY SET-XSELECTIONEVENT-DISPLAY + XCHAR2B-BYTE2 SET-SCREEN-MHEIGHT SET-SCREEN-HEIGHT + SET-XSETWINDOWATTRIBUTES-OVERRIDE_REDIRECT XROTATEBUFFERS + SET-XKEYMAPEVENT-SERIAL XBLACKPIXEL XTEXTEXTENTS16 + SET-XCONFIGUREREQUESTEVENT-VALUE_MASK SET-XWMHINTS-ICON_X + MAKE-XERROREVENT COMPILE-DWINDOW WINDOW-STRING-EXTENTS + SET-XSELECTIONCLEAREVENT-WINDOW XFREEFONTNAMES + XFONTSTRUCT-ALL_CHARS_EXIST XMAPEVENT-SERIAL SET-XKEYEVENT-ROOT + SET-XKEYEVENT-X_ROOT SET-XKEYEVENT-Y_ROOT WINDOW-RESET-GEOMETRY + SET-XSETWINDOWATTRIBUTES-CURSOR XCONFIGUREEVENT-TYPE + XMAPPINGEVENT-REQUEST SET-XKEYEVENT-SEND_EVENT XFLUSH + WINDOW-DRAW-ARC-XY MAKE-XARC XREMOVEHOST XKEYEVENT-SAME_SCREEN + WINDOW-COPY-AREA-XY SET-XWMHINTS-ICON_Y WINDOW-DRAW-ELLIPSE-XY + WINDOW-DRAW-CIRCLE-XY WINDOW-DRAW-LINE-XY XERROREVENT-SERIAL + SET-SCREEN-MIN_MAPS SET-SCREEN-MAX_MAPS SET-XKEYEVENT-DISPLAY + MAKE-XWINDOWCHANGES XSELECTIONREQUESTEVENT-SEND_EVENT + SET-DEPTH-DEPTH SET-XCHARSTRUCT-RBEARING SET-XCHARSTRUCT-LBEARING + XGETWINDOWPROPERTY XANYEVENT-WINDOW XFILLPOLYGON + XSELECTIONREQUESTEVENT-DISPLAY XWMHINTS-INITIAL_STATE + SET-XKEYEVENT-WINDOW SET-XKEYEVENT-SUBWINDOW XDRAWPOINTS INT-POS + SET-XBUTTONEVENT-ROOT SET-XBUTTONEVENT-X_ROOT + SET-XBUTTONEVENT-Y_ROOT SET-XDESTROYWINDOWEVENT-EVENT + SET-XDESTROYWINDOWEVENT-SEND_EVENT XICONIFYWINDOW + SET-XBUTTONEVENT-SEND_EVENT XLASTKNOWNREQUESTPROCESSED + SET-XDESTROYWINDOWEVENT-DISPLAY XADDTOEXTENSIONLIST + XCONFIGUREEVENT-SERIAL XGETICONSIZES WINDOW-DRAW-CROSS-XY + WINDOW-DRAW-CROSSHAIRS-XY XCREATESIMPLEWINDOW + SET-XBUTTONEVENT-DISPLAY XRECTINREGION XREPARENTWINDOW + MAKE-XFONTSTRUCT XRESIZEWINDOW SET-XDESTROYWINDOWEVENT-WINDOW + WINDOW-DRAW-ARROW-XY WINDOW-WAIT-EXPOSURE MENU-SIZE + XMAPEVENT-OVERRIDE_REDIRECT SET-XBUTTONEVENT-WINDOW + SET-XBUTTONEVENT-SUBWINDOW SET-XGRAPHICSEXPOSEEVENT-MINOR_CODE + SET-XGRAPHICSEXPOSEEVENT-MAJOR_CODE XCLEARWINDOW + BARMENU-UPDATE-VALUE SET-XCONFIGUREEVENT-HEIGHT + SET-XCONFIGUREREQUESTEVENT-HEIGHT SET-XCOLORMAPEVENT-NEW + SET-XEXPOSEEVENT-TYPE SET-XGRAPHICSEXPOSEEVENT-DRAWABLE + XMOVERESIZEWINDOW XREPARENTEVENT-TYPE XCOLOR-PAD + XWMHINTS-ICON_WINDOW XGETZOOMHINTS MAKE-XFOCUSCHANGEEVENT + MAKE-XTEXTITEM16 XUNIQUECONTEXT XWMHINTS-WINDOW_GROUP + SET-XTEXTPROPERTY-FORMAT XWINDOWATTRIBUTES-MAP_INSTALLED XDRAWPOINT + XCOPYGC SET-XEXPOSEEVENT-SERIAL MAKE-XEXPOSEEVENT SET-XIMAGE-OBDATA + XCHECKWINDOWEVENT SET-XSETWINDOWATTRIBUTES-WIN_GRAVITY + SET-XSETWINDOWATTRIBUTES-BIT_GRAVITY XCONFIGUREEVENT-X XCOLOR-RED + XREPARENTEVENT-SERIAL XKEYEVENT-SEND_EVENT MAKE-XPOINT XTEXTWIDTH16 + MAKE-XHOSTADDRESS XCONFIGUREEVENT-Y SET-XTEXTPROPERTY-NITEMS + SET-SCREENFORMAT-SCANLINE_PAD WINDOW-MAP + XCOMPOSESTATUS-CHARS_MATCHED MAKE-_XQEVENT SET-XTEXTITEM-FONT + SET-XTEXTITEM16-FONT MAKE-XGRAPHICSEXPOSEEVENT + XRESIZEREQUESTEVENT-TYPE XWMGEOMETRY XKEYEVENT-SUBWINDOW + XCONFIGUREREQUESTEVENT-ABOVE SET-XKEYMAPEVENT-SEND_EVENT + SET-XTEXTITEM-NCHARS SET-XTEXTITEM-CHARS SET-XTEXTITEM16-NCHARS + SET-XTEXTITEM16-CHARS XMODIFIERKEYMAP-MAX_KEYPERMOD XBITMAPUNIT + XCONFIGUREEVENT-OVERRIDE_REDIRECT XGETGEOMETRY XMAPEVENT-SEND_EVENT + XWINDOWCHANGES-SIBLING SET-XKEYMAPEVENT-DISPLAY XPOLYGONREGION + XROTATEWINDOWPROPERTIES MAKE-XGRAVITYEVENT XSETWMNORMALHINTS + MENU-MOVETO-XY DOWINDOWCOM SET-XGRAPHICSEXPOSEEVENT-WIDTH + SET-XIMAGE-BYTES_PER_LINE XSCREENCOUNT XALLPLANES + SET-XKEYMAPEVENT-WINDOW XDISPLAYWIDTH XCONFIGUREREQUESTEVENT-TYPE + SET-XFONTSTRUCT-PER_CHAR SET-XFONTSTRUCT-DEFAULT_CHAR + XGETWMICONNAME XERROREVENT-DISPLAY XWINDOWATTRIBUTES-BACKING_STORE + MAKE-XCHAR2B SET-VISUAL-VISUALID PICMENU-CREATE-FROM-SPEC + PICMENU-CREATE-SPEC XRESIZEREQUESTEVENT-SERIAL + XPIXMAPFORMATVALUES-SCANLINE_PAD XKEYEVENT-X_ROOT + SET-XCREATEWINDOWEVENT-BORDER_WIDTH SET-XCREATEWINDOWEVENT-WIDTH + XWINDOWATTRIBUTES-MAP_STATE SET-SCREENFORMAT-DEPTH XGETWMPROTOCOLS + SET-XEXPOSEEVENT-X XKEYEVENT-Y_ROOT XCONFIGUREEVENT-EVENT + XCONFIGUREEVENT-SEND_EVENT XSETTSORIGIN XKEYEVENT-WINDOW + SET-SCREENFORMAT-BITS_PER_PIXEL SET-XHOSTADDRESS-FAMILY + XGETKEYBOARDMAPPING XCONFIGUREEVENT-DISPLAY XREPARENTEVENT-X + SET-XEXPOSEEVENT-Y ISMODIFIERKEY XCONFIGUREREQUESTEVENT-SERIAL + XSETLINEATTRIBUTES XSETIOERRORHANDLER WINDOW-GET-GEOMETRY-B + XREPARENTEVENT-Y XCONFIGUREEVENT-WINDOW SET-VISUAL-BITS_PER_RGB + MENU-SELECT! BARMENU-CALCULATE-SIZE XLOWERWINDOW XSTORENAME + XMAPEVENT-WINDOW XUNGRABKEY XPIXMAPFORMATVALUES-DEPTH + SET-XSTANDARDCOLORMAP-VISUALID XREPARENTEVENT-OVERRIDE_REDIRECT + SET-XFONTSTRUCT-MAX_BOUNDS SET-XFONTSTRUCT-MIN_BOUNDS + XCONFIGUREREQUESTEVENT-DETAIL SET-XFONTSTRUCT-DESCENT + SET-XFONTSTRUCT-ASCENT XLISTINSTALLEDCOLORMAPS + XPIXMAPFORMATVALUES-BITS_PER_PIXEL XDISPLAYPLANES + SET-XMAPPINGEVENT-FIRST_KEYCODE XGETINPUTFOCUS PICMENU-UNBOX-ITEM + XUNMAPEVENT-TYPE XWINDOWATTRIBUTES-SCREEN XSETICONSIZES + XMODIFIERKEYMAP-MODIFIERMAP XWINDOWATTRIBUTES-COLORMAP + XSIZEHINTS-FLAGS XINIT SET-XEXPOSEEVENT-SEND_EVENT XCOPYPLANE + XREPARENTEVENT-PARENT SET-XCOMPOSESTATUS-COMPOSE_PTR + SET-XCIRCULATEEVENT-PLACE SET-XCIRCULATEREQUESTEVENT-PLACE + SET-XEXPOSEEVENT-DISPLAY XGRAPHICSEXPOSEEVENT-TYPE XFREEPIXMAP + XDISPLAYCELLS SET-XTIMECOORD-TIME XREPARENTEVENT-EVENT + XREPARENTEVENT-SEND_EVENT MENU-CREATE XGETKEYBOARDCONTROL + MENU-CALCULATE-SIZE SET-XGRAPHICSEXPOSEEVENT-HEIGHT + XGETFONTPROPERTY XUNMAPEVENT-SERIAL XREPARENTEVENT-DISPLAY + XDISPLAYHEIGHT SET-XEXPOSEEVENT-WINDOW XCIRCULATEEVENT-PLACE + SET-XEXTCODES-FIRST_ERROR XCONFIGUREREQUESTEVENT-X XGETSUBIMAGE + XLOOKUPKEYSYM XACTIVATESCREENSAVER XWINDOWATTRIBUTES-SAVE_UNDER + XNOEXPOSEEVENT-MINOR_CODE XNOEXPOSEEVENT-MAJOR_CODE + XRECONFIGUREWMWINDOW XLOOKUPCOLOR XSETZOOMHINTS + SET-XCREATEWINDOWEVENT-HEIGHT XREPARENTEVENT-WINDOW + XCONFIGUREREQUESTEVENT-Y SET-XERROREVENT-MINOR_CODE + SET-XERROREVENT-REQUEST_CODE SET-XERROREVENT-ERROR_CODE + SET-XERROREVENT-RESOURCEID SET-XARC-WIDTH XSETREGION + SET-XVISIBILITYEVENT-TYPE XGRAPHICSEXPOSEEVENT-SERIAL + XNOEXPOSEEVENT-DRAWABLE XXORREGION SET-XGRAPHICSEXPOSEEVENT-COUNT + SET-XIMAGE-XOFFSET SET-XIMAGE-BITMAP_BIT_ORDER + SET-XIMAGE-BYTE_ORDER XWINDOWATTRIBUTES-OVERRIDE_REDIRECT + SET-XEXTCODES-FIRST_EVENT XSETCLOSEDOWNMODE XRAISEWINDOW + SET-XVISIBILITYEVENT-STATE SET-XCROSSINGEVENT-MODE XREADBITMAPFILE + SET-VISUAL-BLUE_MASK SET-VISUAL-GREEN_MASK SET-VISUAL-RED_MASK + SET-XIMAGE-FORMAT SET-SCREEN-CMAP SET-XCIRCULATEEVENT-TYPE + SET-XCIRCULATEREQUESTEVENT-TYPE XMAXREQUESTSIZE + XRESIZEREQUESTEVENT-SEND_EVENT XGRABKEY + SET-XWINDOWATTRIBUTES-MAP_INSTALLED + SET-XSTANDARDCOLORMAP-BASE_PIXEL XWINDOWATTRIBUTES-CLASS + XLISTFONTSWITHINFO XRESIZEREQUESTEVENT-DISPLAY + XFOCUSCHANGEEVENT-MODE XEVENTSQUEUED SET-XVISIBILITYEVENT-SERIAL + XDRAWTEXT XCIRCULATEEVENT-TYPE INT-ARRAY XMAPRAISED + XCONFIGUREREQUESTEVENT-PARENT WINDOW-GET-CIRCLE + XKEYBOARDCONTROL-LED XWINDOWATTRIBUTES-ROOT + XRESIZEREQUESTEVENT-WINDOW XWHITEPIXEL XCREATEGC + XCONFIGUREREQUESTEVENT-SEND_EVENT PICMENU-CALCULATE-SIZE + XDRAWIMAGESTRING16 XCROSSINGEVENT-TIME + XCONFIGUREREQUESTEVENT-DISPLAY SET-XCIRCULATEEVENT-SERIAL + SET-XCIRCULATEREQUESTEVENT-SERIAL XUNMAPWINDOW XCROSSINGEVENT-TYPE + SET-XCLASSHINT-RES_NAME MAKE-XKEYMAPEVENT XSETWMICONNAME + MAKE-XKEYBOARDSTATE XEMPTYREGION XCLIPBOX XSETSTIPPLE XEQUALREGION + XFORCESCREENSAVER XCONFIGUREREQUESTEVENT-WINDOW + XCIRCULATEEVENT-SERIAL PICMENU-BUTTON-CONTAINSXY? XWINDOWEVENT + WINDOW-GET-CLICK XCROSSINGEVENT-STATE XGRAPHICSEXPOSEEVENT-X + XSETWMPROTOCOLS XSIZEHINTS-WIN_GRAVITY XGRAPHICSEXPOSEEVENT-Y + SET-XWINDOWCHANGES-SIBLING XGETPOINTERMAPPING XFETCHNAME + XCHANGEACTIVEPOINTERGRAB SET-XWINDOWATTRIBUTES-BACKING_STORE + SET-XTIMECOORD-X XCROSSINGEVENT-SERIAL + SET-XWINDOWATTRIBUTES-MAP_STATE SCREEN-DEFAULT_GC SET-XARC-HEIGHT + XGETSCREENSAVER SET-XVISUALINFO-SCREEN SET-XTIMECOORD-Y + SET-DEPTH-NVISUALS XCOMPOSESTATUS-COMPOSE_PTR + MAKE-XSETWINDOWATTRIBUTES XUNMAPEVENT-EVENT XUNMAPEVENT-SEND_EVENT + XMASKEVENT XPEEKEVENT XKEYBOARDCONTROL-AUTO_REPEAT_MODE + XKEYBOARDCONTROL-LED_MODE XCROSSINGEVENT-DETAIL XTEXTITEM16-DELTA + XUNMAPEVENT-DISPLAY XWINDOWATTRIBUTES-WIN_GRAVITY + XWINDOWATTRIBUTES-BIT_GRAVITY XCONFIGUREWINDOW XSETINPUTFOCUS + XCROSSINGEVENT-SAME_SCREEN MAKE-XKEYBOARDCONTROL + XCIRCULATEREQUESTEVENT-PLACE XCLEARAREA XFONTSTRUCT-FID + XUNMAPEVENT-WINDOW XGRAPHICSEXPOSEEVENT-SEND_EVENT + XKEYBOARDCONTROL-BELL_PITCH XGETRGBCOLORMAPS XPOINT-X XSETPLANEMASK + XFETCHBYTES XGRAPHICSEXPOSEEVENT-DISPLAY XSUBTRACTREGION + XEXTCODES-MAJOR_OPCODE SET-XSTANDARDCOLORMAP-BLUE_MULT + SET-XSTANDARDCOLORMAP-GREEN_MULT SET-XSTANDARDCOLORMAP-RED_MULT + MAKE-XTIMECOORD SET-XWINDOWATTRIBUTES-SCREEN XADDTOSAVESET + XGETPOINTERCONTROL WINDOW-GET-LATEX-POSITION + WINDOW-GET-LINE-POSITION WINDOW-GET-ICON-POSITION + WINDOW-GET-BOX-POSITION WINDOW-GET-MOUSE-POSITION + SET-XWINDOWATTRIBUTES-COLORMAP XCROSSINGEVENT-X + XDISABLEACCESSCONTROL SET-XMAPPINGEVENT-COUNT XGETNORMALHINTS + SET-XVISIBILITYEVENT-SEND_EVENT XCROSSINGEVENT-Y XSETFOREGROUND + SET-XVISIBILITYEVENT-DISPLAY SET-XICONSIZE-HEIGHT_INC + SET-XICONSIZE-WIDTH_INC MAKE-XCOLOR + SET-XCIRCULATEREQUESTEVENT-PARENT XMOVEWINDOW + XCIRCULATEREQUESTEVENT-TYPE XALLOCCOLOR XSETDASHES + XGCVALUES-ARC_MODE XDRAWARC MENU-SELECT-B SET-XVISUALINFO-CLASS + SET-XWINDOWATTRIBUTES-SAVE_UNDER SET-XCIRCULATEEVENT-EVENT + SET-XCIRCULATEEVENT-SEND_EVENT + SET-XCIRCULATEREQUESTEVENT-SEND_EVENT SET-XVISIBILITYEVENT-WINDOW + XOPENDISPLAY XQUERYBESTSIZE MAKE-XSIZEHINTS + SET-XMAPPINGEVENT-REQUEST PICMENU-BOX-ITEM SET-DEPTH-VISUALS + WINDOW-GET-CHARS SET-XEDATAOBJECT-VISUAL XKEYBOARDSTATE-BELL_PITCH + MAKE-XSEGMENT XALLOCSIZEHINTS SET-XCIRCULATEEVENT-DISPLAY + SET-XCIRCULATEREQUESTEVENT-DISPLAY XFREEEXTENSIONLIST + SET-XSTANDARDCOLORMAP-BLUE_MAX SET-XSTANDARDCOLORMAP-GREEN_MAX + SET-XSTANDARDCOLORMAP-RED_MAX ISMISCFUNCTIONKEY XSIZEHINTS-X + XCIRCULATEEVENT-EVENT XCIRCULATEEVENT-SEND_EVENT + XSTANDARDCOLORMAP-VISUALID MAKE-XTEXTITEM SET-XICONSIZE-MAX_WIDTH + SET-XICONSIZE-MIN_WIDTH XGETVISUALINFO MENU-ITEM-VALUE + SET-XCIRCULATEEVENT-WINDOW SET-XCIRCULATEREQUESTEVENT-WINDOW + XCIRCULATEEVENT-DISPLAY XUNGRABKEYBOARD SET-XPROPERTYEVENT-ATOM + XSIZEHINTS-Y SET-XWINDOWATTRIBUTES-OVERRIDE_REDIRECT MAKE-XKEYEVENT + XCIRCULATEREQUESTEVENT-SERIAL XGCVALUES-BACKGROUND WINDOW-GET-CROSS + WINDOW-ADJ-BOX-XY XEXTCODES-EXTENSION XCROSSINGEVENT-ROOT + XCROSSINGEVENT-X_ROOT XCROSSINGEVENT-Y_ROOT XCIRCULATEEVENT-WINDOW + OPEN-WINDOW XVENDORRELEASE SET-XSIZEHINTS-X SET-XSIZEHINTS-FLAGS + SET-XCROSSINGEVENT-FOCUS XIMAGE-BYTES_PER_LINE + XCROSSINGEVENT-SEND_EVENT SET-XCLASSHINT-RES_CLASS + SCREEN-BACKING_STORE XCROSSINGEVENT-DISPLAY SET-XSIZEHINTS-Y + SET-XWINDOWATTRIBUTES-CLASS XDEFAULTGC WINDOW-SET-ERASE + XDISPLAYMOTIONBUFFERSIZE XUNDEFINECURSOR DEPTH-DEPTH + SCREEN-EXT_DATA XRESETSCREENSAVER XSETGRAPHICSEXPOSURES + SET-XWINDOWATTRIBUTES-ROOT XCROSSINGEVENT-WINDOW + XCROSSINGEVENT-SUBWINDOW SET-XCHAR2B-BYTE1 XROOTWINDOW + XFONTSTRUCT-MAX_BYTE1 XFONTSTRUCT-MIN_BYTE1 SET-XCHAR2B-BYTE2 + XGCVALUES-FOREGROUND XADDEXTENSION XSTRINGTOCONTEXT + XSETPOINTERMAPPING SET-XIMAGE-DATA XFONTSTRUCT-MAX_CHAR_OR_BYTE2 + XFONTSTRUCT-MIN_CHAR_OR_BYTE2 BARMENU-CREATE XSETARCMODE + XCREATEIMAGE XKEYBOARDCONTROL-KEY XDEFAULTSCREEN XSETSCREENSAVER + XCIRCULATESUBWINDOWSDOWN XKEYBOARDSTATE-LED_MASK XINTERSECTREGION + MAKE-XMAPREQUESTEVENT XGETWMSIZEHINTS XKEYBOARDCONTROL-BELL_PERCENT + XKEYBOARDCONTROL-KEY_CLICK_PERCENT XCOLOR-BLUE XSETBACKGROUND + XSTANDARDCOLORMAP-BASE_PIXEL XUNIONREGION VERTEX-POS-FLAG + SET-XICONSIZE-MAX_HEIGHT SET-XICONSIZE-MIN_HEIGHT XSETSUBWINDOWMODE + XGCVALUES-CLIP_Y_ORIGIN XGCVALUES-CLIP_X_ORIGIN XGCVALUES-CLIP_MASK + SET-XRECTANGLE-WIDTH XSETRGBCOLORMAPS XGCONTEXTFROMGC + XALLOCCOLORPLANES SET-XWINDOWATTRIBUTES-WIN_GRAVITY + SET-XWINDOWATTRIBUTES-BIT_GRAVITY MAKE-XMAPPINGEVENT + XDRAWIMAGESTRING MAKE-XCOMPOSESTATUS XIMAGE-OBDATA XIMAGE-DATA + XCIRCULATESUBWINDOWS SET-XCLIENTMESSAGEEVENT-MESSAGE_TYPE + SET-XCLIENTMESSAGEEVENT-TYPE XSTOREBYTES + XCIRCULATEREQUESTEVENT-PARENT XCOLORMAPEVENT-TYPE VISUAL-EXT_DATA + SET-XSIZEHINTS-WIN_GRAVITY XCIRCULATEREQUESTEVENT-SEND_EVENT + XKEYBOARDSTATE-BELL_PERCENT XKEYBOARDSTATE-KEY_CLICK_PERCENT + XSETNORMALHINTS XVISIBILITYEVENT-TYPE XSETTILE XAUTOREPEATON + XALLOCCOLORCELLS XGETMOTIONEVENTS XCOLORMAPEVENT-STATE PICMENU-SPEC + XCIRCULATEREQUESTEVENT-DISPLAY XEVENTMASKOFSCREEN + SET-XKEYBOARDCONTROL-LED XGRABKEYBOARD XKEYBOARDSTATE-AUTO_REPEATS + XIMAGE-BYTE_ORDER XVISIBILITYEVENT-STATE XROOTWINDOWOFSCREEN + XEXPOSEEVENT-WIDTH XCIRCULATEREQUESTEVENT-WINDOW + SET-XCLIENTMESSAGEEVENT-SERIAL SET-XCOLOR-GREEN window-code-char + gcfunction gcforeground gcbackground GXxor GXcopy LineSolid CapButt + JoinMiter XK_Shift_R XK_Shift_L XK_Control_L XK_Control_R XK_Alt_R + XK_Alt_L XK_Return XK_Tab XK_BackSpace window-get-raw-char + ) :user) + +(import '(*WINDOW-META* *TEXT-WIDTH-RETURN* *WINDOW-STRING* *WINDOW-SCREEN* + *WINDOW-EVENT* *WINDOW-MENU* *WINDOW-KEYMAP* *WINDOW-SHIFT* + *BORDER-WIDTH* *ROOT-X-RETURN* *POS-X* *ROOT-Y-RETURN* *DEFAULT-GC* + *DEFAULT-EVENT* *GC-VALUES* *MENU-TITLE-PAD* *DEFAULT-SCREEN* + *CHILD-RETURN* *DEPTH-RETURN* *WINDOW-ADD-MENU-TITLE* + *OVERALL-RETURN* *WINDOW-DEFAULT-BORDER* + *BORDER-WIDTH-RETURN* *DEFAULT-COLORMAP* *MOUSE-X* *MOUSE-Y* + *WINDOW-INPUT-STRING-CHARWIDTH* A-WINDOW *WINDOW-DISPLAY* + *WINDOW-ATTRIBUTES* *DESCENT-RETURN* + *WIDTH-RETURN* *WIN-Y-RETURN* *WIN-X-RETURN* *WINDOW-KEYINIT* + *BARMENU-UPDATE-VALUE-CONS* *ROOT-WINDOW* *PICMENU-NO-SELECTION* + *WINDOW-CTRL* *WINDOW-XCOLOR* *DIRECTION-RETURN* *WINDOW-FONTS* + *WINDOW-ATTR* *POS-Y* *X-RETURN* *Y-RETURN* *WIN-WIDTH* + *MASK-RETURN* *ASCENT-RETURN* *ROOT-RETURN* *HEIGHT-RETURN* + *BLACK-PIXEL* *WINDOW-DEFAULT-FONT-NAME* *DEFAULT-BG-COLOR* + *DEFAULT-FG-COLOR* *DEFAULT-SIZE-HINTS* *DEFAULT-DISPLAY* + *WINDOW-DEFAULT-CURSOR* *WINDOW-SHIFTKEYMAP* *WINDOW-DEFAULT-POS-X* + *WINDOW-DEFAULT-POS-Y* *WINDOW-MENU-CODE* *MOUSE-WINDOW* + *WINDOW-INPUT-STRING-X* *WINDOW-INPUT-STRING-Y* *WINDOW-STRING-MAX* + *WINDOW-STRING-COUNT* *WINDOW-SAVE-FOREGROUND* + *WINDOW-SAVE-FUNCTION* *WIN-HEIGHT* *WHITE-PIXEL* + *min-keycodes-return* *max-keycodes-return* *keycodes-return* + *window-shift-keys* *window-control-keys* *window-meta-keys* + ) :user) + +(import '(courier-bold-12 8x10 9x15 top bottom + left right center paint xor erase + copy close move clear display-size + menu window picmenu picmenu-spec barmenu + picmenu-button) :user) diff --git a/xgcl-2/gcl_index.lsp b/xgcl-2/gcl_index.lsp new file mode 100644 index 0000000..3491201 --- /dev/null +++ b/xgcl-2/gcl_index.lsp @@ -0,0 +1,88 @@ +; index.lsp Gordon S. Novak Jr. 08 Dec 00; 18 May 06 + +; This program processes LaTeX index entries, printing an index in +; either LaTeX or HTML form. + +; Copyright (c) 2006 Gordon S. Novak Jr. and The University of Texas at Austin. + +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 2 of the License, or +; (at your option) any later version. + +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + + +; To use: Gather the LaTeX index data: use \index{foo} within the +; text and include a \makeindex command at the top of the file, +; producing a file .idx when the file is run through LaTeX. +; Use an editor to change the index data from LaTeX form to Lisp: +; \indexentry{combination}{37} LaTeX +; ((combination) 37) Lisp + +; We assume that indexdata is a list of such entries, as illustrated +; at the end of this file. + +; Warning: quote characters or apostrophes within the indexed +; entries will not read into Lisp as expected. +; Get rid of ' or change it to \' + +; Start /p/bin/gcl +; (load "index.lsp") +; (printindex indexdata) ; for LaTeX output +; (printindex indexdata "prefix") ; for HTML output +; where "prefix" is the file name prefix for HTML files. + +; Print index for LaTeX given a list of items ((words ...) page-number) +(in-package 'xlib) +(defun printindex (origlst &optional html) + (let (lst top) + (setq lst + (sort origlst + #'(lambda (x y) (or (wordlist< (car x) (car y)) + (and (equal (car x) (car y)) + (< (cadr x) (cadr y))))))) + (terpri) + (while lst + (setq top (pop lst)) + (if (not html) + (princ "\\item ")) + (dolist (word (car top)) + (princ (string-downcase (symbol-name word))) (princ " ")) + (printindexn (cadr top) html nil) + (while (equal (caar lst) (car top)) + (setq top (pop lst)) + (printindexn (cadr top) html t) ) + (if html + (format t "

    ~%") + (terpri)) ) )) + +(defun wordlist< (x y) + (and (consp x) (consp y) + (or (string< (symbol-name (car x)) + (symbol-name (car y))) + (and (eq (car x) (car y)) + (or (and (null (cdr x)) (cdr y)) + (and (cdr x) (cdr y) + (wordlist< (cdr x) (cdr y)))))))) + +(defun printindexn (n html comma) + (if comma (princ ", ")) + (if html + (format t "~D" html n n) + (princ n)) ) + +(setq indexdata '( + +; Insert index entry data here. Data should look like: +; ((isomorphism) 20) +; ((artificial intelligence) 30) + +)) diff --git a/xgcl-2/gcl_init_xgcl.lsp b/xgcl-2/gcl_init_xgcl.lsp new file mode 100644 index 0000000..bf10ca0 --- /dev/null +++ b/xgcl-2/gcl_init_xgcl.lsp @@ -0,0 +1,118 @@ +; Copyright (c) 1994 William F. Schelter + +; See the files gnu.license and dec.copyright . + +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 1, or (at your option) +; any later version. + +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +; Some of the files that interface to the Xlib are adapted from DEC/MIT files. +; See the file dec.copyright for details. +(in-package :XLIB) +(in-package "COMPILER") +(in-package "SYSTEM") +(defvar *command-args* nil) +(in-package "USER") +(in-package "LISP") + +(lisp::in-package "SLOOP") +;;Appropriate for Austin +#-winnt +(setq SYSTEM:*DEFAULT-TIME-ZONE* 6) +#+winnt +(setq SYSTEM:*DEFAULT-TIME-ZONE* (GET-SYSTEM-TIME-ZONE)) + +(in-package "USER") +(progn (allocate 'cons 100) (allocate 'string 40) + (system:init-system) (gbc t) + (si::multiply-bignum-stack 25) + (or lisp::*link-array* + (setq lisp::*link-array* + (make-array 500 :element-type 'fixnum :fill-pointer 0))) + (use-fast-links t) +(setq compiler::*cmpinclude* "") (load #"../cmpnew/cmpmain.lsp") (gbc t) (load #"../cmpnew/lfun_list.lsp") + (gbc t) (load #"../cmpnew/cmpopt.lsp") (gbc t) +(load #"../lsp/auto.lsp") (gbc t) +(defun si::src-path (x) + (si::string-concatenate (or si::*lib-directory* "GCLDIR/") x)) + + (when compiler::*cmpinclude-string* + (with-open-file (st "../h/cmpinclude.h") + (let + ((tem (make-array (file-length st) :element-type 'standard-char + :static t))) + (if (si::fread tem 0 (length tem) st) + (setq compiler::*cmpinclude-string* tem))))) + ;;compile-file is in cmpmain.lsp + + (setf (symbol-function 'si:clear-compiler-properties) + (symbol-function 'compiler::compiler-clear-compiler-properties)) +; (load "../lsp/setdoc.lsp") + (setq system::*old-top-level* (symbol-function 'system:top-level)) +(defvar si::*command-args* nil) +(defun si::get-command-arg (a &optional val-if-there) + ;; return non nil if a is in si::*command-args* and return + ;; the string which is after it if there is one" + (let ((tem (member a si::*command-args* :test 'equal))) + (if tem (or val-if-there (cadr tem) t)))) +(defvar si::*lib-directory* nil) +(defun system::gcl-top-level (&aux tem) + (dotimes (i (si::argc)) + (setq si::*command-args* (cons (si::argv i) si::*command-args*))) + (setq si::*command-args* (nreverse si::*command-args* )) + (setq si::*system-directory* + (or (si::get-command-arg "-dir") + (car si::*command-args*))) + (setq si::*lib-directory* (si::get-command-arg "-libdir")) + + (when (si::get-command-arg "-compile") + (let ((system::*quit-tag* (cons nil nil)) + (system::*quit-tags* nil) (system::*break-level* '()) + (system::*break-env* nil) (system::*ihs-base* 1) + (system::*ihs-top* 1) (system::*current-ihs* 1) + (*break-enable* nil)) + (system:error-set + '(progn + (compile-file (si::get-command-arg "-compile") + :output-file + (or (si::get-command-arg "-o") + (si::get-command-arg "-compile")) + :o-file (not (si::get-command-arg "-no-o" t)) + :c-file (si::get-command-arg "-system-p" t) + :h-file (si::get-command-arg "-system-p" t) + :data-file (si::get-command-arg "-system-p" t) + :system-p (si::get-command-arg "-system-p" t)))) + (bye (if compiler::*error-p* 1 0)))) + (format t "GCL (GNU Common Lisp) ~A~%~a~%~a~%" "DATE" + "Licensed under GNU Public Library License" + "Contains Enhancements by W. Schelter") + (setq si::*ihs-top* 1) + (in-package 'system::user) (incf system::*ihs-top* 2) + (funcall system::*old-top-level*)) + (setq si::*gcl-version* 600) + (defun lisp-implementation-version nil (format nil "1-~a" si::*gcl-version*)) + (setq si:*inhibit-macro-special* t) + ;(setq *modules* nil) + (gbc t) (system:reset-gbc-count) + (allocate 'cons 200) + (defun system:top-level nil (system::gcl-top-level)) + (unintern 'system) + (unintern 'lisp) + (unintern 'compiler) + (unintern 'user) + (si::chdir "/d19/staff/wfs/novak-xgcl")(user::user-init)(si::save-system "saved_xgcl") + (if (fboundp 'user-init) (user-init)) + (system:save-system "saved_gcl") (bye) + (defun system:top-level nil (system::gcl-top-level)) + (save "saved_gcl") (bye)) + diff --git a/xgcl-2/gcl_keysymdef.lsp b/xgcl-2/gcl_keysymdef.lsp new file mode 100644 index 0000000..a9d492f --- /dev/null +++ b/xgcl-2/gcl_keysymdef.lsp @@ -0,0 +1,1151 @@ +(in-package :XLIB) +; keysymdef.lsp modified by Hiep Huu Nguyen 27 Aug 92 + +; Copyright (c) 1994 Hiep Huu Nguyen and The University of Texas at Austin. + +; See the files gnu.license and dec.copyright . + +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 1, or (at your option) +; any later version. + +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +; Some of the files that interface to the Xlib are adapted from DEC/MIT files. +; See the file dec.copyright for details. + +;; $XConsortium: keysymdef.h,v 1.13 89/12/12 16:23:30 rws Exp $ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defconstant XK_VoidSymbol #xFFFFFF ;; void symbol + +;;#ifdef XK_MISCELLANY +;; + ; TTY Functions, cleverly chosen to map to ascii, for convenience of + ; programming, but could have been arbitrary at the cost of lookup + ; tables in client code. + + +)(defconstant XK_BackSpace #xFF08 ;; back space, back char +)(defconstant XK_Tab #xFF09 +)(defconstant XK_Linefeed #xFF0A ;; Linefeed, LF +)(defconstant XK_Clear #xFF0B +)(defconstant XK_Return #xFF0D ;; Return, enter +)(defconstant XK_Pause #xFF13 ;; Pause, hold +)(defconstant XK_Scroll_Lock #xFF14 +)(defconstant XK_Escape #xFF1B +)(defconstant XK_Delete #xFFFF ;; Delete, rubout + + + +;; International & multi-key character composition + +)(defconstant XK_Multi_key #xFF20 ;; Multi-key character compose + +;; Japanese keyboard support + +)(defconstant XK_Kanji #xFF21 ;; Kanji, Kanji convert +)(defconstant XK_Muhenkan #xFF22 ;; Cancel Conversion +)(defconstant XK_Henkan_Mode #xFF23 ;; Start/Stop Conversion +)(defconstant XK_Henkan #xFF23 ;; Alias for Henkan_Mode +)(defconstant XK_Romaji #xFF24 ;; to Romaji +)(defconstant XK_Hiragana #xFF25 ;; to Hiragana +)(defconstant XK_Katakana #xFF26 ;; to Katakana +)(defconstant XK_Hiragana_Katakana #xFF27 ;; Hiragana/Katakana toggle +)(defconstant XK_Zenkaku #xFF28 ;; to Zenkaku +)(defconstant XK_Hankaku #xFF29 ;; to Hankaku +)(defconstant XK_Zenkaku_Hankaku #xFF2A ;; Zenkaku/Hankaku toggle +)(defconstant XK_Touroku #xFF2B ;; Add to Dictionary +)(defconstant XK_Massyo #xFF2C ;; Delete from Dictionary +)(defconstant XK_Kana_Lock #xFF2D ;; Kana Lock +)(defconstant XK_Kana_Shift #xFF2E ;; Kana Shift +)(defconstant XK_Eisu_Shift #xFF2F ;; Alphanumeric Shift +)(defconstant XK_Eisu_toggle #xFF30 ;; Alphanumeric toggle + +;; Cursor control & motion + +)(defconstant XK_Home #xFF50 +)(defconstant XK_Left #xFF51 ;; Move left, left arrow +)(defconstant XK_Up #xFF52 ;; Move up, up arrow +)(defconstant XK_Right #xFF53 ;; Move right, right arrow +)(defconstant XK_Down #xFF54 ;; Move down, down arrow +)(defconstant XK_Prior #xFF55 ;; Prior, previous +)(defconstant XK_Next #xFF56 ;; Next +)(defconstant XK_End #xFF57 ;; EOL +)(defconstant XK_Begin #xFF58 ;; BOL + + +;; Misc Functions + +)(defconstant XK_Select #xFF60 ;; Select, mark +)(defconstant XK_Print #xFF61 +)(defconstant XK_Execute #xFF62 ;; Execute, run, do +)(defconstant XK_Insert #xFF63 ;; Insert, insert here +)(defconstant XK_Undo #xFF65 ;; Undo, oops +)(defconstant XK_Redo #xFF66 ;; redo, again +)(defconstant XK_Menu #xFF67 +)(defconstant XK_Find #xFF68 ;; Find, search +)(defconstant XK_Cancel #xFF69 ;; Cancel, stop, abort, exit +)(defconstant XK_Help #xFF6A ;; Help, ? +)(defconstant XK_Break #xFF6B +)(defconstant XK_Mode_switch #xFF7E ;; Character set switch +)(defconstant XK_script_switch #xFF7E ;; Alias for mode_switch +)(defconstant XK_Num_Lock #xFF7F + +;; Keypad Functions, keypad numbers cleverly chosen to map to ascii + +)(defconstant XK_KP_Space #xFF80 ;; space +)(defconstant XK_KP_Tab #xFF89 +)(defconstant XK_KP_Enter #xFF8D ;; enter +)(defconstant XK_KP_F1 #xFF91 ;; PF1, KP_A, ... +)(defconstant XK_KP_F2 #xFF92 +)(defconstant XK_KP_F3 #xFF93 +)(defconstant XK_KP_F4 #xFF94 +)(defconstant XK_KP_Equal #xFFBD ;; equals +)(defconstant XK_KP_Multiply #xFFAA +)(defconstant XK_KP_Add #xFFAB +)(defconstant XK_KP_Separator #xFFAC ;; separator, often comma +)(defconstant XK_KP_Subtract #xFFAD +)(defconstant XK_KP_Decimal #xFFAE +)(defconstant XK_KP_Divide #xFFAF +)(defconstant XK_KP_0 #xFFB0 +)(defconstant XK_KP_1 #xFFB1 +)(defconstant XK_KP_2 #xFFB2 +)(defconstant XK_KP_3 #xFFB3 +)(defconstant XK_KP_4 #xFFB4 +)(defconstant XK_KP_5 #xFFB5 +)(defconstant XK_KP_6 #xFFB6 +)(defconstant XK_KP_7 #xFFB7 +)(defconstant XK_KP_8 #xFFB8 +)(defconstant XK_KP_9 #xFFB9 + + + +;; + ; Auxilliary Functions; note the duplicate definitions for left and right + ; function keys; Sun keyboards and a few other manufactures have such + ; function key groups on the left and/or right sides of the keyboard. + ; We've not found a keyboard with more than 35 function keys total. + + +)(defconstant XK_F1 #xFFBE +)(defconstant XK_F2 #xFFBF +)(defconstant XK_F3 #xFFC0 +)(defconstant XK_F4 #xFFC1 +)(defconstant XK_F5 #xFFC2 +)(defconstant XK_F6 #xFFC3 +)(defconstant XK_F7 #xFFC4 +)(defconstant XK_F8 #xFFC5 +)(defconstant XK_F9 #xFFC6 +)(defconstant XK_F10 #xFFC7 +)(defconstant XK_F11 #xFFC8 +)(defconstant XK_L1 #xFFC8 +)(defconstant XK_F12 #xFFC9 +)(defconstant XK_L2 #xFFC9 +)(defconstant XK_F13 #xFFCA +)(defconstant XK_L3 #xFFCA +)(defconstant XK_F14 #xFFCB +)(defconstant XK_L4 #xFFCB +)(defconstant XK_F15 #xFFCC +)(defconstant XK_L5 #xFFCC +)(defconstant XK_F16 #xFFCD +)(defconstant XK_L6 #xFFCD +)(defconstant XK_F17 #xFFCE +)(defconstant XK_L7 #xFFCE +)(defconstant XK_F18 #xFFCF +)(defconstant XK_L8 #xFFCF +)(defconstant XK_F19 #xFFD0 +)(defconstant XK_L9 #xFFD0 +)(defconstant XK_F20 #xFFD1 +)(defconstant XK_L10 #xFFD1 +)(defconstant XK_F21 #xFFD2 +)(defconstant XK_R1 #xFFD2 +)(defconstant XK_F22 #xFFD3 +)(defconstant XK_R2 #xFFD3 +)(defconstant XK_F23 #xFFD4 +)(defconstant XK_R3 #xFFD4 +)(defconstant XK_F24 #xFFD5 +)(defconstant XK_R4 #xFFD5 +)(defconstant XK_F25 #xFFD6 +)(defconstant XK_R5 #xFFD6 +)(defconstant XK_F26 #xFFD7 +)(defconstant XK_R6 #xFFD7 +)(defconstant XK_F27 #xFFD8 +)(defconstant XK_R7 #xFFD8 +)(defconstant XK_F28 #xFFD9 +)(defconstant XK_R8 #xFFD9 +)(defconstant XK_F29 #xFFDA +)(defconstant XK_R9 #xFFDA +)(defconstant XK_F30 #xFFDB +)(defconstant XK_R10 #xFFDB +)(defconstant XK_F31 #xFFDC +)(defconstant XK_R11 #xFFDC +)(defconstant XK_F32 #xFFDD +)(defconstant XK_R12 #xFFDD +)(defconstant XK_R13 #xFFDE +)(defconstant XK_F33 #xFFDE +)(defconstant XK_F34 #xFFDF +)(defconstant XK_R14 #xFFDF +)(defconstant XK_F35 #xFFE0 +)(defconstant XK_R15 #xFFE0 + +;; Modifiers + +)(defconstant XK_Shift_L #xFFE1 ;; Left shift +)(defconstant XK_Shift_R #xFFE2 ;; Right shift +)(defconstant XK_Control_L #xFFE3 ;; Left control +)(defconstant XK_Control_R #xFFE4 ;; Right control +)(defconstant XK_Caps_Lock #xFFE5 ;; Caps lock +)(defconstant XK_Shift_Lock #xFFE6 ;; Shift lock + +)(defconstant XK_Meta_L #xFFE7 ;; Left meta +)(defconstant XK_Meta_R #xFFE8 ;; Right meta +)(defconstant XK_Alt_L #xFFE9 ;; Left alt +)(defconstant XK_Alt_R #xFFEA ;; Right alt +)(defconstant XK_Super_L #xFFEB ;; Left super +)(defconstant XK_Super_R #xFFEC ;; Right super +)(defconstant XK_Hyper_L #xFFED ;; Left hyper +)(defconstant XK_Hyper_R #xFFEE ;; Right hyper +;;#endif ;; XK_MISCELLANY + +;; + ; Latin 1 + ; Byte 3 = 0 + +;;ifdef XK_LATIN1 +)(defconstant XK_space #x020 +)(defconstant XK_exclam #x021 +)(defconstant XK_quotedbl #x022 +)(defconstant XK_numbersign #x023 +)(defconstant XK_dollar #x024 +)(defconstant XK_percent #x025 +)(defconstant XK_ampersand #x026 +)(defconstant XK_apostrophe #x027 +)(defconstant XK_quoteright #x027 ;; deprecated +)(defconstant XK_parenleft #x028 +)(defconstant XK_parenright #x029 +)(defconstant XK_asterisk #x02a +)(defconstant XK_plus #x02b +)(defconstant XK_comma #x02c +)(defconstant XK_minus #x02d +)(defconstant XK_period #x02e +)(defconstant XK_slash #x02f +)(defconstant XK_0 #x030 +)(defconstant XK_1 #x031 +)(defconstant XK_2 #x032 +)(defconstant XK_3 #x033 +)(defconstant XK_4 #x034 +)(defconstant XK_5 #x035 +)(defconstant XK_6 #x036 +)(defconstant XK_7 #x037 +)(defconstant XK_8 #x038 +)(defconstant XK_9 #x039 +)(defconstant XK_colon #x03a +)(defconstant XK_semicolon #x03b +)(defconstant XK_less #x03c +)(defconstant XK_equal #x03d +)(defconstant XK_greater #x03e +)(defconstant XK_question #x03f +)(defconstant XK_at #x040 +)(defconstant XK_A #x041 +)(defconstant XK_B #x042 +)(defconstant XK_C #x043 +)(defconstant XK_D #x044 +)(defconstant XK_E #x045 +)(defconstant XK_F #x046 +)(defconstant XK_G #x047 +)(defconstant XK_H #x048 +)(defconstant XK_I #x049 +)(defconstant XK_J #x04a +)(defconstant XK_K #x04b +)(defconstant XK_L #x04c +)(defconstant XK_M #x04d +)(defconstant XK_N #x04e +)(defconstant XK_O #x04f +)(defconstant XK_P #x050 +)(defconstant XK_Q #x051 +)(defconstant XK_R #x052 +)(defconstant XK_S #x053 +)(defconstant XK_T #x054 +)(defconstant XK_U #x055 +)(defconstant XK_V #x056 +)(defconstant XK_W #x057 +)(defconstant XK_X #x058 +)(defconstant XK_Y #x059 +)(defconstant XK_Z #x05a +)(defconstant XK_bracketleft #x05b +)(defconstant XK_backslash #x05c +)(defconstant XK_bracketright #x05d +)(defconstant XK_asciicircum #x05e +)(defconstant XK_underscore #x05f +)(defconstant XK_grave #x060 +)(defconstant XK_quoteleft #x060 ;; deprecated +)(defconstant XK_a #x061 +)(defconstant XK_b #x062 +)(defconstant XK_c #x063 +)(defconstant XK_d #x064 +)(defconstant XK_e #x065 +)(defconstant XK_f #x066 +)(defconstant XK_g #x067 +)(defconstant XK_h #x068 +)(defconstant XK_i #x069 +)(defconstant XK_j #x06a +)(defconstant XK_k #x06b +)(defconstant XK_l #x06c +)(defconstant XK_m #x06d +)(defconstant XK_n #x06e +)(defconstant XK_o #x06f +)(defconstant XK_p #x070 +)(defconstant XK_q #x071 +)(defconstant XK_r #x072 +)(defconstant XK_s #x073 +)(defconstant XK_t #x074 +)(defconstant XK_u #x075 +)(defconstant XK_v #x076 +)(defconstant XK_w #x077 +)(defconstant XK_x #x078 +)(defconstant XK_y #x079 +)(defconstant XK_z #x07a +)(defconstant XK_braceleft #x07b +)(defconstant XK_bar #x07c +)(defconstant XK_braceright #x07d +)(defconstant XK_asciitilde #x07e + +)(defconstant XK_nobreakspace #x0a0 +)(defconstant XK_exclamdown #x0a1 +)(defconstant XK_cent #x0a2 +)(defconstant XK_sterling #x0a3 +)(defconstant XK_currency #x0a4 +)(defconstant XK_yen #x0a5 +)(defconstant XK_brokenbar #x0a6 +)(defconstant XK_section #x0a7 +)(defconstant XK_diaeresis #x0a8 +)(defconstant XK_copyright #x0a9 +)(defconstant XK_ordfeminine #x0aa +)(defconstant XK_guillemotleft #x0ab ;; left angle quotation mark +)(defconstant XK_notsign #x0ac +)(defconstant XK_hyphen #x0ad +)(defconstant XK_registered #x0ae +)(defconstant XK_macron #x0af +)(defconstant XK_degree #x0b0 +)(defconstant XK_plusminus #x0b1 +)(defconstant XK_twosuperior #x0b2 +)(defconstant XK_threesuperior #x0b3 +)(defconstant XK_acute #x0b4 +)(defconstant XK_mu #x0b5 +)(defconstant XK_paragraph #x0b6 +)(defconstant XK_periodcentered #x0b7 +)(defconstant XK_cedilla #x0b8 +)(defconstant XK_onesuperior #x0b9 +)(defconstant XK_masculine #x0ba +)(defconstant XK_guillemotright #x0bb ;; right angle quotation mark +)(defconstant XK_onequarter #x0bc +)(defconstant XK_onehalf #x0bd +)(defconstant XK_threequarters #x0be +)(defconstant XK_questiondown #x0bf +)(defconstant XK_Agrave #x0c0 +)(defconstant XK_Aacute #x0c1 +)(defconstant XK_Acircumflex #x0c2 +)(defconstant XK_Atilde #x0c3 +)(defconstant XK_Adiaeresis #x0c4 +)(defconstant XK_Aring #x0c5 +)(defconstant XK_AE #x0c6 +)(defconstant XK_Ccedilla #x0c7 +)(defconstant XK_Egrave #x0c8 +)(defconstant XK_Eacute #x0c9 +)(defconstant XK_Ecircumflex #x0ca +)(defconstant XK_Ediaeresis #x0cb +)(defconstant XK_Igrave #x0cc +)(defconstant XK_Iacute #x0cd +)(defconstant XK_Icircumflex #x0ce +)(defconstant XK_Idiaeresis #x0cf +)(defconstant XK_ETH #x0d0 +)(defconstant XK_Eth #x0d0 ;; deprecated +)(defconstant XK_Ntilde #x0d1 +)(defconstant XK_Ograve #x0d2 +)(defconstant XK_Oacute #x0d3 +)(defconstant XK_Ocircumflex #x0d4 +)(defconstant XK_Otilde #x0d5 +)(defconstant XK_Odiaeresis #x0d6 +)(defconstant XK_multiply #x0d7 +)(defconstant XK_Ooblique #x0d8 +)(defconstant XK_Ugrave #x0d9 +)(defconstant XK_Uacute #x0da +)(defconstant XK_Ucircumflex #x0db +)(defconstant XK_Udiaeresis #x0dc +)(defconstant XK_Yacute #x0dd +)(defconstant XK_THORN #x0de +)(defconstant XK_Thorn #x0de ;; deprecated +)(defconstant XK_ssharp #x0df +)(defconstant XK_agrave #x0e0 +)(defconstant XK_aacute #x0e1 +)(defconstant XK_acircumflex #x0e2 +)(defconstant XK_atilde #x0e3 +)(defconstant XK_adiaeresis #x0e4 +)(defconstant XK_aring #x0e5 +)(defconstant XK_ae #x0e6 +)(defconstant XK_ccedilla #x0e7 +)(defconstant XK_egrave #x0e8 +)(defconstant XK_eacute #x0e9 +)(defconstant XK_ecircumflex #x0ea +)(defconstant XK_ediaeresis #x0eb +)(defconstant XK_igrave #x0ec +)(defconstant XK_iacute #x0ed +)(defconstant XK_icircumflex #x0ee +)(defconstant XK_idiaeresis #x0ef +)(defconstant XK_eth #x0f0 +)(defconstant XK_ntilde #x0f1 +)(defconstant XK_ograve #x0f2 +)(defconstant XK_oacute #x0f3 +)(defconstant XK_ocircumflex #x0f4 +)(defconstant XK_otilde #x0f5 +)(defconstant XK_odiaeresis #x0f6 +)(defconstant XK_division #x0f7 +)(defconstant XK_oslash #x0f8 +)(defconstant XK_ugrave #x0f9 +)(defconstant XK_uacute #x0fa +)(defconstant XK_ucircumflex #x0fb +)(defconstant XK_udiaeresis #x0fc +)(defconstant XK_yacute #x0fd +)(defconstant XK_thorn #x0fe +)(defconstant XK_ydiaeresis #x0ff +;;endif ;; XK_LATIN1 + +;; + ; Latin 2 + ; Byte 3 = 1 + + +;;ifdef XK_LATIN2 +)(defconstant XK_Aogonek #x1a1 +)(defconstant XK_breve #x1a2 +)(defconstant XK_Lstroke #x1a3 +)(defconstant XK_Lcaron #x1a5 +)(defconstant XK_Sacute #x1a6 +)(defconstant XK_Scaron #x1a9 +)(defconstant XK_Scedilla #x1aa +)(defconstant XK_Tcaron #x1ab +)(defconstant XK_Zacute #x1ac +)(defconstant XK_Zcaron #x1ae +)(defconstant XK_Zabovedot #x1af +)(defconstant XK_aogonek #x1b1 +)(defconstant XK_ogonek #x1b2 +)(defconstant XK_lstroke #x1b3 +)(defconstant XK_lcaron #x1b5 +)(defconstant XK_sacute #x1b6 +)(defconstant XK_caron #x1b7 +)(defconstant XK_scaron #x1b9 +)(defconstant XK_scedilla #x1ba +)(defconstant XK_tcaron #x1bb +)(defconstant XK_zacute #x1bc +)(defconstant XK_doubleacute #x1bd +)(defconstant XK_zcaron #x1be +)(defconstant XK_zabovedot #x1bf +)(defconstant XK_Racute #x1c0 +)(defconstant XK_Abreve #x1c3 +)(defconstant XK_Lacute #x1c5 +)(defconstant XK_Cacute #x1c6 +)(defconstant XK_Ccaron #x1c8 +)(defconstant XK_Eogonek #x1ca +)(defconstant XK_Ecaron #x1cc +)(defconstant XK_Dcaron #x1cf +)(defconstant XK_Dstroke #x1d0 +)(defconstant XK_Nacute #x1d1 +)(defconstant XK_Ncaron #x1d2 +)(defconstant XK_Odoubleacute #x1d5 +)(defconstant XK_Rcaron #x1d8 +)(defconstant XK_Uring #x1d9 +)(defconstant XK_Udoubleacute #x1db +)(defconstant XK_Tcedilla #x1de +)(defconstant XK_racute #x1e0 +)(defconstant XK_abreve #x1e3 +)(defconstant XK_lacute #x1e5 +)(defconstant XK_cacute #x1e6 +)(defconstant XK_ccaron #x1e8 +)(defconstant XK_eogonek #x1ea +)(defconstant XK_ecaron #x1ec +)(defconstant XK_dcaron #x1ef +)(defconstant XK_dstroke #x1f0 +)(defconstant XK_nacute #x1f1 +)(defconstant XK_ncaron #x1f2 +)(defconstant XK_odoubleacute #x1f5 +)(defconstant XK_udoubleacute #x1fb +)(defconstant XK_rcaron #x1f8 +)(defconstant XK_uring #x1f9 +)(defconstant XK_tcedilla #x1fe +)(defconstant XK_abovedot #x1ff +;;endif ;; XK_LATIN2 + +;; + ; Latin 3 + ; Byte 3 = 2 + + +;;ifdef XK_LATIN3 +)(defconstant XK_Hstroke #x2a1 +)(defconstant XK_Hcircumflex #x2a6 +)(defconstant XK_Iabovedot #x2a9 +)(defconstant XK_Gbreve #x2ab +)(defconstant XK_Jcircumflex #x2ac +)(defconstant XK_hstroke #x2b1 +)(defconstant XK_hcircumflex #x2b6 +)(defconstant XK_idotless #x2b9 +)(defconstant XK_gbreve #x2bb +)(defconstant XK_jcircumflex #x2bc +)(defconstant XK_Cabovedot #x2c5 +)(defconstant XK_Ccircumflex #x2c6 +)(defconstant XK_Gabovedot #x2d5 +)(defconstant XK_Gcircumflex #x2d8 +)(defconstant XK_Ubreve #x2dd +)(defconstant XK_Scircumflex #x2de +)(defconstant XK_cabovedot #x2e5 +)(defconstant XK_ccircumflex #x2e6 +)(defconstant XK_gabovedot #x2f5 +)(defconstant XK_gcircumflex #x2f8 +)(defconstant XK_ubreve #x2fd +)(defconstant XK_scircumflex #x2fe +;;endif ;; XK_LATIN3 + + +;; + ; Latin 4 + ; Byte 3 = 3 + + +;;ifdef XK_LATIN4 +)(defconstant XK_kra #x3a2 +)(defconstant XK_kappa #x3a2 ;; deprecated +)(defconstant XK_Rcedilla #x3a3 +)(defconstant XK_Itilde #x3a5 +)(defconstant XK_Lcedilla #x3a6 +)(defconstant XK_Emacron #x3aa +)(defconstant XK_Gcedilla #x3ab +)(defconstant XK_Tslash #x3ac +)(defconstant XK_rcedilla #x3b3 +)(defconstant XK_itilde #x3b5 +)(defconstant XK_lcedilla #x3b6 +)(defconstant XK_emacron #x3ba +)(defconstant XK_gcedilla #x3bb +)(defconstant XK_tslash #x3bc +)(defconstant XK_ENG #x3bd +)(defconstant XK_eng #x3bf +)(defconstant XK_Amacron #x3c0 +)(defconstant XK_Iogonek #x3c7 +)(defconstant XK_Eabovedot #x3cc +)(defconstant XK_Imacron #x3cf +)(defconstant XK_Ncedilla #x3d1 +)(defconstant XK_Omacron #x3d2 +)(defconstant XK_Kcedilla #x3d3 +)(defconstant XK_Uogonek #x3d9 +)(defconstant XK_Utilde #x3dd +)(defconstant XK_Umacron #x3de +)(defconstant XK_amacron #x3e0 +)(defconstant XK_iogonek #x3e7 +)(defconstant XK_eabovedot #x3ec +)(defconstant XK_imacron #x3ef +)(defconstant XK_ncedilla #x3f1 +)(defconstant XK_omacron #x3f2 +)(defconstant XK_kcedilla #x3f3 +)(defconstant XK_uogonek #x3f9 +)(defconstant XK_utilde #x3fd +)(defconstant XK_umacron #x3fe +;;endif ;; XK_LATIN4 + +;; + ; Katakana + ; Byte 3 = 4 + + +;;ifdef XK_KATAKANA +)(defconstant XK_overline #x47e +)(defconstant XK_kana_fullstop #x4a1 +)(defconstant XK_kana_openingbracket #x4a2 +)(defconstant XK_kana_closingbracket #x4a3 +)(defconstant XK_kana_comma #x4a4 +)(defconstant XK_kana_conjunctive #x4a5 +)(defconstant XK_kana_middledot #x4a5 ;; deprecated +)(defconstant XK_kana_WO #x4a6 +)(defconstant XK_kana_a #x4a7 +)(defconstant XK_kana_i #x4a8 +)(defconstant XK_kana_u #x4a9 +)(defconstant XK_kana_e #x4aa +)(defconstant XK_kana_o #x4ab +)(defconstant XK_kana_ya #x4ac +)(defconstant XK_kana_yu #x4ad +)(defconstant XK_kana_yo #x4ae +)(defconstant XK_kana_tsu #x4af +)(defconstant XK_kana_tu #x4af ;; deprecated +)(defconstant XK_prolongedsound #x4b0 +)(defconstant XK_kana_A #x4b1 +)(defconstant XK_kana_I #x4b2 +)(defconstant XK_kana_U #x4b3 +)(defconstant XK_kana_E #x4b4 +)(defconstant XK_kana_O #x4b5 +)(defconstant XK_kana_KA #x4b6 +)(defconstant XK_kana_KI #x4b7 +)(defconstant XK_kana_KU #x4b8 +)(defconstant XK_kana_KE #x4b9 +)(defconstant XK_kana_KO #x4ba +)(defconstant XK_kana_SA #x4bb +)(defconstant XK_kana_SHI #x4bc +)(defconstant XK_kana_SU #x4bd +)(defconstant XK_kana_SE #x4be +)(defconstant XK_kana_SO #x4bf +)(defconstant XK_kana_TA #x4c0 +)(defconstant XK_kana_CHI #x4c1 +)(defconstant XK_kana_TI #x4c1 ;; deprecated +)(defconstant XK_kana_TSU #x4c2 +)(defconstant XK_kana_TU #x4c2 ;; deprecated +)(defconstant XK_kana_TE #x4c3 +)(defconstant XK_kana_TO #x4c4 +)(defconstant XK_kana_NA #x4c5 +)(defconstant XK_kana_NI #x4c6 +)(defconstant XK_kana_NU #x4c7 +)(defconstant XK_kana_NE #x4c8 +)(defconstant XK_kana_NO #x4c9 +)(defconstant XK_kana_HA #x4ca +)(defconstant XK_kana_HI #x4cb +)(defconstant XK_kana_FU #x4cc +)(defconstant XK_kana_HU #x4cc ;; deprecated +)(defconstant XK_kana_HE #x4cd +)(defconstant XK_kana_HO #x4ce +)(defconstant XK_kana_MA #x4cf +)(defconstant XK_kana_MI #x4d0 +)(defconstant XK_kana_MU #x4d1 +)(defconstant XK_kana_ME #x4d2 +)(defconstant XK_kana_MO #x4d3 +)(defconstant XK_kana_YA #x4d4 +)(defconstant XK_kana_YU #x4d5 +)(defconstant XK_kana_YO #x4d6 +)(defconstant XK_kana_RA #x4d7 +)(defconstant XK_kana_RI #x4d8 +)(defconstant XK_kana_RU #x4d9 +)(defconstant XK_kana_RE #x4da +)(defconstant XK_kana_RO #x4db +)(defconstant XK_kana_WA #x4dc +)(defconstant XK_kana_N #x4dd +)(defconstant XK_voicedsound #x4de +)(defconstant XK_semivoicedsound #x4df +)(defconstant XK_kana_switch #xFF7E ;; Alias for mode_switch +;;endif ;; XK_KATAKANA + +;; + ; Arabic + ; Byte 3 = 5 + + +;;ifdef XK_ARABIC +)(defconstant XK_Arabic_comma #x5ac +)(defconstant XK_Arabic_semicolon #x5bb +)(defconstant XK_Arabic_question_mark #x5bf +)(defconstant XK_Arabic_hamza #x5c1 +)(defconstant XK_Arabic_maddaonalef #x5c2 +)(defconstant XK_Arabic_hamzaonalef #x5c3 +)(defconstant XK_Arabic_hamzaonwaw #x5c4 +)(defconstant XK_Arabic_hamzaunderalef #x5c5 +)(defconstant XK_Arabic_hamzaonyeh #x5c6 +)(defconstant XK_Arabic_alef #x5c7 +)(defconstant XK_Arabic_beh #x5c8 +)(defconstant XK_Arabic_tehmarbuta #x5c9 +)(defconstant XK_Arabic_teh #x5ca +)(defconstant XK_Arabic_theh #x5cb +)(defconstant XK_Arabic_jeem #x5cc +)(defconstant XK_Arabic_hah #x5cd +)(defconstant XK_Arabic_khah #x5ce +)(defconstant XK_Arabic_dal #x5cf +)(defconstant XK_Arabic_thal #x5d0 +)(defconstant XK_Arabic_ra #x5d1 +)(defconstant XK_Arabic_zain #x5d2 +)(defconstant XK_Arabic_seen #x5d3 +)(defconstant XK_Arabic_sheen #x5d4 +)(defconstant XK_Arabic_sad #x5d5 +)(defconstant XK_Arabic_dad #x5d6 +)(defconstant XK_Arabic_tah #x5d7 +)(defconstant XK_Arabic_zah #x5d8 +)(defconstant XK_Arabic_ain #x5d9 +)(defconstant XK_Arabic_ghain #x5da +)(defconstant XK_Arabic_tatweel #x5e0 +)(defconstant XK_Arabic_feh #x5e1 +)(defconstant XK_Arabic_qaf #x5e2 +)(defconstant XK_Arabic_kaf #x5e3 +)(defconstant XK_Arabic_lam #x5e4 +)(defconstant XK_Arabic_meem #x5e5 +)(defconstant XK_Arabic_noon #x5e6 +)(defconstant XK_Arabic_ha #x5e7 +)(defconstant XK_Arabic_heh #x5e7 ;; deprecated +)(defconstant XK_Arabic_waw #x5e8 +)(defconstant XK_Arabic_alefmaksura #x5e9 +)(defconstant XK_Arabic_yeh #x5ea +)(defconstant XK_Arabic_fathatan #x5eb +)(defconstant XK_Arabic_dammatan #x5ec +)(defconstant XK_Arabic_kasratan #x5ed +)(defconstant XK_Arabic_fatha #x5ee +)(defconstant XK_Arabic_damma #x5ef +)(defconstant XK_Arabic_kasra #x5f0 +)(defconstant XK_Arabic_shadda #x5f1 +)(defconstant XK_Arabic_sukun #x5f2 +)(defconstant XK_Arabic_switch #xFF7E ;; Alias for mode_switch +;;endif ;; XK_ARABIC + +;; + ; Cyrillic + ; Byte 3 = 6 + +;;ifdef XK_CYRILLIC +)(defconstant XK_Serbian_dje #x6a1 +)(defconstant XK_Macedonia_gje #x6a2 +)(defconstant XK_Cyrillic_io #x6a3 +)(defconstant XK_Ukrainian_ie #x6a4 +)(defconstant XK_Ukranian_je #x6a4 ;; deprecated +)(defconstant XK_Macedonia_dse #x6a5 +)(defconstant XK_Ukrainian_i #x6a6 +)(defconstant XK_Ukranian_i #x6a6 ;; deprecated +)(defconstant XK_Ukrainian_yi #x6a7 +)(defconstant XK_Ukranian_yi #x6a7 ;; deprecated +)(defconstant XK_Cyrillic_je #x6a8 +)(defconstant XK_Serbian_je #x6a8 ;; deprecated +)(defconstant XK_Cyrillic_lje #x6a9 +)(defconstant XK_Serbian_lje #x6a9 ;; deprecated +)(defconstant XK_Cyrillic_nje #x6aa +)(defconstant XK_Serbian_nje #x6aa ;; deprecated +)(defconstant XK_Serbian_tshe #x6ab +)(defconstant XK_Macedonia_kje #x6ac +)(defconstant XK_Byelorussian_shortu #x6ae +)(defconstant XK_Cyrillic_dzhe #x6af +)(defconstant XK_Serbian_dze #x6af ;; deprecated +)(defconstant XK_numerosign #x6b0 +)(defconstant XK_Serbian_DJE #x6b1 +)(defconstant XK_Macedonia_GJE #x6b2 +)(defconstant XK_Cyrillic_IO #x6b3 +)(defconstant XK_Ukrainian_IE #x6b4 +)(defconstant XK_Ukranian_JE #x6b4 ;; deprecated +)(defconstant XK_Macedonia_DSE #x6b5 +)(defconstant XK_Ukrainian_I #x6b6 +)(defconstant XK_Ukranian_I #x6b6 ;; deprecated +)(defconstant XK_Ukrainian_YI #x6b7 +)(defconstant XK_Ukranian_YI #x6b7 ;; deprecated +)(defconstant XK_Cyrillic_JE #x6b8 +)(defconstant XK_Serbian_JE #x6b8 ;; deprecated +)(defconstant XK_Cyrillic_LJE #x6b9 +)(defconstant XK_Serbian_LJE #x6b9 ;; deprecated +)(defconstant XK_Cyrillic_NJE #x6ba +)(defconstant XK_Serbian_NJE #x6ba ;; deprecated +)(defconstant XK_Serbian_TSHE #x6bb +)(defconstant XK_Macedonia_KJE #x6bc +)(defconstant XK_Byelorussian_SHORTU #x6be +)(defconstant XK_Cyrillic_DZHE #x6bf +)(defconstant XK_Serbian_DZE #x6bf ;; deprecated +)(defconstant XK_Cyrillic_yu #x6c0 +)(defconstant XK_Cyrillic_a #x6c1 +)(defconstant XK_Cyrillic_be #x6c2 +)(defconstant XK_Cyrillic_tse #x6c3 +)(defconstant XK_Cyrillic_de #x6c4 +)(defconstant XK_Cyrillic_ie #x6c5 +)(defconstant XK_Cyrillic_ef #x6c6 +)(defconstant XK_Cyrillic_ghe #x6c7 +)(defconstant XK_Cyrillic_ha #x6c8 +)(defconstant XK_Cyrillic_i #x6c9 +)(defconstant XK_Cyrillic_shorti #x6ca +)(defconstant XK_Cyrillic_ka #x6cb +)(defconstant XK_Cyrillic_el #x6cc +)(defconstant XK_Cyrillic_em #x6cd +)(defconstant XK_Cyrillic_en #x6ce +)(defconstant XK_Cyrillic_o #x6cf +)(defconstant XK_Cyrillic_pe #x6d0 +)(defconstant XK_Cyrillic_ya #x6d1 +)(defconstant XK_Cyrillic_er #x6d2 +)(defconstant XK_Cyrillic_es #x6d3 +)(defconstant XK_Cyrillic_te #x6d4 +)(defconstant XK_Cyrillic_u #x6d5 +)(defconstant XK_Cyrillic_zhe #x6d6 +)(defconstant XK_Cyrillic_ve #x6d7 +)(defconstant XK_Cyrillic_softsign #x6d8 +)(defconstant XK_Cyrillic_yeru #x6d9 +)(defconstant XK_Cyrillic_ze #x6da +)(defconstant XK_Cyrillic_sha #x6db +)(defconstant XK_Cyrillic_e #x6dc +)(defconstant XK_Cyrillic_shcha #x6dd +)(defconstant XK_Cyrillic_che #x6de +)(defconstant XK_Cyrillic_hardsign #x6df +)(defconstant XK_Cyrillic_YU #x6e0 +)(defconstant XK_Cyrillic_A #x6e1 +)(defconstant XK_Cyrillic_BE #x6e2 +)(defconstant XK_Cyrillic_TSE #x6e3 +)(defconstant XK_Cyrillic_DE #x6e4 +)(defconstant XK_Cyrillic_IE #x6e5 +)(defconstant XK_Cyrillic_EF #x6e6 +)(defconstant XK_Cyrillic_GHE #x6e7 +)(defconstant XK_Cyrillic_HA #x6e8 +)(defconstant XK_Cyrillic_I #x6e9 +)(defconstant XK_Cyrillic_SHORTI #x6ea +)(defconstant XK_Cyrillic_KA #x6eb +)(defconstant XK_Cyrillic_EL #x6ec +)(defconstant XK_Cyrillic_EM #x6ed +)(defconstant XK_Cyrillic_EN #x6ee +)(defconstant XK_Cyrillic_O #x6ef +)(defconstant XK_Cyrillic_PE #x6f0 +)(defconstant XK_Cyrillic_YA #x6f1 +)(defconstant XK_Cyrillic_ER #x6f2 +)(defconstant XK_Cyrillic_ES #x6f3 +)(defconstant XK_Cyrillic_TE #x6f4 +)(defconstant XK_Cyrillic_U #x6f5 +)(defconstant XK_Cyrillic_ZHE #x6f6 +)(defconstant XK_Cyrillic_VE #x6f7 +)(defconstant XK_Cyrillic_SOFTSIGN #x6f8 +)(defconstant XK_Cyrillic_YERU #x6f9 +)(defconstant XK_Cyrillic_ZE #x6fa +)(defconstant XK_Cyrillic_SHA #x6fb +)(defconstant XK_Cyrillic_E #x6fc +)(defconstant XK_Cyrillic_SHCHA #x6fd +)(defconstant XK_Cyrillic_CHE #x6fe +)(defconstant XK_Cyrillic_HARDSIGN #x6ff +;;endif ;; XK_CYRILLIC + +;; + ; Greek + ; Byte 3 = 7 + + +;;ifdef XK_GREEK +)(defconstant XK_Greek_ALPHAaccent #x7a1 +)(defconstant XK_Greek_EPSILONaccent #x7a2 +)(defconstant XK_Greek_ETAaccent #x7a3 +)(defconstant XK_Greek_IOTAaccent #x7a4 +)(defconstant XK_Greek_IOTAdiaeresis #x7a5 +)(defconstant XK_Greek_OMICRONaccent #x7a7 +)(defconstant XK_Greek_UPSILONaccent #x7a8 +)(defconstant XK_Greek_UPSILONdieresis #x7a9 +)(defconstant XK_Greek_OMEGAaccent #x7ab +)(defconstant XK_Greek_accentdieresis #x7ae +)(defconstant XK_Greek_horizbar #x7af +)(defconstant XK_Greek_alphaaccent #x7b1 +)(defconstant XK_Greek_epsilonaccent #x7b2 +)(defconstant XK_Greek_etaaccent #x7b3 +)(defconstant XK_Greek_iotaaccent #x7b4 +)(defconstant XK_Greek_iotadieresis #x7b5 +)(defconstant XK_Greek_iotaaccentdieresis #x7b6 +)(defconstant XK_Greek_omicronaccent #x7b7 +)(defconstant XK_Greek_upsilonaccent #x7b8 +)(defconstant XK_Greek_upsilondieresis #x7b9 +)(defconstant XK_Greek_upsilonaccentdieresis #x7ba +)(defconstant XK_Greek_omegaaccent #x7bb +)(defconstant XK_Greek_ALPHA #x7c1 +)(defconstant XK_Greek_BETA #x7c2 +)(defconstant XK_Greek_GAMMA #x7c3 +)(defconstant XK_Greek_DELTA #x7c4 +)(defconstant XK_Greek_EPSILON #x7c5 +)(defconstant XK_Greek_ZETA #x7c6 +)(defconstant XK_Greek_ETA #x7c7 +)(defconstant XK_Greek_THETA #x7c8 +)(defconstant XK_Greek_IOTA #x7c9 +)(defconstant XK_Greek_KAPPA #x7ca +)(defconstant XK_Greek_LAMDA #x7cb +)(defconstant XK_Greek_LAMBDA #x7cb +)(defconstant XK_Greek_MU #x7cc +)(defconstant XK_Greek_NU #x7cd +)(defconstant XK_Greek_XI #x7ce +)(defconstant XK_Greek_OMICRON #x7cf +)(defconstant XK_Greek_PI #x7d0 +)(defconstant XK_Greek_RHO #x7d1 +)(defconstant XK_Greek_SIGMA #x7d2 +)(defconstant XK_Greek_TAU #x7d4 +)(defconstant XK_Greek_UPSILON #x7d5 +)(defconstant XK_Greek_PHI #x7d6 +)(defconstant XK_Greek_CHI #x7d7 +)(defconstant XK_Greek_PSI #x7d8 +)(defconstant XK_Greek_OMEGA #x7d9 +)(defconstant XK_Greek_alpha #x7e1 +)(defconstant XK_Greek_beta #x7e2 +)(defconstant XK_Greek_gamma #x7e3 +)(defconstant XK_Greek_delta #x7e4 +)(defconstant XK_Greek_epsilon #x7e5 +)(defconstant XK_Greek_zeta #x7e6 +)(defconstant XK_Greek_eta #x7e7 +)(defconstant XK_Greek_theta #x7e8 +)(defconstant XK_Greek_iota #x7e9 +)(defconstant XK_Greek_kappa #x7ea +)(defconstant XK_Greek_lamda #x7eb +)(defconstant XK_Greek_lambda #x7eb +)(defconstant XK_Greek_mu #x7ec +)(defconstant XK_Greek_nu #x7ed +)(defconstant XK_Greek_xi #x7ee +)(defconstant XK_Greek_omicron #x7ef +)(defconstant XK_Greek_pi #x7f0 +)(defconstant XK_Greek_rho #x7f1 +)(defconstant XK_Greek_sigma #x7f2 +)(defconstant XK_Greek_finalsmallsigma #x7f3 +)(defconstant XK_Greek_tau #x7f4 +)(defconstant XK_Greek_upsilon #x7f5 +)(defconstant XK_Greek_phi #x7f6 +)(defconstant XK_Greek_chi #x7f7 +)(defconstant XK_Greek_psi #x7f8 +)(defconstant XK_Greek_omega #x7f9 +)(defconstant XK_Greek_switch #xFF7E ;; Alias for mode_switch +;;endif ;; XK_GREEK + +;; + ; Technical + ; Byte 3 = 8 + + +;;ifdef XK_TECHNICAL +)(defconstant XK_leftradical #x8a1 +)(defconstant XK_topleftradical #x8a2 +)(defconstant XK_horizconnector #x8a3 +)(defconstant XK_topintegral #x8a4 +)(defconstant XK_botintegral #x8a5 +)(defconstant XK_vertconnector #x8a6 +)(defconstant XK_topleftsqbracket #x8a7 +)(defconstant XK_botleftsqbracket #x8a8 +)(defconstant XK_toprightsqbracket #x8a9 +)(defconstant XK_botrightsqbracket #x8aa +)(defconstant XK_topleftparens #x8ab +)(defconstant XK_botleftparens #x8ac +)(defconstant XK_toprightparens #x8ad +)(defconstant XK_botrightparens #x8ae +)(defconstant XK_leftmiddlecurlybrace #x8af +)(defconstant XK_rightmiddlecurlybrace #x8b0 +)(defconstant XK_topleftsummation #x8b1 +)(defconstant XK_botleftsummation #x8b2 +)(defconstant XK_topvertsummationconnector #x8b3 +)(defconstant XK_botvertsummationconnector #x8b4 +)(defconstant XK_toprightsummation #x8b5 +)(defconstant XK_botrightsummation #x8b6 +)(defconstant XK_rightmiddlesummation #x8b7 +)(defconstant XK_lessthanequal #x8bc +)(defconstant XK_notequal #x8bd +)(defconstant XK_greaterthanequal #x8be +)(defconstant XK_integral #x8bf +)(defconstant XK_therefore #x8c0 +)(defconstant XK_variation #x8c1 +)(defconstant XK_infinity #x8c2 +)(defconstant XK_nabla #x8c5 +)(defconstant XK_approximate #x8c8 +)(defconstant XK_similarequal #x8c9 +)(defconstant XK_ifonlyif #x8cd +)(defconstant XK_implies #x8ce +)(defconstant XK_identical #x8cf +)(defconstant XK_radical #x8d6 +)(defconstant XK_includedin #x8da +)(defconstant XK_includes #x8db +)(defconstant XK_intersection #x8dc +)(defconstant XK_union #x8dd +)(defconstant XK_logicaland #x8de +)(defconstant XK_logicalor #x8df +)(defconstant XK_partialderivative #x8ef +)(defconstant XK_function #x8f6 +)(defconstant XK_leftarrow #x8fb +)(defconstant XK_uparrow #x8fc +)(defconstant XK_rightarrow #x8fd +)(defconstant XK_downarrow #x8fe +;;endif ;; XK_TECHNICAL + +;; + ; Special + ; Byte 3 = 9 + + +;;ifdef XK_SPECIAL +)(defconstant XK_blank #x9df +)(defconstant XK_soliddiamond #x9e0 +)(defconstant XK_checkerboard #x9e1 +)(defconstant XK_ht #x9e2 +)(defconstant XK_ff #x9e3 +)(defconstant XK_cr #x9e4 +)(defconstant XK_lf #x9e5 +)(defconstant XK_nl #x9e8 +)(defconstant XK_vt #x9e9 +)(defconstant XK_lowrightcorner #x9ea +)(defconstant XK_uprightcorner #x9eb +)(defconstant XK_upleftcorner #x9ec +)(defconstant XK_lowleftcorner #x9ed +)(defconstant XK_crossinglines #x9ee +)(defconstant XK_horizlinescan1 #x9ef +)(defconstant XK_horizlinescan3 #x9f0 +)(defconstant XK_horizlinescan5 #x9f1 +)(defconstant XK_horizlinescan7 #x9f2 +)(defconstant XK_horizlinescan9 #x9f3 +)(defconstant XK_leftt #x9f4 +)(defconstant XK_rightt #x9f5 +)(defconstant XK_bott #x9f6 +)(defconstant XK_topt #x9f7 +)(defconstant XK_vertbar #x9f8 +;;endif ;; XK_SPECIAL + +;; + ; Publishing + ; Byte 3 = a + + +;;ifdef XK_PUBLISHING +)(defconstant XK_emspace #xaa1 +)(defconstant XK_enspace #xaa2 +)(defconstant XK_em3space #xaa3 +)(defconstant XK_em4space #xaa4 +)(defconstant XK_digitspace #xaa5 +)(defconstant XK_punctspace #xaa6 +)(defconstant XK_thinspace #xaa7 +)(defconstant XK_hairspace #xaa8 +)(defconstant XK_emdash #xaa9 +)(defconstant XK_endash #xaaa +)(defconstant XK_signifblank #xaac +)(defconstant XK_ellipsis #xaae +)(defconstant XK_doubbaselinedot #xaaf +)(defconstant XK_onethird #xab0 +)(defconstant XK_twothirds #xab1 +)(defconstant XK_onefifth #xab2 +)(defconstant XK_twofifths #xab3 +)(defconstant XK_threefifths #xab4 +)(defconstant XK_fourfifths #xab5 +)(defconstant XK_onesixth #xab6 +)(defconstant XK_fivesixths #xab7 +)(defconstant XK_careof #xab8 +)(defconstant XK_figdash #xabb +)(defconstant XK_leftanglebracket #xabc +)(defconstant XK_decimalpoint #xabd +)(defconstant XK_rightanglebracket #xabe +)(defconstant XK_marker #xabf +)(defconstant XK_oneeighth #xac3 +)(defconstant XK_threeeighths #xac4 +)(defconstant XK_fiveeighths #xac5 +)(defconstant XK_seveneighths #xac6 +)(defconstant XK_trademark #xac9 +)(defconstant XK_signaturemark #xaca +)(defconstant XK_trademarkincircle #xacb +)(defconstant XK_leftopentriangle #xacc +)(defconstant XK_rightopentriangle #xacd +)(defconstant XK_emopencircle #xace +)(defconstant XK_emopenrectangle #xacf +)(defconstant XK_leftsinglequotemark #xad0 +)(defconstant XK_rightsinglequotemark #xad1 +)(defconstant XK_leftdoublequotemark #xad2 +)(defconstant XK_rightdoublequotemark #xad3 +)(defconstant XK_prescription #xad4 +)(defconstant XK_minutes #xad6 +)(defconstant XK_seconds #xad7 +)(defconstant XK_latincross #xad9 +)(defconstant XK_hexagram #xada +)(defconstant XK_filledrectbullet #xadb +)(defconstant XK_filledlefttribullet #xadc +)(defconstant XK_filledrighttribullet #xadd +)(defconstant XK_emfilledcircle #xade +)(defconstant XK_emfilledrect #xadf +)(defconstant XK_enopencircbullet #xae0 +)(defconstant XK_enopensquarebullet #xae1 +)(defconstant XK_openrectbullet #xae2 +)(defconstant XK_opentribulletup #xae3 +)(defconstant XK_opentribulletdown #xae4 +)(defconstant XK_openstar #xae5 +)(defconstant XK_enfilledcircbullet #xae6 +)(defconstant XK_enfilledsqbullet #xae7 +)(defconstant XK_filledtribulletup #xae8 +)(defconstant XK_filledtribulletdown #xae9 +)(defconstant XK_leftpointer #xaea +)(defconstant XK_rightpointer #xaeb +)(defconstant XK_club #xaec +)(defconstant XK_diamond #xaed +)(defconstant XK_heart #xaee +)(defconstant XK_maltesecross #xaf0 +)(defconstant XK_dagger #xaf1 +)(defconstant XK_doubledagger #xaf2 +)(defconstant XK_checkmark #xaf3 +)(defconstant XK_ballotcross #xaf4 +)(defconstant XK_musicalsharp #xaf5 +)(defconstant XK_musicalflat #xaf6 +)(defconstant XK_malesymbol #xaf7 +)(defconstant XK_femalesymbol #xaf8 +)(defconstant XK_telephone #xaf9 +)(defconstant XK_telephonerecorder #xafa +)(defconstant XK_phonographcopyright #xafb +)(defconstant XK_caret #xafc +)(defconstant XK_singlelowquotemark #xafd +)(defconstant XK_doublelowquotemark #xafe +)(defconstant XK_cursor #xaff +;;endif ;; XK_PUBLISHING + +;; + ; APL + ; Byte 3 = b + + +;;ifdef XK_APL +)(defconstant XK_leftcaret #xba3 +)(defconstant XK_rightcaret #xba6 +)(defconstant XK_downcaret #xba8 +)(defconstant XK_upcaret #xba9 +)(defconstant XK_overbar #xbc0 +)(defconstant XK_downtack #xbc2 +)(defconstant XK_upshoe #xbc3 +)(defconstant XK_downstile #xbc4 +)(defconstant XK_underbar #xbc6 +)(defconstant XK_jot #xbca +)(defconstant XK_quad #xbcc +)(defconstant XK_uptack #xbce +)(defconstant XK_circle #xbcf +)(defconstant XK_upstile #xbd3 +)(defconstant XK_downshoe #xbd6 +)(defconstant XK_rightshoe #xbd8 +)(defconstant XK_leftshoe #xbda +)(defconstant XK_lefttack #xbdc +)(defconstant XK_righttack #xbfc +;;endif ;; XK_APL + +;; + ; Hebrew + ; Byte 3 = c + + +;;ifdef XK_HEBREW +)(defconstant XK_hebrew_doublelowline #xcdf +)(defconstant XK_hebrew_aleph #xce0 +)(defconstant XK_hebrew_bet #xce1 +)(defconstant XK_hebrew_beth #xce1 ;; deprecated +)(defconstant XK_hebrew_gimel #xce2 +)(defconstant XK_hebrew_gimmel #xce2 ;; deprecated +)(defconstant XK_hebrew_dalet #xce3 +)(defconstant XK_hebrew_daleth #xce3 ;; deprecated +)(defconstant XK_hebrew_he #xce4 +)(defconstant XK_hebrew_waw #xce5 +)(defconstant XK_hebrew_zain #xce6 +)(defconstant XK_hebrew_zayin #xce6 ;; deprecated +)(defconstant XK_hebrew_chet #xce7 +)(defconstant XK_hebrew_het #xce7 ;; deprecated +)(defconstant XK_hebrew_tet #xce8 +)(defconstant XK_hebrew_teth #xce8 ;; deprecated +)(defconstant XK_hebrew_yod #xce9 +)(defconstant XK_hebrew_finalkaph #xcea +)(defconstant XK_hebrew_kaph #xceb +)(defconstant XK_hebrew_lamed #xcec +)(defconstant XK_hebrew_finalmem #xced +)(defconstant XK_hebrew_mem #xcee +)(defconstant XK_hebrew_finalnun #xcef +)(defconstant XK_hebrew_nun #xcf0 +)(defconstant XK_hebrew_samech #xcf1 +)(defconstant XK_hebrew_samekh #xcf1 ;; deprecated +)(defconstant XK_hebrew_ayin #xcf2 +)(defconstant XK_hebrew_finalpe #xcf3 +)(defconstant XK_hebrew_pe #xcf4 +)(defconstant XK_hebrew_finalzade #xcf5 +)(defconstant XK_hebrew_finalzadi #xcf5 ;; deprecated +)(defconstant XK_hebrew_zade #xcf6 +)(defconstant XK_hebrew_zadi #xcf6 ;; deprecated +)(defconstant XK_hebrew_qoph #xcf7 +)(defconstant XK_hebrew_kuf #xcf7 ;; deprecated +)(defconstant XK_hebrew_resh #xcf8 +)(defconstant XK_hebrew_shin #xcf9 +)(defconstant XK_hebrew_taw #xcfa +)(defconstant XK_hebrew_taf #xcfa ;; deprecated +)(defconstant XK_Hebrew_switch #xFF7E ;; Alias for mode_switch +;;endif ;; XK_HEBREW +) diff --git a/xgcl-2/gcl_lispserver.lsp b/xgcl-2/gcl_lispserver.lsp new file mode 100644 index 0000000..79acade --- /dev/null +++ b/xgcl-2/gcl_lispserver.lsp @@ -0,0 +1,130 @@ +; lispserver.lsp Gordon S. Novak Jr. ; 26 Jan 06 + +; Copyright (c) 2006 Gordon S. Novak Jr. and The University of Texas at Austin. + +; 06 Jun 02 + +; See the file gnu.license . + +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 1, or (at your option) +; any later version. + +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +; Written by: Gordon S. Novak Jr., Department of Computer Sciences, +; University of Texas at Austin 78712. novak@cs.utexas.edu + +;------------------------------------------------------------------------ + +; This is an example of a simple interactive graphical interface +; to a Lisp program. It reads Lisp expressions from the user, +; evaluates them, and prints the result. + +; Stand-alone usage using XGCL (edit file paths as appropriate): +; (load "/u/novak/X/xgcl-2/dwsyms.lsp") +; (load "/u/novak/X/xgcl-2/dwimports.lsp") +; (load "/u/novak/X/solaris/dwtrans.o") +; (load "/u/novak/glisp/menu-settrans.lsp") +; (load "/u/novak/glisp/lispservertrans.lsp") +; (lisp-server) + +; Usage with the WeirdX Java emulation of an X server begins with +; the web page example.html and uses the files lispserver.cgi , +; nph-lisp-action.cgi , and lispdemo.lsp . + +;------------------------------------------------------------------------ + +(defvar *wio-window* nil) +(defvar *wio-window-width* 500) +(defvar *wio-window-height* 300) +(defvar *wio-menu-set* nil) +(defvar *wio-font* '8x13) + +(glispglobals (*wio-window* window) + (*wio-window-width* integer) + (*wio-window-height* integer) + (*wio-menu-set* menu-set) ) + +(defmacro while (test &rest forms) + `(loop (unless ,test (return)) ,@forms) ) + +; 18 Apr 95; 20 Apr 95; 08 May 95; 31 May 02 +; Make a window to use. +(setf (glfnresulttype 'wio-window) 'window) +(defun wio-window (&optional title width height (posx 0) (posy 0) font) + (if width (setq *wio-window-width* width)) + (if height (setq *wio-window-height* height)) + (or *wio-window* + (setq *wio-window* + (window-create *wio-window-width* *wio-window-height* title + nil posx posy font))) ) + +; 19 Apr 95 +(defun wio-init-menus (w commands) + (let () + (window-clear w) + (setq *wio-menu-set* (menu-set-create w nil)) + (menu-set-add-menu *wio-menu-set* 'command nil "Commands" + commands (list 0 0)) + (menu-set-adjust *wio-menu-set* 'command 'top nil 2) + (menu-set-adjust *wio-menu-set* 'command 'right nil 2) + )) + +; 19 Apr 95; 20 Apr 95; 25 Apr 95; 02 May 95; 29 May 02 +; Lisp server example +(gldefun lisp-server () + (let (w inputm done sel (redraw t) str result) + (w = (wio-window "Lisp Server")) + (open w) + (clear w) + (set-font w *wio-font*) + (wio-init-menus w '(("Quit" . quit))) + (window-print-lines w + '("Click mouse in the input box, then enter" + "a Lisp expression followed by Return." + "" + "Input: e.g. (+ 3 4) or (sqrt 2)") + 10 (- *wio-window-height* 20)) + (window-printat-xy w "Result:" 10 (- *wio-window-height* 150)) + (inputm = (textmenu-create (- *wio-window-width* 100) 30 nil w + 20 (- *wio-window-height* 110) t t '9x15 t)) + (add-item *wio-menu-set* 'input nil inputm) + (while ~ done do + (sel = (menu-set-select *wio-menu-set* redraw)) + (redraw = nil) + (case (menu-name sel) + (command + (case (port sel) + (quit (done = t)) + )) + (input (str = (port sel)) + (result = (catch 'error + (eval (safe-read-from-string str)))) + (erase-area-xy w 20 2 (- *wio-window-width* 20) + (- *wio-window-height* 160)) + (window-print-line w (write-to-string result :pretty t) + 20 (- *wio-window-height* 170))) + ) ) + (close w) + )) + +; 25 Apr 95; 14 Mar 01 +(defun safe-read-from-string (str) + (if (and (stringp str) (> (length str) 0)) + (read-from-string str nil 'read-error))) + +(defun compile-lispserver () + (glcompfiles *directory* + '("glisp/vector.lsp") ; auxiliary files + '("glisp/lispserver.lsp") ; translated files + "glisp/lispservertrans.lsp") ; output file + ) diff --git a/xgcl-2/gcl_lispservertrans.lsp b/xgcl-2/gcl_lispservertrans.lsp new file mode 100644 index 0000000..49f6388 --- /dev/null +++ b/xgcl-2/gcl_lispservertrans.lsp @@ -0,0 +1,110 @@ +; 27 Jan 2006 14:38:08 CST +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 2 of the License, or +; (at your option) any later version. + +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + + +(DEFVAR *WIO-WINDOW* NIL) + +(DEFVAR *WIO-WINDOW-WIDTH* 500) + +(DEFVAR *WIO-WINDOW-HEIGHT* 300) + +(DEFVAR *WIO-MENU-SET* NIL) + +(DEFVAR *WIO-FONT* '8X13) + +(DEFVAR *WIO-WINDOW*) +(SETF (GET '*WIO-WINDOW* 'GLISPGLOBALVAR) T) +(SETF (GET '*WIO-WINDOW* 'GLISPGLOBALVARTYPE) 'WINDOW) +(DEFVAR *WIO-WINDOW-WIDTH*) +(SETF (GET '*WIO-WINDOW-WIDTH* 'GLISPGLOBALVAR) T) +(SETF (GET '*WIO-WINDOW-WIDTH* 'GLISPGLOBALVARTYPE) 'INTEGER) +(DEFVAR *WIO-WINDOW-HEIGHT*) +(SETF (GET '*WIO-WINDOW-HEIGHT* 'GLISPGLOBALVAR) T) +(SETF (GET '*WIO-WINDOW-HEIGHT* 'GLISPGLOBALVARTYPE) 'INTEGER) +(DEFVAR *WIO-MENU-SET*) +(SETF (GET '*WIO-MENU-SET* 'GLISPGLOBALVAR) T) +(SETF (GET '*WIO-MENU-SET* 'GLISPGLOBALVARTYPE) 'MENU-SET) + + +(DEFMACRO WHILE (TEST &REST FORMS) + (LIST* 'LOOP (LIST 'UNLESS TEST '(RETURN)) FORMS)) + +(SETF (GET 'WIO-WINDOW 'GLFNRESULTTYPE) 'WINDOW) + +(DEFUN WIO-WINDOW (&OPTIONAL TITLE WIDTH HEIGHT (POSX 0) (POSY 0) FONT) + (IF WIDTH (SETQ *WIO-WINDOW-WIDTH* WIDTH)) + (IF HEIGHT (SETQ *WIO-WINDOW-HEIGHT* HEIGHT)) + (OR *WIO-WINDOW* + (SETQ *WIO-WINDOW* + (WINDOW-CREATE *WIO-WINDOW-WIDTH* *WIO-WINDOW-HEIGHT* TITLE + NIL POSX POSY FONT)))) + +(DEFUN WIO-INIT-MENUS (W COMMANDS) + (LET () + (WINDOW-CLEAR W) + (SETQ *WIO-MENU-SET* (MENU-SET-CREATE W NIL)) + (MENU-SET-ADD-MENU *WIO-MENU-SET* 'COMMAND NIL "Commands" COMMANDS + (LIST 0 0)) + (MENU-SET-ADJUST *WIO-MENU-SET* 'COMMAND 'TOP NIL 2) + (MENU-SET-ADJUST *WIO-MENU-SET* 'COMMAND 'RIGHT NIL 2))) + +(DEFUN LISP-SERVER () + (LET (W INPUTM DONE SEL (REDRAW T) STR RESULT) + (SETQ W (WIO-WINDOW "Lisp Server")) + (WINDOW-OPEN W) + (WINDOW-CLEAR W) + (WINDOW-SET-FONT W *WIO-FONT*) + (WIO-INIT-MENUS W '(("Quit" . QUIT))) + (WINDOW-PRINT-LINES W + '("Click mouse in the input box, then enter" + "a Lisp expression followed by Return." "" + "Input: e.g. (+ 3 4) or (sqrt 2)") + 10 (+ -20 *WIO-WINDOW-HEIGHT*)) + (WINDOW-PRINTAT-XY W "Result:" 10 (+ -150 *WIO-WINDOW-HEIGHT*)) + (SETQ INPUTM + (TEXTMENU-CREATE (+ -100 *WIO-WINDOW-WIDTH*) 30 NIL W 20 + (+ -110 *WIO-WINDOW-HEIGHT*) T T '9X15 T)) + (MENU-SET-ADD-ITEM *WIO-MENU-SET* 'INPUT NIL INPUTM) + (WHILE (NOT DONE) + (SETQ SEL (MENU-SET-SELECT *WIO-MENU-SET* REDRAW)) + (SETQ REDRAW NIL) + (CASE (CADR SEL) + (COMMAND (CASE (CAR SEL) (QUIT (SETQ DONE T)))) + (INPUT (SETQ STR (CAR SEL)) + (SETQ RESULT + (CATCH 'ERROR + (EVAL (SAFE-READ-FROM-STRING STR)))) + (WINDOW-ERASE-AREA-XY W 20 2 + (+ -20 *WIO-WINDOW-WIDTH*) + (+ -160 *WIO-WINDOW-HEIGHT*)) + (WINDOW-PRINT-LINE W + (WRITE-TO-STRING RESULT :PRETTY T) 20 + (+ -170 *WIO-WINDOW-HEIGHT*))))) + (WINDOW-CLOSE W))) + +(DEFUN SAFE-READ-FROM-STRING (STR) + (IF (AND (STRINGP STR) (> (LENGTH STR) 0)) + (READ-FROM-STRING STR NIL 'READ-ERROR))) + +(DEFUN COMPILE-LISPSERVER () + (GLCOMPFILES *DIRECTORY* '("glisp/vector.lsp") + '("glisp/lispserver.lsp") "glisp/lispservertrans.lsp" + "glisp/gpl.txt")) + +(DEFUN COMPILE-LISPSERVERB () + (GLCOMPFILES *DIRECTORY* + '("glisp/vector.lsp" "X/dwindow.lsp" "X/dwnoopen.lsp") + '("glisp/lispserver.lsp") "glisp/lispservertrans.lsp" + "glisp/gpl.txt")) diff --git a/xgcl-2/gcl_menu-set.lsp b/xgcl-2/gcl_menu-set.lsp new file mode 100644 index 0000000..ca0b260 --- /dev/null +++ b/xgcl-2/gcl_menu-set.lsp @@ -0,0 +1,521 @@ +; menu-set.lsp Gordon S. Novak Jr. ; 17 Jan 08 + +; Functions to handle a set of menus within a single window. + +; Copyright (c) 2008 Gordon S. Novak Jr. and The University of Texas at Austin. + +; See the file gnu.license . + +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 1, or (at your option) +; any later version. + +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +; Written by: Gordon S. Novak Jr., Department of Computer Sciences, +; University of Texas at Austin 78712. novak@cs.utexas.edu + +; 12 Aug 96; 04 Nov 97; 28 Feb 02; 05 Jan 04; 03 Mar 04; 30 Jul 04; 02 Aug 04 +; 27 Jan 06 + +; (wtesta) ; in dwtest.lsp, to create window myw +; (setq ms (menu-set-create myw nil)) +; (menu-set-add-menu ms 'flag1 nil "Colors" '(red white blue)) +; position w/mouse +; (menu-set-add-menu ms 'Test1 nil "Choice" '(yes no)) +; position w/mouse +; do (wteste) to create the square picmenu +; (menu-set-add-picmenu ms 'square1 nil "Square" mypms) +; following is alternative -- window is too small to hold both square and cone +; create cone with draw +; (menu-set-add-picmenu ms 'cone1 'cone "Cone" 'cone) +; (menu-set-add-component ms 'nand) ; load draw-gates for nand and cone +; +; (menu-set-draw ms) +; (menu-set-select ms) ; click a menu or background +; (setq mc (menu-conns-create ms)) ; make a menu-conns object from menu set +; (menu-conns-add-conn mc) ; click two buttons/menu items +; repeat above as desired +; (menu-conns-move mc) ; click a menu and move it + +(glispobjects + +(menu-set (listobject (window window) + (menu-items (listof menu-set-item)) + (commandfn anything)) + msg ((draw menu-set-draw) + (select menu-set-select) + (named-menu menu-set-named-menu) + (named-item menu-set-named-item) + (add-menu menu-set-add-menu) + (add-picmenu menu-set-add-picmenu) + (add-component menu-set-add-component) + (add-barmenu menu-set-add-barmenu) + (add-item menu-set-add-item) + (find-item menu-set-find-item) + (delete-item menu-set-delete-item) + (remove-items menu-set-remove-items) + (item-position menu-set-item-position) + (itemp menu-set-itemp) + (adjust menu-set-adjust) + (move menu-set-move) + (draw-conn menu-set-draw-conn) ) ) + +(menu-set-item (list (menu-name symbol) + (sym anything) ; extra info + (menu menu-set-menu) ) + prop ((left ((parent-offset-x menu))) + (bottom ((parent-offset-y menu))) + (width ((picture-width menu))) + (height ((picture-height menu))) ) + supers (region) ) + +(menu-set-menu (transparent menu) ; menu or picmenu + msg ((draw menu-mdraw)) ) + +(menu-port (list (port symbol) (menu-name symbol)) ) + +(menu-selection (list (port symbol) (menu-name symbol) (button integer)) ) + +(menu-set-conn (list (from menu-port) + (to menu-port))) + +(menu-conns (listobject (menu-set menu-set) + (connections (listof menu-set-conn))) + prop ((window ((window (menu-set self))))) + msg ((draw menu-conns-draw) + (redraw menu-conns-redraw) + (move menu-conns-move) + (add-conn menu-conns-add-conn) + (add-item menu-conns-add-item open t) + (find-conn menu-conns-find-conn) + (find-item menu-conns-find-item) + (delete-item menu-conns-delete-item) + (delete-conn menu-conns-delete-conn) + (remove-items menu-conns-remove-items) + (find-conns menu-conns-find-conns) + (connected-ports menu-conns-connected-ports) + (new-conn menu-conns-new-conn) + (named-menu menu-conns-named-menu) + (named-item menu-conns-named-item) ) ) + + ) ; glispobjects + +; 04 Sep 92; 09 Feb 94; 12 Oct 94 +(gldefun menu-set-create ((w window) &optional fn) + (a menu-set with window = w commandfn = fn)) + +; 05 Sep 92; 09 Sep 92; 10 Sep 92; 02 Nov 92; 05 May 93; 07 May 93; 04 Aug 93 +; 03 Jan 94; 07 Jan 94; 03 May 94; 05 Jan 95; 11 Apr 95; 03 Nov 97; 05 Jan 04 +; Select from multiple menu-like regions within a window. +; Result is a menu-selection, i.e., a list of the value selected, +; menu name, and button used, +; e.g., (QUIT COMMAND 1) for selecting the QUIT item from the COMMAND menu. +; A click outside any menu returns ((x y) BACKGROUND button-code). +; enabled, if specified, is a list of names of menus enabled for selection. +(gldefun menu-set-select ((ms menu-set) &optional (redraw boolean) + (enabled (listof symbol))) + (result menu-selection) + (let ((res menu-selection) resb (itm menu-set-item) (sel symbol) lastx lasty) + (if redraw (draw ms)) + (while ~ (or res resb) + (setq itm (window-track-mouse (window ms) + #'(lambda (x y code) + (or (and (> code 0) + (setq lastx x) + (setq lasty y) + code) + (that menu-item with + (contains-xy (that menu-item) x y)))))) + (if (numberp itm) + (resb = (a menu-selection with + port (a vector with x = lastx y = lasty) + menu-name 'background + button itm)) + (if (or (atom enabled) + (member (menu-name itm) enabled)) + (progn (sel = (menu-mselect (menu itm) (eq enabled t))) + (if sel + (res = (a menu-selection with + menu-name (menu-name itm) + port sel + button *window-menu-code*)) + (if (and *window-menu-code* + (*window-menu-code* <> 0)) + (res = (a menu-selection with + menu-name (menu-name itm) + port nil + button *window-menu-code*)))) ) ) )) + (force-output (window ms)) + (or res resb) )) + +; 05 Sep 92; 25 Sep 92; 29 Sep 92 +; Add a menu to a menu set. +; name is the name of the menu. sym is extra info such as data type. +(gldefun menu-set-add-menu ((ms menu-set) (name symbol) (sym symbol) + (title string) items + &optional (offset vector)) + (let (menu) + (menu = (menu-create items title (window ms) (x offset) (y offset) t t)) + (init menu) + (if ~ offset (offset = (get-box-position (window ms) + (picture-width menu) + (picture-height menu)))) + ((parent-offset-x menu) = (x offset)) + ((parent-offset-y menu) = (y offset)) + (add-item ms name sym menu) )) + +; 25 Sep 92; 29 Sep 92; 07 May 93 +(gldefun menu-set-add-item ((ms menu-set) (name symbol) (sym symbol) + (menu menu)) + ((menu-items ms) _+ (a menu-set-item with menu-name = name sym = sym + menu = menu)) ) + +; 25 Sep 92 +(gldefun menu-set-remove-items ((ms menu-set)) + ((menu-items ms) = nil) ) + +; 06 Sep 92; 08 Sep 92; 14 Sep 92; 25 Sep 92; 29 Sep 92; 05 Jan 04; 23 Jun 04 +(gldefun menu-set-add-picmenu ((ms menu-set) (name symbol) (sym symbol) + (title string) + (spec picmenu-spec) + &optional (offset vector) + (nobox boolean)) + (let (menu maxwidth maxheight) + (if (and spec (symbolp spec)) + (spec = (get spec 'picmenu-spec)) ) + (menu = (picmenu-create-from-spec spec title (window ms) + (x offset) (y offset) t t (not nobox))) + (maxwidth = (max (if title ((* 9 (length title)) + 6) 0) + (drawing-width spec))) + (maxheight = (if title 15 0) + (drawing-height spec)) + (if ~ offset (offset = (get-box-position (window ms) maxwidth maxheight))) + ((parent-offset-x menu) = (x offset)) + ((parent-offset-y menu) = (y offset)) + (add-item ms name sym menu) )) + +; 11 Oct 93 +(gldefun menu-set-add-component ((ms menu-set) (name symbol) + &optional (offset vector)) + (menu-set-add-picmenu ms (menu-set-name name) name nil name offset t)) + +; 03 Jan 94; 05 Jan 04 +; Add a barmenu to a menu set. +(gldefun menu-set-add-barmenu ((ms menu-set) (name symbol) (sym symbol) + (menu barmenu) + (title string) &optional (offset vector)) + (let () + (init menu) + (if ~ offset + (offset = (get-box-position (window ms) + (picture-width menu) (picture-height menu)))) + ((parent-offset-x menu) = (x offset)) + ((parent-offset-y menu) = (y offset)) + (add-item ms name sym menu) )) + +; 11 Oct 93 +(gldefun menu-set-name ((nm symbol)) (result symbol) + (intern (symbol-name (gensym (symbol-name nm)))) ) + +; 29 Sep 92; 07 May 93; 28 Feb 02 +(gldefun menu-set-named-item ((ms menu-set) (name symbol)) + (result menu-set-item) + (that menu-item with (menu-name (that menu-item)) == name) ) + +; 08 Sep 92; 29 Sep 92 +(gldefun menu-set-named-menu ((ms menu-set) (name symbol)) + (result menu-set-menu) + (menu (named-item ms name))) + +; 17 Jan 08 +(gldefun menu-set-itemp ((ms menu-set) (name symbol) (itemname symbol)) + (let ((thismenu (named-menu ms name))) + (if thismenu is a menu + (some #'(lambda (x) (or (eq x itemname) + (and (consp x) (eq (car x) itemname)))) + (items thismenu)) + (if thismenu is a picmenu + (assoc itemname (buttons thismenu)) ) ) )) + +; 30 Jul 04 +(gldefun menu-conns-named-item ((mc menu-conns) (name symbol)) + (result menu-set-item) + (named-item (menu-set mc) name) ) + +; 01 Feb 94 +(gldefun menu-conns-named-menu ((mc menu-conns) (name symbol)) + (result menu-set-menu) + (named-menu (menu-set mc) name) ) + +; 29 Apr 93; 30 Apr 93; 05 Jan 04 +; Find the item at specified position, if any +(gldefun menu-set-find-item ((ms menu-set) (pos vector)) + (result menu-set-item) + (let (mitem) + (for mi in (menu-items ms) do + (if (contains? (menu mi) pos) + (mitem = mi))) + mitem)) + +; 29 Apr 93 +; Delete an item +(gldefun menu-set-delete-item ((ms menu-set) (mi menu-set-item)) + ((menu-items ms) _- mi)) + +; 08 Sep 92; 10 Sep 92; 05 May 93; 06 May 93; 07 May 93 +(gldefun menu-set-move ((ms menu-set)) + (let (sel m) + (sel = (menu-set-select ms nil t)) + (m = (named-menu ms (menu-name sel))) + (menu-reposition m) )) + +; 10 Sep 92; 05 Jan 94; 06 Jan 94; 20 Apr 95; 12 Aug 96 +; Draw either a menu or picmenu +(gldefun menu-mdraw (m) + (case (first m) + (menu (menu-draw m)) + (picmenu (picmenu-draw m)) + (barmenu (barmenu-draw m)) + (textmenu (textmenu-draw m)) + (editmenu (editmenu-draw m)) + (t (glsend m draw)) ) ) + +; 10 Sep 92; 29 Sep 92; 05 May 93; 03 Jan 94; 06 Jan 94; 20 Apr 95; 21 Apr 95 +; 12 Aug 96 +; Select from either a menu or picmenu +(gldefun menu-mselect (m &optional anyclick) + (case (first m) + (menu (menu-select m t)) + (picmenu (picmenu-select m t anyclick)) + (barmenu (barmenu-select m)) + (textmenu (textmenu-select m t)) + (editmenu (editmenu-select m t)) + (t (glsend m select)) ) ) + +; 10 Sep 92; 06 Jan 94 +; Get item position from either a menu or picmenu; 20 Apr 95 +(gldefun menu-mitem-position (m name loc) + (case (first m) + (menu (menu-item-position m name loc)) + (picmenu (picmenu-item-position m name loc)) + (t (glsend m item-position name loc)) ) ) + +; 05 Sep 92; 08 Sep 92 +(gldefun menu-set-draw ((ms menu-set)) + (let () + (open (window ms)) + (for item in (menu-items ms) do (draw (menu item))) )) + +; 08 Sep 92; 28 Sep 92; 07 May 93; 25 Jan 94 +(gldefun menu-set-item-position ((ms menu-set) (desc menu-port) + &optional (loc symbol)) + (result vector) + (let (m) + (m = (named-menu ms (menu-name desc))) + (or (menu-mitem-position m (port desc) loc) + (menu-mitem-position m nil loc)) )) ; header if it cannot be found + +; 08 Sep 92; 05 Jan 04 +(gldefun menu-set-draw-conn ((ms menu-set) (conn menu-set-conn)) + (let (pa pb tmp (desca (from conn)) (descb (to conn))) + (pa = (menu-set-item-position ms desca 'center)) + (pb = (menu-set-item-position ms descb 'center)) + (if ((x pa) > (x pb)) + (progn (tmp = desca) + (desca = descb) + (descb = tmp))) + (pa = (menu-set-item-position ms desca 'right)) + (pb = (menu-set-item-position ms descb 'left)) + (draw-circle (window ms) pa 3) + (draw-line (window ms) pa pb) + (draw-circle (window ms) pb 3) + (force-output (window ms)) )) + +; 02 Dec 93; 07 Jan 94; 05 Jan 04 +(gldefun menu-set-adjust ((ms menu-set) (name symbol) (edge symbol) + (from symbol) (offset integer)) + (let (m fromm place) + (if (m = (named-item ms name)) + (progn + (if from + (progn (fromm = (named-item ms from)) + (place = (case edge + (top (bottom fromm)) + (bottom (top fromm)) + (left (right fromm)) + (right (left fromm))))) + (place = (case edge + (top (height (window ms))) + ((bottom left) 0) + (right (width (window ms))) )) ) + (case edge (top ((bottom m) = place - (height m) - offset)) + (bottom ((bottom m) = place + offset)) + (left ((left m) = place + offset)) + (right ((left m) = place - (width m) - offset)))) ) )) + +; 21 Nov 08 +; align the vector approx with the vector fixed if within tolerance +(gldefun vector-snap ((fixed vector) (approx vector) + &optional tolerance) + (let () + (or tolerance (tolerance = 10)) + (if (< (abs (- (x fixed) (x approx))) tolerance) + (a vector x = (x fixed) y = (y approx)) + (if (< (abs (- (y fixed) (y approx))) tolerance) + (a vector x = (x approx) y = (y fixed)) + approx) ) )) + +; 12 Oct 94; 28 Feb 02 +(gldefun menu-conns-create ((ms menu-set)) + (a menu-conns with menu-set = ms)) + +; 08 Sep 92 +(gldefun menu-conns-draw ((mc menu-conns)) + (let () + (draw (menu-set mc)) + (for c in (connections mc) (draw-conn (menu-set mc) c)) )) + +; 08 Sep 92 +(gldefun menu-conns-move ((mc menu-conns)) + (let () + (menu-set-move (menu-set mc)) + (clear (window mc)) + (draw mc) )) + +; 29 Apr 93 +(gldefun menu-conns-redraw ((mc menu-conns)) + (let () + (clear (window mc)) + (draw mc) )) + +; 08 Sep 92; 07 May 93; 21 Oct 93; 05 Jan 95; 28 Feb 02; 05 Jan 04 +(gldefun menu-conns-add-conn ((mc menu-conns)) + (let (sel selb conn) + (sel = (select (menu-set mc))) + (if ((menu-name sel) == 'background) + sel + (progn (selb = (select (menu-set mc))) + (if ((menu-name selb) <> 'background) + (progn (conn = (a menu-set-conn with from = sel to = selb)) + (draw-conn (menu-set mc) conn) + ((connections mc) _+ conn))) + nil) ) )) + +; 02 Aug 04 +(gldefun menu-conns-new-conn ((mc menu-conns) (fromname symbol) + (fromport symbol) (toname symbol) + (toport symbol)) + (let (conn) + (conn = (a menu-set-conn with + from = (a menu-port with menu-name = fromname port = fromport) + to = (a menu-port with menu-name = toname port = toport))) + ((connections mc) _+ conn) )) + +; 30 Apr 93 +(gldefun menu-conns-add-item + ((mc menu-conns) (name symbol) (sym symbol) (menu menu)) + (add-item (menu-set mc) name sym menu)) + +; 29 Apr 93; 05 Jan 04 +; Find the connection that is selected by the given point, if any. +(gldefun menu-conns-find-conn ((mc menu-conns) (pt vector)) + (result menu-set-conn) + (let (ms ls found res pa pb tmp desca descb) + (ls = (a line-segment)) + (ms = (menu-set mc)) + (for conn in (connections mc) when (not found) do + (desca = (from conn)) + (descb = (to conn)) + (pa = (menu-set-item-position ms desca 'center)) + (pb = (menu-set-item-position ms descb 'center)) + (if ((x pa) > (x pb)) + (progn (tmp = desca) + (desca = descb) + (descb = tmp))) + ((p1 ls) = (menu-set-item-position ms desca 'right)) + ((p2 ls) = (menu-set-item-position ms descb 'left)) + (if (< (distance ls pt) 5) + (progn (found = t) + (res = conn)) )) + res)) + +; 29 Apr 93; 30 Apr 93 +; Find the menu item that is selected by the given point, if any. +(gldefun menu-conns-find-item ((mc menu-conns) (pt vector)) + (result menu-set-item) + (find-item (menu-set mc) pt)) + +; 29 Apr 93 +; Delete a connection +(gldefun menu-conns-delete-conn ((mc menu-conns) (conn menu-set-conn)) + ((connections mc) _- conn)) + +; 29 Apr 93; 07 May 93; 28 Feb 02; 05 Jan 04 +; Delete a menu item and all its connections +(gldefun menu-conns-delete-item ((mc menu-conns) (mi menu-set-item)) + (let (ms) + (ms = (menu-set mc)) + (delete-item ms mi) + (for conn in (connections mc) do + (if (or ((menu-name (from conn)) == (menu-name mi)) + ((menu-name (to conn)) == (menu-name mi))) + (delete-conn mc conn))) )) + +; 30 Apr 93 +(gldefun menu-conns-remove-items ((mc menu-conns)) + (remove-items (menu-set mc)) + ((connections mc) = nil)) + +; 30 Apr 93; 07 May 93; 28 Feb 02; 05 Jan 04 +; find all ports of a given named menu that are connected to something +(gldefun menu-conns-connected-ports ((mc menu-conns) (boxname symbol)) + (let (ports) + (for conn in (connections mc) do + (if (boxname == (menu-name (to conn))) + (pushnew (port (to conn)) ports) + (if (boxname == (menu-name (from conn))) + (pushnew (port (from conn)) ports)))) + ports)) + +; 30 Apr 93; 07 May 93; 28 Feb 02 +; Find connections of a given port of a named box +(gldefun menu-conns-find-conns ((mc menu-conns) (boxname symbol) (port symbol)) + (result (listof menu-port)) + (let (res) + (for conn in (connections mc) do + (if (and (boxname == (menu-name (to conn))) + (port == (port (to conn)))) + (res _+ (from conn))) + (if (and (boxname == (menu-name (from conn))) + (port == (port (from conn)))) + (res _+ (to conn))) ) + res)) + +; 03 May 94 +; Compile menu-set.lsp into a plain Lisp file +(defun compile-menu-set () + (glcompfiles *directory* + '("glisp/vector.lsp" ; auxiliary files + "X/dwindow.lsp") + '("glisp/menu-set.lsp") ; translated files + "glisp/menu-settrans.lsp" ; output file + "glisp/menu-set-header.lsp") ; header file + (compile-file "glisp/menu-settrans.lsp") ) + +; Compile menu-set.lsp into a plain Lisp file for XGCL distribution +(defun compile-menu-setb () + (glcompfiles *directory* + '("glisp/vector.lsp" ; auxiliary files + "X/dwindow.lsp" "X/dwnoopen.lsp") + '("glisp/menu-set.lsp") ; translated files + "glisp/menu-settrans.lsp" ; output file + "glisp/menu-set-header.lsp") ; header file + ) diff --git a/xgcl-2/gcl_menu-settrans.lsp b/xgcl-2/gcl_menu-settrans.lsp new file mode 100644 index 0000000..f4e5552 --- /dev/null +++ b/xgcl-2/gcl_menu-settrans.lsp @@ -0,0 +1,531 @@ +; 07 Jan 2010 16:46:11 EST + +; menu-settrans.lsp -- translation of menu-set.lsp Gordon S. Novak Jr. + +; Copyright 2006 Gordon S. Novak Jr. and The University of Texas at Austin. + +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 2 of the License, or +; (at your option) any later version. + +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + +; Written by: Gordon S. Novak Jr., Department of Computer Sciences, +; University of Texas at Austin 78712. novak@cs.utexas.edu + +(defmacro nconc1 (lst x) `(nconc ,lst (cons ,x nil))) + +(defmacro glmethod (class selector) + `(cadr (assoc ,selector (getf (cdr (get ,class 'glstructure)) 'msg))) ) + +(SETF (GET 'MENU-SET 'GLSTRUCTURE) + '((LISTOBJECT (WINDOW WINDOW) (MENU-ITEMS (LISTOF MENU-SET-ITEM)) + (COMMANDFN ANYTHING)) + MSG + ((DRAW MENU-SET-DRAW) (SELECT MENU-SET-SELECT) + (NAMED-MENU MENU-SET-NAMED-MENU) + (NAMED-ITEM MENU-SET-NAMED-ITEM) (ADD-MENU MENU-SET-ADD-MENU) + (ADD-PICMENU MENU-SET-ADD-PICMENU) + (ADD-COMPONENT MENU-SET-ADD-COMPONENT) + (ADD-BARMENU MENU-SET-ADD-BARMENU) + (ADD-ITEM MENU-SET-ADD-ITEM) (FIND-ITEM MENU-SET-FIND-ITEM) + (DELETE-ITEM MENU-SET-DELETE-ITEM) + (REMOVE-ITEMS MENU-SET-REMOVE-ITEMS) + (ITEM-POSITION MENU-SET-ITEM-POSITION) (ITEMP MENU-SET-ITEMP) + (ADJUST MENU-SET-ADJUST) (MOVE MENU-SET-MOVE) + (DRAW-CONN MENU-SET-DRAW-CONN)))) +(SETF (GET 'MENU-SET-ITEM 'GLSTRUCTURE) + '((LIST (MENU-NAME SYMBOL) (SYM ANYTHING) (MENU MENU-SET-MENU)) + PROP + ((LEFT ((PARENT-OFFSET-X MENU))) + (BOTTOM ((PARENT-OFFSET-Y MENU))) + (WIDTH ((PICTURE-WIDTH MENU))) + (HEIGHT ((PICTURE-HEIGHT MENU)))) + SUPERS (REGION))) +(SETF (GET 'MENU-SET-MENU 'GLSTRUCTURE) + '((TRANSPARENT MENU) MSG ((DRAW MENU-MDRAW)))) +(SETF (GET 'MENU-PORT 'GLSTRUCTURE) + '((LIST (PORT SYMBOL) (MENU-NAME SYMBOL)))) +(SETF (GET 'MENU-SELECTION 'GLSTRUCTURE) + '((LIST (PORT SYMBOL) (MENU-NAME SYMBOL) (BUTTON INTEGER)))) +(SETF (GET 'MENU-SET-CONN 'GLSTRUCTURE) + '((LIST (FROM MENU-PORT) (TO MENU-PORT)))) +(SETF (GET 'MENU-CONNS 'GLSTRUCTURE) + '((LISTOBJECT (MENU-SET MENU-SET) + (CONNECTIONS (LISTOF MENU-SET-CONN))) + PROP ((WINDOW ((WINDOW (MENU-SET SELF))))) MSG + ((DRAW MENU-CONNS-DRAW) (REDRAW MENU-CONNS-REDRAW) + (MOVE MENU-CONNS-MOVE) (ADD-CONN MENU-CONNS-ADD-CONN) + (ADD-ITEM MENU-CONNS-ADD-ITEM OPEN T) + (FIND-CONN MENU-CONNS-FIND-CONN) + (FIND-ITEM MENU-CONNS-FIND-ITEM) + (DELETE-ITEM MENU-CONNS-DELETE-ITEM) + (DELETE-CONN MENU-CONNS-DELETE-CONN) + (REMOVE-ITEMS MENU-CONNS-REMOVE-ITEMS) + (FIND-CONNS MENU-CONNS-FIND-CONNS) + (CONNECTED-PORTS MENU-CONNS-CONNECTED-PORTS) + (NEW-CONN MENU-CONNS-NEW-CONN) + (NAMED-MENU MENU-CONNS-NAMED-MENU) + (NAMED-ITEM MENU-CONNS-NAMED-ITEM)))) + + +(DEFUN MENU-SET-CREATE (W &OPTIONAL FN) (LIST 'MENU-SET W NIL FN)) +(SETF (GET 'MENU-SET-CREATE 'GLARGUMENTS) + '((W WINDOW) (&OPTIONAL NIL))) +(SETF (GET 'MENU-SET-CREATE 'GLFNRESULTTYPE) 'MENU-SET) + + +(DEFUN MENU-SET-SELECT (MS &OPTIONAL REDRAW ENABLED) + (LET (RES RESB ITM SEL LASTX LASTY) + (IF REDRAW (MENU-SET-DRAW MS)) + (WHILE (NOT (OR RES RESB)) + (SETQ ITM + (WINDOW-TRACK-MOUSE (CADR MS) + #'(LAMBDA (X Y CODE) + (OR (AND (PLUSP CODE) (SETQ LASTX X) + (SETQ LASTY Y) CODE) + (SOME #'(LAMBDA (GLVAR237) + (IF + (AND + (BETWEEN X + (FIFTH (CADDR GLVAR237)) + (+ (FIFTH (CADDR GLVAR237)) + (SEVENTH (CADDR GLVAR237)))) + (BETWEEN Y + (SIXTH (CADDR GLVAR237)) + (+ (SIXTH (CADDR GLVAR237)) + (EIGHTH (CADDR GLVAR237))))) + GLVAR237)) + (CADDR MS)))))) + (IF (NUMBERP ITM) + (SETQ RESB (LIST (LIST LASTX LASTY) 'BACKGROUND ITM)) + (WHEN (OR (ATOM ENABLED) (MEMBER (CAR ITM) ENABLED)) + (SETQ SEL (MENU-MSELECT (CADDR ITM) (EQ ENABLED T))) + (IF SEL + (SETQ RES (LIST SEL (CAR ITM) *WINDOW-MENU-CODE*)) + (IF (AND *WINDOW-MENU-CODE* + (NOT (ZEROP *WINDOW-MENU-CODE*))) + (SETQ RES + (LIST NIL (CAR ITM) *WINDOW-MENU-CODE*))))))) + (XFLUSH *WINDOW-DISPLAY*) + (OR RES RESB))) +(SETF (GET 'MENU-SET-SELECT 'GLARGUMENTS) + '((MS MENU-SET) (&OPTIONAL BOOLEAN) (REDRAW (LISTOF SYMBOL)))) +(SETF (GET 'MENU-SET-SELECT 'GLFNRESULTTYPE) 'MENU-SELECTION) + + +(DEFUN MENU-SET-ADD-MENU (MS NAME SYM TITLE ITEMS &OPTIONAL OFFSET) + (LET (MENU) + (SETQ MENU + (MENU-CREATE ITEMS TITLE (CADR MS) (CAR OFFSET) (CADR OFFSET) + T T)) + (MENU-INIT MENU) + (IF (NOT OFFSET) + (SETQ OFFSET + (WINDOW-GET-BOX-POSITION (CADR MS) (SEVENTH MENU) + (EIGHTH MENU)))) + (SETF (FIFTH MENU) (CAR OFFSET)) + (SETF (SIXTH MENU) (CADR OFFSET)) + (MENU-SET-ADD-ITEM MS NAME SYM MENU))) +(SETF (GET 'MENU-SET-ADD-MENU 'GLARGUMENTS) + '((MS MENU-SET) (NAME SYMBOL) (SYM SYMBOL) (TITLE STRING) + (ITEMS NIL) (&OPTIONAL VECTOR))) +(SETF (GET 'MENU-SET-ADD-MENU 'GLFNRESULTTYPE) '(LISTOF MENU-SET-ITEM)) + + +(DEFUN MENU-SET-ADD-ITEM (MS NAME SYM MENU) + (SETF (CADDR MS) (NCONC (CADDR MS) (CONS (LIST NAME SYM MENU) NIL)))) +(SETF (GET 'MENU-SET-ADD-ITEM 'GLARGUMENTS) + '((MS MENU-SET) (NAME SYMBOL) (SYM SYMBOL) (MENU MENU))) +(SETF (GET 'MENU-SET-ADD-ITEM 'GLFNRESULTTYPE) '(LISTOF MENU-SET-ITEM)) + + +(DEFUN MENU-SET-REMOVE-ITEMS (MS) (SETF (CADDR MS) NIL)) +(SETF (GET 'MENU-SET-REMOVE-ITEMS 'GLARGUMENTS) '((MS MENU-SET))) +(SETF (GET 'MENU-SET-REMOVE-ITEMS 'GLFNRESULTTYPE) + '(LISTOF MENU-SET-ITEM)) + + +(DEFUN MENU-SET-ADD-PICMENU + (MS NAME SYM TITLE SPEC &OPTIONAL OFFSET NOBOX) + (LET (MENU MAXWIDTH MAXHEIGHT) + (IF (AND SPEC (SYMBOLP SPEC)) (SETQ SPEC (GET SPEC 'PICMENU-SPEC))) + (SETQ MENU + (PICMENU-CREATE-FROM-SPEC SPEC TITLE (CADR MS) (CAR OFFSET) + (CADR OFFSET) T T (NOT NOBOX))) + (SETQ MAXWIDTH + (MAX (IF TITLE (+ 6 (* 9 (LENGTH TITLE))) 0) (CADR SPEC))) + (SETQ MAXHEIGHT (+ (IF TITLE 15 0) (CADDR SPEC))) + (IF (NOT OFFSET) + (SETQ OFFSET + (WINDOW-GET-BOX-POSITION (CADR MS) MAXWIDTH MAXHEIGHT))) + (SETF (FIFTH MENU) (CAR OFFSET)) + (SETF (SIXTH MENU) (CADR OFFSET)) + (MENU-SET-ADD-ITEM MS NAME SYM MENU))) +(SETF (GET 'MENU-SET-ADD-PICMENU 'GLARGUMENTS) + '((MS MENU-SET) (NAME SYMBOL) (SYM SYMBOL) (TITLE STRING) + (SPEC PICMENU-SPEC) (&OPTIONAL VECTOR) (OFFSET BOOLEAN))) +(SETF (GET 'MENU-SET-ADD-PICMENU 'GLFNRESULTTYPE) + '(LISTOF MENU-SET-ITEM)) + + +(DEFUN MENU-SET-ADD-COMPONENT (MS NAME &OPTIONAL OFFSET) + (MENU-SET-ADD-PICMENU MS (MENU-SET-NAME NAME) NAME NIL NAME OFFSET T)) +(SETF (GET 'MENU-SET-ADD-COMPONENT 'GLARGUMENTS) + '((MS MENU-SET) (NAME SYMBOL) (&OPTIONAL VECTOR))) +(SETF (GET 'MENU-SET-ADD-COMPONENT 'GLFNRESULTTYPE) + '(LISTOF MENU-SET-ITEM)) + + +(DEFUN MENU-SET-ADD-BARMENU (MS NAME SYM MENU TITLE &OPTIONAL OFFSET) + (BARMENU-INIT MENU) + (IF (NOT OFFSET) + (SETQ OFFSET + (WINDOW-GET-BOX-POSITION (CADR MS) (SEVENTH MENU) + (EIGHTH MENU)))) + (SETF (FIFTH MENU) (CAR OFFSET)) + (SETF (SIXTH MENU) (CADR OFFSET)) + (MENU-SET-ADD-ITEM MS NAME SYM MENU)) +(SETF (GET 'MENU-SET-ADD-BARMENU 'GLARGUMENTS) + '((MS MENU-SET) (NAME SYMBOL) (SYM SYMBOL) (MENU BARMENU) + (TITLE STRING) (&OPTIONAL VECTOR))) +(SETF (GET 'MENU-SET-ADD-BARMENU 'GLFNRESULTTYPE) + '(LISTOF MENU-SET-ITEM)) + + +(DEFUN MENU-SET-NAME (NM) + (INTERN (SYMBOL-NAME (GENSYM (SYMBOL-NAME NM))))) +(SETF (GET 'MENU-SET-NAME 'GLARGUMENTS) '((NM SYMBOL))) +(SETF (GET 'MENU-SET-NAME 'GLFNRESULTTYPE) 'SYMBOL) + + +(DEFUN MENU-SET-NAMED-ITEM (MS NAME) (ASSOC NAME (CADDR MS))) +(SETF (GET 'MENU-SET-NAMED-ITEM 'GLARGUMENTS) + '((MS MENU-SET) (NAME SYMBOL))) +(SETF (GET 'MENU-SET-NAMED-ITEM 'GLFNRESULTTYPE) 'MENU-SET-ITEM) + + +(DEFUN MENU-SET-NAMED-MENU (MS NAME) + (CADDR (MENU-SET-NAMED-ITEM MS NAME))) +(SETF (GET 'MENU-SET-NAMED-MENU 'GLARGUMENTS) + '((MS MENU-SET) (NAME SYMBOL))) +(SETF (GET 'MENU-SET-NAMED-MENU 'GLFNRESULTTYPE) 'MENU-SET-MENU) + + +(DEFUN MENU-SET-ITEMP (MS NAME ITEMNAME) + (LET ((THISMENU (MENU-SET-NAMED-MENU MS NAME))) + (IF (EQ (FIRST THISMENU) 'MENU) + (SOME #'(LAMBDA (X) + (OR (EQ X ITEMNAME) + (AND (CONSP X) (EQ (CAR X) ITEMNAME)))) + (NTH 13 THISMENU)) + (IF (EQ (FIRST THISMENU) 'PICMENU) + (ASSOC ITEMNAME (CADDDR (NTH 10 THISMENU))))))) +(SETF (GET 'MENU-SET-ITEMP 'GLARGUMENTS) + '((MS MENU-SET) (NAME SYMBOL) (ITEMNAME SYMBOL))) +(SETF (GET 'MENU-SET-ITEMP 'GLFNRESULTTYPE) 'BOOLEAN) + + +(DEFUN MENU-CONNS-NAMED-ITEM (MC NAME) + (MENU-SET-NAMED-ITEM (CADR MC) NAME)) +(SETF (GET 'MENU-CONNS-NAMED-ITEM 'GLARGUMENTS) + '((MC MENU-CONNS) (NAME SYMBOL))) +(SETF (GET 'MENU-CONNS-NAMED-ITEM 'GLFNRESULTTYPE) 'MENU-SET-ITEM) + + +(DEFUN MENU-CONNS-NAMED-MENU (MC NAME) + (MENU-SET-NAMED-MENU (CADR MC) NAME)) +(SETF (GET 'MENU-CONNS-NAMED-MENU 'GLARGUMENTS) + '((MC MENU-CONNS) (NAME SYMBOL))) +(SETF (GET 'MENU-CONNS-NAMED-MENU 'GLFNRESULTTYPE) 'MENU-SET-MENU) + + +(DEFUN MENU-SET-FIND-ITEM (MS POS) + (LET (MITEM) + (DOLIST (MI (CADDR MS)) + (IF (AND (BETWEEN (CAR POS) + (LET ((SELF (CADDR MI))) + (IF (CADDR SELF) (FIFTH SELF) 0)) + (+ (LET ((SELF (CADDR MI))) + (IF (CADDR SELF) (FIFTH SELF) 0)) + (SEVENTH (CADDR MI)))) + (BETWEEN (CADR POS) + (LET ((SELF (CADDR MI))) + (IF (CADDR SELF) (SIXTH SELF) 0)) + (+ (LET ((SELF (CADDR MI))) + (IF (CADDR SELF) (SIXTH SELF) 0)) + (EIGHTH (CADDR MI))))) + (SETQ MITEM MI))) + MITEM)) +(SETF (GET 'MENU-SET-FIND-ITEM 'GLARGUMENTS) + '((MS MENU-SET) (POS VECTOR))) +(SETF (GET 'MENU-SET-FIND-ITEM 'GLFNRESULTTYPE) 'MENU-SET-ITEM) + + +(DEFUN MENU-SET-DELETE-ITEM (MS MI) + (SETF (CADDR MS) (REMOVE MI (CADDR MS)))) +(SETF (GET 'MENU-SET-DELETE-ITEM 'GLARGUMENTS) + '((MS MENU-SET) (MI MENU-SET-ITEM))) +(SETF (GET 'MENU-SET-DELETE-ITEM 'GLFNRESULTTYPE) + '(LISTOF MENU-SET-ITEM)) + + +(DEFUN MENU-SET-MOVE (MS) + (LET (SEL M) + (SETQ SEL (MENU-SET-SELECT MS NIL T)) + (SETQ M (MENU-SET-NAMED-MENU MS (CADR SEL))) + (MENU-REPOSITION M))) + +(DEFUN MENU-MDRAW (M) + (CASE (FIRST M) + (MENU (MENU-DRAW M)) + (PICMENU (PICMENU-DRAW M)) + (BARMENU (BARMENU-DRAW M)) + (TEXTMENU (TEXTMENU-DRAW M)) + (EDITMENU (EDITMENU-DRAW M)) + (T (GLSEND M DRAW)))) + +(DEFUN MENU-MSELECT (M &OPTIONAL ANYCLICK) + (CASE (FIRST M) + (MENU (MENU-SELECT M T)) + (PICMENU (PICMENU-SELECT M T ANYCLICK)) + (BARMENU (BARMENU-SELECT M)) + (TEXTMENU (TEXTMENU-SELECT M T)) + (EDITMENU (EDITMENU-SELECT M T)) + (T (GLSEND M SELECT)))) + +(DEFUN MENU-MITEM-POSITION (M NAME LOC) + (CASE (FIRST M) + (MENU (MENU-ITEM-POSITION M NAME LOC)) + (PICMENU (PICMENU-ITEM-POSITION M NAME LOC)) + (T (GLSEND M ITEM-POSITION NAME LOC)))) + +(DEFUN MENU-SET-DRAW (MS) + (XMAPWINDOW *WINDOW-DISPLAY* (CADADR MS)) + (XFLUSH *WINDOW-DISPLAY*) + (WINDOW-WAIT-EXPOSURE (CADR MS)) + (DOLIST (ITEM (CADDR MS)) (MENU-MDRAW (CADDR ITEM)))) + +(DEFUN MENU-SET-ITEM-POSITION (MS DESC &OPTIONAL LOC) + (LET (M) + (SETQ M (MENU-SET-NAMED-MENU MS (CADR DESC))) + (OR (MENU-MITEM-POSITION M (CAR DESC) LOC) + (MENU-MITEM-POSITION M NIL LOC)))) +(SETF (GET 'MENU-SET-ITEM-POSITION 'GLARGUMENTS) + '((MS MENU-SET) (DESC MENU-PORT) (&OPTIONAL SYMBOL))) +(SETF (GET 'MENU-SET-ITEM-POSITION 'GLFNRESULTTYPE) 'VECTOR) + + +(DEFUN MENU-SET-DRAW-CONN (MS CONN) + (LET (PA PB TMP (DESCA (CAR CONN)) (DESCB (CADR CONN))) + (SETQ PA (MENU-SET-ITEM-POSITION MS DESCA 'CENTER)) + (SETQ PB (MENU-SET-ITEM-POSITION MS DESCB 'CENTER)) + (WHEN (> (CAR PA) (CAR PB)) + (SETQ TMP DESCA) + (SETQ DESCA DESCB) + (SETQ DESCB TMP)) + (SETQ PA (MENU-SET-ITEM-POSITION MS DESCA 'RIGHT)) + (SETQ PB (MENU-SET-ITEM-POSITION MS DESCB 'LEFT)) + (WINDOW-DRAW-CIRCLE-XY (CADR MS) (CAR PA) (CADR PA) 3 NIL) + (WINDOW-DRAW-LINE-XY (CADR MS) (CAR PA) (CADR PA) (CAR PB) + (CADR PB) NIL) + (WINDOW-DRAW-CIRCLE-XY (CADR MS) (CAR PB) (CADR PB) 3 NIL) + (XFLUSH *WINDOW-DISPLAY*))) + +(DEFUN MENU-SET-ADJUST (MS NAME EDGE FROM OFFSET) + (LET (M FROMM PLACE) + (WHEN (SETQ M (MENU-SET-NAMED-ITEM MS NAME)) + (IF FROM + (PROGN + (SETQ FROMM (MENU-SET-NAMED-ITEM MS FROM)) + (SETQ PLACE + (CASE EDGE + (TOP (SIXTH (CADDR FROMM))) + (BOTTOM (+ (SIXTH (CADDR FROMM)) + (EIGHTH (CADDR FROMM)))) + (LEFT (+ (FIFTH (CADDR FROMM)) + (SEVENTH (CADDR FROMM)))) + (RIGHT (FIFTH (CADDR FROMM)))))) + (SETQ PLACE + (CASE EDGE + (TOP (CADDDR (CADR MS))) + ((BOTTOM LEFT) 0) + (RIGHT (FIFTH (CADR MS)))))) + (CASE EDGE + (TOP (SETF (SIXTH (CADDR M)) + (- (- PLACE (EIGHTH (CADDR M))) OFFSET))) + (BOTTOM (SETF (SIXTH (CADDR M)) (+ PLACE OFFSET))) + (LEFT (SETF (FIFTH (CADDR M)) (+ PLACE OFFSET))) + (RIGHT (SETF (FIFTH (CADDR M)) + (- (- PLACE (SEVENTH (CADDR M))) OFFSET))))))) +(SETF (GET 'MENU-SET-ADJUST 'GLARGUMENTS) + '((MS MENU-SET) (NAME SYMBOL) (EDGE SYMBOL) (FROM SYMBOL) + (OFFSET INTEGER))) +(SETF (GET 'MENU-SET-ADJUST 'GLFNRESULTTYPE) 'INTEGER) + + +(DEFUN VECTOR-SNAP (FIXED APPROX &OPTIONAL TOLERANCE) + (OR TOLERANCE (SETQ TOLERANCE 10)) + (IF (< (ABS (- (CAR FIXED) (CAR APPROX))) TOLERANCE) + (LIST (CAR FIXED) (CADR APPROX)) + (IF (< (ABS (- (CADR FIXED) (CADR APPROX))) TOLERANCE) + (LIST (CAR APPROX) (CADR FIXED)) APPROX))) +(SETF (GET 'VECTOR-SNAP 'GLARGUMENTS) + '((FIXED VECTOR) (APPROX VECTOR) (&OPTIONAL NIL))) +(SETF (GET 'VECTOR-SNAP 'GLFNRESULTTYPE) 'VECTOR) + + +(DEFUN MENU-CONNS-CREATE (MS) (LIST 'MENU-CONNS MS NIL)) +(SETF (GET 'MENU-CONNS-CREATE 'GLARGUMENTS) '((MS MENU-SET))) +(SETF (GET 'MENU-CONNS-CREATE 'GLFNRESULTTYPE) 'MENU-CONNS) + + +(DEFUN MENU-CONNS-DRAW (MC) + (MENU-SET-DRAW (CADR MC)) + (DOLIST (C (CADDR MC)) (MENU-SET-DRAW-CONN (CADR MC) C))) + +(DEFUN MENU-CONNS-MOVE (MC) + (MENU-SET-MOVE (CADR MC)) + (XCLEARWINDOW *WINDOW-DISPLAY* (CADR (CADADR MC))) + (XFLUSH *WINDOW-DISPLAY*) + (MENU-CONNS-DRAW MC)) + +(DEFUN MENU-CONNS-REDRAW (MC) + (XCLEARWINDOW *WINDOW-DISPLAY* (CADR (CADADR MC))) + (XFLUSH *WINDOW-DISPLAY*) + (MENU-CONNS-DRAW MC)) + +(DEFUN MENU-CONNS-ADD-CONN (MC) + (LET (SEL SELB CONN) + (SETQ SEL (MENU-SET-SELECT (CADR MC))) + (IF (EQ (CADR SEL) 'BACKGROUND) SEL + (PROGN + (SETQ SELB (MENU-SET-SELECT (CADR MC))) + (WHEN (NOT (EQ (CADR SELB) 'BACKGROUND)) + (SETQ CONN (LIST SEL SELB)) + (MENU-SET-DRAW-CONN (CADR MC) CONN) + (SETF (CADDR MC) (NCONC (CADDR MC) (CONS CONN NIL)))) + NIL)))) +(SETF (GET 'MENU-CONNS-ADD-CONN 'GLARGUMENTS) '((MC MENU-CONNS))) +(SETF (GET 'MENU-CONNS-ADD-CONN 'GLFNRESULTTYPE) 'MENU-SELECTION) + + +(DEFUN MENU-CONNS-NEW-CONN (MC FROMNAME FROMPORT TONAME TOPORT) + (LET (CONN) + (SETQ CONN (LIST (LIST FROMPORT FROMNAME) (LIST TOPORT TONAME))) + (SETF (CADDR MC) (NCONC (CADDR MC) (CONS CONN NIL))))) +(SETF (GET 'MENU-CONNS-NEW-CONN 'GLARGUMENTS) + '((MC MENU-CONNS) (FROMNAME SYMBOL) (FROMPORT SYMBOL) + (TONAME SYMBOL) (TOPORT SYMBOL))) +(SETF (GET 'MENU-CONNS-NEW-CONN 'GLFNRESULTTYPE) + '(LISTOF MENU-SET-CONN)) + + +(DEFUN MENU-CONNS-ADD-ITEM (MC NAME SYM MENU) + (MENU-SET-ADD-ITEM (CADR MC) NAME SYM MENU)) +(SETF (GET 'MENU-CONNS-ADD-ITEM 'GLARGUMENTS) + '((MC MENU-CONNS) (NAME SYMBOL) (SYM SYMBOL) (MENU MENU))) +(SETF (GET 'MENU-CONNS-ADD-ITEM 'GLFNRESULTTYPE) + '(LISTOF MENU-SET-ITEM)) + + +(DEFUN MENU-CONNS-FIND-CONN (MC PT) + (LET (MS LS FOUND RES PA PB TMP DESCA DESCB) + (SETQ LS (LIST (COPY-LIST '(0 0)) (COPY-LIST '(0 0)))) + (SETQ MS (CADR MC)) + (DOLIST (CONN (CADDR MC)) + (UNLESS FOUND + (SETQ DESCA (CAR CONN)) + (SETQ DESCB (CADR CONN)) + (SETQ PA (MENU-SET-ITEM-POSITION MS DESCA 'CENTER)) + (SETQ PB (MENU-SET-ITEM-POSITION MS DESCB 'CENTER)) + (WHEN (> (CAR PA) (CAR PB)) + (SETQ TMP DESCA) + (SETQ DESCA DESCB) + (SETQ DESCB TMP)) + (SETF (CAR LS) (MENU-SET-ITEM-POSITION MS DESCA 'RIGHT)) + (SETF (CADR LS) (MENU-SET-ITEM-POSITION MS DESCB 'LEFT)) + (WHEN (< (ABS (/ (- (* (- (CAADR LS) (CAAR LS)) + (- (CADR PT) (CADAR LS))) + (* (- (CADADR LS) (CADAR LS)) + (- (CAR PT) (CAAR LS)))) + (SQRT (+ (EXPT (- (CAADR LS) (CAAR LS)) 2) + (EXPT (- (CADADR LS) (CADAR LS)) 2))))) + 5) + (SETQ FOUND T) + (SETQ RES CONN)))) + RES)) +(SETF (GET 'MENU-CONNS-FIND-CONN 'GLARGUMENTS) + '((MC MENU-CONNS) (PT VECTOR))) +(SETF (GET 'MENU-CONNS-FIND-CONN 'GLFNRESULTTYPE) 'MENU-SET-CONN) + + +(DEFUN MENU-CONNS-FIND-ITEM (MC PT) (MENU-SET-FIND-ITEM (CADR MC) PT)) +(SETF (GET 'MENU-CONNS-FIND-ITEM 'GLARGUMENTS) + '((MC MENU-CONNS) (PT VECTOR))) +(SETF (GET 'MENU-CONNS-FIND-ITEM 'GLFNRESULTTYPE) 'MENU-SET-ITEM) + + +(DEFUN MENU-CONNS-DELETE-CONN (MC CONN) + (SETF (CADDR MC) (REMOVE CONN (CADDR MC)))) +(SETF (GET 'MENU-CONNS-DELETE-CONN 'GLARGUMENTS) + '((MC MENU-CONNS) (CONN MENU-SET-CONN))) +(SETF (GET 'MENU-CONNS-DELETE-CONN 'GLFNRESULTTYPE) + '(LISTOF MENU-SET-CONN)) + + +(DEFUN MENU-CONNS-DELETE-ITEM (MC MI) + (LET (MS) + (SETQ MS (CADR MC)) + (MENU-SET-DELETE-ITEM MS MI) + (DOLIST (CONN (CADDR MC)) + (IF (OR (EQ (CADAR CONN) (CAR MI)) (EQ (CADADR CONN) (CAR MI))) + (MENU-CONNS-DELETE-CONN MC CONN))))) + +(DEFUN MENU-CONNS-REMOVE-ITEMS (MC) + (MENU-SET-REMOVE-ITEMS (CADR MC)) + (SETF (CADDR MC) NIL)) +(SETF (GET 'MENU-CONNS-REMOVE-ITEMS 'GLARGUMENTS) '((MC MENU-CONNS))) +(SETF (GET 'MENU-CONNS-REMOVE-ITEMS 'GLFNRESULTTYPE) + '(LISTOF MENU-SET-CONN)) + + +(DEFUN MENU-CONNS-CONNECTED-PORTS (MC BOXNAME) + (LET (PORTS) + (DOLIST (CONN (CADDR MC)) + (IF (EQ BOXNAME (CADADR CONN)) (PUSHNEW (CAADR CONN) PORTS) + (IF (EQ BOXNAME (CADAR CONN)) (PUSHNEW (CAAR CONN) PORTS)))) + PORTS)) + +(DEFUN MENU-CONNS-FIND-CONNS (MC BOXNAME PORT) + (LET (RES) + (DOLIST (CONN (CADDR MC)) + (IF (AND (EQ BOXNAME (CADADR CONN)) (EQ PORT (CAADR CONN))) + (SETQ RES (NCONC RES (CONS (CAR CONN) NIL)))) + (IF (AND (EQ BOXNAME (CADAR CONN)) (EQ PORT (CAAR CONN))) + (SETQ RES (NCONC RES (CONS (CADR CONN) NIL))))) + RES)) +(SETF (GET 'MENU-CONNS-FIND-CONNS 'GLARGUMENTS) + '((MC MENU-CONNS) (BOXNAME SYMBOL) (PORT SYMBOL))) +(SETF (GET 'MENU-CONNS-FIND-CONNS 'GLFNRESULTTYPE) '(LISTOF MENU-PORT)) + + +(DEFUN COMPILE-MENU-SET () + (GLCOMPFILES *DIRECTORY* '("glisp/vector.lsp" "X/dwindow.lsp") + '("glisp/menu-set.lsp") "glisp/menu-settrans.lsp" + "glisp/menu-set-header.lsp") + (COMPILE-FILE "glisp/menu-settrans.lsp")) + +(DEFUN COMPILE-MENU-SETB () + (GLCOMPFILES *DIRECTORY* + '("glisp/vector.lsp" "X/dwindow.lsp" "X/dwnoopen.lsp") + '("glisp/menu-set.lsp") "glisp/menu-settrans.lsp" + "glisp/menu-set-header.lsp")) diff --git a/xgcl-2/gcl_pcalc.lsp b/xgcl-2/gcl_pcalc.lsp new file mode 100644 index 0000000..01dfd71 --- /dev/null +++ b/xgcl-2/gcl_pcalc.lsp @@ -0,0 +1,133 @@ +; pcalc.lsp Gordon S. Novak Jr. 20 Oct 94 + +; Pocket calculator implemented using a picmenu. Entry is (pcalc) . + +; Copyright (c) 1994 Gordon S. Novak Jr. and The University of Texas at Austin. + +; See the file gnu.license . + +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 1, or (at your option) +; any later version. + +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +; Written by: Gordon S. Novak Jr., Department of Computer Sciences, +; University of Texas at Austin 78712. novak@cs.utexas.edu + + +(defvar *pcalcw* nil) ; window +(defvar *pcalcm* nil) ; picmenu + +(defun pcalc-draw (w x y) + (let (items item over up) + (window-open w) + (window-clear w) + (window-draw-rcbox-xy *pcalcw* 0 0 170 215 10 2) + (window-draw-rcbox-xy *pcalcw* 10 180 150 25 6) + (setq items '(0 \. = + 1 2 3 - 4 5 6 * 7 8 9 / off ac ce +-)) + (dotimes (i 5) + (setq up (+ 10 (* i 35))) + (dotimes (j 4) + (setq over (+ 10 (* j 40))) + (setq item (pop items)) + (window-printat-xy *pcalcw* item + (+ over 15 (* (if (numberp item) 1 + (length (stringify item))) + -5)) (+ up 3)) + (window-draw-rcbox-xy *pcalcw* over up 28 20 6) )) + (window-force-output) )) + +(defun pcalc-init () + (prog ((n 15)) + (setq *pcalcw* (window-create 170 215 "pcalc" nil nil nil '9x15)) + lp (when (and (> n 0) (null (window-wait-exposure *pcalcw*))) + (sleep 1.0) (decf n) (go lp)) + (setq *pcalcm* + (picmenu-create + '((0 (24 20) (24 16)) + (\. (64 20) (24 16)) + (= (104 20) (24 16)) + (+ (144 20) (24 16)) + (1 (24 55) (24 16)) + (2 (64 55) (24 16)) + (3 (104 55) (24 16)) + (- (144 55) (24 16)) + (4 (24 90) (24 16)) + (5 (64 90) (24 16)) + (6 (104 90) (24 16)) + (* (144 90) (24 16)) + (7 (24 125) (24 16)) + (8 (64 125) (24 16)) + (9 (104 125) (24 16)) + (/ (144 125) (24 16)) + (off (24 160) (24 16)) + (ac (64 160) (24 16)) + (ce (104 160) (24 16)) + (+- (144 160) (24 16))) + 170 215 'pcalc-draw nil nil *pcalcw* 0 0 t t)) )) + +(defun pcalc-display (val) + (let (str) + (window-erase-area-xy *pcalcw* 15 182 140 20) + (setq str (if (integerp val) + (princ-to-string val) + (format nil "~8,4F" val))) + (window-printat-xy *pcalcw* str (- 131 (* 9 (length str))) 185) + (window-force-output) )) + + +(defun pcalc () + (prog (key (ent 0) (ac 0) decpt lastop lastkey) + (or *pcalcw* (pcalc-init)) + (pcalc-draw *pcalcw* 0 0) + (pcalc-display ent) + lp (setq key (picmenu-select *pcalcm*)) + (if (numberp key) + (progn (when (eq lastkey '=) + (setq ent 0) (setq decpt nil) (setq ac 0) (setq lastop nil)) + (if decpt + (progn (setq ent (+ ent (* key decpt))) + (setq decpt (/ decpt 10.0)) ) + (setq ent (+ key (* ent 10))) ) + (pcalc-display ent)) + (case key + ((+ - * /) + (if lastop + (progn (setq ac (if (eq lastop '/) + (/ (float ac) ent) + (funcall lastop ac ent))) + (pcalc-display ac)) + (setq ac ent)) + (setq lastop key) + (setq ent 0) + (setq decpt nil)) + (= (if lastop + (progn (setq ent (if (eq lastop '/) + (/ (float ac) ent) + (funcall lastop ac ent))) + (pcalc-display ent))) + (setq lastop nil)) + (\. (when (eq lastkey '=) + (setq ent 0) (setq ac 0) (setq lastop nil)) + (setq decpt 0.1) + (setq ent (float ent)) + (pcalc-display ent)) + (+- (setq ent (- ent)) + (pcalc-display ent)) + (ce (setq ent 0) (setq decpt nil) (pcalc-display ent)) + (ac (setq ent 0) (setq decpt nil) (setq ac 0) (setq lastop nil) + (pcalc-display ent)) + (off (window-close *pcalcw*) + (return nil)) ) ) + (setq lastkey key) + (go lp) )) + diff --git a/xgcl-2/gcl_sysinit.lsp b/xgcl-2/gcl_sysinit.lsp new file mode 100644 index 0000000..e77963a --- /dev/null +++ b/xgcl-2/gcl_sysinit.lsp @@ -0,0 +1,69 @@ +; Copyright (c) 1994 William F. Schelter + +; See the files gnu.license and dec.copyright . + +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 1, or (at your option) +; any later version. + +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +; Some of the files that interface to the Xlib are adapted from DEC/MIT files. +; See the file dec.copyright for details. + +(in-package :XLIB) + +;; This file is used for defining the C function user_init, to run the +;; initialization code from a list of files in *files*. These files +;; should have been compiled with (compile-file "foo.lsp" :system-p t) +;; and have been linked into the image. It presumes the .o files +;; are in the current directory, and the files *files* are in the proper +;; order to be loaded. + +;;define a function USER::USER-INIT, which will run the init code for a set +;;of files which are linked into an image. + +(clines "#define init_or_load(fn,file) do {extern void fn(void); gcl_init_or_load1(fn,file);} while(0)") +(clines "static void") +(clines "load1(char *x) {") +(clines "printf(\"loading %s\\n\",x);") +(clines "fflush(stdout);") +(clines "load(x);") +(clines "}") + +#. +(let ((files *files*)) + (declare (special object-path)) + (with-open-file (st "maxobjs" :direction :output) + `(progn + (clines "object user_init() {") + (clines "load1(\"../xgcl-2/sysdef.lisp\");") + ,@(sloop::sloop for x in files + for f = (substitute #\_ #\- x) + for ff = (namestring (merge-pathnames (make-pathname :type "o") (pathname (format nil "~a.lsp" x)))) + do (princ ff st) (princ " " st) + collect + `(clines ,(Format nil "init_or_load(init_~a,\"~a\");" (string-downcase f) ff)) + finally (terpri st) + )) + + )) + +(clines "return Cnil;}") + +;; invoke this to initialize maxima. + +;; make this if you dont want the invocation done automatically. +;(defentry user::user-init () "user_init") + + + + diff --git a/xgcl-2/gcl_tohtml.lsp b/xgcl-2/gcl_tohtml.lsp new file mode 100644 index 0000000..48ae538 --- /dev/null +++ b/xgcl-2/gcl_tohtml.lsp @@ -0,0 +1,502 @@ +; tohtml.lsp Gordon S. Novak Jr. ; 13 Jan 06 + +; Translate LaTex file to HTML web pages + +; Make table of contents for LaTex files of slides + +; Copyright (c) 2006 Gordon S. Novak Jr. and The University of Texas at Austin. + +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 2 of the License, or +; (at your option) any later version. + +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + +; 21 Aug 00; 07 Sep 00; 11 Sep 00; 07 Dec 00; 24 Jul 02; 25 Jul 02; 29 Jul 02 +; 12 Feb 03; 28 Aug 03; 29 Aug 03; 15 Jan 04; 11 May 04; 29 Aug 05 + +; This program converts a LaTeX file into one or more HTML files. +; The HTML file may need some minor hand editing. + +; The program produces a new file in response to \pagebreak +; and puts in links to other pages. + +; I have used it to put class lecture slides on the web; +; see http://www.cs.utexas.edu/users/novak/cs375contents.html +; See the README for notes on how this is all created. +; See also the file index.lsp for making indexes. + +; To use: +; Start Lisp: e.g. /p/bin/gcl +; (load "tohtml.lsp") + +; To translate LaTeX to HTML web pages: +; (tohtml "myfile.tex" "myprefix" ) +; where "myfile.tex" = LaTeX file +; "myprefix" = file name prefix for HTML files +; = number of first page if not 1 +; \setcounter{page} will override this + +; To make contents: +; The contents program looks for header lines, which +; in my files look something like: +; \begin{center} {\bf Lexical Analysis} \end{center} + +; (makecont "myfile.tex" ) +; where "myfile.tex" = LaTeX file +; = number of first page if not 1 +; = t for html output, nil for LaTeX output + + +; 22 Aug 97; 28 Apr 00; 07 Aug 00; 08 Aug 00; 17 Aug 00; 18 Aug 00; 07 Dec 00 +; 24 Jul 02; 26 Aug 03; 28 Aug 03; 11 Jan 05 +; Make a contents list for a file of LaTex slides +; n is first page number: required if first page is not 1. +; html is prefix string to make html contents +(in-package 'xlib) + +(defvar *line*) +(defvar *ptr*) +(defvar *lng*) + +(defun makecont (filenm &optional (n 1) html) + (let (line ptr lng done depth pagebr lastbr doit (first t)) + (with-open-file (infile filenm :direction :input + :if-does-not-exist nil) + (while (not (or (null infile) + (eq (setq line (read-line infile nil 'zzeofvalue)) + 'zzeofvalue) )) + (setq lng (length line)) + (setq lastbr pagebr) + (setq pagebr + (and (>= lng 10) + (string= line "\\pagebreak" :end1 10))) + (if (and pagebr (not first)) (incf n)) + (when (and (> lng 18) + (string= line "\\setcounter{page}{" :end1 18)) + (setq *line* line) + (setq *lng* lng) + (setq *ptr* 18) + (setq n (parse-int))) + (when (and (> lng 20) + (string= line "\\addtocounter{page}{" :end1 20)) + (setq *line* line) + (setq *lng* lng) + (setq *ptr* 20) + (setq n (+ n (parse-int))) ) + (setq doit nil) + (if (and (> lng 30) + (or (string= line "\\begin{center} {\\bf " :end1 20) + (string= line "\\begin{center} {\\bf " :end1 21))) + (progn (setq doit t) (setq ptr 20)) ) + (if (and (> lng 6) lastbr + (string= line "{\\bf " :end1 5)) + (progn (setq doit t) (setq ptr 5)) ) + (when doit + (setq first nil) + (if html + (format t "~D. " html n n)) + (setq lng (length line)) + (setq done nil) + (setq depth 0) + (if (char= (char line ptr) #\Space) (incf ptr)) + (while (and (< ptr lng) (not done)) + (if (char= (char line ptr) #\\) + (if (string= line "\\index" :start1 ptr :end1 (min lng (+ ptr 6))) + (progn (while (and (< ptr lng) + (not (char= (char line ptr) #\}))) + (incf ptr)) + (incf ptr)))) + (if (char= (char line ptr) #\{) + (progn (incf depth) (princ (char line ptr))) + (if (char= (char line ptr) #\}) + (if (> depth 0) + (progn (decf depth) (princ (char line ptr))) + (setq done t)) + (princ (char line ptr))) ) + (incf ptr)) + (if html + (format t "

    ~%") + (format t "~60T& ~D \\\\~%" n)) ) ) ) )) + +(defvar *prefix* "") +(defvar *feof* nil) +(defvar *done* nil) +(defvar *pagenumber* 0) +(defvar *firstpage* 1) +(defvar *lastpage* 999) +(defvar *center* nil) +(defvar *modestack* nil) +(defvar *verbatim* nil) +(defvar *ignore* t) +(defvar *specials* nil) +; ¬in &there4 &nsub © ° +(setq *specials* '(("pm" "±") ("cdot" "·") ("cap" "&cap") + ("cup" "&cup") ("vee" "&or") ("wedge" "&and") ("leq" "&le") ("geq" "&ge") + ("subset" "&sub") ("subseteq" "&sube") ("supset" "&sup") + ("supseteq" "&supe") ("in" "&isin") ("perp" "&perp") ("cong" "&cong") + ("sim" "&tilde") ("neq" "&ne") ("mid" "|") ("leftarrow" "&larr") + ("rightarrow" "&rarr") ("leftrightarrow" "&harr") ("Leftarrow" "&lArr") + ("Rightarrow" "&rArr") ("Leftrightarrow" "&hArr") ("uparrow" "&uarr") + ("downarrow" "&darr") ("surd" "&radic ") ("emptyset" "&empty") + ("forall" "&forall") ("exists" "&exist") ("neg" "¬") ("Box" "□") + ("models" "⊨") ("vdash" "⊢") + ("filledBox" "■") ("sum" "&sum") ("prod" "&prod") ("int" "&int") + ("infty" "&infin") ("times" "X") ("sqrt" "&radic ") ("ll" "< < ") + ("alpha" "&alpha") ("beta" "&beta") ("gamma" "&gamma") ("delta" "&delta") + ("epsilon" "&epsilon") ("zeta" "&zeta") ("eta" "&eta") ("theta" "&theta") + ("iota" "&iota") ("kappa" "&kappa") ("lambda" "&lambda") ("mu" "&mu") + ("nu" "&nu") ("xi" "&xi") ("pi" "&pi") ("rho" "&rho") ("sigma" "&sigma") + ("tau" "&tau") ("upsilon" "&upsilon") ("phi" "&phi") ("chi" "&chi") + ("psi" "&psi") ("omega" "&omega") + ("Alpha" "&Alpha") ("Beta" "&Beta") ("Gamma" "&Gamma") ("Delta" "&Delta") + ("Epsilon" "&Epsilon") ("Zeta" "&Zeta") ("Eta" "&Eta") ("Theta" "&Theta") + ("Iota" "&Iota") ("Kappa" "&Kappa") ("Lambda" "&Lambda") ("Mu" "&Mu") + ("Nu" "&Nu") ("Xi" "&Xi") ("Pi" "&Pi") ("Rho" "&Rho") ("Sigma" "&Sigma") + ("Tau" "&Tau") ("Upsilon" "&Upsilon") ("Phi" "&Phi") ("Chi" "&Chi") + ("Psi" "&Psi") ("Omega" "&Omega") ("vert" "|") +) ) + +; 28 Apr 00; 07 Aug 00 +; Translate a file of LaTex slides to HTML +; prefix is a prefix string for output files +; pagenumber is first page number. +(defun tohtml (filenm prefix &optional (pagenumber 1)) + (let (c) + (setq *pagenumber* pagenumber) + (setq *prefix* (stringify prefix)) + (setq *feof* nil) + (setq *ignore* t) + (setq *center* nil) + (setq *modestack* nil) + (setq *verbatim* nil) + (with-open-file (infile filenm :direction :input :if-does-not-exist nil) + ; skip initial stuff + (while (and *ignore* + (not (or (null infile) + (eq (setq *line* (read-line infile nil 'zzeofvalue)) + 'zzeofvalue) ))) + (setq *lng* (length *line*)) + (setq *ptr* 0) + (while (< *ptr* *lng*) + (setq c (char *line* *ptr*)) + (incf *ptr*) + (if (and (char= c #\%) (not *verbatim*)) + (flushline) + (if (char= c #\\) + (if (alpha-char-p (safe-char)) + (docommand nil) ) ) ) ) ) + (while (not *feof*) (dohtml infile)) ) )) + +; 08 Aug 00; 18 Aug 00; 21 Aug 00; 07 Sep 00; 24 Jul 02; 25 Jul 02; 13 Jan 06 +; Process input to produce one .html file +(defvar c) +(defun dohtml (infile) + (let (c) + (setq *done* nil) + (with-open-file (outfile (concatenate 'string *prefix* + (stringify *pagenumber*) ".html") + :direction :output :if-exists :supersede) + (princ " " outfile) + (princ *prefix* outfile) + (princ " p. " outfile) + (princ (stringify *pagenumber*) outfile) + (princ " " outfile) + (terpri outfile) + (princ "" outfile) (terpri outfile) + (terpri outfile) + (while (not (or *done* *feof* + (setq *feof* + (eq (setq *line* (read-line infile nil 'zzeofvalue)) + 'zzeofvalue)))) + (doline outfile) + (terpri outfile) ) + ; *pagenumber* is too large by 1 at this point... + (if *feof* (incf *pagenumber*)) + (format outfile + "Contents   ~%" + *prefix*) + (if (>= *pagenumber* (+ *firstpage* 11)) + (format outfile "Page-10   ~%" + *prefix* (- *pagenumber* 11))) + (if (>= *pagenumber* (+ *firstpage* 2)) + (format outfile "Prev   ~%" + *prefix* (- *pagenumber* 2))) + (if (<= *pagenumber* *lastpage*) + (format outfile "Next   ~%" + *prefix* *pagenumber*)) + (if (<= *pagenumber* (- *lastpage* 9)) + (format outfile "Page+10   ~%" + *prefix* (+ *pagenumber* 9))) + (format outfile + "Index   ~%" *prefix*) + (princ "" outfile) (terpri outfile) + ) + )) + +; 13 Jan 06 +; process *line* +(defun doline (outfile) + (let () + (setq *lng* (length *line*)) + (setq *ptr* 0) + (if (and (= *lng* 0) (not *verbatim*)) + (princ "

    " outfile)) + (while (< *ptr* *lng*) + (setq c (char *line* *ptr*)) + (incf *ptr*) + (if (and (char= c #\%) (not *verbatim*)) + (flushline) + (if (char= c #\\) + (if (alpha-char-p (setq c (safe-char))) + (docommand outfile) + (if (char= c #\\) + (progn (termline outfile) (incf *ptr*)) + (if (char= c #\/) + (progn (princ " " outfile) (incf *ptr*)) + (if (char= c #\[) + (progn (pushfont '$ outfile) (incf *ptr*)) + (if (char= c #\]) + (progn (popenv outfile) (incf *ptr*)) + (progn (if *verbatim* (princ #\\ outfile)) + (princ c outfile) (incf *ptr*))))))) + (if (char= c #\&) + (princ "" outfile) + (if (char= c #\{) + (if *verbatim* + (princ #\{ outfile) + (pushenv nil)) + (if (char= c #\}) + (if *verbatim* + (princ #\} outfile) + (popenv outfile)) + (if (and (char= c #\$) (not *verbatim*)) + (if (eq (car *modestack*) '$) + (popenv outfile) + (pushfont '$ outfile)) + (if (and (or (char= c #\^) (char= c #\_)) + (eq (car *modestack*) '$)) + (progn + (pushfont (if (char= c #\^) 'sup 'sub) outfile) + (searchfor #\{)) + (princ (if (char= c #\>) "> " + (if (char= c #\<) "< " + c)) + outfile))))))))) )) + +; 24 Jul 02; 25 Jul 02; 29 Jul 02; 12 Feb 03; 28 Aug 03 +(defun docommand (outfile) + (let (wordstring word subword termch done tmp c pair (saveptr (1- *ptr*))) + (setq wordstring (car (parse-word nil))) + (setq word (intern (string-upcase wordstring))) + (case word + ((documentstyle pagestyle setlength hyphenpenalty sloppy + large) + (flushline)) + (setcounter (searchfor #\{) + (setq subword (intern (car (parse-word t)))) + (when (eq subword 'page) + (searchfor #\{) + (setq *pagenumber* (1- (parse-int))) ; assumes pagebreak + (flushline)) ) + (addtocounter (searchfor #\{) + (setq subword (intern (car (parse-word t)))) + (when (eq subword 'page) + (searchfor #\{) + (setq *pagenumber* (+ *pagenumber* (parse-int))) + (flushline)) ) + (includegraphics (searchfor #\{) (searchforalpha) + (setq done nil) + (while (not done) + (setq tmp (parse-word nil)) + (if (char= (cadr tmp) #\}) + (setq done t) + (if (char= (cadr tmp) #\.) + (progn (setq done t) + (princ "" outfile) + (terpri outfile) + (flushline) ) + (incf *ptr*))))) + (begin (searchfor #\{) + (setq subword (intern (car (parse-word t)))) + (searchfor #\}) + ; (format t "subword = ~s~%" subword) + (case subword + (document (setq *ignore* nil)) + (center (pushenv 'center)) + (itemize (princ "

      " outfile) (terpri outfile)) + (enumerate (princ "
        " outfile) (terpri outfile)) + (verbatim (princ "
        " outfile) (terpri outfile)
+		    (setq *verbatim* t))
+	  (tabular (dotabular outfile))
+	  ((quotation abstract quote)
+	    (princ "
        " outfile) (terpri outfile))
+	  ))
+      (end (searchfor #\{)
+	(setq subword (intern (car (parse-word t))))
+	(searchfor #\})
+	(case subword
+	  (document (setq *feof* t))
+	  (center (popenv outfile))
+	  (itemize (princ "
    " outfile) (terpri outfile)) + (enumerate (princ "" outfile) (terpri outfile)) + (verbatim (princ "" outfile) (terpri outfile) + (setq *verbatim* nil)) + (tabular (princ "" outfile) (terpri outfile) + (popenv outfile)) + ((quotation abstract quote) + (princ "" outfile) (terpri outfile)) + )) + (item (princ "
  • " outfile)) + (pagebreak (setq *done* t) (incf *pagenumber*)) + ((bf tt em it) (pushfont word outfile)) + ((title section subsection subsubsection paragraph) + (searchfor #\{) + (pushfont (cadr (assoc word '((title h1) (section h2) + (subsection h3) (subsubsection h4) + (paragraph b)))) + outfile)) + ((vspace vspace*) (searchfor #\}) + (princ "

    " outfile) (terpri outfile)) + ((hspace hspace*) (searchfor #\}) + (dotimes (i 8) (princ " " outfile))) + ((index) (searchfor #\})) ; ignore and consume + (verb (setq termch (char *line* *ptr*)) + (incf *ptr*) + (pushfont 'tt outfile) + (xferchars outfile termch) + (popenv outfile) ) + ((cite bibitem) (searchfor #\{) + (princ "[" outfile) + (xferchars outfile #\}) + (princ "]" outfile) ) + (footnote (searchfor #\{) + (princ "[" outfile) + (pushenv 'footnote)) + (t (if *verbatim* + (while (< saveptr *ptr*) + (princ (char *line* saveptr) outfile) + (incf saveptr)) + (if (setq pair (assoc wordstring *specials* :test #'string=)) + (princ (cadr pair) outfile)) ) ) ) )) + +; push a new item on the mode stack +(defun pushenv (item) + (if (and *modestack* (eq (car *modestack*) nil)) + (setf (car *modestack*) item) + (push item *modestack*))) + +; 24 Jul 02; 25 Jul 02 +(defun popenv (outfile) + (let ((item (pop *modestack*)) new) + (setq new (cadr (assoc item '((em i) (bf b) (it i) ($ i))))) + (case item + ((bf tt it em $ h1 h2 h3 h4 sub sup) + (princ "" outfile)) + (footnote (princ "]" outfile)) + ) + item)) + +(defun pushfont (word outfile) + (let ((new (cadr (assoc word '((em i) (bf b) (it i) ($ i)))))) + (pushenv word) + (princ "<" outfile) (princ (or new word) outfile) + (princ ">" outfile) )) + +; transfer chars to output until termch +(defun xferchars (outfile termch) + (let (done) + (while (and (< *ptr* *lng*) (not done)) + (setq c (char *line* *ptr*)) + (incf *ptr*) + (if (char= c termch) + (setq done t) + (princ c outfile)) ) )) + +(defun dotabular (outfile) + (let ((ncols 0) done) + (searchfor #\{) + (while (and (< *ptr* *lng*) (not done)) + (setq c (char *line* *ptr*)) + (incf *ptr*) + (if (char= c #\}) + (setq done t) + (if (or (char= c #\l) (char= c #\r) (char= c #\c)) + (incf ncols))) ) + (princ "" outfile) + (terpri outfile) + (princ "" outfile) + (terpri outfile) + (princ "
    " outfile) + (pushenv 'table) + )) + +(defun termline (outfile) + (if (eq (car *modestack*) 'table) + (progn (princ "
    " outfile)) + (progn (princ "
    " outfile) (terpri outfile) ))) + +(defun safe-char () + (if (< *ptr* *lng*) + (char *line* *ptr*) + #\Space)) + +; Parse a word of alpha/num characters +; Returns ("word" ch) where ch is the terminating character +(defun parse-word (upper) + (let (c res) + (while (and (< *ptr* *lng*) + (or (alpha-char-p (setq c (char *line* *ptr*))) + (and res (digit-char-p c)) + (char= c #\*))) + (push (if upper (char-upcase c) c) res) + (incf *ptr*)) + (if res (list (coerce (nreverse res) 'string) + (and (not (alpha-char-p c)) c))) )) + +(defun searchfor (ch) + (let (c) + (while (and (< *ptr* *lng*) + (setq c (char *line* *ptr*)) + (not (char= ch c))) + (incf *ptr*)) + (if (and c (char= ch c)) (incf *ptr*)) + c)) + +(defun searchforalpha () + (while (and (< *ptr* *lng*) + (not (alpha-char-p (char *line* *ptr*)))) + (incf *ptr*))) + +(defun flushline () (setq *lng* 0)) + +(defun stringify (x) + (cond ((stringp x) x) + ((symbolp x) (symbol-name x)) + (t (princ-to-string x)))) + +; Parse an integer +(defun parse-int () + (let (c (n 0) digit found) + (while (and (< *ptr* *lng*) + (setq digit (digit-char-p + (setq c (char *line* *ptr*))))) + (setq found (or found digit)) + (setq n (+ (* n 10) digit)) + (incf *ptr*)) + (if found n) )) diff --git a/xgcl-2/general-c.c b/xgcl-2/general-c.c new file mode 100644 index 0000000..1dd207a --- /dev/null +++ b/xgcl-2/general-c.c @@ -0,0 +1,65 @@ +/* general-c.c Hiep Huu Nguyen 24 Jun 06 */ +/* 27 Aug 92; 24 Jan 06; 22 Jun 06 */ +/* ; Copyright (c) 1994 Hiep Huu Nguyen and The University of Texas at Austin. + +; See the files gnu.license and dec.copyright . + +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 1, or (at your option) +; any later version. + +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +; Some of the files that interface to the Xlib are adapted from DEC/MIT files. +; See the file dec.copyright for details. */ + +/* 24 Jan 06: edited by G. Novak to remove vertex_array functions, + remove includes, change function arg lists to new form */ +/* 22 Jun 06: edited by G. Novak to be compatible with 64-bit machines */ + +#include +#define fixnum long +fixnum char_array(int size) { + return ((fixnum) calloc (size, sizeof(char))); +} + +char char_pos (char* array, int pos) { + return (array[pos]); +} + +void set_char_array (char* array, int pos, char val) { + array[pos] = val; +} + +fixnum int_array(int size) { + return ((fixnum) calloc (size, sizeof(int))); +} + +int int_pos (int* array, int pos) { + return (array[pos]); +} + +void set_int_array (int* array, int pos, int val) { + array[pos] = val; +} + +fixnum fixnum_array(int size) { + return ((fixnum) calloc (size, sizeof(fixnum))); +} + +fixnum fixnum_pos (fixnum* array, int pos) { + return (array[pos]); +} + +void set_fixnum_array (fixnum* array, int pos, fixnum val) { + array[pos] = val; +} + diff --git a/xgcl-2/gnu.license b/xgcl-2/gnu.license new file mode 100644 index 0000000..9a17037 --- /dev/null +++ b/xgcl-2/gnu.license @@ -0,0 +1,249 @@ + + GNU GENERAL PUBLIC LICENSE + Version 1, February 1989 + + Copyright (C) 1989 Free Software Foundation, Inc. + 675 Mass Ave, Cambridge, MA 02139, USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The license agreements of most software companies try to keep users +at the mercy of those companies. By contrast, our General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. The +General Public License applies to the Free Software Foundation's +software and to any other program whose authors commit to using it. +You can use it for your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Specifically, the General Public License is designed to make +sure that you have the freedom to give away or sell copies of free +software, that you receive source code or can get it if you want it, +that you can change the software or use pieces of it in new free +programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of a such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must tell them their rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any program or other work which +contains a notice placed by the copyright holder saying it may be +distributed under the terms of this General Public License. The +"Program", below, refers to any such program or work, and a "work based +on the Program" means either the Program or any work containing the +Program or a portion of it, either verbatim or with modifications. Each +licensee is addressed as "you". + + 1. You may copy and distribute verbatim copies of the Program's source +code as you receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice and +disclaimer of warranty; keep intact all the notices that refer to this +General Public License and to the absence of any warranty; and give any +other recipients of the Program a copy of this General Public License +along with the Program. You may charge a fee for the physical act of +transferring a copy. + + 2. You may modify your copy or copies of the Program or any portion of +it, and copy and distribute such modifications under the terms of Paragraph +1 above, provided that you also do the following: + + a) cause the modified files to carry prominent notices stating that + you changed the files and the date of any change; and + + b) cause the whole of any work that you distribute or publish, that + in whole or in part contains the Program or any part thereof, either + with or without modifications, to be licensed at no charge to all + third parties under the terms of this General Public License (except + that you may choose to grant warranty protection to some or all + third parties, at your option). + + c) If the modified program normally reads commands interactively when + run, you must cause it, when started running for such interactive use + in the simplest and most usual way, to print or display an + announcement including an appropriate copyright notice and a notice + that there is no warranty (or else, saying that you provide a + warranty) and that users may redistribute the program under these + conditions, and telling the user how to view a copy of this General + Public License. + + d) You may charge a fee for the physical act of transferring a + copy, and you may at your option offer warranty protection in + exchange for a fee. + +Mere aggregation of another independent work with the Program (or its +derivative) on a volume of a storage or distribution medium does not bring +the other work under the scope of these terms. + + 3. You may copy and distribute the Program (or a portion or derivative of +it, under Paragraph 2) in object code or executable form under the terms of +Paragraphs 1 and 2 above provided that you also do one of the following: + + a) accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of + Paragraphs 1 and 2 above; or, + + b) accompany it with a written offer, valid for at least three + years, to give any third party free (except for a nominal charge + for the cost of distribution) a complete machine-readable copy of the + corresponding source code, to be distributed under the terms of + Paragraphs 1 and 2 above; or, + + c) accompany it with the information you received as to where the + corresponding source code may be obtained. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form alone.) + +Source code for a work means the preferred form of the work for making +modifications to it. For an executable file, complete source code means +all the source code for all modules it contains; but, as a special +exception, it need not include source code for modules which are standard +libraries that accompany the operating system on which the executable +file runs, or for standard header files or definitions files that +accompany that operating system. + + 4. You may not copy, modify, sublicense, distribute or transfer the +Program except as expressly provided under this General Public License. +Any attempt otherwise to copy, modify, sublicense, distribute or transfer +the Program is void, and will automatically terminate your rights to use +the Program under this License. However, parties who have received +copies, or rights to use copies, from you under this General Public +License will not have their licenses terminated so long as such parties +remain in full compliance. + + 5. By copying, distributing or modifying the Program (or any work based +on the Program) you indicate your acceptance of this license to do so, +and all its terms and conditions. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the original +licensor to copy, distribute or modify the Program subject to these +terms and conditions. You may not impose any further restrictions on the +recipients' exercise of the rights granted herein. + + 7. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of the license which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +the license, you may choose any version ever published by the Free Software +Foundation. + + 8. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + Appendix: How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to humanity, the best way to achieve this is to make it +free software which everyone can redistribute and change under these +terms. + + To do so, attach the following notices to the program. It is safest to +attach them to the start of each source file to most effectively convey +the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + + Copyright (C) 19yy + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 1, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) 19xx name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the +appropriate parts of the General Public License. Of course, the +commands you use may be called something other than `show w' and `show +c'; they could even be mouse-clicks or menu items--whatever suits your +program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + program `Gnomovision' (a program to direct compilers to make passes + at assemblers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +That's all there is to it! diff --git a/xgcl-2/makefile b/xgcl-2/makefile new file mode 100644 index 0000000..2353b0f --- /dev/null +++ b/xgcl-2/makefile @@ -0,0 +1,35 @@ +-include ../makedefs + + +all: objects #docs + +objects: $(LISP) + echo '(load "sysdef.lisp")(xlib::compile-xgcl)' | $(LISP) + +saved_xgcl: $(LISP) + echo '(load "sysdef.lisp")(xlib::compile-xgcl)(xlib::save-xgcl "$@")' | $(LISP) + +docs: dwdoc/dwdoccontents.html dwdoc.pdf + +dwdoc/dwdoccontents.html: $(LISP) + mkdir -p $(@D) && \ + cd $(@D) && \ + echo '(load "../sysdef.lisp")(in-package :xlib)(defmacro while (test &rest forms) `(loop (unless ,test (return)) ,@forms))(load "../gcl_tohtml.lsp")(load "../gcl_index.lsp")(tohtml "../dwdoc.tex" "dwdoc")(with-open-file (s "dwdoccontents.html" :direction :output) (let ((*standard-output* s)) (xlib::makecont "../dwdoc.tex" 1 "dwdoc")))(with-open-file (s "dwdocindex.html" :direction :output) (let ((*standard-output* s)) (xlib::printindex indexdata "dwdoc")))' | ../$< + + +dwdoc.pdf: dwdoc.tex + pdflatex $< + +clean: + rm -f *.o *.data saved_* cmpinclude.h dwdoc.aux dwdoc.log gmon.out + rm -f gcl*c gcl*h gcl*data gcl_xrecompile* user-init* + +clean-docs: + rm -rf dwdoc dwdoc.pdf + +install: + -mkdir -p $(DESTDIR)$(INFO_DIR)../doc + -cp -r dwdoc $(DESTDIR)$(INFO_DIR)../doc + -cp *tex *.pdf $(DESTDIR)$(INFO_DIR)../doc + +#.INTERMEDIATE: saved_xgcl diff --git a/xgcl-2/sysdef.lisp b/xgcl-2/sysdef.lisp new file mode 100644 index 0000000..a60a607 --- /dev/null +++ b/xgcl-2/sysdef.lisp @@ -0,0 +1,75 @@ +; Copyright (c) 1994 William F. Schelter + +; See the files gnu.license and dec.copyright . + +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation; either version 1, or (at your option) +; any later version. + +; This program is distributed in the hope that it will be useful, +; but WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +; GNU General Public License for more details. + +; You should have received a copy of the GNU General Public License +; along with this program; if not, write to the Free Software +; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +; Some of the files that interface to the Xlib are adapted from DEC/MIT files. +; See the file dec.copyright for details. + +(make-package :XLIB) +(in-package :XLIB) +(sys::use-package '(:lisp :system :sys)) + +(defvar *files* '( "gcl_Xlib" + "gcl_Xutil" + "gcl_X" + "gcl_XAtom" + "gcl_defentry_events" + "gcl_Xstruct" + "gcl_XStruct_l_3" + "gcl_general" + "gcl_keysymdef" + "gcl_X10" + "gcl_Xinit" + "gcl_dwtrans" + "gcl_tohtml" + "gcl_index" +; "gcl_sysinit" + )) + + +(defun compile-xgcl() + (mapc (lambda (x) + (let ((x (concatenate 'string compiler::*cc* " -I../h " (namestring x)))) + (unless (zerop (system x)) + (error "compile failure: ~s~%" x)))) + (directory "*.c")) + (mapc (lambda (x) + (compile-file (format nil "~a.lsp" x) :system-p t)) *files*)) + + +(defun load-xgcl() + (mapcar (lambda (x) (load (format nil "~a.o" x))) *files*)) + +(defun load-xgcl-interp() + (mapcar (lambda (x) (load (format nil "~a.lsp" x))) *files*)) + +(defun save-xgcl (pn) + (let* ((x (mapcar (lambda (x) (probe-file (concatenate 'string x ".o"))) *files*)) + (y (directory "*.o")) + (z (set-difference y x :test 'equal))) + (compiler::link x (namestring pn) (format nil "(load ~s)(mapc 'load '~s)" "sysdef.lisp" x) + (reduce (lambda (&rest xy) (when xy (concatenate 'string (namestring (car xy)) " " (cadr xy)))) z + :initial-value " -lXmu -lXt -lXext -lXaw -lX11" :from-end t) nil))) + + + + + + + + + diff --git a/xgcl-2/version b/xgcl-2/version new file mode 100644 index 0000000..0cfbf08 --- /dev/null +++ b/xgcl-2/version @@ -0,0 +1 @@ +2 -- 2.30.2